RORX011 ;HOIFO/SG,VAC - PATIENT MEDICATION HISTORY ;4/17/09 10:45am
;;1.5;CLINICAL CASE REGISTRIES;**1,8,13,19,21,31,39**;Feb 17, 2006;Build 4
;
; This routine uses the following IAs:
;
; #10103 DT^XLFDT, FMADD^XLFDT (supported)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*8 MAR 2010 V CARR Modified to handle ICD9 filter for
; 'include' or 'exclude'.
;ROR*1.5*13 DEC 2010 A SAUNDERS Added #refills remaining and logic
; to include only most recent fills
; NOTE: Patch 11 became patch 13.
; Any references to patch 11 in the code
; below is referring to path 13.
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
; additional identifier option selected
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT and PCP as additional identifiers.
;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
;******************************************************************************
;******************************************************************************
Q
;
;***** OUTPUTS THE REPORT HEADER
;
; PARTAG Reference (IEN) to the parent tag
;
; Return Values:
; <0 Error code
; >0 IEN of the HEADER element
;
;;PATIENTS(#,NAME,LAST4,DOB,AGE,DOD,ICN,PACT,PCP)
;;PTRXL(DATE,ORDER,TYPE,NAME,GENERIC,DAYSPLY,FILLTYPE,REFILLS)
;REFILLS added to column headers (above) - Patch 11
N HEADER,NOTES,RC
S HEADER=$$HEADER^RORXU002(.RORTSK,PARTAG)
Q:HEADER<0 HEADER
S NOTES=$$ADDVAL^RORTSK11(RORTSK,"NOTES",,HEADER)
D ADDVAL^RORTSK11(RORTSK,"AGE",$$DT^XLFDT,NOTES)
S RC=$$TBLDEF^RORXU002("HEADER^RORX011",HEADER)
Q $S(RC<0:RC,1:HEADER)
;
;***** OUTPUTS THE PARAMETERS TO THE REPORT
;
; PARTAG Reference (IEN) to the parent tag
;
; [.STDT] Start and end dates of the report
; [.ENDT] are returned via these parameters
; [.FLAGS] Flags for the $$SKIP^RORXU005 are returned via this parameter
;
; Return Values:
; <0 Error code
; >0 IEN of the PARAMETERS element
;
PARAMS(PARTAG,STDT,ENDT,FLAGS) ;
N PARAMS,TMP
S PARAMS=$$PARAMS^RORXU002(.RORTSK,PARTAG,.STDT,.ENDT,.FLAGS)
Q:PARAMS<0 PARAMS
;--- Process the drug list and options
S TMP=$$DRUGLST^RORXU007(.RORTSK,PARAMS,.RORXL,.RORXGRP)
Q:TMP<0 TMP
;
Q PARAMS
;
;***** PROCESS THE PATIENT'S DATA
;
; PTLIST Reference (IEN) to the parent tag
; PATIEN Patient IEN in the file #2 (DFN)
; RORXDST Patient's Medication History data
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
PATIENT(PTLIST,PATIEN,RORXDST) ;
N BUF,FLT,FLTL,FQL,ITEM,NODE,PTAG,QSB,RC,TABLE,VA,VADM,VAERR
S (ECNT,RC)=0
;--- Patient data
S PTAG=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,PTLIST,,PATIEN)
Q:PTAG<0 PTAG
D VADEM^RORUTL05(PATIEN,1)
D ADDVAL^RORTSK11(RORTSK,"NAME",VADM(1),PTAG,1)
S VA("BID")="0000" D ADDVAL^RORTSK11(RORTSK,"LAST4",VA("BID"),PTAG,2)
D ADDVAL^RORTSK11(RORTSK,"DOB",$$DATE^RORXU002(VADM(3)\1),PTAG,1)
D ADDVAL^RORTSK11(RORTSK,"AGE",VADM(4),PTAG,3)
D ADDVAL^RORTSK11(RORTSK,"DOD",$$DATE^RORXU002(VADM(6)\1),PTAG,1)
I $$PARAM^RORTSK01("PATIENTS","ICN") D
. D ADDVAL^RORTSK11(RORTSK,"ICN",$$ICN^RORUTL02(PATIEN),PTAG,1)
I $$PARAM^RORTSK01("PATIENTS","PACT") D
. D ADDVAL^RORTSK11(RORTSK,"PACT",$$PACT^RORUTL02(PATIEN),PTAG,1)
I $$PARAM^RORTSK01("PATIENTS","PCP") D
. D ADDVAL^RORTSK11(RORTSK,"PCP",$$PCP^RORUTL02(PATIEN),PTAG,1)
;--- List of drugs
S TABLE=$$ADDVAL^RORTSK11(RORTSK,"PTRXL",,PTAG)
Q:TABLE<0 TABLE
D ADDATTR^RORTSK11(RORTSK,TABLE,"TABLE","PTRXL")
;---
S NODE=RORXDST,FLTL=$L(NODE)-1,FLT=$E(NODE,1,FLTL)
S QSB=$QL(NODE),FQL=QSB+5
F S NODE=$Q(@NODE) Q:$E(NODE,1,FLTL)'=FLT D:$QL(NODE)=FQL
. ; NODE: @RORXDST@(DATE,DRUGNAME,DRUGIEN,RXNUM,RXCNT)
. S BUF=@NODE
. S ITEM=$$ADDVAL^RORTSK11(RORTSK,"DRUG",,TABLE)
. D ADDVAL^RORTSK11(RORTSK,"DATE",$QS(NODE,QSB+1)\1,ITEM,1)
. D ADDVAL^RORTSK11(RORTSK,"ORDER",$QS(NODE,QSB+4),ITEM,1)
. S TMP=$P(BUF,U)
. S TMP=$S(TMP="O":"ORIGINAL",TMP="P":"PARTIAL",TMP="R":"REFILL",1:"")
. D ADDVAL^RORTSK11(RORTSK,"TYPE",TMP,ITEM,1)
. D ADDVAL^RORTSK11(RORTSK,"NAME",$QS(NODE,QSB+2),ITEM,1)
. D ADDVAL^RORTSK11(RORTSK,"GENERIC",$P(BUF,U,4),ITEM,1)
. D ADDVAL^RORTSK11(RORTSK,"DAYSPLY",$P(BUF,U,5),ITEM,1)
. S TMP=$P(BUF,U,2)
. S TMP=$S(TMP="I":"INPATIENT",TMP="M":"MAIL",TMP="W":"WINDOW",1:"")
. D ADDVAL^RORTSK11(RORTSK,"FILLTYPE",TMP,ITEM,1)
. D ADDVAL^RORTSK11(RORTSK,"REFILLS",$P(BUF,U,6),ITEM,1) ;number of refills remaining - Patch 11
;---
Q $S(RC<0:RC,1:ECNT)
;
;***** PROCESSES THE LIST OF PATIENTS
;
; REPORT Reference (IEN) to the parent tag
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
PROCESS(REPORT,FLAGS) ;
N CNT,ECNT,IEN798,PTIEN,PTLIST,PTNODE,RC,RORPTN,RORXDST,RXFLAGS,SKIP,TMP,DFN
N RORX011 S RORX011=1 ;Patch 11: needed for 'callback' function setup in PROCESS^RORUTL15
S (CNT,ECNT,RC)=0
N RCC,FLAG
N RORCDLIST ; Flag to indicate whether a clinic or division list exists
N RORCDSTDT ; Start date for clinic/division utilization search
N RORCDENDT ; End date for clinic/division utilization search
;
;--- Count patients in the list. Define which patient 'list' to use: the one
;selected by the user, or all patients in 798
I RORALL D S:RORPTN<0 RORPTN=0
. S PTNODE=$NA(^RORDATA(798,"ARP",RORREG_"#"))
. S RORPTN=$$REGSIZE^RORUTL02(+RORREG)
E S (PTIEN,RORPTN)=0 D Q:RORPTN'>0 0
. S PTNODE=$NA(RORTSK("PARAMS","PATIENTS","C"))
. F S PTIEN=$O(@PTNODE@(PTIEN)) Q:PTIEN'>0 S RORPTN=RORPTN+1
;---
S PTLIST=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,REPORT)
Q:PTLIST<0 PTLIST
;
;--- Prepare parameters for the pharmacy search API
S RORXDST=$NA(^TMP("RORX011",$J))
S RORXDST("RORCB")="$$RXSCB^RORX011"
S RXFLAGS="E"
S:$$PARAM^RORTSK01("PATIENTS","INPATIENT") RXFLAGS=RXFLAGS_"IV"
S:$$PARAM^RORTSK01("PATIENTS","OUTPATIENT") RXFLAGS=RXFLAGS_"O"
;
;=== Set up Clinic/Division list parameters
S RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT)
;
;--- Browse through the list of selected patients
S (CNT,PTIEN)=0
S FLAG=$G(RORTSK("PARAMS","ICDFILT","A","FILTER"))
;
F S PTIEN=$O(@PTNODE@(PTIEN)) Q:PTIEN'>0 D Q:RC<0
. S RC=$$LOOP^RORTSK01(CNT/RORPTN) Q:RC<0
. S CNT=CNT+1,IEN798=$$PRRIEN^RORUTL01(PTIEN,RORREG) Q:IEN798'>0
. ;--- Check if the patient should be skipped
. I RORALL Q:$$SKIP^RORXU005(IEN798,FLAGS,RORSDT,ROREDT)
. ;
. ;--- Check the patient against the ICD Filter
. S RCC=0
. I FLAG'="ALL" D
. . S RCC=$$ICD^RORXU010(PTIEN)
. I (FLAG="INCLUDE")&(RCC=0) Q
. I (FLAG="EXCLUDE")&(RCC=1) Q
. ;--- End of check for ICD Filter
. ;--- Check for Clinic or Division list and quit if not in list
. I RORCDLIST,'$$CDUTIL^RORXU001(.RORTSK,PTIEN,RORCDSTDT,RORCDENDT) Q
. ;--- Search the pharmacy data
. K @RORXDST
. S TMP=$$RXSEARCH^RORUTL14(PTIEN,RORXL,.RORXDST,RXFLAGS,RORSDT,ROREDT1)
. I TMP<0 S ECNT=ECNT+1 Q
. I RORALL Q:TMP'>0
. ;--- If user selected most recent drug fills, remove older duplicates
. I $$PARAM^RORTSK01("OPTIONS","RECENT_FILLS") D RECENT(RORXDST)
. ;--- Append the patient's data to the report
. S TMP=$$PATIENT(PTLIST,PTIEN,RORXDST)
. I TMP S ECNT=ECNT+$S(TMP>0:TMP,1:1) Q
;
;--- Cleanup
K @RORXDST
K ^TMP("RORX011-RESORTED",$J) ;Patch 11
Q $S(RC<0:RC,1:ECNT)
;
;***** COMPILES THE "PATIENT DRUG HISTORY" REPORT
; REPORT CODE: 011
;
; .RORTSK Task number and task parameters
;
; The ^TMP("RORX011",$J) global node is used by this function.
;
; Return Values:
; <0 Error code
; 0 Ok
;
RXHIST(RORTSK) ;
N RORALL ; Consider all registry patients
N ROREDT ; End date
N ROREDT1 ; End date + 1
N RORREG ; Registry IEN
N RORSDT ; Start date
N RORXGRP ; List of drug groups
N RORXL ; Closed root of the medication list
;
N ECNT,FLAGS,RC,REPORT,TMP
S RORXL="",(ECNT,RC)=0
K ^TMP("RORX011",$J)
;
;--- Root node of the report
S REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
Q:REPORT<0 REPORT
;
D
. ;--- Get and prepare the report parameters
. S RORREG=+$$PARAM^RORTSK01("REGIEN")
. S RORALL=$$PARAM^RORTSK01("PATIENTS","ALL")
. S RC=$$PARAMS(REPORT,.RORSDT,.ROREDT,.FLAGS) Q:RC<0
. S ROREDT1=$$FMADD^XLFDT(ROREDT\1,1)
. ;
. ;--- Report header
. S RC=$$HEADER(REPORT) Q:RC<0
. ;
. ;--- Process the data and generate the report
. S RC=$$PROCESS(REPORT,FLAGS) S:RC>0 ECNT=ECNT+RC
;
;--- Cleanup
K ^TMP("RORX011-RESORTED",$J)
D FREE^RORTMP(RORXL)
Q $S(RC<0:RC,ECNT>0:-43,1:0)
;
;***** CALLBACK FUNCTION FOR THE PHARMACY SEARCH API
RXSCB(ROR8DST,ORDER,ORDFLG,DRUG,DATE,NUMREF) ;
N DRUGIEN,DRUGNAME,FILLTYPE,IEN,IRP,OFD,RPSUB,RXBUF,RXCNT,RXNUM,TMP
S DRUGIEN=+DRUG,DRUGNAME=$P(DRUG,U,2)
Q:(DRUGIEN'>0)!(DRUGNAME="") 1
;--- Check the drug groups
S TMP=$$RXGRPCHK^RORXU007(.ROR8DST,+DRUG,RORXL)
Q:TMP TMP
;--- Process the order
S:ROR8DST("RORXGEN")>0 $P(RXBUF,U,4)=$P(ROR8DST("RORXGEN"),U,2)
S $P(RXBUF,U,5)=$P($G(^TMP("PS",$J,0)),U,7) ; Days Supply
S $P(RXBUF,U,6)=+$G(NUMREF) ; # Refills remaining - Patch 11
S TMP=$G(^TMP("PS",$J,"RXN",0))
S FILLTYPE=$S(ORDFLG["I":"I",1:$P(TMP,U,3))
S RXNUM=$P(TMP,U) S:RXNUM="" RXNUM=" "
S RXCNT=0
;--- Original prescription
I ORDFLG["I" D ;--- Inpatient
. S OFD=$P($G(^TMP("PS",$J,0)),U,5) ; Start Date
. S $P(RXBUF,U,1,2)="I"_U_FILLTYPE,RXCNT=RXCNT+1
. S @ROR8DST@(OFD,DRUGNAME,DRUGIEN,RXNUM,RXCNT)=RXBUF
E D ;--- Outpatient
. S OFD=+$P($G(^TMP("PS",$J,"RXN",0)),U,6) ; Original Fill Date
. Q:(OFD<ROR8DST("RORSDT"))!(OFD'<ROR8DST("ROREDT"))
. S $P(RXBUF,U,1,2)="O"_U_FILLTYPE,RXCNT=RXCNT+1
. S @ROR8DST@(OFD,DRUGNAME,DRUGIEN,RXNUM,RXCNT)=RXBUF
;--- Refills and partials
F RPSUB="REF","PAR" D
. S $P(RXBUF,U)=$E(RPSUB,1)
. S IRP=0
. F S IRP=$O(^TMP("PS",$J,RPSUB,IRP)) Q:IRP'>0 D
. . S TMP=$G(^TMP("PS",$J,RPSUB,IRP,0))
. . S $P(RXBUF,U,2)=$S(ORDFLG["I":"I",1:$P(TMP,U,5))
. . S $P(RXBUF,U,5)=$P(TMP,U,2) ; Days Supply
. . I TMP>0 S RXCNT=RXCNT+1 D
. . . S @ROR8DST@(+TMP,DRUGNAME,DRUGIEN,RXNUM,RXCNT)=RXBUF
Q 0
;
;***** KEEP ONLY MOST RECENT FILLS FOR EACH DRUG
;Input:
; RORXDST - arry containing all drug fills for patient
;
;Output:
; RORXDST - array containing only most recent drug fills for patient
;
;The ^TMP("RORX011-RESORTED",$J) global node is used by this function.
;Indirection: RORXDST = $NA(^TMP("RORX011",$J))
; ^TMP("RORX011",$J,DATE,DRUG_NAME,IEN,...)
;
RECENT(RORXDST) ;
N DATE,DRUG
K ^TMP("RORX011-RESORTED",$J) ;empty the temporary global
;Patient's Rx data was stored by date, then drug name. Spin through
;Rx data and re-order it by drug name first, then date. The reordered
;data is put into temp global ^TMP("RORX011-RESORTED",$J,DRUG,DATE)
S DATE=0 F S DATE=$O(@RORXDST@(DATE)) Q:'DATE D
. S DRUG=0 F S DRUG=$O(@RORXDST@(DATE,DRUG)) Q:'$L(DRUG) D
. . S ^TMP("RORX011-RESORTED",$J,DRUG,DATE)=1
;
;spin through re-sorted drug file
S DRUG=0 F S DRUG=$O(^TMP("RORX011-RESORTED",$J,DRUG)) Q:'$L(DRUG) D
. ;get entry for drug with most recent (latest) date
. S DATE=$O(^TMP("RORX011-RESORTED",$J,DRUG,9999999),-1)
. ;has any drug been re-filled?
. F S DATE=$O(^TMP("RORX011-RESORTED",$J,DRUG,DATE),-1) Q:'DATE D
. . ;yes, previous/older fill found - delete from the original file
. . K @RORXDST@(DATE,DRUG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX011 12325 printed Dec 13, 2024@01:44:35 Page 2
RORX011 ;HOIFO/SG,VAC - PATIENT MEDICATION HISTORY ;4/17/09 10:45am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,8,13,19,21,31,39**;Feb 17, 2006;Build 4
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #10103 DT^XLFDT, FMADD^XLFDT (supported)
+6 ;
+7 ;******************************************************************************
+8 ;******************************************************************************
+9 ; --- ROUTINE MODIFICATION LOG ---
+10 ;
+11 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+12 ;----------- ---------- ----------- ----------------------------------------
+13 ;ROR*1.5*8 MAR 2010 V CARR Modified to handle ICD9 filter for
+14 ; 'include' or 'exclude'.
+15 ;ROR*1.5*13 DEC 2010 A SAUNDERS Added #refills remaining and logic
+16 ; to include only most recent fills
+17 ; NOTE: Patch 11 became patch 13.
+18 ; Any references to patch 11 in the code
+19 ; below is referring to path 13.
+20 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+21 ;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
+22 ; additional identifier option selected
+23 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT and PCP as additional identifiers.
+24 ;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
+25 ;******************************************************************************
+26 ;******************************************************************************
+27 QUIT
+28 ;
+29 ;***** OUTPUTS THE REPORT HEADER
+30 ;
+31 ; PARTAG Reference (IEN) to the parent tag
+32 ;
+33 ; Return Values:
+34 ; <0 Error code
+35 ; >0 IEN of the HEADER element
+36 ;
+1 ;;PATIENTS(#,NAME,LAST4,DOB,AGE,DOD,ICN,PACT,PCP)
+2 ;;PTRXL(DATE,ORDER,TYPE,NAME,GENERIC,DAYSPLY,FILLTYPE,REFILLS)
+3 ;REFILLS added to column headers (above) - Patch 11
+4 NEW HEADER,NOTES,RC
+5 SET HEADER=$$HEADER^RORXU002(.RORTSK,PARTAG)
+6 if HEADER<0
QUIT HEADER
+7 SET NOTES=$$ADDVAL^RORTSK11(RORTSK,"NOTES",,HEADER)
+8 DO ADDVAL^RORTSK11(RORTSK,"AGE",$$DT^XLFDT,NOTES)
+9 SET RC=$$TBLDEF^RORXU002("HEADER^RORX011",HEADER)
+10 QUIT $SELECT(RC<0:RC,1:HEADER)
+11 ;
+12 ;***** OUTPUTS THE PARAMETERS TO THE REPORT
+13 ;
+14 ; PARTAG Reference (IEN) to the parent tag
+15 ;
+16 ; [.STDT] Start and end dates of the report
+17 ; [.ENDT] are returned via these parameters
+18 ; [.FLAGS] Flags for the $$SKIP^RORXU005 are returned via this parameter
+19 ;
+20 ; Return Values:
+21 ; <0 Error code
+22 ; >0 IEN of the PARAMETERS element
+23 ;
PARAMS(PARTAG,STDT,ENDT,FLAGS) ;
+1 NEW PARAMS,TMP
+2 SET PARAMS=$$PARAMS^RORXU002(.RORTSK,PARTAG,.STDT,.ENDT,.FLAGS)
+3 if PARAMS<0
QUIT PARAMS
+4 ;--- Process the drug list and options
+5 SET TMP=$$DRUGLST^RORXU007(.RORTSK,PARAMS,.RORXL,.RORXGRP)
+6 if TMP<0
QUIT TMP
+7 ;
+8 QUIT PARAMS
+9 ;
+10 ;***** PROCESS THE PATIENT'S DATA
+11 ;
+12 ; PTLIST Reference (IEN) to the parent tag
+13 ; PATIEN Patient IEN in the file #2 (DFN)
+14 ; RORXDST Patient's Medication History data
+15 ;
+16 ; Return Values:
+17 ; <0 Error code
+18 ; 0 Ok
+19 ; >0 Number of non-fatal errors
+20 ;
PATIENT(PTLIST,PATIEN,RORXDST) ;
+1 NEW BUF,FLT,FLTL,FQL,ITEM,NODE,PTAG,QSB,RC,TABLE,VA,VADM,VAERR
+2 SET (ECNT,RC)=0
+3 ;--- Patient data
+4 SET PTAG=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,PTLIST,,PATIEN)
+5 if PTAG<0
QUIT PTAG
+6 DO VADEM^RORUTL05(PATIEN,1)
+7 DO ADDVAL^RORTSK11(RORTSK,"NAME",VADM(1),PTAG,1)
+8 SET VA("BID")="0000"
DO ADDVAL^RORTSK11(RORTSK,"LAST4",VA("BID"),PTAG,2)
+9 DO ADDVAL^RORTSK11(RORTSK,"DOB",$$DATE^RORXU002(VADM(3)\1),PTAG,1)
+10 DO ADDVAL^RORTSK11(RORTSK,"AGE",VADM(4),PTAG,3)
+11 DO ADDVAL^RORTSK11(RORTSK,"DOD",$$DATE^RORXU002(VADM(6)\1),PTAG,1)
+12 IF $$PARAM^RORTSK01("PATIENTS","ICN")
Begin DoDot:1
+13 DO ADDVAL^RORTSK11(RORTSK,"ICN",$$ICN^RORUTL02(PATIEN),PTAG,1)
End DoDot:1
+14 IF $$PARAM^RORTSK01("PATIENTS","PACT")
Begin DoDot:1
+15 DO ADDVAL^RORTSK11(RORTSK,"PACT",$$PACT^RORUTL02(PATIEN),PTAG,1)
End DoDot:1
+16 IF $$PARAM^RORTSK01("PATIENTS","PCP")
Begin DoDot:1
+17 DO ADDVAL^RORTSK11(RORTSK,"PCP",$$PCP^RORUTL02(PATIEN),PTAG,1)
End DoDot:1
+18 ;--- List of drugs
+19 SET TABLE=$$ADDVAL^RORTSK11(RORTSK,"PTRXL",,PTAG)
+20 if TABLE<0
QUIT TABLE
+21 DO ADDATTR^RORTSK11(RORTSK,TABLE,"TABLE","PTRXL")
+22 ;---
+23 SET NODE=RORXDST
SET FLTL=$LENGTH(NODE)-1
SET FLT=$EXTRACT(NODE,1,FLTL)
+24 SET QSB=$QLENGTH(NODE)
SET FQL=QSB+5
+25 FOR
SET NODE=$QUERY(@NODE)
if $EXTRACT(NODE,1,FLTL)'=FLT
QUIT
if $QLENGTH(NODE)=FQL
Begin DoDot:1
+26 ; NODE: @RORXDST@(DATE,DRUGNAME,DRUGIEN,RXNUM,RXCNT)
+27 SET BUF=@NODE
+28 SET ITEM=$$ADDVAL^RORTSK11(RORTSK,"DRUG",,TABLE)
+29 DO ADDVAL^RORTSK11(RORTSK,"DATE",$QSUBSCRIPT(NODE,QSB+1)\1,ITEM,1)
+30 DO ADDVAL^RORTSK11(RORTSK,"ORDER",$QSUBSCRIPT(NODE,QSB+4),ITEM,1)
+31 SET TMP=$PIECE(BUF,U)
+32 SET TMP=$SELECT(TMP="O":"ORIGINAL",TMP="P":"PARTIAL",TMP="R":"REFILL",1:"")
+33 DO ADDVAL^RORTSK11(RORTSK,"TYPE",TMP,ITEM,1)
+34 DO ADDVAL^RORTSK11(RORTSK,"NAME",$QSUBSCRIPT(NODE,QSB+2),ITEM,1)
+35 DO ADDVAL^RORTSK11(RORTSK,"GENERIC",$PIECE(BUF,U,4),ITEM,1)
+36 DO ADDVAL^RORTSK11(RORTSK,"DAYSPLY",$PIECE(BUF,U,5),ITEM,1)
+37 SET TMP=$PIECE(BUF,U,2)
+38 SET TMP=$SELECT(TMP="I":"INPATIENT",TMP="M":"MAIL",TMP="W":"WINDOW",1:"")
+39 DO ADDVAL^RORTSK11(RORTSK,"FILLTYPE",TMP,ITEM,1)
+40 ;number of refills remaining - Patch 11
DO ADDVAL^RORTSK11(RORTSK,"REFILLS",$PIECE(BUF,U,6),ITEM,1)
End DoDot:1
+41 ;---
+42 QUIT $SELECT(RC<0:RC,1:ECNT)
+43 ;
+44 ;***** PROCESSES THE LIST OF PATIENTS
+45 ;
+46 ; REPORT Reference (IEN) to the parent tag
+47 ;
+48 ; Return Values:
+49 ; <0 Error code
+50 ; 0 Ok
+51 ; >0 Number of non-fatal errors
+52 ;
PROCESS(REPORT,FLAGS) ;
+1 NEW CNT,ECNT,IEN798,PTIEN,PTLIST,PTNODE,RC,RORPTN,RORXDST,RXFLAGS,SKIP,TMP,DFN
+2 ;Patch 11: needed for 'callback' function setup in PROCESS^RORUTL15
NEW RORX011
SET RORX011=1
+3 SET (CNT,ECNT,RC)=0
+4 NEW RCC,FLAG
+5 ; Flag to indicate whether a clinic or division list exists
NEW RORCDLIST
+6 ; Start date for clinic/division utilization search
NEW RORCDSTDT
+7 ; End date for clinic/division utilization search
NEW RORCDENDT
+8 ;
+9 ;--- Count patients in the list. Define which patient 'list' to use: the one
+10 ;selected by the user, or all patients in 798
+11 IF RORALL
Begin DoDot:1
+12 SET PTNODE=$NAME(^RORDATA(798,"ARP",RORREG_"#"))
+13 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
End DoDot:1
if RORPTN<0
SET RORPTN=0
+14 IF '$TEST
SET (PTIEN,RORPTN)=0
Begin DoDot:1
+15 SET PTNODE=$NAME(RORTSK("PARAMS","PATIENTS","C"))
+16 FOR
SET PTIEN=$ORDER(@PTNODE@(PTIEN))
if PTIEN'>0
QUIT
SET RORPTN=RORPTN+1
End DoDot:1
if RORPTN'>0
QUIT 0
+17 ;---
+18 SET PTLIST=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,REPORT)
+19 if PTLIST<0
QUIT PTLIST
+20 ;
+21 ;--- Prepare parameters for the pharmacy search API
+22 SET RORXDST=$NAME(^TMP("RORX011",$JOB))
+23 SET RORXDST("RORCB")="$$RXSCB^RORX011"
+24 SET RXFLAGS="E"
+25 if $$PARAM^RORTSK01("PATIENTS","INPATIENT")
SET RXFLAGS=RXFLAGS_"IV"
+26 if $$PARAM^RORTSK01("PATIENTS","OUTPATIENT")
SET RXFLAGS=RXFLAGS_"O"
+27 ;
+28 ;=== Set up Clinic/Division list parameters
+29 SET RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT)
+30 ;
+31 ;--- Browse through the list of selected patients
+32 SET (CNT,PTIEN)=0
+33 SET FLAG=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+34 ;
+35 FOR
SET PTIEN=$ORDER(@PTNODE@(PTIEN))
if PTIEN'>0
QUIT
Begin DoDot:1
+36 SET RC=$$LOOP^RORTSK01(CNT/RORPTN)
if RC<0
QUIT
+37 SET CNT=CNT+1
SET IEN798=$$PRRIEN^RORUTL01(PTIEN,RORREG)
if IEN798'>0
QUIT
+38 ;--- Check if the patient should be skipped
+39 IF RORALL
if $$SKIP^RORXU005(IEN798,FLAGS,RORSDT,ROREDT)
QUIT
+40 ;
+41 ;--- Check the patient against the ICD Filter
+42 SET RCC=0
+43 IF FLAG'="ALL"
Begin DoDot:2
+44 SET RCC=$$ICD^RORXU010(PTIEN)
End DoDot:2
+45 IF (FLAG="INCLUDE")&(RCC=0)
QUIT
+46 IF (FLAG="EXCLUDE")&(RCC=1)
QUIT
+47 ;--- End of check for ICD Filter
+48 ;--- Check for Clinic or Division list and quit if not in list
+49 IF RORCDLIST
IF '$$CDUTIL^RORXU001(.RORTSK,PTIEN,RORCDSTDT,RORCDENDT)
QUIT
+50 ;--- Search the pharmacy data
+51 KILL @RORXDST
+52 SET TMP=$$RXSEARCH^RORUTL14(PTIEN,RORXL,.RORXDST,RXFLAGS,RORSDT,ROREDT1)
+53 IF TMP<0
SET ECNT=ECNT+1
QUIT
+54 IF RORALL
if TMP'>0
QUIT
+55 ;--- If user selected most recent drug fills, remove older duplicates
+56 IF $$PARAM^RORTSK01("OPTIONS","RECENT_FILLS")
DO RECENT(RORXDST)
+57 ;--- Append the patient's data to the report
+58 SET TMP=$$PATIENT(PTLIST,PTIEN,RORXDST)
+59 IF TMP
SET ECNT=ECNT+$SELECT(TMP>0:TMP,1:1)
QUIT
End DoDot:1
if RC<0
QUIT
+60 ;
+61 ;--- Cleanup
+62 KILL @RORXDST
+63 ;Patch 11
KILL ^TMP("RORX011-RESORTED",$JOB)
+64 QUIT $SELECT(RC<0:RC,1:ECNT)
+65 ;
+66 ;***** COMPILES THE "PATIENT DRUG HISTORY" REPORT
+67 ; REPORT CODE: 011
+68 ;
+69 ; .RORTSK Task number and task parameters
+70 ;
+71 ; The ^TMP("RORX011",$J) global node is used by this function.
+72 ;
+73 ; Return Values:
+74 ; <0 Error code
+75 ; 0 Ok
+76 ;
RXHIST(RORTSK) ;
+1 ; Consider all registry patients
NEW RORALL
+2 ; End date
NEW ROREDT
+3 ; End date + 1
NEW ROREDT1
+4 ; Registry IEN
NEW RORREG
+5 ; Start date
NEW RORSDT
+6 ; List of drug groups
NEW RORXGRP
+7 ; Closed root of the medication list
NEW RORXL
+8 ;
+9 NEW ECNT,FLAGS,RC,REPORT,TMP
+10 SET RORXL=""
SET (ECNT,RC)=0
+11 KILL ^TMP("RORX011",$JOB)
+12 ;
+13 ;--- Root node of the report
+14 SET REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
+15 if REPORT<0
QUIT REPORT
+16 ;
+17 Begin DoDot:1
+18 ;--- Get and prepare the report parameters
+19 SET RORREG=+$$PARAM^RORTSK01("REGIEN")
+20 SET RORALL=$$PARAM^RORTSK01("PATIENTS","ALL")
+21 SET RC=$$PARAMS(REPORT,.RORSDT,.ROREDT,.FLAGS)
if RC<0
QUIT
+22 SET ROREDT1=$$FMADD^XLFDT(ROREDT\1,1)
+23 ;
+24 ;--- Report header
+25 SET RC=$$HEADER(REPORT)
if RC<0
QUIT
+26 ;
+27 ;--- Process the data and generate the report
+28 SET RC=$$PROCESS(REPORT,FLAGS)
if RC>0
SET ECNT=ECNT+RC
End DoDot:1
+29 ;
+30 ;--- Cleanup
+31 KILL ^TMP("RORX011-RESORTED",$JOB)
+32 DO FREE^RORTMP(RORXL)
+33 QUIT $SELECT(RC<0:RC,ECNT>0:-43,1:0)
+34 ;
+35 ;***** CALLBACK FUNCTION FOR THE PHARMACY SEARCH API
RXSCB(ROR8DST,ORDER,ORDFLG,DRUG,DATE,NUMREF) ;
+1 NEW DRUGIEN,DRUGNAME,FILLTYPE,IEN,IRP,OFD,RPSUB,RXBUF,RXCNT,RXNUM,TMP
+2 SET DRUGIEN=+DRUG
SET DRUGNAME=$PIECE(DRUG,U,2)
+3 if (DRUGIEN'>0)!(DRUGNAME="")
QUIT 1
+4 ;--- Check the drug groups
+5 SET TMP=$$RXGRPCHK^RORXU007(.ROR8DST,+DRUG,RORXL)
+6 if TMP
QUIT TMP
+7 ;--- Process the order
+8 if ROR8DST("RORXGEN")>0
SET $PIECE(RXBUF,U,4)=$PIECE(ROR8DST("RORXGEN"),U,2)
+9 ; Days Supply
SET $PIECE(RXBUF,U,5)=$PIECE($GET(^TMP("PS",$JOB,0)),U,7)
+10 ; # Refills remaining - Patch 11
SET $PIECE(RXBUF,U,6)=+$GET(NUMREF)
+11 SET TMP=$GET(^TMP("PS",$JOB,"RXN",0))
+12 SET FILLTYPE=$SELECT(ORDFLG["I":"I",1:$PIECE(TMP,U,3))
+13 SET RXNUM=$PIECE(TMP,U)
if RXNUM=""
SET RXNUM=" "
+14 SET RXCNT=0
+15 ;--- Original prescription
+16 ;--- Inpatient
IF ORDFLG["I"
Begin DoDot:1
+17 ; Start Date
SET OFD=$PIECE($GET(^TMP("PS",$JOB,0)),U,5)
+18 SET $PIECE(RXBUF,U,1,2)="I"_U_FILLTYPE
SET RXCNT=RXCNT+1
+19 SET @ROR8DST@(OFD,DRUGNAME,DRUGIEN,RXNUM,RXCNT)=RXBUF
End DoDot:1
+20 ;--- Outpatient
IF '$TEST
Begin DoDot:1
+21 ; Original Fill Date
SET OFD=+$PIECE($GET(^TMP("PS",$JOB,"RXN",0)),U,6)
+22 if (OFD<ROR8DST("RORSDT"))!(OFD'<ROR8DST("ROREDT"))
QUIT
+23 SET $PIECE(RXBUF,U,1,2)="O"_U_FILLTYPE
SET RXCNT=RXCNT+1
+24 SET @ROR8DST@(OFD,DRUGNAME,DRUGIEN,RXNUM,RXCNT)=RXBUF
End DoDot:1
+25 ;--- Refills and partials
+26 FOR RPSUB="REF","PAR"
Begin DoDot:1
+27 SET $PIECE(RXBUF,U)=$EXTRACT(RPSUB,1)
+28 SET IRP=0
+29 FOR
SET IRP=$ORDER(^TMP("PS",$JOB,RPSUB,IRP))
if IRP'>0
QUIT
Begin DoDot:2
+30 SET TMP=$GET(^TMP("PS",$JOB,RPSUB,IRP,0))
+31 SET $PIECE(RXBUF,U,2)=$SELECT(ORDFLG["I":"I",1:$PIECE(TMP,U,5))
+32 ; Days Supply
SET $PIECE(RXBUF,U,5)=$PIECE(TMP,U,2)
+33 IF TMP>0
SET RXCNT=RXCNT+1
Begin DoDot:3
+34 SET @ROR8DST@(+TMP,DRUGNAME,DRUGIEN,RXNUM,RXCNT)=RXBUF
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT 0
+36 ;
+37 ;***** KEEP ONLY MOST RECENT FILLS FOR EACH DRUG
+38 ;Input:
+39 ; RORXDST - arry containing all drug fills for patient
+40 ;
+41 ;Output:
+42 ; RORXDST - array containing only most recent drug fills for patient
+43 ;
+44 ;The ^TMP("RORX011-RESORTED",$J) global node is used by this function.
+45 ;Indirection: RORXDST = $NA(^TMP("RORX011",$J))
+46 ; ^TMP("RORX011",$J,DATE,DRUG_NAME,IEN,...)
+47 ;
RECENT(RORXDST) ;
+1 NEW DATE,DRUG
+2 ;empty the temporary global
KILL ^TMP("RORX011-RESORTED",$JOB)
+3 ;Patient's Rx data was stored by date, then drug name. Spin through
+4 ;Rx data and re-order it by drug name first, then date. The reordered
+5 ;data is put into temp global ^TMP("RORX011-RESORTED",$J,DRUG,DATE)
+6 SET DATE=0
FOR
SET DATE=$ORDER(@RORXDST@(DATE))
if 'DATE
QUIT
Begin DoDot:1
+7 SET DRUG=0
FOR
SET DRUG=$ORDER(@RORXDST@(DATE,DRUG))
if '$LENGTH(DRUG)
QUIT
Begin DoDot:2
+8 SET ^TMP("RORX011-RESORTED",$JOB,DRUG,DATE)=1
End DoDot:2
End DoDot:1
+9 ;
+10 ;spin through re-sorted drug file
+11 SET DRUG=0
FOR
SET DRUG=$ORDER(^TMP("RORX011-RESORTED",$JOB,DRUG))
if '$LENGTH(DRUG)
QUIT
Begin DoDot:1
+12 ;get entry for drug with most recent (latest) date
+13 SET DATE=$ORDER(^TMP("RORX011-RESORTED",$JOB,DRUG,9999999),-1)
+14 ;has any drug been re-filled?
+15 FOR
SET DATE=$ORDER(^TMP("RORX011-RESORTED",$JOB,DRUG,DATE),-1)
if 'DATE
QUIT
Begin DoDot:2
+16 ;yes, previous/older fill found - delete from the original file
+17 KILL @RORXDST@(DATE,DRUG)
End DoDot:2
End DoDot:1
+18 QUIT
