DG_53_P841.KID

KIDS Distribution saved on Aug 09, 2011@15:48:36
PUBLIC LAW 3.6 (8/9/11)
**KIDS**:DG*5.3*841^IB*2.0*454^

**INSTALL NAME**
DG*5.3*841
"BLD",8189,0)
DG*5.3*841^REGISTRATION^0^3110809^y
"BLD",8189,4,0)
^9.64PA^^
"BLD",8189,6)
1^
"BLD",8189,6.3)
7
"BLD",8189,"KRN",0)
^9.67PA^779.2^20
"BLD",8189,"KRN",.4,0)
.4
"BLD",8189,"KRN",.401,0)
.401
"BLD",8189,"KRN",.402,0)
.402
"BLD",8189,"KRN",.403,0)
.403
"BLD",8189,"KRN",.5,0)
.5
"BLD",8189,"KRN",.84,0)
.84
"BLD",8189,"KRN",3.6,0)
3.6
"BLD",8189,"KRN",3.8,0)
3.8
"BLD",8189,"KRN",9.2,0)
9.2
"BLD",8189,"KRN",9.8,0)
9.8
"BLD",8189,"KRN",9.8,"NM",0)
^9.68A^13^13
"BLD",8189,"KRN",9.8,"NM",1,0)
DGENA^^0^B20613434
"BLD",8189,"KRN",9.8,"NM",2,0)
DGENELA^^0^B27857025
"BLD",8189,"KRN",9.8,"NM",3,0)
DGENELA1^^0^B78071004
"BLD",8189,"KRN",9.8,"NM",4,0)
DGENPTA^^0^B40976431
"BLD",8189,"KRN",9.8,"NM",5,0)
DGENPTA1^^0^B22181053
"BLD",8189,"KRN",9.8,"NM",6,0)
DGENU^^0^B44311306
"BLD",8189,"KRN",9.8,"NM",7,0)
DGENUPL3^^0^B75053019
"BLD",8189,"KRN",9.8,"NM",8,0)
DGENA1A^^0^B15415989
"BLD",8189,"KRN",9.8,"NM",9,0)
DGENELA4^^0^B69534652
"BLD",8189,"KRN",9.8,"NM",10,0)
DGENUPL4^^0^B67002910
"BLD",8189,"KRN",9.8,"NM",11,0)
DGRP6^^0^B15906836
"BLD",8189,"KRN",9.8,"NM",12,0)
DGENL1^^0^B69443276
"BLD",8189,"KRN",9.8,"NM",13,0)
DGMTR^^0^B68219377
"BLD",8189,"KRN",9.8,"NM","B","DGENA",1)

"BLD",8189,"KRN",9.8,"NM","B","DGENA1A",8)

"BLD",8189,"KRN",9.8,"NM","B","DGENELA",2)

"BLD",8189,"KRN",9.8,"NM","B","DGENELA1",3)

"BLD",8189,"KRN",9.8,"NM","B","DGENELA4",9)

"BLD",8189,"KRN",9.8,"NM","B","DGENL1",12)

"BLD",8189,"KRN",9.8,"NM","B","DGENPTA",4)

"BLD",8189,"KRN",9.8,"NM","B","DGENPTA1",5)

"BLD",8189,"KRN",9.8,"NM","B","DGENU",6)

"BLD",8189,"KRN",9.8,"NM","B","DGENUPL3",7)

"BLD",8189,"KRN",9.8,"NM","B","DGENUPL4",10)

"BLD",8189,"KRN",9.8,"NM","B","DGMTR",13)

"BLD",8189,"KRN",9.8,"NM","B","DGRP6",11)

"BLD",8189,"KRN",19,0)
19
"BLD",8189,"KRN",19.1,0)
19.1
"BLD",8189,"KRN",101,0)
101
"BLD",8189,"KRN",409.61,0)
409.61
"BLD",8189,"KRN",771,0)
771
"BLD",8189,"KRN",779.2,0)
779.2
"BLD",8189,"KRN",870,0)
870
"BLD",8189,"KRN",8989.51,0)
8989.51
"BLD",8189,"KRN",8989.52,0)
8989.52
"BLD",8189,"KRN",8994,0)
8994
"BLD",8189,"KRN","B",.4,.4)

"BLD",8189,"KRN","B",.401,.401)

"BLD",8189,"KRN","B",.402,.402)

"BLD",8189,"KRN","B",.403,.403)

"BLD",8189,"KRN","B",.5,.5)

"BLD",8189,"KRN","B",.84,.84)

"BLD",8189,"KRN","B",3.6,3.6)

"BLD",8189,"KRN","B",3.8,3.8)

"BLD",8189,"KRN","B",9.2,9.2)

"BLD",8189,"KRN","B",9.8,9.8)

"BLD",8189,"KRN","B",19,19)

"BLD",8189,"KRN","B",19.1,19.1)

"BLD",8189,"KRN","B",101,101)

"BLD",8189,"KRN","B",409.61,409.61)

"BLD",8189,"KRN","B",771,771)

"BLD",8189,"KRN","B",779.2,779.2)

"BLD",8189,"KRN","B",870,870)

"BLD",8189,"KRN","B",8989.51,8989.51)

"BLD",8189,"KRN","B",8989.52,8989.52)

"BLD",8189,"KRN","B",8994,8994)

"BLD",8189,"QUES",0)
^9.62^^
"BLD",8189,"REQB",0)
^9.611^9^5
"BLD",8189,"REQB",1,0)
DG*5.3*688^2
"BLD",8189,"REQB",6,0)
DG*5.3*840^2
"BLD",8189,"REQB",7,0)
DG*5.3*797^2
"BLD",8189,"REQB",8,0)
DG*5.3*754^2
"BLD",8189,"REQB",9,0)
DG*5.3*838^2
"BLD",8189,"REQB","B","DG*5.3*688",1)

"BLD",8189,"REQB","B","DG*5.3*754",8)

"BLD",8189,"REQB","B","DG*5.3*797",7)

"BLD",8189,"REQB","B","DG*5.3*838",9)

"BLD",8189,"REQB","B","DG*5.3*840",6)

"MBREQ")
0
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
841^3110809^123456989
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
13
"RTN","DGENA")
0^1^B20613434
"RTN","DGENA",1,0)
DGENA ;ALB/CJM,ISA/KWP,Zoltan,LBD,CKN,EG,ERC,TDM - Enrollment API - Retrieve Data ; 3/3/11 3:36pm
"RTN","DGENA",2,0)
 ;;5.3;Registration;**121,122,147,232,314,564,672,659,653,688,841**;Aug 13, 1993;Build 7
"RTN","DGENA",3,0)
 ;
"RTN","DGENA",4,0)
FINDCUR(DFN) ;
"RTN","DGENA",5,0)
 ;Description: Used to find a patients current enrollment.
"RTN","DGENA",6,0)
 ;Input :
"RTN","DGENA",7,0)
 ;  DFN - Patient IEN
"RTN","DGENA",8,0)
 ;Output:
"RTN","DGENA",9,0)
 ;  Function Value - returns the internal entry number of the patient's
"RTN","DGENA",10,0)
 ;     current enrollment if there is one, NULL otherwise. Checks that
"RTN","DGENA",11,0)
 ;     current enrollment actually belongs to the patient.
"RTN","DGENA",12,0)
 ;
"RTN","DGENA",13,0)
 Q:'$G(DFN) ""
"RTN","DGENA",14,0)
 ;
"RTN","DGENA",15,0)
 N CUR
"RTN","DGENA",16,0)
 S CUR=$P($G(^DPT(DFN,"ENR")),"^")
"RTN","DGENA",17,0)
 I CUR,$P($G(^DGEN(27.11,CUR,0)),"^",2)'=DFN S CUR=""
"RTN","DGENA",18,0)
 Q CUR
"RTN","DGENA",19,0)
 ;
"RTN","DGENA",20,0)
FINDPRI(DGENRIEN) ;
"RTN","DGENA",21,0)
 ;Description: Used to obtain a patient's  enrollment record that was
"RTN","DGENA",22,0)
 ;     prior to the enrollment identified by DGENRIEN.
"RTN","DGENA",23,0)
 ;Input :
"RTN","DGENA",24,0)
 ;  DGENRIEN - this is the internal entry number of a PATIENT ENROLLMENT
"RTN","DGENA",25,0)
 ;     record
"RTN","DGENA",26,0)
 ;Output:
"RTN","DGENA",27,0)
 ;  Function Value - returns the internal entry number of the prior
"RTN","DGENA",28,0)
 ;     enrollment for the patient if there is one, NULL otherwise.
"RTN","DGENA",29,0)
 ;
"RTN","DGENA",30,0)
 Q:'$G(DGENRIEN) ""
"RTN","DGENA",31,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",9)
"RTN","DGENA",32,0)
 ;
"RTN","DGENA",33,0)
ENROLLED(DFN) ;
"RTN","DGENA",34,0)
 ;Description: Returns whether the patient is currently enrolled.
"RTN","DGENA",35,0)
 ;Input:
"RTN","DGENA",36,0)
 ;  DFN - Patient IEN
"RTN","DGENA",37,0)
 ;Output:
"RTN","DGENA",38,0)
 ;  Function Value - returns 1 if the patient is currently enrolled with
"RTN","DGENA",39,0)
 ;     a status of VERIFIED, 0 otherwise
"RTN","DGENA",40,0)
 ;
"RTN","DGENA",41,0)
 N STATUS
"RTN","DGENA",42,0)
 S STATUS=$$STATUS($G(DFN))
"RTN","DGENA",43,0)
 I (STATUS=2) Q 1
"RTN","DGENA",44,0)
 Q 0
"RTN","DGENA",45,0)
 ;
"RTN","DGENA",46,0)
STATUS(DFN) ;
"RTN","DGENA",47,0)
 ;Description: Returns ENROLLMENT STATUS from the patient's current
"RTN","DGENA",48,0)
 ;     enrollment.
"RTN","DGENA",49,0)
 ;Input:
"RTN","DGENA",50,0)
 ;  DFN -  Patient IEN
"RTN","DGENA",51,0)
 ;Output:
"RTN","DGENA",52,0)
 ;  Function Value - If the patient has a current ENROLLMENT STATUS this
"RTN","DGENA",53,0)
 ;     function will return its value, otherwise it returns NULL.
"RTN","DGENA",54,0)
 N DGENRIEN
"RTN","DGENA",55,0)
 S DGENRIEN=$$FINDCUR($G(DFN))
"RTN","DGENA",56,0)
 Q:'DGENRIEN ""
"RTN","DGENA",57,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",4)
"RTN","DGENA",58,0)
 ;
"RTN","DGENA",59,0)
PRIORITY(DFN) ;
"RTN","DGENA",60,0)
 ;Description: Returns ENROLLMENT PRIORITY from the patient's current
"RTN","DGENA",61,0)
 ;     enrollment.
"RTN","DGENA",62,0)
 ;Input:
"RTN","DGENA",63,0)
 ;  DFN -  Patient IEN
"RTN","DGENA",64,0)
 ;Output:
"RTN","DGENA",65,0)
 ;  Function Value - If the patient has a current ENROLLMENT PRIORITY
"RTN","DGENA",66,0)
 ;     this function will return its value, otherwise it returns NULL.
"RTN","DGENA",67,0)
 N DGENRIEN
"RTN","DGENA",68,0)
 S DGENRIEN=$$FINDCUR($G(DFN))
"RTN","DGENA",69,0)
 Q:'DGENRIEN ""
"RTN","DGENA",70,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",7)
"RTN","DGENA",71,0)
 ;
"RTN","DGENA",72,0)
SOURCE(DFN) ;
"RTN","DGENA",73,0)
 ;Description: Returns SOURCE OF ENROLLMENT from the patient's current
"RTN","DGENA",74,0)
 ;     enrollment.
"RTN","DGENA",75,0)
 ;Input:
"RTN","DGENA",76,0)
 ;  DFN -  Patient IEN
"RTN","DGENA",77,0)
 ;Output:
"RTN","DGENA",78,0)
 ;  Function Value - If the patient has a current ENROLLMENT 
"RTN","DGENA",79,0)
 ;     this function will return the SOURCE OF ENROLLMENT, otherwise
"RTN","DGENA",80,0)
 ;     it returns NULL.
"RTN","DGENA",81,0)
 ;
"RTN","DGENA",82,0)
 N DGENRIEN
"RTN","DGENA",83,0)
 S DGENRIEN=$$FINDCUR($G(DFN))
"RTN","DGENA",84,0)
 Q:'DGENRIEN ""
"RTN","DGENA",85,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",3)
"RTN","DGENA",86,0)
 ;
"RTN","DGENA",87,0)
GET(DGENRIEN,DGENR) ;
"RTN","DGENA",88,0)
 ;Description: Used to obtain a record from the Patient Enrollment file
"RTN","DGENA",89,0)
 ;     into the local DGENR array.
"RTN","DGENA",90,0)
 ;Input :
"RTN","DGENA",91,0)
 ;  DGENRIEN - this is the internal entry number of a PATIENT ENROLLMENT record
"RTN","DGENA",92,0)
 ;Output:
"RTN","DGENA",93,0)
 ;  Function  Value - returns 1 on success, 0 on failure.
"RTN","DGENA",94,0)
 ;  DGENR - this is the name of  a local array, it should be passed by
"RTN","DGENA",95,0)
 ;     reference. If the function is successful this array will
"RTN","DGENA",96,0)
 ;     contain the enrollment.
"RTN","DGENA",97,0)
 ;
"RTN","DGENA",98,0)
 ;      subscript      field name
"RTN","DGENA",99,0)
 ;     "APP"           Enrollment Applicaiton Date
"RTN","DGENA",100,0)
 ;     "DATE"          Enrollment Date
"RTN","DGENA",101,0)
 ;     "END"          Enrollment End Date
"RTN","DGENA",102,0)
 ;     "DFN"           Patient IEN
"RTN","DGENA",103,0)
 ;     "SOURCE"        Enrollment Source
"RTN","DGENA",104,0)
 ;     "STATUS"        Enrollment Status
"RTN","DGENA",105,0)
 ;     "REASON"        Reason Canceled/Declined
"RTN","DGENA",106,0)
 ;     "REMARKS"       Canceled/Declined Remarks
"RTN","DGENA",107,0)
 ;     "FACREC"        Facility Received
"RTN","DGENA",108,0)
 ;     "PRIORITY"      Enrollment Priority
"RTN","DGENA",109,0)
 ;     "SUBGRP"        Enrollment Sub-Group
"RTN","DGENA",110,0)
 ;     "EFFDATE"       Effective Date
"RTN","DGENA",111,0)
 ;     "PRIORREC"      Prior Enrollment Record
"RTN","DGENA",112,0)
 ;     "ELIG","CODE"            Primary Eligibility Code
"RTN","DGENA",113,0)
 ;     "ELIG","CODE",<code ien> Eligibility Codes
"RTN","DGENA",114,0)
 ;     "ELIG","SC"              Service Connected
"RTN","DGENA",115,0)
 ;     "ELIG","SCPER"           Service Connected Percentage
"RTN","DGENA",116,0)
 ;     "ELIG","POW"             POW Status Indicated
"RTN","DGENA",117,0)
 ;     "ELIG","A&A"             Receiving A&A Benefits
"RTN","DGENA",118,0)
 ;     "ELIG","HB"              Receiving Housebound Benefits
"RTN","DGENA",119,0)
 ;     "ELIG","VAPEN"           Receiving a VA Pension
"RTN","DGENA",120,0)
 ;     "ELIG","VACKAMT"         Total Annual VA Check Amount
"RTN","DGENA",121,0)
 ;     "ELIG","DISRET"          Military Disability Retirement
"RTN","DGENA",122,0)
 ;     "ELIG","DISLOD"          Discharged Due to Disability
"RTN","DGENA",123,0)
 ;     "ELIG","MEDICAID"        Medicaid
"RTN","DGENA",124,0)
 ;     "ELIG","AO"              Exposed to Agent Orange
"RTN","DGENA",125,0)
 ;     "ELIG","AOEXPLOC"        Agent Orange Exposure Location
"RTN","DGENA",126,0)
 ;     "ELIG","IR"              Radiation Exposure Indicated
"RTN","DGENA",127,0)
 ;     "ELIG","RADEXPM"         Radiation Exposure Method
"RTN","DGENA",128,0)
 ;     "ELIG","EC"              SW Asia Cond - was Env Con, DG*5.3*688
"RTN","DGENA",129,0)
 ;     "ELIG","MTSTA"           Means Test Status
"RTN","DGENA",130,0)
 ;     "ELIG","VCD"             Veteran Catastrophically Disabled?
"RTN","DGENA",131,0)
 ;     "ELIG","PH"              Purple Heart Indicated?
"RTN","DGENA",132,0)
 ;     "ELIG","UNEMPLOY"        Unemployable
"RTN","DGENA",133,0)
 ;     "ELIG","CVELEDT"         Combat Veteran End Date
"RTN","DGENA",134,0)
 ;     "ELIG","SHAD"            SHAD Indicated
"RTN","DGENA",135,0)
 ;     "ELIG","MOH"             Medal of Honor Indicated
"RTN","DGENA",136,0)
 ;     "DATETIME"      Date/Time Entered
"RTN","DGENA",137,0)
 ;     "USER"          Entered By
"RTN","DGENA",138,0)
 ;    
"RTN","DGENA",139,0)
 N SUB,NODE
"RTN","DGENA",140,0)
 I '$G(DGENRIEN) Q 0
"RTN","DGENA",141,0)
 I '$D(^DGEN(27.11,DGENRIEN,0)) Q 0
"RTN","DGENA",142,0)
 K DGENR
"RTN","DGENA",143,0)
 S DGENR=""
"RTN","DGENA",144,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,0))
"RTN","DGENA",145,0)
 S DGENR("APP")=$P(NODE,"^")
"RTN","DGENA",146,0)
 S DGENR("DATE")=$P(NODE,"^",10)
"RTN","DGENA",147,0)
 S DGENR("END")=$P(NODE,"^",11)
"RTN","DGENA",148,0)
 S DGENR("DFN")=$P(NODE,"^",2)
"RTN","DGENA",149,0)
 S DGENR("SOURCE")=$P(NODE,"^",3)
"RTN","DGENA",150,0)
 S DGENR("STATUS")=$P(NODE,"^",4)
"RTN","DGENA",151,0)
 S DGENR("REASON")=$P(NODE,"^",5)
"RTN","DGENA",152,0)
 S DGENR("FACREC")=$P(NODE,"^",6)
"RTN","DGENA",153,0)
 S DGENR("PRIORITY")=$P(NODE,"^",7)
"RTN","DGENA",154,0)
 S DGENR("EFFDATE")=$P(NODE,"^",8)
"RTN","DGENA",155,0)
 S DGENR("PRIORREC")=$P(NODE,"^",9)
"RTN","DGENA",156,0)
 ;Phase II Get enrollment sub-grp (SRS 6.4)
"RTN","DGENA",157,0)
 S DGENR("SUBGRP")=$P(NODE,"^",12)
"RTN","DGENA",158,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,"R"))
"RTN","DGENA",159,0)
 S DGENR("REMARKS")=$P(NODE,"^")
"RTN","DGENA",160,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,"E"))
"RTN","DGENA",161,0)
 S DGENR("ELIG","CODE")=$P(NODE,"^")
"RTN","DGENA",162,0)
 S DGENR("ELIG","SC")=$P(NODE,"^",2)
"RTN","DGENA",163,0)
 S DGENR("ELIG","SCPER")=$P(NODE,"^",3)
"RTN","DGENA",164,0)
 S DGENR("ELIG","POW")=$P(NODE,"^",4)
"RTN","DGENA",165,0)
 S DGENR("ELIG","A&A")=$P(NODE,"^",5)
"RTN","DGENA",166,0)
 S DGENR("ELIG","HB")=$P(NODE,"^",6)
"RTN","DGENA",167,0)
 S DGENR("ELIG","VAPEN")=$P(NODE,"^",7)
"RTN","DGENA",168,0)
 S DGENR("ELIG","VACKAMT")=$P(NODE,"^",8)
"RTN","DGENA",169,0)
 S DGENR("ELIG","DISRET")=$P(NODE,"^",9)
"RTN","DGENA",170,0)
 S DGENR("ELIG","DISLOD")=$P(NODE,"^",20)  ;added with DG*5.3*672
"RTN","DGENA",171,0)
 S DGENR("ELIG","MEDICAID")=$P(NODE,"^",10)
"RTN","DGENA",172,0)
 S DGENR("ELIG","AO")=$P(NODE,"^",11)
"RTN","DGENA",173,0)
 S DGENR("ELIG","AOEXPLOC")=$P(NODE,"^",22)  ;added with DG*5.3*688
"RTN","DGENA",174,0)
 S DGENR("ELIG","IR")=$P(NODE,"^",12)
"RTN","DGENA",175,0)
 S DGENR("ELIG","EC")=$P(NODE,"^",13)
"RTN","DGENA",176,0)
 S DGENR("ELIG","MTSTA")=$P(NODE,"^",14)
"RTN","DGENA",177,0)
 S DGENR("ELIG","VCD")=$P(NODE,"^",15)
"RTN","DGENA",178,0)
 S DGENR("ELIG","PH")=$P(NODE,"^",16)
"RTN","DGENA",179,0)
 S DGENR("ELIG","UNEMPLOY")=$P(NODE,"^",17)
"RTN","DGENA",180,0)
 S DGENR("ELIG","CVELEDT")=$P(NODE,"^",18)
"RTN","DGENA",181,0)
 S DGENR("ELIG","SHAD")=$P(NODE,"^",19)
"RTN","DGENA",182,0)
 S DGENR("ELIG","RADEXPM")=$P(NODE,"^",21)
"RTN","DGENA",183,0)
 S DGENR("ELIG","MOH")=$P(NODE,"^",23)
"RTN","DGENA",184,0)
 ;S DGENCDZZ=1 ; for CD Testing (disabled).
"RTN","DGENA",185,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,"U"))
"RTN","DGENA",186,0)
 S DGENR("DATETIME")=$P(NODE,"^")
"RTN","DGENA",187,0)
 S DGENR("USER")=$P(NODE,"^",2)
"RTN","DGENA",188,0)
 Q 1
"RTN","DGENA",189,0)
 ;
"RTN","DGENA1A")
0^8^B15415989
"RTN","DGENA1A",1,0)
DGENA1A ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TDM - Enrollment API - File Data Continued ; 5/10/11 12:03pm
"RTN","DGENA1A",2,0)
 ;;5.3;Registration;**121,147,232,314,564,672,659,653,688,841**;Aug 13,1993;Build 7
"RTN","DGENA1A",3,0)
 ;
"RTN","DGENA1A",4,0)
KILLALL(DGENRIEN) ;
"RTN","DGENA1A",5,0)
 ;kills all x-refs on the record in the Patient Enrollment file
"RTN","DGENA1A",6,0)
 ;pointed to by DGENRIEN
"RTN","DGENA1A",7,0)
 ;
"RTN","DGENA1A",8,0)
 N DGENR,SUB,VALUE
"RTN","DGENA1A",9,0)
 Q:'$G(DGENRIEN)
"RTN","DGENA1A",10,0)
 Q:'$$GET^DGENA(DGENRIEN,.DGENR)
"RTN","DGENA1A",11,0)
 S SUB=""
"RTN","DGENA1A",12,0)
 F  S SUB=$O(DGENR(SUB)) Q:SUB=""  D
"RTN","DGENA1A",13,0)
 .Q:(SUB="ELIG")
"RTN","DGENA1A",14,0)
 .Q:DGENR(SUB)=""
"RTN","DGENA1A",15,0)
 .D KILL(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR(SUB))
"RTN","DGENA1A",16,0)
 S SUB=""
"RTN","DGENA1A",17,0)
 F  S SUB=$O(DGENR("ELIG",SUB)) Q:SUB=""  D
"RTN","DGENA1A",18,0)
 .Q:DGENR("ELIG",SUB)=""
"RTN","DGENA1A",19,0)
 .D KILL(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR("ELIG",SUB))
"RTN","DGENA1A",20,0)
 Q
"RTN","DGENA1A",21,0)
 ;
"RTN","DGENA1A",22,0)
SETALL(DGENRIEN,DGENR) ;
"RTN","DGENA1A",23,0)
 ;Sets all x-refs on the record in the Patient Enrollment file.
"RTN","DGENA1A",24,0)
 ;Inputs:
"RTN","DGENA1A",25,0)
 ;  DGENRIEN - ptr to PATIENT ENROLLMENT file
"RTN","DGENA1A",26,0)
 ;  DGENR - array containing the record, pass by reference
"RTN","DGENA1A",27,0)
 ;
"RTN","DGENA1A",28,0)
 N SUB,VALUE
"RTN","DGENA1A",29,0)
 Q:'$G(DGENRIEN)
"RTN","DGENA1A",30,0)
 Q:'$D(DGENR)
"RTN","DGENA1A",31,0)
 ;
"RTN","DGENA1A",32,0)
 S SUB=""
"RTN","DGENA1A",33,0)
 F  S SUB=$O(DGENR(SUB)) Q:SUB=""  D
"RTN","DGENA1A",34,0)
 .Q:(SUB="ELIG")
"RTN","DGENA1A",35,0)
 .Q:DGENR(SUB)=""
"RTN","DGENA1A",36,0)
 .D SET(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR(SUB))
"RTN","DGENA1A",37,0)
 S SUB=""
"RTN","DGENA1A",38,0)
 F  S SUB=$O(DGENR("ELIG",SUB)) Q:SUB=""  D
"RTN","DGENA1A",39,0)
 .Q:DGENR("ELIG",SUB)=""
"RTN","DGENA1A",40,0)
 .D SET(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR("ELIG",SUB))
"RTN","DGENA1A",41,0)
 Q
"RTN","DGENA1A",42,0)
 ;
"RTN","DGENA1A",43,0)
KILL(FILE,IEN,FIELD,VALUE) ;
"RTN","DGENA1A",44,0)
 ;executes all the kill logic for x-refs on the field=FIELD for the
"RTN","DGENA1A",45,0)
 ;record=DGENRIEN for the file=FILE for the field value=VALUE
"RTN","DGENA1A",46,0)
 ;
"RTN","DGENA1A",47,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGENA1A",48,0)
 S DA=IEN,X=VALUE,DGIX=0
"RTN","DGENA1A",49,0)
 F  S DGIX=$O(^DD(FILE,FIELD,1,DGIX)) Q:'DGIX  X ^(DGIX,2) S X=VALUE
"RTN","DGENA1A",50,0)
 Q
"RTN","DGENA1A",51,0)
 ;
"RTN","DGENA1A",52,0)
SET(FILE,IEN,FIELD,VALUE) ;
"RTN","DGENA1A",53,0)
 ;executes all the set logic for x-refs on the field=FIELD for the
"RTN","DGENA1A",54,0)
 ;record=DGENRIEN for the file=FILE for the field value=VALUE
"RTN","DGENA1A",55,0)
 ;
"RTN","DGENA1A",56,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGENA1A",57,0)
 S DA=IEN,X=VALUE,DGIX=0
"RTN","DGENA1A",58,0)
 F  S DGIX=$O(^DD(FILE,FIELD,1,DGIX)) Q:'DGIX  X ^(DGIX,1)
"RTN","DGENA1A",59,0)
 Q
"RTN","DGENA1A",60,0)
 ;
"RTN","DGENA1A",61,0)
EDIT(DA,DGENR) ;
"RTN","DGENA1A",62,0)
 ;Description: Overlays a currently existing record, ien=DA, with values
"RTN","DGENA1A",63,0)
 ;     from DGENR array
"RTN","DGENA1A",64,0)
 ;Input -
"RTN","DGENA1A",65,0)
 ;  DA - ien of record in Patient Enrollment file
"RTN","DGENA1A",66,0)
 ;  DGENR - array containing an enrollment, pass by reference
"RTN","DGENA1A",67,0)
 ;Output - 1 on success, 0 on failure
"RTN","DGENA1A",68,0)
 ;
"RTN","DGENA1A",69,0)
 ; *** NOTE: This is called from within FM.  There is a problem in ***
"RTN","DGENA1A",70,0)
 ; *** that ^DIE can not be used.  Instead, the fields             ***
"RTN","DGENA1A",71,0)
 ; *** are hard-set and cross-referenced.                          ***
"RTN","DGENA1A",72,0)
 ;
"RTN","DGENA1A",73,0)
 N NODE
"RTN","DGENA1A",74,0)
 Q:'$G(DA) 0
"RTN","DGENA1A",75,0)
 S NODE=$G(^DGEN(27.11,$G(DA),0))
"RTN","DGENA1A",76,0)
 Q:NODE="" 0
"RTN","DGENA1A",77,0)
 ;
"RTN","DGENA1A",78,0)
 ;kill off all the cross-references (FM doesn't have an API to do this)
"RTN","DGENA1A",79,0)
 D KILLALL(DA)
"RTN","DGENA1A",80,0)
 ;
"RTN","DGENA1A",81,0)
 ;now hand-set all the fields
"RTN","DGENA1A",82,0)
 ;Phase II Add subgroup to the 12 piece (SRS 6.4)
"RTN","DGENA1A",83,0)
 S NODE=DGENR("APP")_U_DGENR("DFN")_U_DGENR("SOURCE")_U_DGENR("STATUS")_U_DGENR("REASON")_U_DGENR("FACREC")_U_DGENR("PRIORITY")_U_DGENR("EFFDATE")_U_DGENR("PRIORREC")_U_DGENR("DATE")_U_DGENR("END")_U_DGENR("SUBGRP")
"RTN","DGENA1A",84,0)
 S ^DGEN(27.11,DA,0)=NODE
"RTN","DGENA1A",85,0)
 S ^DGEN(27.11,DA,"R")=DGENR("REMARKS")
"RTN","DGENA1A",86,0)
 S NODE=DGENR("ELIG","CODE")
"RTN","DGENA1A",87,0)
 S NODE=NODE_U_DGENR("ELIG","SC")
"RTN","DGENA1A",88,0)
 S NODE=NODE_U_DGENR("ELIG","SCPER")
"RTN","DGENA1A",89,0)
 S NODE=NODE_U_DGENR("ELIG","POW")
"RTN","DGENA1A",90,0)
 S NODE=NODE_U_DGENR("ELIG","A&A")
"RTN","DGENA1A",91,0)
 S NODE=NODE_U_DGENR("ELIG","HB")
"RTN","DGENA1A",92,0)
 S NODE=NODE_U_DGENR("ELIG","VAPEN")
"RTN","DGENA1A",93,0)
 S NODE=NODE_U_DGENR("ELIG","VACKAMT")
"RTN","DGENA1A",94,0)
 S NODE=NODE_U_DGENR("ELIG","DISRET")
"RTN","DGENA1A",95,0)
 S NODE=NODE_U_DGENR("ELIG","MEDICAID")
"RTN","DGENA1A",96,0)
 S NODE=NODE_U_DGENR("ELIG","AO")
"RTN","DGENA1A",97,0)
 S NODE=NODE_U_DGENR("ELIG","IR")
"RTN","DGENA1A",98,0)
 S NODE=NODE_U_DGENR("ELIG","EC")  ;changed to SW Asia Cond - DG*5.3*688
"RTN","DGENA1A",99,0)
 S NODE=NODE_U_DGENR("ELIG","MTSTA")
"RTN","DGENA1A",100,0)
 S NODE=NODE_U_DGENR("ELIG","VCD")
"RTN","DGENA1A",101,0)
 S NODE=NODE_U_DGENR("ELIG","PH")
"RTN","DGENA1A",102,0)
 S NODE=NODE_U_DGENR("ELIG","UNEMPLOY")
"RTN","DGENA1A",103,0)
 S NODE=NODE_U_DGENR("ELIG","CVELEDT")
"RTN","DGENA1A",104,0)
 S NODE=NODE_U_DGENR("ELIG","SHAD") ;field added with DG*5.3*653
"RTN","DGENA1A",105,0)
 S NODE=NODE_U_DGENR("ELIG","DISLOD") ;field added with DG*5.3*672
"RTN","DGENA1A",106,0)
 S NODE=NODE_U_DGENR("ELIG","RADEXPM")
"RTN","DGENA1A",107,0)
 S NODE=NODE_U_DGENR("ELIG","AOEXPLOC") ;field added with DG*5.3*688
"RTN","DGENA1A",108,0)
 S NODE=NODE_U_DGENR("ELIG","MOH") ;field added with DG*5.3*841
"RTN","DGENA1A",109,0)
 S ^DGEN(27.11,DA,"E")=NODE
"RTN","DGENA1A",110,0)
 S ^DGEN(27.11,DA,"U")=DGENR("DATETIME")_U_DGENR("USER")
"RTN","DGENA1A",111,0)
 ;
"RTN","DGENA1A",112,0)
 ;set the x-refs
"RTN","DGENA1A",113,0)
 D SETALL(DA,.DGENR)
"RTN","DGENA1A",114,0)
 Q 1
"RTN","DGENELA")
0^2^B27857025
"RTN","DGENELA",1,0)
DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN,ERC,TDM - Patient Eligibility API ; 3/3/11 3:40pm
"RTN","DGENELA",2,0)
 ;;5.3;Registration;**121,147,232,314,451,564,631,672,659,583,653,688,841**;Aug 13,1993;Build 7
"RTN","DGENELA",3,0)
 ;
"RTN","DGENELA",4,0)
GET(DFN,DGELG) ;
"RTN","DGENELA",5,0)
 ;Description: Used to obtain the patient eligibility data.
"RTN","DGENELA",6,0)
 ;  The data is placed in the local DGELG array.
"RTN","DGENELA",7,0)
 ;Input:
"RTN","DGENELA",8,0)
 ;  DFN - internal entry number of a record in the PATIENT file
"RTN","DGENELA",9,0)
 ;Output:
"RTN","DGENELA",10,0)
 ;  Function Value - returns 1 on success, 0 on failure
"RTN","DGENELA",11,0)
 ;  DGELG - this is  a local array that will be used to return patient eligibility data. The array subscripts and the fields mapped to are defined below. (pass by reference)
"RTN","DGENELA",12,0)
 ;
"RTN","DGENELA",13,0)
 ;subscript             field name
"RTN","DGENELA",14,0)
 ;"DFN"                ien Patient record
"RTN","DGENELA",15,0)
 ;"ELIG","CODE"        Primary Eligibility Code
"RTN","DGENELA",16,0)
 ;"ELIG","CODE",<ien>  Patient Eligibilities
"RTN","DGENELA",17,0)
 ;"SC"                 Service Connected
"RTN","DGENELA",18,0)
 ;"SCPER"              Service Connected Percentage
"RTN","DGENELA",19,0)
 ;"EFFDT"              SC Combined Effective Date
"RTN","DGENELA",20,0)
 ;"POW"                POW Status Indicated
"RTN","DGENELA",21,0)
 ;"A&A"                Receiving A&A Benefits
"RTN","DGENELA",22,0)
 ;"HB"                 Receiving Housebound Benefits
"RTN","DGENELA",23,0)
 ;"VAPEN"              Receiving a VA Pension
"RTN","DGENELA",24,0)
 ;"VACKAMT"            Total Annual VA Check Amount
"RTN","DGENELA",25,0)
 ;"DISRET"             Military Disability Retirement
"RTN","DGENELA",26,0)
 ;"DISLOD"             Discharge Due to Disability (added with DG 672)
"RTN","DGENELA",27,0)
 ;"MEDICAID"           Medicaid
"RTN","DGENELA",28,0)
 ;"MEDASKDT"           Date Medicaid Last Asked
"RTN","DGENELA",29,0)
 ;"AO"                 Exposed to Agent Orange
"RTN","DGENELA",30,0)
 ;"IR"                 Radiation Exposure Indicated
"RTN","DGENELA",31,0)
 ;"RADEXPM"            Radiation Exposure Method
"RTN","DGENELA",32,0)
 ;"EC"                 SW Asia Cond - change from Env Con, DG*5.3*688
"RTN","DGENELA",33,0)
 ;"MTSTA"              Means Test Status
"RTN","DGENELA",34,0)
 ;P&T                  P&T
"RTN","DGENELA",35,0)
 ;P&TDT                P&T EFFECTIVE DATE (added with DG 688)
"RTN","DGENELA",36,0)
 ;POS                  PERIOD OF SERVICE
"RTN","DGENELA",37,0)
 ;UNEMPLOY             UNEMPLOYABLE
"RTN","DGENELA",38,0)
 ;SCAWDATE             SC AWARD DATE
"RTN","DGENELA",39,0)
 ;RATEINC              RATED INCOMPETENT
"RTN","DGENELA",40,0)
 ;CLAIMNUM             CLAIM NUMBER
"RTN","DGENELA",41,0)
 ;CLAIMLOC             CLAIM FOLDER LOCATION
"RTN","DGENELA",42,0)
 ;VADISAB              RECEIVING VA DISABILITY?
"RTN","DGENELA",43,0)
 ;ELIGSTA              ELIGIBILITY STATUS
"RTN","DGENELA",44,0)
 ;ELIGSTADATE          ELIGIBILITY STATUS DATE
"RTN","DGENELA",45,0)
 ;ELIGVERIF            ELIGIBILITY VERIF. METHOD
"RTN","DGENELA",46,0)
 ;ELIGVSITE            ELIGIBILITY VERIFICATION SITE
"RTN","DGENELA",47,0)
 ;ELIGENTBY            ELIGIBILITY STATUS ENTERED BY
"RTN","DGENELA",48,0)
 ;RATEDIS
"RTN","DGENELA",49,0)
 ;  <COUNT>,"RD"      RATED DISABILITY
"RTN","DGENELA",50,0)
 ;  <COUNT>,"PER"      DISABILITY %
"RTN","DGENELA",51,0)
 ;  <COUNT>,"RDSC"     SERVICE CONNECTED
"RTN","DGENELA",52,0)
 ;  <COUNT>,"RDEXT"    EXTREMITY
"RTN","DGENELA",53,0)
 ;  <COUNT>,"RDORIG"   ORIGINAL RD EFFECTIVE DATE
"RTN","DGENELA",54,0)
 ;  <COUNT>."RDCURR"   CURRENT RD EFFECTIVE DATE
"RTN","DGENELA",55,0)
 ;"VCD"               Veteran Catastrophically Disabled? (#.39)
"RTN","DGENELA",56,0)
 ;"PH"                PURPLE HEART INDICATED
"RTN","DGENELA",57,0)
 ;"AOEXPLOC"          AGENT ORANGE EXPOSURE LOCATION
"RTN","DGENELA",58,0)
 ;"CVELEDT"           COMBAT VETERAN END DATE
"RTN","DGENELA",59,0)
 ;"SHAD"              SHAD EXPOSURE
"RTN","DGENELA",60,0)
 ;"MOH"               MEDAL OF HONOR
"RTN","DGENELA",61,0)
 ;
"RTN","DGENELA",62,0)
 K DGELG
"RTN","DGENELA",63,0)
 S DGELG=""
"RTN","DGENELA",64,0)
 Q:'$D(^DPT(DFN)) 0
"RTN","DGENELA",65,0)
 N NODE,SUBREC,COUNT,CODE,IEN
"RTN","DGENELA",66,0)
 ;
