ADGICAL3 ; IHS/ADC/PDW/ENM - DS INCOMPLETE CHARTS 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 DGAD=$P(DGSTR,U,2),DGSV=$P(DGSTR,U,6)
S DGOPD=$P(DGSTR,U,3),DGOPR=$P(DGSTR,U,4),DGCOM=$P(DGSTR,U,5)
;
;***> 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:DGSV'="" $E($P($G(^DIC(45.7,DGSV,0)),U,3),1,3)
W:DGOPD'="" ?44,$E(DGOPD,4,5)_"/"_$E(DGOPD,6,7)_"/"_$E(DGOPD,2,3)
W:DGOPR'="" ?55,$E(DGOPR,4,5)_"/"_$E(DGOPR,6,7)_"/"_$E(DGOPR,2,3)
;
G A3:'$D(^ADGDSI(DFN,"DT",DGDFN1,"P",0))
;
;**> loop thru & find provi with chart deficiencies for this admission
S DGDFN2=0
A4 S DGDFN2=$O(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2)) G A3:+DGDFN2'=DGDFN2
S DGPRV=$P(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2,0),U)
W:$X>65 ! W ?65
W:DGPRV'="" $E($P($G(^VA(200,DGPRV,0)),U),1,18) ;provider name
;
;***> find all chart deficiencies for provider
S DGX=0 F Q:+DGX'=DGX Q:DGSTOP=U D
.S DGX=$O(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2,"CD",DGX)) Q:+DGX'=DGX
.S DGY=$P(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2,"CD",DGX,0),U)
.I DGY'="",$D(^ADGCD(DGY,0)) W ?90,$E($P(^ADGCD(DGY,0),U),1,16)
.I ($Y+6)>IOSL D NEWPG
I $X>110 W ! I ($Y+6)>IOSL D NEWPG G END:DGSTOP=U
W ?110,$E(DGCOM,1,13),?123,$E($$INS^ADGMREC(DFN),1,8)
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,"DS INCOMPLETE CHARTS 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,"Surg Date",?38,"Srv"
W ?44,"Op Dict",?55,"Op Rvcd",?65,"Provider",?90,"Chart Def"
W ?110,"Comments",?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)
ADGICAL3 ; IHS/ADC/PDW/ENM - DS INCOMPLETE CHARTS 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 DGAD=$PIECE(DGSTR,U,2)
SET DGSV=$PIECE(DGSTR,U,6)
+5 SET DGOPD=$PIECE(DGSTR,U,3)
SET DGOPR=$PIECE(DGSTR,U,4)
SET DGCOM=$PIECE(DGSTR,U,5)
+6 ;
+7 ;***> print line
+8 WRITE !!,$$NAME,?18,$JUSTIFY($PIECE(DGSTR,U),7)
+9 IF DGAD'=""
WRITE ?27,$EXTRACT(DGAD,4,5)_"/"_$EXTRACT(DGAD,6,7)_"/"_$EXTRACT(DGAD,2,3)
+10 WRITE ?38
IF DGSV'=""
WRITE $EXTRACT($PIECE($GET(^DIC(45.7,DGSV,0)),U,3),1,3)
+11 IF DGOPD'=""
WRITE ?44,$EXTRACT(DGOPD,4,5)_"/"_$EXTRACT(DGOPD,6,7)_"/"_$EXTRACT(DGOPD,2,3)
+12 IF DGOPR'=""
WRITE ?55,$EXTRACT(DGOPR,4,5)_"/"_$EXTRACT(DGOPR,6,7)_"/"_$EXTRACT(DGOPR,2,3)
+13 ;
+14 IF '$DATA(^ADGDSI(DFN,"DT",DGDFN1,"P",0))
GOTO A3
+15 ;
+16 ;**> loop thru & find provi with chart deficiencies for this admission
+17 SET DGDFN2=0
A4 SET DGDFN2=$ORDER(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2))
IF +DGDFN2'=DGDFN2
GOTO A3
+1 SET DGPRV=$PIECE(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2,0),U)
+2 IF $X>65
WRITE !
WRITE ?65
+3 ;provider name
IF DGPRV'=""
WRITE $EXTRACT($PIECE($GET(^VA(200,DGPRV,0)),U),1,18)
+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(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2,"CD",DGX))
IF +DGX'=DGX
QUIT
+8 SET DGY=$PIECE(^ADGDSI(DFN,"DT",DGDFN1,"P",DGDFN2,"CD",DGX,0),U)
+9 IF DGY'=""
IF $DATA(^ADGCD(DGY,0))
WRITE ?90,$EXTRACT($PIECE(^ADGCD(DGY,0),U),1,16)
+10 IF ($Y+6)>IOSL
DO NEWPG
End DoDot:1
+11 IF $X>110
WRITE !
IF ($Y+6)>IOSL
DO NEWPG
IF DGSTOP=U
GOTO END
+12 WRITE ?110,$EXTRACT(DGCOM,1,13),?123,$EXTRACT($$INS^ADGMREC(DFN),1,8)
+13 IF DGSTOP=U
GOTO END
GOTO A4
+14 ;
+15 ;***> 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,"DS INCOMPLETE CHARTS 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,"Surg Date",?38,"Srv"
+8 WRITE ?44,"Op Dict",?55,"Op Rvcd",?65,"Provider",?90,"Chart Def"
+9 WRITE ?110,"Comments",?122,"Insurance",!,DGLIN1
+10 QUIT
+11 ;
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)
