PSJOREN ;BIR/CML3-INTERFACE FOR INPATIENT PHARMACY AND OE/RR ;07 AUG 97 / 3:21 PM
;;5.0; INPATIENT MEDICATIONS ;**109,127,134**;16 DEC 97;Build 124
;
;Reference to ^ORD(100.98 supported by DBIA 873
;Reference to ^PS(51.2 supported by DBIA 2178
;Reference to ^PS(55 supported by DBIA 2191
;
ENTRY ;
K PSGOEE,PSGOES
I '$D(^DPT(+ORVP,.1)) W !!,"THIS PATIENT HAS NOT BEEN ADMITTED.",!,"(Any non-IV orders entered will be discontinued by the pharmacist...)"
;
GO ; get orders
S PSGOEORF=1,PSGOEAV=0,PSJORTOU=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",0)),PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=PSJORPV
F S PSGOEOS="U" D ^PSGOE7 Q:Y<0 D:X?1"S."1.E ^PSGOES I X'?1."S."1.E D ^PSGOE6 K PSGOEE D:$D(Y) ^PSGOETO
;
DONE ;
;
OUT ;
Q ;
PS ;
W $C(7),!!,"The selected PROVIDER is NOT qualified to write MEDICATION orders. You must",!,"select a valid provider to be able to continue with Inpatient Medications."
K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSG=$G(^(""PS"")) I PSG,$S('$P(PSG,""^"",4):1,1:DT<$P(PSG,""^"",4))" F W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0) W $C(7)," (Required.)"
K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORPV=+Y,PSJORPVN=Y(0,0) Q
Q
ENBKOUT(DFN,ON) ; Undo Renew.
Q:'$G(ON)
N PSJOLD,PSJRES,PSJOC,PSJOC2,PSIVACT,PSIVALT,PSIVREA,ON55,PSGAL,DA,PSIVAL,PSJUNDC
S PSJOC=PSOC,PSJOC2=PSJHLMTN,PSIVAL=24000
S X=$G(^PS(53.1,+ON,0)) Q:'X
S PSJRES=$P(X,U,24),(X,PSJOLD)=$P(X,U,25)
I PSJOLD["V" D
.I $D(^PS(55,DFN,"IV",+PSJOLD,2)) D
..N PSJOSTOP,PSJNOW,PSJSTAT S PSJNOW=$$DATE^PSJUTL2(),PSJOSTOP=$P($G(^PS(55,DFN,"IV",+PSJOLD,0)),"^",3),PSJSTAT=$P(^(0),"^",17)
..S $P(^PS(55,DFN,"IV",+PSJOLD,2),U,6)="",$P(^(2),U,9)="",$P(^(0),U,17)=$S(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT)
..S PSIVACT=1,PSIVALT=$S(PSOC="CR":2,1:1),PSJUNDC=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U),PSIVREA="PNRD",ON55=PSJOLD
.D LOG^PSIVORAL
I PSJOLD["U" D
.I $D(^PS(55,DFN,5,+PSJOLD,0)) N PSJSTAT S PSJSTAT=$P(^(0),"^",9) D
..N PSJOSTOP,PSJNOW S PSJNOW=$$DATE^PSJUTL2(),PSJOSTOP=$P($G(^PS(55,DFN,5,+PSJOLD,2)),"^",4)
..S $P(^PS(55,DFN,5,+PSJOLD,0),U,26,27)=U,PSGAL("C")=24000,DA=+PSJOLD,DA(1)=DFN S $P(^(0),U,9)=$S(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT)
.D ^PSGAL5
S PSOC="SC",PSJHLMTN="ORM" D EN1^PSJHL2(DFN,PSOC,PSJOLD) S PSOC=PSJOC,PSJHLMTN=PSJOC2
Q
;
ENUDTX(DFN,ON,RES) ; Set up ORTX( Array for UD orders.
K ORTX N DO,MRN,ND0,NDP1,ND2,PD,ST,SCH
S Y=2 I ON["A"!(ON["O") S ND0=$G(^PS(55,DFN,5,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(55,DFN,5,+ON,12,X)) Q:'X S Y=Y+1,ORTX(Y)=$G(^(X,0))
E S ND0=$G(^PS(53.1,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X S Y=Y+1,ORTX(Y)=$G(^(X,0))
S ORTX(1)=$S($G(RES)="NR":"RENEWAL -",$G(RES)="OR":"RENEWED -",1:"")_$P($G(^PS(50.3,+NDP1,0)),U)
S ORTX(2)=" Give: "_$S($P(NDP1,U,2)]"":$P(NDP1,U,2)_" ",1:"")_$P($G(^PS(51.2,+$P(ND0,U,3),0)),U,3)_" "_$P(ND2,U)_$S($P(ND2,U)["PRN":"",$P(ND0,U,7)="P":" PRN",1:"")
I $G(DFN),$G(ON) S:ON["U" ^PS(55,"AUE",DFN,+ON)=""
Q
PSJOREN ;BIR/CML3-INTERFACE FOR INPATIENT PHARMACY AND OE/RR ;07 AUG 97 / 3:21 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**109,127,134**;16 DEC 97;Build 124
+2 ;
+3 ;Reference to ^ORD(100.98 supported by DBIA 873
+4 ;Reference to ^PS(51.2 supported by DBIA 2178
+5 ;Reference to ^PS(55 supported by DBIA 2191
+6 ;
ENTRY ;
+1 KILL PSGOEE,PSGOES
+2 IF '$DATA(^DPT(+ORVP,.1))
WRITE !!,"THIS PATIENT HAS NOT BEEN ADMITTED.",!,"(Any non-IV orders entered will be discontinued by the pharmacist...)"
+3 ;
GO ; get orders
+1 SET PSGOEORF=1
SET PSGOEAV=0
SET PSJORTOU=$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",0))
SET PSGOEDMR=$ORDER(^PS(51.2,"B","ORAL",0))
SET PSGOEPR=PSJORPV
+2 FOR
SET PSGOEOS="U"
DO ^PSGOE7
IF Y<0
QUIT
IF X?1"S."1.E
DO ^PSGOES
IF X'?1."S."1.E
DO ^PSGOE6
KILL PSGOEE
IF $DATA(Y)
DO ^PSGOETO
+3 ;
DONE ;
+1 ;
OUT ;
+1 ;
QUIT
PS ;
+1 WRITE $CHAR(7),!!,"The selected PROVIDER is NOT qualified to write MEDICATION orders. You must",!,"select a valid provider to be able to continue with Inpatient Medications."
+2 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select PHARMACY PROVIDER: "
SET DIC("S")="S PSG=$G(^(""PS"")) I PSG,$S('$P(PSG,""^"",4):1,1:DT<$P(PSG,""^"",4))"
FOR
WRITE !
DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)!(Y>0)
QUIT
WRITE $CHAR(7)," (Required.)"
+3 KILL DIC
IF Y'>0
SET PSJORPF=11
IF Y>0
SET PSJORPV=+Y
SET PSJORPVN=Y(0,0)
QUIT
+4 QUIT
ENBKOUT(DFN,ON) ; Undo Renew.
+1 IF '$GET(ON)
QUIT
+2 NEW PSJOLD,PSJRES,PSJOC,PSJOC2,PSIVACT,PSIVALT,PSIVREA,ON55,PSGAL,DA,PSIVAL,PSJUNDC
+3 SET PSJOC=PSOC
SET PSJOC2=PSJHLMTN
SET PSIVAL=24000
+4 SET X=$GET(^PS(53.1,+ON,0))
IF 'X
QUIT
+5 SET PSJRES=$PIECE(X,U,24)
SET (X,PSJOLD)=$PIECE(X,U,25)
+6 IF PSJOLD["V"
Begin DoDot:1
+7 IF $DATA(^PS(55,DFN,"IV",+PSJOLD,2))
Begin DoDot:2
+8 NEW PSJOSTOP,PSJNOW,PSJSTAT
SET PSJNOW=$$DATE^PSJUTL2()
SET PSJOSTOP=$PIECE($GET(^PS(55,DFN,"IV",+PSJOLD,0)),"^",3)
SET PSJSTAT=$PIECE(^(0),"^",17)
+9 SET $PIECE(^PS(55,DFN,"IV",+PSJOLD,2),U,6)=""
SET $PIECE(^(2),U,9)=""
SET $PIECE(^(0),U,17)=$SELECT(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT)
+10 SET PSIVACT=1
SET PSIVALT=$SELECT(PSOC="CR":2,1:1)
SET PSJUNDC=1
SET PSIVAL=$PIECE($GET(^PS(53.3,+PSIVAL,0)),U)
SET PSIVREA="PNRD"
SET ON55=PSJOLD
End DoDot:2
+11 DO LOG^PSIVORAL
End DoDot:1
+12 IF PSJOLD["U"
Begin DoDot:1
+13 IF $DATA(^PS(55,DFN,5,+PSJOLD,0))
NEW PSJSTAT
SET PSJSTAT=$PIECE(^(0),"^",9)
Begin DoDot:2
+14 NEW PSJOSTOP,PSJNOW
SET PSJNOW=$$DATE^PSJUTL2()
SET PSJOSTOP=$PIECE($GET(^PS(55,DFN,5,+PSJOLD,2)),"^",4)
+15 SET $PIECE(^PS(55,DFN,5,+PSJOLD,0),U,26,27)=U
SET PSGAL("C")=24000
SET DA=+PSJOLD
SET DA(1)=DFN
SET $PIECE(^(0),U,9)=$SELECT(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT)
End DoDot:2
+16 DO ^PSGAL5
End DoDot:1
+17 SET PSOC="SC"
SET PSJHLMTN="ORM"
DO EN1^PSJHL2(DFN,PSOC,PSJOLD)
SET PSOC=PSJOC
SET PSJHLMTN=PSJOC2
+18 QUIT
+19 ;
ENUDTX(DFN,ON,RES) ; Set up ORTX( Array for UD orders.
+1 KILL ORTX
NEW DO,MRN,ND0,NDP1,ND2,PD,ST,SCH
+2 SET Y=2
IF ON["A"!(ON["O")
SET ND0=$GET(^PS(55,DFN,5,+ON,0))
SET NDP1=$GET(^(.1))
SET ND2=$GET(^(2))
SET Y=2
FOR X=0:0
SET X=$ORDER(^PS(55,DFN,5,+ON,12,X))
IF 'X
QUIT
SET Y=Y+1
SET ORTX(Y)=$GET(^(X,0))
+3 IF '$TEST
SET ND0=$GET(^PS(53.1,+ON,0))
SET NDP1=$GET(^(.1))
SET ND2=$GET(^(2))
SET Y=2
FOR X=0:0
SET X=$ORDER(^PS(53.1,+ON,12,X))
IF 'X
QUIT
SET Y=Y+1
SET ORTX(Y)=$GET(^(X,0))
+4 SET ORTX(1)=$SELECT($GET(RES)="NR":"RENEWAL -",$GET(RES)="OR":"RENEWED -",1:"")_$PIECE($GET(^PS(50.3,+NDP1,0)),U)
+5 SET ORTX(2)=" Give: "_$SELECT($PIECE(NDP1,U,2)]"":$PIECE(NDP1,U,2)_" ",1:"")_$PIECE($GET(^PS(51.2,+$PIECE(ND0,U,3),0)),U,3)_" "_$PIECE(ND2,U)_$SELECT($PIECE(ND2,U)["PRN":"",$PIECE(ND0,U,7)="P":" PRN",1:"")
+6 IF $GET(DFN)
IF $GET(ON)
IF ON["U"
SET ^PS(55,"AUE",DFN,+ON)=""
+7 QUIT
