ADEPME ; IHS/HQT/MJL - MEDICAID ELIGIBLES PT 1 ;08:33 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
INIT ;
;------->GET DATE RANGE
D DATE G:Y<0 END
;------->DEVICE
ASKDEV ;FHL 9/9/98 S %ZIS="Q" D ^%ZIS G END:POP I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTSK) !,"REQUEST QUEUED." G END
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 ADEPCD("AC" (TASKMAN ENTRY)
D PROC
;------->PRINT
D ^ADEPME1
I $D(ZTQUEUED) S ZTREQ="@"
K ^ADEUTL("ADEPME",$J) ;^ADEUTL is a transient report global
;------->END
END K ADEAGE,ADEBD,ADEBDT,ADEDAT,ADEDFN,ADEDOB,ADEED,ADEFAC,ADELIN,ADEMDFN,ADENAM,ADEND,ADENOD,ADENUM,ADEPAG,ADEPAT,ADEPRV,J
Q
QUE S ZTRTN="ZTM^ADEPME",ZTDESC="DENTAL MEDICAID ELIGIBLE REPORT"
F J="ADEBD","ADEED" S ZTSAVE(J)=""
D ^%ZTLOAD Q
DATE S U="^",%DT="AE",%DT(0)=-DT,%DT("A")="SELECT BEGINNING DATE: " D ^%DT K %DT
Q:Y<0
S ADEBD=Y,%DT="AE",%DT(0)=ADEBD,%DT("A")="SELECT ENDING DATE: " D ^%DT K %DT
G:X="^" DATE Q:Y<0 S ADEED=Y I ADEED>DT W " ??",*7 G DATE
Q
PROC S ADEBD=ADEBD-1
K ^ADEUTL("ADEPME",$J)
I '$D(IO("S")),$P(IOST,"-")="C" W !,"Please wait while I scan the records..."
F J=0:0 S ADEBD=$O(^ADEPCD("AC",ADEBD)) Q:'ADEBD!(ADEBD>ADEED) S ADEDAT=$E(ADEBD,4,5)_"-"_$E(ADEBD,6,7)_"-"_$E(ADEBD,2,3) D P1
Q
P1 S ADEDFN=0 F J=0:0 S ADEDFN=$O(^ADEPCD("AC",ADEBD,ADEDFN)) Q:'ADEDFN D P3
Q
P3 Q:'$D(^ADEPCD(ADEDFN,0))
S ADENOD=^ADEPCD(ADEDFN,0)
Q:$P(ADENOD,U,9)'="d"
S ADEPAT=$P(ADENOD,U)
S ADEPRV=$P(ADENOD,U,4)
Q:'ADEPRV Q:'$D(^DIC(16,ADEPRV,0))
S ADEPRV=$P(^DIC(16,ADEPRV,0),U)
Q:'$D(^AUPNMCD("B",ADEPAT))
S ADEMDFN=$O(^AUPNMCD("B",ADEPAT,0))
Q:'ADEMDFN Q:'$D(^AUPNMCD(ADEMDFN,0))
S ADENUM=$P(^AUPNMCD(ADEMDFN,0),U,3) S:ADENUM']"" ADENUM="<Missing>"
Q:'$D(^DPT(ADEPAT,0))
S ADENOD=^DPT(ADEPAT,0),ADENAM=$P(ADENOD,U),ADEDOB=$P(ADENOD,U,3)
Q:'ADEDOB
S X1=DT,X2=ADEDOB D ^%DTC Q:X<1
;beginning Y2K fix
;S ADEAGE=X\364.25
S ADEAGE=X\365.25 ;Y2000
;end Y2K fix block
S ADEAGE=$S(ADEAGE<19:"0-18 YRS",(ADEAGE>18)&(ADEAGE<22):"19-21 YRS",ADEAGE>21:"22+ YRS",1:"") Q:ADEAGE=""
;***FUTURE VERSION: CALL LOCAL ELIGIBLE SERVICES TABLE HERE
S ^ADEUTL("ADEPME",$J,ADEAGE,ADENAM,ADEDFN)=ADEDAT_U_ADENUM_U_ADEPRV
Q
ADEPME ; IHS/HQT/MJL - MEDICAID ELIGIBLES PT 1 ;08:33 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
INIT ;
+1 ;------->GET DATE RANGE
+2 DO DATE
IF Y<0
GOTO END
+3 ;------->DEVICE
ASKDEV ;FHL 9/9/98 S %ZIS="Q" D ^%ZIS G END:POP I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTSK) !,"REQUEST QUEUED." G END
+1 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 ADEPCD("AC" (TASKMAN ENTRY)
+2 DO PROC
+3 ;------->PRINT
+4 DO ^ADEPME1
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 ;^ADEUTL is a transient report global
KILL ^ADEUTL("ADEPME",$JOB)
+7 ;------->END
END KILL ADEAGE,ADEBD,ADEBDT,ADEDAT,ADEDFN,ADEDOB,ADEED,ADEFAC,ADELIN,ADEMDFN,ADENAM,ADEND,ADENOD,ADENUM,ADEPAG,ADEPAT,ADEPRV,J
+1 QUIT
QUE SET ZTRTN="ZTM^ADEPME"
SET ZTDESC="DENTAL MEDICAID ELIGIBLE REPORT"
+1 FOR J="ADEBD","ADEED"
SET ZTSAVE(J)=""
+2 DO ^%ZTLOAD
QUIT
DATE SET U="^"
SET %DT="AE"
SET %DT(0)=-DT
SET %DT("A")="SELECT BEGINNING DATE: "
DO ^%DT
KILL %DT
+1 IF Y<0
QUIT
+2 SET ADEBD=Y
SET %DT="AE"
SET %DT(0)=ADEBD
SET %DT("A")="SELECT ENDING DATE: "
DO ^%DT
KILL %DT
+3 IF X="^"
GOTO DATE
IF Y<0
QUIT
SET ADEED=Y
IF ADEED>DT
WRITE " ??",*7
GOTO DATE
+4 QUIT
PROC SET ADEBD=ADEBD-1
+1 KILL ^ADEUTL("ADEPME",$JOB)
+2 IF '$DATA(IO("S"))
IF $PIECE(IOST,"-")="C"
WRITE !,"Please wait while I scan the records..."
+3 FOR J=0:0
SET ADEBD=$ORDER(^ADEPCD("AC",ADEBD))
IF 'ADEBD!(ADEBD>ADEED)
QUIT
SET ADEDAT=$EXTRACT(ADEBD,4,5)_"-"_$EXTRACT(ADEBD,6,7)_"-"_$EXTRACT(ADEBD,2,3)
DO P1
+4 QUIT
P1 SET ADEDFN=0
FOR J=0:0
SET ADEDFN=$ORDER(^ADEPCD("AC",ADEBD,ADEDFN))
IF 'ADEDFN
QUIT
DO P3
+1 QUIT
P3 IF '$DATA(^ADEPCD(ADEDFN,0))
QUIT
+1 SET ADENOD=^ADEPCD(ADEDFN,0)
+2 IF $PIECE(ADENOD,U,9)'="d"
QUIT
+3 SET ADEPAT=$PIECE(ADENOD,U)
+4 SET ADEPRV=$PIECE(ADENOD,U,4)
+5 IF 'ADEPRV
QUIT
IF '$DATA(^DIC(16,ADEPRV,0))
QUIT
+6 SET ADEPRV=$PIECE(^DIC(16,ADEPRV,0),U)
+7 IF '$DATA(^AUPNMCD("B",ADEPAT))
QUIT
+8 SET ADEMDFN=$ORDER(^AUPNMCD("B",ADEPAT,0))
+9 IF 'ADEMDFN
QUIT
IF '$DATA(^AUPNMCD(ADEMDFN,0))
QUIT
+10 SET ADENUM=$PIECE(^AUPNMCD(ADEMDFN,0),U,3)
IF ADENUM']""
SET ADENUM="<Missing>"
+11 IF '$DATA(^DPT(ADEPAT,0))
QUIT
+12 SET ADENOD=^DPT(ADEPAT,0)
SET ADENAM=$PIECE(ADENOD,U)
SET ADEDOB=$PIECE(ADENOD,U,3)
+13 IF 'ADEDOB
QUIT
+14 SET X1=DT
SET X2=ADEDOB
DO ^%DTC
IF X<1
QUIT
+15 ;beginning Y2K fix
+16 ;S ADEAGE=X\364.25
+17 ;Y2000
SET ADEAGE=X\365.25
+18 ;end Y2K fix block
+19 SET ADEAGE=$SELECT(ADEAGE<19:"0-18 YRS",(ADEAGE>18)&(ADEAGE<22):"19-21 YRS",ADEAGE>21:"22+ YRS",1:"")
IF ADEAGE=""
QUIT
+20 ;***FUTURE VERSION: CALL LOCAL ELIGIBLE SERVICES TABLE HERE
+21 SET ^ADEUTL("ADEPME",$JOB,ADEAGE,ADENAM,ADEDFN)=ADEDAT_U_ADENUM_U_ADEPRV
+22 QUIT
