RORX009A ;HOIFO/SG,VAC - PRESCRIPTION UTILIZ. (QUERY & SORT) ;4/7/09 2:08pm
;;1.5;CLINICAL CASE REGISTRIES;**8,13,19,21,31,39**;Feb 17, 2006;Build 4
;
; This routine uses the following IAs:
;
; #10103 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 User can select specific patients,
; clinics, or divisions for the report.
;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, PCP, and AGE/DOB as additional
; identifiers.
;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
;
;******************************************************************************
;******************************************************************************
Q
;
;***** QUERIES THE REGISTRY
;
; FLAGS Flags for the $$SKIP^RORXU005
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
QUERY(FLAGS) ;
N ROREDT1 ; Day after the end date
N RORPTN ; Number of patients in the registry
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
;
N CNT,ECNT,IEN,IENS,PATIEN,RC,RORXDST,RXFLAGS,TMP,XREFNODE
N RCC,FLAG
S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
S ROREDT1=$$FMADD^XLFDT(ROREDT,1)
S (CNT,ECNT,RC)=0
;
;--- Prepare parameters for the pharmacy search API
S RORXDST=$NA(^TMP("RORX009",$J))
S RORXDST("RORCB")="$$RXSCB^RORX009A"
S RORXDST("GENERIC")=$$PARAM^RORTSK01("DRUGS","AGGR_GENERIC")
S RXFLAGS="E"
S:$$PARAM^RORTSK01("PATIENTS","INPATIENT") RXFLAGS=RXFLAGS_"IV"
S:$$PARAM^RORTSK01("PATIENTS","OUTPATIENT") RXFLAGS=RXFLAGS_"O"
Q:RXFLAGS="E" 0
;
;=== Set up Clinic/Division list parameters
S RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT)
;
;--- Browse through the registry records
S IEN=0
S FLAG=$G(RORTSK("PARAMS","ICDFILT","A","FILTER"))
F S IEN=$O(@XREFNODE@(IEN)) Q:IEN'>0 D Q:RC<0
. S TMP=$S(RORPTN>0:CNT/RORPTN,1:"")
. S RC=$$LOOP^RORTSK01(TMP) Q:RC<0
. S IENS=IEN_",",CNT=CNT+1
. ;--- Get patient DFN
. S PATIEN=$$PTIEN^RORUTL01(IEN) Q:PATIEN'>0
. ;check for patient list and quit if not on list
. I $D(RORTSK("PARAMS","PATIENTS","C")),'$D(RORTSK("PARAMS","PATIENTS","C",PATIEN)) Q
. ;--- Check if the patient should be skipped
. Q:$$SKIP^RORXU005(IEN,FLAGS,RORSDT,ROREDT)
. ;--- Check if patient filtered for ICD Codes
. S RCC=0
. I FLAG'="ALL" D
. . S RCC=$$ICD^RORXU010(PATIEN)
. I (FLAG="INCLUDE")&(RCC=0) Q
. I (FLAG="EXCLUDE")&(RCC=1) Q
. ;--- End of ICD Filter check.
. ;
. ;--- Check for Clinic or Division list and quit if not in list
. I RORCDLIST,'$$CDUTIL^RORXU001(.RORTSK,PATIEN,RORCDSTDT,RORCDENDT) Q
. ;
. ;--- Search the pharmacy data
. M RORXDST("RORXGRP")=RORXGRP("C")
. S TMP=$$RXSEARCH^RORUTL14(PATIEN,RORXL,.RORXDST,RXFLAGS,RORSDT,ROREDT1)
. I TMP<0 S ECNT=ECNT+1 Q
. ;--- No medications from some groups
. Q:$D(RORXDST("RORXGRP"))>1
. ;--- Skip the patient if no data has been found
. I '$D(@RORXDST@("IP",PATIEN)),'$D(@RORXDST@("OP",PATIEN)) Q
. ;
. ;--- Calculate intermediate totals
. S RC=$$TOTALS(PATIEN)
. I RC S ECNT=ECNT+1 Q:RC<0
;---
Q $S(RC<0:RC,1:ECNT)
;
;***** CALLBACK FUNCTION FOR THE PHARMACY SEARCH API
RXSCB(ROR8DST,ORDER,ORDFLG,DRUG,DATE) ;
N DRUGIEN,DRUGNAME,IRP,RPS,RXCNT,SUBS,TMP
I ROR8DST("GENERIC") D
. S DRUGIEN=+ROR8DST("RORXGEN"),DRUGNAME=$P(ROR8DST("RORXGEN"),U,2)
E 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 SUBS=$S(ORDFLG["I":"IP",ORDFLG["O":"OP",1:"") Q:SUBS="" 1
S RXCNT=0
;--- Count the original order, refills and partials
I ORDFLG["I" S RXCNT=RXCNT+1 ; Inpatient
E D ; Outpatient
. S TMP=+$P($G(^TMP("PS",$J,"RXN",0)),U,6) ; Original Fill Date
. S:(TMP'<ROR8DST("RORSDT"))&(TMP<ROR8DST("ROREDT")) RXCNT=RXCNT+1
F RPS="PAR","REF" S IRP=0 D
. F S IRP=$O(^TMP("PS",$J,RPS,IRP)) Q:IRP'>0 S RXCNT=RXCNT+1
;--- Update the counters
D:RXCNT>0
. S TMP=$G(@ROR8DST@(SUBS,+ROR8DST("RORDFN"),"D",DRUGIEN))
. S @ROR8DST@(SUBS,+ROR8DST("RORDFN"),"D",DRUGIEN)=TMP+RXCNT
. S TMP=SUBS_"D"
. S:'$D(@ROR8DST@(TMP,DRUGIEN)) @ROR8DST@(TMP,DRUGIEN)=DRUGNAME
Q 0
;
;***** SORTS THE RESULTS AND COMPILES THE TOTALS
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
SORT() ;
N ECNT,NODE,RC
S (ECNT,RC)=0
S NODE=$NA(^TMP("RORX009",$J))
Q:$D(@NODE)<10 0
;---
S RC=$$LOOP^RORTSK01(0) Q:RC<0 RC
D SORTRX(NODE,"IPD")
;---
S RC=$$LOOP^RORTSK01(.33) Q:RC<0 RC
D SORTRX(NODE,"OPD")
;---
S RC=$$LOOP^RORTSK01(.66) Q:RC<0 RC
S RC=$$SUMRX(NODE)
;---
Q $S(RC<0:RC,1:ECNT)
;
;***** SORTS THE DRUG LIST
;
; NODE Closed root of the category section
; in the temporary global
;
; SUBS Drug list subscript ("IPD" or "OPD")
;
SORTRX(NODE,SUBS) ;
N IEN,NAME,NDRUGS,SUM,TMP
S IEN=0,NDRUGS=0
F S IEN=$O(@NODE@(SUBS,IEN)) Q:IEN'>0 D
. S NAME=@NODE@(SUBS,IEN),NDRUGS=NDRUGS+1
. S TMP=+$G(@NODE@(SUBS,IEN,"D"))
. S @NODE@(SUBS,"B",TMP,NAME,IEN)=""
;--- Numbers of different drugs
S @NODE@(SUBS)=NDRUGS
Q
;
;***** COMBINES THE INPATIENT AND OUTPATIENT DATA
;
; NODE Closed root of the category section
; in the temporary global
;
SUMRX(NODE) ;
N COUNT,I,MAXUTNUM,NDRX,NRX,RC,RXIEN,SUMNRX,TMP
Q:($D(@NODE@("IPRX"))<10)!($D(@NODE@("OPRX"))<10) 0
S MAXUTNUM=$$PARAM^RORTSK01("MAXUTNUM")
Q:MAXUTNUM'>0 0
;
;=== Outpatient data
S NRX="",(COUNT,RC)=0
F S NRX=$O(@NODE@("OPRX",NRX),-1) Q:NRX="" D Q:RC
. S RC=$$LOOP^RORTSK01() Q:RC<0
. S @NODE@("SUMRX",NRX)=$G(@NODE@("OPRX",NRX))
. S NAME=""
. F S NAME=$O(@NODE@("OPRX",NRX,NAME)) Q:NAME="" D Q:RC
. . S DFN=""
. . F S DFN=$O(@NODE@("OPRX",NRX,NAME,DFN)) Q:DFN="" D Q:RC
. . . ;--- Include only the patients with highest utilization
. . . S COUNT=COUNT+1 I COUNT>MAXUTNUM S RC=1 Q
. . . ;--- Calculate the totals
. . . S (NDRX,SUMNRX)=0
. . . F I="IP","OP" S TMP=$G(@NODE@(I,DFN)) D
. . . . S NDRX=NDRX+$P(TMP,U,5),SUMNRX=SUMNRX+$P(TMP,U,4)
. . . S @NODE@("SUMRX",SUMNRX,NAME,DFN,"OP")=""
. . . S @NODE@("SUMRX",SUMNRX)=$G(@NODE@("SUMRX",SUMNRX))+1
. . . ;--- Adjust the total number of different drugs
. . . ;--- (some drugs could be both inpatient and outpatient)
. . . S RXIEN=0
. . . F S RXIEN=$O(@NODE@("OP",DFN,"D",RXIEN)) Q:RXIEN'>0 D
. . . . S:$D(@NODE@("IP",DFN,"D",RXIEN)) NDRX=NDRX-1
. . . ;--- Store the number of different drugs
. . . S @NODE@("SUMRX",SUMNRX,NAME,DFN)=NDRX
;
;=== Inpatient data
S NRX="",(COUNT,RC)=0
F S NRX=$O(@NODE@("IPRX",NRX),-1) Q:NRX="" D Q:RC
. S RC=$$LOOP^RORTSK01() Q:RC<0
. S NAME=""
. F S NAME=$O(@NODE@("IPRX",NRX,NAME)) Q:NAME="" D Q:RC
. . S DFN=""
. . F S DFN=$O(@NODE@("IPRX",NRX,NAME,DFN)) Q:DFN="" D Q:RC
. . . ;--- Include only the patients with highest utilization
. . . S COUNT=COUNT+1 I COUNT>MAXUTNUM S RC=1 Q
. . . ;--- Calculate the totals
. . . S (NDRX,SUMNRX)=0
. . . F I="IP","OP" S TMP=$G(@NODE@(I,DFN)) D
. . . . S NDRX=NDRX+$P(TMP,U,5),SUMNRX=SUMNRX+$P(TMP,U,4)
. . . S @NODE@("SUMRX",SUMNRX,NAME,DFN,"IP")=""
. . . ;--- Quit if the patient has been processed already
. . . Q:$D(@NODE@("SUMRX",SUMNRX,NAME,DFN,"OP"))
. . . S @NODE@("SUMRX",SUMNRX)=$G(@NODE@("SUMRX",SUMNRX))+1
. . . ;--- Adjust the total number of different drugs
. . . ;--- (some drugs could be both inpatient and outpatient)
. . . S RXIEN=0
. . . F S RXIEN=$O(@NODE@("IP",DFN,"D",RXIEN)) Q:RXIEN'>0 D
. . . . S:$D(@NODE@("OP",DFN,"D",RXIEN)) NDRX=NDRX-1
. . . ;--- Store the number of different drugs
. . . S @NODE@("SUMRX",SUMNRX,NAME,DFN)=NDRX
;===
Q $S(RC<0:RC,1:0)
;
;***** CALCULATES THE INTERMEDIATE TOTALS
;
; PATIEN Patient IEN (DFN)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
TOTALS(PATIEN) ;
N DOD,IEN,LAST4,NDRUGS,NODE,NRX,PTNAME,PTNRX,RXS,SUBS,TMP,VA,VADM,VAERR,AGE,AGETYPE
S NODE=$NA(^TMP("RORX009",$J))
;--- Get the patient's data
D VADEM^RORUTL05(PATIEN,1)
S PTNAME=VADM(1),LAST4="0000",DOD=$$DATE^RORXU002(VADM(6)\1)
S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
S AGE=$S(AGETYPE="AGE":$P(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($P(VADM(3),U)\1),1:"")
;---
F SUBS="IP","OP" D:$D(@NODE@(SUBS,PATIEN))>1
. S RXS=SUBS_"D"
. S IEN=0,(NDRUGS,PTNRX)=0
. F S IEN=$O(@NODE@(SUBS,PATIEN,"D",IEN)) Q:IEN'>0 D
. . S NRX=@NODE@(SUBS,PATIEN,"D",IEN)
. . S NDRUGS=NDRUGS+1,PTNRX=PTNRX+NRX
. . ;---
. . S @NODE@(RXS,IEN,"D")=$G(@NODE@(RXS,IEN,"D"))+NRX
. . S @NODE@(RXS,IEN,"P")=$G(@NODE@(RXS,IEN,"P"))+1
. . ;---
. . S TMP=$G(@NODE@(RXS,IEN,"M"))
. . D:NRX'<TMP
. . . I NRX>TMP S @NODE@(RXS,IEN,"M")=NRX_U_1 Q
. . . S $P(@NODE@(RXS,IEN,"M"),U,2)=$P(TMP,U,2)+1
. ;---
. S @NODE@(SUBS)=$G(@NODE@(SUBS))+1
. S TMP=$S($$PARAM^RORTSK01("PATIENTS","ICN"):$$ICN^RORUTL02(PATIEN),1:"")
. S @NODE@(SUBS,PATIEN)=LAST4_U_PTNAME_U_DOD_U_PTNRX_U_NDRUGS_U_TMP
. S TMP=$S($$PARAM^RORTSK01("PATIENTS","PACT"):$$PACT^RORUTL02(PATIEN),1:"")
. S @NODE@(SUBS,PATIEN)=@NODE@(SUBS,PATIEN)_U_TMP
. S TMP=$S($$PARAM^RORTSK01("PATIENTS","PCP"):$$PCP^RORUTL02(PATIEN),1:"")
. S @NODE@(SUBS,PATIEN)=@NODE@(SUBS,PATIEN)_U_TMP_U_AGE
. ;---
. S RXS=SUBS_"RX"
. S @NODE@(RXS)=$G(@NODE@(RXS))+PTNRX
. S @NODE@(RXS,PTNRX)=$G(@NODE@(RXS,PTNRX))+1
. S @NODE@(RXS,PTNRX,PTNAME,PATIEN)=""
;---
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX009A 10764 printed Sep 23, 2025@19:20:31 Page 2
RORX009A ;HOIFO/SG,VAC - PRESCRIPTION UTILIZ. (QUERY & SORT) ;4/7/09 2:08pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**8,13,19,21,31,39**;Feb 17, 2006;Build 4
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #10103 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 User can select specific patients,
+16 ; clinics, or divisions for the report.
+17 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+18 ;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
+19 ; additional identifier option selected
+20 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP, and AGE/DOB as additional
+21 ; identifiers.
+22 ;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
+23 ;
+24 ;******************************************************************************
+25 ;******************************************************************************
+26 QUIT
+27 ;
+28 ;***** QUERIES THE REGISTRY
+29 ;
+30 ; FLAGS Flags for the $$SKIP^RORXU005
+31 ;
+32 ; Return Values:
+33 ; <0 Error code
+34 ; 0 Ok
+35 ; >0 Number of non-fatal errors
+36 ;
QUERY(FLAGS) ;
+1 ; Day after the end date
NEW ROREDT1
+2 ; Number of patients in the registry
NEW RORPTN
+3 ; Flag to indicate whether a clinic or division list exists
NEW RORCDLIST
+4 ; Start date for clinic/division utilization search
NEW RORCDSTDT
+5 ; End date for clinic/division utilization search
NEW RORCDENDT
+6 ;
+7 NEW CNT,ECNT,IEN,IENS,PATIEN,RC,RORXDST,RXFLAGS,TMP,XREFNODE
+8 NEW RCC,FLAG
+9 SET XREFNODE=$NAME(^RORDATA(798,"AC",+RORREG))
+10 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
if RORPTN<0
SET RORPTN=0
+11 SET ROREDT1=$$FMADD^XLFDT(ROREDT,1)
+12 SET (CNT,ECNT,RC)=0
+13 ;
+14 ;--- Prepare parameters for the pharmacy search API
+15 SET RORXDST=$NAME(^TMP("RORX009",$JOB))
+16 SET RORXDST("RORCB")="$$RXSCB^RORX009A"
+17 SET RORXDST("GENERIC")=$$PARAM^RORTSK01("DRUGS","AGGR_GENERIC")
+18 SET RXFLAGS="E"
+19 if $$PARAM^RORTSK01("PATIENTS","INPATIENT")
SET RXFLAGS=RXFLAGS_"IV"
+20 if $$PARAM^RORTSK01("PATIENTS","OUTPATIENT")
SET RXFLAGS=RXFLAGS_"O"
+21 if RXFLAGS="E"
QUIT 0
+22 ;
+23 ;=== Set up Clinic/Division list parameters
+24 SET RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT)
+25 ;
+26 ;--- Browse through the registry records
+27 SET IEN=0
+28 SET FLAG=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+29 FOR
SET IEN=$ORDER(@XREFNODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+30 SET TMP=$SELECT(RORPTN>0:CNT/RORPTN,1:"")
+31 SET RC=$$LOOP^RORTSK01(TMP)
if RC<0
QUIT
+32 SET IENS=IEN_","
SET CNT=CNT+1
+33 ;--- Get patient DFN
+34 SET PATIEN=$$PTIEN^RORUTL01(IEN)
if PATIEN'>0
QUIT
+35 ;check for patient list and quit if not on list
+36 IF $DATA(RORTSK("PARAMS","PATIENTS","C"))
IF '$DATA(RORTSK("PARAMS","PATIENTS","C",PATIEN))
QUIT
+37 ;--- Check if the patient should be skipped
+38 if $$SKIP^RORXU005(IEN,FLAGS,RORSDT,ROREDT)
QUIT
+39 ;--- Check if patient filtered for ICD Codes
+40 SET RCC=0
+41 IF FLAG'="ALL"
Begin DoDot:2
+42 SET RCC=$$ICD^RORXU010(PATIEN)
End DoDot:2
+43 IF (FLAG="INCLUDE")&(RCC=0)
QUIT
+44 IF (FLAG="EXCLUDE")&(RCC=1)
QUIT
+45 ;--- End of ICD Filter check.
+46 ;
+47 ;--- Check for Clinic or Division list and quit if not in list
+48 IF RORCDLIST
IF '$$CDUTIL^RORXU001(.RORTSK,PATIEN,RORCDSTDT,RORCDENDT)
QUIT
+49 ;
+50 ;--- Search the pharmacy data
+51 MERGE RORXDST("RORXGRP")=RORXGRP("C")
+52 SET TMP=$$RXSEARCH^RORUTL14(PATIEN,RORXL,.RORXDST,RXFLAGS,RORSDT,ROREDT1)
+53 IF TMP<0
SET ECNT=ECNT+1
QUIT
+54 ;--- No medications from some groups
+55 if $DATA(RORXDST("RORXGRP"))>1
QUIT
+56 ;--- Skip the patient if no data has been found
+57 IF '$DATA(@RORXDST@("IP",PATIEN))
IF '$DATA(@RORXDST@("OP",PATIEN))
QUIT
+58 ;
+59 ;--- Calculate intermediate totals
+60 SET RC=$$TOTALS(PATIEN)
+61 IF RC
SET ECNT=ECNT+1
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+62 ;---
+63 QUIT $SELECT(RC<0:RC,1:ECNT)
+64 ;
+65 ;***** CALLBACK FUNCTION FOR THE PHARMACY SEARCH API
RXSCB(ROR8DST,ORDER,ORDFLG,DRUG,DATE) ;
+1 NEW DRUGIEN,DRUGNAME,IRP,RPS,RXCNT,SUBS,TMP
+2 IF ROR8DST("GENERIC")
Begin DoDot:1
+3 SET DRUGIEN=+ROR8DST("RORXGEN")
SET DRUGNAME=$PIECE(ROR8DST("RORXGEN"),U,2)
End DoDot:1
+4 IF '$TEST
SET DRUGIEN=+DRUG
SET DRUGNAME=$PIECE(DRUG,U,2)
+5 if (DRUGIEN'>0)!(DRUGNAME="")
QUIT 1
+6 ;=== Check the drug groups
+7 SET TMP=$$RXGRPCHK^RORXU007(.ROR8DST,+DRUG,RORXL)
+8 if TMP
QUIT TMP
+9 ;=== Process the order
+10 SET SUBS=$SELECT(ORDFLG["I":"IP",ORDFLG["O":"OP",1:"")
if SUBS=""
QUIT 1
+11 SET RXCNT=0
+12 ;--- Count the original order, refills and partials
+13 ; Inpatient
IF ORDFLG["I"
SET RXCNT=RXCNT+1
+14 ; Outpatient
IF '$TEST
Begin DoDot:1
+15 ; Original Fill Date
SET TMP=+$PIECE($GET(^TMP("PS",$JOB,"RXN",0)),U,6)
+16 if (TMP'<ROR8DST("RORSDT"))&(TMP<ROR8DST("ROREDT"))
SET RXCNT=RXCNT+1
End DoDot:1
+17 FOR RPS="PAR","REF"
SET IRP=0
Begin DoDot:1
+18 FOR
SET IRP=$ORDER(^TMP("PS",$JOB,RPS,IRP))
if IRP'>0
QUIT
SET RXCNT=RXCNT+1
End DoDot:1
+19 ;--- Update the counters
+20 if RXCNT>0
Begin DoDot:1
+21 SET TMP=$GET(@ROR8DST@(SUBS,+ROR8DST("RORDFN"),"D",DRUGIEN))
+22 SET @ROR8DST@(SUBS,+ROR8DST("RORDFN"),"D",DRUGIEN)=TMP+RXCNT
+23 SET TMP=SUBS_"D"
+24 if '$DATA(@ROR8DST@(TMP,DRUGIEN))
SET @ROR8DST@(TMP,DRUGIEN)=DRUGNAME
End DoDot:1
+25 QUIT 0
+26 ;
+27 ;***** SORTS THE RESULTS AND COMPILES THE TOTALS
+28 ;
+29 ; Return Values:
+30 ; <0 Error code
+31 ; 0 Ok
+32 ; >0 Number of non-fatal errors
+33 ;
SORT() ;
+1 NEW ECNT,NODE,RC
+2 SET (ECNT,RC)=0
+3 SET NODE=$NAME(^TMP("RORX009",$JOB))
+4 if $DATA(@NODE)<10
QUIT 0
+5 ;---
+6 SET RC=$$LOOP^RORTSK01(0)
if RC<0
QUIT RC
+7 DO SORTRX(NODE,"IPD")
+8 ;---
+9 SET RC=$$LOOP^RORTSK01(.33)
if RC<0
QUIT RC
+10 DO SORTRX(NODE,"OPD")
+11 ;---
+12 SET RC=$$LOOP^RORTSK01(.66)
if RC<0
QUIT RC
+13 SET RC=$$SUMRX(NODE)
+14 ;---
+15 QUIT $SELECT(RC<0:RC,1:ECNT)
+16 ;
+17 ;***** SORTS THE DRUG LIST
+18 ;
+19 ; NODE Closed root of the category section
+20 ; in the temporary global
+21 ;
+22 ; SUBS Drug list subscript ("IPD" or "OPD")
+23 ;
SORTRX(NODE,SUBS) ;
+1 NEW IEN,NAME,NDRUGS,SUM,TMP
+2 SET IEN=0
SET NDRUGS=0
+3 FOR
SET IEN=$ORDER(@NODE@(SUBS,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+4 SET NAME=@NODE@(SUBS,IEN)
SET NDRUGS=NDRUGS+1
+5 SET TMP=+$GET(@NODE@(SUBS,IEN,"D"))
+6 SET @NODE@(SUBS,"B",TMP,NAME,IEN)=""
End DoDot:1
+7 ;--- Numbers of different drugs
+8 SET @NODE@(SUBS)=NDRUGS
+9 QUIT
+10 ;
+11 ;***** COMBINES THE INPATIENT AND OUTPATIENT DATA
+12 ;
+13 ; NODE Closed root of the category section
+14 ; in the temporary global
+15 ;
SUMRX(NODE) ;
+1 NEW COUNT,I,MAXUTNUM,NDRX,NRX,RC,RXIEN,SUMNRX,TMP
+2 if ($DATA(@NODE@("IPRX"))<10)!($DATA(@NODE@("OPRX"))<10)
QUIT 0
+3 SET MAXUTNUM=$$PARAM^RORTSK01("MAXUTNUM")
+4 if MAXUTNUM'>0
QUIT 0
+5 ;
+6 ;=== Outpatient data
+7 SET NRX=""
SET (COUNT,RC)=0
+8 FOR
SET NRX=$ORDER(@NODE@("OPRX",NRX),-1)
if NRX=""
QUIT
Begin DoDot:1
+9 SET RC=$$LOOP^RORTSK01()
if RC<0
QUIT
+10 SET @NODE@("SUMRX",NRX)=$GET(@NODE@("OPRX",NRX))
+11 SET NAME=""
+12 FOR
SET NAME=$ORDER(@NODE@("OPRX",NRX,NAME))
if NAME=""
QUIT
Begin DoDot:2
+13 SET DFN=""
+14 FOR
SET DFN=$ORDER(@NODE@("OPRX",NRX,NAME,DFN))
if DFN=""
QUIT
Begin DoDot:3
+15 ;--- Include only the patients with highest utilization
+16 SET COUNT=COUNT+1
IF COUNT>MAXUTNUM
SET RC=1
QUIT
+17 ;--- Calculate the totals
+18 SET (NDRX,SUMNRX)=0
+19 FOR I="IP","OP"
SET TMP=$GET(@NODE@(I,DFN))
Begin DoDot:4
+20 SET NDRX=NDRX+$PIECE(TMP,U,5)
SET SUMNRX=SUMNRX+$PIECE(TMP,U,4)
End DoDot:4
+21 SET @NODE@("SUMRX",SUMNRX,NAME,DFN,"OP")=""
+22 SET @NODE@("SUMRX",SUMNRX)=$GET(@NODE@("SUMRX",SUMNRX))+1
+23 ;--- Adjust the total number of different drugs
+24 ;--- (some drugs could be both inpatient and outpatient)
+25 SET RXIEN=0
+26 FOR
SET RXIEN=$ORDER(@NODE@("OP",DFN,"D",RXIEN))
if RXIEN'>0
QUIT
Begin DoDot:4
+27 if $DATA(@NODE@("IP",DFN,"D",RXIEN))
SET NDRX=NDRX-1
End DoDot:4
+28 ;--- Store the number of different drugs
+29 SET @NODE@("SUMRX",SUMNRX,NAME,DFN)=NDRX
End DoDot:3
if RC
QUIT
End DoDot:2
if RC
QUIT
End DoDot:1
if RC
QUIT
+30 ;
+31 ;=== Inpatient data
+32 SET NRX=""
SET (COUNT,RC)=0
+33 FOR
SET NRX=$ORDER(@NODE@("IPRX",NRX),-1)
if NRX=""
QUIT
Begin DoDot:1
+34 SET RC=$$LOOP^RORTSK01()
if RC<0
QUIT
+35 SET NAME=""
+36 FOR
SET NAME=$ORDER(@NODE@("IPRX",NRX,NAME))
if NAME=""
QUIT
Begin DoDot:2
+37 SET DFN=""
+38 FOR
SET DFN=$ORDER(@NODE@("IPRX",NRX,NAME,DFN))
if DFN=""
QUIT
Begin DoDot:3
+39 ;--- Include only the patients with highest utilization
+40 SET COUNT=COUNT+1
IF COUNT>MAXUTNUM
SET RC=1
QUIT
+41 ;--- Calculate the totals
+42 SET (NDRX,SUMNRX)=0
+43 FOR I="IP","OP"
SET TMP=$GET(@NODE@(I,DFN))
Begin DoDot:4
+44 SET NDRX=NDRX+$PIECE(TMP,U,5)
SET SUMNRX=SUMNRX+$PIECE(TMP,U,4)
End DoDot:4
+45 SET @NODE@("SUMRX",SUMNRX,NAME,DFN,"IP")=""
+46 ;--- Quit if the patient has been processed already
+47 if $DATA(@NODE@("SUMRX",SUMNRX,NAME,DFN,"OP"))
QUIT
+48 SET @NODE@("SUMRX",SUMNRX)=$GET(@NODE@("SUMRX",SUMNRX))+1
+49 ;--- Adjust the total number of different drugs
+50 ;--- (some drugs could be both inpatient and outpatient)
+51 SET RXIEN=0
+52 FOR
SET RXIEN=$ORDER(@NODE@("IP",DFN,"D",RXIEN))
if RXIEN'>0
QUIT
Begin DoDot:4
+53 if $DATA(@NODE@("OP",DFN,"D",RXIEN))
SET NDRX=NDRX-1
End DoDot:4
+54 ;--- Store the number of different drugs
+55 SET @NODE@("SUMRX",SUMNRX,NAME,DFN)=NDRX
End DoDot:3
if RC
QUIT
End DoDot:2
if RC
QUIT
End DoDot:1
if RC
QUIT
+56 ;===
+57 QUIT $SELECT(RC<0:RC,1:0)
+58 ;
+59 ;***** CALCULATES THE INTERMEDIATE TOTALS
+60 ;
+61 ; PATIEN Patient IEN (DFN)
+62 ;
+63 ; Return Values:
+64 ; <0 Error code
+65 ; 0 Ok
+66 ; >0 Number of non-fatal errors
+67 ;
TOTALS(PATIEN) ;
+1 NEW DOD,IEN,LAST4,NDRUGS,NODE,NRX,PTNAME,PTNRX,RXS,SUBS,TMP,VA,VADM,VAERR,AGE,AGETYPE
+2 SET NODE=$NAME(^TMP("RORX009",$JOB))
+3 ;--- Get the patient's data
+4 DO VADEM^RORUTL05(PATIEN,1)
+5 SET PTNAME=VADM(1)
SET LAST4="0000"
SET DOD=$$DATE^RORXU002(VADM(6)\1)
+6 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
+7 SET AGE=$SELECT(AGETYPE="AGE":$PIECE(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($PIECE(VADM(3),U)\1),1:"")
+8 ;---
+9 FOR SUBS="IP","OP"
if $DATA(@NODE@(SUBS,PATIEN))>1
Begin DoDot:1
+10 SET RXS=SUBS_"D"
+11 SET IEN=0
SET (NDRUGS,PTNRX)=0
+12 FOR
SET IEN=$ORDER(@NODE@(SUBS,PATIEN,"D",IEN))
if IEN'>0
QUIT
Begin DoDot:2
+13 SET NRX=@NODE@(SUBS,PATIEN,"D",IEN)
+14 SET NDRUGS=NDRUGS+1
SET PTNRX=PTNRX+NRX
+15 ;---
+16 SET @NODE@(RXS,IEN,"D")=$GET(@NODE@(RXS,IEN,"D"))+NRX
+17 SET @NODE@(RXS,IEN,"P")=$GET(@NODE@(RXS,IEN,"P"))+1
+18 ;---
+19 SET TMP=$GET(@NODE@(RXS,IEN,"M"))
+20 if NRX'<TMP
Begin DoDot:3
+21 IF NRX>TMP
SET @NODE@(RXS,IEN,"M")=NRX_U_1
QUIT
+22 SET $PIECE(@NODE@(RXS,IEN,"M"),U,2)=$PIECE(TMP,U,2)+1
End DoDot:3
End DoDot:2
+23 ;---
+24 SET @NODE@(SUBS)=$GET(@NODE@(SUBS))+1
+25 SET TMP=$SELECT($$PARAM^RORTSK01("PATIENTS","ICN"):$$ICN^RORUTL02(PATIEN),1:"")
+26 SET @NODE@(SUBS,PATIEN)=LAST4_U_PTNAME_U_DOD_U_PTNRX_U_NDRUGS_U_TMP
+27 SET TMP=$SELECT($$PARAM^RORTSK01("PATIENTS","PACT"):$$PACT^RORUTL02(PATIEN),1:"")
+28 SET @NODE@(SUBS,PATIEN)=@NODE@(SUBS,PATIEN)_U_TMP
+29 SET TMP=$SELECT($$PARAM^RORTSK01("PATIENTS","PCP"):$$PCP^RORUTL02(PATIEN),1:"")
+30 SET @NODE@(SUBS,PATIEN)=@NODE@(SUBS,PATIEN)_U_TMP_U_AGE
+31 ;---
+32 SET RXS=SUBS_"RX"
+33 SET @NODE@(RXS)=$GET(@NODE@(RXS))+PTNRX
+34 SET @NODE@(RXS,PTNRX)=$GET(@NODE@(RXS,PTNRX))+1
+35 SET @NODE@(RXS,PTNRX,PTNAME,PATIEN)=""
End DoDot:1
+36 ;---
+37 QUIT 0
