KIDS Distribution saved on Jul 02, 2007@15:47:12 ENROLLMENT VISTA CHANGES RELEASE 1 (7/2/07) **KIDS**:DG*5.3*653^IVM*2.0*105^ **INSTALL NAME** DG*5.3*653 "BLD",7085,0) DG*5.3*653^REGISTRATION^0^3070702^y "BLD",7085,4,0) ^9.64PA^408.13^4 "BLD",7085,4,2,0) 2 "BLD",7085,4,2,2,0) ^9.641^2.141^3 "BLD",7085,4,2,2,2,0) PATIENT (File-top level) "BLD",7085,4,2,2,2,1,0) ^9.6411^.118^31 "BLD",7085,4,2,2,2,1,.09,0) SOCIAL SECURITY NUMBER "BLD",7085,4,2,2,2,1,.0906,0) PSEUDO SSN REASON "BLD",7085,4,2,2,2,1,.118,0) ADDRESS CHANGE DT/TM "BLD",7085,4,2,2,2,1,.121,0) BAD ADDRESS INDICATOR "BLD",7085,4,2,2,2,1,.1311,0) CELLULAR NUMBER CHANGE SOURCE "BLD",7085,4,2,2,2,1,.13111,0) CELLULAR NUMBER CHANGE SITE "BLD",7085,4,2,2,2,1,.1312,0) PAGER NUMBER CHANGE DT/TM "BLD",7085,4,2,2,2,1,.1313,0) PAGER NUMBER CHANGE SOURCE "BLD",7085,4,2,2,2,1,.1314,0) PAGER NUMBER CHANGE SITE "BLD",7085,4,2,2,2,1,.133,0) EMAIL ADDRESS "BLD",7085,4,2,2,2,1,.134,0) PHONE NUMBER [CELLULAR] "BLD",7085,4,2,2,2,1,.135,0) PAGER NUMBER "BLD",7085,4,2,2,2,1,.136,0) EMAIL ADDRESS CHANGE DT/TM "BLD",7085,4,2,2,2,1,.137,0) EMAIL ADDRESS CHANGE SOURCE "BLD",7085,4,2,2,2,1,.138,0) EMAIL ADDRESS CHANGE SITE "BLD",7085,4,2,2,2,1,.139,0) CELLULAR NUMBER CHANGE DT/TM "BLD",7085,4,2,2,2,1,.14105,0) CONFIDENTIAL ADDRESS ACTIVE? "BLD",7085,4,2,2,2,1,.1411,0) CONFIDENTIAL STREET [LINE 1] "BLD",7085,4,2,2,2,1,.14111,0) CONFIDENTIAL ADDRESS COUNTY "BLD",7085,4,2,2,2,1,.14112,0) CONFIDENTIAL ADDR CHANGE DT/TM "BLD",7085,4,2,2,2,1,.1412,0) CONFIDENTIAL STREET [LINE 2] "BLD",7085,4,2,2,2,1,.1413,0) CONFIDENTIAL STREET [LINE 3] "BLD",7085,4,2,2,2,1,.1414,0) CONFIDENTIAL ADDRESS CITY "BLD",7085,4,2,2,2,1,.1415,0) CONFIDENTIAL ADDRESS STATE "BLD",7085,4,2,2,2,1,.1416,0) CONFIDENTIAL ADDRESS ZIP CODE "BLD",7085,4,2,2,2,1,.1417,0) CONFIDENTIAL START DATE "BLD",7085,4,2,2,2,1,.1418,0) CONFIDENTIAL END DATE "BLD",7085,4,2,2,2,1,.32115,0) PROJ 112/SHAD "BLD",7085,4,2,2,2,1,.3951,0) DATE VETERAN REQUESTED CD EVAL "BLD",7085,4,2,2,2,1,.3952,0) DATE FACILITY INITIATED REVIEW "BLD",7085,4,2,2,2,1,.3953,0) DATE VETERAN WAS NOTIFIED "BLD",7085,4,2,2,2.141,0) CONFIDENTIAL ADDRESS CATEGORY (sub-file) "BLD",7085,4,2,2,2.141,1,0) ^9.6411^1^2 "BLD",7085,4,2,2,2.141,1,.01,0) CONFIDENTIAL ADDRESS CATEGORY "BLD",7085,4,2,2,2.141,1,1,0) CONFIDENTIAL CATEGORY ACTIVE "BLD",7085,4,2,2,2.399,0) CD HISTORY DATE (sub-file) "BLD",7085,4,2,2,2.399,1,0) ^9.6411^.3953^3 "BLD",7085,4,2,2,2.399,1,.3951,0) DATE VETERAN REQUESTED CD EVAL "BLD",7085,4,2,2,2.399,1,.3952,0) DATE FACILITY INITIATED REVIEW "BLD",7085,4,2,2,2.399,1,.3953,0) DATE VETERAN WAS NOTIFIED "BLD",7085,4,2,222) y^y^p^^^^n^^n "BLD",7085,4,2,224) "BLD",7085,4,27.11,0) 27.11 "BLD",7085,4,27.11,2,0) ^9.641^27.11^1 "BLD",7085,4,27.11,2,27.11,0) PATIENT ENROLLMENT (File-top level) "BLD",7085,4,27.11,2,27.11,1,0) ^9.6411^50.19^1 "BLD",7085,4,27.11,2,27.11,1,50.19,0) PROJ 112/SHAD "BLD",7085,4,27.11,222) y^y^p^^^^n^^n "BLD",7085,4,27.11,224) "BLD",7085,4,38.6,0) 38.6 "BLD",7085,4,38.6,2,0) ^9.641^38.6^1 "BLD",7085,4,38.6,2,38.6,0) INCONSISTENT DATA ELEMENTS (File-top level) "BLD",7085,4,38.6,2,38.6,1,0) ^9.6411^6^1 "BLD",7085,4,38.6,2,38.6,1,6,0) USE FOR Z07 CHECK "BLD",7085,4,38.6,222) y^y^p^^^^n^^n "BLD",7085,4,38.6,224) "BLD",7085,4,408.13,0) 408.13 "BLD",7085,4,408.13,2,0) ^9.641^408.13^1 "BLD",7085,4,408.13,2,408.13,0) INCOME PERSON (File-top level) "BLD",7085,4,408.13,2,408.13,1,0) ^9.6411^.1^2 "BLD",7085,4,408.13,2,408.13,1,.09,0) SOCIAL SECURITY NUMBER "BLD",7085,4,408.13,2,408.13,1,.1,0) PSEUDO SSN REASON "BLD",7085,4,408.13,222) y^n^p^^^^n^^n "BLD",7085,4,408.13,224) "BLD",7085,4,"APDD",2,2) "BLD",7085,4,"APDD",2,2,.09) "BLD",7085,4,"APDD",2,2,.0906) "BLD",7085,4,"APDD",2,2,.118) "BLD",7085,4,"APDD",2,2,.121) "BLD",7085,4,"APDD",2,2,.1311) "BLD",7085,4,"APDD",2,2,.13111) "BLD",7085,4,"APDD",2,2,.1312) "BLD",7085,4,"APDD",2,2,.1313) "BLD",7085,4,"APDD",2,2,.1314) "BLD",7085,4,"APDD",2,2,.133) "BLD",7085,4,"APDD",2,2,.134) "BLD",7085,4,"APDD",2,2,.135) "BLD",7085,4,"APDD",2,2,.136) "BLD",7085,4,"APDD",2,2,.137) "BLD",7085,4,"APDD",2,2,.138) "BLD",7085,4,"APDD",2,2,.139) "BLD",7085,4,"APDD",2,2,.14105) "BLD",7085,4,"APDD",2,2,.1411) "BLD",7085,4,"APDD",2,2,.14111) "BLD",7085,4,"APDD",2,2,.14112) "BLD",7085,4,"APDD",2,2,.1412) "BLD",7085,4,"APDD",2,2,.1413) "BLD",7085,4,"APDD",2,2,.1414) "BLD",7085,4,"APDD",2,2,.1415) "BLD",7085,4,"APDD",2,2,.1416) "BLD",7085,4,"APDD",2,2,.1417) "BLD",7085,4,"APDD",2,2,.1418) "BLD",7085,4,"APDD",2,2,.32115) "BLD",7085,4,"APDD",2,2,.3951) "BLD",7085,4,"APDD",2,2,.3952) "BLD",7085,4,"APDD",2,2,.3953) "BLD",7085,4,"APDD",2,2.141) "BLD",7085,4,"APDD",2,2.141,.01) "BLD",7085,4,"APDD",2,2.141,1) "BLD",7085,4,"APDD",2,2.399) "BLD",7085,4,"APDD",2,2.399,.3951) "BLD",7085,4,"APDD",2,2.399,.3952) "BLD",7085,4,"APDD",2,2.399,.3953) "BLD",7085,4,"APDD",27.11,27.11) "BLD",7085,4,"APDD",27.11,27.11,50.19) "BLD",7085,4,"APDD",38.6,38.6) "BLD",7085,4,"APDD",38.6,38.6,6) "BLD",7085,4,"APDD",408.13,408.13) "BLD",7085,4,"APDD",408.13,408.13,.09) "BLD",7085,4,"APDD",408.13,408.13,.1) "BLD",7085,4,"B",2,2) "BLD",7085,4,"B",27.11,27.11) "BLD",7085,4,"B",38.6,38.6) "BLD",7085,4,"B",408.13,408.13) "BLD",7085,6.3) 2 "BLD",7085,"ABNS",0) ^9.66A^^ "BLD",7085,"ABPKG") n^n "BLD",7085,"INI") EN^DG53653P "BLD",7085,"INID") ^n^n "BLD",7085,"INIT") EN^DG53653A "BLD",7085,"KRN",0) ^9.67PA^8989.52^19 "BLD",7085,"KRN",.4,0) .4 "BLD",7085,"KRN",.4,"NM",0) ^9.68A^^ "BLD",7085,"KRN",.401,0) .401 "BLD",7085,"KRN",.401,"NM",0) ^9.68A^^ "BLD",7085,"KRN",.402,0) .402 "BLD",7085,"KRN",.402,"NM",0) ^9.68A^^0 "BLD",7085,"KRN",.403,0) .403 "BLD",7085,"KRN",.403,"NM",0) ^9.68A^^ "BLD",7085,"KRN",.5,0) .5 "BLD",7085,"KRN",.5,"NM",0) ^9.68A^^ "BLD",7085,"KRN",.84,0) .84 "BLD",7085,"KRN",.84,"NM",0) ^9.68A^^ "BLD",7085,"KRN",3.6,0) 3.6 "BLD",7085,"KRN",3.6,"NM",0) ^9.68A^^ "BLD",7085,"KRN",3.8,0) 3.8 "BLD",7085,"KRN",3.8,"NM",0) ^9.68A^^ "BLD",7085,"KRN",9.2,0) 9.2 "BLD",7085,"KRN",9.2,"NM",0) ^9.68A^^ "BLD",7085,"KRN",9.8,0) 9.8 "BLD",7085,"KRN",9.8,"NM",0) ^9.68A^84^61 "BLD",7085,"KRN",9.8,"NM",1,0) VAFHLZCT^^0^B8791571 "BLD",7085,"KRN",9.8,"NM",2,0) VAFHLZDP^^0^B5724563 "BLD",7085,"KRN",9.8,"NM",3,0) VAFHLZE1^^0^B25671247 "BLD",7085,"KRN",9.8,"NM",4,0) VAFHLZIR^^0^B13611124 "BLD",7085,"KRN",9.8,"NM",6,0) VAFHLZSP^^0^B4401981 "BLD",7085,"KRN",9.8,"NM",7,0) DGENA^^0^B19072068 "BLD",7085,"KRN",9.8,"NM",8,0) DGENA1A^^0^B13695008 "BLD",7085,"KRN",9.8,"NM",9,0) DGENELA^^0^B26371073 "BLD",7085,"KRN",9.8,"NM",10,0) DGENL1^^0^B65028374 "BLD",7085,"KRN",9.8,"NM",11,0) DGENU^^0^B38090905 "BLD",7085,"KRN",9.8,"NM",12,0) DGENELA4^^0^B44980796 "BLD",7085,"KRN",9.8,"NM",21,0) DGENELA1^^0^B76546694 "BLD",7085,"KRN",9.8,"NM",23,0) DGENPTA1^^0^B18612546 "BLD",7085,"KRN",9.8,"NM",25,0) DGENUPL1^^0^B34423336 "BLD",7085,"KRN",9.8,"NM",26,0) DGENUPL2^^0^B72501035 "BLD",7085,"KRN",9.8,"NM",27,0) DGENUPLA^^0^B55510983 "BLD",7085,"KRN",9.8,"NM",31,0) DGRP7^^0^B16119751 "BLD",7085,"KRN",9.8,"NM",33,0) DGRPLE^^0^B20956933 "BLD",7085,"KRN",9.8,"NM",37,0) DGUTL3^^0^B9126169 "BLD",7085,"KRN",9.8,"NM",40,0) DGENUPL7^^0^B29968061 "BLD",7085,"KRN",9.8,"NM",41,0) DGENSEC^^0^B30651011 "BLD",7085,"KRN",9.8,"NM",42,0) DGENCDA^^0^B8468771 "BLD",7085,"KRN",9.8,"NM",43,0) VAFHLZCD^^0^B33018689 "BLD",7085,"KRN",9.8,"NM",46,0) VAFHLZTA^^0^B6091122 "BLD",7085,"KRN",9.8,"NM",47,0) DG53653P^^0^B3450208 "BLD",7085,"KRN",9.8,"NM",48,0) DGENCDA1^^0^B47052771 "BLD",7085,"KRN",9.8,"NM",49,0) DGENCDA2^^0^B16601492 "BLD",7085,"KRN",9.8,"NM",50,0) DGPZ07C^^0^B1691045 "BLD",7085,"KRN",9.8,"NM",51,0) DGRPC^^0^B24943025 "BLD",7085,"KRN",9.8,"NM",52,0) DGRPCP^^0^B10965667 "BLD",7085,"KRN",9.8,"NM",53,0) DGRPCP1^^0^B22768467 "BLD",7085,"KRN",9.8,"NM",54,0) DGRPCF^^0^B21529174 "BLD",7085,"KRN",9.8,"NM",56,0) DG53653U^^0^B6864665 "BLD",7085,"KRN",9.8,"NM",57,0) DG53653W^^0^B12933770 "BLD",7085,"KRN",9.8,"NM",58,0) DG53653X^^0^B28622000 "BLD",7085,"KRN",9.8,"NM",59,0) DG53653V^^0^B12198923 "BLD",7085,"KRN",9.8,"NM",60,0) DGMTU1^^0^B4468630 "BLD",7085,"KRN",9.8,"NM",61,0) DGDEP0^^0^B12397379 "BLD",7085,"KRN",9.8,"NM",62,0) DGDEP1^^0^B26014891 "BLD",7085,"KRN",9.8,"NM",63,0) DGDEP3^^0^B24479543 "BLD",7085,"KRN",9.8,"NM",64,0) DGMTDD1^^0^B10762436 "BLD",7085,"KRN",9.8,"NM",65,0) DGPSEUDO^^0^B49360032 "BLD",7085,"KRN",9.8,"NM",66,0) DGRPECE^^0^B62016325 "BLD",7085,"KRN",9.8,"NM",67,0) DGRPEIS^^0^B41614327 "BLD",7085,"KRN",9.8,"NM",68,0) DGRPEIS2^^0^B15374909 "BLD",7085,"KRN",9.8,"NM",69,0) DGRPEIS3^^0^B78209595 "BLD",7085,"KRN",9.8,"NM",70,0) DGRP1^^0^B28795198 "BLD",7085,"KRN",9.8,"NM",71,0) DG53653Y^^0^B58594943 "BLD",7085,"KRN",9.8,"NM",72,0) DG53653A^^0^B3589425 "BLD",7085,"KRN",9.8,"NM",73,0) DGRPCU^^0^B8938902 "BLD",7085,"KRN",9.8,"NM",74,0) DGRPCR^^0^B15602283 "BLD",7085,"KRN",9.8,"NM",75,0) DPTLK2^^0^B32261378 "BLD",7085,"KRN",9.8,"NM",76,0) DGPSEU2^^0^B34825670 "BLD",7085,"KRN",9.8,"NM",77,0) DGRPCTRG^^0^B902330 "BLD",7085,"KRN",9.8,"NM",78,0) DGDDDTTM^^0^B4161602 "BLD",7085,"KRN",9.8,"NM",79,0) DGRPCE^^0^B31050795 "BLD",7085,"KRN",9.8,"NM",80,0) DGPZ07P^^0^B8264367 "BLD",7085,"KRN",9.8,"NM",81,0) VAFHLZPD^^0^B55095720 "BLD",7085,"KRN",9.8,"NM",82,0) DGENUPL3^^0^B39755070 "BLD",7085,"KRN",9.8,"NM",83,0) DGCLEAR^^0^B1141198 "BLD",7085,"KRN",9.8,"NM",84,0) VAFCTR^^0^B1588263 "BLD",7085,"KRN",9.8,"NM","B","DG53653A",72) "BLD",7085,"KRN",9.8,"NM","B","DG53653P",47) "BLD",7085,"KRN",9.8,"NM","B","DG53653U",56) "BLD",7085,"KRN",9.8,"NM","B","DG53653V",59) "BLD",7085,"KRN",9.8,"NM","B","DG53653W",57) "BLD",7085,"KRN",9.8,"NM","B","DG53653X",58) "BLD",7085,"KRN",9.8,"NM","B","DG53653Y",71) "BLD",7085,"KRN",9.8,"NM","B","DGCLEAR",83) "BLD",7085,"KRN",9.8,"NM","B","DGDDDTTM",78) "BLD",7085,"KRN",9.8,"NM","B","DGDEP0",61) "BLD",7085,"KRN",9.8,"NM","B","DGDEP1",62) "BLD",7085,"KRN",9.8,"NM","B","DGDEP3",63) "BLD",7085,"KRN",9.8,"NM","B","DGENA",7) "BLD",7085,"KRN",9.8,"NM","B","DGENA1A",8) "BLD",7085,"KRN",9.8,"NM","B","DGENCDA",42) "BLD",7085,"KRN",9.8,"NM","B","DGENCDA1",48) "BLD",7085,"KRN",9.8,"NM","B","DGENCDA2",49) "BLD",7085,"KRN",9.8,"NM","B","DGENELA",9) "BLD",7085,"KRN",9.8,"NM","B","DGENELA1",21) "BLD",7085,"KRN",9.8,"NM","B","DGENELA4",12) "BLD",7085,"KRN",9.8,"NM","B","DGENL1",10) "BLD",7085,"KRN",9.8,"NM","B","DGENPTA1",23) "BLD",7085,"KRN",9.8,"NM","B","DGENSEC",41) "BLD",7085,"KRN",9.8,"NM","B","DGENU",11) "BLD",7085,"KRN",9.8,"NM","B","DGENUPL1",25) "BLD",7085,"KRN",9.8,"NM","B","DGENUPL2",26) "BLD",7085,"KRN",9.8,"NM","B","DGENUPL3",82) "BLD",7085,"KRN",9.8,"NM","B","DGENUPL7",40) "BLD",7085,"KRN",9.8,"NM","B","DGENUPLA",27) "BLD",7085,"KRN",9.8,"NM","B","DGMTDD1",64) "BLD",7085,"KRN",9.8,"NM","B","DGMTU1",60) "BLD",7085,"KRN",9.8,"NM","B","DGPSEU2",76) "BLD",7085,"KRN",9.8,"NM","B","DGPSEUDO",65) "BLD",7085,"KRN",9.8,"NM","B","DGPZ07C",50) "BLD",7085,"KRN",9.8,"NM","B","DGPZ07P",80) "BLD",7085,"KRN",9.8,"NM","B","DGRP1",70) "BLD",7085,"KRN",9.8,"NM","B","DGRP7",31) "BLD",7085,"KRN",9.8,"NM","B","DGRPC",51) "BLD",7085,"KRN",9.8,"NM","B","DGRPCE",79) "BLD",7085,"KRN",9.8,"NM","B","DGRPCF",54) "BLD",7085,"KRN",9.8,"NM","B","DGRPCP",52) "BLD",7085,"KRN",9.8,"NM","B","DGRPCP1",53) "BLD",7085,"KRN",9.8,"NM","B","DGRPCR",74) "BLD",7085,"KRN",9.8,"NM","B","DGRPCTRG",77) "BLD",7085,"KRN",9.8,"NM","B","DGRPCU",73) "BLD",7085,"KRN",9.8,"NM","B","DGRPECE",66) "BLD",7085,"KRN",9.8,"NM","B","DGRPEIS",67) "BLD",7085,"KRN",9.8,"NM","B","DGRPEIS2",68) "BLD",7085,"KRN",9.8,"NM","B","DGRPEIS3",69) "BLD",7085,"KRN",9.8,"NM","B","DGRPLE",33) "BLD",7085,"KRN",9.8,"NM","B","DGUTL3",37) "BLD",7085,"KRN",9.8,"NM","B","DPTLK2",75) "BLD",7085,"KRN",9.8,"NM","B","VAFCTR",84) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZCD",43) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZCT",1) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZDP",2) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZE1",3) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZIR",4) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZPD",81) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZSP",6) "BLD",7085,"KRN",9.8,"NM","B","VAFHLZTA",46) "BLD",7085,"KRN",19,0) 19 "BLD",7085,"KRN",19,"NM",0) ^9.68A^7^6 "BLD",7085,"KRN",19,"NM",2,0) DG PATIENT PSEUDO SSN REPORT^^0 "BLD",7085,"KRN",19,"NM",3,0) DG DEPENDENT PSEUDO SSN REPORT^^0 "BLD",7085,"KRN",19,"NM",4,0) DG REGISTRATION MENU^^2 "BLD",7085,"KRN",19,"NM",5,0) DG MEANS TEST USER MENU^^2 "BLD",7085,"KRN",19,"NM",6,0) DG Z07 CONSISTENCY CHECK^^0 "BLD",7085,"KRN",19,"NM",7,0) DG OUTPUTS MENU^^2 "BLD",7085,"KRN",19,"NM","B","DG DEPENDENT PSEUDO SSN REPORT",3) "BLD",7085,"KRN",19,"NM","B","DG MEANS TEST USER MENU",5) "BLD",7085,"KRN",19,"NM","B","DG OUTPUTS MENU",7) "BLD",7085,"KRN",19,"NM","B","DG PATIENT PSEUDO SSN REPORT",2) "BLD",7085,"KRN",19,"NM","B","DG REGISTRATION MENU",4) "BLD",7085,"KRN",19,"NM","B","DG Z07 CONSISTENCY CHECK",6) "BLD",7085,"KRN",19.1,0) 19.1 "BLD",7085,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",7085,"KRN",101,0) 101 "BLD",7085,"KRN",409.61,0) 409.61 "BLD",7085,"KRN",771,0) 771 "BLD",7085,"KRN",870,0) 870 "BLD",7085,"KRN",8989.51,0) 8989.51 "BLD",7085,"KRN",8989.52,0) 8989.52 "BLD",7085,"KRN",8994,0) 8994 "BLD",7085,"KRN","B",.4,.4) "BLD",7085,"KRN","B",.401,.401) "BLD",7085,"KRN","B",.402,.402) "BLD",7085,"KRN","B",.403,.403) "BLD",7085,"KRN","B",.5,.5) "BLD",7085,"KRN","B",.84,.84) "BLD",7085,"KRN","B",3.6,3.6) "BLD",7085,"KRN","B",3.8,3.8) "BLD",7085,"KRN","B",9.2,9.2) "BLD",7085,"KRN","B",9.8,9.8) "BLD",7085,"KRN","B",19,19) "BLD",7085,"KRN","B",19.1,19.1) "BLD",7085,"KRN","B",101,101) "BLD",7085,"KRN","B",409.61,409.61) "BLD",7085,"KRN","B",771,771) "BLD",7085,"KRN","B",870,870) "BLD",7085,"KRN","B",8989.51,8989.51) "BLD",7085,"KRN","B",8989.52,8989.52) "BLD",7085,"KRN","B",8994,8994) "BLD",7085,"QUES",0) ^9.62^^ "BLD",7085,"REQB",0) ^9.611^57^26 "BLD",7085,"REQB",10,0) DG*5.3*528^2 "BLD",7085,"REQB",19,0) DG*5.3*451^2 "BLD",7085,"REQB",20,0) DG*5.3*466^2 "BLD",7085,"REQB",23,0) DG*5.3*665^2 "BLD",7085,"REQB",24,0) DG*5.3*673^2 "BLD",7085,"REQB",25,0) DG*5.3*624^2 "BLD",7085,"REQB",31,0) DG*5.3*641^2 "BLD",7085,"REQB",33,0) DG*5.3*702^2 "BLD",7085,"REQB",34,0) DG*5.3*689^2 "BLD",7085,"REQB",35,0) DG*5.3*700^2 "BLD",7085,"REQB",36,0) DG*5.3*672^2 "BLD",7085,"REQB",37,0) DG*5.3*677^2 "BLD",7085,"REQB",38,0) DG*5.3*656^2 "BLD",7085,"REQB",39,0) DG*5.3*583^2 "BLD",7085,"REQB",40,0) DG*5.3*707^2 "BLD",7085,"REQB",47,0) DG*5.3*659^2 "BLD",7085,"REQB",48,0) DG*5.3*716^2 "BLD",7085,"REQB",49,0) DG*5.3*720^2 "BLD",7085,"REQB",50,0) DG*5.3*746^2 "BLD",7085,"REQB",51,0) DG*5.3*648^2 "BLD",7085,"REQB",52,0) DG*5.3*401^2 "BLD",7085,"REQB",53,0) DG*5.3*166^2 "BLD",7085,"REQB",54,0) DG*5.3*250^2 "BLD",7085,"REQB",55,0) DG*5.3*431^2 "BLD",7085,"REQB",56,0) DG*5.3*506^2 "BLD",7085,"REQB",57,0) DG*5.3*387^2 "BLD",7085,"REQB","B","DG*5.3*166",53) "BLD",7085,"REQB","B","DG*5.3*250",54) "BLD",7085,"REQB","B","DG*5.3*387",57) "BLD",7085,"REQB","B","DG*5.3*401",52) "BLD",7085,"REQB","B","DG*5.3*431",55) "BLD",7085,"REQB","B","DG*5.3*451",19) "BLD",7085,"REQB","B","DG*5.3*466",20) "BLD",7085,"REQB","B","DG*5.3*506",56) "BLD",7085,"REQB","B","DG*5.3*528",10) "BLD",7085,"REQB","B","DG*5.3*583",39) "BLD",7085,"REQB","B","DG*5.3*624",25) "BLD",7085,"REQB","B","DG*5.3*641",31) "BLD",7085,"REQB","B","DG*5.3*648",51) "BLD",7085,"REQB","B","DG*5.3*656",38) "BLD",7085,"REQB","B","DG*5.3*659",47) "BLD",7085,"REQB","B","DG*5.3*665",23) "BLD",7085,"REQB","B","DG*5.3*672",36) "BLD",7085,"REQB","B","DG*5.3*673",24) "BLD",7085,"REQB","B","DG*5.3*677",37) "BLD",7085,"REQB","B","DG*5.3*689",34) "BLD",7085,"REQB","B","DG*5.3*700",35) "BLD",7085,"REQB","B","DG*5.3*702",33) "BLD",7085,"REQB","B","DG*5.3*707",40) "BLD",7085,"REQB","B","DG*5.3*716",48) "BLD",7085,"REQB","B","DG*5.3*720",49) "BLD",7085,"REQB","B","DG*5.3*746",50) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^y^p^^^^n^^n "FIA",2,0,10) "FIA",2,0,11) "FIA",2,0,"RLRO") "FIA",2,0,"VR") 5.3^DG "FIA",2,2) 1 "FIA",2,2,.09) "FIA",2,2,.0906) "FIA",2,2,.118) "FIA",2,2,.121) "FIA",2,2,.1311) "FIA",2,2,.13111) "FIA",2,2,.1312) "FIA",2,2,.1313) "FIA",2,2,.1314) "FIA",2,2,.133) "FIA",2,2,.134) "FIA",2,2,.135) "FIA",2,2,.136) "FIA",2,2,.137) "FIA",2,2,.138) "FIA",2,2,.139) "FIA",2,2,.141) "FIA",2,2,.14105) "FIA",2,2,.1411) "FIA",2,2,.14111) "FIA",2,2,.14112) "FIA",2,2,.1412) "FIA",2,2,.1413) "FIA",2,2,.1414) "FIA",2,2,.1415) "FIA",2,2,.1416) "FIA",2,2,.1417) "FIA",2,2,.1418) "FIA",2,2,.32115) "FIA",2,2,.3951) "FIA",2,2,.3952) "FIA",2,2,.3953) "FIA",2,2.141) 1 "FIA",2,2.141,.01) "FIA",2,2.141,1) "FIA",2,2.399) 1 "FIA",2,2.399,.3951) "FIA",2,2.399,.3952) "FIA",2,2.399,.3953) "FIA",27.11) PATIENT ENROLLMENT "FIA",27.11,0) ^DGEN(27.11, "FIA",27.11,0,0) 27.11OID "FIA",27.11,0,1) y^y^p^^^^n^^n "FIA",27.11,0,10) "FIA",27.11,0,11) "FIA",27.11,0,"RLRO") "FIA",27.11,0,"VR") 5.3^DG "FIA",27.11,27.11) 1 "FIA",27.11,27.11,50.19) "FIA",38.6) INCONSISTENT DATA ELEMENTS "FIA",38.6,0) ^DGIN(38.6, "FIA",38.6,0,0) 38.6s "FIA",38.6,0,1) y^y^p^^^^n^^n "FIA",38.6,0,10) "FIA",38.6,0,11) "FIA",38.6,0,"RLRO") "FIA",38.6,0,"VR") 5.3^DG "FIA",38.6,38.6) 1 "FIA",38.6,38.6,6) "FIA",408.13) INCOME PERSON "FIA",408.13,0) ^DGPR(408.13, "FIA",408.13,0,0) 408.13 "FIA",408.13,0,1) y^n^p^^^^n^^n "FIA",408.13,0,10) "FIA",408.13,0,11) "FIA",408.13,0,"RLRO") "FIA",408.13,0,"VR") 5.3^DG "FIA",408.13,408.13) 1 "FIA",408.13,408.13,.09) "FIA",408.13,408.13,.1) "INI") EN^DG53653P "INIT") EN^DG53653A "IX",2,2,"ADGFMD09",0) 2^ADGFMD09^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD09",.1,0) ^^5^5^3021118 "IX",2,2,"ADGFMD09",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD09",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD09",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD09",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD09",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD09",1) D FC^DGFCPROT(.DA,2,.09,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD09",2) D FC^DGFCPROT(.DA,2,.09,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD09",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD09",11.1,1,0) 1^F^2^.09^^^F "IX",2,2,"ADGFMD1411",0) 2^ADGFMD1411^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1411",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1411",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1411",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1411",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1411",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1411",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1411",1) D FC^DGFCPROT(.DA,2,.1411,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1411",2) D FC^DGFCPROT(.DA,2,.1411,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1411",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1411",11.1,1,0) 1^F^2^.1411^^^F "IX",2,2,"ADGFMD1412",0) 2^ADGFMD1412^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1412",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1412",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1412",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1412",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1412",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1412",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1412",1) D FC^DGFCPROT(.DA,2,.1412,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1412",2) D FC^DGFCPROT(.DA,2,.1412,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1412",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1412",11.1,1,0) 1^F^2^.1412^^^F "IX",2,2,"ADGFMD1413",0) 2^ADGFMD1413^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1413",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1413",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1413",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1413",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1413",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1413",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1413",1) D FC^DGFCPROT(.DA,2,.1413,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1413",2) D FC^DGFCPROT(.DA,2,.1413,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1413",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1413",11.1,1,0) 1^F^2^.1413^^^F "IX",2,2,"ADGFMD1414",0) 2^ADGFMD1414^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1414",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1414",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1414",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1414",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1414",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1414",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1414",1) D FC^DGFCPROT(.DA,2,.1414,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1414",2) D FC^DGFCPROT(.DA,2,.1414,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1414",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1414",11.1,1,0) 1^F^2^.1414^^^F "IX",2,2,"ADGFMD1415",0) 2^ADGFMD1415^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1415",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1415",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1415",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1415",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1415",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1415",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1415",1) D FC^DGFCPROT(.DA,2,.1415,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1415",2) D FC^DGFCPROT(.DA,2,.1415,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1415",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1415",11.1,1,0) 1^F^2^.1415^^^F "IX",2,2,"ADGFMD1416",0) 2^ADGFMD1416^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1416",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1416",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1416",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1416",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1416",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1416",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1416",1) D FC^DGFCPROT(.DA,2,.1416,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1416",2) D FC^DGFCPROT(.DA,2,.1416,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1416",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1416",11.1,1,0) 1^F^2^.1416^^^F "IX",2,2,"ADGFMD1417",0) 2^ADGFMD1417^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1417",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1417",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1417",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1417",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1417",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1417",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1417",1) D FC^DGFCPROT(.DA,2,.1417,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1417",2) D FC^DGFCPROT(.DA,2,.1417,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1417",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1417",11.1,1,0) 1^F^2^.1417^^^F "IX",2,2,"ADGFMD1418",0) 2^ADGFMD1418^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD1418",.1,0) ^^5^5^3030702 "IX",2,2,"ADGFMD1418",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"ADGFMD1418",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"ADGFMD1418",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"ADGFMD1418",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"ADGFMD1418",.1,5,0) the information available at the time of the event. "IX",2,2,"ADGFMD1418",1) D FC^DGFCPROT(.DA,2,.1418,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1418",2) D FC^DGFCPROT(.DA,2,.1418,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD1418",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD1418",11.1,1,0) 1^F^2^.1418^^^F "IX",2,2,"ADTTM2",0) 2^ADTTM2^CONFIDENTIAL ADDRESS Cross-Reference^MU^^R^^I^2^^^^^A "IX",2,2,"ADTTM2",.1,0) ^^2^2^3060501^ "IX",2,2,"ADTTM2",.1,1,0) This cross-reference will update the CONFIDENTIAL ADDR CHANGE DT/TM field "IX",2,2,"ADTTM2",.1,2,0) when the confidential address data changes for a patient. "IX",2,2,"ADTTM2",1) D CONF^DGDDDTTM "IX",2,2,"ADTTM2",2) D CONF^DGDDDTTM "IX",2,2,"ADTTM2",11.1,0) ^.114IA^11^10 "IX",2,2,"ADTTM2",11.1,1,0) 1^F^2^.1411^^^F "IX",2,2,"ADTTM2",11.1,2,0) 2^F^2^.1412^^^F "IX",2,2,"ADTTM2",11.1,3,0) 3^F^2^.1413^^^F "IX",2,2,"ADTTM2",11.1,4,0) 4^F^2^.1414^^^F "IX",2,2,"ADTTM2",11.1,5,0) 5^F^2^.1415^^^F "IX",2,2,"ADTTM2",11.1,6,0) 6^F^2^.1416^^^F "IX",2,2,"ADTTM2",11.1,8,0) 8^F^2^.1418^^^F "IX",2,2,"ADTTM2",11.1,9,0) 9^F^2^.14105^^^F "IX",2,2,"ADTTM2",11.1,10,0) 10^F^2^.14111^^^F "IX",2,2,"ADTTM2",11.1,11,0) 7^F^2^.1417^^^F "IX",2,2,"ADTTM2",11.1,11,3) "IX",2,2,"AVAFC0906",0) 2^AVAFC0906^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"AVAFC0906",.1,0) ^^5^5^3070330^ "IX",2,2,"AVAFC0906",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2,"AVAFC0906",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"AVAFC0906",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"AVAFC0906",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"AVAFC0906",.1,5,0) the information available at the time of the event. "IX",2,2,"AVAFC0906",1) D FC^DGFCPROT(.DA,2,.0906,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"AVAFC0906",2) D FC^DGFCPROT(.DA,2,.0906,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"AVAFC0906",11.1,0) ^.114IA^1^1 "IX",2,2,"AVAFC0906",11.1,1,0) 1^F^2^.0906^^^F "IX",2,2,"AVAFC0906",11.1,1,3) "IX",2,2,"AXENR13",0) 2^AXENR13^TRIGGER A MESSAGE FOR ANY CHANGE TO THESE FIELDS^MU^^R^R^I^2^^^^^A "IX",2,2,"AXENR13",.1,0) ^^2^2^3060410^ "IX",2,2,"AXENR13",.1,1,0) This cross-reference will trigger a message to the HEC anytime one of the "IX",2,2,"AXENR13",.1,2,0) related fields is changed. "IX",2,2,"AXENR13",1) D EVENT^IVMPLOG(DFN) "IX",2,2,"AXENR13",2) D EVENT^IVMPLOG(DFN) "IX",2,2,"AXENR13",11.1,0) ^.114IA^3^3 "IX",2,2,"AXENR13",11.1,1,0) 1^F^2^.133^^^F "IX",2,2,"AXENR13",11.1,1,3) "IX",2,2,"AXENR13",11.1,2,0) 2^F^2^.134^^^F "IX",2,2,"AXENR13",11.1,2,3) "IX",2,2,"AXENR13",11.1,3,0) 3^F^2^.135^^^F "IX",2,2,"AXENR13",11.1,3,3) "IX",2,2.141,"ACEE141",0) 2.141^ACEE141^TRIGGER A Z07 ON E/E CHANGES^MU^^R^R^I^2.141^^^^^A "IX",2,2.141,"ACEE141",.1,0) ^^3^3^3060501^ "IX",2,2.141,"ACEE141",.1,1,0) This cross reference will trigger a Z07 message whenever changes are made "IX",2,2.141,"ACEE141",.1,2,0) to the E/E CONFIDENTIAL ADDRESS CATEGORY. This includes add, changes, "IX",2,2.141,"ACEE141",.1,3,0) and deletes. "IX",2,2.141,"ACEE141",1) D CONF^DGDDDTTM I ($T(EECHG^DGRPCTRG)'="") D EECHG^DGRPCTRG "IX",2,2.141,"ACEE141",2) D CONF^DGDDDTTM I ($T(EECHG^DGRPCTRG)'="") D EECHG^DGRPCTRG "IX",2,2.141,"ACEE141",11.1,0) ^.114IA^2^2 "IX",2,2.141,"ACEE141",11.1,1,0) 1^F^2.141^.01^^^F "IX",2,2.141,"ACEE141",11.1,1,3) "IX",2,2.141,"ACEE141",11.1,2,0) 2^F^2.141^1^^^F "IX",2,2.141,"ACEE141",11.1,2,3) "IX",2,2.141,"ADGFM1",0) 2.141^ADGFM1^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2.141^^^^^A "IX",2,2.141,"ADGFM1",.1,0) ^^5^5^3030702 "IX",2,2.141,"ADGFM1",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2.141,"ADGFM1",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2.141,"ADGFM1",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2.141,"ADGFM1",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2.141,"ADGFM1",.1,5,0) the information available at the time of the event. "IX",2,2.141,"ADGFM1",1) D FC^DGFCPROT(.DA,2.141,1,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.141,"ADGFM1",2) D FC^DGFCPROT(.DA,2.141,1,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.141,"ADGFM1",11.1,0) ^.114IA^1^1 "IX",2,2.141,"ADGFM1",11.1,1,0) 1^F^2.141^1^^^F "IX",2,2.141,"ADGFMD01",0) 2.141^ADGFMD01^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2.141^^^^^A "IX",2,2.141,"ADGFMD01",.1,0) ^^5^5^3030702 "IX",2,2.141,"ADGFMD01",.1,1,0) This cross reference activates the DG FIELD MONITOR event point. "IX",2,2.141,"ADGFMD01",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2.141,"ADGFMD01",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2.141,"ADGFMD01",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2.141,"ADGFMD01",.1,5,0) the information available at the time of the event. "IX",2,2.141,"ADGFMD01",1) D FC^DGFCPROT(.DA,2.141,.01,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.141,"ADGFMD01",2) D FC^DGFCPROT(.DA,2.141,.01,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.141,"ADGFMD01",11.1,0) ^.114IA^1^1 "IX",2,2.141,"ADGFMD01",11.1,1,0) 1^F^2.141^.01^^^F "KRN",19,1896,-1) 2^7 "KRN",19,1896,0) DG OUTPUTS MENU^ADT Outputs Menu^^M^.5^^^^^^^47 "KRN",19,1896,10,0) ^19.01PI^41^41 "KRN",19,1896,10,41,0) 10648 "KRN",19,1896,10,41,"^") DG Z07 CONSISTENCY CHECK "KRN",19,1896,"U") ADT OUTPUTS MENU "KRN",19,1930,-1) 2^4 "KRN",19,1930,0) DG REGISTRATION MENU^Registration Menu^^M^.5^^^^^^^47 "KRN",19,1930,10,0) ^19.01IP^37^37 "KRN",19,1930,10,16,0) 2032^ "KRN",19,1930,10,16,"^") DG MEANS TEST USER MENU "KRN",19,1930,10,37,0) 10646 "KRN",19,1930,10,37,"^") DG PATIENT PSEUDO SSN REPORT "KRN",19,1930,"U") REGISTRATION MENU "KRN",19,2032,-1) 2^5 "KRN",19,2032,0) DG MEANS TEST USER MENU^Means Test User Menu^^M^.5^^^^^^^47 "KRN",19,2032,10,0) ^19.01PI^10^10 "KRN",19,2032,10,10,0) 10647 "KRN",19,2032,10,10,"^") DG DEPENDENT PSEUDO SSN REPORT "KRN",19,2032,"U") MEANS TEST USER MENU "KRN",19,10646,-1) 0^2 "KRN",19,10646,0) DG PATIENT PSEUDO SSN REPORT^Pseudo SSN Report (Patient)^^R^^^^^^^^REGISTRATION "KRN",19,10646,1,0) ^19.06^3^3^3051006^^ "KRN",19,10646,1,1,0) This report will list patients with Pseudo SSNs. It can be pulled for "KRN",19,10646,1,2,0) veterans, non-veterans or both. It can be pulled for all Pseudo SSN "KRN",19,10646,1,3,0) Reasons or for just one Pseudo SSN Reason. "KRN",19,10646,25) TSK1^DGPSEUDO "KRN",19,10646,"U") PSEUDO SSN REPORT (PATIENT) "KRN",19,10647,-1) 0^3 "KRN",19,10647,0) DG DEPENDENT PSEUDO SSN REPORT^Pseudo SSN Report for Means Test Dependents^^R^^^^^^^^REGISTRATION "KRN",19,10647,1,0) ^19.06^2^2^3060824^^ "KRN",19,10647,1,1,0) This report will list dependents, sorted by patient, who have pseudo SSNs. "KRN",19,10647,1,2,0) It will display the Pseudo SSN Reason field for each. "KRN",19,10647,25) TSK2^DGPSEU2 "KRN",19,10647,"U") PSEUDO SSN REPORT FOR MEANS TE "KRN",19,10648,-1) 0^6 "KRN",19,10648,0) DG Z07 CONSISTENCY CHECK^Z07 Build Consistency Check^^R^^DG CONSISTENCY^^^^^^ "KRN",19,10648,1,0) ^19.06^4^4^3051104^^^ "KRN",19,10648,1,1,0) This option is used to test for inconsistencies which will prevent a Z07 "KRN",19,10648,1,2,0) message from being sent. The check is done per patient and will notify "KRN",19,10648,1,3,0) the user if inconsistencies are found. For details on the inconsistencies "KRN",19,10648,1,4,0) found, run the Inconsistent Data Elements Report in the ADT Outputs Menu. "KRN",19,10648,25) EN^DGPZ07C "KRN",19,10648,"U") Z07 BUILD CONSISTENCY CHECK "MBREQ") 0 "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "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) 653^3070702^83 "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") YES "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") YES "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") YES "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") 61 "RTN","DG53653A") 0^72^B3589425 "RTN","DG53653A",1,0) DG53653A ;ALB/TDM,CKN - Patch DG*5.3*653 Post-Install Utility Routine ; 10/24/06 11:39am "RTN","DG53653A",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653A",3,0) Q "RTN","DG53653A",4,0) ; "RTN","DG53653A",5,0) EN N DIE,DA,DR "RTN","DG53653A",6,0) D MOD386 ;Edit file 38.6 entries "RTN","DG53653A",7,0) D EP^DG53653U ;Add file 38.6 entries "RTN","DG53653A",8,0) D DELXREF ;Remove cross references "RTN","DG53653A",9,0) D HECMSG ;Send Message to HEC Legacy "RTN","DG53653A",10,0) Q "RTN","DG53653A",11,0) ; "RTN","DG53653A",12,0) MOD386 ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6) "RTN","DG53653A",13,0) N ERR "RTN","DG53653A",14,0) F RULE=4,7,9,11,13,15,16,19,24,29,30,31,34,60,72,74,75,76,78,81,83,85,86 D "RTN","DG53653A",15,0) . D BMES^XPDUTL("Modifying entry #"_RULE_" in 38.6 file.") "RTN","DG53653A",16,0) . S DIE=38.6,DA=$$FIND1^DIC(DIE,"","X",RULE) "RTN","DG53653A",17,0) . I 'DA D MES^XPDUTL(" *** Entry not found! ***") Q "RTN","DG53653A",18,0) . S DR="6////1" D ^DIE "RTN","DG53653A",19,0) . D MES^XPDUTL(" *** Update Complete ***") "RTN","DG53653A",20,0) D BMES^XPDUTL("") "RTN","DG53653A",21,0) Q "RTN","DG53653A",22,0) ; "RTN","DG53653A",23,0) DELXREF ;Delete x-ref and indexes "RTN","DG53653A",24,0) N ZINDX "RTN","DG53653A",25,0) D BMES^XPDUTL(">>> Deleting ADELBAI index from PATIENT File #2") "RTN","DG53653A",26,0) D DELIXN^DDMOD(2,"ADELBAI") "RTN","DG53653A",27,0) Q "RTN","DG53653A",28,0) HECMSG ; Send message to HEC Legacy that install is complete. "RTN","DG53653A",29,0) N SITE,STATN,PRODFLG,XMDUZ,XMSUB,XMY,XMTEXT,MSG "RTN","DG53653A",30,0) S SITE=$$SITE^VASITE,STATN=$P($G(SITE),U,3) "RTN","DG53653A",31,0) S PRODFLG=$$GET1^DIQ(869.3,"1,",.03,"I")="P" "RTN","DG53653A",32,0) S XMDUZ="EVC I1 Install" "RTN","DG53653A",33,0) S XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*653)" "RTN","DG53653A",34,0) S:PRODFLG XMY("S.IVMB*2*860 MESSAGE@IVM.MED.VA.GOV")="" "RTN","DG53653A",35,0) S:'PRODFLG XMY(DUZ)="" "RTN","DG53653A",36,0) S XMTEXT="MSG(" "RTN","DG53653A",37,0) S $P(MSG(1),U)="IVMB*2*860" "RTN","DG53653A",38,0) S $P(MSG(1),U,2)=STATN "RTN","DG53653A",39,0) S $P(MSG(1),U,3)="DG*5.3*653 "_$$FMTE^XLFDT($$NOW^XLFDT(),"5D") "RTN","DG53653A",40,0) S $P(MSG(1),U,4)=PRODFLG "RTN","DG53653A",41,0) D ^XMD "RTN","DG53653A",42,0) D BMES^XPDUTL(" *** Install Message Sent to HEC Legacy ***") "RTN","DG53653A",43,0) Q "RTN","DG53653P") 0^47^B3450208 "RTN","DG53653P",1,0) DG53653P ;TDM - Patch DG*5.3*653 Pre-Install Utility Routine ; 11/22/05 9:06am "RTN","DG53653P",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653P",3,0) Q "RTN","DG53653P",4,0) ; "RTN","DG53653P",5,0) EN N DIE,DA,DR "RTN","DG53653P",6,0) D MOD386 Q:$G(XPDABORT)=2 ;Check file 38.6 entries "RTN","DG53653P",7,0) D MOD30192 Q:$G(XPDABORT)=2 ;Edit file 301.92 entries "RTN","DG53653P",8,0) Q "RTN","DG53653P",9,0) ; "RTN","DG53653P",10,0) MOD386 ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6) "RTN","DG53653P",11,0) N ERR "RTN","DG53653P",12,0) K XPDABORT "RTN","DG53653P",13,0) F RULE=4,7,9,11,13,15,16,19,24,29,30,31,34,60,72,74,75,76,78,81,83,85,86 D Q:$G(XPDABORT)=2 "RTN","DG53653P",14,0) . D BMES^XPDUTL("Checking entry #"_RULE_" in 38.6 file.") "RTN","DG53653P",15,0) . S DIE=38.6,DA=$$FIND1^DIC(DIE,"","X",RULE) I 'DA D Q "RTN","DG53653P",16,0) . . S XPDABORT=2 "RTN","DG53653P",17,0) . . D MES^XPDUTL(" *** Entry not found! ***") "RTN","DG53653P",18,0) . . D BMES^XPDUTL(" *** Please contact EVS for assistance ***") "RTN","DG53653P",19,0) . . D BMES^XPDUTL(" *** INSTALLATION ABORTED ***") "RTN","DG53653P",20,0) . . D BMES^XPDUTL("") "RTN","DG53653P",21,0) . D MES^XPDUTL(" *** Complete ***") "RTN","DG53653P",22,0) D BMES^XPDUTL("") "RTN","DG53653P",23,0) Q "RTN","DG53653P",24,0) ; "RTN","DG53653P",25,0) MOD30192 ; Update entry in IVM DEMOGRAPHIC UPLOAD FIELDS file (#301.92) "RTN","DG53653P",26,0) N ERR "RTN","DG53653P",27,0) K XPDABORT "RTN","DG53653P",28,0) S DIE=301.92 "RTN","DG53653P",29,0) D BMES^XPDUTL("Modifying 'RATED INCOMPETENT?' entry in 301.92 file.") "RTN","DG53653P",30,0) S DA=$$FIND1^DIC(DIE,"","X","RATED INCOMPETENT?") I 'DA D Q "RTN","DG53653P",31,0) . S XPDABORT=2 "RTN","DG53653P",32,0) . D MES^XPDUTL(" *** Entry not found! ***") "RTN","DG53653P",33,0) . D BMES^XPDUTL(" *** Please contact EVS for assistance ***") "RTN","DG53653P",34,0) . D BMES^XPDUTL(" *** INSTALLATION ABORTED ***") "RTN","DG53653P",35,0) . D BMES^XPDUTL("") "RTN","DG53653P",36,0) S DR=".09////0" D ^DIE "RTN","DG53653P",37,0) D MES^XPDUTL(" *** Update Complete ***") "RTN","DG53653P",38,0) D BMES^XPDUTL("") "RTN","DG53653P",39,0) Q "RTN","DG53653U") 0^56^B6864665 "RTN","DG53653U",1,0) DG53653U ;TDM - Patch DG*5.3*653 Install Utility Routine ; 11/28/05 4:58pm "RTN","DG53653U",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653U",3,0) Q "RTN","DG53653U",4,0) ; "RTN","DG53653U",5,0) EP ; Add new entries to the INCONSISTENT DATA ELEMENTS file (#38.6) "RTN","DG53653U",6,0) N BRNG,ERNG,DGKRTN,KEYREQ "RTN","DG53653U",7,0) D ADDINC(301,312,"DG53653V",0) Q:$G(XPDABORT)=2 "RTN","DG53653U",8,0) D ADDINC(401,413,"DG53653W",0) Q:$G(XPDABORT)=2 "RTN","DG53653U",9,0) D ADDINC(501,517,"DG53653X",0) Q:$G(XPDABORT)=2 "RTN","DG53653U",10,0) D ADDINC(701,726,"DG53653Y",0) Q:$G(XPDABORT)=2 "RTN","DG53653U",11,0) Q "RTN","DG53653U",12,0) ; "RTN","DG53653U",13,0) ADDINC(BRNG,ERNG,DGKRTN,KEYREQ) ; add new entries to the INCONSISTENT DATA ELEMENTS file (#38.6) "RTN","DG53653U",14,0) ;----------------------------------------------------------------- "RTN","DG53653U",15,0) ; Input: BRNG = Beginning Number "RTN","DG53653U",16,0) ; ERNG = Ending Number "RTN","DG53653U",17,0) ; DGKRTN = Routine Name for the Range "RTN","DG53653U",18,0) ; KEYREQ = Key Required "RTN","DG53653U",19,0) ; 0=No Key Required "RTN","DG53653U",20,0) ; 1=Eligibility Verified "RTN","DG53653U",21,0) ; 2=Money Verified "RTN","DG53653U",22,0) ; 3=Service Verified "RTN","DG53653U",23,0) ; 4=Key Always Required "RTN","DG53653U",24,0) ;----------------------------------------------------------------- "RTN","DG53653U",25,0) N DGK,DGKSUB,DGWP,ROOT,DGFDA,DGWP,DGERR,DGIEN,DGTITL "RTN","DG53653U",26,0) K XPDABORT "RTN","DG53653U",27,0) D BMES^XPDUTL(" >> Adding entries "_BRNG_"-"_ERNG_" into the INCONSISTENT DATA ELEMENTS file (#38.6)") "RTN","DG53653U",28,0) F DGK=BRNG:1:ERNG Q:$G(XPDABORT)=2 D "RTN","DG53653U",29,0) .I $D(^DGIN(38.6,DGK)) D Q "RTN","DG53653U",30,0) ..D BMES^XPDUTL(" Internal Entry # "_DGK_" already exists in file #38.6") "RTN","DG53653U",31,0) ..S ROOT="DGFDA(38.6,"""_DGK_","")" S DGKSUB=DGK_U_DGKRTN D @DGKSUB "RTN","DG53653U",32,0) ..I $P($G(^DGIN(38.6,DGK,0)),"^")=$G(@ROOT@(.01)) D MES^XPDUTL("Entry "_DGK_" matches incoming entry - OK") Q "RTN","DG53653U",33,0) ..D MES^XPDUTL(" >>> ERROR: Entry # "_DGK_" needs to be reviewed by NVS! <<<") "RTN","DG53653U",34,0) ..D MES^XPDUTL(" Existing entry: "_$P($G(^DGIN(38.6,DGK,0)),"^")) "RTN","DG53653U",35,0) ..D MES^XPDUTL(" Incoming entry: "_$G(@ROOT@(.01))) "RTN","DG53653U",36,0) ..D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>") "RTN","DG53653U",37,0) ..S XPDABORT=2 "RTN","DG53653U",38,0) .K DGFDA,ROOT,DGWP "RTN","DG53653U",39,0) .S ROOT="DGFDA(38.6,""?+1,"")" "RTN","DG53653U",40,0) .S DGKSUB=DGK_U_DGKRTN D @DGKSUB Q:'$D(DGFDA) "RTN","DG53653U",41,0) .S DGIEN(1)=DGK,DGTITL=@ROOT@(.01),@ROOT@(3)=KEYREQ,@ROOT@(4)=0,@ROOT@(5)=0,@ROOT@(6)=1,@ROOT@(50)="DGWP" "RTN","DG53653U",42,0) .D UPDATE^DIE("","DGFDA","DGIEN","DGERR") "RTN","DG53653U",43,0) .I $D(DGERR) D Q "RTN","DG53653U",44,0) ..D BMES^XPDUTL(" >>> ERROR! "_DGTITL_" not added to file #38.6") "RTN","DG53653U",45,0) ..D MES^XPDUTL(" "_DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1)) "RTN","DG53653U",46,0) ..D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>") "RTN","DG53653U",47,0) ..S XPDABORT=2 "RTN","DG53653U",48,0) .D BMES^XPDUTL(" "_DGTITL_" successfully added.") "RTN","DG53653U",49,0) Q "RTN","DG53653V") 0^59^B12198923 "RTN","DG53653V",1,0) DG53653V ;CKN - Patch DG*5.3*653 Install Utility Routine ; 3/14/06 3:33pm "RTN","DG53653V",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653V",3,0) ; Called from DG53653U "RTN","DG53653V",4,0) Q "RTN","DG53653V",5,0) ; "RTN","DG53653V",6,0) 301 S @ROOT@(.01)="PERSON LASTNAME REQUIRED" "RTN","DG53653V",7,0) S @ROOT@(2)="PERSON MUST HAVE A LAST NAME" "RTN","DG53653V",8,0) S DGWP(1,0)="The last name of the name components is not present." "RTN","DG53653V",9,0) S DGWP(2,0)="This applies to patient, spouse and dependents." "RTN","DG53653V",10,0) Q "RTN","DG53653V",11,0) ; "RTN","DG53653V",12,0) 302 Q ; "RTN","DG53653V",13,0) S @ROOT@(.01)="DATE OF BIRTH REQUIRED" "RTN","DG53653V",14,0) S @ROOT@(2)="DATE OF BIRTH MUST BE ENTERED" "RTN","DG53653V",15,0) S DGWP(1,0)="The person's date of birth is missing. This applies to" "RTN","DG53653V",16,0) S DGWP(2,0)="patient, spouse and dependents. Year is the minimum" "RTN","DG53653V",17,0) S DGWP(3,0)="data element that must be entered." "RTN","DG53653V",18,0) Q "RTN","DG53653V",19,0) ; "RTN","DG53653V",20,0) 303 S @ROOT@(.01)="GENDER REQUIRED" "RTN","DG53653V",21,0) S @ROOT@(2)="GENDER MUST BE ENTERED" "RTN","DG53653V",22,0) S DGWP(1,0)="The person's gender value is missing. This applies to" "RTN","DG53653V",23,0) S DGWP(2,0)="patient, spouse and dependents." "RTN","DG53653V",24,0) Q "RTN","DG53653V",25,0) ; "RTN","DG53653V",26,0) 304 S @ROOT@(.01)="GENDER INVALID" "RTN","DG53653V",27,0) S @ROOT@(2)="THE PERSON GENDER MUST BE EITHER MALE OR FEMALE" "RTN","DG53653V",28,0) S DGWP(1,0)="The person has a gender value, but it is not either" "RTN","DG53653V",29,0) S DGWP(2,0)="male or female. This applies to patient, spouse and" "RTN","DG53653V",30,0) S DGWP(3,0)="dependents." "RTN","DG53653V",31,0) Q "RTN","DG53653V",32,0) ; "RTN","DG53653V",33,0) 305 Q ;Removed as duplicate "RTN","DG53653V",34,0) S @ROOT@(.01)="VETERAN SSN MISSING" "RTN","DG53653V",35,0) S @ROOT@(2)="VETERAN'S SSN IS MISSING" "RTN","DG53653V",36,0) S DGWP(1,0)="The person's SSN is missing. This applies to the" "RTN","DG53653V",37,0) S DGWP(2,0)="patient only." "RTN","DG53653V",38,0) Q "RTN","DG53653V",39,0) ; "RTN","DG53653V",40,0) 306 S @ROOT@(.01)="VALID SSN/PSEUDO SSN REQUIRED" "RTN","DG53653V",41,0) S @ROOT@(2)="PATIENT MUST HAVE A VALID SSN OR A PSEUDO SSN" "RTN","DG53653V",42,0) S DGWP(1,0)="Patient must have a valid SSN or a Pseudo SSN." "RTN","DG53653V",43,0) Q "RTN","DG53653V",44,0) ; "RTN","DG53653V",45,0) 307 S @ROOT@(.01)="PSEUDO SSN REASON REQUIRED" "RTN","DG53653V",46,0) S @ROOT@(2)="PSEUDO SSN REASON IS MISSING" "RTN","DG53653V",47,0) S DGWP(1,0)="If a Pseudo SSN number is entered for a person, spouse" "RTN","DG53653V",48,0) S DGWP(2,0)="or dependents, then a reason must be entered." "RTN","DG53653V",49,0) Q "RTN","DG53653V",50,0) ; "RTN","DG53653V",51,0) 308 ; "RTN","DG53653V",52,0) S @ROOT@(.01)="DATE OF DEATH BEFORE DOB" "RTN","DG53653V",53,0) S @ROOT@(2)="THE DATE OF DEATH IS BEFORE THE DATE OF BIRTH" "RTN","DG53653V",54,0) S DGWP(1,0)="The Date of Death cannot be prior to the Date of Birth." "RTN","DG53653V",55,0) Q "RTN","DG53653V",56,0) ; "RTN","DG53653V",57,0) 309 S @ROOT@(.01)="PATIENT RELATIONSHIP INVALID" "RTN","DG53653V",58,0) S @ROOT@(2)="RELATIONSHIP TO PATIENT IS NOT A VALID VALUE" "RTN","DG53653V",59,0) S DGWP(1,0)="The value of Relationship to Patient does not match" "RTN","DG53653V",60,0) S DGWP(2,0)="one of the valid values." "RTN","DG53653V",61,0) Q "RTN","DG53653V",62,0) ; "RTN","DG53653V",63,0) 310 S @ROOT@(.01)="DEPENDENT EFF. DATE REQUIRED" "RTN","DG53653V",64,0) S @ROOT@(2)="DEPENDENT(S) EFFECTIVE DATE IS MISSING" "RTN","DG53653V",65,0) S DGWP(1,0)="A dependent is present but the effective date is null." "RTN","DG53653V",66,0) Q "RTN","DG53653V",67,0) ; "RTN","DG53653V",68,0) 311 Q ;Duplicate with #16 "RTN","DG53653V",69,0) S @ROOT@(.01)="DATE OF DEATH IS FUTURE DATE" "RTN","DG53653V",70,0) S @ROOT@(2)="DATE OF DEATH CANNOT BE A FUTURE DATE" "RTN","DG53653V",71,0) S DGWP(1,0)="Date Of Death cannot be a future date." "RTN","DG53653V",72,0) Q "RTN","DG53653V",73,0) ; "RTN","DG53653V",74,0) 312 S @ROOT@(.01)="PERSON MUST HAVE NATIONAL ICN" "RTN","DG53653V",75,0) S @ROOT@(2)="PERSON MUST HAVE NATIONAL ICN" "RTN","DG53653V",76,0) S DGWP(1,0)="Person does not have National ICN." "RTN","DG53653V",77,0) Q "RTN","DG53653V",78,0) ; "RTN","DG53653W") 0^57^B12933770 "RTN","DG53653W",1,0) DG53653W ;TDM - Patch DG*5.3*653 Install Utility Routine ; 10/24/05 9:28am "RTN","DG53653W",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653W",3,0) ; Called from DG53653U "RTN","DG53653W",4,0) Q "RTN","DG53653W",5,0) ; "RTN","DG53653W",6,0) 401 S @ROOT@(.01)="RATED INCOMPETENT INVALID" "RTN","DG53653W",7,0) S @ROOT@(2)="RATED INCOMPETENT MUST BE EITHER YES, NO, OR UNKNOWN/NULL" "RTN","DG53653W",8,0) S DGWP(1,0)="If completed, the value of Rated Incompetent must be either yes," "RTN","DG53653W",9,0) S DGWP(2,0)="no, or unknown." "RTN","DG53653W",10,0) Q "RTN","DG53653W",11,0) ; "RTN","DG53653W",12,0) 402 S @ROOT@(.01)="ELIGIBLE FOR MEDICAID INVALID" "RTN","DG53653W",13,0) S @ROOT@(2)="ELIGIBLE FOR MEDICAID MUST BE EITHER YES, NO, OR NULL" "RTN","DG53653W",14,0) S DGWP(1,0)="If completed, the value of Eligible For Medicaid must be either" "RTN","DG53653W",15,0) S DGWP(2,0)="yes or no." "RTN","DG53653W",16,0) Q "RTN","DG53653W",17,0) ; "RTN","DG53653W",18,0) 403 S @ROOT@(.01)="DT MEDICAID LAST ASKED INVALID" "RTN","DG53653W",19,0) S @ROOT@(2)="ELIGIBLE FOR MEDICAID IS YES AND DATE MEDICAID LAST ASKED IS MISSING" "RTN","DG53653W",20,0) S DGWP(1,0)="The value of 'Eligible for Medicaid' is Yes, but the Date Medicaid" "RTN","DG53653W",21,0) S DGWP(2,0)="Last Asked value is null." "RTN","DG53653W",22,0) Q "RTN","DG53653W",23,0) ; "RTN","DG53653W",24,0) 404 Q ;Same as #15? "RTN","DG53653W",25,0) S @ROOT@(.01)="INELIGIBLE REASON INVALID" "RTN","DG53653W",26,0) S @ROOT@(2)="INELIGIBLE DATE IS PRESENT AND THE INELIGIBLE REASON IS MISSING" "RTN","DG53653W",27,0) S DGWP(1,0)="There is an Ineligible Date present, but the Ineligible Reason" "RTN","DG53653W",28,0) S DGWP(2,0)="is missing." "RTN","DG53653W",29,0) Q "RTN","DG53653W",30,0) ;; "RTN","DG53653W",31,0) 405 Q ;Same as #19? "RTN","DG53653W",32,0) S @ROOT@(.01)="NON VETERAN ELIG CODE INVALID" "RTN","DG53653W",33,0) S @ROOT@(2)="ELIGIBILITY CODE FOR NON-VETERAN IS NOT A VALID VALUE" "RTN","DG53653W",34,0) S DGWP(1,0)="The value of Eligibility Code is completed, but it does not match" "RTN","DG53653W",35,0) S DGWP(2,0)="one of the non-veteran values." "RTN","DG53653W",36,0) Q "RTN","DG53653W",37,0) ; "RTN","DG53653W",38,0) 406 S @ROOT@(.01)="CLAIM FOLDER NUMBER INVALID" "RTN","DG53653W",39,0) S @ROOT@(2)="CLAIM FOLDER NUM MUST BE 7 TO 8 DIGITS. IF 9 DIGITS THEN MUST BE SSN" "RTN","DG53653W",40,0) S DGWP(1,0)="Claim Folder Number must consist of 7 or 8, or 9 numbers if SSN." "RTN","DG53653W",41,0) Q "RTN","DG53653W",42,0) ; "RTN","DG53653W",43,0) 407 S @ROOT@(.01)="ELIGIBILITY STATUS INVALID" "RTN","DG53653W",44,0) S @ROOT@(2)="THE VALUE ENTERED FOR ELIGIBILITY STATUS MUST BE P, R, V OR NULL" "RTN","DG53653W",45,0) S DGWP(1,0)="The value of Eligibility Status is completed, but it does not match" "RTN","DG53653W",46,0) S DGWP(2,0)="one of the values." "RTN","DG53653W",47,0) Q "RTN","DG53653W",48,0) ; "RTN","DG53653W",49,0) 408 ;Removed per customer 05/08/2006 - BAJ "RTN","DG53653W",50,0) ;S @ROOT@(.01)="DECLINE TO GIVE INCOME INVALID" "RTN","DG53653W",51,0) ;S @ROOT@(2)="MEANS TEST IS PRESENT, NO INCOME AND DECLINE TO GIVE INCOME NOT YES" "RTN","DG53653W",52,0) ;S DGWP(1,0)="A Means Test is present, there is no income and the Declines to" "RTN","DG53653W",53,0) ;S DGWP(2,0)="Give Income is null or no." "RTN","DG53653W",54,0) Q "RTN","DG53653W",55,0) ; "RTN","DG53653W",56,0) 409 S @ROOT@(.01)="AGREE TO PAY DEDUCT INVALID" "RTN","DG53653W",57,0) S @ROOT@(2)="MEANS TEST IS PRESENT AND AGREE TO PAY DEDUCTIBLE IS NULL" "RTN","DG53653W",58,0) S DGWP(1,0)="A Means Test is present, the status of the test is either MT Co-Pay" "RTN","DG53653W",59,0) S DGWP(2,0)="Required, GMT Co-Pay Required or Pending Adjudication and Agree to" "RTN","DG53653W",60,0) S DGWP(3,0)="pay Deductible is null." "RTN","DG53653W",61,0) Q "RTN","DG53653W",62,0) ; "RTN","DG53653W",63,0) 410 Q ;Same as #404 "RTN","DG53653W",64,0) ; "RTN","DG53653W",65,0) 411 S @ROOT@(.01)="ENROLLMENT APP DATE INVALID" "RTN","DG53653W",66,0) S @ROOT@(2)="ENROLLMENT APPLICATION DATE MUST BE A PRECISE DATE" "RTN","DG53653W",67,0) S DGWP(1,0)="Enrollment Application Date must be a precise date." "RTN","DG53653W",68,0) Q "RTN","DG53653W",69,0) ; "RTN","DG53653W",70,0) 412 Q ;Same as #24 "RTN","DG53653W",71,0) S @ROOT@(.01)="POS/ELIG CODE INVALID" "RTN","DG53653W",72,0) S @ROOT@(2)="POS INCONSISTENT WITH PRIMARY ELIGIBILITY CODE" "RTN","DG53653W",73,0) S DGWP(1,0)="POS Inconsistent With Primary Eligibility." "RTN","DG53653W",74,0) Q "RTN","DG53653W",75,0) ; "RTN","DG53653W",76,0) 413 Q ;Same as #13 "RTN","DG53653W",77,0) S @ROOT@(.01)="POS INVALID" "RTN","DG53653W",78,0) S @ROOT@(2)="POS UNSPECIFIED" "RTN","DG53653W",79,0) S DGWP(1,0)="POS Unspecified." "RTN","DG53653W",80,0) Q "RTN","DG53653X") 0^58^B28622000 "RTN","DG53653X",1,0) DG53653X ;TDM - Patch DG*5.3*653 Install Utility Routine ; 10/27/05 5:14pm "RTN","DG53653X",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653X",3,0) ; Called from DG53653U "RTN","DG53653X",4,0) Q "RTN","DG53653X",5,0) ; "RTN","DG53653X",6,0) 501 S @ROOT@(.01)="POW STATUS INVALID" "RTN","DG53653X",7,0) S @ROOT@(2)="POW STATUS INDICATED MUST BE EITHER YES, NO, OR UNKNOWN/NULL" "RTN","DG53653X",8,0) S DGWP(1,0)="If completed, the value of POW Status Indicated must be either" "RTN","DG53653X",9,0) S DGWP(2,0)="Yes, No, or Unknown." "RTN","DG53653X",10,0) Q "RTN","DG53653X",11,0) ; "RTN","DG53653X",12,0) 502 S @ROOT@(.01)="MIL DIS RETIREMENT INVALID" "RTN","DG53653X",13,0) S @ROOT@(2)="THE VALUE FOR MIL DIS RETIREMENT MUST BE EITHER YES,NO OR UNKNOWN/NULL" "RTN","DG53653X",14,0) S DGWP(1,0)="The Value of Mil. Dis. Retirement is completed, but does not" "RTN","DG53653X",15,0) S DGWP(2,0)="match any valid value. (Note: This value is replacing" "RTN","DG53653X",16,0) S DGWP(3,0)="Disability Retirement from Military.)" "RTN","DG53653X",17,0) Q "RTN","DG53653X",18,0) ; "RTN","DG53653X",19,0) 503 S @ROOT@(.01)="DISCHARGE DUE TO DISAB INVALID" "RTN","DG53653X",20,0) S @ROOT@(2)="THE VALUE FOR DISCH DUE TO DISAB MUST BE EITHER YES,NO,OR UNKNOWN/NULL" "RTN","DG53653X",21,0) S DGWP(1,0)="The Value for Discharge Due to Disability is completed but" "RTN","DG53653X",22,0) S DGWP(2,0)="not a valid value." "RTN","DG53653X",23,0) Q "RTN","DG53653X",24,0) ; "RTN","DG53653X",25,0) 504 S @ROOT@(.01)="AGENT ORANGE EXPOSURE INVALID" "RTN","DG53653X",26,0) S @ROOT@(2)="AGENT ORANGE EXPOSURE MUST BE EITHER YES, NO, OR UNKNOWN" "RTN","DG53653X",27,0) S DGWP(1,0)="If completed, the value of Exposed to Agent Orange must be" "RTN","DG53653X",28,0) S DGWP(2,0)="either Yes, No, or Unknown" "RTN","DG53653X",29,0) Q "RTN","DG53653X",30,0) ; "RTN","DG53653X",31,0) 505 S @ROOT@(.01)="RADIATION EXPOSURE INVALID" "RTN","DG53653X",32,0) S @ROOT@(2)="RADIATION EXPOSURE MUST BE EITHER YES, NO, OR UNKNOWN" "RTN","DG53653X",33,0) S DGWP(1,0)="If completed, the value of Radiation Exposure Indicated must" "RTN","DG53653X",34,0) S DGWP(2,0)="be either Yes, No, or Unknown." "RTN","DG53653X",35,0) Q "RTN","DG53653X",36,0) ; "RTN","DG53653X",37,0) 506 S @ROOT@(.01)="ENV CONTAMINANTS EXP INVALID" "RTN","DG53653X",38,0) S @ROOT@(2)="ENVIRONMENTAL CONTAMINANTS EXPOSURE MUST BE EITHER YES, NO, OR UNKNOWN" "RTN","DG53653X",39,0) S DGWP(1,0)="If completed, the value of Environmental Contaminants must be" "RTN","DG53653X",40,0) S DGWP(2,0)="Yes, No or Unknown." "RTN","DG53653X",41,0) Q "RTN","DG53653X",42,0) ; "RTN","DG53653X",43,0) 507 S @ROOT@(.01)="RAD EXPOSURE METHOD INVALID" "RTN","DG53653X",44,0) S @ROOT@(2)="RAD EXPOSURE METHOD MUST BE ENTERED SINCE RAD EXP INDICATOR IS YES" "RTN","DG53653X",45,0) S DGWP(1,0)="Radiation Exposure Indicated is Yes and Radiation Exposure Method" "RTN","DG53653X",46,0) S DGWP(2,0)="is null." "RTN","DG53653X",47,0) Q "RTN","DG53653X",48,0) ; "RTN","DG53653X",49,0) 508 S @ROOT@(.01)="MST STATUS INVALID" "RTN","DG53653X",50,0) S @ROOT@(2)="MST STATUS MUST BE YES, NO, OR DECLINES" "RTN","DG53653X",51,0) S DGWP(1,0)="The value of MST Status is completed, but it does not match one" "RTN","DG53653X",52,0) S DGWP(2,0)="of the values." "RTN","DG53653X",53,0) Q "RTN","DG53653X",54,0) ; "RTN","DG53653X",55,0) 509 S @ROOT@(.01)="MST STATUS CHANGE DATE MISSING" "RTN","DG53653X",56,0) S @ROOT@(2)="MST STATUS CHANGE DATE IS REQUIRED IF MST STATUS IS Y, N, OR D" "RTN","DG53653X",57,0) S DGWP(1,0)="MST Status Change Date is required if MST Status is Yes, No, or" "RTN","DG53653X",58,0) S DGWP(2,0)="or Declines to answer." "RTN","DG53653X",59,0) Q "RTN","DG53653X",60,0) ; "RTN","DG53653X",61,0) 510 S @ROOT@(.01)="MST STATUS SITE REQUIRED" "RTN","DG53653X",62,0) S @ROOT@(2)="SITE DETERMINING MST STATUS IS REQUIRED IF MST STATUS IS Y, N, OR D" "RTN","DG53653X",63,0) S DGWP(1,0)="Site Determining MST Status is required if MST Status is Yes, No," "RTN","DG53653X",64,0) S DGWP(2,0)="or Declines to answer." "RTN","DG53653X",65,0) Q "RTN","DG53653X",66,0) ; "RTN","DG53653X",67,0) 511 S @ROOT@(.01)="MST STATUS SITE INVALID" "RTN","DG53653X",68,0) S @ROOT@(2)="SITE DETERMINING MST STATUS MUST BE A VAMC OR CLINIC" "RTN","DG53653X",69,0) S DGWP(1,0)="The Site Determining MST Status is present, but the type of" "RTN","DG53653X",70,0) S DGWP(2,0)=" Institution that it points to is not identified as a VA Medical" "RTN","DG53653X",71,0) S DGWP(3,0)="Center or an Outpatient Clinic." "RTN","DG53653X",72,0) Q "RTN","DG53653X",73,0) ; "RTN","DG53653X",74,0) 512 Q ;Same as or conflicting with #60 in 38.6??? "RTN","DG53653X",75,0) S @ROOT@(.01)="AO EXPOSURE LOCATION MISSING" "RTN","DG53653X",76,0) S @ROOT@(2)="AO EXPOSURE LOCATION IS MISSING AND EXPOSED TO AGENT ORANGE IS YES" "RTN","DG53653X",77,0) S DGWP(1,0)="The Exposed to Agent Orange is Yes and the Agent Orange Exposure" "RTN","DG53653X",78,0) S DGWP(2,0)="Location is null." "RTN","DG53653X",79,0) Q "RTN","DG53653X",80,0) ; "RTN","DG53653X",81,0) 513 Q ;Same as or conflicting with #72 in 38.6??? "RTN","DG53653X",82,0) S @ROOT@(.01)="MS ENTRY DATE REQUIRED" "RTN","DG53653X",83,0) S @ROOT@(2)="MILITARY SERVICE ENTRY DATE (SED) MUST CONTAIN AT LEAST A YEAR DATE" "RTN","DG53653X",84,0) S DGWP(1,0)="If completed, Military Service Entry Date (SED) must contain at" "RTN","DG53653X",85,0) S DGWP(2,0)="least a year date." "RTN","DG53653X",86,0) Q "RTN","DG53653X",87,0) ; "RTN","DG53653X",88,0) 514 Q ;Same as or conflicting with #72 in 38.6??? "RTN","DG53653X",89,0) S @ROOT@(.01)="MS SEPARATION DATE REQUIRED" "RTN","DG53653X",90,0) S @ROOT@(2)="MILITARY SERVICE SEPARATION DATE-SSD MUST CONTAIN AT LEAST A YEAR DATE" "RTN","DG53653X",91,0) S DGWP(1,0)="If completed, Military Service Separation Date must contain at" "RTN","DG53653X",92,0) S DGWP(2,0)="least a year date." "RTN","DG53653X",93,0) Q "RTN","DG53653X",94,0) ; "RTN","DG53653X",95,0) 515 Q ;Same as or conflicting with #74 in 38.6? "RTN","DG53653X",96,0) S @ROOT@(.01)="CONFLICT FROM/TO DATE REQUIRED" "RTN","DG53653X",97,0) S @ROOT@(2)="CONFLICT FROM/TO DATES DO NOT CONTAIN AT LEAST A MONTH AND YEAR DATE" "RTN","DG53653X",98,0) S DGWP(1,0)="If present, Conflict From/To Dates must consist of at least a" "RTN","DG53653X",99,0) S DGWP(2,0)="year date." "RTN","DG53653X",100,0) Q "RTN","DG53653X",101,0) ; "RTN","DG53653X",102,0) 516 S @ROOT@(.01)="DOB INVALID-MEXICAN BORDER WAR" "RTN","DG53653X",103,0) S @ROOT@(2)="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" "RTN","DG53653X",104,0) S DGWP(1,0)="DOB is Inconsistent With Eligibility Of Mexican Border War." "RTN","DG53653X",105,0) Q "RTN","DG53653X",106,0) ; "RTN","DG53653X",107,0) 517 S @ROOT@(.01)="DOB INVALID-WORLD WAR I" "RTN","DG53653X",108,0) S @ROOT@(2)="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" "RTN","DG53653X",109,0) S DGWP(1,0)="DOB is Inconsistent With Eligibility Of World War I." "RTN","DG53653X",110,0) Q "RTN","DG53653Y") 0^71^B58594943 "RTN","DG53653Y",1,0) DG53653Y ;BAJ - Patch DG*5.3*653 Install Utility Routine ; 10/17/05 10:36am "RTN","DG53653Y",2,0) ;;5.3;Registration;**653**;AUG 13, 1993;Build 2 "RTN","DG53653Y",3,0) Q "RTN","DG53653Y",4,0) ; "RTN","DG53653Y",5,0) 701 ;Catastrophic Disability 'Decided By' Can Not Be 'HINQ' "RTN","DG53653Y",6,0) S @ROOT@(.01)="CD 'DECIDED BY' CANNOT BE HINQ" "RTN","DG53653Y",7,0) S @ROOT@(2)="CD 'DECIDED BY' CANNOT BE 'HINQ'" "RTN","DG53653Y",8,0) S DGWP(1,0)="Enter the name of the VA staff physician who made the " "RTN","DG53653Y",9,0) S DGWP(2,0)="decision that the patient was catastrophically disabled." "RTN","DG53653Y",10,0) Q "RTN","DG53653Y",11,0) ; "RTN","DG53653Y",12,0) 702 ;Catastrophic Disability 'Decided By' Not Valid "RTN","DG53653Y",13,0) S @ROOT@(.01)="CD 'DECIDED BY' NOT VALID" "RTN","DG53653Y",14,0) S @ROOT@(2)="CD 'DECIDED BY' IS NOT VALID" "RTN","DG53653Y",15,0) S DGWP(1,0)="Enter the name of the VA staff physician who made the " "RTN","DG53653Y",16,0) S DGWP(2,0)="decision that the patient was catastrophically disabled." "RTN","DG53653Y",17,0) Q "RTN","DG53653Y",18,0) ; "RTN","DG53653Y",19,0) 703 ;Catastrophic Disability 'Decided By' Required "RTN","DG53653Y",20,0) S @ROOT@(.01)="CD 'DECIDED BY' IS REQUIRED" "RTN","DG53653Y",21,0) S @ROOT@(2)="CD 'DECIDED BY' IS REQUIRED" "RTN","DG53653Y",22,0) S DGWP(1,0)="Enter the name of the VA staff physician who made the " "RTN","DG53653Y",23,0) S DGWP(2,0)="decision that the patient was catastrophically disabled." "RTN","DG53653Y",24,0) S DGWP(3,0)="This is a required field." "RTN","DG53653Y",25,0) Q "RTN","DG53653Y",26,0) ; "RTN","DG53653Y",27,0) 704 ;'Catastrophic Disability Review Date' Required "RTN","DG53653Y",28,0) S @ROOT@(.01)="CD 'REVIEW DATE' IS REQUIRED" "RTN","DG53653Y",29,0) S @ROOT@(2)="CD 'REVIEW DATE' IS REQUIRED" "RTN","DG53653Y",30,0) S DGWP(1,0)="Enter the date that a review to determine Catastrophic Disability " "RTN","DG53653Y",31,0) S DGWP(2,0)="was made. This review may be a medical record review or" "RTN","DG53653Y",32,0) S DGWP(3,0)="physical exam review." "RTN","DG53653Y",33,0) Q "RTN","DG53653Y",34,0) ; "RTN","DG53653Y",35,0) 705 ;'Catastrophic Disabilty Review Date' Invalid "RTN","DG53653Y",36,0) S @ROOT@(.01)="CD 'REVIEW DATE' IS INVALID" "RTN","DG53653Y",37,0) S @ROOT@(2)="CD 'REVIEW DATE' SHOULD BE A MEDICAL RECORD OR PHYS EXAM REVIEW DATE" "RTN","DG53653Y",38,0) S DGWP(1,0)="Enter the date that a review to determine Catastrophic Disability " "RTN","DG53653Y",39,0) S DGWP(2,0)="was made. This review may be a medical record review or" "RTN","DG53653Y",40,0) S DGWP(3,0)="physical exam review." "RTN","DG53653Y",41,0) Q "RTN","DG53653Y",42,0) ; "RTN","DG53653Y",43,0) 706 ;'CD Condition Score' Not Valid "RTN","DG53653Y",44,0) S @ROOT@(.01)="CD CONDITION SCORE NOT VALID" "RTN","DG53653Y",45,0) S @ROOT@(2)="CD 'CONDITION SCORE MUST BE A VALID ENTRY" "RTN","DG53653Y",46,0) S DGWP(1,0)="The exact criteria for the score are determined by the" "RTN","DG53653Y",47,0) S DGWP(2,0)="CATASTROPHIC DISABILITY REASONS file (#27.17). This file" "RTN","DG53653Y",48,0) S DGWP(3,0)="also contains the help text for responding to SCORE." "RTN","DG53653Y",49,0) Q "RTN","DG53653Y",50,0) ; "RTN","DG53653Y",51,0) 707 ;'CD Review Date' Greater Than 'CD Date Of Determination'. "RTN","DG53653Y",52,0) S @ROOT@(.01)="CD REVIEW DT AFTER DECISION DT" "RTN","DG53653Y",53,0) S @ROOT@(2)="CD REVIEW DATE IS AFTER DATE OF DECISION" "RTN","DG53653Y",54,0) S DGWP(1,0)="The Catastrophic Disability Review Date must be before " "RTN","DG53653Y",55,0) S DGWP(2,0)="the date of decision." "RTN","DG53653Y",56,0) Q "RTN","DG53653Y",57,0) ; "RTN","DG53653Y",58,0) 708 ;'CD Status Affected Extremity' Invalid "RTN","DG53653Y",59,0) S @ROOT@(.01)="CD AFFECTED EXTREMITY INVALID" "RTN","DG53653Y",60,0) S @ROOT@(2)="CD AFFECTED EXTREMITY IS INVALID" "RTN","DG53653Y",61,0) S DGWP(1,0)="If completed, AFFECTED EXTREMITY must be one of " "RTN","DG53653Y",62,0) S DGWP(2,0)="the following codes: " "RTN","DG53653Y",63,0) S DGWP(3,0)=" RUE:RIGHT UPPER EXTREMITY" "RTN","DG53653Y",64,0) S DGWP(4,0)=" LUE:LEFT UPPER EXTREMITY" "RTN","DG53653Y",65,0) S DGWP(5,0)=" RLE:RIGHT LOWER EXTREMITY" "RTN","DG53653Y",66,0) S DGWP(6,0)=" LLE:LEFT LOWER EXTREMITY" "RTN","DG53653Y",67,0) Q "RTN","DG53653Y",68,0) ; "RTN","DG53653Y",69,0) 709 ;'CD Status Diagnoses' Not Valid "RTN","DG53653Y",70,0) S @ROOT@(.01)="CD DIAGNOSIS IS NOT VALID" "RTN","DG53653Y",71,0) S @ROOT@(2)="CD STATUS DIAGNOSIS IS NOT VALID" "RTN","DG53653Y",72,0) S DGWP(1,0)="The status diagnosis must be a valid diagnosis in the " "RTN","DG53653Y",73,0) S DGWP(2,0)="CD Reasons File (#27.17)." "RTN","DG53653Y",74,0) Q "RTN","DG53653Y",75,0) ; "RTN","DG53653Y",76,0) 710 ;'CD Status Procedure' Not Valid "RTN","DG53653Y",77,0) S @ROOT@(.01)="CD PROCEDURE IS NOT VALID" "RTN","DG53653Y",78,0) S @ROOT@(2)="CD STATUS PROCEDURE IS NOT VALID" "RTN","DG53653Y",79,0) S DGWP(1,0)="The status procedure must be a valid procedure in the " "RTN","DG53653Y",80,0) S DGWP(2,0)="CD Reasons File (#27.17)." "RTN","DG53653Y",81,0) Q "RTN","DG53653Y",82,0) ; "RTN","DG53653Y",83,0) 711 ;'CD Status Reason' Not Present "RTN","DG53653Y",84,0) S @ROOT@(.01)="CD REASON IS NOT PRESENT" "RTN","DG53653Y",85,0) S @ROOT@(2)="CD STATUS REASON IS REQUIRED FOR EACH COND, DX AND PROC ENTERED" "RTN","DG53653Y",86,0) S DGWP(1,0)="A CD status reason is required for each CD " "RTN","DG53653Y",87,0) S DGWP(2,0)="Condition, Diagnosis and Procedure " "RTN","DG53653Y",88,0) S DGWP(3,0)="that is entered." "RTN","DG53653Y",89,0) Q "RTN","DG53653Y",90,0) ; "RTN","DG53653Y",91,0) 712 ;'Date Of Catastophic Disability Decision' Not Valid "RTN","DG53653Y",92,0) S @ROOT@(.01)="CD DATE OF DECISION NOT VALID" "RTN","DG53653Y",93,0) S @ROOT@(2)="CD DATE OF DECISION MUST BE A VALID DATE" "RTN","DG53653Y",94,0) S DGWP(1,0)="Enter the date the catastrophic disability determination was " "RTN","DG53653Y",95,0) S DGWP(2,0)="made. This must be a valid date." "RTN","DG53653Y",96,0) Q "RTN","DG53653Y",97,0) ; "RTN","DG53653Y",98,0) 713 ;'Date Of Catastophic Disability Decision' Required "RTN","DG53653Y",99,0) S @ROOT@(.01)="CD DATE OF DECISION REQUIRED" "RTN","DG53653Y",100,0) S @ROOT@(2)="CD DATE OF DECISION IS REQUIRED" "RTN","DG53653Y",101,0) S DGWP(1,0)="The 'Date of Catastrophic Disability Decision is required if the patient " "RTN","DG53653Y",102,0) S DGWP(2,0)="is catastrophically disabled. Enter the date the catastrophic disability " "RTN","DG53653Y",103,0) S DGWP(3,0)="determination was made. This must be a valid date." "RTN","DG53653Y",104,0) Q "RTN","DG53653Y",105,0) ; "RTN","DG53653Y",106,0) 714 ;'Facility Making Catastrophic Disability Determination' Not Valid "RTN","DG53653Y",107,0) S @ROOT@(.01)="CD FACILITY IS NOT VALID" "RTN","DG53653Y",108,0) S @ROOT@(2)="FACILITY MAKING CD DETERMINATION MUST BE A VALID FACILITY" "RTN","DG53653Y",109,0) S DGWP(1,0)="The Facility Making Catastrophic Disability Determination must be " "RTN","DG53653Y",110,0) S DGWP(2,0)="a valid facility and defined in the INSTITUTION file (#4)." "RTN","DG53653Y",111,0) Q "RTN","DG53653Y",112,0) ; "RTN","DG53653Y",113,0) 715 ;'Method Of Determination' Is A Required Value "RTN","DG53653Y",114,0) S @ROOT@(.01)="CD METHOD IS REQUIRED" "RTN","DG53653Y",115,0) S @ROOT@(2)="CD METHOD OF DETERMINATION IS REQUIRED" "RTN","DG53653Y",116,0) S DGWP(1,0)="Method of Determination is a required field. Possible values are:" "RTN","DG53653Y",117,0) S DGWP(2,0)=" 2:MEDICAL RECORD REVIEW:" "RTN","DG53653Y",118,0) S DGWP(3,0)=" 3:PHYSICAL EXAMINATION " "RTN","DG53653Y",119,0) S DGWP(4,0)="The valid codes may vary depending on the Institution." "RTN","DG53653Y",120,0) Q "RTN","DG53653Y",121,0) ; "RTN","DG53653Y",122,0) 716 ;'Method Of Determination' Not Valid "RTN","DG53653Y",123,0) S @ROOT@(.01)="CD METHOD IS NOT VALID" "RTN","DG53653Y",124,0) S @ROOT@(2)="CD METHOD OF DETERMINATION IS NOT VALID" "RTN","DG53653Y",125,0) S DGWP(1,0)="Method of Determination is a required field. Possible values are:" "RTN","DG53653Y",126,0) S DGWP(2,0)=" 2:MEDICAL RECORD REVIEW:" "RTN","DG53653Y",127,0) S DGWP(3,0)=" 3:PHYSICAL EXAMINATION " "RTN","DG53653Y",128,0) S DGWP(4,0)="The valid codes may vary depending on the Institution." "RTN","DG53653Y",129,0) Q "RTN","DG53653Y",130,0) ; "RTN","DG53653Y",131,0) 717 ;Not Enough Diagnoses/Procedures/Conditions To Qualify For CD Status "RTN","DG53653Y",132,0) S @ROOT@(.01)="CD NOT ENOUGH TO QUALIFY" "RTN","DG53653Y",133,0) S @ROOT@(2)="NOT ENOUGH DX/PROC/CON TO QUALIFY FOR CD STATUS" "RTN","DG53653Y",134,0) S DGWP(1,0)="Not Enough Diagnoses/Procedures/Conditions To " "RTN","DG53653Y",135,0) S DGWP(2,0)="qualify For CD Status'" "RTN","DG53653Y",136,0) Q "RTN","DG53653Y",137,0) ; "RTN","DG53653Y",138,0) 718 ;'Permanent Status Indicator' Not Valid "RTN","DG53653Y",139,0) S @ROOT@(.01)="CD PERMANENT INDICATOR INVALID" "RTN","DG53653Y",140,0) S @ROOT@(2)="CD PERMANENT STATUS INDICATOR SHOULD BE 1,2 OR 3" "RTN","DG53653Y",141,0) S DGWP(1,0)="The Permanent Status Indicator should be one of the following: " "RTN","DG53653Y",142,0) S DGWP(2,0)=" 1:PERMANENT" "RTN","DG53653Y",143,0) S DGWP(3,0)=" 2:NOT PERMANENT" "RTN","DG53653Y",144,0) S DGWP(4,0)=" 3:UNKNOWN " "RTN","DG53653Y",145,0) Q "RTN","DG53653Y",146,0) ; "RTN","DG53653Y",147,0) 719 ;'Veteran Catastrophically Disabled?' Field Must Have A Response "RTN","DG53653Y",148,0) S @ROOT@(.01)="CD STATUS UNSPECIFIED" "RTN","DG53653Y",149,0) S @ROOT@(2)="CD STATUS MUST BE SPECIFIED" "RTN","DG53653Y",150,0) S DGWP(1,0)="Indicate if the Veteran is Catastrophically Disabled." "RTN","DG53653Y",151,0) S DGWP(2,0)="This is a required field" "RTN","DG53653Y",152,0) Q "RTN","DG53653Y",153,0) ; "RTN","DG53653Y",154,0) 720 ;Veteran Has Enough Diagnoses/Procedures/Conditions To Qualify For CD Status "RTN","DG53653Y",155,0) S @ROOT@(.01)="CD ENOUGH TO QUALIFY" "RTN","DG53653Y",156,0) S @ROOT@(2)="PT HAS ENOUGH DX/PROC/COND TO QUALIFY FOR CD STATUS" "RTN","DG53653Y",157,0) S DGWP(1,0)="The Veteran Has Enough Diagnoses/Procedures/Conditions To Qualify For CD " "RTN","DG53653Y",158,0) S DGWP(2,0)="Status" "RTN","DG53653Y",159,0) Q "RTN","DG53653Y",160,0) 721 ; "RTN","DG53653Y",161,0) Q "RTN","DG53653Y",162,0) 722 ; "RTN","DG53653Y",163,0) Q "RTN","DG53653Y",164,0) ; "RTN","DG53653Y",165,0) 723 ;Catastrophic Disability Review Date is required to be a precise date "RTN","DG53653Y",166,0) S @ROOT@(.01)="CD REVIEW DATE MUST BE PRECISE" "RTN","DG53653Y",167,0) S @ROOT@(2)="CD REVIEW DATE MUST BE A PRECISE CALENDAR DATE" "RTN","DG53653Y",168,0) S DGWP(1,0)="Inconsistency results when the Review date is not a precise calendar date." "RTN","DG53653Y",169,0) Q "RTN","DG53653Y",170,0) ; "RTN","DG53653Y",171,0) 724 ;Catastrophic Disability Date of Decision is required to be a precise date "RTN","DG53653Y",172,0) S @ROOT@(.01)="CD DECISION DT MUST BE PRECISE" "RTN","DG53653Y",173,0) S @ROOT@(2)="CD DECISION DATE MUST BE A PRECISE CALENDAR DATE" "RTN","DG53653Y",174,0) S DGWP(1,0)="Inconsistency results when the Data of Decision is not a precise calendar date." "RTN","DG53653Y",175,0) Q "RTN","DG53653Y",176,0) ; "RTN","DG53653Y",177,0) 725 ;An Affected Extremity is required for each procedure code received for a Catastrophic Disabled Veteran "RTN","DG53653Y",178,0) S @ROOT@(.01)="CD EXTREMITY REQUIRED" "RTN","DG53653Y",179,0) S @ROOT@(2)="AFFECTED EXTREMITY IS REQUIRED FOR EACH PROCEDURE REC'D" "RTN","DG53653Y",180,0) S DGWP(1,0)="An Affected Extremity is required for each procedure code received " "RTN","DG53653Y",181,0) S DGWP(2,0)="for a Catastrophically Disabiled veteran" "RTN","DG53653Y",182,0) Q "RTN","DG53653Y",183,0) ; "RTN","DG53653Y",184,0) 726 ;A score is required for each condition code entered for catastrophically disabled determinations "RTN","DG53653Y",185,0) S @ROOT@(.01)="CD SCORE REQUIRED" "RTN","DG53653Y",186,0) S @ROOT@(2)="A VALID SCORE IS REQUIRED FOR EACH CONDITION CODE" "RTN","DG53653Y",187,0) S DGWP(1,0)="A score is required for each condition code entered for catastrophically " "RTN","DG53653Y",188,0) S DGWP(2,0)="disabled determinations " "RTN","DG53653Y",189,0) Q "RTN","DG53653Y",190,0) ; "RTN","DGCLEAR") 0^83^B1141198 "RTN","DGCLEAR",1,0) DGCLEAR ;ALB/CKN - REGISTRATION CROSS REFERENCE CLEANUP ; 10/6/06 4:09pm "RTN","DGCLEAR",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGCLEAR",3,0) ; "RTN","DGCLEAR",4,0) ; called from Z05 process to clear Permanent address before update "RTN","DGCLEAR",5,0) ; "RTN","DGCLEAR",6,0) EN(DGENDA) ; Entry point "RTN","DGCLEAR",7,0) ; Code to TRIGGER deletion of field data. "RTN","DGCLEAR",8,0) N DATA "RTN","DGCLEAR",9,0) D SETARR(.DATA) "RTN","DGCLEAR",10,0) Q $$UPD^DGENDBS(2,.DGENDA,.DATA) "RTN","DGCLEAR",11,0) ; "RTN","DGCLEAR",12,0) SETARR(DATA) ;Setup Data Array "RTN","DGCLEAR",13,0) N CNT,CURFILE,CTRYFLD,FDFLG,ADDTYPE,T,FTYPE,CURFTYPE "RTN","DGCLEAR",14,0) ; assemble array of fields to clear "RTN","DGCLEAR",15,0) F CNT=1:1 S T=$P($T(DTABLE+CNT),";;",3) Q:T="QUIT" D "RTN","DGCLEAR",16,0) . S DATA($P(T,";",3))=$P(T,";",4) "RTN","DGCLEAR",17,0) Q "RTN","DGCLEAR",18,0) DTABLE ;TABLE of Foreign and Domestic fields: structure -->>;;Description;;(P)ERMANENT;FILE;FIELD;DATA "RTN","DGCLEAR",19,0) ;;PERMANENT STREET [LINE 1];;P;2;.111;@ "RTN","DGCLEAR",20,0) ;;PERMANENT STREET [LINE 2];;P;2;.112;@ "RTN","DGCLEAR",21,0) ;;PERMANENT CITY;;P;2;.114;@ "RTN","DGCLEAR",22,0) ;;PERMANENT STATE;;P;2;.115;@ "RTN","DGCLEAR",23,0) ;;PERMANENT COUNTY;;P;2;.117;@ "RTN","DGCLEAR",24,0) ;;PERMANENT ZIP CODE;;P;2;.1112;@ "RTN","DGCLEAR",25,0) ;;PERMANENT BAD ADDRESS INDICATOR;;P;2;.121;@ "RTN","DGCLEAR",26,0) ;;QUIT;;QUIT "RTN","DGDDDTTM") 0^78^B4161602 "RTN","DGDDDTTM",1,0) DGDDDTTM ;ALB/MRL,BAJ - TRIGGER DT/TM CROSS REFERENCES [PATIENT] ; 05/18/2006 "RTN","DGDDDTTM",2,0) ;;5.3;Registration;**665,653**;Aug 13, 1993;Build 2 "RTN","DGDDDTTM",3,0) ; "RTN","DGDDDTTM",4,0) ; This routine contains the code for new style cross-reference record "RTN","DGDDDTTM",5,0) ; triggers for the PATIENT File #2. "RTN","DGDDDTTM",6,0) ; "RTN","DGDDDTTM",7,0) TEMP ; PATIENT File #2 Record Index: ADTTM1 "RTN","DGDDDTTM",8,0) ; "RTN","DGDDDTTM",9,0) ; This code updates the TEMPORARY ADDRESS CHANGE DT/TM field when any "RTN","DGDDDTTM",10,0) ; of the following Temporary Address related data changes for a patient: "RTN","DGDDDTTM",11,0) ; "RTN","DGDDDTTM",12,0) ; TEMPORARY STREET [LINE 1] (#.1211) "RTN","DGDDDTTM",13,0) ; TEMPORARY STREET [LINE 2] (#.1212) "RTN","DGDDDTTM",14,0) ; TEMPORARY STREET [LINE 3] (#.1213) "RTN","DGDDDTTM",15,0) ; TEMPORARY CITY (#.1214) "RTN","DGDDDTTM",16,0) ; TEMPORARY STATE (#.1215) "RTN","DGDDDTTM",17,0) ; TEMPORARY ZIP CODE (#.1216) "RTN","DGDDDTTM",18,0) ; TEMPORARY ADDRESS START DATE (#.1217) "RTN","DGDDDTTM",19,0) ; TEMPORARY ADDRESS END DATE (#.1218) "RTN","DGDDDTTM",20,0) ; TEMPORARY ADDRESS ACTIVE? (#.12105) "RTN","DGDDDTTM",21,0) ; TEMPORARY ZIP+4 (#.12112) "RTN","DGDDDTTM",22,0) ; "RTN","DGDDDTTM",23,0) N DGIEN,DATA S DATA(.12113)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",24,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",25,0) Q "RTN","DGDDDTTM",26,0) ; "RTN","DGDDDTTM",27,0) CONF ; PATIENT File #2 Record Index: ADTTM2 "RTN","DGDDDTTM",28,0) ; "RTN","DGDDDTTM",29,0) ; This code updates the CONFIDENTIAL ADDR CHANGE DT/TM field when any "RTN","DGDDDTTM",30,0) ; of the following Confidential Address related data changes for a "RTN","DGDDDTTM",31,0) ; patient: "RTN","DGDDDTTM",32,0) ; "RTN","DGDDDTTM",33,0) ; CONFIDENTIAL STREET [LINE 1] (#.1411) "RTN","DGDDDTTM",34,0) ; CONFIDENTIAL STREET [LINE 2] (#.1412) "RTN","DGDDDTTM",35,0) ; CONFIDENTIAL STREET [LINE 3] (#.1413) "RTN","DGDDDTTM",36,0) ; CONFIDENTIAL ADDRESS CITY (#.1414) "RTN","DGDDDTTM",37,0) ; CONFIDENTIAL ADDRESS STATE (#.1415) "RTN","DGDDDTTM",38,0) ; CONFIDENTIAL ADDRESS ZIP CODE (#.1416) "RTN","DGDDDTTM",39,0) ; CONFIDENTIAL START DATE (#.1417) "RTN","DGDDDTTM",40,0) ; CONFIDENTIAL END DATE (#.1418) "RTN","DGDDDTTM",41,0) ; CONFIDENTIAL ADDRESS ACTIVE? (#.14105) "RTN","DGDDDTTM",42,0) ; CONFIDENTIAL ADDRESS COUNTY (#.14111) "RTN","DGDDDTTM",43,0) ; "RTN","DGDDDTTM",44,0) N DGIEN,DATA S DATA(.14112)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",45,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",46,0) Q "RTN","DGDDDTTM",47,0) ; "RTN","DGDDDTTM",48,0) PNOK ; PATIENT File #2 Record Index: ADTTM3 "RTN","DGDDDTTM",49,0) ; "RTN","DGDDDTTM",50,0) ; This code updates the PRIMARY NOK CHANGE DATE/TIME field when any "RTN","DGDDDTTM",51,0) ; of the following Primary Next of Kin related data changes for a "RTN","DGDDDTTM",52,0) ; patient: "RTN","DGDDDTTM",53,0) ; "RTN","DGDDDTTM",54,0) ; K-NAME OF PRIMARY NOK (#.211) "RTN","DGDDDTTM",55,0) ; K-RELATIONSHIP TO PATIENT (#.212) "RTN","DGDDDTTM",56,0) ; K-STREET ADDRESS [LINE 1] (#.213) "RTN","DGDDDTTM",57,0) ; K-STREET ADDRESS [LINE 2] (#.214) "RTN","DGDDDTTM",58,0) ; K-STREET ADDRESS [LINE 3] (#.215) "RTN","DGDDDTTM",59,0) ; K-CITY (#.216) "RTN","DGDDDTTM",60,0) ; K-STATE (#.217) "RTN","DGDDDTTM",61,0) ; K-ZIP CODE (#.218) "RTN","DGDDDTTM",62,0) ; K-ADDRESS SAME AS PATIENT'S? (#.2125) "RTN","DGDDDTTM",63,0) ; K-ZIP+4 (#.2207) "RTN","DGDDDTTM",64,0) ; "RTN","DGDDDTTM",65,0) N DGIEN,DATA S DATA(.21012)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",66,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",67,0) Q "RTN","DGDDDTTM",68,0) ; "RTN","DGDDDTTM",69,0) SNOK ; PATIENT File #2 Record Index: ADTTM4 "RTN","DGDDDTTM",70,0) ; "RTN","DGDDDTTM",71,0) ; This code updates the SECONDARY NOK CHANGE DATE/TIME field when any "RTN","DGDDDTTM",72,0) ; of the following Secondary Next of Kin related data changes for a "RTN","DGDDDTTM",73,0) ; patient: "RTN","DGDDDTTM",74,0) ; "RTN","DGDDDTTM",75,0) ; K2-NAME OF SECONDARY NOK (#.2191) "RTN","DGDDDTTM",76,0) ; K2-RELATIONSHIP TO PATIENT (#.2192) "RTN","DGDDDTTM",77,0) ; K2-STREET ADDRESS [LINE 1] (#.2193) "RTN","DGDDDTTM",78,0) ; K2-STREET ADDRESS [LINE 2] (#.2194) "RTN","DGDDDTTM",79,0) ; K2-STREET ADDRESS [LINE 3] (#.2195) "RTN","DGDDDTTM",80,0) ; K2-CITY (#.2196) "RTN","DGDDDTTM",81,0) ; K2-STATE (#.2197) "RTN","DGDDDTTM",82,0) ; K2-ZIP CODE (#.2198) "RTN","DGDDDTTM",83,0) ; K2-ADDRESS SAME AS PATIENT'S? (#.21925) "RTN","DGDDDTTM",84,0) ; K2-ZIP+4 (#.2203) "RTN","DGDDDTTM",85,0) ; "RTN","DGDDDTTM",86,0) N DGIEN,DATA S DATA(.211012)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",87,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",88,0) Q "RTN","DGDDDTTM",89,0) ; "RTN","DGDDDTTM",90,0) ECON ; PATIENT File #2 Record Index: ADTTM5 "RTN","DGDDDTTM",91,0) ; "RTN","DGDDDTTM",92,0) ; This code updates the E-CONTACT CHANGE DATE/TIME field when any "RTN","DGDDDTTM",93,0) ; of the following Emergency Contact related data changes for a "RTN","DGDDDTTM",94,0) ; patient: "RTN","DGDDDTTM",95,0) ; "RTN","DGDDDTTM",96,0) ; E-NAME (#.331) "RTN","DGDDDTTM",97,0) ; E-RELATIONSHIP TO PATIENT (#.332) "RTN","DGDDDTTM",98,0) ; E-STREET ADDRESS [LINE 1] (#.333) "RTN","DGDDDTTM",99,0) ; E-STREET ADDRESS [LINE 2] (#.334) "RTN","DGDDDTTM",100,0) ; E-STREET ADDRESS [LINE 3] (#.335) "RTN","DGDDDTTM",101,0) ; E-CITY (#.336) "RTN","DGDDDTTM",102,0) ; E-STATE (#.337) "RTN","DGDDDTTM",103,0) ; E-ZIP CODE (#.338) "RTN","DGDDDTTM",104,0) ; E-EMER. CONTACT SAME AS NOK? (#.3305) "RTN","DGDDDTTM",105,0) ; E-ZIP+4 (#.2201) "RTN","DGDDDTTM",106,0) ; "RTN","DGDDDTTM",107,0) N DGIEN,DATA S DATA(.33012)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",108,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",109,0) Q "RTN","DGDDDTTM",110,0) ; "RTN","DGDDDTTM",111,0) ECON2 ; PATIENT File #2 Record Index: ADTTM6 "RTN","DGDDDTTM",112,0) ; "RTN","DGDDDTTM",113,0) ; This code updates the E2-CONTACT CHANGE DATE/TIME field when any "RTN","DGDDDTTM",114,0) ; of the following Secondary Emergency Contact related data changes "RTN","DGDDDTTM",115,0) ; for a patient: "RTN","DGDDDTTM",116,0) ; "RTN","DGDDDTTM",117,0) ; E2-NAME OF SECONDARY CONTACT (#.3311) "RTN","DGDDDTTM",118,0) ; E2-RELATIONSHIP TO PATIENT (#.3312) "RTN","DGDDDTTM",119,0) ; E2-STREET ADDRESS [LINE 1] (#.3313) "RTN","DGDDDTTM",120,0) ; E2-STREET ADDRESS [LINE 2] (#.3314) "RTN","DGDDDTTM",121,0) ; E2-STREET ADDRESS [LINE 3] (#.3315) "RTN","DGDDDTTM",122,0) ; E2-CITY (#.3316) "RTN","DGDDDTTM",123,0) ; E2-STATE (#.3317) "RTN","DGDDDTTM",124,0) ; E2-ZIP CODE (#.3318) "RTN","DGDDDTTM",125,0) ; E2-ZIP+4 (#.2204) "RTN","DGDDDTTM",126,0) ; "RTN","DGDDDTTM",127,0) N DGIEN,DATA S DATA(.33112)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",128,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",129,0) Q "RTN","DGDDDTTM",130,0) ; "RTN","DGDDDTTM",131,0) DESIG ; PATIENT File #2 Record Index: ADTTM7 "RTN","DGDDDTTM",132,0) ; "RTN","DGDDDTTM",133,0) ; This code updates the DESIGNEE CHANGE DATE/TIME field when any "RTN","DGDDDTTM",134,0) ; of the following Designee related data changes for a patient: "RTN","DGDDDTTM",135,0) ; "RTN","DGDDDTTM",136,0) ; D-NAME OF DESIGNEE (#.341) "RTN","DGDDDTTM",137,0) ; D-RELATIONSHIP TO PATIENT (#.342) "RTN","DGDDDTTM",138,0) ; D-STREET ADDRESS [LINE 1] (#.343) "RTN","DGDDDTTM",139,0) ; D-STREET ADDRESS [LINE 2] (#.344) "RTN","DGDDDTTM",140,0) ; D-STREET ADDRESS [LINE 3] (#.345) "RTN","DGDDDTTM",141,0) ; D-CITY (#.346) "RTN","DGDDDTTM",142,0) ; D-STATE (#.347) "RTN","DGDDDTTM",143,0) ; D-ZIP CODE (#.348) "RTN","DGDDDTTM",144,0) ; D-DESIGNEE SAME AS NOK? (#.3405) "RTN","DGDDDTTM",145,0) ; D-ZIP+4 (#.2202) "RTN","DGDDDTTM",146,0) ; "RTN","DGDDDTTM",147,0) N DGIEN,DATA S DATA(.3412)=$$NOW^XLFDT(),DGIEN=DA "RTN","DGDDDTTM",148,0) I $$UPD^DGENDBS(2,.DGIEN,.DATA) "RTN","DGDDDTTM",149,0) Q "RTN","DGDEP0") 0^61^B12397379 "RTN","DGDEP0",1,0) DGDEP0 ;ALB/CAW,JAN,ERC Dependent Driver (con't) ; 10/27/05 9:59am "RTN","DGDEP0",2,0) ;;5.3;Registration;**45,60,395,624,653**;Aug 13, 1993;Build 2 "RTN","DGDEP0",3,0) ; "RTN","DGDEP0",4,0) RETDEP ;Return printable data of dependents "RTN","DGDEP0",5,0) Q:'$D(DGDEP("DGDEP",$J)) "RTN","DGDEP0",6,0) N ACT,ACTIVE,CNT,CNTR,DEP,DGII,DGX,EDATE,INCOME,INCPER,MORE,NAME,RELATE "RTN","DGDEP0",7,0) F DGII=0:0 S DGII=$O(DGDEP(DGII)) Q:'DGII K DGDEP(DGII) ; clear dependent array "RTN","DGDEP0",8,0) S RELATE=0,CNT=1 "RTN","DGDEP0",9,0) ; "RTN","DGDEP0",10,0) F S RELATE=$O(DGDEP("DGDEP",$J,RELATE)) Q:'RELATE D "RTN","DGDEP0",11,0) .; "RTN","DGDEP0",12,0) .S MORE=0 "RTN","DGDEP0",13,0) .F S MORE=$O(DGDEP("DGDEP",$J,RELATE,MORE)) Q:'MORE S DEP=DGDEP("DGDEP",$J,RELATE,MORE) D S CNT=CNT+1,DGCNT=CNT-1 "RTN","DGDEP0",14,0) ..; "RTN","DGDEP0",15,0) ..S $P(DGDEP(CNT),U,2)=$P($G(^DG(408.11,RELATE,0)),U) "RTN","DGDEP0",16,0) ..S NAME=$P(DEP,U),$P(DGDEP(CNT),U)=$P(DEP,U) "RTN","DGDEP0",17,0) ..S $P(DGDEP(CNT),U,3)=$S($P(DEP,U,2)="M":"Male",$P(DEP,U,2)="F":"Female",1:"Unknown"),$P(DGDEP(CNT),U,20)=$P(DEP,U,20) "RTN","DGDEP0",18,0) ..S $P(DGDEP(CNT),U,21)=$P(DEP,U,21),$P(DGDEP(CNT),U,22)=$P(DEP,U,22) "RTN","DGDEP0",19,0) ..N Y S Y=$P(DEP,U,3) D DD^%DT S $P(DGDEP(CNT),U,4)=Y "RTN","DGDEP0",20,0) ..; "RTN","DGDEP0",21,0) ..I $P(DEP,U,9) D "RTN","DGDEP0",22,0) ... N T S $P(DGDEP(CNT),U,5)=$E($P(DEP,U,9),1,3)_"-"_$E($P(DEP,U,9),4,5)_"-"_$E($P(DEP,U,9),6,10) "RTN","DGDEP0",23,0) ...;set 10th piece to value of Pseudo SSN Reason, if there is one "RTN","DGDEP0",24,0) ...;for DG*5.3*653 - ERC "RTN","DGDEP0",25,0) ...S $P(DGDEP(CNT),U,10)=$S($P(DEP,U,10)="R":"Refused to Provide",$P(DEP,U,10)="S":"SSN Unknown/Follow-up Required",$P(DEP,U,10)="N":"NO SSN ASSIGNED",1:"") "RTN","DGDEP0",26,0) ..; "RTN","DGDEP0",27,0) ..S INCOME=$P(DGDEP("DGDEP",$J,RELATE,MORE),U,21) "RTN","DGDEP0",28,0) ..S INCPER=$P(DGDEP("DGDEP",$J,RELATE,MORE),U,22) "RTN","DGDEP0",29,0) ..I RELATE>1 S DGDEP(CNT,"MNADD")=$$SPDEPADD(INCPER) "RTN","DGDEP0",30,0) ..I RELATE=1 D SELF("",NAME,RELATE,"",DGDEP(1),$G(DGMTI),CNT) "RTN","DGDEP0",31,0) ..S ACT=$O(DGDEP("DGDEP",$J,RELATE,MORE,"")) Q:'ACT S ACT=DGDEP("DGDEP",$J,RELATE,MORE,+ACT) "RTN","DGDEP0",32,0) ..I RELATE=1 D SELF(INCPER,NAME,RELATE,ACT,DGDEP(1),$G(DGMTI),CNT) "RTN","DGDEP0",33,0) ..I RELATE=2 D DEP(INCPER,NAME,RELATE,ACT,DGDEP(CNT),$G(DGMTI),$G(DGMTACT),CNT) "RTN","DGDEP0",34,0) ..I RELATE>2 D DEP(INCPER,NAME,RELATE,ACT,DGDEP(CNT),$G(DGMTI),$G(DGMTACT),CNT) "RTN","DGDEP0",35,0) ..S EDATE="",CNTR=0 "RTN","DGDEP0",36,0) ..F S EDATE=$O(DGDEP("DGDEP",$J,RELATE,MORE,EDATE)) Q:EDATE']"" S ACTIVE=DGDEP("DGDEP",$J,RELATE,MORE,EDATE) D "RTN","DGDEP0",37,0) ...; "RTN","DGDEP0",38,0) ...N Y S Y=+ACTIVE D DD^%DT S DGDEP(CNT,EDATE)=Y "RTN","DGDEP0",39,0) ...S $P(DGDEP(CNT,EDATE),U,2)=$S($P(ACTIVE,U,2)=1:"Active",1:"Inactive") "RTN","DGDEP0",40,0) ...S $P(DGDEP(CNT,EDATE),U,3)=$P(ACTIVE,U,3) "RTN","DGDEP0",41,0) K DGDEP("DGDEP",$J) "RTN","DGDEP0",42,0) Q "RTN","DGDEP0",43,0) ; "RTN","DGDEP0",44,0) SELF(INCPER,NAME,RELATE,ACT,DGDEP,DGMTI,CNT) ; "RTN","DGDEP0",45,0) I $G(DGMTI),$G(DGMTACT)="VEW" G SELFQ "RTN","DGDEP0",46,0) I $G(DGMTI) D ADD^DGDEP2(DFN,DGDEP,DGMTI) "RTN","DGDEP0",47,0) SELFQ I INCPER>0 D SELF^DGDEP3(INCPER,NAME,RELATE,ACT,$G(DGMTI),CNT) "RTN","DGDEP0",48,0) Q "RTN","DGDEP0",49,0) ; "RTN","DGDEP0",50,0) DEP(INCPER,NAME,RELATE,ACT,DGDEP,DGMTI,DGMTACT,CNT) ; "RTN","DGDEP0",51,0) ; "RTN","DGDEP0",52,0) I $G(DGMTI),$G(DGMTACT)="VEW" G DEP1 "RTN","DGDEP0",53,0) I $G(DGMTI),$P(ACT,U,2),$G(DGMTACT)="ADD",'$G(DGREMOVE) D ADD^DGDEP2(DFN,DGDEP,DGMTI) "RTN","DGDEP0",54,0) DEP1 I RELATE=2 D SELF^DGDEP3(INCPER,NAME,RELATE,ACT,$G(DGMTI),CNT) G DEPQ "RTN","DGDEP0",55,0) I INCPER>0 D CHILD^DGDEP3(INCPER,NAME,RELATE,ACT,$G(DGMTI),$G(DGMTACT),CNT) "RTN","DGDEP0",56,0) DEPQ Q "RTN","DGDEP0",57,0) ; "RTN","DGDEP0",58,0) SPDEPADD(INCPER) ;Return Spouse/Dependent Maiden Name and Address info "RTN","DGDEP0",59,0) N ADDCKVAL,INDAIIEN,PRIEN,IPIEN,SPDEPINF "RTN","DGDEP0",60,0) S INDAIIEN=$P($G(^DGMT(408.22,INCPER,0)),"^",2) "RTN","DGDEP0",61,0) S PRIEN=$P($G(^DGMT(408.21,INDAIIEN,0)),"^",2) "RTN","DGDEP0",62,0) S IPIEN=$P($G(^DGPR(408.12,PRIEN,0)),"^",3) "RTN","DGDEP0",63,0) I IPIEN["DGPR(408.13" DO "RTN","DGDEP0",64,0) . S IPIEN=$P(IPIEN,";",1) "RTN","DGDEP0",65,0) . S SPDEPINF=$P($G(^DGPR(408.13,IPIEN,1)),"^",1,8) "RTN","DGDEP0",66,0) Q SPDEPINF "RTN","DGDEP1") 0^62^B26014891 "RTN","DGDEP1",1,0) DGDEP1 ;ALB/CAW,ERC List One Dependent/Edit Effective Dates ; 9/29/05 8:11am "RTN","DGDEP1",2,0) ;;5.3;Registration;**45,60,624,653**;Aug 13, 1993;Build 2 "RTN","DGDEP1",3,0) ; "RTN","DGDEP1",4,0) LSTDEP(DGDEP) ;List Dependents "RTN","DGDEP1",5,0) N DEP,CNT S CNT=0 "RTN","DGDEP1",6,0) F S CNT=$O(DGDEP(CNT)) Q:'CNT D ONE(CNT) "RTN","DGDEP1",7,0) Q "RTN","DGDEP1",8,0) ; "RTN","DGDEP1",9,0) ONE(CNT) ; List one dependent "RTN","DGDEP1",10,0) ; "RTN","DGDEP1",11,0) N DGLN S DGLN=1 "RTN","DGDEP1",12,0) ; "RTN","DGDEP1",13,0) S X="",X=$$SETSTR^VALM1("DOB: ",X,5,5) "RTN","DGDEP1",14,0) S X=$$SETSTR^VALM1($P(DGDEP(CNT),U,4),X,10,14) "RTN","DGDEP1",15,0) S X=$$SETSTR^VALM1("Sex: ",X,30,5) "RTN","DGDEP1",16,0) S X=$$SETSTR^VALM1($P(DGDEP(CNT),U,3),X,35,8) "RTN","DGDEP1",17,0) S X=$$SETSTR^VALM1("SSN: ",X,52,5) "RTN","DGDEP1",18,0) S X=$$SETSTR^VALM1($P(DGDEP(CNT),U,5),X,57,14) "RTN","DGDEP1",19,0) D SET(X) "RTN","DGDEP1",20,0) ; "RTN","DGDEP1",21,0) ;* Output Spouse' Maiden Name, if defined (DG*5.3*624) "RTN","DGDEP1",22,0) S X="" "RTN","DGDEP1",23,0) I $P($G(DGDEP(CNT)),U,2)="SPOUSE" DO "RTN","DGDEP1",24,0) . N DGMNTEXT "RTN","DGDEP1",25,0) . S X=$$SETSTR^VALM1("Maiden: ",X,2,8) "RTN","DGDEP1",26,0) . S DGMNTEXT=$P($G(DGDEP(CNT,"MNADD")),U,1) "RTN","DGDEP1",27,0) . S:DGMNTEXT]"" X=$$SETSTR^VALM1(DGMNTEXT,X,10,30) "RTN","DGDEP1",28,0) . S:DGMNTEXT']"" X=$$SETSTR^VALM1("UNANSWERED",X,10,10) "RTN","DGDEP1",29,0) ;display PSSN Reason if SSN is a pseudo - DG*5.3*653 "RTN","DGDEP1",30,0) I $P($G(DGDEP(CNT)),U,2)'="SELF",($P(DGDEP(CNT),U,5)["P") D "RTN","DGDEP1",31,0) . S X=$$SETSTR^VALM1("PSSN Reason: ",X,44,15) "RTN","DGDEP1",32,0) . I $P(DGDEP(CNT),U,10)["Unk" S $P(DGDEP(CNT),U,10)="SSN Unkn/Follow-up Req" "RTN","DGDEP1",33,0) . S X=$$SETSTR^VALM1($P(DGDEP(CNT),U,10),X,57,22) "RTN","DGDEP1",34,0) D SET(X) "RTN","DGDEP1",35,0) S DEP="" "RTN","DGDEP1",36,0) F S DEP=$O(DGDEP(CNT,DEP)) Q:DEP']"" D "RTN","DGDEP1",37,0) .I DEP'="MNADD" DO "RTN","DGDEP1",38,0) ..S X="",X=$$SETSTR^VALM1("Status: ",X,2,8) "RTN","DGDEP1",39,0) ..S X=$$SETSTR^VALM1($P(DGDEP(CNT,DEP),U,2),X,10,24) "RTN","DGDEP1",40,0) ..S X=$$SETSTR^VALM1("Effective Date: ",X,41,15) "RTN","DGDEP1",41,0) ..S X=$$SETSTR^VALM1($P(DGDEP(CNT,DEP),U),X,57,20) "RTN","DGDEP1",42,0) ..D SET(X) "RTN","DGDEP1",43,0) ..I $P(DGDEP(CNT,DEP),U,3) D "RTN","DGDEP1",44,0) ...S X="",X=$$SETSTR^VALM1("Filed by IVM: ",X,43,14) "RTN","DGDEP1",45,0) ...S X=$$SETSTR^VALM1("Yes",X,57,20) "RTN","DGDEP1",46,0) ...D SET(X) "RTN","DGDEP1",47,0) ..D SET("") "RTN","DGDEP1",48,0) S VALMCNT=DGLN-1 "RTN","DGDEP1",49,0) ; "RTN","DGDEP1",50,0) S X="" "RTN","DGDEP1",51,0) S X=$$SETSTR^VALM1("Address: ",X,1,9) "RTN","DGDEP1",52,0) S:($P($G(DGDEP(CNT,"MNADD")),U,2,7)="^^^^^") X=$$SETSTR^VALM1("UNANSWERED",X,10,10) "RTN","DGDEP1",53,0) S:($P($G(DGDEP(CNT,"MNADD")),U,2,7)'="^^^^^") X=$$SETSTR^VALM1($P($G(DGDEP(CNT,"MNADD")),U,2),X,10,35) "RTN","DGDEP1",54,0) S X=$$SETSTR^VALM1("Phone: ",X,50,7) "RTN","DGDEP1",55,0) S:($P($G(DGDEP(CNT,"MNADD")),U,8)="") X=$$SETSTR^VALM1("UNANSWERED",X,57,10) "RTN","DGDEP1",56,0) S:($P($G(DGDEP(CNT,"MNADD")),U,8)'="") X=$$SETSTR^VALM1($P($G(DGDEP(CNT,"MNADD")),U,8),X,57,13) "RTN","DGDEP1",57,0) D SET(X) "RTN","DGDEP1",58,0) ; "RTN","DGDEP1",59,0) ;* Output dependent address (DG*5.3*624) "RTN","DGDEP1",60,0) I ($P($G(DGDEP(CNT,"MNADD")),U,2,7)'="^^^^^") DO "RTN","DGDEP1",61,0) .S X="" "RTN","DGDEP1",62,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,3)'="") X=$$SETSTR^VALM1($P($G(DGDEP(CNT,"MNADD")),U,3),X,10,30) "RTN","DGDEP1",63,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,3)="") X=$$SETSTR^VALM1(" ",X,10,1) "RTN","DGDEP1",64,0) .D SET(X) "RTN","DGDEP1",65,0) .S X="" "RTN","DGDEP1",66,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,4)'="") X=$$SETSTR^VALM1($P($G(DGDEP(CNT,"MNADD")),U,4),X,10,30) "RTN","DGDEP1",67,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,4)="") X=$$SETSTR^VALM1(" ",X,10,1) "RTN","DGDEP1",68,0) .D SET(X) "RTN","DGDEP1",69,0) .S X="" "RTN","DGDEP1",70,0) .I ($P($G(DGDEP(CNT,"MNADD")),U,5)'="") DO "RTN","DGDEP1",71,0) ..S X=$$SETSTR^VALM1($P($G(DGDEP(CNT,"MNADD")),U,5),X,10,30) "RTN","DGDEP1",72,0) ..S X=$$SETSTR^VALM1(",",X,($L($P($G(DGDEP(CNT,"MNADD")),U,5))+10),1) "RTN","DGDEP1",73,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,5)="") X=$$SETSTR^VALM1(" ",X,10,1) "RTN","DGDEP1",74,0) .N STATVAL,ZIPPOS "RTN","DGDEP1",75,0) .S STATVAL="" "RTN","DGDEP1",76,0) .I ($P($G(DGDEP(CNT,"MNADD")),U,6)'="") DO "RTN","DGDEP1",77,0) ..S STATVAL=$P(^DIC(5,$P($G(DGDEP(CNT,"MNADD")),U,6),0),"^",1) "RTN","DGDEP1",78,0) ..S X=$$SETSTR^VALM1(STATVAL,X,($L($P($G(DGDEP(CNT,"MNADD")),U,5))+12),30) "RTN","DGDEP1",79,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,6)="") X=$$SETSTR^VALM1(" ",X,41,1) "RTN","DGDEP1",80,0) .;;D SET(X) "RTN","DGDEP1",81,0) .;;S X="" "RTN","DGDEP1",82,0) .I ($P($G(DGDEP(CNT,"MNADD")),U,7)'="") DO "RTN","DGDEP1",83,0) ..S ZIPPOS=($L($P($G(DGDEP(CNT,"MNADD")),U,5))+($L(STATVAL))+14) "RTN","DGDEP1",84,0) ..S X=$$SETSTR^VALM1($P($G(DGDEP(CNT,"MNADD")),U,7),X,ZIPPOS,10) "RTN","DGDEP1",85,0) .S:($P($G(DGDEP(CNT,"MNADD")),U,7)="") X=$$SETSTR^VALM1(" ",X,20,1) "RTN","DGDEP1",86,0) .D SET(X) "RTN","DGDEP1",87,0) ; "RTN","DGDEP1",88,0) S VALMCNT=DGLN-1 "RTN","DGDEP1",89,0) Q "RTN","DGDEP1",90,0) ; "RTN","DGDEP1",91,0) SET(X) ;Set up array "RTN","DGDEP1",92,0) S ^TMP("DGMTEP",$J,DGLN,0)=X "RTN","DGDEP1",93,0) S DGLN=DGLN+1 "RTN","DGDEP1",94,0) Q "RTN","DGDEP1",95,0) ; "RTN","DGDEP1",96,0) EXIT ; "RTN","DGDEP1",97,0) K ^TMP("DGMTEP",$J) "RTN","DGDEP1",98,0) Q "RTN","DGDEP1",99,0) ; "RTN","DGDEP1",100,0) EN ; Effective Dates "RTN","DGDEP1",101,0) S VALMBCK="" "RTN","DGDEP1",102,0) I $D(DGMTI),$G(DGMTACT)="VEW" W !,"Cannot edit when viewing a means test." H 2 G ENQ "RTN","DGDEP1",103,0) I '$D(DGMTI),$G(DGRPV)=1 W !,"Not while viewing" H 2 G ENQ "RTN","DGDEP1",104,0) D EDIT "RTN","DGDEP1",105,0) I DGW=1 D I $G(DGERR) W !,"Cannot inactivate veteran" K DGERR G EN "RTN","DGDEP1",106,0) .S DATE=$O(DGDEP(1,"")) "RTN","DGDEP1",107,0) .S ACTIVE=$P(DGDEP(1,DATE),U,2) "RTN","DGDEP1",108,0) .I ACTIVE="Inactive" S DGERR=1 "RTN","DGDEP1",109,0) ENQ S VALMBCK="R" "RTN","DGDEP1",110,0) Q "RTN","DGDEP1",111,0) ; "RTN","DGDEP1",112,0) EDIT ; Edit Effective Dates "RTN","DGDEP1",113,0) ; values for DGFLG: "RTN","DGDEP1",114,0) ; DGFLG = 1 IVM effective date "RTN","DGDEP1",115,0) ; "RTN","DGDEP1",116,0) N DA,DR,DIE,DIC,DATE,DGEDIT,DGEE,Y "RTN","DGDEP1",117,0) S DGFLG=0,DGEDIT=1 "RTN","DGDEP1",118,0) S DGPR=$S($G(DGW):$P(DGDEP(DGW),U,20),1:$P(DGDEP,U,20)) "RTN","DGDEP1",119,0) S DIE="^DGPR(408.12,",DA=DGPR,DR="75" "RTN","DGDEP1",120,0) S DR(2,408.1275)="I $P($G(^DGPR(408.12,DGPR,""E"",DA,0)),U,3) S Y=0,DGFLG=1;S:$P($G(^DGPR(408.12,DGPR,""E"",DA,0)),U,2)']"""" DIE(""NO^"")="""";.01;.02" "RTN","DGDEP1",121,0) D ^DIE "RTN","DGDEP1",122,0) I DGFLG W !!,"Cannot edit date added by IVM." H 2 G EDITQ "RTN","DGDEP1",123,0) S DATE=0,DATE=$O(^DGPR(408.12,$P(DGDEP(DGW),U,20),"E",DATE)) "RTN","DGDEP1",124,0) I 'DATE W !!,"There has to be an effective date for this person." H 2 G EDIT "RTN","DGDEP1",125,0) EDITQ K DGDEP,DGFLG D INIT^DGDEP "RTN","DGDEP1",126,0) K ^TMP("DGMTEP",$J) D ONE(DGW) "RTN","DGDEP1",127,0) Q "RTN","DGDEP1",128,0) ; "RTN","DGDEP1",129,0) DOB(DA,X) ;CHECK EFFECTIVE DATE AGAINST DOB "RTN","DGDEP1",130,0) N DGFILE,X1 "RTN","DGDEP1",131,0) S DGFILE=$P($G(^DGPR(408.12,DA,0)),U,3),X1=$P(DGFILE,";"),DGFILE=$S(DGFILE["DGPR":"^DGPR(408.13,",1:"^DPT(") "RTN","DGDEP1",132,0) I X<$P($G(@(DGFILE_X1_",0)")),U,3) D "RTN","DGDEP1",133,0) . W !," <>",*7 "RTN","DGDEP1",134,0) . S X=0 "RTN","DGDEP1",135,0) Q X "RTN","DGDEP3") 0^63^B24479543 "RTN","DGDEP3",1,0) DGDEP3 ;ALB/CAW,ERC - Dependents display ; 11/3/05 9:42am "RTN","DGDEP3",2,0) ;;5.3;Registration;**45,624,653**;Aug 13, 1993;Build 2 "RTN","DGDEP3",3,0) ; "RTN","DGDEP3",4,0) SELF(INCPER,NAME,RELATE,ACT,DGMTI,CNT) ; Display information concerning veteran "RTN","DGDEP3",5,0) ; "RTN","DGDEP3",6,0) S DGX="",DGX=$$SETSTR^VALM1(CNT,DGX,3,3) "RTN","DGDEP3",7,0) I $G(DGMTI),INCPER,($P($G(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI) S DGX=$$SETSTR^VALM1("*",DGX,5,1) "RTN","DGDEP3",8,0) S DGX=$$SETSTR^VALM1(NAME,DGX,9,22) "RTN","DGDEP3",9,0) S DGX=$$SETSTR^VALM1($P($G(^DG(408.11,RELATE,0)),U),DGX,32,30) "RTN","DGDEP3",10,0) S DGX=$$SETSTR^VALM1($S($P(ACT,U,2)=1:"*",1:""),DGX,65,1) "RTN","DGDEP3",11,0) S:RELATE=2 DGX=$$SETSTR^VALM1($S(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1) "RTN","DGDEP3",12,0) D SET^DGDEP(DGX) "RTN","DGDEP3",13,0) ; "RTN","DGDEP3",14,0) I RELATE=2 D "RTN","DGDEP3",15,0) . S DGX="",DGX=$$SETSTR^VALM1($P(DGDEP,"^",5),DGX,9,14) "RTN","DGDEP3",16,0) . ;if a Pseudo SSN need Pseudo SSN Reason - DG*5.3*653, ERC "RTN","DGDEP3",17,0) . I $P(DGDEP,U,5)["P" D "RTN","DGDEP3",18,0) . . S DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15) "RTN","DGDEP3",19,0) . . S DGX=$$SETSTR^VALM1($P(DGDEP,U,10),DGX,45,30) "RTN","DGDEP3",20,0) . . ;D SET^DGDEP(DGX) "RTN","DGDEP3",21,0) . D SET^DGDEP(DGX) "RTN","DGDEP3",22,0) ; "RTN","DGDEP3",23,0) Q:RELATE=2 "RTN","DGDEP3",24,0) S INCPER=^DGMT(408.22,INCPER,0) "RTN","DGDEP3",25,0) S DGX="",DGX=$$SETSTR^VALM1("Married Last Year: ",DGX,18,19) "RTN","DGDEP3",26,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,5):"Yes",$P(INCPER,U,5)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",27,0) D SET^DGDEP(DGX) "RTN","DGDEP3",28,0) ; "RTN","DGDEP3",29,0) Q:'$G(DGMTI) "RTN","DGDEP3",30,0) I $P(INCPER,U,5)=1 D "RTN","DGDEP3",31,0) .S DGX="",DGX=$$SETSTR^VALM1("Lived with Spouse: ",DGX,18,19) "RTN","DGDEP3",32,0) .S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6):"Yes",$P(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",33,0) .D SET^DGDEP(DGX) "RTN","DGDEP3",34,0) ; "RTN","DGDEP3",35,0) I $P(INCPER,U,6)=0 D "RTN","DGDEP3",36,0) .S DGX="",DGX=$$SETSTR^VALM1("Amount Contributed: ",DGX,17,19) "RTN","DGDEP3",37,0) .S DGX=$$SETSTR^VALM1($S($P(INCPER,U,7)]"":$P(INCPER,U,7),1:"Unanswered"),DGX,38,10) "RTN","DGDEP3",38,0) .D SET^DGDEP(DGX) "RTN","DGDEP3",39,0) Q "RTN","DGDEP3",40,0) ; "RTN","DGDEP3",41,0) CHILD(INCPER,NAME,RELATE,ACT,DGMTI,DGMTACT,CNT) ; Display information concerning dependents "RTN","DGDEP3",42,0) ; "RTN","DGDEP3",43,0) S DGX="",DGX=$$SETSTR^VALM1(CNT,DGX,3,3) "RTN","DGDEP3",44,0) I $G(DGMTI),INCPER,($P($G(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI) S DGX=$$SETSTR^VALM1("*",DGX,5,1) "RTN","DGDEP3",45,0) S DGX=$$SETSTR^VALM1(NAME,DGX,9,22) "RTN","DGDEP3",46,0) S DGX=$$SETSTR^VALM1($P($G(^DG(408.11,RELATE,0)),U),DGX,32,30) "RTN","DGDEP3",47,0) S DGX=$$SETSTR^VALM1($S($P(ACT,U,2)=1:"*",1:""),DGX,65,1) "RTN","DGDEP3",48,0) S DGX=$$SETSTR^VALM1($S(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1) "RTN","DGDEP3",49,0) D SET^DGDEP(DGX) "RTN","DGDEP3",50,0) ; "RTN","DGDEP3",51,0) S DGX="",DGX=$$SETSTR^VALM1($P(DGDEP,"^",5),DGX,9,14) "RTN","DGDEP3",52,0) I $P(DGDEP,U,5)["P" D "RTN","DGDEP3",53,0) . S DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15) "RTN","DGDEP3",54,0) . S DGX=$$SETSTR^VALM1($P(DGDEP,U,10),DGX,45,30) "RTN","DGDEP3",55,0) D SET^DGDEP(DGX) "RTN","DGDEP3",56,0) ; "RTN","DGDEP3",57,0) Q:'$G(DGMTI)!('$P($G(^DG(408.11,RELATE,0)),U,4)) "RTN","DGDEP3",58,0) S INCPER=^DGMT(408.22,INCPER,0) "RTN","DGDEP3",59,0) S DGX="",DGX=$$SETSTR^VALM1("Incapable of Self-support: ",DGX,10,27) "RTN","DGDEP3",60,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,9):"Yes",$P(INCPER,U,9)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",61,0) D SET^DGDEP(DGX) "RTN","DGDEP3",62,0) ; "RTN","DGDEP3",63,0) ;* DG*5.3*624 "RTN","DGDEP3",64,0) S DGX="",DGX=$$SETSTR^VALM1("Child 18 to 23. Attended School: ",DGX,4,33) "RTN","DGDEP3",65,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,18):"Yes",$P(INCPER,U,18)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",66,0) D SET^DGDEP(DGX) "RTN","DGDEP3",67,0) ; "RTN","DGDEP3",68,0) S DGX="",DGX=$$SETSTR^VALM1("Child lived with you: ",DGX,15,22) "RTN","DGDEP3",69,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6):"Yes",$P(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",70,0) D SET^DGDEP(DGX) "RTN","DGDEP3",71,0) ; "RTN","DGDEP3",72,0) S DGX="",DGX=$$SETSTR^VALM1("Child Support: ",DGX,22,15) "RTN","DGDEP3",73,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6)=1:"N/A",$P(INCPER,U,10)=1:"Yes",$P(INCPER,U,10)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",74,0) D SET^DGDEP(DGX) "RTN","DGDEP3",75,0) ; "RTN","DGDEP3",76,0) ;* DG*5.3*624 "RTN","DGDEP3",77,0) S DGX="",DGX=$$SETSTR^VALM1("Amount contributed: ",DGX,17,20) "RTN","DGDEP3",78,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,10)'=1:"N/A",($P(INCPER,U,19)'="0")&($P(INCPER,U,19)'=""):$P(INCPER,U,19),$P(INCPER,U,19)="":"Unanswered",1:"0"),DGX,38,10) "RTN","DGDEP3",79,0) D SET^DGDEP(DGX) "RTN","DGDEP3",80,0) ; "RTN","DGDEP3",81,0) S DGX="",DGX=$$SETSTR^VALM1("Child Has Income: ",DGX,19,18) "RTN","DGDEP3",82,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,11)=1:"Yes",$P(INCPER,U,11)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",83,0) D SET^DGDEP(DGX) "RTN","DGDEP3",84,0) ; "RTN","DGDEP3",85,0) S DGX="",DGX=$$SETSTR^VALM1("Income Available: ",DGX,19,18) "RTN","DGDEP3",86,0) S DGX=$$SETSTR^VALM1($S($P(INCPER,U,11)=0:"N/A",$P(INCPER,U,12)=1:"Yes",$P(INCPER,U,12)="":"Unanswered",1:"No"),DGX,38,10) "RTN","DGDEP3",87,0) D SET^DGDEP(DGX) "RTN","DGDEP3",88,0) CHILDQ Q "RTN","DGDEP3",89,0) ; "RTN","DGDEP3",90,0) ADDCHK(INCPER) ; Indicates existence of any dependent address "RTN","DGDEP3",91,0) ; Input: "RTN","DGDEP3",92,0) ; INCPER - Pointer to dep. entry in Income Relation file (408.22) "RTN","DGDEP3",93,0) ; "RTN","DGDEP3",94,0) ; Output: "RTN","DGDEP3",95,0) ; both address and phone^address^phone "RTN","DGDEP3",96,0) ; KEY: "RTN","DGDEP3",97,0) ; 0 - No data exists for the dependent in 408.13 "RTN","DGDEP3",98,0) ; 1 - Data exists for the dependent in 408.13 "RTN","DGDEP3",99,0) ; "RTN","DGDEP3",100,0) ; 1^1^1 - Address and Phone data exist for dependent "RTN","DGDEP3",101,0) ; 0^1^0 - Address only exists for dependent "RTN","DGDEP3",102,0) ; 0^0^1 - Phone only exists for dependent "RTN","DGDEP3",103,0) ; 0^0^0 - Neither Phone nor Address data exists for dependent "RTN","DGDEP3",104,0) ; "RTN","DGDEP3",105,0) N ADDCKVAL,INDAIIEN,PRIEN,IPIEN "RTN","DGDEP3",106,0) S ADDCKVAL="0^0^0" "RTN","DGDEP3",107,0) S INDAIIEN=$P($G(^DGMT(408.22,INCPER,0)),"^",2) "RTN","DGDEP3",108,0) S PRIEN=$P($G(^DGMT(408.21,INDAIIEN,0)),"^",2) "RTN","DGDEP3",109,0) S IPIEN=$P($G(^DGPR(408.12,PRIEN,0)),"^",3) "RTN","DGDEP3",110,0) I IPIEN["DGPR(408.13" DO "RTN","DGDEP3",111,0) . S IPIEN=$P(IPIEN,";",1) "RTN","DGDEP3",112,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",2)]"" S $P(ADDCKVAL,U,1,2)="1^1" "RTN","DGDEP3",113,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",3)]"" S $P(ADDCKVAL,U,1,2)="1^1" "RTN","DGDEP3",114,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",4)]"" S $P(ADDCKVAL,U,1,2)="1^1" "RTN","DGDEP3",115,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",5)]"" S $P(ADDCKVAL,U,1,2)="1^1" "RTN","DGDEP3",116,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",6)]"" S $P(ADDCKVAL,U,1,2)="1^1" "RTN","DGDEP3",117,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",7)]"" S $P(ADDCKVAL,U,1,2)="1^1" "RTN","DGDEP3",118,0) . I $P($G(^DGPR(408.13,IPIEN,1)),"^",8)]"" S $P(ADDCKVAL,U,3)="1" "RTN","DGDEP3",119,0) Q ADDCKVAL "RTN","DGENA") 0^7^B19072068 "RTN","DGENA",1,0) DGENA ;ALB/CJM,ISA/KWP,Zoltan,LBD,CKN,EG - Enrollment API - Retrieve Data; 12/11/00 4:19pm ; 04/24/2006 8:51 AM "RTN","DGENA",2,0) ;;5.3;Registration;**121,122,147,232,314,564,672,659,653**;Aug 13, 1993;Build 2 "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", 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","IR" Radiation Exposure Indicated "RTN","DGENA",126,0) ; "ELIG","RADEXPM" Radiation Exposure Method "RTN","DGENA",127,0) ; "ELIG","EC" Environmental Contaminants "RTN","DGENA",128,0) ; "ELIG","MTSTA" Means Test Status "RTN","DGENA",129,0) ; "ELIG","VCD" Veteran Catastrophically Disabled? "RTN","DGENA",130,0) ; "ELIG","PH" Purple Heart Indicated? "RTN","DGENA",131,0) ; "ELIG","UNEMPLOY" Unemployable "RTN","DGENA",132,0) ; "ELIG","CVELEDT" Combat Veteran End Date "RTN","DGENA",133,0) ; "ELIG","SHAD" SHAD Indicated "RTN","DGENA",134,0) ; "DATETIME" Date/Time Entered "RTN","DGENA",135,0) ; "USER" Entered By "RTN","DGENA",136,0) ; "RTN","DGENA",137,0) N SUB,NODE "RTN","DGENA",138,0) I '$G(DGENRIEN) Q 0 "RTN","DGENA",139,0) I '$D(^DGEN(27.11,DGENRIEN,0)) Q 0 "RTN","DGENA",140,0) K DGENR "RTN","DGENA",141,0) S DGENR="" "RTN","DGENA",142,0) S NODE=$G(^DGEN(27.11,DGENRIEN,0)) "RTN","DGENA",143,0) S DGENR("APP")=$P(NODE,"^") "RTN","DGENA",144,0) S DGENR("DATE")=$P(NODE,"^",10) "RTN","DGENA",145,0) S DGENR("END")=$P(NODE,"^",11) "RTN","DGENA",146,0) S DGENR("DFN")=$P(NODE,"^",2) "RTN","DGENA",147,0) S DGENR("SOURCE")=$P(NODE,"^",3) "RTN","DGENA",148,0) S DGENR("STATUS")=$P(NODE,"^",4) "RTN","DGENA",149,0) S DGENR("REASON")=$P(NODE,"^",5) "RTN","DGENA",150,0) S DGENR("FACREC")=$P(NODE,"^",6) "RTN","DGENA",151,0) S DGENR("PRIORITY")=$P(NODE,"^",7) "RTN","DGENA",152,0) S DGENR("EFFDATE")=$P(NODE,"^",8) "RTN","DGENA",153,0) S DGENR("PRIORREC")=$P(NODE,"^",9) "RTN","DGENA",154,0) ;Phase II Get enrollment sub-grp (SRS 6.4) "RTN","DGENA",155,0) S DGENR("SUBGRP")=$P(NODE,"^",12) "RTN","DGENA",156,0) S NODE=$G(^DGEN(27.11,DGENRIEN,"R")) "RTN","DGENA",157,0) S DGENR("REMARKS")=$P(NODE,"^") "RTN","DGENA",158,0) S NODE=$G(^DGEN(27.11,DGENRIEN,"E")) "RTN","DGENA",159,0) S DGENR("ELIG","CODE")=$P(NODE,"^") "RTN","DGENA",160,0) S DGENR("ELIG","SC")=$P(NODE,"^",2) "RTN","DGENA",161,0) S DGENR("ELIG","SCPER")=$P(NODE,"^",3) "RTN","DGENA",162,0) S DGENR("ELIG","POW")=$P(NODE,"^",4) "RTN","DGENA",163,0) S DGENR("ELIG","A&A")=$P(NODE,"^",5) "RTN","DGENA",164,0) S DGENR("ELIG","HB")=$P(NODE,"^",6) "RTN","DGENA",165,0) S DGENR("ELIG","VAPEN")=$P(NODE,"^",7) "RTN","DGENA",166,0) S DGENR("ELIG","VACKAMT")=$P(NODE,"^",8) "RTN","DGENA",167,0) S DGENR("ELIG","DISRET")=$P(NODE,"^",9) "RTN","DGENA",168,0) S DGENR("ELIG","DISLOD")=$P(NODE,"^",20) ;added with DG*5.3*672 "RTN","DGENA",169,0) S DGENR("ELIG","MEDICAID")=$P(NODE,"^",10) "RTN","DGENA",170,0) S DGENR("ELIG","AO")=$P(NODE,"^",11) "RTN","DGENA",171,0) S DGENR("ELIG","IR")=$P(NODE,"^",12) "RTN","DGENA",172,0) S DGENR("ELIG","EC")=$P(NODE,"^",13) "RTN","DGENA",173,0) S DGENR("ELIG","MTSTA")=$P(NODE,"^",14) "RTN","DGENA",174,0) S DGENR("ELIG","VCD")=$P(NODE,"^",15) "RTN","DGENA",175,0) S DGENR("ELIG","PH")=$P(NODE,"^",16) "RTN","DGENA",176,0) S DGENR("ELIG","UNEMPLOY")=$P(NODE,"^",17) "RTN","DGENA",177,0) S DGENR("ELIG","CVELEDT")=$P(NODE,"^",18) "RTN","DGENA",178,0) S DGENR("ELIG","SHAD")=$P(NODE,"^",19) "RTN","DGENA",179,0) S DGENR("ELIG","RADEXPM")=$P(NODE,"^",21) "RTN","DGENA",180,0) ;S DGENCDZZ=1 ; for CD Testing (disabled). "RTN","DGENA",181,0) S NODE=$G(^DGEN(27.11,DGENRIEN,"U")) "RTN","DGENA",182,0) S DGENR("DATETIME")=$P(NODE,"^") "RTN","DGENA",183,0) S DGENR("USER")=$P(NODE,"^",2) "RTN","DGENA",184,0) Q 1 "RTN","DGENA",185,0) ; "RTN","DGENA1A") 0^8^B13695008 "RTN","DGENA1A",1,0) DGENA1A ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN - Enrollment API - File Data Continued; 12/11/00 3:47pm ; 04/24/2006 8:57 AM "RTN","DGENA1A",2,0) ;;5.3;Registration;**121,147,232,314,564,672,659,653**;Aug 13,1993;Build 2 "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") "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 ^DGEN(27.11,DA,"E")=NODE "RTN","DGENA1A",108,0) S ^DGEN(27.11,DA,"U")=DGENR("DATETIME")_U_DGENR("USER") "RTN","DGENA1A",109,0) ; "RTN","DGENA1A",110,0) ;set the x-refs "RTN","DGENA1A",111,0) D SETALL(DA,.DGENR) "RTN","DGENA1A",112,0) Q 1 "RTN","DGENCDA") 0^42^B8468771 "RTN","DGENCDA",1,0) DGENCDA ;ALB/CJM,Zoltan,JAN,BRM,TDM - Catastrophic Disability API - Retrieve Data;May 24, 1999;Nov 14, 2001 ; 9/19/05 11:35am "RTN","DGENCDA",2,0) ;;5.3;Registration;**121,147,232,387,451,653**;Aug 13,1993;Build 2 "RTN","DGENCDA",3,0) ; "RTN","DGENCDA",4,0) GET(DFN,DGCDIS) ; "RTN","DGENCDA",5,0) ;Description: Get catastrophic disability information for a patient "RTN","DGENCDA",6,0) ;Input: "RTN","DGENCDA",7,0) ; DFN - Patient IEN "RTN","DGENCDA",8,0) ;Output: "RTN","DGENCDA",9,0) ; DGCDIS - the catastrophic disability array, passed by reference "RTN","DGENCDA",10,0) ; subscripts: "RTN","DGENCDA",11,0) ; "BY" Decided By "RTN","DGENCDA",12,0) ; "DATE" Date of Decision "RTN","DGENCDA",13,0) ; "FACDET" Facility Making Determination "RTN","DGENCDA",14,0) ; "REVDTE" Review Date "RTN","DGENCDA",15,0) ; "VETREQDT" Date Veteran Requested CD Evaluation "RTN","DGENCDA",16,0) ; "DTFACIRV" Date Facility Initiated Review "RTN","DGENCDA",17,0) ; "DTVETNOT" Date Veteran Was Notified "RTN","DGENCDA",18,0) ; "RTN","DGENCDA",19,0) N SUB,ITEM,SITEM,SIEN,IND "RTN","DGENCDA",20,0) K DGCDIS S DGCDIS="" "RTN","DGENCDA",21,0) I '$G(DFN) D Q 0 "RTN","DGENCDA",22,0) . F SUB="VCD","BY","DATE","FACDET","REVDTE","METDET","VETREQDT","DTFACIRV","DTVETNOT" S DGCDIS(SUB)="" "RTN","DGENCDA",23,0) ; .39 VETERAN CATASTROPHICALLY DISABLED? field. "RTN","DGENCDA",24,0) S DGCDIS("VCD")=$P($G(^DPT(DFN,.39)),"^",6) "RTN","DGENCDA",25,0) ; .391 DECIDED BY field. "RTN","DGENCDA",26,0) S DGCDIS("BY")=$P($G(^DPT(DFN,.39)),"^",1) "RTN","DGENCDA",27,0) ; .392 DATE OF DECISION field. "RTN","DGENCDA",28,0) S DGCDIS("DATE")=$P($G(^DPT(DFN,.39)),"^",2) "RTN","DGENCDA",29,0) ; .393 FACILITY MAKING DETERMINATION field. "RTN","DGENCDA",30,0) S DGCDIS("FACDET")=$P($G(^DPT(DFN,.39)),"^",3) "RTN","DGENCDA",31,0) ; .394 REVIEW DATE field. "RTN","DGENCDA",32,0) S DGCDIS("REVDTE")=$P($G(^DPT(DFN,.39)),"^",4) "RTN","DGENCDA",33,0) ; .395 METHOD OF DETERMINATION field. "RTN","DGENCDA",34,0) S DGCDIS("METDET")=$P($G(^DPT(DFN,.39)),"^",5) "RTN","DGENCDA",35,0) ; .3951 DATE VETERAN REQUESTED CD EVAL "RTN","DGENCDA",36,0) S DGCDIS("VETREQDT")=$P($G(^DPT(DFN,.39)),"^",7) "RTN","DGENCDA",37,0) ; .3952 DATE FACILITY INITIATED REVIEW "RTN","DGENCDA",38,0) S DGCDIS("DTFACIRV")=$P($G(^DPT(DFN,.39)),"^",8) "RTN","DGENCDA",39,0) ; .3953 DATE VETERAN WAS NOTIFIED "RTN","DGENCDA",40,0) S DGCDIS("DTVETNOT")=$P($G(^DPT(DFN,.39)),"^",9) "RTN","DGENCDA",41,0) ; .396 CD STATUS DIAGNOSES field (multiple): "RTN","DGENCDA",42,0) S SIEN=0 "RTN","DGENCDA",43,0) F ITEM=1:1 S SIEN=$O(^DPT(DFN,.396,SIEN)) Q:'SIEN D "RTN","DGENCDA",44,0) . ; .01 CD STATUS DIAGNOSES sub-field. "RTN","DGENCDA",45,0) . S DGCDIS("DIAG",ITEM)=$P($G(^DPT(DFN,.396,SIEN,0)),"^",1) "RTN","DGENCDA",46,0) ; .397 CD STATUS PROCEDURES field (multiple): "RTN","DGENCDA",47,0) S (ITEM,SITEM,SIEN)=0 "RTN","DGENCDA",48,0) F S ITEM=$O(^DPT(DFN,.397,"B",ITEM)) Q:'ITEM D "RTN","DGENCDA",49,0) . S IND=0,SIEN=SIEN+1 "RTN","DGENCDA",50,0) . F S SITEM=$O(^DPT(DFN,.397,"B",ITEM,SITEM)) Q:'SITEM D "RTN","DGENCDA",51,0) . . ; .01 CD STATUS PROCEDURES sub-field. "RTN","DGENCDA",52,0) . . S DGCDIS("PROC",SIEN)=$P($G(^DPT(DFN,.397,SITEM,0)),"^",1) "RTN","DGENCDA",53,0) . . ; 1 AFFECTED EXTREMITY sub-field. "RTN","DGENCDA",54,0) . . S DGCDIS("EXT",SIEN)=$P($G(^DPT(DFN,.397,SITEM,0)),"^",2) "RTN","DGENCDA",55,0) . . S IND=IND+1,DGCDIS("EXT",SIEN,IND)=$P($G(^DPT(DFN,.397,SITEM,0)),"^",2) "RTN","DGENCDA",56,0) ; - .398 CD STATUS CONDITIONS field (multiple): "RTN","DGENCDA",57,0) S SIEN=0 "RTN","DGENCDA",58,0) F ITEM=1:1 S SIEN=$O(^DPT(DFN,.398,SIEN)) Q:'SIEN D "RTN","DGENCDA",59,0) . ; .01 CD STATUS CONDITIONS sub-field. "RTN","DGENCDA",60,0) . S DGCDIS("COND",ITEM)=$P($G(^DPT(DFN,.398,SIEN,0)),"^",1) "RTN","DGENCDA",61,0) . ; 1 SCORE sub-field. "RTN","DGENCDA",62,0) . S DGCDIS("SCORE",ITEM)=$P($G(^DPT(DFN,.398,SIEN,0)),"^",2) "RTN","DGENCDA",63,0) . ; 2 PERMANENT INDICATOR sub-field. "RTN","DGENCDA",64,0) . S DGCDIS("PERM",ITEM)=$P($G(^DPT(DFN,.398,SIEN,0)),"^",3) "RTN","DGENCDA",65,0) Q 1 "RTN","DGENCDA",66,0) ; "RTN","DGENCDA",67,0) DISABLED(DFN) ; "RTN","DGENCDA",68,0) ;Description: Returns whether the patient is catastrophically disabled. "RTN","DGENCDA",69,0) ; "RTN","DGENCDA",70,0) ;Input: "RTN","DGENCDA",71,0) ; DFN - Patient IEN "RTN","DGENCDA",72,0) ;Output: "RTN","DGENCDA",73,0) ; Function Value - returns 1 if the patient is catastrophically "RTN","DGENCDA",74,0) ; disabled, otherwise 0 "RTN","DGENCDA",75,0) ; "RTN","DGENCDA",76,0) Q $$HASCAT(DFN) "RTN","DGENCDA",77,0) ; "RTN","DGENCDA",78,0) HASCAT(DFN) ; "RTN","DGENCDA",79,0) ;Description: returns 1 if the patient is CATASTROPHICALLY DISABLED "RTN","DGENCDA",80,0) ; "RTN","DGENCDA",81,0) Q:'$G(DFN) 0 "RTN","DGENCDA",82,0) Q $P($G(^DPT(DFN,.39)),"^",6)="Y" "RTN","DGENCDA",83,0) ; "RTN","DGENCDA",84,0) CHKSITE(DFN) ;is this the facility that made the CD determination? "RTN","DGENCDA",85,0) ; "RTN","DGENCDA",86,0) ;Input: "RTN","DGENCDA",87,0) ; DFN - Patient IEN "RTN","DGENCDA",88,0) ;Output: "RTN","DGENCDA",89,0) ; Function Value - returns 1 if CD evaluation was entered at local "RTN","DGENCDA",90,0) ; site, otherwise 0^SITE # "RTN","DGENCDA",91,0) ; "RTN","DGENCDA",92,0) Q:'$G(DFN) 0 "RTN","DGENCDA",93,0) N SITE "RTN","DGENCDA",94,0) S SITE=$$SITE^VASITE "RTN","DGENCDA",95,0) Q:$P($G(^DPT(DFN,.39)),"^",3)=$P(SITE,"^") 1 "RTN","DGENCDA",96,0) Q "0^"_$P($G(^DPT(DFN,.39)),"^",3) "RTN","DGENCDA",97,0) ; "RTN","DGENCDA",98,0) CDTYPE(DFN) ; Was the method of determination "Physical Exam"? "RTN","DGENCDA",99,0) ; "RTN","DGENCDA",100,0) ;Input: "RTN","DGENCDA",101,0) ; DFN - Patient IEN "RTN","DGENCDA",102,0) ;Output: "RTN","DGENCDA",103,0) ; Function Value - returns 1 if CD='Yes' & Method='Physical Exam' "RTN","DGENCDA",104,0) ; otherwise 0 "RTN","DGENCDA",105,0) ; "RTN","DGENCDA",106,0) Q:'$G(DFN) 0 "RTN","DGENCDA",107,0) Q:'$$HASCAT(DFN) 0 "RTN","DGENCDA",108,0) Q $P($G(^DPT(DFN,.39)),"^",5)=3 "RTN","DGENCDA",109,0) ; "RTN","DGENCDA1") 0^48^B47052771 "RTN","DGENCDA1",1,0) DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM,CKN - Catastrophic Disabilty API - File Data;Sep 16, 2002 ; 9/22/05 5:25pm "RTN","DGENCDA1",2,0) ;;5.3;Registration;**121,147,232,302,356,387,475,451,653**;Aug 13,1993;Build 2 "RTN","DGENCDA1",3,0) ; "RTN","DGENCDA1",4,0) LOCK(DFN) ; "RTN","DGENCDA1",5,0) ;Description: Locks the catastrophic disability record for a patient "RTN","DGENCDA1",6,0) ;Input: "RTN","DGENCDA1",7,0) ; DFN - Patient IEN "RTN","DGENCDA1",8,0) ;Output: "RTN","DGENCDA1",9,0) ; Function Value - returns 1 if the patient is catastrophic disability "RTN","DGENCDA1",10,0) ; record can be locked, otherwise 0 "RTN","DGENCDA1",11,0) I $G(DFN) L +^DPT(DFN,.39):2 "RTN","DGENCDA1",12,0) Q $T "RTN","DGENCDA1",13,0) ; "RTN","DGENCDA1",14,0) UNLOCK(DFN) ; "RTN","DGENCDA1",15,0) ;Description: Unlocks the catastrophic disability record for a patient "RTN","DGENCDA1",16,0) ;Input: "RTN","DGENCDA1",17,0) ; DFN - Patient IEN "RTN","DGENCDA1",18,0) ;Output: "RTN","DGENCDA1",19,0) ; None "RTN","DGENCDA1",20,0) I $G(DFN) L -^DPT(DFN,.39) "RTN","DGENCDA1",21,0) Q "RTN","DGENCDA1",22,0) ; "RTN","DGENCDA1",23,0) CHECK(DGCDIS,ERROR) ; "RTN","DGENCDA1",24,0) ;Description: Validity checks on the catastrophic disability contained "RTN","DGENCDA1",25,0) ; in the DGCDIS array "RTN","DGENCDA1",26,0) ;Input: "RTN","DGENCDA1",27,0) ; DGCDIS - the catastrophic disability array, passed by reference "RTN","DGENCDA1",28,0) ;Output: "RTN","DGENCDA1",29,0) ; Function Value - returns 1 if validation checks passed, 0 otherwise "RTN","DGENCDA1",30,0) ; ERROR - if validation fails an error mssg is returned, pass by "RTN","DGENCDA1",31,0) ; reference "RTN","DGENCDA1",32,0) N VALID,RESULT,EXTERNAL,ITEM,EIEN,EXIT,OK,ISCD,POP,FLD "RTN","DGENCDA1",33,0) S ERROR="" "RTN","DGENCDA1",34,0) Q:DGCDIS("VCD")="@" 1 ;this is a deletion "RTN","DGENCDA1",35,0) D ;drops out of block if invalid condition found "RTN","DGENCDA1",36,0) . S VALID=0 ; Usually invalid if it exits early. "RTN","DGENCDA1",37,0) . ; CD Flag must have a value if any other CD field is populated "RTN","DGENCDA1",38,0) . S POP=0 "RTN","DGENCDA1",39,0) . I DGCDIS("VCD")="" D Q:POP "RTN","DGENCDA1",40,0) . . F FLD="BY","DATE","FACDET","REVDTE","METDET" D Q:POP "RTN","DGENCDA1",41,0) . . . I $G(DGCDIS(FLD))]"" S POP=1 "RTN","DGENCDA1",42,0) . . I POP S ERROR="'VETERAN CATASTROPHICALLY DISABLED?' FIELD MUST HAVE A RESPONSE" Q "RTN","DGENCDA1",43,0) . . I $G(DGCDIS("DIAG",1))]""!($G(DGCDIS("COND",1))]"")!($G(DGCDIS("PROC",1))]"") D "RTN","DGENCDA1",44,0) . . . S POP=1,ERROR="'VETERAN CATASTROPHICALLY DISABLED?' FIELD MUST HAVE A RESPONSE" Q "RTN","DGENCDA1",45,0) . ; Decided by. "RTN","DGENCDA1",46,0) . I DGCDIS("VCD")'="",$G(DGCDIS("BY"))="" S ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' REQUIRED" Q "RTN","DGENCDA1",47,0) . I $G(DGCDIS("BY"))'="",($L(DGCDIS("BY"))<3)!($L(DGCDIS("BY"))>35) S ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' NOT VALID" Q "RTN","DGENCDA1",48,0) . I $$UPPER^DGUTL($G(DGCDIS("BY")))="HINQ" S ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' CAN NOT BE 'HINQ'" Q "RTN","DGENCDA1",49,0) . ; Date of Decision "RTN","DGENCDA1",50,0) . S OK=1,EXTERNAL="" "RTN","DGENCDA1",51,0) . I DGCDIS("VCD")'="",$G(DGCDIS("DATE"))="" S ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' REQUIRED" Q "RTN","DGENCDA1",52,0) . I $G(DGCDIS("DATE"))'="" D "RTN","DGENCDA1",53,0) . . I 'DGCDIS("DATE") S OK=0 Q "RTN","DGENCDA1",54,0) . . S EXTERNAL=$$EXTERNAL^DILFD(2,.392,"",DGCDIS("DATE")) "RTN","DGENCDA1",55,0) . . I EXTERNAL="" S OK=0 "RTN","DGENCDA1",56,0) . . D CHK^DIE(2,.392,,EXTERNAL,.RESULT) "RTN","DGENCDA1",57,0) . . I RESULT="^" S OK=0 "RTN","DGENCDA1",58,0) . I 'OK S ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' NOT VALID" Q "RTN","DGENCDA1",59,0) . ; Facility Making Determination. "RTN","DGENCDA1",60,0) . I DGCDIS("VCD")'=""!(DGCDIS("FACDET")'=""),$$EXTERNAL^DILFD(2,.393,"",$G(DGCDIS("FACDET")))="" S ERROR="'FACILITY MAKING CATASTROPHIC DISABILITY DETERMINATION' NOT VALID" Q "RTN","DGENCDA1",61,0) . ; Review Date "RTN","DGENCDA1",62,0) . I DGCDIS("VCD")'="",$G(DGCDIS("REVDTE"))="" S ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' REQUIRED" Q "RTN","DGENCDA1",63,0) . I DGCDIS("REVDTE")'="" D Q:ERROR'="" "RTN","DGENCDA1",64,0) . . S EXTERNAL=$$EXTERNAL^DILFD(2,.394,"",DGCDIS("REVDTE")) "RTN","DGENCDA1",65,0) . . I EXTERNAL="" S ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' NOT VALID" Q "RTN","DGENCDA1",66,0) . . D CHK^DIE(2,.394,,EXTERNAL,.RESULT) "RTN","DGENCDA1",67,0) . . I RESULT="^" S ERROR="'CATASTROPHIC DISABILTY REVIEW DATE' INVALID" Q "RTN","DGENCDA1",68,0) . . I $G(DGCDIS("DATE")),DGCDIS("REVDTE")>DGCDIS("DATE") S ERROR="'CD REVIEW DATE' GREATER THAN 'CD DATE OF DETERMINATION'." Q "RTN","DGENCDA1",69,0) . ; Method of Determination "RTN","DGENCDA1",70,0) . I $G(DGCDIS("METDET"))="",DGCDIS("VCD")'="" S ERROR="'METHOD OF DETERMINATION' IS A REQUIRED VALUE." Q "RTN","DGENCDA1",71,0) . I "..2.3."'[("."_$G(DGCDIS("METDET"))_".") S ERROR="'METHOD OF DETERMINATION' NOT VALID" Q "RTN","DGENCDA1",72,0) . S ITEM="",EXIT=0 "RTN","DGENCDA1",73,0) . ; Diagnoses "RTN","DGENCDA1",74,0) . F S ITEM=$O(DGCDIS("DIAG",ITEM)) Q:'ITEM Q:EXIT D "RTN","DGENCDA1",75,0) . . I DGCDIS("DIAG",ITEM)="" Q "RTN","DGENCDA1",76,0) . . I $$TYPE^DGENA5(DGCDIS("DIAG",ITEM))'="D" S EXIT=1,ERROR="'CD STATUS DIAGNOSES' NOT VALID" "RTN","DGENCDA1",77,0) . Q:EXIT "RTN","DGENCDA1",78,0) . ; Procedures "RTN","DGENCDA1",79,0) . F S ITEM=$O(DGCDIS("PROC",ITEM)) Q:'ITEM Q:EXIT D "RTN","DGENCDA1",80,0) . . I DGCDIS("PROC",ITEM)="" Q "RTN","DGENCDA1",81,0) . . I $$TYPE^DGENA5(DGCDIS("PROC",ITEM))'="P" S EXIT=1,ERROR="'CD STATUS PROCEDURE' NOT VALID" Q "RTN","DGENCDA1",82,0) . . S EIEN="" F S EIEN=$O(DGCDIS("EXT",ITEM,EIEN)) Q:EIEN="" D "RTN","DGENCDA1",83,0) . . . I '$$LIMBOK^DGENA5(DGCDIS("PROC",ITEM),DGCDIS("EXT",ITEM,EIEN)) S EXIT=1,ERROR="'CD STATUS AFFECTED EXTREMITY' INVALID" "RTN","DGENCDA1",84,0) . Q:EXIT "RTN","DGENCDA1",85,0) . ; Conditions "RTN","DGENCDA1",86,0) . F S ITEM=$O(DGCDIS("COND",ITEM)) Q:'ITEM Q:EXIT D "RTN","DGENCDA1",87,0) . . I DGCDIS("COND",ITEM)="" Q "RTN","DGENCDA1",88,0) . . I $$TYPE^DGENA5(DGCDIS("COND",ITEM))'="C" S EXIT=1,ERROR="'' NOT VALID" Q "RTN","DGENCDA1",89,0) . . I '$$VALID^DGENA5(DGCDIS("COND",ITEM),DGCDIS("SCORE",ITEM)) S EXIT=1,ERROR="'CD CONDITION SCORE' NOT VALID" Q "RTN","DGENCDA1",90,0) . . I ".1.2.3."'[("."_DGCDIS("PERM",ITEM)_".") S ERROR="'PERMANENT STATUS INDICATOR' NOT VALID" Q "RTN","DGENCDA1",91,0) . Q:EXIT "RTN","DGENCDA1",92,0) . ; No reason present? "RTN","DGENCDA1",93,0) . I DGCDIS("VCD")="Y",'($D(DGCDIS("DIAG"))!$D(DGCDIS("PROC"))!$D(DGCDIS("COND"))) S ERROR="'CD STATUS REASON' NOT PRESENT" Q "RTN","DGENCDA1",94,0) . ; VCD doesn't match determination status? "RTN","DGENCDA1",95,0) . S ISCD=$$ISCD(.DGCDIS) "RTN","DGENCDA1",96,0) . I DGCDIS("VCD")="Y",'ISCD S ERROR="Not enough diagnoses/procedures/conditions to qualify for CD Status." Q "RTN","DGENCDA1",97,0) . I DGCDIS("VCD")="N",ISCD S ERROR="Veteran has enough diagnoses/procedures/conditions to qualify for CD Status." Q "RTN","DGENCDA1",98,0) . S VALID=1 "RTN","DGENCDA1",99,0) Q VALID "RTN","DGENCDA1",100,0) ; "RTN","DGENCDA1",101,0) ISCD(DGCDIS) ; Returns 1/0, is the patient CD? "RTN","DGENCDA1",102,0) ; DGCDIS("DIAG",N)=CD REASON for Diagnosis. "RTN","DGENCDA1",103,0) ; DGCDIS("COND",N)=CD REASON for Condition. "RTN","DGENCDA1",104,0) ; DGCDIS("SCORE",N)=SCORE (for condition.) "RTN","DGENCDA1",105,0) ; DGCDIS("PERM",N)=Permanant Indicator (for condition). "RTN","DGENCDA1",106,0) ; DGCDIS("PROC",N)=CD REASON for procedure. "RTN","DGENCDA1",107,0) ; DGCDIS("EXT",N)=Affected Extremity (for procedure.) "RTN","DGENCDA1",108,0) N CD S CD=0 ; True if patient is CD. "RTN","DGENCDA1",109,0) N SUB,LIMB,LCODE,EXT,LIEN,EXCLUDE "RTN","DGENCDA1",110,0) S SUB="" "RTN","DGENCDA1",111,0) F S SUB=$O(DGCDIS("DIAG",SUB)) Q:SUB="" D "RTN","DGENCDA1",112,0) . I $$TYPE^DGENA5($G(DGCDIS("DIAG",SUB)))'="D" Q "RTN","DGENCDA1",113,0) . S CD=CD+1 "RTN","DGENCDA1",114,0) F S SUB=$O(DGCDIS("PROC",SUB)) Q:SUB="" D "RTN","DGENCDA1",115,0) . I $$TYPE^DGENA5($G(DGCDIS("PROC",SUB)))'="P" Q "RTN","DGENCDA1",116,0) . S LCODE=0 "RTN","DGENCDA1",117,0) . F S LCODE=$O(DGCDIS("EXT",SUB,LCODE)) Q:'LCODE D "RTN","DGENCDA1",118,0) . . S EXT=DGCDIS("EXT",SUB,LCODE) "RTN","DGENCDA1",119,0) . . Q:EXT="" "RTN","DGENCDA1",120,0) . . S LIEN=$O(^DGEN(27.17,DGCDIS("PROC",SUB),1,"B",EXT,0)) "RTN","DGENCDA1",121,0) . . Q:LIEN="" "RTN","DGENCDA1",122,0) . . S LIMB=$$LIMBCODE^DGENA5(DGCDIS("PROC",SUB),LIEN) "RTN","DGENCDA1",123,0) . . I LIMB'=EXT Q "RTN","DGENCDA1",124,0) . . I $D(EXCLUDE(SUB,LIMB)) Q "RTN","DGENCDA1",125,0) . . S EXCLUDE(SUB,LIMB)="" "RTN","DGENCDA1",126,0) . . S CD=CD+.5 "RTN","DGENCDA1",127,0) F S SUB=$O(DGCDIS("COND",SUB)) Q:SUB="" D "RTN","DGENCDA1",128,0) . I $$TYPE^DGENA5($G(DGCDIS("COND",SUB)))'="C" Q "RTN","DGENCDA1",129,0) . I '$$RANGEMET^DGENA5(DGCDIS("COND",SUB),DGCDIS("SCORE",SUB),DGCDIS("PERM",SUB)) Q "RTN","DGENCDA1",130,0) . S CD=CD+1 "RTN","DGENCDA1",131,0) S CD=(CD'<1) "RTN","DGENCDA1",132,0) ;S DGCDIS("VCD")=$E("NY",CD+1) "RTN","DGENCDA1",133,0) Q CD "RTN","DGENCDA1",134,0) ; "RTN","DGENCDA1",135,0) ERRDISP(FILE) ; Display error. "RTN","DGENCDA1",136,0) N LINE "RTN","DGENCDA1",137,0) S LINE=0 "RTN","DGENCDA1",138,0) W:$X ! "RTN","DGENCDA1",139,0) W "ERROR updating ",$S(FILE=2.396:"CD DIAGNOSES",FILE=2.397:"CD PROCEDURES",FILE=2.398:"CD CONDITIONS",FILE=2.399!(FILE=2.409):"CD HISTORY",1:"PATIENT CD DATA"),! "RTN","DGENCDA1",140,0) F S LINE=$O(DGCDERR("DIERR",1,"TEXT",LINE)) Q:'LINE W ?5,DGCDERR("DIERR",1,"TEXT",LINE),! "RTN","DGENCDA1",141,0) W ! "RTN","DGENCDA1",142,0) Q "RTN","DGENCDA1",143,0) ; "RTN","DGENCDA1",144,0) DELETE(DFN) ; "RTN","DGENCDA1",145,0) ;Description: Delete a catastrophic disability record for a patient "RTN","DGENCDA1",146,0) ;Input: "RTN","DGENCDA1",147,0) ; DFN - Patient IEN "RTN","DGENCDA1",148,0) ;Output: "RTN","DGENCDA1",149,0) ; Function Value - returns 1 if successful, otherwise 0 "RTN","DGENCDA1",150,0) N SUCCESS,DIE,DR,DA,D0,DIC "RTN","DGENCDA1",151,0) S SUCCESS=1 "RTN","DGENCDA1",152,0) D ;drops out if invalid condition found "RTN","DGENCDA1",153,0) . I $G(DFN),$D(^DPT(DFN,0)) "RTN","DGENCDA1",154,0) . E S SUCCESS=0 Q "RTN","DGENCDA1",155,0) . I '$$LOCK(DFN) S SUCCESS=0 Q "RTN","DGENCDA1",156,0) . S DIE="^DPT(" "RTN","DGENCDA1",157,0) . S DR=".39////@" "RTN","DGENCDA1",158,0) . S DR=DR_";.391////@" "RTN","DGENCDA1",159,0) . S DR=DR_";.392////@" "RTN","DGENCDA1",160,0) . S DR=DR_";.393////@" "RTN","DGENCDA1",161,0) . S DR=DR_";.394////@" "RTN","DGENCDA1",162,0) . S DR=DR_";.395////@" "RTN","DGENCDA1",163,0) . S DR=DR_";.3951////@" "RTN","DGENCDA1",164,0) . S DR=DR_";.3952////@" "RTN","DGENCDA1",165,0) . S DR=DR_";.3953////@" "RTN","DGENCDA1",166,0) . S DA=DFN "RTN","DGENCDA1",167,0) . D ^DIE "RTN","DGENCDA1",168,0) . N SIEN,SUBFILE "RTN","DGENCDA1",169,0) . F SUBFILE=.396,.397,.398 I $D(^DPT(DFN,SUBFILE)) D "RTN","DGENCDA1",170,0) . . S SIEN=0 "RTN","DGENCDA1",171,0) . . F S SIEN=$O(^DPT(DFN,SUBFILE,SIEN)) Q:'SIEN D "RTN","DGENCDA1",172,0) . . . N DA,DIE,DR "RTN","DGENCDA1",173,0) . . . S DIE="^DPT("_DFN_","_SUBFILE_"," "RTN","DGENCDA1",174,0) . . . S DR=".01////@" "RTN","DGENCDA1",175,0) . . . S DA=SIEN,DA(1)=DFN "RTN","DGENCDA1",176,0) . . . D ^DIE "RTN","DGENCDA1",177,0) . ; Note -- CD HISTORY field (#.399) must not be deleted. "RTN","DGENCDA1",178,0) D UNLOCK(DFN) "RTN","DGENCDA1",179,0) Q SUCCESS "RTN","DGENCDA2") 0^49^B16601492 "RTN","DGENCDA2",1,0) DGENCDA2 ;ALB/CJM,ISA/KWP,Zoltan,JAN,CKN - Catastrophic Disabilty API - File Data;May 24, 1999,Nov 14, 2001 ; 9/22/05 5:40pm "RTN","DGENCDA2",2,0) ;;5.3;Registration;**232,387,653**;Aug 13,1993;Build 2 "RTN","DGENCDA2",3,0) ; "RTN","DGENCDA2",4,0) STORE(DFN,DGCDIS,ERROR) ; "RTN","DGENCDA2",5,0) ;Description: Creates a catastrophic disability record for a patient. "RTN","DGENCDA2",6,0) ; Attempts to add catastrophically disabled eligibility code. "RTN","DGENCDA2",7,0) ;Input: "RTN","DGENCDA2",8,0) ; DFN - Patient IEN "RTN","DGENCDA2",9,0) ; DGCDIS - the catastrophic disability array, passed by reference "RTN","DGENCDA2",10,0) ;Output: "RTN","DGENCDA2",11,0) ; Function Value - returns 1 if successful, otherwise 0 "RTN","DGENCDA2",12,0) ; ERROR - if not successful, an error message is returned,pass "RTN","DGENCDA2",13,0) ; by reference "RTN","DGENCDA2",14,0) N SUCCESS,FDA,SUB,HIEN,HSUB,FDB,NIEN,EIEN "RTN","DGENCDA2",15,0) S SUCCESS=1 "RTN","DGENCDA2",16,0) S ERROR="" "RTN","DGENCDA2",17,0) D ;drops out if invalid condition found "RTN","DGENCDA2",18,0) . I $G(DFN),$D(^DPT(DFN,0)) "RTN","DGENCDA2",19,0) . E S SUCCESS=0,ERROR="PATIENT NOT FOUND" Q "RTN","DGENCDA2",20,0) . I '$$LOCK^DGENCDA1(DFN) S SUCCESS=0,ERROR="RECORD IN USE, CAN NOT BE EDITED" Q "RTN","DGENCDA2",21,0) . I '$$CHECK^DGENCDA1(.DGCDIS,.ERROR) S SUCCESS=0 Q "RTN","DGENCDA2",22,0) . S HIEN=$P($G(^DPT(DFN,.399,0)),"^",3)+1 "RTN","DGENCDA2",23,0) . S HIEN=HIEN_","_DFN_"," "RTN","DGENCDA2",24,0) . S FDA(2,DFN_",",.39)=DGCDIS("VCD") "RTN","DGENCDA2",25,0) . S FDB(2.399,HIEN,.39)=DGCDIS("VCD") "RTN","DGENCDA2",26,0) . S FDA(2,DFN_",",.391)=DGCDIS("BY") "RTN","DGENCDA2",27,0) . S FDB(2.399,HIEN,.391)=DGCDIS("BY") "RTN","DGENCDA2",28,0) . S FDA(2,DFN_",",.392)=DGCDIS("DATE") "RTN","DGENCDA2",29,0) . S FDB(2.399,HIEN,.392)=DGCDIS("DATE") "RTN","DGENCDA2",30,0) . S FDA(2,DFN_",",.393)=DGCDIS("FACDET") "RTN","DGENCDA2",31,0) . S FDB(2.399,HIEN,.393)=DGCDIS("FACDET") "RTN","DGENCDA2",32,0) . S FDA(2,DFN_",",.394)=DGCDIS("REVDTE") "RTN","DGENCDA2",33,0) . S FDB(2.399,HIEN,.394)=DGCDIS("REVDTE") "RTN","DGENCDA2",34,0) . S FDA(2,DFN_",",.395)=DGCDIS("METDET") "RTN","DGENCDA2",35,0) . S FDB(2.399,HIEN,.395)=DGCDIS("METDET") "RTN","DGENCDA2",36,0) . S FDA(2,DFN_",",.3951)=DGCDIS("VETREQDT") "RTN","DGENCDA2",37,0) . S FDB(2.399,HIEN,.3951)=DGCDIS("VETREQDT") "RTN","DGENCDA2",38,0) . S FDA(2,DFN_",",.3952)=DGCDIS("DTFACIRV") "RTN","DGENCDA2",39,0) . S FDB(2.399,HIEN,.3952)=DGCDIS("DTFACIRV") "RTN","DGENCDA2",40,0) . S FDA(2,DFN_",",.3953)=DGCDIS("DTVETNOT") "RTN","DGENCDA2",41,0) . S FDB(2.399,HIEN,.3953)=DGCDIS("DTVETNOT") "RTN","DGENCDA2",42,0) . S SUB="",HSUB=0 "RTN","DGENCDA2",43,0) . S NIEN=0 F S SUB=$O(DGCDIS("DIAG",SUB)) Q:'SUB D "RTN","DGENCDA2",44,0) . . I DGCDIS("DIAG",SUB)="" Q "RTN","DGENCDA2",45,0) . . S NIEN=NIEN+1 "RTN","DGENCDA2",46,0) . . S FDB(2.396,NIEN_","_DFN_",",.01)=DGCDIS("DIAG",SUB) "RTN","DGENCDA2",47,0) . . S HSUB=HSUB+1 "RTN","DGENCDA2",48,0) . . S FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("DIAG",SUB) "RTN","DGENCDA2",49,0) . S NIEN=0 F S SUB=$O(DGCDIS("PROC",SUB)) Q:'SUB D "RTN","DGENCDA2",50,0) . . I DGCDIS("PROC",SUB)="" Q "RTN","DGENCDA2",51,0) . . S EIEN=0 F S EIEN=$O(DGCDIS("EXT",SUB,EIEN)) Q:'EIEN D "RTN","DGENCDA2",52,0) . . . S NIEN=NIEN+1 "RTN","DGENCDA2",53,0) . . . S FDB(2.397,NIEN_","_DFN_",",.01)=DGCDIS("PROC",SUB) "RTN","DGENCDA2",54,0) . . . S HSUB=HSUB+1 "RTN","DGENCDA2",55,0) . . . S FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("PROC",SUB) "RTN","DGENCDA2",56,0) . . . S FDB(2.397,NIEN_","_DFN_",",1)=DGCDIS("EXT",SUB,EIEN) "RTN","DGENCDA2",57,0) . . . S FDB(2.409,HSUB_","_HIEN,1)=DGCDIS("EXT",SUB,EIEN) "RTN","DGENCDA2",58,0) . S NIEN=0 F S SUB=$O(DGCDIS("COND",SUB)) Q:'SUB D "RTN","DGENCDA2",59,0) . . I DGCDIS("COND",SUB)="" Q "RTN","DGENCDA2",60,0) . . S NIEN=NIEN+1 "RTN","DGENCDA2",61,0) . . S FDB(2.398,NIEN_","_DFN_",",.01)=DGCDIS("COND",SUB) "RTN","DGENCDA2",62,0) . . S HSUB=HSUB+1 "RTN","DGENCDA2",63,0) . . S FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("COND",SUB) "RTN","DGENCDA2",64,0) . . S FDB(2.398,NIEN_","_DFN_",",1)=DGCDIS("SCORE",SUB) "RTN","DGENCDA2",65,0) . . S FDB(2.409,HSUB_","_HIEN,2)=DGCDIS("SCORE",SUB) "RTN","DGENCDA2",66,0) . . S FDB(2.398,NIEN_","_DFN_",",2)=DGCDIS("PERM",SUB) "RTN","DGENCDA2",67,0) . . S FDB(2.409,HSUB_","_HIEN,3)=DGCDIS("PERM",SUB) "RTN","DGENCDA2",68,0) . S FDB(2.399,HIEN,.01)=$$NOW^XLFDT "RTN","DGENCDA2",69,0) I SUCCESS D "RTN","DGENCDA2",70,0) . N SUBFDA,SUBFILE "RTN","DGENCDA2",71,0) . S SUCCESS=$$DELETE^DGENCDA1(DFN) "RTN","DGENCDA2",72,0) . Q:'SUCCESS "RTN","DGENCDA2",73,0) . D FILE^DIE("K","FDA","DGCDERR") "RTN","DGENCDA2",74,0) . I $G(DIERR) D Q "RTN","DGENCDA2",75,0) . . S ERROR="FILEMAN UNABLE TO PERFORM UPDATE" "RTN","DGENCDA2",76,0) . . S SUCCESS=0 "RTN","DGENCDA2",77,0) . . D ERRDISP^DGENCDA1(2) "RTN","DGENCDA2",78,0) . S SUBFILE="" "RTN","DGENCDA2",79,0) . S ERROR="FILEMAN UPDATE FAILED FOR " "RTN","DGENCDA2",80,0) . F S SUBFILE=$O(FDB(SUBFILE)) Q:SUBFILE="" D Q:'SUCCESS "RTN","DGENCDA2",81,0) . . N IEN,NODE,ITEM "RTN","DGENCDA2",82,0) . . S IEN="" "RTN","DGENCDA2",83,0) . . F ITEM=0:1 S IEN=$O(FDB(SUBFILE,IEN)) Q:'IEN D Q:'SUCCESS "RTN","DGENCDA2",84,0) . . . N DIC,Y,DO,DD,DINUM,DA,NODE "RTN","DGENCDA2",85,0) . . . I SUBFILE'=2.409 D "RTN","DGENCDA2",86,0) . . . . S NODE=SUBFILE-2 "RTN","DGENCDA2",87,0) . . . . S DIC("P")=$P($G(^DD(2,SUBFILE-2,0)),"^",2) "RTN","DGENCDA2",88,0) . . . . S DA(1)=DFN "RTN","DGENCDA2",89,0) . . . E D "RTN","DGENCDA2",90,0) . . . . S NODE=".399,"_$P(IEN,",",2)_",1" "RTN","DGENCDA2",91,0) . . . . S DIC("P")=$P($G(^DD(2.399,.396,0)),"^",2) "RTN","DGENCDA2",92,0) . . . . S DA(1)=$P(IEN,",",2),DA(2)=DFN "RTN","DGENCDA2",93,0) . . . S DIC="^DPT("_DFN_","_NODE_"," "RTN","DGENCDA2",94,0) . . . S DIC(0)="L" "RTN","DGENCDA2",95,0) . . . S X=FDB(SUBFILE,IEN,.01) "RTN","DGENCDA2",96,0) . . . S DINUM=+IEN "RTN","DGENCDA2",97,0) . . . D FILE^DICN "RTN","DGENCDA2",98,0) . . . I Y=-1 S ERROR="FAILED TO ADD ENTRY TO #"_SUBFILE,SUCCESS=0 "RTN","DGENCDA2",99,0) . . Q:'SUCCESS "RTN","DGENCDA2",100,0) . . K SUBFDA "RTN","DGENCDA2",101,0) . . M SUBFDA(SUBFILE)=FDB(SUBFILE) "RTN","DGENCDA2",102,0) . . D FILE^DIE("K","SUBFDA","DGCDERR") "RTN","DGENCDA2",103,0) . . I $G(DIERR) D "RTN","DGENCDA2",104,0) . . . S ERROR=ERROR_" #"_SUBFILE "RTN","DGENCDA2",105,0) . . . S SUCCESS=0 "RTN","DGENCDA2",106,0) . . . D ERRDISP^DGENCDA1(SUBFILE) "RTN","DGENCDA2",107,0) . I SUCCESS S ERROR="" "RTN","DGENCDA2",108,0) D CLEAN^DILF "RTN","DGENCDA2",109,0) D UNLOCK^DGENCDA1(DFN) "RTN","DGENCDA2",110,0) Q SUCCESS "RTN","DGENELA") 0^9^B26371073 "RTN","DGENELA",1,0) DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN - Patient Eligibility API ; 9/18/06 12:01pm "RTN","DGENELA",2,0) ;;5.3;Registration;**121,147,232,314,451,564,631,672,659,583,653**;Aug 13,1993;Build 2 "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", 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" Environmental Contaminants "RTN","DGENELA",33,0) ;"MTSTA" Means Test Status "RTN","DGENELA",34,0) ;P&T P&T "RTN","DGENELA",35,0) ;POS PERIOD OF SERVICE "RTN","DGENELA",36,0) ;UNEMPLOY UNEMPLOYABLE "RTN","DGENELA",37,0) ;SCAWDATE SC AWARD DATE "RTN","DGENELA",38,0) ;RATEINC RATED INCOMPETENT "RTN","DGENELA",39,0) ;CLAIMNUM CLAIM NUMBER "RTN","DGENELA",40,0) ;CLAIMLOC CLAIM FOLDER LOCATION "RTN","DGENELA",41,0) ;VADISAB RECEIVING VA DISABILITY? "RTN","DGENELA",42,0) ;ELIGSTA ELIGIBILITY STATUS "RTN","DGENELA",43,0) ;ELIGSTADATE ELIGIBILITY STATUS DATE "RTN","DGENELA",44,0) ;ELIGVERIF ELIGIBILITY VERIF. METHOD "RTN","DGENELA",45,0) ;ELIGVSITE ELIGIBILITY VERIFICATION SITE "RTN","DGENELA",46,0) ;ELIGENTBY ELIGIBILITY STATUS ENTERED BY "RTN","DGENELA",47,0) ;RATEDIS "RTN","DGENELA",48,0) ; ,"RD" RATED DISABILITY "RTN","DGENELA",49,0) ; ,"PER" DISABILITY % "RTN","DGENELA",50,0) ; ,"RDSC" SERVICE CONNECTED "RTN","DGENELA",51,0) ; ,"RDEXT" EXTREMITY "RTN","DGENELA",52,0) ; ,"RDORIG" ORIGINAL RD EFFECTIVE DATE "RTN","DGENELA",53,0) ; ."RDCURR" CURRENT RD EFFECTIVE DATE "RTN","DGENELA",54,0) ;"VCD" Veteran Catastrophically Disabled? (#.39) "RTN","DGENELA",55,0) ;"PH" PURPLE HEART INDICATED "RTN","DGENELA",56,0) ;"AOEXPLOC" AGENT ORANGE EXPOSURE LOCATION "RTN","DGENELA",57,0) ;"CVELEDT" COMBAT VETERAN END DATE "RTN","DGENELA",58,0) ;"SHAD" SHAD EXPOSURE "RTN","DGENELA",59,0) ; "RTN","DGENELA",60,0) K DGELG "RTN","DGENELA",61,0) S DGELG="" "RTN","DGENELA",62,0) Q:'$D(^DPT(DFN)) 0 "RTN","DGENELA",63,0) N NODE,SUBREC,COUNT,CODE,IEN "RTN","DGENELA",64,0) ; "RTN","DGENELA",65,0) S DGELG("DFN")=DFN "RTN","DGENELA",66,0) S DGELG("VCD")=$$VCD^DGENA5(DFN) "RTN","DGENELA",67,0) ; "RTN","DGENELA",68,0) ; "RTN","DGENELA",69,0) S NODE=$G(^DPT(DFN,.29)) "RTN","DGENELA",70,0) S DGELG("RATEINC")=$P(NODE,"^",12) "RTN","DGENELA",71,0) ; "RTN","DGENELA",72,0) S NODE=$G(^DPT(DFN,.3)) "RTN","DGENELA",73,0) S DGELG("SC")=$P(NODE,"^") "RTN","DGENELA",74,0) S DGELG("SCPER")=$P(NODE,"^",2) "RTN","DGENELA",75,0) S DGELG("P&T")=$P(NODE,"^",4) "RTN","DGENELA",76,0) S DGELG("UNEMPLOY")=$P(NODE,"^",5) "RTN","DGENELA",77,0) S DGELG("SCAWDATE")=$P(NODE,"^",12) "RTN","DGENELA",78,0) S DGELG("VADISAB")=$P(NODE,"^",11) "RTN","DGENELA",79,0) S DGELG("EFFDT")=$P(NODE,"^",14) "RTN","DGENELA",80,0) ; "RTN","DGENELA",81,0) S NODE=$G(^DPT(DFN,.31)) "RTN","DGENELA",82,0) S DGELG("CLAIMNUM")=$P(NODE,"^",3) "RTN","DGENELA",83,0) S DGELG("CLAIMLOC")=$P(NODE,"^",4) "RTN","DGENELA",84,0) ; "RTN","DGENELA",85,0) S NODE=$G(^DPT(DFN,.32)) "RTN","DGENELA",86,0) S DGELG("POS")=$P(NODE,"^",3) "RTN","DGENELA",87,0) ; "RTN","DGENELA",88,0) S NODE=$G(^DPT(DFN,.36)) "RTN","DGENELA",89,0) S DGELG("ELIG","CODE")=$P(NODE,"^") ;primary eligibility "RTN","DGENELA",90,0) S DGELG("DISRET")=$P(NODE,"^",12) "RTN","DGENELA",91,0) S DGELG("DISLOD")=$P(NODE,"^",13) "RTN","DGENELA",92,0) ; "RTN","DGENELA",93,0) S NODE=$G(^DPT(DFN,.38)) "RTN","DGENELA",94,0) S DGELG("MEDICAID")=$P(NODE,"^") "RTN","DGENELA",95,0) S DGELG("MEDASKDT")=$P(NODE,"^",2) ;Date Medicaid Last Asked "RTN","DGENELA",96,0) ; "RTN","DGENELA",97,0) S NODE=$G(^DPT(DFN,.361)) "RTN","DGENELA",98,0) S DGELG("ELIGSTA")=$P(NODE,"^") "RTN","DGENELA",99,0) S DGELG("ELIGSTADATE")=$P(NODE,"^",2) "RTN","DGENELA",100,0) S DGELG("ELIGVERIF")=$P(NODE,"^",5) "RTN","DGENELA",101,0) S DGELG("ELIGENTBY")=$P(NODE,"^",6) "RTN","DGENELA",102,0) ; "RTN","DGENELA",103,0) S NODE=$G(^DPT(DFN,.362)) "RTN","DGENELA",104,0) S DGELG("VACKAMT")=$P(NODE,"^",20) "RTN","DGENELA",105,0) S DGELG("VAPEN")=$P(NODE,"^",14) "RTN","DGENELA",106,0) S DGELG("A&A")=$P(NODE,"^",12) "RTN","DGENELA",107,0) S DGELG("HB")=$P(NODE,"^",13) "RTN","DGENELA",108,0) ; "RTN","DGENELA",109,0) ; "RTN","DGENELA",110,0) S NODE=$G(^DPT(DFN,.321)) "RTN","DGENELA",111,0) S DGELG("AO")=$P(NODE,"^",2) "RTN","DGENELA",112,0) S DGELG("IR")=$P(NODE,"^",3) "RTN","DGENELA",113,0) S DGELG("RADEXPM")=$P(NODE,"^",12) "RTN","DGENELA",114,0) S DGELG("AOEXPLOC")=$P(NODE,"^",13) "RTN","DGENELA",115,0) S DGELG("SHAD")=$P(NODE,"^",15) ;added with DG*5.3*653 "RTN","DGENELA",116,0) ; "RTN","DGENELA",117,0) S NODE=$G(^DPT(DFN,.322)) "RTN","DGENELA",118,0) S DGELG("EC")=$P(NODE,"^",13) "RTN","DGENELA",119,0) ; "RTN","DGENELA",120,0) S NODE=$G(^DPT(DFN,.52)) "RTN","DGENELA",121,0) S DGELG("POW")=$P(NODE,"^",5) "RTN","DGENELA",122,0) S DGELG("CVELEDT")=$P(NODE,"^",15) "RTN","DGENELA",123,0) ; "RTN","DGENELA",124,0) ; Purple Heart Indicator "RTN","DGENELA",125,0) S NODE=$G(^DPT(DFN,.53)) "RTN","DGENELA",126,0) S DGELG("PH")=$P(NODE,"^") "RTN","DGENELA",127,0) ; "RTN","DGENELA",128,0) ;means test category "RTN","DGENELA",129,0) S DGELG("MTSTA")="" "RTN","DGENELA",130,0) S IEN=$P($$LST^DGMTU(DFN),"^") "RTN","DGENELA",131,0) I IEN S DGELG("MTSTA")=$P($G(^DGMT(408.31,IEN,0)),"^",3) "RTN","DGENELA",132,0) ; "RTN","DGENELA",133,0) ;get the other eligibilities multiple "RTN","DGENELA",134,0) S SUBREC=0 "RTN","DGENELA",135,0) F S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC D "RTN","DGENELA",136,0) .S CODE=+$G(^DPT(DFN,"E",SUBREC,0)) "RTN","DGENELA",137,0) .; "RTN","DGENELA",138,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",139,0) .I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC "RTN","DGENELA",140,0) ; "RTN","DGENELA",141,0) ;rated disability multiple "RTN","DGENELA",142,0) S SUBREC=0,COUNT=0 "RTN","DGENELA",143,0) F S SUBREC=$O(^DPT(DFN,.372,SUBREC)) Q:'SUBREC D "RTN","DGENELA",144,0) .S NODE=$G(^DPT(DFN,.372,SUBREC,0)) "RTN","DGENELA",145,0) .Q:'$P(NODE,"^") "RTN","DGENELA",146,0) .S COUNT=COUNT+1 "RTN","DGENELA",147,0) .S DGELG("RATEDIS",COUNT,"RD")=$P(NODE,"^") "RTN","DGENELA",148,0) .S DGELG("RATEDIS",COUNT,"PER")=$P(NODE,"^",2) "RTN","DGENELA",149,0) .S DGELG("RATEDIS",COUNT,"RDSC")=$P(NODE,"^",3) "RTN","DGENELA",150,0) .S DGELG("RATEDIS",COUNT,"RDEXT")=$P(NODE,"^",4) "RTN","DGENELA",151,0) .S DGELG("RATEDIS",COUNT,"RDORIG")=$P(NODE,"^",5) "RTN","DGENELA",152,0) .S DGELG("RATEDIS",COUNT,"RDCURR")=$P(NODE,"^",6) "RTN","DGENELA",153,0) ; "RTN","DGENELA",154,0) Q 1 "RTN","DGENELA",155,0) ; "RTN","DGENELA",156,0) NATNAME(CODE) ; "RTN","DGENELA",157,0) ;Description: Given an entry in file #8, Eligibility Code file, "RTN","DGENELA",158,0) ; finds the corresponding entry in file 8.1, MAS Eligbility Code file, "RTN","DGENELA",159,0) ; and returns the name "RTN","DGENELA",160,0) ;Input: "RTN","DGENELA",161,0) ; CODE - pointer to file #8 "RTN","DGENELA",162,0) ;Output: "RTN","DGENELA",163,0) ; Function Value - name of corresponding code in file #8.1 "RTN","DGENELA",164,0) ; "RTN","DGENELA",165,0) Q:'$G(CODE) "" "RTN","DGENELA",166,0) Q $$CODENAME($P($G(^DIC(8,CODE,0)),"^",9)) "RTN","DGENELA",167,0) ; "RTN","DGENELA",168,0) NATCODE(CODE) ; "RTN","DGENELA",169,0) ;Description: Given an entry in file #8, Eligibility Code file, "RTN","DGENELA",170,0) ; finds the corresponding entry in file 8.1, MAS Eligbility Code file "RTN","DGENELA",171,0) ;Input: "RTN","DGENELA",172,0) ; CODE - pointer to file #8 "RTN","DGENELA",173,0) ;Output: "RTN","DGENELA",174,0) ; Function Value - pointer to file #8.1 "RTN","DGENELA",175,0) ; "RTN","DGENELA",176,0) Q:'$G(CODE) "" "RTN","DGENELA",177,0) Q $P($G(^DIC(8,CODE,0)),"^",9) "RTN","DGENELA",178,0) ; "RTN","DGENELA",179,0) CODENAME(CODE) ; "RTN","DGENELA",180,0) ;Description: Given a pointer to file #8.1, MAS Eligibility Code file, "RTN","DGENELA",181,0) ; it returns the name of the code "RTN","DGENELA",182,0) ;Input: "RTN","DGENELA",183,0) ; CODE - pointer to file #8.1 "RTN","DGENELA",184,0) ;Output: "RTN","DGENELA",185,0) ; Function Value - name of the code pointed to "RTN","DGENELA",186,0) ; "RTN","DGENELA",187,0) Q:'$G(CODE) "" "RTN","DGENELA",188,0) Q $P($G(^DIC(8.1,CODE,0)),"^") "RTN","DGENELA",189,0) ; "RTN","DGENELA",190,0) ELIGSTAT(DFN,DGELG) ; "RTN","DGENELA",191,0) ;Description: Used to get the ELIGIBILITY STATUS and the "RTN","DGENELA",192,0) ;ELIGIBILITY STATUS DATE of the patient. "RTN","DGENELA",193,0) ; "RTN","DGENELA",194,0) ;Input: "RTN","DGENELA",195,0) ; DFN - ien of patient record "RTN","DGENELA",196,0) ; "RTN","DGENELA",197,0) ;Ouput: "RTN","DGENELA",198,0) ; Function Value - 1 on success, 0 on failure "RTN","DGENELA",199,0) ; DGELG array (pass by reference) "RTN","DGENELA",200,0) ; "ELIGSTA" - ELIGIBILITY STATUS "RTN","DGENELA",201,0) ; "ELIGSTADATE" - ELIGIBILITY STATUS DATE "RTN","DGENELA",202,0) ; "RTN","DGENELA",203,0) N NODE,SUCCESS "RTN","DGENELA",204,0) D "RTN","DGENELA",205,0) .S SUCCESS=1 "RTN","DGENELA",206,0) .I '$G(DFN) S SUCCESS=0 Q "RTN","DGENELA",207,0) .S NODE=$G(^DPT(DFN,.361)) "RTN","DGENELA",208,0) .S DGELG("ELIGSTA")=$P(NODE,"^") "RTN","DGENELA",209,0) .S DGELG("ELIGSTADATE")=$P(NODE,"^",2) "RTN","DGENELA",210,0) Q SUCCESS "RTN","DGENELA1") 0^21^B76546694 "RTN","DGENELA1",1,0) DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ; 9/18/06 12:05pm "RTN","DGENELA1",2,0) ;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653**;Aug 13,1993;Build 2 "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) .I '$$UPD^DGENDBS(2,DFN,.DATA) S ERROR="FILEMAN FAILED TO UPDATE THE PATIENT RECORD" Q "RTN","DGENELA1",137,0) .; "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 "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="POS" .323 "RTN","DGENELA1",182,0) Q:SUB="UNEMPLOY" .305 "RTN","DGENELA1",183,0) Q:SUB="SCAWDATE" .3012 "RTN","DGENELA1",184,0) Q:SUB="RATEINC" .293 "RTN","DGENELA1",185,0) Q:SUB="CLAIMNUM" .313 "RTN","DGENELA1",186,0) Q:SUB="CLAIMLOC" .314 "RTN","DGENELA1",187,0) Q:SUB="VADISAB" .3025 "RTN","DGENELA1",188,0) Q:SUB="ELIGSTA" .3611 "RTN","DGENELA1",189,0) Q:SUB="ELIGSTADATE" .3612 "RTN","DGENELA1",190,0) Q:SUB="ELIGVERIF" .3615 "RTN","DGENELA1",191,0) Q:SUB="ELIGENTBY" .3616 "RTN","DGENELA1",192,0) Q:SUB="RD" .01 "RTN","DGENELA1",193,0) Q:SUB="PER" 2 "RTN","DGENELA1",194,0) Q:SUB="RDSC" 3 "RTN","DGENELA1",195,0) Q:SUB="RDEXT" 4 "RTN","DGENELA1",196,0) Q:SUB="RDORIG" 5 "RTN","DGENELA1",197,0) Q:SUB="RDCURR" 6 "RTN","DGENELA1",198,0) Q:SUB="UEYEAR" .3617 "RTN","DGENELA1",199,0) Q:SUB="UESITE" .3618 "RTN","DGENELA1",200,0) Q:SUB="AOEXPLOC" .3213 "RTN","DGENELA1",201,0) Q:SUB="CVELEDT" .5295 "RTN","DGENELA1",202,0) Q:SUB="SHAD" .32115 "RTN","DGENELA1",203,0) ; "RTN","DGENELA1",204,0) Q "" "RTN","DGENELA1",205,0) ; "RTN","DGENELA1",206,0) CHKFIELD(SUB,VAL) ; "RTN","DGENELA1",207,0) ;Description: Does field level validation of the value. Returns 1 "RTN","DGENELA1",208,0) ;if the value is good, 0 otherwise. "RTN","DGENELA1",209,0) ; "RTN","DGENELA1",210,0) Q:($G(VAL)="") 1 ;for now, all NULL values assumed okay "RTN","DGENELA1",211,0) ; "RTN","DGENELA1",212,0) N BAD S BAD=0 "RTN","DGENELA1",213,0) I (SUB="SCPER")!(SUB="PER"),(+VAL'=VAL)!(VAL>100)!(VAL<0)!(VAL?.E1"."1N.N) S BAD=1 "RTN","DGENELA1",214,0) I SUB="VACKAMT",+VAL'=VAL&(VAL'?.N1"."2N)!(VAL>99999)!(VAL<0) S BAD=1 "RTN","DGENELA1",215,0) I SUB="DISRET",VAL'=0,VAL'=1 S BAD=1 "RTN","DGENELA1",216,0) I SUB="DISLOD",VAL'=0,VAL'=1 S BAD=1 "RTN","DGENELA1",217,0) I SUB="MEDICAID",VAL'=0,VAL'=1 S BAD=1 "RTN","DGENELA1",218,0) I SUB="RATEINC",VAL'=0,VAL'=1 S BAD=1 "RTN","DGENELA1",219,0) I SUB="ELIGSTA",VAL'="P",VAL'="R",VAL'="V" S BAD=1 "RTN","DGENELA1",220,0) I SUB="POW",VAL'="Y",VAL'="N",VAL'="U" S BAD=1 "RTN","DGENELA1",221,0) Q 'BAD "RTN","DGENELA1",222,0) ; "RTN","DGENELA1",223,0) ; "RTN","DGENELA1",224,0) OVERLAY() ; "RTN","DGENELA1",225,0) ;Description: Overlay the local Rated Disabilities with whatever HEC "RTN","DGENELA1",226,0) ;sent. "RTN","DGENELA1",227,0) ; "RTN","DGENELA1",228,0) N SUCCESS S SUCCESS=1 "RTN","DGENELA1",229,0) ; "RTN","DGENELA1",230,0) ;delete the rated disabilties multiple "RTN","DGENELA1",231,0) D DELRDIS^DGENELA2(DFN) "RTN","DGENELA1",232,0) ; "RTN","DGENELA1",233,0) ;add the rated disabilities "RTN","DGENELA1",234,0) K DATA,DA "RTN","DGENELA1",235,0) S DA(1)=DFN "RTN","DGENELA1",236,0) S COUNT=0 "RTN","DGENELA1",237,0) F S COUNT=$O(DGELG("RATEDIS",COUNT)) Q:'COUNT D "RTN","DGENELA1",238,0) .S DATA(.01)=DGELG("RATEDIS",COUNT,"RD") "RTN","DGENELA1",239,0) .I DATA(.01) D "RTN","DGENELA1",240,0) ..S DATA(2)=DGELG("RATEDIS",COUNT,"PER") "RTN","DGENELA1",241,0) ..S DATA(3)=DGELG("RATEDIS",COUNT,"RDSC") "RTN","DGENELA1",242,0) ..S DATA(4)=DGELG("RATEDIS",COUNT,"RDEXT") "RTN","DGENELA1",243,0) ..S DATA(5)=DGELG("RATEDIS",COUNT,"RDORIG") "RTN","DGENELA1",244,0) ..S DATA(6)=DGELG("RATEDIS",COUNT,"RDCURR") "RTN","DGENELA1",245,0) ..I '$$ADD^DGENDBS(2.04,.DA,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILTIES",SUCCESS=0 "RTN","DGENELA1",246,0) Q SUCCESS "RTN","DGENELA4") 0^12^B44980796 "RTN","DGENELA4",1,0) DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN - Patient Eligibility API ; 04/24/2006 9:09 AM "RTN","DGENELA4",2,0) ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653**;Aug 13,1993;Build 2 "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)&((PRI0)&(SUB49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q "RTN","DGENELA4",105,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",106,0) .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q "RTN","DGENELA4",107,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",108,0) .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q "RTN","DGENELA4",109,0) .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q "RTN","DGENELA4",110,0) .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("AO")="Y")!(DGELG("EC")="Y")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'MTTHR)) S PRIORITY=7 D Q "RTN","DGENELA4",113,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",114,0) ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3) "RTN","DGENELA4",115,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",116,0) .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q "RTN","DGENELA4",117,0) ; "RTN","DGENELA4",118,0) Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"") "RTN","DGENELA4",119,0) ; "RTN","DGENELA4",120,0) SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT "RTN","DGENELA4",121,0) ; "RTN","DGENELA4",122,0) N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X "RTN","DGENELA4",123,0) Q:'$G(DFN) "RTN","DGENELA4",124,0) S U="^" "RTN","DGENELA4",125,0) S:$G(PRIORITY)="" PRIORITY="" "RTN","DGENELA4",126,0) S:$G(SUBGRP)="" SUBGRP="" "RTN","DGENELA4",127,0) D NOW^%DTC S TODAY=X "RTN","DGENELA4",128,0) Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP ;EGT isn't set "RTN","DGENELA4",129,0) Q:TODAYEGT("PRIORITY")) $$SUBCNV(SUBGRP) "RTN","DGENELA4",133,0) ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP "RTN","DGENELA4",134,0) S DGENRIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENELA4",135,0) I 'DGENRIEN,$G(ENRDATE),ENRDATE75)!($L(DGPAT("INELDEC"))<3) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE VARO DECISION" G QCHECK "RTN","DGENPTA1",72,0) ; "RTN","DGENPTA1",73,0) I DGPAT("INELREA")'="",($L(DGPAT("INELREA"))>40) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE REASON" G QCHECK "RTN","DGENPTA1",74,0) ; "RTN","DGENPTA1",75,0) I DGPAT("VETERAN")="" S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD = VETERAN (Y/N)?" G QCHECK "RTN","DGENPTA1",76,0) ; "RTN","DGENPTA1",77,0) I DGPAT("DEATH"),(DGPAT("DEATH")>DT) S SUCCESS=0,ERROR="DATE OF DEATH CAN NOT BE A FUTURE DATE" G QCHECK "RTN","DGENPTA1",78,0) ; "RTN","DGENPTA1",79,0) I DGPAT("INELDATE"),(DGPAT("INELREA")="") S SUCCESS=0,ERROR="INELIGIBLE REASON UNSPECIFIED FOR INELIGIBLE PATIENT" G QCHECK "RTN","DGENPTA1",80,0) ; "RTN","DGENPTA1",81,0) QCHECK ; "RTN","DGENPTA1",82,0) Q SUCCESS "RTN","DGENPTA1",83,0) ; "RTN","DGENPTA1",84,0) STORE(DGPAT,ERROR,NOCHECK) ; "RTN","DGENPTA1",85,0) ;Description: Files data in the patient record. It requires a lock "RTN","DGENPTA1",86,0) ;on the Patient record, adn releases the lock when done. "RTN","DGENPTA1",87,0) ; "RTN","DGENPTA1",88,0) ;Input: "RTN","DGENPTA1",89,0) ; DGPAT- the patient array, passed by reference "RTN","DGENPTA1",90,0) ; NOCHECK - a flag, if set to 1 it means consistency checks were done aready, so skip "RTN","DGENPTA1",91,0) ; "RTN","DGENPTA1",92,0) ;Output: "RTN","DGENPTA1",93,0) ; Function Value - returns 1 if successful, otherwise 0 "RTN","DGENPTA1",94,0) ; ERROR - on failure, an error message is returned (optional, pass by reference) "RTN","DGENPTA1",95,0) ; "RTN","DGENPTA1",96,0) S ERROR="" "RTN","DGENPTA1",97,0) I '$D(DGPAT) S ERROR="PATIENT NOT FOUND" Q 0 "RTN","DGENPTA1",98,0) I '$$LOCK(DGPAT("DFN")) S ERROR="UNABLE TO LOCK THE PATIENT RECORD" Q 0 "RTN","DGENPTA1",99,0) I $G(NOCHECK)'=1 Q:'$$CHECK(.DGPAT,.ERROR) 0 "RTN","DGENPTA1",100,0) ; "RTN","DGENPTA1",101,0) N DATA,SUB,FIELD,SUCCESS "RTN","DGENPTA1",102,0) S SUB="" "RTN","DGENPTA1",103,0) ; "RTN","DGENPTA1",104,0) F S SUB=$O(DGPAT(SUB)) Q:(SUB="") I SUB'="DEATH" S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=$G(DGPAT(SUB)) "RTN","DGENPTA1",105,0) S SUCCESS=$$UPD^DGENDBS(2,DGPAT("DFN"),.DATA) "RTN","DGENPTA1",106,0) I 'SUCCESS S ERROR="FILEMAN UNABLE TO UPDATE PATIENT RECORD" "RTN","DGENPTA1",107,0) ; Call Purple Heart API to file PH data in file 2 "RTN","DGENPTA1",108,0) I SUCCESS,$D(DGPAT("PHI")) D EDITPH^DGRPLE($G(DGPAT("PHI")),$G(DGPAT("PHST")),$G(DGPAT("PHRR")),DGPAT("DFN")) "RTN","DGENPTA1",109,0) ; Call POW API to file POW data in file 2 - DG*5.3*653 "RTN","DGENPTA1",110,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",111,0) D UNLOCK(DGPAT("DFN")) "RTN","DGENPTA1",112,0) Q SUCCESS "RTN","DGENPTA1",113,0) ; "RTN","DGENPTA1",114,0) FIELD(SUB) ; "RTN","DGENPTA1",115,0) ;Description: Returns the field number of a subscript for the PATIENT object. "RTN","DGENPTA1",116,0) ; "RTN","DGENPTA1",117,0) N FNUM "RTN","DGENPTA1",118,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="INELDATE":.152,SUB="INELREA":.307,SUB="INELDEC":.1656,SUB="PID":.363,SUB="EMGRES":.181,1:"") "RTN","DGENPTA1",119,0) I FNUM="" S FNUM=$S(SUB="IR":.32103,SUB="RADEXPM":.3212,SUB="APPREQ":1010.159,SUB="APPREQDT":1010.1511,1:"") "RTN","DGENPTA1",120,0) Q FNUM "RTN","DGENSEC") 0^41^B30651011 "RTN","DGENSEC",1,0) DGENSEC ;ALB/KCL/CKN - Patient Security API's ; 5/11/05 12:02pm "RTN","DGENSEC",2,0) ;;5.3;Registration;**222,653**;Aug 13,1993;Build 2 "RTN","DGENSEC",3,0) ; "RTN","DGENSEC",4,0) ; "RTN","DGENSEC",5,0) LOCK(DFN) ; "RTN","DGENSEC",6,0) ; Description: Used to lock the DG SECURITY LOG record for a patient "RTN","DGENSEC",7,0) ; "RTN","DGENSEC",8,0) ; Input: "RTN","DGENSEC",9,0) ; DFN - internal entry number of record in the DG SECURITY LOG file "RTN","DGENSEC",10,0) ; "RTN","DGENSEC",11,0) ; Output: "RTN","DGENSEC",12,0) ; Function Value: Returns 1 if the DG SECURITY LOG record can be "RTN","DGENSEC",13,0) ; locked, otherwise returns 0 on failure "RTN","DGENSEC",14,0) ; "RTN","DGENSEC",15,0) I $G(DFN) L +^DGSL(38.1,DFN,0):2 "RTN","DGENSEC",16,0) Q $T "RTN","DGENSEC",17,0) ; "RTN","DGENSEC",18,0) ; "RTN","DGENSEC",19,0) UNLOCK(DFN) ; "RTN","DGENSEC",20,0) ; Description: Used to unlock the DG SECURITY LOG record for a patient "RTN","DGENSEC",21,0) ; "RTN","DGENSEC",22,0) ; Input: "RTN","DGENSEC",23,0) ; DFN - internal entry number of record in the DG SECURITY LOG file "RTN","DGENSEC",24,0) ; "RTN","DGENSEC",25,0) ; Output: "RTN","DGENSEC",26,0) ; None "RTN","DGENSEC",27,0) ; "RTN","DGENSEC",28,0) I $G(DFN) L -^DGSL(38.1,DFN,0) "RTN","DGENSEC",29,0) Q "RTN","DGENSEC",30,0) ; "RTN","DGENSEC",31,0) ; "RTN","DGENSEC",32,0) FINDSEC(DFN) ; "RTN","DGENSEC",33,0) ; Description: Used to find a record in the DG SECURITY LOG file "RTN","DGENSEC",34,0) ; "RTN","DGENSEC",35,0) ; Input: "RTN","DGENSEC",36,0) ; DFN - Patient IEN "RTN","DGENSEC",37,0) ; "RTN","DGENSEC",38,0) ; Output: "RTN","DGENSEC",39,0) ; Function Value: If successful, returns internal entry number of "RTN","DGENSEC",40,0) ; DG SECURITY LOG file, otherwise returns 0 on failure "RTN","DGENSEC",41,0) ; "RTN","DGENSEC",42,0) Q:'$G(DFN)="" 0 "RTN","DGENSEC",43,0) Q +$O(^DGSL(38.1,"B",DFN,0)) "RTN","DGENSEC",44,0) ; "RTN","DGENSEC",45,0) ; "RTN","DGENSEC",46,0) GET(SECIEN,DGSEC) ; "RTN","DGENSEC",47,0) ; Description: Used to obtain a record in the DG SECURITY LOG file. The values will be returned in the DGSEC() array. "RTN","DGENSEC",48,0) ; "RTN","DGENSEC",49,0) ; Input: "RTN","DGENSEC",50,0) ; SECIEN - internal entry number of record in the DG SECURITY LOG file "RTN","DGENSEC",51,0) ; "RTN","DGENSEC",52,0) ; Output: "RTN","DGENSEC",53,0) ; DGSEC - the patient security array, passed by reference "RTN","DGENSEC",54,0) ; subscripts are: "RTN","DGENSEC",55,0) ; "DFN" Patient "RTN","DGENSEC",56,0) ; "LEVEL" Security Level "RTN","DGENSEC",57,0) ; "USER" Security Assigned By "RTN","DGENSEC",58,0) ; "DATETIME" Date/Time Security Assigned "RTN","DGENSEC",59,0) ; "SOURCE" Secuity Source "RTN","DGENSEC",60,0) ; "RTN","DGENSEC",61,0) N SUB,NODE0 "RTN","DGENSEC",62,0) K DGSEC S DGSEC="" "RTN","DGENSEC",63,0) ; "RTN","DGENSEC",64,0) I '$G(SECIEN) D Q 0 "RTN","DGENSEC",65,0) .F SUB="DFN","LEVEL","USER","DATETIME","SOURCE" S DGSEC(SUB)="" "RTN","DGENSEC",66,0) ; "RTN","DGENSEC",67,0) S NODE0=$G(^DGSL(38.1,SECIEN,0)) "RTN","DGENSEC",68,0) S DGSEC("DFN")=$P(NODE0,"^") "RTN","DGENSEC",69,0) S DGSEC("LEVEL")=$P(NODE0,"^",2) "RTN","DGENSEC",70,0) S DGSEC("USER")=$P(NODE0,"^",3) "RTN","DGENSEC",71,0) S DGSEC("DATETIME")=$P(NODE0,"^",4) "RTN","DGENSEC",72,0) S DGSEC("SOURCE")=$P(NODE0,"^",5) "RTN","DGENSEC",73,0) Q 1 "RTN","DGENSEC",74,0) ; "RTN","DGENSEC",75,0) ; "RTN","DGENSEC",76,0) STORE(DGSEC,ERROR) ; "RTN","DGENSEC",77,0) ; Description: Creates a new entry in the DG SECURITY LOG file. "RTN","DGENSEC",78,0) ; "RTN","DGENSEC",79,0) ; Input: "RTN","DGENSEC",80,0) ; DGSEC - as array containing the DG SECURITY LOG record, "RTN","DGENSEC",81,0) ; passed by reference "RTN","DGENSEC",82,0) ; "RTN","DGENSEC",83,0) ; Output: "RTN","DGENSEC",84,0) ; Function Value: Returns internal entry number of the entry created, "RTN","DGENSEC",85,0) ; otherwise 0 is returned "RTN","DGENSEC",86,0) ; ERROR - (optional) if not successful, an error msg is "RTN","DGENSEC",87,0) ; returned, pass by reference "RTN","DGENSEC",88,0) ; "RTN","DGENSEC",89,0) N DA,DD,DIC,DIE,DLAYGO,DO,DR,X,Y "RTN","DGENSEC",90,0) S DIC(0)="L",(X,DINUM)=DGSEC("DFN"),DIC="^DGSL(38.1,",DLAYGO=38.1 "RTN","DGENSEC",91,0) D FILE^DICN "RTN","DGENSEC",92,0) I Y=-1 S ERROR="FILEMAN UNABLE TO CREATE DG SECURITY LOG RECORD" Q 0 "RTN","DGENSEC",93,0) S DA=+Y "RTN","DGENSEC",94,0) ; "RTN","DGENSEC",95,0) I 'DA S ERROR="FILEMAN UNABLE TO CREATE DG SECURITY LOG RECORD" Q 0 "RTN","DGENSEC",96,0) ; "RTN","DGENSEC",97,0) ; edit/update the new record "RTN","DGENSEC",98,0) I '$$UPDATE(DA,.DGSEC,.ERROR) S ERROR="FILEMAN UNABLE TO CREATE DG SECURITY LOG RECORD" Q 0 "RTN","DGENSEC",99,0) ; "RTN","DGENSEC",100,0) ; quit with ien "RTN","DGENSEC",101,0) Q DA "RTN","DGENSEC",102,0) ; "RTN","DGENSEC",103,0) ; "RTN","DGENSEC",104,0) UPDATE(DFN,DGSEC,ERROR) ; "RTN","DGENSEC",105,0) ; Description: Updates a DG SECURITY LOG record for a patient. This "RTN","DGENSEC",106,0) ; function locks the DG SECURITY LOG record and releases the lock "RTN","DGENSEC",107,0) ; when the update is complete. "RTN","DGENSEC",108,0) ; "RTN","DGENSEC",109,0) ; Input: "RTN","DGENSEC",110,0) ; DFN - internal entry number of record in the DG SECURITY LOG file "RTN","DGENSEC",111,0) ; DGSEC - the DG SECURITY LOG array, passed by reference "RTN","DGENSEC",112,0) ; "RTN","DGENSEC",113,0) ; Output: "RTN","DGENSEC",114,0) ; Function Value - Returns 1 if successful, otherwise 0 "RTN","DGENSEC",115,0) ; ERROR - if not successful, an error message is returned, "RTN","DGENSEC",116,0) ; pass by reference "RTN","DGENSEC",117,0) ; "RTN","DGENSEC",118,0) N SUCCESS,DATA "RTN","DGENSEC",119,0) S SUCCESS=1 "RTN","DGENSEC",120,0) S ERROR="" "RTN","DGENSEC",121,0) ; "RTN","DGENSEC",122,0) D ; drops out if an invalid condition is found "RTN","DGENSEC",123,0) .I $G(DFN),$D(^DGSL(38.1,DFN,0)) "RTN","DGENSEC",124,0) .E S SUCCESS=0,ERROR="DG SECURITY LOG RECORD NOT FOUND" Q "RTN","DGENSEC",125,0) .I '$$LOCK(DFN) S SUCCESS=0,ERROR="SECURITY LOG RECORD IS LOCKED, CAN NOT BE EDITED" Q "RTN","DGENSEC",126,0) .S DATA(2)=DGSEC("LEVEL") "RTN","DGENSEC",127,0) .S DATA(3)=DGSEC("USER") "RTN","DGENSEC",128,0) .S DATA(4)=DGSEC("DATETIME") "RTN","DGENSEC",129,0) .S DATA(5)=DGSEC("SOURCE") "RTN","DGENSEC",130,0) .I '$$UPD^DGENDBS(38.1,DFN,.DATA) S ERROR="FILEMAN UNABLE TO PERFORM UPDATE",SUCCESS=0 Q "RTN","DGENSEC",131,0) ; "RTN","DGENSEC",132,0) D UNLOCK(DFN) "RTN","DGENSEC",133,0) ; "RTN","DGENSEC",134,0) Q SUCCESS "RTN","DGENSEC",135,0) ; "RTN","DGENSEC",136,0) ; "RTN","DGENSEC",137,0) CHECK(DGSEC,ERROR) ; "RTN","DGENSEC",138,0) ; Description: Performs validation checks on DG SECURITY LOG record "RTN","DGENSEC",139,0) ; contained in the DGSEC array. "RTN","DGENSEC",140,0) ; "RTN","DGENSEC",141,0) ; Input: "RTN","DGENSEC",142,0) ; DGSEC - as the patient security array, passed by reference "RTN","DGENSEC",143,0) ; "RTN","DGENSEC",144,0) ; Output: "RTN","DGENSEC",145,0) ; Function Value - Returns 1 if validation checks passed, 0 otherwise "RTN","DGENSEC",146,0) ; ERROR - if validation checks fail, an error message is "RTN","DGENSEC",147,0) ; returned, pass by reference "RTN","DGENSEC",148,0) ; "RTN","DGENSEC",149,0) N VALID,RESULT,EXTERNAL "RTN","DGENSEC",150,0) S VALID=1,ERROR="" "RTN","DGENSEC",151,0) ; "RTN","DGENSEC",152,0) D ; drops out of block if an invalid condition is found "RTN","DGENSEC",153,0) .; "RTN","DGENSEC",154,0) .I '$G(DGSEC("DFN")) S VALID=0,ERROR="PATIENT NOT FOUND IN DATABASE" Q "RTN","DGENSEC",155,0) .I '$D(^DPT(DGSEC("DFN"),0)) S VALID=0,ERROR="PATIENT NOT FOUND IN DATABASE" Q "RTN","DGENSEC",156,0) .; "RTN","DGENSEC",157,0) .; check for required fields "RTN","DGENSEC",158,0) .I $G(DGSEC("LEVEL"))="" S VALID=0,ERROR="REQUIRED FIELD 'SECURITY LEVEL' MISSING" Q "RTN","DGENSEC",159,0) .I $G(DGSEC("USER"))="" S VALID=0,ERROR="REQUIRED FIELD 'SECURITY ASSIGNED BY' MISSING" Q "RTN","DGENSEC",160,0) .I $G(DGSEC("DATETIME"))="" S VALID=0,ERROR="REQUIRED FIELD 'DATE/TIME SECURITY ASSIGNED' MISSING" Q "RTN","DGENSEC",161,0) .I $G(DGSEC("SOURCE"))="" S VALID=0,ERROR="REQUIRED FIELD 'SECURITY SOURCE' MISSING" Q "RTN","DGENSEC",162,0) .; "RTN","DGENSEC",163,0) .; apply consistency rules "RTN","DGENSEC",164,0) .I DGSEC("LEVEL")'=1 S VALID=0,ERROR="'SECURITY LEVEL' OTHER THAN SENSITIVE NOT ALLOWED" Q "RTN","DGENSEC",165,0) .;Remove consistency check for SOURCE - DG*5.3*653 "RTN","DGENSEC",166,0) .;I DGSEC("SOURCE")'="AAC" S VALID=0,ERROR="'SECURITY SOURCE' OTHER THAN AAC NOT ALLOWED" Q "RTN","DGENSEC",167,0) .; "RTN","DGENSEC",168,0) .; check if field values are valid "RTN","DGENSEC",169,0) .S EXTERNAL=$$EXTERNAL^DILFD(38.1,2,"",DGSEC("LEVEL")) "RTN","DGENSEC",170,0) .I EXTERNAL="" S VALID=0,ERROR="'SECURITY LEVEL' NOT VALID" Q "RTN","DGENSEC",171,0) .S EXTERNAL=$$EXTERNAL^DILFD(38.1,4,"",DGSEC("DATETIME")) "RTN","DGENSEC",172,0) .I EXTERNAL="" S VALID=0,ERROR="'DATE/TIME SECURITY ASSIGNED' NOT VALID" Q "RTN","DGENSEC",173,0) .I ($L($G(DGSEC("SOURCE")))<1)!($L($G(DGSEC("SOURCE")))>65) S VALID=0,ERROR="'SECURITY SOURCE' NOT VALID" Q "RTN","DGENSEC",174,0) ; "RTN","DGENSEC",175,0) Q VALID "RTN","DGENSEC",176,0) ; "RTN","DGENSEC",177,0) ; "RTN","DGENSEC",178,0) EXT(SUB,VALUE) ; Description: Given the subscript used in the PATIENT SECURITY "RTN","DGENSEC",179,0) ; array and a field value, this function returns the external "RTN","DGENSEC",180,0) ; representation of the value, as defined in the fields output "RTN","DGENSEC",181,0) ; transform of the DG SECURITY LOG file. "RTN","DGENSEC",182,0) ; "RTN","DGENSEC",183,0) ; Input: "RTN","DGENSEC",184,0) ; SUB - array subscript defined for the PATIENT SECURITY object "RTN","DGENSEC",185,0) ; VALUE - field value "RTN","DGENSEC",186,0) ; "RTN","DGENSEC",187,0) ; Output: "RTN","DGENSEC",188,0) ; Function Value - Returns the external value of the field "RTN","DGENSEC",189,0) ; "RTN","DGENSEC",190,0) Q:(('$G(SUB)="")!($G(VALUE)="")) "" "RTN","DGENSEC",191,0) ; "RTN","DGENSEC",192,0) N FIELD "RTN","DGENSEC",193,0) S FIELD=$S(SUB="DFN":.01,SUB="LEVEL":2,SUB="USER":3,SUB="DATETIME":4,SUB="SOURCE":5,1:"") "RTN","DGENSEC",194,0) ; "RTN","DGENSEC",195,0) Q:(FIELD="") "" "RTN","DGENSEC",196,0) ; "RTN","DGENSEC",197,0) Q $$EXTERNAL^DILFD(38.1,FIELD,"F",VALUE) "RTN","DGENU") 0^11^B38090905 "RTN","DGENU",1,0) DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN - Enrollment Utilities; 04/24/2006 9:20 AM "RTN","DGENU",2,0) ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653**;Aug 13,1993;Build 2 "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 group threshold, and preferred facility "RTN","DGENU",26,0) ; "RTN","DGENU",27,0) N FACNAME,PREFAC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF "RTN","DGENU",28,0) I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) "RTN","DGENU",29,0) ;Get enrollment category "RTN","DGENU",30,0) S DGENCAT=$$CATEGORY^DGENA4(DFN) "RTN","DGENU",31,0) ;Display Category in reverse video "RTN","DGENU",32,0) D REV "RTN","DGENU",33,0) ;Get enrollment group threshold "RTN","DGENU",34,0) S DGEGTIEN=$$FINDCUR^DGENEGT "RTN","DGENU",35,0) S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT) "RTN","DGENU",36,0) ;Preferred facility "RTN","DGENU",37,0) S PREFAC=$$PREF^DGENPTA(DFN,.FACNAME) "RTN","DGENU",38,0) W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE"))) "RTN","DGENU",39,0) W !?3,"Enrollment Application Date",?35,": ",$S('$G(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP"))) "RTN","DGENU",40,0) W !?3,IORVON,"Enrollment Category : ",$S($G(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF "RTN","DGENU",41,0) W !?3,"Enrollment Status",?35,": ",$S($G(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS"))) "RTN","DGENU",42,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",43,0) W !?3,"Preferred Facility",?35,": ",$S($G(FACNAME)'="":FACNAME,1:"-none-") "RTN","DGENU",44,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",45,0) W ! "RTN","DGENU",46,0) Q "RTN","DGENU",47,0) REV ;Get variables to display text in reverse video "RTN","DGENU",48,0) N X "RTN","DGENU",49,0) S X="IORVON;IORVOFF" "RTN","DGENU",50,0) D ENDR^%ZISS "RTN","DGENU",51,0) Q "RTN","DGENU",52,0) PATID(DFN) ; "RTN","DGENU",53,0) ;Description - Called by FileMan as an identifier for the Patient file. "RTN","DGENU",54,0) ;Displays current enrollment status, priority, and preferred facility. "RTN","DGENU",55,0) ; "RTN","DGENU",56,0) ;Input: "RTN","DGENU",57,0) ; DFN - ien to Patient file "RTN","DGENU",58,0) ; "RTN","DGENU",59,0) N PREFAC,DGENR,OUTPUT "RTN","DGENU",60,0) I '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) D "RTN","DGENU",61,0) .S OUTPUT="NO ENROLLMENT APPLICATION ON FILE " "RTN","DGENU",62,0) E D "RTN","DGENU",63,0) .S OUTPUT=$E("PRIORITY:"_DGENR("PRIORITY")_" ",1,12)_$E("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_" ",1,26) "RTN","DGENU",64,0) S PREFAC=$$PREF^DGENPTA(DFN) "RTN","DGENU",65,0) S:PREFAC OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$P($G(^DIC(4,PREFAC,99)),"^") "RTN","DGENU",66,0) I $G(IOM) I ($X#$G(IOM))<6 D "RTN","DGENU",67,0) .D EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))") "RTN","DGENU",68,0) E D "RTN","DGENU",69,0) .D EN^DDIOL(OUTPUT,,"!?10") "RTN","DGENU",70,0) Q "RTN","DGENU",71,0) ; "RTN","DGENU",72,0) EXT(SUB,VAL) ; "RTN","DGENU",73,0) ;Description: Given the subscript used in the PATIENT ENROLLMENT array, "RTN","DGENU",74,0) ; and a field value, returns the external representation of the "RTN","DGENU",75,0) ; value, as defined in the fields output transform of the PATIENT "RTN","DGENU",76,0) ; ENROLLMENT file. "RTN","DGENU",77,0) ;Input: "RTN","DGENU",78,0) ; SUB - subscript in the array defined by the PATIENT ENROLLMENT object "RTN","DGENU",79,0) ; VAL - value of the PATIENT ENROLLMENT object attribute named by SUB "RTN","DGENU",80,0) ;Output: "RTN","DGENU",81,0) ; Function Value - returns the external value of the attribute as "RTN","DGENU",82,0) ; defined by the PATIENT ENROLLMENT file "RTN","DGENU",83,0) ; "RTN","DGENU",84,0) Q:(($G(SUB)="")!($G(VAL)="")) "" "RTN","DGENU",85,0) ; "RTN","DGENU",86,0) N FLD "RTN","DGENU",87,0) S FLD=$$FIELD(SUB) "RTN","DGENU",88,0) ; "RTN","DGENU",89,0) Q:(FLD="") "" "RTN","DGENU",90,0) Q $$EXTERNAL^DILFD(27.11,FLD,"F",VAL) "RTN","DGENU",91,0) ; "RTN","DGENU",92,0) FIELD(SUB) ; "RTN","DGENU",93,0) ;Description: given a subscript in the enrollment array, returns the "RTN","DGENU",94,0) ; corresponding field number "RTN","DGENU",95,0) N FLD S FLD="" "RTN","DGENU",96,0) D ;drops out of block once SUB is determined "RTN","DGENU",97,0) .I SUB="APP" S FLD=.01 Q "RTN","DGENU",98,0) .I SUB="DATE" S FLD=.1 Q "RTN","DGENU",99,0) .I SUB="END" S FLD=.11 Q "RTN","DGENU",100,0) .I SUB="DFN" S FLD=.02 Q "RTN","DGENU",101,0) .I SUB="SOURCE" S FLD=.03 Q "RTN","DGENU",102,0) .I SUB="STATUS" S FLD=.04 Q "RTN","DGENU",103,0) .I SUB="REASON" S FLD=.05 Q "RTN","DGENU",104,0) .I SUB="REMARKS" S FLD=25 Q "RTN","DGENU",105,0) .I SUB="FACREC" S FLD=.06 Q "RTN","DGENU",106,0) .I SUB="PRIORITY" S FLD=.07 Q "RTN","DGENU",107,0) .I SUB="EFFDATE" S FLD=.08 Q "RTN","DGENU",108,0) .I SUB="PRIORREC" S FLD=.09 Q "RTN","DGENU",109,0) .I SUB="SUBGRP" S FLD=.12 Q "RTN","DGENU",110,0) .I SUB="CODE" S FLD=50.01 Q "RTN","DGENU",111,0) .I SUB="SC" S FLD=50.02 Q "RTN","DGENU",112,0) .I SUB="SCPER" S FLD=50.03 Q "RTN","DGENU",113,0) .I SUB="POW" S FLD=50.04 Q "RTN","DGENU",114,0) .I SUB="A&A" S FLD=50.05 Q "RTN","DGENU",115,0) .I SUB="HB" S FLD=50.06 Q "RTN","DGENU",116,0) .I SUB="VAPEN" S FLD=50.07 Q "RTN","DGENU",117,0) .I SUB="VACKAMT" S FLD=50.08 Q "RTN","DGENU",118,0) .I SUB="DISRET" S FLD=50.09 Q "RTN","DGENU",119,0) .I SUB="DISLOD" S FLD=50.2 Q ;field added with DG*5.3*672 "RTN","DGENU",120,0) .I SUB="MEDICAID" S FLD=50.1 Q "RTN","DGENU",121,0) .I SUB="AO" S FLD=50.11 Q "RTN","DGENU",122,0) .I SUB="IR" S FLD=50.12 Q "RTN","DGENU",123,0) .I SUB="EC" S FLD=50.13 Q "RTN","DGENU",124,0) .I SUB="MTSTA" S FLD=50.14 Q "RTN","DGENU",125,0) .I SUB="VCD" S FLD=50.15 Q "RTN","DGENU",126,0) .I SUB="PH" S FLD=50.16 Q "RTN","DGENU",127,0) .I SUB="UNEMPLOY" S FLD=50.17 Q "RTN","DGENU",128,0) .I SUB="CVELEDT" S FLD=50.18 Q "RTN","DGENU",129,0) .I SUB="SHAD" S FLD=50.19 Q ;field added with DG*5.3*653 "RTN","DGENU",130,0) .I SUB="DATETIME" S FLD=75.01 Q "RTN","DGENU",131,0) .I SUB="USER" S FLD=75.02 Q "RTN","DGENU",132,0) .I SUB="RADEXPM" S FLD=76 Q "RTN","DGENU",133,0) Q FLD "RTN","DGENU",134,0) ; "RTN","DGENU",135,0) PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ; "RTN","DGENU",136,0) ;Description: requests user to enter a single field value. "RTN","DGENU",137,0) ;Input: "RTN","DGENU",138,0) ; FILE - the file # "RTN","DGENU",139,0) ; FIELD - the field # "RTN","DGENU",140,0) ; DEFAULT - default value, internal form "RTN","DGENU",141,0) ; REQUIRE - a flag, (+value)'=0 means to require a value to be "RTN","DGENU",142,0) ; entered and to return failure otherwise (optional) "RTN","DGENU",143,0) ; PRMPTNM - Optional "RTN","DGENU",144,0) ; 0 - display field LABEL "RTN","DGENU",145,0) ; 1 - Prompt field TITLE "RTN","DGENU",146,0) ;Output: "RTN","DGENU",147,0) ; Function Value - 0 on failure, 1 on success "RTN","DGENU",148,0) ; RESPONSE - value entered by user, pass by reference "RTN","DGENU",149,0) ; "RTN","DGENU",150,0) Q:(('$G(FILE))!('$G(FIELD))) 0 "RTN","DGENU",151,0) S REQUIRE=$G(REQUIRE) "RTN","DGENU",152,0) S PRMPTNM=$G(PRMPTNM) "RTN","DGENU",153,0) N DIR,DA,QUIT,AGAIN "RTN","DGENU",154,0) ; "RTN","DGENU",155,0) S DIR(0)=FILE_","_FIELD_$S($G(REQUIRE):"",1:"O")_"AO" "RTN","DGENU",156,0) I $G(DEFAULT)'="" DO "RTN","DGENU",157,0) . S:+$G(PRMPTNM)=0 DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// " "RTN","DGENU",158,0) . S:+$G(PRMPTNM)>0 DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// " "RTN","DGENU",159,0) S QUIT=0 "RTN","DGENU",160,0) F D Q:QUIT "RTN","DGENU",161,0) . D ^DIR "RTN","DGENU",162,0) . I $D(DTOUT)!$D(DUOUT) S QUIT=1 Q "RTN","DGENU",163,0) . I X="@" D Q:AGAIN "RTN","DGENU",164,0) . . S AGAIN=0 "RTN","DGENU",165,0) . . I 'REQUIRE,"Yy"'[$E($$YN^DGENCD1(" Are you sure")_"X") S AGAIN=1 Q "RTN","DGENU",166,0) . . S RESPONSE="" ; This might trigger the "required" message below. "RTN","DGENU",167,0) . E I X="" S RESPONSE=$G(DEFAULT) "RTN","DGENU",168,0) . E S RESPONSE=$P(Y,"^") "RTN","DGENU",169,0) . ; "RTN","DGENU",170,0) . ; quit this loop if the user entered value OR value not required "RTN","DGENU",171,0) . I RESPONSE'="" S QUIT=1 Q "RTN","DGENU",172,0) . I 'REQUIRE S QUIT=1 Q "RTN","DGENU",173,0) . W !,"This is a required response. Enter '^' to exit" "RTN","DGENU",174,0) I $D(DTOUT)!$D(DUOUT) Q 0 "RTN","DGENU",175,0) Q 1 "RTN","DGENU",176,0) ; "RTN","DGENU",177,0) INST() ; "RTN","DGENU",178,0) ; Description: Determine the institution affiliation associated with a user. "RTN","DGENU",179,0) ; "RTN","DGENU",180,0) ; Input: "RTN","DGENU",181,0) ; DUZ(2) - Pointer to the INSTITUTION (#4) file (institution "RTN","DGENU",182,0) ; affiliated with user, prompted at Kernel sign-on) "RTN","DGENU",183,0) ; "RTN","DGENU",184,0) ; Output: "RTN","DGENU",185,0) ; Function Value - Returns pointer to the INSTITUTION (#4) file "RTN","DGENU",186,0) ; entry that is associated with the user, otherwise the pointer "RTN","DGENU",187,0) ; to the INSTITUTION (#4) file entry of the primary VA Medical "RTN","DGENU",188,0) ; Center division is returned. "RTN","DGENU",189,0) ; "RTN","DGENU",190,0) Q $S($G(DUZ(2)):DUZ(2),1:$P($$SITE^VASITE(),"^")) "RTN","DGENU",191,0) ; "RTN","DGENU",192,0) GETINST(DGPREFAC,DGINST) ;Get Institution file data "RTN","DGENU",193,0) ; Input -- DGPREFAC Institution file IEN "RTN","DGENU",194,0) ; Output -- 1=Successful and 0=Failure "RTN","DGENU",195,0) ; DGINST - Institution file Array "RTN","DGENU",196,0) N DGINST0,DGINST99,DGOKF "RTN","DGENU",197,0) S DGINST0=$G(^DIC(4,DGPREFAC,0)) G GETQ:DGINST0="" "RTN","DGENU",198,0) S DGINST("NAME")=$P(DGINST0,U) "RTN","DGENU",199,0) S DGINST99=$G(^DIC(4,DGPREFAC,99)) "RTN","DGENU",200,0) S DGINST("STANUM")=$P(DGINST99,U) "RTN","DGENU",201,0) S DGOKF=1 "RTN","DGENU",202,0) GETQ Q +$G(DGOKF) "RTN","DGENUPL1") 0^25^B34423336 "RTN","DGENUPL1",1,0) DGENUPL1 ;ALB/CJM,ISA/KWP,CKN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 2/25/02 1:39pm "RTN","DGENUPL1",2,0) ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653**;Aug 13,1993;Build 2 "RTN","DGENUPL1",3,0) ; "RTN","DGENUPL1",4,0) ; "RTN","DGENUPL1",5,0) PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST) ; "RTN","DGENUPL1",6,0) ;Description: This function parses the HL7 segments. It creates arrays "RTN","DGENUPL1",7,0) ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY, "RTN","DGENUPL1",8,0) ;OEF/OIF CONFLICT objects. "RTN","DGENUPL1",9,0) ;Field values are put in DHCP format and the validity at the "RTN","DGENUPL1",10,0) ;field level is tested. Fields to be deleted are set to "@". "RTN","DGENUPL1",11,0) ; "RTN","DGENUPL1",12,0) ;Input: "RTN","DGENUPL1",13,0) ; MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772) "RTN","DGENUPL1",14,0) ; MSGID -message control id of HL7 msg in the MSH segment "RTN","DGENUPL1",15,0) ; CURLINE - the subscript of the PID segment of the current message (pass by reference) "RTN","DGENUPL1",16,0) ; ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref) "RTN","DGENUPL1",17,0) ; "RTN","DGENUPL1",18,0) ;Output: "RTN","DGENUPL1",19,0) ; Function Value: Returns 1 on success, 0 on failure. "RTN","DGENUPL1",20,0) ; CURLINE - upon leaving the procedure this parameter should be set to the end of the current message. "RTN","DGENUPL1",21,0) ; ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref) "RTN","DGENUPL1",22,0) ; DGPAT - array defined by the PATIENT object. (pass by ref) "RTN","DGENUPL1",23,0) ; DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref) "RTN","DGENUPL1",24,0) ; DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref) "RTN","DGENUPL1",25,0) ; DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref) "RTN","DGENUPL1",26,0) ; DGSEC - array defined by the PATIENT SECURITY object. (pass by ref) "RTN","DGENUPL1",27,0) ; DGOEIF - array defined by the OEF/OIF CONFLICT object. (pass by ref) "RTN","DGENUPL1",28,0) ; DGNTR - array defined for NTR data. "RTN","DGENUPL1",29,0) ; DGMST - array defined for MST data. "RTN","DGENUPL1",30,0) N SEG,ERROR,COUNT,QFLG,NFLG "RTN","DGENUPL1",31,0) ; "RTN","DGENUPL1",32,0) K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST "RTN","DGENUPL1",33,0) ; "RTN","DGENUPL1",34,0) S ERROR=0,NFLG=1 "RTN","DGENUPL1",35,0) F SEG="PID","ZPD","ZIE","ZIO","ZEL" D Q:ERROR "RTN","DGENUPL1",36,0) .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",37,0) .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q "RTN","DGENUPL1",38,0) .I SEG("TYPE")=SEG D Q "RTN","DGENUPL1",39,0) ..D:(SEG'="ZEL") @SEG^DGENUPL2 "RTN","DGENUPL1",40,0) ..D:(SEG="ZEL") ZEL^DGENUPL2(1) "RTN","DGENUPL1",41,0) ..S NFLG=1 "RTN","DGENUPL1",42,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT) "RTN","DGENUPL1",43,0) .S ERROR=1 "RTN","DGENUPL1",44,0) .; "RTN","DGENUPL1",45,0) .;possible that in a bad message we are now past the end "RTN","DGENUPL1",46,0) .S CURLINE=CURLINE-1 "RTN","DGENUPL1",47,0) ; "RTN","DGENUPL1",48,0) I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL") D Q:ERROR "RTN","DGENUPL1",49,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",50,0) .D ZEL^DGENUPL2(COUNT) "RTN","DGENUPL1",51,0) ;Phase II Add the capability to accept more than 1 ZCD "RTN","DGENUPL1",52,0) I 'ERROR F SEG="ZEN","ZMT","ZCD" D Q:ERROR "RTN","DGENUPL1",53,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",54,0) .I SEG("TYPE")=SEG D "RTN","DGENUPL1",55,0) ..D @SEG^DGENUPL2 "RTN","DGENUPL1",56,0) .E D "RTN","DGENUPL1",57,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUTOF ORDER",.ERRCOUNT) "RTN","DGENUPL1",58,0) ..S ERROR=1 "RTN","DGENUPL1",59,0) ..; "RTN","DGENUPL1",60,0) ..;possible that in a bad message we are now past the end "RTN","DGENUPL1",61,0) ..S CURLINE=CURLINE-1 "RTN","DGENUPL1",62,0) ; "RTN","DGENUPL1",63,0) I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD") D Q:ERROR "RTN","DGENUPL1",64,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",65,0) .D ZCD^DGENUPL2 "RTN","DGENUPL1",66,0) ; "RTN","DGENUPL1",67,0) ; Purple Heart/OEF-OIF Addition of optional ZMH segment "RTN","DGENUPL1",68,0) ; Modified handling of ZSP and ZRD to accomodate ZMH "RTN","DGENUPL1",69,0) ; "RTN","DGENUPL1",70,0) I 'ERROR D Q:ERROR $S(ERROR:0,1:1) "RTN","DGENUPL1",71,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",72,0) .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q "RTN","DGENUPL1",73,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT) "RTN","DGENUPL1",74,0) .S ERROR=1 "RTN","DGENUPL1",75,0) .;possible that in a bad message we are now past the end "RTN","DGENUPL1",76,0) .S CURLINE=CURLINE-1 "RTN","DGENUPL1",77,0) ; "RTN","DGENUPL1",78,0) ;Modified following code to receive multiple ZMH segment for "RTN","DGENUPL1",79,0) ;Military service information - DG*5.3*653 "RTN","DGENUPL1",80,0) I 'ERROR D Q:ERROR $S(ERROR:0,1:1) "RTN","DGENUPL1",81,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",82,0) .S QFLG=0 F D Q:QFLG "RTN","DGENUPL1",83,0) . . I SEG("TYPE")'="ZMH" S QFLG=1 Q "RTN","DGENUPL1",84,0) . . D ZMH^DGENUPL2,NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",85,0) .I SEG("TYPE")="ZRD" D ZRD^DGENUPL2 Q "RTN","DGENUPL1",86,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT) "RTN","DGENUPL1",87,0) .S ERROR=1 "RTN","DGENUPL1",88,0) .;possible that in a bad message we are now past the end "RTN","DGENUPL1",89,0) .S CURLINE=CURLINE-1 "RTN","DGENUPL1",90,0) ; "RTN","DGENUPL1",91,0) I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD") D Q:ERROR "RTN","DGENUPL1",92,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",93,0) .D ZRD^DGENUPL2 "RTN","DGENUPL1",94,0) ; "RTN","DGENUPL1",95,0) I 'ERROR F D Q:(ERROR!(SEG("TYPE")'="OBX")) "RTN","DGENUPL1",96,0) .;possible if OBX segment not present that we are now past the end "RTN","DGENUPL1",97,0) .I SEG("TYPE")'="OBX" S CURLINE=CURLINE-1 Q "RTN","DGENUPL1",98,0) .D OBX^DGENUPL2 "RTN","DGENUPL1",99,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",100,0) .D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) "RTN","DGENUPL1",101,0) ; "RTN","DGENUPL1",102,0) Q $S(ERROR:0,1:1) "RTN","DGENUPL1",103,0) ; "RTN","DGENUPL1",104,0) CONVERT(VAL,DATATYPE,ERROR) ; "RTN","DGENUPL1",105,0) ;Description: Converts the value found in the HL7 segment to DHCP format "RTN","DGENUPL1",106,0) ; "RTN","DGENUPL1",107,0) ;Input: "RTN","DGENUPL1",108,0) ; VAL - value parsed from the HL7 segment "RTN","DGENUPL1",109,0) ; DATATYPE: indicates the type of conversion necessary "RTN","DGENUPL1",110,0) ; "DATE" - needs to be converted to FM format "RTN","DGENUPL1",111,0) ; "TS" - time stamp, needs to be converted to FM format "RTN","DGENUPL1",112,0) ; "Y/N" - 0->"N",1->"Y" "RTN","DGENUPL1",113,0) ; "1/0" - "Y"->1,"N"->0 "RTN","DGENUPL1",114,0) ; "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file "RTN","DGENUPL1",115,0) ; "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8) "RTN","DGENUPL1",116,0) ; "RTN","DGENUPL1",117,0) ; "MT" - VAL is a Means Test Status code, it needs to be converted "RTN","DGENUPL1",118,0) ; to a pointer to the Means Test Status file "RTN","DGENUPL1",119,0) ; Phase II convert code to RSN IEN for DGCDIS object "RTN","DGENUPL1",120,0) ; "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5) "RTN","DGENUPL1",121,0) ; "EXT" convert from code to abbreviation "RTN","DGENUPL1",122,0) ; "POS" convert from Period of Service code to a point to Period of Service file "RTN","DGENUPL1",123,0) ;OUTPUT: "RTN","DGENUPL1",124,0) ; Function Value - the result of the conversion "RTN","DGENUPL1",125,0) ; ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref) "RTN","DGENUPL1",126,0) ; "RTN","DGENUPL1",127,0) S ERROR=0 "RTN","DGENUPL1",128,0) D "RTN","DGENUPL1",129,0) .I VAL="" Q "RTN","DGENUPL1",130,0) .I VAL="""""" S VAL="@" Q "RTN","DGENUPL1",131,0) .I $G(DATATYPE)="EXT" D Q "RTN","DGENUPL1",132,0) ..S VAL=$$HLTOLIMB^DGENA5(VAL) "RTN","DGENUPL1",133,0) .I $G(DATATYPE)="CDRSN" D Q "RTN","DGENUPL1",134,0) ..S VAL=$$HL7TORSN^DGENA5(VAL) "RTN","DGENUPL1",135,0) .I ($G(DATATYPE)="MT") D Q "RTN","DGENUPL1",136,0) ..S VAL=$O(^DG(408.32,"AC",1,VAL,0)) "RTN","DGENUPL1",137,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",138,0) .I ($G(DATATYPE)="DATE") D Q "RTN","DGENUPL1",139,0) ..I $L(VAL)'=8 S ERROR=1 Q "RTN","DGENUPL1",140,0) ..S VAL=$$FMDATE^HLFNC(VAL) "RTN","DGENUPL1",141,0) ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1 "RTN","DGENUPL1",142,0) .I ($G(DATATYPE)="TS") D Q "RTN","DGENUPL1",143,0) ..I $L(VAL)<8 S ERROR=1 Q "RTN","DGENUPL1",144,0) ..S VAL=$$FMDATE^HLFNC(VAL) "RTN","DGENUPL1",145,0) ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1 "RTN","DGENUPL1",146,0) .I ($G(DATATYPE)="Y/N") D Q "RTN","DGENUPL1",147,0) ..I VAL=0 S VAL="N" Q "RTN","DGENUPL1",148,0) ..I VAL=1 S VAL="Y" Q "RTN","DGENUPL1",149,0) ..S ERROR=1 "RTN","DGENUPL1",150,0) .I ($G(DATATYPE)="1/0") D Q "RTN","DGENUPL1",151,0) ..I VAL="N" S VAL=0 Q "RTN","DGENUPL1",152,0) ..I VAL="Y" S VAL=1 Q "RTN","DGENUPL1",153,0) ..S ERROR=1 "RTN","DGENUPL1",154,0) .I ($G(DATATYPE)="ELIGIBILITY") D Q "RTN","DGENUPL1",155,0) ..S VAL=$$MAP(VAL) "RTN","DGENUPL1",156,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",157,0) .I ($G(DATATYPE)="INSTITUTION") D Q "RTN","DGENUPL1",158,0) ..N OLDVAL "RTN","DGENUPL1",159,0) ..S OLDVAL=VAL "RTN","DGENUPL1",160,0) ..S VAL=$O(^DIC(4,"D",OLDVAL,0)) "RTN","DGENUPL1",161,0) ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0)) "RTN","DGENUPL1",162,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",163,0) .I ($G(DATATYPE)="POS") D Q "RTN","DGENUPL1",164,0) ..N OLDVAL "RTN","DGENUPL1",165,0) ..S OLDVAL=VAL "RTN","DGENUPL1",166,0) ..S VAL=$O(^DIC(21,"D",OLDVAL,0)) "RTN","DGENUPL1",167,0) Q VAL "RTN","DGENUPL1",168,0) ; "RTN","DGENUPL1",169,0) MAP(VALUE) ; "RTN","DGENUPL1",170,0) ;Description: Tries to map an eligibility code from file #8.1 (the national MAS ELIGIBILITY CODE file) to file #8 (the local ELIGIBILITY CODE file) "RTN","DGENUPL1",171,0) ; "RTN","DGENUPL1",172,0) ;Input: VALUE - ien of an entry in file #8.1 "RTN","DGENUPL1",173,0) ; "RTN","DGENUPL1",174,0) ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8 "RTN","DGENUPL1",175,0) ; "RTN","DGENUPL1",176,0) N ECODE,NODE,COUNT,NAME "RTN","DGENUPL1",177,0) ;try to choose a code from file 8 to use that is appropriate "RTN","DGENUPL1",178,0) S (COUNT,ECODE)=0 "RTN","DGENUPL1",179,0) ; "RTN","DGENUPL1",180,0) F S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE D "RTN","DGENUPL1",181,0) .S NODE=$G(^DIC(8,ECODE,0)) "RTN","DGENUPL1",182,0) .;put code on list if active "RTN","DGENUPL1",183,0) .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1 "RTN","DGENUPL1",184,0) ; "RTN","DGENUPL1",185,0) ;only one match found, so use it "RTN","DGENUPL1",186,0) Q:COUNT=1 $O(ECODE(0)) "RTN","DGENUPL1",187,0) ; "RTN","DGENUPL1",188,0) ;no match found "RTN","DGENUPL1",189,0) Q:'COUNT "" "RTN","DGENUPL1",190,0) ; "RTN","DGENUPL1",191,0) ;multiple matches found, try to match by name "RTN","DGENUPL1",192,0) I COUNT>1 D "RTN","DGENUPL1",193,0) .S ECODE=0 "RTN","DGENUPL1",194,0) .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^") "RTN","DGENUPL1",195,0) .F S ECODE=$O(ECODE(ECODE)) Q:'ECODE Q:ECODE(ECODE)=NAME "RTN","DGENUPL1",196,0) Q ECODE "RTN","DGENUPL1",197,0) ; "RTN","DGENUPL1",198,0) ACCEPT(MSGID) ; "RTN","DGENUPL1",199,0) ;Description: Writes an ack (AA) to a global to be transmitted later. "RTN","DGENUPL1",200,0) ; "RTN","DGENUPL1",201,0) ;Inputs: "RTN","DGENUPL1",202,0) ; MSGID -message control id of HL7 msg in the MSH segment "RTN","DGENUPL1",203,0) ; "RTN","DGENUPL1",204,0) ;Outputs: none "RTN","DGENUPL1",205,0) ; "RTN","DGENUPL1",206,0) K HL,HLMID,HLMTIEN,HLDT,HLDT1 "RTN","DGENUPL1",207,0) D INIT^HLFNC2(HLEID,.HL) "RTN","DGENUPL1",208,0) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) "RTN","DGENUPL1",209,0) S HLEVN=1 "RTN","DGENUPL1",210,0) S MID=HLMID_"-"_HLEVN "RTN","DGENUPL1",211,0) D MSH^HLFNC2(.HL,MID,.HLRES) "RTN","DGENUPL1",212,0) S ^TMP("HLS",$J,1)=HLRES "RTN","DGENUPL1",213,0) ; "RTN","DGENUPL1",214,0) ;it seems HLFS sometimes disappears upon reaching this point "RTN","DGENUPL1",215,0) I $G(HLFS)="" S HLFS="^" "RTN","DGENUPL1",216,0) ; "RTN","DGENUPL1",217,0) S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID "RTN","DGENUPL1",218,0) Q "RTN","DGENUPL1",219,0) ; "RTN","DGENUPL1",220,0) MVERRORS ; "RTN","DGENUPL1",221,0) ;Error messages were being deleted from ^TMP("HLS",$J by another package "RTN","DGENUPL1",222,0) ;during the upload. To fix this, errors are written to another "RTN","DGENUPL1",223,0) ;subscript, then moved when the error list is complete. "RTN","DGENUPL1",224,0) ; "RTN","DGENUPL1",225,0) M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J) "RTN","DGENUPL1",226,0) K ^TMP("IVM","HLS",$J) "RTN","DGENUPL1",227,0) Q "RTN","DGENUPL2") 0^26^B72501035 "RTN","DGENUPL2",1,0) DGENUPL2 ;ALB/CJM,RTK,TMK,ISA/KWP/RMM/CKN,EG,TDM,ERC - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 9/18/06 4:38pm "RTN","DGENUPL2",2,0) ;;5.3;REGISTRATION;**147,222,232,310,314,367,397,677,631,675,672,673,716,653**;Aug 13,1993;Build 2 "RTN","DGENUPL2",3,0) ; "RTN","DGENUPL2",4,0) ;************************************************************** "RTN","DGENUPL2",5,0) ;The following procedures parse particular segment types. "RTN","DGENUPL2",6,0) ;Input:SEG(),MSGID "RTN","DGENUPL2",7,0) ;Output:DGPAT(),DGELG(),DGENR(),DGCDIS(),DGNTR(),DGOEIF(),ERROR "RTN","DGENUPL2",8,0) ;************************************************************** "RTN","DGENUPL2",9,0) ; "RTN","DGENUPL2",10,0) PID ; "RTN","DGENUPL2",11,0) S DGPAT("SSN")=SEG(19) "RTN","DGENUPL2",12,0) Q "RTN","DGENUPL2",13,0) ; "RTN","DGENUPL2",14,0) ZPD ; "RTN","DGENUPL2",15,0) S DGELG("RATEINC")=$$CONVERT^DGENUPL1(SEG(8)) "RTN","DGENUPL2",16,0) S DGPAT("DEATH")=$$CONVERT^DGENUPL1(SEG(9),"TS",.ERROR) "RTN","DGENUPL2",17,0) I ERROR D Q "RTN","DGENUPL2",18,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 9",.ERRCOUNT) "RTN","DGENUPL2",19,0) S DGELG("MEDICAID")=$$CONVERT^DGENUPL1(SEG(12)) "RTN","DGENUPL2",20,0) S DGELG("MEDASKDT")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR) "RTN","DGENUPL2",21,0) I ERROR D Q "RTN","DGENUPL2",22,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 13",.ERRCOUNT) "RTN","DGENUPL2",23,0) S DGELG("POW")=$$CONVERT^DGENUPL1(SEG(17)) "RTN","DGENUPL2",24,0) S DGPAT("EMGRES")=$$CONVERT^DGENUPL1(SEG(40)) ;DG*5.3*677 "RTN","DGENUPL2",25,0) Q "RTN","DGENUPL2",26,0) ; "RTN","DGENUPL2",27,0) ZIE ; "RTN","DGENUPL2",28,0) S DGPAT("INELDATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR) "RTN","DGENUPL2",29,0) I ERROR D Q "RTN","DGENUPL2",30,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIE SEGMENT, SEQ 2",.ERRCOUNT) "RTN","DGENUPL2",31,0) S DGPAT("INELREA")=$$CONVERT^DGENUPL1(SEG(3)) "RTN","DGENUPL2",32,0) S DGPAT("INELDEC")=$$CONVERT^DGENUPL1(SEG(4)) "RTN","DGENUPL2",33,0) Q "RTN","DGENUPL2",34,0) ; "RTN","DGENUPL2",35,0) ZIO ;New segment - DG*5.3*653 "RTN","DGENUPL2",36,0) D ZIO^DGENUPLA ;Code for ZIO has moved to DGENUPLA "RTN","DGENUPL2",37,0) Q "RTN","DGENUPL2",38,0) ; "RTN","DGENUPL2",39,0) ZEL(COUNT) ; "RTN","DGENUPL2",40,0) D ZEL^DGENUPLA(COUNT) ;code for ZEL segment has moved to DGENUPLA "RTN","DGENUPL2",41,0) Q "RTN","DGENUPL2",42,0) ; "RTN","DGENUPL2",43,0) ZEN ; "RTN","DGENUPL2",44,0) N SUB "RTN","DGENUPL2",45,0) S DGENR("DATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR) "RTN","DGENUPL2",46,0) I ERROR D Q "RTN","DGENUPL2",47,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 2",.ERRCOUNT) "RTN","DGENUPL2",48,0) S DGENR("SOURCE")=$$CONVERT^DGENUPL1(SEG(3)) "RTN","DGENUPL2",49,0) S DGENR("STATUS")=$$CONVERT^DGENUPL1(SEG(4)) "RTN","DGENUPL2",50,0) S ERROR=$$PEND(DFN,DGENR("STATUS")) "RTN","DGENUPL2",51,0) I ERROR D Q "RTN","DGENUPL2",52,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ENROLLMENT STATUS PENDING-ELIGIBILITY IS VERIFIED",.ERRCOUNT) "RTN","DGENUPL2",53,0) S DGENR("REASON")=$$CONVERT^DGENUPL1(SEG(5)) "RTN","DGENUPL2",54,0) S DGENR("REMARKS")=$$CONVERT^DGENUPL1(SEG(6)) "RTN","DGENUPL2",55,0) S DGENR("FACREC")=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR) "RTN","DGENUPL2",56,0) I ERROR D Q "RTN","DGENUPL2",57,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY RECEIVED "_SEG(7)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT) "RTN","DGENUPL2",58,0) S DGPAT("PREFAC")=$$CONVERT^DGENUPL1(SEG(8),"INSTITUTION",.ERROR) "RTN","DGENUPL2",59,0) I ERROR D Q "RTN","DGENUPL2",60,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"PREFERRED FACILITY "_SEG(8)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT) "RTN","DGENUPL2",61,0) ; "RTN","DGENUPL2",62,0) S DGENR("PRIORITY")=$$CONVERT^DGENUPL1(SEG(9)) "RTN","DGENUPL2",63,0) S DGENR("EFFDATE")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR) "RTN","DGENUPL2",64,0) I ERROR D Q "RTN","DGENUPL2",65,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 10",.ERRCOUNT) "RTN","DGENUPL2",66,0) S DGENR("APP")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR) "RTN","DGENUPL2",67,0) I ERROR D Q "RTN","DGENUPL2",68,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 11",.ERRCOUNT) "RTN","DGENUPL2",69,0) ; "RTN","DGENUPL2",70,0) ;!!!!!! take next line out when HEC begins transmitting application dt "RTN","DGENUPL2",71,0) I DGENR("APP")="" S DGENR("APP")=DGENR("DATE") "RTN","DGENUPL2",72,0) I DGENR("APP")="" S DGENR("APP")=DGENR("EFFDATE") "RTN","DGENUPL2",73,0) ; "RTN","DGENUPL2",74,0) S DGENR("END")=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR) "RTN","DGENUPL2",75,0) I ERROR D Q "RTN","DGENUPL2",76,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 12",.ERRCOUNT) "RTN","DGENUPL2",77,0) ;Phase II Parse out Sub-Group (SRS 6.4) "RTN","DGENUPL2",78,0) S DGENR("SUBGRP")=$$CONVERT^DGENUPL1(SEG(13)) "RTN","DGENUPL2",79,0) ; "RTN","DGENUPL2",80,0) ;want to ignore double quotes sent for enrollment fields "RTN","DGENUPL2",81,0) S SUB="" "RTN","DGENUPL2",82,0) F S SUB=$O(DGENR(SUB)) Q:SUB="" I DGENR(SUB)="@" S DGENR(SUB)="" "RTN","DGENUPL2",83,0) ; "RTN","DGENUPL2",84,0) Q "RTN","DGENUPL2",85,0) ; "RTN","DGENUPL2",86,0) ZMT ; "RTN","DGENUPL2",87,0) I SEG(1)>1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ZMT SEGMENT, SEQ 1, SHOULD SPECIFY MEANS TEST",.ERRCOUNT) S ERROR=1 Q "RTN","DGENUPL2",88,0) S DGELG("MTSTA")=$$CONVERT^DGENUPL1(SEG(3),"MT",.ERROR) "RTN","DGENUPL2",89,0) I ERROR D Q "RTN","DGENUPL2",90,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMT SEGMENT, SEQ 3",.ERRCOUNT) "RTN","DGENUPL2",91,0) Q "RTN","DGENUPL2",92,0) ; "RTN","DGENUPL2",93,0) ZCD ; "RTN","DGENUPL2",94,0) ;Phase II for multiple ZCD's "RTN","DGENUPL2",95,0) I SEG(1)>1 G SKIP "RTN","DGENUPL2",96,0) S DGCDIS("BY")=$$CONVERT^DGENUPL1(SEG(3)) "RTN","DGENUPL2",97,0) S DGCDIS("DATE")=$$CONVERT^DGENUPL1(SEG(5),"DATE",.ERROR) "RTN","DGENUPL2",98,0) I ERROR D Q "RTN","DGENUPL2",99,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 5",.ERRCOUNT) "RTN","DGENUPL2",100,0) S DGCDIS("FACDET")=$$CONVERT^DGENUPL1(SEG(4),"INSTITUTION",.ERROR) "RTN","DGENUPL2",101,0) I ERROR D Q "RTN","DGENUPL2",102,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY "_SEG(4)_" MAKING CATASTROPHIC DISABILITY DETERMINATION NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT) "RTN","DGENUPL2",103,0) S DGCDIS("REVDTE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR) "RTN","DGENUPL2",104,0) I ERROR D Q "RTN","DGENUPL2",105,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 2",.ERRCOUNT) "RTN","DGENUPL2",106,0) S DGCDIS("METDET")=$$CONVERT^DGENUPL1($P(SEG(6),$E(HLECH))) "RTN","DGENUPL2",107,0) S DGCDIS("VCD")=$$CONVERT^DGENUPL1(SEG(12)) "RTN","DGENUPL2",108,0) ;SEQ 14 - DATE VETERAN REQUESTED CD EVALUATION "RTN","DGENUPL2",109,0) S DGCDIS("VETREQDT")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR) "RTN","DGENUPL2",110,0) I ERROR D Q "RTN","DGENUPL2",111,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 14",.ERRCOUNT) "RTN","DGENUPL2",112,0) ;SEQ 15 - DATE FACILITY INITIATED REVIEW "RTN","DGENUPL2",113,0) S DGCDIS("DTFACIRV")=$$CONVERT^DGENUPL1(SEG(15),"DATE",.ERROR) "RTN","DGENUPL2",114,0) I ERROR D Q "RTN","DGENUPL2",115,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 15",.ERRCOUNT) "RTN","DGENUPL2",116,0) ;SEQ 16 - DATE VETERAN WAS NOTIFIED "RTN","DGENUPL2",117,0) S DGCDIS("DTVETNOT")=$$CONVERT^DGENUPL1(SEG(16),"DATE",.ERROR) "RTN","DGENUPL2",118,0) I ERROR D Q "RTN","DGENUPL2",119,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 16",.ERRCOUNT) "RTN","DGENUPL2",120,0) SKIP ; "RTN","DGENUPL2",121,0) ;Phase II Parse out additional fields. CONVERT type of RSN converts the code to IEN for diagnosis,procedure and condition (HL7TORSN^DGENA5). "RTN","DGENUPL2",122,0) S DGCDIS("DIAG",SEG(1))=$$CONVERT^DGENUPL1(SEG(7),"CDRSN") "RTN","DGENUPL2",123,0) S DGCDIS("PROC",SEG(1))=$$CONVERT^DGENUPL1(SEG(8),"CDRSN") "RTN","DGENUPL2",124,0) S DGCDIS("EXT",SEG(1),1)=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH)),"EXT") "RTN","DGENUPL2",125,0) S DGCDIS("COND",SEG(1))=$$CONVERT^DGENUPL1(SEG(10),"CDRSN") "RTN","DGENUPL2",126,0) S DGCDIS("SCORE",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(11),$E(HLECH))) "RTN","DGENUPL2",127,0) S DGCDIS("PERM",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(13),$E(HLECH))) "RTN","DGENUPL2",128,0) I DGCDIS("VCD")="Y",'DGCDIS("DIAG",SEG(1)),'DGCDIS("PROC",SEG(1)),'DGCDIS("COND",SEG(1)) D Q "RTN","DGENUPL2",129,0) .S ERROR=1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"NO VALID DIAGNOSIS,PROCEDURE, OR CONDITION IN THE ZCD SEGMENT",.ERRCOUNT) "RTN","DGENUPL2",130,0) Q "RTN","DGENUPL2",131,0) ; "RTN","DGENUPL2",132,0) ZSP ; "RTN","DGENUPL2",133,0) S DGELG("SC")=$$CONVERT^DGENUPL1(SEG(2),"Y/N",.ERROR) "RTN","DGENUPL2",134,0) I ERROR D Q "RTN","DGENUPL2",135,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 2",.ERRCOUNT) "RTN","DGENUPL2",136,0) S DGELG("SCPER")=$$CONVERT^DGENUPL1(SEG(3)) "RTN","DGENUPL2",137,0) S DGELG("POS")=$$CONVERT^DGENUPL1(SEG(4),"POS",.ERROR) "RTN","DGENUPL2",138,0) I ERROR D Q "RTN","DGENUPL2",139,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 4",.ERRCOUNT) "RTN","DGENUPL2",140,0) S DGELG("EFFDT")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR) "RTN","DGENUPL2",141,0) I ERROR D Q "RTN","DGENUPL2",142,0) . D ADDERROR^DGENUPL(MSGID,$G(DGELG("EFFDT")),"BAD VALUE, ZSP SEGMENT, SEQ 11",.ERRCOUNT) "RTN","DGENUPL2",143,0) ;if effective date is null, set update value to "@" (delete) "RTN","DGENUPL2",144,0) I DGELG("EFFDT")="" S DGELG("EFFDT")="@" "RTN","DGENUPL2",145,0) ; "RTN","DGENUPL2",146,0) ;added 8/3/98 to reduce #rejects "RTN","DGENUPL2",147,0) ;if HEC sends SC=NO, SC% not sent, and site has value for SC% then delete it "RTN","DGENUPL2",148,0) I DGELG("SC")="N",DGELG("SCPER")="" S DGELG("SCPER")="@" "RTN","DGENUPL2",149,0) ; "RTN","DGENUPL2",150,0) S DGELG("P&T")=$$CONVERT^DGENUPL1(SEG(6),"Y/N",.ERROR) "RTN","DGENUPL2",151,0) I ERROR D Q "RTN","DGENUPL2",152,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 6",.ERRCOUNT) "RTN","DGENUPL2",153,0) S DGELG("UNEMPLOY")=$$CONVERT^DGENUPL1(SEG(7),"Y/N",.ERROR) "RTN","DGENUPL2",154,0) I ERROR D Q "RTN","DGENUPL2",155,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 7",.ERRCOUNT) "RTN","DGENUPL2",156,0) S DGELG("SCAWDATE")=$$CONVERT^DGENUPL1(SEG(8),"DATE",.ERROR) "RTN","DGENUPL2",157,0) I ERROR D Q "RTN","DGENUPL2",158,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 8",.ERRCOUNT) "RTN","DGENUPL2",159,0) Q "RTN","DGENUPL2",160,0) ; "RTN","DGENUPL2",161,0) ZMH ;Purple Heart, OEFOIE, POW "RTN","DGENUPL2",162,0) D ZMH^DGENUPL3 ;Moved to DGENUPL3 - DG*5.3*653 "RTN","DGENUPL2",163,0) Q "RTN","DGENUPL2",164,0) ; "RTN","DGENUPL2",165,0) ZRD ; "RTN","DGENUPL2",166,0) N COUNT,DXCODE,NAME,COND "RTN","DGENUPL2",167,0) S DXCODE=$P(SEG(2),$E(HLECH)) "RTN","DGENUPL2",168,0) I DXCODE="""""" S DXCODE="" "RTN","DGENUPL2",169,0) S NAME=$P(SEG(2),$E(HLECH),2) "RTN","DGENUPL2",170,0) Q:DXCODE="" ;segment does not contain a disability condition "RTN","DGENUPL2",171,0) ; "RTN","DGENUPL2",172,0) S COUNT=1+(+$G(DGELG("RATEDIS"))) "RTN","DGENUPL2",173,0) S (COND,DGELG("RATEDIS",COUNT,"RD"))=$$DCLOOKUP(DXCODE,NAME) "RTN","DGENUPL2",174,0) S DGELG("RATEDIS",COUNT,"PER")=SEG(3),DGELG("RATEDIS")=COUNT "RTN","DGENUPL2",175,0) S DGELG("RATEDIS",COUNT,"RDEXT")=SEG(12) "RTN","DGENUPL2",176,0) S DGELG("RATEDIS",COUNT,"RDORIG")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR) "RTN","DGENUPL2",177,0) I ERROR D Q "RTN","DGENUPL2",178,0) . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 13",.ERRCOUNT) "RTN","DGENUPL2",179,0) S DGELG("RATEDIS",COUNT,"RDCURR")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR) "RTN","DGENUPL2",180,0) I ERROR D Q "RTN","DGENUPL2",181,0) . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 14",.ERRCOUNT) "RTN","DGENUPL2",182,0) I 'COND D Q "RTN","DGENUPL2",183,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, SEQ 2 - DISABILTY CONDITION LOOKUP FAILED",.ERRCOUNT) "RTN","DGENUPL2",184,0) .S ERROR=1 "RTN","DGENUPL2",185,0) Q "RTN","DGENUPL2",186,0) OBX ; "RTN","DGENUPL2",187,0) D OBX^DGENUPLA ;code for OBX segment moved to DGENUPLA "RTN","DGENUPL2",188,0) Q "RTN","DGENUPL2",189,0) ; "RTN","DGENUPL2",190,0) ;*********** end of segment parsers **** "RTN","DGENUPL2",191,0) ; "RTN","DGENUPL2",192,0) DCLOOKUP(DGCODE,DGNAME) ; "RTN","DGENUPL2",193,0) ;Description: Returns the ien of a Disability Condition (file #31) based on the DGCODE and DGNAME "RTN","DGENUPL2",194,0) ; "RTN","DGENUPL2",195,0) ;Input: "RTN","DGENUPL2",196,0) ; DGCODE - DX Code of the Disability Condition "RTN","DGENUPL2",197,0) ; DGNAME - name of the Disability Condition "RTN","DGENUPL2",198,0) ;Output: "RTN","DGENUPL2",199,0) ; Function Value: ien of the entry found, or 0 otherwise "RTN","DGENUPL2",200,0) ; "RTN","DGENUPL2",201,0) Q:(DGCODE="") 0 "RTN","DGENUPL2",202,0) N NODE,IEN,FOUND "RTN","DGENUPL2",203,0) S (FOUND,IEN)=0 "RTN","DGENUPL2",204,0) F S IEN=$O(^DIC(31,"C",DGCODE,IEN)) Q:'IEN D Q:FOUND "RTN","DGENUPL2",205,0) .S NODE=$G(^DIC(31,IEN,0)) "RTN","DGENUPL2",206,0) .I DGNAME=$P(NODE,"^"),DGCODE=$P(NODE,"^",3) S FOUND=1 "RTN","DGENUPL2",207,0) I 'FOUND S IEN=$O(^DIC(31,"C",DGCODE,0)) "RTN","DGENUPL2",208,0) Q +IEN "RTN","DGENUPL2",209,0) ; "RTN","DGENUPL2",210,0) REGCHECK(DFN) ; "RTN","DGENUPL2",211,0) ; Description: passes patient through the registration consistency checker "RTN","DGENUPL2",212,0) ;Input - "RTN","DGENUPL2",213,0) ; DFN - is a pointer to the Patient File "RTN","DGENUPL2",214,0) ; "RTN","DGENUPL2",215,0) N DGCD,DGCHK,DGDAY,DGEDCN,DGER,DGLST,DGNCK,DGRPCOLD,DGSC,DGTYPE,DGVT,VA,X "RTN","DGENUPL2",216,0) ; "RTN","DGENUPL2",217,0) S DGEDCN=0 "RTN","DGENUPL2",218,0) D ^DGRPC "RTN","DGENUPL2",219,0) Q "RTN","DGENUPL2",220,0) PEND(DFN,DGSTAT) ; "RTN","DGENUPL2",221,0) N DGARR,DGEC,DGERR,DGX "RTN","DGENUPL2",222,0) I $P($G(^DPT(DFN,.361)),U)'="V" Q 0 "RTN","DGENUPL2",223,0) I $G(DGSTAT)']"" Q 0 "RTN","DGENUPL2",224,0) S DGSTAT="^"_DGSTAT_"^" "RTN","DGENUPL2",225,0) Q:"^15^17^"'[DGSTAT 0 "RTN","DGENUPL2",226,0) D GETS^DIQ(2,DFN_",",".301;.302;.361;.36295","IE","DGARR","DGERR") "RTN","DGENUPL2",227,0) I $D(DGERR) Q 0 "RTN","DGENUPL2",228,0) S DGEC=$G(DGARR(2,DFN_",",.361,"I")) "RTN","DGENUPL2",229,0) I $G(DGEC)']"" Q 0 "RTN","DGENUPL2",230,0) S DGEC=$P($G(^DIC(8,DGEC,0)),U,9) "RTN","DGENUPL2",231,0) I $G(DGEC)']"" Q 0 "RTN","DGENUPL2",232,0) I DGEC=5 Q 1 "RTN","DGENUPL2",233,0) I DGEC=3 D Q DGX "RTN","DGENUPL2",234,0) . S DGX=1 "RTN","DGENUPL2",235,0) . I $G(DGARR(2,DFN_",",.301,"I"))'="Y" S DGX=0 Q "RTN","DGENUPL2",236,0) . I +$G(DGARR(2,DFN_",",.302,"I"))>0 S DGX=0 Q "RTN","DGENUPL2",237,0) . I +$G(DGARR(2,DFN_",",.36295,"I"))>0 S DGX=0 Q "RTN","DGENUPL2",238,0) Q 0 "RTN","DGENUPL3") 0^82^B39755070 "RTN","DGENUPL3",1,0) DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 9/29/06 12:51pm "RTN","DGENUPL3",2,0) ;;5.3;REGISTRATION;**147,230,232,377,404,451,653**;Aug 13,1993;Build 2 "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) ; "RTN","DGENUPL3",143,0) ;ZMH code moved here from DGENUPL2 - DG*5.3*653 "RTN","DGENUPL3",144,0) ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc "RTN","DGENUPL3",145,0) ;ONLY PROCESS PH, OEF/OIF & POW FROM ZMH "RTN","DGENUPL3",146,0) Q:$S(SEG(2)="PH":0,SEG(2)="OEIF":0,SEG(2)="POW":0,1:1) "RTN","DGENUPL3",147,0) I SEG(2)="PH" D Q ;Process Purple Heart from ZMH "RTN","DGENUPL3",148,0) . S DGPAT("PHI")=$P(SEG(3),$E(HLECH)) "RTN","DGENUPL3",149,0) . S DGELG("PH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) "RTN","DGENUPL3",150,0) . S DGPAT("PHST")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2)) "RTN","DGENUPL3",151,0) . S DGPAT("PHRR")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3)) "RTN","DGENUPL3",152,0) ; "RTN","DGENUPL3",153,0) I SEG(2)="OEIF" D Q "RTN","DGENUPL3",154,0) . S DGOEIF("COUNT")=$G(DGOEIF("COUNT"))+1 "RTN","DGENUPL3",155,0) . S DGOEIF("LOC",DGOEIF("COUNT"))=$E($P(SEG(3),$E(HLECH)),1,3) "RTN","DGENUPL3",156,0) . S DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2),"INSTITUTION") "RTN","DGENUPL3",157,0) . S DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE") "RTN","DGENUPL3",158,0) . S DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE") "RTN","DGENUPL3",159,0) . S DGOEIF("LOCK")=1 "RTN","DGENUPL3",160,0) ; "RTN","DGENUPL3",161,0) I SEG(2)="POW" D ;Process POW from ZMH "RTN","DGENUPL3",162,0) . S DGPAT("POWI")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;POW STATUS INDICATED "RTN","DGENUPL3",163,0) . S DGELG("POW")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) "RTN","DGENUPL3",164,0) . S DGPAT("POWLOC")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2)) "RTN","DGENUPL3",165,0) . I DGPAT("POWLOC")'="@" S DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR) ;POW CONFINEMENT LOCATION "RTN","DGENUPL3",166,0) . I ERROR D Q "RTN","DGENUPL3",167,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT) "RTN","DGENUPL3",168,0) . S DGPAT("POWFDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE",.ERROR) ;POW FROM DATE "RTN","DGENUPL3",169,0) . I ERROR D Q "RTN","DGENUPL3",170,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT) "RTN","DGENUPL3",171,0) . S DGPAT("POWTDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;POW TO DATE "RTN","DGENUPL3",172,0) . I ERROR D Q "RTN","DGENUPL3",173,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT) "RTN","DGENUPL3",174,0) Q "RTN","DGENUPL3",175,0) ; "RTN","DGENUPL3",176,0) POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023 "RTN","DGENUPL3",177,0) ; Input: LOC - HL7 code for location "RTN","DGENUPL3",178,0) ; Output: ERROR - Return error 1 on failure "RTN","DGENUPL3",179,0) ; IEN22 - IEN of file 22 "RTN","DGENUPL3",180,0) N TBL023 "RTN","DGENUPL3",181,0) S ERROR=0 "RTN","DGENUPL3",182,0) ;Uncomment following line for EVC R2 "RTN","DGENUPL3",183,0) ;I LOC="" S ERROR=1 Q "" "RTN","DGENUPL3",184,0) I LOC="" Q "" ;Remove this line for EVC R2 "RTN","DGENUPL3",185,0) S TBL023(4)="WWI",TBL023(5)="WWII-EUROPE",TBL023(6)="WWII-PACIFIC" "RTN","DGENUPL3",186,0) S TBL023(7)="KOREAN",TBL023(8)="VIETNAM",TBL023(9)="OTHER" "RTN","DGENUPL3",187,0) S TBL023("A")="PERSIAN GULF",TBL023("B")="YUGOSLAVIA" "RTN","DGENUPL3",188,0) S IEN22=$O(^DIC(22,"C",TBL023(LOC),"")) "RTN","DGENUPL3",189,0) I IEN22="" S ERROR=1 "RTN","DGENUPL3",190,0) Q IEN22 "RTN","DGENUPL3",191,0) ; "RTN","DGENUPL7") 0^40^B29968061 "RTN","DGENUPL7",1,0) DGENUPL7 ;ISA/KWP/CKN/TMK - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 10/19/05 "RTN","DGENUPL7",2,0) ;;5.3;REGISTRATION;**232,367,397,417,379,431,513,628,673,653**;Aug 13,1993;Build 2 "RTN","DGENUPL7",3,0) ;Phase II split from DGENUPL "RTN","DGENUPL7",4,0) Z11(MSGIEN,MSGID,CURLINE,DFN,ERRCOUNT) ; "RTN","DGENUPL7",5,0) ;Description: This is used to process a single ORU~Z11 or ORF~Z11 msg. "RTN","DGENUPL7",6,0) ;Input: "RTN","DGENUPL7",7,0) ; MSGIEN - the internal entry number of the HL7 message in the "RTN","DGENUPL7",8,0) ; HL7 MESSAGE TEXT file (772) "RTN","DGENUPL7",9,0) ; MSGID -message control id of HL7 msg in the MSH segment "RTN","DGENUPL7",10,0) ; CURLINE - the subscript of the MSH segment of the current message (pass by reference) "RTN","DGENUPL7",11,0) ; DFN - identifies the patient, is the ien of a record in the PATIENT file. "RTN","DGENUPL7",12,0) ; ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by reference) "RTN","DGENUPL7",13,0) ; "RTN","DGENUPL7",14,0) ;Output: "RTN","DGENUPL7",15,0) ; CURLINE - upon leaving the procedure this parameter should be set to the end of the current message. (pass by reference) "RTN","DGENUPL7",16,0) ; ERRCOUNT - set to count of messages that were not processed due to errors encountered (pass by reference) "RTN","DGENUPL7",17,0) ; "RTN","DGENUPL7",18,0) N DGELG,DGENR,DGPAT,DGCDIS,DGOEIF,ERROR,ERRMSG,MSGS,DGELGSUB,DGENUPLD,DGCON "RTN","DGENUPL7",19,0) N DGNEWVAL,DIV,SUB,OLDELG,OLDPAT,OLDDCDIS,OLDEIF,DGSEC,OLDSEC,DGNTR,DGMST,DGPHINC "RTN","DGENUPL7",20,0) ; "RTN","DGENUPL7",21,0) ;some process is killing these HL7 variables, so need to protect them "RTN","DGENUPL7",22,0) S SUB=HLFS "RTN","DGENUPL7",23,0) S DIV=HLECH "RTN","DGENUPL7",24,0) N HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLECH,HLFS,HLNDAP,HLNDAP0,HLPID,HLQ,HLVER,HLERR,HLMTN,HLSDT "RTN","DGENUPL7",25,0) S HLFS=SUB "RTN","DGENUPL7",26,0) S HLECH=DIV "RTN","DGENUPL7",27,0) K DIV,SUB "RTN","DGENUPL7",28,0) ; "RTN","DGENUPL7",29,0) ;drops out of block on error "RTN","DGENUPL7",30,0) D "RTN","DGENUPL7",31,0) .Q:'$$PARSE^DGENUPL1(MSGIEN,MSGID,.CURLINE,.ERRCOUNT,.DGPAT,.DGELG,.DGENR,.DGCDIS,.DGOEIF,.DGSEC,.DGNTR,.DGMST) "RTN","DGENUPL7",32,0) .D GETLOCKS^DGENUPL5(DFN) "RTN","DGENUPL7",33,0) .; "RTN","DGENUPL7",34,0) .;Used by cross-references to determine if an upload is in progress. "RTN","DGENUPL7",35,0) .S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" "RTN","DGENUPL7",36,0) .; "RTN","DGENUPL7",37,0) .;Update the PATIENT, ELIGIBILITY, CATASTROPHIC DISABILITY objects in memory "RTN","DGENUPL7",38,0) .Q:'$$UOBJECTS^DGENUPL4(DFN,.DGPAT,.DGELG,.DGCDIS,.DGOEIF,MSGID,.ERRCOUNT,.MSGS,.OLDPAT,.OLDELG,.OLDCDIS,.OLDEIF) "RTN","DGENUPL7",39,0) .S ERROR=0 "RTN","DGENUPL7",40,0) .;if the msg contains patient security, process it "RTN","DGENUPL7",41,0) .I $D(DGSEC) D Q:ERROR "RTN","DGENUPL7",42,0) ..S DGSEC("DFN")=DFN "RTN","DGENUPL7",43,0) ..S DGSEC("USER")=.5 "RTN","DGENUPL7",44,0) ..I DGSEC("LEVEL")'="" D "RTN","DGENUPL7",45,0) ...I DGSEC("DATETIME")="" S DGSEC("DATETIME")=$$NOW^XLFDT ;DG*5.3*653 "RTN","DGENUPL7",46,0) ..; "RTN","DGENUPL7",47,0) ..; check consistency of patient security record "RTN","DGENUPL7",48,0) ..I '$$CHECK^DGENSEC(.DGSEC,.ERRMSG) D Q "RTN","DGENUPL7",49,0) ...S ERROR=1 "RTN","DGENUPL7",50,0) ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",51,0) ..; "RTN","DGENUPL7",52,0) ..; upload patient security, consistency checks passed "RTN","DGENUPL7",53,0) ..D SECUPLD^DGENUPL5(DFN,.DGSEC,.OLDSEC) "RTN","DGENUPL7",54,0) .; "RTN","DGENUPL7",55,0) .;if the msg has an enrollment process it "RTN","DGENUPL7",56,0) .I DGENR("STATUS")!DGENR("APP") D Q:ERROR "RTN","DGENUPL7",57,0) ..;use $$PRIORITY to get the eligibility data used to compute priority "RTN","DGENUPL7",58,0) ..I $$PRIORITY^DGENELA4(DFN,.DGELG,.DGELGSUB,DGENR("DATE"),DGENR("APP")) "RTN","DGENUPL7",59,0) ..; "RTN","DGENUPL7",60,0) ..;store the eligibility data in the enrollment record and other missing fields "RTN","DGENUPL7",61,0) ..M DGENR("ELIG")=DGELGSUB "RTN","DGENUPL7",62,0) ..S DGENR("DFN")=DFN "RTN","DGENUPL7",63,0) ..S DGENR("PRIORREC")="" "RTN","DGENUPL7",64,0) ..S DGENR("USER")=.5 "RTN","DGENUPL7",65,0) ..S DGENR("DATETIME")=$$NOW^XLFDT "RTN","DGENUPL7",66,0) ..; "RTN","DGENUPL7",67,0) ..;Allow null overwrites of Ineligible data (Ineligible Project): "RTN","DGENUPL7",68,0) ..I $D(DGENR("DATE")),DGENR("DATE")="" S DGENR("DATE")="@" "RTN","DGENUPL7",69,0) ..I $D(DGENR("FACREC")),DGENR("FACREC")="" S DGENR("FACREC")="@" "RTN","DGENUPL7",70,0) ..; "RTN","DGENUPL7",71,0) ..;check the consistency of the enrollment record "RTN","DGENUPL7",72,0) ..I '$$CHECK^DGENA3(.DGENR,.DGPAT,.ERRMSG) D Q "RTN","DGENUPL7",73,0) ...S ERROR=1 "RTN","DGENUPL7",74,0) ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",75,0) ..; "RTN","DGENUPL7",76,0) ..; removed EGT consistency check with DG*5.3*628 "RTN","DGENUPL7",77,0) ..;Phase II EGT consistency checks (SRS 6.5.1.3) "RTN","DGENUPL7",78,0) ..;Only do the EGT consistency checks for Rejected-Fiscal Year (11),Rejected-Mid Cycle (12),Rejected-Stop enrolling new apps (13),Rejected-Initil App by VAMC (14),Rejected below EGT threshold (22) "RTN","DGENUPL7",79,0) ..;I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$ABOVE^DGENEGT1(DGENR("DFN"),DGENR("PRIORITY"),DGENR("SUBGRP"),"","",1) D Q "RTN","DGENUPL7",80,0) ..;.S ERROR=1 "RTN","DGENUPL7",81,0) ..;.S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE EGT CONSISTENCY CHECKS." "RTN","DGENUPL7",82,0) ..;.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",83,0) ..; "RTN","DGENUPL7",84,0) ..;Allow null overwrites for Ineligible vets (Ineligible Project): "RTN","DGENUPL7",85,0) ..I $G(DGPAT("INELDATE"))'="" S (DGENR("PRIORITY"),DGENR("SUBGRP"))="" "RTN","DGENUPL7",86,0) ..I DGENR("DATE")="@" S DGENR("DATE")="" "RTN","DGENUPL7",87,0) ..I DGENR("FACREC")="@" S DGENR("FACREC")="" "RTN","DGENUPL7",88,0) ..; "RTN","DGENUPL7",89,0) ..D ENRUPLD^DGENUPL8(.DGENR,.DGPAT) "RTN","DGENUPL7",90,0) .; "RTN","DGENUPL7",91,0) .;Store the PATIENT, ELIGIBILITY, & CAT. DISB. objects "RTN","DGENUPL7",92,0) .I $$STORE^DGENPTA1(.DGPAT,,1) "RTN","DGENUPL7",93,0) .I $$STORE^DGENELA1(.DGELG,.DGPAT,.DGCDIS,,1) "RTN","DGENUPL7",94,0) .I $G(DGCDIS("VCD"))'="",$$STORE^DGENCDA2(DFN,.DGCDIS) ;checks first if there is catastrophic disability information "RTN","DGENUPL7",95,0) .; "RTN","DGENUPL7",96,0) .;Call PIMS api to file NTR data. "RTN","DGENUPL7",97,0) .I $D(DGNTR),$$ENRUPD^DGNTAPI1(DFN,.DGNTR) "RTN","DGENUPL7",98,0) .; "RTN","DGENUPL7",99,0) .;Call PIMS api to file MST data. "RTN","DGENUPL7",100,0) .I DGMST("MSTSTAT")'="",DGMST("MSTDT")'="",DGMST("MSTST")'="" D "RTN","DGENUPL7",101,0) ..I $$NEWSTAT^DGMSTAPI(DFN,DGMST("MSTSTAT"),DGMST("MSTDT"),".5",DGMST("MSTST"),0) "RTN","DGENUPL7",102,0) .; "RTN","DGENUPL7",103,0) .;Call PIMS api to file OEF/OIF data. "RTN","DGENUPL7",104,0) .I $D(DGOEIF) D OEIFUPD^DGCLAPI1(DFN,.DGOEIF) "RTN","DGENUPL7",105,0) .; "RTN","DGENUPL7",106,0) .;if the current enrollment is a local then log patient for transmission "RTN","DGENUPL7",107,0) .I $$SOURCE^DGENA(DFN)=1!$G(DGPHINC) K DGENUPLD,DGPHINC D EVENT^IVMPLOG(DFN) "RTN","DGENUPL7",108,0) .; "RTN","DGENUPL7",109,0) .;create the audit trail "RTN","DGENUPL7",110,0) .I $$AUDIT^DGENUPA1(,MSGID,.OLDPAT,.DGPAT,.OLDELG,.DGELG,.OLDCDIS,.DGCDIS,.DGSEC,.OLDSEC) "RTN","DGENUPL7",111,0) .;send notifications "RTN","DGENUPL7",112,0) .D NOTIFY^DGENUPL3(.DGPAT,.MSGS) "RTN","DGENUPL7",113,0) .; "RTN","DGENUPL7",114,0) .;invoke registration consistency checker "RTN","DGENUPL7",115,0) .D REGCHECK^DGENUPL2(DFN) "RTN","DGENUPL7",116,0) ; "RTN","DGENUPL7",117,0) D UNLOCK^DGENUPL5(DFN) "RTN","DGENUPL7",118,0) Q "RTN","DGENUPLA") 0^27^B55510983 "RTN","DGENUPLA",1,0) DGENUPLA ;ALB/CKN,TDM,PJR,RGL,EG,TMK,CKN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 9/19/06 10:45am "RTN","DGENUPLA",2,0) ;;5.3;REGISTRATION;**397,379,497,451,564,672,659,583,653**;Aug 13,1993;Build 2 "RTN","DGENUPLA",3,0) ; "RTN","DGENUPLA",4,0) ;*************************************************************** "RTN","DGENUPLA",5,0) ; This routine was created because DGENUPL2 had reached it's "RTN","DGENUPLA",6,0) ; maximum size, therefore no new code could not be added. All "RTN","DGENUPLA",7,0) ; code that existed in the ZEL and OBX tags of DGENUPL2 has "RTN","DGENUPLA",8,0) ; been moved to the ZEL and OBX tags of DGENUPLA. A line of code "RTN","DGENUPLA",9,0) ; was placed in ZEL^DGENUPL2 to call ZEL^DGENUPLA. A line of "RTN","DGENUPLA",10,0) ; code was placed in OBX^DGENUPL2 to call OBX^DGENUPLA. "RTN","DGENUPLA",11,0) ; Any routine that calls ZEL^DGENUPL2 or OBX^DGENUPL2 will not "RTN","DGENUPLA",12,0) ; be affected by this change. "RTN","DGENUPLA",13,0) ;*************************************************************** "RTN","DGENUPLA",14,0) ; "RTN","DGENUPLA",15,0) ;*************************************************************** "RTN","DGENUPLA",16,0) ;The following procedures parse particular segment types. "RTN","DGENUPLA",17,0) ;Input:SEG(),MSGID "RTN","DGENUPLA",18,0) ;Output:DGPAT(),DGELG(),DGENR(),DGNTR(),DGMST(),ERROR "RTN","DGENUPLA",19,0) ;*************************************************************** "RTN","DGENUPLA",20,0) ; "RTN","DGENUPLA",21,0) ; "RTN","DGENUPLA",22,0) ZEL(COUNT) ; "RTN","DGENUPLA",23,0) N CODE "RTN","DGENUPLA",24,0) S CODE=$$CONVERT^DGENUPL1(SEG(2),"ELIGIBILITY",.ERROR) "RTN","DGENUPLA",25,0) I ERROR D Q "RTN","DGENUPLA",26,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ELIGIBILITY CODE "_SEG(2)_" NOT FOUND IN ELIGIBILTIY CODE FILE",.ERRCOUNT) "RTN","DGENUPLA",27,0) I COUNT=1 D "RTN","DGENUPLA",28,0) .S DGELG("ELIG","CODE")=CODE "RTN","DGENUPLA",29,0) .;S DGELG("DISRET")=$$CONVERT^DGENUPL1(SEG(5)) "RTN","DGENUPLA",30,0) .S DGELG("DISRET")=$$DISCONV(SEG(5)) ;DG*5.3*672 "RTN","DGENUPLA",31,0) .I ERROR D Q "RTN","DGENUPLA",32,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 5",.ERRCOUNT) "RTN","DGENUPLA",33,0) .S DGELG("CLAIMNUM")=$$CONVERT^DGENUPL1(SEG(6)) "RTN","DGENUPLA",34,0) .S DGELG("CLAIMLOC")=$$SITECNV(SEG(7)) "RTN","DGENUPLA",35,0) .; "RTN","DGENUPLA",36,0) .S DGPAT("VETERAN")=$$CONVERT^DGENUPL1(SEG(8),"Y/N",.ERROR) "RTN","DGENUPLA",37,0) .I ERROR D Q "RTN","DGENUPLA",38,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 8",.ERRCOUNT) "RTN","DGENUPLA",39,0) .S DGELG("ELIGSTA")=$$CONVERT^DGENUPL1(SEG(10)) "RTN","DGENUPLA",40,0) .S DGELG("ELIGSTADATE")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR) "RTN","DGENUPLA",41,0) .I ERROR D Q "RTN","DGENUPLA",42,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 11",.ERRCOUNT) "RTN","DGENUPLA",43,0) .S DGELG("ELIGVERIF")=$$CONVERT^DGENUPL1(SEG(13)) "RTN","DGENUPLA",44,0) .S DGELG("A&A")=$$CONVERT^DGENUPL1(SEG(14),"Y/N",.ERROR) "RTN","DGENUPLA",45,0) .I ERROR D Q "RTN","DGENUPLA",46,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 14",.ERRCOUNT) "RTN","DGENUPLA",47,0) .S DGELG("HB")=$$CONVERT^DGENUPL1(SEG(15),"Y/N",.ERROR) "RTN","DGENUPLA",48,0) .I ERROR D Q "RTN","DGENUPLA",49,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 15",.ERRCOUNT) "RTN","DGENUPLA",50,0) .S DGELG("VAPEN")=$$CONVERT^DGENUPL1(SEG(16),"Y/N",.ERROR) "RTN","DGENUPLA",51,0) .I ERROR D Q "RTN","DGENUPLA",52,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 16",.ERRCOUNT) "RTN","DGENUPLA",53,0) .S DGELG("VADISAB")=$$CONVERT^DGENUPL1(SEG(17),"Y/N",.ERROR) "RTN","DGENUPLA",54,0) .I ERROR D Q "RTN","DGENUPLA",55,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 17",.ERRCOUNT) "RTN","DGENUPLA",56,0) .S DGELG("AO")=$$CONVERT^DGENUPL1(SEG(18),"Y/N",.ERROR) "RTN","DGENUPLA",57,0) .N AOERR S AOERR=ERROR ; See SEG(29) below. "RTN","DGENUPLA",58,0) .I ERROR D Q "RTN","DGENUPLA",59,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 18",.ERRCOUNT) "RTN","DGENUPLA",60,0) .S (DGPAT("IR"),DGELG("IR"))=$$CONVERT^DGENUPL1(SEG(19),"Y/N",.ERROR) "RTN","DGENUPLA",61,0) .I ERROR D Q "RTN","DGENUPLA",62,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 19",.ERRCOUNT) "RTN","DGENUPLA",63,0) .S DGELG("EC")=$$CONVERT^DGENUPL1(SEG(20),"Y/N",.ERROR) "RTN","DGENUPLA",64,0) .I ERROR D Q "RTN","DGENUPLA",65,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 20",.ERRCOUNT) "RTN","DGENUPLA",66,0) .S (DGPAT("RADEXPM"),DGELG("RADEXPM"))=$G(SEG(22)) "RTN","DGENUPLA",67,0) .S ERROR=$S(DGELG("RADEXPM")="":0,",2,3,4,5,6,7,"[(","_DGELG("RADEXPM")_","):0,1:1) "RTN","DGENUPLA",68,0) .I ERROR D Q "RTN","DGENUPLA",69,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 22",.ERRCOUNT) "RTN","DGENUPLA",70,0) .; "RTN","DGENUPLA",71,0) .S DGELG("VACKAMT")=$$CONVERT^DGENUPL1(SEG(21)) "RTN","DGENUPLA",72,0) .; "RTN","DGENUPLA",73,0) .;Parse MST data into DGMST array from sequences 23, 24, 25 of ZEL segment "RTN","DGENUPLA",74,0) . S DGMST("MSTSTAT")=SEG(23) "RTN","DGENUPLA",75,0) . S DGMST("MSTDT")=$$CONVERT^DGENUPL1(SEG(24),"TS",.ERROR) "RTN","DGENUPLA",76,0) . I ERROR D Q "RTN","DGENUPLA",77,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 24",.ERRCOUNT) "RTN","DGENUPLA",78,0) . S DGMST("MSTST")=$$CONVERT^DGENUPL1(SEG(25),"INSTITUTION",.ERROR) "RTN","DGENUPLA",79,0) . I ERROR D Q "RTN","DGENUPLA",80,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 25",.ERRCOUNT) "RTN","DGENUPLA",81,0) .; "RTN","DGENUPLA",82,0) . S DGELG("AOEXPLOC")=SEG(29) "RTN","DGENUPLA",83,0) .; Logic enhanced during SQA of patch 451. AOERR from SEG(18) above. "RTN","DGENUPLA",84,0) . I 'AOERR,DGELG("AO")'="Y",DGELG("AOEXPLOC")="" S DGELG("AOEXPLOC")="@" "RTN","DGENUPLA",85,0) . S DGELG("UEYEAR")=$$CONVERT^DGENUPL1(SEG(34),"DATE",.ERROR) "RTN","DGENUPLA",86,0) . I ERROR D Q "RTN","DGENUPLA",87,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 34",.ERRCOUNT) "RTN","DGENUPLA",88,0) . S DGELG("UESITE")=$$CONVERT^DGENUPL1(SEG(35),"INSTITUTION",.ERROR) "RTN","DGENUPLA",89,0) . I ERROR D Q "RTN","DGENUPLA",90,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 35",.ERRCOUNT) "RTN","DGENUPLA",91,0) . S DGELG("CVELEDT")=$$CONVERT^DGENUPL1(SEG(38),"DATE",.ERROR) "RTN","DGENUPLA",92,0) . I ERROR D Q "RTN","DGENUPLA",93,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 38",.ERRCOUNT) "RTN","DGENUPLA",94,0) . I $G(DGELG("DISLOD"))="" S DGELG("DISLOD")=$$CONVERT^DGENUPL1(SEG(39),"1/0",.ERROR) ;Discharge due to Disability - DG*5.3*672 "RTN","DGENUPLA",95,0) . I ERROR D Q "RTN","DGENUPLA",96,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 39",.ERRCOUNT) "RTN","DGENUPLA",97,0) . S DGELG("SHAD")=$$CONVERT^DGENUPL1(SEG(40),"1/0",.ERROR) ;Proj 112/SHAD - DG*5.3*653 "RTN","DGENUPLA",98,0) . I ERROR D Q "RTN","DGENUPLA",99,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 40 - SHAD Indicator",.ERRCOUNT) "RTN","DGENUPLA",100,0) ; "RTN","DGENUPLA",101,0) I COUNT>1 D "RTN","DGENUPLA",102,0) .S DGELG("ELIG","CODE",CODE)="" "RTN","DGENUPLA",103,0) Q "RTN","DGENUPLA",104,0) ; "RTN","DGENUPLA",105,0) OBX N OBXPCE,OBXVAL,OBXTBL,I,CS,SS,RS "RTN","DGENUPLA",106,0) I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&" "RTN","DGENUPLA",107,0) I $G(HLFS)="" N HLFS S HLFS="^" "RTN","DGENUPLA",108,0) S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2) "RTN","DGENUPLA",109,0) I $G(SEG(3))=("38.1"_$E(HLECH)_"SECURITY LOG") D "RTN","DGENUPLA",110,0) . N LEVEL "RTN","DGENUPLA",111,0) . S LEVEL=$P(SEG(5),$E(HLECH)) "RTN","DGENUPLA",112,0) . S DGSEC("LEVEL")=$$CONVERT^DGENUPL1(LEVEL,"1/0",.ERROR) "RTN","DGENUPLA",113,0) . I ERROR D Q "RTN","DGENUPLA",114,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, OBX SEGMENT, SEQ 5",.ERRCOUNT) "RTN","DGENUPLA",115,0) . S DGSEC("DATETIME")=$$CONVERT^DGENUPL1(SEG(14),"TS",.ERROR) "RTN","DGENUPLA",116,0) . I ERROR D Q "RTN","DGENUPLA",117,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, OBX SEGMENT, SEQ 14, Patient Sensitivity Date/Time",.ERRCOUNT) ;DG*5.3*653 "RTN","DGENUPLA",118,0) . S DGSEC("SOURCE")=$$CONVERT^DGENUPL1(SEG(16)) "RTN","DGENUPLA",119,0) ; "RTN","DGENUPLA",120,0) I $G(SEG(3))=("VISTA"_CS_"28.11") D "RTN","DGENUPLA",121,0) . S OBXTBL(1)="NTR^Y",OBXTBL(2)="AVI^Y",OBXTBL(3)="SUB^Y" "RTN","DGENUPLA",122,0) . S OBXTBL(4)="HNC^Y",OBXTBL(5)="NTR^N",OBXTBL(6)="AVI^N" "RTN","DGENUPLA",123,0) . S OBXTBL(7)="SUB^N",OBXTBL(8)="HNC^N",OBXTBL(9)="NTR^U" "RTN","DGENUPLA",124,0) . F I=1:1:$L($G(SEG(5)),RS) D "RTN","DGENUPLA",125,0) . . S OBXPCE=$P($G(SEG(5)),RS,I),OBXVAL=$P($G(OBXPCE),CS) "RTN","DGENUPLA",126,0) . . S DGNTR($P($G(OBXTBL(OBXVAL)),"^"))=$P($G(OBXTBL(OBXVAL)),"^",2) "RTN","DGENUPLA",127,0) . I $G(SEG(12))'="" S DGNTR("HDT")=$$CONVERT^DGENUPL1(SEG(12),"TS",.ERROR) "RTN","DGENUPLA",128,0) . S DGNTR("VDT")=$$CONVERT^DGENUPL1(SEG(14),"TS",.ERROR) "RTN","DGENUPLA",129,0) . S DGNTR("VSIT")=$$CONVERT^DGENUPL1(SEG(15),"INSTITUTION",.ERROR) "RTN","DGENUPLA",130,0) . S DGNTR("HSIT")=$P($P($G(SEG(16)),CS,14),SS,2) "RTN","DGENUPLA",131,0) . I DGNTR("HSIT")'="" S DGNTR("HSIT")=$$CONVERT^DGENUPL1($G(DGNTR("HSIT")),"INSTITUTION",.ERROR) "RTN","DGENUPLA",132,0) . S DGNTR("VER")=$P($G(SEG(17)),CS) "RTN","DGENUPLA",133,0) Q "RTN","DGENUPLA",134,0) ; "RTN","DGENUPLA",135,0) ZIO ;New segment - DG*5.3*653 "RTN","DGENUPLA",136,0) S DGPAT("APPREQ")=$$CONVERT^DGENUPL1(SEG(5),"1/0",.ERROR) "RTN","DGENUPLA",137,0) I ERROR D Q "RTN","DGENUPLA",138,0) . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIO SEGMENT, SEQ 5, APPOINTMENT REQUEST ON 1010EZ",.ERRCOUNT) "RTN","DGENUPLA",139,0) S DGPAT("APPREQDT")=$$CONVERT^DGENUPL1(SEG(6),"DATE",.ERROR) "RTN","DGENUPLA",140,0) I ERROR D Q "RTN","DGENUPLA",141,0) . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIO SEGMENT, SEQ 6, APPOINTMENT REQUEST DATE",.ERRCOUNT) "RTN","DGENUPLA",142,0) Q "RTN","DGENUPLA",143,0) ; "RTN","DGENUPLA",144,0) DISCONV(VAL,ERROR) ; "RTN","DGENUPLA",145,0) ;DG*5.3*672 - Military Disability conversion to new values "RTN","DGENUPLA",146,0) N DISRET "RTN","DGENUPLA",147,0) S ERROR=0 "RTN","DGENUPLA",148,0) I VAL="" Q VAL "RTN","DGENUPLA",149,0) I VAL="""""" S VAL="@" Q VAL "RTN","DGENUPLA",150,0) I ((VAL="Y")!(VAL="N")) D Q DISRET "RTN","DGENUPLA",151,0) . S DISRET=$$CONVERT^DGENUPL1(VAL,"1/0",.ERROR) "RTN","DGENUPLA",152,0) S (DISRET,DGELG("DISLOD"))=$S(VAL=0:0,VAL=1:1,VAL=2:1,VAL=3:0,1:"") "RTN","DGENUPLA",153,0) I DISRET="" S ERROR=1 Q VAL "RTN","DGENUPLA",154,0) Q DISRET "RTN","DGENUPLA",155,0) ; "RTN","DGENUPLA",156,0) SITECNV(STRING) ; Convert claim folder loc (site # or site # and name) to "RTN","DGENUPLA",157,0) ; ptr to file 4 "RTN","DGENUPLA",158,0) N SITE "RTN","DGENUPLA",159,0) S SITE="" "RTN","DGENUPLA",160,0) I STRING'="" D "RTN","DGENUPLA",161,0) . N SUB,START,END "RTN","DGENUPLA",162,0) . ; Find site ien if only site # is returned "RTN","DGENUPLA",163,0) . I $O(^DIC(4,"D",STRING,0)) S SITE=$O(^DIC(4,"D",STRING,0)) Q "RTN","DGENUPLA",164,0) . ; Check if name is concatenated onto site # to find site ien "RTN","DGENUPLA",165,0) . S SUB="" "RTN","DGENUPLA",166,0) . F S SUB=$O(^DIC(4,"D",SUB)) Q:SUB="" I $E(SUB,1,3)=$E(STRING,1,3),$$CHK(SUB,STRING) S SITE=$O(^DIC(4,"D",SUB,0)) Q "RTN","DGENUPLA",167,0) ; SITE is the pointer to file 4 or null for site not found "RTN","DGENUPLA",168,0) Q SITE "RTN","DGENUPLA",169,0) ; "RTN","DGENUPLA",170,0) CHK(SUB,STRING) ; "RTN","DGENUPLA",171,0) N IEN,X,STN,RET "RTN","DGENUPLA",172,0) I SUB=STRING Q 1 "RTN","DGENUPLA",173,0) S RET=0 "RTN","DGENUPLA",174,0) S IEN=+$O(^DIC(4,"D",SUB,"")) "RTN","DGENUPLA",175,0) I IEN D "RTN","DGENUPLA",176,0) . S X=$P($G(^DIC(4,IEN,0)),U),STN=$P($G(^(99)),U) "RTN","DGENUPLA",177,0) . ; assume institution file names will be the same on HEC and VistA "RTN","DGENUPLA",178,0) . I STN=SUB,X'="",$E($P(STRING,SUB,2,999),1,40)=X S RET=1 "RTN","DGENUPLA",179,0) Q RET "RTN","DGENUPLA",180,0) ; "RTN","DGMTDD1") 0^64^B10762436 "RTN","DGMTDD1",1,0) DGMTDD1 ;ALB/MIR,JAN,AEG,ERC,BAJ - DD calls from income screening files ; May 18, 2006 "RTN","DGMTDD1",2,0) ;;5.3;Registration;**180,313,345,401,653**;Aug 13, 1993;Build 2 "RTN","DGMTDD1",3,0) ; "RTN","DGMTDD1",4,0) ; This routine contains miscellaneous input transform and other DD "RTN","DGMTDD1",5,0) ; calls from income screening files. "RTN","DGMTDD1",6,0) ; "RTN","DGMTDD1",7,0) ; "RTN","DGMTDD1",8,0) SSN ; called from the input transform of the SSN field in file 408.13 "RTN","DGMTDD1",9,0) N %,L,DGN,DGPAT,PATNAME,PREVX,KANS "RTN","DGMTDD1",10,0) ;with DG*5.3*653 Pseudo SSNs will be allowed for spouse/dependents "RTN","DGMTDD1",11,0) I X'?9N&(X'?3N1"-"2N1"-"4N)&(X'?9N1"P")&(X'?3N1"-"2N1"-"4N1"P"),(X'?1"P")&(X'?1"p") W !,"Response must be either nine numbers, be in the format nnn-nn-nnnn",!,"or include a ""P"" for a Pseudo SSN." K X Q "RTN","DGMTDD1",12,0) I X="P"!(X="p") D PSEU S X=L K L G SSNQ "RTN","DGMTDD1",13,0) I X["P" D PSEU I X'=L K X,L W !!,$C(7),"Invalid Pseudo SSN, type ""P"" for valid one." Q "RTN","DGMTDD1",14,0) I X["P" G SSNQ "RTN","DGMTDD1",15,0) I X'?.AN F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,999),%=%-1 "RTN","DGMTDD1",16,0) I X'?9N K X Q "RTN","DGMTDD1",17,0) I $D(X) S L=$E(X,1) I L=9 W !,*7,"The SSN must not begin with 9." K X Q "RTN","DGMTDD1",18,0) I $D(X),$E(X,1,3)="000" W !,*7,"First three digits cannot be zeros." K X Q "RTN","DGMTDD1",19,0) ; "RTN","DGMTDD1",20,0) ; warning if the spouse's/dependent's SSN is found in the PATIENT file "RTN","DGMTDD1",21,0) ; and spouse/dependent is not a veteran. spouse/dependent is a veteran "RTN","DGMTDD1",22,0) ; if name, sex, DOB match. "RTN","DGMTDD1",23,0) ; "RTN","DGMTDD1",24,0) ; input (OPTIONAL) "RTN","DGMTDD1",25,0) ; ANS(.01) = NAME, ANS(.02) = SEX, ANS(.03) = DOB "RTN","DGMTDD1",26,0) ; "RTN","DGMTDD1",27,0) ; if newly entered values (those not yet committed to dbase) not "RTN","DGMTDD1",28,0) ; supplied then pull current detail from the Person Income file "RTN","DGMTDD1",29,0) ; (#408.13) for this dependent. "RTN","DGMTDD1",30,0) I '$G(ANS(.01)),'$G(ANS(.02)),'$G(ANS(.03)) D "RTN","DGMTDD1",31,0) . N REC,FLD "RTN","DGMTDD1",32,0) . D GETS^DIQ(408.13,DA,".01;.02;.03","I","REC") "RTN","DGMTDD1",33,0) . F FLD=".01",".02",".03" S ANS(FLD)=REC(408.13,DA_",",FLD,"I") "RTN","DGMTDD1",34,0) . S KANS=1 "RTN","DGMTDD1",35,0) E S KANS=0 "RTN","DGMTDD1",36,0) ; "RTN","DGMTDD1",37,0) S DGN=$O(^DPT("SSN",X,0)) G:'DGN SSDEP S DGPAT=$G(^DPT(DGN,0)) "RTN","DGMTDD1",38,0) I $P(DGPAT,"^",3)=ANS(.03),($P(DGPAT,"^",2)=ANS(.02)),($P(DGPAT,"^")=ANS(.01)) G SSDEP "RTN","DGMTDD1",39,0) S PATNAME=$P(DGPAT,"^") D WARN Q "RTN","DGMTDD1",40,0) ; "RTN","DGMTDD1",41,0) SSDEP ; warning if spouse's/dependent's SSN is found in file 408.13 and "RTN","DGMTDD1",42,0) ; name, sex, DOB don't match "RTN","DGMTDD1",43,0) S DGN=$O(^DGPR(408.13,"SSN",X,0)) G:'DGN SSNQ S DGPAT=$G(^DGPR(408.13,DGN,0)) "RTN","DGMTDD1",44,0) I $P(DGPAT,"^",3)=ANS(.03),($P(DGPAT,"^",2)=ANS(.02)),($P(DGPAT,"^")=ANS(.01)) G SSNQ "RTN","DGMTDD1",45,0) S PATNAME=$P($G(^DGPR(408.13,DGN,0)),"^") D WARN Q "RTN","DGMTDD1",46,0) ; "RTN","DGMTDD1",47,0) SSNQ K:KANS ANS Q "RTN","DGMTDD1",48,0) ; "RTN","DGMTDD1",49,0) ; "RTN","DGMTDD1",50,0) PSEU ;create a Pseudo SSN using same algorithm as file 2 in PSEU^DGRPDD1 "RTN","DGMTDD1",51,0) S KANS="" "RTN","DGMTDD1",52,0) I $G(ANS(.01))']""!($G(ANS(.03))'?7N) D "RTN","DGMTDD1",53,0) . S DGNODE0=^DGPR(408.13,DA,0) "RTN","DGMTDD1",54,0) . S ANS(.01)=$P(DGNODE0,U),ANS(.03)=$P(DGNODE0,U,3) "RTN","DGMTDD1",55,0) I $D(ANS(.01)) S NAM=ANS(.01) "RTN","DGMTDD1",56,0) I $D(ANS(.03)) S DOB=ANS(.03) "RTN","DGMTDD1",57,0) I $G(DOB)="" S DOB=2000000 "RTN","DGMTDD1",58,0) S L1=$E($P(NAM," ",2)),L3=$E(NAM),NAM=$P(NAM,",",2),L2=$E(NAM) "RTN","DGMTDD1",59,0) S Z=L1 D CON S L1=Z "RTN","DGMTDD1",60,0) S Z=L2 D CON S L2=Z "RTN","DGMTDD1",61,0) S Z=L3 D CON S L3=Z "RTN","DGMTDD1",62,0) S L=L2_L1_L3_$E(DOB,4,7)_$E(DOB,2,3)_"P" "RTN","DGMTDD1",63,0) Q "RTN","DGMTDD1",64,0) CON ; "RTN","DGMTDD1",65,0) S Z=$A(Z)-65\3+1 S:Z<0 Z=0 "RTN","DGMTDD1",66,0) Q "RTN","DGMTDD1",67,0) ; "RTN","DGMTDD1",68,0) WARN ; printed WARNING message to alert user that spouse/dependent SSN be "RTN","DGMTDD1",69,0) ; that of a veteran in Patient/Income Person File. "RTN","DGMTDD1",70,0) W !,*7,"Warning - ",X," belongs to patient ",PATNAME "RTN","DGMTDD1",71,0) K DIR S PREVX=X,DIR(0)="YA",DIR("A")="Are you sure this is the correct SSN? ",DIR("B")="YES" D ^DIR "RTN","DGMTDD1",72,0) I Y=1 S X=PREVX K PREVX,DIR("B") Q "RTN","DGMTDD1",73,0) E K DIR("B"),X Q "RTN","DGMTDD1",74,0) ; "RTN","DGMTDD1",75,0) REL ; called from the input transform of the RELATIONSHIP field of file 408.12...sets DIC("S") "RTN","DGMTDD1",76,0) N DGNODE,DGX,SEX "RTN","DGMTDD1",77,0) S DGNODE=$G(^DGPR(408.12,DA,0)),DGX=$P(DGNODE,"^",2) Q:'DGNODE "RTN","DGMTDD1",78,0) I DGX,(DGX<3) S DIC("S")="I Y="_DGX Q "RTN","DGMTDD1",79,0) S DGX=$P(DGNODE,"^",3),SEX=$P($G(@("^"_$P(DGX,";",2)_+DGX_",0)")),"^",2) "RTN","DGMTDD1",80,0) S DIC("S")="I Y>2,(""E"_SEX_"""[$P(^(0),""^"",3))" "RTN","DGMTDD1",81,0) I $D(DGTYPE),DGTYPE="C" S DIC("S")=DIC("S")_",(Y<7)" "RTN","DGMTDD1",82,0) Q "RTN","DGMTU1") 0^60^B4468630 "RTN","DGMTU1",1,0) DGMTU1 ;ALB/RMO/MIR/CKN - Patient Relation Utilities ; 11/8/05 2:21pm "RTN","DGMTU1",2,0) ;;5.3;Registration;**166,653**;Aug 13, 1993;Build 2 "RTN","DGMTU1",3,0) ; "RTN","DGMTU1",4,0) ; "RTN","DGMTU1",5,0) ;======================================================================= "RTN","DGMTU1",6,0) ; The first set of utilities will display data from the PATIENT "RTN","DGMTU1",7,0) ; RELATION file "RTN","DGMTU1",8,0) ;======================================================================= "RTN","DGMTU1",9,0) ; "RTN","DGMTU1",10,0) ; "RTN","DGMTU1",11,0) DEM(DGPRI) ;Demographics of Patient Relation "RTN","DGMTU1",12,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",13,0) ; Output -- Patient or Income Person 0th node "RTN","DGMTU1",14,0) N DGVPI,DGVP0 "RTN","DGMTU1",15,0) S DGVPI=$P($G(^DGPR(408.12,DGPRI,0)),"^",3) "RTN","DGMTU1",16,0) I DGVPI]"" S DGVP0=$G(@("^"_$P(DGVPI,";",2)_+DGVPI_",0)")) "RTN","DGMTU1",17,0) Q $S($G(DGVP0)]"":DGVP0,1:"") "RTN","DGMTU1",18,0) ; "RTN","DGMTU1",19,0) DEM1(DGPRI) ;Demographics of Patient Relation node 1 "RTN","DGMTU1",20,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",21,0) ; Output -- Patient or Income Person node 1 "RTN","DGMTU1",22,0) N DGVPI,DGVP1 "RTN","DGMTU1",23,0) S DGVPI=$P($G(^DGPR(408.12,DGPRI,0)),"^",3) "RTN","DGMTU1",24,0) I DGVPI]"" S DGVP1=$G(@("^"_$P(DGVPI,";",2)_+DGVPI_",1)")) "RTN","DGMTU1",25,0) Q $S($G(DGVP1)]"":DGVP1,1:"") "RTN","DGMTU1",26,0) ; "RTN","DGMTU1",27,0) NODE(DGPRI) ;Send back the name, sex, dob, and SSN in external format "RTN","DGMTU1",28,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",29,0) ; Output -- External format of name, sex, dob, and SSN "RTN","DGMTU1",30,0) ; in pieces 1,2,3, and 9 respectively "RTN","DGMTU1",31,0) ; "RTN","DGMTU1",32,0) ; NOTE: date is in mm/dd/yyyy format "RTN","DGMTU1",33,0) ; "RTN","DGMTU1",34,0) N NODE,X,Y "RTN","DGMTU1",35,0) S NODE=$$DEM(DGPRI) "RTN","DGMTU1",36,0) S X=$P(NODE,"^",2) I X]"" S $P(NODE,"^",2)=$S(X="M":"MALE",X="F":"FEMALE",1:"") ; sex "RTN","DGMTU1",37,0) S X=$P(NODE,"^",3) I X]"" S X=$$FMTE^XLFDT(X,"5DF") S $P(NODE,"^",3)=$TR(X," ","0") "RTN","DGMTU1",38,0) S X=$P(NODE,"^",9) I X]"" S $P(NODE,"^",9)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10) "RTN","DGMTU1",39,0) S $P(NODE,"^",4,8)="^^^^",$P(NODE,"^",10,99)="" "RTN","DGMTU1",40,0) Q NODE "RTN","DGMTU1",41,0) ; "RTN","DGMTU1",42,0) NAME(DGPRI) ;Name of Patient Relation "RTN","DGMTU1",43,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",44,0) ; Output -- Patient or Income Person Name "RTN","DGMTU1",45,0) N DGNM "RTN","DGMTU1",46,0) S DGNM=$P($$DEM(DGPRI),"^") "RTN","DGMTU1",47,0) Q $G(DGNM) "RTN","DGMTU1",48,0) ; "RTN","DGMTU1",49,0) SEX(DGPRI) ;Sex of Patient Relation "RTN","DGMTU1",50,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",51,0) ; Output -- Patient or Income Person Sex "RTN","DGMTU1",52,0) N DGSEX,Y "RTN","DGMTU1",53,0) S Y=$P($$DEM(DGPRI),"^",2) S DGSEX=$S(Y="M":"MALE",Y="F":"FEMALE",1:"") "RTN","DGMTU1",54,0) Q $G(DGSEX) "RTN","DGMTU1",55,0) ; "RTN","DGMTU1",56,0) DOB(DGPRI) ;Date of Birth of Patient Relation "RTN","DGMTU1",57,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",58,0) ; Output -- Patient or Income Person Date of Birth "RTN","DGMTU1",59,0) N DGDOB,Y "RTN","DGMTU1",60,0) S Y=$P($$DEM(DGPRI),"^",3) X ^DD("DD") S DGDOB=Y "RTN","DGMTU1",61,0) Q $G(DGDOB) "RTN","DGMTU1",62,0) ; "RTN","DGMTU1",63,0) SSN(DGPRI) ;Social Security Number of Patient Relation "RTN","DGMTU1",64,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",65,0) ; Output -- Patient or Income Person Social Security Number "RTN","DGMTU1",66,0) N DGSSN,Y "RTN","DGMTU1",67,0) S Y=$P($$DEM(DGPRI),"^",9) S DGSSN=$S(Y]"":$E(Y,1,3)_"-"_$E(Y,4,5)_"-"_$E(Y,6,10),1:"") "RTN","DGMTU1",68,0) Q $G(DGSSN) "RTN","DGMTU1",69,0) ; "RTN","DGMTU1",70,0) REL(DGPRI) ;Relationship of Patient Relation "RTN","DGMTU1",71,0) ; Input -- DGPRI Patient Relation IEN "RTN","DGMTU1",72,0) ; Output -- Relationship of Patient Relation "RTN","DGMTU1",73,0) N DGREL "RTN","DGMTU1",74,0) S DGREL=$P($G(^DG(408.11,+$P($G(^DGPR(408.12,DGPRI,0)),U,2),0)),U) "RTN","DGMTU1",75,0) Q $G(DGREL) "RTN","DGPSEU2") 0^76^B34825670 "RTN","DGPSEU2",1,0) DGPSEU2 ;ALB/ERC - REPORTS FOR PSEUDO SSN ; 1/9/06 7:46am "RTN","DGPSEU2",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGPSEU2",3,0) ; "RTN","DGPSEU2",4,0) ;creates a report of all dependents with pseudo SSNs "RTN","DGPSEU2",5,0) ;can call for one Pseudo SSN Reason or can call for all reasons "RTN","DGPSEU2",6,0) ;sorted by reason "RTN","DGPSEU2",7,0) ; "RTN","DGPSEU2",8,0) TSK2 ; "RTN","DGPSEU2",9,0) N DGQ,DGQUIT,DGREAS,DGXREAS,DGTXT "RTN","DGPSEU2",10,0) N ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR "RTN","DGPSEU2",11,0) N IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE "RTN","DGPSEU2",12,0) K ^TMP("DGEVC",$J) "RTN","DGPSEU2",13,0) S DGQUIT=0 "RTN","DGPSEU2",14,0) D QUESREAS^DGPSEUDO Q:DGQUIT "RTN","DGPSEU2",15,0) S %ZIS="Q" "RTN","DGPSEU2",16,0) D ^%ZIS I $G(POP) D ^%ZISC,HOME^%ZIS W !,"Job Terminated!" Q "RTN","DGPSEU2",17,0) I $D(IO("Q")) D Q "RTN","DGPSEU2",18,0) . S ZTRTN="RPT2^DGPSEU2" "RTN","DGPSEU2",19,0) . S ZTDESC="DEPENDENTS WITH PSEUDO SOCIAL SECURITY NUMBERS" "RTN","DGPSEU2",20,0) . S (ZTSAVE("DGXREAS"),ZTSAVE("DGXVET"))="" "RTN","DGPSEU2",21,0) . D ^%ZTLOAD "RTN","DGPSEU2",22,0) . S DGTXT=$S($G(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!") "RTN","DGPSEU2",23,0) . W !,DGTXT "RTN","DGPSEU2",24,0) RPT2 ; "RTN","DGPSEU2",25,0) N DGC,DGPAGE,DGQ "RTN","DGPSEU2",26,0) S (DGQUIT,DGPAGE)=0 "RTN","DGPSEU2",27,0) S DGC=0 "RTN","DGPSEU2",28,0) D LOOP2 "RTN","DGPSEU2",29,0) D HDR2 "RTN","DGPSEU2",30,0) I $G(DGC)'>0 W !!?25,"****NO RECORDS TO REPORT****" W ! D PAUSE^DGPSEUDO Q "RTN","DGPSEU2",31,0) D REP2(DGXREAS) "RTN","DGPSEU2",32,0) D ^%ZISC,HOME^%ZIS "RTN","DGPSEU2",33,0) K ^TMP("DGEVC",$J) "RTN","DGPSEU2",34,0) Q "RTN","DGPSEU2",35,0) LOOP2 ; "RTN","DGPSEU2",36,0) I $E(IOST,1,2)["C-" U IO(0) W !!,"Scanning file...." "RTN","DGPSEU2",37,0) U IO "RTN","DGPSEU2",38,0) N DGCT,DGIEN13,DGX "RTN","DGPSEU2",39,0) K ^TMP("DGEVC",$J) "RTN","DGPSEU2",40,0) S DGX=999999999 "RTN","DGPSEU2",41,0) S DGCT=0 "RTN","DGPSEU2",42,0) S ^TMP("DGEVC",$J,"COUNT")=0 "RTN","DGPSEU2",43,0) S ^TMP("DGEVC",$J,"COUNT","REFUSED TO PROVIDE")=0 "RTN","DGPSEU2",44,0) S ^TMP("DGEVC",$J,"COUNT","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0 "RTN","DGPSEU2",45,0) S ^TMP("DGEVC",$J,"COUNT","NO SSN ASSIGNED")=0 "RTN","DGPSEU2",46,0) S ^TMP("DGEVC",$J,"COUNT","NULL")=0 "RTN","DGPSEU2",47,0) F S DGX=$O(^DGPR(408.13,"SSN",DGX)) Q:DGX="" D "RTN","DGPSEU2",48,0) . I DGX'["P" Q "RTN","DGPSEU2",49,0) . S DGIEN13=0 "RTN","DGPSEU2",50,0) . F S DGIEN13=$O(^DGPR(408.13,"SSN",DGX,DGIEN13)) Q:'DGIEN13 D "RTN","DGPSEU2",51,0) . . Q:'$D(^DGPR(408.13,DGIEN13,0)) "RTN","DGPSEU2",52,0) . . D PSEU2 "RTN","DGPSEU2",53,0) Q "RTN","DGPSEU2",54,0) PSEU2 ; "RTN","DGPSEU2",55,0) N DGARR,DGCT,DGDFN,DGDOB,DGERR,DGIEN12,DGNAM,DGPAT,DGPSSN,DGSSN "RTN","DGPSEU2",56,0) I $D(^TMP("DGEVC",$J,DGIEN13)) Q "RTN","DGPSEU2",57,0) D GETS^DIQ(408.13,DGIEN13_",",".01;.09;.1","EI","DGARR","DGERR") "RTN","DGPSEU2",58,0) I $D(DGERR) K DGERR Q "RTN","DGPSEU2",59,0) I $G(DGARR(408.13,DGIEN13_",",.09,"I"))'["P" K DGARR Q "RTN","DGPSEU2",60,0) S DGDEPNAM=$G(DGARR(408.13,DGIEN13_",",.01,"I")) "RTN","DGPSEU2",61,0) S DGDEPSSN=$G(DGARR(408.13,DGIEN13_",",.09,"I")) "RTN","DGPSEU2",62,0) S DGREASON=$G(DGARR(408.13,DGIEN13_",",.1,"E")) "RTN","DGPSEU2",63,0) I $G(DGREASON)']"" S DGREASON="NULL" "RTN","DGPSEU2",64,0) I DGXREAS'="ALL",DGXREAS'=DGREASON K DGARR Q "RTN","DGPSEU2",65,0) S DGIEN12=0 "RTN","DGPSEU2",66,0) S DGIEN12=$O(^DGPR(408.12,"C",DGIEN13_";DGPR(408.13,",DGIEN12)) "RTN","DGPSEU2",67,0) I $G(DGIEN12)']"" K DGARR Q "RTN","DGPSEU2",68,0) I '$D(^DGPR(408.12,DGIEN12,0)) K DGARR Q "RTN","DGPSEU2",69,0) D GETS^DIQ(408.12,DGIEN12_",",".01;.02","EI","DGARR","DGERR") "RTN","DGPSEU2",70,0) I $D(DGERR) K DGARR,DGERR Q "RTN","DGPSEU2",71,0) S DGDFN=$G(DGARR(408.12,DGIEN12_",",.01,"I")) "RTN","DGPSEU2",72,0) I '$D(^DPT(DGDFN)),($G(^DPT(DGDFN,0))']"") K DGARR Q "RTN","DGPSEU2",73,0) S DGREL=$G(DGARR(408.12,DGIEN12_",",.02,"E")) "RTN","DGPSEU2",74,0) S DGREL=$$GETREL(DGREL) "RTN","DGPSEU2",75,0) D GETS^DIQ(2,DGDFN_",",".01;.09","EI","DGARR","DGERR") "RTN","DGPSEU2",76,0) I $D(DGERR) K DGARR,DGERR Q "RTN","DGPSEU2",77,0) S DGPATNAM=$G(DGARR(2,DGDFN_",",.01,"E")) "RTN","DGPSEU2",78,0) S DGPATSSN=$G(DGARR(2,DGDFN_",",.09,"I")) "RTN","DGPSEU2",79,0) S DGC=DGC+1 "RTN","DGPSEU2",80,0) S ^TMP("DGEVC",$J,DGPATNAM,DGDFN,DGDEPNAM,DGIEN13)=DGPATSSN_"^"_DGREL_"^"_DGDEPSSN_"^"_DGREASON "RTN","DGPSEU2",81,0) S ^TMP("DGEVC",$J,"COUNT")=DGC "RTN","DGPSEU2",82,0) S ^TMP("DGEVC",$J,"COUNT",DGREASON)=$G(^TMP("DGEVC",$J,"COUNT",DGREASON))+1 "RTN","DGPSEU2",83,0) K DGARR,DGDFN,DGERR,DGDEPNAM,DGDEPSSN,DGPATNAM,DGPATSSN,DGREASON,DGREL "RTN","DGPSEU2",84,0) Q "RTN","DGPSEU2",85,0) HDR2 ; "RTN","DGPSEU2",86,0) N DGDATE,DGL,DGLINE,DGT,Y ;display veteran, non-vet or both "RTN","DGPSEU2",87,0) I $E(IOST,1,2)["C-" W @IOF "RTN","DGPSEU2",88,0) S DGPAGE=DGPAGE+1 "RTN","DGPSEU2",89,0) W !?((IOM-46)\2),"Pseudo SSN Report for Means Test Dependents",?70,"Page:"_DGPAGE "RTN","DGPSEU2",90,0) S DGT="Report shows "_$S(DGXREAS="NULL":"",1:DGXREAS) "RTN","DGPSEU2",91,0) S DGL=$L(DGT) "RTN","DGPSEU2",92,0) W !?((IOM-DGL)\2),DGT "RTN","DGPSEU2",93,0) S Y=DT X ^DD("DD") S DGDATE=Y "RTN","DGPSEU2",94,0) W !?62,"Date: "_$G(DGDATE) "RTN","DGPSEU2",95,0) W !!,"PATIENT",?27,"PATIENT SSN" "RTN","DGPSEU2",96,0) W !?5,"DEPENDENT",?38,"RELATIONSHIP",?52,"DEP. PSSN",?64,"PSSN REASON" "RTN","DGPSEU2",97,0) N DGZ "RTN","DGPSEU2",98,0) W ! "RTN","DGPSEU2",99,0) F DGZ=1:1:IOM W "-" "RTN","DGPSEU2",100,0) Q "RTN","DGPSEU2",101,0) REP2(DGXREAS) ; "RTN","DGPSEU2",102,0) N DG0,DGCT,DGDNAM,DGIEN,DGN,DGPNAM,DGRR "RTN","DGPSEU2",103,0) S (DGDNAM,DGN,DGDFN,DGPNAM)="" "RTN","DGPSEU2",104,0) S DGCT=0 "RTN","DGPSEU2",105,0) F S DGPNAM=$O(^TMP("DGEVC",$J,DGPNAM)) Q:DGPNAM']""!($G(DGQ)) D "RTN","DGPSEU2",106,0) . I DGPNAM="COUNT",($O(^TMP("DGEVC",$J,DGPNAM,""))'>0) Q "RTN","DGPSEU2",107,0) . F S DGDFN=$O(^TMP("DGEVC",$J,DGPNAM,DGDFN)) Q:DGDFN'>0!($G(DGQ)) D "RTN","DGPSEU2",108,0) . . N DG0 "RTN","DGPSEU2",109,0) . . I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE^DGPSEUDO Q:$G(DGQ) "RTN","DGPSEU2",110,0) . . I $Y>(IOSL-4) D "RTN","DGPSEU2",111,0) . . . W @IOF "RTN","DGPSEU2",112,0) . . . D HDR2 "RTN","DGPSEU2",113,0) . . S DG0=^DPT(DGDFN,0) "RTN","DGPSEU2",114,0) . . S DGSSN=$P(DG0,U,9) "RTN","DGPSEU2",115,0) . . W !!,$E($G(DGPNAM),1,25),?27,$G(DGSSN) "RTN","DGPSEU2",116,0) . . S (DGDNAM,DGIEN)="" "RTN","DGPSEU2",117,0) . . F S DGDNAM=$O(^TMP("DGEVC",$J,DGPNAM,DGDFN,DGDNAM)) Q:DGDNAM']""!($G(DGQ)) D "RTN","DGPSEU2",118,0) . . . F S DGIEN=$O(^TMP("DGEVC",$J,DGPNAM,DGDFN,DGDNAM,DGIEN)) Q:DGIEN'>0!($G(DGQ)) D "RTN","DGPSEU2",119,0) . . . . S DGN=^TMP("DGEVC",$J,DGPNAM,DGDFN,DGDNAM,DGIEN) "RTN","DGPSEU2",120,0) . . . . S DGRR=$P(DGN,U,4) "RTN","DGPSEU2",121,0) . . . . S DGRR=$S(DGRR["REF":"REF TO PROVIDE",DGRR["UNKN":"SSN UNK-F/U REQ",DGRR["NULL":"",1:DGRR) "RTN","DGPSEU2",122,0) . . . . I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE^DGPSEUDO Q:$G(DGQ) "RTN","DGPSEU2",123,0) . . . . I $Y>(IOSL-4) D "RTN","DGPSEU2",124,0) . . . . . W @IOF "RTN","DGPSEU2",125,0) . . . . . D HDR2 "RTN","DGPSEU2",126,0) . . . . . W !,$E($G(DGPNAM),1,25),?27,$G(DGSSN) "RTN","DGPSEU2",127,0) . . . . W !?5,$G(DGDNAM),?38,$E($P(DGN,U,2),1,12),?52,$P(DGN,U,3),?64,$G(DGRR) "RTN","DGPSEU2",128,0) . . . . S DGCT=DGCT+1 "RTN","DGPSEU2",129,0) I DGCT=DGC D "RTN","DGPSEU2",130,0) . I $E(IOST,1,2)["C-",($Y>(IOSL-6)) D PAUSE^DGPSEUDO Q:$G(DGQ) "RTN","DGPSEU2",131,0) . I $Y>(IOSL-6) D "RTN","DGPSEU2",132,0) . . W @IOF "RTN","DGPSEU2",133,0) . . D HDR2 "RTN","DGPSEU2",134,0) . W !!?5,"Total number of dependents with Pseudo SSNs for this report: "_DGC "RTN","DGPSEU2",135,0) . I DGXREAS="ALL" D "RTN","DGPSEU2",136,0) . . W !?31,"Dependents who REFUSED TO PROVIDE: "_^TMP("DGEVC",$J,"COUNT","REFUSED TO PROVIDE") "RTN","DGPSEU2",137,0) . . W !?29,"Dependents who have NO SSN ASSIGNED: "_^TMP("DGEVC",$J,"COUNT","NO SSN ASSIGNED") "RTN","DGPSEU2",138,0) . . W !?33,"Dependents who have SSN UNKNOWN: "_^TMP("DGEVC",$J,"COUNT","SSN UNKNOWN/FOLLOW-UP REQUIRED") "RTN","DGPSEU2",139,0) . . W !?22,"Dependents who have no PSSN Reason entered: "_^TMP("DGEVC",$J,"COUNT","NULL") "RTN","DGPSEU2",140,0) W ! "RTN","DGPSEU2",141,0) I $E(IOST,1,2)["C-",('$G(DGQ)) D PAUSE^DGPSEUDO "RTN","DGPSEU2",142,0) D ^%ZISC,HOME^%ZIS "RTN","DGPSEU2",143,0) Q "RTN","DGPSEU2",144,0) GETREL(DGREL) ;some relationships will need to be abbreviated to fit the 12 "RTN","DGPSEU2",145,0) ; char spacing limit "RTN","DGPSEU2",146,0) I DGREL']"" Q DGREL "RTN","DGPSEU2",147,0) I $P(DGREL,"-")="GREAT" S $P(DGREL,"-")="GR" "RTN","DGPSEU2",148,0) Q DGREL "RTN","DGPSEUDO") 0^65^B49360032 "RTN","DGPSEUDO",1,0) DGPSEUDO ;ALB/ERC - REPORTS FOR PSEUDO SSN ; 1/17/06 9:58am "RTN","DGPSEUDO",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGPSEUDO",3,0) ; "RTN","DGPSEUDO",4,0) ;creates a report of all patients with pseudo SSNs "RTN","DGPSEUDO",5,0) ;can call for veteran, non-veterans or both "RTN","DGPSEUDO",6,0) ;can call for one Pseudo SSN Reason or can call for all reasons "RTN","DGPSEUDO",7,0) ;sorted by reason "RTN","DGPSEUDO",8,0) TSK1 ; "RTN","DGPSEUDO",9,0) N DGQUIT,DGREAS,DGREASON,DGTXT,DGQ,DGVET,DGXREAS,DGXVET "RTN","DGPSEUDO",10,0) N ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR "RTN","DGPSEUDO",11,0) N IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE "RTN","DGPSEUDO",12,0) K ^TMP("DGEVC",$J) "RTN","DGPSEUDO",13,0) S DGQUIT=0 "RTN","DGPSEUDO",14,0) D QUESVET Q:DGQUIT "RTN","DGPSEUDO",15,0) D QUESREAS Q:DGQUIT "RTN","DGPSEUDO",16,0) S %ZIS="Q" D ^%ZIS I $G(POP) D ^%ZISC,HOME^%ZIS W !,"Job Terminated!" Q "RTN","DGPSEUDO",17,0) I $D(IO("Q")) D Q "RTN","DGPSEUDO",18,0) . S ZTRTN="RPT1^DGPSEUDO" "RTN","DGPSEUDO",19,0) . S ZTDESC="PATIENTS WITH PSEUDO SOCIAL SECURITY NUMBERS" "RTN","DGPSEUDO",20,0) . S (ZTSAVE("DGXREAS"),ZTSAVE("DGXVET"))="" "RTN","DGPSEUDO",21,0) . D ^%ZTLOAD "RTN","DGPSEUDO",22,0) . S DGTXT=$S($G(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!") "RTN","DGPSEUDO",23,0) . W !,DGTXT "RTN","DGPSEUDO",24,0) RPT1 ; "RTN","DGPSEUDO",25,0) N DGC,DGPAGE,DGXXVET "RTN","DGPSEUDO",26,0) S DGPAGE=0 "RTN","DGPSEUDO",27,0) S DGC=0 "RTN","DGPSEUDO",28,0) S DGXXVET=DGXVET "RTN","DGPSEUDO",29,0) D LOOP1 "RTN","DGPSEUDO",30,0) D HDR1 "RTN","DGPSEUDO",31,0) I $G(DGC)'>0 W !!?25,"****NO RECORDS TO REPORT****" W ! D PAUSE Q "RTN","DGPSEUDO",32,0) D REP1(DGXVET,DGXREAS) "RTN","DGPSEUDO",33,0) D ^%ZISC,HOME^%ZIS "RTN","DGPSEUDO",34,0) K ^TMP("DGEVC",$J) "RTN","DGPSEUDO",35,0) Q "RTN","DGPSEUDO",36,0) QUESVET ;ask user if report should be veterans, non-veterans, or both "RTN","DGPSEUDO",37,0) N DGBOTH,DIR,DIRUT,DIROUT,X "RTN","DGPSEUDO",38,0) W !!!,?10,"REPORT OF PATIENTS WITH PSEUDO SOCIAL SECURITY NUMBERS" "RTN","DGPSEUDO",39,0) W !?5,"This report excludes deceased patients, non-user enrollees and" "RTN","DGPSEUDO",40,0) W !?5,"with no Integration Control Numbers (ICN).",! "RTN","DGPSEUDO",41,0) S DIR("A",1)="Do you want this report for Veterans, Non-Veterans or both?" "RTN","DGPSEUDO",42,0) S DIR("A",2)="1. Veterans only" "RTN","DGPSEUDO",43,0) S DIR("A",3)="2. Non-Veterans only" "RTN","DGPSEUDO",44,0) S DIR("A",4)="3. Veterans and Non-Veterans" "RTN","DGPSEUDO",45,0) S DIR("A")="Select" "RTN","DGPSEUDO",46,0) S DIR("B")=1 "RTN","DGPSEUDO",47,0) S DIR("?")="Choose a report with Veterans only, Non-Veterans only or both." "RTN","DGPSEUDO",48,0) S DIR(0)="N^1:3" "RTN","DGPSEUDO",49,0) D ^DIR "RTN","DGPSEUDO",50,0) I $D(DIRUT)!($D(DIROUT)) S DGQUIT=1 "RTN","DGPSEUDO",51,0) S DGXVET=$S(X=1:"VET",X=2:"NON",1:"BOTH") "RTN","DGPSEUDO",52,0) Q "RTN","DGPSEUDO",53,0) ; "RTN","DGPSEUDO",54,0) QUESREAS ;ask user which Pseudo SSN Reason, or all "RTN","DGPSEUDO",55,0) N DIR,DIRUT,DIROUT,X "RTN","DGPSEUDO",56,0) W ! "RTN","DGPSEUDO",57,0) S DIR("A",1)="Select which Pseudo SSN Reason(s) to be included in the report." "RTN","DGPSEUDO",58,0) S DIR("A",2)="1. Refused to Provide" "RTN","DGPSEUDO",59,0) S DIR("A",3)="2. SSN Unknown/Follow-up Required" "RTN","DGPSEUDO",60,0) S DIR("A",4)="3. No SSN Assigned" "RTN","DGPSEUDO",61,0) S DIR("A",5)="4. No reason on file" "RTN","DGPSEUDO",62,0) S DIR("A",6)="5. All of the above" "RTN","DGPSEUDO",63,0) S DIR("A")="Select" "RTN","DGPSEUDO",64,0) S DIR("?")="Select one of the Reasons for having a Pseudo SSN." "RTN","DGPSEUDO",65,0) S DIR(0)="N^1:5" "RTN","DGPSEUDO",66,0) D ^DIR "RTN","DGPSEUDO",67,0) I $D(DIRUT)!($D(DIROUT)) S DGQUIT=1 "RTN","DGPSEUDO",68,0) S DGXREAS=$S(X=1:"REFUSED TO PROVIDE",X=2:"SSN UNKNOWN/FOLLOW-UP REQUIRED",X=3:"NO SSN ASSIGNED",X=4:"NULL",1:"ALL") "RTN","DGPSEUDO",69,0) Q "RTN","DGPSEUDO",70,0) LOOP1 ; "RTN","DGPSEUDO",71,0) I $E(IOST,1,2)["C-" U IO(0) W !!,"Scanning file...." "RTN","DGPSEUDO",72,0) U IO "RTN","DGPSEUDO",73,0) N DGDFN,DGX "RTN","DGPSEUDO",74,0) K ^TMP("DGEVC",$J) "RTN","DGPSEUDO",75,0) S ^TMP("DGEVC",$J,"COUNT","VET","REFUSED TO PROVIDE")=0 "RTN","DGPSEUDO",76,0) S ^TMP("DGEVC",$J,"COUNT","VET","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0 "RTN","DGPSEUDO",77,0) S ^TMP("DGEVC",$J,"COUNT","VET","NO SSN ASSIGNED")=0 "RTN","DGPSEUDO",78,0) S ^TMP("DGEVC",$J,"COUNT","VET","NULL")=0 "RTN","DGPSEUDO",79,0) S ^TMP("DGEVC",$J,"COUNT","NON","REFUSED TO PROVIDE")=0 "RTN","DGPSEUDO",80,0) S ^TMP("DGEVC",$J,"COUNT","NON","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0 "RTN","DGPSEUDO",81,0) S ^TMP("DGEVC",$J,"COUNT","NON","NO SSN ASSIGNED")=0 "RTN","DGPSEUDO",82,0) S ^TMP("DGEVC",$J,"COUNT","NON","NULL")=0 "RTN","DGPSEUDO",83,0) S DGX=999999999 "RTN","DGPSEUDO",84,0) F S DGX=$O(^DPT("SSN",DGX)) Q:DGX="" D "RTN","DGPSEUDO",85,0) . I DGX'["P" Q "RTN","DGPSEUDO",86,0) . S DGDFN="" "RTN","DGPSEUDO",87,0) . F S DGDFN=$O(^DPT("SSN",DGX,DGDFN)) Q:'DGDFN D "RTN","DGPSEUDO",88,0) . . I '$D(^DPT(DGDFN,0)) Q "RTN","DGPSEUDO",89,0) . . D PSEU1 "RTN","DGPSEUDO",90,0) Q "RTN","DGPSEUDO",91,0) PSEU1 ; "RTN","DGPSEUDO",92,0) N DGARR,DGDOB,DGEC,DGERR,DGNAM,DGREASON,DGSSN,DGUSER,DGVET "RTN","DGPSEUDO",93,0) I $D(^TMP("DGEVC",$J,DGDFN)) Q "RTN","DGPSEUDO",94,0) D GETS^DIQ(2,DGDFN_",",".01;.03;.09;.0906;.351;.361;.3617;991.01;1901","EI","DGARR","DGERR") "RTN","DGPSEUDO",95,0) I $D(DGERR) K DGERR Q "RTN","DGPSEUDO",96,0) I $G(DGARR(2,DGDFN_",",.351,"I"))]"" K DGARR Q "RTN","DGPSEUDO",97,0) I $G(DGARR(2,DGDFN_",",991.01,"I"))']"" K DGARR Q "RTN","DGPSEUDO",98,0) S DGVET=$S($G(DGARR(2,DGDFN_",",1901,"I"))="Y":"VET",$G(DGARR(2,DGDFN_",",1901,"I"))="N":"NON",1:"NON") "RTN","DGPSEUDO",99,0) I $G(DGVET)]"",DGXVET'="BOTH",DGVET'=DGXVET K DGARR Q "RTN","DGPSEUDO",100,0) S DGREASON=$G(DGARR(2,DGDFN_",",.0906,"E")) "RTN","DGPSEUDO",101,0) I $G(DGREASON)']"" S DGREASON="NULL" "RTN","DGPSEUDO",102,0) I DGXREAS'="ALL",DGXREAS'=DGREASON K DGARR Q "RTN","DGPSEUDO",103,0) S DGUSER=$G(DGARR(2,DGDFN_",",.3617,"I")) "RTN","DGPSEUDO",104,0) I DGVET="YES",($G(DGUSER)']"") K DGARR Q "RTN","DGPSEUDO",105,0) S DGUSER=$$FY($E(DGUSER,1,3)+1700) "RTN","DGPSEUDO",106,0) I DGVET="VET",$G(DGUSER)'=1 K DGARR Q "RTN","DGPSEUDO",107,0) S DGNAM=$G(DGARR(2,DGDFN_",",.01,"I")) "RTN","DGPSEUDO",108,0) I $G(DGNAM)']"" K DGARR Q "RTN","DGPSEUDO",109,0) S DGDOB=$G(DGARR(2,DGDFN_",",.03,"E")) "RTN","DGPSEUDO",110,0) S DGEC=$G(DGARR(2,DGDFN_",",.361,"E")) "RTN","DGPSEUDO",111,0) S DGSSN=DGARR(2,DGDFN_",",.09,"I") "RTN","DGPSEUDO",112,0) I DGX'=DGSSN K DGARR Q "RTN","DGPSEUDO",113,0) S DGC=DGC+1 "RTN","DGPSEUDO",114,0) S ^TMP("DGEVC",$J,DGVET,DGREASON,DGNAM,DGDFN)=$G(DGSSN)_"^"_$G(DGDOB)_"^"_$G(DGEC) "RTN","DGPSEUDO",115,0) S ^TMP("DGEVC",$J,"COUNT")=DGC "RTN","DGPSEUDO",116,0) S ^TMP("DGEVC",$J,"COUNT",DGVET,DGREASON)=$G(^TMP("DGEVC",$J,"COUNT",DGVET,DGREASON))+1 "RTN","DGPSEUDO",117,0) Q "RTN","DGPSEUDO",118,0) FY(DGFY) ;determine if user enrollee date is current FY or later "RTN","DGPSEUDO",119,0) N DGYEAR "RTN","DGPSEUDO",120,0) S DGYEAR=$E(DT,1,3)+1700 "RTN","DGPSEUDO",121,0) I $E(DT,4,5)>9 S DGYEAR=DGYEAR+1 "RTN","DGPSEUDO",122,0) Q $S(DGFY>DGYEAR:1,DGFY=DGYEAR:1,1:0) "RTN","DGPSEUDO",123,0) HDR1 ; "RTN","DGPSEUDO",124,0) N DGDATE,DGL,DGLINE,DGT,Y ;display veteran, non-vet or both "RTN","DGPSEUDO",125,0) I $E(IOST,1,2)["C-" W @IOF "RTN","DGPSEUDO",126,0) S DGPAGE=DGPAGE+1 "RTN","DGPSEUDO",127,0) W !?((IOM-44)\2),"Patients with Pseudo Social Security Numbers",?70,"Page:"_DGPAGE "RTN","DGPSEUDO",128,0) S DGT=$S(DGXXVET="VET":"Veterans only",DGXXVET="NON":"Non-Veterans only",1:"Veterans and Non-Veterans") "RTN","DGPSEUDO",129,0) S DGT="Report shows "_DGT "RTN","DGPSEUDO",130,0) S DGL=$L(DGT) "RTN","DGPSEUDO",131,0) W !?((IOM-DGL)\2),DGT "RTN","DGPSEUDO",132,0) S Y=DT X ^DD("DD") S DGDATE=Y "RTN","DGPSEUDO",133,0) W !?62,"Date: "_$G(DGDATE) "RTN","DGPSEUDO",134,0) W !!,"PATIENT",?32,"PSEUDO SSN",?44,"BIRTHDATE",?56,"PRIMARY ELIGIBILITY CODE" "RTN","DGPSEUDO",135,0) N DGZ "RTN","DGPSEUDO",136,0) W ! "RTN","DGPSEUDO",137,0) F DGZ=1:1:IOM W "-" ;S $P(DGLINE,"-",DGZ)="" "RTN","DGPSEUDO",138,0) Q "RTN","DGPSEUDO",139,0) REP1(DGXVET,DGXREAS) ; "RTN","DGPSEUDO",140,0) N DGCT,DGV "RTN","DGPSEUDO",141,0) S DGCT=0 "RTN","DGPSEUDO",142,0) I DGXVET="BOTH" D "RTN","DGPSEUDO",143,0) . F DGV="VET","NON" D "RTN","DGPSEUDO",144,0) . . Q:'$D(^TMP("DGEVC",$J,DGV)) "RTN","DGPSEUDO",145,0) . . Q:$G(DGQ) "RTN","DGPSEUDO",146,0) . . I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE Q:$G(DGQ) "RTN","DGPSEUDO",147,0) . . I $Y>(IOSL-4) D "RTN","DGPSEUDO",148,0) . . . W @IOF "RTN","DGPSEUDO",149,0) . . . D HDR1 "RTN","DGPSEUDO",150,0) . . W !!?5,"Report for "_$S(DGV="VET":"Veterans",1:"Non-Veterans") "RTN","DGPSEUDO",151,0) . . D VET(DGV) "RTN","DGPSEUDO",152,0) I DGXVET'="BOTH" D VET(DGXVET) "RTN","DGPSEUDO",153,0) I $G(DGC)=DGCT W !!?29,"Patients with Pseudo SSNs: "_DGCT "RTN","DGPSEUDO",154,0) I $E(IOST,1,2)["C-",('$G(DGQ)) W ! D PAUSE "RTN","DGPSEUDO",155,0) Q "RTN","DGPSEUDO",156,0) VET(DGXVET) ; "RTN","DGPSEUDO",157,0) N DGR "RTN","DGPSEUDO",158,0) I DGXREAS="ALL" D "RTN","DGPSEUDO",159,0) . F DGR="REFUSED TO PROVIDE","SSN UNKNOWN/FOLLOW-UP REQUIRED","NO SSN ASSIGNED","NULL" D "RTN","DGPSEUDO",160,0) . . Q:$G(DGQ) "RTN","DGPSEUDO",161,0) . . D REAS(DGXVET,DGR) "RTN","DGPSEUDO",162,0) I DGXREAS'="ALL" D "RTN","DGPSEUDO",163,0) . D REAS(DGXVET,DGXREAS) "RTN","DGPSEUDO",164,0) Q "RTN","DGPSEUDO",165,0) REAS(DGXVET,DGXRR) ; "RTN","DGPSEUDO",166,0) N DGN,DGNAM,DGDFN "RTN","DGPSEUDO",167,0) S DGDFN=0 "RTN","DGPSEUDO",168,0) I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE Q:$G(DGQ) "RTN","DGPSEUDO",169,0) I $Y>(IOSL-4) D "RTN","DGPSEUDO",170,0) . W @IOF "RTN","DGPSEUDO",171,0) . D HDR1 "RTN","DGPSEUDO",172,0) I $O(^TMP("DGEVC",$J,DGXVET,DGXRR,""))]"" W !!?10,"Pseudo SSN Reason: "_$S(DGXRR="NULL":"",1:DGXRR) "RTN","DGPSEUDO",173,0) S DGNAM="" "RTN","DGPSEUDO",174,0) F S DGNAM=$O(^TMP("DGEVC",$J,DGXVET,DGXRR,DGNAM)) Q:DGNAM']""!($G(DGQ)) D "RTN","DGPSEUDO",175,0) . F S DGDFN=$O(^TMP("DGEVC",$J,DGXVET,DGXRR,DGNAM,DGDFN)) Q:DGDFN']""!($G(DGQ)) D "RTN","DGPSEUDO",176,0) . . I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE Q:$G(DGQ) "RTN","DGPSEUDO",177,0) . . I $Y>(IOSL-4) D "RTN","DGPSEUDO",178,0) . . . W @IOF "RTN","DGPSEUDO",179,0) . . . D HDR1 "RTN","DGPSEUDO",180,0) . . S DGN=^TMP("DGEVC",$J,DGXVET,DGXRR,DGNAM,DGDFN) "RTN","DGPSEUDO",181,0) . . W !,DGNAM,?32,$P(DGN,U),?44,$P(DGN,U,2) "RTN","DGPSEUDO",182,0) . . I $P(DGN,U,3)["SERVICE CONNECTED" S $P(DGN,U,3)="SC 50% TO 100%" "RTN","DGPSEUDO",183,0) . . W ?56,$E($P(DGN,U,3),1,23) "RTN","DGPSEUDO",184,0) . . S DGCT=$G(DGCT)+1 "RTN","DGPSEUDO",185,0) I ^TMP("DGEVC",$J,"COUNT",DGXVET,DGXRR)>0,(DGXREAS="ALL") W !?46,"Subtotal: "_^TMP("DGEVC",$J,"COUNT",DGXVET,DGXRR) "RTN","DGPSEUDO",186,0) Q "RTN","DGPSEUDO",187,0) ; "RTN","DGPSEUDO",188,0) PAUSE ; "RTN","DGPSEUDO",189,0) N DIR,X,Y "RTN","DGPSEUDO",190,0) S DGQ=0 "RTN","DGPSEUDO",191,0) S DIR(0)="E" "RTN","DGPSEUDO",192,0) D ^DIR "RTN","DGPSEUDO",193,0) I '+Y!($D(DIRUT)) S DGQ=1 "RTN","DGPSEUDO",194,0) Q "RTN","DGPSEUDO",195,0) ; "RTN","DGPZ07C") 0^50^B1691045 "RTN","DGPZ07C",1,0) DGPZ07C ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 10/14/05 11:48am "RTN","DGPZ07C",2,0) ;;5.3;Registration;**653**;Aug 13,1993;Build 2 "RTN","DGPZ07C",3,0) ; "RTN","DGPZ07C",4,0) ; This routine prompts the user for a patient name. Then, when found, calls the IVMZ07C support routine "RTN","DGPZ07C",5,0) ; to check for inconsistencies in the patient record which will prevent the building of a Z07 HL7 record. "RTN","DGPZ07C",6,0) ; Data from this routine will be available on the Inconsistent Data report. "RTN","DGPZ07C",7,0) ; "RTN","DGPZ07C",8,0) ; structure: "RTN","DGPZ07C",9,0) ; 1. Begin loop "RTN","DGPZ07C",10,0) ; 2. Select patient "RTN","DGPZ07C",11,0) ; 3. Call IVMZ07C support routine "RTN","DGPZ07C",12,0) ; 4. Notify user of Pass/Fail "RTN","DGPZ07C",13,0) ; "RTN","DGPZ07C",14,0) ; Must be called from entry point "RTN","DGPZ07C",15,0) Q "RTN","DGPZ07C",16,0) ; "RTN","DGPZ07C",17,0) EN ; entry point. "RTN","DGPZ07C",18,0) ; Start loop, quit when no more patients to check "RTN","DGPZ07C",19,0) F I '$$SELECT() Q "RTN","DGPZ07C",20,0) ; "RTN","DGPZ07C",21,0) SELECT() ; Select patient and call support routine "RTN","DGPZ07C",22,0) N DFN,DIC,Y,DGP,DGSD,PASS,SEL "RTN","DGPZ07C",23,0) S SEL=0 "RTN","DGPZ07C",24,0) W !! S DIC=2,DIC(0)="AEQM",DIC("A")="Check consistency for which PATIENT: " D ^DIC "RTN","DGPZ07C",25,0) I Y<0 Q SEL "RTN","DGPZ07C",26,0) S DFN=+Y,SEL=1 "RTN","DGPZ07C",27,0) W !,"Checking..." "RTN","DGPZ07C",28,0) S PASS=$$EN^IVMZ07C(DFN) "RTN","DGPZ07C",29,0) D NOTIFY(PASS) "RTN","DGPZ07C",30,0) ; we only need "CC" counter in batch mode so kill it here. "RTN","DGPZ07C",31,0) K ^TMP($J,"CC") "RTN","DGPZ07C",32,0) Q SEL "RTN","DGPZ07C",33,0) ; "RTN","DGPZ07C",34,0) NOTIFY(PASS) ; Notify user of Pass/Fail "RTN","DGPZ07C",35,0) W !! ;write two blank lines "RTN","DGPZ07C",36,0) I PASS W "NO INCONSISTENCIES FOUND..." Q "RTN","DGPZ07C",37,0) W "INCONSISTENCIES FOUND..." "RTN","DGPZ07C",38,0) D ON^DGRPC Q:DGER "RTN","DGPZ07C",39,0) S DGVAR="DUZ^DFN",DGPGM="^DGPZ07P" D ZIS^DGUTQ G Q^DGPZ07P:POP U IO G ^DGPZ07P "RTN","DGPZ07C",40,0) Q "RTN","DGPZ07C",41,0) ; "RTN","DGPZ07P") 0^80^B8264367 "RTN","DGPZ07P",1,0) DGPZ07P ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- PRINT ROUTINE ; 06/30/06 "RTN","DGPZ07P",2,0) ;;5.3;Registration;**653**;Aug 13,1993;Build 2 "RTN","DGPZ07P",3,0) ; "RTN","DGPZ07P",4,0) ; This routine prints the inconsistency report for the Z07 Consistency Check option "RTN","DGPZ07P",5,0) ; This routine is copied from DGRPCP1 and modified for a single DFN "RTN","DGPZ07P",6,0) ; "RTN","DGPZ07P",7,0) ST N DGSTOP,ZTSTOP,CRT,%,DGCLK1,I,J,X,Y,Z,DGCT,DGPG,DGDATA,DGDFN,DGER,DGHDR,DGINC,DGOFF,DGSSN,DGSTORE,DGZ,I1,I2,X1 "RTN","DGPZ07P",8,0) S CRT=$S($E(IOST,1,2)="C-":1,1:0) "RTN","DGPZ07P",9,0) S DGDATA=^DGIN(38.5,DFN,0) I $D(^DPT(DFN,0)) D SET I $$FIRST^DGUTL G Q "RTN","DGPZ07P",10,0) S DGPG=0,DGHDR="INCONSISTENT ELEMENTS FOR "_$P(^DPT(DFN,0),"^",1)_" "_$P(^DPT(DFN,0),"^",9) D HDR "RTN","DGPZ07P",11,0) S I=0 F I1=0:0 S I=$O(^UTILITY($J,"DGINC",I)) Q:I="" F I2=0:0 S I2=$O(^UTILITY($J,"DGINC",I,I2)) Q:'I2 G:$G(DGSTOP) Q S X=^(I2) D W "RTN","DGPZ07P",12,0) D TRA "RTN","DGPZ07P",13,0) Q K %,%DT,DGVAR,DGER,DFN,DGPGM,^UTILITY($J,"DGINC") "RTN","DGPZ07P",14,0) D ENDREP^DGUTL,CLOSE^DGUTQ "RTN","DGPZ07P",15,0) Q "RTN","DGPZ07P",16,0) W W !,$P(X,"^",1),?31,$P(X,"^",2),?$S($E($P(X,"^",3))="*":43,1:45),$P(X,"^",3) I $S(CRT:$Y>20,1:$Y>45) D "RTN","DGPZ07P",17,0) . D:'CRT TRA S DGSTOP=$$SUBSEQ^DGUTL "RTN","DGPZ07P",18,0) . D HDR "RTN","DGPZ07P",19,0) Q "RTN","DGPZ07P",20,0) HDR Q:$G(DGSTOP) S DGPG=DGPG+1 W !,DGHDR "RTN","DGPZ07P",21,0) W:DGPG>1 ?73,"Page "_DGPG W !,"Patient Name",?31,"Soc Sec #",?45,"Inconsistent/Missing Data Elements" "RTN","DGPZ07P",22,0) S X1="",$P(X1,"=",80)="" W !,X1,! "RTN","DGPZ07P",23,0) Q "RTN","DGPZ07P",24,0) TRA S DGCT=0,X1="",$P(X1,"*",80)="" X "F DGZ=$Y:1:$S($D(IOSL):(IOSL-10),1:41) W !" "RTN","DGPZ07P",25,0) W !!,X1,!,"An inconsistent Data element preceded by '**' prevents a Z07" "RTN","DGPZ07P",26,0) W !,"record from being sent to the HEC.",!,X1 "RTN","DGPZ07P",27,0) Q "RTN","DGPZ07P",28,0) SET S DGDFN=^DPT(DFN,0),DGSSN=$P(DGDFN,"^",9),DGSTORE=$S($P(DGDFN,"^",1)]"":$P(DGDFN,"^",1),1:"UNIDENTIFIED PATIENT #"_DFN)_" "_$E(DGSSN,8,9)_$E(DGSSN,6,7)_$E(DGSSN,4,5)_$E(DGSSN,1,3),DGINC="",DGLOOP=0 "RTN","DGPZ07P",29,0) F J=0:0 S J=$O(^DGIN(38.5,DFN,"I",J)) Q:'J D "RTN","DGPZ07P",30,0) . Q:'$D(^DGIN(38.6,J)) "RTN","DGPZ07P",31,0) . S DG6=$P(^DGIN(38.6,J,0),"^",6) I DG6'=1 S DG6=0 "RTN","DGPZ07P",32,0) . S DGTEXT=$P(^DGIN(38.6,J,0),"^",1) I DG6 S DGTEXT="**"_DGTEXT "RTN","DGPZ07P",33,0) . ; set up variables "RTN","DGPZ07P",34,0) . S DGLOOP=DGLOOP+1 "RTN","DGPZ07P",35,0) . ; print full first record, abbreviated subsequent records "RTN","DGPZ07P",36,0) . I DGLOOP=1 S ^UTILITY($J,"DGINC",DGSTORE,DGLOOP)=$S($P(DGDFN,"^",1)]"":$P(DGDFN,"^",1),1:"UNIDENTIFIED PATIENT #"_DFN)_U_$P(DGDFN,"^",9)_U_DGTEXT Q "RTN","DGPZ07P",37,0) . S ^UTILITY($J,"DGINC",DGSTORE,DGLOOP)="^^"_DGTEXT "RTN","DGPZ07P",38,0) K J,DGINC,DGSSN,DGDFN,DGLOOP,DGSTORE,DG6,DGCHK,DGTEXT "RTN","DGPZ07P",39,0) Q "RTN","DGPZ07P",40,0) ; "RTN","DGRP1") 0^70^B28795198 "RTN","DGRP1",1,0) DGRP1 ;ALB/MRL,ERC - DEMOGRAPHIC DATA ; 06/22/06 "RTN","DGRP1",2,0) ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653**;Aug 13, 1993;Build 2 "RTN","DGRP1",3,0) ; "RTN","DGRP1",4,0) EN S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP1",5,0) I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRP1",6,0) ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRP1",7,0) W ! S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV "RTN","DGRP1",8,0) W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV "RTN","DGRP1",9,0) W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y "RTN","DGRP1",10,0) ;add Pseudo SSN Reason - DG*5.3*653, ERC "RTN","DGRP1",11,0) I $P(DGRP(0),U,9)["P" D "RTN","DGRP1",12,0) . N DGSPACE "RTN","DGRP1",13,0) . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen "RTN","DGRP1",14,0) . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: " "RTN","DGRP1",15,0) . I $P(DGRP(0),U,9)["P" D "RTN","DGRP1",16,0) . . N DGREAS D SSNREAS(.DGREAS) "RTN","DGRP1",17,0) . . Q:$G(DGREAS)']"" "RTN","DGRP1",18,0) . . W DGREAS "RTN","DGRP1",19,0) D GETNCAL ;Display name component, sex, and alias information "RTN","DGRP1",20,0) S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU "RTN","DGRP1",21,0) S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17 "RTN","DGRP1",22,0) D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: " "RTN","DGRP1",23,0) W !?11 "RTN","DGRP1",24,0) S Z1=40,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS") "RTN","DGRP1",25,0) S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?11 W:'(I#2) ?51 W DGA(I) "RTN","DGRP1",26,0) S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?3,"County: ",DGCC K DGCC "RTN","DGRP1",27,0) S DGCC=$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(.121),U,5),1,+$P(DGRP(.121),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W ?43,"County: ",DGCC K DGCC "RTN","DGRP1",28,0) W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) "RTN","DGRP1",29,0) S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU) "RTN","DGRP1",30,0) W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X "RTN","DGRP1",31,0) W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16)) "RTN","DGRP1",32,0) ; "RTN","DGRP1",33,0) ; *** Additional displays added for Pre-Registration "RTN","DGRP1",34,0) I $G(DGPRFLG)=1 D "RTN","DGRP1",35,0) . W ! "RTN","DGRP1",36,0) . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1 "RTN","DGRP1",37,0) . I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1 I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2) "RTN","DGRP1",38,0) . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D") "RTN","DGRP1",39,0) . I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1 S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2) "RTN","DGRP1",40,0) . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D") "RTN","DGRP1",41,0) . I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1 S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2) "RTN","DGRP1",42,0) . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D") "RTN","DGRP1",43,0) . I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1 S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2) "RTN","DGRP1",44,0) . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D") "RTN","DGRP1",45,0) . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration "RTN","DGRP1",46,0) . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI D "RTN","DGRP1",47,0) .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2) "RTN","DGRP1",48,0) .. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D") "RTN","DGRP1",49,0) ; "RTN","DGRP1",50,0) G ^DGRPP "RTN","DGRP1",51,0) ; "RTN","DGRP1",52,0) GETNCAL ;Get name component values "RTN","DGRP1",53,0) N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW "RTN","DGRP1",54,0) S DGNC="Family^Given^Middle^Prefix^Suffix^Degree" "RTN","DGRP1",55,0) S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," "RTN","DGRP1",56,0) I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") "RTN","DGRP1",57,0) ;Get alias values "RTN","DGRP1",58,0) S DGA=0 F DGI=1:1:5 D Q:'$D(DGALIAS(DGI)) "RTN","DGRP1",59,0) A2 .S DGA=$O(^DPT(DFN,.01,DGA)) "RTN","DGRP1",60,0) .I 'DGA D:DGI=1 Q "RTN","DGRP1",61,0) ..S DGALIAS(DGI)="< No alias entries on file >" Q "RTN","DGRP1",62,0) .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q "RTN","DGRP1",63,0) .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2 "RTN","DGRP1",64,0) .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2) "RTN","DGRP1",65,0) .I $L(DGX) D "RTN","DGRP1",66,0) ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9) "RTN","DGRP1",67,0) ..; BAJ DG*5.3*700 retrofit 06/22/06 "RTN","DGRP1",68,0) ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19) "RTN","DGRP1",69,0) ..S $E(DGALIAS(DGI),20)=DGX Q "RTN","DGRP1",70,0) .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32) "RTN","DGRP1",71,0) .Q "RTN","DGRP1",72,0) ;Display name component, sex, multiple birth indicator and alias data "RTN","DGRP1",73,0) F DGI=1:1:6 D "RTN","DGRP1",74,0) .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:23,1:27)) "RTN","DGRP1",75,0) .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV "RTN","DGRP1",76,0) .; BAJ DG*5.3*700 retrofit 06/2206 "RTN","DGRP1",77,0) .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV "RTN","DGRP1",78,0) .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: " "RTN","DGRP1",79,0) .I DGI>1 W ?47,$G(DGALIAS(DGI-1)) "RTN","DGRP1",80,0) .Q "RTN","DGRP1",81,0) Q "RTN","DGRP1",82,0) SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC "RTN","DGRP1",83,0) S DGREAS=$P(DGRP("SSN"),U) "RTN","DGRP1",84,0) I $G(DGREAS)']"" Q "RTN","DGRP1",85,0) S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >") "RTN","DGRP1",86,0) Q "RTN","DGRP7") 0^31^B16119751 "RTN","DGRP7",1,0) DGRP7 ;ALB/MRL,CKN - REGISTRATION SCREEN 7/ELIGIBILITY INFORMATION ; 7/25/06 11:42am "RTN","DGRP7",2,0) ;;5.3;Registration;**528,653**;Aug 13, 1993;Build 2 "RTN","DGRP7",3,0) N DGCASH,DGMBCK "RTN","DGRP7",4,0) S DGRPS=7 D H^DGRPU F I=0,.29,.3,.31,.32,.321,.36,.362,"TYPE","VET" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP7",5,0) S (DGRPW,Z)=1 D WW^DGRPV W " Patient Type: " S DGRPX=DGRP("TYPE"),Z=$S($D(^DG(391,+DGRPX,0)):$P(^(0),"^",1),1:DGRPU),Z1=36 D WW1^DGRPV W "Veteran: " S DGRPX=DGRP("VET"),(X,Z1)=1 D YN "RTN","DGRP7",6,0) W !?9,"Svc Connected: " S DGRPX=DGRP(.3),X=1,Z1=33,DGNA=$S($P(DGRP("VET"),"^",1)="Y":0,1:1) D YN2 W "SC Percent: " W:$E(Z)'="Y" "N/A" I $E(Z)="Y" D "RTN","DGRP7",7,0) .S X=$P(DGRPX,"^",2) W $S(X="":"UNANSWERED",1:+X_"%") "RTN","DGRP7",8,0) .S X=$P(DGRP(.3),"^",1),DGNA=$S(X'="Y":1,1:0) "RTN","DGRP7",9,0) .W !?19,"P&T: " S X=4,Z1=31 D YN2 W "Unemployable: " S X=5,Z1=0 D YN2 "RTN","DGRP7",10,0) .W !?9,"SC Award Date: ",$$DATENP^DG1010P0(DGRPX,12) "RTN","DGRP7",11,0) W !?9,"Rated Incomp.: " S X=$$YN2^DG1010P0(DGRP(.29),12) W X D:X["Y" "RTN","DGRP7",12,0) .W " Date (CIVIL): ",$$DATENP^DG1010P0(DGRP(.29),2) "RTN","DGRP7",13,0) .W " Date (VA): ",$$DATENP^DG1010P0(DGRP(.29),1) "RTN","DGRP7",14,0) S DGRPX=DGRP(.31) W !?10,"Claim Number: ",$S($P(DGRPX,"^",3)]"":$P(DGRPX,"^",3),1:DGRPU),!?11,"Folder Loc.: ",$$POINT^DG1010P0(DGRP(.31),4,4) "RTN","DGRP7",15,0) S Z=2 D WW^DGRPV ;monetary benefits section "RTN","DGRP7",16,0) W " Aid & Attendance: " S Z=$$YN2^DG1010P0(DGRP(.362),12) D MBCK S Z1=33 D WW1^DGRPV "RTN","DGRP7",17,0) W "Housebound: ",$$YN2^DG1010P0(DGRP(.362),13) D MBCK "RTN","DGRP7",18,0) W !?12,"VA Pension: " S Z=$$YN2^DG1010P0(DGRP(.362),14) D MBCK S Z1=30 D WW1^DGRPV "RTN","DGRP7",19,0) W "VA Disability: ",$$YN2^DG1010P0(DGRP(.3),11) D MBCK "RTN","DGRP7",20,0) W !?4,"Total Check Amount: " S X=$$DISP^DG1010P0(DGRP(.362),20,'DGMBCK) W $S(X:"$"_X,1:X) "RTN","DGRP7",21,0) W !?10,"GI Insurance: " S Z=$$YN2^DG1010P0(DGRP(.362),17) S Z1=37 D WW1^DGRPV "RTN","DGRP7",22,0) W "Amount: " S X=$$DISP^DG1010P0(DGRP(.362),6) W $S(X:"$"_X,1:X) "RTN","DGRP7",23,0) S Z=3 D WW^DGRPV S DGRPE=+DGRP(.36),Z=$S($D(^DIC(8,+DGRPE,0)):$P(^(0),"^",1),1:DGRPU) "RTN","DGRP7",24,0) W " Primary Elig Code: ",Z D AAC1^DGLOCK2 I DGAAC(1)]"" W !?8,"Agency/Country: ",$S($D(^DIC(35,+$P(DGRP(.3),"^",9),0)):$P(^(0),"^",1),1:DGRPU) "RTN","DGRP7",25,0) W !?4,"Other Elig Code(s): " S I1="" F I=0:0 S I=$O(^DPT("AEL",DFN,I)) Q:'I I $D(^DIC(8,+I,0)),I'=DGRPE S I1=I1+1 W:I1>1 !?24 W $P(^(0),"^",1) "RTN","DGRP7",26,0) W:'I1 "NO ADDITIONAL ELIGIBILITIES IDENTIFIED" "RTN","DGRP7",27,0) S DGRPX=+$P(DGRP(.32),"^",3) W !?5,"Period of Service: ",$S($D(^DIC(21,+DGRPX,0)):$P(^(0),"^",1),1:DGRPU) "RTN","DGRP7",28,0) D ^DGYZODS G:'DGODS CONT S DGRPX=$S($D(^DPT(DFN,"ODS")):^("ODS"),1:"") W !?6,"Recalled to Duty: ",$S($P(DGRPX,"^",2)=1:"FROM NATIONAL GUARDS",$P(DGRPX,"^",2)=2:"FROM RESERVES",$P(DGRPX,"^",2)=0:"NO",1:DGRPU) "RTN","DGRP7",29,0) W !?18,"Rank: ",$S($D(^DIC(25002.1,+$P(DGRPX,"^",3),0)):$P(^(0),"^",1),1:DGRPU) "RTN","DGRP7",30,0) CONT ; "RTN","DGRP7",31,0) ;display Combat Vet Eiligibility, if present "RTN","DGRP7",32,0) N DGCV,SHAD "RTN","DGRP7",33,0) S SHAD=$P(DGRP(.321),"^",15) ;SHAD Indicator "RTN","DGRP7",34,0) S DGCV=$$CVEDT^DGCV(DFN) I +$G(DGCV)=1 D "RTN","DGRP7",35,0) . W !,"<3.1> Combat Vet Elig.: " "RTN","DGRP7",36,0) . W $S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)=0:"EXPIRED",1:"") "RTN","DGRP7",37,0) . I $P($G(DGCV),U,2)]"" D "RTN","DGRP7",38,0) . . S Y=$P(DGCV,U,2) D DD^%DT "RTN","DGRP7",39,0) . . W " End Date: "_Y "RTN","DGRP7",40,0) . I SHAD=1 W ?56,"<3.2>Proj 112/SHAD: YES" ;Only display if YES "RTN","DGRP7",41,0) ; "RTN","DGRP7",42,0) I (+$G(DGCV)'=1)&(SHAD=1) W !,?56,"<3.2>Proj 112/SHAD: YES" "RTN","DGRP7",43,0) ; "RTN","DGRP7",44,0) ;print sc disabilities (per patient) "RTN","DGRP7",45,0) W ! S Z=4 D WW^DGRPV W " Service Connected Conditions as stated by applicant" S X="",$P(X,"-",52)="" W !?4,X "RTN","DGRP7",46,0) W !?4 S I3=0 F I=0:0 S I=$O(^DPT(DFN,.373,I)) Q:'I S I1=$P(^(I,0),"^",1)_" ("_+$P(^(0),"^",2)_"%), ",I3=I W:(79-$X)<$L(I1) !?4 W I1 "RTN","DGRP7",47,0) W:'I3 ?4,"NONE STATED" "RTN","DGRP7",48,0) Q K DGAAC,DGNA,DGODS,DGRP,DGRPE,DGRPX,I,I1,I2,I3,X,X1,Z,Z1 "RTN","DGRP7",49,0) G ^DGRPP "RTN","DGRP7",50,0) YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNKNOWN",1:"UNANSWERED") D WW1^DGRPV "RTN","DGRP7",51,0) Q "RTN","DGRP7",52,0) YN2 S Z=$S(DGNA:"N/A",$P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNKNOWN",1:"UNANSWERED") D WW1^DGRPV "RTN","DGRP7",53,0) Q "RTN","DGRP7",54,0) MBCK ;flag for any MB Y/N fields = yes "RTN","DGRP7",55,0) S DGMBCK=$S($G(DGMBCK):1,(X="Y"):1,1:0) "RTN","DGRP7",56,0) Q "RTN","DGRPC") 0^51^B24943025 "RTN","DGRPC",1,0) DGRPC ;ALB/MRL/PJR/PHH/EG/BAJ - CHECK CONSISTENCY OF PATIENT DATA ; 11/8/05 8:37am "RTN","DGRPC",2,0) ;;5.3;Registration;**108,121,314,301,470,489,505,451,568,585,641,653**;Aug 13, 1993;Build 2 "RTN","DGRPC",3,0) ; "RTN","DGRPC",4,0) ;linetags in routines correspond to IEN of file 38.6 "RTN","DGRPC",5,0) ; "RTN","DGRPC",6,0) ;variables: DGVT = 1 if VETERAN? = YES, 0 if NO "RTN","DGRPC",7,0) ; DGSC = 1 if SC? = YES, 0 if NO "RTN","DGRPC",8,0) ; DGCD = 0 node of file EC file (#8) "RTN","DGRPC",9,0) ; DGRPCOLD = old inconsistencies for pt (separated by ,s) "RTN","DGRPC",10,0) ; DGCHK = #s to check (separated by ,s) "RTN","DGRPC",11,0) ; DGLST = next # to check "RTN","DGRPC",12,0) ; DGER = inconsistencies found (separated by ,s) "RTN","DGRPC",13,0) ; DGNCK = 1 if missing key elig data...can't process further "RTN","DGRPC",14,0) ; "RTN","DGRPC",15,0) N ANYMSE,CONARR,CONCHK,CONERR,CONSPEC,LOC,I5,I6 "RTN","DGRPC",16,0) N MSECHK,MSESET,MSERR,MSDATERR,RANGE,RANSET "RTN","DGRPC",17,0) D ON I $S(('$D(DFN)#2):1,'$D(^DPT(DFN,0)):1,DGER:1,1:0) G KVAR^DGRPCE:DGER "RTN","DGRPC",18,0) EN S:'$D(DGEDCN)#2 DGEDCN=0 I DGEDCN W !!,"Checking data for consistency..." "RTN","DGRPC",19,0) D START:DGEDCN "RTN","DGRPC",20,0) F I=0,.13,.141,.22,.24,.3,.31,.311,.32,.321,.322,.33,.35,.36,.362,.38,.39,.52,.53,"TYPE","VET" S DGP(I)=$G(^DPT(DFN,I)) "RTN","DGRPC",21,0) ;get old inconsistencies "RTN","DGRPC",22,0) S DGRPCOLD="," I $D(^DGIN(38.5,DFN)) F I=0:0 S I=$O(^DGIN(38.5,DFN,"I",I)) Q:'I S DGRPCOLD=DGRPCOLD_I_"," "RTN","DGRPC",23,0) ;find consistencies to check/not check "RTN","DGRPC",24,0) ; DG*5.3*653 modified to exclude checks numbered>99 BAJ 10/25/2005 "RTN","DGRPC",25,0) S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99) I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,'$P(^(0),"^",5):1,1:0),I'=99 S DGCHK=DGCHK_I_"," "RTN","DGRPC",26,0) S DGVT=$S(DGP("VET")="Y":1,1:0),DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0),DGCD=$S($D(^DIC(8,+DGP(.36),0)):^(0),1:""),(DGCT,DGER,DGNCK)="" I 'DGVT,$D(^DG(391,+DGP("TYPE"),0)),$P(^(0),"^",2) S DGVT=2 "RTN","DGRPC",27,0) S DGLST=+$P(DGCHK,",",2) G @DGLST "RTN","DGRPC",28,0) 1 S DGD=$P(DGP(0),"^",1) I DGD?1L.E!(DGD?.E1L.E)!(DGD="") S X=1 D COMB,NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",29,0) S I1=0 F I=1:1:$L(DGD) Q:I1 S J=$E(DGD,I) I J?1NP,$A(J)>32,J'=",",J'="-",J'=".",J'="'" S I1=1 "RTN","DGRPC",30,0) I I1 S X=1 D COMB "RTN","DGRPC",31,0) D NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",32,0) 2 S I1=0 F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I!(I1) I $P(^(I,0),"^",1)'?1A.E S I1=1 "RTN","DGRPC",33,0) I I1 S X=2 D COMB "RTN","DGRPC",34,0) D NEXT I +DGLST>7!('DGLST) G @DGLST "RTN","DGRPC",35,0) 3 ; "RTN","DGRPC",36,0) 4 ; "RTN","DGRPC",37,0) 5 ; "RTN","DGRPC",38,0) 6 ; "RTN","DGRPC",39,0) 7 F I=2,3,5,8,9 I $P(DGP(0),"^",I)="" S X=$S(I=2:3,I=3:4,I=5:5,I=8:6,1:7) D COMB:DGCHK[(","_X_",") "RTN","DGRPC",40,0) S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST "RTN","DGRPC",41,0) 8 S I1=0,DGD=$G(^DPT(DFN,.11)) F I=1,4,5,6,7 Q:I1 I $P(DGD,"^",I)="" S I1=1 "RTN","DGRPC",42,0) I I1 S X=8 D COMB "RTN","DGRPC",43,0) D NEXT I +DGLST'=9 G @DGLST "RTN","DGRPC",44,0) 9 I DGP("VET")="" S X=9,DGNCK=1 D COMB "RTN","DGRPC",45,0) D NEXT I +DGLST'=10 G @DGLST "RTN","DGRPC",46,0) 10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB "RTN","DGRPC",47,0) D NEXT I +DGLST'=11 G @DGLST "RTN","DGRPC",48,0) 11 I 'DGVT,DGSC S X=11 D COMB "RTN","DGRPC",49,0) D NEXT I +DGLST'=12 G @DGLST "RTN","DGRPC",50,0) 12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB "RTN","DGRPC",51,0) D NEXT I +DGLST'=13 G @DGLST "RTN","DGRPC",52,0) 13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB "RTN","DGRPC",53,0) D NEXT I +DGLST'=14 G @DGLST "RTN","DGRPC",54,0) 14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB "RTN","DGRPC",55,0) ; "RTN","DGRPC",56,0) ;Check Patient Eligibilities multiple if Primary Elig Code defined "RTN","DGRPC",57,0) I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301 "RTN","DGRPC",58,0) ; "RTN","DGRPC",59,0) D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",60,0) 15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB "RTN","DGRPC",61,0) D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",62,0) 16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB "RTN","DGRPC",63,0) D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",64,0) 17 K DGDATE,DGTIME "RTN","DGRPC",65,0) N SDARRAY,SDCLIEN,SDDATE "RTN","DGRPC",66,0) S I1=0,DGD=DT "RTN","DGRPC",67,0) S SDARRAY("FLDS")=3 "RTN","DGRPC",68,0) S SDARRAY(4)=DFN "RTN","DGRPC",69,0) I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D "RTN","DGRPC",70,0) .;if there is data hanging from the 101 subscript, "RTN","DGRPC",71,0) .;then this is a valid appointment "RTN","DGRPC",72,0) .;otherwise it is an error eg 01/21/2005 "RTN","DGRPC",73,0) .I $D(^TMP($J,"SDAMA301",101))=1 Q "RTN","DGRPC",74,0) .S SDCLIEN=0 "RTN","DGRPC",75,0) .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(I1) D "RTN","DGRPC",76,0) ..S SDDATE=0 "RTN","DGRPC",77,0) ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(I1) D "RTN","DGRPC",78,0) ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";") "RTN","DGRPC",79,0) ...I X=""!(X="I") S I1=1 "RTN","DGRPC",80,0) K ^TMP($J,"SDAMA301") "RTN","DGRPC",81,0) I I1 S X=17 D COMB "RTN","DGRPC",82,0) ; "RTN","DGRPC",83,0) END ; end of routine...find next check to execute (or goto end) "RTN","DGRPC",84,0) S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST "RTN","DGRPC",85,0) ; "RTN","DGRPC",86,0) COMB ;record inconsistency "RTN","DGRPC",87,0) S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q "RTN","DGRPC",88,0) Q "RTN","DGRPC",89,0) ; "RTN","DGRPC",90,0) NEXT ; find the next consistency check to check (goto end if can't process further) "RTN","DGRPC",91,0) S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q "RTN","DGRPC",92,0) I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35," G NEXT "RTN","DGRPC",93,0) S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,+DGLST<79:2,1:3) "RTN","DGRPC",94,0) Q "RTN","DGRPC",95,0) ; "RTN","DGRPC",96,0) PAT ;check inconsistencies for a selected patient "RTN","DGRPC",97,0) D ON G KVAR^DGRPCE:DGER W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Check consistency for which PATIENT: " D ^DIC K DIC G KVAR^DGRPCE:Y'>0 S DFN=+Y,DGEDCN=1 D DGRPC G PAT "RTN","DGRPC",98,0) ; "RTN","DGRPC",99,0) START ;record start time for checker "RTN","DGRPC",100,0) S DGSTART=$H Q "RTN","DGRPC",101,0) ; "RTN","DGRPC",102,0) TIME ;record end time for checker "RTN","DGRPC",103,0) Q:'$D(DGSTART)#2 S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2) "RTN","DGRPC",104,0) I +DGSTART=+DGEND S DGTIME=X1-X "RTN","DGRPC",105,0) E S DGTIME=(5184000-X)+X1 "RTN","DGRPC",106,0) I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ "RTN","DGRPC",107,0) W !!,"===> ",$S(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$S(DGCT=1:"y",1:"ies")," ",$S('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$S(DGTIME=1:"",1:"s"),"..." H 1 "RTN","DGRPC",108,0) TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q "RTN","DGRPC",109,0) ; "RTN","DGRPC",110,0) ON ;check if checker is on "RTN","DGRPC",111,0) S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1 "RTN","DGRPC",112,0) S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q "RTN","DGRPCE") 0^79^B31050795 "RTN","DGRPCE",1,0) DGRPCE ;ALB/MRL,KV,PJR,BRM,ERC - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am "RTN","DGRPCE",2,0) ;;5.3;Registration;**121,122,175,297,342,451,626,689,653**;Aug 13, 1993;Build 2 "RTN","DGRPCE",3,0) ; "RTN","DGRPCE",4,0) ;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens "RTN","DGRPCE",5,0) ; ;Adding CD Elig Codes in Load/Edit Screen used to "RTN","DGRPCE",6,0) ; ;cause undefined line tag error. "RTN","DGRPCE",7,0) ; "RTN","DGRPCE",8,0) S DGVTYN=$P($G(^DPT(DFN,"VET")),"^",1),DGDR="DR",(DR,DGD,DGDRC,DGCCF)="",DGASK=",",DGER=","_DGER D ^DGRPCE1 "RTN","DGRPCE",9,0) S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q:DGEK I DGER[(","_I_",") S DGEK=1 Q "RTN","DGRPCE",10,0) I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK "RTN","DGRPCE",11,0) F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0 "RTN","DGRPCE",12,0) G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK "RTN","DGRPCE",13,0) I DGASK'[26 F I=41,42 I DGASK'[41 D SASK "RTN","DGRPCE",14,0) I DGASK'[27 S I=60 I DGASK'[25 D SASK "RTN","DGRPCE",15,0) I DGASK'[34 F I=37,38 I DGASK'[37 D SASK "RTN","DGRPCE",16,0) I DGASK'[35 F I=39,40 I DGASK'[39 D SASK "RTN","DGRPCE",17,0) NKEY D ^DGRPCE1 "RTN","DGRPCE",18,0) I $S(DGER[49:1,(DGER[50):1,(DGER[52):1,1:0) D "RTN","DGRPCE",19,0) .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q "RTN","DGRPCE",20,0) .D REG^IBCNBME(DFN) "RTN","DGRPCE",21,0) .Q "RTN","DGRPCE",22,0) D Q S DIE="^DPT(",(DA,Y)=DFN D ^DIE:$D(DR) "RTN","DGRPCE",23,0) I DGER[54 D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT)) D "RTN","DGRPCE",24,0) . I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") D ASKSSN(DGREL("S")) "RTN","DGRPCE",25,0) . F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP I $$SSN^DGMTU1(+DGREL("D",DGDEP))']"" D ASKSSN(DGREL("D",DGDEP)) "RTN","DGRPCE",26,0) ; "RTN","DGRPCE",27,0) I DGER[59 D CATDIB "RTN","DGRPCE",28,0) I DGER["82" D EN2^DGRP6CL "RTN","DGRPCE",29,0) ; "RTN","DGRPCE",30,0) K DGREL,DGDEP "RTN","DGRPCE",31,0) KVAR K DR,DGEDCN,DGCT,DGER,DGINC55,DGRPADI,DGRPOUT,DGVTYN "RTN","DGRPCE",32,0) Q K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2,DGDR,DGDRC,DGECODE,DGEDIT,DGEK,DGKEY,DGP,DGRPADI,DGRPE,DIC,DIE,DIK,I,I1,J,X,X1,X2 "RTN","DGRPCE",33,0) K DGCOMLOC,DGCOMBR,FRDT,DGFRDT "RTN","DGRPCE",34,0) D KVAR^VADPT "RTN","DGRPCE",35,0) Q "RTN","DGRPCE",36,0) SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=$P($T(@I),";;",2,999),DGASK=DGASK_I_",",DGCCF=1 D SAVE "RTN","DGRPCE",37,0) Q "RTN","DGRPCE",38,0) SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q "RTN","DGRPCE",39,0) S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q "RTN","DGRPCE",40,0) ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38," "RTN","DGRPCE",41,0) I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE "RTN","DGRPCE",42,0) I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE "RTN","DGRPCE",43,0) D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE "RTN","DGRPCE",44,0) I 'DGKEY(1) D ELIG^DGRPCE1 "RTN","DGRPCE",45,0) Q "RTN","DGRPCE",46,0) MON I $S(I<40:1,I=56:1,1:0) D SAVE Q "RTN","DGRPCE",47,0) I $S(I<46:1,1:0),DGASK'[(","_(I-14)_",") D SAVE Q "RTN","DGRPCE",48,0) I DGASK'[(","_(I-15)_",") D SAVE "RTN","DGRPCE",49,0) Q "RTN","DGRPCE",50,0) ; "RTN","DGRPCE",51,0) 15 ;;.152;S:X']"" Y="@15";S DIE("NO^")="";.307;I X']"" W !!,*7,"But I need a reason why this applicant is ineligible!" S Y=.152;@15;K DIE("NO^"); "RTN","DGRPCE",52,0) 23 ;;.3611;S:X'="V" Y="@23";.3612;S DIE("NO^")="";I X']"" W !!,*7,"But I need to know the date eligibility was verifed!";@23;K DIE("NO^"); "RTN","DGRPCE",53,0) 25 ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25; "RTN","DGRPCE",54,0) 26 ;; "RTN","DGRPCE",55,0) 27 ;; "RTN","DGRPCE",56,0) 28 ;; "RTN","DGRPCE",57,0) 29 ;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29; "RTN","DGRPCE",58,0) 30 ;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30; "RTN","DGRPCE",59,0) 31 ;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31; "RTN","DGRPCE",60,0) 32 ;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32; "RTN","DGRPCE",61,0) 33 ;; "RTN","DGRPCE",62,0) 34 ;;.525;S:X'="Y" Y="@34";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim POW STATUS" S Y=.525;.526:.528;@34; "RTN","DGRPCE",63,0) 35 ;; "RTN","DGRPCE",64,0) 37 ;;.525;S:X'="Y" Y="@37";.526:.528;@37; "RTN","DGRPCE",65,0) 38 ;;.525;S:X'="Y" Y="@38";.526:.528;@38; "RTN","DGRPCE",66,0) 39 ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39; "RTN","DGRPCE",67,0) 40 ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40; "RTN","DGRPCE",68,0) 41 ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41; "RTN","DGRPCE",69,0) 42 ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42; "RTN","DGRPCE",70,0) 43 ;; "RTN","DGRPCE",71,0) 44 ;; "RTN","DGRPCE",72,0) 45 ;; "RTN","DGRPCE",73,0) 46 ;; "RTN","DGRPCE",74,0) 47 ;; "RTN","DGRPCE",75,0) 48 ;;.36265;S:X'="Y" Y="@48";.3626;@48; "RTN","DGRPCE",76,0) 51 ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51; "RTN","DGRPCE",77,0) 56 ;;.3025;S:X'="Y" Y="@56";.36295;@56; "RTN","DGRPCE",78,0) 60 ;;.32102;S:X'="Y" Y="@60";.32107;.3211;.32109;.3213;@60; "RTN","DGRPCE",79,0) ; "RTN","DGRPCE",80,0) ; NOTE: #46 & 47 REMOVED WITH PIMS5.3 "RTN","DGRPCE",81,0) ; "RTN","DGRPCE",82,0) ASKSSN(DEP) ;edit ssns if missing "RTN","DGRPCE",83,0) ; "RTN","DGRPCE",84,0) ; input: DEP as string for dependent (from GETREL) "RTN","DGRPCE",85,0) ; "RTN","DGRPCE",86,0) W !,$$NAME^DGMTU1(+DEP) "RTN","DGRPCE",87,0) S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE "RTN","DGRPCE",88,0) PS ; "RTN","DGRPCE",89,0) S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE "RTN","DGRPCE",90,0) I $$GET1^DIQ(408.13,DA_",",.09)["P" D "RTN","DGRPCE",91,0) . S DR=.1,DA=$P(DA,";") D ^DIE "RTN","DGRPCE",92,0) . I X']"" W !,"If SSN is a Pseudo SSN, the Pseudo SSN Reason field is required." G PS "RTN","DGRPCE",93,0) K DA,DR,DIE "RTN","DGRPCE",94,0) Q "RTN","DGRPCE",95,0) ; "RTN","DGRPCE",96,0) CATDIB ; "RTN","DGRPCE",97,0) ;Could be inconsistent because there is the catastrophic disability "RTN","DGRPCE",98,0) ;code without supporting information, or visa versa "RTN","DGRPCE",99,0) ; "RTN","DGRPCE",100,0) N DGCDIS,CODE,INFO "RTN","DGRPCE",101,0) S (INFO,CODE)=0 "RTN","DGRPCE",102,0) I $$GET^DGENCDA(DFN,.DGCDIS),DGCDIS("DATE") S INFO=1 "RTN","DGRPCE",103,0) S CODE=$$HASCAT^DGENCDA(DFN) "RTN","DGRPCE",104,0) I CODE D Q "RTN","DGRPCE",105,0) .W !!,">>> Catastrophically Disabled eligibilty requires additional information <<<" "RTN","DGRPCE",106,0) .D EDITCD^DGENCD(DFN) "RTN","DGRPCE",107,0) I INFO D "RTN","DGRPCE",108,0) . ;KV;11/15/00;DG*5.3*297;Start of modifications "RTN","DGRPCE",109,0) . W !!,"The patient record indicates that a determination was made " "RTN","DGRPCE",110,0) . W "that the patient",!,"is catastrophically disabled." "RTN","DGRPCE",111,0) . W !!,"To add Catastrophic Disability Eligibility Code(s), please use " "RTN","DGRPCE",112,0) . W "the menu option",!,"DGEN PATIENT ENROLLMENT.",!! "RTN","DGRPCE",113,0) .I $$ASKDEL() D "RTN","DGRPCE",114,0) .. I $$DELETE^DGENCDA1(DFN) D "RTN","DGRPCE",115,0) ...W !,">>> Determination Deleted <<<" "RTN","DGRPCE",116,0) ..; "RTN","DGRPCE",117,0) ..;could fail if lock could not be obtained "RTN","DGRPCE",118,0) ..E W !,"Catastrophic disability determination can not be deleted at this time.",!,"Please try again later." "RTN","DGRPCE",119,0) ;KV;11/15/00;DG*5.3*297;End of modifications "RTN","DGRPCE",120,0) Q "RTN","DGRPCE",121,0) ; "RTN","DGRPCE",122,0) ASKDEL() ; "RTN","DGRPCE",123,0) ;ask whether to delete catastrphic disability determination "RTN","DGRPCE",124,0) N DIR "RTN","DGRPCE",125,0) S DIR(0)="Y" "RTN","DGRPCE",126,0) ;KV;11/15/00;DG*5.3*297;Cosmetic change for DIR("A") "RTN","DGRPCE",127,0) S DIR("A")="Do you want to delete the determination showing that patient is catastrophically disabled" "RTN","DGRPCE",128,0) S DIR("B")="YES" "RTN","DGRPCE",129,0) D ^DIR "RTN","DGRPCE",130,0) Q:$D(DIRUT) 0 "RTN","DGRPCE",131,0) Q $S(Y=1:1,1:0) "RTN","DGRPCF") 0^54^B21529174 "RTN","DGRPCF",1,0) DGRPCF ;ALB/MRL,BAJ - CONSISTENCY OF PATIENT DATA (FILE/EDIT) ;Nov 2, 2005 "RTN","DGRPCF",2,0) ;;5.3;Registration;**250,653**;Aug 13, 1993;Build 2 "RTN","DGRPCF",3,0) ; "RTN","DGRPCF",4,0) ; file new inconsistencies or update file entries for patient "RTN","DGRPCF",5,0) ; "RTN","DGRPCF",6,0) ; DGCT = count of inconsistencies found (passed in from checker) "RTN","DGRPCF",7,0) ; DGCT1= count of inconsistencies which can't be edited because "RTN","DGRPCF",8,0) ; user does not hold appropriate key "RTN","DGRPCF",9,0) ; DGCT2= count of already filed inconsistencies "RTN","DGRPCF",10,0) ; DGCT3= count of inconsistencies which are uneditable through "RTN","DGRPCF",11,0) ; checker options "RTN","DGRPCF",12,0) ; "RTN","DGRPCF",13,0) ; "RTN","DGRPCF",14,0) ; "RTN","DGRPCF",15,0) EN I '$D(DGCT) G KVAR^DGRPCE "RTN","DGRPCF",16,0) ; DG*5.3*653 BAJ modified to delete only inconsistencies numbered 99 or less "RTN","DGRPCF",17,0) I 'DGCT,$O(^DGIN(38.5,DFN,"I",""),-1)>99 D DELETE G KVAR^DGRPCE "RTN","DGRPCF",18,0) S DGEDCN=+$G(DGEDCN),DGRPOUT=+$G(DGRPOUT),DGCON=1 D:DGEDCN START^DGRPC I 'DGCT D ^DGRPCF1,TIMEQ^DGRPC G KVAR^DGRPCE "RTN","DGRPCF",19,0) S:'$D(^DGIN(38.5,DFN,0)) ^(0)=DFN_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ) S X=$P(^(0),"^",4),^DGIN(38.5,DFN,0)=$P(^(0),"^",1,3)_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ)_"^"_$P(^(0),"^",6) K ^DGIN(38.5,"AC",9999999-X,DFN) "RTN","DGRPCF",20,0) S ^DGIN(38.5,"B",DFN,DFN)="",^DGIN(38.5,"AC",9999999-DT,DFN)="",^DGIN(38.5,0)=$P(^DGIN(38.5,0),"^",1,2)_"^"_DFN_"^"_($P(^(0),"^",4)+1) "RTN","DGRPCF",21,0) I $D(^DGIN(38.5,DFN,"I")) D DELETE "RTN","DGRPCF",22,0) S DGD2=0 F DGD=1:1 S DGD1=$P(DGER,",",DGD) Q:DGD1="" I $D(^DGIN(38.6,DGD1,0)) S DGD2=DGD1 S ^DGIN(38.5,DFN,"I",DGD1,0)=DGD1 "RTN","DGRPCF",23,0) S ^DGIN(38.5,DFN,"I",0)="^38.51PA^"_DGD2_"^"_DGCT I DGCT,DGEDCN G DIS "RTN","DGRPCF",24,0) G KVAR^DGRPCE "RTN","DGRPCF",25,0) ; "RTN","DGRPCF",26,0) DIS D TIME^DGRPC S DGRPE=$S($D(DGRPE):DGRPE+1,1:0) D KEY S IOP="HOME" D ^%ZIS K IOP W @IOF,! D DEM^VADPT W VADM(1)," (",$P(VADM(2),"^",2),")",?65,$P(VADM(3),"^",2) S X="",$P(X,"=",79)="" W !,X "RTN","DGRPCF",27,0) S (C,DGCT1,DGCT2,DGCT3)=0,DGEDIT="0000000011111110011111113333222223313333332222220030000" F I=1:1 S J=$P(DGER,",",I) Q:J="" I $D(^DGIN(38.6,J,0)) S X2=$P(^(0),"^",1) D WRIT "RTN","DGRPCF",28,0) I DGCT1!DGCT3 W ! D NOEDIT "RTN","DGRPCF",29,0) S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1) "RTN","DGRPCF",30,0) EDIT G:DGRPOUT BUL I DGCT1+DGCT3'=DGCT W !!,"DO YOU WANT TO UPDATE THESE INCONSISTENCIES NOW" S %=1 D YN^DICN I %=1 D G ^DGRPC "RTN","DGRPCF",31,0) . S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1) "RTN","DGRPCF",32,0) . L +^DPT(DFN):3 E W *7,!!,"Patient is being edited. Try again later." S DGEDCN=0 Q "RTN","DGRPCF",33,0) . D ^DGRPCE "RTN","DGRPCF",34,0) . L -^DPT(DFN) "RTN","DGRPCF",35,0) . S DGEDCN=1 "RTN","DGRPCF",36,0) I $S(($G(DGRETURN)>10):0,$G(DGINC55):1,1:0) D "RTN","DGRPCF",37,0) .N DIR "RTN","DGRPCF",38,0) .S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? ",DIR("B")="YES" D ^DIR "RTN","DGRPCF",39,0) .S:Y>0 DGRPV=0 "RTN","DGRPCF",40,0) .S:Y>0 DGRETURN=$G(DGRETURN)+1 "RTN","DGRPCF",41,0) I $S($G(Y)'>0:0,(DGRETURN>11):0,1:1) D ^DGRPV G ^DGRP9 "RTN","DGRPCF",42,0) I DGCT1+DGCT3'=DGCT,'% W !!?4,"YES - To correct inconsistencies to unrestricted fields immediately.",!?4,"NO - To abort this process immediately." G EDIT "RTN","DGRPCF",43,0) BUL K DGRETURN,X,Y D ^DGRPCB G KVAR^DGRPCE "RTN","DGRPCF",44,0) ; "RTN","DGRPCF",45,0) WRIT S C=C+1 W:(C#2) ! S X1=$S((C#2):0,1:40) W ?X1,$E(J_" ",1,3),"- ",X2 I DGKEY(+$E(DGEDIT,J)) W "*" S DGCT1=DGCT1+1 "RTN","DGRPCF",46,0) I "^17^55^"[("^"_+J_"^") W "**" S DGCT3=DGCT3+1 "RTN","DGRPCF",47,0) I +$P(DGRPCOLD,",",2),DGRPCOLD'[(","_J_",") S DGCT2=DGCT2+1 "RTN","DGRPCF",48,0) Q "RTN","DGRPCF",49,0) KEY S X=$S(('$D(DUZ)#2):1,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):1,1:0) F I=.3,.32,.361 S DGP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPCF",50,0) F I=0:1:4 S DGKEY(I)="" "RTN","DGRPCF",51,0) I $P(DGP(.361),"^",1)="V",X S DGKEY(1)=1 "RTN","DGRPCF",52,0) I $P(DGP(.3),"^",6)]"",X S DGKEY(2)=1 "RTN","DGRPCF",53,0) I $P(DGP(.32),"^",2)]"",X S DGKEY(3)=1 "RTN","DGRPCF",54,0) S:'X DGKEY(4)=1 K DGP Q "RTN","DGRPCF",55,0) ; "RTN","DGRPCF",56,0) DELETE ; Delete all Registration inconsistencies from INCONSISTENT DATA file (#38.5). "RTN","DGRPCF",57,0) ; "RTN","DGRPCF",58,0) ; "RTN","DGRPCF",59,0) N RULE,DIK,DA "RTN","DGRPCF",60,0) ; "RTN","DGRPCF",61,0) S RULE=0,DA="" "RTN","DGRPCF",62,0) S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," "RTN","DGRPCF",63,0) F S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE="" Q:RULE>99 S DA=RULE D ^DIK "RTN","DGRPCF",64,0) Q "RTN","DGRPCF",65,0) ; "RTN","DGRPCF",66,0) NOEDIT ; write explanation of non-editable items "RTN","DGRPCF",67,0) I DGCT1 W !,"You will not be able to edit inconsistencies followed by an asterisk [*]",!,"as you do not hold the appropriate ""DG ELIGIBILITY"" security key." "RTN","DGRPCF",68,0) I DGCT3 W !,"Inconsistencies followed by two (2) asterisks [**] must be corrected by",!,"using the appropriate MAS menu option(s)." "RTN","DGRPCF",69,0) I DGCT1+DGCT3'=DGCT W !!,"All items not followed by an asterisk can be edited at this time. If these",!,"items are not corrected at this time, a bulletin will be sent to the",!,"appropriate hospital personnel." "RTN","DGRPCF",70,0) ;;QUIT "RTN","DGRPCP") 0^52^B10965667 "RTN","DGRPCP",1,0) DGRPCP ;ALB/MRL/BAJ - CONSISTENCY PRINT ; OCT 25, 2005 "RTN","DGRPCP",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGRPCP",3,0) ; "RTN","DGRPCP",4,0) ;DG*5.3*653 BAJ 10/25/2005 "RTN","DGRPCP",5,0) ;modified code to prompt for and process inconsistencies found during Z07 build "RTN","DGRPCP",6,0) ;Also modified format of report. Changed to print inconsistency descriptions instead "RTN","DGRPCP",7,0) ;of numbers. See DGRPCP1 for detail. "RTN","DGRPCP",8,0) ; "RTN","DGRPCP",9,0) ; "RTN","DGRPCP",10,0) D ON^DGRPC G Q^DGRPCP1:DGER "RTN","DGRPCP",11,0) 1 K ^UTILITY($J) D DT^DICRW S Z="^" W !!,"Generate a listing of inconsistent data elements by:",! F I=1:1:3 S J=$P($T(T+I),";;",2),Z=Z_$P(J,"^",1)_"^" W !?4,$P(J,"^",1) "RTN","DGRPCP",12,0) R !!,"CHOOSE OUTPUT METHOD OR ENTER '^' TO QUIT: ",X:DTIME S:'$T X="^" D IN^DGHELP G Q^DGRPCP1:X["^"!(X']"") I %=-1 W !!,"The available choices are:",! X "F I=1:1:3 S J=$P($T(T+I),"";;"",2) W !,$P(J,""^"",1),"" - "",$P(J,""^"",2)" G 1 "RTN","DGRPCP",13,0) S DGHOW=X_"^"_$S(X="A":"ADMISSION",X="R":"REGISTRATION",1:"IDENTIFICATION")_" DATE" "RTN","DGRPCP",14,0) D W !! S %DT="EAX",%DT(0)=-DT,%DT("A")="Start with "_$P(DGHOW,"^",2)_": " D ^%DT G Q^DGRPCP1:Y'>0 S DGFRD=Y "RTN","DGRPCP",15,0) S Y=DGFRD X ^DD("DD") S %DT("A")=" Go To "_$P(DGHOW,"^",2)_": "_Y_"// " D ^%DT I X']"" S DGTOD=DGFRD_".9999" G H "RTN","DGRPCP",16,0) G Q^DGRPCP1:Y'>0 S DGTOD=Y_".9999" I DGFRD>DGTOD W !?4,"TO DATE CAN'T BE BEFORE FROM DATE!!",*7 G D "RTN","DGRPCP",17,0) H K %DT S Z="^NAME^TERMINAL DIGIT" R !!,"List by (N)ame or (T)erminal Digit: ",X:DTIME S:'$T X="^" D IN^DGHELP G Q^DGRPCP1:X["^" "RTN","DGRPCP",18,0) I %=-1 W !!?4,"N - To generate listing in Alphabetical Order",!?4,"T - To generate listing in Terminal Digit Order." G H "RTN","DGRPCP",19,0) Z07 S DGHOW1=X,Z="^Registration^Z07 Messages^All" R !!,"List (R)egistration, (Z)07 Messages or (A)ll Inconsistencies: ",X:DTIME S:'$T X="^" D IN^DGHELP G Q^DGRPCP1:X["^" "RTN","DGRPCP",20,0) I %=-1 D G Z07 "RTN","DGRPCP",21,0) . W !!?4,"R - Generate a list of inconsistencies found during Registration" "RTN","DGRPCP",22,0) . W !?4,"Z - Generate a list of inconsistencies found during Z07 Message build" "RTN","DGRPCP",23,0) . W !?4,"A - Generate a list of all inconsistencies found" "RTN","DGRPCP",24,0) S DGFILT=$S("RZ"[X:X,1:"A") "RTN","DGRPCP",25,0) W !!,*7,"THIS OUTPUT REQUIRES 132 COLUMN OUTPUT" S DGVAR="DUZ^DGHOW^DGHOW1^DGFRD^DGTOD^DGFILT",DGPGM="^DGRPCP1" D ZIS^DGUTQ G Q^DGRPCP1:POP U IO G ^DGRPCP1 "RTN","DGRPCP",26,0) T ; "RTN","DGRPCP",27,0) ;;ADMISSION DATE^Patients admitted during a specified date range. "RTN","DGRPCP",28,0) ;;IDENTIFICATION DATE^Inconsistencies identified during a specified date range. "RTN","DGRPCP",29,0) ;;REGISTRATION DATE^Patients registered during a specified date range. "RTN","DGRPCP1") 0^53^B22768467 "RTN","DGRPCP1",1,0) DGRPCP1 ;ALB/MRL/BAJ - CONSISTENCY PRINT, CONTINUED ; 10/18/2005 "RTN","DGRPCP1",2,0) ;;5.3;Registration;**108,161,653**;Aug 13, 1993;Build 2 "RTN","DGRPCP1",3,0) ; "RTN","DGRPCP1",4,0) ; DG*5.3*653 BAJ 10/18/2005 "RTN","DGRPCP1",5,0) ; enhanced for Z07 Consistency check project "RTN","DGRPCP1",6,0) ; 1. Allow filtering on Reg/Z07 Inconsistency (see ^DGRPCP) "RTN","DGRPCP1",7,0) ; 2. Print Short description instead of Inconsistency Number "RTN","DGRPCP1",8,0) ; 3. Fix report to end if user enters "^" at prompt "RTN","DGRPCP1",9,0) ; 4. Fix report to display message if no records match. "RTN","DGRPCP1",10,0) ; "RTN","DGRPCP1",11,0) ; "RTN","DGRPCP1",12,0) ST N DGSTOP,ZTSTOP "RTN","DGRPCP1",13,0) G I:$E(DGHOW)="I",A:($E(DGHOW)="A") "RTN","DGRPCP1",14,0) F I=DGFRD:0 S I=$O(^DPT("ADIS",I)) Q:'I!(I>DGTOD) F DFN=0:0 S DFN=$O(^DPT("ADIS",I,DFN)) Q:('DFN)!($G(ZTSTOP)) I $D(^DGIN(38.5,DFN,0)) S DGDATA=^(0) I $D(^DPT(DFN,0)) D SET "RTN","DGRPCP1",15,0) G PR "RTN","DGRPCP1",16,0) A F I=DGFRD:0 S I=$O(^DGPM("ATT1",I)) Q:'I!(I>DGTOD) F I1=0:0 S I1=$O(^DGPM("ATT1",I,I1)) Q:('I1)!($G(ZTSTOP)) I $D(^DGPM(+I1,0)) S DFN=$P(^(0),"^",3) I $D(^DGIN(38.5,DFN,0)) S DGDATA=^(0) I $D(^DPT(DFN,0)) D SET "RTN","DGRPCP1",17,0) G PR "RTN","DGRPCP1",18,0) I S DGTOD1=9999999-DGTOD,DGFRD1=9999999-DGFRD,I=DGTOD1 "RTN","DGRPCP1",19,0) F I1=0:0 S I=$O(^DGIN(38.5,"AC",I)) Q:'I!(I>DGFRD1) F DFN=0:0 S DFN=$O(^DGIN(38.5,"AC",I,DFN)) Q:('DFN)!($G(ZTSTOP)) I $D(^DGIN(38.5,DFN,0)) S DGDATA=^(0) I $D(^DPT(DFN,0)) D SET "RTN","DGRPCP1",20,0) PR I $$FIRST^DGUTL G Q "RTN","DGRPCP1",21,0) S DGPG=0,DGHDR="INCONSISTENT ELEMENTS FOR PATIENTS WITH A",Y=DGFRD X ^DD("DD") S DGFRD1="'"_Y_"'" I $P(DGTOD,".",1)'=DGFRD S Y=$P(DGTOD,".",1) X ^DD("DD") S DGFRD1=" BETWEEN "_DGFRD1_" AND '"_Y_"'" "RTN","DGRPCP1",22,0) E S DGFRD1=" OF "_DGFRD1 "RTN","DGRPCP1",23,0) S DGHDR=DGHDR_$S($E(DGHOW)="R":"",1:"N")_" "_$P(DGHOW,"^",2)_DGFRD1 G Q:$G(DGSTOP) D HDR S I=0 "RTN","DGRPCP1",24,0) I '$D(^UTILITY($J,"DGINC")) W !!,"** NO RECORDS MATCH SELECTION CRITERIA **",!! G Q "RTN","DGRPCP1",25,0) F I1=0:0 S I=$O(^UTILITY($J,"DGINC",I)) Q:I="" F I2=0:0 S I2=$O(^UTILITY($J,"DGINC",I,I2)) Q:'I2 G:$G(DGSTOP) Q S X=^(I2) D W "RTN","DGRPCP1",26,0) D TRA G Q "RTN","DGRPCP1",27,0) W S DGCLK=$S(I2=1:$E($S($D(^VA(200,+$P(X,U,5),0)):$S($P(^(0),U,2)]"":$P(^(0),U,2),1:$P(X,U,5)),$P(X,U,5)="":"Missing",1:$P(X,U,5)),1,9),1:"") "RTN","DGRPCP1",28,0) W !,$P(X,"^",1),?33,$P(X,"^",2),?56,$P(X,"^",3),?67,$TR($$FMTE^XLFDT($P(X,"^",4),"5DZ"),"/","-"),?78,DGCLK,?$S($E($P(X,"^",6))="*":87,1:89),$P(X,"^",6) I $Y>40 D TRA I $$SUBSEQ^DGUTL S DGSTOP=1 D HDR "RTN","DGRPCP1",29,0) Q "RTN","DGRPCP1",30,0) HDR Q:$G(DGSTOP) S DGPG=DGPG+1,X=$S($D(IOM):(IOM-13),1:119) W !,DGHDR,", PAGE ",DGPG,?X,Y,!?67,"Last Day",?78,"Last",!,"Patient Name",?33,"Home Phone #",?56,"Soc Sec #",?67,"ID'ed",?78,"Edited by",?89,"Inconsistent/Missing Data Elements" "RTN","DGRPCP1",31,0) S X1="",$P(X1,"=",131)="" W !,X1,! Q "RTN","DGRPCP1",32,0) TRA S DGCT=0,X1="",$P(X1,"*",131)="" X "F DGZ=$Y:1:$S($D(IOSL):(IOSL-25),1:41) W !" "RTN","DGRPCP1",33,0) W !,X1,!,"An inconsistent Data element preceded by '**' prevents a Z07 record from being sent to the HEC.",! "RTN","DGRPCP1",34,0) Q "RTN","DGRPCP1",35,0) SET S DGDFN=^DPT(DFN,0),DGSSN=$P(DGDFN,"^",9),DGSTORE=$S(DGHOW1="N":$S($P(DGDFN,"^",1)]"":$P(DGDFN,"^",1),1:"UNIDENTIFIED PATIENT #"_DFN),1:" "_$E(DGSSN,8,9)_$E(DGSSN,6,7)_$E(DGSSN,4,5)_$E(DGSSN,1,3)),DGINC="",DGLOOP=0 "RTN","DGRPCP1",36,0) F J=0:0 S J=$O(^DGIN(38.5,DFN,"I",J)) Q:'J D "RTN","DGRPCP1",37,0) . Q:'$D(^DGIN(38.6,J)) "RTN","DGRPCP1",38,0) . ; only print the records requested by the user "RTN","DGRPCP1",39,0) . S DG6=$P(^DGIN(38.6,J,0),"^",6) I DG6'=1 S DG6=0 "RTN","DGRPCP1",40,0) . S DGFILT=$G(DGFILT),DGCHK=$S(DGFILT="R":0,DGFILT="Z":1,1:DG6) "RTN","DGRPCP1",41,0) . Q:DGCHK'=DG6 "RTN","DGRPCP1",42,0) . ;S DGTEXT=$J(J,3)_" "_$P(^DGIN(38.6,J,0),"^",1) I DG6 S DGTEXT="**"_DGTEXT "RTN","DGRPCP1",43,0) . S DGTEXT=$P(^DGIN(38.6,J,0),"^",1) I DG6 S DGTEXT="**"_DGTEXT "RTN","DGRPCP1",44,0) . ; set up variables "RTN","DGRPCP1",45,0) . S DGLOOP=DGLOOP+1 "RTN","DGRPCP1",46,0) . S DGCLK1=$S($P(DGDATA,U,5):$P(DGDATA,U,5),1:$P(DGDATA,U,3)) "RTN","DGRPCP1",47,0) . S DGPHONE=$P($G(^DPT(DFN,.13)),U,1) "RTN","DGRPCP1",48,0) . ; print full first record, abbreviated subsequent records "RTN","DGRPCP1",49,0) . I DGLOOP=1 S ^UTILITY($J,"DGINC",DGSTORE,DGLOOP)=$S($P(DGDFN,"^",1)]"":$P(DGDFN,"^",1),1:"UNIDENTIFIED PATIENT #"_DFN)_"^"_DGPHONE_"^"_$P(DGDFN,"^",9)_"^"_$P(DGDATA,"^",4)_"^"_DGCLK1_U_DGTEXT Q "RTN","DGRPCP1",50,0) . S ^UTILITY($J,"DGINC",DGSTORE,DGLOOP)=""_"^"_""_"^"_""_"^"_""_"^"_""_U_DGTEXT "RTN","DGRPCP1",51,0) K J,DGINC,DGSSN,DGDFN,DGLOOP,DGSTORE,DG6,DGCHK,DGTEXT "RTN","DGRPCP1",52,0) Q "RTN","DGRPCP1",53,0) ; "RTN","DGRPCP1",54,0) Q K %,%DT,DGCLK,DGCLK1,DGFRD,DGHOW,DGHOW1,DGTOD,DGVAR,I,J,X,Y,Z,DGCT,DGCONRUN,DGDATA,DGDFN,DGEDCN,DGER,DGFRD1,DGHDR,DGINC,DGOFF,DGPG,DGPGM,DGSSN,DGSTORE,DGTOD1,DGZ,I1,I2,X1,^UTILITY($J,"DGINC"),DGSTOP,ZTSTOP,DGPHONE "RTN","DGRPCP1",55,0) D ENDREP^DGUTL,CLOSE^DGUTQ Q "RTN","DGRPCR") 0^74^B15602283 "RTN","DGRPCR",1,0) DGRPCR ;ALB/MRL,BAJ - CONSISTENCY FLAGGER, REBUILD FILE ; NOV 16, 2005 "RTN","DGRPCR",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGRPCR",3,0) S U="^" D DT^DICRW F I=1:1 S J=$P($T(T+I),";;",2) Q:J']"" W !,J "RTN","DGRPCR",4,0) D ^DGRPCS G Q:DGCONRUN S Y=$S($D(^DG(43,1,"CON")):$P(^("CON"),"^",4),1:"") I +Y X ^DD("DD") W !!,"LAST RUN COMPLETED: ",Y "RTN","DGRPCR",5,0) K W !!,"Do you want to delete the existing entries and rebuild the file" S %=2 D YN^DICN G Q:%=-1 I % S DGKILL=$S(%=1:1,1:0) "RTN","DGRPCR",6,0) I '% W !!?4,"Y - If you want to remove all existing entries from the INCONSISTENT DATA",!?9,"file and rebuild from scratch.",!?5,"N - If you just want to add newly identified inconsistencies to the",!?9,"existing file." G K "RTN","DGRPCR",7,0) D W !! S %DT="EA",%DT(0)=-DT,%DT("A")="Rebuild for patients seen since what date: " D ^%DT G Q:Y'>0 S DGDAT=Y,X1=DT,X2=DGDAT D ^%DTC S DGDAY=+X "RTN","DGRPCR",8,0) I DGDAT=DT W !!?4,"SELECT A DATE IN THE PAST PLEASE!!",*7 G D "RTN","DGRPCR",9,0) OK K %DT W !!,"I'm going to check all patients who were admitted or registered on or after " S Y=DGDAT X ^DD("DD") W !,Y," [Within the Past ",+DGDAY," day",$S(+DGDAY>1:"s",1:""),"]." "RTN","DGRPCR",10,0) W !,"I will ",$S(DGKILL:"DELETE all existing entries prior to rebuilding",1:"add any new inconsistent data elements to the existing file"),"." "RTN","DGRPCR",11,0) W !!,"Is this correct" S %=2 D YN^DICN G Q:%=2!(%=-1) I '% W !!?4,"Y - If this is what you want to do.",!?4,"N - If you wish to STOP processing and reconsider this action." G OK "RTN","DGRPCR",12,0) S ION="",DGPGM="S^DGRPCR",DGVAR="DUZ^DGDAT^DGKILL" D QUE^DGUTQ "RTN","DGRPCR",13,0) Q K %,%DT,DFN,DGCONRUN,DGDAT,DGDAY,DGDD,DGDD1,DGEDCN,DGTIME,DGKILL,DGPGM,DGVAR,I,J,X,X1,X2,Y,^UTILITY($J,"DGINCP"),PASS D CLOSE^DGUTQ Q "RTN","DGRPCR",14,0) S D H^DGUTL S $P(^DG(43,1,"CON"),"^",3)=DGTIME K ^UTILITY($J,"DGINCP") "RTN","DGRPCR",15,0) I DGKILL K ^DGIN(38.5) S ^DGIN(38.5,0)="INCONSISTENT DATA^38.5P^^0" "RTN","DGRPCR",16,0) ; DG*5.3*653 BAJ Added call to Z07 Consistency Checks "RTN","DGRPCR",17,0) F DGDD=DGDAT:0 S DGDD=$O(^DPT("ADIS",DGDD)) Q:'DGDD F DFN=0:0 S DFN=$O(^DPT("ADIS",DGDD,DFN)) Q:'DFN D "RTN","DGRPCR",18,0) . I '$D(^UTILITY($J,"DGINCP",DFN)) S ^UTILITY($J,"DGINCP",DFN)="" D EN^DGRPC S PASS=$$EN^IVMZ07C(DFN) "RTN","DGRPCR",19,0) F DGDD=DGDAT:0 S DGDD=$O(^DGPM("ATT1",DGDD)) Q:'DGDD F DGDD1=0:0 S DGDD1=$O(^DGPM("ATT1",DGDD,DGDD1)) Q:'DGDD1 D "RTN","DGRPCR",20,0) . I $D(^DGPM(+DGDD1,0)) S DFN=$P(^(0),"^",3) I '$D(^UTILITY($J,"DGINCP",DFN)) S ^UTILITY($J,"DGINCP",DFN)="" D EN^DGRPC S PASS=$$EN^IVMZ07C(DFN) "RTN","DGRPCR",21,0) D H^DGUTL S $P(^DG(43,1,"CON"),"^",4)=DGTIME G Q "RTN","DGRPCR",22,0) T ; "RTN","DGRPCR",23,0) ;;This routine is used to build the INCONSISTENT DATA file. I will ask you to "RTN","DGRPCR",24,0) ;;enter a date and will check all patients who were admitted or were registered "RTN","DGRPCR",25,0) ;;on or after that date for inconsistencies. If any exist I will add "RTN","DGRPCR",26,0) ;;those patients to the INCONSISTENT DATA file for further editing of those "RTN","DGRPCR",27,0) ;;inconsistencies. You will also be asked if you wish to delete all the existing "RTN","DGRPCR",28,0) ;;entries and rebuild the file. If you answer YES I will kill off all entries "RTN","DGRPCR",29,0) ;;which are currently in the file and then rebuild based on the date you entered. "RTN","DGRPCR",30,0) ;;If you answer NO I will simply add the new entries I find to the existing file. "RTN","DGRPCTRG") 0^77^B902330 "RTN","DGRPCTRG",1,0) DGRPCTRG ;ALB/BAJ - CONFIDENTIAL ADDRESS TRIGGER AXEE141 ;May 17, 2006 "RTN","DGRPCTRG",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGRPCTRG",3,0) ;;**653 BAJ May 1,2006 Modifications to Confidential address to support functionality moved "RTN","DGRPCTRG",4,0) ;;from EVC Release 2 to EVC Release 1 "RTN","DGRPCTRG",5,0) Q "RTN","DGRPCTRG",6,0) EECHG ; entry point "RTN","DGRPCTRG",7,0) ; this tag is called by a trigger in the CONFIDENTIAL ADDRESS CATEGORY FIELD (#2.141) "RTN","DGRPCTRG",8,0) ; If the ELIGIBILITY/ENROLLMENT Category has been added, changed, or deleted, X will equal 1 "RTN","DGRPCTRG",9,0) ; A Z07 must be sent anytime the E/E Category is modified on a confidential address "RTN","DGRPCTRG",10,0) Q:'$G(DFN) "RTN","DGRPCTRG",11,0) I X=1 D EVENT^IVMPLOG(DFN) "RTN","DGRPCTRG",12,0) Q "RTN","DGRPCTRG",13,0) EECONF(DFN) ; used to identify E/E Confidential Category "RTN","DGRPCTRG",14,0) ; This tag is called by all Confidential Address fields and files a Z07 message if true: "RTN","DGRPCTRG",15,0) ; I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG "RTN","DGRPCTRG",16,0) ; "RTN","DGRPCTRG",17,0) ; if there is no active E/E Category on file for this Confidential Address, return 0 "RTN","DGRPCTRG",18,0) N ISEE,ACT "RTN","DGRPCTRG",19,0) S ISEE=0 "RTN","DGRPCTRG",20,0) I '$G(DFN) Q ISEE "RTN","DGRPCTRG",21,0) I '$D(^DPT(DFN,.14,"B",1)) Q ISEE "RTN","DGRPCTRG",22,0) S ACT=+$O(^DPT(DFN,.14,"B",1,"")) "RTN","DGRPCTRG",23,0) S ISEE=$P(^DPT(DFN,.14,ACT,0),U,2)="Y" "RTN","DGRPCTRG",24,0) Q ISEE "RTN","DGRPCTRG",25,0) ; "RTN","DGRPCU") 0^73^B8938902 "RTN","DGRPCU",1,0) DGRPCU ;ALB/MRL,BAJ - CONSISTENCY FLAGGER, CHECK EXISTING ; NOV 18, 2005 "RTN","DGRPCU",2,0) ;;5.3;Registration;**653**;Aug 13, 1993;Build 2 "RTN","DGRPCU",3,0) S U="^" D DT^DICRW F I=1:1 S J=$P($T(T+I),";;",2) Q:J']"" W !,J "RTN","DGRPCU",4,0) D ^DGRPCS G Q:DGCONRUN S Y=$S($D(^DG(43,1,"CON")):$P(^("CON"),"^",6),1:"") I +Y X ^DD("DD") W !!,"LAST RUN COMPLETED: ",Y "RTN","DGRPCU",5,0) OK W !!,"Do you really want to update existing inconsistent entries" S %=2 D YN^DICN G Q:%=2!(%=-1) "RTN","DGRPCU",6,0) I '% W !!?4,"Y - If you want me to run through all the entries currently filed in",!?9,"the INCONSISTENT DATA file and verify they're still inconsistent.",!?4,"N - If you wish to QUIT and rethink this action." G OK "RTN","DGRPCU",7,0) S ION="",DGPGM="ST^DGRPCU",DGVAR="DUZ" D QUE^DGUTQ S IOP="HOME" D ^%ZIS K IOP "RTN","DGRPCU",8,0) Q K DFN,DGCONRUN,DGPGM,DGTIME,DGVAR,I,J,Y,%,%Y,PASS D CLOSE^DGUTQ Q "RTN","DGRPCU",9,0) ; DG*5.3*653 BAJ Added call to Z07 Consistency checker "RTN","DGRPCU",10,0) ST D H^DGUTL S $P(^DG(43,1,"CON"),"^",5)=DGTIME F DFN=0:0 S DFN=$O(^DGIN(38.5,DFN)) Q:'DFN D EN^DGRPC S PASS=$$EN^IVMZ07C(DFN) "RTN","DGRPCU",11,0) D H^DGUTL S $P(^DG(43,1,"CON"),"^",6)=DGTIME G Q "RTN","DGRPCU",12,0) T ; "RTN","DGRPCU",13,0) ;;This option is designed to loop through the existing entries in the INCONSISTENT "RTN","DGRPCU",14,0) ;;DATA file and verify that all elements are still inconsistent. This function "RTN","DGRPCU",15,0) ;;is necessary because some data may get updated by means where the consistency "RTN","DGRPCU",16,0) ;;checker isn't automatically run, i.e., VA FileMan. If you wish to in fact run "RTN","DGRPCU",17,0) ;;this option simply respond YES when asked and enter the DATE/TIME you wish the "RTN","DGRPCU",18,0) ;;option to commence running. "RTN","DGRPCU",19,0) ; "RTN","DGRPCU",20,0) ; "RTN","DGRPCU",21,0) UPD ;update file 38.5 - called from DG CONSISTENCY CHECK option "RTN","DGRPCU",22,0) D ON^DGRPC G KVAR^DGRPCE:DGER W !! S DGEDIT=1,DIC="^DGIN(38.6,",DIC(0)="AEQMZ",DIC("S")="I Y'=21" D ^DIC G KVAR^DGRPCE:Y'>0 S DGD=+Y "RTN","DGRPCU",23,0) S DGL="",$P(DGL,"=",80)="" W !,DGL F I=0:0 S I=$O(^DGIN(38.6,+DGD,"D",I)) Q:'I W !,^(I,0) "RTN","DGRPCU",24,0) I "^2^9^10^13^14^22^51^52^53^"[("^"_DGD_"^") W !!,*7,"This check can not be edited. It is automatically turned ",$S(DGD=2:"OFF",DGD=51:"OFF",1:"ON"),"!",!,DGL G UPDQ "RTN","DGRPCU",25,0) W !,DGL S (DA,Y)=DGD,DIE=DIC,DR="5;" K DG,DQ D ^DIE "RTN","DGRPCU",26,0) UPDQ K DA,DGD,DGEDIT,DGER,DGL,DR,DIC,DIE,I,X,Y "RTN","DGRPCU",27,0) G UPD "RTN","DGRPECE") 0^66^B62016325 "RTN","DGRPECE",1,0) DGRPECE ;ALB/MRY,ERC - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 2:35pm "RTN","DGRPECE",2,0) ;;5.3;Registration;**638,682,700,720,653**;Aug 13, 1993;Build 2 "RTN","DGRPECE",3,0) ; "RTN","DGRPECE",4,0) CEDITS(DFN) ;catastrophic edits - buffer values, save after check "RTN","DGRPECE",5,0) ;Input; "RTN","DGRPECE",6,0) ; DFN := patient ien "RTN","DGRPECE",7,0) ;Catastrophic edits will prompt for name, ssn, dob, and sex. Placing "RTN","DGRPECE",8,0) ;responses into a buffer space. User will be alerted on catastrophic "RTN","DGRPECE",9,0) ;edits on the following conditions: "RTN","DGRPECE",10,0) ; 1. Two or more catastrophic edits will generate a warning message. "RTN","DGRPECE",11,0) ; 2. Acceptance of two or more catastrophic edits will generate an alert "RTN","DGRPECE",12,0) ; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key. "RTN","DGRPECE",13,0) ; 3. Acceptance of <2 catastrophic edits will process normally. "RTN","DGRPECE",14,0) ; "RTN","DGRPECE",15,0) ; Arrays: BEFORE - Holds patient values before the edit process "RTN","DGRPECE",16,0) ; (before snapshot). "RTN","DGRPECE",17,0) ; BUFFER - initialized with BEFORE array, holds edited changes "RTN","DGRPECE",18,0) ; (after snapshot). "RTN","DGRPECE",19,0) ; SAVE - holds only edited changes for filing into file #2. "RTN","DGRPECE",20,0) ; "RTN","DGRPECE",21,0) N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN "RTN","DGRPECE",22,0) D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values "RTN","DGRPECE",23,0) ;buffer - get name "RTN","DGRPECE",24,0) K DG20NAME "RTN","DGRPECE",25,0) S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME) "RTN","DGRPECE",26,0) I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME") "RTN","DGRPECE",27,0) I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY") "RTN","DGRPECE",28,0) I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN") "RTN","DGRPECE",29,0) I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE") "RTN","DGRPECE",30,0) I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX") "RTN","DGRPECE",31,0) ; the formal name is last name, first name, middle name and suffix "RTN","DGRPECE",32,0) ; the prefix and degree are only stored in file 20 "RTN","DGRPECE",33,0) I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX") "RTN","DGRPECE",34,0) I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE") "RTN","DGRPECE",35,0) K DG20NAME "RTN","DGRPECE",36,0) ;buffer - get ssn "RTN","DGRPECE",37,0) S DIR(0)="2,.09^^" "RTN","DGRPECE",38,0) S DA=DFN D ^DIR "RTN","DGRPECE",39,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",40,0) S BUFFER("SSN")=Y "RTN","DGRPECE",41,0) ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC "RTN","DGRPECE",42,0) I $G(BUFFER("SSN"))["P" D I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",43,0) REAS . ; "RTN","DGRPECE",44,0) . N DGREA,DGQSSN,DIR "RTN","DGRPECE",45,0) . S DGQSSN=0 "RTN","DGRPECE",46,0) . S DGREA=$P($G(^DPT(DFN,"SSN")),U) "RTN","DGRPECE",47,0) . S DIR(0)="2,.0906^^" "RTN","DGRPECE",48,0) . S DA=DFN "RTN","DGRPECE",49,0) . D ^DIR "RTN","DGRPECE",50,0) . I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D "RTN","DGRPECE",51,0) . . W !?10,"PSSN Reason Required if SSN is a Pseudo." "RTN","DGRPECE",52,0) . . I $G(BEFORE("SSN"))["P" G REAS "RTN","DGRPECE",53,0) . . I $G(BEFORE("SSN"))']"" G REAS "RTN","DGRPECE",54,0) . . S DIR(0)="YA",DIR("A")=" Delete Pseudo SSN?: ",DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason.",DIR("B")="YES" "RTN","DGRPECE",55,0) . . D ^DIR "RTN","DGRPECE",56,0) . . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q "RTN","DGRPECE",57,0) . . G REAS "RTN","DGRPECE",58,0) . I DGQSSN=1 Q "RTN","DGRPECE",59,0) . S BUFFER("SSNREAS")=Y "RTN","DGRPECE",60,0) . I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q "RTN","DGRPECE",61,0) DOB ;buffer - get dob "RTN","DGRPECE",62,0) S DIR(0)="2,.03^^" "RTN","DGRPECE",63,0) S DA=DFN D ^DIR "RTN","DGRPECE",64,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",65,0) S BUFFER("DOB")=Y "RTN","DGRPECE",66,0) SEX ;buffer - get sex "RTN","DGRPECE",67,0) S DIR(0)="2,.02^^" "RTN","DGRPECE",68,0) S DA=DFN D ^DIR "RTN","DGRPECE",69,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",70,0) S BUFFER("SEX")=Y "RTN","DGRPECE",71,0) MBI ; buffer - get MBI (multiple birth indicator) "RTN","DGRPECE",72,0) S DIR(0)="2,994^^" "RTN","DGRPECE",73,0) S DA=DFN D ^DIR "RTN","DGRPECE",74,0) S BUFFER("MBI")=Y "RTN","DGRPECE",75,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",76,0) CECHECK ;do catastrophic edit checks, alert, and save "RTN","DGRPECE",77,0) N DGCNT,DGCEFLG "RTN","DGRPECE",78,0) ;Compare before/buffer arrays, putting edits into save array. "RTN","DGRPECE",79,0) S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE) "RTN","DGRPECE",80,0) ; DGCNT: 0 = no changes "RTN","DGRPECE",81,0) ; 1 = only one edit change, ok to save w/o CE message "RTN","DGRPECE",82,0) ; >1 = more then 1 edit, give CE message "RTN","DGRPECE",83,0) I DGCNT>1 D ;give CE message "RTN","DGRPECE",84,0) . S DGCEFLG=$$WARNING() "RTN","DGRPECE",85,0) . ; DGCEFLG: 0 = exit without saving changes "RTN","DGRPECE",86,0) . ; 1 = send alert and save "RTN","DGRPECE",87,0) . I DGCEFLG=0 S DGCNT=0 "RTN","DGRPECE",88,0) I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT "RTN","DGRPECE",89,0) Q "RTN","DGRPECE",90,0) ; "RTN","DGRPECE",91,0) SAVE(DFN) ;store accepted/edited values into patient file "RTN","DGRPECE",92,0) N FDATA,DIERR "RTN","DGRPECE",93,0) I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME") "RTN","DGRPECE",94,0) I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB") "RTN","DGRPECE",95,0) I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX") "RTN","DGRPECE",96,0) I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN") "RTN","DGRPECE",97,0) I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS") "RTN","DGRPECE",98,0) I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI") "RTN","DGRPECE",99,0) D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",100,0) K FDATA,DIERR "RTN","DGRPECE",101,0) I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") "RTN","DGRPECE",102,0) I $D(SAVE("NAME")) D "RTN","DGRPECE",103,0) .S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY") "RTN","DGRPECE",104,0) .S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN") "RTN","DGRPECE",105,0) .S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE") "RTN","DGRPECE",106,0) .S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX") "RTN","DGRPECE",107,0) .D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",108,0) .K FDATA,DIERR "RTN","DGRPECE",109,0) I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX") "RTN","DGRPECE",110,0) I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE") "RTN","DGRPECE",111,0) I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX") "RTN","DGRPECE",112,0) I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE") "RTN","DGRPECE",113,0) D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",114,0) K FDATA,DIERR "RTN","DGRPECE",115,0) Q "RTN","DGRPECE",116,0) ; "RTN","DGRPECE",117,0) BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree "RTN","DGRPECE",118,0) N DG20 "RTN","DGRPECE",119,0) S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME") "RTN","DGRPECE",120,0) S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN") "RTN","DGRPECE",121,0) S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS") "RTN","DGRPECE",122,0) S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB") "RTN","DGRPECE",123,0) S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX") "RTN","DGRPECE",124,0) S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI") "RTN","DGRPECE",125,0) D GETS^DIQ(2,+IEN_",",1.01,"I","DG20") "RTN","DGRPECE",126,0) S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")="" "RTN","DGRPECE",127,0) S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")="" "RTN","DGRPECE",128,0) S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")="" "RTN","DGRPECE",129,0) S DG20IEN=DG20(2,+IEN_",",1.01,"I") "RTN","DGRPECE",130,0) I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D "RTN","DGRPECE",131,0) . S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY") "RTN","DGRPECE",132,0) . S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN") "RTN","DGRPECE",133,0) . S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE") "RTN","DGRPECE",134,0) . S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX") "RTN","DGRPECE",135,0) . S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX") "RTN","DGRPECE",136,0) . S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE") "RTN","DGRPECE",137,0) ;add some demographic information (before snapshot) "RTN","DGRPECE",138,0) S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17) "RTN","DGRPECE",139,0) S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15) "RTN","DGRPECE",140,0) S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I") "RTN","DGRPECE",141,0) Q "RTN","DGRPECE",142,0) ; "RTN","DGRPECE",143,0) AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks "RTN","DGRPECE",144,0) N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0 "RTN","DGRPECE",145,0) I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D "RTN","DGRPECE",146,0) . S DG20CNT=DG20CNT+1 "RTN","DGRPECE",147,0) . S SAV("NAME")=BUF("NAME") "RTN","DGRPECE",148,0) I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D "RTN","DGRPECE",149,0) . S DG20CNT=DG20CNT+1 "RTN","DGRPECE",150,0) . S SAV("NAME")=BUF("NAME") "RTN","DGRPECE",151,0) I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D "RTN","DGRPECE",152,0) . S SAV("NAME")=BUF("NAME") ; minor change doesn't count "RTN","DGRPECE",153,0) I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D "RTN","DGRPECE",154,0) . S SAV("NAME")=BUF("NAME") ; minor change doesn't count "RTN","DGRPECE",155,0) I DG20CNT>0 S DGCNT=1 "RTN","DGRPECE",156,0) I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D "RTN","DGRPECE",157,0) . S SAV("PREFIX")=BUF("PREFIX") "RTN","DGRPECE",158,0) I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D "RTN","DGRPECE",159,0) . S SAV("DEGREE")=BUF("DEGREE") "RTN","DGRPECE",160,0) I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D "RTN","DGRPECE",161,0) . S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1 "RTN","DGRPECE",162,0) I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D "RTN","DGRPECE",163,0) . S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1 "RTN","DGRPECE",164,0) I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D "RTN","DGRPECE",165,0) . S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1 "RTN","DGRPECE",166,0) I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D "RTN","DGRPECE",167,0) . S SAV("SSNREAS")=BUF("SSNREAS"),DGCNT=DGCNT+1 "RTN","DGRPECE",168,0) I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D "RTN","DGRPECE",169,0) . S SAV("MBI")=BUF("MBI") "RTN","DGRPECE",170,0) I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix) "RTN","DGRPECE",171,0) I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change "RTN","DGRPECE",172,0) I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change "RTN","DGRPECE",173,0) I DGCNT=0 Q 0 ;no changes "RTN","DGRPECE",174,0) I DGCNT<2 Q 1 ;make one change w/o CE message "RTN","DGRPECE",175,0) I DGCNT>1 Q 2 ;more than 1 change, send CE message "RTN","DGRPECE",176,0) ; "RTN","DGRPECE",177,0) WARNING() ;CE warning message "RTN","DGRPECE",178,0) ;Output 0 = exit without saving changes "RTN","DGRPECE",179,0) ; 1 = send alert and save "RTN","DGRPECE",180,0) W !!,?25,"**WARNING!!**" "RTN","DGRPECE",181,0) W !!,"The edits you are about to make, may potentially change the identity of" "RTN","DGRPECE",182,0) W !,"this patient. Please verify that you have selected the correct patient" "RTN","DGRPECE",183,0) W !,"and ensure that supporting documentation exists for these changes. If" "RTN","DGRPECE",184,0) W !,"you continue with these edits, an alert will be generated and sent to" "RTN","DGRPECE",185,0) W !,"your Supervisor and ADPAC, notifying them of the changes." "RTN","DGRPECE",186,0) N DIR,DGANS,Y "RTN","DGRPECE",187,0) S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:" "RTN","DGRPECE",188,0) S DIR("B")="NO" D ^DIR K DIR S DGANS=Y "RTN","DGRPECE",189,0) S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert "RTN","DGRPECE",190,0) Q DGANS "RTN","DGRPECE",191,0) ; "RTN","DGRPECE",192,0) ALERT ;Queue alert "RTN","DGRPECE",193,0) X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN "RTN","DGRPECE",194,0) F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)="" "RTN","DGRPECE",195,0) S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD Q "RTN","DGRPECE",196,0) ;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE) "RTN","DGRPECE",197,0) Q "RTN","DGRPEIS") 0^67^B41614327 "RTN","DGRPEIS",1,0) DGRPEIS ;ALB/MIR,ERC - INCOME SCREENING DATA FOR EDIT ; 1/3/06 9:33am "RTN","DGRPEIS",2,0) ;;5.3;Registration;**10,45,108,624,653**;Aug 13, 1993;Build 2 "RTN","DGRPEIS",3,0) ; Handles editing of dependent info "RTN","DGRPEIS",4,0) ; CHANGES TO THIS ROUTINE SHOULD BE COORDINATED WITH THE MEANS TEST "RTN","DGRPEIS",5,0) ; DEVELOPER. MANY CALLS IN THIS ROUTINE (ADD, EDIT, INACT, ETC.) ARE "RTN","DGRPEIS",6,0) ; CALLED FROM MEANS TEST OR ARE MIMICKED THERE. "RTN","DGRPEIS",7,0) ; In: DFN as IEN of PATIENT file "RTN","DGRPEIS",8,0) ; DGDR as string of items selected for editing "RTN","DGRPEIS",9,0) ;Out: DGFL as -2 if time-out, -1 if up-arrow "RTN","DGRPEIS",10,0) EN S DGFL=0 "RTN","DGRPEIS",11,0) S DGISDT=$$LYR^DGMTSCU1(DT) "RTN","DGRPEIS",12,0) S DGRP(0)=$G(^DPT(DFN,0)) D NEW^DGRPEIS1,GETREL^DGMTU11(DFN,"VSD",DGISDT) "RTN","DGRPEIS",13,0) I DGDR[801 D SPOUSE^DGRPEIS2 S DGPREF=$G(DGREL("S")) G Q:DGFL I DGSPFL D:DGPREF EDIT(DGPREF,"S") I 'DGPREF D ADD(DFN,"S") "RTN","DGRPEIS",14,0) K DGSPFL,DGPREF "RTN","DGRPEIS",15,0) Q Q "RTN","DGRPEIS",16,0) ; "RTN","DGRPEIS",17,0) ADD(DFN,DGTYPE,DGTSTDT) ; subroutine to add to files 408.12 & 408.13 "RTN","DGRPEIS",18,0) ; In -- DFN as the IEN of file 2 for the vet "RTN","DGRPEIS",19,0) ; DGTYPE as C for mt children or D for all deps "RTN","DGRPEIS",20,0) ; S for spouse (default spouse) "RTN","DGRPEIS",21,0) ; DGTSTDT - optional test date "RTN","DGRPEIS",22,0) ;Out -- DGPRI as patient relation IEN "RTN","DGRPEIS",23,0) ; DGIPI as income person IEN "RTN","DGRPEIS",24,0) ; DGFL as -2 if time-out, -1 if '^', 0 otherwise "RTN","DGRPEIS",25,0) N ANS,DA,PROMPT,SPOUSE,TYPE,DGVADD,DGSKIPST,DGSADD,DGIPIEN,DGUQTLP "RTN","DGRPEIS",26,0) I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT) "RTN","DGRPEIS",27,0) S DGFL=$G(DGFL) "RTN","DGRPEIS",28,0) S DGTYPE=$G(DGTYPE),SPOUSE=$S(DGTYPE']"":1,DGTYPE="C":0,DGTYPE="D":0,1:1) "RTN","DGRPEIS",29,0) S DGFL=$G(DGFL),PROMPT="NAME^SEX^DATE OF BIRTH^^^^^^SSN^PS SSN REASON^MAIDEN NAME^STREET ADDRESS [LINE 1]^STREET ADDRESS [LINE 2]^STREET ADDRESS [LINE 3]^CITY^STATE^ZIP^PHONE NUMBER" "RTN","DGRPEIS",30,0) S TYPE=$S(SPOUSE:"SPOUSE'S ",DGTYPE="C":"CHILD'S ",1:"DEPENDENT'S ") "RTN","DGRPEIS",31,0) S DGSKIPST=0 ;* Skip Add 2 and 3 prompts when Add 1 or 2 not entered "RTN","DGRPEIS",32,0) S DGUQTLP=0 "RTN","DGRPEIS",33,0) F DGRPI=.01:.01:.03,.09,.1,1.1:.1:1.8 D Q:DGVADD Q:DGSADD Q:DGUQTLP I DGFL Q "RTN","DGRPEIS",34,0) . S (DGSADD,DGVADD,DGIPIEN)=0 "RTN","DGRPEIS",35,0) . ; Is spouse/dependent address same as patient address? "RTN","DGRPEIS",36,0) . I +DGRPI=1.2 DO "RTN","DGRPEIS",37,0) . . K DIR "RTN","DGRPEIS",38,0) . . S DIR(0)="YAO^^" "RTN","DGRPEIS",39,0) . . S DIR("A")=TYPE_"STREET ADDRESS SAME AS PATIENT'S: " "RTN","DGRPEIS",40,0) . . S DIR("B")="YES" "RTN","DGRPEIS",41,0) . . S:TYPE'="SPOUSE'S " DIR("?")="Enter 'Y' if the child/dependent has the same address and phone number as the patient, otherwise enter 'N'." "RTN","DGRPEIS",42,0) . . S:TYPE="SPOUSE'S " DIR("?")="Enter 'Y' if the spouse has the same address and phone number as the patient, otherwise enter 'N'." "RTN","DGRPEIS",43,0) . . D ^DIR "RTN","DGRPEIS",44,0) . . S DGVADD=+Y "RTN","DGRPEIS",45,0) . . K Y,DIR "RTN","DGRPEIS",46,0) . . S DGIPIEN=$$SPSCHK(DFN) "RTN","DGRPEIS",47,0) . . I 'DGVADD,(TYPE'="SPOUSE'S"),(DGIPIEN) DO "RTN","DGRPEIS",48,0) . . . K DIR,Y "RTN","DGRPEIS",49,0) . . . S DIR(0)="YAO^^" "RTN","DGRPEIS",50,0) . . . S DIR("A")=TYPE_"STREET ADDRESS SAME AS SPOUSE'S: " "RTN","DGRPEIS",51,0) . . . S DIR("B")="YES" "RTN","DGRPEIS",52,0) . . . S DIR("?")="Enter 'Y' if the child/dependent has the same address as the spouse, otherwise enter 'N'." "RTN","DGRPEIS",53,0) . . . D ^DIR "RTN","DGRPEIS",54,0) . . . S DGSADD=+Y "RTN","DGRPEIS",55,0) . . . K Y,DIR "RTN","DGRPEIS",56,0) . ; "RTN","DGRPEIS",57,0) . ; If spouse/dependent address is same as patient's set spouse/dep add. "RTN","DGRPEIS",58,0) . I DGVADD D PATASET(DFN) ;*Set to Patient address "RTN","DGRPEIS",59,0) . I DGSADD D SPSASET(DGIPIEN) ;*Set to Spouse address "RTN","DGRPEIS",60,0) . ; "RTN","DGRPEIS",61,0) . ; Spouse/dep address is not same as patient/spouse add, prompt add. "RTN","DGRPEIS",62,0) . I 'DGVADD,'DGSADD DO "RTN","DGRPEIS",63,0) . . K DIR S DIR(0)="408.13,"_DGRPI I DGRPI=.01 S DIR(0)=DIR(0)_"O" "RTN","DGRPEIS",64,0) . . I DGRPI=.02,SPOUSE S X=$P($G(^DPT(DFN,0)),"^",2) I X]"" S DIR("B")=$S(X="F":"MALE",1:"FEMALE") ; default spouse sex "RTN","DGRPEIS",65,0) . . S:DGRPI=.03 DIR(0)=DIR(0)_"^^"_"S %DT=""EP"" D ^%DT S X=Y K:($E(DGTSTDT,1,3)-1_1231)1 DIR("A")=TYPE_$P(PROMPT,"^",DGRPI*10) "RTN","DGRPEIS",68,0) . . I (+DGRPI'=1.1)!((+DGRPI=1.1)&(SPOUSE)&($G(ANS(.02))="F")) DO "RTN","DGRPEIS",69,0) . . . ;if .1, check to see if SSN is a pseudo, if yes, require Reason "RTN","DGRPEIS",70,0) . . . I DGRPI=.1 D REAS Q "RTN","DGRPEIS",71,0) . . . I (+DGRPI=1.3)!(+DGRPI=1.4) D:('DGSKIPST) ^DIR "RTN","DGRPEIS",72,0) . . . I (+DGRPI'=1.3)&(+DGRPI'=1.4) D ^DIR "RTN","DGRPEIS",73,0) . . . I $D(DTOUT)!$D(DUOUT) S:(DGRPI=.09)!((DGRPI>1.1)&(DGRPI<1.9)) DGUQTLP=1 "RTN","DGRPEIS",74,0) . . . I $D(DTOUT)!$D(DUOUT) S DGFL=$S($D(DUOUT):$S((DGRPI>1.1)&(DGRPI<1.9):"",1:-1),1:-2) Q "RTN","DGRPEIS",75,0) . . . I DGRPI=.01,(Y']"") S DGFL=-1 Q "RTN","DGRPEIS",76,0) . . . S ANS(DGRPI)=Y "RTN","DGRPEIS",77,0) . . . I (+DGRPI=1.2),(ANS(1.2)']"") S DGSKIPST=1 "RTN","DGRPEIS",78,0) . . . I (+DGRPI=1.3),(ANS(1.3)']"") S DGSKIPST=1 "RTN","DGRPEIS",79,0) . . . I DGRPI=.03,$D(ANS(.03)) S X2=ANS(.03),X1=DT D ^%DTC I 'SPOUSE S AGE=(X/365.25) W ?62,"(AGE: "_$P(AGE,".")_")" I AGE>17 D WRT^DGRPEIS3 "RTN","DGRPEIS",80,0) . . I DGRPI=.01,(Y']"") Q "RTN","DGRPEIS",81,0) I '$D(ANS(.01)) S DGFL=0 G ADDQ "RTN","DGRPEIS",82,0) I DGFL=-2!'$D(ANS(.09)) W !?3,*7,"Incomplete Entry...Deleted" G ADDQ "RTN","DGRPEIS",83,0) S DGRP0ND=ANS(.01)_"^"_ANS(.02)_"^"_ANS(.03)_"^^^^^^"_$G(ANS(.09))_"^"_$G(ANS(.1)) "RTN","DGRPEIS",84,0) S DGRP1ND=$G(ANS(1.1))_"^"_$G(ANS(1.2))_"^"_$G(ANS(1.3))_"^"_$G(ANS(1.4))_"^"_$G(ANS(1.5))_"^"_$P($G(ANS(1.6)),"^",1)_"^"_$G(ANS(1.7))_"^"_$G(ANS(1.8)) "RTN","DGRPEIS",85,0) D NEWIP^DGRPEIS1 "RTN","DGRPEIS",86,0) ADDQ K DGRP0ND,DGRP1ND,DGRPI,DIR,DIRUT,DTOUT,DUOUT "RTN","DGRPEIS",87,0) Q "RTN","DGRPEIS",88,0) ; "RTN","DGRPEIS",89,0) PATASET(DFN) ;* Set the address equal to the patient's "RTN","DGRPEIS",90,0) ; Input: DFN - Patient file IEN and key to Patient Relation entries "RTN","DGRPEIS",91,0) ; Output: ANS array of dependents address "RTN","DGRPEIS",92,0) S ANS(1.2)=$P($G(^DPT(DFN,.11)),"^",1) "RTN","DGRPEIS",93,0) S ANS(1.3)=$P($G(^DPT(DFN,.11)),"^",2) "RTN","DGRPEIS",94,0) S ANS(1.4)=$P($G(^DPT(DFN,.11)),"^",3) "RTN","DGRPEIS",95,0) S ANS(1.5)=$P($G(^DPT(DFN,.11)),"^",4) "RTN","DGRPEIS",96,0) S ANS(1.6)=$P($G(^DPT(DFN,.11)),"^",5) "RTN","DGRPEIS",97,0) S ANS(1.7)=$P($G(^DPT(DFN,.11)),"^",12) "RTN","DGRPEIS",98,0) S ANS(1.8)=$P($G(^DPT(DFN,.13)),"^",1) "RTN","DGRPEIS",99,0) Q "RTN","DGRPEIS",100,0) ; "RTN","DGRPEIS",101,0) SPSCHK(DFN) ;*Check for existence of active spouse "RTN","DGRPEIS",102,0) ; Input: DFN - Patient file IEN and key to Patient Relation entries "RTN","DGRPEIS",103,0) ; Output: IPIEN - Spouse IEN in 408.13 "RTN","DGRPEIS",104,0) ; 0: no active spouse "RTN","DGRPEIS",105,0) N PRIEN,IPIEN,SPREDIEN,SPRED "RTN","DGRPEIS",106,0) S IPIEN=0 "RTN","DGRPEIS",107,0) I $D(^DGPR(408.12,"B",DFN)) DO "RTN","DGRPEIS",108,0) . S PRIEN="" "RTN","DGRPEIS",109,0) . F S PRIEN=$O(^DGPR(408.12,"B",DFN,PRIEN)) Q:(+PRIEN=0) DO "RTN","DGRPEIS",110,0) . . I $D(^DG(408.11,$P(^DGPR(408.12,PRIEN,0),"^",2),0)) DO "RTN","DGRPEIS",111,0) . . . I $P(^DG(408.11,$P(^DGPR(408.12,PRIEN,0),"^",2),0),"^",1)="SPOUSE" DO "RTN","DGRPEIS",112,0) . . . . S SPRED=$O(^DGPR(408.12,PRIEN,"E","AID","")) "RTN","DGRPEIS",113,0) . . . . S:+SPRED'=0 SPREDIEN=$O(^DGPR(408.12,PRIEN,"E","AID",SPRED,"")) "RTN","DGRPEIS",114,0) . . . . I +$P($G(^DGPR(408.12,PRIEN,"E",SPREDIEN,0)),"^",2)=1 S IPIEN=$P($P(^DGPR(408.12,PRIEN,0),"^",3),";",1) "RTN","DGRPEIS",115,0) Q IPIEN "RTN","DGRPEIS",116,0) ; "RTN","DGRPEIS",117,0) SPSASET(IPIEN) ;* Set the address equal to the patient's spouse address "RTN","DGRPEIS",118,0) ; Input: IPIEN - Spouse IEN in 408.13 "RTN","DGRPEIS",119,0) ; Output: ANS array of Childs address "RTN","DGRPEIS",120,0) ; "RTN","DGRPEIS",121,0) S ANS(1.2)=$P($G(^DGPR(408.13,IPIEN,1)),"^",2) "RTN","DGRPEIS",122,0) S ANS(1.3)=$P($G(^DGPR(408.13,IPIEN,1)),"^",3) "RTN","DGRPEIS",123,0) S ANS(1.4)=$P($G(^DGPR(408.13,IPIEN,1)),"^",4) "RTN","DGRPEIS",124,0) S ANS(1.5)=$P($G(^DGPR(408.13,IPIEN,1)),"^",5) "RTN","DGRPEIS",125,0) S ANS(1.6)=$P($G(^DGPR(408.13,IPIEN,1)),"^",6) "RTN","DGRPEIS",126,0) S ANS(1.7)=$P($G(^DGPR(408.13,IPIEN,1)),"^",7) "RTN","DGRPEIS",127,0) S ANS(1.8)=$P($G(^DGPR(408.13,IPIEN,1)),"^",8) "RTN","DGRPEIS",128,0) Q "RTN","DGRPEIS",129,0) ; "RTN","DGRPEIS",130,0) INACT ; prompt to inactivate a patient relation "RTN","DGRPEIS",131,0) ; Input -- DGREL("D") array of dependents "RTN","DGRPEIS",132,0) ; DGDEP as number of deps (from GETREL call) "RTN","DGRPEIS",133,0) N ACT,DGDT,IEN,X "RTN","DGRPEIS",134,0) S DGFL=$G(DGFL) "RTN","DGRPEIS",135,0) I 'DGDEP W !!,"No dependents to inactivate!" Q "RTN","DGRPEIS",136,0) W !!,"Enter a number 1-",DGDEP," to indicate the dependent you wish to inactivate: " R X:DTIME "RTN","DGRPEIS",137,0) I '$T S DGFL=-2 Q "RTN","DGRPEIS",138,0) I X["^" S DGFL=-1 Q "RTN","DGRPEIS",139,0) I X']"" Q "RTN","DGRPEIS",140,0) I X["?" W !!,"Enter a number 1-",DGDEP," indicating the number of the dependent you wish to inactivate" G INACT "RTN","DGRPEIS",141,0) I $D(DGREL("D",X)) S X=DGREL("D",X) D SETUP^DGRPEIS1 Q ; check for IVM dependents "RTN","DGRPEIS",142,0) S X=$G(DGREL("C",X)) I 'X G INACT ; check for MT deps "RTN","DGRPEIS",143,0) D SETUP^DGRPEIS1 "RTN","DGRPEIS",144,0) Q "RTN","DGRPEIS",145,0) EDIT(DGPREF,DGTYPE,DATE) ; edit demographic data for a dep "RTN","DGRPEIS",146,0) ; Input -- DGPREF as returned by GETREL^DGMTU11 for dep to edit "RTN","DGRPEIS",147,0) ; DGTYPE as D if all deps or C if MT children only "RTN","DGRPEIS",148,0) ; S for spouse (optional - spouse if not defined) "RTN","DGRPEIS",149,0) ; DATE [optional] as income screening year/default= last yr "RTN","DGRPEIS",150,0) ; Output -- DGFL as -2 if timeout, -1 if '^', or 0 o/w "RTN","DGRPEIS",151,0) N DOB,DGACT,RELATION,UPARROW,X,Y,DGEDDEP "RTN","DGRPEIS",152,0) D EDIT^DGRPEIS3 "RTN","DGRPEIS",153,0) Q "RTN","DGRPEIS",154,0) REAS ;require a Pseudo SSN Reason if the SSN is a Pseudo - DG*5.3*653 ERC "RTN","DGRPEIS",155,0) Q:ANS(.09)'["P" "RTN","DGRPEIS",156,0) S DIR(0)="408.13,.1^^" "RTN","DGRPEIS",157,0) D ^DIR "RTN","DGRPEIS",158,0) I $D(DUOUT) S DGFL=-2 Q "RTN","DGRPEIS",159,0) I $D(DTOUT)!($D(DIRUT)) W !!,"Pseudo SSN Reason Required if the SSN is Pseudo." G REAS "RTN","DGRPEIS",160,0) ;I $D(DUOUT) S DGFL=-2 Q "RTN","DGRPEIS",161,0) S ANS(.1)=Y "RTN","DGRPEIS",162,0) Q "RTN","DGRPEIS2") 0^68^B15374909 "RTN","DGRPEIS2",1,0) DGRPEIS2 ;ALB/MIR,ERC - EDIT INCOME SCREENING DATA (SCREEN 9) ; 10/6/05 4:33pm "RTN","DGRPEIS2",2,0) ;;5.3;Registration;**10,45,122,653**;Aug 13, 1993;Build 2 "RTN","DGRPEIS2",3,0) ; -Called from DGRPE to edit Scr #9 (Income Screening) "RTN","DGRPEIS2",4,0) EDIT9 ; Allow edit of income screening amounts (called from DGRPE) "RTN","DGRPEIS2",5,0) ; In: DFN "RTN","DGRPEIS2",6,0) ; DGRPANN as string of selected items "RTN","DGRPEIS2",7,0) ; DGRPSEL as allowable groups for edit (V, S, and/or D) "RTN","DGRPEIS2",8,0) ; DGRPSELT (maybe) as type of dependent selected (V=vet, "RTN","DGRPEIS2",9,0) ; S=spouse, and D=dependent). If not defined, it is set "RTN","DGRPEIS2",10,0) ; to DGRPSEL. "RTN","DGRPEIS2",11,0) I 'DGRPANN Q ; if no string passed in (nothing selected) "RTN","DGRPEIS2",12,0) S DGRPSELT=$G(DGRPSELT) I DGRPSELT']"" S DGRPSELT=DGRPSEL ; if no V, S, or D preface, edit all "RTN","DGRPEIS2",13,0) D ALL^DGMTU21(DFN,"VSD",DT,"IP") "RTN","DGRPEIS2",14,0) I '$G(DGREL("V")) D HELP^DGRPEIS3 G EDIT9Q "RTN","DGRPEIS2",15,0) I DGRPSELT["V" S DGPRI=+DGREL("V"),DGMTED=$D(DGMTED("V")) D EDT "RTN","DGRPEIS2",16,0) I '$G(DGRPOUT)&(DGRPSELT["S") S DGPRI=+DGREL("S"),DGMTED=$D(DGMTED("S")) D EDT "RTN","DGRPEIS2",17,0) I '$G(DGRPOUT)&(DGRPSELT["D") F DGCNT=0:0 S DGCNT=$O(DGREL("D",DGCNT)) Q:'DGCNT!($G(DGRPOUT)) S DGPRI=+DGREL("D",DGCNT),DGMTED=$D(DGMTED("D",DGCNT)) D EDT "RTN","DGRPEIS2",18,0) S DGFL=$G(DGFL) "RTN","DGRPEIS2",19,0) K DGCNT "RTN","DGRPEIS2",20,0) EDIT9Q Q "RTN","DGRPEIS2",21,0) ; "RTN","DGRPEIS2",22,0) EDT ;Edit inc and nt worth "RTN","DGRPEIS2",23,0) N DA,DGERR,DGFIN,DGINI,DGIRI,DIE,DR,OK "RTN","DGRPEIS2",24,0) I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT) "RTN","DGRPEIS2",25,0) D GETIENS^DGMTU2(DFN,+DGPRI,DGTSTDT) G EDTQ:DGERR "RTN","DGRPEIS2",26,0) I DGRPSELT]"" W !!,"NAME: ",$$NAME^DGMTU1(DGPRI) "RTN","DGRPEIS2",27,0) I DGMTED W " [Must edit through means test!!]" Q "RTN","DGRPEIS2",28,0) S DA=DGINI,DIE="^DGMT(408.21,",DR="[DGRP ENTER/EDIT ANNUAL INCOME]" D ^DIE S:'$D(DGFIN) DGRPOUT=1 "RTN","DGRPEIS2",29,0) I $D(DTOUT) S DGFL=-2,DGRPOUT=1 Q "RTN","DGRPEIS2",30,0) I 'DGRPOUT S DR="103////^S X=DUZ;104///^S X=""NOW""" D ^DIE "RTN","DGRPEIS2",31,0) I 'DGRPOUT&'$D(DGINC("V")) D GETIENS^DGMTU2(DFN,+DGREL("V"),DT) S DGINC("V")=DGINI G:DGERR EDTQ "RTN","DGRPEIS2",32,0) I 'DGRPOUT&($G(DA)'=$G(DGINC("V"))) S DA=DGINC("V") D ^DIE "RTN","DGRPEIS2",33,0) ; "RTN","DGRPEIS2",34,0) ;log patient for transmission to HEC if DCD criteria are met "RTN","DGRPEIS2",35,0) D LOGDCD^IVMCUC($G(DFN)) "RTN","DGRPEIS2",36,0) ; "RTN","DGRPEIS2",37,0) EDTQ Q "RTN","DGRPEIS2",38,0) ; "RTN","DGRPEIS2",39,0) SPOUSE ; make sure marital status, spouse is up-to-date "RTN","DGRPEIS2",40,0) ; input -- DFN "RTN","DGRPEIS2",41,0) ; DGREL("V") as returned from GETREL for veteran "RTN","DGRPEIS2",42,0) ; used -- DGSPFL as VETS marital status "RTN","DGRPEIS2",43,0) N DGMS "RTN","DGRPEIS2",44,0) D GETIENS^DGMTU2(DFN,+DGREL("V"),DT) "RTN","DGRPEIS2",45,0) S DGMS=$P($G(^DIC(11,+$P($G(^DPT(DFN,0)),"^",5),0)),"^",3),DGMS=$S("^M^S^"[("^"_DGMS_"^"):"YES",DGMS']"":"",1:"NO") "RTN","DGRPEIS2",46,0) D GETREL^DGMTU11(DFN,"S",DT,$G(DGMTI)) I $D(DGREL("S")) S DGMS="YES" "RTN","DGRPEIS2",47,0) ; "RTN","DGRPEIS2",48,0) SPOUSE1 S DIE="^DGMT(408.22,",DA=DGIRI,DR=".05"_$S($G(DGMTI):"///",1:"//")_"^S X=DGMS" D ^DIE K DIE,DA,DR "RTN","DGRPEIS2",49,0) S DGSPFL=$P($G(^DGMT(408.22,DGIRI,0)),"^",5) "RTN","DGRPEIS2",50,0) Q "RTN","DGRPEIS2",51,0) ; "RTN","DGRPEIS2",52,0) ACT ; ask date active as of (use dob if KIDS) "RTN","DGRPEIS2",53,0) ; In: DOB "RTN","DGRPEIS2",54,0) ; DGRP0ND as 0 node of PATIENT RELATION file (relation=piece 2) "RTN","DGRPEIS2",55,0) ;Out: DGACT as date patient should be activated as of "RTN","DGRPEIS2",56,0) ; DGFL as -1 if '^' or -2 if time-out "RTN","DGRPEIS2",57,0) N RELATION,X,Y "RTN","DGRPEIS2",58,0) S DGFL=$G(DGFL),RELATION=$P(DGRP0ND,"^",2) "RTN","DGRPEIS2",59,0) I RELATION=1 S DGACT=DOB Q ;use DOB is self "RTN","DGRPEIS2",60,0) I "^3^4^"[("^"_RELATION_"^") S Y=DOB X ^DD("DD") S DIR("B")=Y ;if son or daughter, use DOB as default "RTN","DGRPEIS2",61,0) ; "RTN","DGRPEIS2",62,0) READ ; get active as of date "RTN","DGRPEIS2",63,0) ; DIR("B") set before entry "RTN","DGRPEIS2",64,0) ; DOB passed in as input "RTN","DGRPEIS2",65,0) N DGDT,DGISDT,DGDTSPEC "RTN","DGRPEIS2",66,0) I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT) "RTN","DGRPEIS2",67,0) S DGDT=$E(DGTSTDT,1,3)-1_"1231",DGISDT=$E(DGDT,1,3)+1700,DGACT=DOB "RTN","DGRPEIS2",68,0) S DGDTSPEC=$S($G(DGEDDEP):":EPX",1:":EP") "RTN","DGRPEIS2",69,0) S DIR(0)="D^"_DOB_":"_DGDT_DGDTSPEC,DIR("A")="EFFECTIVE DATE" "RTN","DGRPEIS2",70,0) S DIR("?")="^D HELP1^DGRPEIS3(DGISDT)" "RTN","DGRPEIS2",71,0) D ^DIR K DIR I Y'>0 S DGFL=$S($D(DTOUT):-2,$D(DUOUT)!$D(DIRUT):-1,1:0) G ACTQ:DGFL,READ "RTN","DGRPEIS2",72,0) S DGACT=Y "RTN","DGRPEIS2",73,0) ACTQ K DIRUT,DTOUT,DUOUT "RTN","DGRPEIS2",74,0) Q "RTN","DGRPEIS2",75,0) RELTYPE(RELIEN,TYPE) ;* Return type of relationship "RTN","DGRPEIS2",76,0) ; "RTN","DGRPEIS2",77,0) ;* INPUT "RTN","DGRPEIS2",78,0) ; RELIEN - IEN from Income Person file (408.13) "RTN","DGRPEIS2",79,0) ; TYPE - 0: Pull specific relationship from Relationship file "RTN","DGRPEIS2",80,0) ; - 1: Just return "spouse", "child", "dependent" "RTN","DGRPEIS2",81,0) ; "RTN","DGRPEIS2",82,0) ;* OUTPUT "RTN","DGRPEIS2",83,0) ; DGPATREL - Relationship value "RTN","DGRPEIS2",84,0) ; "RTN","DGRPEIS2",85,0) N DGPTRLIN,DGRELIEN,DGPATREL "RTN","DGRPEIS2",86,0) S TYPE=+$G(TYPE) "RTN","DGRPEIS2",87,0) I +$G(RELIEN)>0 DO "RTN","DGRPEIS2",88,0) .S DGPTRLIN="" "RTN","DGRPEIS2",89,0) .S DGPTRLIN=$O(^DGPR(408.12,"C",RELIEN_";DGPR(408.13,",DGPTRLIN)) "RTN","DGRPEIS2",90,0) .S DGRELIEN=$P($G(^DGPR(408.12,DGPTRLIN,0)),"^",2) "RTN","DGRPEIS2",91,0) .S DGPATREL=$P($G(^DG(408.11,DGRELIEN,0)),"^",1) "RTN","DGRPEIS2",92,0) .S:DGPATREL']"" DGPATREL="dependent" "RTN","DGRPEIS2",93,0) .I +TYPE=1 S DGPATREL=$S(DGPATREL["SPOUSE":"spouse",($G(DGRPS)=8):"relative",$G(DGSCR8):"relative",1:"child") "RTN","DGRPEIS2",94,0) I +$G(RELIEN)'>0 DO "RTN","DGRPEIS2",95,0) .S:$G(DGANS)="S" DGPATREL="spouse" "RTN","DGRPEIS2",96,0) .S:$G(DGANS)="C" DGPATREL="child" "RTN","DGRPEIS2",97,0) .S:$G(DGANS)="D" DGPATREL="relative" "RTN","DGRPEIS2",98,0) S:DGPATREL="" DGPATREL="relative" "RTN","DGRPEIS2",99,0) Q DGPATREL "RTN","DGRPEIS3") 0^69^B78209595 "RTN","DGRPEIS3",1,0) DGRPEIS3 ;ALB/CAW,EG,ERC - INCOME SCREENING DATA (CON'T) ; 1/3/06 9:03am "RTN","DGRPEIS3",2,0) ;;5.3;Registration;**45,624,659,653**;Aug 13, 1993;Build 2 "RTN","DGRPEIS3",3,0) ; "RTN","DGRPEIS3",4,0) HELP ; Display information when veteran's DOB is past the income year "RTN","DGRPEIS3",5,0) ; "RTN","DGRPEIS3",6,0) W !!,"Please return to screen 8 and check the veteran's effective date." "RTN","DGRPEIS3",7,0) W !,"The effective date was created based on the veteran's date of birth." "RTN","DGRPEIS3",8,0) W !,"You might also want to check the date of birth for this veteran." "RTN","DGRPEIS3",9,0) W ! S DIR(0)="E" D ^DIR K DIR W ! "RTN","DGRPEIS3",10,0) Q "RTN","DGRPEIS3",11,0) ; "RTN","DGRPEIS3",12,0) WRT ; Write age statement "RTN","DGRPEIS3",13,0) Q:'$G(DGMTI) "RTN","DGRPEIS3",14,0) W !!,"This dependent is 18 years or older. To list this person as a dependent" "RTN","DGRPEIS3",15,0) W !,"they have to be:" "RTN","DGRPEIS3",16,0) W !," 1. An UNMARRIED child who is under the age of 18." "RTN","DGRPEIS3",17,0) W !," 2. Between the ages of 18 and 23 and attending school." "RTN","DGRPEIS3",18,0) W !," 3. An unmarried child over the age of 17 who became permanently" "RTN","DGRPEIS3",19,0) W !," incapable of self support before the age of 18." "RTN","DGRPEIS3",20,0) Q "RTN","DGRPEIS3",21,0) ; "RTN","DGRPEIS3",22,0) EDIT ;CALLED FROM ROUTINE DGRPEIS "RTN","DGRPEIS3",23,0) N DGEXIT "RTN","DGRPEIS3",24,0) S DGEDDEP=1 "RTN","DGRPEIS3",25,0) S DGFL=$G(DGFL) "RTN","DGRPEIS3",26,0) S DATE=$S($G(DATE):DATE,1:$$LYR^DGMTSCU1(DT)) "RTN","DGRPEIS3",27,0) S X=$P(DGPREF,"^",2) "RTN","DGRPEIS3",28,0) S DGTYPE=$G(DGTYPE),DGTYPE=$S(DGTYPE']"":"S",DGTYPE="C":"C",DGTYPE="D":"D",1:"S") "RTN","DGRPEIS3",29,0) S DIE="^"_$P(X,";",2),DA=+X "RTN","DGRPEIS3",30,0) ; "RTN","DGRPEIS3",31,0) ;changes to make Pseudo SSN Reason required - DG*5.3*653, ERC "RTN","DGRPEIS3",32,0) S DGEXIT=0 "RTN","DGRPEIS3",33,0) S DR=".01;.02;.03;.09;S UPARROW=1" "RTN","DGRPEIS3",34,0) K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 Q "RTN","DGRPEIS3",35,0) I $P($G(@(DIE_DA_",0)")),U,9)["P" D "RTN","DGRPEIS3",36,0) SSNREA . ;if SSN is pseudo Pseudo SSN Reason is required - DG*5.3*653, ERC "RTN","DGRPEIS3",37,0) . S DR=$S(DIE["DGPR":.1,1:.0906)_";S UPARROW=1" "RTN","DGRPEIS3",38,0) . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 Q "RTN","DGRPEIS3",39,0) . I $P($G(@(DIE_DA_",0)")),U,10)']"" G SSNREA "RTN","DGRPEIS3",40,0) I DGEXIT=1 Q "RTN","DGRPEIS3",41,0) I DGTYPE="S" D "RTN","DGRPEIS3",42,0) . S DR="1.1;S UPARROW=1" "RTN","DGRPEIS3",43,0) . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 "RTN","DGRPEIS3",44,0) I DGEXIT=1 Q "RTN","DGRPEIS3",45,0) ; "RTN","DGRPEIS3",46,0) ; "RTN","DGRPEIS3",47,0) S DOB=$P($G(@(DIE_DA_",0)")),U,3) "RTN","DGRPEIS3",48,0) ; "RTN","DGRPEIS3",49,0) N DGVADD,DGSADD,DGIPIEN,DGUQTLP,SPOUSE,DGFL,DGRPI "RTN","DGRPEIS3",50,0) S (DGVADD,DGSADD,DGIPIEN,DGUQTLP)=0 "RTN","DGRPEIS3",51,0) S SPOUSE=$S(DGTYPE="S":1,1:0),DGFL=$G(DGFL) "RTN","DGRPEIS3",52,0) ; Is spouse/dependent address same as patient address? "RTN","DGRPEIS3",53,0) K DIR "RTN","DGRPEIS3",54,0) S DIR(0)="YAO^^" "RTN","DGRPEIS3",55,0) S DIR("A")="STREET ADDRESS SAME AS PATIENT'S: " "RTN","DGRPEIS3",56,0) S DIR("B")="YES" "RTN","DGRPEIS3",57,0) S DIR("?")="Enter 'Y' if the "_$S(SPOUSE:"spouse",1:"child")_" has the same address as the patient, otherwise enter 'N'." "RTN","DGRPEIS3",58,0) D ^DIR "RTN","DGRPEIS3",59,0) S DGVADD=+Y "RTN","DGRPEIS3",60,0) K Y,DIR "RTN","DGRPEIS3",61,0) S DGIPIEN=$$SPSCHK^DGRPEIS(DFN) "RTN","DGRPEIS3",62,0) I 'DGVADD,(DGTYPE'="S"),DGIPIEN D "RTN","DGRPEIS3",63,0) . K DIR,Y "RTN","DGRPEIS3",64,0) . S DIR(0)="YAO^^" "RTN","DGRPEIS3",65,0) . S DIR("A")="STREET ADDRESS SAME AS SPOUSE'S: " "RTN","DGRPEIS3",66,0) . S DIR("B")="YES" "RTN","DGRPEIS3",67,0) . S DIR("?")="Enter 'Y' if the child has the same address as the spouse, otherwise enter 'N'." "RTN","DGRPEIS3",68,0) . D ^DIR "RTN","DGRPEIS3",69,0) . S DGSADD=+Y "RTN","DGRPEIS3",70,0) . K Y,DIR "RTN","DGRPEIS3",71,0) ; "RTN","DGRPEIS3",72,0) ; If spouse/dependent address is same as patient's, set spouse/dep address "RTN","DGRPEIS3",73,0) I DGVADD!DGSADD D "RTN","DGRPEIS3",74,0) . I DGVADD D PATASET^DGRPEIS(DFN) ;*Set to Patient address "RTN","DGRPEIS3",75,0) . I DGSADD D SPSASET^DGRPEIS(DGIPIEN) ;*Set to Spouse address "RTN","DGRPEIS3",76,0) . N FLD,FDA S FLD=0 F S FLD=$O(ANS(FLD)) Q:'FLD D "RTN","DGRPEIS3",77,0) . . S FDA(408.13,DA_",",FLD)=ANS(FLD) K ANS(FLD) "RTN","DGRPEIS3",78,0) . D FILE^DIE("","FDA","") "RTN","DGRPEIS3",79,0) ; "RTN","DGRPEIS3",80,0) ;Spouse/dep address not same as patient/spouse address; prompt for it "RTN","DGRPEIS3",81,0) I 'DGVADD,'DGSADD D "RTN","DGRPEIS3",82,0) . S DR="1.2;S:X']"""" Y=1.5;1.3;S:X']"""" Y=1.5;1.4;1.5;1.6;1.7;1.8;S UPARROW=1" "RTN","DGRPEIS3",83,0) . K DG,DQ D ^DIE "RTN","DGRPEIS3",84,0) I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) D EDITQ Q "RTN","DGRPEIS3",85,0) ; "RTN","DGRPEIS3",86,0) I DGTYPE'="S" K UPARROW S DIE="^DGPR(408.12,",DA=+DGPREF,DR=".02;S UPARROW=1" K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) "RTN","DGRPEIS3",87,0) S RELATION=$P($G(^DGPR(408.12,+DGPREF,0)),"^",2) "RTN","DGRPEIS3",88,0) S DGX=$O(^DGPR(408.12,+DGPREF,"E","AID","")),DGMIEN=$O(^(+DGX,0)) "RTN","DGRPEIS3",89,0) EDACTDT I $G(^DGPR(408.12,+DGPREF,"E",+DGMIEN,0)) D G:$G(DGFL)<0 EDITQ "RTN","DGRPEIS3",90,0) . S (DGACT,Y)=+^(0) X ^DD("DD") "RTN","DGRPEIS3",91,0) . S DIR("B")=Y "RTN","DGRPEIS3",92,0) . D READ^DGRPEIS2 "RTN","DGRPEIS3",93,0) . I -DGACT'=DGX W !,"Use 'Expand Dependent' option to change effective date." H 2 S DGFL=-1 Q "RTN","DGRPEIS3",94,0) . Q:$G(DGFL)<0 "RTN","DGRPEIS3",95,0) . S DIE="^DGPR(408.12,"_+DGPREF_",""E"",",DA(1)=+DGPREF,DA=DGMIEN,DR=".01///"_DGACT "RTN","DGRPEIS3",96,0) . D ^DIE "RTN","DGRPEIS3",97,0) I DGTYPE="S" S X=+DGPREF D SETUP^DGRPEIS1 "RTN","DGRPEIS3",98,0) K DGACT,DGMIEN,RELATION,DA,DIE,DR,UPARROW,DTOUT,DUOUT,DIRUT "RTN","DGRPEIS3",99,0) EDITQ K DA,DIE,DIRUT,DR,DTOUT,DUOUT "RTN","DGRPEIS3",100,0) Q "RTN","DGRPEIS3",101,0) ; "RTN","DGRPEIS3",102,0) HELP1(DGISDT) ; Displays the help for the active/inactive prompt "RTN","DGRPEIS3",103,0) ; "RTN","DGRPEIS3",104,0) D CLEAR^VALM1 "RTN","DGRPEIS3",105,0) W !,"Enter the date this person first became a dependent of the veteran." "RTN","DGRPEIS3",106,0) W !,"In the case of a spouse, this would be the date of marriage. For" "RTN","DGRPEIS3",107,0) W !,"a child, this would be the date of birth or date of adoption. For a" "RTN","DGRPEIS3",108,0) W !,"stepchild, this would be the date of marriage to the child's parent." "RTN","DGRPEIS3",109,0) W !!,"Date must be before DEC 31, "_DGISDT_" as dependents are collected for the" "RTN","DGRPEIS3",110,0) W !,"prior calendar year only." "RTN","DGRPEIS3",111,0) S VALMBCK="R" "RTN","DGRPEIS3",112,0) Q "RTN","DGRPEIS3",113,0) ; "RTN","DGRPEIS3",114,0) HELPDOB ; * Displays help for Date of Birth "RTN","DGRPEIS3",115,0) N DGRDVAR "RTN","DGRPEIS3",116,0) I X="?" D Q "RTN","DGRPEIS3",117,0) . W !?5,"Enter the date this dependent was born. The date must not be during the" "RTN","DGRPEIS3",118,0) . W !?5,"current calendar year. Only persons that were dependents before the" "RTN","DGRPEIS3",119,0) . W !?5,"current year may be entered.",! "RTN","DGRPEIS3",120,0) . I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W ! "RTN","DGRPEIS3",121,0) ; "RTN","DGRPEIS3",122,0) W !?8,"Enter the date on which this relative was born. This information is" "RTN","DGRPEIS3",123,0) W !?8,"necessary for use in the income screening and means test portions of" "RTN","DGRPEIS3",124,0) W !?8,"MAS." "RTN","DGRPEIS3",125,0) W !!?8,"The date entered must not be during the current calendar year. That" "RTN","DGRPEIS3",126,0) W !?8,"is, it must be on or before December 31 or the prior calendar year." "RTN","DGRPEIS3",127,0) I $G(DA) W ! S DIR(0)="E" D ^DIR Q:+Y<1 "RTN","DGRPEIS3",128,0) W !!?8,"The reason for this is that this data is used for collecting income" "RTN","DGRPEIS3",129,0) W !?8,"information for the purposes of comparing this data with the Internal" "RTN","DGRPEIS3",130,0) W !?8,"Revenue Service (IRS). Children born during the calendar year cannot" "RTN","DGRPEIS3",131,0) W !?8,"be entered until next year." "RTN","DGRPEIS3",132,0) I $G(DA) W !!,"Enter RETURN to continue:" R DGRDVAR:DTIME W ! "RTN","DGRPEIS3",133,0) Q "RTN","DGRPEIS3",134,0) ; "RTN","DGRPEIS3",135,0) HELPMN ; * Displays help for Spouse Maiden Name "RTN","DGRPEIS3",136,0) W !?8,"Enter the spouse's maiden name in 'LAST,FIRST MIDDLE SUFFIX' format." "RTN","DGRPEIS3",137,0) W !?8,"Entry of the LAST name only is permitted and the comma may be omitted." "RTN","DGRPEIS3",138,0) W !?8,"If the response contains no comma, one will be appended to the value." "RTN","DGRPEIS3",139,0) W !?8,"Including the comma, the value must be at least 3 characters in length.",! "RTN","DGRPEIS3",140,0) Q "RTN","DGRPEIS3",141,0) ; "RTN","DGRPEIS3",142,0) HELPSA1 ; * Displays help for Street Address 1 "RTN","DGRPEIS3",143,0) N DGRELTP "RTN","DGRPEIS3",144,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",145,0) W !,"If a "_DGRELTP_"'s name has been specified, enter the first line of" "RTN","DGRPEIS3",146,0) W !,"that person's street address [3-30 characters]; otherwise this field" "RTN","DGRPEIS3",147,0) W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s" "RTN","DGRPEIS3",148,0) W !,"name is on file." "RTN","DGRPEIS3",149,0) I $G(DA),(X="?") W ! "RTN","DGRPEIS3",150,0) Q "RTN","DGRPEIS3",151,0) ; "RTN","DGRPEIS3",152,0) HELPSA2 ; * Displays help for Street Address 2 "RTN","DGRPEIS3",153,0) N DGRELTP "RTN","DGRPEIS3",154,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",155,0) W !,"If a "_DGRELTP_"'s name has been specified, enter the second line of" "RTN","DGRPEIS3",156,0) W !,"that person's street address [3-30 characters]; otherwise this field" "RTN","DGRPEIS3",157,0) W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s" "RTN","DGRPEIS3",158,0) W !,"name is on file." "RTN","DGRPEIS3",159,0) I $G(DA),(X="?") W ! "RTN","DGRPEIS3",160,0) Q "RTN","DGRPEIS3",161,0) ; "RTN","DGRPEIS3",162,0) HELPSA3 ; * Displays help for Street Address 3 "RTN","DGRPEIS3",163,0) N DGRELTP "RTN","DGRPEIS3",164,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",165,0) W !,"If a "_DGRELTP_"'s name has been specified, enter the third line of" "RTN","DGRPEIS3",166,0) W !,"that person's street address [3-30 characters]; otherwise this field" "RTN","DGRPEIS3",167,0) W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s" "RTN","DGRPEIS3",168,0) W !,"name is on file." "RTN","DGRPEIS3",169,0) I $G(DA),(X="?") W ! "RTN","DGRPEIS3",170,0) Q "RTN","DGRPEIS3",171,0) ; "RTN","DGRPEIS3",172,0) HELPCITY ; * Displays help for City "RTN","DGRPEIS3",173,0) N DGRELTP "RTN","DGRPEIS3",174,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",175,0) W !,"If a "_DGRELTP_"'s name has been specified, enter the city in which" "RTN","DGRPEIS3",176,0) W !,"that person resides [3-30 characters]; otherwise this field may be" "RTN","DGRPEIS3",177,0) W !,"left blank. This field cannot be deleted as long as a "_DGRELTP_"'s" "RTN","DGRPEIS3",178,0) W !,"name is on file." "RTN","DGRPEIS3",179,0) I $G(DA),(X="?") W ! "RTN","DGRPEIS3",180,0) Q "RTN","DGRPEIS3",181,0) ; "RTN","DGRPEIS3",182,0) HELPSTAT ; * Displays help for the state "RTN","DGRPEIS3",183,0) N DGRELTP,DIRA,DGRDVAR "RTN","DGRPEIS3",184,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",185,0) W !,"If a "_DGRELTP_"'s name has been specified, select the state in which" "RTN","DGRPEIS3",186,0) W !,"that person resides; otherwise this field may be left blank. This" "RTN","DGRPEIS3",187,0) W !,"field cannot be deleted as long as a "_DGRELTP_"'s name is on file.",! "RTN","DGRPEIS3",188,0) ; "RTN","DGRPEIS3",189,0) Q:X="?" "RTN","DGRPEIS3",190,0) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME "RTN","DGRPEIS3",191,0) Q "RTN","DGRPEIS3",192,0) ; "RTN","DGRPEIS3",193,0) HELPZIP ; * Displays help for the Zip code "RTN","DGRPEIS3",194,0) N DGRELTP "RTN","DGRPEIS3",195,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",196,0) W !,"Answer with the 5 digit format (e.g. 12345) or the nine digit" "RTN","DGRPEIS3",197,0) W !,"format (e.g. 12345-6789 or 123456789). This is related to the" "RTN","DGRPEIS3",198,0) W !,DGRELTP_"'s address." "RTN","DGRPEIS3",199,0) I $G(DA),(X="?") W ! "RTN","DGRPEIS3",200,0) Q "RTN","DGRPEIS3",201,0) HELPPHON ; * Displays help for the Phone number "RTN","DGRPEIS3",202,0) N DGRELTP "RTN","DGRPEIS3",203,0) S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1) "RTN","DGRPEIS3",204,0) W !,"If a "_DGRELTP_"'s name has been specified, enter the "_DGRELTP_"'s" "RTN","DGRPEIS3",205,0) W !,"phone number [4-20 characters], otherwise this field may be left" "RTN","DGRPEIS3",206,0) W !,"blank. This field cannot be deleted as long as a "_DGRELTP_"'s" "RTN","DGRPEIS3",207,0) W !,"name is on file." "RTN","DGRPEIS3",208,0) I $G(DA),(X="?") W ! "RTN","DGRPEIS3",209,0) Q "RTN","DGRPLE") 0^33^B20956933 "RTN","DGRPLE",1,0) DGRPLE ;WAS/ERC/RMM,ALB/CKN - REGISTRATION EDITS OF PURPLE HEART FIELDS ; 9/29/05 4:53pm "RTN","DGRPLE",2,0) ;;5.3;Registration;**314,343,377,431,653**;Aug 13, 1993;Build 2 "RTN","DGRPLE",3,0) ; "RTN","DGRPLE",4,0) DIV() ;Get Institution Name "RTN","DGRPLE",5,0) ;If site is multi-divisional then ask user for division "RTN","DGRPLE",6,0) ; "RTN","DGRPLE",7,0) ; DBIA: #10112 - supported API $$SITE^VASITE and $$PRIM^VASITE "RTN","DGRPLE",8,0) ; for retrieving Institution name "RTN","DGRPLE",9,0) ; "RTN","DGRPLE",10,0) ; Input: none "RTN","DGRPLE",11,0) ; "RTN","DGRPLE",12,0) ; Output: DGNAM - Institution name "RTN","DGRPLE",13,0) ; "RTN","DGRPLE",14,0) N DGDIV,DGSTN,DGNAM "RTN","DGRPLE",15,0) S DGDIV=$S($D(^DG(40.8,"B")):$$MULTDIV,1:$$PRIM^VASITE) "RTN","DGRPLE",16,0) S DGSTN=$$SITE^VASITE(,DGDIV) "RTN","DGRPLE",17,0) S DGNAM=$S($P(DGSTN,U,2)]"":$P(DGSTN,U,2),1:"") "RTN","DGRPLE",18,0) Q DGNAM "RTN","DGRPLE",19,0) ; "RTN","DGRPLE",20,0) MULTDIV() ;User selects from active divisions "RTN","DGRPLE",21,0) ; "RTN","DGRPLE",22,0) ; Input: none "RTN","DGRPLE",23,0) ; "RTN","DGRPLE",24,0) ; Output: "RTN","DGRPLE",25,0) ; Function return value - Division IEN "RTN","DGRPLE",26,0) ; "RTN","DGRPLE",27,0) N DIR,X,Y "RTN","DGRPLE",28,0) S DIR(0)="PA^40.8:EM" "RTN","DGRPLE",29,0) S DIR("A")="Enter your division: " "RTN","DGRPLE",30,0) S DIR("S")="I $$SITE^VASITE(,+Y)>0" "RTN","DGRPLE",31,0) D ^DIR "RTN","DGRPLE",32,0) Q +Y "RTN","DGRPLE",33,0) ; "RTN","DGRPLE",34,0) EDITPOW(DG1,DG2,DG3,DG4,DGDFN) ;entry from enrollment for HEC updates "RTN","DGRPLE",35,0) ; DGDFN - Patient File IEN "RTN","DGRPLE",36,0) ; DG1 - POW Indicator "RTN","DGRPLE",37,0) ; DG2 - POW Confinement Location "RTN","DGRPLE",38,0) ; DG3 - POW From Date "RTN","DGRPLE",39,0) ; DG4 - POW To Date "RTN","DGRPLE",40,0) ; Update POW data from HEC - DG*5.3*653 "RTN","DGRPLE",41,0) N DATA,DGENDA,ERROR,CURPOW,POW "RTN","DGRPLE",42,0) S DGENDA=DGDFN "RTN","DGRPLE",43,0) S CURPOW=$G(^DPT(DGDFN,.52)) "RTN","DGRPLE",44,0) S POW(.525)=$P(CURPOW,"^",5) ;Current POW indicator "RTN","DGRPLE",45,0) ;add following code for EVC R2 "RTN","DGRPLE",46,0) ;S POW(.529)=$P(CURPOW,"^",9) ;Current POW verified status "RTN","DGRPLE",47,0) S DATA(.525)=$G(DG1) "RTN","DGRPLE",48,0) ;add following commented line for EVC R2 "RTN","DGRPLE",49,0) ;If Current POW Verified Status is null, "RTN","DGRPLE",50,0) ;OR Current POW Verified Status is not null and incoming POW indicator is different than current POW indicator, "RTN","DGRPLE",51,0) ;set POW Verified Status to current Date/Time. "RTN","DGRPLE",52,0) ;I (POW(.529)="")!((POW(.529)'="")&(DG1'=POW(.525))) S DATA(.529)=$$NOW^XLFDT() "RTN","DGRPLE",53,0) ;Remove the values in database if POW Indicator is NO "RTN","DGRPLE",54,0) ;otherwise update new values "RTN","DGRPLE",55,0) S DATA(.526)=$S(DG1="N":"@",1:DG2) "RTN","DGRPLE",56,0) S DATA(.527)=$S(DG1="N":"@",1:DG3) "RTN","DGRPLE",57,0) S DATA(.528)=$S(DG1="N":"@",1:DG4) "RTN","DGRPLE",58,0) I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D "RTN","DGRPLE",59,0) . D ADDMSG^DGENUPL3(.MSGS,"Unable to update POW Data.",1) "RTN","DGRPLE",60,0) K DATA,DGENDA,ERROR,DG1,DG2,DG3,DG4 "RTN","DGRPLE",61,0) Q "RTN","DGRPLE",62,0) ; "RTN","DGRPLE",63,0) EDITPH(DG1,DG2,DG3,DGDFN) ;entry from enrollment for HEC updates "RTN","DGRPLE",64,0) ; DGDFN - Patient File IEN "RTN","DGRPLE",65,0) ; DG1 - PH Indicator "RTN","DGRPLE",66,0) ; DG2 - PH Status "RTN","DGRPLE",67,0) ; DG3 - PH Remarks "RTN","DGRPLE",68,0) ; "RTN","DGRPLE",69,0) N DATA,DGENDA,ERROR,DGUSER,DGPHARR,% "RTN","DGRPLE",70,0) S DGENDA=DGDFN "RTN","DGRPLE",71,0) S (DG(1),DATA(.531))=DG1 "RTN","DGRPLE",72,0) S (DG(2),DATA(.532))=$S(DG1="N":"",1:DG2) "RTN","DGRPLE",73,0) S (DG(3),DATA(.533))=$S(DG1="Y":"",1:DG3) "RTN","DGRPLE",74,0) I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D "RTN","DGRPLE",75,0) .D ADDMSG^DGENUPL3(.MSGS,"Unable to update Purple Heart Data.",1) "RTN","DGRPLE",76,0) K DATA,DGENDA,ERROR "RTN","DGRPLE",77,0) ; If the Database Server Failed, Quit. "RTN","DGRPLE",78,0) Q:'$D(^DPT(DGDFN,.53)) "RTN","DGRPLE",79,0) S DGUSER="HEC User",DGPHARR=^DPT(DGDFN,.53) "RTN","DGRPLE",80,0) ; If nothing was changed, don't update the history, Quit. "RTN","DGRPLE",81,0) Q:'$$CHANGE(DG(1),DG(2),DG(3),DGDFN) "RTN","DGRPLE",82,0) ; "RTN","DGRPLE",83,0) D NOW^%DTC "RTN","DGRPLE",84,0) S DATA(.01)=%,DATA(1)=DG(1),DATA(2)=DG(2),DATA(3)=DG(3) "RTN","DGRPLE",85,0) S DATA(4)=DGUSER,DGENDA(1)=DGDFN "RTN","DGRPLE",86,0) I '$$ADD^DGENDBS(2.0534,.DGENDA,.DATA,.ERROR) D "RTN","DGRPLE",87,0) .D ADDMSG^DGENUPL3(.MSGS,"Unable to update Purple Heart History.",1) "RTN","DGRPLE",88,0) K DATA,DGENDA,ERROR "RTN","DGRPLE",89,0) ; "RTN","DGRPLE",90,0) Q "RTN","DGRPLE",91,0) ; "RTN","DGRPLE",92,0) EDITPH1(DGUSER) ; "RTN","DGRPLE",93,0) ; Input: DGUSER - Person filing Purple Heart changes "RTN","DGRPLE",94,0) ; "RTN","DGRPLE",95,0) ; Output: none "RTN","DGRPLE",96,0) ; "RTN","DGRPLE",97,0) S DGUSER=$G(DGUSER,$P(^VA(200,DUZ,0),U)) "RTN","DGRPLE",98,0) NEW DGPHARR,DG,DGX "RTN","DGRPLE",99,0) S DGPHARR=^DPT(DFN,.53) "RTN","DGRPLE",100,0) ;REDIE will ensure there is a STATUS only if indicator is "RTN","DGRPLE",101,0) ;'yes' and a REMARK only if indicator is 'no' "RTN","DGRPLE",102,0) I $P(DGPHARR,U)="Y",($P(DGPHARR,U,3)]"") D REDIE(3) "RTN","DGRPLE",103,0) I $P(DGPHARR,U)="N",($P(DGPHARR,U,2)]"") D REDIE(2) "RTN","DGRPLE",104,0) F DGX=1:1:3 S DG(DGX)=$P(DGPHARR,U,DGX) "RTN","DGRPLE",105,0) I $$CHANGE(DG(1),DG(2),DG(3),DFN) D EDITPH2(DG(1),DG(2),DG(3),DGUSER) "RTN","DGRPLE",106,0) Q "RTN","DGRPLE",107,0) ; "RTN","DGRPLE",108,0) EDITPH2(DG1,DG2,DG3,DG4) ;stuff PH values into the PH multiple of file #2 "RTN","DGRPLE",109,0) S DFN=DA "RTN","DGRPLE",110,0) N DA,DIC,DIE "RTN","DGRPLE",111,0) S DIC="^DPT("_DFN_",""PH""," "RTN","DGRPLE",112,0) S DA(1)=DFN "RTN","DGRPLE",113,0) D NOW^%DTC S X=% "RTN","DGRPLE",114,0) S DIC(0)="L" "RTN","DGRPLE",115,0) S DIC("DR")="1///^S X=$G(DG1);2///^S X=$G(DG2);3///^S X=$G(DG3);4///^S X=$G(DG4)" "RTN","DGRPLE",116,0) D ^DIC "RTN","DGRPLE",117,0) Q "RTN","DGRPLE",118,0) ; "RTN","DGRPLE",119,0) REDIE(DGPCE) ; make sure value in PH Status and PH Remarks consistent "RTN","DGRPLE",120,0) ; with value of PH Indicator "RTN","DGRPLE",121,0) N DA,DIE,DR "RTN","DGRPLE",122,0) S DIE="^DPT(",DR=$S($G(DGPCE)=2:.532,1:.533)_"///^S X=""@""" "RTN","DGRPLE",123,0) S DA=DFN "RTN","DGRPLE",124,0) D ^DIE "RTN","DGRPLE",125,0) S DGPHARR=^DPT(DFN,.53) "RTN","DGRPLE",126,0) Q "RTN","DGRPLE",127,0) ; "RTN","DGRPLE",128,0) CHANGE(DGPH1,DGPH2,DGPH3,DGPHDFN) ;Check to see if the entry has changed "RTN","DGRPLE",129,0) ; Input: "RTN","DGRPLE",130,0) ; DGPH1 - PH Indicator "RTN","DGRPLE",131,0) ; DGPH2 - PH Status "RTN","DGRPLE",132,0) ; DGPH3 - PH Remarks "RTN","DGRPLE",133,0) ; DGPHDFN- Patient file IEN "RTN","DGRPLE",134,0) ; "RTN","DGRPLE",135,0) ; Output: none "RTN","DGRPLE",136,0) ; "RTN","DGRPLE",137,0) ; Return: DGCHG = 1 - Change in any of the input values has occurred "RTN","DGRPLE",138,0) ; DGCHG = 0 - No change "RTN","DGRPLE",139,0) ; "RTN","DGRPLE",140,0) N DGCHG ;Return value "RTN","DGRPLE",141,0) N DGARR ;Array containing last values from audit "RTN","DGRPLE",142,0) N DGPHVAL ;Merged array of DGARR "RTN","DGRPLE",143,0) N DGERR ;Error root for DIQ "RTN","DGRPLE",144,0) N DGIEN ;IEN of last audit value "RTN","DGRPLE",145,0) N DGFILE ;Purple Heart Multiple "RTN","DGRPLE",146,0) N DGI ;Index counter "RTN","DGRPLE",147,0) ; "RTN","DGRPLE",148,0) K DGPHINC "RTN","DGRPLE",149,0) S DGCHG=0 "RTN","DGRPLE",150,0) S DGFILE=2.0534 "RTN","DGRPLE",151,0) S DGIEN=$O(^DPT(DGPHDFN,"PH","B"),-1) "RTN","DGRPLE",152,0) I DGIEN="" S DGCHG=1 G AUDITQ "RTN","DGRPLE",153,0) D GETS^DIQ(DGFILE,DGIEN_","_DGPHDFN_",","1;2;3","I","DGARR","DGERR") "RTN","DGRPLE",154,0) I $D(DGERR) S DGCHG=1 G AUDITQ "RTN","DGRPLE",155,0) M DGPHVAL=DGARR(DGFILE,DGIEN_","_DGPHDFN_",") "RTN","DGRPLE",156,0) F DGI=1:1:3 I @("DGPH"_DGI)'=DGPHVAL(DGI,"I") D "RTN","DGRPLE",157,0) . S DGCHG=1 "RTN","DGRPLE",158,0) . I DGI=1 D ; PH INDICATOR has changed "RTN","DGRPLE",159,0) . . I DGPH1="N",DGPHVAL(DGI,"I")="Y" S DGPHINC=1 ; Package Variable to note PH Indicator has changed "RTN","DGRPLE",160,0) AUDITQ Q DGCHG "RTN","DGUTL3") 0^37^B9126169 "RTN","DGUTL3",1,0) DGUTL3 ;ALB/MTC,CKN - ELIGIBILITY UTILITIES ; 10/4/05 12:22pm "RTN","DGUTL3",2,0) ;;5.3;Registration;**114,506,653**;Aug 13, 1993;Build 2 "RTN","DGUTL3",3,0) ; "RTN","DGUTL3",4,0) Q "RTN","DGUTL3",5,0) ELIG(DFN,SOURCE,DEFAULT) ;-- This function will prompt for the eligibility for a patient. If "RTN","DGUTL3",6,0) ; only one eligibility then it will be returned without prompting. "RTN","DGUTL3",7,0) ; "RTN","DGUTL3",8,0) ; INPUT: DFN - Patient "RTN","DGUTL3",9,0) ; SOURCE - (1:PTF,2:ADMISSION,3:TRANSFER) "RTN","DGUTL3",10,0) ; DEFALUT - IEN from file 8.1 "RTN","DGUTL3",11,0) ; OUTPUT: IEN of file 8^Name "RTN","DGUTL3",12,0) ; "RTN","DGUTL3",13,0) ; "RTN","DGUTL3",14,0) N RESULT,VAEL,ALLEL,EMP,X,DGDEF,Y "RTN","DGUTL3",15,0) ; "RTN","DGUTL3",16,0) ;-- get eligility codes "RTN","DGUTL3",17,0) D GETEL(DFN) "RTN","DGUTL3",18,0) S DGDEF=$P($G(^DIC(8,+$G(DEFAULT),0)),U) "RTN","DGUTL3",19,0) I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF "RTN","DGUTL3",20,0) ; "RTN","DGUTL3",21,0) S RESULT="",EMP=$P(VAEL(1),U,2),ALLEL=U_EMP "RTN","DGUTL3",22,0) I '$D(VAEL) G ELIGQ "RTN","DGUTL3",23,0) I $D(VAEL(1))=1 S RESULT=VAEL(1) G ELIGQ "RTN","DGUTL3",24,0) ;-- if no default set default to primary eligibility "RTN","DGUTL3",25,0) I DGDEF="" S DGDEF=VAEL(1) "RTN","DGUTL3",26,0) ; "RTN","DGUTL3",27,0) DISP ;-- display choices "RTN","DGUTL3",28,0) W !,"THIS PATIENT HAS OTHER ENTITLED ELIGIBILITIES:" "RTN","DGUTL3",29,0) W !?5,$P(VAEL(1),U,2) "RTN","DGUTL3",30,0) S X="" F S X=$O(VAEL(1,X)) Q:X'>0 D "RTN","DGUTL3",31,0) . W !?5,$P(VAEL(1,X),U,2) "RTN","DGUTL3",32,0) . S ALLEL=ALLEL_U_$P(VAEL(1,X),U,2) "RTN","DGUTL3",33,0) ; "RTN","DGUTL3",34,0) ;-- prompt for eligibility codes "RTN","DGUTL3",35,0) ; "RTN","DGUTL3",36,0) 1 W !,"ENTER THE ELIGIBILITY FOR THIS "_$S(SOURCE=1:"MOVEMENT",SOURCE=2:"ADMISSION",SOURCE=3:"TRANSFER",1:"PATIENT")_": "_$P(DGDEF,U,2)_"// " "RTN","DGUTL3",37,0) R X:DTIME "RTN","DGUTL3",38,0) ;-- if timeout "RTN","DGUTL3",39,0) G ELIGQ:'$T "RTN","DGUTL3",40,0) ;-- if ^ "RTN","DGUTL3",41,0) G ELIGQ:X[U "RTN","DGUTL3",42,0) ;-- if default (primary) quit "RTN","DGUTL3",43,0) I X="" S RESULT=DGDEF G ELIGQ "RTN","DGUTL3",44,0) ;-- find eligibility "RTN","DGUTL3",45,0) S X=$$UPPER^VALM1(X) "RTN","DGUTL3",46,0) G DISP:X["?",1:ALLEL'[(U_X) "RTN","DGUTL3",47,0) ; "RTN","DGUTL3",48,0) S EMP=X_$P($P(ALLEL,U_X,2),U) W $P($P(ALLEL,U_X,2),U) "RTN","DGUTL3",49,0) I $P(VAEL(1),U,2)=EMP S RESULT=VAEL(1) G ELIGQ "RTN","DGUTL3",50,0) S X="" F S X=$O(VAEL(1,X)) Q:X'>0 D "RTN","DGUTL3",51,0) . I $P(VAEL(1,X),U,2)=EMP S RESULT=X_U_EMP "RTN","DGUTL3",52,0) ; "RTN","DGUTL3",53,0) ELIGQ ; "RTN","DGUTL3",54,0) K VAEL "RTN","DGUTL3",55,0) Q +RESULT "RTN","DGUTL3",56,0) ; "RTN","DGUTL3",57,0) GETEL(DFN) ;-- This function will get the eligibilities for the patient "RTN","DGUTL3",58,0) ; specified by DFN and return all the active eligibilities in the "RTN","DGUTL3",59,0) ; ARRAY specified. "RTN","DGUTL3",60,0) ; "RTN","DGUTL3",61,0) ; INPUT: DFN - Patient "RTN","DGUTL3",62,0) ; "RTN","DGUTL3",63,0) D ELIG^VADPT "RTN","DGUTL3",64,0) Q "RTN","DGUTL3",65,0) ; "RTN","DGUTL3",66,0) GETDEL(DFN,START,END) ;-- This function will scan the Eligibility Date "RTN","DGUTL3",67,0) ; Sensitive file #8.3 for all active eligibilities for a date range. "RTN","DGUTL3",68,0) ; "RTN","DGUTL3",69,0) N DGI,DGJ,DGK "RTN","DGUTL3",70,0) ; "RTN","DGUTL3",71,0) S DGI=0 F S DGI=$O(^VAEL(8.3,"AE",DFN,DGI)) Q:DGI="" D "RTN","DGUTL3",72,0) . S DGJ=$O(^VAEL(8.3,"AE",DFN,DGI,0)),DGK=^(DGJ) "RTN","DGUTL3",73,0) . I $P(DGK,U,2) S VAEL(1)=DGI_U_$P($G(^DIC(8,DGI,0)),U) "RTN","DGUTL3",74,0) . I '$P(DGK,U,2) S VAEL(1,DGI)=DGI_U_$P($G(^DIC(8,DGI,0)),U) "RTN","DGUTL3",75,0) Q "RTN","DGUTL3",76,0) ; "RTN","DGUTL3",77,0) ASKPR(DFN) ;-- This function will ask the user for the primary eligibility. "RTN","DGUTL3",78,0) ; "RTN","DGUTL3",79,0) N RESULT,VAEL,ALLEL,EMP,X,DGDEF,Y "RTN","DGUTL3",80,0) ; "RTN","DGUTL3",81,0) ;-- get eligility codes "RTN","DGUTL3",82,0) S DEFAULT=$O(^VAEL(8.3,"AP",DFN,0)) "RTN","DGUTL3",83,0) S DGDEF=$P($G(^DIC(8,+$G(DEFAULT),0)),U) "RTN","DGUTL3",84,0) I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF "RTN","DGUTL3",85,0) ; "RTN","DGUTL3",86,0) S RESULT="" "RTN","DGUTL3",87,0) ; "RTN","DGUTL3",88,0) TRY W !,"PRIMARY ELIGIBILITY CODE: "_$P(DGDEF,U,2)_"// " "RTN","DGUTL3",89,0) R X:DTIME "RTN","DGUTL3",90,0) ;-- if timeout "RTN","DGUTL3",91,0) G PRIMQ:'$T "RTN","DGUTL3",92,0) ;-- if ^ "RTN","DGUTL3",93,0) G PRIMQ:X[U "RTN","DGUTL3",94,0) ;-- find eligibility "RTN","DGUTL3",95,0) S X=$$UPPER^VALM1(X) "RTN","DGUTL3",96,0) ; "RTN","DGUTL3",97,0) PRIMQ ; "RTN","DGUTL3",98,0) K VAEL "RTN","DGUTL3",99,0) Q +RESULT "RTN","DGUTL3",100,0) ; "RTN","DGUTL3",101,0) BADADR(DFN) ;does this patient have a bad address? "RTN","DGUTL3",102,0) ; "RTN","DGUTL3",103,0) Q:'$G(DFN) "" "RTN","DGUTL3",104,0) Q $P($G(^DPT(DFN,.11)),"^",16) "RTN","DGUTL3",105,0) ; "RTN","DGUTL3",106,0) DELBAI(DFN) ;delete bad address indicator "RTN","DGUTL3",107,0) N FDA,IENS "RTN","DGUTL3",108,0) Q:'$G(DFN) "RTN","DGUTL3",109,0) S IENS=DFN_",",FDA(2,IENS,.121)="@" "RTN","DGUTL3",110,0) D FILE^DIE("E","FDA") "RTN","DGUTL3",111,0) Q "RTN","DGUTL3",112,0) GETSHAD(DFN) ;Get current value of Proj 112/SHAD from Patient file. "RTN","DGUTL3",113,0) ; Input: DFN - Patient ien "RTN","DGUTL3",114,0) ; Output: Valid values - 1 (Yes), 0 (No), or null "RTN","DGUTL3",115,0) ; -1 - error "RTN","DGUTL3",116,0) Q:$G(DFN)="" -1 ;Quit with error if missing input parameter "RTN","DGUTL3",117,0) Q $P($G(^DPT(DFN,.321)),"^",15) "RTN","DPTLK2") 0^75^B32261378 "RTN","DPTLK2",1,0) DPTLK2 ;ALB/RMO,ERC - MAS Patient Look-up Add New Patient ; 07/07/06 "RTN","DPTLK2",2,0) ;;5.3;Registration;**32,197,214,244,532,578,615,620,647,680,702,653**;Aug 13, 1993;Build 2 "RTN","DPTLK2",3,0) N DPTCT,DGVV,DPTLIDR,DGCOL S DGCOL=0 "RTN","DPTLK2",4,0) I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY "RTN","DPTLK2",5,0) I '$D(DUZ(0)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. Your Fileman Access Code is undefined." S DPTDFN=-1 G Q "RTN","DPTLK2",6,0) I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(2,0,"LAYGO")) F I=1:1 I DUZ(0)[$E(^("LAYGO"),I) Q:I'>$L(^("LAYGO")) S DPTDFN=-1 W:DIC(0)["Q" *7," ??" G Q "RTN","DPTLK2",7,0) N DG20NAME S DG20NAME=DPTX,DPTX=$$FORMAT^XLFNAME7(.DG20NAME,3,30,,1) "RTN","DPTLK2",8,0) S DPTX=$S($E(DPTX)[""""&($E(DPTX,$L(DPTX))[""""):$P(DPTX,"""",2),$E(DPTX)["""":$P(DPTX,"""",2),$E(DPTX,$L(DPTX))["""":$P(DPTX,"""",1),1:DPTX) "RTN","DPTLK2",9,0) I $L(DPTX)<3!($L(DPTX)>30)!(DPTX?1P.E)!(DPTX'[",")!(DPTX'?1U.ANP) W:DIC(0)["Q" *7," ??" S DPTDFN=-1 G Q "RTN","DPTLK2",10,0) ; DG*647 "RTN","DPTLK2",11,0) I $P($G(XQY0),U)="DG COLLATERAL PATIENT" S DGCOL=1,DGCOL("DR")=$P(DIC("DR"),";",5,8) "RTN","DPTLK2",12,0) K DPTLID I DIC(0)["E" D ASKADD D G Q:DPTDFN<0 I ('$D(DIC("DR")))!(DGCOL) D CHKID G Q:DPTDFN<0 D ^DPTLK3 G Q:DPTDFN<0 W !!?3,"...adding new patient" "RTN","DPTLK2",13,0) .S:DPTDFN<1&('$D(DTOUT)) DUOUT=1 "RTN","DPTLK2",14,0) S X=DPTX,DPT("NO^")=$G(DIE("NO^")) K DD,DO,DPTX N DPTZNV "RTN","DPTLK2",15,0) S:$D(DPT("DR")) DIC("DR")="S DIE(""NO^"")=""BACK"";"_DPT("DR") "RTN","DPTLK2",16,0) I DGCOL S:$D(DPT("DR")) DIC("DR")=DPT("DR")_";"_DGCOL("DR") "RTN","DPTLK2",17,0) D FILE^DICN K:$D(DPT("DR")) DIC("DR") "RTN","DPTLK2",18,0) I +Y>0 W ?24,"...new patient added",!?3 "RTN","DPTLK2",19,0) S DPTDFN=Y S:$L(DPT("NO^")) DIE("NO^")=DPT("NO^") "RTN","DPTLK2",20,0) ;offer prompt of patient file components "RTN","DPTLK2",21,0) K DA,DIE,DR "RTN","DPTLK2",22,0) S DIE="^DPT(",DA=+Y,DR="S DIE(""NO^"")=""BACK"";.01///^S (X,DPTZNV)=$$NCEDIT^DPTNAME(DA,1,.DG20NAME)" "RTN","DPTLK2",23,0) D ^DIE K DR "RTN","DPTLK2",24,0) ;look for other (local) identifiers "RTN","DPTLK2",25,0) I '$D(DIC("DR")),DIC(0)["E",'DGCOL D "RTN","DPTLK2",26,0) .F DPTID=0:0 S DPTID=$O(^DD(2,0,"ID",DPTID)) Q:'DPTID D "RTN","DPTLK2",27,0) ..I $F(DPTGID,U_DPTID_U) Q "RTN","DPTLK2",28,0) ..I '$D(^DD(2,DPTID,0)) Q "RTN","DPTLK2",29,0) ..S DPTLID="" "RTN","DPTLK2",30,0) ..S DPTLIDR=$S('$D(DPTLIDR):DPTID,1:DPTLIDR_";"_DPTID) "RTN","DPTLK2",31,0) I $D(DPTLID) W !!?3,"Please enter the following additional information:",!?3 S DIE="^DPT(",DA=+DPTDFN,DIE("NO^")="BACK",DR=DPTLIDR D ^DIE K DIE,DA,DR "RTN","DPTLK2",32,0) ; "RTN","DPTLK2",33,0) Q K DFN,DPT("DR"),DPTLID,DPTGID,DPTID,DPTID0,DPTIDS "RTN","DPTLK2",34,0) Q "RTN","DPTLK2",35,0) ; "RTN","DPTLK2",36,0) ASKADD I $D(DDS) I $Y>21 D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY "RTN","DPTLK2",37,0) S Y=+$P(^DPT(0),U,4)+1 W !?3,*7,"ARE YOU ADDING ",$S(DPTX'?.N:"'"_DPTX_"' AS ",1:""),"A NEW PATIENT (THE ",Y,$S(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),")" "RTN","DPTLK2",38,0) S %=2 D YN^DICN S DPTDFN=$S(%<0!(%=2):-1,%=1:1,1:0) I 'DPTDFN W !?6,"Enter 'YES' to add a new applicant, or 'NO' not to." G ASKADD "RTN","DPTLK2",39,0) I %=1 S:$$CONF1^DPTNAME(DPTX)'=1 DPTDFN=-1 "RTN","DPTLK2",40,0) Q "RTN","DPTLK2",41,0) ; "RTN","DPTLK2",42,0) CHKID K DFN S DPTDFN=1,DPTGID="^.02^.03^.09^391^1901^.301^994^" I DGCOL S DPTGID="^.03^.09^.02^.3601^" "RTN","DPTLK2",43,0) F DPTCT=2:1 S DPTID=$P(DPTGID,U,DPTCT) Q:'DPTID!(DPTDFN<0) D CHKID1 "RTN","DPTLK2",44,0) Q "RTN","DPTLK2",45,0) ; "RTN","DPTLK2",46,0) CHKID1 I $D(^DD(2,DPTID,0)) S DPT("DR")=$S('$D(DPT("DR")):DPTID,1:DPT("DR")_";"_DPTID),DPTID0=^DD(2,DPTID,0) D ASKID S:'$D(X) DPTDFN=-1 "RTN","DPTLK2",47,0) Q "RTN","DPTLK2",48,0) ; "RTN","DPTLK2",49,0) ASKID N DGREC W !?3,"PATIENT ",$P(DPTID0,U),": " R X:DTIME D I $D(DTOUT)!$G(DUOUT)!($G(DGREC)=1) W !?6,*7,"<'",DPTX,"'> NOT ADDED" K X Q "RTN","DPTLK2",50,0) .S:'$T DTOUT=U "RTN","DPTLK2",51,0) .S:X="^" DUOUT=1 "RTN","DPTLK2",52,0) .Q:$D(DTOUT)!($G(DUOUT))!(X["^") "RTN","DPTLK2",53,0) .I DPTID=.09 D "RTN","DPTLK2",54,0) ..;added with DG*5.3*653 - ERC "RTN","DPTLK2",55,0) ..I X="P"!(X="p") S DPTGID=$P(DPTGID,".09",1)_".09^.0906"_$P(DPTGID,".09",2) "RTN","DPTLK2",56,0) ..N DGNEWPT "RTN","DPTLK2",57,0) ..S DGNEWPT=1 "RTN","DPTLK2",58,0) ..D REC^DGSEC "RTN","DPTLK2",59,0) I X["^" W:$E(X)["^" !?6,*7,"Sorry, '^' not allowed!" W " ??" G ASKID "RTN","DPTLK2",60,0) ; field 994 is not a required field "RTN","DPTLK2",61,0) I DPTID=994 I X["?" D HLPID G ASKID "RTN","DPTLK2",62,0) I DPTID=994 I X="" G SKIP "RTN","DPTLK2",63,0) I X["?"!(X="") W:X="" *7," ??" D HLPID G ASKID "RTN","DPTLK2",64,0) I $P(DPTID0,U,2)["S" F I=1:1 S Y=$P($P(DPTID0,U,3),";",I) K:Y="" X Q:Y="" I $P(Y,":",1)=X!($E($P(Y,":",2),1,$L(X))=X) S X=$P(Y,":",1),DPTSET=$P(Y,":",2) Q "RTN","DPTLK2",65,0) SKIP I $P(DPTID0,U,2)["P" D P1 G ASKID:Y'>0 Q:'$D(X) S DPTIDS(DPTID)=X,DPT("DR")=DPT("DR")_"///"_X K DPTSET Q "RTN","DPTLK2",66,0) I DPTID=.301,$D(X) D CHKIT Q:'$D(X) I $D(X) W:$D(DPTSET) " ",DPTSET S DPTIDS(DPTID)=X,DPT("DR")=DPT("DR")_"///"_X K DPTSET Q "RTN","DPTLK2",67,0) I DPTID'=.301 X $P(DPTID0,U,5,99) I $D(X) W:$D(DPTSET) " ",DPTSET S DPTIDS(DPTID)=X,DPT("DR")=DPT("DR")_"///"_X K DPTSET Q "RTN","DPTLK2",68,0) W:'$D(X)&($P(DPTID0,U,2)'["D") *7," ??" D HLPID G ASKID "RTN","DPTLK2",69,0) ; "RTN","DPTLK2",70,0) HLPID W:$D(^DD(2,DPTID,.1)) !?5,^(.1) W:$D(^DD(2,DPTID,3)) !?5,^(3) I $D(X),X["?" F I=0:0 S I=$O(^DD(2,DPTID,21,I)) Q:'I!(I>3&(X?1"?")) I $D(^(I,0)) W !?5,^(0) I I>2,X?1"?" W !?5,"..." "RTN","DPTLK2",71,0) X:$D(^DD(2,DPTID,4)) ^(4) I $P(DPTID0,U,2)["D" S X="?",%DT="E" D ^%DT "RTN","DPTLK2",72,0) I $P(DPTID0,U,2)["S" W !?7,"CHOOSE FROM: " F I=1:1 S Y=$P($P(DPTID0,U,3),";",I) Q:Y="" W !?7,$P(Y,":",1),?15," ",$P(Y,":",2) "RTN","DPTLK2",73,0) I $P(DPTID0,U,2)["P" D P1 "RTN","DPTLK2",74,0) Q "RTN","DPTLK2",75,0) P1 I DPTID=".3601" S X=$$UCASE^DPTLK1(X) ;DG*5.3*680 "RTN","DPTLK2",76,0) S DPTDIC=$G(DIC),DPTDIC(0)=$G(DIC(0)) S:$D(DIC("S")) DPTDIC("S")=DIC("S") S:$D(DIC("W")) DPTDIC("W")=DIC("W") S DIC="^"_$P(DPTID0,"^",3),DIC(0)="QEMZ",D="B" D IX^DIC "RTN","DPTLK2",77,0) S DIC=DPTDIC,DIC(0)=DPTDIC(0) S:$D(DPTDIC("S")) DIC("S")=DPTDIC("S") S:$D(DPTDIC("W")) DIC("W")=DPTDIC("W") K DPTDIC D DO^DIC1 S:X["^" DPTDFN=-1 I X'["^",X'["?",Y'>0 S X="?" G P1 "RTN","DPTLK2",78,0) ; DG*5.3*680 S X=+Y stores the IEN of the sponsor picked to pass to FILE^DICN "RTN","DPTLK2",79,0) I DPTID=".3601" S X=+Y I '$D(^DPT(+Y,"VET"))!($P($G(^DPT(+Y,"VET")),U)'="Y") D EN^DDIOL("Sponsor must be a veteran","","!?4") K X W !?6,*7,"<'",DPTX,"'> NOT ADDED" "RTN","DPTLK2",80,0) Q "RTN","DPTLK2",81,0) CHKIT ; do input transform for .301 "RTN","DPTLK2",82,0) I X'="Y" Q "RTN","DPTLK2",83,0) S DGVV=DPTIDS(391),DGVV=$O(^DG(391,"B",DGVV,0)) "RTN","DPTLK2",84,0) S DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"") "RTN","DPTLK2",85,0) I DPTIDS(1901)'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X W !?6,*7,"<'",DPTX,"'> NOT ADDED" "RTN","DPTLK2",86,0) Q "RTN","DPTLK2",87,0) DEL ;Delete logic "RTN","DPTLK2",88,0) N I,J,A,G,Q,ERR S Q="""",ERR=0 F I=0:0 S I=$O(^DD(2,0,"PT",I)) Q:'I F J=0:0 S J=$O(^DD(2,0,"PT",I,J)) Q:'J D "RTN","DPTLK2",89,0) .F K=0:0 S K=$O(^DD(I,+J,1,K)) Q:'K S A=$G(^(K,0)) I $L($P(A,U,2)),'$L($P(A,U,3)) D "RTN","DPTLK2",90,0) ..S G=$G(^DIC(+I,0,"GL")) Q:'$L(G) I $D(@(G_Q_$P(A,U,2)_Q_","_DA_")")) W !,"Entry in "_$P($G(^DIC(I,0)),U)_" ("_I_") refers to this patient" S ERR=1 Q "RTN","DPTLK2",91,0) I ERR "RTN","VAFCTR") 0^84^B1588263 "RTN","VAFCTR",1,0) VAFCTR ;BIR/CMC,ERC-Monitoring fields for MPI/PD via DG field monitoring ; 3/30/07 1:56pm "RTN","VAFCTR",2,0) ;;5.3;Registration;**575,648,653**;Aug 13, 1993;Build 2 "RTN","VAFCTR",3,0) Q ; quit if called from the top "RTN","VAFCTR",4,0) ; "RTN","VAFCTR",5,0) MPIPD ; protocol entry point for monitoring fields via DG field monitoring "RTN","VAFCTR",6,0) ; Currently monitoring for fields: "RTN","VAFCTR",7,0) ; 1 ALIAS - .01 of the multiple "RTN","VAFCTR",8,0) ; 2 RACE INFORMATION - .01 of the multiple "RTN","VAFCTR",9,0) ; 6 ETHNICITY INFORMATION - .01 of the multiple "RTN","VAFCTR",10,0) ; 994 MULTIPLE BIRTH INDICATOR "RTN","VAFCTR",11,0) ; 361 PATIENT ELIGIBILITIES - .01 of the multiple - MOVED TO 691 "RTN","VAFCTR",12,0) ; .525 POW STAUTS INDICATED? "RTN","VAFCTR",13,0) ; .0906 PSEUDO SSN REASON "RTN","VAFCTR",14,0) ; "RTN","VAFCTR",15,0) I $G(DGFILE)'=2&($G(DGFILE)'=2.01)&($G(DGFILE)'=2.02)&($G(DGFILE)'=2.06)&($G(DGFILE)'=2.0361) Q "RTN","VAFCTR",16,0) S DGFIELD=$G(DGFIELD) "RTN","VAFCTR",17,0) I DGFIELD'=.01&(DGFIELD'=994)&(DGFIELD'=.525)&(DGFIELD'=.0906) Q "RTN","VAFCTR",18,0) I $T(AVAFC^VAFCDD01)="" Q "RTN","VAFCTR",19,0) I (DGFIELD=994)!(DGFIELD=.525)!(DGFIELD=.0906) S VAFCF=DGFIELD_";" D AVAFC^VAFCDD01(DGDA) "RTN","VAFCTR",20,0) ; ^ MULTIPLE BIRTH INDICATOR "RTN","VAFCTR",21,0) I DGFILE=2.01 S VAFCF="1;" D AVAFC^VAFCDD01(DGDA(1)) ;ALIAS "RTN","VAFCTR",22,0) I DGFILE=2.02 S VAFCF="2.02,.01;" D AVAFC^VAFCDD01(DGDA(1)) "RTN","VAFCTR",23,0) ; ^ RACE INFORMATION "RTN","VAFCTR",24,0) I DGFILE=2.06 S VAFCF="2.06,.01;" D AVAFC^VAFCDD01(DGDA(1)) "RTN","VAFCTR",25,0) ; ^ ETHNICITY INFORMATION "RTN","VAFCTR",26,0) ; MOVED TO DG*5.3*691 "RTN","VAFCTR",27,0) ;I DGFILE=2.0361 S VAFCF="2.0361,.01;" D AVAFC^VAFCDD01(DGDA(1)) "RTN","VAFCTR",28,0) ; ^ PATIENT ELIGIBILITIES "RTN","VAFCTR",29,0) Q "RTN","VAFHLZCD") 0^43^B33018689 "RTN","VAFHLZCD",1,0) VAFHLZCD ;ALB/KCL,Zoltan,JAN,TDM - Create HL7 Catastrophic Disability (ZCD) segment ; 9/19/05 11:31am "RTN","VAFHLZCD",2,0) ;;5.3;Registration;**122,232,387,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZCD",3,0) ; "RTN","VAFHLZCD",4,0) ; "RTN","VAFHLZCD",5,0) ; This generic extrinsic function is designed to return the "RTN","VAFHLZCD",6,0) ; HL7 Catastrophic Disability (ZCD) segment. This segment "RTN","VAFHLZCD",7,0) ; contains VA-specific catastrophic disability information "RTN","VAFHLZCD",8,0) ; for a patient. "RTN","VAFHLZCD",9,0) ; "RTN","VAFHLZCD",10,0) EN(DFN,VAFSTR,VAFNUM,VAFHLQ,VAFHLFS) ; -- "RTN","VAFHLZCD",11,0) ; Entry point for creating HL7 Catastrophic Disability (ZCD) segment. "RTN","VAFHLZCD",12,0) ; "RTN","VAFHLZCD",13,0) ; Input(s): "RTN","VAFHLZCD",14,0) ; DFN - internal entry number of Patient (#2) file "RTN","VAFHLZCD",15,0) ; VAFSTR - (optional) string of fields requested, separated by "RTN","VAFHLZCD",16,0) ; commas. If not passed, return all data fields. "RTN","VAFHLZCD",17,0) ; VAFNUM - (optional) sequential number for SET ID (default=1) "RTN","VAFHLZCD",18,0) ; VAFHLQ - (optional) HL7 null variable "RTN","VAFHLZCD",19,0) ; VAFHLFS - (optional) HL7 field separator "RTN","VAFHLZCD",20,0) ; "RTN","VAFHLZCD",21,0) ; Performance Note: "RTN","VAFHLZCD",22,0) ; VAFCDLST - Optional array (created by MAKELST subroutine below.) "RTN","VAFHLZCD",23,0) ; In cases involving multiple ZCD segments, performance "RTN","VAFHLZCD",24,0) ; is enhanced by calling MAKELST to create this array "RTN","VAFHLZCD",25,0) ; before invoking this function. This may not apply "RTN","VAFHLZCD",26,0) ; in cases where BUILD is invoked to create multiple "RTN","VAFHLZCD",27,0) ; ZCD segments. "RTN","VAFHLZCD",28,0) ; "RTN","VAFHLZCD",29,0) ; Other optional input variables: "RTN","VAFHLZCD",30,0) ; HLQ - HL7 default value to use when a sequence is empty. "RTN","VAFHLZCD",31,0) ; HLFS - HL7 default primary delimiter (between sequences.) "RTN","VAFHLZCD",32,0) ; "RTN","VAFHLZCD",33,0) ; Output(s): "RTN","VAFHLZCD",34,0) ; String containing the desired components of the HL7 ZCD segment "RTN","VAFHLZCD",35,0) ; "RTN","VAFHLZCD",36,0) ; NOTE: "RTN","VAFHLZCD",37,0) ; In cases where multiple diagnoses, procedures, and/or conditions "RTN","VAFHLZCD",38,0) ; exist to support a status of CATASTROPHICALLY DISABLED, the "RTN","VAFHLZCD",39,0) ; MAKELST subroutine (see below) is invoked to serialize them "RTN","VAFHLZCD",40,0) ; (along with any related information) into separate ZCD "RTN","VAFHLZCD",41,0) ; segments. This function will return the text of a single "RTN","VAFHLZCD",42,0) ; ZCD segment based on the segment number in VAFNUM. "RTN","VAFHLZCD",43,0) ; "RTN","VAFHLZCD",44,0) N VAFCAT,VAFY,X,SETID,VALOK,SUB "RTN","VAFHLZCD",45,0) ; "RTN","VAFHLZCD",46,0) ; if VAFHLQ or VAFHLFS not passed, use default HL7 variables "RTN","VAFHLZCD",47,0) I $D(VAFHLQ)[0 S VAFHLQ=$G(HLQ) "RTN","VAFHLZCD",48,0) I $G(VAFHLFS)="" S VAFHLFS=$G(HLFS,"^") "RTN","VAFHLZCD",49,0) ; "RTN","VAFHLZCD",50,0) ; if set id not passed, use default "RTN","VAFHLZCD",51,0) S VAFNUM=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLZCD",52,0) ; "RTN","VAFHLZCD",53,0) ; if DFN not passed, exit "RTN","VAFHLZCD",54,0) I '$G(DFN) S VAFY=1 G ENQ "RTN","VAFHLZCD",55,0) ; "RTN","VAFHLZCD",56,0) ; get catastrophic disability info for a patient into VAFCAT "RTN","VAFHLZCD",57,0) I '$$GET^DGENCDA(DFN,.VAFCAT) S VAFY=1 G ENQ "RTN","VAFHLZCD",58,0) ; If sequence 13="Y" or "N", then sequences 2 through 6 are required. "RTN","VAFHLZCD",59,0) ; If sequence 13="" then sequences 2 through 6 should not be sent. "RTN","VAFHLZCD",60,0) S VALOK=1 "RTN","VAFHLZCD",61,0) I VAFCAT("VCD")'="" F SUB="REVDTE","BY","FACDET","DATE","METDET" I $G(VAFCAT(SUB))="" S VALOK=0 "RTN","VAFHLZCD",62,0) I 'VALOK F SUB="REVDTE","BY","FACDET","DATE","METDET","VCD" S VAFCAT(SUB)="" "RTN","VAFHLZCD",63,0) ; "RTN","VAFHLZCD",64,0) ; if VAFSTR not passed, return all data fields "RTN","VAFHLZCD",65,0) I $G(VAFSTR)="" S VAFSTR="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16" "RTN","VAFHLZCD",66,0) ; "RTN","VAFHLZCD",67,0) ; initialize output string and requested data fields "RTN","VAFHLZCD",68,0) S $P(VAFY,VAFHLFS,$L(VAFSTR,","))="" "RTN","VAFHLZCD",69,0) S VAFSTR=","_VAFSTR_"," "RTN","VAFHLZCD",70,0) ; "RTN","VAFHLZCD",71,0) ; Create a list to restrict multiple-valued fields to separate "RTN","VAFHLZCD",72,0) ; segments. For example, if there are any DIAG, PROC and COND "RTN","VAFHLZCD",73,0) ; entries, then no two of those values (or their associated sub- "RTN","VAFHLZCD",74,0) ; fields) may occupy the same ZCD segment. (See MAKELST below "RTN","VAFHLZCD",75,0) ; for implementation details.) "RTN","VAFHLZCD",76,0) I '$D(VAFCDLST) N VAFCDLST D MAKELST(.VAFCDLST,.VAFCAT) "RTN","VAFHLZCD",77,0) ; "RTN","VAFHLZCD",78,0) ; set-up segment data fields "RTN","VAFHLZCD",79,0) ; 1 - Set ID "RTN","VAFHLZCD",80,0) S SETID=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLZCD",81,0) S $P(VAFY,VAFHLFS,1)=SETID "RTN","VAFHLZCD",82,0) ; 2 - Review Date "RTN","VAFHLZCD",83,0) I VAFSTR[",2," S $P(VAFY,VAFHLFS,2)=$S(VAFCAT("REVDTE")'="":$$HLDATE^HLFNC(VAFCAT("REVDTE")),1:VAFHLQ) "RTN","VAFHLZCD",84,0) ; 3 - Decided By "RTN","VAFHLZCD",85,0) I VAFSTR[",3," S $P(VAFY,VAFHLFS,3)=$S(VAFCAT("BY")'="":VAFCAT("BY"),1:VAFHLQ) "RTN","VAFHLZCD",86,0) ; 4 - Facility Making Determination "RTN","VAFHLZCD",87,0) I VAFSTR[",4," S X=$$STATION^VAFHLFNC(VAFCAT("FACDET")) S $P(VAFY,VAFHLFS,4)=$S(X'="":X,1:VAFHLQ) "RTN","VAFHLZCD",88,0) ; 5 - Date of Decision "RTN","VAFHLZCD",89,0) I VAFSTR[",5," S $P(VAFY,VAFHLFS,5)=$S(VAFCAT("DATE")'="":$$HLDATE^HLFNC(VAFCAT("DATE")),1:VAFHLQ) "RTN","VAFHLZCD",90,0) ; 6 - Method of Determination "RTN","VAFHLZCD",91,0) I VAFSTR[",6," S $P(VAFY,VAFHLFS,6)=$S(VAFCAT("METDET")'="":$$METH2HL7^DGENA5(VAFCAT("METDET")),1:VAFHLQ) "RTN","VAFHLZCD",92,0) ; 7 - Diagnosis (multiple) "RTN","VAFHLZCD",93,0) I VAFSTR[",7," S $P(VAFY,VAFHLFS,7)=$S($G(VAFCDLST(SETID,"DIAG"))'="":$$RSNTOHL7^DGENA5(VAFCDLST(SETID,"DIAG")),1:VAFHLQ) "RTN","VAFHLZCD",94,0) ; 8 - Procedure (multiple) "RTN","VAFHLZCD",95,0) I VAFSTR[",8," S $P(VAFY,VAFHLFS,8)=$S($G(VAFCDLST(SETID,"PROC"))'="":$$RSNTOHL7^DGENA5(VAFCDLST(SETID,"PROC")),1:VAFHLQ) "RTN","VAFHLZCD",96,0) ; 9 - Affected Extremity (Procedure sub-field) "RTN","VAFHLZCD",97,0) I VAFSTR[",9," S $P(VAFY,VAFHLFS,9)=$S($G(VAFCDLST(SETID,"EXT"))'="":$$LIMBTOHL^DGENA5(VAFCDLST(SETID,"EXT")),1:VAFHLQ) "RTN","VAFHLZCD",98,0) ; 10 - Condition (multiple) "RTN","VAFHLZCD",99,0) I VAFSTR[",10," S $P(VAFY,VAFHLFS,10)=$S($G(VAFCDLST(SETID,"COND"))'="":$$RSNTOHL7^DGENA5(VAFCDLST(SETID,"COND")),1:VAFHLQ) "RTN","VAFHLZCD",100,0) ; 11 - Score (Condition sub-field) "RTN","VAFHLZCD",101,0) I VAFSTR[",11," S $P(VAFY,VAFHLFS,11)=$S($G(VAFCDLST(SETID,"SCORE"))'="":VAFCDLST(SETID,"SCORE"),1:VAFHLQ) "RTN","VAFHLZCD",102,0) ; 12 - Veteran Catastrophically Disabled? "RTN","VAFHLZCD",103,0) I VAFSTR[",12," S $P(VAFY,VAFHLFS,12)=$S(VAFCAT("VCD")'="":VAFCAT("VCD"),1:VAFHLQ) "RTN","VAFHLZCD",104,0) ; 13 - Permanent Indicator (Condition sub-field) "RTN","VAFHLZCD",105,0) I VAFSTR[",13," S $P(VAFY,VAFHLFS,13)=$S($G(VAFCDLST(SETID,"PERM"))'="":$$PERMTOHL^DGENA5(VAFCDLST(SETID,"PERM")),1:VAFHLQ) "RTN","VAFHLZCD",106,0) ; 14 - Date Veteran Requested CD Evaluation "RTN","VAFHLZCD",107,0) I VAFSTR[",14," S $P(VAFY,VAFHLFS,14)=$S(VAFCAT("VETREQDT")'="":$$HLDATE^HLFNC(VAFCAT("VETREQDT")),1:VAFHLQ) "RTN","VAFHLZCD",108,0) ; 15 - Date Facility Initiated Review "RTN","VAFHLZCD",109,0) I VAFSTR[",15," S $P(VAFY,VAFHLFS,15)=$S(VAFCAT("DTFACIRV")'="":$$HLDATE^HLFNC(VAFCAT("DTFACIRV")),1:VAFHLQ) "RTN","VAFHLZCD",110,0) ; 16 - Date Veteran Was Notified "RTN","VAFHLZCD",111,0) I VAFSTR[",16," S $P(VAFY,VAFHLFS,16)=$S(VAFCAT("DTVETNOT")'="":$$HLDATE^HLFNC(VAFCAT("DTVETNOT")),1:VAFHLQ) "RTN","VAFHLZCD",112,0) ; "RTN","VAFHLZCD",113,0) S:$E(VAFSTR,1)="," VAFSTR=$E(VAFSTR,2,$L(VAFSTR)) "RTN","VAFHLZCD",114,0) S:$E(VAFSTR,$L(VAFSTR))="," VAFSTR=$E(VAFSTR,1,$L(VAFSTR)-1) "RTN","VAFHLZCD",115,0) ENQ Q "ZCD"_VAFHLFS_$G(VAFY) "RTN","VAFHLZCD",116,0) ; "RTN","VAFHLZCD",117,0) ; Subroutines follow... "RTN","VAFHLZCD",118,0) MAKELST(VAFCDLST,VAFCAT) ; Make list of ZCD Segments. "RTN","VAFHLZCD",119,0) ; Inputs: "RTN","VAFHLZCD",120,0) ; VAFCDLST - By reference (used to hold output array.) "RTN","VAFHLZCD",121,0) ; VAFCAT - By reference, an array containing the patient's CD "RTN","VAFHLZCD",122,0) ; data (as created in $$GET^DGENCDA). "RTN","VAFHLZCD",123,0) ; Output: "RTN","VAFHLZCD",124,0) ; VAFCDLST(Segment#,"DIAG") = CD Diagnosis (pointer to #27.17). "RTN","VAFHLZCD",125,0) ; VAFCDLST(Segment#,"PROC")= CD Procedure(pointer to #27.17). "RTN","VAFHLZCD",126,0) ; VAFCDLST(Segment#,"EXT") = Affected Extremity (for procedure). "RTN","VAFHLZCD",127,0) ; VAFCDLST(Segment#,"COND")= CD Condition (pointer to #27.17). "RTN","VAFHLZCD",128,0) ; VAFCDLST(Segment#,"PERM") = Permanent Indicator (for condition). "RTN","VAFHLZCD",129,0) ; VAFCDLST(Segment#,"SCORE") = Test Score (for condition). "RTN","VAFHLZCD",130,0) ; "RTN","VAFHLZCD",131,0) ; Per Enrollment Phase II SRS (Section 4.2.4) no ZCD segment should "RTN","VAFHLZCD",132,0) ; contain more than one CD Reason (Diagnosis, Procedure, Condition.) "RTN","VAFHLZCD",133,0) ; So this procedure adds each one as a separate ZCD segment. "RTN","VAFHLZCD",134,0) ; "RTN","VAFHLZCD",135,0) N ITEM,SITEM,STR "RTN","VAFHLZCD",136,0) K VAFCDLST "RTN","VAFHLZCD",137,0) S VAFCDLST=0 "RTN","VAFHLZCD",138,0) S (ITEM,SITEM)="" "RTN","VAFHLZCD",139,0) ; Add each Diagnosis as a separate ZCD segment. "RTN","VAFHLZCD",140,0) F S ITEM=$O(VAFCAT("DIAG",ITEM)) Q:ITEM="" D "RTN","VAFHLZCD",141,0) . D ADDNEW(.VAFCDLST,"DIAG",VAFCAT("DIAG",ITEM)) "RTN","VAFHLZCD",142,0) ; Add each Procedure as a separate ZCD segment. "RTN","VAFHLZCD",143,0) F S ITEM=$O(VAFCAT("PROC",ITEM)) Q:ITEM="" D "RTN","VAFHLZCD",144,0) . F S SITEM=$O(VAFCAT("EXT",ITEM,SITEM)) Q:SITEM="" D "RTN","VAFHLZCD",145,0) .. D ADDNEW(.VAFCDLST,"PROC",VAFCAT("PROC",ITEM)) "RTN","VAFHLZCD",146,0) .. D INSERT(.VAFCDLST,"EXT",VAFCAT("EXT",ITEM,SITEM)) "RTN","VAFHLZCD",147,0) ; Add each Condition as a separate ZCD segment. "RTN","VAFHLZCD",148,0) F S ITEM=$O(VAFCAT("COND",ITEM)) Q:ITEM="" D "RTN","VAFHLZCD",149,0) . D ADDNEW(.VAFCDLST,"COND",VAFCAT("COND",ITEM)) "RTN","VAFHLZCD",150,0) . D INSERT(.VAFCDLST,"SCORE",VAFCAT("SCORE",ITEM)) "RTN","VAFHLZCD",151,0) . D INSERT(.VAFCDLST,"PERM",VAFCAT("PERM",ITEM)) "RTN","VAFHLZCD",152,0) I VAFCDLST=0 S VAFCDLST=1 ; At least one ZCD segment. "RTN","VAFHLZCD",153,0) Q "RTN","VAFHLZCD",154,0) ADDNEW(LIST,NAME,ITEM) ; Add an item to the list (internal use only). "RTN","VAFHLZCD",155,0) ; Inputs: "RTN","VAFHLZCD",156,0) ; LIST - By reference, a list of items. "RTN","VAFHLZCD",157,0) ; NAME - Name of one item to add. "RTN","VAFHLZCD",158,0) ; ITEM - Value of item to add. "RTN","VAFHLZCD",159,0) ; Note: a new position is created in the list. "RTN","VAFHLZCD",160,0) S LIST=LIST+1 "RTN","VAFHLZCD",161,0) S LIST(LIST,NAME)=ITEM "RTN","VAFHLZCD",162,0) Q "RTN","VAFHLZCD",163,0) INSERT(LIST,NAME,ITEM) ; Insert item into existing list position (internal). "RTN","VAFHLZCD",164,0) ; LIST - By reference, a list of items. "RTN","VAFHLZCD",165,0) ; NAME - Name of one item to add. "RTN","VAFHLZCD",166,0) ; ITEM - Value of item to add. "RTN","VAFHLZCD",167,0) ; Note: the list should already contain at least one item. "RTN","VAFHLZCD",168,0) S LIST(LIST,NAME)=ITEM "RTN","VAFHLZCD",169,0) Q "RTN","VAFHLZCD",170,0) BUILD(VAFSEGS,DFN,VAFSTR,VAFHLQ,VAFHLFS) ; "RTN","VAFHLZCD",171,0) ; Entry point for creating HL7 Catastrophic Disability (ZCD) segments. "RTN","VAFHLZCD",172,0) ; This is the preferred entry point for building ZCD segments. "RTN","VAFHLZCD",173,0) ; "RTN","VAFHLZCD",174,0) ; Input(s): "RTN","VAFHLZCD",175,0) ; VAFSEGS - Pass-by-reference array to contain all ZCD segments "RTN","VAFHLZCD",176,0) ; for this patient. "RTN","VAFHLZCD",177,0) ; DFN - internal entry number of Patient (#2) file "RTN","VAFHLZCD",178,0) ; VAFSTR - (optional) string of fields requested, separated by "RTN","VAFHLZCD",179,0) ; commas. If not passed, return all data fields. "RTN","VAFHLZCD",180,0) ; VAFHLQ - (optional) HL7 null variable "RTN","VAFHLZCD",181,0) ; VAFHLFS - (optional) HL7 field separator "RTN","VAFHLZCD",182,0) ; "RTN","VAFHLZCD",183,0) ; Output: "RTN","VAFHLZCD",184,0) ; VAFSEGS - By reference, an array containing all ZCD segments. "RTN","VAFHLZCD",185,0) ; Format: VAFSEGS = Number of ZCD Segments "RTN","VAFHLZCD",186,0) ; VAFSEGS(1) = First ZCD Segment "RTN","VAFHLZCD",187,0) ; VAFSEGS(2) = Second ZCD Segment (if any)... "RTN","VAFHLZCD",188,0) ; etc. "RTN","VAFHLZCD",189,0) ; "RTN","VAFHLZCD",190,0) ; NOTE: "RTN","VAFHLZCD",191,0) ; Per Enrollment Phase II SRS (Section 4.2.4) no ZCD segment should "RTN","VAFHLZCD",192,0) ; contain more than one CD Reason (Diagnosis, Procedure, Condition.) "RTN","VAFHLZCD",193,0) ; As a result, multiple ZCD segments will be created if more than "RTN","VAFHLZCD",194,0) ; one of these fields has a value. The MAKELST procedure contains "RTN","VAFHLZCD",195,0) ; logic to enforce this requirement. "RTN","VAFHLZCD",196,0) ; "RTN","VAFHLZCD",197,0) N VAFCDLST ; Temporary array of CD REASON info. "RTN","VAFHLZCD",198,0) K VAFSEGS S VAFSEGS=0 ; Initialize array. "RTN","VAFHLZCD",199,0) ; DFN is required. "RTN","VAFHLZCD",200,0) I '$G(DFN) Q "RTN","VAFHLZCD",201,0) ; get catastrophic disability info for a patient into VAFCAT "RTN","VAFHLZCD",202,0) I '$$GET^DGENCDA(DFN,.VAFCAT) Q "RTN","VAFHLZCD",203,0) ; Create a list VAFCDLST to enforce one CD REASON per segment. "RTN","VAFHLZCD",204,0) D MAKELST(.VAFCDLST,.VAFCAT) "RTN","VAFHLZCD",205,0) I 'VAFCDLST Q "RTN","VAFHLZCD",206,0) ; Create an array of HL7 segments. "RTN","VAFHLZCD",207,0) F VAFSEGS=1:1:VAFCDLST S VAFSEGS(VAFSEGS)=$$EN(DFN,.VAFSTR,VAFSEGS,.VAFHLQ,.VAFHLFS) "RTN","VAFHLZCD",208,0) Q "RTN","VAFHLZCT") 0^1^B8791571 "RTN","VAFHLZCT",1,0) VAFHLZCT ;ALB/ESD,TDM - Creation of ZCT segment ; 9/19/05 11:44am "RTN","VAFHLZCT",2,0) ;;5.3;Registration;**68,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZCT",3,0) ; "RTN","VAFHLZCT",4,0) ; This generic extrinsic function transfers information pertaining to "RTN","VAFHLZCT",5,0) ; a patient's next of kin through the Emergency Contact (ZCT) segment. "RTN","VAFHLZCT",6,0) ; "RTN","VAFHLZCT",7,0) ; "RTN","VAFHLZCT",8,0) EN(DFN,VAFSTR,VAFNUM,VAFTYPE,VAFNAMFT) ;function returns ZCT segment containing emergency contact info. "RTN","VAFHLZCT",9,0) ; "RTN","VAFHLZCT",10,0) ; Input: "RTN","VAFHLZCT",11,0) ; DFN -- Internal entry number of the PATIENT file. "RTN","VAFHLZCT",12,0) ; VAFSTR -- String of fields requested separated by commas "RTN","VAFHLZCT",13,0) ; VAFNUM -- Set Id (sequential number-if not passed, set to 1). "RTN","VAFHLZCT",14,0) ; VAFTYPE -- Contact type to determine type of data returned "RTN","VAFHLZCT",15,0) ; (1=NOK, 2=2nd NOK, 3=Emer Cont, 4=2nd Emer Cont, "RTN","VAFHLZCT",16,0) ; 5=Designee). "RTN","VAFHLZCT",17,0) ; VAFNAMFT -- Flag indicating to format the name field (SEQ-3) "RTN","VAFHLZCT",18,0) ; to HL7 XPN data type.(1=Format, 0=Do Not Format) "RTN","VAFHLZCT",19,0) ; "RTN","VAFHLZCT",20,0) ; Output: String of components forming ZCT segment. "RTN","VAFHLZCT",21,0) ; "RTN","VAFHLZCT",22,0) ; ****Also assumes all HL7 variables returned from**** "RTN","VAFHLZCT",23,0) ; INIT^HLTRANS are defined. "RTN","VAFHLZCT",24,0) ; "RTN","VAFHLZCT",25,0) N VAFNODE,VAFCNODE,X,X1,VAFY "RTN","VAFHLZCT",26,0) I '$G(DFN)!($G(VAFSTR)']"") G QUIT "RTN","VAFHLZCT",27,0) S $P(VAFY,HLFS,9)="",VAFSTR=","_VAFSTR_"," "RTN","VAFHLZCT",28,0) I "^1^2^3^4^5^"'[("^"_$G(VAFTYPE)_"^") S VAFTYPE=1 "RTN","VAFHLZCT",29,0) I $G(VAFNAMFT)<1 S VAFNAMFT=0 "RTN","VAFHLZCT",30,0) S VAFNODE=$P($T(TYPE+VAFTYPE),";;",2),VAFCNODE=$G(^DPT(DFN,VAFNODE)) "RTN","VAFHLZCT",31,0) S $P(VAFY,HLFS,1)=$S($G(VAFNUM):+VAFNUM\1,1:1) ; If Set Id not passed in, set to 1 "RTN","VAFHLZCT",32,0) S $P(VAFY,HLFS,2)=VAFTYPE ; Contact Type "RTN","VAFHLZCT",33,0) I VAFSTR[",3," D ;Name of Next of Kin "RTN","VAFHLZCT",34,0) . S X=$P(VAFCNODE,"^",1) "RTN","VAFHLZCT",35,0) . I VAFNAMFT D "RTN","VAFHLZCT",36,0) . . S X=$$HLNAME^XLFNAME(X,"",$E(HL("ECH"),1)) "RTN","VAFHLZCT",37,0) . . I X'="",$P(X,$E(HL("ECH"),1),7)'="L" S $P(X,$E(HL("ECH"),1),7)="L" "RTN","VAFHLZCT",38,0) . S $P(VAFY,HLFS,3)=$S(X]"":X,1:HLQ) "RTN","VAFHLZCT",39,0) I VAFSTR[",4," S X=$P(VAFCNODE,"^",2),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Relationship to Patient "RTN","VAFHLZCT",40,0) I VAFSTR[",5," D "RTN","VAFHLZCT",41,0) . S X1=$G(^DPT(DFN,.22)) "RTN","VAFHLZCT",42,0) . S X=$$ADDR^VAFHLFNC($P(VAFCNODE,"^",3,7)_"^"_$P(X1,"^",$P($T(TYPE+VAFTYPE),";;",3))) "RTN","VAFHLZCT",43,0) . S $P(VAFY,HLFS,5)=$S(X]"":$P(X,HLFS,1),1:HLQ) ; Next of Kin address "RTN","VAFHLZCT",44,0) ; "RTN","VAFHLZCT",45,0) I VAFSTR[",6," S X=$$HLPHONE^HLFNC($P(VAFCNODE,"^",9)),$P(VAFY,HLFS,6)=$S(X]"":X,1:HLQ) ; Home Phone "RTN","VAFHLZCT",46,0) I VAFSTR[",7," S X=$$HLPHONE^HLFNC($P(VAFCNODE,"^",11)),$P(VAFY,HLFS,7)=$S(X]"":X,1:HLQ) ; Work Phone "RTN","VAFHLZCT",47,0) S X=$P(VAFCNODE,"^",10) ;Get this piece for next two fields "RTN","VAFHLZCT",48,0) I VAFSTR[",8," S $P(VAFY,HLFS,8)=$S(VAFTYPE=1!(VAFTYPE=2):$$YN^VAFHLFNC(X),1:HLQ) ; Contact Address Same as NOK? "RTN","VAFHLZCT",49,0) I VAFSTR[",9," S $P(VAFY,HLFS,9)=$S(VAFTYPE=3!(VAFTYPE=5):$$YN^VAFHLFNC(X),1:HLQ) ; Contact Person Same as NOK? "RTN","VAFHLZCT",50,0) I VAFSTR[",10," D ; Last Date/Time Updated "RTN","VAFHLZCT",51,0) . Q:((VAFTYPE'=1)&(VAFTYPE'=2)) ; Currently only available for type 1 & 2 "RTN","VAFHLZCT",52,0) . S X=$P($G(^DPT(DFN,.212)),"^",VAFTYPE) "RTN","VAFHLZCT",53,0) . S $P(VAFY,HLFS,10)=$S(X'="":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZCT",54,0) QUIT Q "ZCT"_HLFS_$G(VAFY) "RTN","VAFHLZCT",55,0) TYPE ; Corresponding nodes for emergency contact type and ZIP+4 field piece. "RTN","VAFHLZCT",56,0) ;;.21;;7 "RTN","VAFHLZCT",57,0) ;;.211;;3 "RTN","VAFHLZCT",58,0) ;;.33;;1 "RTN","VAFHLZCT",59,0) ;;.331;;4 "RTN","VAFHLZCT",60,0) ;;.34;;2 "RTN","VAFHLZDP") 0^2^B5724563 "RTN","VAFHLZDP",1,0) VAFHLZDP ;ALB/MLI,TDM - Creates HL7 segments ZDP and/or ZIC ; 9/26/05 3:32pm "RTN","VAFHLZDP",2,0) ;;5.3;Registration;**33,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZDP",3,0) ; "RTN","VAFHLZDP",4,0) ; This routine will return the ZDP (dependent) segment for the "RTN","VAFHLZDP",5,0) ; dependent specified by the variable VAFIEN. "RTN","VAFHLZDP",6,0) ; "RTN","VAFHLZDP",7,0) EN(VAFIEN,VAFSTR,VAFNUM,VAFMTDT) ; Call to produce ZDP segment for given individual "RTN","VAFHLZDP",8,0) ; "RTN","VAFHLZDP",9,0) ; "RTN","VAFHLZDP",10,0) ; Input: VAFIEN as IEN of PATIENT RELATION (#408.12) file "RTN","VAFHLZDP",11,0) ; VAFSTR as string of desired fields separated by commas "RTN","VAFHLZDP",12,0) ; VAFNUM as the number desired for the set id (default = 1) "RTN","VAFHLZDP",13,0) ; VAFMTDT as the date of the means test (default = DT) "RTN","VAFHLZDP",14,0) ; "RTN","VAFHLZDP",15,0) ; Output: String of fields forming HL7 ZDP segment "RTN","VAFHLZDP",16,0) ; "RTN","VAFHLZDP",17,0) N NODE,NODE0,X,VAFY,NODE1 "RTN","VAFHLZDP",18,0) S NODE=$$DEM^DGMTU1(+$G(VAFIEN)) "RTN","VAFHLZDP",19,0) I $G(VAFSTR)']"" G QUIT "RTN","VAFHLZDP",20,0) S $P(VAFY,HLFS,7)="",VAFSTR=","_VAFSTR_"," "RTN","VAFHLZDP",21,0) S $P(VAFY,HLFS,1)=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLZDP",22,0) S VAFMTDT=$S($G(VAFMTDT):VAFMTDT,1:DT) "RTN","VAFHLZDP",23,0) I VAFSTR[",2," S X=$$HLNAME^HLFNC($P(NODE,"^",1)),$P(VAFY,HLFS,2)=$S(X]"":X,1:HLQ) ; name "RTN","VAFHLZDP",24,0) I VAFSTR[",3," S $P(VAFY,HLFS,3)=$S($P(NODE,"^",2)]"":$P(NODE,"^",2),1:HLQ) ; sex "RTN","VAFHLZDP",25,0) I VAFSTR[",4," S X=$$HLDATE^HLFNC($P(NODE,"^",3)),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; dob "RTN","VAFHLZDP",26,0) I VAFSTR[",5," S $P(VAFY,HLFS,5)=$S($P(NODE,"^",9)]"":$P(NODE,"^",9),1:HLQ) ; ssn "RTN","VAFHLZDP",27,0) I VAFSTR[",6," D "RTN","VAFHLZDP",28,0) .S NODE0=$G(^DGPR(408.12,+$G(VAFIEN),0)) "RTN","VAFHLZDP",29,0) .S $P(VAFY,HLFS,6)=$S($P(NODE0,"^",2)]"":$P(NODE0,"^",2),1:HLQ) ; relationship to patient "RTN","VAFHLZDP",30,0) I VAFSTR[",7," S $P(VAFY,HLFS,7)=+$G(VAFIEN) ; internal entry number "RTN","VAFHLZDP",31,0) I VAFSTR[",8,",$$REL^DGMTU1(VAFIEN)="SPOUSE" D "RTN","VAFHLZDP",32,0) .S NODE1=$$NODE1(+$G(VAFIEN)) "RTN","VAFHLZDP",33,0) .S $P(VAFY,HLFS,8)=$S($P(NODE1,"^")]"":$P(NODE1,"^"),1:HLQ) ; spouse's maiden name "RTN","VAFHLZDP",34,0) I VAFSTR[",9," D "RTN","VAFHLZDP",35,0) .S X=-($E(VAFMTDT,1,3)-1_"1231.9"),X=-$O(^DGPR(408.12,+$G(VAFIEN),"E","AID",X)) "RTN","VAFHLZDP",36,0) .S X=$$HLDATE^HLFNC(X),$P(VAFY,HLFS,9)=$S(X]"":X,1:HLQ) ; effective date "RTN","VAFHLZDP",37,0) I VAFSTR[",10," S $P(VAFY,HLFS,10)=$S($P(NODE,"^",10)]"":$P(NODE,"^",10),1:HLQ) ; pseudo ssn reason "RTN","VAFHLZDP",38,0) ; "RTN","VAFHLZDP",39,0) QUIT Q "ZDP"_HLFS_$G(VAFY) "RTN","VAFHLZDP",40,0) ; "RTN","VAFHLZDP",41,0) NODE1(DGPRI) ;GET Node 1 of Patient Relation "RTN","VAFHLZDP",42,0) N DGVPI,DGVP1 "RTN","VAFHLZDP",43,0) S DGVPI=$P($G(^DGPR(408.12,DGPRI,0)),"^",3) "RTN","VAFHLZDP",44,0) I DGVPI]"" S DGVP1=$G(@("^"_$P(DGVPI,";",2)_+DGVPI_",1)")) "RTN","VAFHLZDP",45,0) Q $S($G(DGVP1)]"":DGVP1,1:"") "RTN","VAFHLZE1") 0^3^B25671247 "RTN","VAFHLZE1",1,0) VAFHLZE1 ;BPFO/JRP,TDM - Data extractor for ZEL segment ; 5/24/06 3:43pm "RTN","VAFHLZE1",2,0) ;;5.3;Registration;**342,497,602,672,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZE1",3,0) ; "RTN","VAFHLZE1",4,0) GETDATA ;Get information needed to build ZEL segment "RTN","VAFHLZE1",5,0) ;Input: Existance of the following variables is assumed "RTN","VAFHLZE1",6,0) ; DFN - Pointer to Patient (#2) file "RTN","VAFHLZE1",7,0) ; VAFPELIG - Primary Eligibility string (.36 node) "RTN","VAFHLZE1",8,0) ; VAFSTR - Fields to extract (padded with commas) "RTN","VAFHLZE1",9,0) ; VAFNODE - Eligibility Node (node from Elig. ["E"] mult) "RTN","VAFHLZE1",10,0) ; VAFMSTDT - Date to use when getting MST status (optional) "RTN","VAFHLZE1",11,0) ; VAFSETID - Value to use for Set ID (optional) "RTN","VAFHLZE1",12,0) ; HL7 encoding characters (HLFS, HLENC, HLQ) "RTN","VAFHLZE1",13,0) ; "RTN","VAFHLZE1",14,0) ;Output: VAFHLZEL(SeqNum) = Value "RTN","VAFHLZE1",15,0) ; "RTN","VAFHLZE1",16,0) ;Notes: VAFHLZEL is initialized (KILLed) on entry "RTN","VAFHLZE1",17,0) ; : If not passed, sequence 1 (Set ID) will have a value of '1' "RTN","VAFHLZE1",18,0) ; if getting data for the primary eligibility and '2' if getting "RTN","VAFHLZE1",19,0) ; data for other eligibility "RTN","VAFHLZE1",20,0) ; : All requested fields will be returned with the primary "RTN","VAFHLZE1",21,0) ; eligibility. The Set ID (seq 1), eligibility code (seq 2) "RTN","VAFHLZE1",22,0) ; long ID (seq 3), and short ID (seq 4) will be the only fields "RTN","VAFHLZE1",23,0) ; returned for all other eligibilities. "RTN","VAFHLZE1",24,0) ; "RTN","VAFHLZE1",25,0) N PRIME,VAF,VAFMST,X "RTN","VAFHLZE1",26,0) K VAFHLZEL "RTN","VAFHLZE1",27,0) ;If true, primary eligibility (return all fields) "RTN","VAFHLZE1",28,0) S PRIME=+VAFNODE=+VAFPELIG "RTN","VAFHLZE1",29,0) ;Set ID "RTN","VAFHLZE1",30,0) I VAFSTR[",1," S VAFHLZEL(1)=$S($G(VAFSETID):VAFSETID,PRIME:1,1:2) "RTN","VAFHLZE1",31,0) ;Eligibility Code "RTN","VAFHLZE1",32,0) I VAFSTR[",2," S X=$P($G(^DIC(8,+VAFNODE,0)),"^",9),VAFHLZEL(2)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",33,0) ;Long ID "RTN","VAFHLZE1",34,0) I VAFSTR[",3," S X=$P(VAFNODE,"^",3),VAFHLZEL(3)=$S(X]"":$$M10^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",35,0) ;Short ID "RTN","VAFHLZE1",36,0) I VAFSTR[",4," S X=$P(VAFNODE,"^",4),VAFHLZEL(4)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",37,0) ;Done if not getting primary eligibility information "RTN","VAFHLZE1",38,0) I 'PRIME D Q "RTN","VAFHLZE1",39,0) .N Y,Z "RTN","VAFHLZE1",40,0) .S Y=$L(VAFSTR,",") "RTN","VAFHLZE1",41,0) .F X=1:1:Y S Z=$P(VAFSTR,",",X) I Z S:(Z>4) VAFHLZEL(Z)=HLQ "RTN","VAFHLZE1",42,0) ;Get needed nodes in Patient file (#2) "RTN","VAFHLZE1",43,0) N VAF "RTN","VAFHLZE1",44,0) F X=.3,.31,.321,.322,.362,.361 S VAF(X)=$G(^DPT(DFN,X)) "RTN","VAFHLZE1",45,0) ;Military Disability Retirement "RTN","VAFHLZE1",46,0) I VAFSTR[",5," S X=$P(VAFPELIG,"^",12),VAFHLZEL(5)=$S(X=0:"N",X=1:"Y",1:HLQ) "RTN","VAFHLZE1",47,0) ;Claim Number "RTN","VAFHLZE1",48,0) I VAFSTR[",6," S X=$P(VAF(.31),"^",3),VAFHLZEL(6)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",49,0) ;Claim Folder Loc "RTN","VAFHLZE1",50,0) I VAFSTR[",7," S X=$P(VAF(.31),"^",2),VAFHLZEL(7)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",51,0) ;Veteran? "RTN","VAFHLZE1",52,0) I VAFSTR[",8," S X=$P($G(^DPT(DFN,"VET")),"^"),VAFHLZEL(8)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",53,0) ;Type "RTN","VAFHLZE1",54,0) I VAFSTR[",9," S X=$P($G(^DG(391,+$P($G(^DPT(DFN,"TYPE")),"^"),0)),"^"),VAFHLZEL(9)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",55,0) ;Elig Status "RTN","VAFHLZE1",56,0) I VAFSTR[10 S X=$P(VAF(.361),"^",1),VAFHLZEL(10)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",57,0) ;Elig Status Date "RTN","VAFHLZE1",58,0) I VAFSTR[11 S X=$P(VAF(.361),"^",2),VAFHLZEL(11)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",59,0) ;Elig Interim Response "RTN","VAFHLZE1",60,0) I VAFSTR[12 S X=$P(VAF(.361),"^",4),VAFHLZEL(12)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",61,0) ;Elig Verif. Method "RTN","VAFHLZE1",62,0) I VAFSTR[13 S X=$P(VAF(.361),"^",5),VAFHLZEL(13)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",63,0) ;Rec A&A Benefits? "RTN","VAFHLZE1",64,0) I VAFSTR[14 S X=$P(VAF(.362),"^",12),VAFHLZEL(14)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",65,0) ;Rec Housebound Benefits? "RTN","VAFHLZE1",66,0) I VAFSTR[15 S X=$P(VAF(.362),"^",13),VAFHLZEL(15)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",67,0) ;Rec VA Pension? "RTN","VAFHLZE1",68,0) I VAFSTR[16 S X=$P(VAF(.362),"^",14),VAFHLZEL(16)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",69,0) ;Rec VA Disability? "RTN","VAFHLZE1",70,0) I VAFSTR[17 S X=$P(VAF(.3),"^",11),VAFHLZEL(17)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",71,0) ;Agent Orange Expos. Indicated? "RTN","VAFHLZE1",72,0) I VAFSTR[18 S X=$P(VAF(.321),"^",2),VAFHLZEL(18)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",73,0) ;Radiation Expos. Indicated? "RTN","VAFHLZE1",74,0) I VAFSTR[19 S X=$P(VAF(.321),"^",3),VAFHLZEL(19)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",75,0) ;Environmental Contaminants? "RTN","VAFHLZE1",76,0) I VAFSTR[20 S X=$P(VAF(.322),"^",13),VAFHLZEL(20)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",77,0) ;Total Annual VA Check Amount "RTN","VAFHLZE1",78,0) I VAFSTR[21 S X=$P(VAF(.362),"^",20),VAFHLZEL(21)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",79,0) ;Radiation Exposure Method "RTN","VAFHLZE1",80,0) I (VAFSTR[22) D "RTN","VAFHLZE1",81,0) .S X=$P(VAF(.321),"^",12) "RTN","VAFHLZE1",82,0) .S:(X="")!($L(X)>1) X=HLQ "RTN","VAFHLZE1",83,0) .S:(X'=HLQ) X=$TR(X,"NTB","234") "RTN","VAFHLZE1",84,0) .S VAFHLZEL(22)=X "RTN","VAFHLZE1",85,0) ;Call MST status API "RTN","VAFHLZE1",86,0) S VAFMST=$$GETSTAT^DGMSTAPI(DFN,$G(VAFMSTDT)) "RTN","VAFHLZE1",87,0) I $P(VAFMST,"^",1)<0 D I 1 "RTN","VAFHLZE1",88,0) .F J=23,24,25 I VAFSTR[J S VAFHLZEL(J)=HLQ "RTN","VAFHLZE1",89,0) E D "RTN","VAFHLZE1",90,0) .;Current MST status "RTN","VAFHLZE1",91,0) .I VAFSTR[23 S X=$P(VAFMST,"^",2),VAFHLZEL(23)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",92,0) .;MST status change date "RTN","VAFHLZE1",93,0) .I VAFSTR[24 S X=$P(VAFMST,"^",3),VAFHLZEL(24)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",94,0) .;Site determining MST status "RTN","VAFHLZE1",95,0) .I VAFSTR[25 S X=$P(VAFMST,"^",7) S X=$$GET1^DIQ(4,(+X)_",",99) S VAFHLZEL(25)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",96,0) ;Agent Orange Registration Date "RTN","VAFHLZE1",97,0) I VAFSTR[26 S X=$P(VAF(.321),"^",7),VAFHLZEL(26)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",98,0) ;Agent Orange Exam Date "RTN","VAFHLZE1",99,0) I VAFSTR[27 S X=$P(VAF(.321),"^",9),VAFHLZEL(27)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",100,0) ;Agent Orange Registration # "RTN","VAFHLZE1",101,0) I VAFSTR[28 S X=$P(VAF(.321),"^",10),VAFHLZEL(28)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",102,0) ;Agent Orange Exposure Location "RTN","VAFHLZE1",103,0) ;I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(X]"":X,$P(VAF(.321),U,2)="Y":"U",1:HLQ) "RTN","VAFHLZE1",104,0) I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(",K,V,O,"[(","_X_","):X,1:HLQ) "RTN","VAFHLZE1",105,0) ;Radiation Registration Date "RTN","VAFHLZE1",106,0) I VAFSTR[30 S X=$P(VAF(.321),"^",11),VAFHLZEL(30)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",107,0) ;Envir. Cont. Exam Date "RTN","VAFHLZE1",108,0) I VAFSTR[31 S X=$P(VAF(.322),"^",15),VAFHLZEL(31)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",109,0) ;Envir. Cont. Registration date "RTN","VAFHLZE1",110,0) I VAFSTR[32 S X=$P(VAF(.322),"^",14),VAFHLZEL(32)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",111,0) ;Monetary Ben. Verify Date "RTN","VAFHLZE1",112,0) I VAFSTR[33 S X=$P(VAF(.3),"^",6),VAFHLZEL(33)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",113,0) ;User Enrollee Valid Through "RTN","VAFHLZE1",114,0) I VAFSTR[34 S X=$P(VAF(.361),"^",7),VAFHLZEL(34)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",115,0) ;User Enrollee Site "RTN","VAFHLZE1",116,0) I VAFSTR[35 S X=$P(VAF(.361),"^",8),X=$$GET1^DIQ(4,+X,99),VAFHLZEL(35)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",117,0) ;Combat Vet "RTN","VAFHLZE1",118,0) I (VAFSTR[37)!(VAFSTR[38) D "RTN","VAFHLZE1",119,0) .N CVET "RTN","VAFHLZE1",120,0) .S CVET=$$CVEDT^DGCV(DFN) "RTN","VAFHLZE1",121,0) .;Eligible "RTN","VAFHLZE1",122,0) .I VAFSTR[37 D "RTN","VAFHLZE1",123,0) ..S X=+CVET "RTN","VAFHLZE1",124,0) ..S:X<0 X="" "RTN","VAFHLZE1",125,0) ..S VAFHLZEL(37)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",126,0) .;End Date "RTN","VAFHLZE1",127,0) .I VAFSTR[38 D "RTN","VAFHLZE1",128,0) ..S X=+$P(CVET,"^",2) "RTN","VAFHLZE1",129,0) ..S VAFHLZEL(38)=$S(X:$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",130,0) ;Discharge Due To Disability "RTN","VAFHLZE1",131,0) I VAFSTR[39 S X=$P(VAFPELIG,"^",13),VAFHLZEL(39)=$S(X=0:"N",X=1:"Y",1:HLQ) "RTN","VAFHLZE1",132,0) ;SHAD Indicator "RTN","VAFHLZE1",133,0) I VAFSTR[40 S X=$P(VAF(.321),"^",15),VAFHLZEL(40)=$S(X=0:"N",X=1:"Y",1:HLQ) "RTN","VAFHLZE1",134,0) ;Done "RTN","VAFHLZE1",135,0) Q "RTN","VAFHLZIR") 0^4^B13611124 "RTN","VAFHLZIR",1,0) VAFHLZIR ;ALB/SEK,TDM - Create generic HL7 ZIR segment ; 9/19/05 11:47am "RTN","VAFHLZIR",2,0) ;;5.3;Registration;**33,94,151,466,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZIR",3,0) ; "RTN","VAFHLZIR",4,0) ; "RTN","VAFHLZIR",5,0) EN(VAFIEN,VAFSTR,VAFNUM,VAFENC) ; This generic extrinsic function was designed to "RTN","VAFHLZIR",6,0) ; return the HL7 ZIR segment. This segment contains "RTN","VAFHLZIR",7,0) ; VA-specific information pertaining to income relation type "RTN","VAFHLZIR",8,0) ; data for a veteran and any applicable relations. "RTN","VAFHLZIR",9,0) ; "RTN","VAFHLZIR",10,0) ; Input - VAFIEN as internal entry number of the INCOME RELATION file. "RTN","VAFHLZIR",11,0) ; VAFSTR as the string of fields requested seperated by commas. "RTN","VAFHLZIR",12,0) ; VAFNUM as the number desired for the SET ID (default = 1) "RTN","VAFHLZIR",13,0) ; VAFENC as Outpatient Encounter IEN (from file #409.68) "RTN","VAFHLZIR",14,0) ; "RTN","VAFHLZIR",15,0) ; NOTE: Input variable VAFENC was added as part of the Ambulatory "RTN","VAFHLZIR",16,0) ; Care Reporting project. "RTN","VAFHLZIR",17,0) ; "RTN","VAFHLZIR",18,0) ; *****Also assumes all HL7 variables returned from***** "RTN","VAFHLZIR",19,0) ; INIT^HLTRANS are defined. "RTN","VAFHLZIR",20,0) ; "RTN","VAFHLZIR",21,0) ; Output - String of data forming the ZIR segment. "RTN","VAFHLZIR",22,0) ; "RTN","VAFHLZIR",23,0) ; "RTN","VAFHLZIR",24,0) N VAFDFN,VAFERR,VAFENODE,VAFNODE,VAFY,X "RTN","VAFHLZIR",25,0) I $G(VAFSTR)']"" G QUIT "RTN","VAFHLZIR",26,0) S VAFENC=+$G(VAFENC) "RTN","VAFHLZIR",27,0) I '$G(VAFIEN)&('VAFENC) G QUIT "RTN","VAFHLZIR",28,0) S $P(VAFY,HLFS,14)="",VAFSTR=","_VAFSTR_"," "RTN","VAFHLZIR",29,0) S VAFNODE=$G(^DGMT(408.22,+$G(VAFIEN),0)) "RTN","VAFHLZIR",30,0) I $G(VAFNODE)']""&('VAFENC) G QUIT "RTN","VAFHLZIR",31,0) S $P(VAFY,HLFS,1)=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLZIR",32,0) I VAFSTR[",2," S $P(VAFY,HLFS,2)=$$YN^VAFHLFNC($P(VAFNODE,"^",5)) ; Married last calendar year "RTN","VAFHLZIR",33,0) I VAFSTR[",3," S $P(VAFY,HLFS,3)=$$YN^VAFHLFNC($P(VAFNODE,"^",6)) ; Lived with patient "RTN","VAFHLZIR",34,0) I VAFSTR[",4," S X=$P(VAFNODE,"^",7),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Amount contributed to spouse "RTN","VAFHLZIR",35,0) I VAFSTR[",5," S $P(VAFY,HLFS,5)=$$YN^VAFHLFNC($P(VAFNODE,"^",8)) ; Dependent children (y/n) "RTN","VAFHLZIR",36,0) I VAFSTR[",6," S $P(VAFY,HLFS,6)=$$YN^VAFHLFNC($P(VAFNODE,"^",9)) ; Incapable of self-support "RTN","VAFHLZIR",37,0) I VAFSTR[",7," S $P(VAFY,HLFS,7)=$$YN^VAFHLFNC($P(VAFNODE,"^",10)) ; Contributed to support "RTN","VAFHLZIR",38,0) I VAFSTR[",8," S $P(VAFY,HLFS,8)=$$YN^VAFHLFNC($P(VAFNODE,"^",11)) ; Child had income "RTN","VAFHLZIR",39,0) I VAFSTR[",9," S $P(VAFY,HLFS,9)=$$YN^VAFHLFNC($P(VAFNODE,"^",12)) ; Income available to you "RTN","VAFHLZIR",40,0) I VAFSTR[",10," S X=$P(VAFNODE,"^",13),$P(VAFY,HLFS,10)=$S(X]"":X,1:HLQ) ; Number of dependent children "RTN","VAFHLZIR",41,0) ; "RTN","VAFHLZIR",42,0) ; ALB/ESD - Data elements 11,12,13 added as part of Ambulatory Care "RTN","VAFHLZIR",43,0) ; Reporting Project requirements. "RTN","VAFHLZIR",44,0) ; "RTN","VAFHLZIR",45,0) I VAFSTR[",11,"!(VAFSTR[",12,")!(VAFSTR[",13,") D "RTN","VAFHLZIR",46,0) . ; "RTN","VAFHLZIR",47,0) . ;- If no encounter ptr, encounter node or DFN elements 11 - 13 = HLQ "RTN","VAFHLZIR",48,0) . I ('VAFENC) S VAFERR=1 Q "RTN","VAFHLZIR",49,0) . S VAFENODE=$$SCE^DGSDU(VAFENC) I VAFENODE']"" S VAFERR=1 Q "RTN","VAFHLZIR",50,0) . S VAFDFN=$P(VAFENODE,"^",2) S:VAFDFN="" VAFERR=1 Q "RTN","VAFHLZIR",51,0) I VAFSTR[",11," S $P(VAFY,HLFS,11)=$S('$G(VAFERR):+$$DEP^VAFMON(VAFDFN,$P(VAFENODE,"^")),1:HLQ) ;Total Dependents "RTN","VAFHLZIR",52,0) I VAFSTR[",12," S $P(VAFY,HLFS,12)=$S('$G(VAFERR):+$$INCOME^VAFMON(VAFDFN,$P(VAFENODE,"^")),1:HLQ) ;Patient Income "RTN","VAFHLZIR",53,0) ; "RTN","VAFHLZIR",54,0) ;- If outpat encounter node exists, get appointment type & "RTN","VAFHLZIR",55,0) ; eligibility of encounter and make call to get means test indicator "RTN","VAFHLZIR",56,0) I VAFSTR[",13," S $P(VAFY,HLFS,13)=$S('$G(VAFERR):$$MTI^SCDXUTL0(VAFDFN,$P(VAFENODE,"^"),$P(VAFENODE,"^",13),$P(VAFENODE,"^",10),VAFENC),1:HLQ) ;Means Test Indicator "RTN","VAFHLZIR",57,0) ; "RTN","VAFHLZIR",58,0) ;- If MT Indicator not = code AN, C, or G, change number of dependents "RTN","VAFHLZIR",59,0) ; to XX (not applicable) "RTN","VAFHLZIR",60,0) I VAFSTR[",11," I '$G(VAFERR) D "RTN","VAFHLZIR",61,0) . I $P(VAFY,HLFS,13)'="AN"&($P(VAFY,HLFS,13)'="C")&($P(VAFY,HLFS,13)'="G") S $P(VAFY,HLFS,11)="XX" ;Total Dependents not applicable for MT indicators AS,N,X,U "RTN","VAFHLZIR",62,0) ; "RTN","VAFHLZIR",63,0) I VAFSTR[",14," S X=$P(VAFNODE,"^",18),$P(VAFY,HLFS,14)=$S(X=0:"N",X=1:"Y",1:HLQ) ; Dependent child school indicator "RTN","VAFHLZIR",64,0) ; "RTN","VAFHLZIR",65,0) QUIT Q "ZIR"_HLFS_$G(VAFY) "RTN","VAFHLZPD") 0^81^B55095720 "RTN","VAFHLZPD",1,0) VAFHLZPD ;ALB/KCL/PHH,TDM - Create generic HL7 ZPD segment ; 7/24/06 10:05am "RTN","VAFHLZPD",2,0) ;;5.3;Registration;**94,122,160,220,247,545,564,568,677,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZPD",3,0) ; "RTN","VAFHLZPD",4,0) ; "RTN","VAFHLZPD",5,0) EN(DFN,VAFSTR) ; This generic extrinsic function was designed to return "RTN","VAFHLZPD",6,0) ; sequences 1 throught 21 of the HL7 ZPD segment. This segment "RTN","VAFHLZPD",7,0) ; contains VA-specific patient information that is not contained in "RTN","VAFHLZPD",8,0) ; the HL7 PID segment. This call does not accomodate a segment "RTN","VAFHLZPD",9,0) ; length greater than 245 and has been superceeded by EN1^VAFHLZPD. "RTN","VAFHLZPD",10,0) ; This line tag has been left for backwards compatability. "RTN","VAFHLZPD",11,0) ; "RTN","VAFHLZPD",12,0) ;Input - DFN as internal entry number of the PATIENT file "RTN","VAFHLZPD",13,0) ; - VAFSTR as the string of fields requested seperated by commas "RTN","VAFHLZPD",14,0) ; (Defaults to all fields) "RTN","VAFHLZPD",15,0) ; "RTN","VAFHLZPD",16,0) ; *****Also assumes all HL7 variables returned from***** "RTN","VAFHLZPD",17,0) ; INIT^HLTRANS are defined. "RTN","VAFHLZPD",18,0) ; "RTN","VAFHLZPD",19,0) ;Output - String of data forming the ZPD segment. "RTN","VAFHLZPD",20,0) ; "RTN","VAFHLZPD",21,0) ; "RTN","VAFHLZPD",22,0) N VAFY,VAFZPD,REMARKS "RTN","VAFHLZPD",23,0) S VAFY=$$EN1($G(DFN),$G(VAFSTR)) "RTN","VAFHLZPD",24,0) ;Segment less than 245 characters "RTN","VAFHLZPD",25,0) I ('$D(VAFZPD(1))) D "RTN","VAFHLZPD",26,0) .;Remove sequences 22 and higher "RTN","VAFHLZPD",27,0) .S VAFY=$P(VAFY,HLFS,1,22) "RTN","VAFHLZPD",28,0) ;Segment greater than 245 characters "RTN","VAFHLZPD",29,0) I ($D(VAFZPD(1))) D "RTN","VAFHLZPD",30,0) .;Strip out REMARKS (seq 2) "RTN","VAFHLZPD",31,0) .S REMARKS=$P(VAFY,HLFS,3) "RTN","VAFHLZPD",32,0) .S $P(VAFY,HLFS,3)="" "RTN","VAFHLZPD",33,0) .;Append up to sequence 21 (PRIMARY CARE TEAM) "RTN","VAFHLZPD",34,0) .S VAFY=VAFY_$P(VAFZPD(1),HLFS,1,((21-$L(VAFY,HLFS))+2)) "RTN","VAFHLZPD",35,0) .;Place REMARKS back into segment, truncating if needed "RTN","VAFHLZPD",36,0) .S $P(VAFY,HLFS,3)=$E(REMARKS,1,(245-$L(VAFY))) "RTN","VAFHLZPD",37,0) ;Done "RTN","VAFHLZPD",38,0) Q VAFY "RTN","VAFHLZPD",39,0) ; "RTN","VAFHLZPD",40,0) EN1(DFN,VAFSTR) ; This generic extrinsic function was designed to return the "RTN","VAFHLZPD",41,0) ; HL7 ZPD segment. This segment contains VA-specific patient "RTN","VAFHLZPD",42,0) ; information that is not contained in the HL7 PID segment. This "RTN","VAFHLZPD",43,0) ; call superceeds EN^VAFHLZPD because it accomodates a segment "RTN","VAFHLZPD",44,0) ; length greater than 245. "RTN","VAFHLZPD",45,0) ; "RTN","VAFHLZPD",46,0) ; "RTN","VAFHLZPD",47,0) ;Input : DFN - Pointer to PATIENT file (#2) "RTN","VAFHLZPD",48,0) ; VAFSTR - List of data elements to retrieve seperated "RTN","VAFHLZPD",49,0) ; by commas (ex: 1,2,3) "RTN","VAFHLZPD",50,0) ; - Defaults to all data elements "RTN","VAFHLZPD",51,0) ; Existance of HL7 encoding variables is assumed "RTN","VAFHLZPD",52,0) ; (HLFS, HLENC, HLQ) "RTN","VAFHLZPD",53,0) ;Output : ZPD segment "RTN","VAFHLZPD",54,0) ; : If the ZPD segment becomes longer than 245 characters, "RTN","VAFHLZPD",55,0) ; remaining fields will be placed in VAFZPD(1) "RTN","VAFHLZPD",56,0) ;Notes : Sequence 1 (Set ID) will always have a value of '1' "RTN","VAFHLZPD",57,0) ; : A ZPD segment with sequence one set to '1' will be returned "RTN","VAFHLZPD",58,0) ; if DFN is not valid "RTN","VAFHLZPD",59,0) ; : Variable VAFZPD is initialized on entry "RTN","VAFHLZPD",60,0) ; "RTN","VAFHLZPD",61,0) ;Declare variables "RTN","VAFHLZPD",62,0) N VAFHLZPD,VAFY,SEQ,SPILL,SPILLON,SPOT,LASTSEQ,MAXLEN "RTN","VAFHLZPD",63,0) K VAFZPD "RTN","VAFHLZPD",64,0) S MAXLEN=245 "RTN","VAFHLZPD",65,0) ;Get data "RTN","VAFHLZPD",66,0) D GETDATA($G(DFN),$G(VAFSTR),"VAFHLZPD") "RTN","VAFHLZPD",67,0) ;Build segment "RTN","VAFHLZPD",68,0) S VAFY="VAFHLZPD" "RTN","VAFHLZPD",69,0) S SPILL=0 "RTN","VAFHLZPD",70,0) S SPILLON=0 "RTN","VAFHLZPD",71,0) S @VAFY="ZPD" "RTN","VAFHLZPD",72,0) S LASTSEQ=+$O(VAFHLZPD(""),-1) "RTN","VAFHLZPD",73,0) F SEQ=1:1:LASTSEQ D "RTN","VAFHLZPD",74,0) .;Make sure maximum length won't be exceeded "RTN","VAFHLZPD",75,0) .I ($L(@VAFY)+$L($G(VAFHLZPD(SEQ)))+1)>MAXLEN D "RTN","VAFHLZPD",76,0) ..;Max length exceeded - start putting data on next node "RTN","VAFHLZPD",77,0) ..S SPILL=SPILL+1 "RTN","VAFHLZPD",78,0) ..S SPILLON=SEQ-1 "RTN","VAFHLZPD",79,0) ..S VAFY=$NA(VAFZPD(SPILL)) "RTN","VAFHLZPD",80,0) .;Add to string "RTN","VAFHLZPD",81,0) .S SPOT=(SEQ+1)-SPILLON "RTN","VAFHLZPD",82,0) .S $P(@VAFY,HLFS,SPOT)=$G(VAFHLZPD(SEQ)) "RTN","VAFHLZPD",83,0) ;Return segment "RTN","VAFHLZPD",84,0) Q VAFHLZPD "RTN","VAFHLZPD",85,0) ; "RTN","VAFHLZPD",86,0) GETDATA(DFN,VAFSTR,ARRAY) ;Get info needed to build segment "RTN","VAFHLZPD",87,0) ;Input : DFN - Pointer to PATIENT file (#2) "RTN","VAFHLZPD",88,0) ; VAFSTR - List of data elements to retrieve seperated "RTN","VAFHLZPD",89,0) ; by commas (ex: 1,2,3) "RTN","VAFHLZPD",90,0) ; - Defaults to all data elements "RTN","VAFHLZPD",91,0) ; ARRAY - Array to return data in (full global reference) "RTN","VAFHLZPD",92,0) ; Defaults to ^TMP($J,"VAFHLZPD") "RTN","VAFHLZPD",93,0) ; Existance of HL7 encoding variables is assumed "RTN","VAFHLZPD",94,0) ; (HLFS, HLENC, HLQ) "RTN","VAFHLZPD",95,0) ;Output : Nothing "RTN","VAFHLZPD",96,0) ; ARRAY(SeqNum) = Value "RTN","VAFHLZPD",97,0) ;Notes : ARRAY is initialized (KILLed) on entry "RTN","VAFHLZPD",98,0) ; : Sequence 1 (Set ID) will always have a value of '1' "RTN","VAFHLZPD",99,0) ; "RTN","VAFHLZPD",100,0) ;Check input "RTN","VAFHLZPD",101,0) S ARRAY=$G(ARRAY) "RTN","VAFHLZPD",102,0) S:(ARRAY="") ARRAY=$NA(^TMP($J,"VAFHLZPD")) "RTN","VAFHLZPD",103,0) K @ARRAY "RTN","VAFHLZPD",104,0) ;Sequence 1 - Set ID "RTN","VAFHLZPD",105,0) ; value is always '1' "RTN","VAFHLZPD",106,0) S @ARRAY@(1)=1 "RTN","VAFHLZPD",107,0) S DFN=+$G(DFN) "RTN","VAFHLZPD",108,0) S VAFSTR=$G(VAFSTR) "RTN","VAFHLZPD",109,0) S:(VAFSTR="") VAFSTR=$$COMMANUM(1,40) "RTN","VAFHLZPD",110,0) S VAFSTR=","_VAFSTR_"," "RTN","VAFHLZPD",111,0) ;Declare variables "RTN","VAFHLZPD",112,0) N VAFNODE,VAPD,X1,X "RTN","VAFHLZPD",113,0) ;Get zero node "RTN","VAFHLZPD",114,0) S VAFNODE=$G(^DPT(DFN,0)) "RTN","VAFHLZPD",115,0) ;Get other patient data from VADPT "RTN","VAFHLZPD",116,0) D OPD^VADPT "RTN","VAFHLZPD",117,0) ;Sequence 2 - Remarks (truncate to 60 characters) "RTN","VAFHLZPD",118,0) I VAFSTR[",2," S X=$P(VAFNODE,"^",10),@ARRAY@(2)=$S(X="":HLQ,1:$E(X,1,60)) "RTN","VAFHLZPD",119,0) ;Sequence 3 - Place of birth (city) "RTN","VAFHLZPD",120,0) I VAFSTR[",3," S @ARRAY@(3)=$S(VAPD(1)]"":VAPD(1),1:HLQ) "RTN","VAFHLZPD",121,0) ;Sequence 4 - Place of birth (State abbrv.) "RTN","VAFHLZPD",122,0) I VAFSTR[",4," S X1=$P($G(^DIC(5,$P(+VAPD(2),"^",1),0)),"^",2),@ARRAY@(4)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",123,0) ;Sequence 5 - Current means test status "RTN","VAFHLZPD",124,0) I VAFSTR[",5," S X=$P(VAFNODE,"^",14),X1=$P($G(^DG(408.32,+X,0)),"^",2),@ARRAY@(5)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",125,0) ;Sequence 6 - Fathers name "RTN","VAFHLZPD",126,0) I VAFSTR[",6," S @ARRAY@(6)=$S(VAPD(3)]"":VAPD(3),1:HLQ) "RTN","VAFHLZPD",127,0) ;Sequence 7 - Mothers name "RTN","VAFHLZPD",128,0) I VAFSTR[",7," S @ARRAY@(7)=$S(VAPD(4)]"":VAPD(4),1:HLQ) "RTN","VAFHLZPD",129,0) ;Sequence 8 - Rated incompetent "RTN","VAFHLZPD",130,0) I VAFSTR[",8," S X1=$$YN^VAFHLFNC($P($G(^DPT(DFN,.29)),"^",12)),@ARRAY@(8)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",131,0) ;Sequence 9 - Date of Death "RTN","VAFHLZPD",132,0) I VAFSTR[",9," S X=$P($G(^DPT(DFN,.35)),"^",1),X1=$$HLDATE^HLFNC(X),@ARRAY@(9)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",133,0) ;Sequence 10 - Collateral sponser name "RTN","VAFHLZPD",134,0) I VAFSTR[10 D "RTN","VAFHLZPD",135,0) .S X=$P($G(^DPT(DFN,.36)),"^",11) "RTN","VAFHLZPD",136,0) .S X1=$P($G(^DPT(+X,0)),"^",1) "RTN","VAFHLZPD",137,0) .S @ARRAY@(10)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",138,0) ;Sequence 11 - Active Health Insurance? "RTN","VAFHLZPD",139,0) I VAFSTR[11 S X=$$INS^VAFHLFNC(DFN),X1=$$YN^VAFHLFNC(X),@ARRAY@(11)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",140,0) ;Sequences 12 & 13 "RTN","VAFHLZPD",141,0) I VAFSTR[12!(VAFSTR[13) D "RTN","VAFHLZPD",142,0) .S X=$G(^DPT(DFN,.38)) "RTN","VAFHLZPD",143,0) .;Sequence 12 - Eligible for Medicaid "RTN","VAFHLZPD",144,0) .I VAFSTR[12 S X1=$$YN^VAFHLFNC($P(X,"^",1)),@ARRAY@(12)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",145,0) .;Sequence 13 - Date Medicaid last asked "RTN","VAFHLZPD",146,0) .I VAFSTR[13 S X1=$$HLDATE^HLFNC($P(X,"^",2)),@ARRAY@(13)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",147,0) ;Sequence 14 - Race "RTN","VAFHLZPD",148,0) I VAFSTR[14 S X=$P(VAFNODE,"^",6) S X1=$P($G(^DIC(10,+X,0)),"^",2),@ARRAY@(14)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",149,0) ;Sequence 15 - Religious Preference "RTN","VAFHLZPD",150,0) I VAFSTR[15 S X=$P(VAFNODE,"^",8) S X1=$P($G(^DIC(13,+X,0)),"^",4),@ARRAY@(15)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",151,0) ;Sequence 16 - Homeless Indicator "RTN","VAFHLZPD",152,0) I VAFSTR[16 S X=$T(HOMELESS^SOWKHIRM) S @ARRAY@(16)=$S(X]"":$$HOMELESS^SOWKHIRM(DFN),1:HLQ) "RTN","VAFHLZPD",153,0) ;Sequences 17 & 20 "RTN","VAFHLZPD",154,0) I ((VAFSTR[17)!(VAFSTR[20)) D "RTN","VAFHLZPD",155,0) .;POW Status & Location "RTN","VAFHLZPD",156,0) .N VAF52,POW,LOC "RTN","VAFHLZPD",157,0) .S VAF52=$G(^DPT(DFN,.52)) "RTN","VAFHLZPD",158,0) .;POW Status Indicated? "RTN","VAFHLZPD",159,0) .S POW=$P(VAF52,"^",5) "RTN","VAFHLZPD",160,0) .S:(POW="") POW=HLQ "RTN","VAFHLZPD",161,0) .;POW Confinement Location (translates pointer to coded value) "RTN","VAFHLZPD",162,0) .S LOC=$P(VAF52,"^",6) "RTN","VAFHLZPD",163,0) .S:(LOC="") LOC=HLQ "RTN","VAFHLZPD",164,0) .I (LOC'=HLQ) S LOC=$S(LOC>0&(LOC<7):LOC+3,LOC>6&(LOC<9):$C(LOC+58),1:"") "RTN","VAFHLZPD",165,0) .;Add to output array "RTN","VAFHLZPD",166,0) .;Sequence 17 - POW Status "RTN","VAFHLZPD",167,0) .S:(VAFSTR[17) @ARRAY@(17)=POW "RTN","VAFHLZPD",168,0) .;Sequence 20 - POW Confinement Location "RTN","VAFHLZPD",169,0) .S:(VAFSTR[20) @ARRAY@(20)=LOC "RTN","VAFHLZPD",170,0) ;Sequence 18 - Insurance Type "RTN","VAFHLZPD",171,0) I VAFSTR[18 S X=+$$INSTYP^IBCNS1(DFN),@ARRAY@(18)=$S(X]"":X,1:HLQ) "RTN","VAFHLZPD",172,0) ;Sequence 19 - RX Copay Exemption Status "RTN","VAFHLZPD",173,0) I VAFSTR[19 S X=+$$RXST^IBARXEU(DFN),@ARRAY@(19)=$S(X'<0:X,1:HLQ) "RTN","VAFHLZPD",174,0) ;Sequence 21 - Primary Care Team "RTN","VAFHLZPD",175,0) I (VAFSTR[21) D "RTN","VAFHLZPD",176,0) .;Get Primary Care Team (as defined in PCMM) "RTN","VAFHLZPD",177,0) .S X=$$PCTEAM^DGSDUTL(DFN) "RTN","VAFHLZPD",178,0) .S X=$P(X,"^",2) "RTN","VAFHLZPD",179,0) .S:(X="") X=HLQ "RTN","VAFHLZPD",180,0) .;Put into output array "RTN","VAFHLZPD",181,0) .S @ARRAY@(21)=X "RTN","VAFHLZPD",182,0) ; "RTN","VAFHLZPD",183,0) ; Sequences 22 thru 30 added by DG*5.3*264 (Smart Card) "RTN","VAFHLZPD",184,0) ; "RTN","VAFHLZPD",185,0) ; Sequences 22 & 23 "RTN","VAFHLZPD",186,0) I VAFSTR[22!(VAFSTR[23) D "RTN","VAFHLZPD",187,0) .; GI Insurance "RTN","VAFHLZPD",188,0) .S X=$G(^DPT(DFN,.362)) "RTN","VAFHLZPD",189,0) .I VAFSTR[22 S X1=$P(X,U,17),@ARRAY@(22)=$S(X1="U":"N",X1]"":X1,1:HLQ) "RTN","VAFHLZPD",190,0) .I VAFSTR[23 S X1=$P(X,U,6),@ARRAY@(23)=$S(X1:$E(X1,1,6),1:HLQ) "RTN","VAFHLZPD",191,0) ; Sequences 24 through 27 "RTN","VAFHLZPD",192,0) I VAFSTR[24!(VAFSTR[25)!(VAFSTR[26)!(VAFSTR[27) D "RTN","VAFHLZPD",193,0) .; Most recent care dates & locations "RTN","VAFHLZPD",194,0) .S X=$G(^DPT(DFN,1010.15)) "RTN","VAFHLZPD",195,0) .I VAFSTR[24 S X1=$$HLDATE^HLFNC($P(X,U)),@ARRAY@(24)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",196,0) .I VAFSTR[25 S X1=$P(X,U,2),X1=$P($G(^DIC(4,+X1,0)),U),@ARRAY@(25)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",197,0) .I VAFSTR[26 S X1=$$HLDATE^HLFNC($P(X,U,3)),@ARRAY@(26)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",198,0) .I VAFSTR[27 S X1=$P(X,U,4),X1=$P($G(^DIC(4,+X1,0)),U),@ARRAY@(27)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",199,0) ; Sequences 28 & 29 "RTN","VAFHLZPD",200,0) I VAFSTR[28!(VAFSTR[29) D "RTN","VAFHLZPD",201,0) .; dates ruled incompetent (civil and VA) "RTN","VAFHLZPD",202,0) .S X=$G(^DPT(DFN,.29)) "RTN","VAFHLZPD",203,0) .I VAFSTR[28 S X1=$$HLDATE^HLFNC($P(X,U,2)),@ARRAY@(28)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",204,0) .I VAFSTR[29 S X1=$$HLDATE^HLFNC($P(X,U)),@ARRAY@(29)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",205,0) ; Sequence 30 - Spinal cord injury "RTN","VAFHLZPD",206,0) I VAFSTR[30 S X=$P($G(^DPT(DFN,57)),U,4),@ARRAY@(30)=$S(X]"":X,1:HLQ) "RTN","VAFHLZPD",207,0) ; Sequence 31 - Source of Notification "RTN","VAFHLZPD",208,0) I VAFSTR[9&(VAFSTR[31) S X=$P($G(^DPT(DFN,.35)),U,3),@ARRAY@(31)=$S(X]"":X,1:HLQ) "RTN","VAFHLZPD",209,0) ; Sequence 32 - Date/Time Last Updated "RTN","VAFHLZPD",210,0) I VAFSTR[9&(VAFSTR[32) S X=$P($G(^DPT(DFN,.35)),U,4),X1=$$HLDATE^HLFNC(X),@ARRAY@(32)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLZPD",211,0) ; Sequence 33 - Filipino Veteran Proof "RTN","VAFHLZPD",212,0) I VAFSTR[33 S X=$P($G(^DPT(DFN,.321)),U,14),@ARRAY@(33)=$S(X]"":X,1:HLQ) "RTN","VAFHLZPD",213,0) ; Sequence 34 - Pseudo SSN Reason - Veteran "RTN","VAFHLZPD",214,0) I VAFSTR[34 S X=$P($G(^DPT(DFN,"SSN")),U),@ARRAY@(34)=$S(X]"":X,1:HLQ) "RTN","VAFHLZPD",215,0) ; Sequence 40 - Emergency Response Indicator "RTN","VAFHLZPD",216,0) I VAFSTR[40 S X=$P($G(^DPT(DFN,.18)),U),@ARRAY@(40)=$S(X]"":X,1:HLQ) "RTN","VAFHLZPD",217,0) ;Done - cleanup & quit "RTN","VAFHLZPD",218,0) D KVA^VADPT "RTN","VAFHLZPD",219,0) Q "RTN","VAFHLZPD",220,0) ; "RTN","VAFHLZPD",221,0) COMMANUM(FROM,TO) ;Build comma seperated list of numbers "RTN","VAFHLZPD",222,0) ;Input : FROM - Starting number (default = 1) "RTN","VAFHLZPD",223,0) ; TO - Ending number (default = FROM) "RTN","VAFHLZPD",224,0) ;Output : Comma seperated list of numbers between FROM and TO "RTN","VAFHLZPD",225,0) ; (Ex: 1,2,3) "RTN","VAFHLZPD",226,0) ;Notes : Call assumes FROM <= TO "RTN","VAFHLZPD",227,0) ; "RTN","VAFHLZPD",228,0) S FROM=$G(FROM) S:(FROM="") FROM=1 "RTN","VAFHLZPD",229,0) S TO=$G(TO) S:(TO="") TO=FROM "RTN","VAFHLZPD",230,0) N OUTPUT,X "RTN","VAFHLZPD",231,0) S OUTPUT=FROM "RTN","VAFHLZPD",232,0) F X=(FROM+1):1:TO S OUTPUT=(OUTPUT_","_X) "RTN","VAFHLZPD",233,0) Q OUTPUT "RTN","VAFHLZSP") 0^6^B4401981 "RTN","VAFHLZSP",1,0) VAFHLZSP ;ALB/RJS,TDM - ZSP SEGMENT - 3/18/96 ; 9/19/05 11:50am "RTN","VAFHLZSP",2,0) ;;5.3;Registration;**94,106,122,220,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZSP",3,0) EN(DFN,VAFNUM,VAFAMB) ; "RTN","VAFHLZSP",4,0) N VAROOT,VAFHROOT,VAFY,VAFNODE,VIETSRV,SERVCONN,PERCENT,POS,RETURN "RTN","VAFHLZSP",5,0) S VAROOT="VAFHROOT" "RTN","VAFHLZSP",6,0) D ELIG^VADPT "RTN","VAFHLZSP",7,0) ;- ALB/ESD - Added VAFNUM as part of Ambulatory Care Reporting Project "RTN","VAFHLZSP",8,0) ; requirements. "RTN","VAFHLZSP",9,0) S VAFNUM=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLZSP",10,0) S VAFAMB=+$G(VAFAMB,1) "RTN","VAFHLZSP",11,0) I $P(VAFHROOT(3),U,1)=1 S SERVCONN="Y",PERCENT=$P(VAFHROOT(3),U,2) "RTN","VAFHLZSP",12,0) I $P(VAFHROOT(3),U,1)=0 S SERVCONN="N" "RTN","VAFHLZSP",13,0) I VAFHROOT(2)'="" S POS=$P($G(^DIC(21,+VAFHROOT(2),0)),U,3) "RTN","VAFHLZSP",14,0) I '$D(SERVCONN) S SERVCONN="""""" "RTN","VAFHLZSP",15,0) I '$D(PERCENT) S PERCENT="""""" "RTN","VAFHLZSP",16,0) I '$D(POS) S POS="""""" "RTN","VAFHLZSP",17,0) ; "RTN","VAFHLZSP",18,0) ;- Convert Y/N to 1/0 (HL7 Table VA01) "RTN","VAFHLZSP",19,0) I $D(SERVCONN) S SERVCONN=$$YN^VAFHLFNC(SERVCONN) "RTN","VAFHLZSP",20,0) S RETURN="ZSP"_HLFS_VAFNUM_HLFS_SERVCONN_HLFS_PERCENT_HLFS_POS "RTN","VAFHLZSP",21,0) ;- ALB/ESD - Get 'Vietnam Service Indicated?' field from PATIENT file "RTN","VAFHLZSP",22,0) ; (required by Ambulatory Care Reporting Project). "RTN","VAFHLZSP",23,0) ;I +$G(VAFAMB)=1 D "RTN","VAFHLZSP",24,0) ;. ; "RTN","VAFHLZSP",25,0) ;. ;- 'Vietnam Service Indicated?' field = Y, N, or U (UNKNOWN) "RTN","VAFHLZSP",26,0) ;. S VIETSRV=$P($G(^DPT(DFN,.321)),"^") "RTN","VAFHLZSP",27,0) ;. I $G(VIETSRV)="" S VIETSRV="""""" "RTN","VAFHLZSP",28,0) ;. S RETURN=RETURN_HLFS_VIETSRV "RTN","VAFHLZSP",29,0) ; "RTN","VAFHLZSP",30,0) ;- DG*5.3*220 REMOVED CHECK FOR VAFAMB PARAMETER "RTN","VAFHLZSP",31,0) ;'Vietnam Service Indicated?' field = Y, N, or U (UNKNOWN) "RTN","VAFHLZSP",32,0) S VIETSRV=$P($G(^DPT(DFN,.321)),"^") "RTN","VAFHLZSP",33,0) I $G(VIETSRV)="" S VIETSRV="""""" "RTN","VAFHLZSP",34,0) S RETURN=RETURN_HLFS_VIETSRV "RTN","VAFHLZSP",35,0) ; "RTN","VAFHLZSP",36,0) ; **** ALB/KCL - Patch DG*5.3*122; Add additional data fields **** "RTN","VAFHLZSP",37,0) S VAFNODE=$G(^DPT(DFN,.3)) "RTN","VAFHLZSP",38,0) S $P(VAFY,HLFS,3)="",HLQ=$S($D(HLQ):HLQ,1:"""""") "RTN","VAFHLZSP",39,0) S $P(VAFY,HLFS,1)=$S($P(VAFNODE,"^",4)]"":$$YN^VAFHLFNC($P(VAFNODE,"^",4)),1:HLQ) ; P&T "RTN","VAFHLZSP",40,0) S $P(VAFY,HLFS,2)=$S($P(VAFNODE,"^",5)]"":$$YN^VAFHLFNC($P(VAFNODE,"^",5)),1:HLQ) ; Unemployable "RTN","VAFHLZSP",41,0) S $P(VAFY,HLFS,3)=$S($P(VAFNODE,"^",12)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",12)),1:HLQ) ; SC Award Date "RTN","VAFHLZSP",42,0) S $P(VAFY,HLFS,5)=$S($P(VAFNODE,"^",13)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",13)),1:HLQ) ; P&T Effective Date "RTN","VAFHLZSP",43,0) ; "RTN","VAFHLZSP",44,0) S RETURN=RETURN_HLFS_$G(VAFY) "RTN","VAFHLZSP",45,0) ; "RTN","VAFHLZSP",46,0) ; "RTN","VAFHLZSP",47,0) D KVAR^VADPT "RTN","VAFHLZSP",48,0) Q RETURN "RTN","VAFHLZTA") 0^46^B6091122 "RTN","VAFHLZTA",1,0) VAFHLZTA ;ALB/ESD,TDM - Creation of ZTA segment ; 9/22/05 2:04pm "RTN","VAFHLZTA",2,0) ;;5.3;Registration;**68,653**;Aug 13, 1993;Build 2 "RTN","VAFHLZTA",3,0) ; "RTN","VAFHLZTA",4,0) ; This generic extrinsic function returns the HL7 VA-Specific Temporary Address (ZTA) segment. "RTN","VAFHLZTA",5,0) ; "RTN","VAFHLZTA",6,0) ; "RTN","VAFHLZTA",7,0) EN(DFN,VAFSTR,VAFNUM) ; Returns HL7 ZTA segment containing temporary address "RTN","VAFHLZTA",8,0) ; data. "RTN","VAFHLZTA",9,0) ; "RTN","VAFHLZTA",10,0) ; Input - DFN as internal entry number of the PATIENT file "RTN","VAFHLZTA",11,0) ; VAFSTR as string of fields requested separated by commas. "RTN","VAFHLZTA",12,0) ; VAFNUM as SetId - set to 1. "RTN","VAFHLZTA",13,0) ; "RTN","VAFHLZTA",14,0) ; Output - string of components forming the ZTA segment. "RTN","VAFHLZTA",15,0) ; "RTN","VAFHLZTA",16,0) ; ******** Also assumes all HL7 variables returned from ******** "RTN","VAFHLZTA",17,0) ; INIT^HLTRANS are defined. "RTN","VAFHLZTA",18,0) ; "RTN","VAFHLZTA",19,0) ; "RTN","VAFHLZTA",20,0) N VAFNODE,VAFY,X,X1 "RTN","VAFHLZTA",21,0) I '$G(DFN)!($G(VAFSTR)']"") G QUIT "RTN","VAFHLZTA",22,0) S VAFNODE=$G(^DPT(DFN,.121)) "RTN","VAFHLZTA",23,0) S $P(VAFY,HLFS,7)="",VAFSTR=","_VAFSTR_"," "RTN","VAFHLZTA",24,0) S $P(VAFY,HLFS,1)=1 ; SetId equal to 1 "RTN","VAFHLZTA",25,0) I VAFSTR[",2," S X=$P(VAFNODE,"^",9),$P(VAFY,HLFS,2)=$$YN^VAFHLFNC(X) ; Temporary Address Enter/Edit? "RTN","VAFHLZTA",26,0) I VAFSTR[",3," S X=$$HLDATE^HLFNC($P(VAFNODE,"^",7)),$P(VAFY,HLFS,3)=$S(X]"":X,1:HLQ) ; Temporary Address Start Date "RTN","VAFHLZTA",27,0) I VAFSTR[",4," S X=$$HLDATE^HLFNC($P(VAFNODE,"^",8)),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Temporary Address End Date "RTN","VAFHLZTA",28,0) I VAFSTR[",5,"!(VAFSTR[",6,") D "RTN","VAFHLZTA",29,0) . S X1=$$ADDR^VAFHLFNC($P(VAFNODE,"^",1,5)_"^"_$P(VAFNODE,"^",12),$P(VAFNODE,"^",11)) "RTN","VAFHLZTA",30,0) . I VAFSTR[",5," S $P(VAFY,HLFS,5)=$S($P(X1,HLFS,1)]"":$P(X1,HLFS,1),1:HLQ) ; Temporary Address "RTN","VAFHLZTA",31,0) . I VAFSTR[",6," S $P(VAFY,HLFS,6)=$S($P(X1,HLFS,2)]"":$P(X1,HLFS,2),1:HLQ) ; Temporary Address County "RTN","VAFHLZTA",32,0) I VAFSTR[",7," S X=$$HLPHONE^HLFNC($P(VAFNODE,"^",10)),$P(VAFY,HLFS,7)=$S(X]"":X,1:HLQ) ; Temporary Address Phone "RTN","VAFHLZTA",33,0) I VAFSTR[",8," S X=$$HLDATE^HLFNC($P(VAFNODE,"^",13)),$P(VAFY,HLFS,8)=$S(X]"":X,1:HLQ) ; Temp Addr Last Updated "RTN","VAFHLZTA",34,0) I VAFSTR[",9," D ; Temp Addr Site of Change "RTN","VAFHLZTA",35,0) . S X=$P(VAFNODE,"^",14),X=$$GET1^DIQ(4,(+X)_",",99) "RTN","VAFHLZTA",36,0) . S $P(VAFY,HLFS,9)=$S(X]"":X,1:HLQ) "RTN","VAFHLZTA",37,0) QUIT Q "ZTA"_HLFS_$G(VAFY) "UP",2,2.141,-1) 2^.14 "UP",2,2.141,0) 2.141 "UP",2,2.399,-1) 2^.399 "UP",2,2.399,0) 2.399 "VER") 8.0^22.0 "^DD",2,2,.09,0) SOCIAL SECURITY NUMBER^RFXa^^0;9^K:X[""""!($A(X)=45) X I $D(X) S:'$D(DPTX) DFN=DA D SSN^DGINP Q I $L(X)>10 "^DD",2,2,.09,.1) SSN "^DD",2,2,.09,1,0) ^.1 "^DD",2,2,.09,1,1,0) 2^BS^MUMPS "^DD",2,2,.09,1,1,1) S ^DPT("BS",$E(X,6,9),DA)="" "^DD",2,2,.09,1,1,2) K:$E(X,6,9)'="" ^DPT("BS",$E(X,6,9),DA) "^DD",2,2,.09,1,2,0) ^^TRIGGER^2^.083 "^DD",2,2,.09,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X=DIV S X="1" X ^DD(2,.09,1,2,1.4) "^DD",2,2,.09,1,2,1.4) S DIH=$S($D(^DPT(DIV(0),0)):^(0),1:""),DIV=X X "F %=0:0 Q:$L($P(DIH,U,19,99)) S DIH=DIH_U" S %=$P(DIH,U,21,999),DIU=$P(DIH,U,20),^(0)=$P(DIH,U,1,19)_U_DIV_$S(%]"":U_%,1:""),DIH=2,DIG=.083 D ^DICR "^DD",2,2,.09,1,2,2) Q "^DD",2,2,.09,1,2,"CREATE VALUE") "1" "^DD",2,2,.09,1,2,"DELETE VALUE") NO EFFECT "^DD",2,2,.09,1,2,"FIELD") #.083 "^DD",2,2,.09,1,3,0) 2^BS5^MUMPS "^DD",2,2,.09,1,3,1) S ^DPT("BS5",$E(^DPT(DA,0),1)_$E(X,6,9),DA)="" "^DD",2,2,.09,1,3,2) K ^DPT("BS5",$E(^DPT(DA,0),1)_$E(X,6,9),DA) "^DD",2,2,.09,1,4,0) 2^AODS1^MUMPS "^DD",2,2,.09,1,4,1) S A1B2TAG="PAT" D ^A1B2XFR "^DD",2,2,.09,1,4,2) S A1B2TAG="PAT" D ^A1B2XFR "^DD",2,2,.09,1,5,0) 2^ATP^MUMPS "^DD",2,2,.09,1,5,1) I $E(X,1,5)="00000" D SET^DGREGDD1(DA,.6,0,21,1) "^DD",2,2,.09,1,5,2) D KILL^DGREGDD1(DA,.6,0,21,0) "^DD",2,2,.09,1,5,"%D",0) ^^2^2^2951026^^^^ "^DD",2,2,.09,1,5,"%D",1,0) This cross reference is used to indentify test patients. Test patients are "^DD",2,2,.09,1,5,"%D",2,0) designated by five leading zeros in the SSN. "^DD",2,2,.09,1,5,"DT") 2951026 "^DD",2,2,.09,1,6,0) 2^AENR09^MUMPS "^DD",2,2,.09,1,6,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.09,1,6,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.09,1,6,3) DO NOT DELETE "^DD",2,2,.09,1,6,"%D",0) ^^3^3^2971007^^^ "^DD",2,2,.09,1,6,"%D",1,0) "^DD",2,2,.09,1,6,"%D",2,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.09,1,6,"%D",3,0) enrollment. "^DD",2,2,.09,1,6,"DT") 2971007 "^DD",2,2,.09,1,7,0) 2^SSN "^DD",2,2,.09,1,7,1) S ^DPT("SSN",$E(X,1,30),DA)="" "^DD",2,2,.09,1,7,2) K ^DPT("SSN",$E(X,1,30),DA) "^DD",2,2,.09,1,8,0) 2^AVADPT6^MUMPS "^DD",2,2,.09,1,8,1) S VADFN=DA D SET^VADPT6 K VADFN "^DD",2,2,.09,1,8,2) S VADFN=DA D KILL^VADPT6 K VADFN "^DD",2,2,.09,1,9,0) 2^AD^MUMPS "^DD",2,2,.09,1,9,1) S PPP=X,X="PPPFMX" X ^%ZOSF("TEST") D:$T SNSSN^PPPFMX S X=PPP K PPP "^DD",2,2,.09,1,9,2) S PPP=X,X="PPPFMX" X ^%ZOSF("TEST") D:$T KNSSN^PPPFMX S X=PPP K PPP "^DD",2,2,.09,1,9,"%D",0) ^.101^2^2^3010423^^ "^DD",2,2,.09,1,9,"%D",1,0) This cross-reference is used to add a new SSN to the Prescription "^DD",2,2,.09,1,9,"%D",2,0) Practices Files when a new patient is added to the patient file. "^DD",2,2,.09,1,9,"DT") 2920611 "^DD",2,2,.09,1,10,0) ^^TRIGGER^2^.0906 "^DD",2,2,.09,1,10,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0)'["P" I X S X=DIV S Y(1)=$S($D(^DPT(D0,"SSN")):^("SSN"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.09,1,10,1.4) "^DD",2,2,.09,1,10,1.4) S DIH=$G(^DPT(DIV(0),"SSN")),DIV=X S $P(^("SSN"),U,1)=DIV,DIH=2,DIG=.0906 D ^DICR "^DD",2,2,.09,1,10,2) Q "^DD",2,2,.09,1,10,"%D",0) ^.101^1^1^3060202^^^^ "^DD",2,2,.09,1,10,"%D",1,0) Pseudo SSN Reason will have a value only if SSN is a Pseudo SSN. "^DD",2,2,.09,1,10,"CREATE CONDITION") #.09'["P" "^DD",2,2,.09,1,10,"CREATE VALUE") @ "^DD",2,2,.09,1,10,"DELETE VALUE") NO EFFECT "^DD",2,2,.09,1,10,"DT") 3051003 "^DD",2,2,.09,1,10,"FIELD") PSEUDO SSN REAS "^DD",2,2,.09,1,301,0) 2^IVM09^MUMPS "^DD",2,2,.09,1,301,1) S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX "^DD",2,2,.09,1,301,2) S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX "^DD",2,2,.09,1,301,"%D",0) ^.101^4^4^3010423^^ "^DD",2,2,.09,1,301,"%D",1,0) This cross-reference will check the IVM PATIENT file to see if a change "^DD",2,2,.09,1,301,"%D",2,0) to this field will require transmission to the IVM Center. If it does, "^DD",2,2,.09,1,301,"%D",3,0) the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and "^DD",2,2,.09,1,301,"%D",4,0) the nightly background job will transmit the updated information. "^DD",2,2,.09,1,301,"DT") 2930605 "^DD",2,2,.09,1,800,0) 2^PX09^MUMPS "^DD",2,2,.09,1,800,1) S PX=X,X="PXXDPT" X ^%ZOSF("TEST") D:$T SETSSN^PXXDPT S X=PX K PX "^DD",2,2,.09,1,800,2) S PX=X,X="PXXDPT" X ^%ZOSF("TEST") D:$T KILLSSN^PXXDPT S X=PX K PX "^DD",2,2,.09,1,800,"%D",0) ^^2^2^2960624^^^ "^DD",2,2,.09,1,800,"%D",1,0) This cross-reference is used to add a new SSN to the 9000001 IHS Patient "^DD",2,2,.09,1,800,"%D",2,0) File when a new patient is added to the Patient File. "^DD",2,2,.09,1,800,"DT") 2930908 "^DD",2,2,.09,1,991,0) 2^AVAFC09^MUMPS "^DD",2,2,.09,1,991,1) I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".09;" D AVAFC^VAFCDD01(DA) "^DD",2,2,.09,1,991,2) I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".09;" D AVAFC^VAFCDD01(DA) "^DD",2,2,.09,1,991,"%D",0) ^^15^15^2990204^^^^ "^DD",2,2,.09,1,991,"%D",1,0) This cross reference is used to remember that changes were made to the "^DD",2,2,.09,1,991,"%D",2,0) PATIENT file (#2) outside of the Registration process. Execution of this "^DD",2,2,.09,1,991,"%D",3,0) cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71) "^DD",2,2,.09,1,991,"%D",4,0) and mark it as requiring transmission of an HL7 ADT-A08 message. "^DD",2,2,.09,1,991,"%D",5,0) "^DD",2,2,.09,1,991,"%D",6,0) The local variable VAFCFLG will be set to 1 if the cross reference is "^DD",2,2,.09,1,991,"%D",7,0) not executed because the change is being made from within the Registration "^DD",2,2,.09,1,991,"%D",8,0) process. "^DD",2,2,.09,1,991,"%D",9,0) "^DD",2,2,.09,1,991,"%D",10,0) Execution of this cross reference can be prevented by setting the local "^DD",2,2,.09,1,991,"%D",11,0) variable VAFCA08 equal to 1. "^DD",2,2,.09,1,991,"%D",12,0) "^DD",2,2,.09,1,991,"%D",13,0) The local variable VAFCF is used to identify the field edited. "^DD",2,2,.09,1,991,"%D",14,0) This data is stored in the FIELD(S) EDITED (#2.1) field in the "^DD",2,2,.09,1,991,"%D",15,0) ADT/HL7 PIVOT file (#391.71). "^DD",2,2,.09,1,991,"DT") 2970825 "^DD",2,2,.09,1,992,0) 2^ADGRU09^MUMPS "^DD",2,2,.09,1,992,1) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) "^DD",2,2,.09,1,992,2) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) "^DD",2,2,.09,1,992,"%D",0) ^^9^9^3000202^^^^ "^DD",2,2,.09,1,992,"%D",1,0) This cross reference is used to remember that changes were made to a "^DD",2,2,.09,1,992,"%D",2,0) monitored data field in the PATIENT File (#2) required for a vendor "^DD",2,2,.09,1,992,"%D",3,0) RAI/MDS COTS system. Execution of this cross reference will create "^DD",2,2,.09,1,992,"%D",4,0) an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring "^DD",2,2,.09,1,992,"%D",5,0) transmission of an HL7 demographic A08 update message to the COTS "^DD",2,2,.09,1,992,"%D",6,0) interface. "^DD",2,2,.09,1,992,"%D",7,0) "^DD",2,2,.09,1,992,"%D",8,0) The local variable DGRUGA08 will be set to 1 if the cross reference is "^DD",2,2,.09,1,992,"%D",9,0) not to be executed as part of a re-indexing. "^DD",2,2,.09,1,992,"DT") 3000202 "^DD",2,2,.09,2) S Y(0)=Y S:$L(Y)=11 Y=$E(Y,10,11)_$E(Y,1,9) "^DD",2,2,.09,2.1) S:$L(Y)=11 Y=$E(Y,10,11)_$E(Y,1,9) "^DD",2,2,.09,3) Enter 9-digit SSN or 'P' for pseudo-SSN. "^DD",2,2,.09,10) 10/10 FORM "^DD",2,2,.09,11,0) ^.2LAP^^0 "^DD",2,2,.09,11,1,0) 1^ "^DD",2,2,.09,11,2,0) 2^ "^DD",2,2,.09,20,0) ^.3LA^1^1 "^DD",2,2,.09,20,1,0) DEMOG^ "^DD",2,2,.09,21,0) ^^14^14^3060919^ "^DD",2,2,.09,21,1,0) Answer with the individual's social security number. Answer must be 9 "^DD",2,2,.09,21,2,0) numbers in length. The SSN will be sent to the SSA for verification. "^DD",2,2,.09,21,3,0) This will be displayed next to the SSN. Once an SSN has received a "^DD",2,2,.09,21,4,0) status of Verified, it is locked from user updating and a "VERIFIED" "^DD",2,2,.09,21,5,0) will be displayed by the SSN field. Only the Identity Management Data "^DD",2,2,.09,21,6,0) QUality Team are able to change a beneficiary's (veteran/non veteran) "^DD",2,2,.09,21,7,0) SSN. If an Invalid per SSA status is received for the SSN, then an "^DD",2,2,.09,21,8,0) "INVALID" will appear next to the invalid SSN of the individual. "^DD",2,2,.09,21,9,0) Facilities should make every effort to obtain the accurate SSN from the "^DD",2,2,.09,21,10,0) individual for any invalid or pseudo SSN entry. "^DD",2,2,.09,21,11,0) "^DD",2,2,.09,21,12,0) If a valid SSN is not known, then a "P" will be entered at the SSN "^DD",2,2,.09,21,13,0) prompt for the system to automatically assign a Pseudo-SSN. If a "^DD",2,2,.09,21,14,0) Pseudo SSN is entered, a Reason for entering it will be required. "^DD",2,2,.09,"AUDIT") y "^DD",2,2,.09,"DT") 3060919 "^DD",2,2,.0906,0) PSEUDO SSN REASON^S^R:REFUSED TO PROVIDE;S:SSN UNKNOWN/FOLLOW-UP REQUIRED;N:NO SSN ASSIGNED;^SSN;1^Q "^DD",2,2,.0906,1,0) ^.1^^0 "^DD",2,2,.0906,5,1,0) 2^.09^10 "^DD",2,2,.0906,21,0) ^^17^17^3060919^ "^DD",2,2,.0906,21,1,0) This field is used to document the reason the individual was assigned a "^DD",2,2,.0906,21,2,0) pseudo SSN. Based on your selection, the Pseudo SSN Report (Patient) "^DD",2,2,.0906,21,3,0) option located in the Registration Menu can provide you a current "^DD",2,2,.0906,21,4,0) report of the reasons entered at this prompt. The following reasons "^DD",2,2,.0906,21,5,0) are available for selection: "^DD",2,2,.0906,21,6,0) "^DD",2,2,.0906,21,7,0) Refused to Provide - use this reason when the individual was asked for "^DD",2,2,.0906,21,8,0) his/her SSN and refused to provide the number. "^DD",2,2,.0906,21,9,0) "^DD",2,2,.0906,21,10,0) SSN Unknown/Follow-up required - use this reason when the individual "^DD",2,2,.0906,21,11,0) is not available to ask/answer the request for SSN. The facility "^DD",2,2,.0906,21,12,0) should initiate Follow-up activity to obtain the SSN. "^DD",2,2,.0906,21,13,0) "^DD",2,2,.0906,21,14,0) No SSN Assigned - use this reason when the individual has not been "^DD",2,2,.0906,21,15,0) assigned an SSN. This generally applies to spouse or dependents of "^DD",2,2,.0906,21,16,0) veterans who are not US citizens and infrequently, non-citizen "^DD",2,2,.0906,21,17,0) beneficiaries. "^DD",2,2,.0906,"DT") 3070330 "^DD",2,2,.118,0) ADDRESS CHANGE DT/TM^D^^.11;13^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.118,1,0) ^.1 "^DD",2,2,.118,1,1,0) ^^TRIGGER^2^.119 "^DD",2,2,.118,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,14)=DIV,DIH=2,DIG=.119 D ^DICR "^DD",2,2,.118,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,14)=DIV,DIH=2,DIG=.119 D ^DICR "^DD",2,2,.118,1,1,"%D",0) ^.101^5^5^3030605^^^ "^DD",2,2,.118,1,1,"%D",1,0) This cross-reference will update the Address Source field when "^DD",2,2,.118,1,1,"%D",2,0) address data changes for a patient. The source will be set to 'VAMC', "^DD",2,2,.118,1,1,"%D",3,0) and should be overwritten for instances where the Address source is "^DD",2,2,.118,1,1,"%D",4,0) something different. The incoming Z05 process has been updated to "^DD",2,2,.118,1,1,"%D",5,0) overwrite this field as appropriate. "^DD",2,2,.118,1,1,"CREATE VALUE") S X="VAMC" "^DD",2,2,.118,1,1,"DELETE VALUE") S X="VAMC" "^DD",2,2,.118,1,1,"FIELD") ADDRESS CHANGE SOURCE "^DD",2,2,.118,1,2,0) ^^TRIGGER^2^.122 "^DD",2,2,.118,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=$G(DUZ) S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,17)=DIV,DIH=2,DIG=.122 D ^DICR "^DD",2,2,.118,1,2,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=$G(DUZ) S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,17)=DIV,DIH=2,DIG=.122 D ^DICR "^DD",2,2,.118,1,2,"%D",0) ^^2^2^3030605^ "^DD",2,2,.118,1,2,"%D",1,0) This cross-reference will record the user who has just changed the "^DD",2,2,.118,1,2,"%D",2,0) patient's primary address. "^DD",2,2,.118,1,2,"CREATE VALUE") S X=$G(DUZ) "^DD",2,2,.118,1,2,"DELETE VALUE") S X=$G(DUZ) "^DD",2,2,.118,1,2,"DT") 3030605 "^DD",2,2,.118,1,2,"FIELD") ADDRESS CHANGE USER "^DD",2,2,.118,1,3,0) 2^AENR118^MUMPS "^DD",2,2,.118,1,3,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.118,1,3,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.118,1,3,3) DO NOT DELETE "^DD",2,2,.118,1,3,"%D",0) ^.101^2^2^3050613^^^^ "^DD",2,2,.118,1,3,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.118,1,3,"%D",2,0) enrollment. "^DD",2,2,.118,1,3,"DT") 3050613 "^DD",2,2,.118,3) (No range limit on date) "^DD",2,2,.118,5,1,0) 2^.111^4 "^DD",2,2,.118,5,2,0) 2^.1112^3 "^DD",2,2,.118,5,3,0) 2^.112^4 "^DD",2,2,.118,5,4,0) 2^.113^3 "^DD",2,2,.118,5,5,0) 2^.114^3 "^DD",2,2,.118,5,6,0) 2^.115^4 "^DD",2,2,.118,5,7,0) 2^.116^3 "^DD",2,2,.118,5,8,0) 2^.121^2 "^DD",2,2,.118,9) ^ "^DD",2,2,.118,21,0) ^.001^1^1^3061006^^ "^DD",2,2,.118,21,1,0) This field will hold the date and time of the last Address Update. "^DD",2,2,.118,"DT") 3061024 "^DD",2,2,.121,0) BAD ADDRESS INDICATOR^S^1:UNDELIVERABLE;2:HOMELESS;3:OTHER;^.11;16^Q "^DD",2,2,.121,1,0) ^.1 "^DD",2,2,.121,1,1,0) 2^AENR121^MUMPS "^DD",2,2,.121,1,1,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.121,1,1,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.121,1,1,3) DO NOT DELETE "^DD",2,2,.121,1,1,"%D",0) ^.101^2^2^3061005^^^ "^DD",2,2,.121,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.121,1,1,"%D",2,0) enrollment. "^DD",2,2,.121,1,1,"DT") 3060911 "^DD",2,2,.121,1,2,0) ^^TRIGGER^2^.118 "^DD",2,2,.121,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR "^DD",2,2,.121,1,2,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR "^DD",2,2,.121,1,2,"CREATE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.121,1,2,"DELETE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.121,1,2,"DT") 3061006 "^DD",2,2,.121,1,2,"FIELD") #.118 "^DD",2,2,.121,3) Please enter 1 if the address is 'UNDELIVERABLE', 2 if the patient is 'HOMELESS', or 3 for 'OTHER' bad address reasons. "^DD",2,2,.121,21,0) ^^14^14^3031209^ "^DD",2,2,.121,21,1,0) The Bad Address Indicator field applies to the address at which the patient "^DD",2,2,.121,21,2,0) resides. This field should be set as follows (if applicable): "^DD",2,2,.121,21,3,0) "^DD",2,2,.121,21,4,0) "UNDELIVERABLE" - Bad Address based on returned mail. "^DD",2,2,.121,21,5,0) "HOMELESS" - Patient is known to be homeless. "^DD",2,2,.121,21,6,0) "OTHER" - Other Bad Address Reason "^DD",2,2,.121,21,7,0) "^DD",2,2,.121,21,8,0) Setting this field will prevent a Bad Address from being shared with HEC "^DD",2,2,.121,21,9,0) and other VAMC facilities. It will also be used to block Means Test "^DD",2,2,.121,21,10,0) Renewal Letters from being sent. "^DD",2,2,.121,21,11,0) "^DD",2,2,.121,21,12,0) Once the Bad Address Indicator is set, incoming "newer" addresses will "^DD",2,2,.121,21,13,0) automatically remove the Bad Address Indicator, and allow the "updated" "^DD",2,2,.121,21,14,0) address to be transmitted to HEC and other VAMC facilities. "^DD",2,2,.121,23,0) ^.001^9^9^3031209^^^ "^DD",2,2,.121,23,1,0) This field is being used in conjunction with Patient Address fields "^DD",2,2,.121,23,2,0) .111, .1112, .112, .113, .114, .115, .116, and .117, which are located "^DD",2,2,.121,23,3,0) in the Patient (#2) file. "^DD",2,2,.121,23,4,0) "^DD",2,2,.121,23,5,0) A programmer API, $$BADADR^DGUTL3(DFN) will allow the return of the Bad "^DD",2,2,.121,23,6,0) Address Indicator. The following parameters are used: "^DD",2,2,.121,23,7,0) "^DD",2,2,.121,23,8,0) Input Parameter: DFN - internal entry number for the Patient file (#2) "^DD",2,2,.121,23,9,0) Return value: internal value of the Bad Address Indicator or "^DD",2,2,.121,"AUDIT") "^DD",2,2,.121,"DT") 3061006 "^DD",2,2,.1311,0) CELLULAR NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;^.13;10^Q "^DD",2,2,.1311,1,0) ^.1 "^DD",2,2,.1311,1,1,0) ^^TRIGGER^2^.13111 "^DD",2,2,.1311,1,1,1) X ^DD(2,.1311,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1311,1,1,1.4) "^DD",2,2,.1311,1,1,1.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1311,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC" "^DD",2,2,.1311,1,1,1.4) S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,11)=DIV,DIH=2,DIG=.13111 D ^DICR "^DD",2,2,.1311,1,1,2) X ^DD(2,.1311,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1311,1,1,2.4) "^DD",2,2,.1311,1,1,2.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(2,.1311,0)),U,3),Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,10)_":",2),$C(59))'="VAMC" "^DD",2,2,.1311,1,1,2.4) S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,11)=DIV,DIH=2,DIG=.13111 D ^DICR "^DD",2,2,.1311,1,1,"%D",0) ^^5^5^3060411^ "^DD",2,2,.1311,1,1,"%D",1,0) This cross-reference will trigger the population of the CELLULAR NUMBER "^DD",2,2,.1311,1,1,"%D",2,0) CHANGE SITE field with the appropriate station number if the CELLULAR "^DD",2,2,.1311,1,1,"%D",3,0) NUMBER CHANGE SOURCE equals "VAMC". The Cellular Number Change Site field "^DD",2,2,.1311,1,1,"%D",4,0) should be overwritten for cases where the site would be incorrect (i.e. "^DD",2,2,.1311,1,1,"%D",5,0) uploading Z05 message). "^DD",2,2,.1311,1,1,"CREATE CONDITION") 'CELLULAR NUMBER CHANGE SOURCE'="VAMC" "^DD",2,2,.1311,1,1,"CREATE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.1311,1,1,"DELETE CONDITION") 'CELLULAR NUMBER CHANGE SOURCE'="VAMC" "^DD",2,2,.1311,1,1,"DELETE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.1311,1,1,"DT") 3060410 "^DD",2,2,.1311,1,1,"FIELD") #.13111 "^DD",2,2,.1311,3) Please enter the source of the Cellular number change. "^DD",2,2,.1311,5,1,0) 2^.139^1 "^DD",2,2,.1311,21,0) ^^2^2^3060410^ "^DD",2,2,.1311,21,1,0) This field will hold the source of the last Cellular number "^DD",2,2,.1311,21,2,0) change. "^DD",2,2,.1311,"DT") 3060410 "^DD",2,2,.13111,0) CELLULAR NUMBER CHANGE SITE^P4'^DIC(4,^.13;11^Q "^DD",2,2,.13111,3) Please enter the site that last changed this patient's Cellular number. "^DD",2,2,.13111,5,1,0) 2^.1311^1 "^DD",2,2,.13111,21,0) ^^3^3^3060410^ "^DD",2,2,.13111,21,1,0) This field will hold the site that last changed this "^DD",2,2,.13111,21,2,0) patient's Cellular number. This field is only populated "^DD",2,2,.13111,21,3,0) when the Cellular Number Change Source is listed as VAMC. "^DD",2,2,.13111,"DT") 3060410 "^DD",2,2,.1312,0) PAGER NUMBER CHANGE DT/TM^D^^.13;12^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.1312,1,0) ^.1 "^DD",2,2,.1312,1,1,0) ^^TRIGGER^2^.1313 "^DD",2,2,.1312,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,13)=DIV,DIH=2,DIG=.1313 D ^DICR "^DD",2,2,.1312,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,13)=DIV,DIH=2,DIG=.1313 D ^DICR "^DD",2,2,.1312,1,1,"%D",0) ^^2^2^3060411^ "^DD",2,2,.1312,1,1,"%D",1,0) This cross reference will update the PAGER NUMBER CHANGE SOURCE field "^DD",2,2,.1312,1,1,"%D",2,0) (#.1313). "^DD",2,2,.1312,1,1,"CREATE VALUE") S X="VAMC" "^DD",2,2,.1312,1,1,"DELETE VALUE") S X="VAMC" "^DD",2,2,.1312,1,1,"DT") 3060410 "^DD",2,2,.1312,1,1,"FIELD") #.1313 "^DD",2,2,.1312,5,1,0) 2^.135^1 "^DD",2,2,.1312,21,0) ^^2^2^3060410^ "^DD",2,2,.1312,21,1,0) This field will contain the date and time of the last "^DD",2,2,.1312,21,2,0) Pager number update. "^DD",2,2,.1312,"DT") 3060410 "^DD",2,2,.1313,0) PAGER NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;^.13;13^Q "^DD",2,2,.1313,1,0) ^.1 "^DD",2,2,.1313,1,1,0) ^^TRIGGER^2^.1314 "^DD",2,2,.1313,1,1,1) X ^DD(2,.1313,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1313,1,1,1.4) "^DD",2,2,.1313,1,1,1.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1313,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC" "^DD",2,2,.1313,1,1,1.4) S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,14)=DIV,DIH=2,DIG=.1314 D ^DICR "^DD",2,2,.1313,1,1,2) X ^DD(2,.1313,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1313,1,1,2.4) "^DD",2,2,.1313,1,1,2.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(2,.1313,0)),U,3),Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,13)_":",2),$C(59))'="VAMC" "^DD",2,2,.1313,1,1,2.4) S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,14)=DIV,DIH=2,DIG=.1314 D ^DICR "^DD",2,2,.1313,1,1,"%D",0) ^^5^5^3060411^ "^DD",2,2,.1313,1,1,"%D",1,0) This cross-reference will trigger the population of the PAGER NUMBER "^DD",2,2,.1313,1,1,"%D",2,0) CHANGE SITE field with the appropriate station number if the PAGER NUMBER "^DD",2,2,.1313,1,1,"%D",3,0) CHANGE SOURCE equals "VAMC". The Pager Number Change Site field should be "^DD",2,2,.1313,1,1,"%D",4,0) overwritten for cases where the site would be incorrect (i.e. uploading "^DD",2,2,.1313,1,1,"%D",5,0) Z05 message). "^DD",2,2,.1313,1,1,"CREATE CONDITION") 'PAGER NUMBER CHANGE SOURCE'="VAMC" "^DD",2,2,.1313,1,1,"CREATE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.1313,1,1,"DELETE CONDITION") 'PAGER NUMBER CHANGE SOURCE'="VAMC" "^DD",2,2,.1313,1,1,"DELETE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.1313,1,1,"DT") 3060410 "^DD",2,2,.1313,1,1,"FIELD") #.1314 "^DD",2,2,.1313,3) Please enter the source of the Pager number change. "^DD",2,2,.1313,5,1,0) 2^.1312^1 "^DD",2,2,.1313,21,0) ^^2^2^3060410^ "^DD",2,2,.1313,21,1,0) This field will hold the source of the last Pager number "^DD",2,2,.1313,21,2,0) change. "^DD",2,2,.1313,"DT") 3060410 "^DD",2,2,.1314,0) PAGER NUMBER CHANGE SITE^P4'^DIC(4,^.13;14^Q "^DD",2,2,.1314,3) Please enter the site that last changed this patient's Pager number. "^DD",2,2,.1314,5,1,0) 2^.1313^1 "^DD",2,2,.1314,21,0) ^^3^3^3060410^ "^DD",2,2,.1314,21,1,0) This field will hold the site that last changed this "^DD",2,2,.1314,21,2,0) patient's Pager number. This field is only populated "^DD",2,2,.1314,21,3,0) when the Pager Number Change Source is listed as VAMC. "^DD",2,2,.1314,"DT") 3060410 "^DD",2,2,.133,0) EMAIL ADDRESS^F^^.13;3^K:$L(X)>50!($L(X)<3)!'(X?1.E1"@"1.E1"."1.E) X "^DD",2,2,.133,.1) Email Address "^DD",2,2,.133,1,0) ^.1 "^DD",2,2,.133,1,1,0) ^^TRIGGER^2^.136 "^DD",2,2,.133,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,6)=DIV,DIH=2,DIG=.136 D ^DICR "^DD",2,2,.133,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,6)=DIV,DIH=2,DIG=.136 D ^DICR "^DD",2,2,.133,1,1,"%D",0) ^^2^2^3060411^ "^DD",2,2,.133,1,1,"%D",1,0) This cross reference will update the EMAIL ADDRESS CHANGE DT/TM field "^DD",2,2,.133,1,1,"%D",2,0) with current date and time stamp each time this field is changed. "^DD",2,2,.133,1,1,"CREATE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.133,1,1,"DELETE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.133,1,1,"FIELD") #.136 "^DD",2,2,.133,3) Enter the applicant's email address [3-50 characters]. The entry must include an '@'. "^DD",2,2,.133,21,0) ^^2^2^3050111^ "^DD",2,2,.133,21,1,0) Enter the applicant's email address [3-50 characters]. The entry must "^DD",2,2,.133,21,2,0) have an '@' in the format. "^DD",2,2,.133,"DT") 3060411 "^DD",2,2,.134,0) PHONE NUMBER [CELLULAR]^FX^^.13;4^K:$L(X)>20!($L(X)<4) X I $D(X) N CTR,CHR,VAR S VAR=X F CTR=1:1:20 S CHR=$E(VAR,CTR) K:("1234567890 -()."'[CHR) X "^DD",2,2,.134,.1) Cell Phone "^DD",2,2,.134,1,0) ^.1 "^DD",2,2,.134,1,1,0) ^^TRIGGER^2^.139 "^DD",2,2,.134,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,9)=DIV,DIH=2,DIG=.139 D ^DICR "^DD",2,2,.134,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,9)=DIV,DIH=2,DIG=.139 D ^DICR "^DD",2,2,.134,1,1,"%D",0) ^^2^2^3060411^ "^DD",2,2,.134,1,1,"%D",1,0) This cross reference will update the CELLULAR NUMBER CHANGE DT/TM field "^DD",2,2,.134,1,1,"%D",2,0) with current date and time stamp each time this field is changed. "^DD",2,2,.134,1,1,"CREATE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.134,1,1,"DELETE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.134,1,1,"FIELD") #.139 "^DD",2,2,.134,3) Answer must be 4-20 characters in length, be numeric with only spaces, parenthesis, periods, and dashes for separators. "^DD",2,2,.134,21,0) ^^2^2^3050111^ "^DD",2,2,.134,21,1,0) Enter the telephone number [4-20 characters] to the applicant's "^DD",2,2,.134,21,2,0) mobile phone. "^DD",2,2,.134,"DT") 3060411 "^DD",2,2,.135,0) PAGER NUMBER^FX^^.13;5^K:$L(X)>20!($L(X)<4) X I $D(X) N CTR,CHR,VAR S VAR=X F CTR=1:1:20 S CHR=$E(VAR,CTR) K:("1234567890 -()."'[CHR) X "^DD",2,2,.135,.1) Pager # "^DD",2,2,.135,1,0) ^.1 "^DD",2,2,.135,1,1,0) ^^TRIGGER^2^.1312 "^DD",2,2,.135,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,12)=DIV,DIH=2,DIG=.1312 D ^DICR "^DD",2,2,.135,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,12)=DIV,DIH=2,DIG=.1312 D ^DICR "^DD",2,2,.135,1,1,"%D",0) ^.101^2^2^3060411^^ "^DD",2,2,.135,1,1,"%D",1,0) This cross reference will update the PAGER NUMBER CHANGE DT/TM field with "^DD",2,2,.135,1,1,"%D",2,0) current date and time stamp each time this field is changed. "^DD",2,2,.135,1,1,"CREATE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.135,1,1,"DELETE VALUE") S X=$$NOW^XLFDT() "^DD",2,2,.135,1,1,"FIELD") #.1312 "^DD",2,2,.135,3) Answer must be 4-20 characters in length, be numeric with only spaces, parenthesis, periods, and dashes for separators. "^DD",2,2,.135,21,0) ^^1^1^3050111^ "^DD",2,2,.135,21,1,0) Enter the applicant's pager number [4-20 characters]. "^DD",2,2,.135,23,0) ^.001^1^1^3050111^^^ "^DD",2,2,.135,23,1,0) Contains between 4 and 20 Free Text characters. "^DD",2,2,.135,"DT") 3060411 "^DD",2,2,.136,0) EMAIL ADDRESS CHANGE DT/TM^D^^.13;6^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.136,1,0) ^.1 "^DD",2,2,.136,1,1,0) ^^TRIGGER^2^.137 "^DD",2,2,.136,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,7)=DIV,DIH=2,DIG=.137 D ^DICR "^DD",2,2,.136,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,7)=DIV,DIH=2,DIG=.137 D ^DICR "^DD",2,2,.136,1,1,"%D",0) ^^2^2^3060411^ "^DD",2,2,.136,1,1,"%D",1,0) This cross reference will update the EMAIL ADDRESS CHANGE SOURCE field "^DD",2,2,.136,1,1,"%D",2,0) (#.137). "^DD",2,2,.136,1,1,"CREATE VALUE") S X="VAMC" "^DD",2,2,.136,1,1,"DELETE VALUE") S X="VAMC" "^DD",2,2,.136,1,1,"FIELD") #.137 "^DD",2,2,.136,5,1,0) 2^.133^1 "^DD",2,2,.136,21,0) ^^2^2^3060410^ "^DD",2,2,.136,21,1,0) This field will contain the date and time of the last "^DD",2,2,.136,21,2,0) EMAIL address update. "^DD",2,2,.136,"DT") 3060410 "^DD",2,2,.137,0) EMAIL ADDRESS CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;^.13;7^Q "^DD",2,2,.137,1,0) ^.1 "^DD",2,2,.137,1,1,0) ^^TRIGGER^2^.138 "^DD",2,2,.137,1,1,1) X ^DD(2,.137,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.137,1,1,1.4) "^DD",2,2,.137,1,1,1.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.137,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC" "^DD",2,2,.137,1,1,1.4) S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,8)=DIV,DIH=2,DIG=.138 D ^DICR "^DD",2,2,.137,1,1,2) X ^DD(2,.137,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.137,1,1,2.4) "^DD",2,2,.137,1,1,2.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(2,.137,0)),U,3),Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,7)_":",2),$C(59))'="VAMC" "^DD",2,2,.137,1,1,2.4) S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,8)=DIV,DIH=2,DIG=.138 D ^DICR "^DD",2,2,.137,1,1,"%D",0) ^^5^5^3060411^ "^DD",2,2,.137,1,1,"%D",1,0) This cross-reference will trigger the population of the EMAIL ADDRESS "^DD",2,2,.137,1,1,"%D",2,0) CHANGE SITE field with the appropriate station number if the EMAIL ADDRESS "^DD",2,2,.137,1,1,"%D",3,0) CHANGE SOURCE equals "VAMC". The EMAIL ADDRESS Change Site field should be "^DD",2,2,.137,1,1,"%D",4,0) overwritten for cases where the site would be incorrect (i.e. uploading "^DD",2,2,.137,1,1,"%D",5,0) Z05 message). "^DD",2,2,.137,1,1,"CREATE CONDITION") 'EMAIL ADDRESS CHANGE SOURCE'="VAMC" "^DD",2,2,.137,1,1,"CREATE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.137,1,1,"DELETE CONDITION") 'EMAIL ADDRESS CHANGE SOURCE'="VAMC" "^DD",2,2,.137,1,1,"DELETE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.137,1,1,"FIELD") #.138 "^DD",2,2,.137,3) Please enter the source of the EMAIL address change. "^DD",2,2,.137,5,1,0) 2^.136^1 "^DD",2,2,.137,21,0) ^^1^1^3060410^ "^DD",2,2,.137,21,1,0) This field will hold the source of the last EMAIL address change. "^DD",2,2,.137,"DT") 3060410 "^DD",2,2,.138,0) EMAIL ADDRESS CHANGE SITE^P4'^DIC(4,^.13;8^Q "^DD",2,2,.138,3) Please enter the site that last changed this patient's EMAIL address. "^DD",2,2,.138,5,1,0) 2^.137^1 "^DD",2,2,.138,21,0) ^^3^3^3060410^ "^DD",2,2,.138,21,1,0) This field will hold the site that last changed this "^DD",2,2,.138,21,2,0) patient's EMAIL address. This field is only populated "^DD",2,2,.138,21,3,0) when the EMAIL Address Source is listed as VAMC. "^DD",2,2,.138,"DT") 3060410 "^DD",2,2,.139,0) CELLULAR NUMBER CHANGE DT/TM^D^^.13;9^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.139,1,0) ^.1 "^DD",2,2,.139,1,1,0) ^^TRIGGER^2^.1311 "^DD",2,2,.139,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,10)=DIV,DIH=2,DIG=.1311 D ^DICR "^DD",2,2,.139,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,10)=DIV,DIH=2,DIG=.1311 D ^DICR "^DD",2,2,.139,1,1,"CREATE VALUE") S X="VAMC" "^DD",2,2,.139,1,1,"DELETE VALUE") S X="VAMC" "^DD",2,2,.139,1,1,"FIELD") #.1311 "^DD",2,2,.139,5,1,0) 2^.134^1 "^DD",2,2,.139,21,0) ^^2^2^3060410^ "^DD",2,2,.139,21,1,0) This field will contain the date and time of the last "^DD",2,2,.139,21,2,0) Cellular number update. "^DD",2,2,.139,"DT") 3060410 "^DD",2,2,.141,0) CONFIDENTIAL ADDRESS CATEGORY^2.141S^^.14;0 "^DD",2,2,.141,21,0) ^.001^2^2^3030313^^^^ "^DD",2,2,.141,21,1,0) This is a multiple valued field containing the confidential address "^DD",2,2,.141,21,2,0) categories for this applicant. "^DD",2,2,.14105,0) CONFIDENTIAL ADDRESS ACTIVE?^RSX^Y:YES;N:NO;^.141;9^S DFN=DA I X="N" D CADD^DGLOCK3 "^DD",2,2,.14105,1,0) ^.1 "^DD",2,2,.14105,1,1,0) 2^AXR31^MUMPS "^DD",2,2,.14105,1,1,1) Q "^DD",2,2,.14105,1,1,2) S DGXRF=.14105 D ^DGDDC Q "^DD",2,2,.14105,1,1,"DT") 3030113 "^DD",2,2,.14105,1,2,0) 2^AENR4105^MUMPS "^DD",2,2,.14105,1,2,1) I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG(DA) "^DD",2,2,.14105,1,2,2) I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG(DA) "^DD",2,2,.14105,1,2,"%D",0) ^.101^4^4^3060828^^ "^DD",2,2,.14105,1,2,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.14105,1,2,"%D",2,0) enrollment. It is necessary to have this trigger in addition to the "^DD",2,2,.14105,1,2,"%D",3,0) triggers on CONFIDENTIAL ADDRESS CATEGORY and CONFIDENTIAL ADDRESS CHANGE "^DD",2,2,.14105,1,2,"%D",4,0) DT/TM because of the order in which the fields are input. "^DD",2,2,.14105,1,2,"DT") 3060518 "^DD",2,2,.14105,3) Enter 'Y' if you want to enter or edit confidential address data. "^DD",2,2,.14105,21,0) ^.001^4^4^3030314^^^ "^DD",2,2,.14105,21,1,0) Enter 'Y' if you wish to enter a confidential address for this applicant "^DD",2,2,.14105,21,2,0) at this time. A 'NO' response will cause the Confidential Start Date "^DD",2,2,.14105,21,3,0) and Confidential End Date fields to be automatically deleted while other "^DD",2,2,.14105,21,4,0) confidential address information will remain on file for future use. "^DD",2,2,.14105,"DT") 3060829 "^DD",2,2,.1411,0) CONFIDENTIAL STREET [LINE 1]^FX^^.141;1^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1411,1,0) ^.1^^-1 "^DD",2,2,.1411,1,1,0) 2^AXR32^MUMPS "^DD",2,2,.1411,1,1,1) Q "^DD",2,2,.1411,1,1,2) S DGXRF=.1411 D ^DGDDC Q "^DD",2,2,.1411,1,1,"DT") 3030113 "^DD",2,2,.1411,3) Enter the first line of the applicant's confidential street address [2-30 characters]. "^DD",2,2,.1411,21,0) ^^4^4^3030311^ "^DD",2,2,.1411,21,1,0) If the 'Confidential Address Active' prompt is answered YES, the "^DD",2,2,.1411,21,2,0) user will be prompted for the first line of the confidential street "^DD",2,2,.1411,21,3,0) address. This field cannot be deleted as long as the need for a "^DD",2,2,.1411,21,4,0) confidential address is indicated. "^DD",2,2,.1411,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1411,"DT") 3060829 "^DD",2,2,.14111,0) CONFIDENTIAL ADDRESS COUNTY^NJ3,0OX^^.141;11^N Z0,DIC S Z0=+$P($G(^DPT(D0,.141)),"^",5) K:'Z0 X Q:'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X "^DD",2,2,.14111,1,0) ^.1^^0 "^DD",2,2,.14111,1,1,0) 2^AENR14111^MUMPS "^DD",2,2,.14111,1,1,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.14111,1,1,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.14111,1,1,3) DO NOT DELETE "^DD",2,2,.14111,1,1,"%D",0) ^.101^2^2^3050608^^^^ "^DD",2,2,.14111,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.14111,1,1,"%D",2,0) enrollment. "^DD",2,2,.14111,1,1,"DT") 3050608 "^DD",2,2,.14111,2) S Y(0)=Y S Y(0)=Y Q:Y']"" N Z0 S Z0=$P($G(^DPT(D0,.141)),"^",5) Q:'Z0 S Y=$P($G(^DIC(5,Z0,1,Y,0)),"^",3) "^DD",2,2,.14111,2.1) S Y(0)=Y Q:Y']"" N Z0 S Z0=$P($G(^DPT(D0,.141)),"^",5) Q:'Z0 S Y=$P($G(^DIC(5,Z0,1,Y,0)),"^",3) "^DD",2,2,.14111,3) Enter a valid county for the applicant's confidential address. "^DD",2,2,.14111,4) N Z0,DIC S X="?",Z0=+$P($G(^DPT(D0,.141)),"^",5) Q:'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC "^DD",2,2,.14111,21,0) ^.001^2^2^3030313^^ "^DD",2,2,.14111,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.14111,21,2,0) enter the county for the applicant's confidential address. "^DD",2,2,.14111,"DT") 3060829 "^DD",2,2,.14112,0) CONFIDENTIAL ADDR CHANGE DT/TM^DX^^.141;12^S %DT="ESTX" D ^%DT S X=Y K:X<1 X "^DD",2,2,.14112,1,0) ^.1 "^DD",2,2,.14112,1,1,0) 2^AENR14112^MUMPS "^DD",2,2,.14112,1,1,1) I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG(DA) "^DD",2,2,.14112,1,1,2) I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG(DA) "^DD",2,2,.14112,1,1,3) DO NOT DELETE "^DD",2,2,.14112,1,1,"%D",0) ^.101^2^2^3060828^^^^ "^DD",2,2,.14112,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.14112,1,1,"%D",2,0) enrollment. "^DD",2,2,.14112,1,1,"DT") 3060501 "^DD",2,2,.14112,1,2,0) ^^TRIGGER^2^.14113 "^DD",2,2,.14112,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.141)):^(.141),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.14112,1,2,1.4) "^DD",2,2,.14112,1,2,1.4) S DIH=$G(^DPT(DIV(0),.141)),DIV=X S $P(^(.141),U,13)=DIV,DIH=2,DIG=.14113 D ^DICR "^DD",2,2,.14112,1,2,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.141)):^(.141),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.14112,1,2,2.4) "^DD",2,2,.14112,1,2,2.4) S DIH=$G(^DPT(DIV(0),.141)),DIV=X S $P(^(.141),U,13)=DIV,DIH=2,DIG=.14113 D ^DICR "^DD",2,2,.14112,1,2,"CREATE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.14112,1,2,"DELETE VALUE") S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) "^DD",2,2,.14112,1,2,"DT") 3060501 "^DD",2,2,.14112,1,2,"FIELD") #.14113 "^DD",2,2,.14112,9) ^ "^DD",2,2,.14112,21,0) ^^2^2^3050519^ "^DD",2,2,.14112,21,1,0) This field will hold the date and time of the last Confidential Address "^DD",2,2,.14112,21,2,0) Update. "^DD",2,2,.14112,"DT") 3060501 "^DD",2,2,.1412,0) CONFIDENTIAL STREET [LINE 2]^FX^^.141;2^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1412,1,0) ^.1^^-1 "^DD",2,2,.1412,1,1,0) 2^AXR33^MUMPS "^DD",2,2,.1412,1,1,1) Q "^DD",2,2,.1412,1,1,2) S DGXRF=.1412 D ^DGDDC Q "^DD",2,2,.1412,1,1,"DT") 3030113 "^DD",2,2,.1412,3) If necessary, enter the second line of this applicant's confidential address [2-30 characters]. "^DD",2,2,.1412,21,0) ^^4^4^3030311^ "^DD",2,2,.1412,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1412,21,2,0) the user will be prompted for the second line of the confidential "^DD",2,2,.1412,21,3,0) street address [2-30 characters]. The second line of the street "^DD",2,2,.1412,21,4,0) address is optional and may be left blank. "^DD",2,2,.1412,"DT") 3060829 "^DD",2,2,.1413,0) CONFIDENTIAL STREET [LINE 3]^FX^^.141;3^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1413,1,0) ^.1^^0 "^DD",2,2,.1413,3) If necessary, enter the third line of this applicant's confidential street address [2-30 characters] "^DD",2,2,.1413,21,0) ^^4^4^3030312^ "^DD",2,2,.1413,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1413,21,2,0) the user will be prompted for the third line of the confidential "^DD",2,2,.1413,21,3,0) street address. The third line of the street address is optional "^DD",2,2,.1413,21,4,0) and may be left blank. "^DD",2,2,.1413,"DT") 3060829 "^DD",2,2,.1414,0) CONFIDENTIAL ADDRESS CITY^FX^^.141;4^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1414,1,0) ^.1^^0 "^DD",2,2,.1414,3) Enter the city for the applicant's confidential address [2-30 characters]. "^DD",2,2,.1414,21,0) ^^4^4^3030311^ "^DD",2,2,.1414,21,1,0) If the 'Confidential Address Active' prompt is answered YES, enter "^DD",2,2,.1414,21,2,0) the confidential address city for this applicant [2-30 characters]. "^DD",2,2,.1414,21,3,0) This field may not be deleted as long as the need for a confidential "^DD",2,2,.1414,21,4,0) address is indicated. "^DD",2,2,.1414,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1414,"DT") 3060829 "^DD",2,2,.1415,0) CONFIDENTIAL ADDRESS STATE^P5'X^DIC(5,^.141;5^S DFN=DA D CAD^DGLOCK3 Q "^DD",2,2,.1415,1,0) ^.1^^0 "^DD",2,2,.1415,3) Enter the State for the applicant's confidential address. "^DD",2,2,.1415,21,0) ^^4^4^3030311^ "^DD",2,2,.1415,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1415,21,2,0) the user will be asked to select the confidential address state "^DD",2,2,.1415,21,3,0) from the available listing. This field may not be deleted as "^DD",2,2,.1415,21,4,0) long as the need for a confidential address is indicated. "^DD",2,2,.1415,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1415,"DT") 3060829 "^DD",2,2,.1416,0) CONFIDENTIAL ADDRESS ZIP CODE^FXO^^.141;6^K:$L(X)>20!($L(X)<5) X I $D(X) S DFN=DA D CAD^DGLOCK3 I $D(X) D ZIPIN^VAFADDR "^DD",2,2,.1416,1,0) ^.1^^0 "^DD",2,2,.1416,2) S Y(0)=Y D ZIPOUT^VAFADDR "^DD",2,2,.1416,2.1) D ZIPOUT^VAFADDR "^DD",2,2,.1416,3) Answer with either the 5 digit or 9 digit zip code. "^DD",2,2,.1416,21,0) ^.001^4^4^3030314^^ "^DD",2,2,.1416,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1416,21,2,0) the user will be asked to enter the zip code assigned to the "^DD",2,2,.1416,21,3,0) city for the confidential address. This field may not be deleted "^DD",2,2,.1416,21,4,0) as long as the need for a confidential address is indicated. "^DD",2,2,.1416,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1416,"DT") 3060829 "^DD",2,2,.1417,0) CONFIDENTIAL START DATE^DX^^.141;7^S %DT="E",%DT(0)=DT D ^%DT S X=Y K:Y<1 X K %DT(0) I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1417,1,0) ^.1^^0 "^DD",2,2,.1417,3) Enter the date to begin contacting the applicant at the confidential address. Date cannot be in the past. "^DD",2,2,.1417,21,0) ^^3^3^3060829^ "^DD",2,2,.1417,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1417,21,2,0) enter the date to begin contacting the applicant at the "^DD",2,2,.1417,21,3,0) confidential address. "^DD",2,2,.1417,23,0) ^^10^10^3060829^ "^DD",2,2,.1417,23,1,0) This field contains an input transform which does a number of things. It "^DD",2,2,.1417,23,2,0) validates the date entered, does not allow a date prior to the current "^DD",2,2,.1417,23,3,0) date, and prevents changes to this field if the Confidential Address is "^DD",2,2,.1417,23,4,0) flagged INACTIVE. "^DD",2,2,.1417,23,5,0) "^DD",2,2,.1417,23,6,0) Special note: the input transform sets %DT(0)=DT to validate the date "^DD",2,2,.1417,23,7,0) entered. Because changes to this field will update the CONFIDENTIAL "^DD",2,2,.1417,23,8,0) ADDRESS CHANGE DT/TM field, it is necessary to kill %DT(0) after the "^DD",2,2,.1417,23,9,0) validation. This variable, if valued, can prevent EVENT^IVMPLOG from "^DD",2,2,.1417,23,10,0) setting the transmit flag if only the Start and End dates are changed. "^DD",2,2,.1417,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1417,"DT") 3060829 "^DD",2,2,.1418,0) CONFIDENTIAL END DATE^DX^^.141;8^S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D CAD^DGLOCK3 I $D(X),(X<$P(^DPT(DFN,.141),"^",7)) K X "^DD",2,2,.1418,1,0) ^.1^^0 "^DD",2,2,.1418,3) Enter the date the applicant will no longer be contacted at the confidential address. End date must be after start date. "^DD",2,2,.1418,21,0) ^.001^2^2^3030314^^ "^DD",2,2,.1418,21,1,0) If the 'Confidential Address Active' prompt is answered YES, enter "^DD",2,2,.1418,21,2,0) the date the applicant will no longer be contacted at this address. "^DD",2,2,.1418,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1418,"DT") 3060829 "^DD",2,2,.32115,0) PROJ 112/SHAD^S^1:YES;0:NO;^.321;15^Q "^DD",2,2,.32115,1,0) ^.1 "^DD",2,2,.32115,1,1,0) 2^AENR32115^MUMPS "^DD",2,2,.32115,1,1,1) D AUTOUPD^DGENA2(DA) "^DD",2,2,.32115,1,1,2) D AUTOUPD^DGENA2(DA) "^DD",2,2,.32115,1,1,3) DO NOT DELETE "^DD",2,2,.32115,1,1,"%D",0) ^^2^2^3060713^ "^DD",2,2,.32115,1,1,"%D",1,0) This cross-reference is used to update the patient's current Patient "^DD",2,2,.32115,1,1,"%D",2,0) Enrollment record. "^DD",2,2,.32115,1,1,"DT") 3060713 "^DD",2,2,.32115,"DT") 3060713 "^DD",2,2,.3951,0) DATE VETERAN REQUESTED CD EVAL^D^^.39;7^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.3951,1,0) ^.1 "^DD",2,2,.3951,1,1,0) 2^AENR3951^MUMPS "^DD",2,2,.3951,1,1,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.3951,1,1,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.3951,1,1,3) DO NOT DELETE "^DD",2,2,.3951,1,1,"%D",0) ^.101^2^2^3050930^^^^ "^DD",2,2,.3951,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.3951,1,1,"%D",2,0) enrollment. "^DD",2,2,.3951,1,1,"DT") 3050930 "^DD",2,2,.3951,"DT") 3050930 "^DD",2,2,.3952,0) DATE FACILITY INITIATED REVIEW^D^^.39;8^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.3952,1,0) ^.1 "^DD",2,2,.3952,1,1,0) 2^AENR3952^MUMPS "^DD",2,2,.3952,1,1,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.3952,1,1,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.3952,1,1,3) DO NOT DELETE "^DD",2,2,.3952,1,1,"%D",0) ^.101^2^2^3050930^^^^ "^DD",2,2,.3952,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.3952,1,1,"%D",2,0) enrollment. "^DD",2,2,.3952,1,1,"DT") 3050930 "^DD",2,2,.3952,"DT") 3050930 "^DD",2,2,.3953,0) DATE VETERAN WAS NOTIFIED^D^^.39;9^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",2,2,.3953,1,0) ^.1 "^DD",2,2,.3953,1,1,0) 2^AENR3953^MUMPS "^DD",2,2,.3953,1,1,1) D EVENT^IVMPLOG(DA) "^DD",2,2,.3953,1,1,2) D EVENT^IVMPLOG(DA) "^DD",2,2,.3953,1,1,3) DO NOT DELETE "^DD",2,2,.3953,1,1,"%D",0) ^.101^2^2^3050930^^^^ "^DD",2,2,.3953,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",2,2,.3953,1,1,"%D",2,0) enrollment. "^DD",2,2,.3953,1,1,"DT") 3050930 "^DD",2,2,.3953,"DT") 3050930 "^DD",2,2.141,0) CONFIDENTIAL ADDRESS CATEGORY SUB-FIELD^^1^2 "^DD",2,2.141,0,"NM","CONFIDENTIAL ADDRESS CATEGORY") "^DD",2,2.141,.01,0) CONFIDENTIAL ADDRESS CATEGORY^MS^1:ELIGIBILITY/ENROLLMENT;2:APPOINTMENT/SCHEDULING;3:COPAYMENTS/VETERAN BILLING;4:MEDICAL RECORDS;5:ALL OTHERS;^0;1^Q "^DD",2,2.141,.01,.1) "^DD",2,2.141,.01,1,0) ^.1 "^DD",2,2.141,.01,1,1,0) 2.141^B "^DD",2,2.141,.01,1,1,1) S ^DPT(DA(1),.14,"B",$E(X,1,30),DA)="" "^DD",2,2.141,.01,1,1,2) K ^DPT(DA(1),.14,"B",$E(X,1,30),DA) "^DD",2,2.141,.01,3) Enter the confidential address category for the applicant's confidential communications. "^DD",2,2.141,.01,21,0) ^.001^3^3^3030313^^ "^DD",2,2.141,.01,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2.141,.01,21,2,0) select the confidential address category for this applicant's "^DD",2,2.141,.01,21,3,0) confidential communications. "^DD",2,2.141,.01,"DT") 3060518 "^DD",2,2.141,1,0) CONFIDENTIAL CATEGORY ACTIVE^S^Y:YES;N:NO;^0;2^Q "^DD",2,2.141,1,3) Enter Yes if the confidential address category for the applicant's confidential communications is active. "^DD",2,2.141,1,21,0) ^.001^3^3^3030313^^ "^DD",2,2.141,1,21,1,0) If the applicant's confidential communications for this category should "^DD",2,2.141,1,21,2,0) be sent to the confidential address, Confidential Category Active field "^DD",2,2.141,1,21,3,0) should be set to yes. If not, select N or No. "^DD",2,2.141,1,"DT") 3060518 "^DD",2,2.399,.3951,0) DATE VETERAN REQUESTED CD EVAL^D^^0;8^S %DT="E" D ^%DT S X=Y K:Y<1 X "^DD",2,2.399,.3951,"DT") 3050915 "^DD",2,2.399,.3952,0) DATE FACILITY INITIATED REVIEW^D^^0;9^S %DT="E" D ^%DT S X=Y K:Y<1 X "^DD",2,2.399,.3952,"DT") 3050915 "^DD",2,2.399,.3953,0) DATE VETERAN WAS NOTIFIED^D^^0;10^S %DT="E" D ^%DT S X=Y K:Y<1 X "^DD",2,2.399,.3953,"DT") 3050915 "^DD",27.11,27.11,50.19,0) PROJ 112/SHAD^S^1:YES;0:NO;^E;19^Q "^DD",27.11,27.11,50.19,"DT") 3050602 "^DD",38.6,38.6,6,0) USE FOR Z07 CHECK^S^0:NO;1:YES;^0;6^Q "^DD",38.6,38.6,6,"DT") 3051013 "^DD",408.13,408.13,.09,0) SOCIAL SECURITY NUMBER^RFX^^0;9^K:X[""""!($A(X)=45) X I $D(X) D SSN^DGMTDD1 "^DD",408.13,408.13,.09,.1) SSN "^DD",408.13,408.13,.09,1,0) ^.1 "^DD",408.13,408.13,.09,1,1,0) 408.13^BS^MUMPS "^DD",408.13,408.13,.09,1,1,1) S ^DGPR(408.13,"BS",$E(X,6,9),DA)="" "^DD",408.13,408.13,.09,1,1,2) K ^DGPR(408.13,"BS",$E(X,6,9),DA) "^DD",408.13,408.13,.09,1,1,"DT") 2920121 "^DD",408.13,408.13,.09,1,2,0) 408.13^BS5^MUMPS "^DD",408.13,408.13,.09,1,2,1) S ^DGPR(408.13,"BS5",$E(^DGPR(408.13,DA,0),1)_$E(X,6,9),DA)="" "^DD",408.13,408.13,.09,1,2,2) K ^DGPR(408.13,"BS5",$E(^DGPR(408.13,DA,0),1)_$E(X,6,9),DA) "^DD",408.13,408.13,.09,1,2,"DT") 2920121 "^DD",408.13,408.13,.09,1,3,0) 408.13^SSN "^DD",408.13,408.13,.09,1,3,1) S ^DGPR(408.13,"SSN",$E(X,1,30),DA)="" "^DD",408.13,408.13,.09,1,3,2) K ^DGPR(408.13,"SSN",$E(X,1,30),DA) "^DD",408.13,408.13,.09,1,3,"DT") 2920121 "^DD",408.13,408.13,.09,1,4,0) 408.13^AIVM^MUMPS "^DD",408.13,408.13,.09,1,4,1) S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T SPSSN^IVMPXFR S X=IVMX K IVMX "^DD",408.13,408.13,.09,1,4,2) S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T SPSSN^IVMPXFR S X=IVMX K IVMX "^DD",408.13,408.13,.09,1,4,"%D",0) ^^4^4^2940714^ "^DD",408.13,408.13,.09,1,4,"%D",1,0) This cross-reference will check the IVM PATIENT file to see if a change "^DD",408.13,408.13,.09,1,4,"%D",2,0) to this field will require transmission to the IVM Center. If it does, "^DD",408.13,408.13,.09,1,4,"%D",3,0) the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and "^DD",408.13,408.13,.09,1,4,"%D",4,0) the nightly background job will transmit the updated information. "^DD",408.13,408.13,.09,1,4,"DT") 2940714 "^DD",408.13,408.13,.09,1,5,0) ^^TRIGGER^408.13^.1 "^DD",408.13,408.13,.09,1,5,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0)'["P" I X S X=DIV S Y(1)=$S($D(^DGPR(408.13,D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(408.13,.09,1,5,1.4) "^DD",408.13,408.13,.09,1,5,1.4) S DIH=$G(^DGPR(408.13,DIV(0),0)),DIV=X S $P(^(0),U,10)=DIV,DIH=408.13,DIG=.1 D ^DICR "^DD",408.13,408.13,.09,1,5,2) Q "^DD",408.13,408.13,.09,1,5,3) DO NOT DELETE "^DD",408.13,408.13,.09,1,5,"%D",0) ^^1^1^3050914^ "^DD",408.13,408.13,.09,1,5,"%D",1,0) Pseudo SSN Reason will have a value only if SSN is a Pseudo SSN. "^DD",408.13,408.13,.09,1,5,"CREATE CONDITION") #.09'["P" "^DD",408.13,408.13,.09,1,5,"CREATE VALUE") @ "^DD",408.13,408.13,.09,1,5,"DELETE VALUE") NO EFFECT "^DD",408.13,408.13,.09,1,5,"DT") 3050914 "^DD",408.13,408.13,.09,1,5,"FIELD") PSEUDO SSN REASON "^DD",408.13,408.13,.09,3) Answer with this dependent's social security number. Answer must be 9 numbers in length or a "P" or a pseudo SSN. "^DD",408.13,408.13,.09,21,0) ^.001^13^13^3070130^^ "^DD",408.13,408.13,.09,21,1,0) Answer with the individual's social security number. Answer must be 9 "^DD",408.13,408.13,.09,21,2,0) numbers in length. The SSN will be sent to the SSA for verification. "^DD",408.13,408.13,.09,21,3,0) This status will be displayed next to the SSN. Once an SSN has "^DD",408.13,408.13,.09,21,4,0) received a status of Verified, it is locked from user updating and a "^DD",408.13,408.13,.09,21,5,0) "VERIFIED" will be displayed by the SSN field. Only HEC staff are able "^DD",408.13,408.13,.09,21,6,0) to change a Spouse or Dependent verified SSN. If SSA indicates the "^DD",408.13,408.13,.09,21,7,0) SSN is invalid, "INVALID" will appear next to the invalid SSN of the "^DD",408.13,408.13,.09,21,8,0) individual. Facilities should make every effort to obtain the accurate "^DD",408.13,408.13,.09,21,9,0) SSN from the individual for any invalid or pseudo SSN. "^DD",408.13,408.13,.09,21,10,0) "^DD",408.13,408.13,.09,21,11,0) If a valid SSN is not known, then a "P" will be entered at the SSN "^DD",408.13,408.13,.09,21,12,0) prompt for the system to automatically assign a Pseudo-SSN. If a "^DD",408.13,408.13,.09,21,13,0) Pseudo SSN is entered, a Reason for entering it will be required. "^DD",408.13,408.13,.09,23,0) ^.001^1^1^3070130^^^^ "^DD",408.13,408.13,.09,23,1,0) This contains the SSN of the veteran's dependents. "^DD",408.13,408.13,.09,"DT") 3060919 "^DD",408.13,408.13,.1,0) PSEUDO SSN REASON^RS^R:REFUSED TO PROVIDE;S:SSN UNKNOWN/FOLLOW-UP REQUIRED;N:NO SSN ASSIGNED;^0;10^Q "^DD",408.13,408.13,.1,1,0) ^.1 "^DD",408.13,408.13,.1,1,1,0) 408.13^AENR1^MUMPS "^DD",408.13,408.13,.1,1,1,1) D E40813^DGRTRIG(DA) "^DD",408.13,408.13,.1,1,1,2) D E40813^DGRTRIG(DA) "^DD",408.13,408.13,.1,1,1,3) DO NOT DELETE "^DD",408.13,408.13,.1,1,1,"%D",0) ^.101^2^2^3050930^^^^ "^DD",408.13,408.13,.1,1,1,"%D",1,0) This cross-reference is used to notify HEC of changes that may affect "^DD",408.13,408.13,.1,1,1,"%D",2,0) enrollment. "^DD",408.13,408.13,.1,1,1,"DT") 3050930 "^DD",408.13,408.13,.1,5,1,0) 408.13^.09^5 "^DD",408.13,408.13,.1,21,0) ^.001^17^17^3060801^^ "^DD",408.13,408.13,.1,21,1,0) This field is used to document the reason the individual was assigned a "^DD",408.13,408.13,.1,21,2,0) pseudo SSN. Based on your selection, the Pseudo SSN Report (Dependent) "^DD",408.13,408.13,.1,21,3,0) option located in the Means Test Menu can provide you a current report "^DD",408.13,408.13,.1,21,4,0) of the reasons entered at this prompt. The following reasons are "^DD",408.13,408.13,.1,21,5,0) available for selection: "^DD",408.13,408.13,.1,21,6,0) "^DD",408.13,408.13,.1,21,7,0) Refused to Provide - use this reason when the individual was asked for "^DD",408.13,408.13,.1,21,8,0) his/her SSN and refused to provide the number. "^DD",408.13,408.13,.1,21,9,0) "^DD",408.13,408.13,.1,21,10,0) SSN Unknown/Follow-up required - use this reason when the individual is "^DD",408.13,408.13,.1,21,11,0) not available to ask/answer the request for SSN. The facility should "^DD",408.13,408.13,.1,21,12,0) initiate Follow-up activity to obtain the SSN. "^DD",408.13,408.13,.1,21,13,0) "^DD",408.13,408.13,.1,21,14,0) No SSN Assigned - use this reason when the individual has not been "^DD",408.13,408.13,.1,21,15,0) assigned an SSN. This generally applies to spouses or dependents "^DD",408.13,408.13,.1,21,16,0) of veterans who are not US citizens and infrequently, non-citizen "^DD",408.13,408.13,.1,21,17,0) beneficiaries. "^DD",408.13,408.13,.1,"DT") 3050930 **INSTALL NAME** IVM*2.0*105 "BLD",7086,0) IVM*2.0*105^INCOME VERIFICATION MATCH^0^3070702^y "BLD",7086,4,0) ^9.64PA^^0 "BLD",7086,6.3) 2 "BLD",7086,"ABPKG") n "BLD",7086,"KRN",0) ^9.67PA^8989.52^19 "BLD",7086,"KRN",.4,0) .4 "BLD",7086,"KRN",.401,0) .401 "BLD",7086,"KRN",.402,0) .402 "BLD",7086,"KRN",.403,0) .403 "BLD",7086,"KRN",.5,0) .5 "BLD",7086,"KRN",.84,0) .84 "BLD",7086,"KRN",3.6,0) 3.6 "BLD",7086,"KRN",3.8,0) 3.8 "BLD",7086,"KRN",9.2,0) 9.2 "BLD",7086,"KRN",9.8,0) 9.8 "BLD",7086,"KRN",9.8,"NM",0) ^9.68A^24^21 "BLD",7086,"KRN",9.8,"NM",3,0) IVMCZMT^^0^B58915874 "BLD",7086,"KRN",9.8,"NM",4,0) IVMZ07C^^0^B18729103 "BLD",7086,"KRN",9.8,"NM",5,0) IVMZ7CR^^0^B68760860 "BLD",7086,"KRN",9.8,"NM",6,0) IVMZ7CCD^^0^B26088689 "BLD",7086,"KRN",9.8,"NM",8,0) IVMPBUL^^0^B7852022 "BLD",7086,"KRN",9.8,"NM",9,0) IVMPREC^^0^B24894893 "BLD",7086,"KRN",9.8,"NM",10,0) IVMPTRN^^0^B44251671 "BLD",7086,"KRN",9.8,"NM",11,0) IVMPTRN7^^0^B7588290 "BLD",7086,"KRN",9.8,"NM",12,0) IVMPTRN8^^0^B44153552 "BLD",7086,"KRN",9.8,"NM",13,0) IVMPTRN9^^0^B52146820 "BLD",7086,"KRN",9.8,"NM",14,0) IVMZ7CE^^0^B3811155 "BLD",7086,"KRN",9.8,"NM",15,0) IVMZ7CD^^0^B18262093 "BLD",7086,"KRN",9.8,"NM",16,0) IVMZ7CS^^0^B9251423 "BLD",7086,"KRN",9.8,"NM",17,0) IVMCMF1^^0^B8196181 "BLD",7086,"KRN",9.8,"NM",18,0) IVMCMF2^^0^B10358684 "BLD",7086,"KRN",9.8,"NM",19,0) IVMCM2^^0^B16587126 "BLD",7086,"KRN",9.8,"NM",20,0) IVMCM5^^0^B18850918 "BLD",7086,"KRN",9.8,"NM",21,0) IVMCM9^^0^B5493749 "BLD",7086,"KRN",9.8,"NM",22,0) IVMPTRNA^^0^B15122403 "BLD",7086,"KRN",9.8,"NM",23,0) IVMZ072^^0^B3473516 "BLD",7086,"KRN",9.8,"NM",24,0) IVMLDEM6^^0^B61965432 "BLD",7086,"KRN",9.8,"NM","B","IVMCM2",19) "BLD",7086,"KRN",9.8,"NM","B","IVMCM5",20) "BLD",7086,"KRN",9.8,"NM","B","IVMCM9",21) "BLD",7086,"KRN",9.8,"NM","B","IVMCMF1",17) "BLD",7086,"KRN",9.8,"NM","B","IVMCMF2",18) "BLD",7086,"KRN",9.8,"NM","B","IVMCZMT",3) "BLD",7086,"KRN",9.8,"NM","B","IVMLDEM6",24) "BLD",7086,"KRN",9.8,"NM","B","IVMPBUL",8) "BLD",7086,"KRN",9.8,"NM","B","IVMPREC",9) "BLD",7086,"KRN",9.8,"NM","B","IVMPTRN",10) "BLD",7086,"KRN",9.8,"NM","B","IVMPTRN7",11) "BLD",7086,"KRN",9.8,"NM","B","IVMPTRN8",12) "BLD",7086,"KRN",9.8,"NM","B","IVMPTRN9",13) "BLD",7086,"KRN",9.8,"NM","B","IVMPTRNA",22) "BLD",7086,"KRN",9.8,"NM","B","IVMZ072",23) "BLD",7086,"KRN",9.8,"NM","B","IVMZ07C",4) "BLD",7086,"KRN",9.8,"NM","B","IVMZ7CCD",6) "BLD",7086,"KRN",9.8,"NM","B","IVMZ7CD",15) "BLD",7086,"KRN",9.8,"NM","B","IVMZ7CE",14) "BLD",7086,"KRN",9.8,"NM","B","IVMZ7CR",5) "BLD",7086,"KRN",9.8,"NM","B","IVMZ7CS",16) "BLD",7086,"KRN",19,0) 19 "BLD",7086,"KRN",19,"NM",0) ^9.68A^^ "BLD",7086,"KRN",19.1,0) 19.1 "BLD",7086,"KRN",101,0) 101 "BLD",7086,"KRN",409.61,0) 409.61 "BLD",7086,"KRN",771,0) 771 "BLD",7086,"KRN",870,0) 870 "BLD",7086,"KRN",8989.51,0) 8989.51 "BLD",7086,"KRN",8989.52,0) 8989.52 "BLD",7086,"KRN",8994,0) 8994 "BLD",7086,"KRN","B",.4,.4) "BLD",7086,"KRN","B",.401,.401) "BLD",7086,"KRN","B",.402,.402) "BLD",7086,"KRN","B",.403,.403) "BLD",7086,"KRN","B",.5,.5) "BLD",7086,"KRN","B",.84,.84) "BLD",7086,"KRN","B",3.6,3.6) "BLD",7086,"KRN","B",3.8,3.8) "BLD",7086,"KRN","B",9.2,9.2) "BLD",7086,"KRN","B",9.8,9.8) "BLD",7086,"KRN","B",19,19) "BLD",7086,"KRN","B",19.1,19.1) "BLD",7086,"KRN","B",101,101) "BLD",7086,"KRN","B",409.61,409.61) "BLD",7086,"KRN","B",771,771) "BLD",7086,"KRN","B",870,870) "BLD",7086,"KRN","B",8989.51,8989.51) "BLD",7086,"KRN","B",8989.52,8989.52) "BLD",7086,"KRN","B",8994,8994) "BLD",7086,"QUES",0) ^9.62^^ "BLD",7086,"REQB",0) ^9.611^10^6 "BLD",7086,"REQB",4,0) IVM*2.0*104^2 "BLD",7086,"REQB",6,0) IVM*2.0*88^2 "BLD",7086,"REQB",7,0) IVM*2.0*107^2 "BLD",7086,"REQB",8,0) IVM*2.0*114^2 "BLD",7086,"REQB",9,0) IVM*2.0*116^2 "BLD",7086,"REQB",10,0) IVM*2.0*106^2 "BLD",7086,"REQB","B","IVM*2.0*104",4) "BLD",7086,"REQB","B","IVM*2.0*106",10) "BLD",7086,"REQB","B","IVM*2.0*107",7) "BLD",7086,"REQB","B","IVM*2.0*114",8) "BLD",7086,"REQB","B","IVM*2.0*116",9) "BLD",7086,"REQB","B","IVM*2.0*88",6) "MBREQ") 0 "PKG",120,-1) 1^1 "PKG",120,0) INCOME VERIFICATION MATCH^IVM^IVM Software for interface with the IVM Center "PKG",120,22,0) ^9.49I^1^1 "PKG",120,22,1,0) 2.0^2941021^2960823 "PKG",120,22,1,"PAH",1,0) 105^3070702^83 "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") YES "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") YES "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") YES "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") 21 "RTN","IVMCM2") 0^19^B16587126 "RTN","IVMCM2",1,0) IVMCM2 ;ALB/SEK,CKN - ADD NEW DCD DEPENDENT TO INCOME PERSON FILE ; 2/8/06 2:00pm "RTN","IVMCM2",2,0) ;;2.0;INCOME VERIFICATION MATCH;**17,105**;21-OCT-94;Build 2 "RTN","IVMCM2",3,0) ;;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","IVMCM2",4,0) ; "RTN","IVMCM2",5,0) EN ; this routine will add entries to INCOME PERSON file (408.13) for "RTN","IVMCM2",6,0) ; new dependents (spouse/children). if DCD demo data (name, dob, "RTN","IVMCM2",7,0) ; ssn, sex) is different than VAMC data, 408.13 will be changed to "RTN","IVMCM2",8,0) ; contain the DCD data. the MEANS TEST CHANGES file (408.41) will "RTN","IVMCM2",9,0) ; contain both values. "RTN","IVMCM2",10,0) ; "RTN","IVMCM2",11,0) INPIEN ; get INCOME PERSON IEN "RTN","IVMCM2",12,0) ; if PATIENT RELATION IEN not in ZDP "RTN","IVMCM2",13,0) ; add dependent to INCOME PERSON file if dependent not found "RTN","IVMCM2",14,0) ; dependent found if dob, sex, & relationship (408.12) match "RTN","IVMCM2",15,0) ; "RTN","IVMCM2",16,0) ; Input DFN IEN of file #2 "RTN","IVMCM2",17,0) ; IVMSEG dependent's ZDP segment "RTN","IVMCM2",18,0) ; "RTN","IVMCM2",19,0) ; ivmflg1=1 have 408.13 ien when exit (found or added) "RTN","IVMCM2",20,0) ; ivmflg2=1 dep record must be added to 408.12 "RTN","IVMCM2",21,0) ; ivmflg5=1 spouse ZDP incomplete(not dependent) - always spouse records "RTN","IVMCM2",22,0) S (IVMFLG1,IVMFLG2,IVMFLG5)=0 "RTN","IVMCM2",23,0) S DGPRI=$P(IVMSEG,"^",7) ; ien of patient relation file "RTN","IVMCM2",24,0) ; "RTN","IVMCM2",25,0) S IVMNM=$$FMNAME^HLFNC($P(IVMSEG,"^",2)),IVMSEX=$P(IVMSEG,"^",3),IVMDOB=$$FMDATE^HLFNC($P(IVMSEG,"^",4)),IVMSSN=$P(IVMSEG,"^",5) "RTN","IVMCM2",26,0) S IVMEFFDT=$$FMDATE^HLFNC($P(IVMSEG,"^",9)),IVMRELN=$P(IVMSEG,"^",6) "RTN","IVMCM2",27,0) S IVMSPMNM=$P(IVMSEG,"^",8) ;Spouse Maiden Name IVM*2*105 "RTN","IVMCM2",28,0) S IVMPSSNR=$P(IVMSEG,"^",10) ;Pseudo SSN Reason IVM*2*105 "RTN","IVMCM2",29,0) I IVMPSSNR]"",IVMPSSNR'="R",IVMPSSNR'="S",IVMPSSNR'="N" S IVMPSSNR="" "RTN","IVMCM2",30,0) ; "RTN","IVMCM2",31,0) I IVMSPCHV="S"&((IVMNM']"")!(IVMSEX']"")!(IVMDOB']"")) S IVMFLG5=1 Q "RTN","IVMCM2",32,0) I 'DGPRI G NOIEN "RTN","IVMCM2",33,0) ; "RTN","IVMCM2",34,0) ; if ien of patient relation file (dgpri) transmitted by IVM Center "RTN","IVMCM2",35,0) ; and found in 408.12, get ien of income person. if DCD demo data "RTN","IVMCM2",36,0) ; is different, change in 408.13 & add to 408.41 "RTN","IVMCM2",37,0) ; ivmprn is 0 node of 408.12 "RTN","IVMCM2",38,0) ; dgipi is ien of 408.13 "RTN","IVMCM2",39,0) S IVMPRN=$G(^DGPR(408.12,+DGPRI,0)) "RTN","IVMCM2",40,0) I IVMPRN]"" D GETIPI Q:$D(IVMFERR) S DGIPI=+$P($P(IVMPRN,"^",3),";"),IVMFLG1=1,IVMRELO=$P(IVMPRN,"^",2) D AUDITP^IVMCM9,AUDIT^IVMCM9 Q "RTN","IVMCM2",41,0) ; "RTN","IVMCM2",42,0) NOIEN ; ien of patient relation file is not transmitted or transmitted and "RTN","IVMCM2",43,0) ; not found "RTN","IVMCM2",44,0) ; check if dependent in income person file "RTN","IVMCM2",45,0) ; if dependent not found in 408.13, setup ivmstr = 0 node of 408.13 "RTN","IVMCM2",46,0) ; subscript of array IVMAR is ien of 408.12 transmitted by IVM Center or "RTN","IVMCM2",47,0) ; created or found by upload. "RTN","IVMCM2",48,0) ; "RTN","IVMCM2",49,0) S DGPRI=0 F S DGPRI=$O(^DGPR(408.12,"B",DFN,DGPRI)) Q:'DGPRI D Q:IVMFLG1!($D(IVMFERR)) "RTN","IVMCM2",50,0) .D GETIP "RTN","IVMCM2",51,0) .Q:$D(IVMFERR)!($D(IVMAR(DGPRI)))!(IVMRELO=1) "RTN","IVMCM2",52,0) .I IVMSEX=IVMSEX13&(IVMDOB=IVMDOB13)&(IVMRELN=IVMRELO) S IVMFLG1=1,IVMAR(DGPRI)="" "RTN","IVMCM2",53,0) .Q "RTN","IVMCM2",54,0) ; "RTN","IVMCM2",55,0) ; found dependent in 408.13. if demo data different, change in 408.13 "RTN","IVMCM2",56,0) ; and add in 408.41 "RTN","IVMCM2",57,0) Q:$D(IVMFERR) "RTN","IVMCM2",58,0) I IVMFLG1 S DGIPI=+$P($P(IVMPRN,"^",3),";") D AUDITP^IVMCM9,AUDIT1^IVMCM9 Q "RTN","IVMCM2",59,0) ; "RTN","IVMCM2",60,0) ; dependent not found. add record to 408.13 "RTN","IVMCM2",61,0) I 'IVMFLG1 D "RTN","IVMCM2",62,0) .S $P(IVMSTR,"^")=IVMNM,$P(IVMSTR,"^",2)=IVMSEX,$P(IVMSTR,"^",3)=IVMDOB,$P(IVMSTR,"^",9)=IVMSSN,$P(IVMSTR,"^",10)=IVMPSSNR,$P(IVMSTR1,"^")=IVMSPMNM "RTN","IVMCM2",63,0) .D ADDDEP "RTN","IVMCM2",64,0) Q "RTN","IVMCM2",65,0) ; "RTN","IVMCM2",66,0) ADDDEP ; add dependent to 408.13 file "RTN","IVMCM2",67,0) ; In - DFN=IEN of File #2 "RTN","IVMCM2",68,0) ; DGRP0ND=0 node of 408.13 "RTN","IVMCM2",69,0) ; DGRP1ND=1 node of 408.13 "RTN","IVMCM2",70,0) ;Out - DGIPI=408.13 IEN "RTN","IVMCM2",71,0) ; "RTN","IVMCM2",72,0) N X,Y "RTN","IVMCM2",73,0) S DGRP0ND=IVMSTR "RTN","IVMCM2",74,0) S DGRP1ND=IVMSTR1 "RTN","IVMCM2",75,0) K DINUM "RTN","IVMCM2",76,0) S (DIK,DIC)="^DGPR(408.13,",DIC(0)="L",DLAYGO=408.13,X=$P(DGRP0ND,"^") K DD,DO D FILE^DICN S (DGIPI,DA)=+Y K DLAYGO "RTN","IVMCM2",77,0) ; "RTN","IVMCM2",78,0) ; if can't create stub notify site & IVM Center "RTN","IVMCM2",79,0) I DGIPI'>0 D Q "RTN","IVMCM2",80,0) .S (IVMTEXT(6))="Can't create stub for file 408.13" "RTN","IVMCM2",81,0) .D PROB^IVMCMC(IVMTEXT(6)) "RTN","IVMCM2",82,0) .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS") "RTN","IVMCM2",83,0) .S IVMFERR="" "RTN","IVMCM2",84,0) L +^DGPR(408.13,+DGIPI) S ^DGPR(408.13,+DGIPI,0)=DGRP0ND,^DGPR(408.13,+DGIPI,1)=DGRP1ND D IX1^DIK L -^DGPR(408.13,+DGIPI) "RTN","IVMCM2",85,0) S IVMFLG2=1 ; added dep to 408.13 must add to 408.12 "RTN","IVMCM2",86,0) K DIK,DIC "RTN","IVMCM2",87,0) Q "RTN","IVMCM2",88,0) ; "RTN","IVMCM2",89,0) ; "RTN","IVMCM2",90,0) GETIP ; if can't find 408.12 record notify site & IVM Center "RTN","IVMCM2",91,0) S IVMPRN=$G(^DGPR(408.12,+DGPRI,0)) "RTN","IVMCM2",92,0) S IVMRELO=$P(IVMPRN,"^",2) "RTN","IVMCM2",93,0) I IVMPRN']"" D Q "RTN","IVMCM2",94,0) .S (IVMTEXT(6))="Can't find 408.12 record "_DGPRI "RTN","IVMCM2",95,0) .D PROB^IVMCMC(IVMTEXT(6)) "RTN","IVMCM2",96,0) .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS") "RTN","IVMCM2",97,0) .S IVMFERR="" "RTN","IVMCM2",98,0) Q:IVMRELO=1 "RTN","IVMCM2",99,0) ; "RTN","IVMCM2",100,0) GETIPI ; ivmseg13 is 0 node of income person file "RTN","IVMCM2",101,0) ; get demo data in 408.13 & 408.12 "RTN","IVMCM2",102,0) S IVMSEG13=$$DEM^DGMTU1(DGPRI) "RTN","IVMCM2",103,0) S IVMSG131=$$DEM1^DGMTU1(DGPRI) ;Get node 1 "RTN","IVMCM2",104,0) I IVMSEG13']"" D Q "RTN","IVMCM2",105,0) .S (IVMTEXT(6))="Can't find 408.13 record" "RTN","IVMCM2",106,0) .D PROB^IVMCMC(IVMTEXT(6)) "RTN","IVMCM2",107,0) .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS") "RTN","IVMCM2",108,0) .S IVMFERR="" "RTN","IVMCM2",109,0) S IVMSEX13=$P(IVMSEG13,"^",2),IVMDOB13=$P(IVMSEG13,"^",3),IVMSSN13=$P(IVMSEG13,"^",9),IVMPSR13=$P(IVMSEG13,"^",10) "RTN","IVMCM2",110,0) S IVMSMN13=$P($G(IVMSG131),"^") "RTN","IVMCM2",111,0) S IVMNM13=$P(IVMSEG13,"^") "RTN","IVMCM2",112,0) Q "RTN","IVMCM5") 0^20^B18850918 "RTN","IVMCM5",1,0) IVMCM5 ;ALB/SEK,BRM,CKN - ADD NEW DCD INCOME RELATION FILE ENTRIES ; 2/8/06 2:01pm "RTN","IVMCM5",2,0) ;;2.0;INCOME VERIFICATION MATCH;**17,49,105**;21-OCT-94;Build 2 "RTN","IVMCM5",3,0) ;;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","IVMCM5",4,0) ; "RTN","IVMCM5",5,0) EN ; this routine will add entries to INCOME RELATION file (408.22). "RTN","IVMCM5",6,0) ; will inactivate dependents (spouse & children) who are not "RTN","IVMCM5",7,0) ; dependents of the test being uploaded, by adding an inactivate "RTN","IVMCM5",8,0) ; entry into the EFFECTIVE DATE sub-file (multiple-408.1275) of "RTN","IVMCM5",9,0) ; the PATIENT RELATION file (#408.12). "RTN","IVMCM5",10,0) ; "RTN","IVMCM5",11,0) ; exceptions to above: "RTN","IVMCM5",12,0) ; . income screening: "RTN","IVMCM5",13,0) ; . "mt" node not set to annual means test ien "RTN","IVMCM5",14,0) ; . no replaced test to change primary test for income year "RTN","IVMCM5",15,0) ; field to 0 "RTN","IVMCM5",16,0) ; "RTN","IVMCM5",17,0) ; "RTN","IVMCM5",18,0) ; DFN Patient file IEN "RTN","IVMCM5",19,0) ; DGINI Individual Annual Income IEN "RTN","IVMCM5",20,0) ; DGIRI Income Relation IEN "RTN","IVMCM5",21,0) ; IVMSEG ZIR record for veteran or spouse or dependent "RTN","IVMCM5",22,0) ; IVM0 408.22 0 node pieces 5-7 "RTN","IVMCM5",23,0) ; IVM01 0 node pieces 9-12 "RTN","IVMCM5",24,0) ; IVM02 0 node piece 6 "RTN","IVMCM5",25,0) ; IVM03 0 node piece 18 "RTN","IVMCM5",26,0) ; "RTN","IVMCM5",27,0) N IVM0,IVM01,IVM02,IVM03 "RTN","IVMCM5",28,0) S DGIRI=$$ADDIR^DGMTU2(DFN,DGINI) "RTN","IVMCM5",29,0) ; "RTN","IVMCM5",30,0) ; if can't create stub notify site & IVM Center "RTN","IVMCM5",31,0) I DGIRI'>0 D Q "RTN","IVMCM5",32,0) .S (IVMTEXT(6))="Can't create stub for file 408.22" "RTN","IVMCM5",33,0) .D PROB^IVMCMC(IVMTEXT(6)) "RTN","IVMCM5",34,0) .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS") "RTN","IVMCM5",35,0) .S IVMFERR="" "RTN","IVMCM5",36,0) ; "RTN","IVMCM5",37,0) ; set "mt" node to annual means test ien "RTN","IVMCM5",38,0) I "^1^2^4^"[("^"_IVMTYPE_"^") D MT^DGMTSCU3(DGIRI,DGMTI) "RTN","IVMCM5",39,0) ; "RTN","IVMCM5",40,0) Q:IVMSPCHV="S" "RTN","IVMCM5",41,0) ; "RTN","IVMCM5",42,0) ; set number of dependent children (#.13) and dependent children(#.08) "RTN","IVMCM5",43,0) ; in income relation file (#408.22) based on active child dependents "RTN","IVMCM5",44,0) ; in patient relation file (#408.12). "RTN","IVMCM5",45,0) ; make DCD means test or copay test primary income test for year "RTN","IVMCM5",46,0) I IVMSPCHV="V" D Q:$D(IVMFERR) "RTN","IVMCM5",47,0) .; "RTN","IVMCM5",48,0) .; inactivate dependents who are not dependents of the test "RTN","IVMCM5",49,0) .; being uploaded. "RTN","IVMCM5",50,0) .K DGREL("V") "RTN","IVMCM5",51,0) .I $D(DGREL) D INACTIVE Q:$D(IVMFERR) "RTN","IVMCM5",52,0) .; "RTN","IVMCM5",53,0) .D RESET^DGMTU11(DFN,DGLY,$S($G(DGMTI):DGMTI,1:0)) "RTN","IVMCM5",54,0) .I $P($G(^DGMT(408.22,DGIRI,0)),"^",8)="" D "RTN","IVMCM5",55,0) ..S DA=DGIRI,DR=".08////0;.13////@",DIE="^DGMT(408.22," D ^DIE "RTN","IVMCM5",56,0) ..K DA,DR,DIE "RTN","IVMCM5",57,0) .S IVM0=$P(IVMSEG,"^",2,4) "RTN","IVMCM5",58,0) I IVMSPCHV="C" S IVM01=$P(IVMSEG,"^",6,9),IVM02=$P(IVMSEG,"^",3),IVM03=$$CONVERT($P(IVMSEG,"^",14),"1/0") "RTN","IVMCM5",59,0) S DIK="^DGMT(408.22," "RTN","IVMCM5",60,0) L +^DGMT(408.22,DGIRI) S:IVMSPCHV="V" $P(^DGMT(408.22,DGIRI,0),"^",5,7)=IVM0 S:IVMSPCHV="C" $P(^DGMT(408.22,DGIRI,0),"^",9,12)=IVM01,$P(^(0),"^",6)=IVM02,$P(^(0),"^",18)=IVM03 S DA=DGIRI D IX1^DIK L -^DGMT(408.22,DGIRI) "RTN","IVMCM5",61,0) K DA,DIK "RTN","IVMCM5",62,0) Q "RTN","IVMCM5",63,0) ; "RTN","IVMCM5",64,0) INACTIVE ; inactivate dependents not in DCD means test or copay test and "RTN","IVMCM5",65,0) ; kill corresponding dgrel "RTN","IVMCM5",66,0) N X,Y "RTN","IVMCM5",67,0) I $D(DGREL("S")) S DA(1)=+DGREL("S") D K DGREL("S") "RTN","IVMCM5",68,0) .D CHKINACT "RTN","IVMCM5",69,0) .Q:IVMFLG6!($D(IVMFERR)) "RTN","IVMCM5",70,0) .; if spouse was active before income year, add record with date "RTN","IVMCM5",71,0) .; of 12/31 of year before income year with active code 0 "RTN","IVMCM5",72,0) .S X=$E(DGLY,1,3)-1_1231 "RTN","IVMCM5",73,0) .D INACT1 "RTN","IVMCM5",74,0) Q:'$D(DGREL)!($D(IVMFERR)) "RTN","IVMCM5",75,0) S IVMACTR=0 "RTN","IVMCM5",76,0) F S IVMACTR=$O(DGREL("C",IVMACTR)) Q:'IVMACTR S DA(1)=+DGREL("C",IVMACTR) D K DGREL("C",IVMACTR) "RTN","IVMCM5",77,0) .D CHKINACT "RTN","IVMCM5",78,0) .Q:IVMFLG6!($D(IVMFERR)) "RTN","IVMCM5",79,0) .; if child was active before income year, add record with date "RTN","IVMCM5",80,0) .; of 12/31 of year before income year with active code 0 "RTN","IVMCM5",81,0) .S X=$E(DGLY,1,3)-1_1231 "RTN","IVMCM5",82,0) .D INACT1 "RTN","IVMCM5",83,0) ; "RTN","IVMCM5",84,0) K IVMACTR,IVMDGLY,IVMFLG6,IVMYEAR "RTN","IVMCM5",85,0) Q "RTN","IVMCM5",86,0) ; "RTN","IVMCM5",87,0) CHKINACT ; if dependent was made active during income year "RTN","IVMCM5",88,0) ; add record for same date (add .08 time) with active code 0 "RTN","IVMCM5",89,0) ; "RTN","IVMCM5",90,0) S IVMFLG6=0 "RTN","IVMCM5",91,0) S IVMDGLY="" F S IVMDGLY=$O(^DGPR(408.12,DA(1),"E","B",IVMDGLY)) Q:IVMDGLY']"" D Q:IVMFLG6!($D(IVMFERR)) "RTN","IVMCM5",92,0) .Q:$E(IVMDGLY,1,3)'=$E(DGLY,1,3) "RTN","IVMCM5",93,0) .S IVMYEAR=0 F S IVMYEAR=$O(^(IVMDGLY,IVMYEAR)) Q:IVMYEAR']"" D Q:IVMFLG6!($D(IVMFERR)) "RTN","IVMCM5",94,0) ..I $P($G(^DGPR(408.12,DA(1),"E",IVMYEAR,0)),"^",2) D "RTN","IVMCM5",95,0) ...S X=IVMDGLY_.08 D INACT1 S IVMFLG6=1 "RTN","IVMCM5",96,0) ...Q "RTN","IVMCM5",97,0) Q "RTN","IVMCM5",98,0) ; "RTN","IVMCM5",99,0) INACT1 ; add inactivate entry to 408.1275 "RTN","IVMCM5",100,0) ; "RTN","IVMCM5",101,0) K DINUM "RTN","IVMCM5",102,0) S (DIK,DIC)="^DGPR(408.12,DA(1),""E"",",DIC(0)="L",DLAYGO=408.1275 K DD,DO D FILE^DICN S DA=+Y K DLAYGO "RTN","IVMCM5",103,0) ; "RTN","IVMCM5",104,0) ; if can't create stub notify site & IVM Center "RTN","IVMCM5",105,0) I DA'>0 D Q "RTN","IVMCM5",106,0) .S (IVMTEXT(6))="Can't create stub for file 408.1275" "RTN","IVMCM5",107,0) .D PROB^IVMCMC(IVMTEXT(6)) "RTN","IVMCM5",108,0) .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS") "RTN","IVMCM5",109,0) .S IVMFERR="" "RTN","IVMCM5",110,0) L +^DGPR(408.12,+DGPRI) S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=0_"^"_1_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI) "RTN","IVMCM5",111,0) K DA,DIC,DIK "RTN","IVMCM5",112,0) Q "RTN","IVMCM5",113,0) CONVERT(VAL,DATATYPE) ;Data Conversion "RTN","IVMCM5",114,0) ; Description: Converts the value found in the HL7 segment to DHCP format "RTN","IVMCM5",115,0) ;Input: "RTN","IVMCM5",116,0) ; VAL - value parsed from HL7 segment "RTN","IVMCM5",117,0) ; DATATYPE - indicates the type of conversion necessary "RTN","IVMCM5",118,0) ; "1/0" - "Y"->1,"N"->0 "RTN","IVMCM5",119,0) ;Currently only one type needs to be converted but new data types can "RTN","IVMCM5",120,0) ;be added for other conversion "RTN","IVMCM5",121,0) I VAL="" Q VAL "RTN","IVMCM5",122,0) I VAL="""""" S VAL="@" Q VAL "RTN","IVMCM5",123,0) I ($G(DATATYPE)="1/0") D "RTN","IVMCM5",124,0) .I VAL="N" S VAL=0 Q "RTN","IVMCM5",125,0) .I VAL="Y" S VAL=1 Q "RTN","IVMCM5",126,0) .S VAL="" "RTN","IVMCM5",127,0) Q VAL "RTN","IVMCM9") 0^21^B5493749 "RTN","IVMCM9",1,0) IVMCM9 ;ALB/SEK,CKN - ADD DCD DEPENDENT CHANGES TO 408.13 & 408.41 ; 10/18/05 10:02am "RTN","IVMCM9",2,0) ;;2.0;INCOME VERIFICATION MATCH;**17,105**;21-OCT-94;Build 2 "RTN","IVMCM9",3,0) ;;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","IVMCM9",4,0) ; "RTN","IVMCM9",5,0) AUDIT ; change dependent demo data in 408.13 and add changes to 408.41. "RTN","IVMCM9",6,0) ; if IVM transmitted IEN of 408.12 and IEN found at VAMC, any of the "RTN","IVMCM9",7,0) ; 4 demo fields could be different. if ien of 408.12 is not "RTN","IVMCM9",8,0) ; transmitted and dependent is found in 408.13, name & ssn could be "RTN","IVMCM9",9,0) ; different because sex, dob, & relationship (408.12) must be the same. "RTN","IVMCM9",10,0) I IVMDOB'=IVMDOB13 D "RTN","IVMCM9",11,0) .S DGMTACT="DOB",DGMTSOLD=IVMDOB13,DGMTSNEW=IVMDOB D SET^DGMTAUD "RTN","IVMCM9",12,0) .S IVMDR=".03////^S X=IVMDOB" "RTN","IVMCM9",13,0) .Q "RTN","IVMCM9",14,0) I IVMSEX'=IVMSEX13 D "RTN","IVMCM9",15,0) .S DGMTACT="SEX",DGMTSOLD=IVMSEX13,DGMTSNEW=IVMSEX D SET^DGMTAUD "RTN","IVMCM9",16,0) .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".02////^S X=IVMSEX" "RTN","IVMCM9",17,0) .Q "RTN","IVMCM9",18,0) AUDIT1 I IVMNM'=IVMNM13 D "RTN","IVMCM9",19,0) .S DGMTACT="NAM",DGMTSOLD=IVMNM13,DGMTSNEW=IVMNM D SET^DGMTAUD "RTN","IVMCM9",20,0) .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".01////^S X=IVMNM" "RTN","IVMCM9",21,0) .Q "RTN","IVMCM9",22,0) I IVMSSN'=IVMSSN13 D "RTN","IVMCM9",23,0) .S DGMTACT="SSN",DGMTSOLD=IVMSSN13,DGMTSNEW=IVMSSN D SET^DGMTAUD "RTN","IVMCM9",24,0) .S IVMSSN=$S(IVMSSN="":"@",1:IVMSSN) "RTN","IVMCM9",25,0) .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".09////^S X=IVMSSN" "RTN","IVMCM9",26,0) .Q "RTN","IVMCM9",27,0) I IVMPSSNR'=IVMPSR13 D "RTN","IVMCM9",28,0) .S IVMPSSNR=$S(IVMPSSNR="":"@",1:IVMPSSNR) "RTN","IVMCM9",29,0) .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".1////^S X=IVMPSSNR" "RTN","IVMCM9",30,0) .Q "RTN","IVMCM9",31,0) I IVMSPMNM'=IVMSMN13 D "RTN","IVMCM9",32,0) .S IVMSPMNM=$S(IVMSPMNM="":"@",1:IVMSPMNM) "RTN","IVMCM9",33,0) .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.1////^S X=IVMSPMNM" "RTN","IVMCM9",34,0) .Q "RTN","IVMCM9",35,0) ; "RTN","IVMCM9",36,0) ; change 408.13 "RTN","IVMCM9",37,0) I $D(IVMDR) S DR=IVMDR,DA=DGIPI,DIE="^DGPR(408.13," D ^DIE K DA,DIE,DR,IVMDR Q "RTN","IVMCM9",38,0) K DGDEPI,DGMTA,DGMTACT,DGMTSNEW,DGMTSOLD "RTN","IVMCM9",39,0) Q "RTN","IVMCM9",40,0) ; "RTN","IVMCM9",41,0) AUDITP ; set common variables for audit "RTN","IVMCM9",42,0) S DGMTYPT=$S(IVMTYPE=3:"",1:IVMTYPE),DGDEPI=DGIPI "RTN","IVMCM9",43,0) I IVMMTIEN S DGMTA=$G(^DGMT(408.31,IVMMTIEN,0)) "RTN","IVMCM9",44,0) S $P(DGMTA,"^",2)=DFN "RTN","IVMCM9",45,0) K IVMDR "RTN","IVMCM9",46,0) ; "RTN","IVMCM9",47,0) ; dgrel("s") contains 408.12 IEN of active spouse of VAMC test "RTN","IVMCM9",48,0) ; dgrel("c",xxx) contains 408.12 IEN of active children of VAMC test "RTN","IVMCM9",49,0) ; if VAMC dependent not a DCD dependent the dependent must be inactivated "RTN","IVMCM9",50,0) ; dependents remaining in dgrel after all DCD dependents are uploaded, will be inactivated "RTN","IVMCM9",51,0) ; if DCD & VAMC dependent, kill dgrel to prevent inactivation of dependent "RTN","IVMCM9",52,0) ; dgpri is DCD (or DCD & VAMC) dependent's 408.12 IEN "RTN","IVMCM9",53,0) I IVMSPCHV="S" D Q "RTN","IVMCM9",54,0) .I +$G(DGREL("S"))=DGPRI K DGREL("S") "RTN","IVMCM9",55,0) S IVMFLG4=1,IVMCC=0 F S IVMCC=$O(DGREL("C",IVMCC)) Q:'IVMCC D Q:'IVMFLG4 "RTN","IVMCM9",56,0) .I +$G(DGREL("C",IVMCC))=DGPRI S IVMFLG4=0 K DGREL("C",IVMCC) "RTN","IVMCM9",57,0) K IVMCC "RTN","IVMCM9",58,0) Q "RTN","IVMCMF1") 0^17^B8196181 "RTN","IVMCMF1",1,0) IVMCMF1 ;ALB/RMM,CKN - CHECK ANNUAL INCOME DATA ; 11/8/05 3:27pm "RTN","IVMCMF1",2,0) ;;2.0;INCOME VERIFICATION MATCH;**71,82,107,105**;21-OCT-94;Build 2 "RTN","IVMCMF1",3,0) ; "RTN","IVMCMF1",4,0) ; This routine is called from IVMCMF. "RTN","IVMCMF1",5,0) ; "RTN","IVMCMF1",6,0) ; "RTN","IVMCMF1",7,0) ZIC(STRING,DEPIEN) ; Check validity of ZIC segment "RTN","IVMCMF1",8,0) ; "RTN","IVMCMF1",9,0) ; Input: STRING as ZIC segment "RTN","IVMCMF1",10,0) ; DEPIEN as the IEN of the dependent in the array, if applicable "RTN","IVMCMF1",11,0) ; "RTN","IVMCMF1",12,0) N X S X=$P(STRING,HLFS,2) "RTN","IVMCMF1",13,0) I $G(DEPIEN) I DEPIEN'=SPOUSE D "RTN","IVMCMF1",14,0) .I $P(STRING,HLFS,15)>0 S X=$P(^DG(43,1,"MT",(X-17000000),0),U,17) I X'<$P(STRING,HLFS,9) S CNT=CNT+1,IVMERR(CNT)="Income does not exceed child exclusion amount-educational expense not allowed" "RTN","IVMCMF1",15,0) ZICQ Q "RTN","IVMCMF1",16,0) ; "RTN","IVMCMF1",17,0) ZIR(STRING,DEPIEN) ; Check validity of ZIR segment "RTN","IVMCMF1",18,0) ; "RTN","IVMCMF1",19,0) ; Input: STRING as ZIR segment "RTN","IVMCMF1",20,0) ; DEPIEN as the IEN of the dependent in the array, if applicable "RTN","IVMCMF1",21,0) ; "RTN","IVMCMF1",22,0) N I,FND1,X "RTN","IVMCMF1",23,0) S X=$P(STRING,HLFS,14) "RTN","IVMCMF1",24,0) I X]"",(X'="Y"),(X'="N") S CNT=CNT+1,FND1=1,IVMERR(CNT)="DEPENDENT CHILD SCHOOL INDICATOR contains unacceptable value." "RTN","IVMCMF1",25,0) I '$G(DEPIEN) D "RTN","IVMCMF1",26,0) .I X]"" S CNT=CNT+1,FND1=1,IVMERR(CNT)="DEPENDENT CHILD SCHOOL INDICATOR should not be filled in for Veteran." "RTN","IVMCMF1",27,0) .I '$P(STRING,HLFS,3),SPOUSE,($P(STRING,HLFS,4)<600) S FND1=0 F I=3:1:20 Q:FND1 I $P(ARRAY(SPOUSE,"ZIC"),HLFS,I) S FND1=1,CNT=CNT+1,IVMERR(CNT)="No income data allowed if spouse didn't live w/vet & amt contributed <$600" "RTN","IVMCMF1",28,0) I $G(DEPIEN)=SPOUSE D "RTN","IVMCMF1",29,0) . I X]"" S CNT=CNT+1,FND1=1,IVMERR(CNT)="DEPENDENT CHILD SCHOOL INDICATOR should not be filled in for spouse ZIR." "RTN","IVMCMF1",30,0) I $G(DEPIEN),(DEPIEN'=SPOUSE) D "RTN","IVMCMF1",31,0) .I '$P(STRING,HLFS,8) S FND1=0 F I=3:1:20 Q:FND1 I $P(ARRAY(DEPIEN,"ZIC"),HLFS,I) S CNT=CNT+1,IVMERR(CNT)="Shouldn't have income data if Child Had Income is NO",FND1=1 "RTN","IVMCMF1",32,0) ZIRQ Q "RTN","IVMCMF2") 0^18^B10358684 "RTN","IVMCMF2",1,0) IVMCMF2 ;ALB/SEK,CKN - CHECK INCOME DEPENDENT DATA ; 11/8/05 3:27pm "RTN","IVMCMF2",2,0) ;;2.0;INCOME VERIFICATION MATCH;**71,107,105**;21-OCT-94;Build 2 "RTN","IVMCMF2",3,0) ; "RTN","IVMCMF2",4,0) ; This routine is a called from IVMCMF. "RTN","IVMCMF2",5,0) ; "RTN","IVMCMF2",6,0) ZMT(STRING) ; check ZMT segment "RTN","IVMCMF2",7,0) ; "RTN","IVMCMF2",8,0) ; Input: STRING as ZMT segment "RTN","IVMCMF2",9,0) ; "RTN","IVMCMF2",10,0) N X,Y "RTN","IVMCMF2",11,0) ; "RTN","IVMCMF2",12,0) ; Means Test Status Checks "RTN","IVMCMF2",13,0) I IVMTYPE=1,$P(STRING,HLFS,3)'="G" D MT^IVMCMF3(STRING,ARRAY("ZIC")) "RTN","IVMCMF2",14,0) ; "RTN","IVMCMF2",15,0) ; Copay Test Status Checks "RTN","IVMCMF2",16,0) I IVMTYPE=2 D CO^IVMCMF3(STRING) "RTN","IVMCMF2",17,0) ; "RTN","IVMCMF2",18,0) ; Hardship consistency checks "RTN","IVMCMF2",19,0) N HARDSHIP K HARDSHIP "RTN","IVMCMF2",20,0) S HARDSHIP("Y/N")=$P(STRING,HLFS,13) "RTN","IVMCMF2",21,0) S HARDSHIP("SITE")=$P(STRING,HLFS,23) "RTN","IVMCMF2",22,0) S HARDSHIP("EFFDATE")=$P(STRING,HLFS,24) "RTN","IVMCMF2",23,0) ; "RTN","IVMCMF2",24,0) I (IVMTYPE'=4),(HARDSHIP("Y/N"))!(+HARDSHIP("SITE"))!(HARDSHIP("EFFDATE")) D "RTN","IVMCMF2",25,0) .I HARDSHIP("Y/N")="" S CNT=CNT+1,IVMERR(CNT)="Missing Hardship Indicator" "RTN","IVMCMF2",26,0) .I HARDSHIP("SITE")="" S CNT=CNT+1,IVMERR(CNT)="Missing Site Granting Hardship" "RTN","IVMCMF2",27,0) .;starting in year 2000, all hardships should have an effective date "RTN","IVMCMF2",28,0) .I $E($P(STRING,HLFS,2),1,4)'<2000,(HARDSHIP("EFFDATE")="") S CNT=CNT+1,IVMERR(CNT)="Missing Hardship Effective Date" "RTN","IVMCMF2",29,0) .I $L(HARDSHIP("EFFDATE")) S X=$$FMDATE^HLFNC(HARDSHIP("EFFDATE")),%DT=X D ^%DT I Y<0 S CNT=CNT+1,IVMERR(CNT)="Invalid Hardship Effective Date" "RTN","IVMCMF2",30,0) .I HARDSHIP("EFFDATE"),(HARDSHIP("EFFDATE")<($P(STRING,HLFS,2))-1) S CNT=CNT+1,IVMERR(CNT)="Hardship Effective Date earlier than Means Test Date" "RTN","IVMCMF2",31,0) ; "RTN","IVMCMF2",32,0) ; Source of Test "RTN","IVMCMF2",33,0) S X=$P(STRING,HLFS,18) "RTN","IVMCMF2",34,0) I "^1^2^3^4^"'[(U_X_U) S CNT=CNT+1,IVMERR(CNT)="Source of Test must be identified" "RTN","IVMCMF2",35,0) I X=4,$P(STRING,HLFS,22)="" S CNT=CNT+1,IVMERR(CNT)="Site Conducting Test must be identified" "RTN","IVMCMF2",36,0) ; "RTN","IVMCMF2",37,0) ZMTQ Q "RTN","IVMCMF2",38,0) ; "RTN","IVMCMF2",39,0) ZDP(STRING) ; Check validity of ZDP segment "RTN","IVMCMF2",40,0) ; "RTN","IVMCMF2",41,0) ; Input: STRING as ZDP segment "RTN","IVMCMF2",42,0) ; "RTN","IVMCMF2",43,0) N RELAT,IVMZDP5,PSSNRSN "RTN","IVMCMF2",44,0) S IVMZDP5=$P(STRING,HLFS,5) "RTN","IVMCMF2",45,0) I +IVMZDP5'>0 D G ZDPQ "RTN","IVMCMF2",46,0) .S RELAT=$P(STRING,HLFS,6),RELAT=$S($D(^DG(408.11,RELAT,0)):$P(^DG(408.11,RELAT,0),HLFS),1:"OTHER") "RTN","IVMCMF2",47,0) .S CNT=CNT+1,IVMERR(CNT)="Dependent ("_RELAT_") transmitted without SSN" "RTN","IVMCMF2",48,0) I $D(IVMAR2(IVMZDP5)) S CNT=CNT+1,IVMERR(CNT)="Two dependents transmitted with same SSN" "RTN","IVMCMF2",49,0) S IVMAR2(IVMZDP5)="" "RTN","IVMCMF2",50,0) S PSSNRSN=$P(STRING,HLFS,10) I PSSNRSN]"",(PSSNRSN'="R"),(PSSNRSN'="S"),(PSSNRSN'="N") S CNT=CNT+1,IVMERR(CNT)="Invalid Pseudo SSN Reason transmitted for Spouse/Dependent." "RTN","IVMCMF2",51,0) ZDPQ Q "RTN","IVMCZMT") 0^3^B58915874 "RTN","IVMCZMT",1,0) IVMCZMT ;ALB/MLI/LD/CKN,TDM,EG,TDM - Creation of HL7 ZMT (means test) segment ; 7/19/06 4:41pm "RTN","IVMCZMT",2,0) ;;2.0;INCOME VERIFICATION MATCH;**17,53,49,58,81,89,104,105**;21-OCT-94;Build 2 "RTN","IVMCZMT",3,0) ; "RTN","IVMCZMT",4,0) ; This routine returns the ZMT segment which contains means test "RTN","IVMCZMT",5,0) ; data for a selected patient. It differs from the standard segment "RTN","IVMCZMT",6,0) ; builder in that it will add default values where needed for "RTN","IVMCZMT",7,0) ; fields added by means test sharing - these fields may not have "RTN","IVMCZMT",8,0) ; values for old tests, though for new tests the values should be there. "RTN","IVMCZMT",9,0) ; "RTN","IVMCZMT",10,0) ; "RTN","IVMCZMT",11,0) ; "RTN","IVMCZMT",12,0) EN(DFN,VAFSTR,VAFMTDT,VAFTYPE,SETID,DELETE,LIMIT) ; Entry point to get ZMT segment "RTN","IVMCZMT",13,0) ; "RTN","IVMCZMT",14,0) ; Input: "RTN","IVMCZMT",15,0) ; DFN - as the IEN or corresponding patient in the PATIENT file "RTN","IVMCZMT",16,0) ; VAFSTR - as string of segment fields needed separated by commas "RTN","IVMCZMT",17,0) ; VAFMTDT - (optional) as date of desired means test (defaults to latest MT) "RTN","IVMCZMT",18,0) ; VAFTYPE - (optional) as type of test: 1 - Means Test (default=1) "RTN","IVMCZMT",19,0) ; 2 - Copay Test "RTN","IVMCZMT",20,0) ; 4 - LTC Copay Exemption Test "RTN","IVMCZMT",21,0) ; SETID - (optional) value to use for SEQ 1, the set id field (1 used "RTN","IVMCZMT",22,0) ; as default if not passed.) "RTN","IVMCZMT",23,0) ; DELETE - (optional, pass by reference) This array is used to "RTN","IVMCZMT",24,0) ; indicate whether the segment is being used to notify of the "RTN","IVMCZMT",25,0) ; the deletion of a means test, pharmacy copay test, or a "RTN","IVMCZMT",26,0) ; hardship determinatin. If a means test or hardship is being "RTN","IVMCZMT",27,0) ; deleted, then VAFTYPE must equal 1. If an Rx copay test is "RTN","IVMCZMT",28,0) ; being deleted, then VAFTYPE must equal 2. The subscripts "RTN","IVMCZMT",29,0) ; are as follows: "RTN","IVMCZMT",30,0) ; DELETE("DATE OF TEST")= - indicates "RTN","IVMCZMT",31,0) ; the income year of the test that the deletion flags "RTN","IVMCZMT",32,0) ; refer to "RTN","IVMCZMT",33,0) ; DELETE("HARDSHIP") - if $G(DELETE("HARDSHIP"))=1 then the "RTN","IVMCZMT",34,0) ; segment will be created to delete the hardship. "RTN","IVMCZMT",35,0) ; DELETE("MT") - if $G(DELETE("MT"))=1 then "RTN","IVMCZMT",36,0) ; the segment will be created to delete a means test. "RTN","IVMCZMT",37,0) ; DELETE("RX")= if $G(DELETE("RX"))=1 then "RTN","IVMCZMT",38,0) ; the segment will be created to delete a pharmacy "RTN","IVMCZMT",39,0) ; copay test. "RTN","IVMCZMT",40,0) ; DELETE("LTC")= if $G(DELETE("LTC"))=1 then "RTN","IVMCZMT",41,0) ; the segment will be created to delete a Long term "RTN","IVMCZMT",42,0) ; care copay exemption test. "RTN","IVMCZMT",43,0) ; LIMIT - (optional) if $G(LIMIT)=1 then this indicates that a test in "RTN","IVMCZMT",44,0) ; an income year other than indicated in the IVM Patient File "RTN","IVMCZMT",45,0) ; should NOT be returned in the ZMT segment "RTN","IVMCZMT",46,0) ; "RTN","IVMCZMT",47,0) ; ****Also assumes all HL7 variables are defined as returned **** "RTN","IVMCZMT",48,0) ; by the INIT^HLTRANS call "RTN","IVMCZMT",49,0) ; "RTN","IVMCZMT",50,0) ; Output - string in the form of the DHCP HL7 ZMT segment "RTN","IVMCZMT",51,0) ; "RTN","IVMCZMT",52,0) ; "RTN","IVMCZMT",53,0) N NODE,PRIM,X,Y,VAFY,NODE2,MTIEN "RTN","IVMCZMT",54,0) ; "RTN","IVMCZMT",55,0) I '$G(DFN)!($G(VAFSTR)']"") G QUIT "RTN","IVMCZMT",56,0) S $P(VAFY,HLFS,22)="",VAFSTR=","_VAFSTR_"," "RTN","IVMCZMT",57,0) S VAFTYPE=$S($G(VAFTYPE):VAFTYPE,1:1) "RTN","IVMCZMT",58,0) S VAFMTDT=$S($G(VAFMTDT):VAFMTDT,1:DT) "RTN","IVMCZMT",59,0) S $P(VAFY,HLFS,1)=$S($G(SETID):SETID,1:1) "RTN","IVMCZMT",60,0) S (NODE,NODE2,PRIM)="" "RTN","IVMCZMT",61,0) ; "RTN","IVMCZMT",62,0) ;handle deletions of a test "RTN","IVMCZMT",63,0) I ($G(DELETE("MT"))=1),VAFTYPE=1 D G QUIT "RTN","IVMCZMT",64,0) .S $P(VAFY,HLFS,2)=$$HLDATE^HLFNC(DELETE("DATE OF TEST")) ; MT Date "RTN","IVMCZMT",65,0) .S $P(VAFY,HLFS,3)=HLQ "RTN","IVMCZMT",66,0) .I ($G(DELETE("HARDSHIP"))=1) S $P(VAFY,HLFS,24)=HLQ "RTN","IVMCZMT",67,0) .S $P(VAFY,HLFS,17)=VAFTYPE ; Type Of Test "RTN","IVMCZMT",68,0) ; "RTN","IVMCZMT",69,0) I ($G(DELETE("RX"))=1),VAFTYPE=2 D G QUIT "RTN","IVMCZMT",70,0) .S $P(VAFY,HLFS,2)=$$HLDATE^HLFNC(DELETE("DATE OF TEST")) ; MT Date "RTN","IVMCZMT",71,0) .S $P(VAFY,HLFS,3)=HLQ "RTN","IVMCZMT",72,0) .S $P(VAFY,HLFS,17)=VAFTYPE ; Type Of Test "RTN","IVMCZMT",73,0) ; "RTN","IVMCZMT",74,0) I ($G(DELETE("LTC"))=1),VAFTYPE=4 D G QUIT "RTN","IVMCZMT",75,0) .S $P(VAFY,HLFS,2)=$$HLDATE^HLFNC(DELETE("DATE OF TEST")) ; MT Date "RTN","IVMCZMT",76,0) .S $P(VAFY,HLFS,3)=HLQ "RTN","IVMCZMT",77,0) .S $P(VAFY,HLFS,17)=VAFTYPE ; Type Of Test "RTN","IVMCZMT",78,0) ; "RTN","IVMCZMT",79,0) ; Income Year requiring transmission from IVM Patient File (301.5) "RTN","IVMCZMT",80,0) S IVMIY=$S($D(IVMIY):IVMIY,1:(VAFMTDT-10000)) "RTN","IVMCZMT",81,0) ; "RTN","IVMCZMT",82,0) ; Check for a future dated Income Test "RTN","IVMCZMT",83,0) S MTIEN="" "RTN","IVMCZMT",84,0) N EC S EC=0 "RTN","IVMCZMT",85,0) I VAFTYPE'=4 D "RTN","IVMCZMT",86,0) . S MTIEN=+$$FUT^DGMTU(DFN,"",$S($G(VAFTYPE):VAFTYPE,1:1)) "RTN","IVMCZMT",87,0) . I MTIEN D "RTN","IVMCZMT",88,0) . . S NODE=$G(^DGMT(408.31,MTIEN,0)),PRIM=$G(^("PRIM")),NODE2=$G(^DGMT(408.31,MTIEN,2)) "RTN","IVMCZMT",89,0) . . ;the FUT API works off the a XREF that is not deleted if the test "RTN","IVMCZMT",90,0) . . ;is no longer future. As a result, you may pick up the wrong income "RTN","IVMCZMT",91,0) . . ;year as a return. The check $E(IVMIY,1,3)+1'=$E(+NODE,1,3) must be "RTN","IVMCZMT",92,0) . . ;performed here and after the current Primary icnome test section below "RTN","IVMCZMT",93,0) . . I ($G(LIMIT)=1),($E(IVMIY,1,3)+1)'=$E(+NODE,1,3) S EC=1 "RTN","IVMCZMT",94,0) . . Q "RTN","IVMCZMT",95,0) . Q "RTN","IVMCZMT",96,0) I VAFTYPE'=4,EC S (NODE,NODE2,MTIEN,PRIM)="" ;Q "ZMT"_HLFS_$G(VAFY) "RTN","IVMCZMT",97,0) ; "RTN","IVMCZMT",98,0) ; Check for a current Primary Income Test "RTN","IVMCZMT",99,0) I 'MTIEN S MTIEN=+$$LST^DGMTU(DFN,VAFMTDT,$S($G(VAFTYPE):VAFTYPE,1:1)) "RTN","IVMCZMT",100,0) S:(NODE="") NODE=$G(^DGMT(408.31,MTIEN,0)),PRIM=$G(^("PRIM")),NODE2=$G(^DGMT(408.31,MTIEN,2)) "RTN","IVMCZMT",101,0) ; "RTN","IVMCZMT",102,0) ;if the wrong income yr, and told to ignore it ($G(LIMIT)=1, "RTN","IVMCZMT",103,0) ;send blank means test "RTN","IVMCZMT",104,0) I ($G(LIMIT)=1),($E(IVMIY,1,3)+1)'=$E(+NODE,1,3) S (NODE,NODE2,MTIEN,PRIM)="" Q "ZMT"_HLFS_$G(VAFY) "RTN","IVMCZMT",105,0) ; "RTN","IVMCZMT",106,0) ; "RTN","IVMCZMT",107,0) I NODE'="" D "RTN","IVMCZMT",108,0) .;add default values to new means test sharing fields "RTN","IVMCZMT",109,0) .N STATUS,CODE,TDSTATUS,TDCODE,HARDSHIP,DATA,SOURCE,TIME "RTN","IVMCZMT",110,0) .S TDSTATUS=$P(NODE2,"^",3) "RTN","IVMCZMT",111,0) .S HARDSHIP=$P(NODE,"^",20) "RTN","IVMCZMT",112,0) .I TDSTATUS="" D "RTN","IVMCZMT",113,0) ..S STATUS=$P(NODE,"^",3) "RTN","IVMCZMT",114,0) ..Q:'STATUS "RTN","IVMCZMT",115,0) ..S CODE=$$GETCODE^DGMTH(STATUS) "RTN","IVMCZMT",116,0) ..I CODE'="","ABCEGMP"[CODE D "RTN","IVMCZMT",117,0) ...I VAFTYPE=1,HARDSHIP D "RTN","IVMCZMT",118,0) ....I "AG"[CODE D Q "RTN","IVMCZMT",119,0) .....I CODE="A",($P(NODE,"^",4)'>$P(NODE,"^",27)) S TDSTATUS=$$GETSTAT^DGMTH("G",1) Q ;Income <= GMT Threshold "RTN","IVMCZMT",120,0) .....S TDSTATUS=$$GETSTAT^DGMTH("C",1) "RTN","IVMCZMT",121,0) ....S TDSTATUS=STATUS "RTN","IVMCZMT",122,0) ...S DATA(2.03)=TDSTATUS,$P(NODE2,"^",3)=TDSTATUS "RTN","IVMCZMT",123,0) .S SOURCE=$P(NODE,"^",23) "RTN","IVMCZMT",124,0) .I SOURCE=1 D "RTN","IVMCZMT",125,0) ..S TIME=$P(NODE2,"^",2) "RTN","IVMCZMT",126,0) ..I TIME="" S TIME=$$NOW^XLFDT,$P(NODE2,"^",2)=TIME,DATA(2.02)=TIME "RTN","IVMCZMT",127,0) ..I $P(NODE2,"^",5)="",$P(NODE,"^",6) S $P(NODE2,"^",5)=$$GETSITE^DGMTU4($P(NODE,"^",6)),DATA(2.05)=$P(NODE2,"^",5) "RTN","IVMCZMT",128,0) .I HARDSHIP,$P(NODE2,"^",4)="",$P(NODE,"^",22) S $P(NODE2,"^",4)=$$GETSITE^DGMTU4($P(NODE,"^",22)),DATA(2.04)=$P(NODE2,"^",4) "RTN","IVMCZMT",129,0) .I $D(DATA),$$UPD^DGENDBS(408.31,MTIEN,.DATA) "RTN","IVMCZMT",130,0) .; "RTN","IVMCZMT",131,0) I VAFSTR[",2," S $P(VAFY,HLFS,2)=$S(+NODE:$$HLDATE^HLFNC(+NODE),1:HLQ) ; MT Date "RTN","IVMCZMT",132,0) I VAFSTR[",3," S X=$P($G(^DG(408.32,+$P(NODE,"^",3),0)),"^",2),$P(VAFY,HLFS,3)=$S(X]"":X,1:"") ; MT Status "RTN","IVMCZMT",133,0) I VAFSTR[",4," S $P(VAFY,HLFS,4)=$S($P(NODE,"^",4)]"":$P(NODE,"^",4),1:HLQ) ; Income "RTN","IVMCZMT",134,0) I VAFSTR[",5," S $P(VAFY,HLFS,5)=$S($P(NODE,"^",5)]"":$P(NODE,"^",5),1:HLQ) ; Net Worth "RTN","IVMCZMT",135,0) I VAFSTR[",6," S $P(VAFY,HLFS,6)=$S($P(NODE,"^",10):$$HLDATE^HLFNC($P(NODE,"^",10)),1:HLQ) ; Adjudication Date/Time "RTN","IVMCZMT",136,0) I VAFSTR[",7," S $P(VAFY,HLFS,7)=$$YN^VAFHLFNC($P(NODE,"^",11)) ;Agreed To Pay "RTN","IVMCZMT",137,0) I VAFSTR[",8," S $P(VAFY,HLFS,8)=$S($P(NODE,"^",12):$P(NODE,"^",12),1:HLQ) ; Threshold A "RTN","IVMCZMT",138,0) I VAFSTR[",9," S $P(VAFY,HLFS,9)=$S($P(NODE,"^",15)]"":$P(NODE,"^",15),1:HLQ) ; Deductible Expenses "RTN","IVMCZMT",139,0) I VAFSTR[",10," S $P(VAFY,HLFS,10)=$S($P(NODE,"^",7):$$HLDATE^HLFNC($P(NODE,"^",7)),1:HLQ) ; Date/Time Completed "RTN","IVMCZMT",140,0) I VAFSTR[",11," S $P(VAFY,HLFS,11)=$$YN^VAFHLFNC($P(NODE,"^",16)) ;Previous Year Means Test Threshold Flag "RTN","IVMCZMT",141,0) I VAFSTR[",12," S $P(VAFY,HLFS,12)=$S($P(NODE,"^",18)]"":$P(NODE,"^",18),1:HLQ) ; Total Dependents "RTN","IVMCZMT",142,0) I VAFSTR[",13," S $P(VAFY,HLFS,13)=$$YN^VAFHLFNC($P(NODE,"^",20)) ;Hardship "RTN","IVMCZMT",143,0) I VAFSTR[",14," S $P(VAFY,HLFS,14)=$S($P(NODE,"^",21):$$HLDATE^HLFNC($P(NODE,"^",21)),1:HLQ) ; Hardship Review Date "RTN","IVMCZMT",144,0) I VAFSTR[",15," S $P(VAFY,HLFS,15)=$S($P(NODE,"^",24):$$HLDATE^HLFNC($P(NODE,"^",24)),1:HLQ) ; Date Vet Signed Test "RTN","IVMCZMT",145,0) I VAFSTR[",16," S $P(VAFY,HLFS,16)=$$YN^VAFHLFNC($P(NODE,"^",14)) ;Declines To Give Income Info "RTN","IVMCZMT",146,0) I VAFSTR[",17," S $P(VAFY,HLFS,17)=$S($P(NODE,"^",19):$P(NODE,"^",19),1:VAFTYPE) ; Type Of Test "RTN","IVMCZMT",147,0) I VAFSTR[",18," S $P(VAFY,HLFS,18)=$S($P(NODE,"^",23)]"":$P(NODE,"^",23),1:HLQ) ; Source Of Test "RTN","IVMCZMT",148,0) I VAFSTR[",19," S $P(VAFY,HLFS,19)=$$YN^VAFHLFNC(PRIM) ; Primary Test? "RTN","IVMCZMT",149,0) I VAFSTR[",20," S $P(VAFY,HLFS,20)=$S($P(NODE,"^",25):$$HLDATE^HLFNC($P(NODE,"^",25)),1:HLQ) ; Date IVM Verified MT Completed "RTN","IVMCZMT",150,0) I VAFSTR[",21," S $P(VAFY,HLFS,21)=$$YN^VAFHLFNC($P(NODE,"^",26)) ;Refused To Sign "RTN","IVMCZMT",151,0) ; "RTN","IVMCZMT",152,0) ; "RTN","IVMCZMT",153,0) I VAFSTR[",22," S $P(VAFY,HLFS,22)=$P(NODE2,"^",5) ;Site Conducting Test "RTN","IVMCZMT",154,0) I VAFSTR[",23," S $P(VAFY,HLFS,23)=$P(NODE2,"^",4) ;Site Granting Hardship "RTN","IVMCZMT",155,0) I VAFSTR[",24," S $P(VAFY,HLFS,24)=$S($P(NODE2,"^"):$$HLDATE^HLFNC($P(NODE2,"^")),1:"") ;Hardship Effective Date "RTN","IVMCZMT",156,0) I VAFSTR[",25," S $P(VAFY,HLFS,25)=$S($P(NODE2,"^",2):$$HLDATE^HLFNC($P(NODE2,"^",2)),1:"") ;Dt/Tm Test Last Edited "RTN","IVMCZMT",157,0) I VAFSTR[",26," S $P(VAFY,HLFS,26)=$S($P(NODE2,"^",3):$$GETCODE^DGMTH($P(NODE2,"^",3)),1:"") ; Test Determined Status "RTN","IVMCZMT",158,0) I VAFSTR[",28," S $P(VAFY,HLFS,28)=$P(NODE,"^",27) ;GMT Threshold "RTN","IVMCZMT",159,0) I VAFSTR[",29," S $P(VAFY,HLFS,29)=$P(NODE2,"^",9) ;Hardship Reason "RTN","IVMCZMT",160,0) I VAFSTR[",30," S $P(VAFY,HLFS,30)=+$P(NODE2,"^",11) ; Test Version "RTN","IVMCZMT",161,0) ; "RTN","IVMCZMT",162,0) ;can only transmit the deletion of a hardship if the segment is for a means test - and the income years must match if there is a means test "RTN","IVMCZMT",163,0) ; "RTN","IVMCZMT",164,0) I VAFTYPE=1,($G(DELETE("HARDSHIP"))=1),('(+NODE)!($E(DELETE("DATE OF TEST"),1,3)=$E((+NODE),1,3))) S $P(VAFY,HLFS,24)=HLQ "RTN","IVMCZMT",165,0) ; "RTN","IVMCZMT",166,0) QUIT Q "ZMT"_HLFS_$G(VAFY) "RTN","IVMLDEM6") 0^24^B61965432 "RTN","IVMLDEM6",1,0) IVMLDEM6 ;ALB/KCL/BRM/PHH/CKN - IVM DEMOGRAPHIC UPLOAD FILE ADDRESS ; 10/10/06 4:06pm "RTN","IVMLDEM6",2,0) ;;2.0;INCOME VERIFICATION MATCH;**10,58,73,79,108,106,105**; 21-OCT-94;Build 2 "RTN","IVMLDEM6",3,0) ;;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","IVMLDEM6",4,0) ; "RTN","IVMLDEM6",5,0) ; "RTN","IVMLDEM6",6,0) ADDR(DFN,IVMDA2,IVMDA1,IVMDA,IVMPPICK) ; - function to check if uploadable field "RTN","IVMLDEM6",7,0) ; is an address field and return a flag "RTN","IVMLDEM6",8,0) ; "RTN","IVMLDEM6",9,0) ; Input: DFN - as patient IEN "RTN","IVMLDEM6",10,0) ; IVMDA2 - pointer to case record in (#301.5) file "RTN","IVMLDEM6",11,0) ; IVMDA1 - pointer to PID msg in (#301.501) sub-file "RTN","IVMLDEM6",12,0) ; IVMDA - pointer to record in (#301.511) sub-file "RTN","IVMLDEM6",13,0) ; IVMPPICK - residence phone number and/or another address "RTN","IVMLDEM6",14,0) ; field selected "RTN","IVMLDEM6",15,0) ; 0 - phone or an address field not selected "RTN","IVMLDEM6",16,0) ; 1 - address field(s) selected "RTN","IVMLDEM6",17,0) ; 2 - phone selected "RTN","IVMLDEM6",18,0) ; 3 - both address field(s) and phone selected "RTN","IVMLDEM6",19,0) ; "RTN","IVMLDEM6",20,0) ; Output: IVMFLAG - 1 if address field "RTN","IVMLDEM6",21,0) ; 0 if not an address field "RTN","IVMLDEM6",22,0) ; "RTN","IVMLDEM6",23,0) ; "RTN","IVMLDEM6",24,0) N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y "RTN","IVMLDEM6",25,0) ; "RTN","IVMLDEM6",26,0) ; - initialize flags "RTN","IVMLDEM6",27,0) S IVMFLAG=0 "RTN","IVMLDEM6",28,0) ; "RTN","IVMLDEM6",29,0) ; - check for required parameters "RTN","IVMLDEM6",30,0) I '$G(DFN)!('$G(IVMDA))!('$G(IVMDA1))!'($G(IVMDA2)) G ADDRQ "RTN","IVMLDEM6",31,0) ; "RTN","IVMLDEM6",32,0) ; - get pointer to (#301.92) file from (#301.511) sub-file "RTN","IVMLDEM6",33,0) S IVMPTR=+$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) G ADDRQ:'IVMPTR "RTN","IVMLDEM6",34,0) ; "RTN","IVMLDEM6",35,0) ASK I '$D(^IVM(301.92,"AD",+IVMPTR)) G ADDRQ "RTN","IVMLDEM6",36,0) I IVMPPICK=2 G ASK1 "RTN","IVMLDEM6",37,0) W ! S DIR("A")="Do you wish to proceed with this action" "RTN","IVMLDEM6",38,0) S DIR("A",1)="You have selected to update an address field." "RTN","IVMLDEM6",39,0) S DIR("A",2)="You will be required to upload the entire address." "RTN","IVMLDEM6",40,0) S DIR("?")="Enter 'YES' to continue or 'NO' to abort." "RTN","IVMLDEM6",41,0) S DIR(0)="Y",DIR("B")="NO" "RTN","IVMLDEM6",42,0) D ^DIR K DIR "RTN","IVMLDEM6",43,0) S IVMFLAG=1 G ADDRQ:'Y "RTN","IVMLDEM6",44,0) W ! S DIR("A")="Are you sure that you want to update the complete address" "RTN","IVMLDEM6",45,0) S:$$PHARM(+$G(DFN)) DIR("A",1)="*** WARNING: This patient has ACTIVE PRESCRIPTIONS on file." "RTN","IVMLDEM6",46,0) S DIR("A",2)="" "RTN","IVMLDEM6",47,0) I $$ADRDTCK^IVMLDEM9(+$G(DFN),IVMDA2,IVMDA1) S DIR("A",2)="*** WARNING: The address that you are attempting to file is OLDER than",DIR("A",3)=" the address on file.",DIR("A",4)="" "RTN","IVMLDEM6",48,0) S DIR("?",1)="Enter 'YES' to update the complete address that was received from" "RTN","IVMLDEM6",49,0) S DIR("?")="HEC. Enter 'NO' to quit." "RTN","IVMLDEM6",50,0) S DIR(0)="Y",DIR("B")="NO" "RTN","IVMLDEM6",51,0) D ^DIR K DIR "RTN","IVMLDEM6",52,0) S IVMFLAG=1 G ADDRQ:'Y "RTN","IVMLDEM6",53,0) W !,"Filing address fields... " "RTN","IVMLDEM6",54,0) ; "RTN","IVMLDEM6",55,0) ; determine correct address change date/time to use "RTN","IVMLDEM6",56,0) D ADDRDT(DFN,IVMDA2,IVMDA1) "RTN","IVMLDEM6",57,0) ; "RTN","IVMLDEM6",58,0) LOOP ; "RTN","IVMLDEM6",59,0) N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) "RTN","IVMLDEM6",60,0) ; "RTN","IVMLDEM6",61,0) ; - loop thru fields in ^IVM(301.92,"AD" x-ref "RTN","IVMLDEM6",62,0) S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D "RTN","IVMLDEM6",63,0) .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D "RTN","IVMLDEM6",64,0) ..; "RTN","IVMLDEM6",65,0) ..; - check for data node in (#301.511) sub-file "RTN","IVMLDEM6",66,0) ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:IVMNODE']"" "RTN","IVMLDEM6",67,0) ..Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"") "RTN","IVMLDEM6",68,0) ..; "RTN","IVMLDEM6",69,0) ..; - check if residence phone number and not selected to upload "RTN","IVMLDEM6",70,0) ..Q:(IVMPPICK=1&(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0)))) "RTN","IVMLDEM6",71,0) ..; - check if not residence phone number and only phone selected to upload "RTN","IVMLDEM6",72,0) ..Q:(IVMPPICK=2&(+IVMNODE'=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0)))) "RTN","IVMLDEM6",73,0) ..; "RTN","IVMLDEM6",74,0) ..; - perform any necessary address field manipulation and "RTN","IVMLDEM6",75,0) ..; load addr field rec'd from IVM into DHCP (#2) file "RTN","IVMLDEM6",76,0) ..D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1 "RTN","IVMLDEM6",77,0) ..; "RTN","IVMLDEM6",78,0) ..; - remove entry from (#301.511) sub-file "RTN","IVMLDEM6",79,0) ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) "RTN","IVMLDEM6",80,0) ; "RTN","IVMLDEM6",81,0) I IVMFLAG W "completed.",! D "RTN","IVMLDEM6",82,0) .N DGCURR "RTN","IVMLDEM6",83,0) .D GETUPDTS^DGADDUTL(DFN,.DGCURR) "RTN","IVMLDEM6",84,0) .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR) "RTN","IVMLDEM6",85,0) ; "RTN","IVMLDEM6",86,0) ; - if addr is uploaded and phone # is not - ask user delete phone "RTN","IVMLDEM6",87,0) I IVMFLAG,$P($G(^DPT(+DFN,.13)),"^")]"",(2>IVMPPICK) D PHONE "RTN","IVMLDEM6",88,0) S VALMBCK="R" "RTN","IVMLDEM6",89,0) ; "RTN","IVMLDEM6",90,0) ; "RTN","IVMLDEM6",91,0) ADDRQ ; - return --> 1 if uploadable field is an address field "RTN","IVMLDEM6",92,0) ; --> 0 if uploadable field is not an address field "RTN","IVMLDEM6",93,0) ; "RTN","IVMLDEM6",94,0) I IVMFLAG D RESET^IVMLDEMU "RTN","IVMLDEM6",95,0) Q IVMFLAG "RTN","IVMLDEM6",96,0) ; "RTN","IVMLDEM6",97,0) ; "RTN","IVMLDEM6",98,0) UPLOAD(DFN,IVMFIELD,IVMVALUE) ; - file address fields received from IVM "RTN","IVMLDEM6",99,0) ; "RTN","IVMLDEM6",100,0) ; Input: DFN - as patient IEN "RTN","IVMLDEM6",101,0) ; IVMFIELD - as the field number to be updated "RTN","IVMLDEM6",102,0) ; IVMVALUE - as the value of the field "RTN","IVMLDEM6",103,0) ; "RTN","IVMLDEM6",104,0) ; Output: None "RTN","IVMLDEM6",105,0) ; "RTN","IVMLDEM6",106,0) ; "RTN","IVMLDEM6",107,0) ; - update specified address field in the Patient (#2) file "RTN","IVMLDEM6",108,0) S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE" "RTN","IVMLDEM6",109,0) D ^DIE K DA,DIE,DR "RTN","IVMLDEM6",110,0) ; "RTN","IVMLDEM6",111,0) ; - delete inaccurate Addr Change Site data if Source is not VAMC "RTN","IVMLDEM6",112,0) ; (trigger x-ref does not fire with 4 slash stuff) "RTN","IVMLDEM6",113,0) I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA") "RTN","IVMLDEM6",114,0) ; "RTN","IVMLDEM6",115,0) ; - delete the Bad Address Indicator field "RTN","IVMLDEM6",116,0) I $$BADADR^DGUTL3(DFN) D DELBAI^DGUTL3(DFN) "RTN","IVMLDEM6",117,0) Q "RTN","IVMLDEM6",118,0) ; "RTN","IVMLDEM6",119,0) ; "RTN","IVMLDEM6",120,0) PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file "RTN","IVMLDEM6",121,0) D FULL^VALM1 "RTN","IVMLDEM6",122,0) W ! S DIR("A")="Is it okay to delete the patient's Phone Number [Residence]" "RTN","IVMLDEM6",123,0) W ! S DIR("A",1)="The patient's address has been updated and the phone number" "RTN","IVMLDEM6",124,0) S DIR("A",2)="remains on file." "RTN","IVMLDEM6",125,0) S DIR("A",3)=" " "RTN","IVMLDEM6",126,0) S DIR("A",4)="Patient Name: "_$P($$PT^IVMUFNC4(+DFN),"^")_" ("_$P($$PT^IVMUFNC4(+DFN),"^",3)_")" "RTN","IVMLDEM6",127,0) S DIR("A",5)="Phone Number [Residence]: "_$P($G(^DPT(+DFN,.13)),"^") "RTN","IVMLDEM6",128,0) S DIR("A",6)=" " "RTN","IVMLDEM6",129,0) S DIR("?",1)="Enter 'YES' to delete the patient's Phone Number [Residence] that is" "RTN","IVMLDEM6",130,0) S DIR("?",2)="currently on file. Enter 'NO' to quit without deleting the patient's" "RTN","IVMLDEM6",131,0) S DIR("?")="Phone Number [Residence]." "RTN","IVMLDEM6",132,0) S DIR(0)="Y",DIR("B")="NO" "RTN","IVMLDEM6",133,0) D ^DIR K DIR "RTN","IVMLDEM6",134,0) S:Y $P(^DPT(DFN,.13),"^")="" W !!,"Patient's Phone Number [Residence] has ",$S(Y:"",1:"not "),"been deleted." "RTN","IVMLDEM6",135,0) Q "RTN","IVMLDEM6",136,0) ; "RTN","IVMLDEM6",137,0) ASK1 ; - phone selected to be uploaded - address fields not selected "RTN","IVMLDEM6",138,0) W ! S DIR("A")="Okay to update the PHONE NUMBER [RESIDENCE] field" "RTN","IVMLDEM6",139,0) S DIR("?",1)="Enter 'YES' to update the patient's Phone Number [Residence] that was" "RTN","IVMLDEM6",140,0) S DIR("?",2)="received from HEC. Enter 'NO' to quit." "RTN","IVMLDEM6",141,0) S DIR(0)="Y",DIR("B")="YES" "RTN","IVMLDEM6",142,0) D ^DIR K DIR "RTN","IVMLDEM6",143,0) S IVMFLAG=1 G ADDRQ:'Y "RTN","IVMLDEM6",144,0) W !,"Updating PHONE NUMBER [RESIDENCE] field... " "RTN","IVMLDEM6",145,0) G LOOP "RTN","IVMLDEM6",146,0) ; "RTN","IVMLDEM6",147,0) AUTOADDR(DFN,IVMPPICK,NOUPDT) ; "RTN","IVMLDEM6",148,0) ; this functionality is copied from above and modified to allow "RTN","IVMLDEM6",149,0) ; an automated upload of patient address information as stipulated "RTN","IVMLDEM6",150,0) ; in the business requirements for Address Indexing to support GMT "RTN","IVMLDEM6",151,0) ; "RTN","IVMLDEM6",152,0) ; Input: DFN - as patient IEN "RTN","IVMLDEM6",153,0) ; IVMPPICK - residence phone number and/or another address "RTN","IVMLDEM6",154,0) ; field selected "RTN","IVMLDEM6",155,0) ; 1 - address field(s) selected "RTN","IVMLDEM6",156,0) ; 3 - both address field(s) and phone selected "RTN","IVMLDEM6",157,0) ; NOUPDT - (optional) this flag is set when the incoming "RTN","IVMLDEM6",158,0) ; address data is older than the existing "RTN","IVMLDEM6",159,0) ; address in the Patient (#2) file "RTN","IVMLDEM6",160,0) ; "RTN","IVMLDEM6",161,0) ; Output: IVMFLAG - 1 if address fields updated "RTN","IVMLDEM6",162,0) ; 0 if address fields not updated "RTN","IVMLDEM6",163,0) ; "RTN","IVMLDEM6",164,0) ; "RTN","IVMLDEM6",165,0) ; "RTN","IVMLDEM6",166,0) N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y "RTN","IVMLDEM6",167,0) ; "RTN","IVMLDEM6",168,0) ; - initialize flags "RTN","IVMLDEM6",169,0) S IVMFLAG=0 "RTN","IVMLDEM6",170,0) S:'$G(NOUPDT) NOUPDT=0 "RTN","IVMLDEM6",171,0) ; "RTN","IVMLDEM6",172,0) ; - check for required parameters "RTN","IVMLDEM6",173,0) Q:'$G(DFN) IVMFLAG "RTN","IVMLDEM6",174,0) ; "RTN","IVMLDEM6",175,0) N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) "RTN","IVMLDEM6",176,0) I 'NOUPDT D EN^DGCLEAR(DFN) ;Deleting existing address before updating "RTN","IVMLDEM6",177,0) ; "RTN","IVMLDEM6",178,0) S IVMDA2=$G(IVM3015) "RTN","IVMLDEM6",179,0) Q:'$G(IVMDA2) IVMFLAG "RTN","IVMLDEM6",180,0) S IVMDA1=$O(^HL(771.3,"B","PID","")) "RTN","IVMLDEM6",181,0) S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1) "RTN","IVMLDEM6",182,0) Q:'IVMDA1 IVMFLAG "RTN","IVMLDEM6",183,0) ; "RTN","IVMLDEM6",184,0) S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D "RTN","IVMLDEM6",185,0) .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D "RTN","IVMLDEM6",186,0) ..; "RTN","IVMLDEM6",187,0) ..; - check for data node in (#301.511) sub-file "RTN","IVMLDEM6",188,0) ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) "RTN","IVMLDEM6",189,0) ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q "RTN","IVMLDEM6",190,0) ..; "RTN","IVMLDEM6",191,0) ..; - check if residence phone number -> do not auto-upload "RTN","IVMLDEM6",192,0) ..I (IVMPPICK=1&(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0)))) D DEMBULL^IVMPREC6 Q "RTN","IVMLDEM6",193,0) ..; "RTN","IVMLDEM6",194,0) ..; don't auto-update if there is an active Prescription record and "RTN","IVMLDEM6",195,0) ..; the Bad Address Indicator is null "RTN","IVMLDEM6",196,0) ..I ('NOUPDT),$$PHARM(+DFN),'$$BADADR^DGUTL3(+DFN) D DEMBULL^IVMPREC6 Q "RTN","IVMLDEM6",197,0) ..; "RTN","IVMLDEM6",198,0) ..; - load addr field rec'd from IVM into DHCP (#2) file "RTN","IVMLDEM6",199,0) ..I 'NOUPDT D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1 "RTN","IVMLDEM6",200,0) ..; "RTN","IVMLDEM6",201,0) ..; - remove entry from (#301.511) sub-file "RTN","IVMLDEM6",202,0) ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) "RTN","IVMLDEM6",203,0) ..; - if no display or uploadable fields left, then delete the PID "RTN","IVMLDEM6",204,0) ..; segment "RTN","IVMLDEM6",205,0) ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D "RTN","IVMLDEM6",206,0) ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter "RTN","IVMLDEM6",207,0) I IVMFLAG D "RTN","IVMLDEM6",208,0) .N DGCURR "RTN","IVMLDEM6",209,0) .D GETUPDTS^DGADDUTL(DFN,.DGCURR) "RTN","IVMLDEM6",210,0) .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR) "RTN","IVMLDEM6",211,0) Q IVMFLAG "RTN","IVMLDEM6",212,0) ; "RTN","IVMLDEM6",213,0) ADDRDT(DFN,IVMDA2,IVMDA1) ; "RTN","IVMLDEM6",214,0) ; - validate Address Change Dt/Tm before filing "RTN","IVMLDEM6",215,0) ; if incoming address is accepted and the change date is older "RTN","IVMLDEM6",216,0) ; than what's on file, then use today's date for Addr Chg Dt/Tm "RTN","IVMLDEM6",217,0) ; "RTN","IVMLDEM6",218,0) Q:'$$ADRDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1) "RTN","IVMLDEM6",219,0) N FDA,IEN92,IVMDA,IENS,ERR "RTN","IVMLDEM6",220,0) S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 "RTN","IVMLDEM6",221,0) Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) "RTN","IVMLDEM6",222,0) S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "RTN","IVMLDEM6",223,0) S IENS=IVMDA_","_IVMDA1_","_IVMDA2_"," "RTN","IVMLDEM6",224,0) S FDA(301.511,IENS,.02)=$$NOW^XLFDT "RTN","IVMLDEM6",225,0) D FILE^DIE("","FDA","ERR") "RTN","IVMLDEM6",226,0) Q "RTN","IVMLDEM6",227,0) ; "RTN","IVMLDEM6",228,0) PHARM(DFN) ;does this patient have active pharmacy prescriptions? "RTN","IVMLDEM6",229,0) ; "RTN","IVMLDEM6",230,0) ;External reference to $$EN^PSSRXACT supported by IA #4237 "RTN","IVMLDEM6",231,0) ; "RTN","IVMLDEM6",232,0) Q $S('$G(DFN):0,1:$$EN^PSSRXACT(DFN)) "RTN","IVMPBUL") 0^8^B7852022 "RTN","IVMPBUL",1,0) IVMPBUL ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- BULLETIN ; 10/20/05 11:48am "RTN","IVMPBUL",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMPBUL",3,0) ; "RTN","IVMPBUL",4,0) ; this routine will send a bulletin for a specified condition "RTN","IVMPBUL",5,0) ; "RTN","IVMPBUL",6,0) EN ; entry point "RTN","IVMPBUL",7,0) N DGB,DGTEXT,XMDUZ,XMSUB,DGSM,XMY,XMTEXT "RTN","IVMPBUL",8,0) ; "RTN","IVMPBUL",9,0) ; type = Type of Bulletin to send "RTN","IVMPBUL",10,0) ; "RTN","IVMPBUL",11,0) D CC ; assemble arrays and variables for bulletin "RTN","IVMPBUL",12,0) S DGB=6 D BUL ; send bulletin and quit "RTN","IVMPBUL",13,0) Q "RTN","IVMPBUL",14,0) ; "RTN","IVMPBUL",15,0) CC ; Consistency check bulletin "RTN","IVMPBUL",16,0) ; This bulletin will be sent for Z07 Consistency check process "RTN","IVMPBUL",17,0) ; it indicates the number of records sent and the number not sent "RTN","IVMPBUL",18,0) ; and instructions for further action "RTN","IVMPBUL",19,0) ; "RTN","IVMPBUL",20,0) N DGSEND,DGSENX,DGTOT,DGC,I,J "RTN","IVMPBUL",21,0) I '$D(^TMP($J,"CC")) Q "RTN","IVMPBUL",22,0) S DGSEND=^TMP($J,"CC",1),DGSENX=^TMP($J,"CC",0),DGTOT=DGSEND+DGSENX "RTN","IVMPBUL",23,0) S XMDUZ="IVM BACKGROUND JOB" "RTN","IVMPBUL",24,0) S XMSUB="HEC INCONSISTENCY TRANSMISSIONS" F I=1:1 S J=$P($T(BT+I),";;",2) Q:J="QUIT" S DGTEXT(I,0)=J,DGC=I "RTN","IVMPBUL",25,0) S DGC=DGC+1,DGTEXT(DGC,0)="" "RTN","IVMPBUL",26,0) S DGC=DGC+1,DGTEXT(DGC,0)=" Z07 MESSAGES SENT: "_$J(DGSEND,10) "RTN","IVMPBUL",27,0) S DGC=DGC+1,DGTEXT(DGC,0)=" Z07 MESSAGES NOT SENT: "_$J(DGSENX,10) "RTN","IVMPBUL",28,0) S DGC=DGC+1,DGTEXT(DGC,0)="" "RTN","IVMPBUL",29,0) Q "RTN","IVMPBUL",30,0) ; "RTN","IVMPBUL",31,0) BT ; ** Bulletin Text -- Line offset is called to assemble message *** "RTN","IVMPBUL",32,0) ;;Following is a summary of the inconsistent data check performed during "RTN","IVMPBUL",33,0) ;;the nightly process to transmit patient data to the HEC. The number NOT "RTN","IVMPBUL",34,0) ;;SENT, indicates the number of Z07 messages that were not transmitted due "RTN","IVMPBUL",35,0) ;;to data inconsistencies. These Z07 messages will not be sent until the "RTN","IVMPBUL",36,0) ;;inconsistencies are corrected. For details, run the Inconsistent Data "RTN","IVMPBUL",37,0) ;;Elements Report in the ADT Outputs Menu. "RTN","IVMPBUL",38,0) ;; "RTN","IVMPBUL",39,0) ;;QUIT "RTN","IVMPBUL",40,0) BUL ; create and transmit bulletin "RTN","IVMPBUL",41,0) ; "RTN","IVMPBUL",42,0) N DIC,DIX,DIY,DO,DD "RTN","IVMPBUL",43,0) I '$D(DGB),'$D(XMSUB) Q "RTN","IVMPBUL",44,0) K:$D(DGTEXT) XMTEXT I '$D(DGTEXT)&('$D(XMTEXT)) Q "RTN","IVMPBUL",45,0) S DGB=+$P($G(^DG(43,1,"NOT")),"^",DGB) "RTN","IVMPBUL",46,0) I '$D(^XMB(3.8,DGB,0)) Q "RTN","IVMPBUL",47,0) ; "RTN","IVMPBUL",48,0) ;Protect Fileman from Mailman call "RTN","IVMPBUL",49,0) N DICRREC,DIDATA,DIEFAR,DIEFCNOD,DIEFDAS,DIEFECNT,DIEFF,DIEFFLAG "RTN","IVMPBUL",50,0) N DIEFFLD,DIEFFLST,DIEFFREF,DIEFFVAL,DIEFFXR,DIEFI,DIEFIEN,DIEFLEV "RTN","IVMPBUL",51,0) N DIEFNODE,DIEFNVAL,DIEFOUT,DIEFOVAL,DIEFRFLD,DIEFRLST,DIEFSORK "RTN","IVMPBUL",52,0) N DIEFSPOT,DIEFTMP,DIEFTREF,DIFLD,DIFM,DIQUIET,DISYS,D,D0,DA "RTN","IVMPBUL",53,0) ; "RTN","IVMPBUL",54,0) S XMY("G."_$P($G(^XMB(3.8,DGB,0)),"^",1))="" ; pass mailgroup "RTN","IVMPBUL",55,0) Q:'$D(DUZ) S:'$D(DGSM) DGSM=1 "RTN","IVMPBUL",56,0) S XMTEXT=$S('$D(XMTEXT):"DGTEXT(",1:XMTEXT) "RTN","IVMPBUL",57,0) S:$D(DUZ)#2&(DGSM) XMY(DUZ)="" K:'$D(XMY) DGSM D ^XMD:$D(XMY) "RTN","IVMPBUL",58,0) ; "RTN","IVMPREC") 0^9^B24894893 "RTN","IVMPREC",1,0) IVMPREC ;ALB/MLI/ESD,BAJ - PROCESS INCOMING HL7 (QRY) MESSAGES ; 8/17/06 2:37pm "RTN","IVMPREC",2,0) ;;2.0;INCOME VERIFICATION MATCH;**1,9,11,15,18,24,34,105**;JUL 8,1996;Build 2 "RTN","IVMPREC",3,0) ;;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","IVMPREC",4,0) ; "RTN","IVMPREC",5,0) ; This routine will process (QRY) HL7 messages received from HEC "RTN","IVMPREC",6,0) ; At present, the (QRY) message queries for updated information "RTN","IVMPREC",7,0) ; for a single patient. "RTN","IVMPREC",8,0) ; "RTN","IVMPREC",9,0) ; "RTN","IVMPREC",10,0) QRY ; - Receive Query Message requesting further information "RTN","IVMPREC",11,0) ; "RTN","IVMPREC",12,0) S (HLEVN,IVMCT,IVMERROR,IVMFLAG)=0 "RTN","IVMPREC",13,0) ; "RTN","IVMPREC",14,0) K IVMQUERY("LTD"),IVMQUERY("OVIS") ;Variables needed to open/close last visit date and outpt visit QUERIES "RTN","IVMPREC",15,0) S IVMRTN="IVMPREC" "RTN","IVMPREC",16,0) K ^TMP($J,IVMRTN),^TMP("HLS",$J),^TMP("HLA",$J) "RTN","IVMPREC",17,0) F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","IVMPREC",18,0) .S CNT=0 "RTN","IVMPREC",19,0) .S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE "RTN","IVMPREC",20,0) .F S CNT=$O(HLNODE(CNT)) Q:'CNT D "RTN","IVMPREC",21,0) ..S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) "RTN","IVMPREC",22,0) ; "RTN","IVMPREC",23,0) ; INITIALIZE HL7 VARIABLES "RTN","IVMPREC",24,0) S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORF-Z07 SERVER" "RTN","IVMPREC",25,0) S HLEID=$O(^ORD(101,"B",HLEID,0)) "RTN","IVMPREC",26,0) D INIT^HLFNC2(HLEID,.HL) "RTN","IVMPREC",27,0) S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) "RTN","IVMPREC",28,0) ; "RTN","IVMPREC",29,0) ; IVM*2.0*105 BAJ 11/02/2005 Temp global for Consistency Checks "RTN","IVMPREC",30,0) K ^TMP($J,"CC") "RTN","IVMPREC",31,0) ; "RTN","IVMPREC",32,0) F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="QRD"!($E(IVMSEG,1,3)="MSH") D "RTN","IVMPREC",33,0) .I $E(IVMSEG,1,3)="MSH" S IVMMSHID=$P(IVMSEG,HLFS,10),MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID Q "RTN","IVMPREC",34,0) .K HLERR S IVMFLAG=1 "RTN","IVMPREC",35,0) .S IVMSEG=$P(IVMSEG,HLFS,2,999) ; strip off segment name "RTN","IVMPREC",36,0) .S IVMQLR=$P(IVMSEG,HLFS,7),DFN=$P(IVMSEG,HLFS,8),IVMIY=$P(IVMSEG,HLFS,10) "RTN","IVMPREC",37,0) .D ERRCK "RTN","IVMPREC",38,0) .I $D(HLERR) D ACK "RTN","IVMPREC",39,0) .I '$D(HLERR) D "RTN","IVMPREC",40,0) ..N EVENTS "RTN","IVMPREC",41,0) ..; - if master query - create entry in (#301.9) file "RTN","IVMPREC",42,0) ..I IVMQLR>1,'DFN D Q "RTN","IVMPREC",43,0) ...S IVMSEG1="QRD"_HLFS_IVMSEG "RTN","IVMPREC",44,0) ...S:'$D(^IVM(301.9,1,10,0)) ^(0)="^301.9001DA^" "RTN","IVMPREC",45,0) ...S DA(1)=1,DIC="^IVM(301.9,1,10,",DIC(0)="" "RTN","IVMPREC",46,0) ...S X=IVMIY "RTN","IVMPREC",47,0) ...K DO,DD D FILE^DICN "RTN","IVMPREC",48,0) ...S DA=+Y,DA(1)=1,DIE="^IVM(301.9,1,10," "RTN","IVMPREC",49,0) ...S DR=".02///NOW;.04////^S X=IVMMSHID;10////^S X=IVMSEG1" D ^DIE "RTN","IVMPREC",50,0) ..; "RTN","IVMPREC",51,0) ..; Send AE if veteran has a Pseudo SSN and eligibility is not verified "RTN","IVMPREC",52,0) ..; Removed with IVM*2*105 "RTN","IVMPREC",53,0) ..; I '$$SNDPSSN^IVMPTRN7(DFN) S HLERR="Pseudo SSN must be verified" D ACK Q "RTN","IVMPREC",54,0) ..; "RTN","IVMPREC",55,0) ..; - prepare (ACK) message "RTN","IVMPREC",56,0) ..D:'$D(HLERR) MSGHDR ;header (MSH) "RTN","IVMPREC",57,0) ..D ACK ;message (MSA) "RTN","IVMPREC",58,0) ..; "RTN","IVMPREC",59,0) ..; - set up local HL7 event type code in MSH "RTN","IVMPREC",60,0) ..S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="QRD"_HLFS_IVMSEG ; copy of incoming QRD "RTN","IVMPREC",61,0) ..; "RTN","IVMPREC",62,0) ..; - build 'FULL' transmission (note: without MSH segment) "RTN","IVMPREC",63,0) ..S IVMMTDT=$E(IVMIY,1,3)+1_"1231.9999" "RTN","IVMPREC",64,0) ..D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,,1,,.IVMQUERY) "RTN","IVMPREC",65,0) ; "RTN","IVMPREC",66,0) ; IVM*2.0*105 BAJ 11/02/2005 "RTN","IVMPREC",67,0) ; send AE if inconsistencies found. "RTN","IVMPREC",68,0) I ^TMP($J,"CC",0) S HLERR="Message not sent. Inconsistencies in Record" D ACK "RTN","IVMPREC",69,0) K ^TMP($J,"CC") "RTN","IVMPREC",70,0) ; "RTN","IVMPREC",71,0) F Z="LTD","OVIS" I $G(IVMQUERY(Z)) D CLOSE^SDQ(IVMQUERY(Z)) K IVMQUERY(Z) "RTN","IVMPREC",72,0) I 'IVMFLAG S HLERR="Invalid Message Format" D ACK "RTN","IVMPREC",73,0) S HLMTN="ORF" "RTN","IVMPREC",74,0) S HLMTIENA=HLMTIEN "RTN","IVMPREC",75,0) K ^TMP("HLA",$J) M ^TMP("HLA",$J)=^TMP("HLS",$J) K ^TMP("HLS",$J) "RTN","IVMPREC",76,0) D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,"GB",1,.HLRESLTA,HLMTIENA,.HLP) "RTN","IVMPREC",77,0) ; "RTN","IVMPREC",78,0) QRYQ K DFN,DR,HLEVN,IVMCT,IVMDA,IVMERROR,IVMFLAG,IVMIY,IVMMTDT,IVMSEG,IVMSEG1,IVMQLR,IVMMSHID,MSGID,MSHID "RTN","IVMPREC",79,0) K ^TMP("HLA",$J),^TMP("HLS",$J),^TMP($J,IVMRTN) "RTN","IVMPREC",80,0) Q "RTN","IVMPREC",81,0) ; "RTN","IVMPREC",82,0) ; "RTN","IVMPREC",83,0) ERRCK ; Perform error checks on HL7 (QRD) segment "RTN","IVMPREC",84,0) I ('DFN!(DFN'=+DFN)) S:IVMQLR'>1 HLERR="Invalid DFN" "RTN","IVMPREC",85,0) I '$D(HLERR) S IVMIY=$$FMDATE^HLFNC(IVMIY) I $E(IVMIY,4,7)'="0000"!($E(IVMIY,1,3)<292) S HLERR="Invalid Income Year" "RTN","IVMPREC",86,0) I '$D(HLERR),$P(IVMSEG,HLFS,2)'="R" S HLERR="Invalid Query Format Code" "RTN","IVMPREC",87,0) I '$D(HLERR),$P(IVMSEG,HLFS,3)'="I",($P(IVMSEG,HLFS,3)'="D") S HLERR="Invalid Query Priority" "RTN","IVMPREC",88,0) I '$D(HLERR),$P(IVMSEG,HLFS,9)'="DEM" S HLERR="Invalid Query Subject Filter" "RTN","IVMPREC",89,0) I '$D(HLERR),$P(IVMSEG,HLFS,12)'="T" S HLERR="Invalid Query Results Level" "RTN","IVMPREC",90,0) ; "RTN","IVMPREC",91,0) Q "RTN","IVMPREC",92,0) ; "RTN","IVMPREC",93,0) MSGHDR ; prepare header MSH segment in batch of 100 message events "RTN","IVMPREC",94,0) ; input variables: "RTN","IVMPREC",95,0) ; IVMCT record counter "RTN","IVMPREC",96,0) ; HLEVN event number "RTN","IVMPREC",97,0) ; MSHID outgoing message id "RTN","IVMPREC",98,0) ; HL array for protocol "RTN","IVMPREC",99,0) ; "RTN","IVMPREC",100,0) N MID,HLRES "RTN","IVMPREC",101,0) S HLEVN=$G(HLEVN)+1 "RTN","IVMPREC",102,0) D:(HLEVN#100)=1 "RTN","IVMPREC",103,0) .K MSHID,HLDT,HLDT1,HLMTIEN "RTN","IVMPREC",104,0) .D INIT^HLFNC2(HLEID,.HL) "RTN","IVMPREC",105,0) .D CREATE^HLTF(.MSHID,.HLMTIEN,.HLDT,.HLDT1) "RTN","IVMPREC",106,0) S MID=MSHID_"-"_HLEVN "RTN","IVMPREC",107,0) D MSH^HLFNC2(.HL,MID,.HLRES) "RTN","IVMPREC",108,0) S IVMCT=$G(IVMCT)+1 "RTN","IVMPREC",109,0) S ^TMP("HLS",$J,IVMCT)=HLRES "RTN","IVMPREC",110,0) Q "RTN","IVMPREC",111,0) ; "RTN","IVMPREC",112,0) ACK ; prepare positive and negative acknowledgement (ACK) message "RTN","IVMPREC",113,0) ; (positive acknowledgement: MSA segment with no MSH segment) "RTN","IVMPREC",114,0) ; (negative acknowledgement: MSA segment with MSH segment) "RTN","IVMPREC",115,0) N MID,HLRES "RTN","IVMPREC",116,0) S IVMCT=$G(IVMCT)+1 "RTN","IVMPREC",117,0) D:$D(HLERR) "RTN","IVMPREC",118,0) .S IVMERROR=1 "RTN","IVMPREC",119,0) .S HLEVN=HLEVN+1 "RTN","IVMPREC",120,0) .D:(HLEVN#100)=1 "RTN","IVMPREC",121,0) ..K HLMID,HLMTIEN,HLDT,HLDT1 ; set up batch "RTN","IVMPREC",122,0) ..D INIT^HLFNC2(HLEID,.HL) "RTN","IVMPREC",123,0) ..D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) "RTN","IVMPREC",124,0) .S MID=HLMID_"-"_HLEVN "RTN","IVMPREC",125,0) .D MSH^HLFNC2(.HL,MID,.HLRES) "RTN","IVMPREC",126,0) .S ^TMP("HLS",$J,IVMCT)=HLRES "RTN","IVMPREC",127,0) .S IVMCT=IVMCT+1 "RTN","IVMPREC",128,0) .S ^TMP("HLS",$J,IVMCT)="MSA"_HLFS_"AE"_HLFS_MSGID_HLFS_HLERR_"- SSN "_$S($G(DFN):$P($$PT^IVMUFNC4(DFN),"^",2),1:"NOT FOUND") "RTN","IVMPREC",129,0) I '$D(HLERR) S ^TMP("HLS",$J,IVMCT)="MSA"_HLFS_"AA"_HLFS_HLMID "RTN","IVMPREC",130,0) ; "RTN","IVMPREC",131,0) Q "RTN","IVMPREC",132,0) ; "RTN","IVMPTRN") 0^10^B44251671 "RTN","IVMPTRN",1,0) IVMPTRN ;ALB/MLI,SEK,RTK,BRM,BAJ - IVM BACKGROUND JOB/TRANSMISSIONS TO IVM CENTER; 10/28/2005 "RTN","IVMPTRN",2,0) ;;2.0;INCOME VERIFICATION MATCH;**1,9,11,12,17,28,34,74,79,89,105**;JUL 8,1996;Build 2 "RTN","IVMPTRN",3,0) ;;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","IVMPTRN",4,0) ; "RTN","IVMPTRN",5,0) ; This routine is run nightly to send HL7 messages to the IVM Center for "RTN","IVMPTRN",6,0) ; processing. "RTN","IVMPTRN",7,0) ; "RTN","IVMPTRN",8,0) BGJ ; - IVM Nightly Background Job "RTN","IVMPTRN",9,0) ; "RTN","IVMPTRN",10,0) ;for tests being held for the future, make them primary if now effective "RTN","IVMPTRN",11,0) D FUTUREMT,FUTURERX "RTN","IVMPTRN",12,0) ; "RTN","IVMPTRN",13,0) ; - retransmit enrollment/eligibility queries with no reply "RTN","IVMPTRN",14,0) D BATCH^DGENQRY1 "RTN","IVMPTRN",15,0) ; "RTN","IVMPTRN",16,0) ; - retransmit income test (financial) queries with no reply "RTN","IVMPTRN",17,0) D MONITOR^IVMCQ2 "RTN","IVMPTRN",18,0) ; "RTN","IVMPTRN",19,0) ; - current year and previous year "RTN","IVMPTRN",20,0) S IVMCURYR=$$LYR^DGMTSCU1(DT),IVMPREYR=$$LYR^DGMTSCU1(IVMCURYR) "RTN","IVMPTRN",21,0) ; "RTN","IVMPTRN",22,0) ; "RTN","IVMPTRN",23,0) ; - Master Query Processing "RTN","IVMPTRN",24,0) ; "RTN","IVMPTRN",25,0) ; - respond to Master Query for previous year, if necessary "RTN","IVMPTRN",26,0) S IVMREC=$$QRY(IVMPREYR) I IVMREC D RESP(IVMPREYR,+IVMREC),END "RTN","IVMPTRN",27,0) ; "RTN","IVMPTRN",28,0) ; - respond to Master Query for current year, if necessary "RTN","IVMPTRN",29,0) S IVMREC=$$QRY(IVMCURYR) I IVMREC D RESP(IVMCURYR,+IVMREC),END "RTN","IVMPTRN",30,0) ; "RTN","IVMPTRN",31,0) ; - send regular 'nightly' transmissions "RTN","IVMPTRN",32,0) D REG,END "RTN","IVMPTRN",33,0) ; "RTN","IVMPTRN",34,0) ; - perform retransmission processing "RTN","IVMPTRN",35,0) D ENTRY^IVMPTRN4,END "RTN","IVMPTRN",36,0) ; "RTN","IVMPTRN",37,0) ; - process billing activity "RTN","IVMPTRN",38,0) D EN^IVMPTRN5 "RTN","IVMPTRN",39,0) ; "RTN","IVMPTRN",40,0) ; - auto-upload address changes from #301.5 if >14 days old "RTN","IVMPTRN",41,0) ; - auto-delete non address changes from #301.5 if >30 days old "RTN","IVMPTRN",42,0) N ADDRDT S ADDRDT(0)=30,ADDRDT(1)=14 D EN^IVMLDEMC(.ADDRDT) "RTN","IVMPTRN",43,0) ; "RTN","IVMPTRN",44,0) END ; - cleanup "RTN","IVMPTRN",45,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","IVMPTRN",46,0) K DA,DFN,DIE,DIK,DR,IVMCT,IVMDA,IVMDT,IVMGTOT,IVMINCYR,IVMINS,IVMMTDT "RTN","IVMPTRN",47,0) K IVMNODE,IVMPAT,IVMPID,IVMQDT,IVMREC,IVMSTAT,X,%,VAFPID,IVMPREYR,IVMIY "RTN","IVMPTRN",48,0) D CLEAN^IVMUFNC "RTN","IVMPTRN",49,0) K ^TMP($J,"CC") "RTN","IVMPTRN",50,0) Q "RTN","IVMPTRN",51,0) ; "RTN","IVMPTRN",52,0) REG ; Creates FULL query transmission for patient's "RTN","IVMPTRN",53,0) ; that exist in file (#301.5) "ATR" x-ref "RTN","IVMPTRN",54,0) ; "RTN","IVMPTRN",55,0) ; "RTN","IVMPTRN",56,0) ; - initialize variables for HL7/IVM "RTN","IVMPTRN",57,0) S HLMTN="ORU" "RTN","IVMPTRN",58,0) S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" "_HLMTN_"-Z07 SERVER" "RTN","IVMPTRN",59,0) S HLEID=$O(^ORD(101,"B",HLEID,0)) "RTN","IVMPTRN",60,0) K ^TMP($J,"CC") ;refresh Consistency Check counter "RTN","IVMPTRN",61,0) D INIT^IVMUFNC(HLEID,.HL) "RTN","IVMPTRN",62,0) ; "RTN","IVMPTRN",63,0) ; - roll thru ATR x-ref for patients that require transmission "RTN","IVMPTRN",64,0) K IVMQUERY("LTD"),IVMQUERY("OVIS") ;Variables needed to open/close last visit date and outpt visit QUERIES "RTN","IVMPTRN",65,0) S IVMIY=0 "RTN","IVMPTRN",66,0) F S IVMIY=$O(^IVM(301.5,"ATR",0,IVMIY)) Q:'IVMIY D "RTN","IVMPTRN",67,0) .S IVMDA=0 "RTN","IVMPTRN",68,0) .F S IVMDA=$O(^IVM(301.5,"ATR",0,IVMIY,IVMDA)) Q:'IVMDA D "RTN","IVMPTRN",69,0) ..; "RTN","IVMPTRN",70,0) ..N EVENTS "RTN","IVMPTRN",71,0) ..; - get node, income year, dfn "RTN","IVMPTRN",72,0) ..S IVMNODE=$G(^IVM(301.5,+IVMDA,0)),IVMDT=+$P(IVMNODE,"^",2),DFN=+IVMNODE "RTN","IVMPTRN",73,0) ..I 'DFN!'IVMDT Q "RTN","IVMPTRN",74,0) ..; "RTN","IVMPTRN",75,0) ..Q:($$STATUS^IVMPLOG(IVMDA,.EVENTS)=1) "RTN","IVMPTRN",76,0) ..; "RTN","IVMPTRN",77,0) ..S IVMMTDT=$P($$LST^DGMTU(DFN,($E(IVMDT,1,3)+1)_"1231.9999"),"^",2) "RTN","IVMPTRN",78,0) ..; "RTN","IVMPTRN",79,0) ..; - prepare FULL transmission "RTN","IVMPTRN",80,0) ..D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,,,,.IVMQUERY) "RTN","IVMPTRN",81,0) ; "RTN","IVMPTRN",82,0) ; After all transmissions send Bulletin of inconsistency check totals "RTN","IVMPTRN",83,0) D EN^IVMPBUL "RTN","IVMPTRN",84,0) ; "RTN","IVMPTRN",85,0) F Z="LTD","OVIS" I $G(IVMQUERY(Z)) D CLOSE^SDQ(IVMQUERY(Z)) K IVMQUERY(Z) "RTN","IVMPTRN",86,0) ; - transmit remaining records "RTN","IVMPTRN",87,0) D "RTN","IVMPTRN",88,0) .N IVMEVENT "RTN","IVMPTRN",89,0) .; event code for Full Data Transmission "RTN","IVMPTRN",90,0) .S IVMEVENT="Z07" "RTN","IVMPTRN",91,0) .D FILE^IVMPTRN3 "RTN","IVMPTRN",92,0) Q "RTN","IVMPTRN",93,0) ; "RTN","IVMPTRN",94,0) RESP(IVMINCYR,IVMREC) ; Response to the Master Query. "RTN","IVMPTRN",95,0) ; "RTN","IVMPTRN",96,0) ; Input: IVMINCYR - The income year for which the query was sent "RTN","IVMPTRN",97,0) ; IVMREC - Internal entry number of query to be updated "RTN","IVMPTRN",98,0) ; "RTN","IVMPTRN",99,0) N DFN,IVMDA,IVMMTDT,DA,DR,DIE,EVENTS "RTN","IVMPTRN",100,0) ; "RTN","IVMPTRN",101,0) ; - initialize variables for HL7/IVM "RTN","IVMPTRN",102,0) S HLMTN="ORF" "RTN","IVMPTRN",103,0) S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" "_HLMTN_"-Z07 SERVER" "RTN","IVMPTRN",104,0) S HLEID=$O(^ORD(101,"B",HLEID,0)) "RTN","IVMPTRN",105,0) D INIT^IVMUFNC(HLEID,.HL) "RTN","IVMPTRN",106,0) ; "RTN","IVMPTRN",107,0) ; - roll thru AYR x-ref "RTN","IVMPTRN",108,0) F DFN=0:0 S DFN=$O(^IVM(301.5,"AYR",IVMINCYR,DFN)) Q:'DFN D "RTN","IVMPTRN",109,0) .F IVMDA=0:0 S IVMDA=$O(^IVM(301.5,"AYR",IVMINCYR,DFN,IVMDA)) Q:'IVMDA D "RTN","IVMPTRN",110,0) ..; "RTN","IVMPTRN",111,0) ..; - check for STOP FLAG in file #301.5. "RTN","IVMPTRN",112,0) ..I '$$CLOSED^IVMPLOG(IVMDA) D "RTN","IVMPTRN",113,0) ...; "RTN","IVMPTRN",114,0) ...; if means test was deleted, -10000 could be entered as income year "RTN","IVMPTRN",115,0) ...; in ^IVM(301.5. close case if deleted. "RTN","IVMPTRN",116,0) ...S IVMMTDT=$P($$LST^DGMTU(DFN,($E(IVMINCYR,1,3)+1)_"1231.9999"),"^",2) "RTN","IVMPTRN",117,0) ...I IVMMTDT="" D CLOSE^IVMPTRN1(IVMINCYR,DFN,1,3) Q "RTN","IVMPTRN",118,0) ...; "RTN","IVMPTRN",119,0) ...;get EVENTS() array "RTN","IVMPTRN",120,0) ...I $$STATUS^IVMPLOG(+IVMDA,.EVENTS) "RTN","IVMPTRN",121,0) ...; "RTN","IVMPTRN",122,0) ...; - prepare FULL transmission "RTN","IVMPTRN",123,0) ...; note: 6th parameter is IVMFLL (=1 to include MSA segment) "RTN","IVMPTRN",124,0) ...D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,1,,$G(IVMREC),.IVMQUERY) "RTN","IVMPTRN",125,0) ; "RTN","IVMPTRN",126,0) ; - transmit remaining records "RTN","IVMPTRN",127,0) D "RTN","IVMPTRN",128,0) .N IVMEVENT "RTN","IVMPTRN",129,0) .; event code for Full Data Transmission "RTN","IVMPTRN",130,0) .S IVMEVENT="Z07" "RTN","IVMPTRN",131,0) .D FILE1^IVMPTRN3 ; added for v1.6 because of MSA segment (note: the original call was to FILE^IVMPTRN3) "RTN","IVMPTRN",132,0) ; "RTN","IVMPTRN",133,0) ; "RTN","IVMPTRN",134,0) ; - update multiple in file #301.9. Stuff (.03) field with date/time "RTN","IVMPTRN",135,0) ; of FULL query transmission. "RTN","IVMPTRN",136,0) S DIE="^IVM(301.9,1,10,",DA=+IVMREC,DA(1)=1,DR=".03////"_$$NOW^XLFDT D ^DIE "RTN","IVMPTRN",137,0) Q "RTN","IVMPTRN",138,0) ; "RTN","IVMPTRN",139,0) QRY(YEAR) ; See if Master Query has been satisfied for YEAR. "RTN","IVMPTRN",140,0) ; Input: YEAR - The income year being checked "RTN","IVMPTRN",141,0) ; "RTN","IVMPTRN",142,0) ; Output: 1^2, where 1 = 0, if query does not need a response "RTN","IVMPTRN",143,0) ; >0, if query needs a response (value "RTN","IVMPTRN",144,0) ; equal to ien of sub-file entry "RTN","IVMPTRN",145,0) ; in #301.9 "RTN","IVMPTRN",146,0) ; 2 = 0, if the request has not been received "RTN","IVMPTRN",147,0) ; 1, if the request has been received "RTN","IVMPTRN",148,0) N IVM,X,Y,Z "RTN","IVMPTRN",149,0) I '$G(YEAR) S X="0^0" G QRYQ "RTN","IVMPTRN",150,0) S Y=$O(^IVM(301.9,1,10,"AB",YEAR,"")) I 'Y S X="0^0" G QRYQ "RTN","IVMPTRN",151,0) S IVM=$O(^IVM(301.9,1,10,"AB",YEAR,Y,0)) I 'IVM S X="0^0" G QRYQ "RTN","IVMPTRN",152,0) S Z=$P($G(^IVM(301.9,1,10,+IVM,0)),"^",3) "RTN","IVMPTRN",153,0) S X=$S(Z:0,1:IVM)_"^1" "RTN","IVMPTRN",154,0) QRYQ Q X "RTN","IVMPTRN",155,0) ; "RTN","IVMPTRN",156,0) FUTUREMT ; "RTN","IVMPTRN",157,0) ;Find future tests, and if now effective then make them primary. Will "RTN","IVMPTRN",158,0) ;call the MT event driver unless NOT required, in which case the status "RTN","IVMPTRN",159,0) ;will have the status will be changed to NO LONGER REQUIRED "RTN","IVMPTRN",160,0) ;and may auto-create a Rx copay test "RTN","IVMPTRN",161,0) ; "RTN","IVMPTRN",162,0) N FDATE,IVMPAT,MTIEN,NODE,DFN,DATA "RTN","IVMPTRN",163,0) ; "RTN","IVMPTRN",164,0) S FDATE=0 "RTN","IVMPTRN",165,0) F S FDATE=$O(^IVM(301.5,"AC",FDATE)) Q:('FDATE) Q:(FDATE>DT) D "RTN","IVMPTRN",166,0) .S IVMPAT=0 "RTN","IVMPTRN",167,0) .F S IVMPAT=$O(^IVM(301.5,"AC",FDATE,IVMPAT)) Q:'IVMPAT D "RTN","IVMPTRN",168,0) ..S MTIEN=$O(^IVM(301.5,"AC",FDATE,IVMPAT,""),-1) "RTN","IVMPTRN",169,0) ..I '$$FUTURECK("AC",FDATE,IVMPAT,MTIEN) K ^IVM(301.5,"AC",FDATE,IVMPAT,MTIEN) "RTN","IVMPTRN",170,0) ..K DATA S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) "RTN","IVMPTRN",171,0) ..S DFN=+$G(^IVM(301.5,IVMPAT,0)) "RTN","IVMPTRN",172,0) ..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,1) I $E($P(NODE,"^",2),1,3)=$E(DT,1,3),$P(NODE,"^",4)'="","R"'=$P(NODE,"^",4) K ^IVM(301.5,"AC",FDATE,IVMPAT,MTIEN) Q "RTN","IVMPTRN",173,0) ..D MTPRIME^DGMTU4(MTIEN) "RTN","IVMPTRN",174,0) Q "RTN","IVMPTRN",175,0) ; "RTN","IVMPTRN",176,0) FUTURERX ; "RTN","IVMPTRN",177,0) ;Find future COPAY tests, and if now effective then make it primary. "RTN","IVMPTRN",178,0) ;Will change the status to NO LONGER APPLICABLE if the vet is not "RTN","IVMPTRN",179,0) ;subject to pharmacy copayments "RTN","IVMPTRN",180,0) ; "RTN","IVMPTRN",181,0) N FDATE,IVMPAT,MTIEN,NODE,DFN,DATA "RTN","IVMPTRN",182,0) ; "RTN","IVMPTRN",183,0) S FDATE=0 "RTN","IVMPTRN",184,0) F S FDATE=$O(^IVM(301.5,"AD",FDATE)) Q:('FDATE) Q:(FDATE>DT) D "RTN","IVMPTRN",185,0) .S IVMPAT=0 "RTN","IVMPTRN",186,0) .F S IVMPAT=$O(^IVM(301.5,"AD",FDATE,IVMPAT)) Q:'IVMPAT D "RTN","IVMPTRN",187,0) ..S MTIEN=$O(^IVM(301.5,"AD",FDATE,IVMPAT,""),-1) "RTN","IVMPTRN",188,0) ..I '$$FUTURECK("AD",FDATE,IVMPAT,MTIEN) K ^IVM(301.5,"AD",FDATE,IVMPAT,MTIEN) "RTN","IVMPTRN",189,0) ..K DATA S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) "RTN","IVMPTRN",190,0) ..S DFN=+$G(^IVM(301.5,IVMPAT,0)) "RTN","IVMPTRN",191,0) ..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,2) I $E($P(NODE,"^",2),1,3)=$E(DT,1,3),$P(NODE,"^",4)'="" K ^IVM(301.5,"AD",FDATE,IVMPAT,MTIEN) Q "RTN","IVMPTRN",192,0) ..D RXPRIME^DGMTU4(MTIEN) "RTN","IVMPTRN",193,0) Q "RTN","IVMPTRN",194,0) ; "RTN","IVMPTRN",195,0) FUTURECK(TYPE,FDATE,IVMPAT,MTIEN) ; "RTN","IVMPTRN",196,0) ; Check the Future MT or CP xref for a valid income test entry, "RTN","IVMPTRN",197,0) ; and Delete all invalid xref entries. "RTN","IVMPTRN",198,0) N VALID,MTREC S VALID=1,MTREC=0 "RTN","IVMPTRN",199,0) ; "RTN","IVMPTRN",200,0) ; Remove duplicate entries from cross reference, leaving last entry "RTN","IVMPTRN",201,0) F S MTREC=$O(^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC)) Q:(MTREC=MTIEN!('MTREC)) K ^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC) "RTN","IVMPTRN",202,0) ; "RTN","IVMPTRN",203,0) I '$D(^IVM(301.5,IVMPAT,0)) S VALID=0 Q VALID "RTN","IVMPTRN",204,0) I '$D(^DGMT(408.31,MTIEN,0)) S VALID=0 Q VALID "RTN","IVMPTRN",205,0) I FDATE'=+(^DGMT(408.31,MTIEN,0)) S VALID=0 Q VALID "RTN","IVMPTRN",206,0) ; "RTN","IVMPTRN",207,0) Q VALID "RTN","IVMPTRN7") 0^11^B7588290 "RTN","IVMPTRN7",1,0) IVMPTRN7 ;ALB/KCL/CJM/PHH/BAJ - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ;10/20/2005 "RTN","IVMPTRN7",2,0) ;;2.0;INCOME VERIFICATION MATCH;**9,11,24,34,74,88,105**;JUL 8,1996;Build 2 "RTN","IVMPTRN7",3,0) ; "RTN","IVMPTRN7",4,0) ; "RTN","IVMPTRN7",5,0) FULL(DFN,IVMMTDT,EVENTS,IVMCT,IVMGTOT,IVMFLL,IVMNOMSH,IVMREC,IVMQUERY) ; "RTN","IVMPTRN7",6,0) ;Description: This entry point will be used to create an HL7 "Full Data Transmission" message for a patient. Transmission of these messages will be in a batch of 1-100 individual HL7 messages. "RTN","IVMPTRN7",7,0) ; "RTN","IVMPTRN7",8,0) ;Input: "RTN","IVMPTRN7",9,0) ; DFN - Patient IEN "RTN","IVMPTRN7",10,0) ; IVMMTDT - date of the patient's Means Test or Copay Test "RTN","IVMPTRN7",11,0) ; EVENTS () - an array of reasons for transmission, pass by reference. "RTN","IVMPTRN7",12,0) ; EVENTS("IVM") = 1 if transmission due to IVM criteria, 0 otherwise "RTN","IVMPTRN7",13,0) ; EVENTS(" "DCD")=1 if transmission due to DCD criteria, 0 otherwise "RTN","IVMPTRN7",14,0) ; EVENTS("ENROLL")=1 if transmission due to enrollment criteria, 0 otherwise "RTN","IVMPTRN7",15,0) ; IVMCT - count of segments transmitted, pass by reference "RTN","IVMPTRN7",16,0) ; IVMGTOT - count of batchs transmitted, pass by reference "RTN","IVMPTRN7",17,0) ; IVMFLL - (optional), flag for creating MSA, QRD segments for FULL query transmission, $G(IVMFLL) means yes "RTN","IVMPTRN7",18,0) ; IVMNOMSH - (optional), if IVMNOMSH=1, means the MSH segment should not be built "RTN","IVMPTRN7",19,0) ; IVMREC - (optional), if $G(IVMFLL), then this variable will contain the internal entry number of Query Income Year #301.9001 mult. "RTN","IVMPTRN7",20,0) ; IVMQUERY - array passed in by reference where "RTN","IVMPTRN7",21,0) ; IVMQUERY("LTD") -- # of the QUERY that is currently open or "RTN","IVMPTRN7",22,0) ; undefined, zero, or null if no QUERY opened for "RTN","IVMPTRN7",23,0) ; last treatment date "RTN","IVMPTRN7",24,0) ; IVMQUERY("OVIS") -- # of the QUERY that is currently open or "RTN","IVMPTRN7",25,0) ; undefined, zero, or null if no QUERY opened for "RTN","IVMPTRN7",26,0) ; finding outpatient visits "RTN","IVMPTRN7",27,0) ; "RTN","IVMPTRN7",28,0) ;HL7 variables as defined by call to INIT^IVMUFNC: "RTN","IVMPTRN7",29,0) ; HLEVN - HL7 message event counter "RTN","IVMPTRN7",30,0) ; HLSDT - a flag that indicates that the data to be sent is stored in the ^TMP("HLS") global array. "RTN","IVMPTRN7",31,0) ; "RTN","IVMPTRN7",32,0) ;The following variables returned by the INIT^HLTRANS entry point: "RTN","IVMPTRN7",33,0) ; HLNDAP - Non-DHCP Application Pointer from file 770 "RTN","IVMPTRN7",34,0) ; HLNDAP0 - Zero node from file 770 corresponding to HLNDAP "RTN","IVMPTRN7",35,0) ; HLDAP - DHCP Application Pointer from file 771 "RTN","IVMPTRN7",36,0) ; HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP "RTN","IVMPTRN7",37,0) ; HLPID - HL7 processing ID from file 770 "RTN","IVMPTRN7",38,0) ; HLVER - HL7 version number from file 770 "RTN","IVMPTRN7",39,0) ; HLFS - HL7 Field Separater from the 'FS' node of file 771 "RTN","IVMPTRN7",40,0) ; HLECH - HL7 Encoding Characters from the 'EC' node of file 771 "RTN","IVMPTRN7",41,0) ; HLQ - Double quotes ("") for use in building HL7 segments "RTN","IVMPTRN7",42,0) ; HLERR - if an error is encountered, an error message is returned in the HLERR variable. "RTN","IVMPTRN7",43,0) ; HLDA - the internal entry number for the entry created in file 772 "RTN","IVMPTRN7",44,0) ; "RTN","IVMPTRN7",45,0) ; HLDT - the transmission date/time (associated with the entry in in file 772 identified by HLDA) in internal VA FileMan format. "RTN","IVMPTRN7",46,0) ; HLDT1 - the same transmission date/time as the HLDT variable, only in HL7 format. "RTN","IVMPTRN7",47,0) ; "RTN","IVMPTRN7",48,0) ;Output: "RTN","IVMPTRN7",49,0) ; ^TMP("HLS",$J,IVMCT) - global array containing all segments of the HL7 message that the VistA application wishes to send. The HLSDT variable is defined above and the IVMCT variable is a sequential number starting at 1. "RTN","IVMPTRN7",50,0) ; "RTN","IVMPTRN7",51,0) N DGREL,DGINC,DR,I,IVMI,IVMDFN,IVMHLMID,IVMNTE,IVMPAT,IVMQRD,X,IVMCNTID "RTN","IVMPTRN7",52,0) ; "RTN","IVMPTRN7",53,0) ; IVM*2.0*105 BAJ 10/20/2005 "RTN","IVMPTRN7",54,0) ; Do Z07 Consistency checks and, if fail, prevent Z07 Build "RTN","IVMPTRN7",55,0) I '$$EN^IVMZ07C(DFN) Q "RTN","IVMPTRN7",56,0) ; "RTN","IVMPTRN7",57,0) ; INITIALIZE HL7 1.6 VARIABLES "RTN","IVMPTRN7",58,0) D INIT^HLFNC2(HLEID,.HL) "RTN","IVMPTRN7",59,0) ; "RTN","IVMPTRN7",60,0) ; quit if Pseudo SSN and not verified "RTN","IVMPTRN7",61,0) ; Q:'$$SNDPSSN(DFN) ;Removed by IVM*2*105 "RTN","IVMPTRN7",62,0) ; "RTN","IVMPTRN7",63,0) ; if count=0 and not first batch "RTN","IVMPTRN7",64,0) ;RMC;I IVMCT=0,$G(IVMGTOT) D FILE^HLTF "RTN","IVMPTRN7",65,0) ; "RTN","IVMPTRN7",66,0) ; HL7 event/message counter "RTN","IVMPTRN7",67,0) S HLEVN=$G(HLEVN)+1 "RTN","IVMPTRN7",68,0) ; "RTN","IVMPTRN7",69,0) ; CREATE SLOT FOR EACH NEW BATCH "RTN","IVMPTRN7",70,0) I HLEVN=1 D "RTN","IVMPTRN7",71,0) . K HLMID,MTIEN,HLDT,HLDT1 "RTN","IVMPTRN7",72,0) . D CREATE^HLTF(.HLMID,.MTIEN,.HLDT,.HLDT1) "RTN","IVMPTRN7",73,0) ; "RTN","IVMPTRN7",74,0) ; handle message header processing for HL7 full data trans (Z07) msg "RTN","IVMPTRN7",75,0) D MSH^IVMUFNC4($G(IVMNOMSH),$G(IVMFLL),$G(IVMREC),.IVMCT,.IVMCNTID) "RTN","IVMPTRN7",76,0) ; "RTN","IVMPTRN7",77,0) I IVMMTDT="" D "RTN","IVMPTRN7",78,0) .S IVMMTDT=$P($$LST^DGMTU(DFN,DT),"^",2) "RTN","IVMPTRN7",79,0) .I IVMMTDT="" S IVMMTDT=DT "RTN","IVMPTRN7",80,0) ; "RTN","IVMPTRN7",81,0) ; build HL7 Full Data Transmission (Z07) message "RTN","IVMPTRN7",82,0) D BUILD^IVMPTRN8(DFN,IVMMTDT,.IVMCT,.IVMQUERY) "RTN","IVMPTRN7",83,0) ; "RTN","IVMPTRN7",84,0) ; log patient transmission "RTN","IVMPTRN7",85,0) D "RTN","IVMPTRN7",86,0) .N IVMSTAT "RTN","IVMPTRN7",87,0) .S X=$$LST^DGMTCOU1(DFN,IVMMTDT,3) "RTN","IVMPTRN7",88,0) .S IVMSTAT=$S($E($P(X,"^",2),1,3)=$E(IVMMTDT,1,3):$P($G(^DGMT(408.31,+X,0)),"^",3),1:"") "RTN","IVMPTRN7",89,0) .; "RTN","IVMPTRN7",90,0) .D FILEPT^IVMPTRN3(DFN,$$LYR^DGMTSCU1(IVMMTDT),HLDT,IVMCNTID,.EVENTS,IVMSTAT,IVMINS) "RTN","IVMPTRN7",91,0) ; "RTN","IVMPTRN7",92,0) ;if number of HL7 events/msgs is 100 then call HL7 pkg to transmit batch "RTN","IVMPTRN7",93,0) I HLEVN=100 D "RTN","IVMPTRN7",94,0) .N IVMEVENT "RTN","IVMPTRN7",95,0) .; event code for Full Data Transmission "RTN","IVMPTRN7",96,0) .S IVMEVENT="Z07" "RTN","IVMPTRN7",97,0) .I $G(IVMFLL) D FILE1^IVMPTRN3 Q "RTN","IVMPTRN7",98,0) .D FILE^IVMPTRN3 "RTN","IVMPTRN7",99,0) Q "RTN","IVMPTRN7",100,0) ; "RTN","IVMPTRN7",101,0) SNDPSSN(DFN) ; check SSN and patient eligibility "RTN","IVMPTRN7",102,0) ; "RTN","IVMPTRN7",103,0) ; Input: "RTN","IVMPTRN7",104,0) ; DFN Patient file (#2) IEN "RTN","IVMPTRN7",105,0) ; Output: "RTN","IVMPTRN7",106,0) ; 1: Pseudo SSN and Eligibility verified or "RTN","IVMPTRN7",107,0) ; not a Pseudo SSN "RTN","IVMPTRN7",108,0) ; 0: Psuedo SSN and Eligibility Pending verification "RTN","IVMPTRN7",109,0) ; Pending re-verification "RTN","IVMPTRN7",110,0) ; "RTN","IVMPTRN7",111,0) N SSN,PFLG "RTN","IVMPTRN7",112,0) ; "RTN","IVMPTRN7",113,0) ; Don't process records with corrupted nodes "RTN","IVMPTRN7",114,0) I '$D(^DPT(DFN,0)) D REM Q 0 "RTN","IVMPTRN7",115,0) ; "RTN","IVMPTRN7",116,0) S SSN=$P(^DPT(DFN,0),U,9) "RTN","IVMPTRN7",117,0) S PFLG=($E(SSN,$L(SSN))="P") I 'PFLG Q 1 "RTN","IVMPTRN7",118,0) I ($P($G(^DPT(DFN,.361)),U)="V") Q 1 "RTN","IVMPTRN7",119,0) ; "RTN","IVMPTRN7",120,0) D REM "RTN","IVMPTRN7",121,0) Q 0 "RTN","IVMPTRN7",122,0) ; "RTN","IVMPTRN7",123,0) REM ; Remove Psuedo SSN from Queue "RTN","IVMPTRN7",124,0) ; Set TRANSMISSION STATUS to transmission not required "RTN","IVMPTRN7",125,0) S PDATA(.03)=1 I $$UPD^DGENDBS(301.5,IVMDA,.PDATA,.ERR) "RTN","IVMPTRN7",126,0) K PDATA,ERR "RTN","IVMPTRN7",127,0) Q "RTN","IVMPTRN8") 0^12^B44153552 "RTN","IVMPTRN8",1,0) IVMPTRN8 ;ALB/RKS/PDJ/BRM,TDM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ; 4/10/06 4:34pm "RTN","IVMPTRN8",2,0) ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,24,36,37,47,48,42,34,77,76,75,79,85,89,98,56,97,104,113,109,114,105**; 21-OCT-94;Build 2 "RTN","IVMPTRN8",3,0) ; "RTN","IVMPTRN8",4,0) ; "RTN","IVMPTRN8",5,0) BUILD(DFN,IVMMTDT,IVMCT,IVMQUERY) ; -- "RTN","IVMPTRN8",6,0) ; Description: This entry point will be used to create an HL7 "RTN","IVMPTRN8",7,0) ; "Full Data Transmission" message for a patient. "RTN","IVMPTRN8",8,0) ; "RTN","IVMPTRN8",9,0) ; Input: "RTN","IVMPTRN8",10,0) ; DFN - Patient IEN "RTN","IVMPTRN8",11,0) ; IVMMTDT - date of the patient's Means Test or Copay Test "RTN","IVMPTRN8",12,0) ; IVMCT - count of hl7 segments transmitted, pass by reference "RTN","IVMPTRN8",13,0) ; IVMQUERY - array passed in by reference where "RTN","IVMPTRN8",14,0) ; IVMQUERY("LTD") -- # of the QUERY that is currently open or "RTN","IVMPTRN8",15,0) ; undefined, zero, or null if no QUERY opened for "RTN","IVMPTRN8",16,0) ; last treatment date "RTN","IVMPTRN8",17,0) ; IVMQUERY("OVIS") -- # of the QUERY that is currently open or "RTN","IVMPTRN8",18,0) ; undefined, zero, or null if no QUERY opened for "RTN","IVMPTRN8",19,0) ; finding outpatient visits "RTN","IVMPTRN8",20,0) ; "RTN","IVMPTRN8",21,0) ; HL7 variables as defined by call to INIT^IVMUFNC: "RTN","IVMPTRN8",22,0) ; HLEVN - HL7 message event counter "RTN","IVMPTRN8",23,0) ; HLSDT - a flag that indicates that the data to be sent is "RTN","IVMPTRN8",24,0) ; stored in the ^TMP("HLS") global array. "RTN","IVMPTRN8",25,0) ; "RTN","IVMPTRN8",26,0) ; The following variables returned by the INIT^HLTRANS entry point: "RTN","IVMPTRN8",27,0) ; HLNDAP - Non-DHCP Application Pointer from file 770 "RTN","IVMPTRN8",28,0) ; HLNDAP0 - Zero node from file 770 corresponding to HLNDAP "RTN","IVMPTRN8",29,0) ; HLDAP - DHCP Application Pointer from file 771 "RTN","IVMPTRN8",30,0) ; HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP "RTN","IVMPTRN8",31,0) ; HLPID - HL7 processing ID from file 770 "RTN","IVMPTRN8",32,0) ; HLVER - HL7 version number from file 770 "RTN","IVMPTRN8",33,0) ; HLFS - HL7 Field Separator from the 'FS' node of file 771 "RTN","IVMPTRN8",34,0) ; HLECH - HL7 Encoding Characters from the 'EC' node of file 771 "RTN","IVMPTRN8",35,0) ; HLQ - Double quotes ("") for use in building HL7 segments "RTN","IVMPTRN8",36,0) ; HLERR - if an error is encountered, an error message is returned "RTN","IVMPTRN8",37,0) ; in the HLERR variable. "RTN","IVMPTRN8",38,0) ; HLDA - the internal entry number for the entry created in "RTN","IVMPTRN8",39,0) ; file #772. "RTN","IVMPTRN8",40,0) ; HLDT - transmission date/time (associated with the entry in file "RTN","IVMPTRN8",41,0) ; #772 identified by HLDA) in internal VA FileMan format. "RTN","IVMPTRN8",42,0) ; HLDT1 - the same transmission date/time as the HLDT variable, "RTN","IVMPTRN8",43,0) ; only in HL7 format. "RTN","IVMPTRN8",44,0) ; "RTN","IVMPTRN8",45,0) ; Output: "RTN","IVMPTRN8",46,0) ; ^TMP("HLS",$J,IVMCT) - global array containing all segments of the HL7 message that the VistA application wishes to send. The HLSDT variable is defined above and the IVMCT variable is a sequential number incremented by 1. "RTN","IVMPTRN8",47,0) ; "RTN","IVMPTRN8",48,0) ; "RTN","IVMPTRN8",49,0) N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,VAFPID,VAFZEL,FBZFE,IVMZCD,DELETE,NODE,IVMPIEN,TEST,IVMPNODE,TESTTYPE,SEQS,TESTCODE,HARDSHIP,ACTVIEN,IVMZMH,IVMSEQ "RTN","IVMPTRN8",50,0) N EDBMTZ06,ZMHSQ,SETID,OBXCNT,OBXTMP,DGSEC,SEGOCC,ZIOSEG,N101015,RF1SEG "RTN","IVMPTRN8",51,0) ; "RTN","IVMPTRN8",52,0) ; create (PID) Patient Identification segment "RTN","IVMPTRN8",53,0) ; **** Add ICN to 2nd piece PID segment for MPI@HEC. "RTN","IVMPTRN8",54,0) S IVMCMOR="1,2",IVMSEQ=1 "RTN","IVMPTRN8",55,0) ; check to see if site is a legacy site. If not add ICN to PID segment. "RTN","IVMPTRN8",56,0) I '$D(^PPP(1020.128,"AC",$P($$SITE^VASITE,"^",3))) D "RTN","IVMPTRN8",57,0) . I +$$GETICN^MPIF001(DFN)>0,($$IFLOCAL^MPIF001(DFN)=0) S IVMSEQ=IVMSEQ_",2",IVMCMOR="1,2,3" ;add SEQ 1 and 2 for PID "RTN","IVMPTRN8",58,0) ; "RTN","IVMPTRN8",59,0) ; send SSN indicating pseudo "RTN","IVMPTRN8",60,0) ; I $P(IVMPID_$G(IVMPID(1)),HLFS,20)["P" D PSEUDO^IVMPTRN1 ; strip 'P' from pseudo SSNs "RTN","IVMPTRN8",61,0) S IVMSEQ=IVMSEQ_",3,5,7,8,11,12,13,14,19" "RTN","IVMPTRN8",62,0) K IVMPID D BLDPID^VAFCQRY1(DFN,1,IVMSEQ,.IVMPID,.HL,.ERROR) "RTN","IVMPTRN8",63,0) S SEGOCC=0 F S SEGOCC=$O(IVMPID(SEGOCC)) Q:SEGOCC="" D "RTN","IVMPTRN8",64,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMPID(SEGOCC) "RTN","IVMPTRN8",65,0) ; "RTN","IVMPTRN8",66,0) ; **** create (PD1) Patient CMOR segment for MPI@HEC. "RTN","IVMPTRN8",67,0) S:'$D(HL("FS")) HL("FS")=HLFS "RTN","IVMPTRN8",68,0) S:'$D(HL("ECH")) HL("ECH")=HLECH "RTN","IVMPTRN8",69,0) S:'$D(HL("Q")) HL("Q")=HLQ "RTN","IVMPTRN8",70,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLPD1(DFN,IVMCMOR) "RTN","IVMPTRN8",71,0) ; "RTN","IVMPTRN8",72,0) ; create (ZPD) Patient Dependent Info. segment "RTN","IVMPTRN8",73,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN1^VAFHLZPD(DFN,"1,8,9,11,12,13,17,19,31,32,33,40"),IVMINS=$P(^(IVMCT),HLFS,12) "RTN","IVMPTRN8",74,0) ; "RTN","IVMPTRN8",75,0) ; create (ZTA) Temporary Address segment "RTN","IVMPTRN8",76,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,8,9") "RTN","IVMPTRN8",77,0) ; "RTN","IVMPTRN8",78,0) ; create (ZIE) Ineligible segment "RTN","IVMPTRN8",79,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIE(DFN,"1,2,3",1) "RTN","IVMPTRN8",80,0) ; "RTN","IVMPTRN8",81,0) ; create (ZEL) Eligibility segment(s) "RTN","IVMPTRN8",82,0) ; **** Add 5th piece to ZEL to correct consistency check "RTN","IVMPTRN8",83,0) D EN1^VAFHLZEL(DFN,"1,2,5,6,7,8,10,11,13,14,15,16,17,18,19,20,21,22,23,24,25,29,34,35,37,38,39,40",2,.VAFZEL) "RTN","IVMPTRN8",84,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1)) ; Primary Eligibility "RTN","IVMPTRN8",85,0) I $D(VAFZEL(1,1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1,1)) "RTN","IVMPTRN8",86,0) ; - other entitled eligibilities "RTN","IVMPTRN8",87,0) F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",88,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(+IVMSUB)) "RTN","IVMPTRN8",89,0) ; "RTN","IVMPTRN8",90,0) ; create (ZEN) Enrollment segment "RTN","IVMPTRN8",91,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN) "RTN","IVMPTRN8",92,0) ; "RTN","IVMPTRN8",93,0) ; create (ZCD) Catastrophic Disability segment(s) "RTN","IVMPTRN8",94,0) D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS) "RTN","IVMPTRN8",95,0) F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",96,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB)) "RTN","IVMPTRN8",97,0) ; "RTN","IVMPTRN8",98,0) ; Optionally create (ZMH) Military History segments "RTN","IVMPTRN8",99,0) D ENTER^VAFHLZMH(DFN,"IVMZMH") "RTN","IVMPTRN8",100,0) S (ZMHSQ,SETID)=0 "RTN","IVMPTRN8",101,0) I $D(IVMZMH) F S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ="" D "RTN","IVMPTRN8",102,0) .Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")="" "RTN","IVMPTRN8",103,0) .S SETID=SETID+1,IVMCT=IVMCT+1 "RTN","IVMPTRN8",104,0) .S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6) "RTN","IVMPTRN8",105,0) ; "RTN","IVMPTRN8",106,0) ; create (ZRD) Rated Disabilities segment(s) "RTN","IVMPTRN8",107,0) D EN^VAFHLZRD(DFN,"1,2,3,4",HLQ,HLFS,"IVMZRD") "RTN","IVMPTRN8",108,0) F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",109,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0)) "RTN","IVMPTRN8",110,0) ; "RTN","IVMPTRN8",111,0) ; create (ZCT) Emergency Contact segment "RTN","IVMPTRN8",112,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1) "RTN","IVMPTRN8",113,0) ; "RTN","IVMPTRN8",114,0) ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse "RTN","IVMPTRN8",115,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3") "RTN","IVMPTRN8",116,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3",2,2) "RTN","IVMPTRN8",117,0) ; "RTN","IVMPTRN8",118,0) ; create (ZGD) Guardian segment for (1) VA & (2) Civil "RTN","IVMPTRN8",119,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1) "RTN","IVMPTRN8",120,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2) "RTN","IVMPTRN8",121,0) ; "RTN","IVMPTRN8",122,0) ; Income Year requiring transmission from IVM Patient File (301.5) "RTN","IVMPTRN8",123,0) S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000)) "RTN","IVMPTRN8",124,0) N MTINFO S MTINFO=$$FUT^DGMTU(DFN) "RTN","IVMPTRN8",125,0) I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2) "RTN","IVMPTRN8",126,0) ;get the primary test for the income year "RTN","IVMPTRN8",127,0) S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN) "RTN","IVMPTRN8",128,0) ; "RTN","IVMPTRN8",129,0) ; The following function call returns: "RTN","IVMPTRN8",130,0) ; - Patient Relation IEN array in DGREL "RTN","IVMPTRN8",131,0) ; - Individual Annual Income IEN array in DGINC "RTN","IVMPTRN8",132,0) ; - Income Relation IEN array in DGINR "RTN","IVMPTRN8",133,0) D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN) "RTN","IVMPTRN8",134,0) ; "RTN","IVMPTRN8",135,0) S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1 "RTN","IVMPTRN8",136,0) ; create (ZIC) Income segment for veteran "RTN","IVMPTRN8",137,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20") "RTN","IVMPTRN8",138,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3) "RTN","IVMPTRN8",139,0) ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct "RTN","IVMPTRN8",140,0) S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY) "RTN","IVMPTRN8",141,0) ; "RTN","IVMPTRN8",142,0) ; create (ZIR) Income Relation segment for veteran "RTN","IVMPTRN8",143,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("V")),"1,2,3,4,5,10") "RTN","IVMPTRN8",144,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1" "RTN","IVMPTRN8",145,0) ; "RTN","IVMPTRN8",146,0) ; create (ZDP) Patient Dependent Info. segment for spouse "RTN","IVMPTRN8",147,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("S")),"1,2,3,4,5,6,7,8,9,10") "RTN","IVMPTRN8",148,0) I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D "RTN","IVMPTRN8",149,0) .; - pass non-existant SSNs as 0s "RTN","IVMPTRN8",150,0) .S $P(X,HLFS,6)="000000000" "RTN","IVMPTRN8",151,0) ; "RTN","IVMPTRN8",152,0) ; create (ZIC) Income segment for spouse "RTN","IVMPTRN8",153,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,4,5,6,7,8,9,10,11,12,16,17,18,19,20") "RTN","IVMPTRN8",154,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3) "RTN","IVMPTRN8",155,0) ; "RTN","IVMPTRN8",156,0) ; create (ZIR) Income Relation segment for spouse "RTN","IVMPTRN8",157,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3") "RTN","IVMPTRN8",158,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2) "RTN","IVMPTRN8",159,0) ; "RTN","IVMPTRN8",160,0) ; "RTN","IVMPTRN8",161,0) ; create ZDP, ZIC, and ZIR segments for all Means Test dependents "RTN","IVMPTRN8",162,0) F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",163,0) .; "RTN","IVMPTRN8",164,0) .; - create (ZDP) Dependent Info. segment for dependent child "RTN","IVMPTRN8",165,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("C",IVMSUB)),"1,2,3,4,5,6,7,9,10") "RTN","IVMPTRN8",166,0) .I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D "RTN","IVMPTRN8",167,0) ..; - pass non-existant SSNs as 0s "RTN","IVMPTRN8",168,0) ..S $P(X,HLFS,6)="000000000" "RTN","IVMPTRN8",169,0) .; "RTN","IVMPTRN8",170,0) .; - create (ZIC) Income segment for dependent child "RTN","IVMPTRN8",171,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,4,5,6,7,8,9,10,11,12,15") "RTN","IVMPTRN8",172,0) .I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3) "RTN","IVMPTRN8",173,0) .; "RTN","IVMPTRN8",174,0) .; - create (ZIR) Income Relation segment for dependent child "RTN","IVMPTRN8",175,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("C",IVMSUB)),"1,2,3,6,7,8,9,14") "RTN","IVMPTRN8",176,0) .I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2) "RTN","IVMPTRN8",177,0) .; "RTN","IVMPTRN8",178,0) ; "RTN","IVMPTRN8",179,0) D GOTO^IVMPTRN9 "RTN","IVMPTRN8",180,0) Q "RTN","IVMPTRN9") 0^13^B52146820 "RTN","IVMPTRN9",1,0) IVMPTRN9 ;ALB/KCL/CN/BRM,TDM,EG - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ; 4/10/06 4:36pm "RTN","IVMPTRN9",2,0) ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46,50,53,34,49,58,79,99,116,105**; 21-OCT-94;Build 2 "RTN","IVMPTRN9",3,0) ; "RTN","IVMPTRN9",4,0) ; "RTN","IVMPTRN9",5,0) GOTO ; place to break up the routine "RTN","IVMPTRN9",6,0) ; "RTN","IVMPTRN9",7,0) ; create (ZIO) Inpatient/Outpatient segment for veteran "RTN","IVMPTRN9",8,0) S N101015=$G(^DPT(DFN,1010.15)) "RTN","IVMPTRN9",9,0) S ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY) ;seq 1-3 "RTN","IVMPTRN9",10,0) S ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY) ;seq 4 "RTN","IVMPTRN9",11,0) S X=$P(N101015,"^",9),$P(ZIOSEG,U,6)=$S(X=0:"N",X=1:"Y",1:HLQ) ;Appt Request "RTN","IVMPTRN9",12,0) S X=$P(N101015,"^",11),$P(ZIOSEG,U,7)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) ;Appt Request Date "RTN","IVMPTRN9",13,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZIOSEG "RTN","IVMPTRN9",14,0) ; "RTN","IVMPTRN9",15,0) ; create (NTE) Notes and Comments segment "RTN","IVMPTRN9",16,0) D NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT) "RTN","IVMPTRN9",17,0) I '$D(IVMNTE) D "RTN","IVMPTRN9",18,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="NTE^1" "RTN","IVMPTRN9",19,0) I $D(IVMNTE) D "RTN","IVMPTRN9",20,0) .; - get notes and comments "RTN","IVMPTRN9",21,0) .F IVMSUB=0:0 S IVMSUB=$O(IVMNTE(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN9",22,0) ..S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMNTE(IVMSUB) "RTN","IVMPTRN9",23,0) ; "RTN","IVMPTRN9",24,0) ; create (IN1) Insurance segment(s) for all active insurance "RTN","IVMPTRN9",25,0) K ^TMP("VAFIN1",$J) "RTN","IVMPTRN9",26,0) D EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36") "RTN","IVMPTRN9",27,0) F IVMSUB=0:0 S IVMSUB=$O(^TMP("VAFIN1",$J,IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN9",28,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=^TMP("VAFIN1",$J,+IVMSUB,0) "RTN","IVMPTRN9",29,0) ; "RTN","IVMPTRN9",30,0) ;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent? "RTN","IVMPTRN9",31,0) F I="RX","MT","HARDSHIP","DATE OF TEST","LTC" S DELETE(I)="" "RTN","IVMPTRN9",32,0) S IVMPIEN=$$FIND^IVMPLOG(DFN,($E(IVMMTDT,1,3)-1)) "RTN","IVMPTRN9",33,0) I IVMPIEN D "RTN","IVMPTRN9",34,0) .S IVMPNODE=$G(^IVM(301.5,IVMPIEN,0)) "RTN","IVMPTRN9",35,0) .I $P(IVMPNODE,"^",8)!$P(IVMPNODE,"^",9)!$P(IVMPNODE,"^",10)!$P(IVMPNODE,"^",11) S DELETE("SET")=1 "RTN","IVMPTRN9",36,0) .;was the MT deletion flag set, and if so verify that there is no completed MT "RTN","IVMPTRN9",37,0) .I $P(IVMPNODE,"^",8),(TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",8),DELETE("MT")=1 "RTN","IVMPTRN9",38,0) .; "RTN","IVMPTRN9",39,0) .;was the hardship deletion flag set, and if so verify that there is no completed hardship "RTN","IVMPTRN9",40,0) .I $P(IVMPNODE,"^",10),'HARDSHIP D "RTN","IVMPTRN9",41,0) ..S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",10) "RTN","IVMPTRN9",42,0) ..S DELETE("HARDSHIP")=1 "RTN","IVMPTRN9",43,0) ; "RTN","IVMPTRN9",44,0) ; create (ZMT) Means Test segment "RTN","IVMPTRN9",45,0) ; "RTN","IVMPTRN9",46,0) S SEQS=$S(TESTTYPE=1:"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29,30",1:"1,17") "RTN","IVMPTRN9",47,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1) "RTN","IVMPTRN9",48,0) ; "RTN","IVMPTRN9",49,0) ; create (ZMT) Rx-Copay Test segment "RTN","IVMPTRN9",50,0) I IVMPIEN D "RTN","IVMPTRN9",51,0) .;was the RX deletion flag set, and if so verify that there is no completed test "RTN","IVMPTRN9",52,0) .I $P(IVMPNODE,"^",9),(TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",9),DELETE("RX")=1 "RTN","IVMPTRN9",53,0) ; "RTN","IVMPTRN9",54,0) N IVMCPDT,CPTST,LINK,CPDATE "RTN","IVMPTRN9",55,0) ;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards "RTN","IVMPTRN9",56,0) ;as long as the means test date is in the current year "RTN","IVMPTRN9",57,0) S CPTST=$$LST^DGMTU(DFN,$E(IVMIY,1,3)+1_1231,2) "RTN","IVMPTRN9",58,0) I CPTST D "RTN","IVMPTRN9",59,0) . S CPDATE=$P(CPTST,U,2) "RTN","IVMPTRN9",60,0) . S LINK=$P($G(^DGMT(408.31,+CPTST,2)),U,6) "RTN","IVMPTRN9",61,0) . I TESTTYPE=1,$E(CPDATE,1,3)=$E(IVMMTDT,1,3) D "RTN","IVMPTRN9",62,0) . . ;if you have a means test and a linked co-pay test then send both (the means test "RTN","IVMPTRN9",63,0) . . ;was already sent from above) "RTN","IVMPTRN9",64,0) . . ;if means and copay are not linked, don't send the co-pay test (the means test "RTN","IVMPTRN9",65,0) . . ;was already sent from above) "RTN","IVMPTRN9",66,0) . . I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S TESTTYPE=2,(IVMCPDT,IVMMTDT)=CPDATE "RTN","IVMPTRN9",67,0) . . Q "RTN","IVMPTRN9",68,0) . Q "RTN","IVMPTRN9",69,0) ;always send the 2nd ZMT segment "RTN","IVMPTRN9",70,0) S SEQS="1,17" "RTN","IVMPTRN9",71,0) ;can also send a co-pay test if there is no means test (see module GETTYPE) "RTN","IVMPTRN9",72,0) I TESTTYPE=2 D "RTN","IVMPTRN9",73,0) . S SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26" "RTN","IVMPTRN9",74,0) . Q "RTN","IVMPTRN9",75,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1) "RTN","IVMPTRN9",76,0) ; "RTN","IVMPTRN9",77,0) ; create (ZMT) Long Term Care Copay Exemption Test segment "RTN","IVMPTRN9",78,0) I IVMPIEN D "RTN","IVMPTRN9",79,0) .; set deletion indicators if LTC test deletion should be transmitted "RTN","IVMPTRN9",80,0) .I $P(IVMPNODE,"^",11) S DELETE("LTC")=1 S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",11) "RTN","IVMPTRN9",81,0) ; "RTN","IVMPTRN9",82,0) S SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25" "RTN","IVMPTRN9",83,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1) "RTN","IVMPTRN9",84,0) ; "RTN","IVMPTRN9",85,0) ;if the deletion flags were set in the IVM Patient file, unset them "RTN","IVMPTRN9",86,0) I $G(DELETE("SET")) D "RTN","IVMPTRN9",87,0) .N DATA "RTN","IVMPTRN9",88,0) .S DATA(.08)="",DATA(.09)="",DATA(.1)="",DATA(.11)="" "RTN","IVMPTRN9",89,0) .I $$UPD^DGENDBS(301.5,IVMPIEN,.DATA) "RTN","IVMPTRN9",90,0) ; "RTN","IVMPTRN9",91,0) ; create (ZBT) Beneficiary Travel segment based on last BT Claim "RTN","IVMPTRN9",92,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7") "RTN","IVMPTRN9",93,0) ; "RTN","IVMPTRN9",94,0) ; create (ZFE) Fee Basis segment(s) "RTN","IVMPTRN9",95,0) D EN^FBHLZFE(DFN,"1,2,3,4,5") "RTN","IVMPTRN9",96,0) F IVMSUB=0:0 S IVMSUB=+$O(FBZFE(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN9",97,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(FBZFE(+IVMSUB)) "RTN","IVMPTRN9",98,0) ; "RTN","IVMPTRN9",99,0) ; create (ZSP) Service Period segment "RTN","IVMPTRN9",100,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZSP(DFN,1,1) "RTN","IVMPTRN9",101,0) ; "RTN","IVMPTRN9",102,0) ; optionally create (OBX) segment for Patient Sensitivity Flag "RTN","IVMPTRN9",103,0) K OBXTMP "RTN","IVMPTRN9",104,0) S OBXCNT=0,GETCUR=$$FINDSEC^DGENSEC(DFN) "RTN","IVMPTRN9",105,0) I GETCUR,$$GET^DGENSEC(GETCUR,.DGSEC) D "RTN","IVMPTRN9",106,0) .Q:(DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0) "RTN","IVMPTRN9",107,0) .S OBXTMP(2)="CE",OBXTMP(3)="38.1"_$E(HL("ECH"))_"SECURITY LOG" "RTN","IVMPTRN9",108,0) .S:DGSEC("LEVEL") OBXTMP(5)="Y"_$E(HL("ECH"))_"YES"_$E(HL("ECH"))_"HL70136" "RTN","IVMPTRN9",109,0) .S:'DGSEC("LEVEL") OBXTMP(5)="N"_$E(HL("ECH"))_"NO"_$E(HL("ECH"))_"HL70136" "RTN","IVMPTRN9",110,0) .S OBXTMP(11)="R",OBXTMP(14)=DGSEC("DATETIME") "RTN","IVMPTRN9",111,0) .S OBXTMP(16)="" I $G(DGSEC("SOURCE"))'="" D "RTN","IVMPTRN9",112,0) ..S $P(OBXTMP(16),$E(HL("ECH")),14)=$E(HL("ECH"),4)_DGSEC("SOURCE") "RTN","IVMPTRN9",113,0) .S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1 "RTN","IVMPTRN9",114,0) .S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16") "RTN","IVMPTRN9",115,0) .I $G(OBXTMP(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(OBXTMP(16)) "RTN","IVMPTRN9",116,0) ; "RTN","IVMPTRN9",117,0) ; create (OBX) segment for NTR "RTN","IVMPTRN9",118,0) ; CALL PIMS API TO GET NTRARRY OF NTR DATA "RTN","IVMPTRN9",119,0) S GETCUR=$$ENRGET^DGNTAPI1(DFN) "RTN","IVMPTRN9",120,0) I GETCUR D NTROBX^IVMPTRNA(.DGNTARR) "RTN","IVMPTRN9",121,0) I $D(NTROBX) D "RTN","IVMPTRN9",122,0) . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1 "RTN","IVMPTRN9",123,0) . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17") "RTN","IVMPTRN9",124,0) . I $G(NTROBX(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(NTROBX(16)) "RTN","IVMPTRN9",125,0) . K NTROBX "RTN","IVMPTRN9",126,0) ; "RTN","IVMPTRN9",127,0) ; create (RF1) segment "RTN","IVMPTRN9",128,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD") "RTN","IVMPTRN9",129,0) F RF1TYP="CAD","CPH","PNO","EAD" D ;Create Optional RF1 Segments "RTN","IVMPTRN9",130,0) . S RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP) Q:RF1SEG="" "RTN","IVMPTRN9",131,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=RF1SEG "RTN","IVMPTRN9",132,0) ; "RTN","IVMPTRN9",133,0) Q "RTN","IVMPTRN9",134,0) ; "RTN","IVMPTRN9",135,0) GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN) ; "RTN","IVMPTRN9",136,0) ;Determines the type of test to include in the Z10. HEC wants only the "RTN","IVMPTRN9",137,0) ;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect. "RTN","IVMPTRN9",138,0) ; "RTN","IVMPTRN9",139,0) ;Input: "RTN","IVMPTRN9",140,0) ; DFN "RTN","IVMPTRN9",141,0) ; IVMMTDT -date to be the search for the test "RTN","IVMPTRN9",142,0) ;Output: "RTN","IVMPTRN9",143,0) ; Function value - type of test to send in Z10 "RTN","IVMPTRN9",144,0) ; CODE - status code of test (pass by reference) "RTN","IVMPTRN9",145,0) ; HARDSHIP - hardship indicator (pass by reference) "RTN","IVMPTRN9",146,0) ; ACTVIEN - ien of test that should have the associated Income Relations (pass by reference) "RTN","IVMPTRN9",147,0) ; "RTN","IVMPTRN9",148,0) N TESTTYPE,MTNODE,RXNODE,NODE0,NODE2 "RTN","IVMPTRN9",149,0) S TESTTYPE=1 "RTN","IVMPTRN9",150,0) S (HARDSHIP,CODE,ACTVIEN)="" "RTN","IVMPTRN9",151,0) Q:'$G(IVMMTDT) TESTTYPE "RTN","IVMPTRN9",152,0) Q:'$G(DFN) TESTTYPE "RTN","IVMPTRN9",153,0) ; "RTN","IVMPTRN9",154,0) S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE="" "RTN","IVMPTRN9",155,0) S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE="" "RTN","IVMPTRN9",156,0) ; "RTN","IVMPTRN9",157,0) I MTNODE="" S MTNODE=$$FUT^DGMTU(DFN,"",1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE="" "RTN","IVMPTRN9",158,0) I RXNODE="" S RXNODE=$$FUT^DGMTU(DFN,"",2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE="" "RTN","IVMPTRN9",159,0) D "RTN","IVMPTRN9",160,0) .;determine which test has the associated income relations "RTN","IVMPTRN9",161,0) .; "RTN","IVMPTRN9",162,0) .I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q "RTN","IVMPTRN9",163,0) .I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q "RTN","IVMPTRN9",164,0) .I +MTNODE S ACTVIEN=+MTNODE Q "RTN","IVMPTRN9",165,0) .I +RXNODE S ACTVIEN=+RXNODE Q "RTN","IVMPTRN9",166,0) I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN) "RTN","IVMPTRN9",167,0) ; "RTN","IVMPTRN9",168,0) ;now find the primary test "RTN","IVMPTRN9",169,0) I '(+MTNODE) G CHKCOPAY "RTN","IVMPTRN9",170,0) S CODE=$P(MTNODE,"^",4) "RTN","IVMPTRN9",171,0) S HARDSHIP=$P($G(^DGMT(408.31,+MTNODE,0)),"^",20) "RTN","IVMPTRN9",172,0) I (CODE="")!("ACGP"'[CODE) S NODE2=$G(^DGMT(408.31,+MTNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("ACGP"'[CODE) G CHKCOPAY "RTN","IVMPTRN9",173,0) ; "RTN","IVMPTRN9",174,0) G QGETTYPE "RTN","IVMPTRN9",175,0) ; "RTN","IVMPTRN9",176,0) CHKCOPAY ; "RTN","IVMPTRN9",177,0) I '(+RXNODE) G QGETTYPE "RTN","IVMPTRN9",178,0) S CODE=$P(RXNODE,"^",4) "RTN","IVMPTRN9",179,0) I (CODE="")!("EM"'[CODE) S NODE2=$G(^DGMT(408.31,+RXNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("EM"'[CODE) G QGETTYPE "RTN","IVMPTRN9",180,0) S TESTTYPE=2 "RTN","IVMPTRN9",181,0) ; "RTN","IVMPTRN9",182,0) QGETTYPE ; "RTN","IVMPTRN9",183,0) Q TESTTYPE "RTN","IVMPTRN9",184,0) ; "RTN","IVMPTRN9",185,0) FILTER(DFN) ; address transmission filter "RTN","IVMPTRN9",186,0) ; Check Bad Address Indicator for a known bad address and "RTN","IVMPTRN9",187,0) ; Scrutinize the Street Address line 1 field for known bad address "RTN","IVMPTRN9",188,0) ; strings based on functionality currently in place in HEC Legacy. "RTN","IVMPTRN9",189,0) ; "RTN","IVMPTRN9",190,0) ; Input: DFN - ien of the Patient (#2) file "RTN","IVMPTRN9",191,0) ; Output: 0 - filter passed (ok to transmit address) "RTN","IVMPTRN9",192,0) ; 1 - filter failed (do not transmit address) "RTN","IVMPTRN9",193,0) ; "RTN","IVMPTRN9",194,0) N VAPA "RTN","IVMPTRN9",195,0) Q:'$G(DFN) 1 ;DFN missing "RTN","IVMPTRN9",196,0) Q:$$BADADR^DGUTL3(DFN) 1 ;check Bad Address Indicator "RTN","IVMPTRN9",197,0) D ADD^VADPT ;get patient address "RTN","IVMPTRN9",198,0) ; Street Address Line 1 or Zip Code is "RTN","IVMPTRN9",199,0) Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1 "RTN","IVMPTRN9",200,0) ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS' "RTN","IVMPTRN9",201,0) Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS") 1 "RTN","IVMPTRN9",202,0) ; The first two characters of the address is equal to '**' "RTN","IVMPTRN9",203,0) Q:$E(VAPA(1),1,2)="**" 1 "RTN","IVMPTRN9",204,0) ; passed all address filters - ok to send "RTN","IVMPTRN9",205,0) Q 0 "RTN","IVMPTRNA") 0^22^B15122403 "RTN","IVMPTRNA",1,0) IVMPTRNA ;ALB/CKN/BRM,TDM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER(CONTINUED);30 AUG 2001 ; 5/17/06 1:57pm "RTN","IVMPTRNA",2,0) ;;2.0;INCOME VERIFICATION MATCH;**46,58,76,105**; 21-OCT-94;Build 2 "RTN","IVMPTRNA",3,0) Q "RTN","IVMPTRNA",4,0) NTROBX(DGNTARR) ; "RTN","IVMPTRNA",5,0) N NTRTEMP,I,CS,RS,SS "RTN","IVMPTRNA",6,0) I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&" "RTN","IVMPTRNA",7,0) I $G(HLFS)'="^" N HLFS S HLFS="^" "RTN","IVMPTRNA",8,0) S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2) "RTN","IVMPTRNA",9,0) S NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053" "RTN","IVMPTRNA",10,0) S NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053" "RTN","IVMPTRNA",11,0) S NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053" "RTN","IVMPTRNA",12,0) S NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053" "RTN","IVMPTRNA",13,0) S NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053" "RTN","IVMPTRNA",14,0) S NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053" "RTN","IVMPTRNA",15,0) S NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053" "RTN","IVMPTRNA",16,0) S NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053" "RTN","IVMPTRNA",17,0) S NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053" "RTN","IVMPTRNA",18,0) S NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052" "RTN","IVMPTRNA",19,0) S NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052" "RTN","IVMPTRNA",20,0) S NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052" "RTN","IVMPTRNA",21,0) S NTROBX(2)="CE",NTROBX(3)="VISTA"_CS_"28.11" "RTN","IVMPTRNA",22,0) S NTROBX(5)="" "RTN","IVMPTRNA",23,0) F I="NTR","AVI","SUB","HNC" D "RTN","IVMPTRNA",24,0) . I $G(DGNTARR(I))="" Q "RTN","IVMPTRNA",25,0) . I NTROBX(5)'="" S NTROBX(5)=$G(NTROBX(5))_RS "RTN","IVMPTRNA",26,0) . S NTROBX(5)=$G(NTROBX(5))_$G(NTRTEMP(I,$G(DGNTARR(I)))) "RTN","IVMPTRNA",27,0) S NTROBX(11)="F" "RTN","IVMPTRNA",28,0) S NTROBX(12)=$G(DGNTARR("HDT")) "RTN","IVMPTRNA",29,0) S NTROBX(14)=$G(DGNTARR("VDT")) "RTN","IVMPTRNA",30,0) I $G(DGNTARR("VSIT"))'="" D "RTN","IVMPTRNA",31,0) . S NTROBX(15)=$P($G(^DIC(4,DGNTARR("VSIT"),99)),"^") "RTN","IVMPTRNA",32,0) S NTROBX(16)="" "RTN","IVMPTRNA",33,0) I $G(DGNTARR("HSIT"))'="" D "RTN","IVMPTRNA",34,0) . S $P(NTROBX(16),CS,14)=SS_$P($G(^DIC(4,DGNTARR("HSIT"),99)),"^") "RTN","IVMPTRNA",35,0) I $G(DGNTARR("VER"))'="" S NTROBX(17)=$G(NTRTEMP("VER",$G(DGNTARR("VER")))) "RTN","IVMPTRNA",36,0) Q "RTN","IVMPTRNA",37,0) RF1(DFN,RF1TYP) ; create RF1 segment "RTN","IVMPTRNA",38,0) ; Input: "RTN","IVMPTRNA",39,0) ; DFN - Patient IEN "RTN","IVMPTRNA",40,0) ; RF1TYP - RF1 Type "RTN","IVMPTRNA",41,0) ; SAD = Street Address Change (Default) "RTN","IVMPTRNA",42,0) ; CAD = Confidential Address Change "RTN","IVMPTRNA",43,0) ; CPH = Cell Phone Number Change "RTN","IVMPTRNA",44,0) ; PNO = Pager Number Change "RTN","IVMPTRNA",45,0) ; EAD = E-Mail Address Change "RTN","IVMPTRNA",46,0) ; "RTN","IVMPTRNA",47,0) ; Output: RF1 segment "RTN","IVMPTRNA",48,0) ; "RTN","IVMPTRNA",49,0) N X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR "RTN","IVMPTRNA",50,0) I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&" "RTN","IVMPTRNA",51,0) I $G(HLFS)'="^" N HLFS S HLFS="^" "RTN","IVMPTRNA",52,0) S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2),HLQ="""" "RTN","IVMPTRNA",53,0) S:$G(RF1TYP)="" RF1TYP="SAD" ;Set type to 'SAD' if no value passed "RTN","IVMPTRNA",54,0) ; initialize the RETURN variable "RTN","IVMPTRNA",55,0) S RETURN="RF1",$P(RETURN,HLFS,4)=RF1TYP,$P(RETURN,HLFS,11)="" "RTN","IVMPTRNA",56,0) Q:'$G(DFN) RETURN "RTN","IVMPTRNA",57,0) ;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN "RTN","IVMPTRNA",58,0) D RF1LOAD(RF1TYP) Q:$D(ERR) RETURN "RTN","IVMPTRNA",59,0) I RF1TYP'="SAD",$G(ADRDT)="" Q "" "RTN","IVMPTRNA",60,0) ; RF1 SEQ 1-2 are not currently used "RTN","IVMPTRNA",61,0) ; RF1 SEQ 3 "RTN","IVMPTRNA",62,0) S $P(RETURN,HLFS,4)=RF1TYP "RTN","IVMPTRNA",63,0) ; RF1 SEQ 4-5 are not currently used "RTN","IVMPTRNA",64,0) ; RF1 SEQ 6 "RTN","IVMPTRNA",65,0) S $P(RETURN,HLFS,7)=$G(ADRSIT) "RTN","IVMPTRNA",66,0) S:$G(ADRSRC)'="" $P(RETURN,HLFS,7)=$P(RETURN,HLFS,7)_CS_ADRSRC "RTN","IVMPTRNA",67,0) ; RF1 SEQ 7 "RTN","IVMPTRNA",68,0) S $P(RETURN,HLFS,8)=$G(ADRDT) "RTN","IVMPTRNA",69,0) ; RF1 SEQ 8-11 are not currently used "RTN","IVMPTRNA",70,0) ; quit with completed RF1 segment "RTN","IVMPTRNA",71,0) Q RETURN "RTN","IVMPTRNA",72,0) ; "RTN","IVMPTRNA",73,0) ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format "RTN","IVMPTRNA",74,0) Q:$G(ADDRSRC)']"" "" "RTN","IVMPTRNA",75,0) Q:ADDRSRC="HEC" "USVAHEC" "RTN","IVMPTRNA",76,0) Q:ADDRSRC="VAMC" "USVAMC" "RTN","IVMPTRNA",77,0) Q:ADDRSRC="HBSC" "USVAHBSC" "RTN","IVMPTRNA",78,0) Q:ADDRSRC="NCOA" "USNCOA" "RTN","IVMPTRNA",79,0) Q:ADDRSRC="BVA" "USVABVA" "RTN","IVMPTRNA",80,0) Q:ADDRSRC="VAINS" "USVAINS" "RTN","IVMPTRNA",81,0) Q:ADDRSRC="USPS" "USPS" "RTN","IVMPTRNA",82,0) Q:ADDRSRC="LACS" "LACS" "RTN","IVMPTRNA",83,0) Q "" "RTN","IVMPTRNA",84,0) ; "RTN","IVMPTRNA",85,0) RF1LOAD(RF1TYP) ; "RTN","IVMPTRNA",86,0) N RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR "RTN","IVMPTRNA",87,0) K ADRDT,ADRSRC,ADRSIT "RTN","IVMPTRNA",88,0) I RF1TYP="SAD" S RFDT=.118,RFSRC=.119,RFSIT=.12 "RTN","IVMPTRNA",89,0) I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14113 "RTN","IVMPTRNA",90,0) I RF1TYP="CPH" S RFDT=.139,RFSRC=.1311,RFSIT=.13111 "RTN","IVMPTRNA",91,0) I RF1TYP="PNO" S RFDT=.1312,RFSRC=.1313,RFSIT=.1314 "RTN","IVMPTRNA",92,0) I RF1TYP="EAD" S RFDT=.136,RFSRC=.137,RFSIT=.138 "RTN","IVMPTRNA",93,0) S GETFLDS=RFDT S:RFSRC'="" GETFLDS=GETFLDS_";"_RFSRC S GETFLDS=GETFLDS_";"_RFSIT "RTN","IVMPTRNA",94,0) D GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR") Q:$D(ERR) "RTN","IVMPTRNA",95,0) S ADRDT=$$FMTHL7^XLFDT($G(RFDAT(2,DFN_",",RFDT,"I"))) "RTN","IVMPTRNA",96,0) S:RFSRC'="" ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$G(RFDAT(2,DFN_",",RFSRC,"I"))) "RTN","IVMPTRNA",97,0) ; only populate Change Site if Source=VAMC or NO Source Field "RTN","IVMPTRNA",98,0) I ($G(ADRSRC)="VAMC")!(RFSRC="") D "RTN","IVMPTRNA",99,0) . S ADRSIT=$G(RFDAT(2,DFN_",",RFSIT,"I")) "RTN","IVMPTRNA",100,0) . S:ADRSIT]"" ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99) "RTN","IVMPTRNA",101,0) S ADRSRC=$$ADDRCNV($G(ADRSRC)) ;convert source to HL7 format "RTN","IVMPTRNA",102,0) Q "RTN","IVMZ072") 0^23^B3473516 "RTN","IVMZ072",1,0) IVMZ072 ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE II ; 09/27/06 "RTN","IVMZ072",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMZ072",3,0) ; "RTN","IVMZ072",4,0) ; "RTN","IVMZ072",5,0) ; This routine supports the IVMZ07C consistency checker routines. "RTN","IVMZ072",6,0) LOADSD(DFN,DGSD) ; Load spouse & dependent data into array "RTN","IVMZ072",7,0) ; We will need to look at the Patient Relationship file to determine the spouse(s) and dependents for the patient "RTN","IVMZ072",8,0) ; from the Patient Relation file ^DGPR(408.12) This file will point to an IEN in the Income Person file. "RTN","IVMZ072",9,0) ; Next, we will load all of the spouse(s) and dependents from the Income Person file into the array. "RTN","IVMZ072",10,0) N NIEN,IEN,RIEN,NODE,I,ENODE "RTN","IVMZ072",11,0) ; look into Patient Relation file #408.12. Here we will find a pointer to each relation. And the record itself will "RTN","IVMZ072",12,0) ; contain a pointer into the INCOME PERSON file (#408.13) "RTN","IVMZ072",13,0) ; "RTN","IVMZ072",14,0) ;Global ^DGPR(408.12,,DFN "RTN","IVMZ072",15,0) ;^DGPR(408.12,"B",9999955601,3206)= "RTN","IVMZ072",16,0) ; 3210)= <<------| "RTN","IVMZ072",17,0) ; 3211)= | "RTN","IVMZ072",18,0) ; 3212)= | "RTN","IVMZ072",19,0) ; ] "RTN","IVMZ072",20,0) ;Global ^DGPR(408.12,3210 <<------------ "RTN","IVMZ072",21,0) ;^DGPR(408.12,3210,0)=9999955601^2^7170758;DGPR(408.13, "RTN","IVMZ072",22,0) ;^DGPR(408.12,3210,"E",0)=^408.1275D^1^1 | "RTN","IVMZ072",23,0) ;^DGPR(408.12,3210,"E",1,0)=2560406^1 | "RTN","IVMZ072",24,0) ;^DGPR(408.12,3210,"E","AID",-2560406,1)= | "RTN","IVMZ072",25,0) ;^DGPR(408.12,3210,"E","B",2560406,1)= | "RTN","IVMZ072",26,0) ; | "RTN","IVMZ072",27,0) ; | "RTN","IVMZ072",28,0) ;Global ^DGPR(408.13,7170758 <<-------------- "RTN","IVMZ072",29,0) ;^DGPR(408.13,7170758,0)=XXXXXX,XXXX SPOUSE^F^2560406^^^^^^174040656P^N "RTN","IVMZ072",30,0) ; 1)=XXXXX,XXXX^^^^^^^ "RTN","IVMZ072",31,0) ; "RTN","IVMZ072",32,0) I '$D(^DGPR(408.12,"B",DFN)) Q "RTN","IVMZ072",33,0) S NIEN="" F S NIEN=$O(^DGPR(408.12,"B",DFN,NIEN)) Q:NIEN="" D "RTN","IVMZ072",34,0) . S IEN=$P(^DGPR(408.12,NIEN,0),U,3) "RTN","IVMZ072",35,0) . ; an entry in DPT is the patient. we only need relations "RTN","IVMZ072",36,0) . Q:$P(IEN,";",2)["DPT" "RTN","IVMZ072",37,0) . Q:'$$ACTIF(NIEN,.ENODE) ;include only Active dependents "RTN","IVMZ072",38,0) . S RIEN=$P(IEN,";",1),NODE=$P(IEN,";",2) "RTN","IVMZ072",39,0) . S NODE=U_NODE,NODE=NODE_RIEN_")" "RTN","IVMZ072",40,0) . Q:'$D(@NODE) "RTN","IVMZ072",41,0) . S DGSD("DEP",RIEN,"EFF")=ENODE "RTN","IVMZ072",42,0) . S DGSD("DEP",RIEN)=$P(^DGPR(408.12,NIEN,0),U,2) "RTN","IVMZ072",43,0) . M DGSD("DEP",RIEN)=@NODE "RTN","IVMZ072",44,0) Q "RTN","IVMZ072",45,0) ; "RTN","IVMZ072",46,0) ACTIF(NIEN,ENODE) ;determine if record in ^DGPR(408.12) is currently active. If active, populate variable ENODE with Effective Date. "RTN","IVMZ072",47,0) ; This API should be called something like this I $$ACTIF^IVMZ072(NIEN,.ENODE)... "RTN","IVMZ072",48,0) ; Input: "RTN","IVMZ072",49,0) ; NIEN = IEN of ^DGPR(408.12) reference "RTN","IVMZ072",50,0) ; ENODE = Variable to contain Effective Date "RTN","IVMZ072",51,0) ; "RTN","IVMZ072",52,0) ; Populates: "RTN","IVMZ072",53,0) ; ENODE = With the most recent effective date of changes "RTN","IVMZ072",54,0) ; "RTN","IVMZ072",55,0) ; Returns: "RTN","IVMZ072",56,0) ; ACTIVE flag "RTN","IVMZ072",57,0) ; 1 = Active "RTN","IVMZ072",58,0) ; 0 = Inactive "RTN","IVMZ072",59,0) ; "RTN","IVMZ072",60,0) N ROOT,ACTDAT,INDEX,ACTIVE,EFF "RTN","IVMZ072",61,0) S ACTIVE=0 "RTN","IVMZ072",62,0) D Q ACTIVE "RTN","IVMZ072",63,0) . S ROOT=$O(^DGPR(408.12,NIEN,"E","AID","")) Q:ROOT="" "RTN","IVMZ072",64,0) . S INDEX=$O(^DGPR(408.12,NIEN,"E","AID",ROOT,"")) Q:INDEX="" "RTN","IVMZ072",65,0) . S ACTDAT=^DGPR(408.12,NIEN,"E",INDEX,0) "RTN","IVMZ072",66,0) . S ACTIVE=$P(ACTDAT,"^",2),ENODE=$P(ACTDAT,"^",1) "RTN","IVMZ072",67,0) Q ACTIVE "RTN","IVMZ072",68,0) ; "RTN","IVMZ07C") 0^4^B18729103 "RTN","IVMZ07C",1,0) IVMZ07C ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 9/27/2006 "RTN","IVMZ07C",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMZ07C",3,0) ; "RTN","IVMZ07C",4,0) ; "RTN","IVMZ07C",5,0) ; This routine calls various checking subroutines and manages arrays and data filing "RTN","IVMZ07C",6,0) ; for inconsistency checking prior to building a Z07 HL7 record. This routine returns "RTN","IVMZ07C",7,0) ; a value and must be called as an API: "RTN","IVMZ07C",8,0) ; "RTN","IVMZ07C",9,0) ; I '$$EN^IVMZ07C(DFN) Q "RTN","IVMZ07C",10,0) ; "RTN","IVMZ07C",11,0) ; Values returned: "RTN","IVMZ07C",12,0) ; 0 = Fail: inconsistencies found, do not build Z07 record "RTN","IVMZ07C",13,0) ; 1 = Pass: No inconsistencies found, Ok to build Z07 record "RTN","IVMZ07C",14,0) ; "RTN","IVMZ07C",15,0) ; Must be called from entry point "RTN","IVMZ07C",16,0) Q "RTN","IVMZ07C",17,0) ; "RTN","IVMZ07C",18,0) EN(DFN) ; entry point. Patient DFN is sent from calling routine. "RTN","IVMZ07C",19,0) ; initialize working variables "RTN","IVMZ07C",20,0) N PASS,DGP,DGSD,U "RTN","IVMZ07C",21,0) S U="^" "RTN","IVMZ07C",22,0) ; "RTN","IVMZ07C",23,0) ; Input: DFN = ^DPT(DFN) of record to check "RTN","IVMZ07C",24,0) ; BATCH = 1 batch/background job records should be counted "RTN","IVMZ07C",25,0) ; = 0 single job, do not count records "RTN","IVMZ07C",26,0) ; structure: "RTN","IVMZ07C",27,0) ; 1. delete existing Z07 inconsistencies "RTN","IVMZ07C",28,0) ; 2. load data arrays "RTN","IVMZ07C",29,0) ; 3. call subroutines "RTN","IVMZ07C",30,0) ; 4. check for Pass/Fail "RTN","IVMZ07C",31,0) ; 5. update file 38.5 if necessary "RTN","IVMZ07C",32,0) ; 6. return Pass/Fail "RTN","IVMZ07C",33,0) ; "RTN","IVMZ07C",34,0) ; Set flag "RTN","IVMZ07C",35,0) S PASS=0 "RTN","IVMZ07C",36,0) I '$D(^DPT(DFN)) Q PASS "RTN","IVMZ07C",37,0) S PASS=1 "RTN","IVMZ07C",38,0) ; "RTN","IVMZ07C",39,0) ; Load Patient and Spouse/dependent data "RTN","IVMZ07C",40,0) D LOADPT(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD) "RTN","IVMZ07C",41,0) ; "RTN","IVMZ07C",42,0) ; Do checks and file inconsistencies "RTN","IVMZ07C",43,0) D WORK(DFN,.DGP,.DGSD) "RTN","IVMZ07C",44,0) ; "RTN","IVMZ07C",45,0) ; Delete old Inconsistency info "RTN","IVMZ07C",46,0) D DELETE(DFN) "RTN","IVMZ07C",47,0) ; "RTN","IVMZ07C",48,0) ; File new inconsistencies if necessary "RTN","IVMZ07C",49,0) I $$FILE(DFN) S PASS=0 "RTN","IVMZ07C",50,0) ; "RTN","IVMZ07C",51,0) ; update counters "RTN","IVMZ07C",52,0) D COUNT(PASS) "RTN","IVMZ07C",53,0) ; "RTN","IVMZ07C",54,0) ; return pass/fail flag "RTN","IVMZ07C",55,0) Q PASS "RTN","IVMZ07C",56,0) ; "RTN","IVMZ07C",57,0) COUNT(PASS) ; counter for batch run "RTN","IVMZ07C",58,0) N I "RTN","IVMZ07C",59,0) ; Set it up the first time through "RTN","IVMZ07C",60,0) I '$D(^TMP($J,"CC")) D "RTN","IVMZ07C",61,0) . F I=0,1 S ^TMP($J,"CC",I)=0 "RTN","IVMZ07C",62,0) ; "RTN","IVMZ07C",63,0) ; Increment Batch counter "RTN","IVMZ07C",64,0) S ^TMP($J,"CC",PASS)=^TMP($J,"CC",PASS)+1 "RTN","IVMZ07C",65,0) Q "RTN","IVMZ07C",66,0) ; "RTN","IVMZ07C",67,0) LOADPT(DFN,DGP) ; load patient data into arrays "RTN","IVMZ07C",68,0) N NIEN,IEN,I,DTTM,NAMCOM,NAME "RTN","IVMZ07C",69,0) ; we need to load data from the following files "RTN","IVMZ07C",70,0) ; Patient File 2 "RTN","IVMZ07C",71,0) ; Name Components 20 "RTN","IVMZ07C",72,0) ; Patient Enrollment 27.11 "RTN","IVMZ07C",73,0) ; Means test file 408.31 "RTN","IVMZ07C",74,0) ; MST History file 29.11 "RTN","IVMZ07C",75,0) ; Note: we also need Catastrophic data info, but that subroutine loads its own data array. "RTN","IVMZ07C",76,0) ; "RTN","IVMZ07C",77,0) ; *************************** "RTN","IVMZ07C",78,0) ; DGP("PAT") Patient file "RTN","IVMZ07C",79,0) F I=0,.3,.15,.29,.31,.32,.321,.322,.35,.36,.361,.38,.52,"SSN","TYPE","VET" S DGP("PAT",I)=$G(^DPT(DFN,I)) "RTN","IVMZ07C",80,0) S NAME=$P($G(^DPT(DFN,0)),"^",1),NAMCOM=$P($G(^DPT(DFN,"NAME")),"^",1)'="" "RTN","IVMZ07C",81,0) ; "RTN","IVMZ07C",82,0) ; *************************** "RTN","IVMZ07C",83,0) ; DGP("NAME") Name Components "RTN","IVMZ07C",84,0) I NAMCOM S NIEN=$P(^DPT(DFN,"NAME"),U,1) I '$D(^VA(20,NIEN,1)) S NAMCOM=0 "RTN","IVMZ07C",85,0) S DGP("NAME",1)=$S(NAMCOM:$G(^VA(20,NIEN,1)),1:$P(NAME,",")_"^"_$P($P(NAME,",",2)," ",1)_"^"_$P($P(NAME,",",2)," ",2)) "RTN","IVMZ07C",86,0) ; "RTN","IVMZ07C",87,0) ; *************************** "RTN","IVMZ07C",88,0) ; "RTN","IVMZ07C",89,0) ; DGP("ENR") Patient Enrollment "RTN","IVMZ07C",90,0) S NIEN="",NIEN=$P($G(^DPT(DFN,"ENR")),U,1) "RTN","IVMZ07C",91,0) I NIEN]"",$D(^DGEN(27.11,NIEN)) M DGP("ENR")=^DGEN(27.11,NIEN) "RTN","IVMZ07C",92,0) ; "RTN","IVMZ07C",93,0) ; *************************** "RTN","IVMZ07C",94,0) ; DGP("MEANS") Means Test "RTN","IVMZ07C",95,0) S NIEN=+$$LST^DGMTU(DFN) I NIEN,$D(^DGMT(408.31,NIEN,0)) S DGP("MEANS",0)=^DGMT(408.31,NIEN,0) "RTN","IVMZ07C",96,0) ; "RTN","IVMZ07C",97,0) ; *************************** "RTN","IVMZ07C",98,0) ; DGP("MST") MST History "RTN","IVMZ07C",99,0) S (DTTM,NIEN)="" "RTN","IVMZ07C",100,0) S DTTM=$O(^DGMS(29.11,"APDT",DFN,""),-1) "RTN","IVMZ07C",101,0) I DTTM'="" D "RTN","IVMZ07C",102,0) . S DTTM=$O(^DGMS(29.11,"APDT",DFN,"")) "RTN","IVMZ07C",103,0) . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,"")) "RTN","IVMZ07C",104,0) . I $D(^DGMS(29.11,NIEN,0)) S DGP("MST",0)=^DGMS(29.11,NIEN,0) "RTN","IVMZ07C",105,0) ; "RTN","IVMZ07C",106,0) ; *************************** "RTN","IVMZ07C",107,0) Q "RTN","IVMZ07C",108,0) ; "RTN","IVMZ07C",109,0) WORK(DFN,DGP,DGSD) ; "RTN","IVMZ07C",110,0) ; call subroutines to run rules and file any inconsistencies "RTN","IVMZ07C",111,0) ; "RTN","IVMZ07C",112,0) ; Demographics rules "RTN","IVMZ07C",113,0) D EN^IVMZ7CD(DFN,.DGP,.DGSD) "RTN","IVMZ07C",114,0) ; "RTN","IVMZ07C",115,0) ; Enrollment/Eligibility rules "RTN","IVMZ07C",116,0) D EN^IVMZ7CE(DFN,.DGP) "RTN","IVMZ07C",117,0) ; "RTN","IVMZ07C",118,0) ; Service rules "RTN","IVMZ07C",119,0) D EN^IVMZ7CS(DFN,.DGP) "RTN","IVMZ07C",120,0) ; "RTN","IVMZ07C",121,0) ; Catastrophic Disability rules "RTN","IVMZ07C",122,0) D EN^IVMZ7CCD(DFN) "RTN","IVMZ07C",123,0) ; "RTN","IVMZ07C",124,0) ; Registration Inconsistencies "RTN","IVMZ07C",125,0) D EN^IVMZ7CR(DFN,.DGP,.DGSD) "RTN","IVMZ07C",126,0) ; "RTN","IVMZ07C",127,0) Q "RTN","IVMZ07C",128,0) ; "RTN","IVMZ07C",129,0) DELETE(DFN) ; delete all Z07 inconsistencies from INCONSISTENT DATA file (#38.5). Since we're not sure which rules "RTN","IVMZ07C",130,0) ; will block a Z07 record, we need to loop through the INCONSISTENT DATA ELEMENTS file (#38.6) and grab only "RTN","IVMZ07C",131,0) ; those rules which are marked to prevent building a Z07 record: "RTN","IVMZ07C",132,0) ; "RTN","IVMZ07C",133,0) ; "RTN","IVMZ07C",134,0) N DELARRY,RULE,DIK,DA "RTN","IVMZ07C",135,0) ; "RTN","IVMZ07C",136,0) ; create an array of rules which prevent Z07 records "RTN","IVMZ07C",137,0) S RULE=0 F S RULE=$O(^DGIN(38.6,RULE)) Q:RULE="" Q:$A(RULE)>$A(9) D "RTN","IVMZ07C",138,0) . I '$P(^DGIN(38.6,RULE,0),U,5),$P(^DGIN(38.6,RULE,0),U,6) S DELARRY(RULE)="" "RTN","IVMZ07C",139,0) ; "RTN","IVMZ07C",140,0) ; Now we have to check the patient INCONSISTENT DATA file (#38.5) and delete any records which have to be rechecked. "RTN","IVMZ07C",141,0) ; "RTN","IVMZ07C",142,0) S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," "RTN","IVMZ07C",143,0) ; "RTN","IVMZ07C",144,0) S DA="" F S DA=$O(DELARRY(DA)) Q:DA="" D ^DIK "RTN","IVMZ07C",145,0) Q "RTN","IVMZ07C",146,0) ; "RTN","IVMZ07C",147,0) FILE(DFN) ; "RTN","IVMZ07C",148,0) N FILE,SUCCESS,CCS,I,DGENDA,DATA,SUBFILE,DIK,DA "RTN","IVMZ07C",149,0) S FILE=38.5,CCS=0 "RTN","IVMZ07C",150,0) ; if no inconsistencies, return 0 "RTN","IVMZ07C",151,0) I '$D(^TMP($J,DFN)) D Q CCS "RTN","IVMZ07C",152,0) . ; clean up INCONSISTENT DATA file if no inconsistencies exist "RTN","IVMZ07C",153,0) . I '$P($G(^DGIN(38.5,DFN,"I",0)),"^",4) D "RTN","IVMZ07C",154,0) . . S DIK="^DGIN(38.5,",DA=DFN "RTN","IVMZ07C",155,0) . . D ^DIK "RTN","IVMZ07C",156,0) ; "RTN","IVMZ07C",157,0) ; else process inconsistencies and return PASS=0 "RTN","IVMZ07C",158,0) S CCS=1 "RTN","IVMZ07C",159,0) ; if a new entry, create a stub "RTN","IVMZ07C",160,0) S DATA(.01)=DFN "RTN","IVMZ07C",161,0) I '$D(^DGIN(FILE,"B",DFN)) D "RTN","IVMZ07C",162,0) . S DATA(2)=$$DT^XLFDT,DATA(3)=.5 "RTN","IVMZ07C",163,0) . S SUCCESS=$$ADD^DGENDBS(FILE,,.DATA,,DFN) "RTN","IVMZ07C",164,0) ; "RTN","IVMZ07C",165,0) ; update file header with data and user info. "RTN","IVMZ07C",166,0) ; Last Updated field (#4) = Today's date "RTN","IVMZ07C",167,0) ; Last Updated by field (#5) = Postmaster "RTN","IVMZ07C",168,0) S DGENDA=DFN,DATA(4)=$$DT^XLFDT,DATA(5)=.5 "RTN","IVMZ07C",169,0) S SUCCESS=$$UPD^DGENDBS(FILE,.DGENDA,.DATA) "RTN","IVMZ07C",170,0) ; "RTN","IVMZ07C",171,0) ; add inconsistencies to file "RTN","IVMZ07C",172,0) K DATA "RTN","IVMZ07C",173,0) S SUBFILE=38.51,DGENDA(1)=DFN "RTN","IVMZ07C",174,0) S I="" F S I=$O(^TMP($J,DFN,I)) Q:I="" D "RTN","IVMZ07C",175,0) . S (DATA(.01),DATA(.001),DGENDA)=I "RTN","IVMZ07C",176,0) . S SUCCESS=$$ADD^DGENDBS(SUBFILE,.DGENDA,.DATA) "RTN","IVMZ07C",177,0) ; "RTN","IVMZ07C",178,0) ; kill temp file before exit "RTN","IVMZ07C",179,0) K ^TMP($J,DFN) "RTN","IVMZ07C",180,0) ; "RTN","IVMZ07C",181,0) Q CCS "RTN","IVMZ07C",182,0) ; "RTN","IVMZ7CCD") 0^6^B26088689 "RTN","IVMZ7CCD",1,0) IVMZ7CCD ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- CATASTROPHIC DISABILITY SUBROUTINE ; 11/9/05 9:30am "RTN","IVMZ7CCD",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMZ7CCD",3,0) ; "RTN","IVMZ7CCD",4,0) ; Catastrophic Disability Consistency Checks "RTN","IVMZ7CCD",5,0) ; This routine checks the various elements of catastrophic disability information "RTN","IVMZ7CCD",6,0) ; prior to building a Z07 record. Any tests which fail consistency check will be "RTN","IVMZ7CCD",7,0) ; saved to the ^DGIN(38.6 record for the patient. "RTN","IVMZ7CCD",8,0) ; "RTN","IVMZ7CCD",9,0) ; "RTN","IVMZ7CCD",10,0) ; Must be called from entry point "RTN","IVMZ7CCD",11,0) Q "RTN","IVMZ7CCD",12,0) ; "RTN","IVMZ7CCD",13,0) EN(DFN) ; entry point. Patient DFN is sent from calling routine. "RTN","IVMZ7CCD",14,0) ; initialize working variables "RTN","IVMZ7CCD",15,0) N RULE,Y,DGCDIS,PASS,FILERR "RTN","IVMZ7CCD",16,0) ; patient array DGCDIS can be populated by a call to $$GET^DGENCDA(DFN,.DGCDIS) as follows: "RTN","IVMZ7CCD",17,0) ; "RTN","IVMZ7CCD",18,0) ; S PASS=$$GET^DGENCDA(DFN,.DGCDIS) "RTN","IVMZ7CCD",19,0) ; "RTN","IVMZ7CCD",20,0) ; and creates an array similar to this: "RTN","IVMZ7CCD",21,0) ; DGCDIS("BY")="DR. JOHN" "RTN","IVMZ7CCD",22,0) ; DGCDIS("COND",1)="48" "RTN","IVMZ7CCD",23,0) ; DGCDIS("DATE")="3050926" "RTN","IVMZ7CCD",24,0) ; DGCDIS("DIAG",1)="8" "RTN","IVMZ7CCD",25,0) ; DGCDIS("DTFACIRV")="" "RTN","IVMZ7CCD",26,0) ; DGCDIS("DTVETNOT")="" "RTN","IVMZ7CCD",27,0) ; DGCDIS("FACDET")="16660" "RTN","IVMZ7CCD",28,0) ; DGCDIS("METDET")="3" "RTN","IVMZ7CCD",29,0) ; DGCDIS("PERM",1)="1" "RTN","IVMZ7CCD",30,0) ; DGCDIS("REVDTE")="3050926" "RTN","IVMZ7CCD",31,0) ; DGCDIS("SCORE",1)="6" "RTN","IVMZ7CCD",32,0) ; DGCDIS("VCD")="Y" "RTN","IVMZ7CCD",33,0) ; DGCDIS("VETREQDT")="" "RTN","IVMZ7CCD",34,0) ; "RTN","IVMZ7CCD",35,0) ; if the patient has no CD data on file, the API will return the following: "RTN","IVMZ7CCD",36,0) ; DGCDIS="" "RTN","IVMZ7CCD",37,0) ; DGCDIS("BY")="" "RTN","IVMZ7CCD",38,0) ; DGCDIS("DATE")="" "RTN","IVMZ7CCD",39,0) ; DGCDIS("DTFACIRV")="" "RTN","IVMZ7CCD",40,0) ; DGCDIS("DTVETNOT")="" "RTN","IVMZ7CCD",41,0) ; DGCDIS("FACDET")="" "RTN","IVMZ7CCD",42,0) ; DGCDIS("METDET")="" "RTN","IVMZ7CCD",43,0) ; DGCDIS("REVDTE")="" "RTN","IVMZ7CCD",44,0) ; DGCDIS("VCD")="" "RTN","IVMZ7CCD",45,0) ; DGCDIS("VETREQDT")="" "RTN","IVMZ7CCD",46,0) ; "RTN","IVMZ7CCD",47,0) S PASS=$$GET^DGENCDA(DFN,.DGCDIS) "RTN","IVMZ7CCD",48,0) ; "RTN","IVMZ7CCD",49,0) ; In cases where patient is not listed as catastrophically disabled, routine should check to see if patient could potentially "RTN","IVMZ7CCD",50,0) ; qualify for CD. If patient qualifies and is not listed as CD, an inconsistency should be filed. Otherwise continue. "RTN","IVMZ7CCD",51,0) ; If patient is not listed as CD, regardless of potential, further checks are not necessary as the rest depend on CD="YES" "RTN","IVMZ7CCD",52,0) ; "RTN","IVMZ7CCD",53,0) I '$$CD(DGCDIS("VCD")="Y") D Q "RTN","IVMZ7CCD",54,0) . I $D(FILERR) D FILE "RTN","IVMZ7CCD",55,0) ; "RTN","IVMZ7CCD",56,0) ; loop through rules in INCONSISTENT DATA ELEMENTS file. "RTN","IVMZ7CCD",57,0) ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 CHECKS fields are turned ON. "RTN","IVMZ7CCD",58,0) ; "RTN","IVMZ7CCD",59,0) ; ***NOTE loop boundary (701-726) must be changed if rule numbers are added *** "RTN","IVMZ7CCD",60,0) F RULE=701:1:726 I $D(^DGIN(38.6,RULE)) D "RTN","IVMZ7CCD",61,0) . S Y=^DGIN(38.6,RULE,0) "RTN","IVMZ7CCD",62,0) . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE "RTN","IVMZ7CCD",63,0) I $D(FILERR) D FILE "RTN","IVMZ7CCD",64,0) Q "RTN","IVMZ7CCD",65,0) ; "RTN","IVMZ7CCD",66,0) CD(VCD) ; Is Patient Catastrophically disabled? If not, we need to examine patient's record to see if qualified for CD "RTN","IVMZ7CCD",67,0) ; Whether qualified or not, if patient is listed as NOT CD, the rest of the rules should not be checked. Therefore, "RTN","IVMZ7CCD",68,0) ; if DGCDIS("VCD") does not = "Y" system will exit after this rule without checking any further. "RTN","IVMZ7CCD",69,0) I VCD Q 1 "RTN","IVMZ7CCD",70,0) I $$ISCD^DGENCDA1(.DGCDIS) S FILERR(720)="" "RTN","IVMZ7CCD",71,0) Q 0 "RTN","IVMZ7CCD",72,0) ; "RTN","IVMZ7CCD",73,0) 701 ;Catastrophic Disability 'Decided By' Cannot be 'HINQ' "RTN","IVMZ7CCD",74,0) I $G(DGCDIS("BY"))="HINQ" S FILERR(RULE)="" "RTN","IVMZ7CCD",75,0) Q "RTN","IVMZ7CCD",76,0) ; "RTN","IVMZ7CCD",77,0) 702 ;Catastrophic Disability 'Decided By' not valid "RTN","IVMZ7CCD",78,0) I ($L(DGCDIS("BY"))<3)!($L(DGCDIS("BY"))>35) S FILERR(RULE)="" "RTN","IVMZ7CCD",79,0) Q "RTN","IVMZ7CCD",80,0) 703 ;"Catastrophic Disability 'Decided By' required" "RTN","IVMZ7CCD",81,0) I $G(DGCDIS("BY"))="" S FILERR(RULE)="" "RTN","IVMZ7CCD",82,0) Q "RTN","IVMZ7CCD",83,0) ; "RTN","IVMZ7CCD",84,0) 704 ;"Catastrophic Disability Review Date Required" "RTN","IVMZ7CCD",85,0) I $G(DGCDIS("REVDTE"))="" S FILERR(RULE)="" "RTN","IVMZ7CCD",86,0) Q "RTN","IVMZ7CCD",87,0) ; "RTN","IVMZ7CCD",88,0) 705 ;"Catastrophic Disability Review Date Invalid" "RTN","IVMZ7CCD",89,0) N RESULT "RTN","IVMZ7CCD",90,0) D CHK^DIE(2,.394,,DGCDIS("REVDTE"),.RESULT) "RTN","IVMZ7CCD",91,0) I RESULT="^" S FILERR(RULE)="" "RTN","IVMZ7CCD",92,0) Q "RTN","IVMZ7CCD",93,0) ; "RTN","IVMZ7CCD",94,0) 706 ;"CD Condition Score not valid" "RTN","IVMZ7CCD",95,0) N ITEM,ERR "RTN","IVMZ7CCD",96,0) S ITEM="",ERR=0 "RTN","IVMZ7CCD",97,0) F S ITEM=$O(DGCDIS("COND",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",98,0) . I '$$VALID^DGENA5(DGCDIS("COND",ITEM),$G(DGCDIS("SCORE",ITEM))) S ERR=1 "RTN","IVMZ7CCD",99,0) I ERR S FILERR(RULE)="" "RTN","IVMZ7CCD",100,0) Q "RTN","IVMZ7CCD",101,0) ; "RTN","IVMZ7CCD",102,0) 707 ;"CD Review Date greater than CD Date of Determination" "RTN","IVMZ7CCD",103,0) I $G(DGCDIS("REVDTE"))>$G(DGCDIS("DATE")) S FILERR(RULE)="" "RTN","IVMZ7CCD",104,0) Q "RTN","IVMZ7CCD",105,0) ; "RTN","IVMZ7CCD",106,0) 708 ;"CD Status Affected Extremity' Invalid" "RTN","IVMZ7CCD",107,0) N ITEM,EIEN,ERR "RTN","IVMZ7CCD",108,0) S ITEM="",ERR=0 "RTN","IVMZ7CCD",109,0) F S ITEM=$O(DGCDIS("PROC",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",110,0) . S EIEN="" F S EIEN=$O(DGCDIS("EXT",ITEM,EIEN)) Q:EIEN="" D "RTN","IVMZ7CCD",111,0) . . I '$$LIMBOK^DGENA5(DGCDIS("PROC",ITEM),DGCDIS("EXT",ITEM,EIEN)) S ERR=1 "RTN","IVMZ7CCD",112,0) I ERR S FILERR(RULE)="" "RTN","IVMZ7CCD",113,0) Q "RTN","IVMZ7CCD",114,0) ; "RTN","IVMZ7CCD",115,0) 709 ;"CD Status Diagnoses' Not Valid" "RTN","IVMZ7CCD",116,0) ; .396 CD STATUS DIAGNOSES field (multiple): "RTN","IVMZ7CCD",117,0) N ITEM,ERR "RTN","IVMZ7CCD",118,0) S ITEM="",ERR=0 "RTN","IVMZ7CCD",119,0) F S ITEM=$O(DGCDIS("DIAG",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",120,0) . I $$TYPE^DGENA5(DGCDIS("DIAG",ITEM))'="D" S ERR=1 "RTN","IVMZ7CCD",121,0) I ERR S FILERR(RULE)="" "RTN","IVMZ7CCD",122,0) Q "RTN","IVMZ7CCD",123,0) ; "RTN","IVMZ7CCD",124,0) 710 ;"'CD Status Procedure' Not Valid" "RTN","IVMZ7CCD",125,0) ; .397 CD STATUS PROCEDURES field (multiple): "RTN","IVMZ7CCD",126,0) N ITEM,ERR "RTN","IVMZ7CCD",127,0) S ITEM="",ERR=0 "RTN","IVMZ7CCD",128,0) F S ITEM=$O(DGCDIS("PROC",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",129,0) . I $$TYPE^DGENA5(DGCDIS("PROC",ITEM))'="P" S ERR=1 "RTN","IVMZ7CCD",130,0) I ERR S FILERR(RULE)="" "RTN","IVMZ7CCD",131,0) Q "RTN","IVMZ7CCD",132,0) ; "RTN","IVMZ7CCD",133,0) 711 ;"'CD Status Reason' Not Present" "RTN","IVMZ7CCD",134,0) I '($D(DGCDIS("DIAG"))!$D(DGCDIS("PROC"))!$D(DGCDIS("COND"))) S FILERR(RULE)="" "RTN","IVMZ7CCD",135,0) Q "RTN","IVMZ7CCD",136,0) ; "RTN","IVMZ7CCD",137,0) 712 ;"'Date Of Catastophic Disability Decision' Not Valid" "RTN","IVMZ7CCD",138,0) N RESULT,OK,EXTERNAL "RTN","IVMZ7CCD",139,0) S OK=0 "RTN","IVMZ7CCD",140,0) I $G(DGCDIS("DATE"))'="" S OK=1 D "RTN","IVMZ7CCD",141,0) . S EXTERNAL=$$EXTERNAL^DILFD(2,.392,"",DGCDIS("DATE")) "RTN","IVMZ7CCD",142,0) . I EXTERNAL="" S OK=0 Q "RTN","IVMZ7CCD",143,0) . D CHK^DIE(2,.392,,EXTERNAL,.RESULT) I RESULT="^" S OK=0 "RTN","IVMZ7CCD",144,0) I 'OK S FILERR(RULE)="" "RTN","IVMZ7CCD",145,0) Q "RTN","IVMZ7CCD",146,0) ; "RTN","IVMZ7CCD",147,0) 713 ;"'Date Of Catastophic Disability Decision' Required" "RTN","IVMZ7CCD",148,0) I $G(DGCDIS("DATE"))="" S FILERR(RULE)="" "RTN","IVMZ7CCD",149,0) Q "RTN","IVMZ7CCD",150,0) ; "RTN","IVMZ7CCD",151,0) 714 ;"'Facility Making Catastrophic Disability Determination' Not Valid" "RTN","IVMZ7CCD",152,0) I DGCDIS("VCD")'=""!(DGCDIS("FACDET")'=""),$$EXTERNAL^DILFD(2,.393,"",$G(DGCDIS("FACDET")))="" S FILERR(RULE)="" "RTN","IVMZ7CCD",153,0) Q "RTN","IVMZ7CCD",154,0) ; "RTN","IVMZ7CCD",155,0) 715 ;"'Method Of Determination' Is A Required Value" "RTN","IVMZ7CCD",156,0) I $G(DGCDIS("METDET"))="" S FILERR(RULE)="" "RTN","IVMZ7CCD",157,0) Q "RTN","IVMZ7CCD",158,0) ; "RTN","IVMZ7CCD",159,0) 716 ;"'Method Of Determination' Not Valid" "RTN","IVMZ7CCD",160,0) I ".2.3."'[("."_$G(DGCDIS("METDET"))_".") S FILERR(RULE)="" "RTN","IVMZ7CCD",161,0) Q "RTN","IVMZ7CCD",162,0) ; "RTN","IVMZ7CCD",163,0) 717 ;"Not Enough Diagnoses/Procedures/Conditions To Qualify For CD Status" "RTN","IVMZ7CCD",164,0) I '$$ISCD^DGENCDA1(.DGCDIS) S FILERR(RULE)="" "RTN","IVMZ7CCD",165,0) Q "RTN","IVMZ7CCD",166,0) ; "RTN","IVMZ7CCD",167,0) 718 ;"Permanent Status Indicator' Not Valid" "RTN","IVMZ7CCD",168,0) N ITEM "RTN","IVMZ7CCD",169,0) S ITEM="" F S ITEM=$O(DGCDIS("COND",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",170,0) . I ".1.2.3."'[("."_DGCDIS("PERM",ITEM)_".") S FILERR(RULE)="" "RTN","IVMZ7CCD",171,0) Q "RTN","IVMZ7CCD",172,0) ; "RTN","IVMZ7CCD",173,0) 719 ;"'Veteran Catastrophically Disabled?' Field Must Have A Response" "RTN","IVMZ7CCD",174,0) ; .39 VETERAN CATASTROPHICALLY DISABLED? field. "RTN","IVMZ7CCD",175,0) I DGCDIS("VCD")="" S FILERR(RULE)="" "RTN","IVMZ7CCD",176,0) Q "RTN","IVMZ7CCD",177,0) ; "RTN","IVMZ7CCD",178,0) 720 ;"Veteran Has Enough Diagnoses/Procedures/Conditions To Qualify For CD Status" "RTN","IVMZ7CCD",179,0) ; We check this rule at the beginning of the routine. No need to check it here, "RTN","IVMZ7CCD",180,0) ; but we need the label as a place holder. "RTN","IVMZ7CCD",181,0) Q "RTN","IVMZ7CCD",182,0) ; "RTN","IVMZ7CCD",183,0) 723 ;"Catastrophic Disability Review date must be a precise date" "RTN","IVMZ7CCD",184,0) N RESULT "RTN","IVMZ7CCD",185,0) D CHK^DIE(2,.394,,DGCDIS("REVDTE"),.RESULT) "RTN","IVMZ7CCD",186,0) I RESULT="^" S FILERR(RULE)="" "RTN","IVMZ7CCD",187,0) Q "RTN","IVMZ7CCD",188,0) ; "RTN","IVMZ7CCD",189,0) 724 ;"Catastrophic Disability Date of Decision must be a precise date" "RTN","IVMZ7CCD",190,0) N RESULT "RTN","IVMZ7CCD",191,0) D CHK^DIE(2,.392,,DGCDIS("DATE"),.RESULT) "RTN","IVMZ7CCD",192,0) I RESULT="^" S FILERR(RULE)="" "RTN","IVMZ7CCD",193,0) Q "RTN","IVMZ7CCD",194,0) ; "RTN","IVMZ7CCD",195,0) 725 ;"Catastrophic Disability Procedure code must be accompanied with an Affected Extremity field" "RTN","IVMZ7CCD",196,0) ; Procedure list = DGCDIS("PROC",ITEM) "RTN","IVMZ7CCD",197,0) ; Affected Extremity list = DGCDIS("EXT",ITEM) "RTN","IVMZ7CCD",198,0) ; This tag makes sure that there is at least one Affected Extremity for each procedure code. "RTN","IVMZ7CCD",199,0) N ITEM,ERR "RTN","IVMZ7CCD",200,0) S ERR=0,ITEM="" "RTN","IVMZ7CCD",201,0) F S ITEM=$O(DGCDIS("PROC",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",202,0) . I '$D(DGCDIS("EXT",ITEM)) S ERR=1 Q "RTN","IVMZ7CCD",203,0) . I $G(DGCDIS("EXT",ITEM))="" S ERR=1 "RTN","IVMZ7CCD",204,0) I ERR S FILERR(RULE)="" "RTN","IVMZ7CCD",205,0) Q "RTN","IVMZ7CCD",206,0) ; "RTN","IVMZ7CCD",207,0) 726 ;"Catastrophic Disablity condition code requires a Score field" "RTN","IVMZ7CCD",208,0) ; Condition list = DGCDIS("COND",ITEM) "RTN","IVMZ7CCD",209,0) ; Score list = DGCDIS("SCORE",ITEM) "RTN","IVMZ7CCD",210,0) N ITEM,ERR "RTN","IVMZ7CCD",211,0) S ERR=0,ITEM="" "RTN","IVMZ7CCD",212,0) F S ITEM=$O(DGCDIS("COND",ITEM)) Q:ITEM="" D "RTN","IVMZ7CCD",213,0) . I '$D(DGCDIS("SCORE",ITEM)) S ERR=1 Q "RTN","IVMZ7CCD",214,0) . I $G(DGCDIS("SCORE",ITEM))="" S ERR=1 "RTN","IVMZ7CCD",215,0) I ERR S FILERR(RULE)="" "RTN","IVMZ7CCD",216,0) Q "RTN","IVMZ7CCD",217,0) ; "RTN","IVMZ7CCD",218,0) FILE ;file the inconsistencies in a temp global "RTN","IVMZ7CCD",219,0) M ^TMP($J,DFN)=FILERR "RTN","IVMZ7CCD",220,0) Q "RTN","IVMZ7CCD",221,0) ; "RTN","IVMZ7CD") 0^15^B18262093 "RTN","IVMZ7CD",1,0) IVMZ7CD ;CKN,BAJ - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006 "RTN","IVMZ7CD",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMZ7CD",3,0) ; "RTN","IVMZ7CD",4,0) ; Demographic Consistency Checks "RTN","IVMZ7CD",5,0) ; This routine will be called from driver routine and it checks the "RTN","IVMZ7CD",6,0) ; various elements of Person demographic information prior to "RTN","IVMZ7CD",7,0) ; building a Z07 record. Any test which fails consistency check will "RTN","IVMZ7CD",8,0) ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person. "RTN","IVMZ7CD",9,0) ; "RTN","IVMZ7CD",10,0) ;It is all facade "RTN","IVMZ7CD",11,0) Q "RTN","IVMZ7CD",12,0) ; "RTN","IVMZ7CD",13,0) EN(DFN,DGP,DGSD) ;Entry point "RTN","IVMZ7CD",14,0) ; input: DFN - Patient IEN "RTN","IVMZ7CD",15,0) ; DGP - Patient data array "RTN","IVMZ7CD",16,0) ; DGSD - Spouse and Dependent data array "RTN","IVMZ7CD",17,0) ; output: ^TMP($J,DFN,RULE) global "RTN","IVMZ7CD",18,0) ; DFN - Patient IEN "RTN","IVMZ7CD",19,0) ; RULE - Consistency rule # "RTN","IVMZ7CD",20,0) ;initializing variables "RTN","IVMZ7CD",21,0) N RULE,Y,X,FILERR "RTN","IVMZ7CD",22,0) ; "RTN","IVMZ7CD",23,0) ; loop through rules in INCONSISTENT DATA ELEMENTS file. "RTN","IVMZ7CD",24,0) ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 "RTN","IVMZ7CD",25,0) ; CHECKS fields are turned ON. "RTN","IVMZ7CD",26,0) ; "RTN","IVMZ7CD",27,0) ; ***NOTE loop boundary (301-311) must be changed if rule numbers "RTN","IVMZ7CD",28,0) ; are added *** "RTN","IVMZ7CD",29,0) F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D "RTN","IVMZ7CD",30,0) . S Y=^DGIN(38.6,RULE,0) "RTN","IVMZ7CD",31,0) . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE "RTN","IVMZ7CD",32,0) I $D(FILERR) M ^TMP($J,DFN)=FILERR "RTN","IVMZ7CD",33,0) Q "RTN","IVMZ7CD",34,0) ; "RTN","IVMZ7CD",35,0) 301 ; PERSON LASTNAME REQUIRED "RTN","IVMZ7CD",36,0) S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",37,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",38,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",39,0) . S X=$P(DGSD("DEP",RIEN,0),U) "RTN","IVMZ7CD",40,0) . S X=$P(X,",") I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",41,0) Q "RTN","IVMZ7CD",42,0) ; "RTN","IVMZ7CD",43,0) 302 ; DATE OF BIRTH REQUIRED - Duplicate with #4 "RTN","IVMZ7CD",44,0) Q ;This tag needs to be removed after its placement in IVMZ7CR "RTN","IVMZ7CD",45,0) S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",46,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",47,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",48,0) . S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",49,0) Q "RTN","IVMZ7CD",50,0) ; "RTN","IVMZ7CD",51,0) 303 ; GENDER REQUIRED "RTN","IVMZ7CD",52,0) S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",53,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",54,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",55,0) . S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",56,0) Q "RTN","IVMZ7CD",57,0) ; "RTN","IVMZ7CD",58,0) 304 ; GENDER INVALID "RTN","IVMZ7CD",59,0) S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)="" "RTN","IVMZ7CD",60,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",61,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",62,0) . S X=$P(DGSD("DEP",RIEN,0),U,2) "RTN","IVMZ7CD",63,0) . I X]"",X'="M",X'="F" S FILERR(RULE)="" "RTN","IVMZ7CD",64,0) Q "RTN","IVMZ7CD",65,0) ; "RTN","IVMZ7CD",66,0) 305 ; VETERAN SSN MISSING - Duplicate with #7 "RTN","IVMZ7CD",67,0) Q ;This tag needs to be removed after its placement in IVMZ7CR "RTN","IVMZ7CD",68,0) S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)="" "RTN","IVMZ7CD",69,0) Q "RTN","IVMZ7CD",70,0) ; "RTN","IVMZ7CD",71,0) 306 ; VALID SSN/PSEUDO SSN REQUIRED "RTN","IVMZ7CD",72,0) N Z "RTN","IVMZ7CD",73,0) S X=$P($G(DGP("PAT",0)),U,9) "RTN","IVMZ7CD",74,0) Q:X="" ;quit if no SSN "RTN","IVMZ7CD",75,0) Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo "RTN","IVMZ7CD",76,0) I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero "RTN","IVMZ7CD",77,0) S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same "RTN","IVMZ7CD",78,0) I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros "RTN","IVMZ7CD",79,0) I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros "RTN","IVMZ7CD",80,0) I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros "RTN","IVMZ7CD",81,0) I X=123456789 S FILERR(RULE)="" ;SSN is 123456789 "RTN","IVMZ7CD",82,0) I X>728999999 S FILERR(RULE)="" ;SSN is greater than 728999999 "RTN","IVMZ7CD",83,0) Q "RTN","IVMZ7CD",84,0) ; "RTN","IVMZ7CD",85,0) 307 ; PSEUDO SSN REASON REQUIRED "RTN","IVMZ7CD",86,0) S X=$P($G(DGP("PAT",0)),U,9) "RTN","IVMZ7CD",87,0) I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)="" "RTN","IVMZ7CD",88,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",89,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",90,0) . S X=$P(DGSD("DEP",RIEN,0),U,9) "RTN","IVMZ7CD",91,0) . I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)="" "RTN","IVMZ7CD",92,0) Q "RTN","IVMZ7CD",93,0) ; "RTN","IVMZ7CD",94,0) 308 ; DATE OF DEATH BEFORE DOB "RTN","IVMZ7CD",95,0) S X=$P($G(DGP("PAT",.35)),U) I X']"" Q "RTN","IVMZ7CD",96,0) I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)="" "RTN","IVMZ7CD",97,0) Q "RTN","IVMZ7CD",98,0) ; "RTN","IVMZ7CD",99,0) 309 ; PATIENT RELATIONSHIP INVALID "RTN","IVMZ7CD",100,0) N DEPSEX,RELSEX,DEPREL "RTN","IVMZ7CD",101,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",102,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",103,0) . S DEPREL=$G(DGSD("DEP",RIEN)) "RTN","IVMZ7CD",104,0) . I DEPREL="" S FILERR(RULE)="" Q "RTN","IVMZ7CD",105,0) . I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q "RTN","IVMZ7CD",106,0) . S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2) "RTN","IVMZ7CD",107,0) . S RELSEX=$P(^DG(408.11,DEPREL,0),U,3) "RTN","IVMZ7CD",108,0) . I RELSEX="E" Q ;Gender for relation can be either "RTN","IVMZ7CD",109,0) . I DEPSEX'=RELSEX S FILERR(RULE)="" "RTN","IVMZ7CD",110,0) Q "RTN","IVMZ7CD",111,0) ; "RTN","IVMZ7CD",112,0) 310 ; DEPENDENT EFF. DATE REQUIRED "RTN","IVMZ7CD",113,0) I '$D(DGSD("DEP")) Q "RTN","IVMZ7CD",114,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CD",115,0) . S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)="" "RTN","IVMZ7CD",116,0) Q "RTN","IVMZ7CD",117,0) ; "RTN","IVMZ7CD",118,0) 311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16 "RTN","IVMZ7CD",119,0) Q ;This tag needs to be removed after its placement in IVMZ7CR "RTN","IVMZ7CD",120,0) S X=$P($G(DGP("PAT",.35)),U) "RTN","IVMZ7CD",121,0) I X]"",X>$$NOW^XLFDT() S FILERR(RULE)="" "RTN","IVMZ7CD",122,0) Q "RTN","IVMZ7CD",123,0) ; "RTN","IVMZ7CD",124,0) 312 ; PERSON MUST HAVE NATIONAL ICN "RTN","IVMZ7CD",125,0) I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN "RTN","IVMZ7CD",126,0) I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN "RTN","IVMZ7CD",127,0) Q "RTN","IVMZ7CD",128,0) ; "RTN","IVMZ7CE") 0^14^B3811155 "RTN","IVMZ7CE",1,0) IVMZ7CE ;TDM,BAJ - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 01/23/07 "RTN","IVMZ7CE",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMZ7CE",3,0) ; "RTN","IVMZ7CE",4,0) ; Eligibility Consistency Checks "RTN","IVMZ7CE",5,0) ; This routine checks the various elements of service information "RTN","IVMZ7CE",6,0) ; prior to building a Z07 record. Any tests which fail consistency "RTN","IVMZ7CE",7,0) ; check will be saved to the ^DGIN(38.6 record for the patient. "RTN","IVMZ7CE",8,0) ; "RTN","IVMZ7CE",9,0) ; Must be called from entry point "RTN","IVMZ7CE",10,0) Q "RTN","IVMZ7CE",11,0) ; "RTN","IVMZ7CE",12,0) EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. "RTN","IVMZ7CE",13,0) ; initialize working variables "RTN","IVMZ7CE",14,0) N RULE,Y,X,FILERR "RTN","IVMZ7CE",15,0) ; "RTN","IVMZ7CE",16,0) ; loop through rules in INCONSISTENT DATA ELEMENTS file. "RTN","IVMZ7CE",17,0) ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 "RTN","IVMZ7CE",18,0) ; CHECKS fields are turned ON. "RTN","IVMZ7CE",19,0) ; "RTN","IVMZ7CE",20,0) ; ***NOTE loop boundary (401-413) must be changed if rule numbers "RTN","IVMZ7CE",21,0) ; are added *** "RTN","IVMZ7CE",22,0) F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D "RTN","IVMZ7CE",23,0) . S Y=^DGIN(38.6,RULE,0) "RTN","IVMZ7CE",24,0) . I '$P(Y,U,5),$P(Y,U,6) D @RULE "RTN","IVMZ7CE",25,0) I $D(FILERR) M ^TMP($J,DFN)=FILERR "RTN","IVMZ7CE",26,0) Q "RTN","IVMZ7CE",27,0) ; "RTN","IVMZ7CE",28,0) 401 ; RATED INCOMPETENT INVALID "RTN","IVMZ7CE",29,0) S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" "RTN","IVMZ7CE",30,0) Q "RTN","IVMZ7CE",31,0) ; "RTN","IVMZ7CE",32,0) 402 ; ELIGIBLE FOR MEDICAID INVALID "RTN","IVMZ7CE",33,0) S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" "RTN","IVMZ7CE",34,0) Q "RTN","IVMZ7CE",35,0) ; "RTN","IVMZ7CE",36,0) 403 ; DT MEDICAID LAST ASKED INVALID "RTN","IVMZ7CE",37,0) I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" "RTN","IVMZ7CE",38,0) Q "RTN","IVMZ7CE",39,0) ; "RTN","IVMZ7CE",40,0) 404 ; INELIGIBLE REASON INVALID "RTN","IVMZ7CE",41,0) ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CE",42,0) Q "RTN","IVMZ7CE",43,0) ; "RTN","IVMZ7CE",44,0) 405 ; NON VETERAN ELIG CODE INVALID "RTN","IVMZ7CE",45,0) ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CE",46,0) Q "RTN","IVMZ7CE",47,0) ; "RTN","IVMZ7CE",48,0) 406 ; CLAIM FOLDER NUMBER INVALID "RTN","IVMZ7CE",49,0) S X=$P(DGP("PAT",.31),U,3) "RTN","IVMZ7CE",50,0) I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" "RTN","IVMZ7CE",51,0) Q "RTN","IVMZ7CE",52,0) ; "RTN","IVMZ7CE",53,0) 407 ; ELIGIBILITY STATUS INVALID "RTN","IVMZ7CE",54,0) S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" "RTN","IVMZ7CE",55,0) Q "RTN","IVMZ7CE",56,0) ; "RTN","IVMZ7CE",57,0) 408 ; DECLINE TO GIVE INCOME INVALID "RTN","IVMZ7CE",58,0) ; This CC removed per customer 05/08/2006 -- BAJ "RTN","IVMZ7CE",59,0) ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" "RTN","IVMZ7CE",60,0) Q "RTN","IVMZ7CE",61,0) ; "RTN","IVMZ7CE",62,0) 409 ; AGREE TO PAY DEDUCT INVALID "RTN","IVMZ7CE",63,0) ; 2 PENDING ADJUDICATION MEANS TEST "RTN","IVMZ7CE",64,0) ; 6 MT COPAY REQUIRED MEANS TEST "RTN","IVMZ7CE",65,0) ;16 GMT COPAY REQUIRED MEANS TEST "RTN","IVMZ7CE",66,0) I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D "RTN","IVMZ7CE",67,0) . S X=$P(DGP("MEANS",0),U,3) "RTN","IVMZ7CE",68,0) . I (X=2)!(X=6) S FILERR(RULE)="" Q "RTN","IVMZ7CE",69,0) . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" "RTN","IVMZ7CE",70,0) Q "RTN","IVMZ7CE",71,0) ; "RTN","IVMZ7CE",72,0) 410 ; Note: RULE #404 above is a duplicate of this rule "RTN","IVMZ7CE",73,0) Q "RTN","IVMZ7CE",74,0) ; "RTN","IVMZ7CE",75,0) 411 ; ENROLLMENT APP DATE INVALID "RTN","IVMZ7CE",76,0) I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" "RTN","IVMZ7CE",77,0) Q "RTN","IVMZ7CE",78,0) ; "RTN","IVMZ7CE",79,0) 412 ; POS/ELIG CODE INVALID "RTN","IVMZ7CE",80,0) ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CE",81,0) Q "RTN","IVMZ7CE",82,0) ; "RTN","IVMZ7CE",83,0) 413 ; POS INVALID "RTN","IVMZ7CE",84,0) ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CE",85,0) Q "RTN","IVMZ7CR") 0^5^B68760860 "RTN","IVMZ7CR",1,0) IVMZ7CR ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/7/05 12:24pm "RTN","IVMZ7CR",2,0) ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 "RTN","IVMZ7CR",3,0) ; "RTN","IVMZ7CR",4,0) ; Registration Consistency Checks "RTN","IVMZ7CR",5,0) Q ; Entry point must be specified "RTN","IVMZ7CR",6,0) EN(DFN,DGP,DGSD) ;Entry point "RTN","IVMZ7CR",7,0) ; input: DFN - Patient IEN "RTN","IVMZ7CR",8,0) ; DGP - Patient data array "RTN","IVMZ7CR",9,0) ; DGSD - Spouse and Dependent data array "RTN","IVMZ7CR",10,0) ; output: ^TMP($J,DFN,RULE) global "RTN","IVMZ7CR",11,0) ; DFN - Patient IEN "RTN","IVMZ7CR",12,0) ; RULE - Consistency rule # "RTN","IVMZ7CR",13,0) ;initialize variables "RTN","IVMZ7CR",14,0) N RULE,Y,X,FILERR,SPDEP "RTN","IVMZ7CR",15,0) S SPDEP=$D(DGSD("DEP")) "RTN","IVMZ7CR",16,0) ; we do not count through all numbers to save routine space "RTN","IVMZ7CR",17,0) F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D "RTN","IVMZ7CR",18,0) . I $$ON(RULE) D @RULE "RTN","IVMZ7CR",19,0) I $D(FILERR) M ^TMP($J,DFN)=FILERR "RTN","IVMZ7CR",20,0) Q "RTN","IVMZ7CR",21,0) 4 ; DOB UNSPECIFIED "RTN","IVMZ7CR",22,0) ; Note: RULE #302 in IVMZ7CD is a duplicate of this rule "RTN","IVMZ7CR",23,0) N RIEN "RTN","IVMZ7CR",24,0) I $P($G(DGP("PAT",0)),U,3)="" S FILERR(RULE)="" "RTN","IVMZ7CR",25,0) I 'SPDEP Q "RTN","IVMZ7CR",26,0) S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D "RTN","IVMZ7CR",27,0) . I $P(DGSD("DEP",RIEN,0),U,3)="" S FILERR(RULE)="" "RTN","IVMZ7CR",28,0) Q "RTN","IVMZ7CR",29,0) 7 ; SSN UNSPECIFIED "RTN","IVMZ7CR",30,0) ; Note: RULE #305 in IVMZ7CD is a duplicate of this rule "RTN","IVMZ7CR",31,0) I $P($G(DGP("PAT",0)),U,9)="" S FILERR(RULE)="" "RTN","IVMZ7CR",32,0) Q "RTN","IVMZ7CR",33,0) 9 ; VETERAN STATUS UNSPECIFIED "RTN","IVMZ7CR",34,0) I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)="" "RTN","IVMZ7CR",35,0) Q "RTN","IVMZ7CR",36,0) 11 ; SC PROMPT INCONSISTENT "RTN","IVMZ7CR",37,0) N VET,SC,PTYPE "RTN","IVMZ7CR",38,0) ; If VET Status is not specified (RULE 9) no need for this test "RTN","IVMZ7CR",39,0) Q:$P($G(DGP("PAT","VET")),U)="" "RTN","IVMZ7CR",40,0) S VET=$P(DGP("PAT","VET"),U,1)="Y",SC=$P(DGP("PAT",.3),U,1)="Y" "RTN","IVMZ7CR",41,0) I 'VET,SC S FILERR(RULE)="" "RTN","IVMZ7CR",42,0) Q "RTN","IVMZ7CR",43,0) 13 ; POS UNSPECIFIED "RTN","IVMZ7CR",44,0) ; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule "RTN","IVMZ7CR",45,0) Q:$P($G(DGP("PAT","VET")),U,1)'="Y" "RTN","IVMZ7CR",46,0) ; Make sure that the value in the field is valid -- DGRPC does this as well "RTN","IVMZ7CR",47,0) I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),0)) S FILERR(RULE)="" "RTN","IVMZ7CR",48,0) Q "RTN","IVMZ7CR",49,0) 15 ; INEL REASON UNSPECIFIED "RTN","IVMZ7CR",50,0) ; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule "RTN","IVMZ7CR",51,0) I $P(DGP("PAT",.15),U,2),$P($G(DGP("PAT",.3)),U,7)="" S FILERR(RULE)="" "RTN","IVMZ7CR",52,0) Q "RTN","IVMZ7CR",53,0) 16 ; DATE OF DEATH IN FUTURE "RTN","IVMZ7CR",54,0) ; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule "RTN","IVMZ7CR",55,0) S X=$P($G(DGP("PAT",.35)),U) I X']"" Q "RTN","IVMZ7CR",56,0) ; Compare DOD to right now "RTN","IVMZ7CR",57,0) I X>$$DT^XLFDT S FILERR(RULE)="" "RTN","IVMZ7CR",58,0) Q "RTN","IVMZ7CR",59,0) 19 ; ELIG/NONVET STAT INCONSISTENT "RTN","IVMZ7CR",60,0) ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule "RTN","IVMZ7CR",61,0) N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE "RTN","IVMZ7CR",62,0) ; Patient's VET status "RTN","IVMZ7CR",63,0) S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q "RTN","IVMZ7CR",64,0) ; do this check for NON-VET status only "RTN","IVMZ7CR",65,0) Q:VET="Y" "RTN","IVMZ7CR",66,0) ; Check PT type to see if we skip VET checks "RTN","IVMZ7CR",67,0) S PTYPE=$P($G(DGP("PAT","TYPE")),U,1) "RTN","IVMZ7CR",68,0) I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q "RTN","IVMZ7CR",69,0) ; Eligibility Code "RTN","IVMZ7CR",70,0) S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q "RTN","IVMZ7CR",71,0) ;start in File #8 "RTN","IVMZ7CR",72,0) S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q "RTN","IVMZ7CR",73,0) ;using the pointer value in field #8 (node 0; piece 9) "RTN","IVMZ7CR",74,0) S MPTR=$P(FILE8,U,9) "RTN","IVMZ7CR",75,0) ;find the record in File #8.1 "RTN","IVMZ7CR",76,0) S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q "RTN","IVMZ7CR",77,0) ;check the Type field #4 (node 0; piece 5). "RTN","IVMZ7CR",78,0) S MTYPE=$P(FILE81,U,5) "RTN","IVMZ7CR",79,0) ; Pt's VET status must match NON-VET Status of Eligibility Code "RTN","IVMZ7CR",80,0) I VET'=MTYPE S FILERR(RULE)="" "RTN","IVMZ7CR",81,0) Q "RTN","IVMZ7CR",82,0) 24 ; POS/ELIG CODE INCONSISTENT "RTN","IVMZ7CR",83,0) ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule "RTN","IVMZ7CR",84,0) I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)="" "RTN","IVMZ7CR",85,0) Q "RTN","IVMZ7CR",86,0) 29 ; A&A CLAIMED, NONVET "RTN","IVMZ7CR",87,0) I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)="" "RTN","IVMZ7CR",88,0) Q "RTN","IVMZ7CR",89,0) 30 ; HOUSEBOUND CLAIMED, NONVET "RTN","IVMZ7CR",90,0) I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)="" "RTN","IVMZ7CR",91,0) Q "RTN","IVMZ7CR",92,0) 31 ; VA PENSION CLAIMED, NONVET "RTN","IVMZ7CR",93,0) I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)="" "RTN","IVMZ7CR",94,0) Q "RTN","IVMZ7CR",95,0) 34 ; POW CLAIMED, NONVET "RTN","IVMZ7CR",96,0) I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)="" "RTN","IVMZ7CR",97,0) Q "RTN","IVMZ7CR",98,0) 60 ; AGENT ORANGE EXP LOC MISSING "RTN","IVMZ7CR",99,0) ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule. "RTN","IVMZ7CR",100,0) I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)="" "RTN","IVMZ7CR",101,0) Q "RTN","IVMZ7CR",102,0) 72 ; MSE DATA MISSING/INCOMPLETE "RTN","IVMZ7CR",103,0) ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule. "RTN","IVMZ7CR",104,0) N I,X "RTN","IVMZ7CR",105,0) S X=DGP("PAT",.32) "RTN","IVMZ7CR",106,0) F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q ;LAST "RTN","IVMZ7CR",107,0) F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q ;NTL "RTN","IVMZ7CR",108,0) F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" ;NNTL "RTN","IVMZ7CR",109,0) Q "RTN","IVMZ7CR",110,0) ; "RTN","IVMZ7CR",111,0) 74 ; CONFLICT DT MISSING/INCOMPLETE "RTN","IVMZ7CR",112,0) ; Note: Rule #515 in IVMZ7CS is a duplicate of this rule. "RTN","IVMZ7CR",113,0) ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT "RTN","IVMZ7CR",114,0) ; # 76 INACCURATE CONFLICT DATE "RTN","IVMZ7CR",115,0) ; "RTN","IVMZ7CR",116,0) N I,T,FROM,TO,RULE1,RULE2,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON75,ON76 "RTN","IVMZ7CR",117,0) S RULE1=75,RULE2=76 "RTN","IVMZ7CR",118,0) S ON75=$$ON(75),ON76=$$ON(76) "RTN","IVMZ7CR",119,0) S I=$$RANGE^DGMSCK() ; load range table "RTN","IVMZ7CR",120,0) F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT" D "RTN","IVMZ7CR",121,0) . ;we have to have a flag ERR because we don't want multiple "RTN","IVMZ7CR",122,0) . ;inconsistencies on a single conflict but we do want to "RTN","IVMZ7CR",123,0) . ;flag a single inconsistency on multiple conflicts "RTN","IVMZ7CR",124,0) . S ERR=0 "RTN","IVMZ7CR",125,0) . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4) "RTN","IVMZ7CR",126,0) . S RNGE=$P(CONFL,U,5) "RTN","IVMZ7CR",127,0) . Q:$P(DGP("PAT",NODE),U,PCE)'="Y" "RTN","IVMZ7CR",128,0) . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO) "RTN","IVMZ7CR",129,0) . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE "RTN","IVMZ7CR",130,0) . F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1 "RTN","IVMZ7CR",131,0) . Q:ERR "RTN","IVMZ7CR",132,0) . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT "RTN","IVMZ7CR",133,0) . I ON75,FROM>TO S FILERR(RULE1)="",ERR=1 "RTN","IVMZ7CR",134,0) . Q:ERR "RTN","IVMZ7CR",135,0) . ; check rule 76 INACCURATE CONFLICT DATE "RTN","IVMZ7CR",136,0) . Q:ERR "RTN","IVMZ7CR",137,0) . Q:'$D(RANGE(RNGE)) ; can't calculate if range table is missing "RTN","IVMZ7CR",138,0) . ; determine whether dates are withing conflict range "RTN","IVMZ7CR",139,0) . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2) "RTN","IVMZ7CR",140,0) . I ON76 D "RTN","IVMZ7CR",141,0) . . I '((RFR'>FROM)&((RTO'FROM&((FROM'>RTO)&((RTO'7) S FILERR(RULE)="" "RTN","IVMZ7CS",54,0) Q "RTN","IVMZ7CS",55,0) ; "RTN","IVMZ7CS",56,0) 508 ; MST STATUS INVALID "RTN","IVMZ7CS",57,0) S X=$P($G(DGP("MST",0)),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="D")&(X'="U") S FILERR(RULE)="" "RTN","IVMZ7CS",58,0) Q "RTN","IVMZ7CS",59,0) ; "RTN","IVMZ7CS",60,0) 509 ; MST STATUS CHANGE DATE MISSING "RTN","IVMZ7CS",61,0) S X=$P($G(DGP("MST",0)),U,3) I ((X="Y")!(X="N")!(X="D")!(X="U")),$P(DGP("MST",0),U)<1 S FILERR(RULE)="" "RTN","IVMZ7CS",62,0) Q "RTN","IVMZ7CS",63,0) ; "RTN","IVMZ7CS",64,0) 510 ; MST STATUS SITE REQUIRED "RTN","IVMZ7CS",65,0) S X=$P($G(DGP("MST",0)),U,3) I ((X="Y")!(X="N")!(X="D")!(X="U")),$P(DGP("MST",0),U,6)="" S FILERR(RULE)="" "RTN","IVMZ7CS",66,0) Q "RTN","IVMZ7CS",67,0) ; "RTN","IVMZ7CS",68,0) 511 ; MST STATUS SITE INVALID "RTN","IVMZ7CS",69,0) S X=$P($G(DGP("MST",0)),U,6) I X'="",'$$TF^XUAF4(X) S FILERR(RULE)="" "RTN","IVMZ7CS",70,0) Q "RTN","IVMZ7CS",71,0) ; "RTN","IVMZ7CS",72,0) 512 ; AO EXPOSURE LOCATION MISSING "RTN","IVMZ7CS",73,0) ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CS",74,0) Q "RTN","IVMZ7CS",75,0) ; "RTN","IVMZ7CS",76,0) 513 ; MS ENTRY DATE REQUIRED "RTN","IVMZ7CS",77,0) ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CS",78,0) Q "RTN","IVMZ7CS",79,0) ; "RTN","IVMZ7CS",80,0) 514 ; MS SEPARATION DATE REQUIRED "RTN","IVMZ7CS",81,0) ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CS",82,0) Q "RTN","IVMZ7CS",83,0) ; "RTN","IVMZ7CS",84,0) 515 ; CONFLICT FROM/TO DATE REQUIRED "RTN","IVMZ7CS",85,0) ; Note: RULE #74 in IVMZ7CR is a duplicate of this rule "RTN","IVMZ7CS",86,0) Q "RTN","IVMZ7CS",87,0) ; "RTN","IVMZ7CS",88,0) 516 ; DOB INVALID-MEXICAN BORDER WAR "RTN","IVMZ7CS",89,0) N MBW "RTN","IVMZ7CS",90,0) I $D(^DPT(DFN,"E")) D "RTN","IVMZ7CS",91,0) . S MBW=$O(^DIC(8,"B","MEXICAN BORDER WAR","")) Q:MBW="" "RTN","IVMZ7CS",92,0) . S X=0 F S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE)) D "RTN","IVMZ7CS",93,0) . . I $P(^DPT(DFN,"E",X,0),U)=MBW,$P(DGP("PAT",0),U,3)>2061231 S FILERR(RULE)="" "RTN","IVMZ7CS",94,0) Q "RTN","IVMZ7CS",95,0) ; "RTN","IVMZ7CS",96,0) 517 ; DOB INVALID-WORLD WAR I "RTN","IVMZ7CS",97,0) N WWI "RTN","IVMZ7CS",98,0) I $D(^DPT(DFN,"E")) D "RTN","IVMZ7CS",99,0) . S WWI=$O(^DIC(8,"B","WORLD WAR I","")) Q:WWI="" "RTN","IVMZ7CS",100,0) . S X=0 F S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE)) D "RTN","IVMZ7CS",101,0) . . I $P(^DPT(DFN,"E",X,0),U)=WWI,$P(DGP("PAT",0),U,3)>2071231 S FILERR(RULE)="" "RTN","IVMZ7CS",102,0) Q "RTN","IVMZ7CS",103,0) YM(X) ; Returns whether date has year & month values: 1=yes, 0=no "RTN","IVMZ7CS",104,0) Q ($E(X,1,3)>0)&($E(X,4,5)>0) "RTN","IVMZ7CS",105,0) ; "RTN","IVMZ7CS",106,0) YY(X) ; Returns whether date has year a value: 1=yes, 0=no "RTN","IVMZ7CS",107,0) Q ($E(X,1,3)>0) "VER") 8.0^22.0 **END** **END**