PSGCAPIV ;BIR/MV-ACTION PROFILE #2 IV ORDERS ; 8/28/09 12:24pm
;;5.0; INPATIENT MEDICATIONS ;**9,58,169,232**;16 DEC 97;Build 2
;
; 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
;
START ;
NEW P,ON,DRG S ON=""
;* S:PSGSS'="P" PSGDT=PSGAPSD-.0001 S:PSGSS="P" STP=9999999
S PSGDT=PSGAPSD-.0001
F PSGEXPDT=PSGDT:0 S PSGEXPDT=$O(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT)) Q:$S('PSGEXPDT:1,PSGAPO="E":PSGEXPDT>PSGAPFD,1:0) F S ON=$O(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT,ON)) Q:ON="" D IV
Q
IV ;
N X,ON55 S DFN=PSGP D GT55^PSIVORFB
Q:"DE"[P(17)
S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV") Q:XTYPE=3&(PST="S")&'($S(X="IV":1,X["IVP":1,1:0)) ;If med route is IVPB or IVP do not quit (PSJ*5*232)
S QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
I QST'="O" S QST=$S(P(9)["PRN":"P",1:"C")
I DRG S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),DRG=$S(P(4)="H":"* TPN *",1:$E($$ENPDN^PSGMI($P(X,U,6)),1,20))
S ^TMP($J,S1,PSGAPWDN,PN,QST_U_$E(DRG,1,20),ON_"V")=""
Q
PRT(ON) ;*** Print IV orders.
NEW TYPE S TYPE=$P(DRG,U),ON=+ON,DCU=0
N ON55,DRG,P,PRTST S DFN=PSGP,PRTST=1 D GT55^PSIVORFB
F X=2,3 S:P(X) P(X)=$E($$ENDTC^PSGMI(P(X)),1,5)
S PSJSI=$$ENSET^PSGSICHK($P(P("OPI"),"^"))
;PSJ*5*169 Set QST so one-time orders will not allow RENEW on report.
N QST
S QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
I QST'="O" S QST=$S(P(9)["PRN":"P",1:"C")
W !,$J(N,3)
I '$O(DRG("AD",0)) D PRTST W !
I $O(DRG("AD",0)) F X=0:0 S X=$O(DRG("AD",X)) Q:'X W ?5,$$WRTDRG^PSIVUTL(DRG("AD",X),41) D:X=1 PRTST D DCU("AD",X),NP("AD") G:$G(PSJDLW) EXIT W !
W ?5,"in "
F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D:X>1 NP("SOL") W:X>1 ! W ?8,$$WRTDRG^PSIVUTL(DRG("SOL",X),41) D DCU("SOL",X) G:$G(PSJDLW) EXIT
W:P(9)]"" " " W P(9)," ",P(8) D:'$G(DRG("AD",1))&PRTST PRTST
I PSJSI]"" W !?5,"Special Instructions: " F Y=1:1:$L(PSJSI," ") S Y1=$P(PSJSI," ",Y) W:($L(Y1)+$X)>79 !?27 W Y1_" "
W ! D ORDP1^PSGCAPP
Q
PRTST ;*** Print the rest of the 1st line.
W:PRTST ?46,TYPE,?49,P(2),?55,P(3),?61,P(17)
S PRTST=0
Q
NP(TYPE) ;*** Print end line after order.
NEW X
D:DRG(TYPE,0)>1&($Y+11>IOSL) NP^PSGCAPP
Q
DCU(TYPE,X) ;*** Calculate drug cost.
NEW COST
S:TYPE="AD" COST=$P(^PS(52.6,+DRG(TYPE,X),0),U,7)
S:TYPE="SOL" COST=$P(^PS(52.7,+DRG(TYPE,X),0),U,7)
S DCU=DCU+(COST*+$P(DRG(TYPE,X),U,3))
Q
EXIT ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGCAPIV 2445 printed Apr 09, 2024@21:07:15 Page 2
PSGCAPIV ;BIR/MV-ACTION PROFILE #2 IV ORDERS ; 8/28/09 12:24pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**9,58,169,232**;16 DEC 97;Build 2
+2 ;
+3 ; Reference to ^PS(52.6 is supported by DBIA# 1231
+4 ; Reference to ^PS(52.7 is supported by DBIA# 2173
+5 ; Reference to ^PS(55 is supported by DBIA# 2191
+6 ;
START ;
+1 NEW P,ON,DRG
SET ON=""
+2 ;* S:PSGSS'="P" PSGDT=PSGAPSD-.0001 S:PSGSS="P" STP=9999999
+3 SET PSGDT=PSGAPSD-.0001
+4 FOR PSGEXPDT=PSGDT:0
SET PSGEXPDT=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT))
if $SELECT('PSGEXPDT
QUIT
FOR
SET ON=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGEXPDT,ON))
if ON=""
QUIT
DO IV
+5 QUIT
IV ;
+1 NEW X,ON55
SET DFN=PSGP
DO GT55^PSIVORFB
+2 if "DE"[P(17)
QUIT
+3 ;If med route is IVPB or IVP do not quit (PSJ*5*232)
SET X=$PIECE(P("MR"),U,2)
if XTYPE=2&(X["IV")
QUIT
if XTYPE=3&(PST="S")&'($SELECT(X="IV"
QUIT
+4 SET QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
+5 IF QST'="O"
SET QST=$SELECT(P(9)["PRN":"P",1:"C")
+6 IF DRG
SET X=$SELECT($GET(DRG("AD",1)):DRG("AD",1),1:$GET(DRG("SOL",1)))
SET DRG=$SELECT(P(4)="H":"* TPN *",1:$EXTRACT($$ENPDN^PSGMI($PIECE(X,U,6)),1,20))
+7 SET ^TMP($JOB,S1,PSGAPWDN,PN,QST_U_$EXTRACT(DRG,1,20),ON_"V")=""
+8 QUIT
PRT(ON) ;*** Print IV orders.
+1 NEW TYPE
SET TYPE=$PIECE(DRG,U)
SET ON=+ON
SET DCU=0
+2 NEW ON55,DRG,P,PRTST
SET DFN=PSGP
SET PRTST=1
DO GT55^PSIVORFB
+3 FOR X=2,3
if P(X)
SET P(X)=$EXTRACT($$ENDTC^PSGMI(P(X)),1,5)
+4 SET PSJSI=$$ENSET^PSGSICHK($PIECE(P("OPI"),"^"))
+5 ;PSJ*5*169 Set QST so one-time orders will not allow RENEW on report.
+6 NEW QST
+7 SET QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
+8 IF QST'="O"
SET QST=$SELECT(P(9)["PRN":"P",1:"C")
+9 WRITE !,$JUSTIFY(N,3)
+10 IF '$ORDER(DRG("AD",0))
DO PRTST
WRITE !
+11 IF $ORDER(DRG("AD",0))
FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
WRITE ?5,$$WRTDRG^PSIVUTL(DRG("AD",X),41)
if X=1
DO PRTST
DO DCU("AD",X)
DO NP("AD")
if $GET(PSJDLW)
GOTO EXIT
WRITE !
+12 WRITE ?5,"in "
+13 FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
if X>1
DO NP("SOL")
if X>1
WRITE !
WRITE ?8,$$WRTDRG^PSIVUTL(DRG("SOL",X),41)
DO DCU("SOL",X)
if $GET(PSJDLW)
GOTO EXIT
+14 if P(9)]""
WRITE " "
WRITE P(9)," ",P(8)
if '$GET(DRG("AD",1))&PRTST
DO PRTST
+15 IF PSJSI]""
WRITE !?5,"Special Instructions: "
FOR Y=1:1:$LENGTH(PSJSI," ")
SET Y1=$PIECE(PSJSI," ",Y)
if ($LENGTH(Y1)+$X)>79
WRITE !?27
WRITE Y1_" "
+16 WRITE !
DO ORDP1^PSGCAPP
+17 QUIT
PRTST ;*** Print the rest of the 1st line.
+1 if PRTST
WRITE ?46,TYPE,?49,P(2),?55,P(3),?61,P(17)
+2 SET PRTST=0
+3 QUIT
NP(TYPE) ;*** Print end line after order.
+1 NEW X
+2 if DRG(TYPE,0)>1&($Y+11>IOSL)
DO NP^PSGCAPP
+3 QUIT
DCU(TYPE,X) ;*** Calculate drug cost.
+1 NEW COST
+2 if TYPE="AD"
SET COST=$PIECE(^PS(52.6,+DRG(TYPE,X),0),U,7)
+3 if TYPE="SOL"
SET COST=$PIECE(^PS(52.7,+DRG(TYPE,X),0),U,7)
+4 SET DCU=DCU+(COST*+$PIECE(DRG(TYPE,X),U,3))
+5 QUIT
EXIT ;
+1 QUIT
