AGOV64.m

AGOV64 ; IHS/ASDS/EFG - PRINT ALL PATS OVER 64 WITH MEDICARE/RAILROAD/SOC SEC NUMBERS ;  

 ;;7.1;PATIENT REGISTRATION;**2,4,9,11,14**;AUG 25, 2005;Build 1

 ;IHS/OIT/NKD AG*7.1*11 REMOVED DEBUG DISPLAY

 ;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2, FIXED BUG WITH ONLY DISPLAYING ONE PATIENT PER DOB

 ;

 S AGIO=IO,AG("HAT")=""

 ;AG*7.1*2 IM 21608

 W !!

 K DIR

 S DIR(0)="Y"

 S DIR("A")="Include inactive patients?"

 S DIR("B")="N"

 D ^DIR

 Q:$D(DUOUT)!$D(DTOUT)

 S AGINACT=+Y

 K DTOUT,DUOUT,DIR

 W !!

 ;END

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^AGOV64",ZTUCI=Y,ZTIO="",ZTDESC="PATIENTS OVER 64 for "_$P(^AUTTLOC(DUZ(2),0),U,2)_".",AGQIO=IO F G="AGQIO","DUZ","AGINACT" S ZTSAVE(G)=""

 D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGIO,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI D ^%ZISC

 Q

START ;EP - From TaskMan.

 S AG("64")=DT-640000,(AGTOT,AGTOTM,AGTOTR,AGPGPG)=0

 K ^TMP($J),AG("LOC"),AG("USR")

 ;F I=0:0 S I=$O(^DPT("ADOB",I)) Q:+I=0!(+I>AG("64"))  S J=$O(^(I,"")) I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S ^TMP($J,J)=""

 ;F I=0:0 S I=$O(^DPT("ADOB",I)) Q:+I=0!(+I>AG("64"))  S J=$O(^(I,"")) Q:($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)  I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S ^TMP($J,J)=""  ;AG*7.1*2 IM21608

 F I=0:0 S I=$O(^DPT("ADOB",I)) Q:+I=0!(+I>AG("64"))  D

 .;S J=$O(^(I,""))

 . ;IHS/OIT/NKD AG*7.1*14 START OLD CODE - BUF FIX TO ALLOW MULTIPLE PATIENTS WITH THE SAME DOB

 . ;S J=$O(^DPT("ADOB",I,""))  ;AG*1.8*4 SAC:TOOK OUT NAKED REFERENCE

 . ;IHS/OIT/NKD AG*7.1*11 REMOVED DEBUG DISPLAY

 . ;I ($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT) W !,J,"    ",$P($G(^DPT(J,0)),U)

 . ;Q:($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)

 . ;Q:((I+650000)>DT)  ;IHS/SD/SDR 11/4/10 HEAT20844

 . ;I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S NAME=$P($G(^DPT(J,0)),U) S ^TMP($J,NAME)=J  ;AG*7.1*2 IM21608

 . ;IHS/OIT/NKD AG*7.1*14 END OLD CODE - START NEW CODE

 . S J="" F  S J=$O(^DPT("ADOB",I,J)) Q:'J  D

 . . Q:($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)

 . . Q:((I+650000)>DT)  ;IHS/SD/SDR 11/4/10 HEAT20844

 . . I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S NAME=$P($G(^DPT(J,0)),U) S ^TMP($J,NAME)=J  ;AG*7.1*2 IM21608

 . ;IHS/OIT/NKD AG*7.1*14 END NEW CODE

 I $D(AGQIO) F AGZ("I")=1:1 S IOP=AGQIO D ^%ZIS Q:'POP

 S AG("LOC")=$P(^DIC(4,DUZ(2),0),U),AG("USR")=$P(^VA(200,DUZ,0),U),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("LOC"),AG("USR") U IO

 D LINES^AG,NOW^AG

 S X="Report date: "_AGTIME D CTR^AG S AGTIME=X D HDR

  ;MAIN LOOP IM21608

 K DUOUT,DFOUT,DTOUT

 S NAME=""

 F  S NAME=$O(^TMP($J,NAME)) Q:NAME=""  D  Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)

 .S DFN=$G(^TMP($J,NAME))

 .S AGRRESW="N"

 .S MCDREC=""

 .S PRVTREC=0

 .D PRINT

 .I $Y>AGBM D RTRN^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)  D HDR

 K AG("HAT")

 Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)

 ;F DFN=0:0 S DFN=$O(^TMP($J,DFN)) Q:'DFN  S AGRRESW="N" D PRINT I $Y>AGBM D RTRN^AG G:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) END D HDR

 K AG("HAT") D RTRN^AG W !!,"Total patients 65 yrs or older: ",AGTOT,!!,"Total patients 65 or older with Medicare: ",AGTOTM,!!,"Total patients 65 or older with Railroad Ret: ",AGTOTR D RTRN^AG W $$S^AGVDF("IOF")

