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

AG3.m

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