Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AG8B

AG8B.m

Go to the documentation of this file.
  1. AG8B ; IHS/ASDS/EFG - NEXT OF KIN DATA ENTRY ;
  1. ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
  1. NKNAME ;EP - NOK NAME
  1. NAME1 W !!,"Name of NEXT-OF-KIN (NOK).",!," (if same as Emerg. Contact, enter SAME): " D NAMED W:$D(AG("EMNM")) AG("EMNM"),"// "
  1. D READ^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)!$D(DLOUT) G QUES:$D(DQOUT),SAME:Y="SAME"
  1. D S2
  1. S DR=".211///"_Y
  1. D ^DIE G NAME1:$D(Y)
  1. ;I $P(^DPT(DFN,.21),U,2)="" S $P(^AUPNPAT(DFN,28),U,2)=""
  1. I $P($G(^DPT(DFN,.21)),U,2)="" S $P(^AUPNPAT(DFN,28),U,2)="" ;AG*7.1*2 FOUND DURING ALPHA
  1. Q
  1. NKREL ;EP - NOK RELATIONSHIP
  1. D S1 S DR=2802 G END
  1. NKSTR ;EP - NOK STREET
  1. D S2 S DR=.213 G END
  1. NKCITY ;EP - NOK CITY
  1. D S2 S DR=.216 G END
  1. NKST ;EP - NOK STATE
  1. D S2 S DR=.217 G END
  1. NKZIP ;EP - NOK ZIP
  1. D S2
  1. I $D(DPTFLAG) S DR=.2207
  1. E S DR=.218
  1. G END
  1. NKPH ;EP - NOK PHONE #
  1. D S2 S DR=.219 G END
  1. S1 K DUOUT S DIE="^AUPNPAT(",DA=DFN W ! Q
  1. S2 K DUOUT S DIE="^DPT(",DA=DFN W ! Q
  1. END D ^DIE S:$D(Y) DUOUT="" Q
  1. QUES W !!,"Enter the next-of-kin's full name.",!! G NKNAME
  1. NAMED K AG("EMNM") I $D(^DPT(DFN,.21)),$P(^DPT(DFN,.21),U)]"" S AG("EMNM")=$P(^DPT(DFN,.21),U)
  1. Q
  1. SAME I $D(^DPT(DFN,.33)),$P(^DPT(DFN,.33),U)]"" G SAME1
  1. W !!,*7,"EMERGENCY CONTACT NOT ON FILE.",! G NKNAME
  1. SAME1 ;
  1. F I=1:1:10 S AGS(I)=$P(^DPT(DFN,.33),"^",I)
  1. S AGDR(1)=".211///"_AGS(1)_";.212///"_AGS(2)_";.213///"_AGS(3)_";.214///"_AGS(4)_";.215///"_AGS(5)
  1. S AGDR(2)=".216///"_AGS(6)_";.217///`"_AGS(7)_";.218///"_AGS(8)_";.219///"_AGS(9)_";.2125////"_AGS(10)
  1. K DR,DIC S DA=DFN,DR=AGDR(1),DIE="^DPT(" D ^DIE
  1. K DR,DIC S DA=DFN,DR=AGDR(2),DIE="^DPT(" D ^DIE
  1. K AGS,AGDR
  1. I $D(^AUPNPAT(DFN,31)) S DA=DFN,DIE="^AUPNPAT(",DR="2802////"_$P(^AUPNPAT(DFN,31),U,2) K DIC D ^DIE
  1. Q
  1. NKRELD ;CALLED FROM DGDDC RTN WHICH IS CALLED BY XREF ON FIELD .211 OF ^DPT
  1. I '$D(XDRMRG) S $P(^AUPNPAT(DA,28),"^",2)=""
  1. Q