AGFACE11 ; IHS/ASDS/EFG - FACE SHEET (ADDITIONAL INFORMATION) ;
;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005
;Q:$G(AGOPT(13))'="Y"!'$D(^AUPNPAT(DFN,13,1))
I $G(AGOPT(13))'="Y"!'$D(^AUPNPAT(DFN,13,1)) D HIST Q ;IHS/SD/TPF BAR*7.1*4
W !,$G(AG("-")),!,"ADDITIONAL REGISTRATION INFORMATION:"
;G FIRST:$E($G(AGOPT(21)),1,1)="F"!($E($G(AGOPT(21)),1,1)="f")
;G LAST:$E($G(AGOPT(21)),1,1)="L"!($E($G(AGOPT(21)),1,1)="l")
;G ALL:$G(AGOPT(21))="A"
D FIRST:$E($G(AGOPT(21)),1,1)="F"!($E($G(AGOPT(21)),1,1)="f")
D LAST:$E($G(AGOPT(21)),1,1)="L"!($E($G(AGOPT(21)),1,1)="l")
D ALL:$G(AGOPT(21))="A"
;IHS/SD/TPF BAR*7.1*4 HISTORICAL ADDRESSES
;IF PARAM = 0, PRINT NOTHING
HIST ;EP -
I $$GET1^DIQ(9009061,DUZ(2)_",",602,"I") D
.D ADDRHIST ;AG*7.1*4
.D EMALHIST ;AG*7.1*4
Q:$G(AGOPT(21))=0
Q
LAST ;PRINT THE LAST # LINES
S AG=$O(^AUPNPAT(DFN,13,""),-1)
Q:'+AG
S AG=AG-($E($G(AGOPT(21)),2,4))
;IF THE REG PARAMETER IS GREATER THAN THE NUMBER
;OF RECORDS IN NODE 13, PRINT THEM ALL
I AG<1 G ALL
;IF THE PARAM IS LESS THAN THE NUMBER OF RECORDS
;IN NODE 13, PRINT THE NUMBER OF LINES REQUESTED.
F S AG=$O(^AUPNPAT(DFN,13,AG)) Q:'AG D
. W !?5,AG,"). ",$G(^AUPNPAT(DFN,13,AG,0))
Q
FIRST ;PRINT THE FIRST # LINES
S AG=0
F S AG=$O(^AUPNPAT(DFN,13,AG)) Q:'AG!(AG>($E($G(AGOPT(21)),2,4))) D
. W !?5,AG,"). ",$G(^AUPNPAT(DFN,13,AG,0))
Q
ALL ;THIS CODE PRINTS ALL LINES
F AG=0:0 S AG=$O(^AUPNPAT(DFN,13,AG)) Q:'AG W !?5,AG,"). ",$G(^AUPNPAT(DFN,13,AG,0))
Q
;
;BEGIN NEW CODE FOR AG*7.1*4 HISTORICAL ADDRESSES
ADDRHIST ;EP - PRINT PREVIOUS MAIL ADRESSES
;BEGIN NEW CODE FOR HISTORICAL MAIL ADDRESSES
N HISTLIM,HISTREC,IENS
S HISTLIM=$$GET1^DIQ(9009061,DUZ(2)_",",601,"I")
W !!,AG("=")
W !,"HISTORICAL ADDRESS(S):"
S HISTREC=0
F CNT=1:1 S HISTREC=$O(^AUPNPAT(DFN,83,HISTREC)) Q:'HISTREC!(CNT>HISTLIM) D
.S IENS=HISTREC_","_DFN_","
.W:$$GET1^DIQ(9000001.83,IENS,.02)'="" !?9,$$GET1^DIQ(9000001.83,IENS,.02)
.W:$$GET1^DIQ(9000001.83,IENS,.03)'="" !?9,$$GET1^DIQ(9000001.83,IENS,.03)
.W:$$GET1^DIQ(9000001.83,IENS,.04)'="" !?9,$$GET1^DIQ(9000001.83,IENS,.04)
.W !?9,$$GET1^DIQ(9000001.83,IENS,.05)_", "
.W $$GET1^DIQ(9000001.83,IENS,.06)
.W " ",$$GET1^DIQ(9000001.83,IENS,.07)
.W !?9,$$GET1^DIQ(9000001.83,IENS,.08)
;END NEW CODE
Q
EMALHIST ;EP - PRINT HISTORICAL EMAIL ADDRESSES
N HISTLIM,HISTREC,IENS
S HISTLIM=$$GET1^DIQ(9009061,DUZ(2)_",",601,"I")
W !!,AG("=")
W !,"HISTORICAL EMAIL ADDRESS(S):"
S HISTREC=0
F CNT=1:1 S HISTREC=$O(^AUPNPAT(DFN,82,HISTREC)) Q:'HISTREC!(CNT>HISTLIM) D
.S IENS=HISTREC_","_DFN_","
.W !?9,$$GET1^DIQ(9000001.82,IENS,.02)
Q
AGFACE11 ; IHS/ASDS/EFG - FACE SHEET (ADDITIONAL INFORMATION) ;
+1 ;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005
+2 ;Q:$G(AGOPT(13))'="Y"!'$D(^AUPNPAT(DFN,13,1))
+3 ;IHS/SD/TPF BAR*7.1*4
IF $GET(AGOPT(13))'="Y"!'$DATA(^AUPNPAT(DFN,13,1))
DO HIST
QUIT
+4 WRITE !,$GET(AG("-")),!,"ADDITIONAL REGISTRATION INFORMATION:"
+5 ;G FIRST:$E($G(AGOPT(21)),1,1)="F"!($E($G(AGOPT(21)),1,1)="f")
+6 ;G LAST:$E($G(AGOPT(21)),1,1)="L"!($E($G(AGOPT(21)),1,1)="l")
+7 ;G ALL:$G(AGOPT(21))="A"
+8 IF $EXTRACT($GET(AGOPT(21)),1,1)="F"!($EXTRACT($GET(AGOPT(21)),1,1)="f")
DO FIRST
+9 IF $EXTRACT($GET(AGOPT(21)),1,1)="L"!($EXTRACT($GET(AGOPT(21)),1,1)="l")
DO LAST
+10 IF $GET(AGOPT(21))="A"
DO ALL
+11 ;IHS/SD/TPF BAR*7.1*4 HISTORICAL ADDRESSES
+12 ;IF PARAM = 0, PRINT NOTHING
HIST ;EP -
+1 IF $$GET1^DIQ(9009061,DUZ(2)_",",602,"I")
Begin DoDot:1
+2 ;AG*7.1*4
DO ADDRHIST
+3 ;AG*7.1*4
DO EMALHIST
End DoDot:1
+4 IF $GET(AGOPT(21))=0
QUIT
+5 QUIT
LAST ;PRINT THE LAST # LINES
+1 SET AG=$ORDER(^AUPNPAT(DFN,13,""),-1)
+2 IF '+AG
QUIT
+3 SET AG=AG-($EXTRACT($GET(AGOPT(21)),2,4))
+4 ;IF THE REG PARAMETER IS GREATER THAN THE NUMBER
+5 ;OF RECORDS IN NODE 13, PRINT THEM ALL
+6 IF AG<1
GOTO ALL
+7 ;IF THE PARAM IS LESS THAN THE NUMBER OF RECORDS
+8 ;IN NODE 13, PRINT THE NUMBER OF LINES REQUESTED.
+9 FOR
SET AG=$ORDER(^AUPNPAT(DFN,13,AG))
IF 'AG
QUIT
Begin DoDot:1
+10 WRITE !?5,AG,"). ",$GET(^AUPNPAT(DFN,13,AG,0))
End DoDot:1
+11 QUIT
FIRST ;PRINT THE FIRST # LINES
+1 SET AG=0
+2 FOR
SET AG=$ORDER(^AUPNPAT(DFN,13,AG))
IF 'AG!(AG>($EXTRACT($GET(AGOPT(21)),2,4)))
QUIT
Begin DoDot:1
+3 WRITE !?5,AG,"). ",$GET(^AUPNPAT(DFN,13,AG,0))
End DoDot:1
+4 QUIT
ALL ;THIS CODE PRINTS ALL LINES
+1 FOR AG=0:0
SET AG=$ORDER(^AUPNPAT(DFN,13,AG))
IF 'AG
QUIT
WRITE !?5,AG,"). ",$GET(^AUPNPAT(DFN,13,AG,0))
+2 QUIT
+3 ;
+4 ;BEGIN NEW CODE FOR AG*7.1*4 HISTORICAL ADDRESSES
ADDRHIST ;EP - PRINT PREVIOUS MAIL ADRESSES
+1 ;BEGIN NEW CODE FOR HISTORICAL MAIL ADDRESSES
+2 NEW HISTLIM,HISTREC,IENS
+3 SET HISTLIM=$$GET1^DIQ(9009061,DUZ(2)_",",601,"I")
+4 WRITE !!,AG("=")
+5 WRITE !,"HISTORICAL ADDRESS(S):"
+6 SET HISTREC=0
+7 FOR CNT=1:1
SET HISTREC=$ORDER(^AUPNPAT(DFN,83,HISTREC))
IF 'HISTREC!(CNT>HISTLIM)
QUIT
Begin DoDot:1
+8 SET IENS=HISTREC_","_DFN_","
+9 IF $$GET1^DIQ(9000001.83,IENS,.02)'=""
WRITE !?9,$$GET1^DIQ(9000001.83,IENS,.02)
+10 IF $$GET1^DIQ(9000001.83,IENS,.03)'=""
WRITE !?9,$$GET1^DIQ(9000001.83,IENS,.03)
+11 IF $$GET1^DIQ(9000001.83,IENS,.04)'=""
WRITE !?9,$$GET1^DIQ(9000001.83,IENS,.04)
+12 WRITE !?9,$$GET1^DIQ(9000001.83,IENS,.05)_", "
+13 WRITE $$GET1^DIQ(9000001.83,IENS,.06)
+14 WRITE " ",$$GET1^DIQ(9000001.83,IENS,.07)
+15 WRITE !?9,$$GET1^DIQ(9000001.83,IENS,.08)
End DoDot:1
+16 ;END NEW CODE
+17 QUIT
EMALHIST ;EP - PRINT HISTORICAL EMAIL ADDRESSES
+1 NEW HISTLIM,HISTREC,IENS
+2 SET HISTLIM=$$GET1^DIQ(9009061,DUZ(2)_",",601,"I")
+3 WRITE !!,AG("=")
+4 WRITE !,"HISTORICAL EMAIL ADDRESS(S):"
+5 SET HISTREC=0
+6 FOR CNT=1:1
SET HISTREC=$ORDER(^AUPNPAT(DFN,82,HISTREC))
IF 'HISTREC!(CNT>HISTLIM)
QUIT
Begin DoDot:1
+7 SET IENS=HISTREC_","_DFN_","
+8 WRITE !?9,$$GET1^DIQ(9000001.82,IENS,.02)
End DoDot:1
+9 QUIT
