- PSGOE4 ;BIR/CML3 - REGULAR ORDER ENTRY ;Jun 18, 2020@14:04:03
- ;;5.0;INPATIENT MEDICATIONS ;**2,50,64,58,111,113,245,253,366,393,399**;16 DEC, 1997;Build 64
- ;
- ; Reference to ^PS(51.2 is supported by DBIA 2178.
- ; Reference to ^PS(51.1 is supported by DBIA 2177.
- ; Reference to ^PSSJORDF is supported by DBIA 2418.
- ;
- 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,PSGIND)="" ;*399
- S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"",'$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)=""
- ;
- 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)=""
- 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="?" D MRSL ;*366
- I X?1."??" D ENHLP^PSGOEM(53.1,3)
- I $E(X)="^" D FF G:Y>0 @Y G 3
- D CKMRSL ;*366
- K DIC S DIC="^PS(51.2,",DIC(0)="EMQZX",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3 ;366
- S PSGMR=+Y,PSGMRN=$P(Y(0),"^") S PSGFOK(3)=""
- Q:$G(PSGOE3)
- ;
- 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,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
- S DOW=0 I $$DOW^PSIVUTL(X) S DOW=1,PSGST="C",PSGSTN=$$ENSTN^PSGMI(PSGST),PSGS0Y=$P(X,"@",2)
- N PSJSLUP S PSJSLUP=1 D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
- I PSGSCH[" PRN",$$PRNOK^PSGS0(PSGSCH) S PSGST="P",PSGSTN=$$ENSTN^PSGMI(PSGST)
- 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($G(DOW):"C",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)
- K DOW
- ;
- 7 ; schedule type
- Q:$G(PSGOE3)
- D ;Default Schedule Type from Schedule file - PSJ*5*113 - DRF
- . N XX
- . I $$DOW^PSIVUTL(PSGSCH) S PSGST="C",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
- . I PSGSCH[" PRN",$$PRNOK^PSGS0(PSGSCH) S PSGST="P",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
- . I PSGSCH]"" D
- .. S XX=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0))
- .. S PSGST=$P($G(^PS(51.1,XX,0)),"^",5) I PSGST="D" S PSGST="C"
- .. S PSGSTN=$$ENSTN^PSGMI(PSGST)
- 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 ^PSGOE41
- 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
- S:X="F" X="R" S X=$S(X="PRN":"P",X="ON CALL":"OC",X="FILL on REQUEST":"R",1:X)
- I ",OC,P,R,"[(","_X_",") S PSGST=X,$P(PSGNEDFD,"^",3)=X,PSGSTN=$S(X="P":"PRN",X="R":"FILL ON REQUEST",1:"ON CALL") W " "_PSGSTN S PSGFOK(7)="" G:X="R" 8^PSGOE41 S (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="R" S PSGFOK(7)="" G 8^PSGOE41
- S PSGFOK(7)=""
- ;
- 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
- ;
- MRSL ;check for OI med route short list;
- N PSGS0Y,PSGS0XT ;393 - Preserve PSGS0Y value through PSSJDORF call.
- I $G(PSGPDRG) D START^PSSJORDF(PSGPDRG,"U") N MRCNT S MRCNT=$O(^TMP("PSJMR",$J,"A"),-1) I MRCNT D
- . N MRTP S MRTP="PSJTP" K ^TMP(MRTP,$J) S ^TMP(MRTP,$J,0)=U_U_MRCNT_U_MRCNT
- . N I S I=0 F S I=$O(^TMP("PSJMR",$J,I)) Q:'I D
- . . S ^TMP(MRTP,$J,I,0)=^TMP("PSJMR",$J,I),^TMP(MRTP,$J,"B",$P(^TMP("PSJMR",$J,I),U),I)="" W !,?10,I_" "_$P(^TMP("PSJMR",$J,I),U)_" "_$P(^TMP("PSJMR",$J,I),U,2)
- . N DIC S DIC("A")="Select MED ROUTE: ",DIC="^TMP(MRTP,$J,",DIC(0)="AEQZ" D ^DIC K ^TMP(MRTP,$J),^TMP("PSJMR",$J) Q:Y=-1
- . I X=" " S X="^" Q
- . S X=$P(Y,"^",2)
- Q
- ;
- CKMRSL ;;check for med route short list leading letters ;*525
- N PSGS0Y,PSGS0XT ;393 - Preserve PSGS0Y value through PSSJDORF call.
- I $G(PSGPDRG) D START^PSSJORDF(PSGPDRG,"U") N MRCNT S MRCNT=$O(^TMP("PSJMR",$J,"A"),-1) I MRCNT D
- . N MRTP S MRTP="PSJTP" K ^TMP(MRTP,$J) S ^TMP(MRTP,$J,0)=U_U_MRCNT_U_MRCNT
- . N I S I=0 F S I=$O(^TMP("PSJMR",$J,I)) Q:'I D
- . . S ^TMP(MRTP,$J,I,0)=^TMP("PSJMR",$J,I),^TMP(MRTP,$J,"B",$P(^TMP("PSJMR",$J,I),U),I)=""
- . N DIC S DIC("T")="",DIC="^TMP(MRTP,$J,",DIC(0)="EM" D ^DIC K ^TMP(MRTP,$J),^TMP("PSJMR",$J)
- . I Y=-1 Q
- . S X=$P(Y,"^",2)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE4 7105 printed Mar 13, 2025@21:06:45 Page 2
- PSGOE4 ;BIR/CML3 - REGULAR ORDER ENTRY ;Jun 18, 2020@14:04:03
- +1 ;;5.0;INPATIENT MEDICATIONS ;**2,50,64,58,111,113,245,253,366,393,399**;16 DEC, 1997;Build 64
- +2 ;
- +3 ; Reference to ^PS(51.2 is supported by DBIA 2178.
- +4 ; Reference to ^PS(51.1 is supported by DBIA 2177.
- +5 ; Reference to ^PSSJORDF is supported by DBIA 2418.
- +6 ;
- +7 ;*399
- 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,PSGIND)=""
- +8 if PSGMR
- SET PSGMRN=$SELECT('$PIECE(PSGNEDFD,"^",2):"",'$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
- +9 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)=""
- +10 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)=""
- +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)=""
- +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 ;*366
- IF X="?"
- DO MRSL
- +5 IF X?1."??"
- DO ENHLP^PSGOEM(53.1,3)
- +6 IF $EXTRACT(X)="^"
- DO FF
- if Y>0
- GOTO @Y
- GOTO 3
- +7 ;*366
- DO CKMRSL
- +8 ;366
- KILL DIC
- SET DIC="^PS(51.2,"
- SET DIC(0)="EMQZX"
- SET DIC("S")="I $P(^(0),""^"",4)"
- DO ^DIC
- KILL DIC
- IF Y'>0
- GOTO 3
- +9 SET PSGMR=+Y
- SET PSGMRN=$PIECE(Y(0),"^")
- SET PSGFOK(3)=""
- +10 if $GET(PSGOE3)
- QUIT
- +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 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
- +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 SET DOW=0
- IF $$DOW^PSIVUTL(X)
- SET DOW=1
- SET PSGST="C"
- SET PSGSTN=$$ENSTN^PSGMI(PSGST)
- SET PSGS0Y=$PIECE(X,"@",2)
- +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 IF PSGSCH[" PRN"
- IF $$PRNOK^PSGS0(PSGSCH)
- SET PSGST="P"
- SET PSGSTN=$$ENSTN^PSGMI(PSGST)
- +8 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)
- +9 IF $GET(PSGOE3)
- Begin DoDot:1
- +10 SET PSGSCH=X
- SET PSGST=$SELECT($GET(DOW):"C",PSGS0XT="O":"O",PSGST="R":"R",X["PRN":"P",X="ON CALL":"OC",PSGST]"":PSGST,1:"C")
- SET PSGFOK(26)=""
- +11 SET $PIECE(PSGNEDFD,"^",3)=PSGST
- if PSGSCH=""!(X?1." ")
- SET PSGSCH="PRN"
- +12 SET PSGSTN=$$ENSTN^PSGMI(PSGST)
- End DoDot:1
- QUIT
- +13 KILL DOW
- +14 ;
- 7 ; schedule type
- +1 if $GET(PSGOE3)
- QUIT
- +2 ;Default Schedule Type from Schedule file - PSJ*5*113 - DRF
- Begin DoDot:1
- +3 NEW XX
- +4 IF $$DOW^PSIVUTL(PSGSCH)
- SET PSGST="C"
- SET PSGSTN=$$ENSTN^PSGMI(PSGST)
- QUIT
- +5 IF PSGSCH[" PRN"
- IF $$PRNOK^PSGS0(PSGSCH)
- SET PSGST="P"
- SET PSGSTN=$$ENSTN^PSGMI(PSGST)
- QUIT
- +6 IF PSGSCH]""
- Begin DoDot:2
- +7 SET XX=+$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,0))
- +8 SET PSGST=$PIECE($GET(^PS(51.1,XX,0)),"^",5)
- IF PSGST="D"
- SET PSGST="C"
- +9 SET PSGSTN=$$ENSTN^PSGMI(PSGST)
- End DoDot:2
- End DoDot:1
- +10 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
- +11 IF X=""
- if PSGST="OC"
- SET PSGSCH=PSGSTN
- SET (PSGS0Y,PSGS0XT)=""
- WRITE " "_PSGSTN
- SET PSGFOK(7)=""
- SET $PIECE(PSGNEDFD,"^",3)=PSGST
- GOTO ^PSGOE41
- +12 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
- +13 IF $EXTRACT(X)="^"
- DO FF
- if Y>0
- GOTO @Y
- GOTO 7
- +14 if X="F"
- SET X="R"
- SET X=$SELECT(X="PRN":"P",X="ON CALL":"OC",X="FILL on REQUEST":"R",1:X)
- +15 IF ",OC,P,R,"[(","_X_",")
- SET PSGST=X
- SET $PIECE(PSGNEDFD,"^",3)=X
- SET PSGSTN=$SELECT(X="P":"PRN",X="R":"FILL ON REQUEST",1:"ON CALL")
- WRITE " "_PSGSTN
- SET PSGFOK(7)=""
- if X="R"
- GOTO 8^PSGOE41
- SET (PSGS0Y,PSGS0XT)=""
- GOTO 8^PSGOE41
- +16 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
- +17 IF '$TEST
- WRITE $CHAR(7)," ??"
- SET X="?"
- DO ENHLP^PSGOEM(53.1,7)
- GOTO 7
- +18 IF PSGST="R"
- SET PSGFOK(7)=""
- GOTO 8^PSGOE41
- +19 SET PSGFOK(7)=""
- +20 ;
- +21 GOTO ^PSGOE41
- +22 ;
- 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
- +3 ;
- MRSL ;check for OI med route short list;
- +1 ;393 - Preserve PSGS0Y value through PSSJDORF call.
- NEW PSGS0Y,PSGS0XT
- +2 IF $GET(PSGPDRG)
- DO START^PSSJORDF(PSGPDRG,"U")
- NEW MRCNT
- SET MRCNT=$ORDER(^TMP("PSJMR",$JOB,"A"),-1)
- IF MRCNT
- Begin DoDot:1
- +3 NEW MRTP
- SET MRTP="PSJTP"
- KILL ^TMP(MRTP,$JOB)
- SET ^TMP(MRTP,$JOB,0)=U_U_MRCNT_U_MRCNT
- +4 NEW I
- SET I=0
- FOR
- SET I=$ORDER(^TMP("PSJMR",$JOB,I))
- if 'I
- QUIT
- Begin DoDot:2
- +5 SET ^TMP(MRTP,$JOB,I,0)=^TMP("PSJMR",$JOB,I)
- SET ^TMP(MRTP,$JOB,"B",$PIECE(^TMP("PSJMR",$JOB,I),U),I)=""
- WRITE !,?10,I_" "_$PIECE(^TMP("PSJMR",$JOB,I),U)_" "_$PIECE(^TMP("PSJMR",$JOB,I),U,2)
- End DoDot:2
- +6 NEW DIC
- SET DIC("A")="Select MED ROUTE: "
- SET DIC="^TMP(MRTP,$J,"
- SET DIC(0)="AEQZ"
- DO ^DIC
- KILL ^TMP(MRTP,$JOB),^TMP("PSJMR",$JOB)
- if Y=-1
- QUIT
- +7 IF X=" "
- SET X="^"
- QUIT
- +8 SET X=$PIECE(Y,"^",2)
- End DoDot:1
- +9 QUIT
- +10 ;
- CKMRSL ;;check for med route short list leading letters ;*525
- +1 ;393 - Preserve PSGS0Y value through PSSJDORF call.
- NEW PSGS0Y,PSGS0XT
- +2 IF $GET(PSGPDRG)
- DO START^PSSJORDF(PSGPDRG,"U")
- NEW MRCNT
- SET MRCNT=$ORDER(^TMP("PSJMR",$JOB,"A"),-1)
- IF MRCNT
- Begin DoDot:1
- +3 NEW MRTP
- SET MRTP="PSJTP"
- KILL ^TMP(MRTP,$JOB)
- SET ^TMP(MRTP,$JOB,0)=U_U_MRCNT_U_MRCNT
- +4 NEW I
- SET I=0
- FOR
- SET I=$ORDER(^TMP("PSJMR",$JOB,I))
- if 'I
- QUIT
- Begin DoDot:2
- +5 SET ^TMP(MRTP,$JOB,I,0)=^TMP("PSJMR",$JOB,I)
- SET ^TMP(MRTP,$JOB,"B",$PIECE(^TMP("PSJMR",$JOB,I),U),I)=""
- End DoDot:2
- +6 NEW DIC
- SET DIC("T")=""
- SET DIC="^TMP(MRTP,$J,"
- SET DIC(0)="EM"
- DO ^DIC
- KILL ^TMP(MRTP,$JOB),^TMP("PSJMR",$JOB)
- +7 IF Y=-1
- QUIT
- +8 SET X=$PIECE(Y,"^",2)
- End DoDot:1
- +9 QUIT
- +10 ;
