- 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