"RTN","DGENELA",67,0)
 S DGELG("DFN")=DFN
"RTN","DGENELA",68,0)
 S DGELG("VCD")=$$VCD^DGENA5(DFN)
"RTN","DGENELA",69,0)
 ;
"RTN","DGENELA",70,0)
 ;
"RTN","DGENELA",71,0)
 S NODE=$G(^DPT(DFN,.29))
"RTN","DGENELA",72,0)
 S DGELG("RATEINC")=$P(NODE,"^",12)
"RTN","DGENELA",73,0)
 ;
"RTN","DGENELA",74,0)
 S NODE=$G(^DPT(DFN,.3))
"RTN","DGENELA",75,0)
 S DGELG("SC")=$P(NODE,"^")
"RTN","DGENELA",76,0)
 S DGELG("SCPER")=$P(NODE,"^",2)
"RTN","DGENELA",77,0)
 S DGELG("P&T")=$P(NODE,"^",4)
"RTN","DGENELA",78,0)
 S DGELG("P&TDT")=$P(NODE,"^",13)
"RTN","DGENELA",79,0)
 S DGELG("UNEMPLOY")=$P(NODE,"^",5)
"RTN","DGENELA",80,0)
 S DGELG("SCAWDATE")=$P(NODE,"^",12)
"RTN","DGENELA",81,0)
 S DGELG("VADISAB")=$P(NODE,"^",11)
"RTN","DGENELA",82,0)
 S DGELG("EFFDT")=$P(NODE,"^",14)
"RTN","DGENELA",83,0)
 ;
"RTN","DGENELA",84,0)
 S NODE=$G(^DPT(DFN,.31))
"RTN","DGENELA",85,0)
 S DGELG("CLAIMNUM")=$P(NODE,"^",3)
"RTN","DGENELA",86,0)
 S DGELG("CLAIMLOC")=$P(NODE,"^",4)
"RTN","DGENELA",87,0)
 ;
"RTN","DGENELA",88,0)
 S NODE=$G(^DPT(DFN,.32))
"RTN","DGENELA",89,0)
 S DGELG("POS")=$P(NODE,"^",3)
"RTN","DGENELA",90,0)
 ;
"RTN","DGENELA",91,0)
 S NODE=$G(^DPT(DFN,.36))
"RTN","DGENELA",92,0)
 S DGELG("ELIG","CODE")=$P(NODE,"^") ;primary eligibility
"RTN","DGENELA",93,0)
 S DGELG("DISRET")=$P(NODE,"^",12)
"RTN","DGENELA",94,0)
 S DGELG("DISLOD")=$P(NODE,"^",13)
"RTN","DGENELA",95,0)
 ;
"RTN","DGENELA",96,0)
 S NODE=$G(^DPT(DFN,.38))
"RTN","DGENELA",97,0)
 S DGELG("MEDICAID")=$P(NODE,"^")
"RTN","DGENELA",98,0)
 S DGELG("MEDASKDT")=$P(NODE,"^",2) ;Date Medicaid Last Asked
"RTN","DGENELA",99,0)
 ;
"RTN","DGENELA",100,0)
 S NODE=$G(^DPT(DFN,.361))
"RTN","DGENELA",101,0)
 S DGELG("ELIGSTA")=$P(NODE,"^")
"RTN","DGENELA",102,0)
 S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
"RTN","DGENELA",103,0)
 S DGELG("ELIGVERIF")=$P(NODE,"^",5)
"RTN","DGENELA",104,0)
 S DGELG("ELIGENTBY")=$P(NODE,"^",6)
"RTN","DGENELA",105,0)
 ;
"RTN","DGENELA",106,0)
 S NODE=$G(^DPT(DFN,.362))
"RTN","DGENELA",107,0)
 S DGELG("VACKAMT")=$P(NODE,"^",20)
"RTN","DGENELA",108,0)
 S DGELG("VAPEN")=$P(NODE,"^",14)
"RTN","DGENELA",109,0)
 S DGELG("A&A")=$P(NODE,"^",12)
"RTN","DGENELA",110,0)
 S DGELG("HB")=$P(NODE,"^",13)
"RTN","DGENELA",111,0)
 ;
"RTN","DGENELA",112,0)
 ;
"RTN","DGENELA",113,0)
 S NODE=$G(^DPT(DFN,.321))
"RTN","DGENELA",114,0)
 S DGELG("AO")=$P(NODE,"^",2)
"RTN","DGENELA",115,0)
 S DGELG("IR")=$P(NODE,"^",3)
"RTN","DGENELA",116,0)
 S DGELG("RADEXPM")=$P(NODE,"^",12)
"RTN","DGENELA",117,0)
 S DGELG("AOEXPLOC")=$P(NODE,"^",13)
"RTN","DGENELA",118,0)
 S DGELG("SHAD")=$P(NODE,"^",15)  ;added with DG*5.3*653
"RTN","DGENELA",119,0)
 ;
"RTN","DGENELA",120,0)
 S NODE=$G(^DPT(DFN,.322))
"RTN","DGENELA",121,0)
 S DGELG("EC")=$P(NODE,"^",13)
"RTN","DGENELA",122,0)
 ;
"RTN","DGENELA",123,0)
 S NODE=$G(^DPT(DFN,.52))
"RTN","DGENELA",124,0)
 S DGELG("POW")=$P(NODE,"^",5)
"RTN","DGENELA",125,0)
 S DGELG("CVELEDT")=$P(NODE,"^",15)
"RTN","DGENELA",126,0)
 ;
"RTN","DGENELA",127,0)
 ; Purple Heart Indicator
"RTN","DGENELA",128,0)
 S NODE=$G(^DPT(DFN,.53))
"RTN","DGENELA",129,0)
 S DGELG("PH")=$P(NODE,"^")
"RTN","DGENELA",130,0)
 ;
"RTN","DGENELA",131,0)
 ; Medal of Honor Indicator
"RTN","DGENELA",132,0)
 S NODE=$G(^DPT(DFN,.54))
"RTN","DGENELA",133,0)
 S DGELG("MOH")=$P(NODE,"^")
"RTN","DGENELA",134,0)
 ;
"RTN","DGENELA",135,0)
 ;means test category
"RTN","DGENELA",136,0)
 S DGELG("MTSTA")=""
"RTN","DGENELA",137,0)
 S IEN=$P($$LST^DGMTU(DFN),"^")
"RTN","DGENELA",138,0)
 I IEN S DGELG("MTSTA")=$P($G(^DGMT(408.31,IEN,0)),"^",3)
"RTN","DGENELA",139,0)
 ;
"RTN","DGENELA",140,0)
 ;get the other eligibilities multiple
"RTN","DGENELA",141,0)
 S SUBREC=0
"RTN","DGENELA",142,0)
 F  S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC  D
"RTN","DGENELA",143,0)
 .S CODE=+$G(^DPT(DFN,"E",SUBREC,0))
"RTN","DGENELA",144,0)
 .;
"RTN","DGENELA",145,0)
 .;need to check the "B" x-ref, because when a code is deleted from the multiple, the kill logic is executed BEFORE the data is actually removed - but the "B" x-ref has been deleted at this point
"RTN","DGENELA",146,0)
 .I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC
"RTN","DGENELA",147,0)
 ;
"RTN","DGENELA",148,0)
 ;rated disability multiple
"RTN","DGENELA",149,0)
 S SUBREC=0,COUNT=0
"RTN","DGENELA",150,0)
 F  S SUBREC=$O(^DPT(DFN,.372,SUBREC)) Q:'SUBREC  D
"RTN","DGENELA",151,0)
 .S NODE=$G(^DPT(DFN,.372,SUBREC,0))
"RTN","DGENELA",152,0)
 .Q:'$P(NODE,"^")
"RTN","DGENELA",153,0)
 .S COUNT=COUNT+1
"RTN","DGENELA",154,0)
 .S DGELG("RATEDIS",COUNT,"RD")=$P(NODE,"^")
"RTN","DGENELA",155,0)
 .S DGELG("RATEDIS",COUNT,"PER")=$P(NODE,"^",2)
"RTN","DGENELA",156,0)
 .S DGELG("RATEDIS",COUNT,"RDSC")=$P(NODE,"^",3)
"RTN","DGENELA",157,0)
 .S DGELG("RATEDIS",COUNT,"RDEXT")=$P(NODE,"^",4)
"RTN","DGENELA",158,0)
 .S DGELG("RATEDIS",COUNT,"RDORIG")=$P(NODE,"^",5)
"RTN","DGENELA",159,0)
 .S DGELG("RATEDIS",COUNT,"RDCURR")=$P(NODE,"^",6)
"RTN","DGENELA",160,0)
 ;
"RTN","DGENELA",161,0)
 Q 1
"RTN","DGENELA",162,0)
 ;
"RTN","DGENELA",163,0)
NATNAME(CODE) ;
"RTN","DGENELA",164,0)
 ;Description: Given an entry in file #8, Eligibility Code file,
"RTN","DGENELA",165,0)
 ;  finds the corresponding entry in file 8.1, MAS Eligbility Code file,
"RTN","DGENELA",166,0)
 ;  and returns the name
"RTN","DGENELA",167,0)
 ;Input:
"RTN","DGENELA",168,0)
 ;  CODE - pointer to file #8
"RTN","DGENELA",169,0)
 ;Output:
"RTN","DGENELA",170,0)
 ;  Function Value - name of corresponding code in file #8.1
"RTN","DGENELA",171,0)
 ;
"RTN","DGENELA",172,0)
 Q:'$G(CODE) ""
"RTN","DGENELA",173,0)
 Q $$CODENAME($P($G(^DIC(8,CODE,0)),"^",9))
"RTN","DGENELA",174,0)
 ;
"RTN","DGENELA",175,0)
NATCODE(CODE) ;
"RTN","DGENELA",176,0)
 ;Description: Given an entry in file #8, Eligibility Code file,
"RTN","DGENELA",177,0)
 ;  finds the corresponding entry in file 8.1, MAS Eligbility Code file
"RTN","DGENELA",178,0)
 ;Input:
"RTN","DGENELA",179,0)
 ;  CODE - pointer to file #8
"RTN","DGENELA",180,0)
 ;Output:
"RTN","DGENELA",181,0)
 ;  Function Value - pointer to file #8.1
"RTN","DGENELA",182,0)
 ;
"RTN","DGENELA",183,0)
 Q:'$G(CODE) ""
"RTN","DGENELA",184,0)
 Q $P($G(^DIC(8,CODE,0)),"^",9)
"RTN","DGENELA",185,0)
 ;
"RTN","DGENELA",186,0)
CODENAME(CODE) ;
"RTN","DGENELA",187,0)
 ;Description: Given a pointer to file #8.1, MAS Eligibility Code file,
"RTN","DGENELA",188,0)
 ;  it returns the name of the code 
"RTN","DGENELA",189,0)
 ;Input:
"RTN","DGENELA",190,0)
 ;  CODE - pointer to file #8.1
"RTN","DGENELA",191,0)
 ;Output:
"RTN","DGENELA",192,0)
 ;  Function Value - name of the code pointed to
"RTN","DGENELA",193,0)
 ;
"RTN","DGENELA",194,0)
 Q:'$G(CODE) ""
"RTN","DGENELA",195,0)
 Q $P($G(^DIC(8.1,CODE,0)),"^")
"RTN","DGENELA",196,0)
 ;
"RTN","DGENELA",197,0)
ELIGSTAT(DFN,DGELG) ;
"RTN","DGENELA",198,0)
 ;Description: Used to get the ELIGIBILITY STATUS and the 
"RTN","DGENELA",199,0)
 ;ELIGIBILITY STATUS DATE of the patient.
"RTN","DGENELA",200,0)
 ;
"RTN","DGENELA",201,0)
 ;Input:
"RTN","DGENELA",202,0)
 ;  DFN - ien of patient record
"RTN","DGENELA",203,0)
 ;
"RTN","DGENELA",204,0)
 ;Ouput:
"RTN","DGENELA",205,0)
 ;  Function Value - 1 on success, 0 on failure
"RTN","DGENELA",206,0)
 ;  DGELG array (pass by reference)
"RTN","DGENELA",207,0)
 ;    "ELIGSTA" - ELIGIBILITY STATUS
"RTN","DGENELA",208,0)
 ;    "ELIGSTADATE" - ELIGIBILITY STATUS DATE
"RTN","DGENELA",209,0)
 ;
"RTN","DGENELA",210,0)
 N NODE,SUCCESS
"RTN","DGENELA",211,0)
 D
"RTN","DGENELA",212,0)
 .S SUCCESS=1
"RTN","DGENELA",213,0)
 .I '$G(DFN) S SUCCESS=0 Q
"RTN","DGENELA",214,0)
 .S NODE=$G(^DPT(DFN,.361))
"RTN","DGENELA",215,0)
 .S DGELG("ELIGSTA")=$P(NODE,"^")
"RTN","DGENELA",216,0)
 .S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
"RTN","DGENELA",217,0)
 Q SUCCESS
"RTN","DGENELA1")
0^3^B78071004
"RTN","DGENELA1",1,0)
DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ; 3/3/11 3:38pm
"RTN","DGENELA1",2,0)
 ;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653,688,841**;Aug 13,1993;Build 7
"RTN","DGENELA1",3,0)
 ;
"RTN","DGENELA1",4,0)
CHECK(DGELG,DGPAT,DGCDIS,ERRMSG) ;
"RTN","DGENELA1",5,0)
 ;Does validation checks on the eligibility contained in the DGELG array.
"RTN","DGENELA1",6,0)
 ;
"RTN","DGENELA1",7,0)
 ;Input:
"RTN","DGENELA1",8,0)
 ;  DGELG - array containing eligibility data (pass by reference)
"RTN","DGENELA1",9,0)
 ;  DGPAT - array containing patient data (pass by reference)
"RTN","DGENELA1",10,0)
 ;  DGCDIS - array containing catastrophic disability determination (pass by reference)
"RTN","DGENELA1",11,0)
 ;
"RTN","DGENELA1",12,0)
 ;Output:
"RTN","DGENELA1",13,0)
 ;  Function Value - returns 1 if all validation checks passed, 0 otherwise
"RTN","DGENELA1",14,0)
 ;  ERRMSG - returns a message if validations fail (pass by reference)
"RTN","DGENELA1",15,0)
 ;
"RTN","DGENELA1",16,0)
 N SUCCESS,NATCODE,BAD,SUB,CODE,DGONV,DGTEXT,INELDATE
"RTN","DGENELA1",17,0)
 S SUCCESS=0
"RTN","DGENELA1",18,0)
 S ERRMSG=""
"RTN","DGENELA1",19,0)
 ;
"RTN","DGENELA1",20,0)
 D  ;drops out of block on failure
"RTN","DGENELA1",21,0)
 .;
"RTN","DGENELA1",22,0)
 .;get optional arrays if not there
"RTN","DGENELA1",23,0)
 .I '$D(DGPAT),'$$GET^DGENPTA(DGELG("DFN"),.DGPAT) S ERRMSG="PATIENT NOT FOUND" Q
"RTN","DGENELA1",24,0)
 .I '$D(DGCDIS),'$$GET^DGENCDA(DGELG("DFN"),.DGCDIS) S ERRMSG="PATIENT NOT FOUND" Q
"RTN","DGENELA1",25,0)
 .;
"RTN","DGENELA1",26,0)
 .;do field level checks
"RTN","DGENELA1",27,0)
 .S SUB="" F  S SUB=$O(DGELG(SUB)) Q:(SUB="")  I SUB'="ELIG",SUB'="RATEDIS",'$$CHKFIELD(SUB,DGELG(SUB)) S ERRMSG="BAD VALUE, FIELD = "_$$GET1^DID(2,$$FIELD(SUB),"","LABEL") Q
"RTN","DGENELA1",28,0)
 .;
"RTN","DGENELA1",29,0)
 .Q:(SUB'="")  ;didn't finish the loop
"RTN","DGENELA1",30,0)
 .;
"RTN","DGENELA1",31,0)
 .;also check SC % field of Rated Disabilities
"RTN","DGENELA1",32,0)
 .S SUB="" F  S SUB=$O(DGELG("RATEDIS",SUB)) Q:(SUB="")  I '$$CHKFIELD("PER",DGELG("RATEDIS",SUB,"PER")) S ERRMSG="BAD VALUE, FIELD = DISABILITY % OF THE RATED DISABILITIES MULTIPLE" Q
"RTN","DGENELA1",33,0)
 .Q:(SUB'="")  ;didn't finish the loop
"RTN","DGENELA1",34,0)
 .;
"RTN","DGENELA1",35,0)
 .I DGELG("SC")="Y",DGELG("SCPER")="" S ERRMSG="SC% UNSPECIFIED FOR SC VET" Q
"RTN","DGENELA1",36,0)
 .;
"RTN","DGENELA1",37,0)
 .;!! put this check back when POS is added to the Z11 message
"RTN","DGENELA1",38,0)
 .;I DGPAT("VETERAN")="Y",'DGELG("POS") S ERRMSG="POS UNSPECIFIED" Q 
"RTN","DGENELA1",39,0)
 .;
"RTN","DGENELA1",40,0)
 .I 'DGELG("ELIG","CODE") S ERRMSG="PRIMARY ELIGIBILITY IS UNSPECIFIED" Q
"RTN","DGENELA1",41,0)
 .;
"RTN","DGENELA1",42,0)
 .I (DGELG("VACKAMT")>0),(DGELG("A&A")_DGELG("HB")_DGELG("VAPEN")_DGELG("VADISAB")'["Y") S ERRMSG="VA CHECK AMOUNT > 0 BUT INCOME INDICATORS ALL SHOW 'NO'" Q
"RTN","DGENELA1",43,0)
 .;
"RTN","DGENELA1",44,0)
 .;
"RTN","DGENELA1",45,0)
 .;
"RTN","DGENELA1",46,0)
 .I (DGELG("SC")="N"),(DGELG("VADISAB")="Y") S ERRMSG="NSC VETERANS CAN NOT BE RECEIVING VA DISABILITY BENEFITS" Q
"RTN","DGENELA1",47,0)
 .;
"RTN","DGENELA1",48,0)
 .S BAD=1 D  Q:BAD  ;check primary eligibility
"RTN","DGENELA1",49,0)
 ..S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
"RTN","DGENELA1",50,0)
 ..Q:'NATCODE
"RTN","DGENELA1",51,0)
 ..;
"RTN","DGENELA1",52,0)
 ..I NATCODE=21 S ERRMSG="CATASTROPHICALLY DISABLED NOT ALLOWED AS PRIMARY ELIGIBILITY" Q
"RTN","DGENELA1",53,0)
 ..;
"RTN","DGENELA1",54,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")<50),(NATCODE'=3) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
"RTN","DGENELA1",55,0)
 ..;
"RTN","DGENELA1",56,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")>49),(NATCODE'=1) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
"RTN","DGENELA1",57,0)
 ..;
"RTN","DGENELA1",58,0)
 ..S DGONV=$O(^DIC(21,"B","OTHER NON-VETERANS","")),INELDATE=$P($G(^DPT(DFN,.15)),"^",2)
"RTN","DGENELA1",59,0)
 ..I INELDATE'="",DGPAT("INELDATE")'>0,DGELG("POS"),DGELG("POS")=DGONV,'$D(^DIC(21,DGELG("POS"),"E",DGELG("ELIG","CODE"))) D
"RTN","DGENELA1",60,0)
 ...S DGTEXT="Patient was previously determined to be ineligible for VA health care.  Upon review, the individual is determined to be eligible for "
"RTN","DGENELA1",61,0)
 ...S DGTEXT=DGTEXT_"VA care.  Please update period of service and other eligibility data as needed.."
"RTN","DGENELA1",62,0)
 ...D ADDMSG^DGENUPL3(.MSGS,DGTEXT,0)
"RTN","DGENELA1",63,0)
 ..;
"RTN","DGENELA1",64,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(NATCODE=1)!(NATCODE=3) S BAD=0 Q  ;primary eligibility OK
"RTN","DGENELA1",65,0)
 ..;
"RTN","DGENELA1",66,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE'=18 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PRISONER OF WAR" Q
"RTN","DGENELA1",67,0)
 ..;
"RTN","DGENELA1",68,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE=18 S BAD=0 Q
"RTN","DGENELA1",69,0)
 ..;
"RTN","DGENELA1",70,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE'=22 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PURPLE HEART RECIPIENT" Q
"RTN","DGENELA1",71,0)
 ..;
"RTN","DGENELA1",72,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE=22 S BAD=0 Q
"RTN","DGENELA1",73,0)
 ..;
"RTN","DGENELA1",74,0)
 ..; disabled DG*5.3*367, for Inel
"RTN","DGENELA1",75,0)
 ..;I (DGPAT("VETERAN")'=$P($G(^DIC(8.1,NATCODE,0)),"^",5)) S ERRMSG="PRIMARY ELIGIBILTY NOT CONSISTENT WITH VETERAN STATUS" Q
"RTN","DGENELA1",76,0)
 ..;
"RTN","DGENELA1",77,0)
 ..I DGELG("A&A")'="Y",NATCODE=2 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH A&A INDICATOR" Q
"RTN","DGENELA1",78,0)
 ..;
"RTN","DGENELA1",79,0)
 ..I DGELG("HB")'="Y",NATCODE=15 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH HOUSEBOUND INDICATOR" Q
"RTN","DGENELA1",80,0)
 ..;
"RTN","DGENELA1",81,0)
 ..I DGELG("VAPEN")'="Y",NATCODE=4 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH VA PENSION INDICATOR" Q
"RTN","DGENELA1",82,0)
 ..;
"RTN","DGENELA1",83,0)
 ..I DGELG("SC")="Y",((NATCODE=4)!(NATCODE=5)) S ERRMSG="NSC ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTION INDICATOR" Q
"RTN","DGENELA1",84,0)
 ..;
"RTN","DGENELA1",85,0)
 ..I (DGPAT("DOB")>2061231),(NATCODE=16) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" Q
"RTN","DGENELA1",86,0)
 ..;
"RTN","DGENELA1",87,0)
 ..I (DGPAT("DOB")>2071231),(NATCODE=17) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" Q
"RTN","DGENELA1",88,0)
 ..;
"RTN","DGENELA1",89,0)
 ..;primary eligibility is good
"RTN","DGENELA1",90,0)
 ..S BAD=0
"RTN","DGENELA1",91,0)
 .;
"RTN","DGENELA1",92,0)
 .S SUCCESS=1
"RTN","DGENELA1",93,0)
 .;check eligibilities multiple
"RTN","DGENELA1",94,0)
 .S CODE=0 F  S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:'CODE  D  Q:('SUCCESS)
"RTN","DGENELA1",95,0)
 ..S NATCODE=$$NATCODE^DGENELA(CODE)
"RTN","DGENELA1",96,0)
 ..Q:'NATCODE
"RTN","DGENELA1",97,0)
 ..I NATCODE=21,'DGCDIS("DATE") S SUCCESS=0,ERRMSG="CATASTROPHICALLY DISABLED ELIGIBILITY REQUIRES CATASTROPHICALLY DISABLED DETERMINATION DATE" Q
"RTN","DGENELA1",98,0)
 .;
"RTN","DGENELA1",99,0)
 Q SUCCESS
"RTN","DGENELA1",100,0)
 ;
"RTN","DGENELA1",101,0)
STORE(DGELG,DGPAT,DGCDIS,ERROR,SKIPCHK) ;
"RTN","DGENELA1",102,0)
 ;Stores an eligibility record for a patient. The patient record must
"RTN","DGENELA1",103,0)
 ;already exist. A lock on the Patient record is required, and is
"RTN","DGENELA1",104,0)
 ;released upon completion.
"RTN","DGENELA1",105,0)
 ;
"RTN","DGENELA1",106,0)
 ;Input:
"RTN","DGENELA1",107,0)
 ;  DGELG - eligibility array (pass by reference)
"RTN","DGENELA1",108,0)
 ;  DGPAT - patient array (optional, pass by reference)
"RTN","DGENELA1",109,0)
 ;  DGCDIS - array containing the catastrophic disability determination (optional, pass by reference)
"RTN","DGENELA1",110,0)
 ;  SKIPCHK - flag, set to 1 means that the consistency checks
"RTN","DGENELA1",111,0)
 ;            were already done & should be skipped
"RTN","DGENELA1",112,0)
 ;
"RTN","DGENELA1",113,0)
 ;Output:
"RTN","DGENELA1",114,0)
 ;  Function Value - returns 1 if successful, otherwise 0
"RTN","DGENELA1",115,0)
 ;  ERROR - in event of failure returns an error message (pass by reference, optional)
"RTN","DGENELA1",116,0)
 ;
"RTN","DGENELA1",117,0)
 N SUCCESS,DATA,FIELD,DA,DFN,COUNT
"RTN","DGENELA1",118,0)
 S DFN=$G(DGELG("DFN"))
"RTN","DGENELA1",119,0)
 S SUCCESS=0
"RTN","DGENELA1",120,0)
 S ERROR=""
"RTN","DGENELA1",121,0)
 ;
"RTN","DGENELA1",122,0)
 D  ;drops out of block on failure
"RTN","DGENELA1",123,0)
 .I '$$LOCK^DGENPTA1(DFN) S ERROR="UNABLE TO LOCK PATIENT RECORD" Q
"RTN","DGENELA1",124,0)
 .I $G(SKIPCHK)'=1,'$$CHECK(.DGELG,.DGPAT,.DGCDIS,.ERROR) Q
"RTN","DGENELA1",125,0)
 .S SUB="" F  S SUB=$O(DGELG(SUB)) Q:SUB=""  D
"RTN","DGENELA1",126,0)
 ..I SUB'="ELIG",SUB'="RATEDIS",SUB'="DFN" S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=DGELG(SUB)
"RTN","DGENELA1",127,0)
 .;
"RTN","DGENELA1",128,0)
 .;don't add the Primary Eligibility unless different, so as to not
"RTN","DGENELA1",129,0)
 .;fire off x-refs unless necessary
"RTN","DGENELA1",130,0)
 .I $P($G(^DPT(DFN,.36)),"^")'=DGELG("ELIG","CODE") S DATA(.361)=DGELG("ELIG","CODE")
"RTN","DGENELA1",131,0)
 .;
"RTN","DGENELA1",132,0)
 .; Only update User Enrollee fields if the incoming UE status is
"RTN","DGENELA1",133,0)
 .; greater than the USER ENROLLEE VALID THROUGH on file.
"RTN","DGENELA1",134,0)
 .I $G(DATA(.3617))<$P($G(^DPT(DFN,.361)),"^",7) K DATA(.3617),DATA(.3618)
"RTN","DGENELA1",135,0)
 .;
"RTN","DGENELA1",136,0)
 .;update Patient file record with data from Z11
"RTN","DGENELA1",137,0)
 .D UPDZ11^DGENELA2
"RTN","DGENELA1",138,0)
 .;
"RTN","DGENELA1",139,0)
 .;delete eligibilities that do not belong
"RTN","DGENELA1",140,0)
 .D DELELIG^DGENELA2(DFN,.DGELG)
"RTN","DGENELA1",141,0)
 .;
"RTN","DGENELA1",142,0)
 .;overlay Rated Disabilities
"RTN","DGENELA1",143,0)
 .Q:'$$OVERLAY()
"RTN","DGENELA1",144,0)
 .;
"RTN","DGENELA1",145,0)
 .;Add the new Patient Eligibilities
"RTN","DGENELA1",146,0)
 .;Don't add the an eligibility unless different - so as to not
"RTN","DGENELA1",147,0)
 .;fire off the x-refs unless necessary.
"RTN","DGENELA1",148,0)
 .;Also, try to assign ien = the code (see input tranform of the field).
"RTN","DGENELA1",149,0)
 .K DA,DATA
"RTN","DGENELA1",150,0)
 .S DA(1)=DFN
"RTN","DGENELA1",151,0)
 .S DATA(.01)=0
"RTN","DGENELA1",152,0)
 .F  S DATA(.01)=$O(DGELG("ELIG","CODE",DATA(.01))) Q:'DATA(.01)  I '$D(^DPT(DFN,"E","B",DATA(.01))) I '$$ADD^DGENDBS(2.0361,.DA,.DATA,,$S($D(^DPT(DFN,"E",DATA(.01))):0,1:DATA(.01))) S ERROR="FILEMAN FAILED TO ADD PATIENT ELIGIBILITY" Q
"RTN","DGENELA1",153,0)
 .;
"RTN","DGENELA1",154,0)
 .S SUCCESS=1
"RTN","DGENELA1",155,0)
 ;
"RTN","DGENELA1",156,0)
 D UNLOCK^DGENPTA1(DFN)
"RTN","DGENELA1",157,0)
 Q SUCCESS
"RTN","DGENELA1",158,0)
 ;
"RTN","DGENELA1",159,0)
FIELD(SUB) ;
"RTN","DGENELA1",160,0)
 ;given a subscript from the ELIGIBILITY array, returns the field number
"RTN","DGENELA1",161,0)
 ;
"RTN","DGENELA1",162,0)
 Q:SUB="CODE" .361
"RTN","DGENELA1",163,0)
 Q:SUB="SC" .301
"RTN","DGENELA1",164,0)
 Q:SUB="SCPER" .302
"RTN","DGENELA1",165,0)
 Q:SUB="EFFDT" .3014
"RTN","DGENELA1",166,0)
 Q:SUB="POW" .525
"RTN","DGENELA1",167,0)
 Q:SUB="PH" .531
"RTN","DGENELA1",168,0)
 Q:SUB="A&A" .36205
"RTN","DGENELA1",169,0)
 Q:SUB="HB" .36215
"RTN","DGENELA1",170,0)
 Q:SUB="VAPEN" .36235
"RTN","DGENELA1",171,0)
 Q:SUB="VACKAMT" .36295
"RTN","DGENELA1",172,0)
 Q:SUB="DISRET" .3602
"RTN","DGENELA1",173,0)
 Q:SUB="DISLOD" .3603
"RTN","DGENELA1",174,0)
 Q:SUB="MEDICAID" .381
"RTN","DGENELA1",175,0)
 Q:SUB="MEDASKDT" .382 ;EVC - DG*5.3*653
"RTN","DGENELA1",176,0)
 Q:SUB="AO" .32102
"RTN","DGENELA1",177,0)
 Q:SUB="IR" .32103
"RTN","DGENELA1",178,0)
 Q:SUB="EC" .322013  ;name change from Env Con, DG*5.3*688
"RTN","DGENELA1",179,0)
 Q:SUB="MTSTA" ""  ;don't map Means Test Category
"RTN","DGENELA1",180,0)
 Q:SUB="P&T" .304
"RTN","DGENELA1",181,0)
 Q:SUB="P&TDT" .3013  ;field added with DG*5.3*688
"RTN","DGENELA1",182,0)
 Q:SUB="POS" .323
"RTN","DGENELA1",183,0)
 Q:SUB="UNEMPLOY" .305
"RTN","DGENELA1",184,0)
 Q:SUB="SCAWDATE" .3012
"RTN","DGENELA1",185,0)
 Q:SUB="RATEINC" .293
"RTN","DGENELA1",186,0)
 Q:SUB="CLAIMNUM" .313
"RTN","DGENELA1",187,0)
 Q:SUB="CLAIMLOC" .314
"RTN","DGENELA1",188,0)
 Q:SUB="VADISAB" .3025
"RTN","DGENELA1",189,0)
 Q:SUB="ELIGSTA" .3611
"RTN","DGENELA1",190,0)
 Q:SUB="ELIGSTADATE" .3612
"RTN","DGENELA1",191,0)
 Q:SUB="ELIGVERIF" .3615
"RTN","DGENELA1",192,0)
 Q:SUB="ELIGENTBY" .3616
"RTN","DGENELA1",193,0)
 Q:SUB="RD" .01
"RTN","DGENELA1",194,0)
 Q:SUB="PER" 2
"RTN","DGENELA1",195,0)
 Q:SUB="RDSC" 3
"RTN","DGENELA1",196,0)
 Q:SUB="RDEXT" 4
"RTN","DGENELA1",197,0)
 Q:SUB="RDORIG" 5
"RTN","DGENELA1",198,0)
 Q:SUB="RDCURR" 6
"RTN","DGENELA1",199,0)
 Q:SUB="UEYEAR" .3617
"RTN","DGENELA1",200,0)
 Q:SUB="UESITE" .3618
"RTN","DGENELA1",201,0)
 Q:SUB="AOEXPLOC" .3213
"RTN","DGENELA1",202,0)
 Q:SUB="CVELEDT" .5295
"RTN","DGENELA1",203,0)
 Q:SUB="SHAD" .32115
"RTN","DGENELA1",204,0)
 Q:SUB="MOH" .541
"RTN","DGENELA1",205,0)
 ;
"RTN","DGENELA1",206,0)
 Q ""
"RTN","DGENELA1",207,0)
 ;
"RTN","DGENELA1",208,0)
CHKFIELD(SUB,VAL) ;
"RTN","DGENELA1",209,0)
 ;Description: Does field level validation of the value. Returns 1
"RTN","DGENELA1",210,0)
 ;if the value is good, 0 otherwise.
"RTN","DGENELA1",211,0)
 ;
"RTN","DGENELA1",212,0)
 Q:($G(VAL)="") 1  ;for now, all NULL values assumed okay
"RTN","DGENELA1",213,0)
 ;
"RTN","DGENELA1",214,0)
 N BAD S BAD=0
"RTN","DGENELA1",215,0)
 I (SUB="SCPER")!(SUB="PER"),(+VAL'=VAL)!(VAL>100)!(VAL<0)!(VAL?.E1"."1N.N) S BAD=1
"RTN","DGENELA1",216,0)
 I SUB="VACKAMT",+VAL'=VAL&(VAL'?.N1"."2N)!(VAL>99999)!(VAL<0) S BAD=1
"RTN","DGENELA1",217,0)
 I SUB="DISRET",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",218,0)
 I SUB="DISLOD",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",219,0)
 I SUB="MEDICAID",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",220,0)
 I SUB="RATEINC",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",221,0)
 I SUB="ELIGSTA",VAL'="P",VAL'="R",VAL'="V" S BAD=1
"RTN","DGENELA1",222,0)
 I SUB="POW",VAL'="Y",VAL'="N",VAL'="U" S BAD=1
"RTN","DGENELA1",223,0)
 Q 'BAD
"RTN","DGENELA1",224,0)
 ;
"RTN","DGENELA1",225,0)
 ;
"RTN","DGENELA1",226,0)
OVERLAY() ;
"RTN","DGENELA1",227,0)
 ;Description: Overlay the local Rated Disabilities with whatever HEC
"RTN","DGENELA1",228,0)
 ;sent.
"RTN","DGENELA1",229,0)
 ;
"RTN","DGENELA1",230,0)
 N SUCCESS S SUCCESS=1
"RTN","DGENELA1",231,0)
 ;
"RTN","DGENELA1",232,0)
 ;delete the rated disabilties multiple
"RTN","DGENELA1",233,0)
 D DELRDIS^DGENELA2(DFN)
"RTN","DGENELA1",234,0)
 ;
"RTN","DGENELA1",235,0)
 ;add the rated disabilities
"RTN","DGENELA1",236,0)
 K DATA,DA
"RTN","DGENELA1",237,0)
 S DA(1)=DFN
"RTN","DGENELA1",238,0)
 S COUNT=0
"RTN","DGENELA1",239,0)
 F  S COUNT=$O(DGELG("RATEDIS",COUNT)) Q:'COUNT  D
"RTN","DGENELA1",240,0)
 .S DATA(.01)=DGELG("RATEDIS",COUNT,"RD")
"RTN","DGENELA1",241,0)
 .I DATA(.01) D
"RTN","DGENELA1",242,0)
 ..S DATA(2)=DGELG("RATEDIS",COUNT,"PER")
"RTN","DGENELA1",243,0)
 ..S DATA(3)=DGELG("RATEDIS",COUNT,"RDSC")
"RTN","DGENELA1",244,0)
 ..S DATA(4)=DGELG("RATEDIS",COUNT,"RDEXT")
"RTN","DGENELA1",245,0)
 ..S DATA(5)=DGELG("RATEDIS",COUNT,"RDORIG")
"RTN","DGENELA1",246,0)
 ..S DATA(6)=DGELG("RATEDIS",COUNT,"RDCURR")
"RTN","DGENELA1",247,0)
 ..I '$$ADD^DGENDBS(2.04,.DA,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILTIES",SUCCESS=0
"RTN","DGENELA1",248,0)
 Q SUCCESS
"RTN","DGENELA4")
0^9^B69534652
"RTN","DGENELA4",1,0)
DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM - Patient Eligibility API ; 5/10/11 12:03pm
"RTN","DGENELA4",2,0)
 ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,803,754,841**;Aug 13,1993;Build 7
"RTN","DGENELA4",3,0)
 ;
"RTN","DGENELA4",4,0)
 ;
"RTN","DGENELA4",5,0)
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ;
"RTN","DGENELA4",6,0)
 ; Description: Used to compute the priority group and subgroup for a
"RTN","DGENELA4",7,0)
 ; patient, also returning the subset of the eligibility data on which 
"RTN","DGENELA4",8,0)
 ; the priority subgroup is based.
"RTN","DGENELA4",9,0)
 ;
"RTN","DGENELA4",10,0)
 ;Input:
"RTN","DGENELA4",11,0)
 ;      DFN - ien of patient
"RTN","DGENELA4",12,0)
 ;    DGELG - ELIGIBILITY object array (optional, pass by reference)
"RTN","DGENELA4",13,0)
 ;  ENRDATE - The Enrollment Date. This date is used in the priority
"RTN","DGENELA4",14,0)
 ;            determination only if the application date is not passed.
"RTN","DGENELA4",15,0)
 ;  APPDATE - The Enrollment Application Date.  This date is used
"RTN","DGENELA4",16,0)
 ;            to determine the priority. If the application date
"RTN","DGENELA4",17,0)
 ;            is not passed then the enrollment date (ENRDATE) is used.
"RTN","DGENELA4",18,0)
 ;
"RTN","DGENELA4",19,0)
 ;Output:
"RTN","DGENELA4",20,0)
 ;  Function Value - returns the priority and subgroup computed by the
"RTN","DGENELA4",21,0)
 ;    function as a 2 piece string 'PRIORITY^SUBGROUP'
"RTN","DGENELA4",22,0)
 ;  DGELGSUB - this local array will contain the eligibility data on
"RTN","DGENELA4",23,0)
 ;    which the priority determination was based, pass by reference
"RTN","DGENELA4",24,0)
 ;    if needed.
"RTN","DGENELA4",25,0)
 ;
"RTN","DGENELA4",26,0)
 N CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
"RTN","DGENELA4",27,0)
 K DGELGSUB S DGELGSUB=""
"RTN","DGENELA4",28,0)
 S (HICODE,HIPRI,SUBGRP,HISUB)=""
"RTN","DGENELA4",29,0)
 D
"RTN","DGENELA4",30,0)
 .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q  ;can not proceed with eligibility
"RTN","DGENELA4",31,0)
 .; can't proceed without an Enrollment Date or Application Date
"RTN","DGENELA4",32,0)
 .I '$G(ENRDATE),'$G(APPDATE) Q
