ADEPDFR ; IHS/HQT/MJL - DEFERRED SVCS PART 1 ;07:05 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;------->INIT
I $D(DUZ(2)),DUZ(2)]""
E W "DIVISION NOT PROPERLY SET -- CONTACT SITE MANAGER" G END
INIT ;
;------->SORT CRITERIA
;NOTE: Add additional criteria here in future version
W !,"You may limit the report to include only patients who were added",!,"to the Deferred Services Register during a particular time."
S ADEBEG=$$DATE^ADEPQA3()
G:$$HAT^ADEPQA3() END
G:'+ADEBEG END
S ADEEND=$P(ADEBEG,U,3),ADEBEG=$P(ADEBEG,U,2)
;------->DEVICE
;FHL 9/9/98
ASKDEV S %ZIS="Q" D ^%ZIS G END:POP I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTQUEUED) !,"REQUEST QUEUED." G END
ZTM ;EP
;------->$O THRU ADEDSR("B" (TASKMAN ENTRY)
D PROC
;------->PRINT
D ^ADEPDFR1
I $D(ZTQUEUED) S ZTREQ="@"
K ^ADEUTIL("ADEPDFR",$J) ;^ADEUTIL is a transient working global
;------->END
END K ADEAGE,ADEDFN,ADELIN,ADENAM,ADENOD,ADETOT,ADEHRN,ADEADD,ADEPAT,ADEPAG,J,ADEJ,ADEK,ADEL,ADEM,ADEGBL,ADESUB,ADESVC,ADEN,ADEBEG,ADEEND,DTOUT,DUOUT,DIROUT
Q
QUE S ZTRTN="ZTM^ADEPDFR",ZTDESC="DENTAL DEFERRED SVCS REPORT"
S ZTSAVE("ADEBEG")="",ZTSAVE("ADEEND")="" ;***IHS/HMW PATCH
D ^%ZTLOAD
Q
PROC S ADEPAT=""
K ^ADEUTIL("ADEPDFR",$J)
I '$D(IO("S")),$P(IOST,"-")="C" W !,"Please wait while I scan the records..."
F ADEJ=0:0 S ADEPAT=$O(^ADEDSR("B",ADEPAT)) Q:'ADEPAT S ADEDFN=$O(^ADEDSR("B",ADEPAT,0)) D P3 I '$D(IO("S")),$P(IOST,"-")="C" W "."
Q
P3 Q:'$D(^ADEDSR(ADEDFN,0))
Q:'$D(^ADEDSR(ADEDFN,1))
Q:'$D(^ADEDSR(ADEDFN,2))
S ADENOD=$P(^ADEDSR(ADEDFN,2),U)
Q:ADENOD<ADEBEG
Q:ADENOD>ADEEND
S ADENOD=^ADEDSR(ADEDFN,0)
S ADETOT=$P(ADENOD,U,2)
S ADEHRN="MISSING"
I $D(^AUPNPAT(+ADENOD,41,DUZ(2),0)) S ADEHRN=$P(^(0),U,2)
Q:'$D(^DPT(+ADENOD,0))
S ADENOD=^DPT(+ADENOD,0),ADENAM=$P(ADENOD,U),ADEAGE=$P(ADENOD,U,3)
Q:'ADEAGE
S X1=DT,X2=ADEAGE D ^%DTC Q:X<1
;beginning Y2K fix
;S ADEAGE=X\364.25
S ADEAGE=X\365.25 ;Y2000
;S ADEADD="" I $D(^ADEDSR(ADEDFN,2)) S ADEADD=^(2),ADEADD=$E(ADEADD,4,5)_"-"_$E(ADEADD,6,7)_"-"_$E(ADEADD,2,3)
S ADEADD="" I $D(^ADEDSR(ADEDFN,2)) S ADEADD=^(2) D:ADEADD'=""
.S ADEYR=1700+$E(ADEADD,1,3) ;Y2000
.S ADEADD=$E(ADEADD,4,5)_"-"_$E(ADEADD,6,7)_"-"_ADEYR ;Y2000
.K ADEYR
;end Y2K fix block
D P4
S ADEGBL=ADENAM_U_ADEHRN_U_ADEAGE_U_ADEADD
F ADEM=1:1:16 S $P(ADEGBL,U,ADEM+4)=ADESVC(ADEM)
S ADEGBL=ADEGBL_U_ADETOT
S ^ADEUTIL("ADEPDFR",$J,ADENAM,ADEDFN)=ADEGBL
Q
P4 Q:'$D(^ADEDSR(ADEDFN,1))
F ADEN=1:1:16 S ADESVC(ADEN)="-"
S ADESUB=0
F S ADESUB=$O(^ADEDSR(ADEDFN,1,ADESUB)) Q:'+ADESUB D
. S ADENOD=^ADEDSR(ADEDFN,1,ADESUB,0)
. S $P(ADENOD,U)=$P(^ADEDNT(+ADENOD,0),U,2)
. D:+ADENOD P5
Q
P5 S ADESVC(+ADENOD)=ADESVC(+ADENOD)+$P(ADENOD,U,2)
Q
ADEPDFR ; IHS/HQT/MJL - DEFERRED SVCS PART 1 ;07:05 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;------->INIT
+3 IF $DATA(DUZ(2))
IF DUZ(2)]""
+4 IF '$TEST
WRITE "DIVISION NOT PROPERLY SET -- CONTACT SITE MANAGER"
GOTO END
INIT ;
+1 ;------->SORT CRITERIA
+2 ;NOTE: Add additional criteria here in future version
+3 WRITE !,"You may limit the report to include only patients who were added",!,"to the Deferred Services Register during a particular time."
+4 SET ADEBEG=$$DATE^ADEPQA3()
+5 IF $$HAT^ADEPQA3()
GOTO END
+6 IF '+ADEBEG
GOTO END
+7 SET ADEEND=$PIECE(ADEBEG,U,3)
SET ADEBEG=$PIECE(ADEBEG,U,2)
+8 ;------->DEVICE
+9 ;FHL 9/9/98
ASKDEV SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO END
IF $DATA(IO("Q"))
KILL IO("Q")
DO QUE
IF $DATA(ZTQUEUED)
WRITE !,"REQUEST QUEUED."
GOTO END
ZTM ;EP
+1 ;------->$O THRU ADEDSR("B" (TASKMAN ENTRY)
+2 DO PROC
+3 ;------->PRINT
+4 DO ^ADEPDFR1
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 ;^ADEUTIL is a transient working global
KILL ^ADEUTIL("ADEPDFR",$JOB)
+7 ;------->END
END KILL ADEAGE,ADEDFN,ADELIN,ADENAM,ADENOD,ADETOT,ADEHRN,ADEADD,ADEPAT,ADEPAG,J,ADEJ,ADEK,ADEL,ADEM,ADEGBL,ADESUB,ADESVC,ADEN,ADEBEG,ADEEND,DTOUT,DUOUT,DIROUT
+1 QUIT
QUE SET ZTRTN="ZTM^ADEPDFR"
SET ZTDESC="DENTAL DEFERRED SVCS REPORT"
+1 ;***IHS/HMW PATCH
SET ZTSAVE("ADEBEG")=""
SET ZTSAVE("ADEEND")=""
+2 DO ^%ZTLOAD
+3 QUIT
PROC SET ADEPAT=""
+1 KILL ^ADEUTIL("ADEPDFR",$JOB)
+2 IF '$DATA(IO("S"))
IF $PIECE(IOST,"-")="C"
WRITE !,"Please wait while I scan the records..."
+3 FOR ADEJ=0:0
SET ADEPAT=$ORDER(^ADEDSR("B",ADEPAT))
IF 'ADEPAT
QUIT
SET ADEDFN=$ORDER(^ADEDSR("B",ADEPAT,0))
DO P3
IF '$DATA(IO("S"))
IF $PIECE(IOST,"-")="C"
WRITE "."
+4 QUIT
P3 IF '$DATA(^ADEDSR(ADEDFN,0))
QUIT
+1 IF '$DATA(^ADEDSR(ADEDFN,1))
QUIT
+2 IF '$DATA(^ADEDSR(ADEDFN,2))
QUIT
+3 SET ADENOD=$PIECE(^ADEDSR(ADEDFN,2),U)
+4 IF ADENOD<ADEBEG
QUIT
+5 IF ADENOD>ADEEND
QUIT
+6 SET ADENOD=^ADEDSR(ADEDFN,0)
+7 SET ADETOT=$PIECE(ADENOD,U,2)
+8 SET ADEHRN="MISSING"
+9 IF $DATA(^AUPNPAT(+ADENOD,41,DUZ(2),0))
SET ADEHRN=$PIECE(^(0),U,2)
+10 IF '$DATA(^DPT(+ADENOD,0))
QUIT
+11 SET ADENOD=^DPT(+ADENOD,0)
SET ADENAM=$PIECE(ADENOD,U)
SET ADEAGE=$PIECE(ADENOD,U,3)
+12 IF 'ADEAGE
QUIT
+13 SET X1=DT
SET X2=ADEAGE
DO ^%DTC
IF X<1
QUIT
+14 ;beginning Y2K fix
+15 ;S ADEAGE=X\364.25
+16 ;Y2000
SET ADEAGE=X\365.25
+17 ;S ADEADD="" I $D(^ADEDSR(ADEDFN,2)) S ADEADD=^(2),ADEADD=$E(ADEADD,4,5)_"-"_$E(ADEADD,6,7)_"-"_$E(ADEADD,2,3)
+18 SET ADEADD=""
IF $DATA(^ADEDSR(ADEDFN,2))
SET ADEADD=^(2)
IF ADEADD'=""
Begin DoDot:1
+19 ;Y2000
SET ADEYR=1700+$EXTRACT(ADEADD,1,3)
+20 ;Y2000
SET ADEADD=$EXTRACT(ADEADD,4,5)_"-"_$EXTRACT(ADEADD,6,7)_"-"_ADEYR
+21 KILL ADEYR
End DoDot:1
+22 ;end Y2K fix block
+23 DO P4
+24 SET ADEGBL=ADENAM_U_ADEHRN_U_ADEAGE_U_ADEADD
+25 FOR ADEM=1:1:16
SET $PIECE(ADEGBL,U,ADEM+4)=ADESVC(ADEM)
+26 SET ADEGBL=ADEGBL_U_ADETOT
+27 SET ^ADEUTIL("ADEPDFR",$JOB,ADENAM,ADEDFN)=ADEGBL
+28 QUIT
P4 IF '$DATA(^ADEDSR(ADEDFN,1))
QUIT
+1 FOR ADEN=1:1:16
SET ADESVC(ADEN)="-"
+2 SET ADESUB=0
+3 FOR
SET ADESUB=$ORDER(^ADEDSR(ADEDFN,1,ADESUB))
IF '+ADESUB
QUIT
Begin DoDot:1
+4 SET ADENOD=^ADEDSR(ADEDFN,1,ADESUB,0)
+5 SET $PIECE(ADENOD,U)=$PIECE(^ADEDNT(+ADENOD,0),U,2)
+6 IF +ADENOD
DO P5
End DoDot:1
+7 QUIT
P5 SET ADESVC(+ADENOD)=ADESVC(+ADENOD)+$PIECE(ADENOD,U,2)
+1 QUIT
