DGRRPSD3 ; ALB/SGG - rtnDGRR PatientServices Demographics Tertiary ;09/30/03 ; Compiled November 4, 2003 12:01:00
;;5.3;Registration;**557**;Aug 13, 1993
;
;
DOC ;<DataSet Name='TertiaryDemographics'
;
;
;
; NAME COMPONENTS
;.092 PLACE OF BIRTH [CITY] (F), [0;11]
;.093 PLACE OF BIRTH [STATE] (P5'), [0;12]
;.096 WHO ENTERED PATIENT (P200'I), [0;15]
; WHO ENTERED PATIENT VPID FROM #200
;.097 DATE ENTERED INTO FILE (D), [0;16]
;.2401 FATHER'S NAME (FX), [.24;1]
;.2402 MOTHER'S NAME (FX), [.24;2]
;.2403 MOTHER'S MAIDEN NAME (FaX), [.24;3]
;.07 OCCUPATION (F), [0;7]
; MULTIPLE BIRTH INDICATOR NEEDS SORTED $P(^DPT(PTID,"MPIMB"),"^").
;
;1 ALIAS (Multiple-2.01), [.01;0]
; .01 ALIAS (MFX), [0;1]
; 1 ALIAS SSN (F), [0;2]
;
GETPSARY(PSARRAY) ;
NEW CNT
SET CNT=$G(CNT)+1,PSARRAY(CNT)="<DataSet Name='TertiaryDemographics'"
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Last^"_$$LAST()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^First^"_$$FIRST()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Middle^"_$$MIDDLE()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Prefix^"_$$PREFIX()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Suffix^"_$$SUFFIX()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Degree^"_$$DEGREE()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^CityOfBirth^"_$$CITYOB()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^StateOfBirth^"_$$STATEOB()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^WhoEnteredPatientVPID^"_$$WHOVPID()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^WhoEnteredPatient^"_$$ENTBYWHO()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^DatePatientEntered^"_$$ENTDATE()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^FathersName^"_$$DADNAME()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^MothersName^"_$$MOMNAME()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^MothersMaidenName^"_$$MADNAME()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Occupation^"_$$OCCUPAT()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^MultipleBirthIndicator^"_$$MULTIBI()
SET CNT=$G(CNT)+1,PSARRAY(CNT)=">"
DO ALISINFO
SET CNT=$G(CNT)+1,PSARRAY(CNT)="</DataSet>"_"^^^1"
QUIT
;
LAST() QUIT $P(GLOB("NAME"),"^",1)
;
FIRST() QUIT $P(GLOB("NAME"),"^",2)
;
MIDDLE() QUIT $P(GLOB("NAME"),"^",3)
;
PREFIX() QUIT $P(GLOB("NAME"),"^",5)
;
SUFFIX() QUIT $P(GLOB("NAME"),"^",4)
;
DEGREE() QUIT $P(GLOB("NAME"),"^",6)
;
CITYOB() QUIT $P(GLOB(0),"^",11)
;
STATEOB() ;
NEW DATA
SET DATA=$P(GLOB(0),"^",12)
IF DATA'="" SET DATA=$P($G(^DIC(5,DATA,0)),"^",2)
QUIT DATA
;
ENTBYWHO() ;
NEW DATA
SET DATA=$P(GLOB(0),"^",15)
IF DATA'="" SET DATA=$P($G(^VA(200,DATA,0)),"^",1)
QUIT DATA
;
WHOVPID() ;
QUIT $$VPID^XUPS($P(GLOB(0),"^",15))
;
ENTDATE() QUIT $P(GLOB(0),"^",16)
;
DADNAME() QUIT $P(GLOB(.24),"^",1)
;
MOMNAME() QUIT $P(GLOB(.24),"^",2)
;
MADNAME() QUIT $P(GLOB(.24),"^",3)
;
OCCUPAT() QUIT $P(GLOB(0),"^",7)
;
MULTIBI() ;
NEW DATA
SET DATA=$P($G(^DPT(PTID,"MPIMB")),"^",1)
SET DATA=$S(DATA="Y":"YES",DATA="N":"NO",1:"")
QUIT DATA
;
ALISINFO ;
NEW ALISCNT,ROWCNT,ALIS,ALISSSN
SET ALISCNT=0,ROWCNT=0
FOR SET ALISCNT=$O(^DPT(PTID,.01,ALISCNT)) QUIT:(ALISCNT<1) DO
.SET ALIS=$P($G(^DPT(PTID,.01,ALISCNT,0)),"^",1)
.SET ALISSSN=$P($G(^DPT(PTID,.01,ALISCNT,0)),"^",2)
.IF +$L(ALIS_ALISSSN) DO
..SET ROWCNT=ROWCNT+1
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="<Alias Row='"_ROWCNT_"'"
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Alias^"_ALIS_"^^ALIAS^"_ROWCNT
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^SSN^"_ALISSSN_"^^ALIAS^"_ROWCNT
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="></Alias>"
IF ROWCNT=0 DO
.SET CNT=$G(CNT)+1,PSARRAY(CNT)="<Alias Row='1' Alias='' SSN=''></Alias>"
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRPSD3 3623 printed Sep 23, 2025@20:33:43 Page 2
DGRRPSD3 ; ALB/SGG - rtnDGRR PatientServices Demographics Tertiary ;09/30/03 ; Compiled November 4, 2003 12:01:00
+1 ;;5.3;Registration;**557**;Aug 13, 1993
+2 ;
+3 ;
DOC ;<DataSet Name='TertiaryDemographics'
+1 ;
+2 ;
+3 ;
+4 ; NAME COMPONENTS
+5 ;.092 PLACE OF BIRTH [CITY] (F), [0;11]
+6 ;.093 PLACE OF BIRTH [STATE] (P5'), [0;12]
+7 ;.096 WHO ENTERED PATIENT (P200'I), [0;15]
+8 ; WHO ENTERED PATIENT VPID FROM #200
+9 ;.097 DATE ENTERED INTO FILE (D), [0;16]
+10 ;.2401 FATHER'S NAME (FX), [.24;1]
+11 ;.2402 MOTHER'S NAME (FX), [.24;2]
+12 ;.2403 MOTHER'S MAIDEN NAME (FaX), [.24;3]
+13 ;.07 OCCUPATION (F), [0;7]
+14 ; MULTIPLE BIRTH INDICATOR NEEDS SORTED $P(^DPT(PTID,"MPIMB"),"^").
+15 ;
+16 ;1 ALIAS (Multiple-2.01), [.01;0]
+17 ; .01 ALIAS (MFX), [0;1]
+18 ; 1 ALIAS SSN (F), [0;2]
+19 ;
GETPSARY(PSARRAY) ;
+1 NEW CNT
+2 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="<DataSet Name='TertiaryDemographics'"
+3 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Last^"_$$LAST()
+4 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^First^"_$$FIRST()
+5 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Middle^"_$$MIDDLE()
+6 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Prefix^"_$$PREFIX()
+7 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Suffix^"_$$SUFFIX()
+8 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Degree^"_$$DEGREE()
+9 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^CityOfBirth^"_$$CITYOB()
+10 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^StateOfBirth^"_$$STATEOB()
+11 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^WhoEnteredPatientVPID^"_$$WHOVPID()
+12 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^WhoEnteredPatient^"_$$ENTBYWHO()
+13 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^DatePatientEntered^"_$$ENTDATE()
+14 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^FathersName^"_$$DADNAME()
+15 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^MothersName^"_$$MOMNAME()
+16 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^MothersMaidenName^"_$$MADNAME()
+17 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Occupation^"_$$OCCUPAT()
+18 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^MultipleBirthIndicator^"_$$MULTIBI()
+19 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)=">"
+20 DO ALISINFO
+21 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="</DataSet>"_"^^^1"
+22 QUIT
+23 ;
LAST() QUIT $PIECE(GLOB("NAME"),"^",1)
+1 ;
FIRST() QUIT $PIECE(GLOB("NAME"),"^",2)
+1 ;
MIDDLE() QUIT $PIECE(GLOB("NAME"),"^",3)
+1 ;
PREFIX() QUIT $PIECE(GLOB("NAME"),"^",5)
+1 ;
SUFFIX() QUIT $PIECE(GLOB("NAME"),"^",4)
+1 ;
DEGREE() QUIT $PIECE(GLOB("NAME"),"^",6)
+1 ;
CITYOB() QUIT $PIECE(GLOB(0),"^",11)
+1 ;
STATEOB() ;
+1 NEW DATA
+2 SET DATA=$PIECE(GLOB(0),"^",12)
+3 IF DATA'=""
SET DATA=$PIECE($GET(^DIC(5,DATA,0)),"^",2)
+4 QUIT DATA
+5 ;
ENTBYWHO() ;
+1 NEW DATA
+2 SET DATA=$PIECE(GLOB(0),"^",15)
+3 IF DATA'=""
SET DATA=$PIECE($GET(^VA(200,DATA,0)),"^",1)
+4 QUIT DATA
+5 ;
WHOVPID() ;
+1 QUIT $$VPID^XUPS($PIECE(GLOB(0),"^",15))
+2 ;
ENTDATE() QUIT $PIECE(GLOB(0),"^",16)
+1 ;
DADNAME() QUIT $PIECE(GLOB(.24),"^",1)
+1 ;
MOMNAME() QUIT $PIECE(GLOB(.24),"^",2)
+1 ;
MADNAME() QUIT $PIECE(GLOB(.24),"^",3)
+1 ;
OCCUPAT() QUIT $PIECE(GLOB(0),"^",7)
+1 ;
MULTIBI() ;
+1 NEW DATA
+2 SET DATA=$PIECE($GET(^DPT(PTID,"MPIMB")),"^",1)
+3 SET DATA=$SELECT(DATA="Y":"YES",DATA="N":"NO",1:"")
+4 QUIT DATA
+5 ;
ALISINFO ;
+1 NEW ALISCNT,ROWCNT,ALIS,ALISSSN
+2 SET ALISCNT=0
SET ROWCNT=0
+3 FOR
SET ALISCNT=$ORDER(^DPT(PTID,.01,ALISCNT))
if (ALISCNT<1)
QUIT
Begin DoDot:1
+4 SET ALIS=$PIECE($GET(^DPT(PTID,.01,ALISCNT,0)),"^",1)
+5 SET ALISSSN=$PIECE($GET(^DPT(PTID,.01,ALISCNT,0)),"^",2)
+6 IF +$LENGTH(ALIS_ALISSSN)
Begin DoDot:2
+7 SET ROWCNT=ROWCNT+1
+8 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="<Alias Row='"_ROWCNT_"'"
+9 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Alias^"_ALIS_"^^ALIAS^"_ROWCNT
+10 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^SSN^"_ALISSSN_"^^ALIAS^"_ROWCNT
+11 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="></Alias>"
End DoDot:2
End DoDot:1
+12 IF ROWCNT=0
Begin DoDot:1
+13 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="<Alias Row='1' Alias='' SSN=''></Alias>"
End DoDot:1
+14 QUIT