"RTN","DGENELA4",33,0)
 .I $$GET^DGENPTA(DFN,.DGPAT)
"RTN","DGENELA4",34,0)
 .; determine priority/subgroup based on primary eligibility
"RTN","DGENELA4",35,0)
 .S HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
"RTN","DGENELA4",36,0)
 .S PRIORITY=$$PRI(HICODE,.DGELG,$G(ENRDATE),$G(APPDATE))
"RTN","DGENELA4",37,0)
 .S HIPRI=$P(PRIORITY,"^"),HISUB=$P(PRIORITY,"^",2)
"RTN","DGENELA4",38,0)
 .S CODE=""
"RTN","DGENELA4",39,0)
 .;
"RTN","DGENELA4",40,0)
 .; determine if other eligibilities result in higher priority/subgroup
"RTN","DGENELA4",41,0)
 .F  S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:('CODE!(HIPRI=1))  D
"RTN","DGENELA4",42,0)
 ..S PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$G(ENRDATE),$G(APPDATE))
"RTN","DGENELA4",43,0)
 ..S PRI=$P(PRIORITY,"^"),SUB=$P(PRIORITY,"^",2)
"RTN","DGENELA4",44,0)
 ..S:((PRI>0)&((PRI<HIPRI)!(HIPRI=""))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
"RTN","DGENELA4",45,0)
 ..S:((PRI=HIPRI)&((SUB>0)&(SUB<HISUB))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
"RTN","DGENELA4",46,0)
 .;
"RTN","DGENELA4",47,0)
 .;set the DGELGSUB() array with the eligibility information used in the
"RTN","DGENELA4",48,0)
 .;priority determination
"RTN","DGENELA4",49,0)
 .S DGELGSUB("CODE")=HICODE,DGELGSUB("SC")=DGELG("SC"),DGELGSUB("SCPER")=DGELG("SCPER"),DGELGSUB("POW")=DGELG("POW"),DGELGSUB("A&A")=DGELG("A&A"),DGELGSUB("HB")=DGELG("HB")
"RTN","DGENELA4",50,0)
 .S DGELGSUB("VAPEN")=DGELG("VAPEN"),DGELGSUB("VACKAMT")=DGELG("VACKAMT"),DGELGSUB("DISRET")=DGELG("DISRET"),DGELGSUB("DISLOD")=DGELG("DISLOD")
"RTN","DGENELA4",51,0)
 .S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA")
"RTN","DGENELA4",52,0)
 .;Purple Heart Added to DGELGSUB
"RTN","DGENELA4",53,0)
 .S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH")
"RTN","DGENELA4",54,0)
 .;Added for HVE Phase III (DG*5.3*564)
"RTN","DGENELA4",55,0)
 .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT"),DGELGSUB("SHAD")=DGELG("SHAD")
"RTN","DGENELA4",56,0)
 .;added dg*5.3*659
"RTN","DGENELA4",57,0)
 .S DGELGSUB("RADEXPM")=DGELG("RADEXPM")
"RTN","DGENELA4",58,0)
 .S DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
"RTN","DGENELA4",59,0)
 .S DGELGSUB("MOH")=DGELG("MOH")
"RTN","DGENELA4",60,0)
 .I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
"RTN","DGENELA4",61,0)
 ;
"RTN","DGENELA4",62,0)
 Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
"RTN","DGENELA4",63,0)
 ;
"RTN","DGENELA4",64,0)
 ;
"RTN","DGENELA4",65,0)
PRI(CODE,DGELG,ENRDATE,APPDATE) ;
"RTN","DGENELA4",66,0)
 ; Description: Returns the priority group and subgroup based on a
"RTN","DGENELA4",67,0)
 ; single eligibility code.
"RTN","DGENELA4",68,0)
 ;Input -
"RTN","DGENELA4",69,0)
 ;  CODE - pointer to file #8.1, MAS Eligibility Code
"RTN","DGENELA4",70,0)
 ;  DGELG - local array obtained by calling $$GET, pass by reference
"RTN","DGENELA4",71,0)
 ;  ENRDATE - The Enrollment Date. This date is used in the priority
"RTN","DGENELA4",72,0)
 ;            determination only if the application date is not passed.
"RTN","DGENELA4",73,0)
 ;  APPDATE - The Enrollment Application Date.  This date is used
"RTN","DGENELA4",74,0)
 ;            to determine the priority. If the application date
"RTN","DGENELA4",75,0)
 ;            is not passed then the enrollment date (ENRDATE) is used.
"RTN","DGENELA4",76,0)
 ;
"RTN","DGENELA4",77,0)
 ;Output -
"RTN","DGENELA4",78,0)
 ;  Function Value - returns the priority and subgroup computed by the
"RTN","DGENELA4",79,0)
 ;   function as a 2 piece string 'PRIORITY^SUBGROUP'
"RTN","DGENELA4",80,0)
 ;
"RTN","DGENELA4",81,0)
 N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
"RTN","DGENELA4",82,0)
 N NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2
"RTN","DGENELA4",83,0)
 S SUBGRP=""
"RTN","DGENELA4",84,0)
 ;
"RTN","DGENELA4",85,0)
 ; use the Application Date when determining the priority, otherwise use
"RTN","DGENELA4",86,0)
 ; the Enrollment Date (ESP DG*5,3*491)
"RTN","DGENELA4",87,0)
 S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE))
"RTN","DGENELA4",88,0)
 ;
"RTN","DGENELA4",89,0)
 ;get the name of the national eligibility code
"RTN","DGENELA4",90,0)
 S CODENAME=$$CODENAME^DGENELA(CODE)
"RTN","DGENELA4",91,0)
 ;
"RTN","DGENELA4",92,0)
 ;get the means test code
"RTN","DGENELA4",93,0)
 S MTSTA=""
"RTN","DGENELA4",94,0)
 I DGELG("MTSTA") S MTSTA=$P($G(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
"RTN","DGENELA4",95,0)
 ;
"RTN","DGENELA4",96,0)
 ;get MT and GMT thresholds
"RTN","DGENELA4",97,0)
 S DGMTI=$P($$LST^DGMTU(DFN),"^")
"RTN","DGENELA4",98,0)
 S MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
"RTN","DGENELA4",99,0)
 S GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
"RTN","DGENELA4",100,0)
 S DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
"RTN","DGENELA4",101,0)
 S DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
"RTN","DGENELA4",102,0)
 D ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
"RTN","DGENELA4",103,0)
 S DGAICM=0
"RTN","DGENELA4",104,0)
 S:$G(DGINC("V")) DGAICM=+DGINC("V")
"RTN","DGENELA4",105,0)
 S (DGMEDEX,DGEDEX,DGASSTS)=0
"RTN","DGENELA4",106,0)
 S DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
"RTN","DGENELA4",107,0)
 I $D(^DGMT(408.21,DGAICM,2))  D
"RTN","DGENELA4",108,0)
 .S NODE2=^DGMT(408.21,DGAICM,2)
"RTN","DGENELA4",109,0)
 .S DGASSTS=DGASSTS+$P(NODE2,U,1)+$P(NODE2,U,2)+$P(NODE2,U,3)+$P(NODE2,U,4)-$P(NODE2,U,5)
"RTN","DGENELA4",110,0)
 .S DGASSTS=DGASSTS+$P(NODE2,U,6)+$P(NODE2,U,7)+$P(NODE2,U,8)+$P(NODE2,U,9)
"RTN","DGENELA4",111,0)
 S:$D(^DGMT(408.21,DGAICM,1)) DGMEDEX=$P(^DGMT(408.21,DGAICM,1),"^",12)
"RTN","DGENELA4",112,0)
 S:$D(^DGMT(408.21,DGAICM,1)) DGEDEX=$P(^DGMT(408.21,DGAICM,1),"^",3)
"RTN","DGENELA4",113,0)
 ;
"RTN","DGENELA4",114,0)
 ; get expiration dates for Special Treatment Authority
"RTN","DGENELA4",115,0)
 S STAEXP("AO")=$$STAEXP^DGENELA4("AO")
"RTN","DGENELA4",116,0)
 S STAEXP("EC")=$$STAEXP^DGENELA4("EC")
"RTN","DGENELA4",117,0)
 ;
"RTN","DGENELA4",118,0)
 ;get the Enrollment Group Threshold (EGT) setting
"RTN","DGENELA4",119,0)
 S DGEGT=""
"RTN","DGENELA4",120,0)
 I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
"RTN","DGENELA4",121,0)
 I '$G(DGELG("RADEXPM")) S DGELG("RADEXPM")=""
"RTN","DGENELA4",122,0)
 I '$G(DGELG("SHAD")) S DGELG("SHAD")=""
"RTN","DGENELA4",123,0)
 ;
"RTN","DGENELA4",124,0)
 D  ;drops out when priority determined
"RTN","DGENELA4",125,0)
 .S PRIORITY=""
"RTN","DGENELA4",126,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q
"RTN","DGENELA4",127,0)
 .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y") S PRIORITY=1 Q
"RTN","DGENELA4",128,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q
"RTN","DGENELA4",129,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>9)&(CODENAME="SC LESS THAN 50%"))!(DGELG("POW")="Y")!(CODENAME="PRISONER OF WAR")!(DGELG("DISRET")=1)!(DGELG("DISLOD")=1)!(CODENAME="PURPLE HEART RECIPIENT")!(DGELG("PH")="Y") S PRIORITY=3 Q
"RTN","DGENELA4",130,0)
 .I DGELG("MOH")="Y" S PRIORITY=3 Q   ;Added for DG*5.3*841
"RTN","DGENELA4",131,0)
 .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q
"RTN","DGENELA4",132,0)
 .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q
"RTN","DGENELA4",133,0)
 .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1) S PRIORITY=6 Q
"RTN","DGENELA4",134,0)
 .I DGELG("EC")="Y" I (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC")) S PRIORITY=6 Q
"RTN","DGENELA4",135,0)
 .I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
"RTN","DGENELA4",136,0)
 .I (DGELG("AO")="Y"),(DGELG("AOEXPLOC"))="V" I (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO")) S PRIORITY=6 Q
"RTN","DGENELA4",137,0)
 .I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D  Q
"RTN","DGENELA4",138,0)
 ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
"RTN","DGENELA4",139,0)
 ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
"RTN","DGENELA4",140,0)
 .S MTTEST1=MTTHR
"RTN","DGENELA4",141,0)
 .I GMTTHR>MTTHR S MTTEST1=GMTTHR
"RTN","DGENELA4",142,0)
 .S MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01 ; Add 10% to the test threshold
"RTN","DGENELA4",143,0)
 .I $$SC^DGMTR(DFN),DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
"RTN","DGENELA4",144,0)
 .I $$SC^DGMTR(DFN),DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
"RTN","DGENELA4",145,0)
 .I DGELG("SC")="N",DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
"RTN","DGENELA4",146,0)
 .I DGELG("SC")="N",DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
"RTN","DGENELA4",147,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
"RTN","DGENELA4",148,0)
 .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q
"RTN","DGENELA4",149,0)
 ;
"RTN","DGENELA4",150,0)
 Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"")
"RTN","DGENELA4",151,0)
 ;
"RTN","DGENELA4",152,0)
SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
"RTN","DGENELA4",153,0)
 ;
"RTN","DGENELA4",154,0)
 N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
"RTN","DGENELA4",155,0)
 Q:'$G(DFN)
"RTN","DGENELA4",156,0)
 S U="^"
"RTN","DGENELA4",157,0)
 S:$G(PRIORITY)="" PRIORITY=""
"RTN","DGENELA4",158,0)
 S:$G(SUBGRP)="" SUBGRP=""
"RTN","DGENELA4",159,0)
 D NOW^%DTC S TODAY=X
"RTN","DGENELA4",160,0)
 Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP  ;EGT isn't set
"RTN","DGENELA4",161,0)
 Q:TODAY<EGT("EFFDATE") SUBGRP  ;EGT is not in effect
"RTN","DGENELA4",162,0)
 I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP
"RTN","DGENELA4",163,0)
 I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01)) Q SUBGRP
"RTN","DGENELA4",164,0)
 I EGT("TYPE")=4 Q:(PRIORITY<EGT("PRIORITY")) SUBGRP  Q:(PRIORITY>EGT("PRIORITY")) $$SUBCNV(SUBGRP)
"RTN","DGENELA4",165,0)
 ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
"RTN","DGENELA4",166,0)
 S DGENRIEN=$$FINDCUR^DGENA(DFN)
"RTN","DGENELA4",167,0)
 I 'DGENRIEN,$G(ENRDATE),ENRDATE<EGT("EFFDATE") Q SUBGRP
"RTN","DGENELA4",168,0)
 S DONE=0
"RTN","DGENELA4",169,0)
 F  Q:DONE  D
"RTN","DGENELA4",170,0)
 .I 'DGENRIEN S DONE=2 Q
"RTN","DGENELA4",171,0)
 .I '$$GET^DGENA(DGENRIEN,.DGENRC) S DONE=2 Q
"RTN","DGENELA4",172,0)
 .S DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
"RTN","DGENELA4",173,0)
 .Q:DGENRC("STATUS")=6   ;deceased
"RTN","DGENELA4",174,0)
 .I $P($G(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N" S DONE=2 Q
"RTN","DGENELA4",175,0)
 .S ENRDT=$G(DGENRC("APP")) S:'ENRDT ENRDT=$G(DGENRC("EFFDATE"))
"RTN","DGENELA4",176,0)
 .I ENRDT,ENRDT<EGT("EFFDATE") S DONE=1 Q
"RTN","DGENELA4",177,0)
 .; HEC is the authoritative source on continuous enrollment
"RTN","DGENELA4",178,0)
 .I $$OVRRIDE^DGENEGT1(DFN,.EGT) S DONE=1
"RTN","DGENELA4",179,0)
 ;
"RTN","DGENELA4",180,0)
 Q $S(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
"RTN","DGENELA4",181,0)
 ;
"RTN","DGENELA4",182,0)
SUBCNV(SUBGRP) ;return new subgrp
"RTN","DGENELA4",183,0)
 I SUBGRP=1 Q 5
"RTN","DGENELA4",184,0)
 I SUBGRP=3 Q 7
"RTN","DGENELA4",185,0)
 Q SUBGRP
"RTN","DGENELA4",186,0)
 ;
"RTN","DGENELA4",187,0)
STAEXP(STATYP) ;return expiration date for Special Treatment Authority (STA)
"RTN","DGENELA4",188,0)
 ;Input -
"RTN","DGENELA4",189,0)
 ;  STATYP - STA Type (Only AO & EC (SWAC) currently supported)
"RTN","DGENELA4",190,0)
 ;
"RTN","DGENELA4",191,0)
 ;Output -
"RTN","DGENELA4",192,0)
 ;  Function Value - returns the requested expiration date from the
"RTN","DGENELA4",193,0)
 ;                   MAS PARAMETERS file (#43), otherwise returns 0
"RTN","DGENELA4",194,0)
 ;
"RTN","DGENELA4",195,0)
 I STATYP="AO" Q +$P($G(^DG(43,1,"ENR")),U,1)  ;AO Exp Dt
"RTN","DGENELA4",196,0)
 I STATYP="EC" Q +$P($G(^DG(43,1,"ENR")),U,2)  ;EC (SWAC) Exp Dt
"RTN","DGENELA4",197,0)
 Q 0
"RTN","DGENL1")
0^12^B69443276
"RTN","DGENL1",1,0)
DGENL1 ;ALB/RMO,ISA/KWP,Zoltan,ALB/BRM,LBD,ERC,EG,CKN,BAJ - Patient Enrollment - Build List Area ; 5/12/11 3:53pm
"RTN","DGENL1",2,0)
 ;;5.3;Registration;**121,147,232,266,343,564,672,659,653,688,838,841**;Aug 13,1993;Build 7
"RTN","DGENL1",3,0)
 ;
"RTN","DGENL1",4,0)
EN(DGARY,DFN,DGENRIEN,DGCNT) ;Entry point to build list area
"RTN","DGENL1",5,0)
 ; for patient enrollment and patient enrollment history
"RTN","DGENL1",6,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGENL1",7,0)
 ;           DFN      Patient IEN
"RTN","DGENL1",8,0)
 ;           DGENRIEN Enrollment IEN
"RTN","DGENL1",9,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGENL1",10,0)
 N DGENCAT,DGENR,DGLINE
"RTN","DGENL1",11,0)
 I DGENRIEN,$$GET^DGENA(DGENRIEN,.DGENR) ;set-up enrollment array
"RTN","DGENL1",12,0)
 S DGENCAT=$$CATEGORY^DGENA4(,$G(DGENR("STATUS")))  ;enrollment category
"RTN","DGENL1",13,0)
 S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
"RTN","DGENL1",14,0)
 S DGLINE=1,DGCNT=0
"RTN","DGENL1",15,0)
 D ENR(DGARY,DFN,.DGENR,.DGLINE,.DGCNT) ;enrollment
"RTN","DGENL1",16,0)
 D PF(DGARY,DFN,.DGENR,.DGLINE,.DGCNT) ;priority factors
"RTN","DGENL1",17,0)
 D HIS^DGENL2(DGARY,DFN,DGENRIEN,.DGLINE,.DGCNT) ;history
"RTN","DGENL1",18,0)
 Q
"RTN","DGENL1",19,0)
 ;
"RTN","DGENL1",20,0)
ENR(DGARY,DFN,DGENR,DGLINE,DGCNT) ;Enrollment 
"RTN","DGENL1",21,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGENL1",22,0)
 ;           DFN      Patient IEN
"RTN","DGENL1",23,0)
 ;           DGENR    Enrollment array
"RTN","DGENL1",24,0)
 ;           DGLINE   Line number
"RTN","DGENL1",25,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGENL1",26,0)
 N DGSTART
"RTN","DGENL1",27,0)
 ;
"RTN","DGENL1",28,0)
 S DGSTART=DGLINE ; starting line number
"RTN","DGENL1",29,0)
 D SET(DGARY,DGLINE,"Enrollment",31,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGENL1",30,0)
 ;
"RTN","DGENL1",31,0)
 ;Enrollment Date
"RTN","DGENL1",32,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",33,0)
 D SET(DGARY,DGLINE,"Enrollment Date: "_$S($G(DGENR("DATE")):$$EXT^DGENU("DATE",DGENR("DATE")),1:""),11,,,,,,.DGCNT)
"RTN","DGENL1",34,0)
 ;
"RTN","DGENL1",35,0)
 ;
"RTN","DGENL1",36,0)
 ;Enrollment End Date
"RTN","DGENL1",37,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",38,0)
 D SET(DGARY,DGLINE,"Enrollment End Date: "_$S($G(DGENR("END")):$$EXT^DGENU("END",DGENR("END")),1:""),7,,,,,,.DGCNT)
"RTN","DGENL1",39,0)
 ;
"RTN","DGENL1",40,0)
 ;Enrollment Application Date
"RTN","DGENL1",41,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",42,0)
 D SET(DGARY,DGLINE,"Application Date: "_$S($G(DGENR("APP")):$$EXT^DGENU("APP",DGENR("APP")),1:""),10,,,,,,.DGCNT)
"RTN","DGENL1",43,0)
 ;
"RTN","DGENL1",44,0)
 ;Source
"RTN","DGENL1",45,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",46,0)
 D SET(DGARY,DGLINE,"Source of Enrollment: "_$S($G(DGENR("SOURCE")):$$EXT^DGENU("SOURCE",DGENR("SOURCE")),1:""),6,,,,,,.DGCNT)
"RTN","DGENL1",47,0)
 ;
"RTN","DGENL1",48,0)
 ;Category
"RTN","DGENL1",49,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",50,0)
 D SET(DGARY,DGLINE,"Enrollment Category: "_DGENCAT,7,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGENL1",51,0)
 ;
"RTN","DGENL1",52,0)
 ;Status
"RTN","DGENL1",53,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",54,0)
 D SET(DGARY,DGLINE,"Enrollment Status: "_$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:""),9,,,,,,.DGCNT)
"RTN","DGENL1",55,0)
 ;
"RTN","DGENL1",56,0)
 ;Priority
"RTN","DGENL1",57,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",58,0)
 D SET(DGARY,DGLINE,"Enrollment Priority: "_$S($G(DGENR("PRIORITY")):DGENR("PRIORITY"),1:"")_$S($G(DGENR("SUBGRP")):$$EXT^DGENU("SUBGRP",DGENR("SUBGRP")),1:""),7,,,,,,.DGCNT)
"RTN","DGENL1",59,0)
 ;
"RTN","DGENL1",60,0)
 ;
"RTN","DGENL1",61,0)
 ;Effective date
"RTN","DGENL1",62,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",63,0)
 D SET(DGARY,DGLINE,"Effective Date: "_$S($G(DGENR("EFFDATE")):$$EXT^DGENU("EFFDATE",DGENR("EFFDATE")),1:""),12,,,,,,.DGCNT)
"RTN","DGENL1",64,0)
 ;
"RTN","DGENL1",65,0)
 ;Reason canceled/declined
"RTN","DGENL1",66,0)
 ; Removed blank line to fix format after screen header was increased
"RTN","DGENL1",67,0)
 ; to 3 lines (DG*5.3*838).
"RTN","DGENL1",68,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",69,0)
 D SET(DGARY,DGLINE,"Reason Canceled/Declined: "_$S($G(DGENR("REASON")):$$EXT^DGENU("REASON",DGENR("REASON")),1:""),2,,,,,,.DGCNT)
"RTN","DGENL1",70,0)
 ;
"RTN","DGENL1",71,0)
 ;Canceled/declined remarks
"RTN","DGENL1",72,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",73,0)
 D SET(DGARY,DGLINE,"Canceled/Declined Remarks: "_$S($G(DGENR("REASON"))'="":$$EXT^DGENU("REMARKS",DGENR("REMARKS")),1:""),1,,,,,,.DGCNT)
"RTN","DGENL1",74,0)
 ;
"RTN","DGENL1",75,0)
 ;Entered by
"RTN","DGENL1",76,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",77,0)
 D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",78,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",79,0)
 D SET(DGARY,DGLINE,"Entered By: "_$S($G(DGENR("USER")):$$EXT^DGENU("USER",DGENR("USER")),1:""),16,,,,,,.DGCNT)
"RTN","DGENL1",80,0)
 ;
"RTN","DGENL1",81,0)
 ;Date/time entered
"RTN","DGENL1",82,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",83,0)
 D SET(DGARY,DGLINE,"Date/Time Entered: "_$S($G(DGENR("DATETIME")):$$EXT^DGENU("DATETIME",DGENR("DATETIME")),1:""),9,,,,,,.DGCNT)
"RTN","DGENL1",84,0)
 ;
"RTN","DGENL1",85,0)
 ;Set line to start on next page
"RTN","DGENL1",86,0)
 F DGLINE=DGLINE+1:1:DGSTART+VALM("LINES") D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",87,0)
 Q
"RTN","DGENL1",88,0)
 ;
"RTN","DGENL1",89,0)
PF(DGARY,DFN,DGENR,DGLINE,DGCNT) ;Priority factors 
"RTN","DGENL1",90,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGENL1",91,0)
 ;           DFN      Patient IEN
"RTN","DGENL1",92,0)
 ;           DGENR    Enrollment array
"RTN","DGENL1",93,0)
 ;           DGLINE   Line number
"RTN","DGENL1",94,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGENL1",95,0)
 N DGSTART
"RTN","DGENL1",96,0)
 ;
"RTN","DGENL1",97,0)
 S DGSTART=DGLINE ; starting line number
"RTN","DGENL1",98,0)
 D SET(DGARY,DGLINE,"Priority Factors",31,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGENL1",99,0)
 ;
"RTN","DGENL1",100,0)
 ;POW
"RTN","DGENL1",101,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",102,0)
 D SET(DGARY,DGLINE,"POW: "_$S($G(DGENR("ELIG","POW"))'="":$$EXT^DGENU("POW",DGENR("ELIG","POW")),1:""),19,,,,,,.DGCNT)
"RTN","DGENL1",103,0)
 ;
"RTN","DGENL1",104,0)
 ;Medal of Honor (DG*5.3*841)
"RTN","DGENL1",105,0)
 I $G(DGENR("ELIG","MOH"))="Y" D
"RTN","DGENL1",106,0)
 .D SET(DGARY,DGLINE,"Medal of Honor: YES",48,,,,,,.DGCNT)
"RTN","DGENL1",107,0)
 ;
"RTN","DGENL1",108,0)
 ;Purple Heart - added for patch 343;brm;10/23/00
"RTN","DGENL1",109,0)
 N PHDAT
"RTN","DGENL1",110,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",111,0)
 S PHDAT=$$PHEART(DFN,$G(DGENRIEN),$G(DGENR("DATETIME")))
"RTN","DGENL1",112,0)
 D SET(DGARY,DGLINE,"Purple Hrt: "_$P(PHDAT,U),12,,,,,,.DGCNT)
"RTN","DGENL1",113,0)
 D:$P(PHDAT,U)="YES" SET(DGARY,DGLINE,"Status: "_$P(PHDAT,U,2),32,,,,,,.DGCNT)
"RTN","DGENL1",114,0)
 D:$P(PHDAT,U)="NO" SET(DGARY,DGLINE,"Remarks: "_$P(PHDAT,U,3),31,,,,,,.DGCNT)
"RTN","DGENL1",115,0)
 ;
"RTN","DGENL1",116,0)
 ;Agent orange
"RTN","DGENL1",117,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",118,0)
 D SET(DGARY,DGLINE,"A/O Exp.: "_$S($G(DGENR("ELIG","AO"))'="":$$EXT^DGENU("AO",DGENR("ELIG","AO")),1:""),14,,,,,,.DGCNT)
"RTN","DGENL1",119,0)
 D SET(DGARY,DGLINE,"A/O Exp Loc: "_$S($G(DGENR("ELIG","AOEXPLOC"))'="":$$EXT^DGENU("AOEXPLOC",DGENR("ELIG","AOEXPLOC")),1:""),51,,,,,,.DGCNT)
"RTN","DGENL1",120,0)
 ;
"RTN","DGENL1",121,0)
 ;Ionizing radiation
"RTN","DGENL1",122,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",123,0)
 D SET(DGARY,DGLINE,"ION Rad.: "_$S($G(DGENR("ELIG","IR"))'="":$$EXT^DGENU("IR",DGENR("ELIG","IR")),1:""),14,,,,,,.DGCNT)
"RTN","DGENL1",124,0)
 ;
"RTN","DGENL1",125,0)
 ;Radiation Exposure Method
"RTN","DGENL1",126,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",127,0)
 D SET(DGARY,DGLINE,"Rad Exp Method: "_$S($G(DGENR("ELIG","RADEXPM"))'="":$$EXT^DGENU("RADEXPM",DGENR("ELIG","RADEXPM")),1:""),8,,,,,,.DGCNT)
"RTN","DGENL1",128,0)
 ;
"RTN","DGENL1",129,0)
 ;SW Asia Conditions - name change from Env con DG*5.3*688
"RTN","DGENL1",130,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",131,0)
 D SET(DGARY,DGLINE,"SW Asia Cond."_$S($G(DGENR("ELIG","EC"))'="":$$EXT^DGENU("EC",DGENR("ELIG","EC")),1:""),12,,,,,,.DGCNT)
"RTN","DGENL1",132,0)
 ;
"RTN","DGENL1",133,0)
 ;Military retirement - new fields added with DG*5.3*672
"RTN","DGENL1",134,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",135,0)
 S DGRET=$G(DGENR("ELIG","DISRET"))
"RTN","DGENL1",136,0)
 D SET(DGARY,DGLINE,"Mil Disab Retirement: "_$S($G(DGRET)=0:"NO",$G(DGRET)=1:"YES",$G(DGRET)=2:"YES",$G(DGRET)=3:"UNK",1:""),2,,,,,,.DGCNT)
"RTN","DGENL1",137,0)
 D SET(DGARY,DGLINE,"Dischrg Due to Disab: "_$S($G(DGENR("ELIG","DISLOD"))'="":$$EXT^DGENU("DISLOD",DGENR("ELIG","DISLOD")),1:""),42,,,,,,.DGCNT)
"RTN","DGENL1",138,0)
 ;
"RTN","DGENL1",139,0)
 ;Combat Vet End Date (added for DG*5.3*564 - HVE Phase III)
"RTN","DGENL1",140,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",141,0)
 D SET(DGARY,DGLINE,"Combat Vet End Date: "_$S($G(DGENR("ELIG","CVELEDT"))'="":$$EXT^DGENU("CVELEDT",DGENR("ELIG","CVELEDT")),1:""),3,,,,,,.DGCNT)
"RTN","DGENL1",142,0)
 ;
"RTN","DGENL1",143,0)
 ;Eligible for medicaid
"RTN","DGENL1",144,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",145,0)
 D SET(DGARY,DGLINE,"Eligible for MEDICAID: "_$S($G(DGENR("ELIG","MEDICAID"))'="":$$EXT^DGENU("MEDICAID",DGENR("ELIG","MEDICAID")),1:""),1,,,,,,.DGCNT)
"RTN","DGENL1",146,0)
 ;
"RTN","DGENL1",147,0)
 ;Service connected and percentage
"RTN","DGENL1",148,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",149,0)
 D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",150,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",151,0)
 D SET(DGARY,DGLINE,"Svc Connected: "_$S($G(DGENR("ELIG","SC"))'="":$$EXT^DGENU("SC",DGENR("ELIG","SC")),1:""),9,,,,,,.DGCNT)
"RTN","DGENL1",152,0)
 D SET(DGARY,DGLINE,"SC Percent: "_$S($G(DGENR("ELIG","SCPER"))'="":$$EXT^DGENU("SCPER",DGENR("ELIG","SCPER"))_"%",1:""),52,,,,,,.DGCNT)
"RTN","DGENL1",153,0)
 ;
"RTN","DGENL1",154,0)
 ;Aid & attendance and housebound
"RTN","DGENL1",155,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",156,0)
 D SET(DGARY,DGLINE,"Aid & Attendance: "_$S($G(DGENR("ELIG","A&A"))'="":$$EXT^DGENU("A&A",DGENR("ELIG","A&A")),1:""),6,,,,,,.DGCNT)
"RTN","DGENL1",157,0)
 D SET(DGARY,DGLINE,"Housebound: "_$S($G(DGENR("ELIG","HB"))'="":$$EXT^DGENU("HB",DGENR("ELIG","HB")),1:""),52,,,,,,.DGCNT)
"RTN","DGENL1",158,0)
 ;
"RTN","DGENL1",159,0)
 ;VA Pension
"RTN","DGENL1",160,0)
 ;Unemployable (added for DG*5.3*564 - HVE Phase III)
"RTN","DGENL1",161,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",162,0)
 D SET(DGARY,DGLINE,"VA Pension: "_$S($G(DGENR("ELIG","VAPEN"))'="":$$EXT^DGENU("VAPEN",DGENR("ELIG","VAPEN")),1:""),12,,,,,,.DGCNT)
"RTN","DGENL1",163,0)
 D SET(DGARY,DGLINE,"Unemployable: "_$S($G(DGENR("ELIG","UNEMPLOY"))'="":$$EXT^DGENU("UNEMPLOY",DGENR("ELIG","UNEMPLOY")),1:""),50,,,,,,.DGCNT)
"RTN","DGENL1",164,0)
 ;
"RTN","DGENL1",165,0)
 ;Total check amount
"RTN","DGENL1",166,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",167,0)
 D SET(DGARY,DGLINE,"Total Check Amount: "_$S($G(DGENR("ELIG","VACKAMT"))'="":$$EXT^DGENU("VACKAMT",DGENR("ELIG","VACKAMT")),1:""),4,,,,,,.DGCNT)
"RTN","DGENL1",168,0)
 ;
"RTN","DGENL1",169,0)
 ;PROJ 112/SHAD - DG*5.3*653
"RTN","DGENL1",170,0)
 I $G(DGENR("ELIG","SHAD"))=1 D
"RTN","DGENL1",171,0)
 .D SET(DGARY,DGLINE,"Proj 112/SHAD: "_$$EXT^DGENU("SHAD",DGENR("ELIG","SHAD")),49,,,,,,.DGCNT)
"RTN","DGENL1",172,0)
 ;
"RTN","DGENL1",173,0)
 ;Eligibility code
"RTN","DGENL1",174,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",175,0)
 D SET(DGARY,DGLINE,"Eligibility Code: "_$S($G(DGENR("ELIG","CODE"))'="":$$EXT^DGENU("CODE",DGENR("ELIG","CODE")),1:""),6,,,,,,.DGCNT)
"RTN","DGENL1",176,0)
 ;
"RTN","DGENL1",177,0)
 ;Means test
"RTN","DGENL1",178,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",179,0)
 D SET(DGARY,DGLINE,"Means Test Status: "_$S($G(DGENR("ELIG","MTSTA"))'="":$$EXT^DGENU("MTSTA",DGENR("ELIG","MTSTA")),1:""),5,,,,,,.DGCNT)
"RTN","DGENL1",180,0)
 ;
"RTN","DGENL1",181,0)
 ;Veteran Catastrophically Disabled
"RTN","DGENL1",182,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",183,0)
 D SET(DGARY,DGLINE,"Veteran CD Status: "_$S($G(DGENR("ELIG","VCD"))'="":$$EXT^DGENU("VCD",DGENR("ELIG","VCD")),1:""),5,,,,,,.DGCNT)
"RTN","DGENL1",184,0)
 ;
"RTN","DGENL1",185,0)
 ;Set line to start on next page
"RTN","DGENL1",186,0)
 F DGLINE=DGLINE+1:1:DGSTART+VALM("LINES") D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",187,0)
 Q
"RTN","DGENL1",188,0)
 ;
"RTN","DGENL1",189,0)
SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,DGCNT) ; moved to
"RTN","DGENL1",190,0)
 ;DGENL2 as DGENL1 was getting too big
"RTN","DGENL1",191,0)
 I $G(DGCOL)']"" S DGCOL=""
"RTN","DGENL1",192,0)
 I $G(DGON)']"" S DGON=""
"RTN","DGENL1",193,0)
 I $G(DGOFF)']"" S DGOFF=""
"RTN","DGENL1",194,0)
 I $G(DGSUB)']"" S DGSUB=""
"RTN","DGENL1",195,0)
 I $G(DGNUM)']"" S DGNUM=""
"RTN","DGENL1",196,0)
 I $G(DGDATA)']"" S DGDATA=""
"RTN","DGENL1",197,0)
 D SET^DGENL2(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,.DGCNT)
"RTN","DGENL1",198,0)
 Q
"RTN","DGENL1",199,0)
PHEART(DFN,DGENRIEN,PHENRDT) ;move to DGENL2
"RTN","DGENL1",200,0)
 N PHI,PHST,PHRR,PHDAT
"RTN","DGENL1",201,0)
 S PHDAT=$$PHEART^DGENL2(DFN,$G(DGENRIEN),$G(DGENR("DATETIME")))
"RTN","DGENL1",202,0)
 S PHI=$P(PHDAT,U),PHST=$P(PHDAT,U,2),PHRR=$P(PHDAT,U,3)
"RTN","DGENL1",203,0)
 I ($G(PHI)]""!($G(PHST)]"")!($G(PHRR)]"")) Q $G(PHI)_"^"_$G(PHST)_"^"_$G(PHRR)
"RTN","DGENL1",204,0)
 Q ""
"RTN","DGENPTA")
0^4^B40976431
"RTN","DGENPTA",1,0)
DGENPTA ;ALB/CJM,ERC,CKN,TDM,PWC - Patient API - Retrieve Data ; 5/23/11 4:51pm
"RTN","DGENPTA",2,0)
 ;;5.3;Registration;**121,122,147,688,754,838,841**;Aug 13,1993;Build 7
"RTN","DGENPTA",3,0)
 ;
"RTN","DGENPTA",4,0)
VET(DFN) ;returns 1 if the patient is an eligible veteran
"RTN","DGENPTA",5,0)
 ;returns 0 if not a veteran or not eligible
"RTN","DGENPTA",6,0)
 ;
"RTN","DGENPTA",7,0)
 N VET S VET=0
"RTN","DGENPTA",8,0)
 I $G(DFN),$D(^DPT(DFN,0)) D
"RTN","DGENPTA",9,0)
 .S VET=1
"RTN","DGENPTA",10,0)
 .I $P($G(^DPT(DFN,"VET")),"^")="N" S VET=0
"RTN","DGENPTA",11,0)
 .I $P($G(^DPT(DFN,.15)),"^",2) S VET=0
"RTN","DGENPTA",12,0)
 Q VET
"RTN","DGENPTA",13,0)
 ;
"RTN","DGENPTA",14,0)
VET1(DFN) ;returns 1 if the patient is a veteran
"RTN","DGENPTA",15,0)
 ;returns 0 if not a veteran
"RTN","DGENPTA",16,0)
 ;
"RTN","DGENPTA",17,0)
 N VET S VET=0
"RTN","DGENPTA",18,0)
 I $G(DFN),$D(^DPT(DFN,0)) D
"RTN","DGENPTA",19,0)
 .I $P($G(^DPT(DFN,"VET")),"^")="Y" S VET=1
"RTN","DGENPTA",20,0)
 Q VET
"RTN","DGENPTA",21,0)
 ;
"RTN","DGENPTA",22,0)
ACTIVE(DFN,DGDT) ;
"RTN","DGENPTA",23,0)
 ;Description - Used to determine whether or not the patient has had a
"RTN","DGENPTA",24,0)
 ;  recent epiosode of inpatient or outpatient care.
"RTN","DGENPTA",25,0)
 ;Input:
"RTN","DGENPTA",26,0)
 ;  DFN - ien of record in Patient file
"RTN","DGENPTA",27,0)
 ;  DGDT - date used to specify how far back to go looking for episode
"RTN","DGENPTA",28,0)
 ;      of care
"RTN","DGENPTA",29,0)
 ;Output -
"RTN","DGENPTA",30,0)
 ;  returns 1 if recent episode of care, 0 otherwise
"RTN","DGENPTA",31,0)
 ;
"RTN","DGENPTA",32,0)
 ;!!!!!!! NOTE: This routine is not complete. !!!!!!!!!!!!!!!
"RTN","DGENPTA",33,0)
 ; Still need to define how user wants to define an 'active' patient.
"RTN","DGENPTA",34,0)
 ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"RTN","DGENPTA",35,0)
 ;
"RTN","DGENPTA",36,0)
 Q 1
"RTN","DGENPTA",37,0)
 ;
"RTN","DGENPTA",38,0)
PREF(DFN,FACNAME) ;
"RTN","DGENPTA",39,0)
 ;Description: Used to determine the patient's preferred facility.
"RTN","DGENPTA",40,0)
 ;Input:
"RTN","DGENPTA",41,0)
 ;  DFN - an ien of a record in the PATIENT file
"RTN","DGENPTA",42,0)
 ;Output:     
"RTN","DGENPTA",43,0)
 ;  Function Value - Returns a pointer to the INSTITUTION file entry that
"RTN","DGENPTA",44,0)
 ;    is the patient's preferred facility, NULL if the preferred facility
"RTN","DGENPTA",45,0)
 ;    can not be determined.
"RTN","DGENPTA",46,0)
 ;  FACNAME - optional parm, pass by reference - returns institution name
"RTN","DGENPTA",47,0)
 ;
