- 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 Jan 18, 2025@03:29:09 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