- PSGAPIV ;BIR/MV-ACTION PROFILE #1 IV ORDERS ;07 Apr 98 / 1:10 PM
- ;;5.0; INPATIENT MEDICATIONS ;**9,58,169**;16 DEC 97
- ;
- ; 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 S DFN=PSGP D GT55^PSIVORFB
- I STP'=9999999\1,(P(2)>STP) Q
- 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="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))
- 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 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
- PSGAPIV ;BIR/MV-ACTION PROFILE #1 IV ORDERS ;07 Apr 98 / 1:10 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**9,58,169**;16 DEC 97
- +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
- SET DFN=PSGP
- DO GT55^PSIVORFB
- +2 IF STP'=9999999\1
- IF (P(2)>STP)
- QUIT
- +3 IF "DE"[P(17)
- 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(DFN,ON,P(9),P(2),P(3))
- +6 IF QST'="O"
- SET QST=$SELECT(P(9)["PRN":"P",1:"C")
- +7 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))
- +8 SET ^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN,QST_U_DRG,ON_"V")=""
- +9 QUIT
- PRT(ON) ;*** Print IV on Action Profile #1.
- +1 NEW TYPE
- 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
