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,!!
Q
;
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)
