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
