AG8A ; IHS/ASDS/EFG - ENTER & EDIT NON-MANDATORY DATA ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
REL ;EP - RELIGION
D S2
S DR=.08
D END
Q
FNAME ;EP - FATHER'S NAME
D S2
S DR=.2401
D END
Q
FCOB ;EP - FATHER'S CITY OF BIRTH
D S1
S DR=2602
D END
Q
FSOB ;EP - FATHER'S STATE OF BIRTH
D S1
S DR=2603
D END
Q
FEMP ;EP - FATHER'S EMPLOYER
D S1
S DR=2701
D END
Q
MNAME ;EP - MOTHER'S MAIDEN NAME
D S2
S DR=.2403
D END
Q
MCOB ;EP - MOTHER'S CITY OF BIRTH
D S1
S DR=2605
D END
Q
MSOB ;EP - MOTHER'S STATE OF BIRTH
D S1
S DR=2606
D END
Q
MEMP ;EP - MOTHER'S EMPLOYER
D S1
S DR=2702
D END
Q
ECNAME ;EP - EMERG CONTACT NAME
D S2
S DR=.331
I $P($G(^DPT(DFN,.33)),U)=""&($P($G(^AUPNPAT(DFN,31)),U,2)'="") S $P(^AUPNPAT(DFN,31),U,2)="" ; IF EC NAME HAS BEEN DELETED - DELETE RELATIONSHIP
G END
ECREL ;EP - EMERG CONT RELATIONSHIP
D S1
S DR=3102
D END
Q
ECSTR ;EP - EMERG CONT STREET
D S2
S DR=.333
W !,"(If the Emerg. Contact address is the patient's, enter SAME)" ; IHS/SD/EFG AG*7*1 03/12/2003
D END
Q:$D(DUOUT) G SAME
Q
ECCITY ;EP - EMERG CONT CITY
D S2
S DR=.336
D END
Q
ECST ;EP - EMERG CONT STATE
D S2
S DR=.337
D END
Q
ECZIP ;EP - EMERG CONT ZIP
D S2
I $D(DPTFLAG) S DR=.2201
E S DR=.338
D END
Q
ECPH ;EP - EMERG CONT PHONE #
D S2
S DR=.339
D END
Q
S1 ;
K DUOUT
S DIE="^AUPNPAT("
S DA=DFN
W !
Q
S2 ;
K DUOUT
S DIE="^DPT("
S DA=DFN
W !
Q
END ;
D ^DIE
S:$D(Y) DUOUT=""
Q
SAME ;
S DA=DFN
S DR=.333
S DIC=2
D ^AGDICLK
Q:'$D(AG("LKPRINT"))
Q:AG("LKPRINT")'="SAME"&(AG("LKPRINT")'="same")
I '$D(^DPT(DFN,.11)) W !,*7,"PATIENT'S ADDRESS NOT ON FILE",! S $P(^DPT(DFN,.33),U,3)="" G ECSTR
S $P(^DPT(DFN,.33),U,3)=$P(^DPT(DFN,.11),U)
S $P(^DPT(DFN,.33),U,6)=$P(^DPT(DFN,.11),U,4)
S $P(^DPT(DFN,.33),U,7)=$P(^DPT(DFN,.11),U,5)
S $P(^DPT(DFN,.33),U,8)=$P(^DPT(DFN,.11),U,6)
Q:'$D(^DPT(DFN,.13))
S $P(^DPT(DFN,.33),U,9)=$P(^DPT(DFN,.13),U)
Q
ECRELD ;CALLED FROM DGDDC RTN WHICH IS CALLED BY XREF ON FIELD .331 OF ^DPT
S $P(^AUPNPAT(DFN,31),"^",2)=""
Q
AG8A ; IHS/ASDS/EFG - ENTER & EDIT NON-MANDATORY DATA ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
REL ;EP - RELIGION
+1 DO S2
+2 SET DR=.08
+3 DO END
+4 QUIT
FNAME ;EP - FATHER'S NAME
+1 DO S2
+2 SET DR=.2401
+3 DO END
+4 QUIT
FCOB ;EP - FATHER'S CITY OF BIRTH
+1 DO S1
+2 SET DR=2602
+3 DO END
+4 QUIT
FSOB ;EP - FATHER'S STATE OF BIRTH
+1 DO S1
+2 SET DR=2603
+3 DO END
+4 QUIT
FEMP ;EP - FATHER'S EMPLOYER
+1 DO S1
+2 SET DR=2701
+3 DO END
+4 QUIT
MNAME ;EP - MOTHER'S MAIDEN NAME
+1 DO S2
+2 SET DR=.2403
+3 DO END
+4 QUIT
MCOB ;EP - MOTHER'S CITY OF BIRTH
+1 DO S1
+2 SET DR=2605
+3 DO END
+4 QUIT
MSOB ;EP - MOTHER'S STATE OF BIRTH
+1 DO S1
+2 SET DR=2606
+3 DO END
+4 QUIT
MEMP ;EP - MOTHER'S EMPLOYER
+1 DO S1
+2 SET DR=2702
+3 DO END
+4 QUIT
ECNAME ;EP - EMERG CONTACT NAME
+1 DO S2
+2 SET DR=.331
+3 ; IF EC NAME HAS BEEN DELETED - DELETE RELATIONSHIP
IF $PIECE($GET(^DPT(DFN,.33)),U)=""&($PIECE($GET(^AUPNPAT(DFN,31)),U,2)'="")
SET $PIECE(^AUPNPAT(DFN,31),U,2)=""
+4 GOTO END
ECREL ;EP - EMERG CONT RELATIONSHIP
+1 DO S1
+2 SET DR=3102
+3 DO END
+4 QUIT
ECSTR ;EP - EMERG CONT STREET
+1 DO S2
+2 SET DR=.333
+3 ; IHS/SD/EFG AG*7*1 03/12/2003
WRITE !,"(If the Emerg. Contact address is the patient's, enter SAME)"
+4 DO END
+5 IF $DATA(DUOUT)
QUIT
GOTO SAME
+6 QUIT
ECCITY ;EP - EMERG CONT CITY
+1 DO S2
+2 SET DR=.336
+3 DO END
+4 QUIT
ECST ;EP - EMERG CONT STATE
+1 DO S2
+2 SET DR=.337
+3 DO END
+4 QUIT
ECZIP ;EP - EMERG CONT ZIP
+1 DO S2
+2 IF $DATA(DPTFLAG)
SET DR=.2201
+3 IF '$TEST
SET DR=.338
+4 DO END
+5 QUIT
ECPH ;EP - EMERG CONT PHONE #
+1 DO S2
+2 SET DR=.339
+3 DO END
+4 QUIT
S1 ;
+1 KILL DUOUT
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 WRITE !
+5 QUIT
S2 ;
+1 KILL DUOUT
+2 SET DIE="^DPT("
+3 SET DA=DFN
+4 WRITE !
+5 QUIT
END ;
+1 DO ^DIE
+2 IF $DATA(Y)
SET DUOUT=""
+3 QUIT
SAME ;
+1 SET DA=DFN
+2 SET DR=.333
+3 SET DIC=2
+4 DO ^AGDICLK
+5 IF '$DATA(AG("LKPRINT"))
QUIT
+6 IF AG("LKPRINT")'="SAME"&(AG("LKPRINT")'="same")
QUIT
+7 IF '$DATA(^DPT(DFN,.11))
WRITE !,*7,"PATIENT'S ADDRESS NOT ON FILE",!
SET $PIECE(^DPT(DFN,.33),U,3)=""
GOTO ECSTR
+8 SET $PIECE(^DPT(DFN,.33),U,3)=$PIECE(^DPT(DFN,.11),U)
+9 SET $PIECE(^DPT(DFN,.33),U,6)=$PIECE(^DPT(DFN,.11),U,4)
+10 SET $PIECE(^DPT(DFN,.33),U,7)=$PIECE(^DPT(DFN,.11),U,5)
+11 SET $PIECE(^DPT(DFN,.33),U,8)=$PIECE(^DPT(DFN,.11),U,6)
+12 IF '$DATA(^DPT(DFN,.13))
QUIT
+13 SET $PIECE(^DPT(DFN,.33),U,9)=$PIECE(^DPT(DFN,.13),U)
+14 QUIT
ECRELD ;CALLED FROM DGDDC RTN WHICH IS CALLED BY XREF ON FIELD .331 OF ^DPT
+1 SET $PIECE(^AUPNPAT(DFN,31),"^",2)=""
+2 QUIT
