- PSGOE8 ;BIR/CML3-EDIT ORDERS IN 53.1 ;25 SEP 97 / 10:58 AM
- ;;5.0; INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192**;16 DEC 97;Build 1
- ;
- ; Reference to ^PS(50.7 is 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 ^PSDRUG is supported by DBIA# 2192
- ;
- 101 ;Orderable Item
- S MSG=0,F2=101,PSGOOPD=PSGPD,PSGOOPDN=PSGPDN S:PSGOEEF(F2) BACK="101^PSGOE8"
- S %=1 I $P(PSJSYSU,";",3)>1 W !!,$C(7),"WARNING! If you change the drug of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted." F W !,"Do you wish to continue" S %=2 D YN^DICN Q:%
- I %'=1 G DONE
- A101 ;
- I $$PNDREN($G(PSGORD)) D Q
- . W !!?5,"Orderable Item may not be edited at this point." D PAUSE^VALM1
- W !,"ORDERABLE ITEM: ",$S(PSGPD:PSGPDN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
- I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$D(^PS(50.7,PSGPD,0)) G DONE
- I $S(X="@":1,X]"":0,1:'PSGPD) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,101) G A101
- I X?1."?" D ENHLP^PSGOEM(53.1,101)
- I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A101
- ;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-references
- K DIC,D S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")",D="B^C" D MIX^DIC1 K DIC,D I Y'>0 G A101
- F S %=2 D DH,YN^DICN Q:%
- I %'=1 G A101
- S (PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
- S PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
- S PSGPDNX=1,PSGDO="",(PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG) K ^PS(53.45,PSJSYSP,2) S X=$O(^PSDRUG("ASP",PSGPD,0)) I X,'$O(^(X)) D
- .S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1",^(1,0)=X,^PS(53.45,PSJSYSP,2,"B",X,1)=""
- D ENDRG^PSGOEF1(PSGPD,0)
- G DONE
- ;
- 109 ; dosage ordered
- S MSG=0,F2=109 S:PSGOEEF(F2) BACK="109^PSGOE8"
- A109 ;
- I $$PNDREN($G(PSGORD)) D Q
- . W !!?5,"Dosage may not be edited at this point." D PAUSE^VALM1
- S PSGOEEF(F2)=PSGOEE
- D EDITDOSE^PSJDOSE S X=PSGDO G DONE
- W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
- I X=""&(PSGDO]"") S X=PSGDO
- I $$CHECK(PSJSYSP)&(X="")&(PSGDO']"") W $C(7)," (Required) " G A109
- I $$CHECK(PSJSYSP)&(X="@") W $C(7)," (Required) " G A109
- I '$$CHECK(PSJSYSP)&(X="@") S PSGDO="" G DONE
- I X?1."?" D ENHLP^PSGOEM(53.1,109) G A109
- I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A109
- 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="":0,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 A109
- S PSGDO=X G DONE
- ;
- 3 ; med route
- S MSG=0,F2=3 S:PSGOEEF(F2) BACK="3^PSGOE8"
- A3 I $$PNDREN($G(PSGORD)) D Q
- . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
- W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
- I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) G DONE
- I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G A3
- I X?1."?" D ENHLP^PSGOEM(53.1,3)
- I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A3
- K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G A3
- S PSGMR=+Y,PSGMRN=Y(0,0) G DONE
- ;
- 7 ; schedule type
- S MSG=0,F2=7 S:PSGOEEF(F2) BACK="7^PSGOE8"
- A7 W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR(X,"coprocf","COPROCF") I X="^"!'$T S PSGOEE=0 W $C(7) G DONE
- I X="" W:PSGSTN]"" " ",PSGSTN G DONE
- I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,7) G A7
- I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A7
- ; 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 PSGOEEF(7)="" G:X="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
- A7DEF ;BHW;PSJ*5*188;Added tag. Called by A26 to set default Schedule type.
- F Y="C^CONTINUOUS","O^ONE TIME","OC^ON CALL","P^PRN","R^FILL on REQUEST" 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 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 A7
- ; I PSGST="OC"!(PSGST="R") S PSGOEEF(7)="" G:PSGST="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
- G DONE
- ;
- 26 ; schedule
- S MSG=0,F2=26 S:PSGOEEF(F2) BACK="26^PSGOE8"
- A26 I $$PNDREN($G(PSGORD)) D Q
- . W !!?5,"Schedule may not be edited at this point." D PAUSE^VALM1
- W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
- S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
- I X?1."?" D ENHLP^PSGOEM(53.1,26) G A26
- I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A26
- ;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), Highlight Admin Times if they changed.
- N PSGOES,PSJSLUP,PSGSFLG,PSGSCIEN S PSJSLUP=1,PSGSFLG=1 D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
- S PSGSCH=X I PSGS0Y'=PSGAT S PSGAT=PSGS0Y W !!,"NOTE: This change in schedule also changes the ADMIN TIMES.",! S MSG=1,PSGOEEF(39)=1 D:$G(PSJNEWOE) PAUSE^VALM1
- ;BHW;PSJ*5*188;Get Schedule type of Selected Schedule, If One-Time type, set Highlighting ON (PSGOEEF(7)=1) and call existing Schedule type logic.
- N X,Y,DIC
- I '$G(PSGSCIEN) S PSGSCIEN=$O(^PS(51.1,"AC","PSJ",PSGSCH,"")) ;Get First schedule with PSJ Package Prefix as default for Lookup
- S X=$S($G(PSGSCIEN):$G(PSGSCIEN),1:PSGSCH),DIC="51.1",DIC(0)="NZ" D ^DIC
- I $P($G(Y(0)),"^",5)="O" S X="O" S PSGOEEF(7)=1 G A7DEF
- ;
- DONE ;
- I PSGOEE G:'PSGOEEF(F2) @BACK S PSGOEE=PSGOEEF(F2)
- K F,F0,F2 Q
- ;
- DEL ; delete entry
- W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
- Q
- ;
- DH ;
- W !!?2,"When the drug of an order is changed, the Dosage Ordered and Dispense Drug(s)",!,"for the order are no longer valid, and therefore deleted from the order.",!,"If possible, a new corresponding dispense drug will be added to the order."
- W !!?2,"Answer 'YES' to continue with this change. Answer 'NO' to select another",!,"drug or to accept the drug as it was. Enter an '^' the exit this edit." Q
- ;
- CHECK(PSJSYSP) ; Check to see if multiple dispense drugs
- ; Input - PSJSYSP
- ; Returns 0 = only one.
- ; 1 = more than one
- ; Checks Inactive Date and doesn't count if < or = today.
- N PSJRSB,PSJINACT,PSJRBCNT S PSJRBCNT=0
- F PSJRSB=0:0 S PSJRSB=$O(^PS(53.45,PSJSYSP,2,PSJRSB)) Q:'PSJRSB D
- .S PSJINACT=$P(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
- .I (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT)) D
- ..S PSJRBCNT=$S('$D(PSJRBCNT):1,1:PSJRBCNT+1)
- Q $S(PSJRBCNT>1:1,1:0)
- ;
- PNDREN(PNDON) ;
- I PNDON'["P" Q 0
- S RNWL="^PS(53.1,"_+PNDON_",0)" S RNWL=$G(@(RNWL)) S RNWL=$S($P(RNWL,"^",24)="R":1,1:0)
- Q RNWL
- PSGOE8 ;BIR/CML3-EDIT ORDERS IN 53.1 ;25 SEP 97 / 10:58 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192**;16 DEC 97;Build 1
- +2 ;
- +3 ; Reference to ^PS(50.7 is 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 ^PSDRUG is supported by DBIA# 2192
- +7 ;
- 101 ;Orderable Item
- +1 SET MSG=0
- SET F2=101
- SET PSGOOPD=PSGPD
- SET PSGOOPDN=PSGPDN
- IF PSGOEEF(F2)
- SET BACK="101^PSGOE8"
- +2 SET %=1
- IF $PIECE(PSJSYSU,";",3)>1
- WRITE !!,$CHAR(7),"WARNING! If you change the drug of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted."
- FOR
- WRITE !,"Do you wish to continue"
- SET %=2
- DO YN^DICN
- IF %
- QUIT
- +3 IF %'=1
- GOTO DONE
- A101 ;
- +1 IF $$PNDREN($GET(PSGORD))
- Begin DoDot:1
- +2 WRITE !!?5,"Orderable Item may not be edited at this point."
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +3 WRITE !,"ORDERABLE ITEM: ",$SELECT(PSGPD:PSGPDN_"// ",1:"")
- READ X:DTIME
- IF X="^"!'$TEST
- IF '$TEST
- WRITE $CHAR(7)
- SET PSGOEE=0
- GOTO DONE
- +4 IF X=""
- IF PSGPD
- SET X=PSGPDN
- IF PSGPD'=PSGPDN
- IF $DATA(^PS(50.7,PSGPD,0))
- GOTO DONE
- +5 IF $SELECT(X="@":1,X]"":0,1:'PSGPD)
- WRITE $CHAR(7)," (Required)"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,101)
- GOTO A101
- +6 IF X?1."?"
- DO ENHLP^PSGOEM(53.1,101)
- +7 IF $EXTRACT(X)="^"
- DO ENFF^PSGOE82
- IF Y>0
- GOTO @Y
- GOTO A101
- +8 ;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-references
- +9 KILL DIC,D
- SET DIC="^PS(50.7,"
- SET DIC(0)="EMQZ"
- SET DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")"
- SET D="B^C"
- DO MIX^DIC1
- KILL DIC,D
- IF Y'>0
- GOTO A101
- +10 FOR
- SET %=2
- DO DH
- DO YN^DICN
- IF %
- QUIT
- +11 IF %'=1
- GOTO A101
- +12 SET (PSGPDRG,PSGPD)=+Y
- SET (PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
- +13 SET PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
- +14 SET PSGPDNX=1
- SET PSGDO=""
- SET (PSGPDRG,PSGPD)=+Y
- SET (PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
- KILL ^PS(53.45,PSJSYSP,2)
- SET X=$ORDER(^PSDRUG("ASP",PSGPD,0))
- IF X
- IF '$ORDER(^(X))
- Begin DoDot:1
- +15 SET ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1"
- SET ^(1,0)=X
- SET ^PS(53.45,PSJSYSP,2,"B",X,1)=""
- End DoDot:1
- +16 DO ENDRG^PSGOEF1(PSGPD,0)
- +17 GOTO DONE
- +18 ;
- 109 ; dosage ordered
- +1 SET MSG=0
- SET F2=109
- IF PSGOEEF(F2)
- SET BACK="109^PSGOE8"
- A109 ;
- +1 IF $$PNDREN($GET(PSGORD))
- Begin DoDot:1
- +2 WRITE !!?5,"Dosage may not be edited at this point."
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +3 SET PSGOEEF(F2)=PSGOEE
- +4 DO EDITDOSE^PSJDOSE
- SET X=PSGDO
- GOTO DONE
- +5 WRITE !,"DOSAGE ORDERED: ",$SELECT(PSGDO]"":PSGDO_"// ",1:"")
- READ X:DTIME
- IF X="^"!'$TEST
- IF '$TEST
- WRITE $CHAR(7)
- SET PSGOEE=0
- GOTO DONE
- +6 IF X=""&(PSGDO]"")
- SET X=PSGDO
- +7 IF $$CHECK(PSJSYSP)&(X="")&(PSGDO']"")
- WRITE $CHAR(7)," (Required) "
- GOTO A109
- +8 IF $$CHECK(PSJSYSP)&(X="@")
- WRITE $CHAR(7)," (Required) "
- GOTO A109
- +9 IF '$$CHECK(PSJSYSP)&(X="@")
- SET PSGDO=""
- GOTO DONE
- +10 IF X?1."?"
- DO ENHLP^PSGOEM(53.1,109)
- GOTO A109
- +11 IF $EXTRACT(X)="^"
- DO ENFF^PSGOE82
- IF Y>0
- GOTO @Y
- GOTO A109
- +12 IF $EXTRACT(X,$LENGTH(X))=" "
- FOR
- SET X=$EXTRACT(X,1,$LENGTH(X)-1)
- IF $EXTRACT(X,$LENGTH(X))'=" "
- QUIT
- +13 IF $SELECT(X?.E1C.E:1,$LENGTH(X)>20:1,X="":0,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 A109
- +14 SET PSGDO=X
- GOTO DONE
- +15 ;
- 3 ; med route
- +1 SET MSG=0
- SET F2=3
- IF PSGOEEF(F2)
- SET BACK="3^PSGOE8"
- A3 IF $$PNDREN($GET(PSGORD))
- Begin DoDot:1
- +1 WRITE !!?5,"Med Route may not be edited at this point."
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +2 WRITE !,"MED ROUTE: ",$SELECT(PSGMR:PSGMRN_"// ",1:"")
- READ X:DTIME
- IF X="^"!'$TEST
- IF '$TEST
- WRITE $CHAR(7)
- SET PSGOEE=0
- GOTO DONE
- +3 IF X=""
- IF PSGMR
- SET X=PSGMRN
- IF PSGMR'=PSGMRN
- IF $DATA(^PS(51.2,PSGMR,0))
- WRITE " "_$PIECE(^(0),"^",3)
- GOTO DONE
- +4 IF $SELECT(X="@":1,X]"":0,1:'PSGMR)
- WRITE $CHAR(7)," (Required)"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,3)
- GOTO A3
- +5 IF X?1."?"
- DO ENHLP^PSGOEM(53.1,3)
- +6 IF $EXTRACT(X)="^"
- DO ENFF^PSGOE82
- IF Y>0
- GOTO @Y
- GOTO A3
- +7 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 A3
- +8 SET PSGMR=+Y
- SET PSGMRN=Y(0,0)
- GOTO DONE
- +9 ;
- 7 ; schedule type
- +1 SET MSG=0
- SET F2=7
- IF PSGOEEF(F2)
- SET BACK="7^PSGOE8"
- A7 WRITE !,"SCHEDULE TYPE: "_$SELECT(PSGSTN]"":PSGSTN_"// ",1:"")
- READ X:DTIME
- SET X=$TRANSLATE(X,"coprocf","COPROCF")
- IF X="^"!'$TEST
- SET PSGOEE=0
- WRITE $CHAR(7)
- GOTO DONE
- +1 IF X=""
- IF PSGSTN]""
- WRITE " ",PSGSTN
- GOTO DONE
- +2 IF X="@"!(X?1."?")
- IF X="@"
- WRITE $CHAR(7)," (Required)"
- IF X="@"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,7)
- GOTO A7
- +3 IF $EXTRACT(X)="^"
- DO ENFF^PSGOE82
- IF Y>0
- GOTO @Y
- GOTO A7
- +4 ; 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 PSGOEEF(7)="" G:X="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
- A7DEF ;BHW;PSJ*5*188;Added tag. Called by A26 to set default Schedule type.
- +1 FOR Y="C^CONTINUOUS","O^ONE TIME","OC^ON CALL","P^PRN","R^FILL on REQUEST"
- 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 PSGST=$PIECE(Y,"^")
- SET PSGSTN=$PIECE(Y,"^",2)
- SET $PIECE(PSGNEDFD,"^",3)=PSGST
- QUIT
- +2 IF '$TEST
- WRITE $CHAR(7)," ??"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,7)
- GOTO A7
- +3 ; I PSGST="OC"!(PSGST="R") S PSGOEEF(7)="" G:PSGST="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
- +4 GOTO DONE
- +5 ;
- 26 ; schedule
- +1 SET MSG=0
- SET F2=26
- IF PSGOEEF(F2)
- SET BACK="26^PSGOE8"
- A26 IF $$PNDREN($GET(PSGORD))
- Begin DoDot:1
- +1 WRITE !!?5,"Schedule may not be edited at this point."
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +2 WRITE !,"SCHEDULE: ",$SELECT(PSGSCH]"":PSGSCH_"// ",1:"")
- READ X:DTIME
- IF X="^"!'$TEST
- IF '$TEST
- WRITE $CHAR(7)
- SET PSGOEE=0
- GOTO DONE
- +3 IF X=""
- SET X=PSGSCH
- SET PSGSCH=""
- IF "@"[X
- WRITE $CHAR(7)," (Required)"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,26)
- GOTO A26
- +4 IF X?1."?"
- DO ENHLP^PSGOEM(53.1,26)
- GOTO A26
- +5 IF $EXTRACT(X)="^"
- DO ENFF^PSGOE82
- IF Y>0
- GOTO @Y
- GOTO A26
- +6 ;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), Highlight Admin Times if they changed.
- +7 NEW PSGOES,PSJSLUP,PSGSFLG,PSGSCIEN
- SET PSJSLUP=1
- SET PSGSFLG=1
- DO EN^PSGS0
- IF '$DATA(X)
- WRITE $CHAR(7)," ??"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,26)
- GOTO A26
- +8 SET PSGSCH=X
- IF PSGS0Y'=PSGAT
- SET PSGAT=PSGS0Y
- WRITE !!,"NOTE: This change in schedule also changes the ADMIN TIMES.",!
- SET MSG=1
- SET PSGOEEF(39)=1
- IF $GET(PSJNEWOE)
- DO PAUSE^VALM1
- +9 ;BHW;PSJ*5*188;Get Schedule type of Selected Schedule, If One-Time type, set Highlighting ON (PSGOEEF(7)=1) and call existing Schedule type logic.
- +10 NEW X,Y,DIC
- +11 ;Get First schedule with PSJ Package Prefix as default for Lookup
- IF '$GET(PSGSCIEN)
- SET PSGSCIEN=$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,""))
- +12 SET X=$SELECT($GET(PSGSCIEN):$GET(PSGSCIEN),1:PSGSCH)
- SET DIC="51.1"
- SET DIC(0)="NZ"
- DO ^DIC
- +13 IF $PIECE($GET(Y(0)),"^",5)="O"
- SET X="O"
- SET PSGOEEF(7)=1
- GOTO A7DEF
- +14 ;
- DONE ;
- +1 IF PSGOEE
- IF 'PSGOEEF(F2)
- GOTO @BACK
- SET PSGOEE=PSGOEEF(F2)
- +2 KILL F,F0,F2
- 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
- +3 ;
- DH ;
- +1 WRITE !!?2,"When the drug of an order is changed, the Dosage Ordered and Dispense Drug(s)",!,"for the order are no longer valid, and therefore deleted from the order.",!,"If possible, a new corresponding dispense drug will be added to the order
- ."
- +2 WRITE !!?2,"Answer 'YES' to continue with this change. Answer 'NO' to select another",!,"drug or to accept the drug as it was. Enter an '^' the exit this edit."
- QUIT
- +3 ;
- CHECK(PSJSYSP) ; Check to see if multiple dispense drugs
- +1 ; Input - PSJSYSP
- +2 ; Returns 0 = only one.
- +3 ; 1 = more than one
- +4 ; Checks Inactive Date and doesn't count if < or = today.
- +5 NEW PSJRSB,PSJINACT,PSJRBCNT
- SET PSJRBCNT=0
- +6 FOR PSJRSB=0:0
- SET PSJRSB=$ORDER(^PS(53.45,PSJSYSP,2,PSJRSB))
- IF 'PSJRSB
- QUIT
- Begin DoDot:1
- +7 SET PSJINACT=$PIECE(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
- +8 IF (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT))
- Begin DoDot:2
- +9 SET PSJRBCNT=$SELECT('$DATA(PSJRBCNT):1,1:PSJRBCNT+1)
- End DoDot:2
- End DoDot:1
- +10 QUIT $SELECT(PSJRBCNT>1:1,1:0)
- +11 ;
- PNDREN(PNDON) ;
- +1 IF PNDON'["P"
- QUIT 0
- +2 SET RNWL="^PS(53.1,"_+PNDON_",0)"
- SET RNWL=$GET(@(RNWL))
- SET RNWL=$SELECT($PIECE(RNWL,"^",24)="R":1,1:0)
- +3 QUIT RNWL
