- 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 Feb 18, 2025@23:10:58 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