PSGOE31 ;BIR/CML3-ORDER ENTRY THROUGH OE/RR (CONT.) ;09 JAN 97 / 2:28 PM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
;
;**************************************************
;*** As of 1/9/97 This routine is no longer use ***.
;**************************************************
1 ; provider
G:$S($D(PSJOERR):1,+PSJSYSU=3:0,1:$P(PSJSYSU,";",2)) 5
A1 W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
S PSGF2=1 I $S(X="@":1,X="":'PSGPR,1:0) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,1) G A1
I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W " "_$P(^("PS"),"^",2)_" "_$P(^("PS"),"^",3) S PSGFOK(1)="" G:$P(PSJSYSW0,"^",24) 5 G DONE
I X?1."?" D ENHLP^PSGOEM(53.1,1)
I $E(X)="^" D FF G:Y>0 @Y G A1
K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC I Y'>0 G A1
S PSGPR=+Y,PSGPRN=$P(Y(0,0),"^"),PSGFOK(1)=""
;
5 ; self med
I '$P(PSJSYSW0,"^",24) G 106:PSGOEORF,DONE
A5 W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" " (",$P("NO^YES","^",PSGSM+1),")" G:'PSGSM 106:PSGOEORF,DONE S PSGFOK(5)="" G 6
S PSGF2=5 I X="@" W:PSGSM="" $C(7)," ??" G:PSGSM="" A5 D DEL G:%'=1 A5 S (PSGSM,PSGHSM)="" G 106:PSGOEORF,DONE
I X?1"^".E D FF G:Y>0 @Y G A5
I X?1."?" D ENHLP^PSGOEM(53.1,5) G A5
D YN I S PSGSM=$E(X)="Y",PSGFOK(5)="" G 6:PSGSM,106:PSGOEORF,DONE
W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
;
6 ; hospital supplied self med
W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
I "01"[X,$L(X)<2 S:PSGHSM=""&(X]"") PSGHSM=X W:PSGHSM]"" " (",$P("NO^YES","^",PSGHSM+1),")" G 106:PSGOEORF,DONE
I X="@" W:PSGHSM="" $C(7)," ??" G:PSGHSM="" 6 D DEL G:%'=1 6 S PSGHSM="" G 106:PSGOEORF,DONE
S PSGF2=6 I X?1"^".E D FF G:Y>0 @Y G 6
I X?1."?" D ENHLP^PSGOEM(53.1,6) G 6
D YN I S PSGHSM=$E(X)="Y" G 106:PSGOEORF,DONE
W $C(7) D ENHLP^PSGOEM(53.1,6) G 6
;
106 ; nature of order
W !,"This is an old nature of order call from ^PSGOE31.",!
Q
G:'PSGOEORF DONE I $S($D(PSJOERR):1,$P(PSJSYSU,";",2):1,1:'PSJSYSU) S PSGFOK(106)="" G DONE
A106 W !!,"NATURE OF ORDER: ",PSJNOON,"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S:'$T X="^" S PSGOROE1=1 G DONE
I X="" W:PSJNOON]"" " ",PSJNOON S PSGFOK(106)="" G DONE
S PSGF2=106 I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,106) G A106
I $E(X)="^" D FF G:Y>0 @Y G A106
F Y="W^WRITTEN","P^TELEPHONED","V^VERBAL" I $S(X=$P(Y,"^"):1,1:$P($P(Y,"^",2),X)="") W $S(X=$P(Y,"^"):" "_$P(Y,"^",2),1:$P($P(Y,"^",2),X,2)) S PSJNOO=$P(Y,"^"),PSJNOON=$P(Y,"^",2) Q
E W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,106) G A106
S PSGFOK(106)=""
;
DONE ;
I PSGOROE1 K Y W $C(7)," ...order not entered..."
K F,F0,F1,PSGF2,F3,PSGFOK,PSGOROE1,PSGSD,SDT Q
;
FF ; up-arrow to another field
S Y=-1 I '$D(PSGFOK) W $C(7)," ??" Q
S X=$E(X,2,99) I X=+X S Y=$S($D(PSGFOK(X)):X,1:-1) W " " W:Y>0 $P(^DD(53.1,X,0),"^") W:Y'>0 $C(7),"??" Q
K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGFOK(+Y))" D ^DIC K DIC S Y=+Y I Y>0 S:Y=2 FB=PSGF2 I Y'=1,Y'=2,Y'=5,Y'=6 S Y=Y_"^PSGOE3"
Q
;
DEL ;
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W " <NOTHING DELETED>"
Q
;
YN ; yes/no as a set of codes
I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,Y+1,$L(X))
F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
Q
;
2 ; dispense drug multiple
I PSGDRG,'$D(^PS(53.45,PSJSYSP,2)) S ^(2,0)="^53.4502P^1^1",^(1,0)=PSGDRG_"^"_PSGUD
K DA,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(53.4502,1)=".01;.02" D ^DIE
I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!"
G @FB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE31 3968 printed Sep 23, 2025@19:37:58 Page 2
PSGOE31 ;BIR/CML3-ORDER ENTRY THROUGH OE/RR (CONT.) ;09 JAN 97 / 2:28 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ;
+3 ;**************************************************
+4 ;*** As of 1/9/97 This routine is no longer use ***.
+5 ;**************************************************
1 ; provider
+1 if $SELECT($DATA(PSJOERR)
GOTO 5
A1 WRITE !,"PROVIDER: ",$SELECT(PSGPR:PSGPRN_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+1 SET PSGF2=1
IF $SELECT(X="@":1,X="":'PSGPR,1:0)
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,1)
GOTO A1
+2 IF X=""
IF PSGPR
SET X=PSGPRN
IF PSGPR'=PSGPRN
IF $DATA(^VA(200,PSGPR,"PS"))
WRITE " "_$PIECE(^("PS"),"^",2)_" "_$PIECE(^("PS"),"^",3)
SET PSGFOK(1)=""
if $PIECE(PSJSYSW0,"^",24)
GOTO 5
GOTO DONE
+3 IF X?1."?"
DO ENHLP^PSGOEM(53.1,1)
+4 IF $EXTRACT(X)="^"
DO FF
if Y>0
GOTO @Y
GOTO A1
+5 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="EMQZ"
SET DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)"
DO ^DIC
KILL DIC
IF Y'>0
GOTO A1
+6 SET PSGPR=+Y
SET PSGPRN=$PIECE(Y(0,0),"^")
SET PSGFOK(1)=""
+7 ;
5 ; self med
+1 IF '$PIECE(PSJSYSW0,"^",24)
if PSGOEORF
GOTO 106
GOTO DONE
A5 WRITE !,"SELF MED: "
if PSGSM]""
WRITE $PIECE("NO^YES","^",PSGSM+1),"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+1 IF "01"[X
IF $LENGTH(X)<2
if PSGSM=""&(X]"")
SET PSGSM=X
if PSGSM]""
WRITE " (",$PIECE("NO^YES","^",PSGSM+1),")"
if 'PSGSM
if PSGOEORF
GOTO 106
GOTO DONE
SET PSGFOK(5)=""
GOTO 6
+2 SET PSGF2=5
IF X="@"
if PSGSM=""
WRITE $CHAR(7)," ??"
if PSGSM=""
GOTO A5
DO DEL
if %'=1
GOTO A5
SET (PSGSM,PSGHSM)=""
if PSGOEORF
GOTO 106
GOTO DONE
+3 IF X?1"^".E
DO FF
if Y>0
GOTO @Y
GOTO A5
+4 IF X?1."?"
DO ENHLP^PSGOEM(53.1,5)
GOTO A5
+5 DO YN
IF $TEST
SET PSGSM=$EXTRACT(X)="Y"
SET PSGFOK(5)=""
if PSGSM
GOTO 6
if PSGOEORF
GOTO 106
GOTO DONE
+6 WRITE $CHAR(7)
DO ENHLP^PSGOEM(53.1,5)
GOTO A5
+7 ;
6 ; hospital supplied self med
+1 WRITE !,"HOSPITAL SUPPLIED SELF MED: "
if PSGHSM]""
WRITE $PIECE("NO^YES","^",PSGHSM+1),"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+2 IF "01"[X
IF $LENGTH(X)<2
if PSGHSM=""&(X]"")
SET PSGHSM=X
if PSGHSM]""
WRITE " (",$PIECE("NO^YES","^",PSGHSM+1),")"
if PSGOEORF
GOTO 106
GOTO DONE
+3 IF X="@"
if PSGHSM=""
WRITE $CHAR(7)," ??"
if PSGHSM=""
GOTO 6
DO DEL
if %'=1
GOTO 6
SET PSGHSM=""
if PSGOEORF
GOTO 106
GOTO DONE
+4 SET PSGF2=6
IF X?1"^".E
DO FF
if Y>0
GOTO @Y
GOTO 6
+5 IF X?1."?"
DO ENHLP^PSGOEM(53.1,6)
GOTO 6
+6 DO YN
IF $TEST
SET PSGHSM=$EXTRACT(X)="Y"
if PSGOEORF
GOTO 106
GOTO DONE
+7 WRITE $CHAR(7)
DO ENHLP^PSGOEM(53.1,6)
GOTO 6
+8 ;
106 ; nature of order
+1 WRITE !,"This is an old nature of order call from ^PSGOE31.",!
+2 QUIT
+3 if 'PSGOEORF
GOTO DONE
IF $SELECT($DATA(PSJOERR):1,$PIECE(PSJSYSU,";",2):1,1:'PSJSYSU)
SET PSGFOK(106)=""
GOTO DONE
A106 WRITE !!,"NATURE OF ORDER: ",PSJNOON,"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
SET PSGOROE1=1
GOTO DONE
+1 IF X=""
if PSJNOON]""
WRITE " ",PSJNOON
SET PSGFOK(106)=""
GOTO DONE
+2 SET PSGF2=106
IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,106)
GOTO A106
+3 IF $EXTRACT(X)="^"
DO FF
if Y>0
GOTO @Y
GOTO A106
+4 FOR Y="W^WRITTEN","P^TELEPHONED","V^VERBAL"
IF $SELECT(X=$PIECE(Y,"^"):1,1:$PIECE($PIECE(Y,"^",2),X)="")
WRITE $SELECT(X=$PIECE(Y,"^"):" "_$PIECE(Y,"^",2),1:$PIECE($PIECE(Y,"^",2),X,2))
SET PSJNOO=$PIECE(Y,"^")
SET PSJNOON=$PIECE(Y,"^",2)
QUIT
+5 IF '$TEST
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,106)
GOTO A106
+6 SET PSGFOK(106)=""
+7 ;
DONE ;
+1 IF PSGOROE1
KILL Y
WRITE $CHAR(7)," ...order not entered..."
+2 KILL F,F0,F1,PSGF2,F3,PSGFOK,PSGOROE1,PSGSD,SDT
QUIT
+3 ;
FF ; up-arrow to another field
+1 SET Y=-1
IF '$DATA(PSGFOK)
WRITE $CHAR(7)," ??"
QUIT
+2 SET X=$EXTRACT(X,2,99)
IF X=+X
SET Y=$SELECT($DATA(PSGFOK(X)):X,1:-1)
WRITE " "
if Y>0
WRITE $PIECE(^DD(53.1,X,0),"^")
if Y'>0
WRITE $CHAR(7),"??"
QUIT
+3 KILL DIC
SET DIC="^DD(53.1,"
SET DIC(0)="QEM"
SET DIC("S")="I $D(PSGFOK(+Y))"
DO ^DIC
KILL DIC
SET Y=+Y
IF Y>0
if Y=2
SET FB=PSGF2
IF Y'=1
IF Y'=2
IF Y'=5
IF Y'=6
SET Y=Y_"^PSGOE3"
+4 QUIT
+5 ;
DEL ;
+1 WRITE !?3,"SURE YOU WANT TO DELETE"
SET %=0
DO YN^DICN
IF %'=1
WRITE " <NOTHING DELETED>"
+2 QUIT
+3 ;
YN ; yes/no as a set of codes
+1 IF X'?.U
FOR Y=1:1:$LENGTH(X)
IF $EXTRACT(X,Y)?1L
SET X=$EXTRACT(X,1,Y-1)_$CHAR($ASCII(X,Y)-32)_$EXTRACT(X,Y+1,$LENGTH(X))
+2 FOR Y="NO","YES"
IF $PIECE(Y,X)=""
WRITE $PIECE(Y,X,2)
QUIT
+3 QUIT
+4 ;
2 ; dispense drug multiple
+1 IF PSGDRG
IF '$DATA(^PS(53.45,PSJSYSP,2))
SET ^(2,0)="^53.4502P^1^1"
SET ^(1,0)=PSGDRG_"^"_PSGUD
+2 KILL DA,DR
SET DIE="^PS(53.45,"
SET DA=PSJSYSP
SET DR=2
SET DR(53.4502,1)=".01;.02"
DO ^DIE
+3 IF '$ORDER(^PS(53.45,PSJSYSP,2,0))
WRITE $CHAR(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!"
+4 GOTO @FB
