- 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
