AGFACE1 ; IHS/ASDS/EFG - FACE SHEET (DEMOGRAPHIC DATA) ;
;;7.1;PATIENT REGISTRATION;**11**;AUG 25,2005;Build 1
;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
;
W !,"BIRTHPLACE: " S DIC=2,DA=DFN,DR=.092 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W AG("LKPRINT"),", "
S DR=.093 D ^AGDICLK W:$D(AG("LKPRINT"))&(AG("LKPRINT")]"") AG("LKPRINT")
W !,"RELIGION: " S DR=.08 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")
W ?47,"TRIBE ENROLL #: " S DIC=9000001,DR=.07 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W AG("LKPRINT")
I '$D(^AUPNPAT(DFN,43))!(AGOPT(8)'="Y") G L2
W !,AG("-"),!,"OTHER TRIBES:",?50,"QUANTUM:"
F AG=0:0 S AG=$O(^AUPNPAT(DFN,43,AG)) Q:+AG=0 S DIC=9000001.43,DA=DFN,AG("DRENT1")=AG,DR=.01 D ^AGDICLK I $D(AG("LKPRINT")) W !?5,AG("LKPRINT") S AG("DRENT1")=AG,DR=.02 D ^AGDICLK W:$D(AG("LKPRINT")) ?53,AG("LKPRINT")
L2 S DIC=2 W !,AG("-"),!
;IHS/OIT/NKD AG*7.1*11 MU2 - DISPLAY ALL RACES - START NEW CODE
I $$GET1^DIQ(9009061,DUZ(2)_",",503,"I") D ;CONDITIONAL DISPLAY OF RACE
.N AGRACE,AGCNT S AGRACE=$$RACE^AGUTL(DFN)
.Q:+AGRACE<2 ;IF LESS THAN 2, DO NOT DISPLAY (0 NO DISPLAY, 1 WILL ALREADY DISPLAY ABOVE)
.W "RACES:"
.F AGCNT=1:1:+AGRACE W !?5,$P(AGRACE,U,AGCNT+1)
.W !,AG("-"),!
;IHS/OIT/NKD AG*7.1*11 END NEW CODE
W "FATHER: " S DR=.2401 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") W ?40,"BIRTHPLACE: "
S DR=2602,DIC=9000001 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")," "
S DR=2603 D ^AGDICLK I $D(^DIC(5,+$G(AG("LKDATA")),0)) D
.W $P(^DIC(5,AG("LKDATA"),0),U,2)
W !,"MOTHER: " S DR=.2403,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") W ?40,"BIRTHPLACE: "
S DR=2605,DIC=9000001 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")," "
S DR=2606 D ^AGDICLK I $D(^DIC(5,+$G(AG("LKDATA")),0)) D
.W $P(^DIC(5,AG("LKDATA"),0),U,2)
W !,AG("-"),!,"EM CONTACT: " S DR=.331,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") S DIC=9000001,DR=3102 D ^AGDICLK W:$D(AG("LKPRINT")) " (",AG("LKPRINT"),")"
W ?51,"EM PHONE: " S DR=.339,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") W !,"EM ADDRESS:"
S DIC=2,DR=.333 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?5,AG("LKPRINT")
S AG="",DR=.336 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AG=AG_AG("LKPRINT")_","
F DR=.337,.338 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AG=AG_" "_AG("LKPRINT")
W:AG]"" !?5,AG
G END:'$D(^DPT(DFN,.21)),END:$P(^DPT(DFN,.21),U)=""
W !,AG("-"),!,"NEXT-OF-KIN: " S DR=.211,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") S DIC=9000001,DR=2802 D ^AGDICLK W:$D(AG("LKPRINT")) " (",AG("LKPRINT"),")"
W ?50,"NOK PHONE: " S DR=.219,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") W !,"NOK ADDRESS:"
S DIC=2,DR=.213 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?5,AG("LKPRINT")
S AG="",DR=.216 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AG=AG_AG("LKPRINT")_","
F DR=.217,.218 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AG=AG_" "_AG("LKPRINT")
W:AG]"" !?5,AG
END Q
AGFACE1 ; IHS/ASDS/EFG - FACE SHEET (DEMOGRAPHIC DATA) ;
+1 ;;7.1;PATIENT REGISTRATION;**11**;AUG 25,2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
+3 ;
+4 WRITE !,"BIRTHPLACE: "
SET DIC=2
SET DA=DFN
SET DR=.092
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE AG("LKPRINT"),", "
+5 SET DR=.093
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))&(AG("LKPRINT")]"")
WRITE AG("LKPRINT")
+6 WRITE !,"RELIGION: "
SET DR=.08
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
+7 WRITE ?47,"TRIBE ENROLL #: "
SET DIC=9000001
SET DR=.07
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE AG("LKPRINT")
+8 IF '$DATA(^AUPNPAT(DFN,43))!(AGOPT(8)'="Y")
GOTO L2
+9 WRITE !,AG("-"),!,"OTHER TRIBES:",?50,"QUANTUM:"
+10 FOR AG=0:0
SET AG=$ORDER(^AUPNPAT(DFN,43,AG))
IF +AG=0
QUIT
SET DIC=9000001.43
SET DA=DFN
SET AG("DRENT1")=AG
SET DR=.01
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE !?5,AG("LKPRINT")
SET AG("DRENT1")=AG
SET DR=.02
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE ?53,AG("LKPRINT")
L2 SET DIC=2
WRITE !,AG("-"),!
+1 ;IHS/OIT/NKD AG*7.1*11 MU2 - DISPLAY ALL RACES - START NEW CODE
+2 ;CONDITIONAL DISPLAY OF RACE
IF $$GET1^DIQ(9009061,DUZ(2)_",",503,"I")
Begin DoDot:1
+3 NEW AGRACE,AGCNT
SET AGRACE=$$RACE^AGUTL(DFN)
+4 ;IF LESS THAN 2, DO NOT DISPLAY (0 NO DISPLAY, 1 WILL ALREADY DISPLAY ABOVE)
IF +AGRACE<2
QUIT
+5 WRITE "RACES:"
+6 FOR AGCNT=1:1:+AGRACE
WRITE !?5,$PIECE(AGRACE,U,AGCNT+1)
+7 WRITE !,AG("-"),!
End DoDot:1
+8 ;IHS/OIT/NKD AG*7.1*11 END NEW CODE
+9 WRITE "FATHER: "
SET DR=.2401
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
WRITE ?40,"BIRTHPLACE: "
+10 SET DR=2602
SET DIC=9000001
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")," "
+11 SET DR=2603
DO ^AGDICLK
IF $DATA(^DIC(5,+$GET(AG("LKDATA")),0))
Begin DoDot:1
+12 WRITE $PIECE(^DIC(5,AG("LKDATA"),0),U,2)
End DoDot:1
+13 WRITE !,"MOTHER: "
SET DR=.2403
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
WRITE ?40,"BIRTHPLACE: "
+14 SET DR=2605
SET DIC=9000001
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")," "
+15 SET DR=2606
DO ^AGDICLK
IF $DATA(^DIC(5,+$GET(AG("LKDATA")),0))
Begin DoDot:1
+16 WRITE $PIECE(^DIC(5,AG("LKDATA"),0),U,2)
End DoDot:1
+17 WRITE !,AG("-"),!,"EM CONTACT: "
SET DR=.331
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
SET DIC=9000001
SET DR=3102
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE " (",AG("LKPRINT"),")"
+18 WRITE ?51,"EM PHONE: "
SET DR=.339
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
WRITE !,"EM ADDRESS:"
+19 SET DIC=2
SET DR=.333
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE !?5,AG("LKPRINT")
+20 SET AG=""
SET DR=.336
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AG=AG_AG("LKPRINT")_","
+21 FOR DR=.337,.338
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AG=AG_" "_AG("LKPRINT")
+22 IF AG]""
WRITE !?5,AG
+23 IF '$DATA(^DPT(DFN,.21))
GOTO END
IF $PIECE(^DPT(DFN,.21),U)=""
GOTO END
+24 WRITE !,AG("-"),!,"NEXT-OF-KIN: "
SET DR=.211
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
SET DIC=9000001
SET DR=2802
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE " (",AG("LKPRINT"),")"
+25 WRITE ?50,"NOK PHONE: "
SET DR=.219
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
WRITE !,"NOK ADDRESS:"
+26 SET DIC=2
SET DR=.213
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE !?5,AG("LKPRINT")
+27 SET AG=""
SET DR=.216
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AG=AG_AG("LKPRINT")_","
+28 FOR DR=.217,.218
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AG=AG_" "_AG("LKPRINT")
+29 IF AG]""
WRITE !?5,AG
END QUIT
