DGRP1 ;ALB/MRL,ERC,BAJ - DEMOGRAPHIC DATA ; 8/15/08 11:30am
;;5.3;PIMS;**109,161,506,244,546,570,629,638,649,700,653,688,1015,1016**;JUN 30, 2012;Build 20
;
EN ;
S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.122,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005
N SSNV D GETSTAT(.SSNV)
W ! S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV W SSNV
W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
;add Pseuso SSN Reason - DG*5.3*653, ERC
I $P(DGRP(0),U,9)["P" D
. N DGSPACE
. S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
. S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
. I $P(DGRP(0),U,9)["P" D
. . N DGREAS D SSNREAS(.DGREAS)
. . Q:$G(DGREAS)']""
. . W DGREAS
D GETNCAL ;Display name component, sex, and alias information
S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: "
W !?9
S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
; loop through DGA array beginning with DGA(2) and print data at ?9 (odds) and ?48 (evens)
S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?9 W:'(I#2) ?48 W DGA(I)
D COUNTY(.DGRP) ; print County if applicable
W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
;
; *** Additional displays added for Pre-Registration
I $G(DGPRFLG)=1 D
. W !
. N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1
. I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1 I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2)
. W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
. I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1 S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2)
. W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
. I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1 S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2)
. W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
. I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1 S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2)
. W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
. ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
. I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI D
.. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
.. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
;
G ^DGRPP
;
GETNCAL ;Get name component values
N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
;Get alias values
S DGA=0 F DGI=1:1:5 D Q:'$D(DGALIAS(DGI))
A2 .S DGA=$O(^DPT(DFN,.01,DGA))
.I 'DGA D:DGI=1 Q
..S DGALIAS(DGI)="< No alias entries on file >" Q
.I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
.S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
.S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
.I $L(DGX) D
..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
..; BAJ DG*5.2*700 retrofit 06/22/06
..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
..S $E(DGALIAS(DGI),20)=DGX Q
.S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
.Q
;Display name component, sex, multiple birth indicator and alias data
F DGI=1:1:6 D
.W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:28,1:27))
.; BAJ DG*5.3*700 retrofit 06/22/06
.I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV
.I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV
.I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
.I DGI>1 W ?47,$G(DGALIAS(DGI-1))
.Q
Q
GETSTAT(SSNV) ;get SSN VERIFIED STATUS DG*5.3*688 BAJ 11/22/2005
N T
S T=$P($G(^DPT(DFN,"SSN")),"^",2)
S SSNV=$S(T=2:"INVALID",T=4:"VERIFIED",1:"")
Q
;
SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
S DGREAS=$P(DGRP("SSN"),U)
I $G(DGREAS)']"" Q
S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
Q
COUNTY(DGRP) ;retrieve and print County info if a US address
N DGCC,CNODE,FNODE,FPCE,FILE,IEN,CNTRY,PLINE
; data location of Permanent Address County info
S FNODE=.11,FPCE=10,DGCC=""
; only print county info if it's a US address
S IEN=$P(DGRP(FNODE),U,FPCE) I '$$FORIEN^DGADDUTL(IEN) D
. S DGCC=$S($D(^DIC(5,+$P(DGRP(FNODE),U,5),1,+$P(DGRP(FNODE),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)
S PLINE=$S(DGCC]"":"County: "_DGCC,1:"")
W !?3,PLINE
S DGCC=""
; data location of Temporary address County info
S CNODE=.121,FNODE=.122,FPCE=3
; only print county info if it's a US address
S IEN=$P(DGRP(FNODE),U,FPCE) I '$$FORIEN^DGADDUTL(IEN) D
. S DGCC=$S($P(DGRP(CNODE),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(CNODE),U,5),1,+$P(DGRP(CNODE),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)
S PLINE=$S(DGCC]"":"County: "_DGCC,1:"")
W ?43,PLINE
Q
;
DGRP1 ;ALB/MRL,ERC,BAJ - DEMOGRAPHIC DATA ; 8/15/08 11:30am
+1 ;;5.3;PIMS;**109,161,506,244,546,570,629,638,649,700,653,688,1015,1016**;JUN 30, 2012;Build 20
+2 ;
EN ;
+1 SET (DGRPS,DGRPW)=1
DO H^DGRPU
FOR I=0,.11,.121,.122,.13,.15,.24,57,"SSN"
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+2 IF $PIECE(DGRP(.15),"^",2)]""
SET Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!"
SET DGRPCM=1
DO WW^DGRPV
SET DGRPCM=0
+3 ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
+4 ;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005
+5 NEW SSNV
DO GETSTAT(.SSNV)
+6 WRITE !
SET Z=1
DO WW^DGRPV
WRITE " Name: "
SET Z=$PIECE(DGRP(0),"^",1)
SET Z1=31
DO WW1^DGRPV
+7 ;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
+8 WRITE "SS: "
SET X=$PIECE(DGRP(0),"^",9)
SET Z=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10)
SET Z1=13
DO WW1^DGRPV
WRITE SSNV
+9 WRITE !
SET Z=""
SET Z1=8
DO WW1^DGRPV
SET Y=$PIECE(DGRP(0),"^",3)
XECUTE ^DD("DD")
WRITE "DOB: ",Y
+10 ;add Pseuso SSN Reason - DG*5.3*653, ERC
+11 IF $PIECE(DGRP(0),U,9)["P"
Begin DoDot:1
+12 NEW DGSPACE
+13 ;adjust to maintain spacing on screen
SET DGSPACE=10-$LENGTH(Y)
+14 SET Z1=12+DGSPACE
DO WW1^DGRPV
WRITE "PSSN Reason: "
+15 IF $PIECE(DGRP(0),U,9)["P"
Begin DoDot:2
+16 NEW DGREAS
DO SSNREAS(.DGREAS)
+17 IF $GET(DGREAS)']""
QUIT
+18 WRITE DGREAS
End DoDot:2
End DoDot:1
+19 ;Display name component, sex, and alias information
DO GETNCAL
+20 SET Z=3
SET DGRPX=DGRP(0)
DO WW^DGRPV
WRITE " Remarks: ",$SELECT($PIECE(DGRPX,"^",10)]"":$EXTRACT($PIECE(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT")
SET DGAD=.11
SET (DGA1,DGA2)=1
DO A^DGRPU
IF $PIECE(DGRP(.121),"^",9)="Y"
SET DGAD=.121
SET DGA1=1
SET DGA2=2
DO A^DGRPU
+21 SET Z=4
DO WW^DGRPV
WRITE " Permanent Address: "
SET Z=" "
SET Z1=17
+22 DO WW1^DGRPV
SET Z=5
SET DGRPW=0
DO WW^DGRPV
WRITE " Temporary Address: "
+23 WRITE !?9
+24 SET Z1=39
SET Z=$SELECT($DATA(DGA(1)):DGA(1),1:"NONE ON FILE")
DO WW1^DGRPV
WRITE $SELECT($DATA(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
+25 ; loop through DGA array beginning with DGA(2) and print data at ?9 (odds) and ?48 (evens)
+26 SET I=2
FOR I1=0:0
SET I=$ORDER(DGA(I))
IF I=""
QUIT
IF (I#2)!($X>50)
WRITE !?9
IF '(I#2)
WRITE ?48
WRITE DGA(I)
+27 ; print County if applicable
DO COUNTY(.DGRP)
+28 WRITE !?4,"Phone: ",$SELECT($PIECE(DGRP(.13),U,1)]"":$PIECE(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$SELECT($PIECE(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$PIECE(DGRP(.121),U,10)]"":$PIECE(DGRP(.121),U,10),1:DGRPU)
+29 SET X="NOT APPLICABLE"
IF $PIECE(DGRP(.121),U,9)="Y"
SET Y=$PIECE(DGRP(.121),U,7)
IF Y]""
XECUTE ^DD("DD")
SET X=$SELECT(Y]"":Y,1:DGRPU)_"-"
SET Y=$PIECE(DGRP(.121),U,8)
IF Y]""
XECUTE ^DD("DD")
SET X=X_$SELECT(Y]"":Y,1:DGRPU)
+30 WRITE !?3,"Office: ",$SELECT($PIECE(DGRP(.13),U,2)]"":$PIECE(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
+31 WRITE !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$PIECE(DGRP(.11),U,16))
+32 ;
+33 ; *** Additional displays added for Pre-Registration
+34 IF $GET(DGPRFLG)=1
Begin DoDot:1
+35 WRITE !
+36 NEW I,MIS1,X,X1,SA1,TP1,X2,X3,ES1
+37 IF $DATA(^DIA(2,"B",DFN))
SET X=""
FOR I=1:1
SET X=$ORDER(^DIA(2,"B",DFN,X))
IF X<1
QUIT
IF $PIECE(^DIA(2,X,0),U,3)=.05
SET MIS1=$PIECE(^DIA(2,X,0),U,2)
+38 IF $DATA(MIS1)>0
WRITE !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
+39 IF $DATA(^DIA(2,"B",DFN))
SET X1=""
FOR I=1:1
SET X1=$ORDER(^DIA(2,"B",DFN,X1))
IF X1<1
QUIT
IF $PIECE(^DIA(2,X1,0),U,3)=.111
SET SA1=$PIECE(^DIA(2,X1,0),U,2)
+40 IF $DATA(SA1)>0
WRITE !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
+41 IF $DATA(^DIA(2,"B",DFN))
SET X2=""
FOR I=1:1
SET X2=$ORDER(^DIA(2,"B",DFN,X2))
IF X2<1
QUIT
IF $PIECE(^DIA(2,X2,0),U,3)=.131
SET TP1=$PIECE(^DIA(2,X2,0),U,2)
+42 IF $DATA(TP1)>0
WRITE !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
+43 IF $DATA(^DIA(2,"B",DFN))
SET X3=""
FOR I=1:1
SET X3=$ORDER(^DIA(2,"B",DFN,X3))
IF X3<1
QUIT
IF $PIECE(^DIA(2,X3,0),U,3)=.31115
SET ES1=$PIECE(^DIA(2,X3,0),U,2)
+44 IF $DATA(ES1)>0
WRITE !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
+45 ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
+46 IF $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11")
FOR DGI=0:0
SET DGI=$ORDER(DGDATA("IBBAPI","INSUR",DGI))
IF 'DGI
QUIT
Begin DoDot:2
+47 WRITE !," [INSURANCE:] ",$PIECE(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
+48 WRITE " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
End DoDot:2
End DoDot:1
+49 ;
+50 GOTO ^DGRPP
+51 ;
GETNCAL ;Get name component values
+1 NEW DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
+2 SET DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
+3 SET DGCOMP=+$GET(^DPT(DFN,"NAME"))_","
+4 IF DGCOMP
DO GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
+5 ;Get alias values
+6 SET DGA=0
FOR DGI=1:1:5
Begin DoDot:1
A2 SET DGA=$ORDER(^DPT(DFN,.01,DGA))
+1 IF 'DGA
IF DGI=1
Begin DoDot:2
+2 SET DGALIAS(DGI)="< No alias entries on file >"
QUIT
End DoDot:2
QUIT
+3 IF DGI=5
SET DGALIAS(DGI)="< More alias entries on file >"
QUIT
+4 SET DGX=$GET(^DPT(DFN,.01,DGA,0))
IF '$LENGTH(DGX)
GOTO A2
+5 SET DGALIAS(DGI)=$PIECE(DGX,U)
SET DGX=$PIECE(DGX,U,2)
+6 IF $LENGTH(DGX)
Begin DoDot:2
+7 SET DGX=" "_$EXTRACT(DGX,1,3)_"-"_$EXTRACT(DGX,4,5)_"-"_$EXTRACT(DGX,6,9)
+8 ; BAJ DG*5.2*700 retrofit 06/22/06
+9 SET DGALIAS(DGI)=$EXTRACT(DGALIAS(DGI),1,19)
+10 SET $EXTRACT(DGALIAS(DGI),20)=DGX
QUIT
End DoDot:2
+11 SET DGALIAS(DGI)=$EXTRACT(DGALIAS(DGI),1,32)
+12 QUIT
End DoDot:1
IF '$DATA(DGALIAS(DGI))
QUIT
+13 ;Display name component, sex, multiple birth indicator and alias data
+14 FOR DGI=1:1:6
Begin DoDot:1
+15 WRITE !?5,$JUSTIFY($PIECE(DGNC,U,DGI),6),": ",$EXTRACT($GET(DGCOMP(20,DGCOMP,DGI)),1,$SELECT(DGI=1:28,1:27))
+16 ; BAJ DG*5.3*700 retrofit 06/22/06
+17 IF DGI=1
SET (Z,DGRPW)=1
WRITE ?43,"Sex: "
SET X=$PIECE(DGRP(0),"^",2)
SET Z=$SELECT(X="M":"MALE",X="F":"FEMALE",1:DGRPU)
SET Z1=3
DO WW1^DGRPV
+18 IF DGI=1
SET (Z,DGRPW)=1
WRITE ?56,"MBI: "
SET X=$PIECE($GET(^DPT(DFN,"MPIMB")),U)
SET Z=$SELECT(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU)
SET Z1=16
DO WW1^DGRPV
+19 IF DGI=2
SET DGRPW=0
SET Z=2
WRITE ?37
DO WW^DGRPV
WRITE " Alias: "
+20 IF DGI>1
WRITE ?47,$GET(DGALIAS(DGI-1))
+21 QUIT
End DoDot:1
+22 QUIT
GETSTAT(SSNV) ;get SSN VERIFIED STATUS DG*5.3*688 BAJ 11/22/2005
+1 NEW T
+2 SET T=$PIECE($GET(^DPT(DFN,"SSN")),"^",2)
+3 SET SSNV=$SELECT(T=2:"INVALID",T=4:"VERIFIED",1:"")
+4 QUIT
+5 ;
SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
+1 SET DGREAS=$PIECE(DGRP("SSN"),U)
+2 IF $GET(DGREAS)']""
QUIT
+3 SET DGREAS=$SELECT(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
+4 QUIT
COUNTY(DGRP) ;retrieve and print County info if a US address
+1 NEW DGCC,CNODE,FNODE,FPCE,FILE,IEN,CNTRY,PLINE
+2 ; data location of Permanent Address County info
+3 SET FNODE=.11
SET FPCE=10
SET DGCC=""
+4 ; only print county info if it's a US address
+5 SET IEN=$PIECE(DGRP(FNODE),U,FPCE)
IF '$$FORIEN^DGADDUTL(IEN)
Begin DoDot:1
+6 SET DGCC=$SELECT($DATA(^DIC(5,+$PIECE(DGRP(FNODE),U,5),1,+$PIECE(DGRP(FNODE),U,7),0)):$EXTRACT($PIECE(^(0),U,1),1,20)_$SELECT($PIECE(^(0),U,3)]"":" ("_$PIECE(^(0),U,3)_")",1:""),1:DGRPU)
End DoDot:1
+7 SET PLINE=$SELECT(DGCC]"":"County: "_DGCC,1:"")
+8 WRITE !?3,PLINE
+9 SET DGCC=""
+10 ; data location of Temporary address County info
+11 SET CNODE=.121
SET FNODE=.122
SET FPCE=3
+12 ; only print county info if it's a US address
+13 SET IEN=$PIECE(DGRP(FNODE),U,FPCE)
IF '$$FORIEN^DGADDUTL(IEN)
Begin DoDot:1
+14 SET DGCC=$SELECT($PIECE(DGRP(CNODE),U,9)'="Y":"NOT APPLICABLE",$DATA(^DIC(5,+$PIECE(DGRP(CNODE),U,5),1,+$PIECE(DGRP(CNODE),U,11),0)):$EXTRACT($PIECE(^(0),U,1),1,20)_$SELECT($PIECE(^(0),U,3)]"":" ("_$PIECE(^(0),U,3)_")",1:""),1:DGRPU)
End DoDot:1
+15 SET PLINE=$SELECT(DGCC]"":"County: "_DGCC,1:"")
+16 WRITE ?43,PLINE
+17 QUIT
+18 ;