END D ^%ZISC K ^TMP($J),A,AG,AGIO,AGTIME,AGBM,DA,DIC,DFN,DLOUT,DR,G,AGL,I,J,AG("LKDATA"),AG("LKPRINT"),AGPCC,AGPGPG,AGRRESW,AGTOT,AGTOTM,AGTOTR,AG("USRLOC"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD

 Q

PRINT S AGTOT=AGTOT+1 W $P(^DPT(DFN,0),U)," (",$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),")"

 W $S($P(^AUPNPAT(DFN,41,DUZ(2),0),U,3)'="":"*",1:"")

 I $D(^DPT(DFN,.13)) S AGPHONE=$P(^(.13),U),AGPHONE=$S($L(AGPHONE)=10:$E(AGPHONE,1,3)_"-"_$E(AGPHONE,4,6)_"-"_$E(AGPHONE,7,10),$L(AGPHONE)=7:$E(AGPHONE,1,3)_"-"_$E(AGPHONE,4,7),1:AGPHONE) W ?35,AGPHONE K AGPHONE

 ;IHS/OIT/NKD AG*7.1*14 - START OLD CODE

 ;MCR G:'$D(^AUPNMCR(DFN,0)) RRE1 S AGMCRNO=$P(^AUPNMCR(DFN,0),U,3) S:$L(AGMCRNO)=9 AGMCRNO=$E(AGMCRNO,1,3)_"-"_$E(AGMCRNO,4,5)_"-"_$E(AGMCRNO,6,9) W ?49,"M=",AGMCRNO,"-"

 ;W:(AGMCRNO)="" ?49,"NO NUMBER " W:$P(^AUPNMCR(DFN,0),U,4)]"" $P(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0),U) S AGTOTM=AGTOTM+1 K AGMCRNO G SSN

 ;IHS/OIT/NKD AG*7.1*14 - END OLD CODE - START NEW CODE

MCR  ;

 G:'$D(^AUPNMCR(DFN,0)) RRE1

 S AGMCRNO=$$GETMCR^AGUTL(DFN),AGISMBI=$$ISMBI^AGUTL(AGMCRNO)

 I 'AGISMBI,AGISMBI["MCR" S AGMCRNO=$E(AGMCRNO,1,3)_"-"_$E(AGMCRNO,4,5)_"-"_$E(AGMCRNO,6,9)_"-"_$E(AGMCRNO,10,11)

 W ?49,$S($L(AGMCRNO):"M="_AGMCRNO,1:"NO NUMBER ")

 S AGTOTM=AGTOTM+1 K AGMCRNO,AGISMBI G SSN

 ;IHS/OIT/NKD AG*7.1*14 - END NEW CODE

RRE1 I '$D(^AUPNMCR(DFN,0)),$D(^AUPNRRE(DFN,0)) D WRRE S AGRRESW="Y"

SSN ;S DIC=2,DR=.09,DA=DFN D ^AGDICLK I $D(AG("LKDATA")) S:$L(AG("LKDATA"))=9 AG("LKDATA")=$E(AG("LKDATA"),1,3)_"-"_$E(AG("LKDATA"),4,5)_"-"_$E(AG("LKDATA"),6,99) W ?67,AG("LKDATA")

 W ?67,$$GET1^DIQ(9000001,DFN_",",1107.3)  ;IHS/SD/TPF AG*7.1*4

 G CKRRE:'$D(^DPT(DFN,.11))

 S AGA=^DPT(DFN,.11) W:$P(AGA,U)]"" !?10,$P(AGA,U) S AG("ADDR")=$P(AGA,U,4)_" " I $P(AGA,U,5)]"",$D(^DIC(5,$P(AGA,U,5),0)) S AG("ADDR")=AG("ADDR")_$P(^(0),U,2)_" " G RRE

CKRRE I $D(^AUPNRRE(DFN,0)),AGRRESW'="Y" W !

