DGRRPSD2 ; ALB/SGG - rtnDGRR PatientServices Demographics Secondary ;09/30/03 ; Compiled December 9, 2003 15:23:28
;;5.3;Registration;**557**;Aug 13, 1993
;
DOC ;<DataSet Name='SecondaryDemographics'
;
;FROM: ^DGSL(38.1,
;3 SECURITY ASSIGNED BY (RP200'), [0;3]
;4 DATE/TIME SECURITY ASSIGNED (RD), [0;4]
;5 SECURITY SOURCE (F), [0;5]
;
;FROM: ^DPT(PTID
; RACE INFORMATION (Multiple-2.02), [.02;0]
; .01 RACE INFORMATION (M*P10'X), [0;1]
; .02 METHOD OF COLLECTION (RP10.3'), [0;2]
;
;.352 DEATH ENTERED BY (P200'), [.35;2]
;
;6 ETHNICITY INFORMATION (Multiple-2.06), [.06;0]
; .01 ETHNICITY INFORMATION (*P10.2'X), [0;1]
; .02 METHOD OF COLLECTION (RP10.3'), [0;2]
;
;Primary Care Provider - Use $$NMPCPR^SCAPMCU2(PTID,DT,1) API to
; retrieve Primary Care Provider. Call VPID^XUPS API to
; convert DUZ to VPID.
;
GETPSARY(PSARRAY) ;
NEW CNT
SET CNT=$G(CNT)+1,PSARRAY(CNT)="<DataSet Name='SecondaryDemographics'"
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^SecurityAssignedBy^"_$$SECASGBY()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^DateTimeSecurityAssigned^"_$$DTSECASG()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^SecuritySource^"_$$SECSOURC()
SET CNT=$G(CNT)+1,PSARRAY(CNT)="^PrimaryCareProvider^"_$$PCP()
DO ETHNINFO
DO RACEINFO
SET CNT=$G(CNT)+1,PSARRAY(CNT)="</DataSet>"_"^^^1"
QUIT
;
SECASGBY() ;
NEW DATA
SET DATA=$P(GLOB(38.1),"^",3)
IF DATA'="" S DATA=$P($G(^VA(200,DATA,0)),"^",1)
QUIT DATA
;
DTSECASG() ;
QUIT $P(GLOB(38.1),"^",4)
;
SECSOURC() ;
QUIT $P(GLOB(38.1),"^",5)
;
DODENTBY() ;
NEW DATA
SET DATA=$P(GLOB(.35),"^",2)
IF DATA'="" SET DATA=$P($G(^VA(200,DATA,0)),"^",1)
QUIT DATA
;
DODVPID() ;
;QUIT "200#ROOT"_$P(GLOB(.35),"^",2)
QUIT $$VPID^XUPS($P(GLOB(.35),"^",2))
;
PCP() ;Primary Care Provider
; get the PCP's IEN and convert to VPID (primary care physician)
;
N PATSPCP,PCPIEN,PCPVPID
SET PATSPCP=$$NMPCPR^SCAPMCU2(PTID,DT,1)
SET PCPIEN=$P(PATSPCP,"^",1)
SET PCPVPID=$$VPID^XUPS(+PCPIEN)
QUIT PCPVPID
;
ETHNINFO ;
NEW ETHCNT,ROWCNT,ETHNIC,METHOD
SET ETHCNT=0,ROWCNT=0
FOR SET ETHCNT=$O(^DPT(PTID,.06,ETHCNT)) QUIT:(ETHCNT<1) DO
.SET ETHNIC=$P($G(^DPT(PTID,.06,ETHCNT,0)),"^",1)
.SET METHOD=$P($G(^DPT(PTID,.06,ETHCNT,0)),"^",2)
.IF ETHNIC'="" DO
..SET ROWCNT=ROWCNT+1
..SET ETHNIC=$P($G(^DIC(10.2,ETHNIC,0)),"^",1)
..IF METHOD'="" SET METHOD=$P(^DIC(10.3,METHOD,0),"^",1)
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="><Ethnicity Row='"_ROWCNT_"'"
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Ethnicity^"_ETHNIC_"^^ETHNIC^"_ROWCNT
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^MethodOfCollection^"_METHOD_"^^ETHNIC^"_ROWCNT
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="></Ethnicity>"
IF ROWCNT=0 DO
.SET CNT=$G(CNT)+1,PSARRAY(CNT)="><Ethnicity Row='1' Ethnicity='' MethodOfCollection=''></Ethnicity>"
QUIT
;
RACEINFO ;
NEW RACECNT,ROWCNT,RACE,METHOD
SET RACECNT=0,ROWCNT=0
FOR SET RACECNT=$O(^DPT(PTID,.02,RACECNT)) QUIT:(RACECNT<1) DO
.SET RACE=$P($G(^DPT(PTID,.02,RACECNT,0)),"^",1)
.SET METHOD=$P($G(^DPT(PTID,.02,RACECNT,0)),"^",2)
.IF RACE'="" DO
..SET ROWCNT=ROWCNT+1
..SET RACE=$P($G(^DIC(10,RACE,0)),"^",1)
..IF METHOD'="" SET METHOD=$P(^DIC(10.3,METHOD,0),"^",1)
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="<Race Row='"_ROWCNT_"'"
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Race^"_RACE_"^^RACE^"_ROWCNT
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^MethodOfCollection^"_METHOD_"^^RACE^"_ROWCNT
..SET CNT=$G(CNT)+1,PSARRAY(CNT)="></Race>"
IF ROWCNT=0 DO
.SET CNT=$G(CNT)+1,PSARRAY(CNT)="<Race Row='1' Race='' MethodOfCollection=''></Race>"
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRPSD2 3710 printed Sep 23, 2025@20:33:42 Page 2
DGRRPSD2 ; ALB/SGG - rtnDGRR PatientServices Demographics Secondary ;09/30/03 ; Compiled December 9, 2003 15:23:28
+1 ;;5.3;Registration;**557**;Aug 13, 1993
+2 ;
DOC ;<DataSet Name='SecondaryDemographics'
+1 ;
+2 ;FROM: ^DGSL(38.1,
+3 ;3 SECURITY ASSIGNED BY (RP200'), [0;3]
+4 ;4 DATE/TIME SECURITY ASSIGNED (RD), [0;4]
+5 ;5 SECURITY SOURCE (F), [0;5]
+6 ;
+7 ;FROM: ^DPT(PTID
+8 ; RACE INFORMATION (Multiple-2.02), [.02;0]
+9 ; .01 RACE INFORMATION (M*P10'X), [0;1]
+10 ; .02 METHOD OF COLLECTION (RP10.3'), [0;2]
+11 ;
+12 ;.352 DEATH ENTERED BY (P200'), [.35;2]
+13 ;
+14 ;6 ETHNICITY INFORMATION (Multiple-2.06), [.06;0]
+15 ; .01 ETHNICITY INFORMATION (*P10.2'X), [0;1]
+16 ; .02 METHOD OF COLLECTION (RP10.3'), [0;2]
+17 ;
+18 ;Primary Care Provider - Use $$NMPCPR^SCAPMCU2(PTID,DT,1) API to
+19 ; retrieve Primary Care Provider. Call VPID^XUPS API to
+20 ; convert DUZ to VPID.
+21 ;
GETPSARY(PSARRAY) ;
+1 NEW CNT
+2 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="<DataSet Name='SecondaryDemographics'"
+3 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^SecurityAssignedBy^"_$$SECASGBY()
+4 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^DateTimeSecurityAssigned^"_$$DTSECASG()
+5 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^SecuritySource^"_$$SECSOURC()
+6 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^PrimaryCareProvider^"_$$PCP()
+7 DO ETHNINFO
+8 DO RACEINFO
+9 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="</DataSet>"_"^^^1"
+10 QUIT
+11 ;
SECASGBY() ;
+1 NEW DATA
+2 SET DATA=$PIECE(GLOB(38.1),"^",3)
+3 IF DATA'=""
SET DATA=$PIECE($GET(^VA(200,DATA,0)),"^",1)
+4 QUIT DATA
+5 ;
DTSECASG() ;
+1 QUIT $PIECE(GLOB(38.1),"^",4)
+2 ;
SECSOURC() ;
+1 QUIT $PIECE(GLOB(38.1),"^",5)
+2 ;
DODENTBY() ;
+1 NEW DATA
+2 SET DATA=$PIECE(GLOB(.35),"^",2)
+3 IF DATA'=""
SET DATA=$PIECE($GET(^VA(200,DATA,0)),"^",1)
+4 QUIT DATA
+5 ;
DODVPID() ;
+1 ;QUIT "200#ROOT"_$P(GLOB(.35),"^",2)
+2 QUIT $$VPID^XUPS($PIECE(GLOB(.35),"^",2))
+3 ;
PCP() ;Primary Care Provider
+1 ; get the PCP's IEN and convert to VPID (primary care physician)
+2 ;
+3 NEW PATSPCP,PCPIEN,PCPVPID
+4 SET PATSPCP=$$NMPCPR^SCAPMCU2(PTID,DT,1)
+5 SET PCPIEN=$PIECE(PATSPCP,"^",1)
+6 SET PCPVPID=$$VPID^XUPS(+PCPIEN)
+7 QUIT PCPVPID
+8 ;
ETHNINFO ;
+1 NEW ETHCNT,ROWCNT,ETHNIC,METHOD
+2 SET ETHCNT=0
SET ROWCNT=0
+3 FOR
SET ETHCNT=$ORDER(^DPT(PTID,.06,ETHCNT))
if (ETHCNT<1)
QUIT
Begin DoDot:1
+4 SET ETHNIC=$PIECE($GET(^DPT(PTID,.06,ETHCNT,0)),"^",1)
+5 SET METHOD=$PIECE($GET(^DPT(PTID,.06,ETHCNT,0)),"^",2)
+6 IF ETHNIC'=""
Begin DoDot:2
+7 SET ROWCNT=ROWCNT+1
+8 SET ETHNIC=$PIECE($GET(^DIC(10.2,ETHNIC,0)),"^",1)
+9 IF METHOD'=""
SET METHOD=$PIECE(^DIC(10.3,METHOD,0),"^",1)
+10 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="><Ethnicity Row='"_ROWCNT_"'"
+11 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Ethnicity^"_ETHNIC_"^^ETHNIC^"_ROWCNT
+12 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^MethodOfCollection^"_METHOD_"^^ETHNIC^"_ROWCNT
+13 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="></Ethnicity>"
End DoDot:2
End DoDot:1
+14 IF ROWCNT=0
Begin DoDot:1
+15 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="><Ethnicity Row='1' Ethnicity='' MethodOfCollection=''></Ethnicity>"
End DoDot:1
+16 QUIT
+17 ;
RACEINFO ;
+1 NEW RACECNT,ROWCNT,RACE,METHOD
+2 SET RACECNT=0
SET ROWCNT=0
+3 FOR
SET RACECNT=$ORDER(^DPT(PTID,.02,RACECNT))
if (RACECNT<1)
QUIT
Begin DoDot:1
+4 SET RACE=$PIECE($GET(^DPT(PTID,.02,RACECNT,0)),"^",1)
+5 SET METHOD=$PIECE($GET(^DPT(PTID,.02,RACECNT,0)),"^",2)
+6 IF RACE'=""
Begin DoDot:2
+7 SET ROWCNT=ROWCNT+1
+8 SET RACE=$PIECE($GET(^DIC(10,RACE,0)),"^",1)
+9 IF METHOD'=""
SET METHOD=$PIECE(^DIC(10.3,METHOD,0),"^",1)
+10 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="<Race Row='"_ROWCNT_"'"
+11 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^Race^"_RACE_"^^RACE^"_ROWCNT
+12 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="^MethodOfCollection^"_METHOD_"^^RACE^"_ROWCNT
+13 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="></Race>"
End DoDot:2
End DoDot:1
+14 IF ROWCNT=0
Begin DoDot:1
+15 SET CNT=$GET(CNT)+1
SET PSARRAY(CNT)="<Race Row='1' Race='' MethodOfCollection=''></Race>"
End DoDot:1
+16 QUIT
