AG8A.m

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