DGRP2 ;ALB/MRL,BRM,ARF,JAM,ARF - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300
;;5.3;Registration;**415,545,638,677,760,867,1014,1064,1093,1140**;Aug 13, 1993;Build 10
;
D NEWB
S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S DGRPX=DGRP(0)
; DG*5.3*1064 - Set group 6 not editable if the INDIAN SELF IDENTIFICATION field (#.571) is not NULL
; DG*5.3*1093 - No longer check for Indian data - group 6 is now read-only always (set in DGRPV)
;I $$GET1^DIQ(2,DFN,.571)'="" S DGRPVV(2)="000101"
S (Z,DGRPW)=1 D WW^DGRPV W " Marital: " S Z=$S($D(^DIC(11,+$P(DGRPX,"^",5),0)):$E($P(^(0),"^",1),1,28),1:DGRPU),Z1=30 D WW1^DGRPV
;S (Z,DGRPW)=1 D WW^DGRPV W " Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV
S DGD=$$DISP^DG1010P0(DGRP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1)
W ?41,"POB: ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,29)
;S DGRPX=DGRP(0)
W !?4,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU)
S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QP"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X
W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU)
W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU)
;W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care",!?4,"------------------ -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X
W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X ;DG*5.3*1014 ARF remove dashes
E F I=1:1:4 S I1=$P(DGRPX,"^",I) X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)" I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
W ! S Z=3 D WW^DGRPV W " Ethnicity: " D
.I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q
.N NODE,NUM,ETHNIC
.S I=0
.F NUM=0:1 S I=+$O(^DPT(DFN,.06,I)) Q:'I D
..S NODE=$G(^DPT(DFN,.06,I,0))
..S X=$P($G(^DIC(10.2,+NODE,0)),"^",1)
..S ETHNIC=$S(X="":"?????",1:X)
..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
..S ETHNIC=ETHNIC_" ("_$S(X="":"?",1:X)_")"
..I NUM S ETHNIC=", "_ETHNIC
..I ($X+$L(ETHNIC))>IOM D W !?15
...F S X=$P(ETHNIC," ",1)_" " Q:($X+$L(X))>IOM W X S ETHNIC=$P(ETHNIC," ",2,999)
..W ETHNIC
W !?9,"Race: " D
.I '$O(^DPT(DFN,.02,0)) W "UNANSWERED" Q
.N NODE,NUM,RACE
.S I=0
.F NUM=0:1 S I=+$O(^DPT(DFN,.02,I)) Q:'I D
..S NODE=$G(^DPT(DFN,.02,I,0))
..S X=$P($G(^DIC(10,+NODE,0)),"^",1)
..S RACE=$S(X="":"?????",1:X)
..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
..S RACE=RACE_" ("_$S(X="":"?",1:X)_")"
..I NUM S RACE=", "_RACE
..I ($X+$L(RACE))>IOM D W !?15
...F S X=$P(RACE," ",1)_" " Q:($X+$L(X))>IOM W X S RACE=$P(RACE," ",2,999)
..W RACE
D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
W !!
W "<4> Date of Death Information"
W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
W ?41,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
W ?41,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
K PDTHINFO
;
;Emergency Response Indicator
N DGEMRES S DGEMRES=$P($G(^DPT(DFN,.18)),"^")
S Z=5 D WW^DGRPV W " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES)
;
; Display new Megabus fields on the PATIENT DATA, SCREEN <2> - DG*5.3*1064
W !
;S Z=6 D WW^DGRPV W ?10,"Indian: " D ;DG*5.3*1140 - Changed label from "Indian:" to "AI/AN Verified:"
S Z=6 D WW^DGRPV W ?2," AI/AN Verified: " D
. N DGIND1,DGIND2,DGIND3,DGIND4,DGINDARR
. D GETS^DIQ(2,DFN,".571:.574","E","DGINDARR")
. S DGIND1=$G(DGINDARR(2,DFN_",",.571,"E")) ;INDIAN SELF IDENTIFICATION field
. S DGIND2=$G(DGINDARR(2,DFN_",",.572,"E")) ;INDIAN START DATE field
. S DGIND3=$G(DGINDARR(2,DFN_",",.573,"E")) ;INDIAN ATTESTATION DATE field
. S DGIND4=$G(DGINDARR(2,DFN_",",.574,"E")) ;INDIAN END DATE field
. I DGIND1="" W "UNANSWERED" Q
. W DGIND1
. W:DGIND2'="" ?45,"Start Date: ",DGIND2
. ;W:DGIND3'="" !,"Attestation Date: ",DGIND3 ;DG*5.3*1140 - Changed label from "Attestation Date:" to "Verified Date:"
. W:DGIND3'="" !,?3," Verified Date: ",DGIND3
. W:(DGIND4'="")&(DGIND3="") ! W:DGIND4'="" ?47,"End Date: ",DGIND4
W !
G ^DGRPP
;
Q
NEWB ;-- check patient DOB, if DOB<365 days, set marital status to "never married"
N DOB,NOW
S DOB=$P(^DPT(DFN,0),"^",3)
D NOW^%DTC S NOW=X
I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;patient is not a newborn
S $P(^DPT(DFN,0),"^",5)=6 ;patient is a newborn
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP2 4888 printed Sep 23, 2025@20:31:29 Page 2
DGRP2 ;ALB/MRL,BRM,ARF,JAM,ARF - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300
+1 ;;5.3;Registration;**415,545,638,677,760,867,1014,1064,1093,1140**;Aug 13, 1993;Build 10
+2 ;
+3 DO NEWB
+4 SET DGRPS=2
DO H^DGRPU
FOR I=0,.24,57,1010.15
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+5 SET DGRPX=DGRP(0)
+6 ; DG*5.3*1064 - Set group 6 not editable if the INDIAN SELF IDENTIFICATION field (#.571) is not NULL
+7 ; DG*5.3*1093 - No longer check for Indian data - group 6 is now read-only always (set in DGRPV)
+8 ;I $$GET1^DIQ(2,DFN,.571)'="" S DGRPVV(2)="000101"
+9 SET (Z,DGRPW)=1
DO WW^DGRPV
WRITE " Marital: "
SET Z=$SELECT($DATA(^DIC(11,+$PIECE(DGRPX,"^",5),0)):$EXTRACT($PIECE(^(0),"^",1),1,28),1:DGRPU)
SET Z1=30
DO WW1^DGRPV
+10 ;S (Z,DGRPW)=1 D WW^DGRPV W " Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV
+11 SET DGD=$$DISP^DG1010P0(DGRP(0),11,0,1)
SET DGNOCITY=DGUNK
SET DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1)
+12 WRITE ?41,"POB: ",$EXTRACT($SELECT((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$SELECT(($LENGTH(DGD)):", ",1:"")_DGD1),1,29)
+13 ;S DGRPX=DGRP(0)
+14 WRITE !?4,"Religion: ",$SELECT($DATA(^DIC(13,+$PIECE(DGRPX,"^",8),0)):$PIECE(^(0),"^",1),1:DGRPU),?41,"Father: ",$SELECT($PIECE(DGRP(.24),"^",1)]"":$EXTRACT($PIECE(DGRP(.24),"^",1),1,29),1:DGRPU)
+15 SET X=$PIECE(DGRP(57),"^",4)
SET X=$SELECT(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON")
SET X=$SELECT("QP"[$EXTRACT(X):X_"TRAUMATIC",1:X)
WRITE !?9,"SCI: ",X
+16 WRITE ?41,"Mother: ",$SELECT($PIECE(DGRP(.24),"^",2)]"":$EXTRACT($PIECE(DGRP(.24),"^",2),1,29),1:DGRPU)
+17 WRITE !,?35,"Mom's Maiden: ",$SELECT($PIECE(DGRP(.24),"^",3)]"":$EXTRACT($PIECE(DGRP(.24),"^",3),1,29),1:DGRPU)
+18 ;W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care",!?4,"------------------ -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X
+19 ;DG*5.3*1014 ARF remove dashes
WRITE !
SET Z=2
DO WW^DGRPV
WRITE " Previous Care Date Location of Previous Care"
SET DGRPX=DGRP(1010.15)
IF $PIECE(DGRPX,"^",5)'="Y"
SET X="NONE INDICATED"
WRITE !?4,X,?28,X
+20 IF '$TEST
FOR I=1:1:4
SET I1=$PIECE(DGRPX,"^",I)
XECUTE "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)"
IF '(I#2)
WRITE ?28,$SELECT($DATA(^DIC(4,+I1,0)):$PIECE(^(0),"^",1),1:DGRPU)
+21 WRITE !
SET Z=3
DO WW^DGRPV
WRITE " Ethnicity: "
Begin DoDot:1
+22 IF '$ORDER(^DPT(DFN,.06,0))
WRITE "UNANSWERED"
QUIT
+23 NEW NODE,NUM,ETHNIC
+24 SET I=0
+25 FOR NUM=0:1
SET I=+$ORDER(^DPT(DFN,.06,I))
if 'I
QUIT
Begin DoDot:2
+26 SET NODE=$GET(^DPT(DFN,.06,I,0))
+27 SET X=$PIECE($GET(^DIC(10.2,+NODE,0)),"^",1)
+28 SET ETHNIC=$SELECT(X="":"?????",1:X)
+29 SET X=$PIECE($GET(^DIC(10.3,+$PIECE(NODE,"^",2),0)),"^",2)
+30 SET ETHNIC=ETHNIC_" ("_$SELECT(X="":"?",1:X)_")"
+31 IF NUM
SET ETHNIC=", "_ETHNIC
+32 IF ($X+$LENGTH(ETHNIC))>IOM
Begin DoDot:3
+33 FOR
SET X=$PIECE(ETHNIC," ",1)_" "
if ($X+$LENGTH(X))>IOM
QUIT
WRITE X
SET ETHNIC=$PIECE(ETHNIC," ",2,999)
End DoDot:3
WRITE !?15
+34 WRITE ETHNIC
End DoDot:2
End DoDot:1
+35 WRITE !?9,"Race: "
Begin DoDot:1
+36 IF '$ORDER(^DPT(DFN,.02,0))
WRITE "UNANSWERED"
QUIT
+37 NEW NODE,NUM,RACE
+38 SET I=0
+39 FOR NUM=0:1
SET I=+$ORDER(^DPT(DFN,.02,I))
if 'I
QUIT
Begin DoDot:2
+40 SET NODE=$GET(^DPT(DFN,.02,I,0))
+41 SET X=$PIECE($GET(^DIC(10,+NODE,0)),"^",1)
+42 SET RACE=$SELECT(X="":"?????",1:X)
+43 SET X=$PIECE($GET(^DIC(10.3,+$PIECE(NODE,"^",2),0)),"^",2)
+44 SET RACE=RACE_" ("_$SELECT(X="":"?",1:X)_")"
+45 IF NUM
SET RACE=", "_RACE
+46 IF ($X+$LENGTH(RACE))>IOM
Begin DoDot:3
+47 FOR
SET X=$PIECE(RACE," ",1)_" "
if ($X+$LENGTH(X))>IOM
QUIT
WRITE X
SET RACE=$PIECE(RACE," ",2,999)
End DoDot:3
WRITE !?15
+48 WRITE RACE
End DoDot:2
End DoDot:1
+49 DO GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
+50 WRITE !!
+51 WRITE "<4> Date of Death Information"
+52 WRITE !,?5,"Date of Death: ",$GET(PDTHINFO(2,DFN_",",.351,"E"))
+53 WRITE ?41,"Source of Notification: ",$GET(PDTHINFO(2,DFN_",",.353,"E"))
+54 WRITE !,?5,"Updated Date/Time: ",$GET(PDTHINFO(2,DFN_",",.354,"E"))
+55 WRITE ?41,"Last Edited By: ",$GET(PDTHINFO(2,DFN_",",.355,"E")),!
+56 KILL PDTHINFO
+57 ;
+58 ;Emergency Response Indicator
+59 NEW DGEMRES
SET DGEMRES=$PIECE($GET(^DPT(DFN,.18)),"^")
+60 SET Z=5
DO WW^DGRPV
WRITE " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES)
+61 ;
+62 ; Display new Megabus fields on the PATIENT DATA, SCREEN <2> - DG*5.3*1064
+63 WRITE !
+64 ;S Z=6 D WW^DGRPV W ?10,"Indian: " D ;DG*5.3*1140 - Changed label from "Indian:" to "AI/AN Verified:"
+65 SET Z=6
DO WW^DGRPV
WRITE ?2," AI/AN Verified: "
Begin DoDot:1
+66 NEW DGIND1,DGIND2,DGIND3,DGIND4,DGINDARR
+67 DO GETS^DIQ(2,DFN,".571:.574","E","DGINDARR")
+68 ;INDIAN SELF IDENTIFICATION field
SET DGIND1=$GET(DGINDARR(2,DFN_",",.571,"E"))
+69 ;INDIAN START DATE field
SET DGIND2=$GET(DGINDARR(2,DFN_",",.572,"E"))
+70 ;INDIAN ATTESTATION DATE field
SET DGIND3=$GET(DGINDARR(2,DFN_",",.573,"E"))
+71 ;INDIAN END DATE field
SET DGIND4=$GET(DGINDARR(2,DFN_",",.574,"E"))
+72 IF DGIND1=""
WRITE "UNANSWERED"
QUIT
+73 WRITE DGIND1
+74 if DGIND2'=""
WRITE ?45,"Start Date: ",DGIND2
+75 ;W:DGIND3'="" !,"Attestation Date: ",DGIND3 ;DG*5.3*1140 - Changed label from "Attestation Date:" to "Verified Date:"
+76 if DGIND3'=""
WRITE !,?3," Verified Date: ",DGIND3
+77 if (DGIND4'="")&(DGIND3="")
WRITE !
if DGIND4'=""
WRITE ?47,"End Date: ",DGIND4
End DoDot:1
+78 WRITE !
+79 GOTO ^DGRPP
+80 ;
+81 QUIT
NEWB ;-- check patient DOB, if DOB<365 days, set marital status to "never married"
+1 NEW DOB,NOW
+2 SET DOB=$PIECE(^DPT(DFN,0),"^",3)
+3 DO NOW^%DTC
SET NOW=X
+4 ;patient is not a newborn
IF $$FMDIFF^XLFDT(NOW,DOB,1)>365
QUIT
+5 ;patient is a newborn
SET $PIECE(^DPT(DFN,0),"^",5)=6
+6 QUIT
