PSJMIV.m

PSJMIV ;BIR/MV-IV ORDER FOR MED DUE WORKSHEET.  ;20 DEC 96 / 3:12 PM

 ;;5.0; INPATIENT MEDICATIONS ;**58,116**;16 DEC 97

 ;

 ; Reference to ^PS(55 is supported by DBIA 2191.

 ;

START ;*** Read IV orders

 NEW P S ON=""

 F PSGEXPDT=PSGPLS-.0001:0 S PSGEXPDT=$O(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT)) Q:'PSGEXPDT  F  S ON=$O(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT,ON)) Q:ON=""  D IV

 Q

IV ;*** Process IV order based on schedule and interval

 K ADM N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT55^PSIVORFB

 Q:"DE"[P(17)

 Q:P(2)>PSGPLF

 S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV")  Q:XTYPE=3&(PST="S")&'($S(X="IV":1,X="IVPB":1,1:0))

 S QST=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3))

 S QST=$S(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE

 I P(9)]"" D SCHEDULE Q

 S PSGON=0 D:P(15) INTERVAL

 Q

INTERVAL ;*** Calculate admin time by schedule interval.

 NEW MN,ND,ND1,PLSD,PSGPLC,ST,T,TS

 K PSGMAR

 F I=0:1 S ADM=$$FMADD^XLFDT(P(2),0,0,P(15)*I,0) Q:ADM>$S(P(3)<PSGPLF:P(3),1:PSGPLF)  S:ADM'<PSGPLS PSGMAR(ADM)=""

 S ON=ON_"*" D IVTMP ;*** ON_"*" =projected time for cont. IV.

 Q

SCHEDULE ;*** Calculate admin times for IV that has schedule defined.

 K PSGMAR S PSGPLC=0 S PSGOES=1,X=P(9) D EN^PSGS0 S T=PSGS0XT,PSGOES=""

 S ND1=P(4),ST=P(2),PLSD=P(3),TS=P(11),MN=T,ND=P(9) I $S(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E) S PSGPLC="OI" Q

 D ENIV^PSJPL0

 D IVTMP

 Q

IVTMP ;*** Set IV ^TMP.

 I DRG S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),DRG=$E($$ENPDN^PSGMI($P(X,U,6)),1,20)_U_ON

 F ADMIN=0:0 S ADMIN=$O(PSGMAR(ADMIN)) Q:'ADMIN  S PSJADT=$P(ADMIN,"."),PSJATME=+$E($P(ADMIN,".",2)_"0000",1,4) D @PSGSS

 Q

P ;*** Set ^TMP when select by patient

 S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB

 Q

G ;*** Goto W to set ^TMP when selected by WARD/WARD GROUP

 ;

W ;

 S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 Q

 ;

 ;

PRT ;*** Print IV orders for Med Due Worksheet.

 N ON55,DRG,P,PSJLABEL S DFN=PSGP,PSJLABEL=1

 D:QST'["Z" GT55^PSIVORFB

 ;* I QST["Z" D GT531^PSIVORFA(DFN,ON) S P("OPI")=^TMP($J,QST,PSGP,ON,1)

 I QST["Z" D GT531^PSIVORFA(DFN,ON),SI^PSJMPEND S P("OPI")=PSJSI

 F X="LOG",2,3 S:P(X) P(X)=$$ENDTC^PSGMI(P(X))

 S PSJONETM=$S(QST="OVO":1,1:0)

 S PSJSI=$P(P("OPI"),"^")

 NEW NEED S PSJNEED=0

 F X="AD","SOL" D NAMENEED^PSJMUTL(X,40,.NEED) S PSJNEED=PSJNEED+NEED

 S X=$L($P(P("OPI"),"^"))/41,X=$P(X,".")+($P(X,".",2)>0)+(P(4)="C")

 S:$D(DRG("AD",0))&$D(DRG("SOL",0)) X=X+1

 S PSJNEED=PSJNEED+X+4+PSJONETM

 D ^PSJMPRTU

 D:(PSJNEED+PSJLN)>PSJTOTLN HDR^PSJMPRTU Q:$G(PSJSTOP)

 D PRTIV

 Q

 ;

PRTIV ;

 ;* W !,PSJPRT(1),?39,$E(P("LOG"),1,5)," | ",$E(P(2),1,5),$E(P(2),9,15)," | ",P(3)

 W !,PSJPRT(1),?39,$E(P("LOG"),1,5)," | "

 I QST["Z" W "P E N D I N G"

 E  W $E(P(2),1,5),$E(P(2),9,15)," | ",P(3)

 NEW X,Y

 F X=0:0 S X=$O(DRG("AD",X)) Q:'X  D NAME^PSIVUTL(DRG("AD",X),40,.NAME,1) F Y=0:0 S Y=$O(NAME(Y))  Q:'Y  D ADSOL W NAME(Y)

 I $G(DRG("SOL",1)) D ADSOL W " in"

 F X=0:0 S X=$O(DRG("SOL",X)) Q:'X  D NAME^PSIVUTL(DRG("SOL",X),40,.NAME,0) F Y=0:0 S Y=$O(NAME(Y))  Q:'Y  D ADSOL W NAME(Y)

 S:ON["*" PSJASTR=1

 W !?39,$P(P("MR"),U,2)," ",P(9)," ",P(8)

 W:PSJONETM !?39,"*** ONE TIME ***"

 W:P(4)="C" !?39,"*CAUTION-CHEMOTHERAPY*"

 I PSJSI]"" W !?39 F Y=1:1:$L(PSJSI," ") S Y1=$P(PSJSI," ",Y) W:($L(Y1)+$X)>79 !?39 W Y1_" "

 W !?39,"RN/LPN Init: ________"

 W !

 S PSJLN=PSJLN+PSJNEED

 Q

ADSOL ;

 I PSJLN>PSJTOTLN W !?39,"*** CONTINUE ON NEXT PAGE ***" NEW X D ^PSJMPRTU,HDR^PSJMPRTU D

 .W !,PSJPRT(1),?39,$E(P("LOG"),1,5)," | ",$E(P(2),1,5),$E(P(2),9,15)," | ",P(3)

 S PSJLN=PSJLN+1,PSJNEED=PSJNEED-1

 S I=$O(PSJPRT(1)) W !,$G(PSJPRT(+I)),?39

 K:I PSJPRT(I)

 Q

PSJMIV    ;BIR/MV-IV ORDER FOR MED DUE WORKSHEET.  ;20 DEC 96 / 3:12 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**58,116**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(55 is supported by DBIA 2191.

 +4       ;

START     ;*** Read IV orders

 +1        NEW P

           SET ON=""

 +2        FOR PSGEXPDT=PSGPLS-.0001:0

               SET PSGEXPDT=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT))

               IF 'PSGEXPDT

                   QUIT 

               FOR 

                   SET ON=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT,ON))

                   IF ON=""

                       QUIT 

                   DO IV

 +3        QUIT 

