Routine: DGRP1

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

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:"")

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 >")

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

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      ;

DGRP1.m