IBDFOSG3.m

IBDFOSG3 ;ALB/MAF/AAS - NUMBER OF ENCOUNTERS WITH CPT'S AND DX'S REPORT ;3/18/96

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 ;

% I '$D(DT) D DT^DICRW

 D END

 W !!,"Number of Encounters with CPT, Diagnosis"

 S VAUTD=1 I $D(^DG(43,1,"GL")) D DIVISION^VAUTOMA G:Y=-1 END

 S IBDFDAT=$$HTE^XLFDT($H)

 ;

DATE ; -- select date

 S (IBBDT,IBDFBEG)=2940401,(IBEDT,IBDFEND)=2960331

 ;

DEV ; -- select device, run option

 S %ZIS="QM" D ^%ZIS G:POP END

 I $D(IO("Q")) S ZTRTN="DQ^IBDFOSG3",ZTSAVE("IB*")="",ZTSAVE("VA*")="",ZTDESC="IBD - Number of Encounters with Stop Codes, CPT, Diagnosis" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END

 ;

 U IO

 S X=132 X ^%ZOSF("RM")

DQ D PRINT G END

 Q

 ;

END ; -- Clean up

 K ^TMP("MNTH",$J),^TMP("DTOT",$J),^TMP("GTOT",$J) W !

 I $D(ZTQUEUED) S ZTREQ="@" Q

 D ^%ZISC

 K IBBDT,IBCS,IBDDT,IBDDT1,IBDFMN,IBDFMN1,IBDFMNI,IBDFN,IBDIV,IBDIVNM,IBI,IBIFN,IBJ,IBMNTH,IBNODE,IBPARNT,IBPIECE,IBPR,IBPROC,IBSTOP,POP,SDCNT,U

 K IBDFBEG,IBDFDAT,IBDFDIV,IBDFDVE,IBDFEND,IBEDT,IBFLG4,IBHDT,IBQUIT,IBTSBDT,IBTSEDT,SDDXY,X,Y,IBCLIN,IBPAG,VAUTD

 Q

 ;K X,Y,DFN,IBPAG,IBHDT,IBDT,IBBDT,IBEDT,IBQUIT,IBDFDVE

 ;K IBCNT,IBDFBEG,IBDFCLI,IBDFDA,IBDFDAT,IBDFDIV,IBDFEND,IBDFIFN,IBDFNODE,IBDFNUM,IBDFSA,IBDFT,IBDFTMP,IBDFTMP1,IBDFTMP2,IBDFTPRT

 ;K IBFLG1,IBFLG2,IBFLG3,IBFLG4,IBFLG5,IBFLG6,IBFLG7,IBFLG8,IBFLG9,IBMCNODE,IBMCSND,IBNAM,IBTSBDT,IBTSEDT

 ;K VAUTC,VAUTD

 Q

 ;

PRINT ; -- print report

 ;    Data sorted into ^tmp arrays

 ;                    

 ;    Monthly Totals  := ^tmp("mnth",$j,division,year/month)=

 ;    Division Totals := ^tmp("dtot",$j,division)       =

 ;    Grand Totals    := ^tmp("gtot",$j)                =

 ;

 S (IBPAG,IBDFDVE)=0,IBHDT=$$HTE^XLFDT($H,1),IBQUIT=0

 S IBTSBDT=IBBDT-.1,IBTSEDT=IBEDT+.9

 D QUIT

 D START^IBDFOSG4

 ;

PR ;

 I '$D(^TMP("MNTH",$J)) D HDR W !!,"No Data Meeting This Criteria for the Date Range Chosen",! Q

 N IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT

 S (IBDFDV,IBDFCL,IBDFPT)=0

 F IBDFDIV=0:0 S IBDFDV=$O(^TMP("MNTH",$J,IBDFDV)) Q:IBDFDV']""!(IBQUIT)  D HDR Q:IBQUIT  D

 .D DIVH

 .S IBDFMN=0

 .F IBDFMNI=0:0 S IBDFMN=$O(^TMP("MNTH",$J,IBDFDV,IBDFMN)) Q:IBDFMN=""  D ONEMN I $O(^TMP("MNTH",$J,IBDFDV,IBDFMN))="" S IBDFDVE=1 D ONEDV

 ;

 ;  -- Print Totals Page

 S IBDFDVE=0

 Q:IBQUIT

 D HDR

 S (IBDFDV,IBDFCL,IBDFPT)=0

 S IBFLG4=1 ;1 := on division totals page

 F IBDFDIV=0:0 S IBDFDV=$O(^TMP("DTOT",$J,IBDFDV)) Q:IBDFDV']""!(IBQUIT)  D ONEDV

 Q:IBQUIT

 D DASH

 D LINE("GRAND TOTAL",^TMP("GTOT",$J))

 Q

 ;

