PSJBCMA ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;16 Mar 99 / 10:13 AM
;;5.0; INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,69,58,81,91,104,111,112,186,159,173,190**;16 DEC 97;Build 12
;
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PS(51 is supported by DBIA 2176.
; Reference to ^PS(51.1 is supported by DIBA 2177.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Reference to ^PS(52.6 is supported by DBIA 1231.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PSDRUG is supported by DBIA 2192.
; Usage of this routine by BCMA is supported by DBIA 2828.
;
EN(DFN,BDT,OTDATE) ; return condensed list of inpat meds
NEW CNT,DN,F,FON,ON,PST,WBDT,X,X1,X2,Y,%
D:+$G(DFN) ORDER
I '$D(^TMP("PSJ",$J,1,0)) S ^(0)=-1
K PSJINX
Q
ORDER ;Loop thru orders.
I '+$G(BDT) D NOW^%DTC S BDT=%
I BDT'["." S BDT=BDT_".0001"
S PSJINX=0
;U/D orders
S F="^PS(55,DFN,5,",WBDT=BDT
F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT D
. F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON S FON=ON_"U",PSJON(FON)="" D UDVAR
;IV orders
S F="^PS(55,DFN,""IV"",",WBDT=BDT
F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT D
. F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON S FON=ON_"V",PSJON(FON)="" D IVVAR
;Pending orders
S F="^PS(53.1,"
F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D
. S FON=ON_"P"
. S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="F":"IVVAR",1:"UDVAR")
;When a one-time order is found, check against PSJON(FON) array to
;make sure no duplicates return on ^TMP.
I '+$G(OTDATE) D NOW^%DTC S X1=$E(%,1,12),X2=-30 D C^%DTC S OTDATE=X
I OTDATE'["." S OTDATE=OTDATE_".0001"
Q:BDT'>OTDATE
S F="^PS(55,DFN,5,",WBDT=OTDATE
F S WBDT=$O(^PS(55,DFN,5,"AU","O",WBDT)) Q:'WBDT D
. F ON=0:0 S ON=$O(^PS(55,DFN,5,"AU","O",WBDT,ON)) Q:'ON D
.. S FON=ON_"U" D:'$D(PSJON(FON)) UDVAR
S F="^PS(55,DFN,""IV"",",WBDT=OTDATE
F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT D
. F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D
.. S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,9)
.. I X]"",$$ONE(DFN,ON_"V",X,$P(X,"^",2),$P(X,"^",3))="O" D
... S FON=ON_"V" D:'$D(PSJON(FON)) IVVAR
K PSJON
Q
UDVAR ;Set ^TMP for Unit dose & Pending orders
D UDPEND Q:'$$CLINICS($G(CLINIC))
D TMP
;Setup Dispense drug for ^TMP
S CNT=0 D NOW^%DTC
F X=0:0 S X=$O(@(F_ON_",1,"_X_")")) Q:'X D
. S PSJDD=@(F_ON_",1,"_X_",0)") I $P(PSJDD,"^",3)]"",$P(PSJDD,"^",3)'>% Q
. S CNT=CNT+1
. S ^TMP("PSJ",$J,PSJINX,700,CNT,0)=+PSJDD_U_$P($G(^PSDRUG(+PSJDD,0)),U)_U_$S((FON["U")&($P(PSJDD,U,2)=""):1,(FON["U")&($E($P(PSJDD,U,2))="."):"0"_$P(PSJDD,U,2),1:$P(PSJDD,U,2))_U_$P(PSJDD,U,3)
S:CNT ^TMP("PSJ",$J,PSJINX,700,0)=CNT
K PSJ,PSJDD
Q
IVVAR ;Set variables for IV and pending orders
NEW ND,X,Y
I FON["P" D UDPEND Q:'$$CLINICS(CLINIC) S PSJ("INFRATE")=$P($G(^PS(53.1,ON,8)),U,5)
I FON["V" D Q:'$$CLINICS(CLINIC)
. S X=$G(^PS(55,DFN,"IV",ON,0)),CLINIC=$G(^("DSS")) Q:'$$CLINICS(CLINIC)
. S PSJ("STARTDT")=$P(X,U,2),PSJ("STOPDT")=$P(X,U,3)
. S PSJ("INFRATE")=$P(X,U,8),PSJ("SCHD")=$P(X,U,9)
. S PSJ("ADM")=$P(X,U,11),PSJ("AUTO")=$P(X,U,12),PSJ("STATUS")=$P(X,U,17)
. S PSJ("IVTYPE")=$P(X,U,4),PSJ("INSYR")=$P(X,U,5)
. S PSJ("CPRS")=$P(X,U,21),PSJ("CHEMO")=$P(X,U,23)
. S X=$G(^PS(55,DFN,"IV",ON,.2))
. S PSJ("DO")="",PSJ("MR")=$P(X,U,3),PSJ("PRI")=$P(X,U,4),PSJ("FLG")=$P(X,U,7),PSJ("COM")="",PSJ("SRC")=""
. I PSJ("FLG") D
.. N S1,A,B,C
.. S S1="" F S S1=$O(^PS(55,DFN,"IV",ON,"A",S1),-1) Q:'S1 S C=$G(^(S1,0)) S A=$P(C,U,2),B=$P(C,U,4) Q:A="UG" D I PSJ("SRC")]"" Q
... Q:A'="G"
... S PSJ("SRC")=$S(B["FLAGGED BY PHARM":"PHARMACIST",B["FLAGGED BY CPRS":"CPRS",1:"")
... S PSJ("COM")=$P(B," ",4,99)
. S PSJ("OI")=+X
. S X=$G(^PS(55,DFN,"IV",ON,2))
. S PSJ("PREV")=$P(X,U,5) I PSJ("PREV")["V",(+PSJ("PREV")=+ON) S PSJ("PREV")=""
. S PSJ("FOLLOW")=$P(X,U,6),PSJ("RFO")=$P(X,U,9) I PSJ("FOLLOW")["V",(+PSJ("FOLLOW")=+ON) S (PSJ("FOLLOW"),PSJ("RFO"))=""
. S PSJ("SIOPI")=$S($P($G(^PS(55,DFN,"IV",+ON,3)),"^",2)&($P($G(^PS(55,DFN,"IV",+ON,3)),"^")'=""):"!",1:"")_$P($G(^(3)),"^")
. N SCHD S SCHD=PSJ("SCHD")
. S PSJ("STC")=$$ONE(DFN,ON_"V",SCHD,PSJ("STARTDT"),PSJ("STOPDT"))
. I PSJ("STC")=""!(PSJ("STC")="C") S PSJ("STC")=$S(SCHD["PRN":"P",1:"C")
. I PSJ("STC")="C" S PSJ("STC")=$S(SCHD["ON CALL":"OC",SCHD["ON-CALL":"OC",SCHD["ONCALL":"OC",1:"C")
D TMP
S CNT=0
F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X D
. S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$G(^PS(52.6,+ND,0))
. S CNT=CNT+1,^TMP("PSJ",$J,PSJINX,850,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(ND,U,3)
S:CNT ^TMP("PSJ",$J,PSJINX,850,0)=CNT,CNT=0
F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X D
. S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0))
. S CNT=CNT+1,^TMP("PSJ",$J,PSJINX,950,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
S:CNT ^TMP("PSJ",$J,PSJINX,950,0)=CNT
K PSJ
S X1=0
F S X1=$O(^PS(55,DFN,"IVBCMA",X1)) Q:'X1 D
. S XX=$G(^PS(55,DFN,"IVBCMA",X1,0)) Q:ON'=$P(XX,"^",2) S PSJBCID=$P(XX,"^"),X2=0
. F I=1:1 S X2=$O(^PS(55,DFN,"IVBCMA",X1,"AD",X2)) Q:'X2 S X=^(X2,0),^TMP("PSJ",$J,PSJINX,800,PSJBCID,I)=+X_"^"_$S($D(^PS(52.6,+X,0)):$P(^(0),"^"),1:"*****")_"^"_$P(X,"^",2,99)
. I I>1 S ^TMP("PSJ",$J,PSJINX,800,PSJBCID,0)=I-1
. S X2=0
. F I=1:1 S X2=$O(^PS(55,DFN,"IVBCMA",X1,"SOL",X2)) Q:'X2 S X=^(X2,0),^TMP("PSJ",$J,PSJINX,900,PSJBCID,I)=$P(X,"^")_"^"_$S($D(^PS(52.7,$P(X,"^"),0)):$P(^(0),"^"),1:"*****")_"^"_$P(X,"^",2,99)
. I I>1 S ^TMP("PSJ",$J,PSJINX,900,PSJBCID,0)=I-1
Q
UDPEND ;
S X=$G(@(F_ON_",0)")) I $P(F,",")[53.1 S CLINIC=$G(@(F_ON_",""DSS"")")) Q:'$$CLINICS(CLINIC)
I $P(F,",")[55 S CLINIC=$G(@(F_ON_",8)")) Q:'$$CLINICS(CLINIC)
S PSJ("MR")=$P(X,U,3),PSJ("SM")=$P(X,U,5),PSJ("HSM")=$P(X,U,6)
S PSJ("ST")=$P(X,U,7),PSJ("STATUS")=$P(X,U,9)
S PSJ("CPRS")=$P(X,U,21),PSJ("PREV")=$P(X,U,25),PSJ("FOLLOW")=$P(X,U,26),PSJ("RFO")=$P(X,U,27)
S:FON["U" PSJ("NGIVEN")=$P(X,U,22)
S X=$G(@(F_ON_",.2)"))
S PSJ("DO")=$P(X,U,2),PSJ("PRI")=$P(X,U,4),PSJ("FLG")=$P(X,U,7),PSJ("COM")="",PSJ("SRC")=""
I PSJ("FLG") D
. N S1,A,B,C
. S S1="" F S S1=$O(^PS(55,DFN,5,ON,9,S1),-1) Q:'S1 S C=$G(^(S1,0)) S A=$P(C,U,3),B=$P(C,U,4) Q:A=7010!(A=7030) D I PSJ("SRC")]"" Q
.. Q:A'=7000&(A'=7020)
.. S PSJ("SRC")=$S(A=7000:"PHARMACIST",A=7020:"CPRS",1:"")
.. S PSJ("COM")=$G(@(F_ON_",13)"))
S PSJ("OI")=+X
S X=$G(@(F_ON_",2)"))
S PSJ("SCHD")=$P(X,U),PSJ("STARTDT")=$P(X,U,2)
S PSJ("STOPDT")=$P(X,U,4),PSJ("ADM")=$P(X,U,5)
S X=$G(@(F_ON_",4)"))
S PSJ("AUTO")=$P(X,U,11)
;naked reference on line below refers to full reference created by indirect reference to F_ON, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
S PSJ("SIOPI")=$S($P($G(@(F_ON_",6)")),"^",2)&($P($G(@(F_ON_",6)")),"^")'=""):"!",1:"")_$$ENSET($P($G(^(6)),"^"))
D SIOPI
S PSJ("STC")=PSJ("ST")
I PSJ("ST")="R"!(PSJ("ST")="C") S PSJ("STC")=$S(PSJ("SCHD")["PRN":"P","^ONCALL^ON-CALL^ON CALL^"[("^"_PSJ("SCHD")_"^"):"OC",$$ONE(DFN,FON,PSJ("SCHD"))="O":"O",1:"C")
Q
TMP ;Setup ^TMP that have common fields between IV and U/D
N A
S PSJINX=PSJINX+1
S PSJ("OINAME")=$$OIDF^PSJLMUT1(+PSJ("OI")) I PSJ("OINAME")["NOT FOUND" S PSJ("OINAME")=""
S PSJ("OIDF")=$$GET1^DIQ(50.7,+PSJ("OI"),.02)
I PSJ("OINAME")="" S PSJ("OIDF")=""
S A=$G(^PS(51.2,+PSJ("MR"),0)),PSJ("MRABB")=$P(A,U,3),PSJ("MRNM")=$P(A,U)
S ^TMP("PSJ",$J,PSJINX,0)=DFN_U_+ON_U_FON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$G(PSJ("IVTYPE"))_U_$G(PSJ("INSYR"))_U_$G(PSJ("CHEMO"))_U_PSJ("CPRS")_U_$G(PSJ("RFO"))
S ^TMP("PSJ",$J,PSJINX,1)=PSJ("MRABB")_U_PSJ("STC")_U_$G(PSJ("SCHD"))_U_PSJ("STARTDT")_U_PSJ("STOPDT")_U_PSJ("ADM")_U_PSJ("STATUS")_U_$G(PSJ("NGIVEN"))_U_$G(PSJ("ST"))_U_$G(PSJ("AUTO"))
S ^TMP("PSJ",$J,PSJINX,1,0)=$P(A,U,8)_U_PSJ("MRNM")_U_$P(A,U,9)
S ^TMP("PSJ",$J,PSJINX,2)=PSJ("DO")_U_$G(PSJ("INFRATE"))_U_$G(PSJ("SM"))_U_$G(PSJ("HSM"))
S ^TMP("PSJ",$J,PSJINX,3)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("OIDF")
S ^TMP("PSJ",$J,PSJINX,4)=PSJ("SIOPI")
S A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
S ^TMP("PSJ",$J,PSJINX,5)=$S(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
Q
SIOPI ; Use provider comments if order is pending and there is no SI
NEW X,Y,Z
I FON["P",(PSJ("SIOPI")=""),$O(^PS(53.1,+ON,12,0)) D
. F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X S Z=$G(^(X,0)) D
.. S Y=$L(PSJ("SIOPI"))
.. S:Y+$L(Z)'>179 PSJ("SIOPI")=PSJ("SIOPI")_Z_""
. I Y+$L(Z)>179 S PSJ("SIOPI")="SEE PROVIDER COMMENTS"
Q
ENSET(X) ; expands SPECIAL INSTRUCTIONS field contained in X into Y
N X1,X2,Y S Y=""
F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
S Y=$E(Y,1,$L(Y)-1)
Q Y
ONE(DFN,ORD,SCH,START,STOP) ;Is order a one-time
; Input: DFN - patient's IEN
; ORD - order number
; SCH - schedule text (required)
; START - order start date (optional)
; STOP - order stop date (optional)
N X,ONEFRQ,TYP,T
I $G(PSJ("PREV")),$G(PSJ("FOLLOW")) I +PSJ("PREV")=+PSJ("FOLLOW") S (PSJ("PREV"),PSJ("FOLLOW"))=""
; PSJ*5*190 One-Time PRN
I $G(SCH)="",$G(DFN),$G(ORD) D
.I ORD["U" S SCH=$P($G(^PS(55,DFN,5,+ORD,2)),"^")
.I ORD["V" S SCH=$P($G(^PS(55,DFN,"IV",+ORD,0)),"^",9)
I $G(SCH)]"",$$OTPRN^PSJBCMA3(SCH)="O" Q "O"
I $G(DFN)]"",$G(ORD)]"",ORD["U",$P(^PS(55,DFN,5,+ORD,0),"^",7)'="R" Q $P(^PS(55,DFN,5,+ORD,0),"^",7)
I $G(SCH)="" Q ""
I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="D":"C",1:X)
I $G(START)]"",$G(STOP)]"",START=STOP Q "O"
Q ""
CLINIC(CL) ;
I $P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N) Q 1
Q 0
CLINICS(CL) ;
Q:'$$CLINIC(CL) 1
Q:'$D(^PS(53.46,"B",+CL)) 1
N A
S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 1
Q $P(^PS(53.46,A,0),"^",4)
PSJBCMA ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;16 Mar 99 / 10:13 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,69,58,81,91,104,111,112,186,159,173,190**;16 DEC 97;Build 12
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+4 ; Reference to ^PS(51 is supported by DBIA 2176.
+5 ; Reference to ^PS(51.1 is supported by DIBA 2177.
+6 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+7 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+8 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+9 ; Reference to ^PS(55 is supported by DBIA 2191.
+10 ; Reference to ^PSDRUG is supported by DBIA 2192.
+11 ; Usage of this routine by BCMA is supported by DBIA 2828.
+12 ;
EN(DFN,BDT,OTDATE) ; return condensed list of inpat meds
+1 NEW CNT,DN,F,FON,ON,PST,WBDT,X,X1,X2,Y,%
+2 IF +$GET(DFN)
DO ORDER
+3 IF '$DATA(^TMP("PSJ",$JOB,1,0))
SET ^(0)=-1
+4 KILL PSJINX
+5 QUIT
ORDER ;Loop thru orders.
+1 IF '+$GET(BDT)
DO NOW^%DTC
SET BDT=%
+2 IF BDT'["."
SET BDT=BDT_".0001"
+3 SET PSJINX=0
+4 ;U/D orders
+5 SET F="^PS(55,DFN,5,"
SET WBDT=BDT
+6 FOR
SET WBDT=$ORDER(^PS(55,DFN,5,"AUS",WBDT))
IF 'WBDT
QUIT
Begin DoDot:1
+7 FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,5,"AUS",WBDT,ON))
IF 'ON
QUIT
SET FON=ON_"U"
SET PSJON(FON)=""
DO UDVAR
End DoDot:1
+8 ;IV orders
+9 SET F="^PS(55,DFN,""IV"","
SET WBDT=BDT
+10 FOR
SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
IF 'WBDT
QUIT
Begin DoDot:1
+11 FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
IF 'ON
QUIT
SET FON=ON_"V"
SET PSJON(FON)=""
DO IVVAR
End DoDot:1
+12 ;Pending orders
+13 SET F="^PS(53.1,"
+14 FOR PST="P","N"
FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS",PST,DFN,ON))
IF 'ON
QUIT
Begin DoDot:1
+15 SET FON=ON_"P"
+16 SET X=$PIECE($GET(^PS(53.1,+ON,0)),U,4)
DO @$SELECT(X="F":"IVVAR",1:"UDVAR")
End DoDot:1
+17 ;When a one-time order is found, check against PSJON(FON) array to
+18 ;make sure no duplicates return on ^TMP.
+19 IF '+$GET(OTDATE)
DO NOW^%DTC
SET X1=$EXTRACT(%,1,12)
SET X2=-30
DO C^%DTC
SET OTDATE=X
+20 IF OTDATE'["."
SET OTDATE=OTDATE_".0001"
+21 IF BDT'>OTDATE
QUIT
+22 SET F="^PS(55,DFN,5,"
SET WBDT=OTDATE
+23 FOR
SET WBDT=$ORDER(^PS(55,DFN,5,"AU","O",WBDT))
IF 'WBDT
QUIT
Begin DoDot:1
+24 FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,5,"AU","O",WBDT,ON))
IF 'ON
QUIT
Begin DoDot:2
+25 SET FON=ON_"U"
IF '$DATA(PSJON(FON))
DO UDVAR
End DoDot:2
End DoDot:1
+26 SET F="^PS(55,DFN,""IV"","
SET WBDT=OTDATE
+27 FOR
SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
IF 'WBDT
QUIT
Begin DoDot:1
+28 FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
IF 'ON
QUIT
Begin DoDot:2
+29 SET X=$PIECE($GET(^PS(55,DFN,"IV",ON,0)),U,9)
+30 IF X]""
IF $$ONE(DFN,ON_"V",X,$PIECE(X,"^",2),$PIECE(X,"^",3))="O"
Begin DoDot:3
+31 SET FON=ON_"V"
IF '$DATA(PSJON(FON))
DO IVVAR
End DoDot:3
End DoDot:2
End DoDot:1
+32 KILL PSJON
+33 QUIT
UDVAR ;Set ^TMP for Unit dose & Pending orders
+1 DO UDPEND
IF '$$CLINICS($GET(CLINIC))
QUIT
+2 DO TMP
+3 ;Setup Dispense drug for ^TMP
+4 SET CNT=0
DO NOW^%DTC
+5 FOR X=0:0
SET X=$ORDER(@(F_ON_",1,"_X_")"))
IF 'X
QUIT
Begin DoDot:1
+6 SET PSJDD=@(F_ON_",1,"_X_",0)")
IF $PIECE(PSJDD,"^",3)]""
IF $PIECE(PSJDD,"^",3)'>%
QUIT
+7 SET CNT=CNT+1
+8 SET ^TMP("PSJ",$JOB,PSJINX,700,CNT,0)=+PSJDD_U_$PIECE($GET(^PSDRUG(+PSJDD,0)),U)_U_$SELECT((FON["U")&($PIECE(PSJDD,U,2)=""):1,(FON["U")&($EXTRACT($PIECE(PSJDD,U,2))="."):"0"_$PIECE(PSJDD,U,2),1:$PIECE(PSJDD,U,2))_U_$PIECE(PSJDD,U,3)
End DoDot:1
+9 IF CNT
SET ^TMP("PSJ",$JOB,PSJINX,700,0)=CNT
+10 KILL PSJ,PSJDD
+11 QUIT
IVVAR ;Set variables for IV and pending orders
+1 NEW ND,X,Y
+2 IF FON["P"
DO UDPEND
IF '$$CLINICS(CLINIC)
QUIT
SET PSJ("INFRATE")=$PIECE($GET(^PS(53.1,ON,8)),U,5)
+3 IF FON["V"
Begin DoDot:1
+4 SET X=$GET(^PS(55,DFN,"IV",ON,0))
SET CLINIC=$GET(^("DSS"))
IF '$$CLINICS(CLINIC)
QUIT
+5 SET PSJ("STARTDT")=$PIECE(X,U,2)
SET PSJ("STOPDT")=$PIECE(X,U,3)
+6 SET PSJ("INFRATE")=$PIECE(X,U,8)
SET PSJ("SCHD")=$PIECE(X,U,9)
+7 SET PSJ("ADM")=$PIECE(X,U,11)
SET PSJ("AUTO")=$PIECE(X,U,12)
SET PSJ("STATUS")=$PIECE(X,U,17)
+8 SET PSJ("IVTYPE")=$PIECE(X,U,4)
SET PSJ("INSYR")=$PIECE(X,U,5)
+9 SET PSJ("CPRS")=$PIECE(X,U,21)
SET PSJ("CHEMO")=$PIECE(X,U,23)
+10 SET X=$GET(^PS(55,DFN,"IV",ON,.2))
+11 SET PSJ("DO")=""
SET PSJ("MR")=$PIECE(X,U,3)
SET PSJ("PRI")=$PIECE(X,U,4)
SET PSJ("FLG")=$PIECE(X,U,7)
SET PSJ("COM")=""
SET PSJ("SRC")=""
+12 IF PSJ("FLG")
Begin DoDot:2
+13 NEW S1,A,B,C
+14 SET S1=""
FOR
SET S1=$ORDER(^PS(55,DFN,"IV",ON,"A",S1),-1)
IF 'S1
QUIT
SET C=$GET(^(S1,0))
SET A=$PIECE(C,U,2)
SET B=$PIECE(C,U,4)
IF A="UG"
QUIT
Begin DoDot:3
+15 IF A'="G"
QUIT
+16 SET PSJ("SRC")=$SELECT(B["FLAGGED BY PHARM":"PHARMACIST",B["FLAGGED BY CPRS":"CPRS",1:"")
+17 SET PSJ("COM")=$PIECE(B," ",4,99)
End DoDot:3
IF PSJ("SRC")]""
QUIT
End DoDot:2
+18 SET PSJ("OI")=+X
+19 SET X=$GET(^PS(55,DFN,"IV",ON,2))
+20 SET PSJ("PREV")=$PIECE(X,U,5)
IF PSJ("PREV")["V"
IF (+PSJ("PREV")=+ON)
SET PSJ("PREV")=""
+21 SET PSJ("FOLLOW")=$PIECE(X,U,6)
SET PSJ("RFO")=$PIECE(X,U,9)
IF PSJ("FOLLOW")["V"
IF (+PSJ("FOLLOW")=+ON)
SET (PSJ("FOLLOW"),PSJ("RFO"))=""
+22 SET PSJ("SIOPI")=$SELECT($PIECE($GET(^PS(55,DFN,"IV",+ON,3)),"^",2)&($PIECE($GET(^PS(55,DFN,"IV",+ON,3)),"^")'=""):"!",1:"")_$PIECE($GET(^(3)),"^")
+23 NEW SCHD
SET SCHD=PSJ("SCHD")
+24 SET PSJ("STC")=$$ONE(DFN,ON_"V",SCHD,PSJ("STARTDT"),PSJ("STOPDT"))
+25 IF PSJ("STC")=""!(PSJ("STC")="C")
SET PSJ("STC")=$SELECT(SCHD["PRN":"P",1:"C")
+26 IF PSJ("STC")="C"
SET PSJ("STC")=$SELECT(SCHD["ON CALL":"OC",SCHD["ON-CALL":"OC",SCHD["ONCALL":"OC",1:"C")
End DoDot:1
IF '$$CLINICS(CLINIC)
QUIT
+27 DO TMP
+28 SET CNT=0
+29 FOR X=0:0
SET X=$ORDER(@(F_ON_",""AD"","_X_")"))
IF 'X
QUIT
Begin DoDot:1
+30 SET ND=$GET(@(F_ON_",""AD"","_X_",0)"))
SET DN=$GET(^PS(52.6,+ND,0))
+31 SET CNT=CNT+1
SET ^TMP("PSJ",$JOB,PSJINX,850,CNT,0)=+ND_U_$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(ND,U,3)
End DoDot:1
+32 IF CNT
SET ^TMP("PSJ",$JOB,PSJINX,850,0)=CNT
SET CNT=0
+33 FOR X=0:0
SET X=$ORDER(@(F_ON_",""SOL"","_X_")"))
IF 'X
QUIT
Begin DoDot:1
+34 SET ND=$GET(@(F_ON_",""SOL"","_X_",0)"))
SET DN=$GET(^PS(52.7,+ND,0))
+35 SET CNT=CNT+1
SET ^TMP("PSJ",$JOB,PSJINX,950,CNT,0)=+ND_U_$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(DN,U,4)
End DoDot:1
+36 IF CNT
SET ^TMP("PSJ",$JOB,PSJINX,950,0)=CNT
+37 KILL PSJ
+38 SET X1=0
+39 FOR
SET X1=$ORDER(^PS(55,DFN,"IVBCMA",X1))
IF 'X1
QUIT
Begin DoDot:1
+40 SET XX=$GET(^PS(55,DFN,"IVBCMA",X1,0))
IF ON'=$PIECE(XX,"^",2)
QUIT
SET PSJBCID=$PIECE(XX,"^")
SET X2=0
+41 FOR I=1:1
SET X2=$ORDER(^PS(55,DFN,"IVBCMA",X1,"AD",X2))
IF 'X2
QUIT
SET X=^(X2,0)
SET ^TMP("PSJ",$JOB,PSJINX,800,PSJBCID,I)=+X_"^"_$SELECT($DATA(^PS(52.6,+X,0)):$PIECE(^(0),"^"),1:"*****")_"^"_$PIECE(X,"^",2,99)
+42 IF I>1
SET ^TMP("PSJ",$JOB,PSJINX,800,PSJBCID,0)=I-1
+43 SET X2=0
+44 FOR I=1:1
SET X2=$ORDER(^PS(55,DFN,"IVBCMA",X1,"SOL",X2))
IF 'X2
QUIT
SET X=^(X2,0)
SET ^TMP("PSJ",$JOB,PSJINX,900,PSJBCID,I)=$PIECE(X,"^")_"^"_$SELECT($DATA(^PS(52.7,$PIECE(X,"^"),0)):$PIECE(^(0),"^"),1:"*****")_"^"_$PIECE(X,"^",2,99)
+45 IF I>1
SET ^TMP("PSJ",$JOB,PSJINX,900,PSJBCID,0)=I-1
End DoDot:1
+46 QUIT
UDPEND ;
+1 SET X=$GET(@(F_ON_",0)"))
IF $PIECE(F,",")[53.1
SET CLINIC=$GET(@(F_ON_",""DSS"")"))
IF '$$CLINICS(CLINIC)
QUIT
+2 IF $PIECE(F,",")[55
SET CLINIC=$GET(@(F_ON_",8)"))
IF '$$CLINICS(CLINIC)
QUIT
+3 SET PSJ("MR")=$PIECE(X,U,3)
SET PSJ("SM")=$PIECE(X,U,5)
SET PSJ("HSM")=$PIECE(X,U,6)
+4 SET PSJ("ST")=$PIECE(X,U,7)
SET PSJ("STATUS")=$PIECE(X,U,9)
+5 SET PSJ("CPRS")=$PIECE(X,U,21)
SET PSJ("PREV")=$PIECE(X,U,25)
SET PSJ("FOLLOW")=$PIECE(X,U,26)
SET PSJ("RFO")=$PIECE(X,U,27)
+6 IF FON["U"
SET PSJ("NGIVEN")=$PIECE(X,U,22)
+7 SET X=$GET(@(F_ON_",.2)"))
+8 SET PSJ("DO")=$PIECE(X,U,2)
SET PSJ("PRI")=$PIECE(X,U,4)
SET PSJ("FLG")=$PIECE(X,U,7)
SET PSJ("COM")=""
SET PSJ("SRC")=""
+9 IF PSJ("FLG")
Begin DoDot:1
+10 NEW S1,A,B,C
+11 SET S1=""
FOR
SET S1=$ORDER(^PS(55,DFN,5,ON,9,S1),-1)
IF 'S1
QUIT
SET C=$GET(^(S1,0))
SET A=$PIECE(C,U,3)
SET B=$PIECE(C,U,4)
IF A=7010!(A=7030)
QUIT
Begin DoDot:2
+12 IF A'=7000&(A'=7020)
QUIT
+13 SET PSJ("SRC")=$SELECT(A=7000:"PHARMACIST",A=7020:"CPRS",1:"")
+14 SET PSJ("COM")=$GET(@(F_ON_",13)"))
End DoDot:2
IF PSJ("SRC")]""
QUIT
End DoDot:1
+15 SET PSJ("OI")=+X
+16 SET X=$GET(@(F_ON_",2)"))
+17 SET PSJ("SCHD")=$PIECE(X,U)
SET PSJ("STARTDT")=$PIECE(X,U,2)
+18 SET PSJ("STOPDT")=$PIECE(X,U,4)
SET PSJ("ADM")=$PIECE(X,U,5)
+19 SET X=$GET(@(F_ON_",4)"))
+20 SET PSJ("AUTO")=$PIECE(X,U,11)
+21 ;naked reference on line below refers to full reference created by indirect reference to F_ON, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
+22 SET PSJ("SIOPI")=$SELECT($PIECE($GET(@(F_ON_",6)")),"^",2)&($PIECE($GET(@(F_ON_",6)")),"^")'=""):"!",1:"")_$$ENSET($PIECE($GET(^(6)),"^"))
+23 DO SIOPI
+24 SET PSJ("STC")=PSJ("ST")
+25 IF PSJ("ST")="R"!(PSJ("ST")="C")
SET PSJ("STC")=$SELECT(PSJ("SCHD")["PRN":"P","^ONCALL^ON-CALL^ON CALL^"[("^"_PSJ("SCHD")_"^"):"OC",$$ONE(DFN,FON,PSJ("SCHD"))="O":"O",1:"C")
+26 QUIT
TMP ;Setup ^TMP that have common fields between IV and U/D
+1 NEW A
+2 SET PSJINX=PSJINX+1
+3 SET PSJ("OINAME")=$$OIDF^PSJLMUT1(+PSJ("OI"))
IF PSJ("OINAME")["NOT FOUND"
SET PSJ("OINAME")=""
+4 SET PSJ("OIDF")=$$GET1^DIQ(50.7,+PSJ("OI"),.02)
+5 IF PSJ("OINAME")=""
SET PSJ("OIDF")=""
+6 SET A=$GET(^PS(51.2,+PSJ("MR"),0))
SET PSJ("MRABB")=$PIECE(A,U,3)
SET PSJ("MRNM")=$PIECE(A,U)
+7 SET ^TMP("PSJ",$JOB,PSJINX,0)=DFN_U_+ON_U_FON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$GET(PSJ("IVTYPE"))_U_$GET(PSJ("INSYR"))_U_$GET(PSJ("CHEMO"))_U_PSJ("CPRS")_U_$GET(PSJ("RFO"))
+8 SET ^TMP("PSJ",$JOB,PSJINX,1)=PSJ("MRABB")_U_PSJ("STC")_U_$GET(PSJ("SCHD"))_U_PSJ("STARTDT")_U_PSJ("STOPDT")_U_PSJ("ADM")_U_PSJ("STATUS")_U_$GET(PSJ("NGIVEN"))_U_$GET(PSJ("ST"))_U_$GET(PSJ("AUTO"))
+9 SET ^TMP("PSJ",$JOB,PSJINX,1,0)=$PIECE(A,U,8)_U_PSJ("MRNM")_U_$PIECE(A,U,9)
+10 SET ^TMP("PSJ",$JOB,PSJINX,2)=PSJ("DO")_U_$GET(PSJ("INFRATE"))_U_$GET(PSJ("SM"))_U_$GET(PSJ("HSM"))
+11 SET ^TMP("PSJ",$JOB,PSJINX,3)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("OIDF")
+12 SET ^TMP("PSJ",$JOB,PSJINX,4)=PSJ("SIOPI")
+13 SET A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
+14 SET ^TMP("PSJ",$JOB,PSJINX,5)=$SELECT(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
+15 QUIT
SIOPI ; Use provider comments if order is pending and there is no SI
+1 NEW X,Y,Z
+2 IF FON["P"
IF (PSJ("SIOPI")="")
IF $ORDER(^PS(53.1,+ON,12,0))
Begin DoDot:1
+3 FOR X=0:0
SET X=$ORDER(^PS(53.1,+ON,12,X))
IF 'X
QUIT
SET Z=$GET(^(X,0))
Begin DoDot:2
+4 SET Y=$LENGTH(PSJ("SIOPI"))
+5 IF Y+$LENGTH(Z)'>179
SET PSJ("SIOPI")=PSJ("SIOPI")_Z_""
End DoDot:2
+6 IF Y+$LENGTH(Z)>179
SET PSJ("SIOPI")="SEE PROVIDER COMMENTS"
End DoDot:1
+7 QUIT
ENSET(X) ; expands SPECIAL INSTRUCTIONS field contained in X into Y
+1 NEW X1,X2,Y
SET Y=""
+2 FOR X1=1:1:$LENGTH(X," ")
SET X2=$PIECE(X," ",X1)
IF X2]""
SET Y=Y_$SELECT($LENGTH(X2)>30:X2,'$DATA(^PS(51,+$ORDER(^PS(51,"B",X2,0)),0)):X2,$PIECE(^(0),"^",2)]""&$PIECE(^(0),"^",4):$PIECE(^(0),"^",2),1:X2)_" "
+3 SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
+4 QUIT Y
ONE(DFN,ORD,SCH,START,STOP) ;Is order a one-time
+1 ; Input: DFN - patient's IEN
+2 ; ORD - order number
+3 ; SCH - schedule text (required)
+4 ; START - order start date (optional)
+5 ; STOP - order stop date (optional)
+6 NEW X,ONEFRQ,TYP,T
+7 IF $GET(PSJ("PREV"))
IF $GET(PSJ("FOLLOW"))
IF +PSJ("PREV")=+PSJ("FOLLOW")
SET (PSJ("PREV"),PSJ("FOLLOW"))=""
+8 ; PSJ*5*190 One-Time PRN
+9 IF $GET(SCH)=""
IF $GET(DFN)
IF $GET(ORD)
Begin DoDot:1
+10 IF ORD["U"
SET SCH=$PIECE($GET(^PS(55,DFN,5,+ORD,2)),"^")
+11 IF ORD["V"
SET SCH=$PIECE($GET(^PS(55,DFN,"IV",+ORD,0)),"^",9)
End DoDot:1
+12 IF $GET(SCH)]""
IF $$OTPRN^PSJBCMA3(SCH)="O"
QUIT "O"
+13 IF $GET(DFN)]""
IF $GET(ORD)]""
IF ORD["U"
IF $PIECE(^PS(55,DFN,5,+ORD,0),"^",7)'="R"
QUIT $PIECE(^PS(55,DFN,5,+ORD,0),"^",7)
+14 IF $GET(SCH)=""
QUIT ""
+15 IF $DATA(^PS(51.1,"AC","PSJ",SCH))
SET X=$ORDER(^(SCH,""))
SET X=$PIECE(^PS(51.1,X,0),"^",5)
QUIT $SELECT(X="D":"C",1:X)
+16 IF $GET(START)]""
IF $GET(STOP)]""
IF START=STOP
QUIT "O"
+17 QUIT ""
CLINIC(CL) ;
+1 IF $PIECE(CL,"^",2)?7N!($PIECE(CL,"^",2)?7N1".".N)
QUIT 1
+2 QUIT 0
CLINICS(CL) ;
+1 IF '$$CLINIC(CL)
QUIT 1
+2 IF '$DATA(^PS(53.46,"B",+CL))
QUIT 1
+3 NEW A
+4 SET A=$ORDER(^PS(53.46,"B",+CL,""))
IF 'A
QUIT 1
+5 QUIT $PIECE(^PS(53.46,A,0),"^",4)
