PSGOE4 ;BIR/CML3-REGULAR ORDER ENTRY ;06 Feb 2001 4:31 PM
;;5.0; INPATIENT MEDICATIONS ;**2,50,64,58,111**;16 DEC 97
;
; Reference to ^PS(51.2 is supported by DBIA 2178.
;
;K PSGOES S PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),PSGPR=$S($D(PSJOERR):PSJORPV,1:PSGOEPR),(PSGSD,PSGFD,PSGSM,PSGHSM,PSGUD,PSGSI,PSGOROE1,PSGNEFD,PSGMRN)=""
K PSGOES S PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),PSGPR=PSGOEPR,(PSGSD,PSGFD,PSGSM,PSGHSM,PSGUD,PSGSI,PSGOROE1,PSGNEFD,PSGMRN)=""
S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"ORAL",'$D(^PS(51.2,PSGMR,0)):PSGMR,$P(^(0),"^")]"":$P(^(0),"^"),1:PSGMR) I PSGPR S PSGPRN=$P($G(^VA(200,PSGPR,0)),"^") S:PSGPRN="" PSGPRN=PSGPR
S PSGST=$S($P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C"),PSGSTN=$$ENSTN^PSGMI(PSGST),F1=53.1 K PSGFOK S PSGFOK(2)=""
S:$P(PSJSYSU,";",4) PSGFOK(2)="" K ^PS(53.45,PSJSYSP,1),^(2) I PSGDRG S ^(2,0)="^53.4502P^"_PSGDRG_"^1",^(1,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)=""
;I '$D(PSJOERR) S PSJNOO=$S($P(PSJSYSU,";",2):"E",1:"W"),PSJNOON=$S(PSJNOO="E":"PROVIDER ENTERED",1:"WRITTEN")
;
109 ; dosage ordered
I $P(PSJSYSU,";",4) D GETDOSE^PSJDOSE(PSGDRG) G:PSGOROE1 DONE G:'$G(PSGOE3) 3
W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
I X="" S X=PSGDO ;I X="" W $C(7)," (Required)" G 109
S PSGF2=109 I X="@" S PSGDO="" ;W $C(7)," (Required)" G 109
I X="@" D DEL G:%'=1 109 S (PSGDO,PSGFOK(109),PSGUD)="" G 3
I X?1."?" D ENHLP^PSGOEM(53.1,109) G 109
I $E(X)="^" D FF G:Y>0 @Y G 109
I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
I $S(X="":0,X?.E1C.E:1,$L(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X) W $C(7)," ",$S(X?1.P!(X=""):"(Required)",1:"??") D ENHLP^PSGOEM(53.1,109) G 109
S PSGDO=X,PSGFOK(109)=""
;
13 ; units per dose
;/** NO LONGER USE WITH POE
Q:$G(PSGOE3)
G:'$P(PSJSYSU,";",4) 3 I $D(PSGFOK(13)) S PSGFOK(13)=1 D 2^PSGOE42 S PSGFOK(13)="" G 3
;
A13 ;
W !,"UNITS PER DOSE: ",$S(PSGUD:PSGUD_"// ",1:"") R X:DTIME I X="^"!'$T S PSGOROE1=1 G DONE
I X="" W:'PSGUD " (1)" G S13
S PSGF2=13 I X="@",'PSGUD W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,13) G A13
I X="@" D DEL G:%'=1 13 S PSGUD="" G S13
I X?1."?" D ENHLP^PSGOEM(53.1,13) G A13
I $E(X)="^" D FF G:Y>0 @Y G A13
I X?1.2N1"/"1.2N S X=+$J(+X/$P(X,"/",2),0,2) W " ("_$E("0",X<1)_X_")"
I $S($L(X)>12:1,X'=+X:1,X>50:1,X<0:1,1:X?.N1"."3.N) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,13) G 13
S PSGUD=X W:'X " (1)"
;
S13 ;
S PSGFOK(13)="" I PSGDRG S $P(^PS(53.45,PSJSYSP,2,1,0),"^",2)=PSGUD
;
3 ; med route
W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) S PSGFOK(3)="" G 7
S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,2) G 3
I X?1."?" D ENHLP^PSGOEM(53.1,3)
I $E(X)="^" D FF G:Y>0 @Y G 3
K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3
S PSGMR=+Y,PSGMRN=$P(Y(0),"^") S PSGFOK(3)=""
;
7 ; schedule type
Q:$G(PSGOE3)
W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR(X,"coprocf","COPROCF") I X="^"!'$T S PSGOROE1=1 W $C(7) G DONE
I X="" S:PSGST="OC" PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" W " "_PSGSTN S PSGFOK(7)="" S $P(PSGNEDFD,"^",3)=PSGST G:PSGST="OC" 8^PSGOE41 G 26
S PSGF2=7 I X="@"!(X?1."?") W:X="@" $C(7)," ?? (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,7) G 7
I $E(X)="^" D FF G:Y>0 @Y G 7
I X="OC"!(X="R") S PSGST=X,$P(PSGNEDFD,"^",3)=X,PSGSTN=$S(X="R":"FILL on REQUEST",1:"ON CALL") W " "_PSGSTN S PSGFOK(7)="" G:X="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
F Y="C^CONTINUOUS","O^ONE TIME","OC^ON CALL","P^PRN","R^FILL on REQUEST" I $P($P(Y,"^",2),X)="" W $P($P(Y,"^",2),X,2) S PSGST=$P(Y,"^"),PSGSTN=$P(Y,"^",2),$P(PSGNEDFD,"^",3)=PSGST Q
E W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,7) G 7
I PSGST="OC"!(PSGST="R") S PSGFOK(7)="" G:PSGST="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
S PSGFOK(7)=""
;
26 ; schedule
W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
;*S PSGF2=26 S:X="" X=PSGSCH I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
S PSGF2=26 S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
I X?1."?" D ENHLP^PSGOEM(53.1,26) G 26
I $E(X)="^" D FF G:Y>0 @Y G 26
N PSJSLUP S PSJSLUP=1 D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
S PSGSCH=X,$P(PSGNEDFD,"^",4)=X,PSGFOK(26)="" I PSGS0XT="O" S $P(PSGNEDFD,"^",3)="O",PSGST="O",PSGSTN=$$ENSTN^PSGMI(PSGST)
I $G(PSGOE3) D Q
. S PSGSCH=X,PSGST=$S(PSGS0XT="O":"O",PSGST="R":"R",X["PRN":"P",X="ON CALL":"OC",PSGST]"":PSGST,1:"C"),PSGFOK(26)=""
. S $P(PSGNEDFD,"^",3)=PSGST S:PSGSCH=""!(X?1." ") PSGSCH="PRN"
. S PSGSTN=$$ENSTN^PSGMI(PSGST)
;***
;Q:$G(PSGOE3)
;
G ^PSGOE41
;
DONE ;
I PSGOROE1 K Y W $C(7)," ...order not entered..."
K F,F0,F1,PSGF2,F3,PSG,PSGSD,SDT Q
;
FF ; up-arrow to another field
D ENFF^PSGOEM I Y>0,Y'=109,Y'=13,Y'=3,Y'=7,Y'=26 S:Y=2 FB=PSGF2_"^PSGOE4" S Y=Y_"^PSGOE4"_$S("^39^8^10^25^"[("^"_Y_"^"):1,1:2)
Q
;
DEL ; delete entry
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
Q
PSGOE4 ;BIR/CML3-REGULAR ORDER ENTRY ;06 Feb 2001 4:31 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**2,50,64,58,111**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+4 ;
+5 ;K PSGOES S PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),PSGPR=$S($D(PSJOERR):PSJORPV,1:PSGOEPR),(PSGSD,PSGFD,PSGSM,PSGHSM,PSGUD,PSGSI,PSGOROE1,PSGNEFD,PSGMRN)=""
+6 KILL PSGOES
SET PSGMR=$SELECT($PIECE(PSGNEDFD,"^",2):$PIECE(PSGNEDFD,"^",2),1:PSGOEDMR)
SET PSGSCH=$PIECE(PSGNEDFD,"^",4)
SET PSGPR=PSGOEPR
SET (PSGSD,PSGFD,PSGSM,PSGHSM,PSGUD,PSGSI,PSGOROE1,PSGNEFD,PSGMRN)=""
+7 IF PSGMR
SET PSGMRN=$SELECT('$PIECE(PSGNEDFD,"^",2):"ORAL",'$DATA(^PS(51.2,PSGMR,0)):PSGMR,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:PSGMR)
IF PSGPR
SET PSGPRN=$PIECE($GET(^VA(200,PSGPR,0)),"^")
IF PSGPRN=""
SET PSGPRN=PSGPR
+8 SET PSGST=$SELECT($PIECE(PSGNEDFD,"^",3)]"":$PIECE(PSGNEDFD,"^",3),1:"C")
SET PSGSTN=$$ENSTN^PSGMI(PSGST)
SET F1=53.1
KILL PSGFOK
SET PSGFOK(2)=""
+9 IF $PIECE(PSJSYSU,";",4)
SET PSGFOK(2)=""
KILL ^PS(53.45,PSJSYSP,1),^(2)
IF PSGDRG
SET ^(2,0)="^53.4502P^"_PSGDRG_"^1"
SET ^(1,0)=PSGDRG
SET ^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)=""
+10 ;I '$D(PSJOERR) S PSJNOO=$S($P(PSJSYSU,";",2):"E",1:"W"),PSJNOON=$S(PSJNOO="E":"PROVIDER ENTERED",1:"WRITTEN")
+11 ;
109 ; dosage ordered
+1 IF $PIECE(PSJSYSU,";",4)
DO GETDOSE^PSJDOSE(PSGDRG)
IF PSGOROE1
GOTO DONE
IF '$GET(PSGOE3)
GOTO 3
+2 WRITE !,"DOSAGE ORDERED: ",$SELECT(PSGDO]"":PSGDO_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
IF '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+3 ;I X="" W $C(7)," (Required)" G 109
IF X=""
SET X=PSGDO
+4 ;W $C(7)," (Required)" G 109
SET PSGF2=109
IF X="@"
SET PSGDO=""
+5 IF X="@"
DO DEL
IF %'=1
GOTO 109
SET (PSGDO,PSGFOK(109),PSGUD)=""
GOTO 3
+6 IF X?1."?"
DO ENHLP^PSGOEM(53.1,109)
GOTO 109
+7 IF $EXTRACT(X)="^"
DO FF
IF Y>0
GOTO @Y
GOTO 109
+8 IF $EXTRACT(X,$LENGTH(X))=" "
FOR
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
+9 IF $SELECT(X="":0,X?.E1C.E:1,$LENGTH(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X)
WRITE $CHAR(7)," ",$SELECT(X?1.P!(X=""):"(Required)",1:"??")
DO ENHLP^PSGOEM(53.1,109)
GOTO 109
+10 SET PSGDO=X
SET PSGFOK(109)=""
+11 ;
13 ; units per dose
+1 ;/** NO LONGER USE WITH POE
+2 IF $GET(PSGOE3)
QUIT
+3 IF '$PIECE(PSJSYSU,";",4)
GOTO 3
IF $DATA(PSGFOK(13))
SET PSGFOK(13)=1
DO 2^PSGOE42
SET PSGFOK(13)=""
GOTO 3
+4 ;
A13 ;
+1 WRITE !,"UNITS PER DOSE: ",$SELECT(PSGUD:PSGUD_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
SET PSGOROE1=1
GOTO DONE
+2 IF X=""
IF 'PSGUD
WRITE " (1)"
GOTO S13
+3 SET PSGF2=13
IF X="@"
IF 'PSGUD
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,13)
GOTO A13
+4 IF X="@"
DO DEL
IF %'=1
GOTO 13
SET PSGUD=""
GOTO S13
+5 IF X?1."?"
DO ENHLP^PSGOEM(53.1,13)
GOTO A13
+6 IF $EXTRACT(X)="^"
DO FF
IF Y>0
GOTO @Y
GOTO A13
+7 IF X?1.2N1"/"1.2N
SET X=+$JUSTIFY(+X/$PIECE(X,"/",2),0,2)
WRITE " ("_$EXTRACT("0",X<1)_X_")"
+8 IF $SELECT($LENGTH(X)>12:1,X'=+X:1,X>50:1,X<0:1,1:X?.N1"."3.N)
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,13)
GOTO 13
+9 SET PSGUD=X
IF 'X
WRITE " (1)"
+10 ;
S13 ;
+1 SET PSGFOK(13)=""
IF PSGDRG
SET $PIECE(^PS(53.45,PSJSYSP,2,1,0),"^",2)=PSGUD
+2 ;
3 ; med route
+1 WRITE !,"MED ROUTE: ",$SELECT(PSGMR:PSGMRN_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
IF '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+2 IF X=""
IF PSGMR
SET X=PSGMRN
IF PSGMR'=PSGMRN
IF $DATA(^PS(51.2,PSGMR,0))
WRITE " "_$PIECE(^(0),"^",3)
SET PSGFOK(3)=""
GOTO 7
+3 SET PSGF2=3
IF $SELECT(X="@":1,X]"":0,1:'PSGMR)
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,2)
GOTO 3
+4 IF X?1."?"
DO ENHLP^PSGOEM(53.1,3)
+5 IF $EXTRACT(X)="^"
DO FF
IF Y>0
GOTO @Y
GOTO 3
+6 KILL DIC
SET DIC="^PS(51.2,"
SET DIC(0)="EMQZ"
SET DIC("S")="I $P(^(0),""^"",4)"
DO ^DIC
KILL DIC
IF Y'>0
GOTO 3
+7 SET PSGMR=+Y
SET PSGMRN=$PIECE(Y(0),"^")
SET PSGFOK(3)=""
+8 ;
7 ; schedule type
+1 IF $GET(PSGOE3)
QUIT
+2 WRITE !,"SCHEDULE TYPE: "_$SELECT(PSGSTN]"":PSGSTN_"// ",1:"")
READ X:DTIME
SET X=$TRANSLATE(X,"coprocf","COPROCF")
IF X="^"!'$TEST
SET PSGOROE1=1
WRITE $CHAR(7)
GOTO DONE
+3 IF X=""
IF PSGST="OC"
SET PSGSCH=PSGSTN
SET (PSGS0Y,PSGS0XT)=""
WRITE " "_PSGSTN
SET PSGFOK(7)=""
SET $PIECE(PSGNEDFD,"^",3)=PSGST
IF PSGST="OC"
GOTO 8^PSGOE41
GOTO 26
+4 SET PSGF2=7
IF X="@"!(X?1."?")
IF X="@"
WRITE $CHAR(7)," ?? (Required)"
IF X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,7)
GOTO 7
+5 IF $EXTRACT(X)="^"
DO FF
IF Y>0
GOTO @Y
GOTO 7
+6 IF X="OC"!(X="R")
SET PSGST=X
SET $PIECE(PSGNEDFD,"^",3)=X
SET PSGSTN=$SELECT(X="R":"FILL on REQUEST",1:"ON CALL")
WRITE " "_PSGSTN
SET PSGFOK(7)=""
IF X="R"
GOTO 26
SET PSGSCH=PSGSTN
SET (PSGS0Y,PSGS0XT)=""
GOTO 8^PSGOE41
+7 FOR Y="C^CONTINUOUS","O^ONE TIME","OC^ON CALL","P^PRN","R^FILL on REQUEST"
IF $PIECE($PIECE(Y,"^",2),X)=""
WRITE $PIECE($PIECE(Y,"^",2),X,2)
SET PSGST=$PIECE(Y,"^")
SET PSGSTN=$PIECE(Y,"^",2)
SET $PIECE(PSGNEDFD,"^",3)=PSGST
QUIT
+8 IF '$TEST
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,7)
GOTO 7
+9 IF PSGST="OC"!(PSGST="R")
SET PSGFOK(7)=""
IF PSGST="R"
GOTO 26
SET PSGSCH=PSGSTN
SET (PSGS0Y,PSGS0XT)=""
GOTO 8^PSGOE41
+10 SET PSGFOK(7)=""
+11 ;
26 ; schedule
+1 WRITE !,"SCHEDULE: ",$SELECT(PSGSCH]"":PSGSCH_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
IF '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+2 ;*S PSGF2=26 S:X="" X=PSGSCH I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
+3 SET PSGF2=26
IF X=""
SET X=PSGSCH
SET PSGSCH=""
IF "@"[X
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,26)
GOTO 26
+4 IF X?1."?"
DO ENHLP^PSGOEM(53.1,26)
GOTO 26
+5 IF $EXTRACT(X)="^"
DO FF
IF Y>0
GOTO @Y
GOTO 26
+6 NEW PSJSLUP
SET PSJSLUP=1
DO EN^PSGS0
IF '$DATA(X)
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,26)
GOTO 26
+7 SET PSGSCH=X
SET $PIECE(PSGNEDFD,"^",4)=X
SET PSGFOK(26)=""
IF PSGS0XT="O"
SET $PIECE(PSGNEDFD,"^",3)="O"
SET PSGST="O"
SET PSGSTN=$$ENSTN^PSGMI(PSGST)
+8 IF $GET(PSGOE3)
Begin DoDot:1
+9 SET PSGSCH=X
SET PSGST=$SELECT(PSGS0XT="O":"O",PSGST="R":"R",X["PRN":"P",X="ON CALL":"OC",PSGST]"":PSGST,1:"C")
SET PSGFOK(26)=""
+10 SET $PIECE(PSGNEDFD,"^",3)=PSGST
IF PSGSCH=""!(X?1." ")
SET PSGSCH="PRN"
+11 SET PSGSTN=$$ENSTN^PSGMI(PSGST)
End DoDot:1
QUIT
+12 ;***
+13 ;Q:$G(PSGOE3)
+14 ;
+15 GOTO ^PSGOE41
+16 ;
DONE ;
+1 IF PSGOROE1
KILL Y
WRITE $CHAR(7)," ...order not entered..."
+2 KILL F,F0,F1,PSGF2,F3,PSG,PSGSD,SDT
QUIT
+3 ;
FF ; up-arrow to another field
+1 DO ENFF^PSGOEM
IF Y>0
IF Y'=109
IF Y'=13
IF Y'=3
IF Y'=7
IF Y'=26
IF Y=2
SET FB=PSGF2_"^PSGOE4"
SET Y=Y_"^PSGOE4"_$SELECT("^39^8^10^25^"[("^"_Y_"^"):1,1:2)
+2 QUIT
+3 ;
DEL ; delete entry
+1 WRITE !?3,"SURE YOU WANT TO DELETE"
SET %=0
DO YN^DICN
IF %'=1
WRITE $CHAR(7)," <NOTHING DELETED>"
+2 QUIT
