- AG3 ; IHS/ASDS/EFG - ENTRY UTILITY FOR NON-MANDATORY DATA ;
- ;;7.1;PATIENT REGISTRATION;**2,4**;JAN 31, 2007
- ;
- W !!,">>This option asks all questions one after the other with no escaping<<",!!
- L1 D S1,SSN^AG3A G:$D(DUOUT) S1
- I $D(DUOUT)!(X="") G:AGOPT(14)'="Y" L4 W !,"Without a Social Security Number a BIC cannot be issued - try again!" D S1,SSN^AG3A G S1:$D(DUOUT)
- ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 12 PAGE 11
- ;ASK MARITAL STATUS
- ASKMSTAT ;
- K DIE,DR,DIC,DIR,DA
- S DIE="^DPT("
- S DR=.05
- S DA=AGPATDFN
- D ^DIE
- G:$D(DUOUT)!($D(DTOUT))!($D(DIROUT)) L1
- ;END NEW CODE
- L4 ;D S1,COB^AG3A G L1:$D(DUOUT)
- D S1,COB^AG3A G ASKMSTAT:$D(DUOUT) ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 12 PAGE 11
- L5 D S1,SOB^AG3A G L4:$D(DUOUT)
- ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 5 PAGE 11
- ASKWEB ;
- D WEB^AGED1
- ;END NEW CODE
- L6 ;D S1,ST^AG3A G L5:$D(DUOUT),L10:X=""
- D S1,ST^AG3A G ASKWEB:$D(DUOUT),L10:X="" ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 5 PAGE 11
- L7 D S1,CITY^AG3A G L6:$D(DUOUT)
- L8 D S1,STATE^AG3A G L7:$D(DUOUT)
- L9 D S1,ZIP^AG3A G L8:$D(DUOUT)
- L10 D S1,HPH^AG3A G L9:$D(DUOUT)
- ;BAR*71.*4 SCR D151
- W !!
- W !,$G(NEWST)
- W !,$G(NEWCITY),",",$G(NEWSTATE)," ",$G(NEWZIP)
- W !,$G(NEWHPH)
- W !!
- N DUOUT,DTOUT,DFOUT
- K DIR
- S DIR(0)="YO"
- S DIR("A")="Is this address correct"
- S DIR("B")="Y"
- D ^DIR
- G:'Y!$D(DTOUT)!$D(DUOUT)!$D(DIRUT) L6
- W !!,"Adding to PREVIOUS MAIL ADDRESSES FIELD...." H 2
- D UPDTHADD^AGUTILS(DFN,"N") ;N SIGNIFIES THIS IS AN EDIT AND NOT A POST INSTALL FORCE
- ;END BAR*7.1*4
- L11 D S1,OPH^AG3A G L10:$D(DUOUT)
- L11A D S1,MSGPH^AGED1 G L11:$D(DUOUT) ;IHS/SD/TPF 3/13/2008 AG*7.1*4 SCR
- L12OPT I AGOPT(3)="Y" D S1,ALIAS^AGOPT2 G L11:$D(DUOUT) I 1
- E G L11:$D(DUOUT)
- G ^AG4
- S1 K DFOUT,DTOUT,DUOUT,DLOUT,DQOUT Q
- DUOUT ;EP
- G L12OPT
- AG3 ; IHS/ASDS/EFG - ENTRY UTILITY FOR NON-MANDATORY DATA ;
- +1 ;;7.1;PATIENT REGISTRATION;**2,4**;JAN 31, 2007
- +2 ;
- +3 WRITE !!,">>This option asks all questions one after the other with no escaping<<",!!
- L1 DO S1
- DO SSN^AG3A
- IF $DATA(DUOUT)
- GOTO S1
- +1 IF $DATA(DUOUT)!(X="")
- IF AGOPT(14)'="Y"
- GOTO L4
- WRITE !,"Without a Social Security Number a BIC cannot be issued - try again!"
- DO S1
- DO SSN^AG3A
- IF $DATA(DUOUT)
- GOTO S1
- +2 ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 12 PAGE 11
- +3 ;ASK MARITAL STATUS
- ASKMSTAT ;
- +1 KILL DIE,DR,DIC,DIR,DA
- +2 SET DIE="^DPT("
- +3 SET DR=.05
- +4 SET DA=AGPATDFN
- +5 DO ^DIE
- +6 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
- GOTO L1
- +7 ;END NEW CODE
- L4 ;D S1,COB^AG3A G L1:$D(DUOUT)
- +1 ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 12 PAGE 11
- DO S1
- DO COB^AG3A
- IF $DATA(DUOUT)
- GOTO ASKMSTAT
- L5 DO S1
- DO SOB^AG3A
- IF $DATA(DUOUT)
- GOTO L4
- +1 ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 5 PAGE 11
- ASKWEB ;
- +1 DO WEB^AGED1
- +2 ;END NEW CODE
- L6 ;D S1,ST^AG3A G L5:$D(DUOUT),L10:X=""
- +1 ;IHS/SD/TPF 4/24/2006 AG*7.1*2 ITEM 5 PAGE 11
- DO S1
- DO ST^AG3A
- IF $DATA(DUOUT)
- GOTO ASKWEB
- IF X=""
- GOTO L10
- L7 DO S1
- DO CITY^AG3A
- IF $DATA(DUOUT)
- GOTO L6
- L8 DO S1
- DO STATE^AG3A
- IF $DATA(DUOUT)
- GOTO L7
- L9 DO S1
- DO ZIP^AG3A
- IF $DATA(DUOUT)
- GOTO L8
- L10 DO S1
- DO HPH^AG3A
- IF $DATA(DUOUT)
- GOTO L9
- +1 ;BAR*71.*4 SCR D151
- +2 WRITE !!
- +3 WRITE !,$GET(NEWST)
- +4 WRITE !,$GET(NEWCITY),",",$GET(NEWSTATE)," ",$GET(NEWZIP)
- +5 WRITE !,$GET(NEWHPH)
- +6 WRITE !!
- +7 NEW DUOUT,DTOUT,DFOUT
- +8 KILL DIR
- +9 SET DIR(0)="YO"
- +10 SET DIR("A")="Is this address correct"
- +11 SET DIR("B")="Y"
- +12 DO ^DIR
- +13 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
- GOTO L6
- +14 WRITE !!,"Adding to PREVIOUS MAIL ADDRESSES FIELD...."
- HANG 2
- +15 ;N SIGNIFIES THIS IS AN EDIT AND NOT A POST INSTALL FORCE
- DO UPDTHADD^AGUTILS(DFN,"N")
- +16 ;END BAR*7.1*4
- L11 DO S1
- DO OPH^AG3A
- IF $DATA(DUOUT)
- GOTO L10
- L11A ;IHS/SD/TPF 3/13/2008 AG*7.1*4 SCR
- DO S1
- DO MSGPH^AGED1
- IF $DATA(DUOUT)
- GOTO L11
- L12OPT IF AGOPT(3)="Y"
- DO S1
- DO ALIAS^AGOPT2
- IF $DATA(DUOUT)
- GOTO L11
- IF 1
- +1 IF '$TEST
- IF $DATA(DUOUT)
- GOTO L11
- +2 GOTO ^AG4
- S1 KILL DFOUT,DTOUT,DUOUT,DLOUT,DQOUT
- QUIT
- DUOUT ;EP
- +1 GOTO L12OPT