"RTN","DGENPTA",48,0)
 N FAC
"RTN","DGENPTA",49,0)
 S (FACNAME,FAC)=""
"RTN","DGENPTA",50,0)
 I $D(DFN),$D(^DPT(DFN,0)) S FAC=$P($G(^DPT(DFN,"ENR")),"^",2)
"RTN","DGENPTA",51,0)
 S:FAC FACNAME=$P($G(^DIC(4,FAC,0)),"^")
"RTN","DGENPTA",52,0)
 Q FAC
"RTN","DGENPTA",53,0)
 ;
"RTN","DGENPTA",54,0)
DEATH(DFN) ;
"RTN","DGENPTA",55,0)
 ;Description: Used to determine whether or not the patient is alive.
"RTN","DGENPTA",56,0)
 ;Input:
"RTN","DGENPTA",57,0)
 ;  DFN - an ien of a record in the PATIENT file
"RTN","DGENPTA",58,0)
 ;Output:     
"RTN","DGENPTA",59,0)
 ;  Function Value - Returns 0 if there is no record of the patient's
"RTN","DGENPTA",60,0)
 ;    death, otherwise returns the patients date of death
"RTN","DGENPTA",61,0)
 ;
"RTN","DGENPTA",62,0)
 N DATE S DATE=0
"RTN","DGENPTA",63,0)
 I $D(DFN),$D(^DPT(DFN,0)) S DATE=$P($G(^DPT(DFN,.35)),"^")
"RTN","DGENPTA",64,0)
 I DATE S DATE=(DATE\1) ;get rid of the time portion
"RTN","DGENPTA",65,0)
 Q +DATE
"RTN","DGENPTA",66,0)
 ;
"RTN","DGENPTA",67,0)
GET(DFN,DGPAT) ;
"RTN","DGENPTA",68,0)
 ;Description: Returns DGPAT() array with identifying info for patient
"RTN","DGENPTA",69,0)
 ;  Input:
"RTN","DGENPTA",70,0)
 ;    DFN - ien, PATIENT file
"RTN","DGENPTA",71,0)
 ;  Output:
"RTN","DGENPTA",72,0)
 ;    Function Value - 1 on success, 0 on failure
"RTN","DGENPTA",73,0)
 ;    DGPAT() array (pass by reference)
"RTN","DGENPTA",74,0)
 ;      "DEATH" - date of death
"RTN","DGENPTA",75,0)
 ;      "DFN" - ien, PATIENT file
"RTN","DGENPTA",76,0)
 ;      "DOB" - date of birth
"RTN","DGENPTA",77,0)
 ;      "INELDATE" - INELIGIBLE DATE
"RTN","DGENPTA",78,0)
 ;      "INELREA" - INELIGIBLE REASON
"RTN","DGENPTA",79,0)
 ;      "INELDEC" - INELIGIBLE VARO DECISION
"RTN","DGENPTA",80,0)
 ;      "NAME" - patient name
"RTN","DGENPTA",81,0)
 ;      "PATYPE" - patient type
"RTN","DGENPTA",82,0)
 ;      "PID" - Primary Long ID
"RTN","DGENPTA",83,0)
 ;      "PREFAC" - preferred facility
"RTN","DGENPTA",84,0)
 ;      "PFSRC" - preferred facility source designation
"RTN","DGENPTA",85,0)
 ;      "SSN" - Social Security Number
"RTN","DGENPTA",86,0)
 ;      "SEX" - M=male, F=female
"RTN","DGENPTA",87,0)
 ;      "VETERAN" - VETERAN (Y/N)? - "Y"=YES,"N"=NO
"RTN","DGENPTA",88,0)
 ;      "AG/ALLY" - Agency/Allied Country
"RTN","DGENPTA",89,0)
 ;      "SPININJ" - Spinal Cord Injury
"RTN","DGENPTA",90,0)
 ;      "MOH" - Medal of Honor
"RTN","DGENPTA",91,0)
 ;
"RTN","DGENPTA",92,0)
 N NODE
"RTN","DGENPTA",93,0)
 Q:'$G(DFN) 0
"RTN","DGENPTA",94,0)
 K DGPAT S DGPAT=""
"RTN","DGENPTA",95,0)
 S DGPAT("DFN")=DFN
"RTN","DGENPTA",96,0)
 S NODE=$G(^DPT(DFN,0))
"RTN","DGENPTA",97,0)
 Q:NODE="" 0
"RTN","DGENPTA",98,0)
 S DGPAT("NAME")=$P(NODE,"^")
"RTN","DGENPTA",99,0)
 S DGPAT("DOB")=$P(NODE,"^",3)
"RTN","DGENPTA",100,0)
 S DGPAT("SEX")=$P(NODE,"^",2)
"RTN","DGENPTA",101,0)
 S DGPAT("SSN")=$P(NODE,"^",9)
"RTN","DGENPTA",102,0)
 ;
"RTN","DGENPTA",103,0)
 S DGPAT("DEATH")=$P($G(^DPT(DFN,.35)),"^")
"RTN","DGENPTA",104,0)
 S DGPAT("PATYPE")=$P($G(^DPT(DFN,"TYPE")),"^")
"RTN","DGENPTA",105,0)
 S DGPAT("VETERAN")=$P($G(^DPT(DFN,"VET")),"^")
"RTN","DGENPTA",106,0)
 S DGPAT("PREFAC")=$P($G(^DPT(DFN,"ENR")),"^",2)
"RTN","DGENPTA",107,0)
 S DGPAT("PFSRC")=$P($G(^DPT(DFN,"ENR")),"^",3)
"RTN","DGENPTA",108,0)
 S DGPAT("INELDATE")=$P($G(^DPT(DFN,.15)),"^",2)
"RTN","DGENPTA",109,0)
 S DGPAT("INELREA")=$P($G(^DPT(DFN,.3)),"^",7)
"RTN","DGENPTA",110,0)
 S DGPAT("INELDEC")=$P($G(^DPT(DFN,"INE")),"^",6)
"RTN","DGENPTA",111,0)
 S DGPAT("PID")=$P($G(^DPT(DFN,.36)),"^",3)
"RTN","DGENPTA",112,0)
 S DGPAT("AG/ALLY")=$P($G(^DPT(DFN,.3)),"^",9)
"RTN","DGENPTA",113,0)
 S DGPAT("SPININJ")=$P($G(^DPT(DFN,57)),"^",4)
"RTN","DGENPTA",114,0)
 S DGPAT("MOH")=$P($G(^DPT(DFN,.54)),"^",1)
"RTN","DGENPTA",115,0)
 Q 1
"RTN","DGENPTA",116,0)
 ;
"RTN","DGENPTA",117,0)
SSN(DFN) ;
"RTN","DGENPTA",118,0)
 ;Description: Function returns the patient's SSN, or "" on failure.
"RTN","DGENPTA",119,0)
 ;
"RTN","DGENPTA",120,0)
 Q:'DFN ""
"RTN","DGENPTA",121,0)
 Q $P($G(^DPT(DFN,0)),"^",9)
"RTN","DGENPTA",122,0)
 ;
"RTN","DGENPTA",123,0)
NAME(DFN) ;
"RTN","DGENPTA",124,0)
 ;Description: Function returns the patient's NAME, or "" on failure.
"RTN","DGENPTA",125,0)
 ;
"RTN","DGENPTA",126,0)
 Q:'DFN ""
"RTN","DGENPTA",127,0)
 Q $P($G(^DPT(DFN,0)),"^")
"RTN","DGENPTA",128,0)
 ;
"RTN","DGENPTA",129,0)
EXT(SUB,VAL) ;
"RTN","DGENPTA",130,0)
 ;Description: Given the subscript used in the PATIENT object array,
"RTN","DGENPTA",131,0)
 ;   DGPAT(), and a field value, returns the external representation of
"RTN","DGENPTA",132,0)
 ;   the value, as defined in the fields output transform of the PATIENT
"RTN","DGENPTA",133,0)
 ;   file.
"RTN","DGENPTA",134,0)
 ;Input: 
"RTN","DGENPTA",135,0)
 ;  SUB - array subscript
"RTN","DGENPTA",136,0)
 ;  VAL - field value
"RTN","DGENPTA",137,0)
 ;Output:
"RTN","DGENPTA",138,0)
 ;  Function Value - returns the external value of the field
"RTN","DGENPTA",139,0)
 ;
"RTN","DGENPTA",140,0)
 Q:(($G(SUB)="")!($G(VAL)="")) ""
"RTN","DGENPTA",141,0)
 ;
"RTN","DGENPTA",142,0)
 N FLD
"RTN","DGENPTA",143,0)
 S FLD=$$FIELD^DGENPTA1(SUB)
"RTN","DGENPTA",144,0)
 Q:(FLD="") ""
"RTN","DGENPTA",145,0)
 Q $$EXTERNAL^DILFD(2,FLD,"F",VAL)
"RTN","DGENPTA",146,0)
 ;
"RTN","DGENPTA",147,0)
 ;
"RTN","DGENPTA",148,0)
VALPAT(DFN) ; --
"RTN","DGENPTA",149,0)
 ; Description: This function returns a 1 if the patient DFN is valid, 0 if the patient DFN is not valid.
"RTN","DGENPTA",150,0)
 ;
"RTN","DGENPTA",151,0)
 ;  Input:
"RTN","DGENPTA",152,0)
 ;    DFN - as pointer to patient in Patient (#2) file
"RTN","DGENPTA",153,0)
 ;
"RTN","DGENPTA",154,0)
 ; Output:
"RTN","DGENPTA",155,0)
 ;   Function Value - Is patient (DFN) valid?
"RTN","DGENPTA",156,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",157,0)
 ;
"RTN","DGENPTA",158,0)
 ; init variables
"RTN","DGENPTA",159,0)
 N DGVALID S DGVALID=0
"RTN","DGENPTA",160,0)
 ;
"RTN","DGENPTA",161,0)
 ; is patient (DFN) valid?
"RTN","DGENPTA",162,0)
 I $G(DFN),$D(^DPT(DFN,0)) S DGVALID=1
"RTN","DGENPTA",163,0)
 ;
"RTN","DGENPTA",164,0)
 Q DGVALID
"RTN","DGENPTA",165,0)
 ;
"RTN","DGENPTA",166,0)
 ;
"RTN","DGENPTA",167,0)
CURINPAT(DFN) ; --
"RTN","DGENPTA",168,0)
 ; Description: This function will determine if the patient is a current inpatient.
"RTN","DGENPTA",169,0)
 ;
"RTN","DGENPTA",170,0)
 ;  Input:
"RTN","DGENPTA",171,0)
 ;    DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",172,0)
 ;
"RTN","DGENPTA",173,0)
 ; Output:
"RTN","DGENPTA",174,0)
 ;   Function Value - Is patient a current inpatient? 
"RTN","DGENPTA",175,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",176,0)
 ;
"RTN","DGENPTA",177,0)
 N DGCUR S DGCUR=0
"RTN","DGENPTA",178,0)
 ;
"RTN","DGENPTA",179,0)
 ; if valid patient, check if current inpatient
"RTN","DGENPTA",180,0)
 I $$VALPAT(DFN) D
"RTN","DGENPTA",181,0)
 .;
"RTN","DGENPTA",182,0)
 .; is patient a current inpatient?
"RTN","DGENPTA",183,0)
 .I $G(^DPT(DFN,.105)) S DGCUR=1
"RTN","DGENPTA",184,0)
 ;
"RTN","DGENPTA",185,0)
 Q DGCUR
"RTN","DGENPTA",186,0)
 ;
"RTN","DGENPTA",187,0)
 ;
"RTN","DGENPTA",188,0)
INPAT(DFN,DGBEG,DGEND) ; --
"RTN","DGENPTA",189,0)
 ; Description: This function will determine if a patient was an inpatient between a specified date range.
"RTN","DGENPTA",190,0)
 ;
"RTN","DGENPTA",191,0)
 ;  Input:
"RTN","DGENPTA",192,0)
 ;       DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",193,0)
 ;    DGBEG - as begin date/time for inpatient search
"RTN","DGENPTA",194,0)
 ;    DGEND - as end date/time for inpatient search
"RTN","DGENPTA",195,0)
 ;
"RTN","DGENPTA",196,0)
 ; Output:
"RTN","DGENPTA",197,0)
 ;   Function Value - Was patient an inpatient between date range?
"RTN","DGENPTA",198,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",199,0)
 ;
"RTN","DGENPTA",200,0)
 N DGINPAT,DGSDT,DGEDT,DGMOVE,DGTRANS
"RTN","DGENPTA",201,0)
 S DGINPAT=0
"RTN","DGENPTA",202,0)
 ;
"RTN","DGENPTA",203,0)
 ; if not valid patient (DFN) and not valid date range, exit
"RTN","DGENPTA",204,0)
 I '$$VALPAT(DFN),'($$RANGE(DGBEG,DGEND)) G INPATQ
"RTN","DGENPTA",205,0)
 ;
"RTN","DGENPTA",206,0)
 ; init date/time(s)
"RTN","DGENPTA",207,0)
 S DGSDT=DGBEG-.0001,DGEDT=DGEND+$S($P(DGEND,".",2)="":.2359,1:"")
"RTN","DGENPTA",208,0)
 ;
"RTN","DGENPTA",209,0)
 ; use "APRD" x-ref of Patient Movement (#405) file
"RTN","DGENPTA",210,0)
 F  S DGSDT=$O(^DGPM("APRD",+DFN,DGSDT)) Q:'DGSDT!(DGSDT>DGEDT)!(DGINPAT)  D
"RTN","DGENPTA",211,0)
 .S DGMOVE=0 F  S DGMOVE=$O(^DGPM("APRD",+DFN,DGSDT,DGMOVE)) Q:'DGMOVE!(DGINPAT)  D
"RTN","DGENPTA",212,0)
 ..; - transaction type of movement
"RTN","DGENPTA",213,0)
 ..S DGTRANS=$P($G(^DGPM(DGMOVE,0)),"^",2)  ; movement transaction type
"RTN","DGENPTA",214,0)
 ..; - if trans type not DISCHARGE, CHECK-IN LODGER, CHECK-OUT LODGER
"RTN","DGENPTA",215,0)
 ..I DGTRANS'=3,(DGTRANS'=4),(DGTRANS'=5) S DGINPAT=1
"RTN","DGENPTA",216,0)
 ;
"RTN","DGENPTA",217,0)
INPATQ Q DGINPAT
"RTN","DGENPTA",218,0)
 ;
"RTN","DGENPTA",219,0)
 ;
"RTN","DGENPTA",220,0)
OUTPAT(DFN,DGBEG,DGEND) ; --
"RTN","DGENPTA",221,0)
 ; Description: This function will determine if a patient has an outpatient encounter between a specified date range that has successfully been checked out.
"RTN","DGENPTA",222,0)
 ;
"RTN","DGENPTA",223,0)
 ;  Input:
"RTN","DGENPTA",224,0)
 ;       DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",225,0)
 ;    DGBEG - as begin date/time for outpatient search
"RTN","DGENPTA",226,0)
 ;    DGEND - as end date/time for outpatient search
"RTN","DGENPTA",227,0)
 ;
"RTN","DGENPTA",228,0)
 ; Output:
"RTN","DGENPTA",229,0)
 ;   Function Value - Does patient have outpatient encounter between date
"RTN","DGENPTA",230,0)
 ;                    range that that has successfully been checked out?
"RTN","DGENPTA",231,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",232,0)
 ;
"RTN","DGENPTA",233,0)
 N DGOUT,DGSDT,DGEDT,DGOE
"RTN","DGENPTA",234,0)
 S DGOUT=0
"RTN","DGENPTA",235,0)
 ;
"RTN","DGENPTA",236,0)
 ; if not valid patient (DFN) and not valid date range, exit
"RTN","DGENPTA",237,0)
 I '$$VALPAT(DFN),'($$RANGE(DGBEG,DGEND)) G OUTPATQ
"RTN","DGENPTA",238,0)
 ;
"RTN","DGENPTA",239,0)
 ; init date/time(s)
"RTN","DGENPTA",240,0)
 S DGSDT=DGBEG-.0001,DGEDT=DGEND+$S($P(DGEND,".",2)="":.2359,1:"")
"RTN","DGENPTA",241,0)
 ;
"RTN","DGENPTA",242,0)
 ; use "ADFN" x-ref of Outpatient Encounter (#409.68) file
"RTN","DGENPTA",243,0)
 F  S DGSDT=$O(^SCE("ADFN",+DFN,DGSDT)) Q:'DGSDT!(DGSDT>DGEDT)!(DGOUT)  D
"RTN","DGENPTA",244,0)
 .;
"RTN","DGENPTA",245,0)
 .S DGOE=0 F  S DGOE=$O(^SCE("ADFN",+DFN,DGSDT,DGOE)) Q:'DGOE!(DGOUT)  D
"RTN","DGENPTA",246,0)
 ..; - if encounter checked out, set flag
"RTN","DGENPTA",247,0)
 ..I $P($G(^SCE(+DGOE,0)),"^",7) S DGOUT=1
"RTN","DGENPTA",248,0)
 ;
"RTN","DGENPTA",249,0)
OUTPATQ Q DGOUT
"RTN","DGENPTA",250,0)
 ;
"RTN","DGENPTA",251,0)
 ;
"RTN","DGENPTA",252,0)
RANGE(DGBEG,DGEND) ; --
"RTN","DGENPTA",253,0)
 ; Description: This function returns a 1 if two dates are a valid date range, 0 if they are not valid.
"RTN","DGENPTA",254,0)
 ;
"RTN","DGENPTA",255,0)
 ;  Input:
"RTN","DGENPTA",256,0)
 ;    DGBEG - as begin date of date range
"RTN","DGENPTA",257,0)
 ;    DGEND - as end date of date range
"RTN","DGENPTA",258,0)
 ;
"RTN","DGENPTA",259,0)
 ; Output:
"RTN","DGENPTA",260,0)
 ;   Function Value - Is date range valid?
"RTN","DGENPTA",261,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",262,0)
 ;
"RTN","DGENPTA",263,0)
 N DGOK
"RTN","DGENPTA",264,0)
 ;
"RTN","DGENPTA",265,0)
 S DGOK=0
"RTN","DGENPTA",266,0)
 ;
"RTN","DGENPTA",267,0)
 ; if input parameters not defined, exit
"RTN","DGENPTA",268,0)
 I '$D(DGBEG),('$D(DGEND)) G RANGEQ
"RTN","DGENPTA",269,0)
 ;
"RTN","DGENPTA",270,0)
 ; remove time from dates
"RTN","DGENPTA",271,0)
 S DGBEG=(DGBEG/1),DGEND=(DGEND/1)
"RTN","DGENPTA",272,0)
 ;
"RTN","DGENPTA",273,0)
 ; if begin date greater than end date, exit
"RTN","DGENPTA",274,0)
 I DGBEG>DGEND G RANGEQ
"RTN","DGENPTA",275,0)
 ;
"RTN","DGENPTA",276,0)
 ; if begin date and end date future dates, exit
"RTN","DGENPTA",277,0)
 I DGBEG>DT,(DGEND>DT) G RANGEQ
"RTN","DGENPTA",278,0)
 ;
"RTN","DGENPTA",279,0)
 S DGOK=1
"RTN","DGENPTA",280,0)
 ;
"RTN","DGENPTA",281,0)
RANGEQ Q DGOK
"RTN","DGENPTA",282,0)
 ;
"RTN","DGENPTA",283,0)
LOOKUP(SSN,DOB,SEX,ERROR) ;
"RTN","DGENPTA",284,0)
 ;Description: This function will do a search for the patient based on
"RTN","DGENPTA",285,0)
 ;the identifying information provided. The function will be successful
"RTN","DGENPTA",286,0)
 ;only if a single patient is found matching the identifiers provided.
"RTN","DGENPTA",287,0)
 ;
"RTN","DGENPTA",288,0)
 ;Inputs:
"RTN","DGENPTA",289,0)
 ;  SSN - patient Social Security Number
"RTN","DGENPTA",290,0)
 ;  DOB - patient date of birth (FM format)
"RTN","DGENPTA",291,0)
 ;  SEX - patient sex
"RTN","DGENPTA",292,0)
 ;Outputs:
"RTN","DGENPTA",293,0)
 ;  Function Value - patient DFN if successful, 0 otherwise
"RTN","DGENPTA",294,0)
 ;  ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
"RTN","DGENPTA",295,0)
 ;
"RTN","DGENPTA",296,0)
 N DFN,NODE
"RTN","DGENPTA",297,0)
 ;
"RTN","DGENPTA",298,0)
 I $G(SSN)="" S ERROR="INVALID SSN" Q 0
"RTN","DGENPTA",299,0)
 S DFN=$O(^DPT("SSN",SSN,0))
"RTN","DGENPTA",300,0)
 I 'DFN S ERROR="SSN NOT FOUND" Q 0
"RTN","DGENPTA",301,0)
 I $O(^DPT("SSN",SSN,DFN)) S ERROR="MULTIPLE PATIENTS MATCHING SSN" Q 0
"RTN","DGENPTA",302,0)
 S NODE=$G(^DPT(DFN,0))
"RTN","DGENPTA",303,0)
 I $P(NODE,"^",2)'=SEX S ERROR="SEX DOES NOT MATCH" Q 0
"RTN","DGENPTA",304,0)
 I $E($P(NODE,"^",3),1,3)'=$E(DOB,1,3) S ERROR="DOB DOES NOT MATCH" Q 0
"RTN","DGENPTA",305,0)
 I $E($P(NODE,"^",3),4,5),$E($P(NODE,"^",3),4,5)'=$E(DOB,4,5) S ERROR="DOB DOES NOT MATCH" Q 0
"RTN","DGENPTA",306,0)
 Q DFN
"RTN","DGENPTA1")
0^5^B22181053
"RTN","DGENPTA1",1,0)
DGENPTA1 ;ALB/CJM,EG,CKN,ERC,TDM,PWC - Patient API - File Data ; 5/23/11 4:52pm
"RTN","DGENPTA1",2,0)
 ;;5.3;Registration;**121,147,314,677,659,653,688,810,754,838,841**;Aug 13,1993;Build 7
"RTN","DGENPTA1",3,0)
 ;
"RTN","DGENPTA1",4,0)
LOCK(DFN) ;
"RTN","DGENPTA1",5,0)
 ;Description: Given an internal entry number of a PATIENT  record, this
"RTN","DGENPTA1",6,0)
 ;   function will lock the record. It should be used when updating the
"RTN","DGENPTA1",7,0)
 ;   record.
"RTN","DGENPTA1",8,0)
 ;Input:
"RTN","DGENPTA1",9,0)
 ;  DFN - Patient IEN
"RTN","DGENPTA1",10,0)
 ;Output:
"RTN","DGENPTA1",11,0)
 ;  Function Value - Returns 1 if the lock was successful, 0 otherwise
"RTN","DGENPTA1",12,0)
 ;
"RTN","DGENPTA1",13,0)
 I $G(DFN) L +^DPT(DFN):2
"RTN","DGENPTA1",14,0)
 Q $T
"RTN","DGENPTA1",15,0)
UNLOCK(DFN) ;
"RTN","DGENPTA1",16,0)
 ;Description: Given an internal entry number of a record in the PATIENT
"RTN","DGENPTA1",17,0)
 ;   file, this function will unlock the record that was previously
"RTN","DGENPTA1",18,0)
 ;   locked by LOCK PATIENT RECORD.  
"RTN","DGENPTA1",19,0)
 ;Input:
"RTN","DGENPTA1",20,0)
 ;   DFN - Patient IEN
"RTN","DGENPTA1",21,0)
 ;Output: None
"RTN","DGENPTA1",22,0)
 ;
"RTN","DGENPTA1",23,0)
 I $G(DFN) L -^DPT(DFN)
"RTN","DGENPTA1",24,0)
 Q
"RTN","DGENPTA1",25,0)
 ;
"RTN","DGENPTA1",26,0)
STOREPRE(DFN,DGPREFAC) ;
"RTN","DGENPTA1",27,0)
 ;Description: Used to store the patient's preferred facility in the
"RTN","DGENPTA1",28,0)
 ;   patient record.
"RTN","DGENPTA1",29,0)
 ;Input:
"RTN","DGENPTA1",30,0)
 ;  DFN - Patient IEN
"RTN","DGENPTA1",31,0)
 ;  DGPREFAC - pointer to the record in the INSTITUTION file.
"RTN","DGENPTA1",32,0)
 ;Output:
"RTN","DGENPTA1",33,0)
 ;  Function Value - Returns 1 on success, 0 on failure.
"RTN","DGENPTA1",34,0)
 ;
"RTN","DGENPTA1",35,0)
 N SUCCESS,DATA
"RTN","DGENPTA1",36,0)
 S SUCCESS=1
"RTN","DGENPTA1",37,0)
 D  ;drops out if invalid condition found
"RTN","DGENPTA1",38,0)
 . I $G(DFN),$D(^DPT(DFN,0))
"RTN","DGENPTA1",39,0)
 . E  S SUCCESS=0 Q
"RTN","DGENPTA1",40,0)
 . I ($G(DGPREFAC)'=""),'$G(DGPREFAC) S SUCCESS=0 Q
"RTN","DGENPTA1",41,0)
 . I $G(DGPREFAC),'$D(^DIC(4,DGPREFAC,0)) S SUCCESS=0 Q
"RTN","DGENPTA1",42,0)
 . S DATA(27.02)=DGPREFAC
"RTN","DGENPTA1",43,0)
 . S DATA(27.03)="V"     ; DG*5.3*838
"RTN","DGENPTA1",44,0)
 . S SUCCESS=$$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGENPTA1",45,0)
 Q SUCCESS
"RTN","DGENPTA1",46,0)
 ;
"RTN","DGENPTA1",47,0)
CHECK(DGPAT,ERROR) ;
"RTN","DGENPTA1",48,0)
 ;Description: Does validation checks on the patient contained in the
"RTN","DGENPTA1",49,0)
 ;DGPAT array.
"RTN","DGENPTA1",50,0)
 ;
"RTN","DGENPTA1",51,0)
 ;Input:
"RTN","DGENPTA1",52,0)
 ;  DGPAT - this local array contains patient data
"RTN","DGENPTA1",53,0)
 ;Output:
"RTN","DGENPTA1",54,0)
 ;  Function Value - returns 1 if all validation checks passed, 0 otherwise
"RTN","DGENPTA1",55,0)
 ;  ERROR - if validation checks fail, an error message is returned (pass by reference)
"RTN","DGENPTA1",56,0)
 ;
"RTN","DGENPTA1",57,0)
 ;
"RTN","DGENPTA1",58,0)
 N SUCCESS,FIELD
"RTN","DGENPTA1",59,0)
 S SUCCESS=1
"RTN","DGENPTA1",60,0)
 S ERROR=""
"RTN","DGENPTA1",61,0)
 ;
"RTN","DGENPTA1",62,0)
 ;check field values
"RTN","DGENPTA1",63,0)
 ;
"RTN","DGENPTA1",64,0)
 ;some of the field's input transforms require DA or DUZ to be defined, so do not do this
"RTN","DGENPTA1",65,0)
 ;F  S SUB=$O(DGPAT(SUB)) Q:SUB=""  D:(DGPAT(SUB)'="")  Q:'SUCCESS
"RTN","DGENPTA1",66,0)
 ;.S FIELD=$$FIELD(SUB)
"RTN","DGENPTA1",67,0)
 ;.I '$$TESTVAL^DGENDBS(2,FIELD,DGPAT(SUB)) D
"RTN","DGENPTA1",68,0)
 ;..S SUCCESS=0
"RTN","DGENPTA1",69,0)
 ;..S ERROR="BAD FIELD VALUE, PATIENT FILE FIELD = "_$$GET1^DID(2,FIELD,,"LABEL")
"RTN","DGENPTA1",70,0)
 ;
"RTN","DGENPTA1",71,0)
 ;instead, check field values without referencing DD
"RTN","DGENPTA1",72,0)
 I DGPAT("INELDEC")'="",($L(DGPAT("INELDEC"))>75)!($L(DGPAT("INELDEC"))<3) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE VARO DECISION" G QCHECK
"RTN","DGENPTA1",73,0)
 ;
"RTN","DGENPTA1",74,0)
 I DGPAT("INELREA")'="",($L(DGPAT("INELREA"))>40) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE REASON" G QCHECK
"RTN","DGENPTA1",75,0)
 ;
"RTN","DGENPTA1",76,0)
 I DGPAT("VETERAN")="" S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD = VETERAN (Y/N)?" G QCHECK
"RTN","DGENPTA1",77,0)
 ;
"RTN","DGENPTA1",78,0)
 I DGPAT("DEATH"),(DGPAT("DEATH")>DT) S SUCCESS=0,ERROR="DATE OF DEATH CAN NOT BE A FUTURE DATE" G QCHECK
"RTN","DGENPTA1",79,0)
 ;
"RTN","DGENPTA1",80,0)
 I DGPAT("INELDATE"),(DGPAT("INELREA")="") S SUCCESS=0,ERROR="INELIGIBLE REASON UNSPECIFIED FOR INELIGIBLE PATIENT" G QCHECK
"RTN","DGENPTA1",81,0)
 ;
"RTN","DGENPTA1",82,0)
QCHECK ;
"RTN","DGENPTA1",83,0)
 Q SUCCESS
"RTN","DGENPTA1",84,0)
 ;
"RTN","DGENPTA1",85,0)
STORE(DGPAT,ERROR,NOCHECK) ;
"RTN","DGENPTA1",86,0)
 ;Description: Files data in the patient record.  It requires a lock
"RTN","DGENPTA1",87,0)
 ;on the Patient record, adn releases the lock when done.
"RTN","DGENPTA1",88,0)
 ;
"RTN","DGENPTA1",89,0)
 ;Input:
"RTN","DGENPTA1",90,0)
 ;  DGPAT- the patient array, passed by reference
"RTN","DGENPTA1",91,0)
 ;  NOCHECK - a flag, if set to 1 it means consistency checks were done aready, so skip
"RTN","DGENPTA1",92,0)
 ;
"RTN","DGENPTA1",93,0)
 ;Output:
"RTN","DGENPTA1",94,0)
 ;  Function Value - returns 1 if successful, otherwise 0
"RTN","DGENPTA1",95,0)
 ;  ERROR - on failure, an error message is returned (optional, pass by reference)
"RTN","DGENPTA1",96,0)
 ;
"RTN","DGENPTA1",97,0)
 S ERROR=""
"RTN","DGENPTA1",98,0)
 I '$D(DGPAT) S ERROR="PATIENT NOT FOUND" Q 0
"RTN","DGENPTA1",99,0)
 I '$$LOCK(DGPAT("DFN")) S ERROR="UNABLE TO LOCK THE PATIENT RECORD" Q 0
"RTN","DGENPTA1",100,0)
 I $G(NOCHECK)'=1 Q:'$$CHECK(.DGPAT,.ERROR) 0
"RTN","DGENPTA1",101,0)
 ;
"RTN","DGENPTA1",102,0)
 N DATA,SUB,FIELD,SUCCESS
"RTN","DGENPTA1",103,0)
 S SUB=""
"RTN","DGENPTA1",104,0)
 ;
"RTN","DGENPTA1",105,0)
 F  S SUB=$O(DGPAT(SUB)) Q:(SUB="")  I (SUB'="DEATH")&(SUB'="SSN") S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=$G(DGPAT(SUB))
"RTN","DGENPTA1",106,0)
 S SUCCESS=$$UPD^DGENDBS(2,DGPAT("DFN"),.DATA)
"RTN","DGENPTA1",107,0)
 I 'SUCCESS S ERROR="FILEMAN UNABLE TO UPDATE PATIENT RECORD"
"RTN","DGENPTA1",108,0)
 ; Call Purple Heart API to file PH data in file 2
"RTN","DGENPTA1",109,0)
 I SUCCESS,$D(DGPAT("PHI")) D EDITPH^DGRPLE($G(DGPAT("PHI")),$G(DGPAT("PHST")),$G(DGPAT("PHRR")),DGPAT("DFN"))
"RTN","DGENPTA1",110,0)
 ; Call POW API to file POW data in file 2 - DG*5.3*653
"RTN","DGENPTA1",111,0)
 ;I SUCCESS,$D(DGPAT("POWI")) D EDITPOW^DGRPLE($G(DGPAT("POWI")),$G(DGPAT("POWLOC")),$G(DGPAT("POWFDT")),$G(DGPAT("POWTDT")),DGPAT("DFN"))
"RTN","DGENPTA1",112,0)
 I SUCCESS D
"RTN","DGENPTA1",113,0)
 . I '$D(DGPAT("POWI")) D  Q
"RTN","DGENPTA1",114,0)
 . . N DATA,ERROR,DGENDA
"RTN","DGENPTA1",115,0)
 . . S DGENDA=DGPAT("DFN")
"RTN","DGENPTA1",116,0)
 . . S (DATA(.525),DATA(.526),DATA(.527),DATA(.528),DATA(.529))="@"
"RTN","DGENPTA1",117,0)
 . . I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D
"RTN","DGENPTA1",118,0)
 . . . D ADDMSG^DGENUPL3(.MSGS,"Unable to update POW Data.",1)
"RTN","DGENPTA1",119,0)
 . . K DATA,ERROR,DGENDA
"RTN","DGENPTA1",120,0)
 . D EDITPOW^DGRPLE($G(DGPAT("POWI")),$G(DGPAT("POWLOC")),$G(DGPAT("POWFDT")),$G(DGPAT("POWTDT")),DGPAT("DFN"))
"RTN","DGENPTA1",121,0)
 D UNLOCK(DGPAT("DFN"))
"RTN","DGENPTA1",122,0)
 Q SUCCESS
"RTN","DGENPTA1",123,0)
 ;
"RTN","DGENPTA1",124,0)
FIELD(SUB) ;
"RTN","DGENPTA1",125,0)
 ;Description: Returns the field number of a subscript for the PATIENT object.
"RTN","DGENPTA1",126,0)
 ;
"RTN","DGENPTA1",127,0)
 N FNUM
"RTN","DGENPTA1",128,0)
 S FNUM=$S(SUB="DEATH":.351,SUB="PATYPE":391,SUB="VETERAN":1901,SUB="NAME":.01,SUB="DOB":.03,SUB="SEX":.02,SUB="SSN":.09,SUB="PREFAC":27.02,SUB="AG/ALLY":.309,1:"")
"RTN","DGENPTA1",129,0)
 S:'FNUM FNUM=$S(SUB="INELDATE":.152,SUB="INELREA":.307,SUB="INELDEC":.1656,SUB="PID":.363,SUB="EMGRES":.181,1:"")
"RTN","DGENPTA1",130,0)
 I FNUM="" S FNUM=$S(SUB="IR":.32103,SUB="RADEXPM":.3212,SUB="APPREQ":1010.159,SUB="APPREQDT":1010.1511,SUB="SPININJ":57.4,SUB="PFSRC":27.03,1:"")
"RTN","DGENPTA1",131,0)
 I FNUM="" S FNUM=$S(SUB="MOH":.541,1:"")
"RTN","DGENPTA1",132,0)
 Q FNUM
"RTN","DGENU")
0^6^B44311306
"RTN","DGENU",1,0)
DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TMK,PWC,TDM - Enrollment Utilities; 04/24/2006 9:20 AM ; 5/10/11 3:10pm
"RTN","DGENU",2,0)
 ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653,688,536,838,841**;Aug 13,1993;Build 7
"RTN","DGENU",3,0)
 ;
"RTN","DGENU",4,0)
DISPLAY(DFN) ;
"RTN","DGENU",5,0)
 ;Description: Display status message, current enrollment and
"RTN","DGENU",6,0)
 ;     preferred facility information
"RTN","DGENU",7,0)
 ;Input:
"RTN","DGENU",8,0)
 ;  DFN - Patient IEN
"RTN","DGENU",9,0)
 ;  Output:     none
"RTN","DGENU",10,0)
 ;
"RTN","DGENU",11,0)
 N STATUS
"RTN","DGENU",12,0)
 S STATUS=$$STATUS^DGENA(DFN)
"RTN","DGENU",13,0)
 I 'STATUS W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
"RTN","DGENU",14,0)
 E  I STATUS=2 D
"RTN","DGENU",15,0)
 .W !!,"Patient is enrolled in the VA Patient Enrollment System..."
"RTN","DGENU",16,0)
 ; Purple Heart added status 21
"RTN","DGENU",17,0)
 E  I (STATUS=9)!(STATUS=1)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) D
"RTN","DGENU",18,0)
 .W !!,"Application is pending for enrollment in the VA Patient Enrollment System..."
"RTN","DGENU",19,0)
 E  D
"RTN","DGENU",20,0)
 .W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
"RTN","DGENU",21,0)
 D CUR(DFN)
"RTN","DGENU",22,0)
 Q
"RTN","DGENU",23,0)
 ;
"RTN","DGENU",24,0)
CUR(DFN) ;
"RTN","DGENU",25,0)
 ;Description - displays current enrollment, category, enrollment
"RTN","DGENU",26,0)
 ;  group threshold, preferred facility and source designation
"RTN","DGENU",27,0)
 ;
"RTN","DGENU",28,0)
 N FACNAME,PREFAC,PFSRC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF
"RTN","DGENU",29,0)
 I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
"RTN","DGENU",30,0)
 ;Get enrollment category
"RTN","DGENU",31,0)
 S DGENCAT=$$CATEGORY^DGENA4(DFN)
"RTN","DGENU",32,0)
 ;Display Category in reverse video
"RTN","DGENU",33,0)
 D REV
"RTN","DGENU",34,0)
 ;Get enrollment group threshold
"RTN","DGENU",35,0)
 S DGEGTIEN=$$FINDCUR^DGENEGT
"RTN","DGENU",36,0)
 S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
"RTN","DGENU",37,0)
 ;Preferred facility
"RTN","DGENU",38,0)
 S PREFAC=$$PREF^DGENPTA(DFN,.FACNAME)
"RTN","DGENU",39,0)
 ;Source Designation
"RTN","DGENU",40,0)
 S PFSRC=$$GET1^DIQ(2,DFN_",",27.03)
"RTN","DGENU",41,0)
 W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
"RTN","DGENU",42,0)
 W !?3,"Enrollment Application Date",?35,": ",$S('$G(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP")))
"RTN","DGENU",43,0)
 W !?3,IORVON,"Enrollment Category             : ",$S($G(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF
"RTN","DGENU",44,0)
 W !?3,"Enrollment Status",?35,": ",$S($G(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS")))
"RTN","DGENU",45,0)
 W !?3,"Enrollment Priority",?35,": ",$S($G(DGENR("PRIORITY"))="":"-none-",1:DGENR("PRIORITY")),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT("SUBGRP",DGENR("SUBGRP")))
"RTN","DGENU",46,0)
 W !?3,"Preferred Facility",?35,": ",$S($G(FACNAME)'="":FACNAME,1:"-none-")
"RTN","DGENU",47,0)
 W !?3,"Preferred Facility Source",?35,": ",$S($G(PFSRC)'="":PFSRC,1:"-none-")
"RTN","DGENU",48,0)
 W !?3,"Enrollment Group Threshold",?35,": ",$S($G(DGEGT("PRIORITY"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"",$G(DGEGT("PRIORITY")))),$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"",$G(DGEGT("SUBGRP"))))
