PSGOE6.m

PSGOE6 ;BIR/CML3-ORDER ENTRY THROUGH OE/RR ;10 Mar 98 / 2:35 PM

 ;;5.0; INPATIENT MEDICATIONS ;**3,7,39,45,65,58,81,156,134**;16 DEC 97;Build 124

 ;

 ; Reference to ^PS(50.7 supported by DBIA #2180.

 ; Reference to ^PS(51.1 is supported by DBIA #2177.

 ; Reference to ^PS(51.2 is supported by DBIA #2178.

 ; Reference to ^PS(55 is supported by DBIA #2191.

 ; Reference to ^DD(53.1 is supported by DBIA #2256.

 ; Reference to ^VA(200 is supported by DBIA #10060.

 ; Reference to ^DICN is supported by DBIA #10009.

 ;

 K PSGFOK S F1=53.1,PSGPR=$S($D(PSGOERR):PSJORPV,1:PSGOEPR),PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),(PSGOROE1,PSGSI,SDT,PSGMRN,PSGSM,PSGHSM,PSGUD,PSGSD,PSGFD,PSGSI,PSGNEFD,PSGNESD)=""

 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")

 ; Naked references in line below refer to ^PS(53.45,PSJSYSP

 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)=""

 ;

109 ; dosage ordered

 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="@" W $C(7),"  (Required)" G 109

 I X?1."?" S F1=53.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?.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:"??") S X="?" D ENHLP^PSGOEM(53.1,109) G 109

 S PSGDO=X,PSGFOK(109)=""

 ;

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 26

 S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) 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=Y(0,0),PSGFOK(3)=""

 ;

26 ; schedule

 W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE

 S:X="" X=PSGSCH S PSGF2=26 ; 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

 I X="" S (PSGS0XT,PSGS0Y,PSGST)=""

 E  D EN^PSGS0 I '$D(X) W $C(7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26

 S PSGSCH=X,(PSGFOK(26),PSGST)="",PSGOES=1 S:PSGS0XT="O" $P(PSGNEDFD,"^",3)="O",PSGST="O" D ^PSGNE3 K PSGOES

 ;

66 ; provider's comments

 ;

 ;

DONE ;

 I PSGOROE1 K Y W $C(7),"  ...order not entered..."

 K F,F0,F1,PSGF2,F3,PSGFOK,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 $$CODES2^PSIVUTL(53.1,X) 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

 Q

 ;

DEL ;

 W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W "  <NOTHING DELETED>"

 Q

 ;

GTST(ON) ; Find schedule type for pending order.

 N PD,PDAP,ST,X,ST1 S ST=""

 S ST=$P($G(^PS(53.1,+ON,0)),"^",7)

 I $P($G(^PS(53.1,+ON,0)),U,24)="R" D

 .; naked ref below is from line above, ^PS(53.1,ON,0)

 .S X=$P(^(0),U,25) S ST=$S(X["N"!(X["P"):$P($G(^PS(53.1,+X,0)),U,7),X["V":"C",1:$P($G(^PS(55,PSGP,5,+X,0)),U,7))

 .I ST]"" S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) Q

 I ST'="" D

 . S ST1=""

 . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST1=$P(X,U,7)

 . I $G(ST1)="R" S ST="R"

 . K ST1

 I ST="" D

 . ;PSJ*5*156 - Don't allow backdoor to override intended schedule type from CPRS unless the default

 . ;            schedule type (if any) is "Fill on Request".

 . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST=$P(X,U,7)  ;see if there is a default schedule type.

 . I ST="R" Q  ;Fill on Request default schedule type will override incoming schedule type from CPRS

 . S ST=""  ;Reset to null in case default schedule type other than Fill on Request is defined.

 . D OTS I ST="O" Q

 . I PSGSCH="ON CALL"!(PSGSCH="ONCALL")!(PSGSCH="ON-CALL") S ST="OC" Q

 . I PSGSCH["PRN" S ST="P" Q

 . S ST="C"

 S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST)

 Q

OTS I PSGSCH]"" S X=+$O(^PS(51.1,"B",PSGSCH,0)) I $P($G(^PS(51.1,X,0)),"^",5)="O" S ST="O" Q

 I PSGSCH="TODAY"!(PSGSCH="NOW")!(PSGSCH="STAT")!(PSGSCH="ONCE")!(PSGSCH="ONE TIME")!(PSGSCH="ONE-TIME")!(PSGSCH="ONETIME")!(PSGSCH="1TIME")!(PSGSCH="1 TIME")!(PSGSCH="1-TIME") S ST="O"

 Q

PSGOE6    ;BIR/CML3-ORDER ENTRY THROUGH OE/RR ;10 Mar 98 / 2:35 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**3,7,39,45,65,58,81,156,134**;16 DEC 97;Build 124

 +2       ;

 +3       ; Reference to ^PS(50.7 supported by DBIA #2180.

 +4       ; Reference to ^PS(51.1 is supported by DBIA #2177.

 +5       ; Reference to ^PS(51.2 is supported by DBIA #2178.

 +6       ; Reference to ^PS(55 is supported by DBIA #2191.

 +7       ; Reference to ^DD(53.1 is supported by DBIA #2256.

 +8       ; Reference to ^VA(200 is supported by DBIA #10060.

 +9       ; Reference to ^DICN is supported by DBIA #10009.

 +10      ;

 +11       KILL PSGFOK

           SET F1=53.1

           SET PSGPR=$SELECT($DATA(PSGOERR):PSJORPV,1:PSGOEPR)

           SET PSGMR=$SELECT($PIECE(PSGNEDFD,"^",2):$PIECE(PSGNEDFD,"^",2),1:PSGOEDMR)

           SET PSGSCH=$PIECE(PSGNEDFD,"^",4)

           SET (PSGOROE1,PSGSI,SDT,PSGMRN,PSGSM,PSGHSM,PSGUD,PSGSD,PSGFD,PSGSI,PSGNEFD,PSGNESD)=""

 +12       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

 +13       SET PSGST=$SELECT($PIECE(PSGNEDFD,"^",3)]"":$PIECE(PSGNEDFD,"^",3),1:"C")

 +14      ; Naked references in line below refer to ^PS(53.45,PSJSYSP

 +15       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)=""

 +16      ;

109       ; dosage ordered

 +1        WRITE !,"DOSAGE ORDERED: ",$SELECT(PSGDO]"":PSGDO_"// ",1:"")

           READ X:DTIME

           IF X="^"!'$TEST

               IF '$TEST

                   WRITE $CHAR(7)

               SET PSGOROE1=1

               GOTO DONE

 +2        IF X=""

               SET X=PSGDO

               IF X=""

                   WRITE $CHAR(7),"  (Required)"

                   GOTO 109

 +3        SET PSGF2=109

           IF X="@"

               WRITE $CHAR(7),"  (Required)"

               GOTO 109

 +4        IF X?1."?"

               SET F1=53.1

               DO ENHLP^PSGOEM(53.1,109)

               GOTO 109

 +5        IF $EXTRACT(X)="^"

               DO FF

               IF Y>0

                   GOTO @Y

               GOTO 109

 +6        IF $EXTRACT(X,$LENGTH(X))=" "

               FOR 

                   SET X=$EXTRACT(X,1,$LENGTH(X)-1)

                   IF $EXTRACT(X,$LENGTH(X))'=" "

                       QUIT 

 +7        IF $SELECT(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:"??")

               SET X="?"

               DO ENHLP^PSGOEM(53.1,109)

               GOTO 109

 +8        SET PSGDO=X

           SET PSGFOK(109)=""

 +9       ;

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 26

 +3        SET PSGF2=3

           IF $SELECT(X="@":1,X]"":0,1:'PSGMR)

               WRITE $CHAR(7),"  (Required)"

               SET X="?"

               DO ENHLP^PSGOEM(53.1,3)

               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=Y(0,0)

           SET PSGFOK(3)=""

 +8       ;

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       ; I "@"[X W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26

           IF X=""

               SET X=PSGSCH

           SET PSGF2=26

 +3        IF X?1."?"

               DO ENHLP^PSGOEM(53.1,26)

               GOTO 26

 +4        IF $EXTRACT(X)="^"

               DO FF

               IF Y>0

                   GOTO @Y

               GOTO 26

 +5        IF X=""

               SET (PSGS0XT,PSGS0Y,PSGST)=""

 +6       IF '$TEST

               DO EN^PSGS0

               IF '$DATA(X)

                   WRITE $CHAR(7),"  ??"

                   SET X="?"

                   DO ENHLP^PSGOEM(53.1,26)

                   GOTO 26

 +7        SET PSGSCH=X

           SET (PSGFOK(26),PSGST)=""

           SET PSGOES=1

           IF PSGS0XT="O"

               SET $PIECE(PSGNEDFD,"^",3)="O"

               SET PSGST="O"

           DO ^PSGNE3

           KILL PSGOES

 +8       ;

66        ; provider's comments

 +1       ;

 +2       ;

DONE      ;

 +1        IF PSGOROE1

               KILL Y

               WRITE $CHAR(7),"  ...order not entered..."

 +2        KILL F,F0,F1,PSGF2,F3,PSGFOK,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 $$CODES2^PSIVUTL(53.1,X)

               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

 +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       ;

GTST(ON)  ; Find schedule type for pending order.

 +1        NEW PD,PDAP,ST,X,ST1

           SET ST=""

 +2        SET ST=$PIECE($GET(^PS(53.1,+ON,0)),"^",7)

 +3        IF $PIECE($GET(^PS(53.1,+ON,0)),U,24)="R"

               Begin DoDot:1

 +4       ; naked ref below is from line above, ^PS(53.1,ON,0)

 +5                SET X=$PIECE(^(0),U,25)

                   SET ST=$SELECT(X["N"!(X["P"):$PIECE($GET(^PS(53.1,+X,0)),U,7),X["V":"C",1:$PIECE($GET(^PS(55,PSGP,5,+X,0)),U,7))

 +6                IF ST]""

                       SET (PSGOST,PSGST)=ST

                       SET PSGSTN=$$ENSTN^PSGMI(ST)

                       QUIT 

               End DoDot:1

 +7        IF ST'=""

               Begin DoDot:1

 +8                SET ST1=""

 +9                SET PD=+$GET(^PS(53.1,+ON,.2))

                   SET X=$GET(^PS(50.7,PD,0))

                   SET ST1=$PIECE(X,U,7)

 +10               IF $GET(ST1)="R"

                       SET ST="R"

 +11               KILL ST1

               End DoDot:1

 +12       IF ST=""

               Begin DoDot:1

 +13      ;PSJ*5*156 - Don't allow backdoor to override intended schedule type from CPRS unless the default

 +14      ;            schedule type (if any) is "Fill on Request".

 +15      ;see if there is a default schedule type.

                   SET PD=+$GET(^PS(53.1,+ON,.2))

                   SET X=$GET(^PS(50.7,PD,0))

                   SET ST=$PIECE(X,U,7)

 +16      ;Fill on Request default schedule type will override incoming schedule type from CPRS

                   IF ST="R"

                       QUIT 

 +17      ;Reset to null in case default schedule type other than Fill on Request is defined.

                   SET ST=""

 +18               DO OTS

                   IF ST="O"

                       QUIT 

 +19               IF PSGSCH="ON CALL"!(PSGSCH="ONCALL")!(PSGSCH="ON-CALL")

                       SET ST="OC"

                       QUIT 

 +20               IF PSGSCH["PRN"

                       SET ST="P"

                       QUIT 

 +21               SET ST="C"

               End DoDot:1

 +22       SET (PSGOST,PSGST)=ST

           SET PSGSTN=$$ENSTN^PSGMI(ST)

 +23       QUIT 

OTS        IF PSGSCH]""

               SET X=+$ORDER(^PS(51.1,"B",PSGSCH,0))

               IF $PIECE($GET(^PS(51.1,X,0)),"^",5)="O"

                   SET ST="O"

                   QUIT 

 +1        IF PSGSCH="TODAY"!(PSGSCH="NOW")!(PSGSCH="STAT")!(PSGSCH="ONCE")!(PSGSCH="ONE TIME")!(PSGSCH="ONE-TIME")!(PSGSCH="ONETIME")!(PSGSCH="1TIME")!(PSGSCH="1 TIME")!(PSGSCH="1-TIME")

               SET ST="O"

 +2        QUIT