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

AGED.m

Go to the documentation of this file. 
  1. AGED ; IHS/ASDS/EFG - EDITOR MAIN ROUTINE ; MAR 19, 2010   
  1.  ;;7.1;PATIENT REGISTRATION;**2,4,7,9**;AUG 25, 2005
  1.  ;
  1.  I '$D(IOF) D HOME^%ZIS
  1.  W $$S^AGVDF("IOF"),!
  1.  D PROGVIEW^AGUTILS(DUZ)
  1.  W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
  1.  ;ONLY SHOW PAGE# IF NOT DISPLAYING INS CATEGORY SCREEN
  1.  I '$D(SEQHD) W "  (page ",+AG("PG"),")"
  1.  W ?78-$L($P($G(^DIC(4,DUZ(2),0)),U)),$P($G(^DIC(4,DUZ(2),0)),U)
  1.  S $P(AGLINE("-"),"-",81)=""
  1.  S $P(AGLINE("EQ"),"=",81)=""
  1.  W !,AGLINE("EQ")
  1.  I '$D(AGPAT) S AGPAT=$P($G(^DPT(DFN,0)),U)
  1.  D CHKNPP^AG,CHKRHI^AG
  1.  I '$D(RHIFLAG) W !,AGPAT
  1.  I $D(RHIFLAG)  D
  1.  . I RHIFLAG'="A" W !,AGPAT
  1.  . I $D(RHIFLAG)  D
  1.  . I RHIFLAG="A" W !,$$S^AGVDF("RVN"),AGPAT,$$S^AGVDF("BLN")," (RHI)",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
  1.  ;W ?36,$$DTEST^AGUTILS(DFN)
  1.  W ?27,$$DTEST^AGUTILS(DFN)  ;AG*7.1*4
  1.  I $D(AGCHRT) W ?55,"HRN:",AGCHRT
  1.  I AG("PG")>1 D
  1.  . ; GET ELIGIBILITY STATUS
  1.  . S AGELSTS=$P($G(^AUPNPAT(DFN,11)),U,12)
  1.  . W ?66,$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PEND. VERIF",1:"NONE")
  1.  W !,AGLINE("EQ")
  1.  G:AG("PG")="5BEB"!(AG("PG")="5BEC")!(AG("PG")="5BEA")!(AG("PG")="5BED")!(AG("PG")="5BEF")!(AG("PG")="5BEE")!(AG("PG")="4TPLA")!(AG("PG")="4GUARA")!(AG("PG")="4WCA")!(AG("PG")="4RRA") END
  1.  I AG("PG")'=4 D
  1.  . W !?$P($T(@AG("PG")),";",3),$P($T(@AG("PG")),";",4)
  1.  I AG("PG")=4&('$D(CATHD))  D
  1.  . ;W !?30,"MEDICAL COVERAGE"
  1.  . W !?30,"SUMMARY COVERAGE"  ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 9 PAGE 11
  1.  I AG("PG")=4&($D(CATHD))  D
  1.  . W !?78-$L(CATHD)/2,CATHD
  1. END ;
  1.  K DR,DIE,AG("ED"),AGDTS
  1.  Q
  1. UPDATE ;PEP - CALLED FROM PCC TO UPDATE AGPATCH FILE
  1.  I $D(AG("NOUPDATE")) G END
  1.  D UPDATE1^AGED(DUZ(2),DFN,"","")
  1.  Q  ;generate extrinsic from general call to update
  1. UPDATE1(AGSITE,AGZDFN,AGPTPG,AGGDA)    ;EP - extrinsic here
  1.  I '$D(DIU(0)),DUZ'=.5,'$D(APMFVAR) ;test re-index,filegram,mfi
  1.  E  K AGPTPG,AGZDFN G END
  1.  D NOW^%DTC
  1.  S AGDTS=%
  1.  D ^XBNEW("XBDIE^AGED:AG*") ;call XBDIE fpr nested DIE call
  1.  Q
  1. XBDIE ;NESTED DIE
  1.  S:'$D(^AGPATCH(AGDTS,AGSITE,AGZDFN)) ^AGPATCH(AGDTS,AGSITE,AGZDFN)=""
  1. ZMFI ;
  1.  ;set zmfi node in ^AGPATCH(agdts,site,dfn,zmfi,pg)=da
  1.  I $G(AGPTPG)]"",("N"'[($P($G(^AUTTSITE(1,0)),U,16))) D
  1.  . S ^AGPATCH(AGDTS,AGSITE,AGZDFN,"ZMFI",AGPTPG)=AGGDA
  1.  . K AGPTPG ;add mfi pgs with ien
  1.  S DIE="^AUPNPAT("
  1.  S DR=".03///TODAY"
  1.  S $P(^AUPNPAT(AGZDFN,0),U,12)=DUZ
  1.  S DA=AGZDFN
  1.  D ^DIE
  1.  S DIE="^AUPNPAT("
  1.  S DR=".16///TODAY"
  1.  S DA=AGZDFN
  1.  D ^DIE
  1.  S Y=DT
  1.  D DD^%DT
  1.  S AGUPDT="(upd:"_Y_")"
  1.  ;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL
  1.  S ^XTMP("AGHL7",DUZ(2),DA)=DA  ;AG*7.1*9 - Added DUZ(2) subscript
  1.  S ^XTMP("AGHL7AG",DUZ(2),DA,"UPDATE")=""  ;AG*7.1*9 - Added DUZ(2) subscript
  1.  K AGZDFN,AGPTPG
  1.  G END
  1.  Q
  1.  ;
  1. 1 ;;0;
  1. 2 ;;21;Religion/Tribal Data/Employment
  1. 3 ;;24;Emergency Contact/Next of Kin
  1. 4 ;;30;Medical Sequencing
  1. 5 ;;0;
  1. 6 ;;28;Veteran's Information
  1. 7 ;;26;Death Info/Other Names
  1. 8 ;;0;
  1. 9 ;;23;CHS Eligibility & Document Summary
  1. 10 ;;30;Other Patient Data
  1. 11 ;;0;
  1. BICFLDS ;;35;BIC Fields
  1. SCRN ;;Label DY^Label DX^File Number^Field;;Data Format for drawing EDIT screens.
  1.  ;
  1.  Q