PSGAPIV.m

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