DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300
;;5.3;PIMS;**415,545,638,677,760,1015,1016**;JUN 30, 2012;Build 20
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)
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
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)
G ^DGRPP
DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300
+1 ;;5.3;PIMS;**415,545,638,677,760,1015,1016**;JUN 30, 2012;Build 20
+2 SET DGRPS=2
DO H^DGRPU
FOR I=0,.24,57,1010.15
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+3 SET DGRPX=DGRP(0)
+4 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
+5 ;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
+6 SET DGD=$$DISP^DG1010P0(DGRP(0),11,0,1)
SET DGNOCITY=DGUNK
SET DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1)
+7 WRITE ?41,"POB: ",$EXTRACT($SELECT((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$SELECT(($LENGTH(DGD)):", ",1:"")_DGD1),1,29)
+8 ;S DGRPX=DGRP(0)
+9 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)
+10 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
+11 WRITE ?41,"Mother: ",$SELECT($PIECE(DGRP(.24),"^",2)]"":$EXTRACT($PIECE(DGRP(.24),"^",2),1,29),1:DGRPU)
+12 WRITE !,?35,"Mom's Maiden: ",$SELECT($PIECE(DGRP(.24),"^",3)]"":$EXTRACT($PIECE(DGRP(.24),"^",3),1,29),1:DGRPU)
+13 WRITE !
SET Z=2
DO WW^DGRPV
WRITE " Previous Care Date Location of Previous Care",!?4,"------------------ -------------------------"
SET DGRPX=DGRP(1010.15)
IF $PIECE(DGRPX,"^",5)'="Y"
SET X="NONE INDICATED"
WRITE !?4,X,?28,X
+14 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)
+15 WRITE !
SET Z=3
DO WW^DGRPV
WRITE " Ethnicity: "
Begin DoDot:1
+16 IF '$ORDER(^DPT(DFN,.06,0))
WRITE "UNANSWERED"
QUIT
+17 NEW NODE,NUM,ETHNIC
+18 SET I=0
+19 FOR NUM=0:1
SET I=+$ORDER(^DPT(DFN,.06,I))
IF 'I
QUIT
Begin DoDot:2
+20 SET NODE=$GET(^DPT(DFN,.06,I,0))
+21 SET X=$PIECE($GET(^DIC(10.2,+NODE,0)),"^",1)
+22 SET ETHNIC=$SELECT(X="":"?????",1:X)
+23 SET X=$PIECE($GET(^DIC(10.3,+$PIECE(NODE,"^",2),0)),"^",2)
+24 SET ETHNIC=ETHNIC_" ("_$SELECT(X="":"?",1:X)_")"
+25 IF NUM
SET ETHNIC=", "_ETHNIC
+26 IF ($X+$LENGTH(ETHNIC))>IOM
Begin DoDot:3
+27 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
+28 WRITE ETHNIC
End DoDot:2
End DoDot:1
+29 WRITE !?9,"Race: "
Begin DoDot:1
+30 IF '$ORDER(^DPT(DFN,.02,0))
WRITE "UNANSWERED"
QUIT
+31 NEW NODE,NUM,RACE
+32 SET I=0
+33 FOR NUM=0:1
SET I=+$ORDER(^DPT(DFN,.02,I))
IF 'I
QUIT
Begin DoDot:2
+34 SET NODE=$GET(^DPT(DFN,.02,I,0))
+35 SET X=$PIECE($GET(^DIC(10,+NODE,0)),"^",1)
+36 SET RACE=$SELECT(X="":"?????",1:X)
+37 SET X=$PIECE($GET(^DIC(10.3,+$PIECE(NODE,"^",2),0)),"^",2)
+38 SET RACE=RACE_" ("_$SELECT(X="":"?",1:X)_")"
+39 IF NUM
SET RACE=", "_RACE
+40 IF ($X+$LENGTH(RACE))>IOM
Begin DoDot:3
+41 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
+42 WRITE RACE
End DoDot:2
End DoDot:1
+43 DO GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
+44 WRITE !!
+45 WRITE "<4> Date of Death Information"
+46 WRITE !,?5,"Date of Death: ",$GET(PDTHINFO(2,DFN_",",.351,"E"))
+47 WRITE ?41,"Source of Notification: ",$GET(PDTHINFO(2,DFN_",",.353,"E"))
+48 WRITE !,?5,"Updated Date/Time: ",$GET(PDTHINFO(2,DFN_",",.354,"E"))
+49 WRITE ?41,"Last Edited By: ",$GET(PDTHINFO(2,DFN_",",.355,"E")),!
+50 KILL PDTHINFO
+51 ;
+52 ;Emergency Response Indicator
+53 NEW DGEMRES
SET DGEMRES=$PIECE($GET(^DPT(DFN,.18)),"^")
+54 SET Z=5
DO WW^DGRPV
WRITE " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES)
+55 GOTO ^DGRPP
