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 ; 11/18/19 1:17pm
 ;;5.0;INPATIENT MEDICATIONS;**317,337,395,405,364,432,438**;16 DEC 97;Build 4
 ;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(RESNDCLN) ;
 ; RESNDCLN=Specific Clinic IEN to be sent
 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)
 I $G(RESNDCLN) Q:$G(RESNDCLN)'=$G(CLN)
 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 ;
 ;*364 Moving to another routine due to SACC max limit.
 D CORD^PSJPDCLV
 Q
 ;
SEND ;
 ;*364 Moving to another routine due to SACC max limit.
 D SEND^PSJPDCLV
 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_$$ESC($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^PSJPDCLV($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=$$PRNOK^PSGS0($P(PS55(2),"^"))
 .N VAR3 S VAR3=$P(PS55(.2),"^",4) ;p438 priority
 .S VAR1=VAR1_NECH_NECH_VAR2_NECH_$$DOWSTR^PSJPDCLV($P(PS55(0),"^",9))_NECH_VAR3 ;p438 appended priority
 Q
 ;
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=$$ESC($P($G(^PSDRUG(ID,0)),"^")),PDL(14)=ID
 S DRGSTR=ID_CS_DRGNM_CS_"99PSD"
 S DRGNM2=$$ESC($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
 ;
ESC(VAL) ;
 N NVAL
 S NVAL="" F I=1:1:$L(VAL) S NVAL=NVAL_$S($E(VAL,I)="&":"\T\",1:$E(VAL,I))
 Q NVAL