- 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 Feb 18, 2025@23:35:06 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