"RTN","DGENU",49,0)
 W !
"RTN","DGENU",50,0)
 Q
"RTN","DGENU",51,0)
REV ;Get variables to display text in reverse video
"RTN","DGENU",52,0)
 N X
"RTN","DGENU",53,0)
 S X="IORVON;IORVOFF"
"RTN","DGENU",54,0)
 D ENDR^%ZISS
"RTN","DGENU",55,0)
 Q
"RTN","DGENU",56,0)
PATID(DFN) ;
"RTN","DGENU",57,0)
 ;Description - Called by FileMan as an identifier for the Patient file.
"RTN","DGENU",58,0)
 ;Displays current enrollment status, priority, and preferred facility.
"RTN","DGENU",59,0)
 ;
"RTN","DGENU",60,0)
 ;Input:
"RTN","DGENU",61,0)
 ;  DFN - ien to Patient file
"RTN","DGENU",62,0)
 ;
"RTN","DGENU",63,0)
 N PREFAC,DGENR,OUTPUT
"RTN","DGENU",64,0)
 I '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) D
"RTN","DGENU",65,0)
 .S OUTPUT="NO ENROLLMENT APPLICATION ON FILE "
"RTN","DGENU",66,0)
 E  D
"RTN","DGENU",67,0)
 .S OUTPUT=$E("PRIORITY:"_DGENR("PRIORITY")_"   ",1,12)_$E("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_"         ",1,26)
"RTN","DGENU",68,0)
 S PREFAC=$$PREF^DGENPTA(DFN)
"RTN","DGENU",69,0)
 S:PREFAC OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$P($G(^DIC(4,PREFAC,99)),"^")
"RTN","DGENU",70,0)
 I $G(IOM) I ($X#$G(IOM))<6 D
"RTN","DGENU",71,0)
 .D EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))")
"RTN","DGENU",72,0)
 E  D
"RTN","DGENU",73,0)
 .D EN^DDIOL(OUTPUT,,"!?10")
"RTN","DGENU",74,0)
 Q
"RTN","DGENU",75,0)
 ;
"RTN","DGENU",76,0)
EXT(SUB,VAL) ;
"RTN","DGENU",77,0)
 ;Description: Given the subscript used in the PATIENT ENROLLMENT array,
"RTN","DGENU",78,0)
 ;     and a field value, returns the external representation of the
"RTN","DGENU",79,0)
 ;     value, as defined in the fields output transform of the PATIENT
"RTN","DGENU",80,0)
 ;     ENROLLMENT file.
"RTN","DGENU",81,0)
 ;Input: 
"RTN","DGENU",82,0)
 ;  SUB - subscript in the array defined by the PATIENT ENROLLMENT object
"RTN","DGENU",83,0)
 ;  VAL - value of the PATIENT ENROLLMENT object attribute named by SUB
"RTN","DGENU",84,0)
 ;Output:
"RTN","DGENU",85,0)
 ;  Function Value - returns the external value of the attribute as
"RTN","DGENU",86,0)
 ;     defined by the PATIENT ENROLLMENT file
"RTN","DGENU",87,0)
 ;
"RTN","DGENU",88,0)
 Q:(($G(SUB)="")!($G(VAL)="")) ""
"RTN","DGENU",89,0)
 ;
"RTN","DGENU",90,0)
 N FLD
"RTN","DGENU",91,0)
 S FLD=$$FIELD(SUB)
"RTN","DGENU",92,0)
 ;
"RTN","DGENU",93,0)
 Q:(FLD="") ""
"RTN","DGENU",94,0)
 Q $$EXTERNAL^DILFD(27.11,FLD,"F",VAL)
"RTN","DGENU",95,0)
 ;
"RTN","DGENU",96,0)
FIELD(SUB) ;
"RTN","DGENU",97,0)
 ;Description: given a subscript in the enrollment array, returns the
"RTN","DGENU",98,0)
 ;     corresponding field number
"RTN","DGENU",99,0)
 N FLD S FLD=""
"RTN","DGENU",100,0)
 D  ;drops out of block once SUB is determined
"RTN","DGENU",101,0)
 .I SUB="APP" S FLD=.01 Q
"RTN","DGENU",102,0)
 .I SUB="DATE" S FLD=.1 Q
"RTN","DGENU",103,0)
 .I SUB="END" S FLD=.11 Q
"RTN","DGENU",104,0)
 .I SUB="DFN" S FLD=.02 Q
"RTN","DGENU",105,0)
 .I SUB="SOURCE" S FLD=.03 Q
"RTN","DGENU",106,0)
 .I SUB="STATUS" S FLD=.04 Q
"RTN","DGENU",107,0)
 .I SUB="REASON" S FLD=.05 Q
"RTN","DGENU",108,0)
 .I SUB="REMARKS" S FLD=25 Q
"RTN","DGENU",109,0)
 .I SUB="FACREC" S FLD=.06 Q
"RTN","DGENU",110,0)
 .I SUB="PRIORITY" S FLD=.07 Q
"RTN","DGENU",111,0)
 .I SUB="EFFDATE" S FLD=.08 Q
"RTN","DGENU",112,0)
 .I SUB="PRIORREC" S FLD=.09 Q
"RTN","DGENU",113,0)
 .I SUB="SUBGRP" S FLD=.12 Q
"RTN","DGENU",114,0)
 .I SUB="CODE" S FLD=50.01 Q
"RTN","DGENU",115,0)
 .I SUB="SC" S FLD=50.02 Q
"RTN","DGENU",116,0)
 .I SUB="SCPER" S FLD=50.03 Q
"RTN","DGENU",117,0)
 .I SUB="POW" S FLD=50.04 Q
"RTN","DGENU",118,0)
 .I SUB="A&A" S FLD=50.05 Q
"RTN","DGENU",119,0)
 .I SUB="HB" S FLD=50.06 Q
"RTN","DGENU",120,0)
 .I SUB="VAPEN" S FLD=50.07 Q
"RTN","DGENU",121,0)
 .I SUB="VACKAMT" S FLD=50.08 Q
"RTN","DGENU",122,0)
 .I SUB="DISRET" S FLD=50.09 Q
"RTN","DGENU",123,0)
 .I SUB="DISLOD" S FLD=50.2 Q  ;field added with DG*5.3*672
"RTN","DGENU",124,0)
 .I SUB="MEDICAID" S FLD=50.1 Q
"RTN","DGENU",125,0)
 .I SUB="AO" S FLD=50.11 Q
"RTN","DGENU",126,0)
 .I SUB="AOEXPLOC" S FLD=50.22 Q  ;field added with DG*5.3*688
"RTN","DGENU",127,0)
 .I SUB="IR" S FLD=50.12 Q
"RTN","DGENU",128,0)
 .I SUB="EC" S FLD=50.13 Q    ;name now SW Asia Con, was Env Con DG*5.3*688
"RTN","DGENU",129,0)
 .I SUB="MTSTA" S FLD=50.14 Q
"RTN","DGENU",130,0)
 .I SUB="VCD" S FLD=50.15 Q
"RTN","DGENU",131,0)
 .I SUB="PH" S FLD=50.16 Q
"RTN","DGENU",132,0)
 .I SUB="UNEMPLOY" S FLD=50.17 Q
"RTN","DGENU",133,0)
 .I SUB="CVELEDT" S FLD=50.18 Q
"RTN","DGENU",134,0)
 .I SUB="SHAD" S FLD=50.19 Q  ;field added with DG*5.3*653
"RTN","DGENU",135,0)
 .I SUB="MOH" S FLD=50.23 Q
"RTN","DGENU",136,0)
 .I SUB="DATETIME" S FLD=75.01 Q
"RTN","DGENU",137,0)
 .I SUB="USER" S FLD=75.02 Q
"RTN","DGENU",138,0)
 .I SUB="RADEXPM" S FLD=76 Q
"RTN","DGENU",139,0)
 Q FLD
"RTN","DGENU",140,0)
 ;
"RTN","DGENU",141,0)
PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ;
"RTN","DGENU",142,0)
 ;Description: requests user to enter a single field value.
"RTN","DGENU",143,0)
 ;Input:
"RTN","DGENU",144,0)
 ;  FILE - the file #
"RTN","DGENU",145,0)
 ;  FIELD - the field #
"RTN","DGENU",146,0)
 ;  DEFAULT - default value, internal form
"RTN","DGENU",147,0)
 ;  REQUIRE - a flag, (+value)'=0 means to require a value to be
"RTN","DGENU",148,0)
 ;            entered and to return failure otherwise (optional)
"RTN","DGENU",149,0)
 ;  PRMPTNM - Optional
"RTN","DGENU",150,0)
 ;             0 - display field LABEL
"RTN","DGENU",151,0)
 ;             1 - Prompt field TITLE
"RTN","DGENU",152,0)
 ;Output:
"RTN","DGENU",153,0)
 ;  Function Value - 0 on failure, 1 on success
"RTN","DGENU",154,0)
 ;  RESPONSE - value entered by user, pass by reference
"RTN","DGENU",155,0)
 ;
"RTN","DGENU",156,0)
 Q:(('$G(FILE))!('$G(FIELD))) 0
"RTN","DGENU",157,0)
 S REQUIRE=$G(REQUIRE)
"RTN","DGENU",158,0)
 S PRMPTNM=$G(PRMPTNM)
"RTN","DGENU",159,0)
 N DIR,DA,QUIT,AGAIN
"RTN","DGENU",160,0)
 ;
"RTN","DGENU",161,0)
 S DIR(0)=FILE_","_FIELD_$S($G(REQUIRE):"",1:"O")_"AO"
"RTN","DGENU",162,0)
 I $G(DEFAULT)'="" DO
"RTN","DGENU",163,0)
 . S:+$G(PRMPTNM)=0 DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
"RTN","DGENU",164,0)
 . S:+$G(PRMPTNM)>0 DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
"RTN","DGENU",165,0)
 S QUIT=0
"RTN","DGENU",166,0)
 F  D  Q:QUIT
"RTN","DGENU",167,0)
 . D ^DIR
"RTN","DGENU",168,0)
 . I $D(DTOUT)!$D(DUOUT) S QUIT=1 Q
"RTN","DGENU",169,0)
 . I X="@" D  Q:AGAIN
"RTN","DGENU",170,0)
 . . S AGAIN=0
"RTN","DGENU",171,0)
 . . I 'REQUIRE,"Yy"'[$E($$YN^DGENCD1("  Are you sure")_"X") S AGAIN=1 Q
"RTN","DGENU",172,0)
 . . S RESPONSE="" ; This might trigger the "required" message below.
"RTN","DGENU",173,0)
 . E  I X="" S RESPONSE=$G(DEFAULT)
"RTN","DGENU",174,0)
 . E  S RESPONSE=$P(Y,"^")
"RTN","DGENU",175,0)
 . ;
"RTN","DGENU",176,0)
 . ; quit this loop if the user entered value OR value not required
"RTN","DGENU",177,0)
 . I RESPONSE'="" S QUIT=1 Q
"RTN","DGENU",178,0)
 . I 'REQUIRE S QUIT=1 Q
"RTN","DGENU",179,0)
 . W !,"This is a required response. Enter '^' to exit"
"RTN","DGENU",180,0)
 I $D(DTOUT)!$D(DUOUT) Q 0
"RTN","DGENU",181,0)
 Q 1
"RTN","DGENU",182,0)
 ;
"RTN","DGENU",183,0)
INST(VADUZ,VACHK) ;
"RTN","DGENU",184,0)
 ; Description: Determine the institution affiliation associated with a
"RTN","DGENU",185,0)
 ;              user.
"RTN","DGENU",186,0)
 ;
"RTN","DGENU",187,0)
 ;  Input:
"RTN","DGENU",188,0)
 ;     VADUZ =  array if passed by reference:
"RTN","DGENU",189,0)
 ;           VADUZ = DUZ
"RTN","DGENU",190,0)
 ;           VADUZ(2) =  
"RTN","DGENU",191,0)
 ;              o  if this value is null: DUZ(2) (institution affiliated
"RTN","DGENU",192,0)
 ;                    with user, prompted at Kernel sign-on)
"RTN","DGENU",193,0)
 ;              o  if value is not null: site to check as valid for the
"RTN","DGENU",194,0)
 ;                    user (Pointer to INSTITUTION (#4) file)
"RTN","DGENU",195,0)
 ; Output:
"RTN","DGENU",196,0)
 ;   Function Value - Returns pointer to the INSTITUTION (#4) file
"RTN","DGENU",197,0)
 ;    entry that is associated with the user, otherwise the pointer
"RTN","DGENU",198,0)
 ;    to the INSTITUTION (#4) file entry of the primary VA Medical
"RTN","DGENU",199,0)
 ;    Center division is returned.
"RTN","DGENU",200,0)
 ;
"RTN","DGENU",201,0)
 ;    VACHK = passed by reference, returned as:
"RTN","DGENU",202,0)
 ;         null if the value in VADUZ(2) is null
"RTN","DGENU",203,0)
 ;            0 if the value in VADUZ(2) is not null and is not a valid
"RTN","DGENU",204,0)
 ;              site for the user
"RTN","DGENU",205,0)
 ;            1 if the value in VADUZ(2) is not null and is a valid site
"RTN","DGENU",206,0)
 ;              for the user
"RTN","DGENU",207,0)
 ;
"RTN","DGENU",208,0)
 S VACHK=$S($G(VADUZ(2))="":"",1:0)
"RTN","DGENU",209,0)
 I $G(VADUZ(2)) D
"RTN","DGENU",210,0)
 . N X,ZZ
"RTN","DGENU",211,0)
 . Q:'$G(VADUZ)
"RTN","DGENU",212,0)
 . S X=$$DIV4^XUSER(.ZZ,VADUZ)
"RTN","DGENU",213,0)
 . I X,$D(ZZ(VADUZ(2))) S VACHK=1
"RTN","DGENU",214,0)
 I '$G(VADUZ(2)) S VADUZ(2)=$G(DUZ(2))
"RTN","DGENU",215,0)
 Q $S($G(VADUZ(2)):VADUZ(2),1:$P($$SITE^VASITE(),"^"))
"RTN","DGENU",216,0)
 ;
"RTN","DGENU",217,0)
GETINST(DGPREFAC,DGINST) ;Get Institution file data
"RTN","DGENU",218,0)
 ; Input  -- DGPREFAC Institution file IEN
"RTN","DGENU",219,0)
 ; Output -- 1=Successful and 0=Failure
"RTN","DGENU",220,0)
 ;           DGINST - Institution file Array
"RTN","DGENU",221,0)
 N DGINST0,DGINST99,DGOKF
"RTN","DGENU",222,0)
 S DGINST0=$G(^DIC(4,DGPREFAC,0)) G GETQ:DGINST0=""
"RTN","DGENU",223,0)
 S DGINST("NAME")=$P(DGINST0,U)
"RTN","DGENU",224,0)
 S DGINST99=$G(^DIC(4,DGPREFAC,99))
"RTN","DGENU",225,0)
 S DGINST("STANUM")=$P(DGINST99,U)
"RTN","DGENU",226,0)
 S DGOKF=1
"RTN","DGENU",227,0)
GETQ Q +$G(DGOKF)
"RTN","DGENUPL3")
0^7^B75053019
"RTN","DGENUPL3",1,0)
DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 5/11/11 12:29pm
"RTN","DGENUPL3",2,0)
 ;;5.3;REGISTRATION;**147,230,232,377,404,451,653,688,793,797,841**;Aug 13,1993;Build 7
"RTN","DGENUPL3",3,0)
 ;
"RTN","DGENUPL3",4,0)
 ;
"RTN","DGENUPL3",5,0)
ADDMSG(MSGS,MESSAGE,TOHEC) ;
"RTN","DGENUPL3",6,0)
 ;Description: Used to add a message to an array of messages to be sent.
"RTN","DGENUPL3",7,0)
 ;
"RTN","DGENUPL3",8,0)
 ;Input:
"RTN","DGENUPL3",9,0)
 ;  MSGS - the array to store the message (pass by reference)
"RTN","DGENUPL3",10,0)
 ;  MESSAGE - the message to store
"RTN","DGENUPL3",11,0)
 ;  TOHEC - a flag, if set to 1 it means that HEC should also receive notification
"RTN","DGENUPL3",12,0)
 ;
"RTN","DGENUPL3",13,0)
 ;Output: none
"RTN","DGENUPL3",14,0)
 ;
"RTN","DGENUPL3",15,0)
 I MESSAGE["DATE OF DEATH" Q
"RTN","DGENUPL3",16,0)
 S MSGS(0)=($G(MSGS(0))+1)
"RTN","DGENUPL3",17,0)
 S MSGS(MSGS(0))=MESSAGE
"RTN","DGENUPL3",18,0)
 I ($G(TOHEC)=1) S MSGS("HEC")=1
"RTN","DGENUPL3",19,0)
 Q
"RTN","DGENUPL3",20,0)
 ;
"RTN","DGENUPL3",21,0)
 ;
"RTN","DGENUPL3",22,0)
NOTIFY(DGPAT,MSGS) ;
"RTN","DGENUPL3",23,0)
 ;Description: This is used to send a message to the local mail group
"RTN","DGENUPL3",24,0)
 ;defined by the MAS Parameter ELIGIBILITY UPLOAD MAIL GROUP.The
"RTN","DGENUPL3",25,0)
 ;notification is to be used when specific problems or conditions
"RTN","DGENUPL3",26,0)
 ;regarding the upload of the enrollment or eligibility data.
"RTN","DGENUPL3",27,0)
 ;
"RTN","DGENUPL3",28,0)
 ;Input: 
"RTN","DGENUPL3",29,0)
 ;  OLDPAT -used if the DGPAT elements have not been built
"RTN","DGENUPL3",30,0)
 ;  DGPAT - patient array (pass by reference)
"RTN","DGENUPL3",31,0)
 ;  MSGS - the an array of messages that should be included in the
"RTN","DGENUPL3",32,0)
 ;         notification (pass by reference). If MSGS("HEC")=1
"RTN","DGENUPL3",33,0)
 ;         it means that HEC should also receive notification.
"RTN","DGENUPL3",34,0)
 ;
"RTN","DGENUPL3",35,0)
 ;Output:   none
"RTN","DGENUPL3",36,0)
 ;
"RTN","DGENUPL3",37,0)
 N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT
"RTN","DGENUPL3",38,0)
 N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD
"RTN","DGENUPL3",39,0)
 ;
"RTN","DGENUPL3",40,0)
 ;if there are no alerts, then quit
"RTN","DGENUPL3",41,0)
 Q:'$G(MSGS(0))
"RTN","DGENUPL3",42,0)
 ;
"RTN","DGENUPL3",43,0)
 ;Get reason for alert.  If there is more than one reason decide which 
"RTN","DGENUPL3",44,0)
 ;reason to display.  'NON-SERVICE' alerts have a higher priority than
"RTN","DGENUPL3",45,0)
 ;other alerts and are therefore displayed before other alerts in the 
"RTN","DGENUPL3",46,0)
 ;subject line, followed by 'POW' alerts in priority.
"RTN","DGENUPL3",47,0)
 S (ELIG,NSC,POW,CD)=0
"RTN","DGENUPL3",48,0)
 S COUNT=0 F  S COUNT=$O(MSGS(COUNT)) Q:'COUNT!NSC  D
"RTN","DGENUPL3",49,0)
 .I MSGS(COUNT)["PREVIOUSLY ELIGIBLE" S ELIG=1 Q
"RTN","DGENUPL3",50,0)
 .I MSGS(COUNT)["NON-SERVICE" S NSC=1 Q
"RTN","DGENUPL3",51,0)
 .I MSGS(COUNT)["POW" S POW=1 Q
"RTN","DGENUPL3",52,0)
 .I MSGS(COUNT)["CD EVALUATION" S CD=1 Q
"RTN","DGENUPL3",53,0)
 .S HEADER=MSGS(COUNT)
"RTN","DGENUPL3",54,0)
 .Q
"RTN","DGENUPL3",55,0)
 D
"RTN","DGENUPL3",56,0)
 .I ELIG S HEADER="Ineligibility Alert: " Q
"RTN","DGENUPL3",57,0)
 .I NSC S HEADER="NSC Alert: " Q
"RTN","DGENUPL3",58,0)
 .I POW&'NSC S HEADER="POW Alert: " Q
"RTN","DGENUPL3",59,0)
 .I CD S HEADER="CD Alert: " Q
"RTN","DGENUPL3",60,0)
 .Q
"RTN","DGENUPL3",61,0)
 ;
"RTN","DGENUPL3",62,0)
 S XMDF=""
"RTN","DGENUPL3",63,0)
 S (XMDUN,XMDUZ)="Registration Enrollment Module"
"RTN","DGENUPL3",64,0)
 ;Phase II Re-Enrollment
"RTN","DGENUPL3",65,0)
 ;DGPAT("SSN") is built by the parser.  DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT.
"RTN","DGENUPL3",66,0)
 ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge. 
"RTN","DGENUPL3",67,0)
 I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME"))
"RTN","DGENUPL3",68,0)
 I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX"))
"RTN","DGENUPL3",69,0)
 I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB"))
"RTN","DGENUPL3",70,0)
 S TMPSTR=" ("_$E(DGPAT("NAME"),1,1)
"RTN","DGENUPL3",71,0)
 S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")"
"RTN","DGENUPL3",72,0)
 S XMSUB=$E(HEADER,1,30)_$E(DGPAT("NAME"),1,25)_TMPSTR
"RTN","DGENUPL3",73,0)
 ;
"RTN","DGENUPL3",74,0)
 ; send msg to local mail group specified in IVM SITE PARAMETER file
"RTN","DGENUPL3",75,0)
 S MAILGRP=+$P($G(^IVM(301.9,1,0)),"^",9)
"RTN","DGENUPL3",76,0)
 S MAILGRP=$$EXTERNAL^DILFD(301.9,.09,"F",MAILGRP)
"RTN","DGENUPL3",77,0)
 I MAILGRP]"" S XMY("G."_MAILGRP)=""
"RTN","DGENUPL3",78,0)
 ;
"RTN","DGENUPL3",79,0)
 ; if flag is set, send msg to remote mail group specified in
"RTN","DGENUPL3",80,0)
 ; the IVM SITE PARAMETER file
"RTN","DGENUPL3",81,0)
 I $G(MSGS("HEC"))=1 D
"RTN","DGENUPL3",82,0)
 .S MAILGRP=$P($G(^IVM(301.9,1,0)),"^",10)
"RTN","DGENUPL3",83,0)
 .S MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP)
"RTN","DGENUPL3",84,0)
 .I MAILGRP]"" S XMY("G."_MAILGRP)=""
"RTN","DGENUPL3",85,0)
 ;
"RTN","DGENUPL3",86,0)
 ;
"RTN","DGENUPL3",87,0)
 S XMTEXT="TEXT("
"RTN","DGENUPL3",88,0)
 S TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
"RTN","DGENUPL3",89,0)
 S TEXT(2)="  "
"RTN","DGENUPL3",90,0)
 S TEXT(3)="Patient Name   :     "_DGPAT("NAME")
"RTN","DGENUPL3",91,0)
 S TEXT(4)="SSN            :     "_DGPAT("SSN")
"RTN","DGENUPL3",92,0)
 S TEXT(5)="DOB            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
"RTN","DGENUPL3",93,0)
 S TEXT(6)="SEX            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
"RTN","DGENUPL3",94,0)
 S TEXT(7)=" "
"RTN","DGENUPL3",95,0)
 ;
"RTN","DGENUPL3",96,0)
 S TEXT(8)=" ** Alerts **"
"RTN","DGENUPL3",97,0)
 S TEXT(9)=" "
"RTN","DGENUPL3",98,0)
 S COUNT=0 F  S COUNT=$O(MSGS(COUNT)) Q:'COUNT  S TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT)
"RTN","DGENUPL3",99,0)
 ;
"RTN","DGENUPL3",100,0)
 D ^XMD
"RTN","DGENUPL3",101,0)
 Q
"RTN","DGENUPL3",102,0)
 ;
"RTN","DGENUPL3",103,0)
BEGUPLD(DFN) ;
"RTN","DGENUPL3",104,0)
 ;Description: Sets a lock used to determine if an eligibility/enrollment
"RTN","DGENUPL3",105,0)
 ;upload is in progress. 
"RTN","DGENUPL3",106,0)
 ;
"RTN","DGENUPL3",107,0)
 ;Input:
"RTN","DGENUPL3",108,0)
 ;   DFN - ien, Patient record
"RTN","DGENUPL3",109,0)
 ;
"RTN","DGENUPL3",110,0)
 ;Output:
"RTN","DGENUPL3",111,0)
 ;  Function value - returns 1 if the lock was obtained, 0 otherwise.
"RTN","DGENUPL3",112,0)
 ;
"RTN","DGENUPL3",113,0)
 Q:'$G(DFN) 1
"RTN","DGENUPL3",114,0)
 L +^DGEN("ELIGIBILITY UPLOAD",DFN):3
"RTN","DGENUPL3",115,0)
 Q $T
"RTN","DGENUPL3",116,0)
 ;
"RTN","DGENUPL3",117,0)
ENDUPLD(DFN) ;
"RTN","DGENUPL3",118,0)
 ;Description: Releases the lock obtained by calling $$BEGUPLD(DFN)
"RTN","DGENUPL3",119,0)
 ;
"RTN","DGENUPL3",120,0)
 Q:'$G(DFN)
"RTN","DGENUPL3",121,0)
 L -^DGEN("ELIGIBILITY UPLOAD",DFN)
"RTN","DGENUPL3",122,0)
 Q
"RTN","DGENUPL3",123,0)
 ;
"RTN","DGENUPL3",124,0)
CKUPLOAD(DFN) ;
"RTN","DGENUPL3",125,0)
 ;Description: Checks if an upload is in progress.  If so, it pauses
"RTN","DGENUPL3",126,0)
 ;until it is completed.
"RTN","DGENUPL3",127,0)
 ;The enrollment/eligibility upload can take a while to accomplish.
"RTN","DGENUPL3",128,0)
 ;If the lock is not obtained initially, it is assumed that the upload
"RTN","DGENUPL3",129,0)
 ;is in progress, and a message is displayed to the user.
"RTN","DGENUPL3",130,0)
 ;
"RTN","DGENUPL3",131,0)
 ;Input: DFN
"RTN","DGENUPL3",132,0)
 ;Output: none
"RTN","DGENUPL3",133,0)
 ;
"RTN","DGENUPL3",134,0)
 N I
"RTN","DGENUPL3",135,0)
 I '$$BEGUPLD(DFN) D
"RTN","DGENUPL3",136,0)
 .W !!,"Upload of patient enrollment/eligibility data is in progress ..."
"RTN","DGENUPL3",137,0)
 .D UNLOCK^DGENPTA1(DFN)
"RTN","DGENUPL3",138,0)
 .F I=1:1:50 Q:$$BEGUPLD(DFN)  W "."
"RTN","DGENUPL3",139,0)
 .W !,"Upload of patient enrollment/eligibility data is completed.",!
"RTN","DGENUPL3",140,0)
 D ENDUPLD(DFN)
"RTN","DGENUPL3",141,0)
 Q
"RTN","DGENUPL3",142,0)
SCVET ;moved from DGENUPL4 - DG*5.3*688
"RTN","DGENUPL3",143,0)
 I DGPAT3("VETERAN")'="N" D
"RTN","DGENUPL3",144,0)
 . I DGELG3("SC")="N" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","NSC VETERAN",0))
"RTN","DGENUPL3",145,0)
 . I DGELG3("SC")="Y" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","SC VETERAN",0))
"RTN","DGENUPL3",146,0)
 I DGPAT3("VETERAN")="N" S DGPAT3("PATYPE")=$$NONVET(DGELG("ELIG","CODE"))
"RTN","DGENUPL3",147,0)
 Q
"RTN","DGENUPL3",148,0)
 ;
"RTN","DGENUPL3",149,0)
NONVET(DGCODE) ;map Patient Type from Primary Elig (and POS)
"RTN","DGENUPL3",150,0)
 ;added with DG*5.3*688 - ERC
"RTN","DGENUPL3",151,0)
 ; input:         DGCODE is the Primary Eligibility code
"RTN","DGENUPL3",152,0)
 ; output:        DGTPYE is returned as the value for Patient Type
"RTN","DGENUPL3",153,0)
 N PTELG,DGTYPE
"RTN","DGENUPL3",154,0)
 S (PTELG,DGTYPE)=""
"RTN","DGENUPL3",155,0)
 Q:$G(DGCODE)']"" ""
"RTN","DGENUPL3",156,0)
 S PTELG=$$NATNAME^DGENELA(DGCODE)
"RTN","DGENUPL3",157,0)
 Q:$G(PTELG)']"" ""
"RTN","DGENUPL3",158,0)
 I "CHAMPVA^OTHER FEDERAL AGENCY^REIMBURSABLE INSURANCE^SHARING AGREEMENT"[PTELG S DGTYPE=$$POS(.DGTYPE) Q:DGTYPE DGTYPE
"RTN","DGENUPL3",159,0)
 S DGTYPE=$S(PTELG["ALLIED":"ALLIED VETERAN",PTELG["COLLATERAL":"COLLATERAL",PTELG["EMPLOYEE":"EMPLOYEE",PTELG["TRICARE":"TRICARE",1:"")
"RTN","DGENUPL3",160,0)
 I DGTYPE']"" S DGTYPE="NON-VETERAN (OTHER)" ;default Pat Type
"RTN","DGENUPL3",161,0)
 S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
"RTN","DGENUPL3",162,0)
 Q DGTYPE
"RTN","DGENUPL3",163,0)
POS(DGTYPE) ;for these Elig Codes, check POS to determine Patient Type
"RTN","DGENUPL3",164,0)
 S DGPOS=DGELG("POS")
"RTN","DGENUPL3",165,0)
 I $G(DGPOS)']"" Q ""
"RTN","DGENUPL3",166,0)
 I '$D(^DIC(21,DGPOS,0)) Q ""
"RTN","DGENUPL3",167,0)
 S DGPOS=$P(^DIC(21,DGPOS,0),U)
"RTN","DGENUPL3",168,0)
 S DGTYPE=$S(DGPOS["ACTIVE":"ACTIVE DUTY",DGPOS["OPERAT":"ACTIVE DUTY",DGPOS["RETIR":"MILITARY RETIREE",1:"")
"RTN","DGENUPL3",169,0)
 I $G(DGTYPE)]"" S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
"RTN","DGENUPL3",170,0)
 Q DGTYPE
"RTN","DGENUPL3",171,0)
 ;
"RTN","DGENUPL3",172,0)
 ;ZMH code moved here from DGENUPL2 - DG*5.3*653
"RTN","DGENUPL3",173,0)
ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc, Military Service Episodes, Medal of Honor
"RTN","DGENUPL3",174,0)
 ;PROCESS PH, OEF/OIF, MH & POW FROM ZMH
"RTN","DGENUPL3",175,0)
 ;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
"RTN","DGENUPL3",176,0)
 I "^SL^SNL^SNNL^MSD^"[("^"_SEG(2)_"^") D  Q
"RTN","DGENUPL3",177,0)
 . N BOS,SN,DIS,SED,SSD,COM
"RTN","DGENUPL3",178,0)
 . S BOS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))  ;Service Branch
"RTN","DGENUPL3",179,0)
 . S:BOS]"" BOS=$O(^DIC(23,"B",BOS,""))
"RTN","DGENUPL3",180,0)
 . S SN=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))  ;Service Number
"RTN","DGENUPL3",181,0)
 . S DIS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))  ;Discharge Type
"RTN","DGENUPL3",182,0)
 . S:DIS]"" DIS=$O(^DIC(25,"B",DIS,""))
"RTN","DGENUPL3",183,0)
 . S SED=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")  ;Entry Date
"RTN","DGENUPL3",184,0)
 . I 'SED!ERROR D  Q
"RTN","DGENUPL3",185,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT)
"RTN","DGENUPL3",186,0)
 . S SSD=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")  ;Sep. Date
"RTN","DGENUPL3",187,0)
 . S COM=$$CONVERT^DGENUPL1($P(SEG(5),$E(HLECH)))  ;Service Component
"RTN","DGENUPL3",188,0)
 . S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
"RTN","DGENUPL3",189,0)
 ;
"RTN","DGENUPL3",190,0)
 I SEG(2)="PH" D  Q  ;Process Purple Heart from ZMH
"RTN","DGENUPL3",191,0)
 . S DGPAT("PHI")=$P(SEG(3),$E(HLECH))
"RTN","DGENUPL3",192,0)
 . S DGELG("PH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",193,0)
 . S DGPAT("PHST")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
"RTN","DGENUPL3",194,0)
 . S DGPAT("PHRR")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))
"RTN","DGENUPL3",195,0)
 ;
"RTN","DGENUPL3",196,0)
 I SEG(2)="OEIF" D  Q
"RTN","DGENUPL3",197,0)
 . N OEIFLOC
"RTN","DGENUPL3",198,0)
 . S OEIFLOC=$P(SEG(3),$E(HLECH))
"RTN","DGENUPL3",199,0)
 . I OEIFLOC="Conflict Unspecified" Q   ;Ignore these entries
"RTN","DGENUPL3",200,0)
 . I OEIFLOC="Unknown OEF/OIF" S OEIFLOC="UNK"
"RTN","DGENUPL3",201,0)
 . S OEIFLOC=$E(OEIFLOC,1,3)
"RTN","DGENUPL3",202,0)
 . Q:((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK"))
"RTN","DGENUPL3",203,0)
 . S DGOEIF("COUNT")=$G(DGOEIF("COUNT"))+1
"RTN","DGENUPL3",204,0)
 . S DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC
"RTN","DGENUPL3",205,0)
 . S DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2),"INSTITUTION")
"RTN","DGENUPL3",206,0)
 . S DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")
"RTN","DGENUPL3",207,0)
 . S DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")
"RTN","DGENUPL3",208,0)
 . S DGOEIF("LOCK",DGOEIF("COUNT"))=1
"RTN","DGENUPL3",209,0)
 ;
"RTN","DGENUPL3",210,0)
 I SEG(2)="POW" D  ;Process POW from ZMH
"RTN","DGENUPL3",211,0)
 . S DGPAT("POWI")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;POW STATUS INDICATED
"RTN","DGENUPL3",212,0)
 . S DGELG("POW")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",213,0)
 . S DGPAT("POWLOC")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
"RTN","DGENUPL3",214,0)
 . I DGPAT("POWLOC")'="@" S DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR) ;POW CONFINEMENT LOCATION
"RTN","DGENUPL3",215,0)
 . I ERROR D  Q
"RTN","DGENUPL3",216,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT)
"RTN","DGENUPL3",217,0)
 . S DGPAT("POWFDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE",.ERROR) ;POW FROM DATE
"RTN","DGENUPL3",218,0)
 . I ERROR D  Q
"RTN","DGENUPL3",219,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT)
"RTN","DGENUPL3",220,0)
 . S DGPAT("POWTDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;POW TO DATE
"RTN","DGENUPL3",221,0)
 . I ERROR D  Q
"RTN","DGENUPL3",222,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT)
"RTN","DGENUPL3",223,0)
 ;
"RTN","DGENUPL3",224,0)
 I SEG(2)="MH" D  ;Process Medal of Honor from ZMH
"RTN","DGENUPL3",225,0)
 . S DGPAT("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;MH STATUS INDICATED
"RTN","DGENUPL3",226,0)
 . S DGELG("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",227,0)
 Q
"RTN","DGENUPL3",228,0)
POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023
"RTN","DGENUPL3",229,0)
 ;  Input: LOC - HL7 code for location
"RTN","DGENUPL3",230,0)
 ; Output: ERROR - Return error 1 on failure
"RTN","DGENUPL3",231,0)
 ;         IEN22 - IEN of file 22
"RTN","DGENUPL3",232,0)
 N TBL023
"RTN","DGENUPL3",233,0)
 S ERROR=0
"RTN","DGENUPL3",234,0)
 I LOC="" S ERROR=1 Q ""
"RTN","DGENUPL3",235,0)
 S TBL023(4)="WWI",TBL023(5)="WWII-EUROPE",TBL023(6)="WWII-PACIFIC"
"RTN","DGENUPL3",236,0)
 S TBL023(7)="KOREAN",TBL023(8)="VIETNAM",TBL023(9)="OTHER"
"RTN","DGENUPL3",237,0)
 S TBL023("A")="PERSIAN GULF",TBL023("B")="YUGOSLAVIA"
"RTN","DGENUPL3",238,0)
 S IEN22=$O(^DIC(22,"C",TBL023(LOC),""))
"RTN","DGENUPL3",239,0)
 I IEN22="" S ERROR=1
"RTN","DGENUPL3",240,0)
 Q IEN22
"RTN","DGENUPL3",241,0)
 ;
"RTN","DGENUPL4")
0^10^B67002910
"RTN","DGENUPL4",1,0)
DGENUPL4 ;ALB/CJM,RTK,ISA/KWP,ISD/GSN,PHH,RGL,PJR,BRM,TDM,TMK,EG,BAJ - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 5/23/11 4:54pm
"RTN","DGENUPL4",2,0)
 ;;5.3;REGISTRATION;**147,177,232,253,327,367,377,514,451,625,673,708,688,841**;Aug 13,1993;Build 7
"RTN","DGENUPL4",3,0)
 ;
"RTN","DGENUPL4",4,0)
UOBJECTS(DFN,DGPAT,DGELG,DGCDIS,DGOEIF,MSGID,ERRCOUNT,MSGS,OLDPAT,OLDELG,OLDCDIS,OLDOEIF) ;
"RTN","DGENUPL4",5,0)
 ;Used to update PATIENT, ELIGIBILITY, CATASTROPHIC
"RTN","DGENUPL4",6,0)
 ;DISABILITY, and OEF/OIF CONFLICT objects 'in memory'.
"RTN","DGENUPL4",7,0)
 ;
"RTN","DGENUPL4",8,0)
 ;Input:
"RTN","DGENUPL4",9,0)
 ;  DFN - ien of record in the PATIENT file
"RTN","DGENUPL4",10,0)
 ;  DGPAT - PATIENT object array (pass by reference)
"RTN","DGENUPL4",11,0)
 ;  DGELG - ELIGIBILITY object array (pass by ref)
"RTN","DGENUPL4",12,0)
 ;  DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
"RTN","DGENUPL4",13,0)
 ;  DGOEIF - OEF/OIF conflict object array (pass by ref)
"RTN","DGENUPL4",14,0)
 ;  MSGID - message control id of the HL7 message being processed
"RTN","DGENUPL4",15,0)
 ;  ERRCOUNT - count of errors (pass by ref)
"RTN","DGENUPL4",16,0)
 ;  MSGS - array of messages for the site (pass by ref)
"RTN","DGENUPL4",17,0)
 ;
"RTN","DGENUPL4",18,0)
 ;Output:
"RTN","DGENUPL4",19,0)
 ;  Function Value: 1 if update was successful 'in memory',
"RTN","DGENUPL4",20,0)
 ;           consistency checks pass and the objects can be stored in
"RTN","DGENUPL4",21,0)
 ;           the local database, 0 otherwise.
