Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOORED5

PSOORED5.m

Go to the documentation of this file.
  1. 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
  1. ;Reference to ^PS(51.2 supported by DBIA 2226
  1. ;Reference to ^PS(50.7 supported by DBIA 2223
  1. ;Reference to ^PSDRUG( supported by DBIA 221
  1. ;Reference to ^PS(55 supported by DBIA 2228
  1. ;External reference to START^PSSJORDF(PSODRUG supported by DBIA 2418
  1. ;called by psoored2 and psodir
  1. ;pre-poe rxs and new backdoor rxs
  1. ;
  1. ;*507 indicate inactive file #51.1 sched entries
  1. ;
  1. DOSE1(PSORXED) ;for new rxs
  1. DOSE ;pre-poe rx
  1. 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
  1. ASK S ROU="PSOORED5" D ASK^PSOBKDED K ROU G:$D(DIRUT) EXE ;486
  1. I $G(JUMP) K JUMP G JUMP
  1. I $G(QUIT)]"" K QUIT,ROU Q
  1. ;
  1. I $G(VERB)]"" S PSORXED("VERB",ENT)=VERB G DUPD
  1. I $G(PSORX("EDIT"))']"" W:$G(PSORXED("VERB",ENT))]"" !,"VERB: "_PSORXED("VERB",ENT) G DUPD
  1. VER D VER^PSOOREDX
  1. I X[U,$L(X)>1 S FIELD="VER" G JUMP
  1. G EX:$D(DTOUT),EXE:$D(DUOUT) I X="@" K PSORXED("VERB",ENT),VERB G DUPD
  1. S:X'="" (PSORXED("VERB",ENT),VERB)=X
  1. DUPD ;
  1. I $G(PSORXED("DOSE",ENT))'?.N&($G(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD") K PSORXED("DOSE ORDERED",ENT),DUPD G NOU1
  1. D KV S DIR(0)="52.0113,1",DIR("A")="DISPENSE UNITS PER DOSE"_$S($G(PSORXED("NOUN",ENT))]"":"("_PSORXED("NOUN",ENT)_")",1:"")
  1. I '$G(PSORXED("DOSE",ENT)),$G(PSORXED("DOSE",ENT-1)) S PSORXED("DOSE",ENT)=PSORXED("DOSE",ENT-1)
  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")
  1. D ^DIR I X[U,$L(X)>1 S FIELD="DUPD" G JUMP
  1. G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. I X="@"!(X=0) W !,"Dispense Units Per Dose is Required!!",! G DUPD
  1. D STR^PSOOREDX
  1. ;
  1. NOU1 G:'$D(DUPD) RTE D CNON^PSOORED3 N PSONDEF
  1. I $G(NOUN)]"",$G(PSORX("EDIT"))']"" S PSORXED("NOUN",ENT)=NOUN W !,"NOUN: "_$G(NOUN) G RTE
  1. I $G(PSORX("EDIT"))']"",$G(PSORXED("NOUN",ENT))]"" W !,"NOUN: "_PSORXED("NOUN",ENT) G RTE
  1. NOU D NOU^PSOOREDX I X[U,$L(X)>1 S FIELD="NOU" G JUMP
  1. G EXE:$D(DTOUT)!$D(DUOUT) I X="@" K PSORXED("NOUN",ENT),NOUN G RTE
  1. I X'="",$G(PSONDEF)="" S NOUN=X
  1. I X'="",$G(PSONDEF)'=X S NOUN=X
  1. S:X'="" PSORXED("NOUN",ENT)=X
  1. ;
  1. 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
  1. 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)
  1. I $G(DRET) S PSORXED("ROUTE",ENT)=""
  1. I $G(RTE) K RTE
  1. ;*525
  1. 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:"")
  1. S X=""
  1. W !,"ROUTE: "_MRDFV_"//"
  1. D G:$G(MRSLS) DQ G:MRQ=1 RTE
  1. . R MRX:DTIME
  1. . I '$T S DTOUT=1 Q
  1. . I MRX="^" S DUOUT=1 Q
  1. . I MRX="?" D MRSL
  1. . I (MRX="")!(MRX=" ")&($G(MRDFV)]"") S MRX=$G(MRDFV)
  1. . I $E(MRX,1)=" " S MRQ=1
  1. S X=MRX
  1. K MRSLS,MRX,MRDFV,MRQ
  1. I X[U,$L(X)>1 S FIELD="RTE" G JUMP
  1. S:($D(DTOUT))!($D(DUOUT)) PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. I X="^" S PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. I X="@"!(X="") K RTE,ERTE S DRET=1,PSORXED("ROUTE",ENT)="" G SCH
  1. D CKMRSL
  1. 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
  1. ;D KV S DIR(0)="FO^2:45",DIR("A")="ROUTE",DIR("?")="^D HLP^PSOORED4"
  1. ;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")
  1. ;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")
  1. ;D ^DIR I X[U,$L(X)>1 S FIELD="RTE" G JUMP
  1. ;S:($D(DTOUT))!($D(DUOUT)) PSODIR("DFLG")=1 G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. ;I X="@"!(X="") K RTE,ERTE S DRET=1,PSORXED("ROUTE",ENT)="" G SCH
  1. ;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
  1. ;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)
  1. DQ ;
  1. 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)
  1. RTF ;
  1. S:X'="" PSORXED("ROUTE",ENT)=+Y,RTE=Y(0,0),ERTE=$P(Y(0),"^",2)
  1. ;
  1. SCH D SCH^PSOBKDED I X[U,$L(X)>1 S FIELD="SCH" G JUMP
  1. G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. S SCH=$$SCHASL(Y) D SCH^PSOSIG I $G(SCH)']""!($D(DTOUT))!($D(DUOUT)) G SCH
  1. S PSORXED("SCHEDULE",ENT)=SCH IF $G(SCHEX)'="" W " ("_SCHEX_")"
  1. K SCH,SCHEX,X,Y,PSOSCH
  1. S:$G(PSORXED("ENT"))<ENT PSORXED("ENT")=ENT
  1. ;
  1. DUR ;
  1. D KV K EXP
  1. ; PSO*7.0*574 - skip limited duration field for clozapine order
  1. I $P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),U)="PSOCLO1" G CON
  1. S DIR(0)="52.0113,4",DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
  1. S DIR("B")=$S($D(DUR):DUR,$G(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"") K:DIR("B")="" DIR("B")
  1. D ^DIR I X[U,$L(X)>1 S FIELD="DUR" G JUMP
  1. G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. ;PSO*7*754 comment out code added with PSO*7*457
  1. ;; START NCC REMEDIATION >> 457*RJS - ADJUST FOR 4 DAY SUPPLY
  1. ;/RBN Begin modification for #326 ;/MZR Added a message and correct checking for Hours/Minutes
  1. ;I $G(DIR("B"))!$G(PSORXED("DURATION",ENT)) N Z,MAX D I Z>MAX S PSORXED("DURATION",$G(PSORXED("ENT")))=MAX G DUR
  1. ;.I X=+X S Z=X
  1. ;.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)
  1. ;.S MAX=$S($G(DIR("B")):+DIR("B"),1:$G(PSORXED("DURATION",ENT)))
  1. ;.I Z>MAX D
  1. ;..W " ("_$S(X["L":"MONTHS",X["W":"WEEKS",X["H":"HOURS",X["M":"MINUTES",1:"DAYS")_")"
  1. ;..W !,"NOT MORE THAN ",MAX," DAYS"
  1. ;; END NCC REMEDIATION << 457*RJS
  1. D DUR1^PSOOREDX
  1. ;
  1. CON D CON^PSOOREDX I X[U,$L(X)>1 S FIELD="CON" G JUMP
  1. G EX:$D(DTOUT),EXE:$D(DUOUT)
  1. I X="@",$G(PSORXED("CONJUNCTION",ENT))="" W !,?10,"Invalid Entry - nothing to delete!!" G CON
  1. S:X'=""&(X'="@") PSORXED("CONJUNCTION",ENT)=Y
  1. I X="@" D CON1^PSOOREDX G:$D(DIRUT) EX G:'Y CON S:'$G(COPY) PSOSIGFL=1 D UPD^PSOOREDX G CON
  1. ;
  1. I '$$DUROK^PSOORED3(.PSORXED,ENT) D G DUR
  1. . W !!,"Duration is required for the dosage entered prior to the THEN conjunction.",$C(7),!
  1. N PSODLBD4 S PSOSAVX=X,PSODLBD4=1
  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
  1. E K PSOCKCON I $$DCHK^PSODOSUT S PSORXED("DFLG")=1,PSORX("DFLG")=1 G EX
  1. I PSOSAVX="",$G(PSORXED)!($D(PSOEDDOS)) K PSOCKCON
  1. K PSOSAVX
  1. ;
  1. EXS ;Entry point for EXE to rebuild SIG PSO*7.0*450
  1. S X=$G(PSORXED("INS")) D SIG^PSOHELP S:$G(INS1)]"" PSORXED("SIG")=$E(INS1,2,9999999)
  1. D EN^PSOFSIG(.PSORXED) I $O(SIG(0)) S PSORXED("ENT")=ENT,SIGOK=1
  1. Q:$G(PSOREEDT)!($G(PSOORRNW))
  1. K QTYHLD S:$G(PSORXED("QTY")) QTYHLD=PSORXED("QTY") D QTY^PSOSIG(.PSORXED) I $G(PSORXED("QTY")) S QTY=1
  1. I $G(QTYHLD),'$G(PSORXED("QTY")) S PSORXED("QTY")=QTYHLD
  1. K QTYHLD Q:$G(PSOFROM)="NEW"!($G(COPY))!($G(PSOFROM))!($G(PSOREEDT))
  1. Q:$G(PSOSIGFL) D
  1. .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))
  1. .S (A,I)=0 F S I=$O(^PSRX(PSORXED("IRXN"),"A",I)) Q:'I S A=A+1
  1. .S:'$D(^PSRX(PSORXED("IRXN"),"A",0)) ^PSRX(PSORXED("IRXN"),"A",0)="^52.3DA^"
  1. .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
  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
  1. ..I '$P(^PSRX(PSORXED("IRXN"),"SIG"),"^",2) S $P(^PSRX(PSORXED("IRXN"),"A",A,1),"^",2)=$P(^PSRX(PSORXED("IRXN"),"SIG"),"^") Q
  1. ..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
  1. .S ^PSRX(PSORXED("IRXN"),"SIG")="^1" K SIG,A,I
  1. S ^PSRX(PSORXED("IRXN"),6,0)="^52.0113^"_ENT_"^"_ENT
  1. 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
  1. .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))
  1. .I $G(PSORXED("DOSE",I))]"" S ^PSRX(PSORXED("IRXN"),6,I,1)=PSORXED("DOSE",I)
  1. S ^PSRX(PSORXED("IRXN"),"POE")=1 G EX
  1. Q
  1. EX I $D(DUOUT)!($D(DTOUT)) S PSONEW("DFLG")=1 S:$D(ENTBKP) ENT=ENTBKP ;p555 added ENTBKP
  1. ;I $D(DUOUT)!($D(DTOUT)) S:'$G(PSORX("EDIT")) PSONEW("DFLG")=1
  1. G:$G(PSOSIGFL)!($G(PSORX("EDIT")))!($G(PSORXED))!($G(PSOREEDT)) EX1
  1. K PSORXED("DOSE"),PSORXED("NOUN"),PSORXED("VERB"),PSORXED("DOSE ORDERED"),PSORXED("ROUTE"),SIG,PSORXED("SCHEDULE"),PSORXED("DURATION"),PSORXED("CONJUNCTION"),PSORXED("ODOSE")
  1. EX1 K UNITN,STRE,DOSE,DUPD,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSOSCH,ENT,PSORTE,DURA,ERTE,ROU
  1. KV K DIR,DIRUT,DTOUT,DUOUT
  1. Q
  1. ;This line tag was added to check if EXit is being performed while EDITing. If it is,
  1. ;process SIG and do not delete order. Previous calls to EX when due to $D(DUOUT) were
  1. ;changed to go to this line tag instead.
  1. EXE I $G(PSORX("EDIT"))]"" K DUOUT S:$D(ENTBKP) ENT=ENTBKP G EXS ;*PSO*7.0*450 p555 added ENTBKP
  1. G EX
  1. ;
  1. UPD ;updates dosing array
  1. D UPD^PSOORED6
  1. Q
  1. JUMP ;
  1. I $G(PSORXED("SCHEDULE",1))']"" W $C(7),!!,"All Dosing Instructions must be entered before Jumping to other Fields!",!! G @FIELD
  1. I $L($E(X,2,99))<3 W !,"Field Name Must Be At Least 3 Characters in Length",! G @FIELD
  1. D FNM^PSOOREDX
  1. I FLDNM']"" K X,NM,FLDNM W !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",! G @FIELD
  1. 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
  1. D KV
  1. I $G(PSOFROM)'="NEW",'$G(COPY) S DIR("A",1)="* Indicates which fields will create a New Order"
  1. S DIR("A")="Select Field by number",DIR(0)="NO^1:"_AR1 D ^DIR G:$D(DIRUT) @FIELD
  1. D JFN^PSOOREDX G:FLDNM="" @FIELD G @FLDNM
  1. G EX
  1. Q
  1. LAN ;
  1. Q:'$G(PSODRUG("IEN"))
  1. I $G(OR0),'$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D K QI,QII Q
  1. .Q:$G(OTHDOS(II))
  1. .F QI=0:0 S QI=$O(^PSDRUG(PSODRUG("IEN"),"DOS2",QI)) Q:'QI D Q:$G(QII)
  1. ..Q:$G(PSONEW("DOSE",II))']""
  1. ..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
  1. I $G(Y),$P($G(DOSE(Y)),"^",13)]"" S PSORXED("ODOSE",ENT)=$P(DOSE(Y),"^",13) Q
  1. 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)
  1. .S PSORXED("ODOSE",ENT)=$P(^PSDRUG(PSODRUG("IEN"),"DOS2",I,0),"^",4),QII=1
  1. K QII,I
  1. Q
  1. ;
  1. SCHASL(SCHA) ;
  1. N SCHEA,SCHFL1 S SCHEA="",SCHFL1=0
  1. ;**Lookup into the ADMINISTRATION SCHEDULE (#51.1) file
  1. K X,Y,DIC,D SET X=$G(SCHA),DIC="^PS(51.1,",DIC(0)="CEMOV"
  1. S DIC("W")="W "" ""_$G(X)_"" ""_$P(^PS(51.1,+Y,0),U,8)_$S($P(^(0),U,12):"" **INACTIVE**"",1:"""")" ;*507
  1. S D="APPSJ^D" W !,"Now searching ADMINISTRATION SCHEDULE (#51.1) file...",! D MIX^DIC1 ;*507
  1. K DIC,D S:Y'>0 SCHFL1=1 IF '$G(SCHFL1),'$D(DTOUT),'$D(DUOUT) SET SCHEA=$P(Y,U,2) Q SCHEA
  1. I $D(DTOUT)!($D(DUOUT)) Q ""
  1. I $G(SCHFL1)=1 S SCHEA=$$SCHMI(SCHA) Q SCHEA
  1. Q ""
  1. ;
  1. SCHMI(SCHM) ;
  1. N SCHEM,SCHFL2 S SCHEM="",SCHFL2=0
  1. ;**Lookup into the MEDICATION INSRUCTION (#51) file
  1. 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
  1. K DIC,D S:Y'>0 SCHFL2=1 IF '$G(SCHFL2),'$D(DTOUT),'$D(DUOUT) SET SCHEM=$P(Y,U,2) Q SCHEM
  1. ;
  1. I $D(DTOUT)!($D(DUOUT)) Q ""
  1. I $G(SCHFL2)=1 Q SCHM
  1. Q ""
  1. ;
  1. MRSL ;;check for OI med route short list ;*525
  1. I $G(PSODRUG("OI")) D START^PSSJORDF(PSODRUG("OI"),"O") N MRCNT S MRCNT=$O(^TMP("PSJMR",$J,"A"),-1) I MRCNT D
  1. . N MRTP S MRTP="PSOTP" K ^TMP(MRTP,$J) S ^TMP(MRTP,$J,0)=U_U_MRCNT_U_MRCNT
  1. . N I S I=0 F S I=$O(^TMP("PSJMR",$J,I)) Q:'I D
  1. . . 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)
  1. . N DIC S DIC("A")="Select MED ROUTE: ",DIC="^TMP(MRTP,$J,",DIC(0)="AEQZ" D ^DIC K ^TMP(MRTP,$J),^TMP("PSJMR",$J)
  1. . I Y=-1 S MRQ=1 Q
  1. . S MRSLS=1,X=$P(Y,"^",2)
  1. Q
  1. ;
  1. CKMRSL ;;check for med route short list leading letters ;*525
  1. I $G(PSODRUG("OI")) D START^PSSJORDF(PSODRUG("OI"),"O") N MRCNT S MRCNT=$O(^TMP("PSJMR",$J,"A"),-1) I MRCNT D
  1. . N MRTP S MRTP="PSOTP" K ^TMP(MRTP,$J) S ^TMP(MRTP,$J,0)=U_U_MRCNT_U_MRCNT
  1. . N I S I=0 F S I=$O(^TMP("PSJMR",$J,I)) Q:'I D
  1. . . S ^TMP(MRTP,$J,I,0)=^TMP("PSJMR",$J,I),^TMP(MRTP,$J,"B",$P(^TMP("PSJMR",$J,I),U),I)=""
  1. . N DIC S DIC("T")="",DIC="^TMP(MRTP,$J,",DIC(0)="EM" D ^DIC K ^TMP(MRTP,$J),^TMP("PSJMR",$J)
  1. . I Y=-1 Q
  1. . S X=$P(Y,"^",2)
  1. Q