SCRPW40 ;RENO/KEITH - Diagnosis/Procedure Frequency Report ;06/22/99
;;5.3;Scheduling;**144,180,556,593**;AUG 13, 1993;Build 13
;06/22/99 ACS - Added CPT modifiers to the report
;06/22/99 ACS - Added CPT modifier API calls
;04/13/08 - Updating to replace calls to unsupported/deleted ICD9 fields with API calls
;
N SDDIV,SD,%DT,X,Y,DIR,SDX,LINEFLAG
D TITL^SCRPW50("Outpatient Diagnosis/Procedure Frequency Report")
I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 G EXIT
D SUBT^SCRPW50("**** Date Range Selection ****")
S Y=$$IMP^SCRPWICD(30) S SD("I10DTI")=Y X ^DD("DD") S SD("I10DTE")=Y
BDT W ! S %DT="AEPX",%DT(0)=2961001,%DT("A")="Beginning date: " D ^%DT I Y<1 S SDOUT=1 G EXIT
S SD("BDT")=Y
EDT S %DT("A")=" Ending date: " W ! D ^%DT I Y<1 S SDOUT=1 G EXIT
I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT
S SD("EDT")=Y_.999999
I (SD("BDT")<SD("I10DTI")),(SD("EDT")'<SD("I10DTI")) D G BDT
. W !!,$C(7),"Beginning and Ending dates must both be prior to "_SD("I10DTE")_" (ICD-9) or both be on or after "_SD("I10DTE")_" (ICD-10)."
D SUBT^SCRPW50("**** Report Format Selection ****")
K DIR S DIR(0)="S^D:DIAGNOSIS FREQUENCY;P:PROCEDURE FREQUENCY;B:BOTH DIAGNOSIS AND PROCEDURE",DIR("A")="Specify the type of report to print",DIR("?")="This determines the type of lists returned by the report."
D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
S SD("TYPE")=Y
K DIR S DIR(0)="N^1:99999:0",DIR("A")="Limit list to most frequent",DIR("B")=50,DIR("?")="Enter the quantity of the most frequent items to list."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
S SD("FREQ")=Y
W ! N ZTSAVE S ZTSAVE("SDDIV")="",ZTSAVE("SDDIV(")="",ZTSAVE("SD(")="" D EN^XUTMDEVQ("START^SCRPW40","Outpatient Diagnosis/Procedure Frequency Report",.ZTSAVE) S SDOUT=1 G EXIT
;
START ;Print report
S (SDOUT,SDSTOP)=0 K ^TMP("SCRPW",$J) S SDI=$O(SDDIV("")),SDI=$O(SDDIV(SDI)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDI=1 S SDDIV("MULT")=SDI
S SDT=SD("BDT") F S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SD("EDT"))!SDOUT S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I '$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,4),$$DIV() D EVAL
G:SDOUT EXIT S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D ORD
D STOP G:SDOUT EXIT D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDLINE="",$P(SDLINE,"-",(IOM+1))="",SDFF=0
S Y=SD("BDT") X ^DD("DD") S SDPBDT=Y,Y=$P(SD("EDT"),".") X ^DD("DD") S SDPEDT=Y,SDT(1)="<*> OUTPATIENT "_$S(SD("TYPE")="D":"DIAGNOSIS",SD("TYPE")="P":"PROCEDURE",1:"DIAGNOSIS/PROCEDURE")_" FREQUENCY REPORT <*>"
S SDT(2)="For the "_SD("FREQ")_" most frequent "_$S(SD("TYPE")="D":"diagnoses",SD("TYPE")="P":"procedures",1:"diagnoses and procedures")
S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV
I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
D:$E(IOST)="C" DISP0^SCRPW23 I '$O(^TMP("SCRPW",$J,0)) S SDIV=0 D DHDR(2,.SDT) D HDR Q:SDOUT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT
S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
S SDI=0,SDI=$O(^TMP("SCRPW",$J,SDI)),SDDIV("MULT")=$O(^TMP("SCRPW",$J,SDI))
G:SDOUT EXIT I SDDIV("MULT") S SDIV=0 D DPRT(.SDIV)
;
EXIT I $E(IOST)="C",'$G(SDOUT) N DIR S DIR(0)="E" D ^DIR
K %,%DT,C,DIR,DIVN,DTOUT,DUOUT,SD,SDCT,SDDIV,SDDX,SDDX0,SDDXC,SDDXN,SDFF,SDI,SDII,SDIV,SDIVN,SDLINE,SDLIST,SDOE,SDOE0
K SDX,SDORD,SDOUT,SDPAGE,SDPBDT,SDPEDT,SDPNOW,SDPR,SDPR0,SDPRC,SDPRN,SDPROC,SDPS,SDQT,SDSTOP,SDT,SDTOT,X,Y D END^SCRPW50 Q
;
DIV() ;Check division
Q:'SDDIV 1 Q $D(SDDIV(+$P(SDOE0,U,11)))
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
EVAL ;Evaluate encounter
S SDSTOP=SDSTOP+1 D:SDSTOP#3000=0 STOP Q:SDOUT
S SDIV=+$P(SDOE0,U,11) D:"DB"[SD("TYPE") DX D:"PB"[SD("TYPE") PROC Q
;
DX ;Get diagnoses
N SDLIST,SDI D GETDX^SDOE(SDOE,"SDLIST")
S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D DX1(SDIV) D:SDDIV("MULT") DX1(0)
Q
;
DX1(SDIV) S SDDX=+SDLIST(SDI),SDPS=$S($P(SDLIST(SDI),U,12)="P":"PRI",1:"SEC")
F SDPS=SDPS,"QTY" S ^TMP("SCRPW",$J,SDIV,"DX",1,SDDX,SDPS)=$G(^TMP("SCRPW",$J,SDIV,"DX",1,SDDX,SDPS))+1
Q
;
PROC ;Get procedures
N SDLIST,SDI D GETCPT^SDOE(SDOE,"SDLIST")
S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D PROC1(SDIV) D:SDDIV("MULT") PROC1(0)
Q
;
PROC1(SDIV) S SDPROC=+SDLIST(SDI),SDQT=$P(SDLIST(SDI),U,16) S:'SDQT SDQT=1
S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"ENC")=$G(^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"ENC"))+1
S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"QTY")=$G(^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"QTY"))+SDQT
;
;set encounter and modifier quantity
N SDMOD,SDMODN
S SDMODN=0
F S SDMODN=$O(SDLIST(SDI,1,SDMODN)) Q:SDMODN="" D
. S SDMOD=$G(SDLIST(SDI,1,SDMODN,0))
. Q:SDMOD=""
. S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,SDMOD,"ENC")=+1
. S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,SDMOD,"QTY")=+SDQT
. Q
Q
;
ORD ;Determine list order
S SDI="" F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDI)) Q:SDI="" S SDII=0 F S SDII=$O(^TMP("SCRPW",$J,SDIV,SDI,1,SDII)) Q:'SDII S ^TMP("SCRPW",$J,SDIV,SDI,2,$$ORDV(),SDII)=""
Q
;
ORDV() Q ^TMP("SCRPW",$J,SDIV,SDI,1,SDII,"QTY")
;
DPRT(SDIV) ;Print report for a division
;Required input: SDIV=division ifn (or '0' for summary)
S C=(IOM-80\2) D DHDR(3,.SDT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDPAGE=1 D HDR Q:SDOUT S SDX="No activity found for this date range!" W !!?(IOM-$L(SDX)\2),SDX Q
I $D(^TMP("SCRPW",$J,SDIV,"DX")) D DXPRT Q:SDOUT
I $D(^TMP("SCRPW",$J,SDIV,"PROC")) D PRPRT
Q
;
DXPRT ;Print diagnosis list
N SDTOT S SDPAGE=1 D HDR Q:SDOUT D DXHD S (SDCT,SDORD)="" F S SDORD=$O(^TMP("SCRPW",$J,SDIV,"DX",2,SDORD),-1) Q:SDORD=""!SDOUT!(SDCT>(SD("FREQ")-1)) D DXP1
Q:SDOUT D:$Y>(IOSL-4) HDR,DXHD Q:SDOUT
W !?(C),$E(SDLINE,1,7),?(C+9),$E(SDLINE,1,35),?(C+46),$E(SDLINE,1,10),?(C+58),$E(SDLINE,1,10),?(C+70),$E(SDLINE,1,10)
W !?(C),"TOTAL:",?(C+46),$J(SDTOT("PRI"),9,0),?(C+58),$J(SDTOT("SEC"),9,0),?(C+70),$J(SDTOT("QTY"),9,0)
Q
;
DXP1 S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"DX",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) S SDDX0=$$ICDDX^SCRPWICD(SDI) I $L(SDDX0) S SDDXC=$P(SDDX0,U,2),SDDXN=$P(SDDX0,U,4) D DXP2
Q
;
DXP2 N DIWL,DIWF,SDL2 S DIWL=1 S DIWF="C35|"
F SDII="PRI","SEC","QTY" S SDDX(SDII)=+$G(^TMP("SCRPW",$J,SDIV,"DX",1,SDI,SDII))
D:$Y>(IOSL-4) HDR,DXHD Q:SDOUT S SDCT=SDCT+1
K ^UTILITY($J,"W") S X=SDDXN D ^DIWP
F SDL2=1:1:^UTILITY($J,"W",DIWL) D
. I SDL2=1 W !?(C),SDDXC,?(C+9),$E(^UTILITY($J,"W",DIWL,SDL2,0),1,35) I 1
. E W !,?(C+9),$E(^UTILITY($J,"W",DIWL,SDL2,0),1,35)
W ?(C+46),$J(SDDX("PRI"),9,0),?(C+58),$J(SDDX("SEC"),9,0),?(C+70),$J(SDDX("QTY"),9,0)
F SDII="PRI","SEC","QTY" S SDTOT(SDII)=$G(SDTOT(SDII))+SDDX(SDII)
Q
;
PRPRT N SDTOT S C=(IOM-62\2),SDPAGE=1 D HDR Q:SDOUT D PRHD S (SDCT,SDORD)="" F S SDORD=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD),-1) Q:SDORD=""!SDOUT!(SDCT>(SD("FREQ")-1)) D PRP1
Q:SDOUT D:$Y>(IOSL-4) HDR,PRHD Q:SDOUT
W !?(C),$E(SDLINE,1,6),?(C+8),$E(SDLINE,1,28),?(C+38),$E(SDLINE,1,10),?(C+50),$E(SDLINE,1,10),!?(C),"PROCEDURE TOTAL:",?(C+38),$J(SDTOT("ENC"),9,0),?(C+50),$J(SDTOT("QTY"),9,0)
Q
;
PRP1 ;S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) S SDPR0=$G(^ICPT(SDI,0)) I $L(SDPR0) S SDPRC=$P(SDPR0,U),SDPRN=$P(SDPR0,U,2) D PRP2
N CPTINFO
S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) D
. S CPTINFO=$$CPT^ICPTCOD(SDI,,1)
. Q:CPTINFO'>0
. S SDPRC=$P(CPTINFO,U,2)
. S SDPRN=$P(CPTINFO,U,3)
. D PRP2
. Q
Q
;
PRP2 F SDII="ENC","QTY" S SDPR(SDII)=+$G(^TMP("SCRPW",$J,SDIV,"PROC",1,SDI,SDII))
D:$Y>(IOSL-4) HDR,PRHD Q:SDOUT S SDCT=SDCT+1
; skip a line in the report if printing next cpt code on same page
I LINEFLAG W !
W !?(C),SDPRC,?(C+8),SDPRN,?(C+38),$J(SDPR("ENC"),9,0),?(C+50),$J(SDPR("QTY"),9,0)
S LINEFLAG=1
F SDII="ENC","QTY" S SDTOT(SDII)=$G(SDTOT(SDII))+SDPR(SDII)
;
;rank and print the modifiers
D START^SCRPW401($NA(^TMP("SCRPW",$J,SDIV,"PROC",1,SDI)))
Q
;
PRHD ;Print procedure subheader
S LINEFLAG=0 Q:SDOUT W !!?(C),"CODE",!?(C),"NUMBER",?(C+8),"PROCEDURE/MODIFIER",?(C+38),"ENCOUNTERS",?(C+52),"QUANTITY",!?(C),$E(SDLINE,1,6),?(C+8),$E(SDLINE,1,28),?(C+38),$E(SDLINE,1,10),?(C+50),$E(SDLINE,1,10)
Q
;
DXHD ;Print diagnosis subheader
Q:SDOUT W !!?(C),"CODE",?(C+49),"PRIMARY",?(C+59),"SECONDARY",?(C+75),"TOTAL",!?(C),"NUMBER",?(C+9),"DIAGNOSIS",?(C+47),"DIAGNOSIS",?(C+59),"DIAGNOSIS",?(C+71),"FREQUENCY"
W !?(C),$E(SDLINE,1,7),?(C+9),$E(SDLINE,1,35),?(C+46),$E(SDLINE,1,10),?(C+58),$E(SDLINE,1,10),?(C+70),$E(SDLINE,1,10) Q
;
HDR ;Print report header
I $E(IOST)="C",SDFF N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
D STOP Q:SDOUT
I SDFF!($E(IOST)="C") W $$XY^SCRPW50(IOF,1,0)
I $X W $$XY^SCRPW50("",0,0)
N SDI W SDLINE S SDI=0 F S SDI=$O(SDT(SDI)) Q:'SDI W !?(IOM-$L(SDT(SDI))\2),SDT(SDI)
W !,SDLINE,!,"For date range: ",SDPBDT," to ",SDPEDT,!,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1,SDFF=1 Q
;
DHDR(SDI,SDT) ;Set up division subheaders
;Required input: SDI=array number to start with
;Required input: SDT=array to store subheaders in (pass by reference)
S SDT(SDI)=$S('SDIV:"Summary for "_$P(SDDIV,U,2),SDDIV!($P(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN,1:"For facility: "_SDIVN)
I 'SDIV,$P(SDDIV,U,2)="SELECTED DIVISIONS" N SDIVN S SDIVN="" D Q
.F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" S SDI=SDI+1,SDT(SDI)="Division: "_SDIVN
.Q
I 'SDIV,$P(SDDIV,U,2)="ALL DIVISIONS" D
.N SDIV S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV S SDI=SDI+1,SDT(SDI)="Division: "_$P($G(^DG(40.8,SDIV,0)),U)
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW40 10001 printed Sep 23, 2025@20:20:01 Page 2
SCRPW40 ;RENO/KEITH - Diagnosis/Procedure Frequency Report ;06/22/99
+1 ;;5.3;Scheduling;**144,180,556,593**;AUG 13, 1993;Build 13
+2 ;06/22/99 ACS - Added CPT modifiers to the report
+3 ;06/22/99 ACS - Added CPT modifier API calls
+4 ;04/13/08 - Updating to replace calls to unsupported/deleted ICD9 fields with API calls
+5 ;
+6 NEW SDDIV,SD,%DT,X,Y,DIR,SDX,LINEFLAG
+7 DO TITL^SCRPW50("Outpatient Diagnosis/Procedure Frequency Report")
+8 IF '$$DIVA^SCRPW17(.SDDIV)
SET SDOUT=1
GOTO EXIT
+9 DO SUBT^SCRPW50("**** Date Range Selection ****")
+10 SET Y=$$IMP^SCRPWICD(30)
SET SD("I10DTI")=Y
XECUTE ^DD("DD")
SET SD("I10DTE")=Y
BDT WRITE !
SET %DT="AEPX"
SET %DT(0)=2961001
SET %DT("A")="Beginning date: "
DO ^%DT
IF Y<1
SET SDOUT=1
GOTO EXIT
+1 SET SD("BDT")=Y
EDT SET %DT("A")=" Ending date: "
WRITE !
DO ^%DT
IF Y<1
SET SDOUT=1
GOTO EXIT
+1 IF Y<SD("BDT")
WRITE !!,$CHAR(7),"End date cannot be before begin date!",!
GOTO EDT
+2 SET SD("EDT")=Y_.999999
+3 IF (SD("BDT")<SD("I10DTI"))
IF (SD("EDT")'<SD("I10DTI"))
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"Beginning and Ending dates must both be prior to "_SD("I10DTE")_" (ICD-9) or both be on or after "_SD("I10DTE")_" (ICD-10)."
End DoDot:1
GOTO BDT
+5 DO SUBT^SCRPW50("**** Report Format Selection ****")
+6 KILL DIR
SET DIR(0)="S^D:DIAGNOSIS FREQUENCY;P:PROCEDURE FREQUENCY;B:BOTH DIAGNOSIS AND PROCEDURE"
SET DIR("A")="Specify the type of report to print"
SET DIR("?")="This determines the type of lists returned by the report."
+7 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
GOTO EXIT
+8 SET SD("TYPE")=Y
+9 KILL DIR
SET DIR(0)="N^1:99999:0"
SET DIR("A")="Limit list to most frequent"
SET DIR("B")=50
SET DIR("?")="Enter the quantity of the most frequent items to list."
+10 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
GOTO EXIT
+11 SET SD("FREQ")=Y
+12 WRITE !
NEW ZTSAVE
SET ZTSAVE("SDDIV")=""
SET ZTSAVE("SDDIV(")=""
SET ZTSAVE("SD(")=""
DO EN^XUTMDEVQ("START^SCRPW40","Outpatient Diagnosis/Procedure Frequency Report",.ZTSAVE)
SET SDOUT=1
GOTO EXIT
+13 ;
START ;Print report
+1 SET (SDOUT,SDSTOP)=0
KILL ^TMP("SCRPW",$JOB)
SET SDI=$ORDER(SDDIV(""))
SET SDI=$ORDER(SDDIV(SDI))
if $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDI=1
SET SDDIV("MULT")=SDI
+2 SET SDT=SD("BDT")
FOR
SET SDT=$ORDER(^SCE("B",SDT))
if 'SDT!(SDT>SD("EDT"))!SDOUT
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDT,SDOE))
if 'SDOE!SDOUT
QUIT
SET SDOE0=$$GETOE^SDOE(SDOE)
IF '$PIECE(SDOE0,U,6)
IF $PIECE(SDOE0,U,2)
IF $PIECE(SDOE0,U,4)
IF $$DIV()
DO EVAL
+3 if SDOUT
GOTO EXIT
SET SDIV=""
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
if SDIV=""
QUIT
DO ORD
+4 DO STOP
if SDOUT
GOTO EXIT
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=$PIECE(Y,":",1,2)
SET SDPAGE=1
SET SDLINE=""
SET $PIECE(SDLINE,"-",(IOM+1))=""
SET SDFF=0
+5 SET Y=SD("BDT")
XECUTE ^DD("DD")
SET SDPBDT=Y
SET Y=$PIECE(SD("EDT"),".")
XECUTE ^DD("DD")
SET SDPEDT=Y
SET SDT(1)="<*> OUTPATIENT "_$SELECT(SD("TYPE")="D":"DIAGNOSIS",SD("TYPE")="P":"PROCEDURE",1:"DIAGNOSIS/PROCEDURE")_" FREQUENCY REPORT <*>"
+6 SET SDT(2)="For the "_SD("FREQ")_" most frequent "_$SELECT(SD("TYPE")="D":"diagnoses",SD("TYPE")="P":"procedures",1:"diagnoses and procedures")
+7 SET SDIV=""
FOR
SET SDIV=$ORDER(SDDIV(SDIV))
if 'SDIV
QUIT
SET SDIV(SDDIV(SDIV))=SDIV
+8 IF 'SDDIV
IF $PIECE(SDDIV,U,2)'="ALL DIVISIONS"
SET SDIV($PIECE(SDDIV,U,2))=$$PRIM^VASITE()
+9 IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)
if $LENGTH(SDX)
SET SDIV(SDX)=SDI
+10 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
IF '$ORDER(^TMP("SCRPW",$JOB,0))
SET SDIV=0
DO DHDR(2,.SDT)
DO HDR
if SDOUT
QUIT
SET SDX="No activity found within selected report parameters!"
WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
GOTO EXIT
+11 SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""!SDOUT
QUIT
SET SDIV=SDIV(SDIVN)
DO DPRT(.SDIV)
+12 SET SDI=0
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
SET SDDIV("MULT")=$ORDER(^TMP("SCRPW",$JOB,SDI))
+13 if SDOUT
GOTO EXIT
IF SDDIV("MULT")
SET SDIV=0
DO DPRT(.SDIV)
+14 ;
EXIT IF $EXTRACT(IOST)="C"
IF '$GET(SDOUT)
NEW DIR
SET DIR(0)="E"
DO ^DIR
+1 KILL %,%DT,C,DIR,DIVN,DTOUT,DUOUT,SD,SDCT,SDDIV,SDDX,SDDX0,SDDXC,SDDXN,SDFF,SDI,SDII,SDIV,SDIVN,SDLINE,SDLIST,SDOE,SDOE0
+2 KILL SDX,SDORD,SDOUT,SDPAGE,SDPBDT,SDPEDT,SDPNOW,SDPR,SDPR0,SDPRC,SDPRN,SDPROC,SDPS,SDQT,SDSTOP,SDT,SDTOT,X,Y
DO END^SCRPW50
QUIT
+3 ;
DIV() ;Check division
+1 if 'SDDIV
QUIT 1
QUIT $DATA(SDDIV(+$PIECE(SDOE0,U,11)))
+2 ;
STOP ;Check for stop task request
+1 if $DATA(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
EVAL ;Evaluate encounter
+1 SET SDSTOP=SDSTOP+1
if SDSTOP#3000=0
DO STOP
if SDOUT
QUIT
+2 SET SDIV=+$PIECE(SDOE0,U,11)
if "DB"[SD("TYPE")
DO DX
if "PB"[SD("TYPE")
DO PROC
QUIT
+3 ;
DX ;Get diagnoses
+1 NEW SDLIST,SDI
DO GETDX^SDOE(SDOE,"SDLIST")
+2 SET SDI=0
FOR
SET SDI=$ORDER(SDLIST(SDI))
if 'SDI
QUIT
DO DX1(SDIV)
if SDDIV("MULT")
DO DX1(0)
+3 QUIT
+4 ;
DX1(SDIV) SET SDDX=+SDLIST(SDI)
SET SDPS=$SELECT($PIECE(SDLIST(SDI),U,12)="P":"PRI",1:"SEC")
+1 FOR SDPS=SDPS,"QTY"
SET ^TMP("SCRPW",$JOB,SDIV,"DX",1,SDDX,SDPS)=$GET(^TMP("SCRPW",$JOB,SDIV,"DX",1,SDDX,SDPS))+1
+2 QUIT
+3 ;
PROC ;Get procedures
+1 NEW SDLIST,SDI
DO GETCPT^SDOE(SDOE,"SDLIST")
+2 SET SDI=0
FOR
SET SDI=$ORDER(SDLIST(SDI))
if 'SDI
QUIT
DO PROC1(SDIV)
if SDDIV("MULT")
DO PROC1(0)
+3 QUIT
+4 ;
PROC1(SDIV) SET SDPROC=+SDLIST(SDI)
SET SDQT=$PIECE(SDLIST(SDI),U,16)
if 'SDQT
SET SDQT=1
+1 SET ^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDPROC,"ENC")=$GET(^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDPROC,"ENC"))+1
+2 SET ^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDPROC,"QTY")=$GET(^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDPROC,"QTY"))+SDQT
+3 ;
+4 ;set encounter and modifier quantity
+5 NEW SDMOD,SDMODN
+6 SET SDMODN=0
+7 FOR
SET SDMODN=$ORDER(SDLIST(SDI,1,SDMODN))
if SDMODN=""
QUIT
Begin DoDot:1
+8 SET SDMOD=$GET(SDLIST(SDI,1,SDMODN,0))
+9 if SDMOD=""
QUIT
+10 SET ^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDPROC,SDMOD,"ENC")=+1
+11 SET ^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDPROC,SDMOD,"QTY")=+SDQT
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
ORD ;Determine list order
+1 SET SDI=""
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDI))
if SDI=""
QUIT
SET SDII=0
FOR
SET SDII=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDI,1,SDII))
if 'SDII
QUIT
SET ^TMP("SCRPW",$JOB,SDIV,SDI,2,$$ORDV(),SDII)=""
+2 QUIT
+3 ;
ORDV() QUIT ^TMP("SCRPW",$JOB,SDIV,SDI,1,SDII,"QTY")
+1 ;
DPRT(SDIV) ;Print report for a division
+1 ;Required input: SDIV=division ifn (or '0' for summary)
+2 SET C=(IOM-80\2)
DO DHDR(3,.SDT)
IF '$DATA(^TMP("SCRPW",$JOB,SDIV))
SET SDPAGE=1
DO HDR
if SDOUT
QUIT
SET SDX="No activity found for this date range!"
WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
QUIT
+3 IF $DATA(^TMP("SCRPW",$JOB,SDIV,"DX"))
DO DXPRT
if SDOUT
QUIT
+4 IF $DATA(^TMP("SCRPW",$JOB,SDIV,"PROC"))
DO PRPRT
+5 QUIT
+6 ;
DXPRT ;Print diagnosis list
+1 NEW SDTOT
SET SDPAGE=1
DO HDR
if SDOUT
QUIT
DO DXHD
SET (SDCT,SDORD)=""
FOR
SET SDORD=$ORDER(^TMP("SCRPW",$JOB,SDIV,"DX",2,SDORD),-1)
if SDORD=""!SDOUT!(SDCT>(SD("FREQ")-1))
QUIT
DO DXP1
+2 if SDOUT
QUIT
if $Y>(IOSL-4)
DO HDR
DO DXHD
if SDOUT
QUIT
+3 WRITE !?(C),$EXTRACT(SDLINE,1,7),?(C+9),$EXTRACT(SDLINE,1,35),?(C+46),$EXTRACT(SDLINE,1,10),?(C+58),$EXTRACT(SDLINE,1,10),?(C+70),$EXTRACT(SDLINE,1,10)
+4 WRITE !?(C),"TOTAL:",?(C+46),$JUSTIFY(SDTOT("PRI"),9,0),?(C+58),$JUSTIFY(SDTOT("SEC"),9,0),?(C+70),$JUSTIFY(SDTOT("QTY"),9,0)
+5 QUIT
+6 ;
DXP1 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDIV,"DX",2,SDORD,SDI))
if 'SDI!SDOUT!(SDCT>(SD("FREQ")-1))
QUIT
SET SDDX0=$$ICDDX^SCRPWICD(SDI)
IF $LENGTH(SDDX0)
SET SDDXC=$PIECE(SDDX0,U,2)
SET SDDXN=$PIECE(SDDX0,U,4)
DO DXP2
+1 QUIT
+2 ;
DXP2 NEW DIWL,DIWF,SDL2
SET DIWL=1
SET DIWF="C35|"
+1 FOR SDII="PRI","SEC","QTY"
SET SDDX(SDII)=+$GET(^TMP("SCRPW",$JOB,SDIV,"DX",1,SDI,SDII))
+2 if $Y>(IOSL-4)
DO HDR
DO DXHD
if SDOUT
QUIT
SET SDCT=SDCT+1
+3 KILL ^UTILITY($JOB,"W")
SET X=SDDXN
DO ^DIWP
+4 FOR SDL2=1:1:^UTILITY($JOB,"W",DIWL)
Begin DoDot:1
+5 IF SDL2=1
WRITE !?(C),SDDXC,?(C+9),$EXTRACT(^UTILITY($JOB,"W",DIWL,SDL2,0),1,35)
IF 1
+6 IF '$TEST
WRITE !,?(C+9),$EXTRACT(^UTILITY($JOB,"W",DIWL,SDL2,0),1,35)
End DoDot:1
+7 WRITE ?(C+46),$JUSTIFY(SDDX("PRI"),9,0),?(C+58),$JUSTIFY(SDDX("SEC"),9,0),?(C+70),$JUSTIFY(SDDX("QTY"),9,0)
+8 FOR SDII="PRI","SEC","QTY"
SET SDTOT(SDII)=$GET(SDTOT(SDII))+SDDX(SDII)
+9 QUIT
+10 ;
PRPRT NEW SDTOT
SET C=(IOM-62\2)
SET SDPAGE=1
DO HDR
if SDOUT
QUIT
DO PRHD
SET (SDCT,SDORD)=""
FOR
SET SDORD=$ORDER(^TMP("SCRPW",$JOB,SDIV,"PROC",2,SDORD),-1)
if SDORD=""!SDOUT!(SDCT>(SD("FREQ")-1))
QUIT
DO PRP1
+1 if SDOUT
QUIT
if $Y>(IOSL-4)
DO HDR
DO PRHD
if SDOUT
QUIT
+2 WRITE !?(C),$EXTRACT(SDLINE,1,6),?(C+8),$EXTRACT(SDLINE,1,28),?(C+38),$EXTRACT(SDLINE,1,10),?(C+50),$EXTRACT(SDLINE,1,10),!?(C),"PROCEDURE TOTAL:",?(C+38),$JUSTIFY(SDTOT("ENC"),9,0),?(C+50),$JUSTIFY(SDTOT("QTY"),9,0)
+3 QUIT
+4 ;
PRP1 ;S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) S SDPR0=$G(^ICPT(SDI,0)) I $L(SDPR0) S SDPRC=$P(SDPR0,U),SDPRN=$P(SDPR0,U,2) D PRP2
+1 NEW CPTINFO
+2 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDIV,"PROC",2,SDORD,SDI))
if 'SDI!SDOUT!(SDCT>(SD("FREQ")-1))
QUIT
Begin DoDot:1
+3 SET CPTINFO=$$CPT^ICPTCOD(SDI,,1)
+4 if CPTINFO'>0
QUIT
+5 SET SDPRC=$PIECE(CPTINFO,U,2)
+6 SET SDPRN=$PIECE(CPTINFO,U,3)
+7 DO PRP2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
PRP2 FOR SDII="ENC","QTY"
SET SDPR(SDII)=+$GET(^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDI,SDII))
+1 if $Y>(IOSL-4)
DO HDR
DO PRHD
if SDOUT
QUIT
SET SDCT=SDCT+1
+2 ; skip a line in the report if printing next cpt code on same page
+3 IF LINEFLAG
WRITE !
+4 WRITE !?(C),SDPRC,?(C+8),SDPRN,?(C+38),$JUSTIFY(SDPR("ENC"),9,0),?(C+50),$JUSTIFY(SDPR("QTY"),9,0)
+5 SET LINEFLAG=1
+6 FOR SDII="ENC","QTY"
SET SDTOT(SDII)=$GET(SDTOT(SDII))+SDPR(SDII)
+7 ;
+8 ;rank and print the modifiers
+9 DO START^SCRPW401($NAME(^TMP("SCRPW",$JOB,SDIV,"PROC",1,SDI)))
+10 QUIT
+11 ;
PRHD ;Print procedure subheader
+1 SET LINEFLAG=0
if SDOUT
QUIT
WRITE !!?(C),"CODE",!?(C),"NUMBER",?(C+8),"PROCEDURE/MODIFIER",?(C+38),"ENCOUNTERS",?(C+52),"QUANTITY",!?(C),$EXTRACT(SDLINE,1,6),?(C+8),$EXTRACT(SDLINE,1,28),?(C+38),$EXTRACT(SDLINE,1,10),?(C+50),$EXTRACT(SDLINE,1,10)
+2 QUIT
+3 ;
DXHD ;Print diagnosis subheader
+1 if SDOUT
QUIT
WRITE !!?(C),"CODE",?(C+49),"PRIMARY",?(C+59),"SECONDARY",?(C+75),"TOTAL",!?(C),"NUMBER",?(C+9),"DIAGNOSIS",?(C+47),"DIAGNOSIS",?(C+59),"DIAGNOSIS",?(C+71),"FREQUENCY"
+2 WRITE !?(C),$EXTRACT(SDLINE,1,7),?(C+9),$EXTRACT(SDLINE,1,35),?(C+46),$EXTRACT(SDLINE,1,10),?(C+58),$EXTRACT(SDLINE,1,10),?(C+70),$EXTRACT(SDLINE,1,10)
QUIT
+3 ;
HDR ;Print report header
+1 IF $EXTRACT(IOST)="C"
IF SDFF
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
SET SDOUT=Y'=1
if SDOUT
QUIT
+2 DO STOP
if SDOUT
QUIT
+3 IF SDFF!($EXTRACT(IOST)="C")
WRITE $$XY^SCRPW50(IOF,1,0)
+4 IF $X
WRITE $$XY^SCRPW50("",0,0)
+5 NEW SDI
WRITE SDLINE
SET SDI=0
FOR
SET SDI=$ORDER(SDT(SDI))
if 'SDI
QUIT
WRITE !?(IOM-$LENGTH(SDT(SDI))\2),SDT(SDI)
+6 WRITE !,SDLINE,!,"For date range: ",SDPBDT," to ",SDPEDT,!,"Date printed: ",SDPNOW,?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
SET SDPAGE=SDPAGE+1
SET SDFF=1
QUIT
+7 ;
DHDR(SDI,SDT) ;Set up division subheaders
+1 ;Required input: SDI=array number to start with
+2 ;Required input: SDT=array to store subheaders in (pass by reference)
+3 SET SDT(SDI)=$SELECT('SDIV:"Summary for "_$PIECE(SDDIV,U,2),SDDIV!($PIECE(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN,1:"For facility: "_SDIVN)
+4 IF 'SDIV
IF $PIECE(SDDIV,U,2)="SELECTED DIVISIONS"
NEW SDIVN
SET SDIVN=""
Begin DoDot:1
+5 FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""
QUIT
SET SDI=SDI+1
SET SDT(SDI)="Division: "_SDIVN
+6 QUIT
End DoDot:1
QUIT
+7 IF 'SDIV
IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
Begin DoDot:1
+8 NEW SDIV
SET SDIV=0
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
if 'SDIV
QUIT
SET SDI=SDI+1
SET SDT(SDI)="Division: "_$PIECE($GET(^DG(40.8,SDIV,0)),U)
+9 QUIT
End DoDot:1
+10 QUIT
