AGDOB ; IHS/ASDS/EFG - LIST PAT'S BY DOB ;
;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005
A1 I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
ALL W !,"Do you want ALL (Universal Look-up) patients in your data base? N // " D READ^AG G KILL:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) S AGUNIV=$S($D(DLOUT)!("Nn"[Y):0,"Yy"[Y:1,1:-1) I AGUNIV<0 D YN^AG G ALL
A2 W !!,"Enter the BEGINNING DOB for this report: EARLIEST DOB ON FILE// " D READ^AG I $D(DLOUT) S AGBDATE=0 G A3
G KILL:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) S:$D(DQOUT) Y="?" S X=Y,%DT="XEP" D ^%DT G A2:Y<1 S AGBDATE=Y I Y>DT W !!,*7,"Do not use future dates." G A2
A3 W !!,"Enter the ENDING DOB for this report: LATEST DOB ON FILE// " D READ^AG I $D(DLOUT) S AGEDATE=9999999 G A4
G KILL:$D(DFOUT)!$D(DTOUT),A2:$D(DUOUT) S:$D(DQOUT) Y="?" S X=Y,%DT="XEP" D ^%DT G A3:Y<1 S AGEDATE=Y I Y>DT W !!,*7,"Do not use future dates." G A3
A4 I AGEDATE<AGBDATE W !!,*7,"INVALID ENTRY - The END is before the BEGINNING." G A2
D BEGEND
B W !!!,"Print the patient list for dates-of-birth from:",!!?10,AGB," through ",AGE,".",!!!,"Is this correct? Y // " D READ^AG S Y=$E(Y_"Y") G KILL:$D(DTOUT)!$D(DFOUT),A1:$D(DUOUT)!(Y="N") I Y'="Y" D YN^AG G B
S AGIO=IO,AG("HAT")=""
DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS Q
G:'$D(IO("Q")) START K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
X ^%ZOSF("UCI") S ZTRTN="START^AGDOB",ZTUCI=Y,ZTDESC="PATIENTS IN DOB ORDER for "_$P(^AUTTLOC(DUZ(2),0),U,2)_"." F G="AGBDATE","AGEDATE","AGUNIV" S ZTSAVE(G)=""
D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGIO,AGBDATE,AGEDATE,AGUNIV,G,ZTDESC,ZTRTN,ZTSK,ZTUCI D ^%ZISC
Q
START ;EP - From TaskMan.
S (AGPGPG,AGTOT)=0,AG("LOC")=$S(AGUNIV:"*** UNIVERSAL ***",1:$P(^DIC(4,DUZ(2),0),U)),AG("USR")="" I $D(^VA(200,DUZ,0)) S AG("USR")=$P(^(0),U)
S AG("USRLOC")=AG("USR")_$J("",40-($L(AG("LOC"))\2)-$L(AG("USR")))_AG("LOC"),AGBM=IOSL-10 I $D(AGIO),AGIO=IO S AGBM=IOSL-4
K AG("USR") X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",") D CTR^AG S AGUCI=X D BEGEND S X="DOB's from "_AGB_" through "_AGE D CTR^AG S AGTTL=X
S:AGBDATE=0 AGBDATE=1 S N=AGBDATE-1 D LINES^AG,NOW^AG S X="as of "_AGTIME D CTR^AG S AGTIME=X U IO D HDR
L1 S N=$O(^DPT("ADOB",N)) G END:N=""!(+N>AGEDATE) S DFN=0
L2 S DFN=$O(^DPT("ADOB",N,DFN)) G L1:DFN="",L2:'$D(^DPT(DFN,0))!('AGUNIV&'$D(^AUPNPAT(DFN,41,DUZ(2),0)))
S AGTOT=AGTOT+1,AGA0=^DPT(DFN,0),AGA41="" I 'AGUNIV!(AGUNIV&$D(^AUPNPAT(DFN,41,DUZ(2),0))) S AGA41=^AUPNPAT(DFN,41,DUZ(2),0)
W $P(AGA0,U)," " S AG=$S($P(AGA41,U,3)]"":"*",1:"") D DEAD^AGMAN S AG=AG_$S($D(AG("DEAD")):"D",1:"") W:AG]"" "(",AG,")" I 'AGUNIV W ?45,$J($P(AGA41,U,2),6)
;S Y=$P(AGA0,U,9) I +Y S:$L(Y)=9 Y=$E(Y,1,3)_"-"_$E(Y,4,5)_"-"_$E(Y,6,99) W ?54,Y
W ?54,$$GET1^DIQ(9000001,DFN_",",1107.3) ;IHS/SD/TPF AG*7.1*4
S Y=$P(AGA0,U,3) I +Y D DD^%DT W ?67,Y
W ! W:$D(^DPT(DFN,.24)) ?20,$P(^(.24),U,3) W:$D(^AUPNPAT(DFN,11)) ?55,$E($P(^(11),U,18),1,23)
I AGUNIV,$D(^AUPNPAT(DFN,41)) S L=0 D FACS G:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) END
W ! I $Y>AGBM D RTRN^AG G END:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) D HDR
G L2
FACS S L=$O(^AUPNPAT(DFN,41,L)) Q:'L
I $D(^DIC(4,L,0)) W !?45,$J($P(^AUPNPAT(DFN,41,L,0),U,2),6)," ",$E($P(^DIC(4,L,0),U),1,26) I $Y>AGBM D RTRN^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) D HDR W:$O(^AUPNPAT(DFN,41,L)) $P(AGA0,U)," (cont.)"
G FACS
Q
END W !!,"Total Patients on this list: ",AGTOT K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF") D ^%ZISC
KILL K A,AGA0,AGA41,AG,AGB,AGBM,AGE,AGIO,AGTIME,AGTOT,AGBDATE,DA,DFN,DIC,DR,AGEDATE,L,AG("LOC"),N,AGPGPG,AGTTL,AGUCI,AGUNIV,AG("USRLOC"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD
Q
HDR S AGPGPG=AGPGPG+1 W $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG,!?21,"REGISTERED PATIENTS - DOB-ORDER LISTING",!,AGUCI,!?23,"(""D"" = DECEASED) (""*"" = INACTIVE)"
W !,AGTIME,!,AGTTL,!!!,"Patient's Name",?46,"IHS #",?58,"SSN",?72,"DOB",!?20,"Mother's maiden name",?55,"Current Community",!,AG("="),!
Q
BEGEND S Y=AGBDATE D DD^%DT S AGB=$S('AGBDATE:"EARLIEST DOB ON FILE",1:Y),Y=AGEDATE D DD^%DT S AGE=$S(AGEDATE=9999999:"LATEST DOB ON FILE",1:Y)
Q
AGDOB_source.html#xB">B ; IHS/ASDS/EFG - LIST PAT'S B_source.html#xB">BY DOB_source.html#xB">B ;
+1 ;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005
A1 IF '$DATA(DT)
SET %DT=""
SET X="T"
DO ^%DT
SET DT=Y
ALL WRITE !,"Do you want ALL (Universal Look-up) patients in your data base? N // "
DO READ^AG
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
GOTO KILL
SET AGUNIV=$SELECT($DATA(DLOUT)!("Nn"[Y):0,"Yy"[Y:1,1:-1)
IF AGUNIV<0
DO YN^AG
GOTO ALL
A2 WRITE !!,"Enter the B_source.html#xB">BEGINNING DOB_source.html#xB">B for this report: EARLIEST DOB_source.html#xB">B ON FILE// "
DO READ^AG
IF $DATA(DLOUT)
SET AGBDATE=0
GOTO A3
+1 IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
GOTO KILL
IF $DATA(DQOUT)
SET Y="?"
SET X=Y
SET %DT="XEP"
DO ^%DT
IF Y<1
GOTO A2
SET AGBDATE=Y
IF Y>DT
WRITE !!,*7,"Do not use future dates."
GOTO A2
A3 WRITE !!,"Enter the ENDING DOB_source.html#xB">B for this report: LATEST DOB_source.html#xB">B ON FILE// "
DO READ^AG
IF $DATA(DLOUT)
SET AGEDATE=9999999
GOTO A4
+1 IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO KILL
IF $DATA(DUOUT)
GOTO A2
IF $DATA(DQOUT)
SET Y="?"
SET X=Y
SET %DT="XEP"
DO ^%DT
IF Y<1
GOTO A3
SET AGEDATE=Y
IF Y>DT
WRITE !!,*7,"Do not use future dates."
GOTO A3
A4 IF AGEDATE<AGBDATE
WRITE !!,*7,"INVALID ENTRY - The END is before the BEGINNING."
GOTO A2
+1 DO BEGEND
B WRITE !!!,"Print the patient list for dates-of-birth from:",!!?10,AGB," through ",AGE,".",!!!,"Is this correct? Y // "
DO READ^AG
SET Y=$EXTRACT(Y_"Y")
IF $DATA(DTOUT)!$DATA(DFOUT)
GOTO KILL
IF $DATA(DUOUT)!(Y="N")
GOTO A1
IF Y'="Y"
DO YN^AG
GOTO B
+1 SET AGIO=IO
SET AG("HAT")=""
DEV SET %ZIS="OPQ"
DO ^%ZIS
IF POP
SET IOP=ION
DO ^%ZIS
QUIT
+1 IF '$DATA(IO("Q"))
GOTO START
KILL IO("Q")
IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+2 XECUTE ^%ZOSF("UCI")
SET ZTRTN="START^AGDOB"
SET ZTUCI=Y
SET ZTDESC="PATIENTS IN DOB ORDER for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."
FOR G="AGBDATE","AGEDATE","AGUNIV"
SET ZTSAVE(G)=""
+3 DO ^%ZTLOAD
IF '$DATA(ZTSK)
GOTO DEV
KILL AG,AGIO,AGBDATE,AGEDATE,AGUNIV,G,ZTDESC,ZTRTN,ZTSK,ZTUCI
DO ^%ZISC
+4 QUIT
START ;EP - From TaskMan.
+1 SET (AGPGPG,AGTOT)=0
SET AG("LOC")=$SELECT(AGUNIV:"*** UNIVERSAL ***",1:$PIECE(^DIC(4,DUZ(2),0),U))
SET AG("USR")=""
IF $DATA(^VA(200,DUZ,0))
SET AG("USR")=$PIECE(^(0),U)
+2 SET AG("USRLOC")=AG("USR")_$JUSTIFY("",40-($LENGTH(AG("LOC"))\2)-$LENGTH(AG("USR")))_AG("LOC")
SET AGBM=IOSL-10
IF $DATA(AGIO)
IF AGIO=IO
SET AGBM=IOSL-4
+3 KILL AG("USR")
XECUTE ^%ZOSF("UCI")
SET X="UCI: "_$PIECE(Y,",")
DO CTR^AG
SET AGUCI=X
DO BEGEND
SET X="DOB's from "_AGB_" through "_AGE
DO CTR^AG
SET AGTTL=X
+4 IF AGBDATE=0
SET AGBDATE=1
SET N=AGBDATE-1
DO LINES^AG
DO NOW^AG
SET X="as of "_AGTIME
DO CTR^AG
SET AGTIME=X
USE IO
DO HDR
L1 SET N=$ORDER(^DPT("ADOB",N))
IF N=""!(+N>AGEDATE)
GOTO END
SET DFN=0
L2 SET DFN=$ORDER(^DPT("ADOB",N,DFN))
IF DFN=""
GOTO L1
IF '$DATA(^DPT(DFN,0))!('AGUNIV&'$DATA(^AUPNPAT(DFN,41,DUZ(2),0)))
GOTO L2
+1 SET AGTOT=AGTOT+1
SET AGA0=^DPT(DFN,0)
SET AGA41=""
IF 'AGUNIV!(AGUNIV&$DATA(^AUPNPAT(DFN,41,DUZ(2),0)))
SET AGA41=^AUPNPAT(DFN,41,DUZ(2),0)
+2 WRITE $PIECE(AGA0,U)," "
SET AG=$SELECT($PIECE(AGA41,U,3)]"":"*",1:"")
DO DEAD^AGMAN
SET AG=AG_$SELECT($DATA(AG("DEAD")):"D",1:"")
IF AG]""
WRITE "(",AG,")"
IF 'AGUNIV
WRITE ?45,$JUSTIFY($PIECE(AGA41,U,2),6)
+3 ;S Y=$P(AGA0,U,9) I +Y S:$L(Y)=9 Y=$E(Y,1,3)_"-"_$E(Y,4,5)_"-"_$E(Y,6,99) W ?54,Y
+4 ;IHS/SD/TPF AG*7.1*4
WRITE ?54,$$GET1^DIQ(9000001,DFN_",",1107.3)
+5 SET Y=$PIECE(AGA0,U,3)
IF +Y
DO DD^%DT
WRITE ?67,Y
+6 WRITE !
IF $DATA(^DPT(DFN,.24))
WRITE ?20,$PIECE(^(.24),U,3)
IF $DATA(^AUPNPAT(DFN,11))
WRITE ?55,$EXTRACT($PIECE(^(11),U,18),1,23)
+7 IF AGUNIV
IF $DATA(^AUPNPAT(DFN,41))
SET L=0
DO FACS
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
GOTO END
+8 WRITE !
IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
GOTO END
DO HDR
+9 GOTO L2
FACS SET L=$ORDER(^AUPNPAT(DFN,41,L))
IF 'L
QUIT
+1 IF $DATA(^DIC(4,L,0))
WRITE !?45,$JUSTIFY($PIECE(^AUPNPAT(DFN,41,L,0),U,2),6)," ",$EXTRACT($PIECE(^DIC(4,L,0),U),1,26)
IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
QUIT
DO HDR
IF $ORDER(^AUPNPAT(DFN,41,L))
WRITE $PIECE(AGA0,U)," (cont.)"
+2 GOTO FACS
+3 QUIT
END WRITE !!,"Total Patients on this list: ",AGTOT
KILL AG("HAT")
DO RTRN^AG
WRITE $$S^AGVDF("IOF")
DO ^%ZISC
KILL KILL A,AGA0,AGA41,AG,AGB,AGBM,AGE,AGIO,AGTIME,AGTOT,AGBDATE,DA,DFN,DIC,DR,AGEDATE,L,AG("LOC"),N,AGPGPG,AGTTL,AGUCI,AGUNIV,AG("USRLOC"),X,Y
IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 QUIT
HDR SET AGPGPG=AGPGPG+1
WRITE $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG,!?21,"REGISTERED PATIENTS - DOB-ORDER LISTING",!,AGUCI,!?23,"(""D"" = DECEASED) (""*"" = INACTIVE)"
+1 WRITE !,AGTIME,!,AGTTL,!!!,"Patient's Name",?46,"IHS #",?58,"SSN",?72,"DOB",!?20,"Mother's maiden name",?55,"Current Community",!,AG("="),!
+2 QUIT
BEGEND SET Y=AGBDATE
DO DD^%DT
SET AGB=$SELECT('AGBDATE:"EARLIEST DOB ON FILE",1:Y)
SET Y=AGEDATE
DO DD^%DT
SET AGE=$SELECT(AGEDATE=9999999:"LATEST DOB ON FILE",1:Y)
+1 QUIT
