- 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 Mar 13, 2025@21:21:02 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)=""
