Routine: ADGICAL1

ADGICAL1 ; IHS/ADC/PDW/ENM - INCOMPLETE CHARTS ALPHA LIST PRINT ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;***> initialize variables

 S DGIOM=IOM,X=132 X ^%ZOSF("RM")

 S DGPAGE=0,DGSTOP=""

 S DGDUZ=$P(^VA(200,DUZ,0),U,2),DGFAC=$P(^DIC(4,DUZ(2),0),U)

 S DGX=$E(DGBDT,4,5)_"/"_$E(DGBDT,6,7)_"/"_($E(DGBDT,1,3)+1700)

 S DGY=$E(DGEDT,4,5)_"/"_$E(DGEDT,6,7)_"/"_($E(DGEDT,1,3)+1700)

 S DGDTS="from "_DGX_" to "_DGY  ;printable date range

 S (DGLIN,DGLIN1)="",$P(DGLIN,"-",132)="",$P(DGLIN1,"=",132)=""

 D HEAD

 ;***> loop thru ^utility

 S DGNAM=0

A1 S DGNAM=$O(^TMP("DGZICAL",$J,DGNAM)) G END:DGNAM="" S DFN=0

A2 S DFN=$O(^TMP("DGZICAL",$J,DGNAM,DFN)) G A1:DFN="" S DGDFN2=0

A3 S DGDFN1=$O(^TMP("DGZICAL",$J,DGNAM,DFN,DGDFN1)) G A2:DGDFN1=""

 ;***> set variables

 S DGSTR=^TMP("DGZICAL",$J,DGNAM,DFN,DGDFN1)

 S DGDD=$P(DGSTR,U,2),DGAD=$P(DGSTR,U,3),DGWD=$P(DGSTR,U,4)

 S DGSV=$P(DGSTR,U,5),DGSMD=$P(DGSTR,U,7),DGSMR=$P(DGSTR,U,8)

 S DGOPD=$P(DGSTR,U,9),DGOPR=$P(DGSTR,U,10),DGCOM=$P(DGSTR,U,13)

 ;***> print line

 W !!,$$NAME,?18,$J($P(DGSTR,U),7)

 W:DGAD'="" ?27,$E(DGAD,4,5)_"/"_$E(DGAD,6,7)_"/"_$E(DGAD,2,3)

 W ?38 W:DGWD'="" $E($P($G(^DIC(42,DGWD,0)),U),1,3)

 W:DGSMD'="" ?44,$E(DGSMD,4,5)_"/"_$E(DGSMD,6,7)_"/"_$E(DGSMD,2,3)

 W:DGOPD'="" ?55,$E(DGOPD,4,5)_"/"_$E(DGOPD,6,7)_"/"_$E(DGOPD,2,3)

 W ?67,$S($P(DGSTR,U,14)="Y":"YES",$P(DGSTR,U,14)="N":"NO",1:"")

 W ?110,$P(DGSTR,U,13),?123,$$INS^ADGMREC(DFN)

 W ! W:DGDD'="" ?27,$E(DGDD,4,5)_"/"_$E(DGDD,6,7)_"/"_$E(DGDD,2,3)

 W ?38 W:DGSV'="" $E($P($G(^DIC(45.7,DGSV,0)),U,3),1,3)

 W:DGSMR'="" ?44,$E(DGSMR,4,5)_"/"_$E(DGSMR,6,7)_"/"_$E(DGSMR,2,3)

 W:DGOPR'="" ?55,$E(DGOPR,4,5)_"/"_$E(DGOPR,6,7)_"/"_$E(DGOPR,2,3)

 W ?67,$S($P(DGSTR,U,12)="Y":"YES",$P(DGSTR,U,12)="N":"NO",1:"")

 I ($Y+6)>IOSL D NEWPG G END:DGSTOP=U

 G A3:'$D(^ADGIC(DFN,"D",DGDFN1,"P",0))

 ;**> loop thru & find provi with chart deficiencies for this admission

 S DGDFN2=0

A4 S DGDFN2=$O(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2)) G A3:+DGDFN2'=DGDFN2

 S DGPRV=$P(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2,0),U)

 W:$X>75 ! W ?75

 W:DGPRV'="" $E($P($G(^VA(200,DGPRV,0)),U),1,15)  ;provider name

 ;***> find all chart deficiencies for provider

 S DGX=0 F  Q:+DGX'=DGX  Q:DGSTOP=U  D

 .S DGX=$O(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2,"C",DGX)) Q:+DGX'=DGX  ;

 .S DGY=$P(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2,"C",DGX,0),U)

 .I DGY'="",$D(^ADGCD(DGY,0)) W ?92,$E($P(^ADGCD(DGY,0),U),1,16),!

 .I ($Y+6)>IOSL D NEWPG

 G END:DGSTOP=U G A4

 ;***> eoj

