- PSOORED4 ;BIR/SAB - Edit front door dosing ;07/13/00
- ;;7.0;OUTPATIENT PHARMACY;**46,91,78,99,111,117,133,159,148,251,391,372,416,313,437,282,402,515,507,574**;DEC 1997;Build 53
- ;External reference ^PS(51 supported by DBIA 2224
- ;External reference to PS(51.2 supported by DBIA 2226
- ;External reference to PS(51.1 supported by DBIA 2225
- ;called from psoornew
- ;
- DOSE(PSORXED) ;
- I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q
- K ROU,STRE,UNITN,PSODOSE M PSODOSE=PSORXED
- D KV K FIELD,DOSEOR,DUPD,X,Y,UNITS S ENT=1,OLENT=$G(PSORXED("ENT"))
- ASK I $G(ORD) W !!,"Possible SIG: " D
- .;Coded only for outside orders with no Patient Instructions
- .I $O(SIG(""))="",$G(ORD),$P($G(^PS(52.41,ORD,"EXT")),"^")'="" D SIGS^PSOHCPRS
- .S INST=0 F S INST=$O(SIG(INST)) Q:'INST S MIG=SIG(INST) D
- ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" "
- K SG,INST,MIG
- S ROU="PSOORED4",II=ENT D ASK^PSOBKDED K ROU,II I $G(JUMP) K JUMP G JUMP
- G:$D(DIRUT) EXQ
- ;
- I $G(VERB)]"" S PSORXED("VERB",ENT)=VERB G DUPD
- VER D VER^PSOOREDX I X[U,$L(X)>1 S FIELD="VER" G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- I X="@" K PSORXED("VERB",ENT),VERB G DUPD
- S:X'="" (PSORXED("VERB",ENT),VERB)=X
- DUPD ;
- I $G(PSORXED("DOSE",ENT))'?.N&($G(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD") K PSORXED("DOSE ORDERED",ENT),DUPD G NOU1
- D DUPD^PSOOREDX
- S DIR("B")=$S($G(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),1:1) S:$E($G(DIR("B")),1)="." DIR("B")="0"_$G(DIR("B")) K:DIR("B")="" DIR("B")
- D ^DIR I X[U,$L(X)>1 S FIELD="DUPD" G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- I X="@"!(X=0) W !,"Dispense Units Per Dose is Required!!",! G DUPD
- D STR^PSOOREDX
- NOU1 G:'$G(PSORXED("DOSE ORDERED",ENT)) RTE
- D CNON^PSOORED3
- N PSONDEF
- I $G(NOUN)]"" S PSORXED("NOUN",ENT)=NOUN
- NOU D NOU^PSOOREDX I X[U,$L(X)>1 S FIELD="NOU" G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- I X="@" K PSORXED("NOUN",ENT),NOUN G RTE
- I X'="",$G(PSONDEF)="" S NOUN=X
- I X'="",$G(PSONDEF)'=X S NOUN=X
- S:X'="" PSORXED("NOUN",ENT)=X
- ;
- RTE K JUMP S ROU="PSOORED4" D RTE^PSOBKDED K ROU
- I $G(JUMP) K JUMP G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- ;
- SCH D SCH^PSOBKDED I X[U,$L(X)>1 S FIELD="SCH" G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- S SCH=$$SCHASL^PSOORED5(Y) D SCH^PSOSIG I $G(SCH)']""!($D(DTOUT))!($D(DUOUT)) G SCH
- S PSORXED("SCHEDULE",ENT)=SCH IF $G(SCHEX)'="" W " ("_SCHEX_")"
- K SCH,SCHEX,X,Y,PSOSCH
- S:$G(PSORXED("ENT"))<ENT PSORXED("ENT")=ENT
- ;
- DUR D KV K EXP
- ; PSO*7.0*574 - skip limited duration field for clozapine order
- I $P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),U)="PSOCLO1" G CON
- S DIR(0)="52.0113,4",DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
- S DIR("B")=$S($G(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"") K:DIR("B")="" DIR("B")
- D ^DIR I X[U,$L(X)>1 S FIELD="DUR" G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- D DUR1^PSOOREDX
- ;
- CON D CON^PSOOREDX I X[U,$L(X)>1 S FIELD="CON" G JUMP
- G:$D(DTOUT)!($D(DUOUT)) EXQ
- I X="@",$G(PSORXED("CONJUNCTION",ENT))="" W !,?10,"Invalid Entry - nothing to delete!!" G CON
- S:X'=""&(X'="@") PSORXED("CONJUNCTION",ENT)=Y
- I X="@",$D(PSORXED("CONJUNCTION",ENT)) D CON1^PSOOREDX G:$D(DIRUT) EXQ G:'Y CON N CKX S CKX=1 D UPD^PSOOREDX G CON
- ;
- N PSODLBD4 S PSOSAVX=X,PSODLBD4=1
- ;*437
- I '$$DUROK^PSOORED3(.PSORXED,ENT) D G DUR
- . W !!,"Duration is required for the dosage entered prior to the THEN conjunction.",$C(7),!
- I $G(PSORXED("CONJUNCTION",ENT))]"" S PSOCKCON=1 D DCHK1^PSODOSUT G:$G(PSONEW("DFLG")) EX S ENT=ENT+1 K DIR G ASK
- E K PSOCKCON D DCHK1^PSODOSUT I $D(DTOUT)!($D(DUOUT)) S PSORX("DFLG")=1,PSONEW("DFLG")=1 G EX ;don't need to print the full summary, just the last sequence.
- I PSOSAVX="",$G(PSORXED) K PSOCKCON,PSOEDDOS
- K PSOSAVX
- ;
- S X=$G(PSORXED("INS")) D SIG^PSOHELP S:$G(INS1)]"" PSORXED("SIG")=$E(INS1,2,9999999)
- D EN^PSOFSIG(.PSORXED),VERI I $G(CKX),'$G(PSOSIGFL) D MP1 K CKX
- I $G(PSOSIGFL)=1 D I '$G(PSOSIGFL) Q
- .I $D(OR0),$P(OR0,"^",24)=1 S VALMSG="Digitally Signed Order - No such changes allowed." K PSORXED,PSOSIGFL M PSORXED=PSODOSE D EN^PSOFSIG(.PSORXED) D Q
- ..I $D(PSOBDR) K PSODRUG M PSODRUG=PSOBDR K PSOBDR,PSOBDRG
- .S PSORXED("ENT")=ENT,SIGOK=1,VALMSG="This change will create a new prescription!",NCPDPFLG=1
- K QTYHLD S:$G(PSORXED("QTY")) QTYHLD=PSORXED("QTY") D QTY^PSOSIG(.PSORXED) I $G(PSORXED("QTY")) S QTY=1
- I $G(QTYHLD),'$G(PSORXED("QTY")) S PSORXED("QTY")=QTYHLD
- K QTYHLD
- I '$G(PSORXED("QTY")),$P(OR0,"^",10) S PSORXED("QTY")=$P(OR0,"^",10)
- EX ;
- K PSOBDR,PSOBDRG,PSOSCH,DUPD,STRE,UNITN,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSODOSE,OLENT,FIELD,FLDNM,AR,NM,ENT,STRE,UNITN,PSODOSE,ERTE,ROU
- KV K DTOUT,DUOUT,DIR,DIRUT
- Q
- EXQ ;
- K PSORXED,PSOSIGFL M PSORXED=PSODOSE D EN^PSOFSIG(.PSORXED) D MP1
- I $D(PSOBDR) M PSODRUG=PSOBDR K PSOBDR,PSOBDRG
- G EX Q
- MP1 D MP1^PSOOREDX
- Q
- VERI ;checks for changes to dosing instructions
- S ENTS=0
- F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S ENTS=$G(ENTS)+1
- I ENTS<OLENT!(ENTS>OLENT) S PSOSIGFL=1 Q
- F I=1:1:OLENT D
- .I +PSODOSE("DOSE",I)'=$G(PSORXED("DOSE",I)) S PSOSIGFL=1
- .I $G(PSODOSE("DURATION",I))]"" D
- ..S DURATION=$S($E(PSODOSE("DURATION",I),1)'?.N:$E(PSODOSE("DURATION",I),2,99)_$E(PSODOSE("DURATION",I),1),1:PSODOSE("DURATION",I))
- ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1
- .I $G(PSODOSE("CONJUNCTION",I))'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1
- .I PSODOSE("ROUTE",I)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1
- .I PSODOSE("SCHEDULE",I)'=$G(PSORXED("SCHEDULE",I)) S PSOSIGFL=1
- K DURATION Q
- JUMP ;jump to fields
- I $L($E(X,2,99))<3 W !,"Field Name Must Be At Least 3 Characters in Length",! G @FIELD
- D FNM^PSOOREDX
- I FLDNM']"" K X,NM,FLDNM W !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",! G @FIELD
- F AR=1:1:PSORXED("ENT") W !,AR_". "_$P(FLDNM,"^",2)_": "_$S(NM="ROU"&($G(PSORXED($P(FLDNM,"^"),AR))):$P(^PS(51.2,PSORXED($P(FLDNM,"^"),AR),0),"^"),1:$G(PSORXED($P(FLDNM,"^"),AR))) S AR1=AR
- D KV S DIR("A",1)="* Indicates which fields will create a New Order",DIR("A")="Select Field to Edit by number",DIR(0)="NO^1:"_AR1 D ^DIR G:$D(DIRUT) @FIELD
- D JFN^PSOOREDX G:FLDNM="" @FIELD G @FLDNM
- G EX
- Q
- HLP ;help text for med route
- D FULL^VALM1 W !,"Please enter how patient will use the medication!"
- S DIC=51.2,X="??",DIC(0)="M",DIC("S")="I $P(^PS(51.2,+Y,0),""^"",4)" D ^DIC K DIC,X,Y
- Q
- SCHLP ;
- D FULL^VALM1 W !,"You can choose an entry from the Administration Schedule File (#51.1),",!,"Medication Instruction File (#51) or enter free text."
- W !,"The free text entry cannot contain more than 2 spaces or be greater than 20",!,"characters in length."
- W ! S DIR(0)="S^A:Administration Schedule File;M:Medication Instruction File;B:Both;F:Free Text",DIR("B")="Both"
- S DIR("A")="Do you want to list from" D ^DIR I Y="F"!($G(DIRUT)) K X,Y G X
- S LBL=Y G @LBL
- A ;display 51.1 entries only
- B K X,Y,DIC S X="??",DIC="^PS(51.1,",DIC(0)="QESMVZ",DIC("W")="D DICW^PSOORED4",D="APPSJ^D" W ! D MIX^DIC1
- K DIC,X I LBL="A"!($G(DTOUT)) K LBL G X
- I Y=-1!($G(DUOUT)) K DIR,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to continue with the Medication Instruction File"
- D ^DIR I 'Y!($G(DTOUT)) K DIR,X,Y G X
- M K X,Y,DIC S DIC=51,X="??",DIC(0)="M" D ^DIC K DIC,X,Y,DTOUT,DUOUT,LBL
- ;*282 Allow multi-word schedules
- X S DIR("?")="^D SCHLP^PSOORED4",DIR("A")="Schedule: ",DIR(0)="FA^1:20^I X[""""""""!(X?.E1C.E)!($A(X)=45)!($L(X,"" "")>$S(X[""PRN"":4,1:3))!($L(X)>20)!($L(X)<1) K X"
- S DIR("B")=$S($D(PSOSCH)&('$D(PSORXED("SCHEDULE",ENT))):PSOSCH,$G(PSORXED("SCHEDULE",ENT))]"":PSORXED("SCHEDULE",ENT),1:"") K:DIR("B")="" DIR("B")
- Q
- DICW ;
- S Z=$P(^PS(51.1,+Y,0),"^",5),Z=$S(Z="O":-1,Z="S":1,Z="R":-2,1:0) W:Z " ",$S(Z>0:"SHIFT",Z=-2:"RANGE",1:"ONE-TIME")
- I Z'<0,$D(PSJW),$D(^(PSJPP'="PSJ"+1,PSJW,0)),$P(^(0),"^",Z+2)]"" W " ",$P(^(0),"^",Z+2)
- ;Naked reference on DICW+2 is from DICW+1, ^PS(51.1,+Y,0)
- W:+Y $S($P(^(0),U,12):" **INACTIVE**",1:"") ;*507
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORED4 8024 printed Jan 18, 2025@03:33:01 Page 2
- PSOORED4 ;BIR/SAB - Edit front door dosing ;07/13/00
- +1 ;;7.0;OUTPATIENT PHARMACY;**46,91,78,99,111,117,133,159,148,251,391,372,416,313,437,282,402,515,507,574**;DEC 1997;Build 53
- +2 ;External reference ^PS(51 supported by DBIA 2224
- +3 ;External reference to PS(51.2 supported by DBIA 2226
- +4 ;External reference to PS(51.1 supported by DBIA 2225
- +5 ;called from psoornew
- +6 ;
- DOSE(PSORXED) ;
- +1 IF '$GET(PSODRUG("IEN"))
- WRITE !,"DRUG NAME REQUIRED!"
- DO 2^PSOORNW1
- IF '$GET(PSODRUG("IEN"))
- SET VALMSG="No Dispense Drug Selected"
- QUIT
- +2 KILL ROU,STRE,UNITN,PSODOSE
- MERGE PSODOSE=PSORXED
- +3 DO KV
- KILL FIELD,DOSEOR,DUPD,X,Y,UNITS
- SET ENT=1
- SET OLENT=$GET(PSORXED("ENT"))
- ASK IF $GET(ORD)
- WRITE !!,"Possible SIG: "
- Begin DoDot:1
- +1 ;Coded only for outside orders with no Patient Instructions
- +2 IF $ORDER(SIG(""))=""
- IF $GET(ORD)
- IF $PIECE($GET(^PS(52.41,ORD,"EXT")),"^")'=""
- DO SIGS^PSOHCPRS
- +3 SET INST=0
- FOR
- SET INST=$ORDER(SIG(INST))
- if 'INST
- QUIT
- SET MIG=SIG(INST)
- Begin DoDot:2
- +4 FOR SG=1:1:$LENGTH(MIG," ")
- if $X+$LENGTH($PIECE(MIG," ",SG)_" ")>IOM
- WRITE !?14
- WRITE $PIECE(MIG," ",SG)_" "
- End DoDot:2
- End DoDot:1
- +5 KILL SG,INST,MIG
- +6 SET ROU="PSOORED4"
- SET II=ENT
- DO ASK^PSOBKDED
- KILL ROU,II
- IF $GET(JUMP)
- KILL JUMP
- GOTO JUMP
- +7 if $DATA(DIRUT)
- GOTO EXQ
- +8 ;
- +9 IF $GET(VERB)]""
- SET PSORXED("VERB",ENT)=VERB
- GOTO DUPD
- VER DO VER^PSOOREDX
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="VER"
- GOTO JUMP
- +1 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +2 IF X="@"
- KILL PSORXED("VERB",ENT),VERB
- GOTO DUPD
- +3 if X'=""
- SET (PSORXED("VERB",ENT),VERB)=X
- DUPD ;
- +1 IF $GET(PSORXED("DOSE",ENT))'?.N&($GET(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD")
- KILL PSORXED("DOSE ORDERED",ENT),DUPD
- GOTO NOU1
- +2 DO DUPD^PSOOREDX
- +3 SET DIR("B")=$SELECT($GET(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),1:1)
- if $EXTRACT($GET(DIR("B")),1)="."
- SET DIR("B")="0"_$GET(DIR("B"))
- if DIR("B")=""
- KILL DIR("B")
- +4 DO ^DIR
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="DUPD"
- GOTO JUMP
- +5 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +6 IF X="@"!(X=0)
- WRITE !,"Dispense Units Per Dose is Required!!",!
- GOTO DUPD
- +7 DO STR^PSOOREDX
- NOU1 if '$GET(PSORXED("DOSE ORDERED",ENT))
- GOTO RTE
- +1 DO CNON^PSOORED3
- +2 NEW PSONDEF
- +3 IF $GET(NOUN)]""
- SET PSORXED("NOUN",ENT)=NOUN
- NOU DO NOU^PSOOREDX
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="NOU"
- GOTO JUMP
- +1 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +2 IF X="@"
- KILL PSORXED("NOUN",ENT),NOUN
- GOTO RTE
- +3 IF X'=""
- IF $GET(PSONDEF)=""
- SET NOUN=X
- +4 IF X'=""
- IF $GET(PSONDEF)'=X
- SET NOUN=X
- +5 if X'=""
- SET PSORXED("NOUN",ENT)=X
- +6 ;
- RTE KILL JUMP
- SET ROU="PSOORED4"
- DO RTE^PSOBKDED
- KILL ROU
- +1 IF $GET(JUMP)
- KILL JUMP
- GOTO JUMP
- +2 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +3 ;
- SCH DO SCH^PSOBKDED
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="SCH"
- GOTO JUMP
- +1 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +2 SET SCH=$$SCHASL^PSOORED5(Y)
- DO SCH^PSOSIG
- IF $GET(SCH)']""!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO SCH
- +3 SET PSORXED("SCHEDULE",ENT)=SCH
- IF $GET(SCHEX)'=""
- WRITE " ("_SCHEX_")"
- +4 KILL SCH,SCHEX,X,Y,PSOSCH
- +5 if $GET(PSORXED("ENT"))<ENT
- SET PSORXED("ENT")=ENT
- +6 ;
- DUR DO KV
- KILL EXP
- +1 ; PSO*7.0*574 - skip limited duration field for clozapine order
- +2 IF $PIECE($GET(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),U)="PSOCLO1"
- GOTO CON
- +3 SET DIR(0)="52.0113,4"
- SET DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
- +4 SET DIR("B")=$SELECT($GET(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"")
- if DIR("B")=""
- KILL DIR("B")
- +5 DO ^DIR
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="DUR"
- GOTO JUMP
- +6 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +7 DO DUR1^PSOOREDX
- +8 ;
- CON DO CON^PSOOREDX
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="CON"
- GOTO JUMP
- +1 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXQ
- +2 IF X="@"
- IF $GET(PSORXED("CONJUNCTION",ENT))=""
- WRITE !,?10,"Invalid Entry - nothing to delete!!"
- GOTO CON
- +3 if X'=""&(X'="@")
- SET PSORXED("CONJUNCTION",ENT)=Y
- +4 IF X="@"
- IF $DATA(PSORXED("CONJUNCTION",ENT))
- DO CON1^PSOOREDX
- if $DATA(DIRUT)
- GOTO EXQ
- if 'Y
- GOTO CON
- NEW CKX
- SET CKX=1
- DO UPD^PSOOREDX
- GOTO CON
- +5 ;
- +6 NEW PSODLBD4
- SET PSOSAVX=X
- SET PSODLBD4=1
- +7 ;*437
- +8 IF '$$DUROK^PSOORED3(.PSORXED,ENT)
- Begin DoDot:1
- +9 WRITE !!,"Duration is required for the dosage entered prior to the THEN conjunction.",$CHAR(7),!
- End DoDot:1
- GOTO DUR
- +10 IF $GET(PSORXED("CONJUNCTION",ENT))]""
- SET PSOCKCON=1
- DO DCHK1^PSODOSUT
- if $GET(PSONEW("DFLG"))
- GOTO EX
- SET ENT=ENT+1
- KILL DIR
- GOTO ASK
- +11 ;don't need to print the full summary, just the last sequence.
- IF '$TEST
- KILL PSOCKCON
- DO DCHK1^PSODOSUT
- IF $DATA(DTOUT)!($DATA(DUOUT))
- SET PSORX("DFLG")=1
- SET PSONEW("DFLG")=1
- GOTO EX
- +12 IF PSOSAVX=""
- IF $GET(PSORXED)
- KILL PSOCKCON,PSOEDDOS
- +13 KILL PSOSAVX
- +14 ;
- +15 SET X=$GET(PSORXED("INS"))
- DO SIG^PSOHELP
- if $GET(INS1)]""
- SET PSORXED("SIG")=$EXTRACT(INS1,2,9999999)
- +16 DO EN^PSOFSIG(.PSORXED)
- DO VERI
- IF $GET(CKX)
- IF '$GET(PSOSIGFL)
- DO MP1
- KILL CKX
- +17 IF $GET(PSOSIGFL)=1
- Begin DoDot:1
- +18 IF $DATA(OR0)
- IF $PIECE(OR0,"^",24)=1
- SET VALMSG="Digitally Signed Order - No such changes allowed."
- KILL PSORXED,PSOSIGFL
- MERGE PSORXED=PSODOSE
- DO EN^PSOFSIG(.PSORXED)
- Begin DoDot:2
- +19 IF $DATA(PSOBDR)
- KILL PSODRUG
- MERGE PSODRUG=PSOBDR
- KILL PSOBDR,PSOBDRG
- End DoDot:2
- QUIT
- +20 SET PSORXED("ENT")=ENT
- SET SIGOK=1
- SET VALMSG="This change will create a new prescription!"
- SET NCPDPFLG=1
- End DoDot:1
- IF '$GET(PSOSIGFL)
- QUIT
- +21 KILL QTYHLD
- if $GET(PSORXED("QTY"))
- SET QTYHLD=PSORXED("QTY")
- DO QTY^PSOSIG(.PSORXED)
- IF $GET(PSORXED("QTY"))
- SET QTY=1
- +22 IF $GET(QTYHLD)
- IF '$GET(PSORXED("QTY"))
- SET PSORXED("QTY")=QTYHLD
- +23 KILL QTYHLD
- +24 IF '$GET(PSORXED("QTY"))
- IF $PIECE(OR0,"^",10)
- SET PSORXED("QTY")=$PIECE(OR0,"^",10)
- EX ;
- +1 KILL PSOBDR,PSOBDRG,PSOSCH,DUPD,STRE,UNITN,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSODOSE,OLENT,FIELD,FLDNM,AR,NM,ENT,STRE,UNITN,PSODOSE,ERTE,ROU
- KV KILL DTOUT,DUOUT,DIR,DIRUT
- +1 QUIT
- EXQ ;
- +1 KILL PSORXED,PSOSIGFL
- MERGE PSORXED=PSODOSE
- DO EN^PSOFSIG(.PSORXED)
- DO MP1
- +2 IF $DATA(PSOBDR)
- MERGE PSODRUG=PSOBDR
- KILL PSOBDR,PSOBDRG
- +3 GOTO EX
- QUIT
- MP1 DO MP1^PSOOREDX
- +1 QUIT
- VERI ;checks for changes to dosing instructions
- +1 SET ENTS=0
- +2 FOR I=0:0
- SET I=$ORDER(PSORXED("DOSE",I))
- if 'I
- QUIT
- SET ENTS=$GET(ENTS)+1
- +3 IF ENTS<OLENT!(ENTS>OLENT)
- SET PSOSIGFL=1
- QUIT
- +4 FOR I=1:1:OLENT
- Begin DoDot:1
- +5 IF +PSODOSE("DOSE",I)'=$GET(PSORXED("DOSE",I))
- SET PSOSIGFL=1
- +6 IF $GET(PSODOSE("DURATION",I))]""
- Begin DoDot:2
- +7 SET DURATION=$SELECT($EXTRACT(PSODOSE("DURATION",I),1)'?.N:$EXTRACT(PSODOSE("DURATION",I),2,99)_$EXTRACT(PSODOSE("DURATION",I),1),1:PSODOSE("DURATION",I))
- +8 IF +DURATION'=+$GET(PSORXED("DURATION",I))
- SET PSOSIGFL=1
- End DoDot:2
- +9 IF $GET(PSODOSE("CONJUNCTION",I))'=$GET(PSORXED("CONJUNCTION",I))
- SET PSOSIGFL=1
- +10 IF PSODOSE("ROUTE",I)'=$GET(PSORXED("ROUTE",I))
- SET PSOSIGFL=1
- +11 IF PSODOSE("SCHEDULE",I)'=$GET(PSORXED("SCHEDULE",I))
- SET PSOSIGFL=1
- End DoDot:1
- +12 KILL DURATION
- QUIT
- JUMP ;jump to fields
- +1 IF $LENGTH($EXTRACT(X,2,99))<3
- WRITE !,"Field Name Must Be At Least 3 Characters in Length",!
- GOTO @FIELD
- +2 DO FNM^PSOOREDX
- +3 IF FLDNM']""
- KILL X,NM,FLDNM
- WRITE !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",!
- GOTO @FIELD
- +4 FOR AR=1:1:PSORXED("ENT")
- WRITE !,AR_". "_$PIECE(FLDNM,"^",2)_": "_$SELECT(NM="ROU"&($GET(PSORXED($PIECE(FLDNM,"^"),AR))):$PIECE(^PS(51.2,PSORXED($PIECE(FLDNM,"^"),AR),0),"^"),1:$GET(PSORXED($PIECE(FLDNM,"^"),AR)))
- SET AR1=AR
- +5 DO KV
- SET DIR("A",1)="* Indicates which fields will create a New Order"
- SET DIR("A")="Select Field to Edit by number"
- SET DIR(0)="NO^1:"_AR1
- DO ^DIR
- if $DATA(DIRUT)
- GOTO @FIELD
- +6 DO JFN^PSOOREDX
- if FLDNM=""
- GOTO @FIELD
- GOTO @FLDNM
- +7 GOTO EX
- +8 QUIT
- HLP ;help text for med route
- +1 DO FULL^VALM1
- WRITE !,"Please enter how patient will use the medication!"
- +2 SET DIC=51.2
- SET X="??"
- SET DIC(0)="M"
- SET DIC("S")="I $P(^PS(51.2,+Y,0),""^"",4)"
- DO ^DIC
- KILL DIC,X,Y
- +3 QUIT
- SCHLP ;
- +1 DO FULL^VALM1
- WRITE !,"You can choose an entry from the Administration Schedule File (#51.1),",!,"Medication Instruction File (#51) or enter free text."
- +2 WRITE !,"The free text entry cannot contain more than 2 spaces or be greater than 20",!,"characters in length."
- +3 WRITE !
- SET DIR(0)="S^A:Administration Schedule File;M:Medication Instruction File;B:Both;F:Free Text"
- SET DIR("B")="Both"
- +4 SET DIR("A")="Do you want to list from"
- DO ^DIR
- IF Y="F"!($GET(DIRUT))
- KILL X,Y
- GOTO X
- +5 SET LBL=Y
- GOTO @LBL
- A ;display 51.1 entries only
- B KILL X,Y,DIC
- SET X="??"
- SET DIC="^PS(51.1,"
- SET DIC(0)="QESMVZ"
- SET DIC("W")="D DICW^PSOORED4"
- SET D="APPSJ^D"
- WRITE !
- DO MIX^DIC1
- +1 KILL DIC,X
- IF LBL="A"!($GET(DTOUT))
- KILL LBL
- GOTO X
- +2 IF Y=-1!($GET(DUOUT))
- KILL DIR,DTOUT,DUOUT
- SET DIR(0)="Y"
- SET DIR("B")="No"
- SET DIR("A")="Do you want to continue with the Medication Instruction File"
- +3 DO ^DIR
- IF 'Y!($GET(DTOUT))
- KILL DIR,X,Y
- GOTO X
- M KILL X,Y,DIC
- SET DIC=51
- SET X="??"
- SET DIC(0)="M"
- DO ^DIC
- KILL DIC,X,Y,DTOUT,DUOUT,LBL
- +1 ;*282 Allow multi-word schedules
- X SET DIR("?")="^D SCHLP^PSOORED4"
- SET DIR("A")="Schedule: "
- SET DIR(0)="FA^1:20^I X[""""""""!(X?.E1C.E)!($A(X)=45)!($L(X,"" "")>$S(X[""PRN"":4,1:3))!($L(X)>20)!($L(X)<1) K X"
- +1 SET DIR("B")=$SELECT($DATA(PSOSCH)&('$DATA(PSORXED("SCHEDULE",ENT))):PSOSCH,$GET(PSORXED("SCHEDULE",ENT))]"":PSORXED("SCHEDULE",ENT),1:"")
- if DIR("B")=""
- KILL DIR("B")
- +2 QUIT
- DICW ;
- +1 SET Z=$PIECE(^PS(51.1,+Y,0),"^",5)
- SET Z=$SELECT(Z="O":-1,Z="S":1,Z="R":-2,1:0)
- if Z
- WRITE " ",$SELECT(Z>0:"SHIFT",Z=-2:"RANGE",1:"ONE-TIME")
- +2 IF Z'<0
- IF $DATA(PSJW)
- IF $DATA(^(PSJPP'="PSJ"+1,PSJW,0))
- IF $PIECE(^(0),"^",Z+2)]""
- WRITE " ",$PIECE(^(0),"^",Z+2)
- +3 ;Naked reference on DICW+2 is from DICW+1, ^PS(51.1,+Y,0)
- +4 ;*507
- if +Y
- WRITE $SELECT($PIECE(^(0),U,12):" **INACTIVE**",1:"")
- +5 QUIT