"RTN","DGENUPL4",22,0)
 ;  DGPAT - PATIENT object array (pass by reference)
"RTN","DGENUPL4",23,0)
 ;  DGELG - ELIGIBILITY object array (pass by ref)
"RTN","DGENUPL4",24,0)
 ;  DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
"RTN","DGENUPL4",25,0)
 ;  ERRCOUNT - count of errors (pass by ref)
"RTN","DGENUPL4",26,0)
 ;  MSGS - array of messages for the site (pass by ref)
"RTN","DGENUPL4",27,0)
 ;  OLDPAT - patient object array as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",28,0)
 ;  OLDELG - eligibility object array as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",29,0)
 ;  OLDCDIS - catastrophically disability object array as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",30,0)
 ;  OLDOEIF - OEF/OIF conflict data as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",31,0)
 ;
"RTN","DGENUPL4",32,0)
 N DGPAT3,DGELG3,DGCDIS3,SUCCESS
"RTN","DGENUPL4",33,0)
 S SUCCESS=1
"RTN","DGENUPL4",34,0)
 D
"RTN","DGENUPL4",35,0)
 .;first get local site's current data
"RTN","DGENUPL4",36,0)
 .I ('$$GET^DGENPTA(DFN,.OLDPAT))!('$$GET^DGENELA(DFN,.OLDELG))!('$$GET^DGENCDA(DFN,.OLDCDIS))!('$P($$GET^DGENOEIF(DFN,.OLDOEIF,0),U,2)) D  Q
"RTN","DGENUPL4",37,0)
 ..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"UNABLE TO ACCESS PATIENT RECORD",.ERRCOUNT)
"RTN","DGENUPL4",38,0)
 ..S SUCCESS=0
"RTN","DGENUPL4",39,0)
 .;
"RTN","DGENUPL4",40,0)
 .;Phase II CD Consistency Checks (SRS 6.5.1.4) check VISTA against HEC
"RTN","DGENUPL4",41,0)
 .S SUCCESS=$$CDCHECK^DGENUPL9()
"RTN","DGENUPL4",42,0)
 .Q:'SUCCESS
"RTN","DGENUPL4",43,0)
 .;
"RTN","DGENUPL4",44,0)
 .;If no 'MH' ZMH segment or Z11 value is null delete VistA value.
"RTN","DGENUPL4",45,0)
 .I ($G(DGPAT("MOH"))="")&($G(OLDPAT("MOH"))'="") S DGPAT("MOH")="@"
"RTN","DGENUPL4",46,0)
 .I ($G(DGELG("MOH"))="")&($G(OLDELG("MOH"))'="") S DGELG("MOH")="@"
"RTN","DGENUPL4",47,0)
 .;
"RTN","DGENUPL4",48,0)
 .;now merge with the update
"RTN","DGENUPL4",49,0)
 .D MERGE
"RTN","DGENUPL4",50,0)
 .;
"RTN","DGENUPL4",51,0)
 .;add the assumed values
"RTN","DGENUPL4",52,0)
 .D ADD
"RTN","DGENUPL4",53,0)
 .;
"RTN","DGENUPL4",54,0)
 .;now do the consistency checks
"RTN","DGENUPL4",55,0)
 .S SUCCESS=$$CHECK()
"RTN","DGENUPL4",56,0)
 .Q:'SUCCESS
"RTN","DGENUPL4",57,0)
 .;
"RTN","DGENUPL4",58,0)
 .;replace input arrays with fully updated versions
"RTN","DGENUPL4",59,0)
 .K DGPAT M DGPAT=DGPAT3
"RTN","DGENUPL4",60,0)
 .K DGELG M DGELG=DGELG3
"RTN","DGENUPL4",61,0)
 .K DGCDIS M DGCDIS=DGCDIS3
"RTN","DGENUPL4",62,0)
 ;
"RTN","DGENUPL4",63,0)
 I SUCCESS D
"RTN","DGENUPL4",64,0)
 .;
"RTN","DGENUPL4",65,0)
 .;list of required notifications
"RTN","DGENUPL4",66,0)
 .;
"RTN","DGENUPL4",67,0)
 .;change in date of death
"RTN","DGENUPL4",68,0)
 .I DGPAT("DEATH"),$P(OLDPAT("DEATH"),".")'=$P(DGPAT("DEATH"),".") D
"RTN","DGENUPL4",69,0)
 ..D ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS DATE OF DEATH = "_$$FMTE^XLFDT(DGPAT("DEATH"),"1"),1)
"RTN","DGENUPL4",70,0)
 ..D ADDMSG^DGENUPL3(.MSGS,$S('OLDPAT("DEATH"):"SITE DOES NOT HAVE DATE OF DEATH",1:"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1")),1)
"RTN","DGENUPL4",71,0)
 .;
"RTN","DGENUPL4",72,0)
 .I OLDPAT("DEATH"),'DGPAT("DEATH") D
"RTN","DGENUPL4",73,0)
 ..D ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS NO DATE OF DEATH",1)
"RTN","DGENUPL4",74,0)
 ..D ADDMSG^DGENUPL3(.MSGS,"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1"),1)
"RTN","DGENUPL4",75,0)
 .;
"RTN","DGENUPL4",76,0)
 .;change in POW
"RTN","DGENUPL4",77,0)
 .I OLDELG("POW")="N",DGELG("POW")="Y" D ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO YES")
"RTN","DGENUPL4",78,0)
 .I OLDELG("POW")="Y",DGELG("POW")="N" D ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO NO")
"RTN","DGENUPL4",79,0)
 .;
"RTN","DGENUPL4",80,0)
 .;SC to NSC
"RTN","DGENUPL4",81,0)
 .I OLDELG("SC")="Y",DGELG("SC")="N" D ADDMSG^DGENUPL3(.MSGS,"VETERAN CHANGED TO NON-SERVICE CONNECTED",1)
"RTN","DGENUPL4",82,0)
 .;
"RTN","DGENUPL4",83,0)
 .; Change from Eligible to Ineligible
"RTN","DGENUPL4",84,0)
 .I 'OLDPAT("INELDATE"),DGPAT("INELDATE") D ADDMSG^DGENUPL3(.MSGS,"VETERAN PREVIOUSLY ELIGIBLE FOR VA HEALTH CARE, NOW INELIGIBLE.",1)
"RTN","DGENUPL4",85,0)
 .;
"RTN","DGENUPL4",86,0)
 .; Check for erroneous CD deletion
"RTN","DGENUPL4",87,0)
 .I OLDCDIS("VCD")="","@"[DGCDIS("VCD") Q  ;no notification is needed
"RTN","DGENUPL4",88,0)
 .;
"RTN","DGENUPL4",89,0)
 .; CD Determination Changed
"RTN","DGENUPL4",90,0)
 .I OLDCDIS("VCD")'=DGCDIS("VCD") D ADDMSG^DGENUPL3(.MSGS,"VETERANS CD EVALUATION HAS CHANGED.")
"RTN","DGENUPL4",91,0)
 D EP^DGENUPLB
"RTN","DGENUPL4",92,0)
 Q SUCCESS
"RTN","DGENUPL4",93,0)
 ;
"RTN","DGENUPL4",94,0)
ADD ;
"RTN","DGENUPL4",95,0)
 ;Description: adds computed and assumed values to the updated objects
"RTN","DGENUPL4",96,0)
 ;
"RTN","DGENUPL4",97,0)
 ;Input: DGELG3(),DGPAT3() created in the UOBJECTS procedure.
"RTN","DGENUPL4",98,0)
 ;
"RTN","DGENUPL4",99,0)
 N SUB,TYPE,DATA
"RTN","DGENUPL4",100,0)
 S DGELG3("ELIGENTBY")=.5
"RTN","DGENUPL4",101,0)
 S SUB=0 F  S SUB=$O(DGELG3("RATEDIS",SUB)) Q:'SUB  S DGELG3("RATEDIS",SUB,"RDSC")=1
"RTN","DGENUPL4",102,0)
 ;
"RTN","DGENUPL4",103,0)
 ; Default Patient Types
"RTN","DGENUPL4",104,0)
 D SCVET^DGENUPL3
"RTN","DGENUPL4",105,0)
 ;
"RTN","DGENUPL4",106,0)
 ; If Ineldate apply business rules
"RTN","DGENUPL4",107,0)
 I DGPAT3("INELDATE"),DGELG3("SC")'="Y" D
"RTN","DGENUPL4",108,0)
 .S DGPAT3("VETERAN")="N",DGPAT3("PATYPE")=$O(^DG(391,"B","NON-VETERAN (OTHER)",0))
"RTN","DGENUPL4",109,0)
 .S DGELG3("POS")=$O(^DIC(21,"B","OTHER NON-VETERANS",0))
"RTN","DGENUPL4",110,0)
 ;
"RTN","DGENUPL4",111,0)
 ;update/set ELIGIBILITY VERIF. SOURCE field (Ineligible Project):
"RTN","DGENUPL4",112,0)
 S DATA(.3613)=$S(DGELG3("ELIGVERIF")["VBA":"H",DGELG3("ELIGVERIF")["CEV":"H",DGELG3("ELIGVERIF")["VIVA":"H",1:"V")
"RTN","DGENUPL4",113,0)
 ;
"RTN","DGENUPL4",114,0)
 ; File data fields modified by Ineligible Business Rules
"RTN","DGENUPL4",115,0)
 I $$UPD^DGENDBS(2,DFN,.DATA,.ERROR)
"RTN","DGENUPL4",116,0)
 Q
"RTN","DGENUPL4",117,0)
 ;
"RTN","DGENUPL4",118,0)
MERGE ;
"RTN","DGENUPL4",119,0)
 ;Description: merges arrays with current patient data with the updates
"RTN","DGENUPL4",120,0)
 ; Merges DGPAT() + OLDPAT() -> DGPAT3()
"RTN","DGENUPL4",121,0)
 ;        DGELG() + OLDELG() -> DGELG3()
"RTN","DGENUPL4",122,0)
 ; overlays catastrophic disability array with data from HEC
"RTN","DGENUPL4",123,0)
 ;        DGCDIS() is info from HEC
"RTN","DGENUPL4",124,0)
 ;
"RTN","DGENUPL4",125,0)
 N SUB,SUB2,LOC,HEC,NATCODE
"RTN","DGENUPL4",126,0)
 M DGPAT3=OLDPAT,DGELG3=OLDELG
"RTN","DGENUPL4",127,0)
 ;Replace POW in VistA with HEC data
"RTN","DGENUPL4",128,0)
 I '$D(DGPAT3("POWI")) S DGELG3("POW")=""
"RTN","DGENUPL4",129,0)
 K DGCDIS3 M DGCDIS3=OLDCDIS K DGCDIS3("EXT"),DGCDIS3("PROC"),DGCDIS3("COND"),DGCDIS3("DIAG")
"RTN","DGENUPL4",130,0)
 ;
"RTN","DGENUPL4",131,0)
 ;discard MT status from local database - don't ever want to use it during upload
"RTN","DGENUPL4",132,0)
 S DGELG3("MTSTA")=DGELG("MTSTA")
"RTN","DGENUPL4",133,0)
 ;
"RTN","DGENUPL4",134,0)
 ;patient array
"RTN","DGENUPL4",135,0)
 S SUB=""
"RTN","DGENUPL4",136,0)
 F  S SUB=$O(DGPAT(SUB)) Q:(SUB="")  I (DGPAT(SUB)'="") S DGPAT3(SUB)=$S((DGPAT(SUB)="@"):"",1:DGPAT(SUB))
"RTN","DGENUPL4",137,0)
 ;
"RTN","DGENUPL4",138,0)
 ;Allow Ineligible info deletion (Ineligible Project):
"RTN","DGENUPL4",139,0)
 I $D(DGPAT("INELDEC")),DGPAT("INELDEC")="" S DGPAT("INELDEC")="@"
"RTN","DGENUPL4",140,0)
 I $D(DGPAT("INELREA")),DGPAT("INELREA")="" S DGPAT("INELREA")="@"
"RTN","DGENUPL4",141,0)
 I $D(DGPAT("INELDATE")),DGPAT("INELDATE")="" S DGPAT("INELDATE")="@"
"RTN","DGENUPL4",142,0)
 ;
"RTN","DGENUPL4",143,0)
 ;catastrophic disability array
"RTN","DGENUPL4",144,0)
 S SUB=""
"RTN","DGENUPL4",145,0)
 F  S SUB=$O(DGCDIS(SUB)) Q:(SUB="")  D
"RTN","DGENUPL4",146,0)
 .I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS3(SUB)=DGCDIS(SUB)
"RTN","DGENUPL4",147,0)
 .I $D(DGCDIS(SUB))=10 D
"RTN","DGENUPL4",148,0)
 ..S SUB2=""
"RTN","DGENUPL4",149,0)
 ..F  S SUB2=$O(DGCDIS(SUB,SUB2)) Q:SUB2=""  D
"RTN","DGENUPL4",150,0)
 ...I ($G(DGCDIS(SUB,SUB2))'="") S DGCDIS3(SUB,SUB2)=DGCDIS(SUB,SUB2)
"RTN","DGENUPL4",151,0)
 ...I SUB="PROC" D
"RTN","DGENUPL4",152,0)
 ....N CDPROC,CDEXT,LIEN
"RTN","DGENUPL4",153,0)
 ....S CDPROC=$G(DGCDIS("PROC",SUB2))
"RTN","DGENUPL4",154,0)
 ....Q:CDPROC=""
"RTN","DGENUPL4",155,0)
 ....S CDEXT=$G(DGCDIS("EXT",SUB2,1))
"RTN","DGENUPL4",156,0)
 ....Q:CDEXT=""
"RTN","DGENUPL4",157,0)
 ....S LIEN=$O(^DGEN(27.17,CDPROC,1,"B",CDEXT,0))
"RTN","DGENUPL4",158,0)
 ....Q:LIEN=""
"RTN","DGENUPL4",159,0)
 ....S DGCDIS3("EXT",SUB2,LIEN)=CDEXT
"RTN","DGENUPL4",160,0)
 ;
"RTN","DGENUPL4",161,0)
 ;eligibility array
"RTN","DGENUPL4",162,0)
 F  S SUB=$O(DGELG(SUB)) Q:(SUB="")  I ($G(DGELG(SUB))'="") S DGELG3(SUB)=$S((DGELG(SUB)="@"):"",1:DGELG(SUB))
"RTN","DGENUPL4",163,0)
 ;
"RTN","DGENUPL4",164,0)
 ;rated disabilities from HEC should replace local sites
"RTN","DGENUPL4",165,0)
 D
"RTN","DGENUPL4",166,0)
 .K DGELG3("RATEDIS")
"RTN","DGENUPL4",167,0)
 .M DGELG3("RATEDIS")=DGELG("RATEDIS")
"RTN","DGENUPL4",168,0)
 ;
"RTN","DGENUPL4",169,0)
 ;primary eligibility
"RTN","DGENUPL4",170,0)
 I (DGELG("ELIG","CODE")'="") S DGELG3("ELIG","CODE")=$S((DGELG("ELIG","CODE")="@"):"",($$NATCODE^DGENELA(DGELG("ELIG","CODE"))=$$NATCODE^DGENELA(DGELG3("ELIG","CODE"))):DGELG3("ELIG","CODE"),1:DGELG("ELIG","CODE"))
"RTN","DGENUPL4",171,0)
 ;
"RTN","DGENUPL4",172,0)
 ;patient eligibilities multiple
"RTN","DGENUPL4",173,0)
 ;delete veteran type codes not mapped to national codes sent by HEC, but leave non-veteran types and the codes where there is a match
"RTN","DGENUPL4",174,0)
 ;first find all local codes already in the patient file and the ones sent from HEC, keep in arrays LOC and HEC
"RTN","DGENUPL4",175,0)
 S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE")) I NATCODE S HEC(NATCODE)=""
"RTN","DGENUPL4",176,0)
 S SUB=0 F  S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB  S NATCODE=$$NATCODE^DGENELA(SUB) I NATCODE S HEC(NATCODE)=""
"RTN","DGENUPL4",177,0)
 S SUB=0 F  S SUB=$O(DGELG3("ELIG","CODE",SUB)) Q:'SUB  S NATCODE=$$NATCODE^DGENELA(SUB) I NATCODE S LOC(NATCODE)=""
"RTN","DGENUPL4",178,0)
 ;Now discard the codes in the local patient database that don't map to a national code sent by HEC, as well as HUMANIARIAN EMERGENCY code if not sent by HEC: 
"RTN","DGENUPL4",179,0)
 S SUB=0
"RTN","DGENUPL4",180,0)
 F  S SUB=$O(DGELG3("ELIG","CODE",SUB)) Q:'SUB  D
"RTN","DGENUPL4",181,0)
 .I $P($G(^DIC(8,SUB,0)),"^",5)="Y"!($P($G(^DIC(8,SUB,0)),"^")["HUMANITARIAN EMERGENCY"),'$D(HEC($$NATCODE^DGENELA(SUB))) K DGELG3("ELIG","CODE",SUB)
"RTN","DGENUPL4",182,0)
 ;now add codes included in the update that the local database does not already contain
"RTN","DGENUPL4",183,0)
 S SUB=0
"RTN","DGENUPL4",184,0)
 F  S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB  D
"RTN","DGENUPL4",185,0)
 .I '$D(LOC($$NATCODE^DGENELA(SUB))) S DGELG3("ELIG","CODE",SUB)=SUB
"RTN","DGENUPL4",186,0)
 ;Agent Orange Exp. Location, use local database when upload is NULL
"RTN","DGENUPL4",187,0)
 D AO^DGENUPL9
"RTN","DGENUPL4",188,0)
 Q
"RTN","DGENUPL4",189,0)
 ;
"RTN","DGENUPL4",190,0)
CHECK() ;
"RTN","DGENUPL4",191,0)
 ;
"RTN","DGENUPL4",192,0)
 N SUCCESS,ALIVE,ERRMSG,DGENR
"RTN","DGENUPL4",193,0)
 S SUCCESS=1
"RTN","DGENUPL4",194,0)
 S ERRMSG=""
"RTN","DGENUPL4",195,0)
 ;
"RTN","DGENUPL4",196,0)
 ;if upload includes date of death, check for indications that patient is alive
"RTN","DGENUPL4",197,0)
 I DGPAT3("DEATH"),'OLDPAT("DEATH") D  S:ALIVE SUCCESS=0
"RTN","DGENUPL4",198,0)
 .;
"RTN","DGENUPL4",199,0)
 .;determine if patient is at the moment being registered
"RTN","DGENUPL4",200,0)
 .S ALIVE=$$IFREG^DGREG(DFN)
"RTN","DGENUPL4",201,0)
 .;
"RTN","DGENUPL4",202,0)
 .;check if an inpatient
"RTN","DGENUPL4",203,0)
 .I 'ALIVE,$$INPAT^DGENPTA(DFN,DT,DT) S ALIVE=1
"RTN","DGENUPL4",204,0)
 .;
"RTN","DGENUPL4",205,0)
 .;Phase II locally enrolled with enrollment date after death date and status of unverified and rejected-initial application by vamc (SRS 6.5.1.2 e)
"RTN","DGENUPL4",206,0)
 .N CURIEN,CURENR
"RTN","DGENUPL4",207,0)
 .S CURIEN=$$FINDCUR^DGENA(DFN)
"RTN","DGENUPL4",208,0)
 .I CURIEN,$$GET^DGENA(CURIEN,.CURENR),CURENR("DATE")>DGPAT3("DEATH"),CURENR("STATUS")=1!(CURENR("STATUS")=14) S ALIVE=1
"RTN","DGENUPL4",209,0)
 .;there is an indication that he patient may not be dead
"RTN","DGENUPL4",210,0)
 .D:ALIVE ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE VERIFY PATIENT DEATH",.ERRCOUNT),ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD CONTAINED DATE OF DEATH AND WAS REJECTED, PLEASE VERIFY PATIENT DEATH",1),NOTIFY^DGENUPL3(.DGPAT,.MSGS)
"RTN","DGENUPL4",211,0)
 ;
"RTN","DGENUPL4",212,0)
 ;only do consistency checks on this data if it is verified
"RTN","DGENUPL4",213,0)
 I SUCCESS,(DGELG3("ELIGSTA")="V") D
"RTN","DGENUPL4",214,0)
 .I $$CHECK^DGENPTA1(.DGPAT3,.ERRMSG),$$CHECK^DGENELA1(.DGELG3,.DGPAT3,.DGCDIS3,.ERRMSG),$$CHECK^DGENCDA1(.DGCDIS3,.ERRMSG)
"RTN","DGENUPL4",215,0)
 .E  D
"RTN","DGENUPL4",216,0)
 ..S SUCCESS=0
"RTN","DGENUPL4",217,0)
 ..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL4",218,0)
 Q SUCCESS
"RTN","DGMTR")
0^13^B68219377
"RTN","DGMTR",1,0)
DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements;7/8/05 2:30pm
"RTN","DGMTR",2,0)
 ;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,773,840,841**;Aug 13, 1993;Build 7
"RTN","DGMTR",3,0)
 ;A patient requires a means test under the following conditions:
"RTN","DGMTR",4,0)
 ;  - Primary Eligibility is NSC OR patient is SC 0% non-compensable
"RTN","DGMTR",5,0)
 ;  - who is NOT receiving disability retirement from the military
"RTN","DGMTR",6,0)
 ;  - who is NOT eligible for medicaid
"RTN","DGMTR",7,0)
 ;  - who is NOT on a DOM ward
"RTN","DGMTR",8,0)
 ;  - who has NOT been means tested in the past year
"RTN","DGMTR",9,0)
 ;  - who is NOT a Purple Heart recipient
"RTN","DGMTR",10,0)
 ;  - who is NOT Catastrophically Disabled
"RTN","DGMTR",11,0)
 ; 
"RTN","DGMTR",12,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTR",13,0)
 ;           DGADDF  Means Test Add Flag  (Optional- default none)
"RTN","DGMTR",14,0)
 ;                   (1 if using the 'Add a New Means Test' option)
"RTN","DGMTR",15,0)
 ;           DGMSGF  Means Test Msg Flag  (Optional- default none)
"RTN","DGMTR",16,0)
 ;                   (1 to suppress messages)
"RTN","DGMTR",17,0)
 ;           DGNOIVMUPD No IVM Update Flag (Optional - default allow)
"RTN","DGMTR",18,0)
 ;                   (1 if updating of an IVM test is not allowed)
"RTN","DGMTR",19,0)
 ; Output -- DGREQF  Means Test Require Flag
"RTN","DGMTR",20,0)
 ;                   (1 if required and 0 if not required)
"RTN","DGMTR",21,0)
 ;           DGDOM1  DOM Patient Flag (defined and set to 1 if
"RTN","DGMTR",22,0)
 ;                               patient currently on a DOM ward)
"RTN","DGMTR",23,0)
 ;           DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
"RTN","DGMTR",24,0)
 ;                      used in CP^DG10.  Killed there as well.
"RTN","DGMTR",25,0)
 ;           If NOT using the 'Add a New Means Test' option,
"RTN","DGMTR",26,0)
 ;           a REQUIRED date of test will be added for the
"RTN","DGMTR",27,0)
 ;           patient if it is required.
"RTN","DGMTR",28,0)
 ;           If a means test is required and the current
"RTN","DGMTR",29,0)
 ;           status is NO LONGER REQUIRED, the last date of
"RTN","DGMTR",30,0)
 ;           test and current means test status will be
"RTN","DGMTR",31,0)
 ;           updated to REQUIRED unless the DGNOIVMUPD flag is set to 1
"RTN","DGMTR",32,0)
 ;           and the current primary means test is an IVM test. 
"RTN","DGMTR",33,0)
 ;           If a means test is no longer required the
"RTN","DGMTR",34,0)
 ;           last date of test and the current means test
"RTN","DGMTR",35,0)
 ;           status will also be updated to NO LONGER REQUIRED unless
"RTN","DGMTR",36,0)
 ;           the DGNOIVMUPD flag is set to 1 and the current primary
"RTN","DGMTR",37,0)
 ;           means test is an IVM test.
"RTN","DGMTR",38,0)
EN N DGCS,DGDOM,DGMT0,DGMTI,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMTLTD,DGMDOD,DGMTDT
"RTN","DGMTR",39,0)
 ;DG*5.3*146 change to exit if during patient merge process
"RTN","DGMTR",40,0)
 Q:$G(VAFCA08)=1
"RTN","DGMTR",41,0)
 ;DGMTCOR is needed if uploading copay test
"RTN","DGMTR",42,0)
 I $G(RXPRIME)'="DGMTU4" N DGMTCOR
"RTN","DGMTR",43,0)
 S (DGQSENT,DGREQF)=0,(OLD,DGMTYPT)=1
"RTN","DGMTR",44,0)
 I $D(^DPT(DFN,.36)) S X=^(.36) D
"RTN","DGMTR",45,0)
 . I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DFN)) S DGREQF=1
"RTN","DGMTR",46,0)
 . I $P(X,"^",12)=1 S DGREQF=0 ;new field, DG 672
"RTN","DGMTR",47,0)
 . I $P(X,"^",13)=1 S DGREQF=0 ;new field, DG 672 
"RTN","DGMTR",48,0)
 S (DGMTI,DGMT0)="",DGMTI=+$$LST^DGMTU(DFN)
"RTN","DGMTR",49,0)
 S:DGMTI DGMT0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTR",50,0)
 ;Added with DG*5.3*344
"RTN","DGMTR",51,0)
 S:DGMTI DGMTDT=$P(DGMT0,U)
"RTN","DGMTR",52,0)
 S DGMDOD=$P($G(^DPT(DFN,.35)),U)
"RTN","DGMTR",53,0)
 I 'DGMTI,$G(DGMDOD) D EN^DGMTCOR S DGREQF=0 Q
"RTN","DGMTR",54,0)
 I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
"RTN","DGMTR",55,0)
 I DGREQF D DOM S:$G(DGDOM) DGREQF=0
"RTN","DGMTR",56,0)
 S DGCS=$P(DGMT0,"^",3)
"RTN","DGMTR",57,0)
 S DGMTLTD=+DGMT0,DGNOCOPF=0
"RTN","DGMTR",58,0)
 I +$G(DGMDOD) S DGNOCOPF=1
"RTN","DGMTR",59,0)
 I DGCS S OLD=$$OLD^DGMTU4(+DGMT0)
"RTN","DGMTR",60,0)
 ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
"RTN","DGMTR",61,0)
 I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
"RTN","DGMTR",62,0)
 ;Catastrophically disabled
"RTN","DGMTR",63,0)
 I $P($G(^DPT(DFN,.39)),U,6)="Y" S DGREQF=0 ;DG*5.3*840
"RTN","DGMTR",64,0)
 ;Medal of Honor DG*5.3*840.  Functionality removed with DG*5.3*841
"RTN","DGMTR",65,0)
 ;I $P($G(^DPT(DFN,.54)),U)="Y" S DGREQF=0
"RTN","DGMTR",66,0)
 D
"RTN","DGMTR",67,0)
 .I DGREQF,DGCS=3,'OLD D REQ Q
"RTN","DGMTR",68,0)
 .I DGREQF,'$G(DGADDF),((DGCS=6)!(DGCS=2)),$P(DGMT0,U,11)=1,DGMTLTD>2991005 S DGREQF=0,DGNOCOPF=1 Q
"RTN","DGMTR",69,0)
 .; next line added 2/19/02 - DG*5.3*426
"RTN","DGMTR",70,0)
 .I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q
"RTN","DGMTR",71,0)
 .I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q
"RTN","DGMTR",72,0)
 .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q
"RTN","DGMTR",73,0)
 ;be sure to check whether or not patient is subject to RX copay!
"RTN","DGMTR",74,0)
 D EN^DGMTCOR
"RTN","DGMTR",75,0)
 Q
"RTN","DGMTR",76,0)
 ;Check if patient is in a DOM
"RTN","DGMTR",77,0)
 ;  call to DOM checks if patient currently on a DOM ward
"RTN","DGMTR",78,0)
 ;                                     (called from EN)
"RTN","DGMTR",79,0)
 ;  call to DOM1 checks if patient on a DOM ward for a specific date
"RTN","DGMTR",80,0)
 ;    before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
"RTN","DGMTR",81,0)
 ;                          S VAINDT=specific date
"RTN","DGMTR",82,0)
 ;                          S DFN=Patient IEN
"RTN","DGMTR",83,0)
 ;                 output - DGDOM & DGDOM1 (defined and set to 1 if
"RTN","DGMTR",84,0)
 ;                          patient on a DOM ward for specific date)
"RTN","DGMTR",85,0)
DOM N VAINDT,VADMVT
"RTN","DGMTR",86,0)
DOM1 D ADM^VADPT2
"RTN","DGMTR",87,0)
 I VADMVT,$P($G(^DG(43,1,0)),"^",21),$D(^DIC(42,+$P($G(^DGPM(VADMVT,0)),"^",6),0)),$P(^(0),"^",3)="D" S (DGDOM,DGDOM1)=1
"RTN","DGMTR",88,0)
 Q
"RTN","DGMTR",89,0)
SC(DFN) ;Check if patient is SC 0% non-compensable
"RTN","DGMTR",90,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTR",91,0)
 ; Output -- 1=Yes and 0=No
"RTN","DGMTR",92,0)
 ;     No if:
"RTN","DGMTR",93,0)
 ;        No total annual VA check amount
"RTN","DGMTR",94,0)
 ;        POW STATUS INDICATOR is yes
"RTN","DGMTR",95,0)
 ;        Secondary Eligibility is one of the following:
"RTN","DGMTR",96,0)
 ;           A&A, NSC, VA PENSION
"RTN","DGMTR",97,0)
 ;           HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
"RTN","DGMTR",98,0)
 N DG,DGE,DGF,Y
"RTN","DGMTR",99,0)
 S Y=0
"RTN","DGMTR",100,0)
 ;Primary eligibility is SC LESS THAN 50%
"RTN","DGMTR",101,0)
 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
"RTN","DGMTR",102,0)
 G:'Y SCQ
"RTN","DGMTR",103,0)
 ;Service connected percentage is 0
"RTN","DGMTR",104,0)
 I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
"RTN","DGMTR",105,0)
 ;No Total annual VA check amount
"RTN","DGMTR",106,0)
 I $P($G(^DPT(DFN,.362)),"^",20) S Y=0 G SCQ
"RTN","DGMTR",107,0)
 ;POW STATUS INDICATOR
"RTN","DGMTR",108,0)
 I $P($G(^DPT(DFN,.52)),"^",5)="Y" S Y=0 G SCQ
"RTN","DGMTR",109,0)
 ;Purple Heart Indicator
"RTN","DGMTR",110,0)
 I $P($G(^DPT(DFN,.53)),"^")="Y" S Y=0 G SCQ
"RTN","DGMTR",111,0)
 ;Secondary Eligibility
"RTN","DGMTR",112,0)
 F DG=2,4,15:1:18 S DGE(DG)=""
"RTN","DGMTR",113,0)
 S DG=0 F  S DG=$O(^DPT(DFN,"E","B",DG)) Q:'DG  D SELIG I DGF,$D(DGE(+DGF)) S Y=0 Q
"RTN","DGMTR",114,0)
SCQ Q +$G(Y)
"RTN","DGMTR",115,0)
ADD ;Add a required means test
"RTN","DGMTR",116,0)
 N DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
"RTN","DGMTR",117,0)
 W:'$G(DGMSGF) !,"MEANS TEST REQUIRED"
"RTN","DGMTR",118,0)
 S DGMTACT="ADD" D PRIOR^DGMTEVT
"RTN","DGMTR",119,0)
 S DGMTDT=DT D ADD^DGMTA
"RTN","DGMTR",120,0)
 I DGMTI>0 S DGMTYPT=1 D
"RTN","DGMTR",121,0)
 .N DATA S DATA(.03)=$$GETSTAT^DGMTH("R",1) I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTR",122,0)
 .D GETINCOM^DGMTU4(DFN,DT)
"RTN","DGMTR",123,0)
 .D QUE
"RTN","DGMTR",124,0)
 I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
"RTN","DGMTR",125,0)
 Q
"RTN","DGMTR",126,0)
REQ ;Update means test status to REQUIRED
"RTN","DGMTR",127,0)
 N DGMTA,AUTOCOMP,DGMTE,ERROR
"RTN","DGMTR",128,0)
 ;may have set prior MT for means test upload
"RTN","DGMTR",129,0)
 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTR",130,0)
 S AUTOCOMP=$$AUTOCOMP(DGMTI)
"RTN","DGMTR",131,0)
 ;if a test were auto-completed, don't want another being added inadvertently
"RTN","DGMTR",132,0)
 I AUTOCOMP,$G(DGADDF) S DGADDF=0
"RTN","DGMTR",133,0)
 I AUTOCOMP S DGCS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
"RTN","DGMTR",134,0)
 I $G(IVMZ10)'="UPLOAD IN PROGRESS",'AUTOCOMP,'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
"RTN","DGMTR",135,0)
 I ('AUTOCOMP),('$G(DGMSGF)) W !,"MEANS TEST REQUIRED"
"RTN","DGMTR",136,0)
 I (AUTOCOMP),('$G(DGMSGF)) W !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
"RTN","DGMTR",137,0)
 S DGMTYPT=1
"RTN","DGMTR",138,0)
 D QUE
"RTN","DGMTR",139,0)
 Q
"RTN","DGMTR",140,0)
AUTOCOMP(DGMTI) ;
"RTN","DGMTR",141,0)
 ;Will either automatically complete the test (RX copay or means test) 
"RTN","DGMTR",142,0)
 ;based on the Test Determined Status, or will change the status to
"RTN","DGMTR",143,0)
 ;Required for means tests or Incomplete for Rx copay tests
"RTN","DGMTR",144,0)
 ;Input:
"RTN","DGMTR",145,0)
 ;  DGMTI - the ien of the test
"RTN","DGMTR",146,0)
 ;Output:
"RTN","DGMTR",147,0)
 ;  Function value - 1 if the test was completed, 0 otherwise
"RTN","DGMTR",148,0)
 N NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
"RTN","DGMTR",149,0)
 S RET=0
"RTN","DGMTR",150,0)
 Q:'$G(DGMTI) RET
"RTN","DGMTR",151,0)
 S NODE0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTR",152,0)
 Q:(NODE0="") RET
"RTN","DGMTR",153,0)
 S TYPE=$P(NODE0,"^",19)
"RTN","DGMTR",154,0)
 S DFN=$P(NODE0,"^",2)
"RTN","DGMTR",155,0)
 S TDATE=+NODE0
"RTN","DGMTR",156,0)
 S NODE2=$G(^DGMT(408.31,DGMTI,2))
"RTN","DGMTR",157,0)
 ;get test-determined status code
"RTN","DGMTR",158,0)
 S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
"RTN","DGMTR",159,0)
 ;if means test
"RTN","DGMTR",160,0)
 I TYPE=1 D
"RTN","DGMTR",161,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("R",1),DATA(.17)=""
"RTN","DGMTR",162,0)
 .I (CODE'=""),"ACGP"[CODE D
"RTN","DGMTR",163,0)
 ..S RET=1
"RTN","DGMTR",164,0)
 ..S DATA(.03)=$P(NODE2,"^",3)
"RTN","DGMTR",165,0)
 ..;determine status if there is a hardship
"RTN","DGMTR",166,0)
 ..I $P(NODE0,"^",20) D
"RTN","DGMTR",167,0)
 ...S DATA(.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="C"&($P(NODE0,U,27)>$P(NODE0,U,12)):"G",1:"A"),1)
"RTN","DGMTR",168,0)
 .I (CODE="")!(CODE'=""&"ACGP"'[CODE) D
"RTN","DGMTR",169,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR",170,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(1,,TDATE)
"RTN","DGMTR",171,0)
 ..S DATA(2.11)=1
"RTN","DGMTR",172,0)
 ;RX copay test
"RTN","DGMTR",173,0)
 I TYPE=2 D
"RTN","DGMTR",174,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("I",2),DATA(.17)=""
"RTN","DGMTR",175,0)
 .I (CODE'=""),"EM"[CODE D
"RTN","DGMTR",176,0)
 ..S RET=1
"RTN","DGMTR",177,0)
 ..S DATA(.03)=$P(NODE2,"^",3)
"RTN","DGMTR",178,0)
 .I (CODE="")!(CODE'=""&"EM"'[CODE) D
"RTN","DGMTR",179,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR",180,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(2,,TDATE)
"RTN","DGMTR",181,0)
 ..S DATA(2.11)=1
"RTN","DGMTR",182,0)
 I '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR) W:'$G(DGMSGF) ERROR
"RTN","DGMTR",183,0)
 ;restore the pointers from the Income Relation file (408.22) to this
"RTN","DGMTR",184,0)
 ;test, using the linked test
"RTN","DGMTR",185,0)
 S LINKIEN=$P(NODE2,"^",6)
"RTN","DGMTR",186,0)
 I LINKIEN D
"RTN","DGMTR",187,0)
 .S DGINI=0 F  S DGINI=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI)) Q:'DGINI  S DGINR=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
"RTN","DGMTR",188,0)
 ..K DATA
"RTN","DGMTR",189,0)
 ..S DATA(31)=DGMTI
"RTN","DGMTR",190,0)
 ..I $$UPD^DGENDBS(408.22,+DGINR,.DATA)
"RTN","DGMTR",191,0)
 D GETINCOM^DGMTU4(DFN,TDATE)
"RTN","DGMTR",192,0)
 Q RET
"RTN","DGMTR",193,0)
NOL ;Update means test status to NO LONGER REQUIRED
"RTN","DGMTR",194,0)
 N DGMTA,DGINI,DGINR,DGMTDT,DATA
"RTN","DGMTR",195,0)
 I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D  G NOLQ ; Check for converted IVM MT
"RTN","DGMTR",196,0)
 . ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM MEANS TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER REQUIRED'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
"RTN","DGMTR",197,0)
 . S DGNOIVMUPD=2 ; Prevent double printing of the message
"RTN","DGMTR",198,0)
 W:'$G(DGMSGF) !,"MEANS TEST NO LONGER REQUIRED"
"RTN","DGMTR",199,0)
 ;may have set prior MT for means test upload
"RTN","DGMTR",200,0)
 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTR",201,0)
 ;save the Test Determined Status
"RTN","DGMTR",202,0)
 D SAVESTAT^DGMTU4(DGMTI)
"RTN","DGMTR",203,0)
 S DATA(.03)=3,DATA(.17)=DT I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTR",204,0)
 D QUE
"RTN","DGMTR",205,0)
 ;create a Rx copay test based on MT if needed
"RTN","DGMTR",206,0)
 D COPYRX^DGMTR1(DFN,DGMTI)
"RTN","DGMTR",207,0)
NOLQ Q
"RTN","DGMTR",208,0)
SET ;Set Cross-reference
"RTN","DGMTR",209,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGMTR",210,0)
 S DA=DGIEN,X=DGVAL,DGIX=0
"RTN","DGMTR",211,0)
 F  S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX  X ^(DGIX,1) S X=DGVAL
"RTN","DGMTR",212,0)
 Q
