- PSOORED5 ;BIR/SAB-Rxs without dosing info ;1 Oct 2019 12:31:04
- ;;7.0;OUTPATIENT PHARMACY;**46,75,78,100,99,117,133,251,378,372,416,313,450,486,402,500,507,525,537,555,457,574,754**;DEC 1997;Build 1
- ;Reference to ^PS(51.2 supported by DBIA 2226
- ;Reference to ^PS(50.7 supported by DBIA 2223
- ;Reference to ^PSDRUG( supported by DBIA 221
- ;Reference to ^PS(55 supported by DBIA 2228
- ;External reference to START^PSSJORDF(PSODRUG supported by DBIA 2418
- ;called by psoored2 and psodir
- ;pre-poe rxs and new backdoor rxs
- ;
- ;*507 indicate inactive file #51.1 sched entries
- ;
- DOSE1(PSORXED) ;for new rxs
- DOSE ;pre-poe rx
- D KV K ROU,STRE,FIELD,DOSEOR,DUPD,X,Y,UNITS,ENTBKP S:$D(PSORXED("ENT")) ENTBKP=PSORXED("ENT") S ENT=1,OLENT=ENT ;p555 added ENTBKP
- ASK S ROU="PSOORED5" D ASK^PSOBKDED K ROU G:$D(DIRUT) EXE ;486
- I $G(JUMP) K JUMP G JUMP
- I $G(QUIT)]"" K QUIT,ROU Q
- ;
- I $G(VERB)]"" S PSORXED("VERB",ENT)=VERB G DUPD
- I $G(PSORX("EDIT"))']"" W:$G(PSORXED("VERB",ENT))]"" !,"VERB: "_PSORXED("VERB",ENT) G DUPD
- VER D VER^PSOOREDX
- I X[U,$L(X)>1 S FIELD="VER" G JUMP
- G EX:$D(DTOUT),EXE:$D(DUOUT) 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 KV S DIR(0)="52.0113,1",DIR("A")="DISPENSE UNITS PER DOSE"_$S($G(PSORXED("NOUN",ENT))]"":"("_PSORXED("NOUN",ENT)_")",1:"")
- I '$G(PSORXED("DOSE",ENT)),$G(PSORXED("DOSE",ENT-1)) S PSORXED("DOSE",ENT)=PSORXED("DOSE",ENT-1)
- S DIR("B")=$S($G(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),$G(DUPD)]"":DUPD,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 EX:$D(DTOUT),EXE:$D(DUOUT)
- I X="@"!(X=0) W !,"Dispense Units Per Dose is Required!!",! G DUPD
- D STR^PSOOREDX
- ;
- NOU1 G:'$D(DUPD) RTE D CNON^PSOORED3 N PSONDEF
- I $G(NOUN)]"",$G(PSORX("EDIT"))']"" S PSORXED("NOUN",ENT)=NOUN W !,"NOUN: "_$G(NOUN) G RTE
- I $G(PSORX("EDIT"))']"",$G(PSORXED("NOUN",ENT))]"" W !,"NOUN: "_PSORXED("NOUN",ENT) G RTE
- NOU D NOU^PSOOREDX I X[U,$L(X)>1 S FIELD="NOU" G JUMP
- G EXE:$D(DTOUT)!$D(DUOUT) 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 I $G(ENT)>1,$G(PSORX("EDIT"))']"",$G(PSORXED("ROUTE",ENT-1)),$G(PSORXED("ROUTE",ENT))']"" S PSORXED("ROUTE",ENT)=PSORXED("ROUTE",ENT-1) G SCH
- I '$G(DRET),'$G(PSORXED("ROUTE",ENT)),$P(^PS(50.7,PSODRUG("OI"),0),"^",6) S PSORXED("ROUTE",ENT)=$P(^PS(50.7,PSODRUG("OI"),0),"^",6)
- I $G(DRET) S PSORXED("ROUTE",ENT)=""
- I $G(RTE) K RTE
- ;*525
- D KV N MRSLS,MRX,MRDFV,MRQ S MRQ=0,MRDFV=$S($G(PSORXED("ROUTE",ENT)):$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),$G(RTE)]"":RTE,1:"")
- S X=""
- W !,"ROUTE: "_MRDFV_"//"
- D G:$G(MRSLS) DQ G:MRQ=1 RTE
- . R MRX:DTIME
- . I '$T S DTOUT=1 Q
- . I MRX="^" S DUOUT=1 Q
- . I MRX="?" D MRSL
- . I (MRX="")!(MRX=" ")&($G(MRDFV)]"") S MRX=$G(MRDFV)
- . I $E(MRX,1)=" " S MRQ=1
- S X=MRX
- K MRSLS,MRX,MRDFV,MRQ
- I X[U,$L(X)>1 S FIELD="RTE" G JUMP
- S:($D(DTOUT))!($D(DUOUT)) PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
- I X="^" S PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
- I X="@"!(X="") K RTE,ERTE S DRET=1,PSORXED("ROUTE",ENT)="" G SCH
- D CKMRSL
- K DRET I X=$P($G(^PS(51.2,+$G(PSORXED("ROUTE",ENT)),0)),"^") S RTE=$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),ERTE=$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^",2) W X_" "_$G(ERTE) G SCH
- ;D KV S DIR(0)="FO^2:45",DIR("A")="ROUTE",DIR("?")="^D HLP^PSOORED4"
- ;S DIR("B")=$S($G(PSORXED("ROUTE",ENT)):$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),$G(RTE)]"":RTE,$G(DRET):"",1:"PO") K:DIR("B")="" DIR("B")
- ;S DIR("B")=$S($G(PSORXED("ROUTE",ENT)):$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),$G(RTE)]"":RTE,1:"") K:DIR("B")="" DIR("B")
- ;D ^DIR I X[U,$L(X)>1 S FIELD="RTE" G JUMP
- ;S:($D(DTOUT))!($D(DUOUT)) PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
- ;I X="@"!(X="") K RTE,ERTE S DRET=1,PSORXED("ROUTE",ENT)="" G SCH
- ;K DRET I X=$P($G(^PS(51.2,+$G(PSORXED("ROUTE",ENT)),0)),"^") S RTE=$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),ERTE=$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^",2) W X_" "_$G(ERTE) G SCH
- ;S DIC=51.2,DIC(0)="QEZM",DIC("S")="I $P(^(0),""^"",4)" D ^DIC Q:X[U G:Y=-1 RTE W " "_$P(Y(0),"^",2)
- DQ ;
- S DIC=51.2,DIC(0)="QEZMX",DIC("S")="I $P(^(0),""^"",4)" D ^DIC Q:X[U G:Y=-1 RTE W " "_$P(Y(0),"^",2)
- RTF ;
- S:X'="" PSORXED("ROUTE",ENT)=+Y,RTE=Y(0,0),ERTE=$P(Y(0),"^",2)
- ;
- SCH D SCH^PSOBKDED I X[U,$L(X)>1 S FIELD="SCH" G JUMP
- G EX:$D(DTOUT),EXE:$D(DUOUT)
- S SCH=$$SCHASL(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($D(DUR):DUR,$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 EX:$D(DTOUT),EXE:$D(DUOUT)
- ;PSO*7*754 comment out code added with PSO*7*457
- ;; START NCC REMEDIATION >> 457*RJS - ADJUST FOR 4 DAY SUPPLY
- ;/RBN Begin modification for #326 ;/MZR Added a message and correct checking for Hours/Minutes
- ;I $G(DIR("B"))!$G(PSORXED("DURATION",ENT)) N Z,MAX D I Z>MAX S PSORXED("DURATION",$G(PSORXED("ENT")))=MAX G DUR
- ;.I X=+X S Z=X
- ;.E S Z=$E(X,$L(X)),Z=$S(Z="L":30*X,Z="W":7*X,Z="H":X/24,Z="M":X/1440,1:+X)
- ;.S MAX=$S($G(DIR("B")):+DIR("B"),1:$G(PSORXED("DURATION",ENT)))
- ;.I Z>MAX D
- ;..W " ("_$S(X["L":"MONTHS",X["W":"WEEKS",X["H":"HOURS",X["M":"MINUTES",1:"DAYS")_")"
- ;..W !,"NOT MORE THAN ",MAX," DAYS"
- ;; END NCC REMEDIATION << 457*RJS
- D DUR1^PSOOREDX
- ;
- CON D CON^PSOOREDX I X[U,$L(X)>1 S FIELD="CON" G JUMP
- G EX:$D(DTOUT),EXE:$D(DUOUT)
- 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 CON1^PSOOREDX G:$D(DIRUT) EX G:'Y CON S:'$G(COPY) PSOSIGFL=1 D UPD^PSOOREDX G CON
- ;
- I '$$DUROK^PSOORED3(.PSORXED,ENT) D G DUR
- . W !!,"Duration is required for the dosage entered prior to the THEN conjunction.",$C(7),!
- N PSODLBD4 S PSOSAVX=X,PSODLBD4=1
- I $G(PSORXED("CONJUNCTION",ENT))]"" S PSOCKCON=1 D DCHK1^PSODOSUT G:$G(PSORXED("DFLG"))!($G(PSORX("DFLG"))) EX S ENT=ENT+1 K DIR G ASK
- E K PSOCKCON I $$DCHK^PSODOSUT S PSORXED("DFLG")=1,PSORX("DFLG")=1 G EX
- I PSOSAVX="",$G(PSORXED)!($D(PSOEDDOS)) K PSOCKCON
- K PSOSAVX
- ;
- EXS ;Entry point for EXE to rebuild SIG PSO*7.0*450
- S X=$G(PSORXED("INS")) D SIG^PSOHELP S:$G(INS1)]"" PSORXED("SIG")=$E(INS1,2,9999999)
- D EN^PSOFSIG(.PSORXED) I $O(SIG(0)) S PSORXED("ENT")=ENT,SIGOK=1
- Q:$G(PSOREEDT)!($G(PSOORRNW))
- 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 Q:$G(PSOFROM)="NEW"!($G(COPY))!($G(PSOFROM))!($G(PSOREEDT))
- Q:$G(PSOSIGFL) D
- .S D=0 F S D=$O(SIG(D)) Q:'D S ^PSRX(PSORXED("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSORXED("IRXN"),"SIG1",0),"^",3)=+$P($G(^PSRX(PSORXED("IRXN"),"SIG1",0)),"^",3)+1,$P(^(0),"^",4)=+$P($G(^(0)),"^",4)+1 Q:'$O(SIG(D))
- .S (A,I)=0 F S I=$O(^PSRX(PSORXED("IRXN"),"A",I)) Q:'I S A=A+1
- .S:'$D(^PSRX(PSORXED("IRXN"),"A",0)) ^PSRX(PSORXED("IRXN"),"A",0)="^52.3DA^"
- .S $P(^PSRX(PSORXED("IRXN"),"A",0),"^",3)=$P($G(^PSRX(PSORXED("IRXN"),"A",0)),"^",3)+1,$P(^(0),"^",4)=$P($G(^(0)),"^",4)+1
- .D NOW^%DTC S A=A+1,^PSRX(PSORXED("IRXN"),"A",A,0)=%_"^E^"_DUZ_"^0^New Dosing Instructions Added",^PSRX(PSORXED("IRXN"),"A",A,1)="ORIGINAL SIG^" D
- ..I '$P(^PSRX(PSORXED("IRXN"),"SIG"),"^",2) S $P(^PSRX(PSORXED("IRXN"),"A",A,1),"^",2)=$P(^PSRX(PSORXED("IRXN"),"SIG"),"^") Q
- ..F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I S ^PSRX(PSORXED("IRXN"),"A",A,2,I,0)=^PSRX(PSORXED("IRXN"),"SIG1",I,0),^PSRX(PSORXED("IRXN"),"A",A,2,0)="^52.34A^"_I_"^"_I
- .S ^PSRX(PSORXED("IRXN"),"SIG")="^1" K SIG,A,I
- S ^PSRX(PSORXED("IRXN"),6,0)="^52.0113^"_ENT_"^"_ENT
- F I=1:1:ENT S ^PSRX(PSORXED("IRXN"),6,I,0)=PSORXED("DOSE",I)_"^"_$G(PSORXED("DOSE ORDERED",I))_"^"_$G(PSORXED("UNITS",I))_"^"_$G(PSORXED("NOUN",I))_"^" D
- .S ^PSRX(PSORXED("IRXN"),6,I,0)=^PSRX(PSORXED("IRXN"),6,I,0)_$G(PSORXED("DURATION",I))_"^"_$G(PSORXED("CONJUNCTION",I))_"^"_$G(PSORXED("ROUTE",I))_"^"_$G(PSORXED("SCHEDULE",I))_"^"_$G(PSORXED("VERB",I))
- .I $G(PSORXED("DOSE",I))]"" S ^PSRX(PSORXED("IRXN"),6,I,1)=PSORXED("DOSE",I)
- S ^PSRX(PSORXED("IRXN"),"POE")=1 G EX
- Q
- EX I $D(DUOUT)!($D(DTOUT)) S PSONEW("DFLG")=1 S:$D(ENTBKP) ENT=ENTBKP ;p555 added ENTBKP
- ;I $D(DUOUT)!($D(DTOUT)) S:'$G(PSORX("EDIT")) PSONEW("DFLG")=1
- G:$G(PSOSIGFL)!($G(PSORX("EDIT")))!($G(PSORXED))!($G(PSOREEDT)) EX1
- K PSORXED("DOSE"),PSORXED("NOUN"),PSORXED("VERB"),PSORXED("DOSE ORDERED"),PSORXED("ROUTE"),SIG,PSORXED("SCHEDULE"),PSORXED("DURATION"),PSORXED("CONJUNCTION"),PSORXED("ODOSE")
- EX1 K UNITN,STRE,DOSE,DUPD,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSOSCH,ENT,PSORTE,DURA,ERTE,ROU
- KV K DIR,DIRUT,DTOUT,DUOUT
- Q
- ;This line tag was added to check if EXit is being performed while EDITing. If it is,
- ;process SIG and do not delete order. Previous calls to EX when due to $D(DUOUT) were
- ;changed to go to this line tag instead.
- EXE I $G(PSORX("EDIT"))]"" K DUOUT S:$D(ENTBKP) ENT=ENTBKP G EXS ;*PSO*7.0*450 p555 added ENTBKP
- G EX
- ;
- UPD ;updates dosing array
- D UPD^PSOORED6
- Q
- JUMP ;
- I $G(PSORXED("SCHEDULE",1))']"" W $C(7),!!,"All Dosing Instructions must be entered before Jumping to other Fields!",!! G @FIELD
- 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
- I $G(PSOFROM)'="NEW",'$G(COPY) S DIR("A",1)="* Indicates which fields will create a New Order"
- S DIR("A")="Select Field by number",DIR(0)="NO^1:"_AR1 D ^DIR G:$D(DIRUT) @FIELD
- D JFN^PSOOREDX G:FLDNM="" @FIELD G @FLDNM
- G EX
- Q
- LAN ;
- Q:'$G(PSODRUG("IEN"))
- I $G(OR0),'$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D K QI,QII Q
- .Q:$G(OTHDOS(II))
- .F QI=0:0 S QI=$O(^PSDRUG(PSODRUG("IEN"),"DOS2",QI)) Q:'QI D Q:$G(QII)
- ..Q:$G(PSONEW("DOSE",II))']""
- ..I PSONEW("DOSE",II)=$P(^PSDRUG(PSODRUG("IEN"),"DOS2",QI,0),"^") S PSONEW("ODOSE",II)=$P(^PSDRUG(PSODRUG("IEN"),"DOS2",QI,0),"^",4),QII=1
- I $G(Y),$P($G(DOSE(Y)),"^",13)]"" S PSORXED("ODOSE",ENT)=$P(DOSE(Y),"^",13) Q
- K QII F I=0:0 S I=$O(^PSDRUG(PSODRUG("IEN"),"DOS2",I)) Q:'I I DOSE=$P(^PSDRUG(PSODRUG("IEN"),"DOS2",I,0),"^") D Q:$G(QII)
- .S PSORXED("ODOSE",ENT)=$P(^PSDRUG(PSODRUG("IEN"),"DOS2",I,0),"^",4),QII=1
- K QII,I
- Q
- ;
- SCHASL(SCHA) ;
- N SCHEA,SCHFL1 S SCHEA="",SCHFL1=0
- ;**Lookup into the ADMINISTRATION SCHEDULE (#51.1) file
- K X,Y,DIC,D SET X=$G(SCHA),DIC="^PS(51.1,",DIC(0)="CEMOV"
- S DIC("W")="W "" ""_$G(X)_"" ""_$P(^PS(51.1,+Y,0),U,8)_$S($P(^(0),U,12):"" **INACTIVE**"",1:"""")" ;*507
- S D="APPSJ^D" W !,"Now searching ADMINISTRATION SCHEDULE (#51.1) file...",! D MIX^DIC1 ;*507
- K DIC,D S:Y'>0 SCHFL1=1 IF '$G(SCHFL1),'$D(DTOUT),'$D(DUOUT) SET SCHEA=$P(Y,U,2) Q SCHEA
- I $D(DTOUT)!($D(DUOUT)) Q ""
- I $G(SCHFL1)=1 S SCHEA=$$SCHMI(SCHA) Q SCHEA
- Q ""
- ;
- SCHMI(SCHM) ;
- N SCHEM,SCHFL2 S SCHEM="",SCHFL2=0
- ;**Lookup into the MEDICATION INSRUCTION (#51) file
- K X,Y,DIC,D SET X=$G(SCHM),DIC="^PS(51,",DIC(0)="CEMOV",DIC("W")="W "" ""_$G(X)_"" ""_$P(^PS(51,+Y,0),U,2)",D="A^B^D" W !,"Now searching MEDICATION INSTRUCTION (#51) file...",! D MIX^DIC1
- K DIC,D S:Y'>0 SCHFL2=1 IF '$G(SCHFL2),'$D(DTOUT),'$D(DUOUT) SET SCHEM=$P(Y,U,2) Q SCHEM
- ;
- I $D(DTOUT)!($D(DUOUT)) Q ""
- I $G(SCHFL2)=1 Q SCHM
- Q ""
- ;
- MRSL ;;check for OI med route short list ;*525
- I $G(PSODRUG("OI")) D START^PSSJORDF(PSODRUG("OI"),"O") N MRCNT S MRCNT=$O(^TMP("PSJMR",$J,"A"),-1) I MRCNT D
- . N MRTP S MRTP="PSOTP" 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)
- . I Y=-1 S MRQ=1 Q
- . S MRSLS=1,X=$P(Y,"^",2)
- Q
- ;
- CKMRSL ;;check for med route short list leading letters ;*525
- I $G(PSODRUG("OI")) D START^PSSJORDF(PSODRUG("OI"),"O") N MRCNT S MRCNT=$O(^TMP("PSJMR",$J,"A"),-1) I MRCNT D
- . N MRTP S MRTP="PSOTP" 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[HPSOORED5 13331 printed Jan 18, 2025@03:33:02 Page 2
- PSOORED5 ;BIR/SAB-Rxs without dosing info ;1 Oct 2019 12:31:04
- +1 ;;7.0;OUTPATIENT PHARMACY;**46,75,78,100,99,117,133,251,378,372,416,313,450,486,402,500,507,525,537,555,457,574,754**;DEC 1997;Build 1
- +2 ;Reference to ^PS(51.2 supported by DBIA 2226
- +3 ;Reference to ^PS(50.7 supported by DBIA 2223
- +4 ;Reference to ^PSDRUG( supported by DBIA 221
- +5 ;Reference to ^PS(55 supported by DBIA 2228
- +6 ;External reference to START^PSSJORDF(PSODRUG supported by DBIA 2418
- +7 ;called by psoored2 and psodir
- +8 ;pre-poe rxs and new backdoor rxs
- +9 ;
- +10 ;*507 indicate inactive file #51.1 sched entries
- +11 ;
- DOSE1(PSORXED) ;for new rxs
- DOSE ;pre-poe rx
- +1 ;p555 added ENTBKP
- DO KV
- KILL ROU,STRE,FIELD,DOSEOR,DUPD,X,Y,UNITS,ENTBKP
- if $DATA(PSORXED("ENT"))
- SET ENTBKP=PSORXED("ENT")
- SET ENT=1
- SET OLENT=ENT
- ASK ;486
- SET ROU="PSOORED5"
- DO ASK^PSOBKDED
- KILL ROU
- if $DATA(DIRUT)
- GOTO EXE
- +1 IF $GET(JUMP)
- KILL JUMP
- GOTO JUMP
- +2 IF $GET(QUIT)]""
- KILL QUIT,ROU
- QUIT
- +3 ;
- +4 IF $GET(VERB)]""
- SET PSORXED("VERB",ENT)=VERB
- GOTO DUPD
- +5 IF $GET(PSORX("EDIT"))']""
- if $GET(PSORXED("VERB",ENT))]""
- WRITE !,"VERB: "_PSORXED("VERB",ENT)
- GOTO DUPD
- VER DO VER^PSOOREDX
- +1 IF X[U
- IF $LENGTH(X)>1
- SET FIELD="VER"
- GOTO JUMP
- +2 if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- 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 KV
- SET DIR(0)="52.0113,1"
- SET DIR("A")="DISPENSE UNITS PER DOSE"_$SELECT($GET(PSORXED("NOUN",ENT))]"":"("_PSORXED("NOUN",ENT)_")",1:"")
- +3 IF '$GET(PSORXED("DOSE",ENT))
- IF $GET(PSORXED("DOSE",ENT-1))
- SET PSORXED("DOSE",ENT)=PSORXED("DOSE",ENT-1)
- +4 SET DIR("B")=$SELECT($GET(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),$GET(DUPD)]"":DUPD,1:"")
- if $EXTRACT($GET(DIR("B")),1)="."
- SET DIR("B")="0"_$GET(DIR("B"))
- if DIR("B")=""
- KILL DIR("B")
- +5 DO ^DIR
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="DUPD"
- GOTO JUMP
- +6 if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- +7 IF X="@"!(X=0)
- WRITE !,"Dispense Units Per Dose is Required!!",!
- GOTO DUPD
- +8 DO STR^PSOOREDX
- +9 ;
- NOU1 if '$DATA(DUPD)
- GOTO RTE
- DO CNON^PSOORED3
- NEW PSONDEF
- +1 IF $GET(NOUN)]""
- IF $GET(PSORX("EDIT"))']""
- SET PSORXED("NOUN",ENT)=NOUN
- WRITE !,"NOUN: "_$GET(NOUN)
- GOTO RTE
- +2 IF $GET(PSORX("EDIT"))']""
- IF $GET(PSORXED("NOUN",ENT))]""
- WRITE !,"NOUN: "_PSORXED("NOUN",ENT)
- GOTO RTE
- NOU DO NOU^PSOOREDX
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="NOU"
- GOTO JUMP
- +1 if $DATA(DTOUT)!$DATA(DUOUT)
- GOTO EXE
- IF X="@"
- KILL PSORXED("NOUN",ENT),NOUN
- GOTO RTE
- +2 IF X'=""
- IF $GET(PSONDEF)=""
- SET NOUN=X
- +3 IF X'=""
- IF $GET(PSONDEF)'=X
- SET NOUN=X
- +4 if X'=""
- SET PSORXED("NOUN",ENT)=X
- +5 ;
- RTE IF $GET(ENT)>1
- IF $GET(PSORX("EDIT"))']""
- IF $GET(PSORXED("ROUTE",ENT-1))
- IF $GET(PSORXED("ROUTE",ENT))']""
- SET PSORXED("ROUTE",ENT)=PSORXED("ROUTE",ENT-1)
- GOTO SCH
- +1 IF '$GET(DRET)
- IF '$GET(PSORXED("ROUTE",ENT))
- IF $PIECE(^PS(50.7,PSODRUG("OI"),0),"^",6)
- SET PSORXED("ROUTE",ENT)=$PIECE(^PS(50.7,PSODRUG("OI"),0),"^",6)
- +2 IF $GET(DRET)
- SET PSORXED("ROUTE",ENT)=""
- +3 IF $GET(RTE)
- KILL RTE
- +4 ;*525
- +5 DO KV
- NEW MRSLS,MRX,MRDFV,MRQ
- SET MRQ=0
- SET MRDFV=$SELECT($GET(PSORXED("ROUTE",ENT)):$PIECE(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),$GET(RTE)]"":RTE,1:"")
- +6 SET X=""
- +7 WRITE !,"ROUTE: "_MRDFV_"//"
- +8 Begin DoDot:1
- +9 READ MRX:DTIME
- +10 IF '$TEST
- SET DTOUT=1
- QUIT
- +11 IF MRX="^"
- SET DUOUT=1
- QUIT
- +12 IF MRX="?"
- DO MRSL
- +13 IF (MRX="")!(MRX=" ")&($GET(MRDFV)]"")
- SET MRX=$GET(MRDFV)
- +14 IF $EXTRACT(MRX,1)=" "
- SET MRQ=1
- End DoDot:1
- if $GET(MRSLS)
- GOTO DQ
- if MRQ=1
- GOTO RTE
- +15 SET X=MRX
- +16 KILL MRSLS,MRX,MRDFV,MRQ
- +17 IF X[U
- IF $LENGTH(X)>1
- SET FIELD="RTE"
- GOTO JUMP
- +18 if ($DATA(DTOUT))!($DATA(DUOUT))
- SET PSODIR("DFLG")=1
- if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- +19 IF X="^"
- SET PSODIR("DFLG")=1
- if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- +20 IF X="@"!(X="")
- KILL RTE,ERTE
- SET DRET=1
- SET PSORXED("ROUTE",ENT)=""
- GOTO SCH
- +21 DO CKMRSL
- +22 KILL DRET
- IF X=$PIECE($GET(^PS(51.2,+$GET(PSORXED("ROUTE",ENT)),0)),"^")
- SET RTE=$PIECE(^PS(51.2,PSORXED("ROUTE",ENT),0),"^")
- SET ERTE=$PIECE(^PS(51.2,PSORXED("ROUTE",ENT),0),"^",2)
- WRITE X_" "_$GET(ERTE)
- GOTO SCH
- +23 ;D KV S DIR(0)="FO^2:45",DIR("A")="ROUTE",DIR("?")="^D HLP^PSOORED4"
- +24 ;S DIR("B")=$S($G(PSORXED("ROUTE",ENT)):$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),$G(RTE)]"":RTE,$G(DRET):"",1:"PO") K:DIR("B")="" DIR("B")
- +25 ;S DIR("B")=$S($G(PSORXED("ROUTE",ENT)):$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),$G(RTE)]"":RTE,1:"") K:DIR("B")="" DIR("B")
- +26 ;D ^DIR I X[U,$L(X)>1 S FIELD="RTE" G JUMP
- +27 ;S:($D(DTOUT))!($D(DUOUT)) PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
- +28 ;I X="@"!(X="") K RTE,ERTE S DRET=1,PSORXED("ROUTE",ENT)="" G SCH
- +29 ;K DRET I X=$P($G(^PS(51.2,+$G(PSORXED("ROUTE",ENT)),0)),"^") S RTE=$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^"),ERTE=$P(^PS(51.2,PSORXED("ROUTE",ENT),0),"^",2) W X_" "_$G(ERTE) G SCH
- +30 ;S DIC=51.2,DIC(0)="QEZM",DIC("S")="I $P(^(0),""^"",4)" D ^DIC Q:X[U G:Y=-1 RTE W " "_$P(Y(0),"^",2)
- DQ ;
- +1 SET DIC=51.2
- SET DIC(0)="QEZMX"
- SET DIC("S")="I $P(^(0),""^"",4)"
- DO ^DIC
- if X[U
- QUIT
- if Y=-1
- GOTO RTE
- WRITE " "_$PIECE(Y(0),"^",2)
- RTF ;
- +1 if X'=""
- SET PSORXED("ROUTE",ENT)=+Y
- SET RTE=Y(0,0)
- SET ERTE=$PIECE(Y(0),"^",2)
- +2 ;
- SCH DO SCH^PSOBKDED
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="SCH"
- GOTO JUMP
- +1 if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- +2 SET SCH=$$SCHASL(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 ;
- +1 DO KV
- KILL EXP
- +2 ; PSO*7.0*574 - skip limited duration field for clozapine order
- +3 IF $PIECE($GET(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),U)="PSOCLO1"
- GOTO CON
- +4 SET DIR(0)="52.0113,4"
- SET DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
- +5 SET DIR("B")=$SELECT($DATA(DUR):DUR,$GET(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"")
- if DIR("B")=""
- KILL DIR("B")
- +6 DO ^DIR
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="DUR"
- GOTO JUMP
- +7 if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- +8 ;PSO*7*754 comment out code added with PSO*7*457
- +9 ;; START NCC REMEDIATION >> 457*RJS - ADJUST FOR 4 DAY SUPPLY
- +10 ;/RBN Begin modification for #326 ;/MZR Added a message and correct checking for Hours/Minutes
- +11 ;I $G(DIR("B"))!$G(PSORXED("DURATION",ENT)) N Z,MAX D I Z>MAX S PSORXED("DURATION",$G(PSORXED("ENT")))=MAX G DUR
- +12 ;.I X=+X S Z=X
- +13 ;.E S Z=$E(X,$L(X)),Z=$S(Z="L":30*X,Z="W":7*X,Z="H":X/24,Z="M":X/1440,1:+X)
- +14 ;.S MAX=$S($G(DIR("B")):+DIR("B"),1:$G(PSORXED("DURATION",ENT)))
- +15 ;.I Z>MAX D
- +16 ;..W " ("_$S(X["L":"MONTHS",X["W":"WEEKS",X["H":"HOURS",X["M":"MINUTES",1:"DAYS")_")"
- +17 ;..W !,"NOT MORE THAN ",MAX," DAYS"
- +18 ;; END NCC REMEDIATION << 457*RJS
- +19 DO DUR1^PSOOREDX
- +20 ;
- CON DO CON^PSOOREDX
- IF X[U
- IF $LENGTH(X)>1
- SET FIELD="CON"
- GOTO JUMP
- +1 if $DATA(DTOUT)
- GOTO EX
- if $DATA(DUOUT)
- GOTO EXE
- +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="@"
- DO CON1^PSOOREDX
- if $DATA(DIRUT)
- GOTO EX
- if 'Y
- GOTO CON
- if '$GET(COPY)
- SET PSOSIGFL=1
- DO UPD^PSOOREDX
- GOTO CON
- +5 ;
- +6 IF '$$DUROK^PSOORED3(.PSORXED,ENT)
- Begin DoDot:1
- +7 WRITE !!,"Duration is required for the dosage entered prior to the THEN conjunction.",$CHAR(7),!
- End DoDot:1
- GOTO DUR
- +8 NEW PSODLBD4
- SET PSOSAVX=X
- SET PSODLBD4=1
- +9 IF $GET(PSORXED("CONJUNCTION",ENT))]""
- SET PSOCKCON=1
- DO DCHK1^PSODOSUT
- if $GET(PSORXED("DFLG"))!($GET(PSORX("DFLG")))
- GOTO EX
- SET ENT=ENT+1
- KILL DIR
- GOTO ASK
- +10 IF '$TEST
- KILL PSOCKCON
- IF $$DCHK^PSODOSUT
- SET PSORXED("DFLG")=1
- SET PSORX("DFLG")=1
- GOTO EX
- +11 IF PSOSAVX=""
- IF $GET(PSORXED)!($DATA(PSOEDDOS))
- KILL PSOCKCON
- +12 KILL PSOSAVX
- +13 ;
- EXS ;Entry point for EXE to rebuild SIG PSO*7.0*450
- +1 SET X=$GET(PSORXED("INS"))
- DO SIG^PSOHELP
- if $GET(INS1)]""
- SET PSORXED("SIG")=$EXTRACT(INS1,2,9999999)
- +2 DO EN^PSOFSIG(.PSORXED)
- IF $ORDER(SIG(0))
- SET PSORXED("ENT")=ENT
- SET SIGOK=1
- +3 if $GET(PSOREEDT)!($GET(PSOORRNW))
- QUIT
- +4 KILL QTYHLD
- if $GET(PSORXED("QTY"))
- SET QTYHLD=PSORXED("QTY")
- DO QTY^PSOSIG(.PSORXED)
- IF $GET(PSORXED("QTY"))
- SET QTY=1
- +5 IF $GET(QTYHLD)
- IF '$GET(PSORXED("QTY"))
- SET PSORXED("QTY")=QTYHLD
- +6 KILL QTYHLD
- if $GET(PSOFROM)="NEW"!($GET(COPY))!($GET(PSOFROM))!($GET(PSOREEDT))
- QUIT
- +7 if $GET(PSOSIGFL)
- QUIT
- Begin DoDot:1
- +8 SET D=0
- FOR
- SET D=$ORDER(SIG(D))
- if 'D
- QUIT
- SET ^PSRX(PSORXED("IRXN"),"SIG1",D,0)=SIG(D)
- SET $PIECE(^PSRX(PSORXED("IRXN"),"SIG1",0),"^",3)=+$PIECE($GET(^PSRX(PSORXED("IRXN"),"SIG1",0)),"^",3)+1
- SET $PIECE(^(0),"^",4)=+$PIECE($GET(^(0)),"^",4)+1
- if '$ORDER(SIG(D))
- QUIT
- +9 SET (A,I)=0
- FOR
- SET I=$ORDER(^PSRX(PSORXED("IRXN"),"A",I))
- if 'I
- QUIT
- SET A=A+1
- +10 if '$DATA(^PSRX(PSORXED("IRXN"),"A",0))
- SET ^PSRX(PSORXED("IRXN"),"A",0)="^52.3DA^"
- +11 SET $PIECE(^PSRX(PSORXED("IRXN"),"A",0),"^",3)=$PIECE($GET(^PSRX(PSORXED("IRXN"),"A",0)),"^",3)+1
- SET $PIECE(^(0),"^",4)=$PIECE($GET(^(0)),"^",4)+1
- +12 DO NOW^%DTC
- SET A=A+1
- SET ^PSRX(PSORXED("IRXN"),"A",A,0)=%_"^E^"_DUZ_"^0^New Dosing Instructions Added"
- SET ^PSRX(PSORXED("IRXN"),"A",A,1)="ORIGINAL SIG^"
- Begin DoDot:2
- +13 IF '$PIECE(^PSRX(PSORXED("IRXN"),"SIG"),"^",2)
- SET $PIECE(^PSRX(PSORXED("IRXN"),"A",A,1),"^",2)=$PIECE(^PSRX(PSORXED("IRXN"),"SIG"),"^")
- QUIT
- +14 FOR I=0:0
- SET I=$ORDER(^PSRX(PSORXED("IRXN"),"SIG1",I))
- if 'I
- QUIT
- SET ^PSRX(PSORXED("IRXN"),"A",A,2,I,0)=^PSRX(PSORXED("IRXN"),"SIG1",I,0)
- SET ^PSRX(PSORXED("IRXN"),"A",A,2,0)="^52.34A^"_I_"^"_I
- End DoDot:2
- +15 SET ^PSRX(PSORXED("IRXN"),"SIG")="^1"
- KILL SIG,A,I
- End DoDot:1
- +16 SET ^PSRX(PSORXED("IRXN"),6,0)="^52.0113^"_ENT_"^"_ENT
- +17 FOR I=1:1:ENT
- SET ^PSRX(PSORXED("IRXN"),6,I,0)=PSORXED("DOSE",I)_"^"_$GET(PSORXED("DOSE ORDERED",I))_"^"_$GET(PSORXED("UNITS",I))_"^"_$GET(PSORXED("NOUN",I))_"^"
- Begin DoDot:1
- +18 SET ^PSRX(PSORXED("IRXN"),6,I,0)=^PSRX(PSORXED("IRXN"),6,I,0)_$GET(PSORXED("DURATION",I))_"^"_$GET(PSORXED("CONJUNCTION",I))_"^"_$GET(PSORXED("ROUTE",I))_"^"_$GET(PSORXED("SCHEDULE",I))_"^"_$GET(PSORXED("VERB",I))
- +19 IF $GET(PSORXED("DOSE",I))]""
- SET ^PSRX(PSORXED("IRXN"),6,I,1)=PSORXED("DOSE",I)
- End DoDot:1
- +20 SET ^PSRX(PSORXED("IRXN"),"POE")=1
- GOTO EX
- +21 QUIT
- EX ;p555 added ENTBKP
- IF $DATA(DUOUT)!($DATA(DTOUT))
- SET PSONEW("DFLG")=1
- if $DATA(ENTBKP)
- SET ENT=ENTBKP
- +1 ;I $D(DUOUT)!($D(DTOUT)) S:'$G(PSORX("EDIT")) PSONEW("DFLG")=1
- +2 if $GET(PSOSIGFL)!($GET(PSORX("EDIT")))!($GET(PSORXED))!($GET(PSOREEDT))
- GOTO EX1
- +3 KILL PSORXED("DOSE"),PSORXED("NOUN"),PSORXED("VERB"),PSORXED("DOSE ORDERED"),PSORXED("ROUTE"),SIG,PSORXED("SCHEDULE"),PSORXED("DURATION"),PSORXED("CONJUNCTION"),PSORXED("ODOSE")
- EX1 KILL UNITN,STRE,DOSE,DUPD,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSOSCH,ENT,PSORTE,DURA,ERTE,ROU
- KV KILL DIR,DIRUT,DTOUT,DUOUT
- +1 QUIT
- +2 ;This line tag was added to check if EXit is being performed while EDITing. If it is,
- +3 ;process SIG and do not delete order. Previous calls to EX when due to $D(DUOUT) were
- +4 ;changed to go to this line tag instead.
- EXE ;*PSO*7.0*450 p555 added ENTBKP
- IF $GET(PSORX("EDIT"))]""
- KILL DUOUT
- if $DATA(ENTBKP)
- SET ENT=ENTBKP
- GOTO EXS
- +1 GOTO EX
- +2 ;
- UPD ;updates dosing array
- +1 DO UPD^PSOORED6
- +2 QUIT
- JUMP ;
- +1 IF $GET(PSORXED("SCHEDULE",1))']""
- WRITE $CHAR(7),!!,"All Dosing Instructions must be entered before Jumping to other Fields!",!!
- GOTO @FIELD
- +2 IF $LENGTH($EXTRACT(X,2,99))<3
- WRITE !,"Field Name Must Be At Least 3 Characters in Length",!
- GOTO @FIELD
- +3 DO FNM^PSOOREDX
- +4 IF FLDNM']""
- KILL X,NM,FLDNM
- WRITE !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",!
- GOTO @FIELD
- +5 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
- +6 DO KV
- +7 IF $GET(PSOFROM)'="NEW"
- IF '$GET(COPY)
- SET DIR("A",1)="* Indicates which fields will create a New Order"
- +8 SET DIR("A")="Select Field by number"
- SET DIR(0)="NO^1:"_AR1
- DO ^DIR
- if $DATA(DIRUT)
- GOTO @FIELD
- +9 DO JFN^PSOOREDX
- if FLDNM=""
- GOTO @FIELD
- GOTO @FLDNM
- +10 GOTO EX
- +11 QUIT
- LAN ;
- +1 if '$GET(PSODRUG("IEN"))
- QUIT
- +2 IF $GET(OR0)
- IF '$GET(PSONEW("DOSE ORDERED",II))
- IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
- Begin DoDot:1
- +3 if $GET(OTHDOS(II))
- QUIT
- +4 FOR QI=0:0
- SET QI=$ORDER(^PSDRUG(PSODRUG("IEN"),"DOS2",QI))
- if 'QI
- QUIT
- Begin DoDot:2
- +5 if $GET(PSONEW("DOSE",II))']""
- QUIT
- +6 IF PSONEW("DOSE",II)=$PIECE(^PSDRUG(PSODRUG("IEN"),"DOS2",QI,0),"^")
- SET PSONEW("ODOSE",II)=$PIECE(^PSDRUG(PSODRUG("IEN"),"DOS2",QI,0),"^",4)
- SET QII=1
- End DoDot:2
- if $GET(QII)
- QUIT
- End DoDot:1
- KILL QI,QII
- QUIT
- +7 IF $GET(Y)
- IF $PIECE($GET(DOSE(Y)),"^",13)]""
- SET PSORXED("ODOSE",ENT)=$PIECE(DOSE(Y),"^",13)
- QUIT
- +8 KILL QII
- FOR I=0:0
- SET I=$ORDER(^PSDRUG(PSODRUG("IEN"),"DOS2",I))
- if 'I
- QUIT
- IF DOSE=$PIECE(^PSDRUG(PSODRUG("IEN"),"DOS2",I,0),"^")
- Begin DoDot:1
- +9 SET PSORXED("ODOSE",ENT)=$PIECE(^PSDRUG(PSODRUG("IEN"),"DOS2",I,0),"^",4)
- SET QII=1
- End DoDot:1
- if $GET(QII)
- QUIT
- +10 KILL QII,I
- +11 QUIT
- +12 ;
- SCHASL(SCHA) ;
- +1 NEW SCHEA,SCHFL1
- SET SCHEA=""
- SET SCHFL1=0
- +2 ;**Lookup into the ADMINISTRATION SCHEDULE (#51.1) file
- +3 KILL X,Y,DIC,D
- SET X=$GET(SCHA)
- SET DIC="^PS(51.1,"
- SET DIC(0)="CEMOV"
- +4 ;*507
- SET DIC("W")="W "" ""_$G(X)_"" ""_$P(^PS(51.1,+Y,0),U,8)_$S($P(^(0),U,12):"" **INACTIVE**"",1:"""")"
- +5 ;*507
- SET D="APPSJ^D"
- WRITE !,"Now searching ADMINISTRATION SCHEDULE (#51.1) file...",!
- DO MIX^DIC1
- +6 KILL DIC,D
- if Y'>0
- SET SCHFL1=1
- IF '$GET(SCHFL1)
- IF '$DATA(DTOUT)
- IF '$DATA(DUOUT)
- SET SCHEA=$PIECE(Y,U,2)
- QUIT SCHEA
- +7 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT ""
- +8 IF $GET(SCHFL1)=1
- SET SCHEA=$$SCHMI(SCHA)
- QUIT SCHEA
- +9 QUIT ""
- +10 ;
- SCHMI(SCHM) ;
- +1 NEW SCHEM,SCHFL2
- SET SCHEM=""
- SET SCHFL2=0
- +2 ;**Lookup into the MEDICATION INSRUCTION (#51) file
- +3 KILL X,Y,DIC,D
- SET X=$GET(SCHM)
- SET DIC="^PS(51,"
- SET DIC(0)="CEMOV"
- SET DIC("W")="W "" ""_$G(X)_"" ""_$P(^PS(51,+Y,0),U,2)"
- SET D="A^B^D"
- WRITE !,"Now searching MEDICATION INSTRUCTION (#51) file...",!
- DO MIX^DIC1
- +4 KILL DIC,D
- if Y'>0
- SET SCHFL2=1
- IF '$GET(SCHFL2)
- IF '$DATA(DTOUT)
- IF '$DATA(DUOUT)
- SET SCHEM=$PIECE(Y,U,2)
- QUIT SCHEM
- +5 ;
- +6 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT ""
- +7 IF $GET(SCHFL2)=1
- QUIT SCHM
- +8 QUIT ""
- +9 ;
- MRSL ;;check for OI med route short list ;*525
- +1 IF $GET(PSODRUG("OI"))
- DO START^PSSJORDF(PSODRUG("OI"),"O")
- NEW MRCNT
- SET MRCNT=$ORDER(^TMP("PSJMR",$JOB,"A"),-1)
- IF MRCNT
- Begin DoDot:1
- +2 NEW MRTP
- SET MRTP="PSOTP"
- KILL ^TMP(MRTP,$JOB)
- SET ^TMP(MRTP,$JOB,0)=U_U_MRCNT_U_MRCNT
- +3 NEW I
- SET I=0
- FOR
- SET I=$ORDER(^TMP("PSJMR",$JOB,I))
- if 'I
- QUIT
- Begin DoDot:2
- +4 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
- +5 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)
- +6 IF Y=-1
- SET MRQ=1
- QUIT
- +7 SET MRSLS=1
- SET X=$PIECE(Y,"^",2)
- End DoDot:1
- +8 QUIT
- +9 ;
- CKMRSL ;;check for med route short list leading letters ;*525
- +1 IF $GET(PSODRUG("OI"))
- DO START^PSSJORDF(PSODRUG("OI"),"O")
- NEW MRCNT
- SET MRCNT=$ORDER(^TMP("PSJMR",$JOB,"A"),-1)
- IF MRCNT
- Begin DoDot:1
- +2 NEW MRTP
- SET MRTP="PSOTP"
- KILL ^TMP(MRTP,$JOB)
- SET ^TMP(MRTP,$JOB,0)=U_U_MRCNT_U_MRCNT
- +3 NEW I
- SET I=0
- FOR
- SET I=$ORDER(^TMP("PSJMR",$JOB,I))
- if 'I
- QUIT
- Begin DoDot:2
- +4 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
- +5 NEW DIC
- SET DIC("T")=""
- SET DIC="^TMP(MRTP,$J,"
- SET DIC(0)="EM"
- DO ^DIC
- KILL ^TMP(MRTP,$JOB),^TMP("PSJMR",$JOB)
- +6 IF Y=-1
- QUIT
- +7 SET X=$PIECE(Y,"^",2)
- End DoDot:1
- +8 QUIT