DGRP1 ;ALB/MRL,ERC,BAJ,PWC,JAM,JAM,ARF - DEMOGRAPHIC DATA ;19 Jul 2017 3:02 PM
;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,688,750,851,907,925,941,985,1014,1033,1056**;Aug 13, 1993;Build 18
;
EN ;
; JAM - Patch DG*5.3*941, Reformatting Registration screen 1. New field layout.
;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:"")
N DGRP
S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.13,.15,.24,"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)
S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
; DG*5.3*985; JAM - reformat screen 1 to add group 6 - Preferred Name next to Name field and move SSN and Pseudo Reason down
S DGRPW=0,Z1="",Z=6 D WW^DGRPV S Z=$P(DGRP(.24),"^",5),Z1=1 S Z=$S(Z]"":" Preferred Name: "_$E(Z,1,17),1:" Preferred Name: Not Answered") D WW1^DGRPV
S DGRPW=1
W ! S Z="",Z1=6 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
W ! S Z="",Z1=7 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
;add Pseuso SSN Reason - DG*5.3*653, ERC
I $P(DGRP(0),U,9)["P" D
. N DGSPACE
. S DGSPACE=10-$L(Z) ;adjust to maintain spacing on screen
. S Z=""
. S Z1=14+DGSPACE D WW1^DGRPV W "PSSN Reason: "
. 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) W ! D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT")
;JAM - Patch DG*5.3*941 registration screen changes - remove addresses from screen and Cell/pager/email now in group 3 and Preferred Lang in group 4
S Z=4,DGRPW=1.1 W ! D WW^DGRPV W " Cell Phone: " ;DG*5.3*941
;
;* Output Cell phone
I $P(DGRP(.13),U,4)'="" W ?19,$P(DGRP(.13),U,4)
I $P(DGRP(.13),U,4)="" W ?19,"UNANSWERED"
;
; DG*5.3*985; JAM - Move pager up to same line across from cell phone
;* Output Pager
W ?47,"Pager #: "
I $P(DGRP(.13),U,5)'="" W ?56,$P(DGRP(.13),U,5)
I $P(DGRP(.13),U,5)="" W ?56,"UNANSWERED"
;
;* Output Email Address
W !," Email Address: "
I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3)
I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED"
;
LANGUAGE ;Get language data *///*
S DGLANGDT=9999999,(DGPRFLAN,DGLANG0,DGRP(1),DGRP(2))=""
S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1)
I DGLANGDT="" G L1
S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0)) I DGLANGDA="" S DGRP(2)="" G L1
S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2)
S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y
S DGRP(1)=DGLANGDT,DGRP(2)=DGPRFLAN
K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
;
L1 W ! S Z=5,DGRPW=1.1 D WW^DGRPV ;*///* ;DG*5.3*941 - remove extra line feed
;W ?4,"Language Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1)) ;ARF-DG*5.3*1014 Preferred Language prompts
;W !?4,"Preferred Language: ",$S(DGRP(2)="":"UNANSWERED",1:DGRP(2)) ; on to the same line
W " Pref Lang: ",$E($S(DGRP(2)="":"UNANSWERED",1:DGRP(2)),1,34)," Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1))
;
; *** Additional displays added for Pre-Registration
I $G(DGPRFLG)=1 D
. W !
. N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1,ADDRDTTM
. 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)
. S ADDRDTTM=$P($G(^DPT(DFN,.11)),"^",13)
. ;DG*5.3*1056 replaced PERMANENT with MAILING for the following displayed message
. I ADDRDTTM'="" W !," [MAILING ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(ADDRDTTM,"5D")
. 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")
;
W !
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
.; DG*5.3*985; jam - Move fields 2 chars over to the left to align with fields above
.W !?3,$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
.; ob - 10/22/14 added "Birth" on the next line
.I DGI=1 S (Z,DGRPW)=1 W ?37,"Birth Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV ;DG*5.3*907
.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))
;*** display Self-Identified Gender Identity DG*5.3*907
;Get node with SIGI in it already done at EN+1
W !?3,"Self-Identified Gender Identity: "
;**1033, VAMPI-13 (jfw) - Remove Hard-Coded logic and replace with FM call to DD
S X=$P(DGRP(.24),"^",4),Z=$$EXTERNAL^DILFD(2,.024,,X) W $S(Z'="":Z,1:DGRPU)
;,Z=$S(X="M":"MALE",X="F":"FEMALE",X="TM":"TRANSMALE/TRANSMAN/FEMALE-TO-MALE",X="TF":"TRANSFEMALE/TRANSWOMAN/MALE-TO-FEMALE",X="O":"OTHER",X="N":"INDIVIDUAL CHOOSES NOT TO ANSWER",1:DGRPU) W Z ;D WW1^DGRPV
; *** end of change
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP1 7654 printed Apr 09, 2024@21:49:30 Page 2
DGRP1 ;ALB/MRL,ERC,BAJ,PWC,JAM,JAM,ARF - DEMOGRAPHIC DATA ;19 Jul 2017 3:02 PM
+1 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,688,750,851,907,925,941,985,1014,1033,1056**;Aug 13, 1993;Build 18
+2 ;
EN ;
+1 ; JAM - Patch DG*5.3*941, Reformatting Registration screen 1. New field layout.
+2 ;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:"")
+3 NEW DGRP
+4 SET (DGRPS,DGRPW)=1
DO H^DGRPU
FOR I=0,.13,.15,.24,"SSN"
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+5 IF $PIECE(DGRP(.15),"^",2)]""
SET Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!"
SET DGRPCM=1
DO WW^DGRPV
SET DGRPCM=0
+6 ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
+7 ;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005
+8 NEW SSNV
DO GETSTAT(.SSNV)
+9 SET Z=1
DO WW^DGRPV
WRITE " Name: "
SET Z=$PIECE(DGRP(0),"^",1)
SET Z1=31
DO WW1^DGRPV
+10 ; DG*5.3*985; JAM - reformat screen 1 to add group 6 - Preferred Name next to Name field and move SSN and Pseudo Reason down
+11 SET DGRPW=0
SET Z1=""
SET Z=6
DO WW^DGRPV
SET Z=$PIECE(DGRP(.24),"^",5)
SET Z1=1
SET Z=$SELECT(Z]"":" Preferred Name: "_$EXTRACT(Z,1,17),1:" Preferred Name: Not Answered")
DO WW1^DGRPV
+12 SET DGRPW=1
+13 WRITE !
SET Z=""
SET Z1=6
DO WW1^DGRPV
SET Y=$PIECE(DGRP(0),"^",3)
XECUTE ^DD("DD")
WRITE "DOB: ",Y
+14 WRITE !
SET Z=""
SET Z1=7
DO WW1^DGRPV
+15 ;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
+16 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
+17 ;add Pseuso SSN Reason - DG*5.3*653, ERC
+18 IF $PIECE(DGRP(0),U,9)["P"
Begin DoDot:1
+19 NEW DGSPACE
+20 ;adjust to maintain spacing on screen
SET DGSPACE=10-$LENGTH(Z)
+21 SET Z=""
+22 SET Z1=14+DGSPACE
DO WW1^DGRPV
WRITE "PSSN Reason: "
+23 NEW DGREAS
DO SSNREAS(.DGREAS)
+24 if $GET(DGREAS)']""
QUIT
+25 WRITE DGREAS
End DoDot:1
+26 ;Display name component, sex, and alias information
DO GETNCAL
+27 SET Z=3
SET DGRPX=DGRP(0)
WRITE !
DO WW^DGRPV
WRITE " Remarks: ",$SELECT($PIECE(DGRPX,"^",10)]"":$EXTRACT($PIECE(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT")
+28 ;JAM - Patch DG*5.3*941 registration screen changes - remove addresses from screen and Cell/pager/email now in group 3 and Preferred Lang in group 4
+29 ;DG*5.3*941
SET Z=4
SET DGRPW=1.1
WRITE !
DO WW^DGRPV
WRITE " Cell Phone: "
+30 ;
+31 ;* Output Cell phone
+32 IF $PIECE(DGRP(.13),U,4)'=""
WRITE ?19,$PIECE(DGRP(.13),U,4)
+33 IF $PIECE(DGRP(.13),U,4)=""
WRITE ?19,"UNANSWERED"
+34 ;
+35 ; DG*5.3*985; JAM - Move pager up to same line across from cell phone
+36 ;* Output Pager
+37 WRITE ?47,"Pager #: "
+38 IF $PIECE(DGRP(.13),U,5)'=""
WRITE ?56,$PIECE(DGRP(.13),U,5)
+39 IF $PIECE(DGRP(.13),U,5)=""
WRITE ?56,"UNANSWERED"
+40 ;
+41 ;* Output Email Address
+42 WRITE !," Email Address: "
+43 IF $PIECE(DGRP(.13),U,3)'=""
WRITE ?19,$PIECE(DGRP(.13),U,3)
+44 IF $PIECE(DGRP(.13),U,3)=""
WRITE ?19,"UNANSWERED"
+45 ;
LANGUAGE ;Get language data *///*
+1 SET DGLANGDT=9999999
SET (DGPRFLAN,DGLANG0,DGRP(1),DGRP(2))=""
+2 SET DGLANGDT=$ORDER(^DPT(DFN,.207,"B",DGLANGDT),-1)
+3 IF DGLANGDT=""
GOTO L1
+4 SET DGLANGDA=$ORDER(^DPT(DFN,.207,"B",DGLANGDT,0))
IF DGLANGDA=""
SET DGRP(2)=""
GOTO L1
+5 SET DGLANG0=$GET(^DPT(DFN,.207,DGLANGDA,0))
SET Y=$PIECE(DGLANG0,U)
SET DGPRFLAN=$PIECE(DGLANG0,U,2)
+6 SET Y=DGLANGDT
XECUTE ^DD("DD")
SET DGLANGDT=Y
+7 SET DGRP(1)=DGLANGDT
SET DGRP(2)=DGPRFLAN
+8 KILL DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
+9 ;
L1 ;*///* ;DG*5.3*941 - remove extra line feed
WRITE !
SET Z=5
SET DGRPW=1.1
DO WW^DGRPV
+1 ;W ?4,"Language Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1)) ;ARF-DG*5.3*1014 Preferred Language prompts
+2 ;W !?4,"Preferred Language: ",$S(DGRP(2)="":"UNANSWERED",1:DGRP(2)) ; on to the same line
+3 WRITE " Pref Lang: ",$EXTRACT($SELECT(DGRP(2)="":"UNANSWERED",1:DGRP(2)),1,34)," Date/Time: ",$SELECT(DGRP(1)="":"UNANSWERED",1:DGRP(1))
+4 ;
+5 ; *** Additional displays added for Pre-Registration
+6 IF $GET(DGPRFLG)=1
Begin DoDot:1
+7 WRITE !
+8 NEW I,MIS1,X,X1,SA1,TP1,X2,X3,ES1,ADDRDTTM
+9 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)
+10 if $DATA(MIS1)>0
WRITE !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
+11 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)
+12 if $DATA(SA1)>0
WRITE !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
+13 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)
+14 SET ADDRDTTM=$PIECE($GET(^DPT(DFN,.11)),"^",13)
+15 ;DG*5.3*1056 replaced PERMANENT with MAILING for the following displayed message
+16 IF ADDRDTTM'=""
WRITE !," [MAILING ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(ADDRDTTM,"5D")
+17 if $DATA(TP1)>0
WRITE !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
+18 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)
+19 if $DATA(ES1)>0
WRITE !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
+20 ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
+21 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
+22 WRITE !," [INSURANCE:] ",$PIECE(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
+23 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
+24 ;
+25 WRITE !
+26 GOTO ^DGRPP
+27 ;
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 ; DG*5.3*985; jam - Move fields 2 chars over to the left to align with fields above
+16 WRITE !?3,$JUSTIFY($PIECE(DGNC,U,DGI),6),": ",$EXTRACT($GET(DGCOMP(20,DGCOMP,DGI)),1,$SELECT(DGI=1:28,1:27))
+17 ; BAJ DG*5.3*700 retrofit 06/22/06
+18 ; ob - 10/22/14 added "Birth" on the next line
+19 ;DG*5.3*907
IF DGI=1
SET (Z,DGRPW)=1
WRITE ?37,"Birth Sex: "
SET X=$PIECE(DGRP(0),"^",2)
SET Z=$SELECT(X="M":"MALE",X="F":"FEMALE",1:DGRPU)
SET Z1=3
DO WW1^DGRPV
+20 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
+21 IF DGI=2
SET DGRPW=0
SET Z=2
WRITE ?37
DO WW^DGRPV
WRITE " Alias: "
+22 IF DGI>1
WRITE ?47,$GET(DGALIAS(DGI-1))
End DoDot:1
+23 ;*** display Self-Identified Gender Identity DG*5.3*907
+24 ;Get node with SIGI in it already done at EN+1
+25 WRITE !?3,"Self-Identified Gender Identity: "
+26 ;**1033, VAMPI-13 (jfw) - Remove Hard-Coded logic and replace with FM call to DD
+27 SET X=$PIECE(DGRP(.24),"^",4)
SET Z=$$EXTERNAL^DILFD(2,.024,,X)
WRITE $SELECT(Z'="":Z,1:DGRPU)
+28 ;,Z=$S(X="M":"MALE",X="F":"FEMALE",X="TM":"TRANSMALE/TRANSMAN/FEMALE-TO-MALE",X="TF":"TRANSFEMALE/TRANSWOMAN/MALE-TO-FEMALE",X="O":"OTHER",X="N":"INDIVIDUAL CHOOSES NOT TO ANSWER",1:DGRPU) W Z ;D WW1^DGRPV
+29 ; *** end of change
+30 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