END W !!,DGLIN,!,"Total Count:  ",DGCNT

 I IOST["C-" D PRTOPT^ADGVAR

 S X=DGIOM X ^%ZOSF("RM") K DGIOM

 W @IOF D KILL^ADGUTIL K ^TMP("DGZICAL",$J)

 D ^%ZISC Q

HEAD ;***> subrtn to print heading

 I (IOST["C-")!(DGPAGE>0) W @IOF

 W ?37,"*****Confidential Patient Data Covered by Privacy Act*****"

 W !,DGDUZ,?132-$L(DGFAC)\2,DGFAC

 W ! D TIME^ADGUTIL W ?52,"INCOMPLETE CHARTS ALPHA LIST"

 S DGPAGE=DGPAGE+1 W ?122,"Page ",DGPAGE

 W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?52,DGDTS

 W !!!,"Patient Name",?20,"HRCN",?27,"Admt Date",?38,"Ward"

 W ?44,"Summ Dict",?55,"Op Dict",?65,"A Sheet"

 W !?27,"Dsch Date",?38,"Srvc",?44,"Summ Rcvd",?55,"Op Rcvd"

 W ?65,"Coded",?75,"Provider",?92,"Chart Deficiency",?110,"Comments"

 W ?122,"Insurance",!,DGLIN1,!!

NEWPG ;***> subrtn for end of page control

 I IOST'?1"C-".E G HEAD

 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X

 G HEAD:DGSTOP'=U Q

NAME() ; -- returns printable name

 NEW N

 S N=$S(DGSRT=1:DGNAM,1:$P(^DPT(DFN,0),U))

 Q $E(N,1,15)

ADGICAL1  ; IHS/ADC/PDW/ENM - INCOMPLETE CHARTS ALPHA LIST PRINT ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3       ;***> initialize variables

 +4        SET DGIOM=IOM

           SET X=132

           XECUTE ^%ZOSF("RM")

 +5        SET DGPAGE=0

           SET DGSTOP=""

 +6        SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)

           SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)

 +7        SET DGX=$EXTRACT(DGBDT,4,5)_"/"_$EXTRACT(DGBDT,6,7)_"/"_($EXTRACT(DGBDT,1,3)+1700)

 +8        SET DGY=$EXTRACT(DGEDT,4,5)_"/"_$EXTRACT(DGEDT,6,7)_"/"_($EXTRACT(DGEDT,1,3)+1700)

 +9       ;printable date range

           SET DGDTS="from "_DGX_" to "_DGY

 +10       SET (DGLIN,DGLIN1)=""

           SET $PIECE(DGLIN,"-",132)=""

           SET $PIECE(DGLIN1,"=",132)=""

 +11       DO HEAD

 +12      ;

 +13      ;***> loop thru ^utility

 +14       SET DGNAM=0

A1         SET DGNAM=$ORDER(^TMP("DGZICAL",$JOB,DGNAM))

           IF DGNAM=""

               GOTO END

           SET DFN=0

A2         SET DFN=$ORDER(^TMP("DGZICAL",$JOB,DGNAM,DFN))

           IF DFN=""

               GOTO A1

           SET DGDFN2=0

A3         SET DGDFN1=$ORDER(^TMP("DGZICAL",$JOB,DGNAM,DFN,DGDFN1))

           IF DGDFN1=""

               GOTO A2

 +1       ;

 +2       ;***> set variables

 +3        SET DGSTR=^TMP("DGZICAL",$JOB,DGNAM,DFN,DGDFN1)

 +4        SET DGDD=$PIECE(DGSTR,U,2)

           SET DGAD=$PIECE(DGSTR,U,3)

           SET DGWD=$PIECE(DGSTR,U,4)

 +5        SET DGSV=$PIECE(DGSTR,U,5)

           SET DGSMD=$PIECE(DGSTR,U,7)

           SET DGSMR=$PIECE(DGSTR,U,8)

 +6        SET DGOPD=$PIECE(DGSTR,U,9)

           SET DGOPR=$PIECE(DGSTR,U,10)

           SET DGCOM=$PIECE(DGSTR,U,13)

 +7       ;

 +8       ;***> print line

 +9        WRITE !!,$$NAME,?18,$JUSTIFY($PIECE(DGSTR,U),7)

 +10       IF DGAD'=""

               WRITE ?27,$EXTRACT(DGAD,4,5)_"/"_$EXTRACT(DGAD,6,7)_"/"_$EXTRACT(DGAD,2,3)

 +11       WRITE ?38

           IF DGWD'=""

               WRITE $EXTRACT($PIECE($GET(^DIC(42,DGWD,0)),U),1,3)

 +12       IF DGSMD'=""

               WRITE ?44,$EXTRACT(DGSMD,4,5)_"/"_$EXTRACT(DGSMD,6,7)_"/"_$EXTRACT(DGSMD,2,3)

 +13       IF DGOPD'=""

               WRITE ?55,$EXTRACT(DGOPD,4,5)_"/"_$EXTRACT(DGOPD,6,7)_"/"_$EXTRACT(DGOPD,2,3)

 +14       WRITE ?67,$SELECT($PIECE(DGSTR,U,14)="Y":"YES",$PIECE(DGSTR,U,14)="N":"NO",1:"")

 +15       WRITE ?110,$PIECE(DGSTR,U,13),?123,$$INS^ADGMREC(DFN)

 +16       WRITE !

           IF DGDD'=""

               WRITE ?27,$EXTRACT(DGDD,4,5)_"/"_$EXTRACT(DGDD,6,7)_"/"_$EXTRACT(DGDD,2,3)

 +17       WRITE ?38

           IF DGSV'=""

               WRITE $EXTRACT($PIECE($GET(^DIC(45.7,DGSV,0)),U,3),1,3)

 +18       IF DGSMR'=""

               WRITE ?44,$EXTRACT(DGSMR,4,5)_"/"_$EXTRACT(DGSMR,6,7)_"/"_$EXTRACT(DGSMR,2,3)

 +19       IF DGOPR'=""

               WRITE ?55,$EXTRACT(DGOPR,4,5)_"/"_$EXTRACT(DGOPR,6,7)_"/"_$EXTRACT(DGOPR,2,3)

 +20       WRITE ?67,$SELECT($PIECE(DGSTR,U,12)="Y":"YES",$PIECE(DGSTR,U,12)="N":"NO",1:"")

 +21       IF ($Y+6)>IOSL

               DO NEWPG

               IF DGSTOP=U

                   GOTO END

 +22      ;

 +23       IF '$DATA(^ADGIC(DFN,"D",DGDFN1,"P",0))

               GOTO A3

 +24      ;

 +25      ;**> loop thru & find provi with chart deficiencies for this admission

 +26       SET DGDFN2=0

