PSOERUT ;ALB/MFR - eRx Utilities; 06/25/2022 5:14pm
;;7.0;OUTPATIENT PHARMACY;**692,700,746,769**;DEC 1997;Build 26
;
DSPERX(ERXIEN) ; Displays eRx Info to the Screen
; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE (#52.49)
;
I '$D(^PS(52.49,+$G(ERXIEN),0)) Q
N HIGH,NORM,XX,ERXSIG,NOTES,MEDIEN,QTYQUAL
S HIGH=$G(IOINHI),NORM=$G(IOINORM)
S $P(XX,$S($D(IOUON):" ",1:"-"),81)="",$E(XX,34,45)="ORIGINAL ERX" W !,$G(IOUON),XX,$G(IOUOFF)
W !,"eRx Drug : ",HIGH,$$GET1^DIQ(52.49,ERXIEN,3.1),NORM
W !,"eRx SIG :" S ERXSIG=$$ERXSIG^PSOERXUT(ERXIEN)
F I=1:1 Q:ERXSIG="" W ?11,HIGH,$E(ERXSIG,1,69),NORM,! S ERXSIG=$E(ERXSIG,70,9999)
S NOTES=$$GET1^DIQ(52.49,ERXIEN,8)
I NOTES'="" W "eRx Notes:" F I=1:1 Q:NOTES="" W ?11,HIGH,$E(NOTES,1,68),NORM,! S NOTES=$E(NOTES,71,9999)
W "Drug Form: ",HIGH,$E($$GET1^DIQ(52.49,ERXIEN,41),1,44),NORM,?55,"Strength: ",HIGH,$E($$GET1^DIQ(52.49,ERXIEN,43),1,25),NORM
S MEDIEN=$O(^PS(52.49,ERXIEN,311,0)),QTYQUAL=$$GET1^DIQ(52.49311,MEDIEN_","_ERXIEN_",",2.2,"I"),QTYQUAL=$$GET1^DIQ(52.45,+QTYQUAL,.02,"E")
W !,"Qty Qualifier: ",HIGH,QTYQUAL,NORM,?40,"Qty Unit of Measure: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,42),NORM
W !,"Qty: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,5.1),NORM
W ?13,"Days Supply: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,5.5),NORM
W ?34,"Refills: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,5.6),NORM
W ?51,"Substitutions: ",HIGH,$S($$GET1^DIQ(52.49,ERXIEN,5.8,"I"):"NO",1:"YES"),NORM
S XX="",$P(XX,$S($D(IOUON):" ",1:"-"),81)="" W !,$G(IOUON),XX,$G(IOUOFF)
Q
;
XML2GBL(XML,OUTARR) ;Transfers XML incoming data into a TMP Gobal
; Input: XML - XML Message to be transferred to a Temp Global or Local Array
; OUTARR - Output Array (Temp Global or Local Array, e.g. $NA(^TMP($J,"PSOERUT")), "XMLMSG", "MSG(""ERX"")", etc.
;Output: Parsed XML data in the Temp Global or Local Array
;
; Protecting from saving non-TEMP globals
I $G(OUTARR)["^",$E(OUTARR,1,5)'="^TMP(",$E(OUTARR,1,6)'="^XTMP(" Q
;
K @OUTARR
N STATUS,READER,ARRDPTH,PRVDPTH,SEQ
S PRVDPTH=0,ARRDPTH=$S(OUTARR[",":$L(OUTARR,","),OUTARR[")":1,1:0)
S STATUS=##class(%XML.TextReader).ParseStream(XML,.READER)
I $$STATCHK^XOBWLIB(STATUS,.XOBERR,1) D
. F Q:'READER.Read()!READER.EOF D
. . I (READER.Depth'<PRVDPTH),READER.LocalName'="" D
. . . S SEQ=+$O(@$NA(@OUTARR@(READER.LocalName,999999)),-1)+1
. . . S OUTARR=$NA(@OUTARR@(READER.LocalName,SEQ))
. . E S:READER.Depth<PRVDPTH OUTARR=$NA(@OUTARR,ARRDPTH+(READER.Depth*2))
. . I (READER.Value'="") D
. . . S @(OUTARR)=READER.Value
. . S PRVDPTH=READER.Depth
Q
;
PATNAME(ERXIEN) ; Returns the eRx Patient Name for a specific eRx Record
; Input: ERXIEN - eRx IEN - Pointer to #52.49
;Output: PATNAME - eRx Patient Name
N PATIEN,MTYPE,PATNAME,NEWERX
S PATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04)
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S PATNAME=$$GET1^DIQ(52.46,PATIEN,.01,"E") I MTYPE="IE"!(MTYPE="OE") S PATNAME=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
I PATNAME="" D
. S NEWERX=$$RESOLV^PSOERXU2(ERXIEN)
. I NEWERX S PATNAME=$$GET1^DIQ(52.49,ERXIEN,.04,"E")
. I PATNAME="" S PATNAME="N/A"
Q PATNAME
;
EPATFLST(MAXSIZE) ; Returns the eRx Patient Filter as a String List
;Input: MAXSIZE - Maximum Size for the String
N PAT,PATFLST,TMP,PATNAM
I '$D(PATFLTR) Q ""
S PATFLST=""
S PAT=0 F S PAT=$O(PATFLTR(PAT)) Q:'PAT D
. S PATNAM=$$GET1^DIQ(52.46,PAT,.01) I PATNAM="" Q
. S:'$D(TMP(PATNAM)) PATFLST=PATFLST_"|"_PATNAM
. S TMP(PATNAM)=""
S $E(PATFLST,1)=""
I $L(PATFLST)>MAXSIZE S PATFLST=$E(PATFLST,1,MAXSIZE-3)_"..."
Q PATFLST
;
VPATFLST(MAXSIZE) ; Returns the VistA Patient Filter as a String List
;Input: MAXSIZE - Maximum Size for the String
N VPAT,VPATFLST,TMP,PATNAM
I '$D(VPATFLTR) Q ""
S VPATFLST=""
S VPAT=0 F S VPAT=$O(VPATFLTR(VPAT)) Q:'VPAT D
. S PATNAM=$$GET1^DIQ(2,VPAT,.01) I PATNAM="" Q
. S:'$D(TMP(PATNAM)) VPATFLST=VPATFLST_"|"_PATNAM
. S TMP(PATNAM)=""
S $E(VPATFLST,1)=""
I $L(VPATFLST)>MAXSIZE S VPATFLST=$E(VPATFLST,1,MAXSIZE-3)_"..."
Q VPATFLST
;
VPRVFLST(MAXSIZE) ; Returns the VistA Provider Filter as a String List
;Input: MAXSIZE - Maximum Size for the String
N VPRV,VPRVFLST,TMP,PRVNAM
I '$D(VPRVFLTR) Q ""
S VPRVFLST=""
S VPRV=0 F S VPRV=$O(VPRVFLTR(VPRV)) Q:'VPRV D
. S PRVNAM=$$GET1^DIQ(200,VPRV,.01) I PRVNAM="" Q
. S:'$D(TMP(PRVNAM)) VPRVFLST=VPRVFLST_"|"_PRVNAM
. S TMP(PRVNAM)=""
S $E(VPRVFLST,1)=""
I $L(VPRVFLST)>MAXSIZE S VPRVFLST=$E(VPRVFLST,1,MAXSIZE-3)_"..."
Q VPRVFLST
;
EPRVFLST(MAXSIZE) ; Returns the eRx Provider Filter as a String List
;Input: MAXSIZE - Maximum Size for the String
N PRV,PRVFLST,TMP,PRVNAM
I '$D(PRVFLTR) Q ""
S PRVFLST=""
S PRV=0 F S PRV=$O(PRVFLTR(PRV)) Q:'PRV D
. S PRVNAM=$$GET1^DIQ(52.48,PRV,.01) I PRVNAM="" Q
. S:'$D(TMP(PRVNAM)) PRVFLST=PRVFLST_"|"_$$GET1^DIQ(52.48,PRV,.01)
. S TMP(PRVNAM)=""
S $E(PRVFLST,1)=""
I $L(PRVFLST)>MAXSIZE S PRVFLST=$E(PRVFLST,1,MAXSIZE-3)_"..."
Q PRVFLST
;
STATEABB(FILE,IEN) ; Returns the Patient or Provider State Abbreviation (eRx and VistA)
; Input: FILE - VistA File # (Can be 2, 200, 52.46 or 52.48)
; IEN - Internal Entry #
;Output: Abbreviated State (e.g., "TX", "AZ", "NY", etc...)
N STATEIEN,FIELD
S FIELD=$S(FILE=2:.115,FILE=52.46:3.4,FILE=200:.115,FILE=52.48:4.4,1:0) I 'FIELD!'$G(IEN) Q ""
S STATEIEN=$$GET1^DIQ(FILE,IEN,FIELD,"I") I 'STATEIEN Q ""
Q $$GET1^DIQ(5,STATEIEN,1)
;
LASTREDT(XREF,IEN) ; Returns the Last eRx Received Date for a VistA Patient OR Provider
;Input: XREF - "AVPAT": VistA Patient | "AVPRV": VistA Provider
; IEN - Pointer to either VistA Patient (#2) or VistA Provider (#200)
N LASTREDT,EIEN
S LASTREDT=""
S EIEN=0 F S EIEN=$O(^PS(52.49,XREF,+$G(IEN),EIEN)) Q:'EIEN D
. I $O(^PS(52.49,XREF,+$G(IEN),EIEN,9999999),-1)>LASTREDT D
. . S LASTREDT=$O(^PS(52.49,XREF,+$G(IEN),EIEN,9999999),-1)\1
Q LASTREDT
;
SSN(SSN) ; Returns the formatted SSN (999-99-9999)
; Input: SSN - Unformatted SSN (999999999)
;Output: Formatted SSN (999-99-9999)
S SSN=$$NUMERIC^PSOASAP0(SSN)
I $G(SSN)=""!(SSN'?.N)!($L(SSN)'=9) Q ""
Q $E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
;
ACTIONSTS(STS) ; Returns whether the eRx status is Actionable or no
; Input: STS - eRx Status. It can be external (e.g.,"N","RXF","RRN", etc...) or internal value (pointer to #52.45)
;Output: 1 - Actionable Status | 0 - Non-actionable status
;
I $G(STS) S STS=$$GET1^DIQ(52.45,STS,.01)
I $G(STS)="" Q 0
I ",N,H,I,W,CAH,CAO,CAP,CAR,CAX,CAF,RXN,RXD,RXR,RXI,RXW,RXF,RXE,RRE,CXN,CXI,CXD,CXW,CXV,CXY,CXE,CRE,"[(","_STS_",") Q 1
Q 0
;
C2S(STR) ; Replaces commas with spaces (for auto-wrap to work) - Arbitrarily using '@' (not likely to be on the string)
N C2S
S C2S=$TR(STR," ","@")
S C2S=$TR(C2S,","," ")
Q C2S
;
S2C(STR) ; Replaces spaces with commas (for auto-wrap to work)
N S2C
S S2C=$TR(STR," ",",")
S S2C=$TR(S2C,"@"," ")
I $E(S2C,$L(S2C))="," S $E(S2C,$L(S2C))=""
Q S2C
;
SORT(STR) ; Sorts a comma (,) separated list alphabetically
N I,SARR,SSTR,WORD
F I=1:1:$L(STR,",") I $TR($P(STR,",",I)," ")'="" S SARR($P(STR,",",I))=""
S (SSTR,WORD)="" F S WORD=$O(SARR(WORD)) Q:WORD="" S SSTR=SSTR_","_WORD
S $E(SSTR)=""
Q SSTR
;
WRAP(STRING,LENGTH,WRPSTR) ; Formats a String into an Array
; Input: STRING - String to be formatted/wrapped in multiple lines
; LENGHT - Text line length
;Output: .WRPSTR - String wrapped (Passed in by Reference)
;
N X,I,DIWL,DIWR,DIWF,TOOLONG K WRPSTR
S X=STRING K ^UTILITY($J,"W") S DIWL=1,DIWR=LENGTH,DIWF="|" D ^DIWP
S TOOLONG=0 F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) I $L($$TRIM^XLFSTR(^UTILITY($J,"W",1,I,0)))>LENGTH S TOOLONG=1 Q
I 'TOOLONG D
. F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S WRPSTR(I,0)=$$TRIM^XLFSTR(^UTILITY($J,"W",1,I,0))
E D
. S STRING=$$TRIM^XLFSTR(STRING)
. F I=1:1 Q:STRING="" D
. . S WRPSTR(I,0)=$E(STRING,1,LENGTH),STRING=$E(STRING,LENGTH+1,9999)
I $G(WRPSTR(1,0))=" ",'$O(WRPSTR(1)) K WRPSTR
Q
;
SADRGVRX(ERXIEN,RXIEN) ; Sets the "ADRGVRX" cross-reference on the ERX HOLDING QUEUE file (#52.49),
; PHARMACY PRESCRIPTION NUMBER field (#.13)
; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
; RXIEN - Pointer to the PRESCRIPTION file (#52)
I '$D(^PS(52.49,+$G(ERXIEN),0))!'$D(^PSRX(+$G(RXIEN),0)) Q
N PSOHASH
I $$GET1^DIQ(52.49,ERXIEN,1)'="PR" Q
S PSOHASH=$$DRUGHASH(ERXIEN) I 'PSOHASH Q
S ^PS(52.49,"ADRGVRX",PSOHASH,RXIEN,ERXIEN)=""
Q
;
KADRGVRX(ERXIEN,RXIEN) ; Kills the "ADRGVRX" cross-reference on the ERX HOLDING QUEUE file (#52.49),
; PHARMACY PRESCRIPTION NUMBER field (#.13)
; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
; RXIEN - Pointer to the PRESCRIPTION file (#52)
I '$D(^PS(52.49,+$G(ERXIEN),0))!'$D(^PSRX(+$G(RXIEN),0)) Q
N PSOHASH
S PSOHASH=$$DRUGHASH^PSOERUT(ERXIEN) I 'PSOHASH Q
K ^PS(52.49,"ADRGVRX",PSOHASH,RXIEN,ERXIEN)
Q
;
DRUGHASH(ERXIEN,FACTOR) ; Return the Drug Information corresponding Hash Value (Recursivity used)
; Input: ERXIEN - Pointer to the eRx being worked on (Pointer to #52.49)
; FACTOR - Counter used to prevent wrong matches
;Output: DRUGHASH - Hash value calculated based on the Drug information for the eRx passed in
;
;NOTICE: Any change that alters the hash value will require the ADRGVRX cross-reference to be rebuild
;
N DRUGHASH,DRUGSIGH,MTYPE,RSPTYPE,DRUG,NDCCODE,DRUGSIG,QTY,SUBS,DAYS,REFS,X,I
S DRUGHASH=0 I '$G(ERXIEN) Q 0
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S RSPTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
S DRUG=$$GETDRUG^PSOERXU5(ERXIEN) I DRUG="" Q 0
S NDCCODE=$TR($TR($$GET1^DIQ(52.49,ERXIEN,4.1)," "),"-")
I NDCCODE="" S NDCCODE=$TR($TR($$GET1^DIQ(52.49311,"1,"_ERXIEN_",",1.1,"I")," "),"-")
I NDCCODE="" Q 0
S QTY=+$$GET1^DIQ(52.49,ERXIEN,5.1) I 'QTY Q 0
S SUBS=+$$GET1^DIQ(52.49,ERXIEN,5.8,"I")
S DAYS=+$$GET1^DIQ(52.49,ERXIEN,5.5,"I")
S REFS=+$$GET1^DIQ(52.49,ERXIEN,5.6,"I") I MTYPE="RE",RSPTYPE="R",REFS>0 S REFS=$G(REFS)-1
; Concatenating Drug Name+SIG for Hash Calculation
S DRUGSIGH=0,DRUGSIG=$E(DRUG_$$UANSIG(ERXIEN),1,200) I DRUGSIG="" Q 0
F I=1:1:$L(DRUGSIG) S DRUGSIGH=($A(DRUGSIG,I)*(5**(I-1)))+DRUGSIGH
S DRUGSIGH=DRUGSIGH#1000009+$G(FACTOR)
; NDC Code|Drug Name+SIG Hash|Substitution|Qty|Days Supply|# of Refills
S DRUGHASH=NDCCODE_DRUGSIGH_SUBS_$E(1000+QTY,2,4)_$E(1000+DAYS,2,4)_$E(100+REFS,2,3)
; Checks if the SIG matches other eRx Sig's, if not increment FACTOR and try again (Recursive call)
I '$$SAMESIG(ERXIEN,DRUGHASH) D
. S DRUGHASH=$$DRUGHASH(ERXIEN,$G(FACTOR)+1)
;
Q DRUGHASH
;
SAMESIG(ERXIEN,HASH) ; Check if SIG matches other eRx with same Hash code
; Input: ERXIEN - Pointer to the eRx being worked on (Pointer to #52.49)
; DRUGHASH - Hash value calculated based on the Drug information for the eRx passed in
;Output: 1: SIG matches previous eRx Sigs (or no previous eRx with same Hash) | 0: SIG is different
N SAMESIG,RX,ERX
S SAMESIG=1 I '$G(ERXIEN)!'$G(HASH) Q 1
S RX=$O(^PS(52.49,"ADRGVRX",HASH,0)) I RX D
. S ERX=$O(^PS(52.49,"ADRGVRX",HASH,RX,0)) I ERX,ERX'=ERXIEN D
. . I $$UANSIG(ERX)'=$$UANSIG(ERXIEN) S SAMESIG=0
Q SAMESIG
;
UANSIG(ERXIEN) ; Returns the SIG in upper case with alphanumeric chars only
; Input: ERXIEN - Pointer to the eRx being worked on (Pointer to #52.49)
;Output: UANSIG - eRx SIG in upper case and alphanumeric chars (e.g.: TAKE1TABLETPOONCEADAY)
N UANSIG,X,I
S UANSIG="",X=$$UP^XLFSTR($$ERXSIG^PSOERXUT(ERXIEN))
F I=1:1:$L(X) I $E(X,I)?.AN S UANSIG=UANSIG_$E(X,I)
Q UANSIG
;
SUGFLDT(ORDIEN) ; Returns the Suggested Fill Date for the eRx Pending Order
; Input: ORDIEN - Ponter to the Pending Order (Pointer to #52.41)
;Output: SUGFLDT - p1: Suggested Fill Date for the Pending Order (YYYMMDD)
; p2: If p1>TODAY, return the pointer to the Rx from last fill (pointer to #52)
N SUGFLDT,ERXIEN,NUMREFS,DAYSSUP,ISSUEDT,DONE,DFN,DRUG,RXIEN,DFN,SEQ,RXSTS,FILLDATE,RELDATE,LASTFILL
I '$D(^PS(52.41,+$G(ORDIEN),0)) Q DT
S SUGFLDT=DT,ERXIEN=$$ERXIEN^PSOERXUT(ORDIEN_"P")
S DFN=$$GET1^DIQ(52.41,ORDIEN,1,"I"),DRUG=$$GET1^DIQ(52.41,ORDIEN,11,"I")
S (DONE)=0,SEQ=99999 F S SEQ=$O(^PS(55,DFN,"P",SEQ),-1) Q:'SEQ D I DONE Q
. S RXIEN=+$G(^PS(55,DFN,"P",SEQ,0)) I 'RXIEN Q
. S RXSTS=+$$GET1^DIQ(52,RXIEN,100,"I") I ",0,3,5,11,12,14,15,"'[(","_RXSTS_",") Q
. I $$GET1^DIQ(52,RXIEN,6,"I")'=DRUG Q
. S DONE=1
. I '$$SAMEDOSE^PSOERUT7(ERXIEN,RXIEN) Q
. S LASTFILL=$$LSTRFL^PSOBPSU1(RXIEN)
. S RELDATE=$$RXRLDT^PSOBPSUT(RXIEN,LASTFILL)\1
. S FILLDATE=$$RXFLDT^PSOBPSUT(RXIEN,LASTFILL)
. ; Last Fill is not released, is Suspended, Not Transmitted/Printed, Future Fill Date
. I 'RELDATE,(RXSTS=5),FILLDATE>DT D S DONE=1 Q
. . S SUGFLDT=FILLDATE_"^"_RXIEN
. ; Last Fill is released and Last Fill + Days Supply is in the future
. I RELDATE,$$FMADD^XLFDT(RELDATE,$$GET1^DIQ(52,RXIEN,8))>DT D S DONE=1 Q
. . S SUGFLDT=$$FMADD^XLFDT(RELDATE,$$GET1^DIQ(52,RXIEN,8))_"^"_RXIEN
. ; Last Fill is not released but fill is transmitted to CMOP
. I 'RELDATE,$$CMOPSTS(RXIEN,LASTFILL)=0!($$CMOPSTS(RXIEN,LASTFILL)=2) D S DONE=1 Q
. . S SUGFLDT=$$FMADD^XLFDT(DT,$$GET1^DIQ(52,RXIEN,8))_"^"_RXIEN
. S SUGFLDT=DT_"^"_RXIEN
; If Pending order has no refills and Suggested Fill Date is after Issue Date+Days Supply, suggest TODAY
S NUMREFS=$$GET1^DIQ(52.41,ORDIEN,13,"I"),DAYSSUP=$$GET1^DIQ(52.41,ORDIEN,101,"I")
S ISSUEDT=$$GET1^DIQ(52.41,ORDIEN,6,"I") I 'ISSUEDT S ISSUEDT=DT
I 'NUMREFS,SUGFLDT>$$FMADD^XLFDT(ISSUEDT,DAYSSUP) S $P(SUGFLDT,"^",1)=DT
;
Q SUGFLDT
;
VARXSIG(RXIEN) ; Returns the VistA Rx SIG (From the PRESCRIPTION file (#52))
; Input: RXIEN - Pointer to the PRESCRIPTION file (#52)
;Output: .DOSEARR - Return Array Containing Dosage Information
N VARXSIG,SIG
S VARXSIG="",RXIEN=+$G(RXIEN)
S SIG=0 F S SIG=$O(^PSRX(RXIEN,"SIG1",SIG)) Q:'SIG D
. I $E(VARXSIG,$L(VARXSIG))'=" " S VARXSIG=VARXSIG_" "
. S VARXSIG=VARXSIG_$G(^PSRX(RXIEN,"SIG1",SIG,0))
Q VARXSIG
;
CMOPSTS(RXIEN,FILL) ; Returns the CMOP Status for the Rx Fill
; Input: RXIEN - Rx IEN (#52)
; FILL - Fill # (0 for original)
;Output: CMOP Status for the Rx Fill ("":NOT A CMOP FILL;0:TRANSMITTED;1:DISPENSED;2:RETRANSMITTED;3:NOT DISPENSED)
N CMOPSTS,CMOP,Z
S CMOPSTS="",CMOP=999 F S CMOP=$O(^PSRX(RXIEN,4,CMOP),-1) Q:'CMOP D I CMOPSTS="" Q
. S Z=$G(^PSRX(RXIEN,4,CMOP,0))
. I +$P(Z,"^",3)=FILL S CMOPSTS=$P(Z,"^",4)
Q CMOPSTS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERUT 14615 printed Dec 13, 2024@02:28 Page 2
PSOERUT ;ALB/MFR - eRx Utilities; 06/25/2022 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**692,700,746,769**;DEC 1997;Build 26
+2 ;
DSPERX(ERXIEN) ; Displays eRx Info to the Screen
+1 ; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE (#52.49)
+2 ;
+3 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))
QUIT
+4 NEW HIGH,NORM,XX,ERXSIG,NOTES,MEDIEN,QTYQUAL
+5 SET HIGH=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+6 SET $PIECE(XX,$SELECT($DATA(IOUON):" ",1:"-"),81)=""
SET $EXTRACT(XX,34,45)="ORIGINAL ERX"
WRITE !,$GET(IOUON),XX,$GET(IOUOFF)
+7 WRITE !,"eRx Drug : ",HIGH,$$GET1^DIQ(52.49,ERXIEN,3.1),NORM
+8 WRITE !,"eRx SIG :"
SET ERXSIG=$$ERXSIG^PSOERXUT(ERXIEN)
+9 FOR I=1:1
if ERXSIG=""
QUIT
WRITE ?11,HIGH,$EXTRACT(ERXSIG,1,69),NORM,!
SET ERXSIG=$EXTRACT(ERXSIG,70,9999)
+10 SET NOTES=$$GET1^DIQ(52.49,ERXIEN,8)
+11 IF NOTES'=""
WRITE "eRx Notes:"
FOR I=1:1
if NOTES=""
QUIT
WRITE ?11,HIGH,$EXTRACT(NOTES,1,68),NORM,!
SET NOTES=$EXTRACT(NOTES,71,9999)
+12 WRITE "Drug Form: ",HIGH,$EXTRACT($$GET1^DIQ(52.49,ERXIEN,41),1,44),NORM,?55,"Strength: ",HIGH,$EXTRACT($$GET1^DIQ(52.49,ERXIEN,43),1,25),NORM
+13 SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,0))
SET QTYQUAL=$$GET1^DIQ(52.49311,MEDIEN_","_ERXIEN_",",2.2,"I")
SET QTYQUAL=$$GET1^DIQ(52.45,+QTYQUAL,.02,"E")
+14 WRITE !,"Qty Qualifier: ",HIGH,QTYQUAL,NORM,?40,"Qty Unit of Measure: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,42),NORM
+15 WRITE !,"Qty: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,5.1),NORM
+16 WRITE ?13,"Days Supply: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,5.5),NORM
+17 WRITE ?34,"Refills: ",HIGH,$$GET1^DIQ(52.49,ERXIEN,5.6),NORM
+18 WRITE ?51,"Substitutions: ",HIGH,$SELECT($$GET1^DIQ(52.49,ERXIEN,5.8,"I"):"NO",1:"YES"),NORM
+19 SET XX=""
SET $PIECE(XX,$SELECT($DATA(IOUON):" ",1:"-"),81)=""
WRITE !,$GET(IOUON),XX,$GET(IOUOFF)
+20 QUIT
+21 ;
XML2GBL(XML,OUTARR) ;Transfers XML incoming data into a TMP Gobal
+1 ; Input: XML - XML Message to be transferred to a Temp Global or Local Array
+2 ; OUTARR - Output Array (Temp Global or Local Array, e.g. $NA(^TMP($J,"PSOERUT")), "XMLMSG", "MSG(""ERX"")", etc.
+3 ;Output: Parsed XML data in the Temp Global or Local Array
+4 ;
+5 ; Protecting from saving non-TEMP globals
+6 IF $GET(OUTARR)["^"
IF $EXTRACT(OUTARR,1,5)'="^TMP("
IF $EXTRACT(OUTARR,1,6)'="^XTMP("
QUIT
+7 ;
+8 KILL @OUTARR
+9 NEW STATUS,READER,ARRDPTH,PRVDPTH,SEQ
+10 SET PRVDPTH=0
SET ARRDPTH=$SELECT(OUTARR[",":$LENGTH(OUTARR,","),OUTARR[")":1,1:0)
+11 SET STATUS=##class(%XML.TextReader).ParseStream(XML,.READER)
+12 IF $$STATCHK^XOBWLIB(STATUS,.XOBERR,1)
Begin DoDot:1
+13 FOR
if 'READER.Read()!READER.EOF
QUIT
Begin DoDot:2
+14 IF (READER.Depth'<PRVDPTH)
IF READER.LocalName'=""
Begin DoDot:3
+15 SET SEQ=+$ORDER(@$NAME(@OUTARR@(READER.LocalName,999999)),-1)+1
+16 SET OUTARR=$NAME(@OUTARR@(READER.LocalName,SEQ))
End DoDot:3
+17 IF '$TEST
if READER.Depth<PRVDPTH
SET OUTARR=$NAME(@OUTARR,ARRDPTH+(READER.Depth*2))
+18 IF (READER.Value'="")
Begin DoDot:3
+19 SET @(OUTARR)=READER.Value
End DoDot:3
+20 SET PRVDPTH=READER.Depth
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
PATNAME(ERXIEN) ; Returns the eRx Patient Name for a specific eRx Record
+1 ; Input: ERXIEN - eRx IEN - Pointer to #52.49
+2 ;Output: PATNAME - eRx Patient Name
+3 NEW PATIEN,MTYPE,PATNAME,NEWERX
+4 SET PATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04)
+5 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+6 SET PATNAME=$$GET1^DIQ(52.46,PATIEN,.01,"E")
IF MTYPE="IE"!(MTYPE="OE")
SET PATNAME=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
+7 IF PATNAME=""
Begin DoDot:1
+8 SET NEWERX=$$RESOLV^PSOERXU2(ERXIEN)
+9 IF NEWERX
SET PATNAME=$$GET1^DIQ(52.49,ERXIEN,.04,"E")
+10 IF PATNAME=""
SET PATNAME="N/A"
End DoDot:1
+11 QUIT PATNAME
+12 ;
EPATFLST(MAXSIZE) ; Returns the eRx Patient Filter as a String List
+1 ;Input: MAXSIZE - Maximum Size for the String
+2 NEW PAT,PATFLST,TMP,PATNAM
+3 IF '$DATA(PATFLTR)
QUIT ""
+4 SET PATFLST=""
+5 SET PAT=0
FOR
SET PAT=$ORDER(PATFLTR(PAT))
if 'PAT
QUIT
Begin DoDot:1
+6 SET PATNAM=$$GET1^DIQ(52.46,PAT,.01)
IF PATNAM=""
QUIT
+7 if '$DATA(TMP(PATNAM))
SET PATFLST=PATFLST_"|"_PATNAM
+8 SET TMP(PATNAM)=""
End DoDot:1
+9 SET $EXTRACT(PATFLST,1)=""
+10 IF $LENGTH(PATFLST)>MAXSIZE
SET PATFLST=$EXTRACT(PATFLST,1,MAXSIZE-3)_"..."
+11 QUIT PATFLST
+12 ;
VPATFLST(MAXSIZE) ; Returns the VistA Patient Filter as a String List
+1 ;Input: MAXSIZE - Maximum Size for the String
+2 NEW VPAT,VPATFLST,TMP,PATNAM
+3 IF '$DATA(VPATFLTR)
QUIT ""
+4 SET VPATFLST=""
+5 SET VPAT=0
FOR
SET VPAT=$ORDER(VPATFLTR(VPAT))
if 'VPAT
QUIT
Begin DoDot:1
+6 SET PATNAM=$$GET1^DIQ(2,VPAT,.01)
IF PATNAM=""
QUIT
+7 if '$DATA(TMP(PATNAM))
SET VPATFLST=VPATFLST_"|"_PATNAM
+8 SET TMP(PATNAM)=""
End DoDot:1
+9 SET $EXTRACT(VPATFLST,1)=""
+10 IF $LENGTH(VPATFLST)>MAXSIZE
SET VPATFLST=$EXTRACT(VPATFLST,1,MAXSIZE-3)_"..."
+11 QUIT VPATFLST
+12 ;
VPRVFLST(MAXSIZE) ; Returns the VistA Provider Filter as a String List
+1 ;Input: MAXSIZE - Maximum Size for the String
+2 NEW VPRV,VPRVFLST,TMP,PRVNAM
+3 IF '$DATA(VPRVFLTR)
QUIT ""
+4 SET VPRVFLST=""
+5 SET VPRV=0
FOR
SET VPRV=$ORDER(VPRVFLTR(VPRV))
if 'VPRV
QUIT
Begin DoDot:1
+6 SET PRVNAM=$$GET1^DIQ(200,VPRV,.01)
IF PRVNAM=""
QUIT
+7 if '$DATA(TMP(PRVNAM))
SET VPRVFLST=VPRVFLST_"|"_PRVNAM
+8 SET TMP(PRVNAM)=""
End DoDot:1
+9 SET $EXTRACT(VPRVFLST,1)=""
+10 IF $LENGTH(VPRVFLST)>MAXSIZE
SET VPRVFLST=$EXTRACT(VPRVFLST,1,MAXSIZE-3)_"..."
+11 QUIT VPRVFLST
+12 ;
EPRVFLST(MAXSIZE) ; Returns the eRx Provider Filter as a String List
+1 ;Input: MAXSIZE - Maximum Size for the String
+2 NEW PRV,PRVFLST,TMP,PRVNAM
+3 IF '$DATA(PRVFLTR)
QUIT ""
+4 SET PRVFLST=""
+5 SET PRV=0
FOR
SET PRV=$ORDER(PRVFLTR(PRV))
if 'PRV
QUIT
Begin DoDot:1
+6 SET PRVNAM=$$GET1^DIQ(52.48,PRV,.01)
IF PRVNAM=""
QUIT
+7 if '$DATA(TMP(PRVNAM))
SET PRVFLST=PRVFLST_"|"_$$GET1^DIQ(52.48,PRV,.01)
+8 SET TMP(PRVNAM)=""
End DoDot:1
+9 SET $EXTRACT(PRVFLST,1)=""
+10 IF $LENGTH(PRVFLST)>MAXSIZE
SET PRVFLST=$EXTRACT(PRVFLST,1,MAXSIZE-3)_"..."
+11 QUIT PRVFLST
+12 ;
STATEABB(FILE,IEN) ; Returns the Patient or Provider State Abbreviation (eRx and VistA)
+1 ; Input: FILE - VistA File # (Can be 2, 200, 52.46 or 52.48)
+2 ; IEN - Internal Entry #
+3 ;Output: Abbreviated State (e.g., "TX", "AZ", "NY", etc...)
+4 NEW STATEIEN,FIELD
+5 SET FIELD=$SELECT(FILE=2:.115,FILE=52.46:3.4,FILE=200:.115,FILE=52.48:4.4,1:0)
IF 'FIELD!'$GET(IEN)
QUIT ""
+6 SET STATEIEN=$$GET1^DIQ(FILE,IEN,FIELD,"I")
IF 'STATEIEN
QUIT ""
+7 QUIT $$GET1^DIQ(5,STATEIEN,1)
+8 ;
LASTREDT(XREF,IEN) ; Returns the Last eRx Received Date for a VistA Patient OR Provider
+1 ;Input: XREF - "AVPAT": VistA Patient | "AVPRV": VistA Provider
+2 ; IEN - Pointer to either VistA Patient (#2) or VistA Provider (#200)
+3 NEW LASTREDT,EIEN
+4 SET LASTREDT=""
+5 SET EIEN=0
FOR
SET EIEN=$ORDER(^PS(52.49,XREF,+$GET(IEN),EIEN))
if 'EIEN
QUIT
Begin DoDot:1
+6 IF $ORDER(^PS(52.49,XREF,+$GET(IEN),EIEN,9999999),-1)>LASTREDT
Begin DoDot:2
+7 SET LASTREDT=$ORDER(^PS(52.49,XREF,+$GET(IEN),EIEN,9999999),-1)\1
End DoDot:2
End DoDot:1
+8 QUIT LASTREDT
+9 ;
SSN(SSN) ; Returns the formatted SSN (999-99-9999)
+1 ; Input: SSN - Unformatted SSN (999999999)
+2 ;Output: Formatted SSN (999-99-9999)
+3 SET SSN=$$NUMERIC^PSOASAP0(SSN)
+4 IF $GET(SSN)=""!(SSN'?.N)!($LENGTH(SSN)'=9)
QUIT ""
+5 QUIT $EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
+6 ;
ACTIONSTS(STS) ; Returns whether the eRx status is Actionable or no
+1 ; Input: STS - eRx Status. It can be external (e.g.,"N","RXF","RRN", etc...) or internal value (pointer to #52.45)
+2 ;Output: 1 - Actionable Status | 0 - Non-actionable status
+3 ;
+4 IF $GET(STS)
SET STS=$$GET1^DIQ(52.45,STS,.01)
+5 IF $GET(STS)=""
QUIT 0
+6 IF ",N,H,I,W,CAH,CAO,CAP,CAR,CAX,CAF,RXN,RXD,RXR,RXI,RXW,RXF,RXE,RRE,CXN,CXI,CXD,CXW,CXV,CXY,CXE,CRE,"[(","_STS_",")
QUIT 1
+7 QUIT 0
+8 ;
C2S(STR) ; Replaces commas with spaces (for auto-wrap to work) - Arbitrarily using '@' (not likely to be on the string)
+1 NEW C2S
+2 SET C2S=$TRANSLATE(STR," ","@")
+3 SET C2S=$TRANSLATE(C2S,","," ")
+4 QUIT C2S
+5 ;
S2C(STR) ; Replaces spaces with commas (for auto-wrap to work)
+1 NEW S2C
+2 SET S2C=$TRANSLATE(STR," ",",")
+3 SET S2C=$TRANSLATE(S2C,"@"," ")
+4 IF $EXTRACT(S2C,$LENGTH(S2C))=","
SET $EXTRACT(S2C,$LENGTH(S2C))=""
+5 QUIT S2C
+6 ;
SORT(STR) ; Sorts a comma (,) separated list alphabetically
+1 NEW I,SARR,SSTR,WORD
+2 FOR I=1:1:$LENGTH(STR,",")
IF $TRANSLATE($PIECE(STR,",",I)," ")'=""
SET SARR($PIECE(STR,",",I))=""
+3 SET (SSTR,WORD)=""
FOR
SET WORD=$ORDER(SARR(WORD))
if WORD=""
QUIT
SET SSTR=SSTR_","_WORD
+4 SET $EXTRACT(SSTR)=""
+5 QUIT SSTR
+6 ;
WRAP(STRING,LENGTH,WRPSTR) ; Formats a String into an Array
+1 ; Input: STRING - String to be formatted/wrapped in multiple lines
+2 ; LENGHT - Text line length
+3 ;Output: .WRPSTR - String wrapped (Passed in by Reference)
+4 ;
+5 NEW X,I,DIWL,DIWR,DIWF,TOOLONG
KILL WRPSTR
+6 SET X=STRING
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=LENGTH
SET DIWF="|"
DO ^DIWP
+7 SET TOOLONG=0
FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
IF $LENGTH($$TRIM^XLFSTR(^UTILITY($JOB,"W",1,I,0)))>LENGTH
SET TOOLONG=1
QUIT
+8 IF 'TOOLONG
Begin DoDot:1
+9 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET WRPSTR(I,0)=$$TRIM^XLFSTR(^UTILITY($JOB,"W",1,I,0))
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET STRING=$$TRIM^XLFSTR(STRING)
+12 FOR I=1:1
if STRING=""
QUIT
Begin DoDot:2
+13 SET WRPSTR(I,0)=$EXTRACT(STRING,1,LENGTH)
SET STRING=$EXTRACT(STRING,LENGTH+1,9999)
End DoDot:2
End DoDot:1
+14 IF $GET(WRPSTR(1,0))=" "
IF '$ORDER(WRPSTR(1))
KILL WRPSTR
+15 QUIT
+16 ;
SADRGVRX(ERXIEN,RXIEN) ; Sets the "ADRGVRX" cross-reference on the ERX HOLDING QUEUE file (#52.49),
+1 ; PHARMACY PRESCRIPTION NUMBER field (#.13)
+2 ; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 ; RXIEN - Pointer to the PRESCRIPTION file (#52)
+4 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))!'$DATA(^PSRX(+$GET(RXIEN),0))
QUIT
+5 NEW PSOHASH
+6 IF $$GET1^DIQ(52.49,ERXIEN,1)'="PR"
QUIT
+7 SET PSOHASH=$$DRUGHASH(ERXIEN)
IF 'PSOHASH
QUIT
+8 SET ^PS(52.49,"ADRGVRX",PSOHASH,RXIEN,ERXIEN)=""
+9 QUIT
+10 ;
KADRGVRX(ERXIEN,RXIEN) ; Kills the "ADRGVRX" cross-reference on the ERX HOLDING QUEUE file (#52.49),
+1 ; PHARMACY PRESCRIPTION NUMBER field (#.13)
+2 ; Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 ; RXIEN - Pointer to the PRESCRIPTION file (#52)
+4 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))!'$DATA(^PSRX(+$GET(RXIEN),0))
QUIT
+5 NEW PSOHASH
+6 SET PSOHASH=$$DRUGHASH^PSOERUT(ERXIEN)
IF 'PSOHASH
QUIT
+7 KILL ^PS(52.49,"ADRGVRX",PSOHASH,RXIEN,ERXIEN)
+8 QUIT
+9 ;
DRUGHASH(ERXIEN,FACTOR) ; Return the Drug Information corresponding Hash Value (Recursivity used)
+1 ; Input: ERXIEN - Pointer to the eRx being worked on (Pointer to #52.49)
+2 ; FACTOR - Counter used to prevent wrong matches
+3 ;Output: DRUGHASH - Hash value calculated based on the Drug information for the eRx passed in
+4 ;
+5 ;NOTICE: Any change that alters the hash value will require the ADRGVRX cross-reference to be rebuild
+6 ;
+7 NEW DRUGHASH,DRUGSIGH,MTYPE,RSPTYPE,DRUG,NDCCODE,DRUGSIG,QTY,SUBS,DAYS,REFS,X,I
+8 SET DRUGHASH=0
IF '$GET(ERXIEN)
QUIT 0
+9 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+10 SET RSPTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
+11 SET DRUG=$$GETDRUG^PSOERXU5(ERXIEN)
IF DRUG=""
QUIT 0
+12 SET NDCCODE=$TRANSLATE($TRANSLATE($$GET1^DIQ(52.49,ERXIEN,4.1)," "),"-")
+13 IF NDCCODE=""
SET NDCCODE=$TRANSLATE($TRANSLATE($$GET1^DIQ(52.49311,"1,"_ERXIEN_",",1.1,"I")," "),"-")
+14 IF NDCCODE=""
QUIT 0
+15 SET QTY=+$$GET1^DIQ(52.49,ERXIEN,5.1)
IF 'QTY
QUIT 0
+16 SET SUBS=+$$GET1^DIQ(52.49,ERXIEN,5.8,"I")
+17 SET DAYS=+$$GET1^DIQ(52.49,ERXIEN,5.5,"I")
+18 SET REFS=+$$GET1^DIQ(52.49,ERXIEN,5.6,"I")
IF MTYPE="RE"
IF RSPTYPE="R"
IF REFS>0
SET REFS=$GET(REFS)-1
+19 ; Concatenating Drug Name+SIG for Hash Calculation
+20 SET DRUGSIGH=0
SET DRUGSIG=$EXTRACT(DRUG_$$UANSIG(ERXIEN),1,200)
IF DRUGSIG=""
QUIT 0
+21 FOR I=1:1:$LENGTH(DRUGSIG)
SET DRUGSIGH=($ASCII(DRUGSIG,I)*(5**(I-1)))+DRUGSIGH
+22 SET DRUGSIGH=DRUGSIGH#1000009+$GET(FACTOR)
+23 ; NDC Code|Drug Name+SIG Hash|Substitution|Qty|Days Supply|# of Refills
+24 SET DRUGHASH=NDCCODE_DRUGSIGH_SUBS_$EXTRACT(1000+QTY,2,4)_$EXTRACT(1000+DAYS,2,4)_$EXTRACT(100+REFS,2,3)
+25 ; Checks if the SIG matches other eRx Sig's, if not increment FACTOR and try again (Recursive call)
+26 IF '$$SAMESIG(ERXIEN,DRUGHASH)
Begin DoDot:1
+27 SET DRUGHASH=$$DRUGHASH(ERXIEN,$GET(FACTOR)+1)
End DoDot:1
+28 ;
+29 QUIT DRUGHASH
+30 ;
SAMESIG(ERXIEN,HASH) ; Check if SIG matches other eRx with same Hash code
+1 ; Input: ERXIEN - Pointer to the eRx being worked on (Pointer to #52.49)
+2 ; DRUGHASH - Hash value calculated based on the Drug information for the eRx passed in
+3 ;Output: 1: SIG matches previous eRx Sigs (or no previous eRx with same Hash) | 0: SIG is different
+4 NEW SAMESIG,RX,ERX
+5 SET SAMESIG=1
IF '$GET(ERXIEN)!'$GET(HASH)
QUIT 1
+6 SET RX=$ORDER(^PS(52.49,"ADRGVRX",HASH,0))
IF RX
Begin DoDot:1
+7 SET ERX=$ORDER(^PS(52.49,"ADRGVRX",HASH,RX,0))
IF ERX
IF ERX'=ERXIEN
Begin DoDot:2
+8 IF $$UANSIG(ERX)'=$$UANSIG(ERXIEN)
SET SAMESIG=0
End DoDot:2
End DoDot:1
+9 QUIT SAMESIG
+10 ;
UANSIG(ERXIEN) ; Returns the SIG in upper case with alphanumeric chars only
+1 ; Input: ERXIEN - Pointer to the eRx being worked on (Pointer to #52.49)
+2 ;Output: UANSIG - eRx SIG in upper case and alphanumeric chars (e.g.: TAKE1TABLETPOONCEADAY)
+3 NEW UANSIG,X,I
+4 SET UANSIG=""
SET X=$$UP^XLFSTR($$ERXSIG^PSOERXUT(ERXIEN))
+5 FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)?.AN
SET UANSIG=UANSIG_$EXTRACT(X,I)
+6 QUIT UANSIG
+7 ;
SUGFLDT(ORDIEN) ; Returns the Suggested Fill Date for the eRx Pending Order
+1 ; Input: ORDIEN - Ponter to the Pending Order (Pointer to #52.41)
+2 ;Output: SUGFLDT - p1: Suggested Fill Date for the Pending Order (YYYMMDD)
+3 ; p2: If p1>TODAY, return the pointer to the Rx from last fill (pointer to #52)
+4 NEW SUGFLDT,ERXIEN,NUMREFS,DAYSSUP,ISSUEDT,DONE,DFN,DRUG,RXIEN,DFN,SEQ,RXSTS,FILLDATE,RELDATE,LASTFILL
+5 IF '$DATA(^PS(52.41,+$GET(ORDIEN),0))
QUIT DT
+6 SET SUGFLDT=DT
SET ERXIEN=$$ERXIEN^PSOERXUT(ORDIEN_"P")
+7 SET DFN=$$GET1^DIQ(52.41,ORDIEN,1,"I")
SET DRUG=$$GET1^DIQ(52.41,ORDIEN,11,"I")
+8 SET (DONE)=0
SET SEQ=99999
FOR
SET SEQ=$ORDER(^PS(55,DFN,"P",SEQ),-1)
if 'SEQ
QUIT
Begin DoDot:1
+9 SET RXIEN=+$GET(^PS(55,DFN,"P",SEQ,0))
IF 'RXIEN
QUIT
+10 SET RXSTS=+$$GET1^DIQ(52,RXIEN,100,"I")
IF ",0,3,5,11,12,14,15,"'[(","_RXSTS_",")
QUIT
+11 IF $$GET1^DIQ(52,RXIEN,6,"I")'=DRUG
QUIT
+12 SET DONE=1
+13 IF '$$SAMEDOSE^PSOERUT7(ERXIEN,RXIEN)
QUIT
+14 SET LASTFILL=$$LSTRFL^PSOBPSU1(RXIEN)
+15 SET RELDATE=$$RXRLDT^PSOBPSUT(RXIEN,LASTFILL)\1
+16 SET FILLDATE=$$RXFLDT^PSOBPSUT(RXIEN,LASTFILL)
+17 ; Last Fill is not released, is Suspended, Not Transmitted/Printed, Future Fill Date
+18 IF 'RELDATE
IF (RXSTS=5)
IF FILLDATE>DT
Begin DoDot:2
+19 SET SUGFLDT=FILLDATE_"^"_RXIEN
End DoDot:2
SET DONE=1
QUIT
+20 ; Last Fill is released and Last Fill + Days Supply is in the future
+21 IF RELDATE
IF $$FMADD^XLFDT(RELDATE,$$GET1^DIQ(52,RXIEN,8))>DT
Begin DoDot:2
+22 SET SUGFLDT=$$FMADD^XLFDT(RELDATE,$$GET1^DIQ(52,RXIEN,8))_"^"_RXIEN
End DoDot:2
SET DONE=1
QUIT
+23 ; Last Fill is not released but fill is transmitted to CMOP
+24 IF 'RELDATE
IF $$CMOPSTS(RXIEN,LASTFILL)=0!($$CMOPSTS(RXIEN,LASTFILL)=2)
Begin DoDot:2
+25 SET SUGFLDT=$$FMADD^XLFDT(DT,$$GET1^DIQ(52,RXIEN,8))_"^"_RXIEN
End DoDot:2
SET DONE=1
QUIT
+26 SET SUGFLDT=DT_"^"_RXIEN
End DoDot:1
IF DONE
QUIT
+27 ; If Pending order has no refills and Suggested Fill Date is after Issue Date+Days Supply, suggest TODAY
+28 SET NUMREFS=$$GET1^DIQ(52.41,ORDIEN,13,"I")
SET DAYSSUP=$$GET1^DIQ(52.41,ORDIEN,101,"I")
+29 SET ISSUEDT=$$GET1^DIQ(52.41,ORDIEN,6,"I")
IF 'ISSUEDT
SET ISSUEDT=DT
+30 IF 'NUMREFS
IF SUGFLDT>$$FMADD^XLFDT(ISSUEDT,DAYSSUP)
SET $PIECE(SUGFLDT,"^",1)=DT
+31 ;
+32 QUIT SUGFLDT
+33 ;
VARXSIG(RXIEN) ; Returns the VistA Rx SIG (From the PRESCRIPTION file (#52))
+1 ; Input: RXIEN - Pointer to the PRESCRIPTION file (#52)
+2 ;Output: .DOSEARR - Return Array Containing Dosage Information
+3 NEW VARXSIG,SIG
+4 SET VARXSIG=""
SET RXIEN=+$GET(RXIEN)
+5 SET SIG=0
FOR
SET SIG=$ORDER(^PSRX(RXIEN,"SIG1",SIG))
if 'SIG
QUIT
Begin DoDot:1
+6 IF $EXTRACT(VARXSIG,$LENGTH(VARXSIG))'=" "
SET VARXSIG=VARXSIG_" "
+7 SET VARXSIG=VARXSIG_$GET(^PSRX(RXIEN,"SIG1",SIG,0))
End DoDot:1
+8 QUIT VARXSIG
+9 ;
CMOPSTS(RXIEN,FILL) ; Returns the CMOP Status for the Rx Fill
+1 ; Input: RXIEN - Rx IEN (#52)
+2 ; FILL - Fill # (0 for original)
+3 ;Output: CMOP Status for the Rx Fill ("":NOT A CMOP FILL;0:TRANSMITTED;1:DISPENSED;2:RETRANSMITTED;3:NOT DISPENSED)
+4 NEW CMOPSTS,CMOP,Z
+5 SET CMOPSTS=""
SET CMOP=999
FOR
SET CMOP=$ORDER(^PSRX(RXIEN,4,CMOP),-1)
if 'CMOP
QUIT
Begin DoDot:1
+6 SET Z=$GET(^PSRX(RXIEN,4,CMOP,0))
+7 IF +$PIECE(Z,"^",3)=FILL
SET CMOPSTS=$PIECE(Z,"^",4)
End DoDot:1
IF CMOPSTS=""
QUIT
+8 QUIT CMOPSTS