RRE G ADDR1:'$D(^AUPNRRE(DFN,0))!(AGRRESW="Y") D WRRE

ADDR1 I $D(^DPT(DFN,.11)) S AG("ADDR")=AG("ADDR")_$P(AGA,U,6) W:AG("ADDR")]"" !?10,AG("ADDR")

 D PMCNM,RRENM W !,AG("-"),!

 Q

HDR S AGPGPG=AGPGPG+1 W $$S^AGVDF("IOF"),!,AG("USRLOC"),?70,"page ",AGPGPG,!?26,"PATIENTS 65 YRS OLD AND OLDER",!,AGTIME,!!?51,"MEDICARE(M)",?69,"SOCIAL",!,"NAME (CHART #)",?35,"HOME PHONE",?51,"RAILROAD(R)",?66,"SECURITY NO.",!,AG("="),!

 Q

 ;WRRE S AGRRNO=$P(^AUPNRRE(DFN,0),U,4) S:$L(AGRRNO)=9 AGRRNO=$E(AGRRNO,1,3)_"-"_$E(AGRRNO,4,5)_"-"_$E(AGRRNO,6,9) W ?49,"R=" W:$P(^AUPNRRE(DFN,0),U,3) $P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U),"-" W AGRRNO S AGTOTR=AGTOTR+1 K AGRRNO  ;IHS/OIT/NKD AG*7.1*14

 ;IHS/OIT/NKD AG*7.1*14 - START NEW CODE

WRRE  ;

 S AGRRNO=$$GETRRE^AGUTL(DFN),AGISMBI=$$ISMBI^AGUTL(AGRRNO)

 I 'AGISMBI,AGISMBI["RRE" S AGRRNO=$S($L(AGRRNO)>9:$E(AGRRNO,1,$L(AGRRNO)-9)_"-",1:"")_$E(AGRRNO,$L(AGRRNO)-8,$L(AGRRNO)-6)_"-"_$E(AGRRNO,$L(AGRRNO)-5,$L(AGRRNO)-4)_"-"_$E(AGRRNO,$L(AGRRNO)-3,$L(AGRRNO))

 W ?49,$S($L(AGRRNO):"R="_AGRRNO,1:"NO NUMBER ")

 S AGTOTR=AGTOTR+1 K AGRRNO,AGISMBI

 Q

 ;IHS/OIT/NKD AG*7.1*14 - END NEW CODE

PMCNM K AGMCRNM I $D(^AUPNMCR(DFN,0)),$D(^AUPNMCR(DFN,21)) S AGMCRNM=$P(^AUPNMCR(DFN,21),U) W:AGMCRNM]"" !,"(MCR) ",AGMCRNM K AGMCRNM

 Q

RRENM K AGRRNM I $D(^AUPNRRE(DFN,0)),$D(^AUPNRRE(DFN,21)) S AGRRNM=$P(^AUPNRRE(DFN,21),U) W:AGRRNM]"" !,"(RR)  ",AGRRNM K AGRRNM

 Q

AGOV64    ; IHS/ASDS/EFG - PRINT ALL PATS OVER 64 WITH MEDICARE/RAILROAD/SOC SEC NUMBERS ;  

 +1       ;;7.1;PATIENT REGISTRATION;**2,4,9,11,14**;AUG 25, 2005;Build 1

 +2       ;IHS/OIT/NKD AG*7.1*11 REMOVED DEBUG DISPLAY

 +3       ;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2, FIXED BUG WITH ONLY DISPLAYING ONE PATIENT PER DOB

 +4       ;

 +5        SET AGIO=IO

           SET AG("HAT")=""

 +6       ;AG*7.1*2 IM 21608

 +7        WRITE !!

 +8        KILL DIR

 +9        SET DIR(0)="Y"

 +10       SET DIR("A")="Include inactive patients?"

 +11       SET DIR("B")="N"

 +12       DO ^DIR

 +13       IF $DATA(DUOUT)!$DATA(DTOUT)

               QUIT 

 +14       SET AGINACT=+Y

 +15       KILL DTOUT,DUOUT,DIR

 +16       WRITE !!

 +17      ;END

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^AGOV64"

           SET ZTUCI=Y

           SET ZTIO=""

           SET ZTDESC="PATIENTS OVER 64 for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."

           SET AGQIO=IO

           FOR G="AGQIO","DUZ","AGINACT"

               SET ZTSAVE(G)=""

 +3        DO ^%ZTLOAD

           IF '$DATA(ZTSK)

               GOTO DEV

           KILL AG,AGIO,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI

           DO ^%ZISC

 +4        QUIT 

