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

AG8.m

Go to the documentation of this file.
  1. AG8 ; IHS/ADSS/EFG - ENTRY UTILITY FOR NON-MANDATORY DATA ;
  1. ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
  1. L1 D S1,REL^AG8A G DUOUT^AG7:$D(DUOUT)
  1. L2 D S1,FNAME^AG8A G L1:$D(DUOUT),L6:X=""
  1. L4 D S1,FCOB^AG8A G L2:$D(DUOUT)
  1. L5 D S1,FSOB^AG8A G L4:$D(DUOUT)
  1. D S1,FEMP^AG8A
  1. L6 D S1,MNAME^AG8A G L5:$D(DUOUT),L81:X=""
  1. L7 D S1,MCOB^AG8A G L6:$D(DUOUT)
  1. L8 D S1,MSOB^AG8A G L7:$D(DUOUT)
  1. D S1,MEMP^AG8A
  1. L81 ;IF PATIENT IS UNDER 18, PARENT EMPLOYER ENTRY IS REQUIRED
  1. I $$AGE^AUPNPAT(DFN)<18,$P($G(^AUPNPAT(DFN,27)),U)="",$P($G(^AUPNPAT(DFN,27)),U,2)="" W !!,"PATIENT IS A MINOR AND MUST HAVE FATHER'S OR MOTHER'S EMPLOYER ENTERED" H 2 G L2
  1. L9 D S1,ECNAME^AG8A G L8:$D(DUOUT),L16:X=""
  1. L10 D S1,ECREL^AG8A G L9:$D(DUOUT)
  1. L11 D S1,ECSTR^AG8A G L10:$D(DUOUT),L15:X=""
  1. L12 D S1,ECCITY^AG8A G L11:$D(DUOUT)
  1. L13 D S1,ECST^AG8A G L12:$D(DUOUT)
  1. L14 D S1,ECZIP^AG8A G L13:$D(DUOUT)
  1. L15 D S1,ECPH^AG8A G L14:$D(DUOUT)
  1. L16 D S1,EMPLR^AGED2 G L15:$D(DUOUT)
  1. L17 D S1,SPSEMP^AGED2 G L16:$D(DUOUT)
  1. END1 I AGOPT(7)'="Y" G ADD^AGED9
  1. N1 D S1,NKNAME^AG8B G L17:$D(DUOUT),END2:'$D(X),END2:X=""
  1. N2 D S1,NKREL^AG8B G N1:$D(DUOUT)
  1. N3 D S1,NKSTR^AG8B G N2:$D(DUOUT)
  1. N4 D S1,NKCITY^AG8B G N3:$D(DUOUT)
  1. N5 D S1,NKST^AG8B G N4:$D(DUOUT)
  1. N6 D S1,NKZIP^AG8B G N5:$D(DUOUT)
  1. N7 D S1,NKPH^AG8B G N6:$D(DUOUT)
  1. END2 G ADD^AGED9
  1. S1 K DFOUT,DTOUT,DUOUT,DLOUT,DQOUT Q
  1. DUOUT G L15:AGOPT(7)'="Y",N7