AGDOB.m

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