START     ;EP - From TaskMan.

 +1        SET AG("64")=DT-640000

           SET (AGTOT,AGTOTM,AGTOTR,AGPGPG)=0

 +2        KILL ^TMP($JOB),AG("LOC"),AG("USR")

 +3       ;F I=0:0 S I=$O(^DPT("ADOB",I)) Q:+I=0!(+I>AG("64"))  S J=$O(^(I,"")) I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S ^TMP($J,J)=""

 +4       ;F I=0:0 S I=$O(^DPT("ADOB",I)) Q:+I=0!(+I>AG("64"))  S J=$O(^(I,"")) Q:($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)  I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S ^TMP($J,J)=""  ;AG*7.1*2 IM21608

 +5        FOR I=0:0

               SET I=$ORDER(^DPT("ADOB",I))

               IF +I=0!(+I>AG("64"))

                   QUIT 

               Begin DoDot:1

 +6       ;S J=$O(^(I,""))

 +7       ;IHS/OIT/NKD AG*7.1*14 START OLD CODE - BUF FIX TO ALLOW MULTIPLE PATIENTS WITH THE SAME DOB

 +8       ;S J=$O(^DPT("ADOB",I,""))  ;AG*1.8*4 SAC:TOOK OUT NAKED REFERENCE

 +9       ;IHS/OIT/NKD AG*7.1*11 REMOVED DEBUG DISPLAY

 +10      ;I ($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT) W !,J,"    ",$P($G(^DPT(J,0)),U)

 +11      ;Q:($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)

 +12      ;Q:((I+650000)>DT)  ;IHS/SD/SDR 11/4/10 HEAT20844

 +13      ;I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),"^",1) S NAME=$P($G(^DPT(J,0)),U) S ^TMP($J,NAME)=J  ;AG*7.1*2 IM21608

 +14      ;IHS/OIT/NKD AG*7.1*14 END OLD CODE - START NEW CODE

 +15               SET J=""

                   FOR 

                       SET J=$ORDER(^DPT("ADOB",I,J))

                       IF 'J

                           QUIT 

                       Begin DoDot:2

 +16                       IF ($PIECE($GET(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)

                               QUIT 

 +17      ;IHS/SD/SDR 11/4/10 HEAT20844

                           IF ((I+650000)>DT)

                               QUIT 

 +18      ;AG*7.1*2 IM21608

                           IF $DATA(^AUPNPAT(J,41,DUZ(2)))

                               IF $DATA(^DPT(J,0))

                                   IF '$PIECE($GET(^DPT(J,.35)),"^",1)

                                       SET NAME=$PIECE($GET(^DPT(J,0)),U)

                                       SET ^TMP($JOB,NAME)=J

                       End DoDot:2

 +19      ;IHS/OIT/NKD AG*7.1*14 END NEW CODE

               End DoDot:1

 +20       IF $DATA(AGQIO)

               FOR AGZ("I")=1:1

                   SET IOP=AGQIO

                   DO ^%ZIS

                   IF 'POP

                       QUIT 

 +21       SET AG("LOC")=$PIECE(^DIC(4,DUZ(2),0),U)

           SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)

           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

 +22       KILL AG("LOC"),AG("USR")

           USE IO

 +23       DO LINES^AG

           DO NOW^AG

 +24       SET X="Report date: "_AGTIME

           DO CTR^AG

           SET AGTIME=X

           DO HDR

 +25      ;MAIN LOOP IM21608

 +26       KILL DUOUT,DFOUT,DTOUT

 +27       SET NAME=""

 +28       FOR 

               SET NAME=$ORDER(^TMP($JOB,NAME))

               IF NAME=""

                   QUIT 

               Begin DoDot:1

 +29               SET DFN=$GET(^TMP($JOB,NAME))

 +30               SET AGRRESW="N"

 +31               SET MCDREC=""

 +32               SET PRVTREC=0

 +33               DO PRINT

 +34               IF $Y>AGBM

                       DO RTRN^AG

                       IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)

                           QUIT 

                       DO HDR

               End DoDot:1

               IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)

                   QUIT 

 +35       KILL AG("HAT")

 +36       IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)

               QUIT 

 +37      ;F DFN=0:0 S DFN=$O(^TMP($J,DFN)) Q:'DFN  S AGRRESW="N" D PRINT I $Y>AGBM D RTRN^AG G:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) END D HDR

 +38       KILL AG("HAT")

           DO RTRN^AG

           WRITE !!,"Total patients 65 yrs or older: ",AGTOT,!!,"Total patients 65 or older with Medicare: ",AGTOTM,!!,"Total patients 65 or older with Railroad Ret: ",AGTOTR

           DO RTRN^AG

           WRITE $$S^AGVDF("IOF")