IV        ;*** Process IV order based on schedule and interval

 +1        KILL ADM

           NEW X,ON55,PSJLABEL

           SET DFN=PSGP

           SET PSJLABEL=1

           DO GT55^PSIVORFB

 +2        IF "DE"[P(17)

               QUIT 

 +3        IF P(2)>PSGPLF

               QUIT 

 +4        SET X=$PIECE(P("MR"),U,2)

           IF XTYPE=2&(X["IV")

               QUIT 

           IF XTYPE=3&(PST="S")&'($SELECT(X="IV"

               QUIT 

 +5        SET QST=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3))

 +6        SET QST=$SELECT(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE

 +7        IF P(9)]""

               DO SCHEDULE

               QUIT 

 +8        SET PSGON=0

           IF P(15)

               DO INTERVAL

 +9        QUIT 

INTERVAL  ;*** Calculate admin time by schedule interval.

 +1        NEW MN,ND,ND1,PLSD,PSGPLC,ST,T,TS

 +2        KILL PSGMAR

 +3        FOR I=0:1

               SET ADM=$$FMADD^XLFDT(P(2),0,0,P(15)*I,0)

               IF ADM>$SELECT(P(3)<PSGPLF

                   QUIT 

               IF ADM'<PSGPLS

                   SET PSGMAR(ADM)=""

 +4       ;*** ON_"*" =projected time for cont. IV.

           SET ON=ON_"*"

           DO IVTMP

 +5        QUIT 

SCHEDULE  ;*** Calculate admin times for IV that has schedule defined.

 +1        KILL PSGMAR

           SET PSGPLC=0

           SET PSGOES=1

           SET X=P(9)

           DO EN^PSGS0

           SET T=PSGS0XT

           SET PSGOES=""

 +2        SET ND1=P(4)

           SET ST=P(2)

           SET PLSD=P(3)

           SET TS=P(11)

           SET MN=T

           SET ND=P(9)

           IF $SELECT(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E)

               SET PSGPLC="OI"

               QUIT 

 +3        DO ENIV^PSJPL0

 +4        DO IVTMP

 +5        QUIT 

IVTMP     ;*** Set IV ^TMP.

 +1        IF DRG

               SET X=$SELECT($GET(DRG("AD",1)):DRG("AD",1),1:$GET(DRG("SOL",1)))

               SET DRG=$EXTRACT($$ENPDN^PSGMI($PIECE(X,U,6)),1,20)_U_ON

 +2        FOR ADMIN=0:0

               SET ADMIN=$ORDER(PSGMAR(ADMIN))

               IF 'ADMIN

                   QUIT 

               SET PSJADT=$PIECE(ADMIN,".")

               SET PSJATME=+$EXTRACT($PIECE(ADMIN,".",2)_"0000",1,4)

               DO @PSGSS

 +3        QUIT 

P         ;*** Set ^TMP when select by patient

 +1        SET ^TMP($JOB,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB

 +2        QUIT 

G         ;*** Goto W to set ^TMP when selected by WARD/WARD GROUP

 +1       ;

W         ;

 +1        IF PSGRBADM="A"

               SET ^TMP($JOB,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 +2        IF PSGRBADM="R"

               SET ^TMP($JOB,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 +3        IF PSGRBADM="P"

               SET ^TMP($JOB,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 +4        QUIT 

 +5       ;

 +6       ;

PRT       ;*** Print IV orders for Med Due Worksheet.

 +1        NEW ON55,DRG,P,PSJLABEL

           SET DFN=PSGP

           SET PSJLABEL=1

 +2        IF QST'["Z"

               DO GT55^PSIVORFB

 +3       ;* I QST["Z" D GT531^PSIVORFA(DFN,ON) S P("OPI")=^TMP($J,QST,PSGP,ON,1)

 +4        IF QST["Z"

               DO GT531^PSIVORFA(DFN,ON)

               DO SI^PSJMPEND

               SET P("OPI")=PSJSI

 +5        FOR X="LOG",2,3

               IF P(X)

                   SET P(X)=$$ENDTC^PSGMI(P(X))

 +6        SET PSJONETM=$SELECT(QST="OVO":1,1:0)

 +7        SET PSJSI=$PIECE(P("OPI"),"^")

 +8        NEW NEED

           SET PSJNEED=0

 +9        FOR X="AD","SOL"

               DO NAMENEED^PSJMUTL(X,40,.NEED)

               SET PSJNEED=PSJNEED+NEED

 +10       SET X=$LENGTH($PIECE(P("OPI"),"^"))/41

           SET X=$PIECE(X,".")+($PIECE(X,".",2)>0)+(P(4)="C")

 +11       IF $DATA(DRG("AD",0))&$DATA(DRG("SOL",0))

               SET X=X+1

 +12       SET PSJNEED=PSJNEED+X+4+PSJONETM

 +13       DO ^PSJMPRTU

 +14       IF (PSJNEED+PSJLN)>PSJTOTLN

               DO HDR^PSJMPRTU

           IF $GET(PSJSTOP)

               QUIT 

 +15       DO PRTIV

 +16       QUIT 

 +17      ;

PRTIV     ;

 +1       ;* W !,PSJPRT(1),?39,$E(P("LOG"),1,5)," | ",$E(P(2),1,5),$E(P(2),9,15)," | ",P(3)

 +2        WRITE !,PSJPRT(1),?39,$EXTRACT(P("LOG"),1,5)," | "

 +3        IF QST["Z"

               WRITE "P E N D I N G"

 +4       IF '$TEST

               WRITE $EXTRACT(P(2),1,5),$EXTRACT(P(2),9,15)," | ",P(3)

 +5        NEW X,Y

 +6        FOR X=0:0

               SET X=$ORDER(DRG("AD",X))

               IF 'X

                   QUIT 

               DO NAME^PSIVUTL(DRG("AD",X),40,.NAME,1)

               FOR Y=0:0

                   SET Y=$ORDER(NAME(Y))

                   IF 'Y

                       QUIT 

                   DO ADSOL

                   WRITE NAME(Y)

 +7        IF $GET(DRG("SOL",1))

               DO ADSOL

               WRITE " in"

 +8        FOR X=0:0

               SET X=$ORDER(DRG("SOL",X))

               IF 'X

                   QUIT 

               DO NAME^PSIVUTL(DRG("SOL",X),40,.NAME,0)

               FOR Y=0:0

                   SET Y=$ORDER(NAME(Y))

                   IF 'Y

                       QUIT 

                   DO ADSOL

                   WRITE NAME(Y)

 +9        IF ON["*"

               SET PSJASTR=1

 +10       WRITE !?39,$PIECE(P("MR"),U,2)," ",P(9)," ",P(8)

 +11       IF PSJONETM

               WRITE !?39,"*** ONE TIME ***"

 +12       IF P(4)="C"

               WRITE !?39,"*CAUTION-CHEMOTHERAPY*"

 +13       IF PSJSI]""

               WRITE !?39

               FOR Y=1:1:$LENGTH(PSJSI," ")

                   SET Y1=$PIECE(PSJSI," ",Y)

                   IF ($LENGTH(Y1)+$X)>79

                       WRITE !?39

                   WRITE Y1_" "

 +14       WRITE !?39,"RN/LPN Init: ________"

 +15       WRITE !

 +16       SET PSJLN=PSJLN+PSJNEED

 +17       QUIT 

ADSOL     ;

 +1        IF PSJLN>PSJTOTLN

               WRITE !?39,"*** CONTINUE ON NEXT PAGE ***"

               NEW X

               DO ^PSJMPRTU

               DO HDR^PSJMPRTU

               Begin DoDot:1

 +2                WRITE !,PSJPRT(1),?39,$EXTRACT(P("LOG"),1,5)," | ",$EXTRACT(P(2),1,5),$EXTRACT(P(2),9,15)," | ",P(3)

               End DoDot:1

 +3        SET PSJLN=PSJLN+1

           SET PSJNEED=PSJNEED-1

 +4        SET I=$ORDER(PSJPRT(1))

           WRITE !,$GET(PSJPRT(+I)),?39

 +5        IF I

               KILL PSJPRT(I)

 +6        QUIT