- 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)
