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

AGED2.m

Go to the documentation of this file. 
  1. AGED2 ; IHS/ASDS/EFG - EDIT PG 2 - RELIGION/TRIBAL DATA/EMPLOYMENT DATA ; MAR 19, 2010
  1.  ;;7.1;PATIENT REGISTRATION;**2,3,7,8,10**;AUG 25, 2005;Build 7
  1.  ;
  1.  ;AG*7.1*7 - Sections of this routine were re-written to accomplish the following:
  1.  ;           1) Modified code to allow for the new page 10
  1.  ;           2) Ethnicity, Race, Internet, and Household Information are now asked on Page 10
  1.  ;              (Edit tags are still located in this routine however)
  1.  ;
  1.  ;AG*7.1*8 - Sections of thsi routine were re-written to accomplish the following:
  1.  ;           1) Added Father/Mother Email/Cell/Alt Phone fields and prompts
  1.  ;           2) Modified code better handle display - line #, tabs, label display/length, field call handling
  1.  ;AG*7.1*10- Put in validity check on user field selection prompt
  1.  N CLLST
  1.  I "YC"[AGOPT(14) S AG("SVELIG")=""
  1.  I $D(^AUPNPAT(DFN,11)) S AG("SVELIG")=$P($G(^AUPNPAT(DFN,11)),U,12)
  1. VAR ;
  1.  ;S CALLS="REL^AG8A,BENED^AG2A,TRIBE^AG2A,TQTM^AGOPT2,IQTM^AG2A,TRINUM^AGOPT2,OTHERT,FATHER,MOTHER,EMPLR,SPSEMP,FEMPL,MEMPL"  ;AG*7.1*7
  1.  D DRAW
  1.  W !,AGLINE("EQ")
  1.  K AG("ER")
  1.  D ^AGDATCK
  1.  ;I ($D(AG("ER",13))!$D(AG("ER","TEMPHRN"))!$D(AG("ER",2))) W *7,!!,"Patient must first have a VALID/permanent HRN prior to editing !" K DIR S DIR(0)="E" D ^DIR S DUOUT=1 K AG("ER") G END
  1.  K AG("ER")
  1.  D:"YC"[AGOPT(14) CKELIG^AGED1 S AGWM=1 D ^AGELCHK W:$D(AG("ER",9)) *7,!,?10,"Corrections are to be made: " K DIR S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE//" D READ
  1.  I $D(MYERRS("C","E")),(Y'?1N.N),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR
  1.  Q:Y=AGOPT("ESCAPE")
  1.  I $D(AG("ER",9)) I (($D(DFOUT))!($D(DLOUT))!(Y["N")!($D(DUOUT))!($D(AG("ED")))) D  G VAR
  1.  . W !,"The corrections must be made !",*7
  1.  G END:$D(DLOUT)!(Y["N")!$D(DUOUT)
  1.  G VAR:$D(AG("ERR"))
  1.  G:$D(AG("ED"))&('$D(AGXTERN)) @("^AGED"_AG("ED"))
  1.  Q:$D(DTOUT)!$D(DFOUT)
  1.  I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
  1.  S AGY=Y
  1.  ;AG*7.1*8 - Replaced existing logic with next 3 lines
  1.  S AGY=Y
  1.  ;AG*7.1*10;Added next line to stop bad user entry errors
  1.  I $TR(AGY,",")'?1N.N W !!,"Invalid entry - Enter a line number or line numbers separated by a ',' to edit" H 3 G VAR
  1.  F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("E"))  D
  1.  . D @(CLLST(AG("SEL")))
  1.  D UPDATE1^AGED(DUZ(2),DFN,2,"")
  1.  G VAR
  1. END ;
  1.  K AG,AGI,AGIO,AGY,CLLST,DLOUT,DQOUT,DFOUT,DTOUT,DA,AGSCRN,Y,QUAN,TRIBE
  1.  K ROUTID
  1.  Q:$D(AGXTERN)
  1.  Q:$D(DIROUT)
  1.  G VAR^AGED1:$D(DUOUT)
  1.  G ^AGED3
  1. ELIG ;
  1.  I AGOPT(14)'="Y" D ELIG^AG2A Q
  1.  W !!,"You can only change a patient's eligibility"
  1.  W !,"by altering their Community of Residence,"
  1.  W !,"Tribe of Membership, or Indian Quantum."
  1.  W !,"Press return to continue"
  1.  W *7
  1.  D READ
  1.  Q
  1. DRAW ;EP
  1.  S CLLST=0
  1.  S CALLS="REL^AG8A,BENED^AG2A,TRIBE^AG2A,TQTM^AGOPT2,IQTM^AG2A,TRINUM^AGOPT2,OTHERT,FATHER,FCPH,FEML,FAPH,MOTHER,MCPH,MEML,MAPH,EMPLR,SPSEMP,FEMPL,MEMPL"  ;AG*7.1*7
  1.  S AG("PG")=2
  1.  S AG("N")=19  ;AG*7.1*8
  1.  S ROUTID=$P($T(+1)," ")  ;SET ROUTINE ID FOR PROGRAMMER VIEW
  1.  S DA=DFN
  1.  D ^AGED                          ;Main editor routine
  1.  K ^UTILITY("DIQ1",$J)
  1.  I AGOPT(14)="Y" D
  1.  . D ^AGBIC2C                     ;Compute eligibility status
  1.  . S DIC=9000001
  1.  . S DR=1124
  1.  . S $P(AGSCRN,";;")=""
  1.  . W !,"1.  ",$P($G(^DD(DIC,DR,0)),U)," :  "
  1.  . W $$GET1^DIQ(DIC,DFN,DR)
  1.  F AG=1:1:AG("N") D
  1.  . N AGSCRN,LBL,LEN,CLM,DIC,DR,VLEN,VALUE  ;AG*7.1*8
  1.  . S AGSCRN=$P($T(@1+AG),";;",2,17)
  1.  . S LBL=$P(AGSCRN,U)           ;AG*7.1*8 - Added LBL,LEN,CLM
  1.  . S LEN=$P(AGSCRN,U,2)
  1.  . S CLM=$P(AGSCRN,U,3)
  1.  . S DIC=$P(AGSCRN,U,4)
  1.  . S DR=$P(AGSCRN,U,5)
  1.  . S VLEN=$P(AGSCRN,U,6)
  1.  . ;
  1.  . ;Prompt position ;AG*7.1*8
  1.  . I CLM="" W !
  1.  . E  W ?CLM
  1.  . ;
  1.  . ;Display Number  ;AG*7.1*8
  1.  . S CLLST=CLLST+1,CLLST(CLLST)=$P(CALLS,",",AG),AG("E")=CLLST
  1.  . W CLLST,". "
  1.  . ;
  1.  . ;Display label  AG*7.1*8
  1.  . W $J(LBL,LEN),": "
  1.  . ;
  1.  . ;D
  1.  . ;. I AG=16,$$GET1^DIQ(9009061,DUZ(2)_",",502,"I") W $E($$GET1^DIQ(DIC,DFN,DR),1,15) Q  ;AG*7.1*8 - Changed AG value to 16
  1.  . S VALUE=$$GET1^DIQ(DIC,DFN,DR)
  1.  . S:VLEN>0 VALUE=$E(VALUE,1,VLEN)
  1.  . W VALUE
  1.  . I AG=3 D
  1.  .. I $P($G(^AUPNPAT(DFN,11)),U,8)'=""  D
  1.  ... S Y=$$GET1^DIQ(DIC,DFN,DR)
  1.  ... D TRBCHK
  1.  . I AG=7,'$D(^AUPNPAT(DFN,43)) D
  1.  .. W ?33,"* NONE LISTED *"
  1.  . I AG=7 D OTHER W !,AGLINE("-")
  1.  . I AG=15 W !,AGLINE("-")  ;AG*7.1*8 - Changed AG value to 15
  1.  ;
  1.  W !,AGLINE("-")
  1.  K MYERRS,MYVARS
  1.  D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
  1.  S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
  1.  D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
  1.  Q
  1. READ ;EP
  1.  K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT
  1.  S DIR("?")="Enter free text"
  1.  S DIR("?",1)="You may enter the item number of the field you wish to edit,"
  1.  S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
  1.  S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
  1.  S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
  1.  S DIR(0)="FO"
  1.  D ^DIR
  1.  Q:$D(DTOUT)
  1.  S:Y="/.,"!(Y="^^") DFOUT=""
  1.  S:Y="" DLOUT=""
  1.  S:Y="^" (DUOUT,Y)=""
  1.  S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
  1.  Q:Y="P"
  1.  I $E(Y,1)="p" S $E(Y,1)="P"
  1.  I $E(Y,1)="P"&($P($G(^AUPNPAT(DFN,11)),U,12)'="") D
  1.  . S AG("ED")=+$P($E(Y,2,99),".")
  1.  . I AG("ED")<1!(AG("ED")>10) D  ;AG*7.1*7
  1.  .. W *7,!!,"Use only pages 1 through 10."  ;AG*7.1*7
  1.  .. H 2
  1.  .. K AG("ED")
  1.  .. S AG("ERR")=""
  1.  . I $D(AG("ED"))  D
  1.  .. I AG("ED")>0&(AG("ED")<11)  D  ;AG*7.1*7
  1.  ... I AG("ED")=4 S AG("ED")="4A"
  1.  ... I AG("ED")=5 S AG("ED")="BEA"
  1.  ... I AG("ED")=6 S AG("ED")=13
  1.  ... I AG("ED")=8 S AG("ED")=11
  1.  ... I AG("ED")=7 S AG("ED")=8
  1.  ... I AG("ED")=9 S AG("ED")="11A"
  1.  ... I AG("ED")=10 S AG("ED")="10A"  ;AG*7.1*7
  1.  Q
  1. TRBCHK ;
  1.  I $P($G(^AUTTTRI($O(^AUTTTRI("B",$E(Y,1,30),0)),0)),U,4)="Y" D  Q
  1.  . W:$X<50 ?50
  1.  . W:$X>50 !?33
  1.  . W $$S^AGVDF("RVN"),"(OLD UNUSED TRIBE NAME)",$$S^AGVDF("RVF")
  1.  I $P($G(^AUTTTRI($O(^AUTTTRI("B",$E(Y,1,30),0)),0)),U,2)=999 D  Q
  1.  . W $$S^AGVDF("RVN")," <- PLEASE SPECIFY IF KNOWN",$$S^AGVDF("RVF")
  1.  I "YC"[AGOPT(14) D
  1.  . S DR=1119
  1.  . K AGRES
  1.  . S TEMPDIC=DIC
  1.  . S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
  1.  . S DIC=TEMPDIC
  1.  . W $G(AGRES(DIC,DFN,DR,"E"))
  1.  . K AGRES,TEMPDIC,AGRES
  1.  Q
  1. EMPLR ;EP - Patient's Employer.
  1.  S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4)
  1.  W !
  1.  K DIR,DIE,DR,DIC
  1.  S DIE="^AUPNPAT("
  1.  ;IF EMPLOYMENT STATUS FULL OR PART TIME
  1.  I ($P($G(^AUPNPAT(DFN,0)),U,21)=1!($P($G(^AUPNPAT(DFN,0)),U,21)=2)),$$ISREQ^AGFLDREQ(9000001,.19) S DIE("NO^")="",DR=".19R"
  1.  E  S DR=.19
  1.  S DA=DFN
  1.  D ^DIE
  1.  I $P($G(^AUPNPAT(DFN,0)),U,19)="",$P($G(^(0)),U,21)]"","39"'[$P($G(^(0)),U,21) D
  1.  . S DR=".21///@"
  1.  . D ^DIE
  1.  . K DIE,DIC,DR
  1.  Q:$P($G(^AUPNPAT(DFN,0)),U,19)=""
  1.  S AGEL("EMP")=$P($G(^AUPNPAT(DFN,0)),U,19)
  1.  D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
  1. EMST ;GET PATIENT'S EMPLOYMENT STATUS
  1.  W !
  1.  S DIE="^AUPNPAT("
  1.  S DA=DFN
  1.  S DR=.21
  1.  D ^DIE
  1.  K DIC,DR,DIE
  1.  K AGEL("EMP")
  1.  K AGEL("ONUM")
  1.  Q
  1. EMPL ;
  1.  S DIE="^AUTNEMPL("
  1.  S DA=AGEL("EMP")
  1.  W !!,"<----------EMPLOYER DEMOGRAPHIC INFO---------->"
  1.  S DR=".02 Street...: ;.03 City.....: ;.04 State....: ;.05 Zip......: ;.06 Phone....: ;.07 Abbrev...: "
  1.  D ^DIE
  1.  Q
  1. SPSEMP ;EP - Spouse's Employer.
  1.  S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4)
  1.  W !
  1.  S DIE="^AUPNPAT("
  1.  S DR=.22
  1.  S DA=DFN
  1.  D ^DIE
  1.  Q:$P($G(^AUPNPAT(DFN,0)),U,22)=""
  1.  S AGEL("EMP")=$P($G(^AUPNPAT(DFN,0)),U,22)
  1.  D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
  1.  K AGEL("EMP")
  1.  K AGEL("ONUM")
  1.  K DIE,DIC,DR
  1.  Q
  1. FEMPL ;FATHER'S EMPLOYER INFO
  1.  S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4) ;NUMBER OF ENTRIES IN FILE
  1.  W !
  1.  S DIE="^AUPNPAT("
  1.  I $$AGE^AUPNPAT(DFN)>17 S DR=2701
  1.  I $$AGE^AUPNPAT(DFN)<18,$P($G(^AUPNPAT(DFN,27)),U,2)="" S DR="2701R"
  1.  E  S DR=2701
  1.  S DA=DFN
  1.  D ^DIE
  1.  Q:$P($G(^AUPNPAT(DFN,27)),U)=""
  1.  S AGEL("EMP")=$P($G(^AUPNPAT(DFN,27)),U)
  1.  D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
  1.  K AGEL("EMP")
  1.  K AGEL("ONUM")
  1.  K DIE,DIC,DR
  1.  Q
  1. MEMPL ;MOTHER'S EMPLOYER INFO
  1.  K DIE,DIC,DR
  1.  S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4) ;# OF ENTRIES IN FILE
  1.  W !
  1.  S DIE="^AUPNPAT("
  1.  I $$AGE^AUPNPAT(DFN)>17 S DR=2702
  1.  I $$AGE^AUPNPAT(DFN)<18,$P($G(^AUPNPAT(DFN,27)),U)="" S DR="2702R"
  1.  E  S DR=2702
  1.  S DA=DFN
  1.  D ^DIE
  1.  Q:$P($G(^AUPNPAT(DFN,27)),U,2)=""
  1.  S AGEL("EMP")=$P($G(^AUPNPAT(DFN,27)),U,2)
  1.  D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
  1.  K AGEL("EMP")
  1.  K AGEL("ONUM")
  1.  K DIE,DIC,DR
  1.  Q
  1. OTHER ;DISPLAY LAST OTHER TRIBE AND QUANTUM
  1.  S D1=0
  1.  S TRIBE="",QUAN=""
  1.  F  S D1=$O(^AUPNPAT(DFN,43,D1)) Q:'D1  D
  1.  . S TRIBE=$P($G(^AUTTTRI($P($G(^AUPNPAT(DFN,43,D1,0)),U),0)),U)
  1.  . S QUAN=$P($G(^AUPNPAT(DFN,43,D1,0)),U,2)
  1.  W ?32,TRIBE
  1.  W ?73,$E(QUAN,1,6)
  1.  Q
  1. OTHERT ;ALLOW ADD AND EDIT OF OTHER TRIBES AND QUANTUMS
  1.  Q:AGOPT(8)'="Y"
  1.  W !!,"OTHER TRIBES:",?50,"QUANTUM:",!
  1.  S D1=0
  1.  F  S D1=$O(^AUPNPAT(DFN,43,D1)) Q:'D1  D
  1.  . S TRIPTR=$P($G(^AUPNPAT(DFN,43,D1,0)),U)
  1.  . S OTRIBE=$P($G(^AUTTTRI(TRIPTR,0)),U)
  1.  . S OQUAN=$P($G(^AUPNPAT(DFN,43,D1,0)),U,2)
  1.  . W !,OTRIBE,?50,OQUAN
  1.  W !!
  1.  K DIC,DIE,DR
  1.  S DIE="^AUPNPAT("
  1.  S DR=4301
  1.  S DA=DFN
  1.  D ^DIE
  1.  D UPDATE1^AGED(DUZ(2),DFN,12,"")
  1.  I '$O(^AUPNPAT(DFN,43,0)) K ^AUPNPAT(DFN,43)
  1.  K DIC,DIE,DR
  1.  Q
  1. FATHER ;GET FATHER'S NAME, CITY AND STATE OF BIRTH
  1.  K DUOUT
  1.  K DIE
  1.  S DIE="^DPT("
  1.  S DA=DFN
  1.  W !
  1.  S DR=.2401
  1.  D ^DIE
  1.  S:$D(Y) DUOUT=""
  1.  K DIE,DIC,DR,DUOUT
  1.  I $P($G(^DPT(DFN,.24)),U)="" D
  1.  . I $P($G(^AUPNPAT(DFN,26)),U,2)'="" S $P(^AUPNPAT(DFN,26),U,2)=""
  1.  . I $P($G(^AUPNPAT(DFN,26)),U,3)'="" S $P(^AUPNPAT(DFN,26),U,3)=""
  1.  I $P($G(^DPT(DFN,.24)),U)'="" D
  1.  . S DIE="^AUPNPAT("
  1.  . W !
  1.  . S DR="2602;2603"
  1.  . D ^DIE
  1.  . S:$D(Y) DUOUT=""
  1.  . K DIE,DIC,DR
  1.  Q
  1.  ;
  1. MOTHER ;GET MOTHER'S NAME, CITY AND STATE OF BIRTH
  1.  K DUOUT,DIE
  1.  S DIE="^DPT("
  1.  S DA=DFN
  1.  W !
  1.  S DR=.2403
  1.  D ^DIE
  1.  S:$D(Y) DUOUT=""
  1.  K DUOUT
  1.  I $P($G(^DPT(DFN,.24)),U,3)="" D
  1.  . I $P($G(^AUPNPAT(DFN,26)),U,5)'="" S $P(^AUPNPAT(DFN,26),U,5)=""
  1.  . I $P($G(^AUPNPAT(DFN,26)),U,6)'="" S $P(^AUPNPAT(DFN,26),U,6)=""
  1.  I $P($G(^DPT(DFN,.24)),U,3)'="" D
  1.  . S DIE="^AUPNPAT("
  1.  . W !
  1.  . S DR="2605;2606"
  1.  . D ^DIE
  1.  . S:$D(Y) DUOUT=""
  1.  . K DIE,DIC,DR
  1.  Q
  1.  ;
  1.  ;AG*7.1*8 - Added FCPH, FEML, FAPH, MCPH, MEML, MAPH, and DIE tags
  1.  ;
  1. FCPH ;EP - Edit Father's Cell Phone
  1.  N DR
  1.  S DR=2903
  1.  D DIE
  1.  Q
  1.  ;
  1. FEML ;EP - Edit Father's Email Address
  1.  N DR
  1.  S DR=2901
  1.  D DIE
  1.  Q
  1.  ;
  1. FAPH ;EP - Edit Father's Alternate Phone
  1.  N DR
  1.  S DR="2902FATHER'S ALT. PHONE"
  1.  D DIE
  1.  Q
  1.  ;
  1. MCPH ;EP - Edit Mother's Cell Phone
  1.  N DR
  1.  S DR=3003
  1.  D DIE
  1.  Q
  1.  ;
  1. MEML ;EP - Edit Mother's Email Address
  1.  N DR
  1.  S DR=3001
  1.  D DIE
  1.  Q
  1.  ;
  1. MAPH ;EP - Edit Mother's Alternate Phone
  1.  N DR
  1.  S DR="3002MOTHER'S ALT. PHONE"
  1.  D DIE
  1.  Q
  1.  ;
  1. DIE ; Do Field Edit
  1.  N DA,DIE,DUOUT
  1.  S DIE="^AUPNPAT("
  1.  S DA=DFN
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;AG*7.1*8 - Added Father/Mother Cell phone/Email/Alt Phone
  1.  ;
  1.  ; ****************************************************************
  1.  ; ON LINES BELOW:
  1.  ; PIECE 1= FLD LBL
  1.  ; PIECE 2= FLD LENGTH
  1.  ; PIECE 3= POSITION ON LINE TO DISP FLD, IF BLANK NEW LINE
  1.  ; PIECE 4= FILE #
  1.  ; PIECE 5= FLD #
  1.  ; PIECE 6= Length (optional)
  1. 1 ;
  1.  ;;RELIGIOUS PREFERENCE ^27^^2^.08
  1.  ;;CLASSIFICATION/BENEFICIARY ^27^^9000001^1111
  1.  ;;TRIBE OF MEMBERSHIP ^27^^9000001^1108
  1.  ;;TRIBE QUANTUM ^14^^9000001^1109
  1.  ;;INDIAN BLOOD QUANTUM ^^40^9000001^1110
  1.  ;;TRIBAL ENROLLMENT NO. ^27^^9000001^.07
  1.  ;;OTHER TRIBE ^27^^9000001^4301
  1.  ;;FATHER'S NAME ^14^^2^.2401^29
  1.  ;;CELL PHONE^12^49^9000001^2903
  1.  ;;EMAIL ADDRESS^12^^9000001^2901^29
  1.  ;;ALT.PHONE^11^49^9000001^2902
  1.  ;;MOTHER'S MAIDEN NAME ^21^^2^.2403^20
  1.  ;;CELL PHONE^12^48^9000001^3003
  1.  ;;EMAIL ADDRESS^12^^9000001^3001^29
  1.  ;;ALT.PHONE^11^49^9000001^3002
  1.  ;;EMPLOYER NAME ^27^^9000001^.19
  1.  ;;SPOUSE'S EMPLOYER NAME ^27^^9000001^.22
  1.  ;;FATHER'S EMPLOYER NAME ^27^^9000001^2701
  1.  ;;MOTHER'S EMPLOYER NAME ^27^^9000001^2702