PSJUTL ;BIR/MLM - MISC. INPATIENT UTILITIES ; 10/7/08 1:22pm
;;5.0;INPATIENT MEDICATIONS;**9,47,58,80,110,136,157,177,134,179,267,349,361,416,434**;16 DEC 97;Build 3
;
; Reference to ^DIC(42 is supported by DBIA 10039.
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PSDRUG( is supported by DBIA 2192.
; Reference to ^DIC is supported by DBIA 10006.
; Reference to ^DIC1 is supported by DBIA 10007.
; Reference to ^DIR is supported by DBIA 10026.
; Reference to ^VALM1 is supported by DBIA 10116.
;
ENDL ; device look-up
N DA,DIC,DIE,DIX,DO,DR
S DIC="^%ZIS(1,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q
S X=Y(0,0)
Q
;
ENDH(X) ; device help
N D,XQH,DA,DIC,DIE,DO,DR,DZ
S DIC="^%ZIS(1,",DIC(0)="EIM" D DO^DIC1,^DIC
Q
;
READ ; hold screen
I $D(IOST) Q:$E(IOST)'="C"
W ! I $D(IOSL),$Y<(IOSL-4) G READ
W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300)
Q
;
ENOISC(PSJOI,USAGE) ;Set DIC("S") so that only Orderable Items with at
;least 1 active dispense drug for the specified usage.
;Input: PSJOI IEN of Orderable Item selected
; USAGE - Type of drugs (UD,IV,etc) to be selected
;Output: 1-At least one dispense drug found
; 0-None found
N FOUND,PSJ
S PSJ=$P($G(^PS(50.7,+PSJOI,0)),U,4),FOUND=$S('PSJ:1,PSJ>DT:1,1:0)
I FOUND S FOUND=0 F PSJ=0:0 S PSJ=$O(^PSDRUG("ASP",PSJOI,PSJ)) Q:FOUND!'PSJ I $P($G(^PSDRUG(PSJ,2)),U,3)[USAGE,'$G(^("I"))!($G(^("I"))'<DT) S FOUND=1
Q FOUND
;
AADR ; display allergies and adverse reactions
D ATS^PSJMUTL(60,50,1) N A,B
I (PSGALG=0)&(PSGADR=0) W !!,"No allergies or ADRs on file."
I PSGALG'=0 W !!,"Allergies: " S B="PSGALG" F S A=$Q(@B) Q:A="" W ?12,$G(@A),! S B=A
I PSGADR'=0 W !," ADR: " S B="PSGADR" F S A=$Q(@B) Q:A="" W ?12,$G(@A),! S B=A
D READ K PSGALG,PSGADR Q
;
ENALU ; application look-up
N PSJ S PSJ=DA(1) N DA,DIC,DIE,DIX,DO,DR S DIC="^PS(50.35,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q
S X=$P(Y(0),"^",2) K:$S(X="":1,1:$D(^PS(50.3,PSJ,1,"B",X))) X
Q
;
ENAQ ; application query
S X=DZ N D,DA,DIC,DIE,DO,DR,DZ,XQH S DIC="^PS(50.35,",DIC(0)="EIMQ" D DO^DIC1,^DIC
Q
;
ENPCL(PSJTYP,PSGP,PSJORD) ; Copy Provider Comments -> Special Instructions.
Q:'$G(PSJORD) ""
Q:'$D(^PS(53.1,+$G(PSJORD),12,1,0)) ""
; Count number of lines minus blank trailing lines
N LN,LNCNT S LNCNT=0,LN=9999 F S LN=$O(^PS(53.1,+$G(PSJORD),12,LN),-1) Q:'LN D
.I 'LNCNT,($G(^PS(53.1,+$G(PSJORD),12,LN,0))="") Q
.S LNCNT=LNCNT+1
I 'LNCNT Q ""
K ^PS(53.45,+$G(PSJSYSP),5),^PS(53.45,+$G(PSJSYSP),6)
N DIR,X,Y,PSJSAVY S (X,Y)="" F S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X S Y=$G(^PS(53.1,+$G(PSJORD),12,X)) S:($G(PSJTYP)'="V") Y=$$ENSET^PSGSICHK(Y) S ^PS(53.45,+$G(PSJSYSP),5,X,0)=Y
W !,"PROVIDER COMMENTS: "
;Display Provider Comments Prior to Asking the Copy Provider Comments Question;BHW;PSJ*5*136
N PSJTMP S PSJTMP=0
F S PSJTMP=$O(^PS(53.1,+$G(PSJORD),12,PSJTMP)) Q:'PSJTMP W !,^PS(53.1,+$G(PSJORD),12,PSJTMP,0)
S PSGSI=Y W ! S DIR(0)="S^Y:Yes (copy);N:No (don't copy);!:Copy and flag for display in a BCMA Message Box;E:Copy and Edit;"
S DIR("A")="Copy the Provider Comments into "_$$ENFIELD(PSJTYP)_" (Yes/No/!/E)",DIR("??")="^D ENPCHLP1^PSJUTL(PSJTYP)" D ^DIR S PSJSAVY=Y
S PSGSI=$S(PSJSAVY="Y":$P(PSGSI,"^"),PSJSAVY="!":$P(PSGSI,"^")_"^1",PSJSAVY="E":$P(PSGSI,"^"),1:"")
I PSJSAVY="Y"!(PSJSAVY="E")!(PSJSAVY="!") D
.I ($G(PSJTYP)="V") N OPILN S OPILN=$O(^PS(53.1,+$G(PSJORD),12," "),-1) N TXT,OPIMSG,PSJTMPTX,PSJOVRMX S OPIMSG="Instructions too long. See Order View or BCMA for full text." D
..S PSJTMPTX="",PSJOVRMX=0 S TMPLIN=0 F S TMPLIN=$O(^PS(53.1,+PSJORD,12,TMPLIN)) Q:'TMPLIN!(PSJOVRMX) D
...S:($L(PSJTMPTX)+$L($G(^PS(53.1,+PSJORD,12,TMPLIN,0))))>60 PSJOVRMX=1 Q:$G(PSJOVRMX) S PSJTMPTX=$G(PSJTMPTX)_$S($G(PSJTMPTX)]"":" ",1:"")_$G(^PS(53.1,+PSJORD,12,TMPLIN,0))
..S PSGSI=$S(PSJTMPTX]"":PSJTMPTX,1:OPIMSG) I $G(PSJOVRMX),(PSJSAVY'="E") D OPIWARN^PSJBCMA5(1)
.S PSGSI=$S(PSJSAVY="!":$P($$PUT5345(PSGORD),"^")_"^1",1:$P($$PUT5345(PSGORD),"^"))
I PSJSAVY="E" K ^PS(53.45,+$G(PSJSYSP),5),^PS(53.45,+$G(PSJSYSP),6) D
.N PRVCLN,X S PRVCLN=$O(^PS(53.1,+$G(PSJORD),12,""),-1)
.S:($G(PSJTYP)["V") ^PS(53.45,+$G(PSJSYSP),6,0)="^53.1136^"_+$G(PRVCLN)_"^"_+$G(PRVCLN)_"^"_1
.S:($G(PSJTYP)'["V") ^PS(53.45,+$G(PSJSYSP),5,0)="^53.1135^"_+$G(PRVCLN)_"^"_+$G(PRVCLN)_"^"_1
.S X=0 F S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X S Y=$G(^PS(53.1,+$G(PSJORD),12,X,0)) S:($G(PSJTYP)'="V") Y=$$ENSET^PSGSICHK(Y) S ^PS(53.45,+$G(PSJSYSP),$S($G(PSJTYP)="V":6,1:5),X,0)=Y
.D:PSJTYP="V" EDITOPI^PSJBCMA5(PSGP,PSJORD) D:PSJTYP'="V" EDITSI^PSJBCMA5(PSGP,PSJORD)
I PSJSAVY="E" S PSGSI=$$ENBCMA(PSJTYP)
Q PSGSI
;
ENPC(PSJTYP,PSJSYSP,LEN,TEXT) ; Copy Provider Comments -> Special Instructions.
S PSGSI=$$ENPCL(PSJTYP,$G(PSGP),$G(PSGORD))
Q PSGSI
;
REDISP ; Redisplay Provider Comments and allow entry of Spec. Instructions.
D CLEAR^VALM1 F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X W ^(X,0),!
W !! S PSGSI=""
D:PSJTYP'="V" 8^PSGOE81
I PSJTYP="V" D 64^PSIVEDT1 S PSGSI=P("OPI")
Q
;
ENPCHLP1(Y) ; Display help messages for Provider Comment copy.
W !,"Enter ""YES"" to copy Provider Comments into the ",$$ENFIELD(Y)," field",!,"or ""NO"" to bypass",!,"or ""!"" to copy the Provider Comments into the ",$$ENFIELD(PSJTYP)," field",!,"and flag them for display in a BCMA Message Box"
W !,"or type ""E"" to copy the Provider Comments into the ",$$ENFIELD(PSJTYP)," field and open a word processing window for editing."
Q
ENPCHLP2(Y,X) ;
W !,"The Provider Comments entered for this order are longer than the space available",!,"in the ",$$ENFIELD(Y)," field.",!!,"Enter ""YES"" to copy the first ",X-3," characters into the ",$$ENFIELD(Y),!,"field, or ""NO"" to continue.",!!
Q
ENBCMA(PSJTYP) ;
N DIR,X,Y
I $G(PSJTYP)="V" Q:'$L($G(^PS(53.45,+$G(PSJSYSP),6,0))) ""
I $G(PSJTYP)="U" Q:'$L($G(^PS(53.45,+$G(PSJSYSP),5,0))) ""
W !!,"Would you like to flag the ",$$ENFIELD(PSJTYP)," field for display in a BCMA",!,"Message box?"
W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Flag the "_$$ENFIELD(PSJTYP)_" (Yes/No)" D ^DIR I X="^" S DONE=1 ;P434 added quit
K PSJCOMSI I $G(PSJCOM),$G(PSJORD)'["P" N TEXT S TEXT=$S(PSJTYP="U":$G(PSGSI),1:$G(P("OPI"))) S PSJCOMSI=$$COMSI(PSJCOM,TEXT)
Q:Y="Y" $S($G(PSJTYP)="U":$P(PSGSI,"^")_"^1",1:$P(P("OPI"),"^")_"^1")
Q $S(PSJTYP="U":PSGSI,1:P("OPI"))
ENFIELD(Y) ;
Q $S(Y="V":"Other Print Info",1:"Special Instructions")
;
COMSI(PARENT,INSTR) ;
N DIR,X,Y
W !!!!?15,"** WARNING **",!?5,"This order is part of a complex order."
W !!,"Would you like to copy the ",$$ENFIELD(PSJTYP)
W !,"to the other orders in the complex order?"
S DIR(0)="S^Y:Yes;N:No",DIR("A")=" Copy the "_$$ENFIELD(PSJTYP)_" (Yes/No)" D ^DIR
Q:Y="Y" 1
Q 0
;
ENORL(X) ; Return patient's location as variable ptr.
Q $S(+$G(^DIC(42,+X,44)):+$G(^(44))_";SC(",$D(^DIC(42,+X,0)):+X_";DIC(42,",1:"")
;
ENMARD() ; validate MAR SELECTION DEFAULT string in WARD PARMS file.
N PSJANS,PSJX1,PSJX2,RANGE,Q
S RANGE="1:6" F PSJX1=1:1:6 S RANGE(PSJX1)=""
S:$E(X)="-" X=+RANGE_X S:$E($L(X))="-" X=X_$P(RANGE,":",2)
S PSJANS="" F Q=1:1:$L(X,",") S PSJX1=$P(X,",",Q) D FS Q:'$D(PSJANS)
Q:'$G(PSJANS) 0
S PSJANS=$E(PSJANS,1,$L(PSJANS)-1) F Q=1:1:$L(PSJANS,",") D Q:'$D(PSJANS)
.I $P(PSJANS,",",Q)=1,$L(PSJANS,",")>1 W !!,"All Medications (1) may not be selected in combination with other types." K PSJANS Q
.W ?47,$P(PSJANS,",",Q)," - ",$P($T(@$P(PSJANS,",",Q)),";;",2),!
S:$G(PSJANS) X=PSJANS Q $G(PSJANS)
;
FS ;
I $S(PSJX1?1.N1"-"1.N:0,PSJX1'?1.N:1,'$D(RANGE(PSJX1)):1,1:","_PSJANS[PSJX1) K PSJANS Q
I PSJX1'["-" S PSJANS=PSJANS_PSJX1_"," Q
S PSJX2=+PSJX1,PSJANS=PSJANS_PSJX2_","
F S PSJX2=$O(RANGE(PSJX2)) K:$S(X="":1,","_PSJANS[PSJX2:1,1:PSJX2>$P(PSJX1,"-",2)) PSJANS Q:'$D(PSJANS) S PSJANS=PSJANS_PSJX2_"," Q:PSJX2=$P(PSJX1,"-",2)
Q
;
ENMARDH ;Help text for MAR default answer.
W !!?2,"Enter the number corresponding to the type of orders to be included on MARs",!,"printed for this ward. Multiple types (except 1) may be selected using ""-""",!,"or "","" as delimiters.",!!,"Choose from: ",!
N X F X=1:1:6 W !?13,X," - ",$P($T(@X),";;",2)
W !
Q
1 ;;All Medications
2 ;;Non-IV Medications only
3 ;;IV Piggybacks
4 ;;LVPs
5 ;;TPNs
6 ;;Chemotherapy Medications (IV)
;
EFD ;The following EFD Tags are used to Calculate the Expected First Dose for backdoor
;orders. The call to $$ENQ^PSJORP2 is used to actually perform the calculation.
;The program $$ENQ^PSJORP2 requires the variable INFO to equal the following:
;BHW;PSJ*5*136
; INFO (piece 1) = START DATE/TIME ;PSGNESD (NEW ORDER)
; INFO (piece 2) = STOP DATE/TIME ;PSGNEFD (NEW ORDER)
; INFO (piece 3) = SCHEDULE ;PSGSCH (NEW ORDER)
; INFO (piece 4) = SCHEDULE TYPE ;PSGST (NEW ORDER)
; INFO (piece 5) = ORDERABLE ITEM ;PSGDRG (NEW ORDER)
; INFO (piece 6) = ADMIN TIMES ;PSGS0Y (NEW ORDER)
;
EFDNEW ;Call Here if NEW or RENEWED Order
N INFO
S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
D EFDDISP
QUIT
EFDACT ;Call here if Editing Fields for an ACTIVE order
; Field 10 = Start Date
; Field 34 = Stop Date
; Field 41 = Admin Times
N INFO,KEY,ORDER,LAST
;Loop Fields to be edited, in order, and determine when to Display expected first dose message
F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER) I "10^34^41"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1)
;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
S LAST=$O(ORDER(99),-1) Q:'LAST
;BHW;PSJ*5*179;Remove "Display Once" logic.
;S LAST=ORDER(LAST)
;I LAST'=PSGF2 Q
S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
S PSGEFDMG="Next Dose Due"
D EFDDISP
QUIT
EFDNV ;Call here if Editing Fields for a NON-VERIFIED order
; Field 10 = Start Date
; Field 25 = Stop Date
; Field 39 = Admin Times
N INFO,KEY,ORDER,LAST
;Check if called during finish process
I '$D(PSGOEER) D D EFDDISP Q
. S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
. Q
;Loop Fields to be edited, in order, and determine when to Display expected first dose message
F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER) I "10^25^39"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1)
;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
S LAST=$O(ORDER(99),-1) Q:'LAST
;Only display EFD once, so Quit if this call is not for the Last field in the Edit
S LAST=ORDER(LAST)
I LAST'=PSGF2 Q
S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
D EFDDISP
QUIT
EFDIV(PSGZZND) ;Set variables for EFD on IV orders.
I $G(PSGZZND)="" D
.N X,ZZND,LYN,PSGS0XT,PSGS0Y,PSGOES S PSGOES=1 S X=P(9) D EN^PSGS0 S:$G(ZZND)'="" PSGZZND=ZZND
S PSGNESD=P(2),PSGNEFD=P(3),PSGSCH=P(9),PSGST=$P($G(PSGZZND),"^",5),PSGDRG=$P($G(P("PD")),"^"),PSGS0Y=P(11)
;BHW - PSJ*5*177 Add call to check stop date. If it's in the past, Display Message
D CHKSTOP
D EFDNEW
W !
Q
EFDDISP ;Display Expected First Dose
N Y,Z
Q:$G(PSGST)="OC"!($G(PSGST)="P")!($G(PSGST)="O")
Q:$G(PSGSCH)["ON CALL"!($G(PSGSCH)["ON-CALL")!($G(PSGSCH)["ONCALL")
Q:$G(PSGSCH)["PRN"
I '$L($G(PSGP)) N PSGP S PSGP=""
S Y=$$ENQ^PSJORP2(PSGP,INFO)
I 'Y S Y="Unable to Calculate"
X ^DD("DD")
;BHW;PSJ*5*179;Add Variable Message. "Next Dose Due". Default to "Expected First Dose"
I '$D(PSGEFDMG) S PSGEFDMG="Expected First Dose"
W !,PSGEFDMG,": ",Y H 3
K PSGEFDMG
Q
CHKSTOP ;BHW - PSJ*5*177 Warn user if the Stop Date is < now.
I '+$G(P(3)) Q
N PSNOW,%,%H,%I,X D NOW^%DTC S PSNOW=%
I +P(3)<PSNOW D Q
. W !,$C(7),"The Stop Date/Time is in the Past!!! This order will",!,"automatically EXPIRE upon Verification!!",!
. Q
Q
;
PUT5345(PSGORD) ; Get text from provider comments, place into temp storage
Q:'$D(^PS(53.1,+PSGORD,12)) ""
N PSJTMPTX,PSJOVRMX,TMPLIN,SIMSG
N LN,TXT,LNCNT S TXT="",LN=0 F LNCNT=0:1 S LN=$O(^PS(53.1,+PSGORD,12,LN)) Q:'LN D
.S TXT=$G(^PS(53.1,+PSGORD,12,LN,0)) S ^PS(53.45,+PSJSYSP,$S($G(PSJTYP)="U":5,$G(PSJTYP)="V":6,1:5),LN,0)=TXT
I $G(LNCNT) N PSJFIREF S PSJFIREF="^PS(53.45,"_+PSJSYSP_","_$S($G(PSJTYP)="U":5,$G(PSJTYP)="V":6,1:5)_"," D ENSI(PSJFIREF)
I $G(LNCNT) S ^PS(53.45,+PSJSYSP,$S(($G(PSJTYP)="V"):6,1:5),0)="^^"_LNCNT_"^"_LNCNT
N DIE,DA
S SIMSG="Instructions too long. See Order View or BCMA for full text."
S PSJTMPTX="",PSJOVRMX=0 S TMPLIN=0 F S TMPLIN=$O(^PS(53.45,+PSJSYSP,$S($G(PSJTYP)="V":6,1:5),TMPLIN)) Q:'TMPLIN!(PSJOVRMX) D
.S:($L(PSJTMPTX)+$L($G(^PS(53.45,+PSJSYSP,$S($G(PSJTYP)="V":6,1:5),TMPLIN,0))))>$S($G(PSJTYP)["V":60,1:180) PSJOVRMX=1
.Q:$G(PSJOVRMX) S PSJTMPTX=$G(PSJTMPTX)_$S($G(PSJTMPTX)]"":" ",1:"")_$G(^PS(53.45,+PSJSYSP,$S($G(PSJTYP)="V":6,1:5),TMPLIN,0))
S TXT=$S(PSJOVRMX:SIMSG,1:PSJTMPTX)
Q TXT
;
ENSI(PSJSIFIL) ; Expand comments using MEDICATIONS INSTRUCTIONS file (#51)
N X,PSJTMPFI,PSJTMPLI,DONE,PSJNWTXT,TOLIN,II,PSJSITXT,FULL,OLD,I S PSJTMPFI=PSJSIFIL_"1)" Q:'$D(@PSJTMPFI)
K ^TMP("PSGSIL",$J)
F I=1:1 Q:$G(DONE) S PSJTMPFI=PSJSIFIL_I_",0)" S DONE=$D(@PSJTMPFI) S DONE=$S(DONE:0,1:1) D
.S PSJTMPLI=$G(@PSJTMPFI) I ($TR(PSJTMPLI," ")'="") D TXT^PSGMUTL($$ENSISET(PSJTMPLI),74)
.I ($TR(PSJTMPLI," ")="") S MARX(1)=PSJTMPLI
.S II="" F S II=$O(MARX(II)) Q:'II S TOLIN=+$O(^TMP("PSGSIL",$J,+$G(PSJSYSP),""),-1) D
..S ^TMP("PSGSIL",$J,+$G(PSJSYSP),TOLIN+1)=MARX(II) Q
S I="" I $O(^TMP("PSGSIL",$J,+$G(PSJSYSP),0)) K ^PS(53.45,+$G(PSJSYSP),5) S TOLIN="" F I=0:1 S TOLIN=$O(^TMP("PSGSIL",$J,+$G(PSJSYSP),TOLIN)) Q:TOLIN="" D
.S ^PS(53.45,+$G(PSJSYSP),5,TOLIN,0)=^TMP("PSGSIL",$J,+$G(PSJSYSP),TOLIN)
S I=$O(^PS(53.45,+$G(PSJSYSP),5,""),-1),^PS(53.45,+$G(PSJSYSP),5,0)="^55.6135^"_I_"^"_I_"^"_$P($G(PSGDT),".")
K ^TMP("PSGSIL",$J)
Q
;
ENSISET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
N X1,X2,Y S Y=""
;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
; ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D
. I X2']"" S Y=Y_" " Q ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue
. S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
. Q
;BHW;Modified stripping of spaces at end of string
F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" " S Y=$E(Y,1,X1-1)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJUTL 14725 printed Oct 16, 2024@18:09:56 Page 2
PSJUTL ;BIR/MLM - MISC. INPATIENT UTILITIES ; 10/7/08 1:22pm
+1 ;;5.0;INPATIENT MEDICATIONS;**9,47,58,80,110,136,157,177,134,179,267,349,361,416,434**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ^DIC(42 is supported by DBIA 10039.
+4 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+5 ; Reference to ^PSDRUG( is supported by DBIA 2192.
+6 ; Reference to ^DIC is supported by DBIA 10006.
+7 ; Reference to ^DIC1 is supported by DBIA 10007.
+8 ; Reference to ^DIR is supported by DBIA 10026.
+9 ; Reference to ^VALM1 is supported by DBIA 10116.
+10 ;
ENDL ; device look-up
+1 NEW DA,DIC,DIE,DIX,DO,DR
+2 SET DIC="^%ZIS(1,"
SET DIC(0)="EIMZ"
DO DO^DIC1
DO ^DIC
IF Y'>0
KILL X
QUIT
+3 SET X=Y(0,0)
+4 QUIT
+5 ;
ENDH(X) ; device help
+1 NEW D,XQH,DA,DIC,DIE,DO,DR,DZ
+2 SET DIC="^%ZIS(1,"
SET DIC(0)="EIM"
DO DO^DIC1
DO ^DIC
+3 QUIT
+4 ;
READ ; hold screen
+1 IF $DATA(IOST)
if $EXTRACT(IOST)'="C"
QUIT
+2 WRITE !
IF $DATA(IOSL)
IF $Y<(IOSL-4)
GOTO READ
+3 WRITE !?5,"Press return to continue "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
+4 QUIT
+5 ;
ENOISC(PSJOI,USAGE) ;Set DIC("S") so that only Orderable Items with at
+1 ;least 1 active dispense drug for the specified usage.
+2 ;Input: PSJOI IEN of Orderable Item selected
+3 ; USAGE - Type of drugs (UD,IV,etc) to be selected
+4 ;Output: 1-At least one dispense drug found
+5 ; 0-None found
+6 NEW FOUND,PSJ
+7 SET PSJ=$PIECE($GET(^PS(50.7,+PSJOI,0)),U,4)
SET FOUND=$SELECT('PSJ:1,PSJ>DT:1,1:0)
+8 IF FOUND
SET FOUND=0
FOR PSJ=0:0
SET PSJ=$ORDER(^PSDRUG("ASP",PSJOI,PSJ))
if FOUND!'PSJ
QUIT
IF $PIECE($GET(^PSDRUG(PSJ,2)),U,3)[USAGE
IF '$GET(^("I"))!($GET(^("I"))'<DT)
SET FOUND=1
+9 QUIT FOUND
+10 ;
AADR ; display allergies and adverse reactions
+1 DO ATS^PSJMUTL(60,50,1)
NEW A,B
+2 IF (PSGALG=0)&(PSGADR=0)
WRITE !!,"No allergies or ADRs on file."
+3 IF PSGALG'=0
WRITE !!,"Allergies: "
SET B="PSGALG"
FOR
SET A=$QUERY(@B)
if A=""
QUIT
WRITE ?12,$GET(@A),!
SET B=A
+4 IF PSGADR'=0
WRITE !," ADR: "
SET B="PSGADR"
FOR
SET A=$QUERY(@B)
if A=""
QUIT
WRITE ?12,$GET(@A),!
SET B=A
+5 DO READ
KILL PSGALG,PSGADR
QUIT
+6 ;
ENALU ; application look-up
+1 NEW PSJ
SET PSJ=DA(1)
NEW DA,DIC,DIE,DIX,DO,DR
SET DIC="^PS(50.35,"
SET DIC(0)="EIMZ"
DO DO^DIC1
DO ^DIC
IF Y'>0
KILL X
QUIT
+2 SET X=$PIECE(Y(0),"^",2)
if $SELECT(X=""
KILL X
+3 QUIT
+4 ;
ENAQ ; application query
+1 SET X=DZ
NEW D,DA,DIC,DIE,DO,DR,DZ,XQH
SET DIC="^PS(50.35,"
SET DIC(0)="EIMQ"
DO DO^DIC1
DO ^DIC
+2 QUIT
+3 ;
ENPCL(PSJTYP,PSGP,PSJORD) ; Copy Provider Comments -> Special Instructions.
+1 if '$GET(PSJORD)
QUIT ""
+2 if '$DATA(^PS(53.1,+$GET(PSJORD),12,1,0))
QUIT ""
+3 ; Count number of lines minus blank trailing lines
+4 NEW LN,LNCNT
SET LNCNT=0
SET LN=9999
FOR
SET LN=$ORDER(^PS(53.1,+$GET(PSJORD),12,LN),-1)
if 'LN
QUIT
Begin DoDot:1
+5 IF 'LNCNT
IF ($GET(^PS(53.1,+$GET(PSJORD),12,LN,0))="")
QUIT
+6 SET LNCNT=LNCNT+1
End DoDot:1
+7 IF 'LNCNT
QUIT ""
+8 KILL ^PS(53.45,+$GET(PSJSYSP),5),^PS(53.45,+$GET(PSJSYSP),6)
+9 NEW DIR,X,Y,PSJSAVY
SET (X,Y)=""
FOR
SET X=$ORDER(^PS(53.1,+$GET(PSJORD),12,X))
if 'X
QUIT
SET Y=$GET(^PS(53.1,+$GET(PSJORD),12,X))
if ($GET(PSJTYP)'="V")
SET Y=$$ENSET^PSGSICHK(Y)
SET ^PS(53.45,+$GET(PSJSYSP),5,X,0)=Y
+10 WRITE !,"PROVIDER COMMENTS: "
+11 ;Display Provider Comments Prior to Asking the Copy Provider Comments Question;BHW;PSJ*5*136
+12 NEW PSJTMP
SET PSJTMP=0
+13 FOR
SET PSJTMP=$ORDER(^PS(53.1,+$GET(PSJORD),12,PSJTMP))
if 'PSJTMP
QUIT
WRITE !,^PS(53.1,+$GET(PSJORD),12,PSJTMP,0)
+14 SET PSGSI=Y
WRITE !
SET DIR(0)="S^Y:Yes (copy);N:No (don't copy);!:Copy and flag for display in a BCMA Message Box;E:Copy and Edit;"
+15 SET DIR("A")="Copy the Provider Comments into "_$$ENFIELD(PSJTYP)_" (Yes/No/!/E)"
SET DIR("??")="^D ENPCHLP1^PSJUTL(PSJTYP)"
DO ^DIR
SET PSJSAVY=Y
+16 SET PSGSI=$SELECT(PSJSAVY="Y":$PIECE(PSGSI,"^"),PSJSAVY="!":$PIECE(PSGSI,"^")_"^1",PSJSAVY="E":$PIECE(PSGSI,"^"),1:"")
+17 IF PSJSAVY="Y"!(PSJSAVY="E")!(PSJSAVY="!")
Begin DoDot:1
+18 IF ($GET(PSJTYP)="V")
NEW OPILN
SET OPILN=$ORDER(^PS(53.1,+$GET(PSJORD),12," "),-1)
NEW TXT,OPIMSG,PSJTMPTX,PSJOVRMX
SET OPIMSG="Instructions too long. See Order View or BCMA for full text."
Begin DoDot:2
+19 SET PSJTMPTX=""
SET PSJOVRMX=0
SET TMPLIN=0
FOR
SET TMPLIN=$ORDER(^PS(53.1,+PSJORD,12,TMPLIN))
if 'TMPLIN!(PSJOVRMX)
QUIT
Begin DoDot:3
+20 if ($LENGTH(PSJTMPTX)+$LENGTH($GET(^PS(53.1,+PSJORD,12,TMPLIN,0))))>60
SET PSJOVRMX=1
if $GET(PSJOVRMX)
QUIT
SET PSJTMPTX=$GET(PSJTMPTX)_$SELECT($GET(PSJTMPTX)]"":" ",1:"")_$GET(^PS(53.1,+PSJORD,12,TMPLIN,0))
End DoDot:3
+21 SET PSGSI=$SELECT(PSJTMPTX]"":PSJTMPTX,1:OPIMSG)
IF $GET(PSJOVRMX)
IF (PSJSAVY'="E")
DO OPIWARN^PSJBCMA5(1)
End DoDot:2
+22 SET PSGSI=$SELECT(PSJSAVY="!":$PIECE($$PUT5345(PSGORD),"^")_"^1",1:$PIECE($$PUT5345(PSGORD),"^"))
End DoDot:1
+23 IF PSJSAVY="E"
KILL ^PS(53.45,+$GET(PSJSYSP),5),^PS(53.45,+$GET(PSJSYSP),6)
Begin DoDot:1
+24 NEW PRVCLN,X
SET PRVCLN=$ORDER(^PS(53.1,+$GET(PSJORD),12,""),-1)
+25 if ($GET(PSJTYP)["V")
SET ^PS(53.45,+$GET(PSJSYSP),6,0)="^53.1136^"_+$GET(PRVCLN)_"^"_+$GET(PRVCLN)_"^"_1
+26 if ($GET(PSJTYP)'["V")
SET ^PS(53.45,+$GET(PSJSYSP),5,0)="^53.1135^"_+$GET(PRVCLN)_"^"_+$GET(PRVCLN)_"^"_1
+27 SET X=0
FOR
SET X=$ORDER(^PS(53.1,+$GET(PSJORD),12,X))
if 'X
QUIT
SET Y=$GET(^PS(53.1,+$GET(PSJORD),12,X,0))
if ($GET(PSJTYP)'="V")
SET Y=$$ENSET^PSGSICHK(Y)
SET ^PS(53.45,+$GET(PSJSYSP),$SELECT($GET(PSJTYP)="V":6,1:5),X,0)=Y
+28 if PSJTYP="V"
DO EDITOPI^PSJBCMA5(PSGP,PSJORD)
if PSJTYP'="V"
DO EDITSI^PSJBCMA5(PSGP,PSJORD)
End DoDot:1
+29 IF PSJSAVY="E"
SET PSGSI=$$ENBCMA(PSJTYP)
+30 QUIT PSGSI
+31 ;
ENPC(PSJTYP,PSJSYSP,LEN,TEXT) ; Copy Provider Comments -> Special Instructions.
+1 SET PSGSI=$$ENPCL(PSJTYP,$GET(PSGP),$GET(PSGORD))
+2 QUIT PSGSI
+3 ;
REDISP ; Redisplay Provider Comments and allow entry of Spec. Instructions.
+1 DO CLEAR^VALM1
FOR X=0:0
SET X=$ORDER(^PS(53.1,+$GET(PSJORD),12,X))
if 'X
QUIT
WRITE ^(X,0),!
+2 WRITE !!
SET PSGSI=""
+3 if PSJTYP'="V"
DO 8^PSGOE81
+4 IF PSJTYP="V"
DO 64^PSIVEDT1
SET PSGSI=P("OPI")
+5 QUIT
+6 ;
ENPCHLP1(Y) ; Display help messages for Provider Comment copy.
+1 WRITE !,"Enter ""YES"" to copy Provider Comments into the ",$$ENFIELD(Y)," field",!,"or ""NO"" to bypass",!,"or ""!"" to copy the Provider Comments into the ",$$ENFIELD(PSJTYP)," field",!,"and flag them for display in a BCMA Message Box"
+2 WRITE !,"or type ""E"" to copy the Provider Comments into the ",$$ENFIELD(PSJTYP)," field and open a word processing window for editing."
+3 QUIT
ENPCHLP2(Y,X) ;
+1 WRITE !,"The Provider Comments entered for this order are longer than the space available",!,"in the ",$$ENFIELD(Y)," field.",!!,"Enter ""YES"" to copy the first ",X-3," characters into the ",$$ENFIELD(Y),!,"field, or ""NO"" to continue.",!!
+2 QUIT
ENBCMA(PSJTYP) ;
+1 NEW DIR,X,Y
+2 IF $GET(PSJTYP)="V"
if '$LENGTH($GET(^PS(53.45,+$GET(PSJSYSP),6,0)))
QUIT ""
+3 IF $GET(PSJTYP)="U"
if '$LENGTH($GET(^PS(53.45,+$GET(PSJSYSP),5,0)))
QUIT ""
+4 WRITE !!,"Would you like to flag the ",$$ENFIELD(PSJTYP)," field for display in a BCMA",!,"Message box?"
+5 ;P434 added quit
WRITE !
SET DIR(0)="S^Y:Yes;N:No"
SET DIR("A")="Flag the "_$$ENFIELD(PSJTYP)_" (Yes/No)"
DO ^DIR
IF X="^"
SET DONE=1
+6 KILL PSJCOMSI
IF $GET(PSJCOM)
IF $GET(PSJORD)'["P"
NEW TEXT
SET TEXT=$SELECT(PSJTYP="U":$GET(PSGSI),1:$GET(P("OPI")))
SET PSJCOMSI=$$COMSI(PSJCOM,TEXT)
+7 if Y="Y"
QUIT $SELECT($GET(PSJTYP)="U":$PIECE(PSGSI,"^")_"^1",1:$PIECE(P("OPI"),"^")_"^1")
+8 QUIT $SELECT(PSJTYP="U":PSGSI,1:P("OPI"))
ENFIELD(Y) ;
+1 QUIT $SELECT(Y="V":"Other Print Info",1:"Special Instructions")
+2 ;
COMSI(PARENT,INSTR) ;
+1 NEW DIR,X,Y
+2 WRITE !!!!?15,"** WARNING **",!?5,"This order is part of a complex order."
+3 WRITE !!,"Would you like to copy the ",$$ENFIELD(PSJTYP)
+4 WRITE !,"to the other orders in the complex order?"
+5 SET DIR(0)="S^Y:Yes;N:No"
SET DIR("A")=" Copy the "_$$ENFIELD(PSJTYP)_" (Yes/No)"
DO ^DIR
+6 if Y="Y"
QUIT 1
+7 QUIT 0
+8 ;
ENORL(X) ; Return patient's location as variable ptr.
+1 QUIT $SELECT(+$GET(^DIC(42,+X,44)):+$GET(^(44))_";SC(",$DATA(^DIC(42,+X,0)):+X_";DIC(42,",1:"")
+2 ;
ENMARD() ; validate MAR SELECTION DEFAULT string in WARD PARMS file.
+1 NEW PSJANS,PSJX1,PSJX2,RANGE,Q
+2 SET RANGE="1:6"
FOR PSJX1=1:1:6
SET RANGE(PSJX1)=""
+3 if $EXTRACT(X)="-"
SET X=+RANGE_X
if $EXTRACT($LENGTH(X))="-"
SET X=X_$PIECE(RANGE,":",2)
+4 SET PSJANS=""
FOR Q=1:1:$LENGTH(X,",")
SET PSJX1=$PIECE(X,",",Q)
DO FS
if '$DATA(PSJANS)
QUIT
+5 if '$GET(PSJANS)
QUIT 0
+6 SET PSJANS=$EXTRACT(PSJANS,1,$LENGTH(PSJANS)-1)
FOR Q=1:1:$LENGTH(PSJANS,",")
Begin DoDot:1
+7 IF $PIECE(PSJANS,",",Q)=1
IF $LENGTH(PSJANS,",")>1
WRITE !!,"All Medications (1) may not be selected in combination with other types."
KILL PSJANS
QUIT
+8 WRITE ?47,$PIECE(PSJANS,",",Q)," - ",$PIECE($TEXT(@$PIECE(PSJANS,",",Q)),";;",2),!
End DoDot:1
if '$DATA(PSJANS)
QUIT
+9 if $GET(PSJANS)
SET X=PSJANS
QUIT $GET(PSJANS)
+10 ;
FS ;
+1 IF $SELECT(PSJX1?1.N1"-"1.N:0,PSJX1'?1.N:1,'$DATA(RANGE(PSJX1)):1,1:","_PSJANS[PSJX1)
KILL PSJANS
QUIT
+2 IF PSJX1'["-"
SET PSJANS=PSJANS_PSJX1_","
QUIT
+3 SET PSJX2=+PSJX1
SET PSJANS=PSJANS_PSJX2_","
+4 FOR
SET PSJX2=$ORDER(RANGE(PSJX2))
if $SELECT(X=""
KILL PSJANS
if '$DATA(PSJANS)
QUIT
SET PSJANS=PSJANS_PSJX2_","
if PSJX2=$PIECE(PSJX1,"-",2)
QUIT
+5 QUIT
+6 ;
ENMARDH ;Help text for MAR default answer.
+1 WRITE !!?2,"Enter the number corresponding to the type of orders to be included on MARs",!,"printed for this ward. Multiple types (except 1) may be selected using ""-""",!,"or "","" as delimiters.",!!,"Choose from: ",!
+2 NEW X
FOR X=1:1:6
WRITE !?13,X," - ",$PIECE($TEXT(@X),";;",2)
+3 WRITE !
+4 QUIT
1 ;;All Medications
2 ;;Non-IV Medications only
3 ;;IV Piggybacks
4 ;;LVPs
5 ;;TPNs
6 ;;Chemotherapy Medications (IV)
+1 ;
EFD ;The following EFD Tags are used to Calculate the Expected First Dose for backdoor
+1 ;orders. The call to $$ENQ^PSJORP2 is used to actually perform the calculation.
+2 ;The program $$ENQ^PSJORP2 requires the variable INFO to equal the following:
+3 ;BHW;PSJ*5*136
+4 ; INFO (piece 1) = START DATE/TIME ;PSGNESD (NEW ORDER)
+5 ; INFO (piece 2) = STOP DATE/TIME ;PSGNEFD (NEW ORDER)
+6 ; INFO (piece 3) = SCHEDULE ;PSGSCH (NEW ORDER)
+7 ; INFO (piece 4) = SCHEDULE TYPE ;PSGST (NEW ORDER)
+8 ; INFO (piece 5) = ORDERABLE ITEM ;PSGDRG (NEW ORDER)
+9 ; INFO (piece 6) = ADMIN TIMES ;PSGS0Y (NEW ORDER)
+10 ;
EFDNEW ;Call Here if NEW or RENEWED Order
+1 NEW INFO
+2 SET INFO=($GET(PSGNESD))_U_($GET(PSGNEFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGDRG))_U_($GET(PSGS0Y))
+3 DO EFDDISP
+4 QUIT
EFDACT ;Call here if Editing Fields for an ACTIVE order
+1 ; Field 10 = Start Date
+2 ; Field 34 = Stop Date
+3 ; Field 41 = Admin Times
+4 NEW INFO,KEY,ORDER,LAST
+5 ;Loop Fields to be edited, in order, and determine when to Display expected first dose message
+6 FOR KEY=1:1
SET ORDER=$PIECE(PSGOEER,";",KEY)
if '$LENGTH(ORDER)
QUIT
IF "10^34^41"[$PIECE(ORDER,U,1)
SET ORDER(KEY)=$PIECE(ORDER,U,1)
+7 ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
+8 SET LAST=$ORDER(ORDER(99),-1)
if 'LAST
QUIT
+9 ;BHW;PSJ*5*179;Remove "Display Once" logic.
+10 ;S LAST=ORDER(LAST)
+11 ;I LAST'=PSGF2 Q
+12 SET INFO=($GET(PSGSD))_U_($GET(PSGFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGPDRG))_U_($GET(PSGS0Y))
+13 SET PSGEFDMG="Next Dose Due"
+14 DO EFDDISP
+15 QUIT
EFDNV ;Call here if Editing Fields for a NON-VERIFIED order
+1 ; Field 10 = Start Date
+2 ; Field 25 = Stop Date
+3 ; Field 39 = Admin Times
+4 NEW INFO,KEY,ORDER,LAST
+5 ;Check if called during finish process
+6 IF '$DATA(PSGOEER)
Begin DoDot:1
+7 SET INFO=($GET(PSGNESD))_U_($GET(PSGNEFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGPDRG))_U_($GET(PSGS0Y))
+8 QUIT
End DoDot:1
DO EFDDISP
QUIT
+9 ;Loop Fields to be edited, in order, and determine when to Display expected first dose message
+10 FOR KEY=1:1
SET ORDER=$PIECE(PSGOEER,";",KEY)
if '$LENGTH(ORDER)
QUIT
IF "10^25^39"[$PIECE(ORDER,U,1)
SET ORDER(KEY)=$PIECE(ORDER,U,1)
+11 ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
+12 SET LAST=$ORDER(ORDER(99),-1)
if 'LAST
QUIT
+13 ;Only display EFD once, so Quit if this call is not for the Last field in the Edit
+14 SET LAST=ORDER(LAST)
+15 IF LAST'=PSGF2
QUIT
+16 SET INFO=($GET(PSGSD))_U_($GET(PSGFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGPDRG))_U_($GET(PSGS0Y))
+17 DO EFDDISP
+18 QUIT
EFDIV(PSGZZND) ;Set variables for EFD on IV orders.
+1 IF $GET(PSGZZND)=""
Begin DoDot:1
+2 NEW X,ZZND,LYN,PSGS0XT,PSGS0Y,PSGOES
SET PSGOES=1
SET X=P(9)
DO EN^PSGS0
if $GET(ZZND)'=""
SET PSGZZND=ZZND
End DoDot:1
+3 SET PSGNESD=P(2)
SET PSGNEFD=P(3)
SET PSGSCH=P(9)
SET PSGST=$PIECE($GET(PSGZZND),"^",5)
SET PSGDRG=$PIECE($GET(P("PD")),"^")
SET PSGS0Y=P(11)
+4 ;BHW - PSJ*5*177 Add call to check stop date. If it's in the past, Display Message
+5 DO CHKSTOP
+6 DO EFDNEW
+7 WRITE !
+8 QUIT
EFDDISP ;Display Expected First Dose
+1 NEW Y,Z
+2 if $GET(PSGST)="OC"!($GET(PSGST)="P")!($GET(PSGST)="O")
QUIT
+3 if $GET(PSGSCH)["ON CALL"!($GET(PSGSCH)["ON-CALL")!($GET(PSGSCH)["ONCALL")
QUIT
+4 if $GET(PSGSCH)["PRN"
QUIT
+5 IF '$LENGTH($GET(PSGP))
NEW PSGP
SET PSGP=""
+6 SET Y=$$ENQ^PSJORP2(PSGP,INFO)
+7 IF 'Y
SET Y="Unable to Calculate"
+8 XECUTE ^DD("DD")
+9 ;BHW;PSJ*5*179;Add Variable Message. "Next Dose Due". Default to "Expected First Dose"
+10 IF '$DATA(PSGEFDMG)
SET PSGEFDMG="Expected First Dose"
+11 WRITE !,PSGEFDMG,": ",Y
HANG 3
+12 KILL PSGEFDMG
+13 QUIT
CHKSTOP ;BHW - PSJ*5*177 Warn user if the Stop Date is < now.
+1 IF '+$GET(P(3))
QUIT
+2 NEW PSNOW,%,%H,%I,X
DO NOW^%DTC
SET PSNOW=%
+3 IF +P(3)<PSNOW
Begin DoDot:1
+4 WRITE !,$CHAR(7),"The Stop Date/Time is in the Past!!! This order will",!,"automatically EXPIRE upon Verification!!",!
+5 QUIT
End DoDot:1
QUIT
+6 QUIT
+7 ;
PUT5345(PSGORD) ; Get text from provider comments, place into temp storage
+1 if '$DATA(^PS(53.1,+PSGORD,12))
QUIT ""
+2 NEW PSJTMPTX,PSJOVRMX,TMPLIN,SIMSG
+3 NEW LN,TXT,LNCNT
SET TXT=""
SET LN=0
FOR LNCNT=0:1
SET LN=$ORDER(^PS(53.1,+PSGORD,12,LN))
if 'LN
QUIT
Begin DoDot:1
+4 SET TXT=$GET(^PS(53.1,+PSGORD,12,LN,0))
SET ^PS(53.45,+PSJSYSP,$SELECT($GET(PSJTYP)="U":5,$GET(PSJTYP)="V":6,1:5),LN,0)=TXT
End DoDot:1
+5 IF $GET(LNCNT)
NEW PSJFIREF
SET PSJFIREF="^PS(53.45,"_+PSJSYSP_","_$SELECT($GET(PSJTYP)="U":5,$GET(PSJTYP)="V":6,1:5)_","
DO ENSI(PSJFIREF)
+6 IF $GET(LNCNT)
SET ^PS(53.45,+PSJSYSP,$SELECT(($GET(PSJTYP)="V"):6,1:5),0)="^^"_LNCNT_"^"_LNCNT
+7 NEW DIE,DA
+8 SET SIMSG="Instructions too long. See Order View or BCMA for full text."
+9 SET PSJTMPTX=""
SET PSJOVRMX=0
SET TMPLIN=0
FOR
SET TMPLIN=$ORDER(^PS(53.45,+PSJSYSP,$SELECT($GET(PSJTYP)="V":6,1:5),TMPLIN))
if 'TMPLIN!(PSJOVRMX)
QUIT
Begin DoDot:1
+10 if ($LENGTH(PSJTMPTX)+$LENGTH($GET(^PS(53.45,+PSJSYSP,$SELECT($GET(PSJTYP)="V"
SET PSJOVRMX=1
+11 if $GET(PSJOVRMX)
QUIT
SET PSJTMPTX=$GET(PSJTMPTX)_$SELECT($GET(PSJTMPTX)]"":" ",1:"")_$GET(^PS(53.45,+PSJSYSP,$SELECT($GET(PSJTYP)="V":6,1:5),TMPLIN,0))
End DoDot:1
+12 SET TXT=$SELECT(PSJOVRMX:SIMSG,1:PSJTMPTX)
+13 QUIT TXT
+14 ;
ENSI(PSJSIFIL) ; Expand comments using MEDICATIONS INSTRUCTIONS file (#51)
+1 NEW X,PSJTMPFI,PSJTMPLI,DONE,PSJNWTXT,TOLIN,II,PSJSITXT,FULL,OLD,I
SET PSJTMPFI=PSJSIFIL_"1)"
if '$DATA(@PSJTMPFI)
QUIT
+2 KILL ^TMP("PSGSIL",$JOB)
+3 FOR I=1:1
if $GET(DONE)
QUIT
SET PSJTMPFI=PSJSIFIL_I_",0)"
SET DONE=$DATA(@PSJTMPFI)
SET DONE=$SELECT(DONE:0,1:1)
Begin DoDot:1
+4 SET PSJTMPLI=$GET(@PSJTMPFI)
IF ($TRANSLATE(PSJTMPLI," ")'="")
DO TXT^PSGMUTL($$ENSISET(PSJTMPLI),74)
+5 IF ($TRANSLATE(PSJTMPLI," ")="")
SET MARX(1)=PSJTMPLI
+6 SET II=""
FOR
SET II=$ORDER(MARX(II))
if 'II
QUIT
SET TOLIN=+$ORDER(^TMP("PSGSIL",$JOB,+$GET(PSJSYSP),""),-1)
Begin DoDot:2
+7 SET ^TMP("PSGSIL",$JOB,+$GET(PSJSYSP),TOLIN+1)=MARX(II)
QUIT
End DoDot:2
End DoDot:1
+8 SET I=""
IF $ORDER(^TMP("PSGSIL",$JOB,+$GET(PSJSYSP),0))
KILL ^PS(53.45,+$GET(PSJSYSP),5)
SET TOLIN=""
FOR I=0:1
SET TOLIN=$ORDER(^TMP("PSGSIL",$JOB,+$GET(PSJSYSP),TOLIN))
if TOLIN=""
QUIT
Begin DoDot:1
+9 SET ^PS(53.45,+$GET(PSJSYSP),5,TOLIN,0)=^TMP("PSGSIL",$JOB,+$GET(PSJSYSP),TOLIN)
End DoDot:1
+10 SET I=$ORDER(^PS(53.45,+$GET(PSJSYSP),5,""),-1)
SET ^PS(53.45,+$GET(PSJSYSP),5,0)="^55.6135^"_I_"^"_I_"^"_$PIECE($GET(PSGDT),".")
+11 KILL ^TMP("PSGSIL",$JOB)
+12 QUIT
+13 ;
ENSISET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
+1 NEW X1,X2,Y
SET Y=""
+2 ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
+3 ; ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
+4 FOR X1=1:1:$LENGTH(X," ")
SET X2=$PIECE(X," ",X1)
Begin DoDot:1
+5 ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue
IF X2']""
SET Y=Y_" "
QUIT
+6 SET Y=Y_$SELECT($LENGTH(X2)>30:X2,'$DATA(^PS(51,+$ORDER(^PS(51,"B",X2,0)),0)):X2,$PIECE(^(0),"^",2)]""&$PIECE(^(0),"^",4):$PIECE(^(0),"^",2),1:X2)_" "
+7 QUIT
End DoDot:1
+8 ;BHW;Modified stripping of spaces at end of string
+9 FOR X1=$LENGTH(Y):-1:0
if $EXTRACT(Y,X1,X1)'=" "
QUIT
SET Y=$EXTRACT(Y,1,X1-1)
+10 QUIT Y
