PSGAPIV ;BIR/MV-ACTION PROFILE #1 IV ORDERS ;07 Apr 98 / 1:10 PM
;;5.0;INPATIENT MEDICATIONS;**9,58,169,275**;16 DEC 97;Build 157
;
; Reference to ^PS(55 is supported by DBIA# 2191
;
START ;
NEW P,ON,DRG S ON=""
F PSGEXPDT=PSGDT: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 ;
N X,ON55,PSJCLN,CLINSORT S DFN=PSGP D GT55^PSIVORFB
I STP'=9999999\1,(P(2)>STP) Q
Q:"DE"[P(17)
; PSJ*5*275 get clinic
S PSJCLN=$$CLINIC^PSJO1(PSGP,ON) I (PSJCLN]"") S PSGAPWDN="zz"
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(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))
I PSJCLN]"" S CLINSORT=$$CLINSORT^PSJO1(QST) S QST="zz"_U_PSJCLN_U_CLINSORT_U_$S(($P(QST,"^")="z"):$P(QST,"^",4),1:QST)
S ^TMP($J,$E(PSGAPWDN,1,20),TM,PN,QST_U_DRG,ON_"V")=""
Q
PRT(ON) ;*** Print IV on Action Profile #1.
NEW TYPE,Y1 S TYPE=$P(DRG,U),ON=+ON
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"),"^"))
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),$S(QST="O":" ",1:" R")_" D N " ;PSJ*5*169 Don't allow RENEW on one-time orders.
I '$D(DRG("AD",0)) D PRTST W !
I $O(DRG("AD",0)) F X=0:0 S X=$O(DRG("AD",X)) Q:'X W ?11,$$WRTDRG^PSIVUTL(DRG("AD",X),41) D:X=1 PRTST D NP("AD") G:$G(PSJDLW) EXIT W !
W ?11,"in "
F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D:X>1 NP("SOL") W:X>1 ! W ?14,$$WRTDRG^PSIVUTL(DRG("SOL",X),41) G:$G(PSJDLW) EXIT
W:P(9)]"" " " W P(9)," ",P(8) D:'$G(DRG("AD",1))&PRTST PRTST
I PSJSI]"" W !?11,"Special Instructions: " F Y=1:1:$L(PSJSI," ") S Y1=$P(PSJSI," ",Y) W:($L(Y1)+$X)>79 !?33 W Y1_" "
W !
Q
PRTST ;*** Print the rest of the 1st line.
W:PRTST ?52,TYPE,?55,P(2),?61,P(3),?67,P(17)
S PRTST=0
Q
NP(TYPE) ;
NEW X
D:DRG(TYPE,0)>1&($Y+11>IOSL) NP^PSGAPP
Q
EXIT ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAPIV 2169 printed Apr 09, 2024@21:03:41 Page 2
PSGAPIV ;BIR/MV-ACTION PROFILE #1 IV ORDERS ;07 Apr 98 / 1:10 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**9,58,169,275**;16 DEC 97;Build 157
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ;
START ;
+1 NEW P,ON,DRG
SET ON=""
+2 FOR PSGEXPDT=PSGDT: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 ;
+1 NEW X,ON55,PSJCLN,CLINSORT
SET DFN=PSGP
DO GT55^PSIVORFB
+2 IF STP'=9999999\1
IF (P(2)>STP)
QUIT
+3 if "DE"[P(17)
QUIT
+4 ; PSJ*5*275 get clinic
+5 SET PSJCLN=$$CLINIC^PSJO1(PSGP,ON)
IF (PSJCLN]"")
SET PSGAPWDN="zz"
+6 SET X=$PIECE(P("MR"),U,2)
if XTYPE=2&(X["IV")
QUIT
if XTYPE=3&(PST="S")&'($SELECT(X="IV"
QUIT
+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 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))
+10 IF PSJCLN]""
SET CLINSORT=$$CLINSORT^PSJO1(QST)
SET QST="zz"_U_PSJCLN_U_CLINSORT_U_$SELECT(($PIECE(QST,"^")="z"):$PIECE(QST,"^",4),1:QST)
+11 SET ^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN,QST_U_DRG,ON_"V")=""
+12 QUIT
PRT(ON) ;*** Print IV on Action Profile #1.
+1 NEW TYPE,Y1
SET TYPE=$PIECE(DRG,U)
SET ON=+ON
+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 SET QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
+6 IF QST'="O"
SET QST=$SELECT(P(9)["PRN":"P",1:"C")
+7 ;PSJ*5*169 Don't allow RENEW on one-time orders.
WRITE !,$JUSTIFY(N,3),$SELECT(QST="O":" ",1:" R")_" D N "
+8 IF '$DATA(DRG("AD",0))
DO PRTST
WRITE !
+9 IF $ORDER(DRG("AD",0))
FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
WRITE ?11,$$WRTDRG^PSIVUTL(DRG("AD",X),41)
if X=1
DO PRTST
DO NP("AD")
if $GET(PSJDLW)
GOTO EXIT
WRITE !
+10 WRITE ?11,"in "
+11 FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
if X>1
DO NP("SOL")
if X>1
WRITE !
WRITE ?14,$$WRTDRG^PSIVUTL(DRG("SOL",X),41)
if $GET(PSJDLW)
GOTO EXIT
+12 if P(9)]""
WRITE " "
WRITE P(9)," ",P(8)
if '$GET(DRG("AD",1))&PRTST
DO PRTST
+13 IF PSJSI]""
WRITE !?11,"Special Instructions: "
FOR Y=1:1:$LENGTH(PSJSI," ")
SET Y1=$PIECE(PSJSI," ",Y)
if ($LENGTH(Y1)+$X)>79
WRITE !?33
WRITE Y1_" "
+14 WRITE !
+15 QUIT
PRTST ;*** Print the rest of the 1st line.
+1 if PRTST
WRITE ?52,TYPE,?55,P(2),?61,P(3),?67,P(17)
+2 SET PRTST=0
+3 QUIT
NP(TYPE) ;
+1 NEW X
+2 if DRG(TYPE,0)>1&($Y+11>IOSL)
DO NP^PSGAPP
+3 QUIT
EXIT ;
+1 QUIT
