Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJPDCLU

PSJPDCLU.m

Go to the documentation of this file.
PSJPDCLU ;BIR/MHA/MC - PADE ORDER ; 10/28/15 9:31am
 ;;5.0;INPATIENT MEDICATIONS;**317,337**;16 DEC 97;Build 9
 ;Reference to ^PS(50.7 supported by DBIA 2180
 ;Reference to ^PS(50.606 supported by DBIA 2174
 ;Reference to ^PS(50.607 supported by DBIA 2221
 ;Reference to ^PS(51.2 supported by DBIA 2178
 ;Reference to ^PS(52.6 supported by DBIA 1231
 ;Reference to ^PS(52.7 supported by DBIA 2173
 ;Reference to ^PSDRUG supported by DBIA 2192
 ;Reference to $$PROD2^PSNAPIS supported by DBIA 2531
 ;Reference to ^ORD(101 supported by DBIA #872
 ;Reference to ^DIC(42 supported by DBIA 10039
 ;Reference to ^SC supported by DBIA 10040
 ;Reference to EN^VAFCPID supported by DBIA 3015
 ;Reference to EN^VAFHLEVN supported by DBIA 3016
 ;Reference to $$PIVCHK^VAFHPIVT supported by DBIA 6606
 Q
 ;
PDORD ;
 Q:'$P($$SEND^VAFHUTL(),"^",2)
 Q:$O(^PS(58.7,"B",""))=""
 N I,J,PSJAP,PSJQ,PSJBAP,PSJFTSH,PSJWARDH,PSJRBDH S (PSJAP,I)=0
 F  S I=$O(^PS(58.7,I)) Q:'I  S J=$$PDACT^PSJPDCLA(I)
 Q:'PSJAP
 M PSJBAP=PSJAP
 N SNM,CNM S SNM="PSJ RDEO11 SERVER"
 Q:'$O(^ORD(101,"B",SNM,0))
 S CNM="PSJ RDEO11 CLIENT"
 Q:'$O(^ORD(101,"B",CNM,0))
 N HL,NSEG,SEQ,SEG,NFS,NECH,NSCS D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
 S NFS=HL("FS"),NECH=$E(HL("ECH"),1),NSCS=$E(HL("ECH"),4)
 N CLN,CLAPDT,PSJWARD,DFN,I,PSJRBD,ADMDT,PIVOT,PV,PSJDIV1,LOC,EVNDT,PDL,FTS,ASIH
 S DFN=PSJHLDFN,(CLN,PIVOT,ADMDT,CLAPDT,EVNDT,ASIH)=0,(LOC,PSJWARD,PSJRBD,PV,PSJDIV1,FTS)=""
 I RXO["V",$D(^PS(55,DFN,"IV",+RXO,"DSS")) S I=^("DSS") S CLN=$P(I,"^"),CLAPDT=$P(I,"^",2)
 I RXO["U",$D(^PS(55,DFN,5,+RXO,8)) S I=^(8) S CLN=$P(I,"^"),CLAPDT=$P(I,"^",2)
 N PSJQ,PSJQ2,PSJQCL,PSJPDON,VAIP,VAIN,PSJPDO,SETZ S (PSJQ,PSJQ2,SETZ)="",PSJPDO=0
 D IN5^VADPT
 I ($P($G(VAIP(13,3)),"^",2)["ASIH")!($P($G(VAIP(14,3)),"^",2)["ASIH") S ASIH=1
 I (VAIP(5)="")&($G(DGPMTYP)=6)&($G(DGPMP)'="")&($G(DGPMA)="")&($D(DGPMVI)) D
 . M VAIP=DGPMVI
 I VAIP(5)!$G(PSJDCA) D
 . I $G(ASIH)&$G(PSJDCA) S PIVOT=$$PIVOT^PSJPDCLA(DFN,$G(RXO),.PSJWARDH,.PSJRBDH,.PSJFTSH) D
 .. S:$G(PSJWARDH)]"" PSJWARD=PSJWARDH
 .. S:$G(PSJRBDH)]"" PSJRBD=PSJRBDH
 .. S:$G(PSJFTSH)]"" FTS=PSJFTSH
 . Q:$G(PIVOT)&$G(ASIH)
 . I VAIP(5)="" S VAIP("D")="L" D IN5^VADPT
 . S I=+VAIP(5),PSJWARD=$P(VAIP(5),"^",2),PSJRBD=$P(VAIP(6),"^",2),ADMDT=+VAIP(13,1),EVNDT=+VAIP(3)
 . S FTS=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
 . S PSJDIV1=+$P($G(^DIC(42,I,0)),"^",11)
 . S PIVOT=+$$PIVCHK^VAFHPIVT(DFN,ADMDT,1,VAIP(13)_";DGPM(")
 . I PIVOT<0 D  ; Still no pivot - try to find admission linked to order login date
 .. S PIVOT=$$PIVOT^PSJPDCLA(DFN,$G(RXO),.PSJWARDH,.PSJRBDH,.PSJFTSH)
 . I PIVOT<0 D  ; STILL no pivot - check PADE OUTBOUND MESSAGES (#58.72) log file
 .. S PIVOT=$$LOGPIVOT^PSJPDCLA(DFN,$G(RXO))
 I PSJWARD'="",CLN,CLAPDT D  Q:'PSJQ  S SETZ="IC" G CORD
 . S PSJQ=$$CHKPD^PSJPDCL(PSJWARD,PSJRBD) S:'PSJQ PIVOT=0
 . I PSJQ M PSJQ2=PSJQ K PSJQ
 . M PSJAP=PSJBAP S PSJPDO=1
 . S PSJQ=$$CHKPDCL^PSJPDCLA(CLN) Q:'PSJQ
 . S PV="CLN"
 I PSJWARD'="" D  Q:'PSJQ  G CORD
 . S PSJPDO=1,PSJQ=$$CHKPD^PSJPDCL(PSJWARD,PSJRBD)
 . Q:'PSJQ
 . S PV="WARD",SETZ="I"
 I CLN S PSJDIV1=+$P($G(^SC(CLN,0)),"^",15) D  Q:'PSJQ  M PSJQ2=PSJQ S SETZ="C"
 . S PSJPDO=1,PSJQ=$$CHKPDCL^PSJPDCLA(CLN) Q:'PSJQ
 . S PV="CLN"
CORD ;
 Q:'PSJQ
 N ST0,PS55,PDL S (SEQ,ST0)=0
 S PS55=$S(RXO["U":"^PS(55,DFN,5,+RXO)",1:"^PS(55,DFN,""IV"",+RXO)")
 Q:PS55=""
 M PS55=@PS55
 I RXO["U" Q:'$P($G(PS55(2)),"^",2)!('$P($G(PS55(2)),"^",4))
 I RXO["V" Q:'$G(PS55(.2))!('$P($G(PS55(0)),"^",2))
 N VAR1,VAR2,STATUS,PDDT,PDHDT
 S PDDT=$$NOW^XLFDT(),PDHDT=+$$HLDATE^HLFNC(PDDT,"TS")
 D PID,PV1,AGY^PSJPDCL,ORC,RXE,RXR
 D:RXO["V" IVRXC
 I RXO["U" N CNT S CNT=0 D  D:CNT>1 RXC  ; IF THERE ARE > 1 ACTIVE DD, MAKE AN RXC FOR EACH
 . N X1 S X1=0 F  S X1=$O(PS55(1,X1)) Q:'X1  D
 .. I $P(PS55(1,X1,0),"^",3),$P(PS55(1,X1,0),"^",3)'>DT Q  ; DONT COUNT IF IT HAS AN INNACTIVATION DATE (PAST)
 .. S CNT=CNT+1
 D ZRX
 N ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTDTH
 S ZTIO=""
 S:CLAPDT PDL(16)=CLAPDT
 S ZTRTN="SEND^PSJPDCLU"
 F XX="NSEG(","PSJQ(","PSJQ2(","SETZ","HLFS","HLECH","HL(","SNM","CNM","PDL(","FTS","ASIH","PSJDCA" S ZTSAVE(XX)=""
 S ZTDESC="PADE HL7 Order Message Router"
 S ZTDTH=$H
 D ^%ZTLOAD
 Q
 ;
SEND ;
 N XX,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,NHL,CT,PDLTMP
 M PDLTMP=PDL  ; Preserve PDL array info
 M NHL=HL
 S XX=0,CT=$O(NSEG(9999),-1)+1
 F  S XX=$O(PSJQ(XX)) Q:'XX  D
 .M PDL=PDLTMP  ; Restore PDL array after cleaned up by LOG^PSJPADE
 .M HL=NHL
 .S PSJND=$G(^PS(58.7,XX,0))
 .Q:PSJND=""
 .S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
 .Q:PSJVNM=""!(PSJDNS="")!('PSJVP)
 .N HLP,PSJSND
 .S HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
 .N ZZ1,ZZ2 S (ZZ1,ZZ2)=""
 .I SETZ="C" S ZZ2=$P($G(PSJQ2(XX)),"^",2)
 .I SETZ="IC" S ZZ1=$P($G(PSJQ2(XX)),"^",2),ZZ2=$P($G(PSJQ(XX)),"^",2)
 .I SETZ="I" S ZZ1=$P($G(PSJQ(XX)),"^",2)
 .S NSEG(CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_ZZ2_HL("FS")_FTS
 .D PV19^PSJPDAPP
 .K HLA M HLA("HLS")=NSEG
 .D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
 .D LOG^PSJPADE
 Q
 ;
PID ;
 N VAFSTR
 S VAFSTR="1,2,3,4,5,6,7,8,9,19"
 N VAFPID,M
 S VAFPID=$$EN^VAFCPID(DFN,VAFSTR)
 S SEQ=SEQ+1
 S NSEG(SEQ)=$TR(VAFPID,"""""","")
 Q
 ;
PV1 ;
 N PV1,VAIP
 I PV="WARD" D
 .S VAFSTR=",2,3,7,10,18,21,39,44,45"
 .S PV1=$$IN^VAFHLPV1(DFN,"",VAFSTR,"","",1,"")
 .I $G(PSJWARDH)]"" S $P(PV1,NFS,4)=PSJWARDH_NECH_$TR($P($G(PSJRBDH),"-",1,2),"-",NECH)
 .S:$P(PV1,NFS,4)="" $P(PV1,NFS,4)=PSJWARD_NECH_$TR($P(PSJRBD,"-",1,2),"-",NECH)
 .S SEG=PV1
 I PV="CLN" D
 .I PSJWARD'="",PIVOT S VAFSTR=",2,3,7,10,18,21,39,44,45"
 .E  S VAFSTR=""
 .S PV1=$$IN^VAFHLPV1(DFN,EVNDT,VAFSTR,"","",1,"")
 .I RXO["U",CLAPDT S $P(PV1,NFS,12)=$P($G(^SC(CLN,0)),"^")_NECH_CLN
 .I RXO["V" I (PSJWARD'=""&CLAPDT)!(PSJWARD="") S $P(PV1,NFS,12)=$P($G(^SC(CLN,0)),"^")_NECH_CLN
 .S SEG=PV1
 S:$G(PIVOT)>0 $P(SEG,NFS,51)=PIVOT
 S:$P(PV1,NFS,4)="" $P(SEG,NFS,3)="O"
 S SEQ=SEQ+1
 S NSEG(SEQ)=$TR(SEG,"""""","")
 S:$G(PSJDIV1) $P(NSEG(SEQ),NFS,40)=$P($$SITE^VASITE(,PSJDIV1),"^",3)
 Q
 ;
ORC ;
 S SEG="ORC"
 S STATUS=$S(RXO["U":$P(PS55(0),"^",9),1:$P(PS55(0),"^",17))
 S:$G(PSJEXPOE) STATUS="E"
 S ($P(SEG,NFS,2),PDL(15))=$S(STATUS="A"&((PDTYP="SN")!(PDTYP="SC")):"NW",PDTYP="OH":"OH",PDTYP="OE":"RL",PDTYP="OD"!($E(STATUS)="D")!(STATUS="E"):"DC",1:"XX")
 S $P(SEG,NFS,3)=+$P(PS55(0),"^",21)
 S ($P(SEG,NFS,4),PDL(2))=RXO
 S $P(SEG,NFS,6)=$S($E(STATUS)="D":"DC",STATUS="E":"ZE",(STATUS="H"!($G(PDTYP)="OH")):"HD",1:"CM")
 S VAR1="",VAR2=$S(RXO["U":$P(PS55(0),"^",25),1:$P(PS55(2),"^",5))
 D:VAR2
 .I RXO["U" S VAR1=$P($G(^PS(55,DFN,5,+VAR2,0)),"^",21)_NECH_VAR2
 .I RXO["V" S VAR1=$P($G(^PS(55,DFN,"IV",+VAR2,0)),"^",21)_NECH_VAR2
 S $P(SEG,NFS,9)=VAR1
 S $P(SEG,NFS,10)=+$$HLDATE^HLFNC($S(RXO["U":$P(PS55(0),"^",16),1:$P(PS55(2),"^")))
 S VAR1=$S(RXO["U":$P(PS55(4),"^",7),1:$P(PS55(2),"^",11))
 D:VAR1
 .S VAR2=$P($G(^VA(200,VAR1,0)),"^")
 .S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 .S ($P(SEG,NFS,11),$P(SEG,NFS,20))=VAR1_NECH_VAR2
 S VAR1=$S(RXO["U":$P($G(PS55(4)),"^",3),1:$P($G(PS55(4)),"^",4))
 S:VAR1="" VAR1=+$G(DUZ)
 D:VAR1
 .S VAR2=$P($G(^VA(200,+VAR1,0)),"^")
 .S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 .S $P(SEG,NFS,12)=VAR1_NECH_VAR2
 S VAR1=$S(RXO["U":$P(PS55(0),"^",2),1:$P($G(PS55(0)),"^",6))
 D:VAR1
 .S VAR2=$P($G(^VA(200,+VAR1,0)),"^")
 .S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 .S $P(SEG,NFS,13)=VAR1_NECH_VAR2
 S VAR1=$P(SEG,NFS,2)
 S VAR2=$S(VAR1="NW":"NEW",VAR1="DC":"DISCONTINUE",VAR1="HD":"HOLD",VAR1="OH":"HOLD",VAR1="RL":"RELEASED HOLD",VAR1="XX":"CHANGE",1:"UNKNOWN")
 S $P(SEG,NFS,17)=VAR2
 I $G(PSJDMU) S VAR1=+$G(DUZ) D:VAR1
 .S VAR2=$P($G(^VA(200,VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 .S $P(SEG,NFS,20)=VAR1_NFS_VAR2
 S SEQ=SEQ+1
 S NSEG(SEQ)=SEG
 D:$D(^XTMP("PADE")) DISP
 Q
 ;
RXE ;
 N DOSE
 S SEG="RXE"
 I RXO["V" D IVRXE Q
 S $P(SEG,NFS,2)=$$QT(DFN,RXO,.PS55)
 S $P(SEG,NFS,3)=$$GIVECODE(+$$DSPDRG,NECH)
 N DOSETMP,MIN,MAX
 S DOSE=$TR($P(PS55(.2),"^",2),","),MIN=+DOSE
 S DOSETMP=$TR(DOSE," ")
 I DOSETMP["-" S MIN=+$P(DOSETMP,"-"),MAX=$P(DOSETMP,"-",2,99)
 S $P(SEG,NFS,4)=$S(MIN:MIN,1:"")
 S $P(SEG,NFS,5)=$S($G(MAX):+$G(MAX),1:"")
 I '$G(MAX),$G(MIN),+$TR($P($G(DOSE),MIN,2,99)," ") D
 . S $P(SEG,NFS,6)=DOSE
 E  D
 . S DOSETMP=$S($G(MAX):$P(DOSE,+MAX,2,99),$G(MIN):$P($G(DOSE),MIN,2,99),1:DOSE)
 . I $E(DOSETMP)=" " S DOSETMP=$E(DOSETMP,2,$L(DOSETMP))
 . S $P(SEG,NFS,6)=DOSETMP
 S VAR1=$$GETFORM(.PS55)
 S $P(SEG,NFS,7)=VAR1
 N PCE S PCE=""
 I $D(PS55(15)) D
 .N PC,I S I=0,PC="" F  S I=$O(PS55(15,I)) Q:'I  D
 ..I PCE]"" S PCE=PCE_$TR(PS55(15,I,0),"|","/") Q
 ..S PC=PC_$TR(PS55(15,I,0),"|","/")
 ..I $L(PC)>200 S PCE=$E(PC,201,999)_" ",PC=$E(PC,1,200)
 .S $P(SEG,NFS,22)=PC
 S $P(SEG,NFS,11)=$P($$DSPDRG,"^",2)
 S VAR1=+$P(PS55(0),"^",2),VAR2=$P($G(^VA(200,VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH),VAR1=$$DEA^XUSER(,VAR1)
 S $P(SEG,NFS,14)=VAR1_NECH_VAR2
 S VAR1=$P($G(PS55(4)),"^",3),VAR2="" I VAR1 S VAR2=$P($G(^VA(200,+VAR1,0)),"^") S VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 S $P(SEG,NFS,15)=VAR1_NECH_VAR2
 S $P(SEG,NFS,16)=RXO
 S SEQ=SEQ+1
 S NSEG(SEQ)=SEG
 I $O(SEG(0)) S I=0 F  S I=$O(SEG(I)) Q:'I  S NSEG(SEQ,I)=SEG(I)
 I $G(PCE)]"" D
 .S SEQ=SEQ+1
 .S NSEG(SEQ)="NTE"_NFS_NFS_NFS_PCE
 D:$D(^XTMP("PADE")) DISP
 K SEG
 Q
 ;
IVRXE ;
 N ND0,NDPT2,NDAD,NDSOL,PCE S PCE=""
 S ND0=PS55(0),NDPT2=PS55(.2),NDAD=$G(PS55("AD",1,0)),NDSOL=$G(PS55("SOL",1,0))
 S $P(SEG,NFS,2)=$$QT(DFN,RXO,.PS55)
 S $P(SEG,NFS,3)=$$GIVECODE($S(NDAD:$P(^PS(52.6,+NDAD,0),"^",2),1:$P(^PS(52.7,+NDSOL,0),"^",2)),NECH)
 S $P(SEG,NFS,4)=+$$QT(DFN,RXO,.PS55)
 S $P(SEG,NFS,6)=$TR($P($G(DOSE),+DOSE,2,9)," ")
 S VAR1=+$G(PS55("AD",1,0)),VAR1=+$P($G(^PS(52.6,VAR1,0)),"^",11),VAR1=+$P($G(^PS(50.7,VAR1,0)),"^",2),VAR1=$G(^PS(50.606,VAR1,0))
 S $P(SEG,NFS,7)=VAR1
 I $D(PS55(10)) D
 .N PC,I S I=0,PC="" F  S I=$O(PS55(10,I)) Q:'I  D
 ..I PCE]"" S PCE=PCE_$TR(PS55(10,I,0),"|","/") Q
 ..S PC=PC_$TR(PS55(10,I,0),"|","/")
 ..I $L(PC)>200 S PCE=$E(PC,201,999)_" ",PC=$E(PC,1,200)
 .S $P(SEG,NFS,22)=PC
 S $P(SEG,NFS,11)=1
 S $P(SEG,NFS,12)="BAG"
 S VAR1=+$P(PS55(0),"^",6)
 D:VAR1
 . S VAR2=$P($G(^VA(200,VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 . S VAR1=$$DEA^XUSER(,VAR1)
 . S $P(SEG,NFS,14)=VAR1_NECH_VAR2
 S VAR1=$P($G(PS55(4)),"^",4)
 D:VAR1
 .S VAR2=$P($G(^VA(200,+VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
 .S $P(SEG,NFS,15)=VAR1_NECH_VAR2
 S $P(SEG,NFS,16)=RXO
 I $P(PS55(0),"^",15)'="" S $P(SEG,NFS,23)="M"_$P(PS55(0),"^",15)
 S VAR1=$P(PS55(0),"^",8),VAR2=$P(VAR1,+VAR1,2),VAR1=+VAR1
 I $E(VAR2)=" " S VAR2=$P(VAR2," ",2)
 I (VAR2="")!(VAR1=0),$P(PS55(0),"^",8)'="" S VAR2=$P(PS55(0),"^",8)
 S $P(SEG,NFS,24)=$S(VAR1=0:"",1:VAR1)
 S $P(SEG,NFS,25)=NECH_VAR2
 S VAR1=$P($G(PS55("AD",1,0)),"^",2),VAR2=$P(VAR1,+VAR1,2)
 I $E(VAR2)=" " S VAR2=$P(VAR2," ",2,99)
 I VAR2="" S VAR1=$P($G(PS55("SOL",1,0)),"^",2),VAR2=$P(VAR1,+VAR1,2)
 I $E(VAR2)=" " S VAR2=$P(VAR2," ",2,99)
 S $P(SEG,NFS,26)=+VAR1
 D CONT(VAR2,27,NFS)
IVC ;
 S SEQ=SEQ+1
 S NSEG(SEQ)=SEG
 I $O(SEG(0)) S I=0 F  S I=$O(SEG(I)) Q:'I  S NSEG(SEQ,I)=SEG(I)
 I $G(PCE)]"" D
 .S SEQ=SEQ+1
 .S NSEG(SEQ)="NTE"_NFS_NFS_NFS_PCE
 D:$D(^XTMP("PADE")) DISP
 K SEG
 Q
 ;
CONT(VALUE,PIECE,FS) ;
 N TEMP,TEMP2,NODES,STRING,BEG,END,REM
 I $L(SEG)+$L(VALUE)<246 S $P(SEG,FS,PIECE)=VALUE Q
 S TEMP=SEG_FS_VALUE
 S SEG=$E(TEMP,1,245)
 S STRING=$E(TEMP,246,$L(TEMP)),NODES=$L(STRING)\245,REM=$L(STRING)#245,BEG=1,END=245 I REM S NODES=NODES+1
 F TEMP2=1:1:NODES S SEG(TEMP2)=$E(STRING,BEG,END) S BEG=BEG+245,END=END+245
 Q
 ;
RXR ;
 S SEG="RXR"
 S VAR1=$S(RXO["U":$P(PS55(0),"^",3),1:$P(PS55(.2),"^",3))
 S VAR1=$G(^PS(51.2,+VAR1,0)) S VAR2=$P(VAR1,"^"),VAR1=$P(VAR1,"^",3)
 S $P(SEG,NFS,2)=VAR1_NECH_VAR2_NECH_"99PSR"
 S SEQ=SEQ+1
 S NSEG(SEQ)=SEG
 D:$D(^XTMP("PADE")) DISP
 Q
 ;
RXC ;
 D RXC^PSJPADE
 Q
 ;
IVRXC ;
 N D,X,PSJDD,PSJADSO,FIL
 F PSJADSO="SOL","AD" S D=0 F  S D=$O(PS55(PSJADSO,D)) Q:'D  S PSJDD=$P(PS55(PSJADSO,D,0),"^") D
 .Q:'PSJDD
 .S FIL=$S(PSJADSO="AD":52.6,1:52.7) S PSJDD=^PS(FIL,PSJDD,0),PSJDD=$P(PSJDD,"^",2)
 .S SEG="RXC"_NFS_$S(PSJADSO="AD":"A",1:"B")
 .S $P(SEG,NFS,3)=$$GIVECODE(PSJDD,NECH)
 .S VAR1=$P(PS55(PSJADSO,D,0),"^",2),VAR2=$P(VAR1,+VAR1,2)
 .S:$E(VAR2)=" " VAR2=$P(VAR2," ",2)
 .S $P(SEG,NFS,4)=+VAR1
 .S $P(SEG,NFS,5)=NECH_VAR2
 .S VAR1=$G(^PSDRUG(PSJDD,"DOS")),X=+$P(VAR1,"^",2)
 .I X S VAR2=$P($G(^PS(50.607,X,0)),"^") S VAR2=X_NECH_VAR2_NECH_"99PSU"
 .I VAR1 S $P(SEG,NFS,6)=+VAR1,$P(SEG,NFS,7)=VAR2
 .S SEQ=SEQ+1
 .S NSEG(SEQ)=SEG
 .D:$D(^XTMP("PADE")) DISP
 Q
 ;
ZRX ;
 S STATUS=$S(RXO["U":$P(PS55(0),"^",9),1:$P(PS55(0),"^",17))
 S VAR1=$S($G(PDTYP)="SN":"N",STATUS["E"!(STATUS["D"):"O",1:"F")
 S SEG="ZRX"_NFS_VAR1_NFS_+PDHDT
 S SEQ=SEQ+1
 S NSEG(SEQ)=SEG
 D:$D(^XTMP("PADE")) DISP
 Q
 ;
GETFORM(PSJ55) ;
 N X
 S X=+$P($G(^PSDRUG(+$$DSPDRG,2)),"^")
 I X S X=+$P($G(^PS(50.7,X,0)),"^",2),VAR1=$P($G(^PS(50.606,X,0)),"^")
 I VAR1="" S VAR1=$P($G(^PSDRUG(+$$DSPDRG,660)),"^",8)
 I VAR1="" S X=$P($G(^PSDRUG(+$$DSPDRG,"ND")),"^",3) S:X VAR1=$P($$PROD2^PSNAPIS(,X),"^",4)
 Q VAR1
 ;
QT(DFN,RXO,PS55) ;
 S VAR1=""
 I RXO["U" D  Q VAR1
 .S DOSE=$TR($P($G(PS55(.2)),"^",2),",")
 .N AT,NAT S AT=$TR($P(PS55(2),"^",5),"-",","),NAT=""
 .I AT N I,J F I=1:1:$L(AT,",") S J=$P(AT,",",I) D
 ..S J=$S($L(J)=2:J_"00",1:J)
 ..S $P(NAT,",",I)=J
 .S VAR1=+DOSE_NECH_$P(PS55(2),"^")_NSCS_NAT_NECH_NECH
 .S VAR1=VAR1_+$$HLDATE^HLFNC($P(PS55(2),"^",2),"TS")_NECH_+$$HLDATE^HLFNC($P(PS55(2),"^",4),"TS")_NECH
 .S VAR2=$$PRNOK^PSGS0($P(PS55(2),"^"))
 .S VAR1=VAR1_NECH_VAR2_NECH_$$DOWSTR($P(PS55(2),"^"))
 I RXO["V" D  Q VAR1
 .S ND0=PS55(0),NDPT2=PS55(.2),NDAD=$G(PS55("AD",1,0)),NDSOL=$G(PS55("SOL",1,0))
 .S DOSE=$P($G(PS55("AD",1,0)),"^",2) S VAR2=$TR($P(DOSE,+DOSE,2,9)," ")
 .I VAR2="" S DOSE=$P($G(PS55("SOL",1,0)),"^",2) S VAR2=$TR($P(DOSE,+DOSE,2,9)," ")
 .N AT,NAT S AT=$TR($P(PS55(0),"^",11),"-",","),NAT=""
 .I AT N I,J F I=1:1:$L(AT,",") S J=$P(AT,",",I) D
 ..S J=$S($L(J)=2:J_"00",1:J)
 ..S $P(NAT,",",I)=J
 .S VAR1=+DOSE_NSCS_VAR2_NECH_$S(($P(PS55(0),"^",9)]""):$P(PS55(0),"^",9),1:"C")_NSCS_NAT_NECH_NECH
 .S VAR1=VAR1_+$$HLDATE^HLFNC($P(PS55(0),"^",2))_NECH_+$$HLDATE^HLFNC($P(PS55(0),"^",3)) S VAR2=$P(PS55(.2),"^",4)
 .S VAR2=$$PRNOK^PSGS0($P(PS55(2),"^"))
 .S VAR1=VAR1_NECH_VAR2_NECH_$$DOWSTR($P(PS55(0),"^",9))
 Q
 ;
DOWSTR(DOWSCH) ;
 N SQ,SQ2,DD,QX,SDW,SWD,DOWSCH2,DAYSTR
 S DAYSTR="00000000",DOWSCH=$P(DOWSCH,"@")
 S DOWSCH2="-SU-MO-TU-WE-TH-FR-SA-"
 F SQ=1:1:$L(DOWSCH,"-") S DD=$E($P(DOWSCH,"-",SQ),1,2) S SQ2=$P(DOWSCH2,DD) Q:(SQ2=DOWSCH2)  S SQ2=$L(SQ2,"-")-1 S $E(DAYSTR,SQ2)=1
 Q DAYSTR
 ;
DSPDRG() ;
 N I,J S I=0,J=999999
 F  S J=$O(PS55(1,J),-1) Q:J=0  D  Q:I
 . I $P(PS55(1,J,0),"^",3),$P(PS55(1,J,0),"^",3)'>DT Q  ;inactive drug
 . S I=J
 S:'I I=1
 Q $G(PS55(1,I,0))
 ;
GIVECODE(ID,CS) ;
 N DRGID,DRGNM,DRGNM2,DRGSTR,DRUGND
 Q:'$D(^PSDRUG(ID)) ""
 S DRUGND=$G(^PSDRUG(ID,"ND"))
 S DRGNM=$P($G(^PSDRUG(ID,0)),"^"),PDL(14)=ID
 S DRGSTR=ID_CS_DRGNM_CS_"99PSD"
 S DRGNM2=$P(DRUGND,"^",2)
 S DRGID=$P(DRUGND,"^",3)
 S DRGSTR=DRGSTR_CS_DRGID_CS_DRGNM2_CS_"99PSP"
 Q DRGSTR
 ;
DISP ;
 Q:'$D(^XUSEC("PSJ PADE MGR",DUZ))
 D FULL^VALM1
 W !!,?5,"THIS IS THE PADE "_$P(NSEG(SEQ),NFS)_" SEGMENT."
 N TR,TX F TR=1:1:$L(NSEG(SEQ),NFS) S TX=$P(NSEG(SEQ),NFS,TR) W !,$P(NSEG(SEQ),NFS)_"-"_(TR-1)_$S(TR<10:"= ",1:"=")_TX
 D PAUSE^VALM1
 Q