- 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 Jan 18, 2025@03:44:48 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