KIDS Distribution saved on Nov 03, 2020@13:16:12 ESM 5.13-KID V14-DG*5.3*1014,IVM*2.0*194 UAM VAL, CCP, MEANS TEST, PREF NAME **KIDS**:DG*5.3*1014^IVM*2.0*194^ **INSTALL NAME** DG*5.3*1014 "BLD",11410,0) DG*5.3*1014^REGISTRATION^0^3201103^y "BLD",11410,1,0) ^^2^2^3200625^^ "BLD",11410,1,1,0) Please see the DG*5.3*1014 patch description for detailed information "BLD",11410,1,2,0) regarding this patch. "BLD",11410,4,0) ^9.64PA^2^1 "BLD",11410,4,2,0) 2 "BLD",11410,4,2,2,0) ^9.641^2^3 "BLD",11410,4,2,2,2,0) PATIENT (File-top level) "BLD",11410,4,2,2,2,1,0) ^9.6411^.361^1 "BLD",11410,4,2,2,2,1,.361,0) PRIMARY ELIGIBILITY CODE "BLD",11410,4,2,2,2.0361,0) PATIENT ELIGIBILITIES (sub-file) "BLD",11410,4,2,2,2.0361,1,0) ^9.6411^.01^1 "BLD",11410,4,2,2,2.0361,1,.01,0) ELIGIBILITY "BLD",11410,4,2,2,2.191,0) COMMUNITY CARE PROGRAM (sub-file) "BLD",11410,4,2,2,2.191,1,0) ^9.6411^4^5 "BLD",11410,4,2,2,2.191,1,.01,0) CCP LAST UPDATED DATE "BLD",11410,4,2,2,2.191,1,1,0) COMMUNITY CARE PROGRAM CODE "BLD",11410,4,2,2,2.191,1,2,0) EFFECTIVE DATE "BLD",11410,4,2,2,2.191,1,3,0) END DATE "BLD",11410,4,2,2,2.191,1,4,0) ARCHIVE "BLD",11410,4,2,222) y^n^p^^^^n^^n "BLD",11410,4,2,224) "BLD",11410,4,"APDD",2,2) "BLD",11410,4,"APDD",2,2,.361) "BLD",11410,4,"APDD",2,2.0361) "BLD",11410,4,"APDD",2,2.0361,.01) "BLD",11410,4,"APDD",2,2.191) "BLD",11410,4,"APDD",2,2.191,.01) "BLD",11410,4,"APDD",2,2.191,1) "BLD",11410,4,"APDD",2,2.191,2) "BLD",11410,4,"APDD",2,2.191,3) "BLD",11410,4,"APDD",2,2.191,4) "BLD",11410,4,"B",2,2) "BLD",11410,6.3) 42 "BLD",11410,"ABPKG") n "BLD",11410,"INID") ^y "BLD",11410,"INIT") EN^DG531014P "BLD",11410,"KRN",0) ^9.67PA^1.5^25 "BLD",11410,"KRN",.4,0) .4 "BLD",11410,"KRN",.401,0) .401 "BLD",11410,"KRN",.402,0) .402 "BLD",11410,"KRN",.402,"NM",0) ^9.68A^^0 "BLD",11410,"KRN",.403,0) .403 "BLD",11410,"KRN",.5,0) .5 "BLD",11410,"KRN",.84,0) .84 "BLD",11410,"KRN",1.5,0) 1.5 "BLD",11410,"KRN",1.6,0) 1.6 "BLD",11410,"KRN",1.61,0) 1.61 "BLD",11410,"KRN",1.62,0) 1.62 "BLD",11410,"KRN",3.6,0) 3.6 "BLD",11410,"KRN",3.8,0) 3.8 "BLD",11410,"KRN",9.2,0) 9.2 "BLD",11410,"KRN",9.8,0) 9.8 "BLD",11410,"KRN",9.8,"NM",0) ^9.68A^44^41 "BLD",11410,"KRN",9.8,"NM",1,0) DGDEP^^0^B9896841 "BLD",11410,"KRN",9.8,"NM",2,0) DGR111^^0^B9351276 "BLD",11410,"KRN",9.8,"NM",3,0) DGR113^^0^B8401629 "BLD",11410,"KRN",9.8,"NM",4,0) DGR1131^^0^B6876398 "BLD",11410,"KRN",9.8,"NM",5,0) DGR114^^0^B6043455 "BLD",11410,"KRN",9.8,"NM",6,0) DGRP1^^0^B40617641 "BLD",11410,"KRN",9.8,"NM",9,0) DGRPU^^0^B123342522 "BLD",11410,"KRN",9.8,"NM",10,0) DGRP11B^^0^B13606123 "BLD",11410,"KRN",9.8,"NM",11,0) DGRPCF^^0^B29623704 "BLD",11410,"KRN",9.8,"NM",12,0) DPTLK^^0^B144170705 "BLD",11410,"KRN",9.8,"NM",13,0) DGDEPE^^0^B1701846 "BLD",11410,"KRN",9.8,"NM",14,0) DGRP2^^0^B12658951 "BLD",11410,"KRN",9.8,"NM",15,0) DGRP6^^0^B27897413 "BLD",11410,"KRN",9.8,"NM",16,0) DGRP61^^0^B67709879 "BLD",11410,"KRN",9.8,"NM",17,0) DGRP62^^0^B4633656 "BLD",11410,"KRN",9.8,"NM",18,0) DGMTSC4^^0^B29917122 "BLD",11410,"KRN",9.8,"NM",19,0) DGMTSC4V^^0^B31073713 "BLD",11410,"KRN",9.8,"NM",20,0) DGREGAED^^0^B62965158 "BLD",11410,"KRN",9.8,"NM",21,0) DGREGRED^^0^B77348398 "BLD",11410,"KRN",9.8,"NM",22,0) DGREGTED^^0^B65810805 "BLD",11410,"KRN",9.8,"NM",23,0) DGADDVAL^^0^B11247230 "BLD",11410,"KRN",9.8,"NM",24,0) DGADDLST^^0^B24537445 "BLD",11410,"KRN",9.8,"NM",25,0) DGENUPL1^^0^B75472345 "BLD",11410,"KRN",9.8,"NM",26,0) DGENUPL7^^0^B88929469 "BLD",11410,"KRN",9.8,"NM",27,0) DGENUPLB^^0^B52239102 "BLD",11410,"KRN",9.8,"NM",28,0) DGRP1152A^^0^B63227684 "BLD",11410,"KRN",9.8,"NM",29,0) DGRPE^^0^B104572440 "BLD",11410,"KRN",9.8,"NM",30,0) DGRPP^^0^B21625700 "BLD",11410,"KRN",9.8,"NM",31,0) VAFHLZCE^^0^B13475226 "BLD",11410,"KRN",9.8,"NM",32,0) DGRP1152U^^0^B20019030 "BLD",11410,"KRN",9.8,"NM",33,0) DGRPV^^0^B21728618 "BLD",11410,"KRN",9.8,"NM",35,0) DGRP11A^^0^B9418502 "BLD",11410,"KRN",9.8,"NM",36,0) DGRPH^^0^B32305129 "BLD",11410,"KRN",9.8,"NM",37,0) DGUAMWS^^0^B107230386 "BLD",11410,"KRN",9.8,"NM",38,0) DGRP6CL^^0^B77220668 "BLD",11410,"KRN",9.8,"NM",39,0) DGRP6EF^^0^B33321348 "BLD",11410,"KRN",9.8,"NM",40,0) DGMTSCC^^0^B38385133 "BLD",11410,"KRN",9.8,"NM",41,0) DGENA6^^0^B32233157 "BLD",11410,"KRN",9.8,"NM",42,0) DGMTSCR^^0^B14897236 "BLD",11410,"KRN",9.8,"NM",43,0) DGLOCK1^^0^B21838410 "BLD",11410,"KRN",9.8,"NM",44,0) DGLOCK3^^0^B10959586 "BLD",11410,"KRN",9.8,"NM","B","DGADDLST",24) "BLD",11410,"KRN",9.8,"NM","B","DGADDVAL",23) "BLD",11410,"KRN",9.8,"NM","B","DGDEP",1) "BLD",11410,"KRN",9.8,"NM","B","DGDEPE",13) "BLD",11410,"KRN",9.8,"NM","B","DGENA6",41) "BLD",11410,"KRN",9.8,"NM","B","DGENUPL1",25) "BLD",11410,"KRN",9.8,"NM","B","DGENUPL7",26) "BLD",11410,"KRN",9.8,"NM","B","DGENUPLB",27) "BLD",11410,"KRN",9.8,"NM","B","DGLOCK1",43) "BLD",11410,"KRN",9.8,"NM","B","DGLOCK3",44) "BLD",11410,"KRN",9.8,"NM","B","DGMTSC4",18) "BLD",11410,"KRN",9.8,"NM","B","DGMTSC4V",19) "BLD",11410,"KRN",9.8,"NM","B","DGMTSCC",40) "BLD",11410,"KRN",9.8,"NM","B","DGMTSCR",42) "BLD",11410,"KRN",9.8,"NM","B","DGR111",2) "BLD",11410,"KRN",9.8,"NM","B","DGR113",3) "BLD",11410,"KRN",9.8,"NM","B","DGR1131",4) "BLD",11410,"KRN",9.8,"NM","B","DGR114",5) "BLD",11410,"KRN",9.8,"NM","B","DGREGAED",20) "BLD",11410,"KRN",9.8,"NM","B","DGREGRED",21) "BLD",11410,"KRN",9.8,"NM","B","DGREGTED",22) "BLD",11410,"KRN",9.8,"NM","B","DGRP1",6) "BLD",11410,"KRN",9.8,"NM","B","DGRP1152A",28) "BLD",11410,"KRN",9.8,"NM","B","DGRP1152U",32) "BLD",11410,"KRN",9.8,"NM","B","DGRP11A",35) "BLD",11410,"KRN",9.8,"NM","B","DGRP11B",10) "BLD",11410,"KRN",9.8,"NM","B","DGRP2",14) "BLD",11410,"KRN",9.8,"NM","B","DGRP6",15) "BLD",11410,"KRN",9.8,"NM","B","DGRP61",16) "BLD",11410,"KRN",9.8,"NM","B","DGRP62",17) "BLD",11410,"KRN",9.8,"NM","B","DGRP6CL",38) "BLD",11410,"KRN",9.8,"NM","B","DGRP6EF",39) "BLD",11410,"KRN",9.8,"NM","B","DGRPCF",11) "BLD",11410,"KRN",9.8,"NM","B","DGRPE",29) "BLD",11410,"KRN",9.8,"NM","B","DGRPH",36) "BLD",11410,"KRN",9.8,"NM","B","DGRPP",30) "BLD",11410,"KRN",9.8,"NM","B","DGRPU",9) "BLD",11410,"KRN",9.8,"NM","B","DGRPV",33) "BLD",11410,"KRN",9.8,"NM","B","DGUAMWS",37) "BLD",11410,"KRN",9.8,"NM","B","DPTLK",12) "BLD",11410,"KRN",9.8,"NM","B","VAFHLZCE",31) "BLD",11410,"KRN",19,0) 19 "BLD",11410,"KRN",19,"NM",0) ^9.68A^^ "BLD",11410,"KRN",19.1,0) 19.1 "BLD",11410,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",11410,"KRN",101,0) 101 "BLD",11410,"KRN",101,"NM",0) ^9.68A^6^6 "BLD",11410,"KRN",101,"NM",1,0) DGEN CCP ADD^^0 "BLD",11410,"KRN",101,"NM",2,0) DGEN CCP EDIT^^0 "BLD",11410,"KRN",101,"NM",3,0) DGEN CCP REMOVE^^0 "BLD",11410,"KRN",101,"NM",4,0) DGEN ADDR SELECT^^0 "BLD",11410,"KRN",101,"NM",5,0) DGEN ADD VALID 1.2 MENU^^0 "BLD",11410,"KRN",101,"NM",6,0) DGEN CCP MENU^^0 "BLD",11410,"KRN",101,"NM","B","DGEN ADD VALID 1.2 MENU",5) "BLD",11410,"KRN",101,"NM","B","DGEN ADDR SELECT",4) "BLD",11410,"KRN",101,"NM","B","DGEN CCP ADD",1) "BLD",11410,"KRN",101,"NM","B","DGEN CCP EDIT",2) "BLD",11410,"KRN",101,"NM","B","DGEN CCP MENU",6) "BLD",11410,"KRN",101,"NM","B","DGEN CCP REMOVE",3) "BLD",11410,"KRN",409.61,0) 409.61 "BLD",11410,"KRN",409.61,"NM",0) ^9.68A^12^8 "BLD",11410,"KRN",409.61,"NM",1,0) DGEN HBP PATIENT^^0 "BLD",11410,"KRN",409.61,"NM",4,0) DGEN CCP DETAIL^^0 "BLD",11410,"KRN",409.61,"NM",5,0) DGEN HBP DETAIL^^0 "BLD",11410,"KRN",409.61,"NM",6,0) DGMT EXPAND PROFILE^^0 "BLD",11410,"KRN",409.61,"NM",7,0) DGEN MSDS PATIENT^^0 "BLD",11410,"KRN",409.61,"NM",8,0) DGEN MSDS PATIENT VIEW^^0 "BLD",11410,"KRN",409.61,"NM",11,0) DGEN ADDR VALID^^0 "BLD",11410,"KRN",409.61,"NM",12,0) DGMT DEPENDENTS^^0 "BLD",11410,"KRN",409.61,"NM","B","DGEN ADDR VALID",11) "BLD",11410,"KRN",409.61,"NM","B","DGEN CCP DETAIL",4) "BLD",11410,"KRN",409.61,"NM","B","DGEN HBP DETAIL",5) "BLD",11410,"KRN",409.61,"NM","B","DGEN HBP PATIENT",1) "BLD",11410,"KRN",409.61,"NM","B","DGEN MSDS PATIENT",7) "BLD",11410,"KRN",409.61,"NM","B","DGEN MSDS PATIENT VIEW",8) "BLD",11410,"KRN",409.61,"NM","B","DGMT DEPENDENTS",12) "BLD",11410,"KRN",409.61,"NM","B","DGMT EXPAND PROFILE",6) "BLD",11410,"KRN",771,0) 771 "BLD",11410,"KRN",779.2,0) 779.2 "BLD",11410,"KRN",870,0) 870 "BLD",11410,"KRN",8989.51,0) 8989.51 "BLD",11410,"KRN",8989.52,0) 8989.52 "BLD",11410,"KRN",8993,0) 8993 "BLD",11410,"KRN",8994,0) 8994 "BLD",11410,"KRN","B",.4,.4) "BLD",11410,"KRN","B",.401,.401) "BLD",11410,"KRN","B",.402,.402) "BLD",11410,"KRN","B",.403,.403) "BLD",11410,"KRN","B",.5,.5) "BLD",11410,"KRN","B",.84,.84) "BLD",11410,"KRN","B",1.5,1.5) "BLD",11410,"KRN","B",1.6,1.6) "BLD",11410,"KRN","B",1.61,1.61) "BLD",11410,"KRN","B",1.62,1.62) "BLD",11410,"KRN","B",3.6,3.6) "BLD",11410,"KRN","B",3.8,3.8) "BLD",11410,"KRN","B",9.2,9.2) "BLD",11410,"KRN","B",9.8,9.8) "BLD",11410,"KRN","B",19,19) "BLD",11410,"KRN","B",19.1,19.1) "BLD",11410,"KRN","B",101,101) "BLD",11410,"KRN","B",409.61,409.61) "BLD",11410,"KRN","B",771,771) "BLD",11410,"KRN","B",779.2,779.2) "BLD",11410,"KRN","B",870,870) "BLD",11410,"KRN","B",8989.51,8989.51) "BLD",11410,"KRN","B",8989.52,8989.52) "BLD",11410,"KRN","B",8993,8993) "BLD",11410,"KRN","B",8994,8994) "BLD",11410,"QDEF") ^^^^NO^^^^NO^^YES "BLD",11410,"QUES",0) ^9.62^^ "BLD",11410,"REQB",0) ^9.611^10^8 "BLD",11410,"REQB",2,0) DG*5.3*567^1 "BLD",11410,"REQB",3,0) DG*5.3*966^1 "BLD",11410,"REQB",5,0) DG*5.3*996^1 "BLD",11410,"REQB",6,0) DG*5.3*997^1 "BLD",11410,"REQB",7,0) DG*5.3*1006^1 "BLD",11410,"REQB",8,0) DG*5.3*1010^1 "BLD",11410,"REQB",9,0) DG*5.3*890^1 "BLD",11410,"REQB",10,0) DG*5.3*1031^1 "BLD",11410,"REQB","B","DG*5.3*1006",7) "BLD",11410,"REQB","B","DG*5.3*1010",8) "BLD",11410,"REQB","B","DG*5.3*1031",10) "BLD",11410,"REQB","B","DG*5.3*567",2) "BLD",11410,"REQB","B","DG*5.3*890",9) "BLD",11410,"REQB","B","DG*5.3*966",3) "BLD",11410,"REQB","B","DG*5.3*996",5) "BLD",11410,"REQB","B","DG*5.3*997",6) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^n^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,.361) "FIA",2,2,361) "FIA",2,2,1910) "FIA",2,2.0361) 1 "FIA",2,2.0361,.01) "FIA",2,2.191) 1 "FIA",2,2.191,.01) "FIA",2,2.191,1) "FIA",2,2.191,2) "FIA",2,2.191,3) "FIA",2,2.191,4) "INIT") EN^DG531014P "IX",2,2,"ADGFMD361",0) 2^ADGFMD361^THhis x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"ADGFMD361",.1,0) ^^2^2^3060624^ "IX",2,2,"ADGFMD361",.1,1,0) This cross reference activates the DG FIELD MONITOR event point if the "IX",2,2,"ADGFMD361",.1,2,0) PRIMARY ELIGIBILITY CODE (#.361)field changes. "IX",2,2,"ADGFMD361",1) D FC^DGFCPROT(.DA,2,.361,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD361",2) D FC^DGFCPROT(.DA,2,.361,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"ADGFMD361",11.1,0) ^.114IA^1^1 "IX",2,2,"ADGFMD361",11.1,1,0) 1^F^2^.361^^^F "IX",2,2.191,"ACCCP",0) 2.191^ACCCP^TRIGGER A Z07 ON CCP CHANGES^MU^^R^IR^I^2.191^^^^^A "IX",2,2.191,"ACCCP",.1,0) ^^2^2^3200717^ "IX",2,2.191,"ACCCP",.1,1,0) This cross reference will trigger a Z07 message whenever changes are made "IX",2,2.191,"ACCCP",.1,2,0) to the Community Care Program. This includes add, changes, and deletes. "IX",2,2.191,"ACCCP",1) D EVENT^IVMPLOG($G(DA(1))) "IX",2,2.191,"ACCCP",2) D EVENT^IVMPLOG($G(DA(1))) "IX",2,2.191,"ACCCP",11.1,0) ^.114IA^4^4 "IX",2,2.191,"ACCCP",11.1,1,0) 1^F^2.191^.01^^^F "IX",2,2.191,"ACCCP",11.1,2,0) 2^F^2.191^1^^^F "IX",2,2.191,"ACCCP",11.1,3,0) 3^F^2.191^2^^^F "IX",2,2.191,"ACCCP",11.1,4,0) 4^F^2.191^3^^^F "KRN",101,5187,-1) 0^6 "KRN",101,5187,0) DGEN CCP MENU^Patient CCP Menu^^M^^^^^^^^REGISTRATION "KRN",101,5187,1,0) ^101.06^2^2^3200829^^^^ "KRN",101,5187,1,1,0) This protocol menu contains all the activities for patient CCP data "KRN",101,5187,1,2,0) that can be added, edited or removed. "KRN",101,5187,4) 25^4 "KRN",101,5187,10,0) ^101.01PA^3^3 "KRN",101,5187,10,1,0) 5188^AD^10^ "KRN",101,5187,10,1,1) ^^ "KRN",101,5187,10,1,"^") DGEN CCP ADD "KRN",101,5187,10,2,0) 5190^ED^20^ "KRN",101,5187,10,2,"^") DGEN CCP EDIT "KRN",101,5187,10,3,0) 5189^RE^30^ "KRN",101,5187,10,3,"^") DGEN CCP REMOVE "KRN",101,5187,15) D PEXIT^DGRP1152A "KRN",101,5187,26) D SHOW^VALM "KRN",101,5187,27) "KRN",101,5187,28) Select Action: "KRN",101,5187,99) 65552,42053 "KRN",101,5188,-1) 0^1 "KRN",101,5188,0) DGEN CCP ADD^Add^^A^^^^^^^^REGISTRATION "KRN",101,5188,1,0) ^101.06^2^2^3200828^^^^ "KRN",101,5188,1,1,0) This protocol action allows a user to add a new COMMUNITY CARE PROGRAM for "KRN",101,5188,1,2,0) a Collateral Eligibility. "KRN",101,5188,4) ^^^AD "KRN",101,5188,20) D ACT^DGRP1152A("A") "KRN",101,5188,27) "KRN",101,5188,99) 65541,62048 "KRN",101,5188,101.04) ^^^ "KRN",101,5189,-1) 0^3 "KRN",101,5189,0) DGEN CCP REMOVE^Remove^^A^^^^^^^^REGISTRATION "KRN",101,5189,1,0) ^101.06^4^4^3200713^^^ "KRN",101,5189,1,1,0) This protocol action allows a user to remove a Community Care Program from "KRN",101,5189,1,2,0) Active status, which had been previously added through the AD - Add option. "KRN",101,5189,1,3,0) Community Care Programs may not be Deleted, they can only be deactivated via "KRN",101,5189,1,4,0) an entry into the END DATE internal data field. "KRN",101,5189,4) ^^^RE "KRN",101,5189,20) D ACT^DGRP1152A("R") "KRN",101,5189,99) 65541,62457 "KRN",101,5190,-1) 0^2 "KRN",101,5190,0) DGEN CCP EDIT^Edit^^A^^^^^^^^REGISTRATION "KRN",101,5190,1,0) ^101.06^2^2^3200713^^^^ "KRN",101,5190,1,1,0) This protocol action allows a user to edit a Community Care Program that "KRN",101,5190,1,2,0) has been previously added through the AD - Add option. "KRN",101,5190,4) ^^^ED "KRN",101,5190,20) D ACT^DGRP1152A("E") "KRN",101,5190,99) 65541,63202 "KRN",101,5192,-1) 0^5 "KRN",101,5192,0) DGEN ADD VALID 1.2 MENU^Patient Address Validation 1.2 Menu^^M^^^^^^^^REGISTRATION "KRN",101,5192,1,0) ^101.06^7^7^3200728^^^^ "KRN",101,5192,1,1,0) This protocol menu contains the activities for selecting a validated "KRN",101,5192,1,2,0) patient address. "KRN",101,5192,1,3,0) "KRN",101,5192,1,4,0) The Address Validation screen will display the address entered by the user "KRN",101,5192,1,5,0) along with all addresses returned from the UAM Address Validation "KRN",101,5192,1,6,0) Service. This protocol menu has only 1 action. The SEL action will prompt "KRN",101,5192,1,7,0) the user to select the address from that list. "KRN",101,5192,10,0) ^101.01PA^1^1 "KRN",101,5192,10,1,0) 5193^SEL^10^ "KRN",101,5192,10,1,1) ^^ "KRN",101,5192,10,1,"^") DGEN ADDR SELECT "KRN",101,5192,15) D PEXIT^DGADDLST "KRN",101,5192,26) D SHOW^VALM "KRN",101,5192,27) "KRN",101,5192,28) Select Action: "KRN",101,5192,99) 65576,46042 "KRN",101,5193,-1) 0^4 "KRN",101,5193,0) DGEN ADDR SELECT^Select Address^^A^^^^^^^^ "KRN",101,5193,1,0) ^101.06^2^2^3200728^^^^ "KRN",101,5193,1,1,0) This action protocol allows the user to select a validated address from a "KRN",101,5193,1,2,0) list of addresses returned from the UAM Address Validation Service. "KRN",101,5193,10,0) ^101.01PA "KRN",101,5193,20) D ACT^DGADDLST("SEL") "KRN",101,5193,27) "KRN",101,5193,28) "KRN",101,5193,29) "KRN",101,5193,30) "KRN",101,5193,99) 65545,54971 "KRN",409.61,27,-1) 0^12 "KRN",409.61,27,0) DGMT DEPENDENTS^1^1^80^6^14^1^1^Dependent^DGMT MEANS TEST DEPENDENT MENU^Dependents Module^4 "KRN",409.61,27,1) ^VALM HIDDEN ACTIONS "KRN",409.61,27,"ARRAY") ^TMP("DGDEP",$J) "KRN",409.61,27,"COL",0) ^409.621^6^6 "KRN",409.61,27,"COL",1,0) DEP #^3^2 "KRN",409.61,27,"COL",2,0) NAME^9^22^Patient/Dependent "KRN",409.61,27,"COL",3,0) RELATION^32^20^Relationship "KRN",409.61,27,"COL",4,0) MEANS TEST^5^2^MT "KRN",409.61,27,"COL",5,0) ACTIVE^63^6^Active "KRN",409.61,27,"COL",6,0) ADDRESS^71^7^Address "KRN",409.61,27,"COL","B","ACTIVE",5) "KRN",409.61,27,"COL","B","ADDRESS",6) "KRN",409.61,27,"COL","B","DEP #",1) "KRN",409.61,27,"COL","B","MEANS TEST",4) "KRN",409.61,27,"COL","B","NAME",2) "KRN",409.61,27,"COL","B","RELATION",3) "KRN",409.61,27,"EXP") "KRN",409.61,27,"FNL") D ENQ^DGDEP,CLEAR^VALM1 "KRN",409.61,27,"HDR") D HDR^DGDEP "KRN",409.61,27,"HLP") S VAR="HELPTXT" D ^DGDEPH "KRN",409.61,27,"INIT") D INIT^DGDEP "KRN",409.61,28,-1) 0^6 "KRN",409.61,28,0) DGMT EXPAND PROFILE^1^^^6^17^1^^^DGMT MEANS TEST DEPENDENT UTIL^Expand Dependent^2 "KRN",409.61,28,"ARRAY") ^TMP("DGMTEP",$J) "KRN",409.61,28,"FNL") D EXIT^DGDEP1 "KRN",409.61,28,"HDR") D HDR^DGDEPE "KRN",409.61,28,"HLP") S VAR="HLPTXT1" D ^DGDEPH "KRN",409.61,28,"INIT") D INIT^DGDEPE "KRN",409.61,707,-1) 0^7 "KRN",409.61,707,0) DGEN MSDS PATIENT^1^^80^7^12^1^1^^DGEN MSDS MENU^Military Service^1^^1 "KRN",409.61,707,1) ^VALM HIDDEN ACTIONS "KRN",409.61,707,"ARRAY") ^TMP("DGRP61",$J) "KRN",409.61,707,"COL",0) ^409.621 "KRN",409.61,707,"FNL") D EXIT^DGRP61 "KRN",409.61,707,"HDR") D HDR^DGRP61 "KRN",409.61,707,"HLP") D HELP^DGRP61 "KRN",409.61,707,"INIT") D INIT^DGRP61 "KRN",409.61,708,-1) 0^8 "KRN",409.61,708,0) DGEN MSDS PATIENT VIEW^2^^80^7^19^1^1^^^Military History View^1^^1 "KRN",409.61,708,1) ^VALM HIDDEN ACTIONS "KRN",409.61,708,"ARRAY") ^TMP("DGRP62",$J) "KRN",409.61,708,"FNL") D EXIT^DGRP62 "KRN",409.61,708,"HDR") D HDR^DGRP62 "KRN",409.61,708,"HLP") D HELP^DGRP62 "KRN",409.61,708,"INIT") D INIT^DGRP62 "KRN",409.61,727,-1) 0^1 "KRN",409.61,727,0) DGEN HBP PATIENT^1^^240^6^15^1^1^^DGEN HBP 11.1 MENU^VHAP <11.1>^1^^1 "KRN",409.61,727,1) ^VALM HIDDEN ACTIONS "KRN",409.61,727,"COL",0) ^409.621^1^1 "KRN",409.61,727,"COL",1,0) 1^4^30^Current VHAP "KRN",409.61,727,"COL","B",1,1) "KRN",409.61,727,"FNL") D EXIT^DGR111 "KRN",409.61,727,"HDR") D HDR^DGR111 "KRN",409.61,727,"HLP") D HELP^DGR111 "KRN",409.61,727,"INIT") D INIT^DGR111 "KRN",409.61,730,-1) 0^5 "KRN",409.61,730,0) DGEN HBP DETAIL^2^^240^6^20^1^1^^^VHAP <11.4>^1^^1 "KRN",409.61,730,1) ^VALM HIDDEN ACTIONS "KRN",409.61,730,"COL",0) ^409.621^1^1 "KRN",409.61,730,"COL",1,0) 1^4^35^VHAP View All Detail "KRN",409.61,730,"COL","B",1,1) "KRN",409.61,730,"EXP") D EXPND^DGR114 "KRN",409.61,730,"FNL") D EXIT^DGR114 "KRN",409.61,730,"HDR") D HDR^DGR114 "KRN",409.61,730,"HLP") D HELP^DGR114 "KRN",409.61,730,"INIT") D INIT^DGR114 "KRN",409.61,837,-1) 0^4 "KRN",409.61,837,0) DGEN CCP DETAIL^1^^80^6^18^1^1^^DGEN CCP MENU^CCP Collateral Data <11.5.2>^1^^1 "KRN",409.61,837,1) ^VALM HIDDEN ACTIONS "KRN",409.61,837,"COL",0) ^409.621^4^3 "KRN",409.61,837,"COL",1,0) CCPNAME^6^30^^^0 "KRN",409.61,837,"COL",3,0) NO^1^5^^^0 "KRN",409.61,837,"COL",4,0) EFFDATE^36^15 "KRN",409.61,837,"COL","AIDENT",0,1) "KRN",409.61,837,"COL","AIDENT",0,3) "KRN",409.61,837,"COL","B","CCPNAME",1) "KRN",409.61,837,"COL","B","EFFDATE",4) "KRN",409.61,837,"COL","B","NO",3) "KRN",409.61,837,"FNL") D EXIT^DGRP1152A "KRN",409.61,837,"HDR") D HDR^DGRP1152A "KRN",409.61,837,"HLP") D HELP^DGRP1152A "KRN",409.61,837,"INIT") D INIT^DGRP1152A "KRN",409.61,839,-1) 0^11 "KRN",409.61,839,0) DGEN ADDR VALID^1^^240^5^19^1^1^Address^DGEN ADD VALID 1.2 MENU^Address Validation ^1^^0 "KRN",409.61,839,1) ^VALM HIDDEN ACTIONS "KRN",409.61,839,"ARRAY") ^TMP("DGADDVAL",$J) "KRN",409.61,839,"COL",0) ^409.621^^0 "KRN",409.61,839,"EXP") "KRN",409.61,839,"FNL") D EXIT^DGADDLST "KRN",409.61,839,"HDR") D HDR^DGADDLST "KRN",409.61,839,"HLP") D HELP^DGADDLST "KRN",409.61,839,"INIT") D INIT^DGADDLST "MBREQ") 0 "ORD",15,101) 101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA "ORD",15,101,0) PROTOCOL "ORD",17,409.61) 409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1 "ORD",17,409.61,0) LIST TEMPLATE "PKG",47,-1) 1^1 "PKG",47,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",47,22,0) ^9.49I^1^1 "PKG",47,22,1,0) 5.3^2930813^2960613 "PKG",47,22,1,"PAH",1,0) 1014^3201103 "PKG",47,22,1,"PAH",1,1,0) ^^2^2^3201103 "PKG",47,22,1,"PAH",1,1,1,0) Please see the DG*5.3*1014 patch description for detailed information "PKG",47,22,1,"PAH",1,1,2,0) regarding this patch. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") 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") 42 "RTN","DG531014P") 0^^B210553470 "RTN","DG531014P",1,0) DG531014P ;ALB/MCF - DG*5.3*1014 POST-INSTALL ROUTINE ;24 July 2020 3:00 PM "RTN","DG531014P",2,0) ;;5.3;Registration;**1014**;Aug 13, 1993;Build 42 "RTN","DG531014P",3,0) ; ICRs: "RTN","DG531014P",4,0) ; 10141 : BMES^XPDUTL "RTN","DG531014P",5,0) ; : MES^XPDUTL "RTN","DG531014P",6,0) ; 5421 : REGREST^XOBWLIB "RTN","DG531014P",7,0) ; 7190 : Read access to file 18.02 "RTN","DG531014P",8,0) ; 7191 : R/W access to file 18.12 "RTN","DG531014P",9,0) ; 3352 : Provides the use of DIEZ^DIKCUTL3 to recompile all compiled input templates that contain specific fields. "RTN","DG531014P",10,0) ; "RTN","DG531014P",11,0) Q "RTN","DG531014P",12,0) EN ; Main entry point for post-install to set up web server and services and recompile input templates "RTN","DG531014P",13,0) ; create HWSC web server and web services entries "RTN","DG531014P",14,0) N DGSRVR,DGPREFIX,DGKEY,DGREGION "RTN","DG531014P",15,0) D BMES^XPDUTL(">>> Patch DG*5.3*1014 - Post-install started.") "RTN","DG531014P",16,0) D BMES^XPDUTL(">>> Patch DG*5.3*1014 - Post-install set up for SSL Configuration...") "RTN","DG531014P",17,0) D INIT "RTN","DG531014P",18,0) D SERVICES "RTN","DG531014P",19,0) D SERVER "RTN","DG531014P",20,0) D BMES^XPDUTL(">>> Post-install SSL set up complete.") "RTN","DG531014P",21,0) ; "RTN","DG531014P",22,0) RECOMP ;Recompile input templates "RTN","DG531014P",23,0) ;Recompile all compiled input templates that contain specific fields. "RTN","DG531014P",24,0) ;This is needed because the data dictionary definition of these fields "RTN","DG531014P",25,0) ;has changed and they are being exported via KIDS. "RTN","DG531014P",26,0) ; "RTN","DG531014P",27,0) N DGFLD "RTN","DG531014P",28,0) ; "RTN","DG531014P",29,0) D BMES^XPDUTL(">>> Recompile all compiled input templates that contain the following fields:") "RTN","DG531014P",30,0) ; "RTN","DG531014P",31,0) D BMES^XPDUTL(" o PRIMARY ELIGIBILITY (#.361) field in PATIENT (#2) file") "RTN","DG531014P",32,0) D MES^XPDUTL(" o ELIGIBILITY (#.01) field in PATIENT ELIGIBILITIES (#2.0361)") "RTN","DG531014P",33,0) D MES^XPDUTL(" subfile of PATIENT (#2) file") "RTN","DG531014P",34,0) ;build array of file and field numbers for top-level (#2) file fields being exported "RTN","DG531014P",35,0) ;array format: DGFLD(file#,field)="" "RTN","DG531014P",36,0) S DGFLD(2,.361)="" "RTN","DG531014P",37,0) S DGFLD(2.0361,.01)="" "RTN","DG531014P",38,0) ;recompile all compiled input templates that contain the fields in the DGLFD array passed by reference "RTN","DG531014P",39,0) D DIEZ^DIKCUTL3(2,.DGFLD) "RTN","DG531014P",40,0) K DGFLD "RTN","DG531014P",41,0) ; "RTN","DG531014P",42,0) D BMES^XPDUTL(">>> Re-compile completed.") "RTN","DG531014P",43,0) D BMES^XPDUTL(">>> Patch DG*5.3*1014 - Post-install complete.") "RTN","DG531014P",44,0) Q "RTN","DG531014P",45,0) INIT ; Initialize variables DGPREFIX, DGSRVR, DGREGION, and DGKEY "RTN","DG531014P",46,0) N DGCOUNT,DGDATA,DGSTATION,DGEXIT "RTN","DG531014P",47,0) ; PREFIX to more quickly change the server/service names per site or for testing "RTN","DG531014P",48,0) S DGPREFIX="DG UAM AV " ; include the space at the end of the prefix "RTN","DG531014P",49,0) S DGSRVR=DGPREFIX_"SERVER" "RTN","DG531014P",50,0) ; Get the current site station number "RTN","DG531014P",51,0) S DGSTATION=$P($$SITE^VASITE,"^",3) ;Output= Institution file pointer^Institution name^station number with suffix "RTN","DG531014P",52,0) ; Set the default region "RTN","DG531014P",53,0) S DGREGION="Staging",DGEXIT=0 "RTN","DG531014P",54,0) ; Loop to find the matching region for the station number "RTN","DG531014P",55,0) F DGCOUNT=1:1 S DGDATA=$P($T(REGMAP+DGCOUNT),";;",2) Q:DGDATA="END" D Q:DGEXIT "RTN","DG531014P",56,0) . I $P(DGDATA,";",1)=DGSTATION S DGREGION=$P(DGDATA,";",3),DGEXIT=1 "RTN","DG531014P",57,0) ; Get the matching DGKEY for the region "RTN","DG531014P",58,0) S DGEXIT=0 "RTN","DG531014P",59,0) F DGCOUNT=1:1 S DGDATA=$P($T(KEYMAP+DGCOUNT),";;",2) Q:DGDATA="END" D Q:DGEXIT "RTN","DG531014P",60,0) . I $P(DGDATA,";",1)=DGREGION S DGKEY=$P(DGDATA,";",2),DGEXIT=1 "RTN","DG531014P",61,0) D BMES^XPDUTL(">UAM Address Validation Key assigned. Region: "_DGREGION) "RTN","DG531014P",62,0) Q "RTN","DG531014P",63,0) SERVICES ; use REGREST^XOBWLIB "RTN","DG531014P",64,0) N DGI,DGILOWCASE,DGCNTXTRT,DGSRVC "RTN","DG531014P",65,0) D BMES^XPDUTL(">Updating WEB SERVICE (#18.02) file...") "RTN","DG531014P",66,0) F DGI="CANDIDATE","VALIDATE" D "RTN","DG531014P",67,0) . ; use the prefix name from INIT "RTN","DG531014P",68,0) . S DGSRVC=DGPREFIX_DGI "RTN","DG531014P",69,0) . S DGILOWCASE=$TR(DGI,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") "RTN","DG531014P",70,0) . IF DGI="CANDIDATE" S DGCNTXTRT="services/address_validation/v2/"_DGILOWCASE_"?apikey="_DGKEY "RTN","DG531014P",71,0) . IF DGI="VALIDATE" S DGCNTXTRT="services/address_validation/v1/"_DGILOWCASE_"?apikey="_DGKEY "RTN","DG531014P",72,0) . D REGREST^XOBWLIB(DGSRVC,DGCNTXTRT) ; REGREST^XOBWLIB handles all messaging. "RTN","DG531014P",73,0) Q "RTN","DG531014P",74,0) SERVER ; set up web server "RTN","DG531014P",75,0) D MES^XPDUTL(">Updating WEB SERVER (#18.12) file...") "RTN","DG531014P",76,0) N DGIEN,DGIENS,DGSERVER,DGFDAI,DGERR,DGERR12,DGERR02,DGI,DGSRVC,DGSRVIEN,DGSERVICE "RTN","DG531014P",77,0) S DGIEN("SRV")=$$FIND1^DIC(18.12,,"B",DGSRVR) "RTN","DG531014P",78,0) I DGIEN("SRV") S DGIENS("SRV")=DGIEN("SRV")_"," "RTN","DG531014P",79,0) E S DGIENS("SRV")="+1," "RTN","DG531014P",80,0) S DGSERVER(18.12,DGIENS("SRV"),.01)=DGSRVR "RTN","DG531014P",81,0) S DGSERVER(18.12,DGIENS("SRV"),.03)=443 "RTN","DG531014P",82,0) ; If the Region is "staging" (non production site) the endpoint is the sandbox, otherwise, use the Production endpoint "RTN","DG531014P",83,0) S DGSERVER(18.12,DGIENS("SRV"),.04)=$S(DGREGION="Staging":"sandbox-api.domain",1:"api.domain") "RTN","DG531014P",84,0) S DGSERVER(18.12,DGIENS("SRV"),.06)=1 "RTN","DG531014P",85,0) S DGSERVER(18.12,DGIENS("SRV"),1.01)=0 "RTN","DG531014P",86,0) S DGSERVER(18.12,DGIENS("SRV"),3.01)=1 "RTN","DG531014P",87,0) S DGSERVER(18.12,DGIENS("SRV"),3.02)="encrypt_only_tlsv12" "RTN","DG531014P",88,0) S DGSERVER(18.12,DGIENS("SRV"),3.03)="443" "RTN","DG531014P",89,0) I DGIEN("SRV") D FILE^DIE("","DGSERVER","DGERR12") ; update existing entry "RTN","DG531014P",90,0) I 'DGIEN("SRV") D UPDATE^DIE("","DGSERVER","DGFDAI","DGERR") ; create new entry "RTN","DG531014P",91,0) I $D(DGFDAI) S DGIENS("SRV")=DGFDAI(1)_",",DGIEN("SRV")=DGFDAI(1) "RTN","DG531014P",92,0) I '$D(DGERR12("DIERR",1,"TEXT",1)) D MES^XPDUTL(" o WEB SERVER '"_DGSRVR_"' addition/update succeeded.") "RTN","DG531014P",93,0) I $D(DGERR12("DIERR",1,"TEXT",1)) D MES^XPDUTL(" o WEB SERVER '"_DGSRVR_"' Error: "_DGERR12("DIERR",1,"TEXT",1)) Q "RTN","DG531014P",94,0) ; once server is set up add the web services in the web service "RTN","DG531014P",95,0) F DGI="CANDIDATE","VALIDATE" D "RTN","DG531014P",96,0) . S DGSRVC=DGPREFIX_DGI "RTN","DG531014P",97,0) . S DGIENS("SRC")="+1," "RTN","DG531014P",98,0) . S DGSRVIEN=0 "RTN","DG531014P",99,0) . F S DGSRVIEN=$O(^XOB(18.12,DGIEN("SRV"),100,"B",DGSRVIEN)) Q:'DGSRVIEN D "RTN","DG531014P",100,0) . . I $$GET1^DIQ(18.02,DGSRVIEN,.01)=DGSRVC S DGIENS("SRC")=DGSRVIEN_"," "RTN","DG531014P",101,0) . I DGIENS("SRC")'="+1," Q ; don't update subentry pointers if already exist. "RTN","DG531014P",102,0) . K DGSERVICE,DGFDAI "RTN","DG531014P",103,0) . S DGSERVICE(18.121,DGIENS("SRC")_DGIENS("SRV"),.01)=DGSRVC "RTN","DG531014P",104,0) . S DGSERVICE(18.121,DGIENS("SRC")_DGIENS("SRV"),.06)="ENABLED" "RTN","DG531014P",105,0) . D UPDATE^DIE("E","DGSERVICE","DGFDAI","DGERR02") ; create new entry "RTN","DG531014P",106,0) . I $D(DGERR02("DIERR",1,"TEXT",1)) D MES^XPDUTL(" o "_DGERR12("DIERR",1,"TEXT",1)) "RTN","DG531014P",107,0) . I '$D(DGERR02("DIERR",1,"TEXT",1)) D MES^XPDUTL(" o "_DGSRVC_" service successfully authorized on server.") "RTN","DG531014P",108,0) Q "RTN","DG531014P",109,0) REGMAP ; Station-to-Region mapping table - Format: ;;Station ID;VISN;Region;VHA Facility Name "RTN","DG531014P",110,0) ;;358;21;Pacific;Manila Outpatient Clinic (Philippines) "RTN","DG531014P",111,0) ;;402;1;North Atlantic;VA Maine Healthcare Systems (Togus) "RTN","DG531014P",112,0) ;;405;1;North Atlantic;White River Junction VA Medical Center "RTN","DG531014P",113,0) ;;436;19;Continental;VA Montana Health Care System (Ft. Harrison, Miles City) "RTN","DG531014P",114,0) ;;437;23;Midwest;Fargo VA Medical Center "RTN","DG531014P",115,0) ;;438;23;Midwest;Royal C. Johnson Veterans Memorial Medical Center (Sioux Falls) "RTN","DG531014P",116,0) ;;442;19;Continental;Cheyenne VA Medical Center "RTN","DG531014P",117,0) ;;459;21;Pacific;VA Pacific Islands Health Care System (Honolulu) "RTN","DG531014P",118,0) ;;460;4;North Atlantic;Wilmington VA Medical Center "RTN","DG531014P",119,0) ;;463;20;Pacific;Alaska VA Healthcare System (Anchorage) "RTN","DG531014P",120,0) ;;501;18;Pacific;New Mexico VA Health Care System (Albuquerque) "RTN","DG531014P",121,0) ;;502;16;Continental;Alexandria VA Health Care System (Pineville) "RTN","DG531014P",122,0) ;;503;4;North Atlantic;Altoona - James E. Van Zandt VA Medical Center "RTN","DG531014P",123,0) ;;504;17;Continental;Amarillo VA Health Care System "RTN","DG531014P",124,0) ;;506;11;Midwest;VA Ann Arbor Healthcare System "RTN","DG531014P",125,0) ;;508;7;Southeast;Atlanta VA Health Care System "RTN","DG531014P",126,0) ;;509;7;Southeast;Charlie Norwood VA Medical Center (Augusta) "RTN","DG531014P",127,0) ;;512;5;North Atlantic;VA Maryland Health Care System (Baltimore, Loch Raven, Perry Point) "RTN","DG531014P",128,0) ;;515;11;Midwest;Battle Creek VA Medical Center "RTN","DG531014P",129,0) ;;516;8;Southeast;C.W. Bill Young VA Medical Center (Bay Pines) "RTN","DG531014P",130,0) ;;517;5;North Atlantic;Beckley VA Medical Center "RTN","DG531014P",131,0) ;;518;1;North Atlantic;Edith Nourse Rogers Memorial Veterans Hospital (Bedford VA) "RTN","DG531014P",132,0) ;;519;17;Continental;West Texas VA Health Care System (Big Spring) "RTN","DG531014P",133,0) ;;520;16;Continental;Gulf Coast Veterans Health Care System (Biloxi) "RTN","DG531014P",134,0) ;;521;7;Southeast;Birmingham VA Medical Center "RTN","DG531014P",135,0) ;;523;1;North Atlantic;VA Boston Health Care System (Jamaica Plain, Brockton, West Roxbury) "RTN","DG531014P",136,0) ;;526;3;North Atlantic;James J. Peters VA Medical Center (Bronx, NY) "RTN","DG531014P",137,0) ;;528;2;North Atlantic;VA Western New York Healthcare System (Buffalo and Batavia) "RTN","DG531014P",138,0) ;;529;4;North Atlantic;VA Butler Healthcare "RTN","DG531014P",139,0) ;;531;20;Pacific;Boise VA Medical Center "RTN","DG531014P",140,0) ;;534;7;Southeast;Ralph H. Johnson VA Medical Center (Charleston) "RTN","DG531014P",141,0) ;;537;12;Midwest;Jesse Brown VA Medical Center (Chicago Westside, Chicago Lakeside) "RTN","DG531014P",142,0) ;;538;10;Midwest;Chillicothe VA Medical Center "RTN","DG531014P",143,0) ;;539;10;Midwest;Cincinnati VA Medical Center "RTN","DG531014P",144,0) ;;540;5;North Atlantic;Louis A. Johnson VA Medical Center (Clarksburg) "RTN","DG531014P",145,0) ;;541;10;Midwest;Louis Stokes Cleveland VA Medical Center "RTN","DG531014P",146,0) ;;542;4;North Atlantic;Coatesville VA Medical Center "RTN","DG531014P",147,0) ;;544;7;Southeast;Wm. Jennings Bryan Dorn VA Medical Center (Columbia) "RTN","DG531014P",148,0) ;;546;8;Southeast;Miami VA Healthcare System "RTN","DG531014P",149,0) ;;548;8;Southeast;West Palm Beach VA Medical Center "RTN","DG531014P",150,0) ;;549;17;Continental;VA North Texas Health Care System (Dallas, Bonham) "RTN","DG531014P",151,0) ;;550;11;Midwest;VA Illiana Health Care System (Danville) "RTN","DG531014P",152,0) ;;552;10;Midwest;Dayton VA Medical Center "RTN","DG531014P",153,0) ;;553;11;Midwest;John D. Dingell VA Medical Center (Detroit) "RTN","DG531014P",154,0) ;;554;19;Continental;VA Eastern Colorado Health Care System (ECHCS) (Denver, Fort Lyon) "RTN","DG531014P",155,0) ;;556;12;Midwest;Captain James A. Lovell Federal Health Care Center (North Chicago) "RTN","DG531014P",156,0) ;;557;7;Southeast;Carl Vinson VA Medical Center (Dublin) "RTN","DG531014P",157,0) ;;558;6;North Atlantic;Durham VA Medical Center "RTN","DG531014P",158,0) ;;561;3;North Atlantic;VA New Jersey Health Care System (East Orange, Lyons) "RTN","DG531014P",159,0) ;;562;4;North Atlantic;Erie VA Medical Center "RTN","DG531014P",160,0) ;;564;16;Continental;Veterans Health Care System of the Ozarks (Fayetteville) "RTN","DG531014P",161,0) ;;565;6;North Atlantic;Fayetteville VA Medical Center "RTN","DG531014P",162,0) ;;568;23;Midwest;VA Black Hills Health Care System (Fort Meade, Hot Springs) "RTN","DG531014P",163,0) ;;570;21;Pacific;Central California VA Health Care System (Fresno) "RTN","DG531014P",164,0) ;;573;8;Southeast;VA North Florida / South Georgia VA Health Care System (Gainesville, Lake City) "RTN","DG531014P",165,0) ;;575;19;Continental;Grand Junction VA Medical Center "RTN","DG531014P",166,0) ;;578;12;Midwest;Edward Hines Jr. VA Hospital (Hines) "RTN","DG531014P",167,0) ;;580;16;Continental;Michael E. DeBakey VA Medical Center (Houston) "RTN","DG531014P",168,0) ;;581;5;North Atlantic;Huntington VA Medical Center "RTN","DG531014P",169,0) ;;583;11;Midwest;Richard L. Roudebush VA Medical Center (Indianapolis) "RTN","DG531014P",170,0) ;;585;12;Midwest;Oscar G. Johnson VA Medical Center (Iron Mountain) "RTN","DG531014P",171,0) ;;586;16;Continental;G.V. (Sonny) Montgomery VA Medical Center (Jackson) "RTN","DG531014P",172,0) ;;589;15;Midwest;VA Eastern Kansas Health Care System (Kansas City, Columbia, Topeka, Leavenworth, Wichita) (formerly VA Heartland - West) "RTN","DG531014P",173,0) ;;590;6;North Atlantic;Hampton VA Medical Center "RTN","DG531014P",174,0) ;;593;21;Pacific;VA Southern Nevada Healthcare System (Las Vegas) "RTN","DG531014P",175,0) ;;595;4;North Atlantic;Lebanon VA Medical Center "RTN","DG531014P",176,0) ;;596;9;Southeast;Lexington VA Medical Center (Leestown, Cooper) "RTN","DG531014P",177,0) ;;598;16;Continental;Central Arkansas Veterans Healthcare System (North Little Rock, Little Rock) "RTN","DG531014P",178,0) ;;600;22;Pacific;VA Long Beach Heathcare System "RTN","DG531014P",179,0) ;;603;9;Southeast;Robley Rex VA Medical Center (Louisville) "RTN","DG531014P",180,0) ;;605;22;Pacific;Jerry L. Pettis Memorial VA Medical Center (Loma Linda) "RTN","DG531014P",181,0) ;;607;12;Midwest;William S. Middleton Memorial Veterans Hospital (Madison) "RTN","DG531014P",182,0) ;;608;1;North Atlantic;Manchester VA Medical Center "RTN","DG531014P",183,0) ;;610;11;Midwest;VA Northern Indiana Health Care System (Marion, Fort Wayne) "RTN","DG531014P",184,0) ;;612;21;Pacific;VA Northern California Health Care System (Mather) "RTN","DG531014P",185,0) ;;613;5;North Atlantic;Martinsburg VA Medical Center "RTN","DG531014P",186,0) ;;614;9;Southeast;Memphis VA Medical Center "RTN","DG531014P",187,0) ;;618;23;Midwest;Minneapolis VA Medical Center "RTN","DG531014P",188,0) ;;619;7;Southeast;Central Alabama Veterans Health Care System (Tuskegee, Montgomery) "RTN","DG531014P",189,0) ;;620;3;North Atlantic;VA Hudson Valley Health Care System (Montrose, Castle Point) "RTN","DG531014P",190,0) ;;621;9;Southeast;James H. Quillen VA Medical Center (Mountain Home) "RTN","DG531014P",191,0) ;;623;19;Continental;Jack C. Montgomery VA Medical Center (Muskogee) "RTN","DG531014P",192,0) ;;626;9;Southeast;VA Tennessee Valley Health Care System (Nashville, Murfreesboro) "RTN","DG531014P",193,0) ;;629;16;Continental;Southeast Louisiana Veterans Health Care System (New Orleans) "RTN","DG531014P",194,0) ;;630;3;North Atlantic;VA New York Harbor Health Care System (Brooklyn, Manhattan) "RTN","DG531014P",195,0) ;;631;1;North Atlantic;VA Central Western Massachusetts Healthcare System (Formerly Northampton VA Medical Center) "RTN","DG531014P",196,0) ;;632;3;North Atlantic;Northport VA Medical Center "RTN","DG531014P",197,0) ;;635;19;Continental;Oklahoma City VA Medical Center "RTN","DG531014P",198,0) ;;636;23;Midwest;VA Nebraska-Western Iowa Health Care System (Omaha, Lincoln, Grand Island of NE, Des Moines, Knoxville, Iowa City of IA) aka VA Central Plains Health Care System "RTN","DG531014P",199,0) ;;637;6;North Atlantic;Asheville VA Medical Center "RTN","DG531014P",200,0) ;;640;21;Pacific;VA Palo Alto Health Care System (Menlo Park, Palo Alto, Livermore) "RTN","DG531014P",201,0) ;;642;4;North Atlantic;Philadelphia VA Medical Center "RTN","DG531014P",202,0) ;;644;18;Pacific;Phoenix VA Health Care System "RTN","DG531014P",203,0) ;;646;4;North Atlantic;VA Pittsburgh Health Care System (Pittsburgh University Dr., H. J. Heinz Campus) "RTN","DG531014P",204,0) ;;648;20;Pacific;VA Portland Health Care System (Portland, Vancouver) "RTN","DG531014P",205,0) ;;649;18;Pacific;Northern Arizona VA Health Care System (Prescott) "RTN","DG531014P",206,0) ;;650;1;North Atlantic;Providence VA Medical Center "RTN","DG531014P",207,0) ;;652;6;North Atlantic;Hunter Holmes McGuire VA Medical Center (Richmond) "RTN","DG531014P",208,0) ;;653;20;Pacific;VA Roseburg Healthcare System "RTN","DG531014P",209,0) ;;654;21;Pacific;VA Sierra Nevada Health Care System (Reno) "RTN","DG531014P",210,0) ;;655;11;Midwest;Aleda E. Lutz VA Medical Center (Saginaw) "RTN","DG531014P",211,0) ;;656;23;Midwest;St. Cloud VA Health Care System "RTN","DG531014P",212,0) ;;657;15;Midwest;VA St. Louis Health Care System (St. Louis, Poplar Bluff, Marion) (formerly VA Heartland East) "RTN","DG531014P",213,0) ;;658;6;North Atlantic;Salem VA Medical Center "RTN","DG531014P",214,0) ;;659;6;North Atlantic;W.G. (Bill) Hefner VA Medical Center (Salisbury) "RTN","DG531014P",215,0) ;;660;19;Continental;VA Salt Lake City Health Care System "RTN","DG531014P",216,0) ;;662;21;Pacific;San Francisco VA Medical Center "RTN","DG531014P",217,0) ;;663;20;Pacific;VA Puget Sound Health Care System (Seattle, American Lake) "RTN","DG531014P",218,0) ;;664;22;Pacific;VA San Diego Healthcare System "RTN","DG531014P",219,0) ;;666;19;Continental;Sheridan VA Medical Center "RTN","DG531014P",220,0) ;;667;16;Continental;Overton Brooks VA Medical Center (Shreveport) "RTN","DG531014P",221,0) ;;668;20;Pacific;Mann-Grandstaff VA Medical Center (Spokane) "RTN","DG531014P",222,0) ;;671;17;Continental;South Texas Veterans Health Care System (San Antonio, Kerrville) "RTN","DG531014P",223,0) ;;672;8;Southeast;VA Caribbean Healthcare System (San Juan) "RTN","DG531014P",224,0) ;;673;8;Southeast;James A. Haley Veterans' Hospital (Tampa) "RTN","DG531014P",225,0) ;;674;17;Continental;Central Texas Veterans Health Care System (Temple, Waco) "RTN","DG531014P",226,0) ;;675;8;Southeast;Orlando VA Medical Center "RTN","DG531014P",227,0) ;;676;12;Midwest;Tomah VA Medical Center "RTN","DG531014P",228,0) ;;678;18;Pacific;Southern Arizona VA Health Care System (Tucson) "RTN","DG531014P",229,0) ;;679;7;Southeast;Tuscaloosa VA Medical Center "RTN","DG531014P",230,0) ;;687;20;Pacific;Jonathan M. Wainwright Memorial VA Medical Center (Walla Walla) "RTN","DG531014P",231,0) ;;688;5;North Atlantic;Washington DC VA Medical Center "RTN","DG531014P",232,0) ;;689;1;North Atlantic;VA Connecticut Health Care System (West Haven, Newington) "RTN","DG531014P",233,0) ;;691;22;Pacific;VA Greater Los Angeles Healthcare System (Los Angeles, West Los Angeles) "RTN","DG531014P",234,0) ;;692;20;Pacific;VA Southern Oregon Rehabilitation Center & Clinics (White City) "RTN","DG531014P",235,0) ;;693;4;North Atlantic;Wilkes-Barre VA Medical Center "RTN","DG531014P",236,0) ;;695;12;Midwest;Clement J. Zablocki Veterans Affairs Medical Center (Milwaukee) "RTN","DG531014P",237,0) ;;740;17;Continental;VA Health Care Center at Harlingen "RTN","DG531014P",238,0) ;;740;17;Continental;VA Texas Valley Coastal Bend Health Care System "RTN","DG531014P",239,0) ;;741;;Continental;HEALTH ADMIN CENTER, CO "RTN","DG531014P",240,0) ;;756;17;Continental;El Paso VA Health Care System "RTN","DG531014P",241,0) ;;757;10;Midwest;Chalmers P. Wylie VA Ambulatory Care Center (Columbus) "RTN","DG531014P",242,0) ;;528A5;2;North Atlantic;Canandaigua VA Medical Center "RTN","DG531014P",243,0) ;;528A6;2;North Atlantic;Bath VA Medical Center "RTN","DG531014P",244,0) ;;528A7;2;North Atlantic;Syracuse VA Medical Center "RTN","DG531014P",245,0) ;;528A8;2;North Atlantic;Albany VA Medical Center (Samuel S. Stratton) "RTN","DG531014P",246,0) ;;589A4;15;Midwest;Columbia VA Medical Center "RTN","DG531014P",247,0) ;;589A5;15;Midwest;East Kansas Health Care System "RTN","DG531014P",248,0) ;;589A7;15;Midwest;Wichita Medical Center "RTN","DG531014P",249,0) ;;636A6;23;Midwest;VA Central Iowa Health Care System (Des Moines) "RTN","DG531014P",250,0) ;;636A8;23;Midwest;Iowa City VA Health Care System "RTN","DG531014P",251,0) ;;657A4;15;Midwest;John J. Pershing VA Medical Center (Popular Bluff) "RTN","DG531014P",252,0) ;;657A5;15;Midwest;Marion Medical Center "RTN","DG531014P",253,0) ;;VISN 2;2;North Atlantic;VISN 2 - Upstate New York Health Care System (Buffalo, Batavia, Canandaigua, Syracuse, Bath, Albany "RTN","DG531014P",254,0) ;;END "RTN","DG531014P",255,0) KEYMAP ; Region 1: North Atlantic, 2: Southeast, 3: Midwest, 4: Continental, 5: Pacific - Format: ;;Region;Key "RTN","DG531014P",256,0) ;;North Atlantic;2xyTcbuRebCNCQi2UjFofcqxU77euN4s "RTN","DG531014P",257,0) ;;Southeast;FKzEuQgt4KGg2ZvNcaDiO94Yoke8SOnM "RTN","DG531014P",258,0) ;;Midwest;YN6kHDcRDNL8zzre8RGI2haDrtSWU365 "RTN","DG531014P",259,0) ;;Continental;oIXW6ik6Ly5zwWkK22TP0BSHZXlxCePU "RTN","DG531014P",260,0) ;;Pacific;hs13RWTYTBcg0EsiaVp59tRCuE4f9CqL "RTN","DG531014P",261,0) ;;Staging;cWhVcsiDfLFQ5TaFskVixKR5Wv5RsZd7 "RTN","DG531014P",262,0) ;;END "RTN","DGADDLST") 0^24^B24537445 "RTN","DGADDLST",1,0) DGADDLST ;ALB/JAM - List Manager Screen for Address Validation ;Jun 12, 2020@12:34 "RTN","DGADDLST",2,0) ;;5.3;Registration;**1014**;AUG 13, 1993;Build 42 "RTN","DGADDLST",3,0) ; "RTN","DGADDLST",4,0) EN(DFN,DGFLDS,DGADDR,DGSELADD) ;Main entry point to invoke the "DGEN ADDR VALID" list - called by DGADDVAL "RTN","DGADDLST",5,0) ; Input: DFN - Patient IEN "RTN","DGADDLST",6,0) ; DGFLDS - String of address field numbers "RTN","DGADDLST",7,0) ; DGADDR (Pass by reference) - Array containing the addresses to list "RTN","DGADDLST",8,0) ; Output: DGSELADD (Pass by reference) - Array containing selected address "RTN","DGADDLST",9,0) ; "RTN","DGADDLST",10,0) ; DGFLDS - Field numbers are in the following format: "RTN","DGADDLST",11,0) ; "AddressLine1,AddressLine2,AddressLine3,City,State,County,Zip,Province,PostalCode^Country" "RTN","DGADDLST",12,0) ; "RTN","DGADDLST",13,0) ; DGADDR Format: "RTN","DGADDLST",14,0) ; DGADDR = Total number of records "RTN","DGADDLST",15,0) ; DGADDR(Counter,field#)=VALUE ForState: VALUE = "STATENAME^STATECODE" "RTN","DGADDLST",16,0) ; For Country: VALUE = "COUNTRY^COUNTRYCODE" "RTN","DGADDLST",17,0) ; "RTN","DGADDLST",18,0) ; DGSELADD Format: "RTN","DGADDLST",19,0) ; DGSELADD(field#)=VALUE ForState: VALUE = "STATENAME^STATECODE" "RTN","DGADDLST",20,0) ; For Country: VALUE = "COUNTRY^COUNTRYCODE" "RTN","DGADDLST",21,0) ; "RTN","DGADDLST",22,0) D WAIT^DICD "RTN","DGADDLST",23,0) D EN^VALM("DGEN ADDR VALID") "RTN","DGADDLST",24,0) N VALMHDR,VALMBCK,VALMCNT,VALMSG,XQORM "RTN","DGADDLST",25,0) Q "RTN","DGADDLST",26,0) ; "RTN","DGADDLST",27,0) HDR ;Header code "RTN","DGADDLST",28,0) N X,DGSSNSTR,DGPTYPE,DGSSN,DGDOB "RTN","DGADDLST",29,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) ; add member id (edipi) and preferred name to banner "RTN","DGADDLST",30,0) S DGSSN=$P($P(DGSSNSTR,";",2)," ",3) "RTN","DGADDLST",31,0) S DGDOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","DGADDLST",32,0) S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1)) "RTN","DGADDLST",33,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGADDLST",34,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGADDLST",35,0) ; If coming from screen 1.1, change the screen title to specify this as screen 1.2 "RTN","DGADDLST",36,0) ; - DGPRS is a system-wide variable containing the screen number "RTN","DGADDLST",37,0) ; - VALM array is used by ListMan (do not NEW this variable) "RTN","DGADDLST",38,0) ; It contains data for the screen and is used to maintain the call stack when a Listman screen flows to another ListMan screen. "RTN","DGADDLST",39,0) ; Changes to VALM entries are unwound after exit - Listman restores the entries of the previous stack level. "RTN","DGADDLST",40,0) I $G(DGRPS)=1.1 S VALM("TITLE")="Address Validation <1.2>" "RTN","DGADDLST",41,0) S VALMHDR(1)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB "RTN","DGADDLST",42,0) S VALMHDR(2)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE "RTN","DGADDLST",43,0) S XQORM("B")="SEL" "RTN","DGADDLST",44,0) Q "RTN","DGADDLST",45,0) ; "RTN","DGADDLST",46,0) INIT ;Build address screen "RTN","DGADDLST",47,0) D CLEAN^VALM10 "RTN","DGADDLST",48,0) K ^TMP("DGADDVAL",$J) "RTN","DGADDLST",49,0) N DGGLBL,DGCNT,DGZ,DGCTRYCD,DGFORGN,DGZIP "RTN","DGADDLST",50,0) S DGGLBL=$NA(^TMP("DGADDVAL",$J)) "RTN","DGADDLST",51,0) S VALMCNT=0,DGCNT=0 "RTN","DGADDLST",52,0) F S DGCNT=$O(DGADDR(DGCNT)) Q:'DGCNT D "RTN","DGADDLST",53,0) . ; Get Country code and determine if this is domestic/foreign address "RTN","DGADDLST",54,0) . S DGCTRYCD=$P(DGADDR(DGCNT,$P(DGFLDS,",",10)),"^",2) "RTN","DGADDLST",55,0) . S DGFORGN=0 "RTN","DGADDLST",56,0) . S DGFORGN=$$FORIEN^DGADDUTL(DGCTRYCD) "RTN","DGADDLST",57,0) . ; Save to List Manager array for display "RTN","DGADDLST",58,0) . ; Address line 1 "RTN","DGADDLST",59,0) . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",60,0) . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",1)) "RTN","DGADDLST",61,0) . S DGZ="["_DGCNT_"] "_DGZ "RTN","DGADDLST",62,0) . S @DGGLBL@(VALMCNT,0)=DGZ "RTN","DGADDLST",63,0) . ; Address line 2 "RTN","DGADDLST",64,0) . I $G(DGADDR(DGCNT,$P(DGFLDS,",",2)))'="" D "RTN","DGADDLST",65,0) . . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",66,0) . . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",2)) "RTN","DGADDLST",67,0) . . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",68,0) . ; Address line 3 "RTN","DGADDLST",69,0) . I $G(DGADDR(DGCNT,$P(DGFLDS,",",3)))'="" D "RTN","DGADDLST",70,0) . . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",71,0) . . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",3)) "RTN","DGADDLST",72,0) . . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",73,0) . ; Put together line for city, state zip or city Province Postal Code "RTN","DGADDLST",74,0) . S DGZ="" "RTN","DGADDLST",75,0) . ; City "RTN","DGADDLST",76,0) . I $G(DGADDR(DGCNT,$P(DGFLDS,",",4)))'="" D "RTN","DGADDLST",77,0) . . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",4)) "RTN","DGADDLST",78,0) . ; For domestic address, add State and Zip "RTN","DGADDLST",79,0) . I 'DGFORGN D "RTN","DGADDLST",80,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",5)))'="" D "RTN","DGADDLST",81,0) . . . ; State "RTN","DGADDLST",82,0) . . . S DGZ=DGZ_","_$P(DGADDR(DGCNT,$P(DGFLDS,",",5)),"^",1) "RTN","DGADDLST",83,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",7)))'="" D "RTN","DGADDLST",84,0) . . . ; Zip "RTN","DGADDLST",85,0) . . . S DGZIP=DGADDR(DGCNT,$P(DGFLDS,",",7)) "RTN","DGADDLST",86,0) . . . S:$L(DGZIP)>5 DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,9) "RTN","DGADDLST",87,0) . . . S DGZ=DGZ_" "_DGZIP "RTN","DGADDLST",88,0) . ; For foreign address, add Province and Postal Code "RTN","DGADDLST",89,0) . I DGFORGN D "RTN","DGADDLST",90,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",8)))'="" D "RTN","DGADDLST",91,0) . . . ; Province "RTN","DGADDLST",92,0) . . . S DGZ=DGZ_" "_DGADDR(DGCNT,$P(DGFLDS,",",8)) "RTN","DGADDLST",93,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",9)))'="" D "RTN","DGADDLST",94,0) . . . ; Postal Code "RTN","DGADDLST",95,0) . . . S DGZ=DGZ_" "_DGADDR(DGCNT,$P(DGFLDS,",",9)) "RTN","DGADDLST",96,0) . ; Add the City string to list "RTN","DGADDLST",97,0) . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",98,0) . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",99,0) . ; Country "RTN","DGADDLST",100,0) . S DGZ=$$CNTRYI^DGADDUTL(DGCTRYCD) "RTN","DGADDLST",101,0) . S DGZ=$S(DGZ="":"UNSPECIFIED COUNTRY",DGZ=-1:"UNKNOWN COUNTRY",1:DGZ) "RTN","DGADDLST",102,0) . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",103,0) . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",104,0) . ; "RTN","DGADDLST",105,0) . I DGCNT=1 S VALMCNT=VALMCNT+1,@DGGLBL@(VALMCNT,0)=" (User Entered Address)" "RTN","DGADDLST",106,0) . I DGCNT>1 D "RTN","DGADDLST",107,0) . . S DGZ=" " "RTN","DGADDLST",108,0) . . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",109,0) . . I $G(DGADDR(DGCNT,"deliveryPoint"))'="" S DGZ=DGZ_"Delivery Point: "_DGADDR(DGCNT,"deliveryPoint")_" " "RTN","DGADDLST",110,0) . . S DGZ=DGZ_"Confidence Score: "_$G(DGADDR(DGCNT,"confidenceScore")) "RTN","DGADDLST",111,0) . . S @DGGLBL@(VALMCNT,0)=DGZ "RTN","DGADDLST",112,0) Q "RTN","DGADDLST",113,0) ; "RTN","DGADDLST",114,0) HELP ;Help code "RTN","DGADDLST",115,0) S X="?" D DISP^XQORM1 W !! "RTN","DGADDLST",116,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGADDLST",117,0) Q "RTN","DGADDLST",118,0) ; "RTN","DGADDLST",119,0) EXIT ;Exit code "RTN","DGADDLST",120,0) D CLEAN^VALM10 "RTN","DGADDLST",121,0) D CLEAR^VALM1 "RTN","DGADDLST",122,0) K ^TMP("DGADDVAL",$J) "RTN","DGADDLST",123,0) Q "RTN","DGADDLST",124,0) ; "RTN","DGADDLST",125,0) PEXIT ;DGEN ADD VALID 1.2 MENU protocol exit code "RTN","DGADDLST",126,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGADDLST",127,0) S XQORM("B")="SEL" "RTN","DGADDLST",128,0) Q "RTN","DGADDLST",129,0) ; "RTN","DGADDLST",130,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGADDLST",131,0) ; = "SEL" - Select an Address - "RTN","DGADDLST",132,0) ; "RTN","DGADDLST",133,0) N DGSEL "RTN","DGADDLST",134,0) ; SEL - user selects one address from the list - merge it into the return array "RTN","DGADDLST",135,0) I DGACT="SEL" S DGSEL=$$SEL() I DGSEL M DGSELADD=DGADDR(DGSEL) Q "RTN","DGADDLST",136,0) ; "RTN","DGADDLST",137,0) S VALMBCK="R" "RTN","DGADDLST",138,0) S XQORM("B")="SEL" "RTN","DGADDLST",139,0) Q "RTN","DGADDLST",140,0) ; "RTN","DGADDLST",141,0) SEL() ; function, prompt to select address "RTN","DGADDLST",142,0) N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y "RTN","DGADDLST",143,0) S DIR(0)="NA^1:"_DGADDR "RTN","DGADDLST",144,0) S DIR("A",1)="",DIR("A")="Select Address (1-"_DGADDR_"): " D ^DIR K DIR "RTN","DGADDLST",145,0) Q X "RTN","DGADDVAL") 0^23^B11247230 "RTN","DGADDVAL",1,0) DGADDVAL ;ALB/JAM - UAM Address Validation ;28 May 2020 10:33 AM "RTN","DGADDVAL",2,0) ;;5.3;Registration;**1014**;Aug 13, 1993;Build 42 "RTN","DGADDVAL",3,0) ; "RTN","DGADDVAL",4,0) EN(DGINPUT,DGTYPE) ; Main entry point "RTN","DGADDVAL",5,0) ; Input: DGINPUT (Required, pass by reference) - Array containing the address to be validated "RTN","DGADDVAL",6,0) ; DGTYPE (optional) - Address Type: "R"-Residential "C"-Confidential "P"-Permanent (default) "RTN","DGADDVAL",7,0) ; Output: DGINPUT (Pass by reference) - Array will contain the address accepted by the user "RTN","DGADDVAL",8,0) ; Return: 0 - error has been encountered "RTN","DGADDVAL",9,0) ; 1 - validation is completed and DGINPUT contains the accepted address "RTN","DGADDVAL",10,0) ; "RTN","DGADDVAL",11,0) ; Format of DGINPUT array "RTN","DGADDVAL",12,0) ; DGINPUT(field#)=VALUE "RTN","DGADDVAL",13,0) ; "RTN","DGADDVAL",14,0) ; Note: For Residential and Perm Addresses: "RTN","DGADDVAL",15,0) ; State VALUE = "STATENAME^STATECODE" "RTN","DGADDVAL",16,0) ; Country VALUE = "COUNTRY^COUNTRYCODE" "RTN","DGADDVAL",17,0) ; County VALUE = "COUNTY^COUNTYCODE "RTN","DGADDVAL",18,0) ; For Confidential Addresses: "RTN","DGADDVAL",19,0) ; State VALUE = "STATECODE^STATENAME" "RTN","DGADDVAL",20,0) ; Country VALUE = "COUNTRYCODE^COUNTRY" "RTN","DGADDVAL",21,0) ; County VALUE = "COUNTYCODE^COUNTY "RTN","DGADDVAL",22,0) ; "RTN","DGADDVAL",23,0) N DGCNT,DGADDR,DGFLDS,DGFORGN,DGCTRYCD,DGSTR,DGX,DGRECS,DGSELADD,DGSTAT,DGSTATECD "RTN","DGADDVAL",24,0) ; "RTN","DGADDVAL",25,0) ; Set up string of address field numbers - Format: "RTN","DGADDVAL",26,0) ; "AddressLine1,AddressLine2,AddressLine3,City,State,County,Zip,Province,PostalCode^Country" "RTN","DGADDVAL",27,0) S DGFLDS=".111,.112,.113,.114,.115,.117,.1112,.1171,.1172,.1173" ; Permanent Address fields "RTN","DGADDVAL",28,0) I $G(DGTYPE)="R" S DGFLDS=".1151,.1152,.1153,.1154,.1155,.1157,.1156,.11571,.11572,.11573" ; Residential address fields "RTN","DGADDVAL",29,0) I $G(DGTYPE)="C" S DGFLDS=".1411,.1412,.1413,.1414,.1415,.14111,.1416,.14114,.14115,.14116" ; Confidential address fields "RTN","DGADDVAL",30,0) ; "RTN","DGADDVAL",31,0) ; All addresses are placed in the DGADDR array for user selection "RTN","DGADDVAL",32,0) ; First address displayed is the address DGINPUT "RTN","DGADDVAL",33,0) S DGCNT=1 "RTN","DGADDVAL",34,0) M DGADDR(DGCNT)=DGINPUT "RTN","DGADDVAL",35,0) ; Normalize the Country and State entries for Conf address in DGADDR so the format is the same for all addresses in DGADDR array "RTN","DGADDVAL",36,0) I DGTYPE="C" D "RTN","DGADDVAL",37,0) . ; State may not be defined "RTN","DGADDVAL",38,0) . I $D(DGADDR(1,$P(DGFLDS,",",5))) S DGX=DGADDR(1,$P(DGFLDS,",",5)),DGADDR(1,$P(DGFLDS,",",5))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",39,0) . S DGX=DGADDR(1,$P(DGFLDS,",",10)),DGADDR(1,$P(DGFLDS,",",10))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",40,0) ; Capture the State code passed in "RTN","DGADDVAL",41,0) S DGCTRYCD=$P(DGADDR(1,$P(DGFLDS,",",10)),"^",2) "RTN","DGADDVAL",42,0) ; Get flag for domestic/foreign address "RTN","DGADDVAL",43,0) S DGFORGN=0 "RTN","DGADDVAL",44,0) S DGFORGN=$$FORIEN^DGADDUTL(DGCTRYCD) "RTN","DGADDVAL",45,0) I 'DGFORGN S DGSTATECD=$P(DGADDR(1,$P(DGFLDS,",",5)),"^",2) "RTN","DGADDVAL",46,0) ; "RTN","DGADDVAL",47,0) ; Call the validation service "RTN","DGADDVAL",48,0) S DGSTAT=$$EN^DGUAMWS(.DGADDR,DGFLDS,DGFORGN) ; DGADDR is updated with address validation results "RTN","DGADDVAL",49,0) I +DGSTAT=0 QUIT DGSTAT "RTN","DGADDVAL",50,0) ; get total records returned. Subtract one for the original. "RTN","DGADDVAL",51,0) S DGRECS=$O(DGADDR(""),-1)-1 "RTN","DGADDVAL",52,0) F DGX=1:1:DGRECS D "RTN","DGADDVAL",53,0) . S DGCNT=DGCNT+1 "RTN","DGADDVAL",54,0) . ; Store in this array entry the same country that was passed in "RTN","DGADDVAL",55,0) . S DGADDR(DGCNT,$P(DGFLDS,",",10))=DGADDR(1,$P(DGFLDS,",",10)) "RTN","DGADDVAL",56,0) . I 'DGFORGN D "RTN","DGADDVAL",57,0) . . ; Store the same county that was passed in "RTN","DGADDVAL",58,0) . . S DGADDR(DGCNT,$P(DGFLDS,",",6))=DGADDR(1,$P(DGFLDS,",",6)) "RTN","DGADDVAL",59,0) ; "RTN","DGADDVAL",60,0) ; Call DGEN ADDR VAL list to show addresses and allow user selection "RTN","DGADDVAL",61,0) S DGADDR=DGCNT "RTN","DGADDVAL",62,0) D EN^DGADDLST(DFN,DGFLDS,.DGADDR,.DGSELADD) "RTN","DGADDVAL",63,0) ; Move selected address into DGINPUT array "RTN","DGADDVAL",64,0) M DGINPUT=DGSELADD "RTN","DGADDVAL",65,0) ; Put the State and Country fields back in DGINPUT to the format used for Conf addresses "RTN","DGADDVAL",66,0) I DGTYPE="C" D "RTN","DGADDVAL",67,0) . I $D(DGADDR(1,$P(DGFLDS,",",5))) D "RTN","DGADDVAL",68,0) . . S DGX=DGINPUT($P(DGFLDS,",",5)),DGINPUT($P(DGFLDS,",",5))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",69,0) . . ; If the State code is empty, put the original State code in the array - Confidential Address needs the State code to file "RTN","DGADDVAL",70,0) . . I $P(DGINPUT($P(DGFLDS,",",5)),"^",1)="" S $P(DGINPUT($P(DGFLDS,",",5)),"^",1)=DGSTATECD "RTN","DGADDVAL",71,0) . S DGX=DGINPUT($P(DGFLDS,",",10)),DGINPUT($P(DGFLDS,",",10))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",72,0) Q 1 "RTN","DGDEP") 0^1^B9896841 "RTN","DGDEP",1,0) DGDEP ;ALB/CAW,BAJ,ARF - Dependent Driver ; 8/1/08 12:55pm "RTN","DGDEP",2,0) ;;5.3;Registration;**45,688,1014**;Aug 13, 1993;Build 42 "RTN","DGDEP",3,0) ; "RTN","DGDEP",4,0) EN ; "RTN","DGDEP",5,0) S VALMBCK="" "RTN","DGDEP",6,0) D WAIT^DICD,EN^VALM("DGMT DEPENDENTS") "RTN","DGDEP",7,0) S VALMBCK="R" "RTN","DGDEP",8,0) ENQ K DEP,DGCNT,DGDEP,DGIR0,DGINI,DGLN,DGPRI,DGREL,^TMP("DGDEP",$J) "RTN","DGDEP",9,0) Q "RTN","DGDEP",10,0) ; "RTN","DGDEP",11,0) PAT ; Patient Lookup "RTN","DGDEP",12,0) N DIC,Y "RTN","DGDEP",13,0) S DIC="^DPT(",DIC(0)="AEMQZ" D ^DIC I Y'>0 G PATQ "RTN","DGDEP",14,0) I ($G(DTOUT)!$G(DUOUT)) G PATQ "RTN","DGDEP",15,0) S DFN=+Y "RTN","DGDEP",16,0) PATQ Q "RTN","DGDEP",17,0) ; "RTN","DGDEP",18,0) HDR ; Header "RTN","DGDEP",19,0) N VA,VAERR,SSNV "RTN","DGDEP",20,0) D PID^VADPT "RTN","DGDEP",21,0) ; Capture and display SSN Verification Status with SSN BAJ DG*5.3*688 11/22/2005 "RTN","DGDEP",22,0) D GETSTAT^DGRP1(.SSNV) "RTN","DGDEP",23,0) I $G(DGSCR8) D G HDRQ "RTN","DGDEP",24,0) .S X="",VALMHDR(1)=" FAMILY DEMOGRAPHIC DATA, SCREEN <8>" "RTN","DGDEP",25,0) .S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),80-$L(X),$L(X)) "RTN","DGDEP",26,0) .D LISTHDR^DGRPU(2) ;DG*5.3*1014 - ARF - sets patient data in the 2nd and 3rd entries in VALMHDR array "RTN","DGDEP",27,0) .;S VALMHDR(2)=$E($P("Patient: "_$G(^DPT(DFN,0)),"^",1),1,30)_" ("_VA("PID")_")"_" "_SSNV ;DG*5.3*1014 "RTN","DGDEP",28,0) .;S X=$S($D(^DPT(DFN,.1)):"Ward: "_^(.1),1:"Outpatient") ;DG*5.3*1014 and next line ;DG*5.3*1014 - Ward removed "RTN","DGDEP",29,0) .;S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),80-$L(X),$L(X)) ;DG*5.3*1014 "RTN","DGDEP",30,0) S X="",VALMHDR(1)=" MARITAL STATUS/DEPENDENTS, SCREEN <1>" "RTN","DGDEP",31,0) S VALMHDR(2)=$E($P("Patient: "_$G(^DPT(DFN,0)),"^",1),1,30)_" ("_VA("PID")_")"_" "_SSNV "RTN","DGDEP",32,0) S X=$S($D(^DPT(DFN,.1)):"Ward: "_^(.1),1:"Outpatient") "RTN","DGDEP",33,0) S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),80-$L(X),$L(X)) "RTN","DGDEP",34,0) HDRQ Q "RTN","DGDEP",35,0) ; "RTN","DGDEP",36,0) INIT ; Find all dependents "RTN","DGDEP",37,0) K DGDEP("DGDEP",$J),^TMP("DGDEP",$J) "RTN","DGDEP",38,0) N CNT,DGDATE,DGDDEP0,DGINCP,DGINI,DGIRI,DGWHERE "RTN","DGDEP",39,0) D NEW^DGRPEIS1 ; Sets up veteran in person file "RTN","DGDEP",40,0) ; Get all active dependents "RTN","DGDEP",41,0) D ALL^DGMTU21(DFN,"VSD",$S($G(DGMTDT):DGMTDT,1:DT),"IPR",$G(DGMTI)) "RTN","DGDEP",42,0) ; "RTN","DGDEP",43,0) ; Get all dependents active and inactive "RTN","DGDEP",44,0) S (CNT,DGDEP)=0,DGLN=1 "RTN","DGDEP",45,0) F S DGDEP=$O(^DGPR(408.12,"B",DFN,DGDEP)) Q:'DGDEP D "RTN","DGDEP",46,0) .N DGDEP0 S CNT=CNT+1 "RTN","DGDEP",47,0) .S DGDEP0=^DGPR(408.12,DGDEP,0) "RTN","DGDEP",48,0) .D GETIENS^DGMTU2(DFN,+DGDEP,$S($G(DGMTDT):DGMTDT,1:DT)) ;Get Annual Income IEN and Income Person IEN "RTN","DGDEP",49,0) .S DGWHERE=$P(DGDEP0,U,3) "RTN","DGDEP",50,0) .S DGINCP=$G(@("^"_$P(DGWHERE,";",2)_+DGWHERE_",0)")) "RTN","DGDEP",51,0) .S DGDEP("DGDEP",$J,$P(DGDEP0,U,2),CNT)=DGINCP "RTN","DGDEP",52,0) .S $P(DGDEP("DGDEP",$J,$P(DGDEP0,U,2),CNT),U,20)=DGDEP "RTN","DGDEP",53,0) .S $P(DGDEP("DGDEP",$J,$P(DGDEP0,U,2),CNT),U,21)=$S($G(DGINI):DGINI,1:$G(DGINC)) "RTN","DGDEP",54,0) .S $P(DGDEP("DGDEP",$J,$P(DGDEP0,U,2),CNT),U,22)=$S($G(DGIRI):DGIRI,1:$G(DGINR)) "RTN","DGDEP",55,0) .N DGEDATE S DGEDATE=0 "RTN","DGDEP",56,0) .F S DGEDATE=$O(^DGPR(408.12,DGDEP,"E",DGEDATE)) Q:'DGEDATE D "RTN","DGDEP",57,0) ..S DGDATE=^DGPR(408.12,DGDEP,"E",DGEDATE,0) "RTN","DGDEP",58,0) ..S DGDEP("DGDEP",$J,$P(DGDEP0,U,2),CNT,-$P(DGDATE,U))=DGDATE "RTN","DGDEP",59,0) D RETDEP^DGDEP0 "RTN","DGDEP",60,0) S VALMCNT=DGLN-1 "RTN","DGDEP",61,0) Q "RTN","DGDEP",62,0) ; "RTN","DGDEP",63,0) SET(X) ; Set in array "RTN","DGDEP",64,0) ; "RTN","DGDEP",65,0) S ^TMP("DGDEP",$J,DGLN,0)=X,^TMP("DGDEP",$J,"IDX",CNT,CNT)="" "RTN","DGDEP",66,0) S DGLN=DGLN+1 "RTN","DGDEP",67,0) Q "RTN","DGDEPE") 0^13^B1701846 "RTN","DGDEPE",1,0) DGDEPE ;ALB/CAW,ARF - Extended Display ; 1/28/92 "RTN","DGDEPE",2,0) ;;5.3;Registration;**45,1014**;Aug 13, 1993;Build 42 "RTN","DGDEPE",3,0) ; "RTN","DGDEPE",4,0) EN ; Selection of dependent "RTN","DGDEPE",5,0) G ENQ:'$D(DGW)!$G(DGERR)=1 "RTN","DGDEPE",6,0) K DGDEP("DGMTEP",$J) "RTN","DGDEPE",7,0) S VALMBCK="" "RTN","DGDEPE",8,0) N DGWIDTH,DGPT,DGSC "RTN","DGDEPE",9,0) W ! D WAIT^DICD,EN^VALM("DGMT EXPAND PROFILE") "RTN","DGDEPE",10,0) ENQ S VALMBCK="R" Q "RTN","DGDEPE",11,0) ; "RTN","DGDEPE",12,0) HDR ; Header "RTN","DGDEPE",13,0) N VA,VAERR "RTN","DGDEPE",14,0) D LISTHDR^DGRPU(1) ;DG*5.3*1014 - ARF - sets patient data in the 1st and 2nd entries in VALMHDR array "RTN","DGDEPE",15,0) S X="",VALMHDR(3)=$$SETSTR^VALM1(X,"Dependent #: "_DGW_" "_$P(DGDEP(DGW),U)_"("_$P(DGDEP(DGW),U,2)_")",81-$L(X),$L(X)) ;DG*5.3*1014 begin "RTN","DGDEPE",16,0) ;D PID^VADPT "RTN","DGDEPE",17,0) ;S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(DFN,0)),"^",1),1,30)_" ("_VA("BID")_")" "RTN","DGDEPE",18,0) ;S X=$S($D(^DPT(DFN,.1)):"Ward: "_^(.1),1:"Outpatient") ;Ward is no longer included in banners "RTN","DGDEPE",19,0) ;S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X)) "RTN","DGDEPE",20,0) ;S X="",VALMHDR(2)=$$SETSTR^VALM1(X,"Dependent #: "_DGW_" "_$P(DGDEP(DGW),U)_"("_$P(DGDEP(DGW),U,2)_")",81-$L(X),$L(X)) ;DG*5.3*1014 end "RTN","DGDEPE",21,0) Q "RTN","DGDEPE",22,0) ; "RTN","DGDEPE",23,0) INIT ; "RTN","DGDEPE",24,0) N VA,VAERR,DGFSTCOL,DGSECCOL "RTN","DGDEPE",25,0) D PID^VADPT "RTN","DGDEPE",26,0) D ONE^DGDEP1(DGW) "RTN","DGDEPE",27,0) Q "RTN","DGDEPE",28,0) ; "RTN","DGDEPE",29,0) FNL ; "RTN","DGDEPE",30,0) D CLEAN^VALM10 "RTN","DGDEPE",31,0) Q "RTN","DGENA6") 0^41^B32233157 "RTN","DGENA6",1,0) DGENA6 ;ALB/CJM,ISA,KWP,RTK,LBD,CKN - Enrollment API to create enrollment record; 04/24/03 ; 8/31/05 2:44pm "RTN","DGENA6",2,0) ;;5.3;Registration;**232,327,417,491,513,672,940,993,1014**;Aug 13, 1993;Build 42 "RTN","DGENA6",3,0) ; "RTN","DGENA6",4,0) ;CREATE line tag moved from DGENA in DG*5.3*232.;MM "RTN","DGENA6",5,0) ; "RTN","DGENA6",6,0) CREATE(DFN,APP,EFFDATE,REASON,REMARKS,DGENR,ENRDATE,END,DGENRYN) ; DG*5.3*993 Added 7th parameter DGENRYN "RTN","DGENA6",7,0) ;Description: Creates a local enrollment as a local array. "RTN","DGENA6",8,0) ;Input : "RTN","DGENA6",9,0) ; DFN- Patient IEN "RTN","DGENA6",10,0) ; APP - the Enrollment Application Date to use "RTN","DGENA6",11,0) ; EFFDATE - the Effective Date, if NULL assume the same as the "RTN","DGENA6",12,0) ; Enrollment Date "RTN","DGENA6",13,0) ; REASON - used to create an enrollment with CANCELLED/DECLINED status, "RTN","DGENA6",14,0) ; pass in the code for REASON CANCELED/DECLINED "RTN","DGENA6",15,0) ; REMARKS - if creating an enrollment with CANCELLED/DECLINED status, "RTN","DGENA6",16,0) ; and the reason is can optionally pass in textual remarks for "RTN","DGENA6",17,0) ; CANCELED/DECLINED REMARKS "RTN","DGENA6",18,0) ; ENRDATE - the Enrollment Date to use (optional) "RTN","DGENA6",19,0) ; END - the Enrollment End Date to use (optional) "RTN","DGENA6",20,0) ; DGENRYN - (Optional) ENROLL Y/N question for registration 0=NO 1=YES "RTN","DGENA6",21,0) ;Output: "RTN","DGENA6",22,0) ; Function Value - returns 1 if successful, 0 otherwise "RTN","DGENA6",23,0) ; DGENR - a local array where the enrollment object will be stored, "RTN","DGENA6",24,0) ; pass by reference "RTN","DGENA6",25,0) ; "RTN","DGENA6",26,0) K DGENR "RTN","DGENA6",27,0) S DGENR="",DGENRYN=$G(DGENRYN) "RTN","DGENA6",28,0) N DGELGSUB,PRIORITY,DEATH,PRIGRP,DODUPD,DGSTUS,DGNOW,DGEIEN,DGENFLG,DGREG "RTN","DGENA6",29,0) S DGREG=1 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans. "RTN","DGENA6",30,0) S DGEIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENA6",31,0) I DGEIEN S DGENFLG=$$GET1^DIQ(27.11,DGEIEN_",",.14,"I") "RTN","DGENA6",32,0) ;S DGNOW=$$NOW^XLFDT() "RTN","DGENA6",33,0) ;Re-Enrollment - var PRIGRP contains priority and subgroup "RTN","DGENA6",34,0) S PRIGRP=$$PRIORITY^DGENELA4(DFN,,.DGELGSUB,$G(ENRDATE),$G(APP),$G(DGENRYN)) ;DG*5.3*993 Added 6th parameter DGENRYN "RTN","DGENA6",35,0) S PRIORITY=$P(PRIGRP,"^") ; Re-Enrollment - Priority is first piece "RTN","DGENA6",36,0) S DGENR("APP")=$G(APP) "RTN","DGENA6",37,0) S DGENR("DATE")=$G(ENRDATE) "RTN","DGENA6",38,0) S DGENR("END")=$G(END) "RTN","DGENA6",39,0) S DGENR("DFN")=DFN "RTN","DGENA6",40,0) S DGENR("SOURCE")=1 "RTN","DGENA6",41,0) I $G(DGENRYN)=0,$G(DGENR("STATUS"))'=6 S DGENR("STATUS")=25 "RTN","DGENA6",42,0) I $G(DGENFLG)=0,$G(DGENR("STATUS"))'=6 S DGENR("STATUS")=25 "RTN","DGENA6",43,0) I ($G(DGENFLG)=0)!($G(DGENRYN)=0) S DGREG=0 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans. "RTN","DGENA6",44,0) D ;drops out of block when status is determined "RTN","DGENA6",45,0) .I $G(REASON) D Q "RTN","DGENA6",46,0) ..S DGENR("STATUS")=7,DGENR("REMARKS")=$G(REMARKS),DGENR("REASON")=REASON ;CANCELED/DECLINED "RTN","DGENA6",47,0) .E S DGENR("REMARKS")="",DGENR("REASON")="" "RTN","DGENA6",48,0) .S DEATH=$$DEATH^DGENPTA(DFN) "RTN","DGENA6",49,0) .I DEATH D Q "RTN","DGENA6",50,0) ..S DGENR("STATUS")=6 ;DECEASED "RTN","DGENA6",51,0) ..S DGENR("END")=DEATH "RTN","DGENA6",52,0) ..S DODUPD=$P($G(^DPT(DFN,.35)),"^",4) ;Get Date of Death last updated date "RTN","DGENA6",53,0) ..;S EFFDATE=DEATH ;Removed - DG*5.3*672 "RTN","DGENA6",54,0) ..S EFFDATE=$S($G(DODUPD)'="":DODUPD,1:DT) ;DG*5.3*672 "RTN","DGENA6",55,0) ..;Find patient's current enrollment record "RTN","DGENA6",56,0) ..N DGENRIEN,DGENRC "RTN","DGENA6",57,0) ..S DGENRIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENA6",58,0) ..I DGENRIEN S:$G(DGENRYN)="" DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I") ;DG*5.3*993 Added REGISTRATION ONLY "RTN","DGENA6",59,0) ..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC) "RTN","DGENA6",60,0) ..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date "RTN","DGENA6",61,0) .I DGREG,'$$VET^DGENPTA(DFN) D Q ;NOT ELIGIBLE ; DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans. "RTN","DGENA6",62,0) ..N DGPAT,DGENRIEN,DGENRC "RTN","DGENA6",63,0) ..S DGENR("STATUS")=20 ;new status for Ineligible Project "RTN","DGENA6",64,0) ..;Find patient's current enrollment record "RTN","DGENA6",65,0) ..S DGENRIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENA6",66,0) ..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC) "RTN","DGENA6",67,0) ..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date "RTN","DGENA6",68,0) ..;Phase II The TESTVAL was moved from DGENA1 to DGENA3 (SRS 6.5.2.1) "RTN","DGENA6",69,0) ..;if vet has an Ineligible Date then the Effective Date should be the later of the Ineligible Date or App Date "RTN","DGENA6",70,0) ..I $$GET^DGENPTA(DFN,.DGENPTA),DGENPTA("INELDATE"),$$TESTVAL^DGENA3("EFFDATE",DGENPTA("INELDATE")),DGENRC=1 S EFFDATE=$G(DGENPTA("INELDATE")) "RTN","DGENA6",71,0) ..I '$G(EFFDATE) S EFFDATE=$G(APP) "RTN","DGENA6",72,0) ..;If currently enrolled, set end date = ineligible date "RTN","DGENA6",73,0) ..I DGENRC=1 S DGENR("END")=$G(DGENPTA("INELDATE")) "RTN","DGENA6",74,0) ..;If not currently enrolled or no ineligible date, set end date = application date "RTN","DGENA6",75,0) ..I '$G(DGENR("END")) S DGENR("END")=$G(APP) "RTN","DGENA6",76,0) .;Determine preliminary enrollment status based on enrollment group threshold "RTN","DGENA6",77,0) .;Get enrollment group threshold "RTN","DGENA6",78,0) .N DGEGTIEN,DGEGT,DGENRC,DGENRIEN "RTN","DGENA6",79,0) .S DGEGTIEN=$$FINDCUR^DGENEGT "RTN","DGENA6",80,0) .S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT) "RTN","DGENA6",81,0) .;If patient's enrollment status not above enrollment group threshold "RTN","DGENA6",82,0) .;set status to Rejected: Initial Application by VAMC) "RTN","DGENA6",83,0) .I $G(PRIORITY)'="",'$$ABOVE2^DGENEGT1(DFN,$G(APP),PRIORITY,$P(PRIGRP,U,2)) D Q "RTN","DGENA6",84,0) ..;Find patient's current enrollment record "RTN","DGENA6",85,0) ..S DGENRIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENA6",86,0) ..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC) "RTN","DGENA6",87,0) ..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date "RTN","DGENA6",88,0) ..S DGENR("END")=$G(APP) ;enrollment end date = application date "RTN","DGENA6",89,0) ..S EFFDATE=$G(APP) ; effective date = application date "RTN","DGENA6",90,0) ..S DGENR("STATUS")=14 ;Rejected: Initial Application by VAMC "RTN","DGENA6",91,0) .S DGENR("STATUS")=1 Q ;UNVERIFIED "RTN","DGENA6",92,0) S DGENR("FACREC")=$$INST^DGENU() "RTN","DGENA6",93,0) S DGENR("PRIORITY")=PRIORITY "RTN","DGENA6",94,0) ;Phase II add subgroup (SRS 6.4) "RTN","DGENA6",95,0) S DGENR("SUBGRP")=$P(PRIGRP,"^",2) "RTN","DGENA6",96,0) S DGENR("EFFDATE")=$S($G(EFFDATE):EFFDATE,$G(ENRDATE):$G(ENRDATE),1:$G(APP)) "RTN","DGENA6",97,0) S DGENR("USER")=$G(DUZ) "RTN","DGENA6",98,0) S DGENR("DATETIME")=$$NOW^XLFDT ;Moved to top of the routine DG*5.3*672 "RTN","DGENA6",99,0) S DGENR("PRIORREC")="" "RTN","DGENA6",100,0) S DGENR("RCODE")="" ;DJE field added with DG*5.3*940 - Closed Application - RM#867186 "RTN","DGENA6",101,0) ;Next line: DG*5.3*993 New fields for decoupling "RTN","DGENA6",102,0) I $G(DGENRYN)=0,$G(DGENR("STATUS"))'=6,$G(DGENR("STATUS"))'=20 S DGENR("STATUS")=25 "RTN","DGENA6",103,0) I $G(DGENFLG)=0,$G(DGENR("STATUS"))'=6,$G(DGENR("STATUS"))'=20 S DGENR("STATUS")=25 "RTN","DGENA6",104,0) S DGENR("PTAPPLIED")=DGENRYN,DGENR("REGREA")=$G(DGENRRSN),DGENR("REGDATE")=$G(DGENRODT),DGENR("REGSRC")=$G(DGENSRCE) "RTN","DGENA6",105,0) M DGENR("ELIG")=DGELGSUB "RTN","DGENA6",106,0) ; "RTN","DGENA6",107,0) Q 1 "RTN","DGENUPL1") 0^25^B75472345 "RTN","DGENUPL1",1,0) DGENUPL1 ;ALB/CJM,ISA,KWP,CKN,LBD,LMD,TDM,TGH,DJS,HM,JAM,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;30 Oct 2017 7:32PM "RTN","DGENUPL1",2,0) ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653,688,797,842,894,871,935,959,975,972,952,996,1014**;Aug 13,1993;Build 42 "RTN","DGENUPL1",3,0) ; "RTN","DGENUPL1",4,0) PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE,DGHBP,DGOTH) ; "RTN","DGENUPL1",5,0) ; "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) ; DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref) "RTN","DGENUPL1",31,0) ; DGHBP - array define for HEALTH BENEFIT PLAN data (pass by ref) DG*5.3*871 "RTN","DGENUPL1",32,0) ; DGOTH - array for OTH data (passed by ref) "RTN","DGENUPL1",33,0) ; "RTN","DGENUPL1",34,0) N SEG,ERROR,COUNT,QFLG,NFLG,DGCCPC "RTN","DGENUPL1",35,0) ; "RTN","DGENUPL1",36,0) ;DJS, Set TMP global to track the presence of ZMH segment; DG*5.3*935 "RTN","DGENUPL1",37,0) K ^TMP($J,"DGENUPL") S ^TMP($J,"DGENUPL","ZMH",0)=0 "RTN","DGENUPL1",38,0) ; "RTN","DGENUPL1",39,0) K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST "RTN","DGENUPL1",40,0) ; "RTN","DGENUPL1",41,0) S ERROR=0,NFLG=1 "RTN","DGENUPL1",42,0) F SEG="PID","ZPD","ZIE","ZIO","ZEL" D Q:ERROR "RTN","DGENUPL1",43,0) .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",44,0) .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q "RTN","DGENUPL1",45,0) .I SEG("TYPE")=SEG D Q "RTN","DGENUPL1",46,0) ..I SEG'="ZEL" N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN ; DG*5.3*894 "RTN","DGENUPL1",47,0) ..D:(SEG="ZEL") ZEL^DGENUPL2(1) "RTN","DGENUPL1",48,0) ..S NFLG=1 "RTN","DGENUPL1",49,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT) "RTN","DGENUPL1",50,0) .S ERROR=1 "RTN","DGENUPL1",51,0) .; "RTN","DGENUPL1",52,0) .;possible that in a bad message we are now past the end "RTN","DGENUPL1",53,0) .S CURLINE=CURLINE-1 "RTN","DGENUPL1",54,0) ; "RTN","DGENUPL1",55,0) ;DJS, Set segment before processing possible multiple segments; DG*5.3*935 "RTN","DGENUPL1",56,0) I 'ERROR S SEG="ZEL" F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL") D Q:ERROR "RTN","DGENUPL1",57,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",58,0) .D ZEL^DGENUPL2(COUNT) "RTN","DGENUPL1",59,0) ; "RTN","DGENUPL1",60,0) ;ZE2 is optional, If no ZE2 segment delete pension data "RTN","DGENUPL1",61,0) I 'ERROR D "RTN","DGENUPL1",62,0) .I SEG("TYPE")="ZE2" D ZE2^DGENUPLB S CURLINE=CURLINE+1 Q "RTN","DGENUPL1",63,0) .I SEG("TYPE")'="ZE2" D "RTN","DGENUPL1",64,0) ..Q:$$GET1^DIQ(2,DFN,.3852,"I")=$O(^DG(27.18,"C","00","")) "RTN","DGENUPL1",65,0) ..N PSUB "RTN","DGENUPL1",66,0) ..F PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S DGPAT(PSUB)="@" "RTN","DGENUPL1",67,0) ; "RTN","DGENUPL1",68,0) ; ZTE is optional and repeatable DG*5.3*952 "RTN","DGENUPL1",69,0) K DGOTH I 'ERROR S SEG="ZTE" I $$CHKNXT(CURLINE+1,SEG) D "RTN","DGENUPL1",70,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",71,0) .S QFLG=0 F D Q:QFLG "RTN","DGENUPL1",72,0) ..I SEG("TYPE")'="ZTE" S QFLG=1,CURLINE=CURLINE-1 Q "RTN","DGENUPL1",73,0) ..D ZTE^DGENUPLB "RTN","DGENUPL1",74,0) ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",75,0) ..Q "RTN","DGENUPL1",76,0) .Q "RTN","DGENUPL1",77,0) ; "RTN","DGENUPL1",78,0) ; ZCE is optional and repeatable DG*5.3*1014 "RTN","DGENUPL1",79,0) S DGCCPC=0 "RTN","DGENUPL1",80,0) K DGOTH I 'ERROR S SEG="ZCE" I $$CHKNXT(CURLINE+1,SEG) D "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")'="ZCE" S QFLG=1,CURLINE=CURLINE-1 Q "RTN","DGENUPL1",84,0) ..D ZCE^DGENUPLB "RTN","DGENUPL1",85,0) ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",86,0) ..Q "RTN","DGENUPL1",87,0) .Q "RTN","DGENUPL1",88,0) ; "RTN","DGENUPL1",89,0) ;ZHP is optional & can repeat. DG*5.3*871 "RTN","DGENUPL1",90,0) K DGHBP "RTN","DGENUPL1",91,0) ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",92,0) I 'ERROR S SEG="ZHP" I $$CHKNXT(CURLINE+1,SEG) D Q:ERROR $S(ERROR:0,1:1) "RTN","DGENUPL1",93,0) . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",94,0) . S QFLG=0 F D Q:QFLG!(ERROR) ;DG*5.3*996; JAM; Trap error - do not continue processing "RTN","DGENUPL1",95,0) . . I SEG("TYPE")'="ZHP" S QFLG=1,CURLINE=CURLINE-1 Q "RTN","DGENUPL1",96,0) . . D ZHP^DGENUPLB Q:ERROR ;DG*5.3*996; JAM; Trap error - do not continue processing "RTN","DGENUPL1",97,0) . . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",98,0) ; "RTN","DGENUPL1",99,0) ;Phase II Add the capability to accept more than 1 ZCD "RTN","DGENUPL1",100,0) I 'ERROR F SEG="ZEN","ZMT","ZCD" D Q:ERROR "RTN","DGENUPL1",101,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",102,0) .I SEG("TYPE")=SEG D "RTN","DGENUPL1",103,0) ..N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN ; DG*5.3*894 "RTN","DGENUPL1",104,0) .E D "RTN","DGENUPL1",105,0) ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT) "RTN","DGENUPL1",106,0) ..S ERROR=1 "RTN","DGENUPL1",107,0) ..; "RTN","DGENUPL1",108,0) ..;possible that in a bad message we are now past the end "RTN","DGENUPL1",109,0) ..S CURLINE=CURLINE-1 "RTN","DGENUPL1",110,0) ; "RTN","DGENUPL1",111,0) ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",112,0) I 'ERROR S SEG="ZCD" I $$CHKNXT(CURLINE+1,SEG) F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD") D Q:ERROR "RTN","DGENUPL1",113,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",114,0) .D ZCD^DGENUPL2 "RTN","DGENUPL1",115,0) ; "RTN","DGENUPL1",116,0) ; Purple Heart/OEF-OIF Addition of optional ZMH segment "RTN","DGENUPL1",117,0) ; Modified handling of ZSP and ZRD to accommodate ZMH "RTN","DGENUPL1",118,0) ; "RTN","DGENUPL1",119,0) ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",120,0) I 'ERROR S SEG="ZSP" I $$CHKNXT(CURLINE+1,SEG) D Q:ERROR $S(ERROR:0,1:1) "RTN","DGENUPL1",121,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",122,0) .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q "RTN","DGENUPL1",123,0) .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT) "RTN","DGENUPL1",124,0) .S ERROR=1 "RTN","DGENUPL1",125,0) .;possible that in a bad message we are now past the end "RTN","DGENUPL1",126,0) .S CURLINE=CURLINE-1 "RTN","DGENUPL1",127,0) ; "RTN","DGENUPL1",128,0) ;Modified following code to receive multiple ZMH segment for "RTN","DGENUPL1",129,0) ;Military service information - DG*5.3*653 "RTN","DGENUPL1",130,0) ; "RTN","DGENUPL1",131,0) ;DJS, Check for no MSE ZMH segments present and non-MSE ZMH segments ; DG*5.3*959 "RTN","DGENUPL1",132,0) I 'ERROR S SEG="ZMH" D ; DG*5.3*972 ;HM - remove Q:ERROR and let code quit with value below "RTN","DGENUPL1",133,0) .N SEGNAM,MSECNT,CURLN,MHSTYP,NONMSE,SGMNT S SEGNAM="",(MSECNT,NONMSE)=0,CURLN=CURLINE "RTN","DGENUPL1",134,0) .F S CURLN=$O(^TMP($J,IVMRTN,CURLN)) Q:'CURLN D "RTN","DGENUPL1",135,0) ..S SGMNT=$G(^TMP($J,IVMRTN,CURLN,0)),SEGNAM=$P($G(SGMNT),U) Q:SEGNAM'="ZMH" S MHSTYP=$P($G(SGMNT),U,3) "RTN","DGENUPL1",136,0) ..I "^SL^SNL^SNNL^MSD^FDD^"[("^"_MHSTYP_"^") S MSECNT=MSECNT+1 Q "RTN","DGENUPL1",137,0) ..E S NONMSE=NONMSE+1 Q ;ZMH segment present, but not an MSE "RTN","DGENUPL1",138,0) .;DJS, No MSE-type ZMH segment present, so branch to DGNOZMH to kill HEC-owned MSEs; DG*5.3*935 "RTN","DGENUPL1",139,0) .I MSECNT=0 I ^TMP($J,"DGENUPL","ZMH",0)=0 D EN^DGNOZMH(DFN) K ^TMP($J,"DGENUPL") "RTN","DGENUPL1",140,0) .Q:('NONMSE&('MSECNT)) "RTN","DGENUPL1",141,0) .;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",142,0) .S QFLG=0 F D Q:QFLG!(ERROR) "RTN","DGENUPL1",143,0) ..I '$$CHKNXT(CURLINE+1,SEG) S QFLG=1 Q "RTN","DGENUPL1",144,0) ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) ;process any ZMH segments that are present in Z11 "RTN","DGENUPL1",145,0) ..D ZMH^DGENUPL2 "RTN","DGENUPL1",146,0) ; "RTN","DGENUPL1",147,0) ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",148,0) I 'ERROR S SEG="ZRD" I $$CHKNXT(CURLINE+1,SEG) F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD") D Q:ERROR "RTN","DGENUPL1",149,0) .S CURLINE=CURLINE+1 "RTN","DGENUPL1",150,0) .D ZRD^DGENUPL2 "RTN","DGENUPL1",151,0) ; "RTN","DGENUPL1",152,0) ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",153,0) I 'ERROR S SEG="OBX" F D Q:(ERROR!('$$CHKNXT(CURLINE+1,SEG))) "RTN","DGENUPL1",154,0) .;possible if OBX segment not present that we are now past the end "RTN","DGENUPL1",155,0) .Q:'$$CHKNXT(CURLINE+1,SEG) "RTN","DGENUPL1",156,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","DGENUPL1",157,0) .D OBX^DGENUPL2 "RTN","DGENUPL1",158,0) .Q "RTN","DGENUPL1",159,0) ; "RTN","DGENUPL1",160,0) K ^TMP($J,"DGENUPL") "RTN","DGENUPL1",161,0) Q $S(ERROR:0,1:1) "RTN","DGENUPL1",162,0) ; "RTN","DGENUPL1",163,0) CONVERT(VAL,DATATYPE,ERROR) ; "RTN","DGENUPL1",164,0) ;Description: Converts the value found in the HL7 segment to DHCP format "RTN","DGENUPL1",165,0) ; "RTN","DGENUPL1",166,0) ;Input: "RTN","DGENUPL1",167,0) ; VAL - value parsed from the HL7 segment "RTN","DGENUPL1",168,0) ; DATATYPE: indicates the type of conversion necessary "RTN","DGENUPL1",169,0) ; "DATE" - needs to be converted to FM format "RTN","DGENUPL1",170,0) ; "TS" - time stamp, needs to be converted to FM format "RTN","DGENUPL1",171,0) ; "Y/N" - 0->"N",1->"Y" "RTN","DGENUPL1",172,0) ; "1/0" - "Y"->1,"N"->0 "RTN","DGENUPL1",173,0) ; "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file "RTN","DGENUPL1",174,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",175,0) ; "RTN","DGENUPL1",176,0) ; "MT" - VAL is a Means Test Status code, it needs to be converted "RTN","DGENUPL1",177,0) ; to a pointer to the Means Test Status file "RTN","DGENUPL1",178,0) ; Phase II convert code to RSN IEN for DGCDIS object "RTN","DGENUPL1",179,0) ; "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5) "RTN","DGENUPL1",180,0) ; "CDDSCR" data type converts the codes descriptor(s) to DSCR IEN. (HL7TODSC^DGENA5) DG*5.3*894 "RTN","DGENUPL1",181,0) ; "EXT" convert from code to abbreviation "RTN","DGENUPL1",182,0) ; "POS" convert from Period of Service code to a point to Period of Service file "RTN","DGENUPL1",183,0) ; "AGENCY" convert Agency/Allied Country code from file 35 "RTN","DGENUPL1",184,0) ; "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18 "RTN","DGENUPL1",185,0) ; "HBP" convert from code to file 25.11 ien DG*5.3*871 "RTN","DGENUPL1",186,0) ;OUTPUT: "RTN","DGENUPL1",187,0) ; Function Value - the result of the conversion "RTN","DGENUPL1",188,0) ; ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref) "RTN","DGENUPL1",189,0) S ERROR=0 "RTN","DGENUPL1",190,0) D "RTN","DGENUPL1",191,0) .I VAL="" Q "RTN","DGENUPL1",192,0) .I VAL="""""" S VAL="@" Q "RTN","DGENUPL1",193,0) .I $G(DATATYPE)="EXT" D Q "RTN","DGENUPL1",194,0) ..S VAL=$$HLTOLIMB^DGENA5(VAL) "RTN","DGENUPL1",195,0) .I $G(DATATYPE)="CDRSN" D Q "RTN","DGENUPL1",196,0) ..S VAL=$$HL7TORSN^DGENA5(VAL) "RTN","DGENUPL1",197,0) .; * check the new DESCRIPTOR seq - DG*5.3*894 "RTN","DGENUPL1",198,0) .I $G(DATATYPE)="CDDSCR" D Q "RTN","DGENUPL1",199,0) ..S VAL=$$HL7TODSC^DGENA5(VAL) "RTN","DGENUPL1",200,0) .I ($G(DATATYPE)="MT") D Q "RTN","DGENUPL1",201,0) ..S VAL=$O(^DG(408.32,"AC",1,VAL,0)) "RTN","DGENUPL1",202,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",203,0) .I ($G(DATATYPE)="DATE") D Q "RTN","DGENUPL1",204,0) ..I $L(VAL)'=8 S ERROR=1 Q "RTN","DGENUPL1",205,0) ..S VAL=$$FMDATE^HLFNC(VAL) "RTN","DGENUPL1",206,0) ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1 "RTN","DGENUPL1",207,0) .I ($G(DATATYPE)="TS") D Q "RTN","DGENUPL1",208,0) ..I $L(VAL)<8 S ERROR=1 Q "RTN","DGENUPL1",209,0) ..S VAL=$$FMDATE^HLFNC(VAL) "RTN","DGENUPL1",210,0) ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1 "RTN","DGENUPL1",211,0) .I ($G(DATATYPE)="Y/N") D Q "RTN","DGENUPL1",212,0) ..I VAL=0 S VAL="N" Q "RTN","DGENUPL1",213,0) ..I VAL=1 S VAL="Y" Q "RTN","DGENUPL1",214,0) ..S ERROR=1 "RTN","DGENUPL1",215,0) .I ($G(DATATYPE)="1/0") D Q "RTN","DGENUPL1",216,0) ..I VAL="N" S VAL=0 Q "RTN","DGENUPL1",217,0) ..I VAL="Y" S VAL=1 Q "RTN","DGENUPL1",218,0) ..S ERROR=1 "RTN","DGENUPL1",219,0) .I ($G(DATATYPE)="ELIGIBILITY") D Q "RTN","DGENUPL1",220,0) ..S VAL=$$MAP(VAL) "RTN","DGENUPL1",221,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",222,0) .I ($G(DATATYPE)="INSTITUTION") D Q "RTN","DGENUPL1",223,0) ..N OLDVAL "RTN","DGENUPL1",224,0) ..S OLDVAL=VAL "RTN","DGENUPL1",225,0) ..S VAL=$O(^DIC(4,"D",OLDVAL,0)) "RTN","DGENUPL1",226,0) ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0)) "RTN","DGENUPL1",227,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",228,0) .I ($G(DATATYPE)="POS") D Q "RTN","DGENUPL1",229,0) ..N OLDVAL "RTN","DGENUPL1",230,0) ..S OLDVAL=VAL "RTN","DGENUPL1",231,0) ..S VAL=$O(^DIC(21,"D",OLDVAL,0)) "RTN","DGENUPL1",232,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",233,0) .I ($G(DATATYPE)="AGENCY") D Q "RTN","DGENUPL1",234,0) ..N OLDVAL "RTN","DGENUPL1",235,0) ..S OLDVAL=VAL "RTN","DGENUPL1",236,0) ..S VAL=$O(^DIC(35,"C",OLDVAL,0)) "RTN","DGENUPL1",237,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",238,0) .I ($G(DATATYPE)="PENSIONCD") D Q "RTN","DGENUPL1",239,0) ..N OLDVAL "RTN","DGENUPL1",240,0) ..S OLDVAL=VAL "RTN","DGENUPL1",241,0) ..S VAL=$O(^DG(27.18,"C",OLDVAL,0)) "RTN","DGENUPL1",242,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",243,0) .I ($G(DATATYPE)="HBP") D Q ; DG*5.3*871 "RTN","DGENUPL1",244,0) ..N OLDVAL "RTN","DGENUPL1",245,0) ..S OLDVAL=VAL "RTN","DGENUPL1",246,0) ..S VAL=$O(^DGHBP(25.11,"C",OLDVAL,0)) "RTN","DGENUPL1",247,0) ..I 'VAL S ERROR=1 "RTN","DGENUPL1",248,0) Q VAL "RTN","DGENUPL1",249,0) ; "RTN","DGENUPL1",250,0) MAP(VALUE) ; "RTN","DGENUPL1",251,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",252,0) ; "RTN","DGENUPL1",253,0) ;Input: VALUE - ien of an entry in file #8.1 "RTN","DGENUPL1",254,0) ; "RTN","DGENUPL1",255,0) ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8 "RTN","DGENUPL1",256,0) ; "RTN","DGENUPL1",257,0) N ECODE,NODE,COUNT,NAME "RTN","DGENUPL1",258,0) ;try to choose a code from file 8 to use that is appropriate "RTN","DGENUPL1",259,0) S (COUNT,ECODE)=0 "RTN","DGENUPL1",260,0) ; "RTN","DGENUPL1",261,0) F S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE D "RTN","DGENUPL1",262,0) .S NODE=$G(^DIC(8,ECODE,0)) "RTN","DGENUPL1",263,0) .;put code on list if active "RTN","DGENUPL1",264,0) .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1 "RTN","DGENUPL1",265,0) ; "RTN","DGENUPL1",266,0) ;only one match found, so use it "RTN","DGENUPL1",267,0) Q:COUNT=1 $O(ECODE(0)) "RTN","DGENUPL1",268,0) ; "RTN","DGENUPL1",269,0) ;no match found "RTN","DGENUPL1",270,0) Q:'COUNT "" "RTN","DGENUPL1",271,0) ; "RTN","DGENUPL1",272,0) ;multiple matches found, try to match by name "RTN","DGENUPL1",273,0) I COUNT>1 D "RTN","DGENUPL1",274,0) .S ECODE=0 "RTN","DGENUPL1",275,0) .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^") "RTN","DGENUPL1",276,0) .F S ECODE=$O(ECODE(ECODE)) Q:'ECODE Q:ECODE(ECODE)=NAME "RTN","DGENUPL1",277,0) Q ECODE "RTN","DGENUPL1",278,0) ; "RTN","DGENUPL1",279,0) ACCEPT(MSGID) ; "RTN","DGENUPL1",280,0) ;Description: Writes an ack (AA) to a global to be transmitted later. "RTN","DGENUPL1",281,0) ; "RTN","DGENUPL1",282,0) ;Inputs: "RTN","DGENUPL1",283,0) ; MSGID -message control id of HL7 msg in the MSH segment "RTN","DGENUPL1",284,0) ; "RTN","DGENUPL1",285,0) ;Outputs: none "RTN","DGENUPL1",286,0) ; "RTN","DGENUPL1",287,0) N MID "RTN","DGENUPL1",288,0) K HL,HLMID,HLMTIEN,HLDT,HLDT1 "RTN","DGENUPL1",289,0) D INIT^HLFNC2(HLEID,.HL) "RTN","DGENUPL1",290,0) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) "RTN","DGENUPL1",291,0) S HLEVN=1 "RTN","DGENUPL1",292,0) S MID=HLMID_"-"_HLEVN "RTN","DGENUPL1",293,0) D MSH^HLFNC2(.HL,MID,.HLRES) "RTN","DGENUPL1",294,0) S ^TMP("HLS",$J,1)=HLRES "RTN","DGENUPL1",295,0) ; "RTN","DGENUPL1",296,0) ;it seems HLFS sometimes disappears upon reaching this point "RTN","DGENUPL1",297,0) I $G(HLFS)="" S HLFS="^" "RTN","DGENUPL1",298,0) ; "RTN","DGENUPL1",299,0) S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID "RTN","DGENUPL1",300,0) Q "RTN","DGENUPL1",301,0) ; "RTN","DGENUPL1",302,0) MVERRORS ; "RTN","DGENUPL1",303,0) ;Error messages were being deleted from ^TMP("HLS",$J by another package "RTN","DGENUPL1",304,0) ;during the upload. To fix this, errors are written to another "RTN","DGENUPL1",305,0) ;subscript, then moved when the error list is complete. "RTN","DGENUPL1",306,0) ; "RTN","DGENUPL1",307,0) M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J) "RTN","DGENUPL1",308,0) K ^TMP("IVM","HLS",$J) "RTN","DGENUPL1",309,0) Q "RTN","DGENUPL1",310,0) ; "RTN","DGENUPL1",311,0) ;DJS, Added Extrinsic Function to determine if multiple segments are present ; DG*5.3*935 "RTN","DGENUPL1",312,0) CHKNXT(DGNVAL,DGNSEG) ; Check the SEG in the next segment manually "RTN","DGENUPL1",313,0) ; DGNVAL = CURLINE or CURLINE+1 "RTN","DGENUPL1",314,0) ; DGNSEG = SEG (3 character SEG) "RTN","DGENUPL1",315,0) ; Returns 1 if there is a match or 0 if there is no match "RTN","DGENUPL1",316,0) ; "RTN","DGENUPL1",317,0) Q $S($E($G(^TMP($J,IVMRTN,+DGNVAL,0)),1,3)=DGNSEG:1,1:0) "RTN","DGENUPL7") 0^26^B88929469 "RTN","DGENUPL7",1,0) DGENUPL7 ;ISA/KWP,CKN,TMK,TDM,LBD,HM,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;9/12/20 5:48pm "RTN","DGENUPL7",2,0) ;;5.3;REGISTRATION;**232,367,397,417,379,431,513,628,673,653,742,688,797,871,972,952,977,993,1014**;Aug 13,1993;Build 42 "RTN","DGENUPL7",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DGENUPL7",4,0) ; "RTN","DGENUPL7",5,0) ;Phase II split from DGENUPL "RTN","DGENUPL7",6,0) Z11(MSGIEN,MSGID,CURLINE,DFN,ERRCOUNT) ; "RTN","DGENUPL7",7,0) ;Description: This is used to process a single ORU~Z11 or ORF~Z11 msg. "RTN","DGENUPL7",8,0) ;Input: "RTN","DGENUPL7",9,0) ; MSGIEN - the internal entry number of the HL7 message in the "RTN","DGENUPL7",10,0) ; HL7 MESSAGE TEXT file (772) "RTN","DGENUPL7",11,0) ; MSGID -message control id of HL7 msg in the MSH segment "RTN","DGENUPL7",12,0) ; CURLINE - the subscript of the MSH segment of the current message (pass by reference) "RTN","DGENUPL7",13,0) ; DFN - identifies the patient, is the ien of a record in the PATIENT file. "RTN","DGENUPL7",14,0) ; ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by reference) "RTN","DGENUPL7",15,0) ; "RTN","DGENUPL7",16,0) ;Output: "RTN","DGENUPL7",17,0) ; CURLINE - upon leaving the procedure this parameter should be set to the end of the current message. (pass by reference) "RTN","DGENUPL7",18,0) ; ERRCOUNT - set to count of messages that were not processed due to errors encountered (pass by reference) "RTN","DGENUPL7",19,0) ; "RTN","DGENUPL7",20,0) N DGELG,DGENR,DGPAT,DGCDIS,DGOEIF,ERROR,ERRMSG,MSGS,DGELGSUB,DGENUPLD,DGCON,DGNMSE,DGCCPG,DGSUB,DGFDA,DGERR,DGIENS "RTN","DGENUPL7",21,0) N DGNEWVAL,DIV,SUB,OLDELG,OLDPAT,OLDDCDIS,OLDEIF,DGSEC,OLDSEC,DGNTR,DGMST,DGPHINC,DGHBP,DGOTH,DGSUB,DGCOVF,DGESCO,DGCOV "RTN","DGENUPL7",22,0) N DGELCV "RTN","DGENUPL7",23,0) ; "RTN","DGENUPL7",24,0) ;some process is killing these HL7 variables, so need to protect them "RTN","DGENUPL7",25,0) S SUB=HLFS "RTN","DGENUPL7",26,0) S DIV=HLECH "RTN","DGENUPL7",27,0) N HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLECH,HLFS,HLNDAP,HLNDAP0,HLPID,HLQ,HLVER,HLERR,HLMTN,HLSDT "RTN","DGENUPL7",28,0) S HLFS=SUB "RTN","DGENUPL7",29,0) S HLECH=DIV "RTN","DGENUPL7",30,0) S HLQ="""""" "RTN","DGENUPL7",31,0) K DIV,SUB "RTN","DGENUPL7",32,0) ; "RTN","DGENUPL7",33,0) ;drops out of block on error "RTN","DGENUPL7",34,0) D "RTN","DGENUPL7",35,0) .Q:'$$PARSE^DGENUPL1(MSGIEN,MSGID,.CURLINE,.ERRCOUNT,.DGPAT,.DGELG,.DGENR,.DGCDIS,.DGOEIF,.DGSEC,.DGNTR,.DGMST,.DGNMSE,.DGHBP,.DGOTH) "RTN","DGENUPL7",36,0) .; DG*5.3*1014 - Capture Z11 eligibilities "RTN","DGENUPL7",37,0) .M DGELCV=DGELG "RTN","DGENUPL7",38,0) .D GETLOCKS^DGENUPL5(DFN) "RTN","DGENUPL7",39,0) .; "RTN","DGENUPL7",40,0) .;Used by cross-references to determine if an upload is in progress. "RTN","DGENUPL7",41,0) .S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" "RTN","DGENUPL7",42,0) .; "RTN","DGENUPL7",43,0) .;Update the PATIENT, ELIGIBILITY, CATASTROPHIC DISABILITY objects in memory "RTN","DGENUPL7",44,0) .Q:'$$UOBJECTS^DGENUPL4(DFN,.DGPAT,.DGELG,.DGCDIS,.DGOEIF,MSGID,.ERRCOUNT,.MSGS,.OLDPAT,.OLDELG,.OLDCDIS,.OLDEIF) "RTN","DGENUPL7",45,0) .;DG*5.3*1014 - Delete Vista secondary eligibilities from DGELG array "RTN","DGENUPL7",46,0) .S DGSUB=0 F S DGSUB=$O(DGELG("ELIG","CODE",DGSUB)) Q:'DGSUB D "RTN","DGENUPL7",47,0) ..I '$D(DGELCV("ELIG","CODE",DGSUB)) K DGELG("ELIG","CODE",DGSUB) "RTN","DGENUPL7",48,0) .; "RTN","DGENUPL7",49,0) .S ERROR=0 "RTN","DGENUPL7",50,0) .;if the msg contains patient security, process it "RTN","DGENUPL7",51,0) .I $D(DGSEC) D Q:ERROR "RTN","DGENUPL7",52,0) ..S DGSEC("DFN")=DFN "RTN","DGENUPL7",53,0) ..S DGSEC("USER")=.5 "RTN","DGENUPL7",54,0) ..I DGSEC("LEVEL")'="" D "RTN","DGENUPL7",55,0) ...I DGSEC("DATETIME")="" S DGSEC("DATETIME")=$$NOW^XLFDT ;DG*5.3*653 "RTN","DGENUPL7",56,0) ..; "RTN","DGENUPL7",57,0) ..; check consistency of patient security record "RTN","DGENUPL7",58,0) ..I '$$CHECK^DGENSEC(.DGSEC,.ERRMSG) D Q "RTN","DGENUPL7",59,0) ...S ERROR=1 "RTN","DGENUPL7",60,0) ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",61,0) ..; "RTN","DGENUPL7",62,0) ..; upload patient security, consistency checks passed "RTN","DGENUPL7",63,0) ..D SECUPLD^DGENUPL5(DFN,.DGSEC,.OLDSEC) "RTN","DGENUPL7",64,0) .; "RTN","DGENUPL7",65,0) .; KUM - DG*5.3*1014 - BEGIN "RTN","DGENUPL7",66,0) .; Upload Community Care Program Data to Patient file (#2) "RTN","DGENUPL7",67,0) .; "RTN","DGENUPL7",68,0) .; End date all CCPs and Set Archive flag if COV is removed from eligibilities "RTN","DGENUPL7",69,0) .S DGCOV=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") "RTN","DGENUPL7",70,0) .S DGCOVF="" "RTN","DGENUPL7",71,0) .S DGESCO="" "RTN","DGENUPL7",72,0) .I $$GET1^DIQ(2,DFN_",",".361","I")=$G(DGCOV) S DGCOVF="Y" "RTN","DGENUPL7",73,0) .S DGSUB=0 F S DGSUB=$O(^DPT(DFN,"E",DGSUB)) Q:'DGSUB D "RTN","DGENUPL7",74,0) ..I +$G(^DPT(DFN,"E",DGSUB,0))=$G(DGCOV) S DGCOVF="Y" "RTN","DGENUPL7",75,0) .I DGELCV("ELIG","CODE")=$G(DGCOV) S DGESCO="Y" "RTN","DGENUPL7",76,0) .S DGSUB=0 F S DGSUB=$O(DGELCV("ELIG","CODE",DGSUB)) Q:'DGSUB D "RTN","DGENUPL7",77,0) ..I DGSUB=$G(DGCOV) S DGESCO="Y" "RTN","DGENUPL7",78,0) .I DGCOVF="Y",DGESCO'="Y" D ARCHALL^DGRP1152U(DFN) "RTN","DGENUPL7",79,0) .; "RTN","DGENUPL7",80,0) .; Allow moving of cov from Primary to Other "RTN","DGENUPL7",81,0) .; Removing COV from patient eligibilities is not allowed if there are active CCPs "RTN","DGENUPL7",82,0) .; But uisng Z11, moving COV from primary to Other eligibilities is allowed, in this Case, bypassing the Check "RTN","DGENUPL7",83,0) .I DGELG("ELIG","CODE")'=$G(DGCOV),$$GET1^DIQ(2,DFN_",",".361","I")=$G(DGCOV),DGESCO="Y" D "RTN","DGENUPL7",84,0) ..S $P(^DPT(DFN,.36),"^",1)="" "RTN","DGENUPL7",85,0) .; "RTN","DGENUPL7",86,0) .S DGSUB="" "RTN","DGENUPL7",87,0) .F S DGSUB=$O(DGCCPG(DGSUB)) Q:DGSUB="" D "RTN","DGENUPL7",88,0) ..N DGMAT,DGPGCD,DGEFDT,DGEDDT,DGLUTS,DGZ,IENS,DGPGC1,DGEFD1 "RTN","DGENUPL7",89,0) ..S DGMAT="N" "RTN","DGENUPL7",90,0) ..S DGPGCD=$P(DGCCPG(DGSUB),"^",1) "RTN","DGENUPL7",91,0) ..S DGEFDT=$P(DGCCPG(DGSUB),"^",2) "RTN","DGENUPL7",92,0) ..S DGEDDT=$P(DGCCPG(DGSUB),"^",3) "RTN","DGENUPL7",93,0) ..I $G(DGEDDT)="@" S DGEDDT="" "RTN","DGENUPL7",94,0) ..I $G(DGEDDT)="" S DGEDDT="" "RTN","DGENUPL7",95,0) ..S DGLUTS=$P(DGCCPG(DGSUB),"^",4) "RTN","DGENUPL7",96,0) ..S DGZ=0 F S DGZ=$O(^DPT(DFN,5,"AC",$G(DGEFDT),DGZ)) Q:'DGZ D "RTN","DGENUPL7",97,0) ...S IENS=DGZ_","_DFN_"," "RTN","DGENUPL7",98,0) ...I $$GET1^DIQ(2.191,IENS,4,"I")'=1 D "RTN","DGENUPL7",99,0) ....S DGPGC1=$$GET1^DIQ(2.191,IENS,1,"I") "RTN","DGENUPL7",100,0) ....S DGEFD1=$$GET1^DIQ(2.191,IENS,2,"I") "RTN","DGENUPL7",101,0) ....I ($G(DGPGCD)=$G(DGPGC1)),($G(DGEFDT)=$G(DGEFD1)) S DGMAT="Y" D CCCUPD "RTN","DGENUPL7",102,0) ..I DGMAT'="Y" D CCCADD "RTN","DGENUPL7",103,0) .Q:ERROR "RTN","DGENUPL7",104,0) .; KUM - DG*5.3*1014 - END "RTN","DGENUPL7",105,0) .; "RTN","DGENUPL7",106,0) .;if the msg has an enrollment process it "RTN","DGENUPL7",107,0) .I DGENR("STATUS")!DGENR("APP") D Q:ERROR "RTN","DGENUPL7",108,0) ..N DGENRYN,DGSTS "RTN","DGENUPL7",109,0) ..S DGENRYN="" "RTN","DGENUPL7",110,0) ..S DGSTS=DGENR("STATUS") "RTN","DGENUPL7",111,0) ..I DGSTS=25 S DGENRYN=0 ;DG*5.3*993 "RTN","DGENUPL7",112,0) ..I DGSTS'=25,'$$PREEXIST^DGREG(DFN) S DGENRYN=1 "RTN","DGENUPL7",113,0) ..;use $$PRIORITY to get the eligibility data used to compute priority "RTN","DGENUPL7",114,0) ..I $$PRIORITY^DGENELA4(DFN,.DGELG,.DGELGSUB,DGENR("DATE"),DGENR("APP"),$G(DGENRYN)) ;DG*5.3*993 Added DGENRYN REGISTRATION ONLY "RTN","DGENUPL7",115,0) ..; "RTN","DGENUPL7",116,0) ..;store the eligibility data in the enrollment record and other missing fields "RTN","DGENUPL7",117,0) ..M DGENR("ELIG")=DGELGSUB "RTN","DGENUPL7",118,0) ..S DGENR("ELIG","OTHTYPE")=$G(DGELG("OTHTYPE")) ; DG*5.3*952 "RTN","DGENUPL7",119,0) ..S DGENR("DFN")=DFN "RTN","DGENUPL7",120,0) ..S DGENR("PRIORREC")="" "RTN","DGENUPL7",121,0) ..S DGENR("USER")=.5 "RTN","DGENUPL7",122,0) ..S DGENR("DATETIME")=$$NOW^XLFDT "RTN","DGENUPL7",123,0) ..; "RTN","DGENUPL7",124,0) ..;Allow null overwrites of Ineligible data (Ineligible Project): "RTN","DGENUPL7",125,0) ..I $D(DGENR("DATE")),DGENR("DATE")="" S DGENR("DATE")="@" "RTN","DGENUPL7",126,0) ..I $D(DGENR("FACREC")),DGENR("FACREC")="" S DGENR("FACREC")="@" "RTN","DGENUPL7",127,0) ..; "RTN","DGENUPL7",128,0) ..;check the consistency of the enrollment record "RTN","DGENUPL7",129,0) ..I '$$CHECK^DGENA3(.DGENR,.DGPAT,.ERRMSG) D Q "RTN","DGENUPL7",130,0) ...S ERROR=1 "RTN","DGENUPL7",131,0) ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",132,0) ..; DG*5.3*993 - BEGIN "RTN","DGENUPL7",133,0) ..;Find patient's current enrollment record "RTN","DGENUPL7",134,0) ..N DGENRIEN,DGENRYN "RTN","DGENUPL7",135,0) ..S DGENRIEN="" "RTN","DGENUPL7",136,0) ..S DGENRYN="" "RTN","DGENUPL7",137,0) ..S DGENRIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENUPL7",138,0) ..I DGENRIEN S:$G(DGENRYN)="" DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I") ;DG*5.3*993 Added REGISTRATION ONLY "RTN","DGENUPL7",139,0) ..I DGENRYN=1,DGENR("PTAPPLIED")=0,DGPAT("VETERAN")="Y" D Q "RTN","DGENUPL7",140,0) ...S ERROR=1 "RTN","DGENUPL7",141,0) ...S ERRMSG="Veteran has applied for enrollment. Do You Wish to Enroll cannot be No." "RTN","DGENUPL7",142,0) ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",143,0) ..; "RTN","DGENUPL7",144,0) ..; DG*5.3*993 - END "RTN","DGENUPL7",145,0) ..; "RTN","DGENUPL7",146,0) ..; removed EGT consistency check with DG*5.3*628 "RTN","DGENUPL7",147,0) ..;Phase II EGT consistency checks (SRS 6.5.1.3) "RTN","DGENUPL7",148,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",149,0) ..;I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$ABOVE^DGENEGT1(DGENR("DFN"),DGENR("PRIORITY"),DGENR("SUBGRP"),"","",1) D Q "RTN","DGENUPL7",150,0) ..;.S ERROR=1 "RTN","DGENUPL7",151,0) ..;.S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE EGT CONSISTENCY CHECKS." "RTN","DGENUPL7",152,0) ..;.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) "RTN","DGENUPL7",153,0) ..; "RTN","DGENUPL7",154,0) ..;Allow null overwrites for Ineligible vets (Ineligible Project): "RTN","DGENUPL7",155,0) ..I $G(DGPAT("INELDATE"))'="" S (DGENR("PRIORITY"),DGENR("SUBGRP"))="" "RTN","DGENUPL7",156,0) ..I DGENR("DATE")="@" S DGENR("DATE")="" "RTN","DGENUPL7",157,0) ..I DGENR("FACREC")="@" S DGENR("FACREC")="" "RTN","DGENUPL7",158,0) ..; "RTN","DGENUPL7",159,0) ..D ENRUPLD^DGENUPL8(.DGENR,.DGPAT) "RTN","DGENUPL7",160,0) .; "RTN","DGENUPL7",161,0) .;Store the PATIENT, ELIGIBILITY, & CAT. DISB. objects "RTN","DGENUPL7",162,0) .I $$STORE^DGENPTA1(.DGPAT,,1) "RTN","DGENUPL7",163,0) .I $$STORE^DGENELA1(.DGELG,.DGPAT,.DGCDIS,,1) "RTN","DGENUPL7",164,0) .I $G(DGCDIS("VCD"))'="",$$STORE^DGENCDA2(DFN,.DGCDIS) ;checks first if there is catastrophic disability information "RTN","DGENUPL7",165,0) .; store OTH data "RTN","DGENUPL7",166,0) .D OTHUPLD^DGENUPL8(DFN,.DGOTH,$G(DGPAT("SSN")),$G(DGELG("ELIG","CODE"))) ; DG*5.3*952 "RTN","DGENUPL7",167,0) .; "RTN","DGENUPL7",168,0) .;Call PIMS api to file NTR data. "RTN","DGENUPL7",169,0) .I $D(DGNTR),$$ENRUPD^DGNTAPI1(DFN,.DGNTR) "RTN","DGENUPL7",170,0) .; "RTN","DGENUPL7",171,0) .;Call PIMS api to file MST data. "RTN","DGENUPL7",172,0) .I DGMST("MSTSTAT")'="",DGMST("MSTDT")'="",DGMST("MSTST")'="" D "RTN","DGENUPL7",173,0) ..I $$NEWSTAT^DGMSTAPI(DFN,DGMST("MSTSTAT"),DGMST("MSTDT"),".5",DGMST("MSTST"),0) "RTN","DGENUPL7",174,0) ..Q "RTN","DGENUPL7",175,0) .; create new entry in sub-file 33.02 "RTN","DGENUPL7",176,0) .D CRTEELCH^DGOTHEL(DFN,$$HASENTRY^DGOTHD2(DFN),$G(DGELG("OTHTS"))) ; DG*5.3*977 OTH-EXT - moved after MST data update "RTN","DGENUPL7",177,0) .; "RTN","DGENUPL7",178,0) .;Since HEC is authoritative source, If no OEF/OIF data in Z11, set count to 0 so existing data in VistA will be deleted. "RTN","DGENUPL7",179,0) .I '$D(DGOEIF) S DGOEIF("COUNT")=0 "RTN","DGENUPL7",180,0) .;Call PIMS api to file OEF/OIF data. "RTN","DGENUPL7",181,0) .I $D(DGOEIF) D OEIFUPD^DGCLAPI1(DFN,.DGOEIF) "RTN","DGENUPL7",182,0) .; "RTN","DGENUPL7",183,0) .;File the Military Service Episode (MSE) data (DG*5.3*797) "RTN","DGENUPL7",184,0) .I $D(DGNMSE) D UPDMSE^DGMSEUTL(DFN,.DGNMSE) "RTN","DGENUPL7",185,0) .; "RTN","DGENUPL7",186,0) .;File the Health Benefit Plan (HBP) data "RTN","DGENUPL7",187,0) .D HL7UPD^DGHBPUTL(DFN,.DGHBP,MSHDT) "RTN","DGENUPL7",188,0) .; "RTN","DGENUPL7",189,0) .;if the current enrollment is a local then log patient for transmission "RTN","DGENUPL7",190,0) .I $$SOURCE^DGENA(DFN)=1!$G(DGPHINC) K DGENUPLD,DGPHINC D EVENT^IVMPLOG(DFN) "RTN","DGENUPL7",191,0) .; "RTN","DGENUPL7",192,0) .;create the audit trail "RTN","DGENUPL7",193,0) .K OLDPAT("MOH"),DGPAT("MOH") ;remove MOH from audit demographics report DG*5.3*972 HM "RTN","DGENUPL7",194,0) .I $$AUDIT^DGENUPA1(,MSGID,.OLDPAT,.DGPAT,.OLDELG,.DGELG,.OLDCDIS,.DGCDIS,.DGSEC,.OLDSEC) "RTN","DGENUPL7",195,0) .;send notifications "RTN","DGENUPL7",196,0) .D NOTIFY^DGENUPL3(.DGPAT,.MSGS) "RTN","DGENUPL7",197,0) .; "RTN","DGENUPL7",198,0) .;invoke registration consistency checker "RTN","DGENUPL7",199,0) .D REGCHECK^DGENUPL2(DFN) "RTN","DGENUPL7",200,0) ; "RTN","DGENUPL7",201,0) D UNLOCK^DGENUPL5(DFN) "RTN","DGENUPL7",202,0) Q "RTN","DGENUPL7",203,0) CCCADD ; Add new entry to #2.191 "RTN","DGENUPL7",204,0) N DGERR,DGIENS,DGFDA "RTN","DGENUPL7",205,0) S DGERR=0 "RTN","DGENUPL7",206,0) S DGIENS=DFN_"," "RTN","DGENUPL7",207,0) S DGIENS="+1,"_DGIENS "RTN","DGENUPL7",208,0) S DGFDA(2.191,DGIENS,.01)=$G(DGLUTS) "RTN","DGENUPL7",209,0) S DGFDA(2.191,DGIENS,1)=$G(DGPGCD) "RTN","DGENUPL7",210,0) S DGFDA(2.191,DGIENS,2)=$G(DGEFDT) "RTN","DGENUPL7",211,0) S DGFDA(2.191,DGIENS,3)=$G(DGEDDT) "RTN","DGENUPL7",212,0) D UPDATE^DIE("","DGFDA","","DGERR") "RTN","DGENUPL7",213,0) I DGERR D "RTN","DGENUPL7",214,0) .S ERROR=1 "RTN","DGENUPL7",215,0) .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),$G(DGERR("DIERR",1,"TEXT",1)),.ERRCOUNT) "RTN","DGENUPL7",216,0) Q "RTN","DGENUPL7",217,0) CCCUPD ; Update entry in #2.191 "RTN","DGENUPL7",218,0) N DGFDA,DGERR,DGIENS,DGTMTS "RTN","DGENUPL7",219,0) S DGERR=0 "RTN","DGENUPL7",220,0) S DGIENS=IENS "RTN","DGENUPL7",221,0) S DGTMTS=+$$GET1^DIQ(2.191,DGIENS,.01,"I") "RTN","DGENUPL7",222,0) I $G(DGLUTS)>$G(DGTMTS) D "RTN","DGENUPL7",223,0) .S DGFDA(2.191,DGIENS,.01)=$G(DGLUTS) "RTN","DGENUPL7",224,0) .S DGFDA(2.191,DGIENS,3)=$G(DGEDDT) "RTN","DGENUPL7",225,0) .S DGFDA(2.191,DGIENS,4)=0 "RTN","DGENUPL7",226,0) .D FILE^DIE("","DGFDA","DGERR") "RTN","DGENUPL7",227,0) .I DGERR D "RTN","DGENUPL7",228,0) ..S ERROR=1 "RTN","DGENUPL7",229,0) ..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),$G(DGERR("DIERR",1,"TEXT",1)),.ERRCOUNT) "RTN","DGENUPL7",230,0) Q "RTN","DGENUPLB") 0^27^B52239102 "RTN","DGENUPLB",1,0) DGENUPLB ;ALB/TDM,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;4/10/13 6:53pm "RTN","DGENUPLB",2,0) ;;5.3;REGISTRATION;**625,763,842,871,952,977,1014**;Aug 13,1993;Build 42 "RTN","DGENUPLB",3,0) ; "RTN","DGENUPLB",4,0) EP N MSGARY "RTN","DGENUPLB",5,0) D CHECK "RTN","DGENUPLB",6,0) Q "RTN","DGENUPLB",7,0) ; "RTN","DGENUPLB",8,0) CHECK ;Check for Rated Disability Changes "RTN","DGENUPLB",9,0) Q:'$D(DGELG) "RTN","DGENUPLB",10,0) N RDOCC,TMPARY,RD,RDOCC1,RDOCC2,RDFLG,RDNOD "RTN","DGENUPLB",11,0) ; "RTN","DGENUPLB",12,0) ;Change in Rated Disabilities "RTN","DGENUPLB",13,0) I $D(OLDELG("RATEDIS")) D "RTN","DGENUPLB",14,0) .S RDOCC=0 F S RDOCC=$O(OLDELG("RATEDIS",RDOCC)) Q:RDOCC="" D "RTN","DGENUPLB",15,0) ..S RD=$P(OLDELG("RATEDIS",RDOCC,"RD"),"^") Q:RD="" "RTN","DGENUPLB",16,0) ..S TMPARY(RD)=RDOCC "RTN","DGENUPLB",17,0) ; "RTN","DGENUPLB",18,0) I $D(DGELG("RATEDIS")) D "RTN","DGENUPLB",19,0) .S RDOCC=0 F S RDOCC=$O(DGELG("RATEDIS",RDOCC)) Q:RDOCC="" D "RTN","DGENUPLB",20,0) ..S RD=$P(DGELG("RATEDIS",RDOCC,"RD"),"^") Q:RD="" "RTN","DGENUPLB",21,0) ..S $P(TMPARY(RD),"^",2)=RDOCC "RTN","DGENUPLB",22,0) ; "RTN","DGENUPLB",23,0) I $D(TMPARY) D "RTN","DGENUPLB",24,0) .S RD="" "RTN","DGENUPLB",25,0) .F S RD=$O(TMPARY(RD)) Q:RD="" D "RTN","DGENUPLB",26,0) ..S RDOCC2=+$P(TMPARY(RD),"^",2) Q:'RDOCC2 "RTN","DGENUPLB",27,0) ..S RDOCC1=+$P(TMPARY(RD),"^") "RTN","DGENUPLB",28,0) ..I 'RDOCC1 D STOR390 Q "RTN","DGENUPLB",29,0) ..S RDFLG=0 "RTN","DGENUPLB",30,0) ..F RDNOD="RD","PER","RDSC","RDEXT","RDORIG","RDCURR" D Q:RDFLG "RTN","DGENUPLB",31,0) ...I $G(OLDELG("RATEDIS",RDOCC1,RDNOD))'=$G(DGELG("RATEDIS",RDOCC2,RDNOD)) D STOR390 "RTN","DGENUPLB",32,0) Q "RTN","DGENUPLB",33,0) ; "RTN","DGENUPLB",34,0) STOR390 ;Store Data in file# 390 "RTN","DGENUPLB",35,0) S RDFLG=1 "RTN","DGENUPLB",36,0) N DATA,DA "RTN","DGENUPLB",37,0) S DATA(.01)=$$NOW^XLFDT "RTN","DGENUPLB",38,0) S DATA(2)=DFN "RTN","DGENUPLB",39,0) S DATA(3)=DGELG("RATEDIS",RDOCC2,"RD") "RTN","DGENUPLB",40,0) S DATA(4)=DGELG("RATEDIS",RDOCC2,"PER") "RTN","DGENUPLB",41,0) S DATA(5)=DGELG("RATEDIS",RDOCC2,"RDEXT") "RTN","DGENUPLB",42,0) S DATA(6)=DGELG("RATEDIS",RDOCC2,"RDORIG") "RTN","DGENUPLB",43,0) S DATA(7)=DGELG("RATEDIS",RDOCC2,"RDCURR") "RTN","DGENUPLB",44,0) I '$$ADD^DGENDBS(390,,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILITY UPLOAD AUDIT" "RTN","DGENUPLB",45,0) Q "RTN","DGENUPLB",46,0) ; "RTN","DGENUPLB",47,0) ZE2 ; Process ZE2 segment "RTN","DGENUPLB",48,0) N HL7REP,HL7SC,SUB "RTN","DGENUPLB",49,0) S HL7SC=$E(HLECH,1) "RTN","DGENUPLB",50,0) S DGPAT("PENAEFDT")=$$CONVERT^DGENUPL1($P(SEG(1),HL7SC),"DATE",.ERROR) "RTN","DGENUPLB",51,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 1-1",.ERRCOUNT) Q "RTN","DGENUPLB",52,0) S DGPAT("PENTRMDT")=$$CONVERT^DGENUPL1($P(SEG(1),HL7SC,2),"DATE",.ERROR) "RTN","DGENUPLB",53,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 1-2",.ERRCOUNT) Q "RTN","DGENUPLB",54,0) S DGPAT("PENAREAS")=$$CONVERT^DGENUPL1($P(SEG(2),HL7SC),"PENSIONCD",.ERRCOUNT) "RTN","DGENUPLB",55,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 2",.ERRCOUNT) Q "RTN","DGENUPLB",56,0) F HL7REP=1:1:4 D Q:ERROR "RTN","DGENUPLB",57,0) .Q:$P($P(SEG(3),"|",HL7REP),HL7SC)="" "RTN","DGENUPLB",58,0) .S SUB="PENTRMR"_HL7REP "RTN","DGENUPLB",59,0) .S DGPAT(SUB)=$$CONVERT^DGENUPL1($P($P(SEG(3),"|",HL7REP),HL7SC),"PENSIONCD",.ERRCOUNT) "RTN","DGENUPLB",60,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 3",.ERRCOUNT) "RTN","DGENUPLB",61,0) ; "RTN","DGENUPLB",62,0) ; Convert to deletion indicator if null "RTN","DGENUPLB",63,0) N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S:$G(DGPAT(SUB))="" DGPAT(SUB)="@" "RTN","DGENUPLB",64,0) Q "RTN","DGENUPLB",65,0) ; "RTN","DGENUPLB",66,0) ZHP ;Process ZHP segment "RTN","DGENUPLB",67,0) N CTR "RTN","DGENUPLB",68,0) S CTR=$O(DGHBP(""),-1)+1 "RTN","DGENUPLB",69,0) S $P(DGHBP(CTR),U)=$$CONVERT^DGENUPL1(SEG(2),"HBP",.ERROR) "RTN","DGENUPLB",70,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 2",.ERRCOUNT) Q "RTN","DGENUPLB",71,0) S $P(DGHBP(CTR),U,2)=$$CONVERT^DGENUPL1(SEG(3),"TS",.ERROR) "RTN","DGENUPLB",72,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 3",.ERRCOUNT) Q "RTN","DGENUPLB",73,0) S $P(DGHBP(CTR),U,3)=.5 ;Postmaster "RTN","DGENUPLB",74,0) S $P(DGHBP(CTR),U,4)=$$CONVERT^DGENUPL1(SEG(5),"INSTITUTION",.ERROR) "RTN","DGENUPLB",75,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 5",.ERRCOUNT) Q "RTN","DGENUPLB",76,0) S $P(DGHBP(CTR),U,5)=$$CONVERT^DGENUPL1(SEG(4),,.ERROR) "RTN","DGENUPLB",77,0) I (($P(DGHBP(CTR),U,5)'="V")&($P(DGHBP(CTR),U,5)'="E")) S ERROR=1 "RTN","DGENUPLB",78,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 4",.ERRCOUNT) Q "RTN","DGENUPLB",79,0) Q "RTN","DGENUPLB",80,0) ; "RTN","DGENUPLB",81,0) ZTE ; process ZTE segment DG*5.3*952 "RTN","DGENUPLB",82,0) N CHKFLG,CNT,EDITTS,ENTBY,FCLTY,ORIGTS,QFLG,SUBDT,TYPE "RTN","DGENUPLB",83,0) S TYPE=$$CONVERT^DGENUPL1(SEG(4),,.ERROR) I "^A^D^P^"'[(U_TYPE_U) S ERROR=1 "RTN","DGENUPLB",84,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 4",.ERRCOUNT) Q "RTN","DGENUPLB",85,0) ; fields common to all 3 request types "RTN","DGENUPLB",86,0) S SUBDT=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR) "RTN","DGENUPLB",87,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 2",.ERRCOUNT) Q "RTN","DGENUPLB",88,0) S CHKFLG=$S(SUBDT="@":0,1:1) "RTN","DGENUPLB",89,0) S ORIGTS=$$CONVERT^DGENUPL1(SEG(3),"TS",.ERROR) "RTN","DGENUPLB",90,0) I ERROR!(ORIGTS="") D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 3",.ERRCOUNT) Q "RTN","DGENUPLB",91,0) S EDITTS=$$CONVERT^DGENUPL1(SEG(5),"TS",.ERROR) "RTN","DGENUPLB",92,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 5",.ERRCOUNT) Q "RTN","DGENUPLB",93,0) S ENTBY=$$GET1^DIQ(200,".5,",.01) ; DG*5.3*977 OTH-EXT set user to POSTMASTER instead of value from ZTE.6 "RTN","DGENUPLB",94,0) S FCLTY=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR) "RTN","DGENUPLB",95,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 7",.ERRCOUNT) Q "RTN","DGENUPLB",96,0) S QFLG=0 "RTN","DGENUPLB",97,0) I TYPE="P" D Q:QFLG "RTN","DGENUPLB",98,0) .I $G(DGOTH("P"))'="" S ERROR=1 "RTN","DGENUPLB",99,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid ZTE segment, only one pending request is allowed.",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",100,0) .S DGOTH("P")="1"_U_SUBDT_U_ENTBY_U_FCLTY_U_ORIGTS_U_EDITTS "RTN","DGENUPLB",101,0) .Q "RTN","DGENUPLB",102,0) I TYPE="D" D Q:QFLG "RTN","DGENUPLB",103,0) .S CNT=$O(DGOTH("D",""),-1)+1 "RTN","DGENUPLB",104,0) .S DGOTH("D",CNT)=SUBDT "RTN","DGENUPLB",105,0) .S $P(DGOTH("D",CNT),U,2)=$$CONVERT^DGENUPL1(SEG(13),,.ERROR) "RTN","DGENUPLB",106,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 13",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",107,0) .S DGOTH("D",CNT)=DGOTH("D",CNT)_U_ENTBY_U_FCLTY_U_ORIGTS_U_EDITTS "RTN","DGENUPLB",108,0) .Q "RTN","DGENUPLB",109,0) I TYPE="A" D Q:QFLG "RTN","DGENUPLB",110,0) .S CNT=$O(DGOTH("A",""),-1)+1 "RTN","DGENUPLB",111,0) .S DGOTH("A",CNT)=$$CONVERT^DGENUPL1(SEG(8),,.ERROR) "RTN","DGENUPLB",112,0) .I CHKFLG,+DGOTH("A",CNT)'>0 S ERROR=1 "RTN","DGENUPLB",113,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 8",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",114,0) .S $P(DGOTH("A",CNT),U,2)=$$CONVERT^DGENUPL1(SEG(9),,.ERROR) "RTN","DGENUPLB",115,0) .I CHKFLG,+$P(DGOTH("A",CNT),U,2)'>0 S ERROR=1 "RTN","DGENUPLB",116,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 9",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",117,0) .S $P(DGOTH("A",CNT),U,3)=SUBDT "RTN","DGENUPLB",118,0) .S $P(DGOTH("A",CNT),U,4)=$$CONVERT^DGENUPL1(SEG(11),,.ERROR) "RTN","DGENUPLB",119,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 11",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",120,0) .S $P(DGOTH("A",CNT),U,5)=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR) "RTN","DGENUPLB",121,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 10",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",122,0) .S $P(DGOTH("A",CNT),U,6)=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR) "RTN","DGENUPLB",123,0) .I CHKFLG,$P(DGOTH("A",CNT),U,6)="" S ERROR=1 "RTN","DGENUPLB",124,0) .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZTE segment, field 12",.ERRCOUNT) S QFLG=1 Q "RTN","DGENUPLB",125,0) .S DGOTH("A",CNT)=DGOTH("A",CNT)_U_ENTBY_U_FCLTY_U_ORIGTS_U_EDITTS "RTN","DGENUPLB",126,0) .Q "RTN","DGENUPLB",127,0) Q "RTN","DGENUPLB",128,0) ZCE ; process ZCE segment DG*5.3*1014 "RTN","DGENUPLB",129,0) N DGCPCD,DGEFDT,DGEDDT,DGLUTS "RTN","DGENUPLB",130,0) S DGCPCD=$$CONVERT^DGENUPL1(SEG(2),,.ERROR) I "^A^C^I^T^"'[(U_DGCPCD_U) S ERROR=1 "RTN","DGENUPLB",131,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZCE segment, field 2",.ERRCOUNT) Q "RTN","DGENUPLB",132,0) S DGEFDT=$$CONVERT^DGENUPL1(SEG(3),"DATE",.ERROR) "RTN","DGENUPLB",133,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZCE segment, field 3",.ERRCOUNT) Q "RTN","DGENUPLB",134,0) S DGEDDT=$$CONVERT^DGENUPL1(SEG(4),"DATE",.ERROR) "RTN","DGENUPLB",135,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZCE segment, field 4",.ERRCOUNT) Q "RTN","DGENUPLB",136,0) S DGLUTS=$$CONVERT^DGENUPL1(SEG(5),"TS",.ERROR) "RTN","DGENUPLB",137,0) I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"Invalid value in ZCE segment, field 5",.ERRCOUNT) Q "RTN","DGENUPLB",138,0) S DGCCPC=DGCCPC+1 "RTN","DGENUPLB",139,0) S DGCCPG(DGCCPC)=DGCPCD_U_DGEFDT_U_DGEDDT_U_DGLUTS "RTN","DGENUPLB",140,0) Q "RTN","DGLOCK1") 0^43^B21838410 "RTN","DGLOCK1",1,0) DGLOCK1 ;ALB/MRL,JAM - PATIENT FILE DATA EDIT CHECK ; 28 JUL 86 "RTN","DGLOCK1",2,0) ;;5.3;Registration;**121,314,1014**;Aug 13, 1993;Build 42 "RTN","DGLOCK1",3,0) AOD ;AO Delete "RTN","DGLOCK1",4,0) I $D(^DPT(DFN,.321)),$P(^(.321),U,2)="Y" W !?4,*7,"Can't delete as long as Agent Orange exposure is indicated." K X "RTN","DGLOCK1",5,0) Q "RTN","DGLOCK1",6,0) COMD ;Combat Delete "RTN","DGLOCK1",7,0) I $D(^DPT(DFN,.52)),$P(^(.52),U,11)="Y" W !?4,*7,"Can't delete as long as Combat Service is indicated." K X "RTN","DGLOCK1",8,0) Q "RTN","DGLOCK1",9,0) INED ;Ineligible Delete "RTN","DGLOCK1",10,0) I $D(^DPT(DFN,.15)),$P(^(.15),U,2)]"" W !?4,*7,"Can't delete this field as long as 'INELIGIBLE DATE' is on file." K X "RTN","DGLOCK1",11,0) Q "RTN","DGLOCK1",12,0) IRD ;ION Rad Delete "RTN","DGLOCK1",13,0) I $D(^DPT(DFN,.321)),$P(^(.321),U,3)="Y" W !?4,*7,"Can't delete as long as Ionizing Radiation exposure is indicated." K X "RTN","DGLOCK1",14,0) Q "RTN","DGLOCK1",15,0) POWD ;POW Delete "RTN","DGLOCK1",16,0) I $D(^DPT(DFN,.52)),$P(^(.52),U,5)="Y" W !?4,*7,"Still identified as former POW...Change status to delete." K X "RTN","DGLOCK1",17,0) Q "RTN","DGLOCK1",18,0) TADD ;Temp Add Delete "RTN","DGLOCK1",19,0) I $D(^DPT(DFN,.121)),$P(^(.121),U,9)="Y" W !?4,*7,"Answer NO to the 'WANT TO ENTER TEMPORARY ADDRESS' prompt, then delete." K X "RTN","DGLOCK1",20,0) Q "RTN","DGLOCK1",21,0) VND ;Viet Svc Delete "RTN","DGLOCK1",22,0) I $D(^DPT(DFN,.321)),$P(^(.321),U,1)="Y" W !?4,*7,"Can't delete as long as Vietnam Service is still indicated." K X "RTN","DGLOCK1",23,0) Q "RTN","DGLOCK1",24,0) SVDEL ;Panama, Grenada, Lebanon, Persian Gulf Svc Delete "RTN","DGLOCK1",25,0) ;DGX = piece position of corresponding service indicated? field "RTN","DGLOCK1",26,0) I $D(^DPT(DFN,.322)),$P(^(.322),U,DGX)="Y" W !?4,*7,"Can't delete as long as ",$S(DGX=1:"Lebanon",DGX=4:"Grenada",DGX=7:"Panama",1:"Persian Gulf")," is still indicated." K X "RTN","DGLOCK1",27,0) K DGX "RTN","DGLOCK1",28,0) Q "RTN","DGLOCK1",29,0) EC S DGEC=$S('$D(^DPT(DFN,.36)):"",$D(^DIC(8,+$P(^DPT(DFN,.36),U,1),0)):$P(^(0),U,9),1:"") I DGEC=5 W !?4,*7,"Eligibility Code is 'NSC'...Can't be YES." K X,DGEC Q "RTN","DGLOCK1",30,0) K DGEC Q "RTN","DGLOCK1",31,0) POS ;Screen "RTN","DGLOCK1",32,0) K DGEC D SV1^DGLOCK I $D(X) S DIC("S")="I '$P(^(0),""^"",8),$D(^DPT(DA,.36)),$D(^DIC(21,+Y,""E"",+$P(^(.36),U,1)))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X D:'$D(X) POSH I $D(X),$D(^DIC(21,X,0)),$P(^(0),U,7)]"" D POS1 Q "RTN","DGLOCK1",33,0) Q "RTN","DGLOCK1",34,0) POS1 S XX=$P(^DIC(21,X,0),U,7) I $P(^DPT(DA,0),U,3)]"" I $P(^(0),U,3)'>XX!($D(^XUSEC("DG ELIGIBILITY",DUZ))) K XX Q "RTN","DGLOCK1",35,0) W !?5,*7,"Applicant is too young to have served in that period of service.",!?5,"See your supervisor if you require assistance." K X,XX Q "RTN","DGLOCK1",36,0) POSH S DGEC=$S('$D(^DPT(DFN,.36)):"",$D(^DIC(8,+$P(^(.36),U,1),0)):$P(^(0),U,1),1:"") W !?5,"Current Eligibility Code" W:DGEC]"" ": ",DGEC I DGEC']"" W " is not defined. Must be defined in order",!?5,"to enter a POS." "RTN","DGLOCK1",37,0) K DGEC Q "RTN","DGLOCK1",38,0) SC S DGSCON=$S('$D(^DPT(DFN,.3)):0,$P(^(.3),U,1)="Y":1,1:0) I 'DGSCON W !?4,*7,"Not possible, applicant is not service-connected." K X,DGSCON Q "RTN","DGLOCK1",39,0) K DGSCON Q "RTN","DGLOCK1",40,0) ; "RTN","DGLOCK1",41,0) ECD ;primary eligibility code input transform "RTN","DGLOCK1",42,0) ; "RTN","DGLOCK1",43,0) N DGNODE,DGPC,DGSER,DGVT,DGXX,DGCOV "RTN","DGLOCK1",44,0) S DGVT=$G(^DPT(DFN,"VET")),DGSER=$S('$D(^DPT(DFN,.3)):0,$P(^(.3),U,1)="Y":1,1:0) "RTN","DGLOCK1",45,0) I DGVT']"" K X W !?4,*7,"'VETERAN (Y/N)' prompt must be answered to select an Eligibility Code'" Q "RTN","DGLOCK1",46,0) ; DG*5.3*1014 - Capture if COLLATERAL OF VET is the current Primary Eligibility "RTN","DGLOCK1",47,0) S DGCOV=0 I $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET." S DGCOV=1 "RTN","DGLOCK1",48,0) S DIC("S")="I $P(^DIC(8,+Y,0),U,5)=DGVT,'$P(^(0),U,7)" I DGVT="N" G ECDS "RTN","DGLOCK1",49,0) I DGSER S DGPC=$S(+$P(^DPT(DFN,.3),U,2)>49:1,1:0),DGXX=$S(DGPC:1,1:3),DIC("S")=DIC("S")_",($P(^(0),U,9)="_DGXX_")" G ECDS ;sc only "RTN","DGLOCK1",50,0) I $P($G(^DPT(DFN,.52)),"^",5)="Y" S DIC("S")=DIC("S")_",($P(^(0),U,9)=18)" G ECDS ;pow only "RTN","DGLOCK1",51,0) S DGXX="^1^3^18^" ; no sc<50, sc 50-100, pow "RTN","DGLOCK1",52,0) I $P($G(^DPT(DFN,.53)),U)="Y" S DIC("S")=DIC("S")_",($P(^(0),U,9)=22)" G ECDS ;checks for PH Indicator "RTN","DGLOCK1",53,0) S DGXX=DGXX_"22^" ;adds PH to DGXX string "RTN","DGLOCK1",54,0) S DGNODE=$G(^DPT(DFN,.362)) "RTN","DGLOCK1",55,0) I $P(DGNODE,"^",12)'="Y" S DGXX=DGXX_"2^" "RTN","DGLOCK1",56,0) I $P(DGNODE,"^",14)'="Y" S DGXX=DGXX_"4^" "RTN","DGLOCK1",57,0) I $P(DGNODE,"^",13)'="Y" S DGXX=DGXX_"15^" "RTN","DGLOCK1",58,0) F I=12:1:14 I $P(DGNODE,"^",I)="Y" S DGXX=DGXX_"5^"_$S(I'=14:"4^",1:"") "RTN","DGLOCK1",59,0) I $P($G(^DPT(DFN,0)),"^",3)>2200101 S DGXX=DGXX_"16^17^" ; WWI or mexican border only "RTN","DGLOCK1",60,0) S DIC("S")=DIC("S")_",("""_DGXX_"""'[(U_$P(^(0),U,9)_U))" "RTN","DGLOCK1",61,0) ECDS D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "RTN","DGLOCK1",62,0) ; "RTN","DGLOCK1",63,0) ;catastrophic disability can not be primary "RTN","DGLOCK1",64,0) I $G(X),$$NATNAME^DGENELA(X)="CATASTROPHICALLY DISABLED" K X Q "RTN","DGLOCK1",65,0) ; "RTN","DGLOCK1",66,0) ; DG*5.3*1014 - if editing Primary Eligibility "COLLATERAL OF VET", save off any CCPs "RTN","DGLOCK1",67,0) I $G(X),DGCOV D REMOVE^DGRP1152U(DFN) "RTN","DGLOCK1",68,0) Q "RTN","DGLOCK3") 0^44^B10959586 "RTN","DGLOCK3",1,0) DGLOCK3 ;ALB/BOK,BAJ,JAM - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECKS ; 01/23/2006 "RTN","DGLOCK3",2,0) ;;5.3;Registration;**489,527,688,1014**;Aug 13,1993;Build 42 "RTN","DGLOCK3",3,0) ; DG*5.3*688 BAJ 01/23/2006 Changed to support foreign confidential addresses "RTN","DGLOCK3",4,0) KILL S DGX=X I $D(^DPT(DFN,.32)) F DGKZ=0:0 S DGKZ=$O(DGBZ(DGKZ)) Q:'DGKZ S X=$P(^DPT(DFN,.32),"^",DGKZ),$P(^(.32),"^",DGKZ)="" I X]"" S DGIZ=$S(DGKZ=20:.32945,1:(DGKZ/10000+.3281)) I $D(^DD(2,DGIZ,1)) D KILL1 "RTN","DGLOCK3",5,0) S X=DGX "RTN","DGLOCK3",6,0) Q "RTN","DGLOCK3",7,0) KILL1 F DGJZ=0:0 S DGJZ=$O(^DD(2,DGIZ,1,DGJZ)) Q:'DGJZ X ^(DGJZ,2) "RTN","DGLOCK3",8,0) Q "RTN","DGLOCK3",9,0) S1 K DGBZ F DGKZ=9:1:13,20 S DGBZ(DGKZ)="" "RTN","DGLOCK3",10,0) D KILL K DGBZ,DGIZ,DGJZ,DGKZ "RTN","DGLOCK3",11,0) Q "RTN","DGLOCK3",12,0) S2 K DGBZ F DGKZ=14:1:18 S DGBZ(DGKZ)="" "RTN","DGLOCK3",13,0) D KILL K DGBZ,DGIZ,DGJZ,DGKZ "RTN","DGLOCK3",14,0) Q "RTN","DGLOCK3",15,0) CAD ;Confidential Address Edit "RTN","DGLOCK3",16,0) I $S('$D(^DPT(DFN,.141)):1,$P(^(.141),U,9)'="Y":1,1:0) D "RTN","DGLOCK3",17,0) .D EN^DDIOL("Requirement for Confidential Address data not indicated...NO EDITING!","","$C(7),!?4") K X "RTN","DGLOCK3",18,0) Q "RTN","DGLOCK3",19,0) CADD ;Confidential Address Delete "RTN","DGLOCK3",20,0) ;Called from input transform on Confidential Address fields "RTN","DGLOCK3",21,0) Q:'$D(^DPT(DFN,.141)) I $P(^(.141),"^",9)="N"!($P(^(.141),"^",1,6)="^^^^^") D Q "RTN","DGLOCK3",22,0) .N DGFDA,DGERR "RTN","DGLOCK3",23,0) .D CADM "RTN","DGLOCK3",24,0) .I $D(DGFDA) D "RTN","DGLOCK3",25,0) ..N DGX "RTN","DGLOCK3",26,0) ..S DGX=X "RTN","DGLOCK3",27,0) ..D FILE^DIE("","DGFDA","DGERR") "RTN","DGLOCK3",28,0) ..S X=DGX "RTN","DGLOCK3",29,0) ; "RTN","DGLOCK3",30,0) ASK W !,"Do you want to delete all confidential address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove confidential address information, 'N'o to leave data in file" G ASK "RTN","DGLOCK3",31,0) ASK1 ; "RTN","DGLOCK3",32,0) Q:%'=1 "RTN","DGLOCK3",33,0) D EN^DGCLEAR(DFN,"CONF") "RTN","DGLOCK3",34,0) D CADM "RTN","DGLOCK3",35,0) N DGX "RTN","DGLOCK3",36,0) S DGX=X "RTN","DGLOCK3",37,0) D FILE^DIE("","DGFDA","DGERR") "RTN","DGLOCK3",38,0) S X=DGX "RTN","DGLOCK3",39,0) Q "RTN","DGLOCK3",40,0) CADM ;Delete data from Confidential Address Categories "RTN","DGLOCK3",41,0) I $D(^DPT(DFN,.14)) D "RTN","DGLOCK3",42,0) .N DGIEN "RTN","DGLOCK3",43,0) .S DGIEN=0 "RTN","DGLOCK3",44,0) .F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D "RTN","DGLOCK3",45,0) ..S DGFDA(2.141,DGIEN_","_DFN_",",.01)="" "RTN","DGLOCK3",46,0) Q "RTN","DGLOCK3",47,0) CADD1 ;Confidential Address Delete "RTN","DGLOCK3",48,0) ;Called from Confidential Address "DEL" nodes "RTN","DGLOCK3",49,0) I $D(^DPT(DFN,.141)),$P(^(.141),U,9)="Y" D "RTN","DGLOCK3",50,0) .D EN^DDIOL("Answer NO to the 'CONFIDENTIAL ADDRESS ACTIVE' prompt to delete.","","$C(7),!?4") K X "RTN","DGLOCK3",51,0) Q "RTN","DGLOCK3",52,0) ; "RTN","DGLOCK3",53,0) COV(DGELG) ; Rule for deleting COLLATERAL OF VET eligibility code DG*5.3*1014;jam; "RTN","DGLOCK3",54,0) ; Cannot delete COV if there is an active CCP assigned to the Patient "RTN","DGLOCK3",55,0) ; Invoked by: "RTN","DGLOCK3",56,0) ; DELETE TEST - .361 (PRIMARY ELIGIBILITY) "RTN","DGLOCK3",57,0) ; - .01 (ELIGIBILITY CODE) of the PATIENT ELIGIBILITIES subfile (.0361) "RTN","DGLOCK3",58,0) ; Input: DGELG - Eligibility code being deleted (Optional - defaults to Primary Elig Code, field .361) "RTN","DGLOCK3",59,0) ; "RTN","DGLOCK3",60,0) I $G(DGELG)="" S DGELG=$$GET1^DIQ(2,DFN_",",.361,"I") "RTN","DGLOCK3",61,0) ; OK if not deleting COLLATERAL OF VET "RTN","DGLOCK3",62,0) I DGELG'=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") Q "RTN","DGLOCK3",63,0) N DGFLG,DGCCP "RTN","DGLOCK3",64,0) S (DGFLG,DGCCP)=0 "RTN","DGLOCK3",65,0) F S DGCCP=$O(^DPT(DFN,5,DGCCP)) Q:'DGCCP I $G(^DPT(DFN,5,DGCCP,0))'="" D Q:DGFLG "RTN","DGLOCK3",66,0) . ; If CCP without an End Date - cannot delete COV "RTN","DGLOCK3",67,0) . I '$P(^DPT(DFN,5,DGCCP,0),"^",4) S DGFLG=1 "RTN","DGLOCK3",68,0) I DGFLG D EN^DDIOL("This eligibility cannot be removed while there are active CCP(s) assigned to the Patient. Please advance to Data Group [2] on Screen <11.5> to remove the active CCP(s).") K X "RTN","DGLOCK3",69,0) Q "RTN","DGMTSC4") 0^18^B29917122 "RTN","DGMTSC4",1,0) DGMTSC4 ;ALB/RMO/CAW,LBD,HM - Means Test Screen Net Worth ;11/7/03 1:44pm "RTN","DGMTSC4",2,0) ;;5.3;Registration;**45,130,456,540,567,1014**;Aug 13, 1993;Build 42 "RTN","DGMTSC4",3,0) ; "RTN","DGMTSC4",4,0) ; Input -- DFN Patient IEN "RTN","DGMTSC4",5,0) ; DGMTDT Date of Test "RTN","DGMTSC4",6,0) ; DGMTYPT Type of Test 1=MT 2=COPAY "RTN","DGMTSC4",7,0) ; DGMTPAR Annual Means Test Parameter Array "RTN","DGMTSC4",8,0) ; DGVINI Veteran Individual Annual Income IEN "RTN","DGMTSC4",9,0) ; DGVIRI Veteran Income Relation IEN "RTN","DGMTSC4",10,0) ; DGVPRI Veteran Patient Relation IEN "RTN","DGMTSC4",11,0) ; DGMTNWC Net Worth Calculation flag "RTN","DGMTSC4",12,0) ; DGMTACT Global variable, Means test action being perfomed, set when DGMTE, DGMTA, or DGMTEO is called "RTN","DGMTSC4",13,0) ; Output -- None "RTN","DGMTSC4",14,0) ; "RTN","DGMTSC4",15,0) ;DG*5.3*540 - Skip displaying of calculated Means Test Status at the "RTN","DGMTSC4",16,0) ; bottom of screen 4 when in VIEW mode. "RTN","DGMTSC4",17,0) ;DG*5.3*567 - Allow bottom to show for all except SOURCE OF TEST[IVM "RTN","DGMTSC4",18,0) ; for IVM display Source is IVM instead. "RTN","DGMTSC4",19,0) ; "RTN","DGMTSC4",20,0) EN ;Entry point for previous calendar year net worth screen "RTN","DGMTSC4",21,0) I DGMTACT'="EDT"&(DGMTACT'="ADD")&(DGMTACT'="COM") D G EN^DGMTSCR ;DG*5.3*1014 check if entry point in screen was from edit, add, or complete a means test and skip screen 4 "RTN","DGMTSC4",22,0) .D DEP^DGMTSCU2,INC^DGMTSCU3 ;DG*5.3*1014 set variable for screen 4 display "RTN","DGMTSC4",23,0) .N DGVET,DGSPD S (DGVET,DGSPD)="" "RTN","DGMTSC4",24,0) .S DGVET(1)=$P($G(DGIN2("V")),U),DGVET(2)=$P($G(DGIN2("V")),U,3),DGVET(3)=$P($G(DGIN2("V")),U,4) "RTN","DGMTSC4",25,0) .S DGSPD(1)=$P($G(DGIN2("S")),U),DGSPD(2)=$P($G(DGIN2("S")),U,3),DGSPD(3)=$P($G(DGIN2("S")),U,4) "RTN","DGMTSC4",26,0) .S DGMTSCI=4 I DGVET(1)'=""!(DGVET(2)'="")!(DGVET(3)'="")!(DGSPD(1)'="")!(DGSPD(2)'="")!(DGSPD(3)'="") D HD^DGMTSCU "RTN","DGMTSC4",27,0) .I DGVET(1)=""&(DGVET(2)="")&(DGVET(3)="") S DGSCR1=1 "RTN","DGMTSC4",28,0) .I DGSPD(1)=""&(DGSPD(2)="")&(DGSPD(3)="") S DGSCR1=1 "RTN","DGMTSC4",29,0) .I $$GETNAME^DGMTH(DGMTSCI)'="MT COPAY EXEMPT",DGVET(1)'=""!(DGVET(2)'="")!(DGVET(3)'="")!(DGSPD(1)'="")!(DGSPD(2)'="")!(DGSPD(3)'="") D DIS ;DG*5.3*1014 do screen 4 if not MT COPAY EXEMPT "RTN","DGMTSC4",30,0) .I $$GETNAME^DGMTH(DGMTSCI)="MT COPAY EXEMPT"&(DGMTACT'="EDT")&(DGMTACT'="ADD")&(DGMTACT'="COM") D ;DG*5.3*1014 do screen 4 if not edit, add, or complete and status is MT COPAY EXEMPT "RTN","DGMTSC4",31,0) ..I DGVET(1)'=""!(DGVET(2)'="")!(DGVET(3)'="")!(DGSPD(1)'="")!(DGSPD(2)'="")!(DGSPD(3)'="") D DIS ;if financial data exists for screen 4 display "RTN","DGMTSC4",32,0) .S DGRNG="1-3" "RTN","DGMTSC4",33,0) .I $G(DGSCR1),DGSCR1=1 D MTMSG ;DG*5.3*1014 display MT status message "RTN","DGMTSC4",34,0) I DGMTACT="EDT"!(DGMTACT="ADD")!(DGMTACT="COM") S DGRNG="1-3",DGMTSCI=4 D FEED^DGMTSCR,EN1^DGMTSCR Q ;DG*5.3*1014 do not rewrite bottom of screen "RTN","DGMTSC4",35,0) ; "RTN","DGMTSC4",36,0) EN1 ;Entry point for read processor return "RTN","DGMTSC4",37,0) D ALL^DGMTU21(DFN,"S",DGMTDT,"IPR",$S($G(DGMTI):DGMTI,1:"")) "RTN","DGMTSC4",38,0) I DGX!($G(DGSELTY)["V") S DGPRI=DGVPRI,DGPRTY="V" D EDT "RTN","DGMTSC4",39,0) I '$G(DGMTOUT)&($G(DGSEL)["S")&(DGX!($G(DGSELTY)["S")) S DGPRI=+DGREL("S"),DGPRTY="S" D EDT "RTN","DGMTSC4",40,0) Q K DGCNT,DGDEP,DGDR,DGMTOUT,DGPRI,DGPRTY,DGREL,DGSEL,DGSELTY,DGX,DGY,DTOUT,DUOUT,Y "RTN","DGMTSC4",41,0) G EN "RTN","DGMTSC4",42,0) ; "RTN","DGMTSC4",43,0) DIS ;Display net worth "RTN","DGMTSC4",44,0) N DGCAT,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGSP,DGTYC,DGTHA,DGTHB,DGTHG,DGVIR0,DGCNT "RTN","DGMTSC4",45,0) D SET^DGMTSCU2 S DGCNT=1 "RTN","DGMTSC4",46,0) I DGMTYPT=1 W !,"Income Thresholds: " W:$D(DGTHA) "MT Threshold: ",$$AMT^DGMTSCU1(DGTHA) W:$D(DGTHG) ?53,"GMT Threshold: ",$$AMT^DGMTSCU1(DGTHG) "RTN","DGMTSC4",47,0) W ! W:$D(DGMTPAR("PREV")) "*Previous Years Thresholds*" "RTN","DGMTSC4",48,0) W ?34,"Veteran" W:DGSP ?46,"Spouse" W ?73,"Total" "RTN","DGMTSC4",49,0) W !?31,"-----------------------------------------------" "RTN","DGMTSC4",50,0) D HIGH^DGMTSCU1(1,DGMTACT),FLD(.DGIN2,1,"Cash, Amts in Bank Accts") "RTN","DGMTSC4",51,0) D HIGH^DGMTSCU1(2,DGMTACT),FLD(.DGIN2,2,"Stocks and Bonds") "RTN","DGMTSC4",52,0) D HIGH^DGMTSCU1(3,DGMTACT),FLD(.DGIN2,3,"Real Property") "RTN","DGMTSC4",53,0) D HIGH^DGMTSCU1(4,DGMTACT),FLD(.DGIN2,4,"Other Property or Assets") "RTN","DGMTSC4",54,0) D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN2,5,"Debts") "RTN","DGMTSC4",55,0) W !?51,"Total -->",?66,$J($$AMT^DGMTSCU1(DGNWT),12) "RTN","DGMTSC4",56,0) I DGMTYPT=1,DGMTACT="VEW",$P($G(DGMT0),"^",14) W !!!!!!!!,"Declines to give income information makes a MT COPAY REQUIRED status." G DISQ "RTN","DGMTSC4",57,0) ; "RTN","DGMTSC4",58,0) ;DG*5.3*540 "RTN","DGMTSC4",59,0) ;DG*5.3*567 "RTN","DGMTSC4",60,0) I DGMTACT="VEW",DGMTI,$$GET1^DIQ(408.31,DGMTI,.23)["IVM" D G DISQ "RTN","DGMTSC4",61,0) . W !!!!!!!!,"Source of Test is IVM" "RTN","DGMTSC4",62,0) K DGSCR1 ;DG*5.3*1014 kill variable to not display repeating info "RTN","DGMTSC4",63,0) MTMSG ;DG*5.3*1014 only display for view a past means test "RTN","DGMTSC4",64,0) I DGMTACT="VEW" D "RTN","DGMTSC4",65,0) .D DEP^DGMTSCU2,INC^DGMTSCU3 "RTN","DGMTSC4",66,0) .S DGCAT=$P(^DGMT(408.31,DGMTI,0),"^",3),DGCAT=$P(^DG(408.32,DGCAT,0),"^",2) D STA^DGMTSCU2 S DGCNT=1 "RTN","DGMTSC4",67,0) .W !!!!!! I DGMTYPT=1 W "Income of ",$J($$AMT^DGMTSCU1(DGINT-DGDET),12) W " ",$$GETNAME^DGMTH(DGMTS) "RTN","DGMTSC4",68,0) .;I DGMTYPT=1,DGTYC="M",(DGNWT-DGDET)+$S($G(DGMTNWC):0,1:DGINT)'<$P(DGMTPAR,"^",8) W !,?3,"with property of ",$J($$AMT^DGMTSCU1(DGNWT),12)," makes a ",$S(DGTHG>DGTHA:"G",1:""),"MT COPAY REQUIRED status." "RTN","DGMTSC4",69,0) .;I DGTYC="M",'DGNWTF W " requires property information." "RTN","DGMTSC4",70,0) .;I DGMTYPT=2,'DGNWTF,DGCAT="E" W "Requires property information." "RTN","DGMTSC4",71,0) DISQ Q "RTN","DGMTSC4",72,0) ; "RTN","DGMTSC4",73,0) FLD(DGIN,DGPCE,DGTXT) ;Display income fields "RTN","DGMTSC4",74,0) ; "RTN","DGMTSC4",75,0) ; Input -- DGIN as Individual Annual Income 0 node for vet, "RTN","DGMTSC4",76,0) ; spouse, and dependents "RTN","DGMTSC4",77,0) ; DGRPCE as piece position wanted "RTN","DGMTSC4",78,0) ; DGTXT as income description "RTN","DGMTSC4",79,0) ; "RTN","DGMTSC4",80,0) ; Also keeps running total if DGGTOT is defined (grand "RTN","DGMTSC4",81,0) ; total) "RTN","DGMTSC4",82,0) ; "RTN","DGMTSC4",83,0) N DGTOT,I "RTN","DGMTSC4",84,0) I '$D(DGBL) S $P(DGBL," ",26)="" "RTN","DGMTSC4",85,0) W:DGCNT<10 " " "RTN","DGMTSC4",86,0) W " ",$E(DGTXT_DGBL,1,26) "RTN","DGMTSC4",87,0) W $J($$AMT^DGMTSCU1($P(DGIN("V"),"^",DGPCE)),10) "RTN","DGMTSC4",88,0) W " ",$S($D(DGIN("S")):$J($$AMT^DGMTSCU1($P(DGIN("S"),"^",DGPCE)),10),1:$E(DGBL,1,10)) "RTN","DGMTSC4",89,0) W " ",$S($D(DGIN("D")):$J($$AMT^DGMTSCU1($P(DGIN("D"),"^",DGPCE)),11),1:$E(DGBL,1,11)) "RTN","DGMTSC4",90,0) S DGTOT="",I="" F S I=$O(DGIN(I)) Q:I="" I $P(DGIN(I),"^",DGPCE)]"" S DGTOT=DGTOT+$P(DGIN(I),"^",DGPCE) "RTN","DGMTSC4",91,0) W " ",$J($$AMT^DGMTSCU1(DGTOT),12) "RTN","DGMTSC4",92,0) S DGCNT=DGCNT+1 "RTN","DGMTSC4",93,0) Q "RTN","DGMTSC4",94,0) ; "RTN","DGMTSC4",95,0) EDT ;Edit net worth fields "RTN","DGMTSC4",96,0) N DA,DGERR,DGFIN,DGINI,DGIN2,DGIRI,DIE,DR "RTN","DGMTSC4",97,0) D GETIENS^DGMTU2(DFN,DGPRI,DGMTDT) G EDTQ:DGERR "RTN","DGMTSC4",98,0) I $G(DGSEL)]"" W !!,"NAME: ",$$NAME^DGMTU1(DGPRI) "RTN","DGMTSC4",99,0) S DGIN2=$G(^DGMT(408.21,DGINI,2)) "RTN","DGMTSC4",100,0) S DA=DGINI,DIE="^DGMT(408.21,",DR="[DGMT ENTER/EDIT NET WORTH]" D ^DIE S:'$D(DGFIN) DGMTOUT=1 "RTN","DGMTSC4",101,0) I DGIN2'=$G(^DGMT(408.21,DGINI,2)) S DR="103////^S X=DUZ;104///^S X=""NOW""" D ^DIE "RTN","DGMTSC4",102,0) EDTQ Q "RTN","DGMTSC4V") 0^19^B31073713 "RTN","DGMTSC4V",1,0) DGMTSC4V ;ALB/AMA,HM - Means Test Screen Net Worth For MT Version 1 ;11/7/03 1:44pm "RTN","DGMTSC4V",2,0) ;;5.3;Registration;**688,1014**;Aug 13, 1993;Build 42 "RTN","DGMTSC4V",3,0) ;Copied from DGMTSC4 "RTN","DGMTSC4V",4,0) ; "RTN","DGMTSC4V",5,0) ; Input -- DFN Patient IEN "RTN","DGMTSC4V",6,0) ; DGMTDT Date of Test "RTN","DGMTSC4V",7,0) ; DGMTYPT Type of Test 1=MT 2=COPAY "RTN","DGMTSC4V",8,0) ; DGMTPAR Annual Means Test Parameter Array "RTN","DGMTSC4V",9,0) ; DGVINI Veteran Individual Annual Income IEN "RTN","DGMTSC4V",10,0) ; DGVIRI Veteran Income Relation IEN "RTN","DGMTSC4V",11,0) ; DGVPRI Veteran Patient Relation IEN "RTN","DGMTSC4V",12,0) ; DGMTNWC Net Worth Calculation flag "RTN","DGMTSC4V",13,0) ; DGMTACT Global variable, Means test action being perfomed, set when DGMTE, DGMTA, or DGMTEO is called "RTN","DGMTSC4V",14,0) ; Output -- None "RTN","DGMTSC4V",15,0) ; "RTN","DGMTSC4V",16,0) EN ;Entry point for previous calendar year net worth screen "RTN","DGMTSC4V",17,0) I DGMTACT'="EDT"&(DGMTACT'="ADD")&(DGMTACT'="COM") D G EN^DGMTSCR ;DG*5.3*1014 check if entry point in screen was from edit, add, or complete a means test and skip screen 4 "RTN","DGMTSC4V",18,0) .D DEP^DGMTSCU2,INC^DGMTSCU3 ;DG*5.3*1014 set variable for screen 4 display "RTN","DGMTSC4V",19,0) .N DGVET,DGSPD S (DGVET,DGSPD)="" "RTN","DGMTSC4V",20,0) .S DGVET(1)=$P($G(DGIN2("V")),U),DGVET(2)=$P($G(DGIN2("V")),U,3),DGVET(3)=$P($G(DGIN2("V")),U,4) "RTN","DGMTSC4V",21,0) .S DGSPD(1)=$P($G(DGIN2("S")),U),DGSPD(2)=$P($G(DGIN2("S")),U,3),DGSPD(3)=$P($G(DGIN2("S")),U,4) "RTN","DGMTSC4V",22,0) .S DGMTSCI=4 I DGVET(1)'=""!(DGVET(2)'="")!(DGVET(3)'="")!(DGSPD(1)'="")!(DGSPD(2)'="")!(DGSPD(3)'="") D HD^DGMTSCU "RTN","DGMTSC4V",23,0) .I DGVET(1)=""&(DGVET(2)="")&(DGVET(3)="") S DGSCR1=1 "RTN","DGMTSC4V",24,0) .I DGSPD(1)=""&(DGSPD(2)="")&(DGSPD(3)="") S DGSCR1=1 "RTN","DGMTSC4V",25,0) .I $$GETNAME^DGMTH(DGMTSCI)'="MT COPAY EXEMPT",DGVET(1)'=""!(DGVET(2)'="")!(DGVET(3)'="")!(DGSPD(1)'="")!(DGSPD(2)'="")!(DGSPD(3)'="") D DIS ;DG*5.3*1014 do screen 4 if not MT COPAY EXEMPT "RTN","DGMTSC4V",26,0) .I $$GETNAME^DGMTH(DGMTSCI)="MT COPAY EXEMPT"&(DGMTACT'="EDT")&(DGMTACT'="ADD")&(DGMTACT'="COM") D ;DG*5.3*1014 do screen 4 if not edit, add, or complete and status is MT COPAY EXEMPT "RTN","DGMTSC4V",27,0) ..I DGVET(1)'=""!(DGVET(2)'="")!(DGVET(3)'="")!(DGSPD(1)'="")!(DGSPD(2)'="")!(DGSPD(3)'="") D DIS ;if financial data exists for screen 4 display "RTN","DGMTSC4V",28,0) .S DGRNG="1-3" "RTN","DGMTSC4V",29,0) .I $G(DGSCR1),DGSCR1=1 D MTMSG ;DG*5.3*1014 display MT status message "RTN","DGMTSC4V",30,0) I DGMTACT="EDT"!(DGMTACT="ADD")!(DGMTACT="COM") S DGRNG="1-3",DGMTSCI=4 D FEED^DGMTSCR,EN1^DGMTSCR Q ;DG*5.3*1014 do not rewrite bottom of screen "RTN","DGMTSC4V",31,0) ; "RTN","DGMTSC4V",32,0) EN1 ;Entry point for read processor return "RTN","DGMTSC4V",33,0) D ALL^DGMTU21(DFN,"CS",DGMTDT,"IPR",$S($G(DGMTI):DGMTI,1:"")) "RTN","DGMTSC4V",34,0) I DGX!($G(DGSELTY)["V") S DGPRI=DGVPRI,DGPRTY="V" D EDT "RTN","DGMTSC4V",35,0) I '$G(DGMTOUT)&($G(DGSEL)["S")&(DGX!($G(DGSELTY)["S")) S DGPRI=+DGREL("S"),DGPRTY="S" D EDT "RTN","DGMTSC4V",36,0) ;*Patch DG*5.3*688 "RTN","DGMTSC4V",37,0) I '$G(DGMTOUT)&($G(DGSEL)["C")&(DGX!($G(DGSELTY)["C")) S DGPRTY="C",DGCNT=0 F S DGCNT=$O(DGREL("C",DGCNT)) Q:'DGCNT!($G(DGMTOUT)) D "RTN","DGMTSC4V",38,0) .D CHK^DGMTSCU2 I Y S DGPRI=+DGREL("C",DGCNT) D EDT "RTN","DGMTSC4V",39,0) Q K DGCNT,DGDEP,DGDR,DGMTOUT,DGPRI,DGPRTY,DGREL,DGSEL,DGSELTY,DGX,DGY,DTOUT,DUOUT,Y "RTN","DGMTSC4V",40,0) G EN "RTN","DGMTSC4V",41,0) ; "RTN","DGMTSC4V",42,0) DIS ;Display net worth "RTN","DGMTSC4V",43,0) N DGCAT,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGSP,DGTYC,DGTHA,DGTHB,DGTHG,DGVIR0,DGCNT "RTN","DGMTSC4V",44,0) D SET^DGMTSCU2 S DGCNT=1 "RTN","DGMTSC4V",45,0) I DGMTYPT=1 W !,"Income Thresholds: " W:$D(DGTHA) "MT Threshold: ",$$AMT^DGMTSCU1(DGTHA) W:$D(DGTHG) ?53,"GMT Threshold: ",$$AMT^DGMTSCU1(DGTHG) "RTN","DGMTSC4V",46,0) W ! W:$D(DGMTPAR("PREV")) "*Previous Years Thresholds*" "RTN","DGMTSC4V",47,0) W ?34,"Veteran" W:DGSP ?47,"Spouse" W:DGDC ?57,"Children" W ?73,"Total" "RTN","DGMTSC4V",48,0) W !?31,"-----------------------------------------------" "RTN","DGMTSC4V",49,0) D HIGH^DGMTSCU1(1,DGMTACT) W " Cash, Amts in Bank Accts" "RTN","DGMTSC4V",50,0) D FLD(.DGIN2,1,"(CDs,IRAs,Stocks,Bonds):") "RTN","DGMTSC4V",51,0) D HIGH^DGMTSCU1(2,DGMTACT) W " Land,Bldgs Less Mortgage," "RTN","DGMTSC4V",52,0) D FLD(.DGIN2,3,"Liens (Not Primary Home):") "RTN","DGMTSC4V",53,0) D HIGH^DGMTSCU1(3,DGMTACT) W " Other Prop.(Farm,Bus.) Or" "RTN","DGMTSC4V",54,0) W !?5,"Assets (Art,Collectibles)" "RTN","DGMTSC4V",55,0) D FLD(.DGIN2,4,"Less Amount Owed:") "RTN","DGMTSC4V",56,0) W !?51,"Total -->",?66,$J($$AMT^DGMTSCU1(DGNWT),12) "RTN","DGMTSC4V",57,0) I DGMTYPT=1,DGMTACT="VEW",$P($G(DGMT0),"^",14) W !!!!!!,"Declines to give income information makes a MT COPAY REQUIRED status." G DISQ "RTN","DGMTSC4V",58,0) ; "RTN","DGMTSC4V",59,0) I DGMTACT="VEW",DGMTI,$$GET1^DIQ(408.31,DGMTI,.23)["IVM" D G DISQ "RTN","DGMTSC4V",60,0) . W !!!!!!,"Source of Test is IVM" "RTN","DGMTSC4V",61,0) K DGSCR1 ;DG*5.3*1014 kill variable to not display repeating info "RTN","DGMTSC4V",62,0) MTMSG ;DG*5.3*1014 only display for view a past means test "RTN","DGMTSC4V",63,0) I DGMTACT="VEW" D "RTN","DGMTSC4V",64,0) .D DEP^DGMTSCU2,INC^DGMTSCU3 "RTN","DGMTSC4V",65,0) .S DGCAT=$P(^DGMT(408.31,DGMTI,0),"^",3),DGCAT=$P(^DG(408.32,DGCAT,0),"^",2) D STA^DGMTSCU2 S DGCNT=1 "RTN","DGMTSC4V",66,0) .W !!!!!! I DGMTYPT=1 W "Income of ",$J($$AMT^DGMTSCU1(DGINT-DGDET),12) W " ",$$GETNAME^DGMTH(DGMTS) "RTN","DGMTSC4V",67,0) .;I DGMTYPT=1,DGTYC="M",(DGNWT-DGDET)+$S($G(DGMTNWC):0,1:DGINT)'<$P(DGMTPAR,"^",8) W !,?3,"with property of ",$J($$AMT^DGMTSCU1(DGNWT),12)," makes a ",$S(DGTHG>DGTHA:"G",1:""),"MT COPAY REQUIRED status." "RTN","DGMTSC4V",68,0) .;I DGTYC="M",'DGNWTF W " requires property information." "RTN","DGMTSC4V",69,0) .;I DGMTYPT=2,'DGNWTF,DGCAT="E" W "Requires property information." "RTN","DGMTSC4V",70,0) DISQ Q "RTN","DGMTSC4V",71,0) ; "RTN","DGMTSC4V",72,0) FLD(DGIN,DGPCE,DGTXT) ;Display income fields "RTN","DGMTSC4V",73,0) ; "RTN","DGMTSC4V",74,0) ; Input -- DGIN as Individual Annual Income 0 node for vet, "RTN","DGMTSC4V",75,0) ; spouse, and dependents "RTN","DGMTSC4V",76,0) ; DGRPCE as piece position wanted "RTN","DGMTSC4V",77,0) ; DGTXT as income description "RTN","DGMTSC4V",78,0) ; "RTN","DGMTSC4V",79,0) ; Also keeps running total if DGGTOT is defined (grand total) "RTN","DGMTSC4V",80,0) ; "RTN","DGMTSC4V",81,0) N DGTOT,I "RTN","DGMTSC4V",82,0) I '$D(DGBL) S $P(DGBL," ",26)="" "RTN","DGMTSC4V",83,0) W !?5,$E(DGTXT_DGBL,1,26) "RTN","DGMTSC4V",84,0) W $J($$AMT^DGMTSCU1($P(DGIN("V"),"^",DGPCE)),10) "RTN","DGMTSC4V",85,0) W " ",$S($D(DGIN("S")):$J($$AMT^DGMTSCU1($P(DGIN("S"),"^",DGPCE)),10),1:$E(DGBL,1,10)) "RTN","DGMTSC4V",86,0) W " ",$S($D(DGIN("C")):$J($$AMT^DGMTSCU1($P(DGIN("C"),"^",DGPCE)),11),1:$E(DGBL,1,11)) "RTN","DGMTSC4V",87,0) S DGTOT="",I="" F S I=$O(DGIN(I)) Q:I="" I $P(DGIN(I),"^",DGPCE)]"" S DGTOT=DGTOT+$P(DGIN(I),"^",DGPCE) "RTN","DGMTSC4V",88,0) W " ",$J($$AMT^DGMTSCU1(DGTOT),12) "RTN","DGMTSC4V",89,0) S DGCNT=DGCNT+1 "RTN","DGMTSC4V",90,0) Q "RTN","DGMTSC4V",91,0) ; "RTN","DGMTSC4V",92,0) EDT ;Edit net worth fields "RTN","DGMTSC4V",93,0) N DA,DGERR,DGFIN,DGINI,DGIN2,DGIRI,DIE,DR,DGMTVR "RTN","DGMTSC4V",94,0) D GETIENS^DGMTU2(DFN,DGPRI,DGMTDT) G EDTQ:DGERR "RTN","DGMTSC4V",95,0) I $G(DGSEL)]"" W !!,"NAME: ",$$NAME^DGMTU1(DGPRI) "RTN","DGMTSC4V",96,0) S DGIN2=$G(^DGMT(408.21,DGINI,2)) "RTN","DGMTSC4V",97,0) S DGMTVR=$P($G(^DGMT(408.31,$G(DGMTI),2)),"^",11) "RTN","DGMTSC4V",98,0) S DR="[DGMT V1 ENTER/EDIT NET WORTH]" "RTN","DGMTSC4V",99,0) S DA=DGINI,DIE="^DGMT(408.21," D ^DIE S:'$D(DGFIN) DGMTOUT=1 "RTN","DGMTSC4V",100,0) I DGIN2'=$G(^DGMT(408.21,DGINI,2)) S DR="103////^S X=DUZ;104///^S X=""NOW""" D ^DIE "RTN","DGMTSC4V",101,0) EDTQ Q "RTN","DGMTSCC") 0^40^B38385133 "RTN","DGMTSCC",1,0) DGMTSCC ;ALB/RMO,CAW,LBD,EG,LMD,HM - Means Test Screen Completion ;03/24/2006 "RTN","DGMTSCC",2,0) ;;5.3;Registration;**33,45,130,438,332,433,462,456,610,624,611,890,1014**;Aug 13, 1993;Build 42 "RTN","DGMTSCC",3,0) ; "RTN","DGMTSCC",4,0) ; Input -- DFN Patient IEN "RTN","DGMTSCC",5,0) ; DGMTACT Means Test Action "RTN","DGMTSCC",6,0) ; DGMTDT Date of Test "RTN","DGMTSCC",7,0) ; DGMTYPT Type of Test 1=MT 2=COPAY "RTN","DGMTSCC",8,0) ; DGMTPAR Annual Means Test Parameters "RTN","DGMTSCC",9,0) ; DGVINI Veteran Individual Annual Income IEN "RTN","DGMTSCC",10,0) ; DGVIRI Veteran Income Relation IEN "RTN","DGMTSCC",11,0) ; DGVPRI Veteran Patient Relation IEN "RTN","DGMTSCC",12,0) ; DGMTNWC Net Worth Calculation flag "RTN","DGMTSCC",13,0) ; Output -- DGERR 1=INCOMPLETE and 0=COMPLETE "RTN","DGMTSCC",14,0) ; "RTN","DGMTSCC",15,0) EN N DGCAT,DGCOMF,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGREF1,DGSP,DGTYC,DGTHA,DGTHB,DGVIR0,DGCOPS,DGCOST,DGTHG "RTN","DGMTSCC",16,0) S DGERR=0 "RTN","DGMTSCC",17,0) I DGMTACT="ADD" D COM I 'Y!($D(DTOUT))!($D(DUOUT)) G Q "RTN","DGMTSCC",18,0) S DGCOMF=1 D DEP^DGMTSCU2,INC^DGMTSCU3 "RTN","DGMTSCC",19,0) ;if ANSPFIN="Y" user already answered to provide financial information (module DISC^DGMTSC) "RTN","DGMTSCC",20,0) I $G(ANSPFIN)="Y",$D(DGREF) D "RTN","DGMTSCC",21,0) . S (DGINTF,DGNWTF)="" "RTN","DGMTSCC",22,0) . W !,"DECLINES TO GIVE INCOME INFORMATION: YES" "RTN","DGMTSCC",23,0) . S DGREF1="" "RTN","DGMTSCC",24,0) . Q "RTN","DGMTSCC",25,0) I ($G(DGINTF)=0),($G(DGNWTF)=0) S DGREF1="" D REF G Q:$D(DTOUT)!($D(DUOUT)) "RTN","DGMTSCC",26,0) D CAT^DGMTSCU2,STA^DGMTSCU2 "RTN","DGMTSCC",27,0) ;don't try to run validation checks if declining to provide financial information "RTN","DGMTSCC",28,0) I '$D(DGREF) D CHK I DGERR W !?3,*7,$S(DGMTYPT=1:"Means",1:"Copay")_" test cannot be completed." G Q "RTN","DGMTSCC",29,0) I DGMTYPT=1,DGTYC="M",(DGNWT-DGDET)+$S(DGMTNWC:0,1:DGINT)'<$P(DGMTPAR,"^",8) D ADJ G Q:$D(DTOUT)!($D(DUOUT)) "RTN","DGMTSCC",30,0) I DGMTYPT=2,DGCAT="P" D ADJ G Q:$D(DTOUT)!($D(DUOUT)) "RTN","DGMTSCC",31,0) S DA=DGMTI,DIE="^DGMT(408.31,",DIE("NO^")="",DR="[DGMT ENTER/EDIT COMPLETION]" D ^DIE K DA,DIE,DR I '$D(DGFIN) S DGERR=1 G Q "RTN","DGMTSCC",32,0) I DGMTACT="EDT",DGMTDT>DT D "RTN","DGMTSCC",33,0) . N DATA S (DATA(.01),DATA(.07))=DT,DATA(2)=1 I $$UPD^DGENDBS(408.31,DGMTI,.DATA) "RTN","DGMTSCC",34,0) W:DGMTYPT=1 !?3,"...means test status is ",$P($$MTS^DGMTU(DFN,DGMTS),"^"),"..." "RTN","DGMTSCC",35,0) W:DGMTYPT=2 !?3,"...copay test status is ",$S(DGCAT="E":"EXEMPT",DGCAT="M":"NON-EXEMPT",DGCAT="P":"PENDING ADJUDICATION",1:"INCOMPLETE"),"..." "RTN","DGMTSCC",36,0) D PRT "RTN","DGMTSCC",37,0) ; "RTN","DGMTSCC",38,0) Q K DGFIN,DTOUT,DUOUT,Y "RTN","DGMTSCC",39,0) Q "RTN","DGMTSCC",40,0) ; "RTN","DGMTSCC",41,0) COM ;Check if user wants to complete the means test "RTN","DGMTSCC",42,0) N DIR "RTN","DGMTSCC",43,0) S DIR("A")="Do you wish to complete the "_$S(DGMTYPT=1:"means",1:"copay exemption")_" test" "RTN","DGMTSCC",44,0) S DIR("B")="YES",DIR(0)="Y" D ^DIR "RTN","DGMTSCC",45,0) ; The following was added for LTC Copay Phase II (DG*5.3*433) "RTN","DGMTSCC",46,0) I DGMTYPT=4,'Y D "RTN","DGMTSCC",47,0) . W !,"NOTE: If you do not complete the LTC copay exemption test, the incomplete test",!?6,"will be deleted." "RTN","DGMTSCC",48,0) . S DIR("A")="Do you wish to complete the copay exemption test" "RTN","DGMTSCC",49,0) . S DIR("B")="YES",DIR(0)="Y" D ^DIR "RTN","DGMTSCC",50,0) Q "RTN","DGMTSCC",51,0) ; "RTN","DGMTSCC",52,0) REF ;Check if patient declines to provide income information "RTN","DGMTSCC",53,0) ;ANSPFIN Y - user already answer this question (see program DGMTSC) "RTN","DGMTSCC",54,0) N DIR,Y,U "RTN","DGMTSCC",55,0) S U="^" "RTN","DGMTSCC",56,0) S DIR("A")="DECLINES TO GIVE INCOME INFORMATION" "RTN","DGMTSCC",57,0) I $P($G(^DGMT(408.31,DGMTI,0)),"^",14)]"" S DIR("B")=$$YN^DGMTSCU1($P(^(0),"^",14)) "RTN","DGMTSCC",58,0) I '$D(DIR("B")),$G(ANSPFIN)'="Y" S DIR("B")="NO" "RTN","DGMTSCC",59,0) ;user answered Y to provide income initially, but didn't provide income information "RTN","DGMTSCC",60,0) I $G(ANSPFIN)="Y" S DIR("B")="YES" "RTN","DGMTSCC",61,0) I $G(DGINTF)=0,$G(DGNWTF)=0 S DIR("B")="YES" "RTN","DGMTSCC",62,0) S DIR(0)="408.31,.14" D ^DIR K DIR G REFQ:$D(DTOUT)!($D(DUOUT)) "RTN","DGMTSCC",63,0) S:Y DGREF="" Q:'$D(DGREF)!($D(DGREF1))!(DGMTYPT'=1) S DGCAT="C" D STA^DGMTSCU2 "RTN","DGMTSCC",64,0) S ANSPFIN="Y" "RTN","DGMTSCC",65,0) REFQ Q "RTN","DGMTSCC",66,0) ; "RTN","DGMTSCC",67,0) CHK ;Check if means test can be completed "RTN","DGMTSCC",68,0) N DGA,DGD,DGDEP,DGREL,DGL,DGM,I "RTN","DGMTSCC",69,0) D GETREL^DGMTU11(DFN,"CS",$$LYR^DGMTSCU1(DGMTDT),$S($G(DGMTI):DGMTI,1:"")) "RTN","DGMTSCC",70,0) S DGM=$P(DGVIR0,"^",5),DGL=$P(DGVIR0,"^",6),DGA=$P(DGVIR0,"^",20),DGD=$P(DGVIR0,"^",8) ;DG*5.3*890 "RTN","DGMTSCC",71,0) I DGM']""!(DGM&(DGL']""))!(DGM&('DGL)&(DGA']"")) W !?3,"Marital section must be completed." S DGERR=1 "RTN","DGMTSCC",72,0) I DGM,'$D(DGREL("S")),'$D(DGREF) W !?3,"Married is 'YES'. An active spouse for this means test does not exist." S DGERR=1 "RTN","DGMTSCC",73,0) I 'DGM,$D(DGREL("S")) W !?3,"An active spouse exists for this means test. Married should be 'YES'." S DGERR=1 "RTN","DGMTSCC",74,0) I DGD']"" W !?3,"Dependent Children section must be completed." S DGERR=1 "RTN","DGMTSCC",75,0) I DGD,'$D(DGREL("C")) W !?3,"Dependent Children is 'YES'. No active children exist." S DGERR=1 "RTN","DGMTSCC",76,0) I 'DGD,$D(DGREL("C")) W !?3,"Active children exist. Dependent Children should be 'YES'." S DGERR=1 "RTN","DGMTSCC",77,0) I DGMTYPT=1,'$D(DGREF),DGTYC="M",'DGNWTF D "RTN","DGMTSCC",78,0) .;DG*5.3*1014 check if entry point in screen was from edit, add, or complete a means test "RTN","DGMTSCC",79,0) .I DGMTACT'="EDT"&(DGMTACT'="ADD")&(DGMTACT'="COM") W !?3,"A status of ",$$GETNAME^DGMTH(DGMTS)," requires property information." S DGERR=1 "RTN","DGMTSCC",80,0) I DGMTYPT=2,'DGNWTF,DGCAT="E",$$ASKNW^DGMTCOU W !?3,"Patient is in an 'EXEMPT' status and requires property information." S DGERR=1 "RTN","DGMTSCC",81,0) I DGDET>DGINT W !?3,"Patient's deductible expenses cannot exceed income." S DGERR=1 "RTN","DGMTSCC",82,0) Q:$G(DGERR) "RTN","DGMTSCC",83,0) N CNT,ACT,DGDEP,FLAG,DGINCP "RTN","DGMTSCC",84,0) D INIT^DGDEP S CNT=0 D "RTN","DGMTSCC",85,0) . F S CNT=$O(DGDEP(CNT)) Q:'CNT I $P(DGDEP(CNT),U,2)="SPOUSE" D Q:$G(DGERR) "RTN","DGMTSCC",86,0) . . D GETIENS^DGMTU2(DFN,$P(DGDEP(CNT),U,20),DGMTDT) "RTN","DGMTSCC",87,0) . . S DGINCP=$G(^DGMT(408.22,+DGIRI,"MT")) S:DGINCP FLAG=$G(FLAG)+1 "RTN","DGMTSCC",88,0) . . I $G(FLAG)>1 W !?3,"Patient has more than one spouse for this means test." S DGERR=1 "RTN","DGMTSCC",89,0) Q "RTN","DGMTSCC",90,0) ; "RTN","DGMTSCC",91,0) ADJ ;Adjudicate the means test "RTN","DGMTSCC",92,0) I DGMTACT="EDT"!(DGMTACT="ADD")!(DGMTACT="COM") Q ;DG*5.3*1014 "RTN","DGMTSCC",93,0) N DIR,Y "RTN","DGMTSCC",94,0) S DIR("?",1)="Since assets exceed the threshold, the "_$S(DGMTYPT=1:"means",1:"copay")_" test can" "RTN","DGMTSCC",95,0) S DIR("?",2)="be sent to adjudication. If the "_$S(DGMTYPT=1:"means",1:"copay")_" test is not" "RTN","DGMTSCC",96,0) S DIR("?")="adjudicated, the patient will be placed in "_$S(DGMTYPT=1&(DGTHG>DGTHA):"GMT Copay Required",DGMTYPT=1:"MT Copay Required",1:"Non-exempt")_" status." "RTN","DGMTSCC",97,0) S DIR("A")="Do you wish to send this case to adjudication" "RTN","DGMTSCC",98,0) S DIR("B")="YES",DIR(0)="Y" D ^DIR G ADJQ:$D(DTOUT)!($D(DUOUT)) "RTN","DGMTSCC",99,0) S DGCAT=$S(Y:"P",DGMTYPT=1&(DGTHG>DGTHA):"G",DGMTYPT=1:"C",1:"N") D STA^DGMTSCU2 "RTN","DGMTSCC",100,0) ADJQ Q "RTN","DGMTSCC",101,0) ; "RTN","DGMTSCC",102,0) ;DG*5.3*624 - REMOVE 10-10F AND REPLACE WITH 10-10EZ/EZR "RTN","DGMTSCC",103,0) PRT ;Print the 10-10EZR or 10-10EZ "RTN","DGMTSCC",104,0) N EZFLAG "RTN","DGMTSCC",105,0) I $D(DGFINOP) DO "RTN","DGMTSCC",106,0) .W !!,"Options for printing financial assessment information will follow." "RTN","DGMTSCC",107,0) .W !,"Generally, you should answer 'YES' to 'PRINT 10-10EZR?' after updating" "RTN","DGMTSCC",108,0) .W !,"patient demographic or financial information. Answer 'YES' to 'PRINT" "RTN","DGMTSCC",109,0) .W !,"10-10EZ?' after entering new patient demographic and financial information." "RTN","DGMTSCC",110,0) S EZFLAG=$$SEL1010^DG1010P("EZR/EZ") "RTN","DGMTSCC",111,0) Q:(EZFLAG=-1) "RTN","DGMTSCC",112,0) D QUE "RTN","DGMTSCC",113,0) ; "RTN","DGMTSCC",114,0) PRTQ Q "RTN","DGMTSCC",115,0) ; "RTN","DGMTSCC",116,0) ;DG*5.3*624 - REMOVE 10-10F AND REPLACE WITH 10-10EZ/EZR "RTN","DGMTSCC",117,0) QUE ; "RTN","DGMTSCC",118,0) N X "RTN","DGMTSCC",119,0) I $G(EZFLAG)="EZ" S X=$$ENEZ^EASEZPDG(DFN,DGMTI) "RTN","DGMTSCC",120,0) I $G(EZFLAG)="EZR" S X=$$ENEZR^EASEZPDG(DFN,DGMTI) "RTN","DGMTSCC",121,0) Q "RTN","DGMTSCR") 0^42^B14897236 "RTN","DGMTSCR",1,0) DGMTSCR ;ALB/RMO/CAW,HM - Means Test Screen Read Processor ; 8/1/08 1:21pm "RTN","DGMTSCR",2,0) ;;5.3;Registration;**45,688,1014**;Aug 13, 1993;Build 42 "RTN","DGMTSCR",3,0) ; "RTN","DGMTSCR",4,0) ; Input -- DGRNG Range of selectable items "RTN","DGMTSCR",5,0) ; DGMTACT Means Test Action "RTN","DGMTSCR",6,0) ; DGMTSC Screen Driver Array "RTN","DGMTSCR",7,0) ; DGMTSCI Screen number "RTN","DGMTSCR",8,0) ; DGVINI Veteran Individual Annual Income IEN "RTN","DGMTSCR",9,0) ; DGVPRI Veteran Income Relation IEN "RTN","DGMTSCR",10,0) ; Output -- DGDR Template tags (ie, 101,102,103,104) "RTN","DGMTSCR",11,0) ; DGX User input - maybe modified (ie, 1-4) "RTN","DGMTSCR",12,0) ; DGY Items selected in expanded form (ie, 1,2,3,4) "RTN","DGMTSCR",13,0) ; Returned for screen 2 and 4: "RTN","DGMTSCR",14,0) ; DGSEL Column selections available (ie, V, S, C) "RTN","DGMTSCR",15,0) ; DGSELTY User input - column selected (ie, V or S or C) "RTN","DGMTSCR",16,0) ; "RTN","DGMTSCR",17,0) EN K DGDR,DGSEL,DGSELTY,DGX,DGY,I D FEED "RTN","DGMTSCR",18,0) I $G(DGSCR1) S X="" G EN1 "RTN","DGMTSCR",19,0) W !,DGVI,"",DGVO," to CONTINUE," W:DGMTACT'="VEW" " ",DGVI,DGRNG,DGVO," or ",DGVI,"'ALL' ",DGVO,"to EDIT," W DGVI," ^N",DGVO," for screen N, or ",DGVI,"'^'",DGVO," to EXIT: " R X:DTIME S:'$T X="^" "RTN","DGMTSCR",20,0) EN1 K DGSCR1 S DGX=$$UPPER^DGUTL(X) "RTN","DGMTSCR",21,0) I DGX="^" G Q^DGMTSC "RTN","DGMTSCR",22,0) I DGX?1"^".N,$D(DGMTSC(+$P(DGX,"^",2))) G @($$ROU^DGMTSCU(+$P(DGX,"^",2))) "RTN","DGMTSCR",23,0) I DGMTACT'="VEW","^2^4^"[("^"_DGMTSCI_"^") D SEL I DGSEL[$E(DGX),$E(DGX,2)?1N S DGSELTY=$E(DGX),DGX=$P(DGX,DGSELTY,2) "RTN","DGMTSCR",24,0) I DGMTACT'="VEW",$E(DGX)="A" S X=DGX,Z="^ALL" D IN^DGHELP S:%'=-1 DGX=DGRNG "RTN","DGMTSCR",25,0) I DGX["?" D HLP G Q^DGMTSC:$D(DTOUT)!($D(DUOUT)),@($$ROU^DGMTSCU(DGMTSCI)) "RTN","DGMTSCR",26,0) I DGX="",$O(DGMTSC(DGMTSCI)) G @($$ROU^DGMTSCU($O(DGMTSC(DGMTSCI)))) "RTN","DGMTSCR",27,0) I DGX="" G Q^DGMTSC "RTN","DGMTSCR",28,0) I DGMTACT'="VEW" D PRO I $D(DGSELTY) S DGX=DGSELTY_DGX "RTN","DGMTSCR",29,0) S:DGMTACT="VEW" DGERR=1 I DGERR D HLP G @($$ROU^DGMTSCU(DGMTSCI)) "RTN","DGMTSCR",30,0) Q G @($$ROURET^DGMTSCU(DGMTSCI)) "RTN","DGMTSCR",31,0) ; "RTN","DGMTSCR",32,0) FEED ;Line feed to the bottom of the screen "RTN","DGMTSCR",33,0) N DGB,I "RTN","DGMTSCR",34,0) S DGB=$S('IOSL:24,1:IOSL)-5 F I=$Y:1:DGB W ! "RTN","DGMTSCR",35,0) Q "RTN","DGMTSCR",36,0) ; "RTN","DGMTSCR",37,0) SEL ;Check available column selections for Veteran, Spouse or Children "RTN","DGMTSCR",38,0) N DGDC,DGNC,DGND,DGSP,DGVIR0,DGX "RTN","DGMTSCR",39,0) D DEP^DGMTSCU2 "RTN","DGMTSCR",40,0) S DGSEL="V"_$S(DGSP:"S",1:"")_$S(DGDC:"C",1:"") "RTN","DGMTSCR",41,0) SELQ Q "RTN","DGMTSCR",42,0) ; "RTN","DGMTSCR",43,0) HLP ;Help display "RTN","DGMTSCR",44,0) N DGIOM,DGLNE,DGMTSCR,DIR,I,X "RTN","DGMTSCR",45,0) S DGHLPF=1 D HD^DGMTSCU "RTN","DGMTSCR",46,0) W !!,"Enter to continue to the next available screen." "RTN","DGMTSCR",47,0) I DGMTACT'="VEW" W !,"Enter an available item number from ",DGRNG," to edit.",!,"The items should be separated by commas or a range of numbers",!,"separated by a dash, or a combination of commas and dashes." "RTN","DGMTSCR",48,0) I DGMTACT'="VEW"&(DGMTSCI=2!(DGMTSCI=4))&($D(DGSEL)) W !,"To edit a specific column, enter 'V'",$S(DGSEL["S":", 'S'",1:""),$S(DGSEL["C":", 'C'",1:"")," in front of the selected items." "RTN","DGMTSCR",49,0) I DGMTACT'="VEW" W !,"Enter 'ALL' to edit all available items on the screen." "RTN","DGMTSCR",50,0) W !,"Enter '^N' to jump to a select screen. Enter '^' to exit." "RTN","DGMTSCR",51,0) W !!,"AVAILABLE SCREENS" "RTN","DGMTSCR",52,0) S I=0 F S I=$O(DGMTSC(I)) Q:'I D "RTN","DGMTSCR",53,0) .I I=4,DGMTACT'="VEW" Q ;DG*5.3*1014 do not display screen 4 for help "RTN","DGMTSCR",54,0) .W !,"[",+$$SCR^DGMTSCU(I),"] ",$P($$SCR^DGMTSCU(I),";",2) "RTN","DGMTSCR",55,0) S DGLNE="",DGIOM=$S('IOM:80,1:IOM),$P(DGLNE,"=",(DGIOM-1))="" "RTN","DGMTSCR",56,0) W !,DGLNE S DIR(0)="E" D ^DIR "RTN","DGMTSCR",57,0) Q "RTN","DGMTSCR",58,0) ; "RTN","DGMTSCR",59,0) PRO ;Process user selection; cnt - dash - parse - selection "RTN","DGMTSCR",60,0) N DGC,DGD,DGP,DGS "RTN","DGMTSCR",61,0) S DGC=0,DGERR=0,DGY="",DGDR="" "RTN","DGMTSCR",62,0) PARSE S DGC=DGC+1,DGP=$P(DGX,",",DGC) G PROQ:DGP="" "RTN","DGMTSCR",63,0) I DGP?.N1"-".N S DGD="" F DGS=$P(DGP,"-"):1:$P(DGP,"-",2) D CHK Q:DGERR "RTN","DGMTSCR",64,0) I '$D(DGD) S DGS=DGP D CHK "RTN","DGMTSCR",65,0) K DGD G PROQ:DGERR,PARSE "RTN","DGMTSCR",66,0) PROQ Q "RTN","DGMTSCR",67,0) ; "RTN","DGMTSCR",68,0) CHK I $D(DGD),+$P(DGP,"-",2)<+$P(DGP,"-",1) S DGERR=1 "RTN","DGMTSCR",69,0) I 'DGERR,DGS'?.N S DGERR=1 "RTN","DGMTSCR",70,0) I 'DGERR&(DGS>$P(DGRNG,"-",2)!(DGS<$P(DGRNG,"-"))) S DGERR=1 "RTN","DGMTSCR",71,0) I 'DGERR S DGY=DGY_$S($L(DGY):",",1:"")_DGS,DGDR=DGDR_$S($L(DGDR):",",1:"")_(DGS+100) "RTN","DGMTSCR",72,0) Q "RTN","DGR111") 0^2^B9351276 "RTN","DGR111",1,0) DGR111 ;ALB/TGH,LMD,JAM,BDB,ARF - Health Benefit Plan Main Menu - List Manager Screen ;4/11/13 10:56am "RTN","DGR111",2,0) ;;5.3;Registration;**871,987,985,1006,1014**;Aug 13, 1993;Build 42 "RTN","DGR111",3,0) ; "RTN","DGR111",4,0) EN(DFN) ;Main entry point to invoke the DGEN HBP PATIENT list "RTN","DGR111",5,0) ; Input -- DFN Patient IEN "RTN","DGR111",6,0) ; "RTN","DGR111",7,0) ; Set up to use two ListMan Menus dependent upon HBP source "RTN","DGR111",8,0) N HBP,DGHBP,HBPSRC,MENU "RTN","DGR111",9,0) D GETHBP^DGHBPUTL(DFN) "RTN","DGR111",10,0) S MENU="DGEN HBP PATIENT" "RTN","DGR111",11,0) D WAIT^DICD "RTN","DGR111",12,0) D EN^VALM(MENU) "RTN","DGR111",13,0) Q "RTN","DGR111",14,0) ; "RTN","DGR111",15,0) HDR ;Header code "RTN","DGR111",16,0) D LISTHDR^DGRPU(1) ;DG*5.3*1014 - ARF - sets patient data in the 1st and 2nd entries in VALMHDR array "RTN","DGR111",17,0) I $O(^DPT(DFN,"HBP",0))<1 S VALMHDR(3)="No Currently Stored VHAP Data" ;ARF/DG*5.3*1014 "RTN","DGR111",18,0) ;D PID^VADPT ;DG*5.3*1014 begin comment previous code "RTN","DGR111",19,0) ;S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGR111",20,0) ;S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")" "RTN","DGR111",21,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGR111",22,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGR111",23,0) ;S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80) "RTN","DGR111",24,0) ; DG*5.3*987; JAM; check for at least 1 plan and modify the message text "RTN","DGR111",25,0) ;I '$D(^DPT(DFN,"HBP",1)) S VALMHDR(2)="No Currently Stored VMBP Data" "RTN","DGR111",26,0) ; DG*5.3*985; JAM; correct check for at least 1 plan "RTN","DGR111",27,0) ;I $O(^DPT(DFN,"HBP",0))<1 S VALMHDR(2)="No Currently Stored VHAP Data" ;DG*5.3*1006 BDB ;DG*5.3*1014 end comment previous code "RTN","DGR111",28,0) Q "RTN","DGR111",29,0) ; "RTN","DGR111",30,0) INIT ;Build patient HBP current screen "RTN","DGR111",31,0) D CLEAN^VALM10 "RTN","DGR111",32,0) D CLEAR^VALM1 "RTN","DGR111",33,0) D GETHBP(DFN) "RTN","DGR111",34,0) Q "RTN","DGR111",35,0) ; "RTN","DGR111",36,0) GETHBP(DFN) ;Load HBPs from HBP array into TMP(VALMAR global for display "RTN","DGR111",37,0) ; INPUT: DFN = Patient IEN "RTN","DGR111",38,0) N DGHBP,DGSEL,DGDATA,Z,HBPSRC,BRACKET,DGHBIEN,DGPNAME "RTN","DGR111",39,0) S VALMCNT=0,(DGDATA,HBPSRC)="" "RTN","DGR111",40,0) D GETHBP^DGHBPUTL(DFN) "RTN","DGR111",41,0) S DGHBP="" "RTN","DGR111",42,0) F S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP="" D "RTN","DGR111",43,0) . S HBPSRC=$S(HBPSRC="E":"E",1:$P(HBP("CUR",DGHBP),"^",5)) "RTN","DGR111",44,0) S BRACKET=$S(HBPSRC="E":"<>",1:"[]") "RTN","DGR111",45,0) F S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP="" D "RTN","DGR111",46,0) . S DGDATA=HBP("CUR",DGHBP) "RTN","DGR111",47,0) . ; DG*5.3*987; jam; Place "zz" before the plan name for inactive plans "RTN","DGR111",48,0) . S DGHBIEN=+DGDATA "RTN","DGR111",49,0) . I $P($G(^DGHBP(25.11,DGHBIEN,0)),"^",4)="Y" S DGPNAME="zz "_DGHBP "RTN","DGR111",50,0) . E S DGPNAME=DGHBP "RTN","DGR111",51,0) . S VALMCNT=VALMCNT+1 "RTN","DGR111",52,0) . S Z=$E(BRACKET)_VALMCNT_$E(BRACKET,2)_" "_DGPNAME "RTN","DGR111",53,0) . S DGSEL(VALMCNT)=DGPNAME "RTN","DGR111",54,0) . D SET^VALM10(VALMCNT,Z,VALMCNT) "RTN","DGR111",55,0) Q "RTN","DGR111",56,0) ; "RTN","DGR111",57,0) HELP ;Help code "RTN","DGR111",58,0) S X="?" D DISP^XQORM1 W !! "RTN","DGR111",59,0) ; DG*53*987; jam; Add this to the help screen. "RTN","DGR111",60,0) W "Profile name preceded by 'zz' indicates the profile is inactive.",! "RTN","DGR111",61,0) Q "RTN","DGR111",62,0) ; "RTN","DGR111",63,0) EXIT ;Exit code "RTN","DGR111",64,0) D CLEAN^VALM10 "RTN","DGR111",65,0) D CLEAR^VALM1 "RTN","DGR111",66,0) ;K ^TMP("DGRP111",$J) "RTN","DGR111",67,0) Q "RTN","DGR111",68,0) ; "RTN","DGR111",69,0) PEXIT ;DGEN MSDS MENU protocol exit code "RTN","DGR111",70,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGR111",71,0) Q "RTN","DGR111",72,0) ; "RTN","DGR111",73,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGR111",74,0) ; = "VH" - View History - DGEN HBP View History protocol "RTN","DGR111",75,0) ; = "VD" - View Detail of HBP "RTN","DGR111",76,0) N DGACTU,DA,DIE,DIC,DIK,DIPA,DR,X,Y,DGHBP,HPSRC,HBP "RTN","DGR111",77,0) I $G(DGACT)="" G ACTQ "RTN","DGR111",78,0) I $G(DGACT)="Q" Q "RTN","DGR111",79,0) ; Determine if any HBPs were processed by ESR "RTN","DGR111",80,0) S (DGDATA,HBPSRC)="" "RTN","DGR111",81,0) D GETHBP^DGHBPUTL(DFN) "RTN","DGR111",82,0) S DGHBP="" "RTN","DGR111",83,0) F S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP="" D "RTN","DGR111",84,0) . S HBPSRC=$S(HBPSRC="E":"E",1:$P(HBP("CUR",DGHBP),"^",5)) "RTN","DGR111",85,0) ; "RTN","DGR111",86,0) D FULL^VALM1 "RTN","DGR111",87,0) ; If action is a VH then View History display screen (DGR113) then return to main screen "RTN","DGR111",88,0) I DGACT="VH" D EN^DGR113(DFN) G ACTQ "RTN","DGR111",89,0) ; If action is a VD then View Detail display screen (DGR114) then return to main screen "RTN","DGR111",90,0) I DGACT="VD" D EN^DGR114(DFN) G ACTQ "RTN","DGR111",91,0) ; If user does not choose VH or VD return to main screen "RTN","DGR111",92,0) W !,"Health Profiles can only be edited/modified by an ESC user," "RTN","DGR111",93,0) W !,"please contact HEC to request changes/edits." "RTN","DGR111",94,0) D PAUSE^VALM1 "RTN","DGR111",95,0) ; "RTN","DGR111",96,0) ACTQ D INIT S VALMBCK="R" Q "RTN","DGR111",97,0) ; "RTN","DGR111",98,0) EXPND ; -- expand code "RTN","DGR111",99,0) Q "RTN","DGR111",100,0) ; "RTN","DGR113") 0^3^B8401629 "RTN","DGR113",1,0) DGR113 ;ALB/TGH,HM,KUM,BDB,ARF - Health Benefit Plan View History - List Manager Screen ;5/21/19 10:56am "RTN","DGR113",2,0) ;;5.3;Registration;**871,987,1006,1014**;Aug 13, 1993;Build 42 "RTN","DGR113",3,0) ; "RTN","DGR113",4,0) EN(DFN) ;Main entry point to invoke the DGEN HBP VIEW list "RTN","DGR113",5,0) ; Input -- DFN Patient IEN "RTN","DGR113",6,0) ; "RTN","DGR113",7,0) D WAIT^DICD "RTN","DGR113",8,0) D EN^VALM("DGEN HBP VIEW") "RTN","DGR113",9,0) Q "RTN","DGR113",10,0) ; "RTN","DGR113",11,0) HDR ;Header code "RTN","DGR113",12,0) N X "RTN","DGR113",13,0) D LISTHDR^DGRPU(1) ;DG*5.3*1014 - ARF - sets patient data in the 1st and 2nd entries in VALMHDR array "RTN","DGR113",14,0) ;D PID^VADPT ;DG*5.3*1014 begin comment previous code "RTN","DGR113",15,0) ;S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGR113",16,0) ;S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")" "RTN","DGR113",17,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGR113",18,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGR113",19,0) ;S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80) ;DG*5.3*1014 end comment previous code "RTN","DGR113",20,0) Q "RTN","DGR113",21,0) ; "RTN","DGR113",22,0) INIT ;Build patient HBP View History screen "RTN","DGR113",23,0) N DGPLAN "RTN","DGR113",24,0) D CLEAN^VALM10 "RTN","DGR113",25,0) D CLEAR^VALM1 "RTN","DGR113",26,0) D GETPLAN "RTN","DGR113",27,0) Q "RTN","DGR113",28,0) ; "RTN","DGR113",29,0) GETPLAN ;Load History from HBP array into TMP(VALMAR global for display "RTN","DGR113",30,0) N DTTIME,CNT,LINEVAR "RTN","DGR113",31,0) S VALMCNT=0 "RTN","DGR113",32,0) S LINEVAR="HISTORY" "RTN","DGR113",33,0) D GETHBP^DGHBPUTL "RTN","DGR113",34,0) ; Go thru History and set individual values into Global for display "RTN","DGR113",35,0) S CNT=0 "RTN","DGR113",36,0) F S CNT=$O(HBP("HIS",CNT)) Q:CNT="" D "RTN","DGR113",37,0) . S DTTIME="" "RTN","DGR113",38,0) . F S DTTIME=$O(HBP("HIS",CNT,DTTIME)) Q:DTTIME="" D "RTN","DGR113",39,0) . . N DATA,Y "RTN","DGR113",40,0) . . S DATA=HBP("HIS",CNT,DTTIME) "RTN","DGR113",41,0) . . S Y=DTTIME X ^DD("DD") "RTN","DGR113",42,0) . . S VALMCNT=VALMCNT+1 "RTN","DGR113",43,0) . . S LINEVAR=$$SETFLD^VALM1("["_VALMCNT_"]",LINEVAR,"NO") ; DG*5.3*987 KUM "RTN","DGR113",44,0) . . S LINEVAR=$$SETFLD^VALM1($S($P(DATA,"^",5)="A":" ASSIGN",1:" UNASSIGN"),LINEVAR,"ACTION") ; DG*5.3*987 HM "RTN","DGR113",45,0) . . S LINEVAR=$$SETFLD^VALM1(Y,LINEVAR,"DATE/TIME") ; DG*5.3*1006 BDB - Time to be displayed along with the date "RTN","DGR113",46,0) . . ; DG*5.3*987 KUM "RTN","DGR113",47,0) . . S LINEVAR=$$SETSTR^VALM1($P(DATA,"^",1),LINEVAR,37,139) ;DG*5.3*1006 BDB - Plan name begins at location 37 "RTN","DGR113",48,0) . . D SET^VALM10(VALMCNT,LINEVAR,VALMCNT) "RTN","DGR113",49,0) Q "RTN","DGR113",50,0) ; "RTN","DGR113",51,0) HELP ;Help code "RTN","DGR113",52,0) S X="?" D DISP^XQORM1 W !! "RTN","DGR113",53,0) Q "RTN","DGR113",54,0) ; "RTN","DGR113",55,0) EXIT ;Exit code "RTN","DGR113",56,0) D CLEAN^VALM10 "RTN","DGR113",57,0) D CLEAR^VALM1 "RTN","DGR113",58,0) Q "RTN","DGR113",59,0) ; "RTN","DGR113",60,0) ACTION ; Get users entered data and process entry to add HBP "RTN","DGR113",61,0) ; DG*5.3*987 - KUM "RTN","DGR113",62,0) N I,VALMY,VALMNOD "RTN","DGR113",63,0) D FULL^VALM1 "RTN","DGR113",64,0) S VALMNOD="3^4450^Select HBP^1-36" "RTN","DGR113",65,0) D EN^VALM2(VALMNOD,"S") "RTN","DGR113",66,0) S I="" "RTN","DGR113",67,0) F S I=$O(VALMY(I)) Q:I="" D "RTN","DGR113",68,0) . S ACT=$O(@VALMAR@("IDX",I,"")) "RTN","DGR113",69,0) . S DGNAME=@VALMAR@(ACT,0) "RTN","DGR113",70,0) . ; DG*5.3*966 - Plan name is at position 37 "RTN","DGR113",71,0) . S DGACT=$$FIND1^DIC(25.11,,"XQ",$$TRIM^XLFSTR($E(DGNAME,37,999))) "RTN","DGR113",72,0) . D ACT(DGACT) "RTN","DGR113",73,0) Q "RTN","DGR113",74,0) ; "RTN","DGR113",75,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGR113",76,0) ; INPUT: DGACT = Plan number to be assigned "RTN","DGR113",77,0) I $G(DGACT)="" Q "RTN","DGR113",78,0) ; Gather data and send to print in EXPND "RTN","DGR113",79,0) D GETDETL^DGHBPUTL(DGACT) "RTN","DGR113",80,0) Q "RTN","DGR113",81,0) ; "RTN","DGR113",82,0) EXPND ; -- expand code "RTN","DGR113",83,0) ; DG*5.3*987 - KUM - For Expand Functionality "RTN","DGR113",84,0) N CNT,LST,ACT,DGNAME,DGACT "RTN","DGR113",85,0) D ACTION "RTN","DGR113",86,0) S VALMBCK="R" "RTN","DGR113",87,0) I $G(DGACT)="" Q "RTN","DGR113",88,0) D FULL^VALM1 "RTN","DGR113",89,0) D EN^DGR1131(DFN,DGNAME,.HBP) "RTN","DGR113",90,0) S VALMBCK="R" "RTN","DGR113",91,0) Q "RTN","DGR113",92,0) ; "RTN","DGR113",93,0) PEXIT ; MENU protocol exit code "RTN","DGR113",94,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGR113",95,0) Q "RTN","DGR113",96,0) ; "RTN","DGR1131") 0^4^B6876398 "RTN","DGR1131",1,0) DGR1131 ;ALB/KUM,BDB,ARF - Health Benefit Plan View History Expanded - List Manager Screen for screen 11.3.1 ;5/30/19 10:56am "RTN","DGR1131",2,0) ;;5.3;Registration;**987,1006,1014**;Aug 13, 1993;Build 42 "RTN","DGR1131",3,0) ; "RTN","DGR1131",4,0) EN(DFN,DGNAME,HBP) ;Main entry point to invoke the DGEN HBP VIEWEXP list "RTN","DGR1131",5,0) ; Input -- DFN Patient ID "RTN","DGR1131",6,0) ; DGNAME Text for plan selected from the list in screen 11.3 "RTN","DGR1131",7,0) ; HBP Patient Plan Details array "RTN","DGR1131",8,0) ; "RTN","DGR1131",9,0) D WAIT^DICD "RTN","DGR1131",10,0) D EN^VALM("DGEN HBP VIEWEXP") "RTN","DGR1131",11,0) Q "RTN","DGR1131",12,0) ; "RTN","DGR1131",13,0) HDR ;Header code "RTN","DGR1131",14,0) N X,DGSTR,DGWD,DGSPC,DGPLAN "RTN","DGR1131",15,0) D LISTHDR^DGRPU(1) ;DG*5.3*1014 - ARF - sets patient data in the 1st and 2nd entries in VALMHDR array "RTN","DGR1131",16,0) ;S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) ;DG*5.3*1014 begin comment previous code "RTN","DGR1131",17,0) ;S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")" "RTN","DGR1131",18,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGR1131",19,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^DG(391,+^DPT(DFN,"TYPE"),0),U,1) "RTN","DGR1131",20,0) ;S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80) "RTN","DGR1131",21,0) ;S VALMHDR(2)=" " "RTN","DGR1131",22,0) ;S VALMHDR(3)="Action Date/Time Profile" ;DG*5.3*1006 BDB ; Time is now displayed with the date "RTN","DGR1131",23,0) ;S VALMHDR(4)="------ --------- -------" ;DG*5.3*1006 BDB "RTN","DGR1131",24,0) ;S DGSTR=$$TRIM^XLFSTR($E(DGNAME,6,999)),DGWD=80,DGSPC=" " "RTN","DGR1131",25,0) ;D FSTRING(DGSTR,DGWD,.DGPLAN) "RTN","DGR1131",26,0) ;S VALMHDR(5)=DGPLAN(1,0) "RTN","DGR1131",27,0) ;I DGPLAN=2 D "RTN","DGR1131",28,0) ;.S VALMHDR(6)=DGSPC_DGPLAN(2,0) "RTN","DGR1131",29,0) ;S VALMHDR(7)=" " "RTN","DGR1131",30,0) ;S VALMSG="+ Next Screen - Prev Screen ?? More Actions" ;DG*5.3*1014 end -increased following VALAMHDR subscripts ;DG*5.3*1014 end comment previous code "RTN","DGR1131",31,0) S VALMHDR(3)=" " "RTN","DGR1131",32,0) S VALMHDR(4)="Action Date/Time Profile" ;DG*5.3*1006 BDB ; Time is now displayed with the date "RTN","DGR1131",33,0) S VALMHDR(5)="------ --------- -------" ;DG*5.3*1006 BDB "RTN","DGR1131",34,0) S DGSTR=$$TRIM^XLFSTR($E(DGNAME,6,999)),DGWD=80,DGSPC=" " "RTN","DGR1131",35,0) D FSTRING(DGSTR,DGWD,.DGPLAN) "RTN","DGR1131",36,0) S VALMHDR(6)=DGPLAN(1,0) "RTN","DGR1131",37,0) I DGPLAN=2 D "RTN","DGR1131",38,0) .S VALMHDR(7)=DGSPC_DGPLAN(2,0) "RTN","DGR1131",39,0) S VALMHDR(8)=" " "RTN","DGR1131",40,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGR1131",41,0) Q "RTN","DGR1131",42,0) ; "RTN","DGR1131",43,0) INIT ; -- init variables and list array "RTN","DGR1131",44,0) N DGACT,LST,CNT "RTN","DGR1131",45,0) D CLEAN^VALM10 "RTN","DGR1131",46,0) D CLEAR^VALM1 "RTN","DGR1131",47,0) S LST=$P(HBP("DETAIL",0),"^",4) "RTN","DGR1131",48,0) ;I LST="" W !,"No detail description is available for this Veteran Medical Benefit Plan" "RTN","DGR1131",49,0) I LST="" W !,"No detail description is available for this VHA Profile" ;DG*5.3*1006 BDB "RTN","DGR1131",50,0) S DGACT=$$FIND1^DIC(25.11,,"XQ",$$TRIM^XLFSTR($E(DGNAME,37,999))) ;DG*5.3*1006 ; BDB; Plan name is at location 37 "RTN","DGR1131",51,0) F CNT=1:1:LST D SET^VALM10(CNT," "_HBP("DETAIL",DGACT,CNT)) "RTN","DGR1131",52,0) S VALMCNT=CNT "RTN","DGR1131",53,0) S VALMBCK="R" "RTN","DGR1131",54,0) Q "RTN","DGR1131",55,0) ; "RTN","DGR1131",56,0) HELP ; -- help code "RTN","DGR1131",57,0) S X="?" D DISP^XQORM1 W !! "RTN","DGR1131",58,0) Q "RTN","DGR1131",59,0) ; "RTN","DGR1131",60,0) EXIT ; -- exit code "RTN","DGR1131",61,0) Q "RTN","DGR1131",62,0) ; "RTN","DGR1131",63,0) EXPND ; -- expand code "RTN","DGR1131",64,0) Q "RTN","DGR1131",65,0) ; "RTN","DGR1131",66,0) PEXIT ; MENU protocol exit code "RTN","DGR1131",67,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGR1131",68,0) Q "RTN","DGR1131",69,0) ; "RTN","DGR1131",70,0) FSTRING(DGSTR,DGWD,DGARRAY) ;Parse text string into lines of length DGWD "RTN","DGR1131",71,0) ; Input: "RTN","DGR1131",72,0) ; DGSTR - (required) Text string to be parsed "RTN","DGR1131",73,0) ; DGWD - Length of parsed lines (default =80) "RTN","DGR1131",74,0) ; "RTN","DGR1131",75,0) ; Output: "RTN","DGR1131",76,0) ; DGARRAY - (required) Result array of formatted output text, passed by reference "RTN","DGR1131",77,0) ; "RTN","DGR1131",78,0) N X,DGI,DIWL,DIWR,DIWF "RTN","DGR1131",79,0) K DGARRAY,^UTILITY($J,"W") "RTN","DGR1131",80,0) S X=$G(DGSTR) "RTN","DGR1131",81,0) I X'="" S DIWL=1,DIWR=$G(DGWD,80),DIWF="" D ^DIWP "RTN","DGR1131",82,0) I $D(^UTILITY($J,"W")) M DGARRAY=^UTILITY($J,"W",1) "RTN","DGR1131",83,0) K ^UTILITY($J,"W") "RTN","DGR1131",84,0) Q "RTN","DGR114") 0^5^B6043455 "RTN","DGR114",1,0) DGR114 ;ALB/TGH,JAM,BDB,ARF - Health Benefit Plan View Detail - List Manager Screen ;7/8/19 10:56am "RTN","DGR114",2,0) ;;5.3;Registration;**871,987,1006,1014**;Aug 13, 1993;Build 42 "RTN","DGR114",3,0) ; "RTN","DGR114",4,0) EN(DFN) ;Main entry point to invoke the DGEN HBP DETAIL list "RTN","DGR114",5,0) ; Input -- DFN Patient IEN "RTN","DGR114",6,0) ; "RTN","DGR114",7,0) D WAIT^DICD "RTN","DGR114",8,0) D EN^VALM("DGEN HBP DETAIL") "RTN","DGR114",9,0) Q "RTN","DGR114",10,0) ; "RTN","DGR114",11,0) HDR ;Header code "RTN","DGR114",12,0) N X "RTN","DGR114",13,0) D LISTHDR^DGRPU(1) ;DG*5.3*1014 - ARF - sets patient data in the 1st and 2nd entries in VALMHDR array "RTN","DGR114",14,0) ;D PID^VADPT ;DG*5.3*1014 begin comment previous code "RTN","DGR114",15,0) ;S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGR114",16,0) ;S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")" "RTN","DGR114",17,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGR114",18,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGR114",19,0) ;S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80) ;DG*5.3*1014 end comment previous code "RTN","DGR114",20,0) Q "RTN","DGR114",21,0) ; "RTN","DGR114",22,0) INIT ;Build patient HBP current screen "RTN","DGR114",23,0) D CLEAN^VALM10 "RTN","DGR114",24,0) D CLEAR^VALM1 "RTN","DGR114",25,0) D GETPLAN "RTN","DGR114",26,0) Q "RTN","DGR114",27,0) ; "RTN","DGR114",28,0) GETPLAN ;Load Plans from HBP array into TMP(VALMAR global for display "RTN","DGR114",29,0) N DGPLAN,Z,DGHBIEN "RTN","DGR114",30,0) D GETPLAN^DGHBPUTL "RTN","DGR114",31,0) S DGPLAN="",VALMCNT=0 "RTN","DGR114",32,0) F S DGPLAN=$O(HBP("PLAN",DGPLAN)) Q:DGPLAN="" D "RTN","DGR114",33,0) . ;DG*5.3*987 - JAM - Filter out Inactive Plans "RTN","DGR114",34,0) . S DGHBIEN=HBP("PLAN",DGPLAN) "RTN","DGR114",35,0) . I $P($G(^DGHBP(25.11,DGHBIEN,0)),"^",4)="Y" Q "RTN","DGR114",36,0) .; "RTN","DGR114",37,0) . S VALMCNT=VALMCNT+1 "RTN","DGR114",38,0) . S Z="["_VALMCNT_"]"_" "_DGPLAN "RTN","DGR114",39,0) . D SET^VALM10(VALMCNT,Z,VALMCNT) "RTN","DGR114",40,0) Q "RTN","DGR114",41,0) ; "RTN","DGR114",42,0) HELP ;Help code "RTN","DGR114",43,0) S X="?" D DISP^XQORM1 W !! "RTN","DGR114",44,0) Q "RTN","DGR114",45,0) ; "RTN","DGR114",46,0) ACTION ; Get users entered data and process entry to add HBP "RTN","DGR114",47,0) N I,VALMY,VALMNOD "RTN","DGR114",48,0) D FULL^VALM1 "RTN","DGR114",49,0) S VALMNOD="3^4450^Select HBP^1-36" "RTN","DGR114",50,0) D EN^VALM2(VALMNOD,"S") "RTN","DGR114",51,0) S I="" "RTN","DGR114",52,0) F S I=$O(VALMY(I)) Q:I="" D "RTN","DGR114",53,0) . S ACT=$O(@VALMAR@("IDX",I,"")) "RTN","DGR114",54,0) . S DGNAME=$P(@VALMAR@(ACT,0)," ",3,99) "RTN","DGR114",55,0) . S DGACT=HBP("PLAN",DGNAME) "RTN","DGR114",56,0) . D ACT(DGACT) "RTN","DGR114",57,0) Q "RTN","DGR114",58,0) ; "RTN","DGR114",59,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGR114",60,0) ; INPUT: DGACT = Plan number to be assigned "RTN","DGR114",61,0) I $G(DGACT)="" Q "RTN","DGR114",62,0) ; Gather data and send to print in EXPND "RTN","DGR114",63,0) D GETDETL^DGHBPUTL(DGACT) "RTN","DGR114",64,0) Q "RTN","DGR114",65,0) ; "RTN","DGR114",66,0) EXIT ;Exit code "RTN","DGR114",67,0) D CLEAN^VALM10 "RTN","DGR114",68,0) D CLEAR^VALM1 "RTN","DGR114",69,0) Q "RTN","DGR114",70,0) ; "RTN","DGR114",71,0) PEXIT ; MENU protocol exit code "RTN","DGR114",72,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGR114",73,0) Q "RTN","DGR114",74,0) ; "RTN","DGR114",75,0) EXPND ; -- expand code "RTN","DGR114",76,0) N CNT,LST,ACT,DGNAME,DGACT "RTN","DGR114",77,0) D ACTION "RTN","DGR114",78,0) S VALMBCK="R" ; CCR 13613 - fix "RTN","DGR114",79,0) I $G(DGACT)="" Q "RTN","DGR114",80,0) S LST=$P(HBP("DETAIL",0),"^",4) "RTN","DGR114",81,0) ;I LST="" W !,"No detail description is available for this Veteran Medical Benefit Plan" ;DG*5.3*987 HM "RTN","DGR114",82,0) I LST="" W !,"No detail description is available for this VHA Profile" ;DG*5.3*1006 BDB;DG*5.3*987 HM "RTN","DGR114",83,0) F CNT=1:1:LST W !,HBP("DETAIL",DGACT,CNT) "RTN","DGR114",84,0) S VALMBCK="R" "RTN","DGR114",85,0) D PAUSE^VALM1 "RTN","DGR114",86,0) Q "RTN","DGR114",87,0) ; "RTN","DGREGAED") 0^20^B62965158 "RTN","DGREGAED",1,0) DGREGAED ;ALB/DW/PHH,BAJ,TDM,JAM - Address Edit API ;02 May 2017 8:33 AM "RTN","DGREGAED",2,0) ;;5.3;Registration;**522,560,658,730,688,808,915,941,1010,1014**;Aug 13, 1993;Build 42 "RTN","DGREGAED",3,0) ;; "RTN","DGREGAED",4,0) ;; **688** Modifications for Country and Foreign address "RTN","DGREGAED",5,0) ;; **915** Make DFN optional in case one is not established yet "RTN","DGREGAED",6,0) ; "RTN","DGREGAED",7,0) EN(DFN,FLG,SRC,DGRET) ;Entry point "RTN","DGREGAED",8,0) ;Input: "RTN","DGREGAED",9,0) ; DFN (optional) - Internal Entry # of Patient File (#2) "RTN","DGREGAED",10,0) ; If not supplied then nothing filed or defaulted "RTN","DGREGAED",11,0) ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details: "RTN","DGREGAED",12,0) ; FLG(1) - if 1 let user edit phone numbers (field #.131 and #.132) "RTN","DGREGAED",13,0) ; FLG(2) - if 1 display before & after address for user confirmation "RTN","DGREGAED",14,0) ; DGRET - if passed by reference will contain address info array "RTN","DGREGAED",15,0) K EASZIPLK,DGRET "RTN","DGREGAED",16,0) N DGINPUT,DGCMP,ICNTRY,CNTRY,FORGN,PSTR,OLDC "RTN","DGREGAED",17,0) N I,X,Y "RTN","DGREGAED",18,0) S DFN=+$G(DFN) "RTN","DGREGAED",19,0) ;I ($G(DFN)'?.N) Q "RTN","DGREGAED",20,0) S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2)) "RTN","DGREGAED",21,0) D GETOLD(.DGCMP,DFN) "RTN","DGREGAED",22,0) S CNTRY="",ICNTRY=$S(DFN:$P($G(^DPT(DFN,.11)),"^",10),1:"") "RTN","DGREGAED",23,0) I ICNTRY="" S ICNTRY=1 ;default country is USA if NULL "RTN","DGREGAED",24,0) ; "RTN","DGREGAED",25,0) ; DG*5.3*1014; jam; ** Start changes ** "RTN","DGREGAED",26,0) RETRY ; DG*5.3*1014;jam ; Tag added for entry point to re-enter the address "RTN","DGREGAED",27,0) S OLDC=DGCMP("OLD",.1173),FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,.1173,.CNTRY) I FORGN=-1 Q "RTN","DGREGAED",28,0) S FSTR=$$INPT1(FORGN,.PSTR) ;set up field string of address prompts "RTN","DGREGAED",29,0) S DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR,CNTRY) I $G(DGINPUT)=-1 Q "RTN","DGREGAED",30,0) I 'DFN M DGRET=DGINPUT Q "RTN","DGREGAED",31,0) ; DG*5.3*1014; jam; If required fields are missing, we can't call the validation service "RTN","DGREGAED",32,0) I DGINPUT(.111)=""!(DGINPUT(.114)="")!(($G(DGINPUT(.1112))="")&('FORGN)) D G RETRY "RTN","DGREGAED",33,0) . I 'FORGN W !!?3,*7,"ADDRESS [LINE 1], CITY, and ZIP CODE fields are required." "RTN","DGREGAED",34,0) . I FORGN W !!?3,*7,"ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGAED",35,0) ; DG*5.3*1014; Display address entered - user may reenter the address or continue to Validation service. "RTN","DGREGAED",36,0) N DGNEWADD "RTN","DGREGAED",37,0) M DGNEWADD("NEW")=DGINPUT "RTN","DGREGAED",38,0) W ! "RTN","DGREGAED",39,0) I FORGN D DISPFGN(.DGNEWADD,"NEW") "RTN","DGREGAED",40,0) I 'FORGN D DISPUS(.DGNEWADD,"NEW") "RTN","DGREGAED",41,0) K DGNEWADD "RTN","DGREGAED",42,0) CHK ; DG*5.3*1014; Prompt user and allow them to correct the address or continue to Validation service "RTN","DGREGAED",43,0) N DIR "RTN","DGREGAED",44,0) S DIR("A",1)="If address is ready for validation enter to continue, 'E' to Edit" "RTN","DGREGAED",45,0) S DIR("A")=" or '^' to quit" "RTN","DGREGAED",46,0) S DIR(0)="FO" "RTN","DGREGAED",47,0) S DIR("?")="Enter 'E' to edit the address, to continue to address validation or '^' to exit and cancel the address entry/edit." "RTN","DGREGAED",48,0) D ^DIR K DIR "RTN","DGREGAED",49,0) I $D(DUOUT)!($D(DTOUT)) W !,"Address changes not saved." D EOP Q ;Exiting - Not saving address "RTN","DGREGAED",50,0) I X="E"!(X="e") G RETRY ; re-enter address "RTN","DGREGAED",51,0) I X'="" G CHK ; at this point, any response but will not be accepted "RTN","DGREGAED",52,0) ; DG*5.3*1014; jam; Add call to Address Validation service "RTN","DGREGAED",53,0) N DGADVRET "RTN","DGREGAED",54,0) S DGADVRET=$$EN^DGADDVAL(.DGINPUT,"P") "RTN","DGREGAED",55,0) ; if return is 0 - address was not validated "RTN","DGREGAED",56,0) I 'DGADVRET W !!,"No Results - UAM Address Validation Service is unable to validate the address.",!,"Please verify the address entered. " D EOP "RTN","DGREGAED",57,0) ; DGINPUT array contains the address that is validated/accepted or what the user entered if the validation service failed "RTN","DGREGAED",58,0) ; "RTN","DGREGAED",59,0) ; DG*5.3*1014; jam; ** End changes ** "RTN","DGREGAED",60,0) ; "RTN","DGREGAED",61,0) CONF I $G(FLG(2))=1 D COMPARE(.DGINPUT,.DGCMP,.FLG) "RTN","DGREGAED",62,0) I '$$CONFIRM() W !,"Address changes not saved." D EOP Q "RTN","DGREGAED",63,0) N DGPRIOR "RTN","DGREGAED",64,0) D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) "RTN","DGREGAED",65,0) D SAVE(.DGINPUT,DFN,FSTR,FORGN) I $G(SRC)="",+$G(DGNEW) Q "RTN","DGREGAED",66,0) Q:'$$FILEYN^DGADDUTL(.DGPRIOR,.DGINPUT) "RTN","DGREGAED",67,0) D GETUPDTS^DGADDUTL(DFN,.DGINPUT) "RTN","DGREGAED",68,0) D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGINPUT) "RTN","DGREGAED",69,0) Q "RTN","DGREGAED",70,0) INPUT(DGINPUT,DFN,FSTR,CNTRY) ;Let user input address changes "RTN","DGREGAED",71,0) ;Output: DGINPUT(field#)=external^internal(if any) "RTN","DGREGAED",72,0) N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L "RTN","DGREGAED",73,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L),DGINPUT(DGN)="" Q:DGINPUT=-1 D "RTN","DGREGAED",74,0) . I $$SKIP(DGN,.DGINPUT,.FLG) Q "RTN","DGREGAED",75,0) . I DGN=.1112 D ZIPINP(.DGINPUT,DFN) Q "RTN","DGREGAED",76,0) . I '$$READ(DFN,DGN,.Y) S DGINPUT=-1 Q "RTN","DGREGAED",77,0) . I DGN=.121 S Y=$G(Y) D Q "RTN","DGREGAED",78,0) .. I Y="",DGINPUT(DGN)="" Q "RTN","DGREGAED",79,0) .. I DFN,$P(Y,U)=$$GET1^DIQ(2,DFN_",",DGN,"I") S DGINPUT(DGN)=$$GET1^DIQ(2,DFN_",",DGN)_U_$P(Y,U) Q "RTN","DGREGAED",80,0) .. S DGINPUT(DGN)=$P(Y(0),U)_U_Y "RTN","DGREGAED",81,0) . S DGINPUT(DGN)=$G(Y) "RTN","DGREGAED",82,0) I DGINPUT'=-1 S DGINPUT(.1173)=CNTRY_"^"_$O(^HL(779.004,"B",CNTRY,"")) "RTN","DGREGAED",83,0) Q "RTN","DGREGAED",84,0) GETOLD(DGCMP,DFN) ;populate array with existing address info "RTN","DGREGAED",85,0) N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,COUNTRY "RTN","DGREGAED",86,0) S CFORGN=0 "RTN","DGREGAED",87,0) ; get current country "RTN","DGREGAED",88,0) ; If current country is NULL it is old data "RTN","DGREGAED",89,0) ; Leave it NULL here because this is not an edit funtion "RTN","DGREGAED",90,0) S CCIEN=$S(DFN:$$GET1^DIQ(2,DFN_",","COUNTRY","I"),1:"") "RTN","DGREGAED",91,0) ;I CCIEN="" S CCIEN=$O(^HL(779.004,"D","UNITED STATES","")) "RTN","DGREGAED",92,0) S CFORGN=$$FORIEN^DGADDUTL(CCIEN) "RTN","DGREGAED",93,0) ;get current address fields and xlate to ^DIQ format "RTN","DGREGAED",94,0) S CFSTR=$$INPT1(CFORGN),CFSTR=$TR(CFSTR,",",";") "RTN","DGREGAED",95,0) ; Domestic data needs some extra fields "RTN","DGREGAED",96,0) I 'CFORGN S CFSTR=CFSTR_";.114;.115;.117" "RTN","DGREGAED",97,0) I DFN D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR") "RTN","DGREGAED",98,0) F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E")) "RTN","DGREGAED",99,0) S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY" "RTN","DGREGAED",100,0) S DGCMP("OLD",.1173)=COUNTRY_"^"_CCIEN "RTN","DGREGAED",101,0) I 'CFORGN D "RTN","DGREGAED",102,0) . S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I")) "RTN","DGREGAED",103,0) . S DGST=$G(DGCURR(2,DFN_",",.115,"I")) "RTN","DGREGAED",104,0) . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) "RTN","DGREGAED",105,0) . I DGCNTY=-1 S DGCNTY="" "RTN","DGREGAED",106,0) . S DGCMP("OLD",.117)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3) "RTN","DGREGAED",107,0) Q "RTN","DGREGAED",108,0) ; "RTN","DGREGAED",109,0) COMPARE(DGINPUT,DGCMP,FLG) ;Display before & after address fields. "RTN","DGREGAED",110,0) N DGM "RTN","DGREGAED",111,0) M DGCMP("NEW")=DGINPUT "RTN","DGREGAED",112,0) F DGM="OLD","NEW" D "RTN","DGREGAED",113,0) . I DGCMP(DGM,.1173)]"",$$FORIEN^DGADDUTL($P(DGCMP(DGM,.1173),U,2)) D DISPFGN(.DGCMP,DGM,.FLG) Q "RTN","DGREGAED",114,0) . I DGM="NEW" D "RTN","DGREGAED",115,0) . . S DGCNTY=$P($G(DGCMP("NEW",.117)),U)_" "_$P($G(DGCMP("NEW",.117)),U,3) "RTN","DGREGAED",116,0) . . S DGCMP("NEW",.117)=DGCNTY "RTN","DGREGAED",117,0) . . I ($L(DGCMP("NEW",.1112))>5)&($P(DGCMP("NEW",.1112),"-",2)="") S DGCMP("NEW",.1112)=$E(DGCMP("NEW",.1112),1,5)_"-"_$E(DGCMP("NEW",.1112),6,9) "RTN","DGREGAED",118,0) . D DISPUS(.DGCMP,DGM,.FLG) "RTN","DGREGAED",119,0) Q "RTN","DGREGAED",120,0) ; "RTN","DGREGAED",121,0) DISPUS(DGCMP,DGM,FLG) ;tag to display US data "RTN","DGREGAED",122,0) N DGCNTRY "RTN","DGREGAED",123,0) W !,?2,"[",DGM," ADDRESS]" "RTN","DGREGAED",124,0) W ?16,$P($G(DGCMP(DGM,.111)),U) "RTN","DGREGAED",125,0) I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U) "RTN","DGREGAED",126,0) I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U) "RTN","DGREGAED",127,0) W !,?16,$P($G(DGCMP(DGM,.114)),U) "RTN","DGREGAED",128,0) W:($P($G(DGCMP(DGM,.114)),U)'="")!($P($G(DGCMP(DGM,.115)),U)'="") "," "RTN","DGREGAED",129,0) W $P($G(DGCMP(DGM,.115)),U) "RTN","DGREGAED",130,0) W " ",$G(DGCMP(DGM,.1112)) "RTN","DGREGAED",131,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.1173)),U,2)) "RTN","DGREGAED",132,0) I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY "RTN","DGREGAED",133,0) I $P($G(DGCMP(DGM,.117)),U)'="" W !,?6," County: ",$P($G(DGCMP(DGM,.117)),U) "RTN","DGREGAED",134,0) I $G(FLG(1))=1 D "RTN","DGREGAED",135,0) . W !,?6," Phone: ",?16,$P($G(DGCMP(DGM,.131)),U) "RTN","DGREGAED",136,0) . W !,?6," Office: ",?16,$P($G(DGCMP(DGM,.132)),U) "RTN","DGREGAED",137,0) W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U) "RTN","DGREGAED",138,0) W ! "RTN","DGREGAED",139,0) Q "RTN","DGREGAED",140,0) ; "RTN","DGREGAED",141,0) DISPFGN(DGCMP,DGM,FLG) ;tag to display Foreign data "RTN","DGREGAED",142,0) N DGCNTRY "RTN","DGREGAED",143,0) W !,?2,"[",DGM," ADDRESS]" "RTN","DGREGAED",144,0) W ?16,$P($G(DGCMP(DGM,.111)),U) "RTN","DGREGAED",145,0) I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U) "RTN","DGREGAED",146,0) I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U) "RTN","DGREGAED",147,0) ;W !,?16,$P($G(DGCMP(DGM,.1172)),U)_" "_$P($G(DGCMP(DGM,.114)),U)_" "_$P($G(DGCMP(DGM,.1171)),U) ;DG*1010 comment out "RTN","DGREGAED",148,0) W !,?16,$P($G(DGCMP(DGM,.114)),U)_" "_$P($G(DGCMP(DGM,.1171)),U)_" "_$P($G(DGCMP(DGM,.1172)),U) ; DG*1010 - display postal code last "RTN","DGREGAED",149,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.1173)),U,2)) "RTN","DGREGAED",150,0) S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY) "RTN","DGREGAED",151,0) I DGCNTRY]"" W !?16,DGCNTRY "RTN","DGREGAED",152,0) I $G(FLG(1))=1 D "RTN","DGREGAED",153,0) . W !,?6," Phone: ",?16,$P($G(DGCMP(DGM,.131)),U) "RTN","DGREGAED",154,0) . W !,?6," Office: ",?16,$P($G(DGCMP(DGM,.132)),U) "RTN","DGREGAED",155,0) W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U) "RTN","DGREGAED",156,0) W ! "RTN","DGREGAED",157,0) Q "RTN","DGREGAED",158,0) ; "RTN","DGREGAED",159,0) CONFIRM() ;Confirm if user wants to save the change "RTN","DGREGAED",160,0) N DIR,X,Y,DTOUT,DUOUT,DIROUT "RTN","DGREGAED",161,0) S DIR(0)="Y" "RTN","DGREGAED",162,0) S DIR("A")="Are you sure that you want to save the above changes" "RTN","DGREGAED",163,0) S DIR("?")="Please answer Y for YES or N for NO." "RTN","DGREGAED",164,0) D ^DIR "RTN","DGREGAED",165,0) I $D(DTOUT)!($G(Y)=0) Q 0 "RTN","DGREGAED",166,0) I $D(DUOUT)!$D(DIROUT) Q 0 "RTN","DGREGAED",167,0) Q 1 "RTN","DGREGAED",168,0) SAVE(DGINPUT,DFN,FSTR,FORGN) ;Save changes "RTN","DGREGAED",169,0) N DGN,DGER,DGM,L,DATA "RTN","DGREGAED",170,0) S DGER=0 "RTN","DGREGAED",171,0) ; need to get the country code into the DGINPUT array "RTN","DGREGAED",172,0) ; if it's a domestic address, we have to add in CITY,STATE & COUNTY "RTN","DGREGAED",173,0) S FSTR=FSTR_$S('FORGN:",.114,.115,.117,.1173",1:",.1173") "RTN","DGREGAED",174,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) D "RTN","DGREGAED",175,0) . I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q "RTN","DGREGAED",176,0) . N DGCODE,DGNAME,FDA,MSG "RTN","DGREGAED",177,0) . S DGCODE=$P($G(DGINPUT(DGN)),U,2) "RTN","DGREGAED",178,0) . S DGNAME=$P($G(DGINPUT(DGN)),U) "RTN","DGREGAED",179,0) . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME) "RTN","DGREGAED",180,0) . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG") "RTN","DGREGAED",181,0) . I $D(MSG) D "RTN","DGREGAED",182,0) .. S DGM="",DGER=1 "RTN","DGREGAED",183,0) .. W !,"Please review the saved changes!!",! "RTN","DGREGAED",184,0) .. F S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM="" D "RTN","DGREGAED",185,0) ... W $G(MSG("DIERR",1,"TEXT",DGM)) "RTN","DGREGAED",186,0) I $G(DGER)=0 W !,"Change saved." D "RTN","DGREGAED",187,0) .;JAM, Set the CASS value for Perm Mailing Address ;DG*5.3*941 "RTN","DGREGAED",188,0) . S DATA(.1118)="NC" "RTN","DGREGAED",189,0) . I $$UPD^DGENDBS(2,DFN,.DATA) "RTN","DGREGAED",190,0) D EOP "RTN","DGREGAED",191,0) Q "RTN","DGREGAED",192,0) READ(DFN,DGN,Y) ;Read input, return success "RTN","DGREGAED",193,0) N SUCCESS,DIR,DA,DTOUT,DUOUT,DIROUT,L,POP "RTN","DGREGAED",194,0) S SUCCESS=1,POP=0 "RTN","DGREGAED",195,0) F L=0:0 D Q:POP "RTN","DGREGAED",196,0) . S DIR(0)=2_","_DGN "RTN","DGREGAED",197,0) . I DFN S DA=DFN "RTN","DGREGAED",198,0) . D ^DIR "RTN","DGREGAED",199,0) . I $D(DTOUT) S POP=1,SUCCESS=0 Q "RTN","DGREGAED",200,0) . I $D(DUOUT)!$D(DIROUT) D UPCT Q "RTN","DGREGAED",201,0) . S POP=1 "RTN","DGREGAED",202,0) Q SUCCESS "RTN","DGREGAED",203,0) INPT1(FORGN,PSTR) ; first address input prompts "RTN","DGREGAED",204,0) N FSTR "RTN","DGREGAED",205,0) ; PSTR is the full set of fields domestic & foreign combined "RTN","DGREGAED",206,0) ; FSTR is the set of fields depending on Country code "RTN","DGREGAED",207,0) S PSTR=".111,.112,.113,.114,.115,.117,.1112,.1171,.1172,.1173,.131,.132,.121" "RTN","DGREGAED",208,0) S FSTR=".111,.112,.113,.1112,.131,.132,.121" "RTN","DGREGAED",209,0) I FORGN S FSTR=".111,.112,.113,.114,.1171,.1172,.131,.132,.121" "RTN","DGREGAED",210,0) Q FSTR "RTN","DGREGAED",211,0) ZIPINP(DGINPUT,DFN) ; get ZIP+4 input "RTN","DGREGAED",212,0) N DGR "RTN","DGREGAED",213,0) D EN^DGREGAZL(.DGR,DFN) "RTN","DGREGAED",214,0) ;DG*5.3*1014 - Zip entry failed (due to timeout, or ^ entry, or input error) - before the Quit, set DGINPUT=-1 "RTN","DGREGAED",215,0) ;I $G(DGR)=-1 Q "RTN","DGREGAED",216,0) I $G(DGR)=-1 S DGINPUT=-1 Q "RTN","DGREGAED",217,0) M DGINPUT=DGR "RTN","DGREGAED",218,0) Q "RTN","DGREGAED",219,0) SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step "RTN","DGREGAED",220,0) N SKIP "RTN","DGREGAED",221,0) S SKIP=0 "RTN","DGREGAED",222,0) I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) S SKIP=1 "RTN","DGREGAED",223,0) I ($G(DGINPUT(.112))="")&(DGN=.113) S SKIP=1 "RTN","DGREGAED",224,0) I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) S SKIP=1 "RTN","DGREGAED",225,0) Q SKIP "RTN","DGREGAED",226,0) EOP ;End of page prompt "RTN","DGREGAED",227,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGAED",228,0) S DIR(0)="E" "RTN","DGREGAED",229,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGAED",230,0) D ^DIR "RTN","DGREGAED",231,0) Q "RTN","DGREGAED",232,0) UPCT ;Indicate "^" or "^^" are unacceptable inputs. "RTN","DGREGAED",233,0) W !,"EXIT NOT ALLOWED ??" "RTN","DGREGAED",234,0) Q "RTN","DGREGRED") 0^21^B77348398 "RTN","DGREGRED",1,0) DGREGRED ;ALB/JAM - Residential Address Edit API ;23 Feb 2018 1:33 PM "RTN","DGREGRED",2,0) ;;5.3;Registration;**941,1010,1014**;Aug 13, 1993;Build 42 "RTN","DGREGRED",3,0) ;; "RTN","DGREGRED",4,0) ; "RTN","DGREGRED",5,0) EN(DFN,FLG) ;Entry point "RTN","DGREGRED",6,0) ;Input: "RTN","DGREGRED",7,0) ; DFN (required) - Internal Entry # of Patient File (#2) "RTN","DGREGRED",8,0) ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details: "RTN","DGREGRED",9,0) ; FLG(1) - if 1 let user edit phone numbers (field #.131 and #.132) "RTN","DGREGRED",10,0) ; FLG(2) - if 1 display before & after address (and phone if FLG(1)=1) for user confirmation "RTN","DGREGRED",11,0) N DGINPUT,DGCMP,ICNTRY,CNTRY,FORGN,PSTR,OLDC,FSTR,BAD "RTN","DGREGRED",12,0) N I,X,Y "RTN","DGREGRED",13,0) I $G(DFN)="" Q "RTN","DGREGRED",14,0) S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2)) "RTN","DGREGRED",15,0) RETRY ; Entry point if address must be re-entered "RTN","DGREGRED",16,0) D GETOLD(.DGCMP,DFN) "RTN","DGREGRED",17,0) S CNTRY="",ICNTRY=$S(DFN:$P($G(^DPT(DFN,.115)),"^",10),1:"") "RTN","DGREGRED",18,0) I ICNTRY="" S ICNTRY=1 ;default country is USA if NULL "RTN","DGREGRED",19,0) S OLDC=DGCMP("OLD",.11573),FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,.11573,.CNTRY) I FORGN=-1 Q "RTN","DGREGRED",20,0) K FSTR,PSTR S FSTR=$$INPT1(FORGN,.PSTR) ;set up field string of address prompts "RTN","DGREGRED",21,0) K DGINPUT S DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR,CNTRY) I $G(DGINPUT)=-1 Q "RTN","DGREGRED",22,0) ; initialize valid address flag "RTN","DGREGRED",23,0) S BAD=0 "RTN","DGREGRED",24,0) ; "RTN","DGREGRED",25,0) ; **** DG*5.3*1014; jam; Start changes **** "RTN","DGREGRED",26,0) ; "RTN","DGREGRED",27,0) ; DG*5.3*1014; jam; If required fields are missing, we can't call the validation service - force user to correct the address "RTN","DGREGRED",28,0) I DGINPUT(.1151)=""!(DGINPUT(.1154)="")!(($G(DGINPUT(.1156))="")&('FORGN)) D G RETRY "RTN","DGREGRED",29,0) . I 'FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1], CITY, and ZIP CODE fields are required." "RTN","DGREGRED",30,0) . I FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGRED",31,0) ; DG*5.3*1014; Display the address entered "RTN","DGREGRED",32,0) N DGNEWADD "RTN","DGREGRED",33,0) M DGNEWADD("NEW")=DGINPUT "RTN","DGREGRED",34,0) W ! "RTN","DGREGRED",35,0) I FORGN D DISPFGN(.DGNEWADD,"NEW") "RTN","DGREGRED",36,0) I 'FORGN D DISPUS(.DGNEWADD,"NEW") "RTN","DGREGRED",37,0) K DGNEWADD "RTN","DGREGRED",38,0) CHK ; DG*5.3*1014; Prompt user and allow them to correct the address or continue to Validation service "RTN","DGREGRED",39,0) N DIR "RTN","DGREGRED",40,0) S DIR("A",1)="If address is ready for validation enter to continue, 'E' to Edit" "RTN","DGREGRED",41,0) S DIR("A")=" or '^' to quit" "RTN","DGREGRED",42,0) S DIR(0)="FO" "RTN","DGREGRED",43,0) S DIR("?")="Enter 'E' to edit the address, to continue to address validation or '^' to exit and cancel the address entry/edit.." "RTN","DGREGRED",44,0) D ^DIR K DIR "RTN","DGREGRED",45,0) I $D(DUOUT)!($D(DTOUT)) W !,"Address changes not saved." D EOP G PHONE ;Exiting - Not saving address - go to phone saving process "RTN","DGREGRED",46,0) I X="E"!(X="e") G RETRY ; re-enter address "RTN","DGREGRED",47,0) I X'="" G CHK ; at this point, any response but will not be accepted "RTN","DGREGRED",48,0) ; DG*5.3*1014; jam; Add call to Address Validation service "RTN","DGREGRED",49,0) N DGADVRET "RTN","DGREGRED",50,0) S DGADVRET=$$EN^DGADDVAL(.DGINPUT,"R") "RTN","DGREGRED",51,0) ; if return is 0 - address was not validated "RTN","DGREGRED",52,0) I 'DGADVRET W !!,"No Results - UAM Address Validation Service is unable to validate the address.",!,"Please verify the address entered. " D EOP "RTN","DGREGRED",53,0) ; DGINPUT array contains the address that is validated/accepted or what the user entered if the validation service failed "RTN","DGREGRED",54,0) ; "RTN","DGREGRED",55,0) ; **** DG*5.3*1014; jam; End changes **** "RTN","DGREGRED",56,0) ; "RTN","DGREGRED",57,0) ; if flag is set, show old and new address "RTN","DGREGRED",58,0) I FLG(2)=1 D COMPARE(.DGINPUT,.DGCMP) "RTN","DGREGRED",59,0) I '$$CONFIRM("ADDRESS") W !,"Address changes not saved." G PHONE ;Not saving address - go to phone saving process "RTN","DGREGRED",60,0) ; Validate the address fields and set BAD=1 if not valid "RTN","DGREGRED",61,0) I DGINPUT(.1151)=""!(DGINPUT(.1154)="")!(($G(DGINPUT(.1156))="")&('FORGN)) D S BAD=1 G PHONE "RTN","DGREGRED",62,0) . I 'FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1], ZIP CODE and CITY fields are required." "RTN","DGREGRED",63,0) . I FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGRED",64,0) ; If address is valid, next check is for PO Box and General Delivery - "RTN","DGREGRED",65,0) ; Pass in LINE 1, State and Country codes "RTN","DGREGRED",66,0) I $$POBOXRES^DGREGCP2(DGINPUT(.1151),$P($G(DGINPUT(.1155)),"^",2),$P(DGINPUT(.11573),"^",2)) D S BAD=1 G PHONE "RTN","DGREGRED",67,0) . W !!?3,*7,"You cannot enter 'P. O. Box' or 'General Delivery' for a Residential Address." "RTN","DGREGRED",68,0) ; If all Validations passed - save the address "RTN","DGREGRED",69,0) D SAVE(.DGINPUT,DFN,FSTR,FORGN) "RTN","DGREGRED",70,0) PHONE ; Process the phone number changes IF FLG(1) = 1 "RTN","DGREGRED",71,0) I $G(FLG(1))=1 D "RTN","DGREGRED",72,0) . ; if compare flag is set, display old/new values "RTN","DGREGRED",73,0) . I $G(FLG(2))=1 D COMPAREP(.DGINPUT,.DGCMP) "RTN","DGREGRED",74,0) . I '$$CONFIRM("PHONE") W !,"Phone changes not saved." D EOP "RTN","DGREGRED",75,0) . E D SAVEPH(.DGINPUT,DFN) "RTN","DGREGRED",76,0) ; Phone number process is completed - go to RETRY if address validation failed "RTN","DGREGRED",77,0) I BAD G RETRY "RTN","DGREGRED",78,0) Q "RTN","DGREGRED",79,0) INPUT(DGINPUT,DFN,FSTR,CNTRY) ;Let user input address changes "RTN","DGREGRED",80,0) ; Output: DGINPUT(field#)=external^internal(if any) "RTN","DGREGRED",81,0) N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L "RTN","DGREGRED",82,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L),DGINPUT(DGN)="" Q:DGINPUT=-1 D "RTN","DGREGRED",83,0) . I $$SKIP(DGN,.DGINPUT,.FLG) Q "RTN","DGREGRED",84,0) . I DGN=.1156 D ZIPINP(.DGINPUT,DFN) Q "RTN","DGREGRED",85,0) . I '$$READ(DFN,DGN,.Y) S DGINPUT=-1 Q "RTN","DGREGRED",86,0) . S DGINPUT(DGN)=$G(Y) "RTN","DGREGRED",87,0) I DGINPUT'=-1 S DGINPUT(.11573)=CNTRY_"^"_$O(^HL(779.004,"B",CNTRY,"")) "RTN","DGREGRED",88,0) Q "RTN","DGREGRED",89,0) GETOLD(DGCMP,DFN) ;populate array with existing address info "RTN","DGREGRED",90,0) K DGCMP "RTN","DGREGRED",91,0) N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,COUNTRY "RTN","DGREGRED",92,0) S CFORGN=0 "RTN","DGREGRED",93,0) ; get current country "RTN","DGREGRED",94,0) S CCIEN=$S(DFN:$$GET1^DIQ(2,DFN_",",.11573,"I"),1:"") "RTN","DGREGRED",95,0) S CFORGN=$$FORIEN^DGADDUTL(CCIEN) "RTN","DGREGRED",96,0) ; get current address fields and xlate to ^DIQ format "RTN","DGREGRED",97,0) S CFSTR=$$INPT1(CFORGN),CFSTR=$TR(CFSTR,",",";") "RTN","DGREGRED",98,0) ; Domestic data needs some extra fields "RTN","DGREGRED",99,0) I 'CFORGN S CFSTR=CFSTR_";.1154;.1155;.1157" "RTN","DGREGRED",100,0) I DFN D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR") "RTN","DGREGRED",101,0) F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E")) "RTN","DGREGRED",102,0) S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY" "RTN","DGREGRED",103,0) S DGCMP("OLD",.11573)=COUNTRY_"^"_CCIEN "RTN","DGREGRED",104,0) I 'CFORGN D "RTN","DGREGRED",105,0) . S DGCIEN=$G(DGCURR(2,DFN_",",.1157,"I")) "RTN","DGREGRED",106,0) . S DGST=$G(DGCURR(2,DFN_",",.1155,"I")) "RTN","DGREGRED",107,0) . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) "RTN","DGREGRED",108,0) . I DGCNTY=-1 S DGCNTY="" "RTN","DGREGRED",109,0) . S DGCMP("OLD",.1157)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3) "RTN","DGREGRED",110,0) Q "RTN","DGREGRED",111,0) ; "RTN","DGREGRED",112,0) COMPARE(DGINPUT,DGCMP) ;Display before & after address fields. "RTN","DGREGRED",113,0) N DGM,DGCNTY "RTN","DGREGRED",114,0) M DGCMP("NEW")=DGINPUT "RTN","DGREGRED",115,0) W ! "RTN","DGREGRED",116,0) F DGM="OLD","NEW" D "RTN","DGREGRED",117,0) . I DGCMP(DGM,.11573)]"",$$FORIEN^DGADDUTL($P(DGCMP(DGM,.11573),U,2)) D DISPFGN(.DGCMP,DGM) Q "RTN","DGREGRED",118,0) . I DGM="NEW" D "RTN","DGREGRED",119,0) . . S DGCNTY=$P($G(DGCMP("NEW",.1157)),U)_" "_$P($G(DGCMP("NEW",.1157)),U,3) "RTN","DGREGRED",120,0) . . S DGCMP("NEW",.1157)=DGCNTY "RTN","DGREGRED",121,0) . . I ($L(DGCMP("NEW",.1156))>5)&($P(DGCMP("NEW",.1156),"-",2)="") S DGCMP("NEW",.1156)=$E(DGCMP("NEW",.1156),1,5)_"-"_$E(DGCMP("NEW",.1156),6,9) "RTN","DGREGRED",122,0) . D DISPUS(.DGCMP,DGM) "RTN","DGREGRED",123,0) Q "RTN","DGREGRED",124,0) ; "RTN","DGREGRED",125,0) COMPAREP(DGINPUT,DGCMP) ;Display before & after phone fields. "RTN","DGREGRED",126,0) N DGM "RTN","DGREGRED",127,0) M DGCMP("NEW")=DGINPUT "RTN","DGREGRED",128,0) W ! "RTN","DGREGRED",129,0) F DGM="OLD","NEW" D "RTN","DGREGRED",130,0) . W !,?2,"[",DGM," PHONE NUMBERS]" "RTN","DGREGRED",131,0) . W !,?6," Phone: ",?16,$P($G(DGCMP(DGM,.131)),U) "RTN","DGREGRED",132,0) . W !,?6," Office: ",?16,$P($G(DGCMP(DGM,.132)),U) "RTN","DGREGRED",133,0) . W ! "RTN","DGREGRED",134,0) Q "RTN","DGREGRED",135,0) ; "RTN","DGREGRED",136,0) DISPUS(DGCMP,DGM) ;tag to display US data "RTN","DGREGRED",137,0) N DGCNTRY "RTN","DGREGRED",138,0) W !,?2,"[",DGM," RESIDENTIAL ADDRESS]" "RTN","DGREGRED",139,0) W !?16,$P($G(DGCMP(DGM,.1151)),U) "RTN","DGREGRED",140,0) I $P($G(DGCMP(DGM,.1152)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1152)),U) "RTN","DGREGRED",141,0) I $P($G(DGCMP(DGM,.1153)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1153)),U) "RTN","DGREGRED",142,0) W !,?16,$P($G(DGCMP(DGM,.1154)),U) "RTN","DGREGRED",143,0) W:($P($G(DGCMP(DGM,.1154)),U)'="")!($P($G(DGCMP(DGM,.1155)),U)'="") "," "RTN","DGREGRED",144,0) W $P($G(DGCMP(DGM,.1155)),U) "RTN","DGREGRED",145,0) W " ",$G(DGCMP(DGM,.1156)) "RTN","DGREGRED",146,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.11573)),U,2)) "RTN","DGREGRED",147,0) I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY "RTN","DGREGRED",148,0) I $P($G(DGCMP(DGM,.1157)),U)'="" W !,?6," County: ",$P($G(DGCMP(DGM,.1157)),U) "RTN","DGREGRED",149,0) W ! "RTN","DGREGRED",150,0) Q "RTN","DGREGRED",151,0) ; "RTN","DGREGRED",152,0) DISPFGN(DGCMP,DGM) ;tag to display Foreign data "RTN","DGREGRED",153,0) N DGCNTRY "RTN","DGREGRED",154,0) W !,?2,"[",DGM," RESIDENTIAL ADDRESS]" "RTN","DGREGRED",155,0) W !?16,$P($G(DGCMP(DGM,.1151)),U) "RTN","DGREGRED",156,0) I $P($G(DGCMP(DGM,.1152)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1152)),U) "RTN","DGREGRED",157,0) I $P($G(DGCMP(DGM,.1153)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1153)),U) "RTN","DGREGRED",158,0) ;W !,?16,$P($G(DGCMP(DGM,.11572)),U)_" "_$P($G(DGCMP(DGM,.1154)),U)_" "_$P($G(DGCMP(DGM,.11571)),U) ;DG*1010 comment out "RTN","DGREGRED",159,0) W !,?16,$P($G(DGCMP(DGM,.1154)),U)_" "_$P($G(DGCMP(DGM,.11571)),U)_" "_$P($G(DGCMP(DGM,.11572)),U) ;DG*1010 - display postal code last "RTN","DGREGRED",160,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.11573)),U,2)) "RTN","DGREGRED",161,0) S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY) "RTN","DGREGRED",162,0) I DGCNTRY]"" W !?16,DGCNTRY "RTN","DGREGRED",163,0) W ! "RTN","DGREGRED",164,0) Q "RTN","DGREGRED",165,0) ; "RTN","DGREGRED",166,0) CONFIRM(TYPE) ;Confirm if user wants to save the changes "RTN","DGREGRED",167,0) ; TYPE - used for the query message displayed to the user: "address" or "phone number" "RTN","DGREGRED",168,0) N DIR,X,Y,DTOUT,DUOUT,DIROUT "RTN","DGREGRED",169,0) S DIR(0)="Y" "RTN","DGREGRED",170,0) S DIR("A")="Are you sure that you want to save the "_TYPE_" changes" "RTN","DGREGRED",171,0) S DIR("?")="Please answer Y for YES or N for NO." "RTN","DGREGRED",172,0) D ^DIR "RTN","DGREGRED",173,0) I $D(DTOUT)!($G(Y)=0) Q 0 "RTN","DGREGRED",174,0) I $D(DUOUT)!$D(DIROUT) Q 0 "RTN","DGREGRED",175,0) Q 1 "RTN","DGREGRED",176,0) ; "RTN","DGREGRED",177,0) SAVE(DGINPUT,DFN,FSTR,FORGN) ;Save changes "RTN","DGREGRED",178,0) N DGN,DGER,DGM,L,DATA "RTN","DGREGRED",179,0) S DGER=0 "RTN","DGREGRED",180,0) ; need to get the country code into the DGINPUT array "RTN","DGREGRED",181,0) ; if it's a domestic address, we have to add in CITY,STATE & COUNTY "RTN","DGREGRED",182,0) S FSTR=FSTR_$S('FORGN:",.1154,.1155,.1157,.11573",1:",.11573") "RTN","DGREGRED",183,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) D "RTN","DGREGRED",184,0) . ; Phone numbers saved separately - skip over here "RTN","DGREGRED",185,0) . I (DGN=.131)!(DGN=.132) Q "RTN","DGREGRED",186,0) . N DGCODE,DGNAME,FDA,MSG "RTN","DGREGRED",187,0) . S DGCODE=$P($G(DGINPUT(DGN)),U,2) "RTN","DGREGRED",188,0) . S DGNAME=$P($G(DGINPUT(DGN)),U) "RTN","DGREGRED",189,0) . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME) "RTN","DGREGRED",190,0) . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG") "RTN","DGREGRED",191,0) . I $D(MSG) D "RTN","DGREGRED",192,0) .. S DGM="",DGER=1 "RTN","DGREGRED",193,0) .. W !,"Please review the saved changes!!",! "RTN","DGREGRED",194,0) .. F S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM="" D "RTN","DGREGRED",195,0) ... W $G(MSG("DIERR",1,"TEXT",DGM)) "RTN","DGREGRED",196,0) I $G(DGER)=0 W !,"Change saved." D "RTN","DGREGRED",197,0) . ; Set the CASS IND field "RTN","DGREGRED",198,0) . S DATA(.1159)="NC" "RTN","DGREGRED",199,0) . I $$UPD^DGENDBS(2,DFN,.DATA) "RTN","DGREGRED",200,0) D EOP "RTN","DGREGRED",201,0) Q "RTN","DGREGRED",202,0) ; "RTN","DGREGRED",203,0) SAVEPH(DGINPUT,DFN) ;Save phone changes "RTN","DGREGRED",204,0) N DGN,DGER,DGM,DATA "RTN","DGREGRED",205,0) S DGER=0 "RTN","DGREGRED",206,0) F DGN=.131,.132 D "RTN","DGREGRED",207,0) . N DGCODE,DGNAME,FDA,MSG "RTN","DGREGRED",208,0) . S DGCODE=$P($G(DGINPUT(DGN)),U,2) "RTN","DGREGRED",209,0) . S DGNAME=$P($G(DGINPUT(DGN)),U) "RTN","DGREGRED",210,0) . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME) "RTN","DGREGRED",211,0) . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG") "RTN","DGREGRED",212,0) . I $D(MSG) D "RTN","DGREGRED",213,0) .. S DGM="",DGER=1 "RTN","DGREGRED",214,0) .. W !,"Please review the saved changes!!",! "RTN","DGREGRED",215,0) .. F S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM="" D "RTN","DGREGRED",216,0) ... W $G(MSG("DIERR",1,"TEXT",DGM)) "RTN","DGREGRED",217,0) I $G(DGER)=0 W !,"Change saved." "RTN","DGREGRED",218,0) D EOP "RTN","DGREGRED",219,0) Q "RTN","DGREGRED",220,0) ; "RTN","DGREGRED",221,0) READ(DFN,DGN,Y) ;Read input, return success "RTN","DGREGRED",222,0) N SUCCESS,DIR,DA,DTOUT,DUOUT,DIROUT,L,POP "RTN","DGREGRED",223,0) S SUCCESS=1,POP=0 "RTN","DGREGRED",224,0) F L=0:0 D Q:POP "RTN","DGREGRED",225,0) . S DIR(0)=2_","_DGN "RTN","DGREGRED",226,0) . I DFN S DA=DFN "RTN","DGREGRED",227,0) . D ^DIR "RTN","DGREGRED",228,0) . I $D(DTOUT) S POP=1,SUCCESS=0 Q "RTN","DGREGRED",229,0) . I $D(DUOUT)!$D(DIROUT) D UPCT Q "RTN","DGREGRED",230,0) . S POP=1 "RTN","DGREGRED",231,0) Q SUCCESS "RTN","DGREGRED",232,0) INPT1(FORGN,PSTR) ; first address input prompts "RTN","DGREGRED",233,0) N FSTR "RTN","DGREGRED",234,0) ; PSTR is the full set of fields domestic & foreign combined "RTN","DGREGRED",235,0) ; FSTR is the set of fields depending on Country code "RTN","DGREGRED",236,0) S PSTR=".1151,.1152,.1153,.1154,.1155,.1157,.1156,.11571,.11572,.11573,.131,.132" "RTN","DGREGRED",237,0) S FSTR=".1151,.1152,.1153,.1156,.131,.132" "RTN","DGREGRED",238,0) I FORGN S FSTR=".1151,.1152,.1153,.1154,.11571,.11572,.131,.132" "RTN","DGREGRED",239,0) Q FSTR "RTN","DGREGRED",240,0) ZIPINP(DGINPUT,DFN) ; get ZIP+4 input "RTN","DGREGRED",241,0) ; This subroutine calls existing code to prompt for zip code and return corresponding city, state and county "RTN","DGREGRED",242,0) ; DFN must be the patient internal ID. "RTN","DGREGRED",243,0) ; DGINPUT - passed by reference - the array containing the resulting county, city, and state for the zipcode. "RTN","DGREGRED",244,0) N FCITY,FZIP,FSTATE,FCOUNTY,TYPE,DGR "RTN","DGREGRED",245,0) ; Set the necessary variables for the Residential Address "RTN","DGREGRED",246,0) ; The variable TYPE is used for Confidential and temporary address types. "RTN","DGREGRED",247,0) ; Here for the Residential Address we clear this variable. "RTN","DGREGRED",248,0) S FZIP=".1156",FCITY=".1154",FSTATE=".1155",FCOUNTY=".1157",TYPE="" "RTN","DGREGRED",249,0) D EN^DGREGTZL(.DGR,DFN) "RTN","DGREGRED",250,0) M DGINPUT=DGR "RTN","DGREGRED",251,0) Q "RTN","DGREGRED",252,0) SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step "RTN","DGREGRED",253,0) N SKIP "RTN","DGREGRED",254,0) S SKIP=0 "RTN","DGREGRED",255,0) I ($G(DGINPUT(.1151))="")&((DGN=.1152)!(DGN=.1153)) S SKIP=1 "RTN","DGREGRED",256,0) I ($G(DGINPUT(.1152))="")&(DGN=.1153) S SKIP=1 "RTN","DGREGRED",257,0) I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) S SKIP=1 "RTN","DGREGRED",258,0) Q SKIP "RTN","DGREGRED",259,0) EOP ;End of page prompt "RTN","DGREGRED",260,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGRED",261,0) S DIR(0)="E" "RTN","DGREGRED",262,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGRED",263,0) D ^DIR "RTN","DGREGRED",264,0) Q "RTN","DGREGRED",265,0) UPCT ;Indicate "^" or "^^" are unacceptable inputs. "RTN","DGREGRED",266,0) W !,"EXIT NOT ALLOWED" "RTN","DGREGRED",267,0) Q "RTN","DGREGTED") 0^22^B65810805 "RTN","DGREGTED",1,0) DGREGTED ;ALB/BAJ,BDB,JAM - Temporary & Confidential Address Edits API ;23 May 2017 12:48 PM "RTN","DGREGTED",2,0) ;;5.3;Registration;**688,851,941,1014**;Aug 13, 1993;Build 42 "RTN","DGREGTED",3,0) ; "RTN","DGREGTED",4,0) EN(DFN,TYPE,RET) ;Entry point "RTN","DGREGTED",5,0) ; This routine controls Edits to Temporary & Confidential addresses "RTN","DGREGTED",6,0) ; "RTN","DGREGTED",7,0) ; Input "RTN","DGREGTED",8,0) ; DFN = Patient DFN "RTN","DGREGTED",9,0) ; TYPE = Type of address: "TEMP" or "CONF" "RTN","DGREGTED",10,0) ; RET = Flag to signal return to first prompt "RTN","DGREGTED",11,0) ; "RTN","DGREGTED",12,0) ; Output "RTN","DGREGTED",13,0) ; RET 0 = Return to first prompt in the address edit group "RTN","DGREGTED",14,0) ; 1 = Do not return (address was saved) "RTN","DGREGTED",15,0) ; "RTN","DGREGTED",16,0) N DGINPUT,FORGN,FSTR,ICNTRY,CNTRY,PSTR,DGCMP,DGOLD,DR,DIE "RTN","DGREGTED",17,0) N FSLINE1,FSLINE2,FSLINE3,FCITY,FSTATE,FCOUNTY,FZIP,FPHONE "RTN","DGREGTED",18,0) N FPROV,FPSTAL,FCNTRY,FNODE1,FNODE2,CPEICE,OLDC,RPROC "RTN","DGREGTED",19,0) N I,X,Y "RTN","DGREGTED",20,0) I $G(DFN)="" Q "RTN","DGREGTED",21,0) ;I ($G(DFN)'?.N) Q "RTN","DGREGTED",22,0) D INIT^DGREGTE2 I $P($G(^DPT(DFN,FNODE1)),U,9)="N" Q "RTN","DGREGTED",23,0) D GETOLD^DGREGTE2(.DGCMP,DFN,TYPE) M DGOLD=DGCMP("OLD") K DGCMP "RTN","DGREGTED",24,0) S CNTRY="",ICNTRY=$P($G(^DPT(DFN,FNODE2)),"^",CPEICE) I ICNTRY="" S ICNTRY=1 ;default US if NULL "RTN","DGREGTED",25,0) ; "RTN","DGREGTED",26,0) ; DG*5.3*1014; jam; ** Start changes ** "RTN","DGREGTED",27,0) ; RETRY tag added below "RTN","DGREGTED",28,0) RETRY ; Tag for reentering the address "RTN","DGREGTED",29,0) S FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,FCNTRY,.CNTRY) Q:$G(CNTRY)="" I FORGN=-1 S RET=0 Q "RTN","DGREGTED",30,0) S FSTR=$$INPT1^DGREGTE2(DFN,FORGN,.PSTR),DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR) "RTN","DGREGTED",31,0) I $G(DGINPUT)=-1 S RET=0 Q "RTN","DGREGTED",32,0) ; "RTN","DGREGTED",33,0) ; DG*5.3*1014; jam; For confidential address, if required fields are missing, we can't call the validation service - force user to correct the address "RTN","DGREGTED",34,0) I TYPE="CONF",DGINPUT(.1411)=""!(DGINPUT(.1414)="")!(($G(DGINPUT(.1416))="")&('FORGN)) D G RETRY "RTN","DGREGTED",35,0) . I 'FORGN W !!?3,*7,"CONFIDENTIAL ADDRESS [LINE 1], CITY, and ZIP CODE fields are required." "RTN","DGREGTED",36,0) . I FORGN W !!?3,*7,"CONFIDENTIAL ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGTED",37,0) ; DG*5.3*1014; jam; Address Validation service for confidential address only - TEMP address will skip over this "RTN","DGREGTED",38,0) I TYPE'="CONF" G SVADD "RTN","DGREGTED",39,0) ; Place the country code and name into the DGINPUT array "RTN","DGREGTED",40,0) S DGINPUT(FCNTRY)=$O(^HL(779.004,"B",CNTRY,""))_"^"_CNTRY "RTN","DGREGTED",41,0) ; DG*5.3*1014; Display address entered - user may reenter the address or continue to Validation service. "RTN","DGREGTED",42,0) W ! "RTN","DGREGTED",43,0) N DGNEWADD "RTN","DGREGTED",44,0) M DGNEWADD("NEW")=DGINPUT "RTN","DGREGTED",45,0) I FORGN D DISPFGN(.DGNEWADD,"NEW") "RTN","DGREGTED",46,0) I 'FORGN D DISPUS(.DGNEWADD,"NEW") "RTN","DGREGTED",47,0) K DGNEWADD "RTN","DGREGTED",48,0) CHK ; DG*5.3*1014; Prompt user and allow them to correct the address or continue to Validation service "RTN","DGREGTED",49,0) N DIR "RTN","DGREGTED",50,0) S DIR("A",1)="If address is ready for validation enter to continue, 'E' to Edit" "RTN","DGREGTED",51,0) S DIR("A")=" or '^' to quit" "RTN","DGREGTED",52,0) S DIR(0)="FO" "RTN","DGREGTED",53,0) S DIR("?")="Enter 'E' to edit the address, to continue to address validation or '^' to exit and cancel the address entry/edit.." "RTN","DGREGTED",54,0) D ^DIR K DIR "RTN","DGREGTED",55,0) I $D(DUOUT)!($D(DTOUT)) W !,"Address changes not saved." D EOP Q ;Exiting - Not saving address "RTN","DGREGTED",56,0) I X="E"!(X="e") G RETRY ; re-enter address "RTN","DGREGTED",57,0) I X'="" G CHK ; at this point, any response but will not be accepted "RTN","DGREGTED",58,0) ; DG*5.3*1014; jam; Add call to Address Validation service "RTN","DGREGTED",59,0) N DGADVRET "RTN","DGREGTED",60,0) S DGADVRET=$$EN^DGADDVAL(.DGINPUT,"C") "RTN","DGREGTED",61,0) ; if return is 0 - address could not be validated "RTN","DGREGTED",62,0) I 'DGADVRET W !!,"No Results - UAM Address Validation Service is unable to validate the address.",!,"Please verify the address entered. " D EOP "RTN","DGREGTED",63,0) ; DGINPUT array contains the address that is validated/accepted or what the user entered if the validation service failed "RTN","DGREGTED",64,0) ; "RTN","DGREGTED",65,0) SVADD ; Save the address - SVADD tag added for DG*5.3*1014; jam; ** End of 1014 changes ** "RTN","DGREGTED",66,0) D SAVE(.DGINPUT,DFN,FSTR,CNTRY) "RTN","DGREGTED",67,0) Q "RTN","DGREGTED",68,0) ; "RTN","DGREGTED",69,0) INPUT(DGINPUT,DFN,FSTR) ;Let user input address changes "RTN","DGREGTED",70,0) ; Input: "RTN","DGREGTED",71,0) ; DGINPUT - Array to hold field values DGINPUT(field#) "RTN","DGREGTED",72,0) ; DFN - Patient DFN "RTN","DGREGTED",73,0) ; FSTR - String of fields (foreign or domestic) to work with "RTN","DGREGTED",74,0) ; "RTN","DGREGTED",75,0) ; Output: "RTN","DGREGTED",76,0) ; DGINPUT(field#)=external^internal(if any) "RTN","DGREGTED",77,0) ; "RTN","DGREGTED",78,0) N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L,SUCCESS,REP "RTN","DGREGTED",79,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) Q:DGINPUT=-1 D "RTN","DGREGTED",80,0) . S REP=0 "RTN","DGREGTED",81,0) . I $$SKIP^DGREGTE2(DGN,.DGINPUT) Q "RTN","DGREGTED",82,0) . I DGN=FZIP D ZIPINP(.DGINPUT,DFN) Q ;DG*5.3*851 "RTN","DGREGTED",83,0) . S SUCCESS=$$READ(DFN,.DGOLD,DGN,.Y,.REP) I 'SUCCESS D Q "RTN","DGREGTED",84,0) . . I 'REP S DGINPUT=-1 Q "RTN","DGREGTED",85,0) . . ; repeat the question so we have to set the counter back "RTN","DGREGTED",86,0) . . S L=L-1 "RTN","DGREGTED",87,0) . ; DG*5.3*1014 ;jam; prevent the @ from getting into the array "RTN","DGREGTED",88,0) . I $G(Y)="@" S Y="" "RTN","DGREGTED",89,0) . S DGINPUT(DGN)=$G(Y) "RTN","DGREGTED",90,0) READ(DFN,DGOLD,DGN,Y,REP) ;Read input, return success "RTN","DGREGTED",91,0) ; Input: "RTN","DGREGTED",92,0) ; DFN - Patient DFN "RTN","DGREGTED",93,0) ; DGOLD - Array of current field values. "RTN","DGREGTED",94,0) ; DGN - Current field to read "RTN","DGREGTED",95,0) ; Y - Current Field value "RTN","DGREGTED",96,0) ; REP - Flag -- should prompt be repeated "RTN","DGREGTED",97,0) ; "RTN","DGREGTED",98,0) ; Output "RTN","DGREGTED",99,0) ; SUCCESS 1 = Input successful go to next prompt "RTN","DGREGTED",100,0) ; 0 = Input unsuccessful Repeat or Abort as indicated by REP variable "RTN","DGREGTED",101,0) ; REP 1 = Error - Repeat prompt "RTN","DGREGTED",102,0) ; 0 = Error - Do not repeat "RTN","DGREGTED",103,0) ; Y New field value "RTN","DGREGTED",104,0) ; "RTN","DGREGTED",105,0) N SUCCESS,DIR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,L,T,POP,DGST,CNTYFLD,REVERSE "RTN","DGREGTED",106,0) S SUCCESS=1,(POP,REVERSE)=0,CNTYFLD=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTY",1:"CONFIDENTIAL ADDRESS COUNTY") "RTN","DGREGTED",107,0) S DIR(0)=2_","_DGN,DIR("B")=$G(DGOLD(DGN)) "RTN","DGREGTED",108,0) S DA=DFN "RTN","DGREGTED",109,0) F D Q:POP "RTN","DGREGTED",110,0) . K DTOUT,DUOUT,DIROUT "RTN","DGREGTED",111,0) . S MSG="" "RTN","DGREGTED",112,0) . I ($G(DGINPUT(FSTATE))="")&(DGN=FCOUNTY) S POP=1 Q "RTN","DGREGTED",113,0) . S DIR("B")=$S($D(DGINPUT(DGN)):DGINPUT(DGN),$G(DGOLD(DGN))]"":DGOLD(DGN),1:"") "RTN","DGREGTED",114,0) . I DGN=FCOUNTY D "RTN","DGREGTED",115,0) . . S DIR(0)="POA^DIC(5,"_$P(DGINPUT(FSTATE),U)_",1,:AEMQ" "RTN","DGREGTED",116,0) . . S DIR("A")=CNTYFLD_": " "RTN","DGREGTED",117,0) . . ; we can't prompt if there's no previous entry "RTN","DGREGTED",118,0) . . I $D(DGOLD(DGN)) S T=$L(DGOLD(DGN)," "),DIR("B")=$P($G(DGOLD(DGN))," ",1,T-1) "RTN","DGREGTED",119,0) . D ^DIR "RTN","DGREGTED",120,0) . I $D(DTOUT) S POP=1,SUCCESS=0 Q "RTN","DGREGTED",121,0) . I $D(DIRUT) S MSG="",REVERSE=0 D ANSW(X,.DGOLD,DGN,.MSG,.Y,.REP,$G(RET),.REVERSE) S:REP SUCCESS=0 W:MSG]"" !,MSG "RTN","DGREGTED",122,0) . I REVERSE S (REP,SUCCESS)=0 "RTN","DGREGTED",123,0) . S POP=1 "RTN","DGREGTED",124,0) Q SUCCESS "RTN","DGREGTED",125,0) ; "RTN","DGREGTED",126,0) SAVE(DGINPUT,DFN,FSTR,CNTRY) ;Save changes "RTN","DGREGTED",127,0) N DATA,DGENDA,L,T,FILE,ERROR,LOOP,LOOP1,LOOP2 "RTN","DGREGTED",128,0) S DGENDA=DFN,FILE=2 "RTN","DGREGTED",129,0) ; need to get the country code into the DGINPUT array "RTN","DGREGTED",130,0) S DGINPUT(FCNTRY)=$O(^HL(779.004,"B",CNTRY,"")) "RTN","DGREGTED",131,0) S FSTR=FSTR_","_FCNTRY "RTN","DGREGTED",132,0) I (TYPE="TEMP")!(TYPE="CONF") S FSTR=FSTR_","_FCITY_","_FSTATE_","_FCOUNTY ;DG*5.3*851 "RTN","DGREGTED",133,0) F L=1:1:$L(FSTR,",") S T=$P(FSTR,",",L) S DATA(T)=$P($G(DGINPUT(T)),U) "RTN","DGREGTED",134,0) ;JAM; Set the CASS field for Temp and Confidential; DG*5.3*941 "RTN","DGREGTED",135,0) I TYPE="TEMP" S DATA(.12115)="NC" "RTN","DGREGTED",136,0) I TYPE="CONF" S DATA(.14117)="NC" "RTN","DGREGTED",137,0) Q $$UPD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR) "RTN","DGREGTED",138,0) ; "RTN","DGREGTED",139,0) ANSW(YIN,DGOLD,DGN,MSG,YOUT,REP,RET,REVERSE) ;analyze input commands "RTN","DGREGTED",140,0) ; This API will process reads and set bits, messages and flags accordingly. "RTN","DGREGTED",141,0) ; Because there is different behavior depending on prompt and input, the input "RTN","DGREGTED",142,0) ; of each field needs to be evaluated separately at the time of input and before "RTN","DGREGTED",143,0) ; deciding to continue the edit. Input rules are loaded into array RPROC at the "RTN","DGREGTED",144,0) ; beginning of this routine in call to INIT^DGREGTE2. "RTN","DGREGTED",145,0) ; "RTN","DGREGTED",146,0) ; Input "RTN","DGREGTED",147,0) ; N - User input "Y" value "RTN","DGREGTED",148,0) ; DGOLD - Array of current values "RTN","DGREGTED",149,0) ; DGN - Current field "RTN","DGREGTED",150,0) ; MSG - Variable for Text message "RTN","DGREGTED",151,0) ; YOUT - User input ("Y") value "RTN","DGREGTED",152,0) ; REP - Flag to repeat prompt "RTN","DGREGTED",153,0) ; RET - Flag to return success or failure to calling module "RTN","DGREGTED",154,0) ; REVERSE - Flag to revert to first prompt in sequence "RTN","DGREGTED",155,0) ; "RTN","DGREGTED",156,0) ; Output "RTN","DGREGTED",157,0) ; MSG - Text message (for incorrect entries) "RTN","DGREGTED",158,0) ; REP - Repeat current prompt "RTN","DGREGTED",159,0) ; REVERSE - Revert to first prompt in sequence "RTN","DGREGTED",160,0) ; "RTN","DGREGTED",161,0) N X,Y,DTOUT,DIRUT,DUOUT,PRMPT,RMSG,TDGN,ACT "RTN","DGREGTED",162,0) N OLDVAL,NEWVAL "RTN","DGREGTED",163,0) ; "RTN","DGREGTED",164,0) S PRMPT=$S(TYPE="TEMP":"TEMPORARY",1:"CONFIDENTIAL") "RTN","DGREGTED",165,0) S RMSG("LINE")="BUT I NEED AT LEAST ONE LINE OF A "_PRMPT_" ADDRESS" "RTN","DGREGTED",166,0) S RMSG("REVERSE")="This is a required response." "RTN","DGREGTED",167,0) S RMSG("REPEAT")="EXIT NOT ALLOWED ??" "RTN","DGREGTED",168,0) S RMSG("QUES")="??" "RTN","DGREGTED",169,0) S RMSG("INSTRUCT")=$S(TYPE="TEMP":"TADD^DGLOCK1",TYPE="CONF":"CADD1^DGLOCK3",1:"OK") "RTN","DGREGTED",170,0) S OLDVAL=$G(DGOLD(DGN)),OLDVAL=$$PROC(OLDVAL),NEWVAL=$$PROC(YIN) "RTN","DGREGTED",171,0) S TDGN=$S($D(RPROC(DGN,OLDVAL,NEWVAL)):DGN,1:"ALL") "RTN","DGREGTED",172,0) I '$D(RPROC(TDGN,OLDVAL,NEWVAL)) S RPROC(TDGN,OLDVAL,NEWVAL)="OK" "RTN","DGREGTED",173,0) S ACT=RPROC(TDGN,OLDVAL,NEWVAL) "RTN","DGREGTED",174,0) D @ACT "RTN","DGREGTED",175,0) Q "RTN","DGREGTED",176,0) REVERSE ; "RTN","DGREGTED",177,0) N MSUB "RTN","DGREGTED",178,0) S MSUB=$S(DGN=FSLINE1:"LINE",1:"REVERSE") "RTN","DGREGTED",179,0) W !,RMSG(MSUB) "RTN","DGREGTED",180,0) S REVERSE=1 "RTN","DGREGTED",181,0) Q "RTN","DGREGTED",182,0) REPEAT ; "RTN","DGREGTED",183,0) W !,RMSG("REPEAT") "RTN","DGREGTED",184,0) S REP=1 "RTN","DGREGTED",185,0) Q "RTN","DGREGTED",186,0) OK ; "RTN","DGREGTED",187,0) Q "RTN","DGREGTED",188,0) QUES ; "RTN","DGREGTED",189,0) W RMSG("QUES") "RTN","DGREGTED",190,0) S REP=1 "RTN","DGREGTED",191,0) Q "RTN","DGREGTED",192,0) CONFIRM ; "RTN","DGREGTED",193,0) I '$$SURE^DGREGTE2 S YOUT=DGOLD(DGN),REP=1 Q "RTN","DGREGTED",194,0) S YOUT=YIN,REP=0 "RTN","DGREGTED",195,0) Q "RTN","DGREGTED",196,0) INSTRUCT ; "RTN","DGREGTED",197,0) D @RMSG("INSTRUCT") "RTN","DGREGTED",198,0) S REP=1 "RTN","DGREGTED",199,0) Q "RTN","DGREGTED",200,0) PROC(VAL) ;process the input and return a type of value "RTN","DGREGTED",201,0) ; input "RTN","DGREGTED",202,0) ; VAL - The value to examine "RTN","DGREGTED",203,0) ; "RTN","DGREGTED",204,0) ; output "RTN","DGREGTED",205,0) ; a value type "RTN","DGREGTED",206,0) ; VALUE = input - validation is a separate task and is not done here "RTN","DGREGTED",207,0) ; NULL = NULL input "RTN","DGREGTED",208,0) ; UPCAR = the "^" character "RTN","DGREGTED",209,0) ; DELETE = the "@" character "RTN","DGREGTED",210,0) Q $S(VAL="":"NULL",$E(VAL)="^":"UPCAR",$E(VAL)="@":"DELETE",1:"VALUE") "RTN","DGREGTED",211,0) EOP ;End of page prompt "RTN","DGREGTED",212,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGTED",213,0) S DIR(0)="E" "RTN","DGREGTED",214,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGTED",215,0) D ^DIR "RTN","DGREGTED",216,0) Q "RTN","DGREGTED",217,0) ; DG*5.3*851 "RTN","DGREGTED",218,0) ZIPINP(DGINPUT,DFN) ;get ZIP+4 input "RTN","DGREGTED",219,0) N DGR,DGX "RTN","DGREGTED",220,0) D EN^DGREGTZL(.DGR,DFN) "RTN","DGREGTED",221,0) ;DG*5.3*1014 - Zip entry failed (due to timeout, or ^ entry, or input error) - before the Quit, set DGINPUT=-1 "RTN","DGREGTED",222,0) ;I $G(DGR)=-1 Q "RTN","DGREGTED",223,0) I $G(DGR)=-1 S DGINPUT=-1 Q "RTN","DGREGTED",224,0) M DGINPUT=DGR "RTN","DGREGTED",225,0) S DGX=DGINPUT(FCOUNTY),DGINPUT(FCOUNTY)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGREGTED",226,0) S DGX=DGINPUT(FSTATE),DGINPUT(FSTATE)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGREGTED",227,0) Q "RTN","DGREGTED",228,0) SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step "RTN","DGREGTED",229,0) N SKIP "RTN","DGREGTED",230,0) S SKIP=0 "RTN","DGREGTED",231,0) I ($G(DGINPUT(FSLINE1))="")&((DGN=FSLINE2)!(DGN=FSLINE3)) S SKIP=1 "RTN","DGREGTED",232,0) I ($G(DGINPUT(FSLINE2))="")&(DGN=FSLINE3) S SKIP=1 "RTN","DGREGTED",233,0) I ($G(FLG(1))'=1)&((DGN=FPHONE)) S SKIP=1 "RTN","DGREGTED",234,0) Q SKIP "RTN","DGREGTED",235,0) UPCT ;Indicate "^" or "^^" are unacceptable inputs. "RTN","DGREGTED",236,0) W !,"EXIT NOT ALLOWED ??" "RTN","DGREGTED",237,0) Q "RTN","DGREGTED",238,0) ; "RTN","DGREGTED",239,0) ; DG*5.3*1014;jam; Added these tags to display the address prior to calling the Validation service "RTN","DGREGTED",240,0) DISPUS(DGCMP,DGM) ;tag to display US data "RTN","DGREGTED",241,0) N DGCNTRY "RTN","DGREGTED",242,0) ; "AddressLine1,AddressLine2,AddressLine3,City,State,County,Zip,Province,PostalCode^Country" "RTN","DGREGTED",243,0) ; ".1411,.1412,.1413,.1414,.1415,.14111,.1416,.14114,.14115,.14116" ; Confidential address fields "RTN","DGREGTED",244,0) W !,?2,"[",DGM," CONFIDENTIAL ADDRESS]" "RTN","DGREGTED",245,0) W !?16,$G(DGCMP(DGM,.1411)) "RTN","DGREGTED",246,0) I $G(DGCMP(DGM,.1412))'="" W !,?16,$G(DGCMP(DGM,.1412)) "RTN","DGREGTED",247,0) I $G(DGCMP(DGM,.1413))'="" W !,?16,$G(DGCMP(DGM,.1413)) "RTN","DGREGTED",248,0) W !,?16,$G(DGCMP(DGM,.1414)) "RTN","DGREGTED",249,0) W:($G(DGCMP(DGM,.1414))'="")!($P($G(DGCMP(DGM,.1415)),U,2)'="") "," "RTN","DGREGTED",250,0) W $P($G(DGCMP(DGM,.1415)),U,2) "RTN","DGREGTED",251,0) W " ",$G(DGCMP(DGM,.1416)) "RTN","DGREGTED",252,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.14116)),U)) "RTN","DGREGTED",253,0) I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY "RTN","DGREGTED",254,0) I $P($G(DGCMP(DGM,.14111)),U)'="" W !,?6," County: ",$P($G(DGCMP(DGM,.14111)),U,2) "RTN","DGREGTED",255,0) W ! "RTN","DGREGTED",256,0) Q "RTN","DGREGTED",257,0) ; "RTN","DGREGTED",258,0) DISPFGN(DGCMP,DGM) ;tag to display Foreign data "RTN","DGREGTED",259,0) N DGCNTRY "RTN","DGREGTED",260,0) W !,?2,"[",DGM," CONFIDENTIAL ADDRESS]" "RTN","DGREGTED",261,0) W !?16,$G(DGCMP(DGM,.1411)) "RTN","DGREGTED",262,0) I $G(DGCMP(DGM,.1412))'="" W !,?16,$G(DGCMP(DGM,.1412)) "RTN","DGREGTED",263,0) I $G(DGCMP(DGM,.1413))'="" W !,?16,$G(DGCMP(DGM,.1413)) "RTN","DGREGTED",264,0) W !,?16,$G(DGCMP(DGM,.1414))_" "_$G(DGCMP(DGM,.14114))_" "_$G(DGCMP(DGM,.14115)) "RTN","DGREGTED",265,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.14116)),U)) "RTN","DGREGTED",266,0) S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY) "RTN","DGREGTED",267,0) I DGCNTRY]"" W !?16,DGCNTRY "RTN","DGREGTED",268,0) W ! "RTN","DGREGTED",269,0) Q "RTN","DGRP1") 0^6^B40617641 "RTN","DGRP1",1,0) DGRP1 ;ALB/MRL,ERC,BAJ,PWC,JAM,JAM,ARF - DEMOGRAPHIC DATA ;19 Jul 2017 3:02 PM "RTN","DGRP1",2,0) ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,688,750,851,907,925,941,985,1014**;Aug 13, 1993;Build 42 "RTN","DGRP1",3,0) ; "RTN","DGRP1",4,0) EN ; "RTN","DGRP1",5,0) ; JAM - Patch DG*5.3*941, Reformatting Registration screen 1. New field layout. "RTN","DGRP1",6,0) ;S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.122,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP1",7,0) N DGRP "RTN","DGRP1",8,0) S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.13,.15,.24,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP1",9,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",10,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",11,0) ;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005 "RTN","DGRP1",12,0) N SSNV D GETSTAT(.SSNV) "RTN","DGRP1",13,0) S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV "RTN","DGRP1",14,0) ; DG*5.3*985; JAM - reformat screen 1 to add group 6 - Preferred Name next to Name field and move SSN and Pseudo Reason down "RTN","DGRP1",15,0) S DGRPW=0,Z1="",Z=6 D WW^DGRPV S Z=$P(DGRP(.24),"^",5),Z1=1 S Z=$S(Z]"":" Preferred Name: "_$E(Z,1,17),1:" Preferred Name: Not Answered") D WW1^DGRPV "RTN","DGRP1",16,0) S DGRPW=1 "RTN","DGRP1",17,0) W ! S Z="",Z1=6 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y "RTN","DGRP1",18,0) W ! S Z="",Z1=7 D WW1^DGRPV "RTN","DGRP1",19,0) ;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005 "RTN","DGRP1",20,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 W SSNV "RTN","DGRP1",21,0) ;add Pseuso SSN Reason - DG*5.3*653, ERC "RTN","DGRP1",22,0) I $P(DGRP(0),U,9)["P" D "RTN","DGRP1",23,0) . N DGSPACE "RTN","DGRP1",24,0) . S DGSPACE=10-$L(Z) ;adjust to maintain spacing on screen "RTN","DGRP1",25,0) . S Z="" "RTN","DGRP1",26,0) . S Z1=14+DGSPACE D WW1^DGRPV W "PSSN Reason: " "RTN","DGRP1",27,0) . N DGREAS D SSNREAS(.DGREAS) "RTN","DGRP1",28,0) . Q:$G(DGREAS)']"" "RTN","DGRP1",29,0) . W DGREAS "RTN","DGRP1",30,0) D GETNCAL ;Display name component, sex, and alias information "RTN","DGRP1",31,0) S Z=3,DGRPX=DGRP(0) W ! D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") "RTN","DGRP1",32,0) ;JAM - Patch DG*5.3*941 registration screen changes - remove addresses from screen and Cell/pager/email now in group 3 and Preferred Lang in group 4 "RTN","DGRP1",33,0) S Z=4,DGRPW=1.1 W ! D WW^DGRPV W " Cell Phone: " ;DG*5.3*941 "RTN","DGRP1",34,0) ; "RTN","DGRP1",35,0) ;* Output Cell phone "RTN","DGRP1",36,0) I $P(DGRP(.13),U,4)'="" W ?19,$P(DGRP(.13),U,4) "RTN","DGRP1",37,0) I $P(DGRP(.13),U,4)="" W ?19,"UNANSWERED" "RTN","DGRP1",38,0) ; "RTN","DGRP1",39,0) ; DG*5.3*985; JAM - Move pager up to same line across from cell phone "RTN","DGRP1",40,0) ;* Output Pager "RTN","DGRP1",41,0) W ?47,"Pager #: " "RTN","DGRP1",42,0) I $P(DGRP(.13),U,5)'="" W ?56,$P(DGRP(.13),U,5) "RTN","DGRP1",43,0) I $P(DGRP(.13),U,5)="" W ?56,"UNANSWERED" "RTN","DGRP1",44,0) ; "RTN","DGRP1",45,0) ;* Output Email Address "RTN","DGRP1",46,0) W !," Email Address: " "RTN","DGRP1",47,0) I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3) "RTN","DGRP1",48,0) I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED" "RTN","DGRP1",49,0) ; "RTN","DGRP1",50,0) LANGUAGE ;Get language data *///* "RTN","DGRP1",51,0) S DGLANGDT=9999999,(DGPRFLAN,DGLANG0,DGRP(1),DGRP(2))="" "RTN","DGRP1",52,0) S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1) "RTN","DGRP1",53,0) I DGLANGDT="" G L1 "RTN","DGRP1",54,0) S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0)) I DGLANGDA="" S DGRP(2)="" G L1 "RTN","DGRP1",55,0) S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2) "RTN","DGRP1",56,0) S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y "RTN","DGRP1",57,0) S DGRP(1)=DGLANGDT,DGRP(2)=DGPRFLAN "RTN","DGRP1",58,0) K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA "RTN","DGRP1",59,0) ; "RTN","DGRP1",60,0) L1 W ! S Z=5,DGRPW=1.1 D WW^DGRPV ;*///* ;DG*5.3*941 - remove extra line feed "RTN","DGRP1",61,0) ;W ?4,"Language Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1)) ;ARF-DG*5.3*1014 Preferred Language prompts "RTN","DGRP1",62,0) ;W !?4,"Preferred Language: ",$S(DGRP(2)="":"UNANSWERED",1:DGRP(2)) ; on to the same line "RTN","DGRP1",63,0) W " Pref Lang: ",$E($S(DGRP(2)="":"UNANSWERED",1:DGRP(2)),1,34)," Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1)) "RTN","DGRP1",64,0) ; "RTN","DGRP1",65,0) ; *** Additional displays added for Pre-Registration "RTN","DGRP1",66,0) I $G(DGPRFLG)=1 D "RTN","DGRP1",67,0) . W ! "RTN","DGRP1",68,0) . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1,ADDRDTTM "RTN","DGRP1",69,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",70,0) . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D") "RTN","DGRP1",71,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",72,0) . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D") "RTN","DGRP1",73,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",74,0) . S ADDRDTTM=$P($G(^DPT(DFN,.11)),"^",13) "RTN","DGRP1",75,0) . I ADDRDTTM'="" W !," [PERMANENT ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(ADDRDTTM,"5D") "RTN","DGRP1",76,0) . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D") "RTN","DGRP1",77,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",78,0) . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D") "RTN","DGRP1",79,0) . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration "RTN","DGRP1",80,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",81,0) .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2) "RTN","DGRP1",82,0) .. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D") "RTN","DGRP1",83,0) ; "RTN","DGRP1",84,0) W ! "RTN","DGRP1",85,0) G ^DGRPP "RTN","DGRP1",86,0) ; "RTN","DGRP1",87,0) GETNCAL ;Get name component values "RTN","DGRP1",88,0) N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW "RTN","DGRP1",89,0) S DGNC="Family^Given^Middle^Prefix^Suffix^Degree" "RTN","DGRP1",90,0) S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," "RTN","DGRP1",91,0) I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") "RTN","DGRP1",92,0) ;Get alias values "RTN","DGRP1",93,0) S DGA=0 F DGI=1:1:5 D Q:'$D(DGALIAS(DGI)) "RTN","DGRP1",94,0) A2 .S DGA=$O(^DPT(DFN,.01,DGA)) "RTN","DGRP1",95,0) .I 'DGA D:DGI=1 Q "RTN","DGRP1",96,0) ..S DGALIAS(DGI)="< No alias entries on file >" Q "RTN","DGRP1",97,0) .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q "RTN","DGRP1",98,0) .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2 "RTN","DGRP1",99,0) .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2) "RTN","DGRP1",100,0) .I $L(DGX) D "RTN","DGRP1",101,0) ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9) "RTN","DGRP1",102,0) ..; BAJ DG*5.2*700 retrofit 06/22/06 "RTN","DGRP1",103,0) ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19) "RTN","DGRP1",104,0) ..S $E(DGALIAS(DGI),20)=DGX Q "RTN","DGRP1",105,0) .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32) "RTN","DGRP1",106,0) .Q ; "RTN","DGRP1",107,0) ;Display name component, sex, multiple birth indicator and alias data "RTN","DGRP1",108,0) F DGI=1:1:6 D "RTN","DGRP1",109,0) .; DG*5.3*985; jam - Move fields 2 chars over to the left to align with fields above "RTN","DGRP1",110,0) .W !?3,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:28,1:27)) "RTN","DGRP1",111,0) .; BAJ DG*5.3*700 retrofit 06/22/06 "RTN","DGRP1",112,0) .; ob - 10/22/14 added "Birth" on the next line "RTN","DGRP1",113,0) .I DGI=1 S (Z,DGRPW)=1 W ?37,"Birth Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV ;DG*5.3*907 "RTN","DGRP1",114,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",115,0) .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: " "RTN","DGRP1",116,0) .I DGI>1 W ?47,$G(DGALIAS(DGI-1)) "RTN","DGRP1",117,0) ;*** display Self-Identified Gender Identity DG*5.3*907 "RTN","DGRP1",118,0) ;Get node with SIGI in it already done at EN+1 "RTN","DGRP1",119,0) W !?3,"Self-Identified Gender Identity: " "RTN","DGRP1",120,0) S X=$P(DGRP(.24),"^",4),Z=$S(X="M":"MALE",X="F":"FEMALE",X="TM":"TRANSMALE/TRANSMAN/FEMALE-TO-MALE",X="TF":"TRANSFEMALE/TRANSWOMAN/MALE-TO-FEMALE",X="O":"OTHER",X="N":"INDIVIDUAL CHOOSES NOT TO ANSWER",1:DGRPU) W Z ;D WW1^DGRPV "RTN","DGRP1",121,0) ; *** end of change "RTN","DGRP1",122,0) Q "RTN","DGRP1",123,0) GETSTAT(SSNV) ;get SSN VERIFIED STATUS DG*5.3*688 BAJ 11/22/2005 "RTN","DGRP1",124,0) N T "RTN","DGRP1",125,0) S T=$P($G(^DPT(DFN,"SSN")),"^",2) "RTN","DGRP1",126,0) S SSNV=$S(T=2:"INVALID",T=4:"VERIFIED",1:"") "RTN","DGRP1",127,0) Q "RTN","DGRP1",128,0) ; "RTN","DGRP1",129,0) SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC "RTN","DGRP1",130,0) S DGREAS=$P(DGRP("SSN"),U) "RTN","DGRP1",131,0) I $G(DGREAS)']"" Q "RTN","DGRP1",132,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",133,0) Q "RTN","DGRP1152A") 0^28^B63227684 "RTN","DGRP1152A",1,0) DGRP1152A ;ALB/LEG - REGISTRATION SCREEN 11.5.2/VERIFICATION INFORMATION ;JUN 08, 2020@23:00 "RTN","DGRP1152A",2,0) ;;5.3;Registration;**1014**;AUG 13, 1993;Build 42 "RTN","DGRP1152A",3,0) ;======================================================================================= "RTN","DGRP1152A",4,0) EN(DFN) ;Main entry point to invoke the DGEN CCP DETAIL list "RTN","DGRP1152A",5,0) ; Input -- DFN Patient IEN "RTN","DGRP1152A",6,0) D WAIT^DICD "RTN","DGRP1152A",7,0) D EN^VALM("DGEN CCP DETAIL") "RTN","DGRP1152A",8,0) N VALMHDR,VALMBCK,VALMSG,VALMCNT "RTN","DGRP1152A",9,0) Q "RTN","DGRP1152A",10,0) ; "RTN","DGRP1152A",11,0) HDR ;Header code "RTN","DGRP1152A",12,0) N DGDOB,DGPTYPE,DGSSNSTR,DGSSN "RTN","DGRP1152A",13,0) N DGBLANKS,DGMEMID,DGNAME,DGPREFNM,DGPTYPE,DGTMP "RTN","DGRP1152A",14,0) K VALMHDR "RTN","DGRP1152A",15,0) S DGDOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","DGRP1152A",16,0) S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1)) "RTN","DGRP1152A",17,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) "RTN","DGRP1152A",18,0) S DGSSN=$P($P(DGSSNSTR,";",2)," ",3) "RTN","DGRP1152A",19,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGRP1152A",20,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGRP1152A",21,0) S VALMHDR(1)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB "RTN","DGRP1152A",22,0) S VALMHDR(2)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE "RTN","DGRP1152A",23,0) S VALMHDR(3)=$J("",5)_"CCP Name"_$J("",20)_"Effective Date" "RTN","DGRP1152A",24,0) Q "RTN","DGRP1152A",25,0) ; "RTN","DGRP1152A",26,0) INIT ;Build patient Collateral screen "RTN","DGRP1152A",27,0) D CLEAN^VALM10 "RTN","DGRP1152A",28,0) D CLEAR^VALM1 "RTN","DGRP1152A",29,0) D TMP^DGRP1152U(.DGTMP) "RTN","DGRP1152A",30,0) Q "RTN","DGRP1152A",31,0) ; "RTN","DGRP1152A",32,0) EXIT ;Exit code "RTN","DGRP1152A",33,0) D CLEAN^VALM10 "RTN","DGRP1152A",34,0) D CLEAR^VALM1 "RTN","DGRP1152A",35,0) K DGTMP,^TMP("VALM DATA",$J) "RTN","DGRP1152A",36,0) Q "RTN","DGRP1152A",37,0) ; "RTN","DGRP1152A",38,0) PEXIT ;DGEN CCP MENU protocol exit code "RTN","DGRP1152A",39,0) ;Reset after page up or down "RTN","DGRP1152A",40,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGRP1152A",41,0) Q "RTN","DGRP1152A",42,0) ; "RTN","DGRP1152A",43,0) HELP ; Invoked from HELP CODE in List Template [DGEN CCP DETAIL] "RTN","DGRP1152A",44,0) S X="?" D DISP^XQORM1 "RTN","DGRP1152A",45,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGRP1152A",46,0) Q "RTN","DGRP1152A",47,0) ; "RTN","DGRP1152A",48,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGRP1152A",49,0) ; INPUT: DGACT = "A" - Add - DGEN CCP ADD protocol "RTN","DGRP1152A",50,0) ; = "E" - Edit - DGEN CCP EDIT protocol "RTN","DGRP1152A",51,0) ; = "R" - Remove - DGEN CCP REMOVE protocol "RTN","DGRP1152A",52,0) N DGX,DA,DIE,DIC,DIK,DIPA,DR "RTN","DGRP1152A",53,0) I $G(DGACT)="" G ACTQ "RTN","DGRP1152A",54,0) ; DGRPV represents the "VIEW" or "EDIT" status that is created in routine DGRPV "RTN","DGRP1152A",55,0) I $G(DGRPV) D FULL^VALM1 W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ "RTN","DGRP1152A",56,0) D FULL^VALM1 "RTN","DGRP1152A",57,0) I DGACT="A" D ADD,ACTQ Q "RTN","DGRP1152A",58,0) I DGACT="E" D EDIT,ACTQ Q "RTN","DGRP1152A",59,0) I DGACT="R" D REMOVE,ACTQ Q "RTN","DGRP1152A",60,0) Q "RTN","DGRP1152A",61,0) ; "RTN","DGRP1152A",62,0) ACTQ ; menu action exit point "RTN","DGRP1152A",63,0) S VALMBCK="R" "RTN","DGRP1152A",64,0) D TMP^DGRP1152U(.DGTMP) "RTN","DGRP1152A",65,0) Q "RTN","DGRP1152A",66,0) ; "RTN","DGRP1152A",67,0) ADD ; Add new CCP to #1910 sub-file "RTN","DGRP1152A",68,0) N DGCCPCD,DGEFFDT "RTN","DGRP1152A",69,0) I '$$ADASKCCP(.DGCCPCD) Q "RTN","DGRP1152A",70,0) I '$$ADASKEFDT(DGCCPCD,.DGEFFDT) Q "RTN","DGRP1152A",71,0) N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DGCCPNM "RTN","DGRP1152A",72,0) S DGCCPNM=$$EXTERNAL^DILFD(2.191,1,"",DGCCPCD) "RTN","DGRP1152A",73,0) S DIR(0)="Y",DIR("A")="Are you adding '"_DGCCPNM_"' as a new CCP",DIR("B")="NO" "RTN","DGRP1152A",74,0) D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!'Y Q "RTN","DGRP1152A",75,0) D SAVREC(DFN,DGCCPCD,DGEFFDT) ;saves new record "RTN","DGRP1152A",76,0) Q "RTN","DGRP1152A",77,0) ; "RTN","DGRP1152A",78,0) EDIT ;EDIT EXISTING CCP "RTN","DGRP1152A",79,0) N DGSEL,DGORIGIDX,DGORIGREC,DGCCPCD,DGEFFDT "RTN","DGRP1152A",80,0) S DGSEL=$$SELECT("E",.DGORIGIDX,.DGORIGREC) Q:'DGSEL "RTN","DGRP1152A",81,0) I '$$EDASKCCP(DGORIGIDX,.DGCCPCD) Q "RTN","DGRP1152A",82,0) I '$$EDASKEFDT(DGORIGIDX,DGORIGREC,DGCCPCD,.DGEFFDT) Q "RTN","DGRP1152A",83,0) D SAVREC(DFN,DGCCPCD,DGEFFDT) ;saves new record "RTN","DGRP1152A",84,0) D SAVENDT(DGORIGIDX) ; set END DATE into originally edited record "RTN","DGRP1152A",85,0) Q "RTN","DGRP1152A",86,0) ; "RTN","DGRP1152A",87,0) REMOVE ;REMOVE EXISTING CCP "RTN","DGRP1152A",88,0) N DGSEL,DGORIGIDX "RTN","DGRP1152A",89,0) S DGSEL=$$SELECT("R",.DGORIGIDX) Q:'DGSEL "RTN","DGRP1152A",90,0) N DIR,Y,DTOUT,DUOUT,DIROUT,DIRUT "RTN","DGRP1152A",91,0) S DIR(0)="Y",DIR("A")="Are you sure you want to remove this CCP entry",DIR("B")="NO" "RTN","DGRP1152A",92,0) D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!'Y Q "RTN","DGRP1152A",93,0) D SAVENDT(DGORIGIDX) ; set END DATE into removed record "RTN","DGRP1152A",94,0) Q "RTN","DGRP1152A",95,0) ; "RTN","DGRP1152A",96,0) SELECT(DGACT,DGORIGIDX,DGORIGREC) ; "RTN","DGRP1152A",97,0) ; Input: DGACT - "E"dit or "R"emove "RTN","DGRP1152A",98,0) ; Output: DGORIGIDX - (Pass by reference) The entry number of the selected CCP "RTN","DGRP1152A",99,0) ; DGORIGREC - (Pass by reference) The fields of the selected CCP "RTN","DGRP1152A",100,0) ; Returns the entry number selected "RTN","DGRP1152A",101,0) ; "RTN","DGRP1152A",102,0) N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,DGRECS,DGSEL "RTN","DGRP1152A",103,0) S DGRECS=$O(DGTMP("IDX",""),-1) "RTN","DGRP1152A",104,0) I 'DGRECS D Q 0 "RTN","DGRP1152A",105,0) . W !,"There are no entries to "_$S(DGACT="E":"edit.",1:"remove.") "RTN","DGRP1152A",106,0) . D PAUSE^VALM1 "RTN","DGRP1152A",107,0) S DIR(0)="NA^1:"_DGRECS_":0" "RTN","DGRP1152A",108,0) S DIR("A",1)="",DIR("A")="Select Entry (1-"_DGRECS_"): " D ^DIR K DIR "RTN","DGRP1152A",109,0) S DGSEL=Y "RTN","DGRP1152A",110,0) I $D(DTOUT)!$D(DUOUT) Q 0 "RTN","DGRP1152A",111,0) ; translate the display [num] to the ^DPT(DFN,5,IDX) "RTN","DGRP1152A",112,0) S DGORIGIDX=$O(DGTMP("IDX",DGSEL,"")),DGORIGREC=^DPT(DFN,5,DGORIGIDX,0) "RTN","DGRP1152A",113,0) Q DGSEL "RTN","DGRP1152A",114,0) ; "RTN","DGRP1152A",115,0) ADASKCCP(DGCCPCD) ; Prompts for CCP to be ADDed "RTN","DGRP1152A",116,0) ; Output: DGCCPCD - CCP Code to be added (Pass by Reference) "RTN","DGRP1152A",117,0) ; Returns - TRUE if valid CCP entered "RTN","DGRP1152A",118,0) ; "RTN","DGRP1152A",119,0) N DIR,DTOUT,DUOUT,DGGOOD,Y,X "RTN","DGRP1152A",120,0) L1 ; Tag to call for re-prompting "RTN","DGRP1152A",121,0) S DIR(0)="2.191,1,A,O^^" "RTN","DGRP1152A",122,0) S DIR("A")="Add CCP: " "RTN","DGRP1152A",123,0) D ^DIR "RTN","DGRP1152A",124,0) K DIR "RTN","DGRP1152A",125,0) I $D(DUOUT)!$D(DTOUT) Q 0 "RTN","DGRP1152A",126,0) I Y="" Q 0 "RTN","DGRP1152A",127,0) S DGCCPCD=Y "RTN","DGRP1152A",128,0) D CHKMULT1(DFN,DGCCPCD,.DGGOOD) "RTN","DGRP1152A",129,0) I 'DGGOOD W " ** Already have this CCP on file." G L1 "RTN","DGRP1152A",130,0) Q 1 "RTN","DGRP1152A",131,0) ; "RTN","DGRP1152A",132,0) EDASKCCP(DGORIGIDX,DGCCPCD) ; ASK EDIT CCP "RTN","DGRP1152A",133,0) ; Input: DGORIGIDX - Entry number of the CCP selected for edit "RTN","DGRP1152A",134,0) ; Output: DGCCPCD - The CCP Code that has been entered {Pass by Reference) "RTN","DGRP1152A",135,0) ; Returns: TRUE is edit of the CCP was successful "RTN","DGRP1152A",136,0) ; "RTN","DGRP1152A",137,0) N DIR,DGENTRY,DTOUT,DUOUT,DGGOOD,X,Y "RTN","DGRP1152A",138,0) L2 ; Tag to call for re-prompting "RTN","DGRP1152A",139,0) S DIR("B")=$$GET1^DIQ(2.191,DGORIGIDX_","_DFN_",",1) "RTN","DGRP1152A",140,0) S DIR(0)="2.191,1,A,r^^" "RTN","DGRP1152A",141,0) S DIR("A")="CCP: " "RTN","DGRP1152A",142,0) D ^DIR "RTN","DGRP1152A",143,0) K DIR "RTN","DGRP1152A",144,0) I $D(DUOUT)!$D(DTOUT) Q 0 "RTN","DGRP1152A",145,0) S DGCCPCD=Y "RTN","DGRP1152A",146,0) D CHKMULT1(DFN,DGCCPCD,.DGGOOD) "RTN","DGRP1152A",147,0) I 'DGGOOD W " ** Already have this CCP on file." G L2 "RTN","DGRP1152A",148,0) Q 1 "RTN","DGRP1152A",149,0) ; "RTN","DGRP1152A",150,0) ADASKEFDT(DGCCPCD,DGEFFDT) ; ASK ADD EFFECTIVE DATE AND IF VALID SAVE "RTN","DGRP1152A",151,0) ; Input: DGCCPCD - CCP Code associated with the effective date "RTN","DGRP1152A",152,0) ; Outut: DGEFFDT - Effective date entered for this CCP (Pass by Reference) "RTN","DGRP1152A",153,0) ; Returns TRUE if valid effective date added for this CCP "RTN","DGRP1152A",154,0) ; "RTN","DGRP1152A",155,0) N DIR,DTOUT,DUOUT,Y,X,DGGOOD,DGEXDT,X,Y "RTN","DGRP1152A",156,0) ; Sets DGEFFDT for the CCP to be added "RTN","DGRP1152A",157,0) ; "RTN","DGRP1152A",158,0) L3 ; Tag to call for re-prompting "RTN","DGRP1152A",159,0) S DIR(0)="2.191,2,A^^" "RTN","DGRP1152A",160,0) S DIR("A")="Enter EFFECTIVE DATE: " "RTN","DGRP1152A",161,0) S DIR("B")="T" "RTN","DGRP1152A",162,0) K X,Y "RTN","DGRP1152A",163,0) D ^DIR "RTN","DGRP1152A",164,0) I $D(DUOUT)!$D(DTOUT) Q 0 "RTN","DGRP1152A",165,0) I +Y<1 Q 0 "RTN","DGRP1152A",166,0) I Y,$L(Y(0))=10 S Y(0)=$P(Y(0)," ")_" 0"_$P(Y(0)," ",2) "RTN","DGRP1152A",167,0) S DGEFFDT=Y,DGEXDT=Y(0) "RTN","DGRP1152A",168,0) I '$L(DGEXDT) W:Y<0 " '"_X_"' is not a valid date." G L3 "RTN","DGRP1152A",169,0) D CHKMULT2(DFN,DGCCPCD,DGEFFDT,.DGGOOD) "RTN","DGRP1152A",170,0) I 'DGGOOD D MULTERR^DGRP1152U G L3 "RTN","DGRP1152A",171,0) Q 1 "RTN","DGRP1152A",172,0) ; "RTN","DGRP1152A",173,0) EDASKEFDT(DGORIGIDX,DGORIGREC,DGCCPCD,DGEFFDT) ; ASK EFFECTIVE DATE AND IF VALID SAVE "RTN","DGRP1152A",174,0) ; Input: DGORIGIDX - Entry number of the CCP selected for edit "RTN","DGRP1152A",175,0) ; DGORIGREC - The fields of the selected CCP (0 node) "RTN","DGRP1152A",176,0) ; DGCCPCD - CCP code for the associated Effective Date "RTN","DGRP1152A",177,0) ; Input: DGEFFDT - Updated Effective Date (Pass by reference) "RTN","DGRP1152A",178,0) ; Returns: TRUE is edit of Effective Date was successful "RTN","DGRP1152A",179,0) ; "RTN","DGRP1152A",180,0) N DIR,DTOUT,DUOUT,Y,X,DGGOOD,DGEXDT "RTN","DGRP1152A",181,0) L4 ; Tag to call for re-prompting "RTN","DGRP1152A",182,0) S DIR(0)="2.191,2,A,r^^" "RTN","DGRP1152A",183,0) S DIR("A")="Enter EFFECTIVE DATE: " "RTN","DGRP1152A",184,0) S DIR("B")=$$GET1^DIQ(2.191,DGORIGIDX_","_DFN_",",2) "RTN","DGRP1152A",185,0) K X,Y "RTN","DGRP1152A",186,0) D ^DIR "RTN","DGRP1152A",187,0) I $D(DUOUT)!$D(DTOUT) Q 0 "RTN","DGRP1152A",188,0) I +Y<1 Q 0 "RTN","DGRP1152A",189,0) I Y,$L(Y(0))=10 S Y(0)=$P(Y(0)," ")_" 0"_$P(Y(0)," ",2) "RTN","DGRP1152A",190,0) S DGEFFDT=Y,DGEXDT=Y(0) "RTN","DGRP1152A",191,0) I '$L(DGEXDT) W:Y<0 " '"_X_"' is not a valid date." G L4 "RTN","DGRP1152A",192,0) ; If the edited CCP/Date matches the original CCP/Date quit - no changes "RTN","DGRP1152A",193,0) I (DGCCPCD_"^"_DGEFFDT)=$P(DGORIGREC,U,2,3) Q 0 "RTN","DGRP1152A",194,0) D CHKMULT2(DFN,DGCCPCD,DGEFFDT,.DGGOOD) "RTN","DGRP1152A",195,0) I 'DGGOOD D MULTERR^DGRP1152U G L4 "RTN","DGRP1152A",196,0) Q 1 "RTN","DGRP1152A",197,0) ; "RTN","DGRP1152A",198,0) CHKMULT1(DFN,DGCCP,DGGOOD) ; checks for disallowed 'A' or 'I' multiples "RTN","DGRP1152A",199,0) ; Input: DFN "RTN","DGRP1152A",200,0) ; DGCCCP - The CPP code to check "RTN","DGRP1152A",201,0) ; Output: DGGOOD - (Pass by Reference) - TRUE if OK "RTN","DGRP1152A",202,0) ; "RTN","DGRP1152A",203,0) N DGI,DGTIDX,DGTREC,DGTCCP,DGTENDT "RTN","DGRP1152A",204,0) S DGGOOD=1 "RTN","DGRP1152A",205,0) I $L(DGCCP)'=1 Q "RTN","DGRP1152A",206,0) ; checks for duplicate CCP if "ART/IVF" or "NEWBORN" "RTN","DGRP1152A",207,0) I "AI"[DGCCP D Q "RTN","DGRP1152A",208,0) . S DGTIDX=0,DGI="" "RTN","DGRP1152A",209,0) . F S DGI=$O(DGTMP("IDX",DGI)) Q:'DGI S DGTIDX=$O(DGTMP("IDX",DGI,"")) Q:'DGTIDX I DGI'=$G(DGSEL) S DGTREC=$G(DGTMP("IDX",DGI,DGTIDX)) Q:DGTREC="" D Q:'DGGOOD "RTN","DGRP1152A",210,0) . . S DGTCCP=$P(DGTREC,U,2),DGTENDT=$P(DGTREC,U,4) "RTN","DGRP1152A",211,0) . . I DGTCCP=DGCCP,'DGTENDT S DGGOOD=0 "RTN","DGRP1152A",212,0) Q "RTN","DGRP1152A",213,0) ; "RTN","DGRP1152A",214,0) CHKMULT2(DFN,DGCCP,DGFMDT,DGGOOD) ; checks for disallowed same CCP with same EFFECTIVE DATE "RTN","DGRP1152A",215,0) ; Input: DFN "RTN","DGRP1152A",216,0) ; DGCCCP - The CPP code to check "RTN","DGRP1152A",217,0) ; DGFMDT - Effective Date to check (Fileman format) "RTN","DGRP1152A",218,0) ; Output: DGGOOD - (Pass by Reference) - TRUE if OK "RTN","DGRP1152A",219,0) ; "RTN","DGRP1152A",220,0) N DGTIDX,DGTCCP,DGTENDT,DGTREC "RTN","DGRP1152A",221,0) S DGGOOD=1 "RTN","DGRP1152A",222,0) I $L(DGCCP)'=1 Q "RTN","DGRP1152A",223,0) ; checks for duplicate date for same CCP "RTN","DGRP1152A",224,0) I "?CT"[DGCCP,DGFMDT D "RTN","DGRP1152A",225,0) . S DGTIDX="" "RTN","DGRP1152A",226,0) . F S DGTIDX=$O(DGTMP("EFDT",DGFMDT,DGTIDX)) Q:'DGTIDX D Q:'DGGOOD "RTN","DGRP1152A",227,0) . . S DGTREC=DGTMP("EFDT",DGFMDT,DGTIDX) "RTN","DGRP1152A",228,0) . . S DGTCCP=$P(DGTREC,U,2) "RTN","DGRP1152A",229,0) . . S DGTENDT=$P(DGTREC,U,4) "RTN","DGRP1152A",230,0) . . I DGTCCP=DGCCP,'DGTENDT S DGGOOD=0 "RTN","DGRP1152A",231,0) Q "RTN","DGRP1152A",232,0) ; "RTN","DGRP1152A",233,0) SAVREC(DFN,DGCCPCD,DGEFFDT) ;save newly ADDed or EDITed record "RTN","DGRP1152A",234,0) ; "RTN","DGRP1152A",235,0) ; If this combination of Code and Effective date already exists in an End-Dated record, it will be reactivated "RTN","DGRP1152A",236,0) I $$SAVEXIST(DFN,DGCCPCD,DGEFFDT) Q "RTN","DGRP1152A",237,0) ; Otherwise, save a new record "RTN","DGRP1152A",238,0) N %,Y,X,DGERR,DGIENS,DGFDA "RTN","DGRP1152A",239,0) S DGERR=0 "RTN","DGRP1152A",240,0) S DGIENS=DFN_"," "RTN","DGRP1152A",241,0) S DGIENS="+1,"_DGIENS "RTN","DGRP1152A",242,0) D NOW^%DTC "RTN","DGRP1152A",243,0) S DGFDA(2.191,DGIENS,.01)=% "RTN","DGRP1152A",244,0) S DGFDA(2.191,DGIENS,1)=DGCCPCD "RTN","DGRP1152A",245,0) S DGFDA(2.191,DGIENS,2)=DGEFFDT "RTN","DGRP1152A",246,0) D UPDATE^DIE("","DGFDA","","DGERR") "RTN","DGRP1152A",247,0) I DGERR W " **UNABLE TO SAVE**" "RTN","DGRP1152A",248,0) Q "RTN","DGRP1152A",249,0) ; "RTN","DGRP1152A",250,0) SAVEXIST(DFN,DGCCP,DGFMDT) ; Check for an existing CCP record to be saved "RTN","DGRP1152A",251,0) ; Checks for a matching CCP/EFFECTIVE DATE record among the End Dated CCPs. If found, reuse it (Remove the end date) "RTN","DGRP1152A",252,0) ; Inputs: DFN - Patient DFN "RTN","DGRP1152A",253,0) ; DGCCP - CCP Code "RTN","DGRP1152A",254,0) ; DGFMDT - CCP Effective date "RTN","DGRP1152A",255,0) ; Returns: The Entry number of the reactivated CCP if found or NULL "RTN","DGRP1152A",256,0) ; "RTN","DGRP1152A",257,0) N DGTIDX,DGTCCP,DGTENDT,DGTREC,DGEXIST,DGERR,DGFDA "RTN","DGRP1152A",258,0) I $L(DGCCP)'=1!('DGFMDT) Q "" "RTN","DGRP1152A",259,0) ; For the effective date, check for a matching CCP - (the record should be end dated since there cannot be duplicate effective dates for an active CCP) "RTN","DGRP1152A",260,0) S (DGEXIST,DGTIDX)="" "RTN","DGRP1152A",261,0) F S DGTIDX=$O(DGTMP("EFDT",DGFMDT,DGTIDX)) Q:'DGTIDX D Q:DGEXIST "RTN","DGRP1152A",262,0) . S DGTREC=DGTMP("EFDT",DGFMDT,DGTIDX) "RTN","DGRP1152A",263,0) . ; Don't check archived records "RTN","DGRP1152A",264,0) . I $P(DGTREC,U,5) Q "RTN","DGRP1152A",265,0) . S DGTCCP=$P(DGTREC,U,2) "RTN","DGRP1152A",266,0) . S DGTENDT=$P(DGTREC,U,4) "RTN","DGRP1152A",267,0) . I DGTCCP=DGCCP,DGTENDT'="" D "RTN","DGRP1152A",268,0) . . ; Matching record found "RTN","DGRP1152A",269,0) . . S DGEXIST=DGTIDX "RTN","DGRP1152A",270,0) . . ; Set the LAST DATE UPDATED and Clear the End Date "RTN","DGRP1152A",271,0) . . S DGFDA(2.191,DGTIDX_","_DFN_",",.01)=$$NOW^XLFDT() "RTN","DGRP1152A",272,0) . . S DGFDA(2.191,DGTIDX_","_DFN_",",3)="" "RTN","DGRP1152A",273,0) . . D FILE^DIE("","DGFDA","DGERR") "RTN","DGRP1152A",274,0) Q DGEXIST "RTN","DGRP1152A",275,0) ; "RTN","DGRP1152A",276,0) SAVENDT(DGSIDX) ;save END DATE in old rec "RTN","DGRP1152A",277,0) ; Input: DGSIDX - Entry number of the CCP to set End Date "RTN","DGRP1152A",278,0) ; "RTN","DGRP1152A",279,0) N DGERR,DGFDA,X "RTN","DGRP1152A",280,0) ; CCP LAST UPDATED DATE "RTN","DGRP1152A",281,0) S DGFDA(2.191,DGSIDX_","_DFN_",",.01)=$$NOW^XLFDT() "RTN","DGRP1152A",282,0) ; END DATE "RTN","DGRP1152A",283,0) D NOW^%DTC "RTN","DGRP1152A",284,0) S DGFDA(2.191,DGSIDX_","_DFN_",",3)=X "RTN","DGRP1152A",285,0) D FILE^DIE("","DGFDA","DGERR") "RTN","DGRP1152A",286,0) Q "RTN","DGRP1152U") 0^32^B20019030 "RTN","DGRP1152U",1,0) DGRP1152U ;ALB/LEG - REGISTRATION SCREEN 11.5.2 (UTILS)/VERIFICATION INFORMATION ;JUN 08, 2020@23:00 "RTN","DGRP1152U",2,0) ;;5.3;Registration;**1014**;AUG 13, 1993;Build 42 "RTN","DGRP1152U",3,0) ;======================================================================================= "RTN","DGRP1152U",4,0) ; EXTRA PROCESSING FUNCTIONS "RTN","DGRP1152U",5,0) Q "RTN","DGRP1152U",6,0) ; "RTN","DGRP1152U",7,0) TMP(DGTMP) ; constructs DGTMP data from Patient CCP data "RTN","DGRP1152U",8,0) N DGFIDX,DGEFFDT,DGREC "RTN","DGRP1152U",9,0) D CLEAN^VALM10 "RTN","DGRP1152U",10,0) ; DGTMP is NEWd in DGRPU1152A "RTN","DGRP1152U",11,0) K DGTMP "RTN","DGRP1152U",12,0) M DGTMP(DFN,5)=^DPT(DFN,5) "RTN","DGRP1152U",13,0) S DGFIDX=0 "RTN","DGRP1152U",14,0) F S DGFIDX=$O(DGTMP(DFN,5,DGFIDX)) Q:'DGFIDX S DGREC=$G(DGTMP(DFN,5,DGFIDX,0)) D "RTN","DGRP1152U",15,0) . S DGEFFDT=$P(DGREC,U,3) "RTN","DGRP1152U",16,0) . S DGTMP("EFDT",DGEFFDT,DGFIDX)=DGREC "RTN","DGRP1152U",17,0) D GETCCP "RTN","DGRP1152U",18,0) Q "RTN","DGRP1152U",19,0) ; "RTN","DGRP1152U",20,0) GETCCP ; collects all CCP recs; sorts decreasing by EFFDT "RTN","DGRP1152U",21,0) N DGBLANKS,DGEFFDT,DGEFFDTO,DGENDT,DGFIDX,DGLINE,DGLINECNT,DGREC,DGRECNO,DGCCPCD,DGRECCCP "RTN","DGRP1152U",22,0) N DGRECCCPCD,DGRECCCPNM,DGRECEFDT,DGRECEFDTO,DGRECODT,DGLINEVAR "RTN","DGRP1152U",23,0) S VALMCNT=0,DGLINECNT=0,DGLINE=0,DGBLANKS="",$P(DGBLANKS," ",40)="" "RTN","DGRP1152U",24,0) ; "RTN","DGRP1152U",25,0) ; BY EFFDT --- DGTMP("EFDT",EFFDT,DGFIDX)=DGREC sort via most recent EFFECTIVE DATE in DECREASING ORDER "RTN","DGRP1152U",26,0) S DGEFFDT="" "RTN","DGRP1152U",27,0) F S DGEFFDT=$O(DGTMP("EFDT",DGEFFDT),-1) Q:DGEFFDT="" D "RTN","DGRP1152U",28,0) . S DGFIDX="" F S DGFIDX=$O(DGTMP("EFDT",DGEFFDT,DGFIDX)) Q:DGFIDX="" D "RTN","DGRP1152U",29,0) . . S DGREC=DGTMP("EFDT",DGEFFDT,DGFIDX) "RTN","DGRP1152U",30,0) . . S DGENDT=$P(DGREC,U,4) "RTN","DGRP1152U",31,0) . . I 'DGENDT D SETREC "RTN","DGRP1152U",32,0) ;NOTE: for VALM* rtns processing, "VALMCNT" represents total lines written, "RTN","DGRP1152U",33,0) S VALMCNT=VALMCNT*2 ; thus, a 2 line display==>"*2", while a 3 line display==>"*3" "RTN","DGRP1152U",34,0) Q "RTN","DGRP1152U",35,0) SETREC ; sets ListMan Display record "RTN","DGRP1152U",36,0) ; for Phase I Line 1 data "RTN","DGRP1152U",37,0) S DGLINEVAR="" "RTN","DGRP1152U",38,0) S DGRECCCPCD=$P(DGREC,U,2) "RTN","DGRP1152U",39,0) S DGRECCCPNM=$E($$EXTERNAL^DILFD(2.191,1,"",DGRECCCPCD)_DGBLANKS,1,30) "RTN","DGRP1152U",40,0) S DGRECEFDT=$P(DGREC,U,3) S DGRECEFDTO=$$UP^XLFSTR($$FMTE^XLFDT($E(DGRECEFDT,1,12),1)) "RTN","DGRP1152U",41,0) ; strip the space between the day and year "RTN","DGRP1152U",42,0) S DGRECODT=$P(DGRECEFDTO," ",1,2)_$P(DGRECEFDTO," ",3) "RTN","DGRP1152U",43,0) S VALMCNT=VALMCNT+1 "RTN","DGRP1152U",44,0) S DGRECNO=$J($E("["_VALMCNT_"] ",1,5),5) "RTN","DGRP1152U",45,0) S DGLINEVAR=$$SETFLD^VALM1(DGRECNO,DGLINEVAR,"NO") "RTN","DGRP1152U",46,0) S DGLINEVAR=$$SETFLD^VALM1(DGRECCCPNM,DGLINEVAR,"CCPNAME") "RTN","DGRP1152U",47,0) S DGLINEVAR=$$SETFLD^VALM1(DGRECODT,DGLINEVAR,"EFFDATE") "RTN","DGRP1152U",48,0) S DGLINECNT=DGLINECNT+1 "RTN","DGRP1152U",49,0) D SET^VALM10(DGLINECNT,DGLINEVAR,VALMCNT) "RTN","DGRP1152U",50,0) S DGLINECNT=DGLINECNT+1 "RTN","DGRP1152U",51,0) S DGLINEVAR="" ; for Phase II Line 2 data space holder "RTN","DGRP1152U",52,0) D SET^VALM10(DGLINECNT,DGLINEVAR) "RTN","DGRP1152U",53,0) S DGTMP("IDX",VALMCNT,DGFIDX)=DGREC "RTN","DGRP1152U",54,0) Q "RTN","DGRP1152U",55,0) ; "RTN","DGRP1152U",56,0) ARCHALL(DFN) ; ARCHIVE CCP entries "RTN","DGRP1152U",57,0) ; Called from KILL logic of Xref in .361 (PRIMARY ELIGIBILITY) field "RTN","DGRP1152U",58,0) ; and .01 (ELIGIBILITY CODE) field of the PATIENT ELIGIBILITIES subfile "RTN","DGRP1152U",59,0) ; when the COLLATERAL OF VET eligibility code is deleted "RTN","DGRP1152U",60,0) ; Also invoked from Z11 logic when ES is removing the COV eligibility "RTN","DGRP1152U",61,0) ; For CCPs not already archived: "RTN","DGRP1152U",62,0) ; - Active CCPs are end dated "RTN","DGRP1152U",63,0) ; - Achive field set "RTN","DGRP1152U",64,0) ; "RTN","DGRP1152U",65,0) N DGCCP,DGFDA,DGERR,X,Y "RTN","DGRP1152U",66,0) S DGCCP=0 F S DGCCP=$O(^DPT(DFN,5,DGCCP)) Q:'DGCCP I $G(^(DGCCP,0))'="" D "RTN","DGRP1152U",67,0) . ; Quit if ARCHIVE flag already set "RTN","DGRP1152U",68,0) . I $$GET1^DIQ(2.191,DGCCP_","_DFN_",",4,"I")=1 Q "RTN","DGRP1152U",69,0) . ; Set the End Date if not already set "RTN","DGRP1152U",70,0) . I $$GET1^DIQ(2.191,DGCCP_","_DFN_",",3)="" D SAVENDT^DGRP1152A(DGCCP) "RTN","DGRP1152U",71,0) . ; Set the ARCHIVE field to "1" "RTN","DGRP1152U",72,0) . S DGFDA(2.191,DGCCP_","_DFN_",",4)=1 "RTN","DGRP1152U",73,0) . ; CCP LAST UPDATED DATE "RTN","DGRP1152U",74,0) . S DGFDA(2.191,DGCCP_","_DFN_",",.01)=$$NOW^XLFDT() "RTN","DGRP1152U",75,0) . D FILE^DIE("","DGFDA","DGERR") "RTN","DGRP1152U",76,0) Q "RTN","DGRP1152U",77,0) ; "RTN","DGRP1152U",78,0) MULTERR ; Invoked from ^DGRP1152A when adding/editing the Effective Date for a CCP "RTN","DGRP1152U",79,0) D EN^DDIOL("Effective Date for this CCP entry must be unique. The Effective Date entered is the same date as a previous entry for a particular CCP.") "RTN","DGRP1152U",80,0) ; "RTN","DGRP1152U",81,0) Q "RTN","DGRP1152U",82,0) REMOVE(DFN) ; Invoked from ECDS^DGLOCK1 (Input Transform logic for Primary Eligibility field .361) "RTN","DGRP1152U",83,0) ; This is called when COLLATERAL OF VET is being replaced "RTN","DGRP1152U",84,0) ; - Remove all CCPs to a temp global and remove them from the Patient record. "RTN","DGRP1152U",85,0) ; New X and Y so input transform vars are not overwritten "RTN","DGRP1152U",86,0) K ^TMP("DGCCP",$J,DFN) "RTN","DGRP1152U",87,0) N DIK,DA,Y,X "RTN","DGRP1152U",88,0) S ^TMP("DGCCP",$J,DFN)="" "RTN","DGRP1152U",89,0) Q:'$D(^DPT(DFN,5)) "RTN","DGRP1152U",90,0) ; Move everything out and ^DIK the CCPs from the patient file "RTN","DGRP1152U",91,0) M ^TMP("DGCCP",$J,DFN,5)=^DPT(DFN,5) "RTN","DGRP1152U",92,0) S DA(1)=DFN "RTN","DGRP1152U",93,0) S DIK="^DPT("_DFN_",5," "RTN","DGRP1152U",94,0) S DA=0 F S DA=$O(^DPT(DFN,5,DA)) Q:'DA D "RTN","DGRP1152U",95,0) .D ^DIK "RTN","DGRP1152U",96,0) S ^DPT(DFN,5,0)="" "RTN","DGRP1152U",97,0) Q "RTN","DGRP1152U",98,0) ; "RTN","DGRP1152U",99,0) RESTORE(DFN) ; Invoked from "AEL" Cross-reference, Set logic, of Primary Eligibility field .361 "RTN","DGRP1152U",100,0) ; - If the ^TMP("DGCCP",$J,DFN) global (see REMOVE tag) does not exist, then quit. "RTN","DGRP1152U",101,0) ; - Otherwise, move the CCPs in ^TMP back into the patient record. "RTN","DGRP1152U",102,0) ; and if COV is no longer in .361 field, add it into the PATIENT ELIGIBILIITIES subfile .0361 "RTN","DGRP1152U",103,0) ; The result is that COV is moved from PRIMARY to the subfile and the CCPs are intact "RTN","DGRP1152U",104,0) ; (COV cannnot be deleted if there are active CCPs but it can be replaced with another eligibility and moved to the subfile.) "RTN","DGRP1152U",105,0) ; NEW X and Y so xref vars aren't overwritten "RTN","DGRP1152U",106,0) N DGZ,Y,X,DGERR,DGIENS,DGFDA,DGDATA,DGFDAIEN,DGNEWIEN "RTN","DGRP1152U",107,0) I '$D(^TMP("DGCCP",$J,DFN)) Q "RTN","DGRP1152U",108,0) S DGZ=0 F S DGZ=$O(^TMP("DGCCP",$J,DFN,5,DGZ)) Q:'DGZ D "RTN","DGRP1152U",109,0) . S DGERR=0 "RTN","DGRP1152U",110,0) . S DGIENS=DFN_"," "RTN","DGRP1152U",111,0) . S DGIENS="+1,"_DGIENS "RTN","DGRP1152U",112,0) . S DGFDA(2.191,DGIENS,.01)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",1) "RTN","DGRP1152U",113,0) . S DGFDA(2.191,DGIENS,1)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",2) "RTN","DGRP1152U",114,0) . S DGFDA(2.191,DGIENS,2)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",3) "RTN","DGRP1152U",115,0) . S DGFDA(2.191,DGIENS,3)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",4) "RTN","DGRP1152U",116,0) . S DGFDA(2.191,DGIENS,4)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",5) "RTN","DGRP1152U",117,0) . D UPDATE^DIE("","DGFDA","","DGERR") "RTN","DGRP1152U",118,0) . K DGFDA "RTN","DGRP1152U",119,0) K ^TMP("DGCCP",$J,DFN) "RTN","DGRP1152U",120,0) ; If COV is still in .361, nothing changed, quit "RTN","DGRP1152U",121,0) I $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET." Q "RTN","DGRP1152U",122,0) ; "RTN","DGRP1152U",123,0) ; Otherwise, COV has been replaced with another eligibility - restore COV into the Eligibilities subfile .0361 "RTN","DGRP1152U",124,0) N DGDATA,DGFDAIEN,DGNEWIEN "RTN","DGRP1152U",125,0) S DGNEWIEN="+1,"_DFN_"," "RTN","DGRP1152U",126,0) S DGDATA(2.0361,DGNEWIEN,.01)=$$FIND1^DIC(8,"","B","COLLATERAL") "RTN","DGRP1152U",127,0) S DGFDAIEN(1)=$$FIND1^DIC(8,"","B","COLLATERAL") "RTN","DGRP1152U",128,0) D UPDATE^DIE("","DGDATA","DGFDAIEN","DGERR") "RTN","DGRP1152U",129,0) Q "RTN","DGRP11A") 0^35^B9418502 "RTN","DGRP11A",1,0) DGRP11A ;ALB/LEG - REGISTRATION SCREEN 11.5/CAREGIVER ;Apr 05, 2020@16:48 "RTN","DGRP11A",2,0) ;;5.3;Registration;**997,1014**;AUG 13, 1993;Build 42 "RTN","DGRP11A",3,0) ; "RTN","DGRP11A",4,0) N DGCGTCNT,Z,DGRPS,DGRPW,DGCGRET,DGCOLL "RTN","DGRP11A",5,0) S DGRPS=11.5 D H^DGRPU "RTN","DGRP11A",6,0) ; call tag WW2 to display Group 1 to be selectable "RTN","DGRP11A",7,0) S (DGRPW,Z)=1 D WW2^DGRPV "RTN","DGRP11A",8,0) W " Caregiver Status Data: " "RTN","DGRP11A",9,0) ; note: see GET^VAFCREL definition details at bottom of routine "RTN","DGRP11A",10,0) D GET^VAFCREL(.DGCGRET,DFN) "RTN","DGRP11A",11,0) I +DGCGRET(0)=-1 W "(WARNING: MPI CONNECTION NOT AVAILABLE - Systems will",!,"be updated automatically when MPI is available. No further action needed to",!,"update.)" ;G CONT "RTN","DGRP11A",12,0) I +DGCGRET(0)'=-1 D ; Get the number of Caregiver records in the array "RTN","DGRP11A",13,0) . S DGCGTCNT=$$MPICGCNT(.DGCGRET) "RTN","DGRP11A",14,0) . W "(",DGCGTCNT_$S(DGCGTCNT=1:" entry",1:" entries"),")" "RTN","DGRP11A",15,0) ; "RTN","DGRP11A",16,0) ;LEG; DG*5.3*1014; adding CCP Group 2 "RTN","DGRP11A",17,0) ; Get flag for patient collateral eligibility "RTN","DGRP11A",18,0) S DGCOLL=$$CHKCOLL(DFN) "RTN","DGRP11A",19,0) ; DGRPVV is a globally used array for screen layout of groups as editable/not-editable "RTN","DGRP11A",20,0) ; Set Group 2 of screen 11.5 as <2> or [2] based on collateral flag "RTN","DGRP11A",21,0) S $E(DGRPVV(11.5),2)='DGCOLL "RTN","DGRP11A",22,0) S DGRPW=1,Z=2 "RTN","DGRP11A",23,0) ; If collateral flag is TRUE, call tag WW2 to display Group [2] (always selectable) "RTN","DGRP11A",24,0) I DGCOLL D WW2^DGRPV "RTN","DGRP11A",25,0) ; otherwise call WW which will show Group as <2> "RTN","DGRP11A",26,0) I 'DGCOLL D WW^DGRPV "RTN","DGRP11A",27,0) W " Community Care Program (CCP) Collateral Data " "RTN","DGRP11A",28,0) ; "RTN","DGRP11A",29,0) G ^DGRPP "RTN","DGRP11A",30,0) Q "RTN","DGRP11A",31,0) CHKCOLL(DFN) ; If patient Eligibility Codes include a COLLATERAL OF VET then return TRUE "RTN","DGRP11A",32,0) N DGI "RTN","DGRP11A",33,0) S DGI=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") "RTN","DGRP11A",34,0) I $D(^DPT("AEL",DFN,DGI)) Q 1 "RTN","DGRP11A",35,0) Q 0 "RTN","DGRP11A",36,0) MPICGCNT(DGCGRET) ; Return the number of CAREGIVER entries from MPI DGCGRET "RTN","DGRP11A",37,0) ; Input: DGCGRET - array of ALL returned records from MPI "RTN","DGRP11A",38,0) ; Return: DGCGNUM - number of CAREGIVER entries from MPI DGCGRET "RTN","DGRP11A",39,0) N DGCGNUM,DGI "RTN","DGRP11A",40,0) S DGCGNUM=0 "RTN","DGRP11A",41,0) I +DGCGRET(0)=-1 Q -1 ;MPI error detection "RTN","DGRP11A",42,0) F DGI=1:1 Q:'$D(DGCGRET(DGI)) I "^CGG^CGP^CGS^"[(U_$P(DGCGRET(DGI),U,2)_U) D "RTN","DGRP11A",43,0) . ; Filter for RelationshipRoleCode = "FROM" "RTN","DGRP11A",44,0) . Q:$P(DGCGRET(DGI),U,4)'="FROM" "RTN","DGRP11A",45,0) . S DGCGNUM=DGCGNUM+1 "RTN","DGRP11A",46,0) Q DGCGNUM "RTN","DGRP11A",47,0) ; "RTN","DGRP11A",48,0) MPIGETCG(DGCGRET,DGCG,DGCGTCNT) ;Get array of CAREGIVER entries from MPI DGCGRET "RTN","DGRP11A",49,0) ; Inputs: "RTN","DGRP11A",50,0) ; DGCGRET - array of ALL returned records from MPI "RTN","DGRP11A",51,0) ; Ouputs: "RTN","DGRP11A",52,0) ; DGCG - array of only Caregiver records from MPI "RTN","DGRP11A",53,0) ; DGCGTCNT - total number of only Caregiver recs "RTN","DGRP11A",54,0) N DGI,DGJ,DGN,DGCGARR "RTN","DGRP11A",55,0) S DGCGTCNT=0 "RTN","DGRP11A",56,0) I +DGCGRET(0)=-1 Q -1 ;MPI error detection "RTN","DGRP11A",57,0) ; Only want records that are RelationshipType for Caregiver "RTN","DGRP11A",58,0) F DGI=1:1 Q:'$D(DGCGRET(DGI)) I "^CGG^CGP^CGS^"[(U_$P(DGCGRET(DGI),U,2)_U) D "RTN","DGRP11A",59,0) . ; Filter for RelationshipRoleCode = "FROM" "RTN","DGRP11A",60,0) . Q:$P(DGCGRET(DGI),U,4)'="FROM" "RTN","DGRP11A",61,0) . S DGCGTCNT=DGCGTCNT+1 "RTN","DGRP11A",62,0) . S DGCGARR(DGCGTCNT)=DGCGRET(DGI) "RTN","DGRP11A",63,0) S DGCGARR(0)=DGCGRET(0) "RTN","DGRP11A",64,0) I $D(DGCGARR(1)) D MPISORT(.DGCGARR,.DGCG,7) "RTN","DGRP11A",65,0) Q "RTN","DGRP11A",66,0) MPISORT(DGCGARRIN,DGCGARROUT,DGCGSORTPC) ; sorts the input array by data piece; default is 7=STATUS DATE, descending "RTN","DGRP11A",67,0) ; DGCGARRIN - Input array of Caregiver data records to be sorted by Status Date "RTN","DGRP11A",68,0) ; DGCGARROUT - Output array of Caregiver data records sorted by Status Date "RTN","DGRP11A",69,0) ; DGCGSORTPC - Piece number of array data to sort by (Status Date) "RTN","DGRP11A",70,0) ; DGCGARRTMP - Intermediate array of Caregiver data being sorted by Status Date "RTN","DGRP11A",71,0) N DGCGARRTMP,DGCGCNT,DGI,DGL1,DGL2,DGX,DGCGDATAPC "RTN","DGRP11A",72,0) I '$D(DGCGSORTPC) S DGCGSORTPC=7 "RTN","DGRP11A",73,0) ; ICN ^ RELTYP ^ RELTYPDISP ^ RCODE ^ RSTATUS ^ RSTATUSDISP ^ RSTATDATE ^ CGSPONSNAM "RTN","DGRP11A",74,0) S DGCGARROUT(0)=DGCGARRIN(0) "RTN","DGRP11A",75,0) F DGI=1:1:DGCGTCNT S DGX=DGCGARRIN(DGI),DGCGDATAPC=$P(DGX,U,DGCGSORTPC),DGCGARRTMP(DGCGDATAPC,DGI)=DGX "RTN","DGRP11A",76,0) S DGL1="",DGCGCNT=0 "RTN","DGRP11A",77,0) F S DGL1=$O(DGCGARRTMP(DGL1),-1),DGL2="" Q:DGL1="" D "RTN","DGRP11A",78,0) . F S DGL2=$O(DGCGARRTMP(DGL1,DGL2),-1) Q:DGL2="" D "RTN","DGRP11A",79,0) .. S DGCGCNT=DGCGCNT+1,DGCGARROUT(DGCGCNT)=DGCGARRTMP(DGL1,DGL2) "RTN","DGRP11A",80,0) Q "RTN","DGRP11A",81,0) ; ======GET^VAFCREL definition details================================================================= "RTN","DGRP11A",82,0) ; Call API: GET^VAFCREL(.RETURN,DFN) to get patient Relationship data in RETURN array "RTN","DGRP11A",83,0) ; Format of array: "RTN","DGRP11A",84,0) ;The RETURN(0) array will always be returned. "RTN","DGRP11A",85,0) ;RETURN(0) - If relationships found for a given DFN, it will contain 1 in the 1st piece "RTN","DGRP11A",86,0) ; and "RELATIONSHIPS RETURNED" text in 2nd piece "RTN","DGRP11A",87,0) ; - If no relationships are found for a given DFN, it will contain 0 in the 1st piece "RTN","DGRP11A",88,0) ; and "NO RELATIONSHIPS RETURNED" text in 2nd piece "RTN","DGRP11A",89,0) ; - If error condition, it will contain -1 in the 1st piece and error message text in 2nd piece "RTN","DGRP11A",90,0) ; RETURN(0)="1^RELATIONSHIPS RETURNED" "RTN","DGRP11A",91,0) ; RETURN(0)="0^NO RELATIONSHIPS RETURNED" "RTN","DGRP11A",92,0) ; RETURN(0)="-1^ERROR:Timeout Limit Reached" *** note: timeout limit is 10 seconds Possible error conditions "RTN","DGRP11A",93,0) ; RETURN(0)="-1^ERROR:Internal Error" "RTN","DGRP11A",94,0) ; RETURN(0)="-1^ERROR:Unknown ID" "RTN","DGRP11A",95,0) ; RETURN(1-n)- If relationships are found for a given DFN, it will contain the list of Relationships "RTN","DGRP11A",96,0) ; in the following format: "RTN","DGRP11A",97,0) ; ICN^RelationshipType^RelationshipTypeDisplay^RelationshipRoleCode^RelationshipStatus "RTN","DGRP11A",98,0) ; ^RelationshipStatusDisplay^RelationshipStatusChangeDate^AssignedName "RTN","DGRP11A",99,0) ; RETURN(1)="1002345678V123456^CGP^CAREGIVER: PRIMARY^QUAL^ACTIVE^APPROVED^20200220^Jones, William M" "RTN","DGRP11A",100,0) ; RETURN(2)="1901234590V098766^CGS^CAREGIVER: SECONDARY^QUAL^ACTIVE^APPROVED^20200220^Jones, Donna" "RTN","DGRP11A",101,0) ; RETURN(3)="1002345678V123456^SONC^SON^QUAL^ACTIVE^ACTIVE^20200220^Jones, Mike" "RTN","DGRP11A",102,0) ; RETURN(4)="1901234590V098766^CGP^CAREGIVER: PRIMARY^QUAL^TERMINATED^BENEFIT END DATE^20170220^Jones, Donna" "RTN","DGRP11A",103,0) ; RETURN(5)="1007879802V000909^SPS^SPOUSE^QUAL^ACTIVE^ACTIVE^20120301^Jones, Donna" "RTN","DGRP11A",104,0) ; RETURN(6)="1089022222V123423^BRO^BROTHER^QUAL^ACTIVE^ACTIVE^20111202^Jones, Joseph" "RTN","DGRP11A",105,0) ; "RTN","DGRP11B") 0^10^B13606123 "RTN","DGRP11B",1,0) DGRP11B ;ALB/JAM,ARF - REGISTRATION SCREEN 11.5.1/VERIFICATION INFORMATION ;Mar 09, 2020@12:34 "RTN","DGRP11B",2,0) ;;5.3;Registration;**997,1014**;AUG 13, 1993;Build 42 "RTN","DGRP11B",3,0) ;IA's: "RTN","DGRP11B",4,0) ; GETDFN^MPIF001 - Supported #2701 ;retrieves DFN from ICN via MPI "RTN","DGRP11B",5,0) ; "RTN","DGRP11B",6,0) EN(DFN) ;Main entry point to invoke the DGEN CGP DETAIL list "RTN","DGRP11B",7,0) ; Input -- DFN Patient IEN "RTN","DGRP11B",8,0) ; "RTN","DGRP11B",9,0) D WAIT^DICD "RTN","DGRP11B",10,0) D EN^VALM("DGEN CGP DETAIL") "RTN","DGRP11B",11,0) Q "RTN","DGRP11B",12,0) ; "RTN","DGRP11B",13,0) HDR ;Header code "RTN","DGRP11B",14,0) N X "RTN","DGRP11B",15,0) D LISTHDR^DGRPU(1) ;DG*5.3*1014 - ARF - sets patient data in the 1st and 2nd entries in VALMHDR array "RTN","DGRP11B",16,0) ;D PID^VADPT ;DG*5.3*1014 begin - comment previous code "RTN","DGRP11B",17,0) ;S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGRP11B",18,0) ;S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")" "RTN","DGRP11B",19,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGRP11B",20,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGRP11B",21,0) ;S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80) ;DG*5.3*1014 end - comment previous code "RTN","DGRP11B",22,0) Q "RTN","DGRP11B",23,0) ; "RTN","DGRP11B",24,0) INIT ;Build patient Caregiver screen "RTN","DGRP11B",25,0) D CLEAN^VALM10 "RTN","DGRP11B",26,0) D CLEAR^VALM1 "RTN","DGRP11B",27,0) D GETCGP "RTN","DGRP11B",28,0) Q "RTN","DGRP11B",29,0) ; "RTN","DGRP11B",30,0) GETCGP ;Load Caregiver data from MPI array into TMP(VALMAR global for display "RTN","DGRP11B",31,0) N DGCGRET,DGCGTCNT,DGCG,DGCGG1,DGCGICN,DGSSN,DGCGRELTYP,DGCGSUBTYP,DGCGSTATUS,DGX,DGY,DGCGSTATDT,DGCGCNT,DGCGDISPDT "RTN","DGRP11B",32,0) N LINEVAR,DGDFN,DGFNAME,DGLNAME,DGNAME "RTN","DGRP11B",33,0) ; Call MPI interface to get patient relationship array "RTN","DGRP11B",34,0) D GET^VAFCREL(.DGCGRET,DFN) "RTN","DGRP11B",35,0) ; Get array of Cargivers (DGCG) from the MPI Relationship array "RTN","DGRP11B",36,0) D MPIGETCG^DGRP11A(.DGCGRET,.DGCG,.DGCGTCNT) "RTN","DGRP11B",37,0) S VALMCNT=0,DGCGCNT=0 "RTN","DGRP11B",38,0) ; Format of DGCG array: "RTN","DGRP11B",39,0) ; ICN^RELTYP^RELTYPDISP^RCODE^RSTATUS^RSTATUSDISP^RSTATDATE^CGSPONSNAM" "RTN","DGRP11B",40,0) ; eg: DGCG(1)="1002345678V123456^CGP^CAREGIVER: PRIMARY^QUAL^ACTIVE^APPROVED^20200220^Jones, William M" "RTN","DGRP11B",41,0) S LINEVAR="CAREGIVER" "RTN","DGRP11B",42,0) F S DGCGCNT=$O(DGCG(DGCGCNT)) Q:DGCGCNT="" D "RTN","DGRP11B",43,0) . S DGCGG1=DGCG(DGCGCNT) "RTN","DGRP11B",44,0) . S VALMCNT=VALMCNT+1 "RTN","DGRP11B",45,0) . S LINEVAR=$$SETFLD^VALM1("<"_VALMCNT_">",LINEVAR,"NO") "RTN","DGRP11B",46,0) . S DGNAME=$P(DGCGG1,U,8) "RTN","DGRP11B",47,0) . S DGNAME=$$UPPER^DGUTL(DGNAME) "RTN","DGRP11B",48,0) . ;Remove extra space between Last and First names "RTN","DGRP11B",49,0) . S DGLNAME=$P(DGNAME,","),DGFNAME=$P(DGNAME,",",2),DGFNAME=$S($E(DGFNAME)=" ":$E(DGFNAME,2,99),1:DGFNAME) "RTN","DGRP11B",50,0) . S LINEVAR=$$SETFLD^VALM1(" "_$E(DGLNAME_","_DGFNAME,1,30),LINEVAR,"NAME") "RTN","DGRP11B",51,0) . ;ICN-->DFN-->SSN "RTN","DGRP11B",52,0) . S DGCGICN=$P(DGCGG1,U,1) "RTN","DGRP11B",53,0) . S DGDFN=$$GETDFN^MPIF001(DGCGICN) "RTN","DGRP11B",54,0) . S DGX=$S($D(^DPT(+DGDFN,0)):^(0),1:"") "RTN","DGRP11B",55,0) . S DGSSN=$P(DGX,"^",9) "RTN","DGRP11B",56,0) . ; Grab chars 6-10 of SSN in case of Pseudo SSN "RTN","DGRP11B",57,0) . S LINEVAR=$$SETFLD^VALM1($E(DGSSN,6,10),LINEVAR,"L4SSN") "RTN","DGRP11B",58,0) . S DGCGRELTYP=$P(DGCGG1,U,2) "RTN","DGRP11B",59,0) . S DGCGRELTYP=$$UPPER^DGUTL(DGCGRELTYP) "RTN","DGRP11B",60,0) . S DGCGSUBTYP=$S(DGCGRELTYP="CGP":"PRIMARY",DGCGRELTYP="CGS":"SECONDARY",DGCGRELTYP="CGG":"GENERAL",1:"??") "RTN","DGRP11B",61,0) . S LINEVAR=$$SETFLD^VALM1(DGCGSUBTYP,LINEVAR,"SUBTYPE") "RTN","DGRP11B",62,0) . S DGCGSTATUS=$P(DGCGG1,U,5) "RTN","DGRP11B",63,0) . S DGCGSTATUS=$$UPPER^DGUTL(DGCGSTATUS) "RTN","DGRP11B",64,0) . ; Pending-> In Process, Decline -> Denied, Inactive->Revoked, Active->Approved, Terminated->Benefit End "RTN","DGRP11B",65,0) . S DGCGSTATUS=$S(DGCGSTATUS="PENDING":"IN PROCESS",DGCGSTATUS="DECLINE":"DENIED",DGCGSTATUS="INACTIVE":"REVOKED",DGCGSTATUS="ACTIVE":"APPROVED",DGCGSTATUS="TERMINATED":"BENEFIT END",1:DGCGSTATUS) "RTN","DGRP11B",66,0) . S LINEVAR=$$SETFLD^VALM1($E(DGCGSTATUS,1,13),LINEVAR,"STATUS") "RTN","DGRP11B",67,0) . S DGX=$P(DGCGG1,U,7),DGY=$E(DGX,5,6)_"/"_$E(DGX,7,8)_"/"_$E(DGX,1,4) D DT^DILF("E",DGY,.DGCGSTATDT) "RTN","DGRP11B",68,0) . ; strip the space between the day and year "RTN","DGRP11B",69,0) . S DGCGDISPDT=$P(DGCGSTATDT(0)," ",1,2)_$P(DGCGSTATDT(0)," ",3) "RTN","DGRP11B",70,0) . S LINEVAR=$$SETFLD^VALM1(DGCGDISPDT,LINEVAR,"DATE") "RTN","DGRP11B",71,0) . D SET^VALM10(VALMCNT,LINEVAR,VALMCNT) "RTN","DGRP11B",72,0) Q "RTN","DGRP11B",73,0) ; "RTN","DGRP11B",74,0) HELP ;Help code "RTN","DGRP11B",75,0) S X="?" D DISP^XQORM1 W !! "RTN","DGRP11B",76,0) Q "RTN","DGRP11B",77,0) ; "RTN","DGRP11B",78,0) EXIT ;Exit code "RTN","DGRP11B",79,0) D CLEAN^VALM10 "RTN","DGRP11B",80,0) D CLEAR^VALM1 "RTN","DGRP11B",81,0) Q "RTN","DGRP2") 0^14^B12658951 "RTN","DGRP2",1,0) DGRP2 ;ALB/MRL,BRM,ARF - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300 "RTN","DGRP2",2,0) ;;5.3;Registration;**415,545,638,677,760,867,1014**;Aug 13, 1993;Build 42 "RTN","DGRP2",3,0) ; "RTN","DGRP2",4,0) D NEWB "RTN","DGRP2",5,0) S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP2",6,0) S DGRPX=DGRP(0) "RTN","DGRP2",7,0) S (Z,DGRPW)=1 D WW^DGRPV W " Marital: " S Z=$S($D(^DIC(11,+$P(DGRPX,"^",5),0)):$E($P(^(0),"^",1),1,28),1:DGRPU),Z1=30 D WW1^DGRPV "RTN","DGRP2",8,0) ;S (Z,DGRPW)=1 D WW^DGRPV W " Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV "RTN","DGRP2",9,0) S DGD=$$DISP^DG1010P0(DGRP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1) "RTN","DGRP2",10,0) W ?41,"POB: ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,29) "RTN","DGRP2",11,0) ;S DGRPX=DGRP(0) "RTN","DGRP2",12,0) W !?4,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU) "RTN","DGRP2",13,0) S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QP"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X "RTN","DGRP2",14,0) W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU) "RTN","DGRP2",15,0) W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU) "RTN","DGRP2",16,0) ;W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care",!?4,"------------------ -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X "RTN","DGRP2",17,0) W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X ;DG*5.3*1014 ARF remove dashes "RTN","DGRP2",18,0) E F I=1:1:4 S I1=$P(DGRPX,"^",I) X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)" I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU) "RTN","DGRP2",19,0) W ! S Z=3 D WW^DGRPV W " Ethnicity: " D "RTN","DGRP2",20,0) .I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q "RTN","DGRP2",21,0) .N NODE,NUM,ETHNIC "RTN","DGRP2",22,0) .S I=0 "RTN","DGRP2",23,0) .F NUM=0:1 S I=+$O(^DPT(DFN,.06,I)) Q:'I D "RTN","DGRP2",24,0) ..S NODE=$G(^DPT(DFN,.06,I,0)) "RTN","DGRP2",25,0) ..S X=$P($G(^DIC(10.2,+NODE,0)),"^",1) "RTN","DGRP2",26,0) ..S ETHNIC=$S(X="":"?????",1:X) "RTN","DGRP2",27,0) ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2) "RTN","DGRP2",28,0) ..S ETHNIC=ETHNIC_" ("_$S(X="":"?",1:X)_")" "RTN","DGRP2",29,0) ..I NUM S ETHNIC=", "_ETHNIC "RTN","DGRP2",30,0) ..I ($X+$L(ETHNIC))>IOM D W !?15 "RTN","DGRP2",31,0) ...F S X=$P(ETHNIC," ",1)_" " Q:($X+$L(X))>IOM W X S ETHNIC=$P(ETHNIC," ",2,999) "RTN","DGRP2",32,0) ..W ETHNIC "RTN","DGRP2",33,0) W !?9,"Race: " D "RTN","DGRP2",34,0) .I '$O(^DPT(DFN,.02,0)) W "UNANSWERED" Q "RTN","DGRP2",35,0) .N NODE,NUM,RACE "RTN","DGRP2",36,0) .S I=0 "RTN","DGRP2",37,0) .F NUM=0:1 S I=+$O(^DPT(DFN,.02,I)) Q:'I D "RTN","DGRP2",38,0) ..S NODE=$G(^DPT(DFN,.02,I,0)) "RTN","DGRP2",39,0) ..S X=$P($G(^DIC(10,+NODE,0)),"^",1) "RTN","DGRP2",40,0) ..S RACE=$S(X="":"?????",1:X) "RTN","DGRP2",41,0) ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2) "RTN","DGRP2",42,0) ..S RACE=RACE_" ("_$S(X="":"?",1:X)_")" "RTN","DGRP2",43,0) ..I NUM S RACE=", "_RACE "RTN","DGRP2",44,0) ..I ($X+$L(RACE))>IOM D W !?15 "RTN","DGRP2",45,0) ...F S X=$P(RACE," ",1)_" " Q:($X+$L(X))>IOM W X S RACE=$P(RACE," ",2,999) "RTN","DGRP2",46,0) ..W RACE "RTN","DGRP2",47,0) D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO") "RTN","DGRP2",48,0) W !! "RTN","DGRP2",49,0) W "<4> Date of Death Information" "RTN","DGRP2",50,0) W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E")) "RTN","DGRP2",51,0) W ?41,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E")) "RTN","DGRP2",52,0) W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E")) "RTN","DGRP2",53,0) W ?41,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),! "RTN","DGRP2",54,0) K PDTHINFO "RTN","DGRP2",55,0) ; "RTN","DGRP2",56,0) ;Emergency Response Indicator "RTN","DGRP2",57,0) N DGEMRES S DGEMRES=$P($G(^DPT(DFN,.18)),"^") "RTN","DGRP2",58,0) S Z=5 D WW^DGRPV W " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES) "RTN","DGRP2",59,0) G ^DGRPP "RTN","DGRP2",60,0) ; "RTN","DGRP2",61,0) Q "RTN","DGRP2",62,0) NEWB ;-- check patient DOB, if DOB<365 days, set marital status to "never married" "RTN","DGRP2",63,0) N DOB,NOW "RTN","DGRP2",64,0) S DOB=$P(^DPT(DFN,0),"^",3) "RTN","DGRP2",65,0) D NOW^%DTC S NOW=X "RTN","DGRP2",66,0) I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;patient is not a newborn "RTN","DGRP2",67,0) S $P(^DPT(DFN,0),"^",5)=6 ;patient is a newborn "RTN","DGRP2",68,0) Q "RTN","DGRP6") 0^15^B27897413 "RTN","DGRP6",1,0) DGRP6 ;ALB/MRL,LBD,TMK,JAM,HM,ARF - REGISTRATION SCREEN 6/SERVICE INFORMATION ;5/12/11 10:49am "RTN","DGRP6",2,0) ;;5.3;Registration;**161,247,343,397,342,451,672,689,797,841,842,947,972,1014**;Aug 13, 1993;Build 42 "RTN","DGRP6",3,0) N DIPA,LIN,XX,Z1,GLBL "RTN","DGRP6",4,0) S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.385,.52,.53,.54 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP6",5,0) S (DGRPW,Z)=1 D WW2^DGRPV S Z=" Service Branch/Component",Z1=27 D WW1^DGRPV S Z="Service #",Z1=16 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z="Separated",Z1=12 D WW1^DGRPV W "Discharge" "RTN","DGRP6",6,0) W !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------" "RTN","DGRP6",7,0) ;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797) "RTN","DGRP6",8,0) K ^TMP("DGRP6",$J) "RTN","DGRP6",9,0) S GLBL=$NA(^TMP("DGRP6",$J)) "RTN","DGRP6",10,0) D GETMSE^DGRP61(DFN,GLBL,0) "RTN","DGRP6",11,0) D S "RTN","DGRP6",12,0) ;W ! ;DG*5.3*1014 - ARF - remove blank line between Service Branch/Component and Conflict Locations groups "RTN","DGRP6",13,0) D CL^DGRP6CL2(DFN,.LIN) "RTN","DGRP6",14,0) S Z=2 D WW2^DGRPV S Z=" Conflict Locations: ",Z1=20 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1) "RTN","DGRP6",15,0) S Z=1 F S Z=$O(LIN(Z)) Q:'Z W !,?25,LIN(Z) "RTN","DGRP6",16,0) D EF^DGRP6EF(DFN,.LIN) "RTN","DGRP6",17,0) S Z=3 D WW2^DGRPV S Z=" Environment Factors: ",Z1=21 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1) "RTN","DGRP6",18,0) S Z=1 F S Z=$O(LIN(Z)) Q:'Z W !,?4,"+ ",LIN(Z) "RTN","DGRP6",19,0) S Z=4,DGRPX=DGRP(.52) D WW^DGRPV W " POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"") "RTN","DGRP6",20,0) S Z=5 D WW^DGRPV W " Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"") "RTN","DGRP6",21,0) S Z=6 D WW^DGRPV S X=$P(DGRP(.36),"^",12),XX=$P(DGRP(.36),"^",13) "RTN","DGRP6",22,0) N DGSPACE "RTN","DGRP6",23,0) S DGSPACE=$S($G(X)="0":" ",$G(X)="1":"",1:" ") "RTN","DGRP6",24,0) W " Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"") W DGSPACE_" Dischrg Due to Disab: ",$S(XX=0:"NO",XX=1:"YES",1:"") "RTN","DGRP6",25,0) ;W ! "RTN","DGRP6",26,0) S Z=7 D WW^DGRPV W " Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1 "RTN","DGRP6",27,0) I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I S I1=1,DGRPX=^(I,0) D DEN "RTN","DGRP6",28,0) S Z=8 D WW^DGRPV W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D "RTN","DGRP6",29,0) . I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"") "RTN","DGRP6",30,0) I $P($G(DGRPX),U)="N" D "RTN","DGRP6",31,0) . S DGX=$P(DGRPX,U,3) "RTN","DGRP6",32,0) . S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"") "RTN","DGRP6",33,0) . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"") "RTN","DGRP6",34,0) ;DG*5.3*841 "RTN","DGRP6",35,0) I $P(DGRP(.54),"^")="Y" D "RTN","DGRP6",36,0) .W !,"<9> Medal of Honor: YES" "RTN","DGRP6",37,0) .;MOH updates start here DG*5.3*972 HM "RTN","DGRP6",38,0) .N DGMOHADT,DGMOHEDT,DGMOHSDT "RTN","DGRP6",39,0) .S DGMOHADT=$P(DGRP(.54),"^",2),DGMOHSDT=$P(DGRP(.54),"^",3),DGMOHEDT=$P(DGRP(.54),"^",4) ;get MOH AWARD DATE,MOH STATUS DATE, & MOH COPAYMENT EXEMPTION DATE "RTN","DGRP6",40,0) .I DGMOHADT="" S DGMOHADT="UNKNOWN",DGMOHEDT="Needs Determination" ;Display text when MOH AWARD DATE empty "RTN","DGRP6",41,0) .W ?26,"Award Date: "_$$FMTE^XLFDT(DGMOHADT,"5DZ") ;format MOH AWARD DATE "RTN","DGRP6",42,0) .W ?51,"Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE "RTN","DGRP6",43,0) .W !?4,"MOH Copayment Exemption Date: "_$$FMTE^XLFDT(DGMOHEDT,"5DZ") ;format MOH COPAYMENT EXEMPTION DATE "RTN","DGRP6",44,0) I $P(DGRP(.54),"^")="N" D ;if MOH indicator is N "RTN","DGRP6",45,0) .N DGMOHSDT S DGMOHSDT=$P(DGRP(.54),"^",3) ;set status date "RTN","DGRP6",46,0) .W !,"<9> Medal of Honor: NO" "RTN","DGRP6",47,0) .W ?26,"Award Date: " "RTN","DGRP6",48,0) .W ?51,"Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE "RTN","DGRP6",49,0) .W !?4,"MOH Copayment Exemption Date: " "RTN","DGRP6",50,0) I $P(DGRP(.54),"^")="" D ;if MOH indicator is null "RTN","DGRP6",51,0) .W !,"<9> Medal of Honor: " "RTN","DGRP6",52,0) .W ?26,"Award Date: " "RTN","DGRP6",53,0) .W ?51,"Status Date: " "RTN","DGRP6",54,0) .W !?4,"MOH Copayment Exemption Date: " "RTN","DGRP6",55,0) .;MOH end updates DG*5.3*972 "RTN","DGRP6",56,0) ;DG*5.3*842 "RTN","DGRP6",57,0) I ($P(DGRP(.385),U,8)["Y")!($P(DGRP(.385),U,8)["N") D EN^DDIOL("<10> Class II Dental Indicator: ","","!?0") S DGRPX=DGRP(.385),X=8,Z1=6 D YN I $P(DGRP(.385),U,8)["Y" D EN^DDIOL("Dental Appl Due Before Date: ","","?0") S X=9 D DAT "RTN","DGRP6",58,0) Q K DGRPD,DGRPSV "RTN","DGRP6",59,0) G ^DGRPP "RTN","DGRP6",60,0) YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") D WW1^DGRPV Q "RTN","DGRP6",61,0) DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z="" "RTN","DGRP6",62,0) E S Z=$$FMTE^XLFDT(Z,"5DZ") "RTN","DGRP6",63,0) D WW1^DGRPV Q "RTN","DGRP6",64,0) DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q "RTN","DGRP6",65,0) S ;Write Military Service Episodes (DG*5.3*797) "RTN","DGRP6",66,0) N DGL,MSECNT "RTN","DGRP6",67,0) Q:$G(GLBL)="" "RTN","DGRP6",68,0) ; JAM; DG*5.3*947 - Reason for Early Separation displayed with MSE data. "RTN","DGRP6",69,0) ; This screen displays up to 3 MSE's and must include RES or Final Discharge Date if present "RTN","DGRP6",70,0) ; Array lines (built in ^DGRP61) may contain an MSE or a RES or FDD, so we need to track the number of MSEs "RTN","DGRP6",71,0) ; being displayed (MSECNT) - not the number of lines "RTN","DGRP6",72,0) S MSECNT=0 "RTN","DGRP6",73,0) S DGL=0 F S DGL=$O(@GLBL@(DGL)) Q:'DGL D "RTN","DGRP6",74,0) .; JAM; DG*5.3*947 - if this array entry is MSE data (node 1 is present), increment the count and only display 3 episodes "RTN","DGRP6",75,0) .I $D(@GLBL@(DGL,1)) S MSECNT=MSECNT+1 "RTN","DGRP6",76,0) .Q:MSECNT>3 "RTN","DGRP6",77,0) .I $G(@GLBL@(DGL,0))]"" W !,@GLBL@(DGL,0) "RTN","DGRP6",78,0) ; "RTN","DGRP6",79,0) ; JAM; DG*5.3*947 - indicate more episodes are available using the MSECNT - not the line count "RTN","DGRP6",80,0) ;I DGL>3 W !," " Q "RTN","DGRP6",81,0) I MSECNT>3 W !," " Q "RTN","DGRP6",82,0) ; end DG*5.3*947 changes "RTN","DGRP6",83,0) Q "RTN","DGRP6",84,0) MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q "RTN","DGRP6",85,0) ; "RTN","DGRP6",86,0) SETLNEX(Z,SEQ,LIN,LENGTH) ; "RTN","DGRP6",87,0) I 'LIN S LIN=1,LIN(1)="" "RTN","DGRP6",88,0) S Z=$E("("_SEQ_") "_Z,1,75) "RTN","DGRP6",89,0) I LENGTH+$L(Z)>$S(LIN<2:49,1:70) S LIN=LIN+1,LIN(LIN)="",LENGTH=0 "RTN","DGRP6",90,0) S LIN(LIN)=LIN(LIN)_$S(LENGTH:" ",1:"")_Z,LENGTH=$L(LIN(LIN)) "RTN","DGRP6",91,0) Q "RTN","DGRP6",92,0) ; "RTN","DGRP61") 0^16^B67709879 "RTN","DGRP61",1,0) DGRP61 ;ALB/PJH,LBD,DJS,JAM,JAM,ARF - Patient MSDS History - List Manager Screen ;16 Oct 2017 16:04:16 "RTN","DGRP61",2,0) ;;5.3;Registration;**797,909,935,947,966,1014**;Aug 13,1993;Build 42 "RTN","DGRP61",3,0) ; "RTN","DGRP61",4,0) EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list "RTN","DGRP61",5,0) ; Input -- DFN Patient IEN "RTN","DGRP61",6,0) ; "RTN","DGRP61",7,0) D WAIT^DICD "RTN","DGRP61",8,0) D EN^VALM("DGEN MSDS PATIENT") "RTN","DGRP61",9,0) Q "RTN","DGRP61",10,0) ; "RTN","DGRP61",11,0) HDR ;Header code "RTN","DGRP61",12,0) N X "RTN","DGRP61",13,0) S VALMHDR(1)=$J("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>" "RTN","DGRP61",14,0) D LISTHDR^DGRPU(2) ;DG*5.3*1014 - ARF - sets patient data in the 2nd and 3rd entries in VALMHDR array "RTN","DGRP61",15,0) ;D PID^VADPT ;DG*5.3*1014 begin comment previous code "RTN","DGRP61",16,0) ;S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGRP61",17,0) ;S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")" "RTN","DGRP61",18,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGRP61",19,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGRP61",20,0) ;S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80) "RTN","DGRP61",21,0) ;S VALMHDR(3)=$J("",4)_"Service Branch/Component Service #" "RTN","DGRP61",22,0) ;S VALMHDR(3)=VALMHDR(3)_" Entered Separated Discharge" ;DG*5.3*1014 end comment previous code "RTN","DGRP61",23,0) S VALMHDR(4)=$J("",4)_"Service Branch/Component Service #" "RTN","DGRP61",24,0) S VALMHDR(4)=VALMHDR(4)_" Entered Separated Discharge" "RTN","DGRP61",25,0) Q "RTN","DGRP61",26,0) ; "RTN","DGRP61",27,0) INIT ;Build patient MSDS screen "RTN","DGRP61",28,0) D CLEAN^VALM10 "RTN","DGRP61",29,0) K ^TMP("DGRP61",$J),DGSEL "RTN","DGRP61",30,0) ; "RTN","DGRP61",31,0) N GLBL "RTN","DGRP61",32,0) S GLBL=$NA(^TMP("DGRP61",$J)) "RTN","DGRP61",33,0) D GETMSE(DFN,GLBL,1) "RTN","DGRP61",34,0) ;Check if any old MSEs didn't copy and display warning message "RTN","DGRP61",35,0) I $$WARNMSG^DGMSEUTL(DFN) D "RTN","DGRP61",36,0) .S VALMSG="**More MSEs available to view on History Screen**" "RTN","DGRP61",37,0) .D MSG^VALM10(VALMSG) "RTN","DGRP61",38,0) Q "RTN","DGRP61",39,0) ; "RTN","DGRP61",40,0) GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array "RTN","DGRP61",41,0) ; INPUT: DFN = Patient IEN "RTN","DGRP61",42,0) ; GLBL = ^TMP global ref "RTN","DGRP61",43,0) ; NUM = 1 - display line numbers "RTN","DGRP61",44,0) N DGDATA,DGDATE,DGSUB,X1,X2,X "RTN","DGRP61",45,0) ; DGSEL - selectable items, DGSEL("episode count") - episode count for DGSEL "RTN","DGRP61",46,0) ; not all items may be selectable "RTN","DGRP61",47,0) K DGSEL S VALMCNT=0,DGDATE="",DGSEL("episode count")=0 "RTN","DGRP61",48,0) F S DGDATE=$O(^DPT(DFN,.3216,"B",DGDATE),-1) Q:'DGDATE D "RTN","DGRP61",49,0) . S DGSUB=$O(^DPT(DFN,.3216,"B",DGDATE,"")) Q:'DGSUB "RTN","DGRP61",50,0) . S DGDATA=$G(^DPT(DFN,.3216,DGSUB,0)) Q:DGDATA="" "RTN","DGRP61",51,0) . D EPISODE(DGDATA,GLBL,NUM) "RTN","DGRP61",52,0) Q "RTN","DGRP61",53,0) ; "RTN","DGRP61",54,0) EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode "RTN","DGRP61",55,0) N DGFDD,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS,Z "RTN","DGRP61",56,0) ; increment episode count "RTN","DGRP61",57,0) S DGSEL("episode count")=DGSEL("episode count")+1 "RTN","DGRP61",58,0) S DGRPSB=+$P(DGDATA,U,3),DGRPSC=$P(DGDATA,U,4),DGRPSN=$P(DGDATA,U,5) "RTN","DGRP61",59,0) ;Service Branch/Component "RTN","DGRP61",60,0) S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:"UNKNOWN") "RTN","DGRP61",61,0) I DGRPSC'="" D "RTN","DGRP61",62,0) . N Z0 "RTN","DGRP61",63,0) . S Z0=$$SVCCOMP^DGRP6CL(DGRPSC) Q:Z0="" "RTN","DGRP61",64,0) . S Z=Z_"/"_Z0 "RTN","DGRP61",65,0) ;Filipino vet proof "RTN","DGRP61",66,0) I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P($G(^DPT(DFN,.321)),U,14)_")" "RTN","DGRP61",67,0) ;Service Number "RTN","DGRP61",68,0) S Z=Z_$J("",26-$L(Z))_$S(DGRPSN]"":DGRPSN,1:"UNKNOWN") "RTN","DGRP61",69,0) S Z=Z_$J("",42-$L(Z)) "RTN","DGRP61",70,0) ;Entry and separation dates "RTN","DGRP61",71,0) S DGRPSE=$P(DGDATA,U,1),DGRPSS=$P(DGDATA,U,2) "RTN","DGRP61",72,0) S X=$S(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN ") "RTN","DGRP61",73,0) S Z=Z_$E(X,1,10)_" " "RTN","DGRP61",74,0) S X=$S(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN ") "RTN","DGRP61",75,0) S Z=Z_$E(X,1,10)_" " "RTN","DGRP61",76,0) ;DJS, Add FUTURE DISCHARGE DATE; DG*5.3*935 "RTN","DGRP61",77,0) ;DGFDD = FUTURE DISCHARGE DATE (internal) "RTN","DGRP61",78,0) ;DGFDD("DISP") = FUTURE DISCHARGE DATE (display) "RTN","DGRP61",79,0) S DGFDD=$P(DGDATA,U,8),DGFDD("DISP")=$S(DGFDD]"":$$FMTE^XLFDT(DGFDD,"5DZ"),1:"") "RTN","DGRP61",80,0) ;Discharge type "RTN","DGRP61",81,0) S DGRPSD=+$P(DGDATA,U,6) "RTN","DGRP61",82,0) I 'DGRPSD S Z=Z_"UNKNOWN" "RTN","DGRP61",83,0) E S Z=Z_$S($D(^DIC(25,+DGRPSD)):$E($P(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN") "RTN","DGRP61",84,0) ; "RTN","DGRP61",85,0) S VALMCNT=VALMCNT+1 "RTN","DGRP61",86,0) ; Add line numbers if NUM true "RTN","DGRP61",87,0) I $G(NUM) D "RTN","DGRP61",88,0) . ;DJS, Indicate MSE episode with FDD not editable or deletable; DG*5.3*935 "RTN","DGRP61",89,0) . ; not selectable, put < > around number, stop "RTN","DGRP61",90,0) . I $G(DGRPV)!($P(DGDATA,U,7)]"")!($P(DGDATA,U,8)]"") S Z="<"_DGSEL("episode count")_"> "_Z Q "RTN","DGRP61",91,0) . ; item is selectable, put into DGSEL, [ ] around number "RTN","DGRP61",92,0) . S Z="["_DGSEL("episode count")_"] "_Z,DGSEL(DGSEL("episode count"))=DGRPSE "RTN","DGRP61",93,0) ; "RTN","DGRP61",94,0) ; Save to List Manager array for display "RTN","DGRP61",95,0) S @GLBL@(VALMCNT,0)=$S($G(NUM):Z,1:$J("",4)_Z) "RTN","DGRP61",96,0) ; JAM; DG*5.3*947 - Track the array entries that are MSE data in the "1" subscript "RTN","DGRP61",97,0) S @GLBL@(VALMCNT,1)="" "RTN","DGRP61",98,0) ; JAM; DG*5.3*947 - if Reason for Early Separation is present, include it in output "RTN","DGRP61",99,0) ; JAM; DG*5.3*966 - If patient record has Separation Reason Code (piece 10), retrieve the Description from file #24 "RTN","DGRP61",100,0) ; otherwise get description from piece 9 "RTN","DGRP61",101,0) N RESDESC "RTN","DGRP61",102,0) I $P(DGDATA,U,10)]"" D "RTN","DGRP61",103,0) . S RESDESC=$$GET1^DIQ(26,$P(DGDATA,U,10),.02) "RTN","DGRP61",104,0) E S RESDESC=$P(DGDATA,U,9) "RTN","DGRP61",105,0) I RESDESC]"" D "RTN","DGRP61",106,0) . ;use the DIWP api to format the text which can be longer than 80 chars "RTN","DGRP61",107,0) . N X,I,DIWL,DIWR,DIWF,RESLINE "RTN","DGRP61",108,0) . K ^UTILITY($J,"W") "RTN","DGRP61",109,0) . S X="Early Separation Reason: "_RESDESC,DIWL=0,DIWR=80,DIWF="" "RTN","DGRP61",110,0) . D ^DIWP "RTN","DGRP61",111,0) . M RESDESC=^UTILITY($J,"W",0) "RTN","DGRP61",112,0) . F I=1:1:RESDESC D "RTN","DGRP61",113,0) . . S RESLINE=RESDESC(I,0) "RTN","DGRP61",114,0) . . S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)=RESLINE "RTN","DGRP61",115,0) ; end patch DG*5.3*947 changes "RTN","DGRP61",116,0) ; "RTN","DGRP61",117,0) D:DGFDD ; if FDD found, add to display "RTN","DGRP61",118,0) . S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)=" Future Discharge Date: "_DGFDD("DISP") "RTN","DGRP61",119,0) Q "RTN","DGRP61",120,0) ; "RTN","DGRP61",121,0) HELP ;Help code "RTN","DGRP61",122,0) S X="?" D DISP^XQORM1 W !! "RTN","DGRP61",123,0) Q "RTN","DGRP61",124,0) ; "RTN","DGRP61",125,0) EXIT ;Exit code "RTN","DGRP61",126,0) D CLEAN^VALM10 "RTN","DGRP61",127,0) D CLEAR^VALM1 "RTN","DGRP61",128,0) K ^TMP("DGRP61",$J) "RTN","DGRP61",129,0) Q "RTN","DGRP61",130,0) ; "RTN","DGRP61",131,0) PEXIT ;DGEN MSDS MENU protocol exit code "RTN","DGRP61",132,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGRP61",133,0) ;Reset after page up or down "RTN","DGRP61",134,0) ;D XQORM "RTN","DGRP61",135,0) Q "RTN","DGRP61",136,0) ; "RTN","DGRP61",137,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGRP61",138,0) ; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol "RTN","DGRP61",139,0) ; = "E" - Edit - DGEN MSDS EDIT protocol "RTN","DGRP61",140,0) ; = "D" - Delete - DGEN MSDS DELETE protocol "RTN","DGRP61",141,0) N DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y "RTN","DGRP61",142,0) I $G(DGACT)="" G ACTQ "RTN","DGRP61",143,0) I $G(DGRPV) W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ "RTN","DGRP61",144,0) D FULL^VALM1 "RTN","DGRP61",145,0) I DGACT="A" D ADD G ACTQ "RTN","DGRP61",146,0) I '$O(DGSEL(0)) D G ACTQ "RTN","DGRP61",147,0) . W !,"There are no episodes to "_$S(DGACT="E":"edit.",1:"delete.") "RTN","DGRP61",148,0) . I $G(VALMCNT) D HECHLP "RTN","DGRP61",149,0) . D PAUSE^VALM1 "RTN","DGRP61",150,0) S DGX=$$SEL(DGACT) I 'DGX G ACTQ "RTN","DGRP61",151,0) S DGX=$G(DGSEL(DGX)) I 'DGX G ACTQ "RTN","DGRP61",152,0) S DA(1)=DFN,DIC="^DPT("_DA(1)_",.3216,",DIC(0)="BX",X=DGX "RTN","DGRP61",153,0) D ^DIC I Y<0 W !,"This episode is not in the patient's record." D PAUSE^VALM1 G ACTQ "RTN","DGRP61",154,0) S DIPA("DA")=+Y "RTN","DGRP61",155,0) I DGACT="E" K DA,DIC,DGFRDT S DIE="^DPT(",DA=DFN D SETDR1 D ^DIE G ACTQ "RTN","DGRP61",156,0) ; deletion, ask user first "RTN","DGRP61",157,0) I DGACT="D",$$RUSURE S DIK=DIC,DA(1)=DFN,DA=DIPA("DA") D ^DIK K DA,DIK "RTN","DGRP61",158,0) ; "RTN","DGRP61",159,0) ; DG*5.3*909 Potentially change Camp Lejeune to No with MSE changes "RTN","DGRP61",160,0) ACTQ ; menu action exit point "RTN","DGRP61",161,0) D INIT S VALMBCK="R" D SETCLNO^DGENCLEA Q "RTN","DGRP61",162,0) ; "RTN","DGRP61",163,0) ADD ; Add new MSE to #2.3216 sub-file "RTN","DGRP61",164,0) N X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT "RTN","DGRP61",165,0) ; Get next record number in sub-file "RTN","DGRP61",166,0) S NEXT=$O(^DPT(DFN,.3216,"A"),-1),NEXT=NEXT+1 "RTN","DGRP61",167,0) D ZNODE(1) "RTN","DGRP61",168,0) ; Prompt for MSE fields "RTN","DGRP61",169,0) S DIE="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D SETDR2 D ^DIE "RTN","DGRP61",170,0) I X["BAD" S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK "RTN","DGRP61",171,0) ; Check if new record is missing or incomplete "RTN","DGRP61",172,0) I '$D(^DPT(DFN,.3216,NEXT)) D ZNODE(-1) Q "RTN","DGRP61",173,0) I '$P(^DPT(DFN,.3216,NEXT,0),U) D Q "RTN","DGRP61",174,0) .S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK D ZNODE(-1) "RTN","DGRP61",175,0) ; "RTN","DGRP61",176,0) ; File FILIPINO VET PROOF, if set "RTN","DGRP61",177,0) I $G(DIPA("FVP"))]"" D "RTN","DGRP61",178,0) .K DA,DR S DIE="^DPT(",DA=DFN,DR=".3214///^S X=DIPA(""FVP"")" "RTN","DGRP61",179,0) .D ^DIE "RTN","DGRP61",180,0) Q "RTN","DGRP61",181,0) ; "RTN","DGRP61",182,0) SEL(ACT) ; function, prompt for episode to edit/delete "RTN","DGRP61",183,0) N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y "RTN","DGRP61",184,0) ; range is 1 to episode count, must be in DGSEL to be selectable "RTN","DGRP61",185,0) S DIR(0)="NAO^1:"_DGSEL("episode count")_"^K:'$D(DGSEL(X)) X" "RTN","DGRP61",186,0) S DIR("A")="Select Episode: " "RTN","DGRP61",187,0) S DIR("?")="^D SELHLP^DGRP61(ACT)" "RTN","DGRP61",188,0) D ^DIR I 'Y Q 0 "RTN","DGRP61",189,0) Q Y "RTN","DGRP61",190,0) ; "RTN","DGRP61",191,0) SELHLP(ACT) ; Help message for episode prompt "RTN","DGRP61",192,0) W !,"Select an episode to ",$S(ACT="E":"edit.",1:"delete.") "RTN","DGRP61",193,0) W !,"Only numbers in square brackets [ ] are selectable." "RTN","DGRP61",194,0) D HECHLP "RTN","DGRP61",195,0) N DIR D PAUSE^VALM1 "RTN","DGRP61",196,0) Q "RTN","DGRP61",197,0) HECHLP ; Help message for episodes that can only be changed by HEC "RTN","DGRP61",198,0) W !,"Angled brackets < > indicate episodes that cannot be changed in VistA." "RTN","DGRP61",199,0) W !,"Please contact the HECAlert mail group or the HEC if you need to update" "RTN","DGRP61",200,0) W !,"this information." "RTN","DGRP61",201,0) Q "RTN","DGRP61",202,0) ; "RTN","DGRP61",203,0) ZNODE(VAL) ; Update zero node of MSE multiple .3216 "RTN","DGRP61",204,0) Q:'$G(VAL) Q:'$G(DFN) "RTN","DGRP61",205,0) N ZNODE "RTN","DGRP61",206,0) S ZNODE=$G(^DPT(DFN,.3216,0)) "RTN","DGRP61",207,0) S ^DPT(DFN,.3216,0)="^2.3216D^"_($P(ZNODE,U,3)+VAL)_U_($P(ZNODE,U,4)+VAL) "RTN","DGRP61",208,0) Q "RTN","DGRP61",209,0) SETDR1 ; Set DR array to edit MSE fields "RTN","DGRP61",210,0) S DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))" "RTN","DGRP61",211,0) S DR(2,2.3216)="D SET0^DGRP61(.DA,.DIPA);@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61" "RTN","DGRP61",212,0) S DR(2,2.3216,1)="I DIPA(""FVP"")=""^"" K DIPA(""FVP"") S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";S Y=""@63""" "RTN","DGRP61",213,0) S DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06" "RTN","DGRP61",214,0) Q "RTN","DGRP61",215,0) SETDR2 ; Set DR array to add MSE fields "RTN","DGRP61",216,0) S DR="@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61;I DIPA(""FVP"")=""^"" S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";@62;S:'$$CMP^DGRP61(DIPA(""X"")) Y=""@63"";.04;@63;.05;.01;.02;.06" "RTN","DGRP61",217,0) Q "RTN","DGRP61",218,0) FVP() ; Prompt for FILIPINO VET PROOF "RTN","DGRP61",219,0) N DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT "RTN","DGRP61",220,0) S DIR(0)="2,.3214",DA=DFN "RTN","DGRP61",221,0) D ^DIR I Y=""!(Y="^") Q Y "RTN","DGRP61",222,0) Q Y "RTN","DGRP61",223,0) ; "RTN","DGRP61",224,0) SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component "RTN","DGRP61",225,0) K DIPA(0) "RTN","DGRP61",226,0) S DIPA(0)=$P($G(^DPT(DA(1),.3216,DA,0)),U,3,4) "RTN","DGRP61",227,0) Q "RTN","DGRP61",228,0) ; "RTN","DGRP61",229,0) WARN(DIPA,Y) ;Warns that the Service Branch was changed so the "RTN","DGRP61",230,0) ; Service Component was deleted "RTN","DGRP61",231,0) ; Returns Y to skip component if the component should not be asked "RTN","DGRP61",232,0) ; for this branch of service "RTN","DGRP61",233,0) I '$$CMP($G(DIPA("X"))) S Y="@63" "RTN","DGRP61",234,0) I $P($G(DIPA(0)),U,2)=""!($P($G(DIPA(0)),U)="") Q "RTN","DGRP61",235,0) I $P(DIPA(0),U)=DIPA("X") Q ;Service Branch didn't change "RTN","DGRP61",236,0) ; "RTN","DGRP61",237,0) I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",! "RTN","DGRP61",238,0) Q "RTN","DGRP61",239,0) ; "RTN","DGRP61",240,0) CMP(X) ; Function to determine if service component is valid for "RTN","DGRP61",241,0) ; branch of service ien in X 0 = invalid 1 = valid "RTN","DGRP61",242,0) ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS "RTN","DGRP61",243,0) Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0) "RTN","DGRP61",244,0) ; "RTN","DGRP61",245,0) RUSURE() ; Confirmation prompt for deleting episode "RTN","DGRP61",246,0) N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT "RTN","DGRP61",247,0) S DIR(0)="YA",DIR("B")="NO" "RTN","DGRP61",248,0) S DIR("A")="Are you sure you want to delete this military service episode? " "RTN","DGRP61",249,0) D ^DIR I 'Y W !,"<< NOTHING DELETED >>" Q 0 "RTN","DGRP61",250,0) Q 1 "RTN","DGRP61",251,0) ; "RTN","DGRP62") 0^17^B4633656 "RTN","DGRP62",1,0) DGRP62 ;ALB/PJH,LBD,ARF - Patient MSDS History - List Manager Screen;12 JUN 1997 10:00 am ; 6/23/09 3:48pm "RTN","DGRP62",2,0) ;;5.3;Registration;**797,1014**;08/13/93;Build 42 "RTN","DGRP62",3,0) ; "RTN","DGRP62",4,0) EN(DFN) ;Main entry point to invoke the DGEN PATIENT MSDS VIEW list "RTN","DGRP62",5,0) ; Input -- DFN Patient IEN "RTN","DGRP62",6,0) ; "RTN","DGRP62",7,0) D WAIT^DICD "RTN","DGRP62",8,0) D EN^VALM("DGEN MSDS PATIENT VIEW") "RTN","DGRP62",9,0) Q "RTN","DGRP62",10,0) ; "RTN","DGRP62",11,0) HDR ;Header code "RTN","DGRP62",12,0) N DGPREFNM,X,VA,VAERR "RTN","DGRP62",13,0) S VALMHDR(1)=$J("",18)_"VISTA MILITARY SERVICE DATA, SCREEN <6.2>" "RTN","DGRP62",14,0) D LISTHDR^DGRPU(2) ;DG*5.3*1014 - ARF - sets patient data in the 2nd and 3rd entries in VALMHDR array "RTN","DGRP62",15,0) ;D PID^VADPT ;DG*5.3*1014 begin - comment previous code "RTN","DGRP62",16,0) ;S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGRP62",17,0) ;S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")" "RTN","DGRP62",18,0) ;S X="PATIENT TYPE UNKNOWN" "RTN","DGRP62",19,0) ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGRP62",20,0) ;S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80) "RTN","DGRP62",21,0) ;S VALMHDR(3)=$J("",4)_"Service Branch/Component Service #" "RTN","DGRP62",22,0) ;S VALMHDR(3)=VALMHDR(3)_" Entered Separated Discharge" ;DG*5.3*1014 end - comment previous code "RTN","DGRP62",23,0) S VALMHDR(4)=$J("",4)_"Service Branch/Component Service #" "RTN","DGRP62",24,0) S VALMHDR(4)=VALMHDR(4)_" Entered Separated Discharge" "RTN","DGRP62",25,0) Q "RTN","DGRP62",26,0) ; "RTN","DGRP62",27,0) INIT ;Build patient MSDS screen "RTN","DGRP62",28,0) D CLEAN^VALM10 "RTN","DGRP62",29,0) K ^TMP("DGRP62",$J) "RTN","DGRP62",30,0) ; "RTN","DGRP62",31,0) N GLBL "RTN","DGRP62",32,0) S GLBL=$NA(^TMP("DGRP62",$J)) "RTN","DGRP62",33,0) D GETMSE(DFN,GLBL,0) "RTN","DGRP62",34,0) Q "RTN","DGRP62",35,0) ; "RTN","DGRP62",36,0) GETMSE(DFN,GLBL,NUM) ;Get old format MSE data from node .32 "RTN","DGRP62",37,0) N DGDATA "RTN","DGRP62",38,0) S VALMCNT=0 "RTN","DGRP62",39,0) S:'$D(DGRP(.32)) DGRP(.32)=$G(^DPT(DFN,.32)) "RTN","DGRP62",40,0) S:'$D(DGRP(.3291)) DGRP(.3291)=$G(^DPT(DFN,.3291)) "RTN","DGRP62",41,0) ;Last service episode (SL) "RTN","DGRP62",42,0) S DGDATA=$$SETDAT(.DGRP,4) "RTN","DGRP62",43,0) D EPISODE^DGRP61(DGDATA,GLBL,NUM) "RTN","DGRP62",44,0) ;Next to last service episode (SNL) "RTN","DGRP62",45,0) Q:$P(DGRP(.32),U,19)'="Y" "RTN","DGRP62",46,0) S DGDATA=$$SETDAT(.DGRP,9) "RTN","DGRP62",47,0) D EPISODE^DGRP61(DGDATA,GLBL,NUM) "RTN","DGRP62",48,0) ;Prior episode (SNNL) "RTN","DGRP62",49,0) Q:$P(DGRP(.32),U,20)'="Y" "RTN","DGRP62",50,0) S DGDATA=$$SETDAT(.DGRP,14) "RTN","DGRP62",51,0) D EPISODE^DGRP61(DGDATA,GLBL,NUM) "RTN","DGRP62",52,0) Q "RTN","DGRP62",53,0) ; "RTN","DGRP62",54,0) SETDAT(DGRP,FLD) ;Set MSE data into DGDATA "RTN","DGRP62",55,0) N DGX,DGY "RTN","DGRP62",56,0) Q:'$G(FLD) "" "RTN","DGRP62",57,0) S DGX=$G(DGRP(.32)) I DGX="" Q "" "RTN","DGRP62",58,0) S DGY=$G(DGRP(.3291)) "RTN","DGRP62",59,0) Q $P(DGX,U,FLD+2)_U_$P(DGX,U,FLD+3)_U_$P(DGX,U,FLD+1)_U_$P(DGY,U,FLD+1/5)_U_$P(DGX,U,FLD+4)_U_$P(DGX,U,FLD) "RTN","DGRP62",60,0) ; "RTN","DGRP62",61,0) ; "RTN","DGRP62",62,0) HELP ;Help code "RTN","DGRP62",63,0) S X="?" D DISP^XQORM1 W !! "RTN","DGRP62",64,0) Q "RTN","DGRP62",65,0) ; "RTN","DGRP62",66,0) EXIT ;Exit code "RTN","DGRP62",67,0) D CLEAN^VALM10 "RTN","DGRP62",68,0) D CLEAR^VALM1 "RTN","DGRP62",69,0) K ^TMP("DGRP62",$J) "RTN","DGRP62",70,0) Q "RTN","DGRP6CL") 0^38^B77220668 "RTN","DGRP6CL",1,0) DGRP6CL ;ALB/TMK,LBD,ARF - REGISTRATION SCREEN 6 FIELDS Conflict locations ; 6/23/09 4:08pm "RTN","DGRP6CL",2,0) ;;5.3;Registration;**689,751,764,797,1014**;Aug 13, 1993;Build 42 "RTN","DGRP6CL",3,0) ; "RTN","DGRP6CL",4,0) CLLST(DFN,DGCONF,DGPOSS,DGMSE) ; "RTN","DGRP6CL",5,0) ; For patient DFN: "RTN","DGRP6CL",6,0) ; Returns DGCONF array: DGCONF(conf loc)= Start dt^End dt "RTN","DGRP6CL",7,0) ; or, for multiple OEF/OIF/ UNKNOWN OEF/OIF: DGCONF(conf loc-ien) = "RTN","DGRP6CL",8,0) ; Start dt ^ End dt ^ Site source ^ Lock flag "RTN","DGRP6CL",9,0) ; DGCONF(conflict loc,1)=1 if dts inconsistent w/mse dts "RTN","DGRP6CL",10,0) ; DGPOSS = array of possible conflict locations, based on service "RTN","DGRP6CL",11,0) ; episode dts DGPOSS(conf loc)="" "RTN","DGRP6CL",12,0) ; DGMSE = array of military svc episodes "RTN","DGRP6CL",13,0) ; DGMSE(1-n)=fr dt^to dt^branch ien^comp code "RTN","DGRP6CL",14,0) ; "RTN","DGRP6CL",15,0) N DGZ,DGZ0,DIQUIET,FRTO "RTN","DGRP6CL",16,0) S DIQUIET=1 K DGCONF,DGPOSS "RTN","DGRP6CL",17,0) ; Get Military Service Episodes and store in DGMSE array (DG*5.3*797) "RTN","DGRP6CL",18,0) D GETMSE "RTN","DGRP6CL",19,0) ; "RTN","DGRP6CL",20,0) ; Must chk all possible/on-file conf locs for valid mil svc pd "RTN","DGRP6CL",21,0) ; Extract OEF/OIF data "RTN","DGRP6CL",22,0) F DGZ="OEF","OIF","UNK" S DGCONF(DGZ)="" "RTN","DGRP6CL",23,0) D GET^DGENOEIF(DFN,.DGZ,0,"","") "RTN","DGRP6CL",24,0) S DGZ0=0 F S DGZ0=$O(DGZ("IEN",DGZ0)) Q:'DGZ0 S DGZ=$G(DGZ("IEN",DGZ0)) D "RTN","DGRP6CL",25,0) . N DGCONFX "RTN","DGRP6CL",26,0) . Q:'$G(DGZ("FR",DGZ0))&'$G(DGZ("TO",DGZ0)) "RTN","DGRP6CL",27,0) . S DGCONFX=$P("OIF^OEF^UNK",U,+$G(DGZ("LOC",DGZ0)))_"-"_DGZ,DGCONF=DGCONFX,DGCONF($P(DGCONFX,"-"))=$G(DGCONF($P(DGCONFX,"-")))_DGZ_";" "RTN","DGRP6CL",28,0) . F FRTO=1,0 S $P(DGCONF(DGCONFX),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONFX,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS) "RTN","DGRP6CL",29,0) . S $P(DGCONF(DGCONFX),U,3)=$G(DGZ("SITE",DGZ0)) "RTN","DGRP6CL",30,0) . S $P(DGCONF(DGCONFX),U,4)=$G(DGZ("LOCK",DGZ0)) "RTN","DGRP6CL",31,0) F DGCONF="OEF","OIF","UNK" D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS) "RTN","DGRP6CL",32,0) F DGCONF="VIET","LEB","GREN","PAN","GULF","SOM","YUG" F FRTO=1,0 S $P(DGCONF(DGCONF),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONF,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS) "RTN","DGRP6CL",33,0) Q "RTN","DGRP6CL",34,0) ; "RTN","DGRP6CL",35,0) GETMSE ;Get Military Service Data and store in DGMSE array (DG*5.3*797) "RTN","DGRP6CL",36,0) ;DGMSE(1-3)=fr dt^to dt^branch ien^comp code "RTN","DGRP6CL",37,0) ;Get MSE data from MSE sub-file #2.3216, if it's populated "RTN","DGRP6CL",38,0) N MSE,DGZ,DGZ0,DGZ1,DG32,DG3291 "RTN","DGRP6CL",39,0) I $D(^DPT(DFN,.3216)) D Q "RTN","DGRP6CL",40,0) . D GETMSE^DGMSEUTL(DFN,.MSE) "RTN","DGRP6CL",41,0) . S (MSE,DGZ)=0 "RTN","DGRP6CL",42,0) . F S MSE=$O(MSE(MSE)) Q:'MSE S DGZ=DGZ+1,DGMSE(DGZ)=$P(MSE(MSE),U,1,4) "RTN","DGRP6CL",43,0) ;Else get MSE data from .32 and .3291 nodes of Patient file #2 "RTN","DGRP6CL",44,0) S DG32=$G(^DPT(DFN,.32)),DG3291=$G(^(.3291)) "RTN","DGRP6CL",45,0) S DGZ1=0 "RTN","DGRP6CL",46,0) F DGZ=1:1:3 S DGZ0=$S(DGZ=1:"5^5^6^7",DGZ=2:"19^10^11^12",1:"20^15^16^17") D "RTN","DGRP6CL",47,0) . Q:$S($P(DG32,U,+DGZ0)="Y":0,1:'$P(DG32,U,+DGZ0)) "RTN","DGRP6CL",48,0) . S DGZ1=DGZ1+1,DGMSE(DGZ1)=$P(DG32,U,$P(DGZ0,U,3))_U_$P(DG32,U,$P(DGZ0,U,4))_U_$P(DG32,U,$P(DGZ0,U,2))_U_$P(DG3291,U,DGZ) "RTN","DGRP6CL",49,0) Q "RTN","DGRP6CL",50,0) ; "RTN","DGRP6CL",51,0) YN(DGRPX,X) ;Format Yes/No fld in $P(DGRPX,U,X) "RTN","DGRP6CL",52,0) Q $S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO ",$P(DGRPX,"^",X)="U":"UNK",1:" ") "RTN","DGRP6CL",53,0) ; "RTN","DGRP6CL",54,0) DAT(DGRPX,X,Z1) ; Format dt in $P(DGRPX,U,X) for a length of Z1 "RTN","DGRP6CL",55,0) N Z "RTN","DGRP6CL",56,0) S Z=$P(DGRPX,U,X) "RTN","DGRP6CL",57,0) I Z'="" S Z=$$FMTE^XLFDT(Z,"5DZ") "RTN","DGRP6CL",58,0) S:$L(Z)4) D "RTN","DGRP6CL",94,0) . I Z=4 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_"" Q "RTN","DGRP6CL",95,0) . S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_$E($$EXTERNAL^DILFD(2,.325,"",$P(DGMSE(Z),U,3))_$S($P(DGMSE(Z),U,4)'="":"/"_$$SVCCOMP($P(DGMSE(Z),U,4)),1:"")_$J("",30),1,30) "RTN","DGRP6CL",96,0) . S DIR("A",DGCT)=DIR("A",DGCT)_" ("_$S($P(DGMSE(Z),U):$$FMTE^XLFDT($P(DGMSE(Z),U),"5DZ"),1:"missing")_"-"_$S($P(DGMSE(Z),U,2):$$FMTE^XLFDT($P(DGMSE(Z),U,2),"5DZ"),1:"missing")_")" "RTN","DGRP6CL",97,0) S DGCT=DGCT+1,DIR("A",DGCT)=" " "RTN","DGRP6CL",98,0) S DGCT=DGCT+1,DIR("A",DGCT)=$J("",24)_"---- CONFLICT LOCATIONS ----" "RTN","DGRP6CL",99,0) S DGCT=DGCT+1,DIR("A",DGCT)=$J("",34)_"FROM"_$J("",9)_"TO"_$J("",7)_"SOURCE (FOR OEF/OIF)" "RTN","DGRP6CL",100,0) ; DGCONF(DGCONF,"OK")=# entries for OEF/OIF/ UNKNOWN OEF/OIF "RTN","DGRP6CL",101,0) ; that are site-entered "RTN","DGRP6CL",102,0) ; DGCONF(DGCONF,"OK",entry ien)=display #^formatted from dt^ "RTN","DGRP6CL",103,0) ; formatted to dt^inconsistent flag (valid entries for editing) "RTN","DGRP6CL",104,0) S DGEG=0 "RTN","DGRP6CL",105,0) F DGEGS=2,1,3 D "RTN","DGRP6CL",106,0) . S DGCONF=$P("OIF^OEF^UNK",U,DGEGS),DGM=0 "RTN","DGRP6CL",107,0) . S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS) "RTN","DGRP6CL",108,0) . S DGEG=DGEG+1 "RTN","DGRP6CL",109,0) . S DGDISP=$S(DGCONF'="UNK":$J("",8),1:"OEF/OIF ")_DGCONF_": " "RTN","DGRP6CL",110,0) . S DGCT=DGCT+1,DGCTX=DGCT S DIR("A",DGCT)=" "_$E(DG,1)_DGEG_$E(DG,2)_" -"_DGDISP_$$YN($S(DGCONF(DGCONF):"Y",'$D(^DPT(DFN,.3215,0)):"",1:"N"),1) "RTN","DGRP6CL",111,0) . I $G(DGCONF(DGCONF))!$D(DGPOSS(DGCONF)) I '$G(DGRPV),$G(DGCONF(DGCONF,"VEDIT"))'=2,'$G(DGCONF(DGCONF,"NOEDIT")) S:DGCONF'="UNK" DIR(0)=DIR(0)_DGEG_":"_DGCONF_";" "RTN","DGRP6CL",112,0) . S (DGZ,DGCONFS)=DGCONF F S DGCONFS=$O(DGCONFS(DGCONFS)) Q:DGCONFS=""!(DGCONFS'[DGZ) D "RTN","DGRP6CL",113,0) .. N DGUN,DGIEN,STA "RTN","DGRP6CL",114,0) .. S DGIEN=DGCONFS(DGCONFS),DGCONF=DGZ_"-"_DGIEN,DGCONF1=DGZ,DGM=DGM+1 "RTN","DGRP6CL",115,0) .. I $G(DGCONF(DGCONF,1)),DGCTX S $E(DIR("A",DGCTX),1,3)="***" "RTN","DGRP6CL",116,0) .. S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS) "RTN","DGRP6CL",117,0) .. S DGUN=$S($G(DGCONF(DGCONF,"NOEDIT")):1,1:0) "RTN","DGRP6CL",118,0) .. I 'DGUN S DGCONF(DGCONF1,"OK")=$G(DGCONF(DGCONF1,"OK"))+1,DGCONF(DGCONF1,"OK",DGIEN)=DGM_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U),"5DZ")_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U,2),"5DZ") "RTN","DGRP6CL",119,0) .. I DGM>1 S DGCT=DGCT+1 "RTN","DGRP6CL",120,0) .. S DIR("A",DGCT)=$S(DGM>1:$J("",27-$L(DGM)),1:DIR("A",DGCT)_" ")_"("_DGM_") "_$E($$DAT(DGCONF(DGCONF),1,13)_$J("",12),1,12)_$E($$DAT(DGCONF(DGCONF),2,11)_$J("",10),1,10)_" " "RTN","DGRP6CL",121,0) .. S STA=$P(DGCONF(DGCONF),U,3) "RTN","DGRP6CL",122,0) .. S:STA STA=$P($G(^DIC(4,+STA,99)),U) "RTN","DGRP6CL",123,0) .. S DIR("A",DGCT)=DIR("A",DGCT)_$S($P(DGCONF(DGCONF),U,3)="CEV":"",1:"Station #")_$E(STA_$J("",$S('DGUN:6,1:3)),1,$S('DGUN:6,1:3)) "RTN","DGRP6CL",124,0) .. I DGUN S DIR("A",DGCT)=DIR("A",DGCT)_" (No Edit)" "RTN","DGRP6CL",125,0) D LOOPCNF^DGRP6CL1(.DGCONF,.DGPOSS,.DIR) "RTN","DGRP6CL",126,0) S DGCT=DGCT+1,DIR("A",DGCT)=" " "RTN","DGRP6CL",127,0) I $G(DGMSG) S DGCT=DGCT+1,DIR("A",DGCT)="*** ==>OEF/OIF Dates are inconsistent with veteran's military service episodes" "RTN","DGRP6CL",128,0) S DIR("A")="SELECT THE NUMBER OF A CONFLICT LOCATION OR (Q)UIT: " "RTN","DGRP6CL",129,0) S DIR(0)=DIR(0)_"Q:QUIT" "RTN","DGRP6CL",130,0) S DIR("?")="^D HELP^DGRP6CL1($P(DIR(0),U,2))" "RTN","DGRP6CL",131,0) S DIR("B")="QUIT" "RTN","DGRP6CL",132,0) D ^DIR K DIR "RTN","DGRP6CL",133,0) I $D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT "RTN","DGRP6CL",134,0) S DGY=Y,DGY1=$S(Y=2:1,Y=1:2,1:Y) "RTN","DGRP6CL",135,0) I DGY<4 S DGCONF="" "RTN","DGRP6CL",136,0) I DGY'<4 D "RTN","DGRP6CL",137,0) . S DGCONF=$P("OEF^OIF^UNK^VIET^LEB^GREN^PAN^GULF^SOM^YUG",U,DGY) "RTN","DGRP6CL",138,0) . I $G(DGCONF(DGCONF,1)) W !!,"WARNING - THIS CONFLICT IS INCONSISTENT WITH MILITARY SERVICE DATA",! "RTN","DGRP6CL",139,0) . S DIE=2,DA=DFN,DR=$P($T(@DGCONF),";;",2) D:DR'="" ^DIE K DIE,DA,DR "RTN","DGRP6CL",140,0) I DGY=1!(DGY=2) D "RTN","DGRP6CL",141,0) . S DGCONF=$P("OEF^OIF",U,DGY) "RTN","DGRP6CL",142,0) . I '$G(DGCONF(DGCONF,"OK")),$G(DGCONF(DGCONF,"VEDIT"))'=2 D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q ; Add new only valid action "RTN","DGRP6CL",143,0) . I $G(DGCONF(DGCONF,"VEDIT"))=1 S DIR("A")="DO YOU WANT TO (A)DD OR (E)DIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="SA^A:ADD;E:EDIT",DIR("B")="ADD" D ^DIR K DIR "RTN","DGRP6CL",144,0) . I $G(DGCONF(DGCONF,"VEDIT"))=2,$G(DGCONF(DGCONF,"OK")) S DIR("A")="DO YOU WANT TO EDIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR S Y=$S(Y=1:"E",1:Y) "RTN","DGRP6CL",145,0) . Q:$D(DTOUT)!$D(DUOUT) "RTN","DGRP6CL",146,0) . I Y="A" D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q "RTN","DGRP6CL",147,0) . I Y="E" D "RTN","DGRP6CL",148,0) .. N DGXREF,IEN,DIR,X,Y "RTN","DGRP6CL",149,0) .. I DGCONF(DGCONF,"OK")=1 S IEN=+$O(DGCONF(DGCONF,"OK",0)) I IEN D EDCFL^DGRP6CL1(DFN,IEN,$G(DGCONF(DGCONF,"VEDIT"))) Q "RTN","DGRP6CL",150,0) .. S DIR(0)="SA^",DIR("A")="SELECT THE # OF THE "_DGCONF_" CONFLICT PERIOD TO EDIT: ",DIR("A",1)=" " "RTN","DGRP6CL",151,0) .. S Z=0 F S Z=$O(DGCONF(DGCONF,"OK",Z)) Q:'Z S Z0=DGCONF(DGCONF,"OK",Z),DIR(0)=DIR(0)_+Z0_":"_$P(Z0,U,2)_$S($P(Z0,U,3)'="":"-"_$P(Z0,U,3),1:"")_";",DGXREF(+Z0)=Z "RTN","DGRP6CL",152,0) .. S DIR(0)=DIR(0)_"Q:QUIT" "RTN","DGRP6CL",153,0) .. D ^DIR K DIR "RTN","DGRP6CL",154,0) .. I Y D EDCFL^DGRP6CL1(DFN,+$G(DGXREF(+Y)),$G(DGCONF(DGCONF,"VEDIT"))) "RTN","DGRP6CL",155,0) G EN1 "RTN","DGRP6CL",156,0) ; "RTN","DGRP6CL",157,0) QUIT Q "RTN","DGRP6CL",158,0) ; "RTN","DGRP6CL",159,0) EN2 ; Consistency checker re-edit entrypoint for OEF/OIF data "RTN","DGRP6CL",160,0) N DGOEIF,DGZ,DGQUIT,Z,Z0,Y "RTN","DGRP6CL",161,0) D GET^DGENOEIF(DFN,.DGOEIF,2,"",1) "RTN","DGRP6CL",162,0) I $G(DGOEIF("COUNT"))&($O(DGOEIF("OIF",0))!$O(DGOEIF("OEF",0))) D "RTN","DGRP6CL",163,0) . F Z="OEF","OIF" S Z0=0 F S Z0=$O(DGOEIF(Z,Z0)) Q:'Z0 I $G(DGOEIF(Z,Z0,"IEN")) S DGZ(DGOEIF(Z,Z0,"IEN"))="" "RTN","DGRP6CL",164,0) . S (DGQUIT,DGZ)=0 F S DGZ=$O(DGZ(DGZ)) Q:'DGZ D Q:DGQUIT "RTN","DGRP6CL",165,0) .. N DGX,DA,DIE,DR,X "RTN","DGRP6CL",166,0) .. S DGX=$G(^DPT(DFN,.3215,DGZ,0)) "RTN","DGRP6CL",167,0) .. W !!,"OEF/OIF CONFLICT: ",$$EXTERNAL^DILFD(2.3215,.01,"",$P(DGX,U))," FROM: "_$$EXTERNAL^DILFD(2.3215,.02,"",$P(DGX,U,2))," TO: "_$$EXTERNAL^DILFD(2.3215,.03,"",$P(DGX,U,3)) "RTN","DGRP6CL",168,0) .. S DA=DGZ,DA(1)=DFN,DIE="^DPT("_DA(1)_",.3215,",DR=".01;.02R;.03R" D ^DIE I $D(Y) S DGQUIT=1 "RTN","DGRP6CL",169,0) Q "RTN","DGRP6CL",170,0) ; "RTN","DGRP6CL",171,0) SVCCOMP(X) ; Returns display text for service component "RTN","DGRP6CL",172,0) Q $S(X="R":"REGULAR",X="V":"RESERVE",X="G":"GUARD",1:"") "RTN","DGRP6CL",173,0) ; "RTN","DGRP6CL",174,0) VIET ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64; "RTN","DGRP6CL",175,0) LEB ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67; "RTN","DGRP6CL",176,0) GREN ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68; "RTN","DGRP6CL",177,0) PAN ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69; "RTN","DGRP6CL",178,0) GULF ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610; "RTN","DGRP6CL",179,0) SOM ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611; "RTN","DGRP6CL",180,0) YUG ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615; "RTN","DGRP6CL",181,0) OEF ;; "RTN","DGRP6CL",182,0) OIF ;; "RTN","DGRP6CL",183,0) UNK ;; "RTN","DGRP6CL",184,0) ;; "RTN","DGRP6EF") 0^39^B33321348 "RTN","DGRP6EF",1,0) DGRP6EF ;ALB/TMK,EG,BAJ,JLS,ARF - REGISTRATION SCREEN 6 FIELDS FOR EXPOSURE FACTORS ;05 Feb 2015 11:06 AM "RTN","DGRP6EF",2,0) ;;5.3;Registration;**689,659,737,688,909,1014**;Aug 13,1993;Build 42 "RTN","DGRP6EF",3,0) ; "RTN","DGRP6EF",4,0) EN(DFN,QUIT) ; Display Environmental exposure factors/allow to edit "RTN","DGRP6EF",5,0) N I,IND,DG321,DG322,DGCT,DIR,Z,X,Y,DIE,DR,DA,DGNONT "RTN","DGRP6EF",6,0) ; Returns QUIT=1 if ^ entered "RTN","DGRP6EF",7,0) ; "RTN","DGRP6EF",8,0) EN1 D CLEAR^VALM1 "RTN","DGRP6EF",9,0) N DTOUT,DUOUT,TYPE,SEL,L,S,L1,L2,L3 "RTN","DGRP6EF",10,0) S DG321=$G(^DPT(DFN,.321)),DG322=$G(^DPT(DFN,.322)) "RTN","DGRP6EF",11,0) ; "RTN","DGRP6EF",12,0) S DIR(0)="SA^",DGCT=0 "RTN","DGRP6EF",13,0) N DGSSNSTR,DGPTYPE,DGSSN,DGDOB ;ARF-DG*5.3*1014 begin - add standardize patient data to the screen banner "RTN","DGRP6EF",14,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) "RTN","DGRP6EF",15,0) S DGSSN=$P($P(DGSSNSTR,";",2)," ",3) "RTN","DGRP6EF",16,0) S DGDOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","DGRP6EF",17,0) S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1)) "RTN","DGRP6EF",18,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGRP6EF",19,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGRP6EF",20,0) S DGCT=DGCT+1,DIR("A",DGCT)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB "RTN","DGRP6EF",21,0) S DGCT=DGCT+1,DIR("A",DGCT)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE "RTN","DGRP6EF",22,0) ;S DGCT=DGCT+1,DIR("A",DGCT)=$$SSNNM^DGRPU(DFN) ;ARF-DG*5.3*1014 end "RTN","DGRP6EF",23,0) S DGCT=DGCT+1,DIR("A",DGCT)="",$P(DIR("A",DGCT),"=",81)="" "RTN","DGRP6EF",24,0) S DGCT=DGCT+1,DIR("A",DGCT)=$J("",23)_"**** ENVIRONMENTAL FACTORS ****",DGCT=DGCT+1,DIR("A",DGCT)=" " "RTN","DGRP6EF",25,0) S IND=$S('$G(DGRPV):"[]",1:"<>") "RTN","DGRP6EF",26,0) S DGCT=DGCT+1 "RTN","DGRP6EF",27,0) S Z=$E(IND)_"1"_$E(IND,2) "RTN","DGRP6EF",28,0) ; "OTHER" choice added DG*5.3*688 "RTN","DGRP6EF",29,0) ; variables S,L1,L2, & L3 used for dynamic spacing "RTN","DGRP6EF",30,0) S SEL=$P(DG321,U,13),S=$C(32),($P(L1,S,6),$P(L2,S,$S(SEL="O":3,1:2)),$P(L3,S,3))="" "RTN","DGRP6EF",31,0) S TYPE=$S(SEL="K":" (DMZ) ",SEL="V":" (VIET)",SEL="O":" (OTH)",1:$J("",7)) "RTN","DGRP6EF",32,0) S DIR("A",DGCT)=Z_L1_"A/O Exp.: "_$$YN^DGRP6CL(DG321,2)_TYPE_L2_"Reg: "_$$DAT^DGRP6CL(DG321,7,12)_L3_"Exam: "_$$DAT^DGRP6CL(DG321,9,12)_"A/O#: "_$P(DG321,U,10) "RTN","DGRP6EF",33,0) S Z=$E(IND)_"2"_$E(IND,2) "RTN","DGRP6EF",34,0) S DGCT=DGCT+1,DIR("A",DGCT)=Z_" ION Rad.: "_$$YN^DGRP6CL(DG321,3)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG321,11,12)_"Method: " "RTN","DGRP6EF",35,0) S:$P(DG321,U,12)>7 $P(DG321,U,12)="" S DIR("A",DGCT)=DIR("A",DGCT)_$P($T(SELTBL+$P(DG321,U,12)),";;",2) "RTN","DGRP6EF",36,0) S Z=$E(IND)_"3"_$E(IND,2) "RTN","DGRP6EF",37,0) ;Env Contam name changed to SW Asia Conditions, DG*5.3*688 "RTN","DGRP6EF",38,0) S DGCT=DGCT+1,DIR("A",DGCT)=Z_" SW Asia Cond: "_$$YN^DGRP6CL(DG322,13)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG322,14,12)_" Exam: "_$$DAT^DGRP6CL(DG322,15,11) "RTN","DGRP6EF",39,0) S DGNONT=0 I $$GETSTAT^DGNTAPI1(DFN)>2,'$D(^XUSEC("DGNT VERIFY",DUZ)) S DGNONT=1 "RTN","DGRP6EF",40,0) I $G(DGRPV) S DGNONT=1 "RTN","DGRP6EF",41,0) S DGCT=DGCT+1,DIR("A",DGCT)=$S(DGNONT:"<",1:"[")_"4"_$S(DGNONT:">",1:"]")_" N/T Radium: " N DGNT S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") S DIR("A",DGCT)=DIR("A",DGCT)_$G(DGNT("INTRP")) "RTN","DGRP6EF",42,0) ; "RTN","DGRP6EF",43,0) ; DG*5.3*909 Display Camp Lejeune info in entirety "RTN","DGRP6EF",44,0) N DG3217CL S DG3217CL=$G(^DPT(DFN,.3217)) "RTN","DGRP6EF",45,0) N DGCLE S DGCLE=$$CLE^DGENCLEA(DFN) "RTN","DGRP6EF",46,0) I DGCLE=1,$G(^DPT(DFN,.32171))=1 S DGCLE=0 "RTN","DGRP6EF",47,0) S IND=$S('DGCLE:"<>",1:IND) "RTN","DGRP6EF",48,0) S Z=$E(IND)_"5"_$E(IND,2) "RTN","DGRP6EF",49,0) S DGCT=DGCT+1,DIR("A",DGCT)=Z_" Camp Lejeune: " "RTN","DGRP6EF",50,0) S DIR("A",DGCT)=DIR("A",DGCT)_$$YN^DGRP6CL(DG3217CL,1) "RTN","DGRP6EF",51,0) ; "RTN","DGRP6EF",52,0) S DGCT=DGCT+1,DIR("A",DGCT)=" " "RTN","DGRP6EF",53,0) N DGENDTXT S DGENDTXT=$S(DGNONT&DGCLE:"3,5",DGNONT&'DGCLE:"3",'DGNONT&DGCLE:"5",1:"4") ; DG*5.3*909 Determine available choices based also on Camp Lejeune eligibility "RTN","DGRP6EF",54,0) S DIR("A")=$S('$G(DGRPV):"SELECT AN ENVIRONMENTAL FACTOR (1-"_DGENDTXT_") OR (Q)UIT: ",1:"PRESS RETURN TO CONTINUE ") ;DG*5.3*909 Camp Lejeune choice added "RTN","DGRP6EF",55,0) ;Env Contam name changed to SW Asia Conditions, DG*5.3*688 "RTN","DGRP6EF",56,0) S DIR(0)=$S('$G(DGRPV):"SA^1:A/O Exp;2:ION Rad;3:SW Asia Cond;"_$S(DGNONT:"",1:"4:N/T Radium;")_$S(DGCLE:"5:Camp Lejeune;",1:"")_"Q:QUIT",1:"EA") ; DG*5.3*909 Camp Lejeune choice added "RTN","DGRP6EF",57,0) I '$G(DGRPV) S DIR("B")="QUIT" "RTN","DGRP6EF",58,0) I 'DGCLE,$G(^DPT(DFN,.32171))=1,$P($G(XQY0),U)'="DG REGISTRATION VIEW" D "RTN","DGRP6EF",59,0) . S DGHECMSG(1)="Camp Lejeune data has been verified by HEC, please " "RTN","DGRP6EF",60,0) . S DGHECMSG(1)=DGHECMSG(1)_"notify the HEC via" "RTN","DGRP6EF",61,0) . S DGHECMSG(2)="the HEC Alert process if changes are required." "RTN","DGRP6EF",62,0) . S DGHECMSG(3)="Press Return key to continue" "RTN","DGRP6EF",63,0) . S DIR("PRE")="I X=5 W !!,DGHECMSG(1),!,DGHECMSG(2),!!,DGHECMSG(3)" "RTN","DGRP6EF",64,0) . S DIR("PRE")=DIR("PRE")_" R *DGANSWER S X=""""" "RTN","DGRP6EF",65,0) D ^DIR K DIR,DGANSWER,DGHECMSG "RTN","DGRP6EF",66,0) I $G(DGRPV)!$D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT "RTN","DGRP6EF",67,0) S Z="603"_$E("0",2-$L(+Y))_+Y "RTN","DGRP6EF",68,0) S DIE=2,DA=DFN,DR=$P($T(@Z),";;",2) "RTN","DGRP6EF",69,0) ; "RTN","DGRP6EF",70,0) ; DG*5.3*909 Camp Lejeune logic added "RTN","DGRP6EF",71,0) I Y'=5 D:DR'="" ^DIE "RTN","DGRP6EF",72,0) E X DR D AUTOUPD^DGENA2(DFN) "RTN","DGRP6EF",73,0) K DIE,DA,DR "RTN","DGRP6EF",74,0) G EN1 "RTN","DGRP6EF",75,0) ; "RTN","DGRP6EF",76,0) QUIT Q "RTN","DGRP6EF",77,0) ; "RTN","DGRP6EF",78,0) EF(DFN,LIN) ; "RTN","DGRP6EF",79,0) N DG321,DG322,LENGTH,Z,SEQ "RTN","DGRP6EF",80,0) K LIN S (LENGTH,LIN)=0 "RTN","DGRP6EF",81,0) S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322)) "RTN","DGRP6EF",82,0) I $P(DG321,U,2)="Y" D "RTN","DGRP6EF",83,0) . S Z="A/O Exp.",SEQ=1 "RTN","DGRP6EF",84,0) . ;S:'$P(DG321,U,7)!'$P(DG321,U,9)!($P(DG321,U,10)="") Z=Z_"(Incomplete)" "RTN","DGRP6EF",85,0) . S:'$P(DG321,U,7)!('$P(DG321,U,9))="" Z=Z_"(Incomplete)" "RTN","DGRP6EF",86,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",87,0) ; "RTN","DGRP6EF",88,0) I $P(DG321,U,3)="Y" D "RTN","DGRP6EF",89,0) . S Z="Ion Rad.",SEQ=2 "RTN","DGRP6EF",90,0) . S:'$P(DG321,U,11)!($P(DG321,U,12)="") Z=Z_"(Incomplete)" "RTN","DGRP6EF",91,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",92,0) ; "RTN","DGRP6EF",93,0) I $P(DG322,U,13)="Y" D "RTN","DGRP6EF",94,0) . I 'LIN S LIN=LIN+1,LIN(LIN)="" "RTN","DGRP6EF",95,0) . ;Env Contam name changed to SW Asia Conditions, DG*5.3*688 "RTN","DGRP6EF",96,0) . S Z="SW Asia Cond.",SEQ=3 "RTN","DGRP6EF",97,0) . S:'$P(DG322,U,14)!'$P(DG322,U,15) Z=Z_"(Incomplete)" "RTN","DGRP6EF",98,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",99,0) ; N/T Radium Exposure "RTN","DGRP6EF",100,0) N DGNT,DGRPX S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") "RTN","DGRP6EF",101,0) I "NO"'[$G(DGNT("INTRP")) D "RTN","DGRP6EF",102,0) . I 'LIN S LIN=LIN+1,LIN(LIN)="" "RTN","DGRP6EF",103,0) . S SEQ=4 D SETLNEX^DGRP6("N/T Radium ("_$P(DGNT("INTRP"),"YES,",2)_")",SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",104,0) ; DG*5.3*909 Get latest Camp Lejeune information from PATIENT file "RTN","DGRP6EF",105,0) N DG3217CL "RTN","DGRP6EF",106,0) S DG3217CL=$G(^DPT(DFN,.3217)) "RTN","DGRP6EF",107,0) I $P(DG3217CL,U,1)="Y" D "RTN","DGRP6EF",108,0) . I 'LIN S LIN=LIN+1,LIN(LIN)="" "RTN","DGRP6EF",109,0) . S Z="Camp Lejeune",SEQ=5 "RTN","DGRP6EF",110,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",111,0) Q "RTN","DGRP6EF",112,0) ; The following tag is a table of values. Do not change location of values including null at SELTBL+0 "RTN","DGRP6EF",113,0) SELTBL ;; "RTN","DGRP6EF",114,0) ;;NO VALUE "RTN","DGRP6EF",115,0) ;;HIROSHIMA/NAGASAKI "RTN","DGRP6EF",116,0) ;;ATMOSPHERIC NUCLEAR TEST "RTN","DGRP6EF",117,0) ;;H/N AND ATMOSPHERIC TEST "RTN","DGRP6EF",118,0) ;;UNDERGROUND NUCLEAR TEST "RTN","DGRP6EF",119,0) ;;EXP. AT NUCLEAR FACILITY "RTN","DGRP6EF",120,0) ;;OTHER "RTN","DGRP6EF",121,0) 60301 ;;.32102//NO;S:X'="Y" Y="@65";.3213;.32107;.32109;.3211;@65; "RTN","DGRP6EF",122,0) 60302 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66; "RTN","DGRP6EF",123,0) 60303 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612; "RTN","DGRP6EF",124,0) 60304 ;;D REG^DGNTQ(DFN) "RTN","DGRP6EF",125,0) 60305 ;;D ADDEDTCL^DGENCLEA(DFN) "RTN","DGRP6EF",126,0) ;; "RTN","DGRPCF") 0^11^B29623704 "RTN","DGRPCF",1,0) DGRPCF ;ALB/MRL,BAJ,TDM,DJE,ARF - CONSISTENCY OF PATIENT DATA (FILE/EDIT) ;Sep 28, 2017 5:35PM "RTN","DGRPCF",2,0) ;;5.3;Registration;**250,653,786,754,867,935,1014**;Aug 13, 1993;Build 42 "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) ; DGCTZ7= count of inconsistencies found that will prevent Z07 "RTN","DGRPCF",13,0) ; "RTN","DGRPCF",14,0) ; "RTN","DGRPCF",15,0) ; "RTN","DGRPCF",16,0) EN I '$D(DGCT) G KVAR^DGRPCE "RTN","DGRPCF",17,0) ; DG*5.3*653 BAJ modified to delete only inconsistencies numbered 99 or less "RTN","DGRPCF",18,0) N DGADD S DGADD=0 ;786 corrects problem with incorrect header "RTN","DGRPCF",19,0) ;I 'DGCT,$O(^DGIN(38.5,DFN,"I",""),-1)>99 D DELETE G KVAR^DGRPCE "RTN","DGRPCF",20,0) I 'DGCT D DELETE G KVAR^DGRPCE "RTN","DGRPCF",21,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",22,0) S:'$D(^DGIN(38.5,DFN,0)) ^(0)=DFN_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ),DGADD=1 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",23,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)+DGADD) ;786 corrected for incorrect header "RTN","DGRPCF",24,0) I $D(^DGIN(38.5,DFN,"I")) D DELETE "RTN","DGRPCF",25,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",26,0) S ^DGIN(38.5,DFN,"I",0)="^38.51PA^"_DGD2_"^"_DGCT I DGCT,DGEDCN G DIS "RTN","DGRPCF",27,0) G KVAR^DGRPCE "RTN","DGRPCF",28,0) ; "RTN","DGRPCF",29,0) ;DJE DG*5.3*935 - Add Member ID To Vista Registration Banner - RM#879322 (added SSNNM call) "RTN","DGRPCF",30,0) ;ARF DG*5.3*1014 - Create two line banner with preferred name and patient type added "RTN","DGRPCF",31,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 $$SSNNM^DGRPU(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",79)="" W !,X "RTN","DGRPCF",32,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,! "RTN","DGRPCF",33,0) N DGPTYPE,DGSSNSTR,DGPREFNM,DGX,DGMEMID ;DG*5.3*1014 begin "RTN","DGRPCF",34,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) "RTN","DGRPCF",35,0) S DGMEMID=$E($P($P(DGSSNSTR,";",2)," ",2),1,40) "RTN","DGRPCF",36,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGRPCF",37,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGRPCF",38,0) S DGPREFNM=$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"") "RTN","DGRPCF",39,0) D DEM^VADPT "RTN","DGRPCF",40,0) W VADM(1) W:DGPREFNM'="" DGPREFNM W " "_$P(VADM(3),"^",2) "RTN","DGRPCF",41,0) W ! W:DGMEMID'="" DGMEMID_" " W $P(VADM(2),U,2)," ",DGPTYPE "RTN","DGRPCF",42,0) S DGX="",$P(DGX,"=",79)="" W !,DGX ;DG*5.3*1014 end "RTN","DGRPCF",43,0) S (C,DGCT1,DGCT2,DGCT3,DGCTZ7)=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",44,0) I DGCT1!DGCT3 W ! D NOEDIT "RTN","DGRPCF",45,0) I DGCTZ7 W !!,"Inconsistencies followed by [+] will prevent a Z07" "RTN","DGRPCF",46,0) S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1) "RTN","DGRPCF",47,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",48,0) . S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1) "RTN","DGRPCF",49,0) . L +^DPT(DFN):3 E W *7,!!,"Patient is being edited. Try again later." S DGEDCN=0 Q "RTN","DGRPCF",50,0) . D ^DGRPCE "RTN","DGRPCF",51,0) . L -^DPT(DFN) "RTN","DGRPCF",52,0) . S DGEDCN=1 "RTN","DGRPCF",53,0) I $S(($G(DGRETURN)>10):0,$G(DGINC55):1,1:0) D "RTN","DGRPCF",54,0) .N DIR "RTN","DGRPCF",55,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",56,0) .S:Y>0 DGRPV=0 "RTN","DGRPCF",57,0) .S:Y>0 DGRETURN=$G(DGRETURN)+1 "RTN","DGRPCF",58,0) I $S($G(Y)'>0:0,(DGRETURN>11):0,1:1) D ^DGRPV G ^DGRP9 "RTN","DGRPCF",59,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",60,0) I DGER[313 D "RTN","DGRPCF",61,0) . N DIR "RTN","DGRPCF",62,0) . S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #15 to enter Sponsor information? ",DIR("B")="YES" D ^DIR "RTN","DGRPCF",63,0) . S:Y>0 DGRPV=0 "RTN","DGRPCF",64,0) . S:Y>0 DGRETURN=$G(DGRETURN)+1 "RTN","DGRPCF",65,0) I $G(Y)>0&(DGER[313) D ^DGRPV G ^DGRP15 "RTN","DGRPCF",66,0) BUL K DGRETURN,X,Y D ^DGRPCB G KVAR^DGRPCE "RTN","DGRPCF",67,0) ; "RTN","DGRPCF",68,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",69,0) S C=C+1 W:(C#2) ! S X1=$S((C#2):0,1:40) W ?X1,$E(J_" ",1,3),"- " "RTN","DGRPCF",70,0) W X2 I DGKEY(+$E(DGEDIT,J))!(J=407) W "*" S DGCT1=DGCT1+1 "RTN","DGRPCF",71,0) I "^17^55^313^314^"[("^"_+J_"^") W "**" S DGCT3=DGCT3+1 "RTN","DGRPCF",72,0) I +$P(DGRPCOLD,",",2),DGRPCOLD'[(","_J_",") S DGCT2=DGCT2+1 "RTN","DGRPCF",73,0) I $P($G(^DGIN(38.6,J,0)),"^",6) W "+" S DGCTZ7=DGCTZ7+1 "RTN","DGRPCF",74,0) Q "RTN","DGRPCF",75,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",76,0) F I=0:1:4 S DGKEY(I)="" "RTN","DGRPCF",77,0) I $P(DGP(.361),"^",1)="V",X S DGKEY(1)=1 "RTN","DGRPCF",78,0) I $P(DGP(.3),"^",6)]"",X S DGKEY(2)=1 "RTN","DGRPCF",79,0) I $P(DGP(.32),"^",2)]"",X S DGKEY(3)=1 "RTN","DGRPCF",80,0) S:'X DGKEY(4)=1 K DGP Q "RTN","DGRPCF",81,0) ; "RTN","DGRPCF",82,0) DELETE ; Delete all Registration inconsistencies from INCONSISTENT DATA file (#38.5). "RTN","DGRPCF",83,0) ; "RTN","DGRPCF",84,0) ; "RTN","DGRPCF",85,0) N RULE,DIK,DA "RTN","DGRPCF",86,0) ; "RTN","DGRPCF",87,0) S RULE=0,DA="" "RTN","DGRPCF",88,0) S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," "RTN","DGRPCF",89,0) ;F S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE="" Q:RULE>99 S DA=RULE D ^DIK "RTN","DGRPCF",90,0) F S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE="" D "RTN","DGRPCF",91,0) . I RULE>99,OVER99'[(","_RULE_",") Q "RTN","DGRPCF",92,0) . S DA=RULE D ^DIK "RTN","DGRPCF",93,0) Q "RTN","DGRPCF",94,0) ; "RTN","DGRPCF",95,0) NOEDIT ; write explanation of non-editable items "RTN","DGRPCF",96,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",97,0) I DGCT3 W !,"Inconsistencies followed by two (2) asterisks [**] must be corrected by",!,"using the appropriate MAS menu option(s)." "RTN","DGRPCF",98,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",99,0) ;;QUIT "RTN","DGRPE") 0^29^B104572440 "RTN","DGRPE",1,0) DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ,PWC,JAM,JAM,JAM,LEG - REGISTRATIONS EDITS ;23 May 2017 1:51 PM "RTN","DGRPE",2,0) ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797,842,865,871,887,941,985,997,1014**;Aug 13, 1993;Build 42 "RTN","DGRPE",3,0) ; "RTN","DGRPE",4,0) ;DGDR contains a string of edits; edit=screen*10+item # "RTN","DGRPE",5,0) ; "RTN","DGRPE",6,0) ;line tag screen*10+item*1000 = continuation line "RTN","DGRPE",7,0) ; "RTN","DGRPE",8,0) I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN) "RTN","DGRPE",9,0) I DGRPS=8 D ^DGRPEIS,Q Q ; family demographic edit...not conventional!! :) "RTN","DGRPE",10,0) I DGRPS=9 D EDIT9^DGRPEIS2,Q Q ; income screening data ($$$) "RTN","DGRPE",11,0) I DGRPS=5,DGDR["501," D "RTN","DGRPE",12,0) .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q "RTN","DGRPE",13,0) .D REG^IBCNBME(DFN) "RTN","DGRPE",14,0) .Q "RTN","DGRPE",15,0) N QUIT S QUIT=0 "RTN","DGRPE",16,0) I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D I QUIT D Q Q ;Screen 6 subscreens "RTN","DGRPE",17,0) .;Use new ListMan screen for Military Service Episodes (DG*5.3*797) "RTN","DGRPE",18,0) . I DGDR["601," D EN^DGRP61(DFN) ; MSEs "RTN","DGRPE",19,0) . ; D SETDR("601,",.DR) "RTN","DGRPE",20,0) . ; S (DA,Y)=DFN,DIE="^DPT(" "RTN","DGRPE",21,0) . ; D ^DIE I $D(Y) S QUIT=1 "RTN","DGRPE",22,0) . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999) "RTN","DGRPE",23,0) . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT) Q:QUIT ; Conflicts "RTN","DGRPE",24,0) . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT) Q:QUIT ; Exposures "RTN","DGRPE",25,0) I DGRPS=7,(DGDR["702,") D EN^DGRP7CP(DFN,.QUIT) I QUIT D Q Q ;DG*5.3*842 screen 7 cp subscreen "RTN","DGRPE",26,0) I DGRPS=11,(DGDR["1105,") D EN^DGR111(DFN) ;DG*5.3*871 screen 11 HBP subscreen "RTN","DGRPE",27,0) ; DG*5.3*997; jam; Screen 11.5 Caregiver subscreen "RTN","DGRPE",28,0) I DGRPS=11.5,(DGDR["1151,") D EN^DGRP11B(DFN) "RTN","DGRPE",29,0) I DGRPS=11.5,(DGDR["1152,") D EN^DGRP1152A(DFN) ;LEG; DG*5.3*1014 ; for CCP screen <11.5.2> "RTN","DGRPE",30,0) ;-- Tricare screen #15 "RTN","DGRPE",31,0) I DGRPS=15 D EDIT^DGRP15,Q Q "RTN","DGRPE",32,0) ; "RTN","DGRPE",33,0) N DGPH,DGPHFLG "RTN","DGRPE",34,0) K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 "RTN","DGRPE",35,0) G ^DGRPE1:DGRPS>6 "RTN","DGRPE",36,0) I DGRPS=4 D ^DGRPE4 "RTN","DGRPE",37,0) D SETDR(DGDR,.DR) "RTN","DGRPE",38,0) S (DA,Y)=DFN,DIE="^DPT(" "RTN","DGRPE",39,0) D ^DIE "RTN","DGRPE",40,0) ;check for Combat Vet status "RTN","DGRPE",41,0) I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D "RTN","DGRPE",42,0) . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!" "RTN","DGRPE",43,0) . S DIR(0)="EA" D ^DIR K DIR "RTN","DGRPE",44,0) I $G(DGPHFLG)>0 D EDITPH1^DGRPLE() "RTN","DGRPE",45,0) Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA "RTN","DGRPE",46,0) Q "RTN","DGRPE",47,0) ; "RTN","DGRPE",48,0) SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected "RTN","DGRPE",49,0) N DGCT,DGDRS,J1,J2 "RTN","DGRPE",50,0) K DR S DR="",DGDRS="DR",DGCT=0 "RTN","DGRPE",51,0) F I=1:1 S J=$P(DGDR,",",I) Q:J="" S J1=J D:$T(@J1) "RTN","DGRPE",52,0) . S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",53,0) . N J2 "RTN","DGRPE",54,0) . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",55,0) Q "RTN","DGRPE",56,0) ; "RTN","DGRPE",57,0) S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q "RTN","DGRPE",58,0) S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q "RTN","DGRPE",59,0) Q "RTN","DGRPE",60,0) ; "RTN","DGRPE",61,0) SETFLDS(DGDR) ; Set up fields to edit "RTN","DGRPE",62,0) Q "RTN","DGRPE",63,0) ; "RTN","DGRPE",64,0) ;DG*5.3*941 - JAM - Reg Screens 1 and 1.1 new formats - Lines below updated for new field locations "RTN","DGRPE",65,0) 101 ;; "RTN","DGRPE",66,0) 102 ;;1; "RTN","DGRPE",67,0) 103 ;;.091; "RTN","DGRPE",68,0) 104 ;;.134;.135;@21;S X=$$YN1316^DGRPE(DFN);S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)="") Y="@25";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)]"") Y="@24";.133;S:($P($G(^DPT(DFN,.13)),U,16)="Y")&($G(X)="") Y="@21";S Y="@25";@24;.133///@;@25;.1317///NOW; "RTN","DGRPE",69,0) 105 ;;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE; "RTN","DGRPE",70,0) ;DG*5.3*985; JAM - Group 6 added to screen 1 - Preferred Name "RTN","DGRPE",71,0) 106 ;;.2405; "RTN","DGRPE",72,0) ;JAM; DG*5.3*941 - Tag 108 added for QUES^DGRPU1 (ICR 413) to edit the perm address with the home/office phone numbers since patch 941 removed these fields from the Perm Address edit logic "RTN","DGRPE",73,0) 108 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG); "RTN","DGRPE",74,0) 109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^"); "RTN","DGRPE",75,0) 111 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGRED(DFN,.FLG);D RESMVQ^DGREGCP1(DFN); "RTN","DGRPE",76,0) ;JAM, DG*5.3*941, Home and Office phone numbers not associated with Perm Address - set flg(1)=0 so we don't edit phone numbers with permanent address "RTN","DGRPE",77,0) ;CLT, Copy Permanent Mailing Address to Residential Address ;DG*5.3*941 "RTN","DGRPE",78,0) ; If Perm address is not null, go to update of address. Otherwise give user option to copy residential address to perm. "RTN","DGRPE",79,0) ; and if address is copied quit, otherwise continue with entering in a perm address. "RTN","DGRPE",80,0) 112 ;;S:$G(^DPT(DFN,.11))'="" Y="@30";D DR11^DGRPE S:$G(^DPT(DFN,.11))'="" Y="@31"; "RTN","DGRPE",81,0) 112000 ;;@30;N FLG S FLG(1)=0,FLG(2)=1 D EN^DGREGAED(DFN,.FLG) D PERMMVQ^DGREGCP1(DFN);@31; "RTN","DGRPE",82,0) 113 ;;.12105TEMP MAILING ADDRESS ACTIVE;S:X="N" Y="@15";S DIE("NO^")="";.1217TEMP MAILING ADDRESS START DATE;.1218TEMP MAILING ADDRESS END DATE;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET Y=.12105;@15;K DIE("NO^"); "RTN","DGRPE",83,0) 114 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105; "RTN","DGRPE",84,0) ; DG*5.3*1014;jam; add K ^DIE("NO^") after enty of confidential address so if we loop back to beginning, we can exit "RTN","DGRPE",85,0) 114000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) K DIE("NO^") S:'RET Y=.14105;@111;K DIE("NO^"); "RTN","DGRPE",86,0) 201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE; "RTN","DGRPE",87,0) 202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^"); "RTN","DGRPE",88,0) 203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06); "RTN","DGRPE",89,0) 205 ;;.181; "RTN","DGRPE",90,0) ; patch DG*5.3*985 - NOK - Tags 301 and 302 for Primary and Secondary NOK: phone number no longer copied when copying patient address - phone number entered on its own "RTN","DGRPE",91,0) ; patch DG*5.3*997; jam; Tags 301-305 modified to allow for copy or entry of Country/foreign addresses "RTN","DGRPE",92,0) ;301 ;;.211;S:X']"" Y="@31";.212;D DR301^DGRPE S:DG4=1 Y=.213;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y="@30";.213;K DG4;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;@30;.219;.21011;@31; "RTN","DGRPE",93,0) ; "RTN","DGRPE",94,0) 301 ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y="@30";.221//USA;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215;.216;S DGADD=".21" D DR301^DGRPE S:DG4=1 Y=.222;.217;.2207;S Y="@30";.222;.223;@30;K DG4;.219;.21011;@31; "RTN","DGRPE",95,0) ;302 ;;.2191;S:X']"" Y="@32";.2192;D DR301^DGRPE S:DG4=1 Y=.2193;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y="@30"; "RTN","DGRPE",96,0) ;302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;@30;.2199;.211011;@32; "RTN","DGRPE",97,0) 302 ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y="@301"; "RTN","DGRPE",98,0) 302000 ;;.2101//USA;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195;.2196;S DGADD=".211" D DR301^DGRPE S:DG4=1 Y=.2102;.2197;.2203;S Y="@301";.2102;.2103;@301;K DG4;.2199;.211011;@32; "RTN","DGRPE",99,0) ; "RTN","DGRPE",100,0) 303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34; "RTN","DGRPE",101,0) ;303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341; "RTN","DGRPE",102,0) ;303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35; "RTN","DGRPE",103,0) ;303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2; "RTN","DGRPE",104,0) ; "RTN","DGRPE",105,0) 303000 ;;S:$G(DGX1) Y="@341";.3306//USA;.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335;.336; S DGADD=".33" D DR301^DGRPE S:DG4=1 Y=.3307;.337;.2201;S Y="@361";.3307;.3308;@361;K DG4;.339;.33011;S DGX1=2;@341; "RTN","DGRPE",106,0) 303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);.3306///^S X=$P(DGX2,U,12);.3307///^S X=$P(DGX2,U,13);.3308///^S X=$P(DGX2,U,14);@35; "RTN","DGRPE",107,0) 303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2; "RTN","DGRPE",108,0) ; "RTN","DGRPE",109,0) ;304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36; "RTN","DGRPE",110,0) 304 ;;.3311;S:X']"" Y="@36";.3312;.331012//USA;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315;.3316; S DGADD=".331" D DR301^DGRPE S:DG4=1 Y=.331013;.3317;.2204;S Y="@37";.331013;.331014;@37;K DG4;.3319;.331011;@36; "RTN","DGRPE",111,0) ; "RTN","DGRPE",112,0) 305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@372";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@372;.341;S:X']"" DGX1=2,Y="@371";.342;@371; "RTN","DGRPE",113,0) ;305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38; "RTN","DGRPE",114,0) ;305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381 "RTN","DGRPE",115,0) ;305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2; "RTN","DGRPE",116,0) 305000 ;;S:$G(DGX1) Y="@38";.34012//USA;.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345;.346; S DGADD=".34" D DR301^DGRPE S:DG4=1 Y=.34013;.347;.2202;S Y="@391";.34013;.34014;@391;K DG4;.349;.34011;S DGX1=2;@38; "RTN","DGRPE",117,0) 305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);.34012///^S X=$P(DGX2,U,12);.34013///^S X=$P(DGX2,U,13);.34014///^S X=$P(DGX2,U,14);@381 "RTN","DGRPE",118,0) 305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2; "RTN","DGRPE",119,0) ; "RTN","DGRPE",120,0) 401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41; "RTN","DGRPE",121,0) 402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42; "RTN","DGRPE",122,0) 501 ;; "RTN","DGRPE",123,0) 502 ;;.381;.382///NOW; "RTN","DGRPE",124,0) 503 ;;.383; "RTN","DGRPE",125,0) 601 ;;Q; "RTN","DGRPE",126,0) 602 ;;Q; "RTN","DGRPE",127,0) 603 ;;Q; "RTN","DGRPE",128,0) 604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62; "RTN","DGRPE",129,0) 605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63; "RTN","DGRPE",130,0) 606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132; "RTN","DGRPE",131,0) 607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614; "RTN","DGRPE",132,0) 608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162; "RTN","DGRPE",133,0) AD ; DG*5.3*1014;jam; Replace code below - store data via Fileman and not direct global sets "RTN","DGRPE",134,0) ; Input: DGADD =.21 for copying to NOK "RTN","DGRPE",135,0) ; =.211 for copying to NOK2 "RTN","DGRPE",136,0) ; "RTN","DGRPE",137,0) ;N DGZ4,DGPC "RTN","DGRPE",138,0) ; patch DG*5.3*985; jam - NOK - do not copy phone number when copying patient address. "RTN","DGRPE",139,0) ; patch DG*5.3*997; jam - copy country/province/postal code "RTN","DGRPE",140,0) ;S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10) "RTN","DGRPE",141,0) ;S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_$P(Y,U,9)_U_$P(Y,U,10)_U_$P(Y,U,11)_U_$P(X,U,10)_U_$P(X,U,8)_U_$P(X,U,9) "RTN","DGRPE",142,0) ;I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4 "RTN","DGRPE",143,0) ;K DGADD,DGPHONE Q "RTN","DGRPE",144,0) N DGPMA,DGDATA,DGERROR "RTN","DGRPE",145,0) ; get Perm Address "RTN","DGRPE",146,0) S DGPMA=$S($D(^DPT(DFN,.11)):^(.11),1:"") "RTN","DGRPE",147,0) ; set fields for copying Perm address to NOK "RTN","DGRPE",148,0) I DGADD=.21 D "RTN","DGRPE",149,0) . S DGDATA(.221)=$P(DGPMA,U,10) "RTN","DGRPE",150,0) . S DGDATA(.213)=$P(DGPMA,U,1) "RTN","DGRPE",151,0) . S DGDATA(.214)=$P(DGPMA,U,2) "RTN","DGRPE",152,0) . S DGDATA(.215)=$P(DGPMA,U,3) "RTN","DGRPE",153,0) . S DGDATA(.216)=$P(DGPMA,U,4) "RTN","DGRPE",154,0) . S DGDATA(.217)=$P(DGPMA,U,5) "RTN","DGRPE",155,0) . S DGDATA(.218)=$P(DGPMA,U,6) "RTN","DGRPE",156,0) . S DGDATA(.222)=$P(DGPMA,U,8) "RTN","DGRPE",157,0) . S DGDATA(.223)=$P(DGPMA,U,9) "RTN","DGRPE",158,0) ; set fields for copying Perm address to NOK2 "RTN","DGRPE",159,0) I DGADD=.211 D "RTN","DGRPE",160,0) . S DGDATA(.2101)=$P(DGPMA,U,10) "RTN","DGRPE",161,0) . S DGDATA(.2193)=$P(DGPMA,U,1) "RTN","DGRPE",162,0) . S DGDATA(.2194)=$P(DGPMA,U,2) "RTN","DGRPE",163,0) . S DGDATA(.2195)=$P(DGPMA,U,3) "RTN","DGRPE",164,0) . S DGDATA(.2196)=$P(DGPMA,U,4) "RTN","DGRPE",165,0) . S DGDATA(.2197)=$P(DGPMA,U,5) "RTN","DGRPE",166,0) . S DGDATA(.2198)=$P(DGPMA,U,6) "RTN","DGRPE",167,0) . S DGDATA(.2102)=$P(DGPMA,U,8) "RTN","DGRPE",168,0) . S DGDATA(.2103)=$P(DGPMA,U,9) "RTN","DGRPE",169,0) I $$UPD^DGENDBS(2,DFN,.DGDATA,.DGERROR) "RTN","DGRPE",170,0) K DGADD "RTN","DGRPE",171,0) Q "RTN","DGRPE",172,0) ; "RTN","DGRPE",173,0) DR109 ;Drop through (use same logic as DR203) "RTN","DGRPE",174,0) DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;" "RTN","DGRPE",175,0) S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;" "RTN","DGRPE",176,0) Q "RTN","DGRPE",177,0) DR11 ;clt; DG*5.3*941 - Called from line tag 112 if Perm address is empty "RTN","DGRPE",178,0) Q:$G(^DPT(DFN,.115))="" "RTN","DGRPE",179,0) ; If Residential Address exists, give user the option of copying residential to permanent address "RTN","DGRPE",180,0) W !,"The Patient has no Permanent Mailing Address." "RTN","DGRPE",181,0) D RESMVQ^DGREGCP1(DFN) "RTN","DGRPE",182,0) Q "RTN","DGRPE",183,0) DR111 ; Set DR string for Confidential Address categories "RTN","DGRPE",184,0) S DR(2,2.141)=".01;1//YES;" "RTN","DGRPE",185,0) ;S DR(2,2.14)=".01;1//"_"YES" "RTN","DGRPE",186,0) Q "RTN","DGRPE",187,0) DR207 ; DR string for preferred language ;*///* "RTN","DGRPE",188,0) S DR(2,2.07)=".01;.02//ENGLISH;D LANGDEL^DGRPE" "RTN","DGRPE",189,0) Q "RTN","DGRPE",190,0) ;DR301 ; set up variables for foreign address - REMOVE FOR PATCH 997 - REPLACED BELOW "RTN","DGRPE",191,0) N DG3,DG33 "RTN","DGRPE",192,0) S DG4=0 "RTN","DGRPE",193,0) S DG3=$P($G(^DPT(DFN,.11)),U,10) "RTN","DGRPE",194,0) S DG33=$O(^HL(779.004,"B","USA","")) "RTN","DGRPE",195,0) I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1 "RTN","DGRPE",196,0) Q "RTN","DGRPE",197,0) ; "RTN","DGRPE",198,0) DR301 ; jam; DG*5.3*997 - check for foreign address "RTN","DGRPE",199,0) N DG3,DG33 "RTN","DGRPE",200,0) S DG4=0 "RTN","DGRPE",201,0) S DG3=$P($G(^DPT(DFN,DGADD)),U,12) "RTN","DGRPE",202,0) S DG33=$O(^HL(779.004,"B","USA","")) "RTN","DGRPE",203,0) I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1 "RTN","DGRPE",204,0) Q "RTN","DGRPE",205,0) ; "RTN","DGRPE",206,0) PRF ; Write Proof needed for FV "RTN","DGRPE",207,0) W !?4,$C(7),"Proof is required for Filipino vet." "RTN","DGRPE",208,0) Q "RTN","DGRPE",209,0) ; "RTN","DGRPE",210,0) SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA "RTN","DGRPE",211,0) ; array with the BOS and component data for the SEQ military service "RTN","DGRPE",212,0) ; episode (1-3) "RTN","DGRPE",213,0) N I,Q,Z "RTN","DGRPE",214,0) K DIPA(32,SEQ) "RTN","DGRPE",215,0) S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291)) "RTN","DGRPE",216,0) S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U) "RTN","DGRPE",217,0) Q "RTN","DGRPE",218,0) ; "RTN","DGRPE",219,0) WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will "RTN","DGRPE",220,0) ; be deleted "RTN","DGRPE",221,0) ; Returns Y to skip component if the component should not be asked "RTN","DGRPE",222,0) ; for this branch of service "RTN","DGRPE",223,0) N Z "RTN","DGRPE",224,0) I '$$CMP(X) S Y="@601"_SEQ "RTN","DGRPE",225,0) S Z=$G(DIPA(32,SEQ)) "RTN","DGRPE",226,0) Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X) "RTN","DGRPE",227,0) ; "RTN","DGRPE",228,0) I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",! "RTN","DGRPE",229,0) Q "RTN","DGRPE",230,0) ; "RTN","DGRPE",231,0) CMP(X) ; Function to determine if service component is valid for "RTN","DGRPE",232,0) ; branch of service ien in X 0 = invalid 1 = valid "RTN","DGRPE",233,0) ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS "RTN","DGRPE",234,0) Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0) "RTN","DGRPE",235,0) ; "RTN","DGRPE",236,0) YN1316(DFN) ;Email address indicator - DG*5.3*865 "RTN","DGRPE",237,0) N %,RSLT "RTN","DGRPE",238,0) S DIE("NO^")="" "RTN","DGRPE",239,0) P1316 ; "RTN","DGRPE",240,0) S %=0 "RTN","DGRPE",241,0) W !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N" "RTN","DGRPE",242,0) D YN^DICN "RTN","DGRPE",243,0) I %=0 W !," If the patient has a valid Email Address, please answer with 'Yes'.",!," If no Email Address please answer with 'No'." G P1316 "RTN","DGRPE",244,0) I %=-1 W !," EXIT NOT ALLOWED ??" G P1316 "RTN","DGRPE",245,0) S RSLT=$S(%=1:"Y",%=2:"N") "RTN","DGRPE",246,0) N FDA,IENS "RTN","DGRPE",247,0) Q:'$G(DFN) "RTN","DGRPE",248,0) S IENS=DFN_",",FDA(2,IENS,.1316)=RSLT "RTN","DGRPE",249,0) D FILE^DIE("","FDA") "RTN","DGRPE",250,0) Q RSLT "RTN","DGRPE",251,0) ; "RTN","DGRPE",252,0) INPXF207 ; Input transform for field 7 in file ;*///* "RTN","DGRPE",253,0) I $L(X)>60!($L(X)<1) K X Q "RTN","DGRPE",254,0) I X="*" S X="DECLINED TO ANSWER",FMT="?($X+3)" D EN^DDIOL(X,"",FMT) Q "RTN","DGRPE",255,0) I $D(X) DO "RTN","DGRPE",256,0) .N DIC S DIC(0)="EQMN",DIC="^DI(.85,",DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" "RTN","DGRPE",257,0) .D ^DIC S:+Y>0 X=$P(^DI(.85,+Y,0),U) I +Y<0 K X "RTN","DGRPE",258,0) Q "RTN","DGRPE",259,0) ; "RTN","DGRPE",260,0) XHELP207 ; This is a screen to be sure the language is a 'living' language, i.e.in use today and that it has the required 2-character code. ;*///* "RTN","DGRPE",261,0) N X S X="?" N DIC S DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" S DIC(0)="EQM",DIC="^DI(.85," D ^DIC "RTN","DGRPE",262,0) Q "RTN","DGRPE",263,0) ; "RTN","DGRPE",264,0) LANGDEL ; If no language entered, remove the stub record ;*///* "RTN","DGRPE",265,0) Q:'$G(D1) "RTN","DGRPE",266,0) N X S X=$G(^DPT(DFN,.207,D1,0)) Q:X="" "RTN","DGRPE",267,0) I $P(X,U,2)="" DO "RTN","DGRPE",268,0) .W $C(7),!!,"No language was entered. Record deleted!",! H 3 "RTN","DGRPE",269,0) .S DIK="^DPT(DFN,.207,",DA=D1 D ^DIK K DIK "RTN","DGRPE",270,0) Q "RTN","DGRPH") 0^36^B32305129 "RTN","DGRPH",1,0) DGRPH ;ALB/MRL,TMK,JAM,ARF,ASF,LEG - REGISTRATION HELP ROUTINE ;Mar 10, 2020@19:19 "RTN","DGRPH",2,0) ;;5.3;Registration;**114,343,397,415,489,545,638,624,689,842,941,985,997,1014**;Aug 13, 1993;Build 42 "RTN","DGRPH",3,0) ; "RTN","DGRPH",4,0) S DGRPH="" D H^DGRPU K DGRPH "RTN","DGRPH",5,0) ;LEG; DG*5.3*997; cosmetically adjusted the spacing around the word "listing" to account for if "and edit" text was/wasn't included "RTN","DGRPH",6,0) W !,"Enter '^' to stop the display ",$S(DGRPV:"",1:"and edit "),"of data, '^N' to jump to screen #N (see ",$S(DGRPV:"listing ",1:""),!,$S(DGRPV:"",1:"listing "),"below), to continue on to the next available screen" "RTN","DGRPH",7,0) I DGRPV,DGRPS'=11.5 W "." G M ;LEG; DG*5.3*1014 - added <11.5> processing "RTN","DGRPH",8,0) W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters. Those groups enclosed in brackets ""[]"" are editable while those",!,"enclosed in arrows ""<>"" are not." "RTN","DGRPH",9,0) W " Enter 'ALL' to edit all editable data",!,"elements on the screen." "RTN","DGRPH",10,0) M I DGRPS=9,DGRPSEL="V" W !!,"You may precede your selection with 'V' to denote veteran." "RTN","DGRPH",11,0) I DGRPS=9,DGRPSEL]"V" W !!,"To edit a specific column, enter 'V'",$S($D(DGREL("S")):", 'S'",1:""),$S($D(DGREL("D")):", 'D'",1:"")," in front of the selected items." "RTN","DGRPH",12,0) ;ASF; DG*5.3*997; added screen 11.5 "RTN","DGRPH",13,0) S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^DGRPV S DGRPCM=0 D:DGRPS=1.1 A1 D:DGRPS=11.5 A2 D:DGRPS'=1.1&(DGRPS'?1"11.5".E) @DGRPS D:$S(DGRPS<12:1,DGRPS=14:1,1:0) W D S W ! F I=$Y:1:20 W ! "RTN","DGRPH",14,0) ;S Z="Press RETURN key",DGRPCM=1 D WW^DGRPV S DGRPCM=0 W " to EXIT Screen ",DGRPS," HELP " R X:DTIME S X="" Q "RTN","DGRPH",15,0) S DGRPW=0 W "Press " S Z="",DGRPCM=1 D WW^DGRPV W " KEY " S Z="TO EXIT" D WW^DGRPV W " SCREEN ",DGRPS," " S Z="HELP" D WW^DGRPV W " " R X:DTIME S (DGRPCM,DGRPW)=0 Q "RTN","DGRPH",16,0) ;JAM; DG*5.3*941; Groups on screen 1 and 1.1 have changed so update help text to reflect new locations "RTN","DGRPH",17,0) ;ARF; DG*5.3*985; Add 'Birth' to 'Sex' and 'Preferred Name of Patient' to the Help screen for PATIENT DEMOGRAPHIC SCREEN 1 "RTN","DGRPH",18,0) 1 S X="Name, SSN, DOB, Birth Sex^Alias Name & SSN (if applicable)^Remarks concerning this patient^Cell Phone, Pager, E-Mail^Date & Time, Preferred Language^Preferred Name of Patient" Q "RTN","DGRPH",19,0) A1 S X="Residential Address^Permanent Mailing Address^Temporary Mailing Address^Confidential Mailing Address" Q "RTN","DGRPH",20,0) 2 S X="POB, Parents, etc.^Dates/Locations of Previous Care^Race and Ethnicity^Date of Death Information" Q "RTN","DGRPH",21,0) 3 S X="Primary Next-of-Kin^Secondary Next-of-Kin^Primary Emergency Contact^Secondary Emergency Contact^Designee to receive personal effects" Q "RTN","DGRPH",22,0) 4 S X="Applicant Employer, Address^Spouses Employer, Address" Q "RTN","DGRPH",23,0) 5 S X="Unexpired Insurance Policies^Eligibile for Medicaid" Q "RTN","DGRPH",24,0) 6 S X="Service History^Conflict Locations^Exposure Factors^Prisoner of War^Combat^Military Retirement/Disability^Dental History^Purple Heart Recipient^Medal of Honor^Class II Dental Indicator" Q "RTN","DGRPH",25,0) 7 S X="Patient Type, SC Data, Claim Info^VA Monetary Benefits^POS, Eligibility Code(s)^SC Conditions relayed by applicant" Q "RTN","DGRPH",26,0) 8 S X="Spouse's Demographic Info^Dependents' Demographic Info" Q "RTN","DGRPH",27,0) 9 S X="Social Security^U.S. Civil Service^U.S. Railroad Retirement^Military Retirement^Unemployment^Other Retirement^Total Employment Income^Interest,Dividend,Annuity^Workers Comp or Black Lung^Other Income" Q "RTN","DGRPH",28,0) 10 S X="Ineligible Patient Information^Missing Patient Information" Q "RTN","DGRPH",29,0) 11 S X="Eligibility Verification^Monetary Benefits Verification^Service Record Verification^Rated Disabilities (VA)^VHA Profiles (VHAP)" Q "RTN","DGRPH",30,0) A2 S X="Caregiver Status Data^Community Care Program (CCP) Collateral Data" Q ;LEG; DG*5.3*1014 added CCP "RTN","DGRPH",31,0) 12 W !,"Four most recent admission episodes on file for this applicant are displayed",!,"in inverse order." Q "RTN","DGRPH",32,0) 13 W !,"Four most recent applications for care (registrations) are displayed in",!,"inverse order." Q "RTN","DGRPH",33,0) 14 S X="Clinics in which actively enrolled^Pending (future) appointments" Q "RTN","DGRPH",34,0) ;LEG; DG*5.3*1014 added Q to end of line to resolve double AVAILABLE SCREENS display "RTN","DGRPH",35,0) 15 W !,"Sponsor information is displayed for patients." Q "RTN","DGRPH",36,0) S W ! S Z="AVAILABLE SCREENS",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRPH",37,0) ;jam; DG*5.3*941; New wording for screens 1 and 1.1 "RTN","DGRPH",38,0) S X="Patient Demographic^Additional Patient Demographic^Patient^Contact^Employment^Insurance^Service Record^Eligibility^Family Demographic^Income Screening^Missing/Ineligible^Eligibility Verification^" "RTN","DGRPH",39,0) ;LEG; DG*5.3.997 ;added new Additional Eligibility Verification screen "RTN","DGRPH",40,0) S X=X_"Additional Elig Verification^Admission Info^Application Info^Appointment Info^Sponsor Demographics" "RTN","DGRPH",41,0) ;S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(DGRPVV,I) S C=C+1,Z="^"_I,DGRPW=(C#2) D WW^DGRPV S Z=$S(I?1N:" ",1:" ")_J_" Data",Z1=$S((C#2)&(I?1N):36,(C#2):35,1:1) D WW1^DGRPV:(C#2) I '(C#2) W Z "RTN","DGRPH",42,0) N DGJ "RTN","DGRPH",43,0) S DGJ="" "RTN","DGRPH",44,0) S C=0 F I=1:1 S DGJ=$O(DGRPVV(DGJ)) Q:DGJ="" I '$E(DGRPVV,DGJ) D "RTN","DGRPH",45,0) .S C=C+1,Z="^"_DGJ,DGRPW=(C#2) "RTN","DGRPH",46,0) .D WW^DGRPV "RTN","DGRPH",47,0) .;jam; DG*5.3*941; Change column position to fit the text of the new wording for screens 1 and 1.1 "RTN","DGRPH",48,0) .S Z1=$S((C#2)&(DGJ?1N):33,(C#2):32,1:1) "RTN","DGRPH",49,0) .S Z=$S(DGJ?1N:" ",1:" ")_$P(X,U,I)_" Data" "RTN","DGRPH",50,0) .;LEG; DG*5.3*997; added to Available Screens list "RTN","DGRPH",51,0) .S:DGJ=11.5 Z=" Add'l Elig Verification Data",Z1=30 "RTN","DGRPH",52,0) .D WW1^DGRPV:(C#2) "RTN","DGRPH",53,0) .I '(C#2) W Z "RTN","DGRPH",54,0) Q "RTN","DGRPH",55,0) W ;LEG; DG*5.3*1014 added C2L check for string too long if in column 2 "RTN","DGRPH",56,0) F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,DGRPW=(I#2) D:'DGRPW C2L D WW^DGRPV S Z=$S(I<10:" ",1:" ")_J,Z1=$S((I#2)&(I>10):36,(I#2):37,1:1) D WW1^DGRPV "RTN","DGRPH",57,0) W:'DGRPW ! ;'((I-1)#2) ! ;Q "RTN","DGRPH",58,0) Q "RTN","DGRPH",59,0) ;LEG; DG*5.3*1014 "RTN","DGRPH",60,0) C2L ;checks if string is too long for end of line display "RTN","DGRPH",61,0) I ($L(J)+$S(I>10:36,1:37))>80 S DGRPW=1 "RTN","DGRPH",62,0) Q "RTN","DGRPP") 0^30^B21625700 "RTN","DGRPP",1,0) DGRPP ;ALB/MRL,AEG,LBD,ASF,LEG - REGISTRATION SCREEN PROCESSOR ;Apr 05, 2020@15:16 "RTN","DGRPP",2,0) ;;5.3;Registration;**92,147,343,404,397,489,689,688,828,797,871,997,1014**;Aug 13, 1993;Build 42 "RTN","DGRPP",3,0) ; "RTN","DGRPP",4,0) ;DGRPS : Screen to edit "RTN","DGRPP",5,0) ;DGRPSEL : If screen 9 (income screening) set to allowable selections "RTN","DGRPP",6,0) ; (V=Veteran, S=Spouse, D=Dependents) "RTN","DGRPP",7,0) ;DGRPSELT : If screen 9, type selected (V, S, or D or all if none specified) "RTN","DGRPP",8,0) ;DGRPAN : Selectable items on screen for edit (user input) "RTN","DGRPP",9,0) ;DGRPANP : Selectable items for print on page footer - i.e. 1-3 "RTN","DGRPP",10,0) ;DGRPANN : Selected item(s) extrapolated (screen_item) "RTN","DGRPP",11,0) ; "RTN","DGRPP",12,0) ; "RTN","DGRPP",13,0) EN ; "RTN","DGRPP",14,0) D:'$$BEGUPLD^DGENUPL3(DFN) "RTN","DGRPP",15,0) .D UNLOCK^DGENPTA1(DFN) "RTN","DGRPP",16,0) .D CKUPLOAD^DGENUPL3(DFN) "RTN","DGRPP",17,0) .I $$LOCK^DGENPTA1(DFN) "RTN","DGRPP",18,0) D ENDUPLD^DGENUPL3(DFN) "RTN","DGRPP",19,0) ;jam; Patch DG*5.3*997 - include screen 11.5 group 1 to be editable when in View Reg option (DGRPV=1) "RTN","DGRPP",20,0) D Q1,WHICH^DGRPP1 W ! K DGRP S DGRPAN="" F I=1:1:$L(DGRPVV(DGRPS)) I $S('DGRPV:1,DGRPS=6:I=1!(I=2)!(I=3),DGRPS=11:I=5,DGRPS=11.5:I=1!(I=2),1:0) S:'$E(DGRPVV(DGRPS),I) DGRPAN=DGRPAN_I_"," ;LEG; DG*5.3*1014 added I=2 for <11.5> "RTN","DGRPP",21,0) D STR^DGRPP1 F I=$Y:1:20 W ! "RTN","DGRPP",22,0) ; remove COPY option DG*5.3*688 "RTN","DGRPP",23,0) I ("8^9"[DGRPS),($G(DGEFDT)'=DT) S Z="E" D W W "=ENTER new "_(DGISYR+1)_" data," "RTN","DGRPP",24,0) S Z="" D W W " to ",$S(DGRPS5) D CHOICE "RTN","DGRPP",44,0) I DGDR']"" D ^DGRPH S X=DGRPS G SCRX "RTN","DGRPP",45,0) D ^DGRPE G QQ:'$D(^DPT(DFN,0)) S X=DGRPS G SCRX "RTN","DGRPP",46,0) Q I 'DGELVER D:$S(DGRPOUT:0,'$D(DGRPV):0,'DGRPV:1,1:0) LT^DGRPP1 "RTN","DGRPP",47,0) K DGDEP,DGINC,DGINR,DGMTC,DGMTED,DGREL,DGTOT,DGSP "RTN","DGRPP",48,0) K DGCH,DGGTOT,DGIRI,DGPRI,DGRPSE1,DGNOCOPY "RTN","DGRPP",49,0) D SENSCHK "RTN","DGRPP",50,0) I 'DGRPV S DGEDCN=1 D ^DGRPC K DGEDCN "RTN","DGRPP",51,0) QQ K DGRPNA,DGRPS,DGRPTYPE,DGRPU,DGRPV,DGRPVV,DGRPW,DGVI,DGVO,DGRPCM,DGELVER,DGRPLAST "RTN","DGRPP",52,0) Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGDR,DGRP,DGRPAG,DGRPAN,DGRPANN,DGRPANP,DGRPD,DGRPSEL,DGRPSELT,DGRPVR,DGRPX,DGAAC "RTN","DGRPP",53,0) K DIRUT,DUOUT,DTOUT "RTN","DGRPP",54,0) K DIC,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1 I $D(DFN)#2,DFN]"" S:$D(^DPT(DFN,0)) DA=DFN "RTN","DGRPP",55,0) Q "RTN","DGRPP",56,0) ; "RTN","DGRPP",57,0) SENSCHK ; check whether patient record should be made sensitive "RTN","DGRPP",58,0) N ELIG,FLAG,X "RTN","DGRPP",59,0) S ELIG=0,FLAG=0 "RTN","DGRPP",60,0) I '$D(^DPT($G(DFN),0)) Q ; patient not defined "RTN","DGRPP",61,0) I $D(^DGSL(38.1,DFN,0)) Q ; patient already in dg security log file "RTN","DGRPP",62,0) S X=$S($D(^DPT(DFN,"TYPE")):+^("TYPE"),1:"") I $D(^DG(391,+X,0)),$P(^(0),"^",4) D SEC Q:FLAG "RTN","DGRPP",63,0) F S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:'ELIG D Q:FLAG "RTN","DGRPP",64,0) . S X=$G(^DIC(8,ELIG,0)) "RTN","DGRPP",65,0) . I $P(X,"^",12) D SEC "RTN","DGRPP",66,0) Q "RTN","DGRPP",67,0) ; "RTN","DGRPP",68,0) SEC ;if patient type says make record sensitive, add to security log file "RTN","DGRPP",69,0) K DD,DO S DIC="^DGSL(38.1,",(X,DINUM)=DFN,DIC(0)="L",DIC("DR")="2///1;3////"_DUZ_";4///NOW;" D FILE^DICN "RTN","DGRPP",70,0) I $D(^DGSL(38.1,DFN,0)) W !!,"===> Record has been classified as sensitive." S FLAG=1 "RTN","DGRPP",71,0) K DIC,X,DINUM,DA,DD,DO,Y "RTN","DGRPP",72,0) Q "RTN","DGRPP",73,0) ; "RTN","DGRPP",74,0) CHOICE ;parse out which items were selected for edit "RTN","DGRPP",75,0) ; "RTN","DGRPP",76,0) ;DGCH=choice to be parsed (either number or number-number) "RTN","DGRPP",77,0) ; "RTN","DGRPP",78,0) N DGFL S DGFL=0 "RTN","DGRPP",79,0) I DGCH["-" Q:DGCH'?1.2N1"-"1.2N!($P(DGCH,"-",2)>17) F J=$P(DGCH,"-",1):1:$P(DGCH,"-",2) I DGRPAN[(J_",") D:(DGRPS=9) SCR9 I 'DGFL S DGDR=DGDR_(DGRPS*100+J)_"," "RTN","DGRPP",80,0) I DGCH'["-",DGCH?1.2N,(DGRPAN[(DGCH_",")) S DGDR=DGDR_(DGRPS*100+DGCH)_"," "RTN","DGRPP",81,0) Q "RTN","DGRPP",82,0) ; "RTN","DGRPP",83,0) NEXT ;find next available screen...goto "RTN","DGRPP",84,0) I DGRPS=DGRPLAST G Q ;last screen and return...quit "RTN","DGRPP",85,0) S X=DGRPLAST "RTN","DGRPP",86,0) F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']"" I 'J S X=I Q "RTN","DGRPP",87,0) I DGRPS=1 S X=1.1 "RTN","DGRPP",88,0) ;LEG; DG*5.3*997; added screen 11.5 "RTN","DGRPP",89,0) I DGRPS=11 S X=11.5 "RTN","DGRPP",90,0) I DGRPS=11.5 S X=12 "RTN","DGRPP",91,0) SCRX ;goto screen X "RTN","DGRPP",92,0) I X[".",X'=1.1,X'=11.5 S X=$P(X,".",1) ;ASF; DG*5.3*997 ; Added screen 11.5 "RTN","DGRPP",93,0) G:X=1.1 ^DGRPCADD "RTN","DGRPP",94,0) ;ASF; DG*5.3*997; add condition for 11.5 "RTN","DGRPP",95,0) G:X=11.5 ^DGRP11A "RTN","DGRPP",96,0) G:(X'=1.1)&(X'=11.5) @("^DGRP"_X) ;goto next available screen; "RTN","DGRPP",97,0) W ;write highlighted text on screen (if parameter on) "RTN","DGRPP",98,0) I IOST="C-QUME",$L(DGVI)'=2 W Z "RTN","DGRPP",99,0) E W @DGVI,Z,@DGVO "RTN","DGRPP",100,0) Q "RTN","DGRPP",101,0) ; "RTN","DGRPP",102,0) SCR9 ; see if MT is completed. Allow only selective editing if so "RTN","DGRPP",103,0) I 'DGMTC Q "RTN","DGRPP",104,0) I '$D(DGRPSELT) S:DGMTC=1 DGFL=1 Q ;if no non-mt dependents "RTN","DGRPP",105,0) I DGRPSELT="S",$D(DGMTC("S")) Q "RTN","DGRPP",106,0) I DGRPSELT="D",$D(DGMTC("D")) Q "RTN","DGRPP",107,0) S DGFL=1 "RTN","DGRPP",108,0) Q "RTN","DGRPU") 0^9^B123342522 "RTN","DGRPU",1,0) DGRPU ;ALB/MRL,TMK,BAJ,DJE,JAM,JAM,ARF - REGISTRATION UTILITY ROUTINE ;12/20/2005 5:37PM "RTN","DGRPU",2,0) ;;5.3;Registration;**33,114,489,624,672,689,688,935,941,997,1014**;Aug 13, 1993;Build 42 "RTN","DGRPU",3,0) ; "RTN","DGRPU",4,0) H ;Screen Header "RTN","DGRPU",5,0) ;I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W "RTN","DGRPU",6,0) I DGRPS'=1.1,DGRPS'?1"11.5" W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W ; LEG; DG*5.3*997; excluded 11.5 "RTN","DGRPU",7,0) I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W "RTN","DGRPU",8,0) ;ASF; DG*5.3*997; add 11.5 screen "RTN","DGRPU",9,0) I DGRPS?1"11.5" W @IOF S Z="ADDITIONAL ELIGIBILITY VERIFICATION DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W "RTN","DGRPU",10,0) S X=$$SSNNM(DFN) "RTN","DGRPU",11,0) ;ARF - DG*5.3*1014 standardize heading and add DOB and PREFERRED NAME "RTN","DGRPU",12,0) ;I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X "RTN","DGRPU",13,0) I '$D(DGRPH) D ;DG*5.3*1014 begin "RTN","DGRPU",14,0) .N DGDOB,DGSSN,DGSSNSTR,DGPREFNM,DGPTYPE,DGNAME,DGMEMID,VADEMO ;DG*5.3*1014 - ARF - updating banner with standard patient data "RTN","DGRPU",15,0) .D DEMUPD^VADPT "RTN","DGRPU",16,0) .S DGNAME=VADEMO(1) "RTN","DGRPU",17,0) .S DGPREFNM=$S(VADEMO(1,1)'="":"("_VADEMO(1,1)_")",1:"") "RTN","DGRPU",18,0) .S DGDOB=$P(VADEMO(3),U,2) "RTN","DGRPU",19,0) .S DGSSN=$P(VADEMO(2),U,2) "RTN","DGRPU",20,0) .S DGSSNSTR=$$SSNNM^DGRPU(DFN) "RTN","DGRPU",21,0) .S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGRPU",22,0) .S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGRPU",23,0) .S DGMEMID=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"") "RTN","DGRPU",24,0) .W !,DGNAME W:DGPREFNM'="" " "_DGPREFNM W " "_DGDOB "RTN","DGRPU",25,0) .W ! W:DGMEMID'="" DGMEMID W DGSSN_" "_DGPTYPE ;DG*5.3*1014 end "RTN","DGRPU",26,0) S X="",$P(X,"=",80)="" W !,X Q "RTN","DGRPU",27,0) Q "RTN","DGRPU",28,0) LISTHDR(DGFIRST) ;sets patient data for banners of list manager screens - DG*5.3*1014 "RTN","DGRPU",29,0) ;DGFIRST - Is the first subscript of VALMHDR array where the patient data should "RTN","DGRPU",30,0) ; be stored. This value is increased for the second line of patient data "RTN","DGRPU",31,0) ; VALMHDR(DGFIRST)="NAME (PREFERRED NAME) MON DD, YYYY" note: the date is the DOB "RTN","DGRPU",32,0) ; VALMHDR(DGFIRST+1)="EDI/PI ###-##-#### PATIENT TYPE" note: if there isn't a EDP/PI(member ID) the "RTN","DGRPU",33,0) ; SSN (###-##-####) begins in the first column "RTN","DGRPU",34,0) N DGSSNSTR,DGPTYPE,DGSSN,DGDOB "RTN","DGRPU",35,0) S:+DGFIRST=0 DGFIRST=1 "RTN","DGRPU",36,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) "RTN","DGRPU",37,0) S DGSSN=$P($P(DGSSNSTR,";",2)," ",3) "RTN","DGRPU",38,0) S DGDOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","DGRPU",39,0) S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1)) "RTN","DGRPU",40,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGRPU",41,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGRPU",42,0) S VALMHDR(DGFIRST)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB "RTN","DGRPU",43,0) S VALMHDR(DGFIRST+1)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE "RTN","DGRPU",44,0) Q "RTN","DGRPU",45,0) AL(DGLEN) ;DGLEN= Available length of line "RTN","DGRPU",46,0) A ;Format address(es) "RTN","DGRPU",47,0) ; DG*5.3*688 BAJ 12/20/2005 modified for foreign address "RTN","DGRPU",48,0) I '$D(DGLEN) N DGLEN S DGLEN=29 "RTN","DGRPU",49,0) N I,DGX,FILE,IEN,CNTRY,TMP,FNODE,FPCE,ROU "RTN","DGRPU",50,0) ; set up variables "RTN","DGRPU",51,0) ; jam; DG*5.3*997; foreign address code for NOK/e-contact addresses .21, .211, .33, .331, .34 - country code is in piece 12 "RTN","DGRPU",52,0) ;S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,1:10) "RTN","DGRPU",53,0) S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,DGAD=.21:12,DGAD=.211:12,DGAD=.33:12,DGAD=.331:12,DGAD=.34:12,1:10) "RTN","DGRPU",54,0) ; collect Street Address info "RTN","DGRPU",55,0) F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S TMP(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2 "RTN","DGRPU",56,0) I DGA2=1 S TMP(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2 "RTN","DGRPU",57,0) ; retrieve country info -- PERM country is piece 10 of node .11 "RTN","DGRPU",58,0) S FOR=0 "RTN","DGRPU",59,0) ; jam; DG*5.3*997; add the country retrieval for screen 3 - NOK/e-contact/designee addresses "RTN","DGRPU",60,0) ;I DGA1=1 D "RTN","DGRPU",61,0) I DGA1=1!(DGAD=.21)!(DGAD=.211)!(DGAD=.33)!(DGAD=.331)!(DGAD=.34) D "RTN","DGRPU",62,0) . ; JAM; DG*5.3*997 - in the $E below, change the length of the CNTRY from 25 chars to DGLEN chars "RTN","DGRPU",63,0) . S FILE=779.004,IEN=$P(DGRP(FNODE),U,FPCE),CNTRY=$E($$CNTRYI^DGADDUTL(IEN),1,DGLEN) I CNTRY=-1 S CNTRY="UNKNOWN COUNTRY" "RTN","DGRPU",64,0) . ; assemble (US) CITY, STATE ZIP or (FOREIGN) CITY PROVINCE POSTAL CODE "RTN","DGRPU",65,0) . S FOR=$$FORIEN^DGADDUTL(IEN) I FOR=-1 S FOR=1 "RTN","DGRPU",66,0) S ROU=$S(FOR=1:"FOREIGN",1:"US")_"(DGAD,.TMP,DGA1,.DGA2)" D @ROU "RTN","DGRPU",67,0) ; append COUNTRY to address "RTN","DGRPU",68,0) S DGA2=DGA2+2,TMP(DGA2)=$S($G(CNTRY)="":"",1:CNTRY) "RTN","DGRPU",69,0) M DGA=TMP "RTN","DGRPU",70,0) K DGA1 "RTN","DGRPU",71,0) Q "RTN","DGRPU",72,0) ; "RTN","DGRPU",73,0) US(DGAD,TMP,DGA1,DGA2) ;process US addresses and format in DGA array "RTN","DGRPU",74,0) ; DG*5.3*688 BAJ this is the code for all addresses prior to the addition of Foreign address logic. "RTN","DGRPU",75,0) ; Modifications for Foreign address are in Tag FOREIGN "RTN","DGRPU",76,0) N DGX,I,J "RTN","DGRPU",77,0) ; format STATE field and merge with CITY & ZIP "RTN","DGRPU",78,0) S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),TMP(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE") "RTN","DGRPU",79,0) ; zip code capture "RTN","DGRPU",80,0) I ".33^.34^.211^.331^.311^.25^.21"[DGAD D "RTN","DGRPU",81,0) .F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I) "RTN","DGRPU",82,0) E D "RTN","DGRPU",83,0) .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q "RTN","DGRPU",84,0) .; JAM - Patch DG*5.3*941, Residential address, zip code is piece 6 "RTN","DGRPU",85,0) .I DGAD=.115 S DGX=$P(DGRP(.115),U,6) Q "RTN","DGRPU",86,0) .S DGX=$P(DGRP(DGAD),U,DGA1+11) "RTN","DGRPU",87,0) ; format ZIP+4 with hyphen "RTN","DGRPU",88,0) S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9) "RTN","DGRPU",89,0) ;combine CITY,STATE and ZIP fields on a single line "RTN","DGRPU",90,0) S TMP(DGA2)=$E($P(TMP(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(TMP(DGA2),",",2)):",",1:"")_$P(TMP(DGA2),",",2)_" "_DGX "RTN","DGRPU",91,0) F I=0:0 S I=$O(TMP(I)) Q:'I S TMP(I)=$E(TMP(I),1,DGLEN) "RTN","DGRPU",92,0) Q "RTN","DGRPU",93,0) ; "RTN","DGRPU",94,0) FOREIGN(DGAD,TMP,DGA1,DGA2) ;process FOREIGN addresses and format in DGA array "RTN","DGRPU",95,0) N I,J,CITY,PRVNCE,PSTCD,FNODE "RTN","DGRPU",96,0) F I=1:1 S J=$P($T(FNPCS+I),";;",3) Q:J="QUIT" D "RTN","DGRPU",97,0) . I DGAD=$P(J,";",1) S FNODE=$P(J,";",2),CITY=$P(J,";",3),PRVNCE=$P(J,";",4),PSTCD=$P(J,";",5) "RTN","DGRPU",98,0) ; Assemble CITY PROVINCE and POSTAL CODE on the same line "RTN","DGRPU",99,0) ; NOTE CITY is sometimes on a different node than the PROVINCE & POSTAL CODE "RTN","DGRPU",100,0) ; DG*5.3*997; jam; For screen 3 put Province and Postal Code to a separate line "RTN","DGRPU",101,0) ; - for other screens, rearrange output so City is followed by Province and then Postal code "RTN","DGRPU",102,0) I $G(DGRPS)=3 D "RTN","DGRPU",103,0) . S TMP(DGA2)=$P(DGRP(DGAD),U,CITY) "RTN","DGRPU",104,0) . S DGA2=DGA2+2 S TMP(DGA2)=$P(DGRP(FNODE),U,PRVNCE)_" "_$P(DGRP(FNODE),U,PSTCD) "RTN","DGRPU",105,0) E S TMP(DGA2)=$P(DGRP(DGAD),U,CITY)_" "_$P(DGRP(FNODE),U,PRVNCE)_" "_$P(DGRP(FNODE),U,PSTCD) "RTN","DGRPU",106,0) F I=0:0 S I=$O(TMP(I)) Q:'I S TMP(I)=$E(TMP(I),1,DGLEN) "RTN","DGRPU",107,0) Q "RTN","DGRPU",108,0) ; "RTN","DGRPU",109,0) W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q "RTN","DGRPU",110,0) W ?X,@DGVI,Z,@DGVO "RTN","DGRPU",111,0) Q "RTN","DGRPU",112,0) ; "RTN","DGRPU",113,0) ; JAM - Patch DG*5.3*941, Add Residential address type "RTN","DGRPU",114,0) ; JAM - Patch DG*5.3*997, Add NOK/e-contact address types "RTN","DGRPU",115,0) FNPCS ; Foreign data pieces. Structure-->Description;;Main Node;Data Node;City;Province;Postal code. "RTN","DGRPU",116,0) ;;Permanent;;.11;.11;4;8;9 "RTN","DGRPU",117,0) ;;Temporary;;.121;.122;4;1;2 "RTN","DGRPU",118,0) ;;Confidential;;.141;.141;4;14;15 "RTN","DGRPU",119,0) ;;Residential;;.115;.115;4;8;9 "RTN","DGRPU",120,0) ;;NOK;;.21;.21;6;13;14 "RTN","DGRPU",121,0) ;;NOK2;;.211;.211;6;13;14 "RTN","DGRPU",122,0) ;;E;;.33;.33;6;13;14 "RTN","DGRPU",123,0) ;;E2;;.331;.331;6;13;14 "RTN","DGRPU",124,0) ;;D;;.34;.34;6;13;14 "RTN","DGRPU",125,0) ;;QUIT;;QUIT "RTN","DGRPU",126,0) ; "RTN","DGRPU",127,0) H1 ; "RTN","DGRPU",128,0) ;;PATIENT DEMOGRAPHIC DATA "RTN","DGRPU",129,0) ;;PATIENT DATA "RTN","DGRPU",130,0) ;;EMERGENCY CONTACT DATA "RTN","DGRPU",131,0) ;;APPLICANT/SPOUSE EMPLOYMENT DATA "RTN","DGRPU",132,0) ;;INSURANCE DATA "RTN","DGRPU",133,0) ;;MILITARY SERVICE DATA "RTN","DGRPU",134,0) ;;ELIGIBILITY STATUS DATA "RTN","DGRPU",135,0) ;;FAMILY DEMOGRAPHIC DATA "RTN","DGRPU",136,0) ;;INCOME SCREENING DATA "RTN","DGRPU",137,0) ;;INELIGIBLE/MISSING DATA "RTN","DGRPU",138,0) ;;ELIGIBILITY VERIFICATION DATA "RTN","DGRPU",139,0) ;;ADMISSION INFORMATION "RTN","DGRPU",140,0) ;;APPLICATION INFORMATION "RTN","DGRPU",141,0) ;;APPOINTMENT INFORMATION "RTN","DGRPU",142,0) ;;SPONSOR DEMOGRAPHIC INFORMATION "RTN","DGRPU",143,0) ; "RTN","DGRPU",144,0) ; "RTN","DGRPU",145,0) INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data "RTN","DGRPU",146,0) ; (called by PTF) "RTN","DGRPU",147,0) ; "RTN","DGRPU",148,0) ; "RTN","DGRPU",149,0) ; Input: DFN as IEN of PATIENT file "RTN","DGRPU",150,0) ; DGDT as date to return income as of "RTN","DGRPU",151,0) ; "RTN","DGRPU",152,0) ; Output: total income (computed function) "RTN","DGRPU",153,0) ; (from 408.21 if available...otherwise from file 2) "RTN","DGRPU",154,0) ; "RTN","DGRPU",155,0) ; "RTN","DGRPU",156,0) N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0 "RTN","DGRPU",157,0) D ALL^DGMTU21(DFN,"V",DGDT,"I") "RTN","DGRPU",158,0) S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I) "RTN","DGRPU",159,0) I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20) "RTN","DGRPU",160,0) Q DGTOT "RTN","DGRPU",161,0) ; "RTN","DGRPU",162,0) ; "RTN","DGRPU",163,0) MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete? "RTN","DGRPU",164,0) ; "RTN","DGRPU",165,0) ; Input: DFN as IEN of PATIENT file "RTN","DGRPU",166,0) ; DGDT as 'as of' date "RTN","DGRPU",167,0) ; "RTN","DGRPU",168,0) ; Output: 1 if means test/COPAY for year prior to DT passed is complete "RTN","DGRPU",169,0) ; 0 otherwise "RTN","DGRPU",170,0) ; DGMTYPT 1=MT;2=CP;0=NONE "RTN","DGRPU",171,0) ; "RTN","DGRPU",172,0) N COMP,MT,X,YR "RTN","DGRPU",173,0) S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT) "RTN","DGRPU",174,0) S DGMTYPT=+$P(MT,U,5) "RTN","DGRPU",175,0) S COMP=1 "RTN","DGRPU",176,0) I DGMTYPT=1 D ;MT "RTN","DGRPU",177,0) .I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0 "RTN","DGRPU",178,0) I DGMTYPT=2 D ;CP "RTN","DGRPU",179,0) .I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0 "RTN","DGRPU",180,0) S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*100001) S STK="" Q ;First active EDIPI "RTN","DGRPU",275,0) .I IDSTAT="H" S EDIPI(J)=EDIPI S J=J+1 "RTN","DGRPU",276,0) .S EDIPI="" "RTN","DGRPU",277,0) I IDSTAT="H" S EDIPI=EDIPI(1) ; First inactive EDIPI "RTN","DGRPU",278,0) S X=$P(X,U)_"; "_EDIPI_" "_SSN "RTN","DGRPU",279,0) Q X "RTN","DGRPV") 0^33^B21728618 "RTN","DGRPV",1,0) DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM,PWC,JAM,JAM,ASF;LEG - REGISTRATION DEFINE VARIABLES ON ENTRY ;Apr 05, 2020@19:00 "RTN","DGRPV",2,0) ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842,871,887,941,985,997,1014**;Aug 13, 1993;Build 42 "RTN","DGRPV",3,0) ; "RTN","DGRPV",4,0) ; "RTN","DGRPV",5,0) ;set up variables for registration screen processing "RTN","DGRPV",6,0) ; "RTN","DGRPV",7,0) ;DGRPVV :string of 15 ones and zeros each character corresponding to "RTN","DGRPV",8,0) ; a particular screen (0 means allow edit, 1 means don't) "RTN","DGRPV",9,0) ; "RTN","DGRPV",10,0) ;DGRPVV(n):where n=screen number. String of x ones and zeros where "RTN","DGRPV",11,0) ; x is the number of elements on screen n (0=edit, 1=don't) "RTN","DGRPV",12,0) ; "RTN","DGRPV",13,0) ;DGVI :Turn on high intensity "RTN","DGRPV",14,0) ;DGVO :Turn off high intensity "RTN","DGRPV",15,0) ; "RTN","DGRPV",16,0) EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS "RTN","DGRPV",17,0) S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity "RTN","DGRPV",18,0) I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X) "RTN","DGRPV",19,0) M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM") "RTN","DGRPV",20,0) S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1) "RTN","DGRPV",21,0) MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2 "RTN","DGRPV",22,0) ;DG*5.3*797 "RTN","DGRPV",23,0) I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN) "RTN","DGRPV",24,0) SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",25,0) S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",26,0) I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10")) "RTN","DGRPV",27,0) ; "RTN","DGRPV",28,0) S DGPH=$P($G(^DPT(DFN,.53)),U) ;Purple Heart Indicator "RTN","DGRPV",29,0) I $G(DGPRFLG)=1 D "RTN","DGRPV",30,0) . S DGRPVV="000001111111111" "RTN","DGRPV",31,0) E D "RTN","DGRPV",32,0) . S DGRPVV="000000000000000" "RTN","DGRPV",33,0) ; DG*5.3*985;JAM - Screen 1 now has 6 groups "RTN","DGRPV",34,0) S X="6^3^5^2^3^10^4^2^3^2^5^5^5^2^1" "RTN","DGRPV",35,0) F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J)) "RTN","DGRPV",36,0) ;JAM - patch DG*5.3*941 - Screen 1.1 reformat - 4 groups "RTN","DGRPV",37,0) S DGRPVV(1.1)="0000" "RTN","DGRPV",38,0) S DGRPVV(2)="00010" "RTN","DGRPV",39,0) ; DG*5.3*997; ASF; Allowing selection for screen 11.5, group 1 (allows user to see sub-screen 11.5.1) "RTN","DGRPV",40,0) S DGRPVV(11.5)="00" ;LEG ;DG*5.3.1014 ; added extra "0" for group [2] ;was S DGRPVV(11.5)=0 "RTN","DGRPV",41,0) I $P($G(^DPT(DFN,.52)),U,9)'="" S $E(DGRPVV(6),4)=1 ;POW status verified, no editing (DG*5.3*688) "RTN","DGRPV",42,0) I $G(DGPH)]"" S $E(DGRPVV(6),8)=1 "RTN","DGRPV",43,0) S $E(DGRPVV(6),9,10)="11" "RTN","DGRPV",44,0) ; "RTN","DGRPV",45,0) F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",46,0) ; "RTN","DGRPV",47,0) ;-- if patient type is TRICARE then turn off screens 2,4 "RTN","DGRPV",48,0) ; "RTN","DGRPV",49,0) ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 "RTN","DGRPV",50,0) ;-- commented the line to allow screens 2 & 4 to display for Tricare "RTN","DGRPV",51,0) ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",52,0) ; "RTN","DGRPV",53,0) F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",54,0) I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99) "RTN","DGRPV",55,0) K DIRUT,DUOUT,DTOUT "RTN","DGRPV",56,0) ; "RTN","DGRPV",57,0) ;Fields are numbered screen_item and put in that piece position. "RTN","DGRPV",58,0) ;Because FM does not allow more than 100 pieces on a node, it was "RTN","DGRPV",59,0) ;necessary to start a new node E10 for fields on screens 10 or higher. "RTN","DGRPV",60,0) ;In these instances, the piece position will be screen_item-100 so, "RTN","DGRPV",61,0) ;for example, screen 11, item 2 would be field 112, but piece 12. "RTN","DGRPV",62,0) ;Items on screens <10 will be found on node E. "RTN","DGRPV",63,0) ; "RTN","DGRPV",64,0) F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",65,0) ; "RTN","DGRPV",66,0) I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip "RTN","DGRPV",67,0) F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPV",68,0) S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob "RTN","DGRPV",69,0) I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data "RTN","DGRPV",70,0) I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen "RTN","DGRPV",71,0) S DGRPVV(11)=$E(DGRPVV(11),1,4)_"0" ; turn on HBP to get to next screen where edit on/off will be controlled "RTN","DGRPV",72,0) ; "RTN","DGRPV",73,0) ELVER ;set up variables for eligibility verification "RTN","DGRPV",74,0) ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10, "RTN","DGRPV",75,0) ; and 11 if they're turned on). "RTN","DGRPV",76,0) ; "RTN","DGRPV",77,0) S DGRP(.361)=$G(^DPT(DFN,.361)) "RTN","DGRPV",78,0) I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10 "RTN","DGRPV",79,0) I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=10000 "RTN","DGRPV",80,0) S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15) "RTN","DGRPV",81,0) I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I "RTN","DGRPV",82,0) S:DGRPLAST=11 DGRPLAST=11.5 ; ASF; DG*5.3*997 - show screen 11.5 in DG Eligibility Verification options "RTN","DGRPV",83,0) Q K DGRPSC,DGRPSCE "RTN","DGRPV",84,0) Q "RTN","DGRPV",85,0) ; "RTN","DGRPV",86,0) WW ;Write number on screens for display and/or edit (Z=number) "RTN","DGRPV",87,0) W:DGRPW ! "RTN","DGRPV",88,0) S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]") "RTN","DGRPV",89,0) I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO "RTN","DGRPV",90,0) I 'DGRPCM&($E(Z)'="[") W Z "RTN","DGRPV",91,0) Q "RTN","DGRPV",92,0) ; "RTN","DGRPV",93,0) WW1 ;spacing for screen display (Z=item to print) "RTN","DGRPV",94,0) F Z2=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","DGRPV",95,0) W Z K Z2 "RTN","DGRPV",96,0) Q "RTN","DGRPV",97,0) ; "RTN","DGRPV",98,0) WW2 ; Write number on screen for fields always selectable "RTN","DGRPV",99,0) W:DGRPW ! S Z="["_Z_"]" "RTN","DGRPV",100,0) I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO "RTN","DGRPV",101,0) Q "RTN","DGUAMWS") 0^37^B107230386 "RTN","DGUAMWS",1,0) DGUAMWS ;ALB/MCF - UAM Address Validation Web Service ;30 June 2020 10:00 AM "RTN","DGUAMWS",2,0) ;;5.3;Registration;**1014**;Aug 13, 1993;Build 42 "RTN","DGUAMWS",3,0) ; "RTN","DGUAMWS",4,0) ; Supported ICR's: "RTN","DGUAMWS",5,0) ; #5421 - XOBWLIB - Public APIs for HWSC "RTN","DGUAMWS",6,0) ; #6682 - DECODE^XLFJSON - Decode JSON "RTN","DGUAMWS",7,0) ; - ENCODE^XLFJSON - Encode JSON "RTN","DGUAMWS",8,0) ; #7191 - Read access to file 18.12 "RTN","DGUAMWS",9,0) ; #7190 - Read access to file 18.02 "RTN","DGUAMWS",10,0) ; "RTN","DGUAMWS",11,0) ; NOTE: EN^DGUAMWS contains vendor specific code that is restricted and will be reported by XINDEX. "RTN","DGUAMWS",12,0) ; Exemption (20200806-01) was granted by the Standards and Conventions (SAC) committee on 8/6/20 "RTN","DGUAMWS",13,0) ; allowing the vendor specific code. "RTN","DGUAMWS",14,0) ; "RTN","DGUAMWS",15,0) EN(DGADDRESS,DGFLDS,DGFORGN) ; Main entry to for UAM Address Validation Web Service "RTN","DGUAMWS",16,0) ; Input : DGADDRESS (Required, pass by reference) - Array containing the address to be validated "RTN","DGUAMWS",17,0) ; DGFLDS (Required) - List of fileman field values. See "Address fields" below. "RTN","DGUAMWS",18,0) ; DGFORGN (Required) - Foreign flag indicator. Determines use of Candidate or Validate web service "RTN","DGUAMWS",19,0) ; 0-Domestic (Candidate), 1-Foreign (Validate), 2-Foreign Exception (Candidate) "RTN","DGUAMWS",20,0) ; Return: DGADDRESS - original address returned with the response addresses from the web service in the same format. "RTN","DGUAMWS",21,0) ; DGADDRESS(DGCNT,"confidenceScore") - Contains the confidence score for this address. "RTN","DGUAMWS",22,0) ; DGADDRESS(DGCNT,"deliveryPoint") - Contains the delivery point validation message for this address. "RTN","DGUAMWS",23,0) ; (Only pertains to USA addresses) "RTN","DGUAMWS",24,0) ; 0 - Error in web service call or no addresses above 80% confidence. 1- Successful request/response. "RTN","DGUAMWS",25,0) ; Note: A "1" returned does NOT imply a "good" address is returned. "RTN","DGUAMWS",26,0) ; Confidence Score, Delivery Point, and Message Codes give more detail if provided by the web service. "RTN","DGUAMWS",27,0) N DGX,DGEXC,DGFRGNEXCPTS,DGADDRLN1,DGADDRLN2,DGADDRLN3,DGCITY,DGSTATE,DGZIP,DGPROV,DGPOSTCODE,DGCOUNTRY "RTN","DGUAMWS",28,0) N DGSERVICE,DGERR,DGHTTPREQ,DGJSON,DGHEADER,DGRESPONSE,DGRESPERR,DGHTTPRESP,DGDATA,DGARRAY,DGRESPMSG,DGSTAT "RTN","DGUAMWS",29,0) D INIT "RTN","DGUAMWS",30,0) ; The Candidate web service may accept some foreign countries like Canada. That list is set up in Init. "RTN","DGUAMWS",31,0) I DGFORGN=1 D "RTN","DGUAMWS",32,0) . F DGX=1:1 S DGEXC=$P(DGFRGNEXCPTS,"^",DGX) Q:DGEXC="" D "RTN","DGUAMWS",33,0) . . I DGADDRESS(1,DGCOUNTRY)=DGEXC S DGFORGN=2 ; Foreign country on exceptions list "RTN","DGUAMWS",34,0) ; Quit if server or services not installed "RTN","DGUAMWS",35,0) I '$$FIND1^DIC(18.12,,"B","DG UAM AV SERVER")!('$$FIND1^DIC(18.02,,"B","DG UAM AV CANDIDATE"))!('$$FIND1^DIC(18.02,,"B","DG UAM AV VALIDATE")) Q "0^Web services are not set up" "RTN","DGUAMWS",36,0) ; Call web server and web service. API key is set in Context Root of the web service in HWSC. "RTN","DGUAMWS",37,0) S DGSERVICE=$S(DGFORGN=1:"DG UAM AV VALIDATE",1:"DG UAM AV CANDIDATE") "RTN","DGUAMWS",38,0) S DGHTTPREQ=$$GETREST^XOBWLIB(DGSERVICE,"DG UAM AV SERVER") "RTN","DGUAMWS",39,0) S DGHTTPREQ.SSLCheckServerIdentity = 0 ; Older versions of xobw.WebServer.cls don't set this value. Setting here to prevent Error #6156 during the POST below. "RTN","DGUAMWS",40,0) ; "RTN","DGUAMWS",41,0) ; JSON specific setup "RTN","DGUAMWS",42,0) S DGJSON=$$JSONREQUEST(.DGADDRESS,DGFLDS) "RTN","DGUAMWS",43,0) D DGHTTPREQ.EntityBody.Write(DGJSON) ; places the entire json string into EntityBody "RTN","DGUAMWS",44,0) F DGHEADER="Accept","ContentType" D DGHTTPREQ.SetHeader(DGHEADER,"application/json") "RTN","DGUAMWS",45,0) D DGHTTPREQ.SetHeader("ContentType","application/json") "RTN","DGUAMWS",46,0) ; "RTN","DGUAMWS",47,0) ; REST API Post Call and Response (response is in DGHTTPREQ.HttpResponse) "RTN","DGUAMWS",48,0) S DGRESPONSE=$$POST^XOBWLIB(DGHTTPREQ,"",.DGRESPERR,0) "RTN","DGUAMWS",49,0) I ('DGRESPONSE) Q "0^"_$$ERRRSPMSG(DGRESPERR) "RTN","DGUAMWS",50,0) S DGHTTPRESP=DGHTTPREQ.HttpResponse "RTN","DGUAMWS",51,0) S DGDATA=DGHTTPRESP.Data.ReadLine() ; reads json string response from the data stream. "RTN","DGUAMWS",52,0) ; "RTN","DGUAMWS",53,0) ; convert json string to an array, parse results and return in DGADDRESS array. "RTN","DGUAMWS",54,0) D DECODE^XLFJSON("DGDATA","DGARRAY") "RTN","DGUAMWS",55,0) I DGFORGN=1 D VALRESULTS(.DGADDRESS,.DGARRAY) "RTN","DGUAMWS",56,0) I DGFORGN'=1 D CANDRESULTS(.DGADDRESS,.DGARRAY) "RTN","DGUAMWS",57,0) ; "RTN","DGUAMWS",58,0) S DGSTAT=$S($Order(DGADDRESS(1)):1,1:0) ; if there are no results to return set status to "0" "RTN","DGUAMWS",59,0) Q DGSTAT_"^"_$$RSPMSG(DGHTTPRESP.StatusCode,.DGRESPMSG) "RTN","DGUAMWS",60,0) ; "RTN","DGUAMWS",61,0) ERRRSPMSG(DGRESPERR) ; "RTN","DGUAMWS",62,0) ; Input : DGRESPERR (Required) - response error from Post call "RTN","DGUAMWS",63,0) ; Return: response code/txt (ex: DGERR(400) from Init)_response code/msg (ex: ADDRVAL###) "RTN","DGUAMWS",64,0) D ZTER^XOBWLIB(DGRESPERR) "RTN","DGUAMWS",65,0) N DGERRCODE S DGERRCODE=DGRESPERR.code "RTN","DGUAMWS",66,0) I '$D(DGERR(DGERRCODE)) Q DGERRCODE_" An error occurred and has been logged. The service is currently not available." "RTN","DGUAMWS",67,0) E Q DGERR(DGERRCODE) "RTN","DGUAMWS",68,0) ; "RTN","DGUAMWS",69,0) RSPMSG(DGSTCODE,DGRESPMSG) ; "RTN","DGUAMWS",70,0) ; Input : DGSTCODE (Required) - response statuscode from DGHTTPRESP "RTN","DGUAMWS",71,0) ; : DGRESPMSG - response message from DGDATA "RTN","DGUAMWS",72,0) ; Return: response code/txt (ex: DGERR(400) from Init)_response code/msg (ex: ADDRVAL###) "RTN","DGUAMWS",73,0) Q DGERR(DGSTCODE) "RTN","DGUAMWS",74,0) ; "RTN","DGUAMWS",75,0) JSONREQUEST(DGADDRESS,DGFLDS) ; places the address elements in the json string "RTN","DGUAMWS",76,0) ; Input : DGADDRESS (Required, pass by reference) - Array containing the address to be validated "RTN","DGUAMWS",77,0) ; DGFLDS (Required) - List of fileman field values. See "Address fields" in Init "RTN","DGUAMWS",78,0) ; Return: DGJSON(1) - a json string "RTN","DGUAMWS",79,0) ; "RTN","DGUAMWS",80,0) ; Format of DGADDRESS array "RTN","DGUAMWS",81,0) ; DGADDRESS(field#)=VALUE "RTN","DGUAMWS",82,0) ; "RTN","DGUAMWS",83,0) ; if a foreign address, get value from Province if it was entered "RTN","DGUAMWS",84,0) N DGSTATEPROV,DGJSON,DGSTCODE "RTN","DGUAMWS",85,0) S DGSTATEPROV=$G(DGADDRESS(1,DGSTATE)) "RTN","DGUAMWS",86,0) ; Address is the full name, which UAM may not always recognize, so get the abbreviation "RTN","DGUAMWS",87,0) S DGSTCODE=$P(DGSTATEPROV,"^",2) "RTN","DGUAMWS",88,0) I DGSTCODE'="" S $P(DGSTATEPROV,"^",1)=$$GET1^DIQ(5,DGSTCODE,1) "RTN","DGUAMWS",89,0) I (DGFORGN=1)&($G(DGADDRESS(1,DGPROV))'="") S DGSTATEPROV=DGADDRESS(1,DGPROV) "RTN","DGUAMWS",90,0) ; DGSTATEPROV and DGADDRESS(1,DGCOUNTRY) will be stripped of the "^CODE" coming from VistA "RTN","DGUAMWS",91,0) S DGJSON("requestAddress","addressLine1")=$G(DGADDRESS(1,DGADDRLN1)) "RTN","DGUAMWS",92,0) S DGJSON("requestAddress","addressLine2")=$G(DGADDRESS(1,DGADDRLN2)) "RTN","DGUAMWS",93,0) S DGJSON("requestAddress","addressLine3")=$G(DGADDRESS(1,DGADDRLN3)) "RTN","DGUAMWS",94,0) S DGJSON("requestAddress","addressPOU")="CORRESPONDENCE" "RTN","DGUAMWS",95,0) S DGJSON("requestAddress","city")=$G(DGADDRESS(1,DGCITY)) "RTN","DGUAMWS",96,0) S DGJSON("requestAddress","internationalPostalCode")=$G(DGADDRESS(1,DGPOSTCODE)) "RTN","DGUAMWS",97,0) S DGJSON("requestAddress","requestCountry","countryCode")="" "RTN","DGUAMWS",98,0) S DGJSON("requestAddress","requestCountry","countryName")=$P($G(DGADDRESS(1,DGCOUNTRY)),"^",1) "RTN","DGUAMWS",99,0) S DGJSON("requestAddress","stateProvince","name")=$P(DGSTATEPROV,"^",1) "RTN","DGUAMWS",100,0) S DGJSON("requestAddress","stateProvince","code")="" "RTN","DGUAMWS",101,0) S DGJSON("requestAddress","zipCode4")="" "RTN","DGUAMWS",102,0) S DGJSON("requestAddress","zipCode5")=$G(DGADDRESS(1,DGZIP)) "RTN","DGUAMWS",103,0) D ENCODE^XLFJSON("DGJSON","DGJSON") "RTN","DGUAMWS",104,0) ; "RTN","DGUAMWS",105,0) ; The resultant DGJSON string above is formatted as follows "RTN","DGUAMWS",106,0) ; { "RTN","DGUAMWS",107,0) ; "requestAddress": { "RTN","DGUAMWS",108,0) ; "addressLine1": ($G(DGADDRESS(1,DGADDRLN1))), "RTN","DGUAMWS",109,0) ; "addressLine2": ($G(DGADDRESS(1,DGADDRLN2))), "RTN","DGUAMWS",110,0) ; "addressLine3": ($G(DGADDRESS(1,DGADDRLN3))), "RTN","DGUAMWS",111,0) ; "addressPOU": "CORRESPONDENCE", "RTN","DGUAMWS",112,0) ; "city": ($G(DGADDRESS(1,DGCITY))), "RTN","DGUAMWS",113,0) ; "internationalPostalCode": ($G(DGADDRESS(1,DGPOSTCODE))), "RTN","DGUAMWS",114,0) ; "requestCountry": { "RTN","DGUAMWS",115,0) ; "countryCode": "", "RTN","DGUAMWS",116,0) ; "countryName": ($P($G(DGADDRESS(1,DGCOUNTRY)),"^",1))}, "RTN","DGUAMWS",117,0) ; "stateProvince": { "RTN","DGUAMWS",118,0) ; "code": "", "RTN","DGUAMWS",119,0) ; "name": ($P(DGSTATEPROV,"^",1))}, "RTN","DGUAMWS",120,0) ; "zipCode4": "", "RTN","DGUAMWS",121,0) ; "zipCode5": ($G(DGADDRESS(1,DGZIP)))} "RTN","DGUAMWS",122,0) ; } "RTN","DGUAMWS",123,0) Q DGJSON(1) "RTN","DGUAMWS",124,0) ; "RTN","DGUAMWS",125,0) CANDRESULTS(DGADDRESS,DGARRAY) ; handles domestic address response from the Candidate web service. Multiple addresses possible. "RTN","DGUAMWS",126,0) ; Input : DGADDRESS (Required, pass by reference) - Array containing the address to be updated and returned "RTN","DGUAMWS",127,0) ; DGARRAY - Array representation of JSON response. "RTN","DGUAMWS",128,0) ; Return: DGADDRESS "RTN","DGUAMWS",129,0) N DGADDR,DGTEMP,DGCNT,DGADDCNT "RTN","DGUAMWS",130,0) S DGADDCNT=1,DGCNT="" "RTN","DGUAMWS",131,0) F S DGCNT=$O(DGARRAY("candidateAddresses",DGCNT)) Q:DGCNT="" D "RTN","DGUAMWS",132,0) . MERGE DGADDR=DGARRAY("candidateAddresses",DGCNT,"address") "RTN","DGUAMWS",133,0) . MERGE DGADDR=DGARRAY("candidateAddresses",DGCNT,"addressMetaData") "RTN","DGUAMWS",134,0) . I $$SETRRESULTS D "RTN","DGUAMWS",135,0) . . S DGADDCNT=DGADDCNT+1 "RTN","DGUAMWS",136,0) . . MERGE DGADDRESS(DGADDCNT)=DGTEMP ; DGADDRESS contains original address in 1 "RTN","DGUAMWS",137,0) Q "RTN","DGUAMWS",138,0) ; "RTN","DGUAMWS",139,0) VALRESULTS(DGADDRESS,DGARRAY) ; handles the foreign address response from the Validate web service. Only one address is returned. "RTN","DGUAMWS",140,0) ; Input : DGADDRESS (Required, pass by reference) - Array containing the address to be updated and returned "RTN","DGUAMWS",141,0) ; DGARRAY - Array representation of JSON response. "RTN","DGUAMWS",142,0) ; Return: DGADDRESS "RTN","DGUAMWS",143,0) N DGADDR,DGTEMP "RTN","DGUAMWS",144,0) MERGE DGADDR=DGARRAY("addressMetaData") "RTN","DGUAMWS",145,0) MERGE DGADDR=DGARRAY("address") "RTN","DGUAMWS",146,0) I $$SETRRESULTS MERGE DGADDRESS(2)=DGTEMP ; DGADDRESS contains original address in 1 "RTN","DGUAMWS",147,0) Q "RTN","DGUAMWS",148,0) ; "RTN","DGUAMWS",149,0) SETRRESULTS() ; checks if Confidence Score is greater than 80 and sets values. "RTN","DGUAMWS",150,0) ; Assumptions: DGADDR contains one address from DGADDRESS "RTN","DGUAMWS",151,0) ; Return: 1 - Confidence Score is at or above 80. 0 - Confidence Score is below 80. "RTN","DGUAMWS",152,0) ; DGTEMP contains data from address. "RTN","DGUAMWS",153,0) N DGVAL "RTN","DGUAMWS",154,0) S DGTEMP("confidenceScore")=$G(DGADDR("confidenceScore")) "RTN","DGUAMWS",155,0) S DGTEMP("deliveryPoint")=$G(DGADDR("deliveryPointValidation")) "RTN","DGUAMWS",156,0) I DGTEMP("confidenceScore")<80 Q 0 "RTN","DGUAMWS",157,0) S DGTEMP(DGADDRLN1)=$G(DGADDR("addressLine1")) "RTN","DGUAMWS",158,0) S DGTEMP(DGADDRLN2)=$G(DGADDR("addressLine2")) "RTN","DGUAMWS",159,0) S DGTEMP(DGADDRLN3)=$G(DGADDR("addressLine3")) "RTN","DGUAMWS",160,0) S DGTEMP(DGCITY)=$G(DGADDR("city")) "RTN","DGUAMWS",161,0) S DGTEMP(DGCOUNTRY)=$G(DGADDR("country","name")) "RTN","DGUAMWS",162,0) I DGFORGN=0 D "RTN","DGUAMWS",163,0) . S DGTEMP(DGSTATE)=$G(DGADDR("stateProvince","name")) "RTN","DGUAMWS",164,0) . ; Some addresses such as APO and FPO return state code only, not the name "RTN","DGUAMWS",165,0) . I DGTEMP(DGSTATE)="" S DGTEMP(DGSTATE)=$G(DGADDR("stateProvince","code")) "RTN","DGUAMWS",166,0) I DGFORGN S DGTEMP(DGPROV)=$G(DGADDR("stateProvince","name")) "RTN","DGUAMWS",167,0) S DGTEMP(DGZIP)=$G(DGADDR("zipCode5"))_$G(DGADDR("zipCode4")) "RTN","DGUAMWS",168,0) S DGTEMP(DGPOSTCODE)=$G(DGADDR("internationalPostalCode")) "RTN","DGUAMWS",169,0) ; traverse through DGTEMP array and convert all values to UPPERCASE. "RTN","DGUAMWS",170,0) S DGVAL="DGTEMP" F S DGVAL=$QUERY(@DGVAL) Q:DGVAL="" S @DGVAL=$$UPPER^DGUTL(@DGVAL) "RTN","DGUAMWS",171,0) Q 1 "RTN","DGUAMWS",172,0) INIT ; Initialized variables "RTN","DGUAMWS",173,0) ; Get foreign country exceptions "RTN","DGUAMWS",174,0) S DGFRGNEXCPTS="CAN^CANADA" "RTN","DGUAMWS",175,0) ; "RTN","DGUAMWS",176,0) ; 1 2 3 4 5 6 7 8 9 10 "RTN","DGUAMWS",177,0) ; Mapping: "AddressLine1,AddressLine2,AddressLine3,City,State,County,ZipCode,Province,PostalCode,Country" "RTN","DGUAMWS",178,0) ; DGFLDS will contain one of the following list of subscripts that are used by DGADDRESS "RTN","DGUAMWS",179,0) ; Permanent Address fields : ".111,.112,.113,.114,.115,.117,.1112,.1171,.1172,.1173" "RTN","DGUAMWS",180,0) ; Residential Address fields : ".1151,.1152,.1153,.1154,.1155,.1157,.1156,.11571,.11572,.11573" "RTN","DGUAMWS",181,0) ; Confidential Address fields: ".1411,.1412,.1413,.1414,.1415,.14111,.1416,.14114,.14115,.14116" "RTN","DGUAMWS",182,0) S DGADDRLN1=$P(DGFLDS,",",1) "RTN","DGUAMWS",183,0) S DGADDRLN2=$P(DGFLDS,",",2) "RTN","DGUAMWS",184,0) S DGADDRLN3=$P(DGFLDS,",",3) "RTN","DGUAMWS",185,0) S DGCITY=$P(DGFLDS,",",4) "RTN","DGUAMWS",186,0) S DGSTATE=$P(DGFLDS,",",5) "RTN","DGUAMWS",187,0) S DGZIP=$P(DGFLDS,",",7) "RTN","DGUAMWS",188,0) S DGPROV=$P(DGFLDS,",",8) "RTN","DGUAMWS",189,0) S DGPOSTCODE=$P(DGFLDS,",",9) "RTN","DGUAMWS",190,0) S DGCOUNTRY=$P(DGFLDS,",",10) "RTN","DGUAMWS",191,0) ; Response Codes/Text "RTN","DGUAMWS",192,0) S DGERR(200)="200 Successful Request/Response from server. " ; may append messages "RTN","DGUAMWS",193,0) S DGERR(400)="400 Error. " ; will append messages "RTN","DGUAMWS",194,0) S DGERR(403)="403 Not authorized. Please verify credentials used in the request. " "RTN","DGUAMWS",195,0) S DGERR(404)="404 The record you requested to retrieve or update could not be found. " "RTN","DGUAMWS",196,0) S DGERR(429)="429 You have exhausted the approved request quota for this API. This request should be retried after the quota window expires (default 60sec). " "RTN","DGUAMWS",197,0) S DGERR(500)="500 Error. " ; will append messages "RTN","DGUAMWS",198,0) Q "RTN","DPTLK") 0^12^B144170705 "RTN","DPTLK",1,0) DPTLK ;ALB/RMO,RTK,ARF,JAM - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm "RTN","DPTLK",2,0) ;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647,769,857,876,915,919,993,1031,1014**;Aug 13, 1993;Build 42 "RTN","DPTLK",3,0) ; "RTN","DPTLK",4,0) ; mods made for magstripe read 12/96 - JFP "RTN","DPTLK",5,0) ; mods made for VIC 4.0 (barcode and magstripe) read 4/2012 - ELZ (*857) "RTN","DPTLK",6,0) ; "RTN","DPTLK",7,0) ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented "RTN","DPTLK",8,0) ; by patch DG*5.3*244 "RTN","DPTLK",9,0) ; "RTN","DPTLK",10,0) EN ; -- Entry point "RTN","DPTLK",11,0) N DIE,DR,DGSEARCH,DPTXX "RTN","DPTLK",12,0) K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X))) "RTN","DPTLK",13,0) I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK "RTN","DPTLK",14,0) I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK "RTN","DPTLK",15,0) EN2 K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0),1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X "RTN","DPTLK",16,0) S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ) "RTN","DPTLK",17,0) ; "RTN","DPTLK",18,0) ASKPAT ; -- Prompt for patient "RTN","DPTLK",19,0) I DIC(0)["A" D G QK:'$T!($E(DPTX)["^")!(DPTX="") "RTN","DPTLK",20,0) .K DTOUT,DUOUT,DGNEW,DGSEARCH "RTN","DPTLK",21,0) .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// " "RTN","DPTLK",22,0) .R X:DTIME "RTN","DPTLK",23,0) .S (DPTX,DPTXX)=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1 "RTN","DPTLK",24,0) ; -- Check for the IATA magnetic stripe input "RTN","DPTLK",25,0) N MAG,GCHK,BARCODE,DGVIC40,DGCAC "RTN","DPTLK",26,0) S (MAG,BARCODE,DGVIC40,DGCAC)=0 "RTN","DPTLK",27,0) I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX) "RTN","DPTLK",28,0) I 'MAG,DPTX?1"%"1N13ANP.3AN S BARCODE=1,(X,DPTX)=$$BARCODE($$UP^XLFSTR(DPTX)) "RTN","DPTLK",29,0) ; - read other line but don't use dbia#10096 don't display input "RTN","DPTLK",30,0) I $G(DGVIC40),'BARCODE X ^%ZOSF("EOFF") R X(1):1 X ^%ZOSF("EON") "RTN","DPTLK",31,0) I 'MAG,'BARCODE,DPTX?1N6AN1A7AN1A2AN S DGCAC=1,(X,DPTX)=$$CACCARD($$UP^XLFSTR(DPTX)) "RTN","DPTLK",32,0) ; fail VHIC card match but starts with %, we're done "RTN","DPTLK",33,0) I 'MAG,'BARCODE,'DGCAC,$E(DPTX,1)="%" G CHKDFN "RTN","DPTLK",34,0) ; "RTN","DPTLK",35,0) CHKPAT ; -- Custom Patient Lookup "RTN","DPTLK",36,0) D DO^DIC1 "RTN","DPTLK",37,0) S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"") "RTN","DPTLK",38,0) K DPTIFNS,DPTS,DPTSEL "RTN","DPTLK",39,0) S DPTCNT=0 "RTN","DPTLK",40,0) ; -- Check input for format an length "RTN","DPTLK",41,0) G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)&('$G(DGVIC40)) "RTN","DPTLK",42,0) ; -- Check for null response or abort "RTN","DPTLK",43,0) I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK "RTN","DPTLK",44,0) ; -- Check for question mark "RTN","DPTLK",45,0) I DPTX["?" D G ASKPAT:DIC(0)["A",QK "RTN","DPTLK",46,0) .S D="B" "RTN","DPTLK",47,0) .S DZ=$S(DPTX?1"?":"",1:"??") "RTN","DPTLK",48,0) .G CHKPAT1:DZ="??" "RTN","DPTLK",49,0) .N % "RTN","DPTLK",50,0) .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of" "RTN","DPTLK",51,0) .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER" "RTN","DPTLK",52,0) .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN "RTN","DPTLK",53,0) .Q:%'=1 "RTN","DPTLK",54,0) .S DZ="??" "RTN","DPTLK",55,0) CHKPAT1 .S X=DPTX "RTN","DPTLK",56,0) .D DQ^DICQ "RTN","DPTLK",57,0) ; -- Check for space bar, return "RTN","DPTLK",58,0) I DPTX=" " D G CHKDFN "RTN","DPTLK",59,0) .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) "RTN","DPTLK",60,0) .D SETDPT^DPTLK1:Y>0 "RTN","DPTLK",61,0) .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) "RTN","DPTLK",62,0) ; -- Check for DFN look up "RTN","DPTLK",63,0) I $E(DPTX)="`" D G CHKDFN "RTN","DPTLK",64,0) .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1) "RTN","DPTLK",65,0) .D SETDPT^DPTLK1:Y>0 "RTN","DPTLK",66,0) .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) "RTN","DPTLK",67,0) ; -- Puts input in correct format "RTN","DPTLK",68,0) G CHKDFN:DPTX="" "RTN","DPTLK",69,0) ; -- Force new entry "RTN","DPTLK",70,0) I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" D STOP G ASKPAT ;DG*5.3*993 "RTN","DPTLK",71,0) ; -- Check for EDIPI lookup "RTN","DPTLK",72,0) I DPTX?10N,DIC(0)["M" D G:$G(DPTDFN)>0 CHKDFN "RTN","DPTLK",73,0) .N DGEDIPI "RTN","DPTLK",74,0) .S DGEDIPI=0 F S DGEDIPI=$O(^DGCN(391.91,"AISS",DPTX,"USDOD","NI",+$$IEN^XUAF4("200DOD"),DGEDIPI)) Q:'DGEDIPI I $P($G(^DGCN(391.91,DGEDIPI,2)),"^",3)'="H" Q "RTN","DPTLK",75,0) .Q:DGEDIPI<1 "RTN","DPTLK",76,0) .S Y=$P($G(^DGCN(391.91,DGEDIPI,0)),"^") "RTN","DPTLK",77,0) .D SETDPT^DPTLK1:Y>0 "RTN","DPTLK",78,0) .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) "RTN","DPTLK",79,0) ; -- Check for index lookups "RTN","DPTLK",80,0) ; DG*5.3*1031 remove the use of the DGSTOP var - not needed - was added by DG*5.3*993 "RTN","DPTLK",81,0) ;N DGSTOP S DGSTOP=0 "RTN","DPTLK",82,0) ;I '$G(DGVIC40)!(DPTX?9N) D ^DPTLK1 D G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT)!(DGSTOP=1),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN "RTN","DPTLK",83,0) I '$G(DGVIC40)!(DPTX?9N) D ^DPTLK1 D G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN "RTN","DPTLK",84,0) . ;Next lines inclusively stop creation of a patient if Load/Edit Patient Data or Admit A Patient DG*5.3*993 "RTN","DPTLK",85,0) . ; DG*5.3*1031 - this check moved to tag NOPAT "RTN","DPTLK",86,0) . ;I DPTDFN=0,$P($G(XQY0),"^",1)="DG LOAD PATIENT DATA"!($P($G(XQY0),"^",1)="DG ADMIT PATIENT") I $G(DIVDIC)'["IBA" I (X'="^"),(X'="") I DIC(0)["A" W:DIC(0)["Q" *7," ??" D STOP Q ;adding sponsor "RTN","DPTLK",87,0) . I DPTDFN<1,$P($G(XQY0),"^",1)="DG REGISTER PATIENT",$T(PATIENT^MPIFXMLP)'="",'MAG D "RTN","DPTLK",88,0) .. S DPTDFN=$$SEARCH^DPTLK7(DPTX,$G(DPTXX)) "RTN","DPTLK",89,0) .. I DPTDFN<1 K DO,D,DIC("W"),DPTCNT,DPTS,DPTSEL,DPTSZ S DPTDFN=-1,Y=-1,(DPTX,DPTXX)="" "RTN","DPTLK",90,0) .. S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ) "RTN","DPTLK",91,0) .. S:DPTDFN>0 DPTS(DPTDFN)=$P(^DPT(DPTDFN,0),"^")_"^"_$P(^DPT(DPTDFN,0),"^") "RTN","DPTLK",92,0) MAG ; -- No patient found, check for mag stripe input, create stub "RTN","DPTLK",93,0) I 'MAG,'BARCODE,'DGCAC G NOPAT "RTN","DPTLK",94,0) ; -- Check for ADT option(s) only "RTN","DPTLK",95,0) N DGOPT "RTN","DPTLK",96,0) S DGOPT=$P($G(XQY0),"^",2) "RTN","DPTLK",97,0) I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D G EN2 "RTN","DPTLK",98,0) .W !," ...Patient not in database, use ADT options to load patient" D Q1 "RTN","DPTLK",99,0) ; -- Prompt for creation of stub "RTN","DPTLK",100,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: " "RTN","DPTLK",101,0) S GCHK=$D(^TMP("DGVIC")) "RTN","DPTLK",102,0) D ^DIR "RTN","DPTLK",103,0) K DIR "RTN","DPTLK",104,0) I 'Y D Q1 G EN2 "RTN","DPTLK",105,0) ; -- Parse IATA fields "RTN","DPTLK",106,0) D @$S(DGVIC40:"VIC40(.DGFLDS,DGVIC40,DGCAC)",1:"FIELDS(IATA)") "RTN","DPTLK",107,0) I '$D(@DGFLDS) W !,"Could not add patient to patient file" D Q1 G EN2 "RTN","DPTLK",108,0) ; -- Check for Duplicates, no checking if VIC 4.0 card or CAC card "RTN","DPTLK",109,0) D:'$G(DGVIC40) EP2^DPTLK3 "RTN","DPTLK",110,0) ; -- No check done on VIC 4.0 or CAC card, so skip DPTDFN value "RTN","DPTLK",111,0) ; check, file record "RTN","DPTLK",112,0) I 'DGVIC40,DPTDFN<0 D Q1 G EN2 "RTN","DPTLK",113,0) ; -- Creates Stub entry in patient file "RTN","DPTLK",114,0) S Y=$$FILE^DPTLK4(DGFLDS,$G(DGVIC40)) "RTN","DPTLK",115,0) I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q "RTN","DPTLK",116,0) D QK1 "RTN","DPTLK",117,0) Q "RTN","DPTLK",118,0) ; "RTN","DPTLK",119,0) STOP ; "RTN","DPTLK",120,0) I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" W:DIC(0)["Q" *7," ??" ;DG*5.3*993 "RTN","DPTLK",121,0) W !!?5,"Use Register A Patient option to add a new person." ;DG*5.3*993 "RTN","DPTLK",122,0) W !!?5,"Press RETURN to continue..." R X:DTIME ;DG*5.3*993 "RTN","DPTLK",123,0) ; DG*5.3*1031 remove DGSTOP var - not needed "RTN","DPTLK",124,0) ;S DGSTOP=1 "RTN","DPTLK",125,0) Q "RTN","DPTLK",126,0) ; "RTN","DPTLK",127,0) NOPAT ; -- No patient found, ask to add new "RTN","DPTLK",128,0) ; DG*5.3*1031;jam; If in Load/Edit or Admit, and not in "Ask" mode (DIC(0)'["A"), then quit. This allows trigger code that does lookups which end up in this routine, to quit (and not call STOP and go back to ASKPAT) "RTN","DPTLK",129,0) ; Otherwise, (per patch DG*5.3*993) do not allow adding a new patient and reprompt for the patient entry. "RTN","DPTLK",130,0) I $P($G(XQY0),"^",1)="DG LOAD PATIENT DATA"!($P($G(XQY0),"^",1)="DG ADMIT PATIENT") G:DIC(0)'["A" QK1 W:DIC(0)["Q" *7," ??" D STOP G ASKPAT "RTN","DPTLK",131,0) I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G(DTOUT)),QK1 "RTN","DPTLK",132,0) ; "RTN","DPTLK",133,0) CHKDFN ; -- "RTN","DPTLK",134,0) S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q" *7," ??" G ASKPAT:DIC(0)["A",QK "RTN","DPTLK",135,0) N DGPREFNM ;DG*5.3*1014 ARF - add PRFERRED NAME to prompt display response if populated "RTN","DPTLK",136,0) S DGPREFNM=$$GET1^DIQ(2,DPTDFN,.2405) "RTN","DPTLK",137,0) ;DG*5.3*1014 - ARF -Add conditional write to the following line of code to display PREFERRED NAME .2405 when the field is populated "RTN","DPTLK",138,0) I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_" "_$P(DPTS(DPTDFN),U)_" ",$D(^DPT(DPTDFN,0)):" "_$P(^(0),U)_" ",1:"") W:DGPREFNM'="" "(",DGPREFNM,")" S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")" "RTN","DPTLK",139,0) .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY "RTN","DPTLK",140,0) ; "RTN","DPTLK",141,0) ; check for other patients in "BS5" xref on Patient file "RTN","DPTLK",142,0) ;I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0 "RTN","DPTLK",143,0) I DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN),'$D(DGSEARCH) D G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0 ;*TEST* "RTN","DPTLK",144,0) .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P(DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9) "RTN","DPTLK",145,0) .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and" "RTN","DPTLK",146,0) .W !,"whose social security number ends with '",DPTSSN,"'." "RTN","DPTLK",147,0) .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN "RTN","DPTLK",148,0) .I %'=1 S DPTDFN=-1 "RTN","DPTLK",149,0) ; "RTN","DPTLK",150,0) ;I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0 "RTN","DPTLK",151,0) I DPTDFN>0,DIC(0)["E" S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0 S DPTBTDT=1 "RTN","DPTLK",152,0) S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U) "RTN","DPTLK",153,0) ; "RTN","DPTLK",154,0) Q ; -- "RTN","DPTLK",155,0) S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)&(+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"") "RTN","DPTLK",156,0) I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1) "RTN","DPTLK",157,0) ;DG*600 "RTN","DPTLK",158,0) I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient." "RTN","DPTLK",159,0) I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator." "RTN","DPTLK",160,0) I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE." "RTN","DPTLK",161,0) ;DG*485 "RTN","DPTLK",162,0) I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5 "RTN","DPTLK",163,0) ;Display enrollment information "RTN","DPTLK",164,0) I Y>0,DIC(0)["E" D ENR "RTN","DPTLK",165,0) ; "RTN","DPTLK",166,0) ;Call Combat Vet check "RTN","DPTLK",167,0) I Y>0,DIC(0)["E" D CV "RTN","DPTLK",168,0) ; "RTN","DPTLK",169,0) ; check whether to display Means Test Required message "RTN","DPTLK",170,0) D "RTN","DPTLK",171,0) .N DPTDIV "RTN","DPTLK",172,0) .I '$G(DUZ(2)) Q "RTN","DPTLK",173,0) .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D "RTN","DPTLK",174,0) ..W $C(7),!!,"MEANS TEST REQUIRED" "RTN","DPTLK",175,0) ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2) "RTN","DPTLK",176,0) ..H 2 "RTN","DPTLK",177,0) ; "RTN","DPTLK",178,0) Q1 ; -- Clean up variables "RTN","DPTLK",179,0) K D,DIC("W"),DO,DPTCNT,G,DPTIFNS,DPTIX,DPTS "RTN","DPTLK",180,0) K:'$G(DICR) DPTBTDT ; IF DICR LEAVE FOR DGSEC TO HANDLE "RTN","DPTLK",181,0) K DPTSAVX,DPTSEL,DPTSZ,DPTX "RTN","DPTLK",182,0) ; "RTN","DPTLK",183,0) K:$D(IATA) IATA "RTN","DPTLK",184,0) K:$D(DGFLDS) @DGFLDS,DGFLDS "RTN","DPTLK",185,0) Q "RTN","DPTLK",186,0) ; "RTN","DPTLK",187,0) QK K:'$D(DPTNOFZK) DPTNOFZY G Q "RTN","DPTLK",188,0) ; "RTN","DPTLK",189,0) QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1 "RTN","DPTLK",190,0) ; "RTN","DPTLK",191,0) IX ; -- "RTN","DPTLK",192,0) I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D "RTN","DPTLK",193,0) G DPTLK "RTN","DPTLK",194,0) ; "RTN","DPTLK",195,0) IATA(X) ; -- "RTN","DPTLK",196,0) ;This function pulls off ssn from the IATA track (old card) "RTN","DPTLK",197,0) ; - If new card, then use card number to look-up DFN, returned as `DFN "RTN","DPTLK",198,0) ; "RTN","DPTLK",199,0) ;Input: X - what was read in "RTN","DPTLK",200,0) ;Output: SSN - social security number OR `DFN if new card "RTN","DPTLK",201,0) ; Q - quit "RTN","DPTLK",202,0) ; "RTN","DPTLK",203,0) ; Track Start Sent End Sent Field Separator "RTN","DPTLK",204,0) ; ----- ---------- -------- --------------- "RTN","DPTLK",205,0) ; IATA (alphanum) % ? { (Note: VA used ^) "RTN","DPTLK",206,0) ; ABA (numeric) ; ? = "RTN","DPTLK",207,0) ; "RTN","DPTLK",208,0) ;N IATA "RTN","DPTLK",209,0) S (IATA)="" "RTN","DPTLK",210,0) I $E(X)'="%" Q X ; no start sentinel "RTN","DPTLK",211,0) I X'["?" Q "Q" "RTN","DPTLK",212,0) ; -- Extract data from track "RTN","DPTLK",213,0) S IATA=$$TRACK(X,"%","?") "RTN","DPTLK",214,0) ; -- checks for no data "RTN","DPTLK",215,0) I IATA="" Q "Q" "RTN","DPTLK",216,0) ; -- checks for new card, look-up DFN "RTN","DPTLK",217,0) I $E(X,1,29)?1"%"9NP1"^"17UNP1"?" D "RTN","DPTLK",218,0) . N CARD "RTN","DPTLK",219,0) . S CARD=+$P($P(X,"%",2),"^") "RTN","DPTLK",220,0) . ; **919, Story 220135 (elz) log the card activity "RTN","DPTLK",221,0) . D CARDLOG^MPIFAPI(CARD,"VHIC","SWIPE") "RTN","DPTLK",222,0) . S IATA=$$CARD(CARD) "RTN","DPTLK",223,0) ; -- Returns SSN or `DFN value "RTN","DPTLK",224,0) I IATA'="" Q $P(IATA,"^") "RTN","DPTLK",225,0) Q "Q" "RTN","DPTLK",226,0) ; "RTN","DPTLK",227,0) TRACK(X,START,END) ; find track where start/end are sentinels "RTN","DPTLK",228,0) ; "RTN","DPTLK",229,0) Q $P($P($G(X),START,2),END,1) "RTN","DPTLK",230,0) ; "RTN","DPTLK",231,0) FIELDS(IATA) ; -- Sets fields "RTN","DPTLK",232,0) Q:'$D(IATA) "RTN","DPTLK",233,0) N CNT,FIELD "RTN","DPTLK",234,0) S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1 "RTN","DPTLK",235,0) K @DGFLDS "RTN","DPTLK",236,0) F S FIELD=$P($G(IATA),"^",CNT) Q:FIELD="" D "RTN","DPTLK",237,0) .S @DGFLDS@(CNT)=FIELD "RTN","DPTLK",238,0) .S CNT=CNT+1 "RTN","DPTLK",239,0) ; -- Define fields for duplicate checker "RTN","DPTLK",240,0) S DPTX=$G(@DGFLDS@(2)) ;NAME "RTN","DPTLK",241,0) S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB "RTN","DPTLK",242,0) S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN "RTN","DPTLK",243,0) Q "RTN","DPTLK",244,0) BARCODE(X) ; "RTN","DPTLK",245,0) ;This function pulls off card number from the barcode scan "RTN","DPTLK",246,0) ; looks up the patient (locally) "RTN","DPTLK",247,0) ; if not locally found, queries mpi "RTN","DPTLK",248,0) ; "RTN","DPTLK",249,0) ;Input: X - what was read in "RTN","DPTLK",250,0) ;Output: DFN - `DFN "RTN","DPTLK",251,0) ; Q - quit "RTN","DPTLK",252,0) ; "RTN","DPTLK",253,0) ; Input Start Data VIC ver DoD EDI_PIN VA/VIC II "RTN","DPTLK",254,0) ; -------- ---------- ------- ----------- ---------- "RTN","DPTLK",255,0) ; alphanum % N alphanum 7 alphanum 6 "RTN","DPTLK",256,0) ; "RTN","DPTLK",257,0) N CARD "RTN","DPTLK",258,0) S CARD=$$B32TO10($E(X,10,15)) I 'CARD Q "Q" "RTN","DPTLK",259,0) ; **919, Story 220135 (elz) log the card activity "RTN","DPTLK",260,0) D CARDLOG^MPIFAPI(CARD,"VHIC","SCAN") "RTN","DPTLK",261,0) Q $$CARD(CARD) "RTN","DPTLK",262,0) ; "RTN","DPTLK",263,0) CACCARD(X) ; "RTN","DPTLK",264,0) ;This function pulls off EDIPI number from the CAC barcode scan "RTN","DPTLK",265,0) ; looks up the patient (locally) "RTN","DPTLK",266,0) ; if not locally found, queries mpi "RTN","DPTLK",267,0) ; "RTN","DPTLK",268,0) ;Input: X - what was read in "RTN","DPTLK",269,0) ;Output: DFN - `DFN "RTN","DPTLK",270,0) ; Q - quit "RTN","DPTLK",271,0) ; "RTN","DPTLK",272,0) ; VC PDI PT DoD EDI PC BC CI "RTN","DPTLK",273,0) ; -- --- -- ------- -- --- --- "RTN","DPTLK",274,0) ; "1" 6UN 1U 7UN 1U 1UN 1UN "RTN","DPTLK",275,0) ; "RTN","DPTLK",276,0) N EDIPI "RTN","DPTLK",277,0) S EDIPI=$$B32TO10($E(X,9,15)) I 'EDIPI Q "Q" "RTN","DPTLK",278,0) Q $$EDIPI(EDIPI) "RTN","DPTLK",279,0) ; "RTN","DPTLK",280,0) EDIPI(EDIPI) ; - returns `DFN from EDIPI number "RTN","DPTLK",281,0) N DFN,VICFAC "RTN","DPTLK",282,0) ; **919, Story 220135 (elz) log the card activity "RTN","DPTLK",283,0) D CARDLOG^MPIFAPI(EDIPI,"CAC","SCAN") "RTN","DPTLK",284,0) S VICFAC=+$$LKUP^XUAF4("200DOD") ; national DOD station number "RTN","DPTLK",285,0) S DFN=+$G(^DGCN(391.91,+$O(^DGCN(391.91,"ASID",EDIPI,VICFAC,0)),0)) "RTN","DPTLK",286,0) S DGVIC40=EDIPI ; saving EDIPI number here so I don't have to look later "RTN","DPTLK",287,0) I DFN Q "`"_DFN "RTN","DPTLK",288,0) ; - not found locally, need to make sure we don't find anyone DGVIC40 "RTN","DPTLK",289,0) Q "Q" "RTN","DPTLK",290,0) CARD(CARD) ; - returns `DFN from card number "RTN","DPTLK",291,0) N DFN,VICFAC "RTN","DPTLK",292,0) S VICFAC=+$$LKUP^XUAF4("742V1") ; national vic facility number "RTN","DPTLK",293,0) S DFN=+$G(^DGCN(391.91,+$O(^DGCN(391.91,"ASID",CARD,VICFAC,0)),0)) "RTN","DPTLK",294,0) S DGVIC40=CARD ; saving card number here so I don't have to look later "RTN","DPTLK",295,0) I DFN Q "`"_DFN "RTN","DPTLK",296,0) ; - not found locally, need to make sure we don't find anyone DGVIC40 "RTN","DPTLK",297,0) Q "Q" "RTN","DPTLK",298,0) VIC40(DGFLDS,DGVIC40,DGCAC) ; - returns the data used to create the "RTN","DPTLK",299,0) ; patient file entry from mpi "RTN","DPTLK",300,0) N X,DGMPI "RTN","DPTLK",301,0) S DGFLDS="^TMP(""DGVIC"","_$J_")" "RTN","DPTLK",302,0) K @DGFLDS "RTN","DPTLK",303,0) I $T(CARDPV^MPIFXMLS)'="" D CARDPV^MPIFXMLS(.DGMPI,DGVIC40,DGCAC) "RTN","DPTLK",304,0) S X=0 F S X=$O(DGMPI(X)) Q:'X S @DGFLDS@(X)=DGMPI(X) "RTN","DPTLK",305,0) Q "RTN","DPTLK",306,0) ENR ;Display Enrollment information after patient selection "RTN","DPTLK",307,0) N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT "RTN","DPTLK",308,0) I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q "RTN","DPTLK",309,0) S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN) "RTN","DPTLK",310,0) S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT) "RTN","DPTLK",311,0) W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP")))) "RTN","DPTLK",312,0) W ?33,"Category: ",DGENCAT "RTN","DPTLK",313,0) W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),! "RTN","DPTLK",314,0) ;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I) "RTN","DPTLK",315,0) I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D "RTN","DPTLK",316,0) . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"") ;H 5 "RTN","DPTLK",317,0) ;check for Combat Veteran Eligibility, if elig do not display EGT info "RTN","DPTLK",318,0) I $$CVEDT^DGCV(+DPTDFN) Q "RTN","DPTLK",319,0) ;Get Enrollment Group Threshold Priority and Subgroup "RTN","DPTLK",320,0) S DGEGTIEN=$$FINDCUR^DGENEGT "RTN","DPTLK",321,0) S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT) "RTN","DPTLK",322,0) Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="") "RTN","DPTLK",323,0) ;Compare Patient's Enrollment Priority to Enrollment Group Threshold "RTN","DPTLK",324,0) I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP")) D "RTN","DPTLK",325,0) .N X,IORVOFF,IORVON "RTN","DPTLK",326,0) .S X="IORVOFF;IORVON" "RTN","DPTLK",327,0) .D ENDR^%ZISS "RTN","DPTLK",328,0) .W !?32 W:$D(IORVON) IORVON W "*** WARNING ***" W:$D(IORVOFF) IORVOFF "RTN","DPTLK",329,0) .I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$$FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q "RTN","DPTLK",330,0) .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING. ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF "RTN","DPTLK",331,0) Q "RTN","DPTLK",332,0) CV ;check for Combat Vet status "RTN","DPTLK",333,0) N DGCV "RTN","DPTLK",334,0) S DGCV=$$CVEDT^DGCV(+DPTDFN) "RTN","DPTLK",335,0) I $P(DGCV,U)=1 D Q "RTN","DPTLK",336,0) . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W ! "RTN","DPTLK",337,0) . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ") "RTN","DPTLK",338,0) Q "RTN","DPTLK",339,0) B32TO10(X) ; - convert from base 32 to base 10 "RTN","DPTLK",340,0) N I,Y,S S Y=0,S="0123456789ABCDEFGHIJKLMNOPQRSTUV" "RTN","DPTLK",341,0) I X[" " S X=$E(X,1,$F(X," ")-2) "RTN","DPTLK",342,0) F I=1:1:$L(X) S Y=Y*32+($F(S,$E(X,I))-2) "RTN","DPTLK",343,0) Q Y "RTN","DPTLK",344,0) RPCVIC(RETURN,DPTX) ; - patient lookup from VIC card, rpc/api "RTN","DPTLK",345,0) ; non-interactive "RTN","DPTLK",346,0) ; this function will return a patient's DFN based on input. input must "RTN","DPTLK",347,0) ; be in the form of the FULL input from a VIC card (magstripe or bar "RTN","DPTLK",348,0) ; code), the patient must be locally known (FULL doesn't but can contain "RTN","DPTLK",349,0) ; additional card tracks) "RTN","DPTLK",350,0) ; RETURN input should be passed by reference "RTN","DPTLK",351,0) ; "RTN","DPTLK",352,0) ; Input examples: "RTN","DPTLK",353,0) ; Barcode possibilities: "RTN","DPTLK",354,0) ; NNNNNNNNN (old VIC card, full 9 digit ssn) "RTN","DPTLK",355,0) ; CCCCCCCCCCCCCCCCCC (new VIC 4.0 card, 18 characters with "RTN","DPTLK",356,0) ; 10-15 being compressed card number) "RTN","DPTLK",357,0) ; Magstripe possibilities: "RTN","DPTLK",358,0) ; Must always start with % "RTN","DPTLK",359,0) ; Must contain ? "RTN","DPTLK",360,0) ; $E(X,2,10) = SSN (old card) "RTN","DPTLK",361,0) ; %NNNNNNNNN^CCCCCCCCCCCCCCCCC? (first 29 characters) where "RTN","DPTLK",362,0) ; N = card number (new card) "RTN","DPTLK",363,0) ; "RTN","DPTLK",364,0) ; Return (pass by reference): If patient known locally = DFN "RTN","DPTLK",365,0) ; If not known locally = -1 "RTN","DPTLK",366,0) ; "RTN","DPTLK",367,0) N MAG,BARCODE "RTN","DPTLK",368,0) S (RETURN,MAG,BARCODE)=0 "RTN","DPTLK",369,0) I '$D(DPTX) Q -1 "RTN","DPTLK",370,0) S DPTX=$$UP^XLFSTR(DPTX) "RTN","DPTLK",371,0) I DPTX["?" S DPTX=$E(DPTX,1,$F(DPTX,"?")-1) "RTN","DPTLK",372,0) I DPTX?9N S RETURN=$O(^DPT("SSN",DPTX,0)) "RTN","DPTLK",373,0) I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?",'RETURN S MAG=1,DPTX=$$IATA(DPTX) "RTN","DPTLK",374,0) I 'MAG,DPTX?1"%"1N13UNP.3UN,'RETURN S BARCODE=1,DPTX=$$BARCODE(DPTX) "RTN","DPTLK",375,0) I 'MAG,'BARCODE,DPTX?1N6UN1U7UN1U2UN S DPTX=$$CACCARD(DPTX) "RTN","DPTLK",376,0) I 'RETURN,$E(DPTX,2,999) S RETURN=$S($E(DPTX)="`":$E(DPTX,2,999),1:$O(^DPT("SSN",DPTX,0))) "RTN","DPTLK",377,0) S RETURN=$S(RETURN:RETURN,1:-1) "RTN","DPTLK",378,0) Q "RTN","VAFHLZCE") 0^31^B13475226 "RTN","VAFHLZCE",1,0) VAFHLZCE ;ALB/KUM - Create generic HL7 Community Care Program (ZCE) segments ;06/16/20 3:34PM "RTN","VAFHLZCE",2,0) ;;5.3;Registration;**1014**;Aug 13, 1993;Build 42 "RTN","VAFHLZCE",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","VAFHLZCE",4,0) ; "RTN","VAFHLZCE",5,0) ; "RTN","VAFHLZCE",6,0) ;Supported ICRs "RTN","VAFHLZCE",7,0) ; #2056 - $$GET1^DIQ(} "RTN","VAFHLZCE",8,0) ; "RTN","VAFHLZCE",9,0) ; This generic extrinsic function is designed to return the "RTN","VAFHLZCE",10,0) ; HL7 Community Care Program (ZCE) segment. This segment contains VA-specific "RTN","VAFHLZCE",11,0) ; Community Care Eligibility data for a patient. "RTN","VAFHLZCE",12,0) ; "RTN","VAFHLZCE",13,0) EN(DFN,VAFSTR,VAFNUM,VAFHLQ,VAFHLFS,VAFZCE) ; build HL7 ZCE segments. "RTN","VAFHLZCE",14,0) ; ZCE segments will be returned in the array VAFZCE. "RTN","VAFHLZCE",15,0) ; "RTN","VAFHLZCE",16,0) ; Input: DFN - Pointer to PATIENT file (#2) "RTN","VAFHLZCE",17,0) ; VAFSTR - String of fields requested separated by commas "RTN","VAFHLZCE",18,0) ; VAFNUM - (optional) sequential number for SET ID (default=1) "RTN","VAFHLZCE",19,0) ; VAFHLQ - (optional) HL7 null variable. "RTN","VAFHLZCE",20,0) ; VAFHLFS - (optional) HL7 field separator. "RTN","VAFHLZCE",21,0) ; .VAFZCE - Array to return segments in "RTN","VAFHLZCE",22,0) ; "RTN","VAFHLZCE",23,0) ; "RTN","VAFHLZCE",24,0) ; Output: VAFZCE(X) = ZCE segment (first 245 characters) "RTN","VAFHLZCE",25,0) ; VAFZCE(X,Y) = Remaining portion of ZCE segment in 245 character chunks "RTN","VAFHLZCE",26,0) ; "RTN","VAFHLZCE",27,0) ; Notes: VAFZCE is initialized (KILLed) on input. "RTN","VAFHLZCE",28,0) ; "RTN","VAFHLZCE",29,0) N VAFHLZCE,VAFNUM,VAFMAXL,VAFIE1,DGFIDX,DGUPDT,DGREC "RTN","VAFHLZCE",30,0) K VAFZCE "RTN","VAFHLZCE",31,0) ; "RTN","VAFHLZCE",32,0) ; if VAFHLQ or VAFHLFS not passed, use default HL7 variables "RTN","VAFHLZCE",33,0) S VAFHLQ=$S($D(VAFHLQ):VAFHLQ,1:$G(HLQ)),VAFHLFS=$S($D(VAFHLFS):VAFHLFS,1:$G(HLFS)) "RTN","VAFHLZCE",34,0) ; "RTN","VAFHLZCE",35,0) ; if set id not passed, use default "RTN","VAFHLZCE",36,0) S VAFNUM=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLZCE",37,0) ; "RTN","VAFHLZCE",38,0) S VAFMAXL=245 "RTN","VAFHLZCE",39,0) S VAFSTR=","_VAFSTR_"," "RTN","VAFHLZCE",40,0) ; Do not create ZCE segment if Archive flag is 1 "RTN","VAFHLZCE",41,0) K DGTMP "RTN","VAFHLZCE",42,0) M DGTMP(DFN,5)=^DPT(DFN,5) "RTN","VAFHLZCE",43,0) S DGFIDX=0 "RTN","VAFHLZCE",44,0) F S DGFIDX=$O(DGTMP(DFN,5,DGFIDX)) Q:'DGFIDX S DGREC=$G(DGTMP(DFN,5,DGFIDX,0)) D ; "RTN","VAFHLZCE",45,0) .I $P(DGREC,U,5)'=1 D "RTN","VAFHLZCE",46,0) ..S DGUPDT=$P(DGREC,U) "RTN","VAFHLZCE",47,0) ..S DGTMP("UPDT",DGUPDT,DGFIDX)=DGREC "RTN","VAFHLZCE",48,0) ; ZCE for approved requests "RTN","VAFHLZCE",49,0) S DGUPDT="" "RTN","VAFHLZCE",50,0) F S DGUPDT=$O(DGTMP("UPDT",DGUPDT)) Q:DGUPDT="" D "RTN","VAFHLZCE",51,0) .S DGFIDX="" F S DGFIDX=$O(DGTMP("UPDT",DGUPDT,DGFIDX)) Q:DGFIDX="" D "RTN","VAFHLZCE",52,0) ..D GETDATA(DGFIDX),MAKESEG S VAFNUM=VAFNUM+1 "RTN","VAFHLZCE",53,0) ..Q "RTN","VAFHLZCE",54,0) .Q "RTN","VAFHLZCE",55,0) Q "RTN","VAFHLZCE",56,0) ; "RTN","VAFHLZCE",57,0) GETDATA(DGFIDX) ; Get information needed to build ZCE segment "RTN","VAFHLZCE",58,0) ; Input: "RTN","VAFHLZCE",59,0) ; DGFIDX = IEN of Subfile #2.191 Community Care Program "RTN","VAFHLZCE",60,0) ; "RTN","VAFHLZCE",61,0) ; Existence of the following variables is assumed "RTN","VAFHLZCE",62,0) ; DFN - Pointer to Patient (#2) file "RTN","VAFHLZCE",63,0) ; VAFSTR - Fields to extract (padded with commas) "RTN","VAFHLZCE",64,0) ; VAFNUM - Value to use for Set ID (optional) "RTN","VAFHLZCE",65,0) ; HL7 encoding characters (HLFS, HLENC, HLQ) "RTN","VAFHLZCE",66,0) ; "RTN","VAFHLZCE",67,0) ; Output: VAFHLZCE(SeqNum) = Value "RTN","VAFHLZCE",68,0) ; "RTN","VAFHLZCE",69,0) ; Notes: VAFHLZCE is initialized (KILLed) on entry "RTN","VAFHLZCE",70,0) ; "RTN","VAFHLZCE",71,0) N VAFIEN,VAFPGM,VAFEFD,VAFEND,VAFCCD "RTN","VAFHLZCE",72,0) K VAFHLZCE "RTN","VAFHLZCE",73,0) S VAFIEN=DGFIDX_","_DFN_"," "RTN","VAFHLZCE",74,0) S VAFPGM=$$GET1^DIQ(2.191,VAFIEN,1,"I") "RTN","VAFHLZCE",75,0) S VAFEFD=$$GET1^DIQ(2.191,VAFIEN,2,"I") "RTN","VAFHLZCE",76,0) S VAFEND=$$GET1^DIQ(2.191,VAFIEN,3,"I") "RTN","VAFHLZCE",77,0) S VAFCCD=$$GET1^DIQ(2.191,VAFIEN,.01,"I") "RTN","VAFHLZCE",78,0) ; "RTN","VAFHLZCE",79,0) ; set-up segment data fields "RTN","VAFHLZCE",80,0) I VAFSTR[",1," S VAFHLZCE(1)=+$G(VAFNUM) ; Sequential ID "RTN","VAFHLZCE",81,0) I VAFSTR[",2," S VAFHLZCE(2)=$S($G(VAFPGM)]"":$G(VAFPGM),1:VAFHLQ) ; Community Care Progarm Code "RTN","VAFHLZCE",82,0) I VAFSTR[",3," S VAFHLZCE(3)=$S($G(VAFEFD)]"":$$HLDATE^HLFNC($G(VAFEFD),"DT"),1:VAFHLQ) ; Effective Date "RTN","VAFHLZCE",83,0) I VAFSTR[",4," S VAFHLZCE(4)=$S($G(VAFEND)]"":$$HLDATE^HLFNC($G(VAFEND),"DT"),1:VAFHLQ) ; End Date "RTN","VAFHLZCE",84,0) I VAFSTR[",5," S VAFHLZCE(5)=$S($G(VAFCCD)]"":$$HLDATE^HLFNC($G(VAFCCD),"TS"),1:VAFHLQ) ; Last Updated Date "RTN","VAFHLZCE",85,0) ; "RTN","VAFHLZCE",86,0) Q "RTN","VAFHLZCE",87,0) ; "RTN","VAFHLZCE",88,0) MAKESEG ; Create segment using obtained data "RTN","VAFHLZCE",89,0) ; Input: Existence of the following variables is assumed "RTN","VAFHLZCE",90,0) ; VAFNUM = Number denoting Xth repetition of the ZCE segment "RTN","VAFHLZCE",91,0) ; VAFMAXL = Maximum length of each node (defaults to 245) "RTN","VAFHLZCE",92,0) ; VAFHLZCE(SeqNum) = Value "RTN","VAFHLZCE",93,0) ; HL7 encoding characters (HLFS, HLECH) "RTN","VAFHLZCE",94,0) ; "RTN","VAFHLZCE",95,0) ; Output: VAFZCE(VAFNUM) = ZCE segment (first VAFMAXL characters) "RTN","VAFHLZCE",96,0) ; VAFZCE(VAFNUM,x) = Remaining portion of ZCE segment in VAFMAXL character chunks (if needed), beginning with a field separator "RTN","VAFHLZCE",97,0) ; "RTN","VAFHLZCE",98,0) ; Notes: VAFZCE(VAFNUM) is initialized (KILLed) on input. Fields will not be split across nodes in VAFZCE() "RTN","VAFHLZCE",99,0) ; "RTN","VAFHLZCE",100,0) N VAFSEQ,VAFSPIL,VAFSPON,VAFSPOT,VAFLSEQ,VAFY "RTN","VAFHLZCE",101,0) K VAFZCE(VAFNUM) "RTN","VAFHLZCE",102,0) S VAFZCE(VAFNUM)="ZCE" "RTN","VAFHLZCE",103,0) S:'+$G(VAFMAXL) VAFMAXL=245 "RTN","VAFHLZCE",104,0) S VAFY=$NA(VAFZCE(VAFNUM)) "RTN","VAFHLZCE",105,0) S (VAFSPIL,VAFSPON)=0 "RTN","VAFHLZCE",106,0) S VAFLSEQ=+$O(VAFHLZCE(""),-1) "RTN","VAFHLZCE",107,0) F VAFSEQ=1:1:VAFLSEQ D "RTN","VAFHLZCE",108,0) .; Make sure maximum length won't be exceeded "RTN","VAFHLZCE",109,0) .I ($L(@VAFY)+$L($G(VAFHLZCE(VAFSEQ)))+1)>VAFMAXL D "RTN","VAFHLZCE",110,0) ..; Max length exceeded - start putting data on next node "RTN","VAFHLZCE",111,0) ..S VAFSPIL=VAFSPIL+1 "RTN","VAFHLZCE",112,0) ..S VAFSPON=VAFSEQ-1 "RTN","VAFHLZCE",113,0) ..S VAFY=$NA(VAFZCE(VAFNUM,VAFSPIL)) "RTN","VAFHLZCE",114,0) .; Add to string "RTN","VAFHLZCE",115,0) .S VAFSPOT=(VAFSEQ+1)-VAFSPON "RTN","VAFHLZCE",116,0) .S $P(@VAFY,VAFHLFS,VAFSPOT)=$G(VAFHLZCE(VAFSEQ)) "RTN","VAFHLZCE",117,0) Q "UP",2,2.0361,-1) 2^E "UP",2,2.0361,0) 2.0361 "UP",2,2.191,-1) 2^5 "UP",2,2.191,0) 2.191 "VER") 8.0^22.2 "^DD",2,2,.361,0) PRIMARY ELIGIBILITY CODE^*P8'Xa^DIC(8,^.36;1^S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 "^DD",2,2,.361,.1) "^DD",2,2,.361,1,0) ^.1^^-1 "^DD",2,2,.361,1,1,0) 2^AG^MUMPS "^DD",2,2,.361,1,1,1) S DFN=DA D INACT33^DGOTHEL(DFN),EN^DGMTR K DGREQF "^DD",2,2,.361,1,1,2) Q "^DD",2,2,.361,1,1,"%D",0) ^.101^4^4^3190731^^ "^DD",2,2,.361,1,1,"%D",1,0) This cross-reference has two functions: "^DD",2,2,.361,1,1,"%D",2,0) 1. It calls INACT33^DGOTHEL to record the change in Primary Eligibility "^DD",2,2,.361,1,1,"%D",3,0) in the OTH ELIGIBILITY PATIENT file (#33) "^DD",2,2,.361,1,1,"%D",4,0) 2. It calls EN^DGMTR to check Means Test Requirements "^DD",2,2,.361,1,1,"DT") 3190529 "^DD",2,2,.361,1,2,0) ^^TRIGGER^2.0361^.01 "^DD",2,2,.361,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) "^DD",2,2,.361,1,2,1.4) S DIH=$S($D(^DPT(DIV(0),"E",DIV(1),0)):^(0),1:""),DIV=X I $D(^(0)) S $P(^(0),U,1)=DIV,DIH=2.0361,DIG=.01 D ^DICR:$O(^DD(DIH,DIG,1,0))>0 "^DD",2,2,.361,1,2,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK "^DD",2,2,.361,1,2,2.2) X ^DD(2,.361,1,2,99.3) S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y "^DD",2,2,.361,1,2,3) This trigger stuffs the ELIGIBILITY CODE into the PATIENT'S ELIGIBILITIES multiple. "^DD",2,2,.361,1,2,89.2) S I(0,0)=$S($D(D0):D0,1:""),I(1,0)=$S($D(D1):D1,1:""),Y(2)=$S($D(^DPT(D0,.36)):^(.36),1:"") S X="`",Y(1)=X S X=$P(Y(2),U,1),X=X S Y=X,X=Y(1),X=X S X=X "^DD",2,2,.361,1,2,89.3) X ^DD(2,.361,1,2,89.2) S X=X_Y,X=X S X=X "^DD",2,2,.361,1,2,89.4) X ^DD(2,.361,1,2,89.3) K DIC S Y=-1,DIC="^DPT(D0,""E"",",DIC(0)="NMFL",DIC("P")="2.0361P",DIU(1)=$S($D(DA(1)):DA(1),1:0),DA(1)=D0 D ^DIC:D0>0 S (D,D1,DIV(1))=+Y,DA(1)=DIU(1) "^DD",2,2,.361,1,2,99.2) S I(0,0)=$S($D(D0):D0,1:""),I(1,0)=$S($D(D1):D1,1:""),Y(2)=DIV S X="`",Y(1)=X S X=$P(Y(2),U,1),X=X S Y=X,X=Y(1),X=X S X=X "^DD",2,2,.361,1,2,99.3) X ^DD(2,.361,1,2,99.2) S X=X_Y K DIC S Y=-1,DIC="^DPT(D0,""E"",",DIC(0)="NMF" D ^DIC:D0>0 S (D,D1,DIV(1))=+Y S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") "^DD",2,2,.361,1,2,"CREATE VALUE") INTERNAL(ELIGIBILITY CODE) "^DD",2,2,.361,1,2,"DELETE VALUE") @ "^DD",2,2,.361,1,2,"DIC") LOOKUP "^DD",2,2,.361,1,2,"DIK") DELETE "^DD",2,2,.361,1,2,"FIELD") "`"_INTERNAL(ELIGIBILITY CODE):#361:#.01 "^DD",2,2,.361,1,3,0) 2^AXR28^MUMPS "^DD",2,2,.361,1,3,1) Q "^DD",2,2,.361,1,3,2) I $S('$D(^DIC(8,+X,0)):0,$P(^(0),"^",1)["DOM":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),"^",1)'["DOM":1,1:0) S DGXRF=.361 D ^DGDDC Q "^DD",2,2,.361,1,3,"%D",0) ^^8^8^2920429^ "^DD",2,2,.361,1,3,"%D",1,0) When the eligibility code is changed, this cross-reference removes the "^DD",2,2,.361,1,3,"%D",2,0) data in the ELIGIBILITY STATUS field. This only occurs if neither the "^DD",2,2,.361,1,3,"%D",3,0) original eligibility code nor the new eligibility code (the one being "^DD",2,2,.361,1,3,"%D",4,0) entered) is DOM. PATIENT. If either is DOM. PATIENT, no update occurs. "^DD",2,2,.361,1,3,"%D",5,0) "^DD",2,2,.361,1,3,"%D",6,0) Since the DOM. PATIENT eligibility is being inactivated with MAS 5.2, "^DD",2,2,.361,1,3,"%D",7,0) the conditional on this cross-reference will be removed in a future "^DD",2,2,.361,1,3,"%D",8,0) version of MAS. "^DD",2,2,.361,1,3,"DT") 2920429 "^DD",2,2,.361,1,4,0) 2^AEL^MUMPS "^DD",2,2,.361,1,4,1) S ^DPT("AEL",DA,+X)="" D RESTORE^DGRP1152U(DA) "^DD",2,2,.361,1,4,2) K ^DPT("AEL",DA,+X) I X=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") D ARCHALL^DGRP1152U(DA) "^DD",2,2,.361,1,4,"%D",0) ^.101^9^9^3200928^^^^ "^DD",2,2,.361,1,4,"%D",1,0) When an eligibility is being set, the SET logic will place the "^DD",2,2,.361,1,4,"%D",2,0) eligibility in the "AEL" cross reference and then invoke logic for "^DD",2,2,.361,1,4,"%D",3,0) handling the edit of the COLLATERAL OF VET eligibility. "^DD",2,2,.361,1,4,"%D",4,0) "^DD",2,2,.361,1,4,"%D",5,0) When an eligibility is deleted, the KILL logic will remove the item from "^DD",2,2,.361,1,4,"%D",6,0) the "AEL" cross reference and then check if "COLLATERAL OF VET" "^DD",2,2,.361,1,4,"%D",7,0) eligibility is being removed. If so, code is called to archive all CCP "^DD",2,2,.361,1,4,"%D",8,0) entries in the COMMUNITY CARE PROGRAM sub-file (#2.191) of the PATIENT "^DD",2,2,.361,1,4,"%D",9,0) file (#2). The ARCHIVE (#.04) field of the CCP entry is set to 1. "^DD",2,2,.361,1,4,"DT") 3200924 "^DD",2,2,.361,1,5,0) 2^AENR361^MUMPS "^DD",2,2,.361,1,5,1) D AUTOUPD^DGENA2(DA) "^DD",2,2,.361,1,5,2) D AUTOUPD^DGENA2(DA) "^DD",2,2,.361,1,5,3) DO NOT DELETE "^DD",2,2,.361,1,5,"%D",0) ^.101^2^2^3190731^^^ "^DD",2,2,.361,1,5,"%D",1,0) This cross-reference is used to update the patient's current Patient Enrollment "^DD",2,2,.361,1,5,"%D",2,0) record. "^DD",2,2,.361,1,5,"DT") 2970715 "^DD",2,2,.361,3) Select from the available list the eligibility code which best defines this applicant's primary entitlement to care. For more detailed information, enter ??. "^DD",2,2,.361,12) Applicable code based on veteran or non-veteran status. "^DD",2,2,.361,12.1) S DFN=DA D ECD^DGLOCK1 "^DD",2,2,.361,20,0) ^.3LA^1^1 "^DD",2,2,.361,20,1,0) ECD "^DD",2,2,.361,21,0) ^.001^45^45^3201009^^^^ "^DD",2,2,.361,21,1,0) Select from the available listing the appropriate eligibility code for "^DD",2,2,.361,21,2,0) this applicant. For non-veteran applicants a wide variety of choices "^DD",2,2,.361,21,3,0) are available. For veteran applicants the choices are screened [in the "^DD",2,2,.361,21,4,0) following order] dependent on the responses to other prompts: "^DD",2,2,.361,21,5,0) "^DD",2,2,.361,21,6,0) 1. If the SERVICE CONNECTED prompt (field .301) is answered YES "^DD",2,2,.361,21,7,0) only the following two choices are available: "^DD",2,2,.361,21,8,0) "^DD",2,2,.361,21,9,0) a. If the SERVICE CONNECTED PERCENTAGE prompt (field .302) entered "^DD",2,2,.361,21,10,0) is 50% or greater 'SERVICE CONNECTED 50% TO 100%' can be "^DD",2,2,.361,21,11,0) selected. "^DD",2,2,.361,21,12,0) "^DD",2,2,.361,21,13,0) b. Otherwise, the percentage is assumed to be less than 50% and "^DD",2,2,.361,21,14,0) only 'SC, LESS THAN 50%' may be entered. "^DD",2,2,.361,21,15,0) "^DD",2,2,.361,21,16,0) 2. If the response to the WERE YOU A PRISONER OF WAR field (# .525) "^DD",2,2,.361,21,17,0) is YES and the veteran is not service connected, you must select "^DD",2,2,.361,21,18,0) PRISONER OF WAR as the eligibility code. "^DD",2,2,.361,21,19,0) "^DD",2,2,.361,21,20,0) 3. If the response to the CURRENT PH INDICATOR field (#.531) "^DD",2,2,.361,21,21,0) is YES and the veteran is not service connected and is not a Prisoner "^DD",2,2,.361,21,22,0) of War, you must select PURPLE HEART RECIPIENT as the eligibility code. "^DD",2,2,.361,21,23,0) "^DD",2,2,.361,21,24,0) 4. If the veteran is receiving VA benefits, but does not meet the "^DD",2,2,.361,21,25,0) criteria in items 1 and 2 above, then the following choices may "^DD",2,2,.361,21,26,0) be presented for selection: "^DD",2,2,.361,21,27,0) "^DD",2,2,.361,21,28,0) If RECEIVING A&A BENEFITS is answered YES, the eligibility code "^DD",2,2,.361,21,29,0) AID & ATTENDANCE may be selected. "^DD",2,2,.361,21,30,0) "^DD",2,2,.361,21,31,0) If the RECEIVING HOUSEBOUND BENEFITS is answered YES ,the eligibility "^DD",2,2,.361,21,32,0) code HOUSEBOUND may be selected. "^DD",2,2,.361,21,33,0) "^DD",2,2,.361,21,34,0) If the above two prompts were answered NO, but the RECEIVING A VA "^DD",2,2,.361,21,35,0) PENSION prompt was answered YES, only the NSC, VA PENSION prompt "^DD",2,2,.361,21,36,0) may be selected. "^DD",2,2,.361,21,37,0) "^DD",2,2,.361,21,38,0) 5. If none of the above pertain to this veteran, then the NSC eligibility "^DD",2,2,.361,21,39,0) will be available for selection. "^DD",2,2,.361,21,40,0) "^DD",2,2,.361,21,41,0) ** Dependent on the birthdate of the applicant, the following two "^DD",2,2,.361,21,42,0) eligibility codes may be displayed along with those shown in items "^DD",2,2,.361,21,43,0) 3 through 5 above: WORLD WAR I and MEXICAN BORDER WAR. These would "^DD",2,2,.361,21,44,0) display for veterans not meeting the criteria in items 1 and 2, but "^DD",2,2,.361,21,45,0) whose date of birth is prior to 1907. "^DD",2,2,.361,"AUDIT") y "^DD",2,2,.361,"DEL",1,0) S DFN=DA D EV^DGLOCK D:$D(X) COV^DGLOCK3 I '$D(X) "^DD",2,2,.361,"DT") 3201009 "^DD",2,2,361,0) PATIENT ELIGIBILITIES^2.0361IP^^E;0 "^DD",2,2,361,3) Choose from the available listing those eligibilities to which this patient might be entitled which are not his primary eligibility. "^DD",2,2,361,20,0) ^.3LA^1^1 "^DD",2,2,361,20,1,0) ECD "^DD",2,2,361,21,0) ^.001^3^3^3200824^^^^ "^DD",2,2,361,21,1,0) This multiple contains all eligibilities under which this patient can "^DD",2,2,361,21,2,0) receive care. This includes his primary eligibility and all other "^DD",2,2,361,21,3,0) eligibilities he may have. "^DD",2,2,1910,0) COMMUNITY CARE PROGRAM^2.191DA^^5;0 "^DD",2,2,1910,21,0) ^.001^27^27^3200831^^^^ "^DD",2,2,1910,21,1,0) Supports the registration of an applicant in the Community Care Program. "^DD",2,2,1910,21,2,0) "^DD",2,2,1910,21,3,0) TECHNICAL DESCRIPTION: "^DD",2,2,1910,21,4,0) The COMMUNITY CARE PROGRAM multiple consists of data reflective of the "^DD",2,2,1910,21,5,0) CCP related information when an Eligibility contains COLLATERAL OF VET. "^DD",2,2,1910,21,6,0) "^DD",2,2,1910,21,7,0) The functionality of these data items operate as follows: "^DD",2,2,1910,21,8,0) 1 - COMMUNITY CARE PROGRAM CODE is a required field entered by the user "^DD",2,2,1910,21,9,0) 2 - EFFECTIVE DATE is a required field entered by the user "^DD",2,2,1910,21,10,0) 3 - CCP LAST UPDATED DATE is created (as a Timestamp) via the system upon "^DD",2,2,1910,21,11,0) filing of the data through an ADD, EDIT or a REMOVE function "^DD",2,2,1910,21,12,0) 4 - END DATE is created via the system upon filing of data, under certain "^DD",2,2,1910,21,13,0) conditions: "^DD",2,2,1910,21,14,0) a) when an EDIT of the record is performed, the existing record is "^DD",2,2,1910,21,15,0) added with an END DATE and a new record is created "^DD",2,2,1910,21,16,0) b) when a REMOVE of a record is performed "^DD",2,2,1910,21,17,0) "^DD",2,2,1910,21,18,0) While all records are always retained, any records with an END DATE will "^DD",2,2,1910,21,19,0) not be displayed as only active records are viewable. "^DD",2,2,1910,21,20,0) "^DD",2,2,1910,21,21,0) When the COLLATERAL OF VET Eligibility is removed (via screen <7>), all "^DD",2,2,1910,21,22,0) the existing open CCP records will be added with an END DATE and closed "^DD",2,2,1910,21,23,0) out with the Archive flag set to 1. CCP records with this flag set will "^DD",2,2,1910,21,24,0) not be sent on the HL-7 ORU/ORF-Z07 message. "^DD",2,2,1910,21,25,0) "^DD",2,2,1910,21,26,0) If the COLLATERAL OF VET Eligibility is re-established, the CCPs need "^DD",2,2,1910,21,27,0) to be re-entered. "^DD",2,2.0361,0) PATIENT ELIGIBILITIES SUB-FIELD^^.04^3 "^DD",2,2.0361,0,"NM","PATIENT ELIGIBILITIES") "^DD",2,2.0361,.01,0) ELIGIBILITY^M*P8'X^DIC(8,^0;1^S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X "^DD",2,2.0361,.01,1,0) ^.1 "^DD",2,2.0361,.01,1,1,0) 2.0361^B "^DD",2,2.0361,.01,1,1,1) S ^DPT(DA(1),"E","B",$E(X,1,30),DA)="" "^DD",2,2.0361,.01,1,1,2) K ^DPT(DA(1),"E","B",$E(X,1,30),DA) "^DD",2,2.0361,.01,1,2,0) 2^AEL1^MUMPS "^DD",2,2.0361,.01,1,2,1) S ^DPT("AEL",DA(1),+X)="" "^DD",2,2.0361,.01,1,2,2) K ^DPT("AEL",DA(1),+X) I X=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") D ARCHALL^DGRP1152U(DA(1)) "^DD",2,2.0361,.01,1,2,"%D",0) ^^5^5^3201020^ "^DD",2,2.0361,.01,1,2,"%D",1,0) When an eligibility is deleted, the KILL logic will remove the item from "^DD",2,2.0361,.01,1,2,"%D",2,0) the "AEL" cross reference and then check if "COLLATERAL OF VET" "^DD",2,2.0361,.01,1,2,"%D",3,0) eligibility is being removed. If so, code is called to archive all CCP "^DD",2,2.0361,.01,1,2,"%D",4,0) entries in the COMMUNITY CARE PROGRAM sub-file (#2.191) of the PATIENT "^DD",2,2.0361,.01,1,2,"%D",5,0) file (#2). The ARCHIVE (#.04) field of the CCP entry is set to 1. "^DD",2,2.0361,.01,1,2,"DT") 3200831 "^DD",2,2.0361,.01,1,3,0) ^^TRIGGER^2.0361^.03 "^DD",2,2.0361,.01,1,3,1) D E31^VADPT62 "^DD",2,2.0361,.01,1,3,1.1) S X=DIV S X="" I $D(^DIC(8,DA,0)),$D(^DIC(8.2,+$P(^(0),U,10),"LONG")) X ^("LONG") "^DD",2,2.0361,.01,1,3,1.4) S DIH=$S($D(^DPT(DIV(0),"E",DIV(1),0)):^(0),1:""),DIV=X S $P(^(0),U,3)=DIV,DIH=2.0361,DIG=.03 D ^DICR:$N(^DD(DIH,DIG,1,0))>0 "^DD",2,2.0361,.01,1,3,2) D E32^VADPT62 "^DD",2,2.0361,.01,1,3,2.4) S DIH=$S($D(^DPT(DIV(0),"E",DIV(1),0)):^(0),1:""),DIV=X S $P(^(0),U,3)=DIV,DIH=2.0361,DIG=.03 D ^DICR:$N(^DD(DIH,DIG,1,0))>0 "^DD",2,2.0361,.01,1,3,"CREATE VALUE") S X="" I $D(^DIC(8,DA,0)),$D(^DIC(8.2,+$P(^(0),U,10),"LONG")) X ^("LONG") "^DD",2,2.0361,.01,1,3,"DELETE VALUE") @ "^DD",2,2.0361,.01,1,3,"FIELD") LONG ID "^DD",2,2.0361,.01,1,4,0) 2^AO^MUMPS "^DD",2,2.0361,.01,1,4,1) S DFN=DA(1) D EN^DGMTR K DGREQF "^DD",2,2.0361,.01,1,4,2) S DFN=DA(1) D EN^DGMTR K DGREQF "^DD",2,2.0361,.01,1,4,"%D",0) ^^2^2^2970923^^^^ "^DD",2,2.0361,.01,1,4,"%D",1,0) This cross-reference is used to determine whether or not a means test or "^DD",2,2.0361,.01,1,4,"%D",2,0) co-pay test is required. "^DD",2,2.0361,.01,1,4,"DT") 2970923 "^DD",2,2.0361,.01,1,5,0) 2^AENR01^MUMPS "^DD",2,2.0361,.01,1,5,1) D AUTOUPD^DGENA2(DA(1)) "^DD",2,2.0361,.01,1,5,2) D AUTOUPD^DGENA2(DA(1)) "^DD",2,2.0361,.01,1,5,3) DO NOT DELETE "^DD",2,2.0361,.01,1,5,"%D",0) ^^7^7^2970820^^^^ "^DD",2,2.0361,.01,1,5,"%D",1,0) This cross-reference is used to update the patient's current Patient Enrollment "^DD",2,2.0361,.01,1,5,"%D",2,0) record. "^DD",2,2.0361,.01,1,5,"%D",3,0) "^DD",2,2.0361,.01,1,5,"%D",4,0) When deleting an eligibility, at the point the kill logic of this x-ref "^DD",2,2.0361,.01,1,5,"%D",5,0) is executed the data still exists in the global. To determine whether an "^DD",2,2.0361,.01,1,5,"%D",6,0) eligibility still exists the "B" x-ref is checked - if not there, the "^DD",2,2.0361,.01,1,5,"%D",7,0) eligibility is ignored. "^DD",2,2.0361,.01,1,5,"DT") 2970715 "^DD",2,2.0361,.01,3) Select other eligibilities to which this patient may be entitled. "^DD",2,2.0361,.01,5,1,0) 2^.361^2 "^DD",2,2.0361,.01,12) Select other eligibilities for the patient. The primary may be selected but it must already exist. "^DD",2,2.0361,.01,12.1) S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" "^DD",2,2.0361,.01,21,0) ^.001^3^3^3200824^^^^ "^DD",2,2.0361,.01,21,1,0) Enter all eligibilities under which this patient may receive care. The "^DD",2,2.0361,.01,21,2,0) patients primary eligibility as well as all other eligibilities he is "^DD",2,2.0361,.01,21,3,0) entitled to is stored in this multiple. "^DD",2,2.0361,.01,23,0) ^.001^9^9^3200824^^^^ "^DD",2,2.0361,.01,23,1,0) Unlike previous versions of the PATIENT file, in this "^DD",2,2.0361,.01,23,2,0) version ALL the patient's eligibilities are stored in this "^DD",2,2.0361,.01,23,3,0) multiple. "^DD",2,2.0361,.01,23,4,0) "^DD",2,2.0361,.01,23,5,0) When the user enters/edits that patient's PRIMARY ELIGIBILITY CODE, that "^DD",2,2.0361,.01,23,6,0) code is automatically stored in the multiple as well as in "^DD",2,2.0361,.01,23,7,0) the PRIMARY ELIGIBILITY CODE field. "^DD",2,2.0361,.01,23,8,0) "^DD",2,2.0361,.01,23,9,0) This change was necessary to accomodate the VA/DOD sharing "^DD",2,2.0361,.01,"DEL",1,0) S DFN=DA(1) D EV^DGLOCK D:$D(X) COV^DGLOCK3(DA) I '$D(X)!(+$G(^DPT(DA(1),.36))=DA) W:$D(X) !?5,"Deleting primary eligibility is not allowed" "^DD",2,2.0361,.01,"DT") 3201006 "^DD",2,2.191,0) COMMUNITY CARE PROGRAM SUB-FIELD^^4^5 "^DD",2,2.191,0,"NM","COMMUNITY CARE PROGRAM") "^DD",2,2.191,.01,0) CCP LAST UPDATED DATE^RDa^^0;1^S %DT="ESTXR" D ^%DT S X=Y K:X<1 X "^DD",2,2.191,.01,1,0) ^.1^^0 "^DD",2,2.191,.01,3) Please enter date and time of change "^DD",2,2.191,.01,21,0) ^.001^2^2^3200717^^^ "^DD",2,2.191,.01,21,1,0) CCP LAST UPDATED DATE is a standard Fileman Date/Time indicating the last "^DD",2,2.191,.01,21,2,0) change in the Community Care Program for a person in the Patient file. "^DD",2,2.191,.01,23,0) ^^2^2^3200717^ "^DD",2,2.191,.01,23,1,0) This is a standard Fileman Date/Time. It is often displayed in medical "^DD",2,2.191,.01,23,2,0) record order. "^DD",2,2.191,.01,"AUDIT") y "^DD",2,2.191,.01,"DT") 3200824 "^DD",2,2.191,1,0) COMMUNITY CARE PROGRAM CODE^RSaX^A:ART/IVF;C:MARRIAGE/FAMILY COUNSELING;I:NEWBORN;T:VHA TRANSPLANT PROGRAM;^0;2^Q "^DD",2,2.191,1,3) Enter the CCP for this entry. "^DD",2,2.191,1,4) "^DD",2,2.191,1,21,0) ^.001^23^23^3200831^^ "^DD",2,2.191,1,21,1,0) This is the program under which a person is registered in the Community "^DD",2,2.191,1,21,2,0) Care Program. "^DD",2,2.191,1,21,3,0) "^DD",2,2.191,1,21,4,0) A - ART/IVF: Assisted Reproductive Technologies (ART) are all treatments "^DD",2,2.191,1,21,5,0) or procedures that include the in vitro handling of both human oocytes and "^DD",2,2.191,1,21,6,0) sperm, or of embryos, for the purpose of establishing a pregnancy. This "^DD",2,2.191,1,21,7,0) includes, but is not limited to, in vitro fertilization; embryo transfer; "^DD",2,2.191,1,21,8,0) gamete intrafallopian transfer; zygote intrafallopian transfer; tubal "^DD",2,2.191,1,21,9,0) embryo transfer; gamete and embryo cryopreservation for the eligible "^DD",2,2.191,1,21,10,0) Veteran and his/her legal spouse. "^DD",2,2.191,1,21,11,0) "^DD",2,2.191,1,21,12,0) C - MARRIAGE/FAMILY COUNSELING: Some members of the Veteran's immediate "^DD",2,2.191,1,21,13,0) family or the Veteran's legal guardian may be eligible to receive family "^DD",2,2.191,1,21,14,0) therapy and/or marriage counseling services. "^DD",2,2.191,1,21,15,0) "^DD",2,2.191,1,21,16,0) I - NEWBORN: Beneficiary Newborn includes newborn care and post-delivery "^DD",2,2.191,1,21,17,0) care for a newborn child for the date of birth plus seven calendar days "^DD",2,2.191,1,21,18,0) after the birth of the child when the birth mother is a woman Veteran "^DD",2,2.191,1,21,19,0) enrolled in VA health care and receiving maternity care furnished under "^DD",2,2.191,1,21,20,0) authorization from VA and the child is delivered at VA expense. "^DD",2,2.191,1,21,21,0) "^DD",2,2.191,1,21,22,0) T - VHA TRANSPLANT PROGRAM: Organ transplant services as a treatment for a "^DD",2,2.191,1,21,23,0) medical condition for eligible Veterans. "^DD",2,2.191,1,23,0) ^.001^1^1^3200831^^^^ "^DD",2,2.191,1,23,1,0) COMMUNITY CARE PROGRAM CODE is a standard Fileman set. "^DD",2,2.191,1,"AUDIT") y "^DD",2,2.191,1,"DT") 3200831 "^DD",2,2.191,2,0) EFFECTIVE DATE^RDaX^^0;3^S %DT="EX" D ^%DT S X=Y K:X<1!(DT0)!(WHEN0,($$IFLOCAL^MPIF001(DFN)=0) S IVMSEQ=IVMSEQ_",2",IVMCMOR="1,2,3" ;add SEQ 1 and 2 for PID "RTN","IVMPTRN8",65,0) ; "RTN","IVMPTRN8",66,0) ; send SSN indicating pseudo "RTN","IVMPTRN8",67,0) ; I $P(IVMPID_$G(IVMPID(1)),HLFS,20)["P" D PSEUDO^IVMPTRN1 ; strip 'P' from pseudo SSNs "RTN","IVMPTRN8",68,0) S IVMSEQ=IVMSEQ_",3,5,6,7,8,10,11,12,13,14,16,17,19,22,24" "RTN","IVMPTRN8",69,0) K IVMPID D BLDPID^VAFCQRY1(DFN,1,IVMSEQ,.IVMPID,.HL,.ERROR) "RTN","IVMPTRN8",70,0) K VAFPID D STRIP11 "RTN","IVMPTRN8",71,0) S SEGOCC="" F S SEGOCC=$O(VAFPID(SEGOCC)) Q:SEGOCC="" D "RTN","IVMPTRN8",72,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFPID(SEGOCC) "RTN","IVMPTRN8",73,0) ; "RTN","IVMPTRN8",74,0) ; **** create (PD1) Patient CMOR segment for MPI@HEC. "RTN","IVMPTRN8",75,0) S:'$D(HL("FS")) HL("FS")=HLFS "RTN","IVMPTRN8",76,0) S:'$D(HL("ECH")) HL("ECH")=HLECH "RTN","IVMPTRN8",77,0) S:'$D(HL("Q")) HL("Q")=HLQ "RTN","IVMPTRN8",78,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLPD1(DFN,IVMCMOR) "RTN","IVMPTRN8",79,0) ; "RTN","IVMPTRN8",80,0) ; create (ZPD) Patient Dependent Info. segment "RTN","IVMPTRN8",81,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN1^VAFHLZPD(DFN,"1,6,7,8,9,11,12,13,17,19,30,31,32,33,34,35,40"),IVMINS=$P(^(IVMCT),HLFS,12) "RTN","IVMPTRN8",82,0) I $D(VAFZPD(1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFZPD(1) K VAFZPD(1) "RTN","IVMPTRN8",83,0) ; "RTN","IVMPTRN8",84,0) ; create (ZTA) Temporary Address segment "RTN","IVMPTRN8",85,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,8,9",,.HL) "RTN","IVMPTRN8",86,0) ; KUM IVM*2.0*164 - Set Flag to determine if Temporary address is in Message "RTN","IVMPTRN8",87,0) I $TR($P(^TMP("HLS",$J,IVMCT),HLFS,6),"~""""^","")'="" S IVMZAVA("C")="" "RTN","IVMPTRN8",88,0) ; "RTN","IVMPTRN8",89,0) ; KUM - IVM*2.0*164 - Send CASS field value for all Address Types "RTN","IVMPTRN8",90,0) ; create (ZAV) Rated Disabilities segment(s) "RTN","IVMPTRN8",91,0) D EN^VAFHLZAV(DFN,"1,2,3,",HLQ,HLFS,.IVMZAV,.IVMZAVA) "RTN","IVMPTRN8",92,0) F IVMSUB=0:0 S IVMSUB=+$O(IVMZAV("HL7",IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",93,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZAV("HL7",+IVMSUB)) "RTN","IVMPTRN8",94,0) ; "RTN","IVMPTRN8",95,0) ; create (ZIE) Ineligible segment "RTN","IVMPTRN8",96,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIE(DFN,"1,2,3",1) "RTN","IVMPTRN8",97,0) ; "RTN","IVMPTRN8",98,0) ; create (ZEL) Eligibility segment(s) "RTN","IVMPTRN8",99,0) ; **** Add 5th piece to ZEL to correct consistency check "RTN","IVMPTRN8",100,0) ; added 41-44 for CLV IVM*2.0*161 "RTN","IVMPTRN8",101,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,41,42,43,44,45,46,47",2,.VAFZEL) "RTN","IVMPTRN8",102,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1)) ; Primary Eligibility "RTN","IVMPTRN8",103,0) I $D(VAFZEL(1,1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1,1)) "RTN","IVMPTRN8",104,0) ; - other entitled eligibilities "RTN","IVMPTRN8",105,0) F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",106,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(+IVMSUB)) "RTN","IVMPTRN8",107,0) ; "RTN","IVMPTRN8",108,0) ; create ZE2 segment (Optional) "RTN","IVMPTRN8",109,0) I $P($G(^DPT(DFN,.385)),U)'="" S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZE2(DFN,"1,2") "RTN","IVMPTRN8",110,0) ; "RTN","IVMPTRN8",111,0) ; create ZTE segments (optional) "RTN","IVMPTRN8",112,0) D EN^VAFHLZTE(DFN,"1,2,3,4,5,6,7,8,9,10,11,12,13",0,.VAFZTE) "RTN","IVMPTRN8",113,0) S IVMSUB=0 F S IVMSUB=$O(VAFZTE(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",114,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZTE(IVMSUB)) "RTN","IVMPTRN8",115,0) .S IVMSUB1=0 F S IVMSUB1=$O(VAFZTE(IVMSUB,IVMSUB1)) Q:'IVMSUB1 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZTE(IVMSUB,IVMSUB1)) "RTN","IVMPTRN8",116,0) .Q "RTN","IVMPTRN8",117,0) ; "RTN","IVMPTRN8",118,0) ; KUM - IVM*2.0*194 "RTN","IVMPTRN8",119,0) ; create ZCE segments (optional) "RTN","IVMPTRN8",120,0) D EN^VAFHLZCE(DFN,"1,2,3,4,5",,HLQ,HLFS,.VAFZCE) "RTN","IVMPTRN8",121,0) S IVMSUB=0 F S IVMSUB=$O(VAFZCE(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",122,0) .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZCE(IVMSUB)) "RTN","IVMPTRN8",123,0) .S IVMSUB1=0 F S IVMSUB1=$O(VAFZCE(IVMSUB,IVMSUB1)) Q:'IVMSUB1 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZCE(IVMSUB,IVMSUB1)) "RTN","IVMPTRN8",124,0) .Q "RTN","IVMPTRN8",125,0) ; "RTN","IVMPTRN8",126,0) ; create (ZEN) Enrollment segment "RTN","IVMPTRN8",127,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN) "RTN","IVMPTRN8",128,0) ; "RTN","IVMPTRN8",129,0) ; create (ZCD) Catastrophic Disability segment(s) "RTN","IVMPTRN8",130,0) D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS) "RTN","IVMPTRN8",131,0) F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",132,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB)) "RTN","IVMPTRN8",133,0) ; "RTN","IVMPTRN8",134,0) ; Optionally create (ZMH) Military History segments "RTN","IVMPTRN8",135,0) ; Pass "*" as parameter to send unlimited MSEs in Z07 (IVM*2*141) "RTN","IVMPTRN8",136,0) D ENTER^VAFHLZMH(DFN,"IVMZMH","*") "RTN","IVMPTRN8",137,0) ;DJS, Don't create ZMH segment if array entry is an FDD MSE; IVM*2.0*167 "RTN","IVMPTRN8",138,0) N ZMHED,MSESUB,DONEMSE "RTN","IVMPTRN8",139,0) S (ZMHSQ,SETID,DONEMSE)=0 "RTN","IVMPTRN8",140,0) I $D(IVMZMH) F S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ="" D "RTN","IVMPTRN8",141,0) . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")="" "RTN","IVMPTRN8",142,0) . ;If no Service Entry Date, QUIT "RTN","IVMPTRN8",143,0) . S ZMHED=$P(IVMZMH(ZMHSQ,0),U,5),ZMHED=$P(ZMHED,"~",1) Q:ZMHED="" "RTN","IVMPTRN8",144,0) . S ZMHED=$$HL7TFM^XLFDT(ZMHED) "RTN","IVMPTRN8",145,0) . ;Get MSE, if no more MSEs, process Conflict Information, if present "RTN","IVMPTRN8",146,0) . I 'DONEMSE S MSESUB="",MSESUB=$O(^DPT(DFN,.3216,"B",ZMHED,MSESUB)) S:MSESUB="" DONEMSE=1 "RTN","IVMPTRN8",147,0) . ;Do not create ZMH segment if FDD MSE "RTN","IVMPTRN8",148,0) . I 'DONEMSE,$P(^DPT(DFN,.3216,MSESUB,0),U,8)'="" Q ;Only check for FDD if MSE entry "RTN","IVMPTRN8",149,0) . S SETID=SETID+1,IVMCT=IVMCT+1 "RTN","IVMPTRN8",150,0) . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6) "RTN","IVMPTRN8",151,0) ; "RTN","IVMPTRN8",152,0) ; create (ZRD) Rated Disabilities segment(s) "RTN","IVMPTRN8",153,0) D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD") "RTN","IVMPTRN8",154,0) F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",155,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0)) "RTN","IVMPTRN8",156,0) ; "RTN","IVMPTRN8",157,0) ; create (ZCT) Emergency Contact segment "RTN","IVMPTRN8",158,0) ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1) "RTN","IVMPTRN8",159,0) K ZCTARY F ZCTTYP=1:1:5 D ;Create Optional ZCT Segments "RTN","IVMPTRN8",160,0) . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1) "RTN","IVMPTRN8",161,0) S (ZCTTYP,ZCTSQ)=0 "RTN","IVMPTRN8",162,0) I $D(ZCTARY) F S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP="" D "RTN","IVMPTRN8",163,0) . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ "RTN","IVMPTRN8",164,0) . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ "RTN","IVMPTRN8",165,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP) "RTN","IVMPTRN8",166,0) I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1) "RTN","IVMPTRN8",167,0) ; "RTN","IVMPTRN8",168,0) ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse "RTN","IVMPTRN8",169,0) ;*168 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7") "RTN","IVMPTRN8",170,0) ;*168 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2) "RTN","IVMPTRN8",171,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,9") ;re-enable imprecise date. "RTN","IVMPTRN8",172,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,9",2,2) "RTN","IVMPTRN8",173,0) ; "RTN","IVMPTRN8",174,0) ; create (ZGD) Guardian segment for (1) VA & (2) Civil "RTN","IVMPTRN8",175,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1) "RTN","IVMPTRN8",176,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2) "RTN","IVMPTRN8",177,0) ; "RTN","IVMPTRN8",178,0) ; Income Year requiring transmission from IVM Patient File (301.5) "RTN","IVMPTRN8",179,0) S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000)) "RTN","IVMPTRN8",180,0) N MTINFO S MTINFO=$$FUT^DGMTU(DFN) "RTN","IVMPTRN8",181,0) I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2) "RTN","IVMPTRN8",182,0) ;get the primary test for the income year "RTN","IVMPTRN8",183,0) S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN) "RTN","IVMPTRN8",184,0) ; "RTN","IVMPTRN8",185,0) ; The following function call returns: "RTN","IVMPTRN8",186,0) ; - Patient Relation IEN array in DGREL "RTN","IVMPTRN8",187,0) ; - Individual Annual Income IEN array in DGINC "RTN","IVMPTRN8",188,0) ; - Income Relation IEN array in DGINR "RTN","IVMPTRN8",189,0) D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN) "RTN","IVMPTRN8",190,0) ; "RTN","IVMPTRN8",191,0) S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1 "RTN","IVMPTRN8",192,0) ; create (ZIC) Income segment for veteran "RTN","IVMPTRN8",193,0) S IVMCT=IVMCT+1 "RTN","IVMPTRN8",194,0) ;IVM*2.0*115 -- Check for Means Test Version Indicator "RTN","IVMPTRN8",195,0) N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0) "RTN","IVMPTRN8",196,0) I MTVERS=0 D I 1 "RTN","IVMPTRN8",197,0) . S ^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",198,0) E D "RTN","IVMPTRN8",199,0) . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19") "RTN","IVMPTRN8",200,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3) "RTN","IVMPTRN8",201,0) ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct "RTN","IVMPTRN8",202,0) S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY) "RTN","IVMPTRN8",203,0) ; "RTN","IVMPTRN8",204,0) ; create (ZIR) Income Relation segment for veteran "RTN","IVMPTRN8",205,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("V")),"1,2,3,4,5,10,15") ;IVM * 2.0 *160 "RTN","IVMPTRN8",206,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1" "RTN","IVMPTRN8",207,0) ; "RTN","IVMPTRN8",208,0) ; create (ZDP) Patient Dependent Info. segment for spouse "RTN","IVMPTRN8",209,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("S")),"1,2,3,4,5,6,7,8,9,10,13,14") "RTN","IVMPTRN8",210,0) ;I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D "RTN","IVMPTRN8",211,0) ;. ; - pass non-existent SSNs as 0s "RTN","IVMPTRN8",212,0) ;. S $P(X,HLFS,6)="000000000" "RTN","IVMPTRN8",213,0) ; "RTN","IVMPTRN8",214,0) ; create (ZIC) Income segment for spouse "RTN","IVMPTRN8",215,0) S IVMCT=IVMCT+1 "RTN","IVMPTRN8",216,0) ;IVM*2.0*115 "RTN","IVMPTRN8",217,0) I MTVERS=0 D I 1 "RTN","IVMPTRN8",218,0) . S ^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",219,0) E D "RTN","IVMPTRN8",220,0) . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19") "RTN","IVMPTRN8",221,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3) "RTN","IVMPTRN8",222,0) ; "RTN","IVMPTRN8",223,0) ; create (ZIR) Income Relation segment for spouse "RTN","IVMPTRN8",224,0) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3") "RTN","IVMPTRN8",225,0) I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2) "RTN","IVMPTRN8",226,0) ; "RTN","IVMPTRN8",227,0) ; "RTN","IVMPTRN8",228,0) ; create ZDP, ZIC, and ZIR segments for all Means Test dependents "RTN","IVMPTRN8",229,0) F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",230,0) . ; "RTN","IVMPTRN8",231,0) . ; - create (ZDP) Dependent Info. segment for dependent child "RTN","IVMPTRN8",232,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",233,0) .; I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D "RTN","IVMPTRN8",234,0) .; . ; - pass non-existent SSNs as 0s "RTN","IVMPTRN8",235,0) .; . S $P(X,HLFS,6)="000000000" "RTN","IVMPTRN8",236,0) . ; "RTN","IVMPTRN8",237,0) . ; - create (ZIC) Income segment for dependent child "RTN","IVMPTRN8",238,0) . S IVMCT=IVMCT+1 "RTN","IVMPTRN8",239,0) . ;IVM*2.0*115 "RTN","IVMPTRN8",240,0) . I MTVERS=0 D I 1 "RTN","IVMPTRN8",241,0) . . S ^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",242,0) . E D "RTN","IVMPTRN8",243,0) . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19") "RTN","IVMPTRN8",244,0) . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3) "RTN","IVMPTRN8",245,0) . ; "RTN","IVMPTRN8",246,0) . ; - create (ZIR) Income Relation segment for dependent child "RTN","IVMPTRN8",247,0) . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("C",IVMSUB)),"1,2,3,4,6,7,8,9,14,15") ;IVM * 2.0 *160 "RTN","IVMPTRN8",248,0) . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2) "RTN","IVMPTRN8",249,0) . ; "RTN","IVMPTRN8",250,0) ; Send INACTIVE spouse/dependents. "RTN","IVMPTRN8",251,0) D GETINACD^DGMTU11(DFN,.DGREL) "RTN","IVMPTRN8",252,0) F I="S","C" D "RTN","IVMPTRN8",253,0) . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB D "RTN","IVMPTRN8",254,0) . . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGIREL(I,IVMSUB)),"1,2,3,4,5,6,7,9,10,11",,,$P(DGIREL(I,IVMSUB),U,3)) "RTN","IVMPTRN8",255,0) ; "RTN","IVMPTRN8",256,0) D GOTO^IVMPTRN9 "RTN","IVMPTRN8",257,0) Q "RTN","IVMPTRN8",258,0) ; "RTN","IVMPTRN8",259,0) STRIP11 N APID,ZPID,ASQ,ATYP,SSQ "RTN","IVMPTRN8",260,0) ;Extract PID segment "RTN","IVMPTRN8",261,0) S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1))) "RTN","IVMPTRN8",262,0) D BLDPID^IVMPREC6(.IVMPID,.APID) "RTN","IVMPTRN8",263,0) ; "RTN","IVMPTRN8",264,0) S CAFLG=0 "RTN","IVMPTRN8",265,0) I $D(APID(11)) D "RTN","IVMPTRN8",266,0) .I $O(APID(11,"")) D Q "RTN","IVMPTRN8",267,0) ..M ZPID(11)=APID(11) K APID(11) "RTN","IVMPTRN8",268,0) ..S (ASQ,SSQ)=0 F S ASQ=$O(ZPID(11,ASQ)) Q:ASQ="" D "RTN","IVMPTRN8",269,0) ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP="" "RTN","IVMPTRN8",270,0) ...;KUM - IVM*2.0*164 - Comment below 2 lines and Add line to enable all categories of Confidential Address "RTN","IVMPTRN8",271,0) ...;I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q "RTN","IVMPTRN8",272,0) ...;I ATYP="VACAE" S CAFLG=1 "RTN","IVMPTRN8",273,0) ...I (ATYP="VACAE")!(ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") S CAFLG=1 "RTN","IVMPTRN8",274,0) ...I (CAFLG=1) S IVMZAVA("CNF")="" "RTN","IVMPTRN8",275,0) ...I (ATYP="P") S IVMZAVA("P")="" "RTN","IVMPTRN8",276,0) ...I (ATYP="R") S IVMZAVA("R")="" "RTN","IVMPTRN8",277,0) ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ) "RTN","IVMPTRN8",278,0) .Q:$G(APID(11))="" "RTN","IVMPTRN8",279,0) .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP="" "RTN","IVMPTRN8",280,0) .;KUM - IVM*2.0*164 - Comment below 2 lines and Add line to enable all categories of Confidential Address "RTN","IVMPTRN8",281,0) .;I ATYP="VACAE" S CAFLG=1 Q "RTN","IVMPTRN8",282,0) .;I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11) "RTN","IVMPTRN8",283,0) .I (ATYP="VACAE")!(ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") S CAFLG=1 Q "RTN","IVMPTRN8",284,0) ; "RTN","IVMPTRN8",285,0) I 'CAFLG,$D(APID(13)) D "RTN","IVMPTRN8",286,0) .I $O(APID(13,"")) D Q "RTN","IVMPTRN8",287,0) ..S ASQ=0 F S ASQ=$O(APID(13,ASQ)) Q:ASQ="" D "RTN","IVMPTRN8",288,0) ...Q:$G(APID(13,ASQ))="" "RTN","IVMPTRN8",289,0) ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP="" "RTN","IVMPTRN8",290,0) ...I ATYP="VACPN" K APID(13,ASQ) Q "RTN","IVMPTRN8",291,0) .Q:$G(APID(13))="" "RTN","IVMPTRN8",292,0) .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP="" "RTN","IVMPTRN8",293,0) .I ATYP="VACPN" K APID(13) Q "RTN","IVMPTRN8",294,0) ; "RTN","IVMPTRN8",295,0) ;Rebuild PID "RTN","IVMPTRN8",296,0) D KVA^VADPT "RTN","IVMPTRN8",297,0) D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID) "RTN","IVMPTRN8",298,0) S VAFPID(0)=VAFPID "RTN","IVMPTRN8",299,0) Q "VER") 8.0^22.2 **END** **END**