MHVXRXM ;BAA - Medication extract ; [12/14/06 11:38am]
;;1.0;My HealtheVet;**40**;Aug 23, 2005;Build 26
;;Per VA Directive 6402, this routine should not be modified
; Copied from MHVXRX
Q
;
;
; Retrieves requested prescription data and returns it in DATAROOT
; Retrieves all prescriptions of all statuses in given date range
; Statuses of deleted are filtered by the pharmacy API.
;
; Integration Agreements:
; 4821 : NONVA^PSO5241
; 4821 : PEN^PSO5241
; 4820 : RX^PSO52API
; 4827 : PSS^PSO59
; 4533 : ARWS^PSS50
; 10040 : Hospital Location file
; 10090 : Institution file
;
;
; Input:
; QRY - Query array
; QRY(DFN) - (required) Pointer to PATIENT (#2) file
; QRY(FROM) - Date to start from
; QRY(TO) - Date to go to
; DATAROOT - Root of array to hold extract data
;
; Output:
; DATAROOT - Populated data array, includes # of hits
; ERR - Errors during extraction
;
N U,DT,HIT,FROM,TO,STA,DRUG,DIV,MHVSTAT,RXN,MHVDATE,INDEX,DFN,SIG,STAT
N IEN,DRUGNM,DSPDT,ISSDT,LSTFDT,NXTFLDT,FLDT,RELDTTM,EXPDT,STATUS,NUM
N QTY,DSUP,NUMRF,PROV,PORDNUM,MAIL,DIV,REMARKS,SOURCE,LIST,OTRKNM,NDC,LIST
N CLINIC,REFDT,SCHD,NDC,TRDNM,CANDT,ORDR,ADMCLN,CMOP,DGNDC,TOTRF,UNDX,DISC,REM
N PACTY,PADD1,PANAM,PAPHN,PASTA,PAZIP,RXCNT,TRAN,PASITE,PHPHN,REASON,RCOM
;
D LOG^MHVUL2("MHVXRM EXTRACT","BEGIN","S","TRACE")
S U="^",DT=$$DT^XLFDT
S ERR=0,HIT=0
K @DATAROOT
K ^TMP($J,"MHV"),^TMP($J,"MHVNV"),^TMP($J,"MHVPD"),^TMP($J,"MHVPS"),^TMP($J,"MHVPA")
S DFN=$G(QRY("DFN"))
S FROM=$G(QRY("FROM"))
S TO=$G(QRY("TO"))
;
;don't show any non active rx greater than 90 days
S:FROM="" FROM=2000101 ;1/1/1900
S:TO="" TO=9999999 ;If no date set to way into the future
;
D RX^PSO52API(DFN,"MHV",,,"0,3,R,P,O,M,C,A,CPRS,ST",FROM,TO)
D PEN^PSO5241(DFN,"MHVPD")
D NONVA^PSO5241(DFN,"MHVNV")
;
D PROCESS
;
K ^TMP($J,"MHV"),^TMP($J,"MHVNV"),^TMP($J,"MHVPD"),^TMP($J,"MHVPS"),^TMP($J,"MHVPA"),^TMP($J,"MHVDG"),^TMP($J,"PTR")
D LOG^MHVUL2("MHVXRM EXTRACT","END","S","TRACE")
Q
;
PROCESS ;
S LIST="MHV"
S INDEX=0
F S INDEX=$O(^TMP($J,LIST,DFN,INDEX)) Q:INDEX="" D
.D INIT
.D MHV
;
I ^TMP($J,"MHVNV",DFN,0)>0 D PRONV
I ^TMP($J,"MHVPD",DFN,0)>0 D PROPD
Q
;
MHV ;
I +^TMP($J,LIST,DFN,0)=-1 Q
S RXN=^TMP($J,LIST,DFN,INDEX,.01)
I RXN="" Q
S STA=$P($G(^TMP($J,LIST,DFN,INDEX,100)),"^",1) ;status
Q:STA=13
D SETDATA
D DATAROOT
;
I +^TMP($J,LIST,DFN,INDEX,"RF",0)>0 D REFILL
I +^TMP($J,LIST,DFN,INDEX,"P",0)>0 D PARTIAL
Q
;
SETDATA ; setup data for original prescription
S UNDX=""
S MHVSTAT=$$AP2^PSOPRA(DFN,RXN)
S MHVDATE=$P(MHVSTAT,"^",2)
S MHVSTAT=$P(MHVSTAT,"^",1)
I MHVSTAT>0 I $$AP5^PSOPRA(DFN,RXN)
S IEN=INDEX
S DRUG=$P($G(^TMP($J,LIST,DFN,INDEX,6)),"^",1) ;drug ien
S DRUGNM=$P($G(^TMP($J,LIST,DFN,INDEX,6)),"^",2) ;drug name
D GETDRG(DRUG,DRUGNM)
S NDC=$G(^TMP($J,LIST,DFN,INDEX,27)) ;RX NDC
I NDC="" S NDC=DGNDC
S DSPDT=$P($G(^TMP($J,LIST,DFN,INDEX,25)),"^",1) ;dispense date
S ISSDT=$P($G(^TMP($J,LIST,DFN,INDEX,1)),"^",1) ;issue date
S LSTFDT=$P($G(^TMP($J,LIST,DFN,INDEX,22)),"^",1) ;last fill date
S NXTFLDT=$P($G(^TMP($J,LIST,DFN,INDEX,102)),"^",1) ;next fill date
S FLDT=$P($G(^TMP($J,LIST,DFN,INDEX,22)),"^",1) ;fill date
S RELDTTM=$P($G(^TMP($J,LIST,DFN,INDEX,31)),"^",1) ;release date & time
S STAT=$P($G(^TMP($J,LIST,DFN,INDEX,100)),"^",2) ;status
S EXPDT=$P($G(^TMP($J,LIST,DFN,INDEX,26)),"^",1) ;expiration date
S STATUS=$S(STA<12&(EXPDT<DT):"EXPIRED",1:STAT)
I STATUS["DISCONTINUED" S STATUS="DISCONTINUED"
S QTY=$G(^TMP($J,LIST,DFN,INDEX,7)) ;quantitY
S DSUP=$G(^TMP($J,LIST,DFN,INDEX,8)) ;days supply
S (NUMRF,TOTRF)=$G(^TMP($J,LIST,DFN,INDEX,9))
S PROV=$G(^TMP($J,LIST,DFN,INDEX,4)) ;provider
S PORDNUM=$P($G(^TMP($J,LIST,DFN,INDEX,39.3)),"^",1) ;placer order number
S MAIL=$P($G(^TMP($J,LIST,DFN,INDEX,11)),"^",1) ;mail (W/M)
S DIV=$G(^TMP($J,LIST,DFN,INDEX,20))_U_$G(^TMP($J,LIST,DFN,INDEX,20,0)) ;division
S REMARKS=$G(^TMP($J,LIST,DFN,INDEX,12)) ;remarks
S SOURCE="RX"
S TRDNM=$G(^TMP($J,LIST,DFN,INDEX,6.5)) ;trade name
S CANDT=$P($G(^TMP($J,LIST,DFN,INDEX,26.1)),"^",1) ;cancel date
S CLINIC=$P($G(^TMP($J,LIST,DFN,INDEX,5)),"^",2) ;clinic
S CMOP=$$CMOP(INDEX,0) ;cmop data
S OTRKNM=$$TRACK(INDEX,"ORIGINAL")
S REASON=$$ACTLG(INDEX,"ORIGINAL")
S RCOM=$P(REASON,"^",2),REASON=$P(REASON,"^",1)
S ORDR=$P($G(^TMP($J,LIST,DFN,IEN,"OI")),"^",2) ;ORDERABLE ITEM
I ORDR="NO DATA FOUND" S ORDR=""
S ADMCLN=+$G(^TMP($J,LIST,DFN,INDEX,14)) ;ADMINISTERED IN CLINIC
S ADMCLN=$S(ADMCLN=1:"YES",1:"NO")
S PAIEN=$P($G(^TMP($J,LIST,DFN,INDEX,20)),U,1)
I PAIEN'="" D GETPHRM(PAIEN)
Q
;
REFILL ; process refills
N RF,TRFL
S TRFL=$G(^TMP($J,LIST,DFN,INDEX,9))
S RF=0
S SOURCE="RF"
F S RF=$O(^TMP($J,LIST,DFN,INDEX,"RF",RF)) Q:RF="" D SETRF(RF)
Q
;
SETRF(RF) ;
D INIT2
S RXN=^TMP($J,LIST,DFN,INDEX,.01)
I RXN="" Q
D STRFDT(RF)
D DATAROOT
I ^TMP($J,LIST,DFN,INDEX,"M",0)=-1 S @DATAROOT@(HIT,"SIG",0)=0
E M @DATAROOT@(HIT,"SIG")=^TMP($J,LIST,DFN,INDEX,"M")
Q
;
STRFDT(RF) ;
S UNDX="RF"_RF
S (FLDT,ISSDT)=$P($G(^TMP($J,LIST,DFN,INDEX,"RF",RF,.01)),"^",1)
S DSPDT=$P($G(^TMP($J,LIST,DFN,INDEX,"RF",RF,10.1)),"^",1)
S RELDTTM=$P($G(^TMP($J,LIST,DFN,INDEX,"RF",RF,17)),"^",1)
S QTY=$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,1))
S DSUP=$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,1.1))
S PROV=$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,15))
S MAIL=$P($G(^TMP($J,LIST,DFN,INDEX,"RF",RF,2)),"^",1)
S DIV=$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,8))_U_$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,8,0))
S REMARKS=$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,3))
S NDC=$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,11))
I NDC="" S NDC=DGNDC
S NUMRF=TOTRF-RF
S CMOP=$$CMOP(INDEX,RF)
S OTRKNM=$$TRACK(INDEX,"REFILL #"_RF)
S REASON=$$ACTLG(INDEX,"REFILL #"_RF)
S RCOM=$P(REASON,"^",2),REASON=$P(REASON,"^",1)
S ADMCLN=+$G(^TMP($J,LIST,DFN,INDEX,"RF",RF,23))
S ADMCLN=$S(ADMCLN=1:"YES",1:"NO")
S PAIEN=$P($G(^TMP($J,LIST,DFN,INDEX,"RF",RF,8)),U,1)
I PAIEN'="" D GETPHRM(PAIEN)
Q
;
PARTIAL ; process partial prescriptions
N PF
S PF=0
S SOURCE="PF"
F S PF=$O(^TMP($J,LIST,DFN,INDEX,"P",PF)) Q:PF="" D SETPF(PF)
Q
;
SETPF(PF) ;
D INIT2
S RXN=$G(^TMP($J,LIST,DFN,INDEX,.01))
I RXN="" Q
D STPFDT(PF)
D DATAROOT
I ^TMP($J,LIST,DFN,INDEX,"M",0)=-1 S @DATAROOT@(HIT,"SIG",0)=0
E M @DATAROOT@(HIT,"SIG")=^TMP($J,LIST,DFN,INDEX,"M")
Q
;
STPFDT(PF) ;
S UNDX="PF"_PF
S (FLDT,ISSDT)=$P($G(^TMP($J,LIST,DFN,INDEX,"P",PF,.01)),"^",1)
S DSPDT=$P($G(^TMP($J,LIST,DFN,INDEX,"P",PF,7.5)),"^",1)
S RELDTTM=$P($G(^TMP($J,LIST,DFN,INDEX,"P",PF,8)),"^",1)
S QTY=$G(^TMP($J,LIST,DFN,INDEX,"P",PF,.04))
S DSUP=$G(^TMP($J,LIST,DFN,INDEX,"P",PF,.041))
S PROV=$G(^TMP($J,LIST,DFN,INDEX,"P",PF,6))
S MAIL=$P($G(^TMP($J,LIST,DFN,INDEX,"P",PF,.02)),"^",1)
S DIV=$G(^TMP($J,LIST,DFN,INDEX,"P",PF,.09))_U_$G(^TMP($J,LIST,DFN,INDEX,"P",PF,.09,0))
S REMARKS=$G(^TMP($J,LIST,DFN,INDEX,"P",PF,.03))
S NDC=$G(^TMP($J,LIST,DFN,INDEX,"P",PF,1))
I NDC="" S NDC=DGNDC
S PAIEN=$P($G(^TMP($J,LIST,DFN,INDEX,"P",PF,.09)),U,1)
I PAIEN'="" D GETPHRM(PAIEN)
Q
;
CMOP(IEN,RF) ; SET UP CMOP VARIABLES
N CM,CMP,CMOP
I +$G(^TMP($J,LIST,DFN,IEN,"C",0))'>0 Q ""
S CMP=+$G(^TMP($J,LIST,DFN,IEN,"C",0))
S CMOP=""
I CMP>0 D
.S CM=0 F S CM=$O(^TMP($J,LIST,DFN,IEN,"C",CM)) Q:CM="" D
..I ^TMP($J,LIST,DFN,IEN,"C",CM,2)=RF D
...S $P(CMOP,U,9)=$P(^TMP($J,LIST,DFN,IEN,"C",CM,9),"^",1)
...F I=2,3,4,10,11,12 D
....I $P(^TMP($J,LIST,DFN,IEN,"C",CM,I),"^",2)]"" S $P(CMOP,U,I)=$P(^TMP($J,LIST,DFN,IEN,"C",CM,I),"^",2)
....E S $P(CMOP,U,I)=$P(^TMP($J,LIST,DFN,IEN,"C",CM,I),"^",1)
Q CMOP
;
ACTLG(IEN,RF) ; Get info from activity log for Auto DC'ed info.
N RSN,COM,RC,RCOM
S (RSN,RC,COM,RCOM)=""
S AN=0 F S AN=$O(^TMP($J,LIST,DFN,IEN,"A",AN)) Q:AN="" D
.S RC=^TMP($J,LIST,DFN,IEN,"A",AN,.04)
.I RF=RC D
..S COM=^TMP($J,LIST,DFN,IEN,"A",AN,.05)
..I COM["Rx Discontinued by EHRM Data Migration." S RSN=$P(^TMP($J,LIST,DFN,IEN,"A",AN,.02),"^",2),RCOM=COM,COM=""
Q RSN_"^"_RCOM
;
TRACK(IEN,RF) ;
N TRKN,COM,AN,RC
S (TRKN,COM)=""
S AN=0 F S AN=$O(^TMP($J,LIST,DFN,IEN,"A",AN)) Q:AN="" D
.S RC=^TMP($J,LIST,DFN,IEN,"A",AN,.04)
.I RF=RC,$D(^TMP($J,LIST,DFN,IEN,"A",AN,"OC")) D TRK
TRACKQ Q TRKN
;
TRK ;
N TR,LINE
S TR=0
F S TR=$O(^TMP($J,LIST,DFN,IEN,"A",AN,"OC",TR)) Q:TR="" D
.S LINE=^TMP($J,LIST,DFN,IEN,"A",AN,"OC",TR,.01)
.I LINE["Mail Tracking Info.: " S TRKN=$P(LINE," ",4) S TRKN=$P(TRKN," ",1)
Q
;
GETPHRM(PAIEN) ;
I '$D(^TMP($J,"MHVPA",PAIEN)) D PSS^PSO59(PAIEN,,"MHVPA")
S PANAM=$P($G(^TMP($J,"MHVPA",PAIEN,.01)),2)
S PADD1=$G(^TMP($J,"MHVPA",PAIEN,.02))
S PAPHN=$G(^TMP($J,"MHVPA",PAIEN,.03))_"-"_$G(^TMP($J,"MHVPA",PAIEN,.04))
I PAPHN="-" S PHPHN=""
S PASITE=$G(^TMP($J,"MHVPA",PAIEN,.06))
S PACTY=$G(^TMP($J,"MHVPA",PAIEN,.07))
S PAZIP=$P($G(^TMP($J,"MHVPA",PAIEN,.05)),U,2)
S PASTA=$P($G(^TMP($J,"MHVPA",PAIEN,.08)),U,2)
Q
;
DATAROOT ;
S HIT=HIT+1
S @DATAROOT=HIT
S @DATAROOT@(HIT)=$G(RXN)_U_$G(DRUG)_U_$G(MHVSTAT)_U_$G(MHVDATE)
S @DATAROOT@(HIT,"P")=$G(PROV)
S @DATAROOT@(HIT,"RXN")=$G(INDEX)_U_$G(DRUGNM)_U_$G(ISSDT)_U_$G(LSTFDT)_U_$G(RELDTTM)_U_$G(EXPDT)_U_$G(CANDT)_U_$G(TRDNM)
S @DATAROOT@(HIT,"RXN1")=$G(STATUS)_U_$G(QTY)_U_$G(DSUP)_U_$G(NUMRF)_U_$G(PORDNUM)_U_$G(MAIL)_U_$G(UNDX)
S @DATAROOT@(HIT,"RXN2")=$G(SOURCE)_U_$G(NDC)_U_$G(DSPDT)_U_$G(REASON)_U_$G(RCOM)_U_$G(CANDT)
S @DATAROOT@(HIT,"RXN3")=$G(CLINIC)_U_$G(NXTFLDT)_U_$G(SCHD)_U_$G(OTRKNM)_U_$G(ORDR)_U_$G(ADMCLN)
S @DATAROOT@(HIT,"PHRM")=$G(PAIEN)_U_$G(PANAM)_U_$G(PADD1)_U_$G(PAPHN)_U_$G(PACTY)_U_$G(PAZIP)_U_$G(PASTA)_U_$G(PASITE)
S @DATAROOT@(HIT,"DIV")=$G(DIV)
S @DATAROOT@(HIT,"CMOP")=$G(CMOP)
I LIST="MHV" D
.I $P(^TMP($J,LIST,DFN,INDEX,"M",0),U,1)=-1 S @DATAROOT@(HIT,"SIG",0)=0
.E M @DATAROOT@(HIT,"SIG")=^TMP($J,LIST,DFN,INDEX,"M")
I LIST="MHV"!("MHVRF")!(LIST="MHVPF") D
.I REMARKS'="" S @DATAROOT@(HIT,"RMK",1,0)=REMARKS
.S @DATAROOT@(HIT,"RMK",0)=$S(REMARKS="":"",1:1)
Q
;
PRONV ;
S SOURCE="NV"
S LIST="MHVNV"
S INDEX=0
F S INDEX=$O(^TMP($J,LIST,DFN,INDEX)) Q:INDEX="" Q:INDEX="B" D MHVNV
Q
;
MHVNV ;Non VA medications
D INIT
N DOSAGE,MEDRT,SCHED,IEN4,PAIEN,CLNUM
S UNDX=""
S RXN=INDEX ;No prescription number exists
S STATUS=$P($G(^TMP($J,LIST,DFN,INDEX,5)),"^",2)
I STATUS="" S STATUS="ACTIVE"
S DRUG=$P($G(^TMP($J,LIST,DFN,INDEX,1)),"^",1)
S DRUGNM=$P($G(^TMP($J,LIST,DFN,INDEX,1)),"^",2) ;drug name
D GETDRG(DRUG,DRUGNM)
S NDC=DGNDC
S DOSAGE=$G(^TMP($J,LIST,DFN,INDEX,2))
S MEDRT=$G(^TMP($J,LIST,DFN,INDEX,3))
S SCHED=$G(^TMP($J,LIST,DFN,INDEX,4))
S SIG=DOSAGE_" "_MEDRT_" "_SCHED
S PROV=$G(^TMP($J,LIST,DFN,INDEX,12))
S LSTFDT=$P($G(^TMP($J,LIST,DFN,INDEX,8)),"^",1)
S ISSDT=$P($G(^TMP($J,LIST,DFN,INDEX,11)),"^",1)
S ISSDT=$P(ISSDT,".",1)
S EXPDT=$P($G(^TMP($J,LIST,DFN,INDEX,6)),"^",1)
S EXPDT=$P(EXPDT,".",1)
S CLNUM=$P($G(^TMP($J,LIST,DFN,INDEX,13)),"^",1)
S CLINIC=$P($G(^TMP($J,LIST,DFN,INDEX,13)),"^",2)
S REMARKS=$G(^TMP($J,LIST,DFN,INDEX,14))
S ORDR=$P($G(^TMP($J,LIST,DFN,INDEX,.01)),"^",2)
S IEN4=$$GET1^DIQ(44,CLNUM,3,"I") ; INSTITUTION file (#4) IEN
S PAIEN=$$GETPTR(IEN4)
I PAIEN'="" D GETPHRM(PAIEN)
D DATAROOT
S N=0 F I=0:1 S N=$O(^TMP($J,LIST,DFN,INDEX,14,N)) Q:N="" S @DATAROOT@(HIT,"RMK",N,0)=^TMP($J,LIST,DFN,INDEX,14,N)
S @DATAROOT@(HIT,"RMK",0)=$S(I=0:"",1:I)
;
S N=0 F I=0:1 S N=$O(^TMP($J,LIST,DFN,INDEX,10,N)) Q:N="" S @DATAROOT@(HIT,"DSC",N,0)=^TMP($J,LIST,DFN,INDEX,10,N)
S @DATAROOT@(HIT,"DSC",0)=$S(I=0:"",1:I)
;
S @DATAROOT@(HIT,"SIG",0)=1
S @DATAROOT@(HIT,"SIG",1,0)=SIG
Q
;
PROPD ;
S SOURCE="PD"
S LIST="MHVPD"
S INDEX=0
F S INDEX=$O(^TMP($J,LIST,DFN,INDEX)) Q:INDEX="" Q:INDEX="B" D MHVPD
Q
;
MHVPD ;Pending Medications
D INIT
N N,I,CIEN
S (RXN,IEN)=INDEX
S UNDX=""
S PORDNUM=$G(^TMP($J,LIST,DFN,INDEX,.01)) ; PLACER NUMBER
S DRUG=$P($G(^TMP($J,LIST,DFN,INDEX,11)),"^",1) ; DRUG
S DRUGNM=$P($G(^TMP($J,LIST,DFN,INDEX,11)),"^",2) ; drug name
S ORDR=$P($G(^TMP($J,LIST,DFN,INDEX,8)),"^",2) ; ORDERABLE ITEM
D GETDRG(DRUG,DRUGNM)
S NDC=DGNDC
S ISSDT=$P($G(^TMP($J,LIST,DFN,INDEX,15)),"^",1) ; LOGIN DATE
S ISSDT=$P(ISSDT,".",1)
S QTY=$P($G(^TMP($J,LIST,DFN,INDEX,12)),"^",1) ; QTANTITY
S DSUP=$P($G(^TMP($J,LIST,DFN,INDEX,101)),"^",1) ; DAY SUPPLY
S NUMRF=$P($G(^TMP($J,LIST,DFN,INDEX,13)),"^",1) ; NUMBER OF REFILLS
S PROV=$G(^TMP($J,LIST,DFN,INDEX,5)) ; PROVIDER
S MAIL=$P($G(^TMP($J,LIST,DFN,INDEX,19)),"^",1) ; MAIL
S STATUS=$P($G(^TMP($J,LIST,DFN,INDEX,2)),"^",2) ; ORDER TYPE (NW, HD, RNW, DE, DC, RP)
S CIEN=$P($G(^TMP($J,LIST,DFN,INDEX,100)),"^",1) ; Related institution FILE #4 POINTER
S CLINIC=$P($G(^TMP($J,LIST,DFN,INDEX,100)),"^",2) ; Related institution FILE #4 NAME
S PAIEN=$$GETPTR(CIEN)
I PAIEN'="" D GETPHRM(PAIEN)
D DATAROOT
S N=0 F I=0:1 S N=$O(^TMP($J,LIST,DFN,INDEX,24,N)) Q:N="" S @DATAROOT@(HIT,"SIG",N,0)=^TMP($J,LIST,DFN,INDEX,24,N)
S @DATAROOT@(HIT,"SIG",0)=I
Q
;
GETPTR(IEN4) ; FIND PHARMACY FIELDS
N OUT,PTR,STNM
S STNM=$$GET1^DIQ(4,IEN4,99,"I")
S OUT=""
D PSS^PSO59(,"??","PTR")
S PTR=0 F S PTR=$O(^TMP($J,"PTR",PTR)) Q:PTR="" Q:PTR="B" I ^TMP($J,"PTR",PTR,.06)=STNM S OUT=PTR Q
Q OUT
;
GETDRG(PSSI,PSSE) ;Drug Information
N PSNIEN,PSNFT
Q:PSSI=""
D ARWS^PSS50(PSSI,PSSE,"MHVDG")
S PSNFT=^TMP($J,"MHVDG",PSSI,21)
S DGNDC=^TMP($J,"MHVDG",PSSI,31)
S PSNIEN=$P(^TMP($J,"MHVDG",PSSI,22),"^",1)
I PSNIEN="" S SCHD="Unscheduled" Q
D DATA^PSN50P68(PSNIEN,PSNFT,"MHVPS")
S SCHD=$P(^TMP($J,"MHVPS",PSNIEN,19),"^",2)
Q
;
INIT ; set variables to null
S (MHVDATE,MHVSTAT,IEN,DRUG,DRUGNM,DSPDT,ISSDT,LSTFDT,NXTFLDT,FLDT,RELDTTM,EXPDT,STATUS)=""
S (QTY,DSUP,NUMRF,PROV,PORDNUM,MAIL,DIV,REMARKS,TRDNM,CANDT,OTRKNM,UNDX,DISC,REM)=""
S (CLINIC,REFDT,SCHD,NDC,ORDR,ADMCLN,CMOP,DGNDC,REMARKS,TOTRF,REASON,RCOM)=""
S (PANAM,PADD1,PAPHN,PACTY,PAZIP,PASTA)=""
Q
INIT2 ;init vars for partials and refills
S (IEN,DSPDT,ISSDT,FLDT,RELDTTM,UNDX)=""
S (QTY,DSUP,PROV,MAIL,DIV,REMARKS,OTRKNM)=""
S (ADMCLN,CMOP,REMARKS,REASON,RCOM,DISC,REM)=""
S (PANAM,PADD1,PAPHN,PACTY,PAZIP,PASTA)=""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMHVXRXM 14736 printed Apr 09, 2024@21:17:30 Page 2
MHVXRXM ;BAA - Medication extract ; [12/14/06 11:38am]
+1 ;;1.0;My HealtheVet;**40**;Aug 23, 2005;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ; Copied from MHVXRX
+4 QUIT
+5 ;
+6 ;
+1 ; Retrieves requested prescription data and returns it in DATAROOT
+2 ; Retrieves all prescriptions of all statuses in given date range
+3 ; Statuses of deleted are filtered by the pharmacy API.
+4 ;
+5 ; Integration Agreements:
+6 ; 4821 : NONVA^PSO5241
+7 ; 4821 : PEN^PSO5241
+8 ; 4820 : RX^PSO52API
+9 ; 4827 : PSS^PSO59
+10 ; 4533 : ARWS^PSS50
+11 ; 10040 : Hospital Location file
+12 ; 10090 : Institution file
+13 ;
+14 ;
+15 ; Input:
+16 ; QRY - Query array
+17 ; QRY(DFN) - (required) Pointer to PATIENT (#2) file
+18 ; QRY(FROM) - Date to start from
+19 ; QRY(TO) - Date to go to
+20 ; DATAROOT - Root of array to hold extract data
+21 ;
+22 ; Output:
+23 ; DATAROOT - Populated data array, includes # of hits
+24 ; ERR - Errors during extraction
+25 ;
+26 NEW U,DT,HIT,FROM,TO,STA,DRUG,DIV,MHVSTAT,RXN,MHVDATE,INDEX,DFN,SIG,STAT
+27 NEW IEN,DRUGNM,DSPDT,ISSDT,LSTFDT,NXTFLDT,FLDT,RELDTTM,EXPDT,STATUS,NUM
+28 NEW QTY,DSUP,NUMRF,PROV,PORDNUM,MAIL,DIV,REMARKS,SOURCE,LIST,OTRKNM,NDC,LIST
+29 NEW CLINIC,REFDT,SCHD,NDC,TRDNM,CANDT,ORDR,ADMCLN,CMOP,DGNDC,TOTRF,UNDX,DISC,REM
+30 NEW PACTY,PADD1,PANAM,PAPHN,PASTA,PAZIP,RXCNT,TRAN,PASITE,PHPHN,REASON,RCOM
+31 ;
+32 DO LOG^MHVUL2("MHVXRM EXTRACT","BEGIN","S","TRACE")
+33 SET U="^"
SET DT=$$DT^XLFDT
+34 SET ERR=0
SET HIT=0
+35 KILL @DATAROOT
+36 KILL ^TMP($JOB,"MHV"),^TMP($JOB,"MHVNV"),^TMP($JOB,"MHVPD"),^TMP($JOB,"MHVPS"),^TMP($JOB,"MHVPA")
+37 SET DFN=$GET(QRY("DFN"))
+38 SET FROM=$GET(QRY("FROM"))
+39 SET TO=$GET(QRY("TO"))
+40 ;
+41 ;don't show any non active rx greater than 90 days
+42 ;1/1/1900
if FROM=""
SET FROM=2000101
+43 ;If no date set to way into the future
if TO=""
SET TO=9999999
+44 ;
+45 DO RX^PSO52API(DFN,"MHV",,,"0,3,R,P,O,M,C,A,CPRS,ST",FROM,TO)
+46 DO PEN^PSO5241(DFN,"MHVPD")
+47 DO NONVA^PSO5241(DFN,"MHVNV")
+48 ;
+49 DO PROCESS
+50 ;
+51 KILL ^TMP($JOB,"MHV"),^TMP($JOB,"MHVNV"),^TMP($JOB,"MHVPD"),^TMP($JOB,"MHVPS"),^TMP($JOB,"MHVPA"),^TMP($JOB,"MHVDG"),^TMP($JOB,"PTR")
+52 DO LOG^MHVUL2("MHVXRM EXTRACT","END","S","TRACE")
+53 QUIT
+54 ;
PROCESS ;
+1 SET LIST="MHV"
+2 SET INDEX=0
+3 FOR
SET INDEX=$ORDER(^TMP($JOB,LIST,DFN,INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+4 DO INIT
+5 DO MHV
End DoDot:1
+6 ;
+7 IF ^TMP($JOB,"MHVNV",DFN,0)>0
DO PRONV
+8 IF ^TMP($JOB,"MHVPD",DFN,0)>0
DO PROPD
+9 QUIT
+10 ;
MHV ;
+1 IF +^TMP($JOB,LIST,DFN,0)=-1
QUIT
+2 SET RXN=^TMP($JOB,LIST,DFN,INDEX,.01)
+3 IF RXN=""
QUIT
+4 ;status
SET STA=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,100)),"^",1)
+5 if STA=13
QUIT
+6 DO SETDATA
+7 DO DATAROOT
+8 ;
+9 IF +^TMP($JOB,LIST,DFN,INDEX,"RF",0)>0
DO REFILL
+10 IF +^TMP($JOB,LIST,DFN,INDEX,"P",0)>0
DO PARTIAL
+11 QUIT
+12 ;
SETDATA ; setup data for original prescription
+1 SET UNDX=""
+2 SET MHVSTAT=$$AP2^PSOPRA(DFN,RXN)
+3 SET MHVDATE=$PIECE(MHVSTAT,"^",2)
+4 SET MHVSTAT=$PIECE(MHVSTAT,"^",1)
+5 IF MHVSTAT>0
IF $$AP5^PSOPRA(DFN,RXN)
+6 SET IEN=INDEX
+7 ;drug ien
SET DRUG=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,6)),"^",1)
+8 ;drug name
SET DRUGNM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,6)),"^",2)
+9 DO GETDRG(DRUG,DRUGNM)
+10 ;RX NDC
SET NDC=$GET(^TMP($JOB,LIST,DFN,INDEX,27))
+11 IF NDC=""
SET NDC=DGNDC
+12 ;dispense date
SET DSPDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,25)),"^",1)
+13 ;issue date
SET ISSDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,1)),"^",1)
+14 ;last fill date
SET LSTFDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,22)),"^",1)
+15 ;next fill date
SET NXTFLDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,102)),"^",1)
+16 ;fill date
SET FLDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,22)),"^",1)
+17 ;release date & time
SET RELDTTM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,31)),"^",1)
+18 ;status
SET STAT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,100)),"^",2)
+19 ;expiration date
SET EXPDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,26)),"^",1)
+20 SET STATUS=$SELECT(STA<12&(EXPDT<DT):"EXPIRED",1:STAT)
+21 IF STATUS["DISCONTINUED"
SET STATUS="DISCONTINUED"
+22 ;quantitY
SET QTY=$GET(^TMP($JOB,LIST,DFN,INDEX,7))
+23 ;days supply
SET DSUP=$GET(^TMP($JOB,LIST,DFN,INDEX,8))
+24 SET (NUMRF,TOTRF)=$GET(^TMP($JOB,LIST,DFN,INDEX,9))
+25 ;provider
SET PROV=$GET(^TMP($JOB,LIST,DFN,INDEX,4))
+26 ;placer order number
SET PORDNUM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,39.3)),"^",1)
+27 ;mail (W/M)
SET MAIL=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,11)),"^",1)
+28 ;division
SET DIV=$GET(^TMP($JOB,LIST,DFN,INDEX,20))_U_$GET(^TMP($JOB,LIST,DFN,INDEX,20,0))
+29 ;remarks
SET REMARKS=$GET(^TMP($JOB,LIST,DFN,INDEX,12))
+30 SET SOURCE="RX"
+31 ;trade name
SET TRDNM=$GET(^TMP($JOB,LIST,DFN,INDEX,6.5))
+32 ;cancel date
SET CANDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,26.1)),"^",1)
+33 ;clinic
SET CLINIC=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,5)),"^",2)
+34 ;cmop data
SET CMOP=$$CMOP(INDEX,0)
+35 SET OTRKNM=$$TRACK(INDEX,"ORIGINAL")
+36 SET REASON=$$ACTLG(INDEX,"ORIGINAL")
+37 SET RCOM=$PIECE(REASON,"^",2)
SET REASON=$PIECE(REASON,"^",1)
+38 ;ORDERABLE ITEM
SET ORDR=$PIECE($GET(^TMP($JOB,LIST,DFN,IEN,"OI")),"^",2)
+39 IF ORDR="NO DATA FOUND"
SET ORDR=""
+40 ;ADMINISTERED IN CLINIC
SET ADMCLN=+$GET(^TMP($JOB,LIST,DFN,INDEX,14))
+41 SET ADMCLN=$SELECT(ADMCLN=1:"YES",1:"NO")
+42 SET PAIEN=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,20)),U,1)
+43 IF PAIEN'=""
DO GETPHRM(PAIEN)
+44 QUIT
+45 ;
REFILL ; process refills
+1 NEW RF,TRFL
+2 SET TRFL=$GET(^TMP($JOB,LIST,DFN,INDEX,9))
+3 SET RF=0
+4 SET SOURCE="RF"
+5 FOR
SET RF=$ORDER(^TMP($JOB,LIST,DFN,INDEX,"RF",RF))
if RF=""
QUIT
DO SETRF(RF)
+6 QUIT
+7 ;
SETRF(RF) ;
+1 DO INIT2
+2 SET RXN=^TMP($JOB,LIST,DFN,INDEX,.01)
+3 IF RXN=""
QUIT
+4 DO STRFDT(RF)
+5 DO DATAROOT
+6 IF ^TMP($JOB,LIST,DFN,INDEX,"M",0)=-1
SET @DATAROOT@(HIT,"SIG",0)=0
+7 IF '$TEST
MERGE @DATAROOT@(HIT,"SIG")=^TMP($JOB,LIST,DFN,INDEX,"M")
+8 QUIT
+9 ;
STRFDT(RF) ;
+1 SET UNDX="RF"_RF
+2 SET (FLDT,ISSDT)=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,.01)),"^",1)
+3 SET DSPDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,10.1)),"^",1)
+4 SET RELDTTM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,17)),"^",1)
+5 SET QTY=$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,1))
+6 SET DSUP=$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,1.1))
+7 SET PROV=$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,15))
+8 SET MAIL=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,2)),"^",1)
+9 SET DIV=$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,8))_U_$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,8,0))
+10 SET REMARKS=$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,3))
+11 SET NDC=$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,11))
+12 IF NDC=""
SET NDC=DGNDC
+13 SET NUMRF=TOTRF-RF
+14 SET CMOP=$$CMOP(INDEX,RF)
+15 SET OTRKNM=$$TRACK(INDEX,"REFILL #"_RF)
+16 SET REASON=$$ACTLG(INDEX,"REFILL #"_RF)
+17 SET RCOM=$PIECE(REASON,"^",2)
SET REASON=$PIECE(REASON,"^",1)
+18 SET ADMCLN=+$GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,23))
+19 SET ADMCLN=$SELECT(ADMCLN=1:"YES",1:"NO")
+20 SET PAIEN=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"RF",RF,8)),U,1)
+21 IF PAIEN'=""
DO GETPHRM(PAIEN)
+22 QUIT
+23 ;
PARTIAL ; process partial prescriptions
+1 NEW PF
+2 SET PF=0
+3 SET SOURCE="PF"
+4 FOR
SET PF=$ORDER(^TMP($JOB,LIST,DFN,INDEX,"P",PF))
if PF=""
QUIT
DO SETPF(PF)
+5 QUIT
+6 ;
SETPF(PF) ;
+1 DO INIT2
+2 SET RXN=$GET(^TMP($JOB,LIST,DFN,INDEX,.01))
+3 IF RXN=""
QUIT
+4 DO STPFDT(PF)
+5 DO DATAROOT
+6 IF ^TMP($JOB,LIST,DFN,INDEX,"M",0)=-1
SET @DATAROOT@(HIT,"SIG",0)=0
+7 IF '$TEST
MERGE @DATAROOT@(HIT,"SIG")=^TMP($JOB,LIST,DFN,INDEX,"M")
+8 QUIT
+9 ;
STPFDT(PF) ;
+1 SET UNDX="PF"_PF
+2 SET (FLDT,ISSDT)=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.01)),"^",1)
+3 SET DSPDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,7.5)),"^",1)
+4 SET RELDTTM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,8)),"^",1)
+5 SET QTY=$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.04))
+6 SET DSUP=$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.041))
+7 SET PROV=$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,6))
+8 SET MAIL=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.02)),"^",1)
+9 SET DIV=$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.09))_U_$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.09,0))
+10 SET REMARKS=$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.03))
+11 SET NDC=$GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,1))
+12 IF NDC=""
SET NDC=DGNDC
+13 SET PAIEN=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,"P",PF,.09)),U,1)
+14 IF PAIEN'=""
DO GETPHRM(PAIEN)
+15 QUIT
+16 ;
CMOP(IEN,RF) ; SET UP CMOP VARIABLES
+1 NEW CM,CMP,CMOP
+2 IF +$GET(^TMP($JOB,LIST,DFN,IEN,"C",0))'>0
QUIT ""
+3 SET CMP=+$GET(^TMP($JOB,LIST,DFN,IEN,"C",0))
+4 SET CMOP=""
+5 IF CMP>0
Begin DoDot:1
+6 SET CM=0
FOR
SET CM=$ORDER(^TMP($JOB,LIST,DFN,IEN,"C",CM))
if CM=""
QUIT
Begin DoDot:2
+7 IF ^TMP($JOB,LIST,DFN,IEN,"C",CM,2)=RF
Begin DoDot:3
+8 SET $PIECE(CMOP,U,9)=$PIECE(^TMP($JOB,LIST,DFN,IEN,"C",CM,9),"^",1)
+9 FOR I=2,3,4,10,11,12
Begin DoDot:4
+10 IF $PIECE(^TMP($JOB,LIST,DFN,IEN,"C",CM,I),"^",2)]""
SET $PIECE(CMOP,U,I)=$PIECE(^TMP($JOB,LIST,DFN,IEN,"C",CM,I),"^",2)
+11 IF '$TEST
SET $PIECE(CMOP,U,I)=$PIECE(^TMP($JOB,LIST,DFN,IEN,"C",CM,I),"^",1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT CMOP
+13 ;
ACTLG(IEN,RF) ; Get info from activity log for Auto DC'ed info.
+1 NEW RSN,COM,RC,RCOM
+2 SET (RSN,RC,COM,RCOM)=""
+3 SET AN=0
FOR
SET AN=$ORDER(^TMP($JOB,LIST,DFN,IEN,"A",AN))
if AN=""
QUIT
Begin DoDot:1
+4 SET RC=^TMP($JOB,LIST,DFN,IEN,"A",AN,.04)
+5 IF RF=RC
Begin DoDot:2
+6 SET COM=^TMP($JOB,LIST,DFN,IEN,"A",AN,.05)
+7 IF COM["Rx Discontinued by EHRM Data Migration."
SET RSN=$PIECE(^TMP($JOB,LIST,DFN,IEN,"A",AN,.02),"^",2)
SET RCOM=COM
SET COM=""
End DoDot:2
End DoDot:1
+8 QUIT RSN_"^"_RCOM
+9 ;
TRACK(IEN,RF) ;
+1 NEW TRKN,COM,AN,RC
+2 SET (TRKN,COM)=""
+3 SET AN=0
FOR
SET AN=$ORDER(^TMP($JOB,LIST,DFN,IEN,"A",AN))
if AN=""
QUIT
Begin DoDot:1
+4 SET RC=^TMP($JOB,LIST,DFN,IEN,"A",AN,.04)
+5 IF RF=RC
IF $DATA(^TMP($JOB,LIST,DFN,IEN,"A",AN,"OC"))
DO TRK
End DoDot:1
TRACKQ QUIT TRKN
+1 ;
TRK ;
+1 NEW TR,LINE
+2 SET TR=0
+3 FOR
SET TR=$ORDER(^TMP($JOB,LIST,DFN,IEN,"A",AN,"OC",TR))
if TR=""
QUIT
Begin DoDot:1
+4 SET LINE=^TMP($JOB,LIST,DFN,IEN,"A",AN,"OC",TR,.01)
+5 IF LINE["Mail Tracking Info.: "
SET TRKN=$PIECE(LINE," ",4)
SET TRKN=$PIECE(TRKN," ",1)
End DoDot:1
+6 QUIT
+7 ;
GETPHRM(PAIEN) ;
+1 IF '$DATA(^TMP($JOB,"MHVPA",PAIEN))
DO PSS^PSO59(PAIEN,,"MHVPA")
+2 SET PANAM=$PIECE($GET(^TMP($JOB,"MHVPA",PAIEN,.01)),2)
+3 SET PADD1=$GET(^TMP($JOB,"MHVPA",PAIEN,.02))
+4 SET PAPHN=$GET(^TMP($JOB,"MHVPA",PAIEN,.03))_"-"_$GET(^TMP($JOB,"MHVPA",PAIEN,.04))
+5 IF PAPHN="-"
SET PHPHN=""
+6 SET PASITE=$GET(^TMP($JOB,"MHVPA",PAIEN,.06))
+7 SET PACTY=$GET(^TMP($JOB,"MHVPA",PAIEN,.07))
+8 SET PAZIP=$PIECE($GET(^TMP($JOB,"MHVPA",PAIEN,.05)),U,2)
+9 SET PASTA=$PIECE($GET(^TMP($JOB,"MHVPA",PAIEN,.08)),U,2)
+10 QUIT
+11 ;
DATAROOT ;
+1 SET HIT=HIT+1
+2 SET @DATAROOT=HIT
+3 SET @DATAROOT@(HIT)=$GET(RXN)_U_$GET(DRUG)_U_$GET(MHVSTAT)_U_$GET(MHVDATE)
+4 SET @DATAROOT@(HIT,"P")=$GET(PROV)
+5 SET @DATAROOT@(HIT,"RXN")=$GET(INDEX)_U_$GET(DRUGNM)_U_$GET(ISSDT)_U_$GET(LSTFDT)_U_$GET(RELDTTM)_U_$GET(EXPDT)_U_$GET(CANDT)_U_$GET(TRDNM)
+6 SET @DATAROOT@(HIT,"RXN1")=$GET(STATUS)_U_$GET(QTY)_U_$GET(DSUP)_U_$GET(NUMRF)_U_$GET(PORDNUM)_U_$GET(MAIL)_U_$GET(UNDX)
+7 SET @DATAROOT@(HIT,"RXN2")=$GET(SOURCE)_U_$GET(NDC)_U_$GET(DSPDT)_U_$GET(REASON)_U_$GET(RCOM)_U_$GET(CANDT)
+8 SET @DATAROOT@(HIT,"RXN3")=$GET(CLINIC)_U_$GET(NXTFLDT)_U_$GET(SCHD)_U_$GET(OTRKNM)_U_$GET(ORDR)_U_$GET(ADMCLN)
+9 SET @DATAROOT@(HIT,"PHRM")=$GET(PAIEN)_U_$GET(PANAM)_U_$GET(PADD1)_U_$GET(PAPHN)_U_$GET(PACTY)_U_$GET(PAZIP)_U_$GET(PASTA)_U_$GET(PASITE)
+10 SET @DATAROOT@(HIT,"DIV")=$GET(DIV)
+11 SET @DATAROOT@(HIT,"CMOP")=$GET(CMOP)
+12 IF LIST="MHV"
Begin DoDot:1
+13 IF $PIECE(^TMP($JOB,LIST,DFN,INDEX,"M",0),U,1)=-1
SET @DATAROOT@(HIT,"SIG",0)=0
+14 IF '$TEST
MERGE @DATAROOT@(HIT,"SIG")=^TMP($JOB,LIST,DFN,INDEX,"M")
End DoDot:1
+15 IF LIST="MHV"!("MHVRF")!(LIST="MHVPF")
Begin DoDot:1
+16 IF REMARKS'=""
SET @DATAROOT@(HIT,"RMK",1,0)=REMARKS
+17 SET @DATAROOT@(HIT,"RMK",0)=$SELECT(REMARKS="":"",1:1)
End DoDot:1
+18 QUIT
+19 ;
PRONV ;
+1 SET SOURCE="NV"
+2 SET LIST="MHVNV"
+3 SET INDEX=0
+4 FOR
SET INDEX=$ORDER(^TMP($JOB,LIST,DFN,INDEX))
if INDEX=""
QUIT
if INDEX="B"
QUIT
DO MHVNV
+5 QUIT
+6 ;
MHVNV ;Non VA medications
+1 DO INIT
+2 NEW DOSAGE,MEDRT,SCHED,IEN4,PAIEN,CLNUM
+3 SET UNDX=""
+4 ;No prescription number exists
SET RXN=INDEX
+5 SET STATUS=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,5)),"^",2)
+6 IF STATUS=""
SET STATUS="ACTIVE"
+7 SET DRUG=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,1)),"^",1)
+8 ;drug name
SET DRUGNM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,1)),"^",2)
+9 DO GETDRG(DRUG,DRUGNM)
+10 SET NDC=DGNDC
+11 SET DOSAGE=$GET(^TMP($JOB,LIST,DFN,INDEX,2))
+12 SET MEDRT=$GET(^TMP($JOB,LIST,DFN,INDEX,3))
+13 SET SCHED=$GET(^TMP($JOB,LIST,DFN,INDEX,4))
+14 SET SIG=DOSAGE_" "_MEDRT_" "_SCHED
+15 SET PROV=$GET(^TMP($JOB,LIST,DFN,INDEX,12))
+16 SET LSTFDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,8)),"^",1)
+17 SET ISSDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,11)),"^",1)
+18 SET ISSDT=$PIECE(ISSDT,".",1)
+19 SET EXPDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,6)),"^",1)
+20 SET EXPDT=$PIECE(EXPDT,".",1)
+21 SET CLNUM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,13)),"^",1)
+22 SET CLINIC=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,13)),"^",2)
+23 SET REMARKS=$GET(^TMP($JOB,LIST,DFN,INDEX,14))
+24 SET ORDR=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,.01)),"^",2)
+25 ; INSTITUTION file (#4) IEN
SET IEN4=$$GET1^DIQ(44,CLNUM,3,"I")
+26 SET PAIEN=$$GETPTR(IEN4)
+27 IF PAIEN'=""
DO GETPHRM(PAIEN)
+28 DO DATAROOT
+29 SET N=0
FOR I=0:1
SET N=$ORDER(^TMP($JOB,LIST,DFN,INDEX,14,N))
if N=""
QUIT
SET @DATAROOT@(HIT,"RMK",N,0)=^TMP($JOB,LIST,DFN,INDEX,14,N)
+30 SET @DATAROOT@(HIT,"RMK",0)=$SELECT(I=0:"",1:I)
+31 ;
+32 SET N=0
FOR I=0:1
SET N=$ORDER(^TMP($JOB,LIST,DFN,INDEX,10,N))
if N=""
QUIT
SET @DATAROOT@(HIT,"DSC",N,0)=^TMP($JOB,LIST,DFN,INDEX,10,N)
+33 SET @DATAROOT@(HIT,"DSC",0)=$SELECT(I=0:"",1:I)
+34 ;
+35 SET @DATAROOT@(HIT,"SIG",0)=1
+36 SET @DATAROOT@(HIT,"SIG",1,0)=SIG
+37 QUIT
+38 ;
PROPD ;
+1 SET SOURCE="PD"
+2 SET LIST="MHVPD"
+3 SET INDEX=0
+4 FOR
SET INDEX=$ORDER(^TMP($JOB,LIST,DFN,INDEX))
if INDEX=""
QUIT
if INDEX="B"
QUIT
DO MHVPD
+5 QUIT
+6 ;
MHVPD ;Pending Medications
+1 DO INIT
+2 NEW N,I,CIEN
+3 SET (RXN,IEN)=INDEX
+4 SET UNDX=""
+5 ; PLACER NUMBER
SET PORDNUM=$GET(^TMP($JOB,LIST,DFN,INDEX,.01))
+6 ; DRUG
SET DRUG=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,11)),"^",1)
+7 ; drug name
SET DRUGNM=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,11)),"^",2)
+8 ; ORDERABLE ITEM
SET ORDR=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,8)),"^",2)
+9 DO GETDRG(DRUG,DRUGNM)
+10 SET NDC=DGNDC
+11 ; LOGIN DATE
SET ISSDT=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,15)),"^",1)
+12 SET ISSDT=$PIECE(ISSDT,".",1)
+13 ; QTANTITY
SET QTY=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,12)),"^",1)
+14 ; DAY SUPPLY
SET DSUP=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,101)),"^",1)
+15 ; NUMBER OF REFILLS
SET NUMRF=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,13)),"^",1)
+16 ; PROVIDER
SET PROV=$GET(^TMP($JOB,LIST,DFN,INDEX,5))
+17 ; MAIL
SET MAIL=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,19)),"^",1)
+18 ; ORDER TYPE (NW, HD, RNW, DE, DC, RP)
SET STATUS=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,2)),"^",2)
+19 ; Related institution FILE #4 POINTER
SET CIEN=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,100)),"^",1)
+20 ; Related institution FILE #4 NAME
SET CLINIC=$PIECE($GET(^TMP($JOB,LIST,DFN,INDEX,100)),"^",2)
+21 SET PAIEN=$$GETPTR(CIEN)
+22 IF PAIEN'=""
DO GETPHRM(PAIEN)
+23 DO DATAROOT
+24 SET N=0
FOR I=0:1
SET N=$ORDER(^TMP($JOB,LIST,DFN,INDEX,24,N))
if N=""
QUIT
SET @DATAROOT@(HIT,"SIG",N,0)=^TMP($JOB,LIST,DFN,INDEX,24,N)
+25 SET @DATAROOT@(HIT,"SIG",0)=I
+26 QUIT
+27 ;
GETPTR(IEN4) ; FIND PHARMACY FIELDS
+1 NEW OUT,PTR,STNM
+2 SET STNM=$$GET1^DIQ(4,IEN4,99,"I")
+3 SET OUT=""
+4 DO PSS^PSO59(,"??","PTR")
+5 SET PTR=0
FOR
SET PTR=$ORDER(^TMP($JOB,"PTR",PTR))
if PTR=""
QUIT
if PTR="B"
QUIT
IF ^TMP($JOB,"PTR",PTR,.06)=STNM
SET OUT=PTR
QUIT
+6 QUIT OUT
+7 ;
GETDRG(PSSI,PSSE) ;Drug Information
+1 NEW PSNIEN,PSNFT
+2 if PSSI=""
QUIT
+3 DO ARWS^PSS50(PSSI,PSSE,"MHVDG")
+4 SET PSNFT=^TMP($JOB,"MHVDG",PSSI,21)
+5 SET DGNDC=^TMP($JOB,"MHVDG",PSSI,31)
+6 SET PSNIEN=$PIECE(^TMP($JOB,"MHVDG",PSSI,22),"^",1)
+7 IF PSNIEN=""
SET SCHD="Unscheduled"
QUIT
+8 DO DATA^PSN50P68(PSNIEN,PSNFT,"MHVPS")
+9 SET SCHD=$PIECE(^TMP($JOB,"MHVPS",PSNIEN,19),"^",2)
+10 QUIT
+11 ;
INIT ; set variables to null
+1 SET (MHVDATE,MHVSTAT,IEN,DRUG,DRUGNM,DSPDT,ISSDT,LSTFDT,NXTFLDT,FLDT,RELDTTM,EXPDT,STATUS)=""
+2 SET (QTY,DSUP,NUMRF,PROV,PORDNUM,MAIL,DIV,REMARKS,TRDNM,CANDT,OTRKNM,UNDX,DISC,REM)=""
+3 SET (CLINIC,REFDT,SCHD,NDC,ORDR,ADMCLN,CMOP,DGNDC,REMARKS,TOTRF,REASON,RCOM)=""
+4 SET (PANAM,PADD1,PAPHN,PACTY,PAZIP,PASTA)=""
+5 QUIT
INIT2 ;init vars for partials and refills
+1 SET (IEN,DSPDT,ISSDT,FLDT,RELDTTM,UNDX)=""
+2 SET (QTY,DSUP,PROV,MAIL,DIV,REMARKS,OTRKNM)=""
+3 SET (ADMCLN,CMOP,REMARKS,REASON,RCOM,DISC,REM)=""
+4 SET (PANAM,PADD1,PAPHN,PACTY,PAZIP,PASTA)=""
