PSJBCMA.m

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