PSOERUT4 ;ALB/MFR - eRx Drug Suggestion Utilities; 06/25/2023 5:14pm
;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
;
MATCHSUG(ERXIEN,VIEW) ; Match Suggestion Prompt
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; (o)VIEW - View Only Mode (1:YES,0/null: NO)
;Output: MATCHSUG - eRx record (Pointer to #52.49) or 0 (Not selected or no suggestion on file)
;
N MATCHSUG,DRUGHASH,MATCHCNT,CNT,VISTARX,QUIT,DIR,Y,X,VADRUG,VASIG,SUGGARR,TEMPARR,II
N VADAYS,VAREFS,VAQTY
I '$D(^PS(52.49,+$G(ERXIEN),0)) Q 0
; Dosage already entered
I '$G(VIEW),$D(^PS(52.49,ERXIEN,21)) Q 0
;
S DRUGHASH=$$DRUGHASH^PSOERUT(ERXIEN) I 'DRUGHASH Q 0
;
S (MATCHSUG,MATCHCNT,QUIT)=0
S VISTARX=9999999999
F S VISTARX=$O(^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX),-1) Q:'VISTARX D I (MATCHCNT>2) Q
. S VADRUG=+$$GET1^DIQ(52,VISTARX,6,"I") I 'VADRUG Q
. ; If in View Mode and VistA Rx was created after eRx Drug was Validated, skip
. I $G(VIEW),$P($G(^PS(52.49,ERXIEN,1)),"^",12),$P($G(^PSRX(VISTARX,"OR1")),"^",8)>+$P($G(^PS(52.49,ERXIEN,1)),"^",12) Q
. ; If Drug is Inactive, forget suggestion automatically
. I $$GET1^DIQ(50,VADRUG,100,"I") D Q
. . K ^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX)
. S VASIG=$$SUGSIG^PSOERUT3(VISTARX,ERXIEN) I VASIG="" Q
. S VAQTY=+$$GET1^DIQ(52,VISTARX,7,"I")
. S VADAYS=+$$GET1^DIQ(52,VISTARX,8,"I")
. S VAREFS=+$$GET1^DIQ(52,VISTARX,9,"I")
. I $D(TEMPARR(VADRUG,VASIG,VAQTY,VADAYS,VAREFS)) Q
. S MATCHCNT=MATCHCNT+1
. S SUGGARR(MATCHCNT)=VISTARX_"^"_DRUGHASH,TEMPARR(VADRUG,VASIG,VAQTY,VADAYS,VAREFS)=""
F CNT=1:1:MATCHCNT D I MATCHSUG!QUIT Q
. S VISTARX=+SUGGARR(CNT),DRUGHASH=$P(SUGGARR(CNT),"^",2)
. D CMPMEDS(ERXIEN,VISTARX,CNT_"^"_MATCHCNT)
. K DIR S DIR(0)="SOA^"_$S('$G(VIEW):"A:ACCEPT;",1:"")_$S(MATCHCNT>1&(MATCHCNT'=CNT):"N:NEXT;",1:"")_"F:FORGET;E:EXIT"
. S DIR("A")="ACTION on SUGGESTION: "_$S('$G(VIEW):"(A)CCEPT ",1:"")_$S(MATCHCNT>1&(MATCHCNT'=CNT):"(N)EXT ",1:"")_"(F)ORGET (E)XIT: "
. S DIR("B")=$S(MATCHCNT>1&(MATCHCNT'=CNT):"NEXT",1:"EXIT")
. S II=0
. I '$G(VIEW) D
. . S II=II+1,DIR("?",II)=" ACCEPT - Accepts the suggested data (right column) and pre-populates the"
. . S II=II+1,DIR("?",II)=" VistA fields"
. I MATCHCNT>1&(MATCHCNT'=CNT) D
. . S II=II+1,DIR("?",II)=" NEXT - Ignores the current suggestion and view the next one"
. S II=II+1,DIR("?",II)=" FORGET - Forgets the current suggestion so that it is not presented again"
. S II=II+1,DIR("?",II)=" in the future to any user"
. S DIR("?")=" EXIT - Exits and continue to filling the VistA fields manually"
. D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="E") S QUIT=1 Q
. I Y="A" S MATCHSUG=VISTARX Q
. I Y="N" W ! Q
. I Y="F" D
. . K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO"
. . S DIR("A")="Are you sure this suggestion match should be forgotten? "
. . S DIR("?")="This suggestion originated from a VistA Rx previously dispensed for an eRx with"
. . S DIR("?")=DIR("?")_" the exact Drug Name, NDC, SIG, Quantity, Days Supply, # of Refills"
. . S DIR("?")=DIR("?")_" and Substitution allowance. Once you forget this match it will no"
. . S DIR("?")=DIR("?")_" longer be suggested as a match for future eRx's with the same fields."
. . W ! D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="N") S CNT=CNT-1 W ! Q
. . W !?64,"Forgetting..." K ^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX) H 1 W "Ok." H .5 W ! Q
Q MATCHSUG
;
CMPMEDS(ERXIEN,VISTARX,COUNTER) ; Display the Comparison Between eRx and VistA Providers
;Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; VISTARX - VistA Rx IEN (Pointer to #52)
; COUNTER - P1: Entry # | P2: Number of Entries
I '$D(^PS(52.49,+$G(ERXIEN),0))!'$D(^PSRX(+$G(VISTARX),0)) Q
N XX,LINE,X
W !?55,"|Sugg. " W $G(IOINHI)_+$G(COUNTER)_$G(IOINORM)_" of "_$G(IOINHI)_$P($G(COUNTER),"^",2)_$G(IOINORM)
W " - ",$G(IOINHI)_$$FMTE^XLFDT($$GET1^DIQ(52,VISTARX,21,"I")\1,"2Z")_$G(IOINORM),?79,"|"
W !,$G(IORVON)_"ERX MED"_$G(IORVOFF),?41,$G(IORVON)_"VISTA MED"_$G(IORVOFF)
W ?55,"|From Rx#: "_$G(IOINHI)_$$GET1^DIQ(52,VISTARX,.01)_$G(IOINORM),?79,"|"
S $P(XX,"_",81)="" W !,XX
S LINE=0 D SETDRUG^PSOERUT2("RS",,ERXIEN,1,VISTARX)
Q
;
CSPRV(PROV,DRG,ORN) ; Sets CS Information (DEA#, Detox #, Site Address,...)
N DETN,DEA,I,LBL,VADD,SPC
I PROV="" Q
S:$L($G(PSORX("RXDEA"))) DEA=PSORX("RXDEA")
I '$L($G(DEA)) D
. S DEA=$S($G(PENDATA("OIRXN")):$$RXDEA^PSOUTIL(PENDATA("OIRXN")),$G(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV))
. S:DEA]"" PSORX("RXDEA")=DEA
S:$L($G(PSORX("DETX"))) DETN=PSORX("DETX")
S LBL="DEA#: "
I DRG,$$DETOX^PSSOPKI(DRG),'$L($G(DETN)) D
. S DETN=$S($G(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
S $P(SPC," ",(33-$L(DEA)))=" "
I (DEA'="")!($G(DETN)'="") D
. S XV="|"_LBL_$$COMPARE^PSOERUT0("LM",DEA,DEA,41+$L(LBL))
. S XV=XV_$S($G(DETN)]"":SPC_"DETOX#: "_$$COMPARE^PSOERUT0("LM",$G(DETN),$G(DETN),49+$L(SPC)),1:"")
. D ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
I $G(ORN) D PRVAD^PSOPKIV2 I $G(VADD(1))]"" D
. S XV="|Site Address: "_$$COMPARE^PSOERUT0("LM",VADD(1),VADD(1),15)
. D ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
. I VADD(2)'="" S XV="| "_$$COMPARE^PSOERUT0("LM",VADD(2),VADD(2),15)
. D ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
. I VADD(3)'="" S XV="| "_$$COMPARE^PSOERUT0("LM",VADD(3),VADD(3),15)
. D ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
Q
;
VASIG(ORD) ; Returns The Pending Order SIG
; Input: ORD - Pointer to the PENDING ORDER file (#52.41)
;Output: VASIG - VistA SIG in one long string
N VASIG,SIG
S VASIG="",ORD=+$G(ORD)
S SIG=0 F S SIG=$O(^PS(52.41,ORD,"SIG",SIG)) Q:'SIG D
. I $E(VASIG,$L(VASIG))'=" " S VASIG=VASIG_" "
. S VASIG=VASIG_$G(^PS(52.41,ORD,"SIG",SIG,0))
Q VASIG
;
ERXDOSE(ERXIEN,DOSEARR,INTVAL) ; Retrieves the Dosage for an eRx and loads an Array
; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
; (o)INTVAL - 1: Use Internal Value Flag | 0/null: External Value
;Output:.DOSEARR - Return Array Containing Dosage Information
;
N ERXDOSE,DOSE
K DOSEARR D GETS^DIQ(52.49,ERXIEN,"21*","IE","ERXDOSE")
S DOSE="" F S DOSE=$O(ERXDOSE(52.4921,DOSE)) Q:DOSE="" D
. S DOSEARR("DOSE ORDERED",+DOSE)=ERXDOSE(52.4921,DOSE,9,"I")
. S DOSEARR("DOSE",+DOSE)=ERXDOSE(52.4921,DOSE,8,"I")
. S DOSEARR("UNITS",+DOSE)=ERXDOSE(52.4921,DOSE,11,"I")
. S DOSEARR("NOUN",+DOSE)=ERXDOSE(52.4921,DOSE,12,"I")
. S DOSEARR("DURATION",+DOSE)=ERXDOSE(52.4921,DOSE,2,"I")
. I $G(ERXDOSE(52.4921,DOSE,6,$S($G(INTVAL):"I",1:"E")))'="" D
. . S DOSEARR("CONJUNCTION",+DOSE)=ERXDOSE(52.4921,DOSE,6,$S($G(INTVAL):"I",1:"E"))
. S DOSEARR("ROUTE",+DOSE)=ERXDOSE(52.4921,DOSE,10,$S($G(INTVAL):"I",1:"E"))
. S DOSEARR("SCHEDULE",+DOSE)=ERXDOSE(52.4921,DOSE,1,"I")
. S DOSEARR("VERB",+DOSE)=ERXDOSE(52.4921,DOSE,13,"I")
Q
;
VARXDOSE(RXIEN,DOSEARR) ; Retrieves the Dosage for a PRESCRIPTION and loads an Array
; Input: RXIEN - Pointer to the PRESCRIPTION file (#52)
;Output: .DOSEARR - Return Array Containing Dosage Information
;
; - Retrieving VistA Rx Dose and Saving to the eRx
N VADOSE,DOSE
I '$D(^PSRX(+$G(RXIEN),0)) Q
K DOSEARR D GETS^DIQ(52,RXIEN,"113*","I","VADOSE")
S DOSE="" F S DOSE=$O(VADOSE(52.0113,DOSE)) Q:DOSE="" D
. S DOSEARR("DOSE ORDERED",+DOSE)=VADOSE(52.0113,DOSE,1,"I")
. S DOSEARR("DOSE",+DOSE)=VADOSE(52.0113,DOSE,.01,"I")
. S DOSEARR("UNITS",+DOSE)=VADOSE(52.0113,DOSE,2,"I")
. S DOSEARR("NOUN",+DOSE)=VADOSE(52.0113,DOSE,3,"I")
. S DOSEARR("DURATION",+DOSE)=VADOSE(52.0113,DOSE,4,"I")
. I VADOSE(52.0113,DOSE,5,"I")'="" D
. . S DOSEARR("CONJUNCTION",+DOSE)=VADOSE(52.0113,DOSE,5,"I")
. S DOSEARR("ROUTE",+DOSE)=VADOSE(52.0113,DOSE,6,"I")
. S DOSEARR("SCHEDULE",+DOSE)=VADOSE(52.0113,DOSE,7,"I")
. S DOSEARR("VERB",+DOSE)=VADOSE(52.0113,DOSE,8,"I")
Q
;
PODOSAGE(NMSPC,ORDIEN,PENDATA,RENEWORD) ; Set ListMan Side-By-Side Section for VistA Pending Order Dosage
;Input: NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1", "PSOPO", ...)
; ORDIEN - Pointer to PENDING OUTPATIENT ORDERS file (#52.41)
; PENDATA - Array containing the Pending Order data
; RENEWORD - Renewal Pending Order? 1: YES | 0/null - NO ; Sets Pending Order Dosage Information
N DOSE,XE,XEI,XV,XVI,LMLINE,DFN,I,WRPDOSE,DISPUNTS,ROUTE,CONJUNCT,PDUE,DUESEQ,COAGENT,REASON,RESULT,ACK
S DFN=+$$GET1^DIQ(52.41,ORDIEN,1,"I")
;
D PDUEDATA^PSOERXU9(.PDUE,ERXIEN,1)
S XEI=0,LMLINE=LINE-1
S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="Prescriber Drug Use Evaluation:"
I '$D(PDUE) D
. S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" None",HIGHLN(LMLINE,2)=4
E D
. F DUESEQ=1:1 Q:'$D(PDUE(DUESEQ)) D
. . S COAGENT=$P(PDUE(DUESEQ),"^",8)
. . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="Co-Agent: "_$$COMPARE^PSOERUT0("LM",$E(COAGENT,1,29),$E(COAGENT,1,29),11,,LMLINE)
. . I $L(COAGENT)>29 D
. . . F I=1:1 S COAGENT=$E(COAGENT,30,999) Q:COAGENT="" D
. . . . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$E(COAGENT,1,29),$E(COAGENT,1,29),11,,LMLINE)
. . S REASON=$P(PDUE(DUESEQ),"^",2) I $$PRESOLV^PSOERXA1(REASON,"REA") S REASON=$$GET1^DIQ(52.45,$$PRESOLV^PSOERXA1(REASON,"REA"),.02)
. . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="Reason: "_$$COMPARE^PSOERUT0("LM",$E(REASON,1,30),$E(REASON,1,30),9,,LMLINE)
. . I $L(REASON)>31 D
. . . F I=1:1 S REASON=$E(REASON,32,999) Q:REASON="" D
. . . . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$E(REASON,1,31),$E(REASON,1,31),9,,LMLINE)
. . S RESULT=$P(PDUE(DUESEQ),"^",4) I $$PRESOLV^PSOERXA1(RESULT,"RES") S RESULT=$$GET1^DIQ(52.45,$$PRESOLV^PSOERXA1(RESULT,"RES"),.02)
. . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="Result: "_$$COMPARE^PSOERUT0("LM",$E(RESULT,1,31),$E(RESULT,1,31),9,,LMLINE)
. . I $L(RESULT)>31 D
. . . F I=1:1 S RESULT=$E(RESULT,32,999) Q:RESULT="" D
. . . . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$E(RESULT,1,31),$E(RESULT,1,31),8,,LMLINE)
. . S ACK=$P(PDUE(DUESEQ),"^",9)
. . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="Override: "_$$COMPARE^PSOERUT0("LM",$E(ACK,1,28),$E(ACK,1,28),11,,LMLINE)
. . I $L(ACK)>28 D
. . . F I=1:1 S ACK=$E(ACK,29,999) Q:ACK="" D
. . . . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$E(ACK,1,28),$E(ACK,1,28),11,,LMLINE)
. . I $O(PDUE(DUESEQ)) S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="......................................"
;
S XVI=0,LMLINE=LINE-1
I '$D(PENDATA) D Q
. S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=$S('RENEWORD:"3) ",1:" ")_" *Dosage:"
F DOSE=1:1 Q:'$D(PENDATA("DOSE",DOSE)) D
. I '$G(PENDATA("DOSE ORDERED",DOSE)),$G(PENDATA("VERB",DOSE))]"" D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" Verb: "_$$COMPARE^PSOERUT0("LM",PENDATA("VERB",DOSE),PENDATA("VERB",DOSE),55,,LMLINE)
. S DOSEX=PENDATA("DOSE",DOSE) I $E(DOSEX,1)=".",$G(PENDATA("DOSE ORDERED",DOSE)) S DOSEX="0"_DOSEX
. I $G(PENDATA("UNITS",DOSE))]"" S DOSEX=DOSEX_" ("_$$GET1^DIQ(50.607,PENDATA("UNITS",DOSE),.01)_")"
. D WRAP^PSOERUT(DOSEX,24,.WRPDOSE)
. S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=$S(DOSE=1&'RENEWORD:"3)",1:" ")_" *Dosage: "_$$COMPARE^PSOERUT0("LM",$G(WRPDOSE(1,0)),$G(WRPDOSE(1,0)),55,,LMLINE)
. I DOSE=1,'RENEWORD S UNDERLN(LMLINE,41)=2
. F I=2:1 Q:'$D(WRPDOSE(I)) D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$G(WRPDOSE(I,0)),$G(WRPDOSE(I,0)),55,,LMLINE)
. I $G(PENDATA("DOSE ORDERED",DOSE)),$G(PENDATA("VERB",DOSE))]"" D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" Verb: "_$$COMPARE^PSOERUT0("LM",PENDATA("VERB",DOSE),PENDATA("VERB",DOSE),55,,LMLINE)
. I '$G(PENDATA("DOSE ORDERED",DOSE)),$P($G(^PS(55,DFN,"LAN")),"^") D
. . D WRAP^PSOERUT($G(PENDATA("ODOSE",DOSE)),22,.WRPDOSE)
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)="*Oth.Lang.Dosage: "_$$COMPARE^PSOERUT0("LM",$G(WRPDOSE(1,0)),$G(WRPDOSE(1,0)),59,,LMLINE)
. . F I=2:1 Q:'$D(WRPDOSE(I)) D
. . . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$G(WRPDOSE(I,0)),$G(WRPDOSE(I,0)),59,,LMLINE)
. I $G(PENDATA("DOSE ORDERED",DOSE))'="" D
. . S DISPUNTS=$S($E(PENDATA("DOSE ORDERED",DOSE),1)=".":"0",1:"")_PENDATA("DOSE ORDERED",DOSE)
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" Disp. Units: "_$$COMPARE^PSOERUT0("LM",DISPUNTS,DISPUNTS,55,,LMLINE)
. I $G(PENDATA("NOUN",DOSE))'="" D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" Noun: "_$$COMPARE^PSOERUT0("LM",PENDATA("NOUN",DOSE),PENDATA("NOUN",DOSE),55,,LMLINE)
. I $G(PENDATA("ROUTE",DOSE)) S ROUTE=$$GET1^DIQ(51.2,PENDATA("ROUTE",DOSE),.01)
. S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" *Route: "_$$COMPARE^PSOERUT0("LM",$G(ROUTE),$G(ROUTE),55,,LMLINE)
. S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" *Schedule: "_$$COMPARE^PSOERUT0("LM",PENDATA("SCHEDULE",DOSE),PENDATA("SCHEDULE",DOSE),55,,LMLINE)
. I $G(PENDATA("DURATION",DOSE))'="" D
. . N DUR S DUR=PENDATA("DURATION",DOSE)
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" *Duration: "_$$COMPARE^PSOERUT0("LM",DUR_" "_$$FREQ(DUR),DUR_" "_$$FREQ(DUR),55,,LMLINE)
. I $G(PENDATA("CONJUNCTION",DOSE))'="" D
. . S CONJUNCT=$S(PENDATA("CONJUNCTION",DOSE)="T":"THEN",PENDATA("CONJUNCTION",DOSE)="X":"EXCEPT",1:"AND")
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)="*Conjunction: "_$$COMPARE^PSOERUT0("LM",CONJUNCT,CONJUNCT,55,,LMLINE)
;
; - Patient Instructions
S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)="________________________________________"
S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=$S('RENEWORD:"4) ",1:"")_"Patient Instruction:"
I 'RENEWORD S UNDERLN(LMLINE,41)=2
S VAPATINS="" F I=1:1 Q:'$D(PENDATA("SIG",I)) S VAPATINS=VAPATINS_" "_$$UP^XLFSTR($G(PENDATA("SIG",I)))
S $E(VAPATINS)=""
I VAPATINS'="" D
. K VARR D WRAP^PSOERUT(VAPATINS,39,.VARR)
. F I=1:1 Q:'$D(VARR(I)) D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$G(VARR(I,0)),$G(VARR(I,0)),42,,LMLINE)
I $O(PENDATA("SINS",0)) D
. S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" Other Lang. Pat. Instruct: :"
. S VAOTHINS="" F I=1:1 Q:'$D(PENDATA("SINS",I)) S VAOTHINS=VAOTHINS_" "_$$UP^XLFSTR($G(PENDATA("SINS",I)))
. S $E(VAOTHINS)=""
. K VARR D WRAP^PSOERUT(VAOTHINS,39,.VARR)
. F I=1:1 Q:'$D(VARR(I)) D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$G(VARR(I,0)),$G(VARR(I,0)),42,,LMLINE)
;
; - Setting eRx Prescriber Drug Use Evaluation (DUE), Matched Dosage and Patient Instructions
F ALLLN=1:1 Q:('$D(ERXLINES(ALLLN))&'$D(VALINES(ALLLN))) D
. S ERXALLS=$G(ERXLINES(ALLLN)),VAALLS=$G(VALINES(ALLLN))
. S XE=$G(ERXLINES(ALLLN))
. S XV="|"_$G(VALINES(ALLLN))
. D ADDLINE^PSOERUT0("LM",NMSPC,XE,XV)
;
Q
;
PENFLAG(NMSPC,ORD) ; Backdoor ListManager Display of Flag/Unflag Information
N FLAG,FLAGHDR,XX,FLAGCOMM
;
D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG") I '$G(FLAG(52.41,ORD_",",33,"I")) Q
S XX="Order Flagged by "_FLAG(52.41,ORD_",",34,"E")_" on "_FLAG(52.41,ORD_",",33,"E")
S $E(FLAGHDR,(81-$L(XX))/2)=XX
S UNDERLN(LINE,1)=100
D ADDLINE^PSOERUT0("LM",NMSPC,FLAGHDR,"")
S XX=FLAG(52.41,ORD_",",35,"E")
F Q:XX="" D
. S FLAGCOMM=$E(XX,1,79)
. S FLAGCOMM=" "_$$COMPARE^PSOERUT0("LM",$E(XX,1,79),$E(XX,1,79),2),XX=$E(XX,80,9999)
. D ADDLINE^PSOERUT0("LM",NMSPC,FLAGCOMM,"")
I FLAG(52.41,ORD_",",36,"I")'="" D
. S XX="Order Un-Flagged by "_FLAG(52.41,ORD_",",37,"E")_" on "_FLAG(52.41,ORD_",",36,"E")
. S FLAGHDR="",$E(FLAGHDR,(81-$L(XX))/2)=XX
. S UNDERLN(LINE,1)=100
. D ADDLINE^PSOERUT0("LM",NMSPC,FLAGHDR,"")
. S XX=FLAG(52.41,ORD_",",38,"E")
. F Q:XX="" D
. . S FLAGCOMM=$E(XX,1,79)
. . S FLAGCOMM=" "_$$COMPARE^PSOERUT0("LM",$E(XX,1,79),$E(XX,1,79),2),XX=$E(XX,80,9999)
. . D ADDLINE^PSOERUT0("LM",NMSPC,FLAGCOMM,"")
D BLANKLN^PSOERUT0("LM",1)
Q
;
ACCDTBY(ERXIEN) ; Returns the eRx latest Accepted Date/Time
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
;Output: P1^P2 - P1: External Accepted Date/Time (MM/DD/YY) | P2: Accepted By Name
;
N ACCDTBY,ACDTTM,ACBY,STHIS,FOUND,STAT
S ACCDTBY="",STHIS=99999,FOUND=0
F S STHIS=$O(^PS(52.49,ERXIEN,19,STHIS),-1) Q:'STHIS!(FOUND) D
. S STAT=$$GET1^DIQ(52.4919,STHIS_","_ERXIEN,.02,"I")
. I ",PR,RXP,CXP,"[(","_$$GET1^DIQ(52.45,STAT,.01,"E")_",") D
. . S ACCDTBY=$$FMTE^XLFDT($$GET1^DIQ(52.4919,STHIS_","_ERXIEN,.01,"I"),"2Y")_"^"_$$GET1^DIQ(52.4919,STHIS_","_ERXIEN,.03,"E")
. . S FOUND=1
Q ACCDTBY
;
PROVCOMM(COMM) ; Expand Provider Comments
; Input: Provider Comments
;Output: Expanded Comments
N PROVCOMM,X,PSODIR,INS1
I $G(COMM)="" Q ""
S COMM=$$UP^XLFSTR(COMM)
S (X,PSODIR("INS"))=COMM D SIG^PSOHELP S $E(INS1)="",PROVCOMM=INS1
Q PROVCOMM
;
FREQ(DUR) ; Returns the Duration Frequency word (WEEKS, DAYS, etc..)
; Input: DUR - Schedule Duration (e.g., "4D", "3W", "6H", etc...)
;Output: Spelled out duration frequency between parenthesis ("(DAYS)", "(WEEKS)", "(HOURS)", etc...)
S DUR=$G(DUR)
I DUR["M" Q "(MINUTES)"
I DUR["H" Q "(HOURS)"
I DUR["L" Q "(MONTHS)"
I DUR["W" Q "(WEEKS)"
Q "(DAYS)"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERUT4 17221 printed Oct 16, 2024@18:28:44 Page 2
PSOERUT4 ;ALB/MFR - eRx Drug Suggestion Utilities; 06/25/2023 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
+2 ;
MATCHSUG(ERXIEN,VIEW) ; Match Suggestion Prompt
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; (o)VIEW - View Only Mode (1:YES,0/null: NO)
+3 ;Output: MATCHSUG - eRx record (Pointer to #52.49) or 0 (Not selected or no suggestion on file)
+4 ;
+5 NEW MATCHSUG,DRUGHASH,MATCHCNT,CNT,VISTARX,QUIT,DIR,Y,X,VADRUG,VASIG,SUGGARR,TEMPARR,II
+6 NEW VADAYS,VAREFS,VAQTY
+7 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))
QUIT 0
+8 ; Dosage already entered
+9 IF '$GET(VIEW)
IF $DATA(^PS(52.49,ERXIEN,21))
QUIT 0
+10 ;
+11 SET DRUGHASH=$$DRUGHASH^PSOERUT(ERXIEN)
IF 'DRUGHASH
QUIT 0
+12 ;
+13 SET (MATCHSUG,MATCHCNT,QUIT)=0
+14 SET VISTARX=9999999999
+15 FOR
SET VISTARX=$ORDER(^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX),-1)
if 'VISTARX
QUIT
Begin DoDot:1
+16 SET VADRUG=+$$GET1^DIQ(52,VISTARX,6,"I")
IF 'VADRUG
QUIT
+17 ; If in View Mode and VistA Rx was created after eRx Drug was Validated, skip
+18 IF $GET(VIEW)
IF $PIECE($GET(^PS(52.49,ERXIEN,1)),"^",12)
IF $PIECE($GET(^PSRX(VISTARX,"OR1")),"^",8)>+$PIECE($GET(^PS(52.49,ERXIEN,1)),"^",12)
QUIT
+19 ; If Drug is Inactive, forget suggestion automatically
+20 IF $$GET1^DIQ(50,VADRUG,100,"I")
Begin DoDot:2
+21 KILL ^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX)
End DoDot:2
QUIT
+22 SET VASIG=$$SUGSIG^PSOERUT3(VISTARX,ERXIEN)
IF VASIG=""
QUIT
+23 SET VAQTY=+$$GET1^DIQ(52,VISTARX,7,"I")
+24 SET VADAYS=+$$GET1^DIQ(52,VISTARX,8,"I")
+25 SET VAREFS=+$$GET1^DIQ(52,VISTARX,9,"I")
+26 IF $DATA(TEMPARR(VADRUG,VASIG,VAQTY,VADAYS,VAREFS))
QUIT
+27 SET MATCHCNT=MATCHCNT+1
+28 SET SUGGARR(MATCHCNT)=VISTARX_"^"_DRUGHASH
SET TEMPARR(VADRUG,VASIG,VAQTY,VADAYS,VAREFS)=""
End DoDot:1
IF (MATCHCNT>2)
QUIT
+29 FOR CNT=1:1:MATCHCNT
Begin DoDot:1
+30 SET VISTARX=+SUGGARR(CNT)
SET DRUGHASH=$PIECE(SUGGARR(CNT),"^",2)
+31 DO CMPMEDS(ERXIEN,VISTARX,CNT_"^"_MATCHCNT)
+32 KILL DIR
SET DIR(0)="SOA^"_$SELECT('$GET(VIEW):"A:ACCEPT;",1:"")_$SELECT(MATCHCNT>1&(MATCHCNT'=CNT):"N:NEXT;",1:"")_"F:FORGET;E:EXIT"
+33 SET DIR("A")="ACTION on SUGGESTION: "_$SELECT('$GET(VIEW):"(A)CCEPT ",1:"")_$SELECT(MATCHCNT>1&(MATCHCNT'=CNT):"(N)EXT ",1:"")_"(F)ORGET (E)XIT: "
+34 SET DIR("B")=$SELECT(MATCHCNT>1&(MATCHCNT'=CNT):"NEXT",1:"EXIT")
+35 SET II=0
+36 IF '$GET(VIEW)
Begin DoDot:2
+37 SET II=II+1
SET DIR("?",II)=" ACCEPT - Accepts the suggested data (right column) and pre-populates the"
+38 SET II=II+1
SET DIR("?",II)=" VistA fields"
End DoDot:2
+39 IF MATCHCNT>1&(MATCHCNT'=CNT)
Begin DoDot:2
+40 SET II=II+1
SET DIR("?",II)=" NEXT - Ignores the current suggestion and view the next one"
End DoDot:2
+41 SET II=II+1
SET DIR("?",II)=" FORGET - Forgets the current suggestion so that it is not presented again"
+42 SET II=II+1
SET DIR("?",II)=" in the future to any user"
+43 SET DIR("?")=" EXIT - Exits and continue to filling the VistA fields manually"
+44 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="E")
SET QUIT=1
QUIT
+45 IF Y="A"
SET MATCHSUG=VISTARX
QUIT
+46 IF Y="N"
WRITE !
QUIT
+47 IF Y="F"
Begin DoDot:2
+48 KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="NO"
+49 SET DIR("A")="Are you sure this suggestion match should be forgotten? "
+50 SET DIR("?")="This suggestion originated from a VistA Rx previously dispensed for an eRx with"
+51 SET DIR("?")=DIR("?")_" the exact Drug Name, NDC, SIG, Quantity, Days Supply, # of Refills"
+52 SET DIR("?")=DIR("?")_" and Substitution allowance. Once you forget this match it will no"
+53 SET DIR("?")=DIR("?")_" longer be suggested as a match for future eRx's with the same fields."
+54 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="N")
SET CNT=CNT-1
WRITE !
QUIT
+55 WRITE !?64,"Forgetting..."
KILL ^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX)
HANG 1
WRITE "Ok."
HANG .5
WRITE !
QUIT
End DoDot:2
End DoDot:1
IF MATCHSUG!QUIT
QUIT
+56 QUIT MATCHSUG
+57 ;
CMPMEDS(ERXIEN,VISTARX,COUNTER) ; Display the Comparison Between eRx and VistA Providers
+1 ;Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; VISTARX - VistA Rx IEN (Pointer to #52)
+3 ; COUNTER - P1: Entry # | P2: Number of Entries
+4 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))!'$DATA(^PSRX(+$GET(VISTARX),0))
QUIT
+5 NEW XX,LINE,X
+6 WRITE !?55,"|Sugg. "
WRITE $GET(IOINHI)_+$GET(COUNTER)_$GET(IOINORM)_" of "_$GET(IOINHI)_$PIECE($GET(COUNTER),"^",2)_$GET(IOINORM)
+7 WRITE " - ",$GET(IOINHI)_$$FMTE^XLFDT($$GET1^DIQ(52,VISTARX,21,"I")\1,"2Z")_$GET(IOINORM),?79,"|"
+8 WRITE !,$GET(IORVON)_"ERX MED"_$GET(IORVOFF),?41,$GET(IORVON)_"VISTA MED"_$GET(IORVOFF)
+9 WRITE ?55,"|From Rx#: "_$GET(IOINHI)_$$GET1^DIQ(52,VISTARX,.01)_$GET(IOINORM),?79,"|"
+10 SET $PIECE(XX,"_",81)=""
WRITE !,XX
+11 SET LINE=0
DO SETDRUG^PSOERUT2("RS",,ERXIEN,1,VISTARX)
+12 QUIT
+13 ;
CSPRV(PROV,DRG,ORN) ; Sets CS Information (DEA#, Detox #, Site Address,...)
+1 NEW DETN,DEA,I,LBL,VADD,SPC
+2 IF PROV=""
QUIT
+3 if $LENGTH($GET(PSORX("RXDEA")))
SET DEA=PSORX("RXDEA")
+4 IF '$LENGTH($GET(DEA))
Begin DoDot:1
+5 SET DEA=$SELECT($GET(PENDATA("OIRXN")):$$RXDEA^PSOUTIL(PENDATA("OIRXN")),$GET(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV))
+6 if DEA]""
SET PSORX("RXDEA")=DEA
End DoDot:1
+7 if $LENGTH($GET(PSORX("DETX")))
SET DETN=PSORX("DETX")
+8 SET LBL="DEA#: "
+9 IF DRG
IF $$DETOX^PSSOPKI(DRG)
IF '$LENGTH($GET(DETN))
Begin DoDot:1
+10 SET DETN=$SELECT($GET(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
End DoDot:1
+11 SET $PIECE(SPC," ",(33-$LENGTH(DEA)))=" "
+12 IF (DEA'="")!($GET(DETN)'="")
Begin DoDot:1
+13 SET XV="|"_LBL_$$COMPARE^PSOERUT0("LM",DEA,DEA,41+$LENGTH(LBL))
+14 SET XV=XV_$SELECT($GET(DETN)]"":SPC_"DETOX#: "_$$COMPARE^PSOERUT0("LM",$GET(DETN),$GET(DETN),49+$LENGTH(SPC)),1:"")
+15 DO ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
End DoDot:1
+16 IF $GET(ORN)
DO PRVAD^PSOPKIV2
IF $GET(VADD(1))]""
Begin DoDot:1
+17 SET XV="|Site Address: "_$$COMPARE^PSOERUT0("LM",VADD(1),VADD(1),15)
+18 DO ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
+19 IF VADD(2)'=""
SET XV="| "_$$COMPARE^PSOERUT0("LM",VADD(2),VADD(2),15)
+20 DO ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
+21 IF VADD(3)'=""
SET XV="| "_$$COMPARE^PSOERUT0("LM",VADD(3),VADD(3),15)
+22 DO ADDLINE^PSOERUT0("LM",NMSPC,"",XV)
End DoDot:1
+23 QUIT
+24 ;
VASIG(ORD) ; Returns The Pending Order SIG
+1 ; Input: ORD - Pointer to the PENDING ORDER file (#52.41)
+2 ;Output: VASIG - VistA SIG in one long string
+3 NEW VASIG,SIG
+4 SET VASIG=""
SET ORD=+$GET(ORD)
+5 SET SIG=0
FOR
SET SIG=$ORDER(^PS(52.41,ORD,"SIG",SIG))
if 'SIG
QUIT
Begin DoDot:1
+6 IF $EXTRACT(VASIG,$LENGTH(VASIG))'=" "
SET VASIG=VASIG_" "
+7 SET VASIG=VASIG_$GET(^PS(52.41,ORD,"SIG",SIG,0))
End DoDot:1
+8 QUIT VASIG
+9 ;
ERXDOSE(ERXIEN,DOSEARR,INTVAL) ; Retrieves the Dosage for an eRx and loads an Array
+1 ; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+2 ; (o)INTVAL - 1: Use Internal Value Flag | 0/null: External Value
+3 ;Output:.DOSEARR - Return Array Containing Dosage Information
+4 ;
+5 NEW ERXDOSE,DOSE
+6 KILL DOSEARR
DO GETS^DIQ(52.49,ERXIEN,"21*","IE","ERXDOSE")
+7 SET DOSE=""
FOR
SET DOSE=$ORDER(ERXDOSE(52.4921,DOSE))
if DOSE=""
QUIT
Begin DoDot:1
+8 SET DOSEARR("DOSE ORDERED",+DOSE)=ERXDOSE(52.4921,DOSE,9,"I")
+9 SET DOSEARR("DOSE",+DOSE)=ERXDOSE(52.4921,DOSE,8,"I")
+10 SET DOSEARR("UNITS",+DOSE)=ERXDOSE(52.4921,DOSE,11,"I")
+11 SET DOSEARR("NOUN",+DOSE)=ERXDOSE(52.4921,DOSE,12,"I")
+12 SET DOSEARR("DURATION",+DOSE)=ERXDOSE(52.4921,DOSE,2,"I")
+13 IF $GET(ERXDOSE(52.4921,DOSE,6,$SELECT($GET(INTVAL):"I",1:"E")))'=""
Begin DoDot:2
+14 SET DOSEARR("CONJUNCTION",+DOSE)=ERXDOSE(52.4921,DOSE,6,$SELECT($GET(INTVAL):"I",1:"E"))
End DoDot:2
+15 SET DOSEARR("ROUTE",+DOSE)=ERXDOSE(52.4921,DOSE,10,$SELECT($GET(INTVAL):"I",1:"E"))
+16 SET DOSEARR("SCHEDULE",+DOSE)=ERXDOSE(52.4921,DOSE,1,"I")
+17 SET DOSEARR("VERB",+DOSE)=ERXDOSE(52.4921,DOSE,13,"I")
End DoDot:1
+18 QUIT
+19 ;
VARXDOSE(RXIEN,DOSEARR) ; Retrieves the Dosage for a PRESCRIPTION and loads an Array
+1 ; Input: RXIEN - Pointer to the PRESCRIPTION file (#52)
+2 ;Output: .DOSEARR - Return Array Containing Dosage Information
+3 ;
+4 ; - Retrieving VistA Rx Dose and Saving to the eRx
+5 NEW VADOSE,DOSE
+6 IF '$DATA(^PSRX(+$GET(RXIEN),0))
QUIT
+7 KILL DOSEARR
DO GETS^DIQ(52,RXIEN,"113*","I","VADOSE")
+8 SET DOSE=""
FOR
SET DOSE=$ORDER(VADOSE(52.0113,DOSE))
if DOSE=""
QUIT
Begin DoDot:1
+9 SET DOSEARR("DOSE ORDERED",+DOSE)=VADOSE(52.0113,DOSE,1,"I")
+10 SET DOSEARR("DOSE",+DOSE)=VADOSE(52.0113,DOSE,.01,"I")
+11 SET DOSEARR("UNITS",+DOSE)=VADOSE(52.0113,DOSE,2,"I")
+12 SET DOSEARR("NOUN",+DOSE)=VADOSE(52.0113,DOSE,3,"I")
+13 SET DOSEARR("DURATION",+DOSE)=VADOSE(52.0113,DOSE,4,"I")
+14 IF VADOSE(52.0113,DOSE,5,"I")'=""
Begin DoDot:2
+15 SET DOSEARR("CONJUNCTION",+DOSE)=VADOSE(52.0113,DOSE,5,"I")
End DoDot:2
+16 SET DOSEARR("ROUTE",+DOSE)=VADOSE(52.0113,DOSE,6,"I")
+17 SET DOSEARR("SCHEDULE",+DOSE)=VADOSE(52.0113,DOSE,7,"I")
+18 SET DOSEARR("VERB",+DOSE)=VADOSE(52.0113,DOSE,8,"I")
End DoDot:1
+19 QUIT
+20 ;
PODOSAGE(NMSPC,ORDIEN,PENDATA,RENEWORD) ; Set ListMan Side-By-Side Section for VistA Pending Order Dosage
+1 ;Input: NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1", "PSOPO", ...)
+2 ; ORDIEN - Pointer to PENDING OUTPATIENT ORDERS file (#52.41)
+3 ; PENDATA - Array containing the Pending Order data
+4 ; RENEWORD - Renewal Pending Order? 1: YES | 0/null - NO ; Sets Pending Order Dosage Information
+5 NEW DOSE,XE,XEI,XV,XVI,LMLINE,DFN,I,WRPDOSE,DISPUNTS,ROUTE,CONJUNCT,PDUE,DUESEQ,COAGENT,REASON,RESULT,ACK
+6 SET DFN=+$$GET1^DIQ(52.41,ORDIEN,1,"I")
+7 ;
+8 DO PDUEDATA^PSOERXU9(.PDUE,ERXIEN,1)
+9 SET XEI=0
SET LMLINE=LINE-1
+10 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="Prescriber Drug Use Evaluation:"
+11 IF '$DATA(PDUE)
Begin DoDot:1
+12 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" None"
SET HIGHLN(LMLINE,2)=4
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 FOR DUESEQ=1:1
if '$DATA(PDUE(DUESEQ))
QUIT
Begin DoDot:2
+15 SET COAGENT=$PIECE(PDUE(DUESEQ),"^",8)
+16 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="Co-Agent: "_$$COMPARE^PSOERUT0("LM",$EXTRACT(COAGENT,1,29),$EXTRACT(COAGENT,1,29),11,,LMLINE)
+17 IF $LENGTH(COAGENT)>29
Begin DoDot:3
+18 FOR I=1:1
SET COAGENT=$EXTRACT(COAGENT,30,999)
if COAGENT=""
QUIT
Begin DoDot:4
+19 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(COAGENT,1,29),$EXTRACT(COAGENT,1,29),11,,LMLINE)
End DoDot:4
End DoDot:3
+20 SET REASON=$PIECE(PDUE(DUESEQ),"^",2)
IF $$PRESOLV^PSOERXA1(REASON,"REA")
SET REASON=$$GET1^DIQ(52.45,$$PRESOLV^PSOERXA1(REASON,"REA"),.02)
+21 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="Reason: "_$$COMPARE^PSOERUT0("LM",$EXTRACT(REASON,1,30),$EXTRACT(REASON,1,30),9,,LMLINE)
+22 IF $LENGTH(REASON)>31
Begin DoDot:3
+23 FOR I=1:1
SET REASON=$EXTRACT(REASON,32,999)
if REASON=""
QUIT
Begin DoDot:4
+24 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(REASON,1,31),$EXTRACT(REASON,1,31),9,,LMLINE)
End DoDot:4
End DoDot:3
+25 SET RESULT=$PIECE(PDUE(DUESEQ),"^",4)
IF $$PRESOLV^PSOERXA1(RESULT,"RES")
SET RESULT=$$GET1^DIQ(52.45,$$PRESOLV^PSOERXA1(RESULT,"RES"),.02)
+26 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="Result: "_$$COMPARE^PSOERUT0("LM",$EXTRACT(RESULT,1,31),$EXTRACT(RESULT,1,31),9,,LMLINE)
+27 IF $LENGTH(RESULT)>31
Begin DoDot:3
+28 FOR I=1:1
SET RESULT=$EXTRACT(RESULT,32,999)
if RESULT=""
QUIT
Begin DoDot:4
+29 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(RESULT,1,31),$EXTRACT(RESULT,1,31),8,,LMLINE)
End DoDot:4
End DoDot:3
+30 SET ACK=$PIECE(PDUE(DUESEQ),"^",9)
+31 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="Override: "_$$COMPARE^PSOERUT0("LM",$EXTRACT(ACK,1,28),$EXTRACT(ACK,1,28),11,,LMLINE)
+32 IF $LENGTH(ACK)>28
Begin DoDot:3
+33 FOR I=1:1
SET ACK=$EXTRACT(ACK,29,999)
if ACK=""
QUIT
Begin DoDot:4
+34 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(ACK,1,28),$EXTRACT(ACK,1,28),11,,LMLINE)
End DoDot:4
End DoDot:3
+35 IF $ORDER(PDUE(DUESEQ))
SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="......................................"
End DoDot:2
End DoDot:1
+36 ;
+37 SET XVI=0
SET LMLINE=LINE-1
+38 IF '$DATA(PENDATA)
Begin DoDot:1
+39 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=$SELECT('RENEWORD:"3) ",1:" ")_" *Dosage:"
End DoDot:1
QUIT
+40 FOR DOSE=1:1
if '$DATA(PENDATA("DOSE",DOSE))
QUIT
Begin DoDot:1
+41 IF '$GET(PENDATA("DOSE ORDERED",DOSE))
IF $GET(PENDATA("VERB",DOSE))]""
Begin DoDot:2
+42 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" Verb: "_$$COMPARE^PSOERUT0("LM",PENDATA("VERB",DOSE),PENDATA("VERB",DOSE),55,,LMLINE)
End DoDot:2
+43 SET DOSEX=PENDATA("DOSE",DOSE)
IF $EXTRACT(DOSEX,1)="."
IF $GET(PENDATA("DOSE ORDERED",DOSE))
SET DOSEX="0"_DOSEX
+44 IF $GET(PENDATA("UNITS",DOSE))]""
SET DOSEX=DOSEX_" ("_$$GET1^DIQ(50.607,PENDATA("UNITS",DOSE),.01)_")"
+45 DO WRAP^PSOERUT(DOSEX,24,.WRPDOSE)
+46 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=$SELECT(DOSE=1&'RENEWORD:"3)",1:" ")_" *Dosage: "_$$COMPARE^PSOERUT0("LM",$GET(WRPDOSE(1,0)),$GET(WRPDOSE(1,0)),55,,LMLINE)
+47 IF DOSE=1
IF 'RENEWORD
SET UNDERLN(LMLINE,41)=2
+48 FOR I=2:1
if '$DATA(WRPDOSE(I))
QUIT
Begin DoDot:2
+49 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$GET(WRPDOSE(I,0)),$GET(WRPDOSE(I,0)),55,,LMLINE)
End DoDot:2
+50 IF $GET(PENDATA("DOSE ORDERED",DOSE))
IF $GET(PENDATA("VERB",DOSE))]""
Begin DoDot:2
+51 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" Verb: "_$$COMPARE^PSOERUT0("LM",PENDATA("VERB",DOSE),PENDATA("VERB",DOSE),55,,LMLINE)
End DoDot:2
+52 IF '$GET(PENDATA("DOSE ORDERED",DOSE))
IF $PIECE($GET(^PS(55,DFN,"LAN")),"^")
Begin DoDot:2
+53 DO WRAP^PSOERUT($GET(PENDATA("ODOSE",DOSE)),22,.WRPDOSE)
+54 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)="*Oth.Lang.Dosage: "_$$COMPARE^PSOERUT0("LM",$GET(WRPDOSE(1,0)),$GET(WRPDOSE(1,0)),59,,LMLINE)
+55 FOR I=2:1
if '$DATA(WRPDOSE(I))
QUIT
Begin DoDot:3
+56 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$GET(WRPDOSE(I,0)),$GET(WRPDOSE(I,0)),59,,LMLINE)
End DoDot:3
End DoDot:2
+57 IF $GET(PENDATA("DOSE ORDERED",DOSE))'=""
Begin DoDot:2
+58 SET DISPUNTS=$SELECT($EXTRACT(PENDATA("DOSE ORDERED",DOSE),1)=".":"0",1:"")_PENDATA("DOSE ORDERED",DOSE)
+59 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" Disp. Units: "_$$COMPARE^PSOERUT0("LM",DISPUNTS,DISPUNTS,55,,LMLINE)
End DoDot:2
+60 IF $GET(PENDATA("NOUN",DOSE))'=""
Begin DoDot:2
+61 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" Noun: "_$$COMPARE^PSOERUT0("LM",PENDATA("NOUN",DOSE),PENDATA("NOUN",DOSE),55,,LMLINE)
End DoDot:2
+62 IF $GET(PENDATA("ROUTE",DOSE))
SET ROUTE=$$GET1^DIQ(51.2,PENDATA("ROUTE",DOSE),.01)
+63 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" *Route: "_$$COMPARE^PSOERUT0("LM",$GET(ROUTE),$GET(ROUTE),55,,LMLINE)
+64 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" *Schedule: "_$$COMPARE^PSOERUT0("LM",PENDATA("SCHEDULE",DOSE),PENDATA("SCHEDULE",DOSE),55,,LMLINE)
+65 IF $GET(PENDATA("DURATION",DOSE))'=""
Begin DoDot:2
+66 NEW DUR
SET DUR=PENDATA("DURATION",DOSE)
+67 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" *Duration: "_$$COMPARE^PSOERUT0("LM",DUR_" "_$$FREQ(DUR),DUR_" "_$$FREQ(DUR),55,,LMLINE)
End DoDot:2
+68 IF $GET(PENDATA("CONJUNCTION",DOSE))'=""
Begin DoDot:2
+69 SET CONJUNCT=$SELECT(PENDATA("CONJUNCTION",DOSE)="T":"THEN",PENDATA("CONJUNCTION",DOSE)="X":"EXCEPT",1:"AND")
+70 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)="*Conjunction: "_$$COMPARE^PSOERUT0("LM",CONJUNCT,CONJUNCT,55,,LMLINE)
End DoDot:2
End DoDot:1
+71 ;
+72 ; - Patient Instructions
+73 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)="________________________________________"
+74 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=$SELECT('RENEWORD:"4) ",1:"")_"Patient Instruction:"
+75 IF 'RENEWORD
SET UNDERLN(LMLINE,41)=2
+76 SET VAPATINS=""
FOR I=1:1
if '$DATA(PENDATA("SIG",I))
QUIT
SET VAPATINS=VAPATINS_" "_$$UP^XLFSTR($GET(PENDATA("SIG",I)))
+77 SET $EXTRACT(VAPATINS)=""
+78 IF VAPATINS'=""
Begin DoDot:1
+79 KILL VARR
DO WRAP^PSOERUT(VAPATINS,39,.VARR)
+80 FOR I=1:1
if '$DATA(VARR(I))
QUIT
Begin DoDot:2
+81 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$GET(VARR(I,0)),$GET(VARR(I,0)),42,,LMLINE)
End DoDot:2
End DoDot:1
+82 IF $ORDER(PENDATA("SINS",0))
Begin DoDot:1
+83 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" Other Lang. Pat. Instruct: :"
+84 SET VAOTHINS=""
FOR I=1:1
if '$DATA(PENDATA("SINS",I))
QUIT
SET VAOTHINS=VAOTHINS_" "_$$UP^XLFSTR($GET(PENDATA("SINS",I)))
+85 SET $EXTRACT(VAOTHINS)=""
+86 KILL VARR
DO WRAP^PSOERUT(VAOTHINS,39,.VARR)
+87 FOR I=1:1
if '$DATA(VARR(I))
QUIT
Begin DoDot:2
+88 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$GET(VARR(I,0)),$GET(VARR(I,0)),42,,LMLINE)
End DoDot:2
End DoDot:1
+89 ;
+90 ; - Setting eRx Prescriber Drug Use Evaluation (DUE), Matched Dosage and Patient Instructions
+91 FOR ALLLN=1:1
if ('$DATA(ERXLINES(ALLLN))&'$DATA(VALINES(ALLLN)))
QUIT
Begin DoDot:1
+92 SET ERXALLS=$GET(ERXLINES(ALLLN))
SET VAALLS=$GET(VALINES(ALLLN))
+93 SET XE=$GET(ERXLINES(ALLLN))
+94 SET XV="|"_$GET(VALINES(ALLLN))
+95 DO ADDLINE^PSOERUT0("LM",NMSPC,XE,XV)
End DoDot:1
+96 ;
+97 QUIT
+98 ;
PENFLAG(NMSPC,ORD) ; Backdoor ListManager Display of Flag/Unflag Information
+1 NEW FLAG,FLAGHDR,XX,FLAGCOMM
+2 ;
+3 DO GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
IF '$GET(FLAG(52.41,ORD_",",33,"I"))
QUIT
+4 SET XX="Order Flagged by "_FLAG(52.41,ORD_",",34,"E")_" on "_FLAG(52.41,ORD_",",33,"E")
+5 SET $EXTRACT(FLAGHDR,(81-$LENGTH(XX))/2)=XX
+6 SET UNDERLN(LINE,1)=100
+7 DO ADDLINE^PSOERUT0("LM",NMSPC,FLAGHDR,"")
+8 SET XX=FLAG(52.41,ORD_",",35,"E")
+9 FOR
if XX=""
QUIT
Begin DoDot:1
+10 SET FLAGCOMM=$EXTRACT(XX,1,79)
+11 SET FLAGCOMM=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(XX,1,79),$EXTRACT(XX,1,79),2)
SET XX=$EXTRACT(XX,80,9999)
+12 DO ADDLINE^PSOERUT0("LM",NMSPC,FLAGCOMM,"")
End DoDot:1
+13 IF FLAG(52.41,ORD_",",36,"I")'=""
Begin DoDot:1
+14 SET XX="Order Un-Flagged by "_FLAG(52.41,ORD_",",37,"E")_" on "_FLAG(52.41,ORD_",",36,"E")
+15 SET FLAGHDR=""
SET $EXTRACT(FLAGHDR,(81-$LENGTH(XX))/2)=XX
+16 SET UNDERLN(LINE,1)=100
+17 DO ADDLINE^PSOERUT0("LM",NMSPC,FLAGHDR,"")
+18 SET XX=FLAG(52.41,ORD_",",38,"E")
+19 FOR
if XX=""
QUIT
Begin DoDot:2
+20 SET FLAGCOMM=$EXTRACT(XX,1,79)
+21 SET FLAGCOMM=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(XX,1,79),$EXTRACT(XX,1,79),2)
SET XX=$EXTRACT(XX,80,9999)
+22 DO ADDLINE^PSOERUT0("LM",NMSPC,FLAGCOMM,"")
End DoDot:2
End DoDot:1
+23 DO BLANKLN^PSOERUT0("LM",1)
+24 QUIT
+25 ;
ACCDTBY(ERXIEN) ; Returns the eRx latest Accepted Date/Time
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ;Output: P1^P2 - P1: External Accepted Date/Time (MM/DD/YY) | P2: Accepted By Name
+3 ;
+4 NEW ACCDTBY,ACDTTM,ACBY,STHIS,FOUND,STAT
+5 SET ACCDTBY=""
SET STHIS=99999
SET FOUND=0
+6 FOR
SET STHIS=$ORDER(^PS(52.49,ERXIEN,19,STHIS),-1)
if 'STHIS!(FOUND)
QUIT
Begin DoDot:1
+7 SET STAT=$$GET1^DIQ(52.4919,STHIS_","_ERXIEN,.02,"I")
+8 IF ",PR,RXP,CXP,"[(","_$$GET1^DIQ(52.45,STAT,.01,"E")_",")
Begin DoDot:2
+9 SET ACCDTBY=$$FMTE^XLFDT($$GET1^DIQ(52.4919,STHIS_","_ERXIEN,.01,"I"),"2Y")_"^"_$$GET1^DIQ(52.4919,STHIS_","_ERXIEN,.03,"E")
+10 SET FOUND=1
End DoDot:2
End DoDot:1
+11 QUIT ACCDTBY
+12 ;
PROVCOMM(COMM) ; Expand Provider Comments
+1 ; Input: Provider Comments
+2 ;Output: Expanded Comments
+3 NEW PROVCOMM,X,PSODIR,INS1
+4 IF $GET(COMM)=""
QUIT ""
+5 SET COMM=$$UP^XLFSTR(COMM)
+6 SET (X,PSODIR("INS"))=COMM
DO SIG^PSOHELP
SET $EXTRACT(INS1)=""
SET PROVCOMM=INS1
+7 QUIT PROVCOMM
+8 ;
FREQ(DUR) ; Returns the Duration Frequency word (WEEKS, DAYS, etc..)
+1 ; Input: DUR - Schedule Duration (e.g., "4D", "3W", "6H", etc...)
+2 ;Output: Spelled out duration frequency between parenthesis ("(DAYS)", "(WEEKS)", "(HOURS)", etc...)
+3 SET DUR=$GET(DUR)
+4 IF DUR["M"
QUIT "(MINUTES)"
+5 IF DUR["H"
QUIT "(HOURS)"
+6 IF DUR["L"
QUIT "(MONTHS)"
+7 IF DUR["W"
QUIT "(WEEKS)"
+8 QUIT "(DAYS)"
