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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDCLU 13969 printed Oct 16, 2024@18:09:29 Page 2
PSJPDCLU ;BIR/MHA/MC - PADE ORDER ; 11/18/19 1:17pm
+1 ;;5.0;INPATIENT MEDICATIONS;**317,337,395,405,364,432,438**;16 DEC 97;Build 4
+2 ;Reference to ^PS(50.7 supported by DBIA 2180
+3 ;Reference to ^PS(50.606 supported by DBIA 2174
+4 ;Reference to ^PS(50.607 supported by DBIA 2221
+5 ;Reference to ^PS(51.2 supported by DBIA 2178
+6 ;Reference to ^PS(52.6 supported by DBIA 1231
+7 ;Reference to ^PS(52.7 supported by DBIA 2173
+8 ;Reference to ^PSDRUG supported by DBIA 2192
+9 ;Reference to $$PROD2^PSNAPIS supported by DBIA 2531
+10 ;Reference to ^ORD(101 supported by DBIA #872
+11 ;Reference to ^DIC(42 supported by DBIA 10039
+12 ;Reference to ^SC supported by DBIA 10040
+13 ;Reference to EN^VAFCPID supported by DBIA 3015
+14 ;Reference to EN^VAFHLEVN supported by DBIA 3016
+15 ;Reference to $$PIVCHK^VAFHPIVT supported by DBIA 6606
+16 QUIT
+17 ;
PDORD(RESNDCLN) ;
+1 ; RESNDCLN=Specific Clinic IEN to be sent
+2 if '$PIECE($$SEND^VAFHUTL(),"^",2)
QUIT
+3 if $ORDER(^PS(58.7,"B",""))=""
QUIT
+4 NEW I,J,PSJAP,PSJQ,PSJBAP,PSJFTSH,PSJWARDH,PSJRBDH
SET (PSJAP,I)=0
+5 FOR
SET I=$ORDER(^PS(58.7,I))
if 'I
QUIT
SET J=$$PDACT^PSJPDCLA(I)
+6 if 'PSJAP
QUIT
+7 MERGE PSJBAP=PSJAP
+8 NEW SNM,CNM
SET SNM="PSJ RDEO11 SERVER"
+9 if '$ORDER(^ORD(101,"B",SNM,0))
QUIT
+10 SET CNM="PSJ RDEO11 CLIENT"
+11 if '$ORDER(^ORD(101,"B",CNM,0))
QUIT
+12 NEW HL,NSEG,SEQ,SEG,NFS,NECH,NSCS
DO INIT^HLFNC2(SNM,.HL)
if $DATA(HL)=1
QUIT
+13 SET NFS=HL("FS")
SET NECH=$EXTRACT(HL("ECH"),1)
SET NSCS=$EXTRACT(HL("ECH"),4)
+14 NEW CLN,CLAPDT,PSJWARD,DFN,I,PSJRBD,ADMDT,PIVOT,PV,PSJDIV1,LOC,EVNDT,PDL,FTS,ASIH
+15 SET DFN=PSJHLDFN
SET (CLN,PIVOT,ADMDT,CLAPDT,EVNDT,ASIH)=0
SET (LOC,PSJWARD,PSJRBD,PV,PSJDIV1,FTS)=""
+16 IF RXO["V"
IF $DATA(^PS(55,DFN,"IV",+RXO,"DSS"))
SET I=^("DSS")
SET CLN=$PIECE(I,"^")
SET CLAPDT=$PIECE(I,"^",2)
+17 IF RXO["U"
IF $DATA(^PS(55,DFN,5,+RXO,8))
SET I=^(8)
SET CLN=$PIECE(I,"^")
SET CLAPDT=$PIECE(I,"^",2)
+18 IF $GET(RESNDCLN)
if $GET(RESNDCLN)'=$GET(CLN)
QUIT
+19 NEW PSJQ,PSJQ2,PSJQCL,PSJPDON,VAIP,VAIN,PSJPDO,SETZ
SET (PSJQ,PSJQ2,SETZ)=""
SET PSJPDO=0
+20 DO IN5^VADPT
+21 IF ($PIECE($GET(VAIP(13,3)),"^",2)["ASIH")!($PIECE($GET(VAIP(14,3)),"^",2)["ASIH")
SET ASIH=1
+22 IF (VAIP(5)="")&($GET(DGPMTYP)=6)&($GET(DGPMP)'="")&($GET(DGPMA)="")&($DATA(DGPMVI))
Begin DoDot:1
+23 MERGE VAIP=DGPMVI
End DoDot:1
+24 IF VAIP(5)!$GET(PSJDCA)
Begin DoDot:1
+25 IF $GET(ASIH)&$GET(PSJDCA)
SET PIVOT=$$PIVOT^PSJPDCLA(DFN,$GET(RXO),.PSJWARDH,.PSJRBDH,.PSJFTSH)
Begin DoDot:2
+26 if $GET(PSJWARDH)]""
SET PSJWARD=PSJWARDH
+27 if $GET(PSJRBDH)]""
SET PSJRBD=PSJRBDH
+28 if $GET(PSJFTSH)]""
SET FTS=PSJFTSH
End DoDot:2
+29 if $GET(PIVOT)&$GET(ASIH)
QUIT
+30 IF VAIP(5)=""
SET VAIP("D")="L"
DO IN5^VADPT
+31 SET I=+VAIP(5)
SET PSJWARD=$PIECE(VAIP(5),"^",2)
SET PSJRBD=$PIECE(VAIP(6),"^",2)
SET ADMDT=+VAIP(13,1)
SET EVNDT=+VAIP(3)
+32 SET FTS=$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2)
+33 SET PSJDIV1=+$PIECE($GET(^DIC(42,I,0)),"^",11)
+34 SET PIVOT=+$$PIVCHK^VAFHPIVT(DFN,ADMDT,1,VAIP(13)_";DGPM(")
+35 ; Still no pivot - try to find admission linked to order login date
IF PIVOT<0
Begin DoDot:2
+36 SET PIVOT=$$PIVOT^PSJPDCLA(DFN,$GET(RXO),.PSJWARDH,.PSJRBDH,.PSJFTSH)
End DoDot:2
+37 ; STILL no pivot - check PADE OUTBOUND MESSAGES (#58.72) log file
IF PIVOT<0
Begin DoDot:2
+38 SET PIVOT=$$LOGPIVOT^PSJPDCLA(DFN,$GET(RXO))
End DoDot:2
End DoDot:1
+39 IF PSJWARD'=""
IF CLN
IF CLAPDT
Begin DoDot:1
+40 SET PSJQ=$$CHKPD^PSJPDCL(PSJWARD,PSJRBD)
if 'PSJQ
SET PIVOT=0
+41 IF PSJQ
MERGE PSJQ2=PSJQ
KILL PSJQ
+42 MERGE PSJAP=PSJBAP
SET PSJPDO=1
+43 SET PSJQ=$$CHKPDCL^PSJPDCLA(CLN)
if 'PSJQ
QUIT
+44 SET PV="CLN"
End DoDot:1
if 'PSJQ
QUIT
SET SETZ="IC"
GOTO CORD
+45 IF PSJWARD'=""
Begin DoDot:1
+46 SET PSJPDO=1
SET PSJQ=$$CHKPD^PSJPDCL(PSJWARD,PSJRBD)
+47 if 'PSJQ
QUIT
+48 SET PV="WARD"
SET SETZ="I"
End DoDot:1
if 'PSJQ
QUIT
GOTO CORD
+49 IF CLN
SET PSJDIV1=+$PIECE($GET(^SC(CLN,0)),"^",15)
Begin DoDot:1
+50 SET PSJPDO=1
SET PSJQ=$$CHKPDCL^PSJPDCLA(CLN)
if 'PSJQ
QUIT
+51 SET PV="CLN"
End DoDot:1
if 'PSJQ
QUIT
MERGE PSJQ2=PSJQ
SET SETZ="C"
CORD ;
+1 ;*364 Moving to another routine due to SACC max limit.
+2 DO CORD^PSJPDCLV
+3 QUIT
+4 ;
SEND ;
+1 ;*364 Moving to another routine due to SACC max limit.
+2 DO SEND^PSJPDCLV
+3 QUIT
+4 ;
PID ;
+1 NEW VAFSTR
+2 SET VAFSTR="1,2,3,4,5,6,7,8,9,19"
+3 NEW VAFPID,M
+4 SET VAFPID=$$EN^VAFCPID(DFN,VAFSTR)
+5 SET SEQ=SEQ+1
+6 SET NSEG(SEQ)=$TRANSLATE(VAFPID,"""""","")
+7 QUIT
+8 ;
PV1 ;
+1 NEW PV1,VAIP
+2 IF PV="WARD"
Begin DoDot:1
+3 SET VAFSTR=",2,3,7,10,18,21,39,44,45"
+4 SET PV1=$$IN^VAFHLPV1(DFN,"",VAFSTR,"","",1,"")
+5 IF $GET(PSJWARDH)]""
SET $PIECE(PV1,NFS,4)=PSJWARDH_NECH_$TRANSLATE($PIECE($GET(PSJRBDH),"-",1,2),"-",NECH)
+6 if $PIECE(PV1,NFS,4)=""
SET $PIECE(PV1,NFS,4)=PSJWARD_NECH_$TRANSLATE($PIECE(PSJRBD,"-",1,2),"-",NECH)
+7 SET SEG=PV1
End DoDot:1
+8 IF PV="CLN"
Begin DoDot:1
+9 IF PSJWARD'=""
IF PIVOT
SET VAFSTR=",2,3,7,10,18,21,39,44,45"
+10 IF '$TEST
SET VAFSTR=""
+11 SET PV1=$$IN^VAFHLPV1(DFN,EVNDT,VAFSTR,"","",1,"")
+12 IF RXO["U"
IF CLAPDT
SET $PIECE(PV1,NFS,12)=$PIECE($GET(^SC(CLN,0)),"^")_NECH_CLN
+13 IF RXO["V"
IF (PSJWARD'=""&CLAPDT)!(PSJWARD="")
SET $PIECE(PV1,NFS,12)=$PIECE($GET(^SC(CLN,0)),"^")_NECH_CLN
+14 SET SEG=PV1
End DoDot:1
+15 if $GET(PIVOT)>0
SET $PIECE(SEG,NFS,51)=PIVOT
+16 if $PIECE(PV1,NFS,4)=""
SET $PIECE(SEG,NFS,3)="O"
+17 SET SEQ=SEQ+1
+18 SET NSEG(SEQ)=$TRANSLATE(SEG,"""""","")
+19 if $GET(PSJDIV1)
SET $PIECE(NSEG(SEQ),NFS,40)=$PIECE($$SITE^VASITE(,PSJDIV1),"^",3)
+20 QUIT
+21 ;
ORC ;
+1 SET SEG="ORC"
+2 SET STATUS=$SELECT(RXO["U":$PIECE(PS55(0),"^",9),1:$PIECE(PS55(0),"^",17))
+3 if $GET(PSJEXPOE)
SET STATUS="E"
+4 SET ($PIECE(SEG,NFS,2),PDL(15))=$SELECT(STATUS="A"&((PDTYP="SN")!(PDTYP="SC")):"NW",PDTYP="OH":"OH",PDTYP="OE":"RL",PDTYP="OD"!($EXTRACT(STATUS)="D")!(STATUS="E"):"DC",1:"XX")
+5 SET $PIECE(SEG,NFS,3)=+$PIECE(PS55(0),"^",21)
+6 SET ($PIECE(SEG,NFS,4),PDL(2))=RXO
+7 SET $PIECE(SEG,NFS,6)=$SELECT($EXTRACT(STATUS)="D":"DC",STATUS="E":"ZE",(STATUS="H"!($GET(PDTYP)="OH")):"HD",1:"CM")
+8 SET VAR1=""
SET VAR2=$SELECT(RXO["U":$PIECE(PS55(0),"^",25),1:$PIECE(PS55(2),"^",5))
+9 if VAR2
Begin DoDot:1
+10 IF RXO["U"
SET VAR1=$PIECE($GET(^PS(55,DFN,5,+VAR2,0)),"^",21)_NECH_VAR2
+11 IF RXO["V"
SET VAR1=$PIECE($GET(^PS(55,DFN,"IV",+VAR2,0)),"^",21)_NECH_VAR2
End DoDot:1
+12 SET $PIECE(SEG,NFS,9)=VAR1
+13 SET $PIECE(SEG,NFS,10)=+$$HLDATE^HLFNC($SELECT(RXO["U":$PIECE(PS55(0),"^",16),1:$PIECE(PS55(2),"^")))
+14 SET VAR1=$SELECT(RXO["U":$PIECE(PS55(4),"^",7),1:$PIECE(PS55(2),"^",11))
+15 if VAR1
Begin DoDot:1
+16 SET VAR2=$PIECE($GET(^VA(200,VAR1,0)),"^")
+17 if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+18 SET ($PIECE(SEG,NFS,11),$PIECE(SEG,NFS,20))=VAR1_NECH_VAR2
End DoDot:1
+19 SET VAR1=$SELECT(RXO["U":$PIECE($GET(PS55(4)),"^",3),1:$PIECE($GET(PS55(4)),"^",4))
+20 if VAR1=""
SET VAR1=+$GET(DUZ)
+21 if VAR1
Begin DoDot:1
+22 SET VAR2=$PIECE($GET(^VA(200,+VAR1,0)),"^")
+23 if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+24 SET $PIECE(SEG,NFS,12)=VAR1_NECH_VAR2
End DoDot:1
+25 SET VAR1=$SELECT(RXO["U":$PIECE(PS55(0),"^",2),1:$PIECE($GET(PS55(0)),"^",6))
+26 if VAR1
Begin DoDot:1
+27 SET VAR2=$PIECE($GET(^VA(200,+VAR1,0)),"^")
+28 if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+29 SET $PIECE(SEG,NFS,13)=VAR1_NECH_VAR2
End DoDot:1
+30 SET VAR1=$PIECE(SEG,NFS,2)
+31 SET VAR2=$SELECT(VAR1="NW":"NEW",VAR1="DC":"DISCONTINUE",VAR1="HD":"HOLD",VAR1="OH":"HOLD",VAR1="RL":"RELEASED HOLD",VAR1="XX":"CHANGE",1:"UNKNOWN")
+32 SET $PIECE(SEG,NFS,17)=VAR2
+33 IF $GET(PSJDMU)
SET VAR1=+$GET(DUZ)
if VAR1
Begin DoDot:1
+34 SET VAR2=$PIECE($GET(^VA(200,VAR1,0)),"^")
if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+35 SET $PIECE(SEG,NFS,20)=VAR1_NFS_VAR2
End DoDot:1
+36 SET SEQ=SEQ+1
+37 SET NSEG(SEQ)=SEG
+38 if $DATA(^XTMP("PADE"))
DO DISP
+39 QUIT
+40 ;
RXE ;
+1 NEW DOSE
+2 SET SEG="RXE"
+3 IF RXO["V"
DO IVRXE
QUIT
+4 SET $PIECE(SEG,NFS,2)=$$QT(DFN,RXO,.PS55)
+5 SET $PIECE(SEG,NFS,3)=$$GIVECODE(+$$DSPDRG,NECH)
+6 NEW DOSETMP,MIN,MAX
+7 SET DOSE=$TRANSLATE($PIECE(PS55(.2),"^",2),",")
SET MIN=+DOSE
+8 SET DOSETMP=$TRANSLATE(DOSE," ")
+9 IF DOSETMP["-"
SET MIN=+$PIECE(DOSETMP,"-")
SET MAX=$PIECE(DOSETMP,"-",2,99)
+10 SET $PIECE(SEG,NFS,4)=$SELECT(MIN:MIN,1:"")
+11 SET $PIECE(SEG,NFS,5)=$SELECT($GET(MAX):+$GET(MAX),1:"")
+12 IF '$GET(MAX)
IF $GET(MIN)
IF +$TRANSLATE($PIECE($GET(DOSE),MIN,2,99)," ")
Begin DoDot:1
+13 SET $PIECE(SEG,NFS,6)=DOSE
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 SET DOSETMP=$SELECT($GET(MAX):$PIECE(DOSE,+MAX,2,99),$GET(MIN):$PIECE($GET(DOSE),MIN,2,99),1:DOSE)
+16 IF $EXTRACT(DOSETMP)=" "
SET DOSETMP=$EXTRACT(DOSETMP,2,$LENGTH(DOSETMP))
+17 SET $PIECE(SEG,NFS,6)=DOSETMP
End DoDot:1
+18 SET VAR1=$$GETFORM(.PS55)
+19 SET $PIECE(SEG,NFS,7)=VAR1
+20 NEW PCE
SET PCE=""
+21 IF $DATA(PS55(15))
Begin DoDot:1
+22 NEW PC,I
SET I=0
SET PC=""
FOR
SET I=$ORDER(PS55(15,I))
if 'I
QUIT
Begin DoDot:2
+23 IF PCE]""
SET PCE=PCE_$TRANSLATE(PS55(15,I,0),"|","/")
QUIT
+24 SET PC=PC_$TRANSLATE(PS55(15,I,0),"|","/")
+25 IF $LENGTH(PC)>200
SET PCE=$EXTRACT(PC,201,999)_" "
SET PC=$EXTRACT(PC,1,200)
End DoDot:2
+26 SET $PIECE(SEG,NFS,22)=PC
End DoDot:1
+27 SET $PIECE(SEG,NFS,11)=$PIECE($$DSPDRG,"^",2)
+28 SET VAR1=+$PIECE(PS55(0),"^",2)
SET VAR2=$PIECE($GET(^VA(200,VAR1,0)),"^")
if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
SET VAR1=$$DEA^XUSER(,VAR1)
+29 SET $PIECE(SEG,NFS,14)=VAR1_NECH_VAR2
+30 SET VAR1=$PIECE($GET(PS55(4)),"^",3)
SET VAR2=""
IF VAR1
SET VAR2=$PIECE($GET(^VA(200,+VAR1,0)),"^")
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+31 SET $PIECE(SEG,NFS,15)=VAR1_NECH_VAR2
+32 SET $PIECE(SEG,NFS,16)=RXO
+33 SET SEQ=SEQ+1
+34 SET NSEG(SEQ)=SEG
+35 IF $ORDER(SEG(0))
SET I=0
FOR
SET I=$ORDER(SEG(I))
if 'I
QUIT
SET NSEG(SEQ,I)=SEG(I)
+36 IF $GET(PCE)]""
Begin DoDot:1
+37 SET SEQ=SEQ+1
+38 SET NSEG(SEQ)="NTE"_NFS_NFS_NFS_PCE
End DoDot:1
+39 if $DATA(^XTMP("PADE"))
DO DISP
+40 KILL SEG
+41 QUIT
+42 ;
IVRXE ;
+1 NEW ND0,NDPT2,NDAD,NDSOL,PCE
SET PCE=""
+2 SET ND0=PS55(0)
SET NDPT2=PS55(.2)
SET NDAD=$GET(PS55("AD",1,0))
SET NDSOL=$GET(PS55("SOL",1,0))
+3 SET $PIECE(SEG,NFS,2)=$$QT(DFN,RXO,.PS55)
+4 SET $PIECE(SEG,NFS,3)=$$GIVECODE($SELECT(NDAD:$PIECE(^PS(52.6,+NDAD,0),"^",2),1:$PIECE(^PS(52.7,+NDSOL,0),"^",2)),NECH)
+5 SET $PIECE(SEG,NFS,4)=+$$QT(DFN,RXO,.PS55)
+6 SET $PIECE(SEG,NFS,6)=$TRANSLATE($PIECE($GET(DOSE),+DOSE,2,9)," ")
+7 SET VAR1=+$GET(PS55("AD",1,0))
SET VAR1=+$PIECE($GET(^PS(52.6,VAR1,0)),"^",11)
SET VAR1=+$PIECE($GET(^PS(50.7,VAR1,0)),"^",2)
SET VAR1=$GET(^PS(50.606,VAR1,0))
+8 SET $PIECE(SEG,NFS,7)=VAR1
+9 IF $DATA(PS55(10))
Begin DoDot:1
+10 NEW PC,I
SET I=0
SET PC=""
FOR
SET I=$ORDER(PS55(10,I))
if 'I
QUIT
Begin DoDot:2
+11 IF PCE]""
SET PCE=PCE_$TRANSLATE(PS55(10,I,0),"|","/")
QUIT
+12 SET PC=PC_$TRANSLATE(PS55(10,I,0),"|","/")
+13 IF $LENGTH(PC)>200
SET PCE=$EXTRACT(PC,201,999)_" "
SET PC=$EXTRACT(PC,1,200)
End DoDot:2
+14 SET $PIECE(SEG,NFS,22)=PC
End DoDot:1
+15 SET $PIECE(SEG,NFS,11)=1
+16 SET $PIECE(SEG,NFS,12)="BAG"
+17 SET VAR1=+$PIECE(PS55(0),"^",6)
+18 if VAR1
Begin DoDot:1
+19 SET VAR2=$PIECE($GET(^VA(200,VAR1,0)),"^")
if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+20 SET VAR1=$$DEA^XUSER(,VAR1)
+21 SET $PIECE(SEG,NFS,14)=VAR1_NECH_VAR2
End DoDot:1
+22 SET VAR1=$PIECE($GET(PS55(4)),"^",4)
+23 if VAR1
Begin DoDot:1
+24 SET VAR2=$PIECE($GET(^VA(200,+VAR1,0)),"^")
if VAR2]""
SET VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
+25 SET $PIECE(SEG,NFS,15)=VAR1_NECH_VAR2
End DoDot:1
+26 SET $PIECE(SEG,NFS,16)=RXO
+27 IF $PIECE(PS55(0),"^",15)'=""
SET $PIECE(SEG,NFS,23)="M"_$PIECE(PS55(0),"^",15)
+28 SET VAR1=$PIECE(PS55(0),"^",8)
SET VAR2=$PIECE(VAR1,+VAR1,2)
SET VAR1=+VAR1
+29 IF $EXTRACT(VAR2)=" "
SET VAR2=$PIECE(VAR2," ",2)
+30 IF (VAR2="")!(VAR1=0)
IF $PIECE(PS55(0),"^",8)'=""
SET VAR2=$PIECE(PS55(0),"^",8)
+31 SET $PIECE(SEG,NFS,24)=$SELECT(VAR1=0:"",1:VAR1)
+32 SET $PIECE(SEG,NFS,25)=NECH_VAR2
+33 SET VAR1=$PIECE($GET(PS55("AD",1,0)),"^",2)
SET VAR2=$PIECE(VAR1,+VAR1,2)
+34 IF $EXTRACT(VAR2)=" "
SET VAR2=$PIECE(VAR2," ",2,99)
+35 IF VAR2=""
SET VAR1=$PIECE($GET(PS55("SOL",1,0)),"^",2)
SET VAR2=$PIECE(VAR1,+VAR1,2)
+36 IF $EXTRACT(VAR2)=" "
SET VAR2=$PIECE(VAR2," ",2,99)
+37 SET $PIECE(SEG,NFS,26)=+VAR1
+38 DO CONT(VAR2,27,NFS)
IVC ;
+1 SET SEQ=SEQ+1
+2 SET NSEG(SEQ)=SEG
+3 IF $ORDER(SEG(0))
SET I=0
FOR
SET I=$ORDER(SEG(I))
if 'I
QUIT
SET NSEG(SEQ,I)=SEG(I)
+4 IF $GET(PCE)]""
Begin DoDot:1
+5 SET SEQ=SEQ+1
+6 SET NSEG(SEQ)="NTE"_NFS_NFS_NFS_PCE
End DoDot:1
+7 if $DATA(^XTMP("PADE"))
DO DISP
+8 KILL SEG
+9 QUIT
+10 ;
CONT(VALUE,PIECE,FS) ;
+1 NEW TEMP,TEMP2,NODES,STRING,BEG,END,REM
+2 IF $LENGTH(SEG)+$LENGTH(VALUE)<246
SET $PIECE(SEG,FS,PIECE)=VALUE
QUIT
+3 SET TEMP=SEG_FS_VALUE
+4 SET SEG=$EXTRACT(TEMP,1,245)
+5 SET STRING=$EXTRACT(TEMP,246,$LENGTH(TEMP))
SET NODES=$LENGTH(STRING)\245
SET REM=$LENGTH(STRING)#245
SET BEG=1
SET END=245
IF REM
SET NODES=NODES+1
+6 FOR TEMP2=1:1:NODES
SET SEG(TEMP2)=$EXTRACT(STRING,BEG,END)
SET BEG=BEG+245
SET END=END+245
+7 QUIT
+8 ;
RXR ;
+1 SET SEG="RXR"
+2 SET VAR1=$SELECT(RXO["U":$PIECE(PS55(0),"^",3),1:$PIECE(PS55(.2),"^",3))
+3 SET VAR1=$GET(^PS(51.2,+VAR1,0))
SET VAR2=$PIECE(VAR1,"^")
SET VAR1=$PIECE(VAR1,"^",3)
+4 SET $PIECE(SEG,NFS,2)=VAR1_NECH_VAR2_NECH_"99PSR"
+5 SET SEQ=SEQ+1
+6 SET NSEG(SEQ)=SEG
+7 if $DATA(^XTMP("PADE"))
DO DISP
+8 QUIT
+9 ;
RXC ;
+1 DO RXC^PSJPADE
+2 QUIT
+3 ;
IVRXC ;
+1 NEW D,X,PSJDD,PSJADSO,FIL
+2 FOR PSJADSO="SOL","AD"
SET D=0
FOR
SET D=$ORDER(PS55(PSJADSO,D))
if 'D
QUIT
SET PSJDD=$PIECE(PS55(PSJADSO,D,0),"^")
Begin DoDot:1
+3 if 'PSJDD
QUIT
+4 SET FIL=$SELECT(PSJADSO="AD":52.6,1:52.7)
SET PSJDD=^PS(FIL,PSJDD,0)
SET PSJDD=$PIECE(PSJDD,"^",2)
+5 SET SEG="RXC"_NFS_$SELECT(PSJADSO="AD":"A",1:"B")
+6 SET $PIECE(SEG,NFS,3)=$$GIVECODE(PSJDD,NECH)
+7 SET VAR1=$PIECE(PS55(PSJADSO,D,0),"^",2)
SET VAR2=$PIECE(VAR1,+VAR1,2)
+8 if $EXTRACT(VAR2)=" "
SET VAR2=$PIECE(VAR2," ",2)
+9 SET $PIECE(SEG,NFS,4)=+VAR1
+10 SET $PIECE(SEG,NFS,5)=NECH_VAR2
+11 SET VAR1=$GET(^PSDRUG(PSJDD,"DOS"))
SET X=+$PIECE(VAR1,"^",2)
+12 IF X
SET VAR2=$PIECE($GET(^PS(50.607,X,0)),"^")
SET VAR2=X_NECH_VAR2_NECH_"99PSU"
+13 IF VAR1
SET $PIECE(SEG,NFS,6)=+VAR1
SET $PIECE(SEG,NFS,7)=VAR2
+14 SET SEQ=SEQ+1
+15 SET NSEG(SEQ)=SEG
+16 if $DATA(^XTMP("PADE"))
DO DISP
End DoDot:1
+17 QUIT
+18 ;
ZRX ;
+1 SET STATUS=$SELECT(RXO["U":$PIECE(PS55(0),"^",9),1:$PIECE(PS55(0),"^",17))
+2 SET VAR1=$SELECT($GET(PDTYP)="SN":"N",STATUS["E"!(STATUS["D"):"O",1:"F")
+3 SET SEG="ZRX"_NFS_VAR1_NFS_+PDHDT
+4 SET SEQ=SEQ+1
+5 SET NSEG(SEQ)=SEG
+6 if $DATA(^XTMP("PADE"))
DO DISP
+7 QUIT
+8 ;
GETFORM(PSJ55) ;
+1 NEW X
+2 SET X=+$PIECE($GET(^PSDRUG(+$$DSPDRG,2)),"^")
+3 IF X
SET X=+$PIECE($GET(^PS(50.7,X,0)),"^",2)
SET VAR1=$PIECE($GET(^PS(50.606,X,0)),"^")
+4 IF VAR1=""
SET VAR1=$PIECE($GET(^PSDRUG(+$$DSPDRG,660)),"^",8)
+5 IF VAR1=""
SET X=$PIECE($GET(^PSDRUG(+$$DSPDRG,"ND")),"^",3)
if X
SET VAR1=$PIECE($$PROD2^PSNAPIS(,X),"^",4)
+6 QUIT VAR1
+7 ;
QT(DFN,RXO,PS55) ;
+1 SET VAR1=""
+2 IF RXO["U"
Begin DoDot:1
+3 SET DOSE=$TRANSLATE($PIECE($GET(PS55(.2)),"^",2),",")
+4 NEW AT,NAT
SET AT=$TRANSLATE($PIECE(PS55(2),"^",5),"-",",")
SET NAT=""
+5 IF AT
NEW I,J
FOR I=1:1:$LENGTH(AT,",")
SET J=$PIECE(AT,",",I)
Begin DoDot:2
+6 SET J=$SELECT($LENGTH(J)=2:J_"00",1:J)
+7 SET $PIECE(NAT,",",I)=J
End DoDot:2
+8 SET VAR1=+DOSE_NECH_$$ESC($PIECE(PS55(2),"^"))_NSCS_NAT_NECH_NECH
+9 SET VAR1=VAR1_+$$HLDATE^HLFNC($PIECE(PS55(2),"^",2),"TS")_NECH_+$$HLDATE^HLFNC($PIECE(PS55(2),"^",4),"TS")_NECH
+10 SET VAR2=$$PRNOK^PSGS0($PIECE(PS55(2),"^"))
+11 SET VAR1=VAR1_NECH_VAR2_NECH_$$DOWSTR^PSJPDCLV($PIECE(PS55(2),"^"))
End DoDot:1
QUIT VAR1
+12 IF RXO["V"
Begin DoDot:1
+13 SET ND0=PS55(0)
SET NDPT2=PS55(.2)
SET NDAD=$GET(PS55("AD",1,0))
SET NDSOL=$GET(PS55("SOL",1,0))
+14 SET DOSE=$PIECE($GET(PS55("AD",1,0)),"^",2)
SET VAR2=$TRANSLATE($PIECE(DOSE,+DOSE,2,9)," ")
+15 IF VAR2=""
SET DOSE=$PIECE($GET(PS55("SOL",1,0)),"^",2)
SET VAR2=$TRANSLATE($PIECE(DOSE,+DOSE,2,9)," ")
+16 NEW AT,NAT
SET AT=$TRANSLATE($PIECE(PS55(0),"^",11),"-",",")
SET NAT=""
+17 IF AT
NEW I,J
FOR I=1:1:$LENGTH(AT,",")
SET J=$PIECE(AT,",",I)
Begin DoDot:2
+18 SET J=$SELECT($LENGTH(J)=2:J_"00",1:J)
+19 SET $PIECE(NAT,",",I)=J
End DoDot:2
+20 SET VAR1=+DOSE_NSCS_VAR2_NECH_$SELECT(($PIECE(PS55(0),"^",9)]""):$PIECE(PS55(0),"^",9),1:"C")_NSCS_NAT_NECH_NECH
+21 SET VAR1=VAR1_+$$HLDATE^HLFNC($PIECE(PS55(0),"^",2))_NECH_+$$HLDATE^HLFNC($PIECE(PS55(0),"^",3))
+22 SET VAR2=$$PRNOK^PSGS0($PIECE(PS55(2),"^"))
+23 ;p438 priority
NEW VAR3
SET VAR3=$PIECE(PS55(.2),"^",4)
+24 ;p438 appended priority
SET VAR1=VAR1_NECH_NECH_VAR2_NECH_$$DOWSTR^PSJPDCLV($PIECE(PS55(0),"^",9))_NECH_VAR3
End DoDot:1
QUIT VAR1
+25 QUIT
+26 ;
DSPDRG() ;
+1 NEW I,J
SET I=0
SET J=999999
+2 FOR
SET J=$ORDER(PS55(1,J),-1)
if J=0
QUIT
Begin DoDot:1
+3 ;inactive drug
IF $PIECE(PS55(1,J,0),"^",3)
IF $PIECE(PS55(1,J,0),"^",3)'>DT
QUIT
+4 SET I=J
End DoDot:1
if I
QUIT
+5 if 'I
SET I=1
+6 QUIT $GET(PS55(1,I,0))
+7 ;
GIVECODE(ID,CS) ;
+1 NEW DRGID,DRGNM,DRGNM2,DRGSTR,DRUGND
+2 if '$DATA(^PSDRUG(ID))
QUIT ""
+3 SET DRUGND=$GET(^PSDRUG(ID,"ND"))
+4 SET DRGNM=$$ESC($PIECE($GET(^PSDRUG(ID,0)),"^"))
SET PDL(14)=ID
+5 SET DRGSTR=ID_CS_DRGNM_CS_"99PSD"
+6 SET DRGNM2=$$ESC($PIECE(DRUGND,"^",2))
+7 SET DRGID=$PIECE(DRUGND,"^",3)
+8 SET DRGSTR=DRGSTR_CS_DRGID_CS_DRGNM2_CS_"99PSP"
+9 QUIT DRGSTR
+10 ;
DISP ;
+1 if '$DATA(^XUSEC("PSJ PADE MGR",DUZ))
QUIT
+2 DO FULL^VALM1
+3 WRITE !!,?5,"THIS IS THE PADE "_$PIECE(NSEG(SEQ),NFS)_" SEGMENT."
+4 NEW TR,TX
FOR TR=1:1:$LENGTH(NSEG(SEQ),NFS)
SET TX=$PIECE(NSEG(SEQ),NFS,TR)
WRITE !,$PIECE(NSEG(SEQ),NFS)_"-"_(TR-1)_$SELECT(TR<10:"= ",1:"=")_TX
+5 DO PAUSE^VALM1
+6 QUIT
+7 ;
ESC(VAL) ;
+1 NEW NVAL
+2 SET NVAL=""
FOR I=1:1:$LENGTH(VAL)
SET NVAL=NVAL_$SELECT($EXTRACT(VAL,I)="&":"\T\",1:$EXTRACT(VAL,I))
+3 QUIT NVAL