"RTN","DGMTR",213,0)
KILL ;Kill Cross-reference
"RTN","DGMTR",214,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGMTR",215,0)
 S DA=DGIEN,X=DGVAL,DGIX=0
"RTN","DGMTR",216,0)
 F  S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX  X ^(DGIX,2) S X=DGVAL
"RTN","DGMTR",217,0)
 Q
"RTN","DGMTR",218,0)
QUE ;Queue means test event driver
"RTN","DGMTR",219,0)
 D AFTER^DGMTEVT
"RTN","DGMTR",220,0)
 S ZTDESC="MEANS TEST EVENT DRIVER",ZTDTH=$H,ZTRTN="EN^DGMTEVT"
"RTN","DGMTR",221,0)
 F I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT" S ZTSAVE(I)=""
"RTN","DGMTR",222,0)
 S ZTSAVE("DGMTINF")=1
"RTN","DGMTR",223,0)
 I $D(IVMZ10) S ZTSAVE("IVMZ10")=""
"RTN","DGMTR",224,0)
 I $D(DGENUPLD) S ZTSAVE("DGENUPLD")=""
"RTN","DGMTR",225,0)
 S ZTIO="" D ^%ZTLOAD
"RTN","DGMTR",226,0)
 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","DGMTR",227,0)
 Q
"RTN","DGMTR",228,0)
SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
"RTN","DGMTR",229,0)
 ;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
"RTN","DGMTR",230,0)
 ;CODE file (#8.1)
"RTN","DGMTR",231,0)
 N DGTXT
"RTN","DGMTR",232,0)
 S DGF=$G(^DIC(8,+DG,0)) I DGF="" D  Q
"RTN","DGMTR",233,0)
 .S DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
"RTN","DGMTR",234,0)
 .S DGTXT(5)="the ELIGIBILITY CODE file (#8)"
"RTN","DGMTR",235,0)
 .D MAIL^DGMTR1
"RTN","DGMTR",236,0)
 .Q
"RTN","DGMTR",237,0)
 S DGF=$P(DGF,"^",9) I DGF=""!('$D(^DIC(8.1,+DGF,0))) D
"RTN","DGMTR",238,0)
 .S DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
"RTN","DGMTR",239,0)
 .S DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
"RTN","DGMTR",240,0)
 .D MAIL^DGMTR1
"RTN","DGMTR",241,0)
 .S DGF=""
"RTN","DGMTR",242,0)
 .Q
"RTN","DGMTR",243,0)
 Q
"RTN","DGRP6")
0^11^B15906836
"RTN","DGRP6",1,0)
DGRP6 ;ALB/MRL,LBD,TMK - REGISTRATION SCREEN 6/SERVICE INFORMATION ; 5/12/11 11:10am
"RTN","DGRP6",2,0)
 ;;5.3;Registration;**161,247,343,397,342,451,672,689,797,841**;Aug 13, 1993;Build 7
"RTN","DGRP6",3,0)
 N DIPA,LIN,XX,Z1,GLBL
"RTN","DGRP6",4,0)
 S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.52,.53,.54 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP6",5,0)
 S (DGRPW,Z)=1 D WW2^DGRPV S Z=" Service Branch/Component",Z1=27 D WW1^DGRPV S Z="Service #",Z1=16 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z="Separated",Z1=12 D WW1^DGRPV W "Discharge"
"RTN","DGRP6",6,0)
 W !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------"
"RTN","DGRP6",7,0)
 ;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797)
"RTN","DGRP6",8,0)
 K ^TMP("DGRP6",$J)
"RTN","DGRP6",9,0)
 S GLBL=$NA(^TMP("DGRP6",$J))
"RTN","DGRP6",10,0)
 D GETMSE^DGRP61(DFN,GLBL,0)
"RTN","DGRP6",11,0)
 D S
"RTN","DGRP6",12,0)
 W !
"RTN","DGRP6",13,0)
 D CL^DGRP6CL2(DFN,.LIN)
"RTN","DGRP6",14,0)
 S Z=2 D WW2^DGRPV S Z="  Conflict Locations: ",Z1=20 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
"RTN","DGRP6",15,0)
 S Z=1 F  S Z=$O(LIN(Z)) Q:'Z  W !,?25,LIN(Z)
"RTN","DGRP6",16,0)
 D EF^DGRP6EF(DFN,.LIN)
"RTN","DGRP6",17,0)
 S Z=3 D WW2^DGRPV S Z=" Environment Factors: ",Z1=21 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
"RTN","DGRP6",18,0)
 S Z=1 F  S Z=$O(LIN(Z)) Q:'Z  W !,?4,"+ ",LIN(Z)
"RTN","DGRP6",19,0)
 S Z=4,DGRPX=DGRP(.52) D WW^DGRPV W "          POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"")
"RTN","DGRP6",20,0)
 S Z=5 D WW^DGRPV W "       Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"")
"RTN","DGRP6",21,0)
 S Z=6 D WW^DGRPV S X=$P(DGRP(.36),"^",12),XX=$P(DGRP(.36),"^",13)
"RTN","DGRP6",22,0)
 N DGSPACE
"RTN","DGRP6",23,0)
 S DGSPACE=$S($G(X)="0":" ",$G(X)="1":"",1:"   ")
"RTN","DGRP6",24,0)
 W "     Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"") W DGSPACE_"        Dischrg Due to Disab: ",$S(XX=0:"NO",XX=1:"YES",1:"")
"RTN","DGRP6",25,0)
 ;W !
"RTN","DGRP6",26,0)
 S Z=7 D WW^DGRPV W "     Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1
"RTN","DGRP6",27,0)
 I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I  S I1=1,DGRPX=^(I,0) D DEN
"RTN","DGRP6",28,0)
 S Z=8 D WW^DGRPV W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D
"RTN","DGRP6",29,0)
 . I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"")
"RTN","DGRP6",30,0)
 I $P($G(DGRPX),U)="N" D
"RTN","DGRP6",31,0)
 . S DGX=$P(DGRPX,U,3)
"RTN","DGRP6",32,0)
 . S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"")
"RTN","DGRP6",33,0)
 . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"")
"RTN","DGRP6",34,0)
 ;DG*5.3*841
"RTN","DGRP6",35,0)
 I $P(DGRP(.54),"^")="Y" W !,"<9> Medal of Honor: YES"
"RTN","DGRP6",36,0)
Q K DGRPD,DGRPSV
"RTN","DGRP6",37,0)
 G ^DGRPP
"RTN","DGRP6",38,0)
YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") D WW1^DGRPV Q
"RTN","DGRP6",39,0)
DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z=""
"RTN","DGRP6",40,0)
 E  S Z=$$FMTE^XLFDT(Z,"5DZ")
"RTN","DGRP6",41,0)
 D WW1^DGRPV Q
"RTN","DGRP6",42,0)
DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q
"RTN","DGRP6",43,0)
S ;Write Military Service Episodes (DG*5.3*797)
"RTN","DGRP6",44,0)
 N DGL
"RTN","DGRP6",45,0)
 Q:$G(GLBL)=""
"RTN","DGRP6",46,0)
 S DGL=0 F  S DGL=$O(@GLBL@(DGL)) Q:'DGL!(DGL>3)  D
"RTN","DGRP6",47,0)
 .I $G(@GLBL@(DGL,0))]"" W !,@GLBL@(DGL,0)
"RTN","DGRP6",48,0)
 I DGL>3 W !,"    <more episodes>" Q
"RTN","DGRP6",49,0)
 Q
"RTN","DGRP6",50,0)
MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q
"RTN","DGRP6",51,0)
 ;
"RTN","DGRP6",52,0)
SETLNEX(Z,SEQ,LIN,LENGTH) ;
"RTN","DGRP6",53,0)
 I 'LIN S LIN=1,LIN(1)=""
"RTN","DGRP6",54,0)
 S Z=$E("("_SEQ_") "_Z,1,75)
"RTN","DGRP6",55,0)
 I LENGTH+$L(Z)>$S(LIN<2:49,1:70) S LIN=LIN+1,LIN(LIN)="",LENGTH=0
"RTN","DGRP6",56,0)
 S LIN(LIN)=LIN(LIN)_$S(LENGTH:"    ",1:"")_Z,LENGTH=$L(LIN(LIN))
"RTN","DGRP6",57,0)
 Q
"RTN","DGRP6",58,0)
 ;
"VER")
8.0^22.0
**INSTALL NAME**
IB*2.0*454
"BLD",8194,0)
IB*2.0*454^INTEGRATED BILLING^0^3110809^y
"BLD",8194,1,0)
^^1^1^3110502^
"BLD",8194,1,1,0)
INSTITUTIONAL LTC CD PATIENT EXEMPTION
"BLD",8194,4,0)
^9.64PA^^
"BLD",8194,6.3)
4
"BLD",8194,"ABPKG")
n
"BLD",8194,"KRN",0)
^9.67PA^779.2^20
"BLD",8194,"KRN",.4,0)
.4
"BLD",8194,"KRN",.401,0)
.401
"BLD",8194,"KRN",.402,0)
.402
"BLD",8194,"KRN",.403,0)
.403
"BLD",8194,"KRN",.5,0)
.5
"BLD",8194,"KRN",.84,0)
.84
"BLD",8194,"KRN",3.6,0)
3.6
"BLD",8194,"KRN",3.8,0)
3.8
"BLD",8194,"KRN",9.2,0)
9.2
"BLD",8194,"KRN",9.8,0)
9.8
"BLD",8194,"KRN",9.8,"NM",0)
^9.68A^6^4
"BLD",8194,"KRN",9.8,"NM",1,0)
IBAECU^^0^B55994641
"BLD",8194,"KRN",9.8,"NM",4,0)
IBECEA3^^0^B65921657
"BLD",8194,"KRN",9.8,"NM",5,0)
IBAECO^^0^B17633008
"BLD",8194,"KRN",9.8,"NM",6,0)
IBAECU3^^0^B13146832
"BLD",8194,"KRN",9.8,"NM","B","IBAECO",5)

"BLD",8194,"KRN",9.8,"NM","B","IBAECU",1)

"BLD",8194,"KRN",9.8,"NM","B","IBAECU3",6)

"BLD",8194,"KRN",9.8,"NM","B","IBECEA3",4)

"BLD",8194,"KRN",19,0)
19
"BLD",8194,"KRN",19.1,0)
19.1
"BLD",8194,"KRN",101,0)
101
"BLD",8194,"KRN",409.61,0)
409.61
"BLD",8194,"KRN",771,0)
771
"BLD",8194,"KRN",779.2,0)
779.2
"BLD",8194,"KRN",870,0)
870
"BLD",8194,"KRN",8989.51,0)
8989.51
"BLD",8194,"KRN",8989.52,0)
8989.52
"BLD",8194,"KRN",8994,0)
8994
"BLD",8194,"KRN","B",.4,.4)

"BLD",8194,"KRN","B",.401,.401)

"BLD",8194,"KRN","B",.402,.402)

"BLD",8194,"KRN","B",.403,.403)

"BLD",8194,"KRN","B",.5,.5)

"BLD",8194,"KRN","B",.84,.84)

"BLD",8194,"KRN","B",3.6,3.6)

"BLD",8194,"KRN","B",3.8,3.8)

"BLD",8194,"KRN","B",9.2,9.2)

"BLD",8194,"KRN","B",9.8,9.8)

"BLD",8194,"KRN","B",19,19)

"BLD",8194,"KRN","B",19.1,19.1)

"BLD",8194,"KRN","B",101,101)

"BLD",8194,"KRN","B",409.61,409.61)

"BLD",8194,"KRN","B",771,771)

"BLD",8194,"KRN","B",779.2,779.2)

"BLD",8194,"KRN","B",870,870)

"BLD",8194,"KRN","B",8989.51,8989.51)

"BLD",8194,"KRN","B",8989.52,8989.52)

"BLD",8194,"KRN","B",8994,8994)

"BLD",8194,"QDEF")
^^^^^^^^^^
"BLD",8194,"QUES",0)
^9.62^^
"BLD",8194,"REQB",0)
^9.611^1^1
"BLD",8194,"REQB",1,0)
IB*2.0*402^2
"BLD",8194,"REQB","B","IB*2.0*402",1)

"MBREQ")
0
"PKG",49,-1)
1^1
"PKG",49,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",49,20,0)
^9.402P^1^1
"PKG",49,20,1,0)
2^^IBAXDR
"PKG",49,20,1,1)

"PKG",49,20,"B",2,1)

"PKG",49,22,0)
^9.49I^1^1
"PKG",49,22,1,0)
2.0^2940321^2960627
"PKG",49,22,1,"PAH",1,0)
454^3110809
"PKG",49,22,1,"PAH",1,1,0)
^^1^1^3110809
"PKG",49,22,1,"PAH",1,1,1,0)
INSTITUTIONAL LTC CD PATIENT EXEMPTION
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
4
"RTN","IBAECO")
0^5^B17633008
"RTN","IBAECO",1,0)
IBAECO ;ALB/BGA - LONG TERM CARE OUTPATIENT TRACKER ;16-OCT-01
"RTN","IBAECO",2,0)
 ;;2.0;INTEGRATED BILLING;**164,171,176,188,312,454**;21-MAR-94;Build 4
"RTN","IBAECO",3,0)
 ;;Per VHA DIRECTIVE 10-93-142, this routine should not be modified.
"RTN","IBAECO",4,0)
 ;
"RTN","IBAECO",5,0)
 ; Comment- This routine is invoked via the appointment driver ^IBAMTS
"RTN","IBAECO",6,0)
 ;          This program checks for check outs and determines if
"RTN","IBAECO",7,0)
 ;          the person checking out is ELIGIBLE for Long Term Care
"RTN","IBAECO",8,0)
 ;          and determines if the encounter was related to LTC.
"RTN","IBAECO",9,0)
 ;          If the episode of care is related to LTC and the patient
"RTN","IBAECO",10,0)
 ;          is eligible to receive care and is compliant with all
"RTN","IBAECO",11,0)
 ;          the LTC business rules than the entry is added to
"RTN","IBAECO",12,0)
 ;          the LTC transaction file #351.8.
"RTN","IBAECO",13,0)
 ;
"RTN","IBAECO",14,0)
 ; Determine if this encounter has a status of checked out
"RTN","IBAECO",15,0)
EN N IBEVT,IBEV0,DFN,IBSDHDL,IBORG,IBOE,IBLTCST,IBCL,IBDT,IBST,IBM
"RTN","IBAECO",16,0)
 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                   ;IB*2.0*312
"RTN","IBAECO",17,0)
 S IBSDHDL=0
"RTN","IBAECO",18,0)
 ;
"RTN","IBAECO",19,0)
 ; === ON/OFF Switch by date if before 11/15/06 software will not run
"RTN","IBAECO",20,0)
 ; === IBALTC=0 the Encounter is not LTC Billable pass to MT Module
"RTN","IBAECO",21,0)
 ; === IBALTC=1 Encounter is LTC Billable do NOT Pass to MTC
"RTN","IBAECO",22,0)
 ;
"RTN","IBAECO",23,0)
 S IBALTC=0
"RTN","IBAECO",24,0)
 ;I DT<$$STDATE^IBAECU1() Q  ;quit if today<effective date
"RTN","IBAECO",25,0)
 F  S IBSDHDL=$O(^TMP("SDEVT",$J,IBSDHDL)) Q:'IBSDHDL  D
"RTN","IBAECO",26,0)
 . S IBORG=0 F  S IBORG=$O(^TMP("SDEVT",$J,IBSDHDL,IBORG)) Q:'IBORG  D
"RTN","IBAECO",27,0)
 . . S IBOE=0 F  S IBOE=$O(^TMP("SDEVT",$J,IBSDHDL,IBORG,"SDOE",IBOE)) Q:'IBOE  S IBEVT=$G(^(IBOE,0,"AFTER")),IBEV0=$G(^("BEFORE")) D
"RTN","IBAECO",28,0)
 . . . ;
"RTN","IBAECO",29,0)
 . . . Q:$P(IBEVT,U,6)  ; do not evaluate sibling encounters
"RTN","IBAECO",30,0)
 . . . Q:$P(IBEVT,U,12)=8  ; do not evaluate inpatient encounters
"RTN","IBAECO",31,0)
 . . . ;
"RTN","IBAECO",32,0)
 . . . ; set variables
"RTN","IBAECO",33,0)
 . . . S DFN=$P(IBEVT,U,2),IBDT=$S(+IBEVT:+IBEVT,1:+IBEV0),IBST=$P(IBEVT,U,3)
"RTN","IBAECO",34,0)
 . . . Q:IBDT<$$STDATE^IBAECU1
"RTN","IBAECO",35,0)
 . . . Q:'DFN!('IBDT)
"RTN","IBAECO",36,0)
 . . . ;
"RTN","IBAECO",37,0)
 . . . ; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date  ;CCR-930
"RTN","IBAECO",38,0)
 . . . I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q           ;IB*2.0*312
"RTN","IBAECO",39,0)
 . . . ;
"RTN","IBAECO",40,0)
 . . . ; stop code preset and LTC event?
"RTN","IBAECO",41,0)
 . . . I 'IBST Q
"RTN","IBAECO",42,0)
 . . . I '$$LTCSTOP^IBAECU(IBST) Q
"RTN","IBAECO",43,0)
 . . . ;
"RTN","IBAECO",44,0)
 . . . ; set flag to stop MT billing
"RTN","IBAECO",45,0)
 . . . S IBALTC=1
"RTN","IBAECO",46,0)
 . . . ;
"RTN","IBAECO",47,0)
 . . . ; LTC patient check
"RTN","IBAECO",48,0)
 . . . S IBLTCST=+$$LTCST^IBAECU(DFN,IBDT\1,1)
"RTN","IBAECO",49,0)
 . . . ;
"RTN","IBAECO",50,0)
 . . . ; are they exempt from non-institutional LTC because of CD status?
"RTN","IBAECO",51,0)
 . . . I $$CDEXMPT^IBAECU(DFN,IBDT\1) Q
"RTN","IBAECO",52,0)
 . . . ;
"RTN","IBAECO",53,0)
 . . . ; no 1010EC on file
"RTN","IBAECO",54,0)
 . . . I IBLTCST=0 D  D XMNOEC^IBAECU(DFN,.IBDT,.IBM) Q
"RTN","IBAECO",55,0)
 . . . . S IBM(1)="",IBM(2)="  Event Type:  Outpatient Encounter"
"RTN","IBAECO",56,0)
 . . . . S IBM(3)="",IBM(4)="Event Action:  "_$S($P(IBEV0,"^",12)'=2&($P(IBEVT,"^",12)=2):"Checked Out",IBEVT&(IBEV0):"Edited",IBEV0:"Deleted",1:"Added")
"RTN","IBAECO",57,0)
 . . . . S IBM(5)="",IBM(6)="    Location:  "_$S($P(IBEVT,"^",4):$P($G(^SC(+$P(IBEVT,"^",4),0)),"^"),$P(IBEVO,"^",4):$P($G(^SC(+$P(IBEVO,"^",4),0)),"^"),1:"")
"RTN","IBAECO",58,0)
 . . . ;
"RTN","IBAECO",59,0)
 . . . ; is this a back billing issue, if so, send message and quit
"RTN","IBAECO",60,0)
 . . . I $$LASTMJ^IBAECU()>0,$$LASTMJ^IBAECU()>IBDT D  D XMBACK^IBAECU(DFN,.IBM) Q
"RTN","IBAECO",61,0)
 . . . . S IBM(1)="An Outpatient Encounter was "_$S(IBEVT&(IBEV0):"Edited",IBEV0:"Deleted",1:"Added")_"."
"RTN","IBAECO",62,0)
 . . . . S IBM(2)="This may result in a Back Billing issue for LTC.  You should review the"
"RTN","IBAECO",63,0)
 . . . . S IBM(3)="patient's records for "_$$FMTE^XLFDT(IBDT)_" to ensure correct billing."
"RTN","IBAECO",64,0)
 . . . . S IBM(4)="LTC Billing Clock and LTC charges may have to be manually adjusted."
"RTN","IBAECO",65,0)
 . . . ;
"RTN","IBAECO",66,0)
 . . . ; add LTC clock/update last event date (if not LTC exempt)
"RTN","IBAECO",67,0)
 . . . I IBLTCST=2 S IBCL=$$CLOCK^IBAECU(DFN,IBDT\1)
"RTN","IBAECO",68,0)
 . . . ;
"RTN","IBAECO",69,0)
 ;
"RTN","IBAECO",70,0)
 Q
"RTN","IBAECO",71,0)
 ;
"RTN","IBAECO",72,0)
CALC ; used to calculate the outpatient charge
"RTN","IBAECO",73,0)
 ; variables needed DFN, IBLTCST, IBCHG, IBFR
"RTN","IBAECO",74,0)
 ; this will adjust IBCHG so the patient is not above their calculated
"RTN","IBAECO",75,0)
 ; copay cap for the month.
"RTN","IBAECO",76,0)
 N IBTYP,IBT
"RTN","IBAECO",77,0)
 ;
"RTN","IBAECO",78,0)
 ; find all LTC charges and set flag to determine inpt or opt
"RTN","IBAECO",79,0)
 ; cap to be used.
"RTN","IBAECO",80,0)
 D TOT^IBAECU
"RTN","IBAECO",81,0)
 ;
"RTN","IBAECO",82,0)
 W !!,"  Calculated Monthly Copay Cap Type to be used: ",$S(IBTYP="I":"IN",1:"OUT"),"PATIENT"
"RTN","IBAECO",83,0)
 W !,"               Calculated Monthly Copay Cap is: $ ",$FN($P(IBLTCST,"^",$S(IBTYP="I":3,1:5)),",",2)
"RTN","IBAECO",84,0)
 W !,"                       Total previously billed: $ ",$FN(IBT,",",2)
"RTN","IBAECO",85,0)
 ;
"RTN","IBAECO",86,0)
 I IBCHG+IBT>$P(IBLTCST,"^",$S(IBTYP="I":3,1:5)) S IBCHG=$P(IBLTCST,"^",$S(IBTYP="I":3,1:5))-IBT
"RTN","IBAECO",87,0)
 ;
"RTN","IBAECO",88,0)
 ; check for negative $ amount cap
"RTN","IBAECO",89,0)
 I $P(IBLTCST,"^",$S(IBTYP="I":3,1:5))<0 S IBCHG=0
"RTN","IBAECO",90,0)
 ;
"RTN","IBAECO",91,0)
 Q
"RTN","IBAECU")
0^1^B55994641
"RTN","IBAECU",1,0)
IBAECU ;ALB/BGA-LTC UTILITIES DETERMINE LTC ELIG ; 25-SEPT-01
"RTN","IBAECU",2,0)
 ;;2.0;INTEGRATED BILLING;**164,171,176,198,188,454**;21-MAR-94;Build 4
"RTN","IBAECU",3,0)
 ;; Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBAECU",4,0)
 ;
"RTN","IBAECU",5,0)
 ; This routine contains the following utilities in support of the
"RTN","IBAECU",6,0)
 ; LTC initiative:
"RTN","IBAECU",7,0)
 ; 1. Determine if a patient is ELIGIBLE for the LTC COPAY
"RTN","IBAECU",8,0)
 ; 2. Determine if a inpatient episode is related to LTC
"RTN","IBAECU",9,0)
 ;
"RTN","IBAECU",10,0)
 ;LTCST(DFN,IBDT); - Returns '2' if LTC Eligible or else '1' Not Eligible
"RTN","IBAECU",11,0)
 ;       ; -- Returns '-1' and a second piece if there is an ERROR
"RTN","IBAECU",12,0)
 ;       ; -- If 2 LTC VET's Income Exceeds Pension Level <LTC ELIG>
"RTN","IBAECU",13,0)
 ;       ; -- If 1 Not LTC Eligible = Exempt
"RTN","IBAECU",14,0)
 ;
"RTN","IBAECU",15,0)
LTCST(DFN,IBDT,LOS) ; returns LTC status from API
"RTN","IBAECU",16,0)
 ;  input:  Patient's DFN, Date of Care, Length of stay
"RTN","IBAECU",17,0)
 ;
"RTN","IBAECU",18,0)
 ; format:  exemption flag ^ exemption reason (714.1 pointer)
"RTN","IBAECU",19,0)
 ;          ^ <181 $ amount ^ >180 $ amount ^ opt $ amount
"RTN","IBAECU",20,0)
 Q $$COPAY^EASECCAL(DFN,$$LASTDT(IBDT),LOS)
"RTN","IBAECU",21,0)
 ;
"RTN","IBAECU",22,0)
 ;
"RTN","IBAECU",23,0)
MAXRATE(IBDT) ; returns the max rates for the effective date
"RTN","IBAECU",24,0)
 ; the rates retuned are the max daily rates for any and all LTC
"RTN","IBAECU",25,0)
 ; copayments.  The return is:  outpatient^inpatient
"RTN","IBAECU",26,0)
 ;
"RTN","IBAECU",27,0)
 N IBATYP,IBR,IBL,IBT,IBCHG
"RTN","IBAECU",28,0)
 ;
"RTN","IBAECU",29,0)
 S IBR=""
"RTN","IBAECU",30,0)
 ;
"RTN","IBAECU",31,0)
 ; if IBDT less than the starting date of LTC set to the starting date
"RTN","IBAECU",32,0)
 I IBDT<3020726 S IBDT=3020726
"RTN","IBAECU",33,0)
 ;
"RTN","IBAECU",34,0)
 F IBL=1:1 S IBT=$P($T(STOP+IBL^IBAECU1),";",3) Q:IBT=""  S IBATYP=$O(^IBE(350.1,"B",IBT,0)) I IBATYP D COST^IBAUTL2 I IBCHG>IBR S IBR=IBCHG
"RTN","IBAECU",35,0)
 F IBL=1:1 S IBT=$P($T(SPEC+IBL^IBAECU1),";",3) Q:IBT=""  S IBATYP=$O(^IBE(350.1,"B",IBT,0)) I IBATYP D COST^IBAUTL2 I IBCHG>$P(IBR,"^",2) S $P(IBR,"^",2)=IBCHG
"RTN","IBAECU",36,0)
 Q IBR
"RTN","IBAECU",37,0)
 ;
"RTN","IBAECU",38,0)
FACSPEC(IBSPEC) ; returns the treating specialty for 42.4 from a facility sp
"RTN","IBAECU",39,0)
 ;
"RTN","IBAECU",40,0)
 Q $P($G(^DIC(45.7,+$G(IBSPEC),0)),"^",2)
"RTN","IBAECU",41,0)
 ;
"RTN","IBAECU",42,0)
 ;
"RTN","IBAECU",43,0)
LTCSPEC(IBSPEC)   ; Determine if INPT Specialty is related to LTC.
"RTN","IBAECU",44,0)
 ;       -- Input the ien of #42.4 Specialty
"RTN","IBAECU",45,0)
 ;
"RTN","IBAECU",46,0)
 ;       -- Output: Piece 1:  If a LTC Specialty Bedsection Pointer 399.1
"RTN","IBAECU",47,0)
 ;                            If not LTC Spec Return 0
"RTN","IBAECU",48,0)
 ;                  Piece 2:  If LTC, type of LTC
"RTN","IBAECU",49,0)
 ;
"RTN","IBAECU",50,0)
 N IBTS
"RTN","IBAECU",51,0)
 ;
"RTN","IBAECU",52,0)
 ;  get the LTC Treating Specialty type
"RTN","IBAECU",53,0)
 S IBTS=$T(@("T"_IBSPEC)^IBAECU1)
"RTN","IBAECU",54,0)
 ;
"RTN","IBAECU",55,0)
 Q $S($L(IBTS):+$E(IBTS,2,99)_"^"_$P(IBTS,";",3),1:0)
"RTN","IBAECU",56,0)
 ;
"RTN","IBAECU",57,0)
 ;
"RTN","IBAECU",58,0)
LTCSTOP(IB407)   ; Determine if the 'STOP CODE' is related to LTC.
"RTN","IBAECU",59,0)
 ;
"RTN","IBAECU",60,0)
 ;       -- Input the ien of #40.7 Clinic Stop Code
"RTN","IBAECU",61,0)
 ;
"RTN","IBAECU",62,0)
 ;       -- Output: 1st piece 1 -  LTC STOP CODE
"RTN","IBAECU",63,0)
 ;                            0 -  Not LTC STOP CODE
"RTN","IBAECU",64,0)
 ;
"RTN","IBAECU",65,0)
 ;                  2nd piece = if LTC, type of LTC
"RTN","IBAECU",66,0)
 ;
"RTN","IBAECU",67,0)
 N IBSTOP,IBSCDATA
"RTN","IBAECU",68,0)
 ;
"RTN","IBAECU",69,0)
 ;  get the stop code in IBSCDATA(40.7,IB407,1,"E")
"RTN","IBAECU",70,0)
 D DIQ407^IBEMTSCU(IB407,1)
"RTN","IBAECU",71,0)
 I $G(IBSCDATA(40.7,IB407,1,"E"))="" Q 0
"RTN","IBAECU",72,0)
 ;
"RTN","IBAECU",73,0)
 ;  get the LTC stop type
"RTN","IBAECU",74,0)
 S IBSTOP=$T(@("C"_IBSCDATA(40.7,IB407,1,"E"))^IBAECU1)
"RTN","IBAECU",75,0)
 ;
"RTN","IBAECU",76,0)
 Q $S($L(IBSTOP):+$E(IBSTOP,2,99)_"^"_$P(IBSTOP,";",3),1:0)
"RTN","IBAECU",77,0)
 ;
"RTN","IBAECU",78,0)
 ;
"RTN","IBAECU",79,0)
CLOCK(DFN,IBDATE) ; verfiy a clock exists, if not, one will be added
"RTN","IBAECU",80,0)
 N X,Y,IBCL,IBX,DA,DIE,DR,IBFLG
"RTN","IBAECU",81,0)
 ;
"RTN","IBAECU",82,0)
 ; get last clock for patient
"RTN","IBAECU",83,0)
 S IBX=9999999,IBFLG=0
"RTN","IBAECU",84,0)
 F  S IBX=$O(^IBA(351.81,"AE",DFN,IBX),-1) Q:+IBX=0!(IBFLG>0)  D
"RTN","IBAECU",85,0)
 . S IBCL=0
"RTN","IBAECU",86,0)
 . F  S IBCL=$O(^IBA(351.81,"AE",DFN,IBX,IBCL)) Q:+IBCL=0!(IBFLG>0)  D
"RTN","IBAECU",87,0)
 . . Q:+$P(^IBA(351.81,IBCL,0),"^",5)'=1  ;if it is not OPEN
"RTN","IBAECU",88,0)
 . . S IBFLG=IBCL
"RTN","IBAECU",89,0)
 ;
"RTN","IBAECU",90,0)
 ; if has an OPEN clock already
"RTN","IBAECU",91,0)
 I IBFLG>0 D  Q 1
"RTN","IBAECU",92,0)
 . I +$P(^IBA(351.81,IBFLG,0),"^",7)>0 Q  ;already flagged - quit
"RTN","IBAECU",93,0)
 . S DIE="^IBA(351.81,",DR=".07////^S X=IBDATE",DA=IBFLG D ^DIE
"RTN","IBAECU",94,0)
 ; if there is no OPEN clock the add a new clock, and set CURRENT EVENTS DATE
"RTN","IBAECU",95,0)
 S DIE="^IBA(351.81,",DA=+$$ADDCL(DFN,IBDATE),DR=".07////^S X=IBDATE" X $S(DA>0:"D ^DIE S Y=DA",1:"S Y=-1")
"RTN","IBAECU",96,0)
 Q +Y
"RTN","IBAECU",97,0)
 ;
"RTN","IBAECU",98,0)
 ;
"RTN","IBAECU",99,0)
YR(IBRTED,IBFR) ; is the effective date of the clock too old?
"RTN","IBAECU",100,0)
 ;  Input:   IBRTED  --  Effective Date
"RTN","IBAECU",101,0)
 ;             IBFR  --  Event Date
"RTN","IBAECU",102,0)
 ;  Output:       1  --  Effective Date is too old
"RTN","IBAECU",103,0)
 ;                0  --  Not
"RTN","IBAECU",104,0)
 N IBNUM,IBYR
"RTN","IBAECU",105,0)
 S IBNUM=$$FMDIFF^XLFDT(IBFR,IBRTED),IBYR=$E(IBFR,1,3)
"RTN","IBAECU",106,0)
 Q IBYR#4&(IBNUM>364)!(IBYR#4=0&(IBNUM>365))
"RTN","IBAECU",107,0)
 ;
"RTN","IBAECU",108,0)
ADDCL(DFN,IBADT) ; adds a LTC clock, returns LTC Clock IEN
"RTN","IBAECU",109,0)
 ; needs DFN and IBADT (clock begin date)
"RTN","IBAECU",110,0)
 ;
"RTN","IBAECU",111,0)
 N %DT,DD,DO,DIC,DR,X,Y,DA,DR,DIE,IBN,IBN1,IBSITE,IBFAC,DINUM,DLAYGO
"RTN","IBAECU",112,0)
 L +^IBA(351.81,0):10 I '$T S Y="-1^IB014" G ADDCLQ
"RTN","IBAECU",113,0)
 S X=$P($S($D(^IBA(351.81,0)):^(0),1:"^^-1"),"^",3)+1 L -^IBA(351.81,0) I 'X S Y="-1^IB015" G ADDCLQ
"RTN","IBAECU",114,0)
 D SITE^IBAUTL
"RTN","IBAECU",115,0)
 N IBAEXDT S IBAEXDT=$$GETEXPDT^IBAECU4(IBADT\1) ;expiration date
"RTN","IBAECU",116,0)
 S DIC="^IBA(351.81,",DIC(0)="L",DLAYGO=351.81
"RTN","IBAECU",117,0)
 F X=X:1 L:$D(IBN1) -^IBA(351.81,IBN1) I X>0,'$D(^IBA(351.81,X)) S IBN1=X L +^IBA(351.81,IBN1):1 I $T,'$D(^IBA(351.81,X)) S DINUM=X,X=+IBSITE_X D FILE^DICN I +Y>0 Q
"RTN","IBAECU",118,0)
 S IBN=+Y,DIE="^IBA(351.81,",DA=IBN,DR=".02////"_$S($D(DFN):DFN,1:"")_";.03////"_$S($D(IBADT):IBADT,1:"")_";.04////"_$S($D(IBAEXDT):IBAEXDT,1:"")_";.05////1;.06////21;"_$S(DUZ:"4.01///"_DUZ_";",1:"")_"4.02///NOW" D ^DIE
"RTN","IBAECU",119,0)
 L -^IBA(351.81,IBN1)
"RTN","IBAECU",120,0)
 S Y=$S('$D(Y):1,1:"-1^IB028")
"RTN","IBAECU",121,0)
 ;
"RTN","IBAECU",122,0)
ADDCLQ Q $S($G(IBN):IBN,1:Y)
"RTN","IBAECU",123,0)
 ;
"RTN","IBAECU",124,0)
LTCENC(DFN,DATE) ; Did the patient have LTC on a specified date?
"RTN","IBAECU",125,0)
 ; Input:    DFN  --  Pointer to the patient in file #2
"RTN","IBAECU",126,0)
 ;          DATE  --  Date of the Outpatient Visit
"RTN","IBAECU",127,0)
 ; Output:     0  --  Patient did not have a LTC on the visit date
"RTN","IBAECU",128,0)
 ;             1  --  Patient had a LTC on the visit date
"RTN","IBAECU",129,0)
 N X,Y,Y0,IBVAL,IBCBK,IBFILTER,IBLTC
"RTN","IBAECU",130,0)
 I '$G(DFN)!('$G(DATE)) G LTCENCQ
"RTN","IBAECU",131,0)
 ; - check appts, stop codes
"RTN","IBAECU",132,0)
 S IBVAL("DFN")=DFN,IBVAL("BDT")=DATE,IBVAL("EDT")=DATE+.9999
"RTN","IBAECU",133,0)
 ; Only parent appt or add/edit encounters
"RTN","IBAECU",134,0)
 S IBFILTER=""
"RTN","IBAECU",135,0)
 S IBCBK="I '$P(Y0,U,6),$P(Y0,U,8)<3,$P(Y0,U,3),$$LTCSTOP^IBAECU($P(Y0,U,3)),$P(Y0,U)'<$$STDATE^IBAECU1 S (IBLTC,SDSTOP)=1"
"RTN","IBAECU",136,0)
 S IBLTC=0
"RTN","IBAECU",137,0)
 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
"RTN","IBAECU",138,0)
 I IBLTC S Y=1
"RTN","IBAECU",139,0)
LTCENCQ Q +$G(Y)
"RTN","IBAECU",140,0)
 ;
"RTN","IBAECU",141,0)
 ;
"RTN","IBAECU",142,0)
XMBACK(DFN,IBM) ; send a message saying LTC processing has stoped for an event
"RTN","IBAECU",143,0)
 ;
"RTN","IBAECU",144,0)
 N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBX,IBT,XMDUZ
"RTN","IBAECU",145,0)
 ;
"RTN","IBAECU",146,0)
 D XMDEM(DFN,.IBT,.IBL)
"RTN","IBAECU",147,0)
 ;
"RTN","IBAECU",148,0)
 S XMSUB="LTC Copayment Back Billing/Error",XMY("G.IB LTC BACK BILLING")="",XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
"RTN","IBAECU",149,0)
 ;
"RTN","IBAECU",150,0)
 S IBX=0 F  S IBX=$O(IBM(IBX)) Q:IBX<1  S IBL=IBL+1,IBT(IBL,0)=IBM(IBX)
"RTN","IBAECU",151,0)
 ;
"RTN","IBAECU",152,0)
 D ^XMD
"RTN","IBAECU",153,0)
 ;
"RTN","IBAECU",154,0)
 Q
"RTN","IBAECU",155,0)
 ;
"RTN","IBAECU",156,0)
XMNOEC(DFN,IBDT,IBE) ; send a message saying no 1010EC on file for LTC pt.
"RTN","IBAECU",157,0)
 ; IBE is optional additional text
"RTN","IBAECU",158,0)
 ;
"RTN","IBAECU",159,0)
 N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,X
"RTN","IBAECU",160,0)
 ;
"RTN","IBAECU",161,0)
 ; if already done for this patient and month, quit
"RTN","IBAECU",162,0)
 I $D(^XTMP("IB1010EC",DFN)) Q
"RTN","IBAECU",163,0)
 S ^XTMP("IB1010EC",DFN)=""
"RTN","IBAECU",164,0)
 ;
"RTN","IBAECU",165,0)
 D XMDEM(DFN,.IBT,.IBL)
"RTN","IBAECU",166,0)
 ;
"RTN","IBAECU",167,0)
 S XMSUB="1010EC Missing for LTC Patient",XMY("G.IB LTC 1010EC MISSING")="",XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
"RTN","IBAECU",168,0)
 ;
"RTN","IBAECU",169,0)
 S IBL=IBL+1,IBT(IBL,0)="The above patient has received LTC services on "_$$FMTE^XLFDT(IBDT)_" and"
"RTN","IBAECU",170,0)
 S IBL=IBL+1,IBT(IBL,0)="does not have a LTC Copayment Test on file.  A LTC Copayment test needs to"
