SCRPW57 ;RENO/KEITH - Most Frequent 50 ICD-9-CM Codes (OP7) or (IP7) ; 5/6/03 1:18pm
;;5.3;Scheduling;**144,295,466,1015**;AUG 13, 1993;Build 21
S SDSTA=$G(SDSTA,2)
D RQUE^SCRPW50("START^SCRPW57","Most Frequent 50 ICD-9-CM Codes "_$S(SDSTA=2:"(OP7)",1:"(IP7)"),1) Q
;
START ;Print report
K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDT=SD("FYD")
F S SDT=$O(^SCE("B",SDT)) Q:'SDT!SDOUT!(SDT>SD("EDT")) S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE),SDIV=$P(SDOE0,U,11) I $$VALID() D SET(SDIV) D:SDMD SET(0)
G:SDOUT EXIT S (SDVCT,SDIV)=""
F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D STOP,DLIST Q:SDOUT D
.S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,0,"LIST",DFN)) Q:'DFN D
..S SDDX=0 F S SDDX=$O(^TMP("SCRPW",$J,SDIV,0,"LIST",DFN,SDDX)) Q:'SDDX S SDPT="" F S SDPT=$O(^TMP("SCRPW",$J,SDIV,0,"LIST",DFN,SDDX,SDPT)) Q:SDPT="" D
...S $P(^TMP("SCRPW",$J,SDIV,0,SDDX,SDPT),U,2)=$P($G(^TMP("SCRPW",$J,SDIV,0,SDDX,SDPT)),U,2)+1
...S:$D(^TMP("SCRPW",$J,SDIV,0,"LIST",DFN,SDDX,SDPT,"P")) $P(^TMP("SCRPW",$J,SDIV,0,SDDX,SDPT),U)=$P($G(^TMP("SCRPW",$J,SDIV,0,SDDX,SDPT)),U)+1
...Q
..Q
.S SDDX=0 F S SDDX=$O(^TMP("SCRPW",$J,SDIV,0,SDDX)) Q:'SDDX S SDI=^TMP("SCRPW",$J,SDIV,0,SDDX),^TMP("SCRPW",$J,SDIV,1,SDI,SDDX)=""
.Q
G:SDOUT EXIT S SDLINE="",$P(SDLINE,"-",(IOM+1))="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDTIT(1)="<*> MOST FREQUENT 50 ICD-9-CM CODES "_$S(SDSTA=2:"(OP7)",1:"(IP7)")_" <*>",SDPG=0 D:$E(IOST)="C" DISP0^SCRPW23
I '$D(^TMP("SCRPW",$J)) S SDPAGE=1,SDX="No activity found within report parameters." D HDR G:SDOUT EXIT W !!?(IOM-$L(SDX)\2),SDX G EXIT
G:SDOUT EXIT S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D DPRT(SDIV(SDIVN))
G:SDOUT EXIT D:SDVCT>1 DPRT(0)
EXIT I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
K ^TMP("SCRPW",$J),%,%H,%I,DIR,DFN,SD,SDDX,SDDXP,SDDIV,SDFL,SDI,SDII,SDIII,SDIV,SDIVN,SDLINE,SDMD,SDOE,SDOE0,SDOUT,SDPAGE,SDPG,SDPNOW,SDDIAG,SDPRTY,SDPT,SDPTN,SDPTV,SDSTOP,SDT,SDTIT,SDV,SDVCT,SDX,X,Y,SDSTA Q
;
DPRT(SDV) ;Print division
;Required input: SDV=division ifn or '0' for combined divisions
I SDV S SDTIT(2)="For "_$S(SDDIV["DIVISIONS":"division",1:"facility")_": "_SDIVN
I 'SDV S SDTIT(2)="Report for: "_$P(SDDIV,U,2) D
.S SDI=2,SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" S SDI=SDI+1,SDTIT(SDI)=$J("Division: ",$L(SDIVN))_SDIVN
.Q
S SDPAGE=1 D HDR Q:SDOUT S (SDI,SDII)="" F S SDI=$O(^TMP("SCRPW",$J,SDV,1,SDI),-1) Q:SDI=""!SDOUT!(SDII>49) S SDDX="" F S SDDX=$O(^TMP("SCRPW",$J,SDV,1,SDI,SDDX)) Q:SDDX=""!SDOUT!(SDII>49) D PLINE
Q
;
PLINE ;Print output line
D:$Y>(IOSL-8) HDR Q:SDOUT D HD1
;S SDDIAG=$G(^ICD9(SDDX,0)),SDDIAG=$P(SDDIAG,U)_" "_$P(SDDIAG,U,3),SDII=SDII+1
S SDDIAG=$$ICDDX^ICDCODE(SDDX,,,1),SDDIAG=$P(SDDIAG,U,2)_" "_$P(SDDIAG,U,4),SDII=SDII+1
W !,$J(SDII,3),?6,$E(SDDIAG,1,38) D W !
.S (SDFL,SDPT)="" F S SDPT=$O(^TMP("SCRPW",$J,SDV,0,SDDX,SDPT)) Q:SDPT=""!SDOUT D
..I $Y>(IOSL-3) D HDR,HD1 Q:SDOUT S SDFL=1
..S SDPTV=^TMP("SCRPW",$J,SDV,0,SDDX,SDPT)
..S SDPTN=$$CODE2TXT^XUA4A72(SDPT),SDPTN=$P(SDPT,"V",2)_" "_$P(SDPTN,U,2)
..W:SDFL ! W ?46,$E(SDPTN,1,38) D S SDFL=SDFL+1
...F SDIII=1:1:4 W ?(86+(12*(SDIII-1))),$J($P(SDPTV,U,SDIII),10,0)
..Q
.Q
Q
;
HDR ;Print header
I $E(IOST)="C",SDPG N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
D STOP Q:SDOUT W:SDPG!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0)
N SDI S SDI=0 W SDLINE F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(IOM-$L(SDTIT(SDI))\2),SDTIT(SDI)
W !,SDLINE,!,"For Fiscal Year activity through ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1,SDPG=1 Q
;
HD1 ;Print subheader
Q:SDOUT W !?87,"Prim. Dx.",?103,"Total",?111,"Prim. Dx.",?127,"Total",!,"Rank IDC-9-DM Diagnosis code",?48,"Provider Type",?89,"Uniques",?101,"Uniques",?110,"Encounters",?122,"Encounters"
N SDI W !,"----",?6,$E(SDLINE,1,38),?46,$E(SDLINE,1,38) F SDI=0:1:3 W ?(86+(12*SDI)),$E(SDLINE,1,10)
Q
;
DLIST ;Create alphabetic list of divisions found
Q:'SDIV S SDX=$P($G(^DG(40.8,SDIV,0)),U) S:'$L(SDX) SDX="*** UNKNOWN ***" S SDIV(SDX)=SDIV,SDVCT=SDVCT+1 Q
;
VALID() ;Check encounter record
I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0
I SDIV,$$DIV(),$P(SDOE0,U,2),'$P(SDOE0,U,6),$P(SDOE0,U,7),$P(SDOE0,U,12)=SDSTA Q 1
Q 0
;
DIV() ;Check division
Q:'SDDIV 1 Q $D(SDDIV(SDIV))
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
SET(SDIV) ;Set division lists
;Required input: SDIV=division ifn or '0' for summary
S SDSTOP=SDSTOP+1 I SDSTOP#2000=0 D STOP^SCRPW40 Q:SDOUT
N SDDIAG,SDPRTY,SDI,SDII,SDIII,SDX S DFN=$P(SDOE0,U,2)
D GETDX^SDOE(SDOE,"SDDIAG"),PROV^SCRPW50(SDOE,.SDPRTY)
S SDI=0 F S SDI=$O(SDDIAG(SDI)) Q:'SDI S SDDX=$P(SDDIAG(SDI),U),SDDXP=$S($P(SDDIAG(SDI),U,12)="P":"P",1:"S") I SDDX D
.S ^TMP("SCRPW",$J,SDIV,0,SDDX)=$G(^TMP("SCRPW",$J,SDIV,0,SDDX))+1
.S SDII=0 F S SDII=$O(SDPRTY(SDII)) Q:'SDII S SDX=SDPRTY(SDII) I $L(SDX) D
..S $P(^TMP("SCRPW",$J,SDIV,0,SDDX,SDX),U,4)=$P($G(^TMP("SCRPW",$J,SDIV,0,SDDX,SDX)),U,4)+1 D
...S:SDDXP="P" $P(^TMP("SCRPW",$J,SDIV,0,SDDX,SDX),U,3)=$P($G(^TMP("SCRPW",$J,SDIV,0,SDDX,SDX)),U,3)+1
...S ^TMP("SCRPW",$J,SDIV,0,"LIST",DFN,SDDX,SDX,SDDXP)=""
...Q
..Q
.Q
Q
SCRPW57 ;RENO/KEITH - Most Frequent 50 ICD-9-CM Codes (OP7) or (IP7) ; 5/6/03 1:18pm
+1 ;;5.3;Scheduling;**144,295,466,1015**;AUG 13, 1993;Build 21
+2 SET SDSTA=$GET(SDSTA,2)
+3 DO RQUE^SCRPW50("START^SCRPW57","Most Frequent 50 ICD-9-CM Codes "_$SELECT(SDSTA=2:"(OP7)",1:"(IP7)"),1)
QUIT
+4 ;
START ;Print report
+1 KILL ^TMP("SCRPW",$JOB)
SET (SDSTOP,SDOUT)=0
SET SDT=SD("FYD")
+2 FOR
SET SDT=$ORDER(^SCE("B",SDT))
IF 'SDT!SDOUT!(SDT>SD("EDT"))
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDT,SDOE))
IF 'SDOE!SDOUT
QUIT
SET SDOE0=$$GETOE^SDOE(SDOE)
SET SDIV=$PIECE(SDOE0,U,11)
IF $$VALID()
DO SET(SDIV)
IF SDMD
DO SET(0)
+3 IF SDOUT
GOTO EXIT
SET (SDVCT,SDIV)=""
+4 FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
IF SDIV=""
QUIT
DO STOP
DO DLIST
IF SDOUT
QUIT
Begin DoDot:1
+5 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,0,"LIST",DFN))
IF 'DFN
QUIT
Begin DoDot:2
+6 SET SDDX=0
FOR
SET SDDX=$ORDER(^TMP("SCRPW",$JOB,SDIV,0,"LIST",DFN,SDDX))
IF 'SDDX
QUIT
SET SDPT=""
FOR
SET SDPT=$ORDER(^TMP("SCRPW",$JOB,SDIV,0,"LIST",DFN,SDDX,SDPT))
IF SDPT=""
QUIT
Begin DoDot:3
+7 SET $PIECE(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDPT),U,2)=$PIECE($GET(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDPT)),U,2)+1
+8 IF $DATA(^TMP("SCRPW",$JOB,SDIV,0,"LIST",DFN,SDDX,SDPT,"P"))
SET $PIECE(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDPT),U)=$PIECE($GET(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDPT)),U)+1
+9 QUIT
End DoDot:3
+10 QUIT
End DoDot:2
+11 SET SDDX=0
FOR
SET SDDX=$ORDER(^TMP("SCRPW",$JOB,SDIV,0,SDDX))
IF 'SDDX
QUIT
SET SDI=^TMP("SCRPW",$JOB,SDIV,0,SDDX)
SET ^TMP("SCRPW",$JOB,SDIV,1,SDI,SDDX)=""
+12 QUIT
End DoDot:1
+13 IF SDOUT
GOTO EXIT
SET SDLINE=""
SET $PIECE(SDLINE,"-",(IOM+1))=""
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=$PIECE(Y,":",1,2)
SET SDTIT(1)="<*> MOST FREQUENT 50 ICD-9-CM CODES "_$SELECT(SDSTA=2:"(OP7)",1:"(IP7)")_" <*>"
SET SDPG=0
IF $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
+14 IF '$DATA(^TMP("SCRPW",$JOB))
SET SDPAGE=1
SET SDX="No activity found within report parameters."
DO HDR
IF SDOUT
GOTO EXIT
WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
GOTO EXIT
+15 IF SDOUT
GOTO EXIT
SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
IF SDIVN=""!SDOUT
QUIT
DO DPRT(SDIV(SDIVN))
+16 IF SDOUT
GOTO EXIT
IF SDVCT>1
DO DPRT(0)
EXIT IF $EXTRACT(IOST)="C"
IF 'SDOUT
NEW DIR
SET DIR(0)="E"
DO ^DIR
+1 KILL ^TMP("SCRPW",$JOB),%,%H,%I,DIR,DFN,SD,SDDX,SDDXP,SDDIV,SDFL,SDI,SDII,SDIII,SDIV,SDIVN,SDLINE,SDMD,SDOE,SDOE0,SDOUT,SDPAGE,SDPG,SDPNOW,SDDIAG,SDPRTY,SDPT,SDPTN,SDPTV,SDSTOP,SDT,SDTIT,SDV,SDVCT,SDX,X,Y,SDSTA
QUIT
+2 ;
DPRT(SDV) ;Print division
+1 ;Required input: SDV=division ifn or '0' for combined divisions
+2 IF SDV
SET SDTIT(2)="For "_$SELECT(SDDIV["DIVISIONS":"division",1:"facility")_": "_SDIVN
+3 IF 'SDV
SET SDTIT(2)="Report for: "_$PIECE(SDDIV,U,2)
Begin DoDot:1
+4 SET SDI=2
SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
IF SDIVN=""
QUIT
SET SDI=SDI+1
SET SDTIT(SDI)=$JUSTIFY("Division: ",$LENGTH(SDIVN))_SDIVN
+5 QUIT
End DoDot:1
+6 SET SDPAGE=1
DO HDR
IF SDOUT
QUIT
SET (SDI,SDII)=""
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDV,1,SDI),-1)
IF SDI=""!SDOUT!(SDII>49)
QUIT
SET SDDX=""
FOR
SET SDDX=$ORDER(^TMP("SCRPW",$JOB,SDV,1,SDI,SDDX))
IF SDDX=""!SDOUT!(SDII>49)
QUIT
DO PLINE
+7 QUIT
+8 ;
PLINE ;Print output line
+1 IF $Y>(IOSL-8)
DO HDR
IF SDOUT
QUIT
DO HD1
+2 ;S SDDIAG=$G(^ICD9(SDDX,0)),SDDIAG=$P(SDDIAG,U)_" "_$P(SDDIAG,U,3),SDII=SDII+1
+3 SET SDDIAG=$$ICDDX^ICDCODE(SDDX,,,1)
SET SDDIAG=$PIECE(SDDIAG,U,2)_" "_$PIECE(SDDIAG,U,4)
SET SDII=SDII+1
+4 WRITE !,$JUSTIFY(SDII,3),?6,$EXTRACT(SDDIAG,1,38)
Begin DoDot:1
+5 SET (SDFL,SDPT)=""
FOR
SET SDPT=$ORDER(^TMP("SCRPW",$JOB,SDV,0,SDDX,SDPT))
IF SDPT=""!SDOUT
QUIT
Begin DoDot:2
+6 IF $Y>(IOSL-3)
DO HDR
DO HD1
IF SDOUT
QUIT
SET SDFL=1
+7 SET SDPTV=^TMP("SCRPW",$JOB,SDV,0,SDDX,SDPT)
+8 SET SDPTN=$$CODE2TXT^XUA4A72(SDPT)
SET SDPTN=$PIECE(SDPT,"V",2)_" "_$PIECE(SDPTN,U,2)
+9 IF SDFL
WRITE !
WRITE ?46,$EXTRACT(SDPTN,1,38)
Begin DoDot:3
+10 FOR SDIII=1:1:4
WRITE ?(86+(12*(SDIII-1))),$JUSTIFY($PIECE(SDPTV,U,SDIII),10,0)
End DoDot:3
SET SDFL=SDFL+1
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
WRITE !
+13 QUIT
+14 ;
HDR ;Print header
+1 IF $EXTRACT(IOST)="C"
IF SDPG
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
SET SDOUT=Y'=1
IF SDOUT
QUIT
+2 DO STOP
IF SDOUT
QUIT
IF SDPG!($EXTRACT(IOST)="C")
WRITE $$XY^SCRPW50(IOF,1,0)
IF $X
WRITE $$XY^SCRPW50("",0,0)
+3 NEW SDI
SET SDI=0
WRITE SDLINE
FOR
SET SDI=$ORDER(SDTIT(SDI))
IF 'SDI
QUIT
WRITE !?(IOM-$LENGTH(SDTIT(SDI))\2),SDTIT(SDI)
+4 WRITE !,SDLINE,!,"For Fiscal Year activity through ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
SET SDPAGE=SDPAGE+1
SET SDPG=1
QUIT
+5 ;
HD1 ;Print subheader
+1 IF SDOUT
QUIT
WRITE !?87,"Prim. Dx.",?103,"Total",?111,"Prim. Dx.",?127,"Total",!,"Rank IDC-9-DM Diagnosis code",?48,"Provider Type",?89,"Uniques",?101,"Uniques",?110,"Encounters",?122,"Encounters"
+2 NEW SDI
WRITE !,"----",?6,$EXTRACT(SDLINE,1,38),?46,$EXTRACT(SDLINE,1,38)
FOR SDI=0:1:3
WRITE ?(86+(12*SDI)),$EXTRACT(SDLINE,1,10)
+3 QUIT
+4 ;
DLIST ;Create alphabetic list of divisions found
+1 IF 'SDIV
QUIT
SET SDX=$PIECE($GET(^DG(40.8,SDIV,0)),U)
IF '$LENGTH(SDX)
SET SDX="*** UNKNOWN ***"
SET SDIV(SDX)=SDIV
SET SDVCT=SDVCT+1
QUIT
+2 ;
VALID() ;Check encounter record
+1 IF $PIECE(SDOE0,U,4)
IF $PIECE($GET(^SC($PIECE(SDOE0,U,4),0)),U,17)="Y"
QUIT 0
+2 IF SDIV
IF $$DIV()
IF $PIECE(SDOE0,U,2)
IF '$PIECE(SDOE0,U,6)
IF $PIECE(SDOE0,U,7)
IF $PIECE(SDOE0,U,12)=SDSTA
QUIT 1
+3 QUIT 0
+4 ;
DIV() ;Check division
+1 IF 'SDDIV
QUIT 1
QUIT $DATA(SDDIV(SDIV))
+2 ;
STOP ;Check for stop task request
+1 IF $DATA(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
SET(SDIV) ;Set division lists
+1 ;Required input: SDIV=division ifn or '0' for summary
+2 SET SDSTOP=SDSTOP+1
IF SDSTOP#2000=0
DO STOP^SCRPW40
IF SDOUT
QUIT
+3 NEW SDDIAG,SDPRTY,SDI,SDII,SDIII,SDX
SET DFN=$PIECE(SDOE0,U,2)
+4 DO GETDX^SDOE(SDOE,"SDDIAG")
DO PROV^SCRPW50(SDOE,.SDPRTY)
+5 SET SDI=0
FOR
SET SDI=$ORDER(SDDIAG(SDI))
IF 'SDI
QUIT
SET SDDX=$PIECE(SDDIAG(SDI),U)
SET SDDXP=$SELECT($PIECE(SDDIAG(SDI),U,12)="P":"P",1:"S")
IF SDDX
Begin DoDot:1
+6 SET ^TMP("SCRPW",$JOB,SDIV,0,SDDX)=$GET(^TMP("SCRPW",$JOB,SDIV,0,SDDX))+1
+7 SET SDII=0
FOR
SET SDII=$ORDER(SDPRTY(SDII))
IF 'SDII
QUIT
SET SDX=SDPRTY(SDII)
IF $LENGTH(SDX)
Begin DoDot:2
+8 SET $PIECE(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDX),U,4)=$PIECE($GET(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDX)),U,4)+1
Begin DoDot:3
+9 IF SDDXP="P"
SET $PIECE(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDX),U,3)=$PIECE($GET(^TMP("SCRPW",$JOB,SDIV,0,SDDX,SDX)),U,3)+1
+10 SET ^TMP("SCRPW",$JOB,SDIV,0,"LIST",DFN,SDDX,SDX,SDDXP)=""
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