END        DO ^%ZISC

           KILL ^TMP($JOB),A,AG,AGIO,AGTIME,AGBM,DA,DIC,DFN,DLOUT,DR,G,AGL,I,J,AG("LKDATA"),AG("LKPRINT"),AGPCC,AGPGPG,AGRRESW,AGTOT,AGTOTM,AGTOTR,AG("USRLOC"),X,Y

           IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +1        QUIT 

PRINT      SET AGTOT=AGTOT+1

           WRITE $PIECE(^DPT(DFN,0),U)," (",$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),")"

 +1        WRITE $SELECT($PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,3)'="":"*",1:"")

 +2        IF $DATA(^DPT(DFN,.13))

               SET AGPHONE=$PIECE(^(.13),U)

               SET AGPHONE=$SELECT($LENGTH(AGPHONE)=10:$EXTRACT(AGPHONE,1,3)_"-"_$EXTRACT(AGPHONE,4,6)_"-"_$EXTRACT(AGPHONE,7,10),$LENGTH(AGPHONE)=7:$EXTRACT(AGPHONE,1,3)_"-"_$EXTRACT(AGPHONE,4,7),1:AGPHONE)

               WRITE ?35,AGPHONE

               KILL AGPHONE

 +3       ;IHS/OIT/NKD AG*7.1*14 - START OLD CODE

 +4       ;MCR G:'$D(^AUPNMCR(DFN,0)) RRE1 S AGMCRNO=$P(^AUPNMCR(DFN,0),U,3) S:$L(AGMCRNO)=9 AGMCRNO=$E(AGMCRNO,1,3)_"-"_$E(AGMCRNO,4,5)_"-"_$E(AGMCRNO,6,9) W ?49,"M=",AGMCRNO,"-"

 +5       ;W:(AGMCRNO)="" ?49,"NO NUMBER " W:$P(^AUPNMCR(DFN,0),U,4)]"" $P(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0),U) S AGTOTM=AGTOTM+1 K AGMCRNO G SSN

 +6       ;IHS/OIT/NKD AG*7.1*14 - END OLD CODE - START NEW CODE

MCR       ;

 +1        IF '$DATA(^AUPNMCR(DFN,0))

               GOTO RRE1

 +2        SET AGMCRNO=$$GETMCR^AGUTL(DFN)

           SET AGISMBI=$$ISMBI^AGUTL(AGMCRNO)

 +3        IF 'AGISMBI

               IF AGISMBI["MCR"

                   SET AGMCRNO=$EXTRACT(AGMCRNO,1,3)_"-"_$EXTRACT(AGMCRNO,4,5)_"-"_$EXTRACT(AGMCRNO,6,9)_"-"_$EXTRACT(AGMCRNO,10,11)

 +4        WRITE ?49,$SELECT($LENGTH(AGMCRNO):"M="_AGMCRNO,1:"NO NUMBER ")

 +5        SET AGTOTM=AGTOTM+1

           KILL AGMCRNO,AGISMBI

           GOTO SSN

 +6       ;IHS/OIT/NKD AG*7.1*14 - END NEW CODE

RRE1       IF '$DATA(^AUPNMCR(DFN,0))

               IF $DATA(^AUPNRRE(DFN,0))

                   DO WRRE

                   SET AGRRESW="Y"

SSN       ;S DIC=2,DR=.09,DA=DFN D ^AGDICLK I $D(AG("LKDATA")) S:$L(AG("LKDATA"))=9 AG("LKDATA")=$E(AG("LKDATA"),1,3)_"-"_$E(AG("LKDATA"),4,5)_"-"_$E(AG("LKDATA"),6,99) W ?67,AG("LKDATA")

 +1       ;IHS/SD/TPF AG*7.1*4

           WRITE ?67,$$GET1^DIQ(9000001,DFN_",",1107.3)

 +2        IF '$DATA(^DPT(DFN,.11))

               GOTO CKRRE

 +3        SET AGA=^DPT(DFN,.11)

           IF $PIECE(AGA,U)]""

               WRITE !?10,$PIECE(AGA,U)

           SET AG("ADDR")=$PIECE(AGA,U,4)_" "

           IF $PIECE(AGA,U,5)]""

               IF $DATA(^DIC(5,$PIECE(AGA,U,5),0))

                   SET AG("ADDR")=AG("ADDR")_$PIECE(^(0),U,2)_" "

                   GOTO RRE