"RTN","IBAECU",171,0)
 S IBL=IBL+1,IBT(IBL,0)="be completed as soon as possible to determine the patient's eligibility"
"RTN","IBAECU",172,0)
 S IBL=IBL+1,IBT(IBL,0)="for exemption and/or copayment obligation.  Billing cannot be processed"
"RTN","IBAECU",173,0)
 S IBL=IBL+1,IBT(IBL,0)="until this information is entered."
"RTN","IBAECU",174,0)
 S IBL=IBL+1,IBT(IBL,0)=""
"RTN","IBAECU",175,0)
 I $D(IBE)>9 S X=0 F  S X=$O(IBE(X)) Q:'X  S IBL=IBL+1,IBT(IBL,0)=IBE(X)
"RTN","IBAECU",176,0)
 ;
"RTN","IBAECU",177,0)
 D ^XMD
"RTN","IBAECU",178,0)
 ;
"RTN","IBAECU",179,0)
 Q
"RTN","IBAECU",180,0)
 ;
"RTN","IBAECU",181,0)
XMDEM(DFN,IBT,IBL) ; Sets basic demographics in text
"RTN","IBAECU",182,0)
 ;
"RTN","IBAECU",183,0)
 N VADM,VA,VAERR
"RTN","IBAECU",184,0)
 ;
"RTN","IBAECU",185,0)
 D DEM^VADPT
"RTN","IBAECU",186,0)
 ;
"RTN","IBAECU",187,0)
 S IBT(1,0)="  Patient: "_VADM(1)
"RTN","IBAECU",188,0)
 S IBT(3,0)="      SSN: "_$P(VADM(2),"^",2)
"RTN","IBAECU",189,0)
 S (IBT(2,0),IBT(4,0))=" "
"RTN","IBAECU",190,0)
 S IBL=4
"RTN","IBAECU",191,0)
 ;
"RTN","IBAECU",192,0)
 Q
"RTN","IBAECU",193,0)
 ;
"RTN","IBAECU",194,0)
LASTDT(X) ; compute the last day of the month in X
"RTN","IBAECU",195,0)
 N XM,X1,X2
"RTN","IBAECU",196,0)
 I $E(X,4,5)=12 Q $E(X,1,5)_"31"
"RTN","IBAECU",197,0)
 S XM=$E(X,4,5)+1
"RTN","IBAECU",198,0)
 S:XM<10 XM="0"_XM
"RTN","IBAECU",199,0)
 S X1=$E(X,1,3)_XM_"01"
"RTN","IBAECU",200,0)
 S X2=-1
"RTN","IBAECU",201,0)
 D C^%DTC
"RTN","IBAECU",202,0)
 Q X
"RTN","IBAECU",203,0)
 ;
"RTN","IBAECU",204,0)
TOT ; calculates the total charged for a patient (for the month)
"RTN","IBAECU",205,0)
 ; requires IBFR, IBLTCST, DFN
"RTN","IBAECU",206,0)
 ; returns IBT (total amount already billed), IBTYP (inpt or opt)
"RTN","IBAECU",207,0)
 ;
"RTN","IBAECU",208,0)
 N IBDT,IBX,IBZ
"RTN","IBAECU",209,0)
 S IBTYP="O",IBT=0
"RTN","IBAECU",210,0)
 ;
"RTN","IBAECU",211,0)
 S IBDT=-$E(IBFR,1,5)_"00" F  S IBDT=$O(^IB("AFDT",DFN,IBDT),-1) Q:IBDT=""!($E(IBDT,2,6)'=$E(IBFR,1,5))  S IBX=0 F  S IBX=$O(^IB("AFDT",DFN,IBDT,IBX)) Q:IBX<1  S IBZ=$G(^IB(IBX,0)) I $E($G(^IBE(350.1,+$P(IBZ,"^",3),0)),1,7)="DG LTC " D
"RTN","IBAECU",212,0)
 . ;
"RTN","IBAECU",213,0)
 . ; don't use bills that are cancelled.
"RTN","IBAECU",214,0)
 . I $P($G(^IBE(350.21,+$P(IBZ,"^",5),0)),"^",5) Q
"RTN","IBAECU",215,0)
 . ;
"RTN","IBAECU",216,0)
 . ; don't use cancellation action types either
"RTN","IBAECU",217,0)
 . I $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^",5)=2 Q
"RTN","IBAECU",218,0)
 . ;
"RTN","IBAECU",219,0)
 . S IBT=IBT+$P(^IB(IBX,0),"^",7)
"RTN","IBAECU",220,0)
 . I $E(^IBE(350.1,$P(IBZ,"^",3),0),8,11)="INPT" S IBTYP="I"
"RTN","IBAECU",221,0)
 ;
"RTN","IBAECU",222,0)
 Q
"RTN","IBAECU",223,0)
 ;
"RTN","IBAECU",224,0)
LASTMJ() ; function to return when the Monthly Job was last run or 0
"RTN","IBAECU",225,0)
 N IBLSTDT
"RTN","IBAECU",226,0)
 S IBLSTDT=$P($G(^IBE(350.9,1,0)),"^",16)
"RTN","IBAECU",227,0)
 Q $S(IBLSTDT>3:IBLSTDT,1:0)
"RTN","IBAECU",228,0)
 ;
"RTN","IBAECU",229,0)
CDEXMPT(DFN,IBDT) ; determine if the patient is exempt from non-institutional
"RTN","IBAECU",230,0)
 ; ltc charges because of Catastrophically Disabled status
"RTN","IBAECU",231,0)
 ; 0 - not exempt from LTC, 1 - exempt from LTC
"RTN","IBAECU",232,0)
 N IBDG
"RTN","IBAECU",233,0)
 S IBDG=$$GET^DGENCDA(DFN,.IBDG)  ; IA# 4969
"RTN","IBAECU",234,0)
 I $G(IBDG("VCD"))'="Y" Q 0 ; cd indicator
"RTN","IBAECU",235,0)
 Q $S(IBDT<$G(IBDG("DATE")):0,1:1)
"RTN","IBAECU",236,0)
 ;
"RTN","IBAECU3")
0^6^B13146832
"RTN","IBAECU3",1,0)
IBAECU3 ;WOIFO/SS-LTC PHASE 2 UTILITIES ; 20-FEB-02
"RTN","IBAECU3",2,0)
 ;;2.0;INTEGRATED BILLING;**176,454**;21-MAR-94;Build 4
"RTN","IBAECU3",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBAECU3",4,0)
 ;
"RTN","IBAECU3",5,0)
 ;****** Outpatient LTC related utilities *********
"RTN","IBAECU3",6,0)
 ;/*--
"RTN","IBAECU3",7,0)
 ;Returns info about all visits via ^TMP($J,IBLB,IBDFN) global
"RTN","IBAECU3",8,0)
 ;
"RTN","IBAECU3",9,0)
 ;Input:
"RTN","IBAECU3",10,0)
 ;
"RTN","IBAECU3",11,0)
 ;IBFRBEG- first date (in FM format),must be a valid,
"RTN","IBAECU3",12,0)
 ;  (wrong date like 3000231 will cause mistakes)
"RTN","IBAECU3",13,0)
 ;IBFREND- last date (in FM format),must be a valid date
"RTN","IBAECU3",14,0)
 ;  if any of dates above > yesterday it will be set to yesterday 
"RTN","IBAECU3",15,0)
 ;
"RTN","IBAECU3",16,0)
 ;IBDFN  - patient's ien in file (#2)
"RTN","IBAECU3",17,0)
 ;IBLB  - any string to identify results in ^TMP($J,IBLB
"RTN","IBAECU3",18,0)
 ;Output:
"RTN","IBAECU3",19,0)
 ;
"RTN","IBAECU3",20,0)
 ;temp global array with inpatient info:
"RTN","IBAECU3",21,0)
 ;  ^TMP($J,IBLB,IBDFN,date,"M"/"L",IEN40968)=L/M^stopcode^
"RTN","IBAECU3",22,0)
 ;
"RTN","IBAECU3",23,0)
 ;  where pieces:
"RTN","IBAECU3",24,0)
 ;  #1 - "L" for LTC, "M" for MeansTest
"RTN","IBAECU3",25,0)
 ;  #2 - stopcode
"RTN","IBAECU3",26,0)
 ;  #3 - empty
"RTN","IBAECU3",27,0)
 ;  #4 - pointer to #350.1 IB action type
"RTN","IBAECU3",28,0)
 ;Returns:
"RTN","IBAECU3",29,0)
 ;  0 - none
"RTN","IBAECU3",30,0)
 ;  1 - if any leave or stay days in the period
"RTN","IBAECU3",31,0)
OUTPINFO(IBFRBEG,IBFREND,IBDFN,IBLB) ;
"RTN","IBAECU3",32,0)
 N IBVAL,IBCBK,IBFILTER,IBRES
"RTN","IBAECU3",33,0)
 S IBVAL("DFN")=IBDFN,IBVAL("BDT")=IBFRBEG-.1,IBVAL("EDT")=+(IBFREND_".9999999")
"RTN","IBAECU3",34,0)
 S IBFILTER=""
"RTN","IBAECU3",35,0)
 ; we look only for STATUS=CHECKED OUT i.e. $P(Y0,U,12)=2 in IBCBK
"RTN","IBAECU3",36,0)
 ;  consider only parent encounters, appts checked out, don't include
"RTN","IBAECU3",37,0)
 ;  if the date is when they are CD exempt
"RTN","IBAECU3",38,0)
 S IBCBK="I '$P(Y0,U,6),$P(Y0,U,12)=2 S:'$$CDEXMPT^IBAECU(IBDFN,$P(Y0,U)/1) IBRES=$$STOPINFO^IBAECU3($P(Y0,U,3),0),^TMP($J,IBLB,IBDFN,+Y0\1,Y)=IBRES"
"RTN","IBAECU3",39,0)
 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
"RTN","IBAECU3",40,0)
 Q +$O(^TMP($J,IBLB,IBDFN,0))>0
"RTN","IBAECU3",41,0)
 ;/**
"RTN","IBAECU3",42,0)
 ;get stop-code related info
"RTN","IBAECU3",43,0)
 ;IB407 pointer to file #40.7
"RTN","IBAECU3",44,0)
 ;IBDT - date to get rate, if 0 then will not return a rate in 3rd piece
"RTN","IBAECU3",45,0)
 ;returns 
"RTN","IBAECU3",46,0)
 ;IBTYPE_"^"_IBCODE_"^"_IBRATE_"^"_IBATYP
"RTN","IBAECU3",47,0)
 ;IBCARE - "M" for means test, "L" for LTC
"RTN","IBAECU3",48,0)
 ;IBCODE - AMIS REPORTING STOP CODE
"RTN","IBAECU3",49,0)
 ;IBRATE - rate for LTC, 0 for Means test
"RTN","IBAECU3",50,0)
 ;IBATYP - ien of 350.1
"RTN","IBAECU3",51,0)
STOPINFO(IB407,IBDT) ;
"RTN","IBAECU3",52,0)
 N Y,X
"RTN","IBAECU3",53,0)
 N IBI,IBCR,IBCODE,IBATYP,IBCHG
"RTN","IBAECU3",54,0)
 N IBSCDATA,IBNAME
"RTN","IBAECU3",55,0)
 D DIQ407^IBEMTSCU(IB407,1)
"RTN","IBAECU3",56,0)
 S IBCODE=$G(IBSCDATA(40.7,IB407,1,"E"))
"RTN","IBAECU3",57,0)
 Q:+IBCODE=0 ""
"RTN","IBAECU3",58,0)
 S IBNAME=$P($$LTCSTOP^IBAECU(IB407),"^",2)
"RTN","IBAECU3",59,0)
 Q:IBNAME="" "M^"_IBCODE_"^^"
"RTN","IBAECU3",60,0)
 S IBATYP=$O(^IBE(350.1,"B",IBNAME,0))
"RTN","IBAECU3",61,0)
 Q:+IBATYP=0 ""
"RTN","IBAECU3",62,0)
 S IBCHG=""
"RTN","IBAECU3",63,0)
 I +$G(IBDT)>0 D
"RTN","IBAECU3",64,0)
 . S IBCHG=0
"RTN","IBAECU3",65,0)
 . D COST^IBAUTL2
"RTN","IBAECU3",66,0)
 Q "L^"_IBCODE_"^"_IBCHG_"^"_IBATYP
"RTN","IBAECU3",67,0)
 ;
"RTN","IBAECU3",68,0)
 ;returns rate for different LTC services
"RTN","IBAECU3",69,0)
 ;INPUT:
"RTN","IBAECU3",70,0)
 ;IBCARE=1 - outpatient(clinic stopcode),IBTYPE=2 - inpatient(treating specialty)
"RTN","IBAECU3",71,0)
 ;IBCODE - treating specialty(outpatient) or clinic stopcode (inpatient)
"RTN","IBAECU3",72,0)
 ;IBDT - date of care
"RTN","IBAECU3",73,0)
 ;if not found - returns 0
"RTN","IBAECU3",74,0)
GETRATE(IBCARE,IBCODE,IBDT) ;
"RTN","IBAECU3",75,0)
 N IBCHG,IBATYP,IBTAG
"RTN","IBAECU3",76,0)
 N IBI,IBCR,IBNAME
"RTN","IBAECU3",77,0)
 S:'$D(U) U="^"
"RTN","IBAECU3",78,0)
 S (IBCHG,IBATYP)=0
"RTN","IBAECU3",79,0)
 S:IBCARE=1 IBTAG="C"_IBCODE,IBNAME=$P($T(@IBTAG^IBAECU1),";",3)
"RTN","IBAECU3",80,0)
 S:IBCARE=2 IBTAG="T"_IBCODE,IBNAME=$P($T(@IBTAG^IBAECU1),";",3)
"RTN","IBAECU3",81,0)
 Q:IBNAME="" IBCHG
"RTN","IBAECU3",82,0)
 S IBATYP=$O(^IBE(350.1,"B",IBNAME,0))
"RTN","IBAECU3",83,0)
 Q:+IBATYP=0 IBCHG
"RTN","IBAECU3",84,0)
 D COST^IBAUTL2
"RTN","IBAECU3",85,0)
 Q IBCHG_"^"_IBATYP
"RTN","IBAECU3",86,0)
 ;/**
"RTN","IBAECU3",87,0)
 ;is there any outp episode with that day
"RTN","IBAECU3",88,0)
 ;Input:
"RTN","IBAECU3",89,0)
 ;IBDFN - dfn of the patient
"RTN","IBAECU3",90,0)
 ;IBDT1 - date
"RTN","IBAECU3",91,0)
 ;IBTMPLB - ^TMP global subscript like IBADM in $$INPINFO
"RTN","IBAECU3",92,0)
 ;Output:
"RTN","IBAECU3",93,0)
 ;Returns "a^b" where :
"RTN","IBAECU3",94,0)
 ;a - number of LTC admissions on this date
"RTN","IBAECU3",95,0)
 ;b - number of Means Test admissions on this date
"RTN","IBAECU3",96,0)
 ;if "" - nothing
"RTN","IBAECU3",97,0)
 ; means test:
"RTN","IBAECU3",98,0)
 ;.IBVIS("M",#)=treating specialty^
"RTN","IBAECU3",99,0)
 ; LTC:  
"RTN","IBAECU3",100,0)
 ;.IBVIS("L",#)=treating specialty^ien of 350.1I action type
"RTN","IBAECU3",101,0)
ISOUTP(IBDFN,IBDT1,IBTMPLB,IBVIS) ;*/
"RTN","IBAECU3",102,0)
 N IB40968,IBRETV,IBD,IB1
"RTN","IBAECU3",103,0)
 S IB40968=0,IBRETV=""
"RTN","IBAECU3",104,0)
 F  S IB40968=$O(^TMP($J,IBTMPLB,IBDFN,IBDT1,IB40968)) Q:+IB40968=0  D
"RTN","IBAECU3",105,0)
 . S IBD=$G(^TMP($J,IBTMPLB,IBDFN,IBDT1,IB40968))
"RTN","IBAECU3",106,0)
 . S IB1=$P(IBD,"^",1)
"RTN","IBAECU3",107,0)
 . I IB1="L" S $P(IBRETV,"^",1)=$P($G(IBRETV),"^",1)+1
"RTN","IBAECU3",108,0)
 . I IB1="M" S $P(IBRETV,"^",2)=$P($G(IBRETV),"^",2)+1
"RTN","IBAECU3",109,0)
 . S IBVIS(IB1,IB40968)=$P(IBD,"^",2)_"^"_$P(IBD,"^",4)
"RTN","IBAECU3",110,0)
 Q IBRETV
"RTN","IBAECU3",111,0)
 ;
"RTN","IBAECU3",112,0)
 ;checks if there is Means test outpatient visits this date and
"RTN","IBAECU3",113,0)
 ;cancels them if there is a charge 
"RTN","IBAECU3",114,0)
CHKMTOUT(IBDFN,IBDT,IBTMPLB) ;
"RTN","IBAECU3",115,0)
 N IBV1
"RTN","IBAECU3",116,0)
 N RETIENS S RETIENS=0
"RTN","IBAECU3",117,0)
 S IBV1=$$ISOUTP(IBDFN,IBDT,IBTMPLB,.RETIENS) Q:+$P(IBV1,"^",2)=0
"RTN","IBAECU3",118,0)
 S IBV1=0
"RTN","IBAECU3",119,0)
 F  S IBV1=$O(RETIENS("M",IBV1)) Q:+IBV1=0  D
"RTN","IBAECU3",120,0)
 . D CANCVIS^IBAECU5(IBDFN,IBDT)
"RTN","IBAECU3",121,0)
 Q
"RTN","IBAECU3",122,0)
 ;
"RTN","IBAECU3",123,0)
 ;
"RTN","IBAECU3",124,0)
 ;return IB action type based on treating specialty (42.4)
"RTN","IBAECU3",125,0)
 ;or clinic stop code
"RTN","IBAECU3",126,0)
 ;IBCARE=1 - outpatient(clinic stopcode),IBTYPE=2 - inpatient(treating specialty)
"RTN","IBAECU3",127,0)
 ;IBCODE - treating specialty(outpatient) or clinic stopcode (inpatient)
"RTN","IBAECU3",128,0)
GET3501(IBCARE,IBCODE) ;
"RTN","IBAECU3",129,0)
 N IBATYP,IBNAME
"RTN","IBAECU3",130,0)
 S:IBCARE=1 IBTAG="C"_IBCODE,IBNAME=$P($T(@IBTAG^IBAECU1),";",3)
"RTN","IBAECU3",131,0)
 S:IBCARE=2 IBTAG="T"_IBCODE,IBNAME=$P($T(@IBTAG^IBAECU1),";",3)
"RTN","IBAECU3",132,0)
 Q:IBNAME="" 0
"RTN","IBAECU3",133,0)
 S IBATYP=$O(^IBE(350.1,"B",IBNAME,0))
"RTN","IBAECU3",134,0)
 Q +IBATYP
"RTN","IBAECU3",135,0)
 ;
"RTN","IBECEA3")
0^4^B65921657
"RTN","IBECEA3",1,0)
IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ;30-MAR-93
"RTN","IBECEA3",2,0)
 ;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,156,167,176,198,188,183,202,240,312,402,454**;21-MAR-94;Build 4
"RTN","IBECEA3",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBECEA3",4,0)
 ;
"RTN","IBECEA3",5,0)
ADD ; Add a Charge protocol
"RTN","IBECEA3",6,0)
 N IBGMT,IBGMTR
"RTN","IBECEA3",7,0)
 S (IBGMT,IBGMTR)=0
"RTN","IBECEA3",8,0)
 S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN),IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
"RTN","IBECEA3",9,0)
 ;I 'IBCVAEL,'IBCATC,'$G(IBRX),+IBEXSTAT<1 W !!,"This patient has never been Means Test billable." S VALMBCK="" D PAUSE^VALM1 G ADDQ1
"RTN","IBECEA3",10,0)
 ;
"RTN","IBECEA3",11,0)
 ; - clear screen and begin
"RTN","IBECEA3",12,0)
 D CLOCK^IBAUTL3 I 'IBCLDA S (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
"RTN","IBECEA3",13,0)
 D HDR^IBECEAU("A D D")
"RTN","IBECEA3",14,0)
 I IBY<0 D NODED^IBECEAU3 G ADDQ
"RTN","IBECEA3",15,0)
 ;
"RTN","IBECEA3",16,0)
 ; - ask for the charge type
"RTN","IBECEA3",17,0)
 D CHTYP^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",18,0)
 N IBAFEE S:$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)="FEE SERVICE/OUTPATIENT" IBAFEE=IBATYP
"RTN","IBECEA3",19,0)
 ;
"RTN","IBECEA3",20,0)
 ; - process CHAMPVA charges
"RTN","IBECEA3",21,0)
 I IBXA=6 D CHMPVA^IBECEA32 G ADDQ
"RTN","IBECEA3",22,0)
 ;
"RTN","IBECEA3",23,0)
 ; - process TRICARE charges
"RTN","IBECEA3",24,0)
 I IBXA=7 D CUS^IBECEA35 G ADDQ
"RTN","IBECEA3",25,0)
 ;
"RTN","IBECEA3",26,0)
 ; - display MT billing clock data
"RTN","IBECEA3",27,0)
 I IBXA=2,$P($G(^IBE(350.1,+IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
"RTN","IBECEA3",28,0)
 I IBXA=1,IBCLDAY>90 D MED^IBECEA34 G:IBY<0 ADDQ
"RTN","IBECEA3",29,0)
 I "^1^2^3^"[("^"_IBXA_"^"),IBCLDA W !!,"  ** Active Billing Clock **   # Inpt Days: ",IBCLDAY,"    ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
"RTN","IBECEA3",30,0)
 ;
"RTN","IBECEA3",31,0)
 ; - if LTC OPT (non-institutional) and CD display message of warning
"RTN","IBECEA3",32,0)
 I IBXA=8,$$CDEXMPT^IBAECU(DFN,DT) W !!,"  ** Patient is currently Catastrophically Disabled",!
"RTN","IBECEA3",33,0)
 ;
"RTN","IBECEA3",34,0)
 ; - display LTC billing clock data
"RTN","IBECEA3",35,0)
 I IBXA>7,IBXA<10 D  G:IBCLDA<1 ADDQ
"RTN","IBECEA3",36,0)
 . N IBCLZ
"RTN","IBECEA3",37,0)
 . S IBCLDA=$O(^IBA(351.81,"AE",DFN,9999999),-1)
"RTN","IBECEA3",38,0)
 . S:IBCLDA IBCLDA=$O(^IBA(351.81,"AE",DFN,IBCLDA,0))
"RTN","IBECEA3",39,0)
 . I 'IBCLDA W !!,"  ** Patient has no LTC billing clock **" Q
"RTN","IBECEA3",40,0)
 . S IBCLZ=^IBA(351.81,IBCLDA,0)
"RTN","IBECEA3",41,0)
 . W !!,"  **Last LTC Billing Clock    Start Date: ",$$FMTE^XLFDT($P(IBCLZ,"^",3)),"  Free Days Remaining: ",+$P(IBCLZ,"^",6)
"RTN","IBECEA3",42,0)
 . I $P(IBCLZ,"^",6) W !,"The patient must use his free days first." S IBCLDA=0
"RTN","IBECEA3",43,0)
 ;
"RTN","IBECEA3",44,0)
 ; - ask units for rx copay charge
"RTN","IBECEA3",45,0)
 I IBXA=5 D UNIT^IBECEAU2(0) G ADDQ:IBY<0 D  G ADDQ:IBY<0 G PROC
"RTN","IBECEA3",46,0)
 . ;
"RTN","IBECEA3",47,0)
 . ; has patient been previously tracked for cap info
"RTN","IBECEA3",48,0)
 . D TRACK^IBARXMN(DFN)
"RTN","IBECEA3",49,0)
 . ;
"RTN","IBECEA3",50,0)
 . D CTBB^IBECEAU3
"RTN","IBECEA3",51,0)
 . ;
"RTN","IBECEA3",52,0)
 . ; check if above cap
"RTN","IBECEA3",53,0)
 . I IBY'<0 D
"RTN","IBECEA3",54,0)
 .. N IBB,IBN,DIR,DIRUT,DUOUT,DTOUT,X,Y
"RTN","IBECEA3",55,0)
 .. D NEW^IBARXMC(1,IBCHG,DT,.IBB,.IBN) Q:'IBN
"RTN","IBECEA3",56,0)
 .. ;
"RTN","IBECEA3",57,0)
 .. ; display message ask to proceed
"RTN","IBECEA3",58,0)
 .. W !!,"This charge will put the patient > $",$J(IBN,0,2)," above their cap amount."
"RTN","IBECEA3",59,0)
 .. S DIR(0)="Y",DIR("A")="Okay to proceed" D ^DIR S:'Y IBY=-1
"RTN","IBECEA3",60,0)
 .. ;
"RTN","IBECEA3",61,0)
 S IBLIM=$S(IBXA=4!(IBXA=3):DT,1:$$FMADD^XLFDT(DT,-1))
"RTN","IBECEA3",62,0)
 ;
"RTN","IBECEA3",63,0)
FR ; - ask 'bill from' date
"RTN","IBECEA3",64,0)
 D FR^IBECEAU2(0) G:IBY<0 ADDQ
"RTN","IBECEA3",65,0)
 ;
"RTN","IBECEA3",66,0)
 S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR),IBGMTR=0 ;GMT Copayment Status
"RTN","IBECEA3",67,0)
 I IBGMT>0,IBXA>0,IBXA<4 W !,"The patient has GMT Copayment Status."
"RTN","IBECEA3",68,0)
 ; - check the MT billing clock
"RTN","IBECEA3",69,0)
 I IBXA'=8,IBXA'=9 D CLMSG^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",70,0)
 ;Adjust Deductible for GMT patient
"RTN","IBECEA3",71,0)
 I IBGMT>0,IBXA>0,IBXA<4,$G(IBMED) S IBMED=$$REDUCE^IBAGMT(IBMED) W !,"Medicare Deductible reduced due to GMT Copayment Status ($",$J(IBMED,"",2),")."
"RTN","IBECEA3",72,0)
 ;
"RTN","IBECEA3",73,0)
 ; - check LTC non-institutional (opt) for CD exemption
"RTN","IBECEA3",74,0)
 I IBXA=8,$$CDEXMPT^IBAECU(DFN,IBFR) W !,"Patient is LTC non-institutional exempt, Catastrophically Disabled" G ADDQ
"RTN","IBECEA3",75,0)
 ;
"RTN","IBECEA3",76,0)
 ; - check the LTC billing clock
"RTN","IBECEA3",77,0)
 I IBXA>7,IBXA<10 D  I IBY<0 W !!,"The patient has no LTC clock active for the date.",! G ADDQ
"RTN","IBECEA3",78,0)
 . N IBCLZ S IBCLZ=^IBA(351.81,IBCLDA,0)
"RTN","IBECEA3",79,0)
 . ;
"RTN","IBECEA3",80,0)
 . ; is this the clock and within the date range
"RTN","IBECEA3",81,0)
 . I IBFR'<$P(IBCLZ,"^",3),$$YR^IBAECU($P(IBCLZ,"^",3),IBFR) S IBY=-1 Q
"RTN","IBECEA3",82,0)
 . ;
"RTN","IBECEA3",83,0)
 . ; look for another clock that might fit the date
"RTN","IBECEA3",84,0)
 . I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE",DFN,IBFR+1),-1) I 'IBCLDA!($$YR^IBAECU($P($G(^IBA(351.81,+IBCLDA,0)),"^",3),IBFR)) S IBY=-1
"RTN","IBECEA3",85,0)
 ;
"RTN","IBECEA3",86,0)
 ; - calculate the MT inpt copay charge
"RTN","IBECEA3",87,0)
 I IBXA=2 S IBDT=IBFR D COPAY^IBAUTL2 G ADDQ:IBY<0 S:IBGMT>0 IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) I IBCHG+IBCLDOL<IBMED W *7,"   ($",IBCHG,"/day)" W:IBGMTR " GMT Rate"
"RTN","IBECEA3",88,0)
 ;
"RTN","IBECEA3",89,0)
 ; - find the correct clock from the 'bill from' date (ignore LTC)
"RTN","IBECEA3",90,0)
 I IBXA'=8,IBXA'=9,('IBCLDA!(IBCLDA&(IBFR<IBCLDT))) D NOCL^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",91,0)
 ;
"RTN","IBECEA3",92,0)
 ; - perform outpatient edits
"RTN","IBECEA3",93,0)
 N IBSTOPDA
"RTN","IBECEA3",94,0)
 I IBXA=4 D  G ADDQ:IBY<0,PROC
"RTN","IBECEA3",95,0)
 .   ;  for visits prior to 12/6/01 or FEE
"RTN","IBECEA3",96,0)
 .   I IBFR<3011206!($G(IBAFEE)) D OPT^IBECEA33 Q
"RTN","IBECEA3",97,0)
 .   ;  for visits on or after 12/5/01
"RTN","IBECEA3",98,0)
 .   D OPT^IBEMTSCU
"RTN","IBECEA3",99,0)
 ;
"RTN","IBECEA3",100,0)
 ; - if LTC outpatient calculate the charge
"RTN","IBECEA3",101,0)
 I IBXA=8 D  G:IBY<0 ADDQ S (IBDT,IBTO,IBEVDT)=IBFR,IBDESC=$P(^IBE(350.1,IBATYP,0),"^",8),IBUNIT=1,IBEVDA="*" D COST^IBAUTL2,CALC^IBAECO,CTBB^IBECEAU3 G @$S(IBCHG:"PROC",1:"ADDQ")
"RTN","IBECEA3",102,0)
 . ;
"RTN","IBECEA3",103,0)
 . ; is this day already a free day
"RTN","IBECEA3",104,0)
 . I $D(^IBA(351.81,IBCLDA,1,"AC",IBFR)) W !!,"This day is already marked as a Free Day." S IBY=-1
"RTN","IBECEA3",105,0)
 . ;
"RTN","IBECEA3",106,0)
 . ; have we already billed for this day
"RTN","IBECEA3",107,0)
 . I $$BFO^IBECEAU(DFN,IBFR) W !!,"This patient has already been billed for this date." S IBY=-1
"RTN","IBECEA3",108,0)
 ;
"RTN","IBECEA3",109,0)
 ; - find per diem charge and description
"RTN","IBECEA3",110,0)
 I IBXA=3 D  I 'IBCHG W !!,"Unable to determine the per diem rate.  Please check your rate table." G ADDQ
"RTN","IBECEA3",111,0)
 .N IBDT S IBDT=IBFR,IBGMTR=0 D COST^IBAUTL2
"RTN","IBECEA3",112,0)
 .I IBGMT>0 S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG)
"RTN","IBECEA3",113,0)
 .S IBDESC="" X:$D(^IBE(350.1,IBATYP,20)) ^(20)
"RTN","IBECEA3",114,0)
 ;
"RTN","IBECEA3",115,0)
 ; - calculate charge for the inpatient copay
"RTN","IBECEA3",116,0)
 I IBXA=2,IBCHG+IBCLDOL'<IBMED S IBCHG=IBMED-IBCLDOL,IBUNIT=1,IBTO=IBFR D CTBB^IBECEAU3 G EV
"RTN","IBECEA3",117,0)
 ;
"RTN","IBECEA3",118,0)
TO ; - ask 'bill to' date
"RTN","IBECEA3",119,0)
 D TO^IBECEAU2(0) G:IBY<0 ADDQ
"RTN","IBECEA3",120,0)
 ;
"RTN","IBECEA3",121,0)
 I IBXA>0,IBXA<4,IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO) W !!,"The patient's GMT Copayment status changed within the specified period!",! G ADDQ
"RTN","IBECEA3",122,0)
 ;
"RTN","IBECEA3",123,0)
 ; - calculate unit charge for LTC inpatient in IBCHG
"RTN","IBECEA3",124,0)
 I IBXA=9 S IBDT=IBFR,IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH),IBEVDT=$E(IBFR,1,5)_"01" D:IBEVDA<1  G ADDQ:IBY<0 D COST^IBAUTL2 I $E(IBFR,1,5)'=$E(IBTO,1,5) W !!,"  LTC Copayment charges cannot go from one month to another." G ADDQ
"RTN","IBECEA3",125,0)
 . D NOEV^IBECEA31 I '$G(IBDG)!(IBY<0) S IBY=-1 Q
"RTN","IBECEA3",126,0)
 . ; - build the event record
"RTN","IBECEA3",127,0)
 . N IBNHLTC S IBNHLTC=1 D ADEV^IBECEA31
"RTN","IBECEA3",128,0)
 ;
"RTN","IBECEA3",129,0)
 ;
"RTN","IBECEA3",130,0)
 ; - calculate units and total charge
"RTN","IBECEA3",131,0)
 S IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR) S:IBXA'=3!(IBFR=IBTO) IBUNIT=IBUNIT+1
"RTN","IBECEA3",132,0)
 I IBXA=1 D:IBGMT>0  D FEPR^IBECEA32 G ADDQ:IBY<0,EV
"RTN","IBECEA3",133,0)
 . S IBGMTR=1
"RTN","IBECEA3",134,0)
 . W !,"The patient has GMT Copayment Status! GMT rate must be applied.",!
"RTN","IBECEA3",135,0)
 S IBCHG=IBCHG*IBUNIT S:IBXA=2 IBCHG=$S(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
"RTN","IBECEA3",136,0)
 ;
"RTN","IBECEA3",137,0)
 ; adjust the LTC charge based on the calculated copay cap
"RTN","IBECEA3",138,0)
 I IBXA=9 D CALC^IBAECI G:IBY<1!('IBCHG) ADDQ S IBDESC="LTC INPATIENT COPAY"
"RTN","IBECEA3",139,0)
 ;
"RTN","IBECEA3",140,0)
 D CTBB^IBECEAU3 W:IBXA=3!(IBXA=9) "  (for ",IBUNIT," day",$E("s",IBUNIT>1),")" W:IBGMTR " GMT Rate"
"RTN","IBECEA3",141,0)
 ;
"RTN","IBECEA3",142,0)
EV ; - find event record, or select admission for linkage
"RTN","IBECEA3",143,0)
 I IBXA'=9 S IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
"RTN","IBECEA3",144,0)
 I IBEVDA'>0 D NOEV^IBECEA31 G ADDQ:IBY<0,PROC
"RTN","IBECEA3",145,0)
 S IBSL=$P($G(^IB(+IBEVDA,0)),"^",4)
"RTN","IBECEA3",146,0)
 W !!,"Linked charge to ",$$TYP(),"admission on ",$$DAT1^IBOUTL($P(IBEVDA,"^",2)),"  ("
"RTN","IBECEA3",147,0)
 W $S($P(IBEVDA,"^",3)=9999999:"Still admitted)",1:"Discharged on "_$$DAT1^IBOUTL($P(IBEVDA,"^",3))_$S($P(IBEVDA,"^",3)>DT:" [pseudo])",1:")"))," ..."
"RTN","IBECEA3",148,0)
 S IBEVDA=+IBEVDA
"RTN","IBECEA3",149,0)
 I '$G(IBSIBC) D SPEC^IBECEA32(0,$O(^IBE(351.2,"AD",IBEVDA,0)))
"RTN","IBECEA3",150,0)
 ;
"RTN","IBECEA3",151,0)
 ;
"RTN","IBECEA3",152,0)
PROC ; - okay to proceed?
"RTN","IBECEA3",153,0)
 D PROC^IBECEAU4("add") G:IBY<0 ADDQ
"RTN","IBECEA3",154,0)
 ;
"RTN","IBECEA3",155,0)
 ; - build the event record first if necessary
"RTN","IBECEA3",156,0)
 I $G(IBDG),IBXA'=9 D @("ADEV^IBECEA3"_$S($G(IBFEEV):4,1:1)) G:IBY<0 ADDQ
"RTN","IBECEA3",157,0)
 ;
"RTN","IBECEA3",158,0)
 ; - disposition the special inpatient billing case, if necessary
"RTN","IBECEA3",159,0)
 I $G(IBSIBC) D CEA^IBAMTI1(IBSIBC,IBEVDA)
"RTN","IBECEA3",160,0)
 ;
"RTN","IBECEA3",161,0)
 ; - generate entry in file #354.71 and #350
"RTN","IBECEA3",162,0)
 I IBXA=5 W !!,"Building the new transaction...  " S IBAM=$$ADD^IBARXMN(DFN,"^^"_DT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE) G:IBAM<0 ADDQ
"RTN","IBECEA3",163,0)
 D ADD^IBECEAU3 G:IBY<0 ADDQ W "done."
"RTN","IBECEA3",164,0)
 ;
"RTN","IBECEA3",165,0)
 ; - pass the charge off to AR on-line
"RTN","IBECEA3",166,0)
 W !,"Passing the charge directly to Accounts Receivable... "
"RTN","IBECEA3",167,0)
 D PASSCH^IBECEA22 W:IBY>0 "done." G:IBY<0 ADDQ
"RTN","IBECEA3",168,0)
 ;
"RTN","IBECEA3",169,0)
 ; - review the special inpatient billing case
"RTN","IBECEA3",170,0)
 I $G(IBSIBC1) D CHK^IBAMTI1(IBSIBC1,IBEVDA)
"RTN","IBECEA3",171,0)
 ;
"RTN","IBECEA3",172,0)
 ; - handle updating of clock
"RTN","IBECEA3",173,0)
 I IBXA'=8,IBXA'=9 D CLUPD^IBECEA32
"RTN","IBECEA3",174,0)
 ;
"RTN","IBECEA3",175,0)
ADDQ ; - display error, rebuild list, and quit
"RTN","IBECEA3",176,0)
 D ERR^IBECEAU4:IBY<0,PAUSE^IBECEAU S VALMBCK="R"
"RTN","IBECEA3",177,0)
 I IBCOMMIT S IBBG=VALMBG W !,"Rebuilding list of charges..." D ARRAY^IBECEA0 S VALMBG=IBBG
"RTN","IBECEA3",178,0)
 K IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBATYP,IBDG,IBSEQNO,IBXA,IBNH,IBBS,IBLIM,IBFR,IBTO,IBRTED,IBSIBC,IBSIBC1,IBBG,IBFEEV,IBAM
"RTN","IBECEA3",179,0)
 K IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR,IBADJMED
"RTN","IBECEA3",180,0)
ADDQ1 K IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL,IBLTCST
"RTN","IBECEA3",181,0)
 Q
"RTN","IBECEA3",182,0)
 ;
"RTN","IBECEA3",183,0)
 ;
"RTN","IBECEA3",184,0)
TYP() ; Return descriptive admission type.
"RTN","IBECEA3",185,0)
 N X S X=""
"RTN","IBECEA3",186,0)
 I IBNH'=2 G TYPQ
"RTN","IBECEA3",187,0)
 I $G(IBADJMED) S X=$S(IBADJMED=1:"C",1:"H")
"RTN","IBECEA3",188,0)
 E  S X=$S($P($G(^IBE(350.1,+IBATYP,0)),"^")["NHCU":"C",1:"H")
"RTN","IBECEA3",189,0)
 S X=$S(X="C":"CNH ",1:"Contract Hospital ")
"RTN","IBECEA3",190,0)
TYPQ Q X
"VER")
8.0^22.0
**END**
**END**