ONEMN ; -- Print one months data

 Q:IBQUIT

 N IBDFNM1

 Q:'$D(^TMP("MNTH",$J,IBDFDV,IBDFMN))!(^TMP("MNTH",$J,IBDFDV,IBDFMN)="0^0^0")

 S Y=IBDFMN D DD^%DT S IBDFMN1=Y

 D LINE(IBDFMN1,^TMP("MNTH",$J,IBDFDV,IBDFMN))

 Q

 ;

ONEDV ;  -- Print Division totals

 Q:IBQUIT

 I IOSL<($Y+5) D HDR Q:IBQUIT

 Q:^TMP("DTOT",$J,IBDFDV)="0^0^0"&('$D(IBFLG4))

 I IBDFDVE=1 D DASH S IBDFDVE=0

 D LINE($E(IBDFDV,1,25)_"  ("_$P($$SITE^VASITE(,$O(^DG(40.8,"B",IBDFDV,0))),"^",3)_")",^TMP("DTOT",$J,IBDFDV))

 Q

 ;

LINE(NAME,IBX) ;

 ; -- print detail line

 ;    input Name := text to be printed

 ;          ibx  ;= 3 piece global node containing data

 ;

 I IOSL<($Y+5) D HDR Q:IBQUIT

 W !,$E(NAME,1,35)

 W ?39,$J($P(IBX,"^",2),8)

 W ?57,$J($P(IBX,"^",3),8)

 Q

 ;

HDR ; -- Print header for report

 Q:IBQUIT

 I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q

 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF

 S IBPAG=IBPAG+1

 W !,"# Encounters / CPT's, Dx",?(IOM-33),"Page ",IBPAG,"  ",IBHDT

 W !,"For Period beginning on ",$$FMTE^XLFDT(IBBDT,2)," to ",$$FMTE^XLFDT(IBEDT,2)

 W !,?44,"CPT",?56,"Diagnosis"

 W !,$TR($J(" ",IOM)," ","-")

 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,IBQUIT=1 W !!,"....task stopped at user request" Q

 Q

 ;

 ;

QUIT K ^TMP("MNTH",$J),^TMP("DTOT",$J),^TMP("GTOT",$J) W !

 Q

 ;

 ;

DASH W !,"------------------",?39,"--------",?57,"--------"

 Q

 ;

DIVH ;  -- Write division header

 I IOSL<($Y+5) D HDR Q:IBQUIT

 Q:^TMP("DTOT",$J,IBDFDV)="0^0^0"

 W !!,?(IOM-$L(IBDFDV)+10/2),"DIVISION: ",IBDFDV_"  ("_$P($$SITE^VASITE(,$O(^DG(40.8,"B",IBDFDV,0))),"^",3)_")",!

 Q

IBDFOSG3  ;ALB/MAF/AAS - NUMBER OF ENCOUNTERS WITH CPT'S AND DX'S REPORT ;3/18/96

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

%          IF '$DATA(DT)

               DO DT^DICRW

 +1        DO END

 +2        WRITE !!,"Number of Encounters with CPT, Diagnosis"

 +3        SET VAUTD=1

           IF $DATA(^DG(43,1,"GL"))

               DO DIVISION^VAUTOMA

               IF Y=-1

                   GOTO END

 +4        SET IBDFDAT=$$HTE^XLFDT($HOROLOG)

 +5       ;

DATE      ; -- select date

 +1        SET (IBBDT,IBDFBEG)=2940401

           SET (IBEDT,IBDFEND)=2960331

 +2       ;

DEV       ; -- select device, run option

 +1        SET %ZIS="QM"

           DO ^%ZIS

           IF POP

               GOTO END

 +2        IF $DATA(IO("Q"))

               SET ZTRTN="DQ^IBDFOSG3"

               SET ZTSAVE("IB*")=""

               SET ZTSAVE("VA*")=""

               SET ZTDESC="IBD - Number of Encounters with Stop Codes, CPT, Diagnosis"

               DO ^%ZTLOAD

               KILL IO("Q"),ZTSK

               DO HOME^%ZIS

               GOTO END

 +3       ;

 +4        USE IO

 +5        SET X=132

           XECUTE ^%ZOSF("RM")

DQ         DO PRINT

           GOTO END

 +1        QUIT 

 +2       ;

END       ; -- Clean up

 +1        KILL ^TMP("MNTH",$JOB),^TMP("DTOT",$JOB),^TMP("GTOT",$JOB)

           WRITE !

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT 

 +3        DO ^%ZISC

 +4        KILL IBBDT,IBCS,IBDDT,IBDDT1,IBDFMN,IBDFMN1,IBDFMNI,IBDFN,IBDIV,IBDIVNM,IBI,IBIFN,IBJ,IBMNTH,IBNODE,IBPARNT,IBPIECE,IBPR,IBPROC,IBSTOP,POP,SDCNT,U

 +5        KILL IBDFBEG,IBDFDAT,IBDFDIV,IBDFDVE,IBDFEND,IBEDT,IBFLG4,IBHDT,IBQUIT,IBTSBDT,IBTSEDT,SDDXY,X,Y,IBCLIN,IBPAG,VAUTD

 +6        QUIT 

 +7       ;K X,Y,DFN,IBPAG,IBHDT,IBDT,IBBDT,IBEDT,IBQUIT,IBDFDVE

 +8       ;K IBCNT,IBDFBEG,IBDFCLI,IBDFDA,IBDFDAT,IBDFDIV,IBDFEND,IBDFIFN,IBDFNODE,IBDFNUM,IBDFSA,IBDFT,IBDFTMP,IBDFTMP1,IBDFTMP2,IBDFTPRT

 +9       ;K IBFLG1,IBFLG2,IBFLG3,IBFLG4,IBFLG5,IBFLG6,IBFLG7,IBFLG8,IBFLG9,IBMCNODE,IBMCSND,IBNAM,IBTSBDT,IBTSEDT

 +10      ;K VAUTC,VAUTD

 +11       QUIT 

 +12      ;

PRINT     ; -- print report

 +1       ;    Data sorted into ^tmp arrays

 +2       ;                    

 +3       ;    Monthly Totals  := ^tmp("mnth",$j,division,year/month)=

 +4       ;    Division Totals := ^tmp("dtot",$j,division)       =

 +5       ;    Grand Totals    := ^tmp("gtot",$j)                =

 +6       ;

 +7        SET (IBPAG,IBDFDVE)=0

           SET IBHDT=$$HTE^XLFDT($HOROLOG,1)

           SET IBQUIT=0

 +8        SET IBTSBDT=IBBDT-.1

           SET IBTSEDT=IBEDT+.9

 +9        DO QUIT

 +10       DO START^IBDFOSG4

 +11      ;

PR        ;

 +1        IF '$DATA(^TMP("MNTH",$JOB))

               DO HDR

               WRITE !!,"No Data Meeting This Criteria for the Date Range Chosen",!

               QUIT 

 +2        NEW IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT

 +3        SET (IBDFDV,IBDFCL,IBDFPT)=0

 +4        FOR IBDFDIV=0:0

               SET IBDFDV=$ORDER(^TMP("MNTH",$JOB,IBDFDV))

               IF IBDFDV']""!(IBQUIT)

                   QUIT 

               DO HDR

               IF IBQUIT

                   QUIT 

               Begin DoDot:1

 +5                DO DIVH

 +6                SET IBDFMN=0

 +7                FOR IBDFMNI=0:0

                       SET IBDFMN=$ORDER(^TMP("MNTH",$JOB,IBDFDV,IBDFMN))

                       IF IBDFMN=""

                           QUIT 

                       DO ONEMN

                       IF $ORDER(^TMP("MNTH",$JOB,IBDFDV,IBDFMN))=""

                           SET IBDFDVE=1

                           DO ONEDV

               End DoDot:1

 +8       ;

 +9       ;  -- Print Totals Page

 +10       SET IBDFDVE=0

 +11       IF IBQUIT

               QUIT 

 +12       DO HDR

 +13       SET (IBDFDV,IBDFCL,IBDFPT)=0

 +14      ;1 := on division totals page

           SET IBFLG4=1

 +15       FOR IBDFDIV=0:0

               SET IBDFDV=$ORDER(^TMP("DTOT",$JOB,IBDFDV))

               IF IBDFDV']""!(IBQUIT)

                   QUIT 

               DO ONEDV

 +16       IF IBQUIT

               QUIT 

 +17       DO DASH

 +18       DO LINE("GRAND TOTAL",^TMP("GTOT",$JOB))

 +19       QUIT 

 +20      ;

ONEMN     ; -- Print one months data

 +1        IF IBQUIT

               QUIT 

 +2        NEW IBDFNM1

 +3        IF '$DATA(^TMP("MNTH",$JOB,IBDFDV,IBDFMN))!(^TMP("MNTH",$JOB,IBDFDV,IBDFMN)="0^0^0")

               QUIT 

 +4        SET Y=IBDFMN

           DO DD^%DT

           SET IBDFMN1=Y

 +5        DO LINE(IBDFMN1,^TMP("MNTH",$JOB,IBDFDV,IBDFMN))

 +6        QUIT 

 +7       ;

ONEDV     ;  -- Print Division totals

 +1        IF IBQUIT

               QUIT 

 +2        IF IOSL<($Y+5)

               DO HDR

               IF IBQUIT

                   QUIT 

 +3        IF ^TMP("DTOT",$JOB,IBDFDV)="0^0^0"&('$DATA(IBFLG4))

               QUIT 

 +4        IF IBDFDVE=1

               DO DASH

               SET IBDFDVE=0

 +5        DO LINE($EXTRACT(IBDFDV,1,25)_"  ("_$PIECE($$SITE^VASITE(,$ORDER(^DG(40.8,"B",IBDFDV,0))),"^",3)_")",^TMP("DTOT",$JOB,IBDFDV))

 +6        QUIT 

 +7       ;

LINE(NAME,IBX) ;

 +1       ; -- print detail line

 +2       ;    input Name := text to be printed

 +3       ;          ibx  ;= 3 piece global node containing data

 +4       ;

 +5        IF IOSL<($Y+5)

               DO HDR

               IF IBQUIT

                   QUIT 

 +6        WRITE !,$EXTRACT(NAME,1,35)

 +7        WRITE ?39,$JUSTIFY($PIECE(IBX,"^",2),8)

 +8        WRITE ?57,$JUSTIFY($PIECE(IBX,"^",3),8)

 +9        QUIT 

 +10      ;

HDR       ; -- Print header for report

 +1        IF IBQUIT

               QUIT 

 +2        IF $EXTRACT(IOST,1,2)="C-"

               IF IBPAG

                   DO PAUSE^VALM1

                   IF $DATA(DIRUT)

                       SET IBQUIT=1

                       QUIT 

 +3        IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)

               WRITE @IOF

 +4        SET IBPAG=IBPAG+1

 +5        WRITE !,"# Encounters / CPT's, Dx",?(IOM-33),"Page ",IBPAG,"  ",IBHDT

 +6        WRITE !,"For Period beginning on ",$$FMTE^XLFDT(IBBDT,2)," to ",$$FMTE^XLFDT(IBEDT,2)

 +7        WRITE !,?44,"CPT",?56,"Diagnosis"

 +8        WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")

 +9        IF $DATA(ZTQUEUED)

               IF $$S^%ZTLOAD

                   SET ZTSTOP=1

                   SET IBQUIT=1

                   WRITE !!,"....task stopped at user request"

                   QUIT 

 +10       QUIT 

 +11      ;

 +12      ;

QUIT       KILL ^TMP("MNTH",$JOB),^TMP("DTOT",$JOB),^TMP("GTOT",$JOB)

           WRITE !

 +1        QUIT 

 +2       ;

 +3       ;

DASH       WRITE !,"------------------",?39,"--------",?57,"--------"

 +1        QUIT 

 +2       ;

DIVH      ;  -- Write division header

 +1        IF IOSL<($Y+5)

               DO HDR

               IF IBQUIT

                   QUIT 

 +2        IF ^TMP("DTOT",$JOB,IBDFDV)="0^0^0"

               QUIT 

 +3        WRITE !!,?(IOM-$LENGTH(IBDFDV)+10/2),"DIVISION: ",IBDFDV_"  ("_$PIECE($$SITE^VASITE(,$ORDER(^DG(40.8,"B",IBDFDV,0))),"^",3)_")",!

 +4        QUIT