CKRRE      IF $DATA(^AUPNRRE(DFN,0))

               IF AGRRESW'="Y"

                   WRITE !

RRE        IF '$DATA(^AUPNRRE(DFN,0))!(AGRRESW="Y")

               GOTO ADDR1

           DO WRRE

ADDR1      IF $DATA(^DPT(DFN,.11))

               SET AG("ADDR")=AG("ADDR")_$PIECE(AGA,U,6)

               IF AG("ADDR")]""

                   WRITE !?10,AG("ADDR")

 +1        DO PMCNM

           DO RRENM

           WRITE !,AG("-"),!

 +2        QUIT 

HDR        SET AGPGPG=AGPGPG+1

           WRITE $$S^AGVDF("IOF"),!,AG("USRLOC"),?70,"page ",AGPGPG,!?26,"PATIENTS 65 YRS OLD AND OLDER",!,AGTIME,!!?51,"MEDICARE(M)",?69,"SOCIAL",!,"NAME (CHART #)",?35,"HOME PHONE",?51,"RAILROAD(R)",?66,"SECURITY NO.",!,AG("="),!

 +1        QUIT 

 +2       ;WRRE S AGRRNO=$P(^AUPNRRE(DFN,0),U,4) S:$L(AGRRNO)=9 AGRRNO=$E(AGRRNO,1,3)_"-"_$E(AGRRNO,4,5)_"-"_$E(AGRRNO,6,9) W ?49,"R=" W:$P(^AUPNRRE(DFN,0),U,3) $P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U),"-" W AGRRNO S AGTOTR=AGTOTR+1 K AGRRNO  ;IHS/OIT/NK

D AG*7.1*14

 +3       ;IHS/OIT/NKD AG*7.1*14 - START NEW CODE

WRRE      ;

 +1        SET AGRRNO=$$GETRRE^AGUTL(DFN)

           SET AGISMBI=$$ISMBI^AGUTL(AGRRNO)

 +2        IF 'AGISMBI

               IF AGISMBI["RRE"

                   SET AGRRNO=$SELECT($LENGTH(AGRRNO)>9:$EXTRACT(AGRRNO,1,$LENGTH(AGRRNO)-9)_"-",1:"")_$EXTRACT(AGRRNO,$LENGTH(AGRRNO)-8,$LENGTH(AGRRNO)-6)_"-"_$EXTRACT(AGRRNO,$LENGTH(AGRRNO)-5,$LENGTH(AGRRNO)-4)_"-"_$EXTRACT(AGRRNO,$LENGTH(AGRRNO)-3,$LEN

GTH(AGRRNO))

 +3        WRITE ?49,$SELECT($LENGTH(AGRRNO):"R="_AGRRNO,1:"NO NUMBER ")

 +4        SET AGTOTR=AGTOTR+1

           KILL AGRRNO,AGISMBI

 +5        QUIT 

 +6       ;IHS/OIT/NKD AG*7.1*14 - END NEW CODE

PMCNM      KILL AGMCRNM

           IF $DATA(^AUPNMCR(DFN,0))

               IF $DATA(^AUPNMCR(DFN,21))

                   SET AGMCRNM=$PIECE(^AUPNMCR(DFN,21),U)

                   IF AGMCRNM]""

                       WRITE !,"(MCR) ",AGMCRNM

                   KILL AGMCRNM

 +1        QUIT 

RRENM      KILL AGRRNM

           IF $DATA(^AUPNRRE(DFN,0))

               IF $DATA(^AUPNRRE(DFN,21))

                   SET AGRRNM=$PIECE(^AUPNRRE(DFN,21),U)

                   IF AGRRNM]""

                       WRITE !,"(RR)  ",AGRRNM

                   KILL AGRRNM

 +1        QUIT