PSJMIV ;BIR/MV-IV ORDER FOR MED DUE WORKSHEET. ; 5/14/09 8:12am
;;5.0; INPATIENT MEDICATIONS ;**58,116,225**;16 DEC 97;Build 16
;
; 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
;PSJ*5*225 include IVP
S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV") Q:XTYPE=3&(PST="S")&'($S(X="IVP":1,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJMIV 3970 printed Nov 22, 2024@17:17:48 Page 2
PSJMIV ;BIR/MV-IV ORDER FOR MED DUE WORKSHEET. ; 5/14/09 8:12am
+1 ;;5.0; INPATIENT MEDICATIONS ;**58,116,225**;16 DEC 97;Build 16
+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 ;PSJ*5*225 include IVP
+5 SET X=$PIECE(P("MR"),U,2)
if XTYPE=2&(X["IV")
QUIT
if XTYPE=3&(PST="S")&'($SELECT(X="IVP"
QUIT
+6 SET QST=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3))
+7 SET QST=$SELECT(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
+8 IF P(9)]""
DO SCHEDULE
QUIT
+9 SET PSGON=0
if P(15)
DO INTERVAL
+10 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
