PSSPOIMO ;BIR/RTR/WRT - Edit Orderable Item Name and Inactive date ;Jun 23, 2020@13:14
;;1.0;PHARMACY DATA MANAGEMENT;**29,32,38,47,68,102,125,141,153,159,166,172,191,189,204,210,225,242,256**;9/30/97;Build 2
S PSSITE=+$O(^PS(59.7,0)) I +$P($G(^PS(59.7,PSSITE,80)),"^",2)<2 W !!?3,"Orderable Item Auto-Create has not been completed yet!",! K PSSITE K DIR S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR Q
K PSSITE W !!,"This option enables you to edit Orderable Item names, Formulary status,",!,"drug text, Inactive Dates, Indications for Use, and Synonyms."
EN I $D(PSOIEN) L -^PS(50.7,PSOIEN)
K PSSCROSS,DTOUT,DUOUT,DIRUT
K DIC ; S PY=$P($G(^PS(59.7,1,31)),"^",2)
S PSS1="W "" ""_$P(^PS(50.606,$P(^PS(50.7,+Y,0),""^"",2),0),""^"")_"" ""_$S($P($G(^PS(50.7,+Y,0)),""^"",4):$E($P(^(0),""^"",4),4,5)_""-""_$E($P(^(0),""^"",4),6,7)_""-""_$E($P(^(0),""^"",4),2,3),1:"""")"
S PSS2=" S NF=$P($G(^PS(50.7,+Y,0)),""^"",12) I NF S NF="" N/F"" W NF"
S DIC("W")=PSS1_PSS2,DIC("S")="I '$P($G(^PS(50.7,+Y,0)),""^"",3)"
;PSO*7*102;ONLY SEARCH B AND C X-REFS
S $P(PLINE,"-",79)="" W !! K PSOUT S DIC="^PS(50.7,",DIC(0)="QEAMZ",D="B^C" D MIX^DIC1 K DIC,PY,D G:Y<0!($D(DTOUT))!($D(DUOUT)) END
S PSOIEN=+Y,PSOINAME=$P(Y,"^",2),PSDOSE=+$P(^PS(50.7,PSOIEN,0),"^",2) L +^PS(50.7,PSOIEN):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I '$T W !,$C(7),"Another person is editing this one." Q
W !!!,?5,"Orderable Item -> ",PSOINAME,!?5,"Dosage Form -> ",$P($G(^PS(50.606,PSDOSE,0)),"^"),!
K DIR S DIR("?")=" ",DIR("?",1)="Enter 'Yes' to see all of the Dispense Drugs, IV Additives, and IV Solutions",DIR("?",2)="that are matched to this Orderable Item. IV Additives will be identified with"
S DIR("?",3)="an (A), and IV Solutions with an (S)."
S DIR(0)="Y",DIR("B")="YES",DIR("A")="List all Drugs/Additives/Solutions tied to this Orderable Item" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G EN
I Y D DISP
EDIT K DIR W ! S DIR(0)="Y",DIR("A")="Are you sure you want to edit this Orderable Item",DIR("B")="NO",DIR("?")="Answer YES to edit the fields associated with this Orderable Item." D ^DIR K DIR I 'Y!($D(DTOUT))!($D(DUOUT)) G EN
W !!?3,"Now editing Orderable Item:",!?3,PSOINAME," ",$P($G(^PS(50.606,PSDOSE,0)),"^")
DIR K DIR S DIR(0)="F^3:40",DIR("B")=PSOINAME,DIR("A")="Orderable Item Name" D ^DIR
I Y["^"!($D(DUOUT))!($D(DTOUT)) G EN
I X[""""!($A(X)=45)!('(X'?1P.E))!(X?2"z".E) W $C(7),!!?5,"??" G DIR
I X'=PSOINAME S ZZFLAG=0 D @$S('$P($G(^PS(50.7,PSOIEN,0)),"^",3):"CHECK",1:"ZCHECK") I ZZFLAG G DIR
S PSONEW=X,DIE="^PS(50.7,",DA=PSOIEN,DR=".01////"_X D ^DIE I PSONEW'=PSOINAME W !!,"Name changed from ",PSOINAME,!?15,"to ",PSONEW
S PSSDTENT=0 W ! K DIE N MFLG S PSBEFORE=$P(^PS(50.7,PSOIEN,0),"^",4),PSAFTER=0,PSINORDE="" D
.;If reactivate OI, prompt to reactivate DD's only if there are any, then always give message saying OI now Active. If Inactivate, prompt to inactivate any active DD's if there are any, and give message
.;but if OI is reactivated, and there are no activities matched to it, and user does not want to activate the drugs, then inactivate the OI again, and give a clear message explaining this.
.W !,"This Orderable Item is "_$S($P($G(^PS(50.7,PSOIEN,0)),"^",12):"Non-Formulary.",1:"Formulary."),!
.I $P($G(^PS(50.7,PSOIEN,0)),"^",10) W !,"This Orderable Item is marked as a Non-VA Med.",!
.S DIE="^PS(50.7,",DA=PSOIEN,DR=6 S PSCREATE=1 D ^DIE K DIE,PSCREATE I $D(DTOUT)!($D(Y)>10) Q
.;PSS*1*102;ADD DRUG TEXT AS SYNONYM IS REQUESTED BY USER
.D ADDSYN^PSSPOIMP
.K DIR S DIR(0)="DO",DIR("A")="INACTIVE DATE" D D ^DIR K DIR I $G(Y)["^"!($D(DTOUT))!($G(DUOUT)) Q
..I $G(PSBEFORE) S Y=PSBEFORE D DD^%DT S DIR("B")=$G(Y)
.I $G(PSBEFORE),'$G(Y) W ?40,"Inactive Date deleted!"
.S PSSDTENT=$G(Y) I $G(Y) D DD^%DT W ?40,$G(Y)
.S PSSOTH=$S($P($G(^PS(59.7,1,40.2)),"^"):1,1:0)
.S DIE="^PS(50.7,",DA=PSOIEN N PSSFG,PSSOU
.S DR=".05;@1;D SETF^PSSPOIMO;.06;D DFR^PSSPOIMO(PSDOSE);10//YES;I X=""Y"" S Y=""@2"";D PDCHK^PSSPOIMO S:PSSFG Y=""@1"";" D ;*256
..S DR=DR_"S:$G(DUOUT) Y=""@3"";@2;K DIE(""NO^""),DIRUT;D:'$G(DIRUT) MRSEL^PSSPOIMO;.07;.08;1;12//0;15;7;D LIND^PSSPOIMO;14;13;14.1T;14.2;S:'$G(PSSOTH) Y=""@3"";7.1;@3" ;*191, *225, *256
.S PSCREATE=1 D ^DIE K DIE,PSCREATE,PSSOTH,^TMP("PSJMR",$J),^TMP("PSSDMR",$J) I $D(PSSOU),'$G(PSSOU) D:'$G(DIRUT) MRSEL K ^TMP("PSJMR",$J)
.S $P(^PS(50.7,PSOIEN,0),"^",4)=PSSDTENT,PSAFTER=PSSDTENT
S:PSBEFORE&('$P(^PS(50.7,PSOIEN,0),"^",4)) PSINORDE="D" S:$P(^PS(50.7,PSOIEN,0),"^",4) PSINORDE="I"
I PSINORDE'="" D CHECK^PSSPOID2(PSOIEN) D
.I PSINORDE="D" D Q
..I $O(PSSDACTI(0))!($O(PSSSACTI(0)))!($O(PSSAACTI(0))) D
...W !!,"There are inactive "_$S($O(PSSDACTI(0)):"drugs, ",1:"")_$S($O(PSSAACTI(0)):"additives, ",1:"")_$S($O(PSSSACTI(0)):"solutions,",1:""),!,"matched to this Pharmacy Orderable Item."
.I $O(PSSDACT(0))!($O(PSSSACT(0)))!($O(PSSAACT(0))) D
..W !!,"There are active "_$S($O(PSSDACT(0)):"drugs, ",1:"")_$S($O(PSSAACT(0)):"additives, ",1:"")_$S($O(PSSSACT(0)):"solutions,",1:""),!,"matched to this Pharmacy Orderable Item."
I $G(PSINORDE)="D" I $O(PSSDACTI(0))!($O(PSSSACTI(0)))!($O(PSSAACTI(0))) D REST^PSSPOIDT(PSOIEN)
I $G(PSINORDE)="I" I $O(PSSDACT(0))!($O(PSSSACT(0)))!($O(PSSAACT(0))) D REST^PSSPOIDT(PSOIEN)
S DIK="^PS(50.7,",DA=PSOIEN,DIK(1)=.04 D EN^DIK K DIK
K PSBEFORE,PSAFTER,PSINORDE,PSSDTENT,PSSDACT,PSSDACTI,PSSSACT,PSSSACTI,PSSAACT,PSSAACTI
;*256 - moving indications for use *204 and other lang *242 fields to DR string above
IMMUN ;PSS*1*141 FOR 'IMMUNIZATIONS DOCUMENTATION BY BCMA'
I $O(^PSDRUG("AOC",PSOIEN,"IM000"))'["IM" G SYN ;ASK WHEN APPROPRIATE
W ! S DIE="^PS(50.7,",DA=PSOIEN,DR=9 D ^DIE K DIE
SYN I $G(Y)["^"!($G(DIRUT))!$D(DTOUT)!($D(Y)>10) G SYN1
W ! K DIC S:'$D(^PS(50.7,PSOIEN,2,0)) ^PS(50.7,PSOIEN,2,0)="^50.72^0^0" S DIC="^PS(50.7,"_PSOIEN_",2,",DA(1)=PSOIEN,DIC(0)="QEAMZL",DIC("A")="Select SYNONYM: ",DLAYGO=50.72 D ^DIC K DIC
I Y<0!($D(DUOUT))!($D(DTOUT)) K:'$O(^PS(50.7,PSOIEN,2,0)) ^PS(50.7,PSOIEN,2,0) D EN^PSSPOIDT(PSOIEN),EN2^PSSHL1(PSOIEN,"MUP") G EN
W ! S DA=+Y,DIE="^PS(50.7,"_PSOIEN_",2,",DA(1)=PSOIEN,DR=.01 D ^DIE K DIE G SYN
SYN1 ;File
D EN^PSSPOIDT(PSOIEN),EN2^PSSHL1(PSOIEN,"MUP")
G EN
END K ZZFLAG,DIC,DIR,DIE,DTOUT,DUOUT,DIRUT,FLAG,PSOINAME,PSOUT,PSDOSE,PSONEW,UPFLAG,VV,ZZ,AA,BB,Y,AAA,SSS,PSOARR,PSOARRAD,PLINE I $D(PSOIEN) L -^PS(50.7,PSOIEN) K PSOIEN
Q
DISP N PSSLFLAG,PSSLDATE S FLAG=1 D HEAD F ZZ=0:0 S ZZ=$O(^PSDRUG("ASP",PSOIEN,ZZ)) Q:'ZZ!($G(PSOUT)) S FLAG=0 D:($Y+5)>IOSL HEAD Q:$G(PSOUT) I ZZ W !,$P($G(^PSDRUG(ZZ,0)),"^") W:$P($G(^PSDRUG(ZZ,0)),"^",9) " N/F" D DTE
Q:$G(PSOUT)
S (FLAG,PSSLFLAG)=0
F ZZ=0:0 S ZZ=$O(^PS(52.6,"AOI",PSOIEN,ZZ)) Q:'ZZ!($G(PSOUT)) D:($Y+5)>IOSL HEAD Q:$G(PSOUT) I ZZ D
.S PSSLFLAG=1
.W !,$P($G(^PS(52.6,ZZ,0)),"^"),?31," (A) "
.W ?40,"Additive Strength: ",$S($$GET1^DIQ(52.6,ZZ,19)'="":$$GET1^DIQ(52.6,ZZ,19)_" "_$$GET1^DIQ(52.6,ZZ,2),1:"N/A")," "
.S PSSLDATE=$P($G(^PS(52.6,ZZ,"I")),"^") I PSSLDATE D DTEX
Q:$G(PSOUT)
;I $G(PSSLFLAG) W !
F ZZ=0:0 S ZZ=$O(^PS(52.7,"AOI",PSOIEN,ZZ)) Q:'ZZ!($G(PSOUT)) D:($Y+5)>IOSL HEAD Q:$G(PSOUT) I ZZ D
.W !,$P($G(^PS(52.7,ZZ,0)),"^"),?31,$P($G(^(0)),"^",3),?42,"(S)"
.S PSSLDATE=$P($G(^PS(52.7,ZZ,"I")),"^") I PSSLDATE D DTEX
Q
HEAD I 'FLAG W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR I 'Y S PSOUT=1 Q
W @IOF W !,?6,"Orderable Item -> ",PSOINAME,!?6,"Dosage Form -> ",$P($G(^PS(50.606,+$P($G(^PS(50.7,PSOIEN,0)),"^",2),0)),"^"),!!,"Dispense Drugs:"_$S('FLAG:" (continued)",1:""),!,"---------------"
Q
ADDIT ;If orderable item is flagged for IV
S AA=$O(^PS(52.6,"AOI",PSOIEN,0))
S BB=$O(^PS(52.7,"AOI",PSOIEN,0))
I 'AA,'BB W $C(7),!,"This Orderable Item is flagged for IV use, but currently there are no IV",!,"Additives or IV Solutions matched to this Orderable Item!" G EDIT
G SOL
CHECK ;
S ZZFLAG=0 F VV=0:0 S VV=$O(^PS(50.7,"ADF",X,PSDOSE,VV)) Q:'VV I VV,'$P($G(^PS(50.7,VV,0)),"^",3) S ZZFLAG=1
I ZZFLAG W $C(7),!!?5,"There is already an Orderable Item with this same name and Dosage Form",!?5,"that is not flagged as 'IV'. Use the 'DISPENSE DRUG/ORDERABLE ITEM",!?5,"MAINTENANCE' option if you want to re-match to this Orderable Item!",!
Q
ZCHECK ;
S ZZFLAG=0 F VV=0:0 S VV=$O(^PS(50.7,"ADF",X,PSDOSE,VV)) Q:'VV I VV,$P($G(^PS(50.7,VV,0)),"^",3) S ZZFLAG=1
I ZZFLAG W $C(7),!!?5,"There is already an Orderable Item with the same name and Dosage Form,",!?5,"that is flagged for 'IV' use.",!
Q
SOL ;
K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="List all Additives and Solutions tied to this Orderable Item" D ^DIR K DIR G:Y["^"!($D(DTOUT)) EN G:Y=0 EDIT
H 1 K PSOARR,PSOARRAD S AAA=$O(^PS(52.6,"AOI",PSOIEN,0)) I AAA,$D(^PS(52.6,AAA,0)) S PSOARRAD=AAA
F SSS=0:0 S SSS=$O(^PS(52.7,"AOI",PSOIEN,SSS)) Q:'SSS S:$D(^PS(52.7,SSS,0)) PSOARR(SSS)=""
S FLAG=1,UPFLAG=0 D SHEAD F ZZ=0:0 S ZZ=$O(PSOARR(ZZ)) Q:'ZZ!($G(PSOUT))!($G(UPFLAG)) S FLAG=0 D:($Y+7)>IOSL SHEAD Q:$G(PSOUT)!($G(UPFLAG)) I ZZ W !,$P($G(^PS(52.7,ZZ,0)),"^")," ",$P($G(^(0)),"^",3)
G:$G(PSOUT) EN
G EDIT
SHEAD I 'FLAG W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR I 'Y S:Y="" PSOUT=1 S:Y=0 UPFLAG=1 Q
W @IOF W !?6,"Orderable Item -> ",PSOINAME,?68,"(IV)",!?6,"Dosage Form -> ",$P($G(^PS(50.606,+$P($G(^PS(50.7,PSOIEN,0)),"^",2),0)),"^"),!,PLINE I FLAG,'$G(PSOARRAD) W !?5,"IV Solutions:",!
I 'FLAG W !?5,"IV Solutions:",!
I FLAG,$G(PSOARRAD) W !,$P($G(^PS(52.6,PSOARRAD,0)),"^")," ","(IV Additive)",! I $D(PSOARR) W !?5,"IV Solutions:",!
Q
DTE I $D(^PSDRUG(ZZ,"I")) S Y=$P(^PSDRUG(ZZ,"I"),"^") D DD^%DT W ?50,Y K Y
Q
DTEX S Y=$G(PSSLDATE) D DD^%DT W ?50,$G(Y) K Y
Q
IVMSG ; display a message if the CORRESPONDING IV field is entered
;
S PSSIVMSG=$P(^PS(50.7,PSOIEN,0),"^",11) I PSSIVMSG="" Q
S PSSIVFRM=$P(^PS(50.7,PSSIVMSG,0),"^",2) I PSSIVFRM S PSSIVFRM=$P(^PS(50.606,PSSIVFRM,0),"^")
S PSSIVMSG=$P(^PS(50.7,PSSIVMSG,0),"^")_" "_PSSIVFRM
W !!,"The Corresponding IV Item is currently identified as: "_PSSIVMSG,!
K PSSIVFRM,PSSIVMSG
Q
UDMSG ; display a message if the CORRESPONDING UD field is entered
;
S PSSUDMSG=$P(^PS(50.7,PSOIEN,0),"^",10) I PSSUDMSG="" Q
S PSSUDFRM=$P(^PS(50.7,PSSUDMSG,0),"^",2) I PSSUDFRM S PSSUDFRM=$P(^PS(50.606,PSSUDFRM,0),"^")
S PSSUDMSG=$P(^PS(50.7,PSSUDMSG,0),"^")_" "_PSSUDFRM
W !!,"The Corresponding UD Item is currently identified as: "_PSSUDMSG,!
K PSSUDMSG,PSSUDFRM
Q
DFR(PSDOSE) ; dosage form med routes - called by DR string at DIR+20^PSSPOIMO
D SETF
N MR,MRNODE,XX K ^TMP("PSSDMR",$J)
S (MCT,MR)=0 F S MR=$O(^PS(50.606,PSDOSE,"MR",MR)) Q:'MR D
.S XX=+$G(^PS(50.606,PSDOSE,"MR",MR,0)) Q:'XX S MRNODE=$G(^PS(51.2,XX,0)) I $P($G(MRNODE),"^",4)'=1 Q
.S MCT=MCT+1,^TMP("PSSDMR",$J,MCT)=$P(MRNODE,U),^TMP("PSSDMR",$J,"B",XX)=""
D DFRL
Q
DFRL W !!," List of med routes associated with the DOSAGE FORM of the orderable item:",!
S MCT=0 I '$O(^TMP("PSSDMR",$J,MCT)) W !,?3,"NO MED ROUTE DEFINED"
F S MCT=$O(^TMP("PSSDMR",$J,MCT)) Q:'MCT W !,?3,$G(^(MCT))
D EN^DDIOL(" If you answer YES to the next prompt, the DEFAULT MED ROUTE (if populated)",,"!!")
D EN^DDIOL(" and this list (if populated) will be displayed as selectable med routes",,"!")
D EN^DDIOL(" during medication ordering dialog. If you answer NO, the DEFAULT MED ROUTE",,"!")
D EN^DDIOL(" (if populated) and POSSIBLE MED ROUTES list will be displayed instead.",,"!") W !
;K ^TMP("PSSMR",$J)
Q
PDR ; possible med routes - called by DR string at DIR+20^PSSPOIMO
N MCT,MR,MRNODE,XX K ^TMP("PSSMR",$J)
S (XX,MCT)=0 F S XX=$O(^PS(50.7,$S($G(PSVAR):PSVAR,1:PSOIEN),3,"B",XX)) Q:'XX S MRNODE=$G(^PS(51.2,XX,0)),MCT=MCT+1,^TMP("PSSMR",$J,MCT)=$P(MRNODE,U)
I $O(^TMP("PSSMR",$J,0)) D
.W !!," List of Possible Med Routes associated with the orderable item:",!
.S MCT=0 F S MCT=$O(^TMP("PSSMR",$J,MCT)) Q:'MCT W !,?3,$G(^(MCT))
W ! K ^TMP("PSSMR",$J)
Q
PDCHK ; called by DR string at DIR+20^PSSPOIMO
N ANS,D,DIC,DIE,DO,DICR,DR,DIR,PSOUT,PSSDA,PSSX,PSSXA,PSSY,Q,X,Y,Z
S DIR(0)="PO^51.2:EMZ",DIR("A")="POSSIBLE MED ROUTES",DIR("S")="I $P(^(0),U,4)" S PSOUT=0
S DIR("PRE")="I X=""?"" D MRTHLP^PSSPOIMO"
F D PDR,^DIR D I PSOUT Q
.I (X="")!$D(DTOUT)!$D(DUOUT) S PSOUT=1 Q
.I X="@",$D(PSSY) S ANS=DA D:$$DASK Q
..N DIK,DA S DA(1)=ANS,DIK="^PS(50.7,"_DA(1)_",3,"
..S DA=$O(^PS(50.7,DA(1),3,"B",PSSY,"")) I DA="" Q
..D ^DIK K PSSY,DIR("B")
.I Y="" W " ??" Q
.I $D(^PS(50.7,DA,3,"B",+Y)) D Q
..I $D(DIR("B")) K PSSY,DIR("B") Q
..S DIR("B")=Y(0,0),PSSY=+Y Q
.S PSSXA=Y(0,0),PSSX=+Y D DFR(+$P(^PS(50.7,DA,0),"^",2))
.I $G(PSSX) S ANS=$$ASK() I 'ANS Q
.S PSSDA(50.711,"+1,"_DA_",",.01)=+PSSX
.D UPDATE^DIE("","PSSDA")
.K ^TMP("PSSMR",$J)
D DP
Q
ASK() ; confirm adding the new entry
N DIR,X,Y W ! S DIR(0)="YO",DIR("B")="YES"
I $D(^TMP("PSSDMR",$J)),'$D(^TMP("PSSDMR",$J,"B",PSSX)) S DIR("B")="NO",DIR("A",1)="The selected entry does not match to any of the dosage form med routes."
W $C(7) S DIR("A")=" Are you adding '"_PSSXA_"' as a new POSSIBLE MED ROUTE" D ^DIR
Q $S(Y=1:1,1:0)
DASK() ; delete possible med route
N DIR
W $C(7) S DIR("A")=" SURE YOU WANT TO DELETE ",DIR(0)="Y" D ^DIR
Q $S(Y=1:1,1:0)
MRTHLP ; help of possible med route
N DIC,RTE,D
S RTE=0 F S RTE=$O(^PS(50.7,DA,3,"B",RTE)) Q:'RTE D EN^DDIOL($P($G(^PS(51.2,RTE,0)),"^"),,"!,?4")
W ! D EN^DDIOL("Enter the most common MED ROUTE associated with this Orderable Item.",,"!,?5")
D EN^DDIOL("ONLY MED ROUTES MARKED FOR USE BY ALL PACKAGES ARE SELECTABLE.",,"!,?5")
Q
DP ; check the existence of Default Med Route & Possible Med Routes
N D,DIC,DIE,DO,DICR,DR,DIR,Q,X,Y,Z
I '$P($G(^PS(50.7,$S($G(PSVAR):PSVAR,1:PSOIEN),0)),"^",6)&('$O(^PS(50.7,$S($G(PSVAR):PSVAR,1:PSOIEN),3,0))) D
.S PSR(1)=" You have not selected ANY med routes to display during order entry. In"
.S PSR(2)=" order to have med routes displayed during order entry, you must either"
.S PSR(3)=" define a DEFAULT MED ROUTE and/or at least one POSSIBLE MED ROUTE, or"
.S PSR(4)=" answer YES to the USE DOSAGE FORM MED ROUTE LIST prompt."
.S PSR(5)=" **WITH THE CURRENT SETTINGS, NO MED ROUTES WILL DISPLAY FOR SELECTION ",PSR(5,"F")="!!"
.S PSR(6)=" DURING ORDER ENTRY FOR THIS ORDERABLE ITEM**"
.D EN^DDIOL(.PSR),EN^DDIOL(" ","","!")
.K DIR S DIR(0)="Y",DIR("?",1)="If you select NO, you will continue to loop back to the Default Med Route"
.S DIR("?")="prompt until either a selection is made or you answer YES to this prompt to proceed."
.S DIR("A",1)="",DIR("A",2)="The current setting is usually only appropriate for supply items."
.S DIR("A")="Continue with NO med route displaying for selection during order entry",DIR("B")="NO"
.D ^DIR K DIR W ! I 'Y!($D(DTOUT))!($D(DUOUT)) S PSSFG=1
.S:Y PSSFG=0
E S PSSFG=0
Q
;
SETF ;
S PSSOU=0 K ^TMP("PSJMR",$J) D MEDRT^PSSJORDF($S($G(PSVAR):PSVAR,1:PSOIEN))
I '$D(^TMP("PSJMR",$J)) S DIE("NO^")="",PSSFG=1
E S PSSFG=0 K DIE("NO^")
Q
MRSEL ;
K ^TMP("PSJMR",$J) D MEDRT^PSSJORDF($S($G(PSVAR):PSVAR,1:PSOIEN))
W !,"The following Med Routes will now be displayed during order entry:"
N I S (PSSOU,I)=0 F S I=$O(^TMP("PSJMR",$J,I)) Q:'I W !,$P(^(I),"^",2) S PSSOU=1
W:'PSSOU !,"(None)"
W ! S PSSOU=1
Q
;
LIND ;*242
N X,Y,C,I,J,K,L,M S C=0,Y=$P($G(^PS(50.7,DA,4)),"^",2),L=" *MOST COMMON",M="<OTHER LANGUAGE>"
S:Y]"" X(1)=Y_L,C=1
S I="" F S I=$O(^PS(50.7,DA,"IND","B",I)) Q:I="" D
.S J=$O(^PS(50.7,DA,"IND","B",I,0)) Q:'J S K=$P($G(^PS(50.7,DA,"IND",J,0)),U)
.S:K]"" C=C+1,X(C)=K
S Y=$P($G(^PS(50.7,DA,4)),"^",4)
S:Y]"" C=C+1,X(C)=Y_L_" "_M
S I="" F S I=$O(^PS(50.7,DA,"INDO","B",I)) Q:I="" D
.S J=$O(^PS(50.7,DA,"INDO","B",I,0)) Q:'J S K=$P($G(^PS(50.7,DA,"INDO",J,0)),U)
.S:K]"" C=C+1,X(C)=K_" "_M
Q:'C
W !!,"Existing INDICATIONS FOR USE:"
F I=1:1:C W !,X(I)
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPOIMO 15934 printed Apr 09, 2024@21:32:55 Page 2
PSSPOIMO ;BIR/RTR/WRT - Edit Orderable Item Name and Inactive date ;Jun 23, 2020@13:14
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**29,32,38,47,68,102,125,141,153,159,166,172,191,189,204,210,225,242,256**;9/30/97;Build 2
+2 SET PSSITE=+$ORDER(^PS(59.7,0))
IF +$PIECE($GET(^PS(59.7,PSSITE,80)),"^",2)<2
WRITE !!?3,"Orderable Item Auto-Create has not been completed yet!",!
KILL PSSITE
KILL DIR
SET DIR("A")="Press RETURN to continue"
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+3 KILL PSSITE
WRITE !!,"This option enables you to edit Orderable Item names, Formulary status,",!,"drug text, Inactive Dates, Indications for Use, and Synonyms."
EN IF $DATA(PSOIEN)
LOCK -^PS(50.7,PSOIEN)
+1 KILL PSSCROSS,DTOUT,DUOUT,DIRUT
+2 ; S PY=$P($G(^PS(59.7,1,31)),"^",2)
KILL DIC
+3 SET PSS1="W "" ""_$P(^PS(50.606,$P(^PS(50.7,+Y,0),""^"",2),0),""^"")_"" ""_$S($P($G(^PS(50.7,+Y,0)),""^"",4):$E($P(^(0),""^"",4),4,5)_""-""_$E($P(^(0),""^"",4),6,7)_""-""_$E($P(^(0),""^"",4),2,3),1:"""")"
+4 SET PSS2=" S NF=$P($G(^PS(50.7,+Y,0)),""^"",12) I NF S NF="" N/F"" W NF"
+5 SET DIC("W")=PSS1_PSS2
SET DIC("S")="I '$P($G(^PS(50.7,+Y,0)),""^"",3)"
+6 ;PSO*7*102;ONLY SEARCH B AND C X-REFS
+7 SET $PIECE(PLINE,"-",79)=""
WRITE !!
KILL PSOUT
SET DIC="^PS(50.7,"
SET DIC(0)="QEAMZ"
SET D="B^C"
DO MIX^DIC1
KILL DIC,PY,D
if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
+8 SET PSOIEN=+Y
SET PSOINAME=$PIECE(Y,"^",2)
SET PSDOSE=+$PIECE(^PS(50.7,PSOIEN,0),"^",2)
LOCK +^PS(50.7,PSOIEN):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF '$TEST
WRITE !,$CHAR(7),"Another person is editing this one."
QUIT
+9 WRITE !!!,?5,"Orderable Item -> ",PSOINAME,!?5,"Dosage Form -> ",$PIECE($GET(^PS(50.606,PSDOSE,0)),"^"),!
+10 KILL DIR
SET DIR("?")=" "
SET DIR("?",1)="Enter 'Yes' to see all of the Dispense Drugs, IV Additives, and IV Solutions"
SET DIR("?",2)="that are matched to this Orderable Item. IV Additives will be identified with"
+11 SET DIR("?",3)="an (A), and IV Solutions with an (S)."
+12 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="List all Drugs/Additives/Solutions tied to this Orderable Item"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EN
+13 IF Y
DO DISP
EDIT KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to edit this Orderable Item"
SET DIR("B")="NO"
SET DIR("?")="Answer YES to edit the fields associated with this Orderable Item."
DO ^DIR
KILL DIR
IF 'Y!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EN
+1 WRITE !!?3,"Now editing Orderable Item:",!?3,PSOINAME," ",$PIECE($GET(^PS(50.606,PSDOSE,0)),"^")
DIR KILL DIR
SET DIR(0)="F^3:40"
SET DIR("B")=PSOINAME
SET DIR("A")="Orderable Item Name"
DO ^DIR
+1 IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
GOTO EN
+2 IF X[""""!($ASCII(X)=45)!('(X'?1P.E))!(X?2"z".E)
WRITE $CHAR(7),!!?5,"??"
GOTO DIR
+3 IF X'=PSOINAME
SET ZZFLAG=0
DO @$SELECT('$PIECE($GET(^PS(50.7,PSOIEN,0)),"^",3):"CHECK",1:"ZCHECK")
IF ZZFLAG
GOTO DIR
+4 SET PSONEW=X
SET DIE="^PS(50.7,"
SET DA=PSOIEN
SET DR=".01////"_X
DO ^DIE
IF PSONEW'=PSOINAME
WRITE !!,"Name changed from ",PSOINAME,!?15,"to ",PSONEW
+5 SET PSSDTENT=0
WRITE !
KILL DIE
NEW MFLG
SET PSBEFORE=$PIECE(^PS(50.7,PSOIEN,0),"^",4)
SET PSAFTER=0
SET PSINORDE=""
Begin DoDot:1
+6 ;If reactivate OI, prompt to reactivate DD's only if there are any, then always give message saying OI now Active. If Inactivate, prompt to inactivate any active DD's if there are any, and give message
+7 ;but if OI is reactivated, and there are no activities matched to it, and user does not want to activate the drugs, then inactivate the OI again, and give a clear message explaining this.
+8 WRITE !,"This Orderable Item is "_$SELECT($PIECE($GET(^PS(50.7,PSOIEN,0)),"^",12):"Non-Formulary.",1:"Formulary."),!
+9 IF $PIECE($GET(^PS(50.7,PSOIEN,0)),"^",10)
WRITE !,"This Orderable Item is marked as a Non-VA Med.",!
+10 SET DIE="^PS(50.7,"
SET DA=PSOIEN
SET DR=6
SET PSCREATE=1
DO ^DIE
KILL DIE,PSCREATE
IF $DATA(DTOUT)!($DATA(Y)>10)
QUIT
+11 ;PSS*1*102;ADD DRUG TEXT AS SYNONYM IS REQUESTED BY USER
+12 DO ADDSYN^PSSPOIMP
+13 KILL DIR
SET DIR(0)="DO"
SET DIR("A")="INACTIVE DATE"
Begin DoDot:2
+14 IF $GET(PSBEFORE)
SET Y=PSBEFORE
DO DD^%DT
SET DIR("B")=$GET(Y)
End DoDot:2
DO ^DIR
KILL DIR
IF $GET(Y)["^"!($DATA(DTOUT))!($GET(DUOUT))
QUIT
+15 IF $GET(PSBEFORE)
IF '$GET(Y)
WRITE ?40,"Inactive Date deleted!"
+16 SET PSSDTENT=$GET(Y)
IF $GET(Y)
DO DD^%DT
WRITE ?40,$GET(Y)
+17 SET PSSOTH=$SELECT($PIECE($GET(^PS(59.7,1,40.2)),"^"):1,1:0)
+18 SET DIE="^PS(50.7,"
SET DA=PSOIEN
NEW PSSFG,PSSOU
+19 ;*256
SET DR=".05;@1;D SETF^PSSPOIMO;.06;D DFR^PSSPOIMO(PSDOSE);10//YES;I X=""Y"" S Y=""@2"";D PDCHK^PSSPOIMO S:PSSFG Y=""@1"";"
Begin DoDot:2
+20 ;*191, *225, *256
SET DR=DR_"S:$G(DUOUT) Y=""@3"";@2;K DIE(""NO^""),DIRUT;D:'$G(DIRUT) MRSEL^PSSPOIMO;.07;.08;1;12//0;15;7;D LIND^PSSPOIMO;14;13;14.1T;14.2;S:'$G(PSSOTH) Y=""@3"";7.1;@3"
End DoDot:2
+21 SET PSCREATE=1
DO ^DIE
KILL DIE,PSCREATE,PSSOTH,^TMP("PSJMR",$JOB),^TMP("PSSDMR",$JOB)
IF $DATA(PSSOU)
IF '$GET(PSSOU)
if '$GET(DIRUT)
DO MRSEL
KILL ^TMP("PSJMR",$JOB)
+22 SET $PIECE(^PS(50.7,PSOIEN,0),"^",4)=PSSDTENT
SET PSAFTER=PSSDTENT
End DoDot:1
+23 if PSBEFORE&('$PIECE(^PS(50.7,PSOIEN,0),"^",4))
SET PSINORDE="D"
if $PIECE(^PS(50.7,PSOIEN,0),"^",4)
SET PSINORDE="I"
+24 IF PSINORDE'=""
DO CHECK^PSSPOID2(PSOIEN)
Begin DoDot:1
+25 IF PSINORDE="D"
Begin DoDot:2
+26 IF $ORDER(PSSDACTI(0))!($ORDER(PSSSACTI(0)))!($ORDER(PSSAACTI(0)))
Begin DoDot:3
+27 WRITE !!,"There are inactive "_$SELECT($ORDER(PSSDACTI(0)):"drugs, ",1:"")_$SELECT($ORDER(PSSAACTI(0)):"additives, ",1:"")_$SELECT($ORDER(PSSSACTI(0)):"solutions,",1:""),!,"matched to this Pharmacy Orderable Item."
End DoDot:3
End DoDot:2
QUIT
+28 IF $ORDER(PSSDACT(0))!($ORDER(PSSSACT(0)))!($ORDER(PSSAACT(0)))
Begin DoDot:2
+29 WRITE !!,"There are active "_$SELECT($ORDER(PSSDACT(0)):"drugs, ",1:"")_$SELECT($ORDER(PSSAACT(0)):"additives, ",1:"")_$SELECT($ORDER(PSSSACT(0)):"solutions,",1:""),!,"matched to this Pharmacy Orderable Item."
End DoDot:2
End DoDot:1
+30 IF $GET(PSINORDE)="D"
IF $ORDER(PSSDACTI(0))!($ORDER(PSSSACTI(0)))!($ORDER(PSSAACTI(0)))
DO REST^PSSPOIDT(PSOIEN)
+31 IF $GET(PSINORDE)="I"
IF $ORDER(PSSDACT(0))!($ORDER(PSSSACT(0)))!($ORDER(PSSAACT(0)))
DO REST^PSSPOIDT(PSOIEN)
+32 SET DIK="^PS(50.7,"
SET DA=PSOIEN
SET DIK(1)=.04
DO EN^DIK
KILL DIK
+33 KILL PSBEFORE,PSAFTER,PSINORDE,PSSDTENT,PSSDACT,PSSDACTI,PSSSACT,PSSSACTI,PSSAACT,PSSAACTI
+34 ;*256 - moving indications for use *204 and other lang *242 fields to DR string above
IMMUN ;PSS*1*141 FOR 'IMMUNIZATIONS DOCUMENTATION BY BCMA'
+1 ;ASK WHEN APPROPRIATE
IF $ORDER(^PSDRUG("AOC",PSOIEN,"IM000"))'["IM"
GOTO SYN
+2 WRITE !
SET DIE="^PS(50.7,"
SET DA=PSOIEN
SET DR=9
DO ^DIE
KILL DIE
SYN IF $GET(Y)["^"!($GET(DIRUT))!$DATA(DTOUT)!($DATA(Y)>10)
GOTO SYN1
+1 WRITE !
KILL DIC
if '$DATA(^PS(50.7,PSOIEN,2,0))
SET ^PS(50.7,PSOIEN,2,0)="^50.72^0^0"
SET DIC="^PS(50.7,"_PSOIEN_",2,"
SET DA(1)=PSOIEN
SET DIC(0)="QEAMZL"
SET DIC("A")="Select SYNONYM: "
SET DLAYGO=50.72
DO ^DIC
KILL DIC
+2 IF Y<0!($DATA(DUOUT))!($DATA(DTOUT))
if '$ORDER(^PS(50.7,PSOIEN,2,0))
KILL ^PS(50.7,PSOIEN,2,0)
DO EN^PSSPOIDT(PSOIEN)
DO EN2^PSSHL1(PSOIEN,"MUP")
GOTO EN
+3 WRITE !
SET DA=+Y
SET DIE="^PS(50.7,"_PSOIEN_",2,"
SET DA(1)=PSOIEN
SET DR=.01
DO ^DIE
KILL DIE
GOTO SYN
SYN1 ;File
+1 DO EN^PSSPOIDT(PSOIEN)
DO EN2^PSSHL1(PSOIEN,"MUP")
+2 GOTO EN
END KILL ZZFLAG,DIC,DIR,DIE,DTOUT,DUOUT,DIRUT,FLAG,PSOINAME,PSOUT,PSDOSE,PSONEW,UPFLAG,VV,ZZ,AA,BB,Y,AAA,SSS,PSOARR,PSOARRAD,PLINE
IF $DATA(PSOIEN)
LOCK -^PS(50.7,PSOIEN)
KILL PSOIEN
+1 QUIT
DISP NEW PSSLFLAG,PSSLDATE
SET FLAG=1
DO HEAD
FOR ZZ=0:0
SET ZZ=$ORDER(^PSDRUG("ASP",PSOIEN,ZZ))
if 'ZZ!($GET(PSOUT))
QUIT
SET FLAG=0
if ($Y+5)>IOSL
DO HEAD
if $GET(PSOUT)
QUIT
IF ZZ
WRITE !,$PIECE($GET(^PSDRUG(ZZ,0)),"^")
if $PIECE($GET(^PSDRUG(ZZ,0)),"^",9)
WRITE " N/F"
DO DTE
+1 if $GET(PSOUT)
QUIT
+2 SET (FLAG,PSSLFLAG)=0
+3 FOR ZZ=0:0
SET ZZ=$ORDER(^PS(52.6,"AOI",PSOIEN,ZZ))
if 'ZZ!($GET(PSOUT))
QUIT
if ($Y+5)>IOSL
DO HEAD
if $GET(PSOUT)
QUIT
IF ZZ
Begin DoDot:1
+4 SET PSSLFLAG=1
+5 WRITE !,$PIECE($GET(^PS(52.6,ZZ,0)),"^"),?31," (A) "
+6 WRITE ?40,"Additive Strength: ",$SELECT($$GET1^DIQ(52.6,ZZ,19)'="":$$GET1^DIQ(52.6,ZZ,19)_" "_$$GET1^DIQ(52.6,ZZ,2),1:"N/A")," "
+7 SET PSSLDATE=$PIECE($GET(^PS(52.6,ZZ,"I")),"^")
IF PSSLDATE
DO DTEX
End DoDot:1
+8 if $GET(PSOUT)
QUIT
+9 ;I $G(PSSLFLAG) W !
+10 FOR ZZ=0:0
SET ZZ=$ORDER(^PS(52.7,"AOI",PSOIEN,ZZ))
if 'ZZ!($GET(PSOUT))
QUIT
if ($Y+5)>IOSL
DO HEAD
if $GET(PSOUT)
QUIT
IF ZZ
Begin DoDot:1
+11 WRITE !,$PIECE($GET(^PS(52.7,ZZ,0)),"^"),?31,$PIECE($GET(^(0)),"^",3),?42,"(S)"
+12 SET PSSLDATE=$PIECE($GET(^PS(52.7,ZZ,"I")),"^")
IF PSSLDATE
DO DTEX
End DoDot:1
+13 QUIT
HEAD IF 'FLAG
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
IF 'Y
SET PSOUT=1
QUIT
+1 WRITE @IOF
WRITE !,?6,"Orderable Item -> ",PSOINAME,!?6,"Dosage Form -> ",$PIECE($GET(^PS(50.606,+$PIECE($GET(^PS(50.7,PSOIEN,0)),"^",2),0)),"^"),!!,"Dispense Drugs:"_$SELECT('FLAG:" (continued)",1:""),!,"---------------"
+2 QUIT
ADDIT ;If orderable item is flagged for IV
+1 SET AA=$ORDER(^PS(52.6,"AOI",PSOIEN,0))
+2 SET BB=$ORDER(^PS(52.7,"AOI",PSOIEN,0))
+3 IF 'AA
IF 'BB
WRITE $CHAR(7),!,"This Orderable Item is flagged for IV use, but currently there are no IV",!,"Additives or IV Solutions matched to this Orderable Item!"
GOTO EDIT
+4 GOTO SOL
CHECK ;
+1 SET ZZFLAG=0
FOR VV=0:0
SET VV=$ORDER(^PS(50.7,"ADF",X,PSDOSE,VV))
if 'VV
QUIT
IF VV
IF '$PIECE($GET(^PS(50.7,VV,0)),"^",3)
SET ZZFLAG=1
+2 IF ZZFLAG
WRITE $CHAR(7),!!?5,"There is already an Orderable Item with this same name and Dosage Form",!?5,"that is not flagged as 'IV'. Use the 'DISPENSE DRUG/ORDERABLE ITEM",!?5,"MAINTENANCE' option if you want to re-match to this Orderable Item!",
!
+3 QUIT
ZCHECK ;
+1 SET ZZFLAG=0
FOR VV=0:0
SET VV=$ORDER(^PS(50.7,"ADF",X,PSDOSE,VV))
if 'VV
QUIT
IF VV
IF $PIECE($GET(^PS(50.7,VV,0)),"^",3)
SET ZZFLAG=1
+2 IF ZZFLAG
WRITE $CHAR(7),!!?5,"There is already an Orderable Item with the same name and Dosage Form,",!?5,"that is flagged for 'IV' use.",!
+3 QUIT
SOL ;
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="List all Additives and Solutions tied to this Orderable Item"
DO ^DIR
KILL DIR
if Y["^"!($DATA(DTOUT))
GOTO EN
if Y=0
GOTO EDIT
+2 HANG 1
KILL PSOARR,PSOARRAD
SET AAA=$ORDER(^PS(52.6,"AOI",PSOIEN,0))
IF AAA
IF $DATA(^PS(52.6,AAA,0))
SET PSOARRAD=AAA
+3 FOR SSS=0:0
SET SSS=$ORDER(^PS(52.7,"AOI",PSOIEN,SSS))
if 'SSS
QUIT
if $DATA(^PS(52.7,SSS,0))
SET PSOARR(SSS)=""
+4 SET FLAG=1
SET UPFLAG=0
DO SHEAD
FOR ZZ=0:0
SET ZZ=$ORDER(PSOARR(ZZ))
if 'ZZ!($GET(PSOUT))!($GET(UPFLAG))
QUIT
SET FLAG=0
if ($Y+7)>IOSL
DO SHEAD
if $GET(PSOUT)!($GET(UPFLAG))
QUIT
IF ZZ
WRITE !,$PIECE($GET(^PS(52.7,ZZ,0)),"^")," ",$PIECE($GET(^(0)),"^",3)
+5 if $GET(PSOUT)
GOTO EN
+6 GOTO EDIT
SHEAD IF 'FLAG
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
IF 'Y
if Y=""
SET PSOUT=1
if Y=0
SET UPFLAG=1
QUIT
+1 WRITE @IOF
WRITE !?6,"Orderable Item -> ",PSOINAME,?68,"(IV)",!?6,"Dosage Form -> ",$PIECE($GET(^PS(50.606,+$PIECE($GET(^PS(50.7,PSOIEN,0)),"^",2),0)),"^"),!,PLINE
IF FLAG
IF '$GET(PSOARRAD)
WRITE !?5,"IV Solutions:",!
+2 IF 'FLAG
WRITE !?5,"IV Solutions:",!
+3 IF FLAG
IF $GET(PSOARRAD)
WRITE !,$PIECE($GET(^PS(52.6,PSOARRAD,0)),"^")," ","(IV Additive)",!
IF $DATA(PSOARR)
WRITE !?5,"IV Solutions:",!
+4 QUIT
DTE IF $DATA(^PSDRUG(ZZ,"I"))
SET Y=$PIECE(^PSDRUG(ZZ,"I"),"^")
DO DD^%DT
WRITE ?50,Y
KILL Y
+1 QUIT
DTEX SET Y=$GET(PSSLDATE)
DO DD^%DT
WRITE ?50,$GET(Y)
KILL Y
+1 QUIT
IVMSG ; display a message if the CORRESPONDING IV field is entered
+1 ;
+2 SET PSSIVMSG=$PIECE(^PS(50.7,PSOIEN,0),"^",11)
IF PSSIVMSG=""
QUIT
+3 SET PSSIVFRM=$PIECE(^PS(50.7,PSSIVMSG,0),"^",2)
IF PSSIVFRM
SET PSSIVFRM=$PIECE(^PS(50.606,PSSIVFRM,0),"^")
+4 SET PSSIVMSG=$PIECE(^PS(50.7,PSSIVMSG,0),"^")_" "_PSSIVFRM
+5 WRITE !!,"The Corresponding IV Item is currently identified as: "_PSSIVMSG,!
+6 KILL PSSIVFRM,PSSIVMSG
+7 QUIT
UDMSG ; display a message if the CORRESPONDING UD field is entered
+1 ;
+2 SET PSSUDMSG=$PIECE(^PS(50.7,PSOIEN,0),"^",10)
IF PSSUDMSG=""
QUIT
+3 SET PSSUDFRM=$PIECE(^PS(50.7,PSSUDMSG,0),"^",2)
IF PSSUDFRM
SET PSSUDFRM=$PIECE(^PS(50.606,PSSUDFRM,0),"^")
+4 SET PSSUDMSG=$PIECE(^PS(50.7,PSSUDMSG,0),"^")_" "_PSSUDFRM
+5 WRITE !!,"The Corresponding UD Item is currently identified as: "_PSSUDMSG,!
+6 KILL PSSUDMSG,PSSUDFRM
+7 QUIT
DFR(PSDOSE) ; dosage form med routes - called by DR string at DIR+20^PSSPOIMO
+1 DO SETF
+2 NEW MR,MRNODE,XX
KILL ^TMP("PSSDMR",$JOB)
+3 SET (MCT,MR)=0
FOR
SET MR=$ORDER(^PS(50.606,PSDOSE,"MR",MR))
if 'MR
QUIT
Begin DoDot:1
+4 SET XX=+$GET(^PS(50.606,PSDOSE,"MR",MR,0))
if 'XX
QUIT
SET MRNODE=$GET(^PS(51.2,XX,0))
IF $PIECE($GET(MRNODE),"^",4)'=1
QUIT
+5 SET MCT=MCT+1
SET ^TMP("PSSDMR",$JOB,MCT)=$PIECE(MRNODE,U)
SET ^TMP("PSSDMR",$JOB,"B",XX)=""
End DoDot:1
+6 DO DFRL
+7 QUIT
DFRL WRITE !!," List of med routes associated with the DOSAGE FORM of the orderable item:",!
+1 SET MCT=0
IF '$ORDER(^TMP("PSSDMR",$JOB,MCT))
WRITE !,?3,"NO MED ROUTE DEFINED"
+2 FOR
SET MCT=$ORDER(^TMP("PSSDMR",$JOB,MCT))
if 'MCT
QUIT
WRITE !,?3,$GET(^(MCT))
+3 DO EN^DDIOL(" If you answer YES to the next prompt, the DEFAULT MED ROUTE (if populated)",,"!!")
+4 DO EN^DDIOL(" and this list (if populated) will be displayed as selectable med routes",,"!")
+5 DO EN^DDIOL(" during medication ordering dialog. If you answer NO, the DEFAULT MED ROUTE",,"!")
+6 DO EN^DDIOL(" (if populated) and POSSIBLE MED ROUTES list will be displayed instead.",,"!")
WRITE !
+7 ;K ^TMP("PSSMR",$J)
+8 QUIT
PDR ; possible med routes - called by DR string at DIR+20^PSSPOIMO
+1 NEW MCT,MR,MRNODE,XX
KILL ^TMP("PSSMR",$JOB)
+2 SET (XX,MCT)=0
FOR
SET XX=$ORDER(^PS(50.7,$SELECT($GET(PSVAR):PSVAR,1:PSOIEN),3,"B",XX))
if 'XX
QUIT
SET MRNODE=$GET(^PS(51.2,XX,0))
SET MCT=MCT+1
SET ^TMP("PSSMR",$JOB,MCT)=$PIECE(MRNODE,U)
+3 IF $ORDER(^TMP("PSSMR",$JOB,0))
Begin DoDot:1
+4 WRITE !!," List of Possible Med Routes associated with the orderable item:",!
+5 SET MCT=0
FOR
SET MCT=$ORDER(^TMP("PSSMR",$JOB,MCT))
if 'MCT
QUIT
WRITE !,?3,$GET(^(MCT))
End DoDot:1
+6 WRITE !
KILL ^TMP("PSSMR",$JOB)
+7 QUIT
PDCHK ; called by DR string at DIR+20^PSSPOIMO
+1 NEW ANS,D,DIC,DIE,DO,DICR,DR,DIR,PSOUT,PSSDA,PSSX,PSSXA,PSSY,Q,X,Y,Z
+2 SET DIR(0)="PO^51.2:EMZ"
SET DIR("A")="POSSIBLE MED ROUTES"
SET DIR("S")="I $P(^(0),U,4)"
SET PSOUT=0
+3 SET DIR("PRE")="I X=""?"" D MRTHLP^PSSPOIMO"
+4 FOR
DO PDR
DO ^DIR
Begin DoDot:1
+5 IF (X="")!$DATA(DTOUT)!$DATA(DUOUT)
SET PSOUT=1
QUIT
+6 IF X="@"
IF $DATA(PSSY)
SET ANS=DA
if $$DASK
Begin DoDot:2
+7 NEW DIK,DA
SET DA(1)=ANS
SET DIK="^PS(50.7,"_DA(1)_",3,"
+8 SET DA=$ORDER(^PS(50.7,DA(1),3,"B",PSSY,""))
IF DA=""
QUIT
+9 DO ^DIK
KILL PSSY,DIR("B")
End DoDot:2
QUIT
+10 IF Y=""
WRITE " ??"
QUIT
+11 IF $DATA(^PS(50.7,DA,3,"B",+Y))
Begin DoDot:2
+12 IF $DATA(DIR("B"))
KILL PSSY,DIR("B")
QUIT
+13 SET DIR("B")=Y(0,0)
SET PSSY=+Y
QUIT
End DoDot:2
QUIT
+14 SET PSSXA=Y(0,0)
SET PSSX=+Y
DO DFR(+$PIECE(^PS(50.7,DA,0),"^",2))
+15 IF $GET(PSSX)
SET ANS=$$ASK()
IF 'ANS
QUIT
+16 SET PSSDA(50.711,"+1,"_DA_",",.01)=+PSSX
+17 DO UPDATE^DIE("","PSSDA")
+18 KILL ^TMP("PSSMR",$JOB)
End DoDot:1
IF PSOUT
QUIT
+19 DO DP
+20 QUIT
ASK() ; confirm adding the new entry
+1 NEW DIR,X,Y
WRITE !
SET DIR(0)="YO"
SET DIR("B")="YES"
+2 IF $DATA(^TMP("PSSDMR",$JOB))
IF '$DATA(^TMP("PSSDMR",$JOB,"B",PSSX))
SET DIR("B")="NO"
SET DIR("A",1)="The selected entry does not match to any of the dosage form med routes."
+3 WRITE $CHAR(7)
SET DIR("A")=" Are you adding '"_PSSXA_"' as a new POSSIBLE MED ROUTE"
DO ^DIR
+4 QUIT $SELECT(Y=1:1,1:0)
DASK() ; delete possible med route
+1 NEW DIR
+2 WRITE $CHAR(7)
SET DIR("A")=" SURE YOU WANT TO DELETE "
SET DIR(0)="Y"
DO ^DIR
+3 QUIT $SELECT(Y=1:1,1:0)
MRTHLP ; help of possible med route
+1 NEW DIC,RTE,D
+2 SET RTE=0
FOR
SET RTE=$ORDER(^PS(50.7,DA,3,"B",RTE))
if 'RTE
QUIT
DO EN^DDIOL($PIECE($GET(^PS(51.2,RTE,0)),"^"),,"!,?4")
+3 WRITE !
DO EN^DDIOL("Enter the most common MED ROUTE associated with this Orderable Item.",,"!,?5")
+4 DO EN^DDIOL("ONLY MED ROUTES MARKED FOR USE BY ALL PACKAGES ARE SELECTABLE.",,"!,?5")
+5 QUIT
DP ; check the existence of Default Med Route & Possible Med Routes
+1 NEW D,DIC,DIE,DO,DICR,DR,DIR,Q,X,Y,Z
+2 IF '$PIECE($GET(^PS(50.7,$SELECT($GET(PSVAR):PSVAR,1:PSOIEN),0)),"^",6)&('$ORDER(^PS(50.7,$SELECT($GET(PSVAR):PSVAR,1:PSOIEN),3,0)))
Begin DoDot:1
+3 SET PSR(1)=" You have not selected ANY med routes to display during order entry. In"
+4 SET PSR(2)=" order to have med routes displayed during order entry, you must either"
+5 SET PSR(3)=" define a DEFAULT MED ROUTE and/or at least one POSSIBLE MED ROUTE, or"
+6 SET PSR(4)=" answer YES to the USE DOSAGE FORM MED ROUTE LIST prompt."
+7 SET PSR(5)=" **WITH THE CURRENT SETTINGS, NO MED ROUTES WILL DISPLAY FOR SELECTION "
SET PSR(5,"F")="!!"
+8 SET PSR(6)=" DURING ORDER ENTRY FOR THIS ORDERABLE ITEM**"
+9 DO EN^DDIOL(.PSR)
DO EN^DDIOL(" ","","!")
+10 KILL DIR
SET DIR(0)="Y"
SET DIR("?",1)="If you select NO, you will continue to loop back to the Default Med Route"
+11 SET DIR("?")="prompt until either a selection is made or you answer YES to this prompt to proceed."
+12 SET DIR("A",1)=""
SET DIR("A",2)="The current setting is usually only appropriate for supply items."
+13 SET DIR("A")="Continue with NO med route displaying for selection during order entry"
SET DIR("B")="NO"
+14 DO ^DIR
KILL DIR
WRITE !
IF 'Y!($DATA(DTOUT))!($DATA(DUOUT))
SET PSSFG=1
+15 if Y
SET PSSFG=0
End DoDot:1
+16 IF '$TEST
SET PSSFG=0
+17 QUIT
+18 ;
SETF ;
+1 SET PSSOU=0
KILL ^TMP("PSJMR",$JOB)
DO MEDRT^PSSJORDF($SELECT($GET(PSVAR):PSVAR,1:PSOIEN))
+2 IF '$DATA(^TMP("PSJMR",$JOB))
SET DIE("NO^")=""
SET PSSFG=1
+3 IF '$TEST
SET PSSFG=0
KILL DIE("NO^")
+4 QUIT
MRSEL ;
+1 KILL ^TMP("PSJMR",$JOB)
DO MEDRT^PSSJORDF($SELECT($GET(PSVAR):PSVAR,1:PSOIEN))
+2 WRITE !,"The following Med Routes will now be displayed during order entry:"
+3 NEW I
SET (PSSOU,I)=0
FOR
SET I=$ORDER(^TMP("PSJMR",$JOB,I))
if 'I
QUIT
WRITE !,$PIECE(^(I),"^",2)
SET PSSOU=1
+4 if 'PSSOU
WRITE !,"(None)"
+5 WRITE !
SET PSSOU=1
+6 QUIT
+7 ;
LIND ;*242
+1 NEW X,Y,C,I,J,K,L,M
SET C=0
SET Y=$PIECE($GET(^PS(50.7,DA,4)),"^",2)
SET L=" *MOST COMMON"
SET M="<OTHER LANGUAGE>"
+2 if Y]""
SET X(1)=Y_L
SET C=1
+3 SET I=""
FOR
SET I=$ORDER(^PS(50.7,DA,"IND","B",I))
if I=""
QUIT
Begin DoDot:1
+4 SET J=$ORDER(^PS(50.7,DA,"IND","B",I,0))
if 'J
QUIT
SET K=$PIECE($GET(^PS(50.7,DA,"IND",J,0)),U)
+5 if K]""
SET C=C+1
SET X(C)=K
End DoDot:1
+6 SET Y=$PIECE($GET(^PS(50.7,DA,4)),"^",4)
+7 if Y]""
SET C=C+1
SET X(C)=Y_L_" "_M
+8 SET I=""
FOR
SET I=$ORDER(^PS(50.7,DA,"INDO","B",I))
if I=""
QUIT
Begin DoDot:1
+9 SET J=$ORDER(^PS(50.7,DA,"INDO","B",I,0))
if 'J
QUIT
SET K=$PIECE($GET(^PS(50.7,DA,"INDO",J,0)),U)
+10 if K]""
SET C=C+1
SET X(C)=K_" "_M
End DoDot:1
+11 if 'C
QUIT
+12 WRITE !!,"Existing INDICATIONS FOR USE:"
+13 FOR I=1:1:C
WRITE !,X(I)
+14 WRITE !
+15 QUIT