A4         SET DGDFN2=$ORDER(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2))

           IF +DGDFN2'=DGDFN2

               GOTO A3

 +1        SET DGPRV=$PIECE(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2,0),U)

 +2        IF $X>75

               WRITE !

           WRITE ?75

 +3       ;provider name

           IF DGPRV'=""

               WRITE $EXTRACT($PIECE($GET(^VA(200,DGPRV,0)),U),1,15)

 +4       ;

 +5       ;***> find all chart deficiencies for provider

 +6        SET DGX=0

FOR

               IF +DGX'=DGX

                   QUIT

               IF DGSTOP=U

                   QUIT

               Begin DoDot:1

 +7       ;

                   SET DGX=$ORDER(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2,"C",DGX))

                   IF +DGX'=DGX

                       QUIT

 +8                SET DGY=$PIECE(^ADGIC(DFN,"D",DGDFN1,"P",DGDFN2,"C",DGX,0),U)

 +9                IF DGY'=""

                       IF $DATA(^ADGCD(DGY,0))

                           WRITE ?92,$EXTRACT($PIECE(^ADGCD(DGY,0),U),1,16),!

 +10               IF ($Y+6)>IOSL

                       DO NEWPG

               End DoDot:1

 +11       IF DGSTOP=U

               GOTO END

           GOTO A4

 +12      ;

 +13      ;***> eoj

END        WRITE !!,DGLIN,!,"Total Count:  ",DGCNT

 +1        IF IOST["C-"

               DO PRTOPT^ADGVAR

 +2        SET X=DGIOM

           XECUTE ^%ZOSF("RM")

           KILL DGIOM

 +3        WRITE @IOF

           DO KILL^ADGUTIL

           KILL ^TMP("DGZICAL",$JOB)

 +4        DO ^%ZISC

           QUIT

 +5       ;

 +6       ;

HEAD      ;***> subrtn to print heading

 +1        IF (IOST["C-")!(DGPAGE>0)

               WRITE @IOF

 +2        WRITE ?37,"*****Confidential Patient Data Covered by Privacy Act*****"

 +3        WRITE !,DGDUZ,?132-$LENGTH(DGFAC)\2,DGFAC

 +4        WRITE !

           DO TIME^ADGUTIL

           WRITE ?52,"INCOMPLETE CHARTS ALPHA LIST"

 +5        SET DGPAGE=DGPAGE+1

           WRITE ?122,"Page ",DGPAGE

 +6        WRITE !,$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),?52,DGDTS

 +7        WRITE !!!,"Patient Name",?20,"HRCN",?27,"Admt Date",?38,"Ward"

 +8        WRITE ?44,"Summ Dict",?55,"Op Dict",?65,"A Sheet"

 +9        WRITE !?27,"Dsch Date",?38,"Srvc",?44,"Summ Rcvd",?55,"Op Rcvd"

 +10       WRITE ?65,"Coded",?75,"Provider",?92,"Chart Deficiency",?110,"Comments"

 +11       WRITE ?122,"Insurance",!,DGLIN1,!!

 +12       QUIT

 +13      ;

NEWPG     ;***> subrtn for end of page control

 +1        IF IOST'?1"C-".E

               GOTO HEAD

 +2        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           SET DGSTOP=X

 +3        IF DGSTOP'=U

               GOTO HEAD

           QUIT

 +4       ;

 +5       ;

NAME()    ; -- returns printable name

 +1        NEW N

 +2        SET N=$SELECT(DGSRT=1:DGNAM,1:$PIECE(^DPT(DFN,0),U))

 +3        QUIT $EXTRACT(N,1,15)

ADGICAL1.m