KIDS Distribution saved on Jun 21, 2008@15:38:50 TMG 1*1.0*2c No Package File Link**KIDS**:TMG1*1.0*2^ **INSTALL NAME** TMG1*1.0*2 "BLD",5420,0) TMG1*1.0*2^^0^3080621^n "BLD",5420,1,0) ^^3^3^3080416^^ "BLD",5420,1,1,0) This KIDS build contains most of the TMG library as of 4/16/08. "BLD",5420,1,2,0) The primary purpose of the build is to install server-side code "BLD",5420,1,3,0) to support customizations of CPRS. "BLD",5420,4,0) ^9.64PA^8925.1^12 "BLD",5420,4,2005.2,0) 2005.2 "BLD",5420,4,2005.2,2,0) ^9.641^2005.2^1 "BLD",5420,4,2005.2,2,2005.2,0) NETWORK LOCATION (File-top level) "BLD",5420,4,2005.2,2,2005.2,1,0) ^9.6411^22700^3 "BLD",5420,4,2005.2,2,2005.2,1,22700,0) TMG PRIVATE PHYSICAL REFERENCE "BLD",5420,4,2005.2,2,2005.2,1,22701,0) TMG NODE DIVIDER SYMBOL "BLD",5420,4,2005.2,2,2005.2,1,22702,0) TMG DROPBOX PHYSICAL REFERENCE "BLD",5420,4,2005.2,222) y^y^p^^^^n^^n "BLD",5420,4,2005.2,224) "BLD",5420,4,8925.1,0) 8925.1 "BLD",5420,4,8925.1,222) n^n^f^^y^^y^a^n "BLD",5420,4,8925.1,224) I X["TMG" "BLD",5420,4,22706.1,0) 22706.1 "BLD",5420,4,22706.1,222) y^y^f^^^^n "BLD",5420,4,22706.2,0) 22706.2 "BLD",5420,4,22706.2,222) y^y^f^^^^n "BLD",5420,4,22706.3,0) 22706.3 "BLD",5420,4,22706.3,222) y^y^f^^^^n "BLD",5420,4,22706.4,0) 22706.4 "BLD",5420,4,22706.4,222) y^y^f^^^^n "BLD",5420,4,22706.5,0) 22706.5 "BLD",5420,4,22706.5,222) y^y^f^^^^n "BLD",5420,4,22706.6,0) 22706.6 "BLD",5420,4,22706.6,222) y^y^f^^^^n "BLD",5420,4,22706.7,0) 22706.7 "BLD",5420,4,22706.7,222) y^y^f^^^^n "BLD",5420,4,22706.8,0) 22706.8 "BLD",5420,4,22706.8,222) y^y^f^^^^n "BLD",5420,4,22706.82,0) 22706.82 "BLD",5420,4,22706.82,222) y^y^f^^^^n "BLD",5420,4,22706.9,0) 22706.9 "BLD",5420,4,22706.9,222) y^y^f^^^^n "BLD",5420,4,"APDD",2005.2,2005.2) "BLD",5420,4,"APDD",2005.2,2005.2,22700) "BLD",5420,4,"APDD",2005.2,2005.2,22701) "BLD",5420,4,"APDD",2005.2,2005.2,22702) "BLD",5420,4,"B",2005.2,2005.2) "BLD",5420,4,"B",8925.1,8925.1) "BLD",5420,4,"B",22706.1,22706.1) "BLD",5420,4,"B",22706.2,22706.2) "BLD",5420,4,"B",22706.3,22706.3) "BLD",5420,4,"B",22706.4,22706.4) "BLD",5420,4,"B",22706.5,22706.5) "BLD",5420,4,"B",22706.6,22706.6) "BLD",5420,4,"B",22706.7,22706.7) "BLD",5420,4,"B",22706.8,22706.8) "BLD",5420,4,"B",22706.82,22706.82) "BLD",5420,4,"B",22706.9,22706.9) "BLD",5420,"INIT") POSTINST^TMGKIDS "BLD",5420,"KRN",0) ^9.67PA^8989.52^19 "BLD",5420,"KRN",.4,0) .4 "BLD",5420,"KRN",.4,"NM",0) ^9.68A^7^1 "BLD",5420,"KRN",.4,"NM",7,0) TMG SENSITIVITY ACCESS FILE #38.1^38.1^0 "BLD",5420,"KRN",.4,"NM","B","TMG SENSITIVITY ACCESS FILE #38.1",7) "BLD",5420,"KRN",.401,0) .401 "BLD",5420,"KRN",.401,"NM",0) ^9.68A^^0 "BLD",5420,"KRN",.402,0) .402 "BLD",5420,"KRN",.403,0) .403 "BLD",5420,"KRN",.403,"NM",0) ^9.68A^5^5 "BLD",5420,"KRN",.403,"NM",1,0) TMG EDIT DRUG FILE #50^50^0 "BLD",5420,"KRN",.403,"NM",2,0) TMG EDIT PROGRESS NOTE FILE #8925^8925^0 "BLD",5420,"KRN",.403,"NM",3,0) TMG REGISTER FILE #2^2^0 "BLD",5420,"KRN",.403,"NM",4,0) TMG UPDATE SETTINGS FILE #22711^22711^0 "BLD",5420,"KRN",.403,"NM",5,0) TMG VIEW DRUG FILE #50.68^50.68^0 "BLD",5420,"KRN",.403,"NM","B","TMG EDIT DRUG FILE #50",1) "BLD",5420,"KRN",.403,"NM","B","TMG EDIT PROGRESS NOTE FILE #8925",2) "BLD",5420,"KRN",.403,"NM","B","TMG REGISTER FILE #2",3) "BLD",5420,"KRN",.403,"NM","B","TMG UPDATE SETTINGS FILE #22711",4) "BLD",5420,"KRN",.403,"NM","B","TMG VIEW DRUG FILE #50.68",5) "BLD",5420,"KRN",.5,0) .5 "BLD",5420,"KRN",.84,0) .84 "BLD",5420,"KRN",3.6,0) 3.6 "BLD",5420,"KRN",3.8,0) 3.8 "BLD",5420,"KRN",9.2,0) 9.2 "BLD",5420,"KRN",9.8,0) 9.8 "BLD",5420,"KRN",9.8,"NM",0) ^9.68A^112^96 "BLD",5420,"KRN",9.8,"NM",1,0) TMGABV^^0^B86362 "BLD",5420,"KRN",9.8,"NM",2,0) TMGBINF^^0^B6621 "BLD",5420,"KRN",9.8,"NM",3,0) TMGBROWS^^0^B6541 "BLD",5420,"KRN",9.8,"NM",4,0) TMGBUTIL^^0^B7315 "BLD",5420,"KRN",9.8,"NM",5,0) TMGCHR^^0^B22942466 "BLD",5420,"KRN",9.8,"NM",6,0) TMGDBAP2^^0^B3476 "BLD",5420,"KRN",9.8,"NM",7,0) TMGDBAPI^^0^B13065932 "BLD",5420,"KRN",9.8,"NM",8,0) TMGDEBUG^^0^B10834 "BLD",5420,"KRN",9.8,"NM",9,0) TMGDIA3^^0^B1371075 "BLD",5420,"KRN",9.8,"NM",10,0) TMGDIS^^0^B118560815 "BLD",5420,"KRN",9.8,"NM",11,0) TMGDIS0^^0^B39243874 "BLD",5420,"KRN",9.8,"NM",12,0) TMGDIS1^^0^B43572349 "BLD",5420,"KRN",9.8,"NM",13,0) TMGDIS2^^0^B21503917 "BLD",5420,"KRN",9.8,"NM",14,0) TMGDIS3^^0^B3848644 "BLD",5420,"KRN",9.8,"NM",15,0) TMGDRUG^^0^B5590 "BLD",5420,"KRN",9.8,"NM",17,0) TMGEDIT^^0^B4891 "BLD",5420,"KRN",9.8,"NM",20,0) TMGFMUT^^0^B7306 "BLD",5420,"KRN",9.8,"NM",21,0) TMGGDFN^^0^B101576 "BLD",5420,"KRN",9.8,"NM",22,0) TMGHTML1^^0^B6207 "BLD",5420,"KRN",9.8,"NM",23,0) TMGHUI1^^0^B205063 "BLD",5420,"KRN",9.8,"NM",24,0) TMGIDE^^0^B7091 "BLD",5420,"KRN",9.8,"NM",25,0) TMGIDE2^^0^B9859 "BLD",5420,"KRN",9.8,"NM",26,0) TMGINIT^^0^B65344038 "BLD",5420,"KRN",9.8,"NM",27,0) TMGIOUTL^^0^B7057 "BLD",5420,"KRN",9.8,"NM",28,0) TMGITR^^0^B9486 "BLD",5420,"KRN",9.8,"NM",29,0) TMGKERNL^^0^B5946 "BLD",5420,"KRN",9.8,"NM",30,0) TMGMATH^^0^B823927915 "BLD",5420,"KRN",9.8,"NM",31,0) TMGMEDIC^^0^B5161 "BLD",5420,"KRN",9.8,"NM",32,0) TMGMGRST^^0^B2452596 "BLD",5420,"KRN",9.8,"NM",33,0) TMGMISC^^0^B9343 "BLD",5420,"KRN",9.8,"NM",34,0) TMGMKU^^0^B159313 "BLD",5420,"KRN",9.8,"NM",35,0) TMGNDF0A^^0^B7420 "BLD",5420,"KRN",9.8,"NM",36,0) TMGNDF0B^^0^B6565 "BLD",5420,"KRN",9.8,"NM",37,0) TMGNDF0C^^0^B5013 "BLD",5420,"KRN",9.8,"NM",38,0) TMGNDF1A^^0^B9060 "BLD",5420,"KRN",9.8,"NM",39,0) TMGNDF1D^^0^B4671 "BLD",5420,"KRN",9.8,"NM",40,0) TMGNDF1E^^0^B4552 "BLD",5420,"KRN",9.8,"NM",41,0) TMGNDF1F^^0^B6001 "BLD",5420,"KRN",9.8,"NM",42,0) TMGNDF2A^^0^B7116 "BLD",5420,"KRN",9.8,"NM",43,0) TMGNDF2C^^0^B7038 "BLD",5420,"KRN",9.8,"NM",44,0) TMGNDF2E^^0^B10640 "BLD",5420,"KRN",9.8,"NM",45,0) TMGNDF2F^^0^B9113 "BLD",5420,"KRN",9.8,"NM",46,0) TMGNDF2G^^0^B7234 "BLD",5420,"KRN",9.8,"NM",47,0) TMGNDF2H^^0^B7403 "BLD",5420,"KRN",9.8,"NM",48,0) TMGNDF3A^^0^B12884 "BLD",5420,"KRN",9.8,"NM",49,0) TMGNDF3B^^0^B4797 "BLD",5420,"KRN",9.8,"NM",50,0) TMGNDF3C^^0^B5446 "BLD",5420,"KRN",9.8,"NM",51,0) TMGNDF3D^^0^B9007 "BLD",5420,"KRN",9.8,"NM",52,0) TMGNDF3E^^0^B4600 "BLD",5420,"KRN",9.8,"NM",53,0) TMGNDF4A^^0^B6524 "BLD",5420,"KRN",9.8,"NM",54,0) TMGNDF4B^^0^B7237 "BLD",5420,"KRN",9.8,"NM",55,0) TMGNDF4C^^0^B10766 "BLD",5420,"KRN",9.8,"NM",56,0) TMGNDF4D^^0^B7415 "BLD",5420,"KRN",9.8,"NM",57,0) TMGNDF4E^^0^B6240 "BLD",5420,"KRN",9.8,"NM",58,0) TMGNDF4F^^0^B7817 "BLD",5420,"KRN",9.8,"NM",59,0) TMGNDF4G^^0^B6258 "BLD",5420,"KRN",9.8,"NM",60,0) TMGNDFK1^^0^B4836 "BLD",5420,"KRN",9.8,"NM",61,0) TMGNDFUT^^0^B10639 "BLD",5420,"KRN",9.8,"NM",66,0) TMGPRNTR^^0^B9035 "BLD",5420,"KRN",9.8,"NM",67,0) TMGPRPN^^0^B76219 "BLD",5420,"KRN",9.8,"NM",68,0) TMGPSSDE^^0^B217084810 "BLD",5420,"KRN",9.8,"NM",69,0) TMGPSSDEE^^0^B217084810 "BLD",5420,"KRN",9.8,"NM",70,0) TMGPUTN0^^0^B125965713 "BLD",5420,"KRN",9.8,"NM",71,0) TMGQIO^^0^B78392 "BLD",5420,"KRN",9.8,"NM",72,0) TMGRPC1^^0^B6434 "BLD",5420,"KRN",9.8,"NM",73,0) TMGSELED^^0^B10024 "BLD",5420,"KRN",9.8,"NM",74,0) TMGSEQL1^^0^B44760 "BLD",5420,"KRN",9.8,"NM",75,0) TMGSEQL1B^^0^B44760 "BLD",5420,"KRN",9.8,"NM",76,0) TMGSEQL2^^0^B11873 "BLD",5420,"KRN",9.8,"NM",77,0) TMGSEQL3^^0^B11370 "BLD",5420,"KRN",9.8,"NM",78,0) TMGSHORT^^0^B7015 "BLD",5420,"KRN",9.8,"NM",79,0) TMGSTUTL^^0^B14081 "BLD",5420,"KRN",9.8,"NM",80,0) TMGTERM^^0^B16915 "BLD",5420,"KRN",9.8,"NM",82,0) TMGTIUOJ^^0^B11722 "BLD",5420,"KRN",9.8,"NM",83,0) TMGTRAN1^^0^B2382006 "BLD",5420,"KRN",9.8,"NM",84,0) TMGTREE^^0^B4518 "BLD",5420,"KRN",9.8,"NM",85,0) TMGTRNRP^^0^B1962236 "BLD",5420,"KRN",9.8,"NM",86,0) TMGUPLD^^0^B4904 "BLD",5420,"KRN",9.8,"NM",87,0) TMGUSRIF^^0^B7202 "BLD",5420,"KRN",9.8,"NM",88,0) TMGVPE^^0^B112139 "BLD",5420,"KRN",9.8,"NM",97,0) TMGXDLG^^0^B61415 "BLD",5420,"KRN",9.8,"NM",98,0) TMGXGF^^0^B43054173 "BLD",5420,"KRN",9.8,"NM",99,0) TMGXGS^^0^B32818030 "BLD",5420,"KRN",9.8,"NM",100,0) TMGXGSW^^0^B23984227 "BLD",5420,"KRN",9.8,"NM",101,0) TMGXINST^^0^B16647 "BLD",5420,"KRN",9.8,"NM",102,0) TMGXML1^^0^B7775128 "BLD",5420,"KRN",9.8,"NM",103,0) TMGXMLE2^^0^B27375 "BLD",5420,"KRN",9.8,"NM",104,0) TMGXMLEX^^0^B11237 "BLD",5420,"KRN",9.8,"NM",105,0) TMGXMLUI^^0^B8350 "BLD",5420,"KRN",9.8,"NM",106,0) TMGXPDR^^0^B20281682 "BLD",5420,"KRN",9.8,"NM",107,0) TMGXSBOX^^0^B6893011 "BLD",5420,"KRN",9.8,"NM",108,0) TMGXUP^^0^B98358 "BLD",5420,"KRN",9.8,"NM",109,0) TMGXUS2^^0^B55991259 "BLD",5420,"KRN",9.8,"NM",110,0) TMGIDE3^^0^B2891 "BLD",5420,"KRN",9.8,"NM",111,0) TMGIDE4^^0^B3347 "BLD",5420,"KRN",9.8,"NM",112,0) TMGKIDS^^0^B2764 "BLD",5420,"KRN",9.8,"NM","B","TMGABV",1) "BLD",5420,"KRN",9.8,"NM","B","TMGBINF",2) "BLD",5420,"KRN",9.8,"NM","B","TMGBROWS",3) "BLD",5420,"KRN",9.8,"NM","B","TMGBUTIL",4) "BLD",5420,"KRN",9.8,"NM","B","TMGCHR",5) "BLD",5420,"KRN",9.8,"NM","B","TMGDBAP2",6) "BLD",5420,"KRN",9.8,"NM","B","TMGDBAPI",7) "BLD",5420,"KRN",9.8,"NM","B","TMGDEBUG",8) "BLD",5420,"KRN",9.8,"NM","B","TMGDIA3",9) "BLD",5420,"KRN",9.8,"NM","B","TMGDIS",10) "BLD",5420,"KRN",9.8,"NM","B","TMGDIS0",11) "BLD",5420,"KRN",9.8,"NM","B","TMGDIS1",12) "BLD",5420,"KRN",9.8,"NM","B","TMGDIS2",13) "BLD",5420,"KRN",9.8,"NM","B","TMGDIS3",14) "BLD",5420,"KRN",9.8,"NM","B","TMGDRUG",15) "BLD",5420,"KRN",9.8,"NM","B","TMGEDIT",17) "BLD",5420,"KRN",9.8,"NM","B","TMGFMUT",20) "BLD",5420,"KRN",9.8,"NM","B","TMGGDFN",21) "BLD",5420,"KRN",9.8,"NM","B","TMGHTML1",22) "BLD",5420,"KRN",9.8,"NM","B","TMGHUI1",23) "BLD",5420,"KRN",9.8,"NM","B","TMGIDE",24) "BLD",5420,"KRN",9.8,"NM","B","TMGIDE2",25) "BLD",5420,"KRN",9.8,"NM","B","TMGIDE3",110) "BLD",5420,"KRN",9.8,"NM","B","TMGIDE4",111) "BLD",5420,"KRN",9.8,"NM","B","TMGINIT",26) "BLD",5420,"KRN",9.8,"NM","B","TMGIOUTL",27) "BLD",5420,"KRN",9.8,"NM","B","TMGITR",28) "BLD",5420,"KRN",9.8,"NM","B","TMGKERNL",29) "BLD",5420,"KRN",9.8,"NM","B","TMGKIDS",112) "BLD",5420,"KRN",9.8,"NM","B","TMGMATH",30) "BLD",5420,"KRN",9.8,"NM","B","TMGMEDIC",31) "BLD",5420,"KRN",9.8,"NM","B","TMGMGRST",32) "BLD",5420,"KRN",9.8,"NM","B","TMGMISC",33) "BLD",5420,"KRN",9.8,"NM","B","TMGMKU",34) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF0A",35) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF0B",36) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF0C",37) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF1A",38) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF1D",39) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF1E",40) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF1F",41) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF2A",42) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF2C",43) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF2E",44) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF2F",45) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF2G",46) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF2H",47) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF3A",48) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF3B",49) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF3C",50) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF3D",51) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF3E",52) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4A",53) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4B",54) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4C",55) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4D",56) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4E",57) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4F",58) "BLD",5420,"KRN",9.8,"NM","B","TMGNDF4G",59) "BLD",5420,"KRN",9.8,"NM","B","TMGNDFK1",60) "BLD",5420,"KRN",9.8,"NM","B","TMGNDFUT",61) "BLD",5420,"KRN",9.8,"NM","B","TMGPRNTR",66) "BLD",5420,"KRN",9.8,"NM","B","TMGPRPN",67) "BLD",5420,"KRN",9.8,"NM","B","TMGPSSDE",68) "BLD",5420,"KRN",9.8,"NM","B","TMGPSSDEE",69) "BLD",5420,"KRN",9.8,"NM","B","TMGPUTN0",70) "BLD",5420,"KRN",9.8,"NM","B","TMGQIO",71) "BLD",5420,"KRN",9.8,"NM","B","TMGRPC1",72) "BLD",5420,"KRN",9.8,"NM","B","TMGSELED",73) "BLD",5420,"KRN",9.8,"NM","B","TMGSEQL1",74) "BLD",5420,"KRN",9.8,"NM","B","TMGSEQL1B",75) "BLD",5420,"KRN",9.8,"NM","B","TMGSEQL2",76) "BLD",5420,"KRN",9.8,"NM","B","TMGSEQL3",77) "BLD",5420,"KRN",9.8,"NM","B","TMGSHORT",78) "BLD",5420,"KRN",9.8,"NM","B","TMGSTUTL",79) "BLD",5420,"KRN",9.8,"NM","B","TMGTERM",80) "BLD",5420,"KRN",9.8,"NM","B","TMGTIUOJ",82) "BLD",5420,"KRN",9.8,"NM","B","TMGTRAN1",83) "BLD",5420,"KRN",9.8,"NM","B","TMGTREE",84) "BLD",5420,"KRN",9.8,"NM","B","TMGTRNRP",85) "BLD",5420,"KRN",9.8,"NM","B","TMGUPLD",86) "BLD",5420,"KRN",9.8,"NM","B","TMGUSRIF",87) "BLD",5420,"KRN",9.8,"NM","B","TMGVPE",88) "BLD",5420,"KRN",9.8,"NM","B","TMGXDLG",97) "BLD",5420,"KRN",9.8,"NM","B","TMGXGF",98) "BLD",5420,"KRN",9.8,"NM","B","TMGXGS",99) "BLD",5420,"KRN",9.8,"NM","B","TMGXGSW",100) "BLD",5420,"KRN",9.8,"NM","B","TMGXINST",101) "BLD",5420,"KRN",9.8,"NM","B","TMGXML1",102) "BLD",5420,"KRN",9.8,"NM","B","TMGXMLE2",103) "BLD",5420,"KRN",9.8,"NM","B","TMGXMLEX",104) "BLD",5420,"KRN",9.8,"NM","B","TMGXMLUI",105) "BLD",5420,"KRN",9.8,"NM","B","TMGXPDR",106) "BLD",5420,"KRN",9.8,"NM","B","TMGXSBOX",107) "BLD",5420,"KRN",9.8,"NM","B","TMGXUP",108) "BLD",5420,"KRN",9.8,"NM","B","TMGXUS2",109) "BLD",5420,"KRN",19,0) 19 "BLD",5420,"KRN",19,"NM",0) ^9.68A^55^52 "BLD",5420,"KRN",19,"NM",1,0) TMG ADAM^^0 "BLD",5420,"KRN",19,"NM",2,0) TMG ADD PATIENT^^0 "BLD",5420,"KRN",19,"NM",3,0) TMG ASK SHOW ARRAY NODES^^0 "BLD",5420,"KRN",19,"NM",4,0) TMG AUTHOR TRANS COST ANY^^0 "BLD",5420,"KRN",19,"NM",5,0) TMG AUTHOR TRANS COST CURRENT^^0 "BLD",5420,"KRN",19,"NM",7,0) TMG DEBUGGER^^0 "BLD",5420,"KRN",19,"NM",8,0) TMG DOC MENU^^0 "BLD",5420,"KRN",19,"NM",10,0) TMG EDIT PATIENT^^0 "BLD",5420,"KRN",19,"NM",11,0) TMG EDIT PROGRESS NOTE^^0 "BLD",5420,"KRN",19,"NM",12,0) TMG EDIT/ADD PATIENT^^0 "BLD",5420,"KRN",19,"NM",13,0) TMG ERROR TRAP CHECK^^0 "BLD",5420,"KRN",19,"NM",14,0) TMG MAIN MENU TRANSCRIPTION^^0 "BLD",5420,"KRN",19,"NM",15,0) TMG MEDIC CONVERTER^^0 "BLD",5420,"KRN",19,"NM",16,0) TMG MGR MENU^^0 "BLD",5420,"KRN",19,"NM",17,0) TMG NURSE MENU^^0 "BLD",5420,"KRN",19,"NM",18,0) TMG OTHER 1^^0 "BLD",5420,"KRN",19,"NM",19,0) TMG PASSWORDS UNMASK^^0 "BLD",5420,"KRN",19,"NM",20,0) TMG PHARM EDIT VA PRODUCT^^0 "BLD",5420,"KRN",19,"NM",21,0) TMG PHARMACY^^0 "BLD",5420,"KRN",19,"NM",22,0) TMG PRINT CONTIGIOUSLY^^0 "BLD",5420,"KRN",19,"NM",23,0) TMG REC BROWSE^^0 "BLD",5420,"KRN",19,"NM",24,0) TMG REC INQUIRE^^0 "BLD",5420,"KRN",19,"NM",25,0) TMG REDIRECT POINTERS^^0 "BLD",5420,"KRN",19,"NM",26,0) TMG REFILE UPLOAD^^0 "BLD",5420,"KRN",19,"NM",27,0) TMG REGISTER^^0 "BLD",5420,"KRN",19,"NM",28,0) TMG RELEASE TRANS ANY USER^^0 "BLD",5420,"KRN",19,"NM",29,0) TMG RELEASE TRANS CURRENT USER^^0 "BLD",5420,"KRN",19,"NM",30,0) TMG REPRINT TEMPLATE^^0 "BLD",5420,"KRN",19,"NM",31,0) TMG RPC CONTEXT SCANNER^^0 "BLD",5420,"KRN",19,"NM",32,0) TMG SELECT EDIT RECORDS^^0 "BLD",5420,"KRN",19,"NM",33,0) TMG SEQUEL CLEAR IMPORT ERRORS^^0 "BLD",5420,"KRN",19,"NM",34,0) TMG SEQUEL DATA IMPORT^^0 "BLD",5420,"KRN",19,"NM",35,0) TMG SEQUEL DATA IMPORT CUSTOM^^0 "BLD",5420,"KRN",19,"NM",36,0) TMG SEQUEL IMPORT DATES^^0 "BLD",5420,"KRN",19,"NM",37,0) TMG SEQUEL IMPORT MENU^^0 "BLD",5420,"KRN",19,"NM",38,0) TMG SEQUEL IMPORT SETTINGS^^0 "BLD",5420,"KRN",19,"NM",39,0) TMG SEQUEL RPT DOB ERROR^^0 "BLD",5420,"KRN",19,"NM",40,0) TMG SEQUEL RPT SSNUM CONFLICTS^^0 "BLD",5420,"KRN",19,"NM",41,0) TMG SET PATIENT DEMOGRAPHICS^^0 "BLD",5420,"KRN",19,"NM",43,0) TMG SHOW POINTERS IN^^0 "BLD",5420,"KRN",19,"NM",44,0) TMG SHOW SENSITIVITY ACCESS^^0 "BLD",5420,"KRN",19,"NM",45,0) TMG SHOW XTER^^0 "BLD",5420,"KRN",19,"NM",46,0) TMG TEXT MENU^^0 "BLD",5420,"KRN",19,"NM",47,0) TMG TRANS REPRINT BATCH^^0 "BLD",5420,"KRN",19,"NM",48,0) TMG TRANS REPRINT TEMPLATE^^0 "BLD",5420,"KRN",19,"NM",49,0) TMG TRANS SHOW UNSIGNED^^0 "BLD",5420,"KRN",19,"NM",50,0) TMG TRANSCRIPTION REPORT^^0 "BLD",5420,"KRN",19,"NM",51,0) TMG UPLOAD BATCH DOCUMENTS^^0 "BLD",5420,"KRN",19,"NM",52,0) TMG VPE MENU^^0 "BLD",5420,"KRN",19,"NM",53,0) TMG WEBSITE EXPORT^^0 "BLD",5420,"KRN",19,"NM",54,0) TMG XML EXPORTER^^0 "BLD",5420,"KRN",19,"NM",55,0) TMG XUINDEX2^^0 "BLD",5420,"KRN",19,"NM","B","TMG ADAM",1) "BLD",5420,"KRN",19,"NM","B","TMG ADD PATIENT",2) "BLD",5420,"KRN",19,"NM","B","TMG ASK SHOW ARRAY NODES",3) "BLD",5420,"KRN",19,"NM","B","TMG AUTHOR TRANS COST ANY",4) "BLD",5420,"KRN",19,"NM","B","TMG AUTHOR TRANS COST CURRENT",5) "BLD",5420,"KRN",19,"NM","B","TMG DEBUGGER",7) "BLD",5420,"KRN",19,"NM","B","TMG DOC MENU",8) "BLD",5420,"KRN",19,"NM","B","TMG EDIT PATIENT",10) "BLD",5420,"KRN",19,"NM","B","TMG EDIT PROGRESS NOTE",11) "BLD",5420,"KRN",19,"NM","B","TMG EDIT/ADD PATIENT",12) "BLD",5420,"KRN",19,"NM","B","TMG ERROR TRAP CHECK",13) "BLD",5420,"KRN",19,"NM","B","TMG MAIN MENU TRANSCRIPTION",14) "BLD",5420,"KRN",19,"NM","B","TMG MEDIC CONVERTER",15) "BLD",5420,"KRN",19,"NM","B","TMG MGR MENU",16) "BLD",5420,"KRN",19,"NM","B","TMG NURSE MENU",17) "BLD",5420,"KRN",19,"NM","B","TMG OTHER 1",18) "BLD",5420,"KRN",19,"NM","B","TMG PASSWORDS UNMASK",19) "BLD",5420,"KRN",19,"NM","B","TMG PHARM EDIT VA PRODUCT",20) "BLD",5420,"KRN",19,"NM","B","TMG PHARMACY",21) "BLD",5420,"KRN",19,"NM","B","TMG PRINT CONTIGIOUSLY",22) "BLD",5420,"KRN",19,"NM","B","TMG REC BROWSE",23) "BLD",5420,"KRN",19,"NM","B","TMG REC INQUIRE",24) "BLD",5420,"KRN",19,"NM","B","TMG REDIRECT POINTERS",25) "BLD",5420,"KRN",19,"NM","B","TMG REFILE UPLOAD",26) "BLD",5420,"KRN",19,"NM","B","TMG REGISTER",27) "BLD",5420,"KRN",19,"NM","B","TMG RELEASE TRANS ANY USER",28) "BLD",5420,"KRN",19,"NM","B","TMG RELEASE TRANS CURRENT USER",29) "BLD",5420,"KRN",19,"NM","B","TMG REPRINT TEMPLATE",30) "BLD",5420,"KRN",19,"NM","B","TMG RPC CONTEXT SCANNER",31) "BLD",5420,"KRN",19,"NM","B","TMG SELECT EDIT RECORDS",32) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL CLEAR IMPORT ERRORS",33) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL DATA IMPORT",34) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL DATA IMPORT CUSTOM",35) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL IMPORT DATES",36) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL IMPORT MENU",37) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL IMPORT SETTINGS",38) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL RPT DOB ERROR",39) "BLD",5420,"KRN",19,"NM","B","TMG SEQUEL RPT SSNUM CONFLICTS",40) "BLD",5420,"KRN",19,"NM","B","TMG SET PATIENT DEMOGRAPHICS",41) "BLD",5420,"KRN",19,"NM","B","TMG SHOW POINTERS IN",43) "BLD",5420,"KRN",19,"NM","B","TMG SHOW SENSITIVITY ACCESS",44) "BLD",5420,"KRN",19,"NM","B","TMG SHOW XTER",45) "BLD",5420,"KRN",19,"NM","B","TMG TEXT MENU",46) "BLD",5420,"KRN",19,"NM","B","TMG TRANS REPRINT BATCH",47) "BLD",5420,"KRN",19,"NM","B","TMG TRANS REPRINT TEMPLATE",48) "BLD",5420,"KRN",19,"NM","B","TMG TRANS SHOW UNSIGNED",49) "BLD",5420,"KRN",19,"NM","B","TMG TRANSCRIPTION REPORT",50) "BLD",5420,"KRN",19,"NM","B","TMG UPLOAD BATCH DOCUMENTS",51) "BLD",5420,"KRN",19,"NM","B","TMG VPE MENU",52) "BLD",5420,"KRN",19,"NM","B","TMG WEBSITE EXPORT",53) "BLD",5420,"KRN",19,"NM","B","TMG XML EXPORTER",54) "BLD",5420,"KRN",19,"NM","B","TMG XUINDEX2",55) "BLD",5420,"KRN",19.1,0) 19.1 "BLD",5420,"KRN",101,0) 101 "BLD",5420,"KRN",409.61,0) 409.61 "BLD",5420,"KRN",771,0) 771 "BLD",5420,"KRN",870,0) 870 "BLD",5420,"KRN",8989.51,0) 8989.51 "BLD",5420,"KRN",8989.52,0) 8989.52 "BLD",5420,"KRN",8994,0) 8994 "BLD",5420,"KRN",8994,"NM",0) ^9.68A^14^14 "BLD",5420,"KRN",8994,"NM",1,0) TMG ADD PATIENT^^0 "BLD",5420,"KRN",8994,"NM",2,0) TMG AUTOSIGN TIU DOCUMENT^^0 "BLD",5420,"KRN",8994,"NM",3,0) TMG BARCODE DECODE^^0 "BLD",5420,"KRN",8994,"NM",4,0) TMG BARCODE ENCODE^^0 "BLD",5420,"KRN",8994,"NM",5,0) TMG DOWNLOAD FILE^^0 "BLD",5420,"KRN",8994,"NM",6,0) TMG DOWNLOAD FILE DROPBOX^^0 "BLD",5420,"KRN",8994,"NM",7,0) TMG GET BLANK TIU DOCUMENT^^0 "BLD",5420,"KRN",8994,"NM",8,0) TMG GET DFN^^0 "BLD",5420,"KRN",8994,"NM",9,0) TMG GET IMAGE LONG DESCRIPTION^^0 "BLD",5420,"KRN",8994,"NM",10,0) TMG GET PATIENT DEMOGRAPHICS^^0 "BLD",5420,"KRN",8994,"NM",11,0) TMG SET PATIENT DEMOGRAPHICS^^0 "BLD",5420,"KRN",8994,"NM",12,0) TMG UPLOAD FILE^^0 "BLD",5420,"KRN",8994,"NM",13,0) TMG UPLOAD FILE DROPBOX^^0 "BLD",5420,"KRN",8994,"NM",14,0) TMG CPRS GET URL LIST^^0 "BLD",5420,"KRN",8994,"NM","B","TMG ADD PATIENT",1) "BLD",5420,"KRN",8994,"NM","B","TMG AUTOSIGN TIU DOCUMENT",2) "BLD",5420,"KRN",8994,"NM","B","TMG BARCODE DECODE",3) "BLD",5420,"KRN",8994,"NM","B","TMG BARCODE ENCODE",4) "BLD",5420,"KRN",8994,"NM","B","TMG CPRS GET URL LIST",14) "BLD",5420,"KRN",8994,"NM","B","TMG DOWNLOAD FILE",5) "BLD",5420,"KRN",8994,"NM","B","TMG DOWNLOAD FILE DROPBOX",6) "BLD",5420,"KRN",8994,"NM","B","TMG GET BLANK TIU DOCUMENT",7) "BLD",5420,"KRN",8994,"NM","B","TMG GET DFN",8) "BLD",5420,"KRN",8994,"NM","B","TMG GET IMAGE LONG DESCRIPTION",9) "BLD",5420,"KRN",8994,"NM","B","TMG GET PATIENT DEMOGRAPHICS",10) "BLD",5420,"KRN",8994,"NM","B","TMG SET PATIENT DEMOGRAPHICS",11) "BLD",5420,"KRN",8994,"NM","B","TMG UPLOAD FILE",12) "BLD",5420,"KRN",8994,"NM","B","TMG UPLOAD FILE DROPBOX",13) "BLD",5420,"KRN","B",.4,.4) "BLD",5420,"KRN","B",.401,.401) "BLD",5420,"KRN","B",.402,.402) "BLD",5420,"KRN","B",.403,.403) "BLD",5420,"KRN","B",.5,.5) "BLD",5420,"KRN","B",.84,.84) "BLD",5420,"KRN","B",3.6,3.6) "BLD",5420,"KRN","B",3.8,3.8) "BLD",5420,"KRN","B",9.2,9.2) "BLD",5420,"KRN","B",9.8,9.8) "BLD",5420,"KRN","B",19,19) "BLD",5420,"KRN","B",19.1,19.1) "BLD",5420,"KRN","B",101,101) "BLD",5420,"KRN","B",409.61,409.61) "BLD",5420,"KRN","B",771,771) "BLD",5420,"KRN","B",870,870) "BLD",5420,"KRN","B",8989.51,8989.51) "BLD",5420,"KRN","B",8989.52,8989.52) "BLD",5420,"KRN","B",8994,8994) "BLD",5420,"QUES",0) ^9.62^^ "BLD",5420,"REQB",0) ^9.611^^ "FIA",2005.2) NETWORK LOCATION "FIA",2005.2,0) ^MAG(2005.2, "FIA",2005.2,0,0) 2005.2I "FIA",2005.2,0,1) y^y^p^^^^n^^n "FIA",2005.2,0,10) "FIA",2005.2,0,11) "FIA",2005.2,0,"RLRO") "FIA",2005.2,2005.2) 1 "FIA",2005.2,2005.2,22700) "FIA",2005.2,2005.2,22701) "FIA",2005.2,2005.2,22702) "FIA",8925.1) TIU DOCUMENT DEFINITION "FIA",8925.1,0) ^TIU(8925.1, "FIA",8925.1,0,0) 8925.1I "FIA",8925.1,0,1) n^n^f^^y^^y^a^n "FIA",8925.1,0,10) "FIA",8925.1,0,11) I X["TMG" "FIA",8925.1,0,"RLRO") "FIA",8925.1,8925.1) 0 "FIA",8925.1,8925.11) 0 "FIA",8925.1,8925.111) 0 "FIA",8925.1,8925.112) 0 "FIA",8925.1,8925.113) 0 "FIA",8925.1,8925.114) 0 "FIA",8925.1,8925.12) 0 "FIA",8925.1,8925.13) 0 "FIA",8925.1,8925.14) 0 "FIA",22706.1) TMG FDA APPLICATION "FIA",22706.1,0) ^TMG(22706.1, "FIA",22706.1,0,0) 22706.1P "FIA",22706.1,0,1) y^y^f^^^^n "FIA",22706.1,0,10) "FIA",22706.1,0,11) "FIA",22706.1,0,"RLRO") "FIA",22706.1,22706.1) 0 "FIA",22706.2) TMG FDA DOSAGE FORM "FIA",22706.2,0) ^TMG(22706.2, "FIA",22706.2,0,0) 22706.2P "FIA",22706.2,0,1) y^y^f^^^^n "FIA",22706.2,0,10) "FIA",22706.2,0,11) "FIA",22706.2,0,"RLRO") "FIA",22706.2,22706.2) 0 "FIA",22706.3) TMG FDA FIRMS "FIA",22706.3,0) ^TMG(22706.3, "FIA",22706.3,0,0) 22706.3 "FIA",22706.3,0,1) y^y^f^^^^n "FIA",22706.3,0,10) "FIA",22706.3,0,11) "FIA",22706.3,0,"RLRO") "FIA",22706.3,22706.3) 0 "FIA",22706.4) TMG FDA FORMULATION "FIA",22706.4,0) ^TMG(22706.4, "FIA",22706.4,0,0) 22706.4P "FIA",22706.4,0,1) y^y^f^^^^n "FIA",22706.4,0,10) "FIA",22706.4,0,11) "FIA",22706.4,0,"RLRO") "FIA",22706.4,22706.4) 0 "FIA",22706.5) TMG FDA LISTING "FIA",22706.5,0) ^TMG(22706.5, "FIA",22706.5,0,0) 22706.5 "FIA",22706.5,0,1) y^y^f^^^^n "FIA",22706.5,0,10) "FIA",22706.5,0,11) "FIA",22706.5,0,"RLRO") "FIA",22706.5,22706.5) 0 "FIA",22706.6) TMG FDA PACKAGES "FIA",22706.6,0) ^TMG(22706.6, "FIA",22706.6,0,0) 22706.6P "FIA",22706.6,0,1) y^y^f^^^^n "FIA",22706.6,0,10) "FIA",22706.6,0,11) "FIA",22706.6,0,"RLRO") "FIA",22706.6,22706.6) 0 "FIA",22706.7) TMG FDA ROUTES "FIA",22706.7,0) ^TMG(22706.7, "FIA",22706.7,0,0) 22706.7P "FIA",22706.7,0,1) y^y^f^^^^n "FIA",22706.7,0,10) "FIA",22706.7,0,11) "FIA",22706.7,0,"RLRO") "FIA",22706.7,22706.7) 0 "FIA",22706.8) TMG FDA FORMS VISTA EQUIVALENTS "FIA",22706.8,0) ^TMG(22706.8, "FIA",22706.8,0,0) 22706.8 "FIA",22706.8,0,1) y^y^f^^^^n "FIA",22706.8,0,10) "FIA",22706.8,0,11) "FIA",22706.8,0,"RLRO") "FIA",22706.8,22706.8) 0 "FIA",22706.82) TMG FDA ROUTES VISTA EQUIVALENTS "FIA",22706.82,0) ^TMG(22706.82, "FIA",22706.82,0,0) 22706.82 "FIA",22706.82,0,1) y^y^f^^^^n "FIA",22706.82,0,10) "FIA",22706.82,0,11) "FIA",22706.82,0,"RLRO") "FIA",22706.82,22706.82) 0 "FIA",22706.9) TMG FDA IMPORT COMPILED "FIA",22706.9,0) ^TMG(22706.9, "FIA",22706.9,0,0) 22706.9P "FIA",22706.9,0,1) y^y^f^^^^n "FIA",22706.9,0,10) "FIA",22706.9,0,11) "FIA",22706.9,0,"RLRO") "FIA",22706.9,22706.9) 0 "FIA",22706.9,22706.9001) 0 "FIA",22706.9,22706.914) 0 "FIA",22706.9,22706.915) 0 "FIA",22706.9,22706.916) 0 "INIT") POSTINST^TMGKIDS "KRN",.4,1362,-1) 0^7 "KRN",.4,1362,0) TMG SENSITIVITY ACCESS^3050202.2147^@^38.1^^@^3070205 "KRN",.4,1362,"F",2) .01~50,.01~50,2~ "KRN",.4,1362,"H") DG SECURITY LOG LIST "KRN",.403,99,-1) 0^3 "KRN",.403,99,0) TMG REGISTER^@^@^^3050104.2156^^^2^1^0^1 "KRN",.403,99,40,0) ^.4031I^1^1 "KRN",.403,99,40,1,0) 1^^1,1 "KRN",.403,99,40,1,1) Page 1 "KRN",.403,99,40,1,40,0) ^.4032IP^367^1 "KRN",.403,99,40,1,40,367,0) TMG MAIN 1^1^1,1^d "KRN",.403,100,-1) 0^2 "KRN",.403,100,0) TMG EDIT PROGRESS NOTE^@^@^^3050612.1225^^^8925^0^0^1 "KRN",.403,100,40,0) ^.4031I^1^1 "KRN",.403,100,40,1,0) 1^^1,1 "KRN",.403,100,40,1,1) Page 1 "KRN",.403,100,40,1,40,0) ^.4032IP^369^2 "KRN",.403,100,40,1,40,368,0) HEADER BLOCK 1^1^1,1^d "KRN",.403,100,40,1,40,369,0) Main Block^2^2,1^e "KRN",.403,101,-1) 0^4 "KRN",.403,101,0) TMG UPDATE SETTINGS^@^@^^3060222.1644^^^22711^0^0^1 "KRN",.403,101,40,0) ^.4031I^1^1 "KRN",.403,101,40,1,0) 1^^1,1 "KRN",.403,101,40,1,1) Page 1 "KRN",.403,101,40,1,40,0) ^.4032IP^370^1 "KRN",.403,101,40,1,40,370,0) TMG UPLOAD SETTINGS BLOCK^1^1,1^e "KRN",.403,102,-1) 0^5 "KRN",.403,102,0) TMG VIEW DRUG^@^@^^3060304.2146^^^50.68^0^0^1 "KRN",.403,102,40,0) ^.4031I^4^3 "KRN",.403,102,40,1,0) 1^^1,1^2^ "KRN",.403,102,40,1,1) Page 1 "KRN",.403,102,40,1,40,0) ^.4032IP^371^1 "KRN",.403,102,40,1,40,371,0) VIEW DRUG^1^1,1^e "KRN",.403,102,40,3,0) 2^^1,1^^1 "KRN",.403,102,40,3,1) Page 2 "KRN",.403,102,40,3,40,0) ^.4032IP^372^1 "KRN",.403,102,40,3,40,372,0) INGREDIENTS REPEATING^2^1,1^e "KRN",.403,102,40,3,40,372,2) 6 "KRN",.403,102,40,4,0) 1.5^^5,7^^^1^15,75 "KRN",.403,102,40,4,1) Page 1.5^ACTIVE INGREDIENTS,VIEW DRUG,1 "KRN",.403,102,40,4,40,0) ^.4032IP^373^1 "KRN",.403,102,40,4,40,373,0) VIEW INGREDIENTS^1^2,2^e "KRN",.403,102,40,4,40,373,2) ^^^^^ "KRN",.403,103,-1) 0^1 "KRN",.403,103,0) TMG EDIT DRUG^@^@^^3070112.2148^^^50^0^0^1 "KRN",.403,103,40,0) ^.4031I^1^1 "KRN",.403,103,40,1,0) 1^^1,1 "KRN",.403,103,40,1,1) Page 1 "KRN",.403,103,40,1,40,0) ^.4032IP^374^1 "KRN",.403,103,40,1,40,374,0) BLOCK1^1^1,1^e "KRN",.404,367,0) TMG MAIN 1^2^ "KRN",.404,367,40,0) ^.4044I^6^6 "KRN",.404,367,40,1,0) 1^Patient Edit / Registration^1 "KRN",.404,367,40,1,2) ^^1,27 "KRN",.404,367,40,2,0) 2^NAME^3 "KRN",.404,367,40,2,1) .01 "KRN",.404,367,40,2,2) 3,7^30^3,1 "KRN",.404,367,40,3,0) 3^Soc. Sec. Number^3 "KRN",.404,367,40,3,1) .09 "KRN",.404,367,40,3,2) 5,19^10^5,1 "KRN",.404,367,40,4,0) 4^DATE OF BIRTH^3 "KRN",.404,367,40,4,1) .03 "KRN",.404,367,40,4,2) 4,16^11^4,1 "KRN",.404,367,40,5,0) 5^MEDIC ACCOUNT NUMBER^3 "KRN",.404,367,40,5,1) 22700 "KRN",.404,367,40,5,2) 6,23^12^6,1 "KRN",.404,367,40,6,0) 6^ATTENDING PHYSICIAN^3 "KRN",.404,367,40,6,1) .1041 "KRN",.404,367,40,6,2) 14,22^35^14,1 "KRN",.404,368,0) HEADER BLOCK 1^8925^ "KRN",.404,368,40,0) ^.4044I^3^2 "KRN",.404,368,40,2,0) 2^The Medical Group of Greeneville^1 "KRN",.404,368,40,2,2) ^^1,1 "KRN",.404,368,40,3,0) 3^Progress Note Properties Editor^1 "KRN",.404,368,40,3,2) ^^1,37 "KRN",.404,369,0) Main Block^8925 "KRN",.404,369,40,0) ^.4044I^16^16 "KRN",.404,369,40,1,0) 1^DOCUMENT TYPE^3^^ "KRN",.404,369,40,1,1) .01 "KRN",.404,369,40,1,2) 2,30^60^2,15 "KRN",.404,369,40,2,0) 2^PATIENT^3 "KRN",.404,369,40,2,1) .02 "KRN",.404,369,40,2,2) 3,30^30^3,21 "KRN",.404,369,40,3,0) 4.6^EPISODE DATE/TIME^3 "KRN",.404,369,40,3,1) .07 "KRN",.404,369,40,3,2) 7,30^20^7,11 "KRN",.404,369,40,4,0) 3^STATUS^3 "KRN",.404,369,40,4,1) .05 "KRN",.404,369,40,4,2) 4,30^30^4,22 "KRN",.404,369,40,5,0) 5^DATA ENTRY DATE/TIME^3 "KRN",.404,369,40,5,1) 1201 "KRN",.404,369,40,5,2) 8,30^20^8,8 "KRN",.404,369,40,6,0) 6^AUTHOR^3 "KRN",.404,369,40,6,1) 1202 "KRN",.404,369,40,6,2) 10,30^35^10,22 "KRN",.404,369,40,7,0) 7^TRANSCRIPTIONIST/ENTERED BY^3 "KRN",.404,369,40,7,1) 1302 "KRN",.404,369,40,7,2) 11,30^35^11,1 "KRN",.404,369,40,8,0) 4^VISIT LOCATION^3 "KRN",.404,369,40,8,1) 1211 "KRN",.404,369,40,8,2) 5,30^21^5,14 "KRN",.404,369,40,9,0) 4.5^VISIT^3 "KRN",.404,369,40,9,1) .03 "KRN",.404,369,40,9,2) 6,30^20^6,23 "KRN",.404,369,40,10,0) 8^REPORT TEXT^3 "KRN",.404,369,40,10,1) 2 "KRN",.404,369,40,10,2) 16,30^4^16,17 "KRN",.404,369,40,11,0) 9^*To edit text, press [ENTER] in REPORT TEXT field*^1 "KRN",.404,369,40,11,2) ^^15,16 "KRN",.404,369,40,12,0) 10^[TAB] between fields. Enter EXIT in COMMAND: field when done.^1 "KRN",.404,369,40,12,2) ^^1,7 "KRN",.404,369,40,13,0) 11^REFERENCE DATE^3^^Reference Date "KRN",.404,369,40,13,1) 1301 "KRN",.404,369,40,13,2) 9,30^20^9,14 "KRN",.404,369,40,14,0) 12^EXPECTED SIGNER^3 "KRN",.404,369,40,14,1) 1204 "KRN",.404,369,40,14,2) 12,30^35^12,13 "KRN",.404,369,40,15,0) 13^SIGNATURE BLOCK NAME^3 "KRN",.404,369,40,15,1) 1503 "KRN",.404,369,40,15,2) 14,30^38^14,8 "KRN",.404,369,40,16,0) 14^SIGNED BY^3 "KRN",.404,369,40,16,1) 1502 "KRN",.404,369,40,16,2) 13,30^35^13,19 "KRN",.404,370,0) TMG UPLOAD SETTINGS BLOCK^22711^ "KRN",.404,370,40,0) ^.4044I^10^9 "KRN",.404,370,40,1,0) 1^Sequel Demographics Import Settings^1 "KRN",.404,370,40,1,2) ^^1,22 "KRN",.404,370,40,2,0) 1.1^IMPORT DATAFILE NAME^3 "KRN",.404,370,40,2,1) 2 "KRN",.404,370,40,2,2) 4,26^51^4,4 "KRN",.404,370,40,3,0) 0^IMPORT DATAFILE PATH^3 "KRN",.404,370,40,3,1) 2.5 "KRN",.404,370,40,3,2) 3,26^50^3,4 "KRN",.404,370,40,4,0) 4^IMPORT DATAFILE 2 NAME^3 "KRN",.404,370,40,4,1) 2.1 "KRN",.404,370,40,4,2) 5,26^54^5,2 "KRN",.404,370,40,5,0) 5^ALERT RECIPIENT^3 "KRN",.404,370,40,5,1) 3 "KRN",.404,370,40,5,2) 7,33^35^7,16 "KRN",.404,370,40,6,0) 6^DELETE DATAFILE AFTER IMPORT?^3 "KRN",.404,370,40,6,1) 5 "KRN",.404,370,40,6,2) 8,33^3^8,2 "KRN",.404,370,40,7,0) 7^PICK GENDER FROM NAME?^3 "KRN",.404,370,40,7,1) 6 "KRN",.404,370,40,7,2) 9,33^3^9,9 "KRN",.404,370,40,8,0) 8^IMPORT FREQUENCY (IN HOURS)^3 "KRN",.404,370,40,8,1) 7 "KRN",.404,370,40,8,2) 10,33^4^10,4 "KRN",.404,370,40,10,0) 10^LAST IMPORT DATE^3 "KRN",.404,370,40,10,1) 4 "KRN",.404,370,40,10,2) 11,33^20^11,15 "KRN",.404,370,40,10,13) SET X=DDSOLD "KRN",.404,371,0) VIEW DRUG^50.68 "KRN",.404,371,40,0) ^.4044I^29^29 "KRN",.404,371,40,1,0) 1^VIEW DRUG (VA PRODUCT FILE ENTRY)^1 "KRN",.404,371,40,1,2) ^^1,23 "KRN",.404,371,40,2,0) 2^NAME^3 "KRN",.404,371,40,2,1) .01 "KRN",.404,371,40,2,2) 2,7^51^2,1 "KRN",.404,371,40,3,0) 3^VA GENERIC NAME^3 "KRN",.404,371,40,3,1) .05 "KRN",.404,371,40,3,2) 3,18^62^3,1 "KRN",.404,371,40,4,0) 4^STRENGTH^3 "KRN",.404,371,40,4,1) 2 "KRN",.404,371,40,4,2) 4,46^15^4,36 "KRN",.404,371,40,5,0) 5^DOSAGE FORM^3 "KRN",.404,371,40,5,1) 1 "KRN",.404,371,40,5,2) 4,14^20^4,1 "KRN",.404,371,40,6,0) 6^UNITS^3 "KRN",.404,371,40,6,1) 3 "KRN",.404,371,40,6,2) 4,70^10^4,63 "KRN",.404,371,40,7,0) 7^NATIONAL FORMULARY NAME^3 "KRN",.404,371,40,7,1) 4 "KRN",.404,371,40,7,2) 5,26^54^5,1 "KRN",.404,371,40,8,0) 8^VA PRINT NAME^3 "KRN",.404,371,40,8,1) 5 "KRN",.404,371,40,8,2) 6,16^40^6,1 "KRN",.404,371,40,9,0) 9^VA PRODUCT IDENTIFIER^3 "KRN",.404,371,40,9,1) 6 "KRN",.404,371,40,9,2) 7,24^5^7,1 "KRN",.404,371,40,10,0) 10^TRANSMIT TO CMOP^3 "KRN",.404,371,40,10,1) 7 "KRN",.404,371,40,10,2) 7,50^3^7,32 "KRN",.404,371,40,11,0) 11^VA DISPENSE UNIT^3 "KRN",.404,371,40,11,1) 8 "KRN",.404,371,40,11,2) 8,19^10^8,1 "KRN",.404,371,40,12,0) 12^GCNSEQNO^3 "KRN",.404,371,40,12,1) 11 "KRN",.404,371,40,12,2) 9,11^9^9,1 "KRN",.404,371,40,13,0) 13^PREVIOUS GCNSEQNO^3 "KRN",.404,371,40,13,1) 12 "KRN",.404,371,40,13,2) 9,41^9^9,22 "KRN",.404,371,40,14,0) 14^NDC LINK TO GCNSEQNO^3 "KRN",.404,371,40,14,1) 13 "KRN",.404,371,40,14,2) 9,74^4^9,52 "KRN",.404,371,40,15,0) 15^PRIMARY VA DRUG CLASS^3 "KRN",.404,371,40,15,1) 15 "KRN",.404,371,40,15,2) 10,24^5^10,1 "KRN",.404,371,40,16,0) 16^Select 2nd VA DRUG CLASS^3^^ "KRN",.404,371,40,16,1) 16 "KRN",.404,371,40,16,2) 10,60^15^10,34 "KRN",.404,371,40,17,0) 17^NAT. FORMULARY INDICATOR^3 "KRN",.404,371,40,17,1) 17 "KRN",.404,371,40,17,2) 11,27^3^11,1 "KRN",.404,371,40,18,0) 18^NATIONAL FORMULARY RESTRICTION^3 "KRN",.404,371,40,18,1) 18 "KRN",.404,371,40,18,2) 11,66^1^11,34 "KRN",.404,371,40,19,0) 19^CS FEDERAL SCHEDULE^3 "KRN",.404,371,40,19,1) 19 "KRN",.404,371,40,19,2) 8,53^26^8,32 "KRN",.404,371,40,20,0) 20^SINGLE/MULTI SOURCE PRODUCT^3 "KRN",.404,371,40,20,1) 20 "KRN",.404,371,40,20,2) 12,30^13^12,1 "KRN",.404,371,40,21,0) 21^INACTIVATION DATE^3 "KRN",.404,371,40,21,1) 21 "KRN",.404,371,40,21,2) 13,20^11^13,1 "KRN",.404,371,40,22,0) 22^EXCLUDE DRG-DRG INTERACTION CK^3 "KRN",.404,371,40,22,1) 23 "KRN",.404,371,40,22,2) 13,66^3^13,34 "KRN",.404,371,40,23,0) 23^MAX SINGLE DOSE^3 "KRN",.404,371,40,23,1) 25 "KRN",.404,371,40,23,2) 14,18^13^14,1 "KRN",.404,371,40,24,0) 24^MIN SINGLE DOSE^3 "KRN",.404,371,40,24,1) 26 "KRN",.404,371,40,24,2) 14,51^13^14,34 "KRN",.404,371,40,25,0) 25^MAX DAILY DOSE^3 "KRN",.404,371,40,25,1) 27 "KRN",.404,371,40,25,2) 15,17^13^15,1 "KRN",.404,371,40,26,0) 26^MIN DAILY DOSE^3 "KRN",.404,371,40,26,1) 28 "KRN",.404,371,40,26,2) 15,50^13^15,34 "KRN",.404,371,40,27,0) 27^MAX CUMULATIVE DOSE^3 "KRN",.404,371,40,27,1) 29 "KRN",.404,371,40,27,2) 16,22^10^16,1 "KRN",.404,371,40,28,0) 28^DSS NUMBER^3 "KRN",.404,371,40,28,1) 30 "KRN",.404,371,40,28,2) 16,46^6^16,34 "KRN",.404,371,40,29,0) 29^Select ACTIVE INGREDIENTS (Popup)^3^^ACTIVE INGREDIENTS "KRN",.404,371,40,29,1) 14 "KRN",.404,371,40,29,2) 17,36^30^17,1 "KRN",.404,372,0) INGREDIENTS REPEATING^50.6814 "KRN",.404,372,40,0) ^.4044I^6^6 "KRN",.404,372,40,1,0) 1^^3 "KRN",.404,372,40,1,1) .01 "KRN",.404,372,40,1,2) 4,2^35 "KRN",.404,372,40,2,0) 2^^3 "KRN",.404,372,40,2,1) 1 "KRN",.404,372,40,2,2) 4,39^15 "KRN",.404,372,40,3,0) 3^^3 "KRN",.404,372,40,3,1) 2 "KRN",.404,372,40,3,2) 4,60^10 "KRN",.404,372,40,4,0) 4^** ACTIVE INGREDIENTS **^1 "KRN",.404,372,40,4,2) ^^3,2 "KRN",.404,372,40,5,0) 5^STRENGTH^1 "KRN",.404,372,40,5,2) ^^3,39 "KRN",.404,372,40,6,0) 6^UNITS^1 "KRN",.404,372,40,6,2) ^^3,60 "KRN",.404,373,0) VIEW INGREDIENTS^50.6814 "KRN",.404,373,40,0) ^.4044I^3^3 "KRN",.404,373,40,1,0) 1^ACTIVE INGREDIENTS^3 "KRN",.404,373,40,1,1) .01 "KRN",.404,373,40,1,2) 1,21^40^1,1 "KRN",.404,373,40,2,0) 2^STRENGTH^3 "KRN",.404,373,40,2,1) 1 "KRN",.404,373,40,2,2) 2,11^45^2,1 "KRN",.404,373,40,3,0) 3^UNITS^3 "KRN",.404,373,40,3,1) 2 "KRN",.404,373,40,3,2) 3,8^30^3,1 "KRN",.404,374,0) BLOCK1^50 "KRN",.404,374,40,0) ^.4044I^11^11 "KRN",.404,374,40,1,0) 1^GENERIC NAME^3 "KRN",.404,374,40,1,1) .01 "KRN",.404,374,40,1,2) 1,15^40^1,1 "KRN",.404,374,40,2,0) 2^VA CLASSIFICATION^3 "KRN",.404,374,40,2,1) 2 "KRN",.404,374,40,2,2) 2,20^20^2,1 "KRN",.404,374,40,3,0) 3^PHARMACY ORDERABLE ITEM^3 "KRN",.404,374,40,3,1) 2.1 "KRN",.404,374,40,3,2) 3,26^40^3,1 "KRN",.404,374,40,4,0) 4^NATIONAL DRUG FILE ENTRY^3 "KRN",.404,374,40,4,1) 20 "KRN",.404,374,40,4,2) 4,27^51^4,1 "KRN",.404,374,40,5,0) 5^VA PRODUCT NAME^3 "KRN",.404,374,40,5,1) 21 "KRN",.404,374,40,5,2) 5,18^60^5,1 "KRN",.404,374,40,6,0) 6^PSNDF VA PRODUCT NAME ENTRY^3 "KRN",.404,374,40,6,1) 22 "KRN",.404,374,40,6,2) 6,30^50^6,1 "KRN",.404,374,40,7,0) 7^STRENGTH^3 "KRN",.404,374,40,7,1) 901 "KRN",.404,374,40,7,2) 7,11^13^7,1 "KRN",.404,374,40,8,0) 8^UNIT^3 "KRN",.404,374,40,8,1) 902 "KRN",.404,374,40,8,2) 8,7^73^8,1 "KRN",.404,374,40,9,0) 9^Select POSSIBLE DOSAGES^3 "KRN",.404,374,40,9,1) 903 "KRN",.404,374,40,9,2) 9,26^13^9,1 "KRN",.404,374,40,10,0) 10^CMOP DISPENSE^3 "KRN",.404,374,40,10,1) 213 "KRN",.404,374,40,10,2) 10,16^3^10,1 "KRN",.404,374,40,11,0) 11^CMOP ID^3 "KRN",.404,374,40,11,1) 27 "KRN",.404,374,40,11,2) 11,10^5^11,1 "KRN",19,10024,-1) 0^46 "KRN",19,10024,0) TMG TEXT MENU^Text Management Menu^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10024,10,0) ^19.01IP^13^13 "KRN",19,10024,10,12,0) 10048 "KRN",19,10024,10,12,"^") TMG AUTHOR TRANS COST ANY "KRN",19,10024,99) 60075,58861 "KRN",19,10024,"U") TEXT MANAGEMENT MENU "KRN",19,10026,-1) 0^52 "KRN",19,10026,0) TMG VPE MENU^VPE Menu Options^^M^^^^^^^^^y "KRN",19,10026,10,0) ^19.01IP^14^14 "KRN",19,10026,10,6,0) 10060^RPTR "KRN",19,10026,10,6,"^") TMG REDIRECT POINTERS "KRN",19,10026,10,7,0) 10061^PTR "KRN",19,10026,10,7,"^") TMG SHOW POINTERS IN "KRN",19,10026,10,8,0) 10062^PRO "KRN",19,10026,10,8,"^") TMG XUINDEX2 "KRN",19,10026,10,9,0) 10063^IDE "KRN",19,10026,10,9,"^") TMG DEBUGGER "KRN",19,10026,10,10,0) 10074^NOD "KRN",19,10026,10,10,"^") TMG ASK SHOW ARRAY NODES "KRN",19,10026,10,11,0) 10075^DUMP "KRN",19,10026,10,11,"^") TMG REC INQUIRE "KRN",19,10026,10,13,0) 10080^SEL "KRN",19,10026,10,13,"^") TMG SELECT EDIT RECORDS "KRN",19,10026,10,14,0) 10081^BRW "KRN",19,10026,10,14,"^") TMG REC BROWSE "KRN",19,10026,99) 60699,74258 "KRN",19,10026,"U") VPE MENU OPTIONS "KRN",19,10032,-1) 0^26 "KRN",19,10032,0) TMG REFILE UPLOAD^Refile Uploaded Buffer^^A^^^^^^^^^y^1 "KRN",19,10032,20) D REFILE^TMGPUTN0 "KRN",19,10032,"U") REFILE UPLOADED BUFFER "KRN",19,10033,-1) 0^21 "KRN",19,10033,0) TMG PHARMACY^TMG Pharmacy Menu^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10033,10,0) ^19.01IP^12^12 "KRN",19,10033,10,12,0) 10073^ED "KRN",19,10033,10,12,"^") TMG PHARM EDIT VA PRODUCT "KRN",19,10033,99) 60332,54590 "KRN",19,10033,"U") TMG PHARMACY MENU "KRN",19,10034,-1) 0^18 "KRN",19,10034,0) TMG OTHER 1^TMG Menu (Other) #1^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10034,10,0) ^19.01IP^21^17 "KRN",19,10034,10,13,0) 10036^DOC "KRN",19,10034,10,13,"^") TMG DOC MENU "KRN",19,10034,10,15,0) 10041^NS2 "KRN",19,10034,10,15,"^") TMG NURSE MENU "KRN",19,10034,10,17,0) 10040^MGR "KRN",19,10034,10,17,"^") TMG MGR MENU "KRN",19,10034,99) 60913,60478 "KRN",19,10034,"U") TMG MENU (OTHER) #1 "KRN",19,10035,-1) 0^44 "KRN",19,10035,0) TMG SHOW SENSITIVITY ACCESS^Show Access to Sensitive Patients^^P^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10035,1,0) ^^2^2^3050202^ "KRN",19,10035,1,1,0) This menu option will show a list off the entire sensitivity access log, "KRN",19,10035,1,2,0) or all patients. "KRN",19,10035,60) DGSL(38.1, "KRN",19,10035,61) 1 "KRN",19,10035,62) 0 "KRN",19,10035,63) [TMG SENSITIVITY ACCESS] "KRN",19,10035,64) .01 "KRN",19,10035,65) "KRN",19,10035,66) "KRN",19,10035,67) ACCESS TO SENSITIVE PATIENTS "KRN",19,10035,68) 1 "KRN",19,10035,70) HOME "KRN",19,10035,79) 0 "KRN",19,10035,"U") SHOW ACCESS TO SENSITIVE PATIE "KRN",19,10036,-1) 0^8 "KRN",19,10036,0) TMG DOC MENU^Doctors Menu^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10036,1,0) ^^1^1^3051027^^ "KRN",19,10036,1,1,0) This is a grouping of options that are targeted for physicians "KRN",19,10036,10,0) ^19.01IP^11^8 "KRN",19,10036,10,6,0) 10035^SEN "KRN",19,10036,10,6,"^") TMG SHOW SENSITIVITY ACCESS "KRN",19,10036,10,8,0) 10044^Rel "KRN",19,10036,10,8,"^") TMG RELEASE TRANS CURRENT USER "KRN",19,10036,10,9,0) 10047^TE "KRN",19,10036,10,9,"^") TMG AUTHOR TRANS COST CURRENT "KRN",19,10036,10,10,0) 10039^REG "KRN",19,10036,10,10,"^") TMG EDIT/ADD PATIENT "KRN",19,10036,99) 60073,52864 "KRN",19,10036,99.1) 61064,63680 "KRN",19,10036,"U") DOCTORS MENU "KRN",19,10037,-1) 0^27 "KRN",19,10037,0) TMG REGISTER^TMG Register Menu^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10037,10,0) ^19.01IP^10^10 "KRN",19,10037,10,9,0) 10038^ED "KRN",19,10037,10,9,"^") TMG EDIT PATIENT "KRN",19,10037,99) 59944,71993 "KRN",19,10037,"U") TMG REGISTER MENU "KRN",19,10038,-1) 0^10 "KRN",19,10038,0) TMG EDIT PATIENT^View/Edit Patient^^A^^^^^^^^^y^1 "KRN",19,10038,1,0) ^^1^1^3051027^^ "KRN",19,10038,1,1,0) This will edit or add a patient to the system (i.e. register them) "KRN",19,10038,20) DO EDITPT^TMGMISC(0) "KRN",19,10038,"U") VIEW/EDIT PATIENT "KRN",19,10039,-1) 0^12 "KRN",19,10039,0) TMG EDIT/ADD PATIENT^Edit (or Add) Patient^^A^^^^^^^^^y^1 "KRN",19,10039,20) DO EDITPT^TMGMISC(1) "KRN",19,10039,"U") EDIT (OR ADD) PATIENT "KRN",19,10040,-1) 0^16 "KRN",19,10040,0) TMG MGR MENU^TMG Manager's Menu^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10040,10,0) ^19.01IP^8^8 "KRN",19,10040,10,1,0) 10082^1^1 "KRN",19,10040,10,1,"^") TMG ADAM "KRN",19,10040,10,4,0) 10039^4^4 "KRN",19,10040,10,4,"^") TMG EDIT/ADD PATIENT "KRN",19,10040,10,5,0) 10043^5^5 "KRN",19,10040,10,5,"^") TMG TRANSCRIPTION REPORT "KRN",19,10040,10,6,0) 10046^6^6 "KRN",19,10040,10,6,"^") TMG PRINT CONTIGIOUSLY "KRN",19,10040,10,7,0) 10048^7^7 "KRN",19,10040,10,7,"^") TMG AUTHOR TRANS COST ANY "KRN",19,10040,10,8,0) 10045^8^8 "KRN",19,10040,10,8,"^") TMG RELEASE TRANS ANY USER "KRN",19,10040,99) 60715,44542 "KRN",19,10040,99.1) 61064,63680 "KRN",19,10040,"U") TMG MANAGER'S MENU "KRN",19,10041,-1) 0^17 "KRN",19,10041,0) TMG NURSE MENU^Nurse Menu^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10041,10,0) ^19.01IP^13^10 "KRN",19,10041,10,9,0) 10035^6^6 "KRN",19,10041,10,9,"^") TMG SHOW SENSITIVITY ACCESS "KRN",19,10041,10,10,0) 10039^7^7 "KRN",19,10041,10,10,"^") TMG EDIT/ADD PATIENT "KRN",19,10041,10,11,0) 10045^8^8 "KRN",19,10041,10,11,"^") TMG RELEASE TRANS ANY USER "KRN",19,10041,10,12,0) 10046^9^9 "KRN",19,10041,10,12,"^") TMG PRINT CONTIGIOUSLY "KRN",19,10041,99) 60073,48870 "KRN",19,10041,99.1) 61064,63680 "KRN",19,10041,"U") NURSE MENU "KRN",19,10042,-1) 0^13 "KRN",19,10042,0) TMG ERROR TRAP CHECK^Check Error Trap^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10042,20) DO ^XTER "KRN",19,10042,"U") CHECK ERROR TRAP "KRN",19,10043,-1) 0^50 "KRN",19,10043,0) TMG TRANSCRIPTION REPORT^Productivity Report^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10043,20) DO RPTASK^TMGTRAN1 "KRN",19,10043,"U") PRODUCTIVITY REPORT "KRN",19,10044,-1) 0^29 "KRN",19,10044,0) TMG RELEASE TRANS CURRENT USER^Release (Auto-Complete) Your Transcription^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10044,20) DO FREECUR^TMGTRAN1 "KRN",19,10044,"U") RELEASE (AUTO-COMPLETE) YOUR T "KRN",19,10045,-1) 0^28 "KRN",19,10045,0) TMG RELEASE TRANS ANY USER^Release (Auto-Complete) Any User's Transcription^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10045,20) DO FREEASK^TMGTRAN1 "KRN",19,10045,"U") RELEASE (AUTO-COMPLETE) ANY US "KRN",19,10046,-1) 0^22 "KRN",19,10046,0) TMG PRINT CONTIGIOUSLY^Print Notes Contigiously^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10046,1,0) ^^5^5^3050319^ "KRN",19,10046,1,1,0) The menu option will prompt for a patient's name, and then a date range. "KRN",19,10046,1,2,0) User will then be asked if notes should be separated onto a fresh page "KRN",19,10046,1,3,0) for each separate note (the default is to print them contigiously, i.e. "KRN",19,10046,1,4,0) the notes will come one right after another, with the break between notes "KRN",19,10046,1,5,0) occuring in the middle of the page). An output device may then be chosen. "KRN",19,10046,20) DO CONTPRNT^TMGPRPN "KRN",19,10046,"U") PRINT NOTES CONTIGIOUSLY "KRN",19,10047,-1) 0^5 "KRN",19,10047,0) TMG AUTHOR TRANS COST CURRENT^Your Transcription Expenses^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10047,1,0) ^^1^1^3051027^^ "KRN",19,10047,1,1,0) This will show the transcription expense for the current user only "KRN",19,10047,20) DO RPTCURA^TMGTRAN1 "KRN",19,10047,"U") YOUR TRANSCRIPTION EXPENSES "KRN",19,10048,-1) 0^4 "KRN",19,10048,0) TMG AUTHOR TRANS COST ANY^Transcription Expenses Report (Any Author)^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10048,1,0) ^^1^1^3051027^^ "KRN",19,10048,1,1,0) This shows the transcription expenses as specified "KRN",19,10048,20) DO RPTASKA^TMGTRAN1 "KRN",19,10048,"U") TRANSCRIPTION EXPENSES REPORT "KRN",19,10049,-1) 0^19 "KRN",19,10049,0) TMG PASSWORDS UNMASK^Password Snooper^^A^^DG SECURITY OFFICER^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10049,1,0) ^^1^1^3050421^ "KRN",19,10049,1,1,0) Will display Access, Verify, and Electronic signiture codes for any user. "KRN",19,10049,20) DO PWDSNOOP^TMGTRAN1() "KRN",19,10049,"U") PASSWORD SNOOPER "KRN",19,10050,-1) 0^49 "KRN",19,10050,0) TMG TRANS SHOW UNSIGNED^Show All Unsigned Notes^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10050,20) DO SHOWUNSIGNED^TMGTRAN1 "KRN",19,10050,"U") SHOW ALL UNSIGNED NOTES "KRN",19,10051,-1) 0^47 "KRN",19,10051,0) TMG TRANS REPRINT BATCH^Reprint Documents Batch Signed^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10051,20) DO REPRINTSET^TMGTRNRP "KRN",19,10051,"U") REPRINT DOCUMENTS BATCH SIGNED "KRN",19,10052,-1) 0^45 "KRN",19,10052,0) TMG SHOW XTER^Show Error Log^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10052,20) DO ^XTER "KRN",19,10052,"U") SHOW ERROR LOG "KRN",19,10053,-1) 0^11 "KRN",19,10053,0) TMG EDIT PROGRESS NOTE^Edit Progress Note Properties^^C^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10053,1,0) ^19.06^1^1^3080209^^^ "KRN",19,10053,1,1,0) This will allow editing of the properties (and the text) of a progress note "KRN",19,10053,30) TIU(8925, "KRN",19,10053,31) AMEQ "KRN",19,10053,32) Enter patient name (^ to quit): "KRN",19,10053,40) [TMG EDIT PROGRESS NOTE] "KRN",19,10053,41) 8925 "KRN",19,10053,43) 1 "KRN",19,10053,"U") EDIT PROGRESS NOTE PROPERTIES "KRN",19,10054,-1) 0^14 "KRN",19,10054,0) TMG MAIN MENU TRANSCRIPTION^Transcription^^M^^^^^^^y^TEXT INTEGRATION UTILITIES^y^1^^^1 "KRN",19,10054,1,0) ^^1^1^2950818^^^^ "KRN",19,10054,1,1,0) Main Text Integration Utilities menu for transcriptionists. "KRN",19,10054,10,0) ^19.01IP^12^11 "KRN",19,10054,10,5,0) 10043^5^5 "KRN",19,10054,10,5,"^") TMG TRANSCRIPTION REPORT "KRN",19,10054,10,6,0) 10039^7^7 "KRN",19,10054,10,6,"^") TMG EDIT/ADD PATIENT "KRN",19,10054,10,7,0) 10045^8^8 "KRN",19,10054,10,7,"^") TMG RELEASE TRANS ANY USER "KRN",19,10054,10,8,0) 10050^9^9 "KRN",19,10054,10,8,"^") TMG TRANS SHOW UNSIGNED "KRN",19,10054,10,9,0) 10051^10^10 "KRN",19,10054,10,9,"^") TMG TRANS REPRINT BATCH "KRN",19,10054,10,10,0) 10053^1^1 "KRN",19,10054,10,10,"^") TMG EDIT PROGRESS NOTE "KRN",19,10054,10,11,0) 10048^6^6 "KRN",19,10054,10,11,"^") TMG AUTHOR TRANS COST ANY "KRN",19,10054,10,12,0) 10078^11^11 "KRN",19,10054,10,12,"^") TMG TRANS REPRINT TEMPLATE "KRN",19,10054,20) D EDITSAVE^TIUEDI2(.DUZ) "KRN",19,10054,26) W !!,$$CENTER^TIULS("--- Transcriptionist Menu ---") "KRN",19,10054,99) 60513,66490 "KRN",19,10054,99.1) 61064,63680 "KRN",19,10054,"U") TRANSCRIPTION "KRN",19,10056,-1) 0^15 "KRN",19,10056,0) TMG MEDIC CONVERTER^Convert Medic Transcription^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10056,20) DO FULLDIRCVD^TMGMEDIC "KRN",19,10056,"U") CONVERT MEDIC TRANSCRIPTION "KRN",19,10057,-1) 0^54 "KRN",19,10057,0) TMG XML EXPORTER^TMG's XML Exporter^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10057,20) DO EXPORT^TMGXMLEX "KRN",19,10057,"U") TMG'S XML EXPORTER "KRN",19,10058,-1) 0^51 "KRN",19,10058,0) TMG UPLOAD BATCH DOCUMENTS^Upload Batch of Documents^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10058,1,0) ^^2^2^3050831^^ "KRN",19,10058,1,1,0) Use this option to load a batch of documents, all stored in a common "KRN",19,10058,1,2,0) directory "KRN",19,10058,20) DO MAIN^TMGUPLD "KRN",19,10058,"U") UPLOAD BATCH OF DOCUMENTS "KRN",19,10060,-1) 0^25 "KRN",19,10060,0) TMG REDIRECT POINTERS^REDIRECT RECORD POINTERS^^A^^XUPROGMODE^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10060,1,0) ^^3^3^3051120^^ "KRN",19,10060,1,1,0) Ask user for a file to search through, then choose a FROM record. Next a TO "KRN",19,10060,1,2,0) record is chosen, and Fileman is used to redirect all pointers to FROM "KRN",19,10060,1,3,0) record into pointers to TO record. "KRN",19,10060,20) DO ASKMVPTR^TMGFMUT "KRN",19,10060,"U") REDIRECT RECORD POINTERS "KRN",19,10061,-1) 0^43 "KRN",19,10061,0) TMG SHOW POINTERS IN^Show Pointers to Record^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10061,1,0) ^^2^2^3051120^^ "KRN",19,10061,1,1,0) This will show all instances of a pointer to a given record. "KRN",19,10061,1,2,0) Note: This can be a SLOW process to scan the entire database. "KRN",19,10061,20) DO ASKPTRIN^TMGFMUT "KRN",19,10061,"U") SHOW POINTERS TO RECORD "KRN",19,10062,-1) 0^55 "KRN",19,10062,0) TMG XUINDEX2^Pretty Print Routines^^R^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10062,1,0) ^19.06^2^2^3060101^^ "KRN",19,10062,1,1,0) This option will allow the direct printing of %INDEX's structured "KRN",19,10062,1,2,0) routine print. "KRN",19,10062,25) XCR^XINDX8 "KRN",19,10062,"U") PRETTY PRINT ROUTINES "KRN",19,10063,-1) 0^7 "KRN",19,10063,0) TMG DEBUGGER^TMGIDE Debugger^^R^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10063,25) START^TMGIDE "KRN",19,10063,"U") TMGIDE DEBUGGER "KRN",19,10064,-1) 0^53 "KRN",19,10064,0) TMG WEBSITE EXPORT^TMG's Website/HTML TIU DOCUMENTS Exporter^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10064,20) DO MAKESITE^TMGHTML1() "KRN",19,10064,"U") TMG'S WEBSITE/HTML TIU DOCUMEN "KRN",19,10065,-1) 0^35 "KRN",19,10065,0) TMG SEQUEL DATA IMPORT CUSTOM^Custom Import Demographics from Sequel^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10065,20) DO ASKIMPORT^TMGSEQL1 "KRN",19,10065,"U") CUSTOM IMPORT DEMOGRAPHICS FRO "KRN",19,10066,-1) 0^40 "KRN",19,10066,0) TMG SEQUEL RPT SSNUM CONFLICTS^Report conflicting SS numbers^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10066,20) DO RPTSSNCF^TMGSEQL3 "KRN",19,10066,"U") REPORT CONFLICTING SS NUMBERS "KRN",19,10067,-1) 0^37 "KRN",19,10067,0) TMG SEQUEL IMPORT MENU^Import Demographics from Sequel^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10067,10,0) ^19.01IP^7^7 "KRN",19,10067,10,1,0) 10065 "KRN",19,10067,10,1,"^") TMG SEQUEL DATA IMPORT CUSTOM "KRN",19,10067,10,2,0) 10066^RPT "KRN",19,10067,10,2,"^") TMG SEQUEL RPT SSNUM CONFLICTS "KRN",19,10067,10,3,0) 10068^CLR "KRN",19,10067,10,3,"^") TMG SEQUEL CLEAR IMPORT ERRORS "KRN",19,10067,10,4,0) 10069^ "KRN",19,10067,10,4,"^") TMG SEQUEL DATA IMPORT "KRN",19,10067,10,5,0) 10070 "KRN",19,10067,10,5,"^") TMG SEQUEL IMPORT DATES "KRN",19,10067,10,6,0) 10071^SET "KRN",19,10067,10,6,"^") TMG SEQUEL IMPORT SETTINGS "KRN",19,10067,10,7,0) 10072^DOB "KRN",19,10067,10,7,"^") TMG SEQUEL RPT DOB ERROR "KRN",19,10067,99) 60325,39286 "KRN",19,10067,"U") IMPORT DEMOGRAPHICS FROM SEQUE "KRN",19,10068,-1) 0^33 "KRN",19,10068,0) TMG SEQUEL CLEAR IMPORT ERRORS^Clear Demographics import error Alerts^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10068,20) DO CLEARALL^TMGSEQL3 "KRN",19,10068,"U") CLEAR DEMOGRAPHICS IMPORT ERRO "KRN",19,10069,-1) 0^34 "KRN",19,10069,0) TMG SEQUEL DATA IMPORT^Import Sequel Demographics Now^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10069,20) DO RUNNOW^TMGSEQL1 "KRN",19,10069,"U") IMPORT SEQUEL DEMOGRAPHICS NOW "KRN",19,10070,-1) 0^36 "KRN",19,10070,0) TMG SEQUEL IMPORT DATES^Show Sequel Import Dates & Times^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10070,20) DO SHOWTIME^TMGSEQL3 "KRN",19,10070,"U") SHOW SEQUEL IMPORT DATES & TIM "KRN",19,10071,-1) 0^38 "KRN",19,10071,0) TMG SEQUEL IMPORT SETTINGS^Sequel Import Settings^^C^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10071,30) TMG(22711, "KRN",19,10071,31) AEQM "KRN",19,10071,32) Press for Settings ( ^ to Quit) "KRN",19,10071,33) `1 "KRN",19,10071,40) [TMG UPDATE SETTINGS] "KRN",19,10071,41) 22711 "KRN",19,10071,43) 1 "KRN",19,10071,"U") SEQUEL IMPORT SETTINGS "KRN",19,10072,-1) 0^39 "KRN",19,10072,0) TMG SEQUEL RPT DOB ERROR^Report DOB errors^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10072,20) DO RPTDOBER^TMGSEQL3 "KRN",19,10072,"U") REPORT DOB ERRORS "KRN",19,10073,-1) 0^20 "KRN",19,10073,0) TMG PHARM EDIT VA PRODUCT^Edit VA PRODUCT^^C^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10073,30) PSNDF(50.68, "KRN",19,10073,31) AEQM "KRN",19,10073,40) [TMG VIEW DRUG] "KRN",19,10073,41) 50.68 "KRN",19,10073,43) 1 "KRN",19,10073,"U") EDIT VA PRODUCT "KRN",19,10074,-1) 0^3 "KRN",19,10074,0) TMG ASK SHOW ARRAY NODES^Show Array Nodes^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10074,20) DO BROWSEASK^TMGMISC "KRN",19,10074,"U") SHOW ARRAY NODES "KRN",19,10075,-1) 0^24 "KRN",19,10075,0) TMG REC INQUIRE^Record Dump (Inquire)^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10075,20) DO ASKDUMP^TMGDEBUG "KRN",19,10075,"U") RECORD DUMP (INQUIRE) "KRN",19,10078,-1) 0^48 "KRN",19,10078,0) TMG TRANS REPRINT TEMPLATE^Reprint Documents Stored in Template^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10078,1,0) ^^8^8^3060905^^ "KRN",19,10078,1,1,0) To use this menu, first use Fileman to search for documents "KRN",19,10078,1,2,0) in file 8925 (TIU DOCUMENTS), using whatever other search "KRN",19,10078,1,3,0) criteria desired (i.e. author, patient etc.) Then, when "KRN",19,10078,1,4,0) prompted to: "KRN",19,10078,1,5,0) STORE RESULTS OF SEARCH IN TEMPLATE: <--- enter a name. "KRN",19,10078,1,6,0) "KRN",19,10078,1,7,0) Then, when running this function, enter this name again to "KRN",19,10078,1,8,0) choose the template, and documents will be reprinted to it. "KRN",19,10078,20) DO PRTEMPL^TMGTRNRP "KRN",19,10078,"U") REPRINT DOCUMENTS STORED IN TE "KRN",19,10079,-1) 0^30 "KRN",19,10079,0) TMG REPRINT TEMPLATE^REPRINT TEMPLATE^^A^^^^^^^^^y^1 "KRN",19,10079,20) DO PRTEMPL^TMGTRNRP "KRN",19,10079,"U") REPRINT TEMPLATE "KRN",19,10080,-1) 0^32 "KRN",19,10080,0) TMG SELECT EDIT RECORDS^Select & Edit Records^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10080,1,0) ^^1^1^3061007^^ "KRN",19,10080,1,1,0) This function asks for records to browse among, then allows users to browse records, selecting those to be edited. "KRN",19,10080,20) DO ASKSELED^TMGSELED "KRN",19,10080,"U") SELECT & EDIT RECORDS "KRN",19,10081,-1) 0^23 "KRN",19,10081,0) TMG REC BROWSE^RECORD BROWSE^^A^^^^^^^^FP OF GREENEVILLE (TMG)^y^1 "KRN",19,10081,1,0) ^^3^3^3070310^^ "KRN",19,10081,1,1,0) This option will allow a browse of a record, "KRN",19,10081,1,2,0) with ability to follow pointers on to other "KRN",19,10081,1,3,0) linked records. "KRN",19,10081,20) D ASKBROWS^TMGBROWS "KRN",19,10081,"U") RECORD BROWSE "KRN",19,10082,-1) 0^1 "KRN",19,10082,0) TMG ADAM^Adam^^M^^^^^^^^FP OF GREENEVILLE (TMG)^y "KRN",19,10082,10,0) ^19.01IP^24^11 "KRN",19,10082,10,9,0) 10024^TX "KRN",19,10082,10,9,"^") TMG TEXT MENU "KRN",19,10082,10,18,0) 10026^VPE "KRN",19,10082,10,18,"^") TMG VPE MENU "KRN",19,10082,10,19,0) 10033^PHAR "KRN",19,10082,10,19,"^") TMG PHARMACY "KRN",19,10082,10,21,0) 10034^Ox "KRN",19,10082,10,21,"^") TMG OTHER 1 "KRN",19,10082,10,22,0) 10039^REG "KRN",19,10082,10,22,"^") TMG EDIT/ADD PATIENT "KRN",19,10082,10,23,0) 10054^TRAN "KRN",19,10082,10,23,"^") TMG MAIN MENU TRANSCRIPTION "KRN",19,10082,10,24,0) 10067^SEQ "KRN",19,10082,10,24,"^") TMG SEQUEL IMPORT MENU "KRN",19,10082,99) 60715,43516 "KRN",19,10082,99.1) 61064,63680 "KRN",19,10082,"U") ADAM "KRN",19,10084,-1) 0^2 "KRN",19,10084,0) TMG ADD PATIENT^TMGADDPATIENT^^^^^^^^^^ "KRN",19,10084,"U") TMGADDPATIENT "KRN",19,10085,-1) 0^41 "KRN",19,10085,0) TMG SET PATIENT DEMOGRAPHICS^SET PATIENT DEMOGRAPHICS^^^^^^^^^^ "KRN",19,10085,"U") SET PATIENT DEMOGRAPHICS "KRN",19,10086,-1) 0^31 "KRN",19,10086,0) TMG RPC CONTEXT SCANNER^ScanManager 1.0.0.0^^B^^^^^^^^ "KRN",19,10086,1,0) ^^3^3^3080120^^ "KRN",19,10086,1,1,0) This option is required by the Kernel Broker to give "KRN",19,10086,1,2,0) access to the RPCs used by the ScanManager app "KRN",19,10086,1,3,0) (Scanner.exe) "KRN",19,10086,"RPC",0) ^19.05P^14^14 "KRN",19,10086,"RPC",1,0) TMG UPLOAD FILE "KRN",19,10086,"RPC",2,0) TMG DOWNLOAD FILE "KRN",19,10086,"RPC",3,0) MAGGADDIMAGE "KRN",19,10086,"RPC",4,0) MAG3 TIU IMAGE "KRN",19,10086,"RPC",5,0) MAG3 CPRS TIU NOTE "KRN",19,10086,"RPC",6,0) TMG GET IMAGE LONG DESCRIPTION "KRN",19,10086,"RPC",7,0) TMG GET DFN "KRN",19,10086,"RPC",8,0) TMG GET BLANK TIU DOCUMENT "KRN",19,10086,"RPC",9,0) TMG AUTOSIGN TIU DOCUMENT "KRN",19,10086,"RPC",10,0) TMG GET PATIENT DEMOGRAPHICS "KRN",19,10086,"RPC",11,0) TMG SET PATIENT DEMOGRAPHICS "KRN",19,10086,"RPC",12,0) TMG ADD PATIENT "KRN",19,10086,"RPC",13,0) TMG BARCODE ENCODE "KRN",19,10086,"RPC",14,0) TMG BARCODE DECODE "KRN",19,10086,"U") SCANMANAGER 1.0.0.0 "KRN",8994,1767,-1) 0^5 "KRN",8994,1767,0) TMG DOWNLOAD FILE^DOWNLOAD^TMGRPC1^4^P^^^1^.5 "KRN",8994,1767,1,0) ^^5^5^3050926^^ "KRN",8994,1767,1,1,0) This RPC will be for requesting a file from the server. "KRN",8994,1767,1,2,0) "KRN",8994,1767,1,3,0) By tunneling file transfer through the RPCBroker, it allows the server to "KRN",8994,1767,1,4,0) control access to files. And it negates need to set up an independant ftp "KRN",8994,1767,1,5,0) or filesystem server etc. "KRN",8994,1767,2,0) ^8994.02A^2^2 "KRN",8994,1767,2,1,0) FNAME^1^256^1^2 "KRN",8994,1767,2,1,1,0) ^^8^8^3050902^^ "KRN",8994,1767,2,1,1,1,0) This should be the filename of the requested file. This needs to be in a "KRN",8994,1767,2,1,1,2,0) format that can be passed to the host filesystem. "KRN",8994,1767,2,1,1,3,0) "KRN",8994,1767,2,1,1,4,0) This should be only the filename (not including the path) "KRN",8994,1767,2,1,1,5,0) "KRN",8994,1767,2,1,1,6,0) For my implementation, I am planning for the server to pass a list of "KRN",8994,1767,2,1,1,7,0) available files to the client. The client can then pass these back one at "KRN",8994,1767,2,1,1,8,0) a time to get the actual file. "KRN",8994,1767,2,2,0) FPATH^1^256^1^1 "KRN",8994,1767,2,2,1,0) ^^2^2^3050926^^ "KRN",8994,1767,2,2,1,1,0) This should be the path up to, but not including, the filename, of the file "KRN",8994,1767,2,2,1,2,0) to be requested from the server. "KRN",8994,1767,2,"B","FNAME",1) "KRN",8994,1767,2,"B","FPATH",2) "KRN",8994,1767,2,"PARAMSEQ",1,2) "KRN",8994,1767,2,"PARAMSEQ",2,1) "KRN",8994,1767,3,0) ^8994.03^19^19^3050926^^^ "KRN",8994,1767,3,1,0) The return value will be an array, with each node containing 512 "KRN",8994,1767,3,2,0) bytes, encoded for ASCII transfer with a Base64 formula (an improvement "KRN",8994,1767,3,3,0) on UUENCODE functions) "KRN",8994,1767,3,4,0) "KRN",8994,1767,3,5,0) GREF(0)=1 <---- 1=valid 0=invalid (failure of load) "KRN",8994,1767,3,6,0) GREF(1)=";lakjsdasvoin;lkj32409u234,mnsdfoi239483....." "KRN",8994,1767,3,7,0) GREF(2)="987sdf,n09xc,/knm6flkhdgjkhsdo4ioidk,sdf....." "KRN",8994,1767,3,8,0) GREF(3)="asdoi,xmnsdkh98xd,.m3ddbdsgkhsdf=cxjkdgm ....." "KRN",8994,1767,3,9,0) ... "KRN",8994,1767,3,10,0) "KRN",8994,1767,3,11,0) Note: Here I am showing random ascii characters. But in actuality, each "KRN",8994,1767,3,12,0) position will hold only those characters used in the Base64 method. "KRN",8994,1767,3,13,0) "KRN",8994,1767,3,14,0) On the client RPCBroker end, the result will be stored in a TStringList, "KRN",8994,1767,3,15,0) with each line being stored in a separate index (i.e. Strings[i]) "KRN",8994,1767,3,16,0) "KRN",8994,1767,3,17,0) Notice that when saving on the client side, the zero node,GREF(0), is NOT "KRN",8994,1767,3,18,0) part of the file, and should be discarded or otherwise not included in the "KRN",8994,1767,3,19,0) save. "KRN",8994,1768,-1) 0^12 "KRN",8994,1768,0) TMG UPLOAD FILE^UPLOAD^TMGRPC1^1^P^^^1^.1 "KRN",8994,1768,1,0) ^8994.01^2^2^3050928^^^ "KRN",8994,1768,1,1,0) This function will accept a binary file uploaded to the server, encoded in a "KRN",8994,1768,1,2,0) BASE64 ascii encoding format. "KRN",8994,1768,2,0) ^8994.02A^4^4 "KRN",8994,1768,2,1,0) FPATH^1^1024^1^1 "KRN",8994,1768,2,1,1,0) ^8994.021^14^14^3050928^^^^ "KRN",8994,1768,2,1,1,1,0) This is the path to store the file into. Note that the server will store "KRN",8994,1768,2,1,1,2,0) all files relative to an internal (hidden) directory. Thus if the storage "KRN",8994,1768,2,1,1,3,0) location is specified to be: "KRN",8994,1768,2,1,1,4,0) /ZZ1/002/IMAGE0001.JPG "KRN",8994,1768,2,1,1,5,0) "KRN",8994,1768,2,1,1,6,0) then the actual storage location might actually be: "KRN",8994,1768,2,1,1,7,0) "KRN",8994,1768,2,1,1,8,0) /var/local/images/storage/ZZ1/002/IMAGE0001.JPG "KRN",8994,1768,2,1,1,9,0) "KRN",8994,1768,2,1,1,10,0) The internal (hidden) directory is stored in field #22700 (TMG PRIVATE "KRN",8994,1768,2,1,1,11,0) PHYSICAL REFERENCE) of file 2005.2 (NETWORK LOCATION) "KRN",8994,1768,2,1,1,12,0) "KRN",8994,1768,2,1,1,13,0) Which record of the NETWORK LOCATION file to use is specified as in the input "KRN",8994,1768,2,1,1,14,0) parameter LOCIEN for this RPC Call (TMG UPLOAD FILE) "KRN",8994,1768,2,2,0) FNAME^1^1024^1^2 "KRN",8994,1768,2,2,1,0) ^^1^1^3050928^^ "KRN",8994,1768,2,2,1,1,0) This is the name of the file to store. It should not include path elements. "KRN",8994,1768,2,3,0) LOCIEN^1^16^0^3 "KRN",8994,1768,2,3,1,0) ^^6^6^3050928^^ "KRN",8994,1768,2,3,1,1,0) This is the record number (IEN) from file 2005.2 (NETWORK LOCATION) that the "KRN",8994,1768,2,3,1,2,0) file will be uploaded to. "KRN",8994,1768,2,3,1,3,0) "KRN",8994,1768,2,3,1,4,0) This is required so that a relative root path can be obtained from custom "KRN",8994,1768,2,3,1,5,0) field 22700 (TMG PRIVATE PHYSICAL LOCATION). See also description of input "KRN",8994,1768,2,3,1,6,0) parameter FPATH. "KRN",8994,1768,2,4,0) ARRAY^2^^1^4 "KRN",8994,1768,2,4,1,0) ^^11^11^3050928^^ "KRN",8994,1768,2,4,1,1,0) This will be the array to store the uploaded data into. "KRN",8994,1768,2,4,1,2,0) For example: "KRN",8994,1768,2,4,1,3,0) "KRN",8994,1768,2,4,1,4,0) ARRAY(0)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,5,0) ARRAY(0)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,6,0) ARRAY(1)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,7,0) ARRAY(2)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,8,0) ARRAY(3)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,9,0) ARRAY(4)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,10,0) ARRAY(5)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,4,1,11,0) ARRAY(6)= "(ascii encoude data in BASE64 format)" "KRN",8994,1768,2,"B","ARRAY",4) "KRN",8994,1768,2,"B","FNAME",2) "KRN",8994,1768,2,"B","FPATH",1) "KRN",8994,1768,2,"B","LOCIEN",3) "KRN",8994,1768,2,"PARAMSEQ",1,1) "KRN",8994,1768,2,"PARAMSEQ",2,2) "KRN",8994,1768,2,"PARAMSEQ",3,3) "KRN",8994,1768,2,"PARAMSEQ",4,4) "KRN",8994,1769,-1) 0^9 "KRN",8994,1769,0) TMG GET IMAGE LONG DESCRIPTION^GETLONG^TMGRPC1^4^P^^^1^1 "KRN",8994,1769,1,0) ^8994.01^2^2^3051016^^^ "KRN",8994,1769,1,1,0) This RPC will return the LONG DESCRIPTION (field 11) from specified record "KRN",8994,1769,1,2,0) in IMAGE file. "KRN",8994,1769,2,0) ^8994.02A^1^1 "KRN",8994,1769,2,1,0) IMAGEIEN^1^6^1^1 "KRN",8994,1769,2,1,1,0) ^8994.021^3^3^3051016^^^ "KRN",8994,1769,2,1,1,1,0) This value should be the IEN for the record in question, from file IMAGE "KRN",8994,1769,2,1,1,2,0) (file 2005). If IEN references a non-existing record, then empty result "KRN",8994,1769,2,1,1,3,0) will be returned. "KRN",8994,1769,2,"B","IMAGEIEN",1) "KRN",8994,1769,2,"PARAMSEQ",1,1) "KRN",8994,1769,3,0) ^^18^18^3051016^^ "KRN",8994,1769,3,1,0) This will return the results from the WP field, number 11 (LONG DESCRIPTION) "KRN",8994,1769,3,2,0) from the IMAGE file (2005) "KRN",8994,1769,3,3,0) "KRN",8994,1769,3,4,0) The return format will be as follows: "KRN",8994,1769,3,5,0) Array(0)=WP header line. Format is: ^^MaxLine^MaxLine^FMDate/TimeStamp "KRN",8994,1769,3,6,0) Array(1)=WP Line 1 "KRN",8994,1769,3,7,0) Array(2)=WP LIne 2 "KRN",8994,1769,3,8,0) ... etc. "KRN",8994,1769,3,9,0) "KRN",8994,1769,3,10,0) In client, these results could be accesible as follows: "KRN",8994,1769,3,11,0) "KRN",8994,1769,3,12,0) RPCBroker.Results[0]=WP Header Line "KRN",8994,1769,3,13,0) RPCBroker.Results[1]=WP Line 1 "KRN",8994,1769,3,14,0) RPCBroker.Results[2]=WP Line 2 "KRN",8994,1769,3,15,0) ... etc. "KRN",8994,1769,3,16,0) "KRN",8994,1769,3,17,0) If there is no value for field 11, result will be: "KRN",8994,1769,3,18,0) Array(0)="" "KRN",8994,1770,-1) 0^8 "KRN",8994,1770,0) TMG GET DFN^GETDFN^TMGRPC1^1^P^0^^1^1 "KRN",8994,1770,1,0) ^8994.01^2^2^3070725^^^^ "KRN",8994,1770,1,1,0) Used by CPRS customization for looking up a patient, and returning "KRN",8994,1770,1,2,0) the DFN (IEN in PATIENT file). "KRN",8994,1770,2,0) ^8994.02A^9^9 "KRN",8994,1770,2,1,0) RECNUM^1^64^0^1 "KRN",8994,1770,2,1,1,0) ^^2^2^3070725^^ "KRN",8994,1770,2,1,1,1,0) This parameter is for a chart or account number in an independent PMS. "KRN",8994,1770,2,1,1,2,0) Optional parameter. "KRN",8994,1770,2,2,0) PMS^1^16^0^2 "KRN",8994,1770,2,2,1,0) ^^12^12^3070725^^ "KRN",8994,1770,2,2,1,1,0) This is a number indicating which PMS that the RECNUM parameter "KRN",8994,1770,2,2,1,2,0) refers to. "KRN",8994,1770,2,2,1,3,0) "KRN",8994,1770,2,2,1,4,0) Example inputs: "KRN",8994,1770,2,2,1,5,0) 1 <-- for TMG MEDIC ACCOUNT NUMBER "KRN",8994,1770,2,2,1,6,0) 2 <-- for SEQUEL ACCOUNT NUMBER "KRN",8994,1770,2,2,1,7,0) "KRN",8994,1770,2,2,1,8,0) Note: This is an 'optional' parameter, BUT if RECNUM parameter is supplied, "KRN",8994,1770,2,2,1,9,0) then this parameter must also be supplied, otherwise RecNum will be ignored. "KRN",8994,1770,2,2,1,10,0) "KRN",8994,1770,2,2,1,11,0) Note: Dealing with these numbers is hard coded into the RPC server code, "KRN",8994,1770,2,2,1,12,0) and adding additional PMS support must be coded into the calls. "KRN",8994,1770,2,3,0) LNAME^1^64^^3 "KRN",8994,1770,2,3,1,0) ^^1^1^3070725^^ "KRN",8994,1770,2,3,1,1,0) This is the patient's last name (i.e. family name) "KRN",8994,1770,2,4,0) FNAME^1^64^^4 "KRN",8994,1770,2,4,1,0) ^^1^1^3070725^^ "KRN",8994,1770,2,4,1,1,0) This is the patient's first (given) name. "KRN",8994,1770,2,5,0) MNAME^1^64^^5 "KRN",8994,1770,2,5,1,0) ^^1^1^3070725^^ "KRN",8994,1770,2,5,1,1,0) This is the patient's middle name, OR middle initial. "KRN",8994,1770,2,6,0) DOB^1^32^^6 "KRN",8994,1770,2,6,1,0) ^^2^2^3070725^^ "KRN",8994,1770,2,6,1,1,0) This is the patient's date of birth, in EXTERNAL (i.e. "KRN",8994,1770,2,6,1,2,0) user supplied) format. "KRN",8994,1770,2,7,0) SEX^1^1^^7 "KRN",8994,1770,2,7,1,0) ^^3^3^3070725^^ "KRN",8994,1770,2,7,1,1,0) This is the patient's sex. Should be: "KRN",8994,1770,2,7,1,2,0) M for male "KRN",8994,1770,2,7,1,3,0) F for female "KRN",8994,1770,2,8,0) SSNUM^1^9^^8 "KRN",8994,1770,2,8,1,0) ^^6^6^3070725^^ "KRN",8994,1770,2,8,1,1,0) This is the patient's Social Security Number (SS Num) "KRN",8994,1770,2,8,1,2,0) Should NOT include dashes. "KRN",8994,1770,2,8,1,3,0) "KRN",8994,1770,2,8,1,4,0) Example: "KRN",8994,1770,2,8,1,5,0) 123456789 "KRN",8994,1770,2,8,1,6,0) NOT: 123-45-6789 "KRN",8994,1770,2,9,0) AUTOADD^1^1^^9 "KRN",8994,1770,2,9,1,0) ^^6^6^3070725^^ "KRN",8994,1770,2,9,1,1,0) If this parameter value is 1, then patient will be automatically "KRN",8994,1770,2,9,1,2,0) registered if they are not found during lookup. "KRN",8994,1770,2,9,1,3,0) "KRN",8994,1770,2,9,1,4,0) Examples: "KRN",8994,1770,2,9,1,5,0) 1 <-- auto add if not found "KRN",8994,1770,2,9,1,6,0) 0 <-- don't auto add (default value) "KRN",8994,1770,2,"B","AUTOADD",9) "KRN",8994,1770,2,"B","DOB",6) "KRN",8994,1770,2,"B","FNAME",4) "KRN",8994,1770,2,"B","LNAME",3) "KRN",8994,1770,2,"B","MNAME",5) "KRN",8994,1770,2,"B","PMS",2) "KRN",8994,1770,2,"B","RECNUM",1) "KRN",8994,1770,2,"B","SEX",7) "KRN",8994,1770,2,"B","SSNUM",8) "KRN",8994,1770,2,"PARAMSEQ",1,1) "KRN",8994,1770,2,"PARAMSEQ",2,2) "KRN",8994,1770,2,"PARAMSEQ",3,3) "KRN",8994,1770,2,"PARAMSEQ",4,4) "KRN",8994,1770,2,"PARAMSEQ",5,5) "KRN",8994,1770,2,"PARAMSEQ",6,6) "KRN",8994,1770,2,"PARAMSEQ",7,7) "KRN",8994,1770,2,"PARAMSEQ",8,8) "KRN",8994,1770,2,"PARAMSEQ",9,9) "KRN",8994,1770,3,0) ^8994.03^1^1^3070725^^^^ "KRN",8994,1770,3,1,0) This will return the DFN (IEN in PATIENT file), or -1 if not found or error. "KRN",8994,1771,-1) 0^7 "KRN",8994,1771,0) TMG GET BLANK TIU DOCUMENT^BLANKTIU^TMGRPC1^1^P^0^^1^1 "KRN",8994,1771,1,0) ^8994.01^3^3^3070725^^ "KRN",8994,1771,1,1,0) This RPC call will be used to create a new record in file 8925 (TIU DOCUMENT) "KRN",8994,1771,1,2,0) that can be used for other purposes. "KRN",8994,1771,1,3,0) Note: This will be an UNSIGNED document that will later need to be signed. "KRN",8994,1771,2,0) ^8994.02A^5^5 "KRN",8994,1771,2,1,0) DFN^1^16^1^1 "KRN",8994,1771,2,1,1,0) ^^2^2^3070725^^ "KRN",8994,1771,2,1,1,1,0) This is the IEN in the PATIENT file. I.e. the record number of the patient "KRN",8994,1771,2,1,1,2,0) for which the note is being created. "KRN",8994,1771,2,2,0) PERSON^1^64^1^2 "KRN",8994,1771,2,2,1,0) ^^1^1^3070725^^ "KRN",8994,1771,2,2,1,1,0) This is the name of the provider of record for the new document. "KRN",8994,1771,2,3,0) LOC^1^64^1^3 "KRN",8994,1771,2,3,1,0) ^^3^3^3070725^^ "KRN",8994,1771,2,3,1,1,0) This is the location for the new document. Note this location should be the "KRN",8994,1771,2,3,1,2,0) name of a location named in the HOSPITAL LOCATION file (#44). That is, the "KRN",8994,1771,2,3,1,3,0) .01 field name, or perhaps the abbreviation for the location if defined. "KRN",8994,1771,2,4,0) DOS^1^32^1^4 "KRN",8994,1771,2,4,1,0) ^^1^1^3070725^^ "KRN",8994,1771,2,4,1,1,0) This is the Date of Service for the new document. "KRN",8994,1771,2,5,0) TITLE^1^64^1^5 "KRN",8994,1771,2,5,1,0) ^^4^4^3070725^^ "KRN",8994,1771,2,5,1,1,0) This is the title for the new note. "KRN",8994,1771,2,5,1,2,0) Note: This must be a title as defined in file 8925.1 (TIU DOCUMENT DEFINITION). "KRN",8994,1771,2,5,1,3,0) That is to say, the name of the .01 field, or perhaps any abbreviation "KRN",8994,1771,2,5,1,4,0) if defined. "KRN",8994,1771,2,"B","DFN",1) "KRN",8994,1771,2,"B","DOS",4) "KRN",8994,1771,2,"B","LOC",3) "KRN",8994,1771,2,"B","PERSON",2) "KRN",8994,1771,2,"B","TITLE",5) "KRN",8994,1771,2,"PARAMSEQ",1,1) "KRN",8994,1771,2,"PARAMSEQ",2,2) "KRN",8994,1771,2,"PARAMSEQ",3,3) "KRN",8994,1771,2,"PARAMSEQ",4,4) "KRN",8994,1771,2,"PARAMSEQ",5,5) "KRN",8994,1771,3,0) ^^1^1^3070725^^ "KRN",8994,1771,3,1,0) Returns the IEN (record number) of a new, blank note in file 8925 "KRN",8994,1772,-1) 0^2 "KRN",8994,1772,0) TMG AUTOSIGN TIU DOCUMENT^AUTOSIGN^TMGRPC1^2^P^0^^1^1 "KRN",8994,1772,1,0) ^^2^2^3070730^^ "KRN",8994,1772,1,1,0) This will allow the auto-signing of a document. It is designed to automatically "KRN",8994,1772,1,2,0) complete documents that are added to VistA via scanning. "KRN",8994,1772,2,0) ^8994.02A^1^1 "KRN",8994,1772,2,1,0) DOCIEN^1^16^1^1 "KRN",8994,1772,2,1,1,0) ^^1^1^3070730^^ "KRN",8994,1772,2,1,1,1,0) This is the IEN (internal entry number) of the document to be signed. "KRN",8994,1772,2,"B","DOCIEN",1) "KRN",8994,1772,2,"PARAMSEQ",1,1) "KRN",8994,1772,3,0) ^^3^3^3070730^^ "KRN",8994,1772,3,1,0) Return value is an array. "KRN",8994,1772,3,2,0) Array(0)=1 if success, or -1 if failure. "KRN",8994,1772,3,3,0) Errors are returned in Array("DIERR") "KRN",8994,1773,-1) 0^10 "KRN",8994,1773,0) TMG GET PATIENT DEMOGRAPHICS^DFNINFO^TMGRPC1^2^P^^^1^1 "KRN",8994,1773,1,0) ^^2^2^3070923^^ "KRN",8994,1773,1,1,0) This RPC calls returns patient demographic info in a formatted array. "KRN",8994,1773,1,2,0) See description of return parameter for details. "KRN",8994,1773,2,0) ^8994.02A^1^1 "KRN",8994,1773,2,1,0) DFN^1^^1^1 "KRN",8994,1773,2,1,1,0) ^^2^2^3070923^^ "KRN",8994,1773,2,1,1,1,0) This is the IEN (internal entry number), aka record number, "KRN",8994,1773,2,1,1,2,0) of the patient to get the demographics for. "KRN",8994,1773,2,"B","DFN",1) "KRN",8994,1773,2,"PARAMSEQ",1,1) "KRN",8994,1773,3,0) ^^49^49^3070923^^ "KRN",8994,1773,3,1,0) ;" The results are in format: KeyName=Value, "KRN",8994,1773,3,2,0) ;" There is no set order these will appear. "KRN",8994,1773,3,3,0) ;" Here are the KeyName names that will be provided. "KRN",8994,1773,3,4,0) ;" If the record has no value, then value will be empty "KRN",8994,1773,3,5,0) ;" "KRN",8994,1773,3,6,0) ;" IEN=record# "KRN",8994,1773,3,7,0) ;" COMBINED_NAME= "KRN",8994,1773,3,8,0) ;" LNAME= "KRN",8994,1773,3,9,0) ;" FNAME= "KRN",8994,1773,3,10,0) ;" MNAME= "KRN",8994,1773,3,11,0) ;" PREFIX= "KRN",8994,1773,3,12,0) ;" SUFFIX= "KRN",8994,1773,3,13,0) ;" DEGREE "KRN",8994,1773,3,14,0) ;" DOB= "KRN",8994,1773,3,15,0) ;" SEX= "KRN",8994,1773,3,16,0) ;" SS_NUM= "KRN",8994,1773,3,17,0) ;" ADDRESS_LINE_1= "KRN",8994,1773,3,18,0) ;" ADDRESS_LINE_2= "KRN",8994,1773,3,19,0) ;" ADDRESS_LINE_3= "KRN",8994,1773,3,20,0) ;" CITY= "KRN",8994,1773,3,21,0) ;" STATE= "KRN",8994,1773,3,22,0) ;" ZIP4= "KRN",8994,1773,3,23,0) ;" BAD_ADDRESS= "KRN",8994,1773,3,24,0) ;" TEMP_ADDRESS_LINE_1= "KRN",8994,1773,3,25,0) ;" TEMP_ADDRESS_LINE_2= "KRN",8994,1773,3,26,0) ;" TEMP_ADDRESS_LINE_3= "KRN",8994,1773,3,27,0) ;" TEMP_CITY= "KRN",8994,1773,3,28,0) ;" TEMP_STATE= "KRN",8994,1773,3,29,0) ;" TEMP_ZIP4= "KRN",8994,1773,3,30,0) ;" TEMP_STARTING_DATE= "KRN",8994,1773,3,31,0) ;" TEMP_ENDING_DATE= "KRN",8994,1773,3,32,0) ;" TEMP_ADDRESS_ACTIVE= "KRN",8994,1773,3,33,0) ;" CONF_ADDRESS_LINE_1= "KRN",8994,1773,3,34,0) ;" CONF_ADDRESS_LINE_2= "KRN",8994,1773,3,35,0) ;" CONF_ADDRESS_LINE_3= "KRN",8994,1773,3,36,0) ;" CONF_CITY= "KRN",8994,1773,3,37,0) ;" CONF_STATE= "KRN",8994,1773,3,38,0) ;" CONF_ZIP4= "KRN",8994,1773,3,39,0) ;" CONF_STARTING_DATE= "KRN",8994,1773,3,40,0) ;" CONF_ENDING_DATE= "KRN",8994,1773,3,41,0) ;" CONF_ADDRESS_ACTIVE= "KRN",8994,1773,3,42,0) ;" PHONE_RESIDENCE= "KRN",8994,1773,3,43,0) ;" PHONE_WORK= "KRN",8994,1773,3,44,0) ;" PHONE_CELL= "KRN",8994,1773,3,45,0) ;" PHONE_TEMP= "KRN",8994,1773,3,46,0) "KRN",8994,1773,3,47,0) ;"Note, for the following, there may be multiple entries. # is record number "KRN",8994,1773,3,48,0) ;" ALIAS # NAME "KRN",8994,1773,3,49,0) ;" ALIAS # SSN "KRN",8994,1774,-1) 0^11 "KRN",8994,1774,0) TMG SET PATIENT DEMOGRAPHICS^STPTINFO^TMGRPC1^1^P^^^1^1 "KRN",8994,1774,1,0) ^8994.01^1^1^3070926^^^ "KRN",8994,1774,1,1,0) This RPC is for setting basic demographics info for a patient. "KRN",8994,1774,2,0) ^8994.02A^2^2 "KRN",8994,1774,2,1,0) DFN^1^^1^1 "KRN",8994,1774,2,1,1,0) ^^1^1^3070926^^ "KRN",8994,1774,2,1,1,1,0) This DFN value is the IEN (internal entry number) of the patient in the PATIENT file. "KRN",8994,1774,2,2,0) INFO^2^^1^2 "KRN",8994,1774,2,2,1,0) ^^47^47^3070926^^ "KRN",8994,1774,2,2,1,1,0) This will be the data to set for the specified patient. "KRN",8994,1774,2,2,1,2,0) Demographics are passed in a Key=Value format: "KRN",8994,1774,2,2,1,3,0) "KRN",8994,1774,2,2,1,4,0) Here are the KeyName names that will be provided. "KRN",8994,1774,2,2,1,5,0) There is no set order these will appear. "KRN",8994,1774,2,2,1,6,0) If the record has no value, then value will be empty "KRN",8994,1774,2,2,1,7,0) If a record should be deleted, its value will be @ "KRN",8994,1774,2,2,1,8,0) INFO("COMBINED_NAME")= "KRN",8994,1774,2,2,1,9,0) INFO("PREFIX")= "KRN",8994,1774,2,2,1,10,0) INFO("SUFFIX")= "KRN",8994,1774,2,2,1,11,0) INFO("DEGREE")= "KRN",8994,1774,2,2,1,12,0) INFO("DOB")= "KRN",8994,1774,2,2,1,13,0) INFO("SEX")= "KRN",8994,1774,2,2,1,14,0) INFO("SS_NUM")= "KRN",8994,1774,2,2,1,15,0) INFO("ADDRESS_LINE_1")= "KRN",8994,1774,2,2,1,16,0) INFO("ADDRESS_LINE_2")= "KRN",8994,1774,2,2,1,17,0) INFO("ADDRESS_LINE_3")= "KRN",8994,1774,2,2,1,18,0) INFO("CITY")= "KRN",8994,1774,2,2,1,19,0) INFO("STATE")= "KRN",8994,1774,2,2,1,20,0) INFO("ZIP4")= "KRN",8994,1774,2,2,1,21,0) INFO("BAD_ADDRESS")= "KRN",8994,1774,2,2,1,22,0) INFO("TEMP_ADDRESS_LINE_1")= "KRN",8994,1774,2,2,1,23,0) INFO("TEMP_ADDRESS_LINE_2")= "KRN",8994,1774,2,2,1,24,0) INFO("TEMP_ADDRESS_LINE_3")= "KRN",8994,1774,2,2,1,25,0) INFO("TEMP_CITY")= "KRN",8994,1774,2,2,1,26,0) INFO("TEMP_STATE")= "KRN",8994,1774,2,2,1,27,0) INFO("TEMP_ZIP4")= "KRN",8994,1774,2,2,1,28,0) INFO("TEMP_STARTING_DATE")= "KRN",8994,1774,2,2,1,29,0) INFO("TEMP_ENDING_DATE")= "KRN",8994,1774,2,2,1,30,0) INFO("TEMP_ADDRESS_ACTIVE")= "KRN",8994,1774,2,2,1,31,0) INFO("CONF_ADDRESS_LINE_1")= "KRN",8994,1774,2,2,1,32,0) INFO("CONF_ADDRESS_LINE_2")= "KRN",8994,1774,2,2,1,33,0) INFO("CONF_ADDRESS_LINE_3")= "KRN",8994,1774,2,2,1,34,0) INFO("CONF_CITY")= "KRN",8994,1774,2,2,1,35,0) INFO("CONF_STATE")= "KRN",8994,1774,2,2,1,36,0) INFO("CONF_ZIP4")= "KRN",8994,1774,2,2,1,37,0) INFO("CONF_STARTING_DATE")= "KRN",8994,1774,2,2,1,38,0) INFO("CONF_ENDING_DATE")= "KRN",8994,1774,2,2,1,39,0) INFO("CONF_ADDRESS_ACTIVE")= "KRN",8994,1774,2,2,1,40,0) INFO("PHONE_RESIDENCE")= "KRN",8994,1774,2,2,1,41,0) INFO("PHONE_WORK")= "KRN",8994,1774,2,2,1,42,0) INFO("PHONE_CELL")= "KRN",8994,1774,2,2,1,43,0) INFO("PHONE_TEMP")= "KRN",8994,1774,2,2,1,44,0) Note, for the following, there may be multiple entries. # is record number "KRN",8994,1774,2,2,1,45,0) If a record should be added, it will be marked +1, +2 etc. "KRN",8994,1774,2,2,1,46,0) INFO("ALIAS # NAME")= "KRN",8994,1774,2,2,1,47,0) INFO("ALIAS # SSN")= "KRN",8994,1774,2,"B","DFN",1) "KRN",8994,1774,2,"B","INFO",2) "KRN",8994,1774,2,"PARAMSEQ",1,1) "KRN",8994,1774,2,"PARAMSEQ",2,2) "KRN",8994,1774,3,0) ^^4^4^3070926^^ "KRN",8994,1774,3,1,0) Return value will be: "KRN",8994,1774,3,2,0) 1 for success, or "KRN",8994,1774,3,3,0) -1^Message for failure "KRN",8994,1774,3,4,0) "KRN",8994,1777,-1) 0^1 "KRN",8994,1777,0) TMG ADD PATIENT^PTADD^TMGRPC1^1^^^^1 "KRN",8994,1777,1,0) ^8994.01^1^1^3071010^^^^ "KRN",8994,1777,1,1,0) This RPC is to add a patient. "KRN",8994,1777,2,0) ^8994.02A^1^1 "KRN",8994,1777,2,1,0) INFO^2^^1^1 "KRN",8994,1777,2,1,1,0) ^8994.021^12^12^3071010^^^^ "KRN",8994,1777,2,1,1,1,0) ;" INFO: Format as follows: "KRN",8994,1777,2,1,1,2,0) ;" The results are in format: INFO("KeyName")=Value, "KRN",8994,1777,2,1,1,3,0) ;" There is no set order these will appear. "KRN",8994,1777,2,1,1,4,0) ;" Here are the KeyName names that will be provided. "KRN",8994,1777,2,1,1,5,0) ;" If the record has no value, then value will be empty "KRN",8994,1777,2,1,1,6,0) ;" If a record should be deleted, its value will be @ "KRN",8994,1777,2,1,1,7,0) ;" INFO("COMBINED_NAME")= "KRN",8994,1777,2,1,1,8,0) ;" INFO("DOB")= "KRN",8994,1777,2,1,1,9,0) ;" INFO("SEX")= "KRN",8994,1777,2,1,1,10,0) ;" INFO("SS_NUM")= "KRN",8994,1777,2,1,1,11,0) ;" INFO("Veteran")= "KRN",8994,1777,2,1,1,12,0) ;" INFO("PtType")= "KRN",8994,1777,2,"B","INFO",1) "KRN",8994,1777,2,"PARAMSEQ",1,1) "KRN",8994,1777,3,0) ^8994.03^3^3^3071010^^^ "KRN",8994,1777,3,1,0) ;"Results: Results passed back in RESULT string: "KRN",8994,1777,3,2,0) ;" 1^DFN = success "KRN",8994,1777,3,3,0) ;" -1^Message = failure "KRN",8994,1778,-1) 0^4 "KRN",8994,1778,0) TMG BARCODE ENCODE^GETBARCD^TMGRPC1^4^P^^^1^1 "KRN",8994,1778,1,0) ^^17^17^3071227^^ "KRN",8994,1778,1,1,0) This RPC will be for requesting a barcode from the server. "KRN",8994,1778,1,2,0) This will return an image containing a DataMatrix 2D "KRN",8994,1778,1,3,0) barcode. "KRN",8994,1778,1,4,0) "KRN",8994,1778,1,5,0) It is dependent on a command to be installed on the "KRN",8994,1778,1,6,0) linux host server: libdtmx which may be installed "KRN",8994,1778,1,7,0) from www.sourceforge.org. See comments in TMGBARC.m for "KRN",8994,1778,1,8,0) details. "KRN",8994,1778,1,9,0) "KRN",8994,1778,1,10,0) If an image type of other than .png is desired then this "KRN",8994,1778,1,11,0) is dependent on "convert" utility being installed on the "KRN",8994,1778,1,12,0) linux host server. This is part of the linux ImageMagick "KRN",8994,1778,1,13,0) package. "KRN",8994,1778,1,14,0) "KRN",8994,1778,1,15,0) It will return the barcode in ascii armour encoding, which "KRN",8994,1778,1,16,0) must be decoded on the client side. This functionality is "KRN",8994,1778,1,17,0) the same as used for TMG UPLOAD and TMG DOWNLOAD of images. "KRN",8994,1778,2,0) ^8994.02A^2^2 "KRN",8994,1778,2,1,0) MESSAGE^1^1024^1^1 "KRN",8994,1778,2,1,1,0) ^^12^12^3071221^^ "KRN",8994,1778,2,1,1,1,0) This should be the message / text / numbers to be "KRN",8994,1778,2,1,1,2,0) encoded in the barcode. "KRN",8994,1778,2,1,1,3,0) "KRN",8994,1778,2,1,1,4,0) I have not explored the limits of what type of chars "KRN",8994,1778,2,1,1,5,0) can be stored in the barcode. I think that it does "KRN",8994,1778,2,1,1,6,0) NOT allow extended chars or control chars. "KRN",8994,1778,2,1,1,7,0) "KRN",8994,1778,2,1,1,8,0) I am also not sure of the allowed length. This can "KRN",8994,1778,2,1,1,9,0) be explored more later. With some bar code creators, "KRN",8994,1778,2,1,1,10,0) if the length exceeds the allowed chars for one 2D "KRN",8994,1778,2,1,1,11,0) square, then a second square is created beside the first "KRN",8994,1778,2,1,1,12,0) for the extra characters. "KRN",8994,1778,2,2,0) OPTION^2^^0^2 "KRN",8994,1778,2,2,1,0) ^^15^15^3071227^^ "KRN",8994,1778,2,2,1,1,0) This array may contain options: "KRN",8994,1778,2,2,1,2,0) "KRN",8994,1778,2,2,1,3,0) OPTION("IMAGE TYPE")=image type. "KRN",8994,1778,2,2,1,4,0) "KRN",8994,1778,2,2,1,5,0) Example "KRN",8994,1778,2,2,1,6,0) OPTION("IMAGE TYPE")="jpg" <-- image returned in jpg format "KRN",8994,1778,2,2,1,7,0) or "KRN",8994,1778,2,2,1,8,0) OPTION("IMAGE TYPE")="tiff" <-- image returned in tiff format "KRN",8994,1778,2,2,1,9,0) "KRN",8994,1778,2,2,1,10,0) Specified image type is NOT case sensitive. "KRN",8994,1778,2,2,1,11,0) "KRN",8994,1778,2,2,1,12,0) Allowed image types is determined by ImageMagick utility "KRN",8994,1778,2,2,1,13,0) 'convert' installed on host linux system. "KRN",8994,1778,2,2,1,14,0) "KRN",8994,1778,2,2,1,15,0) "KRN",8994,1778,2,"B","MESSAGE",1) "KRN",8994,1778,2,"B","OPTION",2) "KRN",8994,1778,2,"PARAMSEQ",1,1) "KRN",8994,1778,2,"PARAMSEQ",2,2) "KRN",8994,1778,3,0) ^^23^23^3071227^^ "KRN",8994,1778,3,1,0) By default, the returned image is the created barcode image in .png format. "KRN",8994,1778,3,2,0) See OPTION parameter regarding specifying other image formats. "KRN",8994,1778,3,3,0) "KRN",8994,1778,3,4,0) Regarding the data transfer itself: "KRN",8994,1778,3,5,0) The return value will be an array, with each node containing 512 "KRN",8994,1778,3,6,0) bytes, encoded for ASCII transfer with a Base64 formula (an improvement "KRN",8994,1778,3,7,0) on UUENCODE functions) "KRN",8994,1778,3,8,0) "KRN",8994,1778,3,9,0) GREF(0)=1 <---- 1=valid 0=invalid (failure of load) "KRN",8994,1778,3,10,0) GREF(1)=";lakjsdasvoin;lkj32409u234,mnsdfoi239483....." "KRN",8994,1778,3,11,0) GREF(2)="987sdf,n09xc,/knm6flkhdgjkhsdo4ioidk,sdf....." "KRN",8994,1778,3,12,0) GREF(3)="asdoi,xmnsdkh98xd,.m3ddbdsgkhsdf=cxjkdgm ....." "KRN",8994,1778,3,13,0) ... "KRN",8994,1778,3,14,0) "KRN",8994,1778,3,15,0) Note: Here I am showing random ascii characters. But in actuality, each "KRN",8994,1778,3,16,0) position will hold only those characters used in the Base64 method. "KRN",8994,1778,3,17,0) "KRN",8994,1778,3,18,0) On the client RPCBroker end, the result will be stored in a TStringList, "KRN",8994,1778,3,19,0) with each line being stored in a separate index (i.e. Strings[i]) "KRN",8994,1778,3,20,0) "KRN",8994,1778,3,21,0) Notice that when saving on the client side, the zero node,GREF(0), is NOT "KRN",8994,1778,3,22,0) part of the file, and should be discarded or otherwise not included in the "KRN",8994,1778,3,23,0) save. "KRN",8994,1779,-1) 0^3 "KRN",8994,1779,0) TMG BARCODE DECODE^DECODEBC^TMGRPC1^1^^^^1^1 "KRN",8994,1779,1,0) ^8994.01^5^5^3080102^^^^ "KRN",8994,1779,1,1,0) This function will return the text encoded inside "KRN",8994,1779,1,2,0) barcode stored on an image that is uploaded to "KRN",8994,1779,1,3,0) function. "KRN",8994,1779,1,4,0) "KRN",8994,1779,1,5,0) Barcode must be in DataMatrix format. "KRN",8994,1779,2,0) ^8994.02A^2^2 "KRN",8994,1779,2,1,0) ARRAY^2^^1^1 "KRN",8994,1779,2,1,1,0) ^^21^21^3071227^^ "KRN",8994,1779,2,1,1,1,0) This will be used for uploading the image that contains "KRN",8994,1779,2,1,1,2,0) the barcode for decoding. "KRN",8994,1779,2,1,1,3,0) "KRN",8994,1779,2,1,1,4,0) Default format for Image is a .png format. See OPTION "KRN",8994,1779,2,1,1,5,0) parameter for specifying Image to be in another format. "KRN",8994,1779,2,1,1,6,0) "KRN",8994,1779,2,1,1,7,0) Barcode should be a DataMatrix barcode. "KRN",8994,1779,2,1,1,8,0) "KRN",8994,1779,2,1,1,9,0) It is OK for the image to NOT contain a barcode. This "KRN",8994,1779,2,1,1,10,0) will cause a null value to be returned. "KRN",8994,1779,2,1,1,11,0) "KRN",8994,1779,2,1,1,12,0) Array Format: "KRN",8994,1779,2,1,1,13,0) For example: "KRN",8994,1779,2,1,1,14,0) ARRAY(0)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,15,0) ARRAY(0)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,16,0) ARRAY(1)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,17,0) ARRAY(2)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,18,0) ARRAY(3)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,19,0) ARRAY(4)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,20,0) ARRAY(5)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,1,1,21,0) ARRAY(6)= "(ascii encoude data in BASE64 format)" "KRN",8994,1779,2,2,0) IMGTYPE^1^^1^2 "KRN",8994,1779,2,2,1,0) ^^10^10^3080102^^ "KRN",8994,1779,2,2,1,1,0) This should be the type of the image held in ARRAY "KRN",8994,1779,2,2,1,2,0) "KRN",8994,1779,2,2,1,3,0) e.g. "jpg", or "JPG", or "tif" etc. "KRN",8994,1779,2,2,1,4,0) "KRN",8994,1779,2,2,1,5,0) NOTE: do not include the "." i.e. use "jpg", NOT ".jpg" "KRN",8994,1779,2,2,1,6,0) "KRN",8994,1779,2,2,1,7,0) Specified image type is NOT case sensitive. "KRN",8994,1779,2,2,1,8,0) "KRN",8994,1779,2,2,1,9,0) Allowed image types is determined by ImageMagick utility "KRN",8994,1779,2,2,1,10,0) 'convert' installed on host linux system. "KRN",8994,1779,2,"B","ARRAY",1) "KRN",8994,1779,2,"B","IMGTYPE",2) "KRN",8994,1779,2,"PARAMSEQ",1,1) "KRN",8994,1779,2,"PARAMSEQ",2,2) "KRN",8994,1779,3,0) ^8994.03^4^4^3080102^^^^ "KRN",8994,1779,3,1,0) Value to be returned will be: "KRN",8994,1779,3,2,0) "KRN",8994,1779,3,3,0) 1^Decoded Message "KRN",8994,1779,3,4,0) 0^Failure Message "KRN",8994,1780,-1) 0^6 "KRN",8994,1780,0) TMG DOWNLOAD FILE DROPBOX^DOWNDROP^TMGRPC1^1^^^^^1 "KRN",8994,1780,1,0) ^8994.01^3^3^3080131^^^ "KRN",8994,1780,1,1,0) This will cause a file to be transferred from the server's "KRN",8994,1780,1,2,0) private file storage location into the drop box location. "KRN",8994,1780,1,3,0) "KRN",8994,1780,2,0) ^8994.02A^3^3 "KRN",8994,1780,2,1,0) FPATH^1^128^1^1 "KRN",8994,1780,2,1,1,0) ^^26^26^3080131^^ "KRN",8994,1780,2,1,1,1,0) The file path up to, but not including, the filename. This "KRN",8994,1780,2,1,1,2,0) is the path that the file is stored at on the server, relative "KRN",8994,1780,2,1,1,3,0) to a private server path. "KRN",8994,1780,2,1,1,4,0) "KRN",8994,1780,2,1,1,5,0) It is NOT the location of the dropbox path. (That is stored in "KRN",8994,1780,2,1,1,6,0) field 22702 in file 2005.2) "KRN",8994,1780,2,1,1,7,0) "KRN",8994,1780,2,1,1,8,0) For security reasons, all path requests will be considered relative to a root path. "KRN",8994,1780,2,1,1,9,0) e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "KRN",8994,1780,2,1,1,10,0) /var/local/Dir1/Dir2/download/SomeFile.jpg "KRN",8994,1780,2,1,1,11,0) "KRN",8994,1780,2,1,1,12,0) This root path is found in custom field 22701 in file 2005.2 "KRN",8994,1780,2,1,1,13,0) Note Also: dropbox location is obtained from custom field 22702 in file 2005.2 "KRN",8994,1780,2,1,1,14,0) "KRN",8994,1780,2,1,1,15,0) So for input: "KRN",8994,1780,2,1,1,16,0) FPATH = /download/ "KRN",8994,1780,2,1,1,17,0) FNAME = SomeFile.jpg "KRN",8994,1780,2,1,1,18,0) "KRN",8994,1780,2,1,1,19,0) And configurations: "KRN",8994,1780,2,1,1,20,0) field 22701 = /var/local/Dir1/Dir2 "KRN",8994,1780,2,1,1,21,0) field 22702 = /mnt/WinServer/DropBox/ "KRN",8994,1780,2,1,1,22,0) "KRN",8994,1780,2,1,1,23,0) Then file: "KRN",8994,1780,2,1,1,24,0) /var/local/Dir1/dir2/download/SomeFile.jpg "KRN",8994,1780,2,1,1,25,0) will be moved to "KRN",8994,1780,2,1,1,26,0) /mnt/WinServer/DropBox/SomeFile.jpg "KRN",8994,1780,2,2,0) FNAME^1^128^1^2 "KRN",8994,1780,2,2,1,0) ^8994.021^3^3^3080131^^^ "KRN",8994,1780,2,2,1,1,0) This is the filename to be transferred, without any path "KRN",8994,1780,2,2,1,2,0) specifications. "KRN",8994,1780,2,2,1,3,0) See help for FNAME parameter for more details. "KRN",8994,1780,2,3,0) LOCIEN^1^16^0^3 "KRN",8994,1780,2,3,1,0) ^8994.021^13^13^3080131^^^ "KRN",8994,1780,2,3,1,1,0) [optional] -- "KRN",8994,1780,2,3,1,2,0) "KRN",8994,1780,2,3,1,3,0) This is the IEN from file 2005.2 (network location) to obtain "KRN",8994,1780,2,3,1,4,0) folder path and drive information from. "KRN",8994,1780,2,3,1,5,0) "KRN",8994,1780,2,3,1,6,0) Default value is 1 "KRN",8994,1780,2,3,1,7,0) "KRN",8994,1780,2,3,1,8,0) Note: For security reasons, all path requests will be considered relative to a root path. "KRN",8994,1780,2,3,1,9,0) e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "KRN",8994,1780,2,3,1,10,0) /var/local/Dir1/Dir2/download/SomeFile.jpg "KRN",8994,1780,2,3,1,11,0) This root path is found in custom field 22701 in file 2005.2 "KRN",8994,1780,2,3,1,12,0) Also: dropbox location is obtained from custom field 22702 in file 2005.2 "KRN",8994,1780,2,3,1,13,0) "KRN",8994,1780,2,"B","FNAME",2) "KRN",8994,1780,2,"B","FPATH",1) "KRN",8994,1780,2,"B","LOCIEN",3) "KRN",8994,1780,2,"PARAMSEQ",1,1) "KRN",8994,1780,2,"PARAMSEQ",2,2) "KRN",8994,1780,2,"PARAMSEQ",3,3) "KRN",8994,1780,3,0) ^8994.03^5^5^3080131^^^^ "KRN",8994,1780,3,1,0) Returns: "KRN",8994,1780,3,2,0) 1^Successful Download <-- file is ready in dropbox "KRN",8994,1780,3,3,0) or "KRN",8994,1780,3,4,0) 0^Error message "KRN",8994,1780,3,5,0) "KRN",8994,1781,-1) 0^13 "KRN",8994,1781,0) TMG UPLOAD FILE DROPBOX^UPLDDROP^TMGRPC1^1^^^^^1 "KRN",8994,1781,1,0) ^8994.01^3^3^3080131^^^ "KRN",8994,1781,1,1,0) This will cause a file to be transferred from the drop box "KRN",8994,1781,1,2,0) location into the server's private file storage location. "KRN",8994,1781,1,3,0) "KRN",8994,1781,2,0) ^8994.02A^3^3 "KRN",8994,1781,2,1,0) FPATH^1^128^1^1 "KRN",8994,1781,2,1,1,0) ^^29^29^3080131^^ "KRN",8994,1781,2,1,1,1,0) The file path up to, but not including, the filename. "KRN",8994,1781,2,1,1,2,0) "KRN",8994,1781,2,1,1,3,0) This is the path that the server is to store the file in, "KRN",8994,1781,2,1,1,4,0) relative to a private server path. "KRN",8994,1781,2,1,1,5,0) It is NOT the location of the dropbox path. (That is stored in "KRN",8994,1781,2,1,1,6,0) field 22702 in file 2005.2) "KRN",8994,1781,2,1,1,7,0) "KRN",8994,1781,2,1,1,8,0) For security reasons, all path requests will be considered "KRN",8994,1781,2,1,1,9,0) relative to a root path. "KRN",8994,1781,2,1,1,10,0) e.g. if user asks to store at /download/SomeFile.jpg, this "KRN",8994,1781,2,1,1,11,0) function will store the file at: "KRN",8994,1781,2,1,1,12,0) /var/local/Dir1/Dir2/download/SomeFile.jpg "KRN",8994,1781,2,1,1,13,0) "KRN",8994,1781,2,1,1,14,0) This root path is found in custom field 22701 in file 2005.2 "KRN",8994,1781,2,1,1,15,0) Note Also: dropbox location is obtained from custom field 22702 in file 2005.2 "KRN",8994,1781,2,1,1,16,0) "KRN",8994,1781,2,1,1,17,0) So for input: "KRN",8994,1781,2,1,1,18,0) FPATH = /download/ "KRN",8994,1781,2,1,1,19,0) FNAME = SomeFile.jpg "KRN",8994,1781,2,1,1,20,0) "KRN",8994,1781,2,1,1,21,0) And configurations: "KRN",8994,1781,2,1,1,22,0) field 22701 = /var/local/Dir1/Dir2 "KRN",8994,1781,2,1,1,23,0) field 22702 = /mnt/WinServer/DropBox/ "KRN",8994,1781,2,1,1,24,0) "KRN",8994,1781,2,1,1,25,0) "KRN",8994,1781,2,1,1,26,0) Then file: "KRN",8994,1781,2,1,1,27,0) /mnt/WinServer/DropBox/SomeFile.jpg <-- the drop box "KRN",8994,1781,2,1,1,28,0) will be moved to "KRN",8994,1781,2,1,1,29,0) /var/local/Dir1/dir2/download/SomeFile.jpg <--- the private store location "KRN",8994,1781,2,2,0) FNAME^1^128^1^2 "KRN",8994,1781,2,2,1,0) ^^4^4^3080131^^ "KRN",8994,1781,2,2,1,1,0) This is the filename to be transferred, without any path "KRN",8994,1781,2,2,1,2,0) specifications. "KRN",8994,1781,2,2,1,3,0) "KRN",8994,1781,2,2,1,4,0) See help for FNAME parameter for more details. "KRN",8994,1781,2,3,0) LOCIEN^1^16^0^3 "KRN",8994,1781,2,3,1,0) ^8994.021^12^12^3080131^^^ "KRN",8994,1781,2,3,1,1,0) [optional] -- "KRN",8994,1781,2,3,1,2,0) "KRN",8994,1781,2,3,1,3,0) This is the IEN from file 2005.2 (network location) to obtain "KRN",8994,1781,2,3,1,4,0) folder path and drive information from. "KRN",8994,1781,2,3,1,5,0) "KRN",8994,1781,2,3,1,6,0) Default value is 1 "KRN",8994,1781,2,3,1,7,0) "KRN",8994,1781,2,3,1,8,0) Note: For security reasons, all path requests will be considered relative to a root path. "KRN",8994,1781,2,3,1,9,0) e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "KRN",8994,1781,2,3,1,10,0) /var/local/Dir1/Dir2/download/SomeFile.jpg "KRN",8994,1781,2,3,1,11,0) This root path is found in custom field 22701 in file 2005.2 "KRN",8994,1781,2,3,1,12,0) Also: dropbox location is obtained from custom field 22702 in file 2005.2 "KRN",8994,1781,2,"B","FNAME",2) "KRN",8994,1781,2,"B","FPATH",1) "KRN",8994,1781,2,"B","LOCIEN",3) "KRN",8994,1781,2,"PARAMSEQ",1,1) "KRN",8994,1781,2,"PARAMSEQ",2,2) "KRN",8994,1781,2,"PARAMSEQ",3,3) "KRN",8994,1781,3,0) ^^4^4^3080131^^ "KRN",8994,1781,3,1,0) Results: "KRN",8994,1781,3,2,0) "KRN",8994,1781,3,3,0) 1^SuccessMessage <-- file uploaded from dropbox "KRN",8994,1781,3,4,0) 0^FailureMessage "KRN",8994,1784,-1) 0^14 "KRN",8994,1784,0) TMG CPRS GET URL LIST^GETURLS^TMGRPC1^2^P^^^1^1 "KRN",8994,1784,1,0) ^8994.01^2^2^3080618^^^^ "KRN",8994,1784,1,1,0) CPRS can call this to get a list of URL's to display from inside CPRS. "KRN",8994,1784,1,2,0) These URL's will be displayed inside custom tabs in CPRS. "KRN",8994,1784,2,0) ^8994.02A^^0 "KRN",8994,1784,3,0) ^8994.03^5^5^3080618^^^^ "KRN",8994,1784,3,1,0) Results are returned as follows: "KRN",8994,1784,3,2,0) RESULT(0)="1^Success" or "0^SomeErrorMessage" "KRN",8994,1784,3,3,0) RESULT(1)="CNN^www.cnn.com" ;display www.cnn.com on tab #1, named 'CNN' "KRN",8994,1784,3,4,0) RESULT(2)="^about:blank" ;display a blank page on tab #2, with name of '' "KRN",8994,1784,3,5,0) RESULT(3)="^" ;hide tab #3, with name of '' "MBREQ") 0 "ORD",5,.4) .4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%) "ORD",5,.4,0) PRINT TEMPLATE "ORD",8,.403) .403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%) "ORD",8,.403,0) FORM "ORD",16,8994) 8994;16;1;;;;;;;RPCDEL^XPDIA1 "ORD",16,8994,0) REMOTE PROCEDURE "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PGL",8925.1,0,5,.05) PERSONAL OWNER^P200'X^VA(200,^0;5^Q "PGL",8925.1,0,6,.06) CLASS OWNER^P8930'X^USR(8930,^0;6^Q "PGL",8925.1,0,7,.07) STATUS^*P8925.6'X^TIU(8925.6,^0;7^K:'$G(TIUFPRIV) X Q:'$D(X) S DIC("S")="I 1 X $$STATSCRN^TIUFLF5" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "PGL",8925.1,1,1,1.01) UPLOAD TARGET FILE^*P1'^DIC(^1;1^S DIC("S")="I $D(^DIC(+Y,""%"",""B"",""TIU""))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "PGL",8925.113,0,4,.04) RESULTING STATUS^P8930.6'^USR(8930.6,^0;4^Q "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 96 "RTN","TMGABV") 0^1^B86362 "RTN","TMGABV",1,0) TMGABV ;TMG/kst/Abbreviation code ; 03/25/06 "RTN","TMGABV",2,0) ;;1.0;TMG-LIB;**1**;12/23/05 "RTN","TMGABV",3,0) "RTN","TMGABV",4,0) ;" ABBREVIATION code "RTN","TMGABV",5,0) "RTN","TMGABV",6,0) ;"Kevin Toppenberg MD "RTN","TMGABV",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGABV",8,0) ;"12-23-2006 "RTN","TMGABV",9,0) "RTN","TMGABV",10,0) ;"======================================================================= "RTN","TMGABV",11,0) ;" API -- Public Functions. "RTN","TMGABV",12,0) ;"======================================================================= "RTN","TMGABV",13,0) ;"$$Read(OrigName,LenCat,DefValue) "RTN","TMGABV",14,0) ;"Write(OrigName,ShortName,LenCat,AskConfirm) "RTN","TMGABV",15,0) ;"Del(OrigName,LenCat,AskConfirm) "RTN","TMGABV",16,0) ;"GetAbvr(Name,AskUser,UseSR) "RTN","TMGABV",17,0) ;"Fix(ShortName) -- provides a way to fix erroneous abbreviations. "RTN","TMGABV",18,0) ;"ShowDiff -- scan and show changes. This is not very useful (a testing function) "RTN","TMGABV",19,0) ;"ScanDel(Text) -- scan for text and allow deletions. "RTN","TMGABV",20,0) "RTN","TMGABV",21,0) ;"======================================================================= "RTN","TMGABV",22,0) ;" Private Functions. "RTN","TMGABV",23,0) ;"======================================================================= "RTN","TMGABV",24,0) ;"CheckDel(longName,DiffArray,DiffStr,lenCat) "RTN","TMGABV",25,0) ;"Fix1(ShortName) -- provide a way to fix erroneous abbreviations. "RTN","TMGABV",26,0) ;"ShowLinks(ShortName,LenCat,array) -- show a chain of abbreviations. "RTN","TMGABV",27,0) ;"GetDiff(longName,LenCat) -- for longName, return what changes for it's abbreviation "RTN","TMGABV",28,0) ;"GetDiffStr(longName,shortName) -- given longName and it's shortname abbreviation, return what changes "RTN","TMGABV",29,0) ;"ScanAbvs(xstr,showProgress) -- scan abbreviations and execute code "RTN","TMGABV",30,0) "RTN","TMGABV",31,0) ;"======================================================================= "RTN","TMGABV",32,0) ;"======================================================================= "RTN","TMGABV",33,0) "RTN","TMGABV",34,0) Read(OrigName,LenCat,DefValue) "RTN","TMGABV",35,0) ;"Purpose: To read from the ABBREV array and return an abbreviation "RTN","TMGABV",36,0) ;"Input: OrigName -- the name to look up "RTN","TMGABV",37,0) ;" LenCat -- OPTIONAL. If specified, then results returned from that category "RTN","TMGABV",38,0) ;" if LenCat="ALL" then all categories are scanned until some value found. "RTN","TMGABV",39,0) ;" DefValue -- OPTIONAL. If specified, a default value if not found "RTN","TMGABV",40,0) ;"Results: Returns the found abbreviation, or "" if not found "RTN","TMGABV",41,0) "RTN","TMGABV",42,0) set DefValue=$get(DefValue) "RTN","TMGABV",43,0) new result set result=DefValue "RTN","TMGABV",44,0) if $get(OrigName)="" goto RdDone "RTN","TMGABV",45,0) if $get(LenCat)'="" do "RTN","TMGABV",46,0) . if LenCat="ALL" do "RTN","TMGABV",47,0) . . set result=$get(^TMG("ABBREV",OrigName),DefValue) quit:(result'="") "RTN","TMGABV",48,0) . . set LenCat="" "RTN","TMGABV",49,0) . . for set LenCat=$order(^TMG("ABBREV",LenCat),-1) quit:(+LenCat'=LenCat)!(result'="") do "RTN","TMGABV",50,0) . . . set result=$get(^TMG("ABBREV",LenCat,OrigName),DefValue) "RTN","TMGABV",51,0) . else do "RTN","TMGABV",52,0) . . set result=$get(^TMG("ABBREV",LenCat,OrigName),DefValue) "RTN","TMGABV",53,0) else do "RTN","TMGABV",54,0) . set result=$get(^TMG("ABBREV",OrigName),DefValue) "RTN","TMGABV",55,0) RdDone "RTN","TMGABV",56,0) if result'="" do "RTN","TMGABV",57,0) . if ($get(TMGDBABV)=1)&(result'=OrigName) do "RTN","TMGABV",58,0) . . write OrigName,"-->",!,result," OK" "RTN","TMGABV",59,0) . . new % set %=1 do YN^DICN write ! "RTN","TMGABV",60,0) . . if %=1 quit "RTN","TMGABV",61,0) . . set result="" "RTN","TMGABV",62,0) . . if %=-1 quit "RTN","TMGABV",63,0) . . if %=2 do Del(OrigNameName,.LenCat,1) "RTN","TMGABV",64,0) "RTN","TMGABV",65,0) quit result "RTN","TMGABV",66,0) "RTN","TMGABV",67,0) "RTN","TMGABV",68,0) Write(OrigName,ShortName,LenCat,AskConfirm) "RTN","TMGABV",69,0) ;"Purpose: To provide a unified writer for ABBREV array "RTN","TMGABV",70,0) ;"Input: OrigName -- the longer name that the abbreviation will stand for "RTN","TMGABV",71,0) ;" ShortName -- the shorter abbreviation of OrigName "RTN","TMGABV",72,0) ;" LenCat -- OPTIONAL -- If supplied, then abbreviation will be stored in this category "RTN","TMGABV",73,0) ;" AskConfirm -- OPTIONAL -- if 1 then user asked to confirm save. "RTN","TMGABV",74,0) ;"results: none "RTN","TMGABV",75,0) ;"Note: Assigning a NULL ShortName is not currently allowed. "RTN","TMGABV",76,0) "RTN","TMGABV",77,0) if $get(OrigName)="" goto WtDone "RTN","TMGABV",78,0) if $get(ShortName)="" goto WtDone "RTN","TMGABV",79,0) set AskConfirm=$get(AskConfirm,0) "RTN","TMGABV",80,0) if $$Read(OrigName,.LenCat)=ShortName goto WtDone ;"Skip write if already there "RTN","TMGABV",81,0) new % set %=1 "RTN","TMGABV",82,0) if AskConfirm=1 do "RTN","TMGABV",83,0) W1 . write "[",OrigName,"] --> [",ShortName,"]",! "RTN","TMGABV",84,0) . write "Save for future use" "RTN","TMGABV",85,0) . do YN^DICN write ! "RTN","TMGABV",86,0) if %'=1 goto WtDone "RTN","TMGABV",87,0) if $get(LenCat)'="" do "RTN","TMGABV",88,0) . set ^TMG("ABBREV",LenCat,OrigName)=ShortName "RTN","TMGABV",89,0) . set ^TMG("ABBREV",LenCat,"XREF",ShortName)=OrigName "RTN","TMGABV",90,0) else do "RTN","TMGABV",91,0) . set ^TMG("ABBREV",OrigName)=ShortName "RTN","TMGABV",92,0) . set ^TMG("ABBREV","XREF",ShortName)=OrigName "RTN","TMGABV",93,0) WtDone quit "RTN","TMGABV",94,0) "RTN","TMGABV",95,0) "RTN","TMGABV",96,0) Del(OrigName,LenCat,AskConfirm) "RTN","TMGABV",97,0) ;"Purpose: To delete a value from the ABBREV array "RTN","TMGABV",98,0) ;"Input: OrigName -- the name to look up "RTN","TMGABV",99,0) ;" LenCat -- OPTIONAL. If specified, then category to delete from "RTN","TMGABV",100,0) ;" AskConfirm -- OPTIONAL -- if 1 then user asked to confirm save. "RTN","TMGABV",101,0) ;"Results: none "RTN","TMGABV",102,0) "RTN","TMGABV",103,0) if $get(OrigName)="" goto DelDone "RTN","TMGABV",104,0) set AskConfirm=$get(AskConfirm,0) "RTN","TMGABV",105,0) new CurValue "RTN","TMGABV",106,0) if $get(LenCat)'="" set CurValue=$get(^TMG("ABBREV",LenCat,OrigName)) "RTN","TMGABV",107,0) else set CurValue=$get(^TMG("ABBREV",OrigName)) "RTN","TMGABV",108,0) new % set %=1 "RTN","TMGABV",109,0) if AskConfirm=1 do "RTN","TMGABV",110,0) . write "[",OrigName,"] -->",!,"[",CurValue,"]",! "RTN","TMGABV",111,0) . write "OK to DELETE" do YN^DICN write ! "RTN","TMGABV",112,0) if %'=1 goto DelDone "RTN","TMGABV",113,0) if $get(LenCat)'="" do "RTN","TMGABV",114,0) . kill ^TMG("ABBREV",LenCat,OrigName) "RTN","TMGABV",115,0) . kill ^TMG("ABBREV",LenCat,"XREF",CurValue) "RTN","TMGABV",116,0) else do "RTN","TMGABV",117,0) . kill ^TMG("ABBREV",OrigName) "RTN","TMGABV",118,0) . kill ^TMG("ABBREV","XREF",CurValue) "RTN","TMGABV",119,0) if AskConfirm'=1 goto DelDone "RTN","TMGABV",120,0) "RTN","TMGABV",121,0) ;"Now see if this same problem needs to be fixed in other abbreviations. "RTN","TMGABV",122,0) new tempS set tempS=$$GetDiffStr(OrigName,CurValue) "RTN","TMGABV",123,0) new DiffArray,count set count=1 "RTN","TMGABV",124,0) write "That association had the following difference(s):",! "RTN","TMGABV",125,0) for quit:(tempS'["^") do "RTN","TMGABV",126,0) . new OneDiff set OneDiff=$piece(tempS,"^",1) "RTN","TMGABV",127,0) . set DiffArray(count)=OneDiff,count=count+1 "RTN","TMGABV",128,0) . write " ",$piece(OneDiff,">",1)," --> ",$piece(OneDiff,">",2),! "RTN","TMGABV",129,0) . set tempS=tempS=$piece(tempS,"^",3,999) "RTN","TMGABV",130,0) set DiffArray("MAXNODE")=$$ListCt^TMGMISC("DiffArray") "RTN","TMGABV",131,0) set %=1 "RTN","TMGABV",132,0) write "Delete all other abbreviations that have these difference(s)" "RTN","TMGABV",133,0) do YN^DICN write ! "RTN","TMGABV",134,0) if %'=1 goto DelDone "RTN","TMGABV",135,0) Del1 new xstr set xstr="do CheckDel(longName,.DiffArray,DiffStr,lenCat)" "RTN","TMGABV",136,0) do ScanAbvs(xstr,1) "RTN","TMGABV",137,0) "RTN","TMGABV",138,0) DelDone quit "RTN","TMGABV",139,0) "RTN","TMGABV",140,0) "RTN","TMGABV",141,0) CheckDel(longName,DiffArray,DiffStr,lenCat) "RTN","TMGABV",142,0) ;"Purpose: this is a callback function for a ScanAbvs run "RTN","TMGABV",143,0) ;" it will be called for each abbreviation "RTN","TMGABV",144,0) ;"Input: DiffArray -- PASS BY REFERENCE. Format: "RTN","TMGABV",145,0) ;" DiffArray(1)="Long1>short1" "RTN","TMGABV",146,0) ;" DiffArray(2)="Long2>short2" "RTN","TMGABV",147,0) ;" DiffArray(3)="Long3>short3" "RTN","TMGABV",148,0) ;" DiffArray("MAXNODE")=3 "RTN","TMGABV",149,0) ;" DiffStr -- a difference string, as created by $$GetDiff "RTN","TMGABV",150,0) ;" lenCat -- the category that eval is from, or "" if none "RTN","TMGABV",151,0) "RTN","TMGABV",152,0) new shouldDel set shouldDel=1 "RTN","TMGABV",153,0) new i for i=1:1:+$get(DiffArray("MAXNODE")) do quit:(shouldDel=0) "RTN","TMGABV",154,0) . set shouldDel=DiffStr[DiffArray(i) "RTN","TMGABV",155,0) "RTN","TMGABV",156,0) if shouldDel=1 do Del(longName,lenCat,0) "RTN","TMGABV",157,0) quit "RTN","TMGABV",158,0) "RTN","TMGABV",159,0) "RTN","TMGABV",160,0) "RTN","TMGABV",161,0) GetAbvr(Name,AskUser,UseSR) "RTN","TMGABV",162,0) ;"Purpose: To get an abbreviation for one word "RTN","TMGABV",163,0) ;"Input: Name -- name to shorten "RTN","TMGABV",164,0) ;" AskUser -- if 1, then user will be asked to supply abbreviations "RTN","TMGABV",165,0) ;" UseSR -- OPTIONAL, default=0. If 0, then ^DIR won't be used "RTN","TMGABV",166,0) ;"Note: The name returned here may be longer than desired, no testing of length done. "RTN","TMGABV",167,0) ;"Results: Returns abreviated name, or original name if not found, or "" if deleted "RTN","TMGABV",168,0) "RTN","TMGABV",169,0) set UseSR=$get(UseSR,0) "RTN","TMGABV",170,0) "RTN","TMGABV",171,0) new result,Y "RTN","TMGABV",172,0) set result=$get(Name) "RTN","TMGABV",173,0) if Name="" goto GADone "RTN","TMGABV",174,0) if $get(AskUser)=1 do "RTN","TMGABV",175,0) . write "Enter a shorter form of '"_Name_"' (^ to delete)",! "RTN","TMGABV",176,0) . if UseSR do "RTN","TMGABV",177,0) . . new DIR "RTN","TMGABV",178,0) . . set DIR(0)="F" "RTN","TMGABV",179,0) . . set DIR("A")="New Name" "RTN","TMGABV",180,0) . . set DIR("B")=result "RTN","TMGABV",181,0) . . do ^DIR write ! "RTN","TMGABV",182,0) . else do "RTN","TMGABV",183,0) . . read "New Name: ",Y:($get(DTIME,3600)),! "RTN","TMGABV",184,0) . if Y="^" do quit "RTN","TMGABV",185,0) . . write "Delete word from name" "RTN","TMGABV",186,0) . . new % set %=1 do YN^DICN write ! "RTN","TMGABV",187,0) . . if %=1 set result="" "RTN","TMGABV",188,0) . if Y'=result do "RTN","TMGABV",189,0) . . do Write(Name,Y,,1) ;"1=> confirm save "RTN","TMGABV",190,0) . . set result=Y "RTN","TMGABV",191,0) else do "RTN","TMGABV",192,0) . set result=$$Read(Name,,Name) "RTN","TMGABV",193,0) . if result="^" set result="" do Del(Name) "RTN","TMGABV",194,0) . if result="" quit "RTN","TMGABV",195,0) . if ($get(TMGDBABV)=1)&(result'=Name) do "RTN","TMGABV",196,0) . . write Name,"-->",!,result,!," OK" "RTN","TMGABV",197,0) . . new % set %=1 do YN^DICN write ! "RTN","TMGABV",198,0) . . if %=1 quit "RTN","TMGABV",199,0) . . if %=-1 set result="" quit "RTN","TMGABV",200,0) . . if %=2 do "RTN","TMGABV",201,0) . . . write "Delete abbreviation" do YN^DICN write ! "RTN","TMGABV",202,0) . . . if %=1 do Del(Name) set result="" "RTN","TMGABV",203,0) "RTN","TMGABV",204,0) GADone "RTN","TMGABV",205,0) quit result "RTN","TMGABV",206,0) "RTN","TMGABV",207,0) "RTN","TMGABV",208,0) "RTN","TMGABV",209,0) Fix(ShortName,Context) "RTN","TMGABV",210,0) ;"Purpose: To provide a way to fix erroneous abbreviations. "RTN","TMGABV",211,0) ;"Input: ShortName -- the abbreviation to fix. "RTN","TMGABV",212,0) ;" Context -- OPTIONAL. The sentence ShortName is found in. "RTN","TMGABV",213,0) ;"Result: Returns new name after fixing mislinked abbreviations, "RTN","TMGABV",214,0) ;" or 0 for requested retry "RTN","TMGABV",215,0) "RTN","TMGABV",216,0) new Menu,Option "RTN","TMGABV",217,0) set Context=$get(Context) "RTN","TMGABV",218,0) new result set result="" "RTN","TMGABV",219,0) "RTN","TMGABV",220,0) FL1 if Context="" goto FL2 "RTN","TMGABV",221,0) "RTN","TMGABV",222,0) set Menu(0)="Pick Which to Fix" "RTN","TMGABV",223,0) set Menu(1)=ShortName "RTN","TMGABV",224,0) set Menu(2)=Context "RTN","TMGABV",225,0) write # "RTN","TMGABV",226,0) set Option=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGABV",227,0) if Option="^" goto FixDone "RTN","TMGABV",228,0) "RTN","TMGABV",229,0) FL2 if (Option=1)!(Context="") do goto:(Context'="") FL1 goto FixDone "RTN","TMGABV",230,0) . set ShortName=$$Fix1(ShortName) "RTN","TMGABV",231,0) . if ShortName'="" set result=ShortName "RTN","TMGABV",232,0) if (Option=2) do goto FixDone "RTN","TMGABV",233,0) . new temp set temp=$$Fix1(Context) "RTN","TMGABV",234,0) . set result=0 "RTN","TMGABV",235,0) if (Option="^") goto FixDone "RTN","TMGABV",236,0) goto FL1 "RTN","TMGABV",237,0) "RTN","TMGABV",238,0) FixDone "RTN","TMGABV",239,0) quit result "RTN","TMGABV",240,0) "RTN","TMGABV",241,0) "RTN","TMGABV",242,0) Fix1(ShortName) "RTN","TMGABV",243,0) ;"Purpose: To provide a way to fix erroneous abbreviations. "RTN","TMGABV",244,0) ;"Input: ShortName -- the abbreviation to fix. "RTN","TMGABV",245,0) ;"Result: Returns new name after fixing mislinked abbreviations. "RTN","TMGABV",246,0) "RTN","TMGABV",247,0) new array,Option "RTN","TMGABV",248,0) new Name,LenCat "RTN","TMGABV",249,0) new result set result="" "RTN","TMGABV",250,0) new max "RTN","TMGABV",251,0) Fix1Loop "RTN","TMGABV",252,0) kill array "RTN","TMGABV",253,0) do ShowLinks(ShortName,,.array) "RTN","TMGABV",254,0) ;"Return Format "RTN","TMGABV",255,0) ;" array(x)=ShortName <-- LongerName[TAB]LongerName^LenCat "RTN","TMGABV",256,0) "RTN","TMGABV",257,0) set max=+$get(array("MAX")) "RTN","TMGABV",258,0) kill array("MAX") "RTN","TMGABV",259,0) set array(0)="Pick item to DELETE" "RTN","TMGABV",260,0) write # "RTN","TMGABV",261,0) set Option=$$Menu^TMGUSRIF(.array,"^") "RTN","TMGABV",262,0) if Option="^" goto Fix1Done "RTN","TMGABV",263,0) set Name=$piece(Option,"^",1) "RTN","TMGABV",264,0) set LenCat=$piece(Option,"^",2) "RTN","TMGABV",265,0) do Del(Name,LenCat,1) "RTN","TMGABV",266,0) goto Fix1Loop "RTN","TMGABV",267,0) "RTN","TMGABV",268,0) Fix1Done "RTN","TMGABV",269,0) new s set s=$get(array(max)) "RTN","TMGABV",270,0) set s=$piece(s,$char(9),2) "RTN","TMGABV",271,0) set s=$piece(s,"^",1) "RTN","TMGABV",272,0) set result=s "RTN","TMGABV",273,0) quit result "RTN","TMGABV",274,0) "RTN","TMGABV",275,0) "RTN","TMGABV",276,0) "RTN","TMGABV",277,0) ShowLinks(ShortName,LenCat,array) "RTN","TMGABV",278,0) ;"Purpose: To show a chain of abbreviations. "RTN","TMGABV",279,0) ;"Input: ShortName -- the abbreviation to check. "RTN","TMGABV",280,0) ;" LenCat -- the category to look in "RTN","TMGABV",281,0) ;" Array -- PASS BY REFERENCE. an OUT PARAMETER. Format "RTN","TMGABV",282,0) ;" array("MAX")=maxCount (e.g. 2) "RTN","TMGABV",283,0) ;" array(1)=ShortName <-- LongerName[TAB]LongerName^LenCat "RTN","TMGABV",284,0) ;" array(2)=ShortName <-- LongerName[TAB]LongerName^LenCat "RTN","TMGABV",285,0) "RTN","TMGABV",286,0) new i set i="" "RTN","TMGABV",287,0) new max set max=$get(array("MAX"),0) "RTN","TMGABV",288,0) new value set value="" "RTN","TMGABV",289,0) if $get(LenCat)="" do "RTN","TMGABV",290,0) . for set i=$order(^TMG("ABBREV",i)) quit:(+i'>0) do "RTN","TMGABV",291,0) . . do ShowLinks(ShortName,i,.array) "RTN","TMGABV",292,0) . set value=$get(^TMG("ABBREV","XREF",ShortName)) "RTN","TMGABV",293,0) else do "RTN","TMGABV",294,0) . set value=$get(^TMG("ABBREV",LenCat,"XREF",ShortName)) "RTN","TMGABV",295,0) if value'="" do "RTN","TMGABV",296,0) . set max=max+1 "RTN","TMGABV",297,0) . write max,". ",ShortName," <-- ",value,! "RTN","TMGABV",298,0) . set array(max)=ShortName_" <-- "_value_$char(9)_value_"^"_$get(LenCat) "RTN","TMGABV",299,0) . set array("MAX")=max "RTN","TMGABV",300,0) . do ShowLinks(value,.LenCat,.array) "RTN","TMGABV",301,0) "RTN","TMGABV",302,0) quit "RTN","TMGABV",303,0) "RTN","TMGABV",304,0) GetDiff(longName,LenCat) "RTN","TMGABV",305,0) ;"Purpose: for a given longName, return what changes for it's abbreviation "RTN","TMGABV",306,0) ;"Input: longName -- the original name to search for "RTN","TMGABV",307,0) ;" LenCat -- OPTIONAL. Default is "ALL" "RTN","TMGABV",308,0) ;"Results: returns difference between longName and its abbreviation, or "" if none. "RTN","TMGABV",309,0) ;"Results: DiffLong1>DiffShort1^pos1>pos2^DiffLong2>DiffShort2^pos1>pos2^... "RTN","TMGABV",310,0) "RTN","TMGABV",311,0) new result set result="" "RTN","TMGABV",312,0) set LenCat=$get(LenCat,"ALL") "RTN","TMGABV",313,0) new shortName set shortName=$$Read(longName,LenCat) "RTN","TMGABV",314,0) if shortName'="" set result=$$GetDiffStr(longName,shortName) "RTN","TMGABV",315,0) quit result "RTN","TMGABV",316,0) "RTN","TMGABV",317,0) "RTN","TMGABV",318,0) GetDiffStr(longName,shortName) "RTN","TMGABV",319,0) ;"Purpose: for a given longName and it's shortname abbreviation, "RTN","TMGABV",320,0) ;" return what changes for it's abbreviation "RTN","TMGABV",321,0) ;"Results: returns difference between longName and shortName, or "" if none. "RTN","TMGABV",322,0) ;"Results: DiffLong1>DiffShort1^pos1>pos2^DiffLong2>DiffShort2^pos1>pos2^... "RTN","TMGABV",323,0) "RTN","TMGABV",324,0) new DiffStr set DiffStr="" "RTN","TMGABV",325,0) ;"if $get(shortName)="" goto GDSDone "RTN","TMGABV",326,0) new longWords,shortWords "RTN","TMGABV",327,0) new DivCh set DivCh=" " "RTN","TMGABV",328,0) if $length(longName,"/")>3 set DivCh="/" "RTN","TMGABV",329,0) do CleaveToArray^TMGSTUTL(longName,DivCh,.longWords) "RTN","TMGABV",330,0) do CleaveToArray^TMGSTUTL(shortName,DivCh,.shortWords) "RTN","TMGABV",331,0) new temp,i "RTN","TMGABV",332,0) set temp=$$DiffWords^TMGSTUTL(.longWords,.shortWords) "RTN","TMGABV",333,0) for do quit:(temp="") "RTN","TMGABV",334,0) . new origS,destNum "RTN","TMGABV",335,0) . set origS=$piece(temp,"^",1) "RTN","TMGABV",336,0) . set temp=$piece(temp,"^",3,999) "RTN","TMGABV",337,0) . if DiffStr'="" set DiffStr=DiffStr_"^" "RTN","TMGABV",338,0) . set DiffStr=DiffStr_origS "RTN","TMGABV",339,0) GDSDone quit DiffStr "RTN","TMGABV",340,0) "RTN","TMGABV",341,0) "RTN","TMGABV",342,0) ScanAbvs(xstr,showProgress) "RTN","TMGABV",343,0) ;"Purpose: scan abbreviations and execute code "RTN","TMGABV",344,0) ;"Input: xstr -- OPTIONAL. m code to execute for each entry.´ "RTN","TMGABV",345,0) ;" showProgress -- OPTIONAL. if 1, progress bar is shown. "RTN","TMGABV",346,0) ;"Note: The following variables will be defined, for use in xstr: "RTN","TMGABV",347,0) ;" longName,shortName,DiffStr,lenCat "RTN","TMGABV",348,0) "RTN","TMGABV",349,0) new longName,shortName,lenCat,DiffStr "RTN","TMGABV",350,0) "RTN","TMGABV",351,0) set longName="",lenCat="" "RTN","TMGABV",352,0) "RTN","TMGABV",353,0) new Itr "RTN","TMGABV",354,0) ;"for set longName=$order(^TMG("ABBREV",longName),-1) quit:(+longName>0) do "RTN","TMGABV",355,0) set longName=$$ItrAInit^TMGITR($name(^TMG("ABBREV")),.Itr,-1) "RTN","TMGABV",356,0) if $get(showProgress)=1 do PrepProgress^TMGITR(.Itr,20,1,"longName") "RTN","TMGABV",357,0) if longName'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.longName,-1)>0)!(longName="") "RTN","TMGABV",358,0) . new shortName "RTN","TMGABV",359,0) . set shortName=$get(^TMG("ABBREV",longName)) "RTN","TMGABV",360,0) . set DiffStr=$$GetDiffStr(longName,shortName) "RTN","TMGABV",361,0) . if xstr'="" xecute xstr "RTN","TMGABV",362,0) "RTN","TMGABV",363,0) set lenCat=0 "RTN","TMGABV",364,0) for set lenCat=$order(^TMG("ABBREV",lenCat)) quit:(+lenCat'=lenCat) do "RTN","TMGABV",365,0) . if $get(showProgress)=1 write ! "RTN","TMGABV",366,0) . ;"set longName="" "RTN","TMGABV",367,0) . ;"for set longName=$order(^TMG("ABBREV",lenCat,longName),-1) quit:(+longName>0)!(longName="") do "RTN","TMGABV",368,0) . set longName=$$ItrAInit^TMGITR($name(^TMG("ABBREV",lenCat)),.Itr,-1) "RTN","TMGABV",369,0) . if $get(showProgress)=1 do PrepProgress^TMGITR(.Itr,20,1,"longName") "RTN","TMGABV",370,0) . if longName'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.longName,-1)>0)!(longName="") "RTN","TMGABV",371,0) . . new shortName set shortName=$get(^TMG("ABBREV",longName)) "RTN","TMGABV",372,0) . . set DiffStr=$$GetDiffStr(longName,shortName) "RTN","TMGABV",373,0) . . if xstr'="" xecute xstr "RTN","TMGABV",374,0) "RTN","TMGABV",375,0) quit "RTN","TMGABV",376,0) "RTN","TMGABV",377,0) "RTN","TMGABV",378,0) ShowDiff "RTN","TMGABV",379,0) ;"Purpose: scan and show changes "RTN","TMGABV",380,0) "RTN","TMGABV",381,0) new xstr "RTN","TMGABV",382,0) set xstr="write longName,"" --> ["",DiffStr,""] "",shortName,!" "RTN","TMGABV",383,0) do ScanAbvs(xstr,1) "RTN","TMGABV",384,0) quit "RTN","TMGABV",385,0) "RTN","TMGABV",386,0) "RTN","TMGABV",387,0) ScanDel(Text) "RTN","TMGABV",388,0) ;"Purpose: scan for text and allow deletions. "RTN","TMGABV",389,0) "RTN","TMGABV",390,0) new xstr "RTN","TMGABV",391,0) set xstr="if DiffStr[Text do Del(longName,,1)" "RTN","TMGABV",392,0) do ScanAbvs(xstr) "RTN","TMGABV",393,0) quit "RTN","TMGABV",394,0) "RTN","TMGABV",395,0) "RTN","TMGBINF") 0^2^B6621 "RTN","TMGBINF",1,0) TMGBINF ;TMG/kst/Binary <--> Global Functions ;03/25/06 "RTN","TMGBINF",2,0) ;;1.0;TMG-LIB;**1**;08/20/05 "RTN","TMGBINF",3,0) "RTN","TMGBINF",4,0) ;"TMG BIN <-->GBL FUNCTIONS "RTN","TMGBINF",5,0) ;"Kevin Toppenberg MD "RTN","TMGBINF",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGBINF",7,0) ;"8-20-2005 "RTN","TMGBINF",8,0) "RTN","TMGBINF",9,0) ;"======================================================================= "RTN","TMGBINF",10,0) ;" API -- Public Functions. "RTN","TMGBINF",11,0) ;"======================================================================= "RTN","TMGBINF",12,0) ;"$$BFTG(path,filename,globalRef,incSubscr,width) -- BINARY FILE TO GLOBAL "RTN","TMGBINF",13,0) ;"$$GTBF(globalRef,incSubscr,path,filename) -- GLOBAL TO BINARY FILE "RTN","TMGBINF",14,0) ;"CPYBG(srcGRef,srcIncSubscr,dstGRef,dstIncSubscr,width) -- COPY/RESIZE BINARY GLOBAL. "RTN","TMGBINF",15,0) "RTN","TMGBINF",16,0) "RTN","TMGBINF",17,0) ;"======================================================================= "RTN","TMGBINF",18,0) ;"PRIVATE API FUNCTIONS "RTN","TMGBINF",19,0) ;"======================================================================= "RTN","TMGBINF",20,0) ;"$$NEXTNODE(curRef,incSubscr) "RTN","TMGBINF",21,0) ;"$$READBG(GRef,incSubscr,pos,count,actualCount) -- STREAM READ FROM BINARY GLOBAL "RTN","TMGBINF",22,0) "RTN","TMGBINF",23,0) ;"======================================================================= "RTN","TMGBINF",24,0) ;"DEPENDENCIES "RTN","TMGBINF",25,0) ;"======================================================================= "RTN","TMGBINF",26,0) ;"Uses: (No other units) "RTN","TMGBINF",27,0) "RTN","TMGBINF",28,0) ;"======================================================================= "RTN","TMGBINF",29,0) "RTN","TMGBINF",30,0) BFTG(path,filename,globalRef,incSubscr,width) "RTN","TMGBINF",31,0) ;"SCOPE: PUBLIC "RTN","TMGBINF",32,0) ;"Purpose: To load a binary file from the host filesystem into a global, storing "RTN","TMGBINF",33,0) ;" the composit bytes as raw binary data. "RTN","TMGBINF",34,0) ;" You do not need to open the host file before making this call; it is opened "RTN","TMGBINF",35,0) ;" and closed automatically "RTN","TMGBINF",36,0) ;"Input: path -- (required) full path, up to but not including the filename "RTN","TMGBINF",37,0) ;" filename -- (required) name of the file to open "RTN","TMGBINF",38,0) ;" globalRef-- (required) Global reference to WRITE the host binary file to, in fully "RTN","TMGBINF",39,0) ;" resolved (closed root) format. This function does NOT kill the global "RTN","TMGBINF",40,0) ;" before writing to it. "RTN","TMGBINF",41,0) ;" Note: "RTN","TMGBINF",42,0) ;" At least one subscript must be numeric. This will be the incrementing "RTN","TMGBINF",43,0) ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment "RTN","TMGBINF",44,0) ;" to store each new global node). This subscript need not be the final "RTN","TMGBINF",45,0) ;" subscript. For example, to load into a WORD PROCESSING field, the "RTN","TMGBINF",46,0) ;" incrementing node is the second-to-last subscript; the final subscript "RTN","TMGBINF",47,0) ;" is always zero. "RTN","TMGBINF",48,0) ;" incSubscr-- (required) Identifies the incrementing subscript level. For example, if you "RTN","TMGBINF",49,0) ;" pass ^TMP(115,1,1,0) as the global_ref parameter and pass 3 as the "RTN","TMGBINF",50,0) ;" inc_subscr parameter, $$BIN2GBL will increment the third subscript, such "RTN","TMGBINF",51,0) ;" as ^TMP(115,1,x), but will WRITE notes at the full global reference, such "RTN","TMGBINF",52,0) ;" as ^TMP(115,1,x,0). "RTN","TMGBINF",53,0) ;" width -- OPTIONAL -- the number of bytes to store per line. Default=512 "RTN","TMGBINF",54,0) ;"*** NOTICE: width is not working properly. For now, just don't supply a number. "RTN","TMGBINF",55,0) "RTN","TMGBINF",56,0) ;"Result: 1=success, 0=failure "RTN","TMGBINF",57,0) ;" "RTN","TMGBINF",58,0) ;"Example: "RTN","TMGBINF",59,0) ;" write $$BFTG(path,file,"^TMP(115,1,1,0)",3) "RTN","TMGBINF",60,0) ;" ^TMP(115,1,1,0)="04016785439093479334987689724398732490782..." "RTN","TMGBINF",61,0) ;" ^TMP(115,1,2,0)="09834573467345092647823450982345858792346..." "RTN","TMGBINF",62,0) ;" ^TMP(115,1,3,0)="90783492734987234098243908723459590823494..." "RTN","TMGBINF",63,0) ;" ^TMP(115,1,4,0)="23489723450234097234980732402349955987284..." "RTN","TMGBINF",64,0) ;" ^TMP(115,1,5,0)="0983457823450982734572349874234874" <-- not padded with terminal zeros "RTN","TMGBINF",65,0) ;"In this example, only digits 0-9 are shown. In reality each digit can be a byte with a value 0-255 "RTN","TMGBINF",66,0) "RTN","TMGBINF",67,0) new result set result=0 ;"default to failure "RTN","TMGBINF",68,0) new handle set handle="TMGHANDLE" "RTN","TMGBINF",69,0) new abort set abort=0 "RTN","TMGBINF",70,0) new blockIn "RTN","TMGBINF",71,0) new $ETRAP "RTN","TMGBINF",72,0) if $get(globalRef)="" goto BFTGDone "RTN","TMGBINF",73,0) "RTN","TMGBINF",74,0) new curRef "RTN","TMGBINF",75,0) new tempRef set tempRef="^TMP(""BFTG^TMGBINF"","_$J_",1)" "RTN","TMGBINF",76,0) ;"if user wants a width other than 512, will have to load into a temporary location, "RTN","TMGBINF",77,0) ;"and then copy over to final destination at requested with "RTN","TMGBINF",78,0) if +$get(width)>0 set curRef=tempRef "RTN","TMGBINF",79,0) else set curRef=globalRef "RTN","TMGBINF",80,0) "RTN","TMGBINF",81,0) set filename=$get(filename) "RTN","TMGBINF",82,0) if filename="" goto BFTGDone "RTN","TMGBINF",83,0) "RTN","TMGBINF",84,0) set path=$$DEFDIR^%ZISH($get(path)) "RTN","TMGBINF",85,0) "RTN","TMGBINF",86,0) ;"Note: Each line will 512 bytes long (512 is hard coded into OPEN^%ZISH) "RTN","TMGBINF",87,0) do OPEN^%ZISH(handle,path,filename,"RB") ;"B is a 512 block/binary mode "RTN","TMGBINF",88,0) if POP write "Error opening file...",! goto BFTGDone "RTN","TMGBINF",89,0) set $ETRAP="set abort=1,$ECODE="""" quit" "RTN","TMGBINF",90,0) use IO "RTN","TMGBINF",91,0) for do quit:($ZEOF)!(abort=1)!(blockIn="") "RTN","TMGBINF",92,0) . read blockIn "RTN","TMGBINF",93,0) . if (blockIn="") quit "RTN","TMGBINF",94,0) . set @curRef=blockIn "RTN","TMGBINF",95,0) . set curRef=$$NEXTNODE(curRef,incSubscr) "RTN","TMGBINF",96,0) "RTN","TMGBINF",97,0) if abort=1 write "Aborted...",! "RTN","TMGBINF",98,0) if (abort'=1) set result=1 ;"SUCCESS "RTN","TMGBINF",99,0) do CLOSE^%ZISH(handle) "RTN","TMGBINF",100,0) "RTN","TMGBINF",101,0) if +$get(width)>0 do "RTN","TMGBINF",102,0) . do CPYBG(tempRef,3,globalRef,incSubscr,width) "RTN","TMGBINF",103,0) . kill @tempRef "RTN","TMGBINF",104,0) "RTN","TMGBINF",105,0) "RTN","TMGBINF",106,0) BFTGDone "RTN","TMGBINF",107,0) quit result "RTN","TMGBINF",108,0) "RTN","TMGBINF",109,0) "RTN","TMGBINF",110,0) GTBF(globalRef,incSubscr,path,filename) "RTN","TMGBINF",111,0) ;"SCOPE: PUBLIC "RTN","TMGBINF",112,0) ;"Purpose: This function will WRITE the values of nodes of a global (at the subscript "RTN","TMGBINF",113,0) ;" level you specify) to a host file, in a binary fashion. If the host file already "RTN","TMGBINF",114,0) ;" exists, it is truncated to length zero (0) before the copy. "RTN","TMGBINF",115,0) ;" Each line of the global is written out, in a serial fashion based on the ordering "RTN","TMGBINF",116,0) ;" of the subscripts, with no line terminators written between lines. "RTN","TMGBINF",117,0) ;" You do not need to open the host file before making this call; it is opened "RTN","TMGBINF",118,0) ;" and closed $$GTBF^TMGBINF "RTN","TMGBINF",119,0) ;"Input: "RTN","TMGBINF",120,0) ;" globalRef-- Global reference to WRITE the host binary file to, in fully resolved "RTN","TMGBINF",121,0) ;" (closed root) format. This function does not kill the global before "RTN","TMGBINF",122,0) ;" writing to it. (required) "RTN","TMGBINF",123,0) ;" Note: "RTN","TMGBINF",124,0) ;" At least one subscript must be numeric. This will be the incrementing "RTN","TMGBINF",125,0) ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment "RTN","TMGBINF",126,0) ;" to store each new global node). This subscript need not be the final "RTN","TMGBINF",127,0) ;" subscript. For example, to load into a WORD PROCESSING field, the "RTN","TMGBINF",128,0) ;" incrementing node is the second-to-last subscript; the final subscript "RTN","TMGBINF",129,0) ;" is always zero. "RTN","TMGBINF",130,0) ;" incSubscr-- (required) Identifies the incrementing subscript level. For example, if you "RTN","TMGBINF",131,0) ;" pass ^TMP(115,1,1,0) as the global_ref parameter and pass 3 as the "RTN","TMGBINF",132,0) ;" inc_subscr parameter, $$BIN2GBL will increment the third subscript, such "RTN","TMGBINF",133,0) ;" as ^TMP(115,1,x), but will WRITE notes at the full global reference, such "RTN","TMGBINF",134,0) ;" as ^TMP(115,1,x,0). "RTN","TMGBINF",135,0) ;" path -- full path, up to but not including the filename (required) "RTN","TMGBINF",136,0) ;" filename -- name of the file to open (required) "RTN","TMGBINF",137,0) ;"Result: 1=success, 0=failure "RTN","TMGBINF",138,0) ;" "RTN","TMGBINF",139,0) ;"Example: "RTN","TMGBINF",140,0) ;" write $$GTBF(path,file,"^TMP(115,1,1,0)",3) "RTN","TMGBINF",141,0) ;" ^TMP(115,1,1,0)="04016785439093479334987689724398732490782..." "RTN","TMGBINF",142,0) ;" ^TMP(115,1,2,0)="09834573467345092647823450982345858792346..." "RTN","TMGBINF",143,0) ;" ^TMP(115,1,3,0)="90783492734987234098243908723459590823494..." "RTN","TMGBINF",144,0) ;" ^TMP(115,1,4,0)="23489723450234097234980732402349955987284..." "RTN","TMGBINF",145,0) ;" ^TMP(115,1,5,0)="0983457823450982734572349874234874" "RTN","TMGBINF",146,0) ;"Each line would be sent to the output file in turn as a continuous data sequence. "RTN","TMGBINF",147,0) ;"In this example, only digits 0-9 are shown. In reality each digit can be a byte with a value 0-255 "RTN","TMGBINF",148,0) ;" "RTN","TMGBINF",149,0) "RTN","TMGBINF",150,0) new result set result=0 ;"default to failure "RTN","TMGBINF",151,0) new handle set handle="TMGHANDLE" "RTN","TMGBINF",152,0) new abort set abort=0 "RTN","TMGBINF",153,0) new blockOut "RTN","TMGBINF",154,0) new mustExist set mustExist=1 "RTN","TMGBINF",155,0) new $ETRAP "RTN","TMGBINF",156,0) new curRef set curRef=globalRef "RTN","TMGBINF",157,0) "RTN","TMGBINF",158,0) set path=$$DEFDIR^%ZISH($get(path)) "RTN","TMGBINF",159,0) do OPEN^%ZISH(handle,path,filename,"W") "RTN","TMGBINF",160,0) if POP goto GTBFDone "RTN","TMGBINF",161,0) set $ETRAP="set abort=1,$ECODE="""" quit" "RTN","TMGBINF",162,0) use IO "RTN","TMGBINF",163,0) for do quit:(curRef="")!(abort=1) "RTN","TMGBINF",164,0) . set blockOut=$get(@curRef) "RTN","TMGBINF",165,0) . if (blockOut'="") write blockOut "RTN","TMGBINF",166,0) . set $X=0 ;"prevent IO system from 'wrapping' (adding a linefeed) "RTN","TMGBINF",167,0) . set curRef=$$NEXTNODE(curRef,incSubscr,mustExist) "RTN","TMGBINF",168,0) "RTN","TMGBINF",169,0) if (abort'=1) set result=1 ;"SUCCESS "RTN","TMGBINF",170,0) do CLOSE^%ZISH(handle) "RTN","TMGBINF",171,0) "RTN","TMGBINF",172,0) GTBFDone "RTN","TMGBINF",173,0) quit result "RTN","TMGBINF",174,0) "RTN","TMGBINF",175,0) "RTN","TMGBINF",176,0) NEXTNODE(curRef,incSubscr,mustExist,incAmount) "RTN","TMGBINF",177,0) ;"SCOPE: PUBLIC "RTN","TMGBINF",178,0) ;"Purpose: to take a global reference, and increment the node specified by incSubscr "RTN","TMGBINF",179,0) ;"Input: curRef -- The reference to alter, e.g. '^TMP(115,1,4,0)' "RTN","TMGBINF",180,0) ;" incSubscr--The node to alter, e.g. "RTN","TMGBINF",181,0) ;" 1-->^TMG(x,1,4,0) x would be incremented "RTN","TMGBINF",182,0) ;" 2-->^TMG(115,x,4,0) x would be incremented "RTN","TMGBINF",183,0) ;" 3-->^TMG(115,1,x,0) x would be incremented "RTN","TMGBINF",184,0) ;" 4-->^TMG(115,1,4,x) x would be incremented "RTN","TMGBINF",185,0) ;" mustExist-- (Option) if >0, then after incrementing, If resulting "RTN","TMGBINF",186,0) ;" reference doesn't exist then "" is returned. "RTN","TMGBINF",187,0) ;" incAmount -- (Optional) the amount to increment by (default=1) "RTN","TMGBINF",188,0) ;"Note: The node that incSubscr references should be numeric (i.e. not a name) "RTN","TMGBINF",189,0) ;" otherwise the alpha node will be treated as a 0 "RTN","TMGBINF",190,0) ;"result: returns the new reference (or "" if doesn't exist and mustExist>0) "RTN","TMGBINF",191,0) "RTN","TMGBINF",192,0) new i,result "RTN","TMGBINF",193,0) set incAmount=$get(incAmount,1) "RTN","TMGBINF",194,0) set result=$qsubscript(curRef,0)_"(" "RTN","TMGBINF",195,0) for i=1:1:$qlength(curRef) do "RTN","TMGBINF",196,0) . new node "RTN","TMGBINF",197,0) . if i'=1 set result=result_"," "RTN","TMGBINF",198,0) . set node=$qsubscript(curRef,i) "RTN","TMGBINF",199,0) . if i=incSubscr set node=node+incAmount "RTN","TMGBINF",200,0) . if (node'=+node) set node=""""_node_"""" "RTN","TMGBINF",201,0) . set result=result_node "RTN","TMGBINF",202,0) set result=result_")" "RTN","TMGBINF",203,0) "RTN","TMGBINF",204,0) if $get(mustExist,0)>0 do "RTN","TMGBINF",205,0) . if $data(@result)#10=0 set result="" "RTN","TMGBINF",206,0) "RTN","TMGBINF",207,0) quit result "RTN","TMGBINF",208,0) "RTN","TMGBINF",209,0) "RTN","TMGBINF",210,0) CPYBG(srcGRef,srcIncSubscr,dstGRef,dstIncSubscr,width) "RTN","TMGBINF",211,0) "RTN","TMGBINF",212,0) ;"*** NOTICE: THIS FUNCTION IS NOT WORKING PROPERLY, IT REPEATS THE DATA IN BLOCKS...*** "RTN","TMGBINF",213,0) "RTN","TMGBINF",214,0) ;"Purpose: COPY/RESIZE BINARY GLOBAL. This can be used to change the number of bytes "RTN","TMGBINF",215,0) ;" stored on each line of a binary global array "RTN","TMGBINF",216,0) ;"Input: "RTN","TMGBINF",217,0) ;" srcGRef-- Global reference of the SOURCE binary global array, in fully resolved "RTN","TMGBINF",218,0) ;" (closed root) format. "RTN","TMGBINF",219,0) ;" Note: "RTN","TMGBINF",220,0) ;" At least one subscript must be numeric. This will be the incrementing "RTN","TMGBINF",221,0) ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment "RTN","TMGBINF",222,0) ;" to store each new global node). This subscript need not be the final "RTN","TMGBINF",223,0) ;" subscript. For example, to load into a WORD PROCESSING field, the "RTN","TMGBINF",224,0) ;" incrementing node is the second-to-last subscript; the final subscript "RTN","TMGBINF",225,0) ;" is always zero. "RTN","TMGBINF",226,0) ;" REQUIRED "RTN","TMGBINF",227,0) ;" srcIncSubscr-- (required) Identifies the incrementing subscript level, for the source global "RTN","TMGBINF",228,0) ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and "RTN","TMGBINF",229,0) ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third "RTN","TMGBINF",230,0) ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global "RTN","TMGBINF",231,0) ;" reference, such as ^TMP(115,1,x,0). "RTN","TMGBINF",232,0) ;" REQUIRED "RTN","TMGBINF",233,0) ;" dstGRef-- Global reference of the DESTINATION binary global array, in fully resolved "RTN","TMGBINF",234,0) ;" (closed root) format. The destination IS NOT KILLED prior to filling with "RTN","TMGBINF",235,0) ;" new data "RTN","TMGBINF",236,0) ;" Note: "RTN","TMGBINF",237,0) ;" At least one subscript must be numeric. (same as note above) "RTN","TMGBINF",238,0) ;" REQUIRED "RTN","TMGBINF",239,0) ;" dstIncSubscr-- (required) Identifies the incrementing subscript level, for the source global "RTN","TMGBINF",240,0) ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and "RTN","TMGBINF",241,0) ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third "RTN","TMGBINF",242,0) ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global "RTN","TMGBINF",243,0) ;" reference, such as ^TMP(115,1,x,0). "RTN","TMGBINF",244,0) ;" REQUIRED "RTN","TMGBINF",245,0) ;" width-- The number of bytes to store per line in the DESTINATION array. "RTN","TMGBINF",246,0) ;" REQUIRED "RTN","TMGBINF",247,0) ;" "RTN","TMGBINF",248,0) ;"Output: @dstGRef is filled with data "RTN","TMGBINF",249,0) ;"Result: None "RTN","TMGBINF",250,0) "RTN","TMGBINF",251,0) "RTN","TMGBINF",252,0) ;"*** NOTICE: THIS FUNCTION IS NOT WORKING PROPERLY, IT REPEATS THE DATA IN BLOCKS...*** "RTN","TMGBINF",253,0) "RTN","TMGBINF",254,0) new readPos set readPos=1 "RTN","TMGBINF",255,0) new bytesRead "RTN","TMGBINF",256,0) if $get(srcGRef)="" goto CPYBGDone "RTN","TMGBINF",257,0) if $get(dstGRef)="" goto CPYBGDone "RTN","TMGBINF",258,0) if $get(srcIncSubscr)="" goto CPYBGDone "RTN","TMGBINF",259,0) if $get(dstIncSubscr)="" goto CPYBGDone "RTN","TMGBINF",260,0) if $get(width)="" goto CPYBGDone "RTN","TMGBINF",261,0) "RTN","TMGBINF",262,0) for do quit:(bytesRead=0) "RTN","TMGBINF",263,0) . set @dstGRef=$$READBG(srcGRef,srcIncSubscr,readPos,width,.bytesRead) "RTN","TMGBINF",264,0) . if (bytesRead=0) kill @dstGRef "RTN","TMGBINF",265,0) . set readPos=readPos+bytesRead "RTN","TMGBINF",266,0) . set dstGRef=$$NEXTNODE(dstGRef,dstIncSubscr,0,1) "RTN","TMGBINF",267,0) "RTN","TMGBINF",268,0) CPYBGDone "RTN","TMGBINF",269,0) quit "RTN","TMGBINF",270,0) "RTN","TMGBINF",271,0) "RTN","TMGBINF",272,0) "RTN","TMGBINF",273,0) READBG(GRef,incSubscr,pos,count,actualCount) "RTN","TMGBINF",274,0) ;"SCOPE: PUBLIC "RTN","TMGBINF",275,0) ;"Purpose: To read 'count' bytes from binary global '@srcGRef', starting at 'pos' "RTN","TMGBINF",276,0) ;"Input: "RTN","TMGBINF",277,0) ;" GRef-- Global reference of the binary global array, in fully resolved "RTN","TMGBINF",278,0) ;" (closed root) format. "RTN","TMGBINF",279,0) ;" Note: "RTN","TMGBINF",280,0) ;" At least one subscript must be numeric. This will be the incrementing "RTN","TMGBINF",281,0) ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment "RTN","TMGBINF",282,0) ;" to store each new global node). This subscript need not be the final "RTN","TMGBINF",283,0) ;" subscript. For example, to load into a WORD PROCESSING field, the "RTN","TMGBINF",284,0) ;" incrementing node is the second-to-last subscript; the final subscript "RTN","TMGBINF",285,0) ;" is always zero. "RTN","TMGBINF",286,0) ;" REQUIRED "RTN","TMGBINF",287,0) ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global "RTN","TMGBINF",288,0) ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and "RTN","TMGBINF",289,0) ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third "RTN","TMGBINF",290,0) ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global "RTN","TMGBINF",291,0) ;" reference, such as ^TMP(115,1,x,0). "RTN","TMGBINF",292,0) ;" REQUIRED "RTN","TMGBINF",293,0) ;" Pos-- The position in the binary global to start reading from (0 is first byte), as if "RTN","TMGBINF",294,0) ;" entire global array is one long binary stream. E.g. the 913th byte might be "RTN","TMGBINF",295,0) ;" actually the 17th byte on the 14th line (if 64 bytes are stored per line). But "RTN","TMGBINF",296,0) ;" this is handled transparently and the user need only specify byte #913 etc. "RTN","TMGBINF",297,0) ;" . The reading will start at the appropriate point. "RTN","TMGBINF",298,0) ;" count-- The number of bytes/characters to read. "RTN","TMGBINF",299,0) ;" actualCount-- OPTIONAL. An OUT PARAMETER -- PASS BY REFERENCE "RTN","TMGBINF",300,0) ;" This is filled with the actual number of bytes/characters successfully read. "RTN","TMGBINF",301,0) ;"Result: a string filled with requested number of bytes/characters "RTN","TMGBINF",302,0) "RTN","TMGBINF",303,0) new result set result="" "RTN","TMGBINF",304,0) new countPerLine "RTN","TMGBINF",305,0) new goalLen set goalLen=count "RTN","TMGBINF",306,0) new Line,p1 "RTN","TMGBINF",307,0) new done "RTN","TMGBINF",308,0) if $get(GRef)="" goto ReadBGDone "RTN","TMGBINF",309,0) set countPerLine=$length(@GRef) "RTN","TMGBINF",310,0) if (countPerLine=0) goto ReadBGDone "RTN","TMGBINF",311,0) "RTN","TMGBINF",312,0) set Line=pos\countPerLine "RTN","TMGBINF",313,0) set p1=pos#countPerLine "RTN","TMGBINF",314,0) "RTN","TMGBINF",315,0) for do quit:(done=1)!(count<1) "RTN","TMGBINF",316,0) . new curRef "RTN","TMGBINF",317,0) . set done=0 "RTN","TMGBINF",318,0) . set curRef=$$NEXTNODE(GRef,incSubscr,1,Line) "RTN","TMGBINF",319,0) . if curRef="" set done=1 quit "RTN","TMGBINF",320,0) . set result=result_$extract(@GRef,p1,p1+count-1) "RTN","TMGBINF",321,0) . set count=goalLen-$length(result) "RTN","TMGBINF",322,0) . if count<1 set done=1 quit "RTN","TMGBINF",323,0) . set Line=Line+1 "RTN","TMGBINF",324,0) . set p1=1 "RTN","TMGBINF",325,0) "RTN","TMGBINF",326,0) ReadBGDone "RTN","TMGBINF",327,0) set actualCount=$length(result) "RTN","TMGBINF",328,0) quit result "RTN","TMGBINF",329,0) "RTN","TMGBINF",330,0) "RTN","TMGBROWS") 0^3^B6541 "RTN","TMGBROWS",1,0) TMGBROWS ;TMG/kst/Record browser ;03/25/06 "RTN","TMGBROWS",2,0) ;;1.0;TMG-LIB;**1**;03/10/07 "RTN","TMGBROWS",3,0) "RTN","TMGBROWS",4,0) ;" TMG BROWSE RECORDS "RTN","TMGBROWS",5,0) ;"Kevin Toppenberg MD "RTN","TMGBROWS",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGBROWS",7,0) ;"3-10-2007 "RTN","TMGBROWS",8,0) "RTN","TMGBROWS",9,0) ;"======================================================================= "RTN","TMGBROWS",10,0) ;" API -- Public Functions. "RTN","TMGBROWS",11,0) ;"======================================================================= "RTN","TMGBROWS",12,0) ;"ASKBROWSE -- browse records, and follow pointers "RTN","TMGBROWS",13,0) "RTN","TMGBROWS",14,0) ;"======================================================================= "RTN","TMGBROWS",15,0) ;" Private Functions. "RTN","TMGBROWS",16,0) ;"======================================================================= "RTN","TMGBROWS",17,0) ;"Browse(FileNum,IENS,ShowEmpty) --Browse a record, allowing display of "RTN","TMGBROWS",18,0) ;" the current record, or follow pointers to other records. "RTN","TMGBROWS",19,0) ;"DispRec(FileNum,IEN) -- To display record "RTN","TMGBROWS",20,0) "RTN","TMGBROWS",21,0) ;"======================================================================= "RTN","TMGBROWS",22,0) "RTN","TMGBROWS",23,0) "RTN","TMGBROWS",24,0) ASKBROWSE "RTN","TMGBROWS",25,0) ;"Purpose: To browse records, and follow pointers. "RTN","TMGBROWS",26,0) "RTN","TMGBROWS",27,0) write !!," -= RECORD BROWSE =-",! "RTN","TMGBROWS",28,0) new FIENS,IENS "RTN","TMGBROWS",29,0) AL1 "RTN","TMGBROWS",30,0) set FIENS=$$AskFIENS^TMGDBAPI() "RTN","TMGBROWS",31,0) if (FIENS["?")!(FIENS="^") goto ASKDone "RTN","TMGBROWS",32,0) "RTN","TMGBROWS",33,0) set FileNum=$piece(FIENS,"^",1) "RTN","TMGBROWS",34,0) set IENS=$piece(FIENS,"^",2) "RTN","TMGBROWS",35,0) "RTN","TMGBROWS",36,0) AL2 "RTN","TMGBROWS",37,0) set IENS=$$AskIENS^TMGDBAPI(FileNum,IENS) "RTN","TMGBROWS",38,0) if (IENS["?")!(IENS="") goto AL1 "RTN","TMGBROWS",39,0) "RTN","TMGBROWS",40,0) new % set %=2 "RTN","TMGBROWS",41,0) write "Display empty fields" "RTN","TMGBROWS",42,0) do YN^DICN "RTN","TMGBROWS",43,0) if %=-1 write ! goto ASKDone "RTN","TMGBROWS",44,0) "RTN","TMGBROWS",45,0) ;"Do the output "RTN","TMGBROWS",46,0) write ! do Browse(FileNum,IENS,(%=1)) "RTN","TMGBROWS",47,0) set IENS=$piece(IENS,",",2,99) ;"force Pick of new record to dump "RTN","TMGBROWS",48,0) if +IENS>0 goto AL2 "RTN","TMGBROWS",49,0) goto AL1 "RTN","TMGBROWS",50,0) "RTN","TMGBROWS",51,0) "RTN","TMGBROWS",52,0) ASKDone "RTN","TMGBROWS",53,0) quit "RTN","TMGBROWS",54,0) "RTN","TMGBROWS",55,0) "RTN","TMGBROWS",56,0) Browse(FileNum,IENS,ShowEmpty) "RTN","TMGBROWS",57,0) ;"Purpose: Browse a record, allowing display of the current record, or "RTN","TMGBROWS",58,0) ;" follow pointers to other records. "RTN","TMGBROWS",59,0) ;"Input: FileNum -- the number of the file to browse "RTN","TMGBROWS",60,0) ;" IENS -- the record number to display (or IENS: #,#,#,) "RTN","TMGBROWS",61,0) ;" ShowEmpty -- OPTIONAL; if 1 then empty fields will be displayed "RTN","TMGBROWS",62,0) "RTN","TMGBROWS",63,0) new FldInfo,field "RTN","TMGBROWS",64,0) do GetPtrsOUT^TMGDBAPI(FileNum,.FldInfo) "RTN","TMGBROWS",65,0) "RTN","TMGBROWS",66,0) if $extract(IENS,$length(IENS))'="," set IENS=IENS_"," "RTN","TMGBROWS",67,0) "RTN","TMGBROWS",68,0) set field="" "RTN","TMGBROWS",69,0) for set field=$order(FldInfo(field)) quit:(field="") do "RTN","TMGBROWS",70,0) . new name set name=$$GetFldName^TMGDBAPI(FileNum,field) "RTN","TMGBROWS",71,0) . set FldInfo(field,"NAME")=name "RTN","TMGBROWS",72,0) "RTN","TMGBROWS",73,0) new Menu "RTN","TMGBROWS",74,0) new count set count=1 "RTN","TMGBROWS",75,0) write "File: ",$$GetFName^TMGDBAPI(FileNum),! "RTN","TMGBROWS",76,0) "RTN","TMGBROWS",77,0) set Menu(0)="File: "_$$GetFName^TMGDBAPI(FileNum)_" ("_FileNum_"), Record: "_IENS "RTN","TMGBROWS",78,0) set field="" "RTN","TMGBROWS",79,0) for set field=$order(FldInfo(field)) quit:(field="") do "RTN","TMGBROWS",80,0) . new ptr set ptr=$$GET1^DIQ(FileNum,IENS,field,"I") "RTN","TMGBROWS",81,0) . new otherName set otherName=$$GET1^DIQ(FileNum,IENS,field) "RTN","TMGBROWS",82,0) . if ptr="" quit "RTN","TMGBROWS",83,0) . new name set name=$$GetFldName^TMGDBAPI(FileNum,field) "RTN","TMGBROWS",84,0) . set Menu(count)="BROWSE: ("_field_") "_name_"--> "_otherName_$char(9)_FldInfo(field)_"|"_ptr "RTN","TMGBROWS",85,0) . set count=count+1 "RTN","TMGBROWS",86,0) "RTN","TMGBROWS",87,0) set Menu(count)="DUMP entire record"_$char(9)_"DUMP" "RTN","TMGBROWS",88,0) "RTN","TMGBROWS",89,0) M0 write # "RTN","TMGBROWS",90,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGBROWS",91,0) "RTN","TMGBROWS",92,0) if UsrSlct="DUMP" do DispRec(FileNum,IENS) goto M0 "RTN","TMGBROWS",93,0) if UsrSlct["|" do goto M0 "RTN","TMGBROWS",94,0) . new newFile set newFile=$piece(UsrSlct,"|",1) "RTN","TMGBROWS",95,0) . new IEN set IEN=$piece(UsrSlct,"|",2)_"," "RTN","TMGBROWS",96,0) . do Browse(newFile,IEN,.ShowEmpty) "RTN","TMGBROWS",97,0) if UsrSlct="^" goto MenuDone "RTN","TMGBROWS",98,0) goto M0 "RTN","TMGBROWS",99,0) "RTN","TMGBROWS",100,0) MenuDone "RTN","TMGBROWS",101,0) quit "RTN","TMGBROWS",102,0) "RTN","TMGBROWS",103,0) "RTN","TMGBROWS",104,0) DispRec(FileNum,IEN) "RTN","TMGBROWS",105,0) ;"Purpose: To display record "RTN","TMGBROWS",106,0) ;"Input: FileNum -- The File number to display "RTN","TMGBROWS",107,0) ;" IEN -- the IEN (record number) to display in file. "RTN","TMGBROWS",108,0) ;"Results: none "RTN","TMGBROWS",109,0) "RTN","TMGBROWS",110,0) write "File: ",$$GetFName^TMGDBAPI(FileNum),! "RTN","TMGBROWS",111,0) do DumpRec2^TMGDEBUG(FileNum,IEN_",",0) "RTN","TMGBROWS",112,0) do PressToCont^TMGUSRIF "RTN","TMGBROWS",113,0) "RTN","TMGBROWS",114,0) quit "RTN","TMGBROWS",115,0) "RTN","TMGBUTIL") 0^4^B7315 "RTN","TMGBUTIL",1,0) TMGBUTIL ;TMG/kst/Binary Global Data Utilities ;03/25/06 "RTN","TMGBUTIL",2,0) ;;1.0;TMG-LIB;**1**;08/20/05 "RTN","TMGBUTIL",3,0) "RTN","TMGBUTIL",4,0) ;"TMG BINARY GLOBAL DATA UTILITY FUNCTIONS "RTN","TMGBUTIL",5,0) ;"Kevin Toppenberg MD "RTN","TMGBUTIL",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGBUTIL",7,0) ;"8-20-2005 "RTN","TMGBUTIL",8,0) "RTN","TMGBUTIL",9,0) ;"======================================================================= "RTN","TMGBUTIL",10,0) ;" API -- Public Functions. "RTN","TMGBUTIL",11,0) ;"======================================================================= "RTN","TMGBUTIL",12,0) ;"DISPLAY(globalRef,incSubscr,offset,numLines,bytesPerLine) "RTN","TMGBUTIL",13,0) ;"BROWSE(globalRef,incSubscr) "RTN","TMGBUTIL",14,0) "RTN","TMGBUTIL",15,0) ;"======================================================================= "RTN","TMGBUTIL",16,0) ;"PRIVATE API FUNCTIONS "RTN","TMGBUTIL",17,0) ;"======================================================================= "RTN","TMGBUTIL",18,0) "RTN","TMGBUTIL",19,0) "RTN","TMGBUTIL",20,0) ;"======================================================================= "RTN","TMGBUTIL",21,0) ;"DEPENDENCIES "RTN","TMGBUTIL",22,0) ;"======================================================================= "RTN","TMGBUTIL",23,0) ;"Uses: TMGBINF "RTN","TMGBUTIL",24,0) ;" TMGMISC "RTN","TMGBUTIL",25,0) ;" TMGSTUTL "RTN","TMGBUTIL",26,0) "RTN","TMGBUTIL",27,0) ;"======================================================================= "RTN","TMGBUTIL",28,0) "RTN","TMGBUTIL",29,0) BROWSE(globalRef,incSubscr) "RTN","TMGBUTIL",30,0) ;"SCOPE: PUBLIC "RTN","TMGBUTIL",31,0) ;"Purpose: to browse a binary set as hex codes "RTN","TMGBUTIL",32,0) "RTN","TMGBUTIL",33,0) new offset set offset=0 "RTN","TMGBUTIL",34,0) new input "RTN","TMGBUTIL",35,0) for do quit:(offset="") "RTN","TMGBUTIL",36,0) . read "Offset to browse (? for help): ",input:$get(DTIME,3600),! "RTN","TMGBUTIL",37,0) . if input="?" write "^ to abort,A=browse up, Z=browse down",! quit "RTN","TMGBUTIL",38,0) . if input="^" set offset="" quit "RTN","TMGBUTIL",39,0) . if input="" set input="Z" "RTN","TMGBUTIL",40,0) . if "Aa"[input set offset=offset-(8*16) "RTN","TMGBUTIL",41,0) . if "Zz"[input set offset=offset+(8*16) "RTN","TMGBUTIL",42,0) . if $extract(input,1)="$" set input=$$HEX2NUM^TMGMISC(input) "RTN","TMGBUTIL",43,0) . if +input=input set offset=input "RTN","TMGBUTIL",44,0) . if +offset'=offset set offset="" quit "RTN","TMGBUTIL",45,0) . do DISPLAY(globalRef,incSubscr,offset,8,16) "RTN","TMGBUTIL",46,0) "RTN","TMGBUTIL",47,0) quit "RTN","TMGBUTIL",48,0) "RTN","TMGBUTIL",49,0) "RTN","TMGBUTIL",50,0) DISPLAY(globalRef,incSubscr,offset,numLines,bytesPerLine) "RTN","TMGBUTIL",51,0) ;"SCOPE: PUBLIC "RTN","TMGBUTIL",52,0) ;"Purpose: to display a binary set as hex codes "RTN","TMGBUTIL",53,0) ;"Input: gobalRef -- the reference of the beginning of the block (in closed form) "RTN","TMGBUTIL",54,0) ;" incSubscr-- (required) Identifies the incrementing subscript level. For example, if you "RTN","TMGBUTIL",55,0) ;" pass ^TMP(115,1,1,0) as the global_ref parameter and pass 3 as the "RTN","TMGBUTIL",56,0) ;" inc_subscr parameter, $$BIN2GBL will increment the third subscript, such "RTN","TMGBUTIL",57,0) ;" as ^TMP(115,1,x), but will WRITE notes at the full global reference, such "RTN","TMGBUTIL",58,0) ;" as ^TMP(115,1,x,0). "RTN","TMGBUTIL",59,0) ;" offset -- (OPTIONAL) the bytes offset from the beginning of the "RTN","TMGBUTIL",60,0) ;" block to start from. Default=0 "RTN","TMGBUTIL",61,0) ;" numLines -- (OPTIONAL) the number of lines to show. Default=8 "RTN","TMGBUTIL",62,0) ;" bytesPerLine -- (OPTIONAL) the number of bytes to show per line Default=16 "RTN","TMGBUTIL",63,0) ;"Output -- displays the hex bytes to the screen "RTN","TMGBUTIL",64,0) ;"Result -- none "RTN","TMGBUTIL",65,0) "RTN","TMGBUTIL",66,0) ;"Note: each line in the global ref is assumed to hold 512 bytes. "RTN","TMGBUTIL",67,0) "RTN","TMGBUTIL",68,0) new index,data "RTN","TMGBUTIL",69,0) new bytesNeeded "RTN","TMGBUTIL",70,0) new atEnd set atEnd=0 "RTN","TMGBUTIL",71,0) "RTN","TMGBUTIL",72,0) set offset=$get(offset,0) "RTN","TMGBUTIL",73,0) set numLines=$get(numLines,8) "RTN","TMGBUTIL",74,0) set bytesPerLine=$get(bytesPerLine,16) "RTN","TMGBUTIL",75,0) set bytesNeeded=numLines*bytesPerLine "RTN","TMGBUTIL",76,0) set index=offset\512 "RTN","TMGBUTIL",77,0) "RTN","TMGBUTIL",78,0) if index>0 set globalRef=$$NEXTNODE^TMGBINF(globalRef,incSubscr,1,index) "RTN","TMGBUTIL",79,0) if (globalRef="") goto DispDone "RTN","TMGBUTIL",80,0) set data=$extract($get(@globalRef),(offset#512)+1,512) "RTN","TMGBUTIL",81,0) "RTN","TMGBUTIL",82,0) for quit:($length(data)'0) do "RTN","TMGBUTIL",83,0) . set globalRef=$$NEXTNODE^TMGBINF(globalRef,incSubscr,1,1) "RTN","TMGBUTIL",84,0) . if (globalRef="") set atEnd=1 quit "RTN","TMGBUTIL",85,0) . new oneLine set oneLine=$get(@globalRef) "RTN","TMGBUTIL",86,0) . if oneLine="" set atEnd=1 quit "RTN","TMGBUTIL",87,0) . set data=data_$extract(oneLine,1,bytesNeeded-$length(data)) "RTN","TMGBUTIL",88,0) "RTN","TMGBUTIL",89,0) ;"Now display data "RTN","TMGBUTIL",90,0) new dispLine "RTN","TMGBUTIL",91,0) new dispOffset set dispOffset=offset "RTN","TMGBUTIL",92,0) for quit:($length(data)=0) do "RTN","TMGBUTIL",93,0) . set dispLine=$extract(data,1,bytesPerLine) "RTN","TMGBUTIL",94,0) . set data=$extract(data,bytesPerLine+1,bytesNeeded) "RTN","TMGBUTIL",95,0) . write "$",$$HEXCHR2^TMGMISC(dispOffset,6)," " "RTN","TMGBUTIL",96,0) . write $$STRB2H^TMGSTUTL(dispLine,1),! "RTN","TMGBUTIL",97,0) . set dispOffset=dispOffset+bytesPerLine "RTN","TMGBUTIL",98,0) "RTN","TMGBUTIL",99,0) "RTN","TMGBUTIL",100,0) DispDone "RTN","TMGBUTIL",101,0) quit "RTN","TMGCHR") 0^5^B22942466 "RTN","TMGCHR",1,0) TMGCHR ;TMG/kst/Custom version of CHRISTEN ;03/25/06 "RTN","TMGCHR",2,0) ;;1.0;TMG-LIB;**1**;11/01/04 "RTN","TMGCHR",3,0) "RTN","TMGCHR",4,0) ;"CHRISTEN(INFO) This library will provide optional NON-INTERACTIVE versions of standard code. "RTN","TMGCHR",5,0) "RTN","TMGCHR",6,0) ;"============================================================================= "RTN","TMGCHR",7,0) ;"Kevin Toppenberg, MD 11-04 "RTN","TMGCHR",8,0) ;" "RTN","TMGCHR",9,0) ;"Purpose: "RTN","TMGCHR",10,0) ;" "RTN","TMGCHR",11,0) ;"This library will provide optional NON-INTERACTIVE versions of standard code. "RTN","TMGCHR",12,0) ;" "RTN","TMGCHR",13,0) ;"CHRISTEN(INFO) "RTN","TMGCHR",14,0) ;" "RTN","TMGCHR",15,0) ;"Dependancies: "RTN","TMGCHR",16,0) ;" TMGQIO "RTN","TMGCHR",17,0) ;"============================================================================= "RTN","TMGCHR",18,0) "RTN","TMGCHR",19,0) MUDCHR ;ISC-SF/GMB-Christen Site ;04/17/2002 11:48 "RTN","TMGCHR",20,0) ;;8.0;MailMan;;Jun 28, 2002 "RTN","TMGCHR",21,0) ; Entry points used by MailMan options (not covered by DBIA): "RTN","TMGCHR",22,0) ; CHRISTEN XMCHRIS - Edit MailMan Site Parameters "RTN","TMGCHR",23,0) ;" "RTN","TMGCHR",24,0) ;"K. Toppenberg's changes made November, 2004 "RTN","TMGCHR",25,0) ;" "RTN","TMGCHR",26,0) ;"Input: "RTN","TMGCHR",27,0) ;" Note: INFO variable is completely an OPTIONAL parameter. "RTN","TMGCHR",28,0) ;" If not supplied, interactive mode used "RTN","TMGCHR",29,0) ;" INFO("SILENT-OUTPUT") -- 1 = output is supressed. "RTN","TMGCHR",30,0) ;" INFO("SILENT-INPUT") -- 1 = User-interactive input is supressed. "RTN","TMGCHR",31,0) ;" "RTN","TMGCHR",32,0) ;" ** if in SILENT-INPUT mode, THEN the following data should be supplied: "RTN","TMGCHR",33,0) ;" ---------------------- "RTN","TMGCHR",34,0) ;" INFO("DOMAIN") -- Answer for 'DOMAIN' to edit-- should be an existing domain "RTN","TMGCHR",35,0) ;" INFO("PARENT") -- Answer for 'PARENT' domain question "RTN","TMGCHR",36,0) ;" INFO("TIMEZONE") -- Answer for 'TIME ZONE' question "RTN","TMGCHR",37,0) ;" INFO("CONTINUE") -- Answer for "Are you sure you want to change the name of this facility" "RTN","TMGCHR",38,0) ;"Output: "RTN","TMGCHR",39,0) ;" If in SILENT-OUTPUT mode, then output that would normally go to the screen, will be routed to this array "RTN","TMGCHR",40,0) ;" NOTE: INFO SHOULD BE PASSED BY REFERENCE if user wants this information passed back out. "RTN","TMGCHR",41,0) ;" INFO("TEXT","LINES")=Number of output lines "RTN","TMGCHR",42,0) ;" INFO("TEXT",1)= 1st output line "RTN","TMGCHR",43,0) ;" INFO("TEXT",2)= 2nd output line, etc... "RTN","TMGCHR",44,0) ; "RTN","TMGCHR",45,0) ; "RTN","TMGCHR",46,0) CHRISTEN(INFO) ;Set up/Change MailMan Site Parameters "RTN","TMGCHR",47,0) ; "RTN","TMGCHR",48,0) NEW SILNTOUT SET SILNTOUT=$get(INFO("SILENT-OUTPUT"),0) ;//kt "RTN","TMGCHR",49,0) NEW SILENTIN SET SILENTIN=$GET(INFO("SILENT-INPUT"),0) ;//KT "RTN","TMGCHR",50,0) KILL INFO("TEXT") ;//kt "RTN","TMGCHR",51,0) "RTN","TMGCHR",52,0) N XMREC,XMABORT "RTN","TMGCHR",53,0) S XMABORT=0 "RTN","TMGCHR",54,0) S XMREC=$G(^XMB(1,1,0)) I '+XMREC,$O(^XMB(1,0)) G E "RTN","TMGCHR",55,0) I XMREC="" D "RTN","TMGCHR",56,0) . D INIT "RTN","TMGCHR",57,0) E D "RTN","TMGCHR",58,0) . D CHANGE "RTN","TMGCHR",59,0) Q:XMABORT "RTN","TMGCHR",60,0) D PARENT "RTN","TMGCHR",61,0) D SCRIPT "RTN","TMGCHR",62,0) G Q "RTN","TMGCHR",63,0) ; "RTN","TMGCHR",64,0) ; "RTN","TMGCHR",65,0) ;====================================================================== "RTN","TMGCHR",66,0) INIT ; Initial Christening "RTN","TMGCHR",67,0) N DIC,DIE,Y,DA,XMFDA "RTN","TMGCHR",68,0) ; "RTN","TMGCHR",69,0) S DIC=4.2 "RTN","TMGCHR",70,0) IF SILENTIN=1 DO "RTN","TMGCHR",71,0) . S DIC(0)="EM" "RTN","TMGCHR",72,0) . SET X=$GET(INFO("DOMAIN")) "RTN","TMGCHR",73,0) ELSE DO "RTN","TMGCHR",74,0) . S DIC(0)="AEMQ" "RTN","TMGCHR",75,0) D ^DIC "RTN","TMGCHR",76,0) I Y<1 S XMABORT=1 D E1 Q "RTN","TMGCHR",77,0) S XMFDA(4.3,"+1,",.01)=+Y "RTN","TMGCHR",78,0) D UPDATE^DIE("","XMFDA") "RTN","TMGCHR",79,0) K DIC,Y "RTN","TMGCHR",80,0) do InputParent "RTN","TMGCHR",81,0) ;"if SILENTIN>0 do ;"Note: Fields 3=PARENT, 1=TIME ZONE "RTN","TMGCHR",82,0) ;". set DR="3///"_$get(INFO("PARENT"),"FORUM.VA.GOV") ;"3 '/'s means force the data in "RTN","TMGCHR",83,0) ;". set DR=DR_";1///"_$get(INFO("PARENT"),"EST") "RTN","TMGCHR",84,0) ;"else do "RTN","TMGCHR",85,0) ;". S DR="3//FORUM.VA.GOV;1//EST" ;"2 '/'s means ask user, with default suggestion. "RTN","TMGCHR",86,0) ;"S DIE=4.3 ;"MAILMAN SITE PARAMETERS "RTN","TMGCHR",87,0) ;"S DA=1 ;"Record#/IEN = 1 "RTN","TMGCHR",88,0) ;"D ^DIE ;"Input selected data elements to a given record. (only for existing records) "RTN","TMGCHR",89,0) I $D(Y) S XMABORT=1 D E1 "RTN","TMGCHR",90,0) Q "RTN","TMGCHR",91,0) ; "RTN","TMGCHR",92,0) ; "RTN","TMGCHR",93,0) ;======================================================================= "RTN","TMGCHR",94,0) CHANGE ; "RTN","TMGCHR",95,0) N XMSITE,DIE,DA,DR,DIC,X,Yi "RTN","TMGCHR",96,0) IF $D(^XMB("NETNAME")) SET XMSITE=^XMB("NETNAME") "RTN","TMGCHR",97,0) ELSE IF $D(^XMB("NAME")) SET XMSITE=^XMB("NAME") "RTN","TMGCHR",98,0) ELSE IF $D(^DIC(4.2,+XMREC,0)) SET XMSITE=$P(^(0),U) "RTN","TMGCHR",99,0) ELSE SET XMSITE=XMREC "RTN","TMGCHR",100,0) I $$SURE(XMSITE)=0 S XMABORT=1 Q ; Are you sure? "RTN","TMGCHR",101,0) S DIC=4.2 "RTN","TMGCHR",102,0) IF SILENTIN=0 DO "RTN","TMGCHR",103,0) . S DIC(0)="AEMQ" "RTN","TMGCHR",104,0) . S DIC("B")=$S($D(^DIC(4.2,+XMREC,0)):$P(^(0),U),1:XMSITE) "RTN","TMGCHR",105,0) ELSE DO "RTN","TMGCHR",106,0) . SET DIC(0)="EM" "RTN","TMGCHR",107,0) . SET DIC("B")="" "RTN","TMGCHR",108,0) . SET X=$GET(INFO("DOMAIN")) "RTN","TMGCHR",109,0) D ^DIC "RTN","TMGCHR",110,0) I Y=-1 S XMABORT=1 Q "RTN","TMGCHR",111,0) I XMSITE'=$P(Y,U,2) D "RTN","TMGCHR",112,0) . I +Y=^XMB("NUM") D "RTN","TMGCHR",113,0) . . ; The domain name in file 4.2 has been changed. "RTN","TMGCHR",114,0) . . ; The pointer to file 4.2 has stayed the same. "RTN","TMGCHR",115,0) . . ; The filer won't fire the xrefs, so we need to do it manually "RTN","TMGCHR",116,0) . . S (^XMB("NETNAME"),^XMB("NAME"))=$P(Y,U,2) "RTN","TMGCHR",117,0) . E D "RTN","TMGCHR",118,0) . . N XMFDA "RTN","TMGCHR",119,0) . . S XMFDA(4.3,"1,",.01)=+Y "RTN","TMGCHR",120,0) . . D FILE^DIE("","XMFDA") "RTN","TMGCHR",121,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","The domain name for this facility is now: ",^XMB("NETNAME")) "RTN","TMGCHR",122,0) E D "RTN","TMGCHR",123,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","The domain name for this facility remains: ",^XMB("NETNAME")) "RTN","TMGCHR",124,0) K DIC,Y "RTN","TMGCHR",125,0) do InputParent "RTN","TMGCHR",126,0) ;"S DR="3//FORUM.VA.GOV;1//EST" "RTN","TMGCHR",127,0) ;"S DIE=4.3,DA=1 "RTN","TMGCHR",128,0) ;"D ^DIE "RTN","TMGCHR",129,0) Q "RTN","TMGCHR",130,0) ; "RTN","TMGCHR",131,0) ; "RTN","TMGCHR",132,0) ;======================================================================= "RTN","TMGCHR",133,0) InputParent "RTN","TMGCHR",134,0) if SILENTIN>0 do ;"Note: Fields 3=PARENT, 1=TIME ZONE "RTN","TMGCHR",135,0) . set DR="3///"_$get(INFO("PARENT"),"FORUM.VA.GOV") ;"3 '/'s means force the data in "RTN","TMGCHR",136,0) . set DR=DR_";1///"_$get(INFO("PARENT"),"EST") "RTN","TMGCHR",137,0) else do "RTN","TMGCHR",138,0) . S DR="3//FORUM.VA.GOV;1//EST" ;"2 '/'s means ask user, with default suggestion. "RTN","TMGCHR",139,0) S DIE=4.3 ;"MAILMAN SITE PARAMETERS "RTN","TMGCHR",140,0) S DA=1 ;"Record#/IEN = 1 "RTN","TMGCHR",141,0) D ^DIE ;"Input selected data elements to a given record. (only for existing records) "RTN","TMGCHR",142,0) quit "RTN","TMGCHR",143,0) ; "RTN","TMGCHR",144,0) ; "RTN","TMGCHR",145,0) ;======================================================================= "RTN","TMGCHR",146,0) SURE(XMSITE) ; Function returns 1 if sure; 0 if not "RTN","TMGCHR",147,0) N DIR,X,Y "RTN","TMGCHR",148,0) N RESULT SET RESULT=0 ; Default to not sure "RTN","TMGCHR",149,0) ; "RTN","TMGCHR",150,0) DO OUTP^TMGQIO(SILNTOUT,"!","!"," * * * * WARNING * * * *","!","!") "RTN","TMGCHR",151,0) DO OUTP^TMGQIO(SILNTOUT,"You are about to change the domain name of this facility","!") "RTN","TMGCHR",152,0) DO OUTP^TMGQIO(SILNTOUT,"in the MailMan Site Parameters file.","!") "RTN","TMGCHR",153,0) DO OUTP^TMGQIO(SILNTOUT,"Currently, this facility is named: ",XMSITE,"!","!") "RTN","TMGCHR",154,0) DO OUTP^TMGQIO(SILNTOUT,"You must be extremely sure before you proceed!","!") "RTN","TMGCHR",155,0) DO OUTP^TMGQIO(SILENTIN,"Are you sure you want to change the name of this facility? NO//") "RTN","TMGCHR",156,0) DO INP^TMGQIO(.X,SILENTIN,120,$GET(INFO("CONTINUE"))) "RTN","TMGCHR",157,0) IF X="" SET X="NO" "RTN","TMGCHR",158,0) IF "Yy"[$E(X_"N") SET RESULT=1 ;Yes, I'm sure! "RTN","TMGCHR",159,0) Q RESULT "RTN","TMGCHR",160,0) ; "RTN","TMGCHR",161,0) ; "RTN","TMGCHR",162,0) PARENT ; "RTN","TMGCHR",163,0) N XMPARENT "RTN","TMGCHR",164,0) S XMPARENT=+$G(^XMB("PARENT")) "RTN","TMGCHR",165,0) I XMPARENT S XMPARENT=$S($D(^DIC(4.2,XMPARENT,0)):$P(^(0),U),1:0) "RTN","TMGCHR",166,0) I XMPARENT'=0 D "RTN","TMGCHR",167,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!",XMPARENT," has been initialized as your 'parent' domain.") "RTN","TMGCHR",168,0) . DO OUTP^TMGQIO(SILNTOUT,"!","(Forum is usually the parent domain, unless this is a subordinate domain.)") "RTN","TMGCHR",169,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","You may edit the MailMan Site Parameter file to change your parent domain.") "RTN","TMGCHR",170,0) E D "RTN","TMGCHR",171,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!",$C(7),"*** YOUR PARENT DOMAIN HAS NOT BEEN INITIALIZED !!! ***") "RTN","TMGCHR",172,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","You MUST edit the MailMan Site Parameter file to ENTER your parent domain.") "RTN","TMGCHR",173,0) Q "RTN","TMGCHR",174,0) ; "RTN","TMGCHR",175,0) ; "RTN","TMGCHR",176,0) SCRIPT ;RESET AUSTIN SCRIPT "RTN","TMGCHR",177,0) ;G SCRIPT^XMYPDOM "RTN","TMGCHR",178,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","We will not initialize your transmission scripts.") "RTN","TMGCHR",179,0) Q "RTN","TMGCHR",180,0) ; "RTN","TMGCHR",181,0) ; "RTN","TMGCHR",182,0) ;======================================================================= "RTN","TMGCHR",183,0) Q DO OUTP^TMGQIO(SILNTOUT,"!","!","Use the 'Subroutine editor' option under network management menu to add your") "RTN","TMGCHR",184,0) DO OUTP^TMGQIO(SILNTOUT,"!","site passwords to the MINIENGINE script, and the 'Edit a script' option") "RTN","TMGCHR",185,0) DO OUTP^TMGQIO(SILNTOUT,"!","to edit any domain scripts that you choose to.") "RTN","TMGCHR",186,0) ;D ^XMYPDOM "RTN","TMGCHR",187,0) Q "RTN","TMGCHR",188,0) ; "RTN","TMGCHR",189,0) ; "RTN","TMGCHR",190,0) ;====================================================================== "RTN","TMGCHR",191,0) PMB S Y=Y+1000 "RTN","TMGCHR",192,0) S ^XMB(3.7,.5,2,+Y,1,0)=^TMP("XM",I,1,0) "RTN","TMGCHR",193,0) S ^XMB(3.7,.5,2,"B",$E($P(Y(0),U,1),1,30),+Y)="" "RTN","TMGCHR",194,0) S ^XMB(3.7,.5,2,+Y,0)=$P(Y(0),U) "RTN","TMGCHR",195,0) F J=0:0 DO Q:J'>0 "RTN","TMGCHR",196,0) . S J=$O(^TMP("XM",I,1,J)) "RTN","TMGCHR",197,0) . Q:J'>0 "RTN","TMGCHR",198,0) . S ^XMB(3.7,.5,2,+Y,1,J,0)=J "RTN","TMGCHR",199,0) . W "." "RTN","TMGCHR",200,0) Q "RTN","TMGCHR",201,0) ; "RTN","TMGCHR",202,0) ; "RTN","TMGCHR",203,0) E DO OUTP^TMGQIO(SILNTOUT,$C(7),"!","!") "RTN","TMGCHR",204,0) DO OUTP^TMGQIO(SILNTOUT,"There is a FILE INTEGRITY problem in your MailMan Site Parameters file","!") "RTN","TMGCHR",205,0) DO OUTP^TMGQIO(SILNTOUT,"There should only be one entry and that entry should be entry number 1.","!") "RTN","TMGCHR",206,0) E1 DO OUTP^TMGQIO(SILNTOUT,$C(7),"!") "RTN","TMGCHR",207,0) DO OUTP^TMGQIO(SILNTOUT,"Your MailMan site parameters MUST be reviewed.","!") "RTN","TMGCHR",208,0) EQ DO OUTP^TMGQIO(SILNTOUT,"Then you can finish the INIT by executing POST^XMYPOST.","!","!") "RTN","TMGCHR",209,0) Q "RTN","TMGCHR",210,0) E2 DO OUTP^TMGQIO(SILNTOUT,$C(7),"!","You do not yet have an entry in your MailMan Site Parameters File","!") "RTN","TMGCHR",211,0) DO OUTP^TMGQIO(SILNTOUT,"Use FileMan to make an entry.","!") "RTN","TMGCHR",212,0) G EQ "RTN","TMGCHR",213,0) "RTN","TMGCHR",214,0) "RTN","TMGDBAP2") 0^6^B3476 "RTN","TMGDBAP2",1,0) TMGDBAP2 ;TMG/kst/Database API library 2 ;03/25/06 "RTN","TMGDBAP2",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGDBAP2",3,0) "RTN","TMGDBAP2",4,0) "RTN","TMGDBAP2",5,0) ;"This module holds moved functions from TMGDBAPI (moved due to size constraints) "RTN","TMGDBAP2",6,0) "RTN","TMGDBAP2",7,0) ConvertFDA(FDA,MarkerArray) "RTN","TMGDBAP2",8,0) ;"Purpose: To convert all the IENS's in a FDA via ConvertIENS "RTN","TMGDBAP2",9,0) ;"Input: FDA -- An FDA that need conversion. MUST PASS BY REFERENCE "RTN","TMGDBAP2",10,0) ;" Expected FDA is as follows. I.e., expecting that "RTN","TMGDBAP2",11,0) ;" there will only be ONE filenumber (the 19.01) part: "RTN","TMGDBAP2",12,0) ;" FDA(*) "RTN","TMGDBAP2",13,0) ;" }~19.01 "RTN","TMGDBAP2",14,0) ;" }~?+4,?+2, "RTN","TMGDBAP2",15,0) ;" | }~.01 = DIUSER "RTN","TMGDBAP2",16,0) ;" | }~2 = FM2 "RTN","TMGDBAP2",17,0) ;" | }~3 = 1 "RTN","TMGDBAP2",18,0) ;" | "RTN","TMGDBAP2",19,0) ;" }~?+5,?+2, "RTN","TMGDBAP2",20,0) ;" | }~.01 = XMMGR "RTN","TMGDBAP2",21,0) ;" | }~2 = X2 "RTN","TMGDBAP2",22,0) ;" | }~3 = 1 "RTN","TMGDBAP2",23,0) ;" | "RTN","TMGDBAP2",24,0) ;" }~?+6,?+2, "RTN","TMGDBAP2",25,0) ;" }~.01 = DIEDIT "RTN","TMGDBAP2",26,0) ;" }~2 = Edit "RTN","TMGDBAP2",27,0) ;" }~3 = 2 "RTN","TMGDBAP2",28,0) ;" MarkerArray -- see documentation in ConvertIENS "RTN","TMGDBAP2",29,0) ;"Output: FDA is changed "RTN","TMGDBAP2",30,0) ;"Result: 1=OKToContinue, 0=Abort "RTN","TMGDBAP2",31,0) "RTN","TMGDBAP2",32,0) "RTN","TMGDBAP2",33,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",34,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",35,0) new cAbort set cAbort=0 "RTN","TMGDBAP2",36,0) new cParentIENS set cParentIENS="ParentIENS" "RTN","TMGDBAP2",37,0) new cRef set cRef="Ref" "RTN","TMGDBAP2",38,0) "RTN","TMGDBAP2",39,0) "RTN","TMGDBAP2",40,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI") "RTN","TMGDBAP2",41,0) "RTN","TMGDBAP2",42,0) new result set result=1 "RTN","TMGDBAP2",43,0) if $data(FDA)=0 set result=0 goto CvFDAQ "RTN","TMGDBAP2",44,0) new FileNum "RTN","TMGDBAP2",45,0) new Index "RTN","TMGDBAP2",46,0) new IENS,OldIENS "RTN","TMGDBAP2",47,0) "RTN","TMGDBAP2",48,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the FDA to convert") "RTN","TMGDBAP2",49,0) ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") "RTN","TMGDBAP2",50,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the MarkerArray") "RTN","TMGDBAP2",51,0) ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MarkerArray") "RTN","TMGDBAP2",52,0) "RTN","TMGDBAP2",53,0) set FileNum=$order(FDA("")) "RTN","TMGDBAP2",54,0) if +FileNum=0 set result=0 goto CvFDAQ "RTN","TMGDBAP2",55,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Looking at filenumber ",FileNum) "RTN","TMGDBAP2",56,0) set IENS=$order(FDA(FileNum,"")) "RTN","TMGDBAP2",57,0) for do quit:(IENS="") "RTN","TMGDBAP2",58,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS) "RTN","TMGDBAP2",59,0) . if IENS="" do quit "RTN","TMGDBAP2",60,0) . . set result=0 "RTN","TMGDBAP2",61,0) . set OldIENS=IENS "RTN","TMGDBAP2",62,0) . if $$ConvertIENS(.IENS,.MarkerArray)=0 do quit "RTN","TMGDBAP2",63,0) . . set IENS="" "RTN","TMGDBAP2",64,0) . . set result=0 "RTN","TMGDBAP2",65,0) . if IENS'=OldIENS do "RTN","TMGDBAP2",66,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Converted to IENS=",IENS) "RTN","TMGDBAP2",67,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Convert FDA(FileNumber,"""_OldIENS_""") to FDA(Filenumber,"""_IENS_""")") "RTN","TMGDBAP2",68,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(FDA(FileNum,OLDIENS))=",$data(FDA(FileNum,OldIENS))) "RTN","TMGDBAP2",69,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is FDA so far") "RTN","TMGDBAP2",70,0) . . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") "RTN","TMGDBAP2",71,0) . . merge FDA(FileNum,IENS)=FDA(FileNum,OldIENS) "RTN","TMGDBAP2",72,0) . . set IENS=$order(FDA(FileNum,OldIENS)) "RTN","TMGDBAP2",73,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"killing FDA(FileNumber,"_OldIENS_")") "RTN","TMGDBAP2",74,0) . . kill FDA(FileNum,OldIENS) "RTN","TMGDBAP2",75,0) . else do "RTN","TMGDBAP2",76,0) . . set IENS=$order(FDA(FileNum,OldIENS)) "RTN","TMGDBAP2",77,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Resulting FDA so far") "RTN","TMGDBAP2",78,0) . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") "RTN","TMGDBAP2",79,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------") "RTN","TMGDBAP2",80,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of cycle. IENS=",IENS) "RTN","TMGDBAP2",81,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------") "RTN","TMGDBAP2",82,0) "RTN","TMGDBAP2",83,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After conversion, here is the FDA.") "RTN","TMGDBAP2",84,0) ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") "RTN","TMGDBAP2",85,0) "RTN","TMGDBAP2",86,0) CvFDAQ "RTN","TMGDBAP2",87,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI") "RTN","TMGDBAP2",88,0) quit result "RTN","TMGDBAP2",89,0) "RTN","TMGDBAP2",90,0) "RTN","TMGDBAP2",91,0) ConvertIENS(IENS,MarkerArray) "RTN","TMGDBAP2",92,0) ;"Purpose: to convert an IENS such as "?+4,?+2," into "?+4,12345,", given "RTN","TMGDBAP2",93,0) ;" the MarkerArray that corelates "2" to #"12345" "RTN","TMGDBAP2",94,0) ;"Input: IENS -- the IENS string to convert. MUST PASS BY REFERENCE "RTN","TMGDBAP2",95,0) ;" MarkerArray -- a composite array composed of results returned "RTN","TMGDBAP2",96,0) ;" by database server, like below. SHOULD PASS BY REFERENCE "RTN","TMGDBAP2",97,0) ;" MarkerArray(*) "RTN","TMGDBAP2",98,0) ;" }~2 = 10033 "RTN","TMGDBAP2",99,0) ;" }~0 = + "RTN","TMGDBAP2",100,0) ;" }~4 = 12345 "RTN","TMGDBAP2",101,0) ;" }~0 = + "RTN","TMGDBAP2",102,0) ;"Output: IENS will be changed "RTN","TMGDBAP2",103,0) ;"Result: 1=OkToContinue, 0=Abort "RTN","TMGDBAP2",104,0) "RTN","TMGDBAP2",105,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",106,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",107,0) new cAbort set cAbort=0 "RTN","TMGDBAP2",108,0) new cParentIENS set cParentIENS="ParentIENS" "RTN","TMGDBAP2",109,0) "RTN","TMGDBAP2",110,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI") "RTN","TMGDBAP2",111,0) "RTN","TMGDBAP2",112,0) new result set result=1 "RTN","TMGDBAP2",113,0) new S set S="" "RTN","TMGDBAP2",114,0) "RTN","TMGDBAP2",115,0) if $data(IENS)#10=0 set result=0 goto CvIENSQ "RTN","TMGDBAP2",116,0) if $data(MarkerArray)=0 set result=0 goto CvIENSQ "RTN","TMGDBAP2",117,0) "RTN","TMGDBAP2",118,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Initial IENS=",IENS) "RTN","TMGDBAP2",119,0) "RTN","TMGDBAP2",120,0) new I set I=1 "RTN","TMGDBAP2",121,0) for do quit:(I=-1) "RTN","TMGDBAP2",122,0) . new Part,RecMarker "RTN","TMGDBAP2",123,0) . set Part=$piece(IENS,",",I) "RTN","TMGDBAP2",124,0) . ;";"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"Part="_Part_" --> ",0) "RTN","TMGDBAP2",125,0) . if Part="" set I=-1 quit "RTN","TMGDBAP2",126,0) . set RecMarker=+$translate(Part,"?+","") "RTN","TMGDBAP2",127,0) . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"RecMarker="_RecMarker_" --> ",0) "RTN","TMGDBAP2",128,0) . new tS set tS=$get(MarkerArray(RecMarker),Part) "RTN","TMGDBAP2",129,0) . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"tS="_tS,1) "RTN","TMGDBAP2",130,0) . set S=S_tS_"," "RTN","TMGDBAP2",131,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"S so far=",S) "RTN","TMGDBAP2",132,0) . set I=I+1 "RTN","TMGDBAP2",133,0) "RTN","TMGDBAP2",134,0) set IENS=S "RTN","TMGDBAP2",135,0) "RTN","TMGDBAP2",136,0) CvIENSQ "RTN","TMGDBAP2",137,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI") "RTN","TMGDBAP2",138,0) quit result "RTN","TMGDBAP2",139,0) "RTN","TMGDBAP2",140,0) "RTN","TMGDBAP2",141,0) SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) "RTN","TMGDBAP2",142,0) ;"Purpose: to transfer from Data format to FDA format "RTN","TMGDBAP2",143,0) ;"Input: Data - Data array should be in format output from GetRInfo "RTN","TMGDBAP2",144,0) ;" FDA -- SHOULD BE PASSED BY REFERENCE (to receive results) "RTN","TMGDBAP2",145,0) ;" parentIENS -- initial IENS.. the IENS of any PARENT record, or "" if no parent record "RTN","TMGDBAP2",146,0) ;" SrchType -- should be "?", "+", or "?+" "RTN","TMGDBAP2",147,0) ;" MarkNum -- -- SHOULD BE PASSED BY REFERENCE. A variable to ensure "RTN","TMGDBAP2",148,0) ;" "?X" search term always has unique number. On first call, should=0 "RTN","TMGDBAP2",149,0) ;" MsgArray -- SHOULD BE PASSED BY REFERENCE. An array that can accept "RTN","TMGDBAP2",150,0) ;" messages back from function. "RTN","TMGDBAP2",151,0) ;" -- One such type of message is a list of needed hackwrites. "RTN","TMGDBAP2",152,0) ;" Format as follows: "RTN","TMGDBAP2",153,0) ;" MsgArray(cHack,0,Entries)=2 "RTN","TMGDBAP2",154,0) ;" MsgArray(cHack,1)="^VA(;200;?+1;.01;SomeData" "RTN","TMGDBAP2",155,0) ;" MsgArray(cHack,1,cFlags)="H" "RTN","TMGDBAP2",156,0) ;" MsgArray(cHack,2)="^VA(;200;?+1;.02;SomeMoreData" "RTN","TMGDBAP2",157,0) ;" MsgArray(cHack,2,cFlags)="H" "RTN","TMGDBAP2",158,0) ;" i.e. MsgArray(cHack,0,Entries)=Number of Entries "RTN","TMGDBAP2",159,0) ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data "RTN","TMGDBAP2",160,0) ;" MsgArray(n,cFlags)=User specified Flags for field. "RTN","TMGDBAP2",161,0) ;" -- MsgArray(cRef,SubFileNumber)=Reference to Part of Data that created this. "RTN","TMGDBAP2",162,0) ;" MsgArray(*) "RTN","TMGDBAP2",163,0) ;" }~cRef "RTN","TMGDBAP2",164,0) ;" }~1234.21 = "Data(6,".07") "RTN","TMGDBAP2",165,0) ;" }~1234.2101 = "Data(6,".07",2,".04") "RTN","TMGDBAP2",166,0) ;" Minimal -- OPTIONAL. 1=fill only .01 fields and subfile .01 fields "RTN","TMGDBAP2",167,0) ;" RecNum -- OPTIONAL. If FDA is to be setup such that data is put into "RTN","TMGDBAP2",168,0) ;" a specified record number, put that number here. "RTN","TMGDBAP2",169,0) ;" !!! Note: I believe this is used erroneously here. A record number "RTN","TMGDBAP2",170,0) ;" is not specified in the FDA. For calls to UPDATE^DIE to a specific "RTN","TMGDBAP2",171,0) ;" record number, the FDA should have an IENS that is like "+1,", and then "RTN","TMGDBAP2",172,0) ;" put the desired record number into the IEN_ROOT, like TMGIEN(1)=1234 "RTN","TMGDBAP2",173,0) ;" with the "1" matching the "1" in TMGIEN(1) "RTN","TMGDBAP2",174,0) ;"Output: FDA is changed if passed by reference. "RTN","TMGDBAP2",175,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGDBAP2",176,0) "RTN","TMGDBAP2",177,0) ;"Note: input Data array will be formated like this: "RTN","TMGDBAP2",178,0) ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion "RTN","TMGDBAP2",179,0) ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," "RTN","TMGDBAP2",180,0) ;" Data(0,cRecNum)=2 <-- only if user-specified. "RTN","TMGDBAP2",181,0) ;" Data(0,cEntries)=1 "RTN","TMGDBAP2",182,0) ;" Data(1,".01")="MyData1" "RTN","TMGDBAP2",183,0) ;" Data(1,".01",cMatchValue)="MyData1" "RTN","TMGDBAP2",184,0) ;" Data(1,".02")="Bill" "RTN","TMGDBAP2",185,0) ;" Data(1,".02",cMatchValue)="John" "RTN","TMGDBAP2",186,0) ;" Data(1,".03")="MyData3" "RTN","TMGDBAP2",187,0) ;" Data(1,".04")="MyData4" "RTN","TMGDBAP2",188,0) ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" "RTN","TMGDBAP2",189,0) ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" "RTN","TMGDBAP2",190,0) ;" Data(1,".07",1,".01")="SubEntry1" "RTN","TMGDBAP2",191,0) ;" Data(1,".07",1,".02")="SE1" "RTN","TMGDBAP2",192,0) ;" Data(1,".07",1,".03")="'Some Info'" "RTN","TMGDBAP2",193,0) ;" Data(1,".07",2,".01")="SubEntry2" "RTN","TMGDBAP2",194,0) ;" Data(1,".07",2,".02")="SE2" "RTN","TMGDBAP2",195,0) ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 "RTN","TMGDBAP2",196,0) ;" Data(1,".07",2,".04",1,".01")="JD" "RTN","TMGDBAP2",197,0) ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" "RTN","TMGDBAP2",198,0) ;" ADDENDUM "RTN","TMGDBAP2",199,0) ;" Data(1,".01",cFlags)=any flags specified for given field. "RTN","TMGDBAP2",200,0) ;" only present if user specified. "RTN","TMGDBAP2",201,0) "RTN","TMGDBAP2",202,0) ;"Resulting FDA will look like this. "RTN","TMGDBAP2",203,0) ;" i.e. FDA(1234,"?+1,10024,",.01)="MyData1" "RTN","TMGDBAP2",204,0) ;" i.e. FDA(1234,"?+1,10024,",.02)="Bill" "RTN","TMGDBAP2",205,0) ;" i.e. FDA(1234,"?+1,10024,",.03)="MyData3" "RTN","TMGDBAP2",206,0) ;" i.e. FDA(1234,"?+1,10024,",.04)="MyData4" "RTN","TMGDBAP2",207,0) ;" i.e. FDA(1234,"?+1,10024,",.06)="MyData5" "RTN","TMGDBAP2",208,0) ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.01)="SubEntry1" "RTN","TMGDBAP2",209,0) ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.02)="SE1" "RTN","TMGDBAP2",210,0) ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.03)="'Some Info'" "RTN","TMGDBAP2",211,0) ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.01)="SubEntry2" "RTN","TMGDBAP2",212,0) ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.02)="SE2" "RTN","TMGDBAP2",213,0) ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.03)="'Some Info'" "RTN","TMGDBAP2",214,0) ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.01)="JD" "RTN","TMGDBAP2",215,0) ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.02)="DOE,JOHN" "RTN","TMGDBAP2",216,0) ;"(OR... reformat of above) "RTN","TMGDBAP2",217,0) ;" FDA(*) "RTN","TMGDBAP2",218,0) ;" }~1234 "RTN","TMGDBAP2",219,0) ;" }~?+1,10024 "RTN","TMGDBAP2",220,0) ;" }~.01 = MyData1 "RTN","TMGDBAP2",221,0) ;" }~.02 = Bill "RTN","TMGDBAP2",222,0) ;" }~.03 = MyData3 "RTN","TMGDBAP2",223,0) ;" }~.04 = MyData4 "RTN","TMGDBAP2",224,0) ;" }~.06 = MyData5 "RTN","TMGDBAP2",225,0) ;" }~1234.21 "RTN","TMGDBAP2",226,0) ;" }~?+2,?+1,10024 "RTN","TMGDBAP2",227,0) ;" }~.01 = SubEntry1 "RTN","TMGDBAP2",228,0) ;" }~.02 = SE1 "RTN","TMGDBAP2",229,0) ;" }~.03 = 'Some Info' "RTN","TMGDBAP2",230,0) ;" }~?+3,?+1,10024 "RTN","TMGDBAP2",231,0) ;" }~.01 = SubEntry2 "RTN","TMGDBAP2",232,0) ;" }~.02 = SE2 "RTN","TMGDBAP2",233,0) ;" }~.03 = 'Some Info' "RTN","TMGDBAP2",234,0) ;" }~1234.2101 "RTN","TMGDBAP2",235,0) ;" }~?+4,?+3,?+1,10024 "RTN","TMGDBAP2",236,0) ;" }~.01 = JD "RTN","TMGDBAP2",237,0) ;" }~.02 = DOE,JOHN "RTN","TMGDBAP2",238,0) "RTN","TMGDBAP2",239,0) ;"MsgArray will hold the following "RTN","TMGDBAP2",240,0) ;" MsgArray(*) "RTN","TMGDBAP2",241,0) ;" }~"H" "RTN","TMGDBAP2",242,0) ;" }~"Ref" "RTN","TMGDBAP2",243,0) ;" }~1234.21 = "Data(6,".07") "RTN","TMGDBAP2",244,0) ;" }~1234.2101 = "Data(6,".07",2,".04") "RTN","TMGDBAP2",245,0) "RTN","TMGDBAP2",246,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",247,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",248,0) new cAbort set cAbort=0 "RTN","TMGDBAP2",249,0) new cFile set cFile="FILE" ;"File" "RTN","TMGDBAP2",250,0) new cHack set cHack="H" "RTN","TMGDBAP2",251,0) new cFlags set cFlags="FLAGS" ;"Flags" "RTN","TMGDBAP2",252,0) new cEntries set cEntries="Entries" "RTN","TMGDBAP2",253,0) new cNoOverwrite set cNoOverwrite="N" "RTN","TMGDBAP2",254,0) "RTN","TMGDBAP2",255,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI") "RTN","TMGDBAP2",256,0) "RTN","TMGDBAP2",257,0) new result set result=cOKToCont "RTN","TMGDBAP2",258,0) new index "RTN","TMGDBAP2",259,0) new FieldNum "RTN","TMGDBAP2",260,0) new FileNumber "RTN","TMGDBAP2",261,0) new SubMarkNum set SubMarkNum=0 "RTN","TMGDBAP2",262,0) new IENS set IENS="" "RTN","TMGDBAP2",263,0) if $get(RecNum)="" kill RecNum "RTN","TMGDBAP2",264,0) "RTN","TMGDBAP2",265,0) set FileNumber=$get(Data(0,cFile)) "RTN","TMGDBAP2",266,0) if +FileNumber=0 goto SFDAQ "RTN","TMGDBAP2",267,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) "RTN","TMGDBAP2",268,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"parentIENS=",parentIENS) "RTN","TMGDBAP2",269,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SrchType=",SrchType) "RTN","TMGDBAP2",270,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",$get(RecNum)) "RTN","TMGDBAP2",271,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the Data array to work with:") "RTN","TMGDBAP2",272,0) ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") "RTN","TMGDBAP2",273,0) "RTN","TMGDBAP2",274,0) set index=$order(Data(0)) "RTN","TMGDBAP2",275,0) ;"Cycle through all entries (i.e. 1, 2, 3) "RTN","TMGDBAP2",276,0) for do quit:(index="")!(result=cAbort) "RTN","TMGDBAP2",277,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index=",index) "RTN","TMGDBAP2",278,0) . set FieldNum=$order(Data(index,"")) "RTN","TMGDBAP2",279,0) . ;"Cycle through all fields (i.e. .01, .02, ,1223) "RTN","TMGDBAP2",280,0) . for do quit:(FieldNum="")!(result=cAbort) "RTN","TMGDBAP2",281,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) "RTN","TMGDBAP2",282,0) . . new NextFieldNum set NextFieldNum=$order(Data(index,FieldNum)) "RTN","TMGDBAP2",283,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NextFieldNum=",NextFieldNum) "RTN","TMGDBAP2",284,0) . . if ($get(Data(index,FieldNum,cFlags))[cNoOverwrite)&(SrchType["?") do quit "RTN","TMGDBAP2",285,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m0") "RTN","TMGDBAP2",286,0) . . . set FieldNum=NextFieldNum "RTN","TMGDBAP2",287,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NoOverwrite flag found, ignoring current field.") "RTN","TMGDBAP2",288,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m1") "RTN","TMGDBAP2",289,0) . . if (FieldNum=.01)!(IENS="") do "RTN","TMGDBAP2",290,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m2") "RTN","TMGDBAP2",291,0) . . . if $data(RecNum)#10=0 do "RTN","TMGDBAP2",292,0) . . . . set MarkNum=+$get(MarkNum)+1 "RTN","TMGDBAP2",293,0) . . . . set IENS=SrchType_MarkNum_","_$get(parentIENS) "RTN","TMGDBAP2",294,0) . . . else do "RTN","TMGDBAP2",295,0) . . . . set IENS=$get(RecNum)_","_$get(parentIENS) "RTN","TMGDBAP2",296,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS) "RTN","TMGDBAP2",297,0) . . if $get(Data(index,FieldNum,cFlags))[cHack do ;"HACK PROCESSING "RTN","TMGDBAP2",298,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Hack Processing") "RTN","TMGDBAP2",299,0) . . . ;"Load hacks into a message array for later processing "RTN","TMGDBAP2",300,0) . . . new NumHacks set NumHacks=$get(MsgArray(cHack,0,cEntries))+1 "RTN","TMGDBAP2",301,0) . . . new Entry set Entry=Data(index,FieldNum) "RTN","TMGDBAP2",302,0) . . . if $get(Data(index,FieldNum,cFlags))[cEncrypt do "RTN","TMGDBAP2",303,0) . . . . set Entry=$$EN^XUSHSH(Entry) ;"encrypt data "RTN","TMGDBAP2",304,0) . . . new Global set Global=$get(Data(0,cFile,cGlobal)) "RTN","TMGDBAP2",305,0) . . . if Global="" do quit "RTN","TMGDBAP2",306,0) . . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to local global name for file") "RTN","TMGDBAP2",307,0) . . . . set result=cAbort "RTN","TMGDBAP2",308,0) . . . set MsgArray(cHack,NumHacks)=Global_";"_FileNumber_";"_IENS_";"_FieldNum_";"_Entry "RTN","TMGDBAP2",309,0) . . . set MsgArray(cHack,NumHacks,cFlags)=Data(index,FieldNum,cFlags) "RTN","TMGDBAP2",310,0) . . else if $data(Data(index,FieldNum,0,cEntries)) do ;"SUB-FILE PROCESSING "RTN","TMGDBAP2",311,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub-file processing") "RTN","TMGDBAP2",312,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Addition of subfile entries encountered.") "RTN","TMGDBAP2",313,0) . . . new tempData merge tempData=Data(index,FieldNum) "RTN","TMGDBAP2",314,0) . . . new SubFileNum set SubFileNum=$get(Data(index,FieldNum,0,cFile),0) "RTN","TMGDBAP2",315,0) . . . set MsgArray(cRef,SubFileNum)=$name(Data(index,FieldNum)) "RTN","TMGDBAP2",316,0) . . . ;"call self recursively to handle subfile. "RTN","TMGDBAP2",317,0) . . . new SubMarkNum set SubMarkNum=MarkNum "RTN","TMGDBAP2",318,0) . . . set result=$$SetupFDA(.tempData,.FDA,IENS,SrchType,.SubMarkNum,.MsgArray,.Minimal) "RTN","TMGDBAP2",319,0) . . . if SubMarkNum>MarkNum set MarkNum=SubMarkNum "RTN","TMGDBAP2",320,0) . . else do ;"THE-USUAL-CASE PROCESSING "RTN","TMGDBAP2",321,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing usual case") "RTN","TMGDBAP2",322,0) . . . if (FieldNum=.01)!($get(Minimal)'=1) do "RTN","TMGDBAP2",323,0) . . . . new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")="_$get(Data(index,FieldNum)) "RTN","TMGDBAP2",324,0) . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ts=",ts) "RTN","TMGDBAP2",325,0) . . . . set FDA(FileNumber,IENS,FieldNum)=$get(Data(index,FieldNum)) "RTN","TMGDBAP2",326,0) . . . if $data(Data(index,FieldNum,"WP")) do "RTN","TMGDBAP2",327,0) . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Detected word-processor field") "RTN","TMGDBAP2",328,0) . . . . merge FDA(FileNumber,IENS,FieldNum,"WP")=Data(index,FieldNum,"WP") "RTN","TMGDBAP2",329,0) . . . . ;"if $get(TMGDEBUG)>0 do "RTN","TMGDBAP2",330,0) . . . . ;". new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")=" "RTN","TMGDBAP2",331,0) . . . . ;". ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE "RTN","TMGDBAP2",332,0) . . . . ;". set ts=ts_$name(TMGFDA(FileNumber,IENS,FieldNum,"WP")) "RTN","TMGDBAP2",333,0) . . . . ;". do DebugMsg^TMGDEBUG(.DBIndent,ts) "RTN","TMGDBAP2",334,0) . . . . ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE "RTN","TMGDBAP2",335,0) . . . . set FDA(FileNumber,IENS,FieldNum)=$name(TMGFDA(FileNumber,IENS,FieldNum,"WP")) "RTN","TMGDBAP2",336,0) . . set FieldNum=NextFieldNum "RTN","TMGDBAP2",337,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of field loop") "RTN","TMGDBAP2",338,0) . set index=$order(Data(index)) "RTN","TMGDBAP2",339,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of index loop") "RTN","TMGDBAP2",340,0) "RTN","TMGDBAP2",341,0) SFDAQ "RTN","TMGDBAP2",342,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is resulting FDA") "RTN","TMGDBAP2",343,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("FDA") ;"zwr FDA(*) "RTN","TMGDBAP2",344,0) "RTN","TMGDBAP2",345,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI") "RTN","TMGDBAP2",346,0) quit result "RTN","TMGDBAP2",347,0) "RTN","TMGDBAP2",348,0) "RTN","TMGDBAP2",349,0) "RTN","TMGDBAP2",350,0) OverwriteRec(RecNum,Data) "RTN","TMGDBAP2",351,0) ;"Purpose: To stuff data from data array into record specified by RecNum. "RTN","TMGDBAP2",352,0) ;" This function will not directly put any data into subfiles, but will "RTN","TMGDBAP2",353,0) ;" call UploadData to handle this. "RTN","TMGDBAP2",354,0) ;"Input: RecNum -- the record number (as returned by GetRecMatch) to put data into "RTN","TMGDBAP2",355,0) ;" Data - Should be in format output from GetRInfo "RTN","TMGDBAP2",356,0) ;"Output: database will be modified by changing record "RTN","TMGDBAP2",357,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGDBAP2",358,0) "RTN","TMGDBAP2",359,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",360,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",361,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGDBAP2",362,0) new cParentIENS set cParentIENS="ParentIENS" "RTN","TMGDBAP2",363,0) "RTN","TMGDBAP2",364,0) new result set result=cOKToCont "RTN","TMGDBAP2",365,0) new Flags "RTN","TMGDBAP2",366,0) new FileNumber,FieldNum,SubFileNum "RTN","TMGDBAP2",367,0) new FieldFlags "RTN","TMGDBAP2",368,0) new tmgFDA,TMGFDA,TMGMsg "RTN","TMGDBAP2",369,0) new index "RTN","TMGDBAP2",370,0) new IENS set IENS=$get(Data(0,cParentIENS)) "RTN","TMGDBAP2",371,0) new FDAIndex "RTN","TMGDBAP2",372,0) new MarkerArray "RTN","TMGDBAP2",373,0) new MsgArray "RTN","TMGDBAP2",374,0) "RTN","TMGDBAP2",375,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI") "RTN","TMGDBAP2",376,0) if $get(RecNum)=0 set result=cAbort goto OWQuit "RTN","TMGDBAP2",377,0) "RTN","TMGDBAP2",378,0) set FileNumber=Data(0,cFile) "RTN","TMGDBAP2",379,0) set Flags="KE" ;"E=External format values; K=Func locks file during use. "RTN","TMGDBAP2",380,0) "RTN","TMGDBAP2",381,0) set IENS=$get(Data(0,cParentIENS)) "RTN","TMGDBAP2",382,0) "RTN","TMGDBAP2",383,0) new MarkNum set MarkNum=0 "RTN","TMGDBAP2",384,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) "RTN","TMGDBAP2",385,0) "RTN","TMGDBAP2",386,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Data") "RTN","TMGDBAP2",387,0) "RTN","TMGDBAP2",388,0) set result=$$SetupFDA(.Data,.tmgFDA,IENS,"?",.MarkNum,.MsgArray,0,RecNum) "RTN","TMGDBAP2",389,0) if result=cAbort goto OWQuit "RTN","TMGDBAP2",390,0) set FileNum=$get(Data(0,cFile),0) if FileNum=0 set result=cAbort goto OWQuit "RTN","TMGDBAP2",391,0) "RTN","TMGDBAP2",392,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") "RTN","TMGDBAP2",393,0) ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MsgArray") "RTN","TMGDBAP2",394,0) "RTN","TMGDBAP2",395,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") "RTN","TMGDBAP2",396,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) "RTN","TMGDBAP2",397,0) "RTN","TMGDBAP2",398,0) if $data(tmgFDA)=0 do goto OWPast ;"This can happen with single records with NoOverwrite flag "RTN","TMGDBAP2",399,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No data to file with fileman, so skipping.") "RTN","TMGDBAP2",400,0) "RTN","TMGDBAP2",401,0) set FDAIndex=FileNum "RTN","TMGDBAP2",402,0) kill TMGFDA "RTN","TMGDBAP2",403,0) merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) "RTN","TMGDBAP2",404,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing "_FDAIndex_" part of tmgFDA") "RTN","TMGDBAP2",405,0) ; "RTN","TMGDBAP2",406,0) set Flags="E" ;"E=External format values "RTN","TMGDBAP2",407,0) ; "RTN","TMGDBAP2",408,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the TMGFDA to pass to FILE^DIE") "RTN","TMGDBAP2",409,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) "RTN","TMGDBAP2",410,0) ; "RTN","TMGDBAP2",411,0) ;"====================================================== "RTN","TMGDBAP2",412,0) ;"Call FILE^DIE "RTN","TMGDBAP2",413,0) ;"====================================================== "RTN","TMGDBAP2",414,0) if $data(TMGFDA)=0 set result=cAbort quit "RTN","TMGDBAP2",415,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE") "RTN","TMGDBAP2",416,0) do "RTN","TMGDBAP2",417,0) . new $etrap set $etrap="do ErrTrp^TMGDBAPI" "RTN","TMGDBAP2",418,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, FILE^DIE is for working with records that already exist.") "RTN","TMGDBAP2",419,0) . set ^TMP("TMG",$J,"ErrorTrap")=result "RTN","TMGDBAP2",420,0) . set ^TMP("TMG",$J,"Caller")="FILE^DIE" "RTN","TMGDBAP2",421,0) . do FILE^DIE(Flags,"TMGFDA","TMGMsg") "RTN","TMGDBAP2",422,0) . set result=^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAP2",423,0) . kill ^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAP2",424,0) . kill ^TMP("TMG",$J,"Caller") "RTN","TMGDBAP2",425,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE") "RTN","TMGDBAP2",426,0) ;"====================================================== "RTN","TMGDBAP2",427,0) ;"====================================================== "RTN","TMGDBAP2",428,0) ;" "RTN","TMGDBAP2",429,0) if $data(TMGMsg("DIERR")) do goto OWQuit "RTN","TMGDBAP2",430,0) . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAP2",431,0) . set result=cAbort "RTN","TMGDBAP2",432,0) "RTN","TMGDBAP2",433,0) if result=cAbort goto OWQuit "RTN","TMGDBAP2",434,0) "RTN","TMGDBAP2",435,0) kill tmgFDA(FDAIndex) "RTN","TMGDBAP2",436,0) set FDAIndex="" ;"I don't want to loop through rest of tmgFDA, will handle below. "RTN","TMGDBAP2",437,0) "RTN","TMGDBAP2",438,0) OWPast "RTN","TMGDBAP2",439,0) set result=$$HandleHacksArray^TMGDBAPI(.MsgArray) "RTN","TMGDBAP2",440,0) if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Error in writing record") goto OWQuit "RTN","TMGDBAP2",441,0) "RTN","TMGDBAP2",442,0) ;"Now we handle possible subfile entries. Info regarding these is in MsgArray "RTN","TMGDBAP2",443,0) if $data(MsgArray(cRef))'=0 do "RTN","TMGDBAP2",444,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Handling subfile entries.") "RTN","TMGDBAP2",445,0) . set SubFileNum=$order(MsgArray(cRef,"")) "RTN","TMGDBAP2",446,0) . for do quit:(+SubFileNum=0)!(result=cAbort) "RTN","TMGDBAP2",447,0) . . if +SubFileNum=0 quit "RTN","TMGDBAP2",448,0) . . new SubData,DataP "RTN","TMGDBAP2",449,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFileNum="_SubFileNum) "RTN","TMGDBAP2",450,0) . . set DataP=MsgArray(cRef,SubFileNum) "RTN","TMGDBAP2",451,0) . . merge SubData=@DataP "RTN","TMGDBAP2",452,0) . . set SubData(0,cParentIENS)=RecNum_","_IENS "RTN","TMGDBAP2",453,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub IENS="_RecNum_","_IENS) "RTN","TMGDBAP2",454,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DataP="_DataP) "RTN","TMGDBAP2",455,0) . . set result=$$UploadData^TMGDBAPI(.SubData) "RTN","TMGDBAP2",456,0) . . set SubFileNum=$order(MsgArray(cRef,SubFileNum)) "RTN","TMGDBAP2",457,0) "RTN","TMGDBAP2",458,0) OWQuit "RTN","TMGDBAP2",459,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI") "RTN","TMGDBAP2",460,0) quit result "RTN","TMGDBAP2",461,0) "RTN","TMGDBAP2",462,0) "RTN","TMGDBAP2",463,0) GetFileNum(FileName) "RTN","TMGDBAP2",464,0) ;"Purpose: Convert a file name into a file number "RTN","TMGDBAP2",465,0) ;"Input: The name of a file "RTN","TMGDBAP2",466,0) ;"Result: The filenumber, or 0 if not found. "RTN","TMGDBAP2",467,0) "RTN","TMGDBAP2",468,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI") "RTN","TMGDBAP2",469,0) new result set result=0 "RTN","TMGDBAP2",470,0) "RTN","TMGDBAP2",471,0) if $get(FileName)="" goto GtFlNumDone "RTN","TMGDBAP2",472,0) "RTN","TMGDBAP2",473,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'") "RTN","TMGDBAP2",474,0) "RTN","TMGDBAP2",475,0) if FileName=" " do goto GtFlNumDone "RTN","TMGDBAP2",476,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!") "RTN","TMGDBAP2",477,0) . set result=0 "RTN","TMGDBAP2",478,0) "RTN","TMGDBAP2",479,0) set DIC=1 ;"File 1=Global file reference (the file listing info for all files) "RTN","TMGDBAP2",480,0) set DIC(0)="M" "RTN","TMGDBAP2",481,0) set X=FileName ;"i.e. "AGENCY" "RTN","TMGDBAP2",482,0) do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY" "RTN","TMGDBAP2",483,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y) "RTN","TMGDBAP2",484,0) set result=$piece(Y,"^",1) "RTN","TMGDBAP2",485,0) if result=-1 set result=0 "RTN","TMGDBAP2",486,0) "RTN","TMGDBAP2",487,0) GtFlNumDone "RTN","TMGDBAP2",488,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI") "RTN","TMGDBAP2",489,0) quit result "RTN","TMGDBAP2",490,0) "RTN","TMGDBAP2",491,0) "RTN","TMGDBAP2",492,0) GetFName(FileNumber) "RTN","TMGDBAP2",493,0) ;"Purpose: Convert a file number into a file name "RTN","TMGDBAP2",494,0) ;"Input: The number of a file "RTN","TMGDBAP2",495,0) ;"Result: The file name, or "" if not found. "RTN","TMGDBAP2",496,0) "RTN","TMGDBAP2",497,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI") "RTN","TMGDBAP2",498,0) new result set result="" "RTN","TMGDBAP2",499,0) "RTN","TMGDBAP2",500,0) if $get(FileNumber)=0 goto GtFlNumDone "RTN","TMGDBAP2",501,0) "RTN","TMGDBAP2",502,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Number='"_FileNumber_"'") "RTN","TMGDBAP2",503,0) "RTN","TMGDBAP2",504,0) set result=$get(^DIC(FileNumber,0)) "RTN","TMGDBAP2",505,0) if (result="")&(FileNumber[".") do "RTN","TMGDBAP2",506,0) . set result=$get(^DD(FileNumber,0)) "RTN","TMGDBAP2",507,0) set result=$piece(result,"^",1) "RTN","TMGDBAP2",508,0) "RTN","TMGDBAP2",509,0) GtFNmDone "RTN","TMGDBAP2",510,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI") "RTN","TMGDBAP2",511,0) quit result "RTN","TMGDBAP2",512,0) "RTN","TMGDBAP2",513,0) "RTN","TMGDBAP2",514,0) GetFldName(File,FieldNumber) "RTN","TMGDBAP2",515,0) ;"Purpose: Convert a field number into a field name "RTN","TMGDBAP2",516,0) ;"Input: File -- name or number of file "RTN","TMGDBAP2",517,0) ;" FieldNumber -- the number of the field to convert "RTN","TMGDBAP2",518,0) ;"Result: The field name, or "" if not found. "RTN","TMGDBAP2",519,0) "RTN","TMGDBAP2",520,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI") "RTN","TMGDBAP2",521,0) new result set result="" "RTN","TMGDBAP2",522,0) new array "RTN","TMGDBAP2",523,0) do GetFieldInfo^TMGDBAPI(.File,.FieldNumber,"array","LABEL") "RTN","TMGDBAP2",524,0) set result=$get(array("LABEL")) "RTN","TMGDBAP2",525,0) "RTN","TMGDBAP2",526,0) GFldNmDone "RTN","TMGDBAP2",527,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI") "RTN","TMGDBAP2",528,0) quit result "RTN","TMGDBAP2",529,0) "RTN","TMGDBAP2",530,0) "RTN","TMGDBAP2",531,0) GetFldList(File,pArray) "RTN","TMGDBAP2",532,0) ;"Purpose: Get list of all fields for a file. "RTN","TMGDBAP2",533,0) ;"Input: File -- File name or number to look query. May be a sub file number "RTN","TMGDBAP2",534,0) ;" pArray -- pointer to (i.e. name of) array to put data into "RTN","TMGDBAP2",535,0) ;" Any preexisting data in pArray will be killed. "RTN","TMGDBAP2",536,0) ;"Output: Array will be fille with info like this: "RTN","TMGDBAP2",537,0) ;" example: Array(.01)=""<--- shows that field .01 exists "RTN","TMGDBAP2",538,0) ;" Array(1)="" <--- shows that field 1 exists "RTN","TMGDBAP2",539,0) ;" Array(2)="" <--- shows that field 2 exists "RTN","TMGDBAP2",540,0) ;"Results: 1=OK to continue. 0=error "RTN","TMGDBAP2",541,0) "RTN","TMGDBAP2",542,0) new result set result=1 "RTN","TMGDBAP2",543,0) new FileNumber,FileName "RTN","TMGDBAP2",544,0) if ($get(File)="")!($get(pArray)="") set result=0 goto GFdLDone "RTN","TMGDBAP2",545,0) kill @pArray "RTN","TMGDBAP2",546,0) "RTN","TMGDBAP2",547,0) if +File=File do "RTN","TMGDBAP2",548,0) . set FileNumber=File "RTN","TMGDBAP2",549,0) . set FileName=$$GetFName(File) "RTN","TMGDBAP2",550,0) else do "RTN","TMGDBAP2",551,0) . set FileName=File "RTN","TMGDBAP2",552,0) . set FileNumber=$$GetFileNum(File) "RTN","TMGDBAP2",553,0) if FileNumber'>0 do goto GFdLDone "RTN","TMGDBAP2",554,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") "RTN","TMGDBAP2",555,0) . set result=0 "RTN","TMGDBAP2",556,0) "RTN","TMGDBAP2",557,0) new index set index=$order(^DD(FileNumber,0)) "RTN","TMGDBAP2",558,0) if +index>0 for do quit:(+index'>0) "RTN","TMGDBAP2",559,0) . set @pArray@(index)="" "RTN","TMGDBAP2",560,0) . set index=$order(^DD(FileNumber,index)) "RTN","TMGDBAP2",561,0) "RTN","TMGDBAP2",562,0) GFdLDone "RTN","TMGDBAP2",563,0) quit result "RTN","TMGDBAP2",564,0) "RTN","TMGDBAP2",565,0) "RTN","TMGDBAP2",566,0) SetupFileNum(Data) "RTN","TMGDBAP2",567,0) ;"Purpose: To Ensure that Data(0,cFile) contains valid file number "RTN","TMGDBAP2",568,0) ;"Input: Data-- should be passed by reference, Array setup by GetRInfo "RTN","TMGDBAP2",569,0) ;" Specifically, Data(0,cFile) should have file name OR number "RTN","TMGDBAP2",570,0) ;"Output: Data is changed: "RTN","TMGDBAP2",571,0) ;" Data(0,cFile)=FileNumber "RTN","TMGDBAP2",572,0) ;" Data(0,cFile,cGlobal)=Global reference name ;i.e. "^VA(200)" "RTN","TMGDBAP2",573,0) ;" Data(0,cFile,cGlobal,cOpen)=Open Global reference name ;i.e. "^VA(200," "RTN","TMGDBAP2",574,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGDBAP2",575,0) "RTN","TMGDBAP2",576,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",577,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",578,0) new cAbort set cAbort=0 "RTN","TMGDBAP2",579,0) new cFile set cFile="FILE" ;"File" "RTN","TMGDBAP2",580,0) new cGlobal set cGlobal="GLOBAL" "RTN","TMGDBAP2",581,0) new cOpen set cOpen="OPEN" "RTN","TMGDBAP2",582,0) "RTN","TMGDBAP2",583,0) new result set result=cOKToCont "RTN","TMGDBAP2",584,0) new FileNumber,FileName,File "RTN","TMGDBAP2",585,0) "RTN","TMGDBAP2",586,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI") "RTN","TMGDBAP2",587,0) "RTN","TMGDBAP2",588,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Data passed to SetupFileNum") "RTN","TMGDBAP2",589,0) ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") ;"zwr Data(*) "RTN","TMGDBAP2",590,0) "RTN","TMGDBAP2",591,0) set File=$get(Data(0,cFile)," ") "RTN","TMGDBAP2",592,0) if +File'=0 do goto CKFileNum "RTN","TMGDBAP2",593,0) . set FileNumber=File "RTN","TMGDBAP2",594,0) set FileName=File "RTN","TMGDBAP2",595,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'") "RTN","TMGDBAP2",596,0) "RTN","TMGDBAP2",597,0) if FileName=" " do goto SFNDone "RTN","TMGDBAP2",598,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!") "RTN","TMGDBAP2",599,0) . set result=cAbort ;"0=Abort "RTN","TMGDBAP2",600,0) "RTN","TMGDBAP2",601,0) ;"Note: I could replace this code with GetFileNum(FileName) "RTN","TMGDBAP2",602,0) ;"---------------- "RTN","TMGDBAP2",603,0) set DIC=1 ;"File 1=Global file reference (the file listing info for all files) "RTN","TMGDBAP2",604,0) set DIC(0)="M" "RTN","TMGDBAP2",605,0) set X=FileName ;"i.e. "AGENCY" "RTN","TMGDBAP2",606,0) do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY" "RTN","TMGDBAP2",607,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y) "RTN","TMGDBAP2",608,0) set FileNumber=$piece(Y,"^",1) "RTN","TMGDBAP2",609,0) ;"---------------- "RTN","TMGDBAP2",610,0) "RTN","TMGDBAP2",611,0) CKFileNum "RTN","TMGDBAP2",612,0) set Data(0,cFile)=FileNumber "RTN","TMGDBAP2",613,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Uploading to File number: "_FileNumber) "RTN","TMGDBAP2",614,0) ;"if $data(FileName) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"('",FileName,"' file)") "RTN","TMGDBAP2",615,0) if FileNumber=-1 do goto SFNDone "RTN","TMGDBAP2",616,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to locate file specified as #"_FileNumber_" or '"_FileName_"'.") "RTN","TMGDBAP2",617,0) . set result=cAbort ;"0=Abort "RTN","TMGDBAP2",618,0) if $$VFILE^DILFD(FileNumber)=0 do goto SFNDone "RTN","TMGDBAP2",619,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") "RTN","TMGDBAP2",620,0) . set result=cAbort ;"0=Abort "RTN","TMGDBAP2",621,0) "RTN","TMGDBAP2",622,0) set Global=$get(^DIC(FileNumber,0,"GL"),"INVALID") ;"^DIC is file 1/FILE "RTN","TMGDBAP2",623,0) set Data(0,cFile,cGlobal,cOpen)=Global "RTN","TMGDBAP2",624,0) ;"Convert global form of ^VA(200, into ^VA(200) "RTN","TMGDBAP2",625,0) new Len "RTN","TMGDBAP2",626,0) set Len=$length(Global) "RTN","TMGDBAP2",627,0) if $extract(Global,Len)="," do "RTN","TMGDBAP2",628,0) . set $extract(Global,Len)=")" "RTN","TMGDBAP2",629,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"The global file to access is: "_Global) "RTN","TMGDBAP2",630,0) set Data(0,cFile,cGlobal)=Global "RTN","TMGDBAP2",631,0) "RTN","TMGDBAP2",632,0) SFNDone "RTN","TMGDBAP2",633,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI") "RTN","TMGDBAP2",634,0) "RTN","TMGDBAP2",635,0) quit result "RTN","TMGDBAP2",636,0) "RTN","TMGDBAP2",637,0) "RTN","TMGDBAP2",638,0) "RTN","TMGDBAP2",639,0) RecFind(Params) "RTN","TMGDBAP2",640,0) ;"Purpose: To look through a file and find matching record "RTN","TMGDBAP2",641,0) ;"Input -- Params(cFile)=File name or number "RTN","TMGDBAP2",642,0) ;" Params(FieldNumber)=LookupValue "RTN","TMGDBAP2",643,0) ;" Params(FieldNumber)=LookupValue "RTN","TMGDBAP2",644,0) ;" "RTN","TMGDBAP2",645,0) ;" e.g. Params(0,cFile)="PERSON CLASS" "RTN","TMGDBAP2",646,0) ;" Params(.01)="Physicians (M.D. and D.O.)" "RTN","TMGDBAP2",647,0) ;" Params(1)="Physician/Osteopath" "RTN","TMGDBAP2",648,0) ;" Params(2)="Family Practice" "RTN","TMGDBAP2",649,0) ;" "RTN","TMGDBAP2",650,0) ;"Note: Does not support searching based on subfile data. "RTN","TMGDBAP2",651,0) ;"Output -- (via results) "RTN","TMGDBAP2",652,0) ;"Result -- Returns record number file, OR 0 if not found "RTN","TMGDBAP2",653,0) "RTN","TMGDBAP2",654,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI") "RTN","TMGDBAP2",655,0) "RTN","TMGDBAP2",656,0) if $data(cFile)=0 new cFile set cFile="FILE" "RTN","TMGDBAP2",657,0) if $data(cEntries)=0 new cEntries set cEntries="Entries" "RTN","TMGDBAP2",658,0) if $data(cMatchValue)=0 new cMatchValue set cMatchValue="MATCHVALUE" "RTN","TMGDBAP2",659,0) new result set result=0 "RTN","TMGDBAP2",660,0) new Data "RTN","TMGDBAP2",661,0) new RecNum "RTN","TMGDBAP2",662,0) new FieldNum "RTN","TMGDBAP2",663,0) "RTN","TMGDBAP2",664,0) set Data(0,cFile)=$get(Params(0,cFile)) "RTN","TMGDBAP2",665,0) if Data(0,cFile)="" goto RFDone "RTN","TMGDBAP2",666,0) if $$SetupFileNum(.Data)=0 goto RFDone "RTN","TMGDBAP2",667,0) set Data(0,cEntries)=1 "RTN","TMGDBAP2",668,0) "RTN","TMGDBAP2",669,0) set FieldNum=$order(Params(0)) "RTN","TMGDBAP2",670,0) for do quit:(+FieldNum=0) "RTN","TMGDBAP2",671,0) . if +FieldNum=0 quit "RTN","TMGDBAP2",672,0) . set Data(1,FieldNum,cMatchValue)=$get(Params(FieldNum)) "RTN","TMGDBAP2",673,0) . set FieldNum=$order(Params(FieldNum)) "RTN","TMGDBAP2",674,0) "RTN","TMGDBAP2",675,0) if $$GetRecMatch^TMGDBAPI(.Data,.RecNum)=0 goto RFDone "RTN","TMGDBAP2",676,0) set result=RecNum "RTN","TMGDBAP2",677,0) "RTN","TMGDBAP2",678,0) RFDone "RTN","TMGDBAP2",679,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI") "RTN","TMGDBAP2",680,0) quit result "RTN","TMGDBAP2",681,0) "RTN","TMGDBAP2",682,0) "RTN","TMGDBAP2",683,0) "RTN","TMGDBAP2",684,0) FieldCompare(TestField,dbField,Type) "RTN","TMGDBAP2",685,0) ;"PURPOSE: To compare two fields and return a comparison code "RTN","TMGDBAP2",686,0) ;"INPUT: TestField -- User input to be tested (in "external format"). **Don't pass by Ref** "RTN","TMGDBAP2",687,0) ;" dbField -- data from database to be tested. **Don't pass by Ref "RTN","TMGDBAP2",688,0) ;" Type -- (Optional) The type of data being compared: "RTN","TMGDBAP2",689,0) ;" "NORMAL" or "" -- Simple comparison carried out (i.e. 'if A=B') "RTN","TMGDBAP2",690,0) ;" "DATE" -- the two values are date/time values "RTN","TMGDBAP2",691,0) ;" "SSNUM"-- the two values are social security numbers "RTN","TMGDBAP2",692,0) ;" "SEX" -- the two values are Sex descriptors. "RTN","TMGDBAP2",693,0) ;" "NUMBER" -- the two values are numbers "RTN","TMGDBAP2",694,0) ;"Results: "RTN","TMGDBAP2",695,0) ;" return value = cConflict (0) if entries conflict "RTN","TMGDBAP2",696,0) ;" i.e. TestField="John" vs dbField="Bill" "RTN","TMGDBAP2",697,0) ;" return value = cFullMatch (1) if entries completely match "RTN","TMGDBAP2",698,0) ;" ie. TestField="John" vs dbField="John" "RTN","TMGDBAP2",699,0) ;" or TestField="" vs. dbField="" "RTN","TMGDBAP2",700,0) ;" return value = cExtraInfo (2) if entries have no conflict, but TestField has extra info. "RTN","TMGDBAP2",701,0) ;" i.e. TestField="John" vs. dbField="" "RTN","TMGDBAP2",702,0) ;" return value = cdbExtraInfo (3) if entries have no conflict, but dbField has extra info. "RTN","TMGDBAP2",703,0) ;" i.e. TestField="" vs. dbField="12345" "RTN","TMGDBAP2",704,0) "RTN","TMGDBAP2",705,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI") "RTN","TMGDBAP2",706,0) "RTN","TMGDBAP2",707,0) if $data(cConflict)#10=0 new cConflict set cConflict=0 "RTN","TMGDBAP2",708,0) if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 "RTN","TMGDBAP2",709,0) if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 "RTN","TMGDBAP2",710,0) if $data(cdbExtraInfo)#10=0 new cdbExtraInfo set cdbExtraInfo=3 "RTN","TMGDBAP2",711,0) "RTN","TMGDBAP2",712,0) set TestField=$get(TestField) "RTN","TMGDBAP2",713,0) set dbField=$get(dbField) "RTN","TMGDBAP2",714,0) set Type=$get(Type) "RTN","TMGDBAP2",715,0) "RTN","TMGDBAP2",716,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField=",TestField) "RTN","TMGDBAP2",717,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField=",dbField) "RTN","TMGDBAP2",718,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Type=",Type) "RTN","TMGDBAP2",719,0) "RTN","TMGDBAP2",720,0) new result set result=cConflict "RTN","TMGDBAP2",721,0) "RTN","TMGDBAP2",722,0) if Type="DATE" do "RTN","TMGDBAP2",723,0) . set TestField=$$IDATE^TIULC(TestField) "RTN","TMGDBAP2",724,0) . set dbField=$$IDATE^TIULC(dbField) "RTN","TMGDBAP2",725,0) else if Type="SSNUM" do "RTN","TMGDBAP2",726,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing SSNUM's") "RTN","TMGDBAP2",727,0) . set TestField=$translate(TestField," /-","") ;"Clean delimiters "RTN","TMGDBAP2",728,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField) "RTN","TMGDBAP2",729,0) . if TestField["P" set TestField="P" "RTN","TMGDBAP2",730,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField) "RTN","TMGDBAP2",731,0) . if dbField["P" set dbField="P" "RTN","TMGDBAP2",732,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField now=",dbField) "RTN","TMGDBAP2",733,0) else if Type="SEX" do "RTN","TMGDBAP2",734,0) . if (TestField="m")!(TestField="M") set TestField="MALE" "RTN","TMGDBAP2",735,0) . if (TestField="f")!(TestField="F") set TestField="FEMALE" "RTN","TMGDBAP2",736,0) "RTN","TMGDBAP2",737,0) if TestField'="" do "RTN","TMGDBAP2",738,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(dbField)=",$data(dbField)) "RTN","TMGDBAP2",739,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$get(dbField)='' =",($get(dbField)="")) "RTN","TMGDBAP2",740,0) . if ($data(dbField)#10=0)!($get(dbField)="") set result=cExtraInfo "RTN","TMGDBAP2",741,0) . else do "RTN","TMGDBAP2",742,0) . . if Type="NUMBER" do "RTN","TMGDBAP2",743,0) . . . if +TestField=+dbField set result=cFullMatch "RTN","TMGDBAP2",744,0) . . else do "RTN","TMGDBAP2",745,0) . . . if TestField=dbField set result=cFullMatch "RTN","TMGDBAP2",746,0) else do ;"i.e. test case when TestField="" "RTN","TMGDBAP2",747,0) . if $get(dbfield)="" set result=cFullMatch "RTN","TMGDBAP2",748,0) . else set result=cdbExtraInfo "RTN","TMGDBAP2",749,0) "RTN","TMGDBAP2",750,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGDBAP2",751,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI") "RTN","TMGDBAP2",752,0) "RTN","TMGDBAP2",753,0) quit result "RTN","TMGDBAP2",754,0) "RTN","TMGDBAP2",755,0) "RTN","TMGDBAP2",756,0) EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) "RTN","TMGDBAP2",757,0) ;"Purpose: To provide code to that will ensure that data is written to "RTN","TMGDBAP2",758,0) ;" the database, but it will not add duplicate records if the value "RTN","TMGDBAP2",759,0) ;" is already there. So a FIND is done first, and added if not found. "RTN","TMGDBAP2",760,0) ;" Note: This is primarly targeted at adding entries in a subfile. "RTN","TMGDBAP2",761,0) ;"Input: File -- File name or number "RTN","TMGDBAP2",762,0) ;" Field -- Field name or number "RTN","TMGDBAP2",763,0) ;" IENS -- standard IENS string describing IEN in File, or IEN path to subfile "RTN","TMGDBAP2",764,0) ;" Value -- The value to be filed "RTN","TMGDBAP2",765,0) ;" Flags -- Flags to be passed "RTN","TMGDBAP2",766,0) ;" MsgArray -- PASS BY REFERENCE. Messages to pass back out. "RTN","TMGDBAP2",767,0) ;"Results : 1=Writen OK, 0=Already present so not written, -1=error "RTN","TMGDBAP2",768,0) "RTN","TMGDBAP2",769,0) new result set result=-1 "RTN","TMGDBAP2",770,0) "RTN","TMGDBAP2",771,0) "RTN","TMGDBAP2",772,0) quit result "RTN","TMGDBAP2",773,0) "RTN","TMGDBAP2",774,0) "RTN","TMGDBAP2",775,0) "RTN","TMGDBAP2",776,0) dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) "RTN","TMGDBAP2",777,0) ;"Purpose: To provide a unified interface for writing a FDA to the database "RTN","TMGDBAP2",778,0) ;"Input: FDA -- PASS BY REFERENCE. A standard FDA structure. (won't be changed) "RTN","TMGDBAP2",779,0) ;" Overwrite -- specifies if records already exist in database "RTN","TMGDBAP2",780,0) ;" if = 1, then FILE^DIE used to write into pre-existing records "RTN","TMGDBAP2",781,0) ;" if = 0, then UPDATE^DIE used to write new records "RTN","TMGDBAP2",782,0) ;" TMGIEN (OPTIONAL)-- an array to receive back records added (only applies if "RTN","TMGDBAP2",783,0) ;" Overwrite=0) "RTN","TMGDBAP2",784,0) ;" It can also be used to pass info to UPDATE^DIE recarding requested record numbers "RTN","TMGDBAP2",785,0) ;" Flags (OPTIONAL) -- Flags to pass to UPDATE^DIE or FILE^DIE. "RTN","TMGDBAP2",786,0) ;" default is "E", pass a " " to NOT use "E" "RTN","TMGDBAP2",787,0) ;" ErrArray (OPTIONAL) -- an OUT parameter to receive fileman "DIERR" results, if any "RTN","TMGDBAP2",788,0) ;"Results -- if error occured "RTN","TMGDBAP2",789,0) ;" cOKToCont (i.e. 1) if no error "RTN","TMGDBAP2",790,0) ;" cAbort (i.e. 0) if error "RTN","TMGDBAP2",791,0) "RTN","TMGDBAP2",792,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",793,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",794,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGDBAP2",795,0) "RTN","TMGDBAP2",796,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"dbWrite^TMGDBAPI") "RTN","TMGDBAP2",797,0) "RTN","TMGDBAP2",798,0) set Overwrite=$get(Overwrite,0) "RTN","TMGDBAP2",799,0) new TMGFDA merge TMGFDA=FDA "RTN","TMGDBAP2",800,0) new TMGMsg "RTN","TMGDBAP2",801,0) new TMGFlags set TMGFlags=$get(Flags,"E") ;"E=External values "RTN","TMGDBAP2",802,0) if TMGFlags=" " set TMGFlags="" "RTN","TMGDBAP2",803,0) if (Overwrite=1)&($get(Flags)'="") set TMGFlags=TMGFlags_"K" ;"K means filer does file locking. "RTN","TMGDBAP2",804,0) "RTN","TMGDBAP2",805,0) new result set result=cOKToCont "RTN","TMGDBAP2",806,0) "RTN","TMGDBAP2",807,0) if $data(TMGFDA)=0 do goto DBWDone "RTN","TMGDBAP2",808,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error: No data passed to write!") "RTN","TMGDBAP2",809,0) . set result=-1 quit "RTN","TMGDBAP2",810,0) else do "RTN","TMGDBAP2",811,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is TMGFDA to write") "RTN","TMGDBAP2",812,0) . ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGFDA") "RTN","TMGDBAP2",813,0) "RTN","TMGDBAP2",814,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TMGFlags=",TMGFlags) "RTN","TMGDBAP2",815,0) "RTN","TMGDBAP2",816,0) set ^TMP("TMG",$J,"ErrorTrap")=result "RTN","TMGDBAP2",817,0) "RTN","TMGDBAP2",818,0) ;"====================================================== "RTN","TMGDBAP2",819,0) ;"====================================================== "RTN","TMGDBAP2",820,0) if Overwrite=1 do ;"i.e. FILE^DIE used to write into pre-existing records "RTN","TMGDBAP2",821,0) . new $etrap set $etrap="do ErrTrp^TMGDBAPI" "RTN","TMGDBAP2",822,0) . set ^TMP("TMG",$J,"Caller")="FILE^DIE" "RTN","TMGDBAP2",823,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using FILE^DIE to work with preexisting records") "RTN","TMGDBAP2",824,0) . do FILE^DIE(TMGFlags,"TMGFDA","TMGMsg") "RTN","TMGDBAP2",825,0) else if Overwrite=0 do ;"i.e. UPDATE^DIE used to write new records "RTN","TMGDBAP2",826,0) . new $etrap set $etrap="do ErrTrp^TMGDBAPI" "RTN","TMGDBAP2",827,0) . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" "RTN","TMGDBAP2",828,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using UPDATE^DIE to add a new records") "RTN","TMGDBAP2",829,0) . do UPDATE^DIE(TMGFlags,"TMGFDA","TMGIEN","TMGMsg") "RTN","TMGDBAP2",830,0) ;"====================================================== "RTN","TMGDBAP2",831,0) ;"====================================================== "RTN","TMGDBAP2",832,0) "RTN","TMGDBAP2",833,0) set result=^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAP2",834,0) kill ^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAP2",835,0) kill ^TMP("TMG",$J,"Caller") "RTN","TMGDBAP2",836,0) "RTN","TMGDBAP2",837,0) ;"if ($get(TMGDEBUG)>0)&($data(TMGIEN)) do DebugMsg^TMGDEBUG(.DBIndent,"Here is TMGIEN") "RTN","TMGDBAP2",838,0) ;". if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGIEN") "RTN","TMGDBAP2",839,0) "RTN","TMGDBAP2",840,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After database write, here is TMGMsg") "RTN","TMGDBAP2",841,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") "RTN","TMGDBAP2",842,0) "RTN","TMGDBAP2",843,0) if $data(TMGMsg("DIERR")) do "RTN","TMGDBAP2",844,0) . ;"TMGDEBUG=-1 --> extra quiet mode "RTN","TMGDBAP2",845,0) . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAP2",846,0) . set result=cAbort "RTN","TMGDBAP2",847,0) . merge ErrArray("DIERR")=TMGMsg("DIERR") "RTN","TMGDBAP2",848,0) "RTN","TMGDBAP2",849,0) if result=cAbort do "RTN","TMGDBAP2",850,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error encountered during write") "RTN","TMGDBAP2",851,0) "RTN","TMGDBAP2",852,0) DBWDone "RTN","TMGDBAP2",853,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"dbWrite^TMGDBAPI") "RTN","TMGDBAP2",854,0) quit result "RTN","TMGDBAP2",855,0) "RTN","TMGDBAP2",856,0) "RTN","TMGDBAP2",857,0) DelIEN(File,RecNumIEN,ErrArray) "RTN","TMGDBAP2",858,0) ;"Purpose: To delete record# RecNumIEN from file FILE "RTN","TMGDBAP2",859,0) ;"Input: File -- File name or number to delete from "RTN","TMGDBAP2",860,0) ;" RecNumIEN -- the IEN to delete "RTN","TMGDBAP2",861,0) ;" ErrArray --OPTIONAL, PASS BY REFERENCE. "RTN","TMGDBAP2",862,0) ;" an OUT parameter to receive fileman "DIERR" results, if any "RTN","TMGDBAP2",863,0) ;"Output: will cause deletion from database "RTN","TMGDBAP2",864,0) ;"Results -- if error occured "RTN","TMGDBAP2",865,0) ;" cOKToCont (i.e. 1) if no error "RTN","TMGDBAP2",866,0) ;" cAbort (i.e. 0) if error "RTN","TMGDBAP2",867,0) "RTN","TMGDBAP2",868,0) new TMGFDA,result "RTN","TMGDBAP2",869,0) set result=0 "RTN","TMGDBAP2",870,0) "RTN","TMGDBAP2",871,0) if $get(File)="" goto DIENDone "RTN","TMGDBAP2",872,0) if +$get(RecNumIEN)'>0 goto DIENDone "RTN","TMGDBAP2",873,0) if +File'>0 set File=$$GetFileNum(File) "RTN","TMGDBAP2",874,0) "RTN","TMGDBAP2",875,0) set TMGFDA(File,+RecNumIEN_",",.01)="@" "RTN","TMGDBAP2",876,0) set result=$$dbWrite(.TMGFDA,1,,,.ErrArray) "RTN","TMGDBAP2",877,0) "RTN","TMGDBAP2",878,0) DIENDone "RTN","TMGDBAP2",879,0) quit result "RTN","TMGDBAP2",880,0) "RTN","TMGDBAP2",881,0) "RTN","TMGDBAP2",882,0) WriteWP(File,RecNumIEN,Field,TMGArray) "RTN","TMGDBAP2",883,0) ;"Purpose: To provide a shell around WP^DIE with error trap, error reporting "RTN","TMGDBAP2",884,0) ;"Note: This does not support subfiles or multiples. Does not support appending "RTN","TMGDBAP2",885,0) ;"Input: File: a number or name "RTN","TMGDBAP2",886,0) ;" RecNumIEN: The record number, in File, to use "RTN","TMGDBAP2",887,0) ;" Field: a name or number "RTN","TMGDBAP2",888,0) ;" TMGArray: The array that contains WP data. Must be in Fileman acceptible format. "RTN","TMGDBAP2",889,0) ;"Results -- if error occured "RTN","TMGDBAP2",890,0) ;" cOKToCont (i.e. 1) if no error "RTN","TMGDBAP2",891,0) ;" cAbort (i.e. 0) if error "RTN","TMGDBAP2",892,0) "RTN","TMGDBAP2",893,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",894,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",895,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGDBAP2",896,0) "RTN","TMGDBAP2",897,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI") "RTN","TMGDBAP2",898,0) "RTN","TMGDBAP2",899,0) new IENS "RTN","TMGDBAP2",900,0) new TMGMsg "RTN","TMGDBAP2",901,0) new FileNumber,FieldNumber "RTN","TMGDBAP2",902,0) new result set result=cAbort "RTN","TMGDBAP2",903,0) new TMGFlags set TMGFlags="K" "RTN","TMGDBAP2",904,0) "RTN","TMGDBAP2",905,0) set FileNumber=+$get(File) "RTN","TMGDBAP2",906,0) if FileNumber=0 set FileNumber=$$GetFileNum(.File) "RTN","TMGDBAP2",907,0) if FileNumber=0 do goto WWPDone "RTN","TMGDBAP2",908,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") "RTN","TMGDBAP2",909,0) "RTN","TMGDBAP2",910,0) set FieldNumber=$get(Field) "RTN","TMGDBAP2",911,0) if FieldNumber=0 set FieldNumber=$$GetNumField^TMGDBAPI(.Field) "RTN","TMGDBAP2",912,0) if FieldNumber=0 do goto WWPDone "RTN","TMGDBAP2",913,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") "RTN","TMGDBAP2",914,0) "RTN","TMGDBAP2",915,0) if +$get(RecNumIEN)=0 do goto WWPDone "RTN","TMGDBAP2",916,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"No numeric record number supplied.") "RTN","TMGDBAP2",917,0) "RTN","TMGDBAP2",918,0) set IENS=RecNumIEN_"," "RTN","TMGDBAP2",919,0) "RTN","TMGDBAP2",920,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) "RTN","TMGDBAP2",921,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS='",IENS,"'") "RTN","TMGDBAP2",922,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNumber=",FieldNumber) "RTN","TMGDBAP2",923,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",TMGFlags) "RTN","TMGDBAP2",924,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGArray") "RTN","TMGDBAP2",925,0) "RTN","TMGDBAP2",926,0) do "RTN","TMGDBAP2",927,0) . ;"====================================================== "RTN","TMGDBAP2",928,0) . ;"Call WP^DIE "RTN","TMGDBAP2",929,0) . ;"====================================================== "RTN","TMGDBAP2",930,0) . ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE") "RTN","TMGDBAP2",931,0) . new $etrap set $etrap="do ErrTrp^TMGDBAPI" "RTN","TMGDBAP2",932,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, WP^DIE files WP data.") "RTN","TMGDBAP2",933,0) . set ^TMP("TMG",$J,"ErrorTrap")=result "RTN","TMGDBAP2",934,0) . set ^TMP("TMG",$J,"Caller")="WP^DIE" "RTN","TMGDBAP2",935,0) . do WP^DIE(FileNumber,IENS,FieldNumber,TMGFlags,"TMGArray","TMGMsg") "RTN","TMGDBAP2",936,0) . set result=^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAP2",937,0) . kill ^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAP2",938,0) . kill ^TMP("TMG",$J,"Caller") "RTN","TMGDBAP2",939,0) . ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE") "RTN","TMGDBAP2",940,0) . ;"====================================================== "RTN","TMGDBAP2",941,0) . ;"====================================================== "RTN","TMGDBAP2",942,0) "RTN","TMGDBAP2",943,0) if $data(TMGMsg("DIERR"))'=0 do goto WWPDone "RTN","TMGDBAP2",944,0) . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAP2",945,0) . set result=cAbort "RTN","TMGDBAP2",946,0) "RTN","TMGDBAP2",947,0) set result=cOKToCont "RTN","TMGDBAP2",948,0) "RTN","TMGDBAP2",949,0) ;"zbreak WWPDone "RTN","TMGDBAP2",950,0) "RTN","TMGDBAP2",951,0) WWPDone "RTN","TMGDBAP2",952,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI") "RTN","TMGDBAP2",953,0) quit result "RTN","TMGDBAP2",954,0) "RTN","TMGDBAP2",955,0) "RTN","TMGDBAP2",956,0) ReadWP(File,IENS,Field,Array) "RTN","TMGDBAP2",957,0) ;"Purpose: To provide a shell for reading a WP with error trap, error reporting "RTN","TMGDBAP2",958,0) ;"Input: File: a number or name "RTN","TMGDBAP2",959,0) ;" IENS: a standard IENS (i.e. "IEN,parent-IEN,grandparent-IEN,ggparent-IEN," etc. "RTN","TMGDBAP2",960,0) ;" Note: can just pass a single IEN (without a terminal ",") "RTN","TMGDBAP2",961,0) ;" Field: a name or number "RTN","TMGDBAP2",962,0) ;" Array: The array to receive WP data. PASS BY REFERENCE "RTN","TMGDBAP2",963,0) ;" returned In Fileman acceptible format. "RTN","TMGDBAP2",964,0) ;" Array will be deleted before refilling "RTN","TMGDBAP2",965,0) ;"Results -- if error occured "RTN","TMGDBAP2",966,0) ;" cOKToCont (i.e. 1) if no error "RTN","TMGDBAP2",967,0) ;" cAbort (i.e. 0) if error "RTN","TMGDBAP2",968,0) "RTN","TMGDBAP2",969,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAP2",970,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGDBAP2",971,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGDBAP2",972,0) "RTN","TMGDBAP2",973,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI") "RTN","TMGDBAP2",974,0) "RTN","TMGDBAP2",975,0) new FileNumber,FieldNumber "RTN","TMGDBAP2",976,0) new TMGWP,temp "RTN","TMGDBAP2",977,0) new result set result=cOKToCont "RTN","TMGDBAP2",978,0) "RTN","TMGDBAP2",979,0) if $get(IENS)="" do goto RWPDone "RTN","TMGDBAP2",980,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Valid IENS not supplied.") "RTN","TMGDBAP2",981,0) if $extract(IENS,$length(IENS))'="," set IENS=IENS_"," "RTN","TMGDBAP2",982,0) "RTN","TMGDBAP2",983,0) if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=cAbort goto RWPDone "RTN","TMGDBAP2",984,0) "RTN","TMGDBAP2",985,0) set temp=$$GET1^DIQ(FileNumber,IENS,FieldNumber,"","TMGWP","TMGMsg") "RTN","TMGDBAP2",986,0) "RTN","TMGDBAP2",987,0) if $data(TMGMsg) do "RTN","TMGDBAP2",988,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here are TMGMsg entries") "RTN","TMGDBAP2",989,0) . ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") "RTN","TMGDBAP2",990,0) . if $data(TMGMsg("DIERR"))'=0 do quit "RTN","TMGDBAP2",991,0) . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAP2",992,0) . . set result=cAbort "RTN","TMGDBAP2",993,0) if result=cAbort goto RWPDone "RTN","TMGDBAP2",994,0) "RTN","TMGDBAP2",995,0) kill Array "RTN","TMGDBAP2",996,0) merge Array=TMGWP "RTN","TMGDBAP2",997,0) "RTN","TMGDBAP2",998,0) RWPDone "RTN","TMGDBAP2",999,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI") "RTN","TMGDBAP2",1000,0) quit result "RTN","TMGDBAP2",1001,0) "RTN","TMGDBAP2",1002,0) ShowIfError(TMGMsg,PriorErrorFound) "RTN","TMGDBAP2",1003,0) ;"Purpose: to show DIERR if preesnt in pTMGMsg "RTN","TMGDBAP2",1004,0) ;"Input: pTMGMsg -- PASS BY REFERENCE, holds message route, as set up by Fileman "RTN","TMGDBAP2",1005,0) ;" PriorErrroFound -- OPTIONAL, a variable holding if a prior error has been found "RTN","TMGDBAP2",1006,0) ;"Output: 1 if ERROR found, 0 otherwise "RTN","TMGDBAP2",1007,0) "RTN","TMGDBAP2",1008,0) new result set result=0 "RTN","TMGDBAP2",1009,0) if $data(TMGMsg("DIERR"))'=0 do "RTN","TMGDBAP2",1010,0) . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAP2",1011,0) . set result=1 "RTN","TMGDBAP2",1012,0) quit result "RTN","TMGDBAP2",1013,0) "RTN","TMGDBAP2",1014,0) "RTN","TMGDBAP2",1015,0) DataImport(Info,ProgressFN) "RTN","TMGDBAP2",1016,0) ;"Purpose: to provide a generic loading utility. "RTN","TMGDBAP2",1017,0) ;" Note: this is more specific than code found in DDMP.m "RTN","TMGDBAP2",1018,0) ;"Assumptions: that all data for one record is found on one line, with a given "RTN","TMGDBAP2",1019,0) ;" number of columns for each field. "RTN","TMGDBAP2",1020,0) ;"Input: Info, an array with relevent info. PASS BY REFERENCE "RTN","TMGDBAP2",1021,0) ;" Format as follows: "RTN","TMGDBAP2",1022,0) ;" Info("HFS DIR")= "RTN","TMGDBAP2",1023,0) ;" Info("HFS FILE")= "RTN","TMGDBAP2",1024,0) ;" Info("DEST FILE")= "RTN","TMGDBAP2",1025,0) ;" Info(x)=field# (or "IEN" if data should be used to determine record number "RTN","TMGDBAP2",1026,0) ;" Info(x,"START")=starting column "RTN","TMGDBAP2",1027,0) ;" Info(x,"END")=ending column "RTN","TMGDBAP2",1028,0) ;" ProgressFN: optional. If not "", then this will be XECUTED after each line "RTN","TMGDBAP2",1029,0) ;"Result: 1 if OK to continue, 0 if error "RTN","TMGDBAP2",1030,0) "RTN","TMGDBAP2",1031,0) ;"Note: input Data array will be formated like this: "RTN","TMGDBAP2",1032,0) ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion "RTN","TMGDBAP2",1033,0) ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," "RTN","TMGDBAP2",1034,0) ;" Data(0,cRecNum)=2 <-- only if user-specified. "RTN","TMGDBAP2",1035,0) ;" Data(0,cEntries)=1 "RTN","TMGDBAP2",1036,0) ;" Data(1,".01")="MyData1" "RTN","TMGDBAP2",1037,0) ;" Data(1,".01",cMatchValue)="MyData1" "RTN","TMGDBAP2",1038,0) ;" Data(1,".02")="Bill" "RTN","TMGDBAP2",1039,0) ;" Data(1,".02",cMatchValue)="John" "RTN","TMGDBAP2",1040,0) ;" Data(1,".03")="MyData3" "RTN","TMGDBAP2",1041,0) ;" Data(1,".04")="MyData4" "RTN","TMGDBAP2",1042,0) ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" "RTN","TMGDBAP2",1043,0) ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" "RTN","TMGDBAP2",1044,0) ;" Data(1,".07",1,".01")="SubEntry1" "RTN","TMGDBAP2",1045,0) ;" Data(1,".07",1,".02")="SE1" "RTN","TMGDBAP2",1046,0) ;" Data(1,".07",1,".03")="'Some Info'" "RTN","TMGDBAP2",1047,0) ;" Data(1,".07",2,".01")="SubEntry2" "RTN","TMGDBAP2",1048,0) ;" Data(1,".07",2,".02")="SE2" "RTN","TMGDBAP2",1049,0) ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 "RTN","TMGDBAP2",1050,0) ;" Data(1,".07",2,".04",1,".01")="JD" "RTN","TMGDBAP2",1051,0) ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" "RTN","TMGDBAP2",1052,0) ;" ADDENDUM "RTN","TMGDBAP2",1053,0) ;" Data(1,".01",cFlags)=any flags specified for given field. "RTN","TMGDBAP2",1054,0) ;" only present if user specified. "RTN","TMGDBAP2",1055,0) "RTN","TMGDBAP2",1056,0) new cFile set cFile="FILE" "RTN","TMGDBAP2",1057,0) new cRecNum set cRecNum="RECNUM" "RTN","TMGDBAP2",1058,0) new result set result=1 "RTN","TMGDBAP2",1059,0) "RTN","TMGDBAP2",1060,0) new GRef set GRef=$name(^TMP("TMG","DATAIMPORT",$J)) "RTN","TMGDBAP2",1061,0) new GRef1 set GRef1=$name(@GRef@(1)) ;"I have to use this to load file "RTN","TMGDBAP2",1062,0) kill @GRef "RTN","TMGDBAP2",1063,0) "RTN","TMGDBAP2",1064,0) new result "RTN","TMGDBAP2",1065,0) new dir set dir=$get(Info("HFS DIR")) "RTN","TMGDBAP2",1066,0) new HFSfile set HFSfile=$get(Info("HFS FILE")) "RTN","TMGDBAP2",1067,0) set result=$$FTG^%ZISH(dir,HFSfile,GRef1,4) "RTN","TMGDBAP2",1068,0) if result=0 goto DIDone "RTN","TMGDBAP2",1069,0) new file set file=$get(Info("DEST FILE")) "RTN","TMGDBAP2",1070,0) if +file=0 set file=$$GetFileNum(file) "RTN","TMGDBAP2",1071,0) "RTN","TMGDBAP2",1072,0) new index "RTN","TMGDBAP2",1073,0) set index=$order(@GRef@("")) "RTN","TMGDBAP2",1074,0) for do quit:(+index=0)!(result=0) "RTN","TMGDBAP2",1075,0) . new RecData,FDA "RTN","TMGDBAP2",1076,0) . set RecData(0,cFile)=file "RTN","TMGDBAP2",1077,0) . new line set line=$get(@GRef@(index)) "RTN","TMGDBAP2",1078,0) . new fields set fields=$order(Info("")) "RTN","TMGDBAP2",1079,0) . new IEN set IEN="" "RTN","TMGDBAP2",1080,0) . for do quit:(+fields=0)!(result=0) "RTN","TMGDBAP2",1081,0) . . new fieldNum set fieldNum=$get(Info(fields)) ;"could be number or 'IEN' "RTN","TMGDBAP2",1082,0) . . new oneField "RTN","TMGDBAP2",1083,0) . . set oneField=$extract(line,$get(Info(fields,"START")),$get(Info(fields,"END"))) "RTN","TMGDBAP2",1084,0) . . set oneField=$$Trim^TMGSTUTL(oneField) "RTN","TMGDBAP2",1085,0) . . if fieldNum="IEN" do "RTN","TMGDBAP2",1086,0) . . . set RecData(0,cRecNum)=fieldNum "RTN","TMGDBAP2",1087,0) . . . set IEN=fieldNum "RTN","TMGDBAP2",1088,0) . . else do "RTN","TMGDBAP2",1089,0) . . . set RecData(1,fieldNum)=oneField "RTN","TMGDBAP2",1090,0) . . set fields=$order(Info(fields)) "RTN","TMGDBAP2",1091,0) . new MarkNum set MarkNum=0 "RTN","TMGDBAP2",1092,0) . new MsgArray "RTN","TMGDBAP2",1093,0) . set result=$$SetupFDA(.RecData,.FDA,,"+",.MarkNum,.MsgArray,IEN) "RTN","TMGDBAP2",1094,0) . if result=0 quit "RTN","TMGDBAP2",1095,0) . set result=$$dbWrite(.FDA,0,," ") "RTN","TMGDBAP2",1096,0) . if result=0 quit "RTN","TMGDBAP2",1097,0) . if $get(ProgressFN)'="" do "RTN","TMGDBAP2",1098,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGDBAP2",1099,0) . . xecute ProgressFN "RTN","TMGDBAP2",1100,0) . set index=$order(@GRef@(index)) "RTN","TMGDBAP2",1101,0) "RTN","TMGDBAP2",1102,0) DIDone "RTN","TMGDBAP2",1103,0) kill @GRef "RTN","TMGDBAP2",1104,0) quit result "RTN","TMGDBAP2",1105,0) "RTN","TMGDBAP2",1106,0) "RTN","TMGDBAP2",1107,0) Set1(File,IEN,Field,Value,Flag) "RTN","TMGDBAP2",1108,0) ;"Purpose: to be the reverse of GET1^DIQ (i.e. a setter instead of a getter) "RTN","TMGDBAP2",1109,0) ;" It will set the value for 1 field in 1 record in 1 file. "RTN","TMGDBAP2",1110,0) ;" Note: only to be used in existing files. "RTN","TMGDBAP2",1111,0) ;"Input: File -- the Filename or number "RTN","TMGDBAP2",1112,0) ;" IEN -- the record number to set into "RTN","TMGDBAP2",1113,0) ;" Field -- the field name or number "RTN","TMGDBAP2",1114,0) ;" Value -- the value to set it to (WP not currently supported) "RTN","TMGDBAP2",1115,0) ;" Flag -- OPTIONAL. Combinations of below: "RTN","TMGDBAP2",1116,0) ;" 'I' -- values are in internal format "RTN","TMGDBAP2",1117,0) ;" 'E' -- values are in external format (this is the DEFAULT) "RTN","TMGDBAP2",1118,0) ;"Results: 1 if OKtoCont, 0 if error "RTN","TMGDBAP2",1119,0) "RTN","TMGDBAP2",1120,0) new FileNumber,FieldNumber "RTN","TMGDBAP2",1121,0) new result set result=0 ;"default to error "RTN","TMGDBAP2",1122,0) "RTN","TMGDBAP2",1123,0) ;"new tempDebug set tempDebug=$get(TMGDEBUG) "RTN","TMGDBAP2",1124,0) ;"set TMGDEBUG=-1 ;"Extra quiet mode "RTN","TMGDBAP2",1125,0) "RTN","TMGDBAP2",1126,0) if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=0 goto S1Done "RTN","TMGDBAP2",1127,0) if (+FileNumber=0)!(+FieldNumber=0) goto S1Done "RTN","TMGDBAP2",1128,0) if ($get(Value)="")!(+IEN=0) goto S1Done "RTN","TMGDBAP2",1129,0) "RTN","TMGDBAP2",1130,0) new result set result=1 ;"default to success. "RTN","TMGDBAP2",1131,0) "RTN","TMGDBAP2",1132,0) new TMGFDA,FMFlag,TMGMSG "RTN","TMGDBAP2",1133,0) set FMFlag="E" "RTN","TMGDBAP2",1134,0) if $get(Flag)["I" set FMFlag="" "RTN","TMGDBAP2",1135,0) set FMFlag=FMFlag_"K" "RTN","TMGDBAP2",1136,0) set TMGFDA(FileNumber,IEN_",",FieldNumber)=Value "RTN","TMGDBAP2",1137,0) do FILE^DIE(FMFlag,"TMGFDA","TMGMSG") "RTN","TMGDBAP2",1138,0) if $data(TMGMSG("DIERR"))'=0 do goto S1Done "RTN","TMGDBAP2",1139,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGDBAP2",1140,0) "RTN","TMGDBAP2",1141,0) S1Done "RTN","TMGDBAP2",1142,0) ;"set TMGDEBUG=tempDebug "RTN","TMGDBAP2",1143,0) quit result "RTN","TMGDBAP2",1144,0) "RTN","TMGDBAP2",1145,0) "RTN","TMGDBAP2",1146,0) GetValidInput(File,Field) "RTN","TMGDBAP2",1147,0) ;"Purpose: Gets a valid input for field in file, asking user from console "RTN","TMGDBAP2",1148,0) ;"Input: File: File number or name of file to use "RTN","TMGDBAP2",1149,0) ;" Field: Field number or name in file. "RTN","TMGDBAP2",1150,0) ;"Results: returns valid input, or "" "RTN","TMGDBAP2",1151,0) "RTN","TMGDBAP2",1152,0) new FileNum,FldNum "RTN","TMGDBAP2",1153,0) new DIR,X,Y "RTN","TMGDBAP2",1154,0) set Y="" "RTN","TMGDBAP2",1155,0) "RTN","TMGDBAP2",1156,0) set FileNum=+$get(File) "RTN","TMGDBAP2",1157,0) if FileNum=0 set FileNum=$$GetFileNum^TMGDBAPI(.File) "RTN","TMGDBAP2",1158,0) if FileNum=0 goto GVIDone "RTN","TMGDBAP2",1159,0) "RTN","TMGDBAP2",1160,0) set FldNum=$get(Field) "RTN","TMGDBAP2",1161,0) if FldNum=0 set FldNum=$$GetNumField^TMGDBAPI(FileNum,.Field) "RTN","TMGDBAP2",1162,0) if FldNum=0 goto GVIDone "RTN","TMGDBAP2",1163,0) "RTN","TMGDBAP2",1164,0) set DIR(0)=FileNum_","_FldNum "RTN","TMGDBAP2",1165,0) do ^DIR write ! "RTN","TMGDBAP2",1166,0) GVIDone "RTN","TMGDBAP2",1167,0) quit Y "RTN","TMGDBAP2",1168,0) "RTN","TMGDBAP2",1169,0) "RTN","TMGDBAP2",1170,0) AskFIENS() "RTN","TMGDBAP2",1171,0) ;"Purpose: Ask user to pick a file number, then pick a record "RTN","TMGDBAP2",1172,0) ;" from that file. This supports selection of subfiles. "RTN","TMGDBAP2",1173,0) ;"Input: none "RTN","TMGDBAP2",1174,0) ;"Results: format-- File^IENS, or ^ if abort "RTN","TMGDBAP2",1175,0) new result set result="^" "RTN","TMGDBAP2",1176,0) "RTN","TMGDBAP2",1177,0) new DIR,X,Y "RTN","TMGDBAP2",1178,0) set DIR(0)="F" "RTN","TMGDBAP2",1179,0) set DIR("A")="Select FILE (or SUBFILE)" "RTN","TMGDBAP2",1180,0) set DIR("?")="Answer with FILE NUMBER or NAME, or SUBFILE NUMBER" "RTN","TMGDBAP2",1181,0) set DIR("PRE")="D ASKSCRN^TMGDBAPI" "RTN","TMGDBAP2",1182,0) do ^DIR "RTN","TMGDBAP2",1183,0) set Y=+Y "RTN","TMGDBAP2",1184,0) if Y>0 set result=Y_"^"_$$AskIENS(Y) "RTN","TMGDBAP2",1185,0) "RTN","TMGDBAP2",1186,0) quit result "RTN","TMGDBAP2",1187,0) "RTN","TMGDBAP2",1188,0) ASKSCRN "RTN","TMGDBAP2",1189,0) ;"Purpose: an Input transform for AskFIENS "RTN","TMGDBAP2",1190,0) ;"Input: (global) X -- the user's response in ^DIR "RTN","TMGDBAP2",1191,0) ;" (global) DTOUT -- this will be defined if the read timed out. "RTN","TMGDBAP2",1192,0) ;"Output: If X is changed, it will be as if user entered in new X "RTN","TMGDBAP2",1193,0) ;" If X is killed, it will be as if user entered an illegal value. "RTN","TMGDBAP2",1194,0) "RTN","TMGDBAP2",1195,0) if $data(DTOUT) quit "RTN","TMGDBAP2",1196,0) if +X=X do "RTN","TMGDBAP2",1197,0) . if $data(^DD(X,0))=0 kill X quit "RTN","TMGDBAP2",1198,0) . if $data(^DIC(X,0)) write " ",$piece(^DIC(X,0),"^",1)," " quit "RTN","TMGDBAP2",1199,0) . ;"Here we deal with subfiles "RTN","TMGDBAP2",1200,0) . new temp,i,filenum "RTN","TMGDBAP2",1201,0) . set filenum=X "RTN","TMGDBAP2",1202,0) . set X="" "RTN","TMGDBAP2",1203,0) . for i=100:-1:0 do quit:(filenum=0) "RTN","TMGDBAP2",1204,0) . . set temp(i)=filenum "RTN","TMGDBAP2",1205,0) . . set X=X_filenum_"," "RTN","TMGDBAP2",1206,0) . . set filenum=+$get(^DD(filenum,0,"UP")) "RTN","TMGDBAP2",1207,0) . new indent set indent=5 "RTN","TMGDBAP2",1208,0) . new indentS set $piece(indentS," ",75)=" " "RTN","TMGDBAP2",1209,0) . write ! "RTN","TMGDBAP2",1210,0) . set i="" "RTN","TMGDBAP2",1211,0) . for set i=$order(temp(i)) quit:(i="") do "RTN","TMGDBAP2",1212,0) . . set filenum=+$get(temp(i)) quit:(filenum=0) "RTN","TMGDBAP2",1213,0) . . write $extract(indentS,1,indent) "RTN","TMGDBAP2",1214,0) . . if $data(^DIC(filenum,0)) do "RTN","TMGDBAP2",1215,0) . . . write $piece(^DIC(filenum,0),"^",1)," (FILE #",filenum,")",! "RTN","TMGDBAP2",1216,0) . . else write "+--SUBFILE# ",filenum,! "RTN","TMGDBAP2",1217,0) . . set indent=indent+3 "RTN","TMGDBAP2",1218,0) else do ;"check validity of FILE NAME "RTN","TMGDBAP2",1219,0) . if X="" quit "RTN","TMGDBAP2",1220,0) . new filenum "RTN","TMGDBAP2",1221,0) . set filenum=$order(^DIC("B",X,"")) "RTN","TMGDBAP2",1222,0) . if +filenum>0 set X=+filenum_"," quit "RTN","TMGDBAP2",1223,0) . set filenum=$$GetFileNum(X) "RTN","TMGDBAP2",1224,0) . if +filenum>0 set X=+filenum_"," quit "RTN","TMGDBAP2",1225,0) . new DIC,Y "RTN","TMGDBAP2",1226,0) . set DIC=1 set DIC(0)="EQM" "RTN","TMGDBAP2",1227,0) . do ^DIC w ! "RTN","TMGDBAP2",1228,0) . if +Y>0 set X=+Y quit "RTN","TMGDBAP2",1229,0) . set X=0 "RTN","TMGDBAP2",1230,0) "RTN","TMGDBAP2",1231,0) if $get(X)="" set X=0 "RTN","TMGDBAP2",1232,0) quit "RTN","TMGDBAP2",1233,0) "RTN","TMGDBAP2",1234,0) "RTN","TMGDBAP2",1235,0) AskIENS(FileNum,IENS) "RTN","TMGDBAP2",1236,0) ;"Purpose: To ask user to select a record in File indicated by FileNum. "RTN","TMGDBAP2",1237,0) ;" If FileNum is a subfile number, then the user will be asked "RTN","TMGDBAP2",1238,0) ;" for records to drill down to desired record, and return values "RTN","TMGDBAP2",1239,0) ;" as an IENS. "RTN","TMGDBAP2",1240,0) ;"Input: FileNum: A file number or subfile number "RTN","TMGDBAP2",1241,0) ;" IENS: OPTIONAL. Allows for supplying a partial IENS supplying a "RTN","TMGDBAP2",1242,0) ;" partial path. E.g. if a full IENS to FileNum "RTN","TMGDBAP2",1243,0) ;" would be '2,3,4455,' and if the IENS supplied is "RTN","TMGDBAP2",1244,0) ;" '3,4455,' then only the missing IEN (in this case 2) "RTN","TMGDBAP2",1245,0) ;" would be asked. "RTN","TMGDBAP2",1246,0) ;"Results: Returns IENS. format: IEN in file,IEN in parentfile,IEN in grandparentfile, ... , "RTN","TMGDBAP2",1247,0) ;" Note: IENS will contain '?' if there is a problem, "RTN","TMGDBAP2",1248,0) ;" or "" if FileNum is invalid "RTN","TMGDBAP2",1249,0) "RTN","TMGDBAP2",1250,0) new array "RTN","TMGDBAP2",1251,0) do GetRefArray(FileNum,.array) "RTN","TMGDBAP2",1252,0) new resultIENS set resultIENS="" "RTN","TMGDBAP2",1253,0) set IENS=$get(IENS) "RTN","TMGDBAP2",1254,0) "RTN","TMGDBAP2",1255,0) new DANum set DANum=1 "RTN","TMGDBAP2",1256,0) new TMGDA,numIENS "RTN","TMGDBAP2",1257,0) set numIENS=$length(IENS,",") "RTN","TMGDBAP2",1258,0) new i,abort set i="",abort=0 "RTN","TMGDBAP2",1259,0) for set i=$order(array(i),-1) quit:(i="")!abort do "RTN","TMGDBAP2",1260,0) . new DIC,X,Y,DA "RTN","TMGDBAP2",1261,0) . new tempIEN set tempIEN=+$piece(IENS,",",numIENS-DANum) "RTN","TMGDBAP2",1262,0) . if tempIEN'>0 do "RTN","TMGDBAP2",1263,0) . . set DIC=$get(array(i,"GL")),DIC(0)="AEQM" "RTN","TMGDBAP2",1264,0) . . if DIC'="" write !,"Select entry in file# ",array(i,"FILE NUM") "RTN","TMGDBAP2",1265,0) . . do ^DIC write ! "RTN","TMGDBAP2",1266,0) . else set Y=tempIEN "RTN","TMGDBAP2",1267,0) . if +Y'>0 set resultIENS="?,"_resultIENS,abort=1 quit "RTN","TMGDBAP2",1268,0) . set TMGDA(DANum)=+Y,DANum=DANum+1 "RTN","TMGDBAP2",1269,0) . set resultIENS=+Y_","_resultIENS "RTN","TMGDBAP2",1270,0) "RTN","TMGDBAP2",1271,0) quit resultIENS "RTN","TMGDBAP2",1272,0) "RTN","TMGDBAP2",1273,0) "RTN","TMGDBAP2",1274,0) GetRefArray(FileNum,array) "RTN","TMGDBAP2",1275,0) ;"Purpose: To return an array containing global references that can "RTN","TMGDBAP2",1276,0) ;" be passed to ^DIC, for given file or subfile number "RTN","TMGDBAP2",1277,0) ;"Input: FileNum: A file number or subfile number "RTN","TMGDBAP2",1278,0) ;" array: PASS BY REFERENCE. See format below "RTN","TMGDBAP2",1279,0) ;"Results: none, but array is filled with result. Format (example): "RTN","TMGDBAP2",1280,0) ;" array(1,"FILE NUM")=2.011 <--- sub sub file "RTN","TMGDBAP2",1281,0) ;" array(1,"GL")="^DPT(TMGDA(1),""DE"",TMGDA(2),""1""," "RTN","TMGDBAP2",1282,0) ;" array(2,"FILE NUM")=2.001 <---- sub file "RTN","TMGDBAP2",1283,0) ;" array(2,"GL")="^DPT(TMGDA(1),""DE""," "RTN","TMGDBAP2",1284,0) ;" array(3,"FILE NUM")=2 <---- parent file "RTN","TMGDBAP2",1285,0) ;" array(3,"GL")="^DPT(" "RTN","TMGDBAP2",1286,0) ;"Note: To use the references stored in "GL", then the IEN for "RTN","TMGDBAP2",1287,0) ;" each step should be stored in TMGDA(x) "RTN","TMGDBAP2",1288,0) "RTN","TMGDBAP2",1289,0) new i "RTN","TMGDBAP2",1290,0) for i=1:1 quit:(+$get(FileNum)=0) do "RTN","TMGDBAP2",1291,0) . set array(i,"FILE NUM")=FileNum "RTN","TMGDBAP2",1292,0) . if $data(^DD(FileNum,0,"UP")) do "RTN","TMGDBAP2",1293,0) . . new parentFlNum,field "RTN","TMGDBAP2",1294,0) . . set parentFlNum=+$get(^DD(FileNum,0,"UP")) "RTN","TMGDBAP2",1295,0) . . if parentFlNum=0 quit ;"really should be an abort "RTN","TMGDBAP2",1296,0) . . set field=$order(^DD(parentFlNum,"SB",FileNum,"")) "RTN","TMGDBAP2",1297,0) . . if field="" quit ;"really should be an abort "RTN","TMGDBAP2",1298,0) . . new node set node=$piece($piece($get(^DD(parentFlNum,field,0)),"^",4),";",1) "RTN","TMGDBAP2",1299,0) . . set array(i,"NODE IN PARENT")=node "RTN","TMGDBAP2",1300,0) . else do "RTN","TMGDBAP2",1301,0) . . set array(i,"GL")=$get(^DIC(FileNum,0,"GL")) "RTN","TMGDBAP2",1302,0) . set FileNum=+$get(^DD(FileNum,0,"UP")) "RTN","TMGDBAP2",1303,0) "RTN","TMGDBAP2",1304,0) set i="" set i=$order(array(i),-1) "RTN","TMGDBAP2",1305,0) set array(i,"ref")=$get(array(i,"GL"))_"TMGDA(1)," "RTN","TMGDBAP2",1306,0) new DANum set DANum=2 "RTN","TMGDBAP2",1307,0) for set i=$order(array(i),-1) quit:(i="") do "RTN","TMGDBAP2",1308,0) . new ref "RTN","TMGDBAP2",1309,0) . set ref=$get(array(i+1,"ref"))_""""_$get(array(i,"NODE IN PARENT"))_"""," "RTN","TMGDBAP2",1310,0) . kill array(i+1,"ref"),array(i,"NODE IN PARENT") "RTN","TMGDBAP2",1311,0) . set array(i,"GL")=ref "RTN","TMGDBAP2",1312,0) . set array(i,"ref")=ref_"TMGDA("_DANum_")," "RTN","TMGDBAP2",1313,0) . set DANum=DANum+1 "RTN","TMGDBAP2",1314,0) kill array(1,"ref") "RTN","TMGDBAP2",1315,0) quit "RTN","TMGDBAP2",1316,0) "RTN","TMGDBAP2",1317,0) FIENS2Root(FIENS) "RTN","TMGDBAP2",1318,0) ;"Purpose: to convert a Files^IENS string into a root reference "RTN","TMGDBAP2",1319,0) ;"Input: FIENS: format: FileNumber^StandardIENS "RTN","TMGDBAP2",1320,0) ;"Output: A global root in open format "RTN","TMGDBAP2",1321,0) quit "RTN","TMGDBAP2",1322,0) "RTN","TMGDBAP2",1323,0) "RTN","TMGDBAP2",1324,0) GetRef(file,IENS,field) "RTN","TMGDBAP2",1325,0) ;"Purpose: to return the global reference for a given record "RTN","TMGDBAP2",1326,0) ;"Input: file -- File or subfile number "RTN","TMGDBAP2",1327,0) ;" IENS -- an IEN, or an IENS for record "RTN","TMGDBAP2",1328,0) ;" field -- OPTIONAL. "RTN","TMGDBAP2",1329,0) ;"Results: if field is NOT supplied, or "RTN","TMGDBAP2",1330,0) ;" OPEN global ref "RTN","TMGDBAP2",1331,0) ;" if field IS supplied "RTN","TMGDBAP2",1332,0) ;" CLOSED global ref@piece "RTN","TMGDBAP2",1333,0) ;" e.g. ^TMG(22706.9,3,2,IEN,0)@1 <-- note 'IEN' placeholder "RTN","TMGDBAP2",1334,0) "RTN","TMGDBAP2",1335,0) ;"Note: This function really needs to be fleshed out some more... "RTN","TMGDBAP2",1336,0) ;"Note: this only will work for normal files, or subfiles ONE (1) level deep... "RTN","TMGDBAP2",1337,0) "RTN","TMGDBAP2",1338,0) new ref set ref="" "RTN","TMGDBAP2",1339,0) new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file) "RTN","TMGDBAP2",1340,0) if parentFile=0 goto GRF1 ;"handle non-subfiles separately. "RTN","TMGDBAP2",1341,0) "RTN","TMGDBAP2",1342,0) set fieldInParent=$piece(parentFile,"^",2) "RTN","TMGDBAP2",1343,0) set ref=$get(^DIC(+parentFile,0,"GL")) "RTN","TMGDBAP2",1344,0) new IENinParent set IENinParent=$piece(IENS,",",2) "RTN","TMGDBAP2",1345,0) set ref=ref_IENinParent_"," "RTN","TMGDBAP2",1346,0) new storeLoc set storeLoc=$piece($get(^DD(+parentFile,fieldInParent,0)),"^",4) "RTN","TMGDBAP2",1347,0) ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this... "RTN","TMGDBAP2",1348,0) set ref=ref_+storeLoc_"," "RTN","TMGDBAP2",1349,0) new IENinSubRec set IENinSubRec=$piece(IENS,",",1) "RTN","TMGDBAP2",1350,0) if IENinSubRec="" set IENinSubRec="IEN" "RTN","TMGDBAP2",1351,0) set ref=ref_IENinSubRec_"," "RTN","TMGDBAP2",1352,0) "RTN","TMGDBAP2",1353,0) if $get(field)="" goto GRF2 ;"done "RTN","TMGDBAP2",1354,0) set storeLoc=$piece($get(^DD(file,field,0)),"^",4) "RTN","TMGDBAP2",1355,0) set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2) "RTN","TMGDBAP2",1356,0) goto GRF2 "RTN","TMGDBAP2",1357,0) "RTN","TMGDBAP2",1358,0) GRF1 "RTN","TMGDBAP2",1359,0) set ref=$get(^DIC(file,0,"GL")) "RTN","TMGDBAP2",1360,0) set ref=ref_+IENS_"," "RTN","TMGDBAP2",1361,0) if $get(field)="" goto GRF2 ;"done "RTN","TMGDBAP2",1362,0) new storeLoc set storeLoc=$piece($get(^DD(file,field,0)),"^",4) "RTN","TMGDBAP2",1363,0) set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2) "RTN","TMGDBAP2",1364,0) ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this... "RTN","TMGDBAP2",1365,0) GRF2 "RTN","TMGDBAP2",1366,0) quit ref "RTN","TMGDBAP2",1367,0) "RTN","TMGDBAP2",1368,0) TrimFDA(FDA,Quiet) "RTN","TMGDBAP2",1369,0) ;"Purpose: To take an FDA, and compare it to data already present in the "RTN","TMGDBAP2",1370,0) ;" record specified by the FDA. If any values already in the record "RTN","TMGDBAP2",1371,0) ;" match those in the FDA, then those entries will be removed from the "RTN","TMGDBAP2",1372,0) ;" FDA array. "RTN","TMGDBAP2",1373,0) ;"Input: FDA -- PASS BY REFERENCE. A standard Fileman FDA. "RTN","TMGDBAP2",1374,0) ;" Quiet -- OPTIONAL. If 1, then error messages will be supressed "RTN","TMGDBAP2",1375,0) ;" (These would be messages generated on READING existing "RTN","TMGDBAP2",1376,0) ;" data, not writing new data.) "RTN","TMGDBAP2",1377,0) ;" default value=1 "RTN","TMGDBAP2",1378,0) ;"Output: Values from FDA may be removed. "RTN","TMGDBAP2",1379,0) ;"Results: final IENS (i.e. '+1,3,' --> '5,3,' if prev value found) "RTN","TMGDBAP2",1380,0) ;"Note: match will be made base on INTERNAL, or EXTERNAL forms "RTN","TMGDBAP2",1381,0) ;"Note: Fields should be specified by numbers, NOT NAMES. "RTN","TMGDBAP2",1382,0) "RTN","TMGDBAP2",1383,0) new tempIENS set tempIENS="" "RTN","TMGDBAP2",1384,0) if $data(FDA)'>0 goto TFDDone "RTN","TMGDBAP2",1385,0) new TMGDATA,TMGMSG "RTN","TMGDBAP2",1386,0) new file,IENS "RTN","TMGDBAP2",1387,0) set file=$order(FDA("")) "RTN","TMGDBAP2",1388,0) set IENS=$order(FDA(file,"")) "RTN","TMGDBAP2",1389,0) set tempIENS=IENS "RTN","TMGDBAP2",1390,0) set Quiet=$get(Quiet,1) "RTN","TMGDBAP2",1391,0) "RTN","TMGDBAP2",1392,0) new fieldsS set fieldsS="" "RTN","TMGDBAP2",1393,0) new field set field="" "RTN","TMGDBAP2",1394,0) for set field=$order(FDA(file,IENS,field)) quit:(field="") do "RTN","TMGDBAP2",1395,0) . set fieldsS=fieldsS_field_";" "RTN","TMGDBAP2",1396,0) "RTN","TMGDBAP2",1397,0) new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file) "RTN","TMGDBAP2",1398,0) if parentFile=0 goto TFD0 ;"handle non-subfiles separately. "RTN","TMGDBAP2",1399,0) "RTN","TMGDBAP2",1400,0) ;"e.g. FDA(22706.9001,"+1,3",.01)=1 "RTN","TMGDBAP2",1401,0) ;" FDA(22706.9001,"+1,3",.02)=2 "RTN","TMGDBAP2",1402,0) ;"Note: The .01 field is used to find a matching subrecord, which is then "RTN","TMGDBAP2",1403,0) ;" check for preexisting data. If multiple matches for .01 are found, "RTN","TMGDBAP2",1404,0) ;" then the process is aborted, and the FDA will NOT BE TRIMMED. "RTN","TMGDBAP2",1405,0) "RTN","TMGDBAP2",1406,0) set $piece(tempIENS,",",1)="" ;"leave first piece blank in IENS "RTN","TMGDBAP2",1407,0) new value set value=$get(FDA(file,IENS,.01)) "RTN","TMGDBAP2",1408,0) "RTN","TMGDBAP2",1409,0) ;"new i for i=1:1:$length(fieldsS,",") do ;"append 'E' to each field number "RTN","TMGDBAP2",1410,0) ;". new field set field=$piece(fieldsS,";",i) "RTN","TMGDBAP2",1411,0) ;". set field=field_"E" "RTN","TMGDBAP2",1412,0) ;". set $piece(fieldsS,";",i)=field "RTN","TMGDBAP2",1413,0) ;" "RTN","TMGDBAP2",1414,0) ;"new TMGFIND "RTN","TMGDBAP2",1415,0) ;" "RTN","TMGDBAP2",1416,0) ;"I can't get this part to work... so will work around "RTN","TMGDBAP2",1417,0) ;"do FIND^DIC(file,tempIENS,fieldsS,"BMU",value,"*",,,,"TMGFIND","TMGMSG") "RTN","TMGDBAP2",1418,0) ;"do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGDBAP2",1419,0) ;"if +$get(TMGFIND(0))'=1 goto TFDDone ;"abort "RTN","TMGDBAP2",1420,0) ;"merge TMGDATA(file,IENS)=TMGDATA("ID",1) "RTN","TMGDBAP2",1421,0) ;"goto TFD1 "RTN","TMGDBAP2",1422,0) "RTN","TMGDBAP2",1423,0) new ref set ref=$$GetRef(file,tempIENS,.01) ;"returns ref with 'IEN' built in... "RTN","TMGDBAP2",1424,0) new ref2 set ref2=$$CREF^DILF($piece(ref,"IEN",1)) "RTN","TMGDBAP2",1425,0) new ref3 set ref3=$piece(ref,"@",1) "RTN","TMGDBAP2",1426,0) new p set p=$piece(ref,"@",2) "RTN","TMGDBAP2",1427,0) new found set found=0 "RTN","TMGDBAP2",1428,0) new IEN set IEN=0 "RTN","TMGDBAP2",1429,0) for set IEN=$order(@ref2@(IEN)) quit:(+IEN'>0)!(found>0) do "RTN","TMGDBAP2",1430,0) . new valueFound set valueFound=$piece($get(@ref3),"^",p) "RTN","TMGDBAP2",1431,0) . if valueFound=value set found=IEN "RTN","TMGDBAP2",1432,0) if found=0 set tempIENS=IENS goto TFDDone "RTN","TMGDBAP2",1433,0) set tempIENS=found_tempIENS "RTN","TMGDBAP2",1434,0) TFD0 "RTN","TMGDBAP2",1435,0) do GETS^DIQ(file,tempIENS,fieldsS,"EI","TMGDATA","TMGMSG") "RTN","TMGDBAP2",1436,0) if 'Quiet do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGDBAP2",1437,0) "RTN","TMGDBAP2",1438,0) TFD1 "RTN","TMGDBAP2",1439,0) for set field=$order(FDA(file,IENS,field)) quit:(field="") do "RTN","TMGDBAP2",1440,0) . new found set found=0 "RTN","TMGDBAP2",1441,0) . new FDAvalue set FDAvalue=$get(FDA(file,IENS,field)) "RTN","TMGDBAP2",1442,0) . if $get(TMGDATA(file,tempIENS,field,"I"))=FDAvalue set found=1 "RTN","TMGDBAP2",1443,0) . if $get(TMGDATA(file,tempIENS,field,"E"))=FDAvalue set found=1 "RTN","TMGDBAP2",1444,0) . if (FDAvalue="@")&($data(TMGDATA(file,tempIENS,field))=0) set found=1 "RTN","TMGDBAP2",1445,0) . if found=1 kill FDA(file,IENS,field) "RTN","TMGDBAP2",1446,0) goto TFDDone "RTN","TMGDBAP2",1447,0) TFDDone "RTN","TMGDBAP2",1448,0) quit tempIENS "RTN","TMGDBAP2",1449,0) "RTN","TMGDBAP2",1450,0) "RTN","TMGDBAP2",1451,0) "RTN","TMGDBAP2",1452,0) GetPtrsOUT(File,Info) "RTN","TMGDBAP2",1453,0) ;"Purpose: to get a list of pointers out from the file. "RTN","TMGDBAP2",1454,0) ;"Input: File -- File Name or Number of file to investigate "RTN","TMGDBAP2",1455,0) ;" Info -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGDBAP2",1456,0) ;" Info(Field#)=PointedToFileNum "RTN","TMGDBAP2",1457,0) ;" Info(Field#,"GL")=an open global ref to pointed-to file "RTN","TMGDBAP2",1458,0) ;"results: none "RTN","TMGDBAP2",1459,0) "RTN","TMGDBAP2",1460,0) if $get(File)="" goto GPODone "RTN","TMGDBAP2",1461,0) if +File'=File set File=$$GetFileNum(File) "RTN","TMGDBAP2",1462,0) new field set field=0 "RTN","TMGDBAP2",1463,0) new done set done=0 "RTN","TMGDBAP2",1464,0) for set field=$order(^DD(File,field)) quit:(+field'>0)!(done=1) do "RTN","TMGDBAP2",1465,0) . new array "RTN","TMGDBAP2",1466,0) . do FIELD^DID(File,field,"N","POINTER","array") "RTN","TMGDBAP2",1467,0) . if $get(array("POINTER"))="" quit "RTN","TMGDBAP2",1468,0) . if array("POINTER")[";" quit "RTN","TMGDBAP2",1469,0) . set Info(field,"GL")=array("POINTER") "RTN","TMGDBAP2",1470,0) . new temp set temp=$piece($get(^DD(File,field,0)),"^",2) "RTN","TMGDBAP2",1471,0) . set temp=+$piece(temp,"P",2) "RTN","TMGDBAP2",1472,0) . set Info(field)=temp "RTN","TMGDBAP2",1473,0) . if $data(array) write field," " zwr array "RTN","TMGDBAP2",1474,0) GPODone "RTN","TMGDBAP2",1475,0) quit "RTN","TMGDBAP2",1476,0) "RTN","TMGDBAPI") 0^7^B13065932 "RTN","TMGDBAPI",1,0) TMGDBAPI ;TMG/kst/Database API library ;03/25/06 "RTN","TMGDBAPI",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGDBAPI",3,0) "RTN","TMGDBAPI",4,0) ;"TMG DATABASE API FUNCTIONS "RTN","TMGDBAPI",5,0) ;"Kevin Toppenberg MD "RTN","TMGDBAPI",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGDBAPI",7,0) ;"7-12-2005 "RTN","TMGDBAPI",8,0) "RTN","TMGDBAPI",9,0) ;"======================================================================= "RTN","TMGDBAPI",10,0) ;" API -- Public Functions. "RTN","TMGDBAPI",11,0) ;"======================================================================= "RTN","TMGDBAPI",12,0) ;"$$GetNumField^TMGDBAPI(FileNumber,FieldName) ;Convert Field Name to Field Number "RTN","TMGDBAPI",13,0) ;"$$GetFileNum^TMGDBAPI(FileName) ;Convert File Name to File Number "RTN","TMGDBAPI",14,0) ;"$$SetFileFldNums^TMGDBAPI(File,Field,FileNumber,FieldNumber) ;do both functions above at once. "RTN","TMGDBAPI",15,0) ;"$$GetFName^TMGDBAPI(FileNumber) ;Convert File Number to File Name "RTN","TMGDBAPI",16,0) ;"$$GetFldName^TMGDBAPI(File,FieldNumber) ;Convert Field Number to Field Name "RTN","TMGDBAPI",17,0) ;"$$GetFldList^TMGDBAPI(File,pArray) ;Get list of all fields for a file. "RTN","TMGDBAPI",18,0) ;"FieldExists^TMGDBAPI(FileNumber,Field) "RTN","TMGDBAPI",19,0) ;"SetFieldInfo^TMGDBAPI(File,Field,Array) "RTN","TMGDBAPI",20,0) ;"GetFieldInfo^TMGDBAPI(FileNumber,Field,VarOutP) "RTN","TMGDBAPI",21,0) ;"GetSubFileNumber^TMGDBAPI(FileNumber,Field) "RTN","TMGDBAPI",22,0) ;"$$IsSubFile^TMGDBAPI(File) "RTN","TMGDBAPI",23,0) ;"GetSubFInfo^TMGDBAPI(SubFileNum,Array) "RTN","TMGDBAPI",24,0) ;"GetRecMatch^TMGDBAPI(Data,RecNumIEN) "RTN","TMGDBAPI",25,0) ;"CompRec^TMGDBAPI(FileNumber,dbRec,TestRec) "RTN","TMGDBAPI",26,0) ;"UploadData^TMGDBAPI(DaDIta,RecNumIEN) "RTN","TMGDBAPI",27,0) ;"ValueLookup^TMGDBAPI(Params) "RTN","TMGDBAPI",28,0) ;"FileUtility^TMGDBAPI(Params) "RTN","TMGDBAPI",29,0) ;"AddRec^TMGDBAPI(Data) "RTN","TMGDBAPI",30,0) ;"OverwriteRec^TMGDBAPI(RecNum,Data) "RTN","TMGDBAPI",31,0) ;"SetupFileNum^TMGDBAPI(Data) "RTN","TMGDBAPI",32,0) ;"RecFind^TMGDBAPI(Params) "RTN","TMGDBAPI",33,0) ;"FieldCompare^TMGDBAPI(TestField,dbField,Type) "RTN","TMGDBAPI",34,0) ;"$$dbWrite^TMGDBAPI(FDA,Overwrite,TMGIDE,Flags,ErrArray) "RTN","TMGDBAPI",35,0) ;"$$DelIEN^TMGDBAPI(File,RecNumIEN,ErrArray) "RTN","TMGDBAPI",36,0) ;"$$WriteWP^TMGDBAPI(File,RecNumIEN,Field,Array) "RTN","TMGDBAPI",37,0) ;"$$ReadWP^TMGDBAPI(File,IENS,Field,Array) "RTN","TMGDBAPI",38,0) ;"$$ShowIfError^TMGDBAPI(TMGMsg,PriorErrorFund) "RTN","TMGDBAPI",39,0) ;"$$GetValidInput^TMGDBAPI(File,Field) -- Get a valid input for field in file, asking user "RTN","TMGDBAPI",40,0) ;"$$AskFIENS^TMGDBAPI() -- pick a (sub)file number, then pick a record from that file. "RTN","TMGDBAPI",41,0) ;"$$AskIENS^TMGDBAPI(FileNum) -- return IENS for File (or subfile) number "RTN","TMGDBAPI",42,0) ;"GetRef^TMGDBAPI(file,IENS,field) -- to return the global reference for a given record "RTN","TMGDBAPI",43,0) ;"GetPtrsOUT^TMGDBAPI(FileNum,Info) -- get a list of pointers out from the file. "RTN","TMGDBAPI",44,0) ;"$$TrimFDA^TMGDBAPI(FDA,Quiet) -- Trim FDA of any data already present in the database "RTN","TMGDBAPI",45,0) "RTN","TMGDBAPI",46,0) ;"======================================================================= "RTN","TMGDBAPI",47,0) ;"PRIVATE API FUNCTIONS "RTN","TMGDBAPI",48,0) ;"======================================================================= "RTN","TMGDBAPI",49,0) ;"ConvertFDA(FDA,MarkerArray) "RTN","TMGDBAPI",50,0) ;"ConvertIENS(IENS,MarkerArray) "RTN","TMGDBAPI",51,0) ;"SetupFDA(Data,FDA,IENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) "RTN","TMGDBAPI",52,0) ;"HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) "RTN","TMGDBAPI",53,0) ;"HandleHacksArray(MsgArray) "RTN","TMGDBAPI",54,0) ;"GetRefArray(FileNum,array) "RTN","TMGDBAPI",55,0) "RTN","TMGDBAPI",56,0) ;"======================================================================= "RTN","TMGDBAPI",57,0) ;"DEPENDENCIES "RTN","TMGDBAPI",58,0) ;"TMGDEBUG "RTN","TMGDBAPI",59,0) ;"TMGUSRIF "RTN","TMGDBAPI",60,0) ;"TMGSTUTL "RTN","TMGDBAPI",61,0) ;"======================================================================= "RTN","TMGDBAPI",62,0) "RTN","TMGDBAPI",63,0) ;"======================================================================= "RTN","TMGDBAPI",64,0) "RTN","TMGDBAPI",65,0) ;"FORMAT OF DATA ARRAY "RTN","TMGDBAPI",66,0) "RTN","TMGDBAPI",67,0) ;" cNull="(none)" "RTN","TMGDBAPI",68,0) ;" cRecNum="RECNUM" "RTN","TMGDBAPI",69,0) ;" cOutput="OUTVAR" "RTN","TMGDBAPI",70,0) ;" cGlobal="GLOBAL" "RTN","TMGDBAPI",71,0) ;" cEntries="Entries" "RTN","TMGDBAPI",72,0) ;" cFlags="FLAGS" "RTN","TMGDBAPI",73,0) ;" cParentIENS="ParentIENS" "RTN","TMGDBAPI",74,0) "RTN","TMGDBAPI",75,0) ;"The Data array will be filed with data. (An example) "RTN","TMGDBAPI",76,0) ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion "RTN","TMGDBAPI",77,0) ;" Data(0,"FILE",cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," "RTN","TMGDBAPI",78,0) ;" Data(0,cRecNum)=2 <-- only if user-specified. "RTN","TMGDBAPI",79,0) ;" Data(0,cEntries)=1 "RTN","TMGDBAPI",80,0) ;" Data(1,".01")="MyData1" "RTN","TMGDBAPI",81,0) ;" Data(1,".01","MATCHVALUE")="MyData1" "RTN","TMGDBAPI",82,0) ;" Data(1,".01",cFlags)=any flags given (only present if user specified) "RTN","TMGDBAPI",83,0) ;" Data(1,".02")="Bill" "RTN","TMGDBAPI",84,0) ;" Data(1,".02","MATCHVALUE")="John" "RTN","TMGDBAPI",85,0) ;" Data(1,".03")="MyData3" "RTN","TMGDBAPI",86,0) ;" Data(1,".03",cFlags)=any flags given (only present if user specified) "RTN","TMGDBAPI",87,0) ;" Data(1,".04")="MyData4" "RTN","TMGDBAPI",88,0) ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" "RTN","TMGDBAPI",89,0) ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" "RTN","TMGDBAPI",90,0) ;" Data(1,".07",0,cParentIENS)=",10033," "RTN","TMGDBAPI",91,0) ;" Data(1,".07",1,".01")="SubEntry1" "RTN","TMGDBAPI",92,0) ;" Data(1,".07",1,".02")="SE1" "RTN","TMGDBAPI",93,0) ;" Data(1,".07",1,".03")="'Some Info'" "RTN","TMGDBAPI",94,0) ;" Data(1,".07",2,".01")="SubEntry2" "RTN","TMGDBAPI",95,0) ;" Data(1,".07",2,".02")="SE2" "RTN","TMGDBAPI",96,0) ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 "RTN","TMGDBAPI",97,0) ;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033," "RTN","TMGDBAPI",98,0) ;" Data(1,".07",2,".04",1,".01")="JD" "RTN","TMGDBAPI",99,0) ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" "RTN","TMGDBAPI",100,0) "RTN","TMGDBAPI",101,0) ;"======================================================================= "RTN","TMGDBAPI",102,0) ;"======================================================================= "RTN","TMGDBAPI",103,0) "RTN","TMGDBAPI",104,0) GetNumField(FileNumber,FieldName) "RTN","TMGDBAPI",105,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",106,0) ;"Purpose: Given file and the name of a field, this will return the field NUMBER "RTN","TMGDBAPI",107,0) ;"Input: FileNumber. Number of file, i.e. "4.11" "RTN","TMGDBAPI",108,0) ;" FieldName: the name of a field, i.e. "NAME" spelling must exactly match "RTN","TMGDBAPI",109,0) ;"Output: Returns field number, i.e. ".01" or 0 if not found "RTN","TMGDBAPI",110,0) "RTN","TMGDBAPI",111,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",112,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",113,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",114,0) "RTN","TMGDBAPI",115,0) new result "RTN","TMGDBAPI",116,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") "RTN","TMGDBAPI",117,0) "RTN","TMGDBAPI",118,0) set result=$$FLDNUM^DILFD(FileNumber,FieldName) "RTN","TMGDBAPI",119,0) "RTN","TMGDBAPI",120,0) if result'=0 goto GNMFDone "RTN","TMGDBAPI",121,0) "RTN","TMGDBAPI",122,0) ;"-------------------------- "RTN","TMGDBAPI",123,0) ;"The below is a manual method "RTN","TMGDBAPI",124,0) "RTN","TMGDBAPI",125,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Having difficulty finding field name (? due to security ?). Doing Manual Check.") "RTN","TMGDBAPI",126,0) "RTN","TMGDBAPI",127,0) new FoundField "RTN","TMGDBAPI",128,0) new Index "RTN","TMGDBAPI",129,0) new result set result=cAbort "RTN","TMGDBAPI",130,0) set U=$get(U,"^") ;"Setup up U if doesn't yet exist "RTN","TMGDBAPI",131,0) "RTN","TMGDBAPI",132,0) if $$VFILE^DILFD(FileNumber)=0 do goto GNMFDone "RTN","TMGDBAPI",133,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") "RTN","TMGDBAPI",134,0) "RTN","TMGDBAPI",135,0) set Index="" "RTN","TMGDBAPI",136,0) GNmLoop set Index=$order(^DD(FileNumber,Index)) "RTN","TMGDBAPI",137,0) if Index="" goto GNMFDone "RTN","TMGDBAPI",138,0) if $data(^DD(FileNumber,Index,0))=0 goto GNMFDone "RTN","TMGDBAPI",139,0) set FoundField=$piece(^DD(FileNumber,Index,0),"^",1) "RTN","TMGDBAPI",140,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing fields: '",FoundField,"' vs. '",FieldName,"'") "RTN","TMGDBAPI",141,0) if FieldName=FoundField do goto GNMFDone "RTN","TMGDBAPI",142,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Match!") "RTN","TMGDBAPI",143,0) . set result=Index "RTN","TMGDBAPI",144,0) goto GNmLoop "RTN","TMGDBAPI",145,0) "RTN","TMGDBAPI",146,0) GNMFDone "RTN","TMGDBAPI",147,0) if result=cAbort do "RTN","TMGDBAPI",148,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to convert '",FieldName,"' in file '",FileNumber,"' to a field number. Check for Field name typo") "RTN","TMGDBAPI",149,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") "RTN","TMGDBAPI",150,0) "RTN","TMGDBAPI",151,0) quit result "RTN","TMGDBAPI",152,0) "RTN","TMGDBAPI",153,0) SetFileFldNums(File,Field,FileNumber,FieldNumber) "RTN","TMGDBAPI",154,0) ;"Purpose: To provide a generic shell to ensure that File and Field numbers are in place "RTN","TMGDBAPI",155,0) ;"Input: File -- File number or name "RTN","TMGDBAPI",156,0) ;" Field -- field number or name "RTN","TMGDBAPI",157,0) ;" FileNumber -- PASS BY REFERENCE -- an out parameter "RTN","TMGDBAPI",158,0) ;" FieldNum -- PASS BY REFERENCE -- an out parameter "RTN","TMGDBAPI",159,0) ;"Results: cOKToCont(1) if ok, otherwise cAbort(0) if error "RTN","TMGDBAPI",160,0) ;"Output -- FileNumber and FieldNumber are filled in. "RTN","TMGDBAPI",161,0) "RTN","TMGDBAPI",162,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",163,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",164,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",165,0) "RTN","TMGDBAPI",166,0) new result set result=cOKToCont "RTN","TMGDBAPI",167,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") "RTN","TMGDBAPI",168,0) "RTN","TMGDBAPI",169,0) set FileNumber=+$get(File) "RTN","TMGDBAPI",170,0) if FileNumber=0 set FileNumber=$$GetFileNum(.File) "RTN","TMGDBAPI",171,0) if FileNumber=0 do goto SFFNDone "RTN","TMGDBAPI",172,0) . set result=cAbort "RTN","TMGDBAPI",173,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") "RTN","TMGDBAPI",174,0) "RTN","TMGDBAPI",175,0) set FieldNumber=$get(Field) "RTN","TMGDBAPI",176,0) if FieldNumber=0 set FieldNumber=$$GetNumField(FileNumber,.Field) "RTN","TMGDBAPI",177,0) if FieldNumber=0 do goto SFFNDone "RTN","TMGDBAPI",178,0) . set result=cAbort "RTN","TMGDBAPI",179,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") "RTN","TMGDBAPI",180,0) "RTN","TMGDBAPI",181,0) SFFNDone "RTN","TMGDBAPI",182,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") "RTN","TMGDBAPI",183,0) quit result "RTN","TMGDBAPI",184,0) "RTN","TMGDBAPI",185,0) "RTN","TMGDBAPI",186,0) FieldExists(FileNumber,Field) "RTN","TMGDBAPI",187,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",188,0) ;"Purpose: To ensure that a field exists -- even if hidden by security measures "RTN","TMGDBAPI",189,0) ;"Input: FileNumber: File to check "RTN","TMGDBAPI",190,0) ;" Field: the field number (or name) to check "RTN","TMGDBAPI",191,0) ;"Result: 1 if field exists, 0 if doesn't, 2 if exists but is hidden to user "RTN","TMGDBAPI",192,0) "RTN","TMGDBAPI",193,0) new result,FieldNumber "RTN","TMGDBAPI",194,0) if +Field=0 set FieldNumber=$$GetNumField(FileNumber,Field) "RTN","TMGDBAPI",195,0) else set FieldNumber=Field "RTN","TMGDBAPI",196,0) "RTN","TMGDBAPI",197,0) set result=$$VFIELD^DILFD(FileNumber,FieldNumber) "RTN","TMGDBAPI",198,0) if result=1 goto FExsDone "RTN","TMGDBAPI",199,0) "RTN","TMGDBAPI",200,0) ;"Try a low-level data dictionary eval to see if really does exist, but is hidden "RTN","TMGDBAPI",201,0) if $data(^DD(FileNumber,FieldNumber,0))'=0 set result=2 "RTN","TMGDBAPI",202,0) "RTN","TMGDBAPI",203,0) FExsDone "RTN","TMGDBAPI",204,0) quit result "RTN","TMGDBAPI",205,0) "RTN","TMGDBAPI",206,0) "RTN","TMGDBAPI",207,0) "RTN","TMGDBAPI",208,0) GetSubFileNumber(FileNumber,Field) "RTN","TMGDBAPI",209,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",210,0) ;"Purpose: If FieldNumber is a 'multiple' field, then this function should return 'subfile' "RTN","TMGDBAPI",211,0) ;" number of the sub file. "RTN","TMGDBAPI",212,0) ;"Input:FileNumber-- the file number (or sub file number) that field exists in "RTN","TMGDBAPI",213,0) ;" Field-- the field number (or name) in file to lookup "RTN","TMGDBAPI",214,0) ;"Result: Returns sub file number, or 0 if not found or invalid "RTN","TMGDBAPI",215,0) "RTN","TMGDBAPI",216,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",217,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",218,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",219,0) "RTN","TMGDBAPI",220,0) new Info "RTN","TMGDBAPI",221,0) new result set result=cAbort "RTN","TMGDBAPI",222,0) new Output "RTN","TMGDBAPI",223,0) "RTN","TMGDBAPI",224,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") "RTN","TMGDBAPI",225,0) "RTN","TMGDBAPI",226,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) "RTN","TMGDBAPI",227,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Field=",Field) "RTN","TMGDBAPI",228,0) "RTN","TMGDBAPI",229,0) ;"First, verify file (or subfile) exists "RTN","TMGDBAPI",230,0) if $$VFILE^DILFD(FileNumber)=0 do goto GSFDone ;"abort "RTN","TMGDBAPI",231,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"File number '"_FileNumber_"' is not valid.") "RTN","TMGDBAPI",232,0) "RTN","TMGDBAPI",233,0) ;"Next, ensure Field exists in file "RTN","TMGDBAPI",234,0) if $$FieldExists(FileNumber,Field)=0 do goto GSFDone ;"abort "RTN","TMGDBAPI",235,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Field number '"_Field_"' is not valid.") "RTN","TMGDBAPI",236,0) "RTN","TMGDBAPI",237,0) ;"Next, ensure field is a multiple and get field info. "RTN","TMGDBAPI",238,0) do GetFieldInfo(FileNumber,Field,"Output") "RTN","TMGDBAPI",239,0) if $data(Output("MULTIPLE-VALUED"))=0 do goto GSFDone ;"abort "RTN","TMGDBAPI",240,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Field '"_Field_"' in File '"_FileNumber_"' is not a subfile.") "RTN","TMGDBAPI",241,0) "RTN","TMGDBAPI",242,0) ;"Now actually get subfile number "RTN","TMGDBAPI",243,0) if $data(Output("SPECIFIER"))=0 do goto GSFDone ;"abort "RTN","TMGDBAPI",244,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find 'Specifier' (subfile number)") "RTN","TMGDBAPI",245,0) set result=+Output("SPECIFIER") "RTN","TMGDBAPI",246,0) "RTN","TMGDBAPI",247,0) ;"Now actually get subfile number "RTN","TMGDBAPI",248,0) ;"set Info=$get(^DD(FileNumber,Field,0),0) "RTN","TMGDBAPI",249,0) ;"if Info=0 do goto GSFDone "RTN","TMGDBAPI",250,0) ;". do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get information from data dictionary.") "RTN","TMGDBAPI",251,0) ;"set result=+$piece(Info,"^",2) "RTN","TMGDBAPI",252,0) "RTN","TMGDBAPI",253,0) GSFDone "RTN","TMGDBAPI",254,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFile number is: ",result) "RTN","TMGDBAPI",255,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") "RTN","TMGDBAPI",256,0) quit result "RTN","TMGDBAPI",257,0) "RTN","TMGDBAPI",258,0) "RTN","TMGDBAPI",259,0) IsSubFile(File) "RTN","TMGDBAPI",260,0) ;"Purpose: to return if file is actually a subfile "RTN","TMGDBAPI",261,0) ;"Input: File -- File name or number "RTN","TMGDBAPI",262,0) ;"Results: Parent file number^Field in Parent File "RTN","TMGDBAPI",263,0) ;" or 0 if not a subfile. "RTN","TMGDBAPI",264,0) "RTN","TMGDBAPI",265,0) new result "RTN","TMGDBAPI",266,0) if +File'=File set File=$$GetFileNum(File) "RTN","TMGDBAPI",267,0) set result=+$get(^DD(File,0,"UP")) "RTN","TMGDBAPI",268,0) if result'>0 goto ISFDone "RTN","TMGDBAPI",269,0) "RTN","TMGDBAPI",270,0) ;"Now find which field this sub file is in its parent "RTN","TMGDBAPI",271,0) new fldInParent set fldInParent=0 "RTN","TMGDBAPI",272,0) new field set field=0 "RTN","TMGDBAPI",273,0) new done set done=0 "RTN","TMGDBAPI",274,0) for set field=$order(^DD(result,field)) quit:(+field'>0)!(done=1) do "RTN","TMGDBAPI",275,0) . new fldInfo set fldInfo=$piece($get(^DD(result,field,0)),"^",2) "RTN","TMGDBAPI",276,0) . if +fldInfo=File set fldInParent=field set done=1 "RTN","TMGDBAPI",277,0) if fldInParent>0 set result=result_"^"_fldInParent "RTN","TMGDBAPI",278,0) ISFDone "RTN","TMGDBAPI",279,0) quit result "RTN","TMGDBAPI",280,0) "RTN","TMGDBAPI",281,0) "RTN","TMGDBAPI",282,0) GetSubFInfo(SubFileNum,Array) "RTN","TMGDBAPI",283,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",284,0) ;"Purpose: To take a subfile NUMBER, and return information about it. "RTN","TMGDBAPI",285,0) ;"Input: SubFileNum-- the sub file number "RTN","TMGDBAPI",286,0) ;" Array -- PASS BY REFERENCE. An array to receive results. "RTN","TMGDBAPI",287,0) ;" any preexisting data is deleted. "RTN","TMGDBAPI",288,0) ;"Output Array is formated as follows: "RTN","TMGDBAPI",289,0) ;" Array("SUBFILE","NUMBER")=file number of this sub file. "RTN","TMGDBAPI",290,0) ;" Array("SUBFILE","NAME")=file name of this sub file. "RTN","TMGDBAPI",291,0) ;" Array("PARENT","NUMBER")=parent file number "RTN","TMGDBAPI",292,0) ;" Array("PARENT","NAME")=parent file name "RTN","TMGDBAPI",293,0) ;" Array("PARENT","GL")=global reference of parent, in open format<-- only valid if parent isn't also a subfile "RTN","TMGDBAPI",294,0) ;" Array("FIELD IN PARENT","NUMBER")=field number of subfile in parent "RTN","TMGDBAPI",295,0) ;" Array("FIELD IN PARENT","NAME")=filed name of subfile in parent "RTN","TMGDBAPI",296,0) ;" Array("FIELD IN PARENT","LOC")=node and piece where subfile is stored "RTN","TMGDBAPI",297,0) ;" Array("FIELD IN PARENT","CODE")=code giving subfile's attributes. "RTN","TMGDBAPI",298,0) ;"Result: 1 if found info, or 0 if not found or invalid "RTN","TMGDBAPI",299,0) "RTN","TMGDBAPI",300,0) new result set result=0 "RTN","TMGDBAPI",301,0) if '$get(SubFileNum) goto GSPDone "RTN","TMGDBAPI",302,0) kill Array "RTN","TMGDBAPI",303,0) set Array("SUBFILE","NUMBER")=SubFileNum "RTN","TMGDBAPI",304,0) set Array("SUBFILE","NAME")=$piece($get(^DD(SubFileNum,0)),"^",1) "RTN","TMGDBAPI",305,0) new parent "RTN","TMGDBAPI",306,0) set parent=+$get(^DD(SubFileNum,0,"UP")) "RTN","TMGDBAPI",307,0) if parent=0 goto GSPDone "RTN","TMGDBAPI",308,0) set Array("PARENT","NUMBER")=parent "RTN","TMGDBAPI",309,0) set Array("PARENT","NAME")=$order(^DD(parent,0,"NM","")) "RTN","TMGDBAPI",310,0) set Array("PARENT","GL")=$get(^DIC(parent,0,"GL")) "RTN","TMGDBAPI",311,0) new i set i=$order(^DD(parent,"")) "RTN","TMGDBAPI",312,0) for do quit:(i="")!(result=1) ;"scan all fields for a match "RTN","TMGDBAPI",313,0) . quit:(i="") "RTN","TMGDBAPI",314,0) . new node,num "RTN","TMGDBAPI",315,0) . set node=$get(^DD(parent,i,0)) "RTN","TMGDBAPI",316,0) . if +$piece(node,"^",2)=SubFileNum do quit "RTN","TMGDBAPI",317,0) . . set Array("FIELD IN PARENT","NUMBER")=i "RTN","TMGDBAPI",318,0) . . set Array("FIELD IN PARENT","NAME")=$piece(node,"^",1) "RTN","TMGDBAPI",319,0) . . set Array("FIELD IN PARENT","LOC")=$piece(node,"^",4) "RTN","TMGDBAPI",320,0) . . set Array("FIELD IN PARENT","CODE")=$piece(node,"^",2) "RTN","TMGDBAPI",321,0) . . set result=1 "RTN","TMGDBAPI",322,0) . set i=$order(^DD(parent,i)) "RTN","TMGDBAPI",323,0) "RTN","TMGDBAPI",324,0) GSPDone "RTN","TMGDBAPI",325,0) quit result "RTN","TMGDBAPI",326,0) "RTN","TMGDBAPI",327,0) "RTN","TMGDBAPI",328,0) "RTN","TMGDBAPI",329,0) GetFieldInfo(FileNumber,Field,VarOutP,InfoS) "RTN","TMGDBAPI",330,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",331,0) ;"Purpose: To get Field info, "RTN","TMGDBAPI",332,0) ;"Input: FileNumber: File or subfile number "RTN","TMGDBAPI",333,0) ;" Field: Field name or number "RTN","TMGDBAPI",334,0) ;" VarOutP -- the NAME of the variable to put result into. "RTN","TMGDBAPI",335,0) ;" InfoS -- [OPTIONAL] -- additional attributes of field info to be looked up "RTN","TMGDBAPI",336,0) ;" (as allowed by FIELD^DID). Multiple items should be "RTN","TMGDBAPI",337,0) ;" separated by a semicolon (';') "RTN","TMGDBAPI",338,0) ;" e.g. "TITLE;LABEL;POINTER" "RTN","TMGDBAPI",339,0) ;"Output: Data is put into VarOutP (any thing in VarOutP is erased first "RTN","TMGDBAPI",340,0) ;" i.e. @VarOutP@("MULTIPLE-VALUED")=X "RTN","TMGDBAPI",341,0) ;" i.e. @VarOutP@("SPECIFIER")=Y "RTN","TMGDBAPI",342,0) ;" i.e. @VarOutP@("TYPE")=Z "RTN","TMGDBAPI",343,0) ;" i.e. @VarOutP@("StoreLoc")="0;1" <-- not from fileman output (i.e. extra info) "RTN","TMGDBAPI",344,0) ;" (if additional attributes were specified, they will also be in array) "RTN","TMGDBAPI",345,0) ;"Result: none "RTN","TMGDBAPI",346,0) "RTN","TMGDBAPI",347,0) kill @VarOutP ;"erase any old information "RTN","TMGDBAPI",348,0) "RTN","TMGDBAPI",349,0) if +Field=0 set Field=$$GetNumField(FileNumber,Field) "RTN","TMGDBAPI",350,0) set @VarOutP@("StoreLoc")=$piece($get(^DD(FileNumber,Field,0)),"^",4) "RTN","TMGDBAPI",351,0) "RTN","TMGDBAPI",352,0) new Attribs set Attribs="MULTIPLE-VALUED;SPECIFIER;TYPE" "RTN","TMGDBAPI",353,0) if $data(InfoS) set Attribs=Attribs_";"_InfoS "RTN","TMGDBAPI",354,0) ;"Next, check if field is a multiple and get field info. "RTN","TMGDBAPI",355,0) do FIELD^DID(FileNumber,Field,,Attribs,VarOutP,"TMGMsg") "RTN","TMGDBAPI",356,0) if $data(TMGMsg) do "RTN","TMGDBAPI",357,0) . if $data(TMGMsg("DIERR"))'=0 do quit "RTN","TMGDBAPI",358,0) . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAPI",359,0) "RTN","TMGDBAPI",360,0) GFIDone "RTN","TMGDBAPI",361,0) quit "RTN","TMGDBAPI",362,0) "RTN","TMGDBAPI",363,0) "RTN","TMGDBAPI",364,0) "RTN","TMGDBAPI",365,0) HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) "RTN","TMGDBAPI",366,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",367,0) ;"Purpse: To force data into a field -- using low level 'hack' method "RTN","TMGDBAPI",368,0) ;"Input: GlobalP -- the NAME of the global to put this into, i.e. "^VA(200," "RTN","TMGDBAPI",369,0) ;" FileNumber- the file number "RTN","TMGDBAPI",370,0) ;" IENS -- the standard API IENS "RTN","TMGDBAPI",371,0) ;" FieldNum the field to put this into "RTN","TMGDBAPI",372,0) ;" Data -- the value to put in "RTN","TMGDBAPI",373,0) ;"Note: This can be used to put a value of "@" into a field "RTN","TMGDBAPI",374,0) ;"Result: 1 if ok to continue, 0=abort "RTN","TMGDBAPI",375,0) ;"!!!NOTICE: This is a very low level means of accessing the database. "RTN","TMGDBAPI",376,0) ;" The built in data verifiers, indexers etc etc will not be made aware of "RTN","TMGDBAPI",377,0) ;" changes made to the database through this method. USE ONLY WITH CAUTION. "RTN","TMGDBAPI",378,0) "RTN","TMGDBAPI",379,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",380,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",381,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",382,0) "RTN","TMGDBAPI",383,0) new result set result=cAbort "RTN","TMGDBAPI",384,0) "RTN","TMGDBAPI",385,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") "RTN","TMGDBAPI",386,0) "RTN","TMGDBAPI",387,0) if '$data(GlobalP) goto HWDone "RTN","TMGDBAPI",388,0) if '$data(FileNumber) goto HWDone "RTN","TMGDBAPI",389,0) if '$data(IENS) goto HWDone "RTN","TMGDBAPI",390,0) if '$data(FieldNum) goto HWDone "RTN","TMGDBAPI",391,0) if '$data(Data) goto HWDone "RTN","TMGDBAPI",392,0) "RTN","TMGDBAPI",393,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) "RTN","TMGDBAPI",394,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File:",FileNumber) "RTN","TMGDBAPI",395,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS:",IENS) "RTN","TMGDBAPI",396,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum:",FieldNum) "RTN","TMGDBAPI",397,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Data:",Data) "RTN","TMGDBAPI",398,0) "RTN","TMGDBAPI",399,0) new DDInfo "RTN","TMGDBAPI",400,0) new FieldInfo "RTN","TMGDBAPI",401,0) new Index,Part "RTN","TMGDBAPI",402,0) new OldData "RTN","TMGDBAPI",403,0) new RecNum "RTN","TMGDBAPI",404,0) "RTN","TMGDBAPI",405,0) ;"Get info from data dictionary r.e. where actual fields are stored in files. "RTN","TMGDBAPI",406,0) set DDInfo=$get(^DD(FileNumber,FieldNum,0)) "RTN","TMGDBAPI",407,0) if '$data(DDInfo) goto HWDone "RTN","TMGDBAPI",408,0) set FieldInfo=$piece(DDInfo,"^",4) "RTN","TMGDBAPI",409,0) if '$data(FieldInfo),(FieldInfo="") goto HWDone "RTN","TMGDBAPI",410,0) set Index=$piece(FieldInfo,";",1) "RTN","TMGDBAPI",411,0) set Part=$piece(FieldInfo,";",2) "RTN","TMGDBAPI",412,0) "RTN","TMGDBAPI",413,0) ;"Convert global form of ^VA(200, into ^VA(200) "RTN","TMGDBAPI",414,0) new Len "RTN","TMGDBAPI",415,0) set Len=$length(GlobalP) "RTN","TMGDBAPI",416,0) if $extract(GlobalP,Len)="," do "RTN","TMGDBAPI",417,0) . set $extract(GlobalP,Len)=")" "RTN","TMGDBAPI",418,0) "RTN","TMGDBAPI",419,0) set RecNum=$piece(IENS,",",1) "RTN","TMGDBAPI",420,0) if $piece(IENS,",",2)'="" do goto HWDone "RTN","TMGDBAPI",421,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Hack writing to subfiles not supported") "RTN","TMGDBAPI",422,0) if $data(@GlobalP@(RecNum,Index))=0 goto HWDone "RTN","TMGDBAPI",423,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) "RTN","TMGDBAPI",424,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) "RTN","TMGDBAPI",425,0) set OldData=$piece(@GlobalP@(RecNum,Index),"^",Part) "RTN","TMGDBAPI",426,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And that data item is now: '",OldData,"'") "RTN","TMGDBAPI",427,0) if Data'=OldData do "RTN","TMGDBAPI",428,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing hack write") "RTN","TMGDBAPI",429,0) . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Data "RTN","TMGDBAPI",430,0) . ;"Give Message "RTN","TMGDBAPI",431,0) . new Text "RTN","TMGDBAPI",432,0) . set Text(0)=" Caution" "RTN","TMGDBAPI",433,0) . set Text(1)="Yikes!" "RTN","TMGDBAPI",434,0) . set Text(2)=" " "RTN","TMGDBAPI",435,0) . set Text(3)="We just bypassed all safety measures, " "RTN","TMGDBAPI",436,0) . set Text(4)="and wrote directly to the database." "RTN","TMGDBAPI",437,0) . set Text(5)="Make sure you know what you are doing!!" "RTN","TMGDBAPI",438,0) . set Text(6)=" " "RTN","TMGDBAPI",439,0) . set Text(7)="File: "_FileNumber "RTN","TMGDBAPI",440,0) . set Text(8)="Field: "_FieldNum "RTN","TMGDBAPI",441,0) . set Text(9)="Prior value: '"_OldData_"'" "RTN","TMGDBAPI",442,0) . set Text(10)="New value: '"_Data_"'" "RTN","TMGDBAPI",443,0) . set Text(11)=" " "RTN","TMGDBAPI",444,0) . set Text(12)="(This was caused by using Flags='H' in" "RTN","TMGDBAPI",445,0) . set Text(13)="the XML script.)" "RTN","TMGDBAPI",446,0) . do PopupArray^TMGUSRIF(5,45,.Text) "RTN","TMGDBAPI",447,0) else do "RTN","TMGDBAPI",448,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No need for hackwrite... the data is already what we want.") "RTN","TMGDBAPI",449,0) "RTN","TMGDBAPI",450,0) HWDone "RTN","TMGDBAPI",451,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") "RTN","TMGDBAPI",452,0) quit "RTN","TMGDBAPI",453,0) "RTN","TMGDBAPI",454,0) "RTN","TMGDBAPI",455,0) HandleHacksArray(MsgArray) "RTN","TMGDBAPI",456,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",457,0) ;"Purpose: To cycle through an array of hackwrites and process each one. "RTN","TMGDBAPI",458,0) ;"Input: HacksArray. Best if passed by reference "RTN","TMGDBAPI",459,0) ;" Expected format of array: "RTN","TMGDBAPI",460,0) ;" MsgArray(cHack,0,cEntries)=Number of Entries "RTN","TMGDBAPI",461,0) ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data "RTN","TMGDBAPI",462,0) ;" MsgArray(cHack,n,cFlags)=User specified Flags for field. "RTN","TMGDBAPI",463,0) ;"Output: database is changed "RTN","TMGDBAPI",464,0) ;"Result: 1 if ok to continue, 0=abort "RTN","TMGDBAPI",465,0) ;"!!!NOTICE: This is a very low level means of accessing the database. "RTN","TMGDBAPI",466,0) ;" The built in data verifiers, indexers etc etc will not be made aware of "RTN","TMGDBAPI",467,0) ;" changes made to the database through this method. USE ONLY WITH CAUTION. "RTN","TMGDBAPI",468,0) "RTN","TMGDBAPI",469,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",470,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",471,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",472,0) new cHack set cHack="H" "RTN","TMGDBAPI",473,0) new cEntries set cEntries="Entries" "RTN","TMGDBAPI",474,0) "RTN","TMGDBAPI",475,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") "RTN","TMGDBAPI",476,0) "RTN","TMGDBAPI",477,0) new result set result=cOKToCont "RTN","TMGDBAPI",478,0) new index set index=1 "RTN","TMGDBAPI",479,0) new GlobalP,FileNum,IENS,FieldNum,Data "RTN","TMGDBAPI",480,0) new s "RTN","TMGDBAPI",481,0) "RTN","TMGDBAPI",482,0) for index=1:1:$get(MsgArray(cHack,0,cEntries)) do quit:(s="")!(result=cAbort) "RTN","TMGDBAPI",483,0) . set s=$get(MsgArray(cHack,index)) if s="" quit "RTN","TMGDBAPI",484,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing: ",s) "RTN","TMGDBAPI",485,0) . set GlobalP=$piece(s,";",1) "RTN","TMGDBAPI",486,0) . set FileNum=$piece(s,";",2) "RTN","TMGDBAPI",487,0) . set IENS=$piece(s,";",3) "RTN","TMGDBAPI",488,0) . set FieldNum=$piece(s,";",4) "RTN","TMGDBAPI",489,0) . set Data=$piece(s,";",5) "RTN","TMGDBAPI",490,0) . set result=$$HackWrite(GlobalP,FileNum,IENS,FieldNum,Data) "RTN","TMGDBAPI",491,0) "RTN","TMGDBAPI",492,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") "RTN","TMGDBAPI",493,0) quit result "RTN","TMGDBAPI",494,0) "RTN","TMGDBAPI",495,0) "RTN","TMGDBAPI",496,0) GetRecMatch(Data,RecNumIEN) "RTN","TMGDBAPI",497,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",498,0) ;"Purpose: Take Data array from DoUpload, and search in database "RTN","TMGDBAPI",499,0) ;" for a prior matching record "RTN","TMGDBAPI",500,0) ;"Input: Data - Data array will contain all the information that is to be uploaded "RTN","TMGDBAPI",501,0) ;" Fields that should be specifically matched will have "MATCHTHIS" fields. "RTN","TMGDBAPI",502,0) ;" A field may have a "MATCHTHIS" node meaning that the value "RTN","TMGDBAPI",503,0) ;" specified should be searched for. "RTN","TMGDBAPI",504,0) ;" Or, rarely, one may want to specifically search for a different "RTN","TMGDBAPI",505,0) ;" search value. This is stored in a "MATCHVALUE" node. This "RTN","TMGDBAPI",506,0) ;" node is ignored if "MATCHTHIS" node is present. "RTN","TMGDBAPI",507,0) ;" The .01 field always is used for searching. If not present, then "RTN","TMGDBAPI",508,0) ;" a "MATCHTHIS" node is assumed. "RTN","TMGDBAPI",509,0) ;" Example array: "RTN","TMGDBAPI",510,0) ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion "RTN","TMGDBAPI",511,0) ;" Data(1,".01")="BILL" "RTN","TMGDBAPI",512,0) ;" Data(1,".01","MATCHVALUE")="JOHN" <-- optional search value "RTN","TMGDBAPI",513,0) ;" Data(1,".01","MATCHTHIS")=1 "RTN","TMGDBAPI",514,0) ;" Data(1,".02")="Sue" "RTN","TMGDBAPI",515,0) ;" Data(1,".03")="MyData3" "RTN","TMGDBAPI",516,0) ;" Data(1,".03",cFlags)=any flags given (only present if user specified) "RTN","TMGDBAPI",517,0) ;" RecNumIEN -- MUST PASS BY REFERENCE. An OUT parameter to receive results "RTN","TMGDBAPI",518,0) ;"Output: Returns answer in RecNumIEN (record number in file) if found, or 0 otherwise "RTN","TMGDBAPI",519,0) ;"Result: 1=OKToContinue, 0=Abort "RTN","TMGDBAPI",520,0) ;"Note: "RTN","TMGDBAPI",521,0) ;" * Data in Multiple fields are NOT used for matching. "RTN","TMGDBAPI",522,0) ;" * I am not going to support matching for subrecords (i.e. SubEntry stuff above) "RTN","TMGDBAPI",523,0) ;" * If data passed is a subset of a larger data group (i.e. when this function "RTN","TMGDBAPI",524,0) ;" is called recursively to handle a subfile), then an entry will be placed "RTN","TMGDBAPI",525,0) ;" in the Data(0,cParentIENS) that will specify the RecNumIEN of the parent record "RTN","TMGDBAPI",526,0) ;" holding this subfile. "RTN","TMGDBAPI",527,0) "RTN","TMGDBAPI",528,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",529,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",530,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",531,0) new cParentIENS set cParentIENS="ParentIENS" "RTN","TMGDBAPI",532,0) "RTN","TMGDBAPI",533,0) new FileNumber,FieldNum "RTN","TMGDBAPI",534,0) set RecNumIEN=0 "RTN","TMGDBAPI",535,0) new IENS,Fields,Flags "RTN","TMGDBAPI",536,0) new MatchValue set MatchValue="" "RTN","TMGDBAPI",537,0) new FieldMatch set FieldMatch="" "RTN","TMGDBAPI",538,0) new ScreenCode "RTN","TMGDBAPI",539,0) new Matches,NumMatches "RTN","TMGDBAPI",540,0) new TMGMsg "RTN","TMGDBAPI",541,0) new result set result=cOKToCont "RTN","TMGDBAPI",542,0) new index "RTN","TMGDBAPI",543,0) new SlimData ;"Will hold just those fields that should be matched against "RTN","TMGDBAPI",544,0) new OneMatch "RTN","TMGDBAPI",545,0) "RTN","TMGDBAPI",546,0) set IENS=$get(Data(0,cParentIENS)) "RTN","TMGDBAPI",547,0) if IENS'="" if $extract(IENS,1)'="," do "RTN","TMGDBAPI",548,0) . set IENS=","_IENS "RTN","TMGDBAPI",549,0) "RTN","TMGDBAPI",550,0) set Fields="@" "RTN","TMGDBAPI",551,0) ;"Setup specifier to tell which fields to return info on "RTN","TMGDBAPI",552,0) new done set done=0 "RTN","TMGDBAPI",553,0) set index=0 "RTN","TMGDBAPI",554,0) for set index=$order(Data(index)) quit:(index="")!done do "RTN","TMGDBAPI",555,0) . set FieldNum="" "RTN","TMGDBAPI",556,0) . for set FieldNum=$order(Data(index,FieldNum)) quit:(+FieldNum=0) do "RTN","TMGDBAPI",557,0) . . if $get(Data(index,FieldNum,"MATCHTHIS"))=1 do "RTN","TMGDBAPI",558,0) . . . set FieldMatch=$get(Data(index,FieldNum)) "RTN","TMGDBAPI",559,0) . . else set FieldMatch=$get(Data(index,FieldNum,"MATCHVALUE")) "RTN","TMGDBAPI",560,0) . . if FieldNum=".01" do "RTN","TMGDBAPI",561,0) . . . if FieldMatch="" set FieldMatch=$get(Data(index,.01)) "RTN","TMGDBAPI",562,0) . . . set MatchValue=FieldMatch "RTN","TMGDBAPI",563,0) . . if FieldMatch'="" do "RTN","TMGDBAPI",564,0) . . . set Fields=Fields_";"_FieldNum "RTN","TMGDBAPI",565,0) . . . set SlimData(FieldNum)=FieldMatch "RTN","TMGDBAPI",566,0) . . . set FieldMatch="" "RTN","TMGDBAPI",567,0) . set done=1 ;"Force handling only 1 entry (i.e. #1), then quit after first cycle. "RTN","TMGDBAPI",568,0) "RTN","TMGDBAPI",569,0) set FileNumber=$get(Data(0,"FILE")) "RTN","TMGDBAPI",570,0) set ScreenCode="" "RTN","TMGDBAPI",571,0) set Flags="" "RTN","TMGDBAPI",572,0) "RTN","TMGDBAPI",573,0) ;"====================================================== "RTN","TMGDBAPI",574,0) ;"Call FIND^DIC "RTN","TMGDBAPI",575,0) ;"====================================================== "RTN","TMGDBAPI",576,0) ;"Params: "RTN","TMGDBAPI",577,0) ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS "RTN","TMGDBAPI",578,0) do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg") "RTN","TMGDBAPI",579,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FIND^DIC") "RTN","TMGDBAPI",580,0) ;"====================================================== "RTN","TMGDBAPI",581,0) ;"====================================================== "RTN","TMGDBAPI",582,0) "RTN","TMGDBAPI",583,0) if $data(TMGMsg) do "RTN","TMGDBAPI",584,0) . if $data(TMGMsg("DIERR"))'=0 do quit "RTN","TMGDBAPI",585,0) . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAPI",586,0) . . set result=cAbort "RTN","TMGDBAPI",587,0) if result=cAbort goto GRMQuit "RTN","TMGDBAPI",588,0) "RTN","TMGDBAPI",589,0) if $data(Matches("DILIST"))=0 goto GRMQuit ;"keep RecNumIEN default of 0 "RTN","TMGDBAPI",590,0) set NumMatches=$piece(Matches("DILIST",0),"^",1) "RTN","TMGDBAPI",591,0) if NumMatches=0 goto GRMQuit ;"keep RecNumIEN default of 0 "RTN","TMGDBAPI",592,0) "RTN","TMGDBAPI",593,0) for index=1:1:NumMatches do quit:RecNumIEN'=0 ;"Note: FIRST match returned. "RTN","TMGDBAPI",594,0) . kill OneMatch "RTN","TMGDBAPI",595,0) . merge OneMatch=Matches("DILIST","ID",index) "RTN","TMGDBAPI",596,0) . if $$CompRec(FileNumber,.OneMatch,.SlimData) set RecNumIEN=Matches("DILIST",2,index) "RTN","TMGDBAPI",597,0) "RTN","TMGDBAPI",598,0) GRMQuit "RTN","TMGDBAPI",599,0) quit result "RTN","TMGDBAPI",600,0) "RTN","TMGDBAPI",601,0) "RTN","TMGDBAPI",602,0) CompRec(FileNumber,dbRec,TestRec) "RTN","TMGDBAPI",603,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",604,0) ;"Purpose: To compare data from the database against a test match "RTN","TMGDBAPI",605,0) ;"Input: FileNumber: the file data is from "RTN","TMGDBAPI",606,0) ;" dbRec, an array of data from the database in the following format "RTN","TMGDBAPI",607,0) ;" dbRec(.01)="JOHNS,BILL" "RTN","TMGDBAPI",608,0) ;" dbRec(.02)="MALE" "RTN","TMGDBAPI",609,0) ;" dbRec(.03)="01/20/1957" "RTN","TMGDBAPI",610,0) ;" dbRec(.07)="(123) 555-1212" "RTN","TMGDBAPI",611,0) ;" TestRec, an array of data to test for match with, in same format "RTN","TMGDBAPI",612,0) ;" as above. Note: there may well be less entries in this array "RTN","TMGDBAPI",613,0) ;" than in the dbRec "RTN","TMGDBAPI",614,0) ;" TestRec(.01)="JOHNS,BILL" "RTN","TMGDBAPI",615,0) ;" TestRec(.03)="01/20/1957" "RTN","TMGDBAPI",616,0) ;"Output: 1 if all values in TestRec=dbRec. 0=conflict "RTN","TMGDBAPI",617,0) ;" Note: values in dbRec that don't have a corresponding entry in TestRec "RTN","TMGDBAPI",618,0) ;" are ignored. "RTN","TMGDBAPI",619,0) "RTN","TMGDBAPI",620,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",621,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",622,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",623,0) "RTN","TMGDBAPI",624,0) new result set result=cOKToCont "RTN","TMGDBAPI",625,0) new index set index="" "RTN","TMGDBAPI",626,0) new FieldType,TMGFDA,TMGMsg "RTN","TMGDBAPI",627,0) new dbIDT,testIDT ;" IDT = internal form of date/time "RTN","TMGDBAPI",628,0) "RTN","TMGDBAPI",629,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") "RTN","TMGDBAPI",630,0) "RTN","TMGDBAPI",631,0) if TMGDEBUG do "RTN","TMGDBAPI",632,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is records to be compared") "RTN","TMGDBAPI",633,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbRec:") "RTN","TMGDBAPI",634,0) . do ArrayDump^TMGDEBUG("dbRec") ;"zwr dbRec(*) "RTN","TMGDBAPI",635,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestRec:") "RTN","TMGDBAPI",636,0) . do ArrayDump^TMGDEBUG("TestRec") ;"zwr TestRec(*) "RTN","TMGDBAPI",637,0) "RTN","TMGDBAPI",638,0) CRLoop "RTN","TMGDBAPI",639,0) set index=$order(TestRec(index)) "RTN","TMGDBAPI",640,0) if index="" goto CRDone "RTN","TMGDBAPI",641,0) if $data(dbRec(index))=0 goto CRLoop "RTN","TMGDBAPI",642,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing field ",index) "RTN","TMGDBAPI",643,0) kill TMGFDA,TMGMsg "RTN","TMGDBAPI",644,0) do FIELD^DID(FileNumber,index,,"TYPE","TMGFDA","TMGMsg") "RTN","TMGDBAPI",645,0) if $get(TMGFDA("TYPE"))="DATE/TIME" do goto CRDone:'result "RTN","TMGDBAPI",646,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Doing special date comparison") "RTN","TMGDBAPI",647,0) . set X=TestRec(index) "RTN","TMGDBAPI",648,0) . do ^%DT ;"convert date/time into internal format "RTN","TMGDBAPI",649,0) . set testIDT=Y "RTN","TMGDBAPI",650,0) . set X=dbRec(index) "RTN","TMGDBAPI",651,0) . do ^%DT ;"convert date/time into internal format "RTN","TMGDBAPI",652,0) . set dbIDT=Y "RTN","TMGDBAPI",653,0) . if testIDT'=dbIDT do "RTN","TMGDBAPI",654,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Dates not equal: ",TestRec(index)," vs, ",dbRec(index)) "RTN","TMGDBAPI",655,0) . . set result=cAbort "RTN","TMGDBAPI",656,0) else if TestRec(index)'=dbRec(index) do goto CRDone ;"Note: simple '=' compare "RTN","TMGDBAPI",657,0) . set result=cAbort "RTN","TMGDBAPI",658,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fields are equal") "RTN","TMGDBAPI",659,0) goto CRLoop "RTN","TMGDBAPI",660,0) CRDone "RTN","TMGDBAPI",661,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Leaving CompRec. Result=",result," (0 if conflict)") "RTN","TMGDBAPI",662,0) "RTN","TMGDBAPI",663,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") "RTN","TMGDBAPI",664,0) quit result "RTN","TMGDBAPI",665,0) "RTN","TMGDBAPI",666,0) "RTN","TMGDBAPI",667,0) UploadData(Data,RecNumIEN) "RTN","TMGDBAPI",668,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",669,0) ;"Purpose: Do actual upload of Data, given in specific format "RTN","TMGDBAPI",670,0) ;"Note: This function may be called recursively by subfiles "RTN","TMGDBAPI",671,0) ;"Input: Data -- data in format show at TOP OF THIS FILE "RTN","TMGDBAPI",672,0) ;" Note: If this function is being passed recursively, then the data "RTN","TMGDBAPI",673,0) ;" passed is probably just a subpart that corresponds to the subfile "RTN","TMGDBAPI",674,0) ;" RecNumIEN -- OPTIONAL pameter. May be used to specify the "RTN","TMGDBAPI",675,0) ;" record to force data into. If passed by reference, then "RTN","TMGDBAPI",676,0) ;" record number (IEN) where data was placed is passed back. "RTN","TMGDBAPI",677,0) ;" Use of this parameter only makes sense when filing the highest "RTN","TMGDBAPI",678,0) ;" level file. (When filing subfiles recursively, then the parent "RTN","TMGDBAPI",679,0) ;" record number is stored in (0,cParentIENS)=",10033," e.g.) "RTN","TMGDBAPI",680,0) ;"Output: Information will be put into global database, based on "RTN","TMGDBAPI",681,0) ;" entries in Data. "RTN","TMGDBAPI",682,0) ;" Record number (IEN) of record will be put into RecNumIEN (or 0 if error) "RTN","TMGDBAPI",683,0) ;"Result: Returns success 1=OK to continue. 0=Abort "RTN","TMGDBAPI",684,0) "RTN","TMGDBAPI",685,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",686,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",687,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",688,0) new cEntries set cEntries="Entries" "RTN","TMGDBAPI",689,0) "RTN","TMGDBAPI",690,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") "RTN","TMGDBAPI",691,0) "RTN","TMGDBAPI",692,0) new result set result=cOKToCont "RTN","TMGDBAPI",693,0) new NumEntries "RTN","TMGDBAPI",694,0) new index "RTN","TMGDBAPI",695,0) "RTN","TMGDBAPI",696,0) set RecNumIEN=$get(RecNumIEN,0) ;"See if user-specified IEN was given. "RTN","TMGDBAPI",697,0) "RTN","TMGDBAPI",698,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) "RTN","TMGDBAPI",699,0) "RTN","TMGDBAPI",700,0) if RecNumIEN'=0 do goto UDDone:(result=cAbort) "RTN","TMGDBAPI",701,0) . new Params,MyOutVar "RTN","TMGDBAPI",702,0) . set Params("FILE")=$get(Data(0,"FILE")) "RTN","TMGDBAPI",703,0) . set Params(cRecNum)=RecNumIEN "RTN","TMGDBAPI",704,0) . set Params(cField)=".01" "RTN","TMGDBAPI",705,0) . set Params(cOutput)="MyOutVar" "RTN","TMGDBAPI",706,0) . set result=$$ValueLookup(.Params) ;"result=0 (cAbort) if unsuccessful lookup "RTN","TMGDBAPI",707,0) . if result=cAbort do "RTN","TMGDBAPI",708,0) . . if $data(PriorErrorFound)=0 new PriorErrorFound "RTN","TMGDBAPI",709,0) . . new s set s="Unable to overwrite data into record#"_RecNumIEN_" because that record does not already exist.\n" "RTN","TMGDBAPI",710,0) . . set s=s_"Will try to put data into a new record, which may not be record#"_RecNumIEN "RTN","TMGDBAPI",711,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,s) "RTN","TMGDBAPI",712,0) . . set result=cOKToCont "RTN","TMGDBAPI",713,0) . . set PriorErrorFound=0 ;"clear errors and continue program. "RTN","TMGDBAPI",714,0) . . set RecNumIEN=0 "RTN","TMGDBAPI",715,0) "RTN","TMGDBAPI",716,0) set NumEntries=$get(Data(0,cEntries)) "RTN","TMGDBAPI",717,0) for index=1:1:NumEntries do quit:(result=cAbort) "RTN","TMGDBAPI",718,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop to process all uploadData entries. Entry=",index) "RTN","TMGDBAPI",719,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) "RTN","TMGDBAPI",720,0) . new tData ;"Create a tData array that has only 1 entry in it. "RTN","TMGDBAPI",721,0) . merge tData(0)=Data(0) "RTN","TMGDBAPI",722,0) . set tData(0,cEntries)=1 "RTN","TMGDBAPI",723,0) . merge tData(1)=Data(index) "RTN","TMGDBAPI",724,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"This is entry to process") "RTN","TMGDBAPI",725,0) . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tData") "RTN","TMGDBAPI",726,0) . if RecNumIEN=0 set result=$$GetRecMatch(.tData,.RecNumIEN) ;"if no prior record, returns 0 "RTN","TMGDBAPI",727,0) . if result=cAbort quit ;//kt added 1/6/05 "RTN","TMGDBAPI",728,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using RecNumIEN=",RecNumIEN) "RTN","TMGDBAPI",729,0) . ; "RTN","TMGDBAPI",730,0) . if RecNumIEN=0 do quit:(result=cAbort) "RTN","TMGDBAPI",731,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling AddRec") "RTN","TMGDBAPI",732,0) . . new AddRecNum "RTN","TMGDBAPI",733,0) . . set AddRecNum=$$AddRec(.tData) "RTN","TMGDBAPI",734,0) . . if AddRecNum=0 do quit "RTN","TMGDBAPI",735,0) . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error adding a record.") "RTN","TMGDBAPI",736,0) . . . set result=cAbort "RTN","TMGDBAPI",737,0) . else do quit:(result=cAbort) "RTN","TMGDBAPI",738,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling Overwriterec") "RTN","TMGDBAPI",739,0) . . set result=$$OverwriteRec(RecNumIEN,.tData) "RTN","TMGDBAPI",740,0) . . set RecNumIEN=0 ;"We won't to file any more into that record num, force search next cycle. "RTN","TMGDBAPI",741,0) . . if result=cAbort do quit "RTN","TMGDBAPI",742,0) . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error modifying an existing record.") "RTN","TMGDBAPI",743,0) "RTN","TMGDBAPI",744,0) UDDone "RTN","TMGDBAPI",745,0) ;"if (result'=cAbort) set result=(RecNumIEN>0) "RTN","TMGDBAPI",746,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result = ",result) "RTN","TMGDBAPI",747,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") "RTN","TMGDBAPI",748,0) quit result "RTN","TMGDBAPI",749,0) "RTN","TMGDBAPI",750,0) "RTN","TMGDBAPI",751,0) "RTN","TMGDBAPI",752,0) ValueLookup(Params) "RTN","TMGDBAPI",753,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",754,0) ;"Purpose: To look for a value of a given value in a given record in given file. "RTN","TMGDBAPI",755,0) ;"Input: Params -- an array loaded with expected parameters. I.e.: "RTN","TMGDBAPI",756,0) ;" Params("FILE")="NEW PERSON" in our example "RTN","TMGDBAPI",757,0) ;" Params(cRecNum)="1" in example "RTN","TMGDBAPI",758,0) ;" Params(cField)=".01" in our example (could be Name of field) "RTN","TMGDBAPI",759,0) ;" Params(cOutput)="MyVar" "RTN","TMGDBAPI",760,0) ;"Output: MyVar is loaded with data, i.e.: "RTN","TMGDBAPI",761,0) ;" MyVar("FILE")=200 "RTN","TMGDBAPI",762,0) ;" MyVar(cGlobal)="^VA(200)" "RTN","TMGDBAPI",763,0) ;" MyVar(cGlobal,cOpen)="^VA(200," "RTN","TMGDBAPI",764,0) ;" MyVar(cRecNum)=1 "RTN","TMGDBAPI",765,0) ;" MyVar(cField)=.01 "RTN","TMGDBAPI",766,0) ;" MyVar(cValue)=xxx <-- the looked-up value "RTN","TMGDBAPI",767,0) ;"Returns: If should continue execution: 1=OK to continue. 0=unsuccessful lookup "RTN","TMGDBAPI",768,0) ;"Note: I am getting values by directly looking into database, rather than use "RTN","TMGDBAPI",769,0) ;" the usual lookup commands. I am doing this so that there will be no "RTN","TMGDBAPI",770,0) ;" 'hidden' data, based on security etc. "RTN","TMGDBAPI",771,0) ;" **I need to check, but this probably means that the data returned will be "RTN","TMGDBAPI",772,0) ;" in INTERNAL FILEMAN FORMAT (i.e. time values are encoded etc.) "RTN","TMGDBAPI",773,0) "RTN","TMGDBAPI",774,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",775,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",776,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",777,0) new cField set cField="FIELD" ;"Field" "RTN","TMGDBAPI",778,0) new cNull set cNull="(none)" "RTN","TMGDBAPI",779,0) new cRecNum set cRecNum="RECNUM" ;"RecNum "RTN","TMGDBAPI",780,0) new cOutput set cOutput="OUTVAR" ;"OutVar" "RTN","TMGDBAPI",781,0) new cGlobal set cGlobal="GLOBAL" "RTN","TMGDBAPI",782,0) new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" "RTN","TMGDBAPI",783,0) new cOpen set cOpen="OPEN" "RTN","TMGDBAPI",784,0) "RTN","TMGDBAPI",785,0) "RTN","TMGDBAPI",786,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") "RTN","TMGDBAPI",787,0) new result set result=cAbort "RTN","TMGDBAPI",788,0) "RTN","TMGDBAPI",789,0) new Data "RTN","TMGDBAPI",790,0) new DDInfo "RTN","TMGDBAPI",791,0) new FieldInfo "RTN","TMGDBAPI",792,0) new Index,Part "RTN","TMGDBAPI",793,0) "RTN","TMGDBAPI",794,0) new Field set Field=$get(Params(cField),cNull) "RTN","TMGDBAPI",795,0) new RecNum set RecNum=$get(Params(cRecNum),cNull) "RTN","TMGDBAPI",796,0) new OutVarP set OutVarP=$get(Params(cOutput),cNull) "RTN","TMGDBAPI",797,0) if (RecNum=cNull),(OutVarP=cNull) goto DVLUDone "RTN","TMGDBAPI",798,0) kill @OutVarP ;"--ensure old variables in output variable are removed. "RTN","TMGDBAPI",799,0) "RTN","TMGDBAPI",800,0) set Data(0,"FILE")=$get(Params("FILE")) "RTN","TMGDBAPI",801,0) set result=$$SetupFileNum(.Data) "RTN","TMGDBAPI",802,0) if result=cAbort goto DVLUDone "RTN","TMGDBAPI",803,0) new FileNum set FileNum=$get(Data(0,"FILE"),cNull) "RTN","TMGDBAPI",804,0) new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) "RTN","TMGDBAPI",805,0) if (FileNum=cNull),(GlobalP=cNull) goto DVLUDone "RTN","TMGDBAPI",806,0) new FieldNum set FieldNum=$$GetNumField(FileNum,Field) "RTN","TMGDBAPI",807,0) if FieldNum=0 goto DVLUDone "RTN","TMGDBAPI",808,0) "RTN","TMGDBAPI",809,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) "RTN","TMGDBAPI",810,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File: ",FileNum) "RTN","TMGDBAPI",811,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Rec#: ",RecNum) "RTN","TMGDBAPI",812,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum: ",FieldNum) "RTN","TMGDBAPI",813,0) "RTN","TMGDBAPI",814,0) ;"Get info from data dictionary r.e. where actual fields are stored in files. "RTN","TMGDBAPI",815,0) set DDInfo=$get(^DD(FileNum,FieldNum,0)) "RTN","TMGDBAPI",816,0) if $data(DDInfo)=0 goto HWDone "RTN","TMGDBAPI",817,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo='",DDInfo,"', $data(DDInfo)=",$data(DDinfo)) "RTN","TMGDBAPI",818,0) set FieldInfo=$piece(DDInfo,"^",4) "RTN","TMGDBAPI",819,0) if '$data(FieldInfo),(FieldInfo="") goto DVLUDone "RTN","TMGDBAPI",820,0) set Index=$piece(FieldInfo,";",1) "RTN","TMGDBAPI",821,0) set Part=$piece(FieldInfo,";",2) "RTN","TMGDBAPI",822,0) "RTN","TMGDBAPI",823,0) if $data(@GlobalP@(RecNum,Index))=0 goto DVLUDone "RTN","TMGDBAPI",824,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) "RTN","TMGDBAPI",825,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) "RTN","TMGDBAPI",826,0) set Data=$piece(@GlobalP@(RecNum,Index),"^",Part) "RTN","TMGDBAPI",827,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And our value is: ",Data) "RTN","TMGDBAPI",828,0) "RTN","TMGDBAPI",829,0) kill @OutVarP "RTN","TMGDBAPI",830,0) set @OutVarP@("FILE")=FileNum "RTN","TMGDBAPI",831,0) set @OutVarP@(cRecNum)=RecNum "RTN","TMGDBAPI",832,0) set @OutVarP@(cField)=FieldNum "RTN","TMGDBAPI",833,0) set @OutVarP@(cValue)=Data "RTN","TMGDBAPI",834,0) set @OutVarP@(cGlobal)=GlobalP "RTN","TMGDBAPI",835,0) set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) "RTN","TMGDBAPI",836,0) "RTN","TMGDBAPI",837,0) set result=cOKToCont "RTN","TMGDBAPI",838,0) "RTN","TMGDBAPI",839,0) DVLUDone "RTN","TMGDBAPI",840,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") "RTN","TMGDBAPI",841,0) quit result "RTN","TMGDBAPI",842,0) "RTN","TMGDBAPI",843,0) "RTN","TMGDBAPI",844,0) FileUtility(Params) "RTN","TMGDBAPI",845,0) ;"PUBLIC FUNCTION "RTN","TMGDBAPI",846,0) ;"Purpose: To provide file access/manipulation utilities to script user "RTN","TMGDBAPI",847,0) ;"syntax: "RTN","TMGDBAPI",848,0) ;" "RTN","TMGDBAPI",849,0) ;"Input: Params -- an array loaded with expected parameters. I.e.: "RTN","TMGDBAPI",850,0) ;" Params("FILE")="NEW PERSON" for example "RTN","TMGDBAPI",851,0) ;" File: The name of the file to act upon. "RTN","TMGDBAPI",852,0) ;" File may have subnodes (i.e. "NEW PERSON|ALIAS|TITLE") "RTN","TMGDBAPI",853,0) ;" **BUT**, any deletion or set values will only work on top level (i.e. "NEW PERSON") "RTN","TMGDBAPI",854,0) ;" Params(cFn)="info" or "delete", or "set" [OPTIONAL] "RTN","TMGDBAPI",855,0) ;" Fn="delete" If Field is not specified: "RTN","TMGDBAPI",856,0) ;" Will cause record RecNum to be deleted. "RTN","TMGDBAPI",857,0) ;" MyOutVar("DELETED")=RecNum of deleted record, or "RTN","TMGDBAPI",858,0) ;" 0 if not found. "RTN","TMGDBAPI",859,0) ;" If Field IS specified: "RTN","TMGDBAPI",860,0) ;" Will delete the value in field, in record RecNum "RTN","TMGDBAPI",861,0) ;" Note: delete is intended only for the highest-level records "RTN","TMGDBAPI",862,0) ;" (i.e. not subfiels, or multiple fields) "RTN","TMGDBAPI",863,0) ;" Note: delete method uses ^DIK to delete the record "RTN","TMGDBAPI",864,0) ;" Fn="info" Will just fill in info below. "RTN","TMGDBAPI",865,0) ;" If Fn not specified, this is default "RTN","TMGDBAPI",866,0) ;" Fn="set" Will put Value into Field, in RecNum, in File (all required) "RTN","TMGDBAPI",867,0) ;" Params(cRecNum)="1" for example "RTN","TMGDBAPI",868,0) ;" RecNum: [OPTIONAL] Specifies which record to act on. If not "RTN","TMGDBAPI",869,0) ;" specified, then just file info is returned. "RTN","TMGDBAPI",870,0) ;" Params(cField)=".01" for example (could be Name of field) "RTN","TMGDBAPI",871,0) ;" Field: [OPTIONAL] Specifies which field to act on. "RTN","TMGDBAPI",872,0) ;" Params(cOutput)="MyVar" "RTN","TMGDBAPI",873,0) ;" OutVar: Needed to get information back from function (but still Optional) "RTN","TMGDBAPI",874,0) ;" Gives name of variable to put info into. "RTN","TMGDBAPI",875,0) ;"Output: MyVar is loaded with data, i.e. "RTN","TMGDBAPI",876,0) ;" i.e. MyOutVar("FILE")=Filenumber "RTN","TMGDBAPI",877,0) ;" MyOutVar("FILE","FILE")=SubFilenumber <-- only if subnodes input in File name (e.g."ALIAS") "RTN","TMGDBAPI",878,0) ;" MyOutVar("FILE","FILE","FILE")=SubSubFilenumber <-- only if subnodes input in File name (e.g."TITLE") "RTN","TMGDBAPI",879,0) ;" MyOutVar("GLOBAL")="^VA(200)" "RTN","TMGDBAPI",880,0) ;" MyOutVar("GLOBAL, OPEN")="^VA(200," "RTN","TMGDBAPI",881,0) ;" MyOutVar("RECNUM")=record number "RTN","TMGDBAPI",882,0) ;" MyOutVar("FIELD")=Filenumber "RTN","TMGDBAPI",883,0) ;" MyOutVar("VALUE")=xxxx <=== value of field (PRIOR TO deletion, if deleted) "RTN","TMGDBAPI",884,0) ;" MyOutVar("NEXTREC")=record number after RecNum, or "" if none "RTN","TMGDBAPI",885,0) ;" MyOutVar("PREVREC")=record number before RecNum, or "" if none "RTN","TMGDBAPI",886,0) ;" MyOutVar("FN")=the function executed "RTN","TMGDBAPI",887,0) ;" MyOutVar("NUMRECS")=Number of records in file PRIOR to any deletions "RTN","TMGDBAPI",888,0) ;" MyOutVar("FIRSTREC")=Rec number of first record in file "RTN","TMGDBAPI",889,0) ;" MyOutVar("LASTREC")=Rec number of last record in file "RTN","TMGDBAPI",890,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort "RTN","TMGDBAPI",891,0) ;"Note: I am getting values by directly looking into database, rather than use "RTN","TMGDBAPI",892,0) ;" the usual lookup commands. I am doing this so that there will be no "RTN","TMGDBAPI",893,0) ;" 'hidden' data, based on security etc. "RTN","TMGDBAPI",894,0) "RTN","TMGDBAPI",895,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",896,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",897,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",898,0) new cField set cField="FIELD" ;"Field" "RTN","TMGDBAPI",899,0) new cNull set cNull="(none)" "RTN","TMGDBAPI",900,0) new cRecNum set cRecNum="RECNUM" ;"RecNum "RTN","TMGDBAPI",901,0) new cRecord set cRecord="RECORD" ;"Record" "RTN","TMGDBAPI",902,0) new cOutput set cOutput="OUTVAR" ;"OutVar" "RTN","TMGDBAPI",903,0) new cGlobal set cGlobal="GLOBAL" "RTN","TMGDBAPI",904,0) new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" "RTN","TMGDBAPI",905,0) new cOpen set cOpen="OPEN" "RTN","TMGDBAPI",906,0) new cInfo set cInfo="INFO" ;"Info "RTN","TMGDBAPI",907,0) if $data(cNodeDiv)#10=0 new cNodeDiv set cNodeDiv="|" "RTN","TMGDBAPI",908,0) new cDelete set cDelete="DELETE" ;"Delete "RTN","TMGDBAPI",909,0) new cNextRec set cNextRec="NEXTREC" "RTN","TMGDBAPI",910,0) new cPrev set cPrev="PREV" "RTN","TMGDBAPI",911,0) new cNumRecs set cNumRecs="NUMRECS" "RTN","TMGDBAPI",912,0) new cFirstRec set cFirstRec="FIRSTREC" "RTN","TMGDBAPI",913,0) new cLastRec set cLastRec="LASTREC" "RTN","TMGDBAPI",914,0) "RTN","TMGDBAPI",915,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") "RTN","TMGDBAPI",916,0) new result set result=cAbort "RTN","TMGDBAPI",917,0) "RTN","TMGDBAPI",918,0) new Data "RTN","TMGDBAPI",919,0) new DDInfo "RTN","TMGDBAPI",920,0) new FieldInfo "RTN","TMGDBAPI",921,0) new Index,Part "RTN","TMGDBAPI",922,0) new DummyOut "RTN","TMGDBAPI",923,0) "RTN","TMGDBAPI",924,0) new OutVarP set OutVarP=$get(Params(cOutput),cNull) "RTN","TMGDBAPI",925,0) ;"if (OutVarP=cNull) goto DFUTDone "RTN","TMGDBAPI",926,0) if (OutVarP=cNull) do "RTN","TMGDBAPI",927,0) . set OutVarP="DummyOut" "RTN","TMGDBAPI",928,0) "RTN","TMGDBAPI",929,0) kill @OutVarP ;"--ensure old variables in output variable are removed. "RTN","TMGDBAPI",930,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output variable=",OutVarP) "RTN","TMGDBAPI",931,0) "RTN","TMGDBAPI",932,0) new RecNum set RecNum=$get(Params(cRecNum)) "RTN","TMGDBAPI",933,0) set @OutVarP@(cRecNum)=RecNum "RTN","TMGDBAPI",934,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) "RTN","TMGDBAPI",935,0) "RTN","TMGDBAPI",936,0) new Fn set Fn=$get(Params(cFn),cInfo) "RTN","TMGDBAPI",937,0) set Fn=$$UP^XLFSTR(Fn) "RTN","TMGDBAPI",938,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Action Fn=",Fn) "RTN","TMGDBAPI",939,0) "RTN","TMGDBAPI",940,0) new Value set Value=$get(Params(cValue)) "RTN","TMGDBAPI",941,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Value=",Value) "RTN","TMGDBAPI",942,0) "RTN","TMGDBAPI",943,0) new FileN set FileN=$get(Params("FILE")) "RTN","TMGDBAPI",944,0) "RTN","TMGDBAPI",945,0) new SpliceArray "RTN","TMGDBAPI",946,0) if FileN[cNodeDiv do ;"Parse 'NEW PERSON|ALIAS|TITLE' into 'NEW PERSON', 'ALIAS', 'TITLE' "RTN","TMGDBAPI",947,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Multiple nodes found for file name. Processing...") "RTN","TMGDBAPI",948,0) . do CleaveToArray^TMGSTUTL(FileN,cNodeDiv,.SpliceArray) "RTN","TMGDBAPI",949,0) . set FileN=$get(SpliceArray(1)) "RTN","TMGDBAPI",950,0) set Data(0,"FILE")=FileN "RTN","TMGDBAPI",951,0) set result=$$SetupFileNum(.Data) if result=cAbort goto DFUTDone "RTN","TMGDBAPI",952,0) new FileNum set FileNum=$get(Data(0,"FILE"),cNull) "RTN","TMGDBAPI",953,0) set @OutVarP@("FILE")=FileNum "RTN","TMGDBAPI",954,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) "RTN","TMGDBAPI",955,0) "RTN","TMGDBAPI",956,0) new index set index=2 "RTN","TMGDBAPI",957,0) new GlobalP set GlobalP=$name(@OutVarP@("FILE")) "RTN","TMGDBAPI",958,0) if $data(SpliceArray(index)) do "RTN","TMGDBAPI",959,0) . for index=index:1 do quit:index="" "RTN","TMGDBAPI",960,0) . . set FileN=SpliceArray(index) "RTN","TMGDBAPI",961,0) . . set FileNum=$$GetSubFileNumber(FileNum,FileN) "RTN","TMGDBAPI",962,0) . . if +FileNum'=0 set @GlobalP@("FILE")=FileNum "RTN","TMGDBAPI",963,0) . . set GlobalP=$name(@GlobalP@("FILE")) "RTN","TMGDBAPI",964,0) . . set index=$order(SpliceArray(index)) "RTN","TMGDBAPI",965,0) "RTN","TMGDBAPI",966,0) new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) "RTN","TMGDBAPI",967,0) if (FileNum=cNull),(GlobalP=cNull) goto DFUTDone "RTN","TMGDBAPI",968,0) set @OutVarP@(cGlobal)=GlobalP "RTN","TMGDBAPI",969,0) set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) "RTN","TMGDBAPI",970,0) "RTN","TMGDBAPI",971,0) ;"If we've gotten this far, will consider the function a success "RTN","TMGDBAPI",972,0) set result=cOKToCont "RTN","TMGDBAPI",973,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Setting fn result to success") "RTN","TMGDBAPI",974,0) "RTN","TMGDBAPI",975,0) new FieldN set FieldN=$get(Params(cField)) "RTN","TMGDBAPI",976,0) new FieldNum "RTN","TMGDBAPI",977,0) if (+FieldN=0)&(FieldN'="") do "RTN","TMGDBAPI",978,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldN=",FieldN) "RTN","TMGDBAPI",979,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) "RTN","TMGDBAPI",980,0) . set FieldNum=$$GetNumField(FileNum,FieldN) "RTN","TMGDBAPI",981,0) else do "RTN","TMGDBAPI",982,0) . if FieldN "RTN","TMGDBAPI",983,0) . set FieldNum=FieldN "RTN","TMGDBAPI",984,0) set @OutVarP@(cField)=FieldNum "RTN","TMGDBAPI",985,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) "RTN","TMGDBAPI",986,0) "RTN","TMGDBAPI",987,0) if $data(@GlobalP@(0))=0 goto DFUTDone "RTN","TMGDBAPI",988,0) new NumRecs set NumRecs=$piece(@GlobalP@(0),"^",4) "RTN","TMGDBAPI",989,0) new LastRec set LastRec=$piece(@GlobalP@(0),"^",3) "RTN","TMGDBAPI",990,0) set @OutVarP@(cNumRecs)=NumRecs "RTN","TMGDBAPI",991,0) set @OutVarP@(cLastRec)=LastRec "RTN","TMGDBAPI",992,0) new RecI set RecI=LastRec "RTN","TMGDBAPI",993,0) new PrevRec "RTN","TMGDBAPI",994,0) for do quit:(RecI="")!(RecI=0) ;"Scan backwards to find first record "RTN","TMGDBAPI",995,0) . set PrevRec=$order(@GlobalP@(RecI),-1) "RTN","TMGDBAPI",996,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"PrevRec=",PrevRec," RecI=",RecI) "RTN","TMGDBAPI",997,0) . if (PrevRec="")!(PrevRec=0) do "RTN","TMGDBAPI",998,0) . . set @OutVarP@(cFirstRec)=RecI "RTN","TMGDBAPI",999,0) . set RecI=PrevRec "RTN","TMGDBAPI",1000,0) "RTN","TMGDBAPI",1001,0) if FieldNum="" do goto DFUTDone "RTN","TMGDBAPI",1002,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No field name specified") "RTN","TMGDBAPI",1003,0) . if (Fn=cDelete)&(RecNum'="") do "RTN","TMGDBAPI",1004,0) . . set DIK=$get(Data(0,"FILE",cGlobal,cOpen)) "RTN","TMGDBAPI",1005,0) . . set DA=RecNum "RTN","TMGDBAPI",1006,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Deleting one record (number: ",RecNum,") from File number",FileNum) "RTN","TMGDBAPI",1007,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Notice: deleting record does not clear any pointers to deleted records") "RTN","TMGDBAPI",1008,0) . . do ^DIK "RTN","TMGDBAPI",1009,0) "RTN","TMGDBAPI",1010,0) ;"Get info from data dictionary r.e. where actual fields are stored in files. "RTN","TMGDBAPI",1011,0) set DDInfo=$get(^DD(FileNum,FieldNum,0)) "RTN","TMGDBAPI",1012,0) if '$data(DDInfo) goto HWDone "RTN","TMGDBAPI",1013,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo=",DDInfo) "RTN","TMGDBAPI",1014,0) set FieldInfo=$piece(DDInfo,"^",4) "RTN","TMGDBAPI",1015,0) if '$data(FieldInfo),(FieldInfo="") goto DFUTDone "RTN","TMGDBAPI",1016,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldInfo=",FieldInfo) "RTN","TMGDBAPI",1017,0) set Index=$piece(FieldInfo,";",1) "RTN","TMGDBAPI",1018,0) set Part=$piece(FieldInfo,";",2) "RTN","TMGDBAPI",1019,0) "RTN","TMGDBAPI",1020,0) if RecNum="" goto DFUTDone "RTN","TMGDBAPI",1021,0) if $data(@GlobalP@(RecNum,Index))=0 goto DFUTDone "RTN","TMGDBAPI",1022,0) "RTN","TMGDBAPI",1023,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) "RTN","TMGDBAPI",1024,0) new Temp set Temp=@GlobalP@(RecNum,Index) "RTN","TMGDBAPI",1025,0) set @OutVarP@(cValue)=$piece(Temp,"^",Part) "RTN","TMGDBAPI",1026,0) kill Temp "RTN","TMGDBAPI",1027,0) set @OutVarP@(cNextRec)=$order(@GlobalP@(RecNum)) "RTN","TMGDBAPI",1028,0) set @OutVarP@(cPrev)=$order(@GlobalP@(RecNum),-1) "RTN","TMGDBAPI",1029,0) "RTN","TMGDBAPI",1030,0) if Fn=cDelete do "RTN","TMGDBAPI",1031,0) . set $piece(@GlobalP@(RecNum,Index),"^",Part)="" "RTN","TMGDBAPI",1032,0) "RTN","TMGDBAPI",1033,0) if Fn=cSet do "RTN","TMGDBAPI",1034,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing a hack write. CAUTION!") "RTN","TMGDBAPI",1035,0) . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Value "RTN","TMGDBAPI",1036,0) "RTN","TMGDBAPI",1037,0) set result=cOKToCont "RTN","TMGDBAPI",1038,0) "RTN","TMGDBAPI",1039,0) DFUTDone "RTN","TMGDBAPI",1040,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fn result=",result) "RTN","TMGDBAPI",1041,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") "RTN","TMGDBAPI",1042,0) quit result "RTN","TMGDBAPI",1043,0) "RTN","TMGDBAPI",1044,0) "RTN","TMGDBAPI",1045,0) "RTN","TMGDBAPI",1046,0) AddRec(Data) "RTN","TMGDBAPI",1047,0) ;"Purpose: Use info from data array to create a MINIMAL new record in database "RTN","TMGDBAPI",1048,0) ;" This record will have only it's .01 field, and any multiple "RTN","TMGDBAPI",1049,0) ;" subfiles will have only their .01 fields also. "RTN","TMGDBAPI",1050,0) ;"Input: Data - Data array should be in format output from GetRInfo "RTN","TMGDBAPI",1051,0) ;"Output: data base will be modified by adding record "RTN","TMGDBAPI",1052,0) ;"Assumption: That a matching record does not already exist in database "RTN","TMGDBAPI",1053,0) ;"Returns: RecNum of added record, or 0 if error (0=abort) "RTN","TMGDBAPI",1054,0) "RTN","TMGDBAPI",1055,0) ;"NOTE!!! -- As I review this code, does it really return record number added??? "RTN","TMGDBAPI",1056,0) "RTN","TMGDBAPI",1057,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGDBAPI",1058,0) new cOKToCont set cOKToCont=1 "RTN","TMGDBAPI",1059,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",1060,0) new cParentIENS set cParentIENS="ParentIENS" "RTN","TMGDBAPI",1061,0) "RTN","TMGDBAPI",1062,0) "RTN","TMGDBAPI",1063,0) new tmgFDA,TMGFDA ;"Fileman Data Array "RTN","TMGDBAPI",1064,0) new IENS ;"Internal Entry Number String "RTN","TMGDBAPI",1065,0) new RecNum ;"Internal number entry array "RTN","TMGDBAPI",1066,0) new Flags "RTN","TMGDBAPI",1067,0) new TMGMsg "RTN","TMGDBAPI",1068,0) new FileNum "RTN","TMGDBAPI",1069,0) new result set result=cAbort "RTN","TMGDBAPI",1070,0) new FDAIndex "RTN","TMGDBAPI",1071,0) new MarkerArray "RTN","TMGDBAPI",1072,0) new MsgArray "RTN","TMGDBAPI",1073,0) "RTN","TMGDBAPI",1074,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") "RTN","TMGDBAPI",1075,0) "RTN","TMGDBAPI",1076,0) set IENS=$get(Data(0,cParentIENS)) "RTN","TMGDBAPI",1077,0) "RTN","TMGDBAPI",1078,0) new MarkNum set MarkNum=0 "RTN","TMGDBAPI",1079,0) set result=$$SetupFDA(.Data,.tmgFDA,IENS,"+",.MarkNum,.MsgArray) "RTN","TMGDBAPI",1080,0) if result=cAbort goto SkRDone "RTN","TMGDBAPI",1081,0) set FileNum=$get(Data(0,"FILE"),0) "RTN","TMGDBAPI",1082,0) if FileNum=0 set result=cAbort goto SkRDone "RTN","TMGDBAPI",1083,0) "RTN","TMGDBAPI",1084,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") "RTN","TMGDBAPI",1085,0) if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("MsgArray") "RTN","TMGDBAPI",1086,0) "RTN","TMGDBAPI",1087,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") "RTN","TMGDBAPI",1088,0) if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) "RTN","TMGDBAPI",1089,0) "RTN","TMGDBAPI",1090,0) set FDAIndex=FileNum "RTN","TMGDBAPI",1091,0) for do quit:(FDAIndex="")!(result=cAbort) "RTN","TMGDBAPI",1092,0) . kill TMGFDA "RTN","TMGDBAPI",1093,0) . merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) "RTN","TMGDBAPI",1094,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting cycle with "_FDAIndex_" part.") "RTN","TMGDBAPI",1095,0) . ; "RTN","TMGDBAPI",1096,0) . set Flags="E" ;"E=External format values "RTN","TMGDBAPI",1097,0) . ; "RTN","TMGDBAPI",1098,0) . set result=$$ConvertFDA(.TMGFDA,.MarkerArray) "RTN","TMGDBAPI",1099,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"AFTER CONVERSION, Here is the FDA to pass to UPDATE^DIE") "RTN","TMGDBAPI",1100,0) . if TMGDEBUG do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) "RTN","TMGDBAPI",1101,0) . ; "RTN","TMGDBAPI",1102,0) . ;"====================================================== "RTN","TMGDBAPI",1103,0) . ;"Call UPDATE^DIE "RTN","TMGDBAPI",1104,0) . ;"====================================================== "RTN","TMGDBAPI",1105,0) . if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") "RTN","TMGDBAPI",1106,0) . if $data(TMGFDA)'=0 do "RTN","TMGDBAPI",1107,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",Flags) "RTN","TMGDBAPI",1108,0) . . new $etrap set $etrap="do ErrTrp^TMGDBAPI" "RTN","TMGDBAPI",1109,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, UPDATE^DIE adds new entries in files or subfiles.") "RTN","TMGDBAPI",1110,0) . . set ^TMP("TMG",$J,"ErrorTrap")=result "RTN","TMGDBAPI",1111,0) . . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" "RTN","TMGDBAPI",1112,0) . . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMsg") "RTN","TMGDBAPI",1113,0) . . set result=^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAPI",1114,0) . . kill ^TMP("TMG",$J,"ErrorTrap") "RTN","TMGDBAPI",1115,0) . . kill ^TMP("TMG",$J,"Caller") "RTN","TMGDBAPI",1116,0) . if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") "RTN","TMGDBAPI",1117,0) . ;"====================================================== "RTN","TMGDBAPI",1118,0) . ;"====================================================== "RTN","TMGDBAPI",1119,0) . ; "RTN","TMGDBAPI",1120,0) . if $data(RecNum) do "RTN","TMGDBAPI",1121,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is RecNum array after update/filing") "RTN","TMGDBAPI",1122,0) . . if TMGDEBUG do ArrayDump^TMGDEBUG("RecNum") ;"zwr RecNum(*) "RTN","TMGDBAPI",1123,0) . . merge MarkerArray=RecNum "RTN","TMGDBAPI",1124,0) . . if result=cAbort do "RTN","TMGDBAPI",1125,0) . . . new index "RTN","TMGDBAPI",1126,0) . . . set index=$order(RecNum("")) "RTN","TMGDBAPI",1127,0) . . . set result=$get(RecNum(index)) "RTN","TMGDBAPI",1128,0) . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output Record#=",result) "RTN","TMGDBAPI",1129,0) . else do "RTN","TMGDBAPI",1130,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After update/filing, RecNum array is empty!") "RTN","TMGDBAPI",1131,0) . ; "RTN","TMGDBAPI",1132,0) . if $data(TMGMsg("DIERR")) do quit "RTN","TMGDBAPI",1133,0) . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGDBAPI",1134,0) . . if $data(RecNum(1)) do "RTN","TMGDBAPI",1135,0) . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Trying to ignore error") "RTN","TMGDBAPI",1136,0) . . . set PriorErrorFound=0 "RTN","TMGDBAPI",1137,0) . . else do "RTN","TMGDBAPI",1138,0) . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to ignore error") "RTN","TMGDBAPI",1139,0) . . . set result=cAbort "RTN","TMGDBAPI",1140,0) . do "RTN","TMGDBAPI",1141,0) . . new tI set tI=FDAIndex "RTN","TMGDBAPI",1142,0) . . set FDAIndex=$order(tmgFDA(FDAIndex)) "RTN","TMGDBAPI",1143,0) . . kill tmgFDA(tI) "RTN","TMGDBAPI",1144,0) "RTN","TMGDBAPI",1145,0) if result=cAbort do goto SkRDone "RTN","TMGDBAPI",1146,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error encountered, dropping out.") "RTN","TMGDBAPI",1147,0) "RTN","TMGDBAPI",1148,0) set result=$$HandleHacksArray(.MsgArray) "RTN","TMGDBAPI",1149,0) "RTN","TMGDBAPI",1150,0) if result=cAbort goto SkRDone "RTN","TMGDBAPI",1151,0) "RTN","TMGDBAPI",1152,0) SkRDone "RTN","TMGDBAPI",1153,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") "RTN","TMGDBAPI",1154,0) quit result "RTN","TMGDBAPI",1155,0) "RTN","TMGDBAPI",1156,0) "RTN","TMGDBAPI",1157,0) "RTN","TMGDBAPI",1158,0) ;"========================================================= "RTN","TMGDBAPI",1159,0) ;" Error trap routine "RTN","TMGDBAPI",1160,0) ;"========================================================= "RTN","TMGDBAPI",1161,0) ErrTrp "RTN","TMGDBAPI",1162,0) new cAbort set cAbort=0 "RTN","TMGDBAPI",1163,0) set $etrap="",$ecode="" "RTN","TMGDBAPI",1164,0) new Caller "RTN","TMGDBAPI",1165,0) set Caller=$get(^TMP("TMG",$J,"Caller"),"?") "RTN","TMGDBAPI",1166,0) do ShowError^TMGDEBUG(.PriorErrorFound,"Error trapped. Caller was: ",Caller) "RTN","TMGDBAPI",1167,0) if $data(TMGMsg) do ShowDIERR^TMGDEBUG(TMGMsg) "RTN","TMGDBAPI",1168,0) set ^TMP("TMG",$J,"ErrorTrap")=cAbort "RTN","TMGDBAPI",1169,0) quit "RTN","TMGDBAPI",1170,0) ;"========================================================= "RTN","TMGDBAPI",1171,0) ;" End of Error trap routine "RTN","TMGDBAPI",1172,0) ;"========================================================= "RTN","TMGDBAPI",1173,0) "RTN","TMGDBAPI",1174,0) ;"======================================================== "RTN","TMGDBAPI",1175,0) ;"The following routines were moved to shorten module length "RTN","TMGDBAPI",1176,0) "RTN","TMGDBAPI",1177,0) ConvertFDA(FDA,MarkerArray) "RTN","TMGDBAPI",1178,0) goto ConvertFDA+1^TMGDBAP2 "RTN","TMGDBAPI",1179,0) "RTN","TMGDBAPI",1180,0) ConvertIENS(IENS,MarkerArray) "RTN","TMGDBAPI",1181,0) goto ConvertIENS+1^TMGDBAP2 "RTN","TMGDBAPI",1182,0) "RTN","TMGDBAPI",1183,0) SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) "RTN","TMGDBAPI",1184,0) goto SetupFDA+1^TMGDBAP2 "RTN","TMGDBAPI",1185,0) "RTN","TMGDBAPI",1186,0) OverwriteRec(RecNum,Data) "RTN","TMGDBAPI",1187,0) goto OverwriteRec+1^TMGDBAP2 "RTN","TMGDBAPI",1188,0) "RTN","TMGDBAPI",1189,0) GetFileNum(FileName) "RTN","TMGDBAPI",1190,0) goto GetFileNum+1^TMGDBAP2 "RTN","TMGDBAPI",1191,0) "RTN","TMGDBAPI",1192,0) GetFName(FileNumber) "RTN","TMGDBAPI",1193,0) goto GetFName+1^TMGDBAP2 "RTN","TMGDBAPI",1194,0) "RTN","TMGDBAPI",1195,0) GetFldName(File,FieldNumber) "RTN","TMGDBAPI",1196,0) goto GetFldName+1^TMGDBAP2 "RTN","TMGDBAPI",1197,0) "RTN","TMGDBAPI",1198,0) GetFldList(File,pArray) "RTN","TMGDBAPI",1199,0) goto GetFldList+1^TMGDBAP2 "RTN","TMGDBAPI",1200,0) "RTN","TMGDBAPI",1201,0) SetupFileNum(Data) "RTN","TMGDBAPI",1202,0) goto SetupFileNum+1^TMGDBAP2 "RTN","TMGDBAPI",1203,0) "RTN","TMGDBAPI",1204,0) RecFind(Params) "RTN","TMGDBAPI",1205,0) goto RecFind+1^TMGDBAP2 "RTN","TMGDBAPI",1206,0) "RTN","TMGDBAPI",1207,0) FieldCompare(TestField,dbField,Type) "RTN","TMGDBAPI",1208,0) goto FieldCompare+1^TMGDBAP2 "RTN","TMGDBAPI",1209,0) "RTN","TMGDBAPI",1210,0) EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) "RTN","TMGDBAPI",1211,0) goto EnsureWrite+1^TMGDBAP2 "RTN","TMGDBAPI",1212,0) "RTN","TMGDBAPI",1213,0) dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) "RTN","TMGDBAPI",1214,0) goto dbWrite+1^TMGDBAP2 "RTN","TMGDBAPI",1215,0) "RTN","TMGDBAPI",1216,0) DelIEN(File,RecNumIEN,ErrArray) "RTN","TMGDBAPI",1217,0) goto DelIEN+1^TMGDBAP2 "RTN","TMGDBAPI",1218,0) "RTN","TMGDBAPI",1219,0) WriteWP(File,RecNumIEN,Field,TMGArray) "RTN","TMGDBAPI",1220,0) goto WriteWP+1^TMGDBAP2 "RTN","TMGDBAPI",1221,0) "RTN","TMGDBAPI",1222,0) ReadWP(File,IENS,Field,Array) "RTN","TMGDBAPI",1223,0) goto ReadWP+1^TMGDBAP2 "RTN","TMGDBAPI",1224,0) "RTN","TMGDBAPI",1225,0) ShowIfError(TMGMsg,PriorErrorFound) "RTN","TMGDBAPI",1226,0) goto ShowIfError+1^TMGDBAP2 "RTN","TMGDBAPI",1227,0) "RTN","TMGDBAPI",1228,0) DataImport(Info,ProgressFN) "RTN","TMGDBAPI",1229,0) goto DataImport+1^TMGDBAP2 "RTN","TMGDBAPI",1230,0) "RTN","TMGDBAPI",1231,0) Set1(File,IEN,Field,Value,Flag) "RTN","TMGDBAPI",1232,0) goto Set1+1^TMGDBAP2 "RTN","TMGDBAPI",1233,0) "RTN","TMGDBAPI",1234,0) GetValidInput(File,Field) "RTN","TMGDBAPI",1235,0) goto GetValidInput+1^TMGDBAP2 "RTN","TMGDBAPI",1236,0) "RTN","TMGDBAPI",1237,0) AskFIENS() "RTN","TMGDBAPI",1238,0) goto AskFIENS+1^TMGDBAP2 "RTN","TMGDBAPI",1239,0) "RTN","TMGDBAPI",1240,0) ASKSCRN "RTN","TMGDBAPI",1241,0) goto ASKSCRN+1^TMGDBAP2 "RTN","TMGDBAPI",1242,0) "RTN","TMGDBAPI",1243,0) AskIENS(FileNum,IENS) "RTN","TMGDBAPI",1244,0) goto AskIENS+1^TMGDBAP2 "RTN","TMGDBAPI",1245,0) "RTN","TMGDBAPI",1246,0) GetRefArray(FileNum,array) "RTN","TMGDBAPI",1247,0) goto GetRefArray+1^TMGDBAP2 "RTN","TMGDBAPI",1248,0) "RTN","TMGDBAPI",1249,0) FIENS2Root(FIENS) "RTN","TMGDBAPI",1250,0) goto FIENS2Root+1^TMGDBAP2 "RTN","TMGDBAPI",1251,0) "RTN","TMGDBAPI",1252,0) GetRef(file,IENS,field) "RTN","TMGDBAPI",1253,0) goto GetRef+1^TMGDBAP2 "RTN","TMGDBAPI",1254,0) "RTN","TMGDBAPI",1255,0) TrimFDA(FDA,Quiet) "RTN","TMGDBAPI",1256,0) goto TrimFDA+1^TMGDBAP2 "RTN","TMGDBAPI",1257,0) "RTN","TMGDBAPI",1258,0) GetPtrsOUT(File,Info) "RTN","TMGDBAPI",1259,0) goto GetPtrsOUT+1^TMGDBAP2 "RTN","TMGDBAPI",1260,0) "RTN","TMGDEBUG") 0^8^B10834 "RTN","TMGDEBUG",1,0) TMGDEBUG ;TMG/kst/Debug utilities: logging, record dump ;03/25/06 "RTN","TMGDEBUG",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGDEBUG",3,0) "RTN","TMGDEBUG",4,0) "RTN","TMGDEBUG",5,0) "RTN","TMGDEBUG",6,0) ;"TMG DEBUG UTILITIES "RTN","TMGDEBUG",7,0) ;"Kevin Toppenberg MD "RTN","TMGDEBUG",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGDEBUG",9,0) ;"7-12-2005 "RTN","TMGDEBUG",10,0) "RTN","TMGDEBUG",11,0) ;"======================================================================= "RTN","TMGDEBUG",12,0) ;" API -- Public Functions. "RTN","TMGDEBUG",13,0) ;"======================================================================= "RTN","TMGDEBUG",14,0) ;"$$GetDebugMode^TMGDEBUG(DefVal) "RTN","TMGDEBUG",15,0) ;"OpenDefLogFile^TMGDEBUG "RTN","TMGDEBUG",16,0) ;"OpenLogFile^TMGDEBUG(DefPath,DefName) "RTN","TMGDEBUG",17,0) ;"DebugMsg^TMGDEBUG(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L) "RTN","TMGDEBUG",18,0) ;"DebugWrite^TMGDEBUG(DBIndent,s,AddNewline) "RTN","TMGDEBUG",19,0) ;"DebugIndent^TMGDEBUG(Num) "RTN","TMGDEBUG",20,0) ;"ArrayDump^TMGDEBUG(ArrayP,index,indent) "RTN","TMGDEBUG",21,0) ;"ASKANODES "RTN","TMGDEBUG",22,0) ;"ArrayNodes(pArray) "RTN","TMGDEBUG",23,0) ;"DebugEntry^TMGDEBUG((DBIndent,ProcName) "RTN","TMGDEBUG",24,0) ;"DebugExit^TMGDEBUG(DBIndent,ProcName) "RTN","TMGDEBUG",25,0) ;"ShowError^TMGDEBUG(PriorErrorFound,Error) "RTN","TMGDEBUG",26,0) ;"$$GetErrStr^TMGDEBUG(ErrArray) "RTN","TMGDEBUG",27,0) ;"ShowIfDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) ;really same as below "RTN","TMGDEBUG",28,0) ;"ShowDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) "RTN","TMGDEBUG",29,0) ;"ExpandLine(Pos) "RTN","TMGDEBUG",30,0) ;"ASKDUMP -- A record dumper -- a little different from Fileman Inquire "RTN","TMGDEBUG",31,0) ;"DumpRec(FileNum,IEN) -- dump (display) a record, using Fileman functionality. "RTN","TMGDEBUG",32,0) ;"DumpRec2(FileNum,IEN,ShowEmpty) -- dump (display) a record, NOT Fileman's Inquire code "RTN","TMGDEBUG",33,0) "RTN","TMGDEBUG",34,0) ;"======================================================================= "RTN","TMGDEBUG",35,0) ;"Private API functions "RTN","TMGDEBUG",36,0) "RTN","TMGDEBUG",37,0) ;"DumpRec2(FileNum,IEN,ShowEmpty) "RTN","TMGDEBUG",38,0) ;"WriteRLabel(IEN,Ender) "RTN","TMGDEBUG",39,0) ;"WriteFLabel(Label,Field,Type,Ender) "RTN","TMGDEBUG",40,0) ;"WriteLine(Line) "RTN","TMGDEBUG",41,0) "RTN","TMGDEBUG",42,0) ;"======================================================================= "RTN","TMGDEBUG",43,0) ;"DEPENDENCIES "RTN","TMGDEBUG",44,0) ;" TMGUSRIF "RTN","TMGDEBUG",45,0) "RTN","TMGDEBUG",46,0) ;"Note: This module accesses custom file 22711, TMG UPLOAD SETTINGS "RTN","TMGDEBUG",47,0) ;" It is OK if this file does not exist (i.e. on other computer systems.) However, the function "RTN","TMGDEBUG",48,0) ;" OpenDefLogFile will fail to find a default specified file, and would not open a log file. "RTN","TMGDEBUG",49,0) ;" Nothing is PUT INTO this file in this module. So new global would NOT be created. "RTN","TMGDEBUG",50,0) ;"======================================================================= "RTN","TMGDEBUG",51,0) ;"======================================================================= "RTN","TMGDEBUG",52,0) "RTN","TMGDEBUG",53,0) GetDebugMode(DefVal) "RTN","TMGDEBUG",54,0) ;"Purpose: to ask if debug output desired "RTN","TMGDEBUG",55,0) ;"Input: DefVal [optional] -- Default choice "RTN","TMGDEBUG",56,0) ;"result: returns values as below "RTN","TMGDEBUG",57,0) ;" 0, cdbNone - no debug "RTN","TMGDEBUG",58,0) ;" 1, cdbToScrn - Debug output to screen "RTN","TMGDEBUG",59,0) ;" 2, cdbToFile - Debug output to file "RTN","TMGDEBUG",60,0) ;" 3, cdbToTail - Debug output to X tail dialog box. "RTN","TMGDEBUG",61,0) ;" Note: 2-2-06 I am adding a mode (-1) which is EXTRA QUIET (used initially in ShowError) "RTN","TMGDEBUG",62,0) ;"Note: This does not set up output streams etc, just gets preference. "RTN","TMGDEBUG",63,0) "RTN","TMGDEBUG",64,0) new cdbNone set cdbNone=0 "RTN","TMGDEBUG",65,0) new cdbAbort set cdbAbort=0 "RTN","TMGDEBUG",66,0) new cdbToScrn set cdbToScrn=1 ;"was 2 "RTN","TMGDEBUG",67,0) new cdbToFile set cdbToFile=2 ;"was 3 "RTN","TMGDEBUG",68,0) new cdbToTail set cdbToTail=3 ;"was 4 "RTN","TMGDEBUG",69,0) "RTN","TMGDEBUG",70,0) new Input "RTN","TMGDEBUG",71,0) new result set result=cdbNone ;"the default "RTN","TMGDEBUG",72,0) new Default set Default=$get(DefVal,3) "RTN","TMGDEBUG",73,0) "RTN","TMGDEBUG",74,0) write !,"Select debug output option:",! "RTN","TMGDEBUG",75,0) write " '^'. Abort",! "RTN","TMGDEBUG",76,0) write " 0. NO debug output",! "RTN","TMGDEBUG",77,0) write " 1. Show debug output on screen",! "RTN","TMGDEBUG",78,0) write " 2. Send debug output to file",! "RTN","TMGDEBUG",79,0) if $get(DispMode(cDialog)) do "RTN","TMGDEBUG",80,0) . write " 3. Show debug output in X tail dialog box.",! "RTN","TMGDEBUG",81,0) "RTN","TMGDEBUG",82,0) write "Enter option number ("_Default_"): " "RTN","TMGDEBUG",83,0) read Input,! "RTN","TMGDEBUG",84,0) "RTN","TMGDEBUG",85,0) if Input="" do "RTN","TMGDEBUG",86,0) . write "Defaulting to: ",Default,! "RTN","TMGDEBUG",87,0) . set Input=Default "RTN","TMGDEBUG",88,0) "RTN","TMGDEBUG",89,0) if Input="^" set result=cdbAbort "RTN","TMGDEBUG",90,0) if Input=0 set result=cdbNone "RTN","TMGDEBUG",91,0) if Input=1 set result=cdbToScrn "RTN","TMGDEBUG",92,0) if Input=2 set result=cdbToFile "RTN","TMGDEBUG",93,0) if Input=3 set result=cdbToTail "RTN","TMGDEBUG",94,0) "RTN","TMGDEBUG",95,0) GDMDone "RTN","TMGDEBUG",96,0) quit result "RTN","TMGDEBUG",97,0) "RTN","TMGDEBUG",98,0) OpenDefLogFile "RTN","TMGDEBUG",99,0) ;"Purpose: To open a default log file for debug output "RTN","TMGDEBUG",100,0) ;"Results: none "RTN","TMGDEBUG",101,0) "RTN","TMGDEBUG",102,0) new DefPath,DefName "RTN","TMGDEBUG",103,0) "RTN","TMGDEBUG",104,0) set DefPath=$piece($get(^TMG(22711,1,2)),"^",1) "RTN","TMGDEBUG",105,0) set DefName=$piece($get(^TMG(22711,1,1)),"^",1) "RTN","TMGDEBUG",106,0) "RTN","TMGDEBUG",107,0) do OpenLogFile(.DefPath,.DefName) "RTN","TMGDEBUG",108,0) "RTN","TMGDEBUG",109,0) quit "RTN","TMGDEBUG",110,0) "RTN","TMGDEBUG",111,0) "RTN","TMGDEBUG",112,0) OpenLogFile(DefPath,DefName) "RTN","TMGDEBUG",113,0) ;"Purpose: To open a log file for debug output "RTN","TMGDEBUG",114,0) ;"Input: DefPath -- the default path, like this: "/tmp/" <-- note trailing '/' "RTN","TMGDEBUG",115,0) ;" DefName -- default file name (without path). e.g. "LogFile.tmp" "RTN","TMGDEBUG",116,0) ;"Results: None "RTN","TMGDEBUG",117,0) "RTN","TMGDEBUG",118,0) new DebugFPath set DebugFPath=$get(DefPath,"/tmp/") "RTN","TMGDEBUG",119,0) new DebugFName set DebugFName=$get(DefName,"M_DebugLog.tmp") "RTN","TMGDEBUG",120,0) if $get(TMGDEBUG)>1 do "RTN","TMGDEBUG",121,0) . write "Note: Sending debug output to file: ",DebugFPath,DebugFName,! "RTN","TMGDEBUG",122,0) "RTN","TMGDEBUG",123,0) ;"new DebugFile -- don't NEW here, needs to be global-scope "RTN","TMGDEBUG",124,0) set DebugFile=DebugFPath_DebugFName "RTN","TMGDEBUG",125,0) new FileSpec set FileSpec(DebugFile)="" "RTN","TMGDEBUG",126,0) "RTN","TMGDEBUG",127,0) if +$piece($get(^TMG(22711,1,1)),"^",2)'=1 do "RTN","TMGDEBUG",128,0) . ;"kill any pre-existing log "RTN","TMGDEBUG",129,0) . new result "RTN","TMGDEBUG",130,0) . set result=$$DEL^%ZISH(DebugFPath,$name(FileSpec)) ;"delete any preexisting one. "RTN","TMGDEBUG",131,0) "RTN","TMGDEBUG",132,0) open DebugFile "RTN","TMGDEBUG",133,0) use $PRINCIPAL "RTN","TMGDEBUG",134,0) "RTN","TMGDEBUG",135,0) quit "RTN","TMGDEBUG",136,0) "RTN","TMGDEBUG",137,0) "RTN","TMGDEBUG",138,0) DebugMsg(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L) "RTN","TMGDEBUG",139,0) ;"PUBLIC FUNCTION "RTN","TMGDEBUG",140,0) ;"Purpose: a debugging message output procedure "RTN","TMGDEBUG",141,0) ;"Input:DBIndent -- the value of indentation expected "RTN","TMGDEBUG",142,0) ;" Msg -- a string or value to show as message "RTN","TMGDEBUG",143,0) ;" A..L -- extra values to show. "RTN","TMGDEBUG",144,0) ;" "RTN","TMGDEBUG",145,0) if $get(TMGDEBUG,0)=0 quit "RTN","TMGDEBUG",146,0) set cTrue=$get(cTrue,1) "RTN","TMGDEBUG",147,0) set DBIndent=$get(DBIndent,0) "RTN","TMGDEBUG",148,0) "RTN","TMGDEBUG",149,0) set Msg=$get(Msg) "RTN","TMGDEBUG",150,0) set Msg=Msg_$get(A) "RTN","TMGDEBUG",151,0) set Msg=Msg_$get(B) "RTN","TMGDEBUG",152,0) set Msg=Msg_$get(C) "RTN","TMGDEBUG",153,0) set Msg=Msg_$get(D) "RTN","TMGDEBUG",154,0) set Msg=Msg_$get(E) "RTN","TMGDEBUG",155,0) set Msg=Msg_$get(F) "RTN","TMGDEBUG",156,0) set Msg=Msg_$get(G) "RTN","TMGDEBUG",157,0) set Msg=Msg_$get(H) "RTN","TMGDEBUG",158,0) set Msg=Msg_$get(I) "RTN","TMGDEBUG",159,0) set Msg=Msg_$get(J) "RTN","TMGDEBUG",160,0) set Msg=Msg_$get(K) "RTN","TMGDEBUG",161,0) set Msg=Msg_$get(L) "RTN","TMGDEBUG",162,0) do DebugIndent(DBIndent) "RTN","TMGDEBUG",163,0) do DebugWrite(DBIndent,.Msg,cTrue) "RTN","TMGDEBUG",164,0) "RTN","TMGDEBUG",165,0) quit "RTN","TMGDEBUG",166,0) "RTN","TMGDEBUG",167,0) "RTN","TMGDEBUG",168,0) DebugWrite(DBIndent,s,AddNewline) "RTN","TMGDEBUG",169,0) ;"PUBLIC FUNCTION "RTN","TMGDEBUG",170,0) ;"Purpose: to write debug output. Having the proc separate will allow "RTN","TMGDEBUG",171,0) ;" easier dump to file etc. "RTN","TMGDEBUG",172,0) ;"Input:DBIndent, the amount of indentation expected for output. "RTN","TMGDEBUG",173,0) ;" s -- the text to write "RTN","TMGDEBUG",174,0) ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s "RTN","TMGDEBUG",175,0) "RTN","TMGDEBUG",176,0) ;"Relevant DEBUG values "RTN","TMGDEBUG",177,0) ;" cdbNone - no debug (0) "RTN","TMGDEBUG",178,0) ;" cdbToScrn - Debug output to screen (1) "RTN","TMGDEBUG",179,0) ;" cdbToFile - Debug output to file (2) "RTN","TMGDEBUG",180,0) ;" cdbToTail - Debug output to X tail dialog box. (3) "RTN","TMGDEBUG",181,0) ;"Note: If above values are not defined, then functionality will be ignored. "RTN","TMGDEBUG",182,0) "RTN","TMGDEBUG",183,0) "RTN","TMGDEBUG",184,0) set cdbNone=$get(cdbNone,0) "RTN","TMGDEBUG",185,0) set cdbToScrn=$get(cdbToScrn,1) "RTN","TMGDEBUG",186,0) set cdbToFile=$get(cdbToFile,2) "RTN","TMGDEBUG",187,0) set cdbToTail=$get(cdbToTail,3) "RTN","TMGDEBUG",188,0) set TMGDEBUG=$get(TMGDEBUG,cdbNone) "RTN","TMGDEBUG",189,0) if $get(TMGDEBUG)=cdbNone quit "RTN","TMGDEBUG",190,0) "RTN","TMGDEBUG",191,0) if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do "RTN","TMGDEBUG",192,0) . if $data(DebugFile) use DebugFile "RTN","TMGDEBUG",193,0) "RTN","TMGDEBUG",194,0) new ch,chN,l,i "RTN","TMGDEBUG",195,0) set l=$length(s) "RTN","TMGDEBUG",196,0) for i=1:1:l do "RTN","TMGDEBUG",197,0) . set ch=$extract(s,i) "RTN","TMGDEBUG",198,0) . set chN=$ascii(ch) "RTN","TMGDEBUG",199,0) . if (chN<32)&(chN'=13) write "<",chN,">" "RTN","TMGDEBUG",200,0) . else write ch "RTN","TMGDEBUG",201,0) ;"write s "RTN","TMGDEBUG",202,0) "RTN","TMGDEBUG",203,0) set cTrue=$get(cTrue,1) "RTN","TMGDEBUG",204,0) if $get(AddNewline)=cTrue write ! "RTN","TMGDEBUG",205,0) "RTN","TMGDEBUG",206,0) if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do "RTN","TMGDEBUG",207,0) . use $PRINCIPAL "RTN","TMGDEBUG",208,0) "RTN","TMGDEBUG",209,0) quit "RTN","TMGDEBUG",210,0) "RTN","TMGDEBUG",211,0) "RTN","TMGDEBUG",212,0) DebugIndent(DBIndentForced) "RTN","TMGDEBUG",213,0) ;"PUBLIC FUNCTION "RTN","TMGDEBUG",214,0) ;"Purpose: to provide a unified indentation for debug messages "RTN","TMGDEBUG",215,0) ;"Input: DBIndent = number of indentations "RTN","TMGDEBUG",216,0) ;" Forced = 1 if to indent regardless of DEBUG mode "RTN","TMGDEBUG",217,0) "RTN","TMGDEBUG",218,0) set Forced=$get(Forced,0) "RTN","TMGDEBUG",219,0) "RTN","TMGDEBUG",220,0) if ($get(TMGDEBUG,0)=0)&(Forced=0) quit "RTN","TMGDEBUG",221,0) new i "RTN","TMGDEBUG",222,0) for i=1:1:DBIndent do "RTN","TMGDEBUG",223,0) . if Forced do DebugWrite(DBIndent," ") "RTN","TMGDEBUG",224,0) . else do DebugWrite(DBIndent,". ") "RTN","TMGDEBUG",225,0) quit "RTN","TMGDEBUG",226,0) "RTN","TMGDEBUG",227,0) "RTN","TMGDEBUG",228,0) "RTN","TMGDEBUG",229,0) ArrayDump(ArrayP,TMGIDX,indent,flags) "RTN","TMGDEBUG",230,0) ;"PUBLIC FUNCTION "RTN","TMGDEBUG",231,0) ;"Purpose: to get a custom version of GTM's "zwr" command "RTN","TMGDEBUG",232,0) ;"Input: Uses global scope var DBIndent (if defined) "RTN","TMGDEBUG",233,0) ;" ArrayP: NAME of global or variable to display, i.e. "^VA(200)", "MyVar" "RTN","TMGDEBUG",234,0) ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) -- Optional "RTN","TMGDEBUG",235,0) ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces) "RTN","TMGDEBUG",236,0) ;" OPTIONAL: indent may be an array, with information about columns "RTN","TMGDEBUG",237,0) ;" to skip. For example: "RTN","TMGDEBUG",238,0) ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2 "RTN","TMGDEBUG",239,0) ;" flags: OPTIONAL. "F"-> flat (don't use tre structure) "RTN","TMGDEBUG",240,0) ;"Result: none "RTN","TMGDEBUG",241,0) "RTN","TMGDEBUG",242,0) ;"--Leave out, this calls itself recursively! do DebugEntry("ArrayDump") "RTN","TMGDEBUG",243,0) ;"--Leave out, this calls itself recursively! do DebugMsg^TMGDEBUG("ArrayP=",ArrayP,", TMGIDX=",index) "RTN","TMGDEBUG",244,0) "RTN","TMGDEBUG",245,0) if $data(ArrayP)=0 quit "RTN","TMGDEBUG",246,0) "RTN","TMGDEBUG",247,0) if $get(flags)["F" do goto ADDone "RTN","TMGDEBUG",248,0) . new ref set ref=ArrayP "RTN","TMGDEBUG",249,0) . new nNums set nNums=$qlength(ref) "RTN","TMGDEBUG",250,0) . new lValue set lValue=$qsubscript(ref,nNums) "RTN","TMGDEBUG",251,0) . write ref,"=""",$get(@ref),"""",! "RTN","TMGDEBUG",252,0) . for set ref=$query(@ref) quit:(ref="")!($qsubscript(ref,nNums)'=lValue) do "RTN","TMGDEBUG",253,0) . . write ref,"=""",$get(@ref),"""",! "RTN","TMGDEBUG",254,0) "RTN","TMGDEBUG",255,0) ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes. "RTN","TMGDEBUG",256,0) new X set X="SET TEMP=$GET("_ArrayP_")" "RTN","TMGDEBUG",257,0) set X=$$UP^XLFSTR(X) "RTN","TMGDEBUG",258,0) do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference. "RTN","TMGDEBUG",259,0) if $get(X)="" quit "RTN","TMGDEBUG",260,0) "RTN","TMGDEBUG",261,0) set DBIndent=$get(DBIndent,0) "RTN","TMGDEBUG",262,0) set cTrue=$get(cTrue,1) "RTN","TMGDEBUG",263,0) set cFalse=$get(cFalse,0) "RTN","TMGDEBUG",264,0) "RTN","TMGDEBUG",265,0) ;"Force this function to output, even if TMGDEBUG is not defined. "RTN","TMGDEBUG",266,0) ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working "RTN","TMGDEBUG",267,0) new TMGDEBUG ;"//kt added 1-16-06 "RTN","TMGDEBUG",268,0) set TMGDEBUG=1 "RTN","TMGDEBUG",269,0) "RTN","TMGDEBUG",270,0) new ChildP,TMGi "RTN","TMGDEBUG",271,0) "RTN","TMGDEBUG",272,0) set TMGIDX=$get(TMGIDX,"") "RTN","TMGDEBUG",273,0) set indent=$get(indent,0) "RTN","TMGDEBUG",274,0) new SavIndex set SavIndex=TMGIDX "RTN","TMGDEBUG",275,0) "RTN","TMGDEBUG",276,0) do DebugIndent(DBIndent) "RTN","TMGDEBUG",277,0) "RTN","TMGDEBUG",278,0) if indent>0 do "RTN","TMGDEBUG",279,0) . for TMGi=1:1:indent-1 do "RTN","TMGDEBUG",280,0) . . new s set s="" "RTN","TMGDEBUG",281,0) . . if $get(indent(TMGi),-1)=0 set s=" " "RTN","TMGDEBUG",282,0) . . else set s="| " "RTN","TMGDEBUG",283,0) . . do DebugWrite(DBIndent,s) "RTN","TMGDEBUG",284,0) . do DebugWrite(DBIndent,"}~") "RTN","TMGDEBUG",285,0) "RTN","TMGDEBUG",286,0) if TMGIDX'="" do "RTN","TMGDEBUG",287,0) . if $data(@ArrayP@(TMGIDX))#10=1 do "RTN","TMGDEBUG",288,0) . . new s set s=@ArrayP@(TMGIDX) "RTN","TMGDEBUG",289,0) . . if s="" set s="""""" "RTN","TMGDEBUG",290,0) . . new qt set qt="" "RTN","TMGDEBUG",291,0) . . if +TMGIDX'=TMGIDX set qt="""" "RTN","TMGDEBUG",292,0) . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue) "RTN","TMGDEBUG",293,0) . else do "RTN","TMGDEBUG",294,0) . . do DebugWrite(DBIndent,TMGIDX,1) "RTN","TMGDEBUG",295,0) . set ArrayP=$name(@ArrayP@(TMGIDX)) "RTN","TMGDEBUG",296,0) else do "RTN","TMGDEBUG",297,0) . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse) "RTN","TMGDEBUG",298,0) . do DebugWrite(DBIndent,ArrayP,cFalse) "RTN","TMGDEBUG",299,0) . if $data(@ArrayP)#10=1 do "RTN","TMGDEBUG",300,0) . . do DebugWrite(0,"="_$get(@ArrayP),cFalse) "RTN","TMGDEBUG",301,0) . do DebugWrite(0,"",cTrue) "RTN","TMGDEBUG",302,0) "RTN","TMGDEBUG",303,0) set TMGIDX=$order(@ArrayP@("")) "RTN","TMGDEBUG",304,0) if TMGIDX="" goto ADDone "RTN","TMGDEBUG",305,0) set indent=indent+1 "RTN","TMGDEBUG",306,0) "RTN","TMGDEBUG",307,0) for do quit:TMGIDX="" "RTN","TMGDEBUG",308,0) . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX)) "RTN","TMGDEBUG",309,0) . if tTMGIDX="" set indent(indent)=0 "RTN","TMGDEBUG",310,0) . new tIndent merge tIndent=indent "RTN","TMGDEBUG",311,0) . do ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively "RTN","TMGDEBUG",312,0) . set TMGIDX=$order(@ArrayP@(TMGIDX)) "RTN","TMGDEBUG",313,0) "RTN","TMGDEBUG",314,0) ;"Put in a blank space at end of subbranch "RTN","TMGDEBUG",315,0) do DebugIndent(DBIndent) "RTN","TMGDEBUG",316,0) "RTN","TMGDEBUG",317,0) if indent>0 do "RTN","TMGDEBUG",318,0) . for TMGi=1:1:indent-1 do "RTN","TMGDEBUG",319,0) . . new s set s="" "RTN","TMGDEBUG",320,0) . . if $get(indent(TMGi),-1)=0 set s=" " "RTN","TMGDEBUG",321,0) . . else set s="| " "RTN","TMGDEBUG",322,0) . . do DebugWrite(DBIndent,s) "RTN","TMGDEBUG",323,0) . do DebugWrite(DBIndent," ",1) "RTN","TMGDEBUG",324,0) "RTN","TMGDEBUG",325,0) ADDone "RTN","TMGDEBUG",326,0) ;"--Leave out, this calls itself recursively! do DebugExit("ArrayDump") "RTN","TMGDEBUG",327,0) quit "RTN","TMGDEBUG",328,0) "RTN","TMGDEBUG",329,0) "RTN","TMGDEBUG",330,0) ASKANODES "RTN","TMGDEBUG",331,0) ;"Purpose: to ask user for the name of an array, then display nodes "RTN","TMGDEBUG",332,0) "RTN","TMGDEBUG",333,0) new name "RTN","TMGDEBUG",334,0) write ! "RTN","TMGDEBUG",335,0) read "Enter name of array to display nodes in: ",name,! "RTN","TMGDEBUG",336,0) if name="^" set name="" "RTN","TMGDEBUG",337,0) if name'="" do ArrayNodes(name) "RTN","TMGDEBUG",338,0) quit "RTN","TMGDEBUG",339,0) "RTN","TMGDEBUG",340,0) "RTN","TMGDEBUG",341,0) ArrayNodes(pArray) "RTN","TMGDEBUG",342,0) ;"Purpose: To display all the nodes of the given array "RTN","TMGDEBUG",343,0) ;"Input: pArray -- NAME OF array to display "RTN","TMGDEBUG",344,0) "RTN","TMGDEBUG",345,0) new TMGi "RTN","TMGDEBUG",346,0) "RTN","TMGDEBUG",347,0) write pArray,! "RTN","TMGDEBUG",348,0) set TMGi=$order(@pArray@("")) "RTN","TMGDEBUG",349,0) if TMGi'="" for do quit:(TMGi="") "RTN","TMGDEBUG",350,0) . write " +--(",TMGi,")",! "RTN","TMGDEBUG",351,0) . set TMGi=$order(@pArray@(TMGi)) "RTN","TMGDEBUG",352,0) "RTN","TMGDEBUG",353,0) quit "RTN","TMGDEBUG",354,0) "RTN","TMGDEBUG",355,0) DebugEntry(DBIndent,ProcName) "RTN","TMGDEBUG",356,0) ;"PUBLIC FUNCTION "RTN","TMGDEBUG",357,0) ;"Purpose: A way to show when entering a procedure, in debug mode "RTN","TMGDEBUG",358,0) ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE "RTN","TMGDEBUG",359,0) ;" ProcName: any arbitrary name to show when decreasing indent amount. "RTN","TMGDEBUG",360,0) "RTN","TMGDEBUG",361,0) set ProcName=$get(ProcName,"?") "RTN","TMGDEBUG",362,0) set DBIndent=$get(DBIndent,0) "RTN","TMGDEBUG",363,0) do DebugMsg(DBIndent,ProcName_" {") "RTN","TMGDEBUG",364,0) set DBIndent=DBIndent+1 "RTN","TMGDEBUG",365,0) quit "RTN","TMGDEBUG",366,0) "RTN","TMGDEBUG",367,0) "RTN","TMGDEBUG",368,0) DebugExit(DBIndent,ProcName) "RTN","TMGDEBUG",369,0) ;"PUBLIC FUNCTION "RTN","TMGDEBUG",370,0) ;"Purpose: A way to show when leaving a procedure, in debug mode "RTN","TMGDEBUG",371,0) ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE "RTN","TMGDEBUG",372,0) ;" ProcName: any arbitrary name to show when decreasing indent amount. "RTN","TMGDEBUG",373,0) "RTN","TMGDEBUG",374,0) ;"write "DBIndent=",DBIndent,! "RTN","TMGDEBUG",375,0) ;"write "ProcName=",ProcName,! "RTN","TMGDEBUG",376,0) set ProcName=$get(ProcName,"?") "RTN","TMGDEBUG",377,0) set DBIndent=$get(DBIndent)-1 "RTN","TMGDEBUG",378,0) if DBIndent<0 set DBIndent=0 "RTN","TMGDEBUG",379,0) do DebugMsg(DBIndent,"} //"_ProcName) "RTN","TMGDEBUG",380,0) "RTN","TMGDEBUG",381,0) quit "RTN","TMGDEBUG",382,0) "RTN","TMGDEBUG",383,0) "RTN","TMGDEBUG",384,0) "RTN","TMGDEBUG",385,0) "RTN","TMGDEBUG",386,0) ShowError(PriorErrorFound,Error) "RTN","TMGDEBUG",387,0) ;"Purpose: to output an error message "RTN","TMGDEBUG",388,0) ;"Input: [OPTIONAL] PriorErrorFound -- var to see if an error already shown. "RTN","TMGDEBUG",389,0) ;" if not passed, then default value used ('no prior error') "RTN","TMGDEBUG",390,0) ;" Error -- a string to display "RTN","TMGDEBUG",391,0) ;"results: none "RTN","TMGDEBUG",392,0) "RTN","TMGDEBUG",393,0) if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely "RTN","TMGDEBUG",394,0) "RTN","TMGDEBUG",395,0) if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowError") "RTN","TMGDEBUG",396,0) if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error msg=",Error) "RTN","TMGDEBUG",397,0) "RTN","TMGDEBUG",398,0) if $get(PriorErrorFound,0) do goto ShErrQuit ;"Remove to show cascading errors "RTN","TMGDEBUG",399,0) . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Prior error found, so won't show this error.") "RTN","TMGDEBUG",400,0) "RTN","TMGDEBUG",401,0) if $data(DBIndent)=0 new DBIndent ;"If it wasn't global before, keep it that way. "RTN","TMGDEBUG",402,0) new SaveIndent set SaveIndent=$get(DBIndent) "RTN","TMGDEBUG",403,0) set DBIndent=1 "RTN","TMGDEBUG",404,0) do PopupBox^TMGUSRIF(" ERROR . . .",Error) "RTN","TMGDEBUG",405,0) set PriorErrorFound=1 "RTN","TMGDEBUG",406,0) set DBIndent=SaveIndent "RTN","TMGDEBUG",407,0) "RTN","TMGDEBUG",408,0) ShErrQuit "RTN","TMGDEBUG",409,0) if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowError") "RTN","TMGDEBUG",410,0) "RTN","TMGDEBUG",411,0) quit "RTN","TMGDEBUG",412,0) "RTN","TMGDEBUG",413,0) "RTN","TMGDEBUG",414,0) GetErrStr(ErrArray) "RTN","TMGDEBUG",415,0) ;"Purpose: convert a standard DIERR array into a string for output "RTN","TMGDEBUG",416,0) ;"Input: ErrArray -- PASS BY REFERENCE. example: "RTN","TMGDEBUG",417,0) ;" array("DIERR")="1^1" "RTN","TMGDEBUG",418,0) ;" array("DIERR",1)=311 "RTN","TMGDEBUG",419,0) ;" array("DIERR",1,"PARAM",0)=3 "RTN","TMGDEBUG",420,0) ;" array("DIERR",1,"PARAM","FIELD")=.02 "RTN","TMGDEBUG",421,0) ;" array("DIERR",1,"PARAM","FILE")=2 "RTN","TMGDEBUG",422,0) ;" array("DIERR",1,"PARAM","IENS")="+1," "RTN","TMGDEBUG",423,0) ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers." "RTN","TMGDEBUG",424,0) ;" array("DIERR","E",311,1)="" "RTN","TMGDEBUG",425,0) ;"Results: returns one long equivalent string from above array. "RTN","TMGDEBUG",426,0) "RTN","TMGDEBUG",427,0) new ErrStr "RTN","TMGDEBUG",428,0) new TMGIDX "RTN","TMGDEBUG",429,0) new ErrNum "RTN","TMGDEBUG",430,0) "RTN","TMGDEBUG",431,0) set ErrStr="" "RTN","TMGDEBUG",432,0) for ErrNum=1:1:+$get(ErrArray("DIERR")) do "RTN","TMGDEBUG",433,0) . set ErrStr=ErrStr_"Fileman says: '" "RTN","TMGDEBUG",434,0) . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") " "RTN","TMGDEBUG",435,0) . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT","")) "RTN","TMGDEBUG",436,0) . if TMGIDX'="" for do quit:(TMGIDX="") "RTN","TMGDEBUG",437,0) . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" " "RTN","TMGDEBUG",438,0) . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX)) "RTN","TMGDEBUG",439,0) . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do "RTN","TMGDEBUG",440,0) . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0)) "RTN","TMGDEBUG",441,0) . . set ErrStr=ErrStr_"Details: " "RTN","TMGDEBUG",442,0) . . for do quit:(TMGIDX="") "RTN","TMGDEBUG",443,0) . . . if TMGIDX="" quit "RTN","TMGDEBUG",444,0) . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" " "RTN","TMGDEBUG",445,0) . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX)) "RTN","TMGDEBUG",446,0) "RTN","TMGDEBUG",447,0) quit ErrStr "RTN","TMGDEBUG",448,0) "RTN","TMGDEBUG",449,0) "RTN","TMGDEBUG",450,0) "RTN","TMGDEBUG",451,0) ShowIfDIERR(ErrMsg,PriorErrorFound) ;"really same as below "RTN","TMGDEBUG",452,0) goto SEL1 "RTN","TMGDEBUG",453,0) "RTN","TMGDEBUG",454,0) ShowDIERR(ErrMsg,PriorErrorFound) "RTN","TMGDEBUG",455,0) ;"Purpose: To provide a standard output mechanism for the fileman DIERR message "RTN","TMGDEBUG",456,0) ;"Input: ErrMsg -- PASS BY REFERENCE. a standard error message array, as "RTN","TMGDEBUG",457,0) ;" put out by fileman calls "RTN","TMGDEBUG",458,0) ;" PriorErrorFound -- OPTIONAL variable to keep track if prior error found. "RTN","TMGDEBUG",459,0) ;" Note -- can also be used as ErrorFound (i.e. set to 1 if error found) "RTN","TMGDEBUG",460,0) ;"Output -- none "RTN","TMGDEBUG",461,0) ;"Result -- none "RTN","TMGDEBUG",462,0) "RTN","TMGDEBUG",463,0) SEL1 "RTN","TMGDEBUG",464,0) if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely "RTN","TMGDEBUG",465,0) "RTN","TMGDEBUG",466,0) if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowDIERR") "RTN","TMGDEBUG",467,0) "RTN","TMGDEBUG",468,0) if $data(ErrMsg("DIERR")) do "RTN","TMGDEBUG",469,0) . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error message found. Here is array:") "RTN","TMGDEBUG",470,0) . if $get(TMGDEBUG) do ArrayDump("ErrMsg") "RTN","TMGDEBUG",471,0) . new ErrStr "RTN","TMGDEBUG",472,0) . set ErrStr=$$GetErrStr(.ErrMsg) "RTN","TMGDEBUG",473,0) . do ShowError(.PriorErrorFound,.ErrStr) "RTN","TMGDEBUG",474,0) "RTN","TMGDEBUG",475,0) if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowDIERR") "RTN","TMGDEBUG",476,0) quit "RTN","TMGDEBUG",477,0) "RTN","TMGDEBUG",478,0) ExpandLine(Pos) "RTN","TMGDEBUG",479,0) ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality "RTN","TMGDEBUG",480,0) ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS) "RTN","TMGDEBUG",481,0) ;"Output: Writes to the currently selecte IO device and expansion of one line of code "RTN","TMGDEBUG",482,0) ;"Note: This is used for taking the very long lines of code, as found in Fileman, and "RTN","TMGDEBUG",483,0) ;" convert them to a format with one command on each line. "RTN","TMGDEBUG",484,0) ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA "RTN","TMGDEBUG",485,0) ;" conventions--such as commands must be UPPERCASE etc. "RTN","TMGDEBUG",486,0) "RTN","TMGDEBUG",487,0) ;"--- copied and modified from XINDX8.m --- "RTN","TMGDEBUG",488,0) "RTN","TMGDEBUG",489,0) kill ^UTILITY($J) "RTN","TMGDEBUG",490,0) "RTN","TMGDEBUG",491,0) new label,offset,RTN,dmod "RTN","TMGDEBUG",492,0) do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod) "RTN","TMGDEBUG",493,0) if label'="" do ;"change position from one relative to label into one relative to top of file "RTN","TMGDEBUG",494,0) . new CodeArray "RTN","TMGDEBUG",495,0) . set Pos=$$ConvertPos^TMGMISC(Pos,"CodeArray") "RTN","TMGDEBUG",496,0) . do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod) "RTN","TMGDEBUG",497,0) "RTN","TMGDEBUG",498,0) if RTN="" goto ELDone "RTN","TMGDEBUG",499,0) "RTN","TMGDEBUG",500,0) do BUILD^XINDX7 "RTN","TMGDEBUG",501,0) set ^UTILITY($J,RTN)="" "RTN","TMGDEBUG",502,0) do LOAD^XINDEX "RTN","TMGDEBUG",503,0) set CCN=0 "RTN","TMGDEBUG",504,0) for I=1:1:+^UTILITY($J,1,RTN,0,0) S CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2 "RTN","TMGDEBUG",505,0) set ^UTILITY($J,1,RTN,0)=CCN "RTN","TMGDEBUG",506,0) ;"do ^XINDX8 -- included below "RTN","TMGDEBUG",507,0) "RTN","TMGDEBUG",508,0) new Q,DDOT,LO,PG,LIN,ML,IDT "RTN","TMGDEBUG",509,0) new tIOSL set tIOSL=IOSL "RTN","TMGDEBUG",510,0) set IOSL=999999 ;"really long 'page length' prevents header printout (and error) "RTN","TMGDEBUG",511,0) "RTN","TMGDEBUG",512,0) set Q="""" "RTN","TMGDEBUG",513,0) set DDOT=0 "RTN","TMGDEBUG",514,0) set LO=0 "RTN","TMGDEBUG",515,0) set PG=+$G(PG) "RTN","TMGDEBUG",516,0) "RTN","TMGDEBUG",517,0) set LC=offset "RTN","TMGDEBUG",518,0) if $D(^UTILITY($J,1,RTN,0,LC)) do "RTN","TMGDEBUG",519,0) . S LIN=^(LC,0),ML=0,IDT=10 "RTN","TMGDEBUG",520,0) . set LO=LC-1 "RTN","TMGDEBUG",521,0) . D CD^XINDX8 "RTN","TMGDEBUG",522,0) "RTN","TMGDEBUG",523,0) K AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY "RTN","TMGDEBUG",524,0) "RTN","TMGDEBUG",525,0) set IOSL=tIOSL ;"restore saved IOSL "RTN","TMGDEBUG",526,0) ELDone "RTN","TMGDEBUG",527,0) quit "RTN","TMGDEBUG",528,0) "RTN","TMGDEBUG",529,0) "RTN","TMGDEBUG",530,0) DumpRec(FileNum,IEN) "RTN","TMGDEBUG",531,0) ;"Purpose: to dump (display) a record, using Fileman functionality. "RTN","TMGDEBUG",532,0) ;"Input: FileNum -- the number of the file to dump from "RTN","TMGDEBUG",533,0) ;" IEN -- the record number to display "RTN","TMGDEBUG",534,0) ;"Note: this code is modified from INQ^DII "RTN","TMGDEBUG",535,0) "RTN","TMGDEBUG",536,0) new DIC,X,Y,DI,DPP,DK,DICSS "RTN","TMGDEBUG",537,0) "RTN","TMGDEBUG",538,0) set X=FileNum,Y=X "RTN","TMGDEBUG",539,0) "RTN","TMGDEBUG",540,0) set DI=$get(^DIC(FileNum,0,"GL")) if DI="" quit "RTN","TMGDEBUG",541,0) set DPP(1)=FileNum_"^^^@" "RTN","TMGDEBUG",542,0) set DK=FileNum "RTN","TMGDEBUG",543,0) "RTN","TMGDEBUG",544,0) K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS "RTN","TMGDEBUG",545,0) "RTN","TMGDEBUG",546,0) set DIK=1 "RTN","TMGDEBUG",547,0) set ^UTILITY(U,$J,DIK,IEN)="" ;"<-- note, to have multiple IEN's shown, iterate via DIK "RTN","TMGDEBUG",548,0) "RTN","TMGDEBUG",549,0) do S^DII ;"Jump into Fileman code. "RTN","TMGDEBUG",550,0) "RTN","TMGDEBUG",551,0) quit "RTN","TMGDEBUG",552,0) "RTN","TMGDEBUG",553,0) "RTN","TMGDEBUG",554,0) xASKDUMP "RTN","TMGDEBUG",555,0) ;"Purpose: A record dumper -- a little different from Fileman Inquire "RTN","TMGDEBUG",556,0) "RTN","TMGDEBUG",557,0) new DIC,X,Y "RTN","TMGDEBUG",558,0) new FileNum,IEN "RTN","TMGDEBUG",559,0) new UseDefault set UseDefault=1 "RTN","TMGDEBUG",560,0) "RTN","TMGDEBUG",561,0) ;"Pick file to dump from "RTN","TMGDEBUG",562,0) xASK1 set DIC=1 "RTN","TMGDEBUG",563,0) set DIC(0)="AEQM" "RTN","TMGDEBUG",564,0) if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called "RTN","TMGDEBUG",565,0) . do ^DICRW ;" has default value of user's last response "RTN","TMGDEBUG",566,0) else do ^DIC ;doesn't have default value... "RTN","TMGDEBUG",567,0) if +Y'>0 write ! goto xASKDone "RTN","TMGDEBUG",568,0) set FileNum=+Y "RTN","TMGDEBUG",569,0) "RTN","TMGDEBUG",570,0) ;"Pick record to dump "RTN","TMGDEBUG",571,0) xASKLOOP kill DIC,X "RTN","TMGDEBUG",572,0) set DIC=+FileNum "RTN","TMGDEBUG",573,0) set DIC(0)="AEQM" "RTN","TMGDEBUG",574,0) do ^DIC write ! "RTN","TMGDEBUG",575,0) if +Y'>0 set UseDefault=0 goto xASK1 "RTN","TMGDEBUG",576,0) set IEN=+Y "RTN","TMGDEBUG",577,0) "RTN","TMGDEBUG",578,0) new % set %=2 "RTN","TMGDEBUG",579,0) write "Display empty fields" "RTN","TMGDEBUG",580,0) do YN^DICN "RTN","TMGDEBUG",581,0) if %=-1 write ! goto xASKDone "RTN","TMGDEBUG",582,0) "RTN","TMGDEBUG",583,0) new %ZIS "RTN","TMGDEBUG",584,0) set %ZIS("A")="Enter Output Device: " "RTN","TMGDEBUG",585,0) set %ZIS("B")="HOME" "RTN","TMGDEBUG",586,0) do ^%ZIS ;"standard device call "RTN","TMGDEBUG",587,0) if POP do goto xASKDone "RTN","TMGDEBUG",588,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") "RTN","TMGDEBUG",589,0) use IO "RTN","TMGDEBUG",590,0) "RTN","TMGDEBUG",591,0) ;"Do the output "RTN","TMGDEBUG",592,0) write ! "RTN","TMGDEBUG",593,0) do DumpRec2(FileNum,IEN,(%=1)) "RTN","TMGDEBUG",594,0) "RTN","TMGDEBUG",595,0) ;" Close the output device "RTN","TMGDEBUG",596,0) do ^%ZISC "RTN","TMGDEBUG",597,0) "RTN","TMGDEBUG",598,0) new temp "RTN","TMGDEBUG",599,0) read "Press [ENTER] to continue...",temp:$get(DTIME,3600),! "RTN","TMGDEBUG",600,0) "RTN","TMGDEBUG",601,0) goto xASKLOOP "RTN","TMGDEBUG",602,0) "RTN","TMGDEBUG",603,0) xASKDone "RTN","TMGDEBUG",604,0) quit "RTN","TMGDEBUG",605,0) "RTN","TMGDEBUG",606,0) ASKDUMP "RTN","TMGDEBUG",607,0) ;"Purpose: A record dumper -- a little different from Fileman Inquire "RTN","TMGDEBUG",608,0) "RTN","TMGDEBUG",609,0) write !!," -= RECORD DUMPER =-",! "RTN","TMGDEBUG",610,0) new FIENS,IENS "RTN","TMGDEBUG",611,0) AL1 "RTN","TMGDEBUG",612,0) set FIENS=$$AskFIENS^TMGDBAPI() "RTN","TMGDEBUG",613,0) if (FIENS["?")!(FIENS="^") goto ASKDone "RTN","TMGDEBUG",614,0) "RTN","TMGDEBUG",615,0) set FileNum=$piece(FIENS,"^",1) "RTN","TMGDEBUG",616,0) set IENS=$piece(FIENS,"^",2) "RTN","TMGDEBUG",617,0) "RTN","TMGDEBUG",618,0) AL2 "RTN","TMGDEBUG",619,0) set IENS=$$AskIENS^TMGDBAPI(FileNum,IENS) "RTN","TMGDEBUG",620,0) if (IENS["?")!(IENS="") goto AL1 "RTN","TMGDEBUG",621,0) "RTN","TMGDEBUG",622,0) new % set %=2 "RTN","TMGDEBUG",623,0) write "Display empty fields" "RTN","TMGDEBUG",624,0) do YN^DICN "RTN","TMGDEBUG",625,0) if %=-1 write ! goto ASKDone "RTN","TMGDEBUG",626,0) "RTN","TMGDEBUG",627,0) new %ZIS "RTN","TMGDEBUG",628,0) set %ZIS("A")="Enter Output Device: " "RTN","TMGDEBUG",629,0) set %ZIS("B")="HOME" "RTN","TMGDEBUG",630,0) do ^%ZIS ;"standard device call "RTN","TMGDEBUG",631,0) if POP do goto ASKDone "RTN","TMGDEBUG",632,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") "RTN","TMGDEBUG",633,0) use IO "RTN","TMGDEBUG",634,0) "RTN","TMGDEBUG",635,0) ;"Do the output "RTN","TMGDEBUG",636,0) write ! do DumpRec2(FileNum,IENS,(%=1)) "RTN","TMGDEBUG",637,0) "RTN","TMGDEBUG",638,0) ;" Close the output device "RTN","TMGDEBUG",639,0) do ^%ZISC "RTN","TMGDEBUG",640,0) "RTN","TMGDEBUG",641,0) do PressToCont^TMGUSRIF "RTN","TMGDEBUG",642,0) ;"new temp "RTN","TMGDEBUG",643,0) ;"read "Press [ENTER] to continue...",temp:$get(DTIME,3600),! "RTN","TMGDEBUG",644,0) "RTN","TMGDEBUG",645,0) set IENS=$piece(IENS,",",2,99) ;"force Pick of new record to dump "RTN","TMGDEBUG",646,0) if +IENS>0 goto AL2 "RTN","TMGDEBUG",647,0) goto AL1 "RTN","TMGDEBUG",648,0) "RTN","TMGDEBUG",649,0) ASKDone "RTN","TMGDEBUG",650,0) quit "RTN","TMGDEBUG",651,0) "RTN","TMGDEBUG",652,0) "RTN","TMGDEBUG",653,0) DumpRec2(FileNum,IENS,ShowEmpty,FieldsArray) "RTN","TMGDEBUG",654,0) ;"Purpose: to dump (display) a record, NOT using ^DII (Fileman's Inquire code) "RTN","TMGDEBUG",655,0) ;"Input: FileNum -- the number of the file to dump from "RTN","TMGDEBUG",656,0) ;" IENS -- the record number to display (or IENS: #,#,#,) "RTN","TMGDEBUG",657,0) ;" ShowEmpty -- OPTIONAL; if 1 then empty fields will be displayed "RTN","TMGDEBUG",658,0) ;" FieldsArray -- OPTIONAL. PASS BY REFERENCE. "RTN","TMGDEBUG",659,0) ;" Allows user to specify which fields to show. Format: "RTN","TMGDEBUG",660,0) ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number "RTN","TMGDEBUG",661,0) ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number "RTN","TMGDEBUG",662,0) ;" Default is an empty array, in which all fields are considered "RTN","TMGDEBUG",663,0) "RTN","TMGDEBUG",664,0) new Fields "RTN","TMGDEBUG",665,0) set Fields("*")="" "RTN","TMGDEBUG",666,0) new flags set flags="i" "RTN","TMGDEBUG",667,0) if $get(ShowEmpty)=1 set flags=flags_"b" "RTN","TMGDEBUG",668,0) "RTN","TMGDEBUG",669,0) write "Record# ",IENS,! "RTN","TMGDEBUG",670,0) "RTN","TMGDEBUG",671,0) new field,fieldName "RTN","TMGDEBUG",672,0) if $data(FieldsArray)=0 do "RTN","TMGDEBUG",673,0) . set field=$order(^DD(FileNum,0)) "RTN","TMGDEBUG",674,0) . if +field>0 for do quit:(+field'>0) "RTN","TMGDEBUG",675,0) . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) "RTN","TMGDEBUG",676,0) . . set Fields("TAG NAME",field)=fieldName_"("_field_")" "RTN","TMGDEBUG",677,0) . . set field=$order(^DD(FileNum,field)) "RTN","TMGDEBUG",678,0) else do ;"Handle case of showing ONLY requested fields "RTN","TMGDEBUG",679,0) . new temp set temp="" "RTN","TMGDEBUG",680,0) . for set temp=$order(FieldsArray(temp)) quit:(temp="") do "RTN","TMGDEBUG",681,0) . . if +temp=temp do "RTN","TMGDEBUG",682,0) . . . set field=+temp "RTN","TMGDEBUG",683,0) . . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) "RTN","TMGDEBUG",684,0) . . else do "RTN","TMGDEBUG",685,0) . . . set fieldName=temp "RTN","TMGDEBUG",686,0) . . . if $$SetFileFldNums^TMGDBAPI(FileNum,fieldName,,.field)=0 quit "RTN","TMGDEBUG",687,0) . . set Fields("TAG NAME",field)=fieldName_"("_field_")" "RTN","TMGDEBUG",688,0) . ;"Now exclude those fields not specifically included "RTN","TMGDEBUG",689,0) . set field=0 "RTN","TMGDEBUG",690,0) . for set field=$order(^DD(FileNum,field)) quit:(+field'>0) do "RTN","TMGDEBUG",691,0) . . if $data(Fields("TAG NAME",field))'=0 quit "RTN","TMGDEBUG",692,0) . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) "RTN","TMGDEBUG",693,0) . . set Fields("Field Exclude",field)="" "RTN","TMGDEBUG",694,0) "RTN","TMGDEBUG",695,0) new RFn,FFn,LFn,WPLFn "RTN","TMGDEBUG",696,0) set RFn="WriteRLabel^TMGDEBUG" "RTN","TMGDEBUG",697,0) set FFn="WriteFLabel^TMGDEBUG" "RTN","TMGDEBUG",698,0) set LFn="WriteLine^TMGDEBUG" "RTN","TMGDEBUG",699,0) set WPLFn="WriteWPLine^TMGDEBUG" "RTN","TMGDEBUG",700,0) "RTN","TMGDEBUG",701,0) ;"write "Using flags (options): ",flags,! "RTN","TMGDEBUG",702,0) "RTN","TMGDEBUG",703,0) if +IENS=IENS do "RTN","TMGDEBUG",704,0) . do Write1Rec^TMGXMLE2(FileNum,IENS,.Fields,flags,,,"",RFn,FFn,LFn,WPLFn) "RTN","TMGDEBUG",705,0) else do ;"dump a subfile record "RTN","TMGDEBUG",706,0) . do Write1Rec^TMGXMLE2(FileNum,+IENS,.Fields,flags,,IENS,"",RFn,FFn,LFn,WPLFn) "RTN","TMGDEBUG",707,0) "RTN","TMGDEBUG",708,0) quit "RTN","TMGDEBUG",709,0) "RTN","TMGDEBUG",710,0) "RTN","TMGDEBUG",711,0) WriteRLabel(IEN,Ender) "RTN","TMGDEBUG",712,0) ;"Purpose: To actually write out labels for record starting and ending. "RTN","TMGDEBUG",713,0) ;" IEN -- the IEN (record number) of the record "RTN","TMGDEBUG",714,0) ;" Ender -- OPTIONAL if 1, then ends field. "RTN","TMGDEBUG",715,0) ;"Results: none. "RTN","TMGDEBUG",716,0) ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 "RTN","TMGDEBUG",717,0) "RTN","TMGDEBUG",718,0) if +$get(Ender)>0 write ! "RTN","TMGDEBUG",719,0) else write " Multiple Entry #",IEN,"",! "RTN","TMGDEBUG",720,0) "RTN","TMGDEBUG",721,0) quit "RTN","TMGDEBUG",722,0) "RTN","TMGDEBUG",723,0) "RTN","TMGDEBUG",724,0) WriteFLabel(Label,Field,Type,Ender) "RTN","TMGDEBUG",725,0) ;"Purpose: This is the code that actually does writing of labels etc for output "RTN","TMGDEBUG",726,0) ;" This is a CUSTOM CALL BACK function called by Write1Fld^TMGXMLE2 "RTN","TMGDEBUG",727,0) ;"Input: Label -- OPTIONAL -- Name of label, to write after 'label=' "RTN","TMGDEBUG",728,0) ;" Field -- OPTIONAL -- Name of field, to write after 'id=' "RTN","TMGDEBUG",729,0) ;" Type -- OPTIONAL -- Typeof field, to write after 'type=' "RTN","TMGDEBUG",730,0) ;" Ender -- OPTIONAL if 1, then ends field. "RTN","TMGDEBUG",731,0) ;"Results: none. "RTN","TMGDEBUG",732,0) ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 "RTN","TMGDEBUG",733,0) "RTN","TMGDEBUG",734,0) ;"To write out or "RTN","TMGDEBUG",735,0) "RTN","TMGDEBUG",736,0) if +$get(Ender)>0 do "RTN","TMGDEBUG",737,0) . write ! "RTN","TMGDEBUG",738,0) else do "RTN","TMGDEBUG",739,0) . new s set s=Field "RTN","TMGDEBUG",740,0) . if $get(Field)'="" write $$RJ^XLFSTR(.s,6," "),"-" "RTN","TMGDEBUG",741,0) . if $get(Label)'="" write Label," " "RTN","TMGDEBUG",742,0) . ;"if $get(Type)'="" write "type=""",Type,""" " "RTN","TMGDEBUG",743,0) . write ": " "RTN","TMGDEBUG",744,0) "RTN","TMGDEBUG",745,0) quit "RTN","TMGDEBUG",746,0) "RTN","TMGDEBUG",747,0) "RTN","TMGDEBUG",748,0) WriteLine(Line) "RTN","TMGDEBUG",749,0) ;"Purpose: To actually write out labels for record starting and ending. "RTN","TMGDEBUG",750,0) ;"Input: Line -- The line of text to be written out. "RTN","TMGDEBUG",751,0) ;"Results: none. "RTN","TMGDEBUG",752,0) ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 "RTN","TMGDEBUG",753,0) "RTN","TMGDEBUG",754,0) write line "RTN","TMGDEBUG",755,0) quit "RTN","TMGDEBUG",756,0) "RTN","TMGDEBUG",757,0) "RTN","TMGDEBUG",758,0) WriteWPLine(Line) "RTN","TMGDEBUG",759,0) ;"Purpose: To actually write out line from WP field "RTN","TMGDEBUG",760,0) ;"Input: Line -- The line of text to be written out. "RTN","TMGDEBUG",761,0) ;"Results: none. "RTN","TMGDEBUG",762,0) ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 "RTN","TMGDEBUG",763,0) "RTN","TMGDEBUG",764,0) write line,! "RTN","TMGDEBUG",765,0) quit "RTN","TMGDEBUG",766,0) "RTN","TMGDIA3") 0^9^B1371075 "RTN","TMGDIA3",1,0) TMGDIA3 ;TMG/kst/Custom version of DIA3 ;03/25/06 "RTN","TMGDIA3",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDIA3",3,0) "RTN","TMGDIA3",4,0) "RTN","TMGDIA3",5,0) DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;9/7/94 09:57 "RTN","TMGDIA3",6,0) ;;22.0;VA FileMan;;Mar 30, 1999 "RTN","TMGDIA3",7,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGDIA3",8,0) "RTN","TMGDIA3",9,0) ;"************************************************************************* "RTN","TMGDIA3",10,0) ;"* Custom version of Fileman code, for customization "RTN","TMGDIA3",11,0) ;"* Also includes code from DITP.m "RTN","TMGDIA3",12,0) ;"************************************************************************* "RTN","TMGDIA3",13,0) "RTN","TMGDIA3",14,0) FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) "RTN","TMGDIA3",15,0) ;"Purpose: DELETE OR REPOINT POINTERS "RTN","TMGDIA3",16,0) ;"Note: In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. "RTN","TMGDIA3",17,0) ;"Input: DIFLG="D" (delete) ;" ADDED "R" (replace) //kt "RTN","TMGDIA3",18,0) ;" DIFILE=File# previously pointed to "RTN","TMGDIA3",19,0) ;" DIDELIEN=Record# previously pointed to "RTN","TMGDIA3",20,0) ;" DIPTIEN=New pointed-to record(future) ;"//KT fixed to do now. "RTN","TMGDIA3",21,0) ;" ;"//e.g. if wanting to replace all pointers to file#50, record#20 to record#40 (must be in file#50) "RTN","TMGDIA3",22,0) ;" ;"// then DIFILE=50, DIDELIEN=20, DIPTIEN=40 "RTN","TMGDIA3",23,0) ;"Output: "RTN","TMGDIA3",24,0) ;"Result: none "RTN","TMGDIA3",25,0) "RTN","TMGDIA3",26,0) ;"Note: sample of array passed to P^DITP "RTN","TMGDIA3",27,0) ;" 23510 is $J "RTN","TMGDIA3",28,0) ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) "RTN","TMGDIA3",29,0) ;" 1646 is IEN to be substituted for all 47's "RTN","TMGDIA3",30,0) ;" "RTN","TMGDIA3",31,0) ;" First part of array is list of all files & fields that point to file "RTN","TMGDIA3",32,0) ;" ---------------- "RTN","TMGDIA3",33,0) ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" "RTN","TMGDIA3",34,0) ;" ... "RTN","TMGDIA3",35,0) ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" "RTN","TMGDIA3",36,0) ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" "RTN","TMGDIA3",37,0) ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" "RTN","TMGDIA3",38,0) ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" "RTN","TMGDIA3",39,0) ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" "RTN","TMGDIA3",40,0) ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" "RTN","TMGDIA3",41,0) ;" "RTN","TMGDIA3",42,0) ;" Second part of array is list of changes that should be made. Only 1 change shown here. "RTN","TMGDIA3",43,0) ;" ---------------- "RTN","TMGDIA3",44,0) ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" "RTN","TMGDIA3",45,0) ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" "RTN","TMGDIA3",46,0) "RTN","TMGDIA3",47,0) new %X,%Y,X,Y "RTN","TMGDIA3",48,0) ;"new DIPTIEN ;//kt allow input value to be used. "RTN","TMGDIA3",49,0) new DIFIXPT,DIFIXPTC,DIFIXPTH "RTN","TMGDIA3",50,0) do if $G(X)]"" do BLD^DIALOG(201,X) quit ;"BUILD FILEMAN DIALOG "RTN","TMGDIA3",51,0) . set X="DIFLG" quit:(($G(DIFLG)'="D")&($G(DIFLG)'="R")) ;"//kt added "R" "RTN","TMGDIA3",52,0) . set X="DIDELIEN" Q:'$G(DIDELIEN) "RTN","TMGDIA3",53,0) . set X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" "RTN","TMGDIA3",54,0) . set X="DIPTIEN" "RTN","TMGDIA3",55,0) . if (DIFLG="R"),$G(DIPTIEN) do quit:(Y="") "RTN","TMGDIA3",56,0) . . set Y=$get(^DIC(DIFILE,0,"GL")) ;"//kt changed ^DD to ^DIC "RTN","TMGDIA3",57,0) . . quit:Y="" "RTN","TMGDIA3",58,0) . . if '$data(@(Y_DIPTIEN_",0)")) set Y="" quit "RTN","TMGDIA3",59,0) . kill X "RTN","TMGDIA3",60,0) . quit "RTN","TMGDIA3",61,0) set DIPTIEN=+$G(DIPTIEN) "RTN","TMGDIA3",62,0) set (DIFIXPT,DIFIXPTC)=1 "RTN","TMGDIA3",63,0) new %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z "RTN","TMGDIA3",64,0) kill ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J) "RTN","TMGDIA3",65,0) set (DIFILE,DIA("P"),Y)=+DIFILE "RTN","TMGDIA3",66,0) set (DIA,DTO)=^DIC(DIFILE,0,"GL") "RTN","TMGDIA3",67,0) set DIA(1)=DIDELIEN "RTN","TMGDIA3",68,0) do PTS^DIT "RTN","TMGDIA3",69,0) set ^UTILITY("DIT",$J,0)=0 "RTN","TMGDIA3",70,0) goto:$D(^(0))<9 QFIXPT "RTN","TMGDIA3",71,0) set ^UTILITY("DIT",$J,DIA(1))=DIPTIEN_";"_$E(DIA,2,999) "RTN","TMGDIA3",72,0) set ^UTILITY("DIT",$J,DIA(1)_";"_$E(DIA,2,999))=DIPTIEN_";"_$E(DIA,2,999) "RTN","TMGDIA3",73,0) "RTN","TMGDIA3",74,0) zwr ^UTILITY("DIT",$J,*) "RTN","TMGDIA3",75,0) ;"do P^DITP "RTN","TMGDIA3",76,0) ;"do P "RTN","TMGDIA3",77,0) "RTN","TMGDIA3",78,0) QFIXPT "RTN","TMGDIA3",79,0) K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN "RTN","TMGDIA3",80,0) quit "RTN","TMGDIA3",81,0) ; "RTN","TMGDIA3",82,0) "RTN","TMGDIA3",83,0) ;"************************************************************************* "RTN","TMGDIA3",84,0) ;"* Code below from DITP.m "RTN","TMGDIA3",85,0) ;"************************************************************************* "RTN","TMGDIA3",86,0) "RTN","TMGDIA3",87,0) PTS ; "RTN","TMGDIA3",88,0) D WAIT^DICD "RTN","TMGDIA3",89,0) kill IOP "RTN","TMGDIA3",90,0) P kill DR,D,DL,X "RTN","TMGDIA3",91,0) set (BY,FR,TO)="" "RTN","TMGDIA3",92,0) set X=$O(^UTILITY("DIT",$J,0,0)) "RTN","TMGDIA3",93,0) if X="" do quit ;"<--- exit point from loop "RTN","TMGDIA3",94,0) . K ^UTILITY("DIT",$J),DIA,DHD,DR,DISTOP,BY,TO,FR,FLDS,L "RTN","TMGDIA3",95,0) set Y=^(X) ;"get value of entry e.g. 50^905^P50'X "RTN","TMGDIA3",96,0) set L=$P(Y,U,2) ;"L= field# "RTN","TMGDIA3",97,0) set DL=1 "RTN","TMGDIA3",98,0) set DL(1)=L "RTN","TMGDIA3",99,0) set DL(1)=DL(1)_"////^S X=$S($D(DE(DQ))[0:"""",$D(^UTILITY(""DIT"",$J,DE(DQ)))-1:"""",^(DE(DQ)):" "RTN","TMGDIA3",100,0) set DL(1)=DL(1)_$S($P(Y,U,3)'["V":"+",1:"") "RTN","TMGDIA3",101,0) set DL(1)=DL(1)_"^(DE(DQ)),1:""@"") I X]"""",$G(DIFIXPT)=1 D PTRPT^TMGDIA3" "RTN","TMGDIA3",102,0) kill ^(X) ;"delete entry from top of list "RTN","TMGDIA3",103,0) set L=$P(^DD(+Y,L,0),U,4) ;"+Y=File#, L=Field# --> L set to 4th piece of data dictionary entry, e.g. '8;6' "RTN","TMGDIA3",104,0) set %=$P(L,";",2) ;"e.g. %=6 "RTN","TMGDIA3",105,0) set L=""""_$P(L,";",1)_"""" ;"e.g. L="8" "RTN","TMGDIA3",106,0) set DHD=$P(^(0),U) ;"DHD--> header for EN1^DIP "RTN","TMGDIA3",107,0) if % set %="$P(^("_L_"),U,"_% ;"--> e.g. set %='$P(^(8),U,8 "RTN","TMGDIA3",108,0) else set %="$E(^("_L_"),"_+$E(%,2,9)_","_$P(%,",",2) "RTN","TMGDIA3",109,0) set L=L_")):"""","_%_")?."" "":"""",'$D(^UTILITY(""DIT"",$J,"_$S($P(Y,U,3)'["V":"+",1:"")_%_"))):"""",1:D" "RTN","TMGDIA3",110,0) UP set D(DL)=+Y ;"+Y = File# "RTN","TMGDIA3",111,0) set %=+Y ;"+Y = File# "RTN","TMGDIA3",112,0) if $D(^DD(%,0,"UP")) do goto UP "RTN","TMGDIA3",113,0) . set DL=DL+1 "RTN","TMGDIA3",114,0) . set Y=^("UP") "RTN","TMGDIA3",115,0) . set (DL(DL),%)=$O(^DD(Y,"SB",%,0))_"///" "RTN","TMGDIA3",116,0) . set X(DL)=""""_$P($P(^DD(Y,+%,0),U,4),";")_"""" "RTN","TMGDIA3",117,0) . set BY=+%_","_BY "RTN","TMGDIA3",118,0) set DHD=$O(^("NM",0))_" entries whose '"_DHD_"' pointers have been changed" "RTN","TMGDIA3",119,0) if '$D(^DIC(%,0,"GL")) goto P "RTN","TMGDIA3",120,0) set DIC=^("GL") "RTN","TMGDIA3",121,0) set Y="S X=$S('$D("_DIC_"D0," "RTN","TMGDIA3",122,0) for X=0:1:DL-1 do "RTN","TMGDIA3",123,0) . set DR(X+1,D(DL-X))=DL(DL-X) "RTN","TMGDIA3",124,0) . if X set Y=Y_X(DL+1-X)_",D"_X_"," "RTN","TMGDIA3",125,0) set DIA("P")=% "RTN","TMGDIA3",126,0) set %=$L(BY,",") "RTN","TMGDIA3",127,0) if %>2 set BY=$P(BY,",",%-2)_",.01,"_BY "RTN","TMGDIA3",128,0) set BY=BY_Y_L_X_")" "RTN","TMGDIA3",129,0) set L=0 "RTN","TMGDIA3",130,0) set FLDS="" "RTN","TMGDIA3",131,0) set DISTOP=0 "RTN","TMGDIA3",132,0) set DHIT="G LOOP^DIA2" "RTN","TMGDIA3",133,0) set %ZIS="" "RTN","TMGDIA3",134,0) do EN1^DIP "RTN","TMGDIA3",135,0) if $G(DIFIXPT)=1 goto P "RTN","TMGDIA3",136,0) set IOP=$G(IO) "RTN","TMGDIA3",137,0) goto P "RTN","TMGDIA3",138,0) ; "RTN","TMGDIA3",139,0) "RTN","TMGDIA3",140,0) PTRPT "RTN","TMGDIA3",141,0) quit:'$G(DIFIXPTC) "RTN","TMGDIA3",142,0) new I,J,X "RTN","TMGDIA3",143,0) for I=1:1:DL do "RTN","TMGDIA3",144,0) . set J="" "RTN","TMGDIA3",145,0) . for set J=$order(DR(I,J)) quit:J="" do "RTN","TMGDIA3",146,0) . . if DR(I,J)["///" do "RTN","TMGDIA3",147,0) . . . set X=$P($G(DR(I,J)),"///",1) "RTN","TMGDIA3",148,0) . . . if X]"" do "RTN","TMGDIA3",149,0) . . . . new s "RTN","TMGDIA3",150,0) . . . . set s=^TMP("DIFIXPT",$J,DIFIXPTC) "RTN","TMGDIA3",151,0) . . . . set s=s_$S(I>1:" entry:"_$S(I=DL:$G(DA),1:$G(DA(DL-I))),1:"") "RTN","TMGDIA3",152,0) . . . . set s=s_$S(I=DL:" field:",1:" mult.fld:") "RTN","TMGDIA3",153,0) . . . . set s=s_X "RTN","TMGDIA3",154,0) . . . . set ^TMP("DIFIXPT",$J,DIFIXPTC)=s "RTN","TMGDIA3",155,0) Q "RTN","TMGDIA3",156,0) "RTN","TMGDIS") 0^10^B118560815 "RTN","TMGDIS",1,0) TMGDIS ;TMG/kst/Custom version of DIS ;03/25/06 "RTN","TMGDIS",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDIS",3,0) "RTN","TMGDIS",4,0) "RTN","TMGDIS",5,0) DIS ;"SFISC/GFT-GATHER SEARCH CRITERIA ;05:52 PM 27 Mar 2002 "RTN","TMGDIS",6,0) ;";22.0;VA FileMan;**6,97**;Mar 30, 1999 "RTN","TMGDIS",7,0) ;"Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGDIS",8,0) ;" "RTN","TMGDIS",9,0) ;"Purpose: to GATHER SEARCH CRITERIA "RTN","TMGDIS",10,0) ;" "RTN","TMGDIS",11,0) kill ^UTILITY($J) "RTN","TMGDIS",12,0) kill DC "RTN","TMGDIS",13,0) ;"Note: Stores coded search values "RTN","TMGDIS",14,0) ;"Example "RTN","TMGDIS",15,0) ;"DC(1)="14,.01^=105" <-- field 14, sub field .01 '=' IEN 105 (in pointed to file) "RTN","TMGDIS",16,0) ;"DC(2)="14,2^=44" <-- field 14, sub field 2 '=' IEN 44 (in pointed to file) "RTN","TMGDIS",17,0) ;" "RTN","TMGDIS",18,0) ;"Example "RTN","TMGDIS",19,0) ;"DC(1)="14,-1^[""ACETA""" <-- field 14 is a multiple, '-' --> ? 1 is field '[' ACETA "RTN","TMGDIS",20,0) ;"DC(2)="14,-2^[""%""" <-- field 14 is a multiple, '-' --> ? 2 is field '[' % "RTN","TMGDIS",21,0) ;" "RTN","TMGDIS",22,0) ;"Example "RTN","TMGDIS",23,0) ;"DC=6 "RTN","TMGDIS",24,0) ;"DC(1) = 14,.01^=105 <-- field 14, sub field .01 '=' IEN 105 (in pointed to file) "RTN","TMGDIS",25,0) ;"DC(2) = 14,-2^["%" <-- field 14 is a multiple, '-' --> ? 2 is field '[' % "RTN","TMGDIS",26,0) ;" note field 2 is a pointer, so perhaps '-' means non-exact match "RTN","TMGDIS",27,0) ;"DC(3) = 14,1^["1" <-- field 14 is a multiple, 1 is field '[' ACETA "RTN","TMGDIS",28,0) ;" note field 1 is free text, so perhaps '-' not needed "RTN","TMGDIS",29,0) ;"DC(4) = 1^=211 <-- field 1 '=' IEN 211 "RTN","TMGDIS",30,0) ;"DC(5) = .01^["A" <-- field .01 '[' A "RTN","TMGDIS",31,0) ;"Values of O with above example "RTN","TMGDIS",32,0) ;"O=0 "RTN","TMGDIS",33,0) ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN "RTN","TMGDIS",34,0) ;"O(2) = VA PRODUCT UNITS CONTAINS "%" "RTN","TMGDIS",35,0) ;"O(3) = VA PRODUCT STRENGTH CONTAINS "1" "RTN","TMGDIS",36,0) ;"O(4) = DOSAGE FORM EQUALS 211^BAG "RTN","TMGDIS",37,0) ;"O(5) = NAME CONTAINS "A" "RTN","TMGDIS",38,0) "RTN","TMGDIS",39,0) kill DIS,%ZIS "RTN","TMGDIS",40,0) kill O ;"Note: Stores file & field names and values to search for ('Oh', not 'zero') "RTN","TMGDIS",41,0) ;"Example: "RTN","TMGDIS",42,0) ;"O=0 "RTN","TMGDIS",43,0) ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "ACETAMINOPHEN" "RTN","TMGDIS",44,0) ;"O(2) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "CAFF" "RTN","TMGDIS",45,0) ;"O(3) = VA GENERIC NAME CONTAINS "A" "RTN","TMGDIS",46,0) ;"Note: "RTN","TMGDIS",47,0) ;" Each node (i.e. (1),(2) etc) contains a separate search item. "RTN","TMGDIS",48,0) ;" "RTN","TMGDIS",49,0) ;"Another example "RTN","TMGDIS",50,0) ;"O="EQUALS" "RTN","TMGDIS",51,0) ;"O(1)="VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN" "RTN","TMGDIS",52,0) ;"O(2)="VA PRODUCT UNITS EQUALS 44^%" "RTN","TMGDIS",53,0) ;" "RTN","TMGDIS",54,0) ;"Note: "RTN","TMGDIS",55,0) ;" In above examples, "RTN","TMGDIS",56,0) ;" O(1) --> VA PRODUCT is file name, ACTIVE INGREDIENTS is .01 field "RTN","TMGDIS",57,0) ;" of ACTIVE INGREDIENTS multiple "RTN","TMGDIS",58,0) ;" 105 is IEN of ACETAMINOPHEN "RTN","TMGDIS",59,0) ;" EQUALS is chosen comparator "RTN","TMGDIS",60,0) ;" O(2)--> VA PRODUCT is file name, UNITS is field 2 of ACTIVE INGREDIENTS multiple "RTN","TMGDIS",61,0) ;" 44 is IEN of unit '%' "RTN","TMGDIS",62,0) ;" EQUALS is chosen comparator "RTN","TMGDIS",63,0) ;" The value in O (e.g. 'EQUALS') is later killed, so not used in actual search. "RTN","TMGDIS",64,0) "RTN","TMGDIS",65,0) kill N,R "RTN","TMGDIS",66,0) do ^DICRW ;"get file to search in, return global open ref in DIC "RTN","TMGDIS",67,0) if '$data(DIC)!$data(DTOUT) goto Q "RTN","TMGDIS",68,0) EN ; "RTN","TMGDIS",69,0) if DIC set DIC=$G(^DIC(DIC,0,"GL")) "RTN","TMGDIS",70,0) if DIC="" quit "RTN","TMGDIS",71,0) kill DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J) "RTN","TMGDIS",72,0) if '$data(@(DIC_"0)")) goto Q "RTN","TMGDIS",73,0) set (R,DI,I(0))=DIC "RTN","TMGDIS",74,0) set DL=1 ;"DL=indent amount from left margin. "RTN","TMGDIS",75,0) set DC=1 ;"DC=search element i.e. 1=A,2=B,3=C etc. "RTN","TMGDIS",76,0) set DY=999 "RTN","TMGDIS",77,0) set N=0 "RTN","TMGDIS",78,0) set Q="""" "RTN","TMGDIS",79,0) set DV="" "RTN","TMGDIS",80,0) R ; "RTN","TMGDIS",81,0) ;"set J(N) and DK<--file NUMBER, R<--file NAME "RTN","TMGDIS",82,0) if +R=R set (J(N),DK)=R,R="" "RTN","TMGDIS",83,0) else set @("(J(N),DK)=+$piece("_R_"0),U,2)"),R=$piece(^(0),U) "RTN","TMGDIS",84,0) F ; "RTN","TMGDIS",85,0) if DC>58 goto UP "RTN","TMGDIS",86,0) write ! "RTN","TMGDIS",87,0) kill X,DIC,P "RTN","TMGDIS",88,0) do W ;"Write label to screen line -A-, or -B- etc. "RTN","TMGDIS",89,0) set DIC(0)="EZ" "RTN","TMGDIS",90,0) set C="," "RTN","TMGDIS",91,0) set DIC="^DD("_DK_C "RTN","TMGDIS",92,0) set DIC("W")="SET %=$PIECE(^(0),U,2) WRITE:% $SELECT($PIECE(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" "RTN","TMGDIS",93,0) set DIC("S")="IF $PIECE(^(0),U,2)'[""m"""_$select($data(DICS):" "_DICS,1:""),DU="" "RTN","TMGDIS",94,0) write "SEARCH FOR "_R_" "_$piece(^DD(DK,0),U)_": " "RTN","TMGDIS",95,0) read X:DTIME ;"ask user for filed to search in, from specified file "RTN","TMGDIS",96,0) set:'$T DTOUT=1 "RTN","TMGDIS",97,0) if X=U!'$T goto Q "RTN","TMGDIS",98,0) if X?1"[".E goto TEM^TMGDIS2 "RTN","TMGDIS",99,0) do "RTN","TMGDIS",100,0) . new DISVX "RTN","TMGDIS",101,0) . set DISVX=X "RTN","TMGDIS",102,0) . do ^DIC ;"search for field, based on user input. "RTN","TMGDIS",103,0) . if Y=-1 set X=DISVX "RTN","TMGDIS",104,0) if '(Y>0) goto HARD "RTN","TMGDIS",105,0) kill P "RTN","TMGDIS",106,0) set DE=Y(0) "RTN","TMGDIS",107,0) set O(DC)=$piece(DE,U) "RTN","TMGDIS",108,0) set DU=+Y ;"DU = field number "RTN","TMGDIS",109,0) set Z=$piece(DE,U,3) ;"pointers or set data "RTN","TMGDIS",110,0) set E=$piece(DE,U,2) ;"field info codes, poss with subfile # "RTN","TMGDIS",111,0) goto G "RTN","TMGDIS",112,0) "RTN","TMGDIS",113,0) ;"========================================== "RTN","TMGDIS",114,0) HARD if X="" goto UP "RTN","TMGDIS",115,0) if X?."?" goto F "RTN","TMGDIS",116,0) if X=U!($data(DTOUT)) goto Q "RTN","TMGDIS",117,0) goto COMP^TMGDIS2 "RTN","TMGDIS",118,0) quit "RTN","TMGDIS",119,0) "RTN","TMGDIS",120,0) ;"========================================== "RTN","TMGDIS",121,0) G ; "RTN","TMGDIS",122,0) kill X,DIC "RTN","TMGDIS",123,0) set DIC="^DOPT(""DIS""," ;"file containing "equals","contains","greater than" etc. "RTN","TMGDIS",124,0) set DIC(0)="QEZ" "RTN","TMGDIS",125,0) if E["B" set X="" goto OK ;"'B'->field is a BOOLEAN COMPUTED field, so skip "RTN","TMGDIS",126,0) if 'E goto G2KT "RTN","TMGDIS",127,0) set N(DL)=N "RTN","TMGDIS",128,0) set N=N+1 "RTN","TMGDIS",129,0) set DV(DL)=DV "RTN","TMGDIS",130,0) set DL(DL)=DK "RTN","TMGDIS",131,0) set DK=+E "RTN","TMGDIS",132,0) set J(N)=DK "RTN","TMGDIS",133,0) set X=$piece($piece(DE,U,4),";") ;"4th piece of 0 node holds storage location "RTN","TMGDIS",134,0) set I(N)=$select(+X=X:X,1:""""_X_"""") "RTN","TMGDIS",135,0) set Y(0)=^DD(DK,.01,0) "RTN","TMGDIS",136,0) set DL=DL+1 ;"indent further "RTN","TMGDIS",137,0) goto WP:$piece(Y(0),U,2)["W" "RTN","TMGDIS",138,0) set DV=DV_+Y_"," "RTN","TMGDIS",139,0) goto F ;"loop back to get more field info. "RTN","TMGDIS",140,0) ;" "RTN","TMGDIS",141,0) G2KT if E["P" set P=+Y_U_Y(0),X="(#"_+Y_")" goto HARD "RTN","TMGDIS",142,0) C do W ;"Write label to screen line -A-, or -B- etc. "RTN","TMGDIS",143,0) read "CONDITION: ",X:DTIME "RTN","TMGDIS",144,0) set:'$T DTOUT=1 "RTN","TMGDIS",145,0) if X[U!'$T goto Q "RTN","TMGDIS",146,0) set DN=$select("'-"[$E(X):"'",1:"") ;"if NOT logic, DN="'" "RTN","TMGDIS",147,0) set X=$E(X,DN]""+1,99) ;"remove 'NOT' symbol, if present "RTN","TMGDIS",148,0) do ^DIC "RTN","TMGDIS",149,0) if Y<0 goto Q:X[U goto B:X="" goto DISCDIQQQ:X["?" goto C "RTN","TMGDIS",150,0) set O=$piece("NOT ",U,DN]"")_$piece(Y,U,2) "RTN","TMGDIS",151,0) if +Y=1 set X=DN_"?."" """ set O(DC)=O(DC)_" "_O goto OK "RTN","TMGDIS",152,0) set DQ=Y "RTN","TMGDIS",153,0) do W ;"Write label to screen line -A-, or -B- etc. "RTN","TMGDIS",154,0) write O "RTN","TMGDIS",155,0) if '((E["D")&(Y-3)) goto TMG1 "RTN","TMGDIS",156,0) read " DATE: ",X:DTIME "RTN","TMGDIS",157,0) set:'$T DTOUT=1 "RTN","TMGDIS",158,0) if X=U!'$T goto Q "RTN","TMGDIS",159,0) set %DT="TE" "RTN","TMGDIS",160,0) do ^%DT "RTN","TMGDIS",161,0) set X=Y_U_X "RTN","TMGDIS",162,0) if Y<0 goto X "RTN","TMGDIS",163,0) xecute ^DD("DD") "RTN","TMGDIS",164,0) set Y=X_U_Y "RTN","TMGDIS",165,0) goto GOT "RTN","TMGDIS",166,0) ; "RTN","TMGDIS",167,0) TMG1 ;"POINTERS "RTN","TMGDIS",168,0) PT if $data(P),+DQ=5 do goto Q:U[X!'$T do ^DIC goto GOT:Y>0,PT "RTN","TMGDIS",169,0) . kill DIC,DIS($char(DC+64)_DL) "RTN","TMGDIS",170,0) . set DIC=U_$piece(P,U,4) "RTN","TMGDIS",171,0) . set DIC(0)="EMQ" "RTN","TMGDIS",172,0) . set DU=+P "RTN","TMGDIS",173,0) . write " "_$piece(@(DIC_"0)"),U)_": " "RTN","TMGDIS",174,0) . read X:DTIME "RTN","TMGDIS",175,0) . set:'$T DTOUT=1 "RTN","TMGDIS",176,0) read ": ",Y:DTIME "RTN","TMGDIS",177,0) if '$T set DTOUT=1 goto Q "RTN","TMGDIS",178,0) goto X:Y="" "RTN","TMGDIS",179,0) if Y[U,$piece(DE,U,4)'[";E" goto Q "RTN","TMGDIS",180,0) if +DQ=3 set X="I X?"_Y do ^DIM goto GOT:$data(X) set Y="?" "RTN","TMGDIS",181,0) goto DISDIQQQ:Y?."?" "RTN","TMGDIS",182,0) SET if E["S" do if '$data(X) kill DIS(U,DC) goto DISDIQQQ "RTN","TMGDIS",183,0) . if +DQ=5!(Y["""") do kill:D="" X quit "RTN","TMGDIS",184,0) . . set Y=":"_Y "RTN","TMGDIS",185,0) . . new TMGQUIT set TMGQUIT=0 "RTN","TMGDIS",186,0) . . ;"for X=1:1 do if D[Y write $piece(D,Y,2,9) set Y=$piece(D,":")_U_$piece(D,":",2) Q "RTN","TMGDIS",187,0) . . for X=1:1 do quit:TMGQUIT=1 "RTN","TMGDIS",188,0) . . . set D=$piece(Z,";",X) "RTN","TMGDIS",189,0) . . . if D="" set TMGQUIT=1 quit "RTN","TMGDIS",190,0) . . . if D[Y do "RTN","TMGDIS",191,0) . . . . write $piece(D,Y,2,9) "RTN","TMGDIS",192,0) . . . . set Y=$piece(D,":")_U_$piece(D,":",2) "RTN","TMGDIS",193,0) . . . . set TMGQUIT=1 "RTN","TMGDIS",194,0) N . new N,%,C "RTN","TMGDIS",195,0) . write !?7 "RTN","TMGDIS",196,0) . set N="DE"_DN_$E(" [?<=>",DQ)_""""_Y_"""" "RTN","TMGDIS",197,0) . new TMGQUIT set TMGQUIT=0 "RTN","TMGDIS",198,0) . for X=1:1 do quit:TMGQUIT=1 "RTN","TMGDIS",199,0) . . set D=$piece(Z,";",X) "RTN","TMGDIS",200,0) . . set DE=$piece(D,":",2) "RTN","TMGDIS",201,0) . . if D="" set TMGQUIT=1 "RTN","TMGDIS",202,0) . . set DIS(U,DC,$piece(D,":"))=DE "RTN","TMGDIS",203,0) . . if @N do "RTN","TMGDIS",204,0) . . . set:'$data(%) %="[ Will match" "RTN","TMGDIS",205,0) . . . write % "RTN","TMGDIS",206,0) . . . set C=$G(C)+1 "RTN","TMGDIS",207,0) . . . set %="'"_DE_"'" "RTN","TMGDIS",208,0) . . . write:C>1 "," "RTN","TMGDIS",209,0) . . . write " " "RTN","TMGDIS",210,0) . . . write:$X+$L(%)>73 !?7 "RTN","TMGDIS",211,0) . if '$data(%) kill X Q "RTN","TMGDIS",212,0) . write:C>1 "and " "RTN","TMGDIS",213,0) . write %_" ]" "RTN","TMGDIS",214,0) T if DQ["THAN",+$piece(Y,U)'=$piece(Y,U) goto X "RTN","TMGDIS",215,0) QUOTE if DQ#3=2 do ;"Equals or Contains "RTN","TMGDIS",216,0) . write:$piece(Y,U)[""""&($L($piece(Y,U))>1) " (Your answer includes quotes)" "RTN","TMGDIS",217,0) . set $piece(Y,U)=""""_$$CONVQQ^DILIBF($piece(Y,U))_"""" "RTN","TMGDIS",218,0) . if $piece(Y,U)?.E2A.E do "RTN","TMGDIS",219,0) . . set DIS("XFORM",DC)="$$UP^DILIBF(;)" "RTN","TMGDIS",220,0) . . set O=O_" (case-insensitive)" "RTN","TMGDIS",221,0) . . set $piece(Y,U)=$$UP^DILIBF($piece(Y,U)) "RTN","TMGDIS",222,0) GOT set X=DN_$E(" [?<=>",DQ)_$piece(Y,U) "RTN","TMGDIS",223,0) if E["D" do "RTN","TMGDIS",224,0) . set Y=$piece(Y,U,3)_U_$piece(Y,U,2) "RTN","TMGDIS",225,0) . if $piece(Y,U)'["." do "RTN","TMGDIS",226,0) . . set %=$piece("^^^^ any time during^ the entire day",U,DQ) "RTN","TMGDIS",227,0) . . if %]"" do "RTN","TMGDIS",228,0) . . . set DIS("XFORM",DC)="$piece(;,""."")" "RTN","TMGDIS",229,0) . . . set O=O_% "RTN","TMGDIS",230,0) set O(DC)=O(DC)_" "_O_" "_Y "RTN","TMGDIS",231,0) OK set DC(DC)=DV_DU_U_X "RTN","TMGDIS",232,0) set %=DL-1_U_(N#100) "RTN","TMGDIS",233,0) if DL>1,O(DC)'[R set O(DC)=R_" "_O(DC) "RTN","TMGDIS",234,0) if DU["W" set %=DL-2_U_(N#100-1) "RTN","TMGDIS",235,0) set DX(DC)=% "RTN","TMGDIS",236,0) set DC=DC+1 ;"Inc logical part (i.e. 'A'->'B'->'C'->D) "RTN","TMGDIS",237,0) if DC=27 set DC=33 "RTN","TMGDIS",238,0) B goto F:(DU'["W"&(DC<59)) "RTN","TMGDIS",239,0) UP if '(DC>1) goto Q "RTN","TMGDIS",240,0) if DL<$select('$data(DIARF0):2,1:2) goto ^TMGDIS0 ;"done with entering conditions "RTN","TMGDIS",241,0) set DL=DL-1 "RTN","TMGDIS",242,0) set DV=DV(DL) "RTN","TMGDIS",243,0) set DK=DL(DL) "RTN","TMGDIS",244,0) set N=N(DL) "RTN","TMGDIS",245,0) set R=$select($data(R(DL)):R(DL),1:R) "RTN","TMGDIS",246,0) kill R(DL) "RTN","TMGDIS",247,0) set %=N "RTN","TMGDIS",248,0) for set %=$O(I(%)) set:%="" %=-1 goto F:%<0 kill I(%),J(%) "RTN","TMGDIS",249,0) for do if %<0 goto F "RTN","TMGDIS",250,0) . set %=$O(I(%)) "RTN","TMGDIS",251,0) . if %="" set %=-1 "RTN","TMGDIS",252,0) . if %<0 quit "RTN","TMGDIS",253,0) . kill I(%),J(%) "RTN","TMGDIS",254,0) Q if '$data(DIARU) goto Q^TMGDIS2 "RTN","TMGDIS",255,0) goto ^TMGDIS2 "RTN","TMGDIS",256,0) "RTN","TMGDIS",257,0) ;"========================================== "RTN","TMGDIS",258,0) WP set DIC("S")="if Y<3" "RTN","TMGDIS",259,0) set DU=+Y_"W" "RTN","TMGDIS",260,0) goto C "RTN","TMGDIS",261,0) "RTN","TMGDIS",262,0) ;"========================================== "RTN","TMGDIS",263,0) X ; "RTN","TMGDIS",264,0) write $char(7),"??",!! "RTN","TMGDIS",265,0) goto B "RTN","TMGDIS",266,0) "RTN","TMGDIS",267,0) ;"========================================== "RTN","TMGDIS",268,0) W write !?DL*2,"-"_$char(DC+64)_"- " "RTN","TMGDIS",269,0) quit "RTN","TMGDIS",270,0) "RTN","TMGDIS",271,0) ;"========================================== "RTN","TMGDIS",272,0) ENS ;" ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE "RTN","TMGDIS",273,0) goto EN^DIS3 "RTN","TMGDIS",274,0) "RTN","TMGDIS",275,0) "RTN","TMGDIS",276,0) "RTN","TMGDIS",277,0) ;" --- COPIED FROM DIQQQ.M to allow goto to return to this file, not ^DIS. "RTN","TMGDIS",278,0) DISDIQQQ ; "RTN","TMGDIS",279,0) write !?8,"ENTER A VALUE WHICH '"_O(DC)_"'" "RTN","TMGDIS",280,0) write !?8,"MUST "_$P("NOT ",U,DN]"") "RTN","TMGDIS",281,0) write $piece("^CONTAIN^MATCH^BE LESS THAN^EQUAL^EXCEED^FOLLOW",U,+DQ) "RTN","TMGDIS",282,0) write ", IN ORDER FOR TRUTH CONDITION -"_$char(DC+64)_"- TO BE TRUE",! "RTN","TMGDIS",283,0) write:+DQ=3 ?8,"(I.E., ENTER WHAT WOULD FOLLOW THE MUMPS '?' OPERATOR)",! "RTN","TMGDIS",284,0) if E["S" write !,"Use EXTERNAL VALUE (from list on the right)" D EN^DIQQ1(DK,DU,"?") "RTN","TMGDIS",285,0) write ! "RTN","TMGDIS",286,0) goto F "RTN","TMGDIS",287,0) "RTN","TMGDIS",288,0) ;" --- COPIED FROM DIQQQ.M to allow goto to return to this file, not ^DIS "RTN","TMGDIS",289,0) DISCDIQQ ; "RTN","TMGDIS",290,0) write !,"YOU CAN NEGATE ANY OF THESE CONDITIONS BY PRECEDING THEM WITH ""'"" OR ""-""" "RTN","TMGDIS",291,0) write !,"SO THAT ""'NULL'"" MEANS ""NOT NULL""",! "RTN","TMGDIS",292,0) goto C "RTN","TMGDIS",293,0) ; "RTN","TMGDIS",294,0) "RTN","TMGDIS0") 0^11^B39243874 "RTN","TMGDIS0",1,0) TMGDIS0 ;TMG/kst/Custom version of DIS0 ;03/25/06 "RTN","TMGDIS0",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDIS0",3,0) "RTN","TMGDIS0",4,0) "RTN","TMGDIS0",5,0) "RTN","TMGDIS0",6,0) DIS0 ;SFISC/GFT-SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;2/24/93 13:51 "RTN","TMGDIS0",7,0) ;;22.0;VA FileMan;;Mar 30, 1999 "RTN","TMGDIS0",8,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGDIS0",9,0) ; "RTN","TMGDIS0",10,0) ;"Purpose: to SEARCH, IF STATEMENT AND MULTIPLE COMBO'S "RTN","TMGDIS0",11,0) ;" i.e. determine combination of search terms, logic etc. "RTN","TMGDIS0",12,0) "RTN","TMGDIS0",13,0) ;"Note: At this point, user query for search conditions has been completed "RTN","TMGDIS0",14,0) ;"There are no calls back to ^DIS (from this module) "RTN","TMGDIS0",15,0) ;" ^DIS2 does go back to ^DIS "RTN","TMGDIS0",16,0) ;"From this module, the program execution flow will go to ^DIS1 "RTN","TMGDIS0",17,0) "RTN","TMGDIS0",18,0) write ! "RTN","TMGDIS0",19,0) "RTN","TMGDIS0",20,0) ;"See format description in TMGDIS.m "RTN","TMGDIS0",21,0) write !,"here is 'O'",! ;"//kt temp "RTN","TMGDIS0",22,0) zwr O(*) ;"//kt temp "RTN","TMGDIS0",23,0) write !,"here is 'DC'",! ;"//kt temp "RTN","TMGDIS0",24,0) zwr DC(*) ;"//kt temp "RTN","TMGDIS0",25,0) w !!;"//kt temp "RTN","TMGDIS0",26,0) "RTN","TMGDIS0",27,0) kill R,N,DL,DE,DJ "RTN","TMGDIS0",28,0) set O=0 "RTN","TMGDIS0",29,0) set E=$data(DC(2)) ;"E=1 if multiple search times, other with 0 "RTN","TMGDIS0",30,0) set N="IF: A// " "RTN","TMGDIS0",31,0) set DE=$select(E:"IF: ",1:N) "RTN","TMGDIS0",32,0) set DL=0 "RTN","TMGDIS0",33,0) set C="," "RTN","TMGDIS0",34,0) R write !,DE "RTN","TMGDIS0",35,0) kill DV "RTN","TMGDIS0",36,0) read X:DTIME ;"query user for logic search, e.g. 'A&B&C' "RTN","TMGDIS0",37,0) set:'$T DTOUT=1 "RTN","TMGDIS0",38,0) goto Q:X[U!'$T ;"quit if ^ or timeout. "RTN","TMGDIS0",39,0) if X="" do goto 1:DL goto BAD:E goto L "RTN","TMGDIS0",40,0) . set DV=1,DU=X "RTN","TMGDIS0",41,0) . quit:DL "RTN","TMGDIS0",42,0) . set DQ="TYPE '^' TO EXIT" "RTN","TMGDIS0",43,0) . set Y="^1^" "RTN","TMGDIS0",44,0) . set DL=1 "RTN","TMGDIS0",45,0) . quit:E ;"don't do ASKQ if multiple logic items, goto 1 "RTN","TMGDIS0",46,0) . do ASKQ "RTN","TMGDIS0",47,0) set Y=U "RTN","TMGDIS0",48,0) set P=0 "RTN","TMGDIS0",49,0) set DU="" "RTN","TMGDIS0",50,0) set D="" "RTN","TMGDIS0",51,0) set DL=DL+1 "RTN","TMGDIS0",52,0) P set P=P+1 "RTN","TMGDIS0",53,0) set DQ=$E(X,P) ;"DQ is parsed logic term (e.g. 'A', or '&', or 'B' etc.) "RTN","TMGDIS0",54,0) if DQ="" goto BAD:Y=U,L "RTN","TMGDIS0",55,0) if DQ?.A set DV=$A(DQ)-64 if $data(DC(DV)) do ASKQ goto CHK ;"end of CHK loops back to P "RTN","TMGDIS0",56,0) goto P:"&+ "[DQ "RTN","TMGDIS0",57,0) if DU="","'-"[DQ set DU="'" goto P "RTN","TMGDIS0",58,0) BAD write $char(7)," <",DQ,">??" "RTN","TMGDIS0",59,0) kill DJ(DL),DE(DL) "RTN","TMGDIS0",60,0) set DL=DL-1 "RTN","TMGDIS0",61,0) goto R "RTN","TMGDIS0",62,0) "RTN","TMGDIS0",63,0) ;"========================================== "RTN","TMGDIS0",64,0) ASKQ set J=DC(DV) "RTN","TMGDIS0",65,0) set %=J["?."" """ "RTN","TMGDIS0",66,0) set I=J["^'"+(DU["'")#2 "RTN","TMGDIS0",67,0) if J["W^" do quit "RTN","TMGDIS0",68,0) . set DV(DV)=$select(I:2-%,1:%+%+1) "RTN","TMGDIS0",69,0) . S:% DC(DV)=$E(J,1,$length(J)-5)_"=""""" "RTN","TMGDIS0",70,0) . quit "RTN","TMGDIS0",71,0) set:$piece(J,U,1)[C DV(DV)=J?.E1",.01^".E&%+(I+%#2) "RTN","TMGDIS0",72,0) quit "RTN","TMGDIS0",73,0) "RTN","TMGDIS0",74,0) ;"========================================== "RTN","TMGDIS0",75,0) CHK set %=$F(Y,U_DV) "RTN","TMGDIS0",76,0) if % do goto BAD "RTN","TMGDIS0",77,0) . set %=$piece($E(Y,%),U,1)'=DU "RTN","TMGDIS0",78,0) . set DQ=""""_DQ_""" AND """_$E("'",%)_DQ_""" IS "_$piece("REDUNDANT^CONTRADICTORY",U,%+1) "RTN","TMGDIS0",79,0) set %=1 "RTN","TMGDIS0",80,0) set Y=Y_DV_DU_U "RTN","TMGDIS0",81,0) set DU="" "RTN","TMGDIS0",82,0) set J=$piece(DC(DV),U,1) "RTN","TMGDIS0",83,0) goto P:J'[C "RTN","TMGDIS0",84,0) for Z=2:1 if $piece(J,C,Z,99)'[C set J=$piece(J,C,1,Z-1)_C Q "RTN","TMGDIS0",85,0) if J=D do "RTN","TMGDIS0",86,0) . do SAMEQ "RTN","TMGDIS0",87,0) . S:%=1 DJ(DL,DV)=DX(DV) "RTN","TMGDIS0",88,0) set D=J "RTN","TMGDIS0",89,0) set DJ=DV "RTN","TMGDIS0",90,0) goto P:%>0 "RTN","TMGDIS0",91,0) "RTN","TMGDIS0",92,0) ;"========================================== "RTN","TMGDIS0",93,0) Q goto Q^TMGDIS2 "RTN","TMGDIS0",94,0) "RTN","TMGDIS0",95,0) ;"========================================== "RTN","TMGDIS0",96,0) SAMEQ if J<0,$piece(DY(-J),U,3)="" Q "RTN","TMGDIS0",97,0) write !?8,"CONDITION -"_$char(DV+64) "RTN","TMGDIS0",98,0) write "- WILL APPLY TO THE SAME MULTIPLE AS CONDITION -" "RTN","TMGDIS0",99,0) write $char(DJ+64)_"-",!?8,"...OK" "RTN","TMGDIS0",100,0) goto YN^DICN "RTN","TMGDIS0",101,0) "RTN","TMGDIS0",102,0) ;"========================================== "RTN","TMGDIS0",103,0) L set P=O "RTN","TMGDIS0",104,0) set DL(DL)=Y "RTN","TMGDIS0",105,0) set DE="OR: " "RTN","TMGDIS0",106,0) for %=2:1 do quit:X="" "RTN","TMGDIS0",107,0) . set X=$piece(Y,U,%) "RTN","TMGDIS0",108,0) . quit:X="" "RTN","TMGDIS0",109,0) . set O=O+1 "RTN","TMGDIS0",110,0) . new tempS1,tempS2 "RTN","TMGDIS0",111,0) . set tempS2=$select($data(DJ(DL,+X)):" together with ",1:" and ") "RTN","TMGDIS0",112,0) . set tempS=$select(%>2:tempS2,O=1:"",1:" Or ") "RTN","TMGDIS0",113,0) . set tempS=tempS_$piece("not ",U,X["'") "RTN","TMGDIS0",114,0) . set tempS=tempS_O(+X) "RTN","TMGDIS0",115,0) . set ^UTILITY($J,O,0)=tempS "RTN","TMGDIS0",116,0) write:$X>18 ! "RTN","TMGDIS0",117,0) write " " "RTN","TMGDIS0",118,0) for %=P+1:1 quit:'$data(^UTILITY($J,%,0)) do "RTN","TMGDIS0",119,0) . set X=^(0) "RTN","TMGDIS0",120,0) . write:$length(X)+$X>77 !?13 "RTN","TMGDIS0",121,0) . write " "_$piece(X,U) "RTN","TMGDIS0",122,0) . if $piece(X,U,2)'="" write " ("_$piece(X,U,2)_")" "RTN","TMGDIS0",123,0) set DV=0 "RTN","TMGDIS0",124,0) DV set DV=$O(DV(DV)) "RTN","TMGDIS0",125,0) set:DV="" DV=-1 "RTN","TMGDIS0",126,0) goto:DV'>0 R:E,1 "RTN","TMGDIS0",127,0) goto DV:$data(DJ(DL,DV)) "RTN","TMGDIS0",128,0) set I=$piece(DC(DV),U,1) "RTN","TMGDIS0",129,0) set D=DK "RTN","TMGDIS0",130,0) set DN=0 "RTN","TMGDIS0",131,0) set Y="DO YOU WANT THIS SEARCH SPECIFICATION TO BE CONSIDERED TRUE FOR CONDITION -"_$char(DV+64)_"-" "RTN","TMGDIS0",132,0) G set DN=DN+1 "RTN","TMGDIS0",133,0) set P=$piece(I,C,1) "RTN","TMGDIS0",134,0) set I=$piece(I,C,2,99) "RTN","TMGDIS0",135,0) goto W:P["W",DV:I="" "RTN","TMGDIS0",136,0) if P<0 do goto G:'$piece(J,U,3) "RTN","TMGDIS0",137,0) . set J=DY(-P) "RTN","TMGDIS0",138,0) . set D=+J "RTN","TMGDIS0",139,0) . set R=" '"_$piece(^DIC(D,0),U,1)_"' ENTRIES " "RTN","TMGDIS0",140,0) else do "RTN","TMGDIS0",141,0) . set D=+$piece(^DD(D,P,0),U,2) "RTN","TMGDIS0",142,0) . set R=" '"_$O(^DD(D,0,"NM",0))_"' MULTIPLES " "RTN","TMGDIS0",143,0) HOW write !!,Y,!?8,"1) WHEN AT LEAST ONE OF THE"_R_"SATISFIES IT" "RTN","TMGDIS0",144,0) write !?8,"2) WHEN ALL OF THE"_R_"SATISFY IT" "RTN","TMGDIS0",145,0) set X=2 "RTN","TMGDIS0",146,0) if DV(DV) do "RTN","TMGDIS0",147,0) . write !?8,"3) WHEN ALL OF THE"_R_"SATISFY IT,",!?16,"OR WHEN THERE ARE NO"_R "RTN","TMGDIS0",148,0) . set X=3 "RTN","TMGDIS0",149,0) write !?4,"CHOOSE 1-"_X_": " "RTN","TMGDIS0",150,0) if DV(DV)>1 do "RTN","TMGDIS0",151,0) . write 3 "RTN","TMGDIS0",152,0) . set %1=3 "RTN","TMGDIS0",153,0) else do "RTN","TMGDIS0",154,0) . write 1 "RTN","TMGDIS0",155,0) . set %1=1 "RTN","TMGDIS0",156,0) read "// ",%:DTIME,! "RTN","TMGDIS0",157,0) set:'$T DTOUT=1 "RTN","TMGDIS0",158,0) set:%="" %=%1 "RTN","TMGDIS0",159,0) kill %1 "RTN","TMGDIS0",160,0) goto Q:%=U!'$T "RTN","TMGDIS0",161,0) goto HOW:%>X!'% "RTN","TMGDIS0",162,0) if %>1 do "RTN","TMGDIS0",163,0) . set DE(DL,DV,DN)=% "RTN","TMGDIS0",164,0) . set O=O+1 "RTN","TMGDIS0",165,0) . set ^UTILITY($J,O,0)=" for all"_R_$piece(", or when no"_R_"exist",U,%>2) "RTN","TMGDIS0",166,0) goto G "RTN","TMGDIS0",167,0) "RTN","TMGDIS0",168,0) ;"========================================== "RTN","TMGDIS0",169,0) W if DV(DV)-2 set DE(DL,DV,DN)=DV(DV) goto DV "RTN","TMGDIS0",170,0) write !!,Y,!?7,"WHEN THERE IS NO '"_$piece(^DD(D,+P,0),U,1)_"' TEXT AT ALL" "RTN","TMGDIS0",171,0) set %=1 "RTN","TMGDIS0",172,0) do YN^DICN "RTN","TMGDIS0",173,0) goto Q:%<0 "RTN","TMGDIS0",174,0) goto W:'% "RTN","TMGDIS0",175,0) set DE(DL,DV,DN)=4-% "RTN","TMGDIS0",176,0) goto DV "RTN","TMGDIS0",177,0) "RTN","TMGDIS0",178,0) ;"========================================== "RTN","TMGDIS0",179,0) 1 kill O,DX,Y "RTN","TMGDIS0",180,0) goto ^TMGDIS1 "RTN","TMGDIS1") 0^12^B43572349 "RTN","TMGDIS1",1,0) TMGDIS1 ;TMG/kst/Custom version of DIS1 ;03/25/06 "RTN","TMGDIS1",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDIS1",3,0) "RTN","TMGDIS1",4,0) "RTN","TMGDIS1",5,0) "RTN","TMGDIS1",6,0) DIS1 ;SFISC/GFT-BUILD DIS-ARRAY ;09:04 AM 21 Aug 2002 "RTN","TMGDIS1",7,0) ;;22.0;VA FileMan;**6,77,97,113**;Mar 30, 1999 "RTN","TMGDIS1",8,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGDIS1",9,0) "RTN","TMGDIS1",10,0) ;"Purpose: BUILD DIS-ARRAY "RTN","TMGDIS1",11,0) ;"From here program execution flow goes only to ^DIS2 "RTN","TMGDIS1",12,0) ;" ^DIS can goto ^DIS (starting back at beginning) "RTN","TMGDIS1",13,0) "RTN","TMGDIS1",14,0) kill DIS0 "RTN","TMGDIS1",15,0) if $data(DL)#2 set DIS0=DL "RTN","TMGDIS1",16,0) set DL(0)="" "RTN","TMGDIS1",17,0) write ! "RTN","TMGDIS1",18,0) goto 1:$data(DE)>1!$data(DJ) "RTN","TMGDIS1",19,0) if DL=1 do "RTN","TMGDIS1",20,0) . set DL(0)=DL(1) "RTN","TMGDIS1",21,0) . set DL=0 "RTN","TMGDIS1",22,0) . kill DL(1) "RTN","TMGDIS1",23,0) else for P=2:1 do quit:Y="" "RTN","TMGDIS1",24,0) . set Y=$piece(DL(1),U,P) "RTN","TMGDIS1",25,0) . quit:Y="" "RTN","TMGDIS1",26,0) . set Y=U_Y_U,X=2 "RTN","TMGDIS1",27,0) . do 2 "RTN","TMGDIS1",28,0) for X=1:1 quit:'$data(DL(X)) do "RTN","TMGDIS1",29,0) . for Y=X+1:1 quit:'$data(DL(Y)) do "RTN","TMGDIS1",30,0) . . if DL(X)=DL(Y)!(DL(Y)?.P) do "RTN","TMGDIS1",31,0) . . . set DL=DL-1 "RTN","TMGDIS1",32,0) . . . kill DL(Y) "RTN","TMGDIS1",33,0) . . . for P=Y:1:DL do "RTN","TMGDIS1",34,0) . . . . set DL(P)=DL(P+1) "RTN","TMGDIS1",35,0) . . . . kill DL(P+1) "RTN","TMGDIS1",36,0) 1 do ENT "RTN","TMGDIS1",37,0) goto ^TMGDIS2:'$data(DIAR) "RTN","TMGDIS1",38,0) goto DIS^TMGDIS2 "RTN","TMGDIS1",39,0) "RTN","TMGDIS1",40,0) ;"========================================== "RTN","TMGDIS1",41,0) ;"========================================== "RTN","TMGDIS1",42,0) ENT set DK(0)=DK "RTN","TMGDIS1",43,0) set Z="D0," "RTN","TMGDIS1",44,0) for DQ=0:1:DL do "RTN","TMGDIS1",45,0) . kill R,M "RTN","TMGDIS1",46,0) . do "RTN","TMGDIS1",47,0) . . new I set I="" "RTN","TMGDIS1",48,0) . . for set I=$O(DI(I)) quit:'I kill DI(I) "RTN","TMGDIS1",49,0) . . quit "RTN","TMGDIS1",50,0) . set X=0 "RTN","TMGDIS1",51,0) . set DQ(0)=DQ "RTN","TMGDIS1",52,0) . set R=-1 "RTN","TMGDIS1",53,0) . do MAKE "RTN","TMGDIS1",54,0) . set %=0 "RTN","TMGDIS1",55,0) . for do quit:R="" "RTN","TMGDIS1",56,0) . . set R=$O(R(R)) "RTN","TMGDIS1",57,0) . . quit:R="" "RTN","TMGDIS1",58,0) . . if R(R)<2 set DIS(R)=DIS(R)_" KILL D" "RTN","TMGDIS1",59,0) set R=-1 "RTN","TMGDIS1",60,0) quit "RTN","TMGDIS1",61,0) "RTN","TMGDIS1",62,0) ;"========================================== "RTN","TMGDIS1",63,0) 2 if X'>DL quit:DL(X)'[Y set X=X+1 goto 2 "RTN","TMGDIS1",64,0) set DL(0)=U_$piece(Y,U,2)_DL(0) "RTN","TMGDIS1",65,0) set P=P-1 "RTN","TMGDIS1",66,0) 22 set X=X-1 "RTN","TMGDIS1",67,0) set DQ=$F(DL(X),Y) "RTN","TMGDIS1",68,0) set DL(X)=$extract(DL(X),1,DQ-$L(Y))_$extract(DL(X),DQ,999) "RTN","TMGDIS1",69,0) goto 22:X>1 "RTN","TMGDIS1",70,0) quit "RTN","TMGDIS1",71,0) "RTN","TMGDIS1",72,0) ;"========================================== "RTN","TMGDIS1",73,0) C set Y=Y_$S(DV="'":" if 'X",1:" I "_$$XFORM("X")_DV) "RTN","TMGDIS1",74,0) do SD "RTN","TMGDIS1",75,0) MAKE set DC=DI "RTN","TMGDIS1",76,0) set DQ=+DQ "RTN","TMGDIS1",77,0) set X=X+1 "RTN","TMGDIS1",78,0) set Y=$piece(DL(DQ),U,X+1) "RTN","TMGDIS1",79,0) quit:Y="" "RTN","TMGDIS1",80,0) set S=+Y "RTN","TMGDIS1",81,0) set DN=$extract("'",Y["'") "RTN","TMGDIS1",82,0) set Y=DC(S) "RTN","TMGDIS1",83,0) set D=0,DL=0 "RTN","TMGDIS1",84,0) if $data(DJ(DQ,S)) do "RTN","TMGDIS1",85,0) . set D=$piece(DJ(DQ,S),U,2) "RTN","TMGDIS1",86,0) . set DL=+DJ(DQ,S) "RTN","TMGDIS1",87,0) . if $data(DI(DL)) set DC=DI(DL) "RTN","TMGDIS1",88,0) set DQ=DQ(DL) "RTN","TMGDIS1",89,0) set Z=$piece(Z,",",1,D+D+1)_"," "RTN","TMGDIS1",90,0) set DU=$piece($piece(Y,U),",",DL+1,99) "RTN","TMGDIS1",91,0) set O=DK(DL) "RTN","TMGDIS1",92,0) set DV=DN_$piece(Y,U,2) "RTN","TMGDIS1",93,0) if DV?1"''".E set DV=$extract(DV,3,999) "RTN","TMGDIS1",94,0) LEV set DL=DL+1 "RTN","TMGDIS1",95,0) set DN=$S($data(DE(+DQ,X,DL)):DE(+DQ,X,DL),1:1) "RTN","TMGDIS1",96,0) set:$G(DI(DL-1))]"" DI(DL)=DI(DL-1) "RTN","TMGDIS1",97,0) if DU<0 goto X:$data(DY(-DU)) set Y=DA(-DU) goto C "RTN","TMGDIS1",98,0) set N=$piece(^DD(O,+DU,0),U,4) "RTN","TMGDIS1",99,0) set DE=$piece(N,";",1) "RTN","TMGDIS1",100,0) set Y=$piece(N,";",2) "RTN","TMGDIS1",101,0) if Y="" set Y="D"_D goto M "RTN","TMGDIS1",102,0) if $piece(^(0),U,2)["C" set Y=$piece(^(0),U,5,99) goto C "RTN","TMGDIS1",103,0) set:+DE'=DE DE=""""_DE_"""" "RTN","TMGDIS1",104,0) set Z=Z_DE "RTN","TMGDIS1",105,0) set E="$G("_DC_Z_"))" "RTN","TMGDIS1",106,0) if Y set Y="$piece("_E_",U,"_Y_")" goto M "RTN","TMGDIS1",107,0) if Y'=0 do goto M "RTN","TMGDIS1",108,0) . set Y=$extract(Y,2,99) "RTN","TMGDIS1",109,0) . set:$piece(Y,",",2)=+Y Y=+Y "RTN","TMGDIS1",110,0) . set Y="$extract("_E_","_Y_")" "RTN","TMGDIS1",111,0) for Y=65:1 set M=DQ_$C(Y) quit:'$data(DIS(M)) "RTN","TMGDIS1",112,0) set D=D+1 "RTN","TMGDIS1",113,0) set Y="set D"_D_"=+$O("_DC_Z_",0)) X DIS("""_M_""") if $T" "RTN","TMGDIS1",114,0) do SD "RTN","TMGDIS1",115,0) if $data(DIAR) set DIAR(DIARF,DQ)="X DIS("""_M_"A"")" "RTN","TMGDIS1",116,0) set DQ=M "RTN","TMGDIS1",117,0) set DIS(DQ)="F X DIS("""_DQ_"A"") X:D"_D_"'>0 ""IF "_(DN=3)_""" Q:"_$extract("'",DN>1)_"$T set D"_D_"=$O("_DC_Z_",D"_D_")) Q:D"_D_"'>0" "RTN","TMGDIS1",118,0) WP set DQ=DQ_"A",DQ(DL)=DQ "RTN","TMGDIS1",119,0) if DU'["," set DIS(DQ)="if "_$$XFORM("$G(^(D"_D_",0))")_DV goto MAKE "RTN","TMGDIS1",120,0) set O=+$piece(^(0),U,2) "RTN","TMGDIS1",121,0) set DK(DL)=O "RTN","TMGDIS1",122,0) set Z=Z_",D"_D_"," "RTN","TMGDIS1",123,0) N set DU=$piece(DU,",",2,99) "RTN","TMGDIS1",124,0) goto LEV "RTN","TMGDIS1",125,0) "RTN","TMGDIS1",126,0) ;"========================================== "RTN","TMGDIS1",127,0) M do "RTN","TMGDIS1",128,0) VARPOINT . if $piece(^DD(O,+DU,0),U,2)["V" do quit "RTN","TMGDIS1",129,0) . . set Y="if "_$$XFORM("$$EXTERNAL^DIDU("_O_","_+DU_","""","_Y_")") "RTN","TMGDIS1",130,0) . ;"--following line modified per GFT to fix search with output transform on pointer, jas 2005-03-23--; "RTN","TMGDIS1",131,0) OUTX . if $data(^(2)),$piece(^(0),U,2)'["D",DV'["=" do quit "RTN","TMGDIS1",132,0) . . set M=0,Y="set Y="_Y_" "_$$OVFL(^(2))_" if "_$$XFORM("Y") "RTN","TMGDIS1",133,0) SET . if $data(DIS(U,S)) do quit "RTN","TMGDIS1",134,0) . . set Y="set Y="_Y_" if $S(Y="""":"""",$D(DIS(U,"_S_",Y)):DIS(U,"_S_",Y),1:"""")" "RTN","TMGDIS1",135,0) . set M=Y "RTN","TMGDIS1",136,0) . set Y="if "_$$XFORM(Y) "RTN","TMGDIS1",137,0) set Y=Y_DV "RTN","TMGDIS1",138,0) do SD "RTN","TMGDIS1",139,0) goto MAKE "RTN","TMGDIS1",140,0) "RTN","TMGDIS1",141,0) ;"========================================== "RTN","TMGDIS1",142,0) XFORM(Y) if '$data(DIS("XFORM",S)) quit Y "RTN","TMGDIS1",143,0) quit $piece(DIS("XFORM",S),";")_Y_$piece(DIS("XFORM",S),";",2) "RTN","TMGDIS1",144,0) "RTN","TMGDIS1",145,0) ;"========================================== "RTN","TMGDIS1",146,0) SD if $data(R(DQ)),R(DQ)>1 set Y="kill D "_Y_" set:$T D=1" "RTN","TMGDIS1",147,0) if '$data(DIS(DQ)) set DIS(DQ)=Y quit "RTN","TMGDIS1",148,0) if $L($G(DL(DQ)))*8+$L(DIS(DQ))+$L(Y)>180 do "RTN","TMGDIS1",149,0) . set Y=$$OVFL(Y)_" if $T" "RTN","TMGDIS1",150,0) . if $L(Y)+$L(DIS(DQ))>235 do "RTN","TMGDIS1",151,0) . . set DIS(DQ)=$$OVFL(DIS(DQ))_" if " "RTN","TMGDIS1",152,0) set DIS(DQ)=DIS(DQ)_" "_Y "RTN","TMGDIS1",153,0) quit "RTN","TMGDIS1",154,0) "RTN","TMGDIS1",155,0) ;"========================================== "RTN","TMGDIS1",156,0) OVFL(Y) new I,% "RTN","TMGDIS1",157,0) for I=1:1 do quit:'$data(DIS(%)) "RTN","TMGDIS1",158,0) . set %=DQ_"@"_I "RTN","TMGDIS1",159,0) set DIS(%)=Y "RTN","TMGDIS1",160,0) quit "X DIS("""_%_""")" "RTN","TMGDIS1",161,0) "RTN","TMGDIS1",162,0) ;"========================================== "RTN","TMGDIS1",163,0) X set D=DY(-DU) "RTN","TMGDIS1",164,0) set O=+D "RTN","TMGDIS1",165,0) set DC=U_$piece(D,U,2) "RTN","TMGDIS1",166,0) for %=66:1 set M=DQ_$C(%) quit:'$data(DIS(M)) "RTN","TMGDIS1",167,0) if $piece(D,U,3) do "RTN","TMGDIS1",168,0) . set M=DQ_U_$piece(D,U,3) "RTN","TMGDIS1",169,0) . set Y="set DIXX="""_M_""" "_$piece("X ""if 0"" ^I 1 ",U,DN=3+1)_$piece(D,U,4,99)_" if $T" "RTN","TMGDIS1",170,0) . set R(M)=DN "RTN","TMGDIS1",171,0) else do "RTN","TMGDIS1",172,0) . set Y=$piece(D,U,4,99)_" set D0=D(0) X DIS("""_M_""") set D0=I(0,0) if $T" "RTN","TMGDIS1",173,0) do SD "RTN","TMGDIS1",174,0) set DQ=M "RTN","TMGDIS1",175,0) set DI(DL)=DC "RTN","TMGDIS1",176,0) set DK(DL)=+D "RTN","TMGDIS1",177,0) set DQ(DL)=DQ "RTN","TMGDIS1",178,0) set D=0 "RTN","TMGDIS1",179,0) set Z="D0," "RTN","TMGDIS1",180,0) goto N "RTN","TMGDIS1",181,0) "RTN","TMGDIS1",182,0) ;-- DIS1 -- Downloaded 25Mar05 from M2Web, vista.vmth.ucdavis.edu "RTN","TMGDIS2") 0^13^B21503917 "RTN","TMGDIS2",1,0) TMGDIS2 ;TMG/kst/Custom version of DIS2 ;03/25/06 "RTN","TMGDIS2",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDIS2",3,0) "RTN","TMGDIS2",4,0) "RTN","TMGDIS2",5,0) "RTN","TMGDIS2",6,0) DIS2 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS ;5:49 AM 2 Jun 1999 "RTN","TMGDIS2",7,0) ;;22.0;VA FileMan;**6**;Mar 30, 1999 "RTN","TMGDIS2",8,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGDIS2",9,0) ; "RTN","TMGDIS2",10,0) "RTN","TMGDIS2",11,0) ;"Purpose: SEARCH, TEMPLATES & COMPUTED FIELDS "RTN","TMGDIS2",12,0) ;"Note: Program execution can loop all the way back to ^DIS "RTN","TMGDIS2",13,0) "RTN","TMGDIS2",14,0) kill DISV "RTN","TMGDIS2",15,0) goto G:'DUZ "RTN","TMGDIS2",16,0) 0 do "RTN","TMGDIS2",17,0) . new DIS,DIS0,DA,DC,DE,DJ,DL "RTN","TMGDIS2",18,0) . do S3^DIBT1 "RTN","TMGDIS2",19,0) . Q "RTN","TMGDIS2",20,0) kill DIRUT,DIROUT "RTN","TMGDIS2",21,0) if $D(DTOUT)!($D(DUOUT)) goto Q "RTN","TMGDIS2",22,0) if X="" goto G:'$D(DIAR) "RTN","TMGDIS2",23,0) if Y<0 goto Q:X=U,0 "RTN","TMGDIS2",24,0) if $D(DIARU),DIARU-Y=0 do goto 0 "RTN","TMGDIS2",25,0) . write $C(7),!,"Archivers must not store results in the default template" "RTN","TMGDIS2",26,0) set (DIARI,DISV)=+Y "RTN","TMGDIS2",27,0) set A=$D(^DIBT(DISV,"DL")) "RTN","TMGDIS2",28,0) set:$D(DIS0)#2 ^("DL")=DIS0 "RTN","TMGDIS2",29,0) set:$D(DA)#2 ^("DA")=DA "RTN","TMGDIS2",30,0) set:$D(DJ)#2 ^("DJ")=DJ "RTN","TMGDIS2",31,0) if $D(DIAR),'$D(DIARU) set $P(^DIAR(1.11,DIARC,0),U,3)=DISV "RTN","TMGDIS2",32,0) set Z=-1,DIS0="^DIBT(+Y," "RTN","TMGDIS2",33,0) for P="DIS","DA","DC","DE","DJ","DL" do "RTN","TMGDIS2",34,0) . set %Y=DIS0_""""_P_"""," "RTN","TMGDIS2",35,0) . set %X=P_"(" "RTN","TMGDIS2",36,0) . do %XY^%RCR "RTN","TMGDIS2",37,0) set %X="^UTILITY($J," "RTN","TMGDIS2",38,0) set %Y="^DIBT(DISV,""O""," "RTN","TMGDIS2",39,0) set @(%X_"0)=U") "RTN","TMGDIS2",40,0) do %XY^%RCR "RTN","TMGDIS2",41,0) G new DISTXT "RTN","TMGDIS2",42,0) set %X="^UTILITY($J," "RTN","TMGDIS2",43,0) set %Y="DISTXT(" "RTN","TMGDIS2",44,0) do %XY^%RCR "RTN","TMGDIS2",45,0) write ! "RTN","TMGDIS2",46,0) set Y=DI "RTN","TMGDIS2",47,0) do Q "RTN","TMGDIS2",48,0) set DIC=Y "RTN","TMGDIS2",49,0) goto EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP "RTN","TMGDIS2",50,0) "RTN","TMGDIS2",51,0) ;"========================================== "RTN","TMGDIS2",52,0) TEM ; "RTN","TMGDIS2",53,0) kill DIC "RTN","TMGDIS2",54,0) set X=$P($extract(X,2,99),"]",1) "RTN","TMGDIS2",55,0) set DIC="^DIBT(" "RTN","TMGDIS2",56,0) set DIC(0)="EQ" "RTN","TMGDIS2",57,0) set DIC("S")="if "_$select($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))" "RTN","TMGDIS2",58,0) set DIC("W")="X ""for %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) write !?9 set I=^(0) W:$L(I)+$X>79 !?9 write I""" "RTN","TMGDIS2",59,0) do ^DIC "RTN","TMGDIS2",60,0) kill DIC "RTN","TMGDIS2",61,0) goto F^TMGDIS:Y<0 "RTN","TMGDIS2",62,0) set P="DIS" "RTN","TMGDIS2",63,0) set Z=-1 "RTN","TMGDIS2",64,0) set %X="^DIBT(+Y,P," "RTN","TMGDIS2",65,0) set %Y="DIS(" "RTN","TMGDIS2",66,0) do %XY^%RCR "RTN","TMGDIS2",67,0) set %Y="^UTILITY($J," "RTN","TMGDIS2",68,0) set P="O" "RTN","TMGDIS2",69,0) do %XY^%RCR "RTN","TMGDIS2",70,0) goto DIS2 "RTN","TMGDIS2",71,0) "RTN","TMGDIS2",72,0) ;"========================================== "RTN","TMGDIS2",73,0) COMP ; "RTN","TMGDIS2",74,0) set E=X "RTN","TMGDIS2",75,0) set DICMX="X DIS(DIXX)" "RTN","TMGDIS2",76,0) set DICOMP=N_"?" "RTN","TMGDIS2",77,0) set DQI="Y(" "RTN","TMGDIS2",78,0) set DA="DIS("""_$C(DC+64)_DL_"""," "RTN","TMGDIS2",79,0) if '$D(O(DC))#2 set O(DC)=X "RTN","TMGDIS2",80,0) goto COLON:X?.E1":" "RTN","TMGDIS2",81,0) if X?.E1":.01",'$D(O(DC))#2 set O(DC)=$extract(X,1,$L(X)-4) "RTN","TMGDIS2",82,0) do EN^DICOMP "RTN","TMGDIS2",83,0) do XA "RTN","TMGDIS2",84,0) goto X^TMGDIS:'$D(X) "RTN","TMGDIS2",85,0) goto X^TMGDIS:Y["m" ;"if Y["m" set X=E_":" goto COMP "RTN","TMGDIS2",86,0) set DA(DC)=X "RTN","TMGDIS2",87,0) set DU=-DC "RTN","TMGDIS2",88,0) set E=$extract("B",Y["B")_$extract("D",Y["D") "RTN","TMGDIS2",89,0) goto G^TMGDIS "RTN","TMGDIS2",90,0) "RTN","TMGDIS2",91,0) ;"========================================== "RTN","TMGDIS2",92,0) XA set %=0 "RTN","TMGDIS2",93,0) for do Q:%="" "RTN","TMGDIS2",94,0) . set %=$O(X(%)) "RTN","TMGDIS2",95,0) . Q:%="" "RTN","TMGDIS2",96,0) . set @(DA_%_")")=X(%) "RTN","TMGDIS2",97,0) set %=-1 "RTN","TMGDIS2",98,0) quit "RTN","TMGDIS2",99,0) "RTN","TMGDIS2",100,0) ;"========================================== "RTN","TMGDIS2",101,0) COLON do ^DICOMPW "RTN","TMGDIS2",102,0) goto X^TMGDIS:'$D(X) "RTN","TMGDIS2",103,0) do XA "RTN","TMGDIS2",104,0) set R(DL)=R "RTN","TMGDIS2",105,0) set N(DL)=N "RTN","TMGDIS2",106,0) set N=+Y "RTN","TMGDIS2",107,0) set DY=DY+1 "RTN","TMGDIS2",108,0) set DV(DL)=DV "RTN","TMGDIS2",109,0) set DL(DL)=DK "RTN","TMGDIS2",110,0) set DL=DL+1 "RTN","TMGDIS2",111,0) set DV=DV_-DY_C "RTN","TMGDIS2",112,0) set DY(DY)=DP_U_$select(Y["m":DC_"."_DL,1:"")_U_X "RTN","TMGDIS2",113,0) set R=U_$P(DP,U,2) "RTN","TMGDIS2",114,0) kill X "RTN","TMGDIS2",115,0) goto R^TMGDIS "RTN","TMGDIS2",116,0) "RTN","TMGDIS2",117,0) ;"========================================== "RTN","TMGDIS2",118,0) Q ; "RTN","TMGDIS2",119,0) kill DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE "RTN","TMGDIS2",120,0) kill DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT "RTN","TMGDIS2",121,0) kill ^UTILITY($J) "RTN","TMGDIS2",122,0) quit "RTN","TMGDIS2",123,0) "RTN","TMGDIS2",124,0) ;"========================================== "RTN","TMGDIS2",125,0) DIS ;"PUT SET LOGIC INTO DIS FOR SUBFILE "RTN","TMGDIS2",126,0) set %X="" "RTN","TMGDIS2",127,0) for %Y=1:1 do Q:'%X "RTN","TMGDIS2",128,0) . set %X=$O(DIS(%X)) "RTN","TMGDIS2",129,0) . quit:'%X "RTN","TMGDIS2",130,0) . set %=$select($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X)) "RTN","TMGDIS2",131,0) . set:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2) "RTN","TMGDIS2",132,0) . set ^DIAR(1.11,DIARC,"S",%Y,0)=%X "RTN","TMGDIS2",133,0) . set ^(1)=% "RTN","TMGDIS2",134,0) if %Y>1 do "RTN","TMGDIS2",135,0) . set %Y=%Y-1 "RTN","TMGDIS2",136,0) . set ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y "RTN","TMGDIS2",137,0) goto ^TMGDIS2 "RTN","TMGDIS3") 0^14^B3848644 "RTN","TMGDIS3",1,0) TMGDIS3 ;TMG/kst/Custom version of DIS3 ;03/25/06 "RTN","TMGDIS3",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDIS3",3,0) "RTN","TMGDIS3",4,0) "RTN","TMGDIS3",5,0) DIS3 ;SFISC/SEARCH - PROGRAMMER ENTRY POINT ;12/16/93 13:16 "RTN","TMGDIS3",6,0) ;;22.0;VA FileMan;;Mar 30, 1999 "RTN","TMGDIS3",7,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGDIS3",8,0) "RTN","TMGDIS3",9,0) EN ; "RTN","TMGDIS3",10,0) new DIQUIET,DIFM "RTN","TMGDIS3",11,0) set L=$G(L) "RTN","TMGDIS3",12,0) set DIFM=+L "RTN","TMGDIS3",13,0) do CLEAN^DIEFU,INIT^DIP "RTN","TMGDIS3",14,0) set:$G(DIC) DIC=$G(^DIC(DIC,0,"GL")) "RTN","TMGDIS3",15,0) goto QER1:$G(DIC)="" "RTN","TMGDIS3",16,0) new DK "RTN","TMGDIS3",17,0) set DK=+$P($G(@(DIC_"0)")),U,2) "RTN","TMGDIS3",18,0) goto QER1:'DK "RTN","TMGDIS3",19,0) new DISV,Y "RTN","TMGDIS3",20,0) do "RTN","TMGDIS3",21,0) . new DIC,X,DIS "RTN","TMGDIS3",22,0) . set Y=-1,DIS=$G(DISTEMP) "RTN","TMGDIS3",23,0) . quit:DIS="" "RTN","TMGDIS3",24,0) . set X=$S($E(DIS)="[":$P($E(DIS,2,99),"]"),1:DIS) "RTN","TMGDIS3",25,0) . set DIC="^DIBT(" "RTN","TMGDIS3",26,0) . set DIC(0)="Q" "RTN","TMGDIS3",27,0) . set DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))" "RTN","TMGDIS3",28,0) . do ^DIC "RTN","TMGDIS3",29,0) . Q "RTN","TMGDIS3",30,0) set DISV=+Y "RTN","TMGDIS3",31,0) if Y<0 set DIC="DISTEMP" goto QER "RTN","TMGDIS3",32,0) new DISTXT "RTN","TMGDIS3",33,0) set %X="^DIBT(DISV,""DIS"",",%Y="DIS(" "RTN","TMGDIS3",34,0) do %XY^%RCR "RTN","TMGDIS3",35,0) set %X="^DIBT(DISV,""O"",",%Y="DISTXT(" "RTN","TMGDIS3",36,0) do %XY^%RCR "RTN","TMGDIS3",37,0) kill ^DIBT(DISV,1) "RTN","TMGDIS3",38,0) do EN1^DIP "RTN","TMGDIS3",39,0) goto EXIT "RTN","TMGDIS3",40,0) "RTN","TMGDIS3",41,0) ;"========================================== "RTN","TMGDIS3",42,0) QER1 set DIC="DIC" "RTN","TMGDIS3",43,0) QER do BLD^DIALOG(201,DIC) "RTN","TMGDIS3",44,0) do:'$G(DIQUIET) MSG^DIALOG() "RTN","TMGDIS3",45,0) do Q^DIP "RTN","TMGDIS3",46,0) EXIT kill DIC,DISTEMP "RTN","TMGDIS3",47,0) Q "RTN","TMGDIS3",48,0) ;"DIALOG #201 'The input variable...is missing or invalid.' "RTN","TMGDRUG") 0^15^B5590 "RTN","TMGDRUG",1,0) TMGDRUG ;TMG/kst/Code for setting up Drugs/Pharmacy ;03/25/06 "RTN","TMGDRUG",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGDRUG",3,0) "RTN","TMGDRUG",4,0) ;"TMG FUNCTIONS FOR SETTING UP DRUGS/PHARMACY "RTN","TMGDRUG",5,0) "RTN","TMGDRUG",6,0) ;"======================================================================= "RTN","TMGDRUG",7,0) ;" API -- Public Functions. "RTN","TMGDRUG",8,0) ;"======================================================================= "RTN","TMGDRUG",9,0) ;"SetupDF -- Set up the Drug File "RTN","TMGDRUG",10,0) ;"MakeExList "RTN","TMGDRUG",11,0) "RTN","TMGDRUG",12,0) ;"======================================================================= "RTN","TMGDRUG",13,0) ;"PRIVATE API FUNCTIONS "RTN","TMGDRUG",14,0) ;"======================================================================= "RTN","TMGDRUG",15,0) ;"MakeSubExClass(ParentClass) "RTN","TMGDRUG",16,0) ;"CodeInCode(TextCode,RefCode) "RTN","TMGDRUG",17,0) ;"ClassInClass(ClassIEN,TextCode,RefClassIEN) Purpose: To return if a class is either equal to, or a child of a Ref Class "RTN","TMGDRUG",18,0) ;"DrugInClass(DrugIEN,TextCode,ClassIEN Purpose: To see if a drug is in a given class "RTN","TMGDRUG",19,0) ;"ShowClHeirarchy(ClassIEN) "RTN","TMGDRUG",20,0) ;"GetClHeirarchy(ClassIEN,Array) "RTN","TMGDRUG",21,0) ;"ShowClass(DrugIEN) "RTN","TMGDRUG",22,0) ;"ShowRxInClass(ClassIEN) Purpose: to show all drugs in given class "RTN","TMGDRUG",23,0) ;"IsClassNull(DrugIEN) "RTN","TMGDRUG",24,0) ;"IsClassExcluded(ClassIEN) Purpose: To see is class is in an excluded class "RTN","TMGDRUG",25,0) ;"TestExclusions "RTN","TMGDRUG",26,0) ;"IsRxExcluded(DrugIEN) Purpose: To see if drug is in excluded catagory "RTN","TMGDRUG",27,0) ;"ShowDrugs "RTN","TMGDRUG",28,0) ;"ShowNCDrugs "RTN","TMGDRUG",29,0) ;"ShowExDrugs "RTN","TMGDRUG",30,0) ;"SURxArray Purpose: To set up the drug file such that the drugs are orderable in CPRS "RTN","TMGDRUG",31,0) ;"MakePO(ShortName) ;Make a Pharmacy Orderable Item "RTN","TMGDRUG",32,0) "RTN","TMGDRUG",33,0) ;"======================================================================= "RTN","TMGDRUG",34,0) ;"======================================================================= "RTN","TMGDRUG",35,0) "RTN","TMGDRUG",36,0) MakeExList "RTN","TMGDRUG",37,0) ;"Purpose: To create an array of drug classes that are not desired "RTN","TMGDRUG",38,0) ;"Output: Stores result in ^TMP("TMGPSExclude",*) "RTN","TMGDRUG",39,0) "RTN","TMGDRUG",40,0) new ClassIEN,LastClass "RTN","TMGDRUG",41,0) new Backup set Backup=0 "RTN","TMGDRUG",42,0) new result set result=1 "RTN","TMGDRUG",43,0) set LastClass="" "RTN","TMGDRUG",44,0) kill ^TMP("TMGPSExclude") "RTN","TMGDRUG",45,0) new TempI set TempI=0 "RTN","TMGDRUG",46,0) set ClassIEN=$order(^PS(50.605,0)) ;"file# 50.605 = VA DRUG CLASS CODE "RTN","TMGDRUG",47,0) for do quit:(ClassIEN="") "RTN","TMGDRUG",48,0) . if ClassIEN="" quit "RTN","TMGDRUG",49,0) . new Node set Node=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",50,0) . new Code set Code=$piece(Node,"^",1) "RTN","TMGDRUG",51,0) . new Parent set Parent=+$piece(Node,"^",3) "RTN","TMGDRUG",52,0) . if Parent=0 do quit:(ClassIEN="") "RTN","TMGDRUG",53,0) . . set result=$$MakeSubExClass(ClassIEN) "RTN","TMGDRUG",54,0) . . if result=0 set ClassIEN="" "RTN","TMGDRUG",55,0) . if Backup=0 set ClassIEN=$order(^PS(50.605,ClassIEN)) "RTN","TMGDRUG",56,0) . else set Backup=0 "RTN","TMGDRUG",57,0) "RTN","TMGDRUG",58,0) write "Here are the excluded IEN's from file 50.605",! "RTN","TMGDRUG",59,0) zwr ^TMP("TMGPSExclude",*) "RTN","TMGDRUG",60,0) "RTN","TMGDRUG",61,0) write "Goodbye!",! "RTN","TMGDRUG",62,0) quit "RTN","TMGDRUG",63,0) "RTN","TMGDRUG",64,0) "RTN","TMGDRUG",65,0) "RTN","TMGDRUG",66,0) MakeSubExClass(ParentClass,ChildDetail) "RTN","TMGDRUG",67,0) ;"Purpose: To review the elements on one class, to see if they need to be excluded "RTN","TMGDRUG",68,0) ;"Input: ParentClass -- The parent class of the class to be reviewed. "RTN","TMGDRUG",69,0) ;" ChildDetail -- OPTIONAL, default=0 "RTN","TMGDRUG",70,0) ;" If 1, then show children of Parent Class "RTN","TMGDRUG",71,0) ;" if 0, just show ParentClass (<--Default Value) "RTN","TMGDRUG",72,0) ;"Output: Stores result in ^TMP("TMGPSExclude",*) "RTN","TMGDRUG",73,0) ;"Result: 1 if OK to continue, 0 if aborted. "RTN","TMGDRUG",74,0) "RTN","TMGDRUG",75,0) new ClassIEN,LastClass "RTN","TMGDRUG",76,0) new Backup set Backup=0 "RTN","TMGDRUG",77,0) set LastClass="" "RTN","TMGDRUG",78,0) new result set result=1 "RTN","TMGDRUG",79,0) set ChildDetail=$get(ChildDetail,0) "RTN","TMGDRUG",80,0) if '$data(ParentClass) set result=0 goto MSECDone "RTN","TMGDRUG",81,0) if $$IsClassExcluded(ParentClass) goto MSECDone "RTN","TMGDRUG",82,0) "RTN","TMGDRUG",83,0) set ClassIEN=ParentClass ;"In file order, children come after parent. "RTN","TMGDRUG",84,0) for do quit:(+ClassIEN=0) ;"Cycle, looking for children. "RTN","TMGDRUG",85,0) . if +ClassIEN=0 quit "RTN","TMGDRUG",86,0) . new AskThisOne set AskThisOne=0 ;"default=no show "RTN","TMGDRUG",87,0) . new Node set Node=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",88,0) . new Code set Code=$piece(Node,"^",1) "RTN","TMGDRUG",89,0) . new Class set Class=$piece(Node,"^",2) "RTN","TMGDRUG",90,0) . new Parent set Parent=+$piece(Node,"^",3) "RTN","TMGDRUG",91,0) . new Type set Type=$piece(Node,"^",4) "RTN","TMGDRUG",92,0) . if ChildDetail=0 do ;" just show parent "RTN","TMGDRUG",93,0) . . if ClassIEN=ParentClass set AskThisOne=1 "RTN","TMGDRUG",94,0) . else do "RTN","TMGDRUG",95,0) . . set AskThisOne=1 "RTN","TMGDRUG",96,0) . . if ClassIEN=ParentClass set AskThisOne=0 ;"(don't show parent) "RTN","TMGDRUG",97,0) . . if ($$ClassInClass(ClassIEN,,ParentClass)=0) do "RTN","TMGDRUG",98,0) . . . set AskThisOne=0 ;"(don't show if not in parent's class) "RTN","TMGDRUG",99,0) . . . set ClassIEN="" ;"as so as we get to an entry in the list that is not in parent, then we can escape "RTN","TMGDRUG",100,0) . if AskThisOne do "RTN","TMGDRUG",101,0) . . write "---------------------------------------------------",! "RTN","TMGDRUG",102,0) . . write Class," (",Code,")",! "RTN","TMGDRUG",103,0) . . write "---------------------------------------------------",! "RTN","TMGDRUG",104,0) . . new ref set ref="^PS(50.605,"_i_",1)" "RTN","TMGDRUG",105,0) . . do WriteWP^TMGSTUTL(ref) "RTN","TMGDRUG",106,0) . . new Exclude set Exclude="" "RTN","TMGDRUG",107,0) . . for do quit:(Exclude="") "RTN","TMGDRUG",108,0) . . . write Class," (",Code,")",! "RTN","TMGDRUG",109,0) . . . read "Exclude this drug class (and any derivative subclasses)? (? for help) NO//",Exclude:$get(DTIME,3600),! "RTN","TMGDRUG",110,0) . . . if Exclude="" set Exclude="NO" "RTN","TMGDRUG",111,0) . . . if Exclude["?" do quit "RTN","TMGDRUG",112,0) . . . . Write "^ to abort",! "RTN","TMGDRUG",113,0) . . . . write "^SUB to explore subclasses",! "RTN","TMGDRUG",114,0) . . . . Write "^BACKUP to backup to previous category.",! "RTN","TMGDRUG",115,0) . . . . write !,"Here is a list:",!! "RTN","TMGDRUG",116,0) . . . . do ShowRxInClass(ClassIEN) "RTN","TMGDRUG",117,0) . . . . write "End of list for: " "RTN","TMGDRUG",118,0) . . . if Exclude="^SUB" do quit "RTN","TMGDRUG",119,0) . . . . set result=$$MakeSubExClass(ClassIEN,1) "RTN","TMGDRUG",120,0) . . . if Exclude="^BACKUP" do quit "RTN","TMGDRUG",121,0) . . . . if LastClass'="" set ClassIEN=LastClass,Backup=1,Exclude="" "RTN","TMGDRUG",122,0) . . . if Exclude="^" set ClassIEN="",Exclude="",result=0 quit "RTN","TMGDRUG",123,0) . . . if '("YyYESYes"[Exclude) write ! set Exclude="" quit "RTN","TMGDRUG",124,0) . . . set Exclude="" "RTN","TMGDRUG",125,0) . . . write "OK... excluding.",!! "RTN","TMGDRUG",126,0) . . . new TempI set TempI=$get(^TMP("TMGPSExclude",0,"Max"),0) "RTN","TMGDRUG",127,0) . . . set TempI=TempI+1 "RTN","TMGDRUG",128,0) . . . set ^TMP("TMGPSExclude",TempI)=ClassIEN "RTN","TMGDRUG",129,0) . . . set ^TMP("TMGPSExclude",TempI,"CLASS")=Class "RTN","TMGDRUG",130,0) . . . set ^TMP("TMGPSExclude",TempI,"CLASS","CODE")=Code "RTN","TMGDRUG",131,0) . . . set ^TMP("TMGPSExclude",0,ClassIEN)="" "RTN","TMGDRUG",132,0) . . . set ^TMP("TMGPSExclude",0,"Max")=TempI "RTN","TMGDRUG",133,0) . . set LastClass=ClassIEN "RTN","TMGDRUG",134,0) . if ClassIEN="" quit "RTN","TMGDRUG",135,0) . if Backup=0 set ClassIEN=$order(^PS(50.605,ClassIEN)) "RTN","TMGDRUG",136,0) . else set Backup=0 "RTN","TMGDRUG",137,0) . if ChildDetail=0 set ClassIEN="" "RTN","TMGDRUG",138,0) MSECDone "RTN","TMGDRUG",139,0) quit result "RTN","TMGDRUG",140,0) "RTN","TMGDRUG",141,0) "RTN","TMGDRUG",142,0) CodeInCode(TextCode,RefCode) "RTN","TMGDRUG",143,0) ;"Purpose: To see if Text Code is in reference code "RTN","TMGDRUG",144,0) ;" e.g. is AX050 "in" AX00 --> yes "RTN","TMGDRUG",145,0) ;"Result: 1 = match present, 0 = no match "RTN","TMGDRUG",146,0) "RTN","TMGDRUG",147,0) set RefCode=$$Trim^TMGSTUTL(RefCode,"0") ;"convert AX000 -> AX "RTN","TMGDRUG",148,0) new CompCode set CompCode=$extract(TextCode,1,$length(RefCode)) "RTN","TMGDRUG",149,0) quit (CompCode=RefCode) "RTN","TMGDRUG",150,0) "RTN","TMGDRUG",151,0) "RTN","TMGDRUG",152,0) ClassInClass(ClassIEN,TextCode,RefClassIEN) "RTN","TMGDRUG",153,0) ;"Purpose: To return if a class is either equal to, or a child of a Ref Class "RTN","TMGDRUG",154,0) ;"Input: ClassIEN: an IEN from file 50.605 to test "RTN","TMGDRUG",155,0) ;" TextCode: OPTIONAL Text code for drug class, from field #2 in DRUG file #50 "RTN","TMGDRUG",156,0) ;" Note: this is the text code for RefClassIEN, not for ClassIEN "RTN","TMGDRUG",157,0) ;" RefClassIEN: an IEN from file 50.605 to test against "RTN","TMGDRUG",158,0) ;"Results: 1 if ClassIEN=RefClassIEN, or is child of RefClassIEN "RTN","TMGDRUG",159,0) ;" 0 otherwise "RTN","TMGDRUG",160,0) "RTN","TMGDRUG",161,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ClassInClass") "RTN","TMGDRUG",162,0) "RTN","TMGDRUG",163,0) new result set result=0 "RTN","TMGDRUG",164,0) set TextCode=$get(TextCode) "RTN","TMGDRUG",165,0) if +$get(RefClassIEN)=0 goto CICDone "RTN","TMGDRUG",166,0) if +$get(ClassIEN)=0 goto CICDone "RTN","TMGDRUG",167,0) new node set node=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",168,0) new RefCode set RefCode=$piece(node,"^",1) "RTN","TMGDRUG",169,0) "RTN","TMGDRUG",170,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Is Class #",ClassIEN," in Class #",RefClassIEN,"?") "RTN","TMGDRUG",171,0) "RTN","TMGDRUG",172,0) if ClassIEN=RefClassIEN set result=1 goto CICDone "RTN","TMGDRUG",173,0) if (TextCode'="")&($$CodeInCode(TextCode,RefCode)) set result=1 goto CICDone "RTN","TMGDRUG",174,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"looking at node: ",node) "RTN","TMGDRUG",175,0) if node'="" do "RTN","TMGDRUG",176,0) . new code set code=$piece(node,"^",1) "RTN","TMGDRUG",177,0) . new ParentClass set ParentClass=$piece(node,"^",3) "RTN","TMGDRUG",178,0) . if ParentClass=ClassIEN set ParentClass=0 ;"I found one cyclic reference->endless loop. Avoid that. "RTN","TMGDRUG",179,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"parent class=",ParentClass) "RTN","TMGDRUG",180,0) . if +ParentClass'=0 do "RTN","TMGDRUG",181,0) . . if ParentClass=RefClassIEN set result=1 "RTN","TMGDRUG",182,0) . . else do "RTN","TMGDRUG",183,0) . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling recursively ClassInClass(",ParentClass,",",RefClassIEN,")") "RTN","TMGDRUG",184,0) . . . set result=$$ClassInClass(ParentClass,TextCode,RefClassIEN) "RTN","TMGDRUG",185,0) "RTN","TMGDRUG",186,0) CICDone "RTN","TMGDRUG",187,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGDRUG",188,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ClassInClass") "RTN","TMGDRUG",189,0) quit result "RTN","TMGDRUG",190,0) "RTN","TMGDRUG",191,0) "RTN","TMGDRUG",192,0) DrugInClass(DrugIEN,TextCode,ClassIEN) "RTN","TMGDRUG",193,0) ;"Purpose: To see if a drug is in a given class "RTN","TMGDRUG",194,0) ;"Input: DrugIEN: The IEN of a drug in file#50 "RTN","TMGDRUG",195,0) ;" TextCode: Text code for drug class, from field #2 in DRUG file #50 "RTN","TMGDRUG",196,0) ;" ClassIEN: the IEN of a drug class in file #50.605 "RTN","TMGDRUG",197,0) ;"Note: If drug is in a class that is a child of ClassIEN, then "RTN","TMGDRUG",198,0) ;" the drug will be considered to be that class. "RTN","TMGDRUG",199,0) ;"Result: 0 if not in class, 1 if is in class, or child of class. "RTN","TMGDRUG",200,0) "RTN","TMGDRUG",201,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DrugInClass") "RTN","TMGDRUG",202,0) "RTN","TMGDRUG",203,0) new result set result=0 "RTN","TMGDRUG",204,0) if $get(DrugIEN)="" goto DICDone "RTN","TMGDRUG",205,0) if $get(^PSDRUG(DrugIEN,0))="" goto DICDone "RTN","TMGDRUG",206,0) "RTN","TMGDRUG",207,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Is Drug #",DrugIEN," in Class #",ClassIEN,"?") "RTN","TMGDRUG",208,0) "RTN","TMGDRUG",209,0) new node set node=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",210,0) new RefCode set RefCode=$piece(node,"^",1) "RTN","TMGDRUG",211,0) if $$CodeInCode(TextCode,RefCode) set result=1 goto DICDone "RTN","TMGDRUG",212,0) "RTN","TMGDRUG",213,0) new DrugClass "RTN","TMGDRUG",214,0) set DrugClass=$piece($get(^PSDRUG(DrugIEN,"ND")),"^",6) ;"field #25,NATIONAL DRUG CLASS "RTN","TMGDRUG",215,0) set result=$$ClassInClass(DrugClass,TextCode,ClassIEN) "RTN","TMGDRUG",216,0) "RTN","TMGDRUG",217,0) DICDone "RTN","TMGDRUG",218,0) ;"write "DrugInClass result=",result,! "RTN","TMGDRUG",219,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGDRUG",220,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DrugInClass") "RTN","TMGDRUG",221,0) quit result "RTN","TMGDRUG",222,0) "RTN","TMGDRUG",223,0) ShowClHeirarchy(ClassIEN) "RTN","TMGDRUG",224,0) new ParentClass,indent "RTN","TMGDRUG",225,0) set indent="" "RTN","TMGDRUG",226,0) if (+ClassIEN'=0) for do quit:(+ClassIEN=0) "RTN","TMGDRUG",227,0) . new Curnode "RTN","TMGDRUG",228,0) . set Curnode=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",229,0) . write indent,"Class ",ClassIEN," (",$piece(Curnode,"^",1),") ",$piece(Curnode,"^",2),! "RTN","TMGDRUG",230,0) . new node set node=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",231,0) . set ParentClass=$piece(node,"^",3) "RTN","TMGDRUG",232,0) . if ParentClass=ClassIEN set ParentClass=0 ;"I found at least one circular ref. "RTN","TMGDRUG",233,0) . set ClassIEN=ParentClass "RTN","TMGDRUG",234,0) . set indent=indent_". " "RTN","TMGDRUG",235,0) "RTN","TMGDRUG",236,0) quit "RTN","TMGDRUG",237,0) "RTN","TMGDRUG",238,0) "RTN","TMGDRUG",239,0) ShowClass(DrugIEN) "RTN","TMGDRUG",240,0) ;"Purpose: To show a given drug's class, and parent classes "RTN","TMGDRUG",241,0) new DrugClass "RTN","TMGDRUG",242,0) set DrugClass=$piece($get(^PSDRUG(DrugIEN,"ND")),"^",6) "RTN","TMGDRUG",243,0) new ParentClass set ParentClass=0 "RTN","TMGDRUG",244,0) new TextCode,node,Name "RTN","TMGDRUG",245,0) set node=$get(^PSDRUG(DrugIEN,0)) "RTN","TMGDRUG",246,0) set TextCode=$piece(node,"^",2) "RTN","TMGDRUG",247,0) set Name=$piece(node,"^",1) "RTN","TMGDRUG",248,0) "RTN","TMGDRUG",249,0) write "Drug: ",Name," [",TextCode,"]",! "RTN","TMGDRUG",250,0) "RTN","TMGDRUG",251,0) if (+DrugClass'=0) for do quit:(+DrugClass=0) "RTN","TMGDRUG",252,0) . new Curnode "RTN","TMGDRUG",253,0) . set Curnode=$get(^PS(50.605,DrugClass,0)) "RTN","TMGDRUG",254,0) . write "Class (",$piece(Curnode,"^",1),") ",$piece(Curnode,"^",2),! "RTN","TMGDRUG",255,0) . new node set node=$get(^PS(50.605,DrugClass,0)) "RTN","TMGDRUG",256,0) . set ParentClass=$piece(node,"^",3) "RTN","TMGDRUG",257,0) . if ParentClass=ClassIEN set ParentClass=0 ;"I found at least one circular ref. "RTN","TMGDRUG",258,0) . set DrugClass=ParentClass "RTN","TMGDRUG",259,0) else do "RTN","TMGDRUG",260,0) . write "Drug class pointer is null",! "RTN","TMGDRUG",261,0) . write "Free text drug class is",$piece($get(^PSDRUG(DrugIEN,0)),"^",2),! "RTN","TMGDRUG",262,0) "RTN","TMGDRUG",263,0) quit "RTN","TMGDRUG",264,0) "RTN","TMGDRUG",265,0) "RTN","TMGDRUG",266,0) ShowRxInClass(ClassIEN) "RTN","TMGDRUG",267,0) ;"Purpose: to show all drugs in given class "RTN","TMGDRUG",268,0) "RTN","TMGDRUG",269,0) new i,name "RTN","TMGDRUG",270,0) "RTN","TMGDRUG",271,0) set i=$order(^PSDRUG(0)) "RTN","TMGDRUG",272,0) for do quit:(i="") "RTN","TMGDRUG",273,0) . if i="" quit "RTN","TMGDRUG",274,0) . set Name=$piece($get(^PSDRUG(i,0)),"^",1) "RTN","TMGDRUG",275,0) . if Name'="" do "RTN","TMGDRUG",276,0) . . new TextCode "RTN","TMGDRUG",277,0) . . set TextCode=$piece($get(^PSDRUG(i,0)),"^",2) ;"field #2,VA CLASSIFICATION "RTN","TMGDRUG",278,0) . . if $$DrugInClass(i,TextCode,ClassIEN)=1 write " -- ",Name,! "RTN","TMGDRUG",279,0) . set i=$order(^PSDRUG(i)) "RTN","TMGDRUG",280,0) "RTN","TMGDRUG",281,0) SRICDone "RTN","TMGDRUG",282,0) write ! "RTN","TMGDRUG",283,0) quit "RTN","TMGDRUG",284,0) "RTN","TMGDRUG",285,0) "RTN","TMGDRUG",286,0) IsClassNull(DrugIEN) "RTN","TMGDRUG",287,0) ;"Purpose: to return if Drug has no assigned class "RTN","TMGDRUG",288,0) "RTN","TMGDRUG",289,0) new result,node,class "RTN","TMGDRUG",290,0) set node=$get(^PSDRUG(DrugIEN,"ND")) "RTN","TMGDRUG",291,0) set class=+$piece(node,"^",6) "RTN","TMGDRUG",292,0) set result=(class=0) "RTN","TMGDRUG",293,0) quit result "RTN","TMGDRUG",294,0) "RTN","TMGDRUG",295,0) "RTN","TMGDRUG",296,0) IsClassExcluded(ClassIEN) "RTN","TMGDRUG",297,0) ;"Purpose: To see is class is in an excluded class, based on exclusions stored "RTN","TMGDRUG",298,0) ;" in ^TMP("TMGPSExclude") "RTN","TMGDRUG",299,0) ;"Input: ClassIEN -- Class to check if excluded. "RTN","TMGDRUG",300,0) ;"Result: 1 if class is in an already excluded class. "RTN","TMGDRUG",301,0) "RTN","TMGDRUG",302,0) new i,result "RTN","TMGDRUG",303,0) set result=0 "RTN","TMGDRUG",304,0) "RTN","TMGDRUG",305,0) set i=$order(^TMP("TMGPSExclude",0)) "RTN","TMGDRUG",306,0) if i'="" for do quit:(i="")!(result=1) "RTN","TMGDRUG",307,0) . new ExClass "RTN","TMGDRUG",308,0) . set ExClass=$get(^TMP("TMGPSExclude",i)) "RTN","TMGDRUG",309,0) . set result=$$ClassInClass(ClassIEN,,ExClass) "RTN","TMGDRUG",310,0) . set i=$order(^TMP("TMGPSExclude",i)) "RTN","TMGDRUG",311,0) "RTN","TMGDRUG",312,0) quit result "RTN","TMGDRUG",313,0) "RTN","TMGDRUG",314,0) TestExclusions "RTN","TMGDRUG",315,0) new ClassIEN "RTN","TMGDRUG",316,0) "RTN","TMGDRUG",317,0) set ClassIEN=$order(^PS(50.605,0)) ;"file# 50.605 = VA DRUG CLASS CODE "RTN","TMGDRUG",318,0) for do quit:(+ClassIEN=0) "RTN","TMGDRUG",319,0) . new Node set Node=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGDRUG",320,0) . new Code set Code=$piece(Node,"^",1) "RTN","TMGDRUG",321,0) . new Class set Class=$piece(Node,"^",2) "RTN","TMGDRUG",322,0) . new Parent set Parent=+$piece(Node,"^",3) "RTN","TMGDRUG",323,0) . new Type set Type=$piece(Node,"^",4) "RTN","TMGDRUG",324,0) . write ClassIEN," (",Code,"): " "RTN","TMGDRUG",325,0) . if $$IsClassExcluded(ClassIEN)=1 do "RTN","TMGDRUG",326,0) . . write "Excluded:",! "RTN","TMGDRUG",327,0) . . ;"do ShowClHeirarchy(ClassIEN) "RTN","TMGDRUG",328,0) . else write "OK",! "RTN","TMGDRUG",329,0) . set ClassIEN=$order(^PS(50.605,ClassIEN)) "RTN","TMGDRUG",330,0) "RTN","TMGDRUG",331,0) quit "RTN","TMGDRUG",332,0) "RTN","TMGDRUG",333,0) IsRxExcluded(DrugIEN) "RTN","TMGDRUG",334,0) ;"Purpose: To see if drug is in excluded catagory "RTN","TMGDRUG",335,0) ;"Input: DrugIEN -- an IEN from file #50 "RTN","TMGDRUG",336,0) ;"Note: This assumes that an exclusion array has been created in "RTN","TMGDRUG",337,0) ;" ^TMP("TMGPSExclude"), as setup by MakeExList() "RTN","TMGDRUG",338,0) ;"Result: 1 if drug is not wanted (i.e. is excluded) "RTN","TMGDRUG",339,0) ;" 0 otherwise "RTN","TMGDRUG",340,0) "RTN","TMGDRUG",341,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"IsRxExcluded") "RTN","TMGDRUG",342,0) "RTN","TMGDRUG",343,0) new result set result=0 "RTN","TMGDRUG",344,0) new i "RTN","TMGDRUG",345,0) new TextCode "RTN","TMGDRUG",346,0) "RTN","TMGDRUG",347,0) set TextCode=$piece($get(^PSDRUG(DrugIEN,0)),"^",2) ;"field #2,VA CLASSIFICATION (text field) "RTN","TMGDRUG",348,0) "RTN","TMGDRUG",349,0) if $$IsClassNull(DrugIEN)&(TextCode="") do goto IREDone "RTN","TMGDRUG",350,0) . set result=1 "RTN","TMGDRUG",351,0) . write "Excluding drug #`",DrugIEN," due to null class, and empty class code.",! "RTN","TMGDRUG",352,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Is drug is excluded because of no assigned class") "RTN","TMGDRUG",353,0) "RTN","TMGDRUG",354,0) if +$get(DrugIEN)=0 goto IREDone "RTN","TMGDRUG",355,0) set i=$order(^TMP("TMGPSExclude",0)) "RTN","TMGDRUG",356,0) for do quit:(i="")!(result=1) "RTN","TMGDRUG",357,0) . if i="" quit "RTN","TMGDRUG",358,0) . new ExClass "RTN","TMGDRUG",359,0) . set ExClass=$get(^TMP("TMGPSExclude",i)) "RTN","TMGDRUG",360,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Is drug #",DrugIEN," is class named '",^TMP("TMGPSExclude",i,"CLASS"),"'?") "RTN","TMGDRUG",361,0) . set result=$$DrugInClass(DrugIEN,TextCode,ExClass) "RTN","TMGDRUG",362,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"The value of result returned from DrugInClass=",result) "RTN","TMGDRUG",363,0) . set i=$order(^TMP("TMGPSExclude",i)) "RTN","TMGDRUG",364,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"next exclusion class i=",i," result=",result) "RTN","TMGDRUG",365,0) "RTN","TMGDRUG",366,0) IREDone "RTN","TMGDRUG",367,0) ;"write "IsRxExcluded result=",result,! "RTN","TMGDRUG",368,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGDRUG",369,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"IsRxExcluded") "RTN","TMGDRUG",370,0) "RTN","TMGDRUG",371,0) quit result "RTN","TMGDRUG",372,0) "RTN","TMGDRUG",373,0) "RTN","TMGDRUG",374,0) ShowDrugs "RTN","TMGDRUG",375,0) new i "RTN","TMGDRUG",376,0) "RTN","TMGDRUG",377,0) set i=$order(^PSDRUG(0)) "RTN","TMGDRUG",378,0) for do quit:(i="") "RTN","TMGDRUG",379,0) . if i="" quit "RTN","TMGDRUG",380,0) . new Name "RTN","TMGDRUG",381,0) . set Name=$piece($get(^PSDRUG(i,0)),"^",1) "RTN","TMGDRUG",382,0) . new Class set Class=$piece($get(^PSDRUG(i,0)),"^",2) "RTN","TMGDRUG",383,0) . if Name'="" do "RTN","TMGDRUG",384,0) . . write $piece(Name," ",1)," -- ",Class,! "RTN","TMGDRUG",385,0) . set i=$order(^PSDRUG(i)) "RTN","TMGDRUG",386,0) "RTN","TMGDRUG",387,0) quit "RTN","TMGDRUG",388,0) "RTN","TMGDRUG",389,0) ShowNCDrugs "RTN","TMGDRUG",390,0) ;"Show all drugs that do not have an assigned class. "RTN","TMGDRUG",391,0) "RTN","TMGDRUG",392,0) new i,count "RTN","TMGDRUG",393,0) set count=0 "RTN","TMGDRUG",394,0) "RTN","TMGDRUG",395,0) set i=$order(^PSDRUG(0)) "RTN","TMGDRUG",396,0) for do quit:(i="") "RTN","TMGDRUG",397,0) . if i="" quit "RTN","TMGDRUG",398,0) . new Name,node "RTN","TMGDRUG",399,0) . set node=$get(^PSDRUG(i,0)) "RTN","TMGDRUG",400,0) . set Name=$piece(node,"^",1) "RTN","TMGDRUG",401,0) . new TextCode set TextCode=$piece(node,"^",2) "RTN","TMGDRUG",402,0) . new Class set Class=$piece($get(^PSDRUG(i,"ND")),"^",6) "RTN","TMGDRUG",403,0) . if (Name'="")&(TextCode="")&(+Class=0) do "RTN","TMGDRUG",404,0) . . write "`#",i," ",Name," -- TextCode='",TextCode,"' ClassIEN=",Class,! "RTN","TMGDRUG",405,0) . . set count=count+1 "RTN","TMGDRUG",406,0) . set i=$order(^PSDRUG(i)) "RTN","TMGDRUG",407,0) "RTN","TMGDRUG",408,0) write count," drugs with no class assigned.",! "RTN","TMGDRUG",409,0) write "Goodbye.",! "RTN","TMGDRUG",410,0) quit "RTN","TMGDRUG",411,0) "RTN","TMGDRUG",412,0) "RTN","TMGDRUG",413,0) "RTN","TMGDRUG",414,0) ShowExDrugs "RTN","TMGDRUG",415,0) ;"Purpose: Show those members of file 50 that should be excluded "RTN","TMGDRUG",416,0) "RTN","TMGDRUG",417,0) new DBIndent "RTN","TMGDRUG",418,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ShowExDrugs") "RTN","TMGDRUG",419,0) "RTN","TMGDRUG",420,0) new i "RTN","TMGDRUG",421,0) "RTN","TMGDRUG",422,0) write "This will show all entries in File#50 that should be excluded based",! "RTN","TMGDRUG",423,0) write "on exclusion list in ^TMP(""TMGPSExclude"")",!! "RTN","TMGDRUG",424,0) "RTN","TMGDRUG",425,0) new Y,DIC,DIR "RTN","TMGDRUG",426,0) set DIR(0)="Y",DIR("B")="NO" "RTN","TMGDRUG",427,0) set DIR("A")="Store values into a Search Template (for later Fileman use)? " "RTN","TMGDRUG",428,0) do ^DIR "RTN","TMGDRUG",429,0) if Y=1 do "RTN","TMGDRUG",430,0) . set DIC=.401 ;"SORT TEMPLATE, ^DIBT "RTN","TMGDRUG",431,0) . set DIC(0)="MAQE" "RTN","TMGDRUG",432,0) . do ^DIC "RTN","TMGDRUG",433,0) . if +Y kill ^DIBT(+Y,1) "RTN","TMGDRUG",434,0) "RTN","TMGDRUG",435,0) set i=$order(^PSDRUG(0)) "RTN","TMGDRUG",436,0) for do quit:(i="") "RTN","TMGDRUG",437,0) . if i="" quit "RTN","TMGDRUG",438,0) . new Name "RTN","TMGDRUG",439,0) . set Name=$piece($get(^PSDRUG(i,0)),"^",1) "RTN","TMGDRUG",440,0) . new Class set Class=$piece($get(^PSDRUG(i,0)),"^",2) "RTN","TMGDRUG",441,0) . if (Name'="") do "RTN","TMGDRUG",442,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Considering: ",Name) "RTN","TMGDRUG",443,0) . . if ($$IsRxExcluded(i)=1) do "RTN","TMGDRUG",444,0) . . . write "`",i,": ",Name," -- ",Class,! "RTN","TMGDRUG",445,0) . . . if +Y do "RTN","TMGDRUG",446,0) . . . . set ^DIBT(+Y,1,i)="" ;"stuff valus into SORT TEMPLATE, IEN=805 (this is a hack) "RTN","TMGDRUG",447,0) . . else do "RTN","TMGDRUG",448,0) . . . ;write "Not #",i," ",Name,! "RTN","TMGDRUG",449,0) . set i=$order(^PSDRUG(i)) "RTN","TMGDRUG",450,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Next i=",i) "RTN","TMGDRUG",451,0) . ;new cont read "Press Key to Continue",*cont:3600,! "RTN","TMGDRUG",452,0) . ;if $char(cont)="^" set i="" "RTN","TMGDRUG",453,0) "RTN","TMGDRUG",454,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ShowExDrugs") "RTN","TMGDRUG",455,0) "RTN","TMGDRUG",456,0) write !,"goodbye...",! "RTN","TMGDRUG",457,0) quit "RTN","TMGDRUG",458,0) "RTN","TMGDRUG",459,0) "RTN","TMGDRUG",460,0) "RTN","TMGDRUG",461,0) SURxArray ;"Set Up Rx array "RTN","TMGDRUG",462,0) ;"Purpose: To set up the drug file such that the drugs are orderable in CPRS "RTN","TMGDRUG",463,0) ;"Note: In the first part of this function, is will group similar drugs into an "RTN","TMGDRUG",464,0) ;" array like this: "RTN","TMGDRUG",465,0) ;" Array("SILDENAFIL",DrugIEN1)="(full drug name)" "RTN","TMGDRUG",466,0) ;" Array("SILDENAFIL",DrugIEN2)="(full drug name)" "RTN","TMGDRUG",467,0) ;" Array("SILDENAFIL",DrugIEN3)="(full drug name)" "RTN","TMGDRUG",468,0) ;" Array("AMOXICILLIN",DrugIEN1)="(full drug name)" "RTN","TMGDRUG",469,0) ;" Array("AMOXICILLIN",DrugIEN2)="(full drug name)" "RTN","TMGDRUG",470,0) ;" Array("AMOXICILLIN",DrugIEN3)="(full drug name)" "RTN","TMGDRUG",471,0) "RTN","TMGDRUG",472,0) new DBIndent "RTN","TMGDRUG",473,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SURxArray") "RTN","TMGDRUG",474,0) "RTN","TMGDRUG",475,0) new i "RTN","TMGDRUG",476,0) new count set count=0 "RTN","TMGDRUG",477,0) new Class set Class="" "RTN","TMGDRUG",478,0) "RTN","TMGDRUG",479,0) if $data(^TMP("TMGPSExclude"))=0 do MakeExList "RTN","TMGDRUG",480,0) kill ^TMP("TMGPSUSE") "RTN","TMGDRUG",481,0) "RTN","TMGDRUG",482,0) set i=$order(^PSDRUG(0)) "RTN","TMGDRUG",483,0) for do quit:(i="") "RTN","TMGDRUG",484,0) . if i="" quit "RTN","TMGDRUG",485,0) . set count=count+1 "RTN","TMGDRUG",486,0) . new Name "RTN","TMGDRUG",487,0) . set Name=$piece($get(^PSDRUG(i,0)),"^",1) "RTN","TMGDRUG",488,0) . new temp set temp=$$UP^XLFSTR($extract(Name,1,2)) "RTN","TMGDRUG",489,0) . if temp="ZZ" set Name="" "RTN","TMGDRUG",490,0) . ;"new Class set Class=$piece($get(^PSDRUG(i,0)),"^",2) ;"Some bad drugs have no class--> skip "RTN","TMGDRUG",491,0) . set Class="zzz" "RTN","TMGDRUG",492,0) . if (Name'="")&(Class'="") do "RTN","TMGDRUG",493,0) . . set Class=$piece($get(^PSDRUG(i,0)),"^",2) ;"Some bad drugs have no class--> skip "RTN","TMGDRUG",494,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Considering: ",Name) "RTN","TMGDRUG",495,0) . . if ($$IsRxExcluded(i)=0) do "RTN","TMGDRUG",496,0) . . . ;"quit ;"temp "RTN","TMGDRUG",497,0) . . . write Name," -- ",Class,! "RTN","TMGDRUG",498,0) . . . new NamePiece,pi "RTN","TMGDRUG",499,0) . . . for pi=1:1 do quit:(NamePiece="")!(+NamePiece>0) "RTN","TMGDRUG",500,0) . . . . set NamePiece=$piece(Name," ",pi) "RTN","TMGDRUG",501,0) . . . new ShortName set ShortName=$piece(Name," ",1,pi-1) "RTN","TMGDRUG",502,0) . . . if ShortName'="" do "RTN","TMGDRUG",503,0) . . . . write "Converted '",Name,"' --> ",ShortName,! "RTN","TMGDRUG",504,0) . . . . set ^TMP("TMGPSUSE",ShortName,i)=Name "RTN","TMGDRUG",505,0) . . . else write "Couldn't convert: ",Name,! "RTN","TMGDRUG",506,0) . . else write "Excluded: ",Name,! "RTN","TMGDRUG",507,0) . else if (Name'="") write "Skipped `",i," due to no class: ",Name," class=[",Class,"]",! "RTN","TMGDRUG",508,0) . set i=$order(^PSDRUG(i)) "RTN","TMGDRUG",509,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Next i=",i) "RTN","TMGDRUG",510,0) "RTN","TMGDRUG",511,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SURxArray") "RTN","TMGDRUG",512,0) "RTN","TMGDRUG",513,0) write "Processed ",count," records.",! "RTN","TMGDRUG",514,0) write "Done. Goodbye.",! "RTN","TMGDRUG",515,0) "RTN","TMGDRUG",516,0) quit "RTN","TMGDRUG",517,0) "RTN","TMGDRUG",518,0) MakePO(ShortName) ;Make a Pharmacy Orderable Item "RTN","TMGDRUG",519,0) ;"Purpose: To take one entry from the Rx Array (as set up by SURxArray) "RTN","TMGDRUG",520,0) ;" and create a fully linked PHARMACY ORDERABLE ITEM entry (File 50.7). "RTN","TMGDRUG",521,0) ;"Note: When the PHARMACY ORDERABLE ITEM record is created, records that match "RTN","TMGDRUG",522,0) ;" are also created in the ORDERABLE ITEM file (101.43), and the QUICK VIEW "RTN","TMGDRUG",523,0) ;" file (101.44)--although the display text in the QUICK VIEW file must be set. "RTN","TMGDRUG",524,0) ;"Steps: 1. "RTN","TMGDRUG",525,0) "RTN","TMGDRUG",526,0) "RTN","TMGDRUG",527,0) "RTN","TMGEDIT") 0^17^B4891 "RTN","TMGEDIT",1,0) TMGEDIT ;TMG/kst/Interface to allow use of linux editor in Fileman ;03/25/06 "RTN","TMGEDIT",2,0) ;;1.0;TMG-LIB;**1**;01/01/06 "RTN","TMGEDIT",3,0) "RTN","TMGEDIT",4,0) ;"TMG EDITOR FUNCTIONS "RTN","TMGEDIT",5,0) "RTN","TMGEDIT",6,0) ;"======================================================================= "RTN","TMGEDIT",7,0) ;" API -- Public Functions. "RTN","TMGEDIT",8,0) ;"======================================================================= "RTN","TMGEDIT",9,0) ;"$$EDIT(Editor) "RTN","TMGEDIT",10,0) "RTN","TMGEDIT",11,0) ;"======================================================================= "RTN","TMGEDIT",12,0) ;"PRIVATE API FUNCTIONS "RTN","TMGEDIT",13,0) ;"======================================================================= "RTN","TMGEDIT",14,0) "RTN","TMGEDIT",15,0) "RTN","TMGEDIT",16,0) ;"======================================================================= "RTN","TMGEDIT",17,0) ;"======================================================================= "RTN","TMGEDIT",18,0) "RTN","TMGEDIT",19,0) EDIT(Editor) "RTN","TMGEDIT",20,0) ;"Purpose: This will be a shell for a linux editor "RTN","TMGEDIT",21,0) ;"Input: Editor -- the name of the linux editor to use (i.e. vim, joe, pico etc) "RTN","TMGEDIT",22,0) ;" Allowed values: joe,vim,pico "RTN","TMGEDIT",23,0) ;"Note: When this function gets called, VistA sets up some variables "RTN","TMGEDIT",24,0) ;" first to tell what should be edited etc. "RTN","TMGEDIT",25,0) ;" DIC=The global root of the WP field where the text to be edited is "RTN","TMGEDIT",26,0) ;" stored (or where new text should be stored) "RTN","TMGEDIT",27,0) ;" e.g. "^TMG(22702,27,DV," "RTN","TMGEDIT",28,0) ;" (DV is also predefined, so reference to DV in DIC is covered.) "RTN","TMGEDIT",29,0) ;" There are other variables set up re margins etc. I will be ignoring these. "RTN","TMGEDIT",30,0) ;"Results: none "RTN","TMGEDIT",31,0) "RTN","TMGEDIT",32,0) new result set result=0 "RTN","TMGEDIT",33,0) new GlobalP "RTN","TMGEDIT",34,0) "RTN","TMGEDIT",35,0) ;"By limiting value to certain values, it prevents a rouge user from putting a wedged "RTN","TMGEDIT",36,0) ;"linux command into "Editor" and executing a system command through zsystem. "RTN","TMGEDIT",37,0) set Editor=$get(Editor,"rvim") "RTN","TMGEDIT",38,0) if (Editor'="rvim")&(Editor'="joe")&(Editor'="pico") goto EditAbort "RTN","TMGEDIT",39,0) "RTN","TMGEDIT",40,0) ;"Only allow users with programmer access to use joe "RTN","TMGEDIT",41,0) if (Editor="joe") do if result=1 goto EditAbort "RTN","TMGEDIT",42,0) . new AccessCode "RTN","TMGEDIT",43,0) . set AccessCode=$piece(^VA(200,DUZ,0),"^",4) "RTN","TMGEDIT",44,0) . if AccessCode'="@" do "RTN","TMGEDIT",45,0) . . write !!,"*** Sorry. Insufficient security clearance to use insecure 'joe' editor. ***",! "RTN","TMGEDIT",46,0) . . write "Please enter 'User's Toolbox', then 'Edit User Characteristics' at a menu",! "RTN","TMGEDIT",47,0) . . write " option to change PREFERRED EDITOR to something other than JOE.",!! "RTN","TMGEDIT",48,0) . . set result=1 "RTN","TMGEDIT",49,0) "RTN","TMGEDIT",50,0) new EditErrFile set EditErrFile="/tmp/trashjoeoutput.txt" "RTN","TMGEDIT",51,0) "RTN","TMGEDIT",52,0) set GlobalP=$extract(DIC,1,$length(DIC)-1)_")" ;"convert to closed form "RTN","TMGEDIT",53,0) new Filename set Filename=$$UNIQUE^%ZISUTL("/tmp/vistaedit.tmp") "RTN","TMGEDIT",54,0) set result=$$WP2HFSfp^TMGIOUTL(GlobalP,Filename) "RTN","TMGEDIT",55,0) if result=0 goto EditDone "RTN","TMGEDIT",56,0) "RTN","TMGEDIT",57,0) "RTN","TMGEDIT",58,0) new HookCmd "RTN","TMGEDIT",59,0) set HookCmd=Editor_" "_Filename_" 2>"_EditErrFile ;"use NULL instead?? "RTN","TMGEDIT",60,0) zsystem HookCmd "RTN","TMGEDIT",61,0) set result=$ZSYSTEM&255 ;"get result of execution. (low byte only). 0=success "RTN","TMGEDIT",62,0) if result>0 goto EditDone "RTN","TMGEDIT",63,0) "RTN","TMGEDIT",64,0) ;"read file back into global WP "RTN","TMGEDIT",65,0) set result=$$HFS2WPfp^TMGIOUTL(Filename,GlobalP) "RTN","TMGEDIT",66,0) ;"if result=1 do "RTN","TMGEDIT",67,0) "RTN","TMGEDIT",68,0) EditDone "RTN","TMGEDIT",69,0) new temp set temp=$$DelFile^TMGIOUTL(Filename) "RTN","TMGEDIT",70,0) set temp=$$DelFile^TMGIOUTL(Filename_"~") ;"joe editor copies output to filename~ as a backup "RTN","TMGEDIT",71,0) set temp=$$DelFile^TMGIOUTL(EditErrFile) "RTN","TMGEDIT",72,0) EditAbort "RTN","TMGEDIT",73,0) quit "RTN","TMGEDIT",74,0) "RTN","TMGEDIT",75,0) "RTN","TMGEDIT",76,0) "RTN","TMGEDIT",77,0) LinuxEdit(Editor,FullPathName) "RTN","TMGEDIT",78,0) ;"Purpose: This will be a shell for a linux editor "RTN","TMGEDIT",79,0) ;"Input: Editor -- the name of the linux editor to use (i.e. vim, joe, pico etc) "RTN","TMGEDIT",80,0) ;" Allowed values: joe,vim,pico "RTN","TMGEDIT",81,0) ;" FullPathName -- the path name on the Linux HFS to edit. "RTN","TMGEDIT",82,0) ;"Results: none "RTN","TMGEDIT",83,0) "RTN","TMGEDIT",84,0) new result set result=0 "RTN","TMGEDIT",85,0) new GlobalP "RTN","TMGEDIT",86,0) "RTN","TMGEDIT",87,0) ;"By limiting value to certain values, it prevents a rouge user from putting a wedged "RTN","TMGEDIT",88,0) ;"linux command into "Editor" and executing a system command through zsystem. "RTN","TMGEDIT",89,0) set Editor=$get(Editor,"rvim") "RTN","TMGEDIT",90,0) if (Editor'="rvim")&(Editor'="joe")&(Editor'="pico") goto LEditAbort "RTN","TMGEDIT",91,0) "RTN","TMGEDIT",92,0) ;"Only allow users with programmer access to use joe "RTN","TMGEDIT",93,0) if (Editor="joe") do if result=1 goto EditAbort "RTN","TMGEDIT",94,0) . new AccessCode "RTN","TMGEDIT",95,0) . set AccessCode=$piece(^VA(200,DUZ,0),"^",4) "RTN","TMGEDIT",96,0) . if AccessCode'="@" do "RTN","TMGEDIT",97,0) . . write !!,"*** Sorry. Insufficient security clearance to use insecure 'joe' editor. ***",! "RTN","TMGEDIT",98,0) . . write "Please enter 'User's Toolbox', then 'Edit User Characteristics' at a menu",! "RTN","TMGEDIT",99,0) . . write " option to change PREFERRED EDITOR to something other than JOE.",!! "RTN","TMGEDIT",100,0) . . set result=1 "RTN","TMGEDIT",101,0) "RTN","TMGEDIT",102,0) ;"new EditErrFile set EditErrFile="/tmp/trashjoeoutput.txt" "RTN","TMGEDIT",103,0) "RTN","TMGEDIT",104,0) new Filename set Filename=FullPathName "RTN","TMGEDIT",105,0) "RTN","TMGEDIT",106,0) new HookCmd "RTN","TMGEDIT",107,0) ;"set HookCmd=Editor_" "_Filename_" 2>"_EditErrFile ;"use NULL instead?? "RTN","TMGEDIT",108,0) set HookCmd=Editor_" "_Filename "RTN","TMGEDIT",109,0) zsystem HookCmd "RTN","TMGEDIT",110,0) set result=$ZSYSTEM&255 ;"get result of execution. (low byte only). 0=success "RTN","TMGEDIT",111,0) if result>0 goto LEditDone "RTN","TMGEDIT",112,0) "RTN","TMGEDIT",113,0) "RTN","TMGEDIT",114,0) LEditDone "RTN","TMGEDIT",115,0) ;"set temp=$$DelFile^TMGIOUTL(Filename_"~") ;"joe editor copies output to filename~ as a backup "RTN","TMGEDIT",116,0) ;"set temp=$$DelFile^TMGIOUTL(EditErrFile) "RTN","TMGEDIT",117,0) LEditAbort "RTN","TMGEDIT",118,0) quit "RTN","TMGEDIT",119,0) "RTN","TMGEDIT",120,0) "RTN","TMGFMUT") 0^20^B7306 "RTN","TMGFMUT",1,0) TMGFMUT ;TMG/kst/Fileman utility functions ;03/25/06 "RTN","TMGFMUT",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGFMUT",3,0) "RTN","TMGFMUT",4,0) ;"TMG FILEMAN-UTILITY FUNCTIONS "RTN","TMGFMUT",5,0) ;"Kevin Toppenberg MD "RTN","TMGFMUT",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGFMUT",7,0) ;"7-12-2005 "RTN","TMGFMUT",8,0) "RTN","TMGFMUT",9,0) ;"======================================================================= "RTN","TMGFMUT",10,0) ;" API -- Public Functions. "RTN","TMGFMUT",11,0) ;"======================================================================= "RTN","TMGFMUT",12,0) ;"$$PTRLINKS "RTN","TMGFMUT",13,0) ;"$$FilePtrs(File,OutVarP) "RTN","TMGFMUT",14,0) ;"DispArray(ArrayP,DispdList,indentDepth,MaxDepth) "RTN","TMGFMUT",15,0) ;"ASKPTRIN "RTN","TMGFMUT",16,0) ;"ASKMVPTR "RTN","TMGFMUT",17,0) ;"QTMVPTR(Info,PFn) --quietly redirect pointers. "RTN","TMGFMUT",18,0) ;"QTMMVPTR(Info,ShowProgress) --quietly redirect multiple pointers at once. "RTN","TMGFMUT",19,0) ;"$$PtrsIn(File,IEN,Array) "RTN","TMGFMUT",20,0) ;"$$PtrsMIn(IENArray,Array,ShowProgress) "RTN","TMGFMUT",21,0) ;"$$PossPtrs(File,Array) "RTN","TMGFMUT",22,0) "RTN","TMGFMUT",23,0) ;"======================================================================= "RTN","TMGFMUT",24,0) ;"PRIVATE API FUNCTIONS "RTN","TMGFMUT",25,0) ;"======================================================================= "RTN","TMGFMUT",26,0) ;"ScanFile(FInfo,IEN,Array) "RTN","TMGFMUT",27,0) ;"ScanMFile(FInfoArray,IENArray,Array,ShowProgress) "RTN","TMGFMUT",28,0) ;"HandleSubFile(SearchValue,FileArray,Array,IENS,Ref) "RTN","TMGFMUT",29,0) ;"HandleMSubFile(IENArray,FileArray,Array,IENS,Ref) "RTN","TMGFMUT",30,0) "RTN","TMGFMUT",31,0) ;"======================================================================= "RTN","TMGFMUT",32,0) ;"DEPENDENCIES "RTN","TMGFMUT",33,0) ;"======================================================================= "RTN","TMGFMUT",34,0) ;"TMGDBAPI "RTN","TMGFMUT",35,0) ;"======================================================================= "RTN","TMGFMUT",36,0) "RTN","TMGFMUT",37,0) "RTN","TMGFMUT",38,0) PTRLINKS "RTN","TMGFMUT",39,0) ;"Purpose: To examine the Fileman data dictionary for a specified file "RTN","TMGFMUT",40,0) ;" Then tell any pointers out to other files. If found, then display "RTN","TMGFMUT",41,0) ;" this 'dependency'. Then follow trail to that file, and show it's "RTN","TMGFMUT",42,0) ;" 'dependency'. Trail will be followed up to N levels deep (set=6 here) "RTN","TMGFMUT",43,0) ;"Results: 1=OKToContinue, 0=failure "RTN","TMGFMUT",44,0) "RTN","TMGFMUT",45,0) new File,Info,DispdList "RTN","TMGFMUT",46,0) new result "RTN","TMGFMUT",47,0) "RTN","TMGFMUT",48,0) write "Display pointer dependencies between files.",!! "RTN","TMGFMUT",49,0) read "Enter file name or number to explore (^ to abort): ",File,! "RTN","TMGFMUT",50,0) if File="^" goto PTDone "RTN","TMGFMUT",51,0) set result=$$FilePtrs(File,"Info") "RTN","TMGFMUT",52,0) if result=0 write "Error. Aborting. Sorry about that...",!! goto PTDone "RTN","TMGFMUT",53,0) "RTN","TMGFMUT",54,0) do DispArray("Info",.DispdList,0,6) ;"force max depth=6 "RTN","TMGFMUT",55,0) "RTN","TMGFMUT",56,0) PTDone "RTN","TMGFMUT",57,0) quit result "RTN","TMGFMUT",58,0) "RTN","TMGFMUT",59,0) "RTN","TMGFMUT",60,0) FilePtrs(File,OutVarP) "RTN","TMGFMUT",61,0) ;"For File, create array listing those fields with pointers to other files "RTN","TMGFMUT",62,0) ;"Input: File -- can be file name or number to explore "RTN","TMGFMUT",63,0) ;" OutVarP -- the name of array to put results into "RTN","TMGFMUT",64,0) ;"Output: Values are put into @OutVarP as follows: "RTN","TMGFMUT",65,0) ;" @OutVarP@(FileNum,"FILE NAME")=File Name "RTN","TMGFMUT",66,0) ;" @OutVarP@(FileNum,FieldNum)=Field Number "RTN","TMGFMUT",67,0) ;" @OutVarP@(FileNum,FieldNum,"FIELD NAME")=Field Name "RTN","TMGFMUT",68,0) ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference "RTN","TMGFMUT",69,0) ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to "RTN","TMGFMUT",70,0) ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to "RTN","TMGFMUT",71,0) ;" @OutVarP@(FileNum,FieldNum,"X GET")=Code to xecute to get value "RTN","TMGFMUT",72,0) ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,.11),"^",5))" "RTN","TMGFMUT",73,0) ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE "RTN","TMGFMUT",74,0) ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value "RTN","TMGFMUT",75,0) ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,.11),"^",5)=TMGVALUE" "RTN","TMGFMUT",76,0) ;" ** For subfiles ** ... "RTN","TMGFMUT",77,0) ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"FIELD NAME")=Field Name "RTN","TMGFMUT",78,0) ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference "RTN","TMGFMUT",79,0) ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to "RTN","TMGFMUT",80,0) ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to "RTN","TMGFMUT",81,0) ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"X GET")=Code to xecute to get value "RTN","TMGFMUT",82,0) ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5))" "RTN","TMGFMUT",83,0) ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE "RTN","TMGFMUT",84,0) ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value "RTN","TMGFMUT",85,0) ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5)=TMGVALUE" "RTN","TMGFMUT",86,0) ;" ... etc. "RTN","TMGFMUT",87,0) ;"Results: 1=OKToContinue, 0=failure "RTN","TMGFMUT",88,0) "RTN","TMGFMUT",89,0) new TMGptrArray "RTN","TMGFMUT",90,0) new result "RTN","TMGFMUT",91,0) new index "RTN","TMGFMUT",92,0) new FileNum,FileName "RTN","TMGFMUT",93,0) "RTN","TMGFMUT",94,0) set result=$$GetFldList^TMGDBAPI(.File,"TMGptrArray") "RTN","TMGFMUT",95,0) if result=0 goto FPtrDone "RTN","TMGFMUT",96,0) set result=($get(OutVarP)'="") "RTN","TMGFMUT",97,0) if result=0 goto FPtrDone "RTN","TMGFMUT",98,0) if +$get(File)=0 do "RTN","TMGFMUT",99,0) . set FileNum=$$GetFileNum^TMGDBAPI(.File) "RTN","TMGFMUT",100,0) . set FileName=$get(File) "RTN","TMGFMUT",101,0) else do "RTN","TMGFMUT",102,0) . set FileNum=+File "RTN","TMGFMUT",103,0) . set FileName=$$GetFName^TMGDBAPI(FileNum) "RTN","TMGFMUT",104,0) set result=(FileNum'=0) "RTN","TMGFMUT",105,0) if result=0 goto FPtrDone "RTN","TMGFMUT",106,0) "RTN","TMGFMUT",107,0) set index=$order(TMGptrArray("")) "RTN","TMGFMUT",108,0) for do quit:(result=0)!(index="") "RTN","TMGFMUT",109,0) . new fieldnum,TMGFldInfo "RTN","TMGFMUT",110,0) . set fieldnum=index "RTN","TMGFMUT",111,0) . if +fieldnum=0 set result=0 quit "RTN","TMGFMUT",112,0) . do FIELD^DID(FileNum,fieldnum,,"POINTER;MULTIPLE-VALUED","TMGFldInfo","TMGMsg") "RTN","TMGFMUT",113,0) . if $data(TMGMsg) do set result=0 quit "RTN","TMGFMUT",114,0) . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") "RTN","TMGFMUT",115,0) . . if $data(TMGMsg("DIERR"))'=0 do quit "RTN","TMGFMUT",116,0) . . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGFMUT",117,0) . if $get(TMGFldInfo("MULTIPLE-VALUED"))=1 do "RTN","TMGFMUT",118,0) . . ;" handle subfiles via a recursive call "RTN","TMGFMUT",119,0) . . new subfile,subArrayP "RTN","TMGFMUT",120,0) . . set subfile=$$GetSubFileNumber^TMGDBAPI(FileNum,fieldnum) "RTN","TMGFMUT",121,0) . . if subfile=0 quit "RTN","TMGFMUT",122,0) . . set subArrayP=$name(@OutVarP@(FileNum,fieldnum,"SUBFILE")) "RTN","TMGFMUT",123,0) . . ;"set subArrayP=OutVarP "RTN","TMGFMUT",124,0) . . set result=$$FilePtrs(subfile,subArrayP) "RTN","TMGFMUT",125,0) . if $get(TMGFldInfo("POINTER"))'="" do "RTN","TMGFMUT",126,0) . . if +TMGFldInfo("POINTER")>0 quit ;"screen out computed nodes. "RTN","TMGFMUT",127,0) . . if TMGFldInfo("POINTER")[":" quit ;"screen out set type fields "RTN","TMGFMUT",128,0) . . new gref,node0 "RTN","TMGFMUT",129,0) . . set gref=TMGFldInfo("POINTER") "RTN","TMGFMUT",130,0) . . set @OutVarP@(FileNum,"FILE NAME")=FileName "RTN","TMGFMUT",131,0) . . set @OutVarP@(FileNum,fieldnum,"FIELD NAME")=$$GetFldName^TMGDBAPI(FileNum,fieldnum) "RTN","TMGFMUT",132,0) . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","GREF")=gref "RTN","TMGFMUT",133,0) . . set gref="^"_gref_"0)" "RTN","TMGFMUT",134,0) . . ;"write "index=",index," gref=",gref,! "RTN","TMGFMUT",135,0) . . set node0=$get(@gref) "RTN","TMGFMUT",136,0) . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NAME")=$piece(node0,"^",1) "RTN","TMGFMUT",137,0) . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NUMBER")=+$piece(node0,"^",2) "RTN","TMGFMUT",138,0) . . new DD set DD=$get(^DD(FileNum,fieldnum,0)) quit:(DD="") "RTN","TMGFMUT",139,0) . . new nodepce set nodepce=$piece(DD,"^",4) quit:(nodepce="") "RTN","TMGFMUT",140,0) . . new node set node=+$piece(nodepce,";",1) quit:(node="") "RTN","TMGFMUT",141,0) . . new pce set pce=+$piece(nodepce,";",2) quit:(pce'>0) "RTN","TMGFMUT",142,0) . . new thisGL set thisGL=$get(^DIC(FileNum,0,"GL")) "RTN","TMGFMUT",143,0) . . new getCode,setCode "RTN","TMGFMUT",144,0) . . if thisGL="" do quit:(thisGL="") "RTN","TMGFMUT",145,0) . . . ;"Note: I am only going to support 1 sub level. More--> brain hurts! "RTN","TMGFMUT",146,0) . . . new upNum set upNum=$get(^DD(FileNum,0,"UP")) "RTN","TMGFMUT",147,0) . . . if upNum="" quit "RTN","TMGFMUT",148,0) . . . set thisGL=$get(^DIC(upNum,0,"GL")) "RTN","TMGFMUT",149,0) . . . if thisGL="" quit ;"happens with sub-sub.. nodes. "RTN","TMGFMUT",150,0) . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,TMGIEN(1),"_node_")),""^"","_pce_")" "RTN","TMGFMUT",151,0) . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,TMGIEN(1),"_node_"),""^"","_pce_")=TMGVALUE" "RTN","TMGFMUT",152,0) . . else do "RTN","TMGFMUT",153,0) . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,"_node_")),""^"","_pce_")" "RTN","TMGFMUT",154,0) . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,"_node_"),""^"","_pce_")=TMGVALUE" "RTN","TMGFMUT",155,0) . . set @OutVarP@(FileNum,fieldnum,"X GET")=getCode "RTN","TMGFMUT",156,0) . . set @OutVarP@(FileNum,fieldnum,"X SET")=setCode "RTN","TMGFMUT",157,0) . set index=$order(TMGptrArray(index)) "RTN","TMGFMUT",158,0) "RTN","TMGFMUT",159,0) FPtrDone "RTN","TMGFMUT",160,0) quit result "RTN","TMGFMUT",161,0) "RTN","TMGFMUT",162,0) DispArray(ArrayP,DispdList,indentDepth,MaxDepth) "RTN","TMGFMUT",163,0) ;"Purpose: Display array created by FilePtrs (see format there) "RTN","TMGFMUT",164,0) ;"Input: ArrayP : name of array containing information "RTN","TMGFMUT",165,0) ;" DispdList : array (pass by reference) contining list of files already displayed "RTN","TMGFMUT",166,0) ;" DispdList("TIU DOCUMENT")="" "RTN","TMGFMUT",167,0) ;" DispdList("PATIENT")="" etc. "RTN","TMGFMUT",168,0) ;" indentDepth : Number of indents deep this function is. Default=0 "RTN","TMGFMUT",169,0) ;" MaxDepth : maximum number of indents deep allowed. "RTN","TMGFMUT",170,0) "RTN","TMGFMUT",171,0) new i,fieldnum,file,FileName "RTN","TMGFMUT",172,0) set indentDepth=+$get(indentDepth,0) "RTN","TMGFMUT",173,0) new indentS set indentS="" "RTN","TMGFMUT",174,0) for i=1:1:(indentDepth) s indentS=indentS_". " "RTN","TMGFMUT",175,0) "RTN","TMGFMUT",176,0) set file=$order(@ArrayP@("")) "RTN","TMGFMUT",177,0) set FileName=$get(@ArrayP@(file,"FILE NAME")) "RTN","TMGFMUT",178,0) set DispdList(FileName)="" "RTN","TMGFMUT",179,0) if FileName'="" write indentS,"FILE: ",FileName,! "RTN","TMGFMUT",180,0) set fieldnum=$order(@ArrayP@(file,"")) "RTN","TMGFMUT",181,0) for do quit:(+fieldnum=0) "RTN","TMGFMUT",182,0) . if +fieldnum=0 quit "RTN","TMGFMUT",183,0) . new p2FName "RTN","TMGFMUT",184,0) . set p2FName=$get(@ArrayP@(file,fieldnum,"POINTS TO","FILE NAME")) "RTN","TMGFMUT",185,0) . write indentS,"field: ",$get(@ArrayP@(file,fieldnum,"FIELD NAME")),"--> file: ",p2FName "RTN","TMGFMUT",186,0) . if $data(DispdList(p2FName))=0 do "RTN","TMGFMUT",187,0) . . set DispdList(p2FName)="" "RTN","TMGFMUT",188,0) . . if indentDepth0 goto APTDone "RTN","TMGFMUT",216,0) set DIC=File "RTN","TMGFMUT",217,0) do ^DIC "RTN","TMGFMUT",218,0) set IEN=+Y "RTN","TMGFMUT",219,0) if IEN'>0 goto APTDone "RTN","TMGFMUT",220,0) new TMGTIME set TMGTIME=$H "RTN","TMGFMUT",221,0) ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!" "RTN","TMGFMUT",222,0) set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" "RTN","TMGFMUT",223,0) write !!,"Starting File Scan for instances of pointers (references) to this record.",!! "RTN","TMGFMUT",224,0) set result=$$PtrsIn(File,IEN,.Array,PFn) "RTN","TMGFMUT",225,0) if result=0 write !,"There was some problem. Sorry.",!! goto APTDone "RTN","TMGFMUT",226,0) "RTN","TMGFMUT",227,0) if $data(Array) do "RTN","TMGFMUT",228,0) . write !,"Done. Here are results:",! "RTN","TMGFMUT",229,0) . write "Format is: ",! "RTN","TMGFMUT",230,0) . write " Array(File#,IEN,0)=LastCount",! "RTN","TMGFMUT",231,0) . write " Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",! "RTN","TMGFMUT",232,0) . write " Description of parts:",! "RTN","TMGFMUT",233,0) . write " ----------------------",! "RTN","TMGFMUT",234,0) . write " File# -- the file the found entry exists it (may be a subfile number)",! "RTN","TMGFMUT",235,0) . write " IEN -- the record number in file",! "RTN","TMGFMUT",236,0) . write " Note: IEN here is different from the IEN passed in as a parameter",! "RTN","TMGFMUT",237,0) . write " FullRef -- the is the full reference to the found value. e.g.",! "RTN","TMGFMUT",238,0) . write " set value=$piece(@FullRef,""^"",piece)",! "RTN","TMGFMUT",239,0) . write " piece -- piece where value is stored in the node that is specified by FullRef",! "RTN","TMGFMUT",240,0) . write " IENS -- this is provided only for matches in subfiles. ",! "RTN","TMGFMUT",241,0) . write " It is the IENS that may be used in database calls",! "RTN","TMGFMUT",242,0) . write " TopGlobalRef -- this is the global reference for file. If the match is in a",! "RTN","TMGFMUT",243,0) . write " subfile, then this is the global reference of the parent file ",! "RTN","TMGFMUT",244,0) . write " (or the highest grandparent file if the parent file itself is",! "RTN","TMGFMUT",245,0) . write " a subfile)",! "RTN","TMGFMUT",246,0) . zwr Array(*) "RTN","TMGFMUT",247,0) . write "---------------------------",! "RTN","TMGFMUT",248,0) . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),! "RTN","TMGFMUT",249,0) else write !,"No pointers to that record found.",! "RTN","TMGFMUT",250,0) "RTN","TMGFMUT",251,0) APTDone "RTN","TMGFMUT",252,0) quit "RTN","TMGFMUT",253,0) "RTN","TMGFMUT",254,0) "RTN","TMGFMUT",255,0) ASKMVPTR "RTN","TMGFMUT",256,0) ;"Purpose: An interface shell toRedirect any pointer. "RTN","TMGFMUT",257,0) ;" Will ask for name of a file, and then a record in that file. "RTN","TMGFMUT",258,0) ;" Will then pass information to fileman function to move pointers. "RTN","TMGFMUT",259,0) "RTN","TMGFMUT",260,0) ;"Note: Example of array passed to P^DITP "RTN","TMGFMUT",261,0) ;" 23510 is $J "RTN","TMGFMUT",262,0) ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) "RTN","TMGFMUT",263,0) ;" 1646 is IEN to be substituted for all 47's "RTN","TMGFMUT",264,0) ;" "RTN","TMGFMUT",265,0) ;" First part of array is list of all files & fields that point to file "RTN","TMGFMUT",266,0) ;" ---------------- "RTN","TMGFMUT",267,0) ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" "RTN","TMGFMUT",268,0) ;" ... "RTN","TMGFMUT",269,0) ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" "RTN","TMGFMUT",270,0) ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" "RTN","TMGFMUT",271,0) ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" "RTN","TMGFMUT",272,0) ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" "RTN","TMGFMUT",273,0) ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" "RTN","TMGFMUT",274,0) ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" "RTN","TMGFMUT",275,0) ;" "RTN","TMGFMUT",276,0) ;" Second part of array is list of changes that should be made. Only 1 change shown here. "RTN","TMGFMUT",277,0) ;" ---------------- "RTN","TMGFMUT",278,0) ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" "RTN","TMGFMUT",279,0) ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" "RTN","TMGFMUT",280,0) "RTN","TMGFMUT",281,0) new File,fromIEN,toIEN,Array,PFn,result "RTN","TMGFMUT",282,0) new PossPtrs "RTN","TMGFMUT",283,0) "RTN","TMGFMUT",284,0) write !,"Pointer Redirection Utility",! "RTN","TMGFMUT",285,0) write "Will change pointers to FROM to TO value",! "RTN","TMGFMUT",286,0) "RTN","TMGFMUT",287,0) kill DIC "RTN","TMGFMUT",288,0) set DIC("A")="Select File holding records being pointed to: " "RTN","TMGFMUT",289,0) set DIC="^DIC(" "RTN","TMGFMUT",290,0) set DIC(0)="MAQE" "RTN","TMGFMUT",291,0) d ^DIC ;"Get File to search "RTN","TMGFMUT",292,0) set File=+Y "RTN","TMGFMUT",293,0) if File'>0 goto AMPTDone "RTN","TMGFMUT",294,0) "RTN","TMGFMUT",295,0) ;"Get list of files/fields with pointers in "RTN","TMGFMUT",296,0) set result=$$PossPtrs(File,.PossPtrs) if result=0 goto AMPTDone "RTN","TMGFMUT",297,0) if $data(PossPtrs)'>0 goto AMPTDone "RTN","TMGFMUT",298,0) "RTN","TMGFMUT",299,0) set DIC=File "RTN","TMGFMUT",300,0) set DIC("A")="Select Original (i.e OLD) Record: " "RTN","TMGFMUT",301,0) do ^DIC ;"get FROM record in File "RTN","TMGFMUT",302,0) set fromIEN=+Y "RTN","TMGFMUT",303,0) if fromIEN'>0 goto AMPTDone "RTN","TMGFMUT",304,0) "RTN","TMGFMUT",305,0) set DIC("A")="Select New Record: " "RTN","TMGFMUT",306,0) do ^DIC ;"get FROM record in File "RTN","TMGFMUT",307,0) set toIEN=+Y "RTN","TMGFMUT",308,0) if toIEN'>0 goto AMPTDone "RTN","TMGFMUT",309,0) "RTN","TMGFMUT",310,0) ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!" "RTN","TMGFMUT",311,0) ;"new TMGTIME set TMGTIME=$H "RTN","TMGFMUT",312,0) set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""Scanning File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" "RTN","TMGFMUT",313,0) write !!,"Starting File Scan for instances of pointers (references) to this record.",!! "RTN","TMGFMUT",314,0) set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 goto AMPTDone "RTN","TMGFMUT",315,0) "RTN","TMGFMUT",316,0) ;" write !,"Here are possible pointers in (file level)",! "RTN","TMGFMUT",317,0) ;" if $data(PossPtrs) zwr PossPtrs(*) "RTN","TMGFMUT",318,0) "RTN","TMGFMUT",319,0) ;" write !,"Here are actual pointers in",! "RTN","TMGFMUT",320,0) ;" if $data(Array) zwr Array(*) "RTN","TMGFMUT",321,0) "RTN","TMGFMUT",322,0) ;"Now convert to FileMan Format. "RTN","TMGFMUT",323,0) kill ^UTILITY("DIT",$J) "RTN","TMGFMUT",324,0) do Prep4FM(.Array) "RTN","TMGFMUT",325,0) "RTN","TMGFMUT",326,0) if $data(^UTILITY("DIT",$J)) do "RTN","TMGFMUT",327,0) . merge ^UTILITY("DIT",$J,0)=PossPtrs "RTN","TMGFMUT",328,0) . ;"write !,"here are results",! "RTN","TMGFMUT",329,0) . ;" zwr ^UTILITY("DIT",$J,*) "RTN","TMGFMUT",330,0) . set DIR(0)="Y",DIR("B")="YES" "RTN","TMGFMUT",331,0) . set DIR("A")="Ask Fileman to redirect pointers?" "RTN","TMGFMUT",332,0) . set DIR("?")="Enter YES if you want Fileman to change all instances of the FROM record into the TO record." "RTN","TMGFMUT",333,0) . do ^DIR ;"get user response "RTN","TMGFMUT",334,0) . if +Y'=1 quit "RTN","TMGFMUT",335,0) . write "YES",! "RTN","TMGFMUT",336,0) . do PTS^DITP "RTN","TMGFMUT",337,0) else do "RTN","TMGFMUT",338,0) . write "No matches found...",!! "RTN","TMGFMUT",339,0) "RTN","TMGFMUT",340,0) AMPTDone "RTN","TMGFMUT",341,0) quit "RTN","TMGFMUT",342,0) "RTN","TMGFMUT",343,0) "RTN","TMGFMUT",344,0) QTMVPTR(Info,PFn) ;"NOTE: this function hasn't been debugged/tested yet "RTN","TMGFMUT",345,0) ;"Purpose: An interface to quietly redirect any pointer. "RTN","TMGFMUT",346,0) ;"Input: Info, an array containing info for redirecting pointers. "RTN","TMGFMUT",347,0) ;" Format: Note: File can be file name or number. "RTN","TMGFMUT",348,0) ;" Info(File,OldIEN)=newIEN "RTN","TMGFMUT",349,0) ;" Info(File,OldIEN)=newIEN1 "RTN","TMGFMUT",350,0) ;" Info(File,OldIEN)=newIEN "RTN","TMGFMUT",351,0) ;" PFn: OPTIONAL, a progress function (must be a complete M expression) "RTN","TMGFMUT",352,0) ;"Output: all pointers in linked files to OldIEN will be changed to newIEN "RTN","TMGFMUT",353,0) ;"Results: none "RTN","TMGFMUT",354,0) "RTN","TMGFMUT",355,0) ;"Note: Example of array passed to P^DITP "RTN","TMGFMUT",356,0) ;" 23510 is $J "RTN","TMGFMUT",357,0) ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) "RTN","TMGFMUT",358,0) ;" 1646 is IEN to be substituted for all 47's "RTN","TMGFMUT",359,0) ;" "RTN","TMGFMUT",360,0) ;" First part of array is list of all files & fields that point to file "RTN","TMGFMUT",361,0) ;" ---------------- "RTN","TMGFMUT",362,0) ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" "RTN","TMGFMUT",363,0) ;" ... "RTN","TMGFMUT",364,0) ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" "RTN","TMGFMUT",365,0) ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" "RTN","TMGFMUT",366,0) ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" "RTN","TMGFMUT",367,0) ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" "RTN","TMGFMUT",368,0) ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" "RTN","TMGFMUT",369,0) ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" "RTN","TMGFMUT",370,0) ;" "RTN","TMGFMUT",371,0) ;" Second part of array is list of changes that should be made. Only 1 change shown here. "RTN","TMGFMUT",372,0) ;" ---------------- "RTN","TMGFMUT",373,0) ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" "RTN","TMGFMUT",374,0) ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" "RTN","TMGFMUT",375,0) "RTN","TMGFMUT",376,0) new File,Array,result "RTN","TMGFMUT",377,0) set PFn=$get(PFn) "RTN","TMGFMUT",378,0) new Itr,File "RTN","TMGFMUT",379,0) "RTN","TMGFMUT",380,0) ;"Cycle through all files to be changed. "RTN","TMGFMUT",381,0) set File=$$ItrAInit^TMGITR("Info",.Itr) "RTN","TMGFMUT",382,0) if File'="" for do quit:($$ItrANext^TMGITR(.Itr,.File)="") "RTN","TMGFMUT",383,0) . new PossPtrs "RTN","TMGFMUT",384,0) . if +File'=File set File=$$GetFileNum^TMGDBAPI(File) ;Convert File Name to File Number "RTN","TMGFMUT",385,0) . ;"Get list of files/fields with pointers in "RTN","TMGFMUT",386,0) . set result=$$PossPtrs(File,.PossPtrs) if result=0 quit "RTN","TMGFMUT",387,0) . if $data(PossPtrs)'>0 quit "RTN","TMGFMUT",388,0) . kill ^UTILITY("DIT",$J) "RTN","TMGFMUT",389,0) . new fromIEN,toIEN,fromItr "RTN","TMGFMUT",390,0) . set fromIEN=+$$ItrAInit^TMGITR($name(Info(File)),.fromItr) "RTN","TMGFMUT",391,0) . new done2 set done2=0 "RTN","TMGFMUT",392,0) . ;"Cycle through all records to be changed. "RTN","TMGFMUT",393,0) . if fromIEN'=0 for do quit:(+$$ItrANext^TMGITR(.fromItr,.fromIEN)=0)!(done2=1) "RTN","TMGFMUT",394,0) . . set toIEN=$get(Info(File,fromIEN)) "RTN","TMGFMUT",395,0) . . set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 set done2=1 "RTN","TMGFMUT",396,0) . . do Prep4FM(.Array) "RTN","TMGFMUT",397,0) . if $data(^UTILITY("DIT",$J))=0 quit "RTN","TMGFMUT",398,0) . merge ^UTILITY("DIT",$J,0)=PossPtrs "RTN","TMGFMUT",399,0) . do PTS^DITP ;"Note: call separately for each file specified. "RTN","TMGFMUT",400,0) "RTN","TMGFMUT",401,0) QMPTDone "RTN","TMGFMUT",402,0) quit "RTN","TMGFMUT",403,0) "RTN","TMGFMUT",404,0) "RTN","TMGFMUT",405,0) QTMMVPTR(Info,ShowProgress) ;"NOTE: this function hasn't been debugged/tested yet "RTN","TMGFMUT",406,0) ;"Purpose: An interface to quietly redirect multiple pointer. "RTN","TMGFMUT",407,0) ;"NOTE: This functions differes from QTMVPTR in that it can look for all IEN's "RTN","TMGFMUT",408,0) ;" for a given file at once, speeding database access. "RTN","TMGFMUT",409,0) ;"Input: Info, an array containing info for redirecting pointers. "RTN","TMGFMUT",410,0) ;" Format: Note: File can be file name or number. "RTN","TMGFMUT",411,0) ;" Info(File,OldIEN)=newIEN "RTN","TMGFMUT",412,0) ;" Info(File,OldIEN)=newIEN1 "RTN","TMGFMUT",413,0) ;" Info(File,OldIEN)=newIEN "RTN","TMGFMUT",414,0) ;" ShowProgress: if 1, progress bar shown "RTN","TMGFMUT",415,0) ;"Output: all pointers in linked files to OldIEN will be changed to newIEN "RTN","TMGFMUT",416,0) ;"Results: none "RTN","TMGFMUT",417,0) "RTN","TMGFMUT",418,0) ;"Note: Example of array passed to P^DITP "RTN","TMGFMUT",419,0) ;" 23510 is $J "RTN","TMGFMUT",420,0) ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) "RTN","TMGFMUT",421,0) ;" 1646 is IEN to be substituted for all 47's "RTN","TMGFMUT",422,0) ;" "RTN","TMGFMUT",423,0) ;" First part of array is list of all files & fields that point to file "RTN","TMGFMUT",424,0) ;" ---------------- "RTN","TMGFMUT",425,0) ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" "RTN","TMGFMUT",426,0) ;" ... "RTN","TMGFMUT",427,0) ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" "RTN","TMGFMUT",428,0) ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" "RTN","TMGFMUT",429,0) ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" "RTN","TMGFMUT",430,0) ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" "RTN","TMGFMUT",431,0) ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" "RTN","TMGFMUT",432,0) ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" "RTN","TMGFMUT",433,0) ;" "RTN","TMGFMUT",434,0) ;" Second part of array is list of changes that should be made. Only 1 change shown here. "RTN","TMGFMUT",435,0) ;" ---------------- "RTN","TMGFMUT",436,0) ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" "RTN","TMGFMUT",437,0) ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" "RTN","TMGFMUT",438,0) "RTN","TMGFMUT",439,0) new ToFile,Array,result "RTN","TMGFMUT",440,0) set PFn=$get(PFn) "RTN","TMGFMUT",441,0) new Itr "RTN","TMGFMUT",442,0) "RTN","TMGFMUT",443,0) ;"Cycle through all files to be changed. "RTN","TMGFMUT",444,0) set ToFile=$$ItrAInit^TMGITR("Info",.Itr) "RTN","TMGFMUT",445,0) if ToFile'="" for do quit:($$ItrANext^TMGITR(.Itr,.ToFile)="") "RTN","TMGFMUT",446,0) . new PossPtrs "RTN","TMGFMUT",447,0) . if +ToFile'=ToFile set ToFile=$$GetFileNum^TMGDBAPI(ToFile) ;"Convert File Name to File Number "RTN","TMGFMUT",448,0) . ;"Get list of files/fields with pointers in "RTN","TMGFMUT",449,0) . set result=$$PossPtrs(ToFile,.PossPtrs) if result=0 quit "RTN","TMGFMUT",450,0) . if $data(PossPtrs)'>0 quit "RTN","TMGFMUT",451,0) . kill ^UTILITY("DIT",$J) "RTN","TMGFMUT",452,0) . ;"new fromIEN,toIEN,fromItr "RTN","TMGFMUT",453,0) . ;"set fromIEN=+$$ItrAInit^TMGITR($name(Info(ToFile)),.fromItr) "RTN","TMGFMUT",454,0) . new IENArray set IENArray=ToFile "RTN","TMGFMUT",455,0) . merge IENArray=Info(ToFile) "RTN","TMGFMUT",456,0) . set IENArray=ToFile "RTN","TMGFMUT",457,0) . set result=$$PtrsMIn(.IENArray,.Array,.ShowProgress) "RTN","TMGFMUT",458,0) . new toFile2,toIEN,fromFile,fromIEN,Array2 "RTN","TMGFMUT",459,0) . set toFile2="" "RTN","TMGFMUT",460,0) . for set toFile2=$order(Array(toFile2)) quit:(toFile2="") do "RTN","TMGFMUT",461,0) . . set toIEN="" "RTN","TMGFMUT",462,0) . . for set toIEN=$order(Array(toFile2,toIEN)) quit:(toIEN="") do "RTN","TMGFMUT",463,0) . . . set fromFile="" "RTN","TMGFMUT",464,0) . . . for set fromFile=$order(Array(toFile2,toIEN,fromFile)) quit:(fromFile="") do "RTN","TMGFMUT",465,0) . . . . set fromIEN="" "RTN","TMGFMUT",466,0) . . . . for set fromIEN=$order(Array(toFile2,toIEN,fromFile,fromIEN)) quit:(fromIEN="") do "RTN","TMGFMUT",467,0) . . . . . merge Array2(fromFile,fromIEN)=Array(toFile2,toIEN,fromFile,fromIEN) "RTN","TMGFMUT",468,0) . set toFile2="" "RTN","TMGFMUT",469,0) . for set toFile2=$order(Array2(toFile2)) quit:(toFile2="") do "RTN","TMGFMUT",470,0) . . do MPrep4FM(toFile2,.Array2) "RTN","TMGFMUT",471,0) . . if $data(^UTILITY("DIT",$J))=0 quit "RTN","TMGFMUT",472,0) . . merge ^UTILITY("DIT",$J,0)=PossPtrs "RTN","TMGFMUT",473,0) . . do PTS^DITP ;"Note: call separately for each file specified. "RTN","TMGFMUT",474,0) "RTN","TMGFMUT",475,0) QMMPTDone "RTN","TMGFMUT",476,0) quit "RTN","TMGFMUT",477,0) "RTN","TMGFMUT",478,0) "RTN","TMGFMUT",479,0) Prep4FM(Array) "RTN","TMGFMUT",480,0) ;"Purpose: to convert Array with redirection info into format for Fileman "RTN","TMGFMUT",481,0) ;"Input: Array -- PASS BY REFERENCE. An array as created by PtrsIn() "RTN","TMGFMUT",482,0) ;"Output: Data will be put into ^UTILITY('DIT',$J) "RTN","TMGFMUT",483,0) ;"Results: none "RTN","TMGFMUT",484,0) "RTN","TMGFMUT",485,0) ;"Now convert to FileMan Format. "RTN","TMGFMUT",486,0) new iFile,iIEN,count,index,toRef "RTN","TMGFMUT",487,0) set iFile=$order(Array("")) "RTN","TMGFMUT",488,0) if +iFile'=0 for do quit:(+iFile=0) "RTN","TMGFMUT",489,0) . set iIEN=$order(Array(iFile,"")) "RTN","TMGFMUT",490,0) . if +iIEN'=0 for do quit:(+iIEN=0) "RTN","TMGFMUT",491,0) . . set count=+$get(Array(iFile,iIEN,0)) "RTN","TMGFMUT",492,0) . . for index=1:1:count do "RTN","TMGFMUT",493,0) . . . set toRef=$piece($get(Array(iFile,iIEN,count)),";",4) "RTN","TMGFMUT",494,0) . . . set toRef=$extract(toRef,2,999) "RTN","TMGFMUT",495,0) . . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef "RTN","TMGFMUT",496,0) . . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_"" "RTN","TMGFMUT",497,0) . . set iIEN=$order(Array(iFile,iIEN)) "RTN","TMGFMUT",498,0) . set iFile=$order(Array(iFile)) "RTN","TMGFMUT",499,0) "RTN","TMGFMUT",500,0) quit "RTN","TMGFMUT",501,0) "RTN","TMGFMUT",502,0) "RTN","TMGFMUT",503,0) MPrep4FM(fromFile,Array) "RTN","TMGFMUT",504,0) ;"Purpose: to convert Array with redirection info into format for Fileman "RTN","TMGFMUT",505,0) ;"Input: fromFile -- the FromFileNum -- Note: should be called once for "RTN","TMGFMUT",506,0) ;" each File number "RTN","TMGFMUT",507,0) ;" Array -- PASS BY REFERENCE. An array as created by PtrsMIn() "RTN","TMGFMUT",508,0) ;" Array(FromFile#,fromIEN,0)=LastCount "RTN","TMGFMUT",509,0) ;" Array(FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",510,0) ;"Output: Data will be put into ^UTILITY('DIT',$J) "RTN","TMGFMUT",511,0) ;"Results: none "RTN","TMGFMUT",512,0) "RTN","TMGFMUT",513,0) ;"Now convert to FileMan Format. "RTN","TMGFMUT",514,0) new fromIEN set fromIEN="" "RTN","TMGFMUT",515,0) for set fromIEN=$order(Array(fromFile,fromIEN)) quit:(+fromIEN'>0) do "RTN","TMGFMUT",516,0) . new count "RTN","TMGFMUT",517,0) . set count=+$get(Array(fromFile,fromIEN,0)) "RTN","TMGFMUT",518,0) . new index for index=1:1:count do "RTN","TMGFMUT",519,0) . . new toRef "RTN","TMGFMUT",520,0) . . set toRef=$piece($get(Array(fromFile,fromIEN,count)),";",4) "RTN","TMGFMUT",521,0) . . set toRef=$extract(toRef,2,999) "RTN","TMGFMUT",522,0) . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef "RTN","TMGFMUT",523,0) . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_"" "RTN","TMGFMUT",524,0) "RTN","TMGFMUT",525,0) quit "RTN","TMGFMUT",526,0) "RTN","TMGFMUT",527,0) "RTN","TMGFMUT",528,0) PtrsIn(File,IEN,Array,PrgsFn) "RTN","TMGFMUT",529,0) ;"SCOPE: PUBLIC "RTN","TMGFMUT",530,0) ;"Purpose: Create a list of incoming pointers to a given record in given file "RTN","TMGFMUT",531,0) ;"Input: File: The file to investigate (Number or Name) "RTN","TMGFMUT",532,0) ;" IEN: IEN of record to "RTN","TMGFMUT",533,0) ;" Array -- PASS BY REFERENCE. An array to receive results back. "RTN","TMGFMUT",534,0) ;" any prexisting data in Array is killed before filling "RTN","TMGFMUT",535,0) ;" PrgsFn: OPTIONAL -- "RTN","TMGFMUT",536,0) ;" because this search process can be quite lengthy, "RTN","TMGFMUT",537,0) ;" an optional line of M code may be given here that will be executed "RTN","TMGFMUT",538,0) ;" before each file is scanned. The following variables will be defined: "RTN","TMGFMUT",539,0) ;" TMGCODE -- will hold code of current file being scanned. "RTN","TMGFMUT",540,0) ;" TMGTOTAL -- will hold total number of records to scan "RTN","TMGFMUT",541,0) ;" TMGCUR -- will hold count of current record being scanned. "RTN","TMGFMUT",542,0) ;"Output: Array is filled with format as follows: "RTN","TMGFMUT",543,0) ;" Array(File#,IEN,0)=LastCount "RTN","TMGFMUT",544,0) ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",545,0) ;" Description of parts: "RTN","TMGFMUT",546,0) ;" ---------------------- "RTN","TMGFMUT",547,0) ;" File# -- the file the found entry exists it (may be a subfile number) "RTN","TMGFMUT",548,0) ;" IEN -- the record number in file "RTN","TMGFMUT",549,0) ;" Note: IEN here is different from the IEN passed in as a parameter "RTN","TMGFMUT",550,0) ;" FullRef -- the is the full reference to the found value. e.g. "RTN","TMGFMUT",551,0) ;" set value=$piece(@FullRef,"^",piece) "RTN","TMGFMUT",552,0) ;" piece -- the piece where value is stored in the node that is specified by FullRef "RTN","TMGFMUT",553,0) ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls "RTN","TMGFMUT",554,0) ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then "RTN","TMGFMUT",555,0) ;" this is the global reference of the parent file (or the highest grandparent file if "RTN","TMGFMUT",556,0) ;" the parent file itself is a subfile, etc.) "RTN","TMGFMUT",557,0) ;" "RTN","TMGFMUT",558,0) ;"Result: 1 if results found, 0 if error occurred. "RTN","TMGFMUT",559,0) ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT! "RTN","TMGFMUT",560,0) "RTN","TMGFMUT",561,0) kill Array "RTN","TMGFMUT",562,0) new result set result=0 "RTN","TMGFMUT",563,0) new FileNum "RTN","TMGFMUT",564,0) set IEN=+$get(IEN) "RTN","TMGFMUT",565,0) if IEN=0 goto FPIDone ;"NOTE: IEN doesn't have to point to a valid record. "RTN","TMGFMUT",566,0) if $data(File)#10=0 goto FPIDone "RTN","TMGFMUT",567,0) if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number "RTN","TMGFMUT",568,0) else set FileNum=File "RTN","TMGFMUT",569,0) if +FileNum=0 goto FPIDone "RTN","TMGFMUT",570,0) "RTN","TMGFMUT",571,0) new PossArray,TMGCODE "RTN","TMGFMUT",572,0) if $$PossPtrs(File,.PossArray)=0 goto FPIDone "RTN","TMGFMUT",573,0) "RTN","TMGFMUT",574,0) ;"Count number of records to scan "RTN","TMGFMUT",575,0) new TMGCUR set TMGCUR=0 "RTN","TMGFMUT",576,0) new TMGTOTAL set TMGTOTAL=0 "RTN","TMGFMUT",577,0) do "RTN","TMGFMUT",578,0) . new temp set temp=$order(PossArray("")) "RTN","TMGFMUT",579,0) . if temp'="" for do quit:(temp="") "RTN","TMGFMUT",580,0) . . new code set code=PossArray(temp) "RTN","TMGFMUT",581,0) . . new ref set ref=$get(^DIC(+code,0,"GL")) "RTN","TMGFMUT",582,0) . . set ref=$$CREF^DILF(ref) ;"convert open to closed format "RTN","TMGFMUT",583,0) . . new NumRecs "RTN","TMGFMUT",584,0) . . if ref'="" set NumRecs=+$piece(@ref@(0),"^",4) "RTN","TMGFMUT",585,0) . . else set NumRecs=10000 ;"some arbitrary guess of #recs in a subfile "RTN","TMGFMUT",586,0) . . set TMGTOTAL=TMGTOTAL+1 "RTN","TMGFMUT",587,0) . . set TMGTOTAL(TMGTOTAL)=NumRecs "RTN","TMGFMUT",588,0) . . set temp=$order(PossArray(temp)) "RTN","TMGFMUT",589,0) . set temp=$order(TMGTOTAL("")) "RTN","TMGFMUT",590,0) . set TMGTOTAL=1 "RTN","TMGFMUT",591,0) . if temp'="" for do quit:(temp="") "RTN","TMGFMUT",592,0) . . set TMGTOTAL=TMGTOTAL+TMGTOTAL(temp) "RTN","TMGFMUT",593,0) . . set temp=$order(TMGTOTAL(temp)) "RTN","TMGFMUT",594,0) . if TMGTOTAL=0 set TMGTOTAL=1 ;"avoid div by zero issues. "RTN","TMGFMUT",595,0) "RTN","TMGFMUT",596,0) new count set count=1 "RTN","TMGFMUT",597,0) new index set index=$order(PossArray("")) "RTN","TMGFMUT",598,0) if index'="" for do quit:(index="") "RTN","TMGFMUT",599,0) . set TMGCUR=TMGCUR+TMGTOTAL(count) "RTN","TMGFMUT",600,0) . set count=count+1 "RTN","TMGFMUT",601,0) . set TMGCODE=PossArray(index) "RTN","TMGFMUT",602,0) . if $get(PrgsFn)'="" do "RTN","TMGFMUT",603,0) . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGFMUT",604,0) . . xecute PrgsFn "RTN","TMGFMUT",605,0) . do ScanFile(TMGCODE,IEN,.Array) "RTN","TMGFMUT",606,0) . set index=$order(PossArray(index)) "RTN","TMGFMUT",607,0) "RTN","TMGFMUT",608,0) set result=1 "RTN","TMGFMUT",609,0) FPIDone "RTN","TMGFMUT",610,0) quit result "RTN","TMGFMUT",611,0) "RTN","TMGFMUT",612,0) "RTN","TMGFMUT",613,0) PtrsMIn(IENArray,Array,ShowProgress) "RTN","TMGFMUT",614,0) ;"SCOPE: PUBLIC "RTN","TMGFMUT",615,0) ;"Purpose: Create a list of incoming pointers to an array of records in given file "RTN","TMGFMUT",616,0) ;"NOTE: this function differes from PtrsIn because is allows multiple input IEN's "RTN","TMGFMUT",617,0) ;"Input: IENArray: PASS BY REFERENCE. Array of IENs of record in ToFile. Format: "RTN","TMGFMUT",618,0) ;" IENArray=SourceFile# "RTN","TMGFMUT",619,0) ;" IENArray(IEN)="" "RTN","TMGFMUT",620,0) ;" IENArray(IEN)="" "RTN","TMGFMUT",621,0) ;" Array -- PASS BY REFERENCE. An array to receive results back. Format below. "RTN","TMGFMUT",622,0) ;" any prexisting data in Array is killed before filling "RTN","TMGFMUT",623,0) ;" ShowProgress: if 1, progress bar shown "RTN","TMGFMUT",624,0) ;"Output: Array is filled with format as follows: "RTN","TMGFMUT",625,0) ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,0)=LastCount "RTN","TMGFMUT",626,0) ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",627,0) ;" Description of parts: "RTN","TMGFMUT",628,0) ;" ---------------------- "RTN","TMGFMUT",629,0) ;" ToFile# -- the file containing the target IEN record "RTN","TMGFMUT",630,0) ;" ToIEN --the IEN in ToFile "RTN","TMGFMUT",631,0) ;" FromFile# -- the file the found entry exists it (may be a subfile number) "RTN","TMGFMUT",632,0) ;" fromIEN -- the record number in file "RTN","TMGFMUT",633,0) ;" Note: IEN here is different from the IEN passed in as a parameter "RTN","TMGFMUT",634,0) ;" FullRef -- the is the full reference to the found value. e.g. "RTN","TMGFMUT",635,0) ;" set value=$piece(@FullRef,"^",piece) "RTN","TMGFMUT",636,0) ;" piece -- the piece where value is stored in the node that is specified by FullRef "RTN","TMGFMUT",637,0) ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls "RTN","TMGFMUT",638,0) ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then "RTN","TMGFMUT",639,0) ;" this is the global reference of the parent file (or the highest grandparent file if "RTN","TMGFMUT",640,0) ;" the parent file itself is a subfile, etc.) "RTN","TMGFMUT",641,0) ;" "RTN","TMGFMUT",642,0) ;"Result: 1 if results found, 0 if error occurred. "RTN","TMGFMUT",643,0) ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT! "RTN","TMGFMUT",644,0) "RTN","TMGFMUT",645,0) kill Array "RTN","TMGFMUT",646,0) new result set result=0 "RTN","TMGFMUT",647,0) new FileNum "RTN","TMGFMUT",648,0) set ToFile=$get(IENArray) if ToFile="" goto FMPIDone "RTN","TMGFMUT",649,0) if +ToFile=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number "RTN","TMGFMUT",650,0) else set FileNum=ToFile "RTN","TMGFMUT",651,0) if +FileNum=0 goto FMPIDone "RTN","TMGFMUT",652,0) "RTN","TMGFMUT",653,0) new PossArray "RTN","TMGFMUT",654,0) if $$PossPtrs(FileNum,.PossArray)=0 goto FMPIDone "RTN","TMGFMUT",655,0) "RTN","TMGFMUT",656,0) new FInfoArray "RTN","TMGFMUT",657,0) new index set index="" "RTN","TMGFMUT",658,0) for set index=$order(PossArray(index)) quit:(index="") do "RTN","TMGFMUT",659,0) . new tempS set tempS=$get(PossArray(index)) "RTN","TMGFMUT",660,0) . new fromFile set fromFile=$piece(tempS,"^",1) "RTN","TMGFMUT",661,0) . new fromField set fromField=$piece(tempS,"^",2) "RTN","TMGFMUT",662,0) . new fldCode set fldCode=$piece(tempS,"^",3) "RTN","TMGFMUT",663,0) . set FInfoArray(fromFile,fromField)=fldCode "RTN","TMGFMUT",664,0) "RTN","TMGFMUT",665,0) do ScanMFile(.FInfoArray,.IENArray,.Array,.ShowProgress) "RTN","TMGFMUT",666,0) "RTN","TMGFMUT",667,0) set result=1 "RTN","TMGFMUT",668,0) FMPIDone "RTN","TMGFMUT",669,0) quit result "RTN","TMGFMUT",670,0) "RTN","TMGFMUT",671,0) "RTN","TMGFMUT",672,0) ScanFile(FInfo,IEN,Array) "RTN","TMGFMUT",673,0) ;"SCOPE: PUBLIC "RTN","TMGFMUT",674,0) ;"Purpose: To scan one file (from array setup by PossPtrs) for actual pointers to IEN "RTN","TMGFMUT",675,0) ;"Input: FInfo : OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field) "RTN","TMGFMUT",676,0) ;"Examples of possible inputs follow: "RTN","TMGFMUT",677,0) ;"50^62.05^*P50'" "RTN","TMGFMUT",678,0) ;"695^.01^RP50'" "RTN","TMGFMUT",679,0) ;"801.43^.02^RV" "RTN","TMGFMUT",680,0) ;"810.31^.04^V" "RTN","TMGFMUT",681,0) ;"811.902^.01^MVX" "RTN","TMGFMUT",682,0) "RTN","TMGFMUT",683,0) ;"NOTE: Idea for future enhancement: Allow FInfo to hold a list rather than just one value. "RTN","TMGFMUT",684,0) ;" This would be for instances where multiple fields in given record need to be searched "RTN","TMGFMUT",685,0) ;" This might speed up database access times. "RTN","TMGFMUT",686,0) "RTN","TMGFMUT",687,0) ;" IEN : the IEN that pointers should point to, to be considered a match. "RTN","TMGFMUT",688,0) ;" Array : PASS BY REFERENCE. An array to receive results. "RTN","TMGFMUT",689,0) ;"Output: Format of Array output: "RTN","TMGFMUT",690,0) ;" Array(File#,IEN,0)=LastCount "RTN","TMGFMUT",691,0) ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",692,0) ;" Description of parts: "RTN","TMGFMUT",693,0) ;" ---------------------- "RTN","TMGFMUT",694,0) ;" File# -- the file the found entry exists it (may be a subfile number) "RTN","TMGFMUT",695,0) ;" IEN -- the record number in file "RTN","TMGFMUT",696,0) ;" Note: IEN here is different from the IEN passed in as a parameter "RTN","TMGFMUT",697,0) ;" FullRef -- the is the full reference to the found value. e.g. "RTN","TMGFMUT",698,0) ;" set value=$piece(@FullRef,"^",piece) "RTN","TMGFMUT",699,0) ;" piece -- the piece where value is stored in the node that is specified by FullRef "RTN","TMGFMUT",700,0) ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls "RTN","TMGFMUT",701,0) ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then "RTN","TMGFMUT",702,0) ;" this is the global reference of the parent file (or the highest grandparent file if "RTN","TMGFMUT",703,0) ;" the parent file itself is a subfile, etc.) "RTN","TMGFMUT",704,0) ;" "RTN","TMGFMUT",705,0) ;"result : none "RTN","TMGFMUT",706,0) "RTN","TMGFMUT",707,0) new File set File=$piece(FInfo,"^",1) if File="" goto SFDone "RTN","TMGFMUT",708,0) new Field set Field=$piece(FInfo,"^",2) if Field="" goto SFDone "RTN","TMGFMUT",709,0) new Code set Code=$piece(FInfo,"^",3) if Code="" goto SFDone "RTN","TMGFMUT",710,0) new count "RTN","TMGFMUT",711,0) if '((Code["P")!(Code["V")) goto SFDone "RTN","TMGFMUT",712,0) new GRef "RTN","TMGFMUT",713,0) new znode set znode=$get(^DD(File,Field,0)) "RTN","TMGFMUT",714,0) new loc set loc=$piece(znode,"^",4) "RTN","TMGFMUT",715,0) new node set node=$piece(loc,";",1) "RTN","TMGFMUT",716,0) new pce set pce=$piece(loc,";",2) "RTN","TMGFMUT",717,0) if +$$IsSubFile^TMGDBAPI(File) do "RTN","TMGFMUT",718,0) . new FileArray,i,k,FNum,SubInfo "RTN","TMGFMUT",719,0) . set i=0 "RTN","TMGFMUT",720,0) . set FileArray(0)=0 "RTN","TMGFMUT",721,0) . set FileArray(i,"PARENT","LOC")=loc "RTN","TMGFMUT",722,0) . set FNum=File "RTN","TMGFMUT",723,0) . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence "RTN","TMGFMUT",724,0) . . set i=i+1 "RTN","TMGFMUT",725,0) . . set FileArray(i)=FNum "RTN","TMGFMUT",726,0) . . if i=1 set FileArray(0,"FILE")=FNum "RTN","TMGFMUT",727,0) . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do "RTN","TMGFMUT",728,0) . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC") "RTN","TMGFMUT",729,0) . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor "RTN","TMGFMUT",730,0) . . else do "RTN","TMGFMUT",731,0) . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL")) "RTN","TMGFMUT",732,0) . . set FNum=$$IsSubFile^TMGDBAPI(FNum) "RTN","TMGFMUT",733,0) . do HandleSubFile(IEN,.FileArray,.Array) "RTN","TMGFMUT",734,0) else do "RTN","TMGFMUT",735,0) . set GRef=$get(^DIC(File,0,"GL")) "RTN","TMGFMUT",736,0) . new ORef set ORef=GRef "RTN","TMGFMUT",737,0) . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format "RTN","TMGFMUT",738,0) . new index set index=$order(@GRef@(0)) "RTN","TMGFMUT",739,0) . if index'="" for do quit:(index="") "RTN","TMGFMUT",740,0) . . new value set value=$get(@GRef@(index,node)) "RTN","TMGFMUT",741,0) . . if $piece(value,"^",pce)=IEN do "RTN","TMGFMUT",742,0) . . . set Array(File,index,0)=1 "RTN","TMGFMUT",743,0) . . . set Array(File,index,1)=$name(@GRef@(index,node))_";"_pce_";"_""_";"_ORef "RTN","TMGFMUT",744,0) . . set index=$order(@GRef@(index)) "RTN","TMGFMUT",745,0) "RTN","TMGFMUT",746,0) SFDone "RTN","TMGFMUT",747,0) quit "RTN","TMGFMUT",748,0) "RTN","TMGFMUT",749,0) "RTN","TMGFMUT",750,0) ScanMFile(FInfoArray,IENArray,Array,ShowProgress) "RTN","TMGFMUT",751,0) ;"SCOPE: PUBLIC "RTN","TMGFMUT",752,0) ;"Purpose: To scan multiple file (from array setup by PossPtrs) for actual pointers to IENs "RTN","TMGFMUT",753,0) ;"Input: FInfoArray : PASS BY REFERENCE. Format: "RTN","TMGFMUT",754,0) ;" FInfoArray(OtherFile,Field)=FieldCode(piece#2 of 0 node of ^DD entry for field) "RTN","TMGFMUT",755,0) ;" Examples of possible inputs follow: "RTN","TMGFMUT",756,0) ;" FInfoArray(50,62.05)="*P50'" "RTN","TMGFMUT",757,0) ;" FInfoArray(695,.01)="RP50'" "RTN","TMGFMUT",758,0) ;" FInfoArray(801.43,.02)="RV" "RTN","TMGFMUT",759,0) ;" FInfoArray(810.31,.04)="V" "RTN","TMGFMUT",760,0) ;" FInfoArray(811.902,.01)="MVX" "RTN","TMGFMUT",761,0) ;" IENArray : PASS BY REFERENCE. IEN's that pointers should point TO, to be considered a match. "RTN","TMGFMUT",762,0) ;" Format: IENArray=SourceFile "RTN","TMGFMUT",763,0) ;" IENArray(IEN)="" "RTN","TMGFMUT",764,0) ;" IENArray(IEN)="" "RTN","TMGFMUT",765,0) ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format: "RTN","TMGFMUT",766,0) ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount "RTN","TMGFMUT",767,0) ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",768,0) ;" Description of parts: "RTN","TMGFMUT",769,0) ;" ---------------------- "RTN","TMGFMUT",770,0) ;" ToFile# -- the file containing the target IEN record "RTN","TMGFMUT",771,0) ;" ToIEN --the IEN in ToFile "RTN","TMGFMUT",772,0) ;" fromFile# -- the file the found entry exists it (may be a subfile number) "RTN","TMGFMUT",773,0) ;" fromIEN -- the record number in file "RTN","TMGFMUT",774,0) ;" Note: IEN here is different from the IEN passed in as a parameter "RTN","TMGFMUT",775,0) ;" FullRef -- the is the full reference to the found value. e.g. "RTN","TMGFMUT",776,0) ;" set value=$piece(@FullRef,"^",piece) "RTN","TMGFMUT",777,0) ;" piece -- the piece where value is stored in the node that is specified by FullRef "RTN","TMGFMUT",778,0) ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls "RTN","TMGFMUT",779,0) ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then "RTN","TMGFMUT",780,0) ;" this is the global reference of the parent file (or the highest grandparent file if "RTN","TMGFMUT",781,0) ;" the parent file itself is a subfile, etc.) "RTN","TMGFMUT",782,0) ;" ShowProgress: if 1, progress bar shown "RTN","TMGFMUT",783,0) ;" "RTN","TMGFMUT",784,0) ;"result : none "RTN","TMGFMUT",785,0) "RTN","TMGFMUT",786,0) new ToFile set ToFile=+$get(IENArray) "RTN","TMGFMUT",787,0) set ShowProgress=$get(ShowProgress,0) "RTN","TMGFMUT",788,0) new abort set abort=0 "RTN","TMGFMUT",789,0) set fromFile="" "RTN","TMGFMUT",790,0) for set fromFile=$order(FInfoArray(fromFile)) quit:(fromFile="")!abort do "RTN","TMGFMUT",791,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGFMUT",792,0) . write !,"Processing File#: ",fromFile,! "RTN","TMGFMUT",793,0) . new Field set Field="" "RTN","TMGFMUT",794,0) . for set Field=$order(FInfoArray(fromFile,Field)) quit:(Field="") do "RTN","TMGFMUT",795,0) . . write " Field#: ",Field,! "RTN","TMGFMUT",796,0) . . new Code set Code=$get(FInfoArray(fromFile,Field)) if Code="" quit "RTN","TMGFMUT",797,0) . . new count "RTN","TMGFMUT",798,0) . . if '((Code["P")!(Code["V")) goto SFDone "RTN","TMGFMUT",799,0) . . new GRef "RTN","TMGFMUT",800,0) . . new znode set znode=$get(^DD(fromFile,Field,0)) "RTN","TMGFMUT",801,0) . . new loc set loc=$piece(znode,"^",4) "RTN","TMGFMUT",802,0) . . new node set node=$piece(loc,";",1) "RTN","TMGFMUT",803,0) . . new pce set pce=$piece(loc,";",2) "RTN","TMGFMUT",804,0) . . if +$$IsSubFile^TMGDBAPI(fromFile) do "RTN","TMGFMUT",805,0) . . . new FileArray,i,k,FNum,SubInfo "RTN","TMGFMUT",806,0) . . . set i=0 "RTN","TMGFMUT",807,0) . . . set FileArray(0)=0 "RTN","TMGFMUT",808,0) . . . set FileArray(i,"PARENT","LOC")=loc "RTN","TMGFMUT",809,0) . . . set FNum=fromFile "RTN","TMGFMUT",810,0) . . . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence "RTN","TMGFMUT",811,0) . . . . set i=i+1 "RTN","TMGFMUT",812,0) . . . . set FileArray(i)=FNum "RTN","TMGFMUT",813,0) . . . . if i=1 set FileArray(0,"FILE")=FNum "RTN","TMGFMUT",814,0) . . . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do "RTN","TMGFMUT",815,0) . . . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC") "RTN","TMGFMUT",816,0) . . . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor "RTN","TMGFMUT",817,0) . . . . else do "RTN","TMGFMUT",818,0) . . . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL")) "RTN","TMGFMUT",819,0) . . . . set FNum=$$IsSubFile^TMGDBAPI(FNum) "RTN","TMGFMUT",820,0) . . . do HandleMSubFile(.IENArray,.FileArray,.Array) "RTN","TMGFMUT",821,0) . . else do "RTN","TMGFMUT",822,0) . . . set GRef=$get(^DIC(fromFile,0,"GL")) "RTN","TMGFMUT",823,0) . . . new ORef set ORef=GRef "RTN","TMGFMUT",824,0) . . . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format "RTN","TMGFMUT",825,0) . . . new Itr,fromIEN "RTN","TMGFMUT",826,0) . . . set fromIEN=$$ItrAInit^TMGITR(GRef,.Itr) "RTN","TMGFMUT",827,0) . . . if ShowProgress=1 do PrepProgress^TMGITR(.Itr,20,1,"fromIEN") "RTN","TMGFMUT",828,0) . . . if fromIEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.fromIEN)="")!abort "RTN","TMGFMUT",829,0) . . . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGFMUT",830,0) . . . . ;"for set fromIEN=$order(@GRef@(fromIEN)) quit:(fromIEN="") do "RTN","TMGFMUT",831,0) . . . . new valueS set valueS=$get(@GRef@(fromIEN,node)) "RTN","TMGFMUT",832,0) . . . . new ToIEN set ToIEN=$piece(valueS,"^",pce) "RTN","TMGFMUT",833,0) . . . . if $data(IENArray(ToIEN))>0 do "RTN","TMGFMUT",834,0) . . . . . new lastCount set lastCount=+$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1 "RTN","TMGFMUT",835,0) . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=lastCount "RTN","TMGFMUT",836,0) . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,lastCount)=$name(@GRef@(fromIEN,node))_";"_pce_";"_""_";"_ORef "RTN","TMGFMUT",837,0) "RTN","TMGFMUT",838,0) SMFDone "RTN","TMGFMUT",839,0) quit "RTN","TMGFMUT",840,0) "RTN","TMGFMUT",841,0) "RTN","TMGFMUT",842,0) HandleSubFile(SearchValue,FileArray,Array,IENS,Ref) "RTN","TMGFMUT",843,0) ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue. "RTN","TMGFMUT",844,0) ;"Input: SearchValue -- the value to be searched for, in INTERNAL format. "RTN","TMGFMUT",845,0) ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers "RTN","TMGFMUT",846,0) ;" and storage locations. Example: "RTN","TMGFMUT",847,0) ;" FileArra(0,"TOP GL")="^XTV(8989.3," "RTN","TMGFMUT",848,0) ;" FileArra(0,"FILE")=8989.33211 "RTN","TMGFMUT",849,0) ;" FileArra(0)=0 "RTN","TMGFMUT",850,0) ;" FileArra(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece "RTN","TMGFMUT",851,0) ;" FileArra(1)=8989.33211 "RTN","TMGFMUT",852,0) ;" FileArra(1,"PARENT","LOC")="1;0" <--- 1 is storage node "RTN","TMGFMUT",853,0) ;" FileArra(2)=8989.3321 "RTN","TMGFMUT",854,0) ;" FileArra(2,"PARENT","LOC")="1;0" <--- 1 is storage node "RTN","TMGFMUT",855,0) ;" FileArra(3)=8989.332 "RTN","TMGFMUT",856,0) ;" FileArra(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node "RTN","TMGFMUT",857,0) ;" FileArra(4)=8989.3 "RTN","TMGFMUT",858,0) ;" FileArra(4,"PARENT","GL")="^XTV(8989.3," "RTN","TMGFMUT",859,0) ;" Array -- PASS BY REFERENCE. An array the receives any search matches. "RTN","TMGFMUT",860,0) ;" Format is as follows "RTN","TMGFMUT",861,0) ;" Array(File#,IEN,0)=LastCount "RTN","TMGFMUT",862,0) ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",863,0) ;" "RTN","TMGFMUT",864,0) ;" IENS -- OPTIONAL -- used by this function internally during recursive calls "RTN","TMGFMUT",865,0) ;" Ref -- OPTIONAL -- used by this function internally during recursive calls "RTN","TMGFMUT",866,0) "RTN","TMGFMUT",867,0) new index,s,IEN,CRef,pce,node "RTN","TMGFMUT",868,0) set index=$order(FileArray(""),-1) "RTN","TMGFMUT",869,0) set s=$get(FileArray(index,"PARENT","LOC")) "RTN","TMGFMUT",870,0) set node=$piece(s,";",1) "RTN","TMGFMUT",871,0) set pce=+$piece(s,";",2) "RTN","TMGFMUT",872,0) if s'="" do "RTN","TMGFMUT",873,0) . if +node'=node set node=""""_node_"""" "RTN","TMGFMUT",874,0) . set s=node_"," "RTN","TMGFMUT",875,0) else do "RTN","TMGFMUT",876,0) . set s=$get(FileArray(index,"PARENT","GL")) "RTN","TMGFMUT",877,0) . set node="" "RTN","TMGFMUT",878,0) set Ref=$get(Ref)_s "RTN","TMGFMUT",879,0) if Ref="" goto HSFDone "RTN","TMGFMUT",880,0) set CRef=$$CREF^DILF(Ref) "RTN","TMGFMUT",881,0) new subFArray "RTN","TMGFMUT",882,0) merge subFArray=FileArray "RTN","TMGFMUT",883,0) kill subFArray(index) ;"trim top entry from list/array "RTN","TMGFMUT",884,0) if index>0 do "RTN","TMGFMUT",885,0) . set IEN=$order(@CRef@(0)) "RTN","TMGFMUT",886,0) . if +IEN>0 for do quit:(+IEN=0) "RTN","TMGFMUT",887,0) . . new subRef,subIENS "RTN","TMGFMUT",888,0) . . set subRef=Ref_IEN_"," "RTN","TMGFMUT",889,0) . . set subIENS=IEN_","_$get(IENS) "RTN","TMGFMUT",890,0) . . do HandleSubFile(SearchValue,.subFArray,.Array,.subIENS,subRef) "RTN","TMGFMUT",891,0) . . set IEN=$order(@CRef@(IEN)) "RTN","TMGFMUT",892,0) else do "RTN","TMGFMUT",893,0) . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs "RTN","TMGFMUT",894,0) . . set subRef=$$CREF^DILF(subRef) "RTN","TMGFMUT",895,0) . . new p,t set (p,t)=0 "RTN","TMGFMUT",896,0) . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter "RTN","TMGFMUT",897,0) . . ;"new ORef set ORef=$extract(subRef,1,p-1) "RTN","TMGFMUT",898,0) . . set IEN=$piece($extract(subRef,p,99),")",1) "RTN","TMGFMUT",899,0) . . new value set value=$get(@subRef@(node)) "RTN","TMGFMUT",900,0) . . set value=$piece(value,"^",pce) "RTN","TMGFMUT",901,0) . . set value=$piece(value,";",1) ;"I think VARIABLE pointers format is: IEN;file# "RTN","TMGFMUT",902,0) . . if value=SearchValue do "RTN","TMGFMUT",903,0) . . . new tFile set tFile=$get(FileArray(0,"FILE"),"?") "RTN","TMGFMUT",904,0) . . . new count set count=$get(Array(tFile,IEN,0))+1 "RTN","TMGFMUT",905,0) . . . set Array(tFile,IEN,0)=count "RTN","TMGFMUT",906,0) . . . set Array(tFile,IEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL")) "RTN","TMGFMUT",907,0) "RTN","TMGFMUT",908,0) HSFDone "RTN","TMGFMUT",909,0) quit "RTN","TMGFMUT",910,0) "RTN","TMGFMUT",911,0) "RTN","TMGFMUT",912,0) HandleMSubFile(IENArray,FileArray,Array,IENS,Ref) "RTN","TMGFMUT",913,0) ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue. "RTN","TMGFMUT",914,0) ;"Input: IENArray : PASS BY REFERENCE. IEN's to search for in INTERNAL format. "RTN","TMGFMUT",915,0) ;" Format: IENArray=SourceFile "RTN","TMGFMUT",916,0) ;" IENArray(IEN)="" "RTN","TMGFMUT",917,0) ;" IENArray(IEN)="" "RTN","TMGFMUT",918,0) ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers "RTN","TMGFMUT",919,0) ;" and storage locations. Example: "RTN","TMGFMUT",920,0) ;" FileArray(0,"TOP GL")="^XTV(8989.3," "RTN","TMGFMUT",921,0) ;" FileArray(0,"FILE")=8989.33211 "RTN","TMGFMUT",922,0) ;" FileArray(0)=0 "RTN","TMGFMUT",923,0) ;" FileArray(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece "RTN","TMGFMUT",924,0) ;" FileArray(1)=8989.33211 "RTN","TMGFMUT",925,0) ;" FileArray(1,"PARENT","LOC")="1;0" <--- 1 is storage node "RTN","TMGFMUT",926,0) ;" FileArray(2)=8989.3321 "RTN","TMGFMUT",927,0) ;" FileArray(2,"PARENT","LOC")="1;0" <--- 1 is storage node "RTN","TMGFMUT",928,0) ;" FileArray(3)=8989.332 "RTN","TMGFMUT",929,0) ;" FileArray(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node "RTN","TMGFMUT",930,0) ;" FileArray(4)=8989.3 "RTN","TMGFMUT",931,0) ;" FileArray(4,"PARENT","GL")="^XTV(8989.3," "RTN","TMGFMUT",932,0) ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format: "RTN","TMGFMUT",933,0) ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount "RTN","TMGFMUT",934,0) ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef "RTN","TMGFMUT",935,0) ;" Description of parts: "RTN","TMGFMUT",936,0) ;" ---------------------- "RTN","TMGFMUT",937,0) ;" ToFile# -- the file containing the target IEN record "RTN","TMGFMUT",938,0) ;" ToIEN --the IEN in ToFile "RTN","TMGFMUT",939,0) ;" fromFile# -- the file the found entry exists it (may be a subfile number) "RTN","TMGFMUT",940,0) ;" fromIEN -- the record number in file "RTN","TMGFMUT",941,0) ;" Note: IEN here is different from the IEN passed in as a parameter "RTN","TMGFMUT",942,0) ;" FullRef -- the is the full reference to the found value. e.g. "RTN","TMGFMUT",943,0) ;" set value=$piece(@FullRef,"^",piece) "RTN","TMGFMUT",944,0) ;" piece -- the piece where value is stored in the node that is specified by FullRef "RTN","TMGFMUT",945,0) ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls "RTN","TMGFMUT",946,0) ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then "RTN","TMGFMUT",947,0) ;" this is the global reference of the parent file (or the highest grandparent file if "RTN","TMGFMUT",948,0) ;" the parent file itself is a subfile, etc.) "RTN","TMGFMUT",949,0) ;" "RTN","TMGFMUT",950,0) ;" IENS -- OPTIONAL -- used by this function internally during recursive calls "RTN","TMGFMUT",951,0) ;" Ref -- OPTIONAL -- used by this function internally during recursive calls "RTN","TMGFMUT",952,0) "RTN","TMGFMUT",953,0) new ToFile set ToFile=$get(IENArray) "RTN","TMGFMUT",954,0) new index,s,IEN,CRef,pce,node "RTN","TMGFMUT",955,0) set index=$order(FileArray(""),-1) "RTN","TMGFMUT",956,0) set s=$get(FileArray(index,"PARENT","LOC")) "RTN","TMGFMUT",957,0) set node=$piece(s,";",1) "RTN","TMGFMUT",958,0) set pce=+$piece(s,";",2) "RTN","TMGFMUT",959,0) if s'="" do "RTN","TMGFMUT",960,0) . if +node'=node set node=""""_node_"""" "RTN","TMGFMUT",961,0) . set s=node_"," "RTN","TMGFMUT",962,0) else do "RTN","TMGFMUT",963,0) . set s=$get(FileArray(index,"PARENT","GL")) "RTN","TMGFMUT",964,0) . set node="" "RTN","TMGFMUT",965,0) set Ref=$get(Ref)_s "RTN","TMGFMUT",966,0) if Ref="" goto HSFDone "RTN","TMGFMUT",967,0) set CRef=$$CREF^DILF(Ref) "RTN","TMGFMUT",968,0) new subFArray "RTN","TMGFMUT",969,0) merge subFArray=FileArray "RTN","TMGFMUT",970,0) kill subFArray(index) ;"trim top entry from list/array "RTN","TMGFMUT",971,0) if index>0 do "RTN","TMGFMUT",972,0) . set fromIEN=0 "RTN","TMGFMUT",973,0) . for set fromIEN=$order(@CRef@(fromIEN)) quit:(+fromIEN=0) do "RTN","TMGFMUT",974,0) . . new subRef,subIENS "RTN","TMGFMUT",975,0) . . set subRef=Ref_fromIEN_"," "RTN","TMGFMUT",976,0) . . set subIENS=fromIEN_","_$get(IENS) "RTN","TMGFMUT",977,0) . . do HandleMSubFile(.IENArray,.subFArray,.Array,.subIENS,subRef) "RTN","TMGFMUT",978,0) else do "RTN","TMGFMUT",979,0) . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs "RTN","TMGFMUT",980,0) . . set subRef=$$CREF^DILF(subRef) "RTN","TMGFMUT",981,0) . . new p,t set (p,t)=0 "RTN","TMGFMUT",982,0) . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter "RTN","TMGFMUT",983,0) . . ;"new ORef set ORef=$extract(subRef,1,p-1) "RTN","TMGFMUT",984,0) . . set fromIEN=$piece($extract(subRef,p,99),")",1) "RTN","TMGFMUT",985,0) . . new valueS set valueS=$get(@subRef@(node)) "RTN","TMGFMUT",986,0) . . set valueS=$piece(valueS,"^",pce) "RTN","TMGFMUT",987,0) . . new ToIEN set ToIEN=$piece(valueS,";",1) ;"I think VARIABLE pointers format is: IEN;file# "RTN","TMGFMUT",988,0) . . if $data(IENArray(ToIEN))>0 do "RTN","TMGFMUT",989,0) . . . new fromFile set fromFile=$get(FileArray(0,"FILE"),"?") "RTN","TMGFMUT",990,0) . . . new count set count=$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1 "RTN","TMGFMUT",991,0) . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=count "RTN","TMGFMUT",992,0) . . . set Array(ToFile,ToIEN,fromFile,fromIEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL")) "RTN","TMGFMUT",993,0) "RTN","TMGFMUT",994,0) HMSFDone "RTN","TMGFMUT",995,0) quit "RTN","TMGFMUT",996,0) "RTN","TMGFMUT",997,0) "RTN","TMGFMUT",998,0) PossPtrs(File,Array) "RTN","TMGFMUT",999,0) ;"SCOPE: PUBLIC "RTN","TMGFMUT",1000,0) ;"Purpose: to create a list of all possible pointers to a specified file, i.e. all other fields/fields "RTN","TMGFMUT",1001,0) ;" that point to the specified file. "RTN","TMGFMUT",1002,0) ;"Input: File: The file to investigate (Number or Name) "RTN","TMGFMUT",1003,0) ;" Array -- PASS BY REFERENCE. An array to receive results back. "RTN","TMGFMUT",1004,0) ;" any prexisting data in Array is killed before filling "RTN","TMGFMUT",1005,0) ;"Output: Array is filled with format as follows: "RTN","TMGFMUT",1006,0) ;" Array(1)=OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field) "RTN","TMGFMUT",1007,0) ;" Array(2)=OtherFile#^Field#^FieldCode "RTN","TMGFMUT",1008,0) ;"Result: 1 if results found, 0 if error occurred. "RTN","TMGFMUT",1009,0) "RTN","TMGFMUT",1010,0) kill Array "RTN","TMGFMUT",1011,0) new result set result=0 "RTN","TMGFMUT",1012,0) new FileNum "RTN","TMGFMUT",1013,0) if $data(File)#10=0 goto PPtrsDone "RTN","TMGFMUT",1014,0) if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number "RTN","TMGFMUT",1015,0) else set FileNum=File "RTN","TMGFMUT",1016,0) if +FileNum=0 goto PPtrsDone "RTN","TMGFMUT",1017,0) "RTN","TMGFMUT",1018,0) new count set count=1 "RTN","TMGFMUT",1019,0) new PtrFile set PtrFile=$order(^DD(FileNum,0,"PT","")) "RTN","TMGFMUT",1020,0) if PtrFile'="" for do quit:(PtrFile="") "RTN","TMGFMUT",1021,0) . new PtrField set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,"")) "RTN","TMGFMUT",1022,0) . if PtrField'="" for do quit:(PtrField="") "RTN","TMGFMUT",1023,0) . . new s set s=PtrFile_"^"_PtrField "RTN","TMGFMUT",1024,0) . . set s=s_"^"_$piece($get(^DD(PtrFile,PtrField,0)),"^",2) "RTN","TMGFMUT",1025,0) . . set Array(count)=s "RTN","TMGFMUT",1026,0) . . set count=count+1 "RTN","TMGFMUT",1027,0) . . set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,PtrField)) "RTN","TMGFMUT",1028,0) . set PtrFile=$order(^DD(FileNum,0,"PT",PtrFile)) "RTN","TMGFMUT",1029,0) "RTN","TMGFMUT",1030,0) set result=1 "RTN","TMGFMUT",1031,0) PPtrsDone "RTN","TMGFMUT",1032,0) quit result "RTN","TMGFMUT",1033,0) "RTN","TMGFMUT",1034,0) "RTN","TMGFMUT",1035,0) ;"Note: Not fully debugged yet..." "RTN","TMGFMUT",1036,0) SAFEKILL(Array,ShowProgress) "RTN","TMGFMUT",1037,0) ;"Purpose: to safely kill records, including removing any pointers TO them "RTN","TMGFMUT",1038,0) ;"input: pArray -- PASS BY REFERENCE. Expected input Format: "RTN","TMGFMUT",1039,0) ;" Array(File,IEN)=0 "RTN","TMGFMUT",1040,0) ;" Array(File,IEN)=0 "RTN","TMGFMUT",1041,0) ;" ShowProgress: if 1, progress bar shown "RTN","TMGFMUT",1042,0) ;"Output: all pointers in linked files to OldIEN will be changed to newIEN "RTN","TMGFMUT",1043,0) ;"Results: none "RTN","TMGFMUT",1044,0) "RTN","TMGFMUT",1045,0) do QTMMVPTR(.Array,.ShowProgress) "RTN","TMGFMUT",1046,0) quit "RTN","TMGFMUT",1047,0) "RTN","TMGFMUT",1048,0) "RTN","TMGFMUT",1049,0) ASKKILL "RTN","TMGFMUT",1050,0) ;"Purpose: to interact with user and safely kill records "RTN","TMGFMUT",1051,0) ;"Input: none. "RTN","TMGFMUT",1052,0) ;"Output: Records and pointers may be deleted "RTN","TMGFMUT",1053,0) ;"Results: none "RTN","TMGFMUT",1054,0) "RTN","TMGFMUT",1055,0) new DIC,File,X,Y "RTN","TMGFMUT",1056,0) new fromIEN,toIEN "RTN","TMGFMUT",1057,0) new delArray "RTN","TMGFMUT",1058,0) "RTN","TMGFMUT",1059,0) kill DIC "RTN","TMGFMUT",1060,0) set DIC("A")="Select file to delete from: " "RTN","TMGFMUT",1061,0) set DIC="^DIC(" "RTN","TMGFMUT",1062,0) set DIC(0)="MAQE" "RTN","TMGFMUT",1063,0) d ^DIC ;"Get File to search "RTN","TMGFMUT",1064,0) set File=+Y "RTN","TMGFMUT",1065,0) if File'>0 goto ASKKDone "RTN","TMGFMUT",1066,0) "RTN","TMGFMUT",1067,0) new Menu,UsrSlct "RTN","TMGFMUT",1068,0) set Menu(0)="Pick Option for Selecting Record(s) to Safely Delete" "RTN","TMGFMUT",1069,0) set Menu(1)="Manually pick Record(s)"_$char(9)_"ManualPick" "RTN","TMGFMUT",1070,0) set Menu(2)="Select a SET (aka SORT TEMPLATE) Contianing Many Records"_$char(9)_"PickSet" "RTN","TMGFMUT",1071,0) "RTN","TMGFMUT",1072,0) M1 write # "RTN","TMGFMUT",1073,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGFMUT",1074,0) "RTN","TMGFMUT",1075,0) if UsrSlct="ManualPick" goto ManualPick "RTN","TMGFMUT",1076,0) if UsrSlct="PickSet" goto PickSet "RTN","TMGFMUT",1077,0) if UsrSlct="^" goto ASKKDone "RTN","TMGFMUT",1078,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGFMUT",1079,0) goto M1 "RTN","TMGFMUT",1080,0) "RTN","TMGFMUT",1081,0) ManualPick "RTN","TMGFMUT",1082,0) set DIC=File "RTN","TMGFMUT",1083,0) set DIC("A")="Select record to delete: " "RTN","TMGFMUT",1084,0) do ^DIC ;"get FROM record in File "RTN","TMGFMUT",1085,0) write ! "RTN","TMGFMUT",1086,0) set fromIEN=+Y "RTN","TMGFMUT",1087,0) if fromIEN'>0 goto ASKGo "RTN","TMGFMUT",1088,0) set delArray(File,fromIEN)=0 "RTN","TMGFMUT",1089,0) new % set %=2 "RTN","TMGFMUT",1090,0) write "Pick another record" do YN^DICN write ! "RTN","TMGFMUT",1091,0) if %=1 goto ManualPick "RTN","TMGFMUT",1092,0) if %=-1 goto ASKKDone "RTN","TMGFMUT",1093,0) goto ASKGo "RTN","TMGFMUT",1094,0) "RTN","TMGFMUT",1095,0) PickSet new IENArray "RTN","TMGFMUT",1096,0) if $$GetTemplateRecs^TMGXMLUI(File,"IENArray","",1)=0 goto ASKKDone "RTN","TMGFMUT",1097,0) ;"Output: Data is put into pRecs like this: @pRecs@(IEN)="" "RTN","TMGFMUT",1098,0) "RTN","TMGFMUT",1099,0) new IEN set IEN="" "RTN","TMGFMUT",1100,0) for set IEN=$order(IENArray(IEN)) quit:(IEN="") do "RTN","TMGFMUT",1101,0) . set delArray(File,IEN)=0 "RTN","TMGFMUT",1102,0) "RTN","TMGFMUT",1103,0) ASKGo "RTN","TMGFMUT",1104,0) if $data(delArray)=0 goto ASKKDone "RTN","TMGFMUT",1105,0) "RTN","TMGFMUT",1106,0) ;"Get list of files/fields with pointers in "RTN","TMGFMUT",1107,0) set result=$$PossPtrs(File,.PossPtrs) if result=0 goto ASKKDone "RTN","TMGFMUT",1108,0) if $data(PossPtrs)'>0 goto DelRecs "RTN","TMGFMUT",1109,0) "RTN","TMGFMUT",1110,0) do SAFEKILL(.delArray,1) "RTN","TMGFMUT",1111,0) "RTN","TMGFMUT",1112,0) DelRecs ;"Now that pointers to records are deleted, it is safe to remove records themselves "RTN","TMGFMUT",1113,0) "RTN","TMGFMUT",1114,0) set IEN="" "RTN","TMGFMUT",1115,0) new abort set abort=0 "RTN","TMGFMUT",1116,0) for set IEN=$order(IENArray(IEN)) quit:(IEN="")!(abort=1) do "RTN","TMGFMUT",1117,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGFMUT",1118,0) . new TMGFDA,TMGMSG "RTN","TMGFMUT",1119,0) . set TMGFDA(File,IEN_",",.01)="@" "RTN","TMGFMUT",1120,0) . do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGFMUT",1121,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGFMUT",1122,0) "RTN","TMGFMUT",1123,0) ASKKDone "RTN","TMGFMUT",1124,0) quit "RTN","TMGFMUT",1125,0) "RTN","TMGFMUT",1126,0) "RTN","TMGFMUT",1127,0) "RTN","TMGFMUT",1128,0) VerifyPtrs(File,pArray,Verbose,AutoFix) "RTN","TMGFMUT",1129,0) ;"Purpose: to scan a file for pointers OUT that are bad/invalid "RTN","TMGFMUT",1130,0) ;"Input: File : file Name or Number to scan "RTN","TMGFMUT",1131,0) ;" pArray : PASS BY NAME, an OUT PARAMETER. Format: "RTN","TMGFMUT",1132,0) ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr "RTN","TMGFMUT",1133,0) ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr "RTN","TMGFMUT",1134,0) ;" Verbose: OPTIONAL. If 1, then errors immediately written out. "RTN","TMGFMUT",1135,0) ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted. "RTN","TMGFMUT",1136,0) ;"Results: None "RTN","TMGFMUT",1137,0) "RTN","TMGFMUT",1138,0) new PtrsOUT "RTN","TMGFMUT",1139,0) new pPtrsOUT set pPtrsOUT="PtrsOUT" "RTN","TMGFMUT",1140,0) new fileNum "RTN","TMGFMUT",1141,0) if +File=File set fileNum=+File "RTN","TMGFMUT",1142,0) else set fileNum=$$GetFileNum^TMGDBAPI(File) "RTN","TMGFMUT",1143,0) set Verbose=+$get(Verbose) "RTN","TMGFMUT",1144,0) set AutoFix=+$get(AutoFix) "RTN","TMGFMUT",1145,0) "RTN","TMGFMUT",1146,0) if $$FilePtrs(fileNum,pPtrsOUT)=0 goto VPtrDone "RTN","TMGFMUT",1147,0) "RTN","TMGFMUT",1148,0) new Itr,Itr2,TMGIEN,fieldNum "RTN","TMGFMUT",1149,0) new TMGVALUE,code "RTN","TMGFMUT",1150,0) new abort set abort=0 "RTN","TMGFMUT",1151,0) new $etrap set $etrap="set Y=""(Invalid M code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGFMUT",1152,0) "RTN","TMGFMUT",1153,0) do DoVerify(File,pArray,Verbose,AutoFix) ;" Split out code to call it to call itself reentrantly "RTN","TMGFMUT",1154,0) "RTN","TMGFMUT",1155,0) VPtrDone "RTN","TMGFMUT",1156,0) quit "RTN","TMGFMUT",1157,0) "RTN","TMGFMUT",1158,0) "RTN","TMGFMUT",1159,0) DoVerify(fileNum,pArray,Verbose,AutoFix,IENS,pTMGIEN) "RTN","TMGFMUT",1160,0) ;"Purpose: Function allow VerifyPtrs to call reentrantly "RTN","TMGFMUT",1161,0) ;"Input: File : file Name or Number to scan "RTN","TMGFMUT",1162,0) ;" pArray : PASS BY NAME, an OUT PARAMETER. Format: "RTN","TMGFMUT",1163,0) ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr "RTN","TMGFMUT",1164,0) ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr "RTN","TMGFMUT",1165,0) ;" Verbose: OPTIONAL. If 1, then errors immediately written out. "RTN","TMGFMUT",1166,0) ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted. "RTN","TMGFMUT",1167,0) ;" IENS: OPTIONAL. If fileNum is a sub-file, then must supply "RTN","TMGFMUT",1168,0) ;" to give location of subfile in parent file. "RTN","TMGFMUT",1169,0) ;" pTMGIEN: "TMGIEN", or "TMGIEN(1)" etc. "RTN","TMGFMUT",1170,0) ;"Results: None "RTN","TMGFMUT",1171,0) ;"NOTICE: right now this MUST first be called from VerifyPtrs because "RTN","TMGFMUT",1172,0) ;" I have not moved some NEW commandes etc from there to here. "RTN","TMGFMUT",1173,0) ;" So this function depends on it's variables with global scope. "RTN","TMGFMUT",1174,0) "RTN","TMGFMUT",1175,0) set IENS=$get(IENS) "RTN","TMGFMUT",1176,0) set pTMGIEN=$get(pTMGIEN,"TMGIEN") "RTN","TMGFMUT",1177,0) set @pTMGIEN=$$ItrInit^TMGITR(fileNum,.Itr,.IENS) "RTN","TMGFMUT",1178,0) if IENS="" do PrepProgress^TMGITR(.Itr,20,0,pTMGIEN) ;" no bar for subfiles "RTN","TMGFMUT",1179,0) if @pTMGIEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.@pTMGIEN)'>0)!abort "RTN","TMGFMUT",1180,0) . set fieldNum=$$ItrAInit^TMGITR($name(@pPtrsOUT@(fileNum)),.Itr2) "RTN","TMGFMUT",1181,0) . if fieldNum'="" for do quit:(+$$ItrANext^TMGITR(.Itr2,.fieldNum)'>0)!abort "RTN","TMGFMUT",1182,0) . . if (@pTMGIEN#10=0),$$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGFMUT",1183,0) . . ;"Line below handles subfiles "RTN","TMGFMUT",1184,0) . . if $data(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE")) do quit "RTN","TMGFMUT",1185,0) . . . new subFile set subFile=$order(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE","")) "RTN","TMGFMUT",1186,0) . . . set IENS=IENS_@pTMGIEN_"," "RTN","TMGFMUT",1187,0) . . . do DoVerify(subFile,$name(@pArray@("SUBFILE")),.Verbose,.AutoFix,IENS,$name(@pTMGIEN@(1))) "RTN","TMGFMUT",1188,0) . . ;"Otherwise, the usual case.... "RTN","TMGFMUT",1189,0) . . set code=$get(PtrsOUT(fileNum,fieldNum,"X GET")) "RTN","TMGFMUT",1190,0) . . if code="" quit "RTN","TMGFMUT",1191,0) . . xecute code "RTN","TMGFMUT",1192,0) . . if TMGVALUE="" quit "RTN","TMGFMUT",1193,0) . . set TMGVALUE=+TMGVALUE "RTN","TMGFMUT",1194,0) . . if TMGVALUE'>0 do quit "RTN","TMGFMUT",1195,0) . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE "RTN","TMGFMUT",1196,0) . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="") "RTN","TMGFMUT",1197,0) . . . new priorValue set priorValue=TMGVALUE "RTN","TMGFMUT",1198,0) . . . set TMGVALUE="" "RTN","TMGFMUT",1199,0) . . . if 'AutoFix quit "RTN","TMGFMUT",1200,0) . . . xecute setCode "RTN","TMGFMUT",1201,0) . . . if 'Verbose quit "RTN","TMGFMUT",1202,0) . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",! "RTN","TMGFMUT",1203,0) . . . write " fixed...",! "RTN","TMGFMUT",1204,0) . . ;"if (fileNum=2)&(TMGVALUE=777) do quit ;"TEMP!!!! "RTN","TMGFMUT",1205,0) . . ;". set code=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(code="") "RTN","TMGFMUT",1206,0) . . ;". set TMGVALUE=69 "RTN","TMGFMUT",1207,0) . . ;". xecute code "RTN","TMGFMUT",1208,0) . . new PtToGref set PtToGref="^"_$get(PtrsOUT(fileNum,fieldNum,"POINTS TO","GREF")) "RTN","TMGFMUT",1209,0) . . if PtToGref="" do quit "RTN","TMGFMUT",1210,0) . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)="??No reference for pointed to file??" "RTN","TMGFMUT",1211,0) . . . if 'Verbose quit "RTN","TMGFMUT",1212,0) . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Pointer value=[",TMGVALUE,"] but 'No reference for pointed to file (??)'",! "RTN","TMGFMUT",1213,0) . . set PtToGref=PtToGref_TMGVALUE_")" "RTN","TMGFMUT",1214,0) . . if $data(@PtToGref)'>0 do quit "RTN","TMGFMUT",1215,0) . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE "RTN","TMGFMUT",1216,0) . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="") "RTN","TMGFMUT",1217,0) . . . new priorValue set priorValue=TMGVALUE "RTN","TMGFMUT",1218,0) . . . set TMGVALUE="" "RTN","TMGFMUT",1219,0) . . . if 'AutoFix quit "RTN","TMGFMUT",1220,0) . . . xecute setCode "RTN","TMGFMUT",1221,0) . . . if 'Verbose quit "RTN","TMGFMUT",1222,0) . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",! "RTN","TMGFMUT",1223,0) . . . write " fixed...",! "RTN","TMGFMUT",1224,0) if IENS="" do ProgressDone^TMGITR(.Itr) "RTN","TMGFMUT",1225,0) quit "RTN","TMGFMUT",1226,0) "RTN","TMGFMUT",1227,0) "RTN","TMGFMUT",1228,0) ASKVFYPT ;"ASK VERIFY POINTERS "RTN","TMGFMUT",1229,0) ;"Ask user to pick file, then verify pointers for that file. "RTN","TMGFMUT",1230,0) "RTN","TMGFMUT",1231,0) write "NOTICE: this function caused corruption of the database from",! "RTN","TMGFMUT",1232,0) write " deletion of pointers incorrectly. Until this function",! "RTN","TMGFMUT",1233,0) write " (ASKVFYPT^TMGFMUT) is fixed, it may not be used.",!,! "RTN","TMGFMUT",1234,0) do PressToCont^TMGUSRIF "RTN","TMGFMUT",1235,0) goto ASKDone "RTN","TMGFMUT",1236,0) "RTN","TMGFMUT",1237,0) "RTN","TMGFMUT",1238,0) new DIC,X,Y "RTN","TMGFMUT",1239,0) new FileNum,IEN "RTN","TMGFMUT",1240,0) new UseDefault set UseDefault=1 "RTN","TMGFMUT",1241,0) "RTN","TMGFMUT",1242,0) ;"Pick file to dump from "RTN","TMGFMUT",1243,0) ASK1 set DIC=1 "RTN","TMGFMUT",1244,0) set DIC(0)="AEQM" "RTN","TMGFMUT",1245,0) set DIC("A")="SELECT FILE TO VERIFY POINTERS IN: " "RTN","TMGFMUT",1246,0) if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called "RTN","TMGFMUT",1247,0) . do ^DICRW ;" has default value of user's last response "RTN","TMGFMUT",1248,0) else do ^DIC ;doesn't have default value... "RTN","TMGFMUT",1249,0) write ! "RTN","TMGFMUT",1250,0) if +Y'>0 write ! goto ASKDone "RTN","TMGFMUT",1251,0) set FileNum=+Y "RTN","TMGFMUT",1252,0) "RTN","TMGFMUT",1253,0) new BadPtrs "RTN","TMGFMUT",1254,0) new AutoFix,Verbose,% "RTN","TMGFMUT",1255,0) set %=2 "RTN","TMGFMUT",1256,0) write "View details of scan" do YN^DICN write ! "RTN","TMGFMUT",1257,0) if %=-1 goto ASKDone "RTN","TMGFMUT",1258,0) set Verbose=(%=1) "RTN","TMGFMUT",1259,0) "RTN","TMGFMUT",1260,0) set %=2 "RTN","TMGFMUT",1261,0) write "Auto-delete bad pointers (i.e. 0 value, or pointers to empty records)" "RTN","TMGFMUT",1262,0) do YN^DICN write ! "RTN","TMGFMUT",1263,0) if %=-1 goto ASKDone "RTN","TMGFMUT",1264,0) set AutoFix=(%=1) "RTN","TMGFMUT",1265,0) "RTN","TMGFMUT",1266,0) do VerifyPtrs(FileNum,"BadPtrs",Verbose,AutoFix) "RTN","TMGFMUT",1267,0) "RTN","TMGFMUT",1268,0) if $data(BadPtrs) do "RTN","TMGFMUT",1269,0) . new % set %=2 "RTN","TMGFMUT",1270,0) . write "View array of bad pointers" do YN^DICN write ! "RTN","TMGFMUT",1271,0) . if %'=1 quit "RTN","TMGFMUT",1272,0) . do ArrayDump^TMGDEBUG("BadPtrs") "RTN","TMGFMUT",1273,0) else write "No bad pointers. Great!",! "RTN","TMGFMUT",1274,0) "RTN","TMGFMUT",1275,0) do PressToCont^TMGUSRIF "RTN","TMGFMUT",1276,0) "RTN","TMGFMUT",1277,0) ASKDone "RTN","TMGFMUT",1278,0) quit "RTN","TMGGDFN") 0^21^B101576 "RTN","TMGGDFN",1,0) TMGGDFN ;TMG/kst-Get A Patient's IEN (DFN) ;01/01/04 "RTN","TMGGDFN",2,0) ;;1.0;TMG-LIB;**1**;06/04/08 "RTN","TMGGDFN",3,0) "RTN","TMGGDFN",4,0) ;"TMG GET DFN (TMGGDFN) "RTN","TMGGDFN",5,0) ;" "RTN","TMGGDFN",6,0) ;"Purpose: This module will provide functionality for getting a DFN "RTN","TMGGDFN",7,0) ;" (which is the database record number) for a given patient. "RTN","TMGGDFN",8,0) ;" If the patient has not been encountered before, then the patient "RTN","TMGGDFN",9,0) ;" will be added to the database. "RTN","TMGGDFN",10,0) "RTN","TMGGDFN",11,0) ;"======================================================================= "RTN","TMGGDFN",12,0) ;" API -- Public Functions. "RTN","TMGGDFN",13,0) ;"======================================================================= "RTN","TMGGDFN",14,0) ;"$$GetDFN(Info) "RTN","TMGGDFN",15,0) "RTN","TMGGDFN",16,0) ;"======================================================================= "RTN","TMGGDFN",17,0) ;"PRIVATE API FUNCTIONS "RTN","TMGGDFN",18,0) ;"======================================================================= "RTN","TMGGDFN",19,0) ;"Pat2Entry(Patient,Entry) convert a named-node entry, into numeric 'Entry' array: "RTN","TMGGDFN",20,0) ;"LookupPatient(Entry) "RTN","TMGGDFN",21,0) ;"SSNumLookup(SSNum) "RTN","TMGGDFN",22,0) ;"PMSNumLookup(PMSNum) "RTN","TMGGDFN",23,0) ;"ParadigmNumLookup(PMSNum) "RTN","TMGGDFN",24,0) ;"Compare(TestData,dbData,EntryNum) "RTN","TMGGDFN",25,0) ;"CompEntry(TestData,dbDataEntry) "RTN","TMGGDFN",26,0) ;"$$AddToPat(DFN,Entry) "RTN","TMGGDFN",27,0) ;"$$AddNewPt(Entry) "RTN","TMGGDFN",28,0) "RTN","TMGGDFN",29,0) "RTN","TMGGDFN",30,0) ;"======================================================================= "RTN","TMGGDFN",31,0) ;"PRIVATE FUNCTIONS "RTN","TMGGDFN",32,0) ;"======================================================================= "RTN","TMGGDFN",33,0) ;"SSNum2Lookup(SSNum) <--- depreciated "RTN","TMGGDFN",34,0) "RTN","TMGGDFN",35,0) "RTN","TMGGDFN",36,0) GetDFN(Patient) "RTN","TMGGDFN",37,0) ;"Purpose: This code is to ensure that a patient is registered "RTN","TMGGDFN",38,0) ;" It is intended for use during upload of old records "RTN","TMGGDFN",39,0) ;" from another EMR. As each dictation is processed, "RTN","TMGGDFN",40,0) ;" this function will be called with the header info. "RTN","TMGGDFN",41,0) ;" If the patient is already registered, then this function "RTN","TMGGDFN",42,0) ;" will have no effect other than to return the DFN. "RTN","TMGGDFN",43,0) ;" Otherwise, the patient will be registered. "RTN","TMGGDFN",44,0) ;" ??? *I'll have this function used another way as well: If "RTN","TMGGDFN",45,0) ;" only the TMGPTNUM is passed, it will load valid values "RTN","TMGGDFN",46,0) ;" into TMGNAME etc., which can be passed back to the calling "RTN","TMGGDFN",47,0) ;" function (providing that values were passed by reference) "RTN","TMGGDFN",48,0) ;"Input: Patient: Array is loaded with Patient, like this: "RTN","TMGGDFN",49,0) ;" Patient("SSNUM")="123-45-6789" "RTN","TMGGDFN",50,0) ;" Patient("NAME")="DOE,JOHN" "RTN","TMGGDFN",51,0) ;" Patient("DOB")="01-04-69" "RTN","TMGGDFN",52,0) ;" Patient("PATIENTNUM")="12345677" <-- Medic account number "RTN","TMGGDFN",53,0) ;" Patient("SEQUELNUM")="234567890" <-- SequelMedSystems Account number "RTN","TMGGDFN",54,0) ;" Patient("PARADIGMNUM")="234567890" <-- Pardigm Account number "RTN","TMGGDFN",55,0) ;" Patient("SEX")="M" "RTN","TMGGDFN",56,0) ;" Patient("ALIAS")="DOE,JOHNNY" "RTN","TMGGDFN",57,0) ;" -Note: The following are optional, only used if adding a patient "RTN","TMGGDFN",58,0) ;" If adding a patient, and these are not supplied, then defaults of "RTN","TMGGDFN",59,0) ;" Not a veteran, NON-VETERAN type, Not service connected are used "RTN","TMGGDFN",60,0) ;" Patient("VETERAN")= VETERAN Y/N --For my purposes, use NO -- optional "RTN","TMGGDFN",61,0) ;" Patient("PT_TYPE")= "SERVICE CONNECTED?" -- required field -- optional "RTN","TMGGDFN",62,0) ;" Patient("SERVICE_CONNECTED")= "TYPE" - required field -- optional "RTN","TMGGDFN",63,0) "RTN","TMGGDFN",64,0) ;" (TMGFREG) Also, variable with global scope, TMGFREG, is used "RTN","TMGGDFN",65,0) ;" if TMGFREG=1, and patient is not found, then "RTN","TMGGDFN",66,0) ;" patient will be automatically registered as a new patient. "RTN","TMGGDFN",67,0) ;" "RTN","TMGGDFN",68,0) ;"Output: The patient's info is used to register the patient, if they are "RTN","TMGGDFN",69,0) ;" are not already registered "RTN","TMGGDFN",70,0) ;"Result: RETURNS DFN (patient internal entry number), or -1 if not found or added. "RTN","TMGGDFN",71,0) ;"------------------------------------------------------------------------------ "RTN","TMGGDFN",72,0) "RTN","TMGGDFN",73,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetDFN^TMGGDFN") "RTN","TMGGDFN",74,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'Patient' passed for processing:") "RTN","TMGGDFN",75,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Patient") "RTN","TMGGDFN",76,0) "RTN","TMGGDFN",77,0) new result,Entry "RTN","TMGGDFN",78,0) do Pat2Entry(.Patient,.Entry) "RTN","TMGGDFN",79,0) set result=$$LookupPatient(.Entry) "RTN","TMGGDFN",80,0) if result>0 goto ERDone "RTN","TMGGDFN",81,0) ;"1-18-2005 I am going to stop adding patients automatically--I think it "RTN","TMGGDFN",82,0) ;" will make duplicate entries. I should have all patients in now... "RTN","TMGGDFN",83,0) ;"10-15-2005 I will allow the patient to be added automatically if the variable "RTN","TMGGDFN",84,0) ;" with global scope TMGFREG=1 (stands for: TMG FORCE REGISTRATION) "RTN","TMGGDFN",85,0) ;" At this time, this will only be set from ERRORS^TMGUPLD "RTN","TMGGDFN",86,0) set result=-1 ;"signal failure as default "RTN","TMGGDFN",87,0) if $get(TMGFREG)=1 do ;"Allowed gobal-scope variable to force add. "RTN","TMGGDFN",88,0) . set result=$$AddNewPt(.Entry) "RTN","TMGGDFN",89,0) . if result'>0 set result=-1 "RTN","TMGGDFN",90,0) "RTN","TMGGDFN",91,0) ERDone "RTN","TMGGDFN",92,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Resulting DFN (patient record number/IEN)=",result) "RTN","TMGGDFN",93,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetDFN^TMGGDFN") "RTN","TMGGDFN",94,0) "RTN","TMGGDFN",95,0) quit result ;"result=DFN "RTN","TMGGDFN",96,0) "RTN","TMGGDFN",97,0) "RTN","TMGGDFN",98,0) ;"====================================================================== "RTN","TMGGDFN",99,0) "RTN","TMGGDFN",100,0) Pat2Entry(Patient,Entry) "RTN","TMGGDFN",101,0) ;"Purpose: to convert a named-node entry, into numeric 'Entry' array: "RTN","TMGGDFN",102,0) ;"Input: Patient: PASS BY REFERENCE. Array loaded with patient info: "RTN","TMGGDFN",103,0) ;" Patient("SSNUM")="123-45-6789" "RTN","TMGGDFN",104,0) ;" Patient("NAME")="DOE,JOHN" "RTN","TMGGDFN",105,0) ;" Patient("DOB")="01-04-69" "RTN","TMGGDFN",106,0) ;" Patient("PATIENTNUM")="12345677" <-- Medic account number "RTN","TMGGDFN",107,0) ;" Patient("SEQUELNUM")="234567890" <-- SequelMedSystems Account number "RTN","TMGGDFN",108,0) ;" Patient("PARADIGMNUM")="234567890" <-- Pardigm Account number "RTN","TMGGDFN",109,0) ;" Patient("SEX")="M" "RTN","TMGGDFN",110,0) ;" Patient("ALIAS")="DOE,JOHNNY" "RTN","TMGGDFN",111,0) ;" -Note: The following are optional, only used if adding a patient "RTN","TMGGDFN",112,0) ;" If adding a patient, and these are not supplied, then defaults of "RTN","TMGGDFN",113,0) ;" Not a veteran, NON-VETERAN type, Not service connected are used "RTN","TMGGDFN",114,0) ;" Patient("VETERAN")= VETERAN Y/N --For my purposes, use NO -- optional "RTN","TMGGDFN",115,0) ;" Patient("PT_TYPE")= "SERVICE CONNECTED?" -- required field -- optional "RTN","TMGGDFN",116,0) ;" Patient("SERVICE_CONNECTED")= "TYPE" - required field -- optional "RTN","TMGGDFN",117,0) ;" Entry; PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGGDFN",118,0) ;"Results: None "RTN","TMGGDFN",119,0) "RTN","TMGGDFN",120,0) if $data(Patient("NAME")) set Entry(.01)=$get(Patient("NAME")) "RTN","TMGGDFN",121,0) if $data(Patient("SEX")) set Entry(.02)=$get(Patient("SEX")) "RTN","TMGGDFN",122,0) if $data(Patient("DOB")) set Entry(.03)=$get(Patient("DOB")) "RTN","TMGGDFN",123,0) if $data(Patient("SSNUM")) set Entry(.09)=$get(Patient("SSNUM")) "RTN","TMGGDFN",124,0) if $data(Patient("PATIENTNUM")) set Entry(22700)=$get(Patient("PATIENTNUM")) "RTN","TMGGDFN",125,0) if $data(Patient("PMS ACCOUNT NUM")) set Entry(22701)=$get(Patient("PMS ACCOUNT NUM")) "RTN","TMGGDFN",126,0) if $data(Patient("SEQUELNUM")) set Entry(22701)=$get(Patient("SEQUELNUM")) "RTN","TMGGDFN",127,0) if $data(Patient("PARADIGMNUM")) set Entry(22702)=$get(Patient("PARADIGM")) "RTN","TMGGDFN",128,0) if $data(Patient("ALIAS")) set Entry(10,.01)=$get(Patient("ALIAS")) "RTN","TMGGDFN",129,0) "RTN","TMGGDFN",130,0) if $data(Patient("VETERAN")) set Entry(1901)=Patient("VETERAN") "RTN","TMGGDFN",131,0) if $data(Patient("PT_TYPE")) set Entry(.301)=Patient("PT_TYPE") "RTN","TMGGDFN",132,0) if $data(Patient("SERVICE_CONNECTED")) set Entry(391)=Patient("SERVICE_CONNECTED") "RTN","TMGGDFN",133,0) "RTN","TMGGDFN",134,0) quit "RTN","TMGGDFN",135,0) "RTN","TMGGDFN",136,0) "RTN","TMGGDFN",137,0) LookupPatient(Entry) "RTN","TMGGDFN",138,0) ;"Purpose: Search for Patient (an existing entry in the database) "RTN","TMGGDFN",139,0) ;"Input: Entry -- Array is loaded with info, like this: "RTN","TMGGDFN",140,0) ;" set Entry(.01)=Name "RTN","TMGGDFN",141,0) ;" set Entry(.02)=Sex "RTN","TMGGDFN",142,0) ;" set Entry(.03)=DOB "RTN","TMGGDFN",143,0) ;" set Entry(.09)=SSNum "RTN","TMGGDFN",144,0) ;" set Entry(22700)=PtNum "RTN","TMGGDFN",145,0) ;" set Entry(22701)=SequelSystems PMS AccountNumber "RTN","TMGGDFN",146,0) ;" set Entry(22702)=Paradigm PMS AccountNumber "RTN","TMGGDFN",147,0) ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found "RTN","TMGGDFN",148,0) ;"NOTE: For now, I am ignoring any passed Alias info. "RTN","TMGGDFN",149,0) ;"------------------------------------------------------------------------------ "RTN","TMGGDFN",150,0) "RTN","TMGGDFN",151,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"LookupPatient^TMGGDFN") "RTN","TMGGDFN",152,0) "RTN","TMGGDFN",153,0) if $data(cConflict)#10=0 new cConflict set cConflict=0 "RTN","TMGGDFN",154,0) if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 "RTN","TMGGDFN",155,0) if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 "RTN","TMGGDFN",156,0) if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3 "RTN","TMGGDFN",157,0) "RTN","TMGGDFN",158,0) new Missing set Missing=0 "RTN","TMGGDFN",159,0) new BailOut set BailOut=0 "RTN","TMGGDFN",160,0) new result set result=0 ;"set default to no match, or conflict found "RTN","TMGGDFN",161,0) new TMGErrMsg,TMGOutput "RTN","TMGGDFN",162,0) new RecComp "RTN","TMGGDFN",163,0) "RTN","TMGGDFN",164,0) ;"If can find patient by SSNum, then don't look any further (if successful) "RTN","TMGGDFN",165,0) if +$get(Entry(.09))>0 set result=$$SSNumLookup(Entry(.09)) "RTN","TMGGDFN",166,0) if result>0 goto LUDone "RTN","TMGGDFN",167,0) "RTN","TMGGDFN",168,0) ;"If can find patient by SequelMedSystem account number, then don't look any further (if successful) "RTN","TMGGDFN",169,0) if (+$get(Entry(22701))>0),$$FieldExists(22701) set result=$$PMSNumLookup(Entry(22701)) "RTN","TMGGDFN",170,0) if result>0 goto LUDone "RTN","TMGGDFN",171,0) "RTN","TMGGDFN",172,0) ;"If can find patient by Paradigm account number, then don't look any further (if successful) "RTN","TMGGDFN",173,0) if (+$get(Entry(22702))>0),$$FieldExists(22702) set result=$$ParadigmNumLookup(Entry(22702)) "RTN","TMGGDFN",174,0) if result>0 goto LUDone "RTN","TMGGDFN",175,0) "RTN","TMGGDFN",176,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'Entry' passed for processing:") "RTN","TMGGDFN",177,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry") "RTN","TMGGDFN",178,0) "RTN","TMGGDFN",179,0) ;"Below specifies fields to get back. Note: file 2 is PATIENT file. "RTN","TMGGDFN",180,0) new Value set Value=$get(Entry(.01)) "RTN","TMGGDFN",181,0) "RTN","TMGGDFN",182,0) ;"========================================================= "RTN","TMGGDFN",183,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FIND^DIC") "RTN","TMGGDFN",184,0) ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",185,0) do "RTN","TMGGDFN",186,0) . new File set File=2 "RTN","TMGGDFN",187,0) . new IENS set IENS="" "RTN","TMGGDFN",188,0) . new Fields set Fields="@;.01;.02;.03;.09" "RTN","TMGGDFN",189,0) . if $$FieldExists(22700) set Fields=Fields_";22700" "RTN","TMGGDFN",190,0) . ;"new Fields set Fields=".01" "RTN","TMGGDFN",191,0) . new Flags set Flags="M" "RTN","TMGGDFN",192,0) . new MatchValue set MatchValue=Value "RTN","TMGGDFN",193,0) . new Number set Number="*" ;"i.e. max number to return *=all entries. "RTN","TMGGDFN",194,0) . new Indexes set Indexes="" "RTN","TMGGDFN",195,0) . new ScreenCode set ScreenCode="" ;"option screening M code "RTN","TMGGDFN",196,0) . new Ident set Ident="" ;"optional text to accompany each found entry "RTN","TMGGDFN",197,0) . new OutVarP set OutVarP="TMGOutput" "RTN","TMGGDFN",198,0) . new ErrVarP set ErrVarP="TMGErrMsg" "RTN","TMGGDFN",199,0) . ;"if $get(TMGDEBUG)>0 do "RTN","TMGGDFN",200,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent,"Here is search data:") "RTN","TMGGDFN",201,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," File='",File,"'") "RTN","TMGGDFN",202,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," IENS='",IENS,"'") "RTN","TMGGDFN",203,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," Fields='",Fields,"'") "RTN","TMGGDFN",204,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," Flags='",Flags,"'") "RTN","TMGGDFN",205,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," MatchValue='",MatchValue,"'") "RTN","TMGGDFN",206,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," Number='",Number,"'") "RTN","TMGGDFN",207,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," Indexes='",Indexes,"'") "RTN","TMGGDFN",208,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," ScreenCode='",ScreenCode,"'") "RTN","TMGGDFN",209,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," Ident='",Ident,"'") "RTN","TMGGDFN",210,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," OutVarP='",OutVarP,"'") "RTN","TMGGDFN",211,0) . ;". do DebugMsg^TMGDEBUG(.DBIndent," ErrVarP='",ErrVarP,"'") "RTN","TMGGDFN",212,0) . do FIND^DIC(File,IENS,Fields,Flags,MatchValue,Number,Indexes,ScreenCode,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",213,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FIND^DIC") "RTN","TMGGDFN",214,0) ;"========================================================= "RTN","TMGGDFN",215,0) "RTN","TMGGDFN",216,0) ;"----------------------------------------------------------- "RTN","TMGGDFN",217,0) ;"Here is an example of the output of FIND^DIC(): "RTN","TMGGDFN",218,0) ;"TMGOutput("DILIST",0)="2^*^0^" <-2 matches "RTN","TMGGDFN",219,0) ;"TMGOutput("DILIST",0,"MAP")=".01^.02^.03^.09^22700" "RTN","TMGGDFN",220,0) ;"TMGOutput("DILIST",2,1)=16 "RTN","TMGGDFN",221,0) ;"TMGOutput("DILIST",2,2)=2914 "RTN","TMGGDFN",222,0) ;"TMGOutput("DILIST","ID",1,.01)="VIRIATO,ENEAS" "RTN","TMGGDFN",223,0) ;"TMGOutput("DILIST","ID",1,.02)="MALE" "RTN","TMGGDFN",224,0) ;"TMGOutput("DILIST","ID",1,.03)="01/20/1957" "RTN","TMGGDFN",225,0) ;"TMGOutput("DILIST","ID",1,.09)=123237654 "RTN","TMGGDFN",226,0) ;"TMGOutput("DILIST","ID",1,22700)=3542340 "RTN","TMGGDFN",227,0) ;"TMGOutput("DILIST","ID",2,.01)="VOID,BURT" "RTN","TMGGDFN",228,0) ;"TMGOutput("DILIST","ID",2,.02)="FEMALE" "RTN","TMGGDFN",229,0) ;"TMGOutput("DILIST","ID",2,.03)="" "RTN","TMGGDFN",230,0) ;"TMGOutput("DILIST","ID",2,.09)="" "RTN","TMGGDFN",231,0) ;"TMGOutput("DILIST","ID",1,22700)=000455454 "RTN","TMGGDFN",232,0) ;"----------------------------------------------- "RTN","TMGGDFN",233,0) "RTN","TMGGDFN",234,0) ;"if ($get(TMGDEBUG)>0) do "RTN","TMGGDFN",235,0) ;". if $data(TMGOutput)>0 do ArrayDump^TMGDEBUG("TMGOutput") "RTN","TMGGDFN",236,0) ;". else do DebugMsg^TMGDEBUG(.DBIndent,"No TMGOutput found.") "RTN","TMGGDFN",237,0) ;". if $data(TMGErrMsg)>0 do ArrayDump^TMGDEBUG("TMGErrMsg") "RTN","TMGGDFN",238,0) ;". else do DebugMsg^TMGDEBUG(.DBIndent,"No TMGErrMsg found") "RTN","TMGGDFN",239,0) "RTN","TMGGDFN",240,0) if $data(TMGErrMsg("DIERR")) do ShowDIERR^TMGDEBUG(.TMGErrMsg,.PriorErrorFound) "RTN","TMGGDFN",241,0) "RTN","TMGGDFN",242,0) if $data(TMGOutput)'=0 do "RTN","TMGGDFN",243,0) . new NumMatch,Num "RTN","TMGGDFN",244,0) . set NumMatch=+$PIECE(TMGOutput("DILIST",0),"^",1) ;"Get first part of entry like this: '8^*^0^' <-8 matches "RTN","TMGGDFN",245,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,NumMatch," matches found in database") "RTN","TMGGDFN",246,0) . for Num=1:1:NumMatch do ;"Compare all entries found. If NumMatch=0-->no 1st loop "RTN","TMGGDFN",247,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop #",Num) "RTN","TMGGDFN",248,0) . . set RecComp=$$Compare(.Entry,.TMGOutput,Num) "RTN","TMGGDFN",249,0) . . if (RecComp=cInsufficient)&(NumMatch=1) do "RTN","TMGGDFN",250,0) . . . ;"Fileman has said there is 1 (and only 1) match. "RTN","TMGGDFN",251,0) . . . ;"Even if the supplied info is lacking, it is still a match. "RTN","TMGGDFN",252,0) . . . ;"We still needed to call $$Compare to check for cExtraInfo "RTN","TMGGDFN",253,0) . . . set RecComp=cFullMatch "RTN","TMGGDFN",254,0) . . if (RecComp=cFullMatch)!(RecComp=cExtraInfo) do "RTN","TMGGDFN",255,0) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Great! A match!") "RTN","TMGGDFN",256,0) . . . set result=TMGOutput("DILIST",2,Num) ;"This is DFN (record) number "RTN","TMGGDFN",257,0) . . . if RecComp=cExtraInfo do "RTN","TMGGDFN",258,0) . . . . new temp set temp=$$AddToPat(result,.Entry) "RTN","TMGGDFN",259,0) . . . set Num=NumMatch+1 ;"some value to abort loop "RTN","TMGGDFN",260,0) . . ;"else if (RecComp=cInsufficient) do DebugMsg^TMGDEBUG(.DBIndent,"Entry #",Num," insufficient data for match") "RTN","TMGGDFN",261,0) . . ;"else if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Entry #",Num," conflicts") "RTN","TMGGDFN",262,0) "RTN","TMGGDFN",263,0) LUDone; "RTN","TMGGDFN",264,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result (patient DFN#)=",result) "RTN","TMGGDFN",265,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"LookupPatient^TMGGDFN") "RTN","TMGGDFN",266,0) "RTN","TMGGDFN",267,0) quit result ;" return patient internal entry number (DFN) "RTN","TMGGDFN",268,0) "RTN","TMGGDFN",269,0) FieldExists(FieldNum) "RTN","TMGGDFN",270,0) ;"Purpose: to ensure a given field exists in File 2 "RTN","TMGGDFN",271,0) ;"Input: FieldNum: NUMBER of field in file 2 "RTN","TMGGDFN",272,0) ;"Output: 1=field exists, 0=doesn't exist "RTN","TMGGDFN",273,0) "RTN","TMGGDFN",274,0) quit ($data(^DD(2,FieldNum,0))'=0) "RTN","TMGGDFN",275,0) "RTN","TMGGDFN",276,0) ExtraLookup(Entry,Intensity) "RTN","TMGGDFN",277,0) ;"Purpose: Search for Patient (an existing entry in the database) "RTN","TMGGDFN",278,0) ;"Input: Entry -- Array is loaded with info, like this: "RTN","TMGGDFN",279,0) ;" Entry(.01)=Name "RTN","TMGGDFN",280,0) ;" Entry(.02)=Sex "RTN","TMGGDFN",281,0) ;" Entry(.03)=DOB "RTN","TMGGDFN",282,0) ;" Entry(.09)=SSNum "RTN","TMGGDFN",283,0) ;" Entry(22701)=SequelMedSystem Account Number "RTN","TMGGDFN",284,0) ;" Intensity -- How intense to search. "RTN","TMGGDFN",285,0) ;" NOTE: Because this returns the FIRST match, is it advised that this function "RTN","TMGGDFN",286,0) ;" be run with intensity 1 first, then 2-->3-->4 "RTN","TMGGDFN",287,0) ;"Result: returns FIRST matching DFN (patient internal entry number), or 0 if none found "RTN","TMGGDFN",288,0) ;"NOTE: For now, I am ignoring any passed Alias info. "RTN","TMGGDFN",289,0) "RTN","TMGGDFN",290,0) ;"Note: I am assuming that LookupPatient(Entry) has been called, and failed. "RTN","TMGGDFN",291,0) ;" Thus I am not going to compare SSNums, Medic or SequelMed's account numbers. "RTN","TMGGDFN",292,0) ;"------------------------------------------------------------------------------ "RTN","TMGGDFN",293,0) "RTN","TMGGDFN",294,0) if $data(cConflict)#10=0 new cConflict set cConflict=0 "RTN","TMGGDFN",295,0) if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 "RTN","TMGGDFN",296,0) if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 "RTN","TMGGDFN",297,0) if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3 "RTN","TMGGDFN",298,0) set Intensity=$get(Intensity,1) "RTN","TMGGDFN",299,0) if Intensity=1 set Threshold=1 ;"(exact match) "RTN","TMGGDFN",300,0) if Intensity=2 set Threshold=.75 ;"(probable match) "RTN","TMGGDFN",301,0) if Intensity=3 set Threshold=.5 ;"(possible match) "RTN","TMGGDFN",302,0) if Intensity=4 set Threshold=.25 ;"(doubtful match) "RTN","TMGGDFN",303,0) "RTN","TMGGDFN",304,0) new Missing set Missing=0 "RTN","TMGGDFN",305,0) new BailOut set BailOut=0 "RTN","TMGGDFN",306,0) new result set result=0 ;"set default to no match, or conflict found "RTN","TMGGDFN",307,0) new TMGErrMsg,TMGOutput "RTN","TMGGDFN",308,0) new RecComp "RTN","TMGGDFN",309,0) "RTN","TMGGDFN",310,0) ;"If can find patient by SSNum, then don't look any further (if successful) "RTN","TMGGDFN",311,0) if +$get(Entry(.09))>0 set result=$$SSNumLookup(Entry(.09)) "RTN","TMGGDFN",312,0) if result>0 goto LUDone "RTN","TMGGDFN",313,0) "RTN","TMGGDFN",314,0) ;"If can find patient by SequelMedSystem account number, then don't look any further (if successful) "RTN","TMGGDFN",315,0) if (+$get(Entry(22701))>0),$$FieldExists(22701) set result=$$PMSNumLookup(Entry(22701)) if result>0 goto LUDone "RTN","TMGGDFN",316,0) "RTN","TMGGDFN",317,0) ;"If can find patient by Paradigm account number, then don't look any further (if successful) "RTN","TMGGDFN",318,0) if (+$get(Entry(22702))>0),$$FieldExists(22702) set result=$$ParadigmNumLookup(Entry(22702)) "RTN","TMGGDFN",319,0) if result>0 goto LUDone "RTN","TMGGDFN",320,0) "RTN","TMGGDFN",321,0) new SearchName set SearchName=$get(Entry(.01)) "RTN","TMGGDFN",322,0) if SearchName="" goto XLUDone "RTN","TMGGDFN",323,0) set SearchName=$$FormatName^TMGMISC(SearchName,1) "RTN","TMGGDFN",324,0) do STDNAME^XLFNAME(.SearchName,"C",.TMGErrMsg) ;"parse into component array "RTN","TMGGDFN",325,0) if Intensity>0 kill SearchName("SUFFIX") "RTN","TMGGDFN",326,0) if Intensity>1 kill SearchName("MIDDLE") "RTN","TMGGDFN",327,0) if Intensity>2 set SearchName("GIVEN")=$EXTRACT(SearchName("GIVEN"),1,3) "RTN","TMGGDFN",328,0) if Intensity>3 do "RTN","TMGGDFN",329,0) . set SearchName("GIVEN")=$EXTRACT(SearchName("GIVEN"),1,1) "RTN","TMGGDFN",330,0) . set SearchName("FAMILY")=$EXTRACT(SearchName("FAMILY"),1,3) "RTN","TMGGDFN",331,0) "RTN","TMGGDFN",332,0) set SearchName=$$BLDNAME^XLFNAME(.SearchName) "RTN","TMGGDFN",333,0) "RTN","TMGGDFN",334,0) "RTN","TMGGDFN",335,0) ;"========================================================= "RTN","TMGGDFN",336,0) ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",337,0) do "RTN","TMGGDFN",338,0) . new Fields set Fields="@;.01;.02;.03" "RTN","TMGGDFN",339,0) . do FIND^DIC(2,"",Fields,"M",SearchName,"*","","","","TMGOutput","TMGErrMsg") "RTN","TMGGDFN",340,0) ;"========================================================= "RTN","TMGGDFN",341,0) "RTN","TMGGDFN",342,0) if $data(TMGErrMsg("DIERR")) goto XLUDone "RTN","TMGGDFN",343,0) "RTN","TMGGDFN",344,0) if $data(TMGOutput)'=0 do "RTN","TMGGDFN",345,0) . new NumMatch,Num "RTN","TMGGDFN",346,0) . set NumMatch=+$get(TMGOutput("DILIST",0),0) ;"Get first part of entry like this: '8^*^0^' <-8 matches "RTN","TMGGDFN",347,0) . for Num=1:1:NumMatch do ;"Compare all entries found. If NumMatch=0-->no 1st loop "RTN","TMGGDFN",348,0) . . new dbDataEntry "RTN","TMGGDFN",349,0) . . merge dbDataEntry=TMGOutput("DILIST","ID",Num) "RTN","TMGGDFN",350,0) . . set RecComp=$$XCompEntry(.Entry,.dbDataEntry,.Threshold) "RTN","TMGGDFN",351,0) . . if (RecComp=cInsufficient)&(NumMatch=1) do "RTN","TMGGDFN",352,0) . . . ;"Fileman has said there is 1 (and only 1) match. "RTN","TMGGDFN",353,0) . . . ;"Even if the supplied info is lacking, it is still a match. "RTN","TMGGDFN",354,0) . . . set RecComp=cFullMatch "RTN","TMGGDFN",355,0) . . if (RecComp=cFullMatch)!(RecComp=cExtraInfo) do "RTN","TMGGDFN",356,0) . . . set result=$get(TMGOutput("DILIST",2,Num),0) ;"This is DFN (record) number "RTN","TMGGDFN",357,0) . . . set Num=NumMatch+1 ;"some value to abort loop "RTN","TMGGDFN",358,0) "RTN","TMGGDFN",359,0) XLUDone; "RTN","TMGGDFN",360,0) quit result ;" return patient internal entry number (DFN) "RTN","TMGGDFN",361,0) "RTN","TMGGDFN",362,0) "RTN","TMGGDFN",363,0) XCompEntry(TestData,dbDataEntry,Threshold) ; "RTN","TMGGDFN",364,0) ;"PURPOSE: To compare two entries for certain fields, and return a comparison code. "RTN","TMGGDFN",365,0) ;"INPUT: TestData -- array holding uploaded data, that is being tested against preexisting data "RTN","TMGGDFN",366,0) ;" See CompEntry for Format "RTN","TMGGDFN",367,0) ;" dbDataEntry -- array derived from output from FIND^DIC. See CompEntry for Format "RTN","TMGGDFN",368,0) ;" Threshold -- OPTIONAL --How strict to be during the comparison "RTN","TMGGDFN",369,0) ;" default is 1. "RTN","TMGGDFN",370,0) ;" e.g. 0.5 --> comparison value must >= 0.5 "RTN","TMGGDFN",371,0) ;" Valid values are: .25, .5, .75, 1 "RTN","TMGGDFN",372,0) ;"Results: "RTN","TMGGDFN",373,0) ;" return value = cConflict (0) if entries conflict "RTN","TMGGDFN",374,0) ;" return value = cFullMatch (1) if entries match (to the degreee specified by Threshold) "RTN","TMGGDFN",375,0) ;" return value = cExtraInfo (2) if entries have no conflict, but tEntry has extra info. "RTN","TMGGDFN",376,0) ;" return value = cInsufficient (3) Insufficient data to make match, but no conflict. "RTN","TMGGDFN",377,0) ;"Note: This function IS DIFFERENT then CompEntry (which this was originally copied from) "RTN","TMGGDFN",378,0) ;" --It's purpose is to look for matches after a partial fileman search, "RTN","TMGGDFN",379,0) ;" Smi,Jo for Smith,John "RTN","TMGGDFN",380,0) "RTN","TMGGDFN",381,0) if $data(cConflict)#10=0 new cConflict set cConflict=0 "RTN","TMGGDFN",382,0) if $data(cConsistent)#10=0 new cConsistent set cConsistent=0.5 "RTN","TMGGDFN",383,0) if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 "RTN","TMGGDFN",384,0) set Threshold=$get(Threshold,1) "RTN","TMGGDFN",385,0) if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3 "RTN","TMGGDFN",386,0) "RTN","TMGGDFN",387,0) new tD,dbD "RTN","TMGGDFN",388,0) new CResult set CResult=cFullMatch ;"set default to match "RTN","TMGGDFN",389,0) new result set result=cFullMatch ;"default is Success. "RTN","TMGGDFN",390,0) new WorstScore set WorstScore=1 "RTN","TMGGDFN",391,0) new Extra set Extra=0 ;"0=false "RTN","TMGGDFN",392,0) "RTN","TMGGDFN",393,0) if $data(TestData(.01))#10'=0 do "RTN","TMGGDFN",394,0) . set tD=$get(TestData(.01)) ;"field .01 = NAME "RTN","TMGGDFN",395,0) . set dbD=$get(dbDataEntry(.01)) "RTN","TMGGDFN",396,0) . set result=$$CompName^TMGMISC(tD,dbD) "RTN","TMGGDFN",397,0) if result=cConflict goto CmpEDone "RTN","TMGGDFN",398,0) if resultWorstScore set result=WorstScore "RTN","TMGGDFN",416,0) set result=(result'success "RTN","TMGGDFN",424,0) if ($data(TestData(.01))#10=0)&($data(TestData(.03))=0) set result=cInsufficient "RTN","TMGGDFN",425,0) "RTN","TMGGDFN",426,0) XCmpEDone "RTN","TMGGDFN",427,0) "RTN","TMGGDFN",428,0) quit result "RTN","TMGGDFN",429,0) "RTN","TMGGDFN",430,0) "RTN","TMGGDFN",431,0) "RTN","TMGGDFN",432,0) SSNumLookup(SSNum) "RTN","TMGGDFN",433,0) ;"PURPOSE: To lookup patient by social security number "RTN","TMGGDFN",434,0) ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found "RTN","TMGGDFN",435,0) ;" "RTN","TMGGDFN",436,0) new result set result=0 "RTN","TMGGDFN",437,0) "RTN","TMGGDFN",438,0) new DIC "RTN","TMGGDFN",439,0) set DIC=2 "RTN","TMGGDFN",440,0) set DIC(0)="M" "RTN","TMGGDFN",441,0) set X=SSNum "RTN","TMGGDFN",442,0) do ^DIC "RTN","TMGGDFN",443,0) if +Y>0 set result=+Y "RTN","TMGGDFN",444,0) quit result "RTN","TMGGDFN",445,0) "RTN","TMGGDFN",446,0) "RTN","TMGGDFN",447,0) SSNum2Lookup(SSNum) "RTN","TMGGDFN",448,0) ;"NOTICE: I have learned to be more effecient, so will not use this function anymore "RTN","TMGGDFN",449,0) ;" Will use SSNumLookup instead "RTN","TMGGDFN",450,0) "RTN","TMGGDFN",451,0) ;"PURPOSE: To lookup patient by social security number "RTN","TMGGDFN",452,0) ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found "RTN","TMGGDFN",453,0) ;" "RTN","TMGGDFN",454,0) "RTN","TMGGDFN",455,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SSNLookup^TMGGDFN") "RTN","TMGGDFN",456,0) "RTN","TMGGDFN",457,0) new result set result=0 ;"set default to no match, or conflict found "RTN","TMGGDFN",458,0) new TMGErrMsg,TMGOutput "RTN","TMGGDFN",459,0) "RTN","TMGGDFN",460,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'Entry' passed for processing:") "RTN","TMGGDFN",461,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry") "RTN","TMGGDFN",462,0) "RTN","TMGGDFN",463,0) ;"Below specifies fields to get back. Note: file 2 is PATIENT file. "RTN","TMGGDFN",464,0) new Value set Value=$get(SSNum) "RTN","TMGGDFN",465,0) "RTN","TMGGDFN",466,0) ;"========================================================= "RTN","TMGGDFN",467,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FIND^DIC") "RTN","TMGGDFN",468,0) ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",469,0) do "RTN","TMGGDFN",470,0) . new File set File=2 "RTN","TMGGDFN",471,0) . new IENS set IENS="" "RTN","TMGGDFN",472,0) . new Fields set Fields="@;.01;.02;.03;.09" "RTN","TMGGDFN",473,0) . if $$FieldExists(22700) set Fields=Fields_";22700" "RTN","TMGGDFN",474,0) . new Flags set Flags="M" "RTN","TMGGDFN",475,0) . new MatchValue set MatchValue=Value "RTN","TMGGDFN",476,0) . new Number set Number="*" ;"i.e. max number to return *=all entries. "RTN","TMGGDFN",477,0) . new Indexes set Indexes="" "RTN","TMGGDFN",478,0) . new ScreenCode set ScreenCode="" ;"option screening M code "RTN","TMGGDFN",479,0) . new Ident set Ident="" ;"optional text to accompany each found entry "RTN","TMGGDFN",480,0) . new OutVarP set OutVarP="TMGOutput" "RTN","TMGGDFN",481,0) . new ErrVarP set ErrVarP="TMGErrMsg" "RTN","TMGGDFN",482,0) . do FIND^DIC(File,IENS,Fields,Flags,MatchValue,Number,Indexes,ScreenCode,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",483,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FIND^DIC") "RTN","TMGGDFN",484,0) ;"========================================================= "RTN","TMGGDFN",485,0) "RTN","TMGGDFN",486,0) ;"if ($get(TMGDEBUG)>0) do "RTN","TMGGDFN",487,0) ;". if $data(TMGOutput)>0 do ArrayDump^TMGDEBUG("TMGOutput") "RTN","TMGGDFN",488,0) ;". else do DebugMsg^TMGDEBUG(.DBIndent,"No TMGOutput found.") "RTN","TMGGDFN",489,0) ;". if $data(TMGErrMsg)>0 do ArrayDump^TMGDEBUG("TMGErrMsg") "RTN","TMGGDFN",490,0) ;". else do DebugMsg^TMGDEBUG(.DBIndent,"No TMGErrMsg found") "RTN","TMGGDFN",491,0) "RTN","TMGGDFN",492,0) if $data(TMGErrMsg("DIERR")) do ShowDIERR^TMGDEBUG(.TMGErrMsg,.PriorErrorFound) "RTN","TMGGDFN",493,0) "RTN","TMGGDFN",494,0) if $data(TMGOutput)'=0 do "RTN","TMGGDFN",495,0) . new NumMatch,Num "RTN","TMGGDFN",496,0) . set NumMatch=+$PIECE(TMGOutput("DILIST",0),"^",1) ;"Get first part of entry like this: '8^*^0^' <-8 matches "RTN","TMGGDFN",497,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,NumMatch," matches found in database") "RTN","TMGGDFN",498,0) . if NumMatch>0 set result=$get(TMGOutput("DILIST",2,1)) "RTN","TMGGDFN",499,0) "RTN","TMGGDFN",500,0) SSLUDone "RTN","TMGGDFN",501,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result (patient DFN#)=",result) "RTN","TMGGDFN",502,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SSNLookup^TMGGDFN") "RTN","TMGGDFN",503,0) "RTN","TMGGDFN",504,0) quit result ;" return patient internal entry number (DFN) "RTN","TMGGDFN",505,0) "RTN","TMGGDFN",506,0) "RTN","TMGGDFN",507,0) PMSNumLookup(PMSNum) "RTN","TMGGDFN",508,0) ;"PURPOSE: To lookup patient by SequelSystem account number "RTN","TMGGDFN",509,0) ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found "RTN","TMGGDFN",510,0) ;" "RTN","TMGGDFN",511,0) "RTN","TMGGDFN",512,0) new result set result=0 ;"set default to no match, or conflict found "RTN","TMGGDFN",513,0) new TMGErrMsg,TMGOutput "RTN","TMGGDFN",514,0) "RTN","TMGGDFN",515,0) ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",516,0) ;"Uses custom TMGS index. "RTN","TMGGDFN",517,0) do FIND^DIC(2,"",".01","",PMSNum,"*","TMGS","","","TMGOutput","TMGErrMsg") "RTN","TMGGDFN",518,0) "RTN","TMGGDFN",519,0) if '$data(TMGErrMsg("DIERR")) set result=$get(TMGOutput("DILIST",2,1),0) "RTN","TMGGDFN",520,0) quit result ;" return patient internal entry number (DFN) "RTN","TMGGDFN",521,0) "RTN","TMGGDFN",522,0) "RTN","TMGGDFN",523,0) ParadigmNumLookup(PMSNum) "RTN","TMGGDFN",524,0) ;"PURPOSE: To lookup patient by Paradigm account number "RTN","TMGGDFN",525,0) ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found "RTN","TMGGDFN",526,0) "RTN","TMGGDFN",527,0) new result set result=0 ;"set default to no match, or conflict found "RTN","TMGGDFN",528,0) new TMGErrMsg,TMGOutput "RTN","TMGGDFN",529,0) "RTN","TMGGDFN",530,0) ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP) "RTN","TMGGDFN",531,0) ;"Uses custom TMGS index. "RTN","TMGGDFN",532,0) do FIND^DIC(2,"",".01","",PMSNum,"*","TMGP","","","TMGOutput","TMGErrMsg") "RTN","TMGGDFN",533,0) "RTN","TMGGDFN",534,0) if '$data(TMGErrMsg("DIERR")) set result=$get(TMGOutput("DILIST",2,1),0) "RTN","TMGGDFN",535,0) quit result ;" return patient internal entry number (DFN) "RTN","TMGGDFN",536,0) "RTN","TMGGDFN",537,0) "RTN","TMGGDFN",538,0) Compare(TestData,dbData,EntryNum) ; "RTN","TMGGDFN",539,0) ;"PURPOSE: To compare two entries for certain fields, and return a comparison code. "RTN","TMGGDFN",540,0) ;"INPUT: TestData -- array holding uploaded data, that is being tested against preexisting data "RTN","TMGGDFN",541,0) ;" Format is: "RTN","TMGGDFN",542,0) ;" TestData(FieldNumber)=Value "RTN","TMGGDFN",543,0) ;" TestData(FieldNumber)=Value "RTN","TMGGDFN",544,0) ;" TestData(FieldNumber)=Value "RTN","TMGGDFN",545,0) ;" dbData -- array returned from FIND^DIC. "RTN","TMGGDFN",546,0) ;" EntryNum -- Entry number in dbData "RTN","TMGGDFN",547,0) ;"Results: "RTN","TMGGDFN",548,0) ;" return value = cConflict (0) if entries conflict "RTN","TMGGDFN",549,0) ;" return value = cFullMatch (1) if entries completely match "RTN","TMGGDFN",550,0) ;" return value = cExtraInfo (2) if entries have no conflict, but tEntry has extra info. "RTN","TMGGDFN",551,0) ;" return value = cInsufficient (3) Insufficient data to make match, but no conflict. "RTN","TMGGDFN",552,0) ;"Note: The following data sets will be sufficient for a match: "RTN","TMGGDFN",553,0) ;" 1. SSNumber (not a P/pseudo value) "RTN","TMGGDFN",554,0) ;" 2. Patient Identifier (field 22700) "RTN","TMGGDFN",555,0) ;" 3. Name, DOB "RTN","TMGGDFN",556,0) "RTN","TMGGDFN",557,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"Compare^TMGGDFN") "RTN","TMGGDFN",558,0) "RTN","TMGGDFN",559,0) if $data(cConflict)#10=0 new cConflict set cConflict=0 "RTN","TMGGDFN",560,0) if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 "RTN","TMGGDFN",561,0) if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 "RTN","TMGGDFN",562,0) if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3 "RTN","TMGGDFN",563,0) "RTN","TMGGDFN",564,0) new dbDataEntry,result "RTN","TMGGDFN",565,0) "RTN","TMGGDFN",566,0) ;"First, ensure no conflict between TestData and dbData "RTN","TMGGDFN",567,0) merge dbDataEntry=dbData("DILIST","ID",EntryNum) "RTN","TMGGDFN",568,0) set result=$$CompEntry(.TestData,.dbDataEntry) "RTN","TMGGDFN",569,0) if result=cConflict goto CompDone "RTN","TMGGDFN",570,0) "RTN","TMGGDFN",571,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No conflict found so far") "RTN","TMGGDFN",572,0) "RTN","TMGGDFN",573,0) if $get(TestData(.01))="" kill TestData(.01) "RTN","TMGGDFN",574,0) if $get(TestData(.03))="" kill TestData(.03) "RTN","TMGGDFN",575,0) if $get(TestData(.09))="" kill TestData(.09) "RTN","TMGGDFN",576,0) if $get(TestData(22700))="" kill TestData(22700) "RTN","TMGGDFN",577,0) if $get(TestData(22701))="" kill TestData(22701) "RTN","TMGGDFN",578,0) "RTN","TMGGDFN",579,0) ;"OK, no conflict. But is there sufficient data for a match? "RTN","TMGGDFN",580,0) if (+$get(TestData(.09))>0)&($get(TestData(.09))'["P") goto CompDone ;".09=SSNum --> success "RTN","TMGGDFN",581,0) if ($data(TestData(22700))#10'=0) goto CompDone ;"22700=Pt. Identifier --> success "RTN","TMGGDFN",582,0) if ($data(TestData(.01))#10'=0)&($data(TestData(.03))) goto CompDone ;"Name & DOB-->success "RTN","TMGGDFN",583,0) "RTN","TMGGDFN",584,0) ;"If here, then we don't have enough data for a match "RTN","TMGGDFN",585,0) set result=cInsufficient "RTN","TMGGDFN",586,0) "RTN","TMGGDFN",587,0) CompDone "RTN","TMGGDFN",588,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGGDFN",589,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"Compare^TMGGDFN") "RTN","TMGGDFN",590,0) quit result "RTN","TMGGDFN",591,0) "RTN","TMGGDFN",592,0) "RTN","TMGGDFN",593,0) CompEntry(TestData,dbDataEntry) ; "RTN","TMGGDFN",594,0) ;"PURPOSE: To compare two entries for certain fields, and return a comparison code. "RTN","TMGGDFN",595,0) ;"INPUT: TestData -- array holding uploaded data, that is being tested against preexisting data "RTN","TMGGDFN",596,0) ;" Format is: "RTN","TMGGDFN",597,0) ;" TestData(FieldNumber)=Value "RTN","TMGGDFN",598,0) ;" TestData(FieldNumber)=Value "RTN","TMGGDFN",599,0) ;" TestData(FieldNumber)=Value "RTN","TMGGDFN",600,0) ;" dbDataEntry -- array derived from output from FIND^DIC. "RTN","TMGGDFN",601,0) ;" Format is: "RTN","TMGGDFN",602,0) ;" dbDataEntry(FieldNumber)=Value "RTN","TMGGDFN",603,0) ;" dbDataEntry(FieldNumber)=Value "RTN","TMGGDFN",604,0) ;" dbDataEntry(FieldNumber)=Value "RTN","TMGGDFN",605,0) ;" EntryNum -- Entry number in dbDataEntry "RTN","TMGGDFN",606,0) ;"Results: "RTN","TMGGDFN",607,0) ;" return value = cConflict (0) if entries conflict "RTN","TMGGDFN",608,0) ;" return value = cFullMatch (1) if entries completely match "RTN","TMGGDFN",609,0) ;" return value = cExtraInfo (2) if entries have no conflict, but tEntry has extra info. "RTN","TMGGDFN",610,0) "RTN","TMGGDFN",611,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompEntry^TMGGDFN") "RTN","TMGGDFN",612,0) "RTN","TMGGDFN",613,0) if $data(cConflict)#10=0 new cConflict set cConflict=0 "RTN","TMGGDFN",614,0) if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 "RTN","TMGGDFN",615,0) if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 "RTN","TMGGDFN",616,0) "RTN","TMGGDFN",617,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'TestData' passed for processing:") "RTN","TMGGDFN",618,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TestData") "RTN","TMGGDFN",619,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'dbDataEntry' passed for processing:") "RTN","TMGGDFN",620,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("dbDataEntry") "RTN","TMGGDFN",621,0) "RTN","TMGGDFN",622,0) new tD,dbD "RTN","TMGGDFN",623,0) new CResult set CResult=cFullMatch ;"set default to match (so data won't be entered into database) "RTN","TMGGDFN",624,0) new result set result=cFullMatch ;"default is Success. "RTN","TMGGDFN",625,0) new Extra set Extra=0 ;"0=false "RTN","TMGGDFN",626,0) "RTN","TMGGDFN",627,0) ;"I am not going to test field .01 (NAME) because Fileman has already done this, and "RTN","TMGGDFN",628,0) ;" feels that the names it has returned are compatible. "RTN","TMGGDFN",629,0) ;" I was having a problem with input like this: "RTN","TMGGDFN",630,0) ;" TestData(.01)="DOE,JOHN" "RTN","TMGGDFN",631,0) ;" dbDataEntry(.01)="DOE,JOHN J" "RTN","TMGGDFN",632,0) ;" And this was failing the match. It shouldn't have. "RTN","TMGGDFN",633,0) ;"if $data(TestData(.01))#10'=0 do "RTN","TMGGDFN",634,0) ;". set tD=$get(TestData(.01)) ;"field .01 = NAME "RTN","TMGGDFN",635,0) ;". set dbD=$get(dbDataEntry(.01)) "RTN","TMGGDFN",636,0) ;". set result=$$FieldCompare^TMGDBAPI(tD,dbD) "RTN","TMGGDFN",637,0) ;"if result=cConflict goto CmpEDone "RTN","TMGGDFN",638,0) ;"if result=cExtraInfo set Extra=1 "RTN","TMGGDFN",639,0) "RTN","TMGGDFN",640,0) if $data(TestData(.09))#10'=0 do "RTN","TMGGDFN",641,0) . set tD=$get(TestData(.09)) ;"field .09 = SSNUM "RTN","TMGGDFN",642,0) . set dbD=$get(dbDataEntry(.09)) "RTN","TMGGDFN",643,0) . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"SSNUM") "RTN","TMGGDFN",644,0) if result=cConflict goto CmpEDone "RTN","TMGGDFN",645,0) if result=cExtraInfo set Extra=1 "RTN","TMGGDFN",646,0) "RTN","TMGGDFN",647,0) if $data(TestData(.02))#10'=0 do "RTN","TMGGDFN",648,0) . set tD=$get(TestData(.02)) ;"field .02 = SEX "RTN","TMGGDFN",649,0) . set dbD=$get(dbDataEntry(.02)) "RTN","TMGGDFN",650,0) . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"SEX") "RTN","TMGGDFN",651,0) if result=cConflict goto CmpEDone "RTN","TMGGDFN",652,0) if result=cExtraInfo set Extra=1 "RTN","TMGGDFN",653,0) "RTN","TMGGDFN",654,0) if $data(TestData(.03))#10'=0 do "RTN","TMGGDFN",655,0) . set tD=$get(TestData(.03)) ;"field .03 = DOB "RTN","TMGGDFN",656,0) . set dbD=$get(dbDataEntry(.03)) "RTN","TMGGDFN",657,0) . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"DATE") "RTN","TMGGDFN",658,0) if result=cConflict goto CmpEDone "RTN","TMGGDFN",659,0) if result=cExtraInfo set Extra=1 "RTN","TMGGDFN",660,0) "RTN","TMGGDFN",661,0) ;"if $data(TestData(22700))#10'=0 do "RTN","TMGGDFN",662,0) ;". set tD=$get(TestData(22700)) ;"field 22700 = Patient ID number "RTN","TMGGDFN",663,0) ;". set dbD=$get(dbDataEntry(22700)) "RTN","TMGGDFN",664,0) ;". set result=$$FieldCompare^TMGDBAPI(tD,dbD,"NUMBER") "RTN","TMGGDFN",665,0) ;"if result=cConflict goto CmpEDone "RTN","TMGGDFN",666,0) ;"if result=cExtraInfo set Extra=1 "RTN","TMGGDFN",667,0) "RTN","TMGGDFN",668,0) ;"If we are here, then there is no conflict. "RTN","TMGGDFN",669,0) set result=cFullMatch "RTN","TMGGDFN",670,0) ;"If extra info present, reflect this in result "RTN","TMGGDFN",671,0) if Extra=1 set result=cExtraInfo "RTN","TMGGDFN",672,0) "RTN","TMGGDFN",673,0) CmpEDone "RTN","TMGGDFN",674,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGGDFN",675,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompEntry^TMGGDFN") "RTN","TMGGDFN",676,0) "RTN","TMGGDFN",677,0) quit result "RTN","TMGGDFN",678,0) "RTN","TMGGDFN",679,0) AddToPat(PatIEN,Entry) "RTN","TMGGDFN",680,0) ;"PURPOSE: Stuffs Entry into record number PatIEN (RecNum must already exist) "RTN","TMGGDFN",681,0) ;"INPUT: PatIEN -- the record number, in file 2, that is to be updated "RTN","TMGGDFN",682,0) ;" Entry -- the record to put in "RTN","TMGGDFN",683,0) ;" Format is: "RTN","TMGGDFN",684,0) ;" Entry(FieldNumber)=Value "RTN","TMGGDFN",685,0) ;" Entry(FieldNumber)=Value "RTN","TMGGDFN",686,0) ;" Entry(FieldNumber)=Value "RTN","TMGGDFN",687,0) ;" The following FieldNumbers will be used if avail. "RTN","TMGGDFN",688,0) ;" .01,.02,.03,.09,22700 "RTN","TMGGDFN",689,0) ;"Results: cOKToCont (1) or cAbort(0) "RTN","TMGGDFN",690,0) "RTN","TMGGDFN",691,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGGDFN",692,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGGDFN",693,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGGDFN",694,0) "RTN","TMGGDFN",695,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddToPat^TMGGDFN") "RTN","TMGGDFN",696,0) "RTN","TMGGDFN",697,0) new TMGFDA,TMGMsg "RTN","TMGGDFN",698,0) new result set result=cOKToCont "RTN","TMGGDFN",699,0) "RTN","TMGGDFN",700,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Entry passed for processing") "RTN","TMGGDFN",701,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry") "RTN","TMGGDFN",702,0) "RTN","TMGGDFN",703,0) if $get(Entry(.01))'="" set TMGFDA(2,PatIEN_",",.01)=Entry(.01) ;"field .01 = NAME "RTN","TMGGDFN",704,0) if $get(Entry(.02))'="" set TMGFDA(2,PatIEN_",",.02)=Entry(.02) ;"field .02 = SEX "RTN","TMGGDFN",705,0) if $get(Entry(.03))'="" set TMGFDA(2,PatIEN_",",.03)=Entry(.03) ;"field .03 = DOB "RTN","TMGGDFN",706,0) if $get(Entry(.09))'=""&($get(Entry(.09))'["P") do "RTN","TMGGDFN",707,0) . set TMGFDA(2,PatIEN_",",.09)=Entry(.09) ;"field .09 = SSNUM "RTN","TMGGDFN",708,0) if $get(Entry(22700))'="" set TMGFDA(2,PatIEN_",",22700)=Entry(22700) ;"field 22700 = Patient Medic ID Num (custom field) "RTN","TMGGDFN",709,0) "RTN","TMGGDFN",710,0) set result=$$dbWrite^TMGDBAPI(.TMGFDA,1) "RTN","TMGGDFN",711,0) if result=cAbort goto ATRDone "RTN","TMGGDFN",712,0) "RTN","TMGGDFN",713,0) ATRDone "RTN","TMGGDFN",714,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddToPat") "RTN","TMGGDFN",715,0) quit result "RTN","TMGGDFN",716,0) "RTN","TMGGDFN",717,0) "RTN","TMGGDFN",718,0) "RTN","TMGGDFN",719,0) AddNewPt(Entry,ErrArray) "RTN","TMGGDFN",720,0) ;"Purpose: Create a new entry in file 2 (Patient File) "RTN","TMGGDFN",721,0) ;"Input: 'Entry' array should be set up prior to calling. See those items expected below "RTN","TMGGDFN",722,0) ;" Entry(.01)=Patient Name "RTN","TMGGDFN",723,0) ;" Entry(.03)=DOB "RTN","TMGGDFN",724,0) ;" Entry(.09)=SS Num "RTN","TMGGDFN",725,0) ;" Entry(22700)=Medic Pt Identifier -- optional "RTN","TMGGDFN",726,0) ;" Entry(1901)=field 1901 = VETERAN Y/N --For my purposes, use NO -- optional "RTN","TMGGDFN",727,0) ;" Entry(.301)=field .301 = "SERVICE CONNECTED?" -- required field -- optional "RTN","TMGGDFN",728,0) ;" Entry(391)=field 391 = "TYPE" - required field -- optional "RTN","TMGGDFN",729,0) "RTN","TMGGDFN",730,0) ;" ErrArray (OPTIONAL) -- PASS BY REFERENCE. An OUT parameter to receive "RTN","TMGGDFN",731,0) ;" Fileman "DIERR" message, if any "RTN","TMGGDFN",732,0) ;" Note: To use this, and have the function not display the Fileman "RTN","TMGGDFN",733,0) ;" Error to the screen, ** must SET ErrArray=-1 (-1 = extra quiet mode) "RTN","TMGGDFN",734,0) ;" If TMGDEBUG is defined, then this quit mode described above will NOT be used, "RTN","TMGGDFN",735,0) ;" and existing values for TMGDEBUG will be used. "RTN","TMGGDFN",736,0) ;"Output: Returns internal entry number (DFN) if successful, otherwise 0 "RTN","TMGGDFN",737,0) ;"Note: The following data sets must be available for a patient to be entered: "RTN","TMGGDFN",738,0) ;" Patient name (.01) -- always required "RTN","TMGGDFN",739,0) ;" Patient sex (.02) -- always required "RTN","TMGGDFN",740,0) ;" And ONE of the following... "RTN","TMGGDFN",741,0) ;" 1. SSNumber (.09) (not a P/pseudo value) "RTN","TMGGDFN",742,0) ;" 2. Patient Identifier (field 22700) "RTN","TMGGDFN",743,0) ;" 3. DOB (.03) "RTN","TMGGDFN",744,0) ;"Results: returns the DFN of the added record, or 0 if not added/error "RTN","TMGGDFN",745,0) "RTN","TMGGDFN",746,0) "RTN","TMGGDFN",747,0) ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddNewPt^TMGGDFN") "RTN","TMGGDFN",748,0) "RTN","TMGGDFN",749,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGGDFN",750,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGGDFN",751,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGGDFN",752,0) "RTN","TMGGDFN",753,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'Entry' passed for processing:") "RTN","TMGGDFN",754,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry") "RTN","TMGGDFN",755,0) "RTN","TMGGDFN",756,0) new TMGFDA,TMGIEN,TMGMSG "RTN","TMGGDFN",757,0) new result set result=cOKToCont ;"default it success. "RTN","TMGGDFN",758,0) "RTN","TMGGDFN",759,0) if ($Data(Entry(.09))#10'=0) do ;"Kill SSNum if it isn't in right format "RTN","TMGGDFN",760,0) . set Entry(.09)=$translate(Entry(.09),"- ","") "RTN","TMGGDFN",761,0) . if Entry(.09)'?9N0.1"P" kill Entry(.09) "RTN","TMGGDFN",762,0) "RTN","TMGGDFN",763,0) if ($Data(Entry(.01))#10=0) goto ANPDone ;"Abort "RTN","TMGGDFN",764,0) if ($Data(Entry(.03))#10'=0) goto ANPOK ;"OK to make record "RTN","TMGGDFN",765,0) if ($Data(Entry(.09))#10'=0) goto ANPOK ;"OK to make record "RTN","TMGGDFN",766,0) if ($Data(Entry(22700))#10'=0) goto ANPOK ;"OK to make record "RTN","TMGGDFN",767,0) "RTN","TMGGDFN",768,0) ;"If we get to this point, then insufficient data to add record... so abort "RTN","TMGGDFN",769,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Not enough info to create unique patient record.") "RTN","TMGGDFN",770,0) set result=cAbort "RTN","TMGGDFN",771,0) goto ANPDone ;"Abort "RTN","TMGGDFN",772,0) "RTN","TMGGDFN",773,0) ANPOK "RTN","TMGGDFN",774,0) ;"Note: the "2" means file 2 (PATIENT file), and "+1" means "add entry" "RTN","TMGGDFN",775,0) set TMGFDA(2,"+1,",.096)="`"_DUZ ;"field .096 = WHO ENTERED PATIENT (`DUZ=current user) "RTN","TMGGDFN",776,0) set TMGFDA(2,"+1,",.01)=Entry(.01) ;"field .01 = NAME "RTN","TMGGDFN",777,0) if $data(Entry(.02)) set TMGFDA(2,"+1,",.02)=Entry(.02) ;"field .02 = SEX "RTN","TMGGDFN",778,0) if $data(Entry(.03)) set TMGFDA(2,"+1,",.03)=Entry(.03) ;"field .03 = DOB "RTN","TMGGDFN",779,0) if +$get(Entry(.09))>0 set TMGFDA(2,"+1,",.09)=Entry(.09) ;"field .09 = SSNUM "RTN","TMGGDFN",780,0) if $data(Entry(22700)),$$FieldExists(22700) set TMGFDA(2,"+1,",22700)=Entry(22700) ;"field 22700 = Patient ID Num (custom field) "RTN","TMGGDFN",781,0) ;"These fields below *USED TO BE* required. I changed the filemans status for these fields to NOT required "RTN","TMGGDFN",782,0) if $data(Entry(1901)) set TMGFDA(2,"+1,",1901)=Entry(1901) "RTN","TMGGDFN",783,0) else set TMGFDA(2,"+1,",1901)="NO" ;"field 1901 = VETERAN Y/N --For my purposes, use NO "RTN","TMGGDFN",784,0) if $data(Entry(.301)) set TMGFDA(2,"+1,",.301)=Entry(.301) "RTN","TMGGDFN",785,0) else set TMGFDA(2,"+1,",.301)="NO" ;"field .301 = SERVICE CONNECTED? -- required field "RTN","TMGGDFN",786,0) if $data(Entry(391)) set TMGFDA(2,"+1,",391)=Entry(391) "RTN","TMGGDFN",787,0) else set TMGFDA(2,"+1,",391)="NON-VETERAN (OTHER)" ;"field 391 = "TYPE" - required field "RTN","TMGGDFN",788,0) "RTN","TMGGDFN",789,0) if $data(TMGDEBUG)=0 new TMGDEBUG "RTN","TMGGDFN",790,0) set TMGDEBUG=$get(ErrArray,0) "RTN","TMGGDFN",791,0) "RTN","TMGGDFN",792,0) ;"set result=$$dbWrite^TMGDBAPI(.TMGFDA,0,.TMGIEN,,.ErrArray) "RTN","TMGGDFN",793,0) do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGGDFN",794,0) if $data(TMGMSG("DIERR")) do "RTN","TMGGDFN",795,0) . ;"TMGDEBUG=-1 --> extra quiet mode "RTN","TMGGDFN",796,0) . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGGDFN",797,0) . merge ErrArray("DIERR")=TMGMSG("DIERR") "RTN","TMGGDFN",798,0) . set result=cAbort "RTN","TMGGDFN",799,0) "RTN","TMGGDFN",800,0) if result=cAbort goto ANPDone "RTN","TMGGDFN",801,0) "RTN","TMGGDFN",802,0) set result=+$get(TMGIEN(1)) ;"result is the added patient's IEN "RTN","TMGGDFN",803,0) if result'>0 goto ANPDone "RTN","TMGGDFN",804,0) "RTN","TMGGDFN",805,0) ;"Add subfile entry for Alias if an alias was specified. "RTN","TMGGDFN",806,0) if $data(Entry(10,.01)) do ;"field 10 in file 2 = ALIAS, .01 subfield=ALIAS "RTN","TMGGDFN",807,0) . kill TMGFDA,TMGMsg,TMGIEN,tempresult "RTN","TMGGDFN",808,0) . set TMGFDA(2.01,"+1,"_result_",",.01)=Entry(10,.01) "RTN","TMGGDFN",809,0) . ;"set tempresult=$$dbWrite^TMGDBAPI(.TMGFDA,0,.TMGIEN,,.ErrArray) "RTN","TMGGDFN",810,0) . do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGGDFN",811,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGGDFN",812,0) . . ;"TMGDEBUG=-1 --> extra quiet mode "RTN","TMGGDFN",813,0) . . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGGDFN",814,0) . . merge ErrArray("DIERR")=TMGMSG("DIERR") "RTN","TMGGDFN",815,0) "RTN","TMGGDFN",816,0) ;"Now, manually add a record in the file 9000001 (^AUPNPAT) with IEN (stored in result) "RTN","TMGGDFN",817,0) ;"This is done because some PATIENT fields don't point to the PATIENT file, but instead "RTN","TMGGDFN",818,0) ;" point to the PATIENT/IHS file (9000001), which in turn points to the PATIENT file. "RTN","TMGGDFN",819,0) set ^AUPNPAT(result,0)=result "RTN","TMGGDFN",820,0) set ^AUPNPAT("B",result,result)="" "RTN","TMGGDFN",821,0) if $data(Entry(.09)) do "RTN","TMGGDFN",822,0) . set ^AUPNPAT(result,41,0)="^9000001.41P^1^1" "RTN","TMGGDFN",823,0) . set ^AUPNPAT(result,41,1,0)="1^"_Entry(.09) "RTN","TMGGDFN",824,0) "RTN","TMGGDFN",825,0) ANPDone "RTN","TMGGDFN",826,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result / IEN of added record=",result) "RTN","TMGGDFN",827,0) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddNewPt^TMGGDFN") "RTN","TMGGDFN",828,0) quit result "RTN","TMGGDFN",829,0) "RTN","TMGGDFN",830,0) "RTN","TMGGDFN",831,0) "RTN","TMGGDFN",832,0) "RTN","TMGGDFN",833,0) "RTN","TMGHTML1") 0^22^B6207 "RTN","TMGHTML1",1,0) TMGHTML1 ;TMG/kst/HTML Mini-chart creator ;03/25/06 "RTN","TMGHTML1",2,0) ;;1.0;TMG-LIB;**1**;01/10/06 "RTN","TMGHTML1",3,0) "RTN","TMGHTML1",4,0) ;"TMG HTML EXPORT FUNCTION "RTN","TMGHTML1",5,0) ;"Kevin Toppenberg MD "RTN","TMGHTML1",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGHTML1",7,0) ;"1-10-2006 "RTN","TMGHTML1",8,0) "RTN","TMGHTML1",9,0) ;"======================================================================= "RTN","TMGHTML1",10,0) ;" API -- Public Functions. "RTN","TMGHTML1",11,0) ;"======================================================================= "RTN","TMGHTML1",12,0) "RTN","TMGHTML1",13,0) ;"======================================================================= "RTN","TMGHTML1",14,0) ;"PRIVATE API FUNCTIONS "RTN","TMGHTML1",15,0) ;"======================================================================= "RTN","TMGHTML1",16,0) ;"DumpNtes(List,FPath,OutArray) "RTN","TMGHTML1",17,0) ;"MakeFName(IEN) "RTN","TMGHTML1",18,0) ;"GetTemplateRecs(pRecs,Template) "RTN","TMGHTML1",19,0) ;"Write1Note(IEN) "RTN","TMGHTML1",20,0) "RTN","TMGHTML1",21,0) "RTN","TMGHTML1",22,0) ;"======================================================================= "RTN","TMGHTML1",23,0) ;"Dependencies (duplicates shown in parenthesies) "RTN","TMGHTML1",24,0) ;"======================================================================= "RTN","TMGHTML1",25,0) ;"^TMGMISC "RTN","TMGHTML1",26,0) "RTN","TMGHTML1",27,0) MAKESITE(FPath,Template) "RTN","TMGHTML1",28,0) ;"Purpose: To create an interlinked site with specified notes. "RTN","TMGHTML1",29,0) ;"Input: FPath OPTIONAL -- if not provided, user will be asked "RTN","TMGHTML1",30,0) ;" This is the directory where output is to be sent "RTN","TMGHTML1",31,0) ;" Input OPTIONAL -- if not provided, user will be asked "RTN","TMGHTML1",32,0) ;" This is the name of the search/sort template holding "RTN","TMGHTML1",33,0) ;" a list of IENs to output "RTN","TMGHTML1",34,0) ;"Output: files are written to file system "RTN","TMGHTML1",35,0) ;"Result: none. "RTN","TMGHTML1",36,0) "RTN","TMGHTML1",37,0) "RTN","TMGHTML1",38,0) if $get(FPath)="" do "RTN","TMGHTML1",39,0) . write !!,"This will export TIU DOCUMENT records to an interlinked website.",!! "RTN","TMGHTML1",40,0) . read "Enter destination directory path: ",FPath,! "RTN","TMGHTML1",41,0) if FPath="^" goto MSDone "RTN","TMGHTML1",42,0) "RTN","TMGHTML1",43,0) ;"Create core index.htm "RTN","TMGHTML1",44,0) ;"---------------------- "RTN","TMGHTML1",45,0) if $$OpenIO(FPath,"index.htm")=0 do goto MSDone "RTN","TMGHTML1",46,0) . write "Error. Aborting.",! "RTN","TMGHTML1",47,0) new offset "RTN","TMGHTML1",48,0) for offset=1:1 do quit:(s["{^}") "RTN","TMGHTML1",49,0) . set s=$piece($TEXT(IndexDat+offset),";;",2) "RTN","TMGHTML1",50,0) . quit:(s["{^}") "RTN","TMGHTML1",51,0) . write s,! "RTN","TMGHTML1",52,0) do ^%ZISC ;" Close the output device "RTN","TMGHTML1",53,0) "RTN","TMGHTML1",54,0) ;"Create core intro.htm "RTN","TMGHTML1",55,0) ;"---------------------- "RTN","TMGHTML1",56,0) if $$OpenIO(FPath,"intro.htm")=0 do goto MSDone "RTN","TMGHTML1",57,0) . write "Error. Aborting.",! "RTN","TMGHTML1",58,0) new offset "RTN","TMGHTML1",59,0) for offset=1:1 do quit:(s["{^}") "RTN","TMGHTML1",60,0) . set s=$piece($TEXT(IntroDat+offset),";;",2) "RTN","TMGHTML1",61,0) . quit:(s["{^}") "RTN","TMGHTML1",62,0) . write s,! "RTN","TMGHTML1",63,0) do ^%ZISC ;" Close the output device "RTN","TMGHTML1",64,0) "RTN","TMGHTML1",65,0) ;"Create individual files with notes. "RTN","TMGHTML1",66,0) ;"----------------------------------- "RTN","TMGHTML1",67,0) new OutArray "RTN","TMGHTML1",68,0) do WriteTemplate(.FPath,.Template,.OutArray) "RTN","TMGHTML1",69,0) "RTN","TMGHTML1",70,0) "RTN","TMGHTML1",71,0) ;"Create toc.htm-- the table of contents. "RTN","TMGHTML1",72,0) ;"--------------------------------------- "RTN","TMGHTML1",73,0) if $$OpenIO(FPath,"toc.htm")=0 do goto MSDone "RTN","TMGHTML1",74,0) . write "Error. Aborting.",! "RTN","TMGHTML1",75,0) do MakeTOC(.OutArray) "RTN","TMGHTML1",76,0) do ^%ZISC ;" Close the output device "RTN","TMGHTML1",77,0) "RTN","TMGHTML1",78,0) MSDone "RTN","TMGHTML1",79,0) write "Good bye.",!! "RTN","TMGHTML1",80,0) quit "RTN","TMGHTML1",81,0) "RTN","TMGHTML1",82,0) WriteTemplate(FPath,Template,OutArray) "RTN","TMGHTML1",83,0) ;"Purpose: To write out notes listed in Template to directory FPath "RTN","TMGHTML1",84,0) ;"Input: FPath -- The name of the directory to put the output files to "RTN","TMGHTML1",85,0) ;" Template -- OPTIONAL -- the name of a search/sort template that contains "RTN","TMGHTML1",86,0) ;" list of IENS's to output "RTN","TMGHTML1",87,0) ;" If not supplied, user will be asked for name. "RTN","TMGHTML1",88,0) ;" OutArray -- An OUT parameter. PASS BY REFERENCE "RTN","TMGHTML1",89,0) ;" An array to receive results of names written. See WriteList for format "RTN","TMGHTML1",90,0) ;"Output: files are written to directory "RTN","TMGHTML1",91,0) ;"Result: none "RTN","TMGHTML1",92,0) "RTN","TMGHTML1",93,0) new List,count "RTN","TMGHTML1",94,0) set count=$$GetTemplateRecs("List",.Template) "RTN","TMGHTML1",95,0) "RTN","TMGHTML1",96,0) new PrgsFn set PrgsFn="do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",1,TMGMAX,,TMGSTART)" "RTN","TMGHTML1",97,0) "RTN","TMGHTML1",98,0) if count>0 do "RTN","TMGHTML1",99,0) . do WriteList(.List,FPath,.OutArray,PrgsFn) "RTN","TMGHTML1",100,0) "RTN","TMGHTML1",101,0) quit "RTN","TMGHTML1",102,0) "RTN","TMGHTML1",103,0) "RTN","TMGHTML1",104,0) WriteList(List,FPath,OutArray,PrgCallback) "RTN","TMGHTML1",105,0) ;"Purpose: To write out all notes given in List to separate files in FPath "RTN","TMGHTML1",106,0) ;"Input: List -- PASS BY REFERENCE. A list of IEN's that must be written. "RTN","TMGHTML1",107,0) ;" Format as follows: "RTN","TMGHTML1",108,0) ;" List(IEN1)="" "RTN","TMGHTML1",109,0) ;" List(IEN2)="" "RTN","TMGHTML1",110,0) ;" List(IEN3)="" "RTN","TMGHTML1",111,0) ;" List(IEN4)="" "RTN","TMGHTML1",112,0) ;" ... "RTN","TMGHTML1",113,0) ;" FPath -- The name of the directory that files should be written to "RTN","TMGHTML1",114,0) ;" e.g. "/tmp/output/" "RTN","TMGHTML1",115,0) ;" OutArray -- An OUT parameter. PASS BY REFERENCE "RTN","TMGHTML1",116,0) ;" An array to receive results of names written. Format: "RTN","TMGHTML1",117,0) ;" OutArray(IEN1)=Filename1 "RTN","TMGHTML1",118,0) ;" OutArray(IEN1,PatientNameAndDOB1)="" "RTN","TMGHTML1",119,0) ;" OutArray(IEN2)=Filename2 "RTN","TMGHTML1",120,0) ;" OutArray(IEN2,PatientNameAndDOB2)="" "RTN","TMGHTML1",121,0) ;" OutArray(IEN3)=Filename3 "RTN","TMGHTML1",122,0) ;" OutArray(IEN3,PatientNameAndDOB3)="" "RTN","TMGHTML1",123,0) ;" OutArray(IEN4)=Filename4 "RTN","TMGHTML1",124,0) ;" OutArray(IEN4,PatientNameAndDOB4)="" "RTN","TMGHTML1",125,0) ;" OutArray("B",PatientNameAndDOB1,IEN1)="" "RTN","TMGHTML1",126,0) ;" OutArray("B",PatientNameAndDOB1,IEN1b)="" <-- if more than one IEN per patient. "RTN","TMGHTML1",127,0) ;" OutArray("B",PatientNameAndDOB2,IEN2)="" "RTN","TMGHTML1",128,0) ;" OutArray("B",PatientNameAndDOB3,IEN3)="" "RTN","TMGHTML1",129,0) ;" OutArray("B",PatientNameAndDOB4,IEN4)="" "RTN","TMGHTML1",130,0) ;" PrgCallback: OPTIONAL -- if supplied, then M code contained in this string "RTN","TMGHTML1",131,0) ;" will be xecuted periodically, to allow display of a progress bar etc. "RTN","TMGHTML1",132,0) ;" Note: the following variables with global scope will be declared and "RTN","TMGHTML1",133,0) ;" available for use: TMGCUR (current count), TMGMAX (max count), "RTN","TMGHTML1",134,0) ;" TMGSTART (the start time "RTN","TMGHTML1",135,0) ;" "RTN","TMGHTML1",136,0) ;"Output: A series of files will be written (or overwritten) to directory "RTN","TMGHTML1",137,0) ;" Each file will be a TIU DOCUMENT in .htm format. "RTN","TMGHTML1",138,0) ;" Filename format: lastname_firstname_title_datetime.htm "RTN","TMGHTML1",139,0) ;"Result: none "RTN","TMGHTML1",140,0) "RTN","TMGHTML1",141,0) new ien "RTN","TMGHTML1",142,0) kill OutArray "RTN","TMGHTML1",143,0) new TMGMAX set TMGMAX=0 "RTN","TMGHTML1",144,0) new TMGSTART set TMGSTART=$H "RTN","TMGHTML1",145,0) new TMGCUR set TMGCUR=0 "RTN","TMGHTML1",146,0) set ien=$order(List("")) "RTN","TMGHTML1",147,0) if ien'="" for do quit:(ien="") "RTN","TMGHTML1",148,0) . set TMGMAX=TMGMAX+1 "RTN","TMGHTML1",149,0) . set ien=$order(List(ien)) "RTN","TMGHTML1",150,0) new delay set delay=0 "RTN","TMGHTML1",151,0) "RTN","TMGHTML1",152,0) set ien=$order(List("")) "RTN","TMGHTML1",153,0) if ien'="" for do quit:(ien="") "RTN","TMGHTML1",154,0) . set TMGCUR=TMGCUR+1 "RTN","TMGHTML1",155,0) . new FName "RTN","TMGHTML1",156,0) . set FName=$$MakeFName(ien) "RTN","TMGHTML1",157,0) . if $$OpenIO(FPath,FName)'=0 do "RTN","TMGHTML1",158,0) . . do Write1Note(ien) "RTN","TMGHTML1",159,0) . . do ^%ZISC ;" Close the output device "RTN","TMGHTML1",160,0) . . set OutArray(ien)=FName "RTN","TMGHTML1",161,0) . . new PtName,DOB,DFN "RTN","TMGHTML1",162,0) . . set DFN=$$GET1^DIQ(8925,ien_",",.02,"I") "RTN","TMGHTML1",163,0) . . set PtName=$$GET1^DIQ(2,DFN_",",.01) "RTN","TMGHTML1",164,0) . . set DOB=$$GET1^DIQ(2,DFN_",",.03) "RTN","TMGHTML1",165,0) . . set PtName=PtName_" "_DOB "RTN","TMGHTML1",166,0) . . set OutArray(ien,PtName)="" "RTN","TMGHTML1",167,0) . . set OutArray("B",PtName,ien)="" "RTN","TMGHTML1",168,0) . if (delay>30),$get(PrgCallback)'="" do ;"update progress bar every 30 cycles "RTN","TMGHTML1",169,0) . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGHTML1",170,0) . . xecute PrgCallback ;"call the specified progress code. "RTN","TMGHTML1",171,0) . . set delay=0 "RTN","TMGHTML1",172,0) . else set delay=delay+1 "RTN","TMGHTML1",173,0) . set ien=$order(List(ien)) "RTN","TMGHTML1",174,0) "RTN","TMGHTML1",175,0) quit "RTN","TMGHTML1",176,0) "RTN","TMGHTML1",177,0) "RTN","TMGHTML1",178,0) OpenIO(FPath,FName,NodeDiv) "RTN","TMGHTML1",179,0) ;"Purpose: to open the IO channel such that all writes "RTN","TMGHTML1",180,0) ;" will go to the file specified. "RTN","TMGHTML1",181,0) ;"Input: FPath -- the path to open file in "RTN","TMGHTML1",182,0) ;" FName -- the name of the file to open "RTN","TMGHTML1",183,0) ;" NodeDiv -- OPTIONAL (default is "/") -- the path delimiter for OS "RTN","TMGHTML1",184,0) ;"result: 1=OK To continue, 0=error "RTN","TMGHTML1",185,0) "RTN","TMGHTML1",186,0) new result set result=1 "RTN","TMGHTML1",187,0) new PFName set PFName=FPath "RTN","TMGHTML1",188,0) set NodeDiv=$get(NodeDiv,"/") "RTN","TMGHTML1",189,0) new ch "RTN","TMGHTML1",190,0) set ch=$extract(PFName,$length(PFName)) "RTN","TMGHTML1",191,0) if ch'=NodeDiv set PFName=PFName_NodeDiv "RTN","TMGHTML1",192,0) set PFName=PFName_FName "RTN","TMGHTML1",193,0) "RTN","TMGHTML1",194,0) ;"Select IO channel "RTN","TMGHTML1",195,0) set %ZIS("HFSNAME")=PFName "RTN","TMGHTML1",196,0) set %ZIS="Q" ;"queing allowed "RTN","TMGHTML1",197,0) set %ZIS("HFSMODE")="W" ;"write mode "RTN","TMGHTML1",198,0) set IOP="HFS" "RTN","TMGHTML1",199,0) "RTN","TMGHTML1",200,0) do ^%ZIS ;"standard device call "RTN","TMGHTML1",201,0) if POP do goto OIODone "RTN","TMGHTML1",202,0) . set result=0 "RTN","TMGHTML1",203,0) "RTN","TMGHTML1",204,0) use IO "RTN","TMGHTML1",205,0) "RTN","TMGHTML1",206,0) OIODone "RTN","TMGHTML1",207,0) quit result "RTN","TMGHTML1",208,0) "RTN","TMGHTML1",209,0) "RTN","TMGHTML1",210,0) MakeFName(IEN) "RTN","TMGHTML1",211,0) ;"Purpose: To create a filename from TIU DOCUMENT IEN "RTN","TMGHTML1",212,0) ;"Input -- IEN. and IEN from file 8925 "RTN","TMGHTML1",213,0) ;"Result -- the filename "RTN","TMGHTML1",214,0) "RTN","TMGHTML1",215,0) new result set result="" "RTN","TMGHTML1",216,0) new name,type,datetime "RTN","TMGHTML1",217,0) "RTN","TMGHTML1",218,0) set name=$$GET1^DIQ(8925,IEN_",",.02) "RTN","TMGHTML1",219,0) set name=$translate(name,",","_") "RTN","TMGHTML1",220,0) set name=$translate(name," ","-") "RTN","TMGHTML1",221,0) "RTN","TMGHTML1",222,0) set type=$$GET1^DIQ(8925,IEN_",",.01) "RTN","TMGHTML1",223,0) set type=$translate(type," ","-") "RTN","TMGHTML1",224,0) "RTN","TMGHTML1",225,0) set date=$$GET1^DIQ(8925,IEN_",",.07,"I") "RTN","TMGHTML1",226,0) set date=$$DTFormat^TMGMISC(date,"mm-dd-yyyy") "RTN","TMGHTML1",227,0) "RTN","TMGHTML1",228,0) set result=name_"_"_type_"_"_date_".htm" "RTN","TMGHTML1",229,0) quit result "RTN","TMGHTML1",230,0) "RTN","TMGHTML1",231,0) "RTN","TMGHTML1",232,0) GetTemplateRecs(pRecs,Template) "RTN","TMGHTML1",233,0) ;"Purpose: to ask user for a search/sort template to inport records from. "RTN","TMGHTML1",234,0) ;"Input -- pRecs -- pointer to (i.e. name of) array to fill "RTN","TMGHTML1",235,0) ;" will probably be passed with "Array(12345)" "RTN","TMGHTML1",236,0) ;" Template -- OPTIONAL. Name of template to import. "RTN","TMGHTML1",237,0) ;" If not supplied, user will be asked for name "RTN","TMGHTML1",238,0) ;"Output: Data is put into pRecs like this: "RTN","TMGHTML1",239,0) ;" @pRecs@(IEN1)="" "RTN","TMGHTML1",240,0) ;" @pRecs@(IEN2)="" "RTN","TMGHTML1",241,0) ;" @pRecs@(IEN3)="" "RTN","TMGHTML1",242,0) ;"Result: Count of records imported "RTN","TMGHTML1",243,0) ;"Note: uses global variable pHeader "RTN","TMGHTML1",244,0) "RTN","TMGHTML1",245,0) new File set File=8925 "RTN","TMGHTML1",246,0) new count set count=0 "RTN","TMGHTML1",247,0) new Y "RTN","TMGHTML1",248,0) if $get(pRecs)="" goto GTRDone "RTN","TMGHTML1",249,0) "RTN","TMGHTML1",250,0) for do quit:((+Y>0)!(+Y=-1)) "RTN","TMGHTML1",251,0) . new DIC "RTN","TMGHTML1",252,0) . set DIC=.401 "RTN","TMGHTML1",253,0) . if $get(Template)'="" do "RTN","TMGHTML1",254,0) . . set X=Template "RTN","TMGHTML1",255,0) . else do "RTN","TMGHTML1",256,0) . . set DIC(0)="AEQ" "RTN","TMGHTML1",257,0) . . write "Select a Template containing records for import. ",! "RTN","TMGHTML1",258,0) . . write "(? for list, ^ to quit) " "RTN","TMGHTML1",259,0) . . set DIC("A")="Enter Template: " "RTN","TMGHTML1",260,0) . do ^DIC "RTN","TMGHTML1",261,0) . if $get(Template)="" write ! "RTN","TMGHTML1",262,0) . if +Y'>0 quit "RTN","TMGHTML1",263,0) . new node set node=$get(^DIBT(+Y,0)) "RTN","TMGHTML1",264,0) . if $piece(node,"^",4)'=File do quit "RTN","TMGHTML1",265,0) . . set Y=0 ;"signal to try again "RTN","TMGHTML1",266,0) . . new PriorErrorFound "RTN","TMGHTML1",267,0) . . write "Error: That template doesn't contain a list of progress notes. Please select another.",! "RTN","TMGHTML1",268,0) "RTN","TMGHTML1",269,0) if (+Y>0)&($data(^DIBT(+Y,1))>1) do "RTN","TMGHTML1",270,0) . new index set index=$order(^DIBT(+Y,1,0)) "RTN","TMGHTML1",271,0) . if index'="" for do quit:(index="") "RTN","TMGHTML1",272,0) . . set @pRecs@(index)="" "RTN","TMGHTML1",273,0) . . set count=count+1 "RTN","TMGHTML1",274,0) . . set index=$order(^DIBT(+Y,1,index)) "RTN","TMGHTML1",275,0) "RTN","TMGHTML1",276,0) if $get(Template)="" write count," Records selected.",! "RTN","TMGHTML1",277,0) "RTN","TMGHTML1",278,0) GTRDone "RTN","TMGHTML1",279,0) quit count "RTN","TMGHTML1",280,0) "RTN","TMGHTML1",281,0) "RTN","TMGHTML1",282,0) "RTN","TMGHTML1",283,0) Write1Note(IEN) "RTN","TMGHTML1",284,0) ;"Purpose: To write out a progress note in HTML format "RTN","TMGHTML1",285,0) ;"Input: IEN -- the IEN in file 8925 (TIU DOCUMENT) "RTN","TMGHTML1",286,0) ;"Output: The note (in complete HTML format) is written to current "RTN","TMGHTML1",287,0) ;" output device. "RTN","TMGHTML1",288,0) ;"Result: none: "RTN","TMGHTML1",289,0) "RTN","TMGHTML1",290,0) new offset,s "RTN","TMGHTML1",291,0) new IENS set IENS=IEN_"," "RTN","TMGHTML1",292,0) "RTN","TMGHTML1",293,0) for offset=1:1 do quit:(s["{^}") "RTN","TMGHTML1",294,0) . set s=$piece($TEXT(NoteHdr+offset),";;",2) "RTN","TMGHTML1",295,0) . quit:(s["{^}") "RTN","TMGHTML1",296,0) . write s,! "RTN","TMGHTML1",297,0) "RTN","TMGHTML1",298,0) write "

",$$GET1^DIQ(8925,IENS,".01"),"

",! ;"Note type "RTN","TMGHTML1",299,0) write "

Name: ",$$GET1^DIQ(8925,IENS,".02"),"
",! ;"patient name "RTN","TMGHTML1",300,0) new Date set Date=$$GET1^DIQ(8925,IENS,".07","I") "RTN","TMGHTML1",301,0) set Date=$$DTFormat^TMGMISC(Date,"mmmm d,yyyy") "RTN","TMGHTML1",302,0) write "Date: ",Date,"

",! ;"note date "RTN","TMGHTML1",303,0) write "

Note:

",! "RTN","TMGHTML1",304,0) "RTN","TMGHTML1",305,0) new TMGWP,x "RTN","TMGHTML1",306,0) set x=$$GET1^DIQ(8925,IENS,2,"","TMGWP")="WP" "RTN","TMGHTML1",307,0) do "RTN","TMGHTML1",308,0) . new i "RTN","TMGHTML1",309,0) . write "

" "RTN","TMGHTML1",310,0) . set i=$order(TMGWP("")) "RTN","TMGHTML1",311,0) . for do quit:(i="") "RTN","TMGHTML1",312,0) . . new line set line=$get(TMGWP(i)) "RTN","TMGHTML1",313,0) . . set line=$$SYMENC^MXMLUTL(line) "RTN","TMGHTML1",314,0) . . write line,"
",! "RTN","TMGHTML1",315,0) . . set i=$order(TMGWP(i)) "RTN","TMGHTML1",316,0) . write "

",! "RTN","TMGHTML1",317,0) "RTN","TMGHTML1",318,0) write "

Note Detail:
",! "RTN","TMGHTML1",319,0) write "Author: ",$$GET1^DIQ(8925,IENS,"1202"),"
",! "RTN","TMGHTML1",320,0) write "Signature Date/Time: ",$$GET1^DIQ(8925,IENS,"1501"),"
",! "RTN","TMGHTML1",321,0) write "Status: ",$$GET1^DIQ(8925,IENS,".05"),"
",! "RTN","TMGHTML1",322,0) write "Location: ",$$GET1^DIQ(8925,IENS,"1211"),"
",! "RTN","TMGHTML1",323,0) write "Transcriptionist: ",$$GET1^DIQ(8925,IENS,"1302"),"
",! "RTN","TMGHTML1",324,0) write "Transcription Date/Time: ",$$GET1^DIQ(8925,IENS,"1201"),"
",! "RTN","TMGHTML1",325,0) ;"write "Line count: ",$$GET1^DIQ(8925,IENS,".1"),"
",! "RTN","TMGHTML1",326,0) ;"write "Character count: ",$$GET1^DIQ(8925,IENS,"22711"),"
",! "RTN","TMGHTML1",327,0) write "

",! "RTN","TMGHTML1",328,0) "RTN","TMGHTML1",329,0) write "",! "RTN","TMGHTML1",331,0) "RTN","TMGHTML1",332,0) quit "RTN","TMGHTML1",333,0) "RTN","TMGHTML1",334,0) "RTN","TMGHTML1",335,0) MakeTOC(OutArray) "RTN","TMGHTML1",336,0) ;"Purpose: To write toc.htm (the table of contents side panel) "RTN","TMGHTML1",337,0) ;"Input: IEN -- the IEN in file 8925 (TIU DOCUMENT) "RTN","TMGHTML1",338,0) ;"Output: OutArray -- PASS BY REFERENCE "RTN","TMGHTML1",339,0) ;" An array with file names written. Format: "RTN","TMGHTML1",340,0) ;" OutArray(IEN1)=Filename1 "RTN","TMGHTML1",341,0) ;" OutArray(IEN1,PatientNameAndDOB1)="" "RTN","TMGHTML1",342,0) ;" OutArray(IEN2)=Filename2 "RTN","TMGHTML1",343,0) ;" OutArray(IEN2,PatientNameAndDOB2)="" "RTN","TMGHTML1",344,0) ;" OutArray(IEN3)=Filename3 "RTN","TMGHTML1",345,0) ;" OutArray(IEN3,PatientNameAndDOB3)="" "RTN","TMGHTML1",346,0) ;" OutArray(IEN4)=Filename4 "RTN","TMGHTML1",347,0) ;" OutArray(IEN4,PatientNameAndDOB4)="" "RTN","TMGHTML1",348,0) ;" OutArray("B",PatientNameAndDOB1,IEN1)="" "RTN","TMGHTML1",349,0) ;" OutArray("B",PatientNameAndDOB1,IEN1b)="" <-- if more than one IEN per patient. "RTN","TMGHTML1",350,0) ;" OutArray("B",PatientNameAndDOB2,IEN2)="" "RTN","TMGHTML1",351,0) ;" OutArray("B",PatientNameAndDOB3,IEN3)="" "RTN","TMGHTML1",352,0) ;" OutArray("B",PatientNameAndDOB4,IEN4)="" "RTN","TMGHTML1",353,0) ;" "RTN","TMGHTML1",354,0) ;"Result: none: "RTN","TMGHTML1",355,0) "RTN","TMGHTML1",356,0) new offset,s "RTN","TMGHTML1",357,0) "RTN","TMGHTML1",358,0) for offset=1:1 do quit:(s["{^}") "RTN","TMGHTML1",359,0) . set s=$piece($TEXT(TOCHdr+offset),";;",2) "RTN","TMGHTML1",360,0) . quit:(s["{^}") "RTN","TMGHTML1",361,0) . write s,! "RTN","TMGHTML1",362,0) "RTN","TMGHTML1",363,0) ;"Write Patient name and DOB, then list of their notes , then repeat. "RTN","TMGHTML1",364,0) new Patient "RTN","TMGHTML1",365,0) set Patient=$order(OutArray("B","")) "RTN","TMGHTML1",366,0) if Patient'="" for do quit:(Patient="") "RTN","TMGHTML1",367,0) . write "

",Patient,"

",! "RTN","TMGHTML1",368,0) . write "
    ",! "RTN","TMGHTML1",369,0) . new ien set ien=$order(OutArray("B",Patient,"")) "RTN","TMGHTML1",370,0) . if ien'="" for do quit:(ien="") "RTN","TMGHTML1",371,0) . . new Type,Date,FName "RTN","TMGHTML1",372,0) . . set Type=$$GET1^DIQ(8925,ien_",",".01") ;"Note type "RTN","TMGHTML1",373,0) . . set Date=$$GET1^DIQ(8925,ien_",",".07","I") ;"note date "RTN","TMGHTML1",374,0) . . set Date=$$DTFormat^TMGMISC(Date,"mm/dd/yyyy") "RTN","TMGHTML1",375,0) . . set FName=OutArray(ien) "RTN","TMGHTML1",376,0) . . write "
  • " "RTN","TMGHTML1",377,0) . . write Type," -- ",Date "RTN","TMGHTML1",378,0) . . write "
    • ",! "RTN","TMGHTML1",379,0) . . set ien=$order(OutArray("B",Patient,ien)) "RTN","TMGHTML1",380,0) . set Patient=$order(OutArray("B",Patient)) "RTN","TMGHTML1",381,0) . write "
",! "RTN","TMGHTML1",382,0) "RTN","TMGHTML1",383,0) write "",! "RTN","TMGHTML1",385,0) "RTN","TMGHTML1",386,0) quit "RTN","TMGHTML1",387,0) "RTN","TMGHTML1",388,0) "RTN","TMGHTML1",389,0) "RTN","TMGHTML1",390,0) ;"======================================================================= "RTN","TMGHTML1",391,0) IndexDat "RTN","TMGHTML1",392,0) ;; "RTN","TMGHTML1",393,0) ;; "RTN","TMGHTML1",394,0) ;; "RTN","TMGHTML1",395,0) ;; "RTN","TMGHTML1",396,0) ;; "RTN","TMGHTML1",397,0) ;; Open VistA Exported Notes "RTN","TMGHTML1",398,0) ;; "RTN","TMGHTML1",399,0) ;; "RTN","TMGHTML1",400,0) ;; "RTN","TMGHTML1",401,0) ;; "RTN","TMGHTML1",402,0) ;; "RTN","TMGHTML1",403,0) ;; <body> "RTN","TMGHTML1",404,0) ;; </body> "RTN","TMGHTML1",405,0) ;; "RTN","TMGHTML1",406,0) ;; "RTN","TMGHTML1",407,0) ;; "RTN","TMGHTML1",408,0) ;; "RTN","TMGHTML1",409,0) ;;{^} ;"Kevin's custom end-of-data symbol "RTN","TMGHTML1",410,0) "RTN","TMGHTML1",411,0) IntroDat "RTN","TMGHTML1",412,0) ;; "RTN","TMGHTML1",413,0) ;; "RTN","TMGHTML1",414,0) ;; "RTN","TMGHTML1",415,0) ;; "RTN","TMGHTML1",416,0) ;; OpenVistA Exported Notes "RTN","TMGHTML1",417,0) ;; "RTN","TMGHTML1",418,0) ;; "RTN","TMGHTML1",419,0) ;;

Please Select A Patient from List at Left

"RTN","TMGHTML1",420,0) ;; "RTN","TMGHTML1",421,0) ;; "RTN","TMGHTML1",422,0) ;; "RTN","TMGHTML1",423,0) ;;{^} ;"Kevin's custom end-of-data symbol "RTN","TMGHTML1",424,0) "RTN","TMGHTML1",425,0) "RTN","TMGHTML1",426,0) TOCHdr "RTN","TMGHTML1",427,0) ;; "RTN","TMGHTML1",428,0) ;; "RTN","TMGHTML1",429,0) ;; "RTN","TMGHTML1",430,0) ;;OpenVista List of Patients "RTN","TMGHTML1",431,0) ;; "RTN","TMGHTML1",432,0) ;; "RTN","TMGHTML1",433,0) ;;

Introduction

"RTN","TMGHTML1",434,0) ;;

Patients

"RTN","TMGHTML1",435,0) ;; "RTN","TMGHTML1",436,0) ;;{^} ;"Kevin's custom end-of-data symbol "RTN","TMGHTML1",437,0) "RTN","TMGHTML1",438,0) "RTN","TMGHTML1",439,0) NoteHdr "RTN","TMGHTML1",440,0) ;; "RTN","TMGHTML1",441,0) ;; "RTN","TMGHTML1",442,0) ;; "RTN","TMGHTML1",443,0) ;; "RTN","TMGHTML1",444,0) ;; OpenVistA Introduction "RTN","TMGHTML1",445,0) ;; "RTN","TMGHTML1",446,0) ;; "RTN","TMGHTML1",447,0) ; "RTN","TMGHTML1",448,0) ;;{^} ;"Kevin's custom end-of-data symbol "RTN","TMGHTML1",449,0) "RTN","TMGHTML1",450,0) "RTN","TMGHUI1") 0^23^B205063 "RTN","TMGHUI1",1,0) TMGHUI1 ;TMG/kst/Custom version of HUI code ;03/25/06 "RTN","TMGHUI1",2,0) ;;1.0;TMG-LIB;**1**;01/12/05 "RTN","TMGHUI1",3,0) "RTN","TMGHUI1",4,0) "RTN","TMGHUI1",5,0) HUIPSUPD ;DLD/Pacific HUI/Updates orderable item file with PS Orderable Items ; 1/25/05 7:55am "RTN","TMGHUI1",6,0) ;;This routine populates the drug orderable items "RTN","TMGHUI1",7,0) "RTN","TMGHUI1",8,0) ;"HUI MISCELLANEOUS FUNCTIONS (used/customized in TMG library) "RTN","TMGHUI1",9,0) "RTN","TMGHUI1",10,0) ;"======================================================================= "RTN","TMGHUI1",11,0) ;" API -- Public Functions. "RTN","TMGHUI1",12,0) ;"======================================================================= "RTN","TMGHUI1",13,0) ;"myGO ;" - global list- (global lister) "RTN","TMGHUI1",14,0) "RTN","TMGHUI1",15,0) ;"======================================================================= "RTN","TMGHUI1",16,0) ;"PRIVATE API FUNCTIONS "RTN","TMGHUI1",17,0) ;"======================================================================= "RTN","TMGHUI1",18,0) "RTN","TMGHUI1",19,0) ;"======================================================================= "RTN","TMGHUI1",20,0) ;"======================================================================= "RTN","TMGHUI1",21,0) "RTN","TMGHUI1",22,0) EN "RTN","TMGHUI1",23,0) ;" loop through PS(50.7 and add to OE Ordeable item "RTN","TMGHUI1",24,0) new PSOIEN "RTN","TMGHUI1",25,0) do DT^DICRW "RTN","TMGHUI1",26,0) set PSOIEN=$order(^PS(50.7,0)) "RTN","TMGHUI1",27,0) if +PSOIEN>0 for do quit:'PSOIEN "RTN","TMGHUI1",28,0) . do ADD(PSOIEN) "RTN","TMGHUI1",29,0) . set PSOIEN=$order(^PS(50.7,PSOIEN)) "RTN","TMGHUI1",30,0) quit "RTN","TMGHUI1",31,0) "RTN","TMGHUI1",32,0) "RTN","TMGHUI1",33,0) ADD(PSOIEN) "RTN","TMGHUI1",34,0) ;" Calls PS Orderable Item update routines "RTN","TMGHUI1",35,0) do EN^PSSPOIDT(PSOIEN) "RTN","TMGHUI1",36,0) do EN2^PSSHL1(PSOIEN,"MUP") "RTN","TMGHUI1",37,0) quit "RTN","TMGHUI1",38,0) "RTN","TMGHUI1",39,0) SET "RTN","TMGHUI1",40,0) ;" - updates view set "RTN","TMGHUI1",41,0) new DIC,X,Y,IEN,D,TYPE,NM,DGNM,UPDTIME,ATTEMPT "RTN","TMGHUI1",42,0) do DT^DICRW "RTN","TMGHUI1",43,0) set DIC="^ORD(101.44," "RTN","TMGHUI1",44,0) set DIC(0)="AQ" "RTN","TMGHUI1",45,0) for D ^DIC quit:+Y quit:X="^" "RTN","TMGHUI1",46,0) quit:X="^" "RTN","TMGHUI1",47,0) set IEN=+Y "RTN","TMGHUI1",48,0) set NM=$P(Y,U,2) "RTN","TMGHUI1",49,0) set DGNM=$P(NM,"ORWDSET ",2) "RTN","TMGHUI1",50,0) set UPDTIME=$H "RTN","TMGHUI1",51,0) set ATTEMPT="" "RTN","TMGHUI1",52,0) do FVBLD^ORWUL "RTN","TMGHUI1",53,0) quit "RTN","TMGHUI1",54,0) "RTN","TMGHUI1",55,0) "RTN","TMGHUI1",56,0) myGO;" - global list- (global lister) "RTN","TMGHUI1",57,0) ;- Jan 2005 - DLD - PACIFIC HUI "RTN","TMGHUI1",58,0) ; - THis routine allows global out of a partial global "RTN","TMGHUI1",59,0) ;" //kt note: Obtained from N. Anthracite 11/4/05. She got "RTN","TMGHUI1",60,0) ;" it from Norman Dodd "RTN","TMGHUI1",61,0) ;" Reformatted for full commands "RTN","TMGHUI1",62,0) ;" User interface changes made also. "RTN","TMGHUI1",63,0) ;" This function dumps one or more globals to selected output device "RTN","TMGHUI1",64,0) "RTN","TMGHUI1",65,0) write !,"Global Output Utility",! "RTN","TMGHUI1",66,0) if '$data(%zdebug) new $et do "RTN","TMGHUI1",67,0) . set $et="zg "_$zl_":ERR^%GO" "RTN","TMGHUI1",68,0) . use $p:(ctrap=$c(3):exc="zg "_$zl_":EXIT^%GO") "RTN","TMGHUI1",69,0) new g,gn,m,n,c,gl,in,%ZD,%ZG,%ZH,fmt "RTN","TMGHUI1",70,0) set c=0 "RTN","TMGHUI1",71,0) for read !,"Enter Global ([enter] if done): ",in,! do quit:in="" "RTN","TMGHUI1",72,0) . quit:in="" "RTN","TMGHUI1",73,0) . if $extract(in)="?",$length(in)=1 do help quit "RTN","TMGHUI1",74,0) . if $extract(in)="^",$length(in)=1 set in="" quit "RTN","TMGHUI1",75,0) . if $extract(in)'="^" do help quit "RTN","TMGHUI1",76,0) . if in["(",in'[")" do help quit "RTN","TMGHUI1",77,0) . set c=c+1,gl(c)=in "RTN","TMGHUI1",78,0) if '$data(gl) write !,"No globals selected" quit "RTN","TMGHUI1",79,0) read !,"Header Label: ",%ZH,! "RTN","TMGHUI1",80,0) read !,"Output Format: GO or ZWR: ",fmt,! "RTN","TMGHUI1",81,0) if (fmt="")!($extract("ZWR",1,$length(fmt))=$translate(fmt,"zwr","ZWR")) set fmt=1 "RTN","TMGHUI1",82,0) else set fmt=0 "RTN","TMGHUI1",83,0) for do quit:$length(%ZD) "RTN","TMGHUI1",84,0) . read !,"Output device: : ",%ZD,! "RTN","TMGHUI1",85,0) . if '$length(%ZD) set %ZD=$p quit "RTN","TMGHUI1",86,0) . if %ZD="^" quit "RTN","TMGHUI1",87,0) . if %ZD="?" do quit "RTN","TMGHUI1",88,0) . . write !!,"Select the device you want for output" "RTN","TMGHUI1",89,0) . . write !,"If you wish to exit enter a carat (^)",! "RTN","TMGHUI1",90,0) . . set %ZD="" "RTN","TMGHUI1",91,0) . if $zparse(%ZD)="" write " no such device" set %ZD="" quit "RTN","TMGHUI1",92,0) . open %ZD:(newversion:block=2048:record=2044:exception="g noopen"):0 "RTN","TMGHUI1",93,0) . if '$t write !,%ZD," is not available" set %ZD="" quit "RTN","TMGHUI1",94,0) . quit "RTN","TMGHUI1",95,0) noopen . write !,$p($ZS,",",2,999),! close %ZD set %ZD="" "RTN","TMGHUI1",96,0) quit:%ZD="^" "RTN","TMGHUI1",97,0) write !! "RTN","TMGHUI1",98,0) if '$length(%ZH) set %ZH="%GO Global Output Utility" "RTN","TMGHUI1",99,0) use %ZD "RTN","TMGHUI1",100,0) write %ZH,!,"GT.M ",$zd($h,"DD-MON-YEAR 24:60:SS") "RTN","TMGHUI1",101,0) write:fmt " ZWR" "RTN","TMGHUI1",102,0) write ! "RTN","TMGHUI1",103,0) set c=0,(m,n)=0 "RTN","TMGHUI1",104,0) for set c=$order(gl(c)) quit:'+c set gn=gl(c),g=gn do "RTN","TMGHUI1",105,0) . use $p "RTN","TMGHUI1",106,0) . write:$x>70 ! "RTN","TMGHUI1",107,0) . write gn,?$x\10+1*10 "RTN","TMGHUI1",108,0) . use %ZD "RTN","TMGHUI1",109,0) . if $p=%ZD write ! "RTN","TMGHUI1",110,0) . quit:g="" "RTN","TMGHUI1",111,0) . set m=m+1 "RTN","TMGHUI1",112,0) . if $data(@g)'[0 write g do set n=n+1 "RTN","TMGHUI1",113,0) . . if fmt write "=" do fw(@g) "RTN","TMGHUI1",114,0) . . else write !,@g,! "RTN","TMGHUI1",115,0) . for set g=$q(@g) quit:g="" do "RTN","TMGHUI1",116,0) . . if fmt zwr @g "RTN","TMGHUI1",117,0) . . else write g,!,@g,! "RTN","TMGHUI1",118,0) . . set n=n+1 "RTN","TMGHUI1",119,0) use %ZD write !! "RTN","TMGHUI1",120,0) use $p "RTN","TMGHUI1",121,0) write !!,"Total of ",n," node",$s(n=1:"",1:"s") "RTN","TMGHUI1",122,0) write " in ",m," global",$s(m=1:".",1:"s."),!! "RTN","TMGHUI1",123,0) close:%ZD'=$p %ZD "RTN","TMGHUI1",124,0) use $p:(ctrap="":exc="") "RTN","TMGHUI1",125,0) quit "RTN","TMGHUI1",126,0) "RTN","TMGHUI1",127,0) fw(s) "RTN","TMGHUI1",128,0) ;" variables used in this function are: fwlen, s, cc, fastate, isctl, i, thistime "RTN","TMGHUI1",129,0) ;" initialize this procedure "RTN","TMGHUI1",130,0) set fwlen=$length(s) "RTN","TMGHUI1",131,0) if fwlen=0 write ! quit "RTN","TMGHUI1",132,0) if s=+s write s,! quit "RTN","TMGHUI1",133,0) set cc=$extract(s) "RTN","TMGHUI1",134,0) if cc?1C write "$C(",$a(cc) set fastate=2 "RTN","TMGHUI1",135,0) else write """",cc w:cc="""" cc set fastate=1 "RTN","TMGHUI1",136,0) ;" start the loop to deal with the whole string. "RTN","TMGHUI1",137,0) for i=2:1:fwlen set cc=$extract(s,i,i),isctl=cc?1C d "RTN","TMGHUI1",138,0) . set thistime=1 "RTN","TMGHUI1",139,0) . if fastate=1 do "RTN","TMGHUI1",140,0) . . if (isctl) write """_$C(",$a(cc) set fastate=2,thistime=0 "RTN","TMGHUI1",141,0) . . else write cc w:cc="""" cc "RTN","TMGHUI1",142,0) . if (fastate=2)&thistime do "RTN","TMGHUI1",143,0) . . if (isctl)!(cc="""") write ",",$a(cc) "RTN","TMGHUI1",144,0) . . else write ")_""",cc set fastate=1 "RTN","TMGHUI1",145,0) if fastate=1 write """",! "RTN","TMGHUI1",146,0) else write ")",! "RTN","TMGHUI1",147,0) quit "RTN","TMGHUI1",148,0) "RTN","TMGHUI1",149,0) ERR use $p write !,$p($zs,",",2,99),! "RTN","TMGHUI1",150,0) ; Warning - Fall-though "RTN","TMGHUI1",151,0) set $ec="" "RTN","TMGHUI1",152,0) EXIT if $data(%ZD),%ZD'=$p close %ZD "RTN","TMGHUI1",153,0) use $p:(ctrap="":exc="") "RTN","TMGHUI1",154,0) quit "RTN","TMGHUI1",155,0) "RTN","TMGHUI1",156,0) help; "RTN","TMGHUI1",157,0) write !,"Enter a global reference to start at with ^" "RTN","TMGHUI1",158,0) write !,"i.e ^DPT or ^VA(200)" "RTN","TMGHUI1",159,0) quit "RTN","TMGIDE") 0^24^B7091 "RTN","TMGIDE",1,0) TMGIDE ;TMG/kst/A debugger/tracer for GT.M ;03/25/06 "RTN","TMGIDE",2,0) ;;1.0;TMG-LIB;**1**;04/12/05 "RTN","TMGIDE",3,0) "RTN","TMGIDE",4,0) ;" A Debug/Tracer for GT.M "RTN","TMGIDE",5,0) ;" "RTN","TMGIDE",6,0) ;" K. Toppenberg "RTN","TMGIDE",7,0) ;" 4-13-2005 "RTN","TMGIDE",8,0) ;" License: GPL Applies "RTN","TMGIDE",9,0) ;" "RTN","TMGIDE",10,0) ;" "RTN","TMGIDE",11,0) ;" This program will launch a shell for the TMG STEP TRAP debugger "RTN","TMGIDE",12,0) ;" It provides the user with a prompt, like this: "RTN","TMGIDE",13,0) ;" "RTN","TMGIDE",14,0) ;" (^ to quit) IDE> "RTN","TMGIDE",15,0) ;" "RTN","TMGIDE",16,0) ;" Any valid M code may be entered here. To use the tracing "RTN","TMGIDE",17,0) ;" ability, launch a function, like this: "RTN","TMGIDE",18,0) ;" "RTN","TMGIDE",19,0) ;" (^ to quit) IDE>do ^MyFunction "RTN","TMGIDE",20,0) ;" "RTN","TMGIDE",21,0) ;" "RTN","TMGIDE",22,0) ;" Dependancies: "RTN","TMGIDE",23,0) ;" Uses TMGIDE2,TMGTERM, "RTN","TMGIDE",24,0) ;" ^DIM,XGF,XINDX7,XINDX8,XINDEX <-- VA code "RTN","TMGIDE",25,0) ;" %ZVEM* (if available) "RTN","TMGIDE",26,0) ;" "RTN","TMGIDE",27,0) ;"======================================================================= "RTN","TMGIDE",28,0) ;" API -- Public Functions. "RTN","TMGIDE",29,0) ;"======================================================================= "RTN","TMGIDE",30,0) ;"Start^TMGIDE -- launch Debugger "RTN","TMGIDE",31,0) ;"BKPT^TMGIDE -- set a breakpoint "RTN","TMGIDE",32,0) ;"KBKPT^TMGIDE -- kill (release) breakpoint "RTN","TMGIDE",33,0) "RTN","TMGIDE",34,0) ;"======================================================================= "RTN","TMGIDE",35,0) ;"PRIVATE API FUNCTIONS "RTN","TMGIDE",36,0) ;"======================================================================= "RTN","TMGIDE",37,0) ;"Prompt "RTN","TMGIDE",38,0) ;"ShutDown "RTN","TMGIDE",39,0) ;"ParsePos(pos,label,offset,routine,dmod) "RTN","TMGIDE",40,0) ;"ConvertPos(Pos,pArray) "RTN","TMGIDE",41,0) ;"ScanMod(Module,pArray) "RTN","TMGIDE",42,0) ;"BROWSENODES(current,Order,paginate,countNodes) "RTN","TMGIDE",43,0) ;"ShowNodes(pArray,order,paginate,countNodes) "RTN","TMGIDE",44,0) ;"ListCt(pArray) "RTN","TMGIDE",45,0) ;"TrimL(S,TrimCh) "RTN","TMGIDE",46,0) ;"TrimR(S,TrimCh) "RTN","TMGIDE",47,0) ;"Trim(S,TrimCh) "RTN","TMGIDE",48,0) ;"Substitute(S,Match,NewValue) "RTN","TMGIDE",49,0) ;"REPLACE(IN,SPEC) "RTN","TMGIDE",50,0) ;"DebugWrite(DBIndent,s,AddNewline) "RTN","TMGIDE",51,0) ;"DebugIndent(DBIndentForced) "RTN","TMGIDE",52,0) ;"$$ArrayDump(ArrayP,TMGIDX,indent) "RTN","TMGIDE",53,0) ;"ExpandLine(Pos) "RTN","TMGIDE",54,0) ;"CREF(X) "RTN","TMGIDE",55,0) ;"LGR() "RTN","TMGIDE",56,0) ;"UP(X) "RTN","TMGIDE",57,0) ;"READ(XGCHARS,XGTO) "RTN","TMGIDE",58,0) ;"READ2(XGCHARS,XGTO) "RTN","TMGIDE",59,0) "RTN","TMGIDE",60,0) ;"------------------------------------------------------------ "RTN","TMGIDE",61,0) ;"------------------------------------------------------------ "RTN","TMGIDE",62,0) "RTN","TMGIDE",63,0) START "RTN","TMGIDE",64,0) Start "RTN","TMGIDE",65,0) ;"Purpose: To Launch debugger. This is the entry point "RTN","TMGIDE",66,0) "RTN","TMGIDE",67,0) ;"Set up variables with global scope (used by TMGIDE2) "RTN","TMGIDE",68,0) if $get(TMGScrWidth)="" set TMGScrWidth=$get(IOM,66)-1 "RTN","TMGIDE",69,0) if $get(TMGScrHeight)="" set TMGScrHeight=10 "RTN","TMGIDE",70,0) set TMGLROffset=0 "RTN","TMGIDE",71,0) ;"set tpWatchLine="" "RTN","TMGIDE",72,0) set TMGTrap=1 ;"kt added 2/10/06 "RTN","TMGIDE",73,0) set TMGStepMode="into" ;"kt added 2/10/06 "RTN","TMGIDE",74,0) set TMGRunMode=1 ;"kt added 2/22/06 "RTN","TMGIDE",75,0) set TMGZTRAP=$ZTRAP "RTN","TMGIDE",76,0) "RTN","TMGIDE",77,0) new tpHideList "RTN","TMGIDE",78,0) set tpHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) "RTN","TMGIDE",79,0) set @tpHideList@("TMGIDE")="" "RTN","TMGIDE",80,0) set @tpHideList@("TMGIDE2")="" "RTN","TMGIDE",81,0) set @tpHideList@("TMGIDE3")="" "RTN","TMGIDE",82,0) set @tpHideList@("TMGIDE4")="" "RTN","TMGIDE",83,0) set @tpHideList@("TMGTERM")="" "RTN","TMGIDE",84,0) set @tpHideList@("%ZVE")="" "RTN","TMGIDE",85,0) set @tpHideList@("%ZVEMK")="" "RTN","TMGIDE",86,0) set @tpHideList@("XGF")="" "RTN","TMGIDE",87,0) set @tpHideList@("XGKB")="" "RTN","TMGIDE",88,0) "RTN","TMGIDE",89,0) do SetGlobals^TMGTERM "RTN","TMGIDE",90,0) do ensureBreakpoints^TMGIDE2() "RTN","TMGIDE",91,0) "RTN","TMGIDE",92,0) new Menu,UsrSlct "RTN","TMGIDE",93,0) M1 set Menu(0)="Welcome to the TMG debugging environment" "RTN","TMGIDE",94,0) set Menu(1)="Start debugger in THIS window."_$char(9)_"AllInOne" "RTN","TMGIDE",95,0) set Menu(2)="Start debugger LISTENER."_$char(9)_"StartListener" "RTN","TMGIDE",96,0) set Menu(3)="Debug, SENDING output to a listener."_$char(9)_"StartSender" "RTN","TMGIDE",97,0) set Menu(4)="Set a custom breakpoint"_$char(9)_"SetBreakpoint" "RTN","TMGIDE",98,0) set Menu(5)="Kill a custom breakpoint"_$char(9)_"KillBreakpoint" "RTN","TMGIDE",99,0) "RTN","TMGIDE",100,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGIDE",101,0) "RTN","TMGIDE",102,0) if UsrSlct="AllInOne" goto MenuDone "RTN","TMGIDE",103,0) if UsrSlct="StartListener" do Listener^TMGIDE3 goto M1 "RTN","TMGIDE",104,0) if UsrSlct="StartSender" do Sender^TMGIDE4 goto M1 "RTN","TMGIDE",105,0) if UsrSlct="SetBreakpoint" do BKPT goto M1 "RTN","TMGIDE",106,0) if UsrSlct="KillBreakpoint" do KBKPT goto M1 "RTN","TMGIDE",107,0) if UsrSlct="^" goto Done "RTN","TMGIDE",108,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGIDE",109,0) goto M1 "RTN","TMGIDE",110,0) "RTN","TMGIDE",111,0) MenuDone "RTN","TMGIDE",112,0) for i=1:1:10 write ! "RTN","TMGIDE",113,0) write !,"Welcome to the TMG debugging environment",! "RTN","TMGIDE",114,0) write "Enter any valid M command...",! "RTN","TMGIDE",115,0) do SetErrTrap "RTN","TMGIDE",116,0) "RTN","TMGIDE",117,0) do Prompt("AllInOne") "RTN","TMGIDE",118,0) Done "RTN","TMGIDE",119,0) do ShutDown "RTN","TMGIDE",120,0) quit "RTN","TMGIDE",121,0) "RTN","TMGIDE",122,0) ;"------------------------------------------------------------------- "RTN","TMGIDE",123,0) SetErrTrap "RTN","TMGIDE",124,0) set $ZTRAP="do ErrTrap^TMGIDE2($ZPOS) break" "RTN","TMGIDE",125,0) set $ZSTATUS="" "RTN","TMGIDE",126,0) quit "RTN","TMGIDE",127,0) "RTN","TMGIDE",128,0) Prompt(Mode) "RTN","TMGIDE",129,0) ;"Purpose: to interact with user and run through code. "RTN","TMGIDE",130,0) ;"Mode: OPTIONAL: Default is 'AllInOne' "RTN","TMGIDE",131,0) ;" AllInOne --> debug output to same window "RTN","TMGIDE",132,0) ;" SendOut --> debug output to Listener widow "RTN","TMGIDE",133,0) "RTN","TMGIDE",134,0) set Mode=$get(Mode,"AllInOne") "RTN","TMGIDE",135,0) new BlankLine set $piece(BlankLine," ",78)=" " "RTN","TMGIDE",136,0) new HxSize set HxSize=8 ;"hard codes in history length of 8 "RTN","TMGIDE",137,0) new TMGdbgLine "RTN","TMGIDE",138,0) new TMGlastline set TMGlastLine="" "RTN","TMGIDE",139,0) new HxShowNum set HxShowNum=0 "RTN","TMGIDE",140,0) new HxLine,HxLineMax,HxLineCur "RTN","TMGIDE",141,0) do INITKB^XGF() ;"set up keyboard input escape code processing "RTN","TMGIDE",142,0) "RTN","TMGIDE",143,0) Ppt2 "RTN","TMGIDE",144,0) set HxShowNum=+$get(HxShowNum) "RTN","TMGIDE",145,0) set TMGStepMode="into" ;"kt added 5/3/06 "RTN","TMGIDE",146,0) set HxLine=$get(^TMG("TMGIDE","CMD HISTORY",$J,HxShowNum)) "RTN","TMGIDE",147,0) set HxLineMax=$get(^TMG("TMGIDE","CMD HISTORY",$J,"MAX"),0) "RTN","TMGIDE",148,0) "RTN","TMGIDE",149,0) write "(^ to quit) " "RTN","TMGIDE",150,0) if HxShowNum=0 write "^// " "RTN","TMGIDE",151,0) else write "// ",HxLine "RTN","TMGIDE",152,0) "RTN","TMGIDE",153,0) set TMGdbgLine=$$READ() ;"$$READ^XGF ;"returns line terminator in TMGXGRT "RTN","TMGIDE",154,0) ;"read TMGdbgLine,! "RTN","TMGIDE",155,0) ;"write "[TMGXGRT=",TMGXGRT,"]" "RTN","TMGIDE",156,0) if TMGdbgLine="?" do goto Ppt2 "RTN","TMGIDE",157,0) . write !,"Here you should enter any valid M command, as would normally",! "RTN","TMGIDE",158,0) . write "entered at a GTM> prompt.",! "RTN","TMGIDE",159,0) . write " examples: WRITE ""HELLO"",! or DO ^TMGTEST",! "RTN","TMGIDE",160,0) "RTN","TMGIDE",161,0) if (TMGdbgLine="")&(HxShowNum>0) set TMGdbgLine=HxLine "RTN","TMGIDE",162,0) ;"if (TMGdbgLine="")&(TMGXGRT="CR")&(HxShowNum>0) set TMGdbgLine=HxLine "RTN","TMGIDE",163,0) "RTN","TMGIDE",164,0) if (TMGXGRT="DOWN")!(TMGXGRT="RIGHT")!(TMGdbgLine="]") do goto Ppt2 "RTN","TMGIDE",165,0) . set HxShowNum=HxShowNum-1 "RTN","TMGIDE",166,0) . if HxShowNum<0 set HxShowNum=HxLineMax "RTN","TMGIDE",167,0) . ;"write "setting HxShowNum=",HxShowNum,! "RTN","TMGIDE",168,0) . do CHA^TMGTERM(1) write BlankLine do CHA^TMGTERM(1) "RTN","TMGIDE",169,0) "RTN","TMGIDE",170,0) if (TMGXGRT="UP")!(TMGXGRT="LEFT")!(TMGdbgLine="[") do goto Ppt2 "RTN","TMGIDE",171,0) . set HxShowNum=HxShowNum+1 "RTN","TMGIDE",172,0) . if HxShowNum>HxLineMax set HxShowNum=0 "RTN","TMGIDE",173,0) . ;"write "setting HxShowNum=",HxShowNum,! "RTN","TMGIDE",174,0) . do CHA^TMGTERM(1) write BlankLine do CHA^TMGTERM(1) "RTN","TMGIDE",175,0) "RTN","TMGIDE",176,0) if TMGdbgLine="" set TMGdbgLine="^" "RTN","TMGIDE",177,0) if TMGdbgLine="^" set $ZSTEP="" quit "RTN","TMGIDE",178,0) write ! "RTN","TMGIDE",179,0) "RTN","TMGIDE",180,0) ;"Save Cmd history "RTN","TMGIDE",181,0) set HxLineCur=$get(^TMG("TMGIDE","CMD HISTORY",$J,"CUR"),0) ;"<-- points to last used, not next avail "RTN","TMGIDE",182,0) set HxLineMax=$get(^TMG("TMGIDE","CMD HISTORY",$J,"MAX"),0) ;"equals buffer size AFTER it fills "RTN","TMGIDE",183,0) set HxLineCur=HxLineCur+1 "RTN","TMGIDE",184,0) if HxLineCur>HxSize set HxLineCur=1 "RTN","TMGIDE",185,0) set ^TMG("TMGIDE","CMD HISTORY",$J,HxLineCur)=TMGdbgLine "RTN","TMGIDE",186,0) set ^TMG("TMGIDE","CMD HISTORY",$J,"CUR")=HxLineCur "RTN","TMGIDE",187,0) if HxLineCur>HxLineMax do "RTN","TMGIDE",188,0) . set HxLineMax=HxLineCur "RTN","TMGIDE",189,0) . set ^TMG("TMGIDE","CMD HISTORY",$J,"MAX")=HxLineMax "RTN","TMGIDE",190,0) "RTN","TMGIDE",191,0) set TMGRunMode=1 ;"1=Step-by-step mode "RTN","TMGIDE",192,0) set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" "RTN","TMGIDE",193,0) "RTN","TMGIDE",194,0) set HxShowNum=0 "RTN","TMGIDE",195,0) zstep into "RTN","TMGIDE",196,0) xecute TMGdbgLine "RTN","TMGIDE",197,0) set $ZSTEP="" ;"turn off step capture "RTN","TMGIDE",198,0) write ! "RTN","TMGIDE",199,0) goto Ppt2 "RTN","TMGIDE",200,0) "RTN","TMGIDE",201,0) ;"------------------------------------------------------------------- "RTN","TMGIDE",202,0) "RTN","TMGIDE",203,0) ShutDown "RTN","TMGIDE",204,0) do KillGlobals^TMGTERM "RTN","TMGIDE",205,0) "RTN","TMGIDE",206,0) ;"kill TMGScrWidth "RTN","TMGIDE",207,0) ;"kill TMGScrHeight "RTN","TMGIDE",208,0) ;"kill TMGLROffset "RTN","TMGIDE",209,0) ;"kill tpWatchLine "RTN","TMGIDE",210,0) kill TMGStepMode ;" 2/10/06 kt "RTN","TMGIDE",211,0) kill ^TMP("TreadMGIDE",$J,"MODULES") "RTN","TMGIDE",212,0) do VTATRIB^TMGTERM(0) "RTN","TMGIDE",213,0) do RESETKB^XGF ;"turn off XGF escape key processing code. "RTN","TMGIDE",214,0) write "Leaving TMG debugging environment. Goodbye.",! "RTN","TMGIDE",215,0) quit "RTN","TMGIDE",216,0) "RTN","TMGIDE",217,0) ;"------------------------------------------------------------------- "RTN","TMGIDE",218,0) "RTN","TMGIDE",219,0) BKPT "RTN","TMGIDE",220,0) ;"Purpose: To ask user for an address, and set a breakpoint there "RTN","TMGIDE",221,0) ;" This can be done from GTM prompt, and debugger will be launched "RTN","TMGIDE",222,0) ;" when this address is reached during normal execution. "RTN","TMGIDE",223,0) "RTN","TMGIDE",224,0) read "Enter breakpoint (e.g. Label+8^MyFunct): ",Pos,! "RTN","TMGIDE",225,0) do SetBreakpoint^TMGIDE2(Pos) "RTN","TMGIDE",226,0) set $ZTRAP="" ;"This makes sure that Fileman error trap is not active "RTN","TMGIDE",227,0) quit "RTN","TMGIDE",228,0) "RTN","TMGIDE",229,0) "RTN","TMGIDE",230,0) KBKPT "RTN","TMGIDE",231,0) ;"Purpose: To ask user for an address, and kill (release) breakpoint there "RTN","TMGIDE",232,0) ;" This can be done from GTM prompt "RTN","TMGIDE",233,0) "RTN","TMGIDE",234,0) read "Enter breakpoint to be killed (released) (e.g. Label+8^MyFunct): ",Pos,! "RTN","TMGIDE",235,0) do RelBreakpoint^TMGIDE2(Pos) "RTN","TMGIDE",236,0) quit "RTN","TMGIDE",237,0) "RTN","TMGIDE",238,0) "RTN","TMGIDE",239,0) ;"------------------------------------------------------------ "RTN","TMGIDE",240,0) ;"------------------------------------------------------------ "RTN","TMGIDE",241,0) ;"Support Functions "RTN","TMGIDE",242,0) ;"------------------------------------------------------------ "RTN","TMGIDE",243,0) ;"------------------------------------------------------------ "RTN","TMGIDE",244,0) "RTN","TMGIDE",245,0) ParsePos(pos,label,offset,routine,dmod) "RTN","TMGIDE",246,0) ;"NOTE: Duplicate of function in TMGMISC "RTN","TMGIDE",247,0) ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts "RTN","TMGIDE",248,0) ;"Input: pos -- the string, as example above "RTN","TMGIDE",249,0) ;" label -- OUT PARAM, PASS BY REF, would return "x" "RTN","TMGIDE",250,0) ;" offset -- OUT PARAM, PASS BY REF, would return "+2" "RTN","TMGIDE",251,0) ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE" "RTN","TMGIDE",252,0) ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD" "RTN","TMGIDE",253,0) ;"Results: none "RTN","TMGIDE",254,0) ;"Note: results are shortened to 8 characters. "RTN","TMGIDE",255,0) "RTN","TMGIDE",256,0) new s "RTN","TMGIDE",257,0) set s=$get(pos) "RTN","TMGIDE",258,0) set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE "RTN","TMGIDE",259,0) set routine=$piece(s,"^",2) "RTN","TMGIDE",260,0) ;"set routine=$extract(routine,1,8) //kt remove 3/1/08, new GTM needs > 8 chars "RTN","TMGIDE",261,0) set label=$piece(s,"^",1) "RTN","TMGIDE",262,0) set offset=$piece(label,"+",2) "RTN","TMGIDE",263,0) set label=$piece(label,"+",1) "RTN","TMGIDE",264,0) ;"set label=$extract(label,1,8) //kt remove 3/1/08, new GTM needs > 8 chars "RTN","TMGIDE",265,0) "RTN","TMGIDE",266,0) quit "RTN","TMGIDE",267,0) "RTN","TMGIDE",268,0) "RTN","TMGIDE",269,0) ConvertPos(Pos,pArray) "RTN","TMGIDE",270,0) ;"NOTE: Duplicate of function in TMGMISC "RTN","TMGIDE",271,0) ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into "RTN","TMGIDE",272,0) ;" one that is relative to the start of the file "RTN","TMGIDE",273,0) ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT "RTN","TMGIDE",274,0) ;"Input: Pos -- a position, as returned from $ZPOS "RTN","TMGIDE",275,0) ;" pArray -- pointer to (name of). Array holding holding tag offsets "RTN","TMGIDE",276,0) ;" pArray will be in this format: "RTN","TMGIDE",277,0) ;" pArray("ModuleA",1,"TAG")="ALabel1" "RTN","TMGIDE",278,0) ;" pArray("ModuleA",1,"OFFSET")=1 "RTN","TMGIDE",279,0) ;" pArray("ModuleA",2,"TAG")="ALabel2" "RTN","TMGIDE",280,0) ;" pArray("ModuleA",2,"OFFSET")=9 "RTN","TMGIDE",281,0) ;" pArray("ModuleA","Label1")=1 "RTN","TMGIDE",282,0) ;" pArray("ModuleA","Label2")=2 "RTN","TMGIDE",283,0) ;" pArray("ModuleA","Label3")=3 "RTN","TMGIDE",284,0) ;" pArray("ModuleB",1,"TAG")="BLabel1" "RTN","TMGIDE",285,0) ;" pArray("ModuleB",1,"OFFSET")=4 "RTN","TMGIDE",286,0) ;" pArray("ModuleB",2,"TAG")="BLabel2" "RTN","TMGIDE",287,0) ;" pArray("ModuleB",2,"OFFSET")=23 "RTN","TMGIDE",288,0) ;" pArray("ModuleB","Label1")=1 "RTN","TMGIDE",289,0) ;" pArray("ModuleB","Label2")=2 "RTN","TMGIDE",290,0) ;" pArray("ModuleB","Label3")=3 "RTN","TMGIDE",291,0) ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it "RTN","TMGIDE",292,0) ;"Result: returns the new position line, relative to the start of the file/module "RTN","TMGIDE",293,0) ;" "RTN","TMGIDE",294,0) "RTN","TMGIDE",295,0) new cpS "RTN","TMGIDE",296,0) new cpResult set cpResult="" "RTN","TMGIDE",297,0) new cpRoutine,cpLabel,cpOffset "RTN","TMGIDE",298,0) "RTN","TMGIDE",299,0) set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE "RTN","TMGIDE",300,0) if cpS="" do goto CPDone "RTN","TMGIDE",301,0) . write "Parse error: Nothing before $ in",cpS,! "RTN","TMGIDE",302,0) "RTN","TMGIDE",303,0) set cpRoutine=$piece(cpS,"^",2) "RTN","TMGIDE",304,0) if cpRoutine="" do goto CPDone "RTN","TMGIDE",305,0) . write "Parse error: No routine specified in: ",cpS,! "RTN","TMGIDE",306,0) "RTN","TMGIDE",307,0) set cpS=$piece(cpS,"^",1) "RTN","TMGIDE",308,0) set cpOffset=+$piece(cpS,"+",2) "RTN","TMGIDE",309,0) ;"if cpOffset="" set cpOffset=1 "RTN","TMGIDE",310,0) ;"else set cpOffset=+cpOffset "RTN","TMGIDE",311,0) set cpLabel=$piece(cpS,"+",1) "RTN","TMGIDE",312,0) "RTN","TMGIDE",313,0) if $data(@pArray@(cpRoutine))=0 do "RTN","TMGIDE",314,0) . new p2Array set p2Array=$name(@pArray@(cpRoutine)) "RTN","TMGIDE",315,0) . do ScanMod(cpRoutine,p2Array) "RTN","TMGIDE",316,0) "RTN","TMGIDE",317,0) new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel)) "RTN","TMGIDE",318,0) if cpIdx=0 do goto CPDone "RTN","TMGIDE",319,0) . ;"write "Parse error: Can't find ",cpRoutine,",",cpLabel," in stored source code.",! "RTN","TMGIDE",320,0) new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") "RTN","TMGIDE",321,0) set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine "RTN","TMGIDE",322,0) "RTN","TMGIDE",323,0) CPDone "RTN","TMGIDE",324,0) quit cpResult "RTN","TMGIDE",325,0) "RTN","TMGIDE",326,0) "RTN","TMGIDE",327,0) RelConvertPos(Pos,ViewOffset,pArray) "RTN","TMGIDE",328,0) ;"Purpose: to convert a positioning line from one that is relative to "RTN","TMGIDE",329,0) ;" the start of the file to one that is relative to the "RTN","TMGIDE",330,0) ;" last tag/label "RTN","TMGIDE",331,0) ;" e.g. +32^MYFUNCT --> START+8^MYFUNCT "RTN","TMGIDE",332,0) ;" I.e. this function in the OPPOSITE of ConvertPos "RTN","TMGIDE",333,0) ;"Input: Pos -- a position, as returned from $ZPOS "RTN","TMGIDE",334,0) ;" ViewOffset -- the offset from the Pos to get pos for "RTN","TMGIDE",335,0) ;" pArray -- pointer to (name of). Array holding holding tag offsets "RTN","TMGIDE",336,0) ;" see Description in ConvertPos() "RTN","TMGIDE",337,0) ;"Result: returns the new position line, relative to the start of the last tag/label "RTN","TMGIDE",338,0) "RTN","TMGIDE",339,0) ;"write !,"Here in RelConvertPos. Pos=",Pos," ViewOffset=",ViewOffset,! "RTN","TMGIDE",340,0) new zbRelPos,zbLabel,zbOffset,zbRoutine "RTN","TMGIDE",341,0) do ParsePos^TMGIDE(Pos,.zbLabel,.zbOffset,.zbRoutine) "RTN","TMGIDE",342,0) set zbRelPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine "RTN","TMGIDE",343,0) new zbTemp set zbTemp=zbRelPos "RTN","TMGIDE",344,0) ;"5/27/07 I don't know why following line was here. Removing. "RTN","TMGIDE",345,0) ;"It was breaking the setting of breakpoints. I wonder if I have now "RTN","TMGIDE",346,0) ;"broken conditional breakpoints... Figure that out later... "RTN","TMGIDE",347,0) ;"set zbRelPos=$$ConvertPos^TMGIDE(zbRelPos,pArray) "RTN","TMGIDE",348,0) if zbRelPos="" do "RTN","TMGIDE",349,0) . write "Before ConvertPos, zbRelPos=",zbTemp,! "RTN","TMGIDE",350,0) . write "Afterwards, zbRelPos=""""",! "RTN","TMGIDE",351,0) ;"write "Done RelConvertPos. Result=",zbRelPos,! "RTN","TMGIDE",352,0) quit zbRelPos "RTN","TMGIDE",353,0) "RTN","TMGIDE",354,0) "RTN","TMGIDE",355,0) ScanMod(Module,pArray) "RTN","TMGIDE",356,0) ;"NOTE: Duplicate of function in TMGMISC "RTN","TMGIDE",357,0) ;"Purpose: To scan a module and find all the labels/entry points/Entry points "RTN","TMGIDE",358,0) ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") "RTN","TMGIDE",359,0) ;" pArray -- pointer to (NAME OF) array Will be filled like this "RTN","TMGIDE",360,0) ;" pArray(1,"TAG")="Label1" "RTN","TMGIDE",361,0) ;" pArray(1,"OFFSET")=1 "RTN","TMGIDE",362,0) ;" pArray(2,"TAG")="Label2" "RTN","TMGIDE",363,0) ;" pArray(2,"OFFSET")=9 "RTN","TMGIDE",364,0) ;" pArray(3,"TAG")="Label3" etc. "RTN","TMGIDE",365,0) ;" pArray(3,"OFFSET")=15 "RTN","TMGIDE",366,0) ;" pArray("Label1")=1 "RTN","TMGIDE",367,0) ;" pArray("Label2")=2 "RTN","TMGIDE",368,0) ;" pArray("Label3")=3 "RTN","TMGIDE",369,0) ;" "RTN","TMGIDE",370,0) ;" NOTE: there seems to be a problem if the passed pArray value is "pArray", "RTN","TMGIDE",371,0) ;" so use another name. "RTN","TMGIDE",372,0) ;" "RTN","TMGIDE",373,0) ;"Output: Results are put into array "RTN","TMGIDE",374,0) ;"Result: none "RTN","TMGIDE",375,0) "RTN","TMGIDE",376,0) new smIdx set smIdx=1 "RTN","TMGIDE",377,0) new LabelNum set LabelNum=0 "RTN","TMGIDE",378,0) new smLine set smLine="" "RTN","TMGIDE",379,0) if $get(Module)="" goto SMDone "RTN","TMGIDE",380,0) ;"look for a var with global scope to see how how many characters are significant to GT.M "RTN","TMGIDE",381,0) if $get(zbSigNameLen)="" do "RTN","TMGIDE",382,0) . set zbSigNameLen=$$NumSigChs^TMGMISC() "RTN","TMGIDE",383,0) "RTN","TMGIDE",384,0) for do quit:(smLine="") "RTN","TMGIDE",385,0) . new smCh "RTN","TMGIDE",386,0) . set smLine=$text(+smIdx^@Module) "RTN","TMGIDE",387,0) . if smLine="" quit "RTN","TMGIDE",388,0) . set smLine=$$Substitute(smLine,$Char(9)," ") ;"replace tabs for 8 spaces "RTN","TMGIDE",389,0) . set smCh=$extract(smLine,1) "RTN","TMGIDE",390,0) . if (smCh'=" ")&(smCh'=";") do "RTN","TMGIDE",391,0) . . new label "RTN","TMGIDE",392,0) . . set label=$piece(smLine," ",1) "RTN","TMGIDE",393,0) . . set label=$piece(label,"(",1) ;"MyFunct(X,Y) --> MyFunct "RTN","TMGIDE",394,0) . . set label=$extract(label,1,zbSigNameLen) "RTN","TMGIDE",395,0) . . set LabelNum=LabelNum+1 "RTN","TMGIDE",396,0) . . set @pArray@(LabelNum,"TAG")=label "RTN","TMGIDE",397,0) . . set @pArray@(LabelNum,"OFFSET")=smIdx "RTN","TMGIDE",398,0) . . set @pArray@(label)=LabelNum "RTN","TMGIDE",399,0) . set smIdx=smIdx+1 "RTN","TMGIDE",400,0) "RTN","TMGIDE",401,0) SMDone "RTN","TMGIDE",402,0) quit "RTN","TMGIDE",403,0) "RTN","TMGIDE",404,0) "RTN","TMGIDE",405,0) "RTN","TMGIDE",406,0) BROWSENODES(current,Order,paginate,countNodes) "RTN","TMGIDE",407,0) ;"NOTE: Duplicate of function in TMGMISC "RTN","TMGIDE",408,0) ;"Purpose: to display nodes of specified array "RTN","TMGIDE",409,0) ;"Input: Current -- The reference to display "RTN","TMGIDE",410,0) ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order "RTN","TMGIDE",411,0) ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page "RTN","TMGIDE",412,0) ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. "RTN","TMGIDE",413,0) "RTN","TMGIDE",414,0) new parent,child "RTN","TMGIDE",415,0) set parent="" "RTN","TMGIDE",416,0) set order=$get(order,1) "RTN","TMGIDE",417,0) set paginate=$get(paginate,0) "RTN","TMGIDE",418,0) set countNodes=$get(countNodes,0) "RTN","TMGIDE",419,0) "RTN","TMGIDE",420,0) new len set len=$length(current) "RTN","TMGIDE",421,0) new lastChar set lastChar=$extract(current,len) "RTN","TMGIDE",422,0) if lastChar'=")" do "RTN","TMGIDE",423,0) . if current'["(" quit "RTN","TMGIDE",424,0) . if lastChar="," set current=$extract(current,1,len-1) "RTN","TMGIDE",425,0) . if lastChar="(" set current=$extract(current,1,len-1) quit "RTN","TMGIDE",426,0) . set current=current_")" "RTN","TMGIDE",427,0) "RTN","TMGIDE",428,0) BNLoop "RTN","TMGIDE",429,0) if current="" goto BNDone "RTN","TMGIDE",430,0) set child=$$ShowNodes(current,order,paginate,countNodes) "RTN","TMGIDE",431,0) if child'="" do "RTN","TMGIDE",432,0) . set parent(child)=current "RTN","TMGIDE",433,0) . set current=child "RTN","TMGIDE",434,0) else set current=$get(parent(current)) "RTN","TMGIDE",435,0) goto BNLoop "RTN","TMGIDE",436,0) BNDone "RTN","TMGIDE",437,0) quit "RTN","TMGIDE",438,0) "RTN","TMGIDE",439,0) "RTN","TMGIDE",440,0) ShowNodes(pArray,order,paginate,countNodes) "RTN","TMGIDE",441,0) ;"NOTE: Duplicate of function in TMGMISC "RTN","TMGIDE",442,0) ;"Purpose: To display all the nodes of the given array "RTN","TMGIDE",443,0) ;"Input: pArray -- NAME OF array to display "RTN","TMGIDE",444,0) ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order "RTN","TMGIDE",445,0) ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page "RTN","TMGIDE",446,0) ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. "RTN","TMGIDE",447,0) ;"Results: returns NAME OF next node to display (or "" if none) "RTN","TMGIDE",448,0) "RTN","TMGIDE",449,0) new TMGi "RTN","TMGIDE",450,0) new count set count=1 "RTN","TMGIDE",451,0) new Answers "RTN","TMGIDE",452,0) new someShown set someShown=0 "RTN","TMGIDE",453,0) new abort set abort=0 "RTN","TMGIDE",454,0) set paginate=$get(paginate,0) "RTN","TMGIDE",455,0) new pageCount set pageCount=0 "RTN","TMGIDE",456,0) new pageLen set pageLen=20 "RTN","TMGIDE",457,0) set countNodes=$get(countNodes,0) "RTN","TMGIDE",458,0) "RTN","TMGIDE",459,0) write pArray,! "RTN","TMGIDE",460,0) set TMGi=$order(@pArray@(""),order) "RTN","TMGIDE",461,0) if TMGi'="" for do quit:(TMGi="")!(abort=1) "RTN","TMGIDE",462,0) . write count,". +--[",TMGi,"]" "RTN","TMGIDE",463,0) . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")" "RTN","TMGIDE",464,0) . write "=",$extract($get(@pArray@(TMGi)),1,40),! "RTN","TMGIDE",465,0) . set someShown=1 "RTN","TMGIDE",466,0) . set Answers(count)=$name(@pArray@(TMGi)) "RTN","TMGIDE",467,0) . set count=count+1 "RTN","TMGIDE",468,0) . new zbTemp read *zbTemp:0 "RTN","TMGIDE",469,0) . if zbTemp'=-1 set abort=1 "RTN","TMGIDE",470,0) . set pageCount=pageCount+1 "RTN","TMGIDE",471,0) . if (paginate=1)&(pageCount>pageLen) do "RTN","TMGIDE",472,0) . . new zbTemp "RTN","TMGIDE",473,0) . . read "Press [ENTER] to continue (^ to stop list)...",zbTemp:$get(DTIME,3600),! "RTN","TMGIDE",474,0) . . if zbTemp="^" set abort=1 "RTN","TMGIDE",475,0) . . set pageCount=0 "RTN","TMGIDE",476,0) . set TMGi=$order(@pArray@(TMGi),order) "RTN","TMGIDE",477,0) "RTN","TMGIDE",478,0) if someShown=0 write " (no data)",! "RTN","TMGIDE",479,0) write !,"Enter # to browse (^ to backup): ^//" "RTN","TMGIDE",480,0) new zbTemp read zbTemp:$get(DTIME,3600),! "RTN","TMGIDE",481,0) "RTN","TMGIDE",482,0) new result set result=$get(Answers(zbTemp)) "RTN","TMGIDE",483,0) "RTN","TMGIDE",484,0) quit result "RTN","TMGIDE",485,0) "RTN","TMGIDE",486,0) "RTN","TMGIDE",487,0) ListCt(pArray) "RTN","TMGIDE",488,0) ;"NOTE: Duplicate of function in TMGMISC "RTN","TMGIDE",489,0) ;"SCOPE: PUBLIC "RTN","TMGIDE",490,0) ;"Purpose: to count the number of entries in an array "RTN","TMGIDE",491,0) ;"Input: pointer to (name of) array to test. "RTN","TMGIDE",492,0) ;"Output: the number of entries at highest level "RTN","TMGIDE",493,0) ;" e.g. Array("TELEPHONE")=1234 "RTN","TMGIDE",494,0) ;" Array("CAR")=4764 "RTN","TMGIDE",495,0) ;" Array("DOG")=5213 "RTN","TMGIDE",496,0) ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted. "RTN","TMGIDE",497,0) ;" The above array would have a count of 3 "RTN","TMGIDE",498,0) new i,result set result=0 "RTN","TMGIDE",499,0) "RTN","TMGIDE",500,0) do "RTN","TMGIDE",501,0) . new $etrap "RTN","TMGIDE",502,0) . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit" "RTN","TMGIDE",503,0) . set i=$order(@pArray@("")) "RTN","TMGIDE",504,0) . if i="" quit "RTN","TMGIDE",505,0) . for set result=result+1 set i=$order(@pArray@(i)) quit:i="" "RTN","TMGIDE",506,0) "RTN","TMGIDE",507,0) quit result "RTN","TMGIDE",508,0) "RTN","TMGIDE",509,0) "RTN","TMGIDE",510,0) TrimL(S,TrimCh) "RTN","TMGIDE",511,0) ;"NOTE: Duplicate of function in TMGSTUTL "RTN","TMGIDE",512,0) ;"Purpose: To a trip a string of leading white space "RTN","TMGIDE",513,0) ;" i.e. convert " hello" into "hello" "RTN","TMGIDE",514,0) ;"Input: S -- the string to convert. Won't be changed if passed by reference "RTN","TMGIDE",515,0) ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " "RTN","TMGIDE",516,0) ;"Results: returns modified string "RTN","TMGIDE",517,0) ;"Note: processing limitation is string length=1024 "RTN","TMGIDE",518,0) "RTN","TMGIDE",519,0) set TrimCh=$get(TrimCh," ") "RTN","TMGIDE",520,0) "RTN","TMGIDE",521,0) new result set result=$get(S) "RTN","TMGIDE",522,0) new Ch set Ch="" "RTN","TMGIDE",523,0) "RTN","TMGIDE",524,0) for do quit:(Ch'=TrimCh) "RTN","TMGIDE",525,0) . set Ch=$extract(result,1,1) "RTN","TMGIDE",526,0) . if Ch=TrimCh do "RTN","TMGIDE",527,0) . . set result=$extract(result,2,1024) "RTN","TMGIDE",528,0) "RTN","TMGIDE",529,0) quit result "RTN","TMGIDE",530,0) "RTN","TMGIDE",531,0) "RTN","TMGIDE",532,0) TrimR(S,TrimCh) "RTN","TMGIDE",533,0) ;"NOTE: Duplicate of function in TMGSTUTL "RTN","TMGIDE",534,0) ;"Purpose: To a trip a string of trailing white space "RTN","TMGIDE",535,0) ;" i.e. convert "hello " into "hello" "RTN","TMGIDE",536,0) ;"Input: S -- the string to convert. Won't be changed if passed by reference "RTN","TMGIDE",537,0) ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " "RTN","TMGIDE",538,0) ;"Results: returns modified string "RTN","TMGIDE",539,0) ;"Note: processing limitation is string length=1024 "RTN","TMGIDE",540,0) "RTN","TMGIDE",541,0) set TrimCh=$get(TrimCh," ") "RTN","TMGIDE",542,0) "RTN","TMGIDE",543,0) new result set result=$get(S) "RTN","TMGIDE",544,0) new Ch set Ch="" "RTN","TMGIDE",545,0) new L "RTN","TMGIDE",546,0) "RTN","TMGIDE",547,0) for do quit:(Ch'=TrimCh) "RTN","TMGIDE",548,0) . set L=$length(result) "RTN","TMGIDE",549,0) . set Ch=$extract(result,L,L) "RTN","TMGIDE",550,0) . if Ch=TrimCh do "RTN","TMGIDE",551,0) . . set result=$extract(result,1,L-1) "RTN","TMGIDE",552,0) "RTN","TMGIDE",553,0) quit result "RTN","TMGIDE",554,0) "RTN","TMGIDE",555,0) "RTN","TMGIDE",556,0) Trim(S,TrimCh) "RTN","TMGIDE",557,0) ;"NOTE: Duplicate of function in TMGSTUTL "RTN","TMGIDE",558,0) ;"Purpose: To a trip a string of leading and trailing white space "RTN","TMGIDE",559,0) ;" i.e. convert " hello " into "hello" "RTN","TMGIDE",560,0) ;"Input: S -- the string to convert. Won't be changed if passed by reference "RTN","TMGIDE",561,0) ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " "RTN","TMGIDE",562,0) ;"Results: returns modified string "RTN","TMGIDE",563,0) ;"Note: processing limitation is string length=1024 "RTN","TMGIDE",564,0) "RTN","TMGIDE",565,0) set TrimCh=$get(TrimCh," ") "RTN","TMGIDE",566,0) "RTN","TMGIDE",567,0) new result set result=$get(S) "RTN","TMGIDE",568,0) set result=$$TrimL(.result,TrimCh) "RTN","TMGIDE",569,0) set result=$$TrimR(.result,TrimCh) "RTN","TMGIDE",570,0) "RTN","TMGIDE",571,0) quit result "RTN","TMGIDE",572,0) "RTN","TMGIDE",573,0) "RTN","TMGIDE",574,0) "RTN","TMGIDE",575,0) Substitute(S,Match,NewValue) "RTN","TMGIDE",576,0) ;"NOTE: Duplicate of function in TMGSTUTL "RTN","TMGIDE",577,0) ;"PUBLIC FUNCTION "RTN","TMGIDE",578,0) ;"Purpose: to look for all instances of Match in S, and replace with NewValue "RTN","TMGIDE",579,0) ;"Input: S - string to alter. Altered if passed by reference "RTN","TMGIDE",580,0) ;" Match -- the sequence to look for, i.e. '##' "RTN","TMGIDE",581,0) ;" NewValue -- what to replace Match with, i.e. '$$' "RTN","TMGIDE",582,0) ;"Note: This is different than $translate, as follows "RTN","TMGIDE",583,0) ;" $translate("ABC###DEF","###","*") --> "ABC***DEF" "RTN","TMGIDE",584,0) ;" $$Substitute("ABC###DEF","###","*") --> "ABC*DEF" "RTN","TMGIDE",585,0) ;"Result: returns altered string (if any alterations indicated) "RTN","TMGIDE",586,0) ;"Output: S is altered, if passed by reference. "RTN","TMGIDE",587,0) "RTN","TMGIDE",588,0) new spec "RTN","TMGIDE",589,0) set spec($get(Match))=$get(NewValue) "RTN","TMGIDE",590,0) set S=$$REPLACE(S,.spec) "RTN","TMGIDE",591,0) quit S "RTN","TMGIDE",592,0) "RTN","TMGIDE",593,0) "RTN","TMGIDE",594,0) REPLACE(IN,SPEC) ;"See $$REPLACE in MDC minutes. "RTN","TMGIDE",595,0) ;"Taken from REPLACE^XLFSTR "RTN","TMGIDE",596,0) quit:'$D(IN) "" "RTN","TMGIDE",597,0) quit:$D(SPEC)'>9 IN "RTN","TMGIDE",598,0) N %1,%2,%3,%4,%5,%6,%7,%8 "RTN","TMGIDE",599,0) set %1=$L(IN) "RTN","TMGIDE",600,0) set %7=$J("",%1) "RTN","TMGIDE",601,0) set %3="" "RTN","TMGIDE",602,0) set %6=9999 "RTN","TMGIDE",603,0) for set %3=$order(SPEC(%3)) quit:%3="" set %6(%6)=%3,%6=%6-1 "RTN","TMGIDE",604,0) for %6=0:0 set %6=$O(%6(%6)) quit:%6'>0 set %3=%6(%6) do:$D(SPEC(%3))#2 RE1 "RTN","TMGIDE",605,0) set %8="" "RTN","TMGIDE",606,0) for %2=1:1:%1 do RE3 "RTN","TMGIDE",607,0) quit %8 "RTN","TMGIDE",608,0) RE1 set %4=$L(%3) "RTN","TMGIDE",609,0) set %5=0 for S %5=$F(IN,%3,%5) Q:%5<1 D RE2 "RTN","TMGIDE",610,0) Q "RTN","TMGIDE",611,0) RE2 Q:$E(%7,%5-%4,%5-1)["X" S %8(%5-%4)=SPEC(%3) "RTN","TMGIDE",612,0) F %2=%5-%4:1:%5-1 S %7=$E(%7,1,%2-1)_"X"_$E(%7,%2+1,%1) "RTN","TMGIDE",613,0) Q "RTN","TMGIDE",614,0) RE3 I $E(%7,%2)=" " S %8=%8_$E(IN,%2) Q "RTN","TMGIDE",615,0) S:$D(%8(%2)) %8=%8_%8(%2) "RTN","TMGIDE",616,0) Q "RTN","TMGIDE",617,0) "RTN","TMGIDE",618,0) "RTN","TMGIDE",619,0) KeyPress(wantChar,waitTime) "RTN","TMGIDE",620,0) ;"NOTE: Duplicate of function in TMGUSRIF "RTN","TMGIDE",621,0) ;"Purpose: to check for a keypress "RTN","TMGIDE",622,0) ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value "RTN","TMGIDE",623,0) ;" waitTime -- OPTIONAL, default is 0 (immediate return) "RTN","TMGIDE",624,0) ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1) "RTN","TMGIDE",625,0) ;"Note: this does NOT wait for user to press key "RTN","TMGIDE",626,0) "RTN","TMGIDE",627,0) new zbTemp "RTN","TMGIDE",628,0) set waitTime=$get(waitTime,0) "RTN","TMGIDE",629,0) read *zbTemp:waitTime "RTN","TMGIDE",630,0) if $get(wantChar)=1 set zbTemp=$char(zbTemp) "RTN","TMGIDE",631,0) quit zbTemp "RTN","TMGIDE",632,0) "RTN","TMGIDE",633,0) "RTN","TMGIDE",634,0) "RTN","TMGIDE",635,0) DebugWrite(DBIndent,s,AddNewline) "RTN","TMGIDE",636,0) ;"NOTE: Duplicate of function in TMGDEBUG "RTN","TMGIDE",637,0) ;"PUBLIC FUNCTION "RTN","TMGIDE",638,0) ;"Purpose: to write debug output. Having the proc separate will allow "RTN","TMGIDE",639,0) ;" easier dump to file etc. "RTN","TMGIDE",640,0) ;"Input:DBIndent, the amount of indentation expected for output. "RTN","TMGIDE",641,0) ;" s -- the text to write "RTN","TMGIDE",642,0) ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s "RTN","TMGIDE",643,0) "RTN","TMGIDE",644,0) ;"Relevant DEBUG values "RTN","TMGIDE",645,0) ;" cdbNone - no debug (0) "RTN","TMGIDE",646,0) ;" cdbToScrn - Debug output to screen (1) "RTN","TMGIDE",647,0) ;" cdbToFile - Debug output to file (2) "RTN","TMGIDE",648,0) ;" cdbToTail - Debug output to X tail dialog box. (3) "RTN","TMGIDE",649,0) ;"Note: If above values are not defined, then functionality will be ignored. "RTN","TMGIDE",650,0) "RTN","TMGIDE",651,0) "RTN","TMGIDE",652,0) set cdbNone=$get(cdbNone,0) "RTN","TMGIDE",653,0) set cdbToScrn=$get(cdbToScrn,1) "RTN","TMGIDE",654,0) set cdbToFile=$get(cdbToFile,2) "RTN","TMGIDE",655,0) set cdbToTail=$get(cdbToTail,3) "RTN","TMGIDE",656,0) set TMGDEBUG=$get(TMGDEBUG,cdbNone) "RTN","TMGIDE",657,0) if $get(TMGDEBUG)=cdbNone quit "RTN","TMGIDE",658,0) "RTN","TMGIDE",659,0) if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do "RTN","TMGIDE",660,0) . if $data(DebugFile) use DebugFile "RTN","TMGIDE",661,0) "RTN","TMGIDE",662,0) write s "RTN","TMGIDE",663,0) set cTrue=$get(cTrue,1) "RTN","TMGIDE",664,0) if $get(AddNewline)=cTrue write ! "RTN","TMGIDE",665,0) "RTN","TMGIDE",666,0) if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do "RTN","TMGIDE",667,0) . use $PRINCIPAL "RTN","TMGIDE",668,0) "RTN","TMGIDE",669,0) quit "RTN","TMGIDE",670,0) "RTN","TMGIDE",671,0) "RTN","TMGIDE",672,0) DebugIndent(DBIndentForced) "RTN","TMGIDE",673,0) ;"NOTE: Duplicate of function in TMGDEBUG "RTN","TMGIDE",674,0) ;"PUBLIC FUNCTION "RTN","TMGIDE",675,0) ;"Purpose: to provide a unified indentation for debug messages "RTN","TMGIDE",676,0) ;"Input: DBIndent = number of indentations "RTN","TMGIDE",677,0) ;" Forced = 1 if to indent regardless of DEBUG mode "RTN","TMGIDE",678,0) "RTN","TMGIDE",679,0) set Forced=$get(Forced,0) "RTN","TMGIDE",680,0) "RTN","TMGIDE",681,0) if ($get(TMGDEBUG,0)=0)&(Forced=0) quit "RTN","TMGIDE",682,0) new i "RTN","TMGIDE",683,0) for i=1:1:DBIndent do "RTN","TMGIDE",684,0) . if Forced do DebugWrite(DBIndent," ") "RTN","TMGIDE",685,0) . else do DebugWrite(DBIndent,". ") "RTN","TMGIDE",686,0) quit "RTN","TMGIDE",687,0) "RTN","TMGIDE",688,0) "RTN","TMGIDE",689,0) ArrayDump(ArrayP,TMGIDX,indent) "RTN","TMGIDE",690,0) ;"NOTE: Duplicate of function in TMGDEBUG "RTN","TMGIDE",691,0) ;"PUBLIC FUNCTION "RTN","TMGIDE",692,0) ;"Purpose: to get a custom version of GTM's "zwr" command "RTN","TMGIDE",693,0) ;"Input: Uses global scope var DBIndent (if defined) "RTN","TMGIDE",694,0) ;" ArrayP: NAME of global to display, i.e. "^VA(200)" "RTN","TMGIDE",695,0) ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) "RTN","TMGIDE",696,0) ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces) "RTN","TMGIDE",697,0) ;" OPTIONAL: indent may be an array, with information about columns "RTN","TMGIDE",698,0) ;" to skip. For example: "RTN","TMGIDE",699,0) ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2 "RTN","TMGIDE",700,0) ;"Result: 0=OK to continue, 1=user aborted display "RTN","TMGIDE",701,0) "RTN","TMGIDE",702,0) new result set result=0 "RTN","TMGIDE",703,0) if $$UserAborted^TMGUSRIF set result=1 goto ADDone "RTN","TMGIDE",704,0) new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" "RTN","TMGIDE",705,0) "RTN","TMGIDE",706,0) AD1 if $data(ArrayP)=0 goto ADDone "RTN","TMGIDE",707,0) new abort set abort=0 "RTN","TMGIDE",708,0) if (ArrayP["@") do goto:(abort=1) ADDone "RTN","TMGIDE",709,0) . new zbTemp set zbTemp=$piece($extract(ArrayP,2,99),"@",1) "RTN","TMGIDE",710,0) . if $data(zbTemp)#10=0 set abort=1 "RTN","TMGIDE",711,0) ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes. "RTN","TMGIDE",712,0) new X set X="SET zbTemp=$GET("_ArrayP_")" "RTN","TMGIDE",713,0) set X=$$UP(X) "RTN","TMGIDE",714,0) do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference. "RTN","TMGIDE",715,0) if $get(X)="" goto ADDone "RTN","TMGIDE",716,0) "RTN","TMGIDE",717,0) set DBIndent=$get(DBIndent,0) "RTN","TMGIDE",718,0) set cTrue=$get(cTrue,1) "RTN","TMGIDE",719,0) set cFalse=$get(cFalse,0) "RTN","TMGIDE",720,0) "RTN","TMGIDE",721,0) ;"Force this function to output, even if TMGDEBUG is not defined. "RTN","TMGIDE",722,0) ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working "RTN","TMGIDE",723,0) new TMGDEBUG ;"//kt added 1-16-06 "RTN","TMGIDE",724,0) set TMGDEBUG=1 "RTN","TMGIDE",725,0) "RTN","TMGIDE",726,0) new ChildP,TMGi "RTN","TMGIDE",727,0) "RTN","TMGIDE",728,0) set TMGIDX=$get(TMGIDX,"") "RTN","TMGIDE",729,0) set indent=$get(indent,0) "RTN","TMGIDE",730,0) new SavIndex set SavIndex=TMGIDX "RTN","TMGIDE",731,0) "RTN","TMGIDE",732,0) do DebugIndent(DBIndent) "RTN","TMGIDE",733,0) "RTN","TMGIDE",734,0) if indent>0 do "RTN","TMGIDE",735,0) . for TMGi=1:1:indent-1 do "RTN","TMGIDE",736,0) . . new s set s="" "RTN","TMGIDE",737,0) . . if $get(indent(TMGi),-1)=0 set s=" " "RTN","TMGIDE",738,0) . . else set s="| " "RTN","TMGIDE",739,0) . . do DebugWrite(DBIndent,s) "RTN","TMGIDE",740,0) . do DebugWrite(DBIndent,"}~") "RTN","TMGIDE",741,0) "RTN","TMGIDE",742,0) if TMGIDX'="" do "RTN","TMGIDE",743,0) . if $data(@ArrayP@(TMGIDX))#10=1 do "RTN","TMGIDE",744,0) . . new s set s=@ArrayP@(TMGIDX) "RTN","TMGIDE",745,0) . . if s="" set s="""""" "RTN","TMGIDE",746,0) . . new qt set qt="" "RTN","TMGIDE",747,0) . . if +TMGIDX'=TMGIDX set qt="""" "RTN","TMGIDE",748,0) . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue) "RTN","TMGIDE",749,0) . else do "RTN","TMGIDE",750,0) . . do DebugWrite(DBIndent,TMGIDX,1) "RTN","TMGIDE",751,0) . set ArrayP=$name(@ArrayP@(TMGIDX)) "RTN","TMGIDE",752,0) else do "RTN","TMGIDE",753,0) . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse) "RTN","TMGIDE",754,0) . do DebugWrite(DBIndent,ArrayP,cFalse) "RTN","TMGIDE",755,0) . if $data(@ArrayP)#10=1 do "RTN","TMGIDE",756,0) . . do DebugWrite(0,"="_$get(@ArrayP),cFalse) "RTN","TMGIDE",757,0) . do DebugWrite(0,"",cTrue) "RTN","TMGIDE",758,0) "RTN","TMGIDE",759,0) set TMGIDX=$order(@ArrayP@("")) "RTN","TMGIDE",760,0) if TMGIDX="" goto ADDone "RTN","TMGIDE",761,0) set indent=indent+1 "RTN","TMGIDE",762,0) "RTN","TMGIDE",763,0) for do quit:TMGIDX="" if result=1 goto ADDone "RTN","TMGIDE",764,0) . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX)) "RTN","TMGIDE",765,0) . if tTMGIDX="" set indent(indent)=0 "RTN","TMGIDE",766,0) . new tIndent merge tIndent=indent "RTN","TMGIDE",767,0) . set result=$$ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively "RTN","TMGIDE",768,0) . set TMGIDX=$order(@ArrayP@(TMGIDX)) "RTN","TMGIDE",769,0) "RTN","TMGIDE",770,0) ;"Put in a blank space at end of subbranch "RTN","TMGIDE",771,0) do DebugIndent(DBIndent) "RTN","TMGIDE",772,0) "RTN","TMGIDE",773,0) if indent>0 do "RTN","TMGIDE",774,0) . for TMGi=1:1:indent-1 do "RTN","TMGIDE",775,0) . . new s set s="" "RTN","TMGIDE",776,0) . . if $get(indent(TMGi),-1)=0 set s=" " "RTN","TMGIDE",777,0) . . else set s="| " "RTN","TMGIDE",778,0) . . do DebugWrite(DBIndent,s) "RTN","TMGIDE",779,0) . do DebugWrite(DBIndent," ",1) "RTN","TMGIDE",780,0) "RTN","TMGIDE",781,0) ADDone "RTN","TMGIDE",782,0) quit result "RTN","TMGIDE",783,0) "RTN","TMGIDE",784,0) "RTN","TMGIDE",785,0) ExpandLine(Pos) "RTN","TMGIDE",786,0) ;"NOTE: Duplicate of function in TMGDEBUG "RTN","TMGIDE",787,0) ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality "RTN","TMGIDE",788,0) ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS) "RTN","TMGIDE",789,0) ;"Output: Writes to the currently selecte IO device and expansion of one line of code "RTN","TMGIDE",790,0) ;"Note: This is used for taking the very long lines of code, as found in Fileman, and "RTN","TMGIDE",791,0) ;" convert them to a format with one command on each line. "RTN","TMGIDE",792,0) ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA "RTN","TMGIDE",793,0) ;" conventions--such as commands must be UPPERCASE etc. "RTN","TMGIDE",794,0) "RTN","TMGIDE",795,0) ;"--- copied and modified from XINDX8.m --- "RTN","TMGIDE",796,0) "RTN","TMGIDE",797,0) kill ^UTILITY($J) "RTN","TMGIDE",798,0) "RTN","TMGIDE",799,0) new label,offset,RTN,dmod "RTN","TMGIDE",800,0) do ParsePos(Pos,.label,.offset,.RTN,.dmod) "RTN","TMGIDE",801,0) if label'="" do ;"change position from one relative to label into one relative to top of file "RTN","TMGIDE",802,0) . new CodeArray "RTN","TMGIDE",803,0) . set Pos=$$ConvertPos(Pos,"CodeArray") "RTN","TMGIDE",804,0) . do ParsePos(Pos,.label,.offset,.RTN,.dmod) "RTN","TMGIDE",805,0) "RTN","TMGIDE",806,0) if RTN="" goto ELDone "RTN","TMGIDE",807,0) "RTN","TMGIDE",808,0) do BUILD^XINDX7 "RTN","TMGIDE",809,0) set ^UTILITY($J,RTN)="" "RTN","TMGIDE",810,0) do LOAD^XINDEX "RTN","TMGIDE",811,0) set CCN=0 "RTN","TMGIDE",812,0) for I=1:1:+^UTILITY($J,1,RTN,0,0) set CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2 "RTN","TMGIDE",813,0) set ^UTILITY($J,1,RTN,0)=CCN "RTN","TMGIDE",814,0) ;"do ^XINDX8 -- included below "RTN","TMGIDE",815,0) "RTN","TMGIDE",816,0) new Q,DDOT,LO,PG,LIN,ML,IDT "RTN","TMGIDE",817,0) new tIOSL set tIOSL=IOSL "RTN","TMGIDE",818,0) set IOSL=999999 ;"really long 'page length' prevents header printout (and error) "RTN","TMGIDE",819,0) "RTN","TMGIDE",820,0) set Q="""" "RTN","TMGIDE",821,0) set DDOT=0 "RTN","TMGIDE",822,0) set LO=0 "RTN","TMGIDE",823,0) set PG=+$G(PG) "RTN","TMGIDE",824,0) "RTN","TMGIDE",825,0) set LC=offset "RTN","TMGIDE",826,0) if $D(^UTILITY($J,1,RTN,0,LC)) do "RTN","TMGIDE",827,0) . set LIN=^(LC,0),ML=0,IDT=10 "RTN","TMGIDE",828,0) . set LO=LC-1 "RTN","TMGIDE",829,0) . do CD^XINDX8 "RTN","TMGIDE",830,0) "RTN","TMGIDE",831,0) kill AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY "RTN","TMGIDE",832,0) "RTN","TMGIDE",833,0) set IOSL=tIOSL ;"restore saved IOSL "RTN","TMGIDE",834,0) ELDone "RTN","TMGIDE",835,0) quit "RTN","TMGIDE",836,0) "RTN","TMGIDE",837,0) "RTN","TMGIDE",838,0) "RTN","TMGIDE",839,0) CREF(X) "RTN","TMGIDE",840,0) ;"Taken from CREF^DILF --> ENCREF^DIQGU "RTN","TMGIDE",841,0) ;"Convert an open reference to a closed reference "RTN","TMGIDE",842,0) new L,X1,X2,X3 "RTN","TMGIDE",843,0) set X1=$piece(X,"(") "RTN","TMGIDE",844,0) set X2=$piece(X,"(",2,99) "RTN","TMGIDE",845,0) set L=$length(X2) "RTN","TMGIDE",846,0) set X3=$translate($extract(X2,L),",)") "RTN","TMGIDE",847,0) set X2=$extract(X2,1,(L-1))_X3 "RTN","TMGIDE",848,0) "RTN","TMGIDE",849,0) quit X1_$select(X2]"":"("_X2_")",1:"") "RTN","TMGIDE",850,0) "RTN","TMGIDE",851,0) "RTN","TMGIDE",852,0) LGR() "RTN","TMGIDE",853,0) ;"Taken from LGR^%ZOSV "RTN","TMGIDE",854,0) ;" Last global reference ($REFERENCE) "RTN","TMGIDE",855,0) quit $R "RTN","TMGIDE",856,0) "RTN","TMGIDE",857,0) UP(X) "RTN","TMGIDE",858,0) ;"Taken from UP^XLFSTR "RTN","TMGIDE",859,0) quit $translate(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","TMGIDE",860,0) "RTN","TMGIDE",861,0) "RTN","TMGIDE",862,0) READ() "RTN","TMGIDE",863,0) ;"Purpose: To read user input, with knowledge of arrow keys "RTN","TMGIDE",864,0) ;" This will use VPE keyboard handling if available, otherwise XGF stuff "RTN","TMGIDE",865,0) ;"Result: Will return all user input up to a terminator (RETURN, or a special key) "RTN","TMGIDE",866,0) ;" See code in %ZVEMKRN for possible code returns. format "RTN","TMGIDE",867,0) "RTN","TMGIDE",868,0) ;"9/3/06 -- don't use VPE keyboard anymore "RTN","TMGIDE",869,0) quit $$OLDREAD(,604800) ;"set timeout to 1 week (604800 secs). "RTN","TMGIDE",870,0) "RTN","TMGIDE",871,0) if $text(+0^%ZVEMKRN)="" quit $$OLDREAD() "RTN","TMGIDE",872,0) "RTN","TMGIDE",873,0) new key,FnKey "RTN","TMGIDE",874,0) new done set done=0 "RTN","TMGIDE",875,0) new result set result="" "RTN","TMGIDE",876,0) "RTN","TMGIDE",877,0) for do quit:(done=1) "RTN","TMGIDE",878,0) . ;"READ^%ZVEMKRN(PROMPT,LENGTH,NOECHO) ; "RTN","TMGIDE",879,0) . ;"PROMPT Display prompt. "RTN","TMGIDE",880,0) . ;"LENGTH Maximum # of characters user may enter. "RTN","TMGIDE",881,0) . ;"NOECHO 1=Do not echo what user types. "RTN","TMGIDE",882,0) . set key=$$READ^%ZVEMKRN("",1,0) "RTN","TMGIDE",883,0) . set FnKey=$get(VEE("K")) "RTN","TMGIDE",884,0) . if FnKey="" set done=1,FnKey="" quit "RTN","TMGIDE",885,0) . if (FnKey="")!(FnKey="") do "RTN","TMGIDE",886,0) . . set result=$extract(result,1,$length(result)-1) "RTN","TMGIDE",887,0) . . write $char(8)_" "_$char(8) ;"a backspace char "RTN","TMGIDE",888,0) . . set FnKey="" set key="" "RTN","TMGIDE",889,0) . if FnKey'="" set key=FnKey,done=1 "RTN","TMGIDE",890,0) . if key'="" set result=result_key "RTN","TMGIDE",891,0) "RTN","TMGIDE",892,0) quit result "RTN","TMGIDE",893,0) "RTN","TMGIDE",894,0) "RTN","TMGIDE",895,0) OLDREAD(XGCHARS,XGTO) "RTN","TMGIDE",896,0) ;"Taken from READ^XGF "RTN","TMGIDE",897,0) ;"read the keyboard "RTN","TMGIDE",898,0) ;"XGCHARS:number of chars to read, XGTO:timeout "RTN","TMGIDE",899,0) quit $$READ2($G(XGCHARS),$G(XGTO)) "RTN","TMGIDE",900,0) "RTN","TMGIDE",901,0) READ2(XGCHARS,XGTO) "RTN","TMGIDE",902,0) ;"Taken from READ^XGKB "RTN","TMGIDE",903,0) ;" read XGCHARS using escape processing. XGTO timeout (optional). Result returned. "RTN","TMGIDE",904,0) ;" Char that terminated the read will be in TMGXGRT "RTN","TMGIDE",905,0) N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence "RTN","TMGIDE",906,0) K DTOUT "RTN","TMGIDE",907,0) S TMGXGRT="" "RTN","TMGIDE",908,0) D:$G(XGTO)="" ;set timeout value if one wasn't passed "RTN","TMGIDE",909,0) . I $D(XGT) D Q ;if timers are defined "RTN","TMGIDE",910,0) . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers "RTN","TMGIDE",911,0) . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window "RTN","TMGIDE",912,0) . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name "RTN","TMGIDE",913,0) . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever "RTN","TMGIDE",914,0) . S XGTO=$G(DTIME,600) "RTN","TMGIDE",915,0) ; "RTN","TMGIDE",916,0) I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read "RTN","TMGIDE",917,0) E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible "RTN","TMGIDE",918,0) S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^ "RTN","TMGIDE",919,0) ; "RTN","TMGIDE",920,0) S:$L($ZB) TMGXGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any "RTN","TMGIDE",921,0) I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out "RTN","TMGIDE",922,0) . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER") "RTN","TMGIDE",923,0) E I $L(TMGXGRT),$D(^TMP("XGKEY",$J,TMGXGRT)) X ^(TMGXGRT) ;do some action "RTN","TMGIDE",924,0) ; this really should be handled by keyboard mapping -- later "RTN","TMGIDE",925,0) Q S "RTN","TMGIDE",926,0) "RTN","TMGIDE2") 0^25^B9859 "RTN","TMGIDE2",1,0) TMGIDE2 ;TMG/kst/A debugger/tracer for GT.M (core functionality) ;03/25/06 "RTN","TMGIDE2",2,0) ;;1.0;TMG-LIB;**1**;04/12/05 "RTN","TMGIDE2",3,0) "RTN","TMGIDE2",4,0) ;" GT.M TRAP STEP "RTN","TMGIDE2",5,0) ;" "RTN","TMGIDE2",6,0) ;" K. Toppenberg "RTN","TMGIDE2",7,0) ;" 4-13-2005 "RTN","TMGIDE2",8,0) ;" License: GPL Applies "RTN","TMGIDE2",9,0) ;" "RTN","TMGIDE2",10,0) ;"------------------------------------------------------------ "RTN","TMGIDE2",11,0) ;"------------------------------------------------------------ "RTN","TMGIDE2",12,0) ;" This code module will allow tracing through code. "RTN","TMGIDE2",13,0) ;" It is used as follows: "RTN","TMGIDE2",14,0) ;" "RTN","TMGIDE2",15,0) ;" set $ZSTEP="do STEPTRAP^TMGIDE2($ZPOS) zstep into zcontinue" "RTN","TMGIDE2",16,0) ;" zstep into "RTN","TMGIDE2",17,0) ;" do ^MyFunction ;"<--- put the function you want to trace here "RTN","TMGIDE2",18,0) ;" "RTN","TMGIDE2",19,0) ;" set $ZSTEP="" ;"<---turn off step capture "RTN","TMGIDE2",20,0) ;" quit "RTN","TMGIDE2",21,0) ;" "RTN","TMGIDE2",22,0) ;" "RTN","TMGIDE2",23,0) ;" Dependencies: "RTN","TMGIDE2",24,0) ;" Uses: ^TMGTERM,^TMGIDE "RTN","TMGIDE2",25,0) ;" "RTN","TMGIDE2",26,0) ;"Notes: "RTN","TMGIDE2",27,0) ;" This function will be called inbetween lines of the main "RTN","TMGIDE2",28,0) ;" program that is being traced. Thus this function can't do "RTN","TMGIDE2",29,0) ;" anything that might change the environment of the main "RTN","TMGIDE2",30,0) ;" program. "RTN","TMGIDE2",31,0) ;"------------------------------------------------------------ "RTN","TMGIDE2",32,0) ;"------------------------------------------------------------ "RTN","TMGIDE2",33,0) "RTN","TMGIDE2",34,0) ;"======================================================================= "RTN","TMGIDE2",35,0) ;" API -- Public Functions. "RTN","TMGIDE2",36,0) ;"======================================================================= "RTN","TMGIDE2",37,0) ;"STEPTRAP(idePos,TMGMsg) "RTN","TMGIDE2",38,0) ;"ErrTrap(idePos) "RTN","TMGIDE2",39,0) "RTN","TMGIDE2",40,0) ;"======================================================================= "RTN","TMGIDE2",41,0) ;"PRIVATE API FUNCTIONS "RTN","TMGIDE2",42,0) ;"======================================================================= "RTN","TMGIDE2",43,0) ;"EvalWatches "RTN","TMGIDE2",44,0) ;"BlankLine "RTN","TMGIDE2",45,0) ;"ShowCode(idePos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset) "RTN","TMGIDE2",46,0) ;"GetStackInfo(Stack,OrigIDEPos) "RTN","TMGIDE2",47,0) ;"SetBreakpoint(pos) "RTN","TMGIDE2",48,0) ;"RelBreakpoint(pos) "RTN","TMGIDE2",49,0) "RTN","TMGIDE2",50,0) ;"======================================================================= "RTN","TMGIDE2",51,0) ;"======================================================================= "RTN","TMGIDE2",52,0) "RTN","TMGIDE2",53,0) "RTN","TMGIDE2",54,0) STEPTRAP(idePos,TMGMsg) "RTN","TMGIDE2",55,0) ;"Purpose: This is the line that is called by GT.M for each zstep event. "RTN","TMGIDE2",56,0) ;" It will be used to display the current code execution point, and "RTN","TMGIDE2",57,0) ;" query user as to plans for future execution: run/step/ etc. "RTN","TMGIDE2",58,0) ;"Input: idePos -- a text line containing position, as returned bye $ZPOS "RTN","TMGIDE2",59,0) ;" TMGMsg -- OPTIONAL -- can be used by programs to pass in info. "RTN","TMGIDE2",60,0) ;" If TMGMsg=1, then this function was called without the "RTN","TMGIDE2",61,0) ;" $ZSTEP value set, so this function should set it. "RTN","TMGIDE2",62,0) "RTN","TMGIDE2",63,0) if $ZTRAP'["^TMG" do SetErrTrap^TMGIDE ;"ensure no redirecting of error trap "RTN","TMGIDE2",64,0) new stpResult set stpResult=1 ;"1=step into, 2=step over "RTN","TMGIDE2",65,0) new NakedRef set NakedRef=$$LGR^TMGIDE ;"save naked reference "RTN","TMGIDE2",66,0) new ArrayName set ArrayName="^TMG(""TMGIDE"",$J,""MODULES"")" "RTN","TMGIDE2",67,0) "RTN","TMGIDE2",68,0) new tpBlankLine,tpAction,tpKeyIn,tpRunMode,tpStepMode,tpI,tpDone "RTN","TMGIDE2",69,0) new ViewOffset set ViewOffset=0 "RTN","TMGIDE2",70,0) new relPos "RTN","TMGIDE2",71,0) "RTN","TMGIDE2",72,0) ;"Run modes: 0=running mode "RTN","TMGIDE2",73,0) ;" 1=stepping mode "RTN","TMGIDE2",74,0) ;" 2=Don't show code "RTN","TMGIDE2",75,0) ;" 3=running SLOW mode "RTN","TMGIDE2",76,0) ;" -1=quit "RTN","TMGIDE2",77,0) "RTN","TMGIDE2",78,0) new savedIO,savedX,savedY "RTN","TMGIDE2",79,0) set savedIO=$IO "RTN","TMGIDE2",80,0) set savedX=$X,savedY=$Y "RTN","TMGIDE2",81,0) "RTN","TMGIDE2",82,0) set tpRunMode=$get(TMGRunMode,1) "RTN","TMGIDE2",83,0) set tpStepMode=$get(TMGStepMode,"into") "RTN","TMGIDE2",84,0) "RTN","TMGIDE2",85,0) new ScrHeight,ScrWidth,LROffset "RTN","TMGIDE2",86,0) set ScrHeight=$get(TMGScrHeight,10) "RTN","TMGIDE2",87,0) set ScrWidth=$get(TMGScrWidth,($get(IOM,66)-1)) "RTN","TMGIDE2",88,0) set LROffset=$get(TMGLROffset,0) "RTN","TMGIDE2",89,0) use $P:(WIDTH=ScrWidth:NOWRAP) ;"reset IO to the screen "RTN","TMGIDE2",90,0) "RTN","TMGIDE2",91,0) set tpBlankLine=" " "RTN","TMGIDE2",92,0) for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " "RTN","TMGIDE2",93,0) "RTN","TMGIDE2",94,0) set relPos=idePos "RTN","TMGIDE2",95,0) new OrigIDEPos set OrigIDEPos=idePos "RTN","TMGIDE2",96,0) new tempPos set tempPos=$$ConvertPos^TMGIDE(idePos,ArrayName) "RTN","TMGIDE2",97,0) if tempPos'="" set idePos=tempPos "RTN","TMGIDE2",98,0) "RTN","TMGIDE2",99,0) ;"Note: I will have to try to get this working later. "RTN","TMGIDE2",100,0) ;"I have it such that the condition is recognized. But now I need to "RTN","TMGIDE2",101,0) ;"Differientate between stepping through code, and a breakpoint from "RTN","TMGIDE2",102,0) ;"a full speed run. "RTN","TMGIDE2",103,0) new stpSkip set stpSkip=0 "RTN","TMGIDE2",104,0) if $$IsBreakpoint(idePos) do ;"goto:(stpSkip=1) SP2Done "RTN","TMGIDE2",105,0) . new ifS set ifS=$$GetBrkCond(idePos) if ifS="" quit "RTN","TMGIDE2",106,0) . new $etrap set $etrap="write ""ERROR in breakpoint condition code."",! quit" "RTN","TMGIDE2",107,0) . if (@ifS=0) set stpSkip=1 "RTN","TMGIDE2",108,0) . if @ifS write "Condition FOUND!!" ;"do PressToCont^TMGUSRIF "RTN","TMGIDE2",109,0) "RTN","TMGIDE2",110,0) ;"don't show hidden modules "RTN","TMGIDE2",111,0) if $$ShouldSkip($piece(idePos,"^",2)) goto SP2Done "RTN","TMGIDE2",112,0) "RTN","TMGIDE2",113,0) do VCUSAV2^TMGTERM "RTN","TMGIDE2",114,0) "RTN","TMGIDE2",115,0) new CsrOnBreakline set CsrOnBreakline=0 "RTN","TMGIDE2",116,0) if tpRunMode'=2 do ;"2=Don't show code "RTN","TMGIDE2",117,0) . do ShowCode(idePos,ScrWidth,ScrHeight,LROffset,.CsrOnBreakline) "RTN","TMGIDE2",118,0) . write CsrOnBreakline,! ;"temps "RTN","TMGIDE2",119,0) else do "RTN","TMGIDE2",120,0) . do CUP^TMGTERM(1,2) "RTN","TMGIDE2",121,0) write tpBlankLine,! "RTN","TMGIDE2",122,0) write tpBlankLine,! "RTN","TMGIDE2",123,0) do CUU^TMGTERM(2) "RTN","TMGIDE2",124,0) "RTN","TMGIDE2",125,0) if (tpRunMode=0)!(tpRunMode=2)!(tpRunMode=3) do ;"i.e. not stepping mode "RTN","TMGIDE2",126,0) . write tpBlankLine,! "RTN","TMGIDE2",127,0) . do CUU^TMGTERM(1) "RTN","TMGIDE2",128,0) . do EvalWatches "RTN","TMGIDE2",129,0) . write "(Press any key to pause)",! "RTN","TMGIDE2",130,0) . read *tpKeyIn:0 "RTN","TMGIDE2",131,0) . if (tpKeyIn>0) set tpRunMode=1 "RTN","TMGIDE2",132,0) . else if tpRunMode=3 hang 0.25 "RTN","TMGIDE2",133,0) "RTN","TMGIDE2",134,0) if tpRunMode=2 goto SPDone ;"Don't-show mode --> goto SPDone "RTN","TMGIDE2",135,0) do CmdPrompt ;"display prompt and interact with user "RTN","TMGIDE2",136,0) "RTN","TMGIDE2",137,0) SPDone "RTN","TMGIDE2",138,0) do VCULOAD2^TMGTERM "RTN","TMGIDE2",139,0) SP2Done "RTN","TMGIDE2",140,0) ;"Finish up and return to GTM execution "RTN","TMGIDE2",141,0) set TMGRunMode=tpRunMode "RTN","TMGIDE2",142,0) if tpStepMode="into" set stpResult=1 "RTN","TMGIDE2",143,0) else set stpResult=2 "RTN","TMGIDE2",144,0) set TMGStepMode=tpStepMode "RTN","TMGIDE2",145,0) "RTN","TMGIDE2",146,0) if $data(savedIO) use savedIO ;"turn IO back to what it was when coming into this function. "RTN","TMGIDE2",147,0) set $X=+$get(savedX),$Y=+$get(savedY) "RTN","TMGIDE2",148,0) "RTN","TMGIDE2",149,0) if $get(TMGMsg)=1 do ;"call was without $ZSTEP set, so we should set it. "RTN","TMGIDE2",150,0) . set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" "RTN","TMGIDE2",151,0) . zstep:(stpResult=1) into zstep:(stpResult=2) over "RTN","TMGIDE2",152,0) "RTN","TMGIDE2",153,0) if NakedRef'["""""" do ;"If holds "" index, skip over "RTN","TMGIDE2",154,0) . new discard set discard=$get(@NakedRef) ;"reset naked reference. "RTN","TMGIDE2",155,0) "RTN","TMGIDE2",156,0) quit stpResult "RTN","TMGIDE2",157,0) "RTN","TMGIDE2",158,0) ;"============================================================================ "RTN","TMGIDE2",159,0) "RTN","TMGIDE2",160,0) CmdPrompt "RTN","TMGIDE2",161,0) ;"Purpose: Display the command prompt, and handle user input "RTN","TMGIDE2",162,0) ;"Note: uses some variables with global scope, because this code block "RTN","TMGIDE2",163,0) ;" was simply cut out of main routine above. "RTN","TMGIDE2",164,0) "RTN","TMGIDE2",165,0) new tpDone "RTN","TMGIDE2",166,0) "RTN","TMGIDE2",167,0) new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" "RTN","TMGIDE2",168,0) set tpDone=0 "RTN","TMGIDE2",169,0) if tpRunMode=1 for do quit:tpDone=1 "RTN","TMGIDE2",170,0) . new DefAction set DefAction="O" "RTN","TMGIDE2",171,0) . do ShowCode(idePos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) "RTN","TMGIDE2",172,0) . new tempi for tempi=1:1:2 do ;"create empty space below display. "RTN","TMGIDE2",173,0) . . write tpBlankLine,! "RTN","TMGIDE2",174,0) . do CUU^TMGTERM(2) "RTN","TMGIDE2",175,0) . if CsrOnBreakline=1 do "RTN","TMGIDE2",176,0) . . new ifS set ifS=$$GetBrkCond($$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName)) "RTN","TMGIDE2",177,0) . . if ifS'="" write "Breakpoint test: [",ifS,"]",! "RTN","TMGIDE2",178,0) . write "}" "RTN","TMGIDE2",179,0) . do EvalWatches "RTN","TMGIDE2",180,0) . set $X=1 "RTN","TMGIDE2",181,0) . write "Action (? for help): " "RTN","TMGIDE2",182,0) . if tpStepMode="into" write "step INTO// " set DefAction="I" "RTN","TMGIDE2",183,0) . else write "step OVER// " set DefAction="O" "RTN","TMGIDE2",184,0) . new loop "RTN","TMGIDE2",185,0) . new tempX set tempX=$X "RTN","TMGIDE2",186,0) . for loop=1:1:20 write " " "RTN","TMGIDE2",187,0) . for loop=1:1:20 write $char(8) ;"backspace "RTN","TMGIDE2",188,0) . set $X=tempX "RTN","TMGIDE2",189,0) . set tpAction=$$READ^TMGIDE() write ! "RTN","TMGIDE2",190,0) . if tpAction="" set tpAction=DefAction "RTN","TMGIDE2",191,0) . set TMGXGRT=$get(TMGXGRT) "RTN","TMGIDE2",192,0) . if TMGXGRT="UP" set tpAction="A" "RTN","TMGIDE2",193,0) . if TMGXGRT="PREV" set tpAction="AA" "RTN","TMGIDE2",194,0) . if TMGXGRT="DOWN" set tpAction="Z" "RTN","TMGIDE2",195,0) . if TMGXGRT="NEXT" set tpAction="ZZ" "RTN","TMGIDE2",196,0) . if TMGXGRT="RIGHT" set tpAction="]" "RTN","TMGIDE2",197,0) . if TMGXGRT="LEFT" set tpAction="[" "RTN","TMGIDE2",198,0) . new origAction set origAction=tpAction "RTN","TMGIDE2",199,0) . set tpAction=$$UP^TMGIDE(tpAction) "RTN","TMGIDE2",200,0) . if tpAction="R" do quit "RTN","TMGIDE2",201,0) . . set tpRunMode=0 "RTN","TMGIDE2",202,0) . . set tpDone=1 "RTN","TMGIDE2",203,0) . if tpAction="L" do quit "RTN","TMGIDE2",204,0) . . set tpRunMode=3 "RTN","TMGIDE2",205,0) . . set tpDone=1 "RTN","TMGIDE2",206,0) . if $extract(tpAction,1)="M" do quit "RTN","TMGIDE2",207,0) . . ;"new zbTemp "RTN","TMGIDE2",208,0) . . do CUU^TMGTERM(1) "RTN","TMGIDE2",209,0) . . do CHA^TMGTERM(1) ;"move to x=1 on this line "RTN","TMGIDE2",210,0) . . write tpBlankLine,! "RTN","TMGIDE2",211,0) . . do CUU^TMGTERM(1) "RTN","TMGIDE2",212,0) . . set tpLine=$$Trim^TMGIDE($piece(origAction," ",2,999)) "RTN","TMGIDE2",213,0) . . if tpLine="" read " enter M code (^ to cancel): ",tpLine,! "RTN","TMGIDE2",214,0) . . if (tpLine'="^") do "RTN","TMGIDE2",215,0) . . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" "RTN","TMGIDE2",216,0) . . . write ! ;"get below bottom line for output. "RTN","TMGIDE2",217,0) . . . xecute tpLine "RTN","TMGIDE2",218,0) . if tpAction="I" do quit "RTN","TMGIDE2",219,0) . . set tpStepMode="into" "RTN","TMGIDE2",220,0) . . ;"set $ZSTEP="do STEPTRAP^TMGIDE2($ZPOS) zstep into zcontinue" "RTN","TMGIDE2",221,0) . . set tpDone=1 "RTN","TMGIDE2",222,0) . if tpAction="O" do quit "RTN","TMGIDE2",223,0) . . set tpStepMode="over" "RTN","TMGIDE2",224,0) . . ;"set $ZSTEP="do STEPTRAP^TMGIDE2($ZPOS) zstep over zcontinue" "RTN","TMGIDE2",225,0) . . set tpDone=1 "RTN","TMGIDE2",226,0) . if tpAction="X" do quit ;"Turn off debugger "RTN","TMGIDE2",227,0) . . set $ZSTEP="" "RTN","TMGIDE2",228,0) . . set TMGMsg=0 "RTN","TMGIDE2",229,0) . . set tpDone=1 "RTN","TMGIDE2",230,0) . if tpAction="C" do quit "RTN","TMGIDE2",231,0) . . new brkPos "RTN","TMGIDE2",232,0) . . read !,"Enter breakpoint (e.g. Label+8^MyFunct): ",brkPos,! "RTN","TMGIDE2",233,0) . . do SetBreakpoint(brkPos) "RTN","TMGIDE2",234,0) . if tpAction="BC" do quit ;"enter a breakpoint condition (IF code) "RTN","TMGIDE2",235,0) . . write "Enter an IF condition. Examples: 'A=1' or '$$FN1^MOD(A)=2'",! "RTN","TMGIDE2",236,0) . . read "Enter IF condition (^ to cancel, @ to delete): ",tpLine,! "RTN","TMGIDE2",237,0) . . if (tpLine="^") quit "RTN","TMGIDE2",238,0) . . new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName) "RTN","TMGIDE2",239,0) . . do SetBrkCond(brkPos,tpLine) "RTN","TMGIDE2",240,0) . if tpAction="B" do quit ;"Toggle a breakpoint at current location "RTN","TMGIDE2",241,0) . . ;"write !,"Trying to determine correct breakpoint. relPos=",relPos," ViewOffset=",ViewOffset,! "RTN","TMGIDE2",242,0) . . new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName) "RTN","TMGIDE2",243,0) . . ;"write "brkPos=",brkPos,! "RTN","TMGIDE2",244,0) . . if brkPos="" write "relPos=",relPos," view offset=",ViewOffset," ArrayName=",ArrayName,! "RTN","TMGIDE2",245,0) . . do ToggleBreakpoint(brkPos) "RTN","TMGIDE2",246,0) . if tpAction="E" do quit "RTN","TMGIDE2",247,0) . . new expPos,zbLabel,zbOffset,zbRoutine "RTN","TMGIDE2",248,0) . . do ParsePos^TMGIDE(idePos,.zbLabel,.zbOffset,.zbRoutine) "RTN","TMGIDE2",249,0) . . set expPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine "RTN","TMGIDE2",250,0) . . write ! "RTN","TMGIDE2",251,0) . . do ExpandLine^TMGIDE(expPos) "RTN","TMGIDE2",252,0) . . new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600) "RTN","TMGIDE2",253,0) . if tpAction="H" do quit "RTN","TMGIDE2",254,0) . . set tpRunMode=2 "RTN","TMGIDE2",255,0) . . set tpDone=1 "RTN","TMGIDE2",256,0) . if $extract(tpAction,1)="W" do quit "RTN","TMGIDE2",257,0) . . ;"new zbTemp "RTN","TMGIDE2",258,0) . . do CUU^TMGTERM(1) "RTN","TMGIDE2",259,0) . . do CHA^TMGTERM(1) ;"move to x=1 on this line "RTN","TMGIDE2",260,0) . . write tpBlankLine,! "RTN","TMGIDE2",261,0) . . do CUU^TMGTERM(1) "RTN","TMGIDE2",262,0) . . if tpAction["+" do "RTN","TMGIDE2",263,0) . . . new watchVar set watchVar=$$Trim^TMGIDE($piece(origAction,"+",2)) "RTN","TMGIDE2",264,0) . . . if watchVar="^" set watchVar="NakedRef" "RTN","TMGIDE2",265,0) . . . set tpWatchLine=$get(tpWatchLine)_" write """_watchVar_" =["",$get("_watchVar_"),""], """ "RTN","TMGIDE2",266,0) . . else do "RTN","TMGIDE2",267,0) . . . new tempCode "RTN","TMGIDE2",268,0) . . . read "Enter M code (^ to cancel): ",tempCode,! "RTN","TMGIDE2",269,0) . . . if tempCode'="^" set tpWatchLine=tempCode "RTN","TMGIDE2",270,0) . if (tpAction="A")!(tpAction="AA")!(tpAction="") do quit "RTN","TMGIDE2",271,0) . . set ViewOffset=ViewOffset-1 "RTN","TMGIDE2",272,0) . . if tpAction="AA" set ViewOffset=ViewOffset-ScrHeight+2; "RTN","TMGIDE2",273,0) . if (tpAction="") do quit "RTN","TMGIDE2",274,0) . . set ViewOffset=ViewOffset-1 "RTN","TMGIDE2",275,0) . . set ViewOffset=ViewOffset-ScrHeight+2; "RTN","TMGIDE2",276,0) . if (tpAction="") do quit "RTN","TMGIDE2",277,0) . . set ViewOffset=ViewOffset+1 "RTN","TMGIDE2",278,0) . . set ViewOffset=ViewOffset+ScrHeight-2; "RTN","TMGIDE2",279,0) . if (tpAction="Z")!(tpAction="ZZ")!(tpAction="") do quit "RTN","TMGIDE2",280,0) . . set ViewOffset=ViewOffset+1 "RTN","TMGIDE2",281,0) . . if tpAction="ZZ" set ViewOffset=ViewOffset+ScrHeight-2; "RTN","TMGIDE2",282,0) . if (tpAction="Q")!(tpAction="^") do quit "RTN","TMGIDE2",283,0) . . kill @ArrayName ;"kt added 7-18-06 "RTN","TMGIDE2",284,0) . . set $etrap="" ;"remove error trap "RTN","TMGIDE2",285,0) . . write !!!!!!!!!!! "RTN","TMGIDE2",286,0) . . write "CREATING AN ARTIFICIAL ERROR TO STOP EXECUTION.",! "RTN","TMGIDE2",287,0) . . write "--->Enter 'ZGOTO' from the GTM> prompt to clear error.",!! "RTN","TMGIDE2",288,0) . . set $ZSTEP="" ;"turn off step capture "RTN","TMGIDE2",289,0) . . xecute "write CrashNonVariable" "RTN","TMGIDE2",290,0) . if tpAction="+" do quit "RTN","TMGIDE2",291,0) . . set TMGScrWidth=$get(TMGScrWidth)+1 "RTN","TMGIDE2",292,0) . if tpAction="=" do quit "RTN","TMGIDE2",293,0) . . new tempWidth "RTN","TMGIDE2",294,0) . . read "Enter screen width: ",tempWidth,! "RTN","TMGIDE2",295,0) . . if (+tempWidth>10) set TMGScrWidth=tempWidth,ScrWidth=tempWidth "RTN","TMGIDE2",296,0) . . set tpBlankLine=" " "RTN","TMGIDE2",297,0) . . for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " "RTN","TMGIDE2",298,0) . . write # ;"clear screen "RTN","TMGIDE2",299,0) . . do ShowCode(idePos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) ;"<---- not working! "RTN","TMGIDE2",300,0) . if tpAction="-" do quit "RTN","TMGIDE2",301,0) . . set TMGScrWidth=$get(TMGScrWidth)-1 "RTN","TMGIDE2",302,0) . . if TMGScrWidth<10 set TMGScrWidth=10 "RTN","TMGIDE2",303,0) . if (tpAction="[")!(tpAction="") do quit "RTN","TMGIDE2",304,0) . . if LROffset>1 set LROffset=LROffset-1 "RTN","TMGIDE2",305,0) . if (tpAction="[[")!(tpAction="") do quit "RTN","TMGIDE2",306,0) . . set LROffset=0 "RTN","TMGIDE2",307,0) . if tpAction="]"!(tpAction="") do quit "RTN","TMGIDE2",308,0) . . if LROffset=0 set LROffset=1 "RTN","TMGIDE2",309,0) . . set LROffset=LROffset+1 "RTN","TMGIDE2",310,0) . if (tpAction="]]")!(tpAction="") do quit "RTN","TMGIDE2",311,0) . . if LROffset=0 set LROffset=1 "RTN","TMGIDE2",312,0) . . set LROffset=LROffset+20 "RTN","TMGIDE2",313,0) . if tpAction="CLS" do quit "RTN","TMGIDE2",314,0) . . write # "RTN","TMGIDE2",315,0) . if tpAction="TABLE" do quit "RTN","TMGIDE2",316,0) . . write ! ;"get below bottom line for output. "RTN","TMGIDE2",317,0) . . zshow "*" "RTN","TMGIDE2",318,0) . . new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600) "RTN","TMGIDE2",319,0) . if tpAction["SHOW" do quit "RTN","TMGIDE2",320,0) . . new varName set varName=$$Trim^TMGSTUTL($extract(origAction,5,999)) "RTN","TMGIDE2",321,0) . . write ! ;"get below bottom line for output. "RTN","TMGIDE2",322,0) . . if varName["$" do "RTN","TMGIDE2",323,0) . . . new tempCode "RTN","TMGIDE2",324,0) . . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" "RTN","TMGIDE2",325,0) . . . write varName,"='" "RTN","TMGIDE2",326,0) . . . ;"set tempCode="write "_varName "RTN","TMGIDE2",327,0) . . . set tempCode="do DebugWrite(1,"_varName_")" "RTN","TMGIDE2",328,0) . . . xecute tempCode "RTN","TMGIDE2",329,0) . . . write "' " "RTN","TMGIDE2",330,0) . . else do "RTN","TMGIDE2",331,0) . . . if $get(varName)'="" do "RTN","TMGIDE2",332,0) . . . . set varName=$$CREF^TMGIDE(varName) ;"convert open to closed format "RTN","TMGIDE2",333,0) . . . . new zbTemp set zbTemp=$$ArrayDump^TMGIDE(varName) "RTN","TMGIDE2",334,0) . . . . if zbTemp=0 do PressToCont^TMGUSRIF "RTN","TMGIDE2",335,0) . . . else do "RTN","TMGIDE2",336,0) . . . . ;"write varName,"='",$get(@varName),"' " "RTN","TMGIDE2",337,0) . if tpAction["BROWSE" do quit "RTN","TMGIDE2",338,0) . . new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999)) "RTN","TMGIDE2",339,0) . . write ! ;"get below bottom line for output. "RTN","TMGIDE2",340,0) . . do BROWSENODES^TMGIDE(varName) "RTN","TMGIDE2",341,0) . if tpAction["NODES" do quit "RTN","TMGIDE2",342,0) . . new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999)) "RTN","TMGIDE2",343,0) . . write ! ;"get below bottom line for output. "RTN","TMGIDE2",344,0) . . do BROWSEASK^TMGMISC "RTN","TMGIDE2",345,0) . if tpAction["STACK" do quit "RTN","TMGIDE2",346,0) . . write ! ;"get below bottom line for output. "RTN","TMGIDE2",347,0) . . new Stack do GetStackInfo(.Stack,OrigIDEPos) "RTN","TMGIDE2",348,0) . . new Menu set Menu(0)="Pick Stack Entry to BROWSE TO" "RTN","TMGIDE2",349,0) . . new TMGi for TMGi=1:1 quit:($get(Stack(TMGi))="") do "RTN","TMGIDE2",350,0) . . . ;"write " ",TMGi,". ",Stack(TMGi)," ",! "RTN","TMGIDE2",351,0) . . . new $etrap set $etrap="set $etrap="""",$ecode=""""" "RTN","TMGIDE2",352,0) . . . new addr set addr=$piece($$TRIM^XLFSTR(Stack(TMGi))," ",2) "RTN","TMGIDE2",353,0) . . . new txt set txt=$$TRIM^XLFSTR($text(@addr)) "RTN","TMGIDE2",354,0) . . . set txt=$$TRIM^XLFSTR(txt,$char(9)) "RTN","TMGIDE2",355,0) . . . new line set line=addr_"-->"_txt "RTN","TMGIDE2",356,0) . . . if $length(line)>TMGScrWidth do "RTN","TMGIDE2",357,0) . . . . set line=$extract(line,1,TMGScrWidth-4)_"..." "RTN","TMGIDE2",358,0) . . . set Menu(TMGi)=line_$char(9)_addr "RTN","TMGIDE2",359,0) . . new UsrSlct set UsrSlct=$$Menu^TMGUSRIF(.Menu) "RTN","TMGIDE2",360,0) . . write "Unfinished code... Later browse to: [",UsrSlct,"]",! "RTN","TMGIDE2",361,0) . if tpAction["RESYNC" do quit "RTN","TMGIDE2",362,0) . . kill @ArrayName "RTN","TMGIDE2",363,0) . if tpAction["HIDE" do quit "RTN","TMGIDE2",364,0) . . do SetupSkips "RTN","TMGIDE2",365,0) . else do quit "RTN","TMGIDE2",366,0) . . write ! "RTN","TMGIDE2",367,0) . . new tpNLines "RTN","TMGIDE2",368,0) . . for tpNLines=1:1:5 write tpBlankLine,! "RTN","TMGIDE2",369,0) . . do CUU^TMGTERM(5) "RTN","TMGIDE2",370,0) . . write " L -- run sLow mode M -- exec M code SHOW [var] -- show [var]",! "RTN","TMGIDE2",371,0) . . write " O -- step OVER line I -- step INTO line STACK -- stack show/jump",! "RTN","TMGIDE2",372,0) . . write " R -- run H -- Hide debug code CLS -- clear screen",! "RTN","TMGIDE2",373,0) . . write " B -- Toggle Breakpoint C -- custom breakpoint BC -- breakpoint code",! "RTN","TMGIDE2",374,0) . . write " W - enter watch code W +MyVar --watch MyVar W +^ -- Add Naked Ref",! "RTN","TMGIDE2",375,0) . . write " A,AA -- scroll up Z,ZZ -- scroll down BROWSE [var] -- browse [var]",! "RTN","TMGIDE2",376,0) . . write " [,[[ -- scroll left ],]] -- scroll right E -- expand current line",! "RTN","TMGIDE2",377,0) . . write " X -- turn off debugger Q -- Abort RESYNC -- sync display",! "RTN","TMGIDE2",378,0) . . write " - or + -- screen width = -- enter width HIDE -- manage/hide modules",! "RTN","TMGIDE2",379,0) . . write " TABLE -- show sym table NODES -- Ask & browse (global) var",! "RTN","TMGIDE2",380,0) "RTN","TMGIDE2",381,0) quit "RTN","TMGIDE2",382,0) "RTN","TMGIDE2",383,0) "RTN","TMGIDE2",384,0) EvalWatches "RTN","TMGIDE2",385,0) if $get(tpWatchLine)'="" do "RTN","TMGIDE2",386,0) . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGIDE2",387,0) . xecute tpWatchLine "RTN","TMGIDE2",388,0) . write ! "RTN","TMGIDE2",389,0) else write ! "RTN","TMGIDE2",390,0) "RTN","TMGIDE2",391,0) "RTN","TMGIDE2",392,0) BlankLine "RTN","TMGIDE2",393,0) write tpBlankLine "RTN","TMGIDE2",394,0) do CHA^TMGTERM(1) ;"move to x=1 on this line "RTN","TMGIDE2",395,0) quit "RTN","TMGIDE2",396,0) "RTN","TMGIDE2",397,0) "RTN","TMGIDE2",398,0) ErrTrap(idePos) "RTN","TMGIDE2",399,0) ;"Purpose: This is the line that is called by GT.M for each ztrap event. "RTN","TMGIDE2",400,0) ;" It will be used to display the current code execution point "RTN","TMGIDE2",401,0) "RTN","TMGIDE2",402,0) new ScrHeight,ScrWidth "RTN","TMGIDE2",403,0) set ScrHeight=$get(TMGScrHeight,10) "RTN","TMGIDE2",404,0) set ScrWidth=$get(TMGScrWidth,70) "RTN","TMGIDE2",405,0) "RTN","TMGIDE2",406,0) do VCUSAV2^TMGTERM "RTN","TMGIDE2",407,0) do ShowCode(idePos,ScrWidth,ScrHeight,0) "RTN","TMGIDE2",408,0) "RTN","TMGIDE2",409,0) ETDone "RTN","TMGIDE2",410,0) do VCULOAD2^TMGTERM "RTN","TMGIDE2",411,0) quit "RTN","TMGIDE2",412,0) "RTN","TMGIDE2",413,0) "RTN","TMGIDE2",414,0) "RTN","TMGIDE2",415,0) "RTN","TMGIDE2",416,0) ShowCode(idePos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset,CsrOnBreakline) "RTN","TMGIDE2",417,0) ;"Purpose: This will display code at the top of the screen "RTN","TMGIDE2",418,0) ;"Input: idePos -- string like this: X+2^ROUTINE[$DMOD] "RTN","TMGIDE2",419,0) ;" ScrWidth -- width of code display (Num of columns) "RTN","TMGIDE2",420,0) ;" ScrHeight -- height of code display (number of rows) "RTN","TMGIDE2",421,0) ;" Wipe -- OPTIONAL. if 1, then code area is wiped blank "RTN","TMGIDE2",422,0) ;" ViewOffset -- OPTIONAL. If a value is supplied, then "RTN","TMGIDE2",423,0) ;" the display will be shifted up or down (i.e. to view "RTN","TMGIDE2",424,0) ;" code other than at the point of execution) "RTN","TMGIDE2",425,0) ;" Positive numbers will scroll page downward. "RTN","TMGIDE2",426,0) ;" LROffset -- OPTIONAL. if value > 0 then the display "RTN","TMGIDE2",427,0) ;" of each line will begin with this number character. "RTN","TMGIDE2",428,0) ;" (i.e. will shift screen so that long lines can be seen.) "RTN","TMGIDE2",429,0) ;" 0->no offset; 1->no offset (start at character 1); 2->offset 1 "RTN","TMGIDE2",430,0) ;" CsrOnBreakline -- OPTIONAL. PASS BY REFERENCE. Will return 1 "RTN","TMGIDE2",431,0) ;" if cursor is on a break line, otherwise 0 "RTN","TMGIDE2",432,0) "RTN","TMGIDE2",433,0) new cdLoop "RTN","TMGIDE2",434,0) new scRoutine,scLabel,scOffset,scS "RTN","TMGIDE2",435,0) new LastRou,LastLabel,LastOffset "RTN","TMGIDE2",436,0) new dbFGColor,bBGColor,nlFGColor,nlBGColor "RTN","TMGIDE2",437,0) new BlankLine "RTN","TMGIDE2",438,0) new StartOffset "RTN","TMGIDE2",439,0) new scCursorLine "RTN","TMGIDE2",440,0) new zBreakIdx set zBreakIdx=-1 "RTN","TMGIDE2",441,0) new ArrayName set ArrayName="^TMG(""TMGIDE"",$J,""MODULES"")" "RTN","TMGIDE2",442,0) "RTN","TMGIDE2",443,0) set ScrWidth=$get(ScrWidth,80) "RTN","TMGIDE2",444,0) set ScrHeight=$get(ScrHeight,10) "RTN","TMGIDE2",445,0) set LROffset=+$get(LROffset,1) "RTN","TMGIDE2",446,0) "RTN","TMGIDE2",447,0) set BlankLine=" " "RTN","TMGIDE2",448,0) for cdLoop=1:1:ScrWidth-1 set BlankLine=BlankLine_" " "RTN","TMGIDE2",449,0) "RTN","TMGIDE2",450,0) do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background "RTN","TMGIDE2",451,0) do CUP^TMGTERM(1,1) ;"Cursor to line (1,1) "RTN","TMGIDE2",452,0) "RTN","TMGIDE2",453,0) if $get(Wipe)=1 do goto SCDone "RTN","TMGIDE2",454,0) . do VTATRIB^TMGTERM(0) ;"reset colors "RTN","TMGIDE2",455,0) . for cdLoop=0:1:ScrHeight+1 write BlankLine "RTN","TMGIDE2",456,0) "RTN","TMGIDE2",457,0) set scS=$piece(idePos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE "RTN","TMGIDE2",458,0) do ParsePos^TMGIDE(scS,.scLabel,.scOffset,.scRoutine) "RTN","TMGIDE2",459,0) if scRoutine="" do goto SCDone "RTN","TMGIDE2",460,0) . write !,!,"Error -- invalid position provided to ShowCode routine: ",idePos,! "RTN","TMGIDE2",461,0) . write "scS=",scS,! "RTN","TMGIDE2",462,0) "RTN","TMGIDE2",463,0) set scS="=== Routine: "_scLabel_"^"_scRoutine_" " "RTN","TMGIDE2",464,0) if $data(OrigIDEPos) set scS=scS_"("_OrigIDEPos_") " "RTN","TMGIDE2",465,0) else set scS=scS_"("_idePos_") " "RTN","TMGIDE2",466,0) write scS "RTN","TMGIDE2",467,0) for cdLoop=1:1:ScrWidth-$length(scS) write "=" "RTN","TMGIDE2",468,0) write ! "RTN","TMGIDE2",469,0) "RTN","TMGIDE2",470,0) do VCOLORS^TMGTERM(14,4) ;"bright white on blue background "RTN","TMGIDE2",471,0) "RTN","TMGIDE2",472,0) do ;"setup to show a symbol for breakpoint "RTN","TMGIDE2",473,0) . new zbS set zbS="" "RTN","TMGIDE2",474,0) . for set zbS=$order(^TMG("TMGIDE",$J,"ZBREAK",zbS)) quit:(zbS="") do "RTN","TMGIDE2",475,0) . . new zbRoutine,zbLabel,zbOffset "RTN","TMGIDE2",476,0) . . ;"write "found bk point:",zbS,! "RTN","TMGIDE2",477,0) . . new tempPos set tempPos=$$ConvertPos^TMGIDE(zbS,ArrayName) "RTN","TMGIDE2",478,0) . . ;"write "converted pos=",tempPos,! "RTN","TMGIDE2",479,0) . . do ParsePos^TMGIDE(tempPos,.zbLabel,.zbOffset,.zbRoutine) "RTN","TMGIDE2",480,0) . . ;"do ParsePos^TMGIDE(zbS,.zbLabel,.zbOffset,.zbRoutine) "RTN","TMGIDE2",481,0) . . ;"write "calculated offset=",zbOffset,! "RTN","TMGIDE2",482,0) . . ;"write "label=",zbLabel,! "RTN","TMGIDE2",483,0) . . ;"write "routine=",zbRoutine,! "RTN","TMGIDE2",484,0) . . if zbRoutine'=scRoutine quit "RTN","TMGIDE2",485,0) . . if zbLabel'=scLabel quit "RTN","TMGIDE2",486,0) . . set zBreakIdx(zbOffset)=1 "RTN","TMGIDE2",487,0) "RTN","TMGIDE2",488,0) if scOffset>(ScrHeight) do "RTN","TMGIDE2",489,0) set StartOffset=(scOffset-ScrHeight)+2 "RTN","TMGIDE2",490,0) else set StartOffset=0 "RTN","TMGIDE2",491,0) set StartOffset=StartOffset+$get(ViewOffset) "RTN","TMGIDE2",492,0) "RTN","TMGIDE2",493,0) set CsrOnBreakline=0 "RTN","TMGIDE2",494,0) for cdLoop=StartOffset:1:(ScrHeight+StartOffset) do "RTN","TMGIDE2",495,0) . new cbLine,cbRef,cbCursor,cBrkLine "RTN","TMGIDE2",496,0) . set cBrkLine=$data(zBreakIdx(cdLoop)) "RTN","TMGIDE2",497,0) . new cHighCsrPos set cHighCsrPos=0 "RTN","TMGIDE2",498,0) . new cHighExecPos set cHighExecPos=0 "RTN","TMGIDE2",499,0) . set cbRef=scLabel_"+"_cdLoop_"^"_scRoutine "RTN","TMGIDE2",500,0) . set cbLine=$text(@cbRef) "RTN","TMGIDE2",501,0) . set cbLine=$$Substitute^TMGIDE(cbLine,$Char(9)," ") "RTN","TMGIDE2",502,0) . if LROffset>0 set cbLine=$extract(cbLine,LROffset,999) "RTN","TMGIDE2",503,0) . set scCursorLine=scOffset+$get(ViewOffset) "RTN","TMGIDE2",504,0) . set cHighCsrPos=(cdLoop=scCursorLine) "RTN","TMGIDE2",505,0) . set cHighExecPos=(cdLoop=scOffset) "RTN","TMGIDE2",506,0) . if cHighCsrPos do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background "RTN","TMGIDE2",507,0) . else if cHighExecPos do VCOLORS^TMGTERM(14,3) ;"bright white on yellow background "RTN","TMGIDE2",508,0) . if cdLoop>0 do "RTN","TMGIDE2",509,0) . . new tSpace set tSpace="" "RTN","TMGIDE2",510,0) . . if cdLoop<10 set tSpace=" " "RTN","TMGIDE2",511,0) . . set cbLine="+"_cdLoop_tSpace_cbLine "RTN","TMGIDE2",512,0) . else set cbLine=" "_cbLine "RTN","TMGIDE2",513,0) . if cBrkLine do "RTN","TMGIDE2",514,0) . . if (cHighCsrPos=0)&(cHighExecPos=0) do VCOLORS^TMGTERM(14,8) ;"bright white on red background "RTN","TMGIDE2",515,0) . . else do "RTN","TMGIDE2",516,0) . . . do VCOLORS^TMGTERM(1,6) ;"red on cyan "RTN","TMGIDE2",517,0) . . . set CsrOnBreakline=1 "RTN","TMGIDE2",518,0) . if (cdLoop=scOffset) write ">" "RTN","TMGIDE2",519,0) . else if cBrkLine write "#" "RTN","TMGIDE2",520,0) . else write " " "RTN","TMGIDE2",521,0) . if $length(cbLine)>(ScrWidth-1) write $extract(cbLine,1,ScrWidth-4),"...",! "RTN","TMGIDE2",522,0) . else do "RTN","TMGIDE2",523,0) . . write $extract(cbLine,1,ScrWidth-1) "RTN","TMGIDE2",524,0) . . write $extract(BlankLine,1,ScrWidth-$length(cbLine)-1),! "RTN","TMGIDE2",525,0) . if (cdLoop=scOffset)!(cHighCsrPos)!(cBrkLine) do "RTN","TMGIDE2",526,0) . . do VCOLORS^TMGTERM(14,4) ;"bright white on blue background "RTN","TMGIDE2",527,0) "RTN","TMGIDE2",528,0) for cdLoop=1:1:ScrWidth write "~" "RTN","TMGIDE2",529,0) write ! "RTN","TMGIDE2",530,0) "RTN","TMGIDE2",531,0) SCDone "RTN","TMGIDE2",532,0) do VTATRIB^TMGTERM(0) ;"reset colors "RTN","TMGIDE2",533,0) "RTN","TMGIDE2",534,0) quit "RTN","TMGIDE2",535,0) "RTN","TMGIDE2",536,0) "RTN","TMGIDE2",537,0) GetStackInfo(Stack,ExecPos) "RTN","TMGIDE2",538,0) ;"Purpose: to query GTM and get back filtered Stack information "RTN","TMGIDE2",539,0) ;"Input: Stack -- PASS BY REFERENCE. An array to received back info. Old info is killed "RTN","TMGIDE2",540,0) ;" ExecPos -- OPTIONAL. Current execution position "RTN","TMGIDE2",541,0) "RTN","TMGIDE2",542,0) set ExecPos=$get(ExecPos) "RTN","TMGIDE2",543,0) kill Stack "RTN","TMGIDE2",544,0) new i,count "RTN","TMGIDE2",545,0) set count=1 "RTN","TMGIDE2",546,0) if $STACK<3 quit ;"0-2 are steps getting into debugger "RTN","TMGIDE2",547,0) for i=3:1:$STACK do "RTN","TMGIDE2",548,0) . new s "RTN","TMGIDE2",549,0) . set s=$STACK(i,"PLACE") "RTN","TMGIDE2",550,0) . if s["TMGIDE" quit "RTN","TMGIDE2",551,0) . if s["GTM$DMODE" quit "RTN","TMGIDE2",552,0) . if s="@" set s=s_""""_$STACK(i,"MCODE")_"""" "RTN","TMGIDE2",553,0) . if s=ExecPos set s=s_" <--Current execution point",i=$STACK+1 "RTN","TMGIDE2",554,0) . set Stack(count)=$STACK(i)_" "_s "RTN","TMGIDE2",555,0) . set count=count+1 "RTN","TMGIDE2",556,0) "RTN","TMGIDE2",557,0) quit "RTN","TMGIDE2",558,0) "RTN","TMGIDE2",559,0) "RTN","TMGIDE2",560,0) ToggleBreakpoint(pos,condition) "RTN","TMGIDE2",561,0) ;"Purpose: to set or release the GT.M breakpoint at position "RTN","TMGIDE2",562,0) ;"Input: pos -- the position to alter "RTN","TMGIDE2",563,0) ;" condition -- OPTIONAL -- should be contain valid M code such that "RTN","TMGIDE2",564,0) ;" if @condition is valid. Examples: "RTN","TMGIDE2",565,0) ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1 "RTN","TMGIDE2",566,0) "RTN","TMGIDE2",567,0) ;"write "Is ",pos," a breakpoint? " "RTN","TMGIDE2",568,0) if $$IsBreakpoint(pos) do "RTN","TMGIDE2",569,0) . ;"write "YES",! "RTN","TMGIDE2",570,0) . do RelBreakpoint(pos) "RTN","TMGIDE2",571,0) else do "RTN","TMGIDE2",572,0) . ;"write "NO",! "RTN","TMGIDE2",573,0) . do SetBreakpoint(pos,.condition) "RTN","TMGIDE2",574,0) quit "RTN","TMGIDE2",575,0) "RTN","TMGIDE2",576,0) IsBreakpoint(pos) "RTN","TMGIDE2",577,0) ;"Purpose: to determine if position is a breakpoint pos "RTN","TMGIDE2",578,0) "RTN","TMGIDE2",579,0) ;"Note: I am concerned that pos might contain a name longer than 8 chars "RTN","TMGIDE2",580,0) ;" and might give a false result, or ^TMP(...) might hold a name "RTN","TMGIDE2",581,0) ;" longer than 8 chars. "RTN","TMGIDE2",582,0) ;" BUT, if I just cut name off at 8 chars, it might not work well "RTN","TMGIDE2",583,0) ;" with GTM v5 "RTN","TMGIDE2",584,0) "RTN","TMGIDE2",585,0) new result set result=0 "RTN","TMGIDE2",586,0) ;"write "looking for breakpoint at: ",pos,! "RTN","TMGIDE2",587,0) if $get(pos)'="" set result=$data(^TMG("TMGIDE",$J,"ZBREAK",pos)) "RTN","TMGIDE2",588,0) ;"if result=1 write "here is result: ",result,! "RTN","TMGIDE2",589,0) quit (result'=0) "RTN","TMGIDE2",590,0) "RTN","TMGIDE2",591,0) "RTN","TMGIDE2",592,0) ensureBreakpoints() "RTN","TMGIDE2",593,0) ;"Purpose: When an module is recompiled, GT.M drops the breakpoints for "RTN","TMGIDE2",594,0) ;" that module. However, the breakpoints are still stored for this "RTN","TMGIDE2",595,0) ;" debugger, meaning that the lines will still be highlighted etc, "RTN","TMGIDE2",596,0) ;" --but they don't work. This function will go through stored "RTN","TMGIDE2",597,0) ;" breakpoints and again register them with GT.M "RTN","TMGIDE2",598,0) "RTN","TMGIDE2",599,0) new pos set pos="" "RTN","TMGIDE2",600,0) for set pos=$order(^TMG("TMGIDE",$J,"ZBREAK",pos)) quit:(pos="") do "RTN","TMGIDE2",601,0) . do SetBreakpoint(pos) "RTN","TMGIDE2",602,0) "RTN","TMGIDE2",603,0) quit "RTN","TMGIDE2",604,0) "RTN","TMGIDE2",605,0) "RTN","TMGIDE2",606,0) SetBreakpoint(pos,condition) "RTN","TMGIDE2",607,0) ;"Purpose: set the GT.M breakpoint to pos position "RTN","TMGIDE2",608,0) ;"Input: pos -- the position to alter "RTN","TMGIDE2",609,0) ;" condition -- OPTIONAL -- should be contain valid M code such that "RTN","TMGIDE2",610,0) ;" if @condition is valid. Examples: "RTN","TMGIDE2",611,0) ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1 "RTN","TMGIDE2",612,0) "RTN","TMGIDE2",613,0) if $get(pos)="" do goto SBkDone "RTN","TMGIDE2",614,0) . write "?? no position specified ??",! "RTN","TMGIDE2",615,0) new brkLine "RTN","TMGIDE2",616,0) set brkLine=pos_":""n tmg s TMGRunMode=1 s tmg=$$STEPTRAP^TMGIDE2($ZPOS,1)""" "RTN","TMGIDE2",617,0) "RTN","TMGIDE2",618,0) set ^TMG("TMGIDE",$J,"ZBREAK",pos)="" "RTN","TMGIDE2",619,0) do SetBrkCond(pos,.condition) "RTN","TMGIDE2",620,0) do "RTN","TMGIDE2",621,0) . new $etrap "RTN","TMGIDE2",622,0) . set $etrap="K ^TMG(""TMGIDE"",$J,""ZBREAK"",pos) S $ETRAP="""",$ECODE=""""" "RTN","TMGIDE2",623,0) . ZBREAK @brkLine "RTN","TMGIDE2",624,0) ;"write "Setting breakpoint at: ",pos,! "RTN","TMGIDE2",625,0) "RTN","TMGIDE2",626,0) SBkDone "RTN","TMGIDE2",627,0) quit "RTN","TMGIDE2",628,0) "RTN","TMGIDE2",629,0) "RTN","TMGIDE2",630,0) SetBrkCond(pos,condition) "RTN","TMGIDE2",631,0) ;"Purpose: A standardized SET for condition. "RTN","TMGIDE2",632,0) if $get(condition)="" quit "RTN","TMGIDE2",633,0) if $get(pos)="" quit "RTN","TMGIDE2",634,0) if condition="@" kill ^TMG("TMGIDE",$J,"ZBREAK",pos,"IF") "RTN","TMGIDE2",635,0) else set ^TMG("TMGIDE",$J,"ZBREAK",pos,"IF")=condition "RTN","TMGIDE2",636,0) if $$IsBreakpoint(pos)=0 do SetBreakpoint(pos) "RTN","TMGIDE2",637,0) quit "RTN","TMGIDE2",638,0) "RTN","TMGIDE2",639,0) "RTN","TMGIDE2",640,0) GetBrkCond(pos) "RTN","TMGIDE2",641,0) ;"Purpose: A standardized GET for condition. "RTN","TMGIDE2",642,0) ;"Results: returns condition code, or "" "RTN","TMGIDE2",643,0) new result set result="" "RTN","TMGIDE2",644,0) set:(pos'="") result=$get(^TMG("TMGIDE",$J,"ZBREAK",pos,"IF")) "RTN","TMGIDE2",645,0) quit result "RTN","TMGIDE2",646,0) "RTN","TMGIDE2",647,0) RelBreakpoint(pos) "RTN","TMGIDE2",648,0) ;"Purpose: to release a GT.M breakpoint at position "RTN","TMGIDE2",649,0) "RTN","TMGIDE2",650,0) new brkLine "RTN","TMGIDE2",651,0) set brkLine=pos_":""zcontinue""" "RTN","TMGIDE2",652,0) kill ^TMG("TMGIDE",$J,"ZBREAK",pos) "RTN","TMGIDE2",653,0) ;"write "released breakpoint at: ",pos,! "RTN","TMGIDE2",654,0) "RTN","TMGIDE2",655,0) ZBREAK @brkLine "RTN","TMGIDE2",656,0) quit "RTN","TMGIDE2",657,0) "RTN","TMGIDE2",658,0) "RTN","TMGIDE2",659,0) ShouldSkip(module) "RTN","TMGIDE2",660,0) ;"Purpose: to see if module is in hidden list "RTN","TMGIDE2",661,0) new result set result=0 "RTN","TMGIDE2",662,0) if $get(tpHideList)="" goto SSKDone "RTN","TMGIDE2",663,0) "RTN","TMGIDE2",664,0) new mod set mod="" "RTN","TMGIDE2",665,0) new l set l=$length(module) "RTN","TMGIDE2",666,0) for set mod=$order(@tpHideList@(mod)) quit:(mod="")!(result=1) do "RTN","TMGIDE2",667,0) . set result=($extract(module,1,l)=mod) "RTN","TMGIDE2",668,0) SSKDone "RTN","TMGIDE2",669,0) quit result "RTN","TMGIDE2",670,0) "RTN","TMGIDE2",671,0) "RTN","TMGIDE2",672,0) SetupSkips "RTN","TMGIDE2",673,0) ;"Purpose: to manage modules that are to be skipped over. "RTN","TMGIDE2",674,0) ;"Input: none. But this modifies variable @tpHideList with global scope "RTN","TMGIDE2",675,0) ;"results: none "RTN","TMGIDE2",676,0) "RTN","TMGIDE2",677,0) new menu,option "RTN","TMGIDE2",678,0) set menu(0)="Pick Options for Hiding/Showing Modules" "RTN","TMGIDE2",679,0) set menu(1)="SHOW current hidden list"_$c(9)_"SHOW" "RTN","TMGIDE2",680,0) set menu(2)="ADD module to hidden list"_$c(9)_"ADD" "RTN","TMGIDE2",681,0) set menu(3)="REMOVE module from hidden list"_$c(9)_"REMOVE" "RTN","TMGIDE2",682,0) set menu(4)="Done."_$c(9)_"^" "RTN","TMGIDE2",683,0) "RTN","TMGIDE2",684,0) StSkp set option=$$Menu^TMGUSRIF(.menu) "RTN","TMGIDE2",685,0) if option="SHOW" do ShowSkip "RTN","TMGIDE2",686,0) if option="ADD" do AddSkip "RTN","TMGIDE2",687,0) if option="REMOVE" do RmSkip "RTN","TMGIDE2",688,0) if option="^" goto StSkDone "RTN","TMGIDE2",689,0) goto StSkp "RTN","TMGIDE2",690,0) "RTN","TMGIDE2",691,0) StSkDone "RTN","TMGIDE2",692,0) quit "RTN","TMGIDE2",693,0) "RTN","TMGIDE2",694,0) AddSkip "RTN","TMGIDE2",695,0) ;"Purpose: to allow user to Add a module to hidden list "RTN","TMGIDE2",696,0) ;"Input: none. But this modifies variable @tpHideList with global scope "RTN","TMGIDE2",697,0) ;"results: none "RTN","TMGIDE2",698,0) "RTN","TMGIDE2",699,0) ASKP1 write "Enter name of module to add to hidden list (? for help, ^ to abort)",! "RTN","TMGIDE2",700,0) new mod "RTN","TMGIDE2",701,0) read "Enter module: ",mod:$get(DTIME,3600),! "RTN","TMGIDE2",702,0) if mod="?" do goto ASKP1 "RTN","TMGIDE2",703,0) . write "Some modules of the code are not helpful to debugging one's code.",! "RTN","TMGIDE2",704,0) . write "For example, if one did not ever want to trace into the code stored",! "RTN","TMGIDE2",705,0) . write "in DIC, then DIC would be added as a module to be hidden. Then, when",! "RTN","TMGIDE2",706,0) . write "debugging one's own code, all traces into ^DIC would be skipped over.",! "RTN","TMGIDE2",707,0) . write "If only part of the name is specified, then ALL modules starting with",! "RTN","TMGIDE2",708,0) . write "this name will be excluded.",! "RTN","TMGIDE2",709,0) . do PressToCont^TMGUSERIF "RTN","TMGIDE2",710,0) if mod="^" goto ASDone "RTN","TMGIDE2",711,0) write "Add '",mod,"' as a module to be skipped over" "RTN","TMGIDE2",712,0) new % set %=1 "RTN","TMGIDE2",713,0) do YN^DICN "RTN","TMGIDE2",714,0) if %=1 set @tpHideList@(mod)="" "RTN","TMGIDE2",715,0) "RTN","TMGIDE2",716,0) ASDone "RTN","TMGIDE2",717,0) quit "RTN","TMGIDE2",718,0) "RTN","TMGIDE2",719,0) RmSkip "RTN","TMGIDE2",720,0) ;"Purpose: to allow user to remove a module from hidden list "RTN","TMGIDE2",721,0) ;"Input: none. But this modifies variable @tpHideList with global scope "RTN","TMGIDE2",722,0) ;"results: none "RTN","TMGIDE2",723,0) "RTN","TMGIDE2",724,0) new menu,option,idx "RTN","TMGIDE2",725,0) RmL1 kill menu "RTN","TMGIDE2",726,0) set idx=0 "RTN","TMGIDE2",727,0) new mod set mod="" "RTN","TMGIDE2",728,0) ;"Load menu with current list. "RTN","TMGIDE2",729,0) for set mod=$order(@tpHideList@(mod)) quit:(mod="") do "RTN","TMGIDE2",730,0) . set idx=idx+1,menu(idx)=mod_$c(9)_mod "RTN","TMGIDE2",731,0) if $data(menu)=0 goto RmSkipDone "RTN","TMGIDE2",732,0) . write "--The list is currently empty--" "RTN","TMGIDE2",733,0) . do PressToCont^TMGUSRIF "RTN","TMGIDE2",734,0) set idx=idx+1 "RTN","TMGIDE2",735,0) set menu(idx)="Done"_$c(9)_"^" "RTN","TMGIDE2",736,0) set menu(0)="Pick Module to remove from hidden list" "RTN","TMGIDE2",737,0) set option=$$Menu^TMGUSRIF(.menu) "RTN","TMGIDE2",738,0) if option="^" goto RmSkipDone "RTN","TMGIDE2",739,0) kill @tpHideList@(option) "RTN","TMGIDE2",740,0) goto RmL1 "RTN","TMGIDE2",741,0) "RTN","TMGIDE2",742,0) RmSkipDone "RTN","TMGIDE2",743,0) quit "RTN","TMGIDE2",744,0) "RTN","TMGIDE2",745,0) "RTN","TMGIDE2",746,0) ShowSkip "RTN","TMGIDE2",747,0) ;"Purpose: to show the hidden list "RTN","TMGIDE2",748,0) ;"Input: none. But this uses variable @tpHideList with global scope "RTN","TMGIDE2",749,0) ;"results: none "RTN","TMGIDE2",750,0) "RTN","TMGIDE2",751,0) new mod set mod="" "RTN","TMGIDE2",752,0) if $data(@tpHideList)>0 do "RTN","TMGIDE2",753,0) . for set mod=$order(@tpHideList@(mod)) quit:(mod="") do "RTN","TMGIDE2",754,0) . . write " ",mod,! "RTN","TMGIDE2",755,0) else do "RTN","TMGIDE2",756,0) . write "--The list is currently empty--" "RTN","TMGIDE2",757,0) do PressToCont^TMGUSRIF "RTN","TMGIDE2",758,0) quit "RTN","TMGIDE3") 0^110^B2891 "RTN","TMGIDE3",1,0) TMGIDE3 ;TMG/kst/A debugger/tracer for GT.M (Listener code) ;04/14/08 "RTN","TMGIDE3",2,0) ;;1.0;TMG-LIB;**1**;04/14/08 "RTN","TMGIDE3",3,0) "RTN","TMGIDE3",4,0) ;" TMG IDE Debugger Listener "RTN","TMGIDE3",5,0) ;" "RTN","TMGIDE3",6,0) ;" K. Toppenberg "RTN","TMGIDE3",7,0) ;" 4-14-2008 "RTN","TMGIDE3",8,0) ;" License: GPL Applies "RTN","TMGIDE3",9,0) ;" "RTN","TMGIDE3",10,0) ;"------------------------------------------------------------ "RTN","TMGIDE3",11,0) ;"------------------------------------------------------------ "RTN","TMGIDE3",12,0) "RTN","TMGIDE3",13,0) Listener "RTN","TMGIDE3",14,0) ;"Purpose: This code will wait for messages from the executing process, and "RTN","TMGIDE3",15,0) ;" will display the code as it changes, and send messages back to "RTN","TMGIDE3",16,0) ;" all the user to control the process remotely. "RTN","TMGIDE3",17,0) ;" --This code will be run from the LISTENING process. "RTN","TMGIDE3",18,0) "RTN","TMGIDE3",19,0) new Msg "RTN","TMGIDE3",20,0) new jobNumWatching set jobNumWatching=0 "RTN","TMGIDE3",21,0) new UsrInput "RTN","TMGIDE3",22,0) new hangDelay set hangDelay=0.2 "RTN","TMGIDE3",23,0) "RTN","TMGIDE3",24,0) new BlankLine set $piece(BlankLine," ",78)=" " "RTN","TMGIDE3",25,0) new HxSize set HxSize=8 ;"hard codes in history length of 8 "RTN","TMGIDE3",26,0) new TMGdbgLine "RTN","TMGIDE3",27,0) new TMGlastline set TMGlastLine="" "RTN","TMGIDE3",28,0) new HxShowNum set HxShowNum=0 "RTN","TMGIDE3",29,0) new HxLine,HxLineMax,HxLineCur "RTN","TMGIDE3",30,0) do INITKB^XGF() ;"set up keyboard input escape code processing "RTN","TMGIDE3",31,0) "RTN","TMGIDE3",32,0) new i write # for i=1:1:12 write ! "RTN","TMGIDE3",33,0) write "=== TMG IDE Listener ===",!,! "RTN","TMGIDE3",34,0) write "Job# ",$J,": Waiting for a Sender..." "RTN","TMGIDE3",35,0) "RTN","TMGIDE3",36,0) new msgRef set msgRef=$name(^TMG("TMGIDE","LISTENER",$J)) "RTN","TMGIDE3",37,0) Init set @msgRef@("STATUS")="AVAIL" "RTN","TMGIDE3",38,0) set @msgRef@("MSG IN")="" "RTN","TMGIDE3",39,0) set @msgRef@("MSG OUT")="" "RTN","TMGIDE3",40,0) Loop "RTN","TMGIDE3",41,0) set Msg=$get(@msgRef@("MSG IN")) "RTN","TMGIDE3",42,0) "RTN","TMGIDE3",43,0) if Msg["INQ" do ;"Expects: 'INQ 12345' and 12345 is job number asking "RTN","TMGIDE3",44,0) . new fromJob set fromJob=$piece(Msg," ",2) "RTN","TMGIDE3",45,0) . set @msgRef@("MSG OUT")="ACK "_fromJob "RTN","TMGIDE3",46,0) . ;"write "Sending msg: ","ACK "_fromJob,! "RTN","TMGIDE3",47,0) else if Msg["LISTEN TO " do ;"Expects: 'LISTEN TO 12345' and 12345 is job number asking "RTN","TMGIDE3",48,0) . set jobNumWatching=+$piece(Msg," ",3) "RTN","TMGIDE3",49,0) . set @msgRef@("STATUS")="LISTENING TO "_jobNumWatching "RTN","TMGIDE3",50,0) . set @msgRef@("MSG OUT")=@msgRef@("STATUS") "RTN","TMGIDE3",51,0) . ;"write "Sending msg: ",@msgRef@("STATUS"),! "RTN","TMGIDE3",52,0) else if Msg="DONE" do goto LstnDone "RTN","TMGIDE3",53,0) . set @msgRef@("MSG OUT")="OK" "RTN","TMGIDE3",54,0) . write "DONE received. Quitting.",! "RTN","TMGIDE3",55,0) else if Msg["TALK" do "RTN","TMGIDE3",56,0) . write $piece(Msg," ",2),! "RTN","TMGIDE3",57,0) . set @msgRef@("MSG OUT")="OK" "RTN","TMGIDE3",58,0) else if Msg="DO PROMPT" do "RTN","TMGIDE3",59,0) . new result set result=$$Prompt() "RTN","TMGIDE3",60,0) . set @msgRef@("MSG OUT")=result "RTN","TMGIDE3",61,0) else if $piece(Msg," ",1)="READ" do "RTN","TMGIDE3",62,0) . new s,result "RTN","TMGIDE3",63,0) . set s=$piece(Msg," ",2,99) "RTN","TMGIDE3",64,0) . write s "RTN","TMGIDE3",65,0) . read result:$get(DTIME,3600),! "RTN","TMGIDE3",66,0) . set @msgRef@("MSG OUT")=result "RTN","TMGIDE3",67,0) else if $piece(Msg," ",1,2)="DO TRAP" do "RTN","TMGIDE3",68,0) . new idePos set idePos=$piece(Msg," ",3) "RTN","TMGIDE3",69,0) . new TMGMsg set TMGMsg=$piece(Msg," ",4) "RTN","TMGIDE3",70,0) . new TMGdbgResult "RTN","TMGIDE3",71,0) . set TMGdbgResult=$$STEPTRAP^TMGIDE2(idePos,TMGMsg) "RTN","TMGIDE3",72,0) . set @msgRef@("MSG OUT")=TMGdbgResult "RTN","TMGIDE3",73,0) "RTN","TMGIDE3",74,0) set @msgRef@("MSG IN")="" "RTN","TMGIDE3",75,0) "RTN","TMGIDE3",76,0) LUser "RTN","TMGIDE3",77,0) set UsrInput=$$KeyPressed^TMGUSRIF(1) ;"1=wantChar "RTN","TMGIDE3",78,0) if UsrInput="" hang hangDelay goto Loop "RTN","TMGIDE3",79,0) "RTN","TMGIDE3",80,0) if UsrInput="^" goto LstnDone "RTN","TMGIDE3",81,0) goto Loop "RTN","TMGIDE3",82,0) "RTN","TMGIDE3",83,0) LstnDone "RTN","TMGIDE3",84,0) kill @msgRef "RTN","TMGIDE3",85,0) quit "RTN","TMGIDE3",86,0) "RTN","TMGIDE3",87,0) ;"------------------------------------------------------------------- "RTN","TMGIDE3",88,0) SetErrTrap "RTN","TMGIDE3",89,0) set $ZTRAP="do ErrTrap^TMGIDE2($ZPOS) break" "RTN","TMGIDE3",90,0) set $ZSTATUS="" "RTN","TMGIDE3",91,0) quit "RTN","TMGIDE3",92,0) "RTN","TMGIDE3",93,0) ;"------------------------------------------------------------------- "RTN","TMGIDE3",94,0) "RTN","TMGIDE3",95,0) Prompt() "RTN","TMGIDE3",96,0) ;"Purpose: to interact with user and run through code. "RTN","TMGIDE3",97,0) "RTN","TMGIDE3",98,0) new i write # for i=1:1:12 write ! "RTN","TMGIDE3",99,0) write "=== TMG IDE Controller ===",!,! "RTN","TMGIDE3",100,0) "RTN","TMGIDE3",101,0) Ppt2 "RTN","TMGIDE3",102,0) set HxShowNum=+$get(HxShowNum) "RTN","TMGIDE3",103,0) set TMGStepMode="into" ;"kt added 5/3/06 "RTN","TMGIDE3",104,0) set HxLine=$get(^TMG("TMGIDE","CMD HISTORY",$J,HxShowNum)) "RTN","TMGIDE3",105,0) set HxLineMax=$get(^TMG("TMGIDE","CMD HISTORY",$J,"MAX"),0) "RTN","TMGIDE3",106,0) "RTN","TMGIDE3",107,0) write "(^ to quit) " "RTN","TMGIDE3",108,0) if HxShowNum=0 write "^// " "RTN","TMGIDE3",109,0) else write "// ",HxLine "RTN","TMGIDE3",110,0) "RTN","TMGIDE3",111,0) set TMGdbgLine=$$READ^TMGIDE() ;"$$READ^XGF ;"returns line terminator in TMGXGRT "RTN","TMGIDE3",112,0) if TMGdbgLine="?" do goto Ppt2 "RTN","TMGIDE3",113,0) . write !,"Here you should enter any valid M command, as would normally",! "RTN","TMGIDE3",114,0) . write "entered at a GTM> prompt.",! "RTN","TMGIDE3",115,0) . write " examples: WRITE ""HELLO"",! or DO ^TMGTEST",! "RTN","TMGIDE3",116,0) "RTN","TMGIDE3",117,0) if (TMGdbgLine="")&(HxShowNum>0) set TMGdbgLine=HxLine "RTN","TMGIDE3",118,0) ;"if (TMGdbgLine="")&(TMGXGRT="CR")&(HxShowNum>0) set TMGdbgLine=HxLine "RTN","TMGIDE3",119,0) "RTN","TMGIDE3",120,0) if (TMGXGRT="DOWN")!(TMGXGRT="RIGHT")!(TMGdbgLine="]") do goto Ppt2 "RTN","TMGIDE3",121,0) . set HxShowNum=HxShowNum-1 "RTN","TMGIDE3",122,0) . if HxShowNum<0 set HxShowNum=HxLineMax "RTN","TMGIDE3",123,0) . ;"write "setting HxShowNum=",HxShowNum,! "RTN","TMGIDE3",124,0) . do CHA^TMGTERM(1) write BlankLine do CHA^TMGTERM(1) "RTN","TMGIDE3",125,0) "RTN","TMGIDE3",126,0) if (TMGXGRT="UP")!(TMGXGRT="LEFT")!(TMGdbgLine="[") do goto Ppt2 "RTN","TMGIDE3",127,0) . set HxShowNum=HxShowNum+1 "RTN","TMGIDE3",128,0) . if HxShowNum>HxLineMax set HxShowNum=0 "RTN","TMGIDE3",129,0) . ;"write "setting HxShowNum=",HxShowNum,! "RTN","TMGIDE3",130,0) . do CHA^TMGTERM(1) write BlankLine do CHA^TMGTERM(1) "RTN","TMGIDE3",131,0) "RTN","TMGIDE3",132,0) if TMGdbgLine="" set TMGdbgLine="^" "RTN","TMGIDE3",133,0) ;"if TMGdbgLine="^" set $ZSTEP="" quit "RTN","TMGIDE3",134,0) write ! "RTN","TMGIDE3",135,0) "RTN","TMGIDE3",136,0) ;"Save Cmd history "RTN","TMGIDE3",137,0) set HxLineCur=$get(^TMG("TMGIDE","CMD HISTORY",$J,"CUR"),0) ;"<-- points to last used, not next avail "RTN","TMGIDE3",138,0) set HxLineMax=$get(^TMG("TMGIDE","CMD HISTORY",$J,"MAX"),0) ;"equals buffer size AFTER it fills "RTN","TMGIDE3",139,0) set HxLineCur=HxLineCur+1 "RTN","TMGIDE3",140,0) if HxLineCur>HxSize set HxLineCur=1 "RTN","TMGIDE3",141,0) set ^TMG("TMGIDE","CMD HISTORY",$J,HxLineCur)=TMGdbgLine "RTN","TMGIDE3",142,0) set ^TMG("TMGIDE","CMD HISTORY",$J,"CUR")=HxLineCur "RTN","TMGIDE3",143,0) if HxLineCur>HxLineMax do "RTN","TMGIDE3",144,0) . set HxLineMax=HxLineCur "RTN","TMGIDE3",145,0) . set ^TMG("TMGIDE","CMD HISTORY",$J,"MAX")=HxLineMax "RTN","TMGIDE3",146,0) ;"write "Saving line in #",HxLineCur," Max=",HxLineMax,! "RTN","TMGIDE3",147,0) "RTN","TMGIDE3",148,0) quit TMGdbgLine "RTN","TMGIDE3",149,0) "RTN","TMGIDE3",150,0) ;"------------------------------------------------------------------- "RTN","TMGIDE3",151,0) ;"------------------------------------------------------------------- "RTN","TMGIDE3",152,0) "RTN","TMGIDE3",153,0) "RTN","TMGIDE3",154,0) "RTN","TMGIDE4") 0^111^B3347 "RTN","TMGIDE4",1,0) TMGIDE4 ;TMG/kst/A debugger/tracer for GT.M (Sender code) ;04/14/08 "RTN","TMGIDE4",2,0) ;;1.0;TMG-LIB;**1**;04/14/08 "RTN","TMGIDE4",3,0) "RTN","TMGIDE4",4,0) ;" TMG IDE Debugger Sender "RTN","TMGIDE4",5,0) ;" "RTN","TMGIDE4",6,0) ;" K. Toppenberg "RTN","TMGIDE4",7,0) ;" 4-14-2008 "RTN","TMGIDE4",8,0) ;" License: GPL Applies "RTN","TMGIDE4",9,0) ;" "RTN","TMGIDE4",10,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",11,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",12,0) "RTN","TMGIDE4",13,0) "RTN","TMGIDE4",14,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",15,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",16,0) Sender "RTN","TMGIDE4",17,0) ;"Purpose: This code will be run from the debugging process, that will "RTN","TMGIDE4",18,0) ;" be sending it's output another listening process. "RTN","TMGIDE4",19,0) "RTN","TMGIDE4",20,0) new TMGdbgListener,TMGdbgResult,TMGdbgXLine "RTN","TMGIDE4",21,0) set TMGdbgListener=$$GetListener() "RTN","TMGIDE4",22,0) write "Found Controller: Job #",TMGdbgListener,! "RTN","TMGIDE4",23,0) set ^TMG("TMGIDE","SENDER",$J,"CONNECTED TO")=TMGdbgListener "RTN","TMGIDE4",24,0) "RTN","TMGIDE4",25,0) set TMGdbgResult=$$MessageTo(TMGdbgListener,"Welcome to the TMG debugging environment",,1) "RTN","TMGIDE4",26,0) set TMGdbgResult=$$MessageTo(TMGdbgListener,"READ "_"Enter any valid M command...",9999,1) "RTN","TMGIDE4",27,0) SendL1 "RTN","TMGIDE4",28,0) write !,!,"=== TMG IDE Sender ===",!,! "RTN","TMGIDE4",29,0) write "Waiting for command from Controller window..." "RTN","TMGIDE4",30,0) set TMGdbgXLine=$$MessageTo(TMGdbgListener,"DO PROMPT",9999,0) "RTN","TMGIDE4",31,0) write ! "RTN","TMGIDE4",32,0) "RTN","TMGIDE4",33,0) if TMGdbgXLine="^" goto SendDone "RTN","TMGIDE4",34,0) "RTN","TMGIDE4",35,0) set TMGRunMode=1 ;"1=Step-by-step mode "RTN","TMGIDE4",36,0) set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE4($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" "RTN","TMGIDE4",37,0) "RTN","TMGIDE4",38,0) ;"write "About to xecute: ",TMGdbgXLine,! "RTN","TMGIDE4",39,0) zstep into "RTN","TMGIDE4",40,0) xecute TMGdbgXLine "RTN","TMGIDE4",41,0) set $ZSTEP="" ;"turn off step capture "RTN","TMGIDE4",42,0) goto SendL1 "RTN","TMGIDE4",43,0) "RTN","TMGIDE4",44,0) "RTN","TMGIDE4",45,0) SendDone "RTN","TMGIDE4",46,0) write $$MessageTo(TMGdbgListener,"DONE",,1),! "RTN","TMGIDE4",47,0) kill ^TMG("TMGIDE","SENDER",$J) "RTN","TMGIDE4",48,0) quit "RTN","TMGIDE4",49,0) "RTN","TMGIDE4",50,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",51,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",52,0) STEPTRAP(idePos,TMGMsg) "RTN","TMGIDE4",53,0) ;"Purpose: This is the line that is called by GT.M for each zstep event. "RTN","TMGIDE4",54,0) ;" It will be used to display the current code execution point, and "RTN","TMGIDE4",55,0) ;" query user as to plans for future execution: run/step/ etc. "RTN","TMGIDE4",56,0) ;"Input: idePos -- a text line containing position, as returned bye $ZPOS "RTN","TMGIDE4",57,0) ;" TMGMsg -- OPTIONAL -- can be used by programs to pass in info. "RTN","TMGIDE4",58,0) ;" If TMGMsg=1, then this function was called without the "RTN","TMGIDE4",59,0) ;" $ZSTEP value set, so this function should set it. "RTN","TMGIDE4",60,0) "RTN","TMGIDE4",61,0) set TMGMsg=$get(TMGMsg) "RTN","TMGIDE4",62,0) new TMGdbgResult "RTN","TMGIDE4",63,0) if +$get(TMGdbgListener)=0 do "RTN","TMGIDE4",64,0) . set TMGdbgListener=$get(^TMG("TMGIDE","SENDER",$J,"CONNECTED TO")) "RTN","TMGIDE4",65,0) set TMGdbgResult=$$MessageTo(TMGdbgListener,"DO TRAP "_idePos_" "_TMGMsg,9999,0) "RTN","TMGIDE4",66,0) "RTN","TMGIDE4",67,0) quit TMGdbgResult "RTN","TMGIDE4",68,0) "RTN","TMGIDE4",69,0) ;"------------------------------------------------------------ "RTN","TMGIDE4",70,0) "RTN","TMGIDE4",71,0) GetListener() "RTN","TMGIDE4",72,0) ;"Purpose: to find an available listener and connect to it. "RTN","TMGIDE4",73,0) ;"Note: this returns the FIRST active listener that is available. "RTN","TMGIDE4",74,0) ;"Result: returns $JOB of listening process, or 0 if none found. "RTN","TMGIDE4",75,0) "RTN","TMGIDE4",76,0) new jobNum,result "RTN","TMGIDE4",77,0) set jobNum=0,result=0 "RTN","TMGIDE4",78,0) for set jobNum=$order(^TMG("TMGIDE","LISTENER",jobNum)) quit:(+jobNum'>0)!(result>0) do "RTN","TMGIDE4",79,0) . if $get(^TMG("TMGIDE","LISTENER",jobNum,"STATUS"))="AVAIL" do "RTN","TMGIDE4",80,0) . . if $$ActiveListener(jobNum) do "RTN","TMGIDE4",81,0) . . . if $$MessageTo(jobNum,"LISTEN TO "_$J)="LISTENING TO "_$J do "RTN","TMGIDE4",82,0) . . . . set result=jobNum "RTN","TMGIDE4",83,0) . . else kill ^TMG("TMGIDE","LISTENER",jobNum) "RTN","TMGIDE4",84,0) quit result "RTN","TMGIDE4",85,0) "RTN","TMGIDE4",86,0) "RTN","TMGIDE4",87,0) ActiveListener(jobNum) "RTN","TMGIDE4",88,0) ;"Purpose: to determine if listener is alive and active. "RTN","TMGIDE4",89,0) ;"Results: 1 if listener active and alive, 0 otherwise "RTN","TMGIDE4",90,0) new result "RTN","TMGIDE4",91,0) set result=($$MessageTo(jobNum,"INQ "_$J)="ACK "_$J) "RTN","TMGIDE4",92,0) quit result "RTN","TMGIDE4",93,0) "RTN","TMGIDE4",94,0) "RTN","TMGIDE4",95,0) "RTN","TMGIDE4",96,0) MessageTo(jobNum,Msg,timeOutTime,ignoreReply) "RTN","TMGIDE4",97,0) ;"Purpose: to send message to listener, and return the reply, or time out "RTN","TMGIDE4",98,0) ;"Input: jobNum -- the $JOB of the listener "RTN","TMGIDE4",99,0) ;" Msg -- the message to send "RTN","TMGIDE4",100,0) ;" timeOutTime -- OPTIONAL, default is 2 seconds "RTN","TMGIDE4",101,0) ;" ignoreReply -- OPTIONAL, default is 0 "RTN","TMGIDE4",102,0) ;"Output: the returned message, or "" if timed out or no reply, or ignoreReply=1 "RTN","TMGIDE4",103,0) "RTN","TMGIDE4",104,0) ;"write !,"Sending to Listener #",jobNum,! "RTN","TMGIDE4",105,0) ;"write "Msg=",Msg,! "RTN","TMGIDE4",106,0) "RTN","TMGIDE4",107,0) set timeOutTime=$get(timeOutTime,2) "RTN","TMGIDE4",108,0) set ignoreReply=$get(ignoreReply,0) "RTN","TMGIDE4",109,0) new result set result="" "RTN","TMGIDE4",110,0) set ^TMG("TMGIDE","LISTENER",jobNum,"MSG OUT")="" ;"clear any old messge "RTN","TMGIDE4",111,0) set ^TMG("TMGIDE","LISTENER",jobNum,"MSG IN")=Msg "RTN","TMGIDE4",112,0) if (ignoreReply=0) for do quit:(result'="")!(timeOutTime<0) "RTN","TMGIDE4",113,0) . set result=$get(^TMG("TMGIDE","LISTENER",jobNum,"MSG OUT")) "RTN","TMGIDE4",114,0) . if (result'="") quit "RTN","TMGIDE4",115,0) . hang 0.1 "RTN","TMGIDE4",116,0) . set timeOutTime=timeOutTime-0.1 "RTN","TMGIDE4",117,0) "RTN","TMGIDE4",118,0) quit result "RTN","TMGIDE4",119,0) "RTN","TMGINIT") 0^26^B65344038 "RTN","TMGINIT",1,0) TMGINIT ;TMG/kst/Custom (non-interactive) version of DINIT ;03/25/06 "RTN","TMGINIT",2,0) ;;1.0;TMG-LIB;**1**;11/01/04 "RTN","TMGINIT",3,0) "RTN","TMGINIT",4,0) ;"DINIT(INFO) -- NON-INTERACTIVE versions of standard DINIT code. "RTN","TMGINIT",5,0) ;"============================================================================= "RTN","TMGINIT",6,0) ;"Kevin Toppenberg, MD 11-04 "RTN","TMGINIT",7,0) ;" "RTN","TMGINIT",8,0) ;"Purpose: "RTN","TMGINIT",9,0) ;" "RTN","TMGINIT",10,0) ;"This library will provide optional NON-INTERACTIVE versions of standard DINIT code. "RTN","TMGINIT",11,0) ;" "RTN","TMGINIT",12,0) ;"DINIT(INFO) "RTN","TMGINIT",13,0) ;" "RTN","TMGINIT",14,0) ;"============================================================================= "RTN","TMGINIT",15,0) "RTN","TMGINIT",16,0) DINIT(INFO) ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;1:06 PM 30 Mar 1999 "RTN","TMGINIT",17,0) V ;;22.0;VA FileMan (WorldVista Modified);;Mar 30, 1999 "RTN","TMGINIT",18,0) ;";;22.0;VA FileMan;;Mar 30, 1999 "RTN","TMGINIT",19,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","TMGINIT",20,0) ;" "RTN","TMGINIT",21,0) ;"K. Toppenberg's changes made November, 2004 "RTN","TMGINIT",22,0) ;" "RTN","TMGINIT",23,0) ;"Input: "RTN","TMGINIT",24,0) ;" Note: INFO variable is completely an OPTIONAL parameter. "RTN","TMGINIT",25,0) ;" If not supplied, interactive mode used "RTN","TMGINIT",26,0) ;" INFO("SILENT-OUTPUT") -- 1 = output is supressed. "RTN","TMGINIT",27,0) ;" INFO("SILENT-INPUT") -- 1 = User-interactive input is supressed. "RTN","TMGINIT",28,0) ;" "RTN","TMGINIT",29,0) ;" ** if in SILENT-INPUT mode, THEN the following data should be supplied: "RTN","TMGINIT",30,0) ;" ---------------------- "RTN","TMGINIT",31,0) ;" INFO("CONTINUE") -- Should contain the answer the user would enter for question: "RTN","TMGINIT",32,0) ;" "Initialize VA Fileman now?" (i.e. Y or N) "RTN","TMGINIT",33,0) ;" INFO("SITE NAME") -- answer for "SITE NAME?" "RTN","TMGINIT",34,0) ;" INFO("SITE NUMBER") -- answer for "SITE NUMBER?" "RTN","TMGINIT",35,0) ;" INFO("SYS TYPE") -- answer for "TYPE OF MUMPS SYSTEM YOU ARE USING" "RTN","TMGINIT",36,0) ;"Output: "RTN","TMGINIT",37,0) ;" If in SILENT-OUTPUT mode, then output that would normally go to the screen, will be routed to this array "RTN","TMGINIT",38,0) ;" NOTE: INFO SHOULD BE PASSED BY REFERENCE if user wants this information passed back out. "RTN","TMGINIT",39,0) ;" INFO("TEXT","LINES")=Number of output lines "RTN","TMGINIT",40,0) ;" INFO("TEXT",1)= 1st output line "RTN","TMGINIT",41,0) ;" INFO("TEXT",2)= 2nd output line, etc... "RTN","TMGINIT",42,0) ; "RTN","TMGINIT",43,0) ; "RTN","TMGINIT",44,0) "RTN","TMGINIT",45,0) NEW DBINDENT SET DBINDENT=0 "RTN","TMGINIT",46,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBINDENT,"Starting: DINIT^TMGINIT") "RTN","TMGINIT",47,0) "RTN","TMGINIT",48,0) NEW SILNTOUT SET SILNTOUT=$get(INFO("SILENT-OUTPUT"),0) ;//KT "RTN","TMGINIT",49,0) NEW SILENTIN SET SILENTIN=$GET(INFO("SILENT-INPUT"),0) ;//KT "RTN","TMGINIT",50,0) KILL INFO("TEXT") ;//kt "RTN","TMGINIT",51,0) "RTN","TMGINIT",52,0) D KL^DINIT6 "RTN","TMGINIT",53,0) N ; "RTN","TMGINIT",54,0) D VERSION "RTN","TMGINIT",55,0) N DIFROM S DIFROM=VERSION "RTN","TMGINIT",56,0) DO OUTP^TMGQIO(SILNTOUT,"!","!",X) "RTN","TMGINIT",57,0) D DT^DICRW "RTN","TMGINIT",58,0) I $G(^DD("VERSION"))]"",^DD("VERSION")_"z"]](VERSION_"z") D "RTN","TMGINIT",59,0) . DO OUTP^TMGQIO(SILNTOUT,$C(7),"!","!","*** WARNING!! VA FileMan version "_^DD("VERSION")_" is currently loaded on this system.","!") "RTN","TMGINIT",60,0) . DO OUTP^TMGQIO(SILNTOUT,"This Initialization will bring in VA FileMan version "_VERSION_", an earlier version!!","!","!") "RTN","TMGINIT",61,0) S Y=$G(^DD("OS")) I Y,"1,2,3,4,5,6,10,11,12,13,15,"[(Y_",") DO G KL^DINIT6 "RTN","TMGINIT",62,0) . DO OUTP^TMGQIO(SILNTOUT,$C(7),"!","!","Your defined operating system entry "_$P($G(^DD("OS",Y,0)),U)_" does not support the") "RTN","TMGINIT",63,0) . DO OUTP^TMGQIO(SILNTOUT,"!","1995 M Standards.","!","!") "RTN","TMGINIT",64,0) . DO OUTP^TMGQIO(SILNTOUT,"You may not initialize VA FileMan V21.") "RTN","TMGINIT",65,0) DO DO OUTP^TMGQIO(SILNTOUT,"!","!","Initialize VA FileMan now? NO//") "RTN","TMGINIT",66,0) DO INP^TMGQIO(.Y,SILENTIN,60,$GET(INFO("CONTINUE"))) "RTN","TMGINIT",67,0) GOTO:Y["^"!("Nn"[$E(Y))!('$T) KL^DINIT6 "RTN","TMGINIT",68,0) I "Yy"'[$E(Y) DO GOTO DO "RTN","TMGINIT",69,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Answer YES to begin Initializing VA FileMan (^ to abort)") "RTN","TMGINIT",70,0) ; "RTN","TMGINIT",71,0) ; "RTN","TMGINIT",72,0) NA DO OUTP^TMGQIO(SILNTOUT,"!","!","SITE NAME: ") "RTN","TMGINIT",73,0) I $D(^DD("SITE")) DO OUTP^TMGQIO(SILNTOUT,^DD("SITE"),"// ") "RTN","TMGINIT",74,0) DO INP^TMGQIO(.X,SILENTIN,60,$GET(INFO("SITE NAME"))) "RTN","TMGINIT",75,0) G KL^DINIT6:X="^"!'$T "RTN","TMGINIT",76,0) I X="",$D(^DD("SITE"))#2 S X=^DD("SITE") "RTN","TMGINIT",77,0) I X'?1AN.ANP DO G NA "RTN","TMGINIT",78,0) . DO OUTP^TMGQIO(SILNTOUT," ENTER THE NAME OF THIS INSTALLATION SITE (^ to abort)","!","!") "RTN","TMGINIT",79,0) S %X=X "RTN","TMGINIT",80,0) ; "RTN","TMGINIT",81,0) ; "RTN","TMGINIT",82,0) NO DO OUTP^TMGQIO(SILNTOUT,"!","!","SITE NUMBER: ") "RTN","TMGINIT",83,0) IF $D(^DD("SITE",1)) DO OUTP^TMGQIO(SILNTOUT,^DD("SITE",1),"// ") "RTN","TMGINIT",84,0) DO INP^TMGQIO(.X,SILENTIN,60,$GET(INFO("SITE NUMBER"))) "RTN","TMGINIT",85,0) IF (X="^")!('$T) G KL^DINIT6 "RTN","TMGINIT",86,0) IF X="" S X=$GET(^DD("SITE",1),0) "RTN","TMGINIT",87,0) IF X>0 DO "RTN","TMGINIT",88,0) . SET ^DD("SITE")=%X,^DD("SITE",1)=X "RTN","TMGINIT",89,0) IF (X'>0)&(SILENTIN=1) GOTO KL^DINIT6 "RTN","TMGINIT",90,0) IF X'>0 DO GOTO NO "RTN","TMGINIT",91,0) . DO OUTP^TMGQIO(SILNTOUT," ENTER A NUMBER, CORRESPONDING TO YOUR INSTITUTION") "RTN","TMGINIT",92,0) ;***** REMOVE AFTER V21 INIT ***** "RTN","TMGINIT",93,0) ;D "RTN","TMGINIT",94,0) ;. N DIREC F DIREC=0:0 S DIREC=$O(^DI(.84,DIREC)) Q:'DIREC Q:DIREC>10000 K ^DI(.84,DIREC,5) "RTN","TMGINIT",95,0) ;. Q "RTN","TMGINIT",96,0) ;********************************* "RTN","TMGINIT",97,0) K ^DD(0) "RTN","TMGINIT",98,0) D ^DINIT0,^DINIT11B "RTN","TMGINIT",99,0) D OSETC "RTN","TMGINIT",100,0) DO OUTP^TMGQIO(SILNTOUT,"!") "RTN","TMGINIT",101,0) S Y=1 "RTN","TMGINIT",102,0) D OS "RTN","TMGINIT",103,0) G KL^DINIT6:Y<0 "RTN","TMGINIT",104,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","Now loading other FileMan files--please wait.") "RTN","TMGINIT",105,0) G GO "RTN","TMGINIT",106,0) ; "RTN","TMGINIT",107,0) ; "RTN","TMGINIT",108,0) ;"============================================================================= "RTN","TMGINIT",109,0) OS DO OUTP^TMGQIO(SILNTOUT,"!") "RTN","TMGINIT",110,0) S DIC="^DD(""OS""," "RTN","TMGINIT",111,0) IF (SILENTIN=0)&($DATA(INFO("SYS TYPE"))'=0) DO "RTN","TMGINIT",112,0) . S DIC(0)="IAQE" "RTN","TMGINIT",113,0) . S DIC("A")="TYPE OF MUMPS SYSTEM YOU ARE USING: " "RTN","TMGINIT",114,0) ELSE DO "RTN","TMGINIT",115,0) . SET DIC(0)="I" "RTN","TMGINIT",116,0) . SET X=INFO("SYS TYPE") "RTN","TMGINIT",117,0) I $D(^DD("OS"))#2 DO "RTN","TMGINIT",118,0) . S (DITZS,DIC("B"))=^("OS") "RTN","TMGINIT",119,0) . S:DITZS=7 (DITZS,DIC("B"))=18 "RTN","TMGINIT",120,0) E DO "RTN","TMGINIT",121,0) . S (DITZS,^DD("OS"))=100 "RTN","TMGINIT",122,0) D ^DIC "RTN","TMGINIT",123,0) K DIC "RTN","TMGINIT",124,0) G Q:Y<0 "RTN","TMGINIT",125,0) S (DITZS,^DD("OS"))=+Y "RTN","TMGINIT",126,0) I $D(^%ZTSK),$D(^%ZOSF("OS"))#2,$D(^("MGR"))#2 D "RTN","TMGINIT",127,0) . S ZTRTN="OS^%RCR" "RTN","TMGINIT",128,0) . S ZTUCI=^%ZOSF("MGR") "RTN","TMGINIT",129,0) . S ZTDTH=$H "RTN","TMGINIT",130,0) . S ZTIO="" "RTN","TMGINIT",131,0) . S ZTSAVE("DITZS")="" "RTN","TMGINIT",132,0) . S ZTDESC="Set Operating System" "RTN","TMGINIT",133,0) . D ^%ZTLOAD "RTN","TMGINIT",134,0) . Q "RTN","TMGINIT",135,0) Q K DITZS,ZTSK "RTN","TMGINIT",136,0) Q "RTN","TMGINIT",137,0) ; "RTN","TMGINIT",138,0) ; "RTN","TMGINIT",139,0) ;"============================================================================= "RTN","TMGINIT",140,0) VERSION ; "RTN","TMGINIT",141,0) S VERSION=$P($T(V),";",3),X="VA FileMan V."_VERSION "RTN","TMGINIT",142,0) Q "RTN","TMGINIT",143,0) ; "RTN","TMGINIT",144,0) ; "RTN","TMGINIT",145,0) ;"============================================================================= "RTN","TMGINIT",146,0) GO ; "RTN","TMGINIT",147,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"GO^TMGINIT") "RTN","TMGINIT",148,0) S I=$C(126) "RTN","TMGINIT",149,0) S DIT=$P($H,",",2) "RTN","TMGINIT",150,0) S $P(^DIBT(0),U,1,2)="TEMPLATE^.4I" "RTN","TMGINIT",151,0) S $P(^DIE(0),U,1,2)="TEMPLATE^.4I" "RTN","TMGINIT",152,0) S $P(^DIPT(0),U,1,2)="TEMPLATE^.4I" "RTN","TMGINIT",153,0) S ^(.01,0)="CAPTIONED^" "RTN","TMGINIT",154,0) S ^("F",1)="S DIC=DCC,DA=D0 D EN^DIQ" "RTN","TMGINIT",155,0) S ^DIPT(.02,0)="FILE SECURITY CODES^^^1" "RTN","TMGINIT",156,0) S ^("F",1)=".01;L20"_I_"0;R13"_I_31_I_33_I_35_I_34_I_32_I_21_I_20 "RTN","TMGINIT",157,0) S ^DIA(0)="AUDIT^1.1I" "RTN","TMGINIT",158,0) K ^DD(.4),^(.41),^("^"),^(.403),^(.4031),^(.40315),^(.403115),^(.4032),^(.404),^(.40415),^(.4044),^(.404421),^(1.2) "RTN","TMGINIT",159,0) K ^DIC(.403),^(.404),^(1.2) "RTN","TMGINIT",160,0) K ^DD(.44),^(.441),^(.4411),^(.447),^(.448),^(.411),^(.42),^(.81),^DIC(.44),^(.81) "RTN","TMGINIT",161,0) F I=.2,.4,.401,.402,.5,.6,.83,1.1,1.11,1.12,1.13 K ^DIC(I,"%D") "RTN","TMGINIT",162,0) K ^DIC(.46),^DD(.46),^(.461),^(.463) "RTN","TMGINIT",163,0) K ^DIC(.11),^(.31) F I=.11,.111,.112,.114,.31,.312 K ^DD(I) "RTN","TMGINIT",164,0) F I=1.521,1.52101,1.5211,1.5212,1.5213,1.5214,1.5215,1.5216,1.5217,1.5218,1.5219,1.52191,1.52192 K ^DIC(I),^DD(I) "RTN","TMGINIT",165,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBINDENT,"Leaving OSETC^TMGINIT--via GOTO ^DINITOFO") "RTN","TMGINIT",166,0) G ^DINIT0F0 "RTN","TMGINIT",167,0) ; "RTN","TMGINIT",168,0) ;"============================================================================= "RTN","TMGINIT",169,0) "RTN","TMGINIT",170,0) OSETC ;BRING IN MUMPS OS, DIALOG & LANGUAGE DD AND DATA FOR FILEMAN "RTN","TMGINIT",171,0) "RTN","TMGINIT",172,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBINDENT,"Starting: OSETC^TMGINIT") "RTN","TMGINIT",173,0) "RTN","TMGINIT",174,0) N DN,R,D,DDF,DDT,DTO,DFR,DFN,DTN,DMRG,I,Z,D0 "RTN","TMGINIT",175,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","Now loading MUMPS Operating System File") "RTN","TMGINIT",176,0) D ^DINIT21 "RTN","TMGINIT",177,0) D OSDD^DINIT24 "RTN","TMGINIT",178,0) S ^DIC(.7,0)="MUMPS OPERATING SYSTEM^.7" "RTN","TMGINIT",179,0) S ^(0,"GL")="^DD(""OS""," "RTN","TMGINIT",180,0) D A^DINIT3 "RTN","TMGINIT",181,0) S ^DIC(.7,"%D",0)="^^5^5^2940908^" "RTN","TMGINIT",182,0) S ^DIC(.7,"%D",1,0)="This file stores operating system-specific code. Since the code to invoke" "RTN","TMGINIT",183,0) S ^DIC(.7,"%D",2,0)="some operating system utilities that FileMan uses varies among operating" "RTN","TMGINIT",184,0) S ^DIC(.7,"%D",3,0)="systems, code to perform these utilities is stored in and executed from" "RTN","TMGINIT",185,0) S ^DIC(.7,"%D",4,0)="this file. During the FileMan INIT process an operating system is" "RTN","TMGINIT",186,0) S ^DIC(.7,"%D",5,0)="selected so that FileMan knows which entry to use from this file." "RTN","TMGINIT",187,0) K ^DD("OS","B"),DA,DIK "RTN","TMGINIT",188,0) S DA(1)=.7 "RTN","TMGINIT",189,0) S DIK="^DD(.7," "RTN","TMGINIT",190,0) D X^DINIT3 "RTN","TMGINIT",191,0) K DA,DIK "RTN","TMGINIT",192,0) S DIK="^DD(""OS""," "RTN","TMGINIT",193,0) D X^DINIT3 "RTN","TMGINIT",194,0) D "RTN","TMGINIT",195,0) . N I,DA,DIK "RTN","TMGINIT",196,0) . F I=1,2,3,4,5,6,7,10,11,12,13,14,15 S DA=I,DIK="^DD(""OS""," D ^DIK "RTN","TMGINIT",197,0) . Q "RTN","TMGINIT",198,0) ; "RTN","TMGINIT",199,0) K ^UTILITY(U,$J) "RTN","TMGINIT",200,0) K ^UTILITY("DIK",$J) "RTN","TMGINIT",201,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","Now loading DIALOG and LANGUAGE Files") "RTN","TMGINIT",202,0) S DN="^DINIT" F R=1:1:39 D @(DN_$$B36(R)) W "." "RTN","TMGINIT",203,0) S $P(^DIC(.84,0),U,1,2)="DIALOG^.84" "RTN","TMGINIT",204,0) S $P(^DI(.84,0),U,1,2)="DIALOG^.84I" "RTN","TMGINIT",205,0) I $D(^DIC(.84,0,"GL")) D A1^DINIT3 "RTN","TMGINIT",206,0) S $P(^DIC(.85,0),U,1,2)="LANGUAGE^.85" "RTN","TMGINIT",207,0) S $P(^DI(.85,0),U,1,2)="LANGUAGE^.85I" "RTN","TMGINIT",208,0) I $D(^DIC(.85,0,"GL")) D A1^DINIT3 "RTN","TMGINIT",209,0) F I=.84,.841,.842,.844,.845,.847,.8471,.85 D XX^DINIT3 "RTN","TMGINIT",210,0) D DATA "RTN","TMGINIT",211,0) "RTN","TMGINIT",212,0) OSETCQ "RTN","TMGINIT",213,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"OSETC^TMGINIT") "RTN","TMGINIT",214,0) Q "RTN","TMGINIT",215,0) ; "RTN","TMGINIT",216,0) ;"============================================================================= "RTN","TMGINIT",217,0) DATA "RTN","TMGINIT",218,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"DATA^TMGINIT") "RTN","TMGINIT",219,0) "RTN","TMGINIT",220,0) DO OUTP^TMGQIO(SILNTOUT,".") "RTN","TMGINIT",221,0) S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) "RTN","TMGINIT",222,0) GOTO:D'>0 DATAQ "RTN","TMGINIT",223,0) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0 "RTN","TMGINIT",224,0) S DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=0 "RTN","TMGINIT",225,0) F D0=0:0 DO GOTO:'$D(^(D0,0)) DATAQ "RTN","TMGINIT",226,0) . S D0=$O(^UTILITY(U,$J,DDF(1),D0)) "RTN","TMGINIT",227,0) . S:D0="" D0=-1 "RTN","TMGINIT",228,0) . Q:'$D(^(D0,0)) "RTN","TMGINIT",229,0) . S Z=^(0) "RTN","TMGINIT",230,0) . D I^DITR "RTN","TMGINIT",231,0) K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN "RTN","TMGINIT",232,0) G DATA "RTN","TMGINIT",233,0) DATAQ "RTN","TMGINIT",234,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"DATA^TMGINIT") "RTN","TMGINIT",235,0) QUIT "RTN","TMGINIT",236,0) ; "RTN","TMGINIT",237,0) ;"============================================================================= "RTN","TMGINIT",238,0) B36(X) Q $$N1(X\(36*36)#36+1)_$$N1(X\36#36+1)_$$N1(X#36+1) "RTN","TMGINIT",239,0) N1(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) "RTN","TMGINIT",240,0) "RTN","TMGINIT",241,0) ;"===================================================================================== "RTN","TMGIOUTL") 0^27^B7057 "RTN","TMGIOUTL",1,0) TMGIOUTL ;TMG/kst/IO Utilities ;03/25/06 "RTN","TMGIOUTL",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGIOUTL",3,0) "RTN","TMGIOUTL",4,0) ;"TMG IO UTILITIES "RTN","TMGIOUTL",5,0) ;"Kevin Toppenberg MD "RTN","TMGIOUTL",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGIOUTL",7,0) ;"7-12-2005 "RTN","TMGIOUTL",8,0) "RTN","TMGIOUTL",9,0) ;"======================================================================= "RTN","TMGIOUTL",10,0) ;" API -- Public Functions. "RTN","TMGIOUTL",11,0) ;"======================================================================= "RTN","TMGIOUTL",12,0) ;"$$FNameExtract^TMGIOUTL(FullNamePath,NodeDiv) "RTN","TMGIOUTL",13,0) ;"$$PathExtract^TMGIOUTL(FullNamePath,NodeDiv) "RTN","TMGIOUTL",14,0) ;"SplitFNamePath^TMGIOUTL(FullNamePath,OutName,OutPath,NodeDiv) "RTN","TMGIOUTL",15,0) ;"$$GetFName^TMGIOUTL(Msg,DefPath,DefFName,NodeDiv,OutPath,OutName) "RTN","TMGIOUTL",16,0) ;"$$IsDir^TMGIOUTL(Path) ;DEPRECIATED .. moved to ^TMGKERNL "RTN","TMGIOUTL",17,0) ;"$$Move^TMGIOUTL(Source,Dest) ;DEPRECIATED .. moved to ^TMGKERNL "RTN","TMGIOUTL",18,0) ;"$$FileExists^TMGIOUTL(FullNamePath) "RTN","TMGIOUTL",19,0) ;"$$Dos2Unix^TMGIOUTL(FullNamePath) ;DEPRECIATED .. moved to ^TMGKERNL "RTN","TMGIOUTL",20,0) ;"$$WP2HFS^TMGIOUTL(GlobalP,path,filename) "RTN","TMGIOUTL",21,0) ;"$$WP2HFSfp^TMGIOUTL(GlobalP,pathfilename) "RTN","TMGIOUTL",22,0) ;"$$HFS2WP^TMGIOUTL(path,filename,GlobalP) "RTN","TMGIOUTL",23,0) ;"$$HFS2WPfp^TMGIOUTL(pathfilename,GlobalP) "RTN","TMGIOUTL",24,0) ;"$$DelFile^TMGIOUTL(pathfilename) "RTN","TMGIOUTL",25,0) ;"$$EnsureTrailDiv^TMGIOUTL(path) "RTN","TMGIOUTL",26,0) "RTN","TMGIOUTL",27,0) ;"======================================================================= "RTN","TMGIOUTL",28,0) ;"Dependancies "RTN","TMGIOUTL",29,0) ;"TMGUSRIF for showing dialogs. "RTN","TMGIOUTL",30,0) ;"TMGDEBUG "RTN","TMGIOUTL",31,0) ;"TMGSTUTL "RTN","TMGIOUTL",32,0) ;"TMGMISC "RTN","TMGIOUTL",33,0) ;"======================================================================= "RTN","TMGIOUTL",34,0) "RTN","TMGIOUTL",35,0) ;"======================================================================= "RTN","TMGIOUTL",36,0) "RTN","TMGIOUTL",37,0) FNameExtract(FullNamePath,NodeDiv) "RTN","TMGIOUTL",38,0) ;"SCOPE: Public "RTN","TMGIOUTL",39,0) ;"Purpose: to extract a file name from a full path+name string "RTN","TMGIOUTL",40,0) ;"Input: FullNamePath: String to process. "RTN","TMGIOUTL",41,0) ;" e.g.: "/tmp/myfilename.txt" "RTN","TMGIOUTL",42,0) ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") "RTN","TMGIOUTL",43,0) ;" if not supplied, then default value is "/" "RTN","TMGIOUTL",44,0) ;"Result: the filename, or "" if not found "RTN","TMGIOUTL",45,0) ;" e.g.: "myfilename.txt" "RTN","TMGIOUTL",46,0) "RTN","TMGIOUTL",47,0) new OutPath,OutName "RTN","TMGIOUTL",48,0) do SplitFNamePath(.FullNamePath,.OutPath,.OutName,.NodeDiv) "RTN","TMGIOUTL",49,0) quit $get(OutName) "RTN","TMGIOUTL",50,0) "RTN","TMGIOUTL",51,0) "RTN","TMGIOUTL",52,0) PathExtract(FullNamePath,NodeDiv) "RTN","TMGIOUTL",53,0) ;"SCOPE: Public "RTN","TMGIOUTL",54,0) ;"Purpose: to extract a file name from a full path+name string "RTN","TMGIOUTL",55,0) ;"Input: FullNamePath: String to process. "RTN","TMGIOUTL",56,0) ;" e.g.: "/usr/local/myfilename.txt" "RTN","TMGIOUTL",57,0) ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") "RTN","TMGIOUTL",58,0) ;" if not supplied, then default value is "/" "RTN","TMGIOUTL",59,0) ;"Result: the path, or "" if not found "RTN","TMGIOUTL",60,0) ;" e.g.: "/usr/local/" "RTN","TMGIOUTL",61,0) "RTN","TMGIOUTL",62,0) new OutPath,OutName "RTN","TMGIOUTL",63,0) do SplitFNamePath(.FullNamePath,.OutPath,.OutName,.NodeDiv) "RTN","TMGIOUTL",64,0) quit $get(OutPath) "RTN","TMGIOUTL",65,0) "RTN","TMGIOUTL",66,0) "RTN","TMGIOUTL",67,0) SplitFNamePath(FullNamePath,OutPath,OutName,NodeDiv) "RTN","TMGIOUTL",68,0) ;"SCOPE: Public "RTN","TMGIOUTL",69,0) ;"Purpose: Take FullNamePath, and split into name and path. "RTN","TMGIOUTL",70,0) ;"Input: FullNamePath: String to process. "RTN","TMGIOUTL",71,0) ;" e.g.: "/tmp/myfilename.txt" "RTN","TMGIOUTL",72,0) ;" NOTICE: IF PASSED BY REFERENCE, WILL BE CHANGED TO FILENAME! "RTN","TMGIOUTL",73,0) ;" OutName: MUST BE PASSED BY REFERENCE. This is an OUT parameter "RTN","TMGIOUTL",74,0) ;" OutPath: MUST BE PASSED BY REFERENCE. This is an OUT parameter "RTN","TMGIOUTL",75,0) ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") "RTN","TMGIOUTL",76,0) ;" if not supplied, then default value is "/" "RTN","TMGIOUTL",77,0) ;"Output: The resulting file name is put into OutName, "RTN","TMGIOUTL",78,0) ;" e.g.: "myfilename.txt" "RTN","TMGIOUTL",79,0) ;" and the path is put into OutPath. "RTN","TMGIOUTL",80,0) ;" e.g.: "/tmp/" "RTN","TMGIOUTL",81,0) ;"Result: None. "RTN","TMGIOUTL",82,0) "RTN","TMGIOUTL",83,0) set OutPath="" "RTN","TMGIOUTL",84,0) set OutName="" "RTN","TMGIOUTL",85,0) new PathNode "RTN","TMGIOUTL",86,0) set NodeDiv=$get(NodeDiv,"/") "RTN","TMGIOUTL",87,0) set FullNamePath=$get(FullNamePath) "RTN","TMGIOUTL",88,0) SPN1 "RTN","TMGIOUTL",89,0) if (FullNamePath[NodeDiv)=0 set OutName=FullNamePath goto SPNDone "RTN","TMGIOUTL",90,0) set PathNode=$piece(FullNamePath,NodeDiv,1) "RTN","TMGIOUTL",91,0) set OutPath=OutPath_PathNode_NodeDiv "RTN","TMGIOUTL",92,0) set $piece(FullNamePath,NodeDiv,1)="" "RTN","TMGIOUTL",93,0) set FullNamePath=$extract(FullNamePath,2,255) "RTN","TMGIOUTL",94,0) goto SPN1 "RTN","TMGIOUTL",95,0) "RTN","TMGIOUTL",96,0) SPNDone "RTN","TMGIOUTL",97,0) quit "RTN","TMGIOUTL",98,0) "RTN","TMGIOUTL",99,0) "RTN","TMGIOUTL",100,0) GetFName(Msg,DefPath,DefFName,NodeDiv,OutPath,OutName,Prompt) "RTN","TMGIOUTL",101,0) ;"SCOPE: PUBLIC "RTN","TMGIOUTL",102,0) ;"Purpose: To query the user, to get a filename back "RTN","TMGIOUTL",103,0) ;" Supplies optional directory listing. "RTN","TMGIOUTL",104,0) ;"Input: Msg. [OPTIONAL] A message to show user prior to name prompt. "RTN","TMGIOUTL",105,0) ;" May contain "\n" character for line wrapping. "RTN","TMGIOUTL",106,0) ;" DefPath: [OPTIONAL] The default path to offer user. "RTN","TMGIOUTL",107,0) ;" DefFName:[OPTIONAL] The default filename to offer user. "RTN","TMGIOUTL",108,0) ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") "RTN","TMGIOUTL",109,0) ;" if not supplied, then default value is "/" "RTN","TMGIOUTL",110,0) ;" OutPath: [OPTIONAL] Pass by reference, filled with selected path "RTN","TMGIOUTL",111,0) ;" //no --> Note: Will return like this: '/home/test' not '/home/test/' "RTN","TMGIOUTL",112,0) ;" (6-5-05: I think this because $$FTG^%ZISH wants the path like this) "RTN","TMGIOUTL",113,0) ;" OutName: [OPTIONAL] Pass by reference, filled with selected name "RTN","TMGIOUTL",114,0) ;" Prompt: [OPTIONAL] Prompt for user to enter filename/directory name "RTN","TMGIOUTL",115,0) ;"Result: returns user specified filename (with path), or "" if aborted "RTN","TMGIOUTL",116,0) "RTN","TMGIOUTL",117,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFName^TMGIOUTL") "RTN","TMGIOUTL",118,0) "RTN","TMGIOUTL",119,0) set Prompt=$get(Prompt,"Enter File Name (? for help): ") "RTN","TMGIOUTL",120,0) if $data(Msg) do "RTN","TMGIOUTL",121,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling PopupBox") "RTN","TMGIOUTL",122,0) . do PopupBox^TMGUSRIF("Message:",.Msg) "RTN","TMGIOUTL",123,0) "RTN","TMGIOUTL",124,0) set DefFName=$get(DefFName) "RTN","TMGIOUTL",125,0) if $get(NodeDiv)="" kill NodeDiv "RTN","TMGIOUTL",126,0) set NodeDiv=$get(NodeDiv,"/") "RTN","TMGIOUTL",127,0) set DefPath=$get(DefPath,NodeDiv) "RTN","TMGIOUTL",128,0) set OutPath=$get(OutPath) "RTN","TMGIOUTL",129,0) set OutName=$get(OutName) "RTN","TMGIOUTL",130,0) new UserName "RTN","TMGIOUTL",131,0) new result set result="" "RTN","TMGIOUTL",132,0) new loop set loop=0 "RTN","TMGIOUTL",133,0) "RTN","TMGIOUTL",134,0) if $$IsDir(DefPath)=0 do "RTN","TMGIOUTL",135,0) . ;"write "Default directory ["_DefPath_"] doesn't exist.",! "RTN","TMGIOUTL",136,0) . set DefPath=NodeDiv "RTN","TMGIOUTL",137,0) "RTN","TMGIOUTL",138,0) GFN1 "RTN","TMGIOUTL",139,0) write Prompt ;"hello "RTN","TMGIOUTL",140,0) if $extract(DefPath,$length(DefPath))'=NodeDiv do "RTN","TMGIOUTL",141,0) . set DefPath=DefPath_NodeDiv "RTN","TMGIOUTL",142,0) write DefPath_DefFName,"" "RTN","TMGIOUTL",143,0) set UserName=$$Read^TMGUSRIF("rt",$get(DTIME,3600),,DefPath_DefFName) "RTN","TMGIOUTL",144,0) write ! "RTN","TMGIOUTL",145,0) ;"read UserName:$get(DTIME,3600),! "RTN","TMGIOUTL",146,0) set UserName=$$Trim^TMGSTUTL(UserName) "RTN","TMGIOUTL",147,0) "RTN","TMGIOUTL",148,0) if (UserName["..") do goto GFN1 "RTN","TMGIOUTL",149,0) . new temp1 "RTN","TMGIOUTL",150,0) . ;"anything missing on this line? Was blank... "RTN","TMGIOUTL",151,0) . if ($extract(DefPath,$length(DefPath))=NodeDiv)&(DefPath'="/") do "RTN","TMGIOUTL",152,0) . set DefPath=$extract(DefPath,1,$length(DefPath)-1) "RTN","TMGIOUTL",153,0) . do SplitFNamePath(DefPath,.DefPath,.temp,1) "RTN","TMGIOUTL",154,0) else if UserName="" do goto GFNDone "RTN","TMGIOUTL",155,0) . set OutPath=DefPath "RTN","TMGIOUTL",156,0) . set OutName=DefFName "RTN","TMGIOUTL",157,0) . set result=DefPath_DefFName "RTN","TMGIOUTL",158,0) else if ($$UP^XLFSTR(UserName)["??") do goto GFN1 "RTN","TMGIOUTL",159,0) . new TMGMask,UserMask "RTN","TMGIOUTL",160,0) . set UserMask=$piece(UserName,"?? ",2) "RTN","TMGIOUTL",161,0) . if UserMask="" set UserMask=$piece(UserName,"?? ",2) "RTN","TMGIOUTL",162,0) . if UserMask="" set UserMask="*" "RTN","TMGIOUTL",163,0) . set TMGMask(UserMask)="" "RTN","TMGIOUTL",164,0) . new TMGFiles "RTN","TMGIOUTL",165,0) . if $$IsDir(DefPath)=0 write "?? invalid directory",! quit "RTN","TMGIOUTL",166,0) . if $$LIST^%ZISH(DefPath,"TMGMask","TMGFiles")=1 do "RTN","TMGIOUTL",167,0) . . write "Directory Listing",! "RTN","TMGIOUTL",168,0) . . write "-----------------",! "RTN","TMGIOUTL",169,0) . . new col set col=3 "RTN","TMGIOUTL",170,0) . . new index set index="" "RTN","TMGIOUTL",171,0) . . for set index=$order(TMGFiles(index)) quit:(index)="" do "RTN","TMGIOUTL",172,0) . . . set col=(col+1)#4 "RTN","TMGIOUTL",173,0) . . . write ?(col*20)+1 "RTN","TMGIOUTL",174,0) . . . new testDir set testDir=$$EnsureTrailDiv(DefPath,NodeDiv) "RTN","TMGIOUTL",175,0) . . . set testDir=testDir_index "RTN","TMGIOUTL",176,0) . . . if $$IsDir(testDir) write "<",index,">" "RTN","TMGIOUTL",177,0) . . . else write index "RTN","TMGIOUTL",178,0) . . . if col=3 write ! "RTN","TMGIOUTL",179,0) . . write ! "RTN","TMGIOUTL",180,0) else if UserName["^" do goto GFNDone "RTN","TMGIOUTL",181,0) . set result="" "RTN","TMGIOUTL",182,0) . set OutPath="" "RTN","TMGIOUTL",183,0) . set OutName="" "RTN","TMGIOUTL",184,0) else if UserName["?" do goto GFN1 "RTN","TMGIOUTL",185,0) . write " Current directory: [",DefPath,"]",! "RTN","TMGIOUTL",186,0) . write " Default file name: [",DefFName,"]",! "RTN","TMGIOUTL",187,0) . write " Example input: ",NodeDiv,"Data",NodeDiv,"Office",NodeDiv,"myfile.txt",! "RTN","TMGIOUTL",188,0) . write " DELETE (with backspace) parts of path not wanted.",! "RTN","TMGIOUTL",189,0) . write " Enter ^ to abort",! "RTN","TMGIOUTL",190,0) . write " Enter ?? for directory listing (?? a* to show files starting with a)",! "RTN","TMGIOUTL",191,0) . write " Enter .. to move up one directory level",! "RTN","TMGIOUTL",192,0) . write " NOTE: If a partial name is entered then [ENTER], it will be autofinished.",! "RTN","TMGIOUTL",193,0) else if $extract(UserName,$length(UserName))=NodeDiv do goto GFN1 "RTN","TMGIOUTL",194,0) . new tempPath set tempPath=DefPath "RTN","TMGIOUTL",195,0) . if $extract(UserName,1,1)=NodeDiv set DefPath="" "RTN","TMGIOUTL",196,0) . if $$IsDir(DefPath_UserName) set DefPath=DefPath_UserName "RTN","TMGIOUTL",197,0) . else write "?? invalid directory",! set DefPath=tempPath "RTN","TMGIOUTL",198,0) else for do quit:(loop'=1) "RTN","TMGIOUTL",199,0) . if loop=0 do "RTN","TMGIOUTL",200,0) . . if $extract(UserName,1,1)=NodeDiv do SplitFNamePath(UserName,.DefPath,.UserName) "RTN","TMGIOUTL",201,0) . . set OutPath=DefPath "RTN","TMGIOUTL",202,0) . . set OutName=UserName "RTN","TMGIOUTL",203,0) . . set result=OutPath_OutName "RTN","TMGIOUTL",204,0) . else set loop=0 "RTN","TMGIOUTL",205,0) . if $$IsDir(result) do quit "RTN","TMGIOUTL",206,0) . . set DefPath=result "RTN","TMGIOUTL",207,0) . . set DefName="" "RTN","TMGIOUTL",208,0) . . set result="" "RTN","TMGIOUTL",209,0) . . do CUU^TMGTERM(1) ;"cursor up 1 VT100 esc sequence. "RTN","TMGIOUTL",210,0) . if result["*" do "RTN","TMGIOUTL",211,0) . . set result=$$PickOneFile(result) "RTN","TMGIOUTL",212,0) . if '$$FileExists(result) do "RTN","TMGIOUTL",213,0) . . new tempresult set tempresult=result "RTN","TMGIOUTL",214,0) . . set result=$$PickOneFile(result_"*") "RTN","TMGIOUTL",215,0) . . if result="^" set loop=0 quit "RTN","TMGIOUTL",216,0) . . if result'="" set loop=1 quit "RTN","TMGIOUTL",217,0) . . new UseAnyway "RTN","TMGIOUTL",218,0) . . write !,"File name """,tempresult,""" doesn't exist.",! "RTN","TMGIOUTL",219,0) . . read "Use name anyway? NO// ",UseAnyway:$get(DTIME,3600),! "RTN","TMGIOUTL",220,0) . . set UseAnyway=$$UP^XLFSTR(UseAnyway) "RTN","TMGIOUTL",221,0) . . if '(UseAnyway["Y") set result="" "RTN","TMGIOUTL",222,0) . . else set result=tempresult "RTN","TMGIOUTL",223,0) "RTN","TMGIOUTL",224,0) if result="" goto GFN1 "RTN","TMGIOUTL",225,0) "RTN","TMGIOUTL",226,0) GFNDone "RTN","TMGIOUTL",227,0) "RTN","TMGIOUTL",228,0) if (result'=UserName)&(UserName'="^") do "RTN","TMGIOUTL",229,0) . write "Using file: ",result,! "RTN","TMGIOUTL",230,0) "RTN","TMGIOUTL",231,0) ;"Take off any terminal '/' from path "RTN","TMGIOUTL",232,0) ;"if $extract(OutPath,$length(OutPath))=NodeDiv do "RTN","TMGIOUTL",233,0) ;". set OutPath=$extract(OutPath,1,$length(OutPath)-1) "RTN","TMGIOUTL",234,0) "RTN","TMGIOUTL",235,0) do SplitFNamePath(result,.OutPath,.OutName,NodeDiv) "RTN","TMGIOUTL",236,0) "RTN","TMGIOUTL",237,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFName^TMGIOUTL") "RTN","TMGIOUTL",238,0) "RTN","TMGIOUTL",239,0) quit result "RTN","TMGIOUTL",240,0) "RTN","TMGIOUTL",241,0) "RTN","TMGIOUTL",242,0) GetDirName(Msg,DefPath,NodeDiv,OutPath,Prompt) "RTN","TMGIOUTL",243,0) "RTN","TMGIOUTL",244,0) ;" **** finish later -- maybe... Not currently in use. "RTN","TMGIOUTL",245,0) "RTN","TMGIOUTL",246,0) ;"SCOPE: PUBLIC "RTN","TMGIOUTL",247,0) ;"Purpose: To query the user, to get a directory name back "RTN","TMGIOUTL",248,0) ;" Supplies optional directory listing. "RTN","TMGIOUTL",249,0) ;"Input: Msg. [OPTIONAL] A message to show user prior to name prompt. "RTN","TMGIOUTL",250,0) ;" May contain "\n" character for line wrapping. "RTN","TMGIOUTL",251,0) ;" DefPath: [OPTIONAL] The default path to offer user. "RTN","TMGIOUTL",252,0) ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") "RTN","TMGIOUTL",253,0) ;" if not supplied, then default value is "/" "RTN","TMGIOUTL",254,0) ;" OutPath: [OPTIONAL] Pass by reference, filled with selected path "RTN","TMGIOUTL",255,0) ;" //no --> Note: Will return like this: '/home/test' not '/home/test/' "RTN","TMGIOUTL",256,0) ;" (6-5-05: I think this because $$FTG^%ZISH wants the path like this) "RTN","TMGIOUTL",257,0) ;" Prompt: [OPTIONAL] Prompt for user to enter filename/directory name "RTN","TMGIOUTL",258,0) ;"Result: returns user specified filename (with path), or "" if aborted "RTN","TMGIOUTL",259,0) "RTN","TMGIOUTL",260,0) "RTN","TMGIOUTL",261,0) set Prompt=$get(Prompt,"Enter Directory Name (? for help): ") "RTN","TMGIOUTL",262,0) if $data(Msg) do PopupBox^TMGUSRIF("Message:",.Msg) "RTN","TMGIOUTL",263,0) "RTN","TMGIOUTL",264,0) set DefFName=$get(DefFName) "RTN","TMGIOUTL",265,0) if $get(NodeDiv)="" kill NodeDiv "RTN","TMGIOUTL",266,0) set NodeDiv=$get(NodeDiv,"/") "RTN","TMGIOUTL",267,0) set DefPath=$get(DefPath,NodeDiv) "RTN","TMGIOUTL",268,0) set OutPath=$get(OutPath) "RTN","TMGIOUTL",269,0) set OutName=$get(OutName) "RTN","TMGIOUTL",270,0) new UserName "RTN","TMGIOUTL",271,0) new result set result="" "RTN","TMGIOUTL",272,0) new loop set loop=0 "RTN","TMGIOUTL",273,0) "RTN","TMGIOUTL",274,0) if $$IsDir(DefPath)=0 set DefPath=NodeDiv "RTN","TMGIOUTL",275,0) "RTN","TMGIOUTL",276,0) GDN1 write Prompt ;"hi "RTN","TMGIOUTL",277,0) if $extract(DefPath,$length(DefPath))'=NodeDiv do "RTN","TMGIOUTL",278,0) . set DefPath=DefPath_NodeDiv "RTN","TMGIOUTL",279,0) write DefPath_DefFName,"" "RTN","TMGIOUTL",280,0) read UserName:$get(DTIME,3600),! "RTN","TMGIOUTL",281,0) set UserName=$$Trim^TMGSTUTL(UserName) "RTN","TMGIOUTL",282,0) "RTN","TMGIOUTL",283,0) if (UserName="..") do goto GDN1 "RTN","TMGIOUTL",284,0) . new temp1 "RTN","TMGIOUTL",285,0) . ;"anything missing on this line? Was blank... "RTN","TMGIOUTL",286,0) . if ($extract(DefPath,$length(DefPath))=NodeDiv)&(DefPath'="/") do "RTN","TMGIOUTL",287,0) . . set DefPath=$extract(DefPath,1,$length(DefPath)-1) "RTN","TMGIOUTL",288,0) . do SplitFNamePath(DefPath,.DefPath,.temp,1) "RTN","TMGIOUTL",289,0) else if UserName="" do goto GFN2Done "RTN","TMGIOUTL",290,0) . set OutPath=DefPath "RTN","TMGIOUTL",291,0) . set OutName=DefFName "RTN","TMGIOUTL",292,0) . set result=DefPath_DefFName "RTN","TMGIOUTL",293,0) else if ($$UP^XLFSTR(UserName)["??") do goto GDN1 "RTN","TMGIOUTL",294,0) . new TMGMask,UserMask "RTN","TMGIOUTL",295,0) . set UserMask=$piece(UserName,"?? ",2) "RTN","TMGIOUTL",296,0) . if UserMask="" set UserMask=$piece(UserName,"?? ",2) "RTN","TMGIOUTL",297,0) . if UserMask="" set UserMask="*" "RTN","TMGIOUTL",298,0) . set TMGMask(UserMask)="" "RTN","TMGIOUTL",299,0) . new TMGFiles "RTN","TMGIOUTL",300,0) . if $$IsDir(DefPath)=0 write "?? invalid directory",! quit "RTN","TMGIOUTL",301,0) . if $$LIST^%ZISH(DefPath,"TMGMask","TMGFiles")=1 do "RTN","TMGIOUTL",302,0) . . write "Directory Listing",! "RTN","TMGIOUTL",303,0) . . write "-----------------",! "RTN","TMGIOUTL",304,0) . . new index set index=$order(TMGFiles("")) "RTN","TMGIOUTL",305,0) . . for do quit:index="" "RTN","TMGIOUTL",306,0) . . . if index="" quit "RTN","TMGIOUTL",307,0) . . . write " ",index,! "RTN","TMGIOUTL",308,0) . . . set index=$order(TMGFiles(index)) "RTN","TMGIOUTL",309,0) else if UserName="^" do goto GFN2Done "RTN","TMGIOUTL",310,0) . set result="" "RTN","TMGIOUTL",311,0) . set OutPath="" "RTN","TMGIOUTL",312,0) . set OutName="" "RTN","TMGIOUTL",313,0) else if UserName["?" do goto GDN1 "RTN","TMGIOUTL",314,0) . write " Current directory: [",DefPath,"]",! "RTN","TMGIOUTL",315,0) . write " Default file name: [",DefFName,"]",! "RTN","TMGIOUTL",316,0) . write " Example input: ",NodeDiv,"Data",NodeDiv,"Office",NodeDiv,"myfile.txt",! "RTN","TMGIOUTL",317,0) . write " Enter ^ to abort",! "RTN","TMGIOUTL",318,0) . write " Enter ?? for directory listing (?? a* to show files starting with a)",! "RTN","TMGIOUTL",319,0) . write " Enter .. to move up one directory level",! "RTN","TMGIOUTL",320,0) else if $extract(UserName,$length(UserName))=NodeDiv do goto GDN1 "RTN","TMGIOUTL",321,0) . new tempPath set tempPath=DefPath "RTN","TMGIOUTL",322,0) . if $extract(UserName,1,1)=NodeDiv set DefPath="" "RTN","TMGIOUTL",323,0) . if $$IsDir(DefPath_UserName) set DefPath=DefPath_UserName "RTN","TMGIOUTL",324,0) . else write "?? invalid directory",! set DefPath=tempPath "RTN","TMGIOUTL",325,0) else for do quit:(loop'=1) "RTN","TMGIOUTL",326,0) . if loop=0 do "RTN","TMGIOUTL",327,0) . . if $extract(UserName,1,1)=NodeDiv do SplitFNamePath(UserName,.DefPath,.UserName) "RTN","TMGIOUTL",328,0) . . set OutPath=DefPath "RTN","TMGIOUTL",329,0) . . set OutName=UserName "RTN","TMGIOUTL",330,0) . . set result=OutPath_OutName "RTN","TMGIOUTL",331,0) . else set loop=0 "RTN","TMGIOUTL",332,0) . if $$IsDir(result) do quit "RTN","TMGIOUTL",333,0) . . set DefPath=result "RTN","TMGIOUTL",334,0) . . set DefName="" "RTN","TMGIOUTL",335,0) . . set result="" "RTN","TMGIOUTL",336,0) . . do CUU^TMGTERM(1) ;"Cursor Up 1 VT100 escape code "RTN","TMGIOUTL",337,0) . if result["*" do "RTN","TMGIOUTL",338,0) . . set result=$$PickOneFile(result) "RTN","TMGIOUTL",339,0) . if '$$FileExists(result) do "RTN","TMGIOUTL",340,0) . . new tempresult set tempresult=result "RTN","TMGIOUTL",341,0) . . set result=$$PickOneFile(result_"*") "RTN","TMGIOUTL",342,0) . . if result="^" set loop=0 quit "RTN","TMGIOUTL",343,0) . . if result'="" set loop=1 quit "RTN","TMGIOUTL",344,0) . . new UseAnyway "RTN","TMGIOUTL",345,0) . . write !,"File name """,tempresult,""" doesn't exist.",! "RTN","TMGIOUTL",346,0) . . read "Use name anyway? NO// ",UseAnyway:$get(DTIME,3600),! "RTN","TMGIOUTL",347,0) . . set UseAnyway=$$UP^XLFSTR(UseAnyway) "RTN","TMGIOUTL",348,0) . . if '(UseAnyway["Y") set result="" "RTN","TMGIOUTL",349,0) . . else set result=tempresult "RTN","TMGIOUTL",350,0) "RTN","TMGIOUTL",351,0) if result="" goto GDN1 "RTN","TMGIOUTL",352,0) "RTN","TMGIOUTL",353,0) GFN2Done "RTN","TMGIOUTL",354,0) "RTN","TMGIOUTL",355,0) if (result'=UserName)&(UserName'="^") do "RTN","TMGIOUTL",356,0) . write "Using file: ",result,! "RTN","TMGIOUTL",357,0) "RTN","TMGIOUTL",358,0) ;"Take off any terminal '/' from path "RTN","TMGIOUTL",359,0) ;"if $extract(OutPath,$length(OutPath))=NodeDiv do "RTN","TMGIOUTL",360,0) ;". set OutPath=$extract(OutPath,1,$length(OutPath)-1) "RTN","TMGIOUTL",361,0) "RTN","TMGIOUTL",362,0) do SplitFNamePath(result,.OutPath,.OutName,NodeDiv) "RTN","TMGIOUTL",363,0) "RTN","TMGIOUTL",364,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFName^TMGIOUTL") "RTN","TMGIOUTL",365,0) "RTN","TMGIOUTL",366,0) quit result "RTN","TMGIOUTL",367,0) "RTN","TMGIOUTL",368,0) "RTN","TMGIOUTL",369,0) IsDir(Path) "RTN","TMGIOUTL",370,0) ;"Purpose: To determine if Path is a path to a directory (i.e. are there sub files) "RTN","TMGIOUTL",371,0) ;"Input: Path to test, e.g. "/home/user" or "/home/user/" "RTN","TMGIOUTL",372,0) ;"Result: 1 if there are files in path, 0 otherwise "RTN","TMGIOUTL",373,0) ;"Note: if Path is a valid path to a directory, but there are no files in directory, 0 returned. "RTN","TMGIOUTL",374,0) "RTN","TMGIOUTL",375,0) "RTN","TMGIOUTL",376,0) ;"Moved to ^TMGKERNL "RTN","TMGIOUTL",377,0) quit $$IsDir^TMGKERNL(.Path) "RTN","TMGIOUTL",378,0) "RTN","TMGIOUTL",379,0) "RTN","TMGIOUTL",380,0) Move(Source,Dest) "RTN","TMGIOUTL",381,0) ;"Purpose to provide a shell for the Linux command 'mv' "RTN","TMGIOUTL",382,0) ;" This can serve to move or rename a file "RTN","TMGIOUTL",383,0) ;"Note: a platform independant version of the this could be constructed later... "RTN","TMGIOUTL",384,0) ;"Result: 0 if no error; >0 if error "RTN","TMGIOUTL",385,0) ;"Notice!!!! The return code here is DIFFERENT from usual "RTN","TMGIOUTL",386,0) "RTN","TMGIOUTL",387,0) ;"Moved to ^TMGKERNL "RTN","TMGIOUTL",388,0) quit $$Move^TMGKERNL(.Source,.Dest) "RTN","TMGIOUTL",389,0) "RTN","TMGIOUTL",390,0) "RTN","TMGIOUTL",391,0) FileExists(FullNamePath) "RTN","TMGIOUTL",392,0) ;"To determine if file exists. "RTN","TMGIOUTL",393,0) ;"Input: FullNamePath -- the full name and path of file to test, e.g. "/tmp/myfiles/a/test.txt" "RTN","TMGIOUTL",394,0) ;"Results: 1 if file exists (and is unique), 0 if not "RTN","TMGIOUTL",395,0) ;"Note: If FullNamePath indicates a directory, then 0 is returned. "RTN","TMGIOUTL",396,0) ;" Note if FullNamePath contains a * pattern, that would cause multiple "RTN","TMGIOUTL",397,0) ;" files to be returned, then filename is not unique, and function "RTN","TMGIOUTL",398,0) ;" will RETURN THAT IT IS NOT A (unique) FILE "RTN","TMGIOUTL",399,0) "RTN","TMGIOUTL",400,0) new JustName,JustPath "RTN","TMGIOUTL",401,0) new TMGMask "RTN","TMGIOUTL",402,0) new TMGFiles "RTN","TMGIOUTL",403,0) new result set result=0 "RTN","TMGIOUTL",404,0) "RTN","TMGIOUTL",405,0) do SplitFNamePath(FullNamePath,.JustPath,.JustName) "RTN","TMGIOUTL",406,0) "RTN","TMGIOUTL",407,0) set TMGMask(JustName)="" "RTN","TMGIOUTL",408,0) if $$LIST^%ZISH(JustPath,"TMGMask","TMGFiles")=1 do "RTN","TMGIOUTL",409,0) . if $$ListCt^TMGMISC("TMGFiles")=1 do "RTN","TMGIOUTL",410,0) . . set result='$$IsDir(FullNamePath) "RTN","TMGIOUTL",411,0) "RTN","TMGIOUTL",412,0) quit result "RTN","TMGIOUTL",413,0) "RTN","TMGIOUTL",414,0) "RTN","TMGIOUTL",415,0) PickOneFile(PartNamePath) "RTN","TMGIOUTL",416,0) ;"To take a name like "MyFil*", and display all matches and allow user to pick one "RTN","TMGIOUTL",417,0) ;"Input: PartNamePath -- the partial name and path of file to test, e.g. "/tmp/myfiles/a/tes*" "RTN","TMGIOUTL",418,0) ;"Results: The FullNamePath of the chosen file (or "" if none, or canceled) "RTN","TMGIOUTL",419,0) ;" 12-14-05, if user enters "^", this is returned. "RTN","TMGIOUTL",420,0) "RTN","TMGIOUTL",421,0) new JustName,JustPath "RTN","TMGIOUTL",422,0) new TMGMask "RTN","TMGIOUTL",423,0) new TMGFiles "RTN","TMGIOUTL",424,0) new result set result="" "RTN","TMGIOUTL",425,0) "RTN","TMGIOUTL",426,0) do SplitFNamePath(PartNamePath,.JustPath,.JustName) "RTN","TMGIOUTL",427,0) "RTN","TMGIOUTL",428,0) set TMGMask(JustName)="" "RTN","TMGIOUTL",429,0) if $$LIST^%ZISH(JustPath,"TMGMask","TMGFiles")=1 do "RTN","TMGIOUTL",430,0) . new count set count=$$ListCt^TMGMISC("TMGFiles") "RTN","TMGIOUTL",431,0) . if count=1 set result=$order(TMGFiles("")) quit "RTN","TMGIOUTL",432,0) . write count," matches to ",PartNamePath," found. Pick one:",! "RTN","TMGIOUTL",433,0) . new part,fName,Num "RTN","TMGIOUTL",434,0) . set fName=$order(TMGFiles("")) "RTN","TMGIOUTL",435,0) . set Num=1 "RTN","TMGIOUTL",436,0) . set part=1 "RTN","TMGIOUTL",437,0) . if fName'="" for do quit:(fName="")!(result="^") "RTN","TMGIOUTL",438,0) . . write " ",Num,". ",JustPath,fName "RTN","TMGIOUTL",439,0) . . if $$IsDir(JustPath_fName) write "/" "RTN","TMGIOUTL",440,0) . . write ! "RTN","TMGIOUTL",441,0) . . set TMGFiles(Num)=fName "RTN","TMGIOUTL",442,0) . . set fName=$order(TMGFiles(fName)) "RTN","TMGIOUTL",443,0) . . if (part=10)!(fName="") do "RTN","TMGIOUTL",444,0) . . . new choice "RTN","TMGIOUTL",445,0) . . . set part=1 "RTN","TMGIOUTL",446,0) . . . write "Choose file (1-",Num,"), '^' to cancel, or [Enter] to continue: " "RTN","TMGIOUTL",447,0) . . . read choice:$get(DTIME,3600),!! "RTN","TMGIOUTL",448,0) . . . if choice="^" set fName="",result="^" quit "RTN","TMGIOUTL",449,0) . . . if (+choice>0)&(+choice0 if error "RTN","TMGIOUTL",467,0) ;"Notice!!!! The return code here is DIFFERENT from usual "RTN","TMGIOUTL",468,0) "RTN","TMGIOUTL",469,0) ;"Moved to ^TMGKERNL "RTN","TMGIOUTL",470,0) quit $$Dos2Unix^TMGKERNL(FullNamePath) "RTN","TMGIOUTL",471,0) "RTN","TMGIOUTL",472,0) "RTN","TMGIOUTL",473,0) WP2HFS(GlobalP,path,filename) "RTN","TMGIOUTL",474,0) ;"Purpose: To write a WP field to a Host-File-System file "RTN","TMGIOUTL",475,0) ;"Input: GlobalP -- The reference to the header node (e.g. ^TMG(22702,99,1) in example below) "RTN","TMGIOUTL",476,0) ;" path: for the output file, the path up to, but not including, the filename "RTN","TMGIOUTL",477,0) ;" filename -- the filename to save to in the host file system. If file already exists, it will be overwritten. "RTN","TMGIOUTL",478,0) ;"Note: The format of a WP field is as follows: "RTN","TMGIOUTL",479,0) ;" e.g. ^TMG(22702,99,1,0) = ^^4^4^3050118^ "RTN","TMGIOUTL",480,0) ;" ^TMG(22702,99,1,1,0) = Here is the first line of text "RTN","TMGIOUTL",481,0) ;" ^TMG(22702,99,1,2,0) = And here is another line "RTN","TMGIOUTL",482,0) ;" ^TMG(22702,99,1,3,0) = "RTN","TMGIOUTL",483,0) ;" ^TMG(22702,99,1,4,0) = And here is a final line "RTN","TMGIOUTL",484,0) ;" And the format of the 0 node is: ^^^^^^ "RTN","TMGIOUTL",485,0) ;"Result: 0 if failure, 1 if success "RTN","TMGIOUTL",486,0) ;"Assumptions: That GlobalP is a valid reference to a WP field "RTN","TMGIOUTL",487,0) "RTN","TMGIOUTL",488,0) new result set result=0 ;"default to failure "RTN","TMGIOUTL",489,0) "RTN","TMGIOUTL",490,0) if $data(GlobalP)&($data(path))&($data(filename)) do "RTN","TMGIOUTL",491,0) . new TMGWP "RTN","TMGIOUTL",492,0) . merge TMGWP=@GlobalP "RTN","TMGIOUTL",493,0) . set result=$$GTF^%ZISH("TMGWP(1,0)",1,path,filename) "RTN","TMGIOUTL",494,0) "RTN","TMGIOUTL",495,0) quit result "RTN","TMGIOUTL",496,0) "RTN","TMGIOUTL",497,0) WP2HFSfp(GlobalP,pathfilename) "RTN","TMGIOUTL",498,0) ;"Purpose: To provide an interface to WP2HFS for cases when filename is not already separated from path "RTN","TMGIOUTL",499,0) ;"Result: 0 if failure, 1 if success "RTN","TMGIOUTL",500,0) "RTN","TMGIOUTL",501,0) new path,filename,result "RTN","TMGIOUTL",502,0) "RTN","TMGIOUTL",503,0) do SplitFNamePath(.pathfilename,.path,.filename) "RTN","TMGIOUTL",504,0) set result=$$WP2HFS(.GlobalP,.path,.filename) "RTN","TMGIOUTL",505,0) quit result "RTN","TMGIOUTL",506,0) "RTN","TMGIOUTL",507,0) "RTN","TMGIOUTL",508,0) HFS2WP(path,filename,GlobalP) "RTN","TMGIOUTL",509,0) ;"Purpose: To read a WP field from a Host-File-System file "RTN","TMGIOUTL",510,0) ;"Input: path: for the output file, the path up to, but not including, the filename "RTN","TMGIOUTL",511,0) ;" filename -- the filename to save to in the host file system. If file already exists, it will be overwritten. "RTN","TMGIOUTL",512,0) ;" GlobalP -- The reference to the header node (e.g. ^TMG(22702,99,1) in example below) "RTN","TMGIOUTL",513,0) ;"Note: The format of a WP field is as follows: "RTN","TMGIOUTL",514,0) ;" e.g. ^TMG(22702,99,1,0) = ^^4^4^3050118^ "RTN","TMGIOUTL",515,0) ;" ^TMG(22702,99,1,1,0) = Here is the first line of text "RTN","TMGIOUTL",516,0) ;" ^TMG(22702,99,1,2,0) = And here is another line "RTN","TMGIOUTL",517,0) ;" ^TMG(22702,99,1,3,0) = "RTN","TMGIOUTL",518,0) ;" ^TMG(22702,99,1,4,0) = And here is a final line "RTN","TMGIOUTL",519,0) ;" And the format of the 0 node is: ^^^^^^ "RTN","TMGIOUTL",520,0) ;"Result: 0 if failure, 1 if success "RTN","TMGIOUTL",521,0) ;"Assumptions: That GlobalP is a valid reference to a WP field "RTN","TMGIOUTL",522,0) "RTN","TMGIOUTL",523,0) new result set result=0 ;"default to failure "RTN","TMGIOUTL",524,0) "RTN","TMGIOUTL",525,0) if $data(GlobalP)&($data(path))&($data(filename)) do "RTN","TMGIOUTL",526,0) . new TMGWP,WP "RTN","TMGIOUTL",527,0) . set result=$$FTG^%ZISH(path,filename,"TMGWP(1,0)",1) "RTN","TMGIOUTL",528,0) . ;"zwr TMGWP(*) "RTN","TMGIOUTL",529,0) . ;"new temp read "press enter to continue",temp:$get(DTIME,3600),! "RTN","TMGIOUTL",530,0) . if result=0 quit "RTN","TMGIOUTL",531,0) . ;"Scan for overflow nodes, and integrate into main body "RTN","TMGIOUTL",532,0) . new i set i=$order(TMGWP("")) "RTN","TMGIOUTL",533,0) . if i'="" for do quit:(i="") "RTN","TMGIOUTL",534,0) . . if $data(TMGWP(i,"OVF")) do "RTN","TMGIOUTL",535,0) . . . new j set j=$order(TMGWP(i,"OVF","")) "RTN","TMGIOUTL",536,0) . . . if j'="" for do quit:(j="") "RTN","TMGIOUTL",537,0) . . . . new n set n=i+(j/10) "RTN","TMGIOUTL",538,0) . . . . set TMGWP(n,0)=TMGWP(i,"OVF",j) "RTN","TMGIOUTL",539,0) . . . . set j=$order(TMGWP(i,"OVF",j)) "RTN","TMGIOUTL",540,0) . . . kill TMGWP(i,"OVF") "RTN","TMGIOUTL",541,0) . . set i=$order(TMGWP(i)) "RTN","TMGIOUTL",542,0) . ;"Now copy into another variable, renumbering lines (in case there were overflow lines) "RTN","TMGIOUTL",543,0) . set i=$order(TMGWP("")) "RTN","TMGIOUTL",544,0) . set j=0 "RTN","TMGIOUTL",545,0) . if i'="" for do quit:(i="") "RTN","TMGIOUTL",546,0) . . set j=j+1 "RTN","TMGIOUTL",547,0) . . set WP(j,0)=TMGWP(i,0) "RTN","TMGIOUTL",548,0) . . set i=$order(TMGWP(i)) "RTN","TMGIOUTL",549,0) . ;"now create a header node "RTN","TMGIOUTL",550,0) . do NOW^%DTC ;"returns result in X "RTN","TMGIOUTL",551,0) . set WP(0)="^^"_j_"^"_j_"^"_X_"^^" "RTN","TMGIOUTL",552,0) . ;"now put WP into global reference. "RTN","TMGIOUTL",553,0) . ;"zwr WP(*) "RTN","TMGIOUTL",554,0) . ;"new temp read "press enter to continue",temp:$get(DTIME,3600),! "RTN","TMGIOUTL",555,0) . kill @GlobalP "RTN","TMGIOUTL",556,0) . merge @GlobalP=WP "RTN","TMGIOUTL",557,0) "RTN","TMGIOUTL",558,0) quit result "RTN","TMGIOUTL",559,0) "RTN","TMGIOUTL",560,0) "RTN","TMGIOUTL",561,0) HFS2WPfp(pathfilename,GlobalP) "RTN","TMGIOUTL",562,0) ;"Purpose: To provide an interface to HFS2WP for cases when filename is not already separated from path "RTN","TMGIOUTL",563,0) ;"Result: 0 if failure, 1 if success "RTN","TMGIOUTL",564,0) "RTN","TMGIOUTL",565,0) new path,filename,result "RTN","TMGIOUTL",566,0) "RTN","TMGIOUTL",567,0) do SplitFNamePath(.pathfilename,.path,.filename) "RTN","TMGIOUTL",568,0) set result=$$HFS2WP(.path,.filename,.GlobalP) "RTN","TMGIOUTL",569,0) quit result "RTN","TMGIOUTL",570,0) "RTN","TMGIOUTL",571,0) "RTN","TMGIOUTL",572,0) DelFile(pathfilename) "RTN","TMGIOUTL",573,0) ;"Purpose: to delete one file on host file system "RTN","TMGIOUTL",574,0) ;"Results: returns 1 if success, 0 if failure "RTN","TMGIOUTL",575,0) ;"Note: 2/22/2006 -- if deletion is blocked by OS, then 1 may be returns but file is not deleted. "RTN","TMGIOUTL",576,0) "RTN","TMGIOUTL",577,0) new path,filename,result "RTN","TMGIOUTL",578,0) new TMGFile "RTN","TMGIOUTL",579,0) "RTN","TMGIOUTL",580,0) do SplitFNamePath(.pathfilename,.path,.filename) "RTN","TMGIOUTL",581,0) set TMGFile(filename)="" "RTN","TMGIOUTL",582,0) set result=$$DEL^%ZISH(path,"TMGFile") "RTN","TMGIOUTL",583,0) "RTN","TMGIOUTL",584,0) quit result "RTN","TMGIOUTL",585,0) "RTN","TMGIOUTL",586,0) "RTN","TMGIOUTL",587,0) EnsureTrailDiv(Path,NodeDiv) "RTN","TMGIOUTL",588,0) ;"Purpose: to ensure that a path ends with a node divider. "RTN","TMGIOUTL",589,0) ;" e.g. /var/local --> /var/local/ "RTN","TMGIOUTL",590,0) ;" and /var/local/ --> /var/local/ "RTN","TMGIOUTL",591,0) ;"Input: Path -- the path to convert "RTN","TMGIOUTL",592,0) ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") "RTN","TMGIOUTL",593,0) ;" if not supplied, then default value is "/" "RTN","TMGIOUTL",594,0) "RTN","TMGIOUTL",595,0) set Path=$get(Path) "RTN","TMGIOUTL",596,0) set NodeDiv=$get(NodeDiv,"/") "RTN","TMGIOUTL",597,0) "RTN","TMGIOUTL",598,0) new result set result=Path "RTN","TMGIOUTL",599,0) if $extract(Path,$length(Path))'=NodeDiv do "RTN","TMGIOUTL",600,0) . set Path=Path_NodeDiv "RTN","TMGIOUTL",601,0) "RTN","TMGIOUTL",602,0) quit result "RTN","TMGIOUTL",603,0) "RTN","TMGIOUTL",604,0) "RTN","TMGITR") 0^28^B9486 "RTN","TMGITR",1,0) TMGITR ;TMG/kst/Array and Files Iterater code ;03/25/06 "RTN","TMGITR",2,0) ;;1.0;TMG-LIB;**1**;08/12/06 "RTN","TMGITR",3,0) "RTN","TMGITR",4,0) ;"TMG MISCELLANEOUS FUNCTIONS "RTN","TMGITR",5,0) ;"Kevin Toppenberg MD "RTN","TMGITR",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGITR",7,0) ;"8-12-06 "RTN","TMGITR",8,0) "RTN","TMGITR",9,0) ;"======================================================================= "RTN","TMGITR",10,0) ;" API -- Public Functions. "RTN","TMGITR",11,0) ;"======================================================================= "RTN","TMGITR",12,0) ;"firstIndex=$$ItrInit^TMGITR(File,.Iterater,[IENS],[direction],[PriorIndex]) -- set up an iterater for a given fileman file "RTN","TMGITR",13,0) ;"nextIndex=$$ItrNext^TMGITR(.Iterater,[.]CurIndex,[direction]) "RTN","TMGITR",14,0) "RTN","TMGITR",15,0) ;"firstfieldValue=$$ItrFInit^TMGITR(File,.Iterater,.Index,[Field],[IENS],[Flags]) -- set up an iterater for a given Fileman file, with FIELD return "RTN","TMGITR",16,0) ;"nextFieldValue=$$ItrFNext^TMGITR(.Iterater,[.]CurIndex,.CurField,[direction]) -- return next $order using iterater, returning FIELD "RTN","TMGITR",17,0) "RTN","TMGITR",18,0) ;"firstIndex=$$ItrAInit^TMGITR(pArray,.Iterater,[direction],[PriorIndex]) -- set up an iterater for a given Array "RTN","TMGITR",19,0) ;"nextIndex=$$ItrANext^TMGITR(.Iterater,[.]CurIndex,[direction]) -- return next $order using iterater "RTN","TMGITR",20,0) "RTN","TMGITR",21,0) ;"PrepProgress^TMGITR(.Iterater,Interval,ByCt,pIndex) "RTN","TMGITR",22,0) ;"ProgressDone^TMGITR(.Iterater) "RTN","TMGITR",23,0) "RTN","TMGITR",24,0) ;"======================================================================= "RTN","TMGITR",25,0) ;"PRIVATE API FUNCTIONS "RTN","TMGITR",26,0) ;"======================================================================= "RTN","TMGITR",27,0) ;"MakeRef(FileNum,IENS) -- make an global reference from a subfile "RTN","TMGITR",28,0) "RTN","TMGITR",29,0) ;"======================================================================= "RTN","TMGITR",30,0) ;"DEPENDENCIES "RTN","TMGITR",31,0) ;" DIQ,DILF "RTN","TMGITR",32,0) ;"======================================================================= "RTN","TMGITR",33,0) ;"======================================================================= "RTN","TMGITR",34,0) "RTN","TMGITR",35,0) ;"Note: This code has not been tested/debugged with subfiles yet. "RTN","TMGITR",36,0) "RTN","TMGITR",37,0) "RTN","TMGITR",38,0) ItrInit(File,Iterater,IENS,Direction) "RTN","TMGITR",39,0) ;"Purpose: To set up an iterater for a given fileman file "RTN","TMGITR",40,0) ;"Input: File -- name or number of a Fileman File "RTN","TMGITR",41,0) ;" Iterater -- PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGITR",42,0) ;" loaded with a reference that can be used with $order "RTN","TMGITR",43,0) ;" e.g. Index=$order(@Iterater@(Index)) "RTN","TMGITR",44,0) ;" Iterater also stores other info as an array: "RTN","TMGITR",45,0) ;" Iterater("FILENUM")=FileNum "RTN","TMGITR",46,0) ;" Iterater("IENS"=IENS used to create iterater (if supplied) "RTN","TMGITR",47,0) ;" Iterater("COUNT")=number of records "RTN","TMGITR",48,0) ;" IENS -- OPTIONAL, if File is a subfile, then must supply "RTN","TMGITR",49,0) ;" the IENS to specify its location, e.g. "RTN","TMGITR",50,0) ;" IEN,parent-IEN,grandparent-IEN, etc. "RTN","TMGITR",51,0) ;" Function will add terminal ',' for user if needed. "RTN","TMGITR",52,0) ;" Direction -- the Direction from "" to go for first record (-1 --> get last record) "RTN","TMGITR",53,0) ;"Results: IEN of the first record in file, or "" if error "RTN","TMGITR",54,0) "RTN","TMGITR",55,0) ;"Note: This is designed to work with Fileman files, with numeric "RTN","TMGITR",56,0) ;" nodes. It is designed to NOT return alpha nodes (indices) "RTN","TMGITR",57,0) "RTN","TMGITR",58,0) kill Iterater ;"Clear any prior entries "RTN","TMGITR",59,0) set File=$get(File) "RTN","TMGITR",60,0) if +File'=File set File=$$GetFileNum^TMGDBAPI(File) "RTN","TMGITR",61,0) new Index set Index="" ;"default to error "RTN","TMGITR",62,0) set Iterater("FILENUM")=File "RTN","TMGITR",63,0) set Iterater("COUNT")=0 "RTN","TMGITR",64,0) set Iterater("MAX")=0 "RTN","TMGITR",65,0) if $get(IENS)'="" do "RTN","TMGITR",66,0) . if $extract(IENS,$length(IENS))'="," set IENS=IENS_"," "RTN","TMGITR",67,0) . set Iterater("IENS")=IENS "RTN","TMGITR",68,0) "RTN","TMGITR",69,0) new ParentFile set ParentFile=+$get(^DD(File,0,"UP")) "RTN","TMGITR",70,0) if ParentFile=0 do "RTN","TMGITR",71,0) . set Iterater=$get(^DIC(File,0,"GL")) "RTN","TMGITR",72,0) . set Iterater=$$CREF^DILF(Iterater) "RTN","TMGITR",73,0) else set Iterater=$$MakeRef(File,IENS) "RTN","TMGITR",74,0) "RTN","TMGITR",75,0) set Direction=$get(Direction,1) "RTN","TMGITR",76,0) if Iterater'="" do "RTN","TMGITR",77,0) . set Index=$order(@Iterater@(0),Direction) "RTN","TMGITR",78,0) . set Iterater("COUNT")=$piece($get(@Iterater@(0)),"^",4) "RTN","TMGITR",79,0) . new index set index=":" "RTN","TMGITR",80,0) . for set index=$order(@Iterater@(index),-1) quit:(+index>0)!(index="") "RTN","TMGITR",81,0) . set Iterater("MAX")=index "RTN","TMGITR",82,0) "RTN","TMGITR",83,0) IIDone "RTN","TMGITR",84,0) quit Index "RTN","TMGITR",85,0) "RTN","TMGITR",86,0) "RTN","TMGITR",87,0) ItrFInit(File,Iterater,Index,Field,IENS,Flags,Direction) "RTN","TMGITR",88,0) ;"Purpose: To set up an iterater for a given Fileman file, with FIELD return "RTN","TMGITR",89,0) ;"Input: File -- name or number of a Fileman File "RTN","TMGITR",90,0) ;" Iterater -- PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGITR",91,0) ;" loaded with a reference that can be used with $order "RTN","TMGITR",92,0) ;" e.g. Index=$order(@Iterater@(Index)) "RTN","TMGITR",93,0) ;" Iterater also stores other info as an array: "RTN","TMGITR",94,0) ;" Iterater("FILENUM")=FileNum "RTN","TMGITR",95,0) ;" Iterater("FIELD")=Field "RTN","TMGITR",96,0) ;" Iterater("FLAGS")=Flags "RTN","TMGITR",97,0) ;" Iterater("IENS"=IENS used to create iterater "RTN","TMGITR",98,0) ;" Index -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGITR",99,0) ;" returns the first IEN in the file. "RTN","TMGITR",100,0) ;" Field -- optional. Field Name or Number. If supplied, "RTN","TMGITR",101,0) ;" value of field will be returned (rather than "RTN","TMGITR",102,0) ;" IENS -- optional, if File is a subfile, then must supply "RTN","TMGITR",103,0) ;" the IENS to specify its location, e.g. "RTN","TMGITR",104,0) ;" NOTE: MUST end in "," "RTN","TMGITR",105,0) ;" IEN,parent-IEN,grandparent-IEN, etc. "RTN","TMGITR",106,0) ;" Flags -- OPTIONAL -- Determines how value is returned. Same Flags as used "RTN","TMGITR",107,0) ;" by GET1^DIQ. "I"=Internal value returned (default is external form) "RTN","TMGITR",108,0) ;" Direction -- OPTIONAL -- the Direction from "" to go for first record (-1 --> get last record) "RTN","TMGITR",109,0) ;"Results: Value of field for IEN of the first record in file, or "" if error "RTN","TMGITR",110,0) new result set result="" "RTN","TMGITR",111,0) set IENS=$get(IENS) "RTN","TMGITR",112,0) set Index=$$ItrInit(.File,.Iterater,.IENS,.Direction) "RTN","TMGITR",113,0) set Field=$get(Field) "RTN","TMGITR",114,0) if +Field'=Field set Field=$$GetNumField^TMGDBAPI(.File,Field) "RTN","TMGITR",115,0) set Iterater("FIELD")=Field "RTN","TMGITR",116,0) set Iterater("FLAGS")=$get(Flags) "RTN","TMGITR",117,0) set IENS=Index_","_IENS "RTN","TMGITR",118,0) if Index'="" set result=$$GET1^DIQ(File,.IENS,.Field,.Flags) "RTN","TMGITR",119,0) "RTN","TMGITR",120,0) quit result "RTN","TMGITR",121,0) "RTN","TMGITR",122,0) ItrAInit(pArray,Iterater,Direction,PriorIndex) "RTN","TMGITR",123,0) ;"Purpose: To set up an iterater for a given Array "RTN","TMGITR",124,0) ;"Input: Array -- PASS BY NAME, the Array to be iterated. "RTN","TMGITR",125,0) ;" Iterater -- PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGITR",126,0) ;" loaded with a reference that can be used with $order "RTN","TMGITR",127,0) ;" e.g. Index=$order(@Iterater@(Index)) "RTN","TMGITR",128,0) ;" Iterater also stores other info as an array: "RTN","TMGITR",129,0) ;" Iterater("COUNT")=number of top level nodes in the Array "RTN","TMGITR",130,0) ;" Direction -- OPTIONAL -- the Direction from "" (or PriorIndex) to go for first record (-1 --> get last record) "RTN","TMGITR",131,0) ;" PriorIndex -- OPTIONAL -- the prior index to start from. Default="" "RTN","TMGITR",132,0) ;"Results: first node in the Array, or "" if error "RTN","TMGITR",133,0) "RTN","TMGITR",134,0) kill Iterater ;"Clear any prior entries "RTN","TMGITR",135,0) set Iterater=pArray "RTN","TMGITR",136,0) new Index set Index="" ;"default to error "RTN","TMGITR",137,0) if $get(pArray)="" goto IAIDone "RTN","TMGITR",138,0) set Direction=$get(Direction,1) "RTN","TMGITR",139,0) set PriorIndex=$get(PriorIndex,"") "RTN","TMGITR",140,0) ;"Will count later, if needed (avoid delay otherwise) "RTN","TMGITR",141,0) ;"set Iterater("COUNT")=$$ListCt^TMGMISC(pArray) "RTN","TMGITR",142,0) set Iterater("COUNT")=0 ;"override later "RTN","TMGITR",143,0) set Iterater("MAX")=$order(@Iterater@(":"),-1) "RTN","TMGITR",144,0) set Index=$order(@Iterater@(PriorIndex),Direction) "RTN","TMGITR",145,0) "RTN","TMGITR",146,0) IAIDone "RTN","TMGITR",147,0) quit Index "RTN","TMGITR",148,0) "RTN","TMGITR",149,0) "RTN","TMGITR",150,0) MakeRef(FileNum,IENS) "RTN","TMGITR",151,0) ;"Purpose: to make an global reference from a subfile "RTN","TMGITR",152,0) ;"Input: FileNum -- must be filenumber "RTN","TMGITR",153,0) ;" IENS -- a standard Fileman IENS of subfile. DON'T pass by reference "RTN","TMGITR",154,0) ;" Array("SUBFILE","NUMBER")=file number of this sub file. "RTN","TMGITR",155,0) ;" Array("SUBFILE","NAME")=file name of this sub file. "RTN","TMGITR",156,0) ;" Array("PARENT","NUMBER")=parent file number "RTN","TMGITR",157,0) ;" Array("PARENT","NAME")=parent file name "RTN","TMGITR",158,0) ;" Array("PARENT","GL")=global reference of parent, in open format<-- only valid if parent isn't also a subfile "RTN","TMGITR",159,0) ;" Array("FIELD IN PARENT","NUMBER")=field number of subfile in parent "RTN","TMGITR",160,0) ;" Array("FIELD IN PARENT","NAME")=filed name of subfile in parent "RTN","TMGITR",161,0) ;" Array("FIELD IN PARENT","LOC")=node and piece where subfile is stored "RTN","TMGITR",162,0) ;" Array("FIELD IN PARENT","CODE")=code giving subfile's attributes. "RTN","TMGITR",163,0) ;"Result: returns reference "RTN","TMGITR",164,0) "RTN","TMGITR",165,0) new i "RTN","TMGITR",166,0) new temp,IEN,parentFile "RTN","TMGITR",167,0) new ref set ref="" "RTN","TMGITR",168,0) new Info "RTN","TMGITR",169,0) "RTN","TMGITR",170,0) for i=1:1 do quit:(FileNum=0) "RTN","TMGITR",171,0) . ;"new NumIENs set NumIENs=$length(IENS,",") "RTN","TMGITR",172,0) . ;"set IEN=$piece(IENS,",",NumIENs) "RTN","TMGITR",173,0) . ;"set IENS=$piece(IENS,",",1,NumIENs-1) "RTN","TMGITR",174,0) . set IEN=$piece(IENS,",",1) "RTN","TMGITR",175,0) . set IENS=$piece(IENS,",",2,999) "RTN","TMGITR",176,0) . if IEN'="" set temp(i+1,"IEN")=IEN "RTN","TMGITR",177,0) . if $$GetSubFInfo^TMGDBAPI(FileNum,.Info)=0 set FileNum=0 quit "RTN","TMGITR",178,0) . set FileNum=$get(Info("PARENT","NUMBER")) "RTN","TMGITR",179,0) . set temp(i,"LOC IN PARENT")=$get(Info("FIELD IN PARENT","LOC")) "RTN","TMGITR",180,0) . set temp(i+1,"REF")=$$CREF^DILF($get(Info("PARENT","GL"))) "RTN","TMGITR",181,0) "RTN","TMGITR",182,0) set i=$order(temp(""),-1) "RTN","TMGITR",183,0) if i'="" for do quit:(i="") "RTN","TMGITR",184,0) . if $get(temp(i,"REF"))'="" set ref=temp(i,"REF") "RTN","TMGITR",185,0) . new IEN set IEN=$get(temp(i,"IEN")) "RTN","TMGITR",186,0) . new LOC set LOC=$piece($get(temp(i,"LOC IN PARENT")),";",1) "RTN","TMGITR",187,0) . if LOC'="" set ref=$name(@ref@(LOC)) "RTN","TMGITR",188,0) . if IEN'="" set ref=$name(@ref@(IEN)) "RTN","TMGITR",189,0) . set i=$order(temp(i),-1) "RTN","TMGITR",190,0) "RTN","TMGITR",191,0) quit ref "RTN","TMGITR",192,0) "RTN","TMGITR",193,0) "RTN","TMGITR",194,0) "RTN","TMGITR",195,0) ItrFNext(Iterater,CurIndex,CurField,direction) "RTN","TMGITR",196,0) ;"Purpose: to return next $order using iterater, returning FIELD "RTN","TMGITR",197,0) ;"Input: Iterater -- PASS BY REFERENCE. an iterater reference, as created by ItrInit "RTN","TMGITR",198,0) ;" Iterater also stores other info as an array: "RTN","TMGITR",199,0) ;" Iterater("FILENUM")=FileNum "RTN","TMGITR",200,0) ;" Iterater("FIELD")=Field "RTN","TMGITR",201,0) ;" Iterater("FLAGS")=Flags "RTN","TMGITR",202,0) ;" Iterater("IENS"=IENS used to create iterater "RTN","TMGITR",203,0) ;" Iterater("PROGRESS FN")=a PROGRESS FUNCTION <-- OPTIONAL "RTN","TMGITR",204,0) ;" CurIndex -- The current value of the index "RTN","TMGITR",205,0) ;" IF PASSED BY REF, WILL BE CHANGED "RTN","TMGITR",206,0) ;" CurField -- OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER -- not used to find next. "RTN","TMGITR",207,0) ;" direction -- OPTIONAL, 1 (default) for forward, -1 for backwards "RTN","TMGITR",208,0) ;"Results: returns the next value by $order, or "" if none "RTN","TMGITR",209,0) ;"NOTE: won't currently work for subfiles--would require passing a IENS "RTN","TMGITR",210,0) "RTN","TMGITR",211,0) set CurIndex=$$ItrNext(.Iterater,.CurIndex,.direction) "RTN","TMGITR",212,0) new File,Field,Flags "RTN","TMGITR",213,0) set CurField="" "RTN","TMGITR",214,0) if CurIndex'="" do "RTN","TMGITR",215,0) . set File=$get(Iterater("FILENUM")) "RTN","TMGITR",216,0) . set Field=$get(Iterater("FIELD")) "RTN","TMGITR",217,0) . set Flags=$get(Iterater("FLAGS")) "RTN","TMGITR",218,0) . set CurField=$$GET1^DIQ(File,CurIndex,Field,Flags) "RTN","TMGITR",219,0) "RTN","TMGITR",220,0) quit CurField "RTN","TMGITR",221,0) "RTN","TMGITR",222,0) "RTN","TMGITR",223,0) ItrNext(Iterater,CurIndex,direction) "RTN","TMGITR",224,0) ;"Purpose: to return next $order using iterater "RTN","TMGITR",225,0) ;"Input: Iterater -- and iterater reference, as created by ItrInit "RTN","TMGITR",226,0) ;" Iterater("PROGRESS FN")=a PROGRESS FUNCTION <-- OPTIONAL "RTN","TMGITR",227,0) ;" CurIndex -- The current value of the index "RTN","TMGITR",228,0) ;" IF PASSED BY REF, WILL BE CHANGED "RTN","TMGITR",229,0) ;" direction -- OPTIONAL, 1 (default) for forward, -1 for backwards "RTN","TMGITR",230,0) ;"Results: returns the next value by $order, or "" if none "RTN","TMGITR",231,0) "RTN","TMGITR",232,0) set CurIndex=$order(@Iterater@(CurIndex),$get(direction,1)) "RTN","TMGITR",233,0) "RTN","TMGITR",234,0) new ProgressFn set ProgressFn=$get(Iterater("PROGRESS FN")) "RTN","TMGITR",235,0) if ProgressFn'="" do "RTN","TMGITR",236,0) . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGITR",237,0) . if CurIndex="" do ProgressDone(.Iterater) "RTN","TMGITR",238,0) . else do "RTN","TMGITR",239,0) . . set Iterater("PROGRESS FN","CURRENT")=Iterater("PROGRESS FN","CURRENT")+1 "RTN","TMGITR",240,0) . . xecute ProgressFn "RTN","TMGITR",241,0) "RTN","TMGITR",242,0) quit CurIndex "RTN","TMGITR",243,0) "RTN","TMGITR",244,0) "RTN","TMGITR",245,0) ItrANext(Iterater,CurIndex,direction) "RTN","TMGITR",246,0) ;"Purpose: to return next $order using iterater "RTN","TMGITR",247,0) ;"Input: Iterater -- and iterater reference, as created by ItrAInit "RTN","TMGITR",248,0) ;" Iterater("PROGRESS FN")=a PROGRESS FUNCTION <-- OPTIONAL "RTN","TMGITR",249,0) ;" CurIndex -- The current value of the index "RTN","TMGITR",250,0) ;" IF PASSED BY REF, WILL BE CHANGED "RTN","TMGITR",251,0) ;" direction -- OPTIONAL, 1 (default) for forward, -1 for backwards "RTN","TMGITR",252,0) ;"Results: returns the next value by $order, or "" if none "RTN","TMGITR",253,0) "RTN","TMGITR",254,0) quit $$ItrNext(.Iterater,.CurIndex,.direction) "RTN","TMGITR",255,0) "RTN","TMGITR",256,0) "RTN","TMGITR",257,0) PrepProgress(Iterater,Interval,ByCt,pIndex) "RTN","TMGITR",258,0) ;"Purpose: to set up code so that ItrNext can easily show a progress function "RTN","TMGITR",259,0) ;"Input: Iterater -- PASS BY REFERENCE. Array as set up by ItrInit "RTN","TMGITR",260,0) ;" Interval -- OPTIONAL, default=10 The interval between showing progress bar "RTN","TMGITR",261,0) ;" ByCt -- OPTIONAL, default=1, "RTN","TMGITR",262,0) ;" if 0: range is 0..MaxIEN, index=IEN "RTN","TMGITR",263,0) ;" if 1: range is 0..Number of Records, index=record counter "RTN","TMGITR",264,0) ;" pIndex -- if ByCt=0, REQUIRED. NAME OF 'IEN' variable "RTN","TMGITR",265,0) "RTN","TMGITR",266,0) new pCurrent,pTotal,pStartTime,PrgFn "RTN","TMGITR",267,0) set Interval=$get(Interval,10) "RTN","TMGITR",268,0) if Interval=1 set Interval=2 ;" X#1 is always 0, so would never show. "RTN","TMGITR",269,0) set ByCt=$get(ByCt,1) "RTN","TMGITR",270,0) set Iterater("PROGRESS FN","BY-CT")=ByCt "RTN","TMGITR",271,0) set Iterater("PROGRESS FN","CURRENT")=0 "RTN","TMGITR",272,0) set Iterater("PROGRESS FN","START TIME")=$H "RTN","TMGITR",273,0) set pStartTime=$name(Iterater("PROGRESS FN","START TIME")) "RTN","TMGITR",274,0) if ByCt=0 do "RTN","TMGITR",275,0) . set Iterater("PROGRESS FN","INDEX")=pIndex "RTN","TMGITR",276,0) . new pMax set pMax=$name(Iterater("MAX")) "RTN","TMGITR",277,0) . set PrgFn="if "_pIndex_"#"_Interval_"=1 " "RTN","TMGITR",278,0) . set PrgFn=PrgFn_"do ProgressBar^TMGUSRIF("_pIndex_",""Progress"",0,"_pMax_",,"_pStartTime_")" "RTN","TMGITR",279,0) else do "RTN","TMGITR",280,0) . set pCurrent=$name(Iterater("PROGRESS FN","CURRENT")) "RTN","TMGITR",281,0) . if +$get(Iterater("COUNT"))=0 do "RTN","TMGITR",282,0) . . set Iterater("COUNT")=$$ListCt^TMGMISC(Iterater) "RTN","TMGITR",283,0) . set pTotal=$name(Iterater("COUNT")) "RTN","TMGITR",284,0) . set PrgFn="if "_pCurrent_"#"_Interval_"=1 " "RTN","TMGITR",285,0) . set PrgFn=PrgFn_"do ProgressBar^TMGUSRIF("_pCurrent_",""Progress"",0,"_pTotal_",,"_pStartTime_")" "RTN","TMGITR",286,0) "RTN","TMGITR",287,0) set Iterater("PROGRESS DONE FN")="do ProgressBar^TMGUSRIF(100,""Progress"",0,100)" "RTN","TMGITR",288,0) set Iterater("PROGRESS FN")=PrgFn "RTN","TMGITR",289,0) "RTN","TMGITR",290,0) quit "RTN","TMGITR",291,0) "RTN","TMGITR",292,0) "RTN","TMGITR",293,0) ProgressDone(Iterater) "RTN","TMGITR",294,0) ;"Purpose: to allow user to call and ensure the progress bar is at 100% after "RTN","TMGITR",295,0) ;" loop is done. This is needed because the Iterater code has no way of "RTN","TMGITR",296,0) ;" knowing what criteria will be used to determine when loop is complete. "RTN","TMGITR",297,0) "RTN","TMGITR",298,0) ;"new ProgressFn set ProgressFn=$get(Iterater("PROGRESS FN")) "RTN","TMGITR",299,0) new ProgressFn set ProgressFn=$get(Iterater("PROGRESS DONE FN")) "RTN","TMGITR",300,0) if $get(ProgressFn)'="" do "RTN","TMGITR",301,0) . ;"new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGITR",302,0) . ;"new ByCt set ByCt=$get(Iterater("PROGRESS FN","BY-CT"),1) "RTN","TMGITR",303,0) . ;"if ByCt=0 do "RTN","TMGITR",304,0) . ;". new pIndex set pIndex=$get(Iterater("PROGRESS FN","INDEX")) "RTN","TMGITR",305,0) . ;". new max set max=1 "RTN","TMGITR",306,0) . ;". if pIndex'="" do "RTN","TMGITR",307,0) . ;". . set Iterater("MAX")=+$get(@pIndex) "RTN","TMGITR",308,0) . ;". . if Iterater("MAX")'>0 set Iterater("MAX")=1 "RTN","TMGITR",309,0) . ;"else do "RTN","TMGITR",310,0) . ;". set Iterater("PROGRESS FN","CURRENT")=$get(Iterater("COUNT")) "RTN","TMGITR",311,0) . xecute ProgressFn "RTN","TMGITR",312,0) write ! "RTN","TMGITR",313,0) quit "RTN","TMGITR",314,0) "RTN","TMGITR",315,0) ;"============================================================ "RTN","TMGITR",316,0) ;"============================================================ "RTN","TMGITR",317,0) "RTN","TMGITR",318,0) "RTN","TMGITR",319,0) Test "RTN","TMGITR",320,0) ;"Purpose: test functionality and usability "RTN","TMGITR",321,0) ;" of plain iterater functions "RTN","TMGITR",322,0) "RTN","TMGITR",323,0) new Itr,IEN "RTN","TMGITR",324,0) new abort set abort=0 "RTN","TMGITR",325,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGITR",326,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGITR",327,0) if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGITR",328,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGITR",329,0) . ;"write IEN,! "RTN","TMGITR",330,0) . ;"other code here... "RTN","TMGITR",331,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGITR",332,0) "RTN","TMGITR",333,0) quit "RTN","TMGITR",334,0) "RTN","TMGITR",335,0) "RTN","TMGITR",336,0) Test2 "RTN","TMGITR",337,0) ;"Purpose: test functionality and usability "RTN","TMGITR",338,0) ;" of iterater functions that return a given field "RTN","TMGITR",339,0) "RTN","TMGITR",340,0) new Itr,IEN,Name "RTN","TMGITR",341,0) new abort set abort=0 "RTN","TMGITR",342,0) set Name=$$ItrFInit^TMGITR(22706.9,.Itr,.IEN,.05) "RTN","TMGITR",343,0) for do quit:(($$ItrFNext^TMGITR(.Itr,.IEN,.Name)="@@@")!(+IEN=0))!abort "RTN","TMGITR",344,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGITR",345,0) . ;"write Name,! "RTN","TMGITR",346,0) . ;"other code here... "RTN","TMGITR",347,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGITR",348,0) "RTN","TMGITR",349,0) quit "RTN","TMGITR",350,0) "RTN","TMGITR",351,0) "RTN","TMGITR",352,0) Test3 "RTN","TMGITR",353,0) ;"Purpose: test functionality and usability "RTN","TMGITR",354,0) ;" of iterater functions that work on an array "RTN","TMGITR",355,0) "RTN","TMGITR",356,0) new Itr,index "RTN","TMGITR",357,0) new abort set abort=0 "RTN","TMGITR",358,0) set index=$$ItrAInit^TMGITR("^PSDRUG(""B"")",.Itr) "RTN","TMGITR",359,0) do PrepProgress^TMGITR(.Itr,20,1,"index") "RTN","TMGITR",360,0) if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="")!abort "RTN","TMGITR",361,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGITR",362,0) . ;"other code here... "RTN","TMGITR",363,0) . ;"write index,! "RTN","TMGITR",364,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGITR",365,0) "RTN","TMGITR",366,0) quit "RTN","TMGITR",367,0) "RTN","TMGKERNL") 0^29^B5946 "RTN","TMGKERNL",1,0) TMGKERNL ;TMG/kst/OS Specific functions ;03/25/06 "RTN","TMGKERNL",2,0) ;;1.0;TMG-LIB;**1**;11/01/04 "RTN","TMGKERNL",3,0) "RTN","TMGKERNL",4,0) ;"TMG KERNEL FUNCTIONS "RTN","TMGKERNL",5,0) ;"I.e. functions that are OS specific. "RTN","TMGKERNL",6,0) ;"Kevin Toppenberg MD "RTN","TMGKERNL",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGKERNL",8,0) ;"7-12-2005 "RTN","TMGKERNL",9,0) "RTN","TMGKERNL",10,0) ;"======================================================================= "RTN","TMGKERNL",11,0) ;" API -- Public Functions. "RTN","TMGKERNL",12,0) ;"======================================================================= "RTN","TMGKERNL",13,0) ;"$$Dos2Unix(FullNamePath) "RTN","TMGKERNL",14,0) ;"$$IsDir(Path) "RTN","TMGKERNL",15,0) ;"$$Move(Source,Dest) "RTN","TMGKERNL",16,0) ;"$$Copy(Source,Dest) "RTN","TMGKERNL",17,0) ;"$$Convert^TMGKERNL(FPathName,NewType) -- convert a graphic image to new type "RTN","TMGKERNL",18,0) "RTN","TMGKERNL",19,0) ;"======================================================================= "RTN","TMGKERNL",20,0) ;"Dependancies "RTN","TMGKERNL",21,0) ;"======================================================================= "RTN","TMGKERNL",22,0) "RTN","TMGKERNL",23,0) ;"======================================================================= "RTN","TMGKERNL",24,0) "RTN","TMGKERNL",25,0) Dos2Unix(FullNamePath) "RTN","TMGKERNL",26,0) ;"Purpose: To execute the unix command Dos2Unix on filename path "RTN","TMGKERNL",27,0) ;"FullNamePath: The filename to act on. "RTN","TMGKERNL",28,0) ;"Result: 0 if no error; >0 if error "RTN","TMGKERNL",29,0) ;"Notice!!!! The return code here is DIFFERENT from usual "RTN","TMGKERNL",30,0) "RTN","TMGKERNL",31,0) new result set result=0 "RTN","TMGKERNL",32,0) if $get(FullNamePath)="" goto DUDone "RTN","TMGKERNL",33,0) new spec set spec(" ")="\ " "RTN","TMGKERNL",34,0) set FullNamePath=$$REPLACE^XLFSTR(FullNamePath,.spec) "RTN","TMGKERNL",35,0) "RTN","TMGKERNL",36,0) new HookCmd "RTN","TMGKERNL",37,0) set HookCmd="dos2unix -q "_FullNamePath "RTN","TMGKERNL",38,0) ;"write "Hookcmd=",HookCmd,! "RTN","TMGKERNL",39,0) zsystem HookCmd "RTN","TMGKERNL",40,0) set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) "RTN","TMGKERNL",41,0) "RTN","TMGKERNL",42,0) DUDone "RTN","TMGKERNL",43,0) quit result "RTN","TMGKERNL",44,0) "RTN","TMGKERNL",45,0) "RTN","TMGKERNL",46,0) "RTN","TMGKERNL",47,0) IsDir(Path) "RTN","TMGKERNL",48,0) ;"Purpose: To determine if Path is a path to a directory (i.e. are there sub files) "RTN","TMGKERNL",49,0) ;"Input: Path to test, e.g. "/home/user" or "/home/user/" "RTN","TMGKERNL",50,0) ;"Result: 1 if there are files in path, 0 otherwise "RTN","TMGKERNL",51,0) ;"Note: if Path is a valid path to a directory, but there are no files in directory, 0 returned. "RTN","TMGKERNL",52,0) "RTN","TMGKERNL",53,0) new TMGMask set TMGMask("*")="" "RTN","TMGKERNL",54,0) new TMGFiles "RTN","TMGKERNL",55,0) new result set result=0 "RTN","TMGKERNL",56,0) "RTN","TMGKERNL",57,0) new spec set spec(" ")="\ " "RTN","TMGKERNL",58,0) set Path=$$REPLACE^XLFSTR(Path,.spec) "RTN","TMGKERNL",59,0) "RTN","TMGKERNL",60,0) ;"Note: I can't seem to get this to work with names containing spaces. "RTN","TMGKERNL",61,0) if $$LIST^%ZISH(Path,"TMGMask","TMGFiles")=1 do "RTN","TMGKERNL",62,0) . new index set index=$order(TMGFiles("")) "RTN","TMGKERNL",63,0) . if index'="" set result=1 "RTN","TMGKERNL",64,0) "RTN","TMGKERNL",65,0) quit result "RTN","TMGKERNL",66,0) "RTN","TMGKERNL",67,0) "RTN","TMGKERNL",68,0) Move(Source,Dest) "RTN","TMGKERNL",69,0) ;"Purpose to provide a shell for the Linux command 'mv' "RTN","TMGKERNL",70,0) ;" This can serve to move or rename a file "RTN","TMGKERNL",71,0) ;"Note: a platform independant version of the this could be constructed later... "RTN","TMGKERNL",72,0) ;"Result: 0 if no error; >0 if error "RTN","TMGKERNL",73,0) ;"Notice!!!! The return code here is DIFFERENT from usual "RTN","TMGKERNL",74,0) "RTN","TMGKERNL",75,0) new HookCmd,result "RTN","TMGKERNL",76,0) new Srch "RTN","TMGKERNL",77,0) set Srch(" ")="\ " "RTN","TMGKERNL",78,0) set Source=$$REPLACE^XLFSTR(Source,.Srch) "RTN","TMGKERNL",79,0) set Dest=$$REPLACE^XLFSTR(Dest,.Srch) "RTN","TMGKERNL",80,0) set HookCmd="mv "_Source_" "_Dest "RTN","TMGKERNL",81,0) zsystem HookCmd "RTN","TMGKERNL",82,0) set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) "RTN","TMGKERNL",83,0) quit result "RTN","TMGKERNL",84,0) "RTN","TMGKERNL",85,0) "RTN","TMGKERNL",86,0) Copy(Source,Dest) "RTN","TMGKERNL",87,0) ;"Purpose to provide a shell for the Linux command 'cp' "RTN","TMGKERNL",88,0) ;" This can serve to move or rename a file "RTN","TMGKERNL",89,0) ;"Note: a platform independant version of the this could be constructed later... "RTN","TMGKERNL",90,0) ;"Result: 0 if no error; >0 if error "RTN","TMGKERNL",91,0) ;"Notice!!!! The return code here is DIFFERENT from usual "RTN","TMGKERNL",92,0) "RTN","TMGKERNL",93,0) new HookCmd,result "RTN","TMGKERNL",94,0) new Srch "RTN","TMGKERNL",95,0) set Srch(" ")="\ " "RTN","TMGKERNL",96,0) set Source=$$REPLACE^XLFSTR(Source,.Srch) "RTN","TMGKERNL",97,0) set Dest=$$REPLACE^XLFSTR(Dest,.Srch) "RTN","TMGKERNL",98,0) set HookCmd="cp "_Source_" "_Dest "RTN","TMGKERNL",99,0) zsystem HookCmd "RTN","TMGKERNL",100,0) set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) "RTN","TMGKERNL",101,0) quit result "RTN","TMGKERNL",102,0) "RTN","TMGKERNL",103,0) "RTN","TMGKERNL",104,0) Convert(FPathName,NewType) "RTN","TMGKERNL",105,0) ;"Purpose: to convert a graphic image on the linux host to new type "RTN","TMGKERNL",106,0) ;" i.e. image.jpg --> image.png. This is more than a simple renaming. "RTN","TMGKERNL",107,0) ;"Input: FPathName -- full path, filename and extention. E.g. "\tmp\image.jpg" "RTN","TMGKERNL",108,0) ;" NewType -- the new image type (without '.'), "RTN","TMGKERNL",109,0) ;" E.g. "jpg", or "JPG", or "TIFF", or "pcd" (NOT ".jpg" etc) "RTN","TMGKERNL",110,0) ;"Output: New FPathName (with new extension) to new image file, or "" if problem "RTN","TMGKERNL",111,0) ;" "RTN","TMGKERNL",112,0) ;"Note: If the conversion is successful, then the original image will be deleted "RTN","TMGKERNL",113,0) ;"Note: This function depends on the ImageMagick graphic utility "convert" to be "RTN","TMGKERNL",114,0) ;" installed on the host linux system, and in the path so that it can be "RTN","TMGKERNL",115,0) ;" launched from any directory. "RTN","TMGKERNL",116,0) "RTN","TMGKERNL",117,0) new newFPathName set newFPathName="" "RTN","TMGKERNL",118,0) set NewType=$get(NewType) "RTN","TMGKERNL",119,0) if NewType="" goto ConvDone "RTN","TMGKERNL",120,0) "RTN","TMGKERNL",121,0) new FName,FPath,FileSpec "RTN","TMGKERNL",122,0) do SplitFNamePath^TMGIOUTL(FPathName,.FPath,.FName,"/") "RTN","TMGKERNL",123,0) set FileSpec(FName)="" "RTN","TMGKERNL",124,0) "RTN","TMGKERNL",125,0) set newFPathName=$piece(FPathName,".",1)_"."_NewType "RTN","TMGKERNL",126,0) "RTN","TMGKERNL",127,0) ;"Setup and launch linux command to execute convert "RTN","TMGKERNL",128,0) new CmdStr "RTN","TMGKERNL",129,0) set CmdStr="convert "_FPathName_" "_newFPathName "RTN","TMGKERNL",130,0) do "RTN","TMGKERNL",131,0) . ;"new $ETRAP,$ZTRAP "RTN","TMGKERNL",132,0) . ;"set $ETRAP="S $ECODE=""""" "RTN","TMGKERNL",133,0) . zsystem CmdStr ;"Launch command "RTN","TMGKERNL",134,0) "RTN","TMGKERNL",135,0) ;"get result of execution. (low byte only) -- if wanted "RTN","TMGKERNL",136,0) new CmdResult set CmdResult=$ZSYSTEM&255 "RTN","TMGKERNL",137,0) if CmdResult'=0 do goto ConvDone "RTN","TMGKERNL",138,0) . set newFPathName="" "RTN","TMGKERNL",139,0) "RTN","TMGKERNL",140,0) ;"Delete old image file "RTN","TMGKERNL",141,0) ;"**** temp!!!!! REMOVE COMMENTS LATER "RTN","TMGKERNL",142,0) ;"new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") "RTN","TMGKERNL",143,0) "RTN","TMGKERNL",144,0) ConvDone "RTN","TMGKERNL",145,0) quit newFPathName "RTN","TMGKERNL",146,0) "RTN","TMGKERNL",147,0) "RTN","TMGKERNL",148,0) "RTN","TMGKERNL",149,0) "RTN","TMGKERNL",150,0) "RTN","TMGKIDS") 0^112^B2764 "RTN","TMGKIDS",1,0) TMGKIDS ;TMG/kst/Code used for pre and post routines for KIDS build ;04/16/08 "RTN","TMGKIDS",2,0) ;;1.0;TMG-LIB;**1**;04/16/08 "RTN","TMGKIDS",3,0) "RTN","TMGKIDS",4,0) POSTINST "RTN","TMGKIDS",5,0) ;"Purpose: To provide a function that KIDS can call after installing patch. "RTN","TMGKIDS",6,0) ;"This particular function will add custom RPC entries to the RPC field in "RTN","TMGKIDS",7,0) ;"the OPTION field in OR CPRS GUI CHART. "RTN","TMGKIDS",8,0) "RTN","TMGKIDS",9,0) D1 ;"Below is a data list, not simple comments "RTN","TMGKIDS",10,0) ;;TMG ADD PATIENT "RTN","TMGKIDS",11,0) ;;TMG AUTOSIGN TIU DOCUMENT "RTN","TMGKIDS",12,0) ;;TMG BARCODE DECODE "RTN","TMGKIDS",13,0) ;;TMG BARCODE ENCODE "RTN","TMGKIDS",14,0) ;;TMG DOWNLOAD FILE "RTN","TMGKIDS",15,0) ;;TMG DOWNLOAD FILE DROPBOX "RTN","TMGKIDS",16,0) ;;TMG GET BLANK TIU DOCUMENT "RTN","TMGKIDS",17,0) ;;TMG GET DFN "RTN","TMGKIDS",18,0) ;;TMG GET IMAGE LONG DESCRIPTION "RTN","TMGKIDS",19,0) ;;TMG GET PATIENT DEMOGRAPHICS "RTN","TMGKIDS",20,0) ;;TMG SET PATIENT DEMOGRAPHICS "RTN","TMGKIDS",21,0) ;;TMG UPLOAD FILE "RTN","TMGKIDS",22,0) ;;TMG UPLOAD FILE DROPBOX "RTN","TMGKIDS",23,0) ;;TMG CPRS GET URL LIST "RTN","TMGKIDS",24,0) ;;--END OF LIST-- "RTN","TMGKIDS",25,0) "RTN","TMGKIDS",26,0) new ienORCPRS,DIC,X,Y "RTN","TMGKIDS",27,0) ;"set ienORCPRS= ... find in OPTION file. "RTN","TMGKIDS",28,0) set DIC=19 ;"OPTION file "RTN","TMGKIDS",29,0) set X="OR CPRS GUI CHART" "RTN","TMGKIDS",30,0) do ^DIC "RTN","TMGKIDS",31,0) set ienORCPRS=+$piece(Y,"^",1) "RTN","TMGKIDS",32,0) if ienORCPRS'>0 do goto PostDone "RTN","TMGKIDS",33,0) . write !,!,"Sorry, unable to locate OR CPRS GUI CHART in OPTION file.",! "RTN","TMGKIDS",34,0) . write "Unable to add TMG's RPC's to allowed list of RPC's for CPRS.",! "RTN","TMGKIDS",35,0) "RTN","TMGKIDS",36,0) new i,rpcName "RTN","TMGKIDS",37,0) for i=1:1 do quit:(rpcName="") "RTN","TMGKIDS",38,0) . set rpcName=$text(D1+i^TMGKIDS) "RTN","TMGKIDS",39,0) . set rpcName=$piece(rpcName,";;",2) "RTN","TMGKIDS",40,0) . if rpcName="--END OF LIST--" set rpcName="" "RTN","TMGKIDS",41,0) . if rpcName="" quit "RTN","TMGKIDS",42,0) . do AddRPC(ienORCPRS,rpcName) "RTN","TMGKIDS",43,0) "RTN","TMGKIDS",44,0) PostDone "RTN","TMGKIDS",45,0) quit "RTN","TMGKIDS",46,0) "RTN","TMGKIDS",47,0) "RTN","TMGKIDS",48,0) "RTN","TMGKIDS",49,0) AddRPC(IENOption,RPCName) "RTN","TMGKIDS",50,0) ;"Purpose: To add the RPC Name to the RPC subfile in the Option record, "RTN","TMGKIDS",51,0) ;" given by IENOption "RTN","TMGKIDS",52,0) ;"Note: If IENRPC is already present, then it won't be added again. "RTN","TMGKIDS",53,0) "RTN","TMGKIDS",54,0) ;"See if RPC is already present, to avoid duplication "RTN","TMGKIDS",55,0) new DIC,TMGD0,X,Y "RTN","TMGKIDS",56,0) set TMGD0=IENOption "RTN","TMGKIDS",57,0) set X=RPCName "RTN","TMGKIDS",58,0) set DIC="^DIC(19,"_IENOption_",""RPC""," "RTN","TMGKIDS",59,0) set DIC(0)="MZ" "RTN","TMGKIDS",60,0) do ^DIC "RTN","TMGKIDS",61,0) "RTN","TMGKIDS",62,0) write RPCName "RTN","TMGKIDS",63,0) if +Y'>0 do "RTN","TMGKIDS",64,0) . ;"code to add RPC here. "RTN","TMGKIDS",65,0) . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGKIDS",66,0) . set TMGFDA(19.05,"+1,"_IENOption_",",.01)=RPCName "RTN","TMGKIDS",67,0) . do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGKIDS",68,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGKIDS",69,0) . write ?30,"... Added as allowed RPC from CPRS",! "RTN","TMGKIDS",70,0) else do "RTN","TMGKIDS",71,0) . write ?30,"... already present",! "RTN","TMGKIDS",72,0) "RTN","TMGKIDS",73,0) quit "RTN","TMGKIDS",74,0) "RTN","TMGKIDS",75,0) "RTN","TMGKIDS",76,0) "RTN","TMGMATH") 0^30^B823927915 "RTN","TMGMATH",1,0) ;"16-Feb-1999, 16:54:35 "RTN","TMGMATH",2,0) ;"Routine Save for all M[UMPS] Library Functions "RTN","TMGMATH",3,0) ; "RTN","TMGMATH",4,0) ;" Unless otherwise noted, the code below "RTN","TMGMATH",5,0) ;" was approved in document X11/95-11 "RTN","TMGMATH",6,0) ; "RTN","TMGMATH",7,0) ;" If corrections have been applied, "RTN","TMGMATH",8,0) ;" first the original line appears, "RTN","TMGMATH",9,0) ;" with three semicolons at the beginning of the line. "RTN","TMGMATH",10,0) ; "RTN","TMGMATH",11,0) ;" Then the source of the correction is acknowledged, "RTN","TMGMATH",12,0) ;" then the corrected line appears, followed by a "RTN","TMGMATH",13,0) ;" line containing three semicolons. "RTN","TMGMATH",14,0) ; "RTN","TMGMATH",15,0) ;"Downloaded from http://www.jacquardsystems.com/Examples/lib/mlibfunc.rs "RTN","TMGMATH",16,0) ;"on 5/21/07 "RTN","TMGMATH",17,0) ABS(X) Quit $Translate(+X,"-") "RTN","TMGMATH",18,0) ;=== "RTN","TMGMATH",19,0) ; "RTN","TMGMATH",20,0) ; "RTN","TMGMATH",21,0) ARCCOS(X) ; "RTN","TMGMATH",22,0) ;;;" ;" Number ~~ "RTN","TMGMATH",23,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",24,0) ;" Comment: This version of the function is "RTN","TMGMATH",25,0) ;" optimized for speed, not for precision. "RTN","TMGMATH",26,0) ;" The 'precision' parameter is not supported, "RTN","TMGMATH",27,0) ;" and the precision is at best 2 in 10**-8. "RTN","TMGMATH",28,0) ;;; "RTN","TMGMATH",29,0) ; "RTN","TMGMATH",30,0) New A,N,R,SIGN,XX "RTN","TMGMATH",31,0) If X<-1 Set $Ecode=",M28," "RTN","TMGMATH",32,0) If X>1 Set $Ecode=",M28," "RTN","TMGMATH",33,0) Set SIGN=1 Set:X<0 X=-X,SIGN=-1 "RTN","TMGMATH",34,0) Set A(0)=1.5707963050,A(1)=-0.2145988016,A(2)=0.0889789874 "RTN","TMGMATH",35,0) Set A(3)=-0.0501743046,A(4)=0.0308918810,A(5)=-0.0170881256 "RTN","TMGMATH",36,0) Set A(6)=0.0066700901,A(7)=-0.0012624911 "RTN","TMGMATH",37,0) Set R=A(0),XX=1 For N=1:1:7 Set XX=XX*X,R=A(N)*XX+R "RTN","TMGMATH",38,0) ; "RTN","TMGMATH",39,0) ;;;" Set R=$%SQRT^MATH(1-X)*R ;" Number ~~ "RTN","TMGMATH",40,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",41,0) Set R=$%SQRT^MATH(1-X,11)*R "RTN","TMGMATH",42,0) ;;; "RTN","TMGMATH",43,0) ; "RTN","TMGMATH",44,0) Quit R*SIGN "RTN","TMGMATH",45,0) ;=== "RTN","TMGMATH",46,0) ; "RTN","TMGMATH",47,0) ; "RTN","TMGMATH",48,0) ARCCOS(X,PREC) ; "RTN","TMGMATH",49,0) ; "RTN","TMGMATH",50,0) ;;;" New L,LIM,K,SIG,SIGS ;" Number ~~ "RTN","TMGMATH",51,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",52,0) New L,LIM,K,SIG,SIGS,VALUE "RTN","TMGMATH",53,0) ;;; "RTN","TMGMATH",54,0) ; "RTN","TMGMATH",55,0) If X<-1 Set $Ecode=",M28," "RTN","TMGMATH",56,0) If X>1 Set $Ecode=",M28," "RTN","TMGMATH",57,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",58,0) ; "RTN","TMGMATH",59,0) ;;;" If $Translate(X,"-")=1 Set VALUE=0 Quit ;" Number ~~ "RTN","TMGMATH",60,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",61,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",62,0) If $Translate(X,"-")=1 Quit 0 "RTN","TMGMATH",63,0) ;;; "RTN","TMGMATH",64,0) ; "RTN","TMGMATH",65,0) Set SIG=$Select(X<0:-1,1:1),VALUE=1-(X*X) "RTN","TMGMATH",66,0) ; "RTN","TMGMATH",67,0) ;;;" Set X=$%SQRT^MATH(VALUE) ;" Number ~~ "RTN","TMGMATH",68,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",69,0) Set X=$%SQRT^MATH(VALUE,PREC) "RTN","TMGMATH",70,0) ;;; "RTN","TMGMATH",71,0) ; "RTN","TMGMATH",72,0) ;;;" If $Translate(X,"-")=1 Do Quit ;" Number ~~ "RTN","TMGMATH",73,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",74,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",75,0) If $Translate(X,"-")=1 Do Quit VALUE "RTN","TMGMATH",76,0) . ;;; "RTN","TMGMATH",77,0) . ; "RTN","TMGMATH",78,0) . Set VALUE=$%PI^MATH()/2*X "RTN","TMGMATH",79,0) . Quit "RTN","TMGMATH",80,0) ; "RTN","TMGMATH",81,0) ;;;" If X>0.9 Do Quit ;" Number ~~ "RTN","TMGMATH",82,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",83,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",84,0) If X>0.9 Do Quit VALUE "RTN","TMGMATH",85,0) . ;;; "RTN","TMGMATH",86,0) . ; "RTN","TMGMATH",87,0) . Set SIGS=$Select(X<0:-1,1:1) "RTN","TMGMATH",88,0) . Set VALUE=1/(1/X/X-1) "RTN","TMGMATH",89,0) . ; "RTN","TMGMATH",90,0) . ;;;" Set X=$%SQRT^MATH(VALUE) ;" Number ~~ "RTN","TMGMATH",91,0) . ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",92,0) . Set X=$%SQRT^MATH(VALUE,PREC) "RTN","TMGMATH",93,0) . ;;; "RTN","TMGMATH",94,0) . ; "RTN","TMGMATH",95,0) . ; "RTN","TMGMATH",96,0) . ;;;" Set VALUE=$%ARCTAN^MATH(X,10)*SIGS ;" Number ~~ "RTN","TMGMATH",97,0) . ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",98,0) . Set VALUE=$%ARCTAN^MATH(X,PREC)*SIGS "RTN","TMGMATH",99,0) . ;;; "RTN","TMGMATH",100,0) ; "RTN","TMGMATH",101,0) . Quit "RTN","TMGMATH",102,0) Set (VALUE,L)=X "RTN","TMGMATH",103,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",104,0) For K=3:2 Do Quit:($Translate(L,"-")1 Set $Ecode=",M28," "RTN","TMGMATH",174,0) Set SIGN=1 Set:X<0 X=-X,SIGN=-1 "RTN","TMGMATH",175,0) Set A(0)=1.5707963050,A(1)=-0.2145988016,A(2)=0.0889789874 "RTN","TMGMATH",176,0) Set A(3)=-0.0501743046,A(4)=0.0308918810,A(5)=-0.0170881256 "RTN","TMGMATH",177,0) Set A(6)=0.0066700901,A(7)=-0.0012624911 "RTN","TMGMATH",178,0) Set R=A(0),XX=1 For N=1:1:7 Set XX=XX*X,R=A(N)*XX+R "RTN","TMGMATH",179,0) ; "RTN","TMGMATH",180,0) ;;;" Set R=$%SQRT^MATH(1-X)*R ;" Number ~~ "RTN","TMGMATH",181,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",182,0) Set R=$%SQRT^MATH(1-X,11)*R "RTN","TMGMATH",183,0) ;;; "RTN","TMGMATH",184,0) ; "RTN","TMGMATH",185,0) Set R=$%PI^MATH()/2-R "RTN","TMGMATH",186,0) Quit R*SIGN "RTN","TMGMATH",187,0) ;=== "RTN","TMGMATH",188,0) ; "RTN","TMGMATH",189,0) ; "RTN","TMGMATH",190,0) ARCSIN(X,PREC) ; "RTN","TMGMATH",191,0) New L,LIM,K,SIGS,VALUE "RTN","TMGMATH",192,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",193,0) ; "RTN","TMGMATH",194,0) ;;;" If $Translate(X,"-")=1 Do Quit ;" Number ~~ "RTN","TMGMATH",195,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",196,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",197,0) If $Translate(X,"-")=1 Do Quit VALUE "RTN","TMGMATH",198,0) . ;;; "RTN","TMGMATH",199,0) . ; "RTN","TMGMATH",200,0) . Set VALUE=$%PI^MATH()/2*X "RTN","TMGMATH",201,0) . Quit "RTN","TMGMATH",202,0) ; "RTN","TMGMATH",203,0) ;;;" If X>0.99999 Do Quit ;" Number ~~ "RTN","TMGMATH",204,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",205,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",206,0) If X>0.99999 Do Quit VALUE "RTN","TMGMATH",207,0) . ;;; "RTN","TMGMATH",208,0) . ; "RTN","TMGMATH",209,0) . Set SIGS=$Select(X<0:-1,1:1) "RTN","TMGMATH",210,0) . Set VALUE=1/(1/X/X-1) "RTN","TMGMATH",211,0) . ; "RTN","TMGMATH",212,0) . ;;;" Set X=$%SQRT^MATH(VALUE) ;" Number ~~ "RTN","TMGMATH",213,0) . ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",214,0) . Set X=$%SQRT^MATH(VALUE,PREC) "RTN","TMGMATH",215,0) . ;;; "RTN","TMGMATH",216,0) . ; "RTN","TMGMATH",217,0) . ;;;" Set VALUE=$%ARCTAN^MATH(X,10)*SIGS ;" Number ~~ "RTN","TMGMATH",218,0) . ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",219,0) . Set VALUE=$%ARCTAN^MATH(X,PREC)*SIGS "RTN","TMGMATH",220,0) . ;;; "RTN","TMGMATH",221,0) . ; "RTN","TMGMATH",222,0) . Quit "RTN","TMGMATH",223,0) Set (VALUE,L)=X "RTN","TMGMATH",224,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",225,0) For K=3:2 Do Quit:($Translate(L,"-")HI:HI,1:X) "RTN","TMGMATH",253,0) ; "RTN","TMGMATH",254,0) ;;;" Set FOLD=$Select(X'<1:0,1:1), ;" Number ~~ "RTN","TMGMATH",255,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",256,0) Set FOLD=$Select(X'<1:0,1:1) "RTN","TMGMATH",257,0) ;;; "RTN","TMGMATH",258,0) ; "RTN","TMGMATH",259,0) Set X=$Select(FOLD:1/X,1:X) "RTN","TMGMATH",260,0) Set L=X,VALUE=$%PI^MATH()/2-(1/X),SIGN=1 "RTN","TMGMATH",261,0) ; "RTN","TMGMATH",262,0) ;;;" If X<1.3 Do Quit ;" Number ~~ "RTN","TMGMATH",263,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",264,0) ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",265,0) If X<1.3 Do Quit VALUE "RTN","TMGMATH",266,0) . ;;; "RTN","TMGMATH",267,0) . ; "RTN","TMGMATH",268,0) . Set X=$Select(FOLD:1/X,1:X),VALUE=1/((1/X/X)+1) "RTN","TMGMATH",269,0) . ; "RTN","TMGMATH",270,0) . ;;;" Set $%SQRT^MATH(VALUE) ;" Number ~~ "RTN","TMGMATH",271,0) . ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",272,0) . ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",273,0) . Set X=$%SQRT^MATH(VALUE,PREC) "RTN","TMGMATH",274,0) . ;;; "RTN","TMGMATH",275,0) . ; "RTN","TMGMATH",276,0) . If $Translate(X,"-")=1 Do Quit "RTN","TMGMATH",277,0) . . Set VALUE=$%PI^MATH()/2*X "RTN","TMGMATH",278,0) . . Quit "RTN","TMGMATH",279,0) . If X>0.9 Do Quit "RTN","TMGMATH",280,0) . . Set SIGS=$Select(X<0:-1,1:1) "RTN","TMGMATH",281,0) . . Set VALUE=1/(1/X/X-1) "RTN","TMGMATH",282,0) . . Set X=$%SQRT^MATH(VALUE) "RTN","TMGMATH",283,0) . . Set VALUE=$$ARCTAN(X,10) "RTN","TMGMATH",284,0) . . Set VALUE=VALUE*SIGS "RTN","TMGMATH",285,0) . . Quit "RTN","TMGMATH",286,0) . Set (VALUE,L)=X "RTN","TMGMATH",287,0) . Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",288,0) . For K=3:2 Do Quit:($Translate(L,"-")11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",294,0) For K=3:2 Do Quit:($Translate(1/L,"-")1 Set $Ecode=",M28," "RTN","TMGMATH",312,0) ; "RTN","TMGMATH",313,0) ;;;" ;" Number ~~ "RTN","TMGMATH",314,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",315,0) ;" Alan Frank (October 1995) "RTN","TMGMATH",316,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",317,0) ;;; "RTN","TMGMATH",318,0) ; "RTN","TMGMATH",319,0) Quit $%LOG^MATH(1+X/(1-X),PREC)/2 "RTN","TMGMATH",320,0) ;=== "RTN","TMGMATH",321,0) ; "RTN","TMGMATH",322,0) ; "RTN","TMGMATH",323,0) CABS(Z) ; "RTN","TMGMATH",324,0) New ZRE,ZIM "RTN","TMGMATH",325,0) Set ZRE=+Z,ZIM=+$Piece(Z,"%",2) "RTN","TMGMATH",326,0) Quit $%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM)) "RTN","TMGMATH",327,0) ;=== "RTN","TMGMATH",328,0) ; "RTN","TMGMATH",329,0) ; "RTN","TMGMATH",330,0) CADD(X,Y) ; "RTN","TMGMATH",331,0) New XRE,XIM,YRE,YIM "RTN","TMGMATH",332,0) Set XRE=+X,XIM=+$Piece(X,"%",2) "RTN","TMGMATH",333,0) Set YRE=+Y,YIM=+$Piece(Y,"%",2) "RTN","TMGMATH",334,0) Quit XRE+YRE_"%"_(XIM+YIM) "RTN","TMGMATH",335,0) ;=== "RTN","TMGMATH",336,0) ; "RTN","TMGMATH",337,0) ; "RTN","TMGMATH",338,0) CCOS(Z,PREC) ; "RTN","TMGMATH",339,0) New E1,E2,IA "RTN","TMGMATH",340,0) ; "RTN","TMGMATH",341,0) ;;;" ;" Number ~~ "RTN","TMGMATH",342,0) ;" Alan Frank (October 1995) "RTN","TMGMATH",343,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",344,0) ;;; "RTN","TMGMATH",345,0) ; "RTN","TMGMATH",346,0) Set IA=$%CMUL^MATH(Z,"0%1") "RTN","TMGMATH",347,0) Set E1=$%CEXP^MATH(IA,PREC) "RTN","TMGMATH",348,0) Set IA=-IA_"%"_(-$Piece(IA,"%",2)) "RTN","TMGMATH",349,0) Set E2=$%CEXP^MATH(IA,PREC) "RTN","TMGMATH",350,0) Set IA=$%CADD^MATH(E1,E2) "RTN","TMGMATH",351,0) Quit $%CMUL^MATH(IA,"0.5%0") "RTN","TMGMATH",352,0) ;=== "RTN","TMGMATH",353,0) ; "RTN","TMGMATH",354,0) ; "RTN","TMGMATH",355,0) CDIV(X,Y) ; "RTN","TMGMATH",356,0) New D,IM,RE,XIM,XRE,YIM,YRE "RTN","TMGMATH",357,0) Set XRE=+X,XIM=+$Piece(X,"%",2) "RTN","TMGMATH",358,0) Set YRE=+Y,YIM=+$Piece(Y,"%",2) "RTN","TMGMATH",359,0) Set D=YRE*YRE+(YIM*YIM) "RTN","TMGMATH",360,0) Set RE=XRE*YRE+(XIM*YIM)/D "RTN","TMGMATH",361,0) Set IM=XIM*YRE-(XRE*YIM)/D "RTN","TMGMATH",362,0) Quit RE_"%"_IM "RTN","TMGMATH",363,0) ;=== "RTN","TMGMATH",364,0) ; "RTN","TMGMATH",365,0) ; "RTN","TMGMATH",366,0) CEXP(Z,PREC) ; "RTN","TMGMATH",367,0) New R,ZIM,ZRE "RTN","TMGMATH",368,0) ; "RTN","TMGMATH",369,0) ;;;" ;" Number ~~ "RTN","TMGMATH",370,0) ;" Alan Frank (October 1995) "RTN","TMGMATH",371,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",372,0) ;;; "RTN","TMGMATH",373,0) ; "RTN","TMGMATH",374,0) Set ZRE=+Z,ZIM=+$Piece(Z,"%",2) "RTN","TMGMATH",375,0) Set R=$%EXP^MATH(ZRE,PREC) "RTN","TMGMATH",376,0) Quit R*$%COS^MATH(ZIM,PREC)_"%"_(R*$%SIN^MATH(ZIM,PREC)) "RTN","TMGMATH",377,0) ;=== "RTN","TMGMATH",378,0) ; "RTN","TMGMATH",379,0) ; "RTN","TMGMATH",380,0) CLOG(Z,PREC) ; "RTN","TMGMATH",381,0) New ABS,ARG,ZIM,ZRE "RTN","TMGMATH",382,0) ; "RTN","TMGMATH",383,0) ;;;" ;" Number ~~ "RTN","TMGMATH",384,0) ;" Alan Frank (October 1995) "RTN","TMGMATH",385,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",386,0) ;;; "RTN","TMGMATH",387,0) ; "RTN","TMGMATH",388,0) Set ABS=$%CABS^MATH(Z) "RTN","TMGMATH",389,0) Set ZRE=+Z,ZIM=+$Piece(Z,"%",2) "RTN","TMGMATH",390,0) ; "RTN","TMGMATH",391,0) ;;;" Set ARG=$%ARCTAN^MATH(ZIM,ZRE,PREC) ;" Number ~~ "RTN","TMGMATH",392,0) ;" Alan Frank (October 1995) "RTN","TMGMATH",393,0) Set ARG=$%ARCTAN^MATH(ZIM/ZRE,PREC) "RTN","TMGMATH",394,0) ;;; "RTN","TMGMATH",395,0) ; "RTN","TMGMATH",396,0) Quit $%LOG^MATH(ABS,PREC)_"%"_ARG "RTN","TMGMATH",397,0) ;=== "RTN","TMGMATH",398,0) ; "RTN","TMGMATH",399,0) ; "RTN","TMGMATH",400,0) CMUL(X,Y) ; "RTN","TMGMATH",401,0) New XIM,XRE,YIM,YRE "RTN","TMGMATH",402,0) Set XRE=+X,XIM=+$Piece(X,"%",2) "RTN","TMGMATH",403,0) Set YRE=+Y,YIM=+$Piece(Y,"%",2) "RTN","TMGMATH",404,0) Quit XRE*YRE-(XIM*YIM)_"%"_(XRE*YIM+(XIM*YRE)) "RTN","TMGMATH",405,0) ;=== "RTN","TMGMATH",406,0) ; "RTN","TMGMATH",407,0) ; "RTN","TMGMATH",408,0) COMPLEX(X) Quit +X_"%0" "RTN","TMGMATH",409,0) ;=== "RTN","TMGMATH",410,0) ; "RTN","TMGMATH",411,0) ; "RTN","TMGMATH",412,0) CONJUG(Z) ; "RTN","TMGMATH",413,0) New ZIM,ZRE "RTN","TMGMATH",414,0) Set ZRE=+Z,ZIM=+$Piece(Z,"%",2) "RTN","TMGMATH",415,0) Quit ZRE_"%"_(-ZIM) "RTN","TMGMATH",416,0) ;=== "RTN","TMGMATH",417,0) ; "RTN","TMGMATH",418,0) ; "RTN","TMGMATH",419,0) COS(X,PREC) ; "RTN","TMGMATH",420,0) New L,LIM,K,SIGN,VALUE "RTN","TMGMATH",421,0) ; "RTN","TMGMATH",422,0) ;;;" Set:X[":" X=$%DMSDEC^MATH(X,12) ;" Number ~~ "RTN","TMGMATH",423,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",424,0) ;" Comment: The official description does not mention than "RTN","TMGMATH",425,0) ;" the function may also be called with the first "RTN","TMGMATH",426,0) ;" parameter in degrees, minutes and seconds. "RTN","TMGMATH",427,0) Set:X[":" X=$%DMSDEC^MATH(X) "RTN","TMGMATH",428,0) ;;; "RTN","TMGMATH",429,0) ; "RTN","TMGMATH",430,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",431,0) Set X=X#(2*$%PI^MATH()) "RTN","TMGMATH",432,0) Set (VALUE,L)=1,SIGN=-1 "RTN","TMGMATH",433,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",434,0) For K=2:2 Do Quit:($Translate(L,"-")PI X=2*PI-X "RTN","TMGMATH",459,0) Set:X*2>PI X=PI-X,SIGN=-1 "RTN","TMGMATH",460,0) ; "RTN","TMGMATH",461,0) Set XX=X*X,A(1)=-0.4999999963,A(2)=0.0416666418 "RTN","TMGMATH",462,0) Set A(3)=-0.0013888397,A(4)=0.0000247609,A(5)=-0.0000002605 "RTN","TMGMATH",463,0) Set (X,R)=1 For N=1:1:5 Set X=X*XX,R=A(N)*X+R "RTN","TMGMATH",464,0) Quit R*SIGN "RTN","TMGMATH",465,0) ;=== "RTN","TMGMATH",466,0) ; "RTN","TMGMATH",467,0) ; "RTN","TMGMATH",468,0) COSH(X,PREC) ; "RTN","TMGMATH",469,0) ; "RTN","TMGMATH",470,0) ;;;" New F,I,P,R,T,XX ;" Number ~~ "RTN","TMGMATH",471,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",472,0) New E,F,I,P,R,T,XX "RTN","TMGMATH",473,0) ;;; "RTN","TMGMATH",474,0) ; "RTN","TMGMATH",475,0) Set PREC=$Get(PREC,11)+1 "RTN","TMGMATH",476,0) Set @("E=1E-"_PREC) "RTN","TMGMATH",477,0) Set XX=X*X,F=1,(P,R,T)=1,I=1 "RTN","TMGMATH",478,0) For Set T=T*XX,F=I+1*I*F,R=T/F+R,P=P-R/R,I=I+2 If -E11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",497,0) For K=2:2 Do Quit:($Translate(L,"-")11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",504,0) For K=3:2 Do Quit:($Translate(L,"-")0:PI/2,1:-PI/2) ;" Number ~~ "RTN","TMGMATH",560,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",561,0) Else Set TH=$SELECT(ZIM>0:PI/2,1:-PI/2) "RTN","TMGMATH",562,0) ;;; "RTN","TMGMATH",563,0) ; "RTN","TMGMATH",564,0) Set RHO=$%LOG^MATH(R,PREC) "RTN","TMGMATH",565,0) Set AR=$%EXP^MATH(RHO*NRE-(TH*NIM),PREC) "RTN","TMGMATH",566,0) Set PHI=RHO*NIM+(NRE*TH) "RTN","TMGMATH",567,0) Quit AR*$%COS^MATH(PHI,PREC)_"%"_(AR*$%SIN^MATH(PHI,PREC)) "RTN","TMGMATH",568,0) ;=== "RTN","TMGMATH",569,0) ; "RTN","TMGMATH",570,0) ; "RTN","TMGMATH",571,0) CSC(X,PREC) ; "RTN","TMGMATH",572,0) New L,LIM,K,SIGN,VALUE "RTN","TMGMATH",573,0) ; "RTN","TMGMATH",574,0) ;;;" Set:X[":" X=$%DMSDEC^MATH(X,12) ;" Number ~~ "RTN","TMGMATH",575,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",576,0) ;" Comment: The official description does not mention than "RTN","TMGMATH",577,0) ;" the function may also be called with the first "RTN","TMGMATH",578,0) ;" parameter in degrees, minutes and seconds. "RTN","TMGMATH",579,0) Set:X[":" X=$%DMSDEC^MATH(X) "RTN","TMGMATH",580,0) ;;; "RTN","TMGMATH",581,0) ; "RTN","TMGMATH",582,0) ;;;" Set PREC=$Select($Data(PREC)#2:PREC,1:10) ;" Number ~~ "RTN","TMGMATH",583,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",584,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",585,0) ;;; "RTN","TMGMATH",586,0) ; "RTN","TMGMATH",587,0) Set X=X#(2*$%PI^MATH()) "RTN","TMGMATH",588,0) Set (VALUE,L)=X,SIGN=-1 "RTN","TMGMATH",589,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",590,0) For K=3:2 Do Quit:($Translate(L,"-")11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",660,0) For K=2:1 Set L=L*X/K,VALUE=VALUE+L Quit:($Translate(L,"-")0 Set $Ecode=",M28," "RTN","TMGMATH",668,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",669,0) Set M=1 "RTN","TMGMATH",670,0) ; "RTN","TMGMATH",671,0) ;;;" If X>0 For N=0:1 Quit:(X/M)<10 Set M=M*10 ;" Number ~~ "RTN","TMGMATH",672,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",673,0) For N=0:1 Quit:(X/M)<10 Set M=M*10 "RTN","TMGMATH",674,0) ;;; "RTN","TMGMATH",675,0) ; "RTN","TMGMATH",676,0) If X<1 For N=0:-1 Quit:(X/M)>0.1 Set M=M*0.1 "RTN","TMGMATH",677,0) Set X=X/M "RTN","TMGMATH",678,0) Set X=(X-1)/(X+1),(VALUE,L)=X "RTN","TMGMATH",679,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",680,0) For K=3:2 Set L=L*X*X,M=L/K,VALUE=M+VALUE Set:M<0 M=-M Quit:M0 Set $Ecode=",M28," "RTN","TMGMATH",689,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",690,0) Set M=1 "RTN","TMGMATH",691,0) ; "RTN","TMGMATH",692,0) ;;;" If X>0 For N=0:1 Quit:(X/M)<10 Set M=M*10 ;" Number ~~ "RTN","TMGMATH",693,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",694,0) For N=0:1 Quit:(X/M)<10 Set M=M*10 "RTN","TMGMATH",695,0) ;;; "RTN","TMGMATH",696,0) ; "RTN","TMGMATH",697,0) If X<1 For N=0:-1 Quit:(X/M)>0.1 Set M=M*0.1 "RTN","TMGMATH",698,0) Set X=X/M "RTN","TMGMATH",699,0) Set X=(X-1)/(X+1),(VALUE,L)=X "RTN","TMGMATH",700,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",701,0) For K=3:2 Set L=L*X*X,M=L/K,VALUE=M+VALUE Set:M<0 M=-M Quit:M$TRANSLATE(TEMP,"-") "RTN","TMGMATH",802,0) . . SET TEMP=T(J1,K),J2=J1 "RTN","TMGMATH",803,0) . . QUIT "RTN","TMGMATH",804,0) . ; "RTN","TMGMATH",805,0) . ;" Exchange row number K with row number J2, "RTN","TMGMATH",806,0) . ;" if necessary "RTN","TMGMATH",807,0) . ; "RTN","TMGMATH",808,0) . DO:J2'=K "RTN","TMGMATH",809,0) . . ; "RTN","TMGMATH",810,0) . . FOR J=K:1:N DO "RTN","TMGMATH",811,0) . . . SET T1=$GET(T(K,J)),T2=$GET(T(J2,J)) "RTN","TMGMATH",812,0) . . . KILL T(K,J),T(J2,J) "RTN","TMGMATH",813,0) . . . IF T1'="" SET T(J2,J)=T1 "RTN","TMGMATH",814,0) . . . IF T2'="" SET T(K,J)=T2 "RTN","TMGMATH",815,0) . . . QUIT "RTN","TMGMATH",816,0) . . FOR J=1:1:M DO "RTN","TMGMATH",817,0) . . . SET T1=$GET(R(K,J)),T2=$GET(R(J2,J)) "RTN","TMGMATH",818,0) . . . KILL R(K,J),R(J2,J) "RTN","TMGMATH",819,0) . . . IF T1'="" SET R(J2,J)=T1 "RTN","TMGMATH",820,0) . . . IF T2'="" SET R(K,J)=T2 "RTN","TMGMATH",821,0) . . . QUIT "RTN","TMGMATH",822,0) . . QUIT "RTN","TMGMATH",823,0) . ; "RTN","TMGMATH",824,0) . ;" Actual reduction "RTN","TMGMATH",825,0) . ; "RTN","TMGMATH",826,0) . FOR I=K+1:1:N DO "RTN","TMGMATH",827,0) . . FOR J=K+1:1:N DO "RTN","TMGMATH",828,0) . . . QUIT:'$GET(T(K,K)) "RTN","TMGMATH",829,0) . . . SET T(I,J)=-$GET(T(K,J))*$GET(T(I,K))/T(K,K)+$GET(T(I,J)) "RTN","TMGMATH",830,0) . . . QUIT "RTN","TMGMATH",831,0) . . FOR J=1:1:M DO "RTN","TMGMATH",832,0) . . . QUIT:'$GET(T(K,K)) "RTN","TMGMATH",833,0) . . . SET R(I,J)=-$GET(R(K,J))*$GET(T(I,K))/T(K,K)+$GET(R(I,J)) "RTN","TMGMATH",834,0) . . . QUIT "RTN","TMGMATH",835,0) . . QUIT "RTN","TMGMATH",836,0) . QUIT "RTN","TMGMATH",837,0) ; "RTN","TMGMATH",838,0) ;" Backsubstitution "RTN","TMGMATH",839,0) ; "RTN","TMGMATH",840,0) FOR J=1:1:M DO "RTN","TMGMATH",841,0) . IF $GET(T(N,N)) SET R(N,J)=$GET(R(N,J))/T(N,N) "RTN","TMGMATH",842,0) . IF N-1>0 FOR I1=1:1:N-1 DO "RTN","TMGMATH",843,0) . . SET I=N-I1 "RTN","TMGMATH",844,0) . . FOR L=I+1:1:N DO "RTN","TMGMATH",845,0) . . . SET R(I,J)=-$GET(T(I,L))*$GET(R(L,J))+$GET(R(I,J)) "RTN","TMGMATH",846,0) . . . QUIT "RTN","TMGMATH",847,0) . . IF $GET(T(I,I)) SET R(I,J)=$GET(R(I,J))/$GET(T(I,I)) "RTN","TMGMATH",848,0) . . QUIT "RTN","TMGMATH",849,0) . QUIT "RTN","TMGMATH",850,0) ;;;QUIT $%MTXDET^MATH(.R) "RTN","TMGMATH",851,0) ;" Ed de Moel, 29 Aug 1999 "RTN","TMGMATH",852,0) QUIT $SELECT(M=N:$%MTXDET^MATH(.R,M),1:1) "RTN","TMGMATH",853,0) ;;; "RTN","TMGMATH",854,0) ;=== "RTN","TMGMATH",855,0) ; "RTN","TMGMATH",856,0) MTXINV(A,R,N) ; "RTN","TMGMATH",857,0) ;" Invert A[N,N], result goes to R[N,N] "RTN","TMGMATH",858,0) IF $DATA(A)<10 QUIT 0 "RTN","TMGMATH",859,0) IF $GET(N)<1 QUIT 0 "RTN","TMGMATH",860,0) ; "RTN","TMGMATH",861,0) NEW T,X "RTN","TMGMATH",862,0) SET X=$%MTXUNIT^MATH(.T,N) "RTN","TMGMATH",863,0) QUIT $%MTXEQU^MATH(.A,.T,.R,N,N) "RTN","TMGMATH",864,0) ;=== "RTN","TMGMATH",865,0) ; "RTN","TMGMATH",866,0) ; "RTN","TMGMATH",867,0) MTXMUL(A,B,R,M,L,N) ; "RTN","TMGMATH",868,0) ;" Multiply A[M,L] by B[L,N], result goes to R[M,N] "RTN","TMGMATH",869,0) IF $DATA(A)<10 QUIT 0 "RTN","TMGMATH",870,0) IF $DATA(B)<10 QUIT 0 "RTN","TMGMATH",871,0) IF $GET(L)<1 QUIT 0 "RTN","TMGMATH",872,0) IF $GET(M)<1 QUIT 0 "RTN","TMGMATH",873,0) IF $GET(N)<1 QUIT 0 "RTN","TMGMATH",874,0) ; "RTN","TMGMATH",875,0) NEW I,J,K,SUM,ANY "RTN","TMGMATH",876,0) FOR I=1:1:M FOR J=1:1:N DO "RTN","TMGMATH",877,0) . SET (SUM,ANY)=0 "RTN","TMGMATH",878,0) . KVALUE R(I,J) "RTN","TMGMATH",879,0) . FOR K=1:1:L DO "RTN","TMGMATH",880,0) . . SET:$DATA(A(I,K))#2 ANY=1 "RTN","TMGMATH",881,0) . . SET:$DATA(B(K,J))#2 ANY=1 "RTN","TMGMATH",882,0) . . SET SUM=$GET(A(I,K))*$GET(B(K,J))+SUM "RTN","TMGMATH",883,0) . . QUIT "RTN","TMGMATH",884,0) . SET:ANY R(I,J)=SUM "RTN","TMGMATH",885,0) . QUIT "RTN","TMGMATH",886,0) QUIT 1 "RTN","TMGMATH",887,0) ;=== "RTN","TMGMATH",888,0) ; "RTN","TMGMATH",889,0) ; "RTN","TMGMATH",890,0) MTXSCA(A,R,ROWS,COLS,S) ; "RTN","TMGMATH",891,0) ;" Multiply A[ROWS,COLS] with the scalar S, "RTN","TMGMATH",892,0) ;" result goes to R[ROWS,COLS] "RTN","TMGMATH",893,0) IF $DATA(A)<10 QUIT 0 "RTN","TMGMATH",894,0) IF $GET(ROWS)<1 QUIT 0 "RTN","TMGMATH",895,0) IF $GET(COLS)<1 QUIT 0 "RTN","TMGMATH",896,0) IF '($DATA(S)#2) QUIT 0 "RTN","TMGMATH",897,0) ; "RTN","TMGMATH",898,0) NEW ROW,COL "RTN","TMGMATH",899,0) FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO "RTN","TMGMATH",900,0) . KVALUE R(ROW,COL) "RTN","TMGMATH",901,0) . SET:$DATA(A(ROW,COL))#2 R(ROW,COL)=A(ROW,COL)*S "RTN","TMGMATH",902,0) . QUIT "RTN","TMGMATH",903,0) QUIT 1 "RTN","TMGMATH",904,0) ;=== "RTN","TMGMATH",905,0) ; "RTN","TMGMATH",906,0) ; "RTN","TMGMATH",907,0) MTXSUB(A,B,R,ROWS,COLS) ; "RTN","TMGMATH",908,0) ;" Subtract B[ROWS,COLS] from A[ROWS,COLS], "RTN","TMGMATH",909,0) ;" result goes to R[ROWS,COLS] "RTN","TMGMATH",910,0) IF $DATA(A)<10 QUIT 0 "RTN","TMGMATH",911,0) IF $DATA(B)<10 QUIT 0 "RTN","TMGMATH",912,0) IF $GET(ROWS)<1 QUIT 0 "RTN","TMGMATH",913,0) IF $GET(COLS)<1 QUIT 0 "RTN","TMGMATH",914,0) ; "RTN","TMGMATH",915,0) NEW ROW,COL,ANY "RTN","TMGMATH",916,0) FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO "RTN","TMGMATH",917,0) . KVALUE R(ROW,COL) SET ANY=0 "RTN","TMGMATH",918,0) . SET:$DATA(A(ROW,COL))#2 ANY=1 "RTN","TMGMATH",919,0) . SET:$DATA(B(ROW,COL))#2 ANY=1 "RTN","TMGMATH",920,0) . ; "RTN","TMGMATH",921,0) . ;;;" SET:ANY R(ROW,COL)=$GET(A(ROW,COL)-$GET(B(ROW,COL)) ;" Number ~~ "RTN","TMGMATH",922,0) . ;" Eli Reidler (28 June 1996) "RTN","TMGMATH",923,0) . SET:ANY R(ROW,COL)=$GET(A(ROW,COL))-$GET(B(ROW,COL)) "RTN","TMGMATH",924,0) . ;;; "RTN","TMGMATH",925,0) . ; "RTN","TMGMATH",926,0) . QUIT "RTN","TMGMATH",927,0) QUIT 1 "RTN","TMGMATH",928,0) ;=== "RTN","TMGMATH",929,0) ; "RTN","TMGMATH",930,0) ; "RTN","TMGMATH",931,0) MTXTRP(A,R,M,N) ; "RTN","TMGMATH",932,0) ;" Transpose A[M,N], result goes to R[N,M] "RTN","TMGMATH",933,0) IF $DATA(A)<10 QUIT 0 "RTN","TMGMATH",934,0) IF $GET(M)<1 QUIT 0 "RTN","TMGMATH",935,0) IF $GET(N)<1 QUIT 0 "RTN","TMGMATH",936,0) ; "RTN","TMGMATH",937,0) NEW I,J,K,D1,V1,D2,V2 "RTN","TMGMATH",938,0) FOR I=1:1:M+N-1 FOR J=1:1:I+1\2 DO "RTN","TMGMATH",939,0) . SET K=I-J+1 "RTN","TMGMATH",940,0) . IF K=J DO QUIT "RTN","TMGMATH",941,0) . . SET V1=$GET(A(J,J)),D1=$DATA(A(J,J))#2 "RTN","TMGMATH",942,0) . . IF J'>N,J'>M KVALUE R(J,J) SET:D1 R(J,J)=V1 "RTN","TMGMATH",943,0) . . QUIT "RTN","TMGMATH",944,0) . ; "RTN","TMGMATH",945,0) . SET V1=$GET(A(K,J)),D1=$DATA(A(K,J))#2 "RTN","TMGMATH",946,0) . SET V2=$GET(A(J,K)),D2=$DATA(A(J,K))#2 "RTN","TMGMATH",947,0) . IF K'>M,J'>N KVALUE R(K,J) SET:D2 R(K,J)=V2 "RTN","TMGMATH",948,0) . IF J'>M,K'>N KVALUE R(J,K) SET:D1 R(J,K)=V1 "RTN","TMGMATH",949,0) . QUIT "RTN","TMGMATH",950,0) QUIT 1 "RTN","TMGMATH",951,0) ;=== "RTN","TMGMATH",952,0) ; "RTN","TMGMATH",953,0) ; "RTN","TMGMATH",954,0) MTXUNIT(R,N,SPARSE) ; "RTN","TMGMATH",955,0) ;" Create a unit matrix R[N,N] "RTN","TMGMATH",956,0) IF $GET(N)<1 QUIT 0 "RTN","TMGMATH",957,0) ; "RTN","TMGMATH",958,0) NEW ROW,COL "RTN","TMGMATH",959,0) FOR ROW=1:1:N FOR COL=1:1:N DO "RTN","TMGMATH",960,0) . KVALUE R(ROW,COL) "RTN","TMGMATH",961,0) . IF $GET(SPARSE) QUIT:ROW'=COL "RTN","TMGMATH",962,0) . SET R(ROW,COL)=$SELECT(ROW=COL:1,1:0) "RTN","TMGMATH",963,0) . QUIT "RTN","TMGMATH",964,0) QUIT 1 "RTN","TMGMATH",965,0) ;=== "RTN","TMGMATH",966,0) ; "RTN","TMGMATH",967,0) ; "RTN","TMGMATH",968,0) PI() Quit 3.14159265358979 "RTN","TMGMATH",969,0) ;=== "RTN","TMGMATH",970,0) ; "RTN","TMGMATH",971,0) ; "RTN","TMGMATH",972,0) PRODUCE(IN,SPEC,MAX) ; "RTN","TMGMATH",973,0) NEW VALUE,AGAIN,P1,P2,I,COUNT "RTN","TMGMATH",974,0) SET VALUE=IN,COUNT=0 "RTN","TMGMATH",975,0) FOR DO QUIT:'AGAIN "RTN","TMGMATH",976,0) . SET AGAIN=0 "RTN","TMGMATH",977,0) . SET I="" "RTN","TMGMATH",978,0) . FOR SET I=$ORDER(SPEC(I)) QUIT:I="" DO QUIT:COUNT<0 "RTN","TMGMATH",979,0) . . QUIT:$GET(SPEC(I,1))="" "RTN","TMGMATH",980,0) . . QUIT:'($DATA(SPEC(I,2))#2) "RTN","TMGMATH",981,0) . . FOR QUIT:VALUE'[SPEC(I,1) DO QUIT:COUNT<0 "RTN","TMGMATH",982,0) . . . SET P1=$PIECE(VALUE,SPEC(I,1),1) "RTN","TMGMATH",983,0) . . . SET P2=$PIECE(VALUE,SPEC(I,1),2,$LENGTH(VALUE)) "RTN","TMGMATH",984,0) . . . SET VALUE=P1_SPEC(I,2)_P2,AGAIN=1 "RTN","TMGMATH",985,0) . . . SET COUNT=COUNT+1 "RTN","TMGMATH",986,0) . . . IF $DATA(MAX),COUNT>MAX SET COUNT=-1,AGAIN=0 "RTN","TMGMATH",987,0) . . . QUIT "RTN","TMGMATH",988,0) . . QUIT "RTN","TMGMATH",989,0) . QUIT "RTN","TMGMATH",990,0) QUIT VALUE "RTN","TMGMATH",991,0) ;=== "RTN","TMGMATH",992,0) ; "RTN","TMGMATH",993,0) ; "RTN","TMGMATH",994,0) RADDEG(X) Quit X*180/3.14159265358979 "RTN","TMGMATH",995,0) ;=== "RTN","TMGMATH",996,0) ; "RTN","TMGMATH",997,0) ; "RTN","TMGMATH",998,0) REPLACE(IN,SPEC) ; "RTN","TMGMATH",999,0) NEW L,MASK,K,I,LT,F,VALUE "RTN","TMGMATH",1000,0) SET L=$LENGTH(IN),MASK=$JUSTIFY("",L) "RTN","TMGMATH",1001,0) SET I="" FOR SET I=$ORDER(SPEC(I)) QUIT:I="" DO "RTN","TMGMATH",1002,0) . QUIT:'($DATA(SPEC(I,1))#2) "RTN","TMGMATH",1003,0) . QUIT:SPEC(I,1)="" "RTN","TMGMATH",1004,0) . QUIT:'($DATA(SPEC(I,2))#2) "RTN","TMGMATH",1005,0) . SET LT=$LENGTH(SPEC(I,1)) "RTN","TMGMATH",1006,0) . SET F=0 FOR SET F=$FIND(IN,SPEC(I,1),F) QUIT:F<1 DO "RTN","TMGMATH",1007,0) . . QUIT:$EXTRACT(MASK,F-LT,F-1)["X" "RTN","TMGMATH",1008,0) . . SET VALUE(F-LT)=SPEC(I,2) "RTN","TMGMATH",1009,0) . . SET $EXTRACT(MASK,F-LT,F-1)=$TRANSLATE($JUSTIFY("",LT)," ","X") "RTN","TMGMATH",1010,0) . . QUIT "RTN","TMGMATH",1011,0) . QUIT "RTN","TMGMATH",1012,0) SET VALUE="" FOR K=1:1:L DO "RTN","TMGMATH",1013,0) . IF $EXTRACT(MASK,K)=" " SET VALUE=VALUE_$EXTRACT(IN,K) QUIT "RTN","TMGMATH",1014,0) . SET:$DATA(VALUE(K)) VALUE=VALUE_VALUE(K) "RTN","TMGMATH",1015,0) . QUIT "RTN","TMGMATH",1016,0) QUIT VALUE "RTN","TMGMATH",1017,0) ;=== "RTN","TMGMATH",1018,0) ; "RTN","TMGMATH",1019,0) ; "RTN","TMGMATH",1020,0) SEC(X,PREC) ; "RTN","TMGMATH",1021,0) New L,LIM,K,SIGN,VALUE "RTN","TMGMATH",1022,0) ; "RTN","TMGMATH",1023,0) ;;;" Set:X[":" X=$%DMSDEC^MATH(X,12) ;" Number ~~ "RTN","TMGMATH",1024,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",1025,0) ;" Comment: The official description does not mention than "RTN","TMGMATH",1026,0) ;" the function may also be called with the first "RTN","TMGMATH",1027,0) ;" parameter in degrees, minutes and seconds. "RTN","TMGMATH",1028,0) Set:X[":" X=$%DMSDEC^MATH(X) "RTN","TMGMATH",1029,0) ;;; "RTN","TMGMATH",1030,0) ; "RTN","TMGMATH",1031,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",1032,0) Set X=X#(2*$%PI^MATH()) "RTN","TMGMATH",1033,0) Set (VALUE,L)=1,SIGN=-1 "RTN","TMGMATH",1034,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",1035,0) For K=2:2 Do Quit:($Translate(L,"-")0:1,1:0) "RTN","TMGMATH",1052,0) ;=== "RTN","TMGMATH",1053,0) ; "RTN","TMGMATH",1054,0) ; "RTN","TMGMATH",1055,0) SIN(X,PREC) ; "RTN","TMGMATH",1056,0) New L,LIM,K,SIGN,VALUE "RTN","TMGMATH",1057,0) ; "RTN","TMGMATH",1058,0) ;;;" Set:X[":" X=$%DMSDEC^MATH(X,12) ;" Number ~~ "RTN","TMGMATH",1059,0) ;" Winfried Gerum (8 June 1995) "RTN","TMGMATH",1060,0) ;" Comment: The official description does not mention than "RTN","TMGMATH",1061,0) ;" the function may also be called with the first "RTN","TMGMATH",1062,0) ;" parameter in degrees, minutes and seconds. "RTN","TMGMATH",1063,0) Set:X[":" X=$%DMSDEC^MATH(X) "RTN","TMGMATH",1064,0) ;;; "RTN","TMGMATH",1065,0) ; "RTN","TMGMATH",1066,0) Set PREC=$Get(PREC,11) "RTN","TMGMATH",1067,0) Set X=X#(2*$%PI^MATH()) "RTN","TMGMATH",1068,0) Set (VALUE,L)=X,SIGN=-1 "RTN","TMGMATH",1069,0) Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",1070,0) For K=3:2 Do Quit:($Translate(L,"-")PI X=2*PI-X,SIGN=-1 "RTN","TMGMATH",1095,0) ; "RTN","TMGMATH",1096,0) ;;;" Set:X*211:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",1170,0) For K=3:2 Do Quit:($Translate(L,"-")11:PREC+3,1:11),@("LIM=1E-"_LIM) "RTN","TMGMATH",1177,0) For K=2:2 Do Quit:($Translate(L,"-")0) do "RTN","TMGMEDIC",56,0) . set DoAll="Y" "RTN","TMGMEDIC",57,0) else do "RTN","TMGMEDIC",58,0) . read "Convert all files in same directory? YES// ",DoAll:$get(DTIME,3600),! "RTN","TMGMEDIC",59,0) if DoAll="" set DoAll="Y" "RTN","TMGMEDIC",60,0) set DoAll=$$UP^XLFSTR(DoAll) "RTN","TMGMEDIC",61,0) if DoAll["Y" do "RTN","TMGMEDIC",62,0) . new result "RTN","TMGMEDIC",63,0) . set TMGMask("*")="" "RTN","TMGMEDIC",64,0) . set result=$$LIST^%ZISH(JustPath,"TMGMask","TMGFiles") "RTN","TMGMEDIC",65,0) else do "RTN","TMGMEDIC",66,0) . set TMGFiles(JustFile)="" "RTN","TMGMEDIC",67,0) if DoAll="^" goto FDCDone "RTN","TMGMEDIC",68,0) "RTN","TMGMEDIC",69,0) for do quit:(DestDir'="") "RTN","TMGMEDIC",70,0) . set s="Enter DESTINATION directory to move originals file(s) into after conversion.\n Leave blank to NOT move." "RTN","TMGMEDIC",71,0) . new Discard "RTN","TMGMEDIC",72,0) . set Discard=$$GetFName^TMGIOUTL(s,JustPath_"originals/","","",.DestDir,,"Enter Directory Name (? for Help): ") "RTN","TMGMEDIC",73,0) . write ! "RTN","TMGMEDIC",74,0) . if DestDir=JustPath set DestDir=NoDestDir quit "RTN","TMGMEDIC",75,0) "RTN","TMGMEDIC",76,0) set FileName=$order(TMGFiles("")) "RTN","TMGMEDIC",77,0) if FileName'="" for do quit:(FileName="")!(abort=1) "RTN","TMGMEDIC",78,0) . new skipThis set skipThis=SkipExisting "RTN","TMGMEDIC",79,0) . new isDir set isDir=0 "RTN","TMGMEDIC",80,0) . set FullNamePath=JustPath_FileName "RTN","TMGMEDIC",81,0) . if $$IsDir^TMGIOUTL(FullNamePath) set skipThis=1,isDir=1 "RTN","TMGMEDIC",82,0) . if (skipThis=0)&(noAskSkip=0)&($$FileExists^TMGIOUTL(FullNamePath_".vista")) do quit:(abort) "RTN","TMGMEDIC",83,0) . . new redo "RTN","TMGMEDIC",84,0) . . write "File ",FullNamePath," has already been converted.",! "RTN","TMGMEDIC",85,0) . . read "Convert anyway? (Yes/No/Yes-Always/No-Always) (Y/N/YA/NA/^) YA// ",redo:$get(DTIME,3600),! "RTN","TMGMEDIC",86,0) . . set redo=$$UP^XLFSTR(redo) "RTN","TMGMEDIC",87,0) . . if redo="" set redo="YA" "RTN","TMGMEDIC",88,0) . . if redo="^" set abort=1 quit "RTN","TMGMEDIC",89,0) . . if redo="YA" set noAskSkip=1 "RTN","TMGMEDIC",90,0) . . if redo="NA" set SkipExisting=1,skipThis=1 "RTN","TMGMEDIC",91,0) . . if "NO"[redo set skipThis=1 "RTN","TMGMEDIC",92,0) . if (FullNamePath'[".vista")&(skipThis=0) do "RTN","TMGMEDIC",93,0) . . write !,"Converting file: ",FullNamePath,"...",! "RTN","TMGMEDIC",94,0) . . write "--------------------------------------------------------",! "RTN","TMGMEDIC",95,0) . . set result=$$CONVDICT(FullNamePath,.OfficeLoc) "RTN","TMGMEDIC",96,0) . . if result'>0 do "RTN","TMGMEDIC",97,0) . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error converting file.") "RTN","TMGMEDIC",98,0) . . . set PriorErrorFound=0 ;"clear errors, to allow reporting of future errors. "RTN","TMGMEDIC",99,0) . . . set ErrorFiles(FullNamePath)=1 "RTN","TMGMEDIC",100,0) . . . if result=-1 set abort=1 quit "RTN","TMGMEDIC",101,0) . . else if DestDir'=NoDestDir do "RTN","TMGMEDIC",102,0) . . . new Dest set Dest=DestDir_FileName "RTN","TMGMEDIC",103,0) . . . ;"write "Moving: ",FullNamePath,! "RTN","TMGMEDIC",104,0) . . . ;"write "To: ",Dest,! "RTN","TMGMEDIC",105,0) . . . if $$Move^TMGIOUTL(FullNamePath,Dest)=0 do "RTN","TMGMEDIC",106,0) . . . . write "Moved ",FileName,!," to: ",Dest,! "RTN","TMGMEDIC",107,0) . if (skipThis=1)&(FullNamePath'[".vista")&(isDir=0) do "RTN","TMGMEDIC",108,0) . . write "Skipping over file, as requested: ",FullNamePath,! "RTN","TMGMEDIC",109,0) . set FileName=$order(TMGFiles(FileName)) "RTN","TMGMEDIC",110,0) "RTN","TMGMEDIC",111,0) if $data(ErrorFiles) do "RTN","TMGMEDIC",112,0) . write !!,"The following files contained notes with errors...",! "RTN","TMGMEDIC",113,0) . set FileName=$order(ErrorFiles("")) "RTN","TMGMEDIC",114,0) . if FileName'="" for do quit:(FileName="") "RTN","TMGMEDIC",115,0) . . write FileName,! "RTN","TMGMEDIC",116,0) . . set FileName=$order(ErrorFiles(FileName)) "RTN","TMGMEDIC",117,0) "RTN","TMGMEDIC",118,0) FDCDone "RTN","TMGMEDIC",119,0) write !,"Goodbye.",! "RTN","TMGMEDIC",120,0) quit "RTN","TMGMEDIC",121,0) "RTN","TMGMEDIC",122,0) "RTN","TMGMEDIC",123,0) ASKCONVD "RTN","TMGMEDIC",124,0) ;"Purpose: To convert files created for old Medic system into format ready for "RTN","TMGMEDIC",125,0) ;" upload into VistA "RTN","TMGMEDIC",126,0) ;"Input: None (Filename will be asked) "RTN","TMGMEDIC",127,0) ;"Output: none (A new file will be created at same site as old file, with .vista extension "RTN","TMGMEDIC",128,0) ;"Result: none "RTN","TMGMEDIC",129,0) "RTN","TMGMEDIC",130,0) new FullNamePath "RTN","TMGMEDIC",131,0) new JustFile,JustPath "RTN","TMGMEDIC",132,0) new result "RTN","TMGMEDIC",133,0) new PriorErrorFound "RTN","TMGMEDIC",134,0) "RTN","TMGMEDIC",135,0) set FullNamePath=$$GetFName^TMGIOUTL("Please select Medic transcription file to convert","/","","",.JustPath,.JustFile) "RTN","TMGMEDIC",136,0) if FullNamePath="" do goto CDDone "RTN","TMGMEDIC",137,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"No file selected. Aborting") "RTN","TMGMEDIC",138,0) "RTN","TMGMEDIC",139,0) set result=$$CONVDICT(FullNamePath) "RTN","TMGMEDIC",140,0) "RTN","TMGMEDIC",141,0) write "Goodbye.",! "RTN","TMGMEDIC",142,0) "RTN","TMGMEDIC",143,0) quit "RTN","TMGMEDIC",144,0) "RTN","TMGMEDIC",145,0) "RTN","TMGMEDIC",146,0) CONVDICT(FullNamePath,OfficeLoc) "RTN","TMGMEDIC",147,0) ;"Purpose: To convert files created for old Medic system into format ready for "RTN","TMGMEDIC",148,0) ;" upload into VistA "RTN","TMGMEDIC",149,0) ;"Input: FullNamePath -- full path and filename. "RTN","TMGMEDIC",150,0) ;" OfficeLoc -OPTIONAL (if not provided, user may be quered for info) "RTN","TMGMEDIC",151,0) ;" OfficeLoc(DUZ)="Full Name of Location" "RTN","TMGMEDIC",152,0) ;" e.g. OfficeLoc(12)="Main_Office" "RTN","TMGMEDIC",153,0) ;"Output: none (A new file will be created at same site as old file, with .vista extension "RTN","TMGMEDIC",154,0) ;"Result: 1 if success, 0 if failure; -1 abort "RTN","TMGMEDIC",155,0) "RTN","TMGMEDIC",156,0) new JustFile,JustPath "RTN","TMGMEDIC",157,0) new TempFile "RTN","TMGMEDIC",158,0) new ResultFile "RTN","TMGMEDIC",159,0) new index "RTN","TMGMEDIC",160,0) new abort set abort=0 "RTN","TMGMEDIC",161,0) new result "RTN","TMGMEDIC",162,0) new error set error=0 "RTN","TMGMEDIC",163,0) new retry set retry=0 "RTN","TMGMEDIC",164,0) new ErrorFound set ErrorFound=0 "RTN","TMGMEDIC",165,0) "RTN","TMGMEDIC",166,0) do SplitFNamePath^TMGIOUTL(FullNamePath,.JustPath,.JustFile) "RTN","TMGMEDIC",167,0) "RTN","TMGMEDIC",168,0) if $$Dos2Unix^TMGIOUTL(FullNamePath)>0 do goto CDDone "RTN","TMGMEDIC",169,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error while converting file ('"_FullNamePath_"') to Linux text format. Aborting") "RTN","TMGMEDIC",170,0) "RTN","TMGMEDIC",171,0) LoadFile "RTN","TMGMEDIC",172,0) if $$FTG^%ZISH(JustPath,JustFile,"TempFile(0)",1)=0 do goto CDDone "RTN","TMGMEDIC",173,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error loading file. Aborting") "RTN","TMGMEDIC",174,0) "RTN","TMGMEDIC",175,0) for do quit:($data(TempFile)=0)!(abort=1) "RTN","TMGMEDIC",176,0) . new OneNote,NoteInfo "RTN","TMGMEDIC",177,0) . set error=0 "RTN","TMGMEDIC",178,0) . do ExtractOneNote(.TempFile,.OneNote) "RTN","TMGMEDIC",179,0) . if $$ConvertOneNote(.OneNote,.NoteInfo,.OfficeLoc)=0 do quit "RTN","TMGMEDIC",180,0) . . set ErrorFound=1 "RTN","TMGMEDIC",181,0) . . set PriorErrorFound=0 "RTN","TMGMEDIC",182,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error while processing note.") "RTN","TMGMEDIC",183,0) . . set PriorErrorFound=0 "RTN","TMGMEDIC",184,0) . . write "Will run through that again, this time in verbose/debug mode",! "RTN","TMGMEDIC",185,0) . . set error=$$ConvertOneNote(.OneNote,.NoteInfo,.OfficeLoc,1) "RTN","TMGMEDIC",186,0) . . write "",! "RTN","TMGMEDIC",187,0) . . write "File: ",FullNamePath,! "RTN","TMGMEDIC",188,0) . . if $data(NoteInfo) do "RTN","TMGMEDIC",189,0) . . . write "Here is the Note Info that was successfully gathered:",! "RTN","TMGMEDIC",190,0) . . . zwr NoteInfo(*) "RTN","TMGMEDIC",191,0) . . new temp "RTN","TMGMEDIC",192,0) . . read !,"Show more info? (^ to abort) NO// ",temp:$get(DTIME,3600),! "RTN","TMGMEDIC",193,0) . . if $$UP^XLFSTR(temp)["Y" do "RTN","TMGMEDIC",194,0) . . . write "Here is the note to be processed:",! "RTN","TMGMEDIC",195,0) . . . zwr OneNote(*) "RTN","TMGMEDIC",196,0) . . . if $data(NoteInfo) do "RTN","TMGMEDIC",197,0) . . . . write "Here is the info that was extracted:",! "RTN","TMGMEDIC",198,0) . . . . zwr NoteInfo(*) "RTN","TMGMEDIC",199,0) . . . write !,"That was the info...",! "RTN","TMGMEDIC",200,0) . . . read !,"Press enter to continue (^ to abort)...",temp:$get(DTIME,3600),! "RTN","TMGMEDIC",201,0) . . if temp="^" set abort=1,error=1 "RTN","TMGMEDIC",202,0) . . write !,"File: ",FullNamePath,! "RTN","TMGMEDIC",203,0) . . read "Edit file? (^ to abort) NO// ",temp:$get(DTIME,3600),! "RTN","TMGMEDIC",204,0) . . if $$UP^XLFSTR(temp)["Y" do quit "RTN","TMGMEDIC",205,0) . . . do LinuxEdit^TMGEDIT("joe",$$LinuxStr^TMGSTUTL(FullNamePath)) "RTN","TMGMEDIC",206,0) . . . set retry=1,abort=1 "RTN","TMGMEDIC",207,0) . . if temp="^" set abort=1,error=1 "RTN","TMGMEDIC",208,0) . if error=0 do WriteOneNote(.OneNote,.NoteInfo,.ResultFile) "RTN","TMGMEDIC",209,0) "RTN","TMGMEDIC",210,0) if retry=1 do goto LoadFile "RTN","TMGMEDIC",211,0) . kill TempFile "RTN","TMGMEDIC",212,0) . set retry=0,abort=0,error=0 "RTN","TMGMEDIC",213,0) "RTN","TMGMEDIC",214,0) if abort=1 goto CDDone "RTN","TMGMEDIC",215,0) set index=$order(ResultFile("")) "RTN","TMGMEDIC",216,0) new ref set ref="ResultFile("_index_")" "RTN","TMGMEDIC",217,0) if $$GTF^%ZISH(ref,1,JustPath,JustFile_".vista")=0 do goto CDDone "RTN","TMGMEDIC",218,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error saving file. Aborting") "RTN","TMGMEDIC",219,0) else do "RTN","TMGMEDIC",220,0) . write !,"File successfully written to: '",JustFile_".vista'",!! "RTN","TMGMEDIC",221,0) . if $$IsDir^TMGIOUTL(JustPath_"orig/") do "RTN","TMGMEDIC",222,0) . . if $$Move^TMGIOUTL(JustPath_JustFile,JustPath_"orig/"_JustFile)=0 do "RTN","TMGMEDIC",223,0) . . . write "Original file moved to: ",JustPath_"orig/",! "RTN","TMGMEDIC",224,0) . . else do "RTN","TMGMEDIC",225,0) . . . write "Unable to move file moved to: ",JustPath_"orig/",! "RTN","TMGMEDIC",226,0) "RTN","TMGMEDIC",227,0) "RTN","TMGMEDIC",228,0) CDDone "RTN","TMGMEDIC",229,0) set result='ErrorFound "RTN","TMGMEDIC",230,0) if abort=1 set result=-1 "RTN","TMGMEDIC",231,0) quit result "RTN","TMGMEDIC",232,0) "RTN","TMGMEDIC",233,0) "RTN","TMGMEDIC",234,0) ExtractOneNote(Array,OneNote) "RTN","TMGMEDIC",235,0) ;"Purpose: To extract one note from Array, and return in OneNote "RTN","TMGMEDIC",236,0) ;"Input: Array: PASS BY REFERENCE. This should be array holding entire transcription file "RTN","TMGMEDIC",237,0) ;" extracted note will be removed from Array "RTN","TMGMEDIC",238,0) ;" OneNote: PASS BY REFERENCE. This array will hold the extracted note. "RTN","TMGMEDIC",239,0) ;" Anything in OneNote array will be killed before refilling "RTN","TMGMEDIC",240,0) ;"Note: notes are always divided by a line that looks like this: "RTN","TMGMEDIC",241,0) ;" !PAT(xxxx) !DATE(xxxx) (Note: I will use !DATE as my signal, because if we use this "RTN","TMGMEDIC",242,0) ;" system in the future, !PAT may not be available. "RTN","TMGMEDIC",243,0) ;" This function will assume that Array is at the first line of the new note (i.e. no lead lines) "RTN","TMGMEDIC",244,0) ;" The new note will be copied from the beginning of Array until the next occurance of "RTN","TMGMEDIC",245,0) ;" !PAT/!DATE, or until the end of the Array. "RTN","TMGMEDIC",246,0) ;"Output: one note is copied into OneNote "RTN","TMGMEDIC",247,0) ;"Results: none "RTN","TMGMEDIC",248,0) "RTN","TMGMEDIC",249,0) new index "RTN","TMGMEDIC",250,0) new j "RTN","TMGMEDIC",251,0) new NextLine set NextLine="" "RTN","TMGMEDIC",252,0) kill OneNote "RTN","TMGMEDIC",253,0) "RTN","TMGMEDIC",254,0) set index=$order(Array("")) "RTN","TMGMEDIC",255,0) set j=0 ;"<-- Start numbering of array at 0 (because 0 header line will be killed later) "RTN","TMGMEDIC",256,0) if index'="" for do quit:(index="")!(NextLine["!DATE") "RTN","TMGMEDIC",257,0) . set OneNote(j)=$get(Array(index)) "RTN","TMGMEDIC",258,0) . set j=j+1 "RTN","TMGMEDIC",259,0) . kill Array(index) "RTN","TMGMEDIC",260,0) . set index=$order(Array(index)) "RTN","TMGMEDIC",261,0) . if index'="" set NextLine=$get(Array(index)) "RTN","TMGMEDIC",262,0) . else set NextLine="" "RTN","TMGMEDIC",263,0) "RTN","TMGMEDIC",264,0) quit "RTN","TMGMEDIC",265,0) "RTN","TMGMEDIC",266,0) "RTN","TMGMEDIC",267,0) "RTN","TMGMEDIC",268,0) ConvertOneNote(OneNote,NoteInfo,OfficeLoc,DebugMode) "RTN","TMGMEDIC",269,0) ;"Purpose: To take a note (in older MEDIC upload format) and extract information needed to make a VistA upload note "RTN","TMGMEDIC",270,0) ;"Input: OneNote -- PASS BY REFERENCE -- a single note to be converted. Format will be like this: "RTN","TMGMEDIC",271,0) ;" OneNote(0)="first line" "RTN","TMGMEDIC",272,0) ;" OneNote(1)="second line" "RTN","TMGMEDIC",273,0) ;" etc. "RTN","TMGMEDIC",274,0) ;" ---Content of note--- "RTN","TMGMEDIC",275,0) ;" !PAT(123456) !DATE(05/12/05) <--- always the first line (OneNote(0)) "RTN","TMGMEDIC",276,0) ;" "RTN","TMGMEDIC",277,0) ;" PATIENT NAME:[TAB]Sarah P. Doe[TAB]DATE: 05/12/2005 <---Date of encounter "RTN","TMGMEDIC",278,0) ;" CHART#: 123456[TAB]DOB: 05/06/1995 "RTN","TMGMEDIC",279,0) ;" "RTN","TMGMEDIC",280,0) ;" "RTN","TMGMEDIC",281,0) ;" ... "RTN","TMGMEDIC",282,0) ;" "RTN","TMGMEDIC",283,0) ;" "RTN","TMGMEDIC",284,0) ;" "RTN","TMGMEDIC",285,0) ;" PATIENT NAME:[TAB]Sarah P. Doe[TAB]DATE: 05/12/2005 "RTN","TMGMEDIC",286,0) ;" CHART#: 123456[TAB]DOB: 05/06/1995 "RTN","TMGMEDIC",287,0) ;" Page Two "RTN","TMGMEDIC",288,0) ;" "RTN","TMGMEDIC",289,0) ;" ... "RTN","TMGMEDIC",290,0) ;" "RTN","TMGMEDIC",291,0) ;" <--- end of note "RTN","TMGMEDIC",292,0) ;" Kevin S. Toppenberg M.D. "RTN","TMGMEDIC",293,0) ;" KST/kle "RTN","TMGMEDIC",294,0) ;" "RTN","TMGMEDIC",295,0) ;" "RTN","TMGMEDIC",296,0) ;" NoteInfo -- PASS BY REFERENCE. This is an array to return note into into, as follows: "RTN","TMGMEDIC",297,0) ;" NoteInfo("PATIENT")="Lastname,firstname initial" "RTN","TMGMEDIC",298,0) ;" NoteInfo("DOB")="5/12/05" "RTN","TMGMEDIC",299,0) ;" NoteInfo("AUTHOR")="Toppenberg,Kevin S" "RTN","TMGMEDIC",300,0) ;" NoteInfo("TRANS INITS")="kle" "RTN","TMGMEDIC",301,0) ;" NoteInfo("MEDIC NUMBER")=123456 "RTN","TMGMEDIC",302,0) ;" NoteInfo("DATE OF ENCOUNTER")="05/12/05" "RTN","TMGMEDIC",303,0) ;" NoteInfo("LOCATION")="Main_Office" "RTN","TMGMEDIC",304,0) ;" OfficeLoc -- PASS BY REFERENCE -- OPTIONAL "RTN","TMGMEDIC",305,0) ;" an array storing default locations for authors. See format in CONVDICT "RTN","TMGMEDIC",306,0) ;" If not passed, into will be looked for in^TMG( "RTN","TMGMEDIC",307,0) ;" Note: **First looks in file 8926 for def. office "RTN","TMGMEDIC",308,0) ;" DebugMode -- OPTIONAL. If value=1, then verbose info written "RTN","TMGMEDIC",309,0) ;"Output: Results are returned in NoteInfo. OneNote is modified to remove !PAT() and !DATE() line "RTN","TMGMEDIC",310,0) ;"Results: 1 if success, 0 if error "RTN","TMGMEDIC",311,0) ;"Note: accesses a global var: PriorErrorFound (OK if not defined) "RTN","TMGMEDIC",312,0) "RTN","TMGMEDIC",313,0) new result set result=1 "RTN","TMGMEDIC",314,0) Kill NoteInfo "RTN","TMGMEDIC",315,0) new index set index=0 "RTN","TMGMEDIC",316,0) new Line "RTN","TMGMEDIC",317,0) new Debug set Debug=$get(DebugMode,0) "RTN","TMGMEDIC",318,0) "RTN","TMGMEDIC",319,0) new HeaderLine set HeaderLine=$get(OneNote(index)) "RTN","TMGMEDIC",320,0) ;"kill OneNote(index) "RTN","TMGMEDIC",321,0) "RTN","TMGMEDIC",322,0) if Debug do "RTN","TMGMEDIC",323,0) . write !,"========================================================",! "RTN","TMGMEDIC",324,0) . write "Processing the following line: ",! "RTN","TMGMEDIC",325,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",326,0) . write HeaderLine,! "RTN","TMGMEDIC",327,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",328,0) . write "Expecting line to contain '!PAT [!DATE]",! "RTN","TMGMEDIC",329,0) . write "========================================================",! "RTN","TMGMEDIC",330,0) "RTN","TMGMEDIC",331,0) if (HeaderLine="")!((HeaderLine'["!DATE")&(HeaderLine'["!PAT")) do goto CONDone "RTN","TMGMEDIC",332,0) . set result=0 "RTN","TMGMEDIC",333,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Header line not correct.") "RTN","TMGMEDIC",334,0) "RTN","TMGMEDIC",335,0) if Debug do "RTN","TMGMEDIC",336,0) . write "Checking header line for '!PAT(xxx)'" "RTN","TMGMEDIC",337,0) if HeaderLine["!PAT(" do "RTN","TMGMEDIC",338,0) . if Debug write "...found.",! "RTN","TMGMEDIC",339,0) . new s,s1,s2 "RTN","TMGMEDIC",340,0) . set s=$piece(HeaderLine,"!PAT(",2) "RTN","TMGMEDIC",341,0) . set s1=$$Trim^TMGSTUTL(s) "RTN","TMGMEDIC",342,0) . set s1=$piece(s,")",1) "RTN","TMGMEDIC",343,0) . set s1=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",344,0) . if s1'="" do "RTN","TMGMEDIC",345,0) . . set NoteInfo("MEDIC NUMBER")=s1 "RTN","TMGMEDIC",346,0) . . if Debug write "!PAT() --> Patient number found was: ",s1,! "RTN","TMGMEDIC",347,0) . else write "Patient number unexpectedly not found!",! "RTN","TMGMEDIC",348,0) "RTN","TMGMEDIC",349,0) if HeaderLine["!DATE(" do "RTN","TMGMEDIC",350,0) . new s,s1,s2 "RTN","TMGMEDIC",351,0) . set s=$piece(HeaderLine,"!DATE(",2) "RTN","TMGMEDIC",352,0) . set s1=$piece(s,")",1) "RTN","TMGMEDIC",353,0) . set s1=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",354,0) . if s1'="" do "RTN","TMGMEDIC",355,0) . . set NoteInfo("DATE OF ENCOUNTER")=s1 "RTN","TMGMEDIC",356,0) . . if Debug write "!DATE() --> Date of encounter found was: ",s1,! "RTN","TMGMEDIC",357,0) . else write "Date of encounter unexpectedly not found!",! "RTN","TMGMEDIC",358,0) "RTN","TMGMEDIC",359,0) set index=index+1 "RTN","TMGMEDIC",360,0) if $$Trim^TMGSTUTL($get(OneNote(index)))="" set index=index+1 ;"Skip any blank line "RTN","TMGMEDIC",361,0) ;"e.g. line-- PATIENT NAME:[TAB]Sarah P. Doe[TAB]DATE: 05/12/2005 <---Date of encounter "RTN","TMGMEDIC",362,0) set Line=$get(OneNote(index)) "RTN","TMGMEDIC",363,0) set Line=$translate(Line,$char(9)," ") ;"convert tabs to space "RTN","TMGMEDIC",364,0) "RTN","TMGMEDIC",365,0) if Debug do "RTN","TMGMEDIC",366,0) . write !,"========================================================",! "RTN","TMGMEDIC",367,0) . write "Processing the following line: ",! "RTN","TMGMEDIC",368,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",369,0) . write Line,! "RTN","TMGMEDIC",370,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",371,0) . write "Expecting pattern line this: ",! "RTN","TMGMEDIC",372,0) . write "[PATIENT NAME: ]Sarah P. Doe [DATE:05/12/2005] [DOS:5/12/2005] [DOB:1/1/1920]",! "RTN","TMGMEDIC",373,0) . write "========================================================",! "RTN","TMGMEDIC",374,0) "RTN","TMGMEDIC",375,0) if (Line["PATIENT NAME:")!(Line["DATE:")!(Line["DOS:")!(Line["DOB:") do "RTN","TMGMEDIC",376,0) . new s,s1,s2 "RTN","TMGMEDIC",377,0) . s s="" "RTN","TMGMEDIC",378,0) . if (Line["PATIENT NAME:") set s=$piece(Line,"PATIENT NAME:",2) "RTN","TMGMEDIC",379,0) . else set s=Line "RTN","TMGMEDIC",380,0) . ;"if (Line'["DATE:")&(Line'["DOS:")&(Line'["DOB:") do "RTN","TMGMEDIC",381,0) . ;". set result=0 "RTN","TMGMEDIC",382,0) . ;". do ShowError^TMGDEBUG(.PriorErrorFound,"'DATE' or 'DOS' or 'DOB' not found in note header.") "RTN","TMGMEDIC",383,0) . ;". write "-->'",Line,"'",! "RTN","TMGMEDIC",384,0) . set s1="" "RTN","TMGMEDIC",385,0) . new doneloop set doneloop=0 "RTN","TMGMEDIC",386,0) . for do quit:(doneloop) "RTN","TMGMEDIC",387,0) . . if (s["DATE:") set s=$piece(s,"DATE:",1) quit "RTN","TMGMEDIC",388,0) . . if (s["DOB:") set s=$piece(s,"DOB:",1) quit "RTN","TMGMEDIC",389,0) . . if (s["DOS:") set s=$piece(s,"DOS:",1) quit "RTN","TMGMEDIC",390,0) . . set s1=$$Trim^TMGSTUTL(s) "RTN","TMGMEDIC",391,0) . . set s1=$$FormatName^TMGMISC(s1) "RTN","TMGMEDIC",392,0) . . set doneloop=1 "RTN","TMGMEDIC",393,0) . if s1'="" set NoteInfo("PATIENT")=s1 "RTN","TMGMEDIC",394,0) . if Debug write "Patient Name found was: ",s1,! "RTN","TMGMEDIC",395,0) . if (Line["DOB:") do ;"expects date to contain NO spaces... e.g. 1/1/05, not 'Jan 1, 2005' "RTN","TMGMEDIC",396,0) . . if Debug write "Looking at ",Line,! "RTN","TMGMEDIC",397,0) . . set s1=$piece(Line,"DOB:",2) "RTN","TMGMEDIC",398,0) . . set s1=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",399,0) . . set s1=$piece(s1," ",1) "RTN","TMGMEDIC",400,0) . . set NoteInfo("DOB")=s1 "RTN","TMGMEDIC",401,0) . . if Debug write "Patient DOB found was: ",s1,! "RTN","TMGMEDIC",402,0) . if (Line["DOS:") do ;"expects date to contain NO spaces... e.g. 1/1/05, not 'Jan 1, 2005' "RTN","TMGMEDIC",403,0) . . if Debug write "Looking at ",Line,! "RTN","TMGMEDIC",404,0) . . set s1=$piece(Line,"DOS:",2) "RTN","TMGMEDIC",405,0) . . set s1=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",406,0) . . set s1=$piece(s1," ",1) "RTN","TMGMEDIC",407,0) . . set NoteInfo("DATE OF ENCOUNTER")=s1 "RTN","TMGMEDIC",408,0) . . if Debug write "Date of Encounter: ",s1,! "RTN","TMGMEDIC",409,0) . if (Line["DATE:") do ;"expects date to contain NO spaces... e.g. 1/1/05, not 'Jan 1, 2005' "RTN","TMGMEDIC",410,0) . . if Debug write "Looking at ",Line,! "RTN","TMGMEDIC",411,0) . . set s1=$piece(Line,"DATE:",2) "RTN","TMGMEDIC",412,0) . . set s1=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",413,0) . . set s1=$piece(s1," ",1) "RTN","TMGMEDIC",414,0) . . set NoteInfo("DATE OF ENCOUNTER")=s1 "RTN","TMGMEDIC",415,0) . . if Debug write "Date of Encounter: ",s1,! "RTN","TMGMEDIC",416,0) else do goto CONDone "RTN","TMGMEDIC",417,0) . set result=0 "RTN","TMGMEDIC",418,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"'PATIENT NAME:' or 'DATE:' or 'DOS:' or 'DOB:' not found.") "RTN","TMGMEDIC",419,0) "RTN","TMGMEDIC",420,0) set index=index+1 "RTN","TMGMEDIC",421,0) if $$Trim^TMGSTUTL($get(OneNote(index)))="" set index=index+1 ;"Skip any blank line "RTN","TMGMEDIC",422,0) ;"e.g. line -- CHART#: 123456[TAB]DOB: 05/06/1995 "RTN","TMGMEDIC",423,0) set Line=$get(OneNote(index)) "RTN","TMGMEDIC",424,0) set Line=$translate(Line,$char(9)," ") ;"convert tabs to space "RTN","TMGMEDIC",425,0) "RTN","TMGMEDIC",426,0) if Debug do "RTN","TMGMEDIC",427,0) . write !,"========================================================",! "RTN","TMGMEDIC",428,0) . write "Processing the following line: ",! "RTN","TMGMEDIC",429,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",430,0) . write Line,! "RTN","TMGMEDIC",431,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",432,0) . write "Expecting pattern line this: ",! "RTN","TMGMEDIC",433,0) . write " CHART#: 123456 DOB: 05/06/1995",! "RTN","TMGMEDIC",434,0) . write "(Note: This line is optional)",! "RTN","TMGMEDIC",435,0) . write "========================================================",! "RTN","TMGMEDIC",436,0) "RTN","TMGMEDIC",437,0) if $get(NoteInfo("MEDIC NUMBER"))="" do "RTN","TMGMEDIC",438,0) . if Line["CHART#:" do "RTN","TMGMEDIC",439,0) . . new s,s1,s2 "RTN","TMGMEDIC",440,0) . . set s=$piece(Line,"CHART#:",2) "RTN","TMGMEDIC",441,0) . . set s1=$piece(s,"DOB:",1) "RTN","TMGMEDIC",442,0) . . set NoteInfo("MEDIC NUMBER")=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",443,0) . else do "RTN","TMGMEDIC",444,0) . . set result=0 "RTN","TMGMEDIC",445,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"'CHART#:' not found in line.") "RTN","TMGMEDIC",446,0) . . write "-->'",Line,"'",! "RTN","TMGMEDIC",447,0) "RTN","TMGMEDIC",448,0) if $get(NoteInfo("DOB"))="" do if result=0 goto CONDone "RTN","TMGMEDIC",449,0) . if Line["DOB:" do "RTN","TMGMEDIC",450,0) . . new s,s1,s2 "RTN","TMGMEDIC",451,0) . . set s1=$piece(Line,"DOB:",2) "RTN","TMGMEDIC",452,0) . . set s1=$$Trim^TMGSTUTL(s1) "RTN","TMGMEDIC",453,0) . . if s1'="" set NoteInfo("DOB")=s1 "RTN","TMGMEDIC",454,0) . else do "RTN","TMGMEDIC",455,0) . . set result=0 "RTN","TMGMEDIC",456,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"'DOB:' not found in line.") "RTN","TMGMEDIC",457,0) . . write "-->'",Line,"'",! "RTN","TMGMEDIC",458,0) "RTN","TMGMEDIC",459,0) if $get(NoteInfo("DATE OF ENCOUNTER"))="" do goto CONDone "RTN","TMGMEDIC",460,0) . set result=0 "RTN","TMGMEDIC",461,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Done with header, but no Date of Encounter found.") "RTN","TMGMEDIC",462,0) "RTN","TMGMEDIC",463,0) ;"Main header processing now done. Now scan for a header for subsequent pages, and delete. "RTN","TMGMEDIC",464,0) if Debug write !!,"Now scanning for unneeded header info in middle of note.",! "RTN","TMGMEDIC",465,0) set index=index+1 "RTN","TMGMEDIC",466,0) for do quit:(index="") "RTN","TMGMEDIC",467,0) . set Line=$get(OneNote(index)) "RTN","TMGMEDIC",468,0) . if Debug write "." "RTN","TMGMEDIC",469,0) . ;"if Debug write ">>",Line,! "RTN","TMGMEDIC",470,0) . if (Line["PATIENT NAME:")&(Line["DATE:") do "RTN","TMGMEDIC",471,0) . . if Debug do "RTN","TMGMEDIC",472,0) . . . write !,"Found one...",! "RTN","TMGMEDIC",473,0) . . . write "-->",Line,! "RTN","TMGMEDIC",474,0) . . kill OneNote(index) "RTN","TMGMEDIC",475,0) . . if $$Trim^TMGSTUTL($get(OneNote(index-1)))="" kill OneNote(index-1) "RTN","TMGMEDIC",476,0) . . set index=index+1 "RTN","TMGMEDIC",477,0) . . set Line=$get(OneNote(index)) "RTN","TMGMEDIC",478,0) . . if (Line["CHART#")&(Line["DOB") kill OneNote(index) "RTN","TMGMEDIC",479,0) . . if Debug write "And-->",Line,! "RTN","TMGMEDIC",480,0) . . set index=index+1 "RTN","TMGMEDIC",481,0) . . set Line=$$Trim^TMGSTUTL($$UP^XLFSTR($get(OneNote(index)))) "RTN","TMGMEDIC",482,0) . . if ($piece(Line," ",1)="PAGE")&($piece(Line," ",3)="") do "RTN","TMGMEDIC",483,0) . . . if Debug write "And-->",Line,! "RTN","TMGMEDIC",484,0) . . . kill OneNote(index) "RTN","TMGMEDIC",485,0) . set index=$order(OneNote(index)) "RTN","TMGMEDIC",486,0) "RTN","TMGMEDIC",487,0) ;"Now work backwards from end of note to get transcriptionist name and author name "RTN","TMGMEDIC",488,0) if Debug write !!,"Now trimming blank lines from the end of the note (scanning backwards).",! "RTN","TMGMEDIC",489,0) ;"Trim blank lines from end of note. "RTN","TMGMEDIC",490,0) set index=$order(OneNote(""),-1) "RTN","TMGMEDIC",491,0) for do quit:(Line'="")!(+index<4) "RTN","TMGMEDIC",492,0) . set Line=$get(OneNote(index)) "RTN","TMGMEDIC",493,0) . set Line=$translate(Line,$char(9)," ") ;"convert tabs to space "RTN","TMGMEDIC",494,0) . set Line=$$Trim^TMGSTUTL(Line) "RTN","TMGMEDIC",495,0) . ;"if Debug write ">> '",Line,"'",! "RTN","TMGMEDIC",496,0) . if Debug write "." "RTN","TMGMEDIC",497,0) . if Line="" kill OneNote(index) "RTN","TMGMEDIC",498,0) . set index=$order(OneNote(index),-1) "RTN","TMGMEDIC",499,0) "RTN","TMGMEDIC",500,0) if Debug write !!,"Now looking for Transcriptionist initials. (scanning backwards)",! "RTN","TMGMEDIC",501,0) new InitsFound set InitsFound=0 "RTN","TMGMEDIC",502,0) ;"Get transcriptionist initials "RTN","TMGMEDIC",503,0) set index=$order(OneNote(""),-1) "RTN","TMGMEDIC",504,0) for do quit:(InitsFound)!(index="")!(+index<4) "RTN","TMGMEDIC",505,0) . set Line=$get(OneNote(index)) "RTN","TMGMEDIC",506,0) . set Line=$translate(Line,$char(9)," ") ;"convert tabs to space "RTN","TMGMEDIC",507,0) . set Line=$$Trim^TMGSTUTL(Line) "RTN","TMGMEDIC",508,0) . ;"if Debug write ">",Line,! "RTN","TMGMEDIC",509,0) . if Debug write "." "RTN","TMGMEDIC",510,0) . if (Line["/")&($piece(Line," ",2)="") do quit "RTN","TMGMEDIC",511,0) . . set InitsFound=1 "RTN","TMGMEDIC",512,0) . . if Debug write "...found a line (#",index,") with '/' -->",Line,! "RTN","TMGMEDIC",513,0) . set index=$order(OneNote(index),-1) "RTN","TMGMEDIC",514,0) "RTN","TMGMEDIC",515,0) if Debug do "RTN","TMGMEDIC",516,0) . write !,"========================================================",! "RTN","TMGMEDIC",517,0) . write "Now looking for transcriptionist's name",! "RTN","TMGMEDIC",518,0) . write "Processing the following line: ",! "RTN","TMGMEDIC",519,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",520,0) . write Line,! "RTN","TMGMEDIC",521,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",522,0) . write "Expecting pattern: 'Author's inits/tran's inits'" "RTN","TMGMEDIC",523,0) . write " (with no other text on line.)",! "RTN","TMGMEDIC",524,0) . write " e.g. KST/abc",! "RTN","TMGMEDIC",525,0) . write "========================================================",! "RTN","TMGMEDIC",526,0) if (Line[" ")&(Debug) do "RTN","TMGMEDIC",527,0) . write "? trim not working?",! "RTN","TMGMEDIC",528,0) . write "OneNote(index)='",OneNote(index),"'",! "RTN","TMGMEDIC",529,0) . write "After trim, resulting Line='",Line,"'",! "RTN","TMGMEDIC",530,0) . write "Will try another trim.",! "RTN","TMGMEDIC",531,0) . set Line=$$Trim^TMGSTUTL(Line) "RTN","TMGMEDIC",532,0) . write "Now Line='",Line,"'",! "RTN","TMGMEDIC",533,0) if (Line["/")&($piece(Line," ",2)="") do "RTN","TMGMEDIC",534,0) . new inits "RTN","TMGMEDIC",535,0) . set inits=$piece(Line,"/",2) "RTN","TMGMEDIC",536,0) . set NoteInfo("TRANS INITS")=inits "RTN","TMGMEDIC",537,0) . if Debug write "...found a line with '/': ",Line,! "RTN","TMGMEDIC",538,0) . ;"now turn initials into full name via database lookup "RTN","TMGMEDIC",539,0) . set DIC=200,DIC(0)="M" "RTN","TMGMEDIC",540,0) . set X=inits "RTN","TMGMEDIC",541,0) . do ^DIC "RTN","TMGMEDIC",542,0) . if Y'>0 do quit "RTN","TMGMEDIC",543,0) . . set result=0 "RTN","TMGMEDIC",544,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find '"_inits_"' in database.") "RTN","TMGMEDIC",545,0) . set NoteInfo("TRANSCRIPTIONIST")=$piece(Y,"^",2) "RTN","TMGMEDIC",546,0) else do goto CONDone "RTN","TMGMEDIC",547,0) . set result=0,PriorErrorFound=0 "RTN","TMGMEDIC",548,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Transcriptionists initials not found") "RTN","TMGMEDIC",549,0) "RTN","TMGMEDIC",550,0) ;"Get author "RTN","TMGMEDIC",551,0) for do quit:(Line'="") "RTN","TMGMEDIC",552,0) . set index=$order(OneNote(index),-1) "RTN","TMGMEDIC",553,0) . set Line=$$Trim^TMGSTUTL($get(OneNote(index))) "RTN","TMGMEDIC",554,0) if Debug do "RTN","TMGMEDIC",555,0) . write !,"========================================================",! "RTN","TMGMEDIC",556,0) . write "Now looking for author's name",! "RTN","TMGMEDIC",557,0) . write "Processing the following line: ",! "RTN","TMGMEDIC",558,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",559,0) . write Line,! "RTN","TMGMEDIC",560,0) . write "--------------------------------------------------------",! "RTN","TMGMEDIC",561,0) . write "Expecting pattern: 'Doctor's name'",! "RTN","TMGMEDIC",562,0) . write "========================================================",! "RTN","TMGMEDIC",563,0) if Line'="" do "RTN","TMGMEDIC",564,0) . set Line=$$FormatName^TMGMISC(Line,1) "RTN","TMGMEDIC",565,0) . If Line="TOPPENBERG,M DEE" set Line="TOPPENBERG,MARCIA D" "RTN","TMGMEDIC",566,0) . if Line="SVENDSEN,CLAES V" set Line="SVENDSEN,CLAES U" "RTN","TMGMEDIC",567,0) . set NoteInfo("AUTHOR")=Line "RTN","TMGMEDIC",568,0) "RTN","TMGMEDIC",569,0) if $get(NoteInfo("DOB"))="" do goto CONDone "RTN","TMGMEDIC",570,0) . set result=0 "RTN","TMGMEDIC",571,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Patient DOB not found.") "RTN","TMGMEDIC",572,0) "RTN","TMGMEDIC",573,0) ;"Ensure provider name is correct "RTN","TMGMEDIC",574,0) if Debug do "RTN","TMGMEDIC",575,0) . write "Looking up Author in VistA database to ensure it's correct.",! "RTN","TMGMEDIC",576,0) set DIC=200 "RTN","TMGMEDIC",577,0) set DIC(0)="" "RTN","TMGMEDIC",578,0) set X=$get(NoteInfo("AUTHOR")) "RTN","TMGMEDIC",579,0) do ^DIC "RTN","TMGMEDIC",580,0) if Y'>0 do goto CONDone "RTN","TMGMEDIC",581,0) . set result=0 "RTN","TMGMEDIC",582,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Provider name in note ('"_$get(NoteInfo("AUTHOR"))_"') incorrect. Aborting") "RTN","TMGMEDIC",583,0) ;"Now get office location based on provider "RTN","TMGMEDIC",584,0) if Debug write "Found: ",Y,! "RTN","TMGMEDIC",585,0) new Office set Office="" "RTN","TMGMEDIC",586,0) new AuthDUZ "RTN","TMGMEDIC",587,0) set AuthDUZ=+Y "RTN","TMGMEDIC",588,0) new i set i=$order(^TIU(8926,"B",AuthDUZ,"")) ;"file 8926: def. office "RTN","TMGMEDIC",589,0) if i'="" do "RTN","TMGMEDIC",590,0) . new j set j=$get(TIU(8926,i,0)) "RTN","TMGMEDIC",591,0) . if j="" quit "RTN","TMGMEDIC",592,0) . new IENOffice set IENOffice=$piece(j,"^",2) "RTN","TMGMEDIC",593,0) . if IENOffice="" quit "RTN","TMGMEDIC",594,0) . set Office=$piece($get(^SC(IENOffice,0)),"^",1) "RTN","TMGMEDIC",595,0) if Office="" set Office=$get(OfficeLoc(AuthDUZ)) "RTN","TMGMEDIC",596,0) if Office="" set Office=$get(^TMG("MEDIC CONV","Office",AuthDUZ)) "RTN","TMGMEDIC",597,0) if Office="" do "RTN","TMGMEDIC",598,0) . set DIC=44 ;"HOSPITAL LOCATION "RTN","TMGMEDIC",599,0) . set DIC(0)="AEQ" "RTN","TMGMEDIC",600,0) . set X="" "RTN","TMGMEDIC",601,0) . set DIC("A")="Which office does "_$piece(Y,"^",2)_" work in (Type ? for list)?: " "RTN","TMGMEDIC",602,0) . do ^DIC "RTN","TMGMEDIC",603,0) . write ! "RTN","TMGMEDIC",604,0) . if Y>0 do "RTN","TMGMEDIC",605,0) . . set Office=$piece(Y,"^",2) "RTN","TMGMEDIC",606,0) . . set OfficeLoc(AuthDUZ)=Office "RTN","TMGMEDIC",607,0) . . set ^TMG("MEDIC CONV","Office",AuthDUZ)=Office "RTN","TMGMEDIC",608,0) if Office="" do goto CONDone "RTN","TMGMEDIC",609,0) . set result=0 "RTN","TMGMEDIC",610,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't determine office location. Aborting") "RTN","TMGMEDIC",611,0) set NoteInfo("LOCATION")=Office "RTN","TMGMEDIC",612,0) "RTN","TMGMEDIC",613,0) CONDone "RTN","TMGMEDIC",614,0) quit result "RTN","TMGMEDIC",615,0) "RTN","TMGMEDIC",616,0) "RTN","TMGMEDIC",617,0) WriteOneNote(OneNote,NoteInfo,ResultFile) "RTN","TMGMEDIC",618,0) ;"Purpose: To take One note, and append to Result File, with appropriate header, based on NoteInfo "RTN","TMGMEDIC",619,0) ;"Input: OneNote -- PASS BY REFERENCE-- the text array to append to resulting file "RTN","TMGMEDIC",620,0) ;" NoteInfo -- array with note info. See format in ConvertOneNote "RTN","TMGMEDIC",621,0) ;" ResultFile -- PASS BY REFERENCE this is the array built to the cumulative output "RTN","TMGMEDIC",622,0) ;" "RTN","TMGMEDIC",623,0) ;" Here is the needed format for vista upload. (at our site) "RTN","TMGMEDIC",624,0) ;" [NewDict]: NOTE "RTN","TMGMEDIC",625,0) ;" Patient Name: Doe,John A "RTN","TMGMEDIC",626,0) ;" DOB: 08/01/0931 "RTN","TMGMEDIC",627,0) ;" Date of Encounter: 06/08/2005 "RTN","TMGMEDIC",628,0) ;" Provider: Welby,Marcus "RTN","TMGMEDIC",629,0) ;" Visit Location: Laughlin_Office "RTN","TMGMEDIC",630,0) ;" Transcriptionist: Fingers,Speedy "RTN","TMGMEDIC",631,0) ;" [TEXT] "RTN","TMGMEDIC",632,0) ;" (Here is the text of the note... "RTN","TMGMEDIC",633,0) ;" [END] "RTN","TMGMEDIC",634,0) "RTN","TMGMEDIC",635,0) kill OneNote(0) ;"the !PAT() !DATE etc. line "RTN","TMGMEDIC",636,0) "RTN","TMGMEDIC",637,0) set OneNote(.1)="[NewDict]: NOTE" "RTN","TMGMEDIC",638,0) set OneNote(.2)="Patient Name: "_$get(NoteInfo("PATIENT")) "RTN","TMGMEDIC",639,0) set OneNote(.3)="DOB: "_$get(NoteInfo("DOB")) "RTN","TMGMEDIC",640,0) set OneNote(.4)="Date of Encounter: "_$get(NoteInfo("DATE OF ENCOUNTER")) "RTN","TMGMEDIC",641,0) set OneNote(.5)="Provider: "_$get(NoteInfo("AUTHOR")) "RTN","TMGMEDIC",642,0) set OneNote(.6)="Visit Location: "_$get(NoteInfo("LOCATION")) "RTN","TMGMEDIC",643,0) set OneNote(.7)="Transcriptionist: "_$get(NoteInfo("TRANSCRIPTIONIST")) "RTN","TMGMEDIC",644,0) set OneNote(.8)="[TEXT]" "RTN","TMGMEDIC",645,0) "RTN","TMGMEDIC",646,0) new s "RTN","TMGMEDIC",647,0) set s=$get(NoteInfo("PATIENT")) "RTN","TMGMEDIC",648,0) set s=s_" on "_$get(NoteInfo("DATE OF ENCOUNTER"))_"; " "RTN","TMGMEDIC",649,0) set s=s_$get(NoteInfo("AUTHOR")) "RTN","TMGMEDIC",650,0) set s=s_" at "_$get(NoteInfo("LOCATION")) "RTN","TMGMEDIC",651,0) write "Done: ",s,! "RTN","TMGMEDIC",652,0) "RTN","TMGMEDIC",653,0) new index,j "RTN","TMGMEDIC",654,0) set index=$order(OneNote(""),-1) "RTN","TMGMEDIC",655,0) set index=index+1 "RTN","TMGMEDIC",656,0) set OneNote(index)="[END]" "RTN","TMGMEDIC",657,0) set OneNote(index+1)=" " "RTN","TMGMEDIC",658,0) "RTN","TMGMEDIC",659,0) ;"Now append OneNote to ResultFile "RTN","TMGMEDIC",660,0) set j=$order(ResultFile(""),-1)+1 "RTN","TMGMEDIC",661,0) set index=$order(OneNote("")) "RTN","TMGMEDIC",662,0) for do quit:(index="") "RTN","TMGMEDIC",663,0) . set ResultFile(j)=$get(OneNote(index)) "RTN","TMGMEDIC",664,0) . set j=j+1 "RTN","TMGMEDIC",665,0) . set index=$order(OneNote(index)) "RTN","TMGMEDIC",666,0) "RTN","TMGMEDIC",667,0) quit "RTN","TMGMEDIC",668,0) "RTN","TMGMEDIC",669,0) "RTN","TMGMEDIC",670,0) TELNET "RTN","TMGMEDIC",671,0) ;"Purpose: to provide ability to telnet to medic server (AIX) "RTN","TMGMEDIC",672,0) "RTN","TMGMEDIC",673,0) new HookCmd "RTN","TMGMEDIC",674,0) set HookCmd="telnet medic" "RTN","TMGMEDIC",675,0) zsystem HookCmd "RTN","TMGMEDIC",676,0) "RTN","TMGMEDIC",677,0) write !,!,"Done. Returning to VistA",! "RTN","TMGMEDIC",678,0) new temp read "Press Enter to Continue...",temp:$get(DTIME,3600),! "RTN","TMGMEDIC",679,0) "RTN","TMGMEDIC",680,0) quit "RTN","TMGMGRST") 0^32^B2452596 "RTN","TMGMGRST",1,0) TMGMGRST ;TMG/kst/Custom version of ZTMGRSET and ZOSFGUX ;03/25/06 "RTN","TMGMGRST",2,0) ;;1.0;TMG-LIB;**1**;11/01/04 "RTN","TMGMGRST",3,0) "RTN","TMGMGRST",4,0) ;"ZTMGRSET(INFO) & ZOSFGUX -- NON-INTERACTIVE versions of standard code. "RTN","TMGMGRST",5,0) ;"============================================================================= "RTN","TMGMGRST",6,0) ;"Kevin Toppenberg, MD 11-04 "RTN","TMGMGRST",7,0) ;" "RTN","TMGMGRST",8,0) ;"Purpose: "RTN","TMGMGRST",9,0) ;" "RTN","TMGMGRST",10,0) ;"This library will provide optional NON-INTERACTIVE versions of standard code. "RTN","TMGMGRST",11,0) ;" "RTN","TMGMGRST",12,0) ;"ZTMGRSET(INFO) "RTN","TMGMGRST",13,0) ;"ZOSFGUX "RTN","TMGMGRST",14,0) ;" "RTN","TMGMGRST",15,0) ;"Dependancies: "RTN","TMGMGRST",16,0) ;" TMGQIO "RTN","TMGMGRST",17,0) ;" if TMGDEBUG defined, then requires TMGDEBUG.m "RTN","TMGMGRST",18,0) ;"============================================================================= "RTN","TMGMGRST",19,0) "RTN","TMGMGRST",20,0) ZTMGRSET(INFO) ;SF/RWF,PUG/TOAD - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;10/29/2003 10:19 "RTN","TMGMGRST",21,0) ;;8.0+;KERNEL;**34,36,69,94,121,127,136,191,275 (WorldVista Modified)**;JUL 10, 1995; "RTN","TMGMGRST",22,0) ;";;8.0;KERNEL;**34,36,69,94,121,127,136,191,275**;JUL 10, 1995; "RTN","TMGMGRST",23,0) ;" "RTN","TMGMGRST",24,0) ;"K. Toppenberg's changes made November, 2004 "RTN","TMGMGRST",25,0) ;" "RTN","TMGMGRST",26,0) ;"Input: "RTN","TMGMGRST",27,0) ;" Note: INFO variable is completely an OPTIONAL parameter. "RTN","TMGMGRST",28,0) ;" If not supplied, interactive mode used "RTN","TMGMGRST",29,0) ;" INFO("SILENT-OUTPUT") -- 1 = output is supressed. "RTN","TMGMGRST",30,0) ;" INFO("SILENT-INPUT") -- 1 = User-interactive input is supressed. "RTN","TMGMGRST",31,0) ;" "RTN","TMGMGRST",32,0) ;" ** if in SILENT-INPUT mode, THEN the following data should be supplied: "RTN","TMGMGRST",33,0) ;" ---------------------- "RTN","TMGMGRST",34,0) ;" INFO("CONTINUE") -- Should contain the answer the user would enter for question: "RTN","TMGMGRST",35,0) ;" "THIS MAY NOT BE THE MANAGER UCI... continue anyway?" (i.e. Y or N) "RTN","TMGMGRST",36,0) ;" INFO("OS") -- should have number that would be used to select OS to install (i.e. 1,2,3 etc.) "RTN","TMGMGRST",37,0) ;" INFO("RENAME") -- should have answer to "Rename fileman routines?" (i.e. Y or N) "RTN","TMGMGRST",38,0) ;" INFO("MGR-UCI,VOL") -- should have Managers UCI,VOL "RTN","TMGMGRST",39,0) ;" INFO("SIGNON-UCI,VOL") -- should have Sign-on UCI,VOL "RTN","TMGMGRST",40,0) ;" INFO("VOLUME-SET")--should have: NAME OF VOLUME SET (use same volume set as for 'Production') "RTN","TMGMGRST",41,0) ;" INFO("TEMP") -- should have temp directory for system "RTN","TMGMGRST",42,0) ;"Output: "RTN","TMGMGRST",43,0) ;" If in SILENT-OUTPUT mode, then output that would normally go to the screen, will be routed to this array "RTN","TMGMGRST",44,0) ;" NOTE: INFO SHOULD BE PASSED BY REFERENCE if user wants this information passed back out. "RTN","TMGMGRST",45,0) ;" INFO("TEXT","LINES")=Number of output lines "RTN","TMGMGRST",46,0) ;" INFO("TEXT",1)= 1st output line "RTN","TMGMGRST",47,0) ;" INFO("TEXT",2)= 2nd output line, etc... "RTN","TMGMGRST",48,0) ; "RTN","TMGMGRST",49,0) ; "RTN","TMGMGRST",50,0) "RTN","TMGMGRST",51,0) IF '$data(DBIndent) NEW DBIndent SET DBIndent=0 "RTN","TMGMGRST",52,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"ZTMGRSET^TMGMGRST") "RTN","TMGMGRST",53,0) "RTN","TMGMGRST",54,0) N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR "RTN","TMGMGRST",55,0) NEW ABORT SET ABORT=0 ;//kt "RTN","TMGMGRST",56,0) NEW SILNTOUT SET SILNTOUT=$get(INFO("SILENT-OUTPUT"),0) ;//kt "RTN","TMGMGRST",57,0) NEW SILENTIN SET SILENTIN=$GET(INFO("SILENT-INPUT"),0) ;//KT "RTN","TMGMGRST",58,0) KILL INFO("TEXT") ;//kt "RTN","TMGMGRST",59,0) "RTN","TMGMGRST",60,0) S ZTMODE=0 "RTN","TMGMGRST",61,0) A "RTN","TMGMGRST",62,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","ZTMGRSET","!","Version ",$P($T(ZTMGRSET+1),";",3)," ",$P($T(ZTMGRSET+1),";",5)) "RTN","TMGMGRST",63,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","HELLO! I'm here to help initialize the current account.") "RTN","TMGMGRST",64,0) "RTN","TMGMGRST",65,0) ; "RTN","TMGMGRST",66,0) SET Y=0 ;//kt added "RTN","TMGMGRST",67,0) I $D(^%ZOSF("UCI")) X ^%ZOSF("UCI") "RTN","TMGMGRST",68,0) new CurUCI set CurUCI=Y "RTN","TMGMGRST",69,0) I CurUCI'["MG" DO QUIT:(ABORT=1) "RTN","TMGMGRST",70,0) . write !,!,"CurUCI=",CurUCI,! "RTN","TMGMGRST",71,0) . DO OUTP^TMGQIO(SILNTOUT,$C(7),"!","!","THIS MAY NOT BE THE MANAGER UCI.","!") "RTN","TMGMGRST",72,0) . DO OUTP^TMGQIO(SILNTOUT," I think it is ",CurUCI,". Should I continue anyway? N//") "RTN","TMGMGRST",73,0) . DO INP^TMGQIO(.X,SILENTIN,120,$GET(INFO("CONTINUE"))) "RTN","TMGMGRST",74,0) . IF "Yy"'[$E(X_"N") DO OUTP^TMGQIO(SILNTOUT,"QUITING.","!") SET ABORT=1 QUIT "RTN","TMGMGRST",75,0) ; "RTN","TMGMGRST",76,0) S ZTOS=$$OS() "RTN","TMGMGRST",77,0) I ZTOS'>0 DO OUTP^TMGQIO(SILNTOUT,"!","Can't determine the OS type. Exiting ZTMGRSET.") QUIT "RTN","TMGMGRST",78,0) ; "RTN","TMGMGRST",79,0) I ZTMODE D QUIT:(ABORT=1) "RTN","TMGMGRST",80,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","Patch number to load: ") "RTN","TMGMGRST",81,0) . DO INP^TMGQIO(.PCNM,SILENTIN,,$get(INFO("PATCHNUM"))) "RTN","TMGMGRST",82,0) . IF (PCNM<1)!(PCNM>999) DO QUIT "RTN","TMGMGRST",83,0) . . DO OUTP^TMGQIO(SILNTOUT,"!","!","Need a Patch number to load. Exiting ZTMGRSET") "RTN","TMGMGRST",84,0) . . SET ABORT=1 "RTN","TMGMGRST",85,0) . S SCR="I $P($T(+2^@X),"";"",5)?.E1P1"_$C(34)_PCNM_$C(34)_"1P.E" "RTN","TMGMGRST",86,0) ; "RTN","TMGMGRST",87,0) ; "RTN","TMGMGRST",88,0) K ^%ZOSF("MASTER"),^("SIGNOFF") ;Remove old nodes. "RTN","TMGMGRST",89,0) ; "RTN","TMGMGRST",90,0) DOIT "RTN","TMGMGRST",91,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","I will now rename a group of routines specific to your operating system.","!") "RTN","TMGMGRST",92,0) D @ZTOS "RTN","TMGMGRST",93,0) D ALL "RTN","TMGMGRST",94,0) D GLOBALS:'ZTMODE "RTN","TMGMGRST",95,0) ; "RTN","TMGMGRST",96,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","Completed ZTMGRSET^TMGMGRST.","!","So I guess this is 'Goodbye'.","!","!") "RTN","TMGMGRST",97,0) ; "RTN","TMGMGRST",98,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"ZTMGRSET^TMGMGRST") "RTN","TMGMGRST",99,0) "RTN","TMGMGRST",100,0) Q "RTN","TMGMGRST",101,0) ; "RTN","TMGMGRST",102,0) ;============================================================================================== "RTN","TMGMGRST",103,0) ;============================================================================================== "RTN","TMGMGRST",104,0) ; "RTN","TMGMGRST",105,0) RELOAD ;Reload any patched routines "RTN","TMGMGRST",106,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"RELOAD^TMGMGRST") "RTN","TMGMGRST",107,0) N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR "RTN","TMGMGRST",108,0) S ZTMODE=1 G A "RTN","TMGMGRST",109,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"OS^TMGMGRST") "RTN","TMGMGRST",110,0) Q "RTN","TMGMGRST",111,0) ; "RTN","TMGMGRST",112,0) ;============================================================================================== "RTN","TMGMGRST",113,0) ;============================================================================================== "RTN","TMGMGRST",114,0) ; "RTN","TMGMGRST",115,0) OS() ;Select the OS "RTN","TMGMGRST",116,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"OS^TMGMGRST") "RTN","TMGMGRST",117,0) N Y,X1,X "RTN","TMGMGRST",118,0) S U="^",SCR="I 1" F I=1:1:20 S X=$T(@I) Q:X="" S OSMAX=I "RTN","TMGMGRST",119,0) B "RTN","TMGMGRST",120,0) S Y=0,ZTOS=0 I $D(^%ZOSF("OS")) D "RTN","TMGMGRST",121,0) . S X1=$P(^%ZOSF("OS"),U),ZTOS=$$OSNUM "RTN","TMGMGRST",122,0) . DO OUTP^TMGQIO(SILNTOUT,"!","I think you are using ",X1) "RTN","TMGMGRST",123,0) DO OUTP^TMGQIO(SILNTOUT,"!","Which MUMPS system should I install?","!") "RTN","TMGMGRST",124,0) DO OUTP^TMGQIO(SILNTOUT,"!",0," = Abort;") "RTN","TMGMGRST",125,0) F I=1:1:OSMAX DO OUTP^TMGQIO(SILNTOUT,"!",I," = ",$P($T(@I),";",3)) "RTN","TMGMGRST",126,0) DO OUTP^TMGQIO(SILNTOUT,"!","System: ") "RTN","TMGMGRST",127,0) IF ZTOS DO OUTP^TMGQIO(SILNTOUT,ZTOS,"//") "RTN","TMGMGRST",128,0) DO INP^TMGQIO(.X,SILENTIN,300,$get(INFO("OS"),U)) "RTN","TMGMGRST",129,0) IF X="" S X=ZTOS "RTN","TMGMGRST",130,0) IF (X=U)!(X=0) DO OUTP^TMGQIO(SILNTOUT,"!") SET X=0 GOTO OSQ "RTN","TMGMGRST",131,0) I X<1!(X>OSMAX) DO OUTP^TMGQIO(SILNTOUT,"!","NOT A VALID OS CHOICE") GOTO B "RTN","TMGMGRST",132,0) OSQ "RTN","TMGMGRST",133,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"OS^TMGMGRST") "RTN","TMGMGRST",134,0) QUIT X "RTN","TMGMGRST",135,0) ; "RTN","TMGMGRST",136,0) "RTN","TMGMGRST",137,0) OSNUM() ;Return the OS number "RTN","TMGMGRST",138,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"OSNUM^TMGMGRST") "RTN","TMGMGRST",139,0) N I,X1,X2,Y S Y=0,X1=$P($G(^%ZOSF("OS")),"^") "RTN","TMGMGRST",140,0) F I=1:1 S X2=$T(@I) Q:X2="" I X2[X1 S Y=I QUIT "RTN","TMGMGRST",141,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"OSNUM^TMGMGRST") "RTN","TMGMGRST",142,0) QUIT Y "RTN","TMGMGRST",143,0) ; "RTN","TMGMGRST",144,0) "RTN","TMGMGRST",145,0) ALL "RTN","TMGMGRST",146,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"ALL^TMGMGRST") "RTN","TMGMGRST",147,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","Now to load routines common to all systems.") "RTN","TMGMGRST",148,0) D TM,ETRAP,DEV,OTHER,FM "RTN","TMGMGRST",149,0) I ZTOS=7!(ZTOS=8) D "RTN","TMGMGRST",150,0) . S ^%ZE="D ^ZE" "RTN","TMGMGRST",151,0) E D ;With ZLoad, ZSave, ZInsert "RTN","TMGMGRST",152,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Installing ^%Z editor") "RTN","TMGMGRST",153,0) . D ^ZTEDIT "RTN","TMGMGRST",154,0) I 'ZTMODE DO "RTN","TMGMGRST",155,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Setting ^%ZIS('C')") "RTN","TMGMGRST",156,0) . K ^%ZIS("C") "RTN","TMGMGRST",157,0) . S ^%ZIS("C")="G ^%ZISC" "RTN","TMGMGRST",158,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"ALL^TMGMGRST") "RTN","TMGMGRST",159,0) Q "RTN","TMGMGRST",160,0) ; "RTN","TMGMGRST",161,0) "RTN","TMGMGRST",162,0) TM ;Taskman "RTN","TMGMGRST",163,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"TM^TMGMGRST") "RTN","TMGMGRST",164,0) S %S="ZTLOAD^ZTLOAD1^ZTLOAD2^ZTLOAD3^ZTLOAD4^ZTLOAD5^ZTLOAD6^ZTLOAD7" "RTN","TMGMGRST",165,0) S %D="%ZTLOAD^%ZTLOAD1^%ZTLOAD2^%ZTLOAD3^%ZTLOAD4^%ZTLOAD5^%ZTLOAD6^%ZTLOAD7" "RTN","TMGMGRST",166,0) D MOVE "RTN","TMGMGRST",167,0) S %S="ZTM^ZTM0^ZTM1^ZTM2^ZTM3^ZTM4^ZTM5^ZTM6" "RTN","TMGMGRST",168,0) S %D="%ZTM^%ZTM0^%ZTM1^%ZTM2^%ZTM3^%ZTM4^%ZTM5^%ZTM6" "RTN","TMGMGRST",169,0) D MOVE "RTN","TMGMGRST",170,0) S %S="ZTMS^ZTMS0^ZTMS1^ZTMS2^ZTMS3^ZTMS4^ZTMS5^ZTMS7^ZTMSH" "RTN","TMGMGRST",171,0) ;I ZTOS=7!(ZTOS=8) S $P(%S,U,1)="ZTMSGTM" "RTN","TMGMGRST",172,0) S %D="%ZTMS^%ZTMS0^%ZTMS1^%ZTMS2^%ZTMS3^%ZTMS4^%ZTMS5^%ZTMS7^%ZTMSH" "RTN","TMGMGRST",173,0) D MOVE "RTN","TMGMGRST",174,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"TM^TMGMGRST") "RTN","TMGMGRST",175,0) Q "RTN","TMGMGRST",176,0) "RTN","TMGMGRST",177,0) FM ;Rename the FileMan routines "RTN","TMGMGRST",178,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"FM^TMGMGRST") "RTN","TMGMGRST",179,0) I ZTMODE=1 GOTO FMQ ;"Only ask on full install "RTN","TMGMGRST",180,0) DO INP^TMGQIO(.X,SILENTIN,600,$get(INFO("RENAME"),"N"),"!","!","Want to rename the FileMan routines: No//") "RTN","TMGMGRST",181,0) GOTO:"Yy"'[$E(X_"N") FMQ "RTN","TMGMGRST",182,0) S %S="DIDT^DIDTC^DIRCR",%D="%DT^%DTC^%RCR" "RTN","TMGMGRST",183,0) D MOVE "RTN","TMGMGRST",184,0) FMQ "RTN","TMGMGRST",185,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"FM^TMGMGRST") "RTN","TMGMGRST",186,0) QUIT "RTN","TMGMGRST",187,0) ; "RTN","TMGMGRST",188,0) ; "RTN","TMGMGRST",189,0) ETRAP ;Error Trap "RTN","TMGMGRST",190,0) S %S="ZTER^ZTER1",%D="%ZTER^%ZTER1" "RTN","TMGMGRST",191,0) D MOVE "RTN","TMGMGRST",192,0) Q "RTN","TMGMGRST",193,0) ; "RTN","TMGMGRST",194,0) ; "RTN","TMGMGRST",195,0) OTHER "RTN","TMGMGRST",196,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"OTHER^TMGMGRST") "RTN","TMGMGRST",197,0) S %S="ZTPP^ZTP1^ZTPTCH^ZTRDEL^ZTMOVE" "RTN","TMGMGRST",198,0) S %D="%ZTPP^%ZTP1^%ZTPTCH^%ZTRDEL^%ZTMOVE" "RTN","TMGMGRST",199,0) D MOVE "RTN","TMGMGRST",200,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"OTHER^TMGMGRST") "RTN","TMGMGRST",201,0) Q "RTN","TMGMGRST",202,0) ; "RTN","TMGMGRST",203,0) ; "RTN","TMGMGRST",204,0) DEV "RTN","TMGMGRST",205,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"DEV^TMGMGRST") "RTN","TMGMGRST",206,0) S %S="ZIS^ZIS1^ZIS2^ZIS3^ZIS5^ZIS6^ZIS7^ZISC^ZISP^ZISS^ZISS1^ZISS2^ZISTCP^ZISUTL" "RTN","TMGMGRST",207,0) S %D="%ZIS^%ZIS1^%ZIS2^%ZIS3^%ZIS5^%ZIS6^%ZIS7^%ZISC^%ZISP^%ZISS^%ZISS1^%ZISS2^%ZISTCP^%ZISUTL" "RTN","TMGMGRST",208,0) D MOVE "RTN","TMGMGRST",209,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"DEV^TMGMGRST") "RTN","TMGMGRST",210,0) Q "RTN","TMGMGRST",211,0) ; "RTN","TMGMGRST",212,0) ; "RTN","TMGMGRST",213,0) RUM ;Build the routines for Capacity Management (CM) "RTN","TMGMGRST",214,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"RUM^TMGMGRST") "RTN","TMGMGRST",215,0) S %S="" "RTN","TMGMGRST",216,0) I ZTOS=1 S %S="ZOSVKRV^ZOSVKSVE^ZOSVKSVS^ZOSVKSD" ;DSM "RTN","TMGMGRST",217,0) I ZTOS=2 S %S="ZOSVKRM^ZOSVKSME^ZOSVKSMS^ZOSVKSD" ;MSM "RTN","TMGMGRST",218,0) I ZTOS=3 S %S="ZOSVKRO^ZOSVKSOE^ZOSVKSOS^ZOSVKSD" ;OpenM "RTN","TMGMGRST",219,0) I ZTOS=7!(ZTOS=8) S %S="ZOSVKRG^ZOSVKSGE^ZOSVKSGS^ZOSVKSD" ;GT.M "RTN","TMGMGRST",220,0) S %D="%ZOSVKR^%ZOSVKSE^%ZOSVKSS^%ZOSVKSD" "RTN","TMGMGRST",221,0) D MOVE "RTN","TMGMGRST",222,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"RUM^TMGMGRST") "RTN","TMGMGRST",223,0) Q "RTN","TMGMGRST",224,0) ; "RTN","TMGMGRST",225,0) ; "RTN","TMGMGRST",226,0) ZOSF(X) ; "RTN","TMGMGRST",227,0) ;"Note: KT made change to this function. It used to be that it would be "RTN","TMGMGRST",228,0) ;" called as do ZOSF("FUNCTION"). Now it should be called like this: "RTN","TMGMGRST",229,0) ;" ZOSF("^FUNCTION"). The old fuction would automatically prefix "RTN","TMGMGRST",230,0) ;" all calls with a '^'. I took this out so that calls to functions "RTN","TMGMGRST",231,0) ;" contained in this module are possible. "RTN","TMGMGRST",232,0) ; "RTN","TMGMGRST",233,0) ;"IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"ZOSF^TMGMGRST") "RTN","TMGMGRST",234,0) X SCR "RTN","TMGMGRST",235,0) I $T DO @(X) "RTN","TMGMGRST",236,0) ;"IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"ZOSF^TMGMGRST") "RTN","TMGMGRST",237,0) Q "RTN","TMGMGRST",238,0) ; "RTN","TMGMGRST",239,0) ; "RTN","TMGMGRST",240,0) 1 ;;VAX DSM(V6), VAX DSM(V7) "RTN","TMGMGRST",241,0) S %S="ZOSVVXD^ZTBKCVXD^ZIS4VXD^ZISFVXD^ZISHVXD^XUCIVXD^ZISETVXD" "RTN","TMGMGRST",242,0) D DES,MOVE "RTN","TMGMGRST",243,0) S %S="ZOSV2VXD^ZTMDCL",%D="%ZOSV2^%ZTMDCL" "RTN","TMGMGRST",244,0) D MOVE,RUM,ZOSF("^ZOSFVXD") "RTN","TMGMGRST",245,0) Q "RTN","TMGMGRST",246,0) ; "RTN","TMGMGRST",247,0) ; "RTN","TMGMGRST",248,0) 2 ;;MSM-PC/PLUS, MSM for NT or UNIX "RTN","TMGMGRST",249,0) DO OUTP^TMGQIO(SILNTOUT,"!","- Use autostart to do ZTMB don't resave as STUSER.") "RTN","TMGMGRST",250,0) S %S="ZOSVMSM^ZTBKCMSM^ZIS4MSM^ZISFMSM^ZISHMSM^XUCIMSM^ZISETMSM" "RTN","TMGMGRST",251,0) D DES,MOVE "RTN","TMGMGRST",252,0) S %S="ZOSV2MSM",%D="%ZOSV2" "RTN","TMGMGRST",253,0) D MOVE,RUM,ZOSF("^ZOSFMSM") "RTN","TMGMGRST",254,0) I $$VERSION^%ZOSV(1)["UNIX" S %S="ZISHMSU",%D="%ZISH" D MOVE "RTN","TMGMGRST",255,0) Q "RTN","TMGMGRST",256,0) ; "RTN","TMGMGRST",257,0) ; "RTN","TMGMGRST",258,0) 3 ;;OpenM for NT, Cache/NT, Cache/VMS "RTN","TMGMGRST",259,0) S %S="ZOSVONT^^ZIS4ONT^ZISFONT^ZISHONT^XUCIONT" "RTN","TMGMGRST",260,0) D DES,MOVE "RTN","TMGMGRST",261,0) S %S="ZISTCPS",%D="%ZISTCPS" "RTN","TMGMGRST",262,0) D MOVE,RUM,ZOSF("^ZOSFONT") "RTN","TMGMGRST",263,0) Q "RTN","TMGMGRST",264,0) ; "RTN","TMGMGRST",265,0) ; "RTN","TMGMGRST",266,0) 4 ;;Datatree, DTM-PC, DT-MAX "RTN","TMGMGRST",267,0) S %S="ZOSVDTM^ZTBKCDTM^ZIS4DTM^ZISFDTM^ZISHDTM^XUCIDTM^ZISETDTM" "RTN","TMGMGRST",268,0) D DES,MOVE "RTN","TMGMGRST",269,0) S %S="ZOSV1DTM^ZTMB",%D="%ZOSV1^%ustart" "RTN","TMGMGRST",270,0) D MOVE,ZOSF("^ZOSFDTM") "RTN","TMGMGRST",271,0) Q "RTN","TMGMGRST",272,0) ; "RTN","TMGMGRST",273,0) ; "RTN","TMGMGRST",274,0) 5 ;;MVX,ISM VAX "RTN","TMGMGRST",275,0) S %S="ZOSVMSQ^ZTBKCMSQ^ZIS4MSQ^ZISFMSQ^ZISHMSQ^XUCIMSQ^ZISETMSQ" "RTN","TMGMGRST",276,0) D DES,MOVE "RTN","TMGMGRST",277,0) S %S="ZTMB",%D="ZSTU" "RTN","TMGMGRST",278,0) D MOVE,ZOSF("^ZOSFMSQ") "RTN","TMGMGRST",279,0) Q "RTN","TMGMGRST",280,0) ; "RTN","TMGMGRST",281,0) ; "RTN","TMGMGRST",282,0) 6 ;;ISM (UNIX, Open VMS) "RTN","TMGMGRST",283,0) S %S="ZOSVIS2^^ZIS4IS2^ZISFIS2^ZISHIS2^XUCIIS2^ZISETIS2" "RTN","TMGMGRST",284,0) D DES,MOVE "RTN","TMGMGRST",285,0) S %S="ZTMB",%D="ZSTU" "RTN","TMGMGRST",286,0) D MOVE,ZOSF("^ZOSFIS2") "RTN","TMGMGRST",287,0) Q "RTN","TMGMGRST",288,0) ; "RTN","TMGMGRST",289,0) ; "RTN","TMGMGRST",290,0) 7 ;;GT.M (VMS) "RTN","TMGMGRST",291,0) S %S="ZOSVGTM^ZTBKCGTM^ZIS4GTM^ZISFGTM^ZISHGTM^XUCIGTM^ZISETGTM" "RTN","TMGMGRST",292,0) D DES,MOVE "RTN","TMGMGRST",293,0) S %S="ZOSV2GTM^ZISTCPS",%D="%ZOSV2^%ZISTCPS" "RTN","TMGMGRST",294,0) D MOVE,ZOSF("^ZOSFGTM") "RTN","TMGMGRST",295,0) Q "RTN","TMGMGRST",296,0) ; "RTN","TMGMGRST",297,0) ; "RTN","TMGMGRST",298,0) 8 ;;GT.M (Unix) "RTN","TMGMGRST",299,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"8^TMGMGRST") "RTN","TMGMGRST",300,0) S %S="ZOSVGUX^ZTBKCGUX^ZIS4GTM^ZISFGTM^ZISHGUX^XUCIGTM^ZISETGUX" "RTN","TMGMGRST",301,0) ;S %S="ZOSVGUX^ZIS4GTM^ZISFGTM^ZISHGUX^XUCIGTM" ;//kt removed 2 files that were missing "RTN","TMGMGRST",302,0) D DES "RTN","TMGMGRST",303,0) D MOVE "RTN","TMGMGRST",304,0) S %S="ZOSV2GTM^ZISTCPS",%D="%ZOSV2^%ZISTCPS" "RTN","TMGMGRST",305,0) D MOVE "RTN","TMGMGRST",306,0) D ZOSF("ZOSFGUX") "RTN","TMGMGRST",307,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"8^TMGMGRST") "RTN","TMGMGRST",308,0) Q "RTN","TMGMGRST",309,0) ; "RTN","TMGMGRST",310,0) ; "RTN","TMGMGRST",311,0) 10 ;;NOT SUPPORTED "RTN","TMGMGRST",312,0) Q "RTN","TMGMGRST",313,0) ; "RTN","TMGMGRST",314,0) ; "RTN","TMGMGRST",315,0) MOVE ; rename % routines "RTN","TMGMGRST",316,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"MOVE^TMGMGRST") "RTN","TMGMGRST",317,0) N %,X,Y "RTN","TMGMGRST",318,0) F %=1:1:$L(%D,"^") D "RTN","TMGMGRST",319,0) . S X=$P(%S,U,%) ; from "RTN","TMGMGRST",320,0) . S Y=$P(%D,U,%) ; to "RTN","TMGMGRST",321,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Routine: ",X) "RTN","TMGMGRST",322,0) . NEW INDENT SET INDENT=12-$LENGTH(X) "RTN","TMGMGRST",323,0) . IF INDENT>0 DO OUTP^TMGQIO(SILNTOUT,"?"_INDENT) "RTN","TMGMGRST",324,0) . DO OUTP^TMGQIO(SILNTOUT," --> ",Y) "RTN","TMGMGRST",325,0) . SET INDENT=12-$LENGTH(Y) "RTN","TMGMGRST",326,0) . DO OUTP^TMGQIO(SILNTOUT,"?"_INDENT) "RTN","TMGMGRST",327,0) . Q:(X="")!(Y="") "RTN","TMGMGRST",328,0) . I $TEXT(^@X)="" DO QUIT "RTN","TMGMGRST",329,0) . . DO OUTP^TMGQIO(SILNTOUT,"Missing") "RTN","TMGMGRST",330,0) . X SCR "RTN","TMGMGRST",331,0) . Q:'$T "RTN","TMGMGRST",332,0) . IF $$COPY(X,Y)=0 DO "RTN","TMGMGRST",333,0) . . DO OUTP^TMGQIO(SILNTOUT,"Loaded") "RTN","TMGMGRST",334,0) . . ;"DO OUTP^TMGQIO(SILNTOUT,"?10","Saved as ",Y) "RTN","TMGMGRST",335,0) . ELSE DO "RTN","TMGMGRST",336,0) . . DO OUTP^TMGQIO(SILNTOUT,"Missing (Failed Copy)") "RTN","TMGMGRST",337,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"MOVE^TMGMGRST") "RTN","TMGMGRST",338,0) QUIT "RTN","TMGMGRST",339,0) ; "RTN","TMGMGRST",340,0) ; "RTN","TMGMGRST",341,0) COPY(FROM,TO) ; "RTN","TMGMGRST",342,0) ;"Purpose: To copy file FROM to TO, getting directory path from $ZRO "RTN","TMGMGRST",343,0) ;"Input: FROM-- a filename without path or '.m' extension "RTN","TMGMGRST",344,0) ;" TO-- a filename without path or '.m' extension "RTN","TMGMGRST",345,0) ;"Result: 0: no error 1=error "RTN","TMGMGRST",346,0) ; "RTN","TMGMGRST",347,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"COPY^TMGMGRST") "RTN","TMGMGRST",348,0) NEW RESULT SET RESULT=0 "RTN","TMGMGRST",349,0) I ZTOS'=7,ZTOS'=8 DO GOTO CPQ "RTN","TMGMGRST",350,0) . X "ZL @FROM ZS @TO" "RTN","TMGMGRST",351,0) ; "RTN","TMGMGRST",352,0) ;"For GT.M below "RTN","TMGMGRST",353,0) ;"-------------- "RTN","TMGMGRST",354,0) ; "RTN","TMGMGRST",355,0) N PATH,COPY "RTN","TMGMGRST",356,0) SET FROM=$GET(FROM)_".m" "RTN","TMGMGRST",357,0) SET TO=$TR($GET(TO),"%","_")_".m" "RTN","TMGMGRST",358,0) S PATH=$$GETPATH(.FROM) "RTN","TMGMGRST",359,0) IF PATH="" SET RESULT=1 GOTO CPQ ;"QUIT 1 "RTN","TMGMGRST",360,0) IF $EXTRACT(PATH,$LENGTH(PATH))'="/" SET PATH=PATH_"/" ;"Ensure path ends in '/'. "RTN","TMGMGRST",361,0) S COPY=$S(ZTOS=7:"COPY",1:"cp") "RTN","TMGMGRST",362,0) ZSYSTEM COPY_" "_PATH_FROM_" "_PATH_TO "RTN","TMGMGRST",363,0) SET RESULT=$ZSYSTEM "RTN","TMGMGRST",364,0) ; "RTN","TMGMGRST",365,0) ;"IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBIndent,"M2") "RTN","TMGMGRST",366,0) ; "RTN","TMGMGRST",367,0) ; "RTN","TMGMGRST",368,0) CPQ "RTN","TMGMGRST",369,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"COPY^TMGMGRST") "RTN","TMGMGRST",370,0) QUIT RESULT "RTN","TMGMGRST",371,0) ; "RTN","TMGMGRST",372,0) GETPATH(FILE) "RTN","TMGMGRST",373,0) ;"Note: This function is for GTM, which has a path sequence that may be searched for files. "RTN","TMGMGRST",374,0) ;"Purpose: To take file, and look through file path to determine which path the file "RTN","TMGMGRST",375,0) ;" exists in. "RTN","TMGMGRST",376,0) ;" e.g. if $ZRO="ObjDir1(SourceDir1 SourceDir2) ObjDir2(SourceDir3 SourceDir4)" "RTN","TMGMGRST",377,0) ;" then this function will look in SourceDir's 1..4 to see which one contains "RTN","TMGMGRST",378,0) ;" FILE. Functions will return the appropriate SourceDir "RTN","TMGMGRST",379,0) ;"Input:FILE: the filename to look for, with extension. e.g. "XUP.m" "RTN","TMGMGRST",380,0) ;"Result: Will return the source directory, e.g. /usr/local/OpenVistA/r "RTN","TMGMGRST",381,0) ; "RTN","TMGMGRST",382,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"GETPATH^TMGMGRST") "RTN","TMGMGRST",383,0) NEW LASTDIR SET LASTDIR="" "RTN","TMGMGRST",384,0) NEW RESULT SET RESULT="" "RTN","TMGMGRST",385,0) NEW PATH SET PATH="" "RTN","TMGMGRST",386,0) ; "RTN","TMGMGRST",387,0) FOR DO QUIT:(RESULT'="")!(LASTDIR="") "RTN","TMGMGRST",388,0) . SET LASTDIR=$$R(LASTDIR) "RTN","TMGMGRST",389,0) . IF LASTDIR="" QUIT "RTN","TMGMGRST",390,0) . ;"DO OUTP^TMGQIO(SILNTOUT,"!","Looking in: ",LASTDIR) "RTN","TMGMGRST",391,0) . SET PATH=LASTDIR "RTN","TMGMGRST",392,0) . IF $$FEXISTS(PATH,FILE) DO "RTN","TMGMGRST",393,0) . . SET RESULT=PATH "RTN","TMGMGRST",394,0) . ELSE DO "RTN","TMGMGRST",395,0) ; "RTN","TMGMGRST",396,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"GETPATH^TMGMGRST") "RTN","TMGMGRST",397,0) QUIT RESULT "RTN","TMGMGRST",398,0) ; "RTN","TMGMGRST",399,0) ; "RTN","TMGMGRST",400,0) R(LASTDIR) ; routine directory for GT.M "RTN","TMGMGRST",401,0) ;"Notice: The comments here only apply to GTM for Linux (#8). "RTN","TMGMGRST",402,0) ;" I don't have details about GT.M for VMS (#7) so I have not implemented "RTN","TMGMGRST",403,0) ;" cyclic directory evaluation. LASTDIR will be ignored. "RTN","TMGMGRST",404,0) ;"INPUT: LASTDIR - OPTIONAL. This is the directory returned last time fuction called, to "RTN","TMGMGRST",405,0) ;" allow for cycling through all possible directories. "RTN","TMGMGRST",406,0) ;"NOTE: The Syntax for $ZRO is as follows: "RTN","TMGMGRST",407,0) ;" ObjectDir1(SourceDir1) ObjectDir2(SourceDir1 SourceDir2 ...) ObjectDir3() ObjectDir4 "RTN","TMGMGRST",408,0) ;" This shows elements are separated by spaces. "RTN","TMGMGRST",409,0) ;" Note that each element starts with the directory for .o files "RTN","TMGMGRST",410,0) ;" Each object directory has an optional (SourceDir) immediately following it "RTN","TMGMGRST",411,0) ;" if (Dir) is present, it contains one or more source directories (separated by spaces) "RTN","TMGMGRST",412,0) ;" if () is empty (i.e. "()") then no source directory is available. "RTN","TMGMGRST",413,0) ;" if (Dir) is absent (i.e. ""), then object dir is used to search for source .m files "RTN","TMGMGRST",414,0) ;"Result: will return the next directory, or "" if none. "RTN","TMGMGRST",415,0) ;" "RTN","TMGMGRST",416,0) ;"IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"R^TMGMGRST") "RTN","TMGMGRST",417,0) NEW RESULT SET RESULT="" "RTN","TMGMGRST",418,0) SET LASTDIR=$GET(LASTDIR) "RTN","TMGMGRST",419,0) ;"if LASTDIR'="" W "Will look for dir AFTER ",LASTDIR,! "RTN","TMGMGRST",420,0) I ZTOS=7 DO "RTN","TMGMGRST",421,0) . SET RESULT=$P($ZRO,",",1) "RTN","TMGMGRST",422,0) IF ZTOS=8 DO ;"GT.M for Linux "RTN","TMGMGRST",423,0) . NEW SECTION "RTN","TMGMGRST",424,0) . NEW PRIORFND SET PRIORFND=0 "RTN","TMGMGRST",425,0) . NEW ELEMENT SET ELEMENT=" " "RTN","TMGMGRST",426,0) . NEW DIVPTS ;"Array to hold cut points of $ZRO. Setup in GETSECTN "RTN","TMGMGRST",427,0) . SET DIVPTS("MAX")=0 "RTN","TMGMGRST",428,0) . FOR SECTION=1:1 DO QUIT:(RESULT'="")!(SECTION>DIVPTS("MAX")+1) "RTN","TMGMGRST",429,0) . . SET ELEMENT=$$GETSECTN($ZRO,SECTION,.DIVPTS) ;"gets 'ObjDir(SrceDir1 SrceDir2 ...)' etc. "RTN","TMGMGRST",430,0) . . NEW SOURCES SET SOURCES="" "RTN","TMGMGRST",431,0) . . IF (ELEMENT["(")&(ELEMENT[")") DO "RTN","TMGMGRST",432,0) . . . SET SOURCES=$PIECE(ELEMENT,"(",2) "RTN","TMGMGRST",433,0) . . . SET SOURCES=$PIECE(SOURCES,")",1) ;"Get just (..) part -- the source file paths. "RTN","TMGMGRST",434,0) . . ELSE DO "RTN","TMGMGRST",435,0) . . . SET SOURCES=ELEMENT ;"i.e. for ObjectDir [i.e. not ObjectDir()] format. "RTN","TMGMGRST",436,0) . . IF (ELEMENT="")!(SOURCES="") QUIT "RTN","TMGMGRST",437,0) . . NEW PART "RTN","TMGMGRST",438,0) . . NEW PATH SET PATH=" " "RTN","TMGMGRST",439,0) . . FOR PART=1:1 DO QUIT:(RESULT'="")!(PATH="") "RTN","TMGMGRST",440,0) . . . SET PATH=$PIECE(SOURCES," ",PART) ;"returns 'SourceDir1' etc. "RTN","TMGMGRST",441,0) . . . IF PATH="" QUIT "RTN","TMGMGRST",442,0) . . . IF (LASTDIR="")!(PRIORFND) SET RESULT=PATH "RTN","TMGMGRST",443,0) . . . ELSE IF PATH=LASTDIR SET PRIORFND=1 "RTN","TMGMGRST",444,0) ; "RTN","TMGMGRST",445,0) ;"OLDER CODE "RTN","TMGMGRST",446,0) ;". NEW temp "RTN","TMGMGRST",447,0) ;". SET temp=$ZRO "RTN","TMGMGRST",448,0) ;". IF $ZRO["(" DO "RTN","TMGMGRST",449,0) ;". SET temp=$P($ZRO,"(",2) "RTN","TMGMGRST",450,0) ;". SET temp=$P(temp,")",1) "RTN","TMGMGRST",451,0) ;". SET RESULT=$P(temp," ",1)_"/" "RTN","TMGMGRST",452,0) ; "RTN","TMGMGRST",453,0) ;"IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"R^TMGMGRST") "RTN","TMGMGRST",454,0) "RTN","TMGMGRST",455,0) QUIT RESULT "RTN","TMGMGRST",456,0) ; "RTN","TMGMGRST",457,0) ; "RTN","TMGMGRST",458,0) GETSECTN(S,NUM,DIVPTS) "RTN","TMGMGRST",459,0) ;"Purpose: To parse a string as follows: "RTN","TMGMGRST",460,0) ;" Expected format of S: "RTN","TMGMGRST",461,0) ;" ObjectDir(SourceDir1 SourceDir2 ...) ObjectDir2(SourceDir1 SourceDir2 ...) ... "RTN","TMGMGRST",462,0) ;" or ObjectDir ObjectDir2(SourceDir1 SourceDir2 ...) ObjectDir() ... etc. "RTN","TMGMGRST",463,0) ;" --- so major sections are divided by spaces, with optional () with optional contents. "RTN","TMGMGRST",464,0) ;" --- there is no nesting of parentheses. "RTN","TMGMGRST",465,0) ;" If NUM=1, return ObjectDir(SourceDir1 SourceDir2 ...) "RTN","TMGMGRST",466,0) ;" If NUM=2, return ObjectDir2(SourceDir1 SourceDir2 ...) etc. "RTN","TMGMGRST",467,0) ;" Notice: Spaces in ObjectDir name are NOT SUPPORTED "RTN","TMGMGRST",468,0) ;" Notice: If more than one space separates sections, will be treated as extra section "RTN","TMGMGRST",469,0) ;"INPUT: S -- string as above "RTN","TMGMGRST",470,0) ;" NUM -- the section number to get (1..n) "RTN","TMGMGRST",471,0) ;" DIVPTS -- [OPTIONAL] PASS BY REFERENCE. If empty, then will be filled "RTN","TMGMGRST",472,0) ;" with the indexes of the dividing spaces "RTN","TMGMGRST",473,0) ;" e.g. DIVPTS(1)=12 DIVPTS(2)=25 DIVPTS(3)=41 DIVPTS("MAX")=3 "RTN","TMGMGRST",474,0) ;" If not empty, then this will be used return the requested section. "RTN","TMGMGRST",475,0) ; "RTN","TMGMGRST",476,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"GETSECTN^TMGMGRST") "RTN","TMGMGRST",477,0) ; "RTN","TMGMGRST",478,0) NEW RESULT SET RESULT="" "RTN","TMGMGRST",479,0) NEW START SET START=0 "RTN","TMGMGRST",480,0) NEW END SET END=9999 "RTN","TMGMGRST",481,0) NEW PTIDX SET PTIDX=0 "RTN","TMGMGRST",482,0) NEW SECTION SET SECTION=0 "RTN","TMGMGRST",483,0) NEW MAXIDX "RTN","TMGMGRST",484,0) ; "RTN","TMGMGRST",485,0) SET S=$GET(S) "RTN","TMGMGRST",486,0) SET NUM=$GET(NUM,0) "RTN","TMGMGRST",487,0) ; "RTN","TMGMGRST",488,0) ;Fill Array of division points if empty "RTN","TMGMGRST",489,0) IF $DATA(DIVPTS)'=11 DO "RTN","TMGMGRST",490,0) . NEW INPAREN SET INPAREN=0 "RTN","TMGMGRST",491,0) . NEW I,CH "RTN","TMGMGRST",492,0) . FOR I=1:1:$LENGTH(S) DO "RTN","TMGMGRST",493,0) . . SET CH=$EXTRACT(S,I) "RTN","TMGMGRST",494,0) . . IF CH="(" SET INPAREN=1 QUIT "RTN","TMGMGRST",495,0) . . IF CH=")" SET INPAREN=0 QUIT "RTN","TMGMGRST",496,0) . . IF (CH=" ")&(INPAREN=0) DO "RTN","TMGMGRST",497,0) . . . SET PTIDX=PTIDX+1 "RTN","TMGMGRST",498,0) . . . SET DIVPTS(PTIDX)=I "RTN","TMGMGRST",499,0) . . . SET DIVPTS("MAX")=PTIDX "RTN","TMGMGRST",500,0) ; "RTN","TMGMGRST",501,0) IF (NUM>0)&(NUM'>DIVPTS("MAX")+1) DO "RTN","TMGMGRST",502,0) . SET PTIDX=$ORDER(DIVPTS(0)) "RTN","TMGMGRST",503,0) . ;" 1 2 3 <-- Section #'2 "RTN","TMGMGRST",504,0) . ;"xxxxx xxxxxx xxxxx <-- sample S "RTN","TMGMGRST",505,0) . ;" ^ ^ <-- DIVPTS 1 & 2 "RTN","TMGMGRST",506,0) . IF NUM>1 SET START=DIVPTS(NUM-1)+1 ;"default START=0 "RTN","TMGMGRST",507,0) . IF NUM'>DIVPTS("MAX") SET END=DIVPTS(NUM)-1 ;"default END=9999 "RTN","TMGMGRST",508,0) . SET RESULT=$EXTRACT(S,START,END) "RTN","TMGMGRST",509,0) ; "RTN","TMGMGRST",510,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"GETSECTN^TMGMGRST") "RTN","TMGMGRST",511,0) QUIT RESULT "RTN","TMGMGRST",512,0) ; "RTN","TMGMGRST",513,0) ; "RTN","TMGMGRST",514,0) FEXISTS(PATH,FNAME) "RTN","TMGMGRST",515,0) ;"Purpose: To determine if file FNAME exists on HFS "RTN","TMGMGRST",516,0) ;"Input: PATH: full path up to, but not including, filename. e.g. '/home/user/' "RTN","TMGMGRST",517,0) ;" FNAME: name of the file to open. e.g. 'myfile.txt' "RTN","TMGMGRST",518,0) ;"Result: 1=file exists, 0=file doesn't exist "RTN","TMGMGRST",519,0) ;"IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"FEXISTS^TMGMGRST") "RTN","TMGMGRST",520,0) NEW RESULT SET RESULT=0 "RTN","TMGMGRST",521,0) IF ($DATA(PATH)'=0)!($DATA(FNAME)'=0) DO "RTN","TMGMGRST",522,0) . NEW HANDLE SET HANDLE="" "RTN","TMGMGRST",523,0) . DO OPEN^%ZISH(HANDLE,PATH,FNAME,"R") ;"Try to access file "RTN","TMGMGRST",524,0) . IF POP=0 DO ;"POP=0 means file opened, ergo file exists. "RTN","TMGMGRST",525,0) . . SET RESULT=1 "RTN","TMGMGRST",526,0) . . DO CLOSE^%ZISH(HANDLE) ;"close file... we don't need it. "RTN","TMGMGRST",527,0) ;"IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"FEXISTS^TMGMGRST") "RTN","TMGMGRST",528,0) QUIT RESULT "RTN","TMGMGRST",529,0) ; "RTN","TMGMGRST",530,0) ; "RTN","TMGMGRST",531,0) SPLITF(IN,PATH,FNAME,NODEDIV) "RTN","TMGMGRST",532,0) ;"Purpose: To take a string with path and filename and "RTN","TMGMGRST",533,0) ;" cleave into a path string and a filename string "RTN","TMGMGRST",534,0) ;"Input: IN: Initial string to parse. e.g. /home/user1/somefile.txt "RTN","TMGMGRST",535,0) ;" PATH & FNAME: vars SHOULD BE PASSED BY REFERENCE -- to take out results "RTN","TMGMGRST",536,0) ;" The character used to divide nodes, e.g. '/' OPTIONAL .. defaults to '/' "RTN","TMGMGRST",537,0) ;"Output:PATH: the path part of IN, e.g. '/home/user1/' "RTN","TMGMGRST",538,0) ;" FNAME: the filename part of IN, e.g. 'somefile.txt' "RTN","TMGMGRST",539,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"SPLITF^TMGMGRST") "RTN","TMGMGRST",540,0) SET NODEDIV=$GET(NODEDIV,"/") "RTN","TMGMGRST",541,0) SET PATH=$GET(PATH) "RTN","TMGMGRST",542,0) SET FNAME=$GET(IN) "RTN","TMGMGRST",543,0) NEW DONE SET DONE=0 "RTN","TMGMGRST",544,0) FOR DO QUIT:(DONE=1) "RTN","TMGMGRST",545,0) IF FNAME[NODEDIV DO "RTN","TMGMGRST",546,0) . SET PATH=PATH_$PIECE(FNAME,NODEDIV,1)_NODEDIV "RTN","TMGMGRST",547,0) . SET FNAME=$PIECE(FNAME,NODEDIV,2,256) "RTN","TMGMGRST",548,0) ELSE SET DONE=1 "RTN","TMGMGRST",549,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"SPLITF^TMGMGRST") "RTN","TMGMGRST",550,0) QUIT "RTN","TMGMGRST",551,0) ; "RTN","TMGMGRST",552,0) ; "RTN","TMGMGRST",553,0) DES "RTN","TMGMGRST",554,0) S %D="%ZOSV^%ZTBKC1^%ZIS4^%ZISF^%ZISH^%XUCI^ZISETUP" "RTN","TMGMGRST",555,0) Q "RTN","TMGMGRST",556,0) ; "RTN","TMGMGRST",557,0) ; "RTN","TMGMGRST",558,0) GLOBALS ;Set node zero of file #3.05 & #3.07 "RTN","TMGMGRST",559,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"GLOBALS^TMGMGRST") "RTN","TMGMGRST",560,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","Now, I will check your % globals.") "RTN","TMGMGRST",561,0) DO OUTP^TMGQIO(SILNTOUT,"..........") "RTN","TMGMGRST",562,0) F %="^%ZIS","^%ZISL","^%ZTER","^%ZUA" S:'$D(@%) @%="" "RTN","TMGMGRST",563,0) S:$D(^%ZTSK(0))[0 ^%ZTSK(-1)=100,^%ZTSCH="" "RTN","TMGMGRST",564,0) S Z1=$G(^%ZTSK(-1),-1),Z2=$G(^%ZTSK(0)) "RTN","TMGMGRST",565,0) I Z1'=$P(Z2,"^",3) S:Z1'>0 ^%ZTSK(-1)=+Z2 S ^%ZTSK(0)="TASK'S^14.4^"_^%ZTSK(-1) "RTN","TMGMGRST",566,0) S:$D(^%ZUA(3.05,0))[0 ^%ZUA(3.05,0)="FAILED ACCESS ATTEMPTS LOG^3.05^^" "RTN","TMGMGRST",567,0) S:$D(^%ZUA(3.07,0))[0 ^%ZUA(3.07,0)="PROGRAMMER MODE LOG^3.07^^" "RTN","TMGMGRST",568,0) DO OUTP^TMGQIO(SILNTOUT,"... Done") "RTN","TMGMGRST",569,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"GLOBALS^TMGMGRST") "RTN","TMGMGRST",570,0) Q "RTN","TMGMGRST",571,0) ; "RTN","TMGMGRST",572,0) ; "RTN","TMGMGRST",573,0) NAME() ;Setup the static names for this system "RTN","TMGMGRST",574,0) ;"Input -- none "RTN","TMGMGRST",575,0) ;"Result -- 0=normal exit 1=error "RTN","TMGMGRST",576,0) ; "RTN","TMGMGRST",577,0) ;"WRITE "IN CUSTOM NAME FUNCTION",! "RTN","TMGMGRST",578,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"NAME^TMGMGRST") "RTN","TMGMGRST",579,0) ; "RTN","TMGMGRST",580,0) NEW RETRY SET RETRY=0 "RTN","TMGMGRST",581,0) NEW ABORT SET ABORT=0 "RTN","TMGMGRST",582,0) NEW RESULT SET RESULT=1 "RTN","TMGMGRST",583,0) ; "RTN","TMGMGRST",584,0) MGR "RTN","TMGMGRST",585,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBIndent,"M1") "RTN","TMGMGRST",586,0) "RTN","TMGMGRST",587,0) IF ABORT=1 GOTO NMQ "RTN","TMGMGRST",588,0) SET RETRY=0 "RTN","TMGMGRST",589,0) DO OUTP^TMGQIO(SILNTOUT,"!","!","ENTER NAME OF MANAGER'S UCI,VOLUME SET: "_^%ZOSF("MGR")_"// ") "RTN","TMGMGRST",590,0) DO INP^TMGQIO(.X,SILENTIN,$G(DTIME,9999),$get(INFO("MGR-UCI,VOL"))) "RTN","TMGMGRST",591,0) IF X="" SET X=^%ZOSF("MGR") "RTN","TMGMGRST",592,0) IF X="^" DO OUTP^TMGQIO(SILNTOUT,"!","SKIPPING...") GOTO NMQ "RTN","TMGMGRST",593,0) I X]"" DO IF (RETRY=1) goto MGR "RTN","TMGMGRST",594,0) . X ^("UCICHECK") "RTN","TMGMGRST",595,0) . IF 0[Y DO "RTN","TMGMGRST",596,0) . . SET RETRY=1 "RTN","TMGMGRST",597,0) . . IF SILENTIN=1 DO "RTN","TMGMGRST",598,0) . . . DO OUTP^TMGQIO(SILNTOUT,"!","Invalid Manager's UCI,VOLUME SET") "RTN","TMGMGRST",599,0) . . . SET ABORT=1 "RTN","TMGMGRST",600,0) S ^%ZOSF("MGR")=X "RTN","TMGMGRST",601,0) ; "RTN","TMGMGRST",602,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBIndent,"M2") "RTN","TMGMGRST",603,0) ; "RTN","TMGMGRST",604,0) PROD "RTN","TMGMGRST",605,0) IF ABORT=1 GOTO NMQ "RTN","TMGMGRST",606,0) SET RETRY=0 "RTN","TMGMGRST",607,0) DO OUTP^TMGQIO(SILNTOUT,"!","ENTER PRODUCTION (SIGN-ON) UCI,VOLUME SET: "_^%ZOSF("PROD")_"// ") "RTN","TMGMGRST",608,0) DO INP^TMGQIO(.X,SILENTIN,$S($G(DTIME):DTIME,1:9999),$get(INFO("SIGNON-UCI,VOL"))) "RTN","TMGMGRST",609,0) IF X="" SET X=^%ZOSF("PROD") "RTN","TMGMGRST",610,0) IF X="^" DO OUTP^TMGQIO(SILNTOUT,"!","SKIPPING...") GOTO NMQ "RTN","TMGMGRST",611,0) I X]"" DO IF (RETRY=1) goto PROD "RTN","TMGMGRST",612,0) . X ^("UCICHECK") "RTN","TMGMGRST",613,0) . IF 0[Y DO "RTN","TMGMGRST",614,0) . . DO OUTP^TMGQIO(SILNTOUT,"!","Invalid Sign-On UCI,VOLUME SET","!") "RTN","TMGMGRST",615,0) . . SET RETRY=1 "RTN","TMGMGRST",616,0) . . IF SILENTIN=1 SET ABORT=1 "RTN","TMGMGRST",617,0) S ^%ZOSF("PROD")=X "RTN","TMGMGRST",618,0) ; "RTN","TMGMGRST",619,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBIndent,"M3") "RTN","TMGMGRST",620,0) ; "RTN","TMGMGRST",621,0) VOL "RTN","TMGMGRST",622,0) IF ABORT=1 GOTO NMQ "RTN","TMGMGRST",623,0) SET RETRY=0 "RTN","TMGMGRST",624,0) DO OUTP^TMGQIO(SILNTOUT,"!","ENTER NAME OF VOLUME SET (use same volume set as for 'Production'): "_^%ZOSF("VOL")_"//") "RTN","TMGMGRST",625,0) DO INP^TMGQIO(.X,SILENTIN,$G(DTIME,9999),$get(INFO("VOLUME-SET"))) "RTN","TMGMGRST",626,0) IF X="" SET X=^%ZOSF("VOL") "RTN","TMGMGRST",627,0) IF X="^" DO OUTP^TMGQIO(SILNTOUT,"!","SKIPPING...") GOTO NMQ "RTN","TMGMGRST",628,0) I X]"" DO IF (RETRY=1) goto VOL "RTN","TMGMGRST",629,0) . IF (X'?3U)!(^%ZOSF("PROD")'[X) DO "RTN","TMGMGRST",630,0) . . DO OUTP^TMGQIO(SILNTOUT,"MUST be 3 upper-case letters.") "RTN","TMGMGRST",631,0) . . DO OUTP^TMGQIO(SILNTOUT,"Also, MUST be same Volume Set entered above.") "RTN","TMGMGRST",632,0) . . SET RETRY=1 "RTN","TMGMGRST",633,0) . . IF SILENTIN=1 DO "RTN","TMGMGRST",634,0) . . . DO OUTP^TMGQIO(SILNTOUT,"!","Invalid VOLUME SET") "RTN","TMGMGRST",635,0) . . . SET ABORT=1 "RTN","TMGMGRST",636,0) SET ^%ZOSF("VOL")=X "RTN","TMGMGRST",637,0) ; "RTN","TMGMGRST",638,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBIndent,"M4") "RTN","TMGMGRST",639,0) ; "RTN","TMGMGRST",640,0) ;"KT copied/modified TMP section from ZOSFGUX (GT.M/Linux specific) "RTN","TMGMGRST",641,0) TMP ;Get the temp directory "RTN","TMGMGRST",642,0) IF ABORT=1 GOTO NMQ "RTN","TMGMGRST",643,0) IF $GET(ZTOS)=8 DO GOTO TMP:(RETRY=1) "RTN","TMGMGRST",644,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Enter the temp directory for the system: '"_^%ZOSF("TMP")_"'//") "RTN","TMGMGRST",645,0) . DO INP^TMGQIO(.X,SILENTIN,$S($G(DTIME):DTIME,1:9999),$get(INFO("TEMP"))) "RTN","TMGMGRST",646,0) . IF X="" SET X=^%ZOSF("TMP") "RTN","TMGMGRST",647,0) . IF SILENTIN=0 SET ABORT=1 QUIT "RTN","TMGMGRST",648,0) . ELSE DO QUIT:(RETRY=1)!(ABORT=1) "RTN","TMGMGRST",649,0) . . IF X="" SET ABORT=1 DO OUTP^TMGQIO(SILNTOUT,"SKIPPING...") QUIT "RTN","TMGMGRST",650,0) . . IF X'?1"/".E SET RETRY=1 QUIT "RTN","TMGMGRST",651,0) . S ^%ZOSF("TMP")=X "RTN","TMGMGRST",652,0) . DO OUTP^TMGQIO(SILNTOUT,"!","^%ZOSF setup") "RTN","TMGMGRST",653,0) "RTN","TMGMGRST",654,0) DO OUTP^TMGQIO(SILNTOUT,"!") "RTN","TMGMGRST",655,0) SET RESULT=0 "RTN","TMGMGRST",656,0) "RTN","TMGMGRST",657,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBIndent,"M5") "RTN","TMGMGRST",658,0) "RTN","TMGMGRST",659,0) NMQ "RTN","TMGMGRST",660,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"NAME^TMGMGRST") "RTN","TMGMGRST",661,0) QUIT RESULT "RTN","TMGMGRST",662,0) ; "RTN","TMGMGRST",663,0) ; "RTN","TMGMGRST",664,0) ;"===================================================================================== "RTN","TMGMGRST",665,0) ;"===================================================================================== "RTN","TMGMGRST",666,0) ;"===================================================================================== "RTN","TMGMGRST",667,0) ;"Note: ZOSFGUX used to be a separate file. I included it here for modification. "RTN","TMGMGRST",668,0) "RTN","TMGMGRST",669,0) ZOSFGUX ;SFISC/MVB,PUG/TOAD - ZOSF Table for GT.M for Unix ;10 Feb 2003 6:37 pm "RTN","TMGMGRST",670,0) ;;8.0;KERNEL;**275**;Jul 10, 1995 "RTN","TMGMGRST",671,0) ;; for GT.M for Unix, version 4.3 "RTN","TMGMGRST",672,0) ; "RTN","TMGMGRST",673,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBIndent,"ZOSFGUX^TMGMGRST") "RTN","TMGMGRST",674,0) S %Y=1 "RTN","TMGMGRST",675,0) S DTIME=$G(DTIME,600) "RTN","TMGMGRST",676,0) K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF") "RTN","TMGMGRST",677,0) I $get(^%ZOSF("VOL"))="" S ^%ZOSF("VOL")="ROU" "RTN","TMGMGRST",678,0) ;"I '$D(^%ZOSF("VOL")) S ^%ZOSF("VOL")="ROU" "RTN","TMGMGRST",679,0) K ZO "RTN","TMGMGRST",680,0) F I="MGR","PROD","VOL","TMP" DO "RTN","TMGMGRST",681,0) . IF $D(^%ZOSF(I)) SET ZO(I)=^%ZOSF(I) "RTN","TMGMGRST",682,0) F I=1:2 DO QUIT:Z="" "RTN","TMGMGRST",683,0) . S Z=$P($TEXT(Z+I),";;",2) "RTN","TMGMGRST",684,0) . Q:Z="" "RTN","TMGMGRST",685,0) . S X=$P($TEXT(Z+1+I),";;",2,99) "RTN","TMGMGRST",686,0) . IF Z="OS" S $P(^%ZOSF(Z),"^")=X "RTN","TMGMGRST",687,0) . IF Z'="OS" S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X) "RTN","TMGMGRST",688,0) ; "RTN","TMGMGRST",689,0) OS2 ;"was OS when this was a separate file. "RTN","TMGMGRST",690,0) S ^%ZOSF("OS")="GT.M (Unix)^19" "RTN","TMGMGRST",691,0) ; "RTN","TMGMGRST",692,0) ; "RTN","TMGMGRST",693,0) ;"I (KT) found the original code for Prod,Vol etc to be same as the NAME function in ZTMGRSET, so "RTN","TMGMGRST",694,0) ;" I'll just use the modifications already made there. I will add the TMP part to NAME() "RTN","TMGMGRST",695,0) IF $$NAME()=1 GOTO ZXQUIT ;"Note, I'm not here making note error returned (doesn't do anything) "RTN","TMGMGRST",696,0) "RTN","TMGMGRST",697,0) ZXQUIT "RTN","TMGMGRST",698,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBIndent,"ZOSFGUX^TMGMGRST") "RTN","TMGMGRST",699,0) ;"write "LEAVING CUSTOM ZOSF",! "RTN","TMGMGRST",700,0) Q "RTN","TMGMGRST",701,0) ; "RTN","TMGMGRST",702,0) ; "RTN","TMGMGRST",703,0) Z ; "RTN","TMGMGRST",704,0) ;;ACTJ "RTN","TMGMGRST",705,0) ;;S Y=$$ACTJ^%ZOSV() "RTN","TMGMGRST",706,0) ;;AVJ "RTN","TMGMGRST",707,0) ;;S Y=$$AVJ^%ZOSV() "RTN","TMGMGRST",708,0) ;;BRK "RTN","TMGMGRST",709,0) ;;U $I:(CENABLE) "RTN","TMGMGRST",710,0) ;;DEL "RTN","TMGMGRST",711,0) ;;N %RD,%OD S %RD=$P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/",%OD=$S($ZRO["(":$P($ZRO,"(",1)_"/",1:%RD) ZSYSTEM "rm -f "_%RD_X_".m" ZSYSTEM "rm -f "_%OD_X_".o" "RTN","TMGMGRST",712,0) ;;EOFF "RTN","TMGMGRST",713,0) ;;U $I:(NOECHO) "RTN","TMGMGRST",714,0) ;;EON "RTN","TMGMGRST",715,0) ;;U $I:(ECHO) "RTN","TMGMGRST",716,0) ;;EOT "RTN","TMGMGRST",717,0) ;;S Y=$ZA\1024#2 ; <===== "RTN","TMGMGRST",718,0) ;;ERRTN "RTN","TMGMGRST",719,0) ;;^%ZTER "RTN","TMGMGRST",720,0) ;;ETRP "RTN","TMGMGRST",721,0) ;;Q "RTN","TMGMGRST",722,0) ;;GD "RTN","TMGMGRST",723,0) ;;G ^%GD "RTN","TMGMGRST",724,0) ;;$INC "RTN","TMGMGRST",725,0) ;;0 "RTN","TMGMGRST",726,0) ;;JOBPARAM "RTN","TMGMGRST",727,0) ;;G JOBPAR^%ZOSV "RTN","TMGMGRST",728,0) ;;LABOFF "RTN","TMGMGRST",729,0) ;;U IO:(NOECHO) ; <===== "RTN","TMGMGRST",730,0) ;;LOAD "RTN","TMGMGRST",731,0) ;;D LOAD^%ZOSV2(X) ;S %N=0 F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N^@X) Q:$L(%)=0 S @(DIF_XCNP_",0)")=% "RTN","TMGMGRST",732,0) ;;LPC "RTN","TMGMGRST",733,0) ;;S Y="" ; <===== "RTN","TMGMGRST",734,0) ;;MAGTAPE "RTN","TMGMGRST",735,0) ;;S %MT("BS")="*1",%MT("FS")="*2",%MT("WTM")="*3",%MT("WB")="*4",%MT("REW")="*5",%MT("RB")="*6",%MT("REL")="*7",%MT("WHL")="*8",%MT("WEL")="*9" ; <===== "RTN","TMGMGRST",736,0) ;;MAXSIZ "RTN","TMGMGRST",737,0) ;;Q "RTN","TMGMGRST",738,0) ;;MGR "RTN","TMGMGRST",739,0) ;;VAH,ROU "RTN","TMGMGRST",740,0) ;;MTBOT "RTN","TMGMGRST",741,0) ;;S Y=$ZA\32#2 ; <===== "RTN","TMGMGRST",742,0) ;;MTERR "RTN","TMGMGRST",743,0) ;;S Y=$ZA\32768#2 ; <===== "RTN","TMGMGRST",744,0) ;;MTONLINE "RTN","TMGMGRST",745,0) ;;S Y=$ZA\64#2 ; <===== "RTN","TMGMGRST",746,0) ;;MTWPROT "RTN","TMGMGRST",747,0) ;;S Y=$ZA\4#2 ; <===== "RTN","TMGMGRST",748,0) ;;NBRK "RTN","TMGMGRST",749,0) ;;U $I:(NOCENABLE) "RTN","TMGMGRST",750,0) ;;NO-PASSALL "RTN","TMGMGRST",751,0) ;;U $I:(NOPASSTHRU) "RTN","TMGMGRST",752,0) ;;NO-TYPE-AHEAD "RTN","TMGMGRST",753,0) ;;U $I:(NOTYPEAHEAD) "RTN","TMGMGRST",754,0) ;;PASSALL "RTN","TMGMGRST",755,0) ;;U $I:(PASSTHRU) "RTN","TMGMGRST",756,0) ;;PRIINQ "RTN","TMGMGRST",757,0) ;;S Y=$$PRIINQ^%ZOSV() "RTN","TMGMGRST",758,0) ;;PRIORITY "RTN","TMGMGRST",759,0) ;;QUIT ;G PRIORITY^%ZOSV "RTN","TMGMGRST",760,0) ;;PROD "RTN","TMGMGRST",761,0) ;;VAH,ROU "RTN","TMGMGRST",762,0) ;;PROGMODE "RTN","TMGMGRST",763,0) ;;S Y=$$PROGMODE^%ZOSV() "RTN","TMGMGRST",764,0) ;;RD "RTN","TMGMGRST",765,0) ;;G ^%RD "RTN","TMGMGRST",766,0) ;;RESJOB "RTN","TMGMGRST",767,0) ;;Q:'$D(DUZ) Q:'$D(^XUSEC("XUMGR",+DUZ)) N XQZ S XQZ="^FORCEX[MGR]" D DO^%XUCI ; <===== "RTN","TMGMGRST",768,0) ;;RM "RTN","TMGMGRST",769,0) ;;U $I:WIDTH=$S(X<256:X,1:0) "RTN","TMGMGRST",770,0) ;;RSEL "RTN","TMGMGRST",771,0) ;;K ^UTILITY($J) D ^%RSEL S X="" X "F S X=$O(%ZR(X)) Q:X="""" S ^UTILITY($J,X)=""""" K %ZR "RTN","TMGMGRST",772,0) ;;RSUM "RTN","TMGMGRST",773,0) ;;S Y=0 F %=1,3:1 S %1=$T(+%^@X),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y "RTN","TMGMGRST",774,0) ;;SS "RTN","TMGMGRST",775,0) ;;D ^ZSY "RTN","TMGMGRST",776,0) ;;SAVE "RTN","TMGMGRST",777,0) ;;D SAVE^%ZOSV2(X) ;N %I,%F S %I=$I,%F=$P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/"_X_".m" O %F:(NEWVERSION) U %F X "F S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=@(DIE_XCN_"",0)"") Q:$E(%,1)=""$"" I $E(%)'="";"" W %,!" C %F U %I "RTN","TMGMGRST",778,0) ;;SIZE "RTN","TMGMGRST",779,0) ;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 ; <===== "RTN","TMGMGRST",780,0) ;;TEST "RTN","TMGMGRST",781,0) ;;I X]"",$T(^@X)]"" "RTN","TMGMGRST",782,0) ;;TMK "RTN","TMGMGRST",783,0) ;;S Y=$ZA\16384#2 "RTN","TMGMGRST",784,0) ;;TMP "RTN","TMGMGRST",785,0) ;;/tmp/ "RTN","TMGMGRST",786,0) ;;TRAP "RTN","TMGMGRST",787,0) ;;$ZT="G "_X "RTN","TMGMGRST",788,0) ;;TRMOFF "RTN","TMGMGRST",789,0) ;;U $I:(TERMINATOR="") "RTN","TMGMGRST",790,0) ;;TRMON "RTN","TMGMGRST",791,0) ;;U $I:(TERMINATOR=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127)) "RTN","TMGMGRST",792,0) ;;TRMRD "RTN","TMGMGRST",793,0) ;;S Y=$A($ZB) "RTN","TMGMGRST",794,0) ;;TYPE-AHEAD "RTN","TMGMGRST",795,0) ;;U $I:(TYPEAHEAD) "RTN","TMGMGRST",796,0) ;;UCI "RTN","TMGMGRST",797,0) ;;S Y=^%ZOSF("PROD") "RTN","TMGMGRST",798,0) ;;UCICHECK "RTN","TMGMGRST",799,0) ;;S Y=1 "RTN","TMGMGRST",800,0) ;;UPPERCASE "RTN","TMGMGRST",801,0) ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","TMGMGRST",802,0) ;;XY "RTN","TMGMGRST",803,0) ;;S $X=DX,$Y=DY ; <===== "RTN","TMGMGRST",804,0) ;;VOL "RTN","TMGMGRST",805,0) ;;ROU "RTN","TMGMGRST",806,0) ;;ZD "RTN","TMGMGRST",807,0) ;;S Y=$$HTE^XLFDT(X,2) I $L($P(Y,"/"))=1 S Y=0_Y "RTN","TMGMISC") 0^33^B9343 "RTN","TMGMISC",1,0) TMGMISC ;TMG/kst/Misc utility library ;03/25/06 "RTN","TMGMISC",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGMISC",3,0) "RTN","TMGMISC",4,0) ;"TMG MISCELLANEOUS FUNCTIONS "RTN","TMGMISC",5,0) ;"Kevin Toppenberg MD "RTN","TMGMISC",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGMISC",7,0) ;"7-12-2005 "RTN","TMGMISC",8,0) "RTN","TMGMISC",9,0) ;"======================================================================= "RTN","TMGMISC",10,0) ;" API -- Public Functions. "RTN","TMGMISC",11,0) ;"======================================================================= "RTN","TMGMISC",12,0) ;"EDITPT(AddOK) "RTN","TMGMISC",13,0) ;"GetPersonClass(PersonClass,ProviderType,Specialty) "RTN","TMGMISC",14,0) ;"$$DocLines(IEN,Chars) -- Count number of lines and chars in a 8925 WP field "RTN","TMGMISC",15,0) ;"$$WPChars(Ptr) "RTN","TMGMISC",16,0) ;"$$RoundUp(n) "RTN","TMGMISC",17,0) ;"$$RoundDn(n) "RTN","TMGMISC",18,0) ;"$$Round(n) "RTN","TMGMISC",19,0) ;"$$InList(Value,ArrayP) -- return if Value is in an array. "RTN","TMGMISC",20,0) ;"$$ListCt(pArray) "RTN","TMGMISC",21,0) ;"$$NodeCt(pArray) -- count all the nodes in an array "RTN","TMGMISC",22,0) ;"$$IndexOf(pArray,value) "RTN","TMGMISC",23,0) ;"ListPack(pArray,StartNum,IncValue) "RTN","TMGMISC",24,0) ;"ListAdd(pArray,index,value) "RTN","TMGMISC",25,0) ;"ListAnd(pArray1,pArray2,pResult) "RTN","TMGMISC",26,0) ;"ListNot(pArray1,pArray2,pResult) "RTN","TMGMISC",27,0) ;"$$DTFormat(FMDate,format) -- format fileman dates "RTN","TMGMISC",28,0) ;"$$CompDOB(DOB1,DOB2) -- compare two dates "RTN","TMGMISC",29,0) ;"BrowseBy(CompArray,ByTag) -- Allow a user to interact with dynamic text tree "RTN","TMGMISC",30,0) ;"$$CompName(Name1,Name2) -- compare two names "RTN","TMGMISC",31,0) ;"$$FormatName(Name) "RTN","TMGMISC",32,0) ;"$$HEXCHR(V) -- Take one BYTE and return HEX Values "RTN","TMGMISC",33,0) ;"$$HEXCHR2(n,digits) -- convert a number (of arbitrary length) to HEX digits "RTN","TMGMISC",34,0) ;"$$HEX2NUM(s) -- convert a string like this $10 to decimal number (e.g.) 16 "RTN","TMGMISC",35,0) ;"$$OR(a,b) ; perform a bitwise OR on operands a and b "RTN","TMGMISC",36,0) ;"ParsePos(pos,label,offset,routine,dmod) "RTN","TMGMISC",37,0) ;"ScanMod(Module,pArray) "RTN","TMGMISC",38,0) ;"ConvertPos(Pos,pArray) "RTN","TMGMISC",39,0) ;"CompArray(pArray1,pArray2) return if two arrays are identical "RTN","TMGMISC",40,0) ;"$$CompABArray(pArrayA,pArrayB,pOutArray) -- FULL compare of two arrays, return diffArray "RTN","TMGMISC",41,0) ;"$$IterTemplate(Template,Prior) "RTN","TMGMISC",42,0) ;"$$NumPieces(s,delim,maxPoss) -- return number of pieces in string "RTN","TMGMISC",43,0) ;"$$LastPiece(s,delim,maxPoss) -- return the last piece of a string "RTN","TMGMISC",44,0) ;"$$ParseLast(s,remainS,delim,maxPoss) -- return the last piece AND the first part of the string "RTN","TMGMISC",45,0) ;"$$Trim1Node(pRef) -- To shorten a reference by one node. "RTN","TMGMISC",46,0) ;"BROWSEASK -- ask user for the name of an array, then display nodes "RTN","TMGMISC",47,0) ;"BROWSENODES(current,Order,paginate,countNodes) -- display nodes of specified array "RTN","TMGMISC",48,0) ;"ShowNodes(pArray,order,paginate,countNodes) -- display all the nodes of the given array "RTN","TMGMISC",49,0) ;"$$IsNumeric(value) -- determine if value is pure numeric. "RTN","TMGMISC",50,0) ;"$$ClipDDigits(Num,digits) -- clip number to specified number of digits "RTN","TMGMISC",51,0) ;"LaunchScreenman(File,FormIEN,RecIEN,Page) -- launching point screenman form "RTN","TMGMISC",52,0) ;"$$NumSigChs --determine how many characters are signficant in a variable name "RTN","TMGMISC",53,0) ;"MkMultList(input,List) -- create a list of entries, given a string containing a list of entries. "RTN","TMGMISC",54,0) ;"MkRangeList(Num,EndNum,List) -- create a list of entries, given a starting and ending number "RTN","TMGMISC",55,0) "RTN","TMGMISC",56,0) ;"======================================================================= "RTN","TMGMISC",57,0) ;"PRIVATE API FUNCTIONS "RTN","TMGMISC",58,0) ;"======================================================================= "RTN","TMGMISC",59,0) ;"GetPersonClass(PersonClass,ProviderType,Specialty) "RTN","TMGMISC",60,0) ;"ProcessToken(Token,Output) "RTN","TMGMISC",61,0) ;"$$IsSuffix(s) "RTN","TMGMISC",62,0) ;"$$IsTitle(s) "RTN","TMGMISC",63,0) ;"ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) "RTN","TMGMISC",64,0) ;"CtTemplate(Template) -- return the Count of IEN's stored in a SORT TEMPLATE "RTN","TMGMISC",65,0) "RTN","TMGMISC",66,0) ;"======================================================================= "RTN","TMGMISC",67,0) ;"DEPENDENCIES "RTN","TMGMISC",68,0) ;" TMGDBAPI "RTN","TMGMISC",69,0) ;" TMGIOUTL "RTN","TMGMISC",70,0) ;" TMGDEBUG "RTN","TMGMISC",71,0) ;" TMGSTUTL "RTN","TMGMISC",72,0) ;"======================================================================= "RTN","TMGMISC",73,0) ;"======================================================================= "RTN","TMGMISC",74,0) "RTN","TMGMISC",75,0) EDITPT(TMGADDOK) "RTN","TMGMISC",76,0) ;"Purpose: To ask for a patient name, and then allow editing "RTN","TMGMISC",77,0) ;"Input: TMGADDOK: if 1, then adding new patients is allowed "RTN","TMGMISC",78,0) ;"Result: none "RTN","TMGMISC",79,0) ; "RTN","TMGMISC",80,0) DO LO^DGUTL "RTN","TMGMISC",81,0) SET DGCLPR="" "RTN","TMGMISC",82,0) NEW DGDIV SET DGDIV=$$PRIM^VASITE "RTN","TMGMISC",83,0) ; "RTN","TMGMISC",84,0) IF DGDIV>0 SET %ZIS("B")=$PIECE($get(^DG(40.8,+DGDIV,"DEV")),U,1) "RTN","TMGMISC",85,0) ; "RTN","TMGMISC",86,0) KILL %ZIS("B") "RTN","TMGMISC",87,0) IF '$data(DGIO),$PIECE(^DG(43,1,0),U,30) do "RTN","TMGMISC",88,0) . SET %ZIS="N",IOP="HOME" "RTN","TMGMISC",89,0) . DO ^%ZIS "RTN","TMGMISC",90,0) ; "RTN","TMGMISC",91,0) A DO ENDREG^DGREG($GET(DFN)) "RTN","TMGMISC",92,0) DO IF (Y<0) GOTO EDITDONE "RTN","TMGMISC",93,0) . WRITE !! "RTN","TMGMISC",94,0) . IF $GET(TMGADDOK)=1 DO "RTN","TMGMISC",95,0) . . SET DIC=2,DIC(0)="ALEQM" "RTN","TMGMISC",96,0) . . SET DLAYGO=2 "RTN","TMGMISC",97,0) . ELSE DO "RTN","TMGMISC",98,0) . . SET DIC=2,DIC(0)="AEQM" "RTN","TMGMISC",99,0) . . SET DLAYGO=0 "RTN","TMGMISC",100,0) . KILL DIC("S") "RTN","TMGMISC",101,0) . DO ^DIC "RTN","TMGMISC",102,0) . KILL DLAYGO "RTN","TMGMISC",103,0) . IF Y<0 QUIT "RTN","TMGMISC",104,0) . SET (DFN,DA)=+Y "RTN","TMGMISC",105,0) . SET DGNEW=$P(Y,"^",3) "RTN","TMGMISC",106,0) . NEW Y "RTN","TMGMISC",107,0) . DO PAUSE^DG10 "RTN","TMGMISC",108,0) . DO BEGINREG^DGREG(DFN) "RTN","TMGMISC",109,0) . IF DGNEW DO NEW^DGRP "RTN","TMGMISC",110,0) ; "RTN","TMGMISC",111,0) IF +$GET(DGNEW) DO "RTN","TMGMISC",112,0) . ;" query CMOR for Patient Record Flag Assignments if NEW patient and "RTN","TMGMISC",113,0) . ;" display results. "RTN","TMGMISC",114,0) . IF $$PRFQRY^DGPFAPI(DFN) DO DISPPRF^DGPFAPI(DFN) "RTN","TMGMISC",115,0) ; "RTN","TMGMISC",116,0) SET (DGFC,CURR)=0 "RTN","TMGMISC",117,0) SET DA=DFN "RTN","TMGMISC",118,0) SET DGFC="^1" "RTN","TMGMISC",119,0) SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0) "RTN","TMGMISC",120,0) ; "RTN","TMGMISC",121,0) SET %ZIS="N",IOP="HOME" "RTN","TMGMISC",122,0) DO ^%ZIS "RTN","TMGMISC",123,0) SET DGELVER=0 "RTN","TMGMISC",124,0) ;"DO EN^DGRPD "RTN","TMGMISC",125,0) ;"IF $data(DGRPOUT) DO GOTO A "RTN","TMGMISC",126,0) ;". DO ENDREG^DGREG($G(DFN)) "RTN","TMGMISC",127,0) ;". DO HL7A08^VAFCDD01 "RTN","TMGMISC",128,0) ;". KILL DFN,DGRPOUT "RTN","TMGMISC",129,0) ; "RTN","TMGMISC",130,0) ;"DO HINQ^DG10 "RTN","TMGMISC",131,0) IF $D(^DIC(195.4,1,"UP")) IF ^("UP") DO ADM^RTQ3 "RTN","TMGMISC",132,0) ; "RTN","TMGMISC",133,0) DO REG^IVMCQ($G(DFN)) ;" send financial query "RTN","TMGMISC",134,0) ; "RTN","TMGMISC",135,0) SET DGRPV=0 "RTN","TMGMISC",136,0) DO EN1^DGRP "RTN","TMGMISC",137,0) ; "RTN","TMGMISC",138,0) EDITDONE "RTN","TMGMISC",139,0) IF $PIECE($GET(^VA(200,DUZ,"TMG")),"^",1)="C" DO "RTN","TMGMISC",140,0) . WRITE @IOF,! ;"clear screen if settings call for this. "RTN","TMGMISC",141,0) ; "RTN","TMGMISC",142,0) QUIT "RTN","TMGMISC",143,0) "RTN","TMGMISC",144,0) "RTN","TMGMISC",145,0) GetPersonClass(PersonClass,ProviderType,Specialty) "RTN","TMGMISC",146,0) ;"Purpose: To look through the PERSON CLASS file and find matching record "RTN","TMGMISC",147,0) ;"Input -- PersonClass -- a value to match against the .01 field (PROVIDER TYPE) "RTN","TMGMISC",148,0) ;" Behavioral Health and Social Service "RTN","TMGMISC",149,0) ;" Chiropractors "RTN","TMGMISC",150,0) ;" Dental Service "RTN","TMGMISC",151,0) ;" Dietary and Nutritional Service "RTN","TMGMISC",152,0) ;" Emergency Medical Service "RTN","TMGMISC",153,0) ;" Eye and Vision Services "RTN","TMGMISC",154,0) ;" Nursing Service "RTN","TMGMISC",155,0) ;" Nursing Service Related "RTN","TMGMISC",156,0) ;" Physicians (M.D. and D.O.) "RTN","TMGMISC",157,0) ;" etc. "RTN","TMGMISC",158,0) ;" -- ProviderType -- a value to match against the 1 field (CLASSIFICATION) "RTN","TMGMISC",159,0) ;" Physician/Osteopath "RTN","TMGMISC",160,0) ;" Resident, Allopathic (includes Interns, Residents, Fellows) "RTN","TMGMISC",161,0) ;" Psychologist "RTN","TMGMISC",162,0) ;" Neuropsychologist "RTN","TMGMISC",163,0) ;" etc. "RTN","TMGMISC",164,0) ;" -- Specialty -- a value to match against the 2 field (AREA OF SPECIALIZATION) "RTN","TMGMISC",165,0) ;"Output -- (via results) "RTN","TMGMISC",166,0) ;"Result -- Returns record number in PERSON CLASS file, OR 0 if not found "RTN","TMGMISC",167,0) "RTN","TMGMISC",168,0) new RecNum,Params "RTN","TMGMISC",169,0) "RTN","TMGMISC",170,0) set Params(0,"FILE")="PERSON CLASS" "RTN","TMGMISC",171,0) set Params(".01")=$get(PersonClass) "RTN","TMGMISC",172,0) set Params("1")=$get(ProviderType) "RTN","TMGMISC",173,0) set Params("2")=$get(Specialty) "RTN","TMGMISC",174,0) "RTN","TMGMISC",175,0) set RecNum=$$RecFind^TMGDBAPI(.Params) "RTN","TMGMISC",176,0) "RTN","TMGMISC",177,0) GPCDone "RTN","TMGMISC",178,0) quit RecNum "RTN","TMGMISC",179,0) "RTN","TMGMISC",180,0) "RTN","TMGMISC",181,0) DocLines(IEN,Chars) "RTN","TMGMISC",182,0) ;"Purpose: To count the number of lines and characters in a WP field "RTN","TMGMISC",183,0) ;" Initially it is targeted at entries in TIU DOCUMENT file. "RTN","TMGMISC",184,0) ;"Input: IEN -- the record number in TIU DOCUMENT to count "RTN","TMGMISC",185,0) ;" Chars -- and OUT parameter. PASS BY REFERENCE "RTN","TMGMISC",186,0) ;"Results: Returns number of lines, (with 1 decimal value) "RTN","TMGMISC",187,0) ;" Also will return character count in Chars, if passed by reference "RTN","TMGMISC",188,0) ;"NOte: This uses the Characters per line parameter value stored in "RTN","TMGMISC",189,0) ;" field .03 of TIU PARAMETERS (in ^TIU(8925.99)) "RTN","TMGMISC",190,0) "RTN","TMGMISC",191,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") "RTN","TMGMISC",192,0) "RTN","TMGMISC",193,0) new CharsPerLine "RTN","TMGMISC",194,0) new LineCount set LineCount=0 "RTN","TMGMISC",195,0) set Chars=0 "RTN","TMGMISC",196,0) set CharsPerLine=+$piece($get(^TIU(8925.99,1,0)),"^",3) "RTN","TMGMISC",197,0) "RTN","TMGMISC",198,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"CharsPerLine=",CharsPerLine) "RTN","TMGMISC",199,0) "RTN","TMGMISC",200,0) set WPPtr=$name(^TIU(8925,IEN,"TEXT")) "RTN","TMGMISC",201,0) set Chars=$$WPChars(WPPtr) "RTN","TMGMISC",202,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Chars=",Chars) "RTN","TMGMISC",203,0) "RTN","TMGMISC",204,0) if CharsPerLine'=0 do "RTN","TMGMISC",205,0) . set LineCount=(((Chars/CharsPerLine)*10)\1)/10 "RTN","TMGMISC",206,0) . ;"new IntLC,LC,Delta "RTN","TMGMISC",207,0) . ;"set LC=Chars\CharsPerLine "RTN","TMGMISC",208,0) . ;"set IntLC=Chars\CharsPerLine ;" \ is integer divide "RTN","TMGMISC",209,0) . ;"set Delta=(LC-IntLC)*10 "RTN","TMGMISC",210,0) . i;"f Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value. "RTN","TMGMISC",211,0) . ;"set LineCount=IntLC "RTN","TMGMISC",212,0) "RTN","TMGMISC",213,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"LineCount=",LineCount) "RTN","TMGMISC",214,0) "RTN","TMGMISC",215,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") "RTN","TMGMISC",216,0) quit LineCount "RTN","TMGMISC",217,0) "RTN","TMGMISC",218,0) "RTN","TMGMISC",219,0) WPChars(Ptr) "RTN","TMGMISC",220,0) ;"Purpose: To count the number of characters in the WP field "RTN","TMGMISC",221,0) ;" pointed to by the name stored in Ptr "RTN","TMGMISC",222,0) ;"Results: Returns number of characters, including spaces "RTN","TMGMISC",223,0) "RTN","TMGMISC",224,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") "RTN","TMGMISC",225,0) "RTN","TMGMISC",226,0) new index "RTN","TMGMISC",227,0) new Chars set Chars=0 "RTN","TMGMISC",228,0) "RTN","TMGMISC",229,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ptr=",Ptr) "RTN","TMGMISC",230,0) set index=$order(@Ptr@(0)) "RTN","TMGMISC",231,0) for do quit:(index="") "RTN","TMGMISC",232,0) . if index="" quit "RTN","TMGMISC",233,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index='",index,"'") "RTN","TMGMISC",234,0) . ;"new s set s=$get(@Ptr@(index,0)) write "s=",s,! "RTN","TMGMISC",235,0) . set Chars=Chars+$length($get(@Ptr@(index,0))) "RTN","TMGMISC",236,0) . set index=$order(@Ptr@(index)) "RTN","TMGMISC",237,0) "RTN","TMGMISC",238,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") "RTN","TMGMISC",239,0) "RTN","TMGMISC",240,0) quit Chars "RTN","TMGMISC",241,0) "RTN","TMGMISC",242,0) "RTN","TMGMISC",243,0) "RTN","TMGMISC",244,0) RoundUp(n) "RTN","TMGMISC",245,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",246,0) ;"Purpose: find the next greatest integer after decimal value of n (round up) "RTN","TMGMISC",247,0) ;" 1.1 --> 2 "RTN","TMGMISC",248,0) ;" 1.0 --> 1 "RTN","TMGMISC",249,0) ;" -2.8 --> 2 "RTN","TMGMISC",250,0) ;"input: n -- decimal or integer value "RTN","TMGMISC",251,0) ;"output an integer, rounded up. "RTN","TMGMISC",252,0) "RTN","TMGMISC",253,0) new result "RTN","TMGMISC",254,0) set result=n\1 "RTN","TMGMISC",255,0) if result 1 "RTN","TMGMISC",262,0) ;" -2.2 --> -2 "RTN","TMGMISC",263,0) ;"input: n -- decimal or integer value "RTN","TMGMISC",264,0) ;"output an integer, rounded down. "RTN","TMGMISC",265,0) "RTN","TMGMISC",266,0) new result "RTN","TMGMISC",267,0) set result=n\1 "RTN","TMGMISC",268,0) quit result "RTN","TMGMISC",269,0) "RTN","TMGMISC",270,0) Round(n) "RTN","TMGMISC",271,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",272,0) ;"Purpose: find the nearest integer from decimal value of n "RTN","TMGMISC",273,0) ;" for values 0.0-0.49 --> 0 "RTN","TMGMISC",274,0) ;" for values 0.5-0.99 --> 1 "RTN","TMGMISC",275,0) ;"input: n -- decimal or integer value "RTN","TMGMISC",276,0) ;"output an integer, rounded to nearest integer "RTN","TMGMISC",277,0) "RTN","TMGMISC",278,0) new result set result=n "RTN","TMGMISC",279,0) new decimal "RTN","TMGMISC",280,0) "RTN","TMGMISC",281,0) set decimal=+(n-(n\1)) "RTN","TMGMISC",282,0) if decimal<0.5 do "RTN","TMGMISC",283,0) . set result=$$RoundDn(n) "RTN","TMGMISC",284,0) else do "RTN","TMGMISC",285,0) . set result=$$RoundUp(n) "RTN","TMGMISC",286,0) "RTN","TMGMISC",287,0) quit result "RTN","TMGMISC",288,0) "RTN","TMGMISC",289,0) "RTN","TMGMISC",290,0) InList(Value,ArrayP) "RTN","TMGMISC",291,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",292,0) ;"Purpose: To return if Value is in an array. Match must be exact (i.e. '=') "RTN","TMGMISC",293,0) ;"Input: Value -- the value to test for. Should not be an array "RTN","TMGMISC",294,0) ;" ArrayP -- the name of the array. e.g. ArrayP="MyArray(""Title"")" "RTN","TMGMISC",295,0) ;"Format of Array: It may be in one of two possible formats: "RTN","TMGMISC",296,0) ;" 1. MyArray("Title")=Value, or "RTN","TMGMISC",297,0) ;" 2. MyArray("Title")="*" <-- a signal that multiple values are given "RTN","TMGMISC",298,0) ;" MyArray("Title",1)=Value1 "RTN","TMGMISC",299,0) ;" MyArray("Title",2)=Value2 "RTN","TMGMISC",300,0) ;" The '1','2', etc may anything "RTN","TMGMISC",301,0) ;"Results: 1 if Value is in list, 0 if not "RTN","TMGMISC",302,0) "RTN","TMGMISC",303,0) new result set result=0 "RTN","TMGMISC",304,0) new index "RTN","TMGMISC",305,0) if ($get(ArrayP)'="")&($data(Value)=1) do "RTN","TMGMISC",306,0) . if @ArrayP'="*" set result=(@ArrayP=$get(Value)) quit "RTN","TMGMISC",307,0) . set index=$order(@ArrayP@("")) quit:(index="") "RTN","TMGMISC",308,0) . for do quit:(index="")!(result=1) "RTN","TMGMISC",309,0) . . if @ArrayP@(index)=Value set result=1 quit "RTN","TMGMISC",310,0) . . set index=$order(@ArrayP@(index)) "RTN","TMGMISC",311,0) "RTN","TMGMISC",312,0) ILDone "RTN","TMGMISC",313,0) quit result "RTN","TMGMISC",314,0) "RTN","TMGMISC",315,0) "RTN","TMGMISC",316,0) ;"IndexOf(pArray,value) "RTN","TMGMISC",317,0) ;" ;"SCOPE: PUBLIC "RTN","TMGMISC",318,0) ;" ;"Purpose: To scan array and return first index holding value "RTN","TMGMISC",319,0) ;" ;"Input: pArray -- PASS BY NAME. Array to scan, in format like this: "RTN","TMGMISC",320,0) ;" ;" @pArray@(1)=value1 "RTN","TMGMISC",321,0) ;" ;" @pArray@(2)=value2 "RTN","TMGMISC",322,0) ;" ;" @pArray@(3)=value3 "RTN","TMGMISC",323,0) ;" ;" @pArray@("some name index 1")=value4 "RTN","TMGMISC",324,0) ;" ;" @pArray@("some name index 2")=value5 "RTN","TMGMISC",325,0) ;" ;" value -- the value to search for "RTN","TMGMISC",326,0) ;" ;"results: returns the index holding the value "RTN","TMGMISC",327,0) ;" "RTN","TMGMISC",328,0) ;" new result set result="" "RTN","TMGMISC",329,0) ;" new done set done=0 "RTN","TMGMISC",330,0) ;" new index set index="" "RTN","TMGMISC",331,0) ;" for set index=$order(@pArray@(index)) quit:(index="")!(done=1) do "RTN","TMGMISC",332,0) ;" . set done=($get(@pArray@(index))=value) "RTN","TMGMISC",333,0) ;" . if done set result=index "RTN","TMGMISC",334,0) ;" "RTN","TMGMISC",335,0) ;"IODone quit result "RTN","TMGMISC",336,0) "RTN","TMGMISC",337,0) "RTN","TMGMISC",338,0) ListCt(pArray) "RTN","TMGMISC",339,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",340,0) ;"Purpose: to count the number of entries in an array "RTN","TMGMISC",341,0) ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. "RTN","TMGMISC",342,0) ;"Output: the number of entries at highest level "RTN","TMGMISC",343,0) ;" e.g. Array("TELEPHONE")=1234 "RTN","TMGMISC",344,0) ;" Array("CAR")=4764 "RTN","TMGMISC",345,0) ;" Array("DOG")=5213 "RTN","TMGMISC",346,0) ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted. "RTN","TMGMISC",347,0) ;" The above array would have a count of 3 "RTN","TMGMISC",348,0) ;"Results: returns count, or count up to point of any error "RTN","TMGMISC",349,0) new i,result set result=0 "RTN","TMGMISC",350,0) "RTN","TMGMISC",351,0) do "RTN","TMGMISC",352,0) . new $etrap "RTN","TMGMISC",353,0) . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit" "RTN","TMGMISC",354,0) . set i=$order(@pArray@("")) "RTN","TMGMISC",355,0) . if i="" quit "RTN","TMGMISC",356,0) . for set result=result+1 set i=$order(@pArray@(i)) quit:i="" "RTN","TMGMISC",357,0) "RTN","TMGMISC",358,0) quit result "RTN","TMGMISC",359,0) "RTN","TMGMISC",360,0) NodeCt(pArray) "RTN","TMGMISC",361,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",362,0) ;"Purpose: to count all the nodes in an array "RTN","TMGMISC",363,0) ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. "RTN","TMGMISC",364,0) ;"Output: the number of entries at highest level "RTN","TMGMISC",365,0) ;" e.g. Array("TELEPHONE")=1234 "RTN","TMGMISC",366,0) ;" Array("CAR")=4764 "RTN","TMGMISC",367,0) ;" Array("DOG")=5213 "RTN","TMGMISC",368,0) ;" Array("DOG","COLLAR")=5213 <-- IS counted "RTN","TMGMISC",369,0) ;" The above array would have a count of 4 "RTN","TMGMISC",370,0) ;"Results: returns count, or count up to point of any error "RTN","TMGMISC",371,0) new result set result=0 "RTN","TMGMISC",372,0) for set pArray=$query(@pArray),result=result+1 quit:(pArray="") "RTN","TMGMISC",373,0) quit result "RTN","TMGMISC",374,0) "RTN","TMGMISC",375,0) IndexOf(pArray,value) "RTN","TMGMISC",376,0) ;"SCOPE: PUBLIC: "RTN","TMGMISC",377,0) ;"Purpose: To search through an array of keys and values, and return 1st index (i.e. key) of value "RTN","TMGMISC",378,0) ;"Input: pArray -- NAME OF array to search, format: "RTN","TMGMISC",379,0) ;" @pArray@(key1)=value1 "RTN","TMGMISC",380,0) ;" @pArray@(key2)=value2 "RTN","TMGMISC",381,0) ;" @pArray@(key3)=value3 "RTN","TMGMISC",382,0) ;" value -- the value to search for "RTN","TMGMISC",383,0) ;"Results: will return key for first found (based on $order sequence),or "" if not found "RTN","TMGMISC",384,0) "RTN","TMGMISC",385,0) new result set result="" "RTN","TMGMISC",386,0) new i set i="" "RTN","TMGMISC",387,0) new done set done=0 "RTN","TMGMISC",388,0) for set i=$order(@pArray@(i)) quit:(i="")!(done=1) do "RTN","TMGMISC",389,0) . if $get(@pArray@(i))=value set result=i,done=1 "RTN","TMGMISC",390,0) "RTN","TMGMISC",391,0) quit result "RTN","TMGMISC",392,0) "RTN","TMGMISC",393,0) ListPack(pArray,StartNum,IncValue) "RTN","TMGMISC",394,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",395,0) ;"Purpose: to take an array with numeric ordering and pack values. "RTN","TMGMISC",396,0) ;" e.g. Array(3)="dog" "RTN","TMGMISC",397,0) ;" Array(5)="cat" "RTN","TMGMISC",398,0) ;" Array(75)="goat" "RTN","TMGMISC",399,0) ;" Will be pack as follows: "RTN","TMGMISC",400,0) ;" Array(1)="dog" "RTN","TMGMISC",401,0) ;" Array(2)="cat" "RTN","TMGMISC",402,0) ;" Array(3)="goat" "RTN","TMGMISC",403,0) ;"Input: pArray -- pointer to (NAME OF) array to pack. "RTN","TMGMISC",404,0) ;" StartNum -- OPTIONAL, default=1. Value to start numbering at "RTN","TMGMISC",405,0) ;" IncValue -- OPTIONAL, default=1. Amount to add to index value each time "RTN","TMGMISC",406,0) ;"Output: array will be altered "RTN","TMGMISC",407,0) ;"Results: none. "RTN","TMGMISC",408,0) ;"Notes: It is assumed that all of the indices are numeric "RTN","TMGMISC",409,0) ;" Nodes that are ALPHA (non-numeric) will be KILLED!! "RTN","TMGMISC",410,0) ;" If nodes have subnodes, they will be preserved. "RTN","TMGMISC",411,0) "RTN","TMGMISC",412,0) new TMGlpArray "RTN","TMGMISC",413,0) new i "RTN","TMGMISC",414,0) new count set count=$get(StartNum,1) "RTN","TMGMISC",415,0) set i=$order(@pArray@("")) "RTN","TMGMISC",416,0) if +i=i for do quit:(+i'=i) "RTN","TMGMISC",417,0) . merge TMGlpArray(count)=@pArray@(i) "RTN","TMGMISC",418,0) . set count=count+$get(IncValue,1) "RTN","TMGMISC",419,0) . set i=$order(@pArray@(i)) "RTN","TMGMISC",420,0) kill @pArray "RTN","TMGMISC",421,0) merge @pArray=TMGlpArray "RTN","TMGMISC",422,0) quit "RTN","TMGMISC",423,0) "RTN","TMGMISC",424,0) "RTN","TMGMISC",425,0) ListTrim(pArray,startIndex,endIndex,CountName) "RTN","TMGMISC",426,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",427,0) ;"Purpose: Take a list with numeric (integer) ordering, and trim (kill) entry "RTN","TMGMISC",428,0) ;" items startIndex...endIndex "RTN","TMGMISC",429,0) ;"Input: pArray -- PASS BY NAME. The array to trim "RTN","TMGMISC",430,0) ;" startIndex -- the first index item to kill. Default=1 "RTN","TMGMISC",431,0) ;" endIndex -- the last index item to kill. Default=1 "RTN","TMGMISC",432,0) ;" CountName -- OPTIONAL. The name of a node that includes the "RTN","TMGMISC",433,0) ;" final count of remaining nodes. Default is "COUNT" "RTN","TMGMISC",434,0) ;"Output: Array items will be killed. Also, a node with the resulting count "RTN","TMGMISC",435,0) ;" of remaining items will be created, with name of CountName. e.g. "RTN","TMGMISC",436,0) ;" INPUT: startIndex=1, endIndex=4 "RTN","TMGMISC",437,0) ;" @pArray@(2)="grape" "RTN","TMGMISC",438,0) ;" @pArray@(3)="orange" "RTN","TMGMISC",439,0) ;" @pArray@(5)="apple" "RTN","TMGMISC",440,0) ;" @pArray@(7)="pear" "RTN","TMGMISC",441,0) ;" @pArray@(9)="peach" "RTN","TMGMISC",442,0) ;" "RTN","TMGMISC",443,0) ;" OUTPUT: "RTN","TMGMISC",444,0) ;" @pArray@(5)="apple" "RTN","TMGMISC",445,0) ;" @pArray@(7)="pear" "RTN","TMGMISC",446,0) ;" @pArray@(9)="peach" "RTN","TMGMISC",447,0) ;" @pArray@("COUNT")=3 "RTN","TMGMISC",448,0) "RTN","TMGMISC",449,0) set startIndex=$get(startIndex,1) "RTN","TMGMISC",450,0) set endIndex=$get(endIndex,1) "RTN","TMGMISC",451,0) set CountName=$get(CountName,"COUNT") "RTN","TMGMISC",452,0) kill @pArray@(CountName) "RTN","TMGMISC",453,0) new i for i=startIndex:1:endIndex kill @pArray@(i) "RTN","TMGMISC",454,0) do ListPack(pArray) "RTN","TMGMISC",455,0) set @pArray@(CountName)=$$ListCt(pArray) "RTN","TMGMISC",456,0) quit "RTN","TMGMISC",457,0) "RTN","TMGMISC",458,0) "RTN","TMGMISC",459,0) ListAdd(pArray,index,value) "RTN","TMGMISC",460,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",461,0) ;"Purpose: To take a simple list and add to end of ist "RTN","TMGMISC",462,0) ;" e.g. Array("Apple")=75 "RTN","TMGMISC",463,0) ;" Array("Pear")=19 "RTN","TMGMISC",464,0) ;" "RTN","TMGMISC",465,0) ;" do ListAdd("Array","Grape",12) --> "RTN","TMGMISC",466,0) ;" "RTN","TMGMISC",467,0) ;" e.g. Array("Apple")=75 "RTN","TMGMISC",468,0) ;" Array("Pear")=19 "RTN","TMGMISC",469,0) ;" Array("Grape")=12 "RTN","TMGMISC",470,0) "RTN","TMGMISC",471,0) ;"Note: function creation aborted, because there is no intrinsic ordering in arrays. I.e. the above would actually "RTN","TMGMISC",472,0) ;" be in this order, as returned by $order(): "RTN","TMGMISC",473,0) ;" e.g. Array("Apple")=75 "RTN","TMGMISC",474,0) ;" Array("Grape")=12 <-- "G" comes before "P" alphabetically "RTN","TMGMISC",475,0) ;" Array("Pear")=19 "RTN","TMGMISC",476,0) "RTN","TMGMISC",477,0) ;"I'll leave this here as a reminder to myself next time. "RTN","TMGMISC",478,0) "RTN","TMGMISC",479,0) quit "RTN","TMGMISC",480,0) "RTN","TMGMISC",481,0) "RTN","TMGMISC",482,0) ListAnd(pArray1,pArray2,pResult) "RTN","TMGMISC",483,0) ;"Purpose: To take two lists, and create a third list that has only those entries that "RTN","TMGMISC",484,0) ;" exist in Array1 AND Array2 "RTN","TMGMISC",485,0) ;"Input: pArray1 : NAME OF array for list 1 "RTN","TMGMISC",486,0) ;" pArray2 : NAME OF array for list 2 "RTN","TMGMISC",487,0) ;" pResult : NAME OF array to results -- any preexisting entries will be killed "RTN","TMGMISC",488,0) ;"Note: only TOP LEVEL nodes are considered, and *value* for pArray1 use for combined value "RTN","TMGMISC",489,0) ;"E.g. of Use "RTN","TMGMISC",490,0) ;" @pArray1@("cat")="feline" "RTN","TMGMISC",491,0) ;" @pArray1@("dog")="canine" "RTN","TMGMISC",492,0) ;" @pArray1@("horse")="equinine" "RTN","TMGMISC",493,0) ;" @pArray1@("bird")="avian" "RTN","TMGMISC",494,0) ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node "RTN","TMGMISC",495,0) ;" "RTN","TMGMISC",496,0) ;" @pArray2@("hog")="porcine" "RTN","TMGMISC",497,0) ;" @pArray2@("horse")="equinine" "RTN","TMGMISC",498,0) ;" @pArray2@("cow")="bovine" "RTN","TMGMISC",499,0) ;" @pArray2@("bird")="flier" <----- note different value for key="bird" "RTN","TMGMISC",500,0) ;" "RTN","TMGMISC",501,0) ;" resulting list: "RTN","TMGMISC",502,0) ;" @pResult@("horse")="equinine" "RTN","TMGMISC",503,0) ;" @pResult@("bird")="avian" <-- note value from pArray1 used. "RTN","TMGMISC",504,0) "RTN","TMGMISC",505,0) new Result "RTN","TMGMISC",506,0) "RTN","TMGMISC",507,0) new i set i=$order(@pArray1@("")) "RTN","TMGMISC",508,0) if i'="" for do quit:(i="") "RTN","TMGMISC",509,0) . if $data(@pArray2@(i))#10 do "RTN","TMGMISC",510,0) . . set Result(i)=$get(@pArray1@(i)) "RTN","TMGMISC",511,0) . set i=$order(@pArray1@(i)) "RTN","TMGMISC",512,0) "RTN","TMGMISC",513,0) kill @pResult "RTN","TMGMISC",514,0) merge @pResult=Result "RTN","TMGMISC",515,0) "RTN","TMGMISC",516,0) quit "RTN","TMGMISC",517,0) "RTN","TMGMISC",518,0) "RTN","TMGMISC",519,0) ListNot(pArray1,pArray2,Verbose) "RTN","TMGMISC",520,0) ;"Purpose: To take two lists, and remove all entries from list 2 from list 1 "RTN","TMGMISC",521,0) ;" exist in Array1 NOT Array2 "RTN","TMGMISC",522,0) ;"Input: pArray1 : NAME OF array for list 1 "RTN","TMGMISC",523,0) ;" pArray2 : NAME OF array for list 2 "RTN","TMGMISC",524,0) ;" Verbose: OPTIONAL. if 1 then verbose output, progress bar etc. "RTN","TMGMISC",525,0) "RTN","TMGMISC",526,0) ;"Note: only TOP LEVEL nodes are considered, and "RTN","TMGMISC",527,0) ;" *value* for pArray1 use for combined value "RTN","TMGMISC",528,0) "RTN","TMGMISC",529,0) ;"E.g. of Use "RTN","TMGMISC",530,0) ;" list 1: "RTN","TMGMISC",531,0) ;" @pArray1@("cat")="feline" "RTN","TMGMISC",532,0) ;" @pArray1@("dog")="canine" "RTN","TMGMISC",533,0) ;" @pArray1@("horse")="equinine" "RTN","TMGMISC",534,0) ;" @pArray1@("bird")="avian" "RTN","TMGMISC",535,0) ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node "RTN","TMGMISC",536,0) ;" "RTN","TMGMISC",537,0) ;" list 2: "RTN","TMGMISC",538,0) ;" @pArray1@("cat")="feline" "RTN","TMGMISC",539,0) ;" @pArray1@("horse")="equinine" "RTN","TMGMISC",540,0) ;" "RTN","TMGMISC",541,0) ;" resulting list: "RTN","TMGMISC",542,0) ;" @pArray1@("dog")="canine" "RTN","TMGMISC",543,0) ;" @pArray1@("bird")="avian" "RTN","TMGMISC",544,0) ;" @pArray1@("bird","weight")=12 "RTN","TMGMISC",545,0) ;" "RTN","TMGMISC",546,0) "RTN","TMGMISC",547,0) new Itr,index "RTN","TMGMISC",548,0) set index=$$ItrAInit^TMGITR(pArray2,.Itr) "RTN","TMGMISC",549,0) if Verbose=1 do PrepProgress^TMGITR(.Itr,20,1,"index") "RTN","TMGMISC",550,0) if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="") "RTN","TMGMISC",551,0) . kill @pArray1@(i) "RTN","TMGMISC",552,0) "RTN","TMGMISC",553,0) quit "RTN","TMGMISC",554,0) "RTN","TMGMISC",555,0) "RTN","TMGMISC",556,0) ;"Note: Sometime, compare this function to $$DATE^TIULS ... I didn't know about this function before! "RTN","TMGMISC",557,0) DTFormat(FMDate,format,Array) "RTN","TMGMISC",558,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",559,0) ;"Purpose: to allow custom formating of fileman dates in to text equivalents "RTN","TMGMISC",560,0) ;"Input: FMDate -- this is the date to work on, in Fileman Format "RTN","TMGMISC",561,0) ;" format -- a formating string with codes as follows. "RTN","TMGMISC",562,0) ;" yy -- 2 digit year "RTN","TMGMISC",563,0) ;" yyyy -- 4 digit year "RTN","TMGMISC",564,0) ;" m - month number without a leading 0. "RTN","TMGMISC",565,0) ;" mm -- 2 digit month number (01-12) "RTN","TMGMISC",566,0) ;" mmm - abreviated months (Jan,Feb,Mar etc.) "RTN","TMGMISC",567,0) ;" mmmm -- full names of months (January,February,March etc) "RTN","TMGMISC",568,0) ;" d -- the number of the day of the month (1-31) without a leading 0 "RTN","TMGMISC",569,0) ;" dd -- 2 digit number of the day of the month "RTN","TMGMISC",570,0) ;" w -- the numeric day of the week (1-7) "RTN","TMGMISC",571,0) ;" ww -- abreviated day of week (Mon,Tue,Wed) "RTN","TMGMISC",572,0) ;" www -- day of week (Monday,Tuesday,Wednesday) "RTN","TMGMISC",573,0) ;" h -- the number of the hour without a leading 0 (1-23) 24-hr clock mode "RTN","TMGMISC",574,0) ;" hh -- 2 digit number of the hour. 24-hr clock mode "RTN","TMGMISC",575,0) ;" H -- the number of the hour without a leading 0 (1-12) 12-hr clock mode "RTN","TMGMISC",576,0) ;" HH -- 2 digit number of the hour. 12-hr clock mode "RTN","TMGMISC",577,0) ;" # -- will display 'am' for hours 1-12 and 'pm' for hours 13-24 "RTN","TMGMISC",578,0) ;" M - the number of minutes with out a leading 0 "RTN","TMGMISC",579,0) ;" MM -- a 2 digit display of minutes "RTN","TMGMISC",580,0) ;" s - the number of seconds without a leading 0 "RTN","TMGMISC",581,0) ;" ss -- a 2 digit display of number of seconds. "RTN","TMGMISC",582,0) ;" allowed punctuation symbols-- ' ' : , / @ .;- (space, colon, comma, forward slash, at symbol,semicolon,period,hyphen) "RTN","TMGMISC",583,0) ;" 'text' is included as is, even if it is same as a formatting code "RTN","TMGMISC",584,0) ;" Other unexpected text will be ignored "RTN","TMGMISC",585,0) ;" "RTN","TMGMISC",586,0) ;" If a date value of 0 is found for a code, that code is ignored (except for min/sec) "RTN","TMGMISC",587,0) ;" "RTN","TMGMISC",588,0) ;" Examples: with FMDate=3050215.183000 (i.e. Feb 5, 2005 @ 18:30 0 sec) "RTN","TMGMISC",589,0) ;" "mmmm d,yyyy" --> "February 5,2005" "RTN","TMGMISC",590,0) ;" "mm d,yyyy" --> "Feb 5,2005" "RTN","TMGMISC",591,0) ;" "'Exactly' H:MM # 'on' mm/dd/yy" --> "Exactly 6:30 pm on 02/05/05" "RTN","TMGMISC",592,0) ;" "mm/dd/yyyy" --> "02/05/2005" "RTN","TMGMISC",593,0) ;" "RTN","TMGMISC",594,0) ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE "RTN","TMGMISC",595,0) ;" The array will be filled with data as follows: "RTN","TMGMISC",596,0) ;" Array(Token)=value for that token (ignores codes such as '/',':' ect) "RTN","TMGMISC",597,0) "RTN","TMGMISC",598,0) ;"Output: Text of date, as specified by above "RTN","TMGMISC",599,0) "RTN","TMGMISC",600,0) new result set result="" "RTN","TMGMISC",601,0) new Token set Token="" "RTN","TMGMISC",602,0) new LastToken set LastToken="" "RTN","TMGMISC",603,0) new ch set ch="" "RTN","TMGMISC",604,0) new LastCh set LastCh="" "RTN","TMGMISC",605,0) new InStr set InStr=0 "RTN","TMGMISC",606,0) new done set done=0 "RTN","TMGMISC",607,0) new i "RTN","TMGMISC",608,0) "RTN","TMGMISC",609,0) if $get(format)="" goto FDTDone "RTN","TMGMISC",610,0) if +$get(FMDate)=0 goto FDTDone "RTN","TMGMISC",611,0) "RTN","TMGMISC",612,0) for i=1:1:$length(format) do quit:done "RTN","TMGMISC",613,0) . set LastCh=ch "RTN","TMGMISC",614,0) . set ch=$extract(format,i) ;"get next char of format string. "RTN","TMGMISC",615,0) . if (ch'=LastCh)&(LastCh'="")&(InStr=0) do ProcessToken(FMDate,.Token,.result,.Array) "RTN","TMGMISC",616,0) . set Token=Token_ch "RTN","TMGMISC",617,0) . if ch="'" do quit "RTN","TMGMISC",618,0) . . if InStr do ProcessToken(FMDate,.Token,.result) "RTN","TMGMISC",619,0) . . set InStr='InStr ;"toggle In-String mode "RTN","TMGMISC",620,0) . if (i=$length(format)) do ProcessToken(FMDate,.Token,.result,.Array) "RTN","TMGMISC",621,0) "RTN","TMGMISC",622,0) FDTDone "RTN","TMGMISC",623,0) quit result "RTN","TMGMISC",624,0) "RTN","TMGMISC",625,0) "RTN","TMGMISC",626,0) ProcessToken(FMDate,Token,Output,Array) "RTN","TMGMISC",627,0) ;"SCOPE: PRIVATE "RTN","TMGMISC",628,0) ;"Purpose: To take tokens and build output following rules specified by DTFormat) "RTN","TMGMISC",629,0) ;"Input: FMDate -- the date to work with "RTN","TMGMISC",630,0) ;" Token -- SHOULD BE PASSED BY REFERENCE. The code as oulined in DTFormat "RTN","TMGMISC",631,0) ;" Output -- SHOULD BE PASSED BY REFERENCE. The cumulative output "RTN","TMGMISC",632,0) ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE "RTN","TMGMISC",633,0) ;" The array will be filled with data as follows: "RTN","TMGMISC",634,0) ;" Array(Token)=value for that token (ignores codes such as '/') "RTN","TMGMISC",635,0) "RTN","TMGMISC",636,0) "RTN","TMGMISC",637,0) if $extract(Token,1,1)="'" do goto PTDone "RTN","TMGMISC",638,0) . new Str set Str=$extract(Token,2,$length(Token)-1) "RTN","TMGMISC",639,0) . set Output=Output_Str "RTN","TMGMISC",640,0) "RTN","TMGMISC",641,0) if Token=" " set Output=Output_Token goto PTDone "RTN","TMGMISC",642,0) if Token="." set Output=Output_Token goto PTDone "RTN","TMGMISC",643,0) if Token=":" set Output=Output_Token goto PTDone "RTN","TMGMISC",644,0) if Token="/" set Output=Output_Token goto PTDone "RTN","TMGMISC",645,0) if Token=";" set Output=Output_Token goto PTDone "RTN","TMGMISC",646,0) if Token="," set Output=Output_Token goto PTDone "RTN","TMGMISC",647,0) if Token="-" set Output=Output_Token goto PTDone "RTN","TMGMISC",648,0) if Token="@" set Output=Output_Token goto PTDone "RTN","TMGMISC",649,0) "RTN","TMGMISC",650,0) if Token="yy" do goto PTDone "RTN","TMGMISC",651,0) . new Year set Year=+$extract(FMDate,1,3) "RTN","TMGMISC",652,0) . if Year=0 quit "RTN","TMGMISC",653,0) . set Year=+$extract(FMDate,2,3) "RTN","TMGMISC",654,0) . if Year<10 set Year="0"_Year "RTN","TMGMISC",655,0) . set Output=Output_Year "RTN","TMGMISC",656,0) . set Array(Token)=Year; "RTN","TMGMISC",657,0) "RTN","TMGMISC",658,0) if Token="yyyy" do goto PTDone "RTN","TMGMISC",659,0) . new Year set Year=+$extract(FMDate,1,3) "RTN","TMGMISC",660,0) . if Year>0 do "RTN","TMGMISC",661,0) . . set Year=Year+1700 "RTN","TMGMISC",662,0) . . set Output=Output_Year "RTN","TMGMISC",663,0) . . set Array(Token)=Year "RTN","TMGMISC",664,0) "RTN","TMGMISC",665,0) if Token="m" do goto PTDone "RTN","TMGMISC",666,0) . new Month set Month=+$extract(FMDate,4,5) "RTN","TMGMISC",667,0) . if Month>0 do "RTN","TMGMISC",668,0) . . set Output=Output_Month "RTN","TMGMISC",669,0) . . set Array(Token)=Month "RTN","TMGMISC",670,0) "RTN","TMGMISC",671,0) if Token="mm" do goto PTDone "RTN","TMGMISC",672,0) . new Month set Month=+$extract(FMDate,4,5) "RTN","TMGMISC",673,0) . if Month=0 quit "RTN","TMGMISC",674,0) . if Month<10 set Month="0"_Month "RTN","TMGMISC",675,0) . set Output=Output_Month "RTN","TMGMISC",676,0) . set Array(Token)=Month "RTN","TMGMISC",677,0) "RTN","TMGMISC",678,0) if Token="mmm" do goto PTDone "RTN","TMGMISC",679,0) . new Month set Month=+$extract(FMDate,4,5) "RTN","TMGMISC",680,0) . if Month=0 quit "RTN","TMGMISC",681,0) . else if Month=1 set Month="Jan" "RTN","TMGMISC",682,0) . else if Month=2 set Month="Feb" "RTN","TMGMISC",683,0) . else if Month=3 set Month="Mar" "RTN","TMGMISC",684,0) . else if Month=4 set Month="Apr" "RTN","TMGMISC",685,0) . else if Month=5 set Month="May" "RTN","TMGMISC",686,0) . else if Month=6 set Month="Jun" "RTN","TMGMISC",687,0) . else if Month=7 set Month="Jul" "RTN","TMGMISC",688,0) . else if Month=8 set Month="Aug" "RTN","TMGMISC",689,0) . else if Month=9 set Month="Sept" "RTN","TMGMISC",690,0) . else if Month=10 set Month="Oct" "RTN","TMGMISC",691,0) . else if Month=11 set Month="Nov" "RTN","TMGMISC",692,0) . else if Month=12 set Month="Dec" "RTN","TMGMISC",693,0) . if +Month=0 do "RTN","TMGMISC",694,0) . . set Output=Output_Month "RTN","TMGMISC",695,0) . . set Array(Token)=Month "RTN","TMGMISC",696,0) "RTN","TMGMISC",697,0) if Token="mmmm" do goto PTDone "RTN","TMGMISC",698,0) . new Month set Month=+$extract(FMDate,4,5) "RTN","TMGMISC",699,0) . if Month=0 quit "RTN","TMGMISC",700,0) . else if Month=1 set Month="January" "RTN","TMGMISC",701,0) . else if Month=2 set Month="February" "RTN","TMGMISC",702,0) . else if Month=3 set Month="March" "RTN","TMGMISC",703,0) . else if Month=4 set Month="April" "RTN","TMGMISC",704,0) . else if Month=5 set Month="May" "RTN","TMGMISC",705,0) . else if Month=6 set Month="June" "RTN","TMGMISC",706,0) . else if Month=7 set Month="July" "RTN","TMGMISC",707,0) . else if Month=8 set Month="August" "RTN","TMGMISC",708,0) . else if Month=9 set Month="September" "RTN","TMGMISC",709,0) . else if Month=10 set Month="October" "RTN","TMGMISC",710,0) . else if Month=11 set Month="November" "RTN","TMGMISC",711,0) . else if Month=12 set Month="December" "RTN","TMGMISC",712,0) . else if +Month=0 do "RTN","TMGMISC",713,0) . . set Output=Output_Month "RTN","TMGMISC",714,0) . . set Array(Token)=Month "RTN","TMGMISC",715,0) "RTN","TMGMISC",716,0) if Token="d" do goto PTDone "RTN","TMGMISC",717,0) . new Day set Day=+$extract(FMDate,6,7) "RTN","TMGMISC",718,0) . if Day>0 do "RTN","TMGMISC",719,0) . . set Output=Output_Day "RTN","TMGMISC",720,0) . . set Array(Token)=Day "RTN","TMGMISC",721,0) "RTN","TMGMISC",722,0) if Token="dd" do goto PTDone "RTN","TMGMISC",723,0) . new Day set Day=+$extract(FMDate,6,7) "RTN","TMGMISC",724,0) . if Day=0 quit "RTN","TMGMISC",725,0) . if Day<10 set Day="0"_Day "RTN","TMGMISC",726,0) . set Output=Output_Day "RTN","TMGMISC",727,0) . set Array(Token)=Day "RTN","TMGMISC",728,0) "RTN","TMGMISC",729,0) if Token="w" do goto PTDone "RTN","TMGMISC",730,0) . new DOW set DOW=$$DOW^XLFDT(FMDate,1) "RTN","TMGMISC",731,0) . if DOW>0 do "RTN","TMGMISC",732,0) . . set Output=Output_DOW "RTN","TMGMISC",733,0) . . set Array(Token)=DOW "RTN","TMGMISC",734,0) "RTN","TMGMISC",735,0) if Token="ww" do goto PTDone "RTN","TMGMISC",736,0) . new DOW set DOW=$$DOW^XLFDT(FMDate,1) "RTN","TMGMISC",737,0) . if (DOW<0)!(DOW>6) quit "RTN","TMGMISC",738,0) . if DOW=0 set DOW="Sun" "RTN","TMGMISC",739,0) . if DOW=1 set DOW="Mon" "RTN","TMGMISC",740,0) . if DOW=2 set DOW="Tue" "RTN","TMGMISC",741,0) . if DOW=3 set DOW="Wed" "RTN","TMGMISC",742,0) . if DOW=4 set DOW="Thur" "RTN","TMGMISC",743,0) . if DOW=5 set DOW="Fri" "RTN","TMGMISC",744,0) . if DOW=6 set DOW="Sat" "RTN","TMGMISC",745,0) . set Output=Output_DOW "RTN","TMGMISC",746,0) . set Array(Token)=DOW "RTN","TMGMISC",747,0) "RTN","TMGMISC",748,0) if Token="www" do goto PTDone "RTN","TMGMISC",749,0) . new DOW set DOW=$$DOW^XLFDT(FMDate) "RTN","TMGMISC",750,0) . if DOW'="day" do "RTN","TMGMISC",751,0) . . set Output=Output_DOW "RTN","TMGMISC",752,0) . . set Array(Token)=DOW "RTN","TMGMISC",753,0) "RTN","TMGMISC",754,0) if Token="h" do goto PTDone "RTN","TMGMISC",755,0) . new Hour set Hour=+$extract(FMDate,9,10) "RTN","TMGMISC",756,0) . if Hour>0 do "RTN","TMGMISC",757,0) . . set Output=Output_Hour "RTN","TMGMISC",758,0) . . set Array(Token)=Hour "RTN","TMGMISC",759,0) "RTN","TMGMISC",760,0) if Token="hh" do goto PTDone "RTN","TMGMISC",761,0) . new Hour set Hour=+$extract(FMDate,9,10) "RTN","TMGMISC",762,0) . if Hour=0 quit "RTN","TMGMISC",763,0) . if Hour<10 set Hour="0"_Hour "RTN","TMGMISC",764,0) . set Output=Output_Hour "RTN","TMGMISC",765,0) . set Array(Token)=Hour "RTN","TMGMISC",766,0) "RTN","TMGMISC",767,0) if Token="H" do goto PTDone "RTN","TMGMISC",768,0) . new Hour set Hour=+$extract(FMDate,9,10) "RTN","TMGMISC",769,0) . if Hour>12 set Hour=Hour-12 "RTN","TMGMISC",770,0) . if Hour>0 do "RTN","TMGMISC",771,0) . . set Output=Output_Hour "RTN","TMGMISC",772,0) . . set Array(Token)=Hour "RTN","TMGMISC",773,0) "RTN","TMGMISC",774,0) if Token="HH" do goto PTDone "RTN","TMGMISC",775,0) . new Hour set Hour=+$extract(FMDate,9,10) "RTN","TMGMISC",776,0) . if Hour=0 quit "RTN","TMGMISC",777,0) . if Hour>12 set Hour=Hour-12 "RTN","TMGMISC",778,0) . if Hour<10 set Hour="0"_Hour "RTN","TMGMISC",779,0) . set Output=Output_Hour "RTN","TMGMISC",780,0) . set Array(Token)=Hour "RTN","TMGMISC",781,0) "RTN","TMGMISC",782,0) if Token="#" do goto PTDone "RTN","TMGMISC",783,0) . new Hour set Hour=+$extract(FMDate,9,10) "RTN","TMGMISC",784,0) . new code "RTN","TMGMISC",785,0) . if Hour=0 quit "RTN","TMGMISC",786,0) . if Hour>12 set code="pm" "RTN","TMGMISC",787,0) . else set code="am" "RTN","TMGMISC",788,0) . set Output=Output_code "RTN","TMGMISC",789,0) . set Array(Token)=code "RTN","TMGMISC",790,0) "RTN","TMGMISC",791,0) new Min set Min=+$extract(FMDate,11,12) "RTN","TMGMISC",792,0) "RTN","TMGMISC",793,0) if Token="M" do goto PTDone "RTN","TMGMISC",794,0) . new Min set Min=+$extract(FMDate,11,12) "RTN","TMGMISC",795,0) . set Output=Output_Min "RTN","TMGMISC",796,0) . set Array(Token)=Min "RTN","TMGMISC",797,0) "RTN","TMGMISC",798,0) if Token="MM" do goto PTDone "RTN","TMGMISC",799,0) . new Min set Min=+$extract(FMDate,11,12) "RTN","TMGMISC",800,0) . if Min<10 set Min="0"_Min "RTN","TMGMISC",801,0) . set Output=Output_Min "RTN","TMGMISC",802,0) . set Array(Token)=Min "RTN","TMGMISC",803,0) "RTN","TMGMISC",804,0) if Token="s" do goto PTDone "RTN","TMGMISC",805,0) . new Sec set Sec=+$extract(FMDate,13,14) "RTN","TMGMISC",806,0) . set Output=Output_Sec "RTN","TMGMISC",807,0) . set Array(Token)=Sec "RTN","TMGMISC",808,0) "RTN","TMGMISC",809,0) if Token="ss" do goto PTDone "RTN","TMGMISC",810,0) . new Sec set Sec=+$extract(FMDate,13,14) "RTN","TMGMISC",811,0) . if Sec<10 set Sec="0"_Sec "RTN","TMGMISC",812,0) . set Output=Output_Sec "RTN","TMGMISC",813,0) . set Array(Token)=Sec "RTN","TMGMISC",814,0) "RTN","TMGMISC",815,0) PTDone "RTN","TMGMISC",816,0) set Token="" "RTN","TMGMISC",817,0) quit "RTN","TMGMISC",818,0) "RTN","TMGMISC",819,0) "RTN","TMGMISC",820,0) "RTN","TMGMISC",821,0) "RTN","TMGMISC",822,0) CompDOB(DOB1,DOB2) "RTN","TMGMISC",823,0) ;"Purpose: to compare two DOB and return if they match, or are similar "RTN","TMGMISC",824,0) ;"Input: DOB1,DOB2 -- the two values to compare (in external format) "RTN","TMGMISC",825,0) ;"Result: 0 - no similarity or equality "RTN","TMGMISC",826,0) ;" 0.25 - doubt similarity "RTN","TMGMISC",827,0) ;" 0.50 - possible similarity "RTN","TMGMISC",828,0) ;" 0.75 - probable similarity "RTN","TMGMISC",829,0) ;" 1 - exact match "RTN","TMGMISC",830,0) ;"Note: I made this function because during lookups, I would get failures with data such as: "RTN","TMGMISC",831,0) ;" WILLIAM,JOHN G JR 05-21-60 "RTN","TMGMISC",832,0) ;" WILLIAM,JOHN G JR 05-11-60 <-- date differs by one digit. "RTN","TMGMISC",833,0) ;"Rules for comparision "RTN","TMGMISC",834,0) ;" if dates differ by 1 digit --> score of 0.75 "RTN","TMGMISC",835,0) ;" if dates differ by an absolute difference of < 1 months --> 0.75 "RTN","TMGMISC",836,0) ;" if dates differ by an absolute difference of < 6 months --> 0.50 "RTN","TMGMISC",837,0) ;" if dates differ by an absolute difference of < 1 year --> 0.25 "RTN","TMGMISC",838,0) ;" if dates differ by 2 digits --> 0.25 "RTN","TMGMISC",839,0) "RTN","TMGMISC",840,0) new DT1,DT2 "RTN","TMGMISC",841,0) new result set result=0 "RTN","TMGMISC",842,0) "RTN","TMGMISC",843,0) new %DT "RTN","TMGMISC",844,0) set X=DOB1 do ^%DT set DT1=Y ;"convert into internal format to avoid format snafu's "RTN","TMGMISC",845,0) set X=DOB2 do ^%DT set DT2=Y "RTN","TMGMISC",846,0) "RTN","TMGMISC",847,0) new DT1array,DT2array "RTN","TMGMISC",848,0) new temp "RTN","TMGMISC",849,0) if DT1=DT2 set result=1 goto CDOBDone "RTN","TMGMISC",850,0) "RTN","TMGMISC",851,0) set temp=$$DTFormat^TMGMISC(DT1,"mm/dd/yy",.DT1array) ;"parse date parts into array. "RTN","TMGMISC",852,0) set temp=$$DTFormat^TMGMISC(DT2,"mm/dd/yy",.DT2array) "RTN","TMGMISC",853,0) "RTN","TMGMISC",854,0) ;"Compare digits "RTN","TMGMISC",855,0) new NumDif set NumDif=0 "RTN","TMGMISC",856,0) new dg1,dg2 "RTN","TMGMISC",857,0) "RTN","TMGMISC",858,0) set dg1=$extract($get(DT1array("dd")),1,1) set dg2=$extract($get(DT2array("dd")),1,1) "RTN","TMGMISC",859,0) if dg1'=dg2 set NumDif=NumDif+1 "RTN","TMGMISC",860,0) set dg1=$extract($get(DT1array("dd")),2,2) set dg2=$extract($get(DT2array("dd")),2,2) "RTN","TMGMISC",861,0) if dg1'=dg2 set NumDif=NumDif+1 "RTN","TMGMISC",862,0) "RTN","TMGMISC",863,0) set dg1=$extract($get(DT1array("mm")),1,1) set dg2=$extract($get(DT2array("mm")),1,1) "RTN","TMGMISC",864,0) if dg1'=dg2 set NumDif=NumDif+1 "RTN","TMGMISC",865,0) set dg1=$extract($get(DT1array("mm")),2,2) set dg2=$extract($get(DT2array("mm")),2,2) "RTN","TMGMISC",866,0) if dg1'=dg2 set NumDif=NumDif+1 "RTN","TMGMISC",867,0) "RTN","TMGMISC",868,0) set dg1=$extract($get(DT1array("yy")),1,1) set dg2=$extract($get(DT2array("yy")),1,1) "RTN","TMGMISC",869,0) if dg1'=dg2 set NumDif=NumDif+1 "RTN","TMGMISC",870,0) set dg1=$extract($get(DT1array("yy")),2,2) set dg2=$extract($get(DT2array("yy")),2,2) "RTN","TMGMISC",871,0) if dg1'=dg2 set NumDif=NumDif+1 "RTN","TMGMISC",872,0) "RTN","TMGMISC",873,0) if NumDif=1 set result=0.75 goto CDOBDone "RTN","TMGMISC",874,0) if NumDif=2 set result=0.50 "RTN","TMGMISC",875,0) "RTN","TMGMISC",876,0) ;"Compare absolute date "RTN","TMGMISC",877,0) new H1,H2,DateDif "RTN","TMGMISC",878,0) set H1=$$FMTH^XLFDT(DT1,1) "RTN","TMGMISC",879,0) set H2=$$FMTH^XLFDT(DT2,1) "RTN","TMGMISC",880,0) set DateDif=$$HDIFF^XLFDT(H1,H2,1) ;"1=results in 'days' "RTN","TMGMISC",881,0) if $$HDIFF^XLFDT(H2,H1)>DateDif set DateDif=$$HDIFF^XLFDT(H2,H1) "RTN","TMGMISC",882,0) "RTN","TMGMISC",883,0) new score set score=0 "RTN","TMGMISC",884,0) if DateDif<30 set score=0.75 "RTN","TMGMISC",885,0) if DateDif<(30*6) set score=0.50 "RTN","TMGMISC",886,0) if DateDif<365 set score=0.25 "RTN","TMGMISC",887,0) "RTN","TMGMISC",888,0) if score>result set result=score "RTN","TMGMISC",889,0) "RTN","TMGMISC",890,0) CDOBDone "RTN","TMGMISC",891,0) quit result "RTN","TMGMISC",892,0) "RTN","TMGMISC",893,0) "RTN","TMGMISC",894,0) "RTN","TMGMISC",895,0) BrowseBy(CompArray,ByTag) "RTN","TMGMISC",896,0) ;"Purpose: Allow a user to interact with dynamic text tree "RTN","TMGMISC",897,0) ;" that will open and close nodes. "RTN","TMGMISC",898,0) ;"Input: CompArray -- array to browse. Should be in this format "RTN","TMGMISC",899,0) ;" CompArray("opening tag",a,b,c,d) "RTN","TMGMISC",900,0) ;" ByTag -- the name to use in for "opening tag") "RTN","TMGMISC",901,0) "RTN","TMGMISC",902,0) new aOpen set aOpen=0 "RTN","TMGMISC",903,0) new bOpen set bOpen=0 "RTN","TMGMISC",904,0) new cOpen set cOpen=0 "RTN","TMGMISC",905,0) "RTN","TMGMISC",906,0) new done set done=0 "RTN","TMGMISC",907,0) new input "RTN","TMGMISC",908,0) "RTN","TMGMISC",909,0) for do quit:(done=1) "RTN","TMGMISC",910,0) . do ShowBy(.CompArray,ByTag,aOpen,bOpen,cOpen) "RTN","TMGMISC",911,0) . read "Enter option:",input:$get(DTIME,3600),! "RTN","TMGMISC",912,0) . if input="" set input=0 "RTN","TMGMISC",913,0) . if +input>0 do "RTN","TMGMISC",914,0) . . if aOpen=0 do "RTN","TMGMISC",915,0) . . . set aOpen=input,bOpen=0,cOpen=0 "RTN","TMGMISC",916,0) . . else if bOpen=0 do "RTN","TMGMISC",917,0) . . . set bOpen=input,cOpen=0 "RTN","TMGMISC",918,0) . . else if cOpen=0 set cOpen=input "RTN","TMGMISC",919,0) . else if input=0 do "RTN","TMGMISC",920,0) . . if cOpen'=0 set cOpen=0 quit "RTN","TMGMISC",921,0) . . if bOpen'=0 set bOpen=0 quit "RTN","TMGMISC",922,0) . . set aOpen=0 "RTN","TMGMISC",923,0) . else if input="^" set done=1 "RTN","TMGMISC",924,0) "RTN","TMGMISC",925,0) quit "RTN","TMGMISC",926,0) "RTN","TMGMISC",927,0) "RTN","TMGMISC",928,0) ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) "RTN","TMGMISC",929,0) "RTN","TMGMISC",930,0) new a,b,c,d "RTN","TMGMISC",931,0) new acount set acount=0 "RTN","TMGMISC",932,0) new bcount set bcount=0 "RTN","TMGMISC",933,0) new ccount set ccount=0 "RTN","TMGMISC",934,0) new dcount set dcount=0 "RTN","TMGMISC",935,0) "RTN","TMGMISC",936,0) write # "RTN","TMGMISC",937,0) "RTN","TMGMISC",938,0) set a=$order(CompArray(ByTag,"")) "RTN","TMGMISC",939,0) if a'="" for do quit:(a="") "RTN","TMGMISC",940,0) . set acount=acount+1 "RTN","TMGMISC",941,0) . new nexta set nexta=$order(CompArray(ByTag,a)) "RTN","TMGMISC",942,0) . new Aindent "RTN","TMGMISC",943,0) . if (aOpen=0) do "RTN","TMGMISC",944,0) . . if acount<10 write "0" "RTN","TMGMISC",945,0) . . write acount,". " "RTN","TMGMISC",946,0) . else write "... " "RTN","TMGMISC",947,0) . write a,! "RTN","TMGMISC",948,0) . set b=$order(CompArray(ByTag,a,"")) "RTN","TMGMISC",949,0) . if (aOpen=acount)&(b'="") for do quit:(b="") "RTN","TMGMISC",950,0) . . set bcount=bcount+1 "RTN","TMGMISC",951,0) . . new nextb set nextb=$order(CompArray(ByTag,a,b)) "RTN","TMGMISC",952,0) . . new Bindent "RTN","TMGMISC",953,0) . . write " +--" "RTN","TMGMISC",954,0) . . if (bOpen=0) do "RTN","TMGMISC",955,0) . . . if bcount<10 write "0" "RTN","TMGMISC",956,0) . . . write bcount,". " "RTN","TMGMISC",957,0) . . else write "... " "RTN","TMGMISC",958,0) . . write b,! "RTN","TMGMISC",959,0) . . if nextb'="" set Aindent=" | " "RTN","TMGMISC",960,0) . . else set Aindent=" " "RTN","TMGMISC",961,0) . . set c=$order(CompArray(ByTag,a,b,"")) "RTN","TMGMISC",962,0) . . if (bOpen=bcount)&(c'="") for do quit:(c="") "RTN","TMGMISC",963,0) . . . set ccount=ccount+1 "RTN","TMGMISC",964,0) . . . new nextc set nextc=$order(CompArray(ByTag,a,b,c)) "RTN","TMGMISC",965,0) . . . if nextc'="" set Bindent=" | " "RTN","TMGMISC",966,0) . . . else set Bindent=" " "RTN","TMGMISC",967,0) . . . write Aindent," +--" "RTN","TMGMISC",968,0) . . . if (cOpen=0) do "RTN","TMGMISC",969,0) . . . . if ccount<10 write "0" "RTN","TMGMISC",970,0) . . . . write ccount,". " "RTN","TMGMISC",971,0) . . . else write "... " "RTN","TMGMISC",972,0) . . . write c,! "RTN","TMGMISC",973,0) . . . set d=$order(CompArray(ByTag,a,b,c,"")) "RTN","TMGMISC",974,0) . . . if (cOpen=ccount)&(d'="") for do quit:(d="") "RTN","TMGMISC",975,0) . . . . set dcount=dcount+1 "RTN","TMGMISC",976,0) . . . . write Aindent,Bindent," +-- " "RTN","TMGMISC",977,0) . . . . if dcount<10 write "0" "RTN","TMGMISC",978,0) . . . . write dcount,". " "RTN","TMGMISC",979,0) . . . . write d,! "RTN","TMGMISC",980,0) . . . . set d=$order(CompArray(ByTag,a,b,c,d)) "RTN","TMGMISC",981,0) . . . set c=nextc "RTN","TMGMISC",982,0) . . set b=nextb "RTN","TMGMISC",983,0) . set a=nexta "RTN","TMGMISC",984,0) "RTN","TMGMISC",985,0) SBDone "RTN","TMGMISC",986,0) quit "RTN","TMGMISC",987,0) "RTN","TMGMISC",988,0) "RTN","TMGMISC",989,0) "RTN","TMGMISC",990,0) CompName(Name1,Name2) "RTN","TMGMISC",991,0) ;"Purpose: To compare two names, to see if they are the name, or compatible. "RTN","TMGMISC",992,0) ;" e.g. WILLIAMS,J BILL vs. WILLAMS,JOHN BILL, vs. WILLIAMS,JOHN B "RTN","TMGMISC",993,0) ;"Input: Two names to compare "RTN","TMGMISC",994,0) ;"Result: 0 -- if entries conflict "RTN","TMGMISC",995,0) ;" 0.5 -- if entries are consistent (i.e. in example above) "RTN","TMGMISC",996,0) ;" 1 -- if entries completely match "RTN","TMGMISC",997,0) ;"Note: This function WILL IGNORE a suffix. This is because "RTN","TMGMISC",998,0) ;" WILLIAM,BILL 5-1-1950 "RTN","TMGMISC",999,0) ;" WILLIAM,BILL SR 5-1-1950 "RTN","TMGMISC",1000,0) ;" would be considered the same person (the date is the determining factor) "RTN","TMGMISC",1001,0) ;"Rules: Last names must completely match or --> 0 "RTN","TMGMISC",1002,0) ;" If name is exactly the same, then --> 1 "RTN","TMGMISC",1003,0) ;" Initial must be same as first letters in name (e.g. N vs. NEWTON) --> 0.5 "RTN","TMGMISC",1004,0) "RTN","TMGMISC",1005,0) new result set result=1 "RTN","TMGMISC",1006,0) "RTN","TMGMISC",1007,0) new NArray1,NArray2,TMGMsg "RTN","TMGMISC",1008,0) "RTN","TMGMISC",1009,0) set Name1=$$FormatName(Name1,1) ;"should convert to standard format. "RTN","TMGMISC",1010,0) set Name2=$$FormatName(Name2,1) "RTN","TMGMISC",1011,0) "RTN","TMGMISC",1012,0) do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) "RTN","TMGMISC",1013,0) do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. "RTN","TMGMISC",1014,0) "RTN","TMGMISC",1015,0) do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) "RTN","TMGMISC",1016,0) do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. "RTN","TMGMISC",1017,0) "RTN","TMGMISC",1018,0) if Name1=Name2 set result=1 goto CompNDone "RTN","TMGMISC",1019,0) if Name1("FAMILY")'=Name2("FAMILY") do goto:(result=0) CompNDone "RTN","TMGMISC",1020,0) . if $$EN^XUA4A71(Name1("FAMILY"))'=$$EN^XUA4A71(Name2("FAMILY")) set result=0 ;"check soundex equality "RTN","TMGMISC",1021,0) "RTN","TMGMISC",1022,0) if Name1("GIVEN")'=Name2("GIVEN") do "RTN","TMGMISC",1023,0) . if $$EN^XUA4A71(Name1("GIVEN"))=$$EN^XUA4A71(Name2("GIVEN")) quit ;"check soundex equality "RTN","TMGMISC",1024,0) . new n1,n2 "RTN","TMGMISC",1025,0) . set n1=Name1("GIVEN") "RTN","TMGMISC",1026,0) . set n2=Name2("GIVEN") "RTN","TMGMISC",1027,0) . if $length(n2)<$length(n1) do ;"ensure length n2>n1 "RTN","TMGMISC",1028,0) . . new temp set temp=n2 "RTN","TMGMISC",1029,0) . . set n2=n1,n1=temp "RTN","TMGMISC",1030,0) . if $extract(n2,1,$length(n1))=n1 set result=0.5 "RTN","TMGMISC",1031,0) . else set result=0 "RTN","TMGMISC",1032,0) if result=0 goto CompNDone "RTN","TMGMISC",1033,0) "RTN","TMGMISC",1034,0) if Name1("MIDDLE")'=Name2("MIDDLE") do "RTN","TMGMISC",1035,0) . if $$EN^XUA4A71(Name1("MIDDLE"))=$$EN^XUA4A71(Name2("MIDDLE")) quit ;"check soundex equality "RTN","TMGMISC",1036,0) . new n1,n2 "RTN","TMGMISC",1037,0) . set n1=Name1("MIDDLE") "RTN","TMGMISC",1038,0) . set n2=Name2("MIDDLE") "RTN","TMGMISC",1039,0) . if $length(n2)<$length(n1) do ;"ensure length n2>n1 "RTN","TMGMISC",1040,0) . . new temp set temp=n2 "RTN","TMGMISC",1041,0) . . set n2=n1,n1=temp "RTN","TMGMISC",1042,0) . if $extract(n2,1,$length(n1))=n1 set result=0.5 "RTN","TMGMISC",1043,0) . else set result=0 "RTN","TMGMISC",1044,0) if result=0 goto CompNDone "RTN","TMGMISC",1045,0) "RTN","TMGMISC",1046,0) CompNDone "RTN","TMGMISC",1047,0) quit result "RTN","TMGMISC",1048,0) "RTN","TMGMISC",1049,0) "RTN","TMGMISC",1050,0) "RTN","TMGMISC",1051,0) FormatName(Name,CutTitle) "RTN","TMGMISC",1052,0) ;"Purpose: To ensure patient name is properly formated. "RTN","TMGMISC",1053,0) ;" i.e. John G. Doe --> DOE,JOHN G "RTN","TMGMISC",1054,0) ;" John G. Doe III --> DOE,JOHN G III "RTN","TMGMISC",1055,0) ;" John G. Doe,III --> DOE,JOHN G III "RTN","TMGMISC",1056,0) ;" Doe, John G --> DOE,JOHN G "RTN","TMGMISC",1057,0) ;" Doe,John g.,III, phd --> DOE,JOHN G III PHD "RTN","TMGMISC",1058,0) ;"Input: Name -- the name to be reformated "RTN","TMGMISC",1059,0) ;" CutTitle -- OPTIONAL -- if 1, then titles (e.g. MD, PhD etc) will be cut "RTN","TMGMISC",1060,0) ;"Results: returns properly formated name "RTN","TMGMISC",1061,0) ;"Note: If Name is passed by reference, it will be changed "RTN","TMGMISC",1062,0) ;" Also, NO lookup is done in database to ensure name exists "RTN","TMGMISC",1063,0) "RTN","TMGMISC",1064,0) ;"Note: this function malfunctioned on a patient with name like this: "RTN","TMGMISC",1065,0) ;" JOHN A VAN DER BON --> BON,JOHN A VAN DER (should be VAN DER BON,JOHN A) "RTN","TMGMISC",1066,0) ;" I don't have a quick for this right now... "RTN","TMGMISC",1067,0) ;"Also, Sue St. Clair --> CLAIR,SUE ST this is also wrong. "RTN","TMGMISC",1068,0) "RTN","TMGMISC",1069,0) ;"FYI: do STDNAME^XLFNAME(.NAME,FLAGS,.ERRARRAY) can also do standardization, "RTN","TMGMISC",1070,0) ;" and also parse to component parts. It specifically address the St. Clair issue. "RTN","TMGMISC",1071,0) "RTN","TMGMISC",1072,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") "RTN","TMGMISC",1073,0) "RTN","TMGMISC",1074,0) new NameArray "RTN","TMGMISC",1075,0) new MaxNode "RTN","TMGMISC",1076,0) new Suffix set Suffix="" "RTN","TMGMISC",1077,0) new i,s,lname "RTN","TMGMISC",1078,0) new fname set fname="" "RTN","TMGMISC",1079,0) new result set result="" "RTN","TMGMISC",1080,0) if $data(Name)#10=0 goto FormatNDone "RTN","TMGMISC",1081,0) "RTN","TMGMISC",1082,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Person's name initially is: '",Name,"'") "RTN","TMGMISC",1083,0) set Name=$translate(Name,"*.","") ;"cleans off any *'s or .'s from initials etc. "RTN","TMGMISC",1084,0) if Name[", " do "RTN","TMGMISC",1085,0) . new s1,s2 "RTN","TMGMISC",1086,0) . set s1=$piece(Name,", ",1) "RTN","TMGMISC",1087,0) . set s2=$piece(Name,", ",2) "RTN","TMGMISC",1088,0) . if $$IsTitle($$UP^XLFSTR(s2))&($get(CutTitle)=1) do "RTN","TMGMISC",1089,0) . . set Name=s1 "RTN","TMGMISC",1090,0) . else do "RTN","TMGMISC",1091,0) . . set Name=s1_","_s2 "RTN","TMGMISC",1092,0) . ;"set Name=$translate(Name,", ",",") ;"Convert 'Doe, John' into 'Doe,John' "RTN","TMGMISC",1093,0) set Name=$$UP^XLFSTR(Name) ;"convert to upper case "RTN","TMGMISC",1094,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After translations, name is: '",Name,"'") "RTN","TMGMISC",1095,0) set result=$$FORMAT^DPTNAME(Name,3,30) ;"Convert to 'internal' format "RTN","TMGMISC",1096,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After $$FORMAT^DPTNAME, name is: '",result,"'") "RTN","TMGMISC",1097,0) "RTN","TMGMISC",1098,0) ;"Now, test if FORMAT^DPTNAME caused empty name, i.e. "RTN","TMGMISC",1099,0) ;" John G Doe --> "" (it wanted Doe,John G) "RTN","TMGMISC",1100,0) set lname=$piece(result,",",2) "RTN","TMGMISC",1101,0) if $$IsTitle(lname)&($get(CutTitle)=1) do ;"trim off title if not wanted. "RTN","TMGMISC",1102,0) . set result=$piece(result,",",1) "RTN","TMGMISC",1103,0) . set lname="" "RTN","TMGMISC",1104,0) if $$IsSuffix(lname)=1 do "RTN","TMGMISC",1105,0) . ;"Here we have 'JOHN DOE,III' --> must be changed to 'DOE,JOHN III' "RTN","TMGMISC",1106,0) . set Name=$translate(Name,","," ") ;"First change 'JOHN DOE,III' --> 'JOHN DOE III' "RTN","TMGMISC",1107,0) . set result="" ;"signal need to rearrange letters. "RTN","TMGMISC",1108,0) if (result="")&(Name'[",") do "RTN","TMGMISC",1109,0) . set s=Name "RTN","TMGMISC",1110,0) . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1) "RTN","TMGMISC",1111,0) . set MaxNode=+$get(NameArray("MAXNODE")) "RTN","TMGMISC",1112,0) . if MaxNode=0 quit "RTN","TMGMISC",1113,0) . if $get(CutTitle)=1 do "RTN","TMGMISC",1114,0) . . if $$IsTitle(NameArray(MaxNode)) do "RTN","TMGMISC",1115,0) . . . kill NameArray(MaxNode) "RTN","TMGMISC",1116,0) . . . set MaxNode=MaxNode-1 "RTN","TMGMISC",1117,0) . . . set NameArray("MAXNODE")=MaxNode "RTN","TMGMISC",1118,0) . set lname=NameArray(MaxNode) "RTN","TMGMISC",1119,0) . if ($$IsSuffix(lname)=1)!($$IsTitle(lname)) do "RTN","TMGMISC",1120,0) . . ;"Change JOHN G DOE III --> JOHN G III DOE (order change in array) "RTN","TMGMISC",1121,0) . . set lname=NameArray(MaxNode-1) ;"i.e. DOE "RTN","TMGMISC",1122,0) . . set Suffix=NameArray(MaxNode) ;"i.e. III "RTN","TMGMISC",1123,0) . . set NameArray(MaxNode)=lname "RTN","TMGMISC",1124,0) . . set NameArray(MaxNode-1)=Suffix "RTN","TMGMISC",1125,0) . set result=lname_"," "RTN","TMGMISC",1126,0) . for i=1:1:MaxNode-1 do "RTN","TMGMISC",1127,0) . . set result=result_NameArray(i)_" " "RTN","TMGMISC",1128,0) "RTN","TMGMISC",1129,0) ;"convert potential 'DOE,JOHN G,III, PHD' --> 'DOE,JOHN G III PHD' "RTN","TMGMISC",1130,0) set lname=$piece(result,",",1) "RTN","TMGMISC",1131,0) set fname=$piece(result,",",2,99) "RTN","TMGMISC",1132,0) set fname=$translate(fname,","," ") "RTN","TMGMISC",1133,0) set result=lname_","_fname "RTN","TMGMISC",1134,0) "RTN","TMGMISC",1135,0) set result=$$Trim^TMGSTUTL(result) "RTN","TMGMISC",1136,0) "RTN","TMGMISC",1137,0) ;"One last run through, after all custom alterations made. "RTN","TMGMISC",1138,0) ;"convert potential 'DOE,JOHN G III PHD' --> 'DOE,JOHN G III PHD' "RTN","TMGMISC",1139,0) set result=$$FORMAT^DPTNAME(result,3,30) ;"Convert to 'internal' format "RTN","TMGMISC",1140,0) "RTN","TMGMISC",1141,0) FormatNDone "RTN","TMGMISC",1142,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") "RTN","TMGMISC",1143,0) quit result "RTN","TMGMISC",1144,0) "RTN","TMGMISC",1145,0) "RTN","TMGMISC",1146,0) IsSuffix(s) "RTN","TMGMISC",1147,0) ;"Purpose: to return whether s is a suffix (i.e. I,II,Jr.,Sr. etc.) "RTN","TMGMISC",1148,0) ;"Input: s : the string to check "RTN","TMGMISC",1149,0) ;"Result 0 if NOT a suffix, 1 if IS a suffix. "RTN","TMGMISC",1150,0) "RTN","TMGMISC",1151,0) new result set result=0 "RTN","TMGMISC",1152,0) "RTN","TMGMISC",1153,0) if (s="I")!(s="II")!(s="III")!(s="JR")!(s="SR") set result=1 "RTN","TMGMISC",1154,0) "RTN","TMGMISC",1155,0) quit result "RTN","TMGMISC",1156,0) "RTN","TMGMISC",1157,0) "RTN","TMGMISC",1158,0) IsTitle(s) "RTN","TMGMISC",1159,0) ;"Purpose: to return whether s is a title (i.e. MD,PHD,JD,DDS etc.) "RTN","TMGMISC",1160,0) ;"Input: s : the string to check "RTN","TMGMISC",1161,0) ;"Result 0 if NOT a suffix, 1 if IS a suffix. "RTN","TMGMISC",1162,0) "RTN","TMGMISC",1163,0) new result set result=0 "RTN","TMGMISC",1164,0) "RTN","TMGMISC",1165,0) if (s="MD")!(s="PHD")!(s="JD")!(s="DDS") set result=1 "RTN","TMGMISC",1166,0) if (s="FNP")!(s="GNP")!(s="NP")!(s="PA") set result=1 "RTN","TMGMISC",1167,0) if (s="RN")!(s="LPN") set result=1 "RTN","TMGMISC",1168,0) "RTN","TMGMISC",1169,0) quit result "RTN","TMGMISC",1170,0) "RTN","TMGMISC",1171,0) "RTN","TMGMISC",1172,0) "RTN","TMGMISC",1173,0) HEXCHR(V) "RTN","TMGMISC",1174,0) ;"Scope: PUBLIC "RTN","TMGMISC",1175,0) ;"Take one BYTE and return HEX Values "RTN","TMGMISC",1176,0) ;"(from Chris Richardson -- thanks!) "RTN","TMGMISC",1177,0) new NV,B1,B2 "RTN","TMGMISC",1178,0) set NV="0123456789ABCDEF" "RTN","TMGMISC",1179,0) set B1=(V#16)+1 ; "0 to 15 becomes 1 to 16 "RTN","TMGMISC",1180,0) set B2=(V\16)+1 "RTN","TMGMISC",1181,0) quit $E(NV,B2)_$E(NV,B1) "RTN","TMGMISC",1182,0) "RTN","TMGMISC",1183,0) "RTN","TMGMISC",1184,0) HEXCHR2(n,digits) "RTN","TMGMISC",1185,0) ;"SCOPE: PUBLIC "RTN","TMGMISC",1186,0) ;"Purpose: convert n to hex characters "RTN","TMGMISC",1187,0) ;"Input: n -- the number to convert "RTN","TMGMISC",1188,0) ;" digits: (optional) number of digits in output. Leading 0's padded to "RTN","TMGMISC",1189,0) ;" front of answer to set number of digits. "RTN","TMGMISC",1190,0) ;" e.g. if answer is "A", then "RTN","TMGMISC",1191,0) ;" 2 -> mandates at least 2 digits ("0A") "RTN","TMGMISC",1192,0) ;" 3->3 digits ("00A") "RTN","TMGMISC",1193,0) ;"Note: This function is not as fast as HEXCHR(V) "RTN","TMGMISC",1194,0) "RTN","TMGMISC",1195,0) new lo "RTN","TMGMISC",1196,0) new result set result="" "RTN","TMGMISC",1197,0) new ch "RTN","TMGMISC",1198,0) set digits=$get(digits,1) "RTN","TMGMISC",1199,0) "RTN","TMGMISC",1200,0) for do quit:(n=0) "RTN","TMGMISC",1201,0) . set lo=n#16 "RTN","TMGMISC",1202,0) . if (lo<10) set ch=+lo "RTN","TMGMISC",1203,0) . else set ch=$char(55+lo) "RTN","TMGMISC",1204,0) . set result=ch_result "RTN","TMGMISC",1205,0) . set n=n\16 "RTN","TMGMISC",1206,0) "RTN","TMGMISC",1207,0) if $length(result) 16 "RTN","TMGMISC",1217,0) "RTN","TMGMISC",1218,0) new multiplier set multiplier=1 "RTN","TMGMISC",1219,0) new result set result=0 "RTN","TMGMISC",1220,0) "RTN","TMGMISC",1221,0) if $extract(s,1)="$" set s=$extract(s,2,$length(s)) "RTN","TMGMISC",1222,0) "RTN","TMGMISC",1223,0) for do quit:(s="") "RTN","TMGMISC",1224,0) . new sStart,sEnd,n "RTN","TMGMISC",1225,0) . set sStart=$extract(s,1,$length(s)-1) "RTN","TMGMISC",1226,0) . set sEnd=$extract(s,$length(s)) "RTN","TMGMISC",1227,0) . if +sEnd=sEnd set n=sEnd "RTN","TMGMISC",1228,0) . else set n=($ascii(sEnd)-65)+16 "RTN","TMGMISC",1229,0) . set result=result+(n*multiplier) "RTN","TMGMISC",1230,0) . set multiplier=multiplier*16 "RTN","TMGMISC",1231,0) . set s=sStart "RTN","TMGMISC",1232,0) "RTN","TMGMISC",1233,0) quit result "RTN","TMGMISC",1234,0) "RTN","TMGMISC",1235,0) "RTN","TMGMISC",1236,0) OR(a,b) "RTN","TMGMISC",1237,0) ;"Scope: PUBLIC "RTN","TMGMISC",1238,0) ;"Purpose: to perform a bitwise OR on operands a and b "RTN","TMGMISC",1239,0) "RTN","TMGMISC",1240,0) new result set result=0 "RTN","TMGMISC",1241,0) new mult set mult=1 "RTN","TMGMISC",1242,0) for do quit:(a'>0)&(b'>0) "RTN","TMGMISC",1243,0) . set result=result+(((a#2)!(b#2))*mult) "RTN","TMGMISC",1244,0) . set a=a\2,b=b\2,mult=mult*2 "RTN","TMGMISC",1245,0) "RTN","TMGMISC",1246,0) quit result "RTN","TMGMISC",1247,0) "RTN","TMGMISC",1248,0) "RTN","TMGMISC",1249,0) ParsePos(pos,label,offset,routine,dmod) "RTN","TMGMISC",1250,0) ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts "RTN","TMGMISC",1251,0) ;"Input: pos -- the string, as example above "RTN","TMGMISC",1252,0) ;" label -- OUT PARAM, PASS BY REF, would return "x" "RTN","TMGMISC",1253,0) ;" offset -- OUT PARAM, PASS BY REF, would return "+2" "RTN","TMGMISC",1254,0) ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE" "RTN","TMGMISC",1255,0) ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD" "RTN","TMGMISC",1256,0) ;"Results: none "RTN","TMGMISC",1257,0) ;"Note: results are shortened to 8 characters. "RTN","TMGMISC",1258,0) "RTN","TMGMISC",1259,0) new s "RTN","TMGMISC",1260,0) set s=$get(pos) "RTN","TMGMISC",1261,0) set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE "RTN","TMGMISC",1262,0) set routine=$piece(s,"^",2) "RTN","TMGMISC",1263,0) set routine=$extract(routine,1,8) "RTN","TMGMISC",1264,0) set label=$piece(s,"^",1) "RTN","TMGMISC",1265,0) set offset=$piece(label,"+",2) "RTN","TMGMISC",1266,0) set label=$piece(label,"+",1) "RTN","TMGMISC",1267,0) set label=$extract(label,1,8) "RTN","TMGMISC",1268,0) "RTN","TMGMISC",1269,0) quit "RTN","TMGMISC",1270,0) "RTN","TMGMISC",1271,0) "RTN","TMGMISC",1272,0) ScanMod(Module,pArray) "RTN","TMGMISC",1273,0) ;"Purpose: To scan a module and find all the labels/entry points/Entry points "RTN","TMGMISC",1274,0) ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") "RTN","TMGMISC",1275,0) ;" pArray -- pointer to (NAME OF) array Will be filled like this "RTN","TMGMISC",1276,0) ;" pArray(1,"TAG")="Label1" "RTN","TMGMISC",1277,0) ;" pArray(1,"OFFSET")=1 "RTN","TMGMISC",1278,0) ;" pArray(2,"TAG")="Label2" "RTN","TMGMISC",1279,0) ;" pArray(2,"OFFSET")=9 "RTN","TMGMISC",1280,0) ;" pArray(3,"TAG")="Label3" etc. "RTN","TMGMISC",1281,0) ;" pArray(3,"OFFSET")=15 "RTN","TMGMISC",1282,0) ;" pArray("Label1")=1 "RTN","TMGMISC",1283,0) ;" pArray("Label2")=2 "RTN","TMGMISC",1284,0) ;" pArray("Label3")=3 "RTN","TMGMISC",1285,0) ;" "RTN","TMGMISC",1286,0) ;" NOTE: there seems to be a problem if the passed pArray value is "pArray", "RTN","TMGMISC",1287,0) ;" so use another name. "RTN","TMGMISC",1288,0) ;" "RTN","TMGMISC",1289,0) ;"Output: Results are put into array "RTN","TMGMISC",1290,0) ;"Result: none "RTN","TMGMISC",1291,0) "RTN","TMGMISC",1292,0) new smIdx set smIdx=1 "RTN","TMGMISC",1293,0) new LabelNum set LabelNum=0 "RTN","TMGMISC",1294,0) new smLine set smLine="" "RTN","TMGMISC",1295,0) if $get(Module)="" goto SMDone "RTN","TMGMISC",1296,0) "RTN","TMGMISC",1297,0) for do quit:(smLine="") "RTN","TMGMISC",1298,0) . new smCh "RTN","TMGMISC",1299,0) . set smLine=$text(+smIdx^@Module) "RTN","TMGMISC",1300,0) . if smLine="" quit "RTN","TMGMISC",1301,0) . set smLine=$$Substitute^TMGSTUTL(smLine,$Char(9)," ") ;"replace tabs for 8 spaces "RTN","TMGMISC",1302,0) . set smCh=$extract(smLine,1) "RTN","TMGMISC",1303,0) . if (smCh'=" ")&(smCh'=";") do "RTN","TMGMISC",1304,0) . . new label "RTN","TMGMISC",1305,0) . . set label=$piece(smLine," ",1) "RTN","TMGMISC",1306,0) . . set LabelNum=LabelNum+1 "RTN","TMGMISC",1307,0) . . set @pArray@(LabelNum,"TAG")=label "RTN","TMGMISC",1308,0) . . set @pArray@(LabelNum,"OFFSET")=smIdx "RTN","TMGMISC",1309,0) . . set @pArray@(label)=LabelNum "RTN","TMGMISC",1310,0) . set smIdx=smIdx+1 "RTN","TMGMISC",1311,0) "RTN","TMGMISC",1312,0) SMDone "RTN","TMGMISC",1313,0) quit "RTN","TMGMISC",1314,0) "RTN","TMGMISC",1315,0) "RTN","TMGMISC",1316,0) ConvertPos(Pos,pArray) "RTN","TMGMISC",1317,0) ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into "RTN","TMGMISC",1318,0) ;" one that is relative to the start of the file "RTN","TMGMISC",1319,0) ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT "RTN","TMGMISC",1320,0) ;"Input: Pos -- a position, as returned from $ZPOS "RTN","TMGMISC",1321,0) ;" pArray -- pointer to (name of). Array holding holding tag offsets "RTN","TMGMISC",1322,0) ;" pArray will be in this format: "RTN","TMGMISC",1323,0) ;" pArray("ModuleA",1,"TAG")="ALabel1" "RTN","TMGMISC",1324,0) ;" pArray("ModuleA",1,"OFFSET")=1 "RTN","TMGMISC",1325,0) ;" pArray("ModuleA",2,"TAG")="ALabel2" "RTN","TMGMISC",1326,0) ;" pArray("ModuleA",2,"OFFSET")=9 "RTN","TMGMISC",1327,0) ;" pArray("ModuleA","Label1")=1 "RTN","TMGMISC",1328,0) ;" pArray("ModuleA","Label2")=2 "RTN","TMGMISC",1329,0) ;" pArray("ModuleA","Label3")=3 "RTN","TMGMISC",1330,0) ;" pArray("ModuleB",1,"TAG")="BLabel1" "RTN","TMGMISC",1331,0) ;" pArray("ModuleB",1,"OFFSET")=4 "RTN","TMGMISC",1332,0) ;" pArray("ModuleB",2,"TAG")="BLabel2" "RTN","TMGMISC",1333,0) ;" pArray("ModuleB",2,"OFFSET")=23 "RTN","TMGMISC",1334,0) ;" pArray("ModuleB","Label1")=1 "RTN","TMGMISC",1335,0) ;" pArray("ModuleB","Label2")=2 "RTN","TMGMISC",1336,0) ;" pArray("ModuleB","Label3")=3 "RTN","TMGMISC",1337,0) ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it "RTN","TMGMISC",1338,0) ;"Result: returns the new position line, relative to the start of the file/module "RTN","TMGMISC",1339,0) ;" "RTN","TMGMISC",1340,0) "RTN","TMGMISC",1341,0) new cpS "RTN","TMGMISC",1342,0) new cpResult set cpResult="" "RTN","TMGMISC",1343,0) new cpRoutine,cpLabel,cpOffset "RTN","TMGMISC",1344,0) "RTN","TMGMISC",1345,0) set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE "RTN","TMGMISC",1346,0) if cpS="" goto CPDone "RTN","TMGMISC",1347,0) "RTN","TMGMISC",1348,0) set cpRoutine=$piece(cpS,"^",2) "RTN","TMGMISC",1349,0) if cpRoutine="" goto CPDone "RTN","TMGMISC",1350,0) "RTN","TMGMISC",1351,0) set cpS=$piece(cpS,"^",1) "RTN","TMGMISC",1352,0) set cpOffset=+$piece(cpS,"+",2) "RTN","TMGMISC",1353,0) ;"if cpOffset="" set cpOffset=1 "RTN","TMGMISC",1354,0) ;"else set cpOffset=+cpOffset "RTN","TMGMISC",1355,0) set cpLabel=$piece(cpS,"+",1) "RTN","TMGMISC",1356,0) "RTN","TMGMISC",1357,0) if $data(@pArray@(cpRoutine))=0 do "RTN","TMGMISC",1358,0) . new p2Array set p2Array=$name(@pArray@(cpRoutine)) "RTN","TMGMISC",1359,0) . do ScanMod(cpRoutine,p2Array) "RTN","TMGMISC",1360,0) "RTN","TMGMISC",1361,0) new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel)) "RTN","TMGMISC",1362,0) if cpIdx=0 goto CPDone "RTN","TMGMISC",1363,0) new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") "RTN","TMGMISC",1364,0) set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine "RTN","TMGMISC",1365,0) "RTN","TMGMISC",1366,0) CPDone "RTN","TMGMISC",1367,0) quit cpResult "RTN","TMGMISC",1368,0) "RTN","TMGMISC",1369,0) "RTN","TMGMISC",1370,0) "RTN","TMGMISC",1371,0) "RTN","TMGMISC",1372,0) CompArray(pArray1,pArray2) "RTN","TMGMISC",1373,0) ;"Purpose: To return if two arrays are identical "RTN","TMGMISC",1374,0) ;" Equality means that all nodes and values are present and equal "RTN","TMGMISC",1375,0) ;"Input: Array1 -- PASS BY NAME. The *name of* the first array to be compared "RTN","TMGMISC",1376,0) ;" Array1 -- PASS BY NAME. The *name of* the second array to be compared "RTN","TMGMISC",1377,0) ;"Output: 1 if two are identical, 0 if not "RTN","TMGMISC",1378,0) "RTN","TMGMISC",1379,0) new result set result=1 "RTN","TMGMISC",1380,0) new index1,index2 "RTN","TMGMISC",1381,0) set index1=$order(@pArray1@("")) "RTN","TMGMISC",1382,0) set index2=$order(@pArray2@("")) "RTN","TMGMISC",1383,0) if (index1="")!(index2="") set result=0 goto CADone "RTN","TMGMISC",1384,0) for do quit:(result=0)!(index1="")!(index2="") "RTN","TMGMISC",1385,0) . if index2'=index2 set result=0 quit "RTN","TMGMISC",1386,0) . if $get(@pArray1@(index1))'=$get(@pArray2@(index2)) set result=0 quit "RTN","TMGMISC",1387,0) . if ($data(@pArray1@(index1))'<10)!($data(@pArray2@(index2))'<10) do "RTN","TMGMISC",1388,0) . . set result=$$CompArray($name(@pArray1@(index1)),$name(@pArray2@(index2))) "RTN","TMGMISC",1389,0) . set index1=$order(@pArray1@(index1)) "RTN","TMGMISC",1390,0) . set index2=$order(@pArray2@(index2)) "RTN","TMGMISC",1391,0) "RTN","TMGMISC",1392,0) CADone quit result "RTN","TMGMISC",1393,0) "RTN","TMGMISC",1394,0) "RTN","TMGMISC",1395,0) "RTN","TMGMISC",1396,0) IterTemplate(Template,Prior) "RTN","TMGMISC",1397,0) ;"Purpose: To iterate through a SORT TEMPLATE (i.e. provide record numbers held in the template "RTN","TMGMISC",1398,0) ;" one at a time. For each time this function is called, one record number (IEN) is returned. "RTN","TMGMISC",1399,0) ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) "RTN","TMGMISC",1400,0) ;" Prior -- OPTIONAL (default is to return first record), an IEN as returned from this "RTN","TMGMISC",1401,0) ;" function during the last call. "RTN","TMGMISC",1402,0) ;"Result: Returns the next record found in list, occuring after Prior, or -1 if error or not found "RTN","TMGMISC",1403,0) ;" Returns "" if end of list (no next record) "RTN","TMGMISC",1404,0) "RTN","TMGMISC",1405,0) ;"Example of use: This will list all records held in SORT TEMPLATE record# 809 "RTN","TMGMISC",1406,0) ;" set IEN="" "RTN","TMGMISC",1407,0) ;" for s IEN=$$IterTemplate^TMGMISC(809,IEN) w IEN,! q:(+IEN'>0) "RTN","TMGMISC",1408,0) "RTN","TMGMISC",1409,0) set Prior=$get(Prior) "RTN","TMGMISC",1410,0) set result=-1 "RTN","TMGMISC",1411,0) if +$get(Template)'>0 goto ItTDone "RTN","TMGMISC",1412,0) "RTN","TMGMISC",1413,0) set result=$order(^DIBT(Template,1,Prior)) "RTN","TMGMISC",1414,0) "RTN","TMGMISC",1415,0) ItTDone quit result "RTN","TMGMISC",1416,0) "RTN","TMGMISC",1417,0) CtTemplate(Template) "RTN","TMGMISC",1418,0) ;"Purpose: To return the Count of IEN's stored in a SORT TEMPLATE "RTN","TMGMISC",1419,0) ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) "RTN","TMGMISC",1420,0) ;"Result: Returns the count of records held "RTN","TMGMISC",1421,0) "RTN","TMGMISC",1422,0) new name set name=$name(^DIBT(Template,1)) "RTN","TMGMISC",1423,0) quit $$ListCt(name) "RTN","TMGMISC",1424,0) "RTN","TMGMISC",1425,0) "RTN","TMGMISC",1426,0) NumPieces(s,delim,maxPoss) "RTN","TMGMISC",1427,0) ;"Purpose: to return the number of pieces in s, using delim as a delimiter "RTN","TMGMISC",1428,0) ;"Input: s -- the string to test "RTN","TMGMISC",1429,0) ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " "RTN","TMGMISC",1430,0) ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 "RTN","TMGMISC",1431,0) ;" the function counts DOWN from this number, so if s has more than default, must specify "RTN","TMGMISC",1432,0) ;"Result: Returns the number of pieces "RTN","TMGMISC",1433,0) ;" e.g. 'this is a test', space delimiter --> returns 4 "RTN","TMGMISC",1434,0) ;"Note: ("this is a test",";") --> 1 "RTN","TMGMISC",1435,0) ;" ("",";") --> 0 "RTN","TMGMISC",1436,0) "RTN","TMGMISC",1437,0) ;"NOTICE!!! "RTN","TMGMISC",1438,0) ;"After writing this function, I was told that $length(s,delim) will do this. "RTN","TMGMISC",1439,0) ;" I will leave this here as a reminder, but it probably shouldn't be used.... "RTN","TMGMISC",1440,0) quit $length(s,$get(delim," ")) "RTN","TMGMISC",1441,0) "RTN","TMGMISC",1442,0) "RTN","TMGMISC",1443,0) new i,result set result=0 "RTN","TMGMISC",1444,0) if $get(s)="" goto NPsDone "RTN","TMGMISC",1445,0) set delim=$get(delim," ") "RTN","TMGMISC",1446,0) set maxPoss=+$get(maxPoss,32) "RTN","TMGMISC",1447,0) "RTN","TMGMISC",1448,0) for result=maxPoss:-1:1 quit:($piece(s,delim,result)'="") "RTN","TMGMISC",1449,0) "RTN","TMGMISC",1450,0) quit result "RTN","TMGMISC",1451,0) "RTN","TMGMISC",1452,0) LastPiece(s,delim,maxPoss) "RTN","TMGMISC",1453,0) ;"Purpose: to return the last piece of a string "RTN","TMGMISC",1454,0) ;"Input: s -- the string to use "RTN","TMGMISC",1455,0) ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " "RTN","TMGMISC",1456,0) ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) "RTN","TMGMISC",1457,0) ;"Results : returns the LAST piece in the string "RTN","TMGMISC",1458,0) "RTN","TMGMISC",1459,0) new result set result="" "RTN","TMGMISC",1460,0) if $get(s)="" goto LPDone "RTN","TMGMISC",1461,0) set delim=$get(delim," ") "RTN","TMGMISC",1462,0) new n "RTN","TMGMISC",1463,0) set n=$length(s,delim) "RTN","TMGMISC",1464,0) set result=$piece(s,delim,n) "RTN","TMGMISC",1465,0) "RTN","TMGMISC",1466,0) LPDone "RTN","TMGMISC",1467,0) quit result "RTN","TMGMISC",1468,0) "RTN","TMGMISC",1469,0) ParseLast(s,remainS,delim,maxPoss) "RTN","TMGMISC",1470,0) ;"Purpose: to return the last piece of a string, AND return the first part of the string in remainS "RTN","TMGMISC",1471,0) ;"Input: s -- the string to use "RTN","TMGMISC",1472,0) ;" remainS -- an OUT parameter. PASS BY REFERENCE. Returns the part of the string up to result "RTN","TMGMISC",1473,0) ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " "RTN","TMGMISC",1474,0) ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) "RTN","TMGMISC",1475,0) ;"Results : returns the LAST piece in the string "RTN","TMGMISC",1476,0) "RTN","TMGMISC",1477,0) new result set result="" "RTN","TMGMISC",1478,0) new tempS set tempS=s ;"in case s passed by reference, and remainS=s (i.e. w $$ParseLast(s,.s) "RTN","TMGMISC",1479,0) set remainS="" "RTN","TMGMISC",1480,0) set delim=$get(delim," ") "RTN","TMGMISC",1481,0) "RTN","TMGMISC",1482,0) if $get(tempS)="" goto PLDone "RTN","TMGMISC",1483,0) new n "RTN","TMGMISC",1484,0) set n=$length(s,delim) "RTN","TMGMISC",1485,0) set result=$piece(tempS,delim,n) "RTN","TMGMISC",1486,0) if n>1 set remainS=$piece(tempS,delim,1,n-1) "RTN","TMGMISC",1487,0) "RTN","TMGMISC",1488,0) PLDone "RTN","TMGMISC",1489,0) quit result "RTN","TMGMISC",1490,0) "RTN","TMGMISC",1491,0) "RTN","TMGMISC",1492,0) "RTN","TMGMISC",1493,0) NPsDone "RTN","TMGMISC",1494,0) quit result "RTN","TMGMISC",1495,0) "RTN","TMGMISC",1496,0) "RTN","TMGMISC",1497,0) Trim1Node(pRef) "RTN","TMGMISC",1498,0) ;"Purpose: To shorten a reference by one node. "RTN","TMGMISC",1499,0) ;" e.g. "Array(567,2342,123)" --> "Array(567,2342)" "RTN","TMGMISC",1500,0) ;"Input: pRef -- the NAME OF an array. "RTN","TMGMISC",1501,0) ;"Result: will return shortened reference, or "" if problem "RTN","TMGMISC",1502,0) ;" If no nodes to trim, just array name will be returnes. "RTN","TMGMISC",1503,0) "RTN","TMGMISC",1504,0) new result set result=pRef "RTN","TMGMISC",1505,0) if pRef="" goto T1NDone "RTN","TMGMISC",1506,0) "RTN","TMGMISC",1507,0) if $qlength(pRef)>0 set result=$name(@pRef,$qlength(pRef)-1) "RTN","TMGMISC",1508,0) goto T1NDone "RTN","TMGMISC",1509,0) "RTN","TMGMISC",1510,0) ;"Below is an old way I came up with (not as effecient!) "RTN","TMGMISC",1511,0) ;"NOT USED. "RTN","TMGMISC",1512,0) set result=$qsubscript(pRef,0) "RTN","TMGMISC",1513,0) "RTN","TMGMISC",1514,0) new numNodes,i "RTN","TMGMISC",1515,0) set numNodes=$qlength(pRef) "RTN","TMGMISC",1516,0) for i=1:1:(numNodes-1) do "RTN","TMGMISC",1517,0) . new node set node=$qsubscript(pRef,i) "RTN","TMGMISC",1518,0) . set result=$name(@result@(node)) "RTN","TMGMISC",1519,0) "RTN","TMGMISC",1520,0) T1NDone "RTN","TMGMISC",1521,0) quit result "RTN","TMGMISC",1522,0) "RTN","TMGMISC",1523,0) "RTN","TMGMISC",1524,0) BROWSEASK "RTN","TMGMISC",1525,0) ;"Purpose: to ask user for the name of an array, then display nodes "RTN","TMGMISC",1526,0) "RTN","TMGMISC",1527,0) new current "RTN","TMGMISC",1528,0) new order set order=1 ;"default = forward display. "RTN","TMGMISC",1529,0) new paginate set paginate=0 ;"no pagination "RTN","TMGMISC",1530,0) new countNodes set countNodes=0 ;"no counting "RTN","TMGMISC",1531,0) write ! "RTN","TMGMISC",1532,0) read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! "RTN","TMGMISC",1533,0) if +current=current do "RTN","TMGMISC",1534,0) . set current=$get(^DIC(+current,0,"GL")) "RTN","TMGMISC",1535,0) . if current="" write "File number not found. Quitting.",! quit "RTN","TMGMISC",1536,0) . write "Browsing array: ",current,! "RTN","TMGMISC",1537,0) if current="" set current="^" "RTN","TMGMISC",1538,0) if current="^" goto BADone "RTN","TMGMISC",1539,0) "RTN","TMGMISC",1540,0) new % set %=2 ;" default= NO "RTN","TMGMISC",1541,0) write "Display in REVERSE order? " "RTN","TMGMISC",1542,0) do YN^DICN write ! "RTN","TMGMISC",1543,0) if %=1 set order=-1 "RTN","TMGMISC",1544,0) if %=-1 goto BADone "RTN","TMGMISC",1545,0) "RTN","TMGMISC",1546,0) set %=2 "RTN","TMGMISC",1547,0) write "Pause after each page? " "RTN","TMGMISC",1548,0) do YN^DICN write ! "RTN","TMGMISC",1549,0) if %=1 set paginate=1 "RTN","TMGMISC",1550,0) if %=-1 goto BADone "RTN","TMGMISC",1551,0) "RTN","TMGMISC",1552,0) set %=2 "RTN","TMGMISC",1553,0) write "Show number of subnodes? " "RTN","TMGMISC",1554,0) do YN^DICN write ! "RTN","TMGMISC",1555,0) if %=1 set countNodes=1 "RTN","TMGMISC",1556,0) if %=-1 goto BADone "RTN","TMGMISC",1557,0) "RTN","TMGMISC",1558,0) do BROWSENODES(current,order,paginate,countNodes) "RTN","TMGMISC",1559,0) BADone "RTN","TMGMISC",1560,0) quit "RTN","TMGMISC",1561,0) "RTN","TMGMISC",1562,0) "RTN","TMGMISC",1563,0) BROWSENODES(current,Order,paginate,countNodes) "RTN","TMGMISC",1564,0) ;"Purpose: to display nodes of specified array "RTN","TMGMISC",1565,0) ;"Input: Current -- The reference to display "RTN","TMGMISC",1566,0) ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order "RTN","TMGMISC",1567,0) ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page "RTN","TMGMISC",1568,0) ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. "RTN","TMGMISC",1569,0) "RTN","TMGMISC",1570,0) new parent,child "RTN","TMGMISC",1571,0) set parent="" "RTN","TMGMISC",1572,0) set order=$get(order,1) "RTN","TMGMISC",1573,0) set paginate=$get(paginate,0) "RTN","TMGMISC",1574,0) set countNodes=$get(countNodes,0) "RTN","TMGMISC",1575,0) "RTN","TMGMISC",1576,0) new len set len=$length(current) "RTN","TMGMISC",1577,0) new lastChar set lastChar=$extract(current,len) "RTN","TMGMISC",1578,0) if lastChar'=")" do "RTN","TMGMISC",1579,0) . if current'["(" quit "RTN","TMGMISC",1580,0) . if lastChar="," set current=$extract(current,1,len-1) "RTN","TMGMISC",1581,0) . if lastChar="(" set current=$extract(current,1,len-1) quit "RTN","TMGMISC",1582,0) . set current=current_")" "RTN","TMGMISC",1583,0) "RTN","TMGMISC",1584,0) BNLoop "RTN","TMGMISC",1585,0) if current="" goto BNDone "RTN","TMGMISC",1586,0) set child=$$ShowNodes(current,order,paginate,countNodes) "RTN","TMGMISC",1587,0) if child'="" do "RTN","TMGMISC",1588,0) . set parent(child)=current "RTN","TMGMISC",1589,0) . set current=child "RTN","TMGMISC",1590,0) else set current=$get(parent(current)) "RTN","TMGMISC",1591,0) goto BNLoop "RTN","TMGMISC",1592,0) BNDone "RTN","TMGMISC",1593,0) quit "RTN","TMGMISC",1594,0) "RTN","TMGMISC",1595,0) "RTN","TMGMISC",1596,0) ShowNodes(pArray,order,paginate,countNodes) "RTN","TMGMISC",1597,0) ;"Purpose: To display all the nodes of the given array "RTN","TMGMISC",1598,0) ;"Input: pArray -- NAME OF array to display "RTN","TMGMISC",1599,0) ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order "RTN","TMGMISC",1600,0) ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page "RTN","TMGMISC",1601,0) ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. "RTN","TMGMISC",1602,0) ;"Results: returns NAME OF next node to display (or "" if none) "RTN","TMGMISC",1603,0) "RTN","TMGMISC",1604,0) new TMGi "RTN","TMGMISC",1605,0) new count set count=1 "RTN","TMGMISC",1606,0) new Answers "RTN","TMGMISC",1607,0) new someShown set someShown=0 "RTN","TMGMISC",1608,0) new abort set abort=0 "RTN","TMGMISC",1609,0) set paginate=$get(paginate,0) "RTN","TMGMISC",1610,0) new pageCount set pageCount=0 "RTN","TMGMISC",1611,0) new pageLen set pageLen=20 "RTN","TMGMISC",1612,0) set countNodes=$get(countNodes,0) "RTN","TMGMISC",1613,0) "RTN","TMGMISC",1614,0) write pArray,! "RTN","TMGMISC",1615,0) set TMGi=$order(@pArray@(""),order) "RTN","TMGMISC",1616,0) if TMGi'="" for do quit:(TMGi="")!(abort=1) "RTN","TMGMISC",1617,0) . write count,". +--[",TMGi,"]" "RTN","TMGMISC",1618,0) . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")" "RTN","TMGMISC",1619,0) . write "=",$extract($get(@pArray@(TMGi)),1,40),! "RTN","TMGMISC",1620,0) . set someShown=1 "RTN","TMGMISC",1621,0) . set Answers(count)=$name(@pArray@(TMGi)) "RTN","TMGMISC",1622,0) . set count=count+1 "RTN","TMGMISC",1623,0) . new temp read *temp:0 "RTN","TMGMISC",1624,0) . if temp'=-1 set abort=1 "RTN","TMGMISC",1625,0) . set pageCount=pageCount+1 "RTN","TMGMISC",1626,0) . if (paginate=1)&(pageCount>pageLen) do "RTN","TMGMISC",1627,0) . . new temp "RTN","TMGMISC",1628,0) . . read "Press [ENTER] to continue (^ to stop list)...",temp:$get(DTIME,3600),! "RTN","TMGMISC",1629,0) . . if temp="^" set abort=1 "RTN","TMGMISC",1630,0) . . set pageCount=0 "RTN","TMGMISC",1631,0) . set TMGi=$order(@pArray@(TMGi),order) "RTN","TMGMISC",1632,0) "RTN","TMGMISC",1633,0) if someShown=0 write " (no data)",! "RTN","TMGMISC",1634,0) write !,"Enter # to browse (^ to backup): ^//" "RTN","TMGMISC",1635,0) new temp read temp:$get(DTIME,3600),! "RTN","TMGMISC",1636,0) "RTN","TMGMISC",1637,0) new result set result=$get(Answers(temp)) "RTN","TMGMISC",1638,0) "RTN","TMGMISC",1639,0) quit result "RTN","TMGMISC",1640,0) "RTN","TMGMISC",1641,0) "RTN","TMGMISC",1642,0) IsNumeric(value) "RTN","TMGMISC",1643,0) ;"Purpose: to determine if value is pure numeric. "RTN","TMGMISC",1644,0) ;"Note: This will be a more involved test than simply: if +value=value, because "RTN","TMGMISC",1645,0) ;" +"00001" is not the same as "1" or 1. Also +"123abc"--> 123, but is not pure numeric "RTN","TMGMISC",1646,0) set value=$$Trim^TMGSTUTL(value) ;" trim whitespace "RTN","TMGMISC",1647,0) set value=$$TrimL^TMGSTUTL(value,"0") ;"trim leading zeros "RTN","TMGMISC",1648,0) quit (value=+value) "RTN","TMGMISC",1649,0) "RTN","TMGMISC",1650,0) "RTN","TMGMISC",1651,0) ClipDDigits(Num,digits) "RTN","TMGMISC",1652,0) ;"Purpose: to clip number to specified number of decimal digits "RTN","TMGMISC",1653,0) ;" e.g. 1234.9876543 --> 1234.9876 if digits=4 "RTN","TMGMISC",1654,0) ;"Input: Num -- the number to process "RTN","TMGMISC",1655,0) ;" digits -- the number of allowed decimal digits after the decimal point "RTN","TMGMISC",1656,0) ;"Result: returns the number clipped to the specified number of decimals "RTN","TMGMISC",1657,0) ;" note: this is a CLIP, not a ROUND function "RTN","TMGMISC",1658,0) "RTN","TMGMISC",1659,0) new result set result=Num "RTN","TMGMISC",1660,0) new decimals set decimals=$extract($piece(Num,".",2),1,digits) "RTN","TMGMISC",1661,0) set result=$piece(Num,".",1) "RTN","TMGMISC",1662,0) if decimals'="" set result=result_"."_decimals "RTN","TMGMISC",1663,0) CDgDone "RTN","TMGMISC",1664,0) quit result "RTN","TMGMISC",1665,0) "RTN","TMGMISC",1666,0) "RTN","TMGMISC",1667,0) Diff(File,IENS1,IENS2,Result) "RTN","TMGMISC",1668,0) ;"Purpose: to determine how two records differ in a given file "RTN","TMGMISC",1669,0) ;"Input: File -- file name or number of file containing records to be compared "RTN","TMGMISC",1670,0) ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared "RTN","TMGMISC",1671,0) ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared "RTN","TMGMISC",1672,0) ;" Result -- PASS BE REFERENCE, and OUT PARAMETER "RTN","TMGMISC",1673,0) ;" Format of output Result array. Will only hold differences "RTN","TMGMISC",1674,0) ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField "RTN","TMGMISC",1675,0) ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField "RTN","TMGMISC",1676,0) ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField "RTN","TMGMISC",1677,0) ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField "RTN","TMGMISC",1678,0) ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName "RTN","TMGMISC",1679,0) ;"Note: this will consider only the first 1024 characters of WP fields "RTN","TMGMISC",1680,0) ;"Note: For now, multiples (subfiles) will be IGNORED "RTN","TMGMISC",1681,0) "RTN","TMGMISC",1682,0) new fileNum set fileNum=+$get(File) "RTN","TMGMISC",1683,0) if fileNum=0 set fileNum=$$GetFileNum^TMGDBAPI(.File) "RTN","TMGMISC",1684,0) new subFileNum "RTN","TMGMISC",1685,0) "RTN","TMGMISC",1686,0) new field set field=$order(^DD(fileNum,0)) "RTN","TMGMISC",1687,0) if +field>0 for do quit:(+field'>0) "RTN","TMGMISC",1688,0) . set subFileNum=+$piece($get(^DD(fileNum,field,0)),"^",2) ;"get subfile number, or 0 if not subfile "RTN","TMGMISC",1689,0) . if subFileNum>0 do ;"finish later... "RTN","TMGMISC",1690,0) . . ;"Here I need to somehow cycle through each record of the subfile and compare THOSE "RTN","TMGMISC",1691,0) . . new subResult "RTN","TMGMISC",1692,0) . . do DiffSubFile(subFileNum,.IENS1,.IENS2,.subResult) ;"null function for now "RTN","TMGMISC",1693,0) . . ;"do some merge between Result and subResult "RTN","TMGMISC",1694,0) . else do Diff1Field(fileNum,field,.IENS1,.IENS2,.Result) "RTN","TMGMISC",1695,0) . set field=$order(^DD(fileNum,field)) "RTN","TMGMISC",1696,0) "RTN","TMGMISC",1697,0) quit "RTN","TMGMISC",1698,0) "RTN","TMGMISC",1699,0) "RTN","TMGMISC",1700,0) Diff1Field(File,Field,IENS1,IEN2,Result) "RTN","TMGMISC",1701,0) ;"Purpose: to determine how two records differ for one given field "RTN","TMGMISC",1702,0) ;"Input: File -- file NUMBER of file containing records to be compared "RTN","TMGMISC",1703,0) ;" Field -- Field NUMBER to be evaluated "RTN","TMGMISC",1704,0) ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared "RTN","TMGMISC",1705,0) ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared "RTN","TMGMISC",1706,0) ;" Result -- PASS BE REFERENCE, and OUT PARAMETER "RTN","TMGMISC",1707,0) ;" Format of output Result array. Will only hold differences "RTN","TMGMISC",1708,0) ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField "RTN","TMGMISC",1709,0) ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField "RTN","TMGMISC",1710,0) ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField "RTN","TMGMISC",1711,0) ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField "RTN","TMGMISC",1712,0) ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName "RTN","TMGMISC",1713,0) ;"Results: none (data returned in Result out parameter) "RTN","TMGMISC",1714,0) ;"Note: only first 1023 characters of a WP field will be compared "RTN","TMGMISC",1715,0) "RTN","TMGMISC",1716,0) new value1,value2,TMGWP1,TMGWP2 "RTN","TMGMISC",1717,0) new fieldName set fieldName=$piece($get(^DD(File,Field,0)),"^",1) "RTN","TMGMISC",1718,0) "RTN","TMGMISC",1719,0) set value1=$$GET1^DIQ(File,IENS1,Field,"","TMGWP1") "RTN","TMGMISC",1720,0) set value2=$$GET1^DIQ(File,IENS2,Field,"","TMGWP2") "RTN","TMGMISC",1721,0) "RTN","TMGMISC",1722,0) if $data(TMGWP1)!$data(TMGWP2) do "RTN","TMGMISC",1723,0) . set value1=$$WPToStr^TMGSTUTL("TMGWP1"," ",1023) ;"Turn first 1023 characters into one long string "RTN","TMGMISC",1724,0) . set value2=$$WPToStr^TMGSTUTL("TMGWP2"," ",1023) ;"Turn first 1023 characters into one long string "RTN","TMGMISC",1725,0) "RTN","TMGMISC",1726,0) if value1=value2 goto D1FDone ;"default is no conflict "RTN","TMGMISC",1727,0) if (value2="")&(value1'="") do "RTN","TMGMISC",1728,0) . set Result(Field,"EXTRA",1)=value1 "RTN","TMGMISC",1729,0) . set Result(Field,"FIELD NAME")=fieldName "RTN","TMGMISC",1730,0) if (value1="")&(value2'="") do "RTN","TMGMISC",1731,0) . set Result(Field,"EXTRA",2)=value2 "RTN","TMGMISC",1732,0) . set Result(Field,"FIELD NAME")=fieldName "RTN","TMGMISC",1733,0) if (value1'="")&(value2'="") do "RTN","TMGMISC",1734,0) . set Result(Field,"CONFLICT",1)=value1 "RTN","TMGMISC",1735,0) . set Result(Field,"CONFLICT",2)=value2 "RTN","TMGMISC",1736,0) . set Result(Field,"FIELD NAME")=fieldName "RTN","TMGMISC",1737,0) "RTN","TMGMISC",1738,0) D1FDone "RTN","TMGMISC",1739,0) quit "RTN","TMGMISC",1740,0) "RTN","TMGMISC",1741,0) DiffSubFile(SubFile,IENS1,IENS2,Result) "RTN","TMGMISC",1742,0) "RTN","TMGMISC",1743,0) quit "RTN","TMGMISC",1744,0) "RTN","TMGMISC",1745,0) "RTN","TMGMISC",1746,0) "RTN","TMGMISC",1747,0) Array2XML(pArray,pResult,indent) "RTN","TMGMISC",1748,0) ;"Purpose: to convert an array into XML format "RTN","TMGMISC",1749,0) ;"Input: pArray -- the NAME OF the array to convert (array can be any format) "RTN","TMGMISC",1750,0) ;" pResult -- the NAME OF the output array. "RTN","TMGMISC",1751,0) ;" format: "RTN","TMGMISC",1752,0) ;" Result(0)="" "RTN","TMGMISC",1753,0) ;" Result(1)="Node Value "RTN","TMGMISC",1754,0) ;" Result(2)=" Node Value "RTN","TMGMISC",1755,0) ;" Result(3)=" Node Value "RTN","TMGMISC",1756,0) ;" Result(4)=" Node Value ;"<--- start subnode "RTN","TMGMISC",1757,0) ;" Result(5)=" Node Value "RTN","TMGMISC",1758,0) ;" Result(6)=" Node Value "RTN","TMGMISC",1759,0) ;" Result(7)=" ;"<---- end subnode "RTN","TMGMISC",1760,0) ;" Result(8)=" Node Value "RTN","TMGMISC",1761,0) ;" indent -- OPTIONAL. if 1, then subnodes have whitespace indent for pretty viewing "RTN","TMGMISC",1762,0) ;"Output: pResult is filled "RTN","TMGMISC",1763,0) ;"Result: none. "RTN","TMGMISC",1764,0) ;"Note: example call do Array2XML("MyArray","MyOutput",1) "RTN","TMGMISC",1765,0) "RTN","TMGMISC",1766,0) kill @pResult "RTN","TMGMISC",1767,0) set @pResult@(0)=0 "RTN","TMGMISC",1768,0) if $get(indent)=1 set indent="" "RTN","TMGMISC",1769,0) else set indent=-1 "RTN","TMGMISC",1770,0) do A2XNode(pArray,pResult,.indent) "RTN","TMGMISC",1771,0) set @pResult@(0)=$$XMLHDR^MXMLUTL "RTN","TMGMISC",1772,0) "RTN","TMGMISC",1773,0) quit "RTN","TMGMISC",1774,0) "RTN","TMGMISC",1775,0) "RTN","TMGMISC",1776,0) A2XNode(pArray,pResult,indent) "RTN","TMGMISC",1777,0) ;"Purpose: To do the output for Array2XML "RTN","TMGMISC",1778,0) ;"Input: pArray - the NAME OF the array to convert "RTN","TMGMISC",1779,0) ;" pResult - the NAME OF the output array. "RTN","TMGMISC",1780,0) ;" Format to be as described in Array2XML, which one exception: Result(0)=MaxLine "RTN","TMGMISC",1781,0) ;" indent -- OPTIONAL. if numeric value, then subnodes WON't whitespace indent for pretty viewing "RTN","TMGMISC",1782,0) ;" otherwise, indent is string holding space to indent "RTN","TMGMISC",1783,0) ;"Result: none "RTN","TMGMISC",1784,0) "RTN","TMGMISC",1785,0) new i,s "RTN","TMGMISC",1786,0) set indent=$get(indent) "RTN","TMGMISC",1787,0) set i=$order(@pArray@("")) "RTN","TMGMISC",1788,0) if i'="" for do quit:(i="") "RTN","TMGMISC",1789,0) . set s="" if indent'=-1 set s=indent "RTN","TMGMISC",1790,0) . set s=s_""_$get(@pArray@(i)) "RTN","TMGMISC",1791,0) . set s=$$SYMENC^MXMLUTL(s) "RTN","TMGMISC",1792,0) . if $data(@pArray@(i))>1 do "RTN","TMGMISC",1793,0) . . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline "RTN","TMGMISC",1794,0) . . set @pResult@(@pResult@(0))=s "RTN","TMGMISC",1795,0) . . new subIndent set subIndent=-1 "RTN","TMGMISC",1796,0) . . if indent'=-1 set subIndent=indent_" " "RTN","TMGMISC",1797,0) . . do A2XNode($name(@pArray@(i)),pResult,subIndent) "RTN","TMGMISC",1798,0) . . set s="" if indent'=-1 set s=indent "RTN","TMGMISC",1799,0) . . set s=s_"" "RTN","TMGMISC",1800,0) . else do "RTN","TMGMISC",1801,0) . . set s=s_"" "RTN","TMGMISC",1802,0) . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline "RTN","TMGMISC",1803,0) . set @pResult@(@pResult@(0))=s "RTN","TMGMISC",1804,0) . set i=$order(@pArray@(i)) "RTN","TMGMISC",1805,0) "RTN","TMGMISC",1806,0) quit "RTN","TMGMISC",1807,0) "RTN","TMGMISC",1808,0) "RTN","TMGMISC",1809,0) Up(pArray) "RTN","TMGMISC",1810,0) ;"Purpose: Return a NAME of an array that is one level 'up' from the "RTN","TMGMISC",1811,0) ;" the current array. This really means one node shorter. "RTN","TMGMISC",1812,0) ;" e.g. '^MyVar('plant','tree','apple tree')' --> '^MyVar('plant','tree')' "RTN","TMGMISC",1813,0) ;"Results: returns shorten array as above, or "" if error "RTN","TMGMISC",1814,0) "RTN","TMGMISC",1815,0) new result set result="" "RTN","TMGMISC",1816,0) if $get(pArray)="" goto UpDone "RTN","TMGMISC",1817,0) set result=$qsubscript(pArray,0) "RTN","TMGMISC",1818,0) new i "RTN","TMGMISC",1819,0) for i=1:1:$qlength(pArray)-1 do "RTN","TMGMISC",1820,0) . set result=$name(@result@($qsubscript(pArray,i))) "RTN","TMGMISC",1821,0) "RTN","TMGMISC",1822,0) UpDone quit result "RTN","TMGMISC",1823,0) "RTN","TMGMISC",1824,0) "RTN","TMGMISC",1825,0) LaunchScreenman(File,FormIEN,RecIEN,Page) "RTN","TMGMISC",1826,0) ;"Purpose: to provide a programatic launching point for displaying a "RTN","TMGMISC",1827,0) ;" screenman form for editing a record "RTN","TMGMISC",1828,0) ;"Input: File -- the IEN of file to be edited "RTN","TMGMISC",1829,0) ;" FormIEN -- the IEN in file FORM (.403) "RTN","TMGMISC",1830,0) ;" RecIEN -- the IEN in File to edit "RTN","TMGMISC",1831,0) ;" Page -- OPTIONAL, default=1. The starting page of form. "RTN","TMGMISC",1832,0) ;"Note: Form should be compiled before calling the function. This can be "RTN","TMGMISC",1833,0) ;" achieved by running the form once from ^DDSRUN (or viat Fileman menu) "RTN","TMGMISC",1834,0) "RTN","TMGMISC",1835,0) new DDSFILE set DDSFILE=File "RTN","TMGMISC",1836,0) new DDSRUNDR set DDSRUNDR=FormIEN "RTN","TMGMISC",1837,0) new DDSPAGE set DDSPAGE=+$get(Page,1) "RTN","TMGMISC",1838,0) new DA set DA=RecIEN "RTN","TMGMISC",1839,0) "RTN","TMGMISC",1840,0) do REC+9^DDSRUN ;"this goes against SAC conventions. "RTN","TMGMISC",1841,0) "RTN","TMGMISC",1842,0) quit "RTN","TMGMISC",1843,0) "RTN","TMGMISC",1844,0) "RTN","TMGMISC",1845,0) NumSigChs() "RTN","TMGMISC",1846,0) ;"Purpose: To determine how many characters are signficant in a variable name "RTN","TMGMISC",1847,0) ;" I.e. older versions of GT.M had only the first 8 characters as "RTN","TMGMISC",1848,0) ;" significant. Newer versions allow more characters to be significant. "RTN","TMGMISC",1849,0) "RTN","TMGMISC",1850,0) new pVar1,pVar2,i "RTN","TMGMISC",1851,0) set pVar1="zb",i=2 "RTN","TMGMISC",1852,0) new done set done=0 "RTN","TMGMISC",1853,0) for do quit:done "RTN","TMGMISC",1854,0) . set i=i+1 "RTN","TMGMISC",1855,0) . set pVar2=pVar1_"b" "RTN","TMGMISC",1856,0) . set pVar1=pVar1_"a" "RTN","TMGMISC",1857,0) . set @pVar1=7 "RTN","TMGMISC",1858,0) . if $get(@pVar2)=@pVar1 set done=1 "RTN","TMGMISC",1859,0) "RTN","TMGMISC",1860,0) quit (i-1) "RTN","TMGMISC",1861,0) "RTN","TMGMISC",1862,0) "RTN","TMGMISC",1863,0) SrchReplace(File,Field,Caption) "RTN","TMGMISC",1864,0) ;"Purpose: To do a text-based search and replace in all record of "RTN","TMGMISC",1865,0) ;" specified file, in the text of the specified file. "RTN","TMGMISC",1866,0) ;" Note: this does not work with pointer fields. It would "RTN","TMGMISC",1867,0) ;" fail to find the matching text in the pointer value and ignore it. "RTN","TMGMISC",1868,0) ;" It does not support subfiles. "RTN","TMGMISC",1869,0) ;"Input: File -- the file name or number to work with. "RTN","TMGMISC",1870,0) ;" Field -- the field name or number to work with "RTN","TMGMISC",1871,0) ;" Caption -- OPTIONAL. A descriptive text of action. "RTN","TMGMISC",1872,0) ;"Output: Data in records will be changed via Fileman and errors (if found) "RTN","TMGMISC",1873,0) ;" will be written to console. "RTN","TMGMISC",1874,0) ;"Results: none. "RTN","TMGMISC",1875,0) "RTN","TMGMISC",1876,0) if $get(File)="" goto SRDone "RTN","TMGMISC",1877,0) if $get(Field)="" goto SRDone "RTN","TMGMISC",1878,0) new OKToCont set OKToCont=1 "RTN","TMGMISC",1879,0) if +Field'=Field set OKToCont=$$SetFileFldNums^TMGDBAPI(File,Field,.File,.Field) "RTN","TMGMISC",1880,0) if OKToCont=0 goto SRDone "RTN","TMGMISC",1881,0) "RTN","TMGMISC",1882,0) if $get(Caption)'="" do "RTN","TMGMISC",1883,0) . write !,!,Caption,! "RTN","TMGMISC",1884,0) . write "----------------------------------------------------",!! "RTN","TMGMISC",1885,0) "RTN","TMGMISC",1886,0) new searchS,replaceS,% "RTN","TMGMISC",1887,0) SR1 "RTN","TMGMISC",1888,0) write "Enter characters/words to SEARCH for (^ to abort): " "RTN","TMGMISC",1889,0) read searchS:$get(DTIME,3600),! "RTN","TMGMISC",1890,0) if (searchS="")!(searchS="^") goto SRDone "RTN","TMGMISC",1891,0) write "REPLACE with (^ to abort): " "RTN","TMGMISC",1892,0) read replaceS:$get(DTIME,3600),! "RTN","TMGMISC",1893,0) if (replaceS="^") goto SRDone "RTN","TMGMISC",1894,0) write "'",searchS,"'-->'",replaceS,"'",! "RTN","TMGMISC",1895,0) set %=1 "RTN","TMGMISC",1896,0) write "OK" do YN^DICN write ! "RTN","TMGMISC",1897,0) if %=1 goto SR2 "RTN","TMGMISC",1898,0) if %=-1 goto SRDone "RTN","TMGMISC",1899,0) goto SR1 "RTN","TMGMISC",1900,0) "RTN","TMGMISC",1901,0) SR2 "RTN","TMGMISC",1902,0) new Itr,IEN,CurValue,abort,count "RTN","TMGMISC",1903,0) new ref set ref=$get(^DIC(File,0,"GL")) "RTN","TMGMISC",1904,0) set ref=$$CREF^DILF(ref) "RTN","TMGMISC",1905,0) if ref="" goto SRDone "RTN","TMGMISC",1906,0) new node set node=$piece($get(^DD(File,Field,0)),"^",4) "RTN","TMGMISC",1907,0) new piece set piece=$piece(node,";",2) "RTN","TMGMISC",1908,0) set node=$piece(node,";",1) "RTN","TMGMISC",1909,0) "RTN","TMGMISC",1910,0) set abort=0,count=0 "RTN","TMGMISC",1911,0) set IEN=$$ItrInit^TMGITR(File,.Itr) "RTN","TMGMISC",1912,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGMISC",1913,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGMISC",1914,0) . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGMISC",1915,0) . set CurValue=$piece($get(@ref@(IEN,node)),"^",piece) "RTN","TMGMISC",1916,0) . if CurValue'[searchS quit "RTN","TMGMISC",1917,0) SR3 . new newValue set newValue=$$Substitute^TMGSTUTL(CurValue,searchS,replaceS) "RTN","TMGMISC",1918,0) . new TMGFDA,TMGMSG "RTN","TMGMISC",1919,0) . set TMGFDA(File,IEN_",",Field)=newValue "RTN","TMGMISC",1920,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGMISC",1921,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGMISC",1922,0) . set count=count+1 "RTN","TMGMISC",1923,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGMISC",1924,0) "RTN","TMGMISC",1925,0) write count," records changed",! "RTN","TMGMISC",1926,0) do PressToCont^TMGUSRIF "RTN","TMGMISC",1927,0) "RTN","TMGMISC",1928,0) SRDone "RTN","TMGMISC",1929,0) quit "RTN","TMGMISC",1930,0) "RTN","TMGMISC",1931,0) "RTN","TMGMISC",1932,0) MkMultList(input,List) "RTN","TMGMISC",1933,0) ;"Purpose: To create a list of entries, given a string containing a list of entries. "RTN","TMGMISC",1934,0) ;"Input: input -- a string of user input. E.g.: '345,3,12678,78-85,2' or '78-93' or '15' "RTN","TMGMISC",1935,0) ;" List -- PASS BY REFERENCE. An OUT PARAMETER. "RTN","TMGMISC",1936,0) ;"Output: List will be filled as follows: "RTN","TMGMISC",1937,0) ;" List(Entry number)="" "RTN","TMGMISC",1938,0) ;" List(Entry number)="" "RTN","TMGMISC",1939,0) ;" List(Entry number)="" "RTN","TMGMISC",1940,0) ;"Result: 1 if values found, 0 none found, or error encountered "RTN","TMGMISC",1941,0) "RTN","TMGMISC",1942,0) new result set result=0 "RTN","TMGMISC",1943,0) "RTN","TMGMISC",1944,0) new i "RTN","TMGMISC",1945,0) for i=1:1:$length(input,",") do "RTN","TMGMISC",1946,0) . new value set value=$piece(input,",",i) "RTN","TMGMISC",1947,0) . if +value=value do "RTN","TMGMISC",1948,0) . . set List(value)="" "RTN","TMGMISC",1949,0) . . set result=1 "RTN","TMGMISC",1950,0) . else if value["-" do "RTN","TMGMISC",1951,0) . . new n1,n2 "RTN","TMGMISC",1952,0) . . set n1=+$piece(value,"-",1) "RTN","TMGMISC",1953,0) . . set n2=+$piece(value,"-",2) "RTN","TMGMISC",1954,0) . . set result=$$MkRangeList(n1,n2,.List) "RTN","TMGMISC",1955,0) "RTN","TMGMISC",1956,0) quit result "RTN","TMGMISC",1957,0) "RTN","TMGMISC",1958,0) "RTN","TMGMISC",1959,0) MkRangeList(Num,EndNum,List) "RTN","TMGMISC",1960,0) ;"Purpose: To create a list of entries, given a starting and ending number "RTN","TMGMISC",1961,0) ;"Input: Num -- the start entry number "RTN","TMGMISC",1962,0) ;" EndNum -- OPTIONAL, the last entry number (if supplied then all values "RTN","TMGMISC",1963,0) ;" between Num and Endnum will be added to list "RTN","TMGMISC",1964,0) ;" List -- PASS BY REFERENCE. An OUT PARAMETER. "RTN","TMGMISC",1965,0) ;"Output: List will be filled as follows: "RTN","TMGMISC",1966,0) ;" List(Entry number)="" "RTN","TMGMISC",1967,0) ;" List(Entry number)="" "RTN","TMGMISC",1968,0) ;" List(Entry number)="" "RTN","TMGMISC",1969,0) ;"Result: 1 if value input found, otherwise 0 "RTN","TMGMISC",1970,0) "RTN","TMGMISC",1971,0) new result set result=0 "RTN","TMGMISC",1972,0) set EndNum=$get(EndNum,Num) "RTN","TMGMISC",1973,0) if (+Num'=Num)!(+EndNum'=EndNum) goto MkRLDone "RTN","TMGMISC",1974,0) "RTN","TMGMISC",1975,0) new i "RTN","TMGMISC",1976,0) for i=Num:1:EndNum do "RTN","TMGMISC",1977,0) . set List(i)="" "RTN","TMGMISC",1978,0) . set result=1 "RTN","TMGMISC",1979,0) "RTN","TMGMISC",1980,0) MkRLDone "RTN","TMGMISC",1981,0) quit result "RTN","TMGMISC",1982,0) "RTN","TMGMISC",1983,0) "RTN","TMGMISC",1984,0) Flags(Var,Flag,Mode) "RTN","TMGMISC",1985,0) ;"Purpose: To set,delete,or toggle a flag stored in Var "RTN","TMGMISC",1986,0) ;"Input: Var -- PASS BY REFERENCE. The variable holding the flags "RTN","TMGMISC",1987,0) ;" Flag -- a single character flag to be stored in Var "RTN","TMGMISC",1988,0) ;" Mode: should be: 'SET','DEL',or 'TOGGLE'. Default is 'SET' "RTN","TMGMISC",1989,0) ;"Results: none "RTN","TMGMISC",1990,0) "RTN","TMGMISC",1991,0) set Flag=$get(Flag,"SET") "RTN","TMGMISC",1992,0) set Var=$get(Var) "RTN","TMGMISC",1993,0) if $get(Mode)="TOGGLE" do "RTN","TMGMISC",1994,0) . if Var[Flag set Mode="DEL" "RTN","TMGMISC",1995,0) . else set Mode="SET" "RTN","TMGMISC",1996,0) if $get(Mode)="SET" do "RTN","TMGMISC",1997,0) . if Var[Flag quit "RTN","TMGMISC",1998,0) . set Var=Var_Flag "RTN","TMGMISC",1999,0) if $get(Mode)="DEL" do "RTN","TMGMISC",2000,0) . if Var'[Flag quit "RTN","TMGMISC",2001,0) . set Var=$piece(Var,Flag,1)_$piece(Var,Flag,2) "RTN","TMGMISC",2002,0) "RTN","TMGMISC",2003,0) quit "RTN","TMGMISC",2004,0) "RTN","TMGMISC",2005,0) "RTN","TMGMISC",2006,0) CompABArray(pArrayA,pArrayB,pExtraB,pMissingB,pDiff,ProgressFn,IncVar) "RTN","TMGMISC",2007,0) ;"Purpose: To compare two arrays, A & B, and return results in OutArray "RTN","TMGMISC",2008,0) ;" that specifies how ArrayB differs from ArrayA "RTN","TMGMISC",2009,0) ;"Input: pArrayA -- PASS BY NAME. Baseline array to be compared against "RTN","TMGMISC",2010,0) ;" pArrayB -- PASS BY NAME. Array to be compare against ArrayA "RTN","TMGMISC",2011,0) ;" pExtraB -- PASS BY NAME. An OUT PARAMETER. Array of extra info from B "RTN","TMGMISC",2012,0) ;" OPTIONAL. If not provided, then data not filled. "RTN","TMGMISC",2013,0) ;" pMissingB -- PASS BY NAME. An OUT PARAMETER. Array of missing info "RTN","TMGMISC",2014,0) ;" OPTIONAL. If not provided, then data not filled. "RTN","TMGMISC",2015,0) ;" pDiff -- PASS BY NAME. An OUT PARAMETER. Output as below. "RTN","TMGMISC",2016,0) ;" OPTIONAL. If not provided, then data not filled. "RTN","TMGMISC",2017,0) ;" @pOutArray@("A",node,node,node,...)=different value "RTN","TMGMISC",2018,0) ;" @pOutArray@("B",node,node,node,...)=different value "RTN","TMGMISC",2019,0) ;" ProgressFn -- OPTIONAL -- M code to exec as a progress indicator "RTN","TMGMISC",2020,0) ;" IncVar -- OPTIONAL -- a counter that can be referenced by ProgressFn "RTN","TMGMISC",2021,0) ;"Results: 0=OK, 1=aborted "RTN","TMGMISC",2022,0) "RTN","TMGMISC",2023,0) new indexA,indexB "RTN","TMGMISC",2024,0) "RTN","TMGMISC",2025,0) set IncVar=+$get(IncVar) "RTN","TMGMISC",2026,0) set ProgressFn=$get(ProgressFn) "RTN","TMGMISC",2027,0) set pExtraB=$get(pExtraB) "RTN","TMGMISC",2028,0) set pMissingB=$get(pMissingB) "RTN","TMGMISC",2029,0) set pdiff=$get(pDiff) "RTN","TMGMISC",2030,0) new abort set abort=0 "RTN","TMGMISC",2031,0) new Compared "RTN","TMGMISC",2032,0) "RTN","TMGMISC",2033,0) set indexA="" "RTN","TMGMISC",2034,0) for set indexA=$order(@pArrayA@(indexA)) quit:(indexA="")!abort do "RTN","TMGMISC",2035,0) . set IncVar=IncVar+1 "RTN","TMGMISC",2036,0) . if (IncVar#10=1),(ProgressFn'="") do quit:(abort) "RTN","TMGMISC",2037,0) . . new $etrap set $etrap="set $etrap="""",$ecode=""""" "RTN","TMGMISC",2038,0) . . xecute ProgressFn "RTN","TMGMISC",2039,0) . . write !,pArrayA,"(",indexA,") ",! do CUU^TMGTERM(2) ;"temp "RTN","TMGMISC",2040,0) . . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGMISC",2041,0) . if $data(@pArrayB@(indexA))=0 do quit "RTN","TMGMISC",2042,0) . . if (pMissingB'="") merge @pMissingB@(pArrayA,indexA)=@pArrayA@(indexA) "RTN","TMGMISC",2043,0) . new s1,s2 "RTN","TMGMISC",2044,0) . set s1=$get(@pArrayA@(indexA)) "RTN","TMGMISC",2045,0) . set s2=$get(@pArrayB@(indexA)) "RTN","TMGMISC",2046,0) . if s1'=s2 do "RTN","TMGMISC",2047,0) . . if pDiff="" quit "RTN","TMGMISC",2048,0) . . if $$TRIM^XLFSTR(s1)=$$TRIM^XLFSTR(s2) quit "RTN","TMGMISC",2049,0) . . set @pDiff@("A",pArrayA,indexA)=s1 "RTN","TMGMISC",2050,0) . . set @pDiff@("B",pArrayA,indexA)=s2 "RTN","TMGMISC",2051,0) . set abort=$$CompABArray($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)),.pExtraB,.pMissingB,.pDiff,.ProgressFn,.IncVar) "RTN","TMGMISC",2052,0) . set Compared($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)))=1 "RTN","TMGMISC",2053,0) "RTN","TMGMISC",2054,0) new temp set temp=1 "RTN","TMGMISC",2055,0) set indexB="" "RTN","TMGMISC",2056,0) for set indexB=$order(@pArrayB@(indexB)) quit:(indexB="")!abort do "RTN","TMGMISC",2057,0) . set temp=temp+1 "RTN","TMGMISC",2058,0) . if (temp#10=1) do quit:(abort) "RTN","TMGMISC",2059,0) . . write !,pArrayA,"(",indexB,") ",! do CUU^TMGTERM(2) ;"temp "RTN","TMGMISC",2060,0) . . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGMISC",2061,0) . if $data(@pArrayA@(indexB))=0 do quit "RTN","TMGMISC",2062,0) . . if (pExtraB'="") merge @pExtraB@(pArrayA,indexB)=@pArrayB@(indexB) "RTN","TMGMISC",2063,0) . if $get(Compared($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB))))=1 do quit ;"already checked "RTN","TMGMISC",2064,0) . . new temp "RTN","TMGMISC",2065,0) . set abort=$$CompABArray($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB)),.pExtraB,.pMissingB,.pDiff) "RTN","TMGMISC",2066,0) "RTN","TMGMISC",2067,0) quit abort "RTN","TMGMISC",2068,0) "RTN","TMGMISC",2069,0) "RTN","TMGMISC",2070,0) FixArray(ref) "RTN","TMGMISC",2071,0) ;"Purpose: Convert an array like this: "RTN","TMGMISC",2072,0) ;" @ref@("^DD(2,.362)",21,1,0) --> @ref@("^DD",2,.362,21,1,0) "RTN","TMGMISC",2073,0) ;" @ref@("^DD(2,.362)",21,2,0) --> @ref@("^DD",2,.362,21,2,0) "RTN","TMGMISC",2074,0) ;" @ref@("^DD(2,.362)",23,0) --> @ref@("^DD",2,.362,23,0) "RTN","TMGMISC",2075,0) ;" @ref@("^DD(2,.362)",23,1,0) --> @ref@("^DD",2,.362,23,1,0) "RTN","TMGMISC",2076,0) ;" @ref@("^DD(2,0,""IX"")","ACFL2",2,.312) --> @ref@("^DD",2,0,"IX","ACFL2",2,.312) "RTN","TMGMISC",2077,0) ;" @ref@("^DD(2,0,""IX"")","AEXP",2,.351) --> @ref@("^DD",2,0,"IX","AEXP",2,.351) "RTN","TMGMISC",2078,0) ;" @ref@("^DD(2,0,""IX"")","TMGS",2,22701) --> @ref@("^DD",2,0,"IX","TMGS",2,22701) "RTN","TMGMISC",2079,0) ;" @ref@("^DD(2,0,""PT"")",228.1,.02) --> @ref@("^DD",2,0,"PT",228.1,.02) "RTN","TMGMISC",2080,0) ;" @ref@("^DD(2,0,""PT"")",228.2,.02) --> @ref@("^DD",2,0,"PT",228.2,.02) "RTN","TMGMISC",2081,0) ;" @ref@("^DD(2,0,""PT"")",19620.92,.08) --> @ref@("^DD",2,0,"PT",19620.92,.08) "RTN","TMGMISC",2082,0) ;" @ref@("^DD(2,0,""PT"",115)",.01) --> @ref@("^DD",2,0,"PT",115,.01) "RTN","TMGMISC",2083,0) ;"Input: ref -- PASS BY NAME "RTN","TMGMISC",2084,0) ;"Output: contents of @ref are converted as above. "RTN","TMGMISC",2085,0) ;"Results: none "RTN","TMGMISC",2086,0) "RTN","TMGMISC",2087,0) new origRef set origRef=ref "RTN","TMGMISC",2088,0) new output,s1,i "RTN","TMGMISC",2089,0) for set ref=$query(@ref) quit:(ref="") do "RTN","TMGMISC",2090,0) . set s1=$qsubscript(ref,1) "RTN","TMGMISC",2091,0) . new newRef set newRef="output" "RTN","TMGMISC",2092,0) . new startI set startI=1 "RTN","TMGMISC",2093,0) . if s1["(" do "RTN","TMGMISC",2094,0) . . set startI=2 "RTN","TMGMISC",2095,0) . . set newRef=newRef_"("""_$qs(s1,0)_""")" "RTN","TMGMISC",2096,0) . . if $qlength(s1)>1 for i=1:1:$qlength(s1) do "RTN","TMGMISC",2097,0) . . . set newRef=$name(@newRef@($qsubscript(s1,i))) "RTN","TMGMISC",2098,0) . for i=startI:1:$qlength(ref) do "RTN","TMGMISC",2099,0) . . new s3 set s3=$qsubscript(ref,i) "RTN","TMGMISC",2100,0) . . set newRef=$name(@newRef@(s3)) "RTN","TMGMISC",2101,0) . merge @newRef=@ref "RTN","TMGMISC",2102,0) "RTN","TMGMISC",2103,0) kill @origRef "RTN","TMGMISC",2104,0) merge @origRef=output ;"put changes back into original array "RTN","TMGMISC",2105,0) "RTN","TMGMISC",2106,0) quit "RTN","TMGMISC",2107,0) "RTN","TMGMISC",2108,0) "RTN","TMGMISC",2109,0) "RTN","TMGMKU") 0^34^B159313 "RTN","TMGMKU",1,0) TMGMKU ;TMG/kst/Custom version of ZTMKU ;03/25/06 "RTN","TMGMKU",2,0) ;;1.0;TMG-LIB;**1**;11/01/04 "RTN","TMGMKU",3,0) "RTN","TMGMKU",4,0) ;"ZTMKU code -- NON-INTERACTIVE versions of standard code. "RTN","TMGMKU",5,0) ;"============================================================================= "RTN","TMGMKU",6,0) ;"Kevin Toppenberg, MD 11-04 "RTN","TMGMKU",7,0) ;" "RTN","TMGMKU",8,0) ;"Purpose: "RTN","TMGMKU",9,0) ;" "RTN","TMGMKU",10,0) ;"This library will provide optional NON-INTERACTIVE versions of standard code. "RTN","TMGMKU",11,0) ;" "RTN","TMGMKU",12,0) ;"ZTMKU code "RTN","TMGMKU",13,0) ;"Apparent Callable points: "RTN","TMGMKU",14,0) ;" (See below about optional "INFO" parameter) "RTN","TMGMKU",15,0) ;" SSUB(NODE) ;Stop sub-managers "RTN","TMGMKU",16,0) ;" SMAN(NODE) ;stop managers "RTN","TMGMKU",17,0) ;" RUN(INFO) ;Remove Task Managers From WAIT State "RTN","TMGMKU",18,0) ;" UPDATE(INFO) ;Have Managers Do an parameter Update "RTN","TMGMKU",19,0) ;" WAIT(INFO) ;Put Task Managers In WAIT State "RTN","TMGMKU",20,0) ;" STOP(INFO) ;Shut Down Task Managers "RTN","TMGMKU",21,0) ;" QUERY ;Query Status Of A Task Manager "RTN","TMGMKU",22,0) ;" NODES ;Return Task Manager Status Nodes "RTN","TMGMKU",23,0) ;" LIVE ;Return Whether A Task Manager Is Live "RTN","TMGMKU",24,0) ;" TABLE(INFO) ;Display Task Manager Table "RTN","TMGMKU",25,0) ;" CLEAN(INFO) ;Cleanup Status Node "RTN","TMGMKU",26,0) ;" PURGE(INFO) ;Purge the TASK list of running tasks. "RTN","TMGMKU",27,0) ;" ZTM ;Return Number Of Live Task Managers "RTN","TMGMKU",28,0) ;" "RTN","TMGMKU",29,0) ;"Dependancies: "RTN","TMGMKU",30,0) ;" if TMGDEBUG defined, then requires TMGDEBUG.m "RTN","TMGMKU",31,0) ;"============================================================================= "RTN","TMGMKU",32,0) "RTN","TMGMKU",33,0) ZTMKU ;SEA/RDS-Taskman: Option, ZTMWAIT/RUN/STOP ;11/04/99 15:05 "RTN","TMGMKU",34,0) ;;8.0;KERNEL;**118,127,275**;Jul 10, 1995 "RTN","TMGMKU",35,0) ; "RTN","TMGMKU",36,0) "RTN","TMGMKU",37,0) ;"K. Toppenberg's changes made November, 2004 "RTN","TMGMKU",38,0) ;" "RTN","TMGMKU",39,0) ;"Input: "RTN","TMGMKU",40,0) ;" Note: INFO variable is completely an OPTIONAL parameter. "RTN","TMGMKU",41,0) ;" If not supplied, interactive mode used "RTN","TMGMKU",42,0) ;" INFO("SILENT-OUTPUT") -- 1 = output is supressed. "RTN","TMGMKU",43,0) ;" INFO("SILENT-INPUT") -- 1 = User-interactive input is supressed. "RTN","TMGMKU",44,0) ;" "RTN","TMGMKU",45,0) ;" ** if in SILENT-INPUT mode, THEN the following data should be supplied, if the "RTN","TMGMKU",46,0) ;" relevent function is being called. "RTN","TMGMKU",47,0) ;" ---------------------- "RTN","TMGMKU",48,0) ;" INFO("CONTINUE") -- Should contain the answer the user would enter for question: "RTN","TMGMKU",49,0) ;" Are you sure you want to stop TaskMan? "RTN","TMGMKU",50,0) ;" Used in STOP^TMGMKU(INFO) "RTN","TMGMKU",51,0) ;" INFO("SUBMANAGERS") -- Answer to: Should active submanagers shut down after finishing their current tasks? "RTN","TMGMKU",52,0) ;" Used in STOP^TMGMKU(INFO) "RTN","TMGMKU",53,0) ;"Output: "RTN","TMGMKU",54,0) ;" If in SILENT-OUTPUT mode, then output that would normally go to the screen, will be routed to this array "RTN","TMGMKU",55,0) ;" NOTE: INFO SHOULD BE PASSED BY REFERENCE if user wants this information passed back out. "RTN","TMGMKU",56,0) ;" INFO("TEXT","LINES")=Number of output lines "RTN","TMGMKU",57,0) ;" INFO("TEXT",1)= 1st output line "RTN","TMGMKU",58,0) ;" INFO("TEXT",2)= 2nd output line, etc... "RTN","TMGMKU",59,0) ; "RTN","TMGMKU",60,0) ; "RTN","TMGMKU",61,0) Q "RTN","TMGMKU",62,0) "RTN","TMGMKU",63,0) INIT "RTN","TMGMKU",64,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"INIT^TMGMKU") "RTN","TMGMKU",65,0) IF $DATA(SILNTOUT)=0 KILL INFO("TEXT") ;//kt "RTN","TMGMKU",66,0) ; "RTN","TMGMKU",67,0) ;"Note: this establishes a variable with global-scope. ... And no one kills it... "RTN","TMGMKU",68,0) SET SILNTOUT=$GET(INFO("SILENT-OUTPUT"),0) ;//kt "RTN","TMGMKU",69,0) SET SILENTIN=$GET(INFO("SILENT-INPUT"),0) ;//KT "RTN","TMGMKU",70,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"INIT^TMGMKU") "RTN","TMGMKU",71,0) ; "RTN","TMGMKU",72,0) QUIT "RTN","TMGMKU",73,0) "RTN","TMGMKU",74,0) "RTN","TMGMKU",75,0) ; "RTN","TMGMKU",76,0) ;"============================================================================= "RTN","TMGMKU",77,0) SSUB(NODE) ;Stop sub-managers "RTN","TMGMKU",78,0) D SS(1,"SUB",NODE) Q "RTN","TMGMKU",79,0) ;"============================================================================= "RTN","TMGMKU",80,0) SMAN(NODE) ;stop managers "RTN","TMGMKU",81,0) D SS(1,"MGR",NODE) Q "RTN","TMGMKU",82,0) ; "RTN","TMGMKU",83,0) ;"============================================================================= "RTN","TMGMKU",84,0) SS(MD,GR,NODE) ;Set/clear STOP nodes. "RTN","TMGMKU",85,0) S GR=$G(GR,"MGR") S:"MGR_SUB_"'[GR GR="MGR" "RTN","TMGMKU",86,0) I MD=1 S ^%ZTSCH("STOP",GR,NODE)=$H D WS(0,GR) "RTN","TMGMKU",87,0) I MD=0 K ^%ZTSCH("STOP",GR,NODE) "RTN","TMGMKU",88,0) Q "RTN","TMGMKU",89,0) ; "RTN","TMGMKU",90,0) ;"============================================================================= "RTN","TMGMKU",91,0) WS(MD,GR) ;Set/Clear Wait state "RTN","TMGMKU",92,0) S GR=$G(GR,"MGR") S:"MGR_SUB_"'[GR GR="MGR" "RTN","TMGMKU",93,0) I MD=1 S ^%ZTSCH("WAIT",GR)=$H ;set wait state "RTN","TMGMKU",94,0) I MD=0 K ^%ZTSCH("WAIT",GR) ;Clear wait "RTN","TMGMKU",95,0) Q "RTN","TMGMKU",96,0) ; "RTN","TMGMKU",97,0) ;"============================================================================= "RTN","TMGMKU",98,0) GROUP(CALL) ;Do CALL for each node, use NODE as the parameter "RTN","TMGMKU",99,0) N J,ND,NODE "RTN","TMGMKU",100,0) F J=0:0 S J=$O(^%ZTSCH("STATUS",J)) Q:J="" S ND=$G(^(J)),NODE=$P(ND,"^",3) D @CALL "RTN","TMGMKU",101,0) Q "RTN","TMGMKU",102,0) ; "RTN","TMGMKU",103,0) ;"============================================================================= "RTN","TMGMKU",104,0) OPT(MD) ;Disable/Enable option prosessing "RTN","TMGMKU",105,0) I MD=1 S ^%ZTSCH("NO-OPTION")="" "RTN","TMGMKU",106,0) I MD=0 K ^%ZTSCH("NO-OPTION") "RTN","TMGMKU",107,0) Q "RTN","TMGMKU",108,0) ; "RTN","TMGMKU",109,0) ;"============================================================================= "RTN","TMGMKU",110,0) RUN(INFO) ;Remove Task Managers From WAIT State "RTN","TMGMKU",111,0) D WS(0,"MGR"),WS(0,"SUB") K ^%ZTSCH("STOP") "RTN","TMGMKU",112,0) "RTN","TMGMKU",113,0) DO INIT "RTN","TMGMKU",114,0) DO OUTP^TMGQIO(SILNTOUT,"!","Done!","!") "RTN","TMGMKU",115,0) Q "RTN","TMGMKU",116,0) ; "RTN","TMGMKU",117,0) ;"============================================================================= "RTN","TMGMKU",118,0) UPDATE(INFO) ;Have Managers Do an parameter Update "RTN","TMGMKU",119,0) K ^%ZTSCH("UPDATE") "RTN","TMGMKU",120,0) DO INIT "RTN","TMGMKU",121,0) DO OUTP^TMGQIO(SILNTOUT,"!","Done!","!") "RTN","TMGMKU",122,0) Q "RTN","TMGMKU",123,0) ; "RTN","TMGMKU",124,0) ;"============================================================================= "RTN","TMGMKU",125,0) WAIT(INFO) ;Put Task Managers In WAIT State "RTN","TMGMKU",126,0) DO INIT "RTN","TMGMKU",127,0) D WS(1,"MGR") "RTN","TMGMKU",128,0) DO OUTP^TMGQIO(SILNTOUT,"!","TaskMan now in 'WAIT STATE'",$C(7),"!") "RTN","TMGMKU",129,0) D QSUB "RTN","TMGMKU",130,0) Q "RTN","TMGMKU",131,0) ; "RTN","TMGMKU",132,0) ;"============================================================================= "RTN","TMGMKU",133,0) STOP(INFO) ;Shut Down Task Managers "RTN","TMGMKU",134,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"STOP^TMGMKU") "RTN","TMGMKU",135,0) DO INIT "RTN","TMGMKU",136,0) N ZTX,ND,J "RTN","TMGMKU",137,0) DO INIT "RTN","TMGMKU",138,0) F DO Q:'$T!("^YESyesNOno"[ZTX)!(SILENTIN=1) "RTN","TMGMKU",139,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","Are you sure you want to stop TaskMan? NO// ") "RTN","TMGMKU",140,0) . IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBINDENT,"Starting Question Loop") "RTN","TMGMKU",141,0) . DO INP^TMGQIO(.ZTX,SILENTIN,$G(DTIME,60),$GET(INFO("CONTINUE"))) "RTN","TMGMKU",142,0) . IF $GET(ZTX)="" SET ZTX="NO" "RTN","TMGMKU",143,0) . Q:'$T!("^YESyesNOno"[ZTX)!(SILENTIN=1) "RTN","TMGMKU",144,0) . IF ZTX'["?" DO OUTP^TMGQIO(SILNTOUT,$C(7)) "RTN","TMGMKU",145,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Answer YES to shut down all Task Managers on current the volume set.") "RTN","TMGMKU",146,0) IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBINDENT,"Processing input") "RTN","TMGMKU",147,0) I "YESyes"[ZTX DO "RTN","TMGMKU",148,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Shutting down TaskMan.") "RTN","TMGMKU",149,0) . D GROUP("SMAN(NODE)") "RTN","TMGMKU",150,0) . ;"F J=0:0 S J=$O(^%ZTSCH("STATUS",J)) Q:J="" S ND=$G(^(J)) D SMAN($P(ND,U,3)) "RTN","TMGMKU",151,0) . ;"Q "RTN","TMGMKU",152,0) . D QSUB "RTN","TMGMKU",153,0) ELSE DO "RTN","TMGMKU",154,0) . DO OUTP^TMGQIO(SILNTOUT,"!","TaskMan NOT shut down.") "RTN","TMGMKU",155,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"STOP^TMGMKU") "RTN","TMGMKU",156,0) Q "RTN","TMGMKU",157,0) ; "RTN","TMGMKU",158,0) ;"============================================================================= "RTN","TMGMKU",159,0) QSUB "RTN","TMGMKU",160,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"QSUB^TMGMKU") "RTN","TMGMKU",161,0) N ZTX,ND "RTN","TMGMKU",162,0) F DO Q:'$T!("^YESyesNOno"[ZTX)!(SILENTIN=1) "RTN","TMGMKU",163,0) . DO OUTP^TMGQIO(SILNTOUT,"!","!","Should active submanagers shut down after finishing their current tasks? NO// ") "RTN","TMGMKU",164,0) . IF $DATA(TMGDEBUG) DO DebugMsg^TMGDEBUG(.DBINDENT,"Auto answer=",$GET(INFO("SUBMANAGERS"))) "RTN","TMGMKU",165,0) . DO INP^TMGQIO(.ZTX,SILENTIN,$S($D(DTIME)#2:DTIME,1:60),$GET(INFO("SUBMANAGERS"))) "RTN","TMGMKU",166,0) . IF ZTX="" SET ZTX="NO" "RTN","TMGMKU",167,0) . Q:'$T!("^YESyesNOno"[ZTX)!(SILENTIN=1) "RTN","TMGMKU",168,0) . IF ZTX'["?" DO OUTP^TMGQIO(SILNTOUT,$C(7)) "RTN","TMGMKU",169,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Please answer YES or NO..") "RTN","TMGMKU",170,0) I "YESyes"[ZTX DO "RTN","TMGMKU",171,0) . DO GROUP("SSUB(NODE)") "RTN","TMGMKU",172,0) . DO OUTP^TMGQIO(SILNTOUT,"!","Okay!","!") "RTN","TMGMKU",173,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"QSUB^TMGMKU") "RTN","TMGMKU",174,0) Q "RTN","TMGMKU",175,0) ; "RTN","TMGMKU",176,0) ;"============================================================================= "RTN","TMGMKU",177,0) QUERY ;Query Status Of A Task Manager "RTN","TMGMKU",178,0) Q:$D(%ZTX)[0 Q:%ZTX="" S %ZTY=0 "RTN","TMGMKU",179,0) I $D(^%ZTSCH("STATUS",%ZTX))#2 S %ZTY=^%ZTSCH("STATUS",%ZTX) "RTN","TMGMKU",180,0) K %ZTX Q "RTN","TMGMKU",181,0) ; "RTN","TMGMKU",182,0) ;"============================================================================= "RTN","TMGMKU",183,0) NODES ;Return Task Manager Status Nodes "RTN","TMGMKU",184,0) S %ZTX="" F %ZTY=0:0 S %ZTX=$O(^%ZTSCH("STATUS",%ZTX)) Q:%ZTX="" S %ZTY=%ZTY+1,%ZTY(%ZTY)=%ZTX "RTN","TMGMKU",185,0) K %ZTX Q "RTN","TMGMKU",186,0) ; "RTN","TMGMKU",187,0) ;"============================================================================= "RTN","TMGMKU",188,0) LIVE ;Return Whether A Task Manager Is Live "RTN","TMGMKU",189,0) Q:$D(%ZTX)[0 Q:%ZTX="" S %ZTY=0,U="^",%ZTX1=$H,%ZTX2=$P(%ZTX,U) "RTN","TMGMKU",190,0) S %ZTX3=%ZTX1-%ZTX2*86400+$P(%ZTX1,",",2)-$P(%ZTX2,",",2) "RTN","TMGMKU",191,0) I %ZTX3'<0 S %ZTY=$S($D(^%ZTSCH("RUN"))[0&(%ZTX'["WAIT"):0,%ZTX3<30:1,%ZTX3<120&(%ZTX["PAUSE"):1,1:0) "RTN","TMGMKU",192,0) K %ZTX,%ZTX1,%ZTX2,%ZTX3 Q "RTN","TMGMKU",193,0) ; "RTN","TMGMKU",194,0) ;"============================================================================= "RTN","TMGMKU",195,0) TABLE(INFO) ;Display Task Manager Table "RTN","TMGMKU",196,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"TABLE^TMGMKU") "RTN","TMGMKU",197,0) DO INIT "RTN","TMGMKU",198,0) DO OUTP^TMGQIO(SILNTOUT,"!","NUMBER","?15","STATUS","?25","DESCRIPTION","?55","LAST UPDATED","?75","LIVE") "RTN","TMGMKU",199,0) DO OUTP^TMGQIO(SILNTOUT,"!","------","?15","------","?25","-----------","?55","------------","?75","----") "RTN","TMGMKU",200,0) D NODES S %ZTZ=%ZTY,%ZTZ1=0,U="^",%H=$H D YMD^%DTC S DT=X "RTN","TMGMKU",201,0) F %ZTI=1:1:%ZTZ DO "RTN","TMGMKU",202,0) . S %ZTX=%ZTY(%ZTI) "RTN","TMGMKU",203,0) . D QUERY "RTN","TMGMKU",204,0) . I %ZTY'=0 DO "RTN","TMGMKU",205,0) . . DO OUTP^TMGQIO(SILNTOUT,"!",%ZTY(%ZTI),"?15",$P(%ZTY,U,2),"?25",$P(%ZTY,U,3),"?55") "RTN","TMGMKU",206,0) . . S %ZTT=$P(%ZTY,U) "RTN","TMGMKU",207,0) . . D T "RTN","TMGMKU",208,0) . . S %ZTX=%ZTY "RTN","TMGMKU",209,0) . . D LIVE "RTN","TMGMKU",210,0) . . DO OUTP^TMGQIO(SILNTOUT,"?75",$S(%ZTY:"YES",1:"NO")) "RTN","TMGMKU",211,0) . . I %ZTY S %ZTZ1=%ZTZ1+1 "RTN","TMGMKU",212,0) DO OUTP^TMGQIO(SILNTOUT,"!","?6","Total:",$J(%ZTZ,3),"!") "RTN","TMGMKU",213,0) DO OUTP^TMGQIO(SILNTOUT,"?6","Live :",$J(%ZTZ1,3)) "RTN","TMGMKU",214,0) K %ZTI,%ZTT,%ZTY,%ZTZ "RTN","TMGMKU",215,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"TABLE^TMGMKU") "RTN","TMGMKU",216,0) Q "RTN","TMGMKU",217,0) ; "RTN","TMGMKU",218,0) ; "RTN","TMGMKU",219,0) ;"============================================================================= "RTN","TMGMKU",220,0) CLEAN(INFO) ;Cleanup Status Node "RTN","TMGMKU",221,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"CLEAN^TMGMKU") "RTN","TMGMKU",222,0) DO INIT "RTN","TMGMKU",223,0) K ^%ZTSCH("STATUS") "RTN","TMGMKU",224,0) DO OUTP^TMGQIO(SILNTOUT,"!","Done!","!") "RTN","TMGMKU",225,0) ; "RTN","TMGMKU",226,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"CLEAN^TMGMKU") "RTN","TMGMKU",227,0) Q "RTN","TMGMKU",228,0) ; "RTN","TMGMKU",229,0) ; "RTN","TMGMKU",230,0) ;"============================================================================= "RTN","TMGMKU",231,0) PURGE(INFO) ;Purge the TASK list of running tasks. "RTN","TMGMKU",232,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"PURGE^TMGMKU") "RTN","TMGMKU",233,0) DO INIT "RTN","TMGMKU",234,0) N TSK S TSK=0 "RTN","TMGMKU",235,0) F S TSK=$O(^%ZTSCH("TASK",TSK)) Q:TSK'>0 I '$D(^%ZTSCH("TASK",TSK,"P")) K ^%ZTSCH("TASK",TSK) "RTN","TMGMKU",236,0) DO OUTP^TMGQIO(SILNTOUT,"!","Done!","!") "RTN","TMGMKU",237,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"CLEAN^TMGMKU") "RTN","TMGMKU",238,0) Q "RTN","TMGMKU",239,0) ; "RTN","TMGMKU",240,0) ; "RTN","TMGMKU",241,0) ;"============================================================================= "RTN","TMGMKU",242,0) ZTM ;Return Number Of Live Task Managers "RTN","TMGMKU",243,0) D NODES S %ZTZ=%ZTY,%ZTZ1=0 F %ZTI=1:1:%ZTZ S %ZTX=%ZTY(%ZTI) D QUERY I %ZTY'=0 S %ZTX=%ZTY D LIVE I %ZTY S %ZTZ1=%ZTZ1+1 "RTN","TMGMKU",244,0) S %ZTY=%ZTZ1 K %ZTI,%ZTZ,%ZTZ1 Q "RTN","TMGMKU",245,0) ; "RTN","TMGMKU",246,0) ;"============================================================================= "RTN","TMGMKU",247,0) T ;Print Informal-format Conversion Of $H-format Date ; Input: %ZTT, DT. "RTN","TMGMKU",248,0) IF $DATA(TMGDEBUG) DO DebugEntry^TMGDEBUG(.DBINDENT,"T^TMGMKU") "RTN","TMGMKU",249,0) S %H=%ZTT "RTN","TMGMKU",250,0) D 7^%DTC "RTN","TMGMKU",251,0) DO OUTP^TMGQIO(SILNTOUT,$S(DT=X:"TODAY",DT+1=X:"TOMORROW",1:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3))_" AT ") "RTN","TMGMKU",252,0) S X=$P(%ZTT,",",2)\60 "RTN","TMGMKU",253,0) S %H=X\60 "RTN","TMGMKU",254,0) DO OUTP^TMGQIO(SILNTOUT,$E(%H+100,2,3)_":"_$E(X#60+100,2,3)) "RTN","TMGMKU",255,0) K %,%D,%H,%M,%Y,X "RTN","TMGMKU",256,0) ; "RTN","TMGMKU",257,0) IF $DATA(TMGDEBUG) DO DebugExit^TMGDEBUG(.DBINDENT,"T^TMGMKU") "RTN","TMGMKU",258,0) Q ; Output: %ZTT, DT. "RTN","TMGMKU",259,0) ; "RTN","TMGMKU",260,0) ;"============================================================================= "RTN","TMGNDF0A") 0^35^B7420 "RTN","TMGNDF0A",1,0) TMGNDF0A ;TMG/kst/FDA Import: Load FDA data files ;03/25/06 "RTN","TMGNDF0A",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF0A",3,0) "RTN","TMGNDF0A",4,0) ;" FDA - NATIONAL DRUG FILES IMPORT FUNCTIONS "RTN","TMGNDF0A",5,0) ;"Kevin Toppenberg MD "RTN","TMGNDF0A",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF0A",7,0) ;"11-21-2006 "RTN","TMGNDF0A",8,0) "RTN","TMGNDF0A",9,0) ;"Purpose: to import the National Drug Files, as distributed by: "RTN","TMGNDF0A",10,0) ;" http://www.fda.gov/cder/ndc/ in format as of 10/17/2005 "RTN","TMGNDF0A",11,0) ;" List of files imported: "RTN","TMGNDF0A",12,0) ;" TMG FDA APPLICATION (22706.1) <--> applicat.TXT "RTN","TMGNDF0A",13,0) ;" TMG FDA DOSAGE FORM (22706.2) <--> dosform.TXT "RTN","TMGNDF0A",14,0) ;" TMG FDA FIRMS (22706.3) <--> FIRMS.TXT ;was firms.txt "RTN","TMGNDF0A",15,0) ;" TMG FDA FORMULATION (22706.4) <--> FORMULAT.TXT "RTN","TMGNDF0A",16,0) ;" TMG FDA LISTING (22706.5) <--> listings.TXT ;was listings.txt "RTN","TMGNDF0A",17,0) ;" TMG FDA PACKAGES (22706.6) <--> packages.txt "RTN","TMGNDF0A",18,0) ;" TMG FDA ROUTES (22706.7) <--> ROUTES.TXT ;was routes.txt "RTN","TMGNDF0A",19,0) ;" TMG FDA UNIT ABBREVIATIONS (22706.8) <--> TBLUNIT.TXT ; was tblunit.txt "RTN","TMGNDF0A",20,0) "RTN","TMGNDF0A",21,0) ;"======================================================================= "RTN","TMGNDF0A",22,0) ;" API -- Public Functions. "RTN","TMGNDF0A",23,0) ;"======================================================================= "RTN","TMGNDF0A",24,0) ;"Menu -- The starting menu for the import process "RTN","TMGNDF0A",25,0) "RTN","TMGNDF0A",26,0) ;"======================================================================= "RTN","TMGNDF0A",27,0) ;" API -- Semi-Public Functions. "RTN","TMGNDF0A",28,0) ;"======================================================================= "RTN","TMGNDF0A",29,0) ;"ImportNDF "RTN","TMGNDF0A",30,0) ;"$$DataImport(Info,ProgressFN) "RTN","TMGNDF0A",31,0) ;"Backup "RTN","TMGNDF0A",32,0) "RTN","TMGNDF0A",33,0) ;"======================================================================= "RTN","TMGNDF0A",34,0) ;" Private Functions. "RTN","TMGNDF0A",35,0) ;"======================================================================= "RTN","TMGNDF0A",36,0) ;"SetLoadDir(LoadDir) "RTN","TMGNDF0A",37,0) ;"$$LoadApplication(LoadDir) "RTN","TMGNDF0A",38,0) ;"$$LoadDosageForm(LoadDir) "RTN","TMGNDF0A",39,0) ;"$$LoadFirms(LoadDir) "RTN","TMGNDF0A",40,0) ;"$$LoadFormulation(LoadDir) "RTN","TMGNDF0A",41,0) ;"$$LoadListing(LoadDir) "RTN","TMGNDF0A",42,0) ;"$$LoadPackages(LoadDir) "RTN","TMGNDF0A",43,0) ;"$$LoadRoutes(LoadDir) "RTN","TMGNDF0A",44,0) ;"$$LoadUnitAbbr(LoadDir) "RTN","TMGNDF0A",45,0) ;"SetSkipFlag "RTN","TMGNDF0A",46,0) "RTN","TMGNDF0A",47,0) ;"======================================================================= "RTN","TMGNDF0A",48,0) ;"======================================================================= "RTN","TMGNDF0A",49,0) Menu "RTN","TMGNDF0A",50,0) ;"Purpose: To give an interactive menu "RTN","TMGNDF0A",51,0) "RTN","TMGNDF0A",52,0) new Menu,UsrSlct "RTN","TMGNDF0A",53,0) set Menu(0)="Pick Option for Parsing FDA Tables (0A)" "RTN","TMGNDF0A",54,0) set Menu(1)="Review instructions"_$char(9)_"Instructions" "RTN","TMGNDF0A",55,0) set Menu(2)="Parse FDA tables into corresponding Fileman Tables"_$char(9)_"ParseAll" "RTN","TMGNDF0A",56,0) ;"set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF0A",57,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF0A",58,0) "RTN","TMGNDF0A",59,0) CD1 "RTN","TMGNDF0A",60,0) write # "RTN","TMGNDF0A",61,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF0A",62,0) if UsrSlct="^" goto CDDone "RTN","TMGNDF0A",63,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF0A",64,0) "RTN","TMGNDF0A",65,0) ;"if UsrSlct="Prev" goto Menu^TMGNDF1D ;"quit can occur from there... "RTN","TMGNDF0A",66,0) if UsrSlct="Next" goto Menu^TMGNDF0B ;"quit can occur from there... "RTN","TMGNDF0A",67,0) if UsrSlct="Instructions" do Instructions goto CD1 "RTN","TMGNDF0A",68,0) if UsrSlct="ParseAll" do ImportNDF goto CD1 "RTN","TMGNDF0A",69,0) goto CD1 "RTN","TMGNDF0A",70,0) CDDone "RTN","TMGNDF0A",71,0) quit "RTN","TMGNDF0A",72,0) "RTN","TMGNDF0A",73,0) ;"======================================================================= "RTN","TMGNDF0A",74,0) "RTN","TMGNDF0A",75,0) Instructions "RTN","TMGNDF0A",76,0) ;"Purpose: to show some instructions "RTN","TMGNDF0A",77,0) "RTN","TMGNDF0A",78,0) write !! "RTN","TMGNDF0A",79,0) write "The individual tables from the FDA should be downloaded from: ",! "RTN","TMGNDF0A",80,0) write " www.fda.gov/cder/ndc",! "RTN","TMGNDF0A",81,0) write ! "RTN","TMGNDF0A",82,0) write "Reloading these files will NOT immediately overwrite changes made",! "RTN","TMGNDF0A",83,0) write "the COMPILED import data. It will simply get the FDA tables",! "RTN","TMGNDF0A",84,0) write "into a format for later compilation.",! "RTN","TMGNDF0A",85,0) write ! "RTN","TMGNDF0A",86,0) write "Note: the instructions on the FDA website should be compared to the",! "RTN","TMGNDF0A",87,0) write "parsing code in TMGNDF0A.m to ensure that the FDA table format has",! "RTN","TMGNDF0A",88,0) write "not changed.",!,! "RTN","TMGNDF0A",89,0) "RTN","TMGNDF0A",90,0) do PressToCont^TMGUSRIF "RTN","TMGNDF0A",91,0) quit "RTN","TMGNDF0A",92,0) "RTN","TMGNDF0A",93,0) ;"======================================================================= "RTN","TMGNDF0A",94,0) ;"Note: these files were downloaded from: "RTN","TMGNDF0A",95,0) ;" www.fda.gov/cder/ndc "RTN","TMGNDF0A",96,0) "RTN","TMGNDF0A",97,0) ImportNDF "RTN","TMGNDF0A",98,0) ;"Purpose: to import the National Drug Files, as distributed by: "RTN","TMGNDF0A",99,0) ;" http://www.fda.gov/cder/ndc/, in format as of 10/17/2005 "RTN","TMGNDF0A",100,0) ;" List of files imported: "RTN","TMGNDF0A",101,0) ;" TMG FDA APPLICATION <--> applicat.TXT "RTN","TMGNDF0A",102,0) ;" TMG FDA DOSAGE FORM <--> dosform.TXT "RTN","TMGNDF0A",103,0) ;" TMG FDA FIRMS <--> FIRMS.TXT ;was firms.txt "RTN","TMGNDF0A",104,0) ;" TMG FDA FORMULATION <--> FORMULAT.TXT "RTN","TMGNDF0A",105,0) ;" TMG FDA LISTING <--> listings.TXT ;was listings.txt "RTN","TMGNDF0A",106,0) ;" TMG FDA PACKAGES <--> packages.txt "RTN","TMGNDF0A",107,0) ;" TMG FDA ROUTES <--> ROUTES.TXT ;was routes.txt "RTN","TMGNDF0A",108,0) ;" TMG FDA UNIT ABBREVIATIONS <--> TBLUNIT.TXT ; was tblunit.txt "RTN","TMGNDF0A",109,0) ;"Prerequisites: Must have Fileman files created to import into "RTN","TMGNDF0A",110,0) "RTN","TMGNDF0A",111,0) new LoadDir "RTN","TMGNDF0A",112,0) new PriorErrorFound "RTN","TMGNDF0A",113,0) new ProgressFn "RTN","TMGNDF0A",114,0) set ProgressFn="if TMGCUR#100=1 do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",0,TMGTOTAL,,StartTime)" "RTN","TMGNDF0A",115,0) "RTN","TMGNDF0A",116,0) write "Custom FDA Drug Files Importer",!! "RTN","TMGNDF0A",117,0) write "This will DELETE all exsting entries in FDA National ",! "RTN","TMGNDF0A",118,0) write "Drug Files, and then reload them from source text files.",! "RTN","TMGNDF0A",119,0) write "Do you want to do this? " "RTN","TMGNDF0A",120,0) set %=2 ;"2=NO default "RTN","TMGNDF0A",121,0) do YN^DICN "RTN","TMGNDF0A",122,0) write ! "RTN","TMGNDF0A",123,0) if %'=1 goto INDFError "RTN","TMGNDF0A",124,0) if $$SetLoadDir(.LoadDir)=0 goto INDFError "RTN","TMGNDF0A",125,0) "RTN","TMGNDF0A",126,0) new skip set skip=0 "RTN","TMGNDF0A",127,0) write "Loading TMG FDA APPLICATIONS",! "RTN","TMGNDF0A",128,0) if 'skip if $$LoadApplication(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",129,0) write "Loading TMG FDA DOSAGE FORMS",! "RTN","TMGNDF0A",130,0) if 'skip if $$LoadDosageForm(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",131,0) write "Loading TMG FDA firms",! "RTN","TMGNDF0A",132,0) if 'skip if $$LoadFirms(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",133,0) write "Loading TMG FDA FORMULATIONS",! "RTN","TMGNDF0A",134,0) if 'skip if $$LoadFormulation(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",135,0) write "Loading TMG FDA PACKAGES",! "RTN","TMGNDF0A",136,0) if 'skip if $$LoadPackages(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",137,0) write "Loading TMG FDA ROUTES",! "RTN","TMGNDF0A",138,0) if 'skip if $$LoadRoutes(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",139,0) write "Loading TMG FDA UNIT ABBREVIATIONS",! "RTN","TMGNDF0A",140,0) if 'skip if $$LoadUnitAbbr(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",141,0) write "Loading TMG FDA LISTINGS",! "RTN","TMGNDF0A",142,0) if 'skip if $$LoadListing(LoadDir)=0 goto INDFError "RTN","TMGNDF0A",143,0) "RTN","TMGNDF0A",144,0) write "All done. Import Successful.",! "RTN","TMGNDF0A",145,0) goto INDFDone "RTN","TMGNDF0A",146,0) "RTN","TMGNDF0A",147,0) INDFError "RTN","TMGNDF0A",148,0) Write "Import was NOT successful. Quitting.",! "RTN","TMGNDF0A",149,0) "RTN","TMGNDF0A",150,0) INDFDone "RTN","TMGNDF0A",151,0) quit "RTN","TMGNDF0A",152,0) "RTN","TMGNDF0A",153,0) "RTN","TMGNDF0A",154,0) SetLoadDir(LoadDir) "RTN","TMGNDF0A",155,0) ;"Purpose to ensure that LoadDir is set properly "RTN","TMGNDF0A",156,0) ;"LoadDir -- PASS BY REFERENCE, an OUT parameter "RTN","TMGNDF0A",157,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",158,0) "RTN","TMGNDF0A",159,0) new Msg "RTN","TMGNDF0A",160,0) new result set result=1 "RTN","TMGNDF0A",161,0) set Msg="Please Pick ANY file in the directory containing NDF files" "RTN","TMGNDF0A",162,0) new defDir set defDir="/home/kdt0p/downloads/FDA-NDC-Files/" "RTN","TMGNDF0A",163,0) if $$GetFName^TMGIOUTL(Msg,defDir,,,.LoadDir)="" do "RTN","TMGNDF0A",164,0) . set result=0 "RTN","TMGNDF0A",165,0) "RTN","TMGNDF0A",166,0) quit result "RTN","TMGNDF0A",167,0) "RTN","TMGNDF0A",168,0) "RTN","TMGNDF0A",169,0) LoadApplication(LoadDir) "RTN","TMGNDF0A",170,0) ;"Purpose: to load from applicat.TXT "RTN","TMGNDF0A",171,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",172,0) ;"Output: Kills any prior entries in TMG FDA APPLICATION "RTN","TMGNDF0A",173,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",174,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",175,0) "RTN","TMGNDF0A",176,0) ;" Info("HFS DIR")= "RTN","TMGNDF0A",177,0) ;" Info("HFS FILE")= "RTN","TMGNDF0A",178,0) ;" Info("DEST FILE")= "RTN","TMGNDF0A",179,0) ;" Info(x)=field# (or "IEN" if data should be used to determine record number "RTN","TMGNDF0A",180,0) ;" Info(x,"START")=starting column "RTN","TMGNDF0A",181,0) ;" Info(x,"END")=ending column "RTN","TMGNDF0A",182,0) "RTN","TMGNDF0A",183,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",184,0) ;"===================================== "RTN","TMGNDF0A",185,0) ;"MAY OCCUR MORE THAN ONCE PER LISTING SEQ NO. "RTN","TMGNDF0A",186,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL:1-7 "RTN","TMGNDF0A",187,0) ;" Linking field to LISTINGS. "RTN","TMGNDF0A",188,0) ;"APPL_NO NULL CHAR(6) COL:9-14 "RTN","TMGNDF0A",189,0) ;" Number of New Drug Application if applicable. If none has been "RTN","TMGNDF0A",190,0) ;" provided by the firm then the value ‘Other’ is used. "RTN","TMGNDF0A",191,0) ;"PROD_NO NULL CHAR(3) COL:16-18 "RTN","TMGNDF0A",192,0) ;" Number used to identify the products of a New Drug Application. "RTN","TMGNDF0A",193,0) ;"===================================== "RTN","TMGNDF0A",194,0) ;"Log: "RTN","TMGNDF0A",195,0) ;" 10/20/07 -- modified for 9/12/07 database "RTN","TMGNDF0A",196,0) "RTN","TMGNDF0A",197,0) new Info "RTN","TMGNDF0A",198,0) new result "RTN","TMGNDF0A",199,0) "RTN","TMGNDF0A",200,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",201,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",202,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",203,0) new temp set temp=$get(^TMG(22706.1,0)) "RTN","TMGNDF0A",204,0) kill ^TMG(22706.1) "RTN","TMGNDF0A",205,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",206,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",207,0) set ^TMG(22706.1,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",208,0) "RTN","TMGNDF0A",209,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",210,0) set Info("HFS FILE")="applicat.txt" ;" was applicat.TXT before "RTN","TMGNDF0A",211,0) set Info("DEST FILE")="TMG FDA APPLICATION" "RTN","TMGNDF0A",212,0) "RTN","TMGNDF0A",213,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",214,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",215,0) if result>0 set result=0 goto LADone "RTN","TMGNDF0A",216,0) "RTN","TMGNDF0A",217,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL:1-7 "RTN","TMGNDF0A",218,0) ;"Linking field to LISTINGS. "RTN","TMGNDF0A",219,0) set Info(.01)=.01 ;"Listing, pointer to 22706.5 "RTN","TMGNDF0A",220,0) set Info(.01,"START")=1 ;"was 1 "RTN","TMGNDF0A",221,0) set Info(.01,"END")=7 ;"was 8 "RTN","TMGNDF0A",222,0) "RTN","TMGNDF0A",223,0) ;"APPL_NO NULL CHAR(6) COL:10-15 "RTN","TMGNDF0A",224,0) ;"Number of New Drug Application if applicable. "RTN","TMGNDF0A",225,0) ;"If none has been provided by the firm then the value ‘Other’ is used. "RTN","TMGNDF0A",226,0) set Info(1)=1 ;"Application "RTN","TMGNDF0A",227,0) set Info(1,"START")=9 ;"was 10 <-- was 9 "RTN","TMGNDF0A",228,0) set Info(1,"END")=14 ;"was 15 <-- was 15 "RTN","TMGNDF0A",229,0) "RTN","TMGNDF0A",230,0) ;"PROD_NO NULL CHAR(3) COL:17-19 "RTN","TMGNDF0A",231,0) ;"Number used to identify the products of a New Drug Application. . "RTN","TMGNDF0A",232,0) set Info(2)=2 ;"Product Number "RTN","TMGNDF0A",233,0) set Info(2,"START")=16 ;"was 17 <-- was 16 "RTN","TMGNDF0A",234,0) set Info(2,"END")=18 ;"was 19 <-- was 22 "RTN","TMGNDF0A",235,0) "RTN","TMGNDF0A",236,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",237,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",238,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",239,0) "RTN","TMGNDF0A",240,0) LADone "RTN","TMGNDF0A",241,0) quit result "RTN","TMGNDF0A",242,0) "RTN","TMGNDF0A",243,0) "RTN","TMGNDF0A",244,0) LoadDosageForm(LoadDir) "RTN","TMGNDF0A",245,0) ;"Purpose: to load TMG FDA DOSAGE FORM <--> doseform.TXT "RTN","TMGNDF0A",246,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",247,0) ;"Output: Kills any prior entries in TMG FDA DOSAGE FORM "RTN","TMGNDF0A",248,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",249,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",250,0) "RTN","TMGNDF0A",251,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",252,0) ;"===================================== "RTN","TMGNDF0A",253,0) ;"MAY OCCUR MULTIPLE TIMES PER LISTING SEQ NO. "RTN","TMGNDF0A",254,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL:1-7 "RTN","TMGNDF0A",255,0) ;" Linking field to LISTINGS. "RTN","TMGNDF0A",256,0) ;"DOSEFORM NULL CHAR(3) COL:9-11 "RTN","TMGNDF0A",257,0) ;" The code for the route of administration. File will allow all assigned values for this element. "RTN","TMGNDF0A",258,0) ;"DOSAGE_NAME NULL CHAR(240) COL:13-252 "RTN","TMGNDF0A",259,0) ;" The translation for the route of administration code. "RTN","TMGNDF0A",260,0) ;"===================================== "RTN","TMGNDF0A",261,0) ;"Log: "RTN","TMGNDF0A",262,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",263,0) "RTN","TMGNDF0A",264,0) new Info "RTN","TMGNDF0A",265,0) new result "RTN","TMGNDF0A",266,0) "RTN","TMGNDF0A",267,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",268,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",269,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",270,0) new temp set temp=$get(^TMG(22706.2,0)) "RTN","TMGNDF0A",271,0) kill ^TMG(22706.2) "RTN","TMGNDF0A",272,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",273,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",274,0) set ^TMG(22706.2,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",275,0) "RTN","TMGNDF0A",276,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",277,0) set Info("HFS FILE")="doseform.TXT" "RTN","TMGNDF0A",278,0) set Info("DEST FILE")="TMG FDA DOSAGE FORM" "RTN","TMGNDF0A",279,0) "RTN","TMGNDF0A",280,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",281,0) set result=$$Dos2Unix^TMGKERNL(tempFile) "RTN","TMGNDF0A",282,0) if result>0 set result=0 goto LDsDone "RTN","TMGNDF0A",283,0) "RTN","TMGNDF0A",284,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL:1-7 "RTN","TMGNDF0A",285,0) ;"Linking field to LISTINGS. "RTN","TMGNDF0A",286,0) set Info(.01)=.01 ;"Listing, pointer to 22706.5 "RTN","TMGNDF0A",287,0) set Info(.01,"START")=1 ;"was 1 "RTN","TMGNDF0A",288,0) set Info(.01,"END")=7 ;"was 8 "RTN","TMGNDF0A",289,0) "RTN","TMGNDF0A",290,0) ;"DOSEFORM NULL CHAR(3) COL:9-11 "RTN","TMGNDF0A",291,0) ;"The code for the route of administration. File will allow all assigned values for this element. "RTN","TMGNDF0A",292,0) set Info(1)=1 ;"Dosage form "RTN","TMGNDF0A",293,0) set Info(1,"START")=9 ;"was 9 "RTN","TMGNDF0A",294,0) set Info(1,"END")=11 ;"was 12 "RTN","TMGNDF0A",295,0) "RTN","TMGNDF0A",296,0) ;"DOSAGE_NAME NULL CHAR(240) COL:13-252 "RTN","TMGNDF0A",297,0) ;"The translation for the route of administration code. "RTN","TMGNDF0A",298,0) set Info(2)=2 ;"Dosage Name "RTN","TMGNDF0A",299,0) set Info(2,"START")=13 ;"was 13 "RTN","TMGNDF0A",300,0) set Info(2,"END")=252 ;"was 128 "RTN","TMGNDF0A",301,0) "RTN","TMGNDF0A",302,0) LDL2 "RTN","TMGNDF0A",303,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",304,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",305,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",306,0) "RTN","TMGNDF0A",307,0) LDsDone "RTN","TMGNDF0A",308,0) quit result "RTN","TMGNDF0A",309,0) "RTN","TMGNDF0A",310,0) "RTN","TMGNDF0A",311,0) LoadFirms(LoadDir) "RTN","TMGNDF0A",312,0) ;"Purpose: to load TMG FDA FIRMS <--> FIRMS.TXT ;was firms.txt "RTN","TMGNDF0A",313,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",314,0) ;"Output: Kills any prior entries in TMG FDA FIRMS "RTN","TMGNDF0A",315,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",316,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",317,0) "RTN","TMGNDF0A",318,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",319,0) ;"===================================== "RTN","TMGNDF0A",320,0) ;"EACH FIRM HAS A UNIQUE FIRM SEQ NO WHICH CAN OCCUR MULTIPLE TIMES IN THE LISTINGS FILE. "RTN","TMGNDF0A",321,0) ;"Contains the firm's full name, and compliance address. The compliance address is the mailing address where the FDA sends listing information to the firm. "RTN","TMGNDF0A",322,0) ;"LBLCODE NOT NULL NUM(6) COL:1-6 "RTN","TMGNDF0A",323,0) ;" FDA generated identification number for each firm. The number is padded to the left with zeroes to fill out to length 6. "RTN","TMGNDF0A",324,0) ;"FIRM_NAME NOT NULL CHAR(65) COL:8-72 "RTN","TMGNDF0A",325,0) ;" Firm name as reported by the firm. "RTN","TMGNDF0A",326,0) ;"ADDR_HEADER NULL CHAR(40) COL:74-113 "RTN","TMGNDF0A",327,0) ;" Address Heading as reported by the firm. "RTN","TMGNDF0A",328,0) ;"STREET NULL CHAR(40) COL:115-154 "RTN","TMGNDF0A",329,0) ;" Street Address as reported by firm. "RTN","TMGNDF0A",330,0) ;"PO_BOX NULL CHAR(9) COL:156-164 "RTN","TMGNDF0A",331,0) ;" Post office box number as reported by firm. "RTN","TMGNDF0A",332,0) ;"FOREIGN_ADDR NULL CHAR(40) COL:166-205 "RTN","TMGNDF0A",333,0) ;" Address information report by firm for foreign countries that does not fit the U.S. Postal service configuration. "RTN","TMGNDF0A",334,0) ;"CITY NULL CHAR(30) COL:207-236 "RTN","TMGNDF0A",335,0) ;"STATE NULL CHAR(2) COL:238-239 "RTN","TMGNDF0A",336,0) ;"ZIP NULL CHAR(9) COL:241-249 "RTN","TMGNDF0A",337,0) ;"USPS Zip code. "RTN","TMGNDF0A",338,0) ;"PROVINCE NULL CHAR(30) COL:251-280 "RTN","TMGNDF0A",339,0) ;" Province of Foreign country if appropriate. "RTN","TMGNDF0A",340,0) ;"COUNTRY_NAME NOT NULL CHAR(40) COL:282-321 "RTN","TMGNDF0A",341,0) ;"===================================== "RTN","TMGNDF0A",342,0) ;"Log: "RTN","TMGNDF0A",343,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",344,0) "RTN","TMGNDF0A",345,0) new Info "RTN","TMGNDF0A",346,0) new result "RTN","TMGNDF0A",347,0) "RTN","TMGNDF0A",348,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",349,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",350,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",351,0) new temp set temp=$get(^TMG(22706.3,0)) "RTN","TMGNDF0A",352,0) kill ^TMG(22706.3) "RTN","TMGNDF0A",353,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",354,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",355,0) set ^TMG(22706.3,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",356,0) "RTN","TMGNDF0A",357,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",358,0) set Info("HFS FILE")="FIRMS.TXT" ;"was firms.txt "RTN","TMGNDF0A",359,0) set Info("DEST FILE")="TMG FDA FIRMS" "RTN","TMGNDF0A",360,0) "RTN","TMGNDF0A",361,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",362,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",363,0) if result>0 set result=0 goto LFrDone "RTN","TMGNDF0A",364,0) "RTN","TMGNDF0A",365,0) ;"LBLCODE NOT NULL NUM(6) COL:1-6 "RTN","TMGNDF0A",366,0) ;"FDA generated identification number for each firm. "RTN","TMGNDF0A",367,0) ;"The number is padded to the left with zeroes to fill out to length 6. "RTN","TMGNDF0A",368,0) set Info(1)=1 ;"Label Code "RTN","TMGNDF0A",369,0) set Info(1,"START")=1 "RTN","TMGNDF0A",370,0) set Info(1,"END")=6 "RTN","TMGNDF0A",371,0) "RTN","TMGNDF0A",372,0) ;"FIRM_NAME NOT NULL CHAR(65) COL:8-72 "RTN","TMGNDF0A",373,0) ;"Firm name as reported by the firm. "RTN","TMGNDF0A",374,0) set Info(.01)=.01 ;"Name "RTN","TMGNDF0A",375,0) set Info(.01,"START")=8 "RTN","TMGNDF0A",376,0) set Info(.01,"END")=72 "RTN","TMGNDF0A",377,0) "RTN","TMGNDF0A",378,0) ;"ADDR_HEADER NULL CHAR(40) COL:74-113 "RTN","TMGNDF0A",379,0) ;"Address Heading as reported by the firm. "RTN","TMGNDF0A",380,0) set Info(2)=2 ;"Address Header "RTN","TMGNDF0A",381,0) set Info(2,"START")=74 "RTN","TMGNDF0A",382,0) set Info(2,"END")=113 "RTN","TMGNDF0A",383,0) "RTN","TMGNDF0A",384,0) ;"STREET NULL CHAR(40) COL:115-154 "RTN","TMGNDF0A",385,0) ;"Street Address as reported by firm. "RTN","TMGNDF0A",386,0) set Info(3)=3 ;"Street "RTN","TMGNDF0A",387,0) set Info(3,"START")=115 "RTN","TMGNDF0A",388,0) set Info(3,"END")=154 "RTN","TMGNDF0A",389,0) "RTN","TMGNDF0A",390,0) ;"PO_BOX NULL CHAR(9) COL:156-164 "RTN","TMGNDF0A",391,0) ;"Post office box number as reported by firm. "RTN","TMGNDF0A",392,0) set Info(4)=4 ;"PO Box "RTN","TMGNDF0A",393,0) set Info(4,"START")=156 "RTN","TMGNDF0A",394,0) set Info(4,"END")=164 "RTN","TMGNDF0A",395,0) "RTN","TMGNDF0A",396,0) ;"FOREIGN_ADDR NULL CHAR(40) COL:166-205 "RTN","TMGNDF0A",397,0) ;"Address information report by firm for foreign "RTN","TMGNDF0A",398,0) ;"countries that does not fit the U.S. Postal service configuration. "RTN","TMGNDF0A",399,0) set Info(5)=5 ;"Foreign Address "RTN","TMGNDF0A",400,0) set Info(5,"START")=166 "RTN","TMGNDF0A",401,0) set Info(5,"END")=205 "RTN","TMGNDF0A",402,0) "RTN","TMGNDF0A",403,0) ;"CITY NULL CHAR(30) COL:207-236 "RTN","TMGNDF0A",404,0) set Info(6)=6 ;"City "RTN","TMGNDF0A",405,0) set Info(6,"START")=207 "RTN","TMGNDF0A",406,0) set Info(6,"END")=236 "RTN","TMGNDF0A",407,0) "RTN","TMGNDF0A",408,0) ;"STATE NULL CHAR(2) COL:238-239 "RTN","TMGNDF0A",409,0) set Info(7)=7 ;"State "RTN","TMGNDF0A",410,0) set Info(7,"START")=238 "RTN","TMGNDF0A",411,0) set Info(7,"END")=239 "RTN","TMGNDF0A",412,0) "RTN","TMGNDF0A",413,0) ;"ZIP NULL CHAR(9) COL:241-249 "RTN","TMGNDF0A",414,0) ;"USPS Zip code. "RTN","TMGNDF0A",415,0) set Info(8)=8 ;"ZIP "RTN","TMGNDF0A",416,0) set Info(8,"START")=241 "RTN","TMGNDF0A",417,0) set Info(8,"END")=249 "RTN","TMGNDF0A",418,0) "RTN","TMGNDF0A",419,0) ;"PROVINCE NULL CHAR(30) COL:251-280 "RTN","TMGNDF0A",420,0) ;"Province of Foreign country if appropriate. "RTN","TMGNDF0A",421,0) set Info(9)=9 ;"Province "RTN","TMGNDF0A",422,0) set Info(9,"START")=251 "RTN","TMGNDF0A",423,0) set Info(9,"END")=280 "RTN","TMGNDF0A",424,0) "RTN","TMGNDF0A",425,0) ;"COUNTRY_NAME NOT NULL CHAR(40) COL:282-321 "RTN","TMGNDF0A",426,0) set Info(10)=10 ;"Country "RTN","TMGNDF0A",427,0) set Info(10,"START")=282 "RTN","TMGNDF0A",428,0) set Info(10,"END")=321 "RTN","TMGNDF0A",429,0) "RTN","TMGNDF0A",430,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",431,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",432,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",433,0) "RTN","TMGNDF0A",434,0) LFrDone "RTN","TMGNDF0A",435,0) quit result "RTN","TMGNDF0A",436,0) "RTN","TMGNDF0A",437,0) "RTN","TMGNDF0A",438,0) LoadFormulation(LoadDir) "RTN","TMGNDF0A",439,0) ;"Purpose: to load TMG FDA FORMULATION <--> FORMULAT.TXT "RTN","TMGNDF0A",440,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",441,0) ;"Output: Kills any prior entries in TMG FDA FIRMS "RTN","TMGNDF0A",442,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",443,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",444,0) "RTN","TMGNDF0A",445,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",446,0) ;"===================================== "RTN","TMGNDF0A",447,0) ;"MAY OCCUR MULTIPLE TIMES PER LISTING SEQ NO. "RTN","TMGNDF0A",448,0) ;"Lists active ingredients contained in product's formulation. "RTN","TMGNDF0A",449,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL: 1-7 "RTN","TMGNDF0A",450,0) ;" Linking field to LISTINGS. "RTN","TMGNDF0A",451,0) ;"STRENGTH NULL CHAR(10) COL: 9-18 "RTN","TMGNDF0A",452,0) ;" This is the potency of the active ingredient. "RTN","TMGNDF0A",453,0) ;"UNIT NULL CHAR(5) COL: 20-24 "RTN","TMGNDF0A",454,0) ;" Unit of measure corresponding to strength. "RTN","TMGNDF0A",455,0) ;"INGREDIENT_NAME NOT NULL CHAR(100) COL: 26-125 "RTN","TMGNDF0A",456,0) ;" Truncated preferred term for the active ingredient. "RTN","TMGNDF0A",457,0) ;"===================================== "RTN","TMGNDF0A",458,0) ;"Log: "RTN","TMGNDF0A",459,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",460,0) "RTN","TMGNDF0A",461,0) new Info "RTN","TMGNDF0A",462,0) new result "RTN","TMGNDF0A",463,0) "RTN","TMGNDF0A",464,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",465,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",466,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",467,0) new temp set temp=$get(^TMG(22706.4,0)) "RTN","TMGNDF0A",468,0) kill ^TMG(22706.4) "RTN","TMGNDF0A",469,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",470,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",471,0) set ^TMG(22706.4,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",472,0) "RTN","TMGNDF0A",473,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",474,0) set Info("HFS FILE")="FORMULAT.TXT" "RTN","TMGNDF0A",475,0) set Info("DEST FILE")="TMG FDA FORMULATION" "RTN","TMGNDF0A",476,0) "RTN","TMGNDF0A",477,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",478,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",479,0) if result>0 set result=0 goto LFmDone "RTN","TMGNDF0A",480,0) "RTN","TMGNDF0A",481,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL: 1-7 "RTN","TMGNDF0A",482,0) ;"Linking field to LISTINGS. "RTN","TMGNDF0A",483,0) set Info(.01)=.01 ;"Listing "RTN","TMGNDF0A",484,0) set Info(.01,"START")=1 "RTN","TMGNDF0A",485,0) set Info(.01,"END")=7 "RTN","TMGNDF0A",486,0) "RTN","TMGNDF0A",487,0) ;"STRENGTH NULL CHAR(10) COL: 9-18 "RTN","TMGNDF0A",488,0) ;"This is the potency of the active ingredient. "RTN","TMGNDF0A",489,0) set Info(1)=1 ;"Strength "RTN","TMGNDF0A",490,0) set Info(1,"START")=9 "RTN","TMGNDF0A",491,0) set Info(1,"END")=18 "RTN","TMGNDF0A",492,0) "RTN","TMGNDF0A",493,0) ;"UNIT NULL CHAR(5) COL: 20-24 "RTN","TMGNDF0A",494,0) ;"Unit of measure corresponding to strength. "RTN","TMGNDF0A",495,0) set Info(2)=2 ;"Unit "RTN","TMGNDF0A",496,0) set Info(2,"START")=20 "RTN","TMGNDF0A",497,0) set Info(2,"END")=24 "RTN","TMGNDF0A",498,0) "RTN","TMGNDF0A",499,0) ;"INGREDIENT_NAME NOT NULL CHAR(100) COL: 26-125 "RTN","TMGNDF0A",500,0) ;"Truncated preferred term for the active ingredient. "RTN","TMGNDF0A",501,0) set Info(3)=3 ;"Ingredient Name "RTN","TMGNDF0A",502,0) set Info(3,"START")=26 "RTN","TMGNDF0A",503,0) set Info(3,"END")=125 "RTN","TMGNDF0A",504,0) "RTN","TMGNDF0A",505,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",506,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",507,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",508,0) "RTN","TMGNDF0A",509,0) LFmDone "RTN","TMGNDF0A",510,0) quit result "RTN","TMGNDF0A",511,0) "RTN","TMGNDF0A",512,0) "RTN","TMGNDF0A",513,0) LoadPackages(LoadDir) "RTN","TMGNDF0A",514,0) ;"Purpose: to load TMG FDA PACKAGES <--> packages.txt "RTN","TMGNDF0A",515,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",516,0) ;"Output: Kills any prior entries in TMG FDA FIRMS "RTN","TMGNDF0A",517,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",518,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",519,0) "RTN","TMGNDF0A",520,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",521,0) ;"===================================== "RTN","TMGNDF0A",522,0) ;"MAY OCCUR MULTIPLE TIMES PER LISTING SEQ NO "RTN","TMGNDF0A",523,0) ;"Stores packages for an individual listing. The packages table includes all packages for a corresponding listing. The PKGCODE field contains the last one or two digit segment of the NDC. "RTN","TMGNDF0A",524,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL: 1-7 "RTN","TMGNDF0A",525,0) ;" Linking field to LISTINGS. "RTN","TMGNDF0A",526,0) ;"PKGCODE NULL CHAR(2) COL: 9-10 "RTN","TMGNDF0A",527,0) ;" The package code portion of NDC code. The package code is the last segment of the NDC. "RTN","TMGNDF0A",528,0) ;"PACKSIZE NOT NULL CHAR(25) COL: 12-36 "RTN","TMGNDF0A",529,0) ;" The unit or number of units which make up a package. "RTN","TMGNDF0A",530,0) ;"PACKTYPE NOT NULL CHAR(25) COL: 38-62 "RTN","TMGNDF0A",531,0) ;" Package type, i.e., box, bottle, vial, plastic, or glass. "RTN","TMGNDF0A",532,0) ;"===================================== "RTN","TMGNDF0A",533,0) ;"Log: "RTN","TMGNDF0A",534,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",535,0) "RTN","TMGNDF0A",536,0) new Info "RTN","TMGNDF0A",537,0) new result "RTN","TMGNDF0A",538,0) "RTN","TMGNDF0A",539,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",540,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",541,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",542,0) new temp set temp=$get(^TMG(22706.6,0)) "RTN","TMGNDF0A",543,0) kill ^TMG(22706.6) "RTN","TMGNDF0A",544,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",545,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",546,0) set ^TMG(22706.6,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",547,0) "RTN","TMGNDF0A",548,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",549,0) set Info("HFS FILE")="packages.txt" "RTN","TMGNDF0A",550,0) set Info("DEST FILE")="TMG FDA PACKAGES" "RTN","TMGNDF0A",551,0) "RTN","TMGNDF0A",552,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",553,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",554,0) if result>0 set result=0 goto LPkDone "RTN","TMGNDF0A",555,0) "RTN","TMGNDF0A",556,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL: 1-7 "RTN","TMGNDF0A",557,0) ;"Linking field to LISTINGS. "RTN","TMGNDF0A",558,0) set Info(.01)=.01 ;"Listing "RTN","TMGNDF0A",559,0) set Info(.01,"START")=1 "RTN","TMGNDF0A",560,0) set Info(.01,"END")=7 "RTN","TMGNDF0A",561,0) "RTN","TMGNDF0A",562,0) ;"PKGCODE NULL CHAR(2) COL: 9-10 "RTN","TMGNDF0A",563,0) ;"The package code portion of NDC code. The package "RTN","TMGNDF0A",564,0) ;"code is the last segment of the NDC. "RTN","TMGNDF0A",565,0) set Info(1)=1 ;"Code "RTN","TMGNDF0A",566,0) set Info(1,"START")=9 "RTN","TMGNDF0A",567,0) set Info(1,"END")=10 "RTN","TMGNDF0A",568,0) "RTN","TMGNDF0A",569,0) ;"PACKSIZE NOT NULL CHAR(25) COL: 12-36 "RTN","TMGNDF0A",570,0) ;"The unit or number of units which make up a package. "RTN","TMGNDF0A",571,0) set Info(2)=2 ;"Size "RTN","TMGNDF0A",572,0) set Info(2,"START")=12 "RTN","TMGNDF0A",573,0) set Info(2,"END")=36 "RTN","TMGNDF0A",574,0) "RTN","TMGNDF0A",575,0) ;"PACKTYPE NOT NULL CHAR(25) COL: 38-62 "RTN","TMGNDF0A",576,0) ;"Package type, i.e., box, bottle, vial, plastic, or glass. "RTN","TMGNDF0A",577,0) set Info(3)=3 ;"Type "RTN","TMGNDF0A",578,0) set Info(3,"START")=38 "RTN","TMGNDF0A",579,0) set Info(3,"END")=62 "RTN","TMGNDF0A",580,0) "RTN","TMGNDF0A",581,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",582,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",583,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",584,0) "RTN","TMGNDF0A",585,0) LPkDone "RTN","TMGNDF0A",586,0) quit result "RTN","TMGNDF0A",587,0) "RTN","TMGNDF0A",588,0) "RTN","TMGNDF0A",589,0) LoadRoutes(LoadDir) "RTN","TMGNDF0A",590,0) ;"Purpose: to load TMG FDA ROUTES <--> ROUTES.TXT ;was routes.txt "RTN","TMGNDF0A",591,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",592,0) ;"Output: Kills any prior entries in TMG FDA FIRMS "RTN","TMGNDF0A",593,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",594,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",595,0) "RTN","TMGNDF0A",596,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",597,0) ;"===================================== "RTN","TMGNDF0A",598,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL:1-7 "RTN","TMGNDF0A",599,0) ;" Linking field to LISTINGS. "RTN","TMGNDF0A",600,0) ;"ROUTE_CODE NULL CHAR(3) COL:9-11 "RTN","TMGNDF0A",601,0) ;" The code for the route of administration. File will allow all assigned values for this element. "RTN","TMGNDF0A",602,0) ;"ROUTE_NAME NULL CHAR(240) COL:13-252 "RTN","TMGNDF0A",603,0) ;" The translation for the route of administration code. "RTN","TMGNDF0A",604,0) ;"===================================== "RTN","TMGNDF0A",605,0) ;"Log: "RTN","TMGNDF0A",606,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",607,0) "RTN","TMGNDF0A",608,0) new Info "RTN","TMGNDF0A",609,0) new result "RTN","TMGNDF0A",610,0) "RTN","TMGNDF0A",611,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",612,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",613,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",614,0) new temp set temp=$get(^TMG(22706.7,0)) "RTN","TMGNDF0A",615,0) kill ^TMG(22706.7) "RTN","TMGNDF0A",616,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",617,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",618,0) set ^TMG(22706.7,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",619,0) "RTN","TMGNDF0A",620,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",621,0) set Info("HFS FILE")="ROUTES.TXT" ;"was routes.txt "RTN","TMGNDF0A",622,0) set Info("DEST FILE")="TMG FDA ROUTES" "RTN","TMGNDF0A",623,0) "RTN","TMGNDF0A",624,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",625,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",626,0) if result>0 set result=0 goto LRtDone "RTN","TMGNDF0A",627,0) "RTN","TMGNDF0A",628,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL:1-7 "RTN","TMGNDF0A",629,0) ;"Linking field to LISTINGS. "RTN","TMGNDF0A",630,0) set Info(.01)=.01 ;"Listing "RTN","TMGNDF0A",631,0) set Info(.01,"START")=1 "RTN","TMGNDF0A",632,0) set Info(.01,"END")=7 "RTN","TMGNDF0A",633,0) "RTN","TMGNDF0A",634,0) ;"ROUTE_CODE NULL CHAR(3) COL:9-11 "RTN","TMGNDF0A",635,0) ;"The code for the route of administration. "RTN","TMGNDF0A",636,0) ;"File will allow all assigned values for this element. "RTN","TMGNDF0A",637,0) set Info(1)=1 ;"Code "RTN","TMGNDF0A",638,0) set Info(1,"START")=9 "RTN","TMGNDF0A",639,0) set Info(1,"END")=11 "RTN","TMGNDF0A",640,0) "RTN","TMGNDF0A",641,0) ;"ROUTE_NAME NULL CHAR(240) COL:13-252 "RTN","TMGNDF0A",642,0) ;"The translation for the route of administration code. "RTN","TMGNDF0A",643,0) set Info(2)=2 ;"Name "RTN","TMGNDF0A",644,0) set Info(2,"START")=13 "RTN","TMGNDF0A",645,0) set Info(2,"END")=252 "RTN","TMGNDF0A",646,0) "RTN","TMGNDF0A",647,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",648,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",649,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",650,0) "RTN","TMGNDF0A",651,0) LRtDone "RTN","TMGNDF0A",652,0) quit result "RTN","TMGNDF0A",653,0) "RTN","TMGNDF0A",654,0) "RTN","TMGNDF0A",655,0) LoadUnitAbbr(LoadDir) "RTN","TMGNDF0A",656,0) ;"Purpose: to load FDA UNIT ABBREVIATIONS <--> TBLUNIT.TXT ; was tblunit.txt "RTN","TMGNDF0A",657,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",658,0) ;"Output: Kills any prior entries in TMG FDA FIRMS "RTN","TMGNDF0A",659,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",660,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",661,0) "RTN","TMGNDF0A",662,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",663,0) ;"===================================== "RTN","TMGNDF0A",664,0) ;"THIS FILE CONTAINS A COMPLETE LIST OF THE POTENCY UNIT ABBREVIATIONS USED IN THE DIRECTORY. "RTN","TMGNDF0A",665,0) ;"UNIT CHAR(15) COL:1-15 "RTN","TMGNDF0A",666,0) ;" The potency unit abbreviations used in the directory. "RTN","TMGNDF0A",667,0) ;"TRANSLATION CHAR(100) COL:17-115 "RTN","TMGNDF0A",668,0) ;" The translation for the UNIT abbreviations. "RTN","TMGNDF0A",669,0) ;"===================================== "RTN","TMGNDF0A",670,0) ;"Log: "RTN","TMGNDF0A",671,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",672,0) "RTN","TMGNDF0A",673,0) new Info "RTN","TMGNDF0A",674,0) new result "RTN","TMGNDF0A",675,0) "RTN","TMGNDF0A",676,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",677,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",678,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",679,0) new temp set temp=$get(^TMG(22706.8,0)) "RTN","TMGNDF0A",680,0) kill ^TMG(22706.8) "RTN","TMGNDF0A",681,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",682,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",683,0) set ^TMG(22706.8,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",684,0) "RTN","TMGNDF0A",685,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",686,0) set Info("HFS FILE")="TBLUNIT.TXT" ;"was tblunit.txt "RTN","TMGNDF0A",687,0) set Info("DEST FILE")="FDA UNIT ABBREVIATIONS" "RTN","TMGNDF0A",688,0) "RTN","TMGNDF0A",689,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",690,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",691,0) if result>0 set result=0 goto LUADone "RTN","TMGNDF0A",692,0) "RTN","TMGNDF0A",693,0) ;"UNIT CHAR(15) COL:1-15 "RTN","TMGNDF0A",694,0) ;"The potency unit abbreviations used in the directory. "RTN","TMGNDF0A",695,0) set Info(.01)=.01 ;"Abbreviation "RTN","TMGNDF0A",696,0) set Info(.01,"START")=1 "RTN","TMGNDF0A",697,0) set Info(.01,"END")=15 "RTN","TMGNDF0A",698,0) "RTN","TMGNDF0A",699,0) ;"TRANSLATION CHAR(100) COL:17-115 "RTN","TMGNDF0A",700,0) ;"The translation for the UNIT abbreviations. "RTN","TMGNDF0A",701,0) set Info(1)=1 ;"Description "RTN","TMGNDF0A",702,0) set Info(1,"START")=17 "RTN","TMGNDF0A",703,0) set Info(1,"END")=115 ;"was 250 before "RTN","TMGNDF0A",704,0) "RTN","TMGNDF0A",705,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",706,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",707,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",708,0) "RTN","TMGNDF0A",709,0) LUADone "RTN","TMGNDF0A",710,0) quit result "RTN","TMGNDF0A",711,0) "RTN","TMGNDF0A",712,0) "RTN","TMGNDF0A",713,0) LoadListing(LoadDir) "RTN","TMGNDF0A",714,0) ;"Purpose: to load TMG FDA LISTING <--> listings.TXT ;was listings.txt "RTN","TMGNDF0A",715,0) ;"Input: LoadDir -- the directory in HFS to get files from "RTN","TMGNDF0A",716,0) ;"Output: Kills any prior entries in TMG FDA FIRMS "RTN","TMGNDF0A",717,0) ;"NOTICE: any pointers to this fill might me made invalid via kills "RTN","TMGNDF0A",718,0) ;"Result: 1=success, 0=error "RTN","TMGNDF0A",719,0) "RTN","TMGNDF0A",720,0) ;"FDA documentation for 9/12/2007 file: "RTN","TMGNDF0A",721,0) ;"===================================== "RTN","TMGNDF0A",722,0) ;"EACH PRODUCT HAS A UNIQUE LISTING SEQ NO; "RTN","TMGNDF0A",723,0) ;" EACH FIRM SEQ NO CAN HAVE MULTIPLE LISTING SEQ NO'S. "RTN","TMGNDF0A",724,0) ;" Each line in this file represents a product for an individual firm. "RTN","TMGNDF0A",725,0) ;" The listing includes such information as the product's name, firm's "RTN","TMGNDF0A",726,0) ;" seq number, dose form(s), and Rx/OTC. "RTN","TMGNDF0A",727,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL: 1-7 "RTN","TMGNDF0A",728,0) ;" FDA generated unique identification number for each product. "RTN","TMGNDF0A",729,0) ;"LBLCODE NOT NULL CHAR(6) COL: 9-14 "RTN","TMGNDF0A",730,0) ;" Labeler code portion of NDC; assigned by FDA to firm. "RTN","TMGNDF0A",731,0) ;" The labeler code is the first segment of the National Drug Code. "RTN","TMGNDF0A",732,0) ;" While always displayed as 6 digits in this file; for labeler codes 2 through 9999, "RTN","TMGNDF0A",733,0) ;" some systems display it as 4 digits; for labeler codes 10,000 through 99,999 it is 5 digits. "RTN","TMGNDF0A",734,0) ;" Can be used to link to the FIRMS.TXT file to obtain firm name. "RTN","TMGNDF0A",735,0) ;"PRODCODE NOT NULL CHAR(4) COL: 16-19 "RTN","TMGNDF0A",736,0) ;" Product code assigned by firm. The prodcode is the second segment of the National "RTN","TMGNDF0A",737,0) ;" Drug Code. It may be a 3-digit or 4-digit code depending upon the NDC configuration "RTN","TMGNDF0A",738,0) ;" selected by the firm. "RTN","TMGNDF0A",739,0) ;"STRENGTH NULL CHAR(10) COL: 21-30 "RTN","TMGNDF0A",740,0) ;" For single entity products, this is the potency of the active ingredient. For combination "RTN","TMGNDF0A",741,0) ;" products, it may be null or a number or combination of numbers, e.g., Inderide 40/25. "RTN","TMGNDF0A",742,0) ;"UNIT NULL CHAR(10) COL: 32-41 "RTN","TMGNDF0A",743,0) ;" Unit of measure corresponding to strength. This non-mandatory field contains the unit "RTN","TMGNDF0A",744,0) ;" code for a single entity product, e.g., MG, %VV. "RTN","TMGNDF0A",745,0) ;"RX_OTC NOT NULL CHAR(1) COL: 43 "RTN","TMGNDF0A",746,0) ;" Indicates whether product is labeled for Rx or OTC use (R/O). "RTN","TMGNDF0A",747,0) ;"TRADENAME NOT NULL CHAR(100) COL: 45-144 "RTN","TMGNDF0A",748,0) ;" Product's name as it appears on the labeling. "RTN","TMGNDF0A",749,0) ;"===================================== "RTN","TMGNDF0A",750,0) ;"Log: "RTN","TMGNDF0A",751,0) ;" 10/20/07 -- no modification needed for 9/12/07 database "RTN","TMGNDF0A",752,0) "RTN","TMGNDF0A",753,0) new Info "RTN","TMGNDF0A",754,0) new result "RTN","TMGNDF0A",755,0) "RTN","TMGNDF0A",756,0) ;"Note: should Kill all prior records... "RTN","TMGNDF0A",757,0) ;"Note: This will blow away ALL records, cross references etc. "RTN","TMGNDF0A",758,0) ;" This is not considered good programming practice! "RTN","TMGNDF0A",759,0) new temp set temp=$get(^TMG(22706.5,0)) "RTN","TMGNDF0A",760,0) kill ^TMG(22706.5) "RTN","TMGNDF0A",761,0) set $piece(temp,"^",3)="" "RTN","TMGNDF0A",762,0) set $piece(temp,"^",4)=0 "RTN","TMGNDF0A",763,0) set ^TMG(22706.5,0)=temp ;"fix up the 0 node "RTN","TMGNDF0A",764,0) "RTN","TMGNDF0A",765,0) set Info("HFS DIR")=$get(LoadDir) "RTN","TMGNDF0A",766,0) set Info("HFS FILE")="listings.TXT" ;"was listings.txt "RTN","TMGNDF0A",767,0) set Info("DEST FILE")="TMG FDA LISTING" "RTN","TMGNDF0A",768,0) "RTN","TMGNDF0A",769,0) new tempFile set tempFile=Info("HFS DIR")_Info("HFS FILE") "RTN","TMGNDF0A",770,0) set result=$$Dos2Unix^TMGIOUTL(tempFile) "RTN","TMGNDF0A",771,0) if result>0 set result=0 goto LLsDone "RTN","TMGNDF0A",772,0) "RTN","TMGNDF0A",773,0) ;"LISTING_SEQ_NO NOT NULL NUM(7) COL: 1-7 "RTN","TMGNDF0A",774,0) ;"FDA generated unique identification number for each product. "RTN","TMGNDF0A",775,0) set Info(.001)="IEN" ;"Sequence number "RTN","TMGNDF0A",776,0) set Info(.001,"START")=1 "RTN","TMGNDF0A",777,0) set Info(.001,"END")=7 "RTN","TMGNDF0A",778,0) "RTN","TMGNDF0A",779,0) set Info(.01)=.01 ;"Sequence number "RTN","TMGNDF0A",780,0) set Info(.01,"START")=1 "RTN","TMGNDF0A",781,0) set Info(.01,"END")=7 "RTN","TMGNDF0A",782,0) "RTN","TMGNDF0A",783,0) ;"LBLCODE NOT NULL CHAR(6) COL: 9-14 "RTN","TMGNDF0A",784,0) ;"Labeler code portion of NDC; assigned by FDA to firm. "RTN","TMGNDF0A",785,0) ;"The labeler code is the first segment of the National "RTN","TMGNDF0A",786,0) ;"Drug Code. While always displayed as 6 digits in this file; "RTN","TMGNDF0A",787,0) ;"for labeler codes 2 through 9999, some systems display it as "RTN","TMGNDF0A",788,0) ;"4 digits; for labeler codes 10,000 through 99,999 it is 5 digits. "RTN","TMGNDF0A",789,0) ;"Can be used to link to the FIRMS.TXT file to obtain firm name. "RTN","TMGNDF0A",790,0) set Info(1)=1 ;"Label Code "RTN","TMGNDF0A",791,0) set Info(1,"START")=9 "RTN","TMGNDF0A",792,0) set Info(1,"END")=14 "RTN","TMGNDF0A",793,0) "RTN","TMGNDF0A",794,0) ;"PRODCODE NOT NULL CHAR(4) COL: 16-19 "RTN","TMGNDF0A",795,0) ;"Product code assigned by firm. The prodcode is the second segment "RTN","TMGNDF0A",796,0) ;"of the National Drug Code (NDC). It may be a 3-digit or 4-digit "RTN","TMGNDF0A",797,0) ;"code depending upon the NDC configuration selected by the firm. "RTN","TMGNDF0A",798,0) set Info(2)=2 ;"Product Code "RTN","TMGNDF0A",799,0) set Info(2,"START")=16 "RTN","TMGNDF0A",800,0) set Info(2,"END")=19 "RTN","TMGNDF0A",801,0) "RTN","TMGNDF0A",802,0) ;"STRENGTH NULL CHAR(10) COL: 21-30 "RTN","TMGNDF0A",803,0) ;"For single entity products, this is the potency of the active ingredient. "RTN","TMGNDF0A",804,0) ;"For combination products, it may be null or a number or combination of "RTN","TMGNDF0A",805,0) ;"numbers, e.g., Inderide 40/25. "RTN","TMGNDF0A",806,0) set Info(3)=3 ;"Strength "RTN","TMGNDF0A",807,0) set Info(3,"START")=21 "RTN","TMGNDF0A",808,0) set Info(3,"END")=30 "RTN","TMGNDF0A",809,0) "RTN","TMGNDF0A",810,0) ;"UNIT NULL CHAR(10) COL: 32-41 "RTN","TMGNDF0A",811,0) ;"Unit of measure corresponding to strength. This non-mandatory field "RTN","TMGNDF0A",812,0) ;"contains the unit code for a single entity product, e.g., MG, %VV. "RTN","TMGNDF0A",813,0) set Info(4)=4 ;"Unit "RTN","TMGNDF0A",814,0) set Info(4,"START")=32 "RTN","TMGNDF0A",815,0) set Info(4,"END")=41 "RTN","TMGNDF0A",816,0) "RTN","TMGNDF0A",817,0) ;"RX_OTC NOT NULL CHAR(1) COL: 43 "RTN","TMGNDF0A",818,0) ;"Indicates whether product is labeled for Rx or OTC use (R/O). "RTN","TMGNDF0A",819,0) set Info(5)=5 ;"Rx or OTC "RTN","TMGNDF0A",820,0) set Info(5,"START")=43 "RTN","TMGNDF0A",821,0) set Info(5,"END")=43 "RTN","TMGNDF0A",822,0) "RTN","TMGNDF0A",823,0) ;"TRADENAME NOT NULL CHAR(100) COL: 45-144 "RTN","TMGNDF0A",824,0) ;"Product's name as it appears on the labeling. "RTN","TMGNDF0A",825,0) set Info(7)=7 ;"Trade name "RTN","TMGNDF0A",826,0) set Info(7,"START")=45 "RTN","TMGNDF0A",827,0) set Info(7,"END")=144 "RTN","TMGNDF0A",828,0) "RTN","TMGNDF0A",829,0) ;"NOTE: This field will be left blank, as it is not included in FDA "RTN","TMGNDF0A",830,0) ;" file here. It is really the same info as LBLCODE, i.e. the "RTN","TMGNDF0A",831,0) ;" Firm that makes drug can be determined from LBL code. "RTN","TMGNDF0A",832,0) ;"set Info(6)=6 ;"Firm "RTN","TMGNDF0A",833,0) ;"set Info(6,"START")=45 "RTN","TMGNDF0A",834,0) ;"set Info(6,"END")=51 "RTN","TMGNDF0A",835,0) "RTN","TMGNDF0A",836,0) new StartTime set StartTime=$H "RTN","TMGNDF0A",837,0) set result=$$DataImport(.Info,ProgressFn) "RTN","TMGNDF0A",838,0) do ProgressBar^TMGUSRIF(100,"Progress",0,100) "RTN","TMGNDF0A",839,0) "RTN","TMGNDF0A",840,0) LLL3 "RTN","TMGNDF0A",841,0) ;"Fix Firms Pointer "RTN","TMGNDF0A",842,0) ;"Note: the latest FDA export does not explicitly specify the Firm, "RTN","TMGNDF0A",843,0) ;" and only gives the label code. Thus the label code must be "RTN","TMGNDF0A",844,0) ;" used to look up the IEN for the firm, and this put into the "RTN","TMGNDF0A",845,0) ;" FIRM fiels (#6) "RTN","TMGNDF0A",846,0) "RTN","TMGNDF0A",847,0) new Itr,IEN "RTN","TMGNDF0A",848,0) set IEN=$$ItrInit^TMGITR(22706.5,.Itr) "RTN","TMGNDF0A",849,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF0A",850,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF0A",851,0) . new lblCode "RTN","TMGNDF0A",852,0) . set lblCode=$piece($get(^TMG(22706.5,IEN,0)),"^",2) "RTN","TMGNDF0A",853,0) . if lblCode="" quit "RTN","TMGNDF0A",854,0) . set lblCode=$$RJ^XLFSTR(lblCode,6,"0") "RTN","TMGNDF0A",855,0) . new IEN2 set IEN2=+$order(^TMG(22706.3,"C",lblCode,"")) "RTN","TMGNDF0A",856,0) . if IEN2'>0 quit "RTN","TMGNDF0A",857,0) . set $piece(^TMG(22706.5,IEN,0),"^",7)=IEN2 "RTN","TMGNDF0A",858,0) "RTN","TMGNDF0A",859,0) LLsDone "RTN","TMGNDF0A",860,0) quit result "RTN","TMGNDF0A",861,0) "RTN","TMGNDF0A",862,0) "RTN","TMGNDF0A",863,0) DataImport(Info,ProgressFN) "RTN","TMGNDF0A",864,0) ;"Purpose: to provide a generic loading utility, for importing data from a text file. "RTN","TMGNDF0A",865,0) ;" Note: this is more specific than code found in DDMP.m "RTN","TMGNDF0A",866,0) ;"Assumptions: that all data for one record is found on one line, with a given "RTN","TMGNDF0A",867,0) ;" number of columns for each field (i.e. not Comma-Separated-Values). "RTN","TMGNDF0A",868,0) ;"Input: Info, an array with relevent info. PASS BY REFERENCE "RTN","TMGNDF0A",869,0) ;" Format as follows: "RTN","TMGNDF0A",870,0) ;" Info("HFS DIR")= "RTN","TMGNDF0A",871,0) ;" Info("HFS FILE")= "RTN","TMGNDF0A",872,0) ;" Info("DEST FILE")= "RTN","TMGNDF0A",873,0) ;" Info(x)=field# (or "IEN" if data should be used to determine record number "RTN","TMGNDF0A",874,0) ;" Info(x,"START")=starting column "RTN","TMGNDF0A",875,0) ;" Info(x,"END")=ending column "RTN","TMGNDF0A",876,0) ;" ProgressFN: optional. If not "", then this will be XECUTED after each line "RTN","TMGNDF0A",877,0) ;" The following variables will be defined: "RTN","TMGNDF0A",878,0) ;" TMGTOTAL -- total number of records "RTN","TMGNDF0A",879,0) ;" TMGCUR -- current index of record being processed "RTN","TMGNDF0A",880,0) ;"Result: 1 if OK to continue, 0 if error "RTN","TMGNDF0A",881,0) "RTN","TMGNDF0A",882,0) ;"Note: input Data array will be formated like this: "RTN","TMGNDF0A",883,0) ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion "RTN","TMGNDF0A",884,0) ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," "RTN","TMGNDF0A",885,0) ;" Data(0,cRecNum)=2 <-- only if user-specified. "RTN","TMGNDF0A",886,0) ;" Data(0,cEntries)=1 "RTN","TMGNDF0A",887,0) ;" Data(1,".01")="MyData1" "RTN","TMGNDF0A",888,0) ;" Data(1,".01",cMatchValue)="MyData1" "RTN","TMGNDF0A",889,0) ;" Data(1,".02")="Bill" "RTN","TMGNDF0A",890,0) ;" Data(1,".02",cMatchValue)="John" "RTN","TMGNDF0A",891,0) ;" Data(1,".03")="MyData3" "RTN","TMGNDF0A",892,0) ;" Data(1,".04")="MyData4" "RTN","TMGNDF0A",893,0) ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" "RTN","TMGNDF0A",894,0) ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" "RTN","TMGNDF0A",895,0) ;" Data(1,".07",1,".01")="SubEntry1" "RTN","TMGNDF0A",896,0) ;" Data(1,".07",1,".02")="SE1" "RTN","TMGNDF0A",897,0) ;" Data(1,".07",1,".03")="'Some Info'" "RTN","TMGNDF0A",898,0) ;" Data(1,".07",2,".01")="SubEntry2" "RTN","TMGNDF0A",899,0) ;" Data(1,".07",2,".02")="SE2" "RTN","TMGNDF0A",900,0) ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 "RTN","TMGNDF0A",901,0) ;" Data(1,".07",2,".04",1,".01")="JD" "RTN","TMGNDF0A",902,0) ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" "RTN","TMGNDF0A",903,0) ;" ADDENDUM "RTN","TMGNDF0A",904,0) ;" Data(1,".01",cFlags)=any flags specified for given field. "RTN","TMGNDF0A",905,0) ;" only present if user specified. "RTN","TMGNDF0A",906,0) "RTN","TMGNDF0A",907,0) new cFile set cFile="FILE" "RTN","TMGNDF0A",908,0) new cRecNum set cRecNum="RECNUM" "RTN","TMGNDF0A",909,0) new result set result=1 "RTN","TMGNDF0A",910,0) new TMGTOTAL,TMGCUR "RTN","TMGNDF0A",911,0) "RTN","TMGNDF0A",912,0) new GRef set GRef=$name(^TMP("TMG","DATAIMPORT",$J)) "RTN","TMGNDF0A",913,0) new GRef1 set GRef1=$name(@GRef@(1)) ;"I have to use this to load file "RTN","TMGNDF0A",914,0) kill @GRef "RTN","TMGNDF0A",915,0) "RTN","TMGNDF0A",916,0) new result "RTN","TMGNDF0A",917,0) new dir set dir=$get(Info("HFS DIR")) "RTN","TMGNDF0A",918,0) new HFSfile set HFSfile=$get(Info("HFS FILE")) "RTN","TMGNDF0A",919,0) set result=$$FTG^%ZISH(dir,HFSfile,GRef1,4) "RTN","TMGNDF0A",920,0) if result=0 goto DIDone "RTN","TMGNDF0A",921,0) set TMGTOTAL=$order(@GRef@(""),-1) "RTN","TMGNDF0A",922,0) new file set file=$get(Info("DEST FILE")) "RTN","TMGNDF0A",923,0) if +file=0 set file=$$GetFileNum^TMGDBAPI(file) "RTN","TMGNDF0A",924,0) "RTN","TMGNDF0A",925,0) new index "RTN","TMGNDF0A",926,0) set index=$order(@GRef@("")) "RTN","TMGNDF0A",927,0) for do quit:(+index=0)!(result=0) "RTN","TMGNDF0A",928,0) . new RecData,TMGFDA "RTN","TMGNDF0A",929,0) . set RecData(0,cFile)=file "RTN","TMGNDF0A",930,0) . new line set line=$get(@GRef@(index)) "RTN","TMGNDF0A",931,0) . if $data(@GRef@(index,"OVF")) do "RTN","TMGNDF0A",932,0) . . new i set i=$order(@GRef@(index,"OVF","")) "RTN","TMGNDF0A",933,0) . . for do quit:(+i=0) "RTN","TMGNDF0A",934,0) . . . set line=line_$get(@GRef@(index,"OVF",i)) ;"note strings can be longer than 255 now "RTN","TMGNDF0A",935,0) . . . set i=$order(@GRef@(index,"OVF",i)) "RTN","TMGNDF0A",936,0) . new fields set fields=$order(Info("")) "RTN","TMGNDF0A",937,0) . new IEN set IEN="" "RTN","TMGNDF0A",938,0) . for do quit:(+fields=0)!(result=0) "RTN","TMGNDF0A",939,0) . . new fieldNum set fieldNum=$get(Info(fields)) ;"could be number or 'IEN' "RTN","TMGNDF0A",940,0) . . new oneField "RTN","TMGNDF0A",941,0) . . set oneField=$extract(line,$get(Info(fields,"START")),$get(Info(fields,"END"))) "RTN","TMGNDF0A",942,0) . . set oneField=$$Trim^TMGSTUTL(oneField) "RTN","TMGNDF0A",943,0) . . if fieldNum="IEN" do "RTN","TMGNDF0A",944,0) . . . set RecData(0,cRecNum)=oneField "RTN","TMGNDF0A",945,0) . . . set IEN=oneField "RTN","TMGNDF0A",946,0) . . else do "RTN","TMGNDF0A",947,0) . . . set RecData(1,fieldNum)=oneField "RTN","TMGNDF0A",948,0) . . set fields=$order(Info(fields)) "RTN","TMGNDF0A",949,0) . new MarkNum set MarkNum=0 "RTN","TMGNDF0A",950,0) . new MsgArray "RTN","TMGNDF0A",951,0) . set result=$$SetupFDA^TMGDBAPI(.RecData,.TMGFDA,,"+",.MarkNum,.MsgArray) "RTN","TMGNDF0A",952,0) . if result=0 quit "RTN","TMGNDF0A",953,0) . new TMGIEN "RTN","TMGNDF0A",954,0) . if IEN'=0 do "RTN","TMGNDF0A",955,0) . . if +IEN>0 set TMGIEN(1)=IEN "RTN","TMGNDF0A",956,0) . . set result=$$dbWrite^TMGDBAPI(.TMGFDA,0,.TMGIEN," ") "RTN","TMGNDF0A",957,0) . if result=0 quit "RTN","TMGNDF0A",958,0) . if $get(ProgressFN)'="" do "RTN","TMGNDF0A",959,0) . . set TMGCUR=index "RTN","TMGNDF0A",960,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGNDF0A",961,0) . . xecute ProgressFN "RTN","TMGNDF0A",962,0) . set index=$order(@GRef@(index)) "RTN","TMGNDF0A",963,0) "RTN","TMGNDF0A",964,0) DIDone "RTN","TMGNDF0A",965,0) kill @GRef "RTN","TMGNDF0A",966,0) quit result "RTN","TMGNDF0A",967,0) "RTN","TMGNDF0A",968,0) "RTN","TMGNDF0A",969,0) SetSkipFlag "RTN","TMGNDF0A",970,0) ;"Purpose: To review entries in TMG FDA IMPORT COMPILED and determine which "RTN","TMGNDF0A",971,0) ;" of those need to have the SKIP THIS RECORD flag set. "RTN","TMGNDF0A",972,0) ;" The following records will be SKIPPED: "RTN","TMGNDF0A",973,0) ;" -- If there is an entry in the VA PRODUCT MATCHES field. This would "RTN","TMGNDF0A",974,0) ;" mean that there is ALREADY an entry in the database for this "RTN","TMGNDF0A",975,0) ;" drug, and it will not need to be added. "RTN","TMGNDF0A",976,0) ;" -- If there are no entries in the INGREDIENTS field. This is because if "RTN","TMGNDF0A",977,0) ;" the FDA database does not list ingredients for a drug, I believe it "RTN","TMGNDF0A",978,0) ;" is because it is not an active drug (otherwise the FDA would require "RTN","TMGNDF0A",979,0) ;" full information), and there is very likely another drug entry for "RTN","TMGNDF0A",980,0) ;" this same drug that DOES have the ingredients. "RTN","TMGNDF0A",981,0) ;"Note: This function is planned to be run after CompileAll^TMGNDF2AA "RTN","TMGNDF0A",982,0) "RTN","TMGNDF0A",983,0) new IEN "RTN","TMGNDF0A",984,0) new NumSkipped,NumNotSkipped,NoIngreds "RTN","TMGNDF0A",985,0) set NumSkipped=0,NumNotSkipped=0,NoIngreds=0 "RTN","TMGNDF0A",986,0) "RTN","TMGNDF0A",987,0) set IEN=$order(^TMG(22706.9,0)) "RTN","TMGNDF0A",988,0) if +IEN>0 for do quit:(+IEN'>0) "RTN","TMGNDF0A",989,0) . new name set name=$piece($get(^TMG(22706.9,IEN,0)),"^",4) "RTN","TMGNDF0A",990,0) . new NumIngreds set NumIngreds=0 "RTN","TMGNDF0A",991,0) . new SkipThisOne set SkipThisOne=0 "RTN","TMGNDF0A",992,0) . ;"See if there are entries in the VA PRODUCT MATCHES field (node 2) "RTN","TMGNDF0A",993,0) . new ProdMatches set ProdMatches=+$piece($get(^TMG(22706.9,IEN,2,0)),"^",4) ;"piece 4 of 0 node is number of entries. "RTN","TMGNDF0A",994,0) . if ProdMatches>0 set SkipThisOne=1 "RTN","TMGNDF0A",995,0) . ;"See if there are NO entries in the INGREDIENTS field (node 4) "RTN","TMGNDF0A",996,0) . set NumIngreds=+$piece($get(^TMG(22706.9,IEN,4,0)),"^",4) ;"piece 4 of 0 node is number of entries. "RTN","TMGNDF0A",997,0) . if NumIngreds=0 set SkipThisOne=1,NoIngreds=NoIngreds+1 "RTN","TMGNDF0A",998,0) . if SkipThisOne set NumSkipped=NumSkipped+1 "RTN","TMGNDF0A",999,0) . else set NumNotSkipped=NumNotSkipped+1 "RTN","TMGNDF0A",1000,0) . set $piece(^TMG(22706.9,IEN,1),"^",4)=SkipThisOne "RTN","TMGNDF0A",1001,0) . ;"write " matches=",ProdMatches," ingredients=",NumIngreds," ",name,! "RTN","TMGNDF0A",1002,0) . set IEN=$order(^TMG(22706.9,IEN)) "RTN","TMGNDF0A",1003,0) "RTN","TMGNDF0A",1004,0) write !,"There are ",NumSkipped," entries that are will be skipped.",! "RTN","TMGNDF0A",1005,0) write " (",NoIngreds," with no ingredients)",! "RTN","TMGNDF0A",1006,0) write " (",NumSkipped-NoIngreds," already in the database)",! "RTN","TMGNDF0A",1007,0) write "There are ",NumNotSkipped," new entries to be added.",! "RTN","TMGNDF0A",1008,0) "RTN","TMGNDF0A",1009,0) quit "RTN","TMGNDF0A",1010,0) "RTN","TMGNDF0A",1011,0) "RTN","TMGNDF0A",1012,0) Backup "RTN","TMGNDF0A",1013,0) ;"Purpose: To backup files to a temporary global "RTN","TMGNDF0A",1014,0) "RTN","TMGNDF0A",1015,0) new dateCode set dateCode="1/15/07" "RTN","TMGNDF0A",1016,0) "RTN","TMGNDF0A",1017,0) new src,dest,i "RTN","TMGNDF0A",1018,0) "RTN","TMGNDF0A",1019,0) for i=1:1:8 do "RTN","TMGNDF0A",1020,0) . set src="^TMG(22706."_i_")" "RTN","TMGNDF0A",1021,0) . set dest=$name(^TMG("TMP",src_" "_dateCode)) "RTN","TMGNDF0A",1022,0) . write "merging ",src," into ",dest,! "RTN","TMGNDF0A",1023,0) . merge @dest=@src "RTN","TMGNDF0A",1024,0) "RTN","TMGNDF0A",1025,0) quit "RTN","TMGNDF0B") 0^36^B6565 "RTN","TMGNDF0B",1,0) TMGNDF0B ;TMG/kst/FDA Import: Display FDA files ;03/25/06 "RTN","TMGNDF0B",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF0B",3,0) "RTN","TMGNDF0B",4,0) ;" FDA - NATIONAL DRUG FILES DISPLAY FUNCTIONS "RTN","TMGNDF0B",5,0) ;"Kevin Toppenberg MD "RTN","TMGNDF0B",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF0B",7,0) ;"11-21-2006 "RTN","TMGNDF0B",8,0) "RTN","TMGNDF0B",9,0) ;"======================================================================= "RTN","TMGNDF0B",10,0) ;" API -- Public Functions. "RTN","TMGNDF0B",11,0) ;"======================================================================= "RTN","TMGNDF0B",12,0) ;"ShowDrug "RTN","TMGNDF0B",13,0) ;"ShowAll "RTN","TMGNDF0B",14,0) ;"CountAll "RTN","TMGNDF0B",15,0) ;"Show1Drug(IEN,Index) "RTN","TMGNDF0B",16,0) "RTN","TMGNDF0B",17,0) ;"======================================================================= "RTN","TMGNDF0B",18,0) ;" Private Functions. "RTN","TMGNDF0B",19,0) ;"======================================================================= "RTN","TMGNDF0B",20,0) ;"AskCompile "RTN","TMGNDF0B",21,0) ;"CompByTemplate "RTN","TMGNDF0B",22,0) ;"ShowTemplate "RTN","TMGNDF0B",23,0) "RTN","TMGNDF0B",24,0) ;"ShowNDCConflict(Array,IEN2) "RTN","TMGNDF0B",25,0) ;"FormatDrug(Array) "RTN","TMGNDF0B",26,0) ;"Format2Drug(Array) "RTN","TMGNDF0B",27,0) ;"Format3Drug(Array) "RTN","TMGNDF0B",28,0) "RTN","TMGNDF0B",29,0) "RTN","TMGNDF0B",30,0) ;"======================================================================= "RTN","TMGNDF0B",31,0) ;"======================================================================= "RTN","TMGNDF0B",32,0) Menu "RTN","TMGNDF0B",33,0) ;"Purpose: To give an interactive menu "RTN","TMGNDF0B",34,0) "RTN","TMGNDF0B",35,0) new Menu,UsrSlct "RTN","TMGNDF0B",36,0) set Menu(0)="Pick Option for Optional Utilities (0B)" "RTN","TMGNDF0B",37,0) set Menu(1)="Show Drugs from FDA Tables"_$char(9)_"ShowAll" "RTN","TMGNDF0B",38,0) set Menu(3)="Show ONE Drug from FDA Tables"_$char(9)_"ShowOne" "RTN","TMGNDF0B",39,0) set Menu(2)="Count Drugs from FDA Tables"_$char(9)_"CountAll" "RTN","TMGNDF0B",40,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF0B",41,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF0B",42,0) "RTN","TMGNDF0B",43,0) CD1 "RTN","TMGNDF0B",44,0) write # "RTN","TMGNDF0B",45,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF0B",46,0) if UsrSlct="^" goto CDDone "RTN","TMGNDF0B",47,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF0B",48,0) "RTN","TMGNDF0B",49,0) if UsrSlct="Prev" goto Menu^TMGNDF0A ;"quit can occur from there... "RTN","TMGNDF0B",50,0) if UsrSlct="Next" goto Menu^TMGNDF0C ;"quit can occur from there... "RTN","TMGNDF0B",51,0) if UsrSlct="ShowAll" do ShowAll goto CD1 "RTN","TMGNDF0B",52,0) if UsrSlct="ShowOne" do ShowDrug goto CD1 "RTN","TMGNDF0B",53,0) if UsrSlct="CountAll" do CountAll goto CD1 "RTN","TMGNDF0B",54,0) goto CD1 "RTN","TMGNDF0B",55,0) CDDone "RTN","TMGNDF0B",56,0) quit "RTN","TMGNDF0B",57,0) "RTN","TMGNDF0B",58,0) ;"======================================================================= "RTN","TMGNDF0B",59,0) "RTN","TMGNDF0B",60,0) ShowDrug "RTN","TMGNDF0B",61,0) ;"Purpose: to ask for an IEN, and then show drug "RTN","TMGNDF0B",62,0) ;" i.e. IEN from TMG FDA LISTING "RTN","TMGNDF0B",63,0) "RTN","TMGNDF0B",64,0) new IEN,pIndex "RTN","TMGNDF0B",65,0) set pIndex=$$GetpVAPIndex^TMGNDF1A() "RTN","TMGNDF0B",66,0) "RTN","TMGNDF0B",67,0) loop read "Enter IEN number (^ to quit) ^// ",IEN:$get(DTIME,3600),! "RTN","TMGNDF0B",68,0) if IEN="" set IEN="^" "RTN","TMGNDF0B",69,0) if IEN="^" goto SDDone "RTN","TMGNDF0B",70,0) do Show1Drug(IEN,.Index) "RTN","TMGNDF0B",71,0) goto loop "RTN","TMGNDF0B",72,0) "RTN","TMGNDF0B",73,0) SDDone "RTN","TMGNDF0B",74,0) quit "RTN","TMGNDF0B",75,0) "RTN","TMGNDF0B",76,0) "RTN","TMGNDF0B",77,0) Show1Drug(IEN,pIndex) "RTN","TMGNDF0B",78,0) ;"Purpose: to show drug from TMG FDA LISTING "RTN","TMGNDF0B",79,0) ;"Input: IEN -- IEN from TMG FDA LISTING file "RTN","TMGNDF0B",80,0) ;" Index -- PASS BY NAME -- OPTIONAL "RTN","TMGNDF0B",81,0) ;" This is an index as returned by IndexVAProd^TMGNDF1A("Index") "RTN","TMGNDF0B",82,0) ;" If not passed, then it will be filled here. "RTN","TMGNDF0B",83,0) ;"Results: none "RTN","TMGNDF0B",84,0) "RTN","TMGNDF0B",85,0) new Array,result "RTN","TMGNDF0B",86,0) if $get(pIndex)="" set pIndex=$$GetpVAPIndex^TMGNDF1A() "RTN","TMGNDF0B",87,0) "RTN","TMGNDF0B",88,0) set result=$$GetDrugInfo^TMGNDF1A(IEN,.Array,pIndex) "RTN","TMGNDF0B",89,0) if (result=1)&($data(Array)'=0) do "RTN","TMGNDF0B",90,0) . write !,"-----------------------------------------",! "RTN","TMGNDF0B",91,0) . zwr Array(*) "RTN","TMGNDF0B",92,0) quit "RTN","TMGNDF0B",93,0) "RTN","TMGNDF0B",94,0) "RTN","TMGNDF0B",95,0) ShowAll "RTN","TMGNDF0B",96,0) ;"Purpose: to show all drugs "RTN","TMGNDF0B",97,0) "RTN","TMGNDF0B",98,0) new count set count=1 "RTN","TMGNDF0B",99,0) new Array "RTN","TMGNDF0B",100,0) new temp set temp=" " "RTN","TMGNDF0B",101,0) new result set result=1 "RTN","TMGNDF0B",102,0) new Matches "RTN","TMGNDF0B",103,0) "RTN","TMGNDF0B",104,0) new pIndex set pIndex=$$GetpVAPIndex^TMGNDF1A() "RTN","TMGNDF0B",105,0) "RTN","TMGNDF0B",106,0) SADloop "RTN","TMGNDF0B",107,0) kill Array "RTN","TMGNDF0B",108,0) "RTN","TMGNDF0B",109,0) ;"2/13/07 note: the call to GetDrugInfo below looks wrong. I have made changes "RTN","TMGNDF0B",110,0) ;" to the location of functions. I think this needs to be reassessed... "RTN","TMGNDF0B",111,0) if $$GetDrugInfo^TMGNDF1A(count,.Array,pIndex) do "RTN","TMGNDF0B",112,0) . new numMatch set numMatch=+$get(Array("FILE 50.68 IEN","COUNT")) "RTN","TMGNDF0B",113,0) . new numPMatch set numPMatch=+$get(Array("FILE 50.68 IEN","POSS MATCH","COUNT")) "RTN","TMGNDF0B",114,0) . set Matches(numMatch,numPMatch)=$get(Matches(numMatch,numPMatch))+1 "RTN","TMGNDF0B",115,0) . write count,": " "RTN","TMGNDF0B",116,0) . do Format2Drug(.Array) "RTN","TMGNDF0B",117,0) . quit "RTN","TMGNDF0B",118,0) . write "Type ^ to abort, to pause",! "RTN","TMGNDF0B",119,0) . if +$get(Array("FILE 50.68 IEN","COUNT"))=0 do "RTN","TMGNDF0B",120,0) . . write "No MATCH in VA PRODUCT file",! "RTN","TMGNDF0B",121,0) . else if +$get(Array("FILE 50.68 IEN","COUNT"))>1 do "RTN","TMGNDF0B",122,0) . . write "MULTIPLE matches found in VA PRODUCT file",! "RTN","TMGNDF0B",123,0) . . zwr Array("FILE 50.68 IEN",*) "RTN","TMGNDF0B",124,0) . else if +$get(Array("FILE 50.68 IEN","COUNT"))>1 do "RTN","TMGNDF0B",125,0) . . write "1 match found.",! "RTN","TMGNDF0B",126,0) else set temp="^" "RTN","TMGNDF0B",127,0) "RTN","TMGNDF0B",128,0) read temp:0.25 "RTN","TMGNDF0B",129,0) if temp=" " do "RTN","TMGNDF0B",130,0) . read "Press to continue (or ^ to abort) ",temp,! "RTN","TMGNDF0B",131,0) set count=count+1 "RTN","TMGNDF0B",132,0) if temp="^" goto SD2Done "RTN","TMGNDF0B",133,0) "RTN","TMGNDF0B",134,0) goto SADloop "RTN","TMGNDF0B",135,0) "RTN","TMGNDF0B",136,0) SD2Done "RTN","TMGNDF0B",137,0) write "Here is the cumulative results of couting matches",! "RTN","TMGNDF0B",138,0) write "Matches(Matches,PossMatches)=count",! "RTN","TMGNDF0B",139,0) zwr Matches(*) "RTN","TMGNDF0B",140,0) quit "RTN","TMGNDF0B",141,0) "RTN","TMGNDF0B",142,0) "RTN","TMGNDF0B",143,0) CountAll "RTN","TMGNDF0B",144,0) ;"Purpose: to ask for an IEN, and then show drug "RTN","TMGNDF0B",145,0) "RTN","TMGNDF0B",146,0) new count set count=20000 "RTN","TMGNDF0B",147,0) new Array "RTN","TMGNDF0B",148,0) new temp set temp=" " "RTN","TMGNDF0B",149,0) new result set result=1 "RTN","TMGNDF0B",150,0) new Matches "RTN","TMGNDF0B",151,0) new showCount set showCount=0 "RTN","TMGNDF0B",152,0) new MaxIEN set MaxIEN=$piece($get(^TMG(22706.5,0)),"^",3) "RTN","TMGNDF0B",153,0) new abort set abort=0 "RTN","TMGNDF0B",154,0) "RTN","TMGNDF0B",155,0) CADloop "RTN","TMGNDF0B",156,0) for count=1:1:MaxIEN do quit:(abort=1) "RTN","TMGNDF0B",157,0) . kill Array "RTN","TMGNDF0B",158,0) . if $$GetDrugInfo^TMGNDF1A(count,.Array)=1 do "RTN","TMGNDF0B",159,0) . . new numMatch set numMatch=+$get(Array("FILE 50.68 IEN","COUNT")) "RTN","TMGNDF0B",160,0) . . new numPMatch set numPMatch=+$get(Array("FILE 50.68 IEN","POSS MATCH","COUNT")) "RTN","TMGNDF0B",161,0) . . set Matches(numMatch,numPMatch)=$get(Matches(numMatch,numPMatch))+1 "RTN","TMGNDF0B",162,0) . . if $get(Array("NDC","NOTE"))'="" do "RTN","TMGNDF0B",163,0) . . . write count,"--> ",Array("NDC","NOTE"),! "RTN","TMGNDF0B",164,0) . . . new badIEN set badIEN=+$piece(Array("NDC","NOTE"),"=",2) "RTN","TMGNDF0B",165,0) . . . do ShowNDCConflict(.Array,badIEN) "RTN","TMGNDF0B",166,0) . . . read temp:0.25 "RTN","TMGNDF0B",167,0) . . . if temp=" " do "RTN","TMGNDF0B",168,0) . . . . read "Press to continue (or ^ to abort) ",temp,! "RTN","TMGNDF0B",169,0) . . . . if temp="^" set abort=1 "RTN","TMGNDF0B",170,0) . . set showCount=showCount+1 "RTN","TMGNDF0B",171,0) . . if showCount=100 do "RTN","TMGNDF0B",172,0) . . . set showCount=0 "RTN","TMGNDF0B",173,0) . . . write count,": " "RTN","TMGNDF0B",174,0) . . . do Format2Drug(.Array) "RTN","TMGNDF0B",175,0) "RTN","TMGNDF0B",176,0) CADDone "RTN","TMGNDF0B",177,0) write "Here is the cumulative results of couting matches",! "RTN","TMGNDF0B",178,0) write "Matches(Matches,PossMatches)=count",! "RTN","TMGNDF0B",179,0) zwr Matches(*) "RTN","TMGNDF0B",180,0) quit "RTN","TMGNDF0B",181,0) "RTN","TMGNDF0B",182,0) "RTN","TMGNDF0B",183,0) "RTN","TMGNDF0B",184,0) FormatDrug(Array) "RTN","TMGNDF0B",185,0) "RTN","TMGNDF0B",186,0) if '$data(Array) quit "RTN","TMGNDF0B",187,0) new i "RTN","TMGNDF0B",188,0) write $get(Array("TRADENAME")),"; " "RTN","TMGNDF0B",189,0) write $get(Array("STRENGTH")),"; " "RTN","TMGNDF0B",190,0) write $get(Array("UNIT")),"; " "RTN","TMGNDF0B",191,0) set i=$order(Array("DOSE","")) "RTN","TMGNDF0B",192,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF0B",193,0) . write $get(Array("DOSE",i,"DOSAGE NAME"))," " "RTN","TMGNDF0B",194,0) . set i=$order(Array("DOSE",i)) "RTN","TMGNDF0B",195,0) write ! "RTN","TMGNDF0B",196,0) set i=$order(Array("FORMULATION","")) "RTN","TMGNDF0B",197,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF0B",198,0) . write " ingredients: ",$get(Array("FORMULATION",i,"INGREDIENT NAME")),"; " "RTN","TMGNDF0B",199,0) . write $get(Array("FORMULATION",i,"STRENGTH")),"; " "RTN","TMGNDF0B",200,0) . write $get(Array("FORMULATION",i,"UNIT")),! "RTN","TMGNDF0B",201,0) . set i=$order(Array("FORMULATION",i)) "RTN","TMGNDF0B",202,0) "RTN","TMGNDF0B",203,0) quit "RTN","TMGNDF0B",204,0) "RTN","TMGNDF0B",205,0) Format2Drug(Array) "RTN","TMGNDF0B",206,0) "RTN","TMGNDF0B",207,0) new s "RTN","TMGNDF0B",208,0) if '$data(Array) quit "RTN","TMGNDF0B",209,0) new i "RTN","TMGNDF0B",210,0) "RTN","TMGNDF0B",211,0) set s="m="_$get(Array("FILE 50.68 IEN","COUNT"),0)_";" "RTN","TMGNDF0B",212,0) set s=s_"lm="_$get(Array("FILE 50.68 IEN","POSS MATCH","COUNT"),0)_" " "RTN","TMGNDF0B",213,0) ;"Array("FILE 50.68 IEN","LOOSE MATCH","COUNT")=1 "RTN","TMGNDF0B",214,0) set s=s_$get(Array("TRADENAME"))_" " "RTN","TMGNDF0B",215,0) set s=s_$get(Array("STRENGTH"))_" " "RTN","TMGNDF0B",216,0) set s=s_$get(Array("UNIT"))_" " "RTN","TMGNDF0B",217,0) set i=$order(Array("DOSE","")) "RTN","TMGNDF0B",218,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF0B",219,0) . set s=s_$get(Array("DOSE",i,"DOSAGE NAME"))_" " "RTN","TMGNDF0B",220,0) . set i=$order(Array("DOSE",i)) "RTN","TMGNDF0B",221,0) "RTN","TMGNDF0B",222,0) write $extract(s,1,60),! "RTN","TMGNDF0B",223,0) "RTN","TMGNDF0B",224,0) "RTN","TMGNDF0B",225,0) if $get(Array("FORMULATION",1,"STRENGTH"))="" do "RTN","TMGNDF0B",226,0) . if $get(Array("STRENGTH"))'="" do "RTN","TMGNDF0B",227,0) . . write "Note: Ingredient #1 strength is empty, but Overall strength=" "RTN","TMGNDF0B",228,0) . . write $get(Array("STRENGTH")),! "RTN","TMGNDF0B",229,0) "RTN","TMGNDF0B",230,0) quit "RTN","TMGNDF0B",231,0) "RTN","TMGNDF0B",232,0) "RTN","TMGNDF0B",233,0) Format3Drug(Array) "RTN","TMGNDF0B",234,0) ;"Purpose: show match, only if 0 matches and >0 possible matches "RTN","TMGNDF0B",235,0) "RTN","TMGNDF0B",236,0) new s "RTN","TMGNDF0B",237,0) if '$data(Array) quit "RTN","TMGNDF0B",238,0) new i "RTN","TMGNDF0B",239,0) if $get(Array("FILE 50.68 IEN","COUNT"),0)'=0 quit "RTN","TMGNDF0B",240,0) if $get(Array("FILE 50.68 IEN","POSS MATCH","COUNT"),0)'>0 quit "RTN","TMGNDF0B",241,0) "RTN","TMGNDF0B",242,0) do Format2Drug(.Array) "RTN","TMGNDF0B",243,0) "RTN","TMGNDF0B",244,0) set i=$order(Array("FILE 50.68 IEN","POSS MATCH","")) "RTN","TMGNDF0B",245,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF0B",246,0) . new Msg set Msg=$get(Array("FILE 50.68 IEN","POSS MATCH",i,"MSG")) "RTN","TMGNDF0B",247,0) . new Problem set Problem=$get(Array("FILE 50.68 IEN","POSS MATCH",i,"PROBLEM")) "RTN","TMGNDF0B",248,0) . new IEN set IEN=$get(Array("FILE 50.68 IEN","POSS MATCH",i)) "RTN","TMGNDF0B",249,0) . write IEN,": ",Problem,"(",Msg,")",! "RTN","TMGNDF0B",250,0) . set i=$order(Array("FILE 50.68 IEN","POSS MATCH",i)) "RTN","TMGNDF0B",251,0) "RTN","TMGNDF0B",252,0) quit "RTN","TMGNDF0B",253,0) "RTN","TMGNDF0B",254,0) "RTN","TMGNDF0B",255,0) ShowNDCConflict(Array,IEN2) "RTN","TMGNDF0B",256,0) ;"Purpose: show two drug entries that have same NDC's, but differing drug properties "RTN","TMGNDF0B",257,0) ;"Input: Array -- PASS BY REFERENECE -- data with DrugIfno (from GetDrugInfo) "RTN","TMGNDF0B",258,0) ;" IEN2: the IEN from file VA PRODUCT (50.68) "RTN","TMGNDF0B",259,0) "RTN","TMGNDF0B",260,0) "RTN","TMGNDF0B",261,0) write "Here is TMG FDA* data:",! "RTN","TMGNDF0B",262,0) do FormatDrug(.Array) "RTN","TMGNDF0B",263,0) write ! "RTN","TMGNDF0B",264,0) "RTN","TMGNDF0B",265,0) write "Here is VA Product data:",! "RTN","TMGNDF0B",266,0) new VAArray "RTN","TMGNDF0B",267,0) do GetVADrugInfo^TMGNDF1C(IEN2,.VAArray) "RTN","TMGNDF0B",268,0) do FormatDrug(.VAArray) "RTN","TMGNDF0B",269,0) "RTN","TMGNDF0B",270,0) write !! "RTN","TMGNDF0B",271,0) quit "RTN","TMGNDF0B",272,0) "RTN","TMGNDF0B",273,0) "RTN","TMGNDF0B",274,0) AskCompile "RTN","TMGNDF0B",275,0) ;"Purpose: To ask for an Entry number from 22706.5 and add drug to compiled file "RTN","TMGNDF0B",276,0) "RTN","TMGNDF0B",277,0) new IEN "RTN","TMGNDF0B",278,0) "RTN","TMGNDF0B",279,0) for do quit:(+IEN'=IEN) "RTN","TMGNDF0B",280,0) . read "Type in Entry Number (^ to abort): ",IEN:$get(DTIME,3600),! "RTN","TMGNDF0B",281,0) . if +IEN'=IEN quit "RTN","TMGNDF0B",282,0) . do CompileOne^TMGNDF1C(IEN) "RTN","TMGNDF0B",283,0) "RTN","TMGNDF0B",284,0) quit "RTN","TMGNDF0B",285,0) "RTN","TMGNDF0B",286,0) CompByTemplate "RTN","TMGNDF0B",287,0) ;"Purpose: To ask for a SORT TEMPLATE, and compile the records for IENs stored there. "RTN","TMGNDF0B",288,0) "RTN","TMGNDF0B",289,0) new pIndex set pIndex=$$GetpVAPIndex^TMGNDF1A() "RTN","TMGNDF0B",290,0) "RTN","TMGNDF0B",291,0) new IEN,Template "RTN","TMGNDF0B",292,0) new DIC,X,Y "RTN","TMGNDF0B",293,0) set DIC=.401 "RTN","TMGNDF0B",294,0) set DIC("A")="Enter a SORT TEMPLATE to compile FDA entries from: " "RTN","TMGNDF0B",295,0) set DIC(0)="AEQM" "RTN","TMGNDF0B",296,0) do ^DIC "RTN","TMGNDF0B",297,0) if +Y'>0 goto CBTDone "RTN","TMGNDF0B",298,0) set Template=+Y "RTN","TMGNDF0B",299,0) "RTN","TMGNDF0B",300,0) new TMGTOTAL set TMGTOTAL=$$CtTemplate^TMGMISC(Template) "RTN","TMGNDF0B",301,0) new StartTime set StartTime=$H "RTN","TMGNDF0B",302,0) new ProgressFn "RTN","TMGNDF0B",303,0) set ProgressFn="if count#10=1 do ProgressBar^TMGUSRIF(count,""Progress"",0,TMGTOTAL,,StartTime)" "RTN","TMGNDF0B",304,0) set IEN="" "RTN","TMGNDF0B",305,0) new count set count=0 "RTN","TMGNDF0B",306,0) for do quit:(+IEN'>0) "RTN","TMGNDF0B",307,0) . set IEN=$$IterTemplate^TMGMISC(Template,IEN) "RTN","TMGNDF0B",308,0) . if +IEN'>0 quit "RTN","TMGNDF0B",309,0) . ;"write IEN,! "RTN","TMGNDF0B",310,0) . do CompileOne^TMGNDF1C(IEN,0,pIndex) "RTN","TMGNDF0B",311,0) . set count=count+1 "RTN","TMGNDF0B",312,0) . if $get(ProgressFn)'="" do "RTN","TMGNDF0B",313,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGNDF0B",314,0) . . xecute ProgressFn "RTN","TMGNDF0B",315,0) "RTN","TMGNDF0B",316,0) CBTDone "RTN","TMGNDF0B",317,0) quit "RTN","TMGNDF0B",318,0) "RTN","TMGNDF0B",319,0) "RTN","TMGNDF0B",320,0) MkGenAll "RTN","TMGNDF0B",321,0) ;"Purpose: To fill in the GENERIC NAME field for record for all records in file "RTN","TMGNDF0B",322,0) ;"Input: none "RTN","TMGNDF0B",323,0) ;"Output: The file 22706.9 (TMG FDA IMPORT COMPILED) has records added. "RTN","TMGNDF0B",324,0) ;"Result: none "RTN","TMGNDF0B",325,0) "RTN","TMGNDF0B",326,0) new IEN set IEN=0 "RTN","TMGNDF0B",327,0) new Array,result,temp "RTN","TMGNDF0B",328,0) new Interval set Interval=0 "RTN","TMGNDF0B",329,0) new abort set abort=0 "RTN","TMGNDF0B",330,0) new TMGTOTAL set TMGTOTAL=$piece($get(^TMG(22706.5,0)),"^",3) "RTN","TMGNDF0B",331,0) new StartTime set StartTime=$H "RTN","TMGNDF0B",332,0) new ProgressFn "RTN","TMGNDF0B",333,0) set ProgressFn="if IEN#10=1 do ProgressBar^TMGUSRIF(IEN,""Progress"",0,TMGTOTAL,,StartTime)" "RTN","TMGNDF0B",334,0) "RTN","TMGNDF0B",335,0) for do quit:(IEN'>0)!(abort=1) "RTN","TMGNDF0B",336,0) . set IEN=$order(^TMG(22706.5,IEN)) "RTN","TMGNDF0B",337,0) . if +IEN'>0 quit "RTN","TMGNDF0B",338,0) . do FillGenericName^TMGNDF1C(IEN) "RTN","TMGNDF0B",339,0) . if $get(ProgressFn)'="" do "RTN","TMGNDF0B",340,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGNDF0B",341,0) . . xecute ProgressFn "RTN","TMGNDF0B",342,0) "RTN","TMGNDF0B",343,0) quit "RTN","TMGNDF0B",344,0) "RTN","TMGNDF0B",345,0) "RTN","TMGNDF0B",346,0) MkGenByTemplate "RTN","TMGNDF0B",347,0) ;"Purpose: To ask for a SORT TEMPLATE, and fill in the GENERIC NAME field for record "RTN","TMGNDF0B",348,0) ;" -- for all records listed in the template "RTN","TMGNDF0B",349,0) ;"Output: The file 22706.9 (TMG FDA IMPORT COMPILED) has GENERIC NAME firecords added. "RTN","TMGNDF0B",350,0) "RTN","TMGNDF0B",351,0) new pIndex set pIndex=$$GetpVAPIndex^TMGNDF1A() "RTN","TMGNDF0B",352,0) "RTN","TMGNDF0B",353,0) new IEN,Template "RTN","TMGNDF0B",354,0) new DIC,X,Y "RTN","TMGNDF0B",355,0) set DIC=.401 "RTN","TMGNDF0B",356,0) set DIC("A")="Enter a SORT TEMPLATE to compile FDA entries from: " "RTN","TMGNDF0B",357,0) set DIC(0)="AEQM" "RTN","TMGNDF0B",358,0) do ^DIC "RTN","TMGNDF0B",359,0) if +Y'>0 goto MGBTDone "RTN","TMGNDF0B",360,0) set Template=+Y "RTN","TMGNDF0B",361,0) "RTN","TMGNDF0B",362,0) new TMGTOTAL set TMGTOTAL=$$CtTemplate^TMGMISC(Template) "RTN","TMGNDF0B",363,0) new StartTime set StartTime=$H "RTN","TMGNDF0B",364,0) new ProgressFn "RTN","TMGNDF0B",365,0) set ProgressFn="if count#10=1 do ProgressBar^TMGUSRIF(count,""Progress"",0,TMGTOTAL,,StartTime)" "RTN","TMGNDF0B",366,0) set IEN="" "RTN","TMGNDF0B",367,0) new count set count=0 "RTN","TMGNDF0B",368,0) for do quit:(+IEN'>0) "RTN","TMGNDF0B",369,0) . set IEN=$$IterTemplate^TMGMISC(Template,IEN) "RTN","TMGNDF0B",370,0) . if +IEN'>0 quit "RTN","TMGNDF0B",371,0) . ;"write IEN,! "RTN","TMGNDF0B",372,0) . do FillGenericName^TMGNDF1C(IEN) "RTN","TMGNDF0B",373,0) . set count=count+1 "RTN","TMGNDF0B",374,0) . if $get(ProgressFn)'="" do "RTN","TMGNDF0B",375,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGNDF0B",376,0) . . xecute ProgressFn "RTN","TMGNDF0B",377,0) "RTN","TMGNDF0B",378,0) MGBTDone "RTN","TMGNDF0B",379,0) quit "RTN","TMGNDF0B",380,0) "RTN","TMGNDF0B",381,0) "RTN","TMGNDF0B",382,0) ShowTemplate "RTN","TMGNDF0B",383,0) ;"Purpose: To ask for a SORT TEMPLATE, and show the records for IENs stored there. "RTN","TMGNDF0B",384,0) "RTN","TMGNDF0B",385,0) new IEN,Template "RTN","TMGNDF0B",386,0) new DIC,X,Y "RTN","TMGNDF0B",387,0) set DIC=.401 "RTN","TMGNDF0B",388,0) set DIC("A")="Enter a SORT TEMPLATE to compile FDA entries from: " "RTN","TMGNDF0B",389,0) set DIC(0)="AEQM" "RTN","TMGNDF0B",390,0) do ^DIC "RTN","TMGNDF0B",391,0) if +Y'>0 goto STDone "RTN","TMGNDF0B",392,0) set Template=+Y "RTN","TMGNDF0B",393,0) "RTN","TMGNDF0B",394,0) set IEN="" "RTN","TMGNDF0B",395,0) new result,Array "RTN","TMGNDF0B",396,0) "RTN","TMGNDF0B",397,0) for do quit:(+IEN'>0) "RTN","TMGNDF0B",398,0) . set IEN=$$IterTemplate^TMGMISC(Template,IEN) "RTN","TMGNDF0B",399,0) . if +IEN'>0 quit "RTN","TMGNDF0B",400,0) . write "IEN: ",IEN,! "RTN","TMGNDF0B",401,0) . set result=$$GetDrugInfo^TMGNDF1A(IEN,.Array) "RTN","TMGNDF0B",402,0) . do Format2Drug(.Array) "RTN","TMGNDF0B",403,0) "RTN","TMGNDF0B",404,0) STDone "RTN","TMGNDF0B",405,0) quit "RTN","TMGNDF0B",406,0) "RTN","TMGNDF0B",407,0) "RTN","TMGNDF0B",408,0) CheckPtrs "RTN","TMGNDF0B",409,0) ;"Purpose: check import files for 0 values for pointers. "RTN","TMGNDF0B",410,0) "RTN","TMGNDF0B",411,0) new Info "RTN","TMGNDF0B",412,0) set Info(22706.1,.01)="0;1" "RTN","TMGNDF0B",413,0) set Info(22706.2,.01)="0;1" "RTN","TMGNDF0B",414,0) set Info(22706.2,3)="1;2" "RTN","TMGNDF0B",415,0) set Info(22706.4,.01)="0;1" "RTN","TMGNDF0B",416,0) set Info(22706.5,6)="0;7" "RTN","TMGNDF0B",417,0) set Info(22706.5,8)="0;9" "RTN","TMGNDF0B",418,0) set Info(22706.6,.01)="0;1" "RTN","TMGNDF0B",419,0) set Info(22706.7,.01)="0;1" "RTN","TMGNDF0B",420,0) "RTN","TMGNDF0B",421,0) set Info(22706.8,1)="0;2" "RTN","TMGNDF0B",422,0) set Info(22706.8,2)="0;3" "RTN","TMGNDF0B",423,0) set Info(22706.82,1)="0;2" "RTN","TMGNDF0B",424,0) ;"set Info(22703,.01)="0;1" ;"no pointers "RTN","TMGNDF0B",425,0) ;"set Info(22707,.01)="0;1" ;"no pointers "RTN","TMGNDF0B",426,0) ;"set Info(22705,.01)="0;1" ;"ignore this one "RTN","TMGNDF0B",427,0) ;"set Info(22711,.01)="0;1" "RTN","TMGNDF0B",428,0) "RTN","TMGNDF0B",429,0) new abort set abort=0 "RTN","TMGNDF0B",430,0) new file set file="" "RTN","TMGNDF0B",431,0) for set file=$order(Info(file)) quit:(file="")!abort do "RTN","TMGNDF0B",432,0) . new field set field="" "RTN","TMGNDF0B",433,0) . for set field=$order(Info(file,field)) quit:(field="")!abort do "RTN","TMGNDF0B",434,0) . . new node,pce "RTN","TMGNDF0B",435,0) . . set node=$piece($get(Info(file,field)),";",1) "RTN","TMGNDF0B",436,0) . . set pce=$piece($get(Info(file,field)),";",2) "RTN","TMGNDF0B",437,0) . . if (node="")!(pce="") quit "RTN","TMGNDF0B",438,0) . . new Itr,IEN "RTN","TMGNDF0B",439,0) . . write !,"Scanning file ",file,! "RTN","TMGNDF0B",440,0) . . set IEN=$$ItrInit^TMGITR(file,.Itr) "RTN","TMGNDF0B",441,0) . . do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF0B",442,0) . . if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF0B",443,0) . . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF0B",444,0) . . . if $piece($get(^TMG(file,IEN,node)),"^",pce)=0 do "RTN","TMGNDF0B",445,0) . . . . write !,file,", IEN: #",IEN," has 0 pointer for the ",field,"field.",! "RTN","TMGNDF0B",446,0) "RTN","TMGNDF0B",447,0) "RTN","TMGNDF0B",448,0) quit "RTN","TMGNDF0C") 0^37^B5013 "RTN","TMGNDF0C",1,0) TMGNDF2B ;TMG/kst/FDA Import: Ensure DRUG INGREDIENTS ;03/25/06 "RTN","TMGNDF0C",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF0C",3,0) "RTN","TMGNDF0C",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF0C",5,0) ;" -- FILLING DRUG INGREDIENTS FILE WITH NEW VALUES "RTN","TMGNDF0C",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF0C",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF0C",8,0) ;"11-21-2006 "RTN","TMGNDF0C",9,0) "RTN","TMGNDF0C",10,0) ;"======================================================================= "RTN","TMGNDF0C",11,0) ;" API -- Public Functions. "RTN","TMGNDF0C",12,0) ;"======================================================================= "RTN","TMGNDF0C",13,0) ;"Menu -- Provide menu to entry points of main routines "RTN","TMGNDF0C",14,0) ;"======================================================================= "RTN","TMGNDF0C",15,0) ;"CheckIngredients -- To cycle through ingredients and ensure that there is an extry in the "RTN","TMGNDF0C",16,0) ;" DRUG INGREDIENTS file. This has to be an interactive process. "RTN","TMGNDF0C",17,0) "RTN","TMGNDF0C",18,0) ;"======================================================================= "RTN","TMGNDF0C",19,0) ;" Private Functions. "RTN","TMGNDF0C",20,0) ;"======================================================================= "RTN","TMGNDF0C",21,0) ;"ShowInstructions "RTN","TMGNDF0C",22,0) ;"LookupRx(ingredient) "RTN","TMGNDF0C",23,0) ;"ShowMatches(Array,max,Label) "RTN","TMGNDF0C",24,0) ;"AddRangeMatch(ScanArray,Label,StartN,EndN) "RTN","TMGNDF0C",25,0) ;"AddMatch(ScanArray,Label,number) "RTN","TMGNDF0C",26,0) ;"ULRangeMatch(ScanArray,StartN,EndN) "RTN","TMGNDF0C",27,0) ;"ULMatch(ScanArray,number) "RTN","TMGNDF0C",28,0) ;"AddOneIngredient(Name) "RTN","TMGNDF0C",29,0) ;"FindIgdMatch(Name,Interactive) "RTN","TMGNDF0C",30,0) ;"DoAddIgd(Name,ParentIEN) "RTN","TMGNDF0C",31,0) "RTN","TMGNDF0C",32,0) ;"======================================================================= "RTN","TMGNDF0C",33,0) ;"======================================================================= "RTN","TMGNDF0C",34,0) Menu "RTN","TMGNDF0C",35,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF0C",36,0) "RTN","TMGNDF0C",37,0) new Menu,UsrSlct "RTN","TMGNDF0C",38,0) set Menu(0)="Pick Option for Checking Import Ingredients (0C)" "RTN","TMGNDF0C",39,0) set Menu(1)="Check for NEW ingredients to ADD."_$char(9)_"CheckIngredients" "RTN","TMGNDF0C",40,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF0C",41,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF0C",42,0) "RTN","TMGNDF0C",43,0) MC1 write # "RTN","TMGNDF0C",44,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF0C",45,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF0C",46,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF0C",47,0) "RTN","TMGNDF0C",48,0) if UsrSlct="CheckIngredients" do CheckIngredients goto MC1 "RTN","TMGNDF0C",49,0) if UsrSlct="Prev" goto Menu^TMGNDF0B ;"quit can occur from there... "RTN","TMGNDF0C",50,0) if UsrSlct="Next" goto Menu^TMGNDF1A ;"quit can occur from there... "RTN","TMGNDF0C",51,0) goto MC1 "RTN","TMGNDF0C",52,0) "RTN","TMGNDF0C",53,0) MCDone "RTN","TMGNDF0C",54,0) quit "RTN","TMGNDF0C",55,0) "RTN","TMGNDF0C",56,0) "RTN","TMGNDF0C",57,0) CheckIngredients "RTN","TMGNDF0C",58,0) ;"Purpose: To cycle through ingredients and ensure that there is an extry in the "RTN","TMGNDF0C",59,0) ;" DRUG INGREDIENTS file. This has to be an interactive process. "RTN","TMGNDF0C",60,0) ;"Input: none "RTN","TMGNDF0C",61,0) ;"Results: none "RTN","TMGNDF0C",62,0) ;"Note: if record in 22706.9 (TMG FDA IMPORT COMPILED) for a given listing "RTN","TMGNDF0C",63,0) ;" has been marked for SKIPPING, or DONE ADDING, then listing will be skipped. "RTN","TMGNDF0C",64,0) "RTN","TMGNDF0C",65,0) new Answers,index,ingredient "RTN","TMGNDF0C",66,0) write "Collecting list of INGREDIENTS that need to be added to database...",! "RTN","TMGNDF0C",67,0) new count set count=1 "RTN","TMGNDF0C",68,0) new MissingArray "RTN","TMGNDF0C",69,0) "RTN","TMGNDF0C",70,0) new Itr,IEN "RTN","TMGNDF0C",71,0) new abort set abort=0 "RTN","TMGNDF0C",72,0) set index=$$ItrInit^TMGITR(22706.4,.Itr) "RTN","TMGNDF0C",73,0) do PrepProgress^TMGITR(.Itr,20,0,"index") "RTN","TMGNDF0C",74,0) if index'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.index)'>0)!abort "RTN","TMGNDF0C",75,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF0C",76,0) . new listingIEN set listingIEN=+$piece($get(^TMG(22706.4,index,0)),"^",1) ;"Not required... "RTN","TMGNDF0C",77,0) . if (listingIEN>0),$piece($get(^TMG(22706.9,listingIEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF0C",78,0) . set ingredient=$piece($get(^TMG(22706.4,index,0)),"^",4) "RTN","TMGNDF0C",79,0) . set ingredient=$extract(ingredient,1,64) "RTN","TMGNDF0C",80,0) . if $get(Answers(ingredient))="" do "RTN","TMGNDF0C",81,0) . . set Y=$$LookupRx(ingredient) "RTN","TMGNDF0C",82,0) . . if +Y'>0 set MissingArray(ingredient)="" "RTN","TMGNDF0C",83,0) . . if +Y>0 set Answers(ingredient)=+Y "RTN","TMGNDF0C",84,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF0C",85,0) "RTN","TMGNDF0C",86,0) do HandleMissing(.MissingArray) "RTN","TMGNDF0C",87,0) quit "RTN","TMGNDF0C",88,0) "RTN","TMGNDF0C",89,0) "RTN","TMGNDF0C",90,0) Check1(IEN) ;"finish later "RTN","TMGNDF0C",91,0) ;"Purpose: to scan the ingredients for 1 entry in 22706.9 "RTN","TMGNDF0C",92,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF0C",93,0) "RTN","TMGNDF0C",94,0) new ingredient "RTN","TMGNDF0C",95,0) new MissingArray "RTN","TMGNDF0C",96,0) "RTN","TMGNDF0C",97,0) new fdaIEN,Y "RTN","TMGNDF0C",98,0) set fdaIEN=+$piece($get(^TMG(22706.9,IEN,0)),"^",1) "RTN","TMGNDF0C",99,0) set ingredient=$piece($get(^TMG(22706.4,fdaIEN,0)),"^",4) "RTN","TMGNDF0C",100,0) set ingredient=$extract(ingredient,1,64) "RTN","TMGNDF0C",101,0) set Y=$$LookupRx(ingredient) "RTN","TMGNDF0C",102,0) if +Y'>0 do "RTN","TMGNDF0C",103,0) . set MissingArray(ingredient)="" "RTN","TMGNDF0C",104,0) . do HandleMissing(.MissingArray) "RTN","TMGNDF0C",105,0) quit "RTN","TMGNDF0C",106,0) "RTN","TMGNDF0C",107,0) "RTN","TMGNDF0C",108,0) HandleMissing(MissingArray) "RTN","TMGNDF0C",109,0) ;"Purpose: To handle and process the array of missing ingredients "RTN","TMGNDF0C",110,0) ;"Input: MissingArray(ingredient)="" "RTN","TMGNDF0C",111,0) ;" MissingArray(ingredient)="" "RTN","TMGNDF0C",112,0) ;"Result: none "RTN","TMGNDF0C",113,0) "RTN","TMGNDF0C",114,0) new max set max=$$ListCt^TMGMISC("MissingArray") "RTN","TMGNDF0C",115,0) write !,"Found ",max," missing INGREDIENTS.",! "RTN","TMGNDF0C",116,0) "RTN","TMGNDF0C",117,0) new ScanArray,count "RTN","TMGNDF0C",118,0) write "Summarizing list...",! "RTN","TMGNDF0C",119,0) set count=1 "RTN","TMGNDF0C",120,0) set ingredient="" "RTN","TMGNDF0C",121,0) for set ingredient=$order(MissingArray(ingredient)) quit:(ingredient="") do "RTN","TMGNDF0C",122,0) . if ingredient["ALLERGENIC EXTRACT" do "RTN","TMGNDF0C",123,0) . . set Y=$$DoAddIgd(ingredient,0) "RTN","TMGNDF0C",124,0) . else do "RTN","TMGNDF0C",125,0) . . set Y=$$FindIgdMatch(ingredient,0) "RTN","TMGNDF0C",126,0) . . if +Y>0 set ScanArray("MATCHED",count,ingredient)=Y "RTN","TMGNDF0C",127,0) . . else set ScanArray("UNMATCHED",count,ingredient)="" "RTN","TMGNDF0C",128,0) . set count=count+1 "RTN","TMGNDF0C",129,0) . set ingredient=$order(MissingArray(ingredient)) "RTN","TMGNDF0C",130,0) write ! "RTN","TMGNDF0C",131,0) "RTN","TMGNDF0C",132,0) new done set done=0 "RTN","TMGNDF0C",133,0) new input set input="R" "RTN","TMGNDF0C",134,0) new displaySet set displaySet="MATCHED" "RTN","TMGNDF0C",135,0) for do quit:(done=1) "RTN","TMGNDF0C",136,0) . if input="R" do "RTN","TMGNDF0C",137,0) . . write !!,"Now pick which potential matches are ",displaySet,! "RTN","TMGNDF0C",138,0) . . do ShowMatches(.ScanArray,max,displaySet) "RTN","TMGNDF0C",139,0) . write " (R to refresh, C custom handle, UL to UnLink)",! "RTN","TMGNDF0C",140,0) . write " (# or #-#, ^ to continue, ? for instructions, " "RTN","TMGNDF0C",141,0) . if displaySet="MATCHED" write "U show Unmatched)",! "RTN","TMGNDF0C",142,0) . else write "M show Matched)",! "RTN","TMGNDF0C",143,0) . write "Enter number(s) to ACCEPT (or codes listed above): ?//" "RTN","TMGNDF0C",144,0) . read input,! "RTN","TMGNDF0C",145,0) . if input="" set input="?" "RTN","TMGNDF0C",146,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF0C",147,0) . if input="^" set done=1 "RTN","TMGNDF0C",148,0) . if (input="U") do "RTN","TMGNDF0C",149,0) . . set displaySet="UNMATCHED" "RTN","TMGNDF0C",150,0) . . set input="R" "RTN","TMGNDF0C",151,0) . if (input="M") do "RTN","TMGNDF0C",152,0) . . set displaySet="MATCHED" "RTN","TMGNDF0C",153,0) . . set input="R" "RTN","TMGNDF0C",154,0) . if (input="A") do "RTN","TMGNDF0C",155,0) . . set displaySet="MATCHED" "RTN","TMGNDF0C",156,0) . . set input="R" "RTN","TMGNDF0C",157,0) . if (input="?") do "RTN","TMGNDF0C",158,0) . . do ShowInstructions "RTN","TMGNDF0C",159,0) . . set input="R" "RTN","TMGNDF0C",160,0) . if +input=input do "RTN","TMGNDF0C",161,0) . . do AddMatch(.ScanArray,displaySet,+input) "RTN","TMGNDF0C",162,0) . . set input="R" "RTN","TMGNDF0C",163,0) . if input["-" do "RTN","TMGNDF0C",164,0) . . new N1,N2 "RTN","TMGNDF0C",165,0) . . set N1=$piece(input,"-",1) "RTN","TMGNDF0C",166,0) . . set N2=$piece(input,"-",2) "RTN","TMGNDF0C",167,0) . . do AddRangeMatch(.ScanArray,displaySet,N1,N2) "RTN","TMGNDF0C",168,0) . . set input="R" "RTN","TMGNDF0C",169,0) . if input="C" do "RTN","TMGNDF0C",170,0) . . read "Enter number for Custom Handling: ",input,! "RTN","TMGNDF0C",171,0) . . if +input'=input quit "RTN","TMGNDF0C",172,0) . . set ingredient=$order(ScanArray(displaySet,+input,"")) "RTN","TMGNDF0C",173,0) . . set Y=$$AddOneIngredient(ingredient) "RTN","TMGNDF0C",174,0) . . if +Y>0 kill ScanArray(displaySet,+input,ingredient) "RTN","TMGNDF0C",175,0) . . set input="R" "RTN","TMGNDF0C",176,0) . if input="UL" do "RTN","TMGNDF0C",177,0) . . read "Enter number to Unlink (# or #-#): ",input,! "RTN","TMGNDF0C",178,0) . . if +input=input do "RTN","TMGNDF0C",179,0) . . . do ULMatch(.ScanArray,input) "RTN","TMGNDF0C",180,0) . . else if input["-" do "RTN","TMGNDF0C",181,0) . . . new N1,N2 "RTN","TMGNDF0C",182,0) . . . set N1=$piece(input,"-",1) "RTN","TMGNDF0C",183,0) . . . set N2=$piece(input,"-",2) "RTN","TMGNDF0C",184,0) . . . do ULRangeMatch(.ScanArray,N1,N2) "RTN","TMGNDF0C",185,0) . . set input="R" "RTN","TMGNDF0C",186,0) "RTN","TMGNDF0C",187,0) quit "RTN","TMGNDF0C",188,0) "RTN","TMGNDF0C",189,0) "RTN","TMGNDF0C",190,0) ShowInstructions "RTN","TMGNDF0C",191,0) write !!,"INSTRUCTIONS:",! "RTN","TMGNDF0C",192,0) write "----------------------------------------------------------------------------",! "RTN","TMGNDF0C",193,0) write "Before adding any medicines or drugs into the database, the underlying",! "RTN","TMGNDF0C",194,0) write "INGREDIENTS must be entered. Each drug will have one or more ingredients",! "RTN","TMGNDF0C",195,0) write "that will be linked to these new entries. DRUG INTERACTIONS are based on",! "RTN","TMGNDF0C",196,0) write "ingredients rather than on the name of the drug itself.",!! "RTN","TMGNDF0C",197,0) write "Often, the name supplied is more specific than an entry already in the",! "RTN","TMGNDF0C",198,0) write "database. For example:",! "RTN","TMGNDF0C",199,0) write " CAFFEINE <-- already in database",! "RTN","TMGNDF0C",200,0) write " CAFFEINE CITRATE <-- new import",! "RTN","TMGNDF0C",201,0) write "Clearly, these two compounds are related, and it could be said that:",! "RTN","TMGNDF0C",202,0) write "CAFFEINE is the PRIMARY INGREDIENT in CAFFEINE CITRATE, or as will be",! "RTN","TMGNDF0C",203,0) write "seen shortly, summarized like this:",! "RTN","TMGNDF0C",204,0) write "CAFFEINE <-- CAFFEINE CITRATE",!! "RTN","TMGNDF0C",205,0) do PressToCont^TMGUSRIF "RTN","TMGNDF0C",206,0) write "What follows next will be a listing of all the ingredients to be added into",! "RTN","TMGNDF0C",207,0) write "the database. The computer will have made a best guess at linking the new",! "RTN","TMGNDF0C",208,0) write "entries to parent compounds (i.e. PRIMARY INGREDIENTS). But not all of these",! "RTN","TMGNDF0C",209,0) write "guesses will be correct. IT IS YOUR JOB TO SCREEN THESE.",!! "RTN","TMGNDF0C",210,0) write "If a linkage or matching is correct, just type in its number to ACCEPT it.",! "RTN","TMGNDF0C",211,0) write "If a linkage or matching is NOT correct, it shoud be UNLINKED.",! "RTN","TMGNDF0C",212,0) write "If you feel you can search for a better match, attempt a CUSTOM handling.",!! "RTN","TMGNDF0C",213,0) write "When you are done with accepting or rejecting the computers matches, you should",! "RTN","TMGNDF0C",214,0) write "then process all the UNMATCHED entries, by selecting 'U' to show UNMATCHED.",! "RTN","TMGNDF0C",215,0) write "These very likely may all be accepted at once by entering a range number (e.g.",! "RTN","TMGNDF0C",216,0) write "1-1000).",!! "RTN","TMGNDF0C",217,0) write "When you have completed processing all the matched and unmatched entries, enter",! "RTN","TMGNDF0C",218,0) write "^ to continue.",! "RTN","TMGNDF0C",219,0) "RTN","TMGNDF0C",220,0) new temp "RTN","TMGNDF0C",221,0) read "Press to continue.",temp:$get(DTIME,3600),! "RTN","TMGNDF0C",222,0) quit "RTN","TMGNDF0C",223,0) "RTN","TMGNDF0C",224,0) "RTN","TMGNDF0C",225,0) LookupRx(ingredient) "RTN","TMGNDF0C",226,0) ;"Purpose: To look up ingredient in the DRUG INGREDIENTS file "RTN","TMGNDF0C",227,0) ;"Input: ingredient -- the name of the ingredient to lookup "RTN","TMGNDF0C",228,0) ;"Result: -1 if not fount, or 1234^ingredientname format "RTN","TMGNDF0C",229,0) "RTN","TMGNDF0C",230,0) new DIC,X,Y "RTN","TMGNDF0C",231,0) set DIC=50.416 "RTN","TMGNDF0C",232,0) set DIC(0)="M" "RTN","TMGNDF0C",233,0) new TMGROOT,TMGMSG "RTN","TMGNDF0C",234,0) "RTN","TMGNDF0C",235,0) set Y=-1 "RTN","TMGNDF0C",236,0) do FIND^DIC(50.416,,".01E","M",ingredient,"*",,,,"TMGROOT","TMGMSG") "RTN","TMGNDF0C",237,0) if +$get(TMGROOT("DILIST",0))>0 do "RTN","TMGNDF0C",238,0) . set Y=$get(TMGROOT("DILIST",2,1),-1)_"^"_$get(TMGROOT("DILIST",1,1)) "RTN","TMGNDF0C",239,0) . if +Y'>0 do "RTN","TMGNDF0C",240,0) . . set X=ingredient "RTN","TMGNDF0C",241,0) . . do ^DIC "RTN","TMGNDF0C",242,0) "RTN","TMGNDF0C",243,0) quit Y "RTN","TMGNDF0C",244,0) "RTN","TMGNDF0C",245,0) "RTN","TMGNDF0C",246,0) ShowMatches(Array,max,Label) "RTN","TMGNDF0C",247,0) new count,ingredient,value "RTN","TMGNDF0C",248,0) new someShown set someShown=0 "RTN","TMGNDF0C",249,0) for count=1:1:max do "RTN","TMGNDF0C",250,0) . set ingredient=$order(ScanArray(Label,count,"")) "RTN","TMGNDF0C",251,0) . if ingredient="" quit "RTN","TMGNDF0C",252,0) . set someShown=1 "RTN","TMGNDF0C",253,0) . set value=$get(ScanArray(Label,count,ingredient)) "RTN","TMGNDF0C",254,0) . write " ",count,". " "RTN","TMGNDF0C",255,0) . if +value>0 write $piece(value,"^",2) "RTN","TMGNDF0C",256,0) . else write "(no parent ingredient)" "RTN","TMGNDF0C",257,0) . write " <--- ",ingredient,! "RTN","TMGNDF0C",258,0) if someShown=0 do "RTN","TMGNDF0C",259,0) . write " --- (List is Empty) ---",! "RTN","TMGNDF0C",260,0) "RTN","TMGNDF0C",261,0) quit "RTN","TMGNDF0C",262,0) "RTN","TMGNDF0C",263,0) AddRangeMatch(ScanArray,Label,StartN,EndN) "RTN","TMGNDF0C",264,0) new num "RTN","TMGNDF0C",265,0) for num=StartN:1:EndN do "RTN","TMGNDF0C",266,0) . do AddMatch(.ScanArray,Label,num) "RTN","TMGNDF0C",267,0) quit "RTN","TMGNDF0C",268,0) "RTN","TMGNDF0C",269,0) AddMatch(ScanArray,Label,number) "RTN","TMGNDF0C",270,0) new ingredient,Y "RTN","TMGNDF0C",271,0) set ingredient=$order(ScanArray(Label,number,"")) "RTN","TMGNDF0C",272,0) set Y=$get(ScanArray(Label,number,ingredient)) "RTN","TMGNDF0C",273,0) if (ingredient'="") do "RTN","TMGNDF0C",274,0) . set Y=$$DoAddIgd(ingredient,Y) "RTN","TMGNDF0C",275,0) . kill ScanArray(Label,number,ingredient) "RTN","TMGNDF0C",276,0) quit "RTN","TMGNDF0C",277,0) "RTN","TMGNDF0C",278,0) ULRangeMatch(ScanArray,StartN,EndN) "RTN","TMGNDF0C",279,0) new num "RTN","TMGNDF0C",280,0) for num=StartN:1:EndN do "RTN","TMGNDF0C",281,0) . do ULMatch(.ScanArray,num) "RTN","TMGNDF0C",282,0) quit "RTN","TMGNDF0C",283,0) "RTN","TMGNDF0C",284,0) ULMatch(ScanArray,number) "RTN","TMGNDF0C",285,0) new ingredient,Y "RTN","TMGNDF0C",286,0) set ingredient=$order(ScanArray("MATCHED",number,"")) "RTN","TMGNDF0C",287,0) if (ingredient'="") set ScanArray("UNMATCHED",number,ingredient)="" "RTN","TMGNDF0C",288,0) kill ScanArray("MATCHED",number) "RTN","TMGNDF0C",289,0) quit "RTN","TMGNDF0C",290,0) "RTN","TMGNDF0C",291,0) "RTN","TMGNDF0C",292,0) AddOneIngredient(Name) "RTN","TMGNDF0C",293,0) ;"Purpose: To add ingredient name to the DRUG INGREDIENTS -- will try to find a parent "RTN","TMGNDF0C",294,0) ;" ingredient interactively "RTN","TMGNDF0C",295,0) ;"Input: Name -- the name of the ingredient to be added. "RTN","TMGNDF0C",296,0) ;"Output: DRUG INGREDIENTS file will have records added. "RTN","TMGNDF0C",297,0) ;"Results: Will return record number (IEN) of newly added record, or 0 if error "RTN","TMGNDF0C",298,0) ;"Note: This function assumes that the ingredient does not already exist in the file. "RTN","TMGNDF0C",299,0) "RTN","TMGNDF0C",300,0) new result set result=0 "RTN","TMGNDF0C",301,0) if $get(Name)="" goto AOIDone "RTN","TMGNDF0C",302,0) "RTN","TMGNDF0C",303,0) new Y "RTN","TMGNDF0C",304,0) set Y=$$FindIgdMatch(Name,1) "RTN","TMGNDF0C",305,0) "RTN","TMGNDF0C",306,0) new % set %=1 ;"1=YES "RTN","TMGNDF0C",307,0) if +Y'>0 do "RTN","TMGNDF0C",308,0) . write "A parent primary ingredient was not found for ",! "RTN","TMGNDF0C",309,0) . write " ",Name," <-- UNMATCHED COMPOUND (Add Now)",! "RTN","TMGNDF0C",310,0) . write "Add Now? " "RTN","TMGNDF0C",311,0) . do YN^DICN ;"returns result in % "RTN","TMGNDF0C",312,0) . write ! "RTN","TMGNDF0C",313,0) "RTN","TMGNDF0C",314,0) if %=1 do "RTN","TMGNDF0C",315,0) . set result=$$DoAddIgd(Name,Y) "RTN","TMGNDF0C",316,0) "RTN","TMGNDF0C",317,0) AOIDone "RTN","TMGNDF0C",318,0) quit result "RTN","TMGNDF0C",319,0) "RTN","TMGNDF0C",320,0) "RTN","TMGNDF0C",321,0) FindIgdMatch(Name,Interactive) "RTN","TMGNDF0C",322,0) ;"Purpose: To find a match for Name from DRUG INGREDIENTS "RTN","TMGNDF0C",323,0) ;"Input: Name -- the name of the ingredient to be added. "RTN","TMGNDF0C",324,0) ;" Interactive -- OPTIONAL, default=1 "RTN","TMGNDF0C",325,0) ;" if 1 then user is asked question, "RTN","TMGNDF0C",326,0) ;" if 0 then best guess is returned. "RTN","TMGNDF0C",327,0) ;"Results: -1 if not found "RTN","TMGNDF0C",328,0) ;" or 1234^Name "RTN","TMGNDF0C",329,0) "RTN","TMGNDF0C",330,0) if $get(Name)="" goto FMDone "RTN","TMGNDF0C",331,0) "RTN","TMGNDF0C",332,0) set Interactive=$get(Interactive,1) "RTN","TMGNDF0C",333,0) "RTN","TMGNDF0C",334,0) if Interactive do "RTN","TMGNDF0C",335,0) . write "------------------------------------------",! "RTN","TMGNDF0C",336,0) . write "Looking for a parent, PRIMARY INGREDIENT for: ",! "RTN","TMGNDF0C",337,0) . write " ",Name," <-- UNMATCHED COMPOUND",! "RTN","TMGNDF0C",338,0) "RTN","TMGNDF0C",339,0) new DIC,X,Y,% "RTN","TMGNDF0C",340,0) set DIC=50.416 "RTN","TMGNDF0C",341,0) set DIC(0)="M" "RTN","TMGNDF0C",342,0) "RTN","TMGNDF0C",343,0) new parent set parent=$$Substitute^TMGSTUTL(Name,", "," ") "RTN","TMGNDF0C",344,0) set parent=$translate(parent,","," ") "RTN","TMGNDF0C",345,0) for do quit:(+Y>0)!(parent="") "RTN","TMGNDF0C",346,0) . new temp "RTN","TMGNDF0C",347,0) . set temp=$$ParseLast^TMGMISC(parent,.parent," ") ;"cut last word off from drug name "RTN","TMGNDF0C",348,0) . set X=$$Trim^TMGSTUTL(parent) "RTN","TMGNDF0C",349,0) . do ^DIC "RTN","TMGNDF0C",350,0) . if Interactive'=1 quit "RTN","TMGNDF0C",351,0) . if +Y>0 do "RTN","TMGNDF0C",352,0) . . ;"At this point, we either have possible match (+Y>0), or no match (parent="") "RTN","TMGNDF0C",353,0) . . write " '"_$piece(Y,"^",2)_"' <-- ?? MATCH ??",! "RTN","TMGNDF0C",354,0) . . write "Use this as the PRIMARY INGREDIENT? " "RTN","TMGNDF0C",355,0) . . set %=1 ;"1=YES "RTN","TMGNDF0C",356,0) . . do YN^DICN ;"returns result in % "RTN","TMGNDF0C",357,0) . . write ! "RTN","TMGNDF0C",358,0) . . if %'=1 set Y=0 "RTN","TMGNDF0C",359,0) . else do "RTN","TMGNDF0C",360,0) . . if X'="" write " ",X," <-- (not found).",! "RTN","TMGNDF0C",361,0) "RTN","TMGNDF0C",362,0) if (+Y'>0)&(Interactive) do "RTN","TMGNDF0C",363,0) . write " No match found. Let's try a generic lookup..." "RTN","TMGNDF0C",364,0) . set DIC(0)="AEQM" "RTN","TMGNDF0C",365,0) . set DIC("A")=" LOOKUP: Enter PRIMARY INGREDIENT (or ^ to continue) ^// " "RTN","TMGNDF0C",366,0) . do ^DIC "RTN","TMGNDF0C",367,0) . write ! "RTN","TMGNDF0C",368,0) "RTN","TMGNDF0C",369,0) FMDone "RTN","TMGNDF0C",370,0) quit Y "RTN","TMGNDF0C",371,0) "RTN","TMGNDF0C",372,0) "RTN","TMGNDF0C",373,0) DoAddIgd(Name,ParentIEN) "RTN","TMGNDF0C",374,0) ;"Purpose: to do the actual addition to the DRUG INGREDIENTS file "RTN","TMGNDF0C",375,0) ;"Input: Name -- the string of the drug name "RTN","TMGNDF0C",376,0) ;" ParentIEN -- a value as returned from DIC (i.e. 1234^Name) "RTN","TMGNDF0C",377,0) ;"Results: IEN of added value, or 0 if not added. "RTN","TMGNDF0C",378,0) "RTN","TMGNDF0C",379,0) new result set result=0 "RTN","TMGNDF0C",380,0) new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF0C",381,0) new PrimIngred set PrimIngred=$get(ParentIEN) "RTN","TMGNDF0C",382,0) set TMGFDA(50.416,"+1,",.01)=$extract(Name,1,64) "RTN","TMGNDF0C",383,0) if +PrimIngred>0 set TMGFDA(50.416,"+1,",2)=$piece(PrimIngred,"^",1) "RTN","TMGNDF0C",384,0) do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF0C",385,0) if $data(TMGMSG)&(+$get(Quiet)=0) do "RTN","TMGNDF0C",386,0) . new PriorErrorFound "RTN","TMGNDF0C",387,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF0C",388,0) set result=$get(TMGIEN(1)) "RTN","TMGNDF0C",389,0) "RTN","TMGNDF0C",390,0) quit result "RTN","TMGNDF0C",391,0) "RTN","TMGNDF1A") 0^38^B9060 "RTN","TMGNDF1A",1,0) TMGNDF1A ;TMG/kst/FDA Import: Compile FDA files into import file ;03/25/06 "RTN","TMGNDF1A",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF1A",3,0) "RTN","TMGNDF1A",4,0) ;"FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF1A",5,0) ;"Kevin Toppenberg MD "RTN","TMGNDF1A",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF1A",7,0) ;"11-21-2006 "RTN","TMGNDF1A",8,0) "RTN","TMGNDF1A",9,0) ;"======================================================================= "RTN","TMGNDF1A",10,0) ;" API -- Public Functions. "RTN","TMGNDF1A",11,0) ;"======================================================================= "RTN","TMGNDF1A",12,0) ;"Menu "RTN","TMGNDF1A",13,0) ;"======================================================================= "RTN","TMGNDF1A",14,0) ;"Compile -- collect relevent data from the TMG FDA * files and put into one record "RTN","TMGNDF1A",15,0) "RTN","TMGNDF1A",16,0) ;"GetpVAPIndex() -- return a pointer to an index of the VAProduct file "RTN","TMGNDF1A",17,0) ;"ReCompOne(IEN22706d9) "RTN","TMGNDF1A",18,0) "RTN","TMGNDF1A",19,0) ;"======================================================================= "RTN","TMGNDF1A",20,0) ;" Private Functions. "RTN","TMGNDF1A",21,0) ;"======================================================================= "RTN","TMGNDF1A",22,0) ;"CompileOne(IEN,Quiet,pIndex,ExclArray,OnlyIfNew) "RTN","TMGNDF1A",23,0) ;"$$MakeCompRec(Array,Quiet) "RTN","TMGNDF1A",24,0) ;"StuffCompRec(IEN,Array,Quiet,ExclArray,Option) "RTN","TMGNDF1A",25,0) ;"FillGenericName(IEN) "RTN","TMGNDF1A",26,0) ;"MakeGenericName(IEN) "RTN","TMGNDF1A",27,0) "RTN","TMGNDF1A",28,0) ;"GetVADrugInfo(IEN,Array) "RTN","TMGNDF1A",29,0) ;"$$GetDrugInfo(IEN,Array,pIndex,noLink) "RTN","TMGNDF1A",30,0) "RTN","TMGNDF1A",31,0) ;"GetSingleRec(File,GRef,IEN,Array) "RTN","TMGNDF1A",32,0) ;"GetMultRec(File,GRef,IEN,Array) "RTN","TMGNDF1A",33,0) ;"LinkToVAProd(Array,Results) "RTN","TMGNDF1A",34,0) ;"Link2VAProd(Array,Results,pIndex) "RTN","TMGNDF1A",35,0) ;"CheckLink(IEN,Array,Results) "RTN","TMGNDF1A",36,0) ;"CheckNDCLink(IEN,Array,Results) "RTN","TMGNDF1A",37,0) ;"IndexVAProd(pArray) "RTN","TMGNDF1A",38,0) ;"GetIndexList(Ingredient,pIndex,pArray) "RTN","TMGNDF1A",39,0) "RTN","TMGNDF1A",40,0) ;"FixGenerics "RTN","TMGNDF1A",41,0) ;"ScanFor(Name,Array) "RTN","TMGNDF1A",42,0) ;"FindSimNames(Name,Array) "RTN","TMGNDF1A",43,0) "RTN","TMGNDF1A",44,0) ;"======================================================================= "RTN","TMGNDF1A",45,0) ;"======================================================================= "RTN","TMGNDF1A",46,0) Menu "RTN","TMGNDF1A",47,0) ;"Purpose: To give an interactive menu "RTN","TMGNDF1A",48,0) "RTN","TMGNDF1A",49,0) new Menu,UsrSlct "RTN","TMGNDF1A",50,0) set Menu(0)="Pick Option for Compiling FDA Imported Data (1A)" "RTN","TMGNDF1A",51,0) set Menu(1)="Compile/Refresh ALL FDA data into IMPORT file"_$char(9)_"CompileAll" "RTN","TMGNDF1A",52,0) set Menu(2)="Compile/Refresh JUST NEW FDA data into IMPORT file"_$char(9)_"CompileNew" "RTN","TMGNDF1A",53,0) set Menu(3)="Compile/Refresh ONE chosen FDA entry into IMPORT file"_$char(9)_"CompileChosen" "RTN","TMGNDF1A",54,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF1A",55,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF1A",56,0) "RTN","TMGNDF1A",57,0) CD1 "RTN","TMGNDF1A",58,0) write # "RTN","TMGNDF1A",59,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF1A",60,0) if UsrSlct="^" goto CDDone "RTN","TMGNDF1A",61,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF1A",62,0) "RTN","TMGNDF1A",63,0) if UsrSlct="Prev" goto Menu^TMGNDF0C ;"quit can occur from there... "RTN","TMGNDF1A",64,0) if UsrSlct="Next" goto Menu^TMGNDF1D ;"quit can occur from there... "RTN","TMGNDF1A",65,0) if UsrSlct="CompileAll" do Compile(0) goto CD1 "RTN","TMGNDF1A",66,0) if UsrSlct="CompileNew" do Compile(2) goto CD1 "RTN","TMGNDF1A",67,0) if UsrSlct="CompileChosen" do Compile(1) goto CD1 "RTN","TMGNDF1A",68,0) goto CDDone "RTN","TMGNDF1A",69,0) CDDone "RTN","TMGNDF1A",70,0) quit "RTN","TMGNDF1A",71,0) "RTN","TMGNDF1A",72,0) ;"======================================================================= "RTN","TMGNDF1A",73,0) "RTN","TMGNDF1A",74,0) Compile(Option) "RTN","TMGNDF1A",75,0) ;"Purpose: To collect relevent data from the TMG FDA * files and put into one record "RTN","TMGNDF1A",76,0) ;"Input: Option: OPTIONAL. Default=0. "RTN","TMGNDF1A",77,0) ;" if 0, all records are added "RTN","TMGNDF1A",78,0) ;" If 1, then only ONE record (user chosed) will be compiled. "RTN","TMGNDF1A",79,0) ;" If 2, then only records that are NEW will "RTN","TMGNDF1A",80,0) ;" be added. Existing records in 22706.9 will not be affected "RTN","TMGNDF1A",81,0) ;" If 3, then only record(s) supplied will be compiled. "RTN","TMGNDF1A",82,0) ;" Option(IEN)="" "RTN","TMGNDF1A",83,0) ;" Option(IEN)="" "RTN","TMGNDF1A",84,0) ;" If Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF1A",85,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF1A",86,0) ;"Output: The file 22706.9 (TMG FDA IMPORT COMPILED) has records added. "RTN","TMGNDF1A",87,0) ;"Result: none "RTN","TMGNDF1A",88,0) "RTN","TMGNDF1A",89,0) new pIndex set pIndex=$$GetpVAPIndex() "RTN","TMGNDF1A",90,0) "RTN","TMGNDF1A",91,0) new abort set abort=0 "RTN","TMGNDF1A",92,0) set Option=+$get(Option) "RTN","TMGNDF1A",93,0) set OnlyIfNew=(Option=2) "RTN","TMGNDF1A",94,0) new CompOption set CompOption=OnlyIfNew "RTN","TMGNDF1A",95,0) merge CompOption("FIX CHAIN")=Option("FIX CHAIN") "RTN","TMGNDF1A",96,0) "RTN","TMGNDF1A",97,0) new % set %=2 "RTN","TMGNDF1A",98,0) new ExclArray "RTN","TMGNDF1A",99,0) if $data(^TMG(22706.9,"VAP1"))>0 do ;"a test for a prior run "RTN","TMGNDF1A",100,0) . if (Option=1)!(Option=2)!(Option=3) quit "RTN","TMGNDF1A",101,0) . write "Prior import processing detected.",! "RTN","TMGNDF1A",102,0) . if Option=0 write "Import ONLY NEW drugs" do YN^DICN write ! "RTN","TMGNDF1A",103,0) . if %=-1 quit "RTN","TMGNDF1A",104,0) . if %=1 set OnlyIfNew=1 quit "RTN","TMGNDF1A",105,0) . write "Choose fields in import file to NOT to OVER WRITE" do YN^DICN write ! "RTN","TMGNDF1A",106,0) . if %=1 do GetExclFields(.ExclArray) "RTN","TMGNDF1A",107,0) if %=-1 goto CADone "RTN","TMGNDF1A",108,0) "RTN","TMGNDF1A",109,0) write "Compiling FDA data into a unified file, for later import.",! "RTN","TMGNDF1A",110,0) new Itr,IEN "RTN","TMGNDF1A",111,0) if Option=1 do "RTN","TMGNDF1A",112,0) . new X,Y,DIC "RTN","TMGNDF1A",113,0) . set DIC=22706.5,DIC(0)="MAEQ" "RTN","TMGNDF1A",114,0) . set DIC("A")="Select FDA drug for import: " "RTN","TMGNDF1A",115,0) . do ^DIC write ! "RTN","TMGNDF1A",116,0) . if +Y'>-1 quit "RTN","TMGNDF1A",117,0) . do CompileOne(+Y,0,pIndex,.ExclArray,.CompOption) "RTN","TMGNDF1A",118,0) . new killthis "RTN","TMGNDF1A",119,0) "RTN","TMGNDF1A",120,0) if Option=3 do "RTN","TMGNDF1A",121,0) . set IEN="" "RTN","TMGNDF1A",122,0) . for set IEN=$order(Option(IEN)) quit:(IEN="")!abort do "RTN","TMGNDF1A",123,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF1A",124,0) . . do CompileOne(IEN,0,pIndex,.ExclArray,.CompOption) "RTN","TMGNDF1A",125,0) . . new killthis "RTN","TMGNDF1A",126,0) "RTN","TMGNDF1A",127,0) else do "RTN","TMGNDF1A",128,0) . set IEN=$$ItrInit^TMGITR(22706.5,.Itr) "RTN","TMGNDF1A",129,0) . do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1A",130,0) . if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!(abort=1) "RTN","TMGNDF1A",131,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF1A",132,0) . . do CompileOne(IEN,0,pIndex,.ExclArray,.CompOption) "RTN","TMGNDF1A",133,0) . . new killthis "RTN","TMGNDF1A",134,0) CADone "RTN","TMGNDF1A",135,0) write !,"Done.",! "RTN","TMGNDF1A",136,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1A",137,0) quit "RTN","TMGNDF1A",138,0) "RTN","TMGNDF1A",139,0) "RTN","TMGNDF1A",140,0) ReCompOne(IEN22706d9,Option) "RTN","TMGNDF1A",141,0) ;"Purpose: To recompile a given record in file 22706.9 "RTN","TMGNDF1A",142,0) ;"Input: IEN -- IEN from 22706.9 "RTN","TMGNDF1A",143,0) ;" OPTION -- Optional. Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF1A",144,0) ;" to file DRUG, POI, OI, OQV etc. "RTN","TMGNDF1A",145,0) ;"Results: none "RTN","TMGNDF1A",146,0) "RTN","TMGNDF1A",147,0) new fdaIEN "RTN","TMGNDF1A",148,0) set fdaIEN=+$piece($get(^TMG(22706.9,IEN22706d9,0)),"^",1) "RTN","TMGNDF1A",149,0) new pIndex set pIndex=$$GetpVAPIndex() "RTN","TMGNDF1A",150,0) set Option=2 ;"2-> ask for overwrites. "RTN","TMGNDF1A",151,0) do CompileOne(fdaIEN,0,pIndex,,.Option) "RTN","TMGNDF1A",152,0) "RTN","TMGNDF1A",153,0) quit "RTN","TMGNDF1A",154,0) "RTN","TMGNDF1A",155,0) "RTN","TMGNDF1A",156,0) CompileOne(IEN,Quiet,pIndex,ExclArray,Option) "RTN","TMGNDF1A",157,0) ;"Purpose: To collect relevent data from the TMG FDA * files, or one entry, and put into one record "RTN","TMGNDF1A",158,0) ;"Input: IEN -- the IEN from file 22706.5 (TMG FDA LISTING) that should be added. "RTN","TMGNDF1A",159,0) ;" Quiet: OPTIONAL (default=1), if 0, then Fileman error messages are displayed. "RTN","TMGNDF1A",160,0) ;" pIndex -- OPTIONAL -- the NAME OF index (as created by IndexVAProd), for faster processing "RTN","TMGNDF1A",161,0) ;" ExclArray --OPTIONAL -- an array with fields to NOT OVERWRITE preexisting fields in. Format: "RTN","TMGNDF1A",162,0) ;" ExclArray(FieldNum)=FieldName <-- data in 22706.9, FieldNum will not be overwritten. "RTN","TMGNDF1A",163,0) ;" ExclArray(FieldNum)=FieldName <-- data in 22706.9, FieldNum will not be overwritten. "RTN","TMGNDF1A",164,0) ;" Option : OPTIONAL. Default=0. PASS BY REFERECE *if* SUBNODES DEFINED "RTN","TMGNDF1A",165,0) ;" 1 -> only records that are NEW will be added. Existing records in 22706.9 will not be affected "RTN","TMGNDF1A",166,0) ;" 2 -> User is prompted for overwrites "RTN","TMGNDF1A",167,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF1A",168,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF1A",169,0) ;"Output: The file 22706.9 (TMG FDA IMPORT COMPILED) may have data/records added. "RTN","TMGNDF1A",170,0) ;"Result: none "RTN","TMGNDF1A",171,0) "RTN","TMGNDF1A",172,0) new Array,result "RTN","TMGNDF1A",173,0) set Quiet=$get(Quiet,1) "RTN","TMGNDF1A",174,0) new destIEN "RTN","TMGNDF1A",175,0) set Option=+$get(Option) "RTN","TMGNDF1A",176,0) new OnlyIfNew set OnlyIfNew=(Option=1) "RTN","TMGNDF1A",177,0) new stuffOption set stuffOption="" "RTN","TMGNDF1A",178,0) if Option=2 set stuffOption("ASK OVERWRITE")=1 "RTN","TMGNDF1A",179,0) "RTN","TMGNDF1A",180,0) if +$get(IEN)'>0 goto C1Done "RTN","TMGNDF1A",181,0) if $$GetDrugInfo(IEN,.Array,.pIndex)=0 goto C1Done ;"returns 0 for error "RTN","TMGNDF1A",182,0) set destIEN=$$FindPriorRec(.Array) "RTN","TMGNDF1A",183,0) if (destIEN>0)&(OnlyIfNew=1) goto C1Done ;"Skip preexisting, don't update, per flag "RTN","TMGNDF1A",184,0) if destIEN'>0 set destIEN=$$MakeCompRec(.Array,Quiet) "RTN","TMGNDF1A",185,0) if destIEN'>0 goto C1Done "RTN","TMGNDF1A",186,0) if $$StuffCompRec(destIEN,.Array,.Quiet,.ExclArray,.stuffOption)=1 goto C1Done ;"returns 1 for error "RTN","TMGNDF1A",187,0) do FillGenericName(destIEN) "RTN","TMGNDF1A",188,0) "RTN","TMGNDF1A",189,0) ;"Set link between COMPILED field in 22706.5 and record in 22706.9 "RTN","TMGNDF1A",190,0) new TMGFDA,TMGMSG,PriorErrorFound "RTN","TMGNDF1A",191,0) set TMGFDA(22706.5,IEN_",",8)=destIEN "RTN","TMGNDF1A",192,0) do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF1A",193,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",194,0) "RTN","TMGNDF1A",195,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF1A",196,0) . do Fix1Name^TMGNDF1D(IEN) "RTN","TMGNDF1A",197,0) . ;"consider if checking for 1 new ROUTE is need in TMGNDF1F "RTN","TMGNDF1A",198,0) . ;"consider if checking for 1 new FORM is need in TMGNDF2A "RTN","TMGNDF1A",199,0) . do Make1Alt^TMGNDF2G(IEN) "RTN","TMGNDF1A",200,0) . do Check1^TMGNDF2H(IEN) "RTN","TMGNDF1A",201,0) . do Refresh1^TMGNDF3C(IEN,.Option) ;"further chaining to occur from this fn. "RTN","TMGNDF1A",202,0) .;"NOTE: I also need to go through modules and add code to handle DELETIONS "RTN","TMGNDF1A",203,0) . ;" (esp DRUG-->POI etc.) "RTN","TMGNDF1A",204,0) "RTN","TMGNDF1A",205,0) "RTN","TMGNDF1A",206,0) C1Done "RTN","TMGNDF1A",207,0) quit "RTN","TMGNDF1A",208,0) "RTN","TMGNDF1A",209,0) "RTN","TMGNDF1A",210,0) FindPriorRec(Array) "RTN","TMGNDF1A",211,0) ;"Purpose: To find an entry in file 22706.9 (TMG FDA IMPORT COMPILED) that "RTN","TMGNDF1A",212,0) ;" matches data in Array, meaning that the data has been previously "RTN","TMGNDF1A",213,0) ;" added. "RTN","TMGNDF1A",214,0) ;" Match criteria: "RTN","TMGNDF1A",215,0) ;"Input: Array: PASS BY REEFRENCE. The drug info array, as created by GetDrugInfo() "RTN","TMGNDF1A",216,0) ;"Result: Returns the IEN from 22706.9, or 0 if no prior match found. "RTN","TMGNDF1A",217,0) "RTN","TMGNDF1A",218,0) new result set result=0 "RTN","TMGNDF1A",219,0) new NDC12 set NDC12=$get(Array("NDC","12DIGIT")) "RTN","TMGNDF1A",220,0) if NDC12>0 set result=$order(^TMG(22706.9,"NDC12",NDC12,"")) "RTN","TMGNDF1A",221,0) "RTN","TMGNDF1A",222,0) quit result "RTN","TMGNDF1A",223,0) "RTN","TMGNDF1A",224,0) "RTN","TMGNDF1A",225,0) MakeCompRec(Array,Quiet) "RTN","TMGNDF1A",226,0) ;"Purpose: To create one entry in file 22706.9 (TMG FDA IMPORT COMPILED) "RTN","TMGNDF1A",227,0) ;" entry will be essentially empty, to be filled later by StuffCompRec "RTN","TMGNDF1A",228,0) ;" Array: PASS BY REFERENCE. The drug info array, as created by GetDrugInfo() "RTN","TMGNDF1A",229,0) ;" Quiet: OPTIONAL (default=1), if 0, then Fileman error messages are displayed. "RTN","TMGNDF1A",230,0) ;"Output: The file 22706.9 (TMG FDA IMPORT COMPILED) has one records added or modified. "RTN","TMGNDF1A",231,0) ;"Result: IEN of new record, or 0 if error "RTN","TMGNDF1A",232,0) ;"Note: any pre-existing data is removed from record. "RTN","TMGNDF1A",233,0) "RTN","TMGNDF1A",234,0) new TMGFDA,IENS,TMGIEN,TMGMSG "RTN","TMGNDF1A",235,0) new result set result=0 ;"default to failure "RTN","TMGNDF1A",236,0) "RTN","TMGNDF1A",237,0) set Quiet=$get(Quiet,1) "RTN","TMGNDF1A",238,0) "RTN","TMGNDF1A",239,0) set IENS="+1," "RTN","TMGNDF1A",240,0) set TMGFDA(22706.9,IENS,.01)=IEN "RTN","TMGNDF1A",241,0) do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") ;"create new record "RTN","TMGNDF1A",242,0) if $data(TMGMSG) do "RTN","TMGNDF1A",243,0) . if Quiet=1 quit "RTN","TMGNDF1A",244,0) . new PriorErrorFound "RTN","TMGNDF1A",245,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",246,0) else set result=+$get(TMGIEN(1)) "RTN","TMGNDF1A",247,0) "RTN","TMGNDF1A",248,0) quit result "RTN","TMGNDF1A",249,0) "RTN","TMGNDF1A",250,0) GetExclFields(ExclArray) "RTN","TMGNDF1A",251,0) ;"Purpose: to determine if there are fields that should not be overwritten "RTN","TMGNDF1A",252,0) ;" during stuffing of records "RTN","TMGNDF1A",253,0) ;"Input: ExclArray -- PASS BY REFERENCE, AN OUT PARAMETER. FORMAT: "RTN","TMGNDF1A",254,0) ;" ExclArray(FieldNum)=FieldName "RTN","TMGNDF1A",255,0) ;" Any preexisting entries will be KILLED "RTN","TMGNDF1A",256,0) "RTN","TMGNDF1A",257,0) kill ExclArray "RTN","TMGNDF1A",258,0) "RTN","TMGNDF1A",259,0) new DIC,X,Y "RTN","TMGNDF1A",260,0) set DIC="^DD(22706.9," "RTN","TMGNDF1A",261,0) set DIC(0)="AEQM" "RTN","TMGNDF1A",262,0) set DIC("S")="IF (Y=.05)!(Y=.05)!(Y=1)!(Y=2)!(Y=3)!(Y=3.4)!(Y=4)!(Y=5)!(Y=7)" "RTN","TMGNDF1A",263,0) set DIC("A")="Pick field to NOT OVERWRITE (^ when done): " "RTN","TMGNDF1A",264,0) GEF1 do ^DIC "RTN","TMGNDF1A",265,0) if Y=-1 goto GEF2 "RTN","TMGNDF1A",266,0) set ExclArray(+Y)=$piece(Y,"^",2) "RTN","TMGNDF1A",267,0) goto GEF1 "RTN","TMGNDF1A",268,0) GEF2 "RTN","TMGNDF1A",269,0) if $data(ExclArray)=0 goto GEFDone "RTN","TMGNDF1A",270,0) write !!,"Will NOT OVERWRITE any preexisting data in these fields:",! "RTN","TMGNDF1A",271,0) new i set i="" "RTN","TMGNDF1A",272,0) for set i=$order(ExclArray(i)) quit:(i="") do "RTN","TMGNDF1A",273,0) . write " ",ExclArray(i)," (",i,")",! "RTN","TMGNDF1A",274,0) new % set %=1 "RTN","TMGNDF1A",275,0) write "OK" do YN^DICN write ! "RTN","TMGNDF1A",276,0) if %=1 goto GEFDone "RTN","TMGNDF1A",277,0) kill ExclArray "RTN","TMGNDF1A",278,0) set %=2 "RTN","TMGNDF1A",279,0) write "Pick again" do YN^DICN write ! "RTN","TMGNDF1A",280,0) if %=1 goto GEF1 "RTN","TMGNDF1A",281,0) "RTN","TMGNDF1A",282,0) GEFDone "RTN","TMGNDF1A",283,0) quit "RTN","TMGNDF1A",284,0) "RTN","TMGNDF1A",285,0) "RTN","TMGNDF1A",286,0) StuffCompRec(IEN,Array,Quiet,ExclArray,Option) "RTN","TMGNDF1A",287,0) ;"Purpose: To fill in data for one entry in file 22706.9 (TMG FDA IMPORT COMPILED) "RTN","TMGNDF1A",288,0) ;"Input: IEN: The IEN of the new record for data to be stuffed into (i.e. IEN22706d9) "RTN","TMGNDF1A",289,0) ;" Array: PASS BY REFERENCE. The drug info array, as created by GetDrugInfo() "RTN","TMGNDF1A",290,0) ;" Quiet: OPTIONAL (default=1), if 0, then Fileman error messages are displayed. "RTN","TMGNDF1A",291,0) ;" ExclArray --OPTIONAL -- an array with fields to NOT OVERWRITE preexisting fields in. Format: "RTN","TMGNDF1A",292,0) ;" ExclArray(FieldNum)=FieldName <-- data in 22706.9, FieldNum will not be overwritten. "RTN","TMGNDF1A",293,0) ;" Option -- OPTIONAL. PASS BY REFERENCE "RTN","TMGNDF1A",294,0) ;" Option("ASK OVERWRITE")=1 --> ask user if overwrites are OK. "RTN","TMGNDF1A",295,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF1A",296,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF1A",297,0) ;"Output: The file 22706.9 (TMG FDA IMPORT COMPILED) has one records added or modified. "RTN","TMGNDF1A",298,0) ;"Result: 0=OK, 1=fatal error encountered "RTN","TMGNDF1A",299,0) ;"Note: any pre-existing data is removed from record. (<--??) "RTN","TMGNDF1A",300,0) "RTN","TMGNDF1A",301,0) new TMGFDA,IENS,TMGIEN,TMGMSG,newIENS "RTN","TMGNDF1A",302,0) new result set result=0 "RTN","TMGNDF1A",303,0) new dataAdded set dataAdded=0 "RTN","TMGNDF1A",304,0) new askOverwrite set askOverwrite=($get(Option("ASK OVERWRITE"))=1) "RTN","TMGNDF1A",305,0) "RTN","TMGNDF1A",306,0) set Quiet=$get(Quiet,1) "RTN","TMGNDF1A",307,0) new map "RTN","TMGNDF1A",308,0) set map(.05)=$name(tradeName) "RTN","TMGNDF1A",309,0) set map(1)=$name(Array("STRENGTH")) "RTN","TMGNDF1A",310,0) set map(2)=$name(Array("UNIT")) "RTN","TMGNDF1A",311,0) set map(3)=$name(Array("ROUTE",1,"NAME")) "RTN","TMGNDF1A",312,0) set map(3.4)=$name(Array("DOSE",1,"DOSAGE NAME")) "RTN","TMGNDF1A",313,0) set map(4)=$name(Array("NDC")) "RTN","TMGNDF1A",314,0) set map(5)=$name(Array("NDC","12DIGIT")) "RTN","TMGNDF1A",315,0) set map(7)=$name(codeOTC) "RTN","TMGNDF1A",316,0) "RTN","TMGNDF1A",317,0) new codeOTC set codeOTC=$get(Array("RX OR OTC")) "RTN","TMGNDF1A",318,0) if codeOTC["PRESCRIPTION" set codeOTC="R" "RTN","TMGNDF1A",319,0) else if codeOTC["OTC" set codeOTC="O" "RTN","TMGNDF1A",320,0) else set codeOTC="" "RTN","TMGNDF1A",321,0) "RTN","TMGNDF1A",322,0) new tradeName set tradeName=$get(Array("TRADENAME")) "RTN","TMGNDF1A",323,0) if $length(tradeName)>64 set tradeName=$extract(tradeName,1,61)_"..." "RTN","TMGNDF1A",324,0) "RTN","TMGNDF1A",325,0) set IENS=IEN_"," "RTN","TMGNDF1A",326,0) "RTN","TMGNDF1A",327,0) new oldData "RTN","TMGNDF1A",328,0) new field set field="" "RTN","TMGNDF1A",329,0) for set field=$order(map(field)) quit:(field="") do "RTN","TMGNDF1A",330,0) . new pVar,value "RTN","TMGNDF1A",331,0) . set pVar=$get(map(field)) "RTN","TMGNDF1A",332,0) . set value=$get(@pVar) "RTN","TMGNDF1A",333,0) . if value="" quit "RTN","TMGNDF1A",334,0) . set oldData(field)=$$GET1^DIQ(22706.9,IENS,field) "RTN","TMGNDF1A",335,0) . if ($data(ExclArray(field))'=0)&(oldData(field)'="") quit "RTN","TMGNDF1A",336,0) . set TMGFDA(22706.9,IENS,field)=value "RTN","TMGNDF1A",337,0) "RTN","TMGNDF1A",338,0) new untrimFDA merge untrimFDA=TMGFDA "RTN","TMGNDF1A",339,0) set newIENS=$$TrimFDA^TMGDBAPI(.TMGFDA) ;"remove entries for data already present. "RTN","TMGNDF1A",340,0) if $data(TMGFDA)=0 goto SCR1 "RTN","TMGNDF1A",341,0) "RTN","TMGNDF1A",342,0) new abort set abort=0 "RTN","TMGNDF1A",343,0) if askOverwrite do "RTN","TMGNDF1A",344,0) . new field set field="" "RTN","TMGNDF1A",345,0) . for set field=$order(TMGFDA(22706.9,IENS,field)) quit:(field="") do "RTN","TMGNDF1A",346,0) . . write field,": '",$get(oldData(field)),"' --> '",$get(TMGFDA(22706.9,IENS,field)),"'",! "RTN","TMGNDF1A",347,0) . write !,"Stuff this data into file 22706.9, record #",IEN,"? " "RTN","TMGNDF1A",348,0) . new % set %=2 do YN^DICN write ! "RTN","TMGNDF1A",349,0) . if %=1 quit "RTN","TMGNDF1A",350,0) . set abort=1 "RTN","TMGNDF1A",351,0) if abort=1 goto MCRDone "RTN","TMGNDF1A",352,0) "RTN","TMGNDF1A",353,0) do FILE^DIE("E","TMGFDA","TMGMSG") ;" Fill existing record "RTN","TMGNDF1A",354,0) if $data(TMGMSG) do goto MCRDone "RTN","TMGNDF1A",355,0) . if Quiet=1 quit "RTN","TMGNDF1A",356,0) . new PriorErrorFound "RTN","TMGNDF1A",357,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",358,0) . set result=1 "RTN","TMGNDF1A",359,0) else set dataAdded=1 "RTN","TMGNDF1A",360,0) "RTN","TMGNDF1A",361,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF1A",362,0) . new opt "RTN","TMGNDF1A",363,0) . set opt("FIX CHAIN")=1 "RTN","TMGNDF1A",364,0) . set opt("FIX CHAIN","IEN22706d9")=IEN ;"used later in chain "RTN","TMGNDF1A",365,0) . ;"pass signal to fix chain forward "RTN","TMGNDF1A",366,0) . do Refresh1^TMGNDF3C(IEN,.opt) ;" no results "RTN","TMGNDF1A",367,0) "RTN","TMGNDF1A",368,0) SCR1 "RTN","TMGNDF1A",369,0) new i,MaxCount,subfile "RTN","TMGNDF1A",370,0) kill TMGFDA,TMGIEN "RTN","TMGNDF1A",371,0) set MaxCount=$get(Array("FILE 50.68 IEN","COUNT")) "RTN","TMGNDF1A",372,0) set subfile=22706.914 "RTN","TMGNDF1A",373,0) for i=1:1:MaxCount do quit:(abort=1) "RTN","TMGNDF1A",374,0) . set IENS="+"_i_","_IEN_"," "RTN","TMGNDF1A",375,0) . new addIEN set addIEN=$get(Array("FILE 50.68 IEN",i)) "RTN","TMGNDF1A",376,0) . set TMGFDA(subfile,IENS,.01)=addIEN "RTN","TMGNDF1A",377,0) . ;"------ "RTN","TMGNDF1A",378,0) . set newIENS=$$TrimFDA^TMGDBAPI(.TMGFDA) ;"remove entries for data already present. "RTN","TMGNDF1A",379,0) . if $data(TMGFDA)'>0 quit "RTN","TMGNDF1A",380,0) . if askOverwrite do quit:(abort=1) "RTN","TMGNDF1A",381,0) . . new field set field="" "RTN","TMGNDF1A",382,0) . . for set field=$order(TMGFDA(subfile,IENS,field)) quit:(field="") do "RTN","TMGNDF1A",383,0) . . . write field,": ",$$GET1^DIQ(subfile,IENS,field)," --> ",$get(TMGFDA(subfile,IENS,field)),! "RTN","TMGNDF1A",384,0) . . write !,"Stuff this data into subfile ",subfile,", record #",IENS,"? " "RTN","TMGNDF1A",385,0) . . new % set %=2 do YN^DICN write ! "RTN","TMGNDF1A",386,0) . . if %=1 quit "RTN","TMGNDF1A",387,0) . . set abort=1 "RTN","TMGNDF1A",388,0) . if newIENS'["+" do "RTN","TMGNDF1A",389,0) . . new tempFDA merge tempFDA(subfile,newIENS)=TMGFDA(subfile,IENS) "RTN","TMGNDF1A",390,0) . . kill TMGFDA merge TMGFDA=tempFDA "RTN","TMGNDF1A",391,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1A",392,0) . else do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF1A",393,0) . if $data(TMGMSG) do "RTN","TMGNDF1A",394,0) . . if Quiet=1 quit "RTN","TMGNDF1A",395,0) . . new PriorErrorFound "RTN","TMGNDF1A",396,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",397,0) . else set dataAdded=1 "RTN","TMGNDF1A",398,0) if abort=1 goto MCRDone "RTN","TMGNDF1A",399,0) "RTN","TMGNDF1A",400,0) SCR2 "RTN","TMGNDF1A",401,0) kill TMGFDA,TMGIEN "RTN","TMGNDF1A",402,0) set MaxCount=$get(Array("FILE 50.68 IEN","POSS MATCH","COUNT")) "RTN","TMGNDF1A",403,0) set subfile=22706.915 "RTN","TMGNDF1A",404,0) for i=1:1:MaxCount do quit:(abort=1) "RTN","TMGNDF1A",405,0) . set IENS="+"_i_","_IEN_"," "RTN","TMGNDF1A",406,0) . new addIEN set addIEN=$get(Array("FILE 50.68 IEN","POSS MATCH",i)) "RTN","TMGNDF1A",407,0) . set TMGFDA(subfile,IENS,.01)=addIEN "RTN","TMGNDF1A",408,0) . set newIENS=$$TrimFDA^TMGDBAPI(.TMGFDA) ;"remove entries for data already present. "RTN","TMGNDF1A",409,0) . if $data(TMGFDA)'>0 quit "RTN","TMGNDF1A",410,0) . if askOverwrite do quit:(abort=1) "RTN","TMGNDF1A",411,0) . . new field set field="" "RTN","TMGNDF1A",412,0) . . for set field=$order(TMGFDA(subfile,IENS,field)) quit:(field="") do "RTN","TMGNDF1A",413,0) . . . write field,": '",$$GET1^DIQ(subfile,IENS,field),"' --> ",$get(TMGFDA(subfile,IENS,field)),! "RTN","TMGNDF1A",414,0) . . write !,"Stuff this data into subfile ",subfile,", record #",IENS,"? " "RTN","TMGNDF1A",415,0) . . new % set %=2 do YN^DICN write ! "RTN","TMGNDF1A",416,0) . . if %=1 quit "RTN","TMGNDF1A",417,0) . . set abort=1 "RTN","TMGNDF1A",418,0) . if newIENS'["+" do "RTN","TMGNDF1A",419,0) . . new tempFDA merge tempFDA(subfile,newIENS)=TMGFDA(subfile,IENS) "RTN","TMGNDF1A",420,0) . . kill TMGFDA merge TMGFDA=tempFDA "RTN","TMGNDF1A",421,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1A",422,0) . else do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF1A",423,0) . if $data(TMGMSG) do "RTN","TMGNDF1A",424,0) . . if Quiet=1 quit "RTN","TMGNDF1A",425,0) . . new PriorErrorFound "RTN","TMGNDF1A",426,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",427,0) . else set dataAdded=1 "RTN","TMGNDF1A",428,0) if abort=1 goto MCRDone "RTN","TMGNDF1A",429,0) "RTN","TMGNDF1A",430,0) SCR3 "RTN","TMGNDF1A",431,0) kill TMGFDA,TMGIEN "RTN","TMGNDF1A",432,0) set MaxCount=$get(Array("FORMULATION","COUNT")) "RTN","TMGNDF1A",433,0) set subfile=22706.916 "RTN","TMGNDF1A",434,0) for i=1:1:MaxCount do "RTN","TMGNDF1A",435,0) . set IENS="+"_i_","_IEN_"," "RTN","TMGNDF1A",436,0) . set TMGFDA(subfile,IENS,.01)=i "RTN","TMGNDF1A",437,0) . set TMGFDA(subfile,IENS,2)=$get(Array("FORMULATION",i,"INGREDIENT NAME","FILE 50.416 IEN")) "RTN","TMGNDF1A",438,0) . set TMGFDA(subfile,IENS,3)=$get(Array("FORMULATION",i,"STRENGTH")) "RTN","TMGNDF1A",439,0) . set TMGFDA(subfile,IENS,5)=$get(Array("FORMULATION",i,"UNIT","FILE 50.607 IEN")) ;"should be a ptr "RTN","TMGNDF1A",440,0) . ;"set TMGFDA(subfile,IENS,5)=$get(Array("FORMULATION",2,"UNIT")) ;"should be a ptr "RTN","TMGNDF1A",441,0) . ;"---------------------- "RTN","TMGNDF1A",442,0) . set newIENS=$$TrimFDA^TMGDBAPI(.TMGFDA) ;"remove entries for data already present. "RTN","TMGNDF1A",443,0) . if $data(TMGFDA)=0 quit "RTN","TMGNDF1A",444,0) . if askOverwrite do quit:(abort=1) "RTN","TMGNDF1A",445,0) . . new field set field="" "RTN","TMGNDF1A",446,0) . . for set field=$order(TMGFDA(subfile,IENS,field)) quit:(field="") do "RTN","TMGNDF1A",447,0) . . . write field,": '",$$GET1^DIQ(subfile,IENS,field),"' --> ",$get(TMGFDA(subfile,IENS,field)),! "RTN","TMGNDF1A",448,0) . . write !,"Stuff this data into subfile ",subfile,", record #",IENS,"? " "RTN","TMGNDF1A",449,0) . . new % set %=2 do YN^DICN write ! "RTN","TMGNDF1A",450,0) . . if %=1 quit "RTN","TMGNDF1A",451,0) . . set abort=1 "RTN","TMGNDF1A",452,0) . if newIENS'["+" do "RTN","TMGNDF1A",453,0) . . new tempFDA merge tempFDA(subfile,newIENS)=TMGFDA(subfile,IENS) "RTN","TMGNDF1A",454,0) . . kill TMGFDA merge TMGFDA=tempFDA "RTN","TMGNDF1A",455,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1A",456,0) . else do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF1A",457,0) . if $data(TMGMSG) do "RTN","TMGNDF1A",458,0) . . if Quiet=1 quit "RTN","TMGNDF1A",459,0) . . new PriorErrorFound "RTN","TMGNDF1A",460,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",461,0) . else set dataAdded=1 "RTN","TMGNDF1A",462,0) if abort=1 goto MCRDone "RTN","TMGNDF1A",463,0) "RTN","TMGNDF1A",464,0) SCR4 "RTN","TMGNDF1A",465,0) ;"Add a comment "RTN","TMGNDF1A",466,0) if dataAdded=0 goto MCRDone "RTN","TMGNDF1A",467,0) kill TMGFDA "RTN","TMGNDF1A",468,0) new %DT,X,Y "RTN","TMGNDF1A",469,0) set %DT="T",X="NOW" do ^%DT ;"get current time "RTN","TMGNDF1A",470,0) set IENS="+1,"_IEN_"," "RTN","TMGNDF1A",471,0) set TMGFDA(22706.9001,IENS,.01)="UPDATE VIA AUTOMATIC IMPORT COMPILE" "RTN","TMGNDF1A",472,0) set TMGFDA(22706.9001,IENS,1)=Y "RTN","TMGNDF1A",473,0) do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF1A",474,0) if $data(TMGMSG) do "RTN","TMGNDF1A",475,0) . if Quiet=1 quit "RTN","TMGNDF1A",476,0) . new PriorErrorFound "RTN","TMGNDF1A",477,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",478,0) "RTN","TMGNDF1A",479,0) MCRDone "RTN","TMGNDF1A",480,0) if abort=1 set result=1 "RTN","TMGNDF1A",481,0) quit result "RTN","TMGNDF1A",482,0) "RTN","TMGNDF1A",483,0) "RTN","TMGNDF1A",484,0) FillGenericName(IEN) "RTN","TMGNDF1A",485,0) ;"Purpose: To create an entry for the GENERIC NAME (field .07) in TMG FDA IMPORT (22706.9) "RTN","TMGNDF1A",486,0) ;"Input: IEN -- the IEN in 22706.9 to alter "RTN","TMGNDF1A",487,0) ;"Output: the record specified by IEN will be altered (if ingredients are known) "RTN","TMGNDF1A",488,0) ;"Result: None "RTN","TMGNDF1A",489,0) "RTN","TMGNDF1A",490,0) new name "RTN","TMGNDF1A",491,0) set name=$$MakeGenericName(IEN) "RTN","TMGNDF1A",492,0) if $data(^TMG(22706.9,IEN,0))>0 do "RTN","TMGNDF1A",493,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1A",494,0) . set TMGFDA(22706.9,IEN_",",.07)=name "RTN","TMGNDF1A",495,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1A",496,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1A",497,0) . ;"set $piece(^TMG(22706.9,IEN,0),"^",6)=name ;"There is no index on this field, so direct write OK "RTN","TMGNDF1A",498,0) quit "RTN","TMGNDF1A",499,0) "RTN","TMGNDF1A",500,0) "RTN","TMGNDF1A",501,0) MakeGenericName(IEN) "RTN","TMGNDF1A",502,0) ;"Purpose: To create a GENERIC NAME string "RTN","TMGNDF1A",503,0) ;"Input: IEN -- the IEN in 22706.9 to use "RTN","TMGNDF1A",504,0) ;"Result: returns a string for the generic name. "RTN","TMGNDF1A",505,0) "RTN","TMGNDF1A",506,0) new Ingredients "RTN","TMGNDF1A",507,0) new i "RTN","TMGNDF1A",508,0) new result set result="" "RTN","TMGNDF1A",509,0) "RTN","TMGNDF1A",510,0) set i=$order(^TMG(22706.9,IEN,4,0)) "RTN","TMGNDF1A",511,0) if i'="" for do quit:(+i'>0) "RTN","TMGNDF1A",512,0) . new IgdIEN,IgdName "RTN","TMGNDF1A",513,0) . set IgdIEN=+$piece($get(^TMG(22706.9,IEN,4,i,0)),"^",3) ;"get field#2, INGREDIENT (ptr to 50.416) "RTN","TMGNDF1A",514,0) . if IgdIEN>0 do "RTN","TMGNDF1A",515,0) . . set IgdName=$$GET1^DIQ(50.416,IgdIEN,.01) "RTN","TMGNDF1A",516,0) . . set IgdName=$$Substitute^TMGSTUTL(IgdName,"HYDROCHLORIDE","") ;"This is what the VA does... "RTN","TMGNDF1A",517,0) . . new temp set temp=IgdName "RTN","TMGNDF1A",518,0) . . set IgdName=$piece(IgdName,",",1) ;"I will also trim off anything after a comma. "RTN","TMGNDF1A",519,0) . . if $length(IgdName)<5 set IgdName=temp ;"I had problem with: N,N-1 ACETYL.... --> 'N' "RTN","TMGNDF1A",520,0) . . set IgdName=$translate(IgdName,"/","\") ;convert '/' --> '\' ('/' used later to concate ingredients) "RTN","TMGNDF1A",521,0) . . set IgdName=$$Trim^TMGSTUTL(IgdName) "RTN","TMGNDF1A",522,0) . . if IgdName'="" set Ingredients(IgdName)="" ;"will sort alphabetically "RTN","TMGNDF1A",523,0) . set i=$order(^TMG(22706.9,IEN,4,i)) "RTN","TMGNDF1A",524,0) "RTN","TMGNDF1A",525,0) set i=$order(Ingredients("")) "RTN","TMGNDF1A",526,0) if i'="" for do quit:(i="") "RTN","TMGNDF1A",527,0) . if result'="" set result=result_"/" "RTN","TMGNDF1A",528,0) . set result=result_i "RTN","TMGNDF1A",529,0) . set i=$order(Ingredients(i)) "RTN","TMGNDF1A",530,0) "RTN","TMGNDF1A",531,0) set result=$extract(result,1,64) "RTN","TMGNDF1A",532,0) "RTN","TMGNDF1A",533,0) quit result "RTN","TMGNDF1A",534,0) "RTN","TMGNDF1A",535,0) "RTN","TMGNDF1A",536,0) GetVADrugInfo(IEN,Array) "RTN","TMGNDF1A",537,0) ;"Purpose: To collect info from VA Product file into an array similar (but limited) to "RTN","TMGNDF1A",538,0) ;" that returned from GetDrugInfo "RTN","TMGNDF1A",539,0) ;"Input: IEN -- the IEN from file 50.68 (VA PRODUCT) "RTN","TMGNDF1A",540,0) "RTN","TMGNDF1A",541,0) kill Array "RTN","TMGNDF1A",542,0) new DIC,X,Y "RTN","TMGNDF1A",543,0) "RTN","TMGNDF1A",544,0) set Array("TRADENAME")=$$GET1^DIQ(50.68,IEN,.01) "RTN","TMGNDF1A",545,0) set Array("STRENGTH")=$$GET1^DIQ(50.68,IEN,2) "RTN","TMGNDF1A",546,0) set Array("UNIT")=$$GET1^DIQ(50.68,IEN,3) "RTN","TMGNDF1A",547,0) "RTN","TMGNDF1A",548,0) set DIC=50.67 "RTN","TMGNDF1A",549,0) set DIC(0)="M" "RTN","TMGNDF1A",550,0) set X=Array("TRADENAME") "RTN","TMGNDF1A",551,0) do ^DIC "RTN","TMGNDF1A",552,0) set Array("NDC")=$$GET1^DIQ(50.67,+Y_",",1) "RTN","TMGNDF1A",553,0) ;"set Array("NDC 12DIGIT")=ndc (see format below) "RTN","TMGNDF1A",554,0) "RTN","TMGNDF1A",555,0) new i,count "RTN","TMGNDF1A",556,0) set count=0 "RTN","TMGNDF1A",557,0) set i=$order(^PSNDF(50.68,IEN,2,0)) "RTN","TMGNDF1A",558,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF1A",559,0) . new node set node=$get(^PSNDF(50.68,IEN,2,i,0)) "RTN","TMGNDF1A",560,0) . set count=count+1 "RTN","TMGNDF1A",561,0) . set Array("FORMULATION","COUNT")=count "RTN","TMGNDF1A",562,0) . set Array("FORMULATION",count,"INGREDIENT NAME","FILE 50.416 IEN")=$piece(node,"^",1) "RTN","TMGNDF1A",563,0) . set Array("FORMULATION",count,"INGREDIENT NAME")=$$GET1^DIQ(50.416,$piece(node,"^",1),.01) "RTN","TMGNDF1A",564,0) . set Array("FORMULATION",count,"STRENGTH")=$piece(node,"^",2) "RTN","TMGNDF1A",565,0) . set Array("FORMULATION",count,"UNIT","FILE 50.607 IEN")=$piece(node,"^",3) "RTN","TMGNDF1A",566,0) . set Array("FORMULATION",count,"UNIT")=$$GET1^DIQ(50.607,$piece(node,"^",3),.01) "RTN","TMGNDF1A",567,0) . set i=$order(^PSNDF(50.68,IEN,2,i)) "RTN","TMGNDF1A",568,0) "RTN","TMGNDF1A",569,0) quit "RTN","TMGNDF1A",570,0) "RTN","TMGNDF1A",571,0) GetDrugInfo(IEN,Array,pIndex,noLink) "RTN","TMGNDF1A",572,0) ;"Purpose: To collect all info about a drug into one array "RTN","TMGNDF1A",573,0) ;"Input: IEN -- the IEN from TMG FDA LISTING file "RTN","TMGNDF1A",574,0) ;" Array -- an OUT parameter. See format below "RTN","TMGNDF1A",575,0) ;" pIndex -- OPTIONAL -- the NAME OF index (as created by IndexVAProd), for faster processing "RTN","TMGNDF1A",576,0) ;" noLink -- OPTIONAL -- default=0. If 1, then linkage to prior VA drugs is NOT attempted. "RTN","TMGNDF1A",577,0) ;"Output: Array will be filled with info as above "RTN","TMGNDF1A",578,0) ;" Array('FILE 50.68 IEN',1)=IEN "RTN","TMGNDF1A",579,0) ;" Array('FILE 50.68 IEN','COUNT') "RTN","TMGNDF1A",580,0) ;" Array('LABEL CODE') "RTN","TMGNDF1A",581,0) ;" Array('PRODUCT CODE') "RTN","TMGNDF1A",582,0) ;" Array('STRENGTH') "RTN","TMGNDF1A",583,0) ;" Array('UNIT') "RTN","TMGNDF1A",584,0) ;" Array('RX OR OTC') "RTN","TMGNDF1A",585,0) ;" Array('FIRM','NAME') "RTN","TMGNDF1A",586,0) ;" Array('FIRM','LABEL CODE') "RTN","TMGNDF1A",587,0) ;" Array('FIRM','ADDRESS HEADER') "RTN","TMGNDF1A",588,0) ;" Array('FIRM','STREET') "RTN","TMGNDF1A",589,0) ;" Array('FIRM','PO BOX') "RTN","TMGNDF1A",590,0) ;" Array('FIRM','FOREIGN ADDRESS') "RTN","TMGNDF1A",591,0) ;" Array('FIRM','CITY') "RTN","TMGNDF1A",592,0) ;" Array('FIRM','STATE') "RTN","TMGNDF1A",593,0) ;" Array('FIRM','ZIP') "RTN","TMGNDF1A",594,0) ;" Array('FIRM','PROVINCE') "RTN","TMGNDF1A",595,0) ;" Array('FIRM','COUNTRY') "RTN","TMGNDF1A",596,0) ;" Array('TRADENAME') "RTN","TMGNDF1A",597,0) ;" Array('PACKAGE',1,'CODE') "RTN","TMGNDF1A",598,0) ;" Array('PACKAGE',1,'SIZE') "RTN","TMGNDF1A",599,0) ;" Array('PACKAGE',1,'TYPE') "RTN","TMGNDF1A",600,0) ;" Array('FORMULATION','COUNT')=1 "RTN","TMGNDF1A",601,0) ;" Array('FORMULATION',1,'STRENGTH') "RTN","TMGNDF1A",602,0) ;" Array('FORMULATION',1,'UNIT') "RTN","TMGNDF1A",603,0) ;" Array('FORMULATION',1,'UNIT','FILE 50.607 IEN') ;note may contain -1 if match not found "RTN","TMGNDF1A",604,0) ;" Array('FORMULATION',1,'INGREDIENT NAME') "RTN","TMGNDF1A",605,0) ;" Array('FORMULATION',1,'INGREDIENT NAME','FILE 50.416 IEN) ;note may contain -1 if match not found "RTN","TMGNDF1A",606,0) ;" Array('APPLICATION') "RTN","TMGNDF1A",607,0) ;" Array('PRODUCT NUMBER') "RTN","TMGNDF1A",608,0) ;" Array('ROUTE',1,'CODE' "RTN","TMGNDF1A",609,0) ;" Array('ROUTE',1,'NAME') "RTN","TMGNDF1A",610,0) ;" Array('DOSE',1,'DOSE FORM') "RTN","TMGNDF1A",611,0) ;" Array('DOSE',1,'DO SAGE NAME') "RTN","TMGNDF1A",612,0) ;" Array('NDC')=ndc (see format below) "RTN","TMGNDF1A",613,0) ;" Array('NDC','12DIGIT')=ndc (see format below) "RTN","TMGNDF1A",614,0) ;" Array('FILE 50.68 IEN','COUNT')=1 "RTN","TMGNDF1A",615,0) ;" Array('FILE 50.68 IEN',1)=1234 "RTN","TMGNDF1A",616,0) ;" Array('FILE 50.68 IEN','POSS MATCH','COUNT')=1 "RTN","TMGNDF1A",617,0) ;" Array('FILE 50.68 IEN','POSS MATCH',1)=2345 "RTN","TMGNDF1A",618,0) ;"result: 0 if error found, 1 otherwise (i.e. is OKToContinue) "RTN","TMGNDF1A",619,0) "RTN","TMGNDF1A",620,0) ;"Note the NDC (national drug code) is comprised as follows: "RTN","TMGNDF1A",621,0) ;"It is a 10 digit number comprised of three segments "RTN","TMGNDF1A",622,0) ;" 1st 4-5 digits - producer/packager <--> field#1 (LABEL CODE) in TMG FDA LISTING "RTN","TMGNDF1A",623,0) ;" next 3-4 digits -- the product code <--> field#2 (PRODUCT CODE) in TMG FDA LISTING "RTN","TMGNDF1A",624,0) ;" next 1-2 digits -- package code, specifying the package size <--> field#1 (CODE) in TMG FDA PACKAGES "RTN","TMGNDF1A",625,0) ;" the grouping will be: 4-4-2, or 5-3-2, or 5-4-1 "RTN","TMGNDF1A",626,0) "RTN","TMGNDF1A",627,0) ;" Example Array("NDC")="000002-0351-02" "RTN","TMGNDF1A",628,0) ;" Example Array("NDC","12DIGIT")="000002035102" "RTN","TMGNDF1A",629,0) "RTN","TMGNDF1A",630,0) new TMGARRAY,TMGMSG "RTN","TMGNDF1A",631,0) new PriorErrorFound,i "RTN","TMGNDF1A",632,0) new IENS set IENS=IEN_"," "RTN","TMGNDF1A",633,0) kill Array "RTN","TMGNDF1A",634,0) new result set result=1 "RTN","TMGNDF1A",635,0) "RTN","TMGNDF1A",636,0) do GETS^DIQ(22706.5,IENS,"*","R","TMGARRAY","TMGMSG") "RTN","TMGNDF1A",637,0) "RTN","TMGNDF1A",638,0) if $data(TMGMSG) do "RTN","TMGNDF1A",639,0) . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMSG") "RTN","TMGNDF1A",640,0) . if $data(TMGMSG("DIERR"))'=0 do quit "RTN","TMGNDF1A",641,0) . . ;"do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",642,0) . . set result=0 "RTN","TMGNDF1A",643,0) "RTN","TMGNDF1A",644,0) if result=0 goto GDIDone "RTN","TMGNDF1A",645,0) "RTN","TMGNDF1A",646,0) merge Array=TMGARRAY(22706.5,IENS) "RTN","TMGNDF1A",647,0) "RTN","TMGNDF1A",648,0) ;"Now look for entries in TMG FDA APPLICATION (22706.1) "RTN","TMGNDF1A",649,0) do GetSingleRec(22706.1,"^TMG(22706.1,""B"",",IEN,.Array) "RTN","TMGNDF1A",650,0) set Array("STRENGTH")=$translate(Array("STRENGTH"),",","") ;"remove ',''s from numbers "RTN","TMGNDF1A",651,0) "RTN","TMGNDF1A",652,0) ;"Now look for entries in TMG FDA DOSAGE FORM (22706.2) "RTN","TMGNDF1A",653,0) do GetMultRec(22706.2,"^TMG(22706.2,""B"",",IEN,.Array,"DOSE") "RTN","TMGNDF1A",654,0) "RTN","TMGNDF1A",655,0) ;"Now look for entries in TMG FDA FIRMS (22706.3) "RTN","TMGNDF1A",656,0) do GetSingleRec(22706.3,"^TMG(22706.3,""B"",",IEN,.Array) "RTN","TMGNDF1A",657,0) "RTN","TMGNDF1A",658,0) ;"Now look for entries in TMG FDA FORMULATION (22706.4) "RTN","TMGNDF1A",659,0) do "RTN","TMGNDF1A",660,0) . new tempArray,index "RTN","TMGNDF1A",661,0) . do GetMultRec(22706.4,"^TMG(22706.4,""B"",",IEN,.tempArray,"FORMULATION") "RTN","TMGNDF1A",662,0) . ;"Note: I need instead to screen for duplicates ingredient entries "RTN","TMGNDF1A",663,0) . set index=$order(tempArray("FORMULATION","")) "RTN","TMGNDF1A",664,0) . if +index>0 for do quit:(+index'>0) "RTN","TMGNDF1A",665,0) . . new i2 set i2=index+1 "RTN","TMGNDF1A",666,0) . . new name1,name2 "RTN","TMGNDF1A",667,0) . . set name1=$name(tempArray("FORMULATION",index)) "RTN","TMGNDF1A",668,0) . . for do quit:(+i2'>0) "RTN","TMGNDF1A",669,0) . . . set name2=$name(tempArray("FORMULATION",i2)) "RTN","TMGNDF1A",670,0) . . . set i2=$order(tempArray("FORMULATION",i2)) "RTN","TMGNDF1A",671,0) . . . if $data(@name2)'>0 quit "RTN","TMGNDF1A",672,0) . . . if $$CompArray^TMGMISC(name1,name2) do "RTN","TMGNDF1A",673,0) . . . . kill @name2 "RTN","TMGNDF1A",674,0) . . set index=$order(tempArray("FORMULATION",index)) "RTN","TMGNDF1A",675,0) . ;"Now put cleaned results of tempArray into Array "RTN","TMGNDF1A",676,0) . set index=$order(tempArray("FORMULATION","")) "RTN","TMGNDF1A",677,0) . new count set count=0 "RTN","TMGNDF1A",678,0) . set Array("FORMULATION","COUNT")=0 "RTN","TMGNDF1A",679,0) . if +index>0 for do quit:(+index'>0) "RTN","TMGNDF1A",680,0) . . if $data(tempArray("FORMULATION",index)) do "RTN","TMGNDF1A",681,0) . . . set count=count+1 "RTN","TMGNDF1A",682,0) . . . merge Array("FORMULATION",count)=tempArray("FORMULATION",index) "RTN","TMGNDF1A",683,0) . . . set Array("FORMULATION","COUNT")=count "RTN","TMGNDF1A",684,0) . . set index=$order(tempArray("FORMULATION",index)) "RTN","TMGNDF1A",685,0) "RTN","TMGNDF1A",686,0) ;"Now look for entries in TMG FDA PACKAGES (22706.6) "RTN","TMGNDF1A",687,0) do GetMultRec(22706.6,"^TMG(22706.6,""B"",",IEN,.Array,"PACKAGE") "RTN","TMGNDF1A",688,0) "RTN","TMGNDF1A",689,0) ;"Now look for entries in TMG FDA ROUTES (22706.7) "RTN","TMGNDF1A",690,0) do GetMultRec(22706.7,"^TMG(22706.7,""B"",",IEN,.Array,"ROUTE") "RTN","TMGNDF1A",691,0) if $length($get(Array("ROUTE",1,"NAME")))>16 do "RTN","TMGNDF1A",692,0) . new temp set temp=$$PShortName^TMGSHORT(Array("ROUTE",1,"NAME"),16,1) "RTN","TMGNDF1A",693,0) . if temp="^" quit "RTN","TMGNDF1A",694,0) . set Array("ROUTE",1,"NAME")=temp "RTN","TMGNDF1A",695,0) "RTN","TMGNDF1A",696,0) if $get(Array("FORMULATION","COUNT"),1)=1 do "RTN","TMGNDF1A",697,0) . new strength,str2 "RTN","TMGNDF1A",698,0) . new units,units2 "RTN","TMGNDF1A",699,0) . set strength=Array("STRENGTH") "RTN","TMGNDF1A",700,0) . set str2=$get(Array("FORMULATION",1,"STRENGTH")) "RTN","TMGNDF1A",701,0) . set units=$get(Array("UNIT")) "RTN","TMGNDF1A",702,0) . set units2=$get(Array("FORMULATION",1,"UNIT")) "RTN","TMGNDF1A",703,0) . if (+str2'>0)!(strength'=str2) do "RTN","TMGNDF1A",704,0) . . set Array("FORMULATION",1,"STRENGTH","OLD")=str2 "RTN","TMGNDF1A",705,0) . . set Array("FORMULATION",1,"STRENGTH")=strength "RTN","TMGNDF1A",706,0) . . set Array("FORMULATION",1,"UNIT","OLD")=units2 "RTN","TMGNDF1A",707,0) . . set Array("FORMULATION",1,"UNIT")=units "RTN","TMGNDF1A",708,0) "RTN","TMGNDF1A",709,0) ;"Now search for IEN in 50.68 of all ingredients, and find IEN for units name(s) "RTN","TMGNDF1A",710,0) new i,X,Y,TMGROOT,TMGMSG "RTN","TMGNDF1A",711,0) for i=1:1:Array("FORMULATION","COUNT") do "RTN","TMGNDF1A",712,0) . new DIC "RTN","TMGNDF1A",713,0) . set X=$get(Array("FORMULATION",i,"INGREDIENT NAME")) "RTN","TMGNDF1A",714,0) . if X="" quit "RTN","TMGNDF1A",715,0) . set Y=$$LookupRx^TMGNDF2B(X) "RTN","TMGNDF1A",716,0) . if +Y>0 set Array("FORMULATION",i,"INGREDIENT NAME","FILE 50.416 IEN")=+Y "RTN","TMGNDF1A",717,0) . ;"look up unit name to find IEN in file 50.607 "RTN","TMGNDF1A",718,0) . set DIC(0)="M" "RTN","TMGNDF1A",719,0) . set DIC=50.607 "RTN","TMGNDF1A",720,0) . set X=$get(Array("FORMULATION",i,"UNIT")) "RTN","TMGNDF1A",721,0) . if X="" quit "RTN","TMGNDF1A",722,0) . do ^DIC "RTN","TMGNDF1A",723,0) . if +Y>0 set Array("FORMULATION",i,"UNIT","FILE 50.607 IEN")=+Y "RTN","TMGNDF1A",724,0) "RTN","TMGNDF1A",725,0) ;"Note the NDC (national drug code) is comprised as follows: "RTN","TMGNDF1A",726,0) ;"It is a 10 digit number comprised of three segments "RTN","TMGNDF1A",727,0) ;" 1st 4-5 digits - producer/packager <--> field#1 (LABEL CODE) in TMG FDA LISTING "RTN","TMGNDF1A",728,0) ;" next 3-4 digits -- the product code <--> field#2 (PRODUCT CODE) in TMG FDA LISTING "RTN","TMGNDF1A",729,0) ;" next 1-2 digits -- package code, specifying the package size <--> field#1 (CODE) in TMG FDA PACKAGES "RTN","TMGNDF1A",730,0) ;" the grouping will be: 4-4-2, or 5-3-2, or 5-4-1 "RTN","TMGNDF1A",731,0) "RTN","TMGNDF1A",732,0) set Array("NDC")=$get(Array("LABEL CODE"),"????")_"-" "RTN","TMGNDF1A",733,0) set Array("NDC")=Array("NDC")_$get(Array("PRODUCT CODE"),"????")_"-" "RTN","TMGNDF1A",734,0) set Array("NDC")=Array("NDC")_$get(Array("PACKAGE",1,"CODE"),"??") "RTN","TMGNDF1A",735,0) "RTN","TMGNDF1A",736,0) set Array("NDC")=$$NewNDC^TMGNDF2E(Array("NDC")) ;"added 5/28/06 //kt "RTN","TMGNDF1A",737,0) "RTN","TMGNDF1A",738,0) set Array("NDC","12DIGIT")=$translate(Array("NDC"),"-","") "RTN","TMGNDF1A",739,0) do ;"ensure length=12 "RTN","TMGNDF1A",740,0) . new num set num=Array("NDC","12DIGIT") "RTN","TMGNDF1A",741,0) . new l set l=$length(num) "RTN","TMGNDF1A",742,0) . if l>12 set num=$extract(num,l-11,99) "RTN","TMGNDF1A",743,0) . if l<12 set num=$extract("00000000000",1,12-l)_num ;"pad with leading 0's "RTN","TMGNDF1A",744,0) . set Array("NDC","12DIGIT")=num "RTN","TMGNDF1A",745,0) "RTN","TMGNDF1A",746,0) if $get(noLink)=1 goto GDIDone ;"Skip linkages if requested. "RTN","TMGNDF1A",747,0) "RTN","TMGNDF1A",748,0) ;"Now try to link to pre-existing VistA entries "RTN","TMGNDF1A",749,0) ;"Note--2/12/07 -- I am changing the significance of this link to 50.68 "RTN","TMGNDF1A",750,0) ;" I found that many drugs had multiple links to entries in 50.68, i.e. "RTN","TMGNDF1A",751,0) ;" there was a one-to-many relationship. And while it is helpful to "RTN","TMGNDF1A",752,0) ;" have a connection to *similar* drugs (i.e. to obtain missing "RTN","TMGNDF1A",753,0) ;" drug class, ingredients etc.), there is also value from having "RTN","TMGNDF1A",754,0) ;" a link to an EXACT match in 50.68 -- i.e. a one-to-one relationship. "RTN","TMGNDF1A",755,0) ;" I have therefore renamed the field in TMG FDA IMPORT COMPILED where "RTN","TMGNDF1A",756,0) ;" this information is stored to: VA PRODUCT SIMILAR MATCHES, and for "RTN","TMGNDF1A",757,0) ;" less certain matches, renamed it to: VA PRODUCT POSSIBLE MATCHES. "RTN","TMGNDF1A",758,0) ;" I have introduced a new field: 'NDC --> VA PRODUCT LINK' that "RTN","TMGNDF1A",759,0) ;" will hold a pointer to a record with the exact same NDC (national "RTN","TMGNDF1A",760,0) ;" drug code). This link will be established in a later stage. "RTN","TMGNDF1A",761,0) do "RTN","TMGNDF1A",762,0) . new DIC,X,Y "RTN","TMGNDF1A",763,0) . set DIC=50.67 "RTN","TMGNDF1A",764,0) . set DIC(0)="M" "RTN","TMGNDF1A",765,0) . ;"set X=""""_Array("NDC","12DIGIT")_"""" "RTN","TMGNDF1A",766,0) . set X=Array("NDC","12DIGIT") "RTN","TMGNDF1A",767,0) . do ^DIC "RTN","TMGNDF1A",768,0) . if Y=-1 quit "RTN","TMGNDF1A",769,0) . new tempIEN set tempIEN=$$GET1^DIQ(50.67,+Y_",",5,"I") "RTN","TMGNDF1A",770,0) . new tempResults "RTN","TMGNDF1A",771,0) . ;"do CheckNDCLink(tempIEN,.Array,.tempResults) "RTN","TMGNDF1A",772,0) . ;"if +$get(tempResults("COUNT"))'>0 do quit "RTN","TMGNDF1A",773,0) . ;". set Array("NDC","NOTE")="NDC Conflict found with drug IEN (in 50.68)="_tempIEN "RTN","TMGNDF1A",774,0) . set Array("FILE 50.68 IEN",1)=tempIEN "RTN","TMGNDF1A",775,0) . set Array("FILE 50.68 IEN","COUNT")=1 "RTN","TMGNDF1A",776,0) "RTN","TMGNDF1A",777,0) if +$get(Array("FILE 50.68 IEN","COUNT"))=0 do "RTN","TMGNDF1A",778,0) . new RArray "RTN","TMGNDF1A",779,0) . new temp "RTN","TMGNDF1A",780,0) . if $get(pIndex)'="" do "RTN","TMGNDF1A",781,0) . . set temp=$$Link2VAProd(.Array,.RArray,pIndex) "RTN","TMGNDF1A",782,0) . else do "RTN","TMGNDF1A",783,0) . . set temp=$$LinkToVAProd(.Array,.RArray) "RTN","TMGNDF1A",784,0) . merge Array("FILE 50.68 IEN")=RArray "RTN","TMGNDF1A",785,0) "RTN","TMGNDF1A",786,0) GDIDone "RTN","TMGNDF1A",787,0) quit result "RTN","TMGNDF1A",788,0) "RTN","TMGNDF1A",789,0) "RTN","TMGNDF1A",790,0) GetSingleRec(File,GRef,IEN,Array) "RTN","TMGNDF1A",791,0) ;"Purpose: To get the data from single record, that points to IEN, and put in Array "RTN","TMGNDF1A",792,0) ;"Input: File -- the file NUMBER "RTN","TMGNDF1A",793,0) ;" GRef -- the OPEN FORMAT global reference of B xref (e.g. '^TMG(22706.1,"B",' ) "RTN","TMGNDF1A",794,0) ;" IEN -- The IEN that is pointed to "RTN","TMGNDF1A",795,0) ;" Array -- an out parameter. PASS BY REFERENCE "RTN","TMGNDF1A",796,0) "RTN","TMGNDF1A",797,0) set GRef=GRef_IEN_","""")" "RTN","TMGNDF1A",798,0) set i=$order(@GRef) "RTN","TMGNDF1A",799,0) if +i>0 do "RTN","TMGNDF1A",800,0) . new IENS,TMGARRAY,TMGMSG "RTN","TMGNDF1A",801,0) . set IENS=i_"," "RTN","TMGNDF1A",802,0) . do GETS^DIQ(File,IENS,"*","R","TMGARRAY","TMGMSG") "RTN","TMGNDF1A",803,0) . if $data(TMGMSG) do quit "RTN","TMGNDF1A",804,0) . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMSG") "RTN","TMGNDF1A",805,0) . . if $data(TMGMSG("DIERR"))'=0 do quit "RTN","TMGNDF1A",806,0) . . . ;"do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",807,0) . merge Array=TMGARRAY(File,IENS) "RTN","TMGNDF1A",808,0) "RTN","TMGNDF1A",809,0) quit "RTN","TMGNDF1A",810,0) "RTN","TMGNDF1A",811,0) GetMultRec(File,GRef,IEN,Array,Label) "RTN","TMGNDF1A",812,0) ;"Purpose: To get the data from mult records, that point to IEN, and put in Array "RTN","TMGNDF1A",813,0) ;"Input: File -- the file NUMBER "RTN","TMGNDF1A",814,0) ;" GRef -- the OPEN FORMAT global reference of B xref (e.g. '^TMG(22706.1,"B",' ) "RTN","TMGNDF1A",815,0) ;" IEN -- The IEN that is pointed to "RTN","TMGNDF1A",816,0) ;" Array -- an out parameter. PASS BY REFERENCE "RTN","TMGNDF1A",817,0) "RTN","TMGNDF1A",818,0) new count set count=1 "RTN","TMGNDF1A",819,0) new Ref "RTN","TMGNDF1A",820,0) set Ref=GRef_IEN_","""")" "RTN","TMGNDF1A",821,0) set i=$order(@Ref) "RTN","TMGNDF1A",822,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF1A",823,0) . new IENS,TMGARRAY,TMGMSG "RTN","TMGNDF1A",824,0) . set IENS=i_"," "RTN","TMGNDF1A",825,0) . do GETS^DIQ(File,IENS,"*","R","TMGARRAY","TMGMSG") "RTN","TMGNDF1A",826,0) . if $data(TMGMSG) do quit "RTN","TMGNDF1A",827,0) . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMSG") "RTN","TMGNDF1A",828,0) . . if $data(TMGMSG("DIERR"))'=0 do quit "RTN","TMGNDF1A",829,0) . . . ;"do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF1A",830,0) . kill TMGARRAY(File,IENS,"LISTING") "RTN","TMGNDF1A",831,0) . if Label="ROUTE" kill TMGARRAY(File,IENS,"CODE") "RTN","TMGNDF1A",832,0) . if Label="DOSE" kill TMGARRAY(File,IENS,"DOSE FORM") "RTN","TMGNDF1A",833,0) . merge Array(Label,count)=TMGARRAY(File,IENS) "RTN","TMGNDF1A",834,0) . set Ref=GRef_IEN_",i)" "RTN","TMGNDF1A",835,0) . set i=$order(@Ref) "RTN","TMGNDF1A",836,0) . set count=count+1 "RTN","TMGNDF1A",837,0) "RTN","TMGNDF1A",838,0) quit "RTN","TMGNDF1A",839,0) "RTN","TMGNDF1A",840,0) "RTN","TMGNDF1A",841,0) LinkToVAProd(Array,Results) "RTN","TMGNDF1A",842,0) ;"Purpose: To take a given drug array, and match to an entry in file VA PRODUCT (50.68) "RTN","TMGNDF1A",843,0) ;"Input: Array -- PASS BY REFERENCE. An array holding drug info, as created by GetDrugInfo(IEN,Array) "RTN","TMGNDF1A",844,0) ;" Results -- OPTIONAL, PASS BY REFERENCE, an OUT parameter to receive results array "RTN","TMGNDF1A",845,0) ;" if more than one IEN. e.g. "RTN","TMGNDF1A",846,0) ;" Results("COUNT")=3 "RTN","TMGNDF1A",847,0) ;" Results(1)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",848,0) ;" Results(2)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",849,0) ;" Results(3)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",850,0) ;" Because a full match is sometimes not found (i.e. because minor variance), I "RTN","TMGNDF1A",851,0) ;" will return all close (but not necessarily perfect) matches as: "RTN","TMGNDF1A",852,0) ;" Results("POSS MATCH","COUNT")=IEN "RTN","TMGNDF1A",853,0) ;" Results("POSS MATCH",1)=ien "RTN","TMGNDF1A",854,0) ;"Result: Returns IEN in file 50.68, or 0 if not found, or -2 if multiple results found "RTN","TMGNDF1A",855,0) ;" (in which case all matches will be reported in Results array "RTN","TMGNDF1A",856,0) ;"Note: this function will have to scan through tens of thousands of entries in the main "RTN","TMGNDF1A",857,0) ;" drug files, so response may be slow. "RTN","TMGNDF1A",858,0) "RTN","TMGNDF1A",859,0) new result set result=0 "RTN","TMGNDF1A",860,0) kill Results "RTN","TMGNDF1A",861,0) new lmCount set lmCount=0 "RTN","TMGNDF1A",862,0) ;"Cycle through all records in file 50.68 (VA PRODUCT FILE) (global: ^PSNDF(50.68, ) "RTN","TMGNDF1A",863,0) new IEN "RTN","TMGNDF1A",864,0) set IEN=$order(^PSNDF(50.68,0)) "RTN","TMGNDF1A",865,0) if +IEN>0 for do quit:(IEN'>0) "RTN","TMGNDF1A",866,0) . if ($get(tmgTEST)=1) write IEN,! "RTN","TMGNDF1A",867,0) . do CheckLink(IEN,.Array,.Results) "RTN","TMGNDF1A",868,0) . set IEN=$order(^PSNDF(50.68,IEN)) "RTN","TMGNDF1A",869,0) "RTN","TMGNDF1A",870,0) if $get(Results("COUNT"))=1 do "RTN","TMGNDF1A",871,0) . set result=$order(Results("")) "RTN","TMGNDF1A",872,0) else if +$get(Results("COUNT"))=0 do "RTN","TMGNDF1A",873,0) . set result=0 "RTN","TMGNDF1A",874,0) else if $get(Results("COUNT"))>1 do "RTN","TMGNDF1A",875,0) . set result=-2 "RTN","TMGNDF1A",876,0) "RTN","TMGNDF1A",877,0) quit result "RTN","TMGNDF1A",878,0) "RTN","TMGNDF1A",879,0) "RTN","TMGNDF1A",880,0) Link2VAProd(Array,Results,pIndex) "RTN","TMGNDF1A",881,0) ;"Purpose: To take a given drug array, and match to an entry in file VA PRODUCT (50.68) "RTN","TMGNDF1A",882,0) ;" -- using a faster index method "RTN","TMGNDF1A",883,0) ;"Input: Array -- PASS BY REFERENCE. An array holding drug info, as created by GetDrugInfo(IEN,Array) "RTN","TMGNDF1A",884,0) ;" Results -- OPTIONAL, PASS BY REFERENCE, an OUT parameter to receive results array "RTN","TMGNDF1A",885,0) ;" if more than one IEN. e.g. "RTN","TMGNDF1A",886,0) ;" Results("COUNT")=3 "RTN","TMGNDF1A",887,0) ;" Results(1)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",888,0) ;" Results(2)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",889,0) ;" Results(3)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",890,0) ;" Because a full match is sometimes not found (i.e. because minor variance), I "RTN","TMGNDF1A",891,0) ;" will return all close (but not necessarily perfect) matches as: "RTN","TMGNDF1A",892,0) ;" Results("POSS MATCH","COUNT")=IEN "RTN","TMGNDF1A",893,0) ;" Results("POSS MATCH",1)=ien "RTN","TMGNDF1A",894,0) ;" pIndex -- NAME OF index array to use, as created by IndexVAProd() "RTN","TMGNDF1A",895,0) ;" @pIndex@(IngredientIEN, 50.68 IEN, 50.6814 IEN)="" "RTN","TMGNDF1A",896,0) ;" @pIndex@(IngredientIEN, 50.68 IEN, 50.6814 IEN)="" "RTN","TMGNDF1A",897,0) ;"Result: Returns IEN in file 50.68, or 0 if not found, or -2 if multiple results found "RTN","TMGNDF1A",898,0) ;" (in which case all matches will be reported in Results array "RTN","TMGNDF1A",899,0) ;"Note: this function will have to scan through tens of thousands of entries in the main "RTN","TMGNDF1A",900,0) ;" drug files, so response may be slow. "RTN","TMGNDF1A",901,0) "RTN","TMGNDF1A",902,0) new result set result=0 "RTN","TMGNDF1A",903,0) kill Results "RTN","TMGNDF1A",904,0) new lmCount set lmCount=0 "RTN","TMGNDF1A",905,0) "RTN","TMGNDF1A",906,0) new PossMatch ;"an array to list all IENs in 50.68 containing ONE specified ingredient "RTN","TMGNDF1A",907,0) new IngredList ;"an array to hold IENS of all ingredients for drug info held in Array "RTN","TMGNDF1A",908,0) new NumIngredients "RTN","TMGNDF1A",909,0) new i "RTN","TMGNDF1A",910,0) for i=1:1:$get(Array("FORMULATION","COUNT")) do "RTN","TMGNDF1A",911,0) . new IngredIEN "RTN","TMGNDF1A",912,0) . set IngredIEN=$get(Array("FORMULATION",i,"INGREDIENT NAME","FILE 50.416 IEN")) "RTN","TMGNDF1A",913,0) . set IngredList(IngredIEN)="" "RTN","TMGNDF1A",914,0) . do GetIndexList(IngredIEN,pIndex,$name(PossMatch(IngredIEN))) "RTN","TMGNDF1A",915,0) ;"Example of Output from code above: "RTN","TMGNDF1A",916,0) ;" PossMatch(50,3456)="" "RTN","TMGNDF1A",917,0) ;" PossMatch(50,57698)="" "RTN","TMGNDF1A",918,0) ;" PossMatch(50,993)="" "RTN","TMGNDF1A",919,0) ;" PossMatch(99,3456)="" <-- 3456 has ingredient 99 and 50 "RTN","TMGNDF1A",920,0) ;" PossMatch(99,3876)="" "RTN","TMGNDF1A",921,0) ;" PossMatch(99,9902)="" "RTN","TMGNDF1A",922,0) set NumIngredients=$$ListCt^TMGMISC("PossMatch") "RTN","TMGNDF1A",923,0) "RTN","TMGNDF1A",924,0) ;"Now, add node to array above, with indexes switched. "RTN","TMGNDF1A",925,0) ;" PossMatch("x",3456,50)="" "RTN","TMGNDF1A",926,0) ;" PossMatch("x",3456,99)="" <-- 3456 has ingredient 99 and 50 "RTN","TMGNDF1A",927,0) ;" PossMatch("x",57698,50)="" "RTN","TMGNDF1A",928,0) ;" PossMatch("x",993,50)="" "RTN","TMGNDF1A",929,0) ;" PossMatch("x",3876,99)="" "RTN","TMGNDF1A",930,0) ;" PossMatch("x",9902,99)="" "RTN","TMGNDF1A",931,0) new VAPIEN "RTN","TMGNDF1A",932,0) set IngredIEN=$order(PossMatch("")) "RTN","TMGNDF1A",933,0) if +IngredIEN>0 for do quit:(+IngredIEN'>0) "RTN","TMGNDF1A",934,0) . set VAPIEN=$order(PossMatch(IngredIEN,"")) "RTN","TMGNDF1A",935,0) . if +VAPIEN>0 for do quit:(+VAPIEN'>0) "RTN","TMGNDF1A",936,0) . . set PossMatch("x",VAPIEN,IngredIEN)="" "RTN","TMGNDF1A",937,0) . . set VAPIEN=$order(PossMatch(IngredIEN,VAPIEN)) "RTN","TMGNDF1A",938,0) . set IngredIEN=$order(PossMatch(IngredIEN)) "RTN","TMGNDF1A",939,0) "RTN","TMGNDF1A",940,0) ;"now find those entries containing ALL given ingredients "RTN","TMGNDF1A",941,0) ;" PossMatch("+",3456)="" <--- only 3456 is a possible match "RTN","TMGNDF1A",942,0) set VAPIEN=$order(PossMatch("x","")) "RTN","TMGNDF1A",943,0) if +VAPIEN>0 for do quit:(+VAPIEN'>0) "RTN","TMGNDF1A",944,0) . if $$ListCt^TMGMISC($name(PossMatch("x",VAPIEN)))'0 for do quit:(IEN'>0) "RTN","TMGNDF1A",952,0) . do CheckLink(IEN,.Array,.Results) "RTN","TMGNDF1A",953,0) . set IEN=$order(PossMatch("+",IEN)) "RTN","TMGNDF1A",954,0) "RTN","TMGNDF1A",955,0) if $get(Results("COUNT"))=1 do "RTN","TMGNDF1A",956,0) . set result=$order(Results("")) "RTN","TMGNDF1A",957,0) else if +$get(Results("COUNT"))=0 do "RTN","TMGNDF1A",958,0) . set result=0 "RTN","TMGNDF1A",959,0) else if $get(Results("COUNT"))>1 do "RTN","TMGNDF1A",960,0) . set result=-2 "RTN","TMGNDF1A",961,0) "RTN","TMGNDF1A",962,0) L2VPDone "RTN","TMGNDF1A",963,0) quit result "RTN","TMGNDF1A",964,0) "RTN","TMGNDF1A",965,0) "RTN","TMGNDF1A",966,0) CheckLink(IEN,Array,Results) "RTN","TMGNDF1A",967,0) ;"Purpose: To take a given drug array, and check for match to an entry in file VA PRODUCT (50.68) "RTN","TMGNDF1A",968,0) ;"Input: IEN -- An IEN in file 50.68 to try for a match, seeing if matches info in Array "RTN","TMGNDF1A",969,0) ;" Array -- PASS BY REFERENCE. An array holding drug info, as created by GetDrugInfo(IEN,Array) "RTN","TMGNDF1A",970,0) ;" partial reference below (See GetDrugInfo for full reference) "RTN","TMGNDF1A",971,0) ;" Array('FORMULATION','COUNT')=1 "RTN","TMGNDF1A",972,0) ;" Array('FORMULATION',1,'STRENGTH') "RTN","TMGNDF1A",973,0) ;" Array('FORMULATION',1,'UNIT') "RTN","TMGNDF1A",974,0) ;" Array('FORMULATION',1,'UNIT','FILE 50.607 IEN') ;note may contain -1 if match not found "RTN","TMGNDF1A",975,0) ;" Array('FORMULATION',1,'INGREDIENT NAME') "RTN","TMGNDF1A",976,0) ;" Array('FORMULATION',1,'INGREDIENT NAME','FILE 50.416 IEN) ;note may contain -1 if match not found "RTN","TMGNDF1A",977,0) ;" Results -- OPTIONAL, PASS BY REFERENCE, an OUT parameter to receive results array "RTN","TMGNDF1A",978,0) ;" if more than one IEN. e.g. "RTN","TMGNDF1A",979,0) ;" Results("COUNT")=3 "RTN","TMGNDF1A",980,0) ;" Results(1)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",981,0) ;" Results(2)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",982,0) ;" Results(3)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",983,0) ;" Because a full match is sometimes not found (i.e. because minor variance), I "RTN","TMGNDF1A",984,0) ;" will return all close (but not necessarily perfect) matches as: "RTN","TMGNDF1A",985,0) ;" Results("POSS MATCH","COUNT")=IEN "RTN","TMGNDF1A",986,0) ;" Results("POSS MATCH",1)=ien "RTN","TMGNDF1A",987,0) ;"Result: None (but returns results in Results array) "RTN","TMGNDF1A",988,0) "RTN","TMGNDF1A",989,0) ;"Note: this function will have to scan through tens of thousands of entries in the main "RTN","TMGNDF1A",990,0) ;" drug files, so response may be slow. "RTN","TMGNDF1A",991,0) "RTN","TMGNDF1A",992,0) new result set result=0 "RTN","TMGNDF1A",993,0) new lmCount set lmCount=0 "RTN","TMGNDF1A",994,0) "RTN","TMGNDF1A",995,0) new ingredient,igdIEN "RTN","TMGNDF1A",996,0) new match set match=1 ;"default to true "RTN","TMGNDF1A",997,0) new numIngredients "RTN","TMGNDF1A",998,0) set numIngredients=$get(Array("FORMULATION","COUNT")) "RTN","TMGNDF1A",999,0) if numIngredients=0 set match=0 "RTN","TMGNDF1A",1000,0) else for ingredient=1:1 do quit:(+igdIEN'>0)!(match=0) "RTN","TMGNDF1A",1001,0) . set igdIEN=$get(Array("FORMULATION",ingredient,"INGREDIENT NAME","FILE 50.416 IEN")) "RTN","TMGNDF1A",1002,0) . if +igdIEN'>0 do quit "RTN","TMGNDF1A",1003,0) . . if igdIEN="" quit ;"just at end of list of ingredients "RTN","TMGNDF1A",1004,0) . . if igdIEN=-1 set match=0 ;"here igdIEN must =-1 (prior ^DIC failed to find match) "RTN","TMGNDF1A",1005,0) . new node set node=$get(^PSNDF(50.68,IEN,2,igdIEN,0)) "RTN","TMGNDF1A",1006,0) . if node="" do quit "RTN","TMGNDF1A",1007,0) . . set match=0 quit ;"no match found "RTN","TMGNDF1A",1008,0) . ;"If we get here, we have a match. Now check for matching strength and units "RTN","TMGNDF1A",1009,0) . set lmCount=lmCount+1 "RTN","TMGNDF1A",1010,0) . set Results("POSS MATCH",lmCount)=IEN "RTN","TMGNDF1A",1011,0) . set Results("POSS MATCH","COUNT")=lmCount "RTN","TMGNDF1A",1012,0) . set Results("POSS MATCH","INDEX",IEN)=lmCount "RTN","TMGNDF1A",1013,0) . new strength set strength=$piece(node,"^",2) "RTN","TMGNDF1A",1014,0) . new str2 set str2=$get(Array("FORMULATION",ingredient,"STRENGTH")) "RTN","TMGNDF1A",1015,0) . if +strength'=+str2 do quit "RTN","TMGNDF1A",1016,0) . . set Results("POSS MATCH",lmCount,"PROBLEM")="dosage STRENGTH mis-match" "RTN","TMGNDF1A",1017,0) . . set Results("POSS MATCH",lmCount,"MSG")="Import="_str2_", VistA="_strength "RTN","TMGNDF1A",1018,0) . . set match=0 "RTN","TMGNDF1A",1019,0) . new units set units=$piece(node,"^",3) "RTN","TMGNDF1A",1020,0) . new units2 set units2=$get(Array("FORMULATION",ingredient,"UNIT","FILE 50.607 IEN")) "RTN","TMGNDF1A",1021,0) . if units'=units2 do "RTN","TMGNDF1A",1022,0) . . set Results("POSS MATCH",lmCount,"PROBLEM")="dosage UNITS mis-match" "RTN","TMGNDF1A",1023,0) . . new s "RTN","TMGNDF1A",1024,0) . . set s="Import="_$$GET1^DIQ(50.607,units2_",",".01") "RTN","TMGNDF1A",1025,0) . . set s=s_", VistA="_$$GET1^DIQ(50.607,units_",",".01") "RTN","TMGNDF1A",1026,0) . . set Results("POSS MATCH",lmCount,"MSG")=s "RTN","TMGNDF1A",1027,0) . . set match=0 "RTN","TMGNDF1A",1028,0) . ;"Now see if VistA drug has more ingredients than import drug. "RTN","TMGNDF1A",1029,0) . new IgdCount set IgdCount=0 "RTN","TMGNDF1A",1030,0) . new TempIdx set TempIdx=$order(^PSNDF(50.68,IEN,2,0)) "RTN","TMGNDF1A",1031,0) . if TempIdx'="" for do quit:(+TempIdx'>0) "RTN","TMGNDF1A",1032,0) . . set IgdCount=IgdCount+1 "RTN","TMGNDF1A",1033,0) . . set TempIdx=$order(^PSNDF(50.68,IEN,2,TempIdx)) "RTN","TMGNDF1A",1034,0) . if IgdCount'=numIngredients do quit "RTN","TMGNDF1A",1035,0) . . set Results("POSS MATCH",lmCount,"PROBLEM")="Number of ingredients mismatch" "RTN","TMGNDF1A",1036,0) . . set Results("POSS MATCH",lmCount,"MSG")="Import="_numIngredients_", VistA="_IgdCount "RTN","TMGNDF1A",1037,0) . . set match=0 "RTN","TMGNDF1A",1038,0) if match=1 do "RTN","TMGNDF1A",1039,0) . new count set count=$get(Results("COUNT"))+1 "RTN","TMGNDF1A",1040,0) . set Results(count)=IEN "RTN","TMGNDF1A",1041,0) . set Results("COUNT")=count "RTN","TMGNDF1A",1042,0) "RTN","TMGNDF1A",1043,0) ;"Now, remove entries in POSS MATCH that are actual full matches. "RTN","TMGNDF1A",1044,0) new SomeKilled set SomeKilled=0 "RTN","TMGNDF1A",1045,0) new index "RTN","TMGNDF1A",1046,0) for index=1:1:+$get(Results("COUNT")) do "RTN","TMGNDF1A",1047,0) . new matchIEN set matchIEN=$get(Results(index)) "RTN","TMGNDF1A",1048,0) . new possEntry set possEntry=$get(Results("POSS MATCH","INDEX",matchIEN)) "RTN","TMGNDF1A",1049,0) . kill Results("POSS MATCH",possEntry) "RTN","TMGNDF1A",1050,0) . kill Results("POSS MATCH","INDEX",matchIEN) "RTN","TMGNDF1A",1051,0) . set SomeKilled=1 "RTN","TMGNDF1A",1052,0) . set Results("POSS MATCH","COUNT")=$get(Results("POSS MATCH","COUNT"))-1 "RTN","TMGNDF1A",1053,0) "RTN","TMGNDF1A",1054,0) ;"Now renumber remaining POSS MATCHES "RTN","TMGNDF1A",1055,0) if SomeKilled do "RTN","TMGNDF1A",1056,0) . do ListPack^TMGMISC($name(Results("POSS MATCH"))) "RTN","TMGNDF1A",1057,0) . set Results("POSS MATCH","COUNT")=$$ListCt^TMGMISC($name(Results("POSS MATCH"))) "RTN","TMGNDF1A",1058,0) "RTN","TMGNDF1A",1059,0) ;"set index=$order(Results("POSS MATCH","")) "RTN","TMGNDF1A",1060,0) ;"new newCount set newCount=0 "RTN","TMGNDF1A",1061,0) ;"if +index>0 for do quit:(index'>0) "RTN","TMGNDF1A",1062,0) ;". set newCount=newCount+1 "RTN","TMGNDF1A",1063,0) ;". merge Results("POSS MATCH 2",newCount)=Results("POSS MATCH",index) "RTN","TMGNDF1A",1064,0) ;". set Results("POSS MATCH 2","COUNT")=$get(Results("POSS MATCH 2","COUNT"))+1 "RTN","TMGNDF1A",1065,0) ;". set index=$order(Results("POSS MATCH",index)) "RTN","TMGNDF1A",1066,0) ;"if $data(Results("POSS MATCH 2"))>0 do "RTN","TMGNDF1A",1067,0) ;". kill Results("POSS MATCH") "RTN","TMGNDF1A",1068,0) ;". merge Results("POSS MATCH")=Results("POSS MATCH 2") "RTN","TMGNDF1A",1069,0) ;". kill Results("POSS MATCH 2") "RTN","TMGNDF1A",1070,0) "RTN","TMGNDF1A",1071,0) quit "RTN","TMGNDF1A",1072,0) "RTN","TMGNDF1A",1073,0) "RTN","TMGNDF1A",1074,0) CheckNDCLink(IEN,Array,Results) "RTN","TMGNDF1A",1075,0) ;"This is like CheckLink, except is it a little bit more lenient about the allowed "RTN","TMGNDF1A",1076,0) ;" variances. For example if UNITS of measure are different (e.g. MG vs. MG/VIAL). "RTN","TMGNDF1A",1077,0) ;"Input: IEN -- An IEN in file 50.68 to try for a match, seeing if matches info in Array "RTN","TMGNDF1A",1078,0) ;" Array -- PASS BY REFERENCE. An array holding drug info, as created by GetDrugInfo(IEN,Array) "RTN","TMGNDF1A",1079,0) ;" Results -- OPTIONAL, PASS BY REFERENCE, an OUT parameter to receive results array "RTN","TMGNDF1A",1080,0) ;" if more than one IEN. e.g. "RTN","TMGNDF1A",1081,0) ;" Results("COUNT")=3 "RTN","TMGNDF1A",1082,0) ;" Results(1)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",1083,0) ;" Results(2)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",1084,0) ;" Results(3)=IEN ;IEN is from file 50.68 "RTN","TMGNDF1A",1085,0) ;" Because a full match is sometimes not found (i.e. because minor variance), I "RTN","TMGNDF1A",1086,0) ;" will return all close (but not necessarily perfect) matches as: "RTN","TMGNDF1A",1087,0) ;" Results("POSS MATCH","COUNT")=IEN "RTN","TMGNDF1A",1088,0) ;" Results("POSS MATCH",1)=ien "RTN","TMGNDF1A",1089,0) ;"Result: None (but returns results in Results array) "RTN","TMGNDF1A",1090,0) "RTN","TMGNDF1A",1091,0) ;"Note: this function will have to scan through tens of thousands of entries in the main "RTN","TMGNDF1A",1092,0) ;" drug files, so response may be slow. "RTN","TMGNDF1A",1093,0) "RTN","TMGNDF1A",1094,0) new match "RTN","TMGNDF1A",1095,0) "RTN","TMGNDF1A",1096,0) do CheckLink(IEN,.Array,.Results) "RTN","TMGNDF1A",1097,0) if +$get(Results("COUNT"))<1 do "RTN","TMGNDF1A",1098,0) . new i,max,done "RTN","TMGNDF1A",1099,0) . set done=0 "RTN","TMGNDF1A",1100,0) . set max=$get(Results("POSS MATCH","COUNT")) "RTN","TMGNDF1A",1101,0) . for i=1:1:max do quit:(done=1) "RTN","TMGNDF1A",1102,0) . . if Results("POSS MATCH",i,"PROBLEM")="dosage UNITS mis-match" do "RTN","TMGNDF1A",1103,0) . . . set Results(1)=Results("POSS MATCH",i) "RTN","TMGNDF1A",1104,0) . . . kill Results("POSS MATCH",i) "RTN","TMGNDF1A",1105,0) . . . do ListPack^TMGMISC($name(Results("POSS MATCH"))) "RTN","TMGNDF1A",1106,0) . . . set Results("COUNT")=$$ListCt^TMGMISC("Results") "RTN","TMGNDF1A",1107,0) . . . set done=1 "RTN","TMGNDF1A",1108,0) "RTN","TMGNDF1A",1109,0) quit "RTN","TMGNDF1A",1110,0) "RTN","TMGNDF1A",1111,0) "RTN","TMGNDF1A",1112,0) GetpVAPIndex() "RTN","TMGNDF1A",1113,0) ;"Purpose: to return a pointer to an index of the VAProduct file "RTN","TMGNDF1A",1114,0) ;"Input: none "RTN","TMGNDF1A",1115,0) ;"Output: returns the NAME of index of VAProduct, or ^ for abort "RTN","TMGNDF1A",1116,0) "RTN","TMGNDF1A",1117,0) new pIndex set pIndex=$name(^TMG("TMP","indexVAProduct")) "RTN","TMGNDF1A",1118,0) new abort set abort=0 "RTN","TMGNDF1A",1119,0) if $data(@pIndex) do "RTN","TMGNDF1A",1120,0) . new % set %=2 "RTN","TMGNDF1A",1121,0) . write "Recreate temporary VA PRODUCT file index *IF* there have",! "RTN","TMGNDF1A",1122,0) . write "been any changes made to this file since last index.",! "RTN","TMGNDF1A",1123,0) . write "Re-index" do YN^DICN write ! "RTN","TMGNDF1A",1124,0) . if %=1 kill @pIndex "RTN","TMGNDF1A",1125,0) . if %=-1 set abort=1 "RTN","TMGNDF1A",1126,0) if abort=1 set pIndex="^" goto GVAPIDone "RTN","TMGNDF1A",1127,0) "RTN","TMGNDF1A",1128,0) if $data(@pIndex)=0 do IndexVAProd(pIndex) "RTN","TMGNDF1A",1129,0) "RTN","TMGNDF1A",1130,0) GVAPIDone "RTN","TMGNDF1A",1131,0) quit pIndex "RTN","TMGNDF1A",1132,0) "RTN","TMGNDF1A",1133,0) IndexVAProd(pArray) "RTN","TMGNDF1A",1134,0) ;"Purpose: to make a temporary index of the VA PRODUCT file based on the ACTIVE INGREDIENTS field "RTN","TMGNDF1A",1135,0) ;"Input: pArray: the NAME OF the array to store index in "RTN","TMGNDF1A",1136,0) ;"Output: Index will be stored in array like this: "RTN","TMGNDF1A",1137,0) ;" @pArray@(IngredientIEN, 50.68 IEN, 50.6814 IEN)="" "RTN","TMGNDF1A",1138,0) ;"Result: none: "RTN","TMGNDF1A",1139,0) ;"Note: prior values in pArray will NOT be killed. "RTN","TMGNDF1A",1140,0) ;" Also, the VA PRODUCT file is setup such that the 50.6814 IEN will also watch IngredientIEN "RTN","TMGNDF1A",1141,0) "RTN","TMGNDF1A",1142,0) new IEN,subIEN,node,Ingredient "RTN","TMGNDF1A",1143,0) "RTN","TMGNDF1A",1144,0) ;"set IEN=$order(^PSNDF(50.68,0)) "RTN","TMGNDF1A",1145,0) ;"if (+IEN>0) for do quit:(+IEN'>0) "RTN","TMGNDF1A",1146,0) "RTN","TMGNDF1A",1147,0) write "Creating a temporary index of VA PRODUCT FILE",! "RTN","TMGNDF1A",1148,0) new Itr,IEN "RTN","TMGNDF1A",1149,0) set IEN=$$ItrInit^TMGITR(50.68,.Itr) "RTN","TMGNDF1A",1150,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1A",1151,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF1A",1152,0) . set subIEN=$order(^PSNDF(50.68,IEN,2,0)) "RTN","TMGNDF1A",1153,0) . if (+subIEN>0) for do quit:(+subIEN'>0) "RTN","TMGNDF1A",1154,0) . . set node=$get(^PSNDF(50.68,IEN,2,subIEN,0)) "RTN","TMGNDF1A",1155,0) . . set Ingredient=$piece(node,"^",1) "RTN","TMGNDF1A",1156,0) . . if +Ingredient>0 do "RTN","TMGNDF1A",1157,0) . . . set @pArray@(Ingredient,IEN,subIEN)="" "RTN","TMGNDF1A",1158,0) . . . ;"set @pArray@("IEN",IEN,subIEN)=Ingredient "RTN","TMGNDF1A",1159,0) . . set subIEN=$order(^PSNDF(50.68,IEN,2,subIEN)) "RTN","TMGNDF1A",1160,0) . ;"set IEN=$order(^PSNDF(50.68,IEN)) "RTN","TMGNDF1A",1161,0) "RTN","TMGNDF1A",1162,0) write ! "RTN","TMGNDF1A",1163,0) quit "RTN","TMGNDF1A",1164,0) "RTN","TMGNDF1A",1165,0) "RTN","TMGNDF1A",1166,0) GetIndexList(Ingredient,pIndex,pArray) "RTN","TMGNDF1A",1167,0) ;"Purpose: for a given Ingredient, return a list of all records containing this ingredient "RTN","TMGNDF1A",1168,0) ;"Input: Ingredient -- the IEN (from file 50.416) to scan for "RTN","TMGNDF1A",1169,0) ;" pIndex -- NAME OF index array, as created by IndexVaProd() "RTN","TMGNDF1A",1170,0) ;" pArray -- NAME OF array to put data into "RTN","TMGNDF1A",1171,0) ;"Output: results will be put in like this: "RTN","TMGNDF1A",1172,0) ;" @pArray@(IEN from 50.68)="" "RTN","TMGNDF1A",1173,0) ;"results: none "RTN","TMGNDF1A",1174,0) ;"Note: any prior data in pArray WILL BE KILLED "RTN","TMGNDF1A",1175,0) "RTN","TMGNDF1A",1176,0) kill @pArray "RTN","TMGNDF1A",1177,0) "RTN","TMGNDF1A",1178,0) new IEN "RTN","TMGNDF1A",1179,0) set IEN=$order(@pIndex@(Ingredient,"")) "RTN","TMGNDF1A",1180,0) if +IEN>0 for do quit:(+IEN'>0) "RTN","TMGNDF1A",1181,0) . set @pArray@(IEN)="" "RTN","TMGNDF1A",1182,0) . set IEN=$order(@pIndex@(Ingredient,IEN)) "RTN","TMGNDF1A",1183,0) "RTN","TMGNDF1A",1184,0) quit "RTN","TMGNDF1A",1185,0) "RTN","TMGNDF1A",1186,0) "RTN","TMGNDF1A",1187,0) FixGenerics "RTN","TMGNDF1A",1188,0) ;"Purpose: After running the Compile function, I found that many records did not have "RTN","TMGNDF1A",1189,0) ;" an entry for the GENERIC NAME field. This seems to happen when a drug has no "RTN","TMGNDF1A",1190,0) ;" Ingredients listed. But often there are other drugs with the same name that DO "RTN","TMGNDF1A",1191,0) ;" have ingredients. If so, then the errent record is essentially a duplicate (except "RTN","TMGNDF1A",1192,0) ;" for different NDC etc), and isn't needed. Therefore the SKIP THIS RECORD field "RTN","TMGNDF1A",1193,0) ;" can be set to 1 (SKIP). But, if there isn't a duplicate record, then the tradename "RTN","TMGNDF1A",1194,0) ;" will be used as the GENERIC name "RTN","TMGNDF1A",1195,0) "RTN","TMGNDF1A",1196,0) new IEN,count "RTN","TMGNDF1A",1197,0) new TMGGeneric,TradeName "RTN","TMGNDF1A",1198,0) "RTN","TMGNDF1A",1199,0) set IEN=$order(^TMG(22706.9,0)) "RTN","TMGNDF1A",1200,0) if IEN'="" for do quit:(+IEN'>0) "RTN","TMGNDF1A",1201,0) . set TMGGeneric=$piece($get(^TMG(22706.9,IEN,0)),"^",6) ;"get field#.07, GENERIC NAME "RTN","TMGNDF1A",1202,0) . if (TMGGeneric="") do "RTN","TMGNDF1A",1203,0) . . set TradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"get field#.05, TRADENAME "RTN","TMGNDF1A",1204,0) . . new list "RTN","TMGNDF1A",1205,0) . . do ScanFor(TradeName,.list) "RTN","TMGNDF1A",1206,0) . . set count=$$ListCt^TMGMISC("list") "RTN","TMGNDF1A",1207,0) . . if count=1 do "RTN","TMGNDF1A",1208,0) . . . write "Unique drug, with no ingredients: ",TradeName,! "RTN","TMGNDF1A",1209,0) . . . do FindSimNames(TradeName,.list) "RTN","TMGNDF1A",1210,0) . . . if $data(list) zwr list "RTN","TMGNDF1A",1211,0) . . else do "RTN","TMGNDF1A",1212,0) . . . write "Drug, with no ingredients: ",TradeName," --> ",count," other similar drugs.",! "RTN","TMGNDF1A",1213,0) . set IEN=$order(^TMG(22706.9,IEN)) "RTN","TMGNDF1A",1214,0) "RTN","TMGNDF1A",1215,0) quit "RTN","TMGNDF1A",1216,0) "RTN","TMGNDF1A",1217,0) "RTN","TMGNDF1A",1218,0) "RTN","TMGNDF1A",1219,0) "RTN","TMGNDF1A",1220,0) ScanFor(Name,Array) "RTN","TMGNDF1A",1221,0) ;"Purpose: To scan file 22706.9 (TMG FDA IMPORT COMPILED) for records with field TRADENAME "RTN","TMGNDF1A",1222,0) ;" contains to 'TradeName' "RTN","TMGNDF1A",1223,0) ;"Input: Name -- the value to search for "RTN","TMGNDF1A",1224,0) ;" Array -- PASS BY REFERENCE. An OUT parameter for result: "RTN","TMGNDF1A",1225,0) ;" Array(Name,IEN)="" "RTN","TMGNDF1A",1226,0) ;" Array(Name,IEN)="" "RTN","TMGNDF1A",1227,0) ;" Array(Name,IEN)="" "RTN","TMGNDF1A",1228,0) ;"Results: none "RTN","TMGNDF1A",1229,0) "RTN","TMGNDF1A",1230,0) new IEN "RTN","TMGNDF1A",1231,0) new TradeName "RTN","TMGNDF1A",1232,0) "RTN","TMGNDF1A",1233,0) set IEN=$order(^TMG(22706.9,0)) "RTN","TMGNDF1A",1234,0) if IEN'="" for do quit:(+IEN'>0) "RTN","TMGNDF1A",1235,0) . set TradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"get field#.05, TRADENAME "RTN","TMGNDF1A",1236,0) . if TradeName[Name do "RTN","TMGNDF1A",1237,0) . . set Array(Name,IEN)=TradeName "RTN","TMGNDF1A",1238,0) . set IEN=$order(^TMG(22706.9,IEN)) "RTN","TMGNDF1A",1239,0) "RTN","TMGNDF1A",1240,0) quit "RTN","TMGNDF1A",1241,0) "RTN","TMGNDF1A",1242,0) "RTN","TMGNDF1A",1243,0) FindSimNames(Name,Array) "RTN","TMGNDF1A",1244,0) ;"Purpose: to scan TMG FDA IMPORT COMPILED file and return an array of similar entries. "RTN","TMGNDF1A",1245,0) ;"Input: Name: the name of the Name drug name to scan for "RTN","TMGNDF1A",1246,0) ;" Array: PASS BY REFERENCE, and OUT PARAMETER -- prior entries are killed "RTN","TMGNDF1A",1247,0) ;"Result: none (output is in Array) "RTN","TMGNDF1A",1248,0) "RTN","TMGNDF1A",1249,0) new i,i2,s "RTN","TMGNDF1A",1250,0) new NumWords,TradeName "RTN","TMGNDF1A",1251,0) set NumWords=$length(Name," ") "RTN","TMGNDF1A",1252,0) kill Array "RTN","TMGNDF1A",1253,0) "RTN","TMGNDF1A",1254,0) set i2=$order(^TMG(22706.9,0)) "RTN","TMGNDF1A",1255,0) if i2'="" for do quit:(i2="") "RTN","TMGNDF1A",1256,0) . set TradeName=$piece($get(^TMG(22706.9,i2,0)),"^",4) ;"get field#.05, TRADENAME "RTN","TMGNDF1A",1257,0) . new IEN set IEN=i2 "RTN","TMGNDF1A",1258,0) . set i2=$order(^TMG(22706.9,i2)) "RTN","TMGNDF1A",1259,0) . if NumWords'=$length(TradeName," ") quit "RTN","TMGNDF1A",1260,0) . new temp set temp=TradeName "RTN","TMGNDF1A",1261,0) . for i=1:1:NumWords do quit:(s="")!(temp="") "RTN","TMGNDF1A",1262,0) . . set s=$piece(Name," ",i) "RTN","TMGNDF1A",1263,0) . . set s=$piece(s," ",1) ;"get first word of multi-word drug name "RTN","TMGNDF1A",1264,0) . . if s="" quit "RTN","TMGNDF1A",1265,0) . . if $extract(TradeName,1,$length(s))'=s set temp="" "RTN","TMGNDF1A",1266,0) . if temp'="" do "RTN","TMGNDF1A",1267,0) . . set Array(TradeName)=IEN_"^"_TradeName "RTN","TMGNDF1A",1268,0) "RTN","TMGNDF1A",1269,0) new count "RTN","TMGNDF1A",1270,0) set count=$$ListCt^TMGMISC("Array") "RTN","TMGNDF1A",1271,0) if count>1 do "RTN","TMGNDF1A",1272,0) . do NarrowGenMatches^TMGNDF2C(Name,.Array," ") "RTN","TMGNDF1A",1273,0) . if (($$ListCt^TMGMISC("Array")/count)>0.5)&(count>5) do ;"i.e. no improvement "RTN","TMGNDF1A",1274,0) . . kill Array "RTN","TMGNDF1A",1275,0) "RTN","TMGNDF1A",1276,0) quit "RTN","TMGNDF1A",1277,0) "RTN","TMGNDF1A",1278,0) "RTN","TMGNDF1A",1279,0) FixLink "RTN","TMGNDF1A",1280,0) ;"Purpose: ask user for entry in 22706.9 to fix, then try to fix link "RTN","TMGNDF1A",1281,0) "RTN","TMGNDF1A",1282,0) new IEN "RTN","TMGNDF1A",1283,0) new DIC,X,Y "RTN","TMGNDF1A",1284,0) set DIC=22706.9,DIC(0)="MAEQ" "RTN","TMGNDF1A",1285,0) do ^DIC write ! "RTN","TMGNDF1A",1286,0) if +Y>0 do Fix1Link(+Y) "RTN","TMGNDF1A",1287,0) quit "RTN","TMGNDF1A",1288,0) "RTN","TMGNDF1A",1289,0) "RTN","TMGNDF1A",1290,0) Fix1Link(IEN) "RTN","TMGNDF1A",1291,0) ;"Purpose: To attemp to fix an entry that doesn't have a link to a VA PRODUCT entry "RTN","TMGNDF1A",1292,0) ;"Input: IEN -- an IEN from 22706.9 "RTN","TMGNDF1A",1293,0) "RTN","TMGNDF1A",1294,0) new array,results,vapIEN "RTN","TMGNDF1A",1295,0) new listIEN set listIEN=+$piece($get(^TMG(22706.9,IEN,0)),"^",1) "RTN","TMGNDF1A",1296,0) if listIEN'>0 goto F1LDone "RTN","TMGNDF1A",1297,0) "RTN","TMGNDF1A",1298,0) if $$GetDrugInfo(listIEN,.array)=0 goto F1LDone "RTN","TMGNDF1A",1299,0) set vapIEN=$$LinkToVAProd(.array,.results) "RTN","TMGNDF1A",1300,0) write vapIEN,! "RTN","TMGNDF1A",1301,0) if $data(results) zwr results(*) "RTN","TMGNDF1A",1302,0) "RTN","TMGNDF1A",1303,0) ;"finish.... "RTN","TMGNDF1A",1304,0) ;" "RTN","TMGNDF1A",1305,0) F1LDone "RTN","TMGNDF1A",1306,0) quit "RTN","TMGNDF1A",1307,0) "RTN","TMGNDF1A",1308,0) ;"======================================================================= "RTN","TMGNDF1A",1309,0) "RTN","TMGNDF1A",1310,0) Show1Source(IEN) "RTN","TMGNDF1A",1311,0) ;"Purpose: to show the source fields for the record "RTN","TMGNDF1A",1312,0) ;"Input: IEN -- records number from 22706.9 "RTN","TMGNDF1A",1313,0) ;"Output: source data for record is dumped to screen. "RTN","TMGNDF1A",1314,0) "RTN","TMGNDF1A",1315,0) new fdaIEN "RTN","TMGNDF1A",1316,0) set fdaIEN=$piece($get(^TMG(22706.9,IEN,0)),"^",1) "RTN","TMGNDF1A",1317,0) "RTN","TMGNDF1A",1318,0) do Show1Drug^TMGNDF0B(fdaIEN) "RTN","TMGNDF1A",1319,0) quit "RTN","TMGNDF1D") 0^39^B4671 "RTN","TMGNDF1D",1,0) TMGNDF1D ;TMG/kst/FDA Import: Import name cleanup ;03/25/06 "RTN","TMGNDF1D",2,0) ;;1.0;TMG-LIB;**1**;01/23/07 "RTN","TMGNDF1D",3,0) "RTN","TMGNDF1D",4,0) ;"FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF1D",5,0) ;"Code for cleaning up names. "RTN","TMGNDF1D",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF1D",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF1D",8,0) ;"1-23-07 "RTN","TMGNDF1D",9,0) "RTN","TMGNDF1D",10,0) ;"======================================================================= "RTN","TMGNDF1D",11,0) ;" API -- Public Functions. "RTN","TMGNDF1D",12,0) ;"======================================================================= "RTN","TMGNDF1D",13,0) ;"Menu "RTN","TMGNDF1D",14,0) ;"Fix1Name(IEN) -- perform this units fixes for just 1 record "RTN","TMGNDF1D",15,0) "RTN","TMGNDF1D",16,0) ;"======================================================================= "RTN","TMGNDF1D",17,0) ;" Private Functions. "RTN","TMGNDF1D",18,0) ;"======================================================================= "RTN","TMGNDF1D",19,0) ;"PickSkips -- select records to mark as to be skipped. "RTN","TMGNDF1D",20,0) ;"RemoveDups -- Set duplicate records to be skipped "RTN","TMGNDF1D",21,0) ;"======================================================================= "RTN","TMGNDF1D",22,0) "RTN","TMGNDF1D",23,0) Menu "RTN","TMGNDF1D",24,0) ;"Purpose: To give an interactive menu of tools to clean up data. "RTN","TMGNDF1D",25,0) "RTN","TMGNDF1D",26,0) new Menu,UsrSlct "RTN","TMGNDF1D",27,0) new i set i=0 "RTN","TMGNDF1D",28,0) set Menu(i)="Pick Option for Cleaning Up FDA Imported Data (1D)",i=i+1 "RTN","TMGNDF1D",29,0) set Menu(i)="Fix common misspellings etc. in Trade Names"_$char(9)_"NormalizeNames",i=i+1 "RTN","TMGNDF1D",30,0) set Menu(i)="SEARCH and REPLACE words in drug TRADE NAME"_$char(9)_"SEARCHd05",i=i+1 "RTN","TMGNDF1D",31,0) set Menu(i)="SEARCH and REPLACE words in drug STRENGTH"_$char(9)_"SEARCH1",i=i+1 "RTN","TMGNDF1D",32,0) set Menu(i)="SEARCH and REPLACE words in drug UNITS"_$char(9)_"SEARCH2",i=i+1 "RTN","TMGNDF1D",33,0) set Menu(i)="Fix dose decimals (e.g. '.5;.125' --> '0.5;0.125')"_$char(9)_"DECIMAL",i=i+1 "RTN","TMGNDF1D",34,0) set Menu(i)="Fix units decimals (e.g. 'MG/.5 ML;' --> 'MG/0.5ML')"_$char(9)_"UNITS",i=i+1 "RTN","TMGNDF1D",35,0) set Menu(i)="Remove unwanted DOSES from TRADE NAME"_$char(9)_"ScrubDoses",i=i+1 "RTN","TMGNDF1D",36,0) set Menu(i)="Edit import TRADE NAME (Caution)"_$char(9)_"EditTradeName",i=i+1 "RTN","TMGNDF1D",37,0) set Menu(i)="HELP"_$char(9)_"?" "RTN","TMGNDF1D",38,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF1D",39,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF1D",40,0) "RTN","TMGNDF1D",41,0) CD1 "RTN","TMGNDF1D",42,0) write # "RTN","TMGNDF1D",43,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF1D",44,0) if UsrSlct="^" goto CDDone "RTN","TMGNDF1D",45,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF1D",46,0) "RTN","TMGNDF1D",47,0) if UsrSlct="Prev" goto Menu^TMGNDF1A ;"quit can occur from there... "RTN","TMGNDF1D",48,0) if UsrSlct="Next" goto Menu^TMGNDF1E ;"quit can occur from there... "RTN","TMGNDF1D",49,0) "RTN","TMGNDF1D",50,0) if UsrSlct="NormalizeNames" do NormalizeNames goto CD1 "RTN","TMGNDF1D",51,0) if UsrSlct="SEARCHd05" do Srch5Replace goto CD1 "RTN","TMGNDF1D",52,0) if UsrSlct="SEARCH1" do Srch1Replace goto CD1 "RTN","TMGNDF1D",53,0) if UsrSlct="SEARCH2" do Srch2Replace goto CD1 "RTN","TMGNDF1D",54,0) if UsrSlct="DECIMAL" do FixDecimals goto CD1 "RTN","TMGNDF1D",55,0) if UsrSlct="UNITS" do FixUnits goto CD1 "RTN","TMGNDF1D",56,0) if UsrSlct="ScrubDoses" do ScrubDoses goto CD1 "RTN","TMGNDF1D",57,0) if UsrSlct="EditTradeName" do EditTradename() goto CD1 "RTN","TMGNDF1D",58,0) if UsrSlct="?" do ShowHelp goto CD1 "RTN","TMGNDF1D",59,0) goto CDDone "RTN","TMGNDF1D",60,0) CDDone "RTN","TMGNDF1D",61,0) quit "RTN","TMGNDF1D",62,0) "RTN","TMGNDF1D",63,0) ShowHelp "RTN","TMGNDF1D",64,0) ;"Purpose: to display help instructions "RTN","TMGNDF1D",65,0) "RTN","TMGNDF1D",66,0) write #,! "RTN","TMGNDF1D",67,0) write "Q: Why does the data need clean up?",! "RTN","TMGNDF1D",68,0) write "A: The FDA database seems to consist of data provided",! "RTN","TMGNDF1D",69,0) write " by vendors. As such, there is a big variety in the",! "RTN","TMGNDF1D",70,0) write " formats of drug names and in the dose specifications,",! "RTN","TMGNDF1D",71,0) write " and also accuracy (many drugs are missing information.)",! "RTN","TMGNDF1D",72,0) write ! "RTN","TMGNDF1D",73,0) write "Q: Are inaccurate or unwanted drug records deleted?",! "RTN","TMGNDF1D",74,0) write "A: No. They are kept so that with the NEXT import, their",! "RTN","TMGNDF1D",75,0) write " unwanted status will be remembered. Instead, they are",! "RTN","TMGNDF1D",76,0) write " flagged with a SKIP THIS RECORD marker. They will be",! "RTN","TMGNDF1D",77,0) write " ignored during further processing.",! "RTN","TMGNDF1D",78,0) write ! "RTN","TMGNDF1D",79,0) write "Q: How do I flag an unwanted record to be SKIPPED?",! "RTN","TMGNDF1D",80,0) write "A: Drug records are browsed in a 'selector' (more below)",! "RTN","TMGNDF1D",81,0) write " and all the drugs to be skipped are selected. Then the",! "RTN","TMGNDF1D",82,0) write " selector is exited by typing [ESC][ESC], and one is ",! "RTN","TMGNDF1D",83,0) write " given a chance to mark all to be SKIPPED at once.",! "RTN","TMGNDF1D",84,0) write ! "RTN","TMGNDF1D",85,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",86,0) write ! "RTN","TMGNDF1D",87,0) write "Q: How do I use the selector?",! "RTN","TMGNDF1D",88,0) write "A: The selector is a tool from the VPE library. It has its",! "RTN","TMGNDF1D",89,0) write " own help. A quick answer is to move the cursor up and down",! "RTN","TMGNDF1D",90,0) write " and press SPACE to select or deselect a record. I recommend",! "RTN","TMGNDF1D",91,0) write " using the '+' feature to select all records matching a",! "RTN","TMGNDF1D",92,0) write " specified pattern.",! "RTN","TMGNDF1D",93,0) write ! "RTN","TMGNDF1D",94,0) write "... more later...",! "RTN","TMGNDF1D",95,0) "RTN","TMGNDF1D",96,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",97,0) quit "RTN","TMGNDF1D",98,0) "RTN","TMGNDF1D",99,0) "RTN","TMGNDF1D",100,0) Fix1Name(IEN) "RTN","TMGNDF1D",101,0) ;"Purpose: perform this units fixes for just 1 record "RTN","TMGNDF1D",102,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF1D",103,0) ;"results: none "RTN","TMGNDF1D",104,0) "RTN","TMGNDF1D",105,0) new temp "RTN","TMGNDF1D",106,0) "RTN","TMGNDF1D",107,0) set temp=$$Fix1Dec(IEN) "RTN","TMGNDF1D",108,0) set temp=$$Fix1Unit(IEN) "RTN","TMGNDF1D",109,0) set temp=$$Norm1Name(IEN) "RTN","TMGNDF1D",110,0) set temp=$$Scrub1Dose(IEN) "RTN","TMGNDF1D",111,0) "RTN","TMGNDF1D",112,0) quit "RTN","TMGNDF1D",113,0) "RTN","TMGNDF1D",114,0) "RTN","TMGNDF1D",115,0) FixDecimals "RTN","TMGNDF1D",116,0) ;"Purpose: To convert bare decimals (e.g. '.5' --> '0.5') in STRENGTH "RTN","TMGNDF1D",117,0) "RTN","TMGNDF1D",118,0) new Itr,IEN,strength,abort,count,newStr "RTN","TMGNDF1D",119,0) set abort=0,count=0 "RTN","TMGNDF1D",120,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1D",121,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1D",122,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF1D",123,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF1D",124,0) . if $$KeyPressed^TMGUSRIF=27 set abort=1 quit "RTN","TMGNDF1D",125,0) . if $$Fix1Dec(IEN)=0 set count=count+1 "RTN","TMGNDF1D",126,0) "RTN","TMGNDF1D",127,0) write !,count," records changed",! "RTN","TMGNDF1D",128,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",129,0) "RTN","TMGNDF1D",130,0) quit "RTN","TMGNDF1D",131,0) "RTN","TMGNDF1D",132,0) Fix1Dec(IEN) "RTN","TMGNDF1D",133,0) ;"Purpose: To convert bare decimals (e.g. '.5' --> '0.5') in STRENGTH "RTN","TMGNDF1D",134,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF1D",135,0) ;"Results: 1 if modified, 0 if not "RTN","TMGNDF1D",136,0) "RTN","TMGNDF1D",137,0) new result set result=0 "RTN","TMGNDF1D",138,0) set strength=$piece($get(^TMG(22706.9,IEN,0)),"^",2) "RTN","TMGNDF1D",139,0) if strength'["." quit "RTN","TMGNDF1D",140,0) set newStr=$$FixNum(strength) "RTN","TMGNDF1D",141,0) if newStr'=strength do "RTN","TMGNDF1D",142,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1D",143,0) . set TMGFDA(22706.9,IEN_",",1)=newStr "RTN","TMGNDF1D",144,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1D",145,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG,.result) "RTN","TMGNDF1D",146,0) "RTN","TMGNDF1D",147,0) quit result "RTN","TMGNDF1D",148,0) "RTN","TMGNDF1D",149,0) "RTN","TMGNDF1D",150,0) FixUnits "RTN","TMGNDF1D",151,0) ;"Purpose: To fix errors in Units (remove spaces, fix hanging decimals) "RTN","TMGNDF1D",152,0) "RTN","TMGNDF1D",153,0) new Itr,IEN,strength,abort,count,newStr "RTN","TMGNDF1D",154,0) set abort=0,count=0 "RTN","TMGNDF1D",155,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1D",156,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1D",157,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF1D",158,0) . if $$KeyPressed^TMGUSRIF=27 set abort=1 quit "RTN","TMGNDF1D",159,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF1D",160,0) . set count=count+$$Fix1Unit(IEN) "RTN","TMGNDF1D",161,0) write !,count," records changed",! "RTN","TMGNDF1D",162,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",163,0) "RTN","TMGNDF1D",164,0) quit "RTN","TMGNDF1D",165,0) "RTN","TMGNDF1D",166,0) "RTN","TMGNDF1D",167,0) Fix1Unit(IEN) "RTN","TMGNDF1D",168,0) ;"Purpose: To fix errors in Units (remove spaces, fix hanging decimals) "RTN","TMGNDF1D",169,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF1D",170,0) ;"Results: 1 if changed, 0 if not "RTN","TMGNDF1D",171,0) "RTN","TMGNDF1D",172,0) new result set result=0 "RTN","TMGNDF1D",173,0) set units=$piece($get(^TMG(22706.9,IEN,0)),"^",3) "RTN","TMGNDF1D",174,0) set newStr=$$FixNum(units) "RTN","TMGNDF1D",175,0) set newStr=$$Substitute^TMGSTUTL(newStr,"/PER","/") "RTN","TMGNDF1D",176,0) set newStr=$$Substitute^TMGSTUTL(newStr,"/VIL","/VIAL") "RTN","TMGNDF1D",177,0) set newStr=$translate(newStr," ","") "RTN","TMGNDF1D",178,0) if $extract(newStr,$length(newStr))=";" set newStr=$extract(newStr,1,$length(newStr)-1) "RTN","TMGNDF1D",179,0) if newStr'=units do "RTN","TMGNDF1D",180,0) . ;"write IEN,": ",units,"-->",newStr,! quit "RTN","TMGNDF1D",181,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1D",182,0) . set TMGFDA(22706.9,IEN_",",2)=newStr "RTN","TMGNDF1D",183,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1D",184,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1D",185,0) . set result=1 "RTN","TMGNDF1D",186,0) "RTN","TMGNDF1D",187,0) quit result "RTN","TMGNDF1D",188,0) "RTN","TMGNDF1D",189,0) "RTN","TMGNDF1D",190,0) FixNum(numStr) "RTN","TMGNDF1D",191,0) ;"Purpose: to fix hanging decimals in numStr (e.g. '.5' --> '0.5') "RTN","TMGNDF1D",192,0) ;"Input: numStr -- the string to be fixed "RTN","TMGNDF1D",193,0) ;"Results: returns fixed string "RTN","TMGNDF1D",194,0) new result set result=numStr "RTN","TMGNDF1D",195,0) new i for i=1:1:$length(result,".")-1 do "RTN","TMGNDF1D",196,0) . new p set p=$$Pos^TMGSTUTL(".",result,i) "RTN","TMGNDF1D",197,0) . new priorCh set priorCh=$extract(result,p-1) "RTN","TMGNDF1D",198,0) . if +priorCh=priorCh quit "RTN","TMGNDF1D",199,0) . if (p=1) do "RTN","TMGNDF1D",200,0) . . set result="0"_result "RTN","TMGNDF1D",201,0) . else do "RTN","TMGNDF1D",202,0) . . new sA,sB "RTN","TMGNDF1D",203,0) . . set sA=$extract(result,1,p-1),sB=$extract(result,p,9999) "RTN","TMGNDF1D",204,0) . . set result=sA_"0"_sB "RTN","TMGNDF1D",205,0) "RTN","TMGNDF1D",206,0) quit result "RTN","TMGNDF1D",207,0) "RTN","TMGNDF1D",208,0) Srch5Replace "RTN","TMGNDF1D",209,0) ;"Purpose: To provide a mechanism for altering the drug trade names (.05 field) "RTN","TMGNDF1D",210,0) ;" e.g. TETRACYCLINE HYDROCHLORIDE --> TETRACYCLINE HCL "RTN","TMGNDF1D",211,0) ;" or LISINOPRIL/HYDROCHLOROTHIAZIDE --> LISINOPRIL/HCTZ "RTN","TMGNDF1D",212,0) ;" The reason for this is that many drugs are put in BOTH WAYS, leading to "RTN","TMGNDF1D",213,0) ;" duplicate entries, differing only in the expansion of these words. "RTN","TMGNDF1D",214,0) "RTN","TMGNDF1D",215,0) do SrchReplace^TMGMISC(22706.9,.05,"SEARCH & REPLACE in Trade Name of FDA Imported Drugs") "RTN","TMGNDF1D",216,0) quit "RTN","TMGNDF1D",217,0) "RTN","TMGNDF1D",218,0) Srch2Replace "RTN","TMGNDF1D",219,0) ;"Purpose: To provide a mechanism for altering the drug UNITS (field 2) "RTN","TMGNDF1D",220,0) ;" The reason for this is that many drugs are put in BOTH WAYS, leading to "RTN","TMGNDF1D",221,0) ;" duplicate entries, differing only in the expansion of these words. "RTN","TMGNDF1D",222,0) "RTN","TMGNDF1D",223,0) do SrchReplace^TMGMISC(22706.9,2,"SEARCH & REPLACE in UNITS of FDA Imported Drugs") "RTN","TMGNDF1D",224,0) quit "RTN","TMGNDF1D",225,0) "RTN","TMGNDF1D",226,0) Srch1Replace "RTN","TMGNDF1D",227,0) ;"Purpose: To provide a mechanism for altering the drug STRENGTH (field 1) "RTN","TMGNDF1D",228,0) ;" The reason for this is that many drugs are put in BOTH WAYS, leading to "RTN","TMGNDF1D",229,0) ;" duplicate entries, differing only in the expansion of these words. "RTN","TMGNDF1D",230,0) "RTN","TMGNDF1D",231,0) do SrchReplace^TMGMISC(22706.9,1,"SEARCH & REPLACE in STRENGTH of FDA Imported Drugs") "RTN","TMGNDF1D",232,0) quit "RTN","TMGNDF1D",233,0) "RTN","TMGNDF1D",234,0) "RTN","TMGNDF1D",235,0) NormalizeNames "RTN","TMGNDF1D",236,0) ;"Purpose: To 'normalize' names, meaning replacing common misspellings etc. "RTN","TMGNDF1D",237,0) "RTN","TMGNDF1D",238,0) new map ;"These are numbered to preserve their order "RTN","TMGNDF1D",239,0) do SetupMap(.map) "RTN","TMGNDF1D",240,0) "RTN","TMGNDF1D",241,0) new Itr,IEN,count "RTN","TMGNDF1D",242,0) set count=0 "RTN","TMGNDF1D",243,0) new abort set abort=0 "RTN","TMGNDF1D",244,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1D",245,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1D",246,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF1D",247,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF1D",248,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF1D",249,0) . set count=count+$$Norm1Name(IEN,.map) "RTN","TMGNDF1D",250,0) "RTN","TMGNDF1D",251,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF1D",252,0) "RTN","TMGNDF1D",253,0) write count," Trade names (.05 field) modified.",! "RTN","TMGNDF1D",254,0) if count>1 write "Because some changes are interdependant, please run this option again.",! "RTN","TMGNDF1D",255,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",256,0) "RTN","TMGNDF1D",257,0) quit "RTN","TMGNDF1D",258,0) "RTN","TMGNDF1D",259,0) "RTN","TMGNDF1D",260,0) Norm1Name(IEN,map) "RTN","TMGNDF1D",261,0) ;"Purpose: To 'normalize' names, meaning replacing common misspellings etc. for 1 record "RTN","TMGNDF1D",262,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF1D",263,0) ;" map -- OPTIONAL. Array of changes to be made. If not provided, then "RTN","TMGNDF1D",264,0) ;" it will be created here. "RTN","TMGNDF1D",265,0) ;"Results: 1 if modified, 0 if not "RTN","TMGNDF1D",266,0) "RTN","TMGNDF1D",267,0) if $data(map)=0 do SetupMap(.map) "RTN","TMGNDF1D",268,0) "RTN","TMGNDF1D",269,0) new result set result=0 "RTN","TMGNDF1D",270,0) new TradeName set TradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"field .05 "RTN","TMGNDF1D",271,0) new oldName set oldName=TradeName "RTN","TMGNDF1D",272,0) new num set num="" "RTN","TMGNDF1D",273,0) for set num=$order(map(num)) quit:(num="") do "RTN","TMGNDF1D",274,0) . set srchS=$order(map(num,"")) quit:(srchS="") "RTN","TMGNDF1D",275,0) . if TradeName'[srchS quit "RTN","TMGNDF1D",276,0) . write !,srchS,"-->",$get(map(num,srchS)),! "RTN","TMGNDF1D",277,0) . set TradeName=$$Substitute^TMGSTUTL(TradeName,srchS,$get(map(num,srchS))) "RTN","TMGNDF1D",278,0) "RTN","TMGNDF1D",279,0) if TradeName'=oldName do "RTN","TMGNDF1D",280,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1D",281,0) . set TMGFDA(22706.9,IEN_",",.05)=TradeName "RTN","TMGNDF1D",282,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1D",283,0) . set result=1 "RTN","TMGNDF1D",284,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1D",285,0) "RTN","TMGNDF1D",286,0) quit result "RTN","TMGNDF1D",287,0) "RTN","TMGNDF1D",288,0) "RTN","TMGNDF1D",289,0) SetupMap(map) "RTN","TMGNDF1D",290,0) ;"Purpose: to set up mapping of spelling corrections to be made. "RTN","TMGNDF1D",291,0) ;"Input: map -- PASS BY REFERENCE. An OUT parameter. "RTN","TMGNDF1D",292,0) "RTN","TMGNDF1D",293,0) ;"NOTE: These are numbered to preserve their order "RTN","TMGNDF1D",294,0) new i set i=0 "RTN","TMGNDF1D",295,0) set i=i+1,map(i,"SOLUTION")="SOLN" "RTN","TMGNDF1D",296,0) set i=i+1,map(i,"OINTMENT")="OINT" "RTN","TMGNDF1D",297,0) set i=i+1,map(i,"CAPSULES")="CAP" "RTN","TMGNDF1D",298,0) set i=i+1,map(i,"CAPSULE")="CAP" "RTN","TMGNDF1D",299,0) set i=i+1,map(i,"TALBETS")="TAB" "RTN","TMGNDF1D",300,0) set i=i+1,map(i,"INJECTION")="INJ" "RTN","TMGNDF1D",301,0) set i=i+1,map(i,"FOR INJ")="INJ" "RTN","TMGNDF1D",302,0) set i=i+1,map(i,"EXTENDED")="EXT" "RTN","TMGNDF1D",303,0) set i=i+1,map(i,"RELEASE")="REL" "RTN","TMGNDF1D",304,0) set i=i+1,map(i,"INH ")="IHNL " "RTN","TMGNDF1D",305,0) set i=i+1,map(i,"INHALATION")="INHL" "RTN","TMGNDF1D",306,0) set i=i+1,map(i,"SUSPENSION")="SUSP" "RTN","TMGNDF1D",307,0) set i=i+1,map(i,"OPHTHALMIC")="OPHTH" "RTN","TMGNDF1D",308,0) set i=i+1,map(i,"HYDROCHLORIDE")="HCL" "RTN","TMGNDF1D",309,0) set i=i+1,map(i,"FOR INJECTABLE SUSPENSION")="INJ" "RTN","TMGNDF1D",310,0) set i=i+1,map(i,"CODEINE PHOSPHATE")="CODEINE" "RTN","TMGNDF1D",311,0) set i=i+1,map(i,"WITH CODEINE")="CODEINE" "RTN","TMGNDF1D",312,0) set i=i+1,map(i,"SOLN FOR INJ")="INJ SOLN" "RTN","TMGNDF1D",313,0) set i=i+1,map(i,"POWDER FOR INJ")="INJ POWDER" "RTN","TMGNDF1D",314,0) set i=i+1,map(i,"SOLN OPHTH")="OPHTH SOLN" "RTN","TMGNDF1D",315,0) set i=i+1,map(i," SUFATE")=" SULFATE" "RTN","TMGNDF1D",316,0) set i=i+1,map(i,"ALBUTEROL SULFATE")="ALBUTEROL" "RTN","TMGNDF1D",317,0) set i=i+1,map(i,"FOR INHL")="INHL" "RTN","TMGNDF1D",318,0) set i=i+1,map(i,"SOLN INHL")="INHL SOLN" "RTN","TMGNDF1D",319,0) set i=i+1,map(i,"SUSTAINED")="SUST" "RTN","TMGNDF1D",320,0) set i=i+1,map(i," BITART ")=" BITARTRATE " "RTN","TMGNDF1D",321,0) set i=i+1,map(i," BITARTRATERATER")=" BITARTRATER" "RTN","TMGNDF1D",322,0) set i=i+1,map(i," BITARTRATER ")=" BITARTRATE " "RTN","TMGNDF1D",323,0) set i=i+1,map(i," BITRATE")=" BITARTRATE" "RTN","TMGNDF1D",324,0) set i=i+1,map(i,"BITARTARATE")="BITARTRATE" "RTN","TMGNDF1D",325,0) set i=i+1,map(i,"BITARTRATERATE")="BITARTRATE" "RTN","TMGNDF1D",326,0) set i=i+1,map(i,"HYDROCODONEARATE")="HYDROCODONE" "RTN","TMGNDF1D",327,0) set i=i+1,map(i,"HYDROCODONE ACET")="HYDROCODONE APAP" "RTN","TMGNDF1D",328,0) set i=i+1,map(i,"HYDROCODONE BITARTRATE")="HYDROCODONE" "RTN","TMGNDF1D",329,0) set i=i+1,map(i,"DIHYDROCODEINE BITARTRATE")="DIHYDROCODEINE" "RTN","TMGNDF1D",330,0) set i=i+1,map(i,"WITH HYDROCODONE")="HYDROCODONE" "RTN","TMGNDF1D",331,0) set i=i+1,map(i,"SOLN FOR IRRIGATION")="IRRIGATION SOLN" "RTN","TMGNDF1D",332,0) set i=i+1,map(i,"CAPLETS")="CAP" "RTN","TMGNDF1D",333,0) set i=i+1,map(i,"TABLET")="TAB" "RTN","TMGNDF1D",334,0) set i=i+1,map(i,"POWDER")="PWDR" "RTN","TMGNDF1D",335,0) set i=i+1,map(i,"TAB EXT REL")="EXT REL TAB" "RTN","TMGNDF1D",336,0) set i=i+1,map(i,"SOLN ORAL")="ORAL SOLN" "RTN","TMGNDF1D",337,0) set i=i+1,map(i,"TAB SUST REL")="SUST REL TAB" "RTN","TMGNDF1D",338,0) set i=i+1,map(i,"RELD ")="REL " "RTN","TMGNDF1D",339,0) set i=i+1,map(i," ")=" " "RTN","TMGNDF1D",340,0) set i=i+1,map(i," SULFATE")="" "RTN","TMGNDF1D",341,0) set i=i+1,map(i,"HYDROCHLOROTHIAZIDE")="HCTZ" "RTN","TMGNDF1D",342,0) set i=i+1,map(i," AND ")=" " "RTN","TMGNDF1D",343,0) set i=i+1,map(i,"HYDROCLORIDE")="HCL" "RTN","TMGNDF1D",344,0) set i=i+1,map(i,"HYDROCLOROTHIAZIDE")="HCTZ" "RTN","TMGNDF1D",345,0) set i=i+1,map(i,"HYDROCHLORITHIZIDE")="HCTZ" "RTN","TMGNDF1D",346,0) set i=i+1,map(i,"HYDROCHLOROHIAZIDE")="HCTZ" "RTN","TMGNDF1D",347,0) set i=i+1,map(i,"HYDROCLORTHIAZIDE")="HCTZ" "RTN","TMGNDF1D",348,0) set i=i+1,map(i,"HYDROCLORIDE")="HCTZ" "RTN","TMGNDF1D",349,0) set i=i+1,map(i,"HYDROCHLORIRDE")="HCTZ" "RTN","TMGNDF1D",350,0) set i=i+1,map(i," HCT ")=" HCTZ " "RTN","TMGNDF1D",351,0) set i=i+1,map(i,"HYDROCHLORIC ACID")="HCL" "RTN","TMGNDF1D",352,0) set i=i+1,map(i,"HYDROCHORIDE")="HCL" "RTN","TMGNDF1D",353,0) set i=i+1,map(i,"HYDROCHLORITHIAZIDE")="HCTZ" "RTN","TMGNDF1D",354,0) set i=i+1,map(i,"HYDROCHLOROTIAZIDE")="HCTZ" "RTN","TMGNDF1D",355,0) set i=i+1,map(i,"HYDROCHOROTHIAZIDE")="HCTZ" "RTN","TMGNDF1D",356,0) set i=i+1,map(i,"HYDROCHLOROTHIAZED")="HCTZ" "RTN","TMGNDF1D",357,0) set i=i+1,map(i,"HYDROCHLOROYTHIAZIDE")="HCTZ" "RTN","TMGNDF1D",358,0) set i=i+1,map(i,"HYDROCHLOROTHIZED")="HCYZ" "RTN","TMGNDF1D",359,0) set i=i+1,map(i,"HYDROCHLROTHIAZIDE")="" "RTN","TMGNDF1D",360,0) set i=i+1,map(i,"HYDROCHOLRIDE")="HCL" "RTN","TMGNDF1D",361,0) set i=i+1,map(i,"HYDROCHOLORIDE")="HCL" "RTN","TMGNDF1D",362,0) set i=i+1,map(i,"HYDROCHLORTHIAZIDE")="HCTZ" "RTN","TMGNDF1D",363,0) set i=i+1,map(i,"HYDROCHOLIRDE")="HCL" "RTN","TMGNDF1D",364,0) set i=i+1,map(i,"HYDROCHLROIDE")="HCL" "RTN","TMGNDF1D",365,0) set i=i+1,map(i,"HYDROCHLORIE")="HCL" "RTN","TMGNDF1D",366,0) set i=i+1,map(i,"HYDROCHLORINE")="HCL" "RTN","TMGNDF1D",367,0) set i=i+1,map(i,"CODIENE")="CODEINE" "RTN","TMGNDF1D",368,0) set i=i+1,map(i,"SOLN INJ")="INJ SOLN" "RTN","TMGNDF1D",369,0) set i=i+1,map(i,"SUBSTAINED")="SUST" "RTN","TMGNDF1D",370,0) set i=i+1,map(i,"SODIM")="SODIUM" "RTN","TMGNDF1D",371,0) set i=i+1,map(i,"CAP EXT REL")="EXT REL CAP" "RTN","TMGNDF1D",372,0) set i=i+1,map(i,"CAP SUST REL")="SUST REL CAP" "RTN","TMGNDF1D",373,0) set i=i+1,map(i,"INHAL ")="INHL " "RTN","TMGNDF1D",374,0) set i=i+1,map(i,"FOR ORAL SOLN")="ORAL SOLN" "RTN","TMGNDF1D",375,0) set i=i+1,map(i," I V ")=" IV " "RTN","TMGNDF1D",376,0) set i=i+1,map(i,"INTRAVENOUS")="IV" "RTN","TMGNDF1D",377,0) set i=i+1,map(i,"FOR ORAL SUSP")="ORAL SUSP" "RTN","TMGNDF1D",378,0) set i=i+1,map(i,"CAPLET")="CAP" "RTN","TMGNDF1D",379,0) set i=i+1,map(i,"WITH HCTZ")="HCTZ" "RTN","TMGNDF1D",380,0) set i=i+1,map(i," HCL ")=" " "RTN","TMGNDF1D",381,0) set i=i+1,map(i," HCL/")="" "RTN","TMGNDF1D",382,0) set i=i+1,map(i,"SUST REL")="SR" "RTN","TMGNDF1D",383,0) set i=i+1,map(i,"SR SR")="SR" "RTN","TMGNDF1D",384,0) set i=i+1,map(i,"SUPENSION")="SUSP" "RTN","TMGNDF1D",385,0) set i=i+1,map(i,"FOR SUSP")="SUSP" "RTN","TMGNDF1D",386,0) set i=i+1,map(i,"SUSP ORAL")="ORAL SUSP" "RTN","TMGNDF1D",387,0) set i=i+1,map(i," USP")="" "RTN","TMGNDF1D",388,0) set i=i+1,map(i,"PHOSPHATE")="PHOS" "RTN","TMGNDF1D",389,0) set i=i+1,map(i,"PHOSPHATES")="PHOS" "RTN","TMGNDF1D",390,0) set i=i+1,map(i,"METROPROLOL")="METOPROLOL" "RTN","TMGNDF1D",391,0) set i=i+1,map(i,"EXT-REL")="EXT REL" "RTN","TMGNDF1D",392,0) set i=i+1,map(i," HCLT")=" HCL" "RTN","TMGNDF1D",393,0) set i=i+1,map(i," HCLM")=" HCL" "RTN","TMGNDF1D",394,0) set i=i+1,map(i," HCL")="" "RTN","TMGNDF1D",395,0) set i=i+1,map(i,"INJECTABLE")="INJ" "RTN","TMGNDF1D",396,0) set i=i+1,map(i,"HYDROCHODONE")="HYDROCODONE" "RTN","TMGNDF1D",397,0) set i=i+1,map(i,"HYDROCHLOROTHAZIDE")="HCTZ" "RTN","TMGNDF1D",398,0) set i=i+1,map(i,"HYDROCHLOROIDE")="HCL" "RTN","TMGNDF1D",399,0) set i=i+1,map(i,"SODIUM CHLORIDE")="NACL" "RTN","TMGNDF1D",400,0) set i=i+1,map(i," NAD ")=" AND " "RTN","TMGNDF1D",401,0) set i=i+1,map(i," SODIUM")="" "RTN","TMGNDF1D",402,0) set i=i+1,map(i,"LEVOYHYROXINE")="LEVOTHYROXINE" "RTN","TMGNDF1D",403,0) set i=i+1,map(i," ACETAMINOPHEN")=" APAP" "RTN","TMGNDF1D",404,0) set i=i+1,map(i,"NAPSLATE")="NAPSYLATE" "RTN","TMGNDF1D",405,0) set i=i+1,map(i,"NAPSULATE")="NAPSYLATE" "RTN","TMGNDF1D",406,0) set i=i+1,map(i," NAPSYLATE")="" "RTN","TMGNDF1D",407,0) set i=i+1,map(i,"DARVOCET-N")="DARVOCET N" "RTN","TMGNDF1D",408,0) set i=i+1,map(i,"PROPOX NAP")="PROPOXYPHENE" "RTN","TMGNDF1D",409,0) set i=i+1,map(i,"PROPOX ")="PROPOXYPHENE " "RTN","TMGNDF1D",410,0) set i=i+1,map(i,"PROPOXY ")="PROPOXYPHENE " "RTN","TMGNDF1D",411,0) set i=i+1,map(i,"PROPOXYPHEN ")="PROPOXYPHENE " "RTN","TMGNDF1D",412,0) set i=i+1,map(i,"PROPACET ")="PROPOXYPHENE APAP " "RTN","TMGNDF1D",413,0) set i=i+1,map(i,"CLAULNATE ")="CLAVULANATE " "RTN","TMGNDF1D",414,0) set i=i+1,map(i,"ASPPIRIN ")="ASPIRIN " "RTN","TMGNDF1D",415,0) "RTN","TMGNDF1D",416,0) set i=i+1,map(i," &")="" "RTN","TMGNDF1D",417,0) set i=i+1,map(i," / ")=" " "RTN","TMGNDF1D",418,0) set i=i+1,map(i," CAFFINE")=" CAFFEINE" "RTN","TMGNDF1D",419,0) set i=i+1,map(i,"MGAPAP")="MG APAP" "RTN","TMGNDF1D",420,0) set i=i+1,map(i,"5MG")="5 MG" "RTN","TMGNDF1D",421,0) set i=i+1,map(i,"0MG")="0 MG" "RTN","TMGNDF1D",422,0) "RTN","TMGNDF1D",423,0) quit "RTN","TMGNDF1D",424,0) "RTN","TMGNDF1D",425,0) "RTN","TMGNDF1D",426,0) ScrubDoses "RTN","TMGNDF1D",427,0) ;"Purpose: To remove doses from Tradename "RTN","TMGNDF1D",428,0) ;" "RTN","TMGNDF1D",429,0) "RTN","TMGNDF1D",430,0) new skips,ignore,PreSelArray "RTN","TMGNDF1D",431,0) do SetScrubMaps(.skips,.ignore) "RTN","TMGNDF1D",432,0) "RTN","TMGNDF1D",433,0) new Itr,IEN,count "RTN","TMGNDF1D",434,0) set count=0 "RTN","TMGNDF1D",435,0) new abort set abort=0 "RTN","TMGNDF1D",436,0) write "Gathering a list of suggested name changes, removing #'s and doses...",! "RTN","TMGNDF1D",437,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1D",438,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1D",439,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF1D",440,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF1D",441,0) . set count=count+$$Scrub1Dose(IEN,.skips,.ignore,0,.PreSelArray) "RTN","TMGNDF1D",442,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF1D",443,0) "RTN","TMGNDF1D",444,0) if $data(PreSelArray)=0 goto SDDone "RTN","TMGNDF1D",445,0) new DelArray "RTN","TMGNDF1D",446,0) do SelRxList("PreSelArray","DelArray","SELECT ALLOWED NAME CHANGES (COLUMN 1=OLD,2=NEW) ESC ESC WHEN DONE",3) "RTN","TMGNDF1D",447,0) if $data(DelArray)=0 goto SDDone "RTN","TMGNDF1D",448,0) "RTN","TMGNDF1D",449,0) new NewName set NewName="" "RTN","TMGNDF1D",450,0) for set NewName=$order(DelArray(NewName)) quit:(NewName="") do "RTN","TMGNDF1D",451,0) . new IEN set IEN=0 "RTN","TMGNDF1D",452,0) . for set IEN=$order(DelArray(NewName,IEN)) quit:(+IEN'>0) do "RTN","TMGNDF1D",453,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF1D",454,0) . . set TMGFDA(22706.9,IEN_",",.05)=NewName "RTN","TMGNDF1D",455,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1D",456,0) . . set count=count+1 "RTN","TMGNDF1D",457,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1D",458,0) "RTN","TMGNDF1D",459,0) SDDone "RTN","TMGNDF1D",460,0) write count," Trade names (.05 field) modified.",! "RTN","TMGNDF1D",461,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",462,0) "RTN","TMGNDF1D",463,0) quit "RTN","TMGNDF1D",464,0) "RTN","TMGNDF1D",465,0) "RTN","TMGNDF1D",466,0) Scrub1Dose(IEN,skips,ignore,askuser,PreSelArray) "RTN","TMGNDF1D",467,0) ;"Purpose: To remove doses from Tradename from 1 record "RTN","TMGNDF1D",468,0) ;"Input: skips -- PASS BY REFERENCE. OPTIONAL "RTN","TMGNDF1D",469,0) ;" ignore -- PASS BY REFERENCE. OPTIONAL "RTN","TMGNDF1D",470,0) ;" askuser -- if 1, then user is asked. Default=1 "RTN","TMGNDF1D",471,0) ;" Otherwise, PreSelArray is filled with questions for user "RTN","TMGNDF1D",472,0) ;" PreSelArray -- PASS BY REFERENCE. OPTIONAL "RTN","TMGNDF1D",473,0) ;"Results: 1 if modified, 0 if not (including options put into PreSelArray) "RTN","TMGNDF1D",474,0) "RTN","TMGNDF1D",475,0) new result set result=0 "RTN","TMGNDF1D",476,0) if ($data(skips)=0)!($data(ignore)=0) do "RTN","TMGNDF1D",477,0) . kill skips,ignore "RTN","TMGNDF1D",478,0) . do SetScrubMaps(.skips,.ignore) "RTN","TMGNDF1D",479,0) set askuser=+$get(askuser,1) "RTN","TMGNDF1D",480,0) "RTN","TMGNDF1D",481,0) new TradeName set TradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"field .05 "RTN","TMGNDF1D",482,0) new j set j=0 "RTN","TMGNDF1D",483,0) new ignore1 set ignore1=0 "RTN","TMGNDF1D",484,0) for set j=$order(ignore(j)) quit:(j="") do "RTN","TMGNDF1D",485,0) . if TradeName[ignore(j) set ignore1=1 "RTN","TMGNDF1D",486,0) if ignore1 quit "RTN","TMGNDF1D",487,0) set j=0 "RTN","TMGNDF1D",488,0) for set j=$order(skips(j)) quit:(j="") do "RTN","TMGNDF1D",489,0) . new srchS set srchS=$get(skips(j)) "RTN","TMGNDF1D",490,0) . if TradeName'[srchS quit "RTN","TMGNDF1D",491,0) . set TradeName=$$Substitute^TMGSTUTL(TradeName,srchS,"@@@"_$char(64+j)_"@@@") "RTN","TMGNDF1D",492,0) new oldName set oldName=TradeName "RTN","TMGNDF1D",493,0) set TradeName=$$ScrubNumeric^TMGSTUTL(TradeName) "RTN","TMGNDF1D",494,0) if TradeName=oldName quit "RTN","TMGNDF1D",495,0) if TradeName="" quit "RTN","TMGNDF1D",496,0) if TradeName["@@@" do "RTN","TMGNDF1D",497,0) . new j set j=$ascii($piece(TradeName,"@@@",2))-64 "RTN","TMGNDF1D",498,0) . set TradeName=$piece(TradeName,"@@@",1)_$get(skips(j))_$piece(TradeName,"@@@",3) "RTN","TMGNDF1D",499,0) . set oldName=$piece(oldName,"@@@",1)_$get(skips(j))_$piece(oldName,"@@@",3) "RTN","TMGNDF1D",500,0) ;" "RTN","TMGNDF1D",501,0) if askuser'=1 set PreSelArray(TradeName,IEN)="" quit ;"bypass user asking... "RTN","TMGNDF1D",502,0) ;"------------------ "RTN","TMGNDF1D",503,0) write !,IEN,": '",oldName,"' --> '",TradeName,"'",! "RTN","TMGNDF1D",504,0) new % set %=2 "RTN","TMGNDF1D",505,0) write "Accept Change" do YN^DICN write ! "RTN","TMGNDF1D",506,0) if %=-1 set abort=1 quit "RTN","TMGNDF1D",507,0) if %'=1 quit "RTN","TMGNDF1D",508,0) if TradeName'=oldName do "RTN","TMGNDF1D",509,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1D",510,0) . set TMGFDA(22706.9,IEN_",",.05)=TradeName "RTN","TMGNDF1D",511,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1D",512,0) . set result=1 "RTN","TMGNDF1D",513,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1D",514,0) "RTN","TMGNDF1D",515,0) quit result "RTN","TMGNDF1D",516,0) "RTN","TMGNDF1D",517,0) "RTN","TMGNDF1D",518,0) SetScrubMaps(skips,ignore) "RTN","TMGNDF1D",519,0) ;"Purpose: setup arrays for removing doses from Tradename "RTN","TMGNDF1D",520,0) ;"Input: skips -- PASS BY REFERENCE "RTN","TMGNDF1D",521,0) ;" ignore -- PASS BY REFERENCE "RTN","TMGNDF1D",522,0) ;"result "RTN","TMGNDF1D",523,0) "RTN","TMGNDF1D",524,0) new i "RTN","TMGNDF1D",525,0) set i=0 ;"NOTE!!! ASCII encoding only allow i up to 63!! "RTN","TMGNDF1D",526,0) set i=i+1,skips(i)="5% DEXTROSE" "RTN","TMGNDF1D",527,0) set i=i+1,skips(i)="5 % DEXTROSE" "RTN","TMGNDF1D",528,0) set i=i+1,skips(i)="10% DEXTROSE" "RTN","TMGNDF1D",529,0) set i=i+1,skips(i)="0.9% NA" "RTN","TMGNDF1D",530,0) set i=i+1,skips(i)=".9% NA" "RTN","TMGNDF1D",531,0) set i=i+1,skips(i)="0.45% NA" "RTN","TMGNDF1D",532,0) set i=i+1,skips(i)="7 7 7" "RTN","TMGNDF1D",533,0) set i=i+1,skips(i)="70 30" "RTN","TMGNDF1D",534,0) set i=i+1,skips(i)="7.4" "RTN","TMGNDF1D",535,0) set i=i+1,skips(i)="3 MONTH" "RTN","TMGNDF1D",536,0) set i=i+1,skips(i)="4 MONTH" "RTN","TMGNDF1D",537,0) set i=i+1,skips(i)="28 TAB" "RTN","TMGNDF1D",538,0) set i=i+1,skips(i)="I 131" "RTN","TMGNDF1D",539,0) set i=i+1,skips(i)="I-131" "RTN","TMGNDF1D",540,0) set i=i+1,skips(i)="I 123" "RTN","TMGNDF1D",541,0) set i=i+1,skips(i)="7 VAGINAL" "RTN","TMGNDF1D",542,0) set i=i+1,skips(i)="3 VAGINAL" "RTN","TMGNDF1D",543,0) set i=i+1,skips(i)="0.3% NACL" "RTN","TMGNDF1D",544,0) set i=i+1,skips(i)="0.2% NACL" "RTN","TMGNDF1D",545,0) set i=i+1,skips(i)="B12" "RTN","TMGNDF1D",546,0) set i=i+1,skips(i)="B6" "RTN","TMGNDF1D",547,0) set i=i+1,skips(i)="TC 99M" "RTN","TMGNDF1D",548,0) set i=i+1,skips(i)="TC99M" "RTN","TMGNDF1D",549,0) set i=i+1,skips(i)="THEO 24" "RTN","TMGNDF1D",550,0) set i=i+1,skips(i)="24 H" "RTN","TMGNDF1D",551,0) set i=i+1,skips(i)="12 H" "RTN","TMGNDF1D",552,0) set i=i+1,skips(i)=" 12 " "RTN","TMGNDF1D",553,0) set i=i+1,skips(i)=" 24 " "RTN","TMGNDF1D",554,0) set i=i+1,skips(i)="VITAMIN K1" "RTN","TMGNDF1D",555,0) set i=i+1,skips(i)="PH7" "RTN","TMGNDF1D",556,0) "RTN","TMGNDF1D",557,0) ;"Put entries here when the presence of a word is enough to ignore entire drug name. "RTN","TMGNDF1D",558,0) ;"if TradeName[ingore(x) then no further check done "RTN","TMGNDF1D",559,0) set i=0 ;"no limit on # here... "RTN","TMGNDF1D",560,0) set i=i+1,ignore(i)="TERAZOL" "RTN","TMGNDF1D",561,0) set i=i+1,ignore(i)="ORTHO " "RTN","TMGNDF1D",562,0) set i=i+1,ignore(i)="DARVOCET" "RTN","TMGNDF1D",563,0) set i=i+1,ignore(i)="DEMULEN" "RTN","TMGNDF1D",564,0) set i=i+1,ignore(i)="LEVLEN" "RTN","TMGNDF1D",565,0) set i=i+1,ignore(i)="LEVLITE" "RTN","TMGNDF1D",566,0) set i=i+1,ignore(i)="LOESTRIN" "RTN","TMGNDF1D",567,0) set i=i+1,ignore(i)="NECON" "RTN","TMGNDF1D",568,0) set i=i+1,ignore(i)=" MT " "RTN","TMGNDF1D",569,0) set i=i+1,ignore(i)="ORTHOCEPT" "RTN","TMGNDF1D",570,0) set i=i+1,ignore(i)="GYNAZOLE" "RTN","TMGNDF1D",571,0) set i=i+1,ignore(i)="OVCON" "RTN","TMGNDF1D",572,0) set i=i+1,ignore(i)="MONISTAT" "RTN","TMGNDF1D",573,0) set i=i+1,ignore(i)="MICROGESTIN" "RTN","TMGNDF1D",574,0) set i=i+1,ignore(i)="ULTRASE" "RTN","TMGNDF1D",575,0) set i=i+1,ignore(i)="MTE " "RTN","TMGNDF1D",576,0) set i=i+1,ignore(i)="M T E " "RTN","TMGNDF1D",577,0) set i=i+1,ignore(i)="INSULIN" "RTN","TMGNDF1D",578,0) "RTN","TMGNDF1D",579,0) quit "RTN","TMGNDF1D",580,0) "RTN","TMGNDF1D",581,0) "RTN","TMGNDF1D",582,0) CautionMsg "RTN","TMGNDF1D",583,0) ;"Purpose: To show a caution message. "RTN","TMGNDF1D",584,0) "RTN","TMGNDF1D",585,0) write !,"**NOTICE**",! "RTN","TMGNDF1D",586,0) write "This will use the MULTI-selector to pick imports to be",! "RTN","TMGNDF1D",587,0) write "be edited. BE VERY CAREFUL not to select more than one",! "RTN","TMGNDF1D",588,0) write "drug before exiting to enter the edit screen.",! "RTN","TMGNDF1D",589,0) write "For example: If 3 different drugs were selected, and then",! "RTN","TMGNDF1D",590,0) write "ESC ESC pressed, then one will be presented with an opportunity",! "RTN","TMGNDF1D",591,0) write "to edit the drug name. BUT NOTE: one would be editing ALL THREE",! "RTN","TMGNDF1D",592,0) write "drugs AT ONCE, very likely creating an error in 2 of the drugs.",! "RTN","TMGNDF1D",593,0) write ! "RTN","TMGNDF1D",594,0) "RTN","TMGNDF1D",595,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1D",596,0) quit "RTN","TMGNDF1D",597,0) "RTN","TMGNDF1D",598,0) "RTN","TMGNDF1D",599,0) EditTradename(SkipValue) "RTN","TMGNDF1D",600,0) ;"Purpose: to select records to mark as to be skipped. "RTN","TMGNDF1D",601,0) ;"Input: SkipValue: OPTIONAL. Default=0. "RTN","TMGNDF1D",602,0) ;" 0=show only values NOT marked to be skipped "RTN","TMGNDF1D",603,0) ;" 1=show only values MARKED to be skipped "RTN","TMGNDF1D",604,0) ;" ALL=show BOTH skip and non-skipped fields. "RTN","TMGNDF1D",605,0) ;"Output: User may alter the value of SKIP THIS RECORD field for all records "RTN","TMGNDF1D",606,0) ;"Results: none "RTN","TMGNDF1D",607,0) "RTN","TMGNDF1D",608,0) do CautionMsg "RTN","TMGNDF1D",609,0) "RTN","TMGNDF1D",610,0) new Options,IEN "RTN","TMGNDF1D",611,0) set Options("FIELDS",1)=".04^LONG NAME^25" "RTN","TMGNDF1D",612,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1D",613,0) set Options("FIELDS",2)=".05^TRADENAME^64" "RTN","TMGNDF1D",614,0) set Options("FIELDS","MAX NUM")=2 "RTN","TMGNDF1D",615,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF1D",616,0) "RTN","TMGNDF1D",617,0) set SkipValue=$get(SkipValue,0) ;"0=NOT SKIPPED "RTN","TMGNDF1D",618,0) ;"Get all records with chosed SKIP THIS RECORD value "RTN","TMGNDF1D",619,0) do GetFldValue^TMGSELED(22706.9,6,SkipValue,$name(Options("IEN LIST"))) "RTN","TMGNDF1D",620,0) "RTN","TMGNDF1D",621,0) PSK1 if $$SELED^TMGSELED(.Options)'=2 goto ETNDone "RTN","TMGNDF1D",622,0) if $$GetIENs^TMGSELED(.Options)=0 goto ETNDone "RTN","TMGNDF1D",623,0) goto PSK1 "RTN","TMGNDF1D",624,0) "RTN","TMGNDF1D",625,0) ETNDone quit "RTN","TMGNDF1D",626,0) "RTN","TMGNDF1D",627,0) "RTN","TMGNDF1D",628,0) "RTN","TMGNDF1D",629,0) "RTN","TMGNDF1D",630,0) SelRxList(pList,pSelList,HdrText,mode) "RTN","TMGNDF1D",631,0) ;"Purpose: To display the Drug list, and allow user to select from the list. "RTN","TMGNDF1D",632,0) ;"Input: pList -- PASS BY NAME -- list of drugs to be added, as created by FillList(pList) "RTN","TMGNDF1D",633,0) ;" @pList@(drugName,IEN)="" "RTN","TMGNDF1D",634,0) ;" pSelList -- PASS BY NAME, an OUT PARAMETER. "RTN","TMGNDF1D",635,0) ;" Returns list of selected items "RTN","TMGNDF1D",636,0) ;" @pSelList@(drugName,IEN)="" ;IEN is from 22706.9 "RTN","TMGNDF1D",637,0) ;" @pSelList@(drugName,IEN)="" "RTN","TMGNDF1D",638,0) ;" HdrText -- optional, some text to show on top of selector "RTN","TMGNDF1D",639,0) ;" mode -- OPTIONAL. Default=1 "RTN","TMGNDF1D",640,0) ;" 1 --> Display by LONG NAME .04 name "RTN","TMGNDF1D",641,0) ;" 2 --> Display by VA PRODUCT (50.68) .01 name "RTN","TMGNDF1D",642,0) ;" 3 --> Display by FDA import name "RTN","TMGNDF1D",643,0) ;" 4 --> Display by VA GENERIC name "RTN","TMGNDF1D",644,0) "RTN","TMGNDF1D",645,0) ;"Results: none "RTN","TMGNDF1D",646,0) "RTN","TMGNDF1D",647,0) new ref set ref="^TMP(""VEE"",$J)" "RTN","TMGNDF1D",648,0) kill @ref "RTN","TMGNDF1D",649,0) new count set count=1 "RTN","TMGNDF1D",650,0) set mode=$get(mode,1) "RTN","TMGNDF1D",651,0) "RTN","TMGNDF1D",652,0) new pNDCIndex "RTN","TMGNDF1D",653,0) set pNDCIndex=$$GetNDCIndex^TMGNDF4A(1) "RTN","TMGNDF1D",654,0) "RTN","TMGNDF1D",655,0) write "Prepping to display list...",! "RTN","TMGNDF1D",656,0) ;"First convert list to a display format "RTN","TMGNDF1D",657,0) new name,IEN,Itr "RTN","TMGNDF1D",658,0) "RTN","TMGNDF1D",659,0) set name=$$ItrAInit^TMGITR(pList,.Itr) "RTN","TMGNDF1D",660,0) do PrepProgress^TMGITR(.Itr,20,1,"name") "RTN","TMGNDF1D",661,0) if name'="" for do quit:($$ItrANext^TMGITR(.Itr,.name)="") "RTN","TMGNDF1D",662,0) . new addedArray,showName "RTN","TMGNDF1D",663,0) . set IEN=0 "RTN","TMGNDF1D",664,0) . for set IEN=$order(@pList@(name,IEN)) quit:(IEN="") do "RTN","TMGNDF1D",665,0) . . new NameInfo do GetInfo^TMGNDF3B(IEN,.NameInfo) "RTN","TMGNDF1D",666,0) . . new IdxName set IdxName=$get(NameInfo("MODES",mode)) "RTN","TMGNDF1D",667,0) . . if mode=3 do ;"Display by FDA import name (TradeName) "RTN","TMGNDF1D",668,0) . . . set showName="" "RTN","TMGNDF1D",669,0) . . . for set showName=$order(NameInfo(IdxName,showName)) quit:(showName="") do "RTN","TMGNDF1D",670,0) . . . . set @ref@(count)=name_"^"_IEN_$char(9) "RTN","TMGNDF1D",671,0) . . . . new newShowName set newShowName=$extract(showName,1,35) "RTN","TMGNDF1D",672,0) . . . . set newShowName=$$LJ^XLFSTR(newShowName,35," ") "RTN","TMGNDF1D",673,0) . . . . new newName set newName=$extract(name,1,35) "RTN","TMGNDF1D",674,0) . . . . set newName=$$LJ^XLFSTR(newName,35," ") "RTN","TMGNDF1D",675,0) . . . . set @ref@(count)=@ref@(count)_newShowName_"|"_newName "RTN","TMGNDF1D",676,0) . . . . set count=count+1 "RTN","TMGNDF1D",677,0) . . . set showName="" ;"prevent duplicate addition below "RTN","TMGNDF1D",678,0) . . else if (mode>0)&(mode<5) set showName=$order(NameInfo(IdxName,"")) "RTN","TMGNDF1D",679,0) . . if (showName'="") set @ref@(count)=name_"^"_IEN_$char(9)_showName set count=count+1 "RTN","TMGNDF1D",680,0) "RTN","TMGNDF1D",681,0) set @ref@("HD")=$get(HdrText,"MENU") "RTN","TMGNDF1D",682,0) "RTN","TMGNDF1D",683,0) ;"Note: Rules of use: "RTN","TMGNDF1D",684,0) ;" ref must=^TMP("VEE",$J) "RTN","TMGNDF1D",685,0) ;" Each line should be in this format: "RTN","TMGNDF1D",686,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF1D",687,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF1D",688,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF1D",689,0) ;" Results come back in: "RTN","TMGNDF1D",690,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF1D",691,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF1D",692,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF1D",693,0) "RTN","TMGNDF1D",694,0) write !,"Passing off to Selector..." "RTN","TMGNDF1D",695,0) D SELECT^%ZVEMKT(ref) "RTN","TMGNDF1D",696,0) "RTN","TMGNDF1D",697,0) set ref="^TMP(""VPE"",""SELECT"","_$J_")" "RTN","TMGNDF1D",698,0) new number set number="" "RTN","TMGNDF1D",699,0) for set number=$order(@ref@(number)) quit:(number="") do "RTN","TMGNDF1D",700,0) . new ReturnValue set ReturnValue=$piece(@ref@(number),$char(9),1) "RTN","TMGNDF1D",701,0) . new drugName set drugName=$piece(ReturnValue,"^",1) "RTN","TMGNDF1D",702,0) . new IEN set IEN=$piece(ReturnValue,"^",2) "RTN","TMGNDF1D",703,0) . set @pSelList@(drugName,IEN)="" "RTN","TMGNDF1D",704,0) "RTN","TMGNDF1D",705,0) quit "RTN","TMGNDF1D",706,0) "RTN","TMGNDF1D",707,0) ;"======================================================== "RTN","TMGNDF1D",708,0) PickEdit "RTN","TMGNDF1D",709,0) ;"Purpose: ask user to pick record, and then edit. "RTN","TMGNDF1D",710,0) "RTN","TMGNDF1D",711,0) new DIC,X,Y "RTN","TMGNDF1D",712,0) set DIC=22706.9 "RTN","TMGNDF1D",713,0) set DIC(0)="MAEQ" "RTN","TMGNDF1D",714,0) set DIC("A")="Enter Imported Drug to Edit (^ to abort): " "RTN","TMGNDF1D",715,0) PE1 "RTN","TMGNDF1D",716,0) do ^DIC write ! "RTN","TMGNDF1D",717,0) if +Y>0 do Edit1(+Y) goto PE1 "RTN","TMGNDF1D",718,0) "RTN","TMGNDF1D",719,0) quit "RTN","TMGNDF1D",720,0) "RTN","TMGNDF1D",721,0) "RTN","TMGNDF1D",722,0) Edit1(IEN) "RTN","TMGNDF1D",723,0) ;"Purpose: To edit one record in 22706.9 "RTN","TMGNDF1D",724,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF1D",725,0) ;"Results: none "RTN","TMGNDF1D",726,0) "RTN","TMGNDF1D",727,0) new Options,IENlist "RTN","TMGNDF1D",728,0) set IENlist(IEN)="" "RTN","TMGNDF1D",729,0) set Options("FILE")=22706.9 "RTN","TMGNDF1D",730,0) new temp "RTN","TMGNDF1D",731,0) set temp=$$GetFields^TMGSELED(.Options) "RTN","TMGNDF1D",732,0) if temp=1 set temp=$$EditRecs^TMGSELED("IENlist",.Options) "RTN","TMGNDF1D",733,0) "RTN","TMGNDF1D",734,0) quit "RTN","TMGNDF1D",735,0) "RTN","TMGNDF1D",736,0) "RTN","TMGNDF1E") 0^40^B4552 "RTN","TMGNDF1E",1,0) TMGNDF1E ;TMG/kst/FDA Import: Pick imports to skip ;03/25/06 "RTN","TMGNDF1E",2,0) ;;1.0;TMG-LIB;**1**;01/23/07 "RTN","TMGNDF1E",3,0) "RTN","TMGNDF1E",4,0) ;"FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF1E",5,0) ;"More code for determining files to skip. "RTN","TMGNDF1E",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF1E",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF1E",8,0) ;"1-23-07 "RTN","TMGNDF1E",9,0) "RTN","TMGNDF1E",10,0) ;"======================================================================= "RTN","TMGNDF1E",11,0) ;" API -- Public Functions. "RTN","TMGNDF1E",12,0) ;"======================================================================= "RTN","TMGNDF1E",13,0) ;"Menu "RTN","TMGNDF1E",14,0) "RTN","TMGNDF1E",15,0) ;"======================================================================= "RTN","TMGNDF1E",16,0) ;" Private Functions. "RTN","TMGNDF1E",17,0) ;"======================================================================= "RTN","TMGNDF1E",18,0) ;"======================================================================= "RTN","TMGNDF1E",19,0) "RTN","TMGNDF1E",20,0) Menu "RTN","TMGNDF1E",21,0) ;"Purpose: To give an interactive menu of tools to clean up data. "RTN","TMGNDF1E",22,0) "RTN","TMGNDF1E",23,0) new Menu,UsrSlct "RTN","TMGNDF1E",24,0) new i set i=0 "RTN","TMGNDF1E",25,0) set Menu(i)="Pick Option for Picking Imports to SKIP (1E)",i=i+1 "RTN","TMGNDF1E",26,0) set Menu(i)="Flag DUPLICATE entries to be skipped"_$char(9)_"DUPS",i=i+1 "RTN","TMGNDF1E",27,0) set Menu(i)="Flag entries with MISSING STRENGTH to be skipped"_$char(9)_"RemoveStrMissing",i=i+1 "RTN","TMGNDF1E",28,0) set Menu(i)="Flag entries with MISSING UNITS to be skipped"_$char(9)_"RemoveUnitMissing",i=i+1 "RTN","TMGNDF1E",29,0) set Menu(i)="Flag entries with MISSING INGREDIENTS to be skipped"_$char(9)_"RemoveIngredMissing",i=i+1 "RTN","TMGNDF1E",30,0) set Menu(i)="Flag entries with MISSING TRADE NAME to be skipped"_$char(9)_"RemoveTNameMissing",i=i+1 "RTN","TMGNDF1E",31,0) set Menu(i)="Flag entries with MISSING GENERIC NAME to be skipped"_$char(9)_"RemoveGNameMissing",i=i+1 "RTN","TMGNDF1E",32,0) set Menu(i)="Flag entries with MISSING NDC to be skipped"_$char(9)_"RemoveNDCMissing",i=i+1 "RTN","TMGNDF1E",33,0) set Menu(i)="Manually PICK drugs to be skipped: Trade Name, Units, Strength"_$char(9)_"PICK",i=i+1 "RTN","TMGNDF1E",34,0) set Menu(i)="Manually PICK drugs to be skipped: Trade Name, Generic Name, Strength"_$char(9)_"PICK2",i=i+1 "RTN","TMGNDF1E",35,0) set Menu(i)="Manually PICK drugs to be skipped: Long Name, Trade&Form, Generic&Form"_$char(9)_"PICK3",i=i+1 "RTN","TMGNDF1E",36,0) set Menu(i)="Manually PICK drugs to be UNSKIPPED: Trade Name, Units, Strength"_$char(9)_"UNPICK",i=i+1 "RTN","TMGNDF1E",37,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF1E",38,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF1E",39,0) "RTN","TMGNDF1E",40,0) CD1 "RTN","TMGNDF1E",41,0) write # "RTN","TMGNDF1E",42,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF1E",43,0) if UsrSlct="^" goto CDDone "RTN","TMGNDF1E",44,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF1E",45,0) "RTN","TMGNDF1E",46,0) if UsrSlct="Prev" goto Menu^TMGNDF1D ;"quit can occur from there... "RTN","TMGNDF1E",47,0) if UsrSlct="Next" goto Menu^TMGNDF1F ;"quit can occur from there... "RTN","TMGNDF1E",48,0) "RTN","TMGNDF1E",49,0) if UsrSlct="DUPS" do RemoveDups goto CD1 "RTN","TMGNDF1E",50,0) if UsrSlct="RemoveStrMissing" do RemoveStrMissing goto CD1 "RTN","TMGNDF1E",51,0) if UsrSlct="RemoveUnitMissing" do RemoveUnitMissing goto CD1 "RTN","TMGNDF1E",52,0) if UsrSlct="RemoveTNameMissing" do RemoveTNameMissing goto CD1 "RTN","TMGNDF1E",53,0) if UsrSlct="RemoveGNameMissing" do RemoveGNameMissing goto CD1 "RTN","TMGNDF1E",54,0) if UsrSlct="RemoveNDCMissing" do RemoveNDCMissing goto CD1 "RTN","TMGNDF1E",55,0) if UsrSlct="RemoveIngredMissing" do RemoveIngredMissing goto CD1 "RTN","TMGNDF1E",56,0) if UsrSlct="PICK" do PickSkips(,,1,1) goto CD1 "RTN","TMGNDF1E",57,0) if UsrSlct="PICK2" do PickSkp2(,) goto CD1 "RTN","TMGNDF1E",58,0) if UsrSlct="PICK3" do PickSkp3(,) goto CD1 "RTN","TMGNDF1E",59,0) if UsrSlct="UNPICK" do PickSkips(,,,,"ALL") goto CD1 "RTN","TMGNDF1E",60,0) goto CDDone "RTN","TMGNDF1E",61,0) CDDone "RTN","TMGNDF1E",62,0) quit "RTN","TMGNDF1E",63,0) "RTN","TMGNDF1E",64,0) "RTN","TMGNDF1E",65,0) "RTN","TMGNDF1E",66,0) "RTN","TMGNDF1E",67,0) SelectScan(ScrnCode,editStr,edtUnit) "RTN","TMGNDF1E",68,0) ;"Purpose: Set chosen records to be skipped "RTN","TMGNDF1E",69,0) ;" This will scan for records passing screen and pre-select "RTN","TMGNDF1E",70,0) ;" them. Then display them to the user to allow "RTN","TMGNDF1E",71,0) ;" the individual drugs to be de-selected if wanted. "RTN","TMGNDF1E",72,0) ;" After finishing the review, then all the selected "RTN","TMGNDF1E",73,0) ;" records may be set to SKIP "RTN","TMGNDF1E",74,0) ;"Input: ScrnCode -- OPTIONAL. M Code to execute in the following format: "RTN","TMGNDF1E",75,0) ;" set flagToSkip=$$SomeTest(IEN) "RTN","TMGNDF1E",76,0) ;" Code may use variable IEN, which is record in 22706.9 "RTN","TMGNDF1E",77,0) ;" editStr: Optional. Default=0. 1 if Can edit Strength field "RTN","TMGNDF1E",78,0) ;" editUnit: Optional. Default=0. 1 if Can edit Unit field "RTN","TMGNDF1E",79,0) ;"Output: Records may be set to be skipped if user chooses to do this. "RTN","TMGNDF1E",80,0) ;"Results: none "RTN","TMGNDF1E",81,0) "RTN","TMGNDF1E",82,0) new SelArray,flagToSkip "RTN","TMGNDF1E",83,0) set ScrnCode=$get(ScrnCode) "RTN","TMGNDF1E",84,0) "RTN","TMGNDF1E",85,0) new Itr,IEN,abort,name "RTN","TMGNDF1E",86,0) set abort=0 "RTN","TMGNDF1E",87,0) write "Scanning drugs for entries to be preselected for skipping...",! "RTN","TMGNDF1E",88,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1E",89,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1E",90,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF1E",91,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)'=0 quit ;"0=KEEP; 1=SKIP "RTN","TMGNDF1E",92,0) . if $$KeyPressed^TMGUSRIF=27 set abort=27 quit "RTN","TMGNDF1E",93,0) . set flagToSkip=0 "RTN","TMGNDF1E",94,0) . new $etrap set $etrap="write !,""Error trapped."",!" "RTN","TMGNDF1E",95,0) . if ScrnCode'="" xecute ScrnCode "RTN","TMGNDF1E",96,0) . if flagToSkip=1 set SelArray(IEN)="" "RTN","TMGNDF1E",97,0) "RTN","TMGNDF1E",98,0) new % set %=2 "RTN","TMGNDF1E",99,0) write !,"Show ONLY preselected drugs (faster)" "RTN","TMGNDF1E",100,0) do YN^DICN write ! "RTN","TMGNDF1E",101,0) ;"write "%=",%,! "RTN","TMGNDF1E",102,0) if %=-1 goto SScDone "RTN","TMGNDF1E",103,0) write !,"Now will show entries PRESELECTED in list of all drugs.",! "RTN","TMGNDF1E",104,0) do PickSkips(.SelArray,(%=1),.editStr,.editUnit) "RTN","TMGNDF1E",105,0) "RTN","TMGNDF1E",106,0) SScDone "RTN","TMGNDF1E",107,0) quit "RTN","TMGNDF1E",108,0) "RTN","TMGNDF1E",109,0) "RTN","TMGNDF1E",110,0) "RTN","TMGNDF1E",111,0) PickSkips(SelArray,JustSelected,editStr,edtUnit,SkipValue) "RTN","TMGNDF1E",112,0) ;"Purpose: to select records to mark as to be skipped. "RTN","TMGNDF1E",113,0) ;"Input: SelArray: Optional. PASS BY REFERENCE. An array of preselected IEN's "RTN","TMGNDF1E",114,0) ;" Format: SelArray(IEN in 22706.9)="" <-- IEN preselected "RTN","TMGNDF1E",115,0) ;" JustSelected: Optional. if 1, then ONLY IENs from SelArray shown. "RTN","TMGNDF1E",116,0) ;" editStr: Optional. Default=0. 1 if Can edit Strength field "RTN","TMGNDF1E",117,0) ;" editUnit: Optional. Default=0. 1 if Can edit Unit field "RTN","TMGNDF1E",118,0) ;" SkipValue: OPTIONAL. Default=0. "RTN","TMGNDF1E",119,0) ;" 0=show only values NOT marked to be skipped "RTN","TMGNDF1E",120,0) ;" 1=show only values MARKED to be skipped "RTN","TMGNDF1E",121,0) ;" ALL=show BOTH skip and non-skipped fields. "RTN","TMGNDF1E",122,0) ;"Output: User may alter the value of SKIP THIS RECORD field for all records "RTN","TMGNDF1E",123,0) ;"Results: none "RTN","TMGNDF1E",124,0) "RTN","TMGNDF1E",125,0) new Options,IEN "RTN","TMGNDF1E",126,0) set Options("FIELDS",1)=".05^TRADENAME^50" "RTN","TMGNDF1E",127,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",128,0) set Options("FIELDS",2)="1^STRENGTH^9" "RTN","TMGNDF1E",129,0) if +$get(editStr)=0 set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",130,0) set Options("FIELDS",3)="2^UNIT^9" "RTN","TMGNDF1E",131,0) if +$get(editUnit)=0 set Options("FIELDS",3,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",132,0) set Options("FIELDS",4)="6^SKIP THIS RECORD^4" "RTN","TMGNDF1E",133,0) set Options("FIELDS","MAX NUM")=4 "RTN","TMGNDF1E",134,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF1E",135,0) "RTN","TMGNDF1E",136,0) set SkipValue=$get(SkipValue,0) "RTN","TMGNDF1E",137,0) if +$get(JustSelected)=0 do "RTN","TMGNDF1E",138,0) . ;"Get all records with chosed SKIP THIS RECORD value "RTN","TMGNDF1E",139,0) . if SkipValue=0 do "RTN","TMGNDF1E",140,0) . . new ScrnCode set ScrnCode="($get(RecValue)=1)" ;"Field has THREE possible values: 0,1,NULL "RTN","TMGNDF1E",141,0) . . do GetFldVScreen^TMGSELED(22706.9,6,ScrnCode,$name(Options("IEN LIST"))) "RTN","TMGNDF1E",142,0) . else do "RTN","TMGNDF1E",143,0) . . do GetFldValue^TMGSELED(22706.9,6,SkipValue,$name(Options("IEN LIST"))) "RTN","TMGNDF1E",144,0) else do "RTN","TMGNDF1E",145,0) . merge Options("IEN LIST")=SelArray "RTN","TMGNDF1E",146,0) "RTN","TMGNDF1E",147,0) PSK1 if $data(SelArray) do "RTN","TMGNDF1E",148,0) . set IEN="" "RTN","TMGNDF1E",149,0) . for set IEN=$order(SelArray(IEN)) quit:(IEN="") do "RTN","TMGNDF1E",150,0) . . if $data(Options("IEN LIST",IEN))>0 do "RTN","TMGNDF1E",151,0) . . . set Options("IEN LIST",IEN,"SEL")="" "RTN","TMGNDF1E",152,0) "RTN","TMGNDF1E",153,0) if $$SELED^TMGSELED(.Options)'=2 goto PSKDone "RTN","TMGNDF1E",154,0) if $$GetIENs^TMGSELED(.Options)=0 goto PSKDone "RTN","TMGNDF1E",155,0) goto PSK1 "RTN","TMGNDF1E",156,0) "RTN","TMGNDF1E",157,0) PSKDone quit "RTN","TMGNDF1E",158,0) "RTN","TMGNDF1E",159,0) "RTN","TMGNDF1E",160,0) PickSkp2(SelArray,JustSelected,SkipValue) "RTN","TMGNDF1E",161,0) ;"Purpose: to select records to mark as to be skipped. "RTN","TMGNDF1E",162,0) ;" Showing Tradename and Generic name "RTN","TMGNDF1E",163,0) ;"Input: SelArray: Optional. PASS BY REFERENCE. An array of preselected IEN's "RTN","TMGNDF1E",164,0) ;" Format: SelArray(IEN in 22706.9)="" <-- IEN preselected "RTN","TMGNDF1E",165,0) ;" JustSelected: Optional. if 1, then ONLY IENs from SelArray shown. "RTN","TMGNDF1E",166,0) ;" SkipValue: OPTIONAL. Default=0. "RTN","TMGNDF1E",167,0) ;" 0=show only values NOT marked to be skipped "RTN","TMGNDF1E",168,0) ;" 1=show only values MARKED to be skipped "RTN","TMGNDF1E",169,0) ;" ALL=show BOTH skip and non-skipped fields. "RTN","TMGNDF1E",170,0) ;"Output: User may alter the value of SKIP THIS RECORD field for all records "RTN","TMGNDF1E",171,0) ;"Results: none "RTN","TMGNDF1E",172,0) "RTN","TMGNDF1E",173,0) new Options,IEN "RTN","TMGNDF1E",174,0) set Options("FIELDS",1)=".05^TRADENAME^30" "RTN","TMGNDF1E",175,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",176,0) set Options("FIELDS",2)=".07^GENERIC NAME^30" "RTN","TMGNDF1E",177,0) set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",178,0) set Options("FIELDS",3)="1^STRENGTH^9" "RTN","TMGNDF1E",179,0) set Options("FIELDS",3,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",180,0) set Options("FIELDS",4)="6^SKIP THIS RECORD^4" "RTN","TMGNDF1E",181,0) set Options("FIELDS","MAX NUM")=4 "RTN","TMGNDF1E",182,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF1E",183,0) "RTN","TMGNDF1E",184,0) set SkipValue=$get(SkipValue,0) "RTN","TMGNDF1E",185,0) if +$get(JustSelected)=0 do "RTN","TMGNDF1E",186,0) . ;"Get all records with chosed SKIP THIS RECORD value "RTN","TMGNDF1E",187,0) . if SkipValue=0 do "RTN","TMGNDF1E",188,0) . . new ScrnCode set ScrnCode="($get(RecValue)=1)" ;"Field has THREE possible values: 0,1,NULL "RTN","TMGNDF1E",189,0) . . do GetFldVScreen^TMGSELED(22706.9,6,ScrnCode,$name(Options("IEN LIST"))) "RTN","TMGNDF1E",190,0) . else do "RTN","TMGNDF1E",191,0) . . do GetFldValue^TMGSELED(22706.9,6,SkipValue,$name(Options("IEN LIST"))) "RTN","TMGNDF1E",192,0) else do "RTN","TMGNDF1E",193,0) . merge Options("IEN LIST")=SelArray "RTN","TMGNDF1E",194,0) "RTN","TMGNDF1E",195,0) PSK21 if $data(SelArray) do "RTN","TMGNDF1E",196,0) . set IEN="" "RTN","TMGNDF1E",197,0) . for set IEN=$order(SelArray(IEN)) quit:(IEN="") do "RTN","TMGNDF1E",198,0) . . if $data(Options("IEN LIST",IEN))>0 do "RTN","TMGNDF1E",199,0) . . . set Options("IEN LIST",IEN,"SEL")="" "RTN","TMGNDF1E",200,0) "RTN","TMGNDF1E",201,0) if $$SELED^TMGSELED(.Options)'=2 goto PSK2Done "RTN","TMGNDF1E",202,0) if $$GetIENs^TMGSELED(.Options)=0 goto PSK2Done "RTN","TMGNDF1E",203,0) goto PSK21 "RTN","TMGNDF1E",204,0) "RTN","TMGNDF1E",205,0) PSK2Done quit "RTN","TMGNDF1E",206,0) "RTN","TMGNDF1E",207,0) "RTN","TMGNDF1E",208,0) "RTN","TMGNDF1E",209,0) PickSkp3(SelArray,JustSelected,SkipValue) "RTN","TMGNDF1E",210,0) ;"Purpose: to select records to mark as to be skipped. "RTN","TMGNDF1E",211,0) ;" Showing Tradename and Generic name "RTN","TMGNDF1E",212,0) ;"Input: SelArray: Optional. PASS BY REFERENCE. An array of preselected IEN's "RTN","TMGNDF1E",213,0) ;" Format: SelArray(IEN in 22706.9)="" <-- IEN preselected "RTN","TMGNDF1E",214,0) ;" JustSelected: Optional. if 1, then ONLY IENs from SelArray shown. "RTN","TMGNDF1E",215,0) ;" SkipValue: OPTIONAL. Default=0. "RTN","TMGNDF1E",216,0) ;" 0=show only values NOT marked to be skipped "RTN","TMGNDF1E",217,0) ;" 1=show only values MARKED to be skipped "RTN","TMGNDF1E",218,0) ;" ALL=show BOTH skip and non-skipped fields. "RTN","TMGNDF1E",219,0) ;"Output: User may alter the value of SKIP THIS RECORD field for all records "RTN","TMGNDF1E",220,0) ;"Results: none "RTN","TMGNDF1E",221,0) "RTN","TMGNDF1E",222,0) new Options,IEN "RTN","TMGNDF1E",223,0) set Options("FIELDS",1)=".04^LONG NAME^30" "RTN","TMGNDF1E",224,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",225,0) set Options("FIELDS",2)=".055^TRADE NAME & FORM - 40^20" "RTN","TMGNDF1E",226,0) set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",227,0) set Options("FIELDS",3)=".075^GENERIC NAME & FORM - 40^20" "RTN","TMGNDF1E",228,0) set Options("FIELDS",3,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1E",229,0) set Options("FIELDS",4)="6^SKIP THIS RECORD^4" "RTN","TMGNDF1E",230,0) set Options("FIELDS","MAX NUM")=4 "RTN","TMGNDF1E",231,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF1E",232,0) "RTN","TMGNDF1E",233,0) set SkipValue=$get(SkipValue,0) "RTN","TMGNDF1E",234,0) if +$get(JustSelected)=0 do "RTN","TMGNDF1E",235,0) . ;"Get all records with chosed SKIP THIS RECORD value "RTN","TMGNDF1E",236,0) . if SkipValue=0 do "RTN","TMGNDF1E",237,0) . . new ScrnCode set ScrnCode="($get(RecValue)=1)" ;"Field has THREE possible values: 0:keep,1:skip,NULL "RTN","TMGNDF1E",238,0) . . do GetFldVScreen^TMGSELED(22706.9,6,ScrnCode,$name(Options("IEN LIST"))) "RTN","TMGNDF1E",239,0) . else do "RTN","TMGNDF1E",240,0) . . do GetFldValue^TMGSELED(22706.9,6,SkipValue,$name(Options("IEN LIST"))) "RTN","TMGNDF1E",241,0) else do "RTN","TMGNDF1E",242,0) . merge Options("IEN LIST")=SelArray "RTN","TMGNDF1E",243,0) "RTN","TMGNDF1E",244,0) PSK31 if $data(SelArray) do "RTN","TMGNDF1E",245,0) . set IEN="" "RTN","TMGNDF1E",246,0) . for set IEN=$order(SelArray(IEN)) quit:(IEN="") do "RTN","TMGNDF1E",247,0) . . if $data(Options("IEN LIST",IEN))>0 do "RTN","TMGNDF1E",248,0) . . . set Options("IEN LIST",IEN,"SEL")="" "RTN","TMGNDF1E",249,0) "RTN","TMGNDF1E",250,0) if $$SELED^TMGSELED(.Options)'=2 goto PSK3Done "RTN","TMGNDF1E",251,0) if $$GetIENs^TMGSELED(.Options)=0 goto PSK3Done "RTN","TMGNDF1E",252,0) goto PSK31 "RTN","TMGNDF1E",253,0) "RTN","TMGNDF1E",254,0) PSK3Done quit "RTN","TMGNDF1E",255,0) "RTN","TMGNDF1E",256,0) "RTN","TMGNDF1E",257,0) "RTN","TMGNDF1E",258,0) RemoveDups "RTN","TMGNDF1E",259,0) ;"Purpose: Set duplicate records to be skipped "RTN","TMGNDF1E",260,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",261,0) "RTN","TMGNDF1E",262,0) new ref set ref=$name(^TMG("TMP","SEL SCAN")) "RTN","TMGNDF1E",263,0) kill @ref "RTN","TMGNDF1E",264,0) do SelectScan("set flagToSkip=$$DupTest(IEN)",0,0) "RTN","TMGNDF1E",265,0) kill @ref "RTN","TMGNDF1E",266,0) quit "RTN","TMGNDF1E",267,0) "RTN","TMGNDF1E",268,0) "RTN","TMGNDF1E",269,0) DupTest(IEN) "RTN","TMGNDF1E",270,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",271,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",272,0) "RTN","TMGNDF1E",273,0) new result set result=0 "RTN","TMGNDF1E",274,0) if $get(IEN)'="" do "RTN","TMGNDF1E",275,0) . new ref set ref=$name(^TMG("TMP","SEL SCAN")) "RTN","TMGNDF1E",276,0) . ;"if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 set result=1 goto DTDone "RTN","TMGNDF1E",277,0) . new name set name=$$MakeName^TMGNDF2G(IEN) "RTN","TMGNDF1E",278,0) . if $data(@ref@(name))>0 set result=1 "RTN","TMGNDF1E",279,0) . else set @ref@(name)="" "RTN","TMGNDF1E",280,0) "RTN","TMGNDF1E",281,0) DTDone quit result "RTN","TMGNDF1E",282,0) "RTN","TMGNDF1E",283,0) "RTN","TMGNDF1E",284,0) RemoveStrMissing "RTN","TMGNDF1E",285,0) ;"Purpose: Set incomplete records to be skipped "RTN","TMGNDF1E",286,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",287,0) write "Preselect items with Strength missing...",! "RTN","TMGNDF1E",288,0) do SelectScan("set flagToSkip=$$MissStrTest(IEN)",1,1) "RTN","TMGNDF1E",289,0) quit "RTN","TMGNDF1E",290,0) "RTN","TMGNDF1E",291,0) MissStrTest(IEN) "RTN","TMGNDF1E",292,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",293,0) ;" Will flag for skipping if missing STRENGTH "RTN","TMGNDF1E",294,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",295,0) "RTN","TMGNDF1E",296,0) new result set result=0 "RTN","TMGNDF1E",297,0) new s set s=$get(^TMG(22706.9,IEN,0)) "RTN","TMGNDF1E",298,0) ;"0;2=STENGTH field "RTN","TMGNDF1E",299,0) if ($piece(s,"^",2)="") set result=1 "RTN","TMGNDF1E",300,0) quit result "RTN","TMGNDF1E",301,0) "RTN","TMGNDF1E",302,0) "RTN","TMGNDF1E",303,0) RemoveUnitMissing "RTN","TMGNDF1E",304,0) ;"Purpose: Set incomplete records to be skipped "RTN","TMGNDF1E",305,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",306,0) write "Preselect items with Units missing...",! "RTN","TMGNDF1E",307,0) do SelectScan("set flagToSkip=$$MissUnitTest(IEN)",1,1) "RTN","TMGNDF1E",308,0) quit "RTN","TMGNDF1E",309,0) "RTN","TMGNDF1E",310,0) "RTN","TMGNDF1E",311,0) MissUnitTest(IEN) "RTN","TMGNDF1E",312,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",313,0) ;" Will flag for skipping if missing UNITS "RTN","TMGNDF1E",314,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",315,0) "RTN","TMGNDF1E",316,0) new result set result=0 "RTN","TMGNDF1E",317,0) new s set s=$get(^TMG(22706.9,IEN,0)) "RTN","TMGNDF1E",318,0) ;"0;3=UNIT field "RTN","TMGNDF1E",319,0) if ($piece(s,"^",3)="") set result=1 "RTN","TMGNDF1E",320,0) quit result "RTN","TMGNDF1E",321,0) "RTN","TMGNDF1E",322,0) RemoveTNameMissing "RTN","TMGNDF1E",323,0) ;"Purpose: Set incomplete records to be skipped "RTN","TMGNDF1E",324,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",325,0) write "Preselect items with Tradename missing...",! "RTN","TMGNDF1E",326,0) do SelectScan("set flagToSkip=$$MissTNameTest(IEN)",1,1) "RTN","TMGNDF1E",327,0) quit "RTN","TMGNDF1E",328,0) "RTN","TMGNDF1E",329,0) "RTN","TMGNDF1E",330,0) MissTNameTest(IEN) "RTN","TMGNDF1E",331,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",332,0) ;" Will flag for skipping if missing TRADENAME "RTN","TMGNDF1E",333,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",334,0) "RTN","TMGNDF1E",335,0) new result set result=0 "RTN","TMGNDF1E",336,0) new s set s=$get(^TMG(22706.9,IEN,0)) "RTN","TMGNDF1E",337,0) ;"0;4=TRADENAME "RTN","TMGNDF1E",338,0) if ($piece(s,"^",4)="") set result=1 "RTN","TMGNDF1E",339,0) quit result "RTN","TMGNDF1E",340,0) "RTN","TMGNDF1E",341,0) RemoveGNameMissing "RTN","TMGNDF1E",342,0) ;"Purpose: Set incomplete records to be skipped "RTN","TMGNDF1E",343,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",344,0) write "Preselect items with Generic Name missing...",! "RTN","TMGNDF1E",345,0) do SelectScan("set flagToSkip=$$MissGNameTest(IEN)",1,1) "RTN","TMGNDF1E",346,0) quit "RTN","TMGNDF1E",347,0) "RTN","TMGNDF1E",348,0) "RTN","TMGNDF1E",349,0) MissGNameTest(IEN) "RTN","TMGNDF1E",350,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",351,0) ;" Will flag for skipping if missing GENERIC NAME "RTN","TMGNDF1E",352,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",353,0) "RTN","TMGNDF1E",354,0) new result set result=0 "RTN","TMGNDF1E",355,0) new s set s=$get(^TMG(22706.9,IEN,0)) "RTN","TMGNDF1E",356,0) ;"0;6=GENERIC NAME "RTN","TMGNDF1E",357,0) if ($piece(s,"^",6)="") set result=1 "RTN","TMGNDF1E",358,0) quit result "RTN","TMGNDF1E",359,0) "RTN","TMGNDF1E",360,0) RemoveNDCMissing "RTN","TMGNDF1E",361,0) ;"Purpose: Set incomplete records to be skipped "RTN","TMGNDF1E",362,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",363,0) write "Preselect items with NDC missing...",! "RTN","TMGNDF1E",364,0) do SelectScan("set flagToSkip=$$MissNDCTest(IEN)",1,1) "RTN","TMGNDF1E",365,0) quit "RTN","TMGNDF1E",366,0) "RTN","TMGNDF1E",367,0) "RTN","TMGNDF1E",368,0) MissNDCTest(IEN) "RTN","TMGNDF1E",369,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",370,0) ;" Will flag for skipping if missing NDC "RTN","TMGNDF1E",371,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",372,0) "RTN","TMGNDF1E",373,0) new result set result=0 "RTN","TMGNDF1E",374,0) set s=$get(^TMG(22706.9,IEN,1)) "RTN","TMGNDF1E",375,0) ;"1;2=NDC 12 DIGIT "RTN","TMGNDF1E",376,0) if ($piece(s,"^",2)="") set result=1 "RTN","TMGNDF1E",377,0) quit result "RTN","TMGNDF1E",378,0) "RTN","TMGNDF1E",379,0) RemoveIngredMissing "RTN","TMGNDF1E",380,0) ;"Purpose: Set incomplete records to be skipped "RTN","TMGNDF1E",381,0) ;" Then allow selected records to be set to SKIP "RTN","TMGNDF1E",382,0) write "Preselect items with Ingredients missing...",! "RTN","TMGNDF1E",383,0) do SelectScan("set flagToSkip=$$MissIngredTest(IEN)",1,1) "RTN","TMGNDF1E",384,0) quit "RTN","TMGNDF1E",385,0) "RTN","TMGNDF1E",386,0) "RTN","TMGNDF1E",387,0) MissIngredTest(IEN) "RTN","TMGNDF1E",388,0) ;"Purpose: to determine if record should be selected "RTN","TMGNDF1E",389,0) ;" Will flag for skipping if missing NDC "RTN","TMGNDF1E",390,0) ;"Returns 1 if should be flagged for skip, otherwise 0 "RTN","TMGNDF1E",391,0) "RTN","TMGNDF1E",392,0) new result set result=0 "RTN","TMGNDF1E",393,0) ;"4th piece of 0 node is total number of records "RTN","TMGNDF1E",394,0) new numRecs "RTN","TMGNDF1E",395,0) set numRecs=+$piece($get(^TMG(22706.9,IEN,4,0)),"^",4) "RTN","TMGNDF1E",396,0) if numRecs=0 set result=1 "RTN","TMGNDF1E",397,0) if numRecs=1 do "RTN","TMGNDF1E",398,0) . if +$piece($get(^TMG(22706.9,IEN,4,1,0)),"^",3)=0 set result=1 "RTN","TMGNDF1E",399,0) quit result "RTN","TMGNDF1E",400,0) "RTN","TMGNDF1F") 0^41^B6001 "RTN","TMGNDF1F",1,0) TMGNDF1F ;TMG/kst/FDA Import: Work with drug ROUTES ;03/25/06 "RTN","TMGNDF1F",2,0) ;;1.0;TMG-LIB;**1**;02/26/07 "RTN","TMGNDF1F",3,0) "RTN","TMGNDF1F",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF1F",5,0) ;" -- Working with Dosage ROUTES "RTN","TMGNDF1F",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF1F",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF1F",8,0) ;"2-26-07 "RTN","TMGNDF1F",9,0) "RTN","TMGNDF1F",10,0) ;"======================================================================= "RTN","TMGNDF1F",11,0) ;" API -- Public Functions. "RTN","TMGNDF1F",12,0) ;"======================================================================= "RTN","TMGNDF1F",13,0) ;"Menu "RTN","TMGNDF1F",14,0) "RTN","TMGNDF1F",15,0) ;"======================================================================= "RTN","TMGNDF1F",16,0) ;" Private Functions. "RTN","TMGNDF1F",17,0) ;"======================================================================= "RTN","TMGNDF1F",18,0) "RTN","TMGNDF1F",19,0) ;"======================================================================= "RTN","TMGNDF1F",20,0) ;"======================================================================= "RTN","TMGNDF1F",21,0) "RTN","TMGNDF1F",22,0) ;"ScrnAll -- Fix missing Dose ROUTES from DRUG file "RTN","TMGNDF1F",23,0) "RTN","TMGNDF1F",24,0) ;"======================================================================= "RTN","TMGNDF1F",25,0) ;" Private Functions. "RTN","TMGNDF1F",26,0) ;"======================================================================= "RTN","TMGNDF1F",27,0) Menu "RTN","TMGNDF1F",28,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF1F",29,0) "RTN","TMGNDF1F",30,0) new Menu,UsrSlct "RTN","TMGNDF1F",31,0) set Menu(0)="Pick Option for Ensuring correct DOSE ROUTES (1F)" "RTN","TMGNDF1F",32,0) "RTN","TMGNDF1F",33,0) new i set i=1 "RTN","TMGNDF1F",34,0) set Menu(i)="Find new import ROUTES"_$char(9)_"FINDNEW" set i=i+1 "RTN","TMGNDF1F",35,0) set Menu(i)="Match imports ROUTE --> VA ROUTE"_$char(9)_"MATCH" set i=i+1 "RTN","TMGNDF1F",36,0) set Menu(i)="Fix imports with missing ROUTE"_$char(9)_"FixMissingRoute" set i=i+1 "RTN","TMGNDF1F",37,0) set Menu(i)="Screen ALL imports for INCORRECT ROUTE"_$char(9)_"ScreenAll" set i=i+1 "RTN","TMGNDF1F",38,0) set Menu(i)="Edit match file (IF NEEDED)"_$char(9)_"EditMatch" set i=i+1 "RTN","TMGNDF1F",39,0) set Menu(i)="Edit VA ROUTES (file 51.2) (ONLY IF NEEDED)"_$char(9)_"EDITVA" set i=i+1 "RTN","TMGNDF1F",40,0) set Menu(i)="USE links for import ROUTE --> VA ROUTE (DO THIS LAST)"_$char(9)_"FillVARoute" set i=i+1 "RTN","TMGNDF1F",41,0) "RTN","TMGNDF1F",42,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF1F",43,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF1F",44,0) "RTN","TMGNDF1F",45,0) MC1 write # "RTN","TMGNDF1F",46,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF1F",47,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF1F",48,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF1F",49,0) "RTN","TMGNDF1F",50,0) if UsrSlct="FixMissingRoute" do FixMissingRoute goto MC1 "RTN","TMGNDF1F",51,0) if UsrSlct="ScreenAll" do ScrnAll goto MC1 "RTN","TMGNDF1F",52,0) "RTN","TMGNDF1F",53,0) if UsrSlct="FillVARoute" do FillVARoute goto MC1 "RTN","TMGNDF1F",54,0) if UsrSlct="EditMatch" do EditMatchFile goto MC1 "RTN","TMGNDF1F",55,0) if UsrSlct="FINDNEW" do FindUnmatched goto MC1 "RTN","TMGNDF1F",56,0) if UsrSlct="MATCH" do HandleLinks goto MC1 "RTN","TMGNDF1F",57,0) if UsrSlct="EDITVA" do EditVARoutes goto MC1 "RTN","TMGNDF1F",58,0) "RTN","TMGNDF1F",59,0) "RTN","TMGNDF1F",60,0) if UsrSlct="Prev" goto Menu^TMGNDF1E ;"quit can occur from there... "RTN","TMGNDF1F",61,0) if UsrSlct="Next" goto Menu^TMGNDF2A ;"quit can occur from there... "RTN","TMGNDF1F",62,0) goto MC1 "RTN","TMGNDF1F",63,0) "RTN","TMGNDF1F",64,0) MCDone "RTN","TMGNDF1F",65,0) quit "RTN","TMGNDF1F",66,0) "RTN","TMGNDF1F",67,0) ;"======================================================================= "RTN","TMGNDF1F",68,0) "RTN","TMGNDF1F",69,0) "RTN","TMGNDF1F",70,0) ScrnAll "RTN","TMGNDF1F",71,0) ;"Purpose: Fix missing or screen for Dose ROUTES from DRUG file "RTN","TMGNDF1F",72,0) ;"Results -- none. "RTN","TMGNDF1F",73,0) "RTN","TMGNDF1F",74,0) write "Scanning for records to display...",! "RTN","TMGNDF1F",75,0) do SelEdRArray() "RTN","TMGNDF1F",76,0) quit "RTN","TMGNDF1F",77,0) "RTN","TMGNDF1F",78,0) "RTN","TMGNDF1F",79,0) FixMissingRoute "RTN","TMGNDF1F",80,0) ;"Purpose: Fix missing or screen for Dose ROUTES from DRUG file "RTN","TMGNDF1F",81,0) ;"Results: none "RTN","TMGNDF1F",82,0) "RTN","TMGNDF1F",83,0) new PreSelArray,JustSelected "RTN","TMGNDF1F",84,0) set JustSelected=0 "RTN","TMGNDF1F",85,0) "RTN","TMGNDF1F",86,0) write "Scanning for entries with no DOSE ROUTE...",! "RTN","TMGNDF1F",87,0) do GetFldVScreen^TMGSELED(22706.9,3,"$$ScrnTest^TMGNDF1F","PreSelArray") "RTN","TMGNDF1F",88,0) "RTN","TMGNDF1F",89,0) write "Show just those preselected? (Faster)" "RTN","TMGNDF1F",90,0) new % set %=1 do YN^DICN write ! "RTN","TMGNDF1F",91,0) if %=1 set JustSelected=1 "RTN","TMGNDF1F",92,0) else write "Now scanning for the rest of the entries...",! "RTN","TMGNDF1F",93,0) do SelEdRArray(.PreSelArray,JustSelected) "RTN","TMGNDF1F",94,0) "RTN","TMGNDF1F",95,0) do FindUnmatched "RTN","TMGNDF1F",96,0) quit "RTN","TMGNDF1F",97,0) "RTN","TMGNDF1F",98,0) "RTN","TMGNDF1F",99,0) ScrnTest() "RTN","TMGNDF1F",100,0) ;"Purpose: this is a callback function for GetFldVScreen^TMGSELED "RTN","TMGNDF1F",101,0) ;" Screen out if value is null (i.e. LOOK FOR MISSING VALUES), "RTN","TMGNDF1F",102,0) ;" or SKIP=true, "RTN","TMGNDF1F",103,0) ;"Input: None. But following global-scope variables will be available for use "RTN","TMGNDF1F",104,0) ;" File -- the File name or number "RTN","TMGNDF1F",105,0) ;" FieldNum -- the field number "RTN","TMGNDF1F",106,0) ;" IEN -- the IEN of the current record. "RTN","TMGNDF1F",107,0) ;" RecValue -- the current value of the field "RTN","TMGNDF1F",108,0) ;"Results: 1 if should be skipped, 0 if should be keps "RTN","TMGNDF1F",109,0) "RTN","TMGNDF1F",110,0) new result set result=1;" default to SKIP "RTN","TMGNDF1F",111,0) if RecValue'="" goto STDone ;"if not null, then skip "RTN","TMGNDF1F",112,0) ;"Now see if 22706.9 is marked for SKIP "RTN","TMGNDF1F",113,0) if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 goto STDone ;"1;4=SKIP field, 1=SKIP "RTN","TMGNDF1F",114,0) set result=0 ;"keep "RTN","TMGNDF1F",115,0) STDone "RTN","TMGNDF1F",116,0) quit result "RTN","TMGNDF1F",117,0) "RTN","TMGNDF1F",118,0) "RTN","TMGNDF1F",119,0) Scrn2Test() "RTN","TMGNDF1F",120,0) ;"Purpose: this is a callback function for GetFldVScreen^TMGSELED "RTN","TMGNDF1F",121,0) ;" Screen out if record in 22706.9=SKIP, "RTN","TMGNDF1F",122,0) ;"Input: None. But following global-scope variables will be available for use "RTN","TMGNDF1F",123,0) ;" File -- the File name or number "RTN","TMGNDF1F",124,0) ;" FieldNum -- the field number "RTN","TMGNDF1F",125,0) ;" IEN -- the IEN of the current record. "RTN","TMGNDF1F",126,0) ;" RecValue -- the current value of the field "RTN","TMGNDF1F",127,0) ;"Results: 1 if should be skipped, 0 if should be keps "RTN","TMGNDF1F",128,0) "RTN","TMGNDF1F",129,0) new result set result=1;" default to SKIP "RTN","TMGNDF1F",130,0) ;"Now see if matching record in 22706.9 is marked for SKIP "RTN","TMGNDF1F",131,0) if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 goto ST2Done ;"1;4=SKIP field, 1=SKIP "RTN","TMGNDF1F",132,0) if $data(^TMG(22706.9,IEN))=0 goto ST2Done ;"if null record (for some reason) "RTN","TMGNDF1F",133,0) set result=0 ;"keep "RTN","TMGNDF1F",134,0) ST2Done "RTN","TMGNDF1F",135,0) quit result "RTN","TMGNDF1F",136,0) "RTN","TMGNDF1F",137,0) "RTN","TMGNDF1F",138,0) "RTN","TMGNDF1F",139,0) SelEdRArray(SelArray,JustSelected) "RTN","TMGNDF1F",140,0) ;"Purpose: Fix missing or screen for Dose ROUTES from DRUG file "RTN","TMGNDF1F",141,0) ;"Input: SelList -- PASS BY REFERENCE. An OUT PARAMETER. Format "RTN","TMGNDF1F",142,0) ;" List(IEN)="" "RTN","TMGNDF1F",143,0) ;" List(IEN)="" <-- IEN in 50 that was selected. "RTN","TMGNDF1F",144,0) ;" Mode -- 0 for missing routes, or "ALL" for screening all "RTN","TMGNDF1F",145,0) ;"Results: none "RTN","TMGNDF1F",146,0) "RTN","TMGNDF1F",147,0) new Options,IEN "RTN","TMGNDF1F",148,0) set Options("FIELDS",1)=".05^TRADENAME^40" "RTN","TMGNDF1F",149,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1F",150,0) set Options("FIELDS",2)="3.4^FDA DOSAGE FORM^15" "RTN","TMGNDF1F",151,0) ;"set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1F",152,0) set Options("FIELDS",3)="3^FDA ROUTE^15" "RTN","TMGNDF1F",153,0) ;"set Options("FIELDS",4)="3.1^VA ROUTE^15" "RTN","TMGNDF1F",154,0) set Options("FIELDS","MAX NUM")=3 "RTN","TMGNDF1F",155,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF1F",156,0) ;"Get all records with SKIP THIS RECORD = 0 (KEEP) "RTN","TMGNDF1F",157,0) "RTN","TMGNDF1F",158,0) if +$get(JustSelected)=0 do "RTN","TMGNDF1F",159,0) . do GetFldVScreen^TMGSELED(22706.9,3,"$$Scrn2Test^TMGNDF1E",$name(Options("IEN LIST"))) "RTN","TMGNDF1F",160,0) else do "RTN","TMGNDF1F",161,0) . merge Options("IEN LIST")=SelArray "RTN","TMGNDF1F",162,0) . kill SelArray "RTN","TMGNDF1F",163,0) "RTN","TMGNDF1F",164,0) SE1 if $data(SelArray) do "RTN","TMGNDF1F",165,0) . set IEN="" "RTN","TMGNDF1F",166,0) . for set IEN=$order(SelArray(IEN)) quit:(IEN="") do "RTN","TMGNDF1F",167,0) . . if $data(Options("IEN LIST",IEN))>0 do "RTN","TMGNDF1F",168,0) . . . set Options("IEN LIST",IEN,"SEL")="" "RTN","TMGNDF1F",169,0) "RTN","TMGNDF1F",170,0) if $$SELED^TMGSELED(.Options)'=2 goto SERDone "RTN","TMGNDF1F",171,0) if $$GetIENs^TMGSELED(.Options)=0 goto SERDone "RTN","TMGNDF1F",172,0) goto SE1 "RTN","TMGNDF1F",173,0) "RTN","TMGNDF1F",174,0) SERDone quit "RTN","TMGNDF1F",175,0) "RTN","TMGNDF1F",176,0) "RTN","TMGNDF1F",177,0) "RTN","TMGNDF1F",178,0) ;"======================================================================= "RTN","TMGNDF1F",179,0) "RTN","TMGNDF1F",180,0) "RTN","TMGNDF1F",181,0) FindUnmatched "RTN","TMGNDF1F",182,0) ;"Purpose: Find new, unhandled, FDA dosage forms, and create a new record in "RTN","TMGNDF1F",183,0) ;" TMG NDF FORMS VISTA EQUIVALENTS "RTN","TMGNDF1F",184,0) "RTN","TMGNDF1F",185,0) new Array "RTN","TMGNDF1F",186,0) write !,"Checking compiled FDA import records for new FDA drug ROUTES...",! "RTN","TMGNDF1F",187,0) do GetFDARoute(.Array) "RTN","TMGNDF1F",188,0) do TrimFoundRoutes(.Array) "RTN","TMGNDF1F",189,0) if $data(Array) do "RTN","TMGNDF1F",190,0) . write $$ListCt^TMGMISC("Array")," new drug ROUTES found. Adding now...",! "RTN","TMGNDF1F",191,0) . do StubInNewRec(.Array) "RTN","TMGNDF1F",192,0) . do HandleLinks "RTN","TMGNDF1F",193,0) . write "Done.",! "RTN","TMGNDF1F",194,0) else do "RTN","TMGNDF1F",195,0) . write !,"No new FDA drug ROUTES found",! "RTN","TMGNDF1F",196,0) "RTN","TMGNDF1F",197,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1F",198,0) "RTN","TMGNDF1F",199,0) quit "RTN","TMGNDF1F",200,0) "RTN","TMGNDF1F",201,0) "RTN","TMGNDF1F",202,0) GetFDARoute(Array) "RTN","TMGNDF1F",203,0) ;"Purpose: to scan file 22706.9 (TMG FDA IMPORT COMPILED) and compile a list of all ROUTES "RTN","TMGNDF1F",204,0) ;"Input: Array -- PASS BY REFERENCE. An OUT PARAMETER. Prior entries will be killed "RTN","TMGNDF1F",205,0) ;"Results: Data passed back as follows: "RTN","TMGNDF1F",206,0) ;" Array(Route)="" "RTN","TMGNDF1F",207,0) ;" Array(Route)="" "RTN","TMGNDF1F",208,0) ;"Result: none. "RTN","TMGNDF1F",209,0) "RTN","TMGNDF1F",210,0) new Itr,IEN "RTN","TMGNDF1F",211,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1F",212,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1F",213,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF1F",214,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF1F",215,0) . new Route "RTN","TMGNDF1F",216,0) . set Route=$piece($get(^TMG(22706.9,IEN,0)),"^",5) "RTN","TMGNDF1F",217,0) . if Route="" quit "RTN","TMGNDF1F",218,0) . set Array(Route)=IEN "RTN","TMGNDF1F",219,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF1F",220,0) "RTN","TMGNDF1F",221,0) "RTN","TMGNDF1F",222,0) quit "RTN","TMGNDF1F",223,0) "RTN","TMGNDF1F",224,0) "RTN","TMGNDF1F",225,0) TrimFoundRoutes(Array) "RTN","TMGNDF1F",226,0) ;"Purpose: To remove entries from Array, for which mapping to a VistA equivilent "RTN","TMGNDF1F",227,0) ;" has already ben created "RTN","TMGNDF1F",228,0) ;"Input: Array -- PASS BY REFERENCE. Array as created by GetFDARoute "RTN","TMGNDF1F",229,0) new Form set Form="" "RTN","TMGNDF1F",230,0) for set Form=$order(Array(Form)) quit:(Form="") do "RTN","TMGNDF1F",231,0) . new shortForm set shortForm=$extract(Form,1,30) "RTN","TMGNDF1F",232,0) . if $order(^TMG(22706.82,"B",shortForm,""))'="" kill Array(Form) "RTN","TMGNDF1F",233,0) quit "RTN","TMGNDF1F",234,0) "RTN","TMGNDF1F",235,0) "RTN","TMGNDF1F",236,0) StubInNewRec(Array) "RTN","TMGNDF1F",237,0) ;"Purpose: To create new entries in 22706.8 for FDA forms not yet added. "RTN","TMGNDF1F",238,0) ;"Input: Array -- PASS BY REFERENCE. An array of Forms to be added, as created "RTN","TMGNDF1F",239,0) ;" by GetFDARoute. "RTN","TMGNDF1F",240,0) ;"NOTE: ALL entries in Array will be added as new records. Thus, screening for "RTN","TMGNDF1F",241,0) ;" prior entries must be performed, such as through TrimFoundRoutes() "RTN","TMGNDF1F",242,0) "RTN","TMGNDF1F",243,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF1F",244,0) new Form set Form="" "RTN","TMGNDF1F",245,0) for set Form=$order(Array(Form)) quit:(Form="") do "RTN","TMGNDF1F",246,0) . set TMGFDA(22706.82,"+1,",.01)=Form "RTN","TMGNDF1F",247,0) . kill TMGMSG,TMGIEN "RTN","TMGNDF1F",248,0) . do UPDATE^DIE("K","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF1F",249,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1F",250,0) quit "RTN","TMGNDF1F",251,0) "RTN","TMGNDF1F",252,0) "RTN","TMGNDF1F",253,0) "RTN","TMGNDF1F",254,0) DisplayRoutes(Answers) "RTN","TMGNDF1F",255,0) ;"Purpose: to display the list of Dosage forms that don't have a corresponding VA DOSE FORM "RTN","TMGNDF1F",256,0) ;"Input: Answers -- PASS BY REFERENCE, and OUT PARAMETER. Old values killed. "RTN","TMGNDF1F",257,0) ;"Output: Answers filled in as follows: "RTN","TMGNDF1F",258,0) ;" Answers(n)=RxRoute^IEN in 22706.82 "RTN","TMGNDF1F",259,0) ;" Answers(n)=RxRoute^IEN in 22706.82 "RTN","TMGNDF1F",260,0) ;"Results: None "RTN","TMGNDF1F",261,0) "RTN","TMGNDF1F",262,0) kill Answers "RTN","TMGNDF1F",263,0) new count set count=0 "RTN","TMGNDF1F",264,0) new Itr,IEN "RTN","TMGNDF1F",265,0) set IEN=$$ItrInit^TMGITR(22706.82,.Itr) "RTN","TMGNDF1F",266,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF1F",267,0) . new VARouteIEN set VARouteIEN=+$piece($get(^TMG(22706.82,IEN,0)),"^",2) "RTN","TMGNDF1F",268,0) . if VARouteIEN'=0 quit "RTN","TMGNDF1F",269,0) . new FDARoute set FDARoute=$piece($get(^TMG(22706.82,IEN,0)),"^",1) "RTN","TMGNDF1F",270,0) . set count=count+1 "RTN","TMGNDF1F",271,0) . write count,". ",FDARoute," --> ??",! "RTN","TMGNDF1F",272,0) . set Answers(count)=FDARoute_"^"_IEN "RTN","TMGNDF1F",273,0) if count=0 do "RTN","TMGNDF1F",274,0) . write " -- List is Empty --",! "RTN","TMGNDF1F",275,0) "RTN","TMGNDF1F",276,0) quit "RTN","TMGNDF1F",277,0) "RTN","TMGNDF1F",278,0) "RTN","TMGNDF1F",279,0) HandleLinks "RTN","TMGNDF1F",280,0) ;"Purpose: To interact with user and find a link between FDA dosage forms, and VA dosage forms "RTN","TMGNDF1F",281,0) ;"Input: none "RTN","TMGNDF1F",282,0) ;"Output: results are stored in 22706.8 "RTN","TMGNDF1F",283,0) ;"Results: none "RTN","TMGNDF1F",284,0) "RTN","TMGNDF1F",285,0) new Answers "RTN","TMGNDF1F",286,0) new done set done=0 "RTN","TMGNDF1F",287,0) new input set input="R" "RTN","TMGNDF1F",288,0) new LastNum "RTN","TMGNDF1F",289,0) new VAPIndex "RTN","TMGNDF1F",290,0) "RTN","TMGNDF1F",291,0) for do quit:(done=1) "RTN","TMGNDF1F",292,0) . if input="R" do "RTN","TMGNDF1F",293,0) . . write !! "RTN","TMGNDF1F",294,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF1F",295,0) . . write "Specify which Dosage ROUTE to Look up",! "RTN","TMGNDF1F",296,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF1F",297,0) . . do DisplayRoutes(.Answers) "RTN","TMGNDF1F",298,0) . . set LastNum=$order(Answers(""),-1) "RTN","TMGNDF1F",299,0) . . if LastNum="" set LastNum="^" "RTN","TMGNDF1F",300,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF1F",301,0) . . write "Specify which Dosage ROUTE to Look up",! "RTN","TMGNDF1F",302,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF1F",303,0) . write " R to refresh, E show Examples",! "RTN","TMGNDF1F",304,0) . write " ^ to continue",! "RTN","TMGNDF1F",305,0) . write "Enter number to Lookup (or codes listed above): ",LastNum,"//" "RTN","TMGNDF1F",306,0) . read input "RTN","TMGNDF1F",307,0) . if input="" set input=LastNum write LastNum "RTN","TMGNDF1F",308,0) . write ! "RTN","TMGNDF1F",309,0) . ;"if input="" set input="^" "RTN","TMGNDF1F",310,0) . if input="" set input=LastNum write LastNum "RTN","TMGNDF1F",311,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF1F",312,0) . if input="^" set done=1 "RTN","TMGNDF1F",313,0) . if +input=input do "RTN","TMGNDF1F",314,0) . . do DoLink(input,.Answers) "RTN","TMGNDF1F",315,0) . . set input="R" "RTN","TMGNDF1F",316,0) . if input="E" do "RTN","TMGNDF1F",317,0) . . write "...Enter number to show examples for: "_LastNum_"//" "RTN","TMGNDF1F",318,0) . . read input,! "RTN","TMGNDF1F",319,0) . . if input="" set input=LastNum "RTN","TMGNDF1F",320,0) . . do ShowExamples(+input,.Answers,.VAPIndex) "RTN","TMGNDF1F",321,0) . . set input="R" "RTN","TMGNDF1F",322,0) "RTN","TMGNDF1F",323,0) quit "RTN","TMGNDF1F",324,0) "RTN","TMGNDF1F",325,0) "RTN","TMGNDF1F",326,0) DoLink(InputNum,Answers) "RTN","TMGNDF1F",327,0) ;"Purpose: To try to establish a link between 1 FDA ROUTE and a VA ROUTE "RTN","TMGNDF1F",328,0) ;"Input: InputNum -- the number that the user chose to fix. "RTN","TMGNDF1F",329,0) ;" Answers -- PASS BY REFERENCE. Array as put out by DisplayRoutes "RTN","TMGNDF1F",330,0) ;"Output: if link is established then it will be store in 22706.8 "RTN","TMGNDF1F",331,0) ;"Results: none "RTN","TMGNDF1F",332,0) "RTN","TMGNDF1F",333,0) new RxRoute,IEN "RTN","TMGNDF1F",334,0) set RxRoute=$piece($get(Answers(InputNum)),"^",1) "RTN","TMGNDF1F",335,0) set IEN=$piece($get(Answers(InputNum)),"^",2) "RTN","TMGNDF1F",336,0) if RxRoute="" goto DLDone "RTN","TMGNDF1F",337,0) new done set done=0 "RTN","TMGNDF1F",338,0) "RTN","TMGNDF1F",339,0) new VistaIEN set VistaIEN=0 "RTN","TMGNDF1F",340,0) new DIC,X,Y "RTN","TMGNDF1F",341,0) set DIC=51.2 "RTN","TMGNDF1F",342,0) set X=RxRoute "RTN","TMGNDF1F",343,0) set DIC(0)="M" "RTN","TMGNDF1F",344,0) do ^DIC "RTN","TMGNDF1F",345,0) if +Y>0 do "RTN","TMGNDF1F",346,0) . write !,"Match automatically found...",! "RTN","TMGNDF1F",347,0) . write "Use '",$piece(Y,"^",2),"' for '",RxRoute,"'" "RTN","TMGNDF1F",348,0) . new % set %=1 do YN^DICN "RTN","TMGNDF1F",349,0) . if %'=1 quit "RTN","TMGNDF1F",350,0) . set VistaIEN=+Y "RTN","TMGNDF1F",351,0) if VistaIEN'=0 goto DL2 "RTN","TMGNDF1F",352,0) "RTN","TMGNDF1F",353,0) set DIC(0)="AEQML" "RTN","TMGNDF1F",354,0) set DIC("A")="Enter VA DOSE FORM name: // " "RTN","TMGNDF1F",355,0) write !,"Enter name to match '"_RxRoute_"'" "RTN","TMGNDF1F",356,0) do ^DIC write ! "RTN","TMGNDF1F",357,0) if +Y>0 do "RTN","TMGNDF1F",358,0) . write "Use '",$piece(Y,"^",2),"' for '",RxRoute,"'" "RTN","TMGNDF1F",359,0) . new % set %=1 do YN^DICN "RTN","TMGNDF1F",360,0) . if %'=1 quit "RTN","TMGNDF1F",361,0) . set VistaIEN=+Y "RTN","TMGNDF1F",362,0) "RTN","TMGNDF1F",363,0) DL2 if VistaIEN'=0 do "RTN","TMGNDF1F",364,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1F",365,0) . set TMGFDA(22706.82,IEN_",",1)=VistaIEN "RTN","TMGNDF1F",366,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1F",367,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1F",368,0) "RTN","TMGNDF1F",369,0) DLDone "RTN","TMGNDF1F",370,0) quit "RTN","TMGNDF1F",371,0) "RTN","TMGNDF1F",372,0) "RTN","TMGNDF1F",373,0) ShowExamples(InputNum,Answers,Index) "RTN","TMGNDF1F",374,0) ;"Purpose: To show all entries using dosage form specified "RTN","TMGNDF1F",375,0) ;"Input: InputNum -- the input number from user to show "RTN","TMGNDF1F",376,0) ;" Answers -- PASS BY REFERENCE, array as put out by DisplayForms "RTN","TMGNDF1F",377,0) ;" Index -- OPTIONAL. An index of VAProduct "RTN","TMGNDF1F",378,0) "RTN","TMGNDF1F",379,0) new RxRoute "RTN","TMGNDF1F",380,0) set RxRoute=$piece($get(Answers(InputNum)),"^",1) "RTN","TMGNDF1F",381,0) if RxRoute="" goto SEDone "RTN","TMGNDF1F",382,0) "RTN","TMGNDF1F",383,0) new count set count=0 "RTN","TMGNDF1F",384,0) new IEN set IEN=0 "RTN","TMGNDF1F",385,0) new abort set abort=0 "RTN","TMGNDF1F",386,0) for set IEN=$order(^TMG(22706.9,"ROUTE",RxRoute,IEN)) quit:(+IEN'>0)!abort do "RTN","TMGNDF1F",387,0) . write "#",IEN,": " "RTN","TMGNDF1F",388,0) . do DumpRec2^TMGDEBUG(22706.9,IEN_",") "RTN","TMGNDF1F",389,0) . set count=count+1 "RTN","TMGNDF1F",390,0) . write " -- Press ENTER to Continue (ESC to quit) --" "RTN","TMGNDF1F",391,0) . new ch set ch=$$KeyPressed^TMGUSRIF(0,60) "RTN","TMGNDF1F",392,0) . write ! "RTN","TMGNDF1F",393,0) . if ch=27 set abort=1 quit "RTN","TMGNDF1F",394,0) "RTN","TMGNDF1F",395,0) if count=0 do "RTN","TMGNDF1F",396,0) . write !,"Couldn't find any examples (error occurred).",! "RTN","TMGNDF1F",397,0) "RTN","TMGNDF1F",398,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1F",399,0) SEDone "RTN","TMGNDF1F",400,0) quit "RTN","TMGNDF1F",401,0) "RTN","TMGNDF1F",402,0) "RTN","TMGNDF1F",403,0) ;"======================================== "RTN","TMGNDF1F",404,0) EditVARoutes "RTN","TMGNDF1F",405,0) ;"Purpose: To edit Vista Routes file file 51.2 "RTN","TMGNDF1F",406,0) "RTN","TMGNDF1F",407,0) new Options,IEN "RTN","TMGNDF1F",408,0) set Options("FIELDS",1)=".01^NAME^30" "RTN","TMGNDF1F",409,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1F",410,0) set Options("FIELDS",2)="1^ABBREVIATION^15" "RTN","TMGNDF1F",411,0) set Options("FIELDS",3)="3^PACKAGE USE^10" "RTN","TMGNDF1F",412,0) set Options("FIELDS",4)="5^INACTIVATION DATE^10" "RTN","TMGNDF1F",413,0) set Options("FIELDS",5)="6^IV FLAG^5" "RTN","TMGNDF1F",414,0) set Options("FIELDS","MAX NUM")=5 "RTN","TMGNDF1F",415,0) set Options("FILE")="51.2^MEDICATION ROUTE" "RTN","TMGNDF1F",416,0) "RTN","TMGNDF1F",417,0) do GetFldValue^TMGSELED(51.2,.01,"ALL",$name(Options("IEN LIST"))) "RTN","TMGNDF1F",418,0) "RTN","TMGNDF1F",419,0) EF1 "RTN","TMGNDF1F",420,0) if $$SELED^TMGSELED(.Options)'=2 goto EFDone "RTN","TMGNDF1F",421,0) if $$GetIENs^TMGSELED(.Options)=0 goto EFDone "RTN","TMGNDF1F",422,0) goto EF1 "RTN","TMGNDF1F",423,0) "RTN","TMGNDF1F",424,0) EFDone quit "RTN","TMGNDF1F",425,0) "RTN","TMGNDF1F",426,0) ;"======================================== "RTN","TMGNDF1F",427,0) "RTN","TMGNDF1F",428,0) FillVARoute "RTN","TMGNDF1F",429,0) ;"Purpose: To ensure that there is a entry in the VA ROUTE field "RTN","TMGNDF1F",430,0) ;" in all records in TMG FDA IMPORT COMPILED "RTN","TMGNDF1F",431,0) ;" (that are not marked to be skipped) "RTN","TMGNDF1F",432,0) "RTN","TMGNDF1F",433,0) new Itr,IEN,abort,count,missingRoute "RTN","TMGNDF1F",434,0) set abort=0,count=0,missingRoute=0 "RTN","TMGNDF1F",435,0) "RTN","TMGNDF1F",436,0) write "Scanning through all imports and applying matches from ROUTE --> VA ROUTE...",! "RTN","TMGNDF1F",437,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF1F",438,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF1F",439,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF1F",440,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF1F",441,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF1F",442,0) . new FDARoute set FDARoute=$piece($get(^TMG(22706.9,IEN,0)),"^",5) "RTN","TMGNDF1F",443,0) . new VARouteIEN set VARouteIEN=+$piece($get(^TMG(22706.9,IEN,7)),"^",7) "RTN","TMGNDF1F",444,0) . if FDARoute="" do quit "RTN","TMGNDF1F",445,0) . . if VARouteIEN'=0 quit "RTN","TMGNDF1F",446,0) . . ;"write !,"No FDA drug ROUTE found for drug in record #",IEN,! "RTN","TMGNDF1F",447,0) . . set missingRoute=missingRoute+1 "RTN","TMGNDF1F",448,0) . new mapIEN set mapIEN=+$order(^TMG(22706.82,"B",$extract(FDARoute,1,30),"")) "RTN","TMGNDF1F",449,0) . new VistaIEN set VistaIEN=+$piece($get(^TMG(22706.82,mapIEN,0)),"^",2) "RTN","TMGNDF1F",450,0) . if (VARouteIEN=VistaIEN)&(VistaIEN'=0) quit ;"already set properly "RTN","TMGNDF1F",451,0) . if VistaIEN=0 do quit "RTN","TMGNDF1F",452,0) . . write !,"Mapping to VA ROUTE incomplete: ",FDARoute," --> ??. Edit Match File.",! "RTN","TMGNDF1F",453,0) . new TMGFDA,TMGMSG "RTN","TMGNDF1F",454,0) . set TMGFDA(22706.9,IEN_",",3.1)=VistaIEN "RTN","TMGNDF1F",455,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF1F",456,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF1F",457,0) . ;"write !,IEN," field 3.1 set to `",VistaIEN,! "RTN","TMGNDF1F",458,0) . set count=count+1 "RTN","TMGNDF1F",459,0) "RTN","TMGNDF1F",460,0) write !,count," records changed",! "RTN","TMGNDF1F",461,0) if missingRoute>0 write missingRoute," imports are missing a specified ROUTE",! "RTN","TMGNDF1F",462,0) do PressToCont^TMGUSRIF "RTN","TMGNDF1F",463,0) "RTN","TMGNDF1F",464,0) FRFDone "RTN","TMGNDF1F",465,0) quit "RTN","TMGNDF1F",466,0) "RTN","TMGNDF1F",467,0) ;"======================================== "RTN","TMGNDF1F",468,0) "RTN","TMGNDF1F",469,0) EditMatchFile "RTN","TMGNDF1F",470,0) ;"Purpose: use Selector to browse and edit TMG FDA ROUTE VISTA EQUIVALENTS (22706.82) "RTN","TMGNDF1F",471,0) "RTN","TMGNDF1F",472,0) new Options,IEN "RTN","TMGNDF1F",473,0) set Options("FIELDS",1)=".01^FDA ROUTE^25" "RTN","TMGNDF1F",474,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF1F",475,0) set Options("FIELDS",2)="1^VISTA ROUTE^25" "RTN","TMGNDF1F",476,0) set Options("FIELDS","MAX NUM")=2 "RTN","TMGNDF1F",477,0) set Options("FILE")="22706.82^TMG FDA ROUTES VISTA EQUIVALENTS" "RTN","TMGNDF1F",478,0) "RTN","TMGNDF1F",479,0) do GetFldValue^TMGSELED(22706.82,.01,"ALL",$name(Options("IEN LIST"))) "RTN","TMGNDF1F",480,0) "RTN","TMGNDF1F",481,0) SFM1 "RTN","TMGNDF1F",482,0) if $$SELED^TMGSELED(.Options)'=2 goto SFMDone "RTN","TMGNDF1F",483,0) if $$GetIENs^TMGSELED(.Options)=0 goto SFMDone "RTN","TMGNDF1F",484,0) goto SFM1 "RTN","TMGNDF1F",485,0) "RTN","TMGNDF1F",486,0) SFMDone quit "RTN","TMGNDF1F",487,0) "RTN","TMGNDF1F",488,0) "RTN","TMGNDF1F",489,0) "RTN","TMGNDF1F",490,0) "RTN","TMGNDF2A") 0^42^B7116 "RTN","TMGNDF2A",1,0) TMGNDF2A ;TMG/kst/FDA Import: Work with Drug Forms ;03/25/06 "RTN","TMGNDF2A",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF2A",3,0) "RTN","TMGNDF2A",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF2A",5,0) ;" -- Working with Dosage Forms "RTN","TMGNDF2A",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF2A",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF2A",8,0) ;"11-21-2006 "RTN","TMGNDF2A",9,0) "RTN","TMGNDF2A",10,0) ;"======================================================================= "RTN","TMGNDF2A",11,0) ;" API -- Public Functions. "RTN","TMGNDF2A",12,0) ;"======================================================================= "RTN","TMGNDF2A",13,0) ;"Menu "RTN","TMGNDF2A",14,0) "RTN","TMGNDF2A",15,0) ;"======================================================================= "RTN","TMGNDF2A",16,0) ;" Private Functions. "RTN","TMGNDF2A",17,0) ;"======================================================================= "RTN","TMGNDF2A",18,0) ;"FillRxFormRoute -- ensure that there is a dosage form in all records in TMG FDA IMPORT COMPILED "RTN","TMGNDF2A",19,0) ;" (that are not marked to be skipped) "RTN","TMGNDF2A",20,0) ;"GetRxForms(Array) -- scan file 22706.2 (TMG FDA DOSAGE FORMS) and compile a list of all dosage forms "RTN","TMGNDF2A",21,0) ;"DisplayForms(Answers) -- display the list of Dosage forms that don't have a corresponding VA DOSE FORM "RTN","TMGNDF2A",22,0) ;"HandleLinks -- interact with user and find a link between FDA dosage forms, and VA dosage forms "RTN","TMGNDF2A",23,0) ;"ShowHelp "RTN","TMGNDF2A",24,0) ;"DoLink(InputNum,Answers) -- try to establish a link between 1 FDA Dosage form and a VA DOSAGE form "RTN","TMGNDF2A",25,0) ;"Unlock50dot606 "RTN","TMGNDF2A",26,0) ;"Lock50dot606 "RTN","TMGNDF2A",27,0) ;"DoRemove(InputNum,Answers) -- remove an unwanted item from list. "RTN","TMGNDF2A",28,0) ;"ShowExamples(InputNum,Answers) -- show all entries using dosage form specified "RTN","TMGNDF2A",29,0) ;"FormatDrug(Array) "RTN","TMGNDF2A",30,0) ;"SelEditForms -- use the Selector to browse and edit the DOSAGE FORM "RTN","TMGNDF2A",31,0) "RTN","TMGNDF2A",32,0) "RTN","TMGNDF2A",33,0) ;"======================================================================= "RTN","TMGNDF2A",34,0) ;"======================================================================= "RTN","TMGNDF2A",35,0) "RTN","TMGNDF2A",36,0) Menu "RTN","TMGNDF2A",37,0) ;"Purpose: To give an interactive menu of tools to clean up data. "RTN","TMGNDF2A",38,0) "RTN","TMGNDF2A",39,0) new Menu,UsrSlct "RTN","TMGNDF2A",40,0) set Menu(0)="Pick Option for Managing Import Dosage FORMS (2A)" "RTN","TMGNDF2A",41,0) new i set i=1 "RTN","TMGNDF2A",42,0) set Menu(i)="Find new FDA dosage FORMS"_$char(9)_"FINDNEW" set i=i+1 "RTN","TMGNDF2A",43,0) set Menu(i)="Match import FORMS --> VA FORMS"_$char(9)_"MATCH" set i=i+1 "RTN","TMGNDF2A",44,0) set Menu(i)="Fix Tradenames with MISSING FORMS"_$char(9)_"FixTrade" set i=i+1 "RTN","TMGNDF2A",45,0) set Menu(i)="Screen ALL imports for INCORRECT FORM (IF NEEDED)"_$char(9)_"MANUAL" set i=i+1 "RTN","TMGNDF2A",46,0) set Menu(i)="Preselect missing and manually edit FORMS"_$char(9)_"MANUAL3" set i=i+1 "RTN","TMGNDF2A",47,0) set Menu(i)="Manually edit match file (IF NEEDED)"_$char(9)_"MANUAL2" set i=i+1 "RTN","TMGNDF2A",48,0) set Menu(i)="Edit VA forms (file 50.606) (ONLY IF NEEDED)"_$char(9)_"EDITVA" set i=i+1 "RTN","TMGNDF2A",49,0) set Menu(i)="USE links for import FORM --> VA FORM (DO THIS LAST)"_$char(9)_"FILL" set i=i+1 "RTN","TMGNDF2A",50,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF2A",51,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF2A",52,0) "RTN","TMGNDF2A",53,0) set Menu("?")="HELP"_$char(9)_"?" "RTN","TMGNDF2A",54,0) "RTN","TMGNDF2A",55,0) CD1 "RTN","TMGNDF2A",56,0) write # "RTN","TMGNDF2A",57,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF2A",58,0) if UsrSlct="^" goto CDDone "RTN","TMGNDF2A",59,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF2A",60,0) "RTN","TMGNDF2A",61,0) if UsrSlct="Prev" goto Menu^TMGNDF1F ;"quit can occur from there... "RTN","TMGNDF2A",62,0) if UsrSlct="Next" goto Menu^TMGNDF2C ;"quit can occur from there... "RTN","TMGNDF2A",63,0) if UsrSlct="FILL" do FillRxFormRoute goto CD1 "RTN","TMGNDF2A",64,0) if UsrSlct="FixTrade" do FixNoForm goto CD1 "RTN","TMGNDF2A",65,0) if UsrSlct="FINDNEW" do FindUnmatched goto CD1 "RTN","TMGNDF2A",66,0) if UsrSlct="MATCH" do HandleLinks goto CD1 "RTN","TMGNDF2A",67,0) if UsrSlct="MANUAL" do SelEditForms() goto CD1 "RTN","TMGNDF2A",68,0) if UsrSlct="MANUAL2" do SelFormMap goto CD1 "RTN","TMGNDF2A",69,0) if UsrSlct="MANUAL3" do SelMissing goto CD1 "RTN","TMGNDF2A",70,0) if UsrSlct="EDITVA" do EditForms goto CD1 "RTN","TMGNDF2A",71,0) if UsrSlct="?" do ShowHelp goto CD1 "RTN","TMGNDF2A",72,0) goto CD1 "RTN","TMGNDF2A",73,0) CDDone "RTN","TMGNDF2A",74,0) quit "RTN","TMGNDF2A",75,0) "RTN","TMGNDF2A",76,0) "RTN","TMGNDF2A",77,0) "RTN","TMGNDF2A",78,0) FillRxFormRoute "RTN","TMGNDF2A",79,0) ;"Purpose: To ensure that there is a dosage form and route "RTN","TMGNDF2A",80,0) ;" in all records in TMG FDA IMPORT COMPILED "RTN","TMGNDF2A",81,0) ;" (that are not marked to be skipped) "RTN","TMGNDF2A",82,0) "RTN","TMGNDF2A",83,0) new % set %=2 "RTN","TMGNDF2A",84,0) ;"write !,"Fill all TMG FDA IMPORT COMPILED records using current" "RTN","TMGNDF2A",85,0) ;"write "mapping FDA dosage forms <--> VA dosage forms" "RTN","TMGNDF2A",86,0) ;"do YN^DICN write ! "RTN","TMGNDF2A",87,0) ;"if %'=1 goto FRFDone "RTN","TMGNDF2A",88,0) "RTN","TMGNDF2A",89,0) new Itr,IEN,abort,count "RTN","TMGNDF2A",90,0) set abort=0,count=0 "RTN","TMGNDF2A",91,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2A",92,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2A",93,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF2A",94,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2A",95,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2A",96,0) . new currentIEN set currentIEN=+$piece($get(^TMG(22706.9,IEN,0)),"^",7) ;"0;7 = VA DOSAGE FORM, file 50.606 "RTN","TMGNDF2A",97,0) . new FDAForm set FDAForm=$piece($get(^TMG(22706.9,IEN,6)),"^",1) ;"text field "RTN","TMGNDF2A",98,0) . if FDAForm="" do quit "RTN","TMGNDF2A",99,0) . . if currentIEN'=0 quit "RTN","TMGNDF2A",100,0) . . write !,"No FDA dose form found for drug in record #",IEN,! "RTN","TMGNDF2A",101,0) . new mapIEN set mapIEN=+$order(^TMG(22706.8,"B",$extract(FDAForm,1,30),"")) "RTN","TMGNDF2A",102,0) . new VistaIEN set VistaIEN=+$piece($get(^TMG(22706.8,mapIEN,0)),"^",2) "RTN","TMGNDF2A",103,0) . if (currentIEN=VistaIEN)&(VistaIEN'=0) quit "RTN","TMGNDF2A",104,0) . if VistaIEN=0 do quit "RTN","TMGNDF2A",105,0) . . write !,"Mapping to VA FORM incomplete: ",FDAForm," --> ??. Edit Match File.",! "RTN","TMGNDF2A",106,0) . new VistaRouteIEN set VistaRouteIEN=+$piece($get(^TMG(22706.8,mapIEN,0)),"^",3) "RTN","TMGNDF2A",107,0) . if VistaIEN=0 do quit "RTN","TMGNDF2A",108,0) . . write !,"Mapping to VA ROUTE incomplete: ",FDAForm," --> ??. Edit Match File.",! "RTN","TMGNDF2A",109,0) . new TMGFDA,TMGMSG "RTN","TMGNDF2A",110,0) . set TMGFDA(22706.9,IEN_",",3.5)=VistaIEN "RTN","TMGNDF2A",111,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2A",112,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",113,0) . ;"write !,IEN," field 3.5 set to `",VistaIEN,! "RTN","TMGNDF2A",114,0) . set count=count+1 "RTN","TMGNDF2A",115,0) "RTN","TMGNDF2A",116,0) write !,count," records changed",! "RTN","TMGNDF2A",117,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2A",118,0) "RTN","TMGNDF2A",119,0) FRFDone "RTN","TMGNDF2A",120,0) quit "RTN","TMGNDF2A",121,0) "RTN","TMGNDF2A",122,0) "RTN","TMGNDF2A",123,0) FindUnmatched "RTN","TMGNDF2A",124,0) ;"Purpose: Find new, unhandled, FDA dosage forms, and create a new record in "RTN","TMGNDF2A",125,0) ;" TMG NDF FORMS VISTA EQUIVALENTS "RTN","TMGNDF2A",126,0) "RTN","TMGNDF2A",127,0) new Array "RTN","TMGNDF2A",128,0) write !,"Checking compiled FDA import records for new FDA drug FORMS...",! "RTN","TMGNDF2A",129,0) do GetFDARxForms(.Array) "RTN","TMGNDF2A",130,0) do TrimFoundForms(.Array) "RTN","TMGNDF2A",131,0) if $data(Array) do "RTN","TMGNDF2A",132,0) . do StubInNewRec(.Array) "RTN","TMGNDF2A",133,0) . do HandleLinks "RTN","TMGNDF2A",134,0) else do "RTN","TMGNDF2A",135,0) . write !,"No new FDA drug FORMS found",! "RTN","TMGNDF2A",136,0) "RTN","TMGNDF2A",137,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2A",138,0) "RTN","TMGNDF2A",139,0) quit "RTN","TMGNDF2A",140,0) "RTN","TMGNDF2A",141,0) "RTN","TMGNDF2A",142,0) GetFDARxForms(Array) "RTN","TMGNDF2A",143,0) ;"Purpose: to scan file 22706.9 (TMG FDA IMPORT COMPILED) and compile a list of all dosage forms "RTN","TMGNDF2A",144,0) ;"Input: Array -- PASS BY REFERENCE. An OUT PARAMETER. Prior entries will be killed "RTN","TMGNDF2A",145,0) ;"Results: Data passed back as follows: "RTN","TMGNDF2A",146,0) ;" Array(DosageForm)="" "RTN","TMGNDF2A",147,0) ;" Array(DosageForm)="" "RTN","TMGNDF2A",148,0) ;"Result: none. "RTN","TMGNDF2A",149,0) "RTN","TMGNDF2A",150,0) new Itr,IEN "RTN","TMGNDF2A",151,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2A",152,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2A",153,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2A",154,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2A",155,0) . new DosageForm "RTN","TMGNDF2A",156,0) . set DosageForm=$piece($get(^TMG(22706.9,IEN,6)),"^",1) "RTN","TMGNDF2A",157,0) . if DosageForm="" quit "RTN","TMGNDF2A",158,0) . set Array(DosageForm)=IEN "RTN","TMGNDF2A",159,0) "RTN","TMGNDF2A",160,0) quit "RTN","TMGNDF2A",161,0) "RTN","TMGNDF2A",162,0) "RTN","TMGNDF2A",163,0) TrimFoundForms(Array) "RTN","TMGNDF2A",164,0) ;"Purpose: To remove entries from Array, for which mapping to a VistA equivilent "RTN","TMGNDF2A",165,0) ;" has already ben created "RTN","TMGNDF2A",166,0) ;"Input: Array -- PASS BY REFERENCE. Array as created by GetFDARxForms "RTN","TMGNDF2A",167,0) new Form set Form="" "RTN","TMGNDF2A",168,0) for set Form=$order(Array(Form)) quit:(Form="") do "RTN","TMGNDF2A",169,0) . new shortForm set shortForm=$extract(Form,1,30) "RTN","TMGNDF2A",170,0) . if $order(^TMG(22706.8,"B",shortForm,""))'="" kill Array(Form) "RTN","TMGNDF2A",171,0) quit "RTN","TMGNDF2A",172,0) "RTN","TMGNDF2A",173,0) "RTN","TMGNDF2A",174,0) StubInNewRec(Array) "RTN","TMGNDF2A",175,0) ;"Purpose: To create new entries in 22706.8 for FDA forms not yet added. "RTN","TMGNDF2A",176,0) ;"Input: Array -- PASS BY REFERENCE. An array of Forms to be added, as created "RTN","TMGNDF2A",177,0) ;" by GetFDARxForms. "RTN","TMGNDF2A",178,0) ;"NOTE: ALL entries in Array will be added as new records. Thus, screening for "RTN","TMGNDF2A",179,0) ;" prior entries must be performed, such as through TrimFoundForms() "RTN","TMGNDF2A",180,0) "RTN","TMGNDF2A",181,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF2A",182,0) new Form set Form="" "RTN","TMGNDF2A",183,0) for set Form=$order(Array(Form)) quit:(Form="") do "RTN","TMGNDF2A",184,0) . set TMGFDA(22706.8,"+1,",.01)=Form "RTN","TMGNDF2A",185,0) . kill TMGMSG,TMGIEN "RTN","TMGNDF2A",186,0) . do UPDATE^DIE("K","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2A",187,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",188,0) quit "RTN","TMGNDF2A",189,0) "RTN","TMGNDF2A",190,0) "RTN","TMGNDF2A",191,0) "RTN","TMGNDF2A",192,0) DisplayForms(Answers) "RTN","TMGNDF2A",193,0) ;"Purpose: to display the list of Dosage forms that don't have a corresponding VA DOSE FORM "RTN","TMGNDF2A",194,0) ;"Input: Answers -- PASS BY REFERENCE, and OUT PARAMETER. Old values killed. "RTN","TMGNDF2A",195,0) ;"Output: Answers filled in as follows: "RTN","TMGNDF2A",196,0) ;" Answers(n)=DosageForm^IEN in 22706.8 "RTN","TMGNDF2A",197,0) ;" Answers(n)=DosageForm^IEN in 22706.8 "RTN","TMGNDF2A",198,0) ;"Results: None "RTN","TMGNDF2A",199,0) "RTN","TMGNDF2A",200,0) kill Answers "RTN","TMGNDF2A",201,0) new count set count=0 "RTN","TMGNDF2A",202,0) new Itr,IEN "RTN","TMGNDF2A",203,0) set IEN=$$ItrInit^TMGITR(22706.8,.Itr) "RTN","TMGNDF2A",204,0) ;"do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2A",205,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2A",206,0) . new VADoseFormIEN set VADoseFormIEN=+$piece($get(^TMG(22706.8,IEN,0)),"^",2) "RTN","TMGNDF2A",207,0) . if VADoseFormIEN'=0 quit "RTN","TMGNDF2A",208,0) . new DoseForm set DoseForm=$piece($get(^TMG(22706.8,IEN,0)),"^",1) "RTN","TMGNDF2A",209,0) . set count=count+1 "RTN","TMGNDF2A",210,0) . write count,". ",DoseForm," --> ??",! "RTN","TMGNDF2A",211,0) . set Answers(count)=DoseForm_"^"_IEN "RTN","TMGNDF2A",212,0) if count=0 do "RTN","TMGNDF2A",213,0) . write " -- List is Empty --",! "RTN","TMGNDF2A",214,0) "RTN","TMGNDF2A",215,0) quit "RTN","TMGNDF2A",216,0) "RTN","TMGNDF2A",217,0) "RTN","TMGNDF2A",218,0) HandleLinks "RTN","TMGNDF2A",219,0) ;"Purpose: To interact with user and find a link between FDA dosage forms, and VA dosage forms "RTN","TMGNDF2A",220,0) ;"Input: none "RTN","TMGNDF2A",221,0) ;"Output: results are stored in 22706.8 "RTN","TMGNDF2A",222,0) ;"Results: none "RTN","TMGNDF2A",223,0) "RTN","TMGNDF2A",224,0) new Answers "RTN","TMGNDF2A",225,0) new done set done=0 "RTN","TMGNDF2A",226,0) new input set input="R" "RTN","TMGNDF2A",227,0) do Unlock50dot606 "RTN","TMGNDF2A",228,0) new LastNum "RTN","TMGNDF2A",229,0) new VAPIndex "RTN","TMGNDF2A",230,0) "RTN","TMGNDF2A",231,0) for do quit:(done=1) "RTN","TMGNDF2A",232,0) . if input="R" do "RTN","TMGNDF2A",233,0) . . write !! "RTN","TMGNDF2A",234,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",235,0) . . write "Specify which Dosage form to Look up",! "RTN","TMGNDF2A",236,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",237,0) . . do DisplayForms(.Answers) "RTN","TMGNDF2A",238,0) . . set LastNum=$order(Answers(""),-1) "RTN","TMGNDF2A",239,0) . . if LastNum="" set LastNum="^" "RTN","TMGNDF2A",240,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",241,0) . . write "Specify which Dosage form to Look up",! "RTN","TMGNDF2A",242,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",243,0) . write " R to refresh, ? for instructions, E show Examples",! "RTN","TMGNDF2A",244,0) . write " ^ to continue",! "RTN","TMGNDF2A",245,0) . write "Enter number to Lookup (or codes listed above): ",LastNum,"//" "RTN","TMGNDF2A",246,0) . read input "RTN","TMGNDF2A",247,0) . if input="" set input=LastNum write LastNum "RTN","TMGNDF2A",248,0) . write ! "RTN","TMGNDF2A",249,0) . ;"if input="" set input="^" "RTN","TMGNDF2A",250,0) . if input="" set input=LastNum write LastNum "RTN","TMGNDF2A",251,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF2A",252,0) . if input="^" set done=1 "RTN","TMGNDF2A",253,0) . if (input="?") do "RTN","TMGNDF2A",254,0) . . do ShowHelp,ShowHlp2 "RTN","TMGNDF2A",255,0) . . set input="R" "RTN","TMGNDF2A",256,0) . if +input=input do "RTN","TMGNDF2A",257,0) . . do DoLink(input,.Answers) "RTN","TMGNDF2A",258,0) . . set input="R" "RTN","TMGNDF2A",259,0) . if input="E" do "RTN","TMGNDF2A",260,0) . . read "...Enter number to show examples for: ",input,! "RTN","TMGNDF2A",261,0) . . do ShowExamples(+input,.Answers,.VAPIndex) "RTN","TMGNDF2A",262,0) . . set input="R" "RTN","TMGNDF2A",263,0) "RTN","TMGNDF2A",264,0) do Lock50dot606 "RTN","TMGNDF2A",265,0) quit "RTN","TMGNDF2A",266,0) "RTN","TMGNDF2A",267,0) "RTN","TMGNDF2A",268,0) ShowHelp "RTN","TMGNDF2A",269,0) ;"Purpose: to write out instructions "RTN","TMGNDF2A",270,0) "RTN","TMGNDF2A",271,0) write #,! "RTN","TMGNDF2A",272,0) write "Drugs in the FDA database have drug 'forms', such as 'TABLET', 'CAPSULE' etc.",! "RTN","TMGNDF2A",273,0) write "In the VistA database, drugs also will have a drug form specified. However",! "RTN","TMGNDF2A",274,0) write "the classification systems don't exctly match. Sometimes the difference",! "RTN","TMGNDF2A",275,0) write "is just a matter of formatting, e.g. INJ,SUSP <--> INJECTION FOR SUSPENSION.",! "RTN","TMGNDF2A",276,0) write "But other times the exact concepts are different. For example, when the FDA",! "RTN","TMGNDF2A",277,0) write "data specified: 'CAPSULE, DELAYED RELEASE PELLETS', I could not find an exact",! "RTN","TMGNDF2A",278,0) write "match, and chose: 'CAP,SPRINKLE,SA'. A appropriately trained person should",! "RTN","TMGNDF2A",279,0) write "make such determinations.",! "RTN","TMGNDF2A",280,0) write ! "RTN","TMGNDF2A",281,0) write "This program does allow additions of NEW drug forms to the VistA database.",! "RTN","TMGNDF2A",282,0) write "However, this may be against VA policy and should be done only if no possible",! "RTN","TMGNDF2A",283,0) write "match can be found. Also, if a new drug form is added, this new entry in file",! "RTN","TMGNDF2A",284,0) write "DOSAGE FORM (50.606) should be completed via a Fileman edit to fill in all",! "RTN","TMGNDF2A",285,0) write "other fields such as VERB, NOUN etc. for the new dosage form.",! "RTN","TMGNDF2A",286,0) write ! "RTN","TMGNDF2A",287,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2A",288,0) quit "RTN","TMGNDF2A",289,0) "RTN","TMGNDF2A",290,0) ShowHlp2 "RTN","TMGNDF2A",291,0) write #,! "RTN","TMGNDF2A",292,0) write "To link a FDA drug form to a VA drug form, enter its number, then type in a",! "RTN","TMGNDF2A",293,0) write "name to search for in the VistA database. It is best to only type in PART of",! "RTN","TMGNDF2A",294,0) write "the name. For example, 'CAP' instead of 'CAPSULE'.",! "RTN","TMGNDF2A",295,0) write ! "RTN","TMGNDF2A",296,0) write "To see examples of drugs that use a particular drug form, enter 'E'.",! "RTN","TMGNDF2A",297,0) write ! "RTN","TMGNDF2A",298,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2A",299,0) quit "RTN","TMGNDF2A",300,0) "RTN","TMGNDF2A",301,0) DoLink(InputNum,Answers) "RTN","TMGNDF2A",302,0) ;"Purpose: To try to establish a link between 1 FDA Dosage form and a VA DOSAGE form "RTN","TMGNDF2A",303,0) ;"Input: InputNum -- the number that the user chose to fix. "RTN","TMGNDF2A",304,0) ;" Answers -- PASS BY REFERENCE. Array as put out by DisplayForms "RTN","TMGNDF2A",305,0) ;"Output: if link is established then it will be store in 22706.8 "RTN","TMGNDF2A",306,0) ;"Results: none "RTN","TMGNDF2A",307,0) "RTN","TMGNDF2A",308,0) new DosageForm,IEN "RTN","TMGNDF2A",309,0) set DosageForm=$piece($get(Answers(InputNum)),"^",1) "RTN","TMGNDF2A",310,0) set IEN=$piece($get(Answers(InputNum)),"^",2) "RTN","TMGNDF2A",311,0) if DosageForm="" goto DLDone "RTN","TMGNDF2A",312,0) new done set done=0 "RTN","TMGNDF2A",313,0) "RTN","TMGNDF2A",314,0) new VistaIEN set VistaIEN=0 "RTN","TMGNDF2A",315,0) new DIC,X,Y "RTN","TMGNDF2A",316,0) set DIC=50.606 "RTN","TMGNDF2A",317,0) set X=DosageForm "RTN","TMGNDF2A",318,0) set DIC(0)="M" "RTN","TMGNDF2A",319,0) do ^DIC "RTN","TMGNDF2A",320,0) if +Y>0 do "RTN","TMGNDF2A",321,0) . write !,"Match automatically found...",! "RTN","TMGNDF2A",322,0) . write "Use '",$piece(Y,"^",2),"' for '",DosageForm,"'" "RTN","TMGNDF2A",323,0) . new % set %=1 do YN^DICN "RTN","TMGNDF2A",324,0) . if %'=1 quit "RTN","TMGNDF2A",325,0) . set VistaIEN=+Y "RTN","TMGNDF2A",326,0) if VistaIEN'=0 goto DL2 "RTN","TMGNDF2A",327,0) "RTN","TMGNDF2A",328,0) set DIC(0)="AEQML" "RTN","TMGNDF2A",329,0) set DIC("A")="Enter VA DOSE FORM name: // " "RTN","TMGNDF2A",330,0) write !,"Enter name to match '"_DosageForm_"'" "RTN","TMGNDF2A",331,0) do ^DIC write ! "RTN","TMGNDF2A",332,0) if +Y>0 do "RTN","TMGNDF2A",333,0) . write "Use '",$piece(Y,"^",2),"' for '",DosageForm,"'" "RTN","TMGNDF2A",334,0) . new % set %=1 do YN^DICN "RTN","TMGNDF2A",335,0) . if %'=1 quit "RTN","TMGNDF2A",336,0) . set VistaIEN=+Y "RTN","TMGNDF2A",337,0) "RTN","TMGNDF2A",338,0) DL2 if VistaIEN'=0 do "RTN","TMGNDF2A",339,0) . new TMGFDA,TMGMSG "RTN","TMGNDF2A",340,0) . set TMGFDA(22706.8,IEN_",",1)=VistaIEN "RTN","TMGNDF2A",341,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2A",342,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",343,0) "RTN","TMGNDF2A",344,0) DLDone "RTN","TMGNDF2A",345,0) quit "RTN","TMGNDF2A",346,0) "RTN","TMGNDF2A",347,0) "RTN","TMGNDF2A",348,0) Unlock50dot606 "RTN","TMGNDF2A",349,0) ;"Purpose: to enable addition of dosage form to file DOSAGE FORM "RTN","TMGNDF2A",350,0) set $piece(^DD(50.606,.01,0),"^",5)="K:$L(X)>30!($L(X)<3) X" "RTN","TMGNDF2A",351,0) kill ^DD(50.606,.01,"LAYGO",.01,0) "RTN","TMGNDF2A",352,0) "RTN","TMGNDF2A",353,0) quit "RTN","TMGNDF2A",354,0) "RTN","TMGNDF2A",355,0) Lock50dot606 "RTN","TMGNDF2A",356,0) ;"NOTE: could just set XPDGREF=1 and not change this.... "RTN","TMGNDF2A",357,0) "RTN","TMGNDF2A",358,0) ;"Purpose: to restore locks on file DOSAGE FORM "RTN","TMGNDF2A",359,0) set $piece(^DD(50.606,.01,0),"^",5)="K:$L(X)>30!($L(X)<3)!'(X'?1P.E)!(X'?.ANP) X" "RTN","TMGNDF2A",360,0) set ^DD(50.606,.01,"LAYGO",.01,0)="D:'$D(XPDGREF) EN^DDIOL(""ADDITIONS ARE NOT ALLOWED"") I $D(XPDGREF)" "RTN","TMGNDF2A",361,0) quit "RTN","TMGNDF2A",362,0) "RTN","TMGNDF2A",363,0) "RTN","TMGNDF2A",364,0) ShowExamples(InputNum,Answers,Index) "RTN","TMGNDF2A",365,0) ;"Purpose: To show all entries using dosage form specified "RTN","TMGNDF2A",366,0) ;"Input: InputNum -- the input number from user to show "RTN","TMGNDF2A",367,0) ;" Answers -- PASS BY REFERENCE, array as put out by DisplayForms "RTN","TMGNDF2A",368,0) ;" Index -- OPTIONAL. An index of VAProduct "RTN","TMGNDF2A",369,0) "RTN","TMGNDF2A",370,0) new DosageForm "RTN","TMGNDF2A",371,0) set DosageForm=$piece($get(Answers(InputNum)),"^",1) "RTN","TMGNDF2A",372,0) if DosageForm="" goto SEDone "RTN","TMGNDF2A",373,0) "RTN","TMGNDF2A",374,0) if $data(Index)=0 do "RTN","TMGNDF2A",375,0) . do IndexVAProd^TMGNDF1C("Index") "RTN","TMGNDF2A",376,0) "RTN","TMGNDF2A",377,0) new count set count=0 "RTN","TMGNDF2A",378,0) new IEN set IEN=0 "RTN","TMGNDF2A",379,0) for do quit:(+IEN'>0) "RTN","TMGNDF2A",380,0) . set IEN=$order(^TMG(22706.2,"C",DosageForm,IEN)) "RTN","TMGNDF2A",381,0) . if +IEN'>0 quit "RTN","TMGNDF2A",382,0) . new Array,result,ListingIEN,CompIEN "RTN","TMGNDF2A",383,0) . set ListingIEN=$piece($get(^TMG(22706.2,IEN,0)),"^",1) "RTN","TMGNDF2A",384,0) . set CompIEN=$piece($get(^TMG(22706.5,ListingIEN,0)),"^",9) "RTN","TMGNDF2A",385,0) . if +CompIEN>0,$piece($get(^TMG(22706.9,CompIEN,1)),"^",4)=1 quit ;"check if skip field true "RTN","TMGNDF2A",386,0) . set result=$$GetDrugInfo^TMGNDF1C(ListingIEN,.Array,"Index") "RTN","TMGNDF2A",387,0) . if result do "RTN","TMGNDF2A",388,0) . . write "#",IEN,": " "RTN","TMGNDF2A",389,0) . . do FormatDrug(.Array) "RTN","TMGNDF2A",390,0) . . set count=count+1 "RTN","TMGNDF2A",391,0) . . if count>10 do "RTN","TMGNDF2A",392,0) . . . new input "RTN","TMGNDF2A",393,0) . . . read "Press ENTER to continue (^ to quit)",input:$get(DTIME,3600),! "RTN","TMGNDF2A",394,0) . . . if input="^" set IEN=0 "RTN","TMGNDF2A",395,0) . . . set count=0 "RTN","TMGNDF2A",396,0) . else do "RTN","TMGNDF2A",397,0) . . ;"write !,"Couldn't find any examples (error occurred).",! "RTN","TMGNDF2A",398,0) "RTN","TMGNDF2A",399,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2A",400,0) SEDone "RTN","TMGNDF2A",401,0) quit "RTN","TMGNDF2A",402,0) "RTN","TMGNDF2A",403,0) "RTN","TMGNDF2A",404,0) FormatDrug(Array) "RTN","TMGNDF2A",405,0) "RTN","TMGNDF2A",406,0) new s "RTN","TMGNDF2A",407,0) if '$data(Array) quit "RTN","TMGNDF2A",408,0) new i "RTN","TMGNDF2A",409,0) "RTN","TMGNDF2A",410,0) set s=$get(Array("TRADENAME"))_" " "RTN","TMGNDF2A",411,0) set s=s_$get(Array("STRENGTH"))_" " "RTN","TMGNDF2A",412,0) set s=s_$get(Array("UNIT"))_" " "RTN","TMGNDF2A",413,0) set i=$order(Array("DOSE","")) "RTN","TMGNDF2A",414,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF2A",415,0) . set s=s_$get(Array("DOSE",i,"DOSAGE NAME"))_" " "RTN","TMGNDF2A",416,0) . set i=$order(Array("DOSE",i)) "RTN","TMGNDF2A",417,0) "RTN","TMGNDF2A",418,0) write $extract(s,1,60),! "RTN","TMGNDF2A",419,0) "RTN","TMGNDF2A",420,0) quit "RTN","TMGNDF2A",421,0) "RTN","TMGNDF2A",422,0) "RTN","TMGNDF2A",423,0) ;"======================================== "RTN","TMGNDF2A",424,0) SelEditForms(SelArray,JustSelected) "RTN","TMGNDF2A",425,0) ;"Purpose: to use the Selector to browse and edit the TMG FDA IMPORT COMPILED, "RTN","TMGNDF2A",426,0) ;" specifically fields 3.4 (FDA DOSAGE FORM) and 3.5 (DOSAGE FORM) "RTN","TMGNDF2A",427,0) ;"Input: SelArray: Optional. PASS BY REFERENCE. An array of preselected IEN's "RTN","TMGNDF2A",428,0) ;" Format: SelArray(IEN in 22706.9)="" <-- IEN preselected "RTN","TMGNDF2A",429,0) ;" JustSelected: Optional. if 1, then ONLY IENs from SelArray shown. "RTN","TMGNDF2A",430,0) ;"Output: User may alter the value of SKIP THIS RECORD field for all records "RTN","TMGNDF2A",431,0) ;"Results: none "RTN","TMGNDF2A",432,0) "RTN","TMGNDF2A",433,0) new Options,IEN "RTN","TMGNDF2A",434,0) set Options("FIELDS",1)=".05^TRADENAME^30" "RTN","TMGNDF2A",435,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF2A",436,0) set Options("FIELDS",2)="2^UNIT^9" "RTN","TMGNDF2A",437,0) if +$get(editUnit)=0 set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF2A",438,0) set Options("FIELDS",3)="3.4^FDA DOSAGE FORM^20" "RTN","TMGNDF2A",439,0) set Options("FIELDS",4)="3.5^DOSAGE FORM^21" "RTN","TMGNDF2A",440,0) set Options("FIELDS","MAX NUM")=4 "RTN","TMGNDF2A",441,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF2A",442,0) "RTN","TMGNDF2A",443,0) if +$get(JustSelected)=0 do "RTN","TMGNDF2A",444,0) . ;"Get all records with SKIP THIS RECORD = 0 (KEEP) "RTN","TMGNDF2A",445,0) . do GetFldValue^TMGSELED(22706.9,6,0,$name(Options("IEN LIST"))) "RTN","TMGNDF2A",446,0) else do "RTN","TMGNDF2A",447,0) . merge Options("IEN LIST")=SelArray "RTN","TMGNDF2A",448,0) "RTN","TMGNDF2A",449,0) SE1 if $data(SelArray) do "RTN","TMGNDF2A",450,0) . set IEN="" "RTN","TMGNDF2A",451,0) . for set IEN=$order(SelArray(IEN)) quit:(IEN="") do "RTN","TMGNDF2A",452,0) . . if $data(Options("IEN LIST",IEN))>0 do "RTN","TMGNDF2A",453,0) . . . set Options("IEN LIST",IEN,"SEL")="" "RTN","TMGNDF2A",454,0) "RTN","TMGNDF2A",455,0) if $$SELED^TMGSELED(.Options)'=2 goto SEKDone "RTN","TMGNDF2A",456,0) if $$GetIENs^TMGSELED(.Options)=0 goto SEKDone "RTN","TMGNDF2A",457,0) goto SE1 "RTN","TMGNDF2A",458,0) "RTN","TMGNDF2A",459,0) SEKDone quit "RTN","TMGNDF2A",460,0) "RTN","TMGNDF2A",461,0) "RTN","TMGNDF2A",462,0) SelFormMap "RTN","TMGNDF2A",463,0) ;"Purpose: use Selector to browse and edit TMG FDA FORMS VISTA EQUIVALENTS "RTN","TMGNDF2A",464,0) "RTN","TMGNDF2A",465,0) new Options,IEN "RTN","TMGNDF2A",466,0) set Options("FIELDS",1)=".01^FDA FORM^35" "RTN","TMGNDF2A",467,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF2A",468,0) set Options("FIELDS",2)="1^VISTA FORM^25" "RTN","TMGNDF2A",469,0) ;"set Options("FIELDS",3)="2^VISTA ROUTE^20" "RTN","TMGNDF2A",470,0) ;"set Options("FIELDS","MAX NUM")=3 "RTN","TMGNDF2A",471,0) set Options("FIELDS","MAX NUM")=2 "RTN","TMGNDF2A",472,0) set Options("FILE")="22706.8^TMG FDA FORMS VISTA EQUIVALENTS" "RTN","TMGNDF2A",473,0) "RTN","TMGNDF2A",474,0) do GetFldValue^TMGSELED(22706.8,.01,"ALL",$name(Options("IEN LIST"))) "RTN","TMGNDF2A",475,0) "RTN","TMGNDF2A",476,0) SFM1 "RTN","TMGNDF2A",477,0) if $$SELED^TMGSELED(.Options)'=2 goto SFMDone "RTN","TMGNDF2A",478,0) if $$GetIENs^TMGSELED(.Options)=0 goto SFMDone "RTN","TMGNDF2A",479,0) goto SFM1 "RTN","TMGNDF2A",480,0) "RTN","TMGNDF2A",481,0) SFMDone quit "RTN","TMGNDF2A",482,0) "RTN","TMGNDF2A",483,0) "RTN","TMGNDF2A",484,0) SelMissing "RTN","TMGNDF2A",485,0) ;"Purpose: To preselect those entries with a missing VISTA FORMS "RTN","TMGNDF2A",486,0) "RTN","TMGNDF2A",487,0) new PreSelArray "RTN","TMGNDF2A",488,0) "RTN","TMGNDF2A",489,0) write "Scanning for entries with no VA FORM...",! "RTN","TMGNDF2A",490,0) do GetFldValue^TMGSELED(22706.9,3.5,"@","PreSelArray") "RTN","TMGNDF2A",491,0) write "Now scanning for the rest of the entries (ignoring skips)...",! "RTN","TMGNDF2A",492,0) do SelEditForms(.PreSelArray) "RTN","TMGNDF2A",493,0) "RTN","TMGNDF2A",494,0) quit "RTN","TMGNDF2A",495,0) "RTN","TMGNDF2A",496,0) EditForms "RTN","TMGNDF2A",497,0) ;"Purpose: To edit Vista drug forms in file 50.606 "RTN","TMGNDF2A",498,0) "RTN","TMGNDF2A",499,0) new Options,IEN "RTN","TMGNDF2A",500,0) set Options("FIELDS",1)=".01^NAME^17" "RTN","TMGNDF2A",501,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF2A",502,0) set Options("FIELDS",2)="3^VERB^8" "RTN","TMGNDF2A",503,0) set Options("FIELDS",3)="5^PEPOSITION^12" "RTN","TMGNDF2A",504,0) set Options("FIELDS",4)="10^CONJUNCTION^12" "RTN","TMGNDF2A",505,0) set Options("FIELDS",5)="22706.8^DIVIDABLE^10" "RTN","TMGNDF2A",506,0) set Options("FIELDS","MAX NUM")=5 "RTN","TMGNDF2A",507,0) set Options("FILE")="50.606^DOSAGE FORM" "RTN","TMGNDF2A",508,0) "RTN","TMGNDF2A",509,0) do GetFldValue^TMGSELED(50.606,.01,"ALL",$name(Options("IEN LIST"))) "RTN","TMGNDF2A",510,0) "RTN","TMGNDF2A",511,0) EF1 "RTN","TMGNDF2A",512,0) if $$SELED^TMGSELED(.Options)'=2 goto EFDone "RTN","TMGNDF2A",513,0) if $$GetIENs^TMGSELED(.Options)=0 goto EFDone "RTN","TMGNDF2A",514,0) goto EF1 "RTN","TMGNDF2A",515,0) "RTN","TMGNDF2A",516,0) EFDone quit "RTN","TMGNDF2A",517,0) "RTN","TMGNDF2A",518,0) ;"========================================================== "RTN","TMGNDF2A",519,0) FixNoForm "RTN","TMGNDF2A",520,0) ;"Purpose: To scan through the TRADENAME fields (.05) and fix "RTN","TMGNDF2A",521,0) ;" drugs that don't have a drug FORM in the name. "RTN","TMGNDF2A",522,0) "RTN","TMGNDF2A",523,0) new IEN,Itr,abort,IgnoreList "RTN","TMGNDF2A",524,0) new quickMem "RTN","TMGNDF2A",525,0) new Suggestions "RTN","TMGNDF2A",526,0) set abort=0 "RTN","TMGNDF2A",527,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2A",528,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2A",529,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF2A",530,0) . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGNDF2A",531,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2A",532,0) . new tradeName,nameArray "RTN","TMGNDF2A",533,0) . set tradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) "RTN","TMGNDF2A",534,0) . if tradeName="" write !,"No TRADENAME found for record#: ",IEN,! quit "RTN","TMGNDF2A",535,0) . new result set result=$$HandleNameArray(IEN,tradeName,.IgnoreList,1) "RTN","TMGNDF2A",536,0) . if result="^" set abort=1 "RTN","TMGNDF2A",537,0) . if +result=0 do "RTN","TMGNDF2A",538,0) . . set Suggestions(IEN)=$piece(result,"^",2) "RTN","TMGNDF2A",539,0) "RTN","TMGNDF2A",540,0) if $data(Suggestions) do HndlSuggestions(.Suggestions,.IgnoreList) "RTN","TMGNDF2A",541,0) else do "RTN","TMGNDF2A",542,0) . write "No changes needed. Great!",! "RTN","TMGNDF2A",543,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2A",544,0) "RTN","TMGNDF2A",545,0) quit "RTN","TMGNDF2A",546,0) "RTN","TMGNDF2A",547,0) "RTN","TMGNDF2A",548,0) "RTN","TMGNDF2A",549,0) HandleNameArray(IEN,tradeName,IgnoreList,Quiet) "RTN","TMGNDF2A",550,0) ;"Purpose: To handle a name array, looking for a form. "RTN","TMGNDF2A",551,0) ;"Input: IEN -- IEN in 22706.9 of current drug "RTN","TMGNDF2A",552,0) ;" tradeName -- current TRADENAME "RTN","TMGNDF2A",553,0) ;" IgnoreList -- OPTIONAL -- a list of forms to be ignored (not perminant). "RTN","TMGNDF2A",554,0) ;" Format: IgnoreList(FormName)="" "RTN","TMGNDF2A",555,0) ;" Quiet -- OPTIONAL. If =1 then will not ask, but prepair suggested answer. "RTN","TMGNDF2A",556,0) ;"NOTE: Makes use of variable with global scope quickMem. Format: "RTN","TMGNDF2A",557,0) ;" quickMem(FormNameFound)="" "RTN","TMGNDF2A",558,0) ;" quickMem(FormNameFound)="" "RTN","TMGNDF2A",559,0) ;"Results: 1=drug FORM found, "RTN","TMGNDF2A",560,0) ;" 0 if not found, OR 0^SuggestedNewName "RTN","TMGNDF2A",561,0) ;" ^=abort "RTN","TMGNDF2A",562,0) "RTN","TMGNDF2A",563,0) new Array "RTN","TMGNDF2A",564,0) do CleaveToArray^TMGSTUTL(tradeName," ",.Array) "RTN","TMGNDF2A",565,0) ;"Returns Array in format: "RTN","TMGNDF2A",566,0) ;" Array(1)="This" "RTN","TMGNDF2A",567,0) ;" Array(2)="Is" "RTN","TMGNDF2A",568,0) ;" Array(3)="A" "RTN","TMGNDF2A",569,0) ;" Array(4)="Test" "RTN","TMGNDF2A",570,0) ;" Array(MAXNODE)=4 "RTN","TMGNDF2A",571,0) "RTN","TMGNDF2A",572,0) HNA0 new index,tempS "RTN","TMGNDF2A",573,0) new found set found=0 "RTN","TMGNDF2A",574,0) new result set result=0 "RTN","TMGNDF2A",575,0) set Quiet=+$get(Quiet,0) "RTN","TMGNDF2A",576,0) new suggestedName set suggestedName="" "RTN","TMGNDF2A",577,0) set tempS="" "RTN","TMGNDF2A",578,0) new DIC,X,Y "RTN","TMGNDF2A",579,0) new menu,menuIndex,UsrSlct "RTN","TMGNDF2A",580,0) new drugForm "RTN","TMGNDF2A",581,0) set menuIndex=1 "RTN","TMGNDF2A",582,0) new lastWord set lastWord="" "RTN","TMGNDF2A",583,0) for index=$get(Array("MAXNODE")):-1:1 do quit:(found=1)!(result="^") "RTN","TMGNDF2A",584,0) . new thisWord set thisWord=$get(Array(index)) "RTN","TMGNDF2A",585,0) . if thisWord="" quit "RTN","TMGNDF2A",586,0) . new % set %=2 "RTN","TMGNDF2A",587,0) . if thisWord=lastWord do quit:(result="^")!(%=1) "RTN","TMGNDF2A",588,0) . . if Quiet=1 quit "RTN","TMGNDF2A",589,0) . . write "Word '",thisWord,"' found more than once",! "RTN","TMGNDF2A",590,0) . . write " in '",tradeName,".'",! "RTN","TMGNDF2A",591,0) . . write " Delete one of these " "RTN","TMGNDF2A",592,0) . . set %=1 do YN^DICN write ! "RTN","TMGNDF2A",593,0) . . if %=-1 set result="^" quit "RTN","TMGNDF2A",594,0) . . if %=2 quit "RTN","TMGNDF2A",595,0) . . if %=1 kill Array(index) quit "RTN","TMGNDF2A",596,0) . set lastWord=thisWord "RTN","TMGNDF2A",597,0) . if tempS'="" set tempS=" "_tempS "RTN","TMGNDF2A",598,0) . set tempS=thisWord_tempS "RTN","TMGNDF2A",599,0) . set menuIndex=menuIndex+1 "RTN","TMGNDF2A",600,0) . set menu(menuIndex)=tempS "RTN","TMGNDF2A",601,0) . new TMGA,TMGMSG "RTN","TMGNDF2A",602,0) . if $data(quickMem(tempS)) set found=1 quit "RTN","TMGNDF2A",603,0) . do FIND^DIC(22706.8,"",".01","M",tempS,"1","B","","","TMGA","TMGMSG") "RTN","TMGNDF2A",604,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",605,0) . if +$get(TMGA("DILIST",0))>0 do quit "RTN","TMGNDF2A",606,0) . . set found=1 "RTN","TMGNDF2A",607,0) . . set quickMem(tempS)="" "RTN","TMGNDF2A",608,0) . if $data(quickMem(thisWord)) set found=1 quit "RTN","TMGNDF2A",609,0) . do FIND^DIC(22706.8,"",".01","MC",thisWord,"1","","","","TMGA","TMGMSG") "RTN","TMGNDF2A",610,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",611,0) . if +$get(TMGA("DILIST",0))>0 do quit "RTN","TMGNDF2A",612,0) . . set found=1 "RTN","TMGNDF2A",613,0) . . set quickMem(tempS)="" "RTN","TMGNDF2A",614,0) if found goto MCDone "RTN","TMGNDF2A",615,0) "RTN","TMGNDF2A",616,0) set drugForm=$$GET1^DIQ(22706.9,IEN_",","3.5:.01") "RTN","TMGNDF2A",617,0) if $data(IgnoreList(drugForm)) goto MCDone ;" marked to be ignored. "RTN","TMGNDF2A",618,0) "RTN","TMGNDF2A",619,0) set menu(0)="Which option best shows the drug FORM? (Record #"_IEN_")" "RTN","TMGNDF2A",620,0) set menu(1)="None below. Use linked FORM: "_drugForm_$char(9)_"NONE" "RTN","TMGNDF2A",621,0) set menuIndex=menuIndex+1 "RTN","TMGNDF2A",622,0) set menu(menuIndex)="Manually enter a NEW FULL TRADENAME + FORM for this drug"_$char(9)_"EDIT" "RTN","TMGNDF2A",623,0) set menuIndex=menuIndex+1 "RTN","TMGNDF2A",624,0) set menu(menuIndex)="Manually change LINKED drug FORM for this drug"_$char(9)_"ChangeForm" "RTN","TMGNDF2A",625,0) set menuIndex=menuIndex+1 "RTN","TMGNDF2A",626,0) set menu(menuIndex)="Ignore this drug and continue"_$char(9)_"Ignore" "RTN","TMGNDF2A",627,0) "RTN","TMGNDF2A",628,0) if Quiet=1 set UsrSlct="QUIET" goto MC2 "RTN","TMGNDF2A",629,0) "RTN","TMGNDF2A",630,0) ;"At this point, no drug form was found. "RTN","TMGNDF2A",631,0) MC1 write ! "RTN","TMGNDF2A",632,0) set UsrSlct=$$Menu^TMGUSRIF(.menu,menuIndex) "RTN","TMGNDF2A",633,0) write ! "RTN","TMGNDF2A",634,0) if UsrSlct="^" set result="^" goto MCDone "RTN","TMGNDF2A",635,0) if UsrSlct="Ignore" do goto MCDone "RTN","TMGNDF2A",636,0) . write "Ignore all drugs with linked drug form of: ",drugForm," " "RTN","TMGNDF2A",637,0) . new % set %=2 do YN^DICN write ! "RTN","TMGNDF2A",638,0) . if %=-1 set result="^" quit "RTN","TMGNDF2A",639,0) . if %=2 quit "RTN","TMGNDF2A",640,0) . set IgnoreList(drugForm)="" "RTN","TMGNDF2A",641,0) "RTN","TMGNDF2A",642,0) MC2 if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF2A",643,0) "RTN","TMGNDF2A",644,0) if UsrSlct>0 do goto MCDone "RTN","TMGNDF2A",645,0) . new newForm set newForm=$get(menu(UsrSlct)) "RTN","TMGNDF2A",646,0) . new DIC,X,Y set DIC=22706.8 "RTN","TMGNDF2A",647,0) . set DIC(0)="MAEQL" "RTN","TMGNDF2A",648,0) . set DIC("A")="Select drug FORM to match with '"_newForm_"' ^//" "RTN","TMGNDF2A",649,0) . do ^DIC write ! "RTN","TMGNDF2A",650,0) . if +Y'>0 quit "RTN","TMGNDF2A",651,0) . new vistaForm,vistaRoute "RTN","TMGNDF2A",652,0) . set vistaForm=$piece($get(^TMG(22706.8,+Y,0)),"^",2) "RTN","TMGNDF2A",653,0) . set vistaRoute=$piece($get(^TMG(22706.8,+Y,0)),"^",3) "RTN","TMGNDF2A",654,0) . new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF2A",655,0) . set TMGFDA(22706.8,"+1,",.01)=newForm "RTN","TMGNDF2A",656,0) . set TMGFDA(22706.8,"+1,",1)=vistaForm "RTN","TMGNDF2A",657,0) . set TMGFDA(22706.8,"+1,",2)=vistaRoute "RTN","TMGNDF2A",658,0) . do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2A",659,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",660,0) . set found=1 "RTN","TMGNDF2A",661,0) "RTN","TMGNDF2A",662,0) set Y=-1 "RTN","TMGNDF2A",663,0) if UsrSlct="ChangeForm" do goto MCDone:(Y=-1),HNA0 "RTN","TMGNDF2A",664,0) . new DIC,X,Y "RTN","TMGNDF2A",665,0) . set DIC=50.606,DIC(0)="MAEQ" "RTN","TMGNDF2A",666,0) . set DIC("A")="Select drug FORM to use: ^// " "RTN","TMGNDF2A",667,0) . write "For '",tradeName,"',",! "RTN","TMGNDF2A",668,0) . do ^DIC "RTN","TMGNDF2A",669,0) . if Y=-1 quit "RTN","TMGNDF2A",670,0) . new newForm set newForm=$piece(Y,"^",2) "RTN","TMGNDF2A",671,0) . new origName set origName=$$GET1^DIQ(22706.9,IEN_",",.05) "RTN","TMGNDF2A",672,0) . set tradeName=origName_" "_newForm "RTN","TMGNDF2A",673,0) . if tradeName="" write "?? tradeName=''",! quit "RTN","TMGNDF2A",674,0) . new TMGFDA,TMGMSG,TMGA "RTN","TMGNDF2A",675,0) . set TMGFDA(22706.9,IEN_",",3.5)=+Y "RTN","TMGNDF2A",676,0) . set TMGFDA(22706.9,IEN_",",.05)=tradeName "RTN","TMGNDF2A",677,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2A",678,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",679,0) . do FIND^DIC(22706.8,"",".01","M",newForm,"1","B","","","TMGA","TMGMSG") "RTN","TMGNDF2A",680,0) . if +$get(TMGA("DILIST",0))'>0 do "RTN","TMGNDF2A",681,0) . . kill TMGFDA,TMGMSG new TMGIEN "RTN","TMGNDF2A",682,0) . . set TMGFDA(22706.8,"+1,",.01)=newForm "RTN","TMGNDF2A",683,0) . . do UPDATE^DIE("E","TMGFDA","TMGIDE","TMGMSG") "RTN","TMGNDF2A",684,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",685,0) . set result="0^"_tradeName "RTN","TMGNDF2A",686,0) "RTN","TMGNDF2A",687,0) if UsrSlct="QUIET" do goto MCDone "RTN","TMGNDF2A",688,0) . set suggestedName=tradeName_" "_drugForm "RTN","TMGNDF2A",689,0) . set result="0^"_suggestedName "RTN","TMGNDF2A",690,0) "RTN","TMGNDF2A",691,0) if UsrSlct="NONE" do goto MCDone "RTN","TMGNDF2A",692,0) . new newName "RTN","TMGNDF2A",693,0) . if drugForm="" do quit "RTN","TMGNDF2A",694,0) . . write "No drug FORM found in field 3.5 for record#: ",IEN,! quit "RTN","TMGNDF2A",695,0) . set newName=tradeName_" "_drugForm "RTN","TMGNDF2A",696,0) . write "Change TRADENAME to: ",newName," " "RTN","TMGNDF2A",697,0) . new % set %=1 do YN^DICN write ! "RTN","TMGNDF2A",698,0) . if %=-1 set result="^" quit "RTN","TMGNDF2A",699,0) . if %=2 quit "RTN","TMGNDF2A",700,0) . new TMGFDA,TMGMSG "RTN","TMGNDF2A",701,0) . set TMGFDA(22706.9,IEN_",",.05)=newName "RTN","TMGNDF2A",702,0) . do UPDATE^DIE("ES","TMGFDA","TMGMSG") "RTN","TMGNDF2A",703,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",704,0) . set found=1 "RTN","TMGNDF2A",705,0) "RTN","TMGNDF2A",706,0) if UsrSlct="EDIT" do goto MCDone "RTN","TMGNDF2A",707,0) . write "Enter NEW TRADENAME for drug (^ to abort): " "RTN","TMGNDF2A",708,0) . new newName read newName:$get(DTIME,3600),! "RTN","TMGNDF2A",709,0) . if newName="^" quit "RTN","TMGNDF2A",710,0) . write !,"Change TRADENAME from:",! "RTN","TMGNDF2A",711,0) . write tradeName," " "RTN","TMGNDF2A",712,0) . write " ----->",! "RTN","TMGNDF2A",713,0) . write newName,! "RTN","TMGNDF2A",714,0) . new % set Y=1 "RTN","TMGNDF2A",715,0) . do YN^DICN write ! "RTN","TMGNDF2A",716,0) . if %=-1 set result="^" quit "RTN","TMGNDF2A",717,0) . if %='1 quit "RTN","TMGNDF2A",718,0) . new TMGFDA,TMGMSG "RTN","TMGNDF2A",719,0) . set TMGFDA(22706.9,IEN_",",.05)=newName "RTN","TMGNDF2A",720,0) . do UPDATE^DIE("ES","TMGFDA","TMGMSG") "RTN","TMGNDF2A",721,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",722,0) . set result="0^"_newName "RTN","TMGNDF2A",723,0) "RTN","TMGNDF2A",724,0) MCDone "RTN","TMGNDF2A",725,0) if (found=1)&(result'="^") set result=1 "RTN","TMGNDF2A",726,0) quit result "RTN","TMGNDF2A",727,0) "RTN","TMGNDF2A",728,0) "RTN","TMGNDF2A",729,0) HndlSuggestions(Suggestions,IgnoreList) "RTN","TMGNDF2A",730,0) ;"Purpose: to interact with user about accepting or editing suggestions "RTN","TMGNDF2A",731,0) ;"Input: Suggestions -- PASS BY REFERENCE. Format: "RTN","TMGNDF2A",732,0) ;" Suggestions(IEN)=SuggestedNameForTradeName "RTN","TMGNDF2A",733,0) ;" Suggestions(IEN)=SuggestedNameForTradeName "RTN","TMGNDF2A",734,0) ;" IgnoreList -- PASS BY REFERENCE. A list of words/forms to be ignored "RTN","TMGNDF2A",735,0) "RTN","TMGNDF2A",736,0) new Answers "RTN","TMGNDF2A",737,0) new done set done=0 "RTN","TMGNDF2A",738,0) new input set input="R" "RTN","TMGNDF2A",739,0) new CompactMode set CompactMode=0 "RTN","TMGNDF2A",740,0) new Cancelled set Cancelled=0 "RTN","TMGNDF2A",741,0) new LastNum set LastNum=0 "RTN","TMGNDF2A",742,0) new EntryList,EntryS "RTN","TMGNDF2A",743,0) "RTN","TMGNDF2A",744,0) for do quit:(done=1) "RTN","TMGNDF2A",745,0) . if input="R" do "RTN","TMGNDF2A",746,0) . . write !! "RTN","TMGNDF2A",747,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",748,0) . . write "Specify which New TRADENAMES to accept",! "RTN","TMGNDF2A",749,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",750,0) . . do DispSuggestions(.Suggestions,.Answers,CompactMode) "RTN","TMGNDF2A",751,0) . . set LastNum=$order(Answers(""),-1) "RTN","TMGNDF2A",752,0) . . if LastNum="" set LastNum="^" "RTN","TMGNDF2A",753,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",754,0) . . write "Specify which New TRADENAMES to accept",! "RTN","TMGNDF2A",755,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2A",756,0) . write " R to refresh, I to Ignore some; M to manually edit",! "RTN","TMGNDF2A",757,0) . write " C=set Compact ",$select((CompactMode=1):"OFF",1:"ON"),", " "RTN","TMGNDF2A",758,0) . write " S to Screen names for a given form to Ignore.",! "RTN","TMGNDF2A",759,0) . write " A to show ALTERNATE drugs similar to shown",! "RTN","TMGNDF2A",760,0) . write " O to show sOurce (from FDA) for drug; K to mark drug sKipped.",! "RTN","TMGNDF2A",761,0) . write " # or #-# or #,#-#,# etc., ^ done, ",! "RTN","TMGNDF2A",762,0) . ;"write "Enter number(s) to Accept (or codes listed above): ",LastNum,"//" "RTN","TMGNDF2A",763,0) . write "Enter number(s) to Accept (or codes listed above): ^//" "RTN","TMGNDF2A",764,0) . read input:$get(DTIME,3600),! "RTN","TMGNDF2A",765,0) . ;"if input="" set input=LastNum write LastNum "RTN","TMGNDF2A",766,0) . if input="" set input="^" write "^" "RTN","TMGNDF2A",767,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF2A",768,0) . if input="^" set done=1 quit "RTN","TMGNDF2A",769,0) . if input="A" do ;"--- show alternatives "RTN","TMGNDF2A",770,0) . . new valid set valid=1 "RTN","TMGNDF2A",771,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF2A",772,0) . . . read "...Enter number(s) to show ALTERNATIVES for from list: ^// ",input,! "RTN","TMGNDF2A",773,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF2A",774,0) . . . if valid set EntryS=input "RTN","TMGNDF2A",775,0) . . set Cancelled=0 "RTN","TMGNDF2A",776,0) . . do ShowAlts(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",777,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF2A",778,0) . . set input="R" "RTN","TMGNDF2A",779,0) . if input="I" do ;"--- ignore entries. "RTN","TMGNDF2A",780,0) . . new valid set valid=1 "RTN","TMGNDF2A",781,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF2A",782,0) . . . read "...Enter number(s) to IGNORE from list: ^// ",input,! "RTN","TMGNDF2A",783,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF2A",784,0) . . . if valid set EntryS=input "RTN","TMGNDF2A",785,0) . . set Cancelled=0 "RTN","TMGNDF2A",786,0) . . do KillSugg(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",787,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF2A",788,0) . . set input="R" "RTN","TMGNDF2A",789,0) . else if input="K" do ;"--- Set to SKIP "RTN","TMGNDF2A",790,0) . . new valid set valid=1 "RTN","TMGNDF2A",791,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF2A",792,0) . . . read "...Enter number(s) to PERMINANTLY SKIP from list: ^// ",input,! "RTN","TMGNDF2A",793,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF2A",794,0) . . . if valid set EntryS=input "RTN","TMGNDF2A",795,0) . . set Cancelled=0 "RTN","TMGNDF2A",796,0) . . do SetSkip(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",797,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF2A",798,0) . . set input="R" "RTN","TMGNDF2A",799,0) . else if input="C" do ;"--- toggle compact mode "RTN","TMGNDF2A",800,0) . . set CompactMode='CompactMode "RTN","TMGNDF2A",801,0) . . set input="R" "RTN","TMGNDF2A",802,0) . else if input="M" do ;"--- manually handle entry "RTN","TMGNDF2A",803,0) . . new valid set valid=1 "RTN","TMGNDF2A",804,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF2A",805,0) . . . read "...Enter number(s) to MANUALLY EDIT from list: ^// ",input,! "RTN","TMGNDF2A",806,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF2A",807,0) . . . if valid set EntryS=input "RTN","TMGNDF2A",808,0) . . set Cancelled=0 "RTN","TMGNDF2A",809,0) . . do ManualEdit(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",810,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF2A",811,0) . . set input="R" "RTN","TMGNDF2A",812,0) . else if input="O" do ;"--- show FDA source "RTN","TMGNDF2A",813,0) . . new valid set valid=1 "RTN","TMGNDF2A",814,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF2A",815,0) . . . read "...Enter number(s) to show FDA SOURCE for from list: ^// ",input,! "RTN","TMGNDF2A",816,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF2A",817,0) . . . if valid set EntryS=input "RTN","TMGNDF2A",818,0) . . set Cancelled=0 "RTN","TMGNDF2A",819,0) . . do ShowSrc(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",820,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF2A",821,0) . . set input="R" "RTN","TMGNDF2A",822,0) . else if input="S" do ;"--- screen for those to ignore "RTN","TMGNDF2A",823,0) . . new scrnForm "RTN","TMGNDF2A",824,0) . . read "Enter Form to screen for. All entries with this form will be ignored: ",scrnForm,! "RTN","TMGNDF2A",825,0) . . if scrnForm="^" quit "RTN","TMGNDF2A",826,0) . . kill EntryList,EntryS "RTN","TMGNDF2A",827,0) . . new num set num="" "RTN","TMGNDF2A",828,0) . . for set num=$order(Answers(num)) quit:(num="") do "RTN","TMGNDF2A",829,0) . . . new newName set newName=$piece($get(Answers(num)),"^",2) "RTN","TMGNDF2A",830,0) . . . if newName[scrnForm set EntryList(num)="" "RTN","TMGNDF2A",831,0) . . do KillSugg(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",832,0) . . set input="R" "RTN","TMGNDF2A",833,0) . else if input'="R" do "RTN","TMGNDF2A",834,0) . . if $$MkMultList^TMGMISC(input,.EntryList)=0 quit "RTN","TMGNDF2A",835,0) . . set EntryS=input "RTN","TMGNDF2A",836,0) . . set Cancelled=0 "RTN","TMGNDF2A",837,0) . . do AcceptSugg(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",838,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF2A",839,0) . . set input="R" "RTN","TMGNDF2A",840,0) "RTN","TMGNDF2A",841,0) quit "RTN","TMGNDF2A",842,0) "RTN","TMGNDF2A",843,0) "RTN","TMGNDF2A",844,0) AcceptSugg(Array,Answers,EntryList,Cancelled) "RTN","TMGNDF2A",845,0) ;"Purpose: To accept new suggested name from Array "RTN","TMGNDF2A",846,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, "RTN","TMGNDF2A",847,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",848,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",849,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF2A",850,0) ;" Array should be the one created by DispSuggestions() "RTN","TMGNDF2A",851,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",852,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",853,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2A",854,0) ;" Format as follows. "RTN","TMGNDF2A",855,0) ;" List(Entry number)="" "RTN","TMGNDF2A",856,0) ;" List(Entry number)="" "RTN","TMGNDF2A",857,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF2A",858,0) ;"Results: none "RTN","TMGNDF2A",859,0) "RTN","TMGNDF2A",860,0) new num set num="" "RTN","TMGNDF2A",861,0) for set num=$order(EntryList(num)) quit:(num="") do "RTN","TMGNDF2A",862,0) . new IEN,newName "RTN","TMGNDF2A",863,0) . set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",864,0) . if IEN="" quit "RTN","TMGNDF2A",865,0) . set newName=$piece($get(Answers(num)),"^",2) "RTN","TMGNDF2A",866,0) . if $length(newName)>64 do quit:(newName="^") "RTN","TMGNDF2A",867,0) . . set newName=$$ShortName^TMGSHORT(newName,64,1," ") "RTN","TMGNDF2A",868,0) . new TMGFDA,TMGMSG "RTN","TMGNDF2A",869,0) . set TMGFDA(22706.9,IEN_",",.05)=newName "RTN","TMGNDF2A",870,0) . do UPDATE^DIE("ES","TMGFDA","TMGMSG") "RTN","TMGNDF2A",871,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",872,0) "RTN","TMGNDF2A",873,0) do KillSugg(.Array,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",874,0) "RTN","TMGNDF2A",875,0) quit "RTN","TMGNDF2A",876,0) "RTN","TMGNDF2A",877,0) ManualEdit(Suggestions,Answers,EntryList,Cancelled,IgnoreList) "RTN","TMGNDF2A",878,0) ;"Purpose: To accept manually edit suggestions from Array "RTN","TMGNDF2A",879,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, "RTN","TMGNDF2A",880,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",881,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",882,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF2A",883,0) ;" Array should be the one created by DispSuggestions() "RTN","TMGNDF2A",884,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",885,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",886,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2A",887,0) ;" Format as follows. "RTN","TMGNDF2A",888,0) ;" List(Entry number)="" "RTN","TMGNDF2A",889,0) ;" List(Entry number)="" "RTN","TMGNDF2A",890,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF2A",891,0) ;" IgnoreList -- PASS BY REFERENCE. A list of words/forms to ignore. "RTN","TMGNDF2A",892,0) ;"NOTE: function HandleNameArray (called here) uses variable with global "RTN","TMGNDF2A",893,0) ;" scope: quickMem "RTN","TMGNDF2A",894,0) ;"Results: none "RTN","TMGNDF2A",895,0) "RTN","TMGNDF2A",896,0) new num set num="" "RTN","TMGNDF2A",897,0) set Cancelled=$get(Cancelled,0) "RTN","TMGNDF2A",898,0) for set num=$order(EntryList(num)) quit:(num="")!(Cancelled=1) do "RTN","TMGNDF2A",899,0) . new IEN,newName "RTN","TMGNDF2A",900,0) . set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",901,0) . if IEN="" quit "RTN","TMGNDF2A",902,0) . ;"set newName=$piece($get(Answers(num)),"^",2) "RTN","TMGNDF2A",903,0) . set newName=$$GET1^DIQ(22706.9,IEN_",",.05) "RTN","TMGNDF2A",904,0) . new result set result=$$HandleNameArray(IEN,newName,.IgnoreList,0) "RTN","TMGNDF2A",905,0) . if +result=0 do "RTN","TMGNDF2A",906,0) . . set $piece(Answers(num),"^",2)=$piece(result,"^",2) "RTN","TMGNDF2A",907,0) . . set Suggestions(IEN)=$piece(result,"^",2) "RTN","TMGNDF2A",908,0) . if result="^" set Cancelled=1 "RTN","TMGNDF2A",909,0) . if result=1 do quit "RTN","TMGNDF2A",910,0) . . write "Entry handled and removed from list.",! "RTN","TMGNDF2A",911,0) . . do PressToContinue^TMGUSRIF "RTN","TMGNDF2A",912,0) . . kill Answers(num),Suggestions(IEN),EntryList(num) "RTN","TMGNDF2A",913,0) "RTN","TMGNDF2A",914,0) quit "RTN","TMGNDF2A",915,0) "RTN","TMGNDF2A",916,0) "RTN","TMGNDF2A",917,0) ShowSrc(Suggestions,Answers,EntryList,Cancelled) "RTN","TMGNDF2A",918,0) ;"Purpose: To show FDA source for drugs in Array "RTN","TMGNDF2A",919,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, "RTN","TMGNDF2A",920,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",921,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",922,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF2A",923,0) ;" Array should be the one created by DispSuggestions() "RTN","TMGNDF2A",924,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",925,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",926,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2A",927,0) ;" Format as follows. "RTN","TMGNDF2A",928,0) ;" List(Entry number)="" "RTN","TMGNDF2A",929,0) ;" List(Entry number)="" "RTN","TMGNDF2A",930,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF2A",931,0) ;"Results: none "RTN","TMGNDF2A",932,0) "RTN","TMGNDF2A",933,0) new num set num="" "RTN","TMGNDF2A",934,0) set Cancelled=$get(Cancelled,0) "RTN","TMGNDF2A",935,0) for set num=$order(EntryList(num)) quit:(num="")!(Cancelled=1) do "RTN","TMGNDF2A",936,0) . new IEN,newName "RTN","TMGNDF2A",937,0) . set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",938,0) . if IEN="" quit "RTN","TMGNDF2A",939,0) . set newName=$piece($get(Answers(num)),"^",2) "RTN","TMGNDF2A",940,0) . do Show1Source^TMGNDF1A(IEN) "RTN","TMGNDF2A",941,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2A",942,0) "RTN","TMGNDF2A",943,0) quit "RTN","TMGNDF2A",944,0) "RTN","TMGNDF2A",945,0) "RTN","TMGNDF2A",946,0) SetSkip(Suggestions,Answers,EntryList,Cancelled,Quiet) "RTN","TMGNDF2A",947,0) ;"Purpose: To set the drugs in the Array as perminantly skipped. "RTN","TMGNDF2A",948,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, "RTN","TMGNDF2A",949,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",950,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",951,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF2A",952,0) ;" Array should be the one created by DispSuggestions() "RTN","TMGNDF2A",953,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",954,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",955,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2A",956,0) ;" Format as follows. "RTN","TMGNDF2A",957,0) ;" List(Entry number)="" "RTN","TMGNDF2A",958,0) ;" List(Entry number)="" "RTN","TMGNDF2A",959,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF2A",960,0) ;" Quiet -- OPTIONAL. if 1, then user is not asked. Default=0 "RTN","TMGNDF2A",961,0) ;"Results: none "RTN","TMGNDF2A",962,0) "RTN","TMGNDF2A",963,0) new num set num="" "RTN","TMGNDF2A",964,0) set Cancelled=$get(Cancelled,0) "RTN","TMGNDF2A",965,0) if $get(Quiet)=1 goto SK1 "RTN","TMGNDF2A",966,0) write "For this list of drug TRADENAME:",! "RTN","TMGNDF2A",967,0) write "--------------------------------",! "RTN","TMGNDF2A",968,0) for set num=$order(EntryList(num)) quit:(num="")!(Cancelled=1) do "RTN","TMGNDF2A",969,0) . new IEN,newName "RTN","TMGNDF2A",970,0) . set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",971,0) . if IEN="" quit "RTN","TMGNDF2A",972,0) . set newName=$piece($get(Answers(num)),"^",2) "RTN","TMGNDF2A",973,0) . write " ",newName," (#",IEN,")",! "RTN","TMGNDF2A",974,0) write "--------------------------------",! "RTN","TMGNDF2A",975,0) write "Set these drugs to be PERMINANTLY SKIPPED" "RTN","TMGNDF2A",976,0) new % set %=2 do YN^DICN write ! "RTN","TMGNDF2A",977,0) if %=-1 set Cancelled=1 goto SSDone "RTN","TMGNDF2A",978,0) if %=2 goto SSDone "RTN","TMGNDF2A",979,0) if %=1 do "RTN","TMGNDF2A",980,0) SK1 for set num=$order(EntryList(num)) quit:(num="")!(Cancelled=1) do "RTN","TMGNDF2A",981,0) . new IEN,newName "RTN","TMGNDF2A",982,0) . set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",983,0) . if IEN="" quit "RTN","TMGNDF2A",984,0) . set $piece(^TMG(22706.9,IEN,1),"^",4)=1 ;"1=SKIP "RTN","TMGNDF2A",985,0) do KillSugg(.Suggestions,.Answers,.EntryList,.Cancelled) "RTN","TMGNDF2A",986,0) "RTN","TMGNDF2A",987,0) SSDone "RTN","TMGNDF2A",988,0) quit "RTN","TMGNDF2A",989,0) "RTN","TMGNDF2A",990,0) "RTN","TMGNDF2A",991,0) ShowAlts(Suggestions,Answers,EntryList,Cancelled) "RTN","TMGNDF2A",992,0) ;"Purpose: To show alternate drugs from drugs in Array "RTN","TMGNDF2A",993,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, "RTN","TMGNDF2A",994,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",995,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",996,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF2A",997,0) ;" Array should be the one created by DispSuggestions() "RTN","TMGNDF2A",998,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",999,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",1000,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2A",1001,0) ;" Format as follows. "RTN","TMGNDF2A",1002,0) ;" List(Entry number)="" "RTN","TMGNDF2A",1003,0) ;" List(Entry number)="" "RTN","TMGNDF2A",1004,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF2A",1005,0) ;"Results: none "RTN","TMGNDF2A",1006,0) "RTN","TMGNDF2A",1007,0) new num set num="" "RTN","TMGNDF2A",1008,0) set Cancelled=$get(Cancelled,0) "RTN","TMGNDF2A",1009,0) new skipList "RTN","TMGNDF2A",1010,0) for set num=$order(EntryList(num)) quit:(num="")!(Cancelled=1) do "RTN","TMGNDF2A",1011,0) . new IEN,newName,foundList "RTN","TMGNDF2A",1012,0) . set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",1013,0) . if IEN="" quit "RTN","TMGNDF2A",1014,0) . set newName=$piece($get(Answers(num)),"^",2) "RTN","TMGNDF2A",1015,0) . do GETS^DIQ(22706.9,IEN_",",".04;.05;.07;1;3.5","","TMGA","TMGMSG") "RTN","TMGNDF2A",1016,0) . new origName set origName=$get(TMGA(22706.9,IEN_",",.05)) "RTN","TMGNDF2A",1017,0) . if origName="" quit "RTN","TMGNDF2A",1018,0) . new NameDose set NameDose=origName_" ("_$get(TMGA(22706.9,IEN_",",.07))_") "_$get(TMGA(22706.9,IEN_",",1)) "RTN","TMGNDF2A",1019,0) . write !,!,"For drug '",NameDose,"', below are alternatives...",! "RTN","TMGNDF2A",1020,0) . do FIND^DIC(22706.9,"",".05","M",origName,"30","B","","","TMGA","TMGMSG") "RTN","TMGNDF2A",1021,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",1022,0) . if +$get(TMGA("DILIST",0))=1 do "RTN","TMGNDF2A",1023,0) . . do FIND^DIC(22706.9,"",".05","M",$piece(origName," ",1),"30","B","","","TMGA","TMGMSG") "RTN","TMGNDF2A",1024,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2A",1025,0) . merge foundList=TMGA("DILIST",2) ;"format foundList(seq#)=IEN22706d9 "RTN","TMGNDF2A",1026,0) SAL1 . new numShown set numShown=0 "RTN","TMGNDF2A",1027,0) . write "--------------------------",! "RTN","TMGNDF2A",1028,0) . if $data(foundList) do "RTN","TMGNDF2A",1029,0) . . new seqNum set seqNum="" "RTN","TMGNDF2A",1030,0) . . for set seqNum=$order(foundList(seqNum)) quit:(seqNum="") do "RTN","TMGNDF2A",1031,0) . . . new TMGA,TMGMSG,IEN2 "RTN","TMGNDF2A",1032,0) . . . set IEN2=$get(foundList(seqNum)) "RTN","TMGNDF2A",1033,0) . . . if (+IEN2'>0)!(IEN2=IEN) quit "RTN","TMGNDF2A",1034,0) . . . if $piece($get(^TMG(22706.9,IEN2,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2A",1035,0) . . . do GETS^DIQ(22706.9,IEN2_",",".04;.07;1;3.5","","TMGA","TMGMSG") "RTN","TMGNDF2A",1036,0) . . . write " ",$get(TMGA(22706.9,IEN2_",",.07)) "RTN","TMGNDF2A",1037,0) . . . write " ",$get(TMGA(22706.9,IEN2_",",1)) "RTN","TMGNDF2A",1038,0) . . . write " ",$get(TMGA(22706.9,IEN2_",",3.5))," ; " "RTN","TMGNDF2A",1039,0) . . . write " ",$get(TMGA(22706.9,IEN2_",",.04)),! "RTN","TMGNDF2A",1040,0) . . . set numShown=numShown+1 "RTN","TMGNDF2A",1041,0) . if numShown=0 do "RTN","TMGNDF2A",1042,0) . . write " -- List is empty --",! "RTN","TMGNDF2A",1043,0) . write "--------------------------",! "RTN","TMGNDF2A",1044,0) . write "For drug '",NameDose,"', above alternatives were found:",! "RTN","TMGNDF2A",1045,0) . write !,"If a similar drug is seen in list above, then SKIP is OK",! "RTN","TMGNDF2A",1046,0) . write "Set '",NameDose,"'",! "RTN","TMGNDF2A",1047,0) . write " to be PERMINANTLY SKIPPED" "RTN","TMGNDF2A",1048,0) . new % set %=2 do YN^DICN write ! "RTN","TMGNDF2A",1049,0) . if %=-1 set Cancelled=1 quit "RTN","TMGNDF2A",1050,0) . if %=1 set skipList(num)="" quit "RTN","TMGNDF2A",1051,0) . set %=2 "RTN","TMGNDF2A",1052,0) . write "Lookup a comparison manually" do YN^DICN write ! "RTN","TMGNDF2A",1053,0) . if %=-1 set Cancelled=1 quit "RTN","TMGNDF2A",1054,0) . if %=2 quit "RTN","TMGNDF2A",1055,0) . if %=1 do goto SAL1 "RTN","TMGNDF2A",1056,0) . . new DIC,X,Y "RTN","TMGNDF2A",1057,0) . . set DIC=22706.9,DIC(0)="MAEQ" "RTN","TMGNDF2A",1058,0) . . do ^DIC write ! "RTN","TMGNDF2A",1059,0) . . if Y=-1 write !,"NO MATCH.",!,! "RTN","TMGNDF2A",1060,0) "RTN","TMGNDF2A",1061,0) "RTN","TMGNDF2A",1062,0) if $data(skipList) do "RTN","TMGNDF2A",1063,0) . do SetSkip(.Suggestions,.Answers,.skipList,.Cancelled,1) "RTN","TMGNDF2A",1064,0) "RTN","TMGNDF2A",1065,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2A",1066,0) "RTN","TMGNDF2A",1067,0) quit "RTN","TMGNDF2A",1068,0) "RTN","TMGNDF2A",1069,0) "RTN","TMGNDF2A",1070,0) KillSugg(Array,Answers,EntryList,Cancelled) "RTN","TMGNDF2A",1071,0) ;"Purpose: To accept new suggested name from Array "RTN","TMGNDF2A",1072,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, "RTN","TMGNDF2A",1073,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",1074,0) ;" Array(IEN)=SuggestedNewTradeName "RTN","TMGNDF2A",1075,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF2A",1076,0) ;" Array should be the one created by DispSuggestions() "RTN","TMGNDF2A",1077,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",1078,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",1079,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2A",1080,0) ;" Format as follows. "RTN","TMGNDF2A",1081,0) ;" List(Entry number)="" "RTN","TMGNDF2A",1082,0) ;" List(Entry number)="" "RTN","TMGNDF2A",1083,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF2A",1084,0) ;"Results: none "RTN","TMGNDF2A",1085,0) "RTN","TMGNDF2A",1086,0) new num set num="" "RTN","TMGNDF2A",1087,0) for set num=$order(EntryList(num)) quit:(num="") do "RTN","TMGNDF2A",1088,0) . new IEN set IEN=$piece($get(Answers(num)),"^",1) "RTN","TMGNDF2A",1089,0) . kill Answers(num) "RTN","TMGNDF2A",1090,0) . kill Array(IEN) "RTN","TMGNDF2A",1091,0) "RTN","TMGNDF2A",1092,0) quit "RTN","TMGNDF2A",1093,0) "RTN","TMGNDF2A",1094,0) "RTN","TMGNDF2A",1095,0) DispSuggestions(Suggestions,Answers,Compact) "RTN","TMGNDF2A",1096,0) ;"Purpose: to display list of Suggested name changes "RTN","TMGNDF2A",1097,0) ;"Input: Suggestions -- PASS BY REFERENCE. Format: "RTN","TMGNDF2A",1098,0) ;" Suggestions(IEN)=SuggestedNameForTradeName "RTN","TMGNDF2A",1099,0) ;" Suggestions(IEN)=SuggestedNameForTradeName "RTN","TMGNDF2A",1100,0) ;" Answers -- PASS BY REFERENCE. Format: "RTN","TMGNDF2A",1101,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",1102,0) ;" Answers(DispNum)=IEN^SuggestedNameForTradeName "RTN","TMGNDF2A",1103,0) ;" Compact -- OPTIONAL, Default=0. If 1, only first part of list shown. "RTN","TMGNDF2A",1104,0) ;"Results: None "RTN","TMGNDF2A",1105,0) "RTN","TMGNDF2A",1106,0) kill Answers "RTN","TMGNDF2A",1107,0) new count set count=0 "RTN","TMGNDF2A",1108,0) set Compact=+$get(Compact) "RTN","TMGNDF2A",1109,0) new IEN set IEN="" "RTN","TMGNDF2A",1110,0) for set IEN=$order(Suggestions(IEN)) quit:(IEN="")!((Compact=1)&(count>10)) do "RTN","TMGNDF2A",1111,0) . new newName set newName=$get(Suggestions(IEN)) "RTN","TMGNDF2A",1112,0) . set count=count+1 "RTN","TMGNDF2A",1113,0) . write count,". ",newName,! "RTN","TMGNDF2A",1114,0) . set Answers(count)=IEN_"^"_newName "RTN","TMGNDF2A",1115,0) if count=0 do "RTN","TMGNDF2A",1116,0) . write " -- List is Empty --",! "RTN","TMGNDF2A",1117,0) "RTN","TMGNDF2A",1118,0) quit "RTN","TMGNDF2A",1119,0) "RTN","TMGNDF2C") 0^43^B7038 "RTN","TMGNDF2C",1,0) TMGNDF2C ;TMG/kst/FDA Import: Fill VA GENERIC entries;03/25/06 "RTN","TMGNDF2C",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF2C",3,0) "RTN","TMGNDF2C",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF2C",5,0) ;" -- FILLING VA GENERIC FILE WITH NEW VALUES "RTN","TMGNDF2C",6,0) ;" -- and linking field .08 (VA GENERIC) in file TMG FDA IMPORT with links to apprpriate values. "RTN","TMGNDF2C",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDF2C",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF2C",9,0) ;"11-21-2006 "RTN","TMGNDF2C",10,0) "RTN","TMGNDF2C",11,0) ;"======================================================================= "RTN","TMGNDF2C",12,0) ;" API -- Public Functions. "RTN","TMGNDF2C",13,0) ;"======================================================================= "RTN","TMGNDF2C",14,0) ;"Menu "RTN","TMGNDF2C",15,0) ;"======================================================================= "RTN","TMGNDF2C",16,0) ;"FillGenerics -- scan TMG FDA IMPORT file and make sure that all of the GENERIC NAMEs "RTN","TMGNDF2C",17,0) ;" have been added into the VA GENERIC file, or that a link exists between a "RTN","TMGNDF2C",18,0) ;" GENERIC name and an existing VA GENERIC name. "RTN","TMGNDF2C",19,0) ;" Then use this data and fill in field .08 in file TMG FDA IMPORT COMPILED "RTN","TMGNDF2C",20,0) "RTN","TMGNDF2C",21,0) ;"======================================================================= "RTN","TMGNDF2C",22,0) ;" Private Functions. "RTN","TMGNDF2C",23,0) ;"======================================================================= "RTN","TMGNDF2C",24,0) ;"CheckGenerics(Results) "RTN","TMGNDF2C",25,0) ;"Rescan(Array,Label,number) "RTN","TMGNDF2C",26,0) ;"FindSimGenerics(Generic,Array) "RTN","TMGNDF2C",27,0) ;"NarrowGenMatches(Generic,Array) "RTN","TMGNDF2C",28,0) ;"FindGenContain(name,Array) "RTN","TMGNDF2C",29,0) ;"Scan4Generics(Array) "RTN","TMGNDF2C",30,0) ;"Unlock50dot6 "RTN","TMGNDF2C",31,0) ;"Lock50dot6 "RTN","TMGNDF2C",32,0) ;"ShowList(Array,Label) "RTN","TMGNDF2C",33,0) ;"ProcessList(Array) -- handle adding generic names, returning a list of linkages "RTN","TMGNDF2C",34,0) ;"HandleAdds(Array) -- handle adding those entries in Array that need to be added to VA GENERIC file. "RTN","TMGNDF2C",35,0) ;"Remove(Array,Label,Num,EndNum) -- remove name(s) from Array of additions to VA GENERIC file "RTN","TMGNDF2C",36,0) ;"CustLookup(Array,Label,Num) -- manually link entry in Array to an existing entry in VA GENERIC file "RTN","TMGNDF2C",37,0) ;"DoAdds(Array,Label,Num,EndNum) -- extract name(s) from Array and add to VA GENERIC file, via Add1Generic "RTN","TMGNDF2C",38,0) ;"Add1Generic(Name) -- add on entry to the VA GENERIC FILE "RTN","TMGNDF2C",39,0) ;"HandleQAdds(Array) -- review 'Uncertain Matches' node of Array and allow user to specify whether "RTN","TMGNDF2C",40,0) ;"DoLinks(Array,Num,EndNum) -- change a link from the "Uncertain Matches" node, to a formal link "RTN","TMGNDF2C",41,0) ;"DoMltLink(Array,Num,TMGGeneric) -- interact with user and pick which link (amoung multiple) "RTN","TMGNDF2C",42,0) ;"FillCompFile(Array) -- fill in field .08 in file TMG FDA IMPORT COMPILED "RTN","TMGNDF2C",43,0) "RTN","TMGNDF2C",44,0) ;"======================================================================= "RTN","TMGNDF2C",45,0) ;"======================================================================= "RTN","TMGNDF2C",46,0) "RTN","TMGNDF2C",47,0) Menu "RTN","TMGNDF2C",48,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF2C",49,0) "RTN","TMGNDF2C",50,0) new Menu,UsrSlct "RTN","TMGNDF2C",51,0) set Menu(0)="Pick Option for filling VA GENERIC entries (2C)" "RTN","TMGNDF2C",52,0) set Menu(1)="Ensure link between import GENERIC name, and VA GENERIC name"_$char(9)_"FillGenerics" "RTN","TMGNDF2C",53,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF2C",54,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF2C",55,0) "RTN","TMGNDF2C",56,0) MC1 write # "RTN","TMGNDF2C",57,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF2C",58,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF2C",59,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF2C",60,0) "RTN","TMGNDF2C",61,0) if UsrSlct="FillGenerics" do FillGenerics goto MC1 "RTN","TMGNDF2C",62,0) if UsrSlct="Prev" goto Menu^TMGNDF2A ;"quit can occur from there... "RTN","TMGNDF2C",63,0) if UsrSlct="Next" goto Menu^TMGNDF2E ;"quit can occur from there... "RTN","TMGNDF2C",64,0) goto MC1 "RTN","TMGNDF2C",65,0) "RTN","TMGNDF2C",66,0) MCDone "RTN","TMGNDF2C",67,0) quit "RTN","TMGNDF2C",68,0) "RTN","TMGNDF2C",69,0) "RTN","TMGNDF2C",70,0) FillGenerics "RTN","TMGNDF2C",71,0) ;"Purpose: To scan TMG FDA IMPORT file and make sure that all of the GENERIC NAMEs "RTN","TMGNDF2C",72,0) ;" have been added into the VA GENERIC file, or that a link exists between a "RTN","TMGNDF2C",73,0) ;" GENERIC name and an existing VA GENERIC name. "RTN","TMGNDF2C",74,0) ;" Then use this data and fill in field .08 in file TMG FDA IMPORT COMPILED "RTN","TMGNDF2C",75,0) "RTN","TMGNDF2C",76,0) new list "RTN","TMGNDF2C",77,0) "RTN","TMGNDF2C",78,0) write # "RTN","TMGNDF2C",79,0) write "======================================================",! "RTN","TMGNDF2C",80,0) write "Link FDA import entries to entries in VA GENERIC file",! "RTN","TMGNDF2C",81,0) write "======================================================",!,! "RTN","TMGNDF2C",82,0) new list "RTN","TMGNDF2C",83,0) if $data(^TMG("templist")) do "RTN","TMGNDF2C",84,0) . write "Data from another work run found. Continue to use this" "RTN","TMGNDF2C",85,0) . new % set %=1 do YN^DICN write ! "RTN","TMGNDF2C",86,0) . if %=1 merge list=^TMG("templist") "RTN","TMGNDF2C",87,0) . if %=2 do "RTN","TMGNDF2C",88,0) . . write "Delete old data from prior run" "RTN","TMGNDF2C",89,0) . . set %=2 do YN^DICN write ! "RTN","TMGNDF2C",90,0) . . if %=1 kill ^TMG("templist"),list "RTN","TMGNDF2C",91,0) . . do CheckGenerics(.list) "RTN","TMGNDF2C",92,0) else do CheckGenerics(.list) "RTN","TMGNDF2C",93,0) kill ^TMG("templist") "RTN","TMGNDF2C",94,0) "RTN","TMGNDF2C",95,0) if $data(list)=0 goto FGDone "RTN","TMGNDF2C",96,0) "RTN","TMGNDF2C",97,0) do ProcessList(.list) "RTN","TMGNDF2C",98,0) merge ^TMG("templist")=list "RTN","TMGNDF2C",99,0) write "Use data to fill in VA GENERIC field in TMG FDA IMPORT COMPILED now" "RTN","TMGNDF2C",100,0) set %=1 do YN^DICN write ! "RTN","TMGNDF2C",101,0) if %=1 do FillCompFile(.list) "RTN","TMGNDF2C",102,0) "RTN","TMGNDF2C",103,0) FGDone "RTN","TMGNDF2C",104,0) write "Goodbye.",! "RTN","TMGNDF2C",105,0) quit "RTN","TMGNDF2C",106,0) "RTN","TMGNDF2C",107,0) "RTN","TMGNDF2C",108,0) CheckGenerics(Results) "RTN","TMGNDF2C",109,0) ;"Purpose: To scan TMG FDA IMPORT file and make sure that all of the GENERIC NAMEs "RTN","TMGNDF2C",110,0) ;" have been added into the VA GENERIC file, or that a link exists between a "RTN","TMGNDF2C",111,0) ;" GENERIC NAME and an existing VA GENERIC name. "RTN","TMGNDF2C",112,0) ;"Input: Results -- PASS BY REFERENCE, and OUT PARAMETER. Returns array with results. "RTN","TMGNDF2C",113,0) "RTN","TMGNDF2C",114,0) new Array,i "RTN","TMGNDF2C",115,0) write "Collecting list of imports not linked to a VA GENERIC entry.",! "RTN","TMGNDF2C",116,0) do Scan4Generics(.Array) ;"note: result Array will not include SKIPPED records "RTN","TMGNDF2C",117,0) if $data(Array)=0 do goto CGDone "RTN","TMGNDF2C",118,0) . write "No unmatched entries found--great!",! "RTN","TMGNDF2C",119,0) "RTN","TMGNDF2C",120,0) write "Processing GENERIC names...",! "RTN","TMGNDF2C",121,0) "RTN","TMGNDF2C",122,0) new DIC,X,Y "RTN","TMGNDF2C",123,0) set DIC=50.6 "RTN","TMGNDF2C",124,0) set DIC(0)="M" ;"multiple index, LAYGO (add if not found) "RTN","TMGNDF2C",125,0) "RTN","TMGNDF2C",126,0) new abort set abort=0 "RTN","TMGNDF2C",127,0) new temp set temp="" "RTN","TMGNDF2C",128,0) new count set count=1 "RTN","TMGNDF2C",129,0) new TMGGeneric "RTN","TMGNDF2C",130,0) new Itr,i "RTN","TMGNDF2C",131,0) set i=$$ItrAInit^TMGITR("Array",.Itr) "RTN","TMGNDF2C",132,0) do PrepProgress^TMGITR(.Itr,20,1,"i") "RTN","TMGNDF2C",133,0) if i'="" for do quit:($$ItrANext^TMGITR(.Itr,.i)="")!abort "RTN","TMGNDF2C",134,0) . set X=i,TMGGeneric=i "RTN","TMGNDF2C",135,0) . set DIC(0)="M" do ^DIC "RTN","TMGNDF2C",136,0) . if Y=-1 set DIC(0)="MX" do ^DIC "RTN","TMGNDF2C",137,0) . if +Y>0 do quit "RTN","TMGNDF2C",138,0) . . set Results("Uncertain Matches",count,TMGGeneric,$piece(Y,"^",2))=Y "RTN","TMGNDF2C",139,0) . . set count=count+1 "RTN","TMGNDF2C",140,0) . new list "RTN","TMGNDF2C",141,0) . do FindSimGenerics(TMGGeneric,.list) "RTN","TMGNDF2C",142,0) . if $data(list) do "RTN","TMGNDF2C",143,0) . . merge Results("Uncertain Matches",count,TMGGeneric)=list "RTN","TMGNDF2C",144,0) . . set count=count+1 ;"is this right??? "RTN","TMGNDF2C",145,0) . else do "RTN","TMGNDF2C",146,0) . . set Results("Should Add",count,TMGGeneric)="" "RTN","TMGNDF2C",147,0) . . set count=count+1 "RTN","TMGNDF2C",148,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2C",149,0) "RTN","TMGNDF2C",150,0) CGDone "RTN","TMGNDF2C",151,0) quit "RTN","TMGNDF2C",152,0) "RTN","TMGNDF2C",153,0) Rescan(Array,Label,number) "RTN","TMGNDF2C",154,0) ;"Purpose: to allow rescan of one entry "RTN","TMGNDF2C",155,0) ;"Input: Array -- PASS BY REFERENCE -- Array with drug lists, as used by CheckGenerics "RTN","TMGNDF2C",156,0) ;" Label -- i.e. "Uncertain Matches", or "Should Add" "RTN","TMGNDF2C",157,0) ;" number -- the number of the listing to rescan "RTN","TMGNDF2C",158,0) ;" NOTE: This affects Results from a global scope "RTN","TMGNDF2C",159,0) ;" ??? Was this intended ??? "RTN","TMGNDF2C",160,0) ;"Output: "RTN","TMGNDF2C",161,0) ;"results: none "RTN","TMGNDF2C",162,0) "RTN","TMGNDF2C",163,0) new DIC,X,Y "RTN","TMGNDF2C",164,0) set DIC=50.6 "RTN","TMGNDF2C",165,0) set DIC(0)="M" ;"multiple index, LAYGO (add if not found) "RTN","TMGNDF2C",166,0) "RTN","TMGNDF2C",167,0) set X=$order(Array(Label,number,"")) "RTN","TMGNDF2C",168,0) if X'="" do "RTN","TMGNDF2C",169,0) . do ^DIC "RTN","TMGNDF2C",170,0) . if +Y'>0 do "RTN","TMGNDF2C",171,0) . . new list "RTN","TMGNDF2C",172,0) . . do FindSimGenerics(X,.list) "RTN","TMGNDF2C",173,0) . . if $data(list) do "RTN","TMGNDF2C",174,0) . . . merge Results("Uncertain Matches",number,X)=list "RTN","TMGNDF2C",175,0) . . else do "RTN","TMGNDF2C",176,0) . . . set Results("Should Add",number,X)="" "RTN","TMGNDF2C",177,0) . else set Results(X)=Y "RTN","TMGNDF2C",178,0) "RTN","TMGNDF2C",179,0) quit "RTN","TMGNDF2C",180,0) "RTN","TMGNDF2C",181,0) "RTN","TMGNDF2C",182,0) FindSimGenerics(Generic,Array) "RTN","TMGNDF2C",183,0) ;"Purpose: to scan VA GENERIC file and return an array of similar entries. "RTN","TMGNDF2C",184,0) ;"Input: Generic: the name of the generic drug name to scan for "RTN","TMGNDF2C",185,0) ;" Array: PASS BY REFERENCE, and OUT PARAMETER -- prior entries are killed "RTN","TMGNDF2C",186,0) ;"Result: none (output is in Array) "RTN","TMGNDF2C",187,0) "RTN","TMGNDF2C",188,0) new i,i2,s "RTN","TMGNDF2C",189,0) kill Array "RTN","TMGNDF2C",190,0) new NumRxs "RTN","TMGNDF2C",191,0) set NumRxs=$length(Generic,"/") "RTN","TMGNDF2C",192,0) "RTN","TMGNDF2C",193,0) set i2=$order(^PSNDF(50.6,0)) "RTN","TMGNDF2C",194,0) if i2'="" for do quit:(i2="") "RTN","TMGNDF2C",195,0) . new VAGeneric set VAGeneric=$piece($get(^PSNDF(50.6,i2,0)),"^",1) "RTN","TMGNDF2C",196,0) . new IEN set IEN=i2 "RTN","TMGNDF2C",197,0) . set i2=$order(^PSNDF(50.6,i2)) "RTN","TMGNDF2C",198,0) . if NumRxs'=$length(VAGeneric,"/") quit "RTN","TMGNDF2C",199,0) . new temp set temp=VAGeneric "RTN","TMGNDF2C",200,0) . for i=1:1:NumRxs do quit:(s="")!(temp="") "RTN","TMGNDF2C",201,0) . . set s=$piece(Generic,"/",i) "RTN","TMGNDF2C",202,0) . . set s=$piece(s," ",1) ;"get first word of multi-word drug name "RTN","TMGNDF2C",203,0) . . if s="" quit "RTN","TMGNDF2C",204,0) . . if $extract(VAGeneric,1,$length(s))'=s set temp="" "RTN","TMGNDF2C",205,0) . if temp'="" do "RTN","TMGNDF2C",206,0) . . set Array(VAGeneric)=IEN_"^"_VAGeneric "RTN","TMGNDF2C",207,0) "RTN","TMGNDF2C",208,0) new count "RTN","TMGNDF2C",209,0) set count=$$ListCt^TMGMISC("Array") "RTN","TMGNDF2C",210,0) if count>1 do "RTN","TMGNDF2C",211,0) . do NarrowGenMatches(Generic,.Array) "RTN","TMGNDF2C",212,0) . if (($$ListCt^TMGMISC("Array")/count)>0.5)&(count>5) do ;"i.e. no improvement "RTN","TMGNDF2C",213,0) . . kill Array "RTN","TMGNDF2C",214,0) "RTN","TMGNDF2C",215,0) quit "RTN","TMGNDF2C",216,0) "RTN","TMGNDF2C",217,0) "RTN","TMGNDF2C",218,0) NarrowGenMatches(Generic,Array,DivCh) "RTN","TMGNDF2C",219,0) ;"Purpose: To take a number of matches, and weed out bad matches (narrow down the list). "RTN","TMGNDF2C",220,0) ;"Input: Generic -- Name of Generic name that ideal match should equal "RTN","TMGNDF2C",221,0) ;" Array -- PASS BY REFERENCE, the array that needs trimming. "RTN","TMGNDF2C",222,0) ;" DivCH -- OPTIONAL, default="/" "RTN","TMGNDF2C",223,0) ;"Output: Array will be thinned if possible. "RTN","TMGNDF2C",224,0) ;"Results: none "RTN","TMGNDF2C",225,0) "RTN","TMGNDF2C",226,0) new i,j,result "RTN","TMGNDF2C",227,0) new MaxScore set MaxScore=0 "RTN","TMGNDF2C",228,0) set DivCh=$get(DivCh,"/") "RTN","TMGNDF2C",229,0) "RTN","TMGNDF2C",230,0) set i=$order(Array("")) "RTN","TMGNDF2C",231,0) if i'="" for do quit:(i="") "RTN","TMGNDF2C",232,0) . new score set score=0 "RTN","TMGNDF2C",233,0) . for j=1:1:$length(i,DivCh) do "RTN","TMGNDF2C",234,0) . . new GenIgd,ArrayIgd "RTN","TMGNDF2C",235,0) . . set GenIgd=$piece(Generic,DivCh,j) "RTN","TMGNDF2C",236,0) . . set ArrayIgd=$piece(i,DivCh,j) "RTN","TMGNDF2C",237,0) . . set score=score+$$Comp2Strs^TMGSTUTL(GenIgd,ArrayIgd) "RTN","TMGNDF2C",238,0) . if score>MaxScore set MaxScore=score "RTN","TMGNDF2C",239,0) . if score'0) "RTN","TMGNDF2C",294,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2C",295,0) . set name=$piece($get(^TMG(22706.9,IEN,0)),"^",6) ;"get field#.07, GENERIC NAME "RTN","TMGNDF2C",296,0) . set VAGeneric=$piece($get(^TMG(22706.9,IEN,1)),"^",3) ;"get field#.08, VA GENERIC "RTN","TMGNDF2C",297,0) . if (+name'=name)&(name'="")&(+VAGeneric=0) do "RTN","TMGNDF2C",298,0) . . set Array(name)="" "RTN","TMGNDF2C",299,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2C",300,0) "RTN","TMGNDF2C",301,0) quit "RTN","TMGNDF2C",302,0) "RTN","TMGNDF2C",303,0) "RTN","TMGNDF2C",304,0) ScanNoGenerics(Array) "RTN","TMGNDF2C",305,0) ;"Purpose: To scan TMG FDA IMPORT file and collect all entries into the array "RTN","TMGNDF2C",306,0) ;" where there is NO GENERIC NAME is provided, and VAGeneric pointer is NULL "RTN","TMGNDF2C",307,0) ;"Input -- Array -- PASS BY REFERENCE. An Out parameter "RTN","TMGNDF2C",308,0) ;"Results -- the Array is filled with names of drugs missing GENERICS NAME & VAGeneric Ptr "RTN","TMGNDF2C",309,0) ;" This will skip records marked to be skipped. "RTN","TMGNDF2C",310,0) "RTN","TMGNDF2C",311,0) new IEN "RTN","TMGNDF2C",312,0) new name,VAGeneric "RTN","TMGNDF2C",313,0) "RTN","TMGNDF2C",314,0) set IEN=$order(^TMG(22706.9,"")) "RTN","TMGNDF2C",315,0) if IEN'="" for do quit:(+IEN'>0) "RTN","TMGNDF2C",316,0) . new skip set skip=$piece($get(^TMG(22706.9,IEN,1)),"^",4) "RTN","TMGNDF2C",317,0) . if skip=0 do "RTN","TMGNDF2C",318,0) . . set name=$piece($get(^TMG(22706.9,IEN,0)),"^",6) ;"get field#.07, GENERIC NAME "RTN","TMGNDF2C",319,0) . . set VAGeneric=$piece($get(^TMG(22706.9,IEN,1)),"^",3) ;"get field#.08, VA GENERIC "RTN","TMGNDF2C",320,0) . . if (name="")&(+VAGeneric=0) do "RTN","TMGNDF2C",321,0) . . . if name["ALLERGENIC EXTRACT" quit ;"skip all these... I don't want them "RTN","TMGNDF2C",322,0) . . . new tradeName set tradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"get field#.05, TRADENAME "RTN","TMGNDF2C",323,0) . . . set Array(tradeName)="" "RTN","TMGNDF2C",324,0) . set IEN=$order(^TMG(22706.9,IEN)) "RTN","TMGNDF2C",325,0) "RTN","TMGNDF2C",326,0) quit "RTN","TMGNDF2C",327,0) "RTN","TMGNDF2C",328,0) "RTN","TMGNDF2C",329,0) "RTN","TMGNDF2C",330,0) Unlock50dot6 "RTN","TMGNDF2C",331,0) ;"note: could just set DUZ(0)="^" and not remove this... "RTN","TMGNDF2C",332,0) "RTN","TMGNDF2C",333,0) ;"Purpose: to remove the write restrictions for file 50.6 "RTN","TMGNDF2C",334,0) "RTN","TMGNDF2C",335,0) kill ^DIC(50.6,0,"LAYGO") "RTN","TMGNDF2C",336,0) kill ^DIC(50.6,0,"WR") "RTN","TMGNDF2C",337,0) kill ^DIC(50.6,0,"DEL") "RTN","TMGNDF2C",338,0) kill ^DD(50.6,.01,9) "RTN","TMGNDF2C",339,0) kill ^DD(50.6,.01,"DEL",.01,0) "RTN","TMGNDF2C",340,0) "RTN","TMGNDF2C",341,0) set XPDGREF=1 "RTN","TMGNDF2C",342,0) "RTN","TMGNDF2C",343,0) quit "RTN","TMGNDF2C",344,0) "RTN","TMGNDF2C",345,0) "RTN","TMGNDF2C",346,0) Lock50dot6 "RTN","TMGNDF2C",347,0) ;"Purpose: to restore the write restrictions for file 50.6 "RTN","TMGNDF2C",348,0) "RTN","TMGNDF2C",349,0) set ^DIC(50.6,0,"LAYGO")="^" "RTN","TMGNDF2C",350,0) set ^DIC(50.6,0,"WR")="^" "RTN","TMGNDF2C",351,0) set ^DIC(50.6,0,"DEL")="^" "RTN","TMGNDF2C",352,0) set ^DD(50.6,.01,9)="^" "RTN","TMGNDF2C",353,0) set ^DD(50.6,.01,"DEL",.01,0)="I 1 D EN^DDIOL(""DELETIONS ARE NOT ALLOWED"")" "RTN","TMGNDF2C",354,0) "RTN","TMGNDF2C",355,0) kill XPDGREF "RTN","TMGNDF2C",356,0) "RTN","TMGNDF2C",357,0) quit "RTN","TMGNDF2C",358,0) "RTN","TMGNDF2C",359,0) "RTN","TMGNDF2C",360,0) ShowList(Array,Label) "RTN","TMGNDF2C",361,0) ;"Purpose: To display the list generated by CheckGenerics "RTN","TMGNDF2C",362,0) ;"Input: Array -- the array containing the data "RTN","TMGNDF2C",363,0) ;" Label -- the name of the node to display "RTN","TMGNDF2C",364,0) "RTN","TMGNDF2C",365,0) new count,ingredient,value,first "RTN","TMGNDF2C",366,0) new someShown set someShown=0 "RTN","TMGNDF2C",367,0) set count=$order(Array(Label,"")) "RTN","TMGNDF2C",368,0) if count'="" for do quit:(count="") "RTN","TMGNDF2C",369,0) . new TMGGeneric,VAGeneric "RTN","TMGNDF2C",370,0) . set TMGGeneric=$order(Array(Label,count,"")) "RTN","TMGNDF2C",371,0) . set first=1 "RTN","TMGNDF2C",372,0) . set someShown=1 "RTN","TMGNDF2C",373,0) . set VAGeneric=$order(Array(Label,count,TMGGeneric,"")) "RTN","TMGNDF2C",374,0) . if VAGeneric'="" for do quit:(VAGeneric="") "RTN","TMGNDF2C",375,0) . . new next set next=$order(Array(Label,count,TMGGeneric,VAGeneric)) "RTN","TMGNDF2C",376,0) . . if first=1 do "RTN","TMGNDF2C",377,0) . . . if next'="" do "RTN","TMGNDF2C",378,0) . . . . write count,". ",TMGGeneric," ---> (multiple)",! "RTN","TMGNDF2C",379,0) . . . . write " ---> ",VAGeneric,! "RTN","TMGNDF2C",380,0) . . . else do "RTN","TMGNDF2C",381,0) . . . . write count,". ",TMGGeneric," ---> ",VAGeneric,! "RTN","TMGNDF2C",382,0) . . . set first=0 "RTN","TMGNDF2C",383,0) . . else write " ---> ",VAGeneric,! "RTN","TMGNDF2C",384,0) . . set VAGeneric=$order(Array(Label,count,TMGGeneric,VAGeneric)) "RTN","TMGNDF2C",385,0) . else do "RTN","TMGNDF2C",386,0) . . write count,". ",TMGGeneric,! "RTN","TMGNDF2C",387,0) . set count=$order(Array(Label,count)) "RTN","TMGNDF2C",388,0) "RTN","TMGNDF2C",389,0) if someShown=0 do "RTN","TMGNDF2C",390,0) . write " --- (List is Empty) ---",! "RTN","TMGNDF2C",391,0) "RTN","TMGNDF2C",392,0) quit "RTN","TMGNDF2C",393,0) "RTN","TMGNDF2C",394,0) ProcessList(Array) "RTN","TMGNDF2C",395,0) ;"Purpose: After list of linkages between GENERIC NAMEs and VA GENERIC names "RTN","TMGNDF2C",396,0) ;" is created by CheckGenerics(), then this function will handle adding those "RTN","TMGNDF2C",397,0) ;" generic names that need adding, and returning a list of linkages to use those "RTN","TMGNDF2C",398,0) ;" cases there an entry already exists that is not exactly the same, but will be "RTN","TMGNDF2C",399,0) ;" used as equivalent. "RTN","TMGNDF2C",400,0) ;"Input: Array -- PASS BY REFERENCE the array generated by CheckGenerics "RTN","TMGNDF2C",401,0) ;" Results are passed back in Array "RTN","TMGNDF2C",402,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",403,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",404,0) ;"Results: none "RTN","TMGNDF2C",405,0) "RTN","TMGNDF2C",406,0) new datafound,abort "RTN","TMGNDF2C",407,0) set abort=0 "RTN","TMGNDF2C",408,0) "RTN","TMGNDF2C",409,0) for do quit:(datafound=0)!(abort=1) "RTN","TMGNDF2C",410,0) . set datafound=0 "RTN","TMGNDF2C",411,0) . if $data(Array("Should Add"))>0 do quit:(abort=1) "RTN","TMGNDF2C",412,0) . . set datafound=1 "RTN","TMGNDF2C",413,0) . . write !!,"There are entries that should be added to the VA GENERIC file",! "RTN","TMGNDF2C",414,0) . . write "Process now (^ to abort)" "RTN","TMGNDF2C",415,0) . . new % set %=1 ;"default to YES "RTN","TMGNDF2C",416,0) . . do YN^DICN write ! "RTN","TMGNDF2C",417,0) . . if %=-1 set abort=1 quit "RTN","TMGNDF2C",418,0) . . if %=1 do HandleAdds(.Array) "RTN","TMGNDF2C",419,0) . if $data(Array("Uncertain Matches"))>0 do "RTN","TMGNDF2C",420,0) . . set datafound=1 "RTN","TMGNDF2C",421,0) . . write !!,"There are presumed linkages that need approval.",! "RTN","TMGNDF2C",422,0) . . write "Process now (^ to abort)" "RTN","TMGNDF2C",423,0) . . new % set %=1 ;"default to YES "RTN","TMGNDF2C",424,0) . . do YN^DICN write ! "RTN","TMGNDF2C",425,0) . . if %=-1 set abort=1 quit "RTN","TMGNDF2C",426,0) . . if %=1 do HandleQAdds(.Array) "RTN","TMGNDF2C",427,0) "RTN","TMGNDF2C",428,0) quit "RTN","TMGNDF2C",429,0) "RTN","TMGNDF2C",430,0) "RTN","TMGNDF2C",431,0) HandleAdds(Array) "RTN","TMGNDF2C",432,0) ;"Purpose: To handle adding those entries in Array that need to be added to VA GENERIC file. "RTN","TMGNDF2C",433,0) ;"Input: Array -- PASS BY REFERENCE the array generated by CheckGenerics "RTN","TMGNDF2C",434,0) ;" Results are passed back in Array "RTN","TMGNDF2C",435,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",436,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",437,0) ;"Output: results returned in Array, as above. "RTN","TMGNDF2C",438,0) ;"Results: none "RTN","TMGNDF2C",439,0) "RTN","TMGNDF2C",440,0) do Unlock50dot6 "RTN","TMGNDF2C",441,0) "RTN","TMGNDF2C",442,0) new done set done=0 "RTN","TMGNDF2C",443,0) new input set input="R" "RTN","TMGNDF2C",444,0) "RTN","TMGNDF2C",445,0) for do quit:(done=1) "RTN","TMGNDF2C",446,0) . if input="R" do "RTN","TMGNDF2C",447,0) . . write !! "RTN","TMGNDF2C",448,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",449,0) . . write "Specify which GENERIC names are OK for ADDITION to VA GENERIC file",! "RTN","TMGNDF2C",450,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",451,0) . . do ShowList(.Array,"Should Add") "RTN","TMGNDF2C",452,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",453,0) . . write "Specify which GENERIC names are OK for ADDITION to VA GENERIC file",! "RTN","TMGNDF2C",454,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",455,0) . write " R to refresh, L lookup, ? for instructions",! "RTN","TMGNDF2C",456,0) . write " # or #-#, ^ to continue, X remove from list",! "RTN","TMGNDF2C",457,0) . write "Enter number(s) to ACCEPT (or codes listed above): ^//" "RTN","TMGNDF2C",458,0) . read input,! "RTN","TMGNDF2C",459,0) . if input="" set input="^" "RTN","TMGNDF2C",460,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF2C",461,0) . if input="^" set done=1 "RTN","TMGNDF2C",462,0) . if (input="?") do "RTN","TMGNDF2C",463,0) . . ;"do ShowInstructions "RTN","TMGNDF2C",464,0) . . set input="R" "RTN","TMGNDF2C",465,0) . if +input=input do "RTN","TMGNDF2C",466,0) . . do DoAdds(.Array,"Should Add",+input) "RTN","TMGNDF2C",467,0) . . set input="R" "RTN","TMGNDF2C",468,0) . if input["-" do "RTN","TMGNDF2C",469,0) . . new N1,N2 "RTN","TMGNDF2C",470,0) . . set N1=$piece(input,"-",1) "RTN","TMGNDF2C",471,0) . . set N2=$piece(input,"-",2) "RTN","TMGNDF2C",472,0) . . do DoAdds(.Array,"Should Add",N1,N2) "RTN","TMGNDF2C",473,0) . . set input="R" "RTN","TMGNDF2C",474,0) . if input="L" do "RTN","TMGNDF2C",475,0) . . read "Enter number to lookup manually: ",input,! "RTN","TMGNDF2C",476,0) . . do CustLookup(.Array,"Should Add",+input) "RTN","TMGNDF2C",477,0) . . set input="R" "RTN","TMGNDF2C",478,0) . if input="X" do "RTN","TMGNDF2C",479,0) . . read "Enter number(s) to REMOVE from list: ",input,! "RTN","TMGNDF2C",480,0) . . if +input=input do "RTN","TMGNDF2C",481,0) . . . do Remove(.Array,"Should Add",+input) "RTN","TMGNDF2C",482,0) . . if input["-" do "RTN","TMGNDF2C",483,0) . . . new N1,N2 "RTN","TMGNDF2C",484,0) . . . set N1=$piece(input,"-",1) "RTN","TMGNDF2C",485,0) . . . set N2=$piece(input,"-",2) "RTN","TMGNDF2C",486,0) . . . do Remove(.Array,"Should Add",N1,N2) "RTN","TMGNDF2C",487,0) . . set input="R" "RTN","TMGNDF2C",488,0) "RTN","TMGNDF2C",489,0) do Lock50dot6 "RTN","TMGNDF2C",490,0) quit "RTN","TMGNDF2C",491,0) "RTN","TMGNDF2C",492,0) "RTN","TMGNDF2C",493,0) Remove(Array,Label,Num,EndNum) "RTN","TMGNDF2C",494,0) ;"Purpose: To remove name(s) from Array of additions to VA GENERIC file "RTN","TMGNDF2C",495,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by CheckGenerics() "RTN","TMGNDF2C",496,0) ;" Label -- the section of the array to extract from (i.e. "Already Present", or "Should Add" etc.) "RTN","TMGNDF2C",497,0) ;" Num -- entry number to add "RTN","TMGNDF2C",498,0) ;" EndNum -- OPTIONAL. If supplied, then range of Num-EndNum are all added. "RTN","TMGNDF2C",499,0) ;"Output: Those values that are removed are changed to a different node, i.e. "RTN","TMGNDF2C",500,0) ;" Array("Should Add",count,Generic)="" "RTN","TMGNDF2C",501,0) ;"Results: none "RTN","TMGNDF2C",502,0) "RTN","TMGNDF2C",503,0) set EndNum=$get(EndNum,Num) "RTN","TMGNDF2C",504,0) new i,Generic,Y "RTN","TMGNDF2C",505,0) "RTN","TMGNDF2C",506,0) for i=Num:1:EndNum do "RTN","TMGNDF2C",507,0) . set Generic=$order(Array(Label,i,"")) "RTN","TMGNDF2C",508,0) . if Generic'="" do "RTN","TMGNDF2C",509,0) . . ;"set Array("Rescan",i,Generic)="" "RTN","TMGNDF2C",510,0) . . set Array("Should Add",i,Generic)="" "RTN","TMGNDF2C",511,0) . . kill Array(Label,i) "RTN","TMGNDF2C",512,0) "RTN","TMGNDF2C",513,0) quit "RTN","TMGNDF2C",514,0) "RTN","TMGNDF2C",515,0) "RTN","TMGNDF2C",516,0) CustLookup(Array,Label,Num) "RTN","TMGNDF2C",517,0) ;"Purpose: To manually link entry in Array to an existing entry in VA GENERIC file "RTN","TMGNDF2C",518,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by CheckGenerics() "RTN","TMGNDF2C",519,0) ;" Results are passed back in Array "RTN","TMGNDF2C",520,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",521,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",522,0) ;" Label -- the section of the array to extract from (i.e. "Already Present", or "Should Add" etc.) "RTN","TMGNDF2C",523,0) ;" Num -- entry number to add "RTN","TMGNDF2C",524,0) ;"Results: none "RTN","TMGNDF2C",525,0) "RTN","TMGNDF2C",526,0) new DIC,X,Y,Generic "RTN","TMGNDF2C",527,0) set DIC=50.6 "RTN","TMGNDF2C",528,0) set DIC(0)="AEQM" "RTN","TMGNDF2C",529,0) "RTN","TMGNDF2C",530,0) set Generic=$order(Array(Label,Num,"")) "RTN","TMGNDF2C",531,0) if Generic'="" do "RTN","TMGNDF2C",532,0) . write !,"Look up an entry to match with: ",Generic "RTN","TMGNDF2C",533,0) . do ^DIC "RTN","TMGNDF2C",534,0) . if +Y>0 do "RTN","TMGNDF2C",535,0) . . kill Array(Label,Num,Generic) "RTN","TMGNDF2C",536,0) . . set Array(Generic)=Y "RTN","TMGNDF2C",537,0) "RTN","TMGNDF2C",538,0) quit "RTN","TMGNDF2C",539,0) "RTN","TMGNDF2C",540,0) "RTN","TMGNDF2C",541,0) DoAdds(Array,Label,Num,EndNum) "RTN","TMGNDF2C",542,0) ;"Purpose: To extract name(s) from Array and add to VA GENERIC file, via Add1Generic "RTN","TMGNDF2C",543,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by CheckGenerics() "RTN","TMGNDF2C",544,0) ;" Results -- PASS BY REFERENCE. An OUT array to received results "RTN","TMGNDF2C",545,0) ;" Results(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",546,0) ;" Results(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",547,0) ;" Label -- the section of the array to extract from (i.e. "Already Present", or "Should Add" etc.) "RTN","TMGNDF2C",548,0) ;" Num -- entry number to add "RTN","TMGNDF2C",549,0) ;" EndNum -- OPTIONAL. If supplied, then range of Num-EndNum are all added. "RTN","TMGNDF2C",550,0) ;"Results: none "RTN","TMGNDF2C",551,0) "RTN","TMGNDF2C",552,0) set EndNum=$get(EndNum,Num) "RTN","TMGNDF2C",553,0) new i,Generic,Y "RTN","TMGNDF2C",554,0) "RTN","TMGNDF2C",555,0) for i=Num:1:EndNum do "RTN","TMGNDF2C",556,0) . set Generic=$order(Array(Label,i,"")) "RTN","TMGNDF2C",557,0) . if Generic'="" do "RTN","TMGNDF2C",558,0) . . set Y=$$Add1Generic(Generic) "RTN","TMGNDF2C",559,0) . . if +Y>0 do "RTN","TMGNDF2C",560,0) . . . set Array(Generic)=Y "RTN","TMGNDF2C",561,0) . . . kill Array(Label,i,Generic) "RTN","TMGNDF2C",562,0) . . . ;"set Array("Already Present",i,Generic)=Y "RTN","TMGNDF2C",563,0) "RTN","TMGNDF2C",564,0) quit "RTN","TMGNDF2C",565,0) "RTN","TMGNDF2C",566,0) "RTN","TMGNDF2C",567,0) Add1Generic(Name) "RTN","TMGNDF2C",568,0) ;"Purpose: To add on entry to the VA GENERIC FILE "RTN","TMGNDF2C",569,0) ;"Input: the name of the genric to be added. Should be 3-64 characters in length "RTN","TMGNDF2C",570,0) ;"Results: returns the added entry: IEN^NAME, or -1 if Fileman error "RTN","TMGNDF2C",571,0) ;"Note: This function assumes that the file as been UNLOCKED via Unlock50dot6 "RTN","TMGNDF2C",572,0) "RTN","TMGNDF2C",573,0) new X,DIC "RTN","TMGNDF2C",574,0) set DIC=50.6 "RTN","TMGNDF2C",575,0) set DIC(0)="XL" "RTN","TMGNDF2C",576,0) set X=Name "RTN","TMGNDF2C",577,0) do ^DIC "RTN","TMGNDF2C",578,0) "RTN","TMGNDF2C",579,0) quit Y "RTN","TMGNDF2C",580,0) "RTN","TMGNDF2C",581,0) "RTN","TMGNDF2C",582,0) ;"-------------------------------- "RTN","TMGNDF2C",583,0) "RTN","TMGNDF2C",584,0) HandleQAdds(Array) "RTN","TMGNDF2C",585,0) ;"Purpose: To review 'Uncertain Matches' node of Array and allow user to specify whether "RTN","TMGNDF2C",586,0) ;" to accept equivilence of match, or to disallow link and add new GENERIC name. "RTN","TMGNDF2C",587,0) ;"Input: Array -- PASS BY REFERENCE the array generated by CheckGenerics "RTN","TMGNDF2C",588,0) ;" Results are passed back in Array "RTN","TMGNDF2C",589,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",590,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",591,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file "RTN","TMGNDF2C",592,0) ;"Output: results returned in Results array, as above. "RTN","TMGNDF2C",593,0) ;"Results: none "RTN","TMGNDF2C",594,0) "RTN","TMGNDF2C",595,0) do Unlock50dot6 "RTN","TMGNDF2C",596,0) "RTN","TMGNDF2C",597,0) new done set done=0 "RTN","TMGNDF2C",598,0) new input set input="R" "RTN","TMGNDF2C",599,0) "RTN","TMGNDF2C",600,0) for do quit:(done=1) "RTN","TMGNDF2C",601,0) . if input="R" do "RTN","TMGNDF2C",602,0) . . write !! "RTN","TMGNDF2C",603,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",604,0) . . write "Specify which links between New --> Existing GENERIC names are OK",! "RTN","TMGNDF2C",605,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",606,0) . . do ShowList(.Array,"Uncertain Matches") "RTN","TMGNDF2C",607,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",608,0) . . write "Specify which links between New --> Existing GENERIC names are OK",! "RTN","TMGNDF2C",609,0) . . write "-------------------------------------------------------------------",! "RTN","TMGNDF2C",610,0) . write " R to refresh, ? for instructions",! "RTN","TMGNDF2C",611,0) . write " # or #-#, ^ to continue, X remove from list",! "RTN","TMGNDF2C",612,0) . write "Enter number(s) to ACCEPT (or codes listed above): ^//" "RTN","TMGNDF2C",613,0) . read input,! "RTN","TMGNDF2C",614,0) . if input="" set input="^" "RTN","TMGNDF2C",615,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF2C",616,0) . if input="^" set done=1 "RTN","TMGNDF2C",617,0) . if (input="?") do "RTN","TMGNDF2C",618,0) . . ;"do ShowInstructions "RTN","TMGNDF2C",619,0) . . set input="R" "RTN","TMGNDF2C",620,0) . if +input=input do "RTN","TMGNDF2C",621,0) . . do DoLinks(.Array,+input) "RTN","TMGNDF2C",622,0) . . set input="R" "RTN","TMGNDF2C",623,0) . if input["-" do "RTN","TMGNDF2C",624,0) . . new N1,N2 "RTN","TMGNDF2C",625,0) . . set N1=$piece(input,"-",1) "RTN","TMGNDF2C",626,0) . . set N2=$piece(input,"-",2) "RTN","TMGNDF2C",627,0) . . do DoLinks(.Array,N1,N2) "RTN","TMGNDF2C",628,0) . . set input="R" "RTN","TMGNDF2C",629,0) . if input="S" do "RTN","TMGNDF2C",630,0) . . read "Enter number to re-SCAN: ",input,! "RTN","TMGNDF2C",631,0) . . if +input=input do "RTN","TMGNDF2C",632,0) . . . do Rescan(.Array,"Uncertain Matches",+input) "RTN","TMGNDF2C",633,0) . if input="X" do "RTN","TMGNDF2C",634,0) . . read "Enter number(s) to REMOVE from list: ",input,! "RTN","TMGNDF2C",635,0) . . if +input=input do "RTN","TMGNDF2C",636,0) . . . do Remove(.Array,"Uncertain Matches",+input) "RTN","TMGNDF2C",637,0) . . if input["-" do "RTN","TMGNDF2C",638,0) . . . new N1,N2 "RTN","TMGNDF2C",639,0) . . . set N1=$piece(input,"-",1) "RTN","TMGNDF2C",640,0) . . . set N2=$piece(input,"-",2) "RTN","TMGNDF2C",641,0) . . . ;"do Remove(.Array,"Uncertain Matches",N1,N2) "RTN","TMGNDF2C",642,0) . . set input="R" "RTN","TMGNDF2C",643,0) "RTN","TMGNDF2C",644,0) do Lock50dot6 "RTN","TMGNDF2C",645,0) quit "RTN","TMGNDF2C",646,0) "RTN","TMGNDF2C",647,0) "RTN","TMGNDF2C",648,0) DoLinks(Array,Num,EndNum) "RTN","TMGNDF2C",649,0) ;"Purpose: To change a link from the "Uncertain Matches" node, to a formal link "RTN","TMGNDF2C",650,0) ;"Input: Array -- PASS BY REFERENCE the array generated by CheckGenerics "RTN","TMGNDF2C",651,0) ;" Results are passed back in Array "RTN","TMGNDF2C",652,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",653,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",654,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",655,0) ;" Num -- entry number to add "RTN","TMGNDF2C",656,0) ;" EndNum -- OPTIONAL. If supplied, then range of Num-EndNum are all added. "RTN","TMGNDF2C",657,0) ;"Results: none "RTN","TMGNDF2C",658,0) "RTN","TMGNDF2C",659,0) set EndNum=$get(EndNum,Num) "RTN","TMGNDF2C",660,0) new i,TMGGeneric,VAGeneric,Y "RTN","TMGNDF2C",661,0) "RTN","TMGNDF2C",662,0) for i=Num:1:EndNum do "RTN","TMGNDF2C",663,0) . set TMGGeneric=$order(Array("Uncertain Matches",i,"")) "RTN","TMGNDF2C",664,0) . if TMGGeneric'="" do "RTN","TMGNDF2C",665,0) . . if $data(Array("Uncertain Matches",i,TMGGeneric))=1 do "RTN","TMGNDF2C",666,0) . . . set VAGeneric=$order(Array("Uncertain Matches",i,TMGGeneric,"")) "RTN","TMGNDF2C",667,0) . . . set Y=$get(Array("Uncertain Matches",i,TMGGeneric,VAGeneric)) "RTN","TMGNDF2C",668,0) . . else do ;"pick from multiple options. "RTN","TMGNDF2C",669,0) . . . set Y=$$DoMltLink(.Array,i,TMGGeneric) "RTN","TMGNDF2C",670,0) . . if +Y>0 do "RTN","TMGNDF2C",671,0) . . . ;"kill Array("Uncertain Matches",i,TMGGeneric,VAGeneric) "RTN","TMGNDF2C",672,0) . . . kill Array("Uncertain Matches",i,TMGGeneric) "RTN","TMGNDF2C",673,0) . . . set Array(TMGGeneric)=Y "RTN","TMGNDF2C",674,0) "RTN","TMGNDF2C",675,0) quit "RTN","TMGNDF2C",676,0) "RTN","TMGNDF2C",677,0) DoMltLink(Array,Num,TMGGeneric) "RTN","TMGNDF2C",678,0) ;"Purpose: To interact with user and pick which link (amoung multiple) "RTN","TMGNDF2C",679,0) ;"Input: Array -- PASS BY REFERENCE. Array as created by CheckGenerics "RTN","TMGNDF2C",680,0) ;" Num -- The number in the "Uncertain Matches" to pick amoung. "RTN","TMGNDF2C",681,0) ;" TMGGeneric -- the Generic Name for to look for a match to "RTN","TMGNDF2C",682,0) ;"Results: The selected link: i.e. IEN^Name, or "" if not found "RTN","TMGNDF2C",683,0) "RTN","TMGNDF2C",684,0) "RTN","TMGNDF2C",685,0) new VAGeneric,j,tempResults "RTN","TMGNDF2C",686,0) new name,input,result "RTN","TMGNDF2C",687,0) new NumAnswers set NumAnswers=0 "RTN","TMGNDF2C",688,0) "RTN","TMGNDF2C",689,0) set VAGeneric=$order(Array("Uncertain Matches",Num,TMGGeneric,"")) "RTN","TMGNDF2C",690,0) if VAGeneric'="" for j=1:1 do quit:(VAGeneric="") "RTN","TMGNDF2C",691,0) . set tempResults(j)=$get(Array("Uncertain Matches",Num,TMGGeneric,VAGeneric)) "RTN","TMGNDF2C",692,0) . set NumAnswers=j "RTN","TMGNDF2C",693,0) . set VAGeneric=$order(Array("Uncertain Matches",Num,TMGGeneric,VAGeneric)) "RTN","TMGNDF2C",694,0) "RTN","TMGNDF2C",695,0) if NumAnswers=1 set result=$get(tempResult(1)) goto DMLDone "RTN","TMGNDF2C",696,0) "RTN","TMGNDF2C",697,0) write "Please select match for ",TMGGeneric,! "RTN","TMGNDF2C",698,0) for j=1:1 do quit:(name="") "RTN","TMGNDF2C",699,0) . set name=$get(tempResult(j)) "RTN","TMGNDF2C",700,0) . if name="" quit "RTN","TMGNDF2C",701,0) . write " ",j,". ",$piece(name,"^",2),! "RTN","TMGNDF2C",702,0) "RTN","TMGNDF2C",703,0) read "Enter number of match (^ to quit): ^// ",input,! "RTN","TMGNDF2C",704,0) set result=$get(tempResult(+input)) "RTN","TMGNDF2C",705,0) "RTN","TMGNDF2C",706,0) DMLDone "RTN","TMGNDF2C",707,0) quit result "RTN","TMGNDF2C",708,0) "RTN","TMGNDF2C",709,0) "RTN","TMGNDF2C",710,0) ;"=========================================================================== "RTN","TMGNDF2C",711,0) "RTN","TMGNDF2C",712,0) FillCompFile(Array) "RTN","TMGNDF2C",713,0) ;"Purpose: To take the list (generated in FillGenerics(), with its linkages "RTN","TMGNDF2C",714,0) ;" between new drug names and existing drug name data, and fill "RTN","TMGNDF2C",715,0) ;" in field .08 in file TMG FDA IMPORT COMPILED "RTN","TMGNDF2C",716,0) ;"Input: Array -- PASS BY REFERENCE. List of linkages between names. "RTN","TMGNDF2C",717,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",718,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",719,0) ;" Array(GENERIC NAME)=IEN in VA GENERIC file^Name "RTN","TMGNDF2C",720,0) ;"Output: Data is put into TMG FDA IMPORT COMPILED "RTN","TMGNDF2C",721,0) ;"Results: none "RTN","TMGNDF2C",722,0) "RTN","TMGNDF2C",723,0) write "Filling field .08 (VA GENERIC) in file TMG FDA IMPORT COMPILED",! "RTN","TMGNDF2C",724,0) write "based on data from field .07 (GENERIC NAME)...",! "RTN","TMGNDF2C",725,0) "RTN","TMGNDF2C",726,0) new TMGGeneric,VAGeneric "RTN","TMGNDF2C",727,0) new IEN,oldval "RTN","TMGNDF2C",728,0) new count set count=0 "RTN","TMGNDF2C",729,0) "RTN","TMGNDF2C",730,0) new Itr,IEN "RTN","TMGNDF2C",731,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2C",732,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2C",733,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2C",734,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2C",735,0) . set TMGGeneric=$piece($get(^TMG(22706.9,IEN,0)),"^",6) ;"0;6 --> field .07, GENERIC NAME "RTN","TMGNDF2C",736,0) . set oldval=$piece($get(^TMG(22706.9,IEN,1)),"^",3) ;"1;3 --> field .08, VA GENERIC "RTN","TMGNDF2C",737,0) . if (+oldval'=0)!(TMGGeneric="") quit "RTN","TMGNDF2C",738,0) . set VAGeneric=$get(Array(TMGGeneric)) "RTN","TMGNDF2C",739,0) . if +VAGeneric>0 do "RTN","TMGNDF2C",740,0) . . if +VAGeneric'=oldval do "RTN","TMGNDF2C",741,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF2C",742,0) . . set TMGFDA(22706.9,IEN_",",.08)=+VAGeneric "RTN","TMGNDF2C",743,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2C",744,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2C",745,0) . . set count=count+1 "RTN","TMGNDF2C",746,0) . . ;"write "Stored ",$piece(VAGeneric,"^",2)," in record# ",IEN,! "RTN","TMGNDF2C",747,0) . else do "RTN","TMGNDF2C",748,0) . . write !,"Can't find entry for: ",TMGGeneric,! "RTN","TMGNDF2C",749,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2C",750,0) write count," records modified.",! "RTN","TMGNDF2C",751,0) "RTN","TMGNDF2C",752,0) quit "RTN","TMGNDF2C",753,0) "RTN","TMGNDF2C",754,0) "RTN","TMGNDF2C",755,0) "RTN","TMGNDF2E") 0^44^B10640 "RTN","TMGNDF2E",1,0) TMGNDF2E ;TMG/kst/FDA Import: Fix ingredients IEN linkages ;03/25/06 "RTN","TMGNDF2E",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF2E",3,0) "RTN","TMGNDF2E",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF2E",5,0) ;" Further processing, after functions in TMGNDF2D "RTN","TMGNDF2E",6,0) ;" Fixing ingredients IEN linkages "RTN","TMGNDF2E",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDF2E",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF2E",9,0) ;"11-21-2006 "RTN","TMGNDF2E",10,0) "RTN","TMGNDF2E",11,0) ;"======================================================================= "RTN","TMGNDF2E",12,0) ;" API -- Public Functions. "RTN","TMGNDF2E",13,0) ;"======================================================================= "RTN","TMGNDF2E",14,0) ;"Menu "RTN","TMGNDF2E",15,0) ;"======================================================================= "RTN","TMGNDF2E",16,0) ;"FixMissing -- Find and fix missing ingredient IEN's in TMG FDA IMPORT COMPILED "RTN","TMGNDF2E",17,0) "RTN","TMGNDF2E",18,0) ;"======================================================================= "RTN","TMGNDF2E",19,0) ;" Private Functions. "RTN","TMGNDF2E",20,0) ;"======================================================================= "RTN","TMGNDF2E",21,0) ;"FindMissing(Array) "RTN","TMGNDF2E",22,0) ;"EasyFix(Array) ;handle the easy fixes from Array (created by FindMissing) "RTN","TMGNDF2E",23,0) ;"HardFix(Array) ;handle the more difficult fixes from Array (created by FindMissing) "RTN","TMGNDF2E",24,0) ;"GetRxIEN(RxName,pDrugInfo) ;get the IEN of the given drug name "RTN","TMGNDF2E",25,0) "RTN","TMGNDF2E",26,0) ;"BatchNDCFix -- Scan TMG FDA IMPORT COMPILED file, and fix NDC codes "RTN","TMGNDF2E",27,0) ;"NewNDC(NDC) -- convert an NDC code with invalid formatting into one acceptible to VistA "RTN","TMGNDF2E",28,0) "RTN","TMGNDF2E",29,0) "RTN","TMGNDF2E",30,0) ;"======================================================================= "RTN","TMGNDF2E",31,0) ;"======================================================================= "RTN","TMGNDF2E",32,0) "RTN","TMGNDF2E",33,0) ;"Notes: I have discovered, when I went to actually add entries from "RTN","TMGNDF2E",34,0) ;" TMG NDF IMPORT COMPILED into VA PRODUCT, that many of the ingredients "RTN","TMGNDF2E",35,0) ;" did not have appropriate links to a VA drug. I am not sure how this "RTN","TMGNDF2E",36,0) ;" happened. Perhaps the drugs had not been added at the time that the "RTN","TMGNDF2E",37,0) ;" compiled entry was create? Perhaps it was drug ingredient that I "RTN","TMGNDF2E",38,0) ;" chose to skip? Anyway, the purpose of this code is to fix this problem. "RTN","TMGNDF2E",39,0) ;" And since I don't know at which step the problem occured, and I am "RTN","TMGNDF2E",40,0) ;" unwilling to put the HOURS of classification work in again if I were "RTN","TMGNDF2E",41,0) ;" to start over, I will just fix the problem at this step of the process. "RTN","TMGNDF2E",42,0) "RTN","TMGNDF2E",43,0) ;"======================================================================= "RTN","TMGNDF2E",44,0) "RTN","TMGNDF2E",45,0) Menu "RTN","TMGNDF2E",46,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF2E",47,0) "RTN","TMGNDF2E",48,0) new Menu,UsrSlct "RTN","TMGNDF2E",49,0) set Menu(0)="Pick Option for Fixing Missing Ingredients (2E)" "RTN","TMGNDF2E",50,0) set Menu(1)="Fix UNMATCHED ingredients in import."_$char(9)_"FixMissing" "RTN","TMGNDF2E",51,0) set Menu(2)="Fix MISSING ingredients in import."_$char(9)_"FixMissing2" "RTN","TMGNDF2E",52,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF2E",53,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF2E",54,0) "RTN","TMGNDF2E",55,0) MC1 write # "RTN","TMGNDF2E",56,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF2E",57,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF2E",58,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF2E",59,0) "RTN","TMGNDF2E",60,0) if UsrSlct="FixMissing" do FixMissing goto MC1 "RTN","TMGNDF2E",61,0) if UsrSlct="FixMissing2" do FixMissing^TMGNDF2F goto MC1 "RTN","TMGNDF2E",62,0) if UsrSlct="Prev" goto Menu^TMGNDF2C ;"quit can occur from there... "RTN","TMGNDF2E",63,0) if UsrSlct="Next" goto Menu^TMGNDF2G ;"quit can occur from there... "RTN","TMGNDF2E",64,0) goto MC1 "RTN","TMGNDF2E",65,0) "RTN","TMGNDF2E",66,0) MCDone "RTN","TMGNDF2E",67,0) quit "RTN","TMGNDF2E",68,0) "RTN","TMGNDF2E",69,0) "RTN","TMGNDF2E",70,0) "RTN","TMGNDF2E",71,0) FixMissing "RTN","TMGNDF2E",72,0) ;"Purpose: To find and fix missing ingredient IEN's in TMG FDA IMPORT COMPILED "RTN","TMGNDF2E",73,0) "RTN","TMGNDF2E",74,0) new Array "RTN","TMGNDF2E",75,0) write "Gathering missing ingredient link entries...",! "RTN","TMGNDF2E",76,0) do FindMissing(.Array) "RTN","TMGNDF2E",77,0) if $data(Array)=0 do goto FMDone "RTN","TMGNDF2E",78,0) . write !,"No missing entries. Great!",! "RTN","TMGNDF2E",79,0) write "Fixing easy problems...",! "RTN","TMGNDF2E",80,0) do EasyFix(.Array) "RTN","TMGNDF2E",81,0) write "Now to fix the more difficult problems...",! "RTN","TMGNDF2E",82,0) do HardFix(.Array) "RTN","TMGNDF2E",83,0) "RTN","TMGNDF2E",84,0) FMDone "RTN","TMGNDF2E",85,0) write "Done. Goodbye...",! "RTN","TMGNDF2E",86,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2E",87,0) quit "RTN","TMGNDF2E",88,0) "RTN","TMGNDF2E",89,0) "RTN","TMGNDF2E",90,0) "RTN","TMGNDF2E",91,0) FindMissing(Array) "RTN","TMGNDF2E",92,0) ;"Purpose: to scan TMG FDA IMPORT COMPILED and find ingredients that "RTN","TMGNDF2E",93,0) ;" don't have a linkage to a VA drug. "RTN","TMGNDF2E",94,0) ;"Input: Array -- PASS BY REFERENCE, it is an OUT PARAMETER. Format below "RTN","TMGNDF2E",95,0) ;" prior entries in array are NOT KILLED. "RTN","TMGNDF2E",96,0) ;"Output: Array is filled as follows: "RTN","TMGNDF2E",97,0) ;" Array(IEN,subIEN)=UnmatchedIngredientName "RTN","TMGNDF2E",98,0) ;" Array(IEN,subIEN,"FILE 50.416 IEN")=IEN "RTN","TMGNDF2E",99,0) ;" Array(IEN,subIEN)=UnmatchedIngredientName "RTN","TMGNDF2E",100,0) ;" Array(IEN,subIEN,"FILE 50.416 IEN")=IEN "RTN","TMGNDF2E",101,0) ;"Results: none. "RTN","TMGNDF2E",102,0) "RTN","TMGNDF2E",103,0) new Itr,IEN "RTN","TMGNDF2E",104,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2E",105,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2E",106,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2E",107,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;" 1=SKIP "RTN","TMGNDF2E",108,0) . new subIEN set subIEN=0 "RTN","TMGNDF2E",109,0) . for set subIEN=+$order(^TMG(22706.9,IEN,4,subIEN)) quit:(+subIEN'>0) do "RTN","TMGNDF2E",110,0) . . new node set node=$get(^TMG(22706.9,IEN,4,subIEN,0)) "RTN","TMGNDF2E",111,0) . . new ingredients set ingredients=$piece(node,"^",3) ;"INGREDIENTS "RTN","TMGNDF2E",112,0) . . if ingredients="" do "RTN","TMGNDF2E",113,0) . . . new FDAitemNum "RTN","TMGNDF2E",114,0) . . . set FDAitemNum=$piece($get(^TMG(22706.9,IEN,0)),"^",1) "RTN","TMGNDF2E",115,0) . . . new DrugInfo "RTN","TMGNDF2E",116,0) . . . new result "RTN","TMGNDF2E",117,0) . . . set result=$$GetDrugInfo^TMGNDF1C(FDAitemNum,.DrugInfo,"",1) "RTN","TMGNDF2E",118,0) . . . if result=0 do quit "RTN","TMGNDF2E",119,0) . . . . write "Unable to get drug info for entry: ",FDAitemNum,! "RTN","TMGNDF2E",120,0) . . . new ingrName,ingrIEN "RTN","TMGNDF2E",121,0) . . . set ingrName=$get(DrugInfo("FORMULATION",subIEN,"INGREDIENT NAME")) "RTN","TMGNDF2E",122,0) . . . set ingrIEN=$get(DrugInfo("FORMULATION",subIEN,"INGREDIENT NAME","FILE 50.416 IEN")) "RTN","TMGNDF2E",123,0) . . . set Array(IEN,subIEN)=ingrName "RTN","TMGNDF2E",124,0) . . . set Array(IEN,subIEN,"FILE 50.416 IEN")=ingrIEN "RTN","TMGNDF2E",125,0) . . . merge Array(IEN,subIEN,"INFO")=DrugInfo "RTN","TMGNDF2E",126,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2E",127,0) "RTN","TMGNDF2E",128,0) quit "RTN","TMGNDF2E",129,0) "RTN","TMGNDF2E",130,0) "RTN","TMGNDF2E",131,0) EasyFix(Array) "RTN","TMGNDF2E",132,0) ;"Purpose: to handle the easy fixes from Array (created by FindMissing) "RTN","TMGNDF2E",133,0) ;"Input: Array -- array as cread by FindMissing() "RTN","TMGNDF2E",134,0) ;" Array(IEN,subIEN)=UnmatchedIngredientName "RTN","TMGNDF2E",135,0) ;" Array(IEN,subIEN,"FILE 50.416 IEN")=IEN "RTN","TMGNDF2E",136,0) ;" Array(IEN,subIEN)=UnmatchedIngredientName "RTN","TMGNDF2E",137,0) ;" Array(IEN,subIEN,"FILE 50.416 IEN")=IEN "RTN","TMGNDF2E",138,0) ;"Output: Missing information will be stuffed into records "RTN","TMGNDF2E",139,0) "RTN","TMGNDF2E",140,0) new IEN,subIEN "RTN","TMGNDF2E",141,0) set IEN=$order(Array("")) "RTN","TMGNDF2E",142,0) if IEN'="" for do quit:IEN="" "RTN","TMGNDF2E",143,0) . set subIEN=$order(Array(IEN,"")) "RTN","TMGNDF2E",144,0) . if subIEN'="" for do quit:subIEN="" "RTN","TMGNDF2E",145,0) . . new RxIEN set RxIEN=$get(Array(IEN,subIEN,"FILE 50.416 IEN")) "RTN","TMGNDF2E",146,0) . . if RxIEN'="" do "RTN","TMGNDF2E",147,0) . . . set $piece(^TMG(22706.9,IEN,4,subIEN,0),"^",3)=RxIEN "RTN","TMGNDF2E",148,0) . . set subIEN=$order(Array(IEN,subIEN)) "RTN","TMGNDF2E",149,0) . set IEN=$order(Array(IEN)) "RTN","TMGNDF2E",150,0) "RTN","TMGNDF2E",151,0) quit "RTN","TMGNDF2E",152,0) "RTN","TMGNDF2E",153,0) "RTN","TMGNDF2E",154,0) HardFix(Array) "RTN","TMGNDF2E",155,0) ;"Purpose: to handle the more difficult fixes from Array (created by FindMissing) "RTN","TMGNDF2E",156,0) ;"Input: Array -- array as cread by FindMissing() "RTN","TMGNDF2E",157,0) ;" Array(IEN,subIEN)=UnmatchedIngredientName "RTN","TMGNDF2E",158,0) ;" Array(IEN,subIEN,"FILE 50.416 IEN")=IEN "RTN","TMGNDF2E",159,0) ;" Array(IEN,subIEN)=UnmatchedIngredientName "RTN","TMGNDF2E",160,0) ;" Array(IEN,subIEN,"FILE 50.416 IEN")=IEN "RTN","TMGNDF2E",161,0) ;"Output: Missing information will be stuffed into records "RTN","TMGNDF2E",162,0) "RTN","TMGNDF2E",163,0) write !,$$ListCt^TMGMISC("Array")," items to fix.",! "RTN","TMGNDF2E",164,0) new IEN,subIEN,PriorAnswer "RTN","TMGNDF2E",165,0) new abort set abort=0 "RTN","TMGNDF2E",166,0) set IEN=$order(Array("")) "RTN","TMGNDF2E",167,0) if IEN'="" for do quit:(IEN="")!(abort=1) "RTN","TMGNDF2E",168,0) . set subIEN=$order(Array(IEN,"")) "RTN","TMGNDF2E",169,0) . if subIEN'="" for do quit:(subIEN="")!(abort=1) "RTN","TMGNDF2E",170,0) . . new RxName,RxIEN "RTN","TMGNDF2E",171,0) . . set RxName=$get(Array(IEN,subIEN)) "RTN","TMGNDF2E",172,0) . . set RxIEN=+$get(PriorAnswer(RxName)) "RTN","TMGNDF2E",173,0) . . if (RxIEN=0)!(RxIEN=-1) do "RTN","TMGNDF2E",174,0) . . . set RxIEN=$$LookupRx^TMGNDF2B(RxName) "RTN","TMGNDF2E",175,0) . . . set PriorAnswer(RxName)=RxIEN "RTN","TMGNDF2E",176,0) . . . if RxIEN=-1 do "RTN","TMGNDF2E",177,0) . . . . set RxIEN=$$GetRxIEN(RxName,$name(Array(IEN,subIEN,"INFO"))) "RTN","TMGNDF2E",178,0) . . . . set PriorAnswer(RxName)=RxIEN "RTN","TMGNDF2E",179,0) . . if +RxIEN>0 do "RTN","TMGNDF2E",180,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDF2E",181,0) . . . set TMGFDA(22706.916,subIEN_","_IEN_",",2)=+RxIEN "RTN","TMGNDF2E",182,0) . . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2E",183,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2E",184,0) . . if RxIEN=-3 set abort=1 quit "RTN","TMGNDF2E",185,0) . . if RxIEN=-2 do "RTN","TMGNDF2E",186,0) . . . set $piece(^TMG(22706.9,IEN,1),"^",4)=1 ;"1=SKIP "RTN","TMGNDF2E",187,0) . . set subIEN=$order(Array(IEN,subIEN)) "RTN","TMGNDF2E",188,0) . set IEN=$order(Array(IEN)) "RTN","TMGNDF2E",189,0) "RTN","TMGNDF2E",190,0) quit "RTN","TMGNDF2E",191,0) "RTN","TMGNDF2E",192,0) GetRxIEN(RxName,pDrugInfo) "RTN","TMGNDF2E",193,0) ;"Purpose: To get the IEN of the given drug name "RTN","TMGNDF2E",194,0) ;"Input: RxName -- the name of the drug to find. "RTN","TMGNDF2E",195,0) ;" pDrugInfo -- NAME OF array containing drug info (as creaged by GetDrugInfo^TMGNDF2 "RTN","TMGNDF2E",196,0) ;"Result: IEN of drug found, or 0 if not found, "RTN","TMGNDF2E",197,0) ;" -2 if drug should be excluded from addition to VA PRODUCT file. "RTN","TMGNDF2E",198,0) ;" -3 if abort requested "RTN","TMGNDF2E",199,0) "RTN","TMGNDF2E",200,0) new result set result=0 "RTN","TMGNDF2E",201,0) new DrugInfo merge DrugInfo=@pDrugInfo "RTN","TMGNDF2E",202,0) "RTN","TMGNDF2E",203,0) GRLoop "RTN","TMGNDF2E",204,0) write !!,"Can't find a ingredient match for: ",RxName,!! "RTN","TMGNDF2E",205,0) write "1. Manual lookup",! "RTN","TMGNDF2E",206,0) write "2. Show info of drug containing this ingredient",! "RTN","TMGNDF2E",207,0) write "3. Set drug containing this ingredient to NOT BE ADDED",! "RTN","TMGNDF2E",208,0) write " to the VA PRODUCT file.",! "RTN","TMGNDF2E",209,0) write "0 next",! "RTN","TMGNDF2E",210,0) write "^ to quit",! "RTN","TMGNDF2E",211,0) write ! "RTN","TMGNDF2E",212,0) new temp "RTN","TMGNDF2E",213,0) read "Enter selection: 0// ",temp:$get(DTIME,3600),! "RTN","TMGNDF2E",214,0) if temp="" set temp="0" "RTN","TMGNDF2E",215,0) if temp="^" set result=-3 goto GRDone "RTN","TMGNDF2E",216,0) if temp=0 goto GRDone "RTN","TMGNDF2E",217,0) if temp=1 do goto:(result>0) GRDone "RTN","TMGNDF2E",218,0) . new DIC,Y "RTN","TMGNDF2E",219,0) . set DIC=50.416 "RTN","TMGNDF2E",220,0) . set DIC(0)="AEQML" "RTN","TMGNDF2E",221,0) . do ^DIC "RTN","TMGNDF2E",222,0) . if +Y>0 set result=+Y "RTN","TMGNDF2E",223,0) if temp=2 do goto GRLoop "RTN","TMGNDF2E",224,0) . do FormatDrug^TMGND2A(.DrugInfo) "RTN","TMGNDF2E",225,0) if temp=3 do goto GRDone "RTN","TMGNDF2E",226,0) . set result=-2 "RTN","TMGNDF2E",227,0) goto GRLoop "RTN","TMGNDF2E",228,0) GRDone "RTN","TMGNDF2E",229,0) quit result "RTN","TMGNDF2E",230,0) "RTN","TMGNDF2E",231,0) "RTN","TMGNDF2E",232,0) ;"======================================================================= "RTN","TMGNDF2E",233,0) ;"Code for Fixing NDC's "RTN","TMGNDF2E",234,0) ;"======================================================================= "RTN","TMGNDF2E",235,0) ;"Note: The NDC's given by the FDA database are not always acceptible by the "RTN","TMGNDF2E",236,0) ;" VistA input transform, because they include *'s. The FDA explains "RTN","TMGNDF2E",237,0) ;" this as follows: "RTN","TMGNDF2E",238,0) ;" Here is the official info from fda.gov on NDC codes: "RTN","TMGNDF2E",239,0) ;" "RTN","TMGNDF2E",240,0) ;" NDC Number "RTN","TMGNDF2E",241,0) ;" "RTN","TMGNDF2E",242,0) ;" Each listed drug product listed is assigned a unique 10-digit, 3-segment "RTN","TMGNDF2E",243,0) ;" number. This number, known as the NDC, identifies the labeler, product, and "RTN","TMGNDF2E",244,0) ;" trade package size. The first segment, the labeler code, is assigned by the "RTN","TMGNDF2E",245,0) ;" FDA. A labeler is any firm that manufactures (including repackers or "RTN","TMGNDF2E",246,0) ;" relabelers), or distributes (under its own name) the drug. The second "RTN","TMGNDF2E",247,0) ;" segment, the product code, identifies a specific strength, dosage form, and "RTN","TMGNDF2E",248,0) ;" formulation for a particular firm. The third segment, the package code, "RTN","TMGNDF2E",249,0) ;" identifies package sizes and types. Both the product and package codes are "RTN","TMGNDF2E",250,0) ;" assigned by the firm. The NDC will be in one of the following "RTN","TMGNDF2E",251,0) ;" configurations: 4-4-2, 5-3-2, or 5-4-1. "RTN","TMGNDF2E",252,0) ;" "RTN","TMGNDF2E",253,0) ;" An asterisk may appear in either a product code or a package code. It "RTN","TMGNDF2E",254,0) ;" simply acts as a place holder and indicates the configuration of the NDC. "RTN","TMGNDF2E",255,0) ;" Since the NDC is limited to 10 digits, a firm with a 5 digit labeler code "RTN","TMGNDF2E",256,0) ;" must choose between a 3 digit product code and 2 digit package code, or a 4 "RTN","TMGNDF2E",257,0) ;" digit product code and 1 digit package code. "RTN","TMGNDF2E",258,0) ;" "RTN","TMGNDF2E",259,0) ;" Thus, you have either a 5-4-1 or a 5-3-2 configuration for the three "RTN","TMGNDF2E",260,0) ;" segments of the NDC. Because of a conflict with the HIPAA standard of an 11 "RTN","TMGNDF2E",261,0) ;" digit NDC, many programs will pad the product code or package code segments "RTN","TMGNDF2E",262,0) ;" of the NDC with a leading zero instead of the asterisk. "RTN","TMGNDF2E",263,0) ;" "RTN","TMGNDF2E",264,0) ;" kt note: I.e. the problem is how to convert 10 digits --> 11 digits. "RTN","TMGNDF2E",265,0) ;" where to put the extra digit? "RTN","TMGNDF2E",266,0) ;" "RTN","TMGNDF2E",267,0) ;" Since a zero can be a valid digit in the NDC, this can lead to confusion "RTN","TMGNDF2E",268,0) ;" when trying to reconstitute the NDC back to its FDA standard. Example: "RTN","TMGNDF2E",269,0) ;" 12345-0678-09 (11 digits) could be 12345-678-09 or 12345-678-90 depending on "RTN","TMGNDF2E",270,0) ;" the firm's configuration. "RTN","TMGNDF2E",271,0) ;" "RTN","TMGNDF2E",272,0) ;" kt note: I think the example is wrong. It should be: "RTN","TMGNDF2E",273,0) ;" Example: "RTN","TMGNDF2E",274,0) ;" 12345-0678-09 (11 digits) could be 12345-678-09 (i.e. 5-3-2) "RTN","TMGNDF2E",275,0) ;" or 12345-0678-9 (5-4-1) depending on the firm's configuration. "RTN","TMGNDF2E",276,0) "RTN","TMGNDF2E",277,0) ;" By storing the segments as character data and "RTN","TMGNDF2E",278,0) ;" using the * as place holders we eliminate the confusion. In the example, FDA "RTN","TMGNDF2E",279,0) ;" stores the segments as 12345-*678-09 for a 5-3-2 configuration or "RTN","TMGNDF2E",280,0) ;" 12345-0678-*9 for a 5-4-1 "RTN","TMGNDF2E",281,0) ;" "RTN","TMGNDF2E",282,0) ;" "RTN","TMGNDF2E",283,0) "RTN","TMGNDF2E",284,0) BatchNDCFix "RTN","TMGNDF2E",285,0) ;"Purpose: Scan TMG FDA IMPORT COMPILED file, and fix NDC codes "RTN","TMGNDF2E",286,0) ;"Output: data in file will be changed, NDC and NDC-12-digit fields will be altered. "RTN","TMGNDF2E",287,0) "RTN","TMGNDF2E",288,0) new IEN "RTN","TMGNDF2E",289,0) set IEN=$order(^TMG(22706.9,0)) "RTN","TMGNDF2E",290,0) if +IEN>0 for do quit:(+IEN'>0) "RTN","TMGNDF2E",291,0) . new node set node=$get(^TMG(22706.9,IEN,1)) "RTN","TMGNDF2E",292,0) . new NDC,newNDC "RTN","TMGNDF2E",293,0) . set NDC=$piece(node,"^",1) "RTN","TMGNDF2E",294,0) . set newNDC=$$NewNDC(NDC) "RTN","TMGNDF2E",295,0) . new digits12NDC set digits12NDC=$translate(newNDC,"-","") "RTN","TMGNDF2E",296,0) . new d1 "RTN","TMGNDF2E",297,0) . if '$$IsNumeric^TMGMISC(digits12NDC) do "RTN","TMGNDF2E",298,0) . . new name set name=$piece(^TMG(22706.9,IEN,0),"^",4) "RTN","TMGNDF2E",299,0) . . write IEN,". NDC=",NDC," ",name,! "RTN","TMGNDF2E",300,0) . if newNDC'=NDC do "RTN","TMGNDF2E",301,0) . . write IEN,". ",NDC," needs --> ",newNDC,! "RTN","TMGNDF2E",302,0) . . if $length(digits12NDC)<12 do "RTN","TMGNDF2E",303,0) . . . set digits12NDC=$extract("000000",1,12-$length(digits12NDC))_digits12NDC "RTN","TMGNDF2E",304,0) BLabel . . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF2E",305,0) . . set TMGFDA(22706.9,IEN_",",4)=newNDC "RTN","TMGNDF2E",306,0) . . set TMGFDA(22706.9,IEN_",",5)=digits12NDC "RTN","TMGNDF2E",307,0) . . do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2E",308,0) . . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF2E",309,0) . . . set result=0 "RTN","TMGNDF2E",310,0) . . . if $get(Quiet)=1 quit "RTN","TMGNDF2E",311,0) . . . new PriorErrorFound "RTN","TMGNDF2E",312,0) . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2E",313,0) . set IEN=$order(^TMG(22706.9,IEN)) "RTN","TMGNDF2E",314,0) "RTN","TMGNDF2E",315,0) quit "RTN","TMGNDF2E",316,0) "RTN","TMGNDF2E",317,0) NewNDC(NDC) "RTN","TMGNDF2E",318,0) ;"Purpose: convert an NDC code with invalid formatting into one acceptible to VistA "RTN","TMGNDF2E",319,0) ;"Input: NDC -- the NDC as provided by FDA, with hyphens ('-'s) "RTN","TMGNDF2E",320,0) ;"Output: the correctly formatted NDC, or "" if not valid conversion possible. "RTN","TMGNDF2E",321,0) "RTN","TMGNDF2E",322,0) ;"Examples of conversions: "RTN","TMGNDF2E",323,0) ;" 12345-*678-09 --> 12345-678-09 (5-3-2 digits) "RTN","TMGNDF2E",324,0) ;" 12345-0678-*9 --> 12345-0678-9 (5-4-1 digits) "RTN","TMGNDF2E",325,0) "RTN","TMGNDF2E",326,0) ;"Sometimes there are two *'s (i.e. **) (always in the LAST grouping -- the package code "RTN","TMGNDF2E",327,0) ;"Here is some examples of how I will convert them: "RTN","TMGNDF2E",328,0) ;" 057587-*022-** (6-4-2) --> 57587-022-00 (5-3-2) "RTN","TMGNDF2E",329,0) ;" 053360-4189-** (6-4-2) --> 53360-4189-0 (5-4-1) "RTN","TMGNDF2E",330,0) ;" 000034-1025-** (6-4-2) --> 00034-1025-0 (5-4-1) "RTN","TMGNDF2E",331,0) ;" 046672-*122-** (6-4-2) --> 46672-122-00 (5-3-2) "RTN","TMGNDF2E",332,0) "RTN","TMGNDF2E",333,0) ;"Also, sometimes the FDA database did not include values for codes. "RTN","TMGNDF2E",334,0) ;"Initially, I converted these to ????'s "RTN","TMGNDF2E",335,0) ;"Now, that won't be acceptible to VistA, so I will convert these to 0's "RTN","TMGNDF2E",336,0) ;"e.g. 000034-????-56 --> 000034-0000-56 "RTN","TMGNDF2E",337,0) "RTN","TMGNDF2E",338,0) new result,valid,digits "RTN","TMGNDF2E",339,0) "RTN","TMGNDF2E",340,0) ;"Setup check for valid digits combo. Allowed combos are: "RTN","TMGNDF2E",341,0) ;" 4-4-2, 5-3-2, 5-4-1, 5-4-2, or 6-4-2 "RTN","TMGNDF2E",342,0) set digits("VALID",4,4,2)=1 ;"total of 10 digits "RTN","TMGNDF2E",343,0) set digits("VALID",5,3,2)=1 ;"total of 10 digits "RTN","TMGNDF2E",344,0) set digits("VALID",5,4,1)=1 ;"total of 10 digits "RTN","TMGNDF2E",345,0) set digits("VALID",5,4,2)=1 ;"total of 11 digits "RTN","TMGNDF2E",346,0) set digits("VALID",6,4,2)=1 ;"total of 12 digits "RTN","TMGNDF2E",347,0) ;"set digits("VALID",6,3,1)=1 ;"total of 10 digits "RTN","TMGNDF2E",348,0) "RTN","TMGNDF2E",349,0) ;"Remove single *'s "RTN","TMGNDF2E",350,0) set result=$$Substitute^TMGSTUTL(NDC,"**","##") ;"protect double **'s "RTN","TMGNDF2E",351,0) ;" 010130-*124-*1 --> 010130-*124-01 "RTN","TMGNDF2E",352,0) if ($piece(result,"-",2)["*")&($piece(result,"-",3)["*") do "RTN","TMGNDF2E",353,0) . set $piece(result,"-",3)=$translate($piece(result,"-",3),"*","0") "RTN","TMGNDF2E",354,0) ;" 010130-*124-01 --> 010130-124-01 "RTN","TMGNDF2E",355,0) set result=$translate(result,"*","") "RTN","TMGNDF2E",356,0) "RTN","TMGNDF2E",357,0) set result=$$Substitute^TMGSTUTL(result,"##","**") "RTN","TMGNDF2E",358,0) "RTN","TMGNDF2E",359,0) ;"Change ?'s into 0's "RTN","TMGNDF2E",360,0) if $length($piece(result,"-",2))=4 do "RTN","TMGNDF2E",361,0) . if $piece(result,"-",3)="??" set $piece(result,"-",3)="0" "RTN","TMGNDF2E",362,0) set result=$translate(result,"?","0") "RTN","TMGNDF2E",363,0) "RTN","TMGNDF2E",364,0) NNDCL1 "RTN","TMGNDF2E",365,0) set digits(1)=$length($piece(result,"-",1)) "RTN","TMGNDF2E",366,0) set digits(2)=$length($piece(result,"-",2)) "RTN","TMGNDF2E",367,0) set digits(3)=$length($piece(result,"-",3)) "RTN","TMGNDF2E",368,0) "RTN","TMGNDF2E",369,0) if result["**" do "RTN","TMGNDF2E",370,0) . if digits(2)=3 set result=$$Substitute^TMGSTUTL(result,"**","00") "RTN","TMGNDF2E",371,0) . else if digits(2)=4 set result=$$Substitute^TMGSTUTL(result,"**","0") "RTN","TMGNDF2E",372,0) . else do "RTN","TMGNDF2E",373,0) . . write "Error converting NDC code: ",NDC,! "RTN","TMGNDF2E",374,0) . . set result="",digits(1)=-1 "RTN","TMGNDF2E",375,0) . set digits(3)=$length($extract(result,"-",3)) "RTN","TMGNDF2E",376,0) "RTN","TMGNDF2E",377,0) ;"convert 12345-123-x --> 12345-123-0x "RTN","TMGNDF2E",378,0) if (digits(1)=5)&(digits(2)=3)&(digits(3)=1) do goto NNDCL1 "RTN","TMGNDF2E",379,0) . new value set value=+$piece(result,"-",3) "RTN","TMGNDF2E",380,0) . set $piece(result,"-",3)="0"_value "RTN","TMGNDF2E",381,0) "RTN","TMGNDF2E",382,0) set digits=digits(1)+digits(2)+digits(3) "RTN","TMGNDF2E",383,0) set valid=+$get(digits("VALID",digits(1),digits(2),digits(3))) "RTN","TMGNDF2E",384,0) "RTN","TMGNDF2E",385,0) if (valid'=1)&(digits(1)=6)&($extract(result,1,1)="0") do goto NNDCL1 "RTN","TMGNDF2E",386,0) . set result=$extract(result,2,99) "RTN","TMGNDF2E",387,0) "RTN","TMGNDF2E",388,0) if valid'=1 set result="" "RTN","TMGNDF2E",389,0) "RTN","TMGNDF2E",390,0) quit result "RTN","TMGNDF2E",391,0) "RTN","TMGNDF2F") 0^45^B9113 "RTN","TMGNDF2F",1,0) TMGNDF2F ;TMG/kst/FDA Import: Fix drugs with missing ingredients ;03/25/06 "RTN","TMGNDF2F",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF2F",3,0) "RTN","TMGNDF2F",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF2F",5,0) ;" Further processing, after functions in TMGNDF2E "RTN","TMGNDF2F",6,0) ;" Fixing drugs with missing ingredients (i.e. not provided by FDA database) "RTN","TMGNDF2F",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDF2F",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF2F",9,0) ;"11-21-2006 "RTN","TMGNDF2F",10,0) "RTN","TMGNDF2F",11,0) ;"======================================================================= "RTN","TMGNDF2F",12,0) ;" API -- Public Functions. "RTN","TMGNDF2F",13,0) ;"======================================================================= "RTN","TMGNDF2F",14,0) ;" //no Menu -- will launch FixMissing from Menu^TMGNDF2E "RTN","TMGNDF2F",15,0) ;"======================================================================= "RTN","TMGNDF2F",16,0) ;"FixMissing -- Fix entries in file 22706.9 that don't have any ingredients, "RTN","TMGNDF2F",17,0) ;" either by finding similar drugs already present, and using "RTN","TMGNDF2F",18,0) ;" their ingredients, or asking user. "RTN","TMGNDF2F",19,0) "RTN","TMGNDF2F",20,0) ;"======================================================================= "RTN","TMGNDF2F",21,0) ;" Private Functions. "RTN","TMGNDF2F",22,0) ;"======================================================================= "RTN","TMGNDF2F",23,0) ;"GetMissing(List) -- Gather list of drugs that have no ingredients "RTN","TMGNDF2F",24,0) ;"GetSuggestions(List) -- expand list such that it contains suggested ingredients "RTN","TMGNDF2F",25,0) ;"Suggest1(IEN,Array) -- find a suggested answer for one record "RTN","TMGNDF2F",26,0) ;"SgstFromVAP(IEN,vapIEN,Array) -- Return list of ingredient IENs based on IEN from VA PRODUCT "RTN","TMGNDF2F",27,0) ;"SgstByName(IEN,Array) -- find suggested ingredients of one drug, based on IEN from 22706.9 "RTN","TMGNDF2F",28,0) ;"ShowList(Array,Answers,ShowBoth,ByGeneric,ShowIngred,CompactMode) -- display the list generated by GetSuggestions "RTN","TMGNDF2F",29,0) ;"HandleList(Array) -- allow user to manipulate and fix problems found "RTN","TMGNDF2F",30,0) ;"XMenuOption(Prompt,FnStr,HlpFn,EntryList,EntryS) -- carry out the various menu functions "RTN","TMGNDF2F",31,0) ;"SetSkip(Array,Answers,EntryList) -- remove entries from consideration for adding to 50.68 "RTN","TMGNDF2F",32,0) ;"ShowInfo(Array,Answers,EntryList) -- allow user to explore existing entries in 22706.9 file "RTN","TMGNDF2F",33,0) ;"Lookup(Array,Answers,EntryList) -- allow user to explore existing entries in 50.68 file "RTN","TMGNDF2F",34,0) ;"FixItems(Array,Answers,EntryList) -- Fix one item "RTN","TMGNDF2F",35,0) ;"AskFix1Item(Array,IEN) -- fix one entry, with user input "RTN","TMGNDF2F",36,0) ;"Show1(Array,IEN,Answers,ShowIgd) -- display the list generated by GetSuggestions "RTN","TMGNDF2F",37,0) ;"Look2Fix(IEN,Array) -- allow user to find a match to use for fixing. "RTN","TMGNDF2F",38,0) ;"KillMatch(IEN,Array,Answers,EntryList) -- remove VA PRODUCT matches from consideration "RTN","TMGNDF2F",39,0) ;"ArrayKill(IEN,Array) -- remove entry IEN from the Array of drugs to be fixed "RTN","TMGNDF2F",40,0) ;"Fix1From(IEN,vapIEN,Array,NoVerify) -- use rec in VA PRODUCT file to fix rec in TMG FDA IMPORT COMPILED "RTN","TMGNDF2F",41,0) ;"VerifySource(vapIEN) -- show the drug name, and the drug's ingredients, and ask user to verify choice "RTN","TMGNDF2F",42,0) ;"Copy1(vapIEN,IEN) -- fill in missing answers in the record in 22706.9, from record in 50.68 "RTN","TMGNDF2F",43,0) ;"ManIngredients(Array,Answers,EntryList) -- Manually Add ingredients to a list of records "RTN","TMGNDF2F",44,0) ;"AskManIngred(IEN,IngredArray) -- ask user for a list of ingredients, then add to record in 22706.9 "RTN","TMGNDF2F",45,0) ;"ShowIngreds(IngredArray) -- Show list of ingredients in array "RTN","TMGNDF2F",46,0) ;"Add1Ingredients(IEN,IngredArray) -- put a list of ingredients into one (1) record in 22706.9 "RTN","TMGNDF2F",47,0) "RTN","TMGNDF2F",48,0) ;"======================================================================= "RTN","TMGNDF2F",49,0) ;"======================================================================= "RTN","TMGNDF2F",50,0) "RTN","TMGNDF2F",51,0) ;"Note: The FDA database lists some drugs that do not have ingredients specified. "RTN","TMGNDF2F",52,0) ;" Some such drugs may not be wanted, and some others might have easily "RTN","TMGNDF2F",53,0) ;" identifiable ingredients (i.e. Lasix -->can figure out ingredient of furosemide) "RTN","TMGNDF2F",54,0) ;" So the purpose of this module is to handle those drugs that don't have "RTN","TMGNDF2F",55,0) ;" enough information for addition into the VistA system. "RTN","TMGNDF2F",56,0) "RTN","TMGNDF2F",57,0) FixMissing "RTN","TMGNDF2F",58,0) ;"Purpose: Fix entries in file 22706.9 that don't have any ingredients, "RTN","TMGNDF2F",59,0) ;" either by finding similar drugs already present, and using "RTN","TMGNDF2F",60,0) ;" their ingredients, or asking user. "RTN","TMGNDF2F",61,0) "RTN","TMGNDF2F",62,0) new List,Answers "RTN","TMGNDF2F",63,0) write "Scanning TMG FDA IMPORT COMPILED file for drugs with missing information.",! "RTN","TMGNDF2F",64,0) do GetMissing(.List) "RTN","TMGNDF2F",65,0) write ! "RTN","TMGNDF2F",66,0) write "Searching for potential fixes for each drug with missing information",! "RTN","TMGNDF2F",67,0) do GetSuggestions(.List) "RTN","TMGNDF2F",68,0) write ! "RTN","TMGNDF2F",69,0) do HandleList(.List) "RTN","TMGNDF2F",70,0) "RTN","TMGNDF2F",71,0) ;"do ShowList(.List,.Answers,1,0) "RTN","TMGNDF2F",72,0) "RTN","TMGNDF2F",73,0) quit "RTN","TMGNDF2F",74,0) "RTN","TMGNDF2F",75,0) "RTN","TMGNDF2F",76,0) GetMissing(List) "RTN","TMGNDF2F",77,0) ;"Purpose: Gather list of drugs that have no ingredients "RTN","TMGNDF2F",78,0) ;"Input: List -- PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF2F",79,0) ;" format: "RTN","TMGNDF2F",80,0) ;" List(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",81,0) ;" List(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",82,0) ;" List("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",83,0) ;" List("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",84,0) ;"results: none "RTN","TMGNDF2F",85,0) "RTN","TMGNDF2F",86,0) new Itr,IEN "RTN","TMGNDF2F",87,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2F",88,0) do PrepProgress^TMGITR(.Itr,2) "RTN","TMGNDF2F",89,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2F",90,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;" 1;4=SKIP THIS RECORD "RTN","TMGNDF2F",91,0) . if +$piece($get(@Itr@(IEN,4,0)),"^",4)=0 do ;"4;0 -> header of INGREDIENTS subfile, part 4=rec count "RTN","TMGNDF2F",92,0) . . new TMGTradeName set TMGTradeName=$$GET1^DIQ(22706.9,IEN,.05) "RTN","TMGNDF2F",93,0) . . set TMGTradeName=$translate(TMGTradeName,"""","'") "RTN","TMGNDF2F",94,0) . . if TMGTradeName="" set TMGTradeName="?" "RTN","TMGNDF2F",95,0) . . new TMGGeneric set TMGGeneric=$$GET1^DIQ(22706.9,IEN,.07) "RTN","TMGNDF2F",96,0) . . set TMGGeneric=$translate(TMGGeneric,"""","'") "RTN","TMGNDF2F",97,0) . . if TMGGeneric="" set TMGGeneric="?" "RTN","TMGNDF2F",98,0) . . set List(IEN)=TMGTradeName_"^"_TMGGeneric "RTN","TMGNDF2F",99,0) . . if TMGGeneric'="?" set List("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",100,0) . . set List("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",101,0) "RTN","TMGNDF2F",102,0) quit "RTN","TMGNDF2F",103,0) "RTN","TMGNDF2F",104,0) "RTN","TMGNDF2F",105,0) GetSuggestions(List) "RTN","TMGNDF2F",106,0) ;"Purpose: expand list such that it contains suggested ingredients "RTN","TMGNDF2F",107,0) ;"Input: List -- PASS BY REFERENCE, "RTN","TMGNDF2F",108,0) ;" List(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",109,0) ;" List(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",110,0) ;" List("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",111,0) ;" List("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",112,0) ;"Output: List is filled in, as follows: "RTN","TMGNDF2F",113,0) ;" List(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",114,0) ;" List(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",115,0) ;" List(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",116,0) ;" List(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",117,0) ;" List(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",118,0) ;" List(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",119,0) ;" List("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",120,0) ;" List("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",121,0) "RTN","TMGNDF2F",122,0) new IEN,Itr "RTN","TMGNDF2F",123,0) set IEN=$$ItrAInit^TMGITR("List",.Itr) "RTN","TMGNDF2F",124,0) do PrepProgress^TMGITR(.Itr,10) "RTN","TMGNDF2F",125,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2F",126,0) . do Suggest1(IEN,.List) "RTN","TMGNDF2F",127,0) "RTN","TMGNDF2F",128,0) quit "RTN","TMGNDF2F",129,0) "RTN","TMGNDF2F",130,0) "RTN","TMGNDF2F",131,0) Suggest1(IEN,Array) "RTN","TMGNDF2F",132,0) ;"Purpose: To find a suggested answer for one record "RTN","TMGNDF2F",133,0) ;"Input: IEN -- the IEN in file 22706.9 to find answer for "RTN","TMGNDF2F",134,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. FORMAT: "RTN","TMGNDF2F",135,0) ;" Array(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",136,0) ;" Array(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",137,0) ;"Output: Array is returned "RTN","TMGNDF2F",138,0) ;" Note: RxIEN is IEN in file 50.416 "RTN","TMGNDF2F",139,0) ;" Array(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",140,0) ;" Array(IEN)=TMGTradeName^VAGeneric "RTN","TMGNDF2F",141,0) ;" List(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",142,0) ;" List(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",143,0) ;" List(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",144,0) ;" List(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",145,0) ;"Results: none "RTN","TMGNDF2F",146,0) "RTN","TMGNDF2F",147,0) new Itr,RxIEN,vapIEN "RTN","TMGNDF2F",148,0) set vapIEN=$$ItrFInit^TMGITR(22706.914,.Itr,.RxIEN,.01,IEN,"I") "RTN","TMGNDF2F",149,0) if vapIEN'="" for do quit:($$ItrFNext^TMGITR(.Itr,.RxIEN,.vapIEN)'>0) "RTN","TMGNDF2F",150,0) . do SgstFromVAP(IEN,vapIEN,.Array) "RTN","TMGNDF2F",151,0) "RTN","TMGNDF2F",152,0) kill Itr "RTN","TMGNDF2F",153,0) set RxIEN=$$ItrFInit^TMGITR(22706.915,.Itr,.RxIEN,.01,IEN,"I") "RTN","TMGNDF2F",154,0) if RxIEN'="" for do quit:($$ItrFNext^TMGITR(.Itr,.RxIEN,.vapIEN)'>0) "RTN","TMGNDF2F",155,0) . do SgstFromVAP(IEN,RxIEN,.Array) "RTN","TMGNDF2F",156,0) "RTN","TMGNDF2F",157,0) do SgstByName(IEN,.Array) "RTN","TMGNDF2F",158,0) "RTN","TMGNDF2F",159,0) quit "RTN","TMGNDF2F",160,0) "RTN","TMGNDF2F",161,0) "RTN","TMGNDF2F",162,0) SgstFromVAP(IEN,vapIEN,Array) "RTN","TMGNDF2F",163,0) ;"Purpose: Return list of ingredient IENs based on IEN from VA PRODUCT "RTN","TMGNDF2F",164,0) ;"Input: IEN -- the IEN in file 22706.9 "RTN","TMGNDF2F",165,0) ;" vapIEN -- an IEN to file 50.68 (VA PRODUCT) "RTN","TMGNDF2F",166,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. format: "RTN","TMGNDF2F",167,0) ;" Note: RxIEN is IEN in file 50.416 "RTN","TMGNDF2F",168,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",169,0) ;"Output: Array is filled with data, if found "RTN","TMGNDF2F",170,0) ;" Note: RxIEN is IEN in file 50.416 "RTN","TMGNDF2F",171,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",172,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",173,0) ;" Array(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",174,0) ;" Array(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",175,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",176,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",177,0) ;"Results: none. "RTN","TMGNDF2F",178,0) "RTN","TMGNDF2F",179,0) new Itr,igdIEN,IEN2 "RTN","TMGNDF2F",180,0) set igdIEN=$$ItrFInit^TMGITR(50.6814,.Itr,.IEN2,.01,vapIEN,"I") "RTN","TMGNDF2F",181,0) if igdIEN'="" for do quit:($$ItrFNext^TMGITR(.Itr,.IEN2,.igdIEN)'>0) "RTN","TMGNDF2F",182,0) . if igdIEN'=0 do "RTN","TMGNDF2F",183,0) . . new IENS set IENS=igdIEN_","_IEN_"," "RTN","TMGNDF2F",184,0) . . new IngredName set IngredName=$$GET1^DIQ(50.416,IENS,.01) "RTN","TMGNDF2F",185,0) . . set Array(IEN,"POSS IGD MATCH",igdIEN)=IngredName "RTN","TMGNDF2F",186,0) "RTN","TMGNDF2F",187,0) quit "RTN","TMGNDF2F",188,0) "RTN","TMGNDF2F",189,0) "RTN","TMGNDF2F",190,0) SgstByName(IEN,Array) "RTN","TMGNDF2F",191,0) ;"Purpose: to find suggested ingredients of one drug, based on IEN from 22706.9 "RTN","TMGNDF2F",192,0) ;"Input: IEN -- IEN from 22706.9 "RTN","TMGNDF2F",193,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. format: "RTN","TMGNDF2F",194,0) ;" Note: RxIEN is IEN in file 50.416 "RTN","TMGNDF2F",195,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",196,0) ;"Output: Array is filled with data, if found "RTN","TMGNDF2F",197,0) ;" Note: RxIEN is IEN in file 50.416 "RTN","TMGNDF2F",198,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",199,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",200,0) ;" Array(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",201,0) ;" Array(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",202,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",203,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",204,0) ;"Results: none. "RTN","TMGNDF2F",205,0) "RTN","TMGNDF2F",206,0) new TMGTradeName,TMGFDA,TMGMSG,PriorErrorFound "RTN","TMGNDF2F",207,0) set TMGTradeName=$piece($get(Array(IEN)),"^",1) "RTN","TMGNDF2F",208,0) if (TMGTradeName="")!(TMGTradeName="?") goto SBNDone "RTN","TMGNDF2F",209,0) new Value set Value=$piece(TMGTradeName," ",1) "RTN","TMGNDF2F",210,0) do FIND^DIC(50.68,,.01,"M",Value,"*",,,,"TMGFDA","TMGMSG") "RTN","TMGNDF2F",211,0) if $data(TMGMSG("DIERR"))'=0 do goto SBNDone "RTN","TMGNDF2F",212,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2F",213,0) "RTN","TMGNDF2F",214,0) ;"Now gather ingredient list from results found "RTN","TMGNDF2F",215,0) new i,vapIEN "RTN","TMGNDF2F",216,0) for i=1:1:$piece($get(TMGFDA("DILIST",0)),"^",1) do "RTN","TMGNDF2F",217,0) . set vapIEN=+$get(TMGFDA("DILIST",2,i)) "RTN","TMGNDF2F",218,0) . new vapName set vapName=$$GET1^DIQ(50.68,vapIEN,.01) "RTN","TMGNDF2F",219,0) . set Array(IEN,"POSS RX MATCH",vapIEN)=vapName "RTN","TMGNDF2F",220,0) . do SgstFromVAP(IEN,vapIEN,.Array) "RTN","TMGNDF2F",221,0) "RTN","TMGNDF2F",222,0) SBNDone "RTN","TMGNDF2F",223,0) quit "RTN","TMGNDF2F",224,0) "RTN","TMGNDF2F",225,0) ;"======================================================================= "RTN","TMGNDF2F",226,0) "RTN","TMGNDF2F",227,0) ShowList(Array,Answers,ShowBoth,ByGeneric,ShowIngred,CompactMode) "RTN","TMGNDF2F",228,0) ;"Purpose: To display the list generated by GetSuggestions "RTN","TMGNDF2F",229,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format: "RTN","TMGNDF2F",230,0) ;" note IEN is from 22706.9 "RTN","TMGNDF2F",231,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",232,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",233,0) ;" Array("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",234,0) ;" Array("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",235,0) ;" Array(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",236,0) ;" Array(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",237,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",238,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",239,0) ;" Answers -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGNDF2F",240,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",241,0) ;" Answer(count)=IEN^TMGTradeName^TMGGeneric "RTN","TMGNDF2F",242,0) ;" Answer(count)=IEN^TMGTradeName^TMGGeneric "RTN","TMGNDF2F",243,0) ;" ShowBoth -- OPTIONAL, if value=1, thenTMGGeneric & TMGTrade names will both be shown. Default=0 "RTN","TMGNDF2F",244,0) ;" ByGeneric -- OPTIONAL, if value=1, then list is shown sorted by Generic Name. Default=0 "RTN","TMGNDF2F",245,0) ;" ShowIngred -- OPTIONAL, if value=1 then all possible ingredients are shown. Default=0 "RTN","TMGNDF2F",246,0) ;" CompactMode -- OPTIONAL, if value=1 then only 20 entries are shown. "RTN","TMGNDF2F",247,0) ;"Output: List is shown, and the Answers array is established and passed back. "RTN","TMGNDF2F",248,0) ;"Results: none. "RTN","TMGNDF2F",249,0) "RTN","TMGNDF2F",250,0) new someShown set someShown=0 "RTN","TMGNDF2F",251,0) new count "RTN","TMGNDF2F",252,0) set count=1 "RTN","TMGNDF2F",253,0) kill Answers "RTN","TMGNDF2F",254,0) set ShowBoth=$get(ShowBoth,0) "RTN","TMGNDF2F",255,0) set ByGeneric=$get(ByGeneric,0) "RTN","TMGNDF2F",256,0) set ShowIngred=$get(ShowIngred,0) "RTN","TMGNDF2F",257,0) set CompactMode=$get(CompactMode,0) "RTN","TMGNDF2F",258,0) new NodeName set NodeName="BY TRADE" "RTN","TMGNDF2F",259,0) if ByGeneric=1 set NodeName="BY GENERIC" "RTN","TMGNDF2F",260,0) new ShortLen set ShortLen=25 "RTN","TMGNDF2F",261,0) "RTN","TMGNDF2F",262,0) write NodeName,! "RTN","TMGNDF2F",263,0) "RTN","TMGNDF2F",264,0) new done set done=0 "RTN","TMGNDF2F",265,0) new Itr,RxName,OtherName,IEN "RTN","TMGNDF2F",266,0) set RxName=$$ItrAInit^TMGITR("Array("""_NodeName_""")",.Itr) "RTN","TMGNDF2F",267,0) if RxName'="" for do quit:($$ItrANext^TMGITR(.Itr,.RxName)="")!(done=1) "RTN","TMGNDF2F",268,0) . new Itr2 "RTN","TMGNDF2F",269,0) . set IEN=$$ItrAInit^TMGITR("Array("""_NodeName_""","""_RxName_""")",.Itr2) "RTN","TMGNDF2F",270,0) . if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr2,.IEN)'>0)!(done=1) "RTN","TMGNDF2F",271,0) . . set OtherName=$get(Array(NodeName,RxName,IEN)) "RTN","TMGNDF2F",272,0) . . set Answers(count)=IEN "RTN","TMGNDF2F",273,0) . . if (CompactMode=0)!(count'>ShortLen) do "RTN","TMGNDF2F",274,0) . . . new NumMatches set NumMatches=$$ListCt^TMGMISC("Array("""_IEN_""",""POSS RX MATCH"")") "RTN","TMGNDF2F",275,0) . . . write count,". ",RxName "RTN","TMGNDF2F",276,0) . . . if (ShowBoth)&(OtherName'="?") write " (",OtherName,")" "RTN","TMGNDF2F",277,0) . . . write " (",NumMatches," possible matches)",! "RTN","TMGNDF2F",278,0) . . set someShown=1 "RTN","TMGNDF2F",279,0) . . set count=count+1 "RTN","TMGNDF2F",280,0) . . if (CompactMode=1)&(count>ShortLen) quit "RTN","TMGNDF2F",281,0) . . new Itr3,IngredIEN set IngredIEN="" "RTN","TMGNDF2F",282,0) . . if ShowIngred=0 quit "RTN","TMGNDF2F",283,0) . . set IngredIEN=$$ItrAInit^TMGITR("Array("""_IEN_""",""POSS IGD MATCH"")",.Itr3) "RTN","TMGNDF2F",284,0) . . if IngredIEN'="" for do quit:($$ItrANext^TMGITR(.Itr3,.IngredIEN)="") "RTN","TMGNDF2F",285,0) . . . new IngredName set IngredName=$get(Array(IEN,"POSS IGD MATCH",IngredIEN)) "RTN","TMGNDF2F",286,0) . . . if IngredName'="" write " -- ",IngredName,! "RTN","TMGNDF2F",287,0) if (CompactMode=1)&(count>ShortLen) do "RTN","TMGNDF2F",288,0) . write "... ",(count-ShortLen-1)," other items truncated.",! "RTN","TMGNDF2F",289,0) "RTN","TMGNDF2F",290,0) SL2 if 'someShown write " --- (List is Empty) ---",! "RTN","TMGNDF2F",291,0) "RTN","TMGNDF2F",292,0) SLDone quit "RTN","TMGNDF2F",293,0) "RTN","TMGNDF2F",294,0) "RTN","TMGNDF2F",295,0) HandleList(Array) "RTN","TMGNDF2F",296,0) ;"Purpose: to allow user to manipulate and fix problems found "RTN","TMGNDF2F",297,0) ;"Input: Array -- PASS BY REFERENCE. The list as created by GetSuggestions() "RTN","TMGNDF2F",298,0) ;" note IEN is from 22706.9 "RTN","TMGNDF2F",299,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",300,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",301,0) ;" Array("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",302,0) ;" Array("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",303,0) ;" Array(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",304,0) ;" Array(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",305,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",306,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",307,0) "RTN","TMGNDF2F",308,0) new done set done=0 "RTN","TMGNDF2F",309,0) new input set input="R" "RTN","TMGNDF2F",310,0) new Answers "RTN","TMGNDF2F",311,0) new CompactMode set CompactMode=1 ;" (list display mode: 1=compact, 0=verbose) "RTN","TMGNDF2F",312,0) new ShowBoth set ShowBoth=0 "RTN","TMGNDF2F",313,0) new ShowIngred set ShowIngred=0 "RTN","TMGNDF2F",314,0) new ByGeneric set ByGeneric=0 "RTN","TMGNDF2F",315,0) new EntryList,EntryS,Fn,Cancelled "RTN","TMGNDF2F",316,0) new CompactMode set CompactMode=1 "RTN","TMGNDF2F",317,0) set Cancelled=0 "RTN","TMGNDF2F",318,0) "RTN","TMGNDF2F",319,0) for do quit:(done=1) "RTN","TMGNDF2F",320,0) . if input="R" do "RTN","TMGNDF2F",321,0) . . write !! "RTN","TMGNDF2F",322,0) . . write "--------------------------------------------------",! "RTN","TMGNDF2F",323,0) . . write "Specify which drugs to FIX",! "RTN","TMGNDF2F",324,0) . . write "--------------------------------------------------",! "RTN","TMGNDF2F",325,0) . . do ShowList(.Array,.Answers,ShowBoth,ByGeneric,ShowIngred,CompactMode) "RTN","TMGNDF2F",326,0) . . write "--------------------------------------------------",! "RTN","TMGNDF2F",327,0) . . write "Specify which drugs to FIX",! "RTN","TMGNDF2F",328,0) . . write "--------------------------------------------------",! "RTN","TMGNDF2F",329,0) . . write " R to refresh, L lookup X remove from list, N iNfo",! "RTN","TMGNDF2F",330,0) . . write " M to Manually add Ingredients",! "RTN","TMGNDF2F",331,0) . . write " C turn Compact display ",$select((CompactMode=1):"OFF",1:"ON") "RTN","TMGNDF2F",332,0) . . write " I turn Show Ingredients display ",$select((ShowIngred=1):"OFF",1:"ON"),! "RTN","TMGNDF2F",333,0) . . if $get(EntryS)'="" write " Current SET #'s: ",EntryS,", D to delete SET",! "RTN","TMGNDF2F",334,0) . . write " # or #-# or #,#-#,# etc., ^ done, ",! "RTN","TMGNDF2F",335,0) . write "Enter number(s) to Fix (or codes listed above): ^//" "RTN","TMGNDF2F",336,0) . read input:$get(DTIME,3600),! "RTN","TMGNDF2F",337,0) . if input="" set input="^" "RTN","TMGNDF2F",338,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF2F",339,0) . if input="^" set done=1 quit "RTN","TMGNDF2F",340,0) . if input="R" quit "RTN","TMGNDF2F",341,0) . else if input="I" do quit "RTN","TMGNDF2F",342,0) . . set ShowIngred='ShowIngred "RTN","TMGNDF2F",343,0) . . set input="R" "RTN","TMGNDF2F",344,0) . else if input="C" do quit "RTN","TMGNDF2F",345,0) . . set CompactMode='CompactMode "RTN","TMGNDF2F",346,0) . . set input="R" "RTN","TMGNDF2F",347,0) . else if input="M" do quit;"<----- Manual add Ingredients "RTN","TMGNDF2F",348,0) . . set Fn="do ManIngredients(.Array,.Answers,.EntryList)" "RTN","TMGNDF2F",349,0) . . do XMenuOption("MANUALLY add INGREDIENTS to",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF2F",350,0) . . set input="R" "RTN","TMGNDF2F",351,0) . else if input="D" do quit;"---- delete set "RTN","TMGNDF2F",352,0) . . kill EntryList,EntryS "RTN","TMGNDF2F",353,0) . . set input="R" "RTN","TMGNDF2F",354,0) . else if input="L" do quit;"<----- Do Lookup "RTN","TMGNDF2F",355,0) . . set input=1 ;"a dummy entry, not needed. "RTN","TMGNDF2F",356,0) . . set Fn="do Lookup(.Array,.Answers,.EntryList)" "RTN","TMGNDF2F",357,0) . . do XMenuOption("",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF2F",358,0) . else if input="N" do quit;"<----- Show Info "RTN","TMGNDF2F",359,0) . . set Fn="do ShowInfo(.Array,.Answers,.EntryList)" "RTN","TMGNDF2F",360,0) . . do XMenuOption("show INFO about",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF2F",361,0) . else if input="X" do quit;"<----- Set Skip "RTN","TMGNDF2F",362,0) . . set Fn="do SetSkip(.Array,.Answers,.EntryList)" "RTN","TMGNDF2F",363,0) . . do XMenuOption("specify NOT to ADD",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF2F",364,0) . . set input="R" "RTN","TMGNDF2F",365,0) . else do ;"default is ACCEPT "RTN","TMGNDF2F",366,0) . . set Cancelled=0 "RTN","TMGNDF2F",367,0) . . set Fn="do FixItems(.Array,.Answers,.EntryList)" "RTN","TMGNDF2F",368,0) . . do XMenuOption("",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF2F",369,0) . . set input="R" "RTN","TMGNDF2F",370,0) "RTN","TMGNDF2F",371,0) quit "RTN","TMGNDF2F",372,0) "RTN","TMGNDF2F",373,0) "RTN","TMGNDF2F",374,0) XMenuOption(Prompt,FnStr,HlpFn,EntryList,EntryS) "RTN","TMGNDF2F",375,0) ;"Purpose: To carry out the various menu functions "RTN","TMGNDF2F",376,0) ;"Input: Prompt: the message to use to prompt user to enter numbers etc. "RTN","TMGNDF2F",377,0) ;" "Enter the Number(s) to" will be automatically provided "RTN","TMGNDF2F",378,0) ;" and ": (? help) ^// " will be added at end "RTN","TMGNDF2F",379,0) ;" FnStr: -- code to execute, e.g. "do DoLookup(.Array,.Answers,.Classes,.EntryList)" "RTN","TMGNDF2F",380,0) ;" HlpFn: e.g. FindHelp, SimHelp, LookupHelp, etc Don't add () to name "RTN","TMGNDF2F",381,0) ;" EntryList -- PASS BY REFERENCE "RTN","TMGNDF2F",382,0) ;" EntryS -- PASS BY REFERENCE. a string showing current set as a string "RTN","TMGNDF2F",383,0) ;"Note: makes use of global scope of 'input', and 'CompactMode', 'Cancelled' "RTN","TMGNDF2F",384,0) ;"Result: none. "RTN","TMGNDF2F",385,0) "RTN","TMGNDF2F",386,0) if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF2F",387,0) . if Prompt'="" do "RTN","TMGNDF2F",388,0) XMO1 . . write "Enter the Number(s) to ",Prompt,": (? help) ^// " "RTN","TMGNDF2F",389,0) . . read input,! "RTN","TMGNDF2F",390,0) . . if (input="?") do goto XMO1 "RTN","TMGNDF2F",391,0) . . . if Hlpfn="" write "(Sorry, no help available)",! quit "RTN","TMGNDF2F",392,0) . . . new Code set Code="do "_HlpFn_"()" "RTN","TMGNDF2F",393,0) . . . Xecute code "RTN","TMGNDF2F",394,0) . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF2F",395,0) . if valid set EntryS=input "RTN","TMGNDF2F",396,0) Xecute FnStr "RTN","TMGNDF2F",397,0) if $get(CompactMode)=1 set input="R" "RTN","TMGNDF2F",398,0) if $get(Cancelled)=0 kill EntryList,EntryS "RTN","TMGNDF2F",399,0) "RTN","TMGNDF2F",400,0) quit "RTN","TMGNDF2F",401,0) "RTN","TMGNDF2F",402,0) "RTN","TMGNDF2F",403,0) SetSkip(Array,Answers,EntryList) "RTN","TMGNDF2F",404,0) ;"Purpose: To remove entries from consideration for adding to 50.68 "RTN","TMGNDF2F",405,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",406,0) ;" Answers -- PASS BY REFERENCE "RTN","TMGNDF2F",407,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",408,0) ;" Answers(count)=IEN^TMGTradeName^TMGGeneric "RTN","TMGNDF2F",409,0) ;" Answers(count)=IEN^TMGTradeName^TMGGeneric "RTN","TMGNDF2F",410,0) ;" EntryList -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2F",411,0) ;" Format as follows. "RTN","TMGNDF2F",412,0) ;" EntryList(Entry number)="" (same as count above) "RTN","TMGNDF2F",413,0) ;" EntryList(Entry number)="" "RTN","TMGNDF2F",414,0) ;"Results: none "RTN","TMGNDF2F",415,0) "RTN","TMGNDF2F",416,0) new Itr,Count,IEN "RTN","TMGNDF2F",417,0) set Count=$$ItrAInit^TMGITR("EntryList",.Itr) "RTN","TMGNDF2F",418,0) if Count>0 for do quit:($$ItrANext^TMGITR(.Itr,.Count)'>0) "RTN","TMGNDF2F",419,0) . set IEN=$piece($get(Answers(Count)),"^",1) "RTN","TMGNDF2F",420,0) . if IEN="" quit "RTN","TMGNDF2F",421,0) . new TMGTradeName,TMGGeneric "RTN","TMGNDF2F",422,0) . set TMGTradeName=$piece($get(Array(IEN)),"^",1) "RTN","TMGNDF2F",423,0) . set TMGGeneric=$piece($get(Array(IEN)),"^",2) "RTN","TMGNDF2F",424,0) . ;"I could put in some undo code here... "RTN","TMGNDF2F",425,0) . set $piece(^TMG(22706.9,IEN,1),"^",4)=1 ;"set skipflag to true "RTN","TMGNDF2F",426,0) . ;"Now delete data from display data "RTN","TMGNDF2F",427,0) . kill Array(IEN) "RTN","TMGNDF2F",428,0) . if (TMGGeneric'="") kill Array("BY GENERIC",TMGGeneric,IEN) "RTN","TMGNDF2F",429,0) . if (TMGTradeName'="") kill Array("BY TRADE",TMGTradeName,IEN) "RTN","TMGNDF2F",430,0) "RTN","TMGNDF2F",431,0) quit "RTN","TMGNDF2F",432,0) "RTN","TMGNDF2F",433,0) "RTN","TMGNDF2F",434,0) ShowInfo(Array,Answers,EntryList) "RTN","TMGNDF2F",435,0) ;"Purpose: To allow user to explore existing entries in 22706.9 file "RTN","TMGNDF2F",436,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",437,0) ;" Answers -- PASS BY REFERENCE, "RTN","TMGNDF2F",438,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",439,0) ;" Answer(count)=IEN "RTN","TMGNDF2F",440,0) ;" EntryList -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2F",441,0) ;" Format as follows. "RTN","TMGNDF2F",442,0) ;" EntryList(Entry number)="" (same as count above) "RTN","TMGNDF2F",443,0) "RTN","TMGNDF2F",444,0) new Itr,Count,IEN "RTN","TMGNDF2F",445,0) set Count=$$ItrAInit^TMGITR("EntryList",.Itr) "RTN","TMGNDF2F",446,0) if Count>0 for do quit:($$ItrANext^TMGITR(.Itr,.Count)'>0) "RTN","TMGNDF2F",447,0) . set IEN=$piece($get(Answers(Count)),"^",1) "RTN","TMGNDF2F",448,0) . do DumpRec2^TMGDEBUG(22706.9,IEN,0) "RTN","TMGNDF2F",449,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2F",450,0) "RTN","TMGNDF2F",451,0) quit "RTN","TMGNDF2F",452,0) "RTN","TMGNDF2F",453,0) "RTN","TMGNDF2F",454,0) Lookup(Array,Answers,EntryList) "RTN","TMGNDF2F",455,0) ;"Purpose: To allow user to explore existing entries in 50.68 file "RTN","TMGNDF2F",456,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",457,0) ;" Answers -- PASS BY REFERENCE, "RTN","TMGNDF2F",458,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",459,0) ;" Answer(count)=IEN "RTN","TMGNDF2F",460,0) ;" EntryList -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2F",461,0) ;" Format as follows. "RTN","TMGNDF2F",462,0) ;" EntryList(Entry number)="" (same as count above) "RTN","TMGNDF2F",463,0) "RTN","TMGNDF2F",464,0) new DIC,Y "RTN","TMGNDF2F",465,0) set DIC=50.68 "RTN","TMGNDF2F",466,0) set DIC(0)="MAEQ" "RTN","TMGNDF2F",467,0) do ^DIC write ! "RTN","TMGNDF2F",468,0) if +Y>0 do "RTN","TMGNDF2F",469,0) . do DumpRec2^TMGDEBUG(50.68,+Y,0) "RTN","TMGNDF2F",470,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2F",471,0) "RTN","TMGNDF2F",472,0) quit "RTN","TMGNDF2F",473,0) "RTN","TMGNDF2F",474,0) FixItems(Array,Answers,EntryList) "RTN","TMGNDF2F",475,0) ;"Purpose: To Fix one item "RTN","TMGNDF2F",476,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",477,0) ;" Answers -- PASS BY REFERENCE "RTN","TMGNDF2F",478,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",479,0) ;" Answers(count)=IEN^TMGTradeName^TMGGeneric "RTN","TMGNDF2F",480,0) ;" Answers(count)=IEN^TMGTradeName^TMGGeneric "RTN","TMGNDF2F",481,0) ;" EntryList -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2F",482,0) ;" Format as follows. "RTN","TMGNDF2F",483,0) ;" EntryList(Entry number)="" (same as count above) "RTN","TMGNDF2F",484,0) ;" EntryList(Entry number)="" "RTN","TMGNDF2F",485,0) ;"Results: none "RTN","TMGNDF2F",486,0) "RTN","TMGNDF2F",487,0) new Itr,Count,IEN "RTN","TMGNDF2F",488,0) new done set done=0 "RTN","TMGNDF2F",489,0) new vapIEN set vapIEN=0 ;"for first cycle, no ready answer available. "RTN","TMGNDF2F",490,0) "RTN","TMGNDF2F",491,0) set Count=$$ItrAInit^TMGITR("EntryList",.Itr) "RTN","TMGNDF2F",492,0) if Count>0 for do quit:($$ItrANext^TMGITR(.Itr,.Count)'>0)!(done=1) "RTN","TMGNDF2F",493,0) . set IEN=$piece($get(Answers(Count)),"^",1) "RTN","TMGNDF2F",494,0) . if vapIEN'=0 do ;"If we've already fixed on, use same answer for rest of list "RTN","TMGNDF2F",495,0) . . if $$Fix1From(IEN,vapIEN,.Array,1)=0 set done=1 "RTN","TMGNDF2F",496,0) . else do "RTN","TMGNDF2F",497,0) . . set vapIEN=$$AskFix1Item(.Array,IEN) "RTN","TMGNDF2F",498,0) . . if vapIEN=0 set done=1 "RTN","TMGNDF2F",499,0) . if done=1 quit "RTN","TMGNDF2F",500,0) . do ArrayKill(IEN,.Array) ;"delete data from display data "RTN","TMGNDF2F",501,0) "RTN","TMGNDF2F",502,0) quit "RTN","TMGNDF2F",503,0) "RTN","TMGNDF2F",504,0) "RTN","TMGNDF2F",505,0) AskFix1Item(Array,IEN) "RTN","TMGNDF2F",506,0) ;"Purpose: to fix one entry, with user input "RTN","TMGNDF2F",507,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",508,0) ;" IEN -- the Record to fix. "RTN","TMGNDF2F",509,0) ;"Results: 1 if item Fixed, 0 if not "RTN","TMGNDF2F",510,0) "RTN","TMGNDF2F",511,0) ;"First, ask if the drug is similar enough that a copy of that other drug "RTN","TMGNDF2F",512,0) ;" is allowed "RTN","TMGNDF2F",513,0) ;"Next, (if above fails), ask for matching of possible ingredients "RTN","TMGNDF2F",514,0) ;"If no ingredient found, even consider adding a new ingredient to INGREDIENT file "RTN","TMGNDF2F",515,0) "RTN","TMGNDF2F",516,0) new done set done=0 "RTN","TMGNDF2F",517,0) new input set input="R" "RTN","TMGNDF2F",518,0) new Answers,Fn "RTN","TMGNDF2F",519,0) new CompactMode set CompactMode=1 ;" (list display mode: 1=compact, 0=verbose) "RTN","TMGNDF2F",520,0) new ShowBoth set ShowBoth=0 "RTN","TMGNDF2F",521,0) new ShowIngred set ShowIngred=0 "RTN","TMGNDF2F",522,0) new ByGeneric set ByGeneric=0 "RTN","TMGNDF2F",523,0) new EntryList,EntryS,Fn,Cancelled "RTN","TMGNDF2F",524,0) new FixedWithIEN set FixedWithIEN=0 "RTN","TMGNDF2F",525,0) "RTN","TMGNDF2F",526,0) for do quit:(done=1) "RTN","TMGNDF2F",527,0) . if input="R" do "RTN","TMGNDF2F",528,0) . . write !! "RTN","TMGNDF2F",529,0) . . write "--------------------------------------------------",! "RTN","TMGNDF2F",530,0) . . write "Specify CLOSEST MATCH (IGNORE DOSE & FORM)",! "RTN","TMGNDF2F",531,0) . . do Show1(.Array,IEN,.Answers,0) "RTN","TMGNDF2F",532,0) . . if $$ListCt^TMGMISC("Answers")>20 do "RTN","TMGNDF2F",533,0) . . . write "--------------------------------------------------",! "RTN","TMGNDF2F",534,0) . . . write "Specify CLOSEST MATCH (IGNORE DOSE & FORM)",! "RTN","TMGNDF2F",535,0) . . write "--------------------------------------------------",! "RTN","TMGNDF2F",536,0) . . write " R to refresh, F to find Match",! "RTN","TMGNDF2F",537,0) . . write " X to remove from list",! "RTN","TMGNDF2F",538,0) . . if $get(EntryS)'="" write " Current SET #'s: ",EntryS,", D to delete SET",! "RTN","TMGNDF2F",539,0) . . write " ^ if done, ",! "RTN","TMGNDF2F",540,0) . write "Enter number to ACCEPT (or codes listed above): ^//" "RTN","TMGNDF2F",541,0) . read input:$get(DTIME,3600),! "RTN","TMGNDF2F",542,0) . if input="" set input="^" "RTN","TMGNDF2F",543,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF2F",544,0) . if input="^" set done=1 quit "RTN","TMGNDF2F",545,0) . if input="R" quit "RTN","TMGNDF2F",546,0) . else if input="D" do quit;"---- delete set "RTN","TMGNDF2F",547,0) . . kill EntryList,EntryS "RTN","TMGNDF2F",548,0) . . set input="R" "RTN","TMGNDF2F",549,0) . else if input="F" do quit;"<----- Look for answer "RTN","TMGNDF2F",550,0) . . set FixedWithIEN=$$Look2Fix(IEN,.Array) "RTN","TMGNDF2F",551,0) . . if FixedWithIEN'=0 set done=1 "RTN","TMGNDF2F",552,0) . . else set input="R" "RTN","TMGNDF2F",553,0) . else if input="X" do quit;"<----- Set Skip "RTN","TMGNDF2F",554,0) . . set Fn="do KillMatch(IEN,.Array,.Answers,.EntryList)" "RTN","TMGNDF2F",555,0) . . do XMenuOption("specify match NOT to USE",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF2F",556,0) . else do ;"default is ACCEPT "RTN","TMGNDF2F",557,0) . . if (input["-")!(input[",") write "ENTER ONLY *ONE* ENTRY NUMBER",! quit "RTN","TMGNDF2F",558,0) . . new vapIEN set vapIEN=+$get(Answers(+input)) "RTN","TMGNDF2F",559,0) . . if vapIEN>0 set FixedWithIEN=$$Fix1From(IEN,vapIEN,.Array) "RTN","TMGNDF2F",560,0) . . if FixedWithIEN'=0 set done=1 "RTN","TMGNDF2F",561,0) . . else set input="R" "RTN","TMGNDF2F",562,0) "RTN","TMGNDF2F",563,0) quit FixedWithIEN "RTN","TMGNDF2F",564,0) "RTN","TMGNDF2F",565,0) "RTN","TMGNDF2F",566,0) Show1(Array,IEN,Answers,ShowIgd) "RTN","TMGNDF2F",567,0) ;"Purpose: To display the list generated by GetSuggestions "RTN","TMGNDF2F",568,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",569,0) ;" IEN -- the One entry to display "RTN","TMGNDF2F",570,0) ;" Answers -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGNDF2F",571,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",572,0) ;" Answer(count)=IEN "RTN","TMGNDF2F",573,0) ;" Answer(count)=IEN "RTN","TMGNDF2F",574,0) ;" ShowIgd -- OPTIONAL, if value=1 then ingredients will be shown, otherwise "RTN","TMGNDF2F",575,0) ;" matches in VA PRODUCT FILE are shown. "RTN","TMGNDF2F",576,0) ;"Output: List is shown, and the Answers array is established and passed back. "RTN","TMGNDF2F",577,0) ;"Results: none. "RTN","TMGNDF2F",578,0) "RTN","TMGNDF2F",579,0) new someShown set someShown=0 "RTN","TMGNDF2F",580,0) new count set count=1 "RTN","TMGNDF2F",581,0) kill Answers "RTN","TMGNDF2F",582,0) new NodeName set NodeName="POSS RX MATCH" "RTN","TMGNDF2F",583,0) if $get(ShowIgd)=1 set NodeName="POSS IGD MATCH" "RTN","TMGNDF2F",584,0) "RTN","TMGNDF2F",585,0) new Itr,subIEN "RTN","TMGNDF2F",586,0) new TMGTradeName,TMGGeneric "RTN","TMGNDF2F",587,0) "RTN","TMGNDF2F",588,0) set TMGTradeName=$piece($get(Array(IEN)),"^",1) "RTN","TMGNDF2F",589,0) set TMGGeneric=$piece($get(Array(IEN)),"^",2) "RTN","TMGNDF2F",590,0) write " For: ",TMGTradeName "RTN","TMGNDF2F",591,0) if (TMGGeneric'="?")&(TMGGeneric'="") write " (",TMGGeneric,")" "RTN","TMGNDF2F",592,0) write ! "RTN","TMGNDF2F",593,0) write "--------------------------------------------------",! "RTN","TMGNDF2F",594,0) "RTN","TMGNDF2F",595,0) if $get(IEN)="" goto S1Done "RTN","TMGNDF2F",596,0) "RTN","TMGNDF2F",597,0) set subIEN=$$ItrAInit^TMGITR("Array("_IEN_","""_NodeName_""")",.Itr) "RTN","TMGNDF2F",598,0) if subIEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.subIEN)="") "RTN","TMGNDF2F",599,0) . set Answers(count)=subIEN "RTN","TMGNDF2F",600,0) . new Name set Name=$get(Array(IEN,NodeName,subIEN)) "RTN","TMGNDF2F",601,0) . write count,". ",Name,! "RTN","TMGNDF2F",602,0) . set count=count+1 "RTN","TMGNDF2F",603,0) . set someShown=1 "RTN","TMGNDF2F",604,0) "RTN","TMGNDF2F",605,0) S1Done "RTN","TMGNDF2F",606,0) if 'someShown write " --- (List is Empty) ---",! "RTN","TMGNDF2F",607,0) quit "RTN","TMGNDF2F",608,0) "RTN","TMGNDF2F",609,0) "RTN","TMGNDF2F",610,0) Look2Fix(IEN,Array) "RTN","TMGNDF2F",611,0) ;"Purpose: To allow user to find a match to use for fixing. "RTN","TMGNDF2F",612,0) ;"Input: IEN -- the IEN to fix "RTN","TMGNDF2F",613,0) ;" Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",614,0) ;"Result: 0 if no fix, or vapIEN (IEN in 50.68) otherwise "RTN","TMGNDF2F",615,0) "RTN","TMGNDF2F",616,0) new result set result=0 ;"default to failure "RTN","TMGNDF2F",617,0) "RTN","TMGNDF2F",618,0) write "SEARCH for a drug that can be used to fix incomplete entry.",! "RTN","TMGNDF2F",619,0) new DIC,Y "RTN","TMGNDF2F",620,0) set DIC=50.68 "RTN","TMGNDF2F",621,0) set DIC(0)="MAEQ" "RTN","TMGNDF2F",622,0) do ^DIC write ! "RTN","TMGNDF2F",623,0) if +Y>0 do "RTN","TMGNDF2F",624,0) . if $$Fix1From(IEN,+Y,.Array)=1 set result=+Y "RTN","TMGNDF2F",625,0) "RTN","TMGNDF2F",626,0) quit result "RTN","TMGNDF2F",627,0) "RTN","TMGNDF2F",628,0) "RTN","TMGNDF2F",629,0) KillMatch(IEN,Array,Answers,EntryList) "RTN","TMGNDF2F",630,0) ;"Purpose: To remove VA PRODUCT matches from consideration "RTN","TMGNDF2F",631,0) ;"Input: IEN -- the IEN in 22706.9, "RTN","TMGNDF2F",632,0) ;" Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",633,0) ;" Answers -- PASS BY REFERENCE, "RTN","TMGNDF2F",634,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",635,0) ;" Answer(count)=IEN "RTN","TMGNDF2F",636,0) ;" EntryList -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2F",637,0) ;" Format as follows. "RTN","TMGNDF2F",638,0) ;" EntryList(Entry number)="" (same as count above) "RTN","TMGNDF2F",639,0) "RTN","TMGNDF2F",640,0) new Itr,Count,subIEN "RTN","TMGNDF2F",641,0) set Count=$$ItrAInit^TMGITR("EntryList",.Itr) "RTN","TMGNDF2F",642,0) if Count>0 for do quit:($$ItrANext^TMGITR(.Itr,.Count)'>0) "RTN","TMGNDF2F",643,0) . set subIEN=$piece($get(Answers(Count)),"^",1) "RTN","TMGNDF2F",644,0) . new TMGTradeName,TMGGeneric "RTN","TMGNDF2F",645,0) . set TMGTradeName=$piece($get(Array(IEN)),"^",1) "RTN","TMGNDF2F",646,0) . set TMGGeneric=$piece($get(Array(IEN)),"^",2) "RTN","TMGNDF2F",647,0) . ;"I could put in some undo code here... "RTN","TMGNDF2F",648,0) . ;"Now delete data from display data "RTN","TMGNDF2F",649,0) . ;"kill Array(IEN,"POSS RX MATCH",subIEN) "RTN","TMGNDF2F",650,0) . do ArrayKill(IEN,.Array) "RTN","TMGNDF2F",651,0) quit "RTN","TMGNDF2F",652,0) "RTN","TMGNDF2F",653,0) "RTN","TMGNDF2F",654,0) ArrayKill(IEN,Array) "RTN","TMGNDF2F",655,0) ;"Purpose: to remove entry IEN from the Array of drugs to be fixed "RTN","TMGNDF2F",656,0) ;"Input: IEN -- the IEN to remove "RTN","TMGNDF2F",657,0) ;" Array -- the array with the drug info. Format as follows: "RTN","TMGNDF2F",658,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",659,0) ;" Array(IEN)=TMGTradeName^TMGGeneric "RTN","TMGNDF2F",660,0) ;" Array("BY GENERIC",TMGGeneric,IEN)=TMGTradeName "RTN","TMGNDF2F",661,0) ;" Array("BY TRADE",TMGTradeName,IEN)=TMGGeneric "RTN","TMGNDF2F",662,0) ;" Array(IEN,"POSS IGD MATCH",igdIEN)=IngredientName "RTN","TMGNDF2F",663,0) ;" Array(IEN,"POSS IGD MATCH"igdIEN)=IngredientName "RTN","TMGNDF2F",664,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",665,0) ;" Array(IEN,"POSS RX MATCH",RxIEN)=vapEntryName "RTN","TMGNDF2F",666,0) "RTN","TMGNDF2F",667,0) new TMGTradeName,TMGGeneric "RTN","TMGNDF2F",668,0) set TMGTradeName=$piece($get(Array(IEN)),"^",1) "RTN","TMGNDF2F",669,0) set TMGGeneric=$piece($get(Array(IEN)),"^",2) "RTN","TMGNDF2F",670,0) if TMGTradeName="" set TMGTradeName="?" "RTN","TMGNDF2F",671,0) if TMGGeneric="" set TMGGeneric="?" "RTN","TMGNDF2F",672,0) kill Array(IEN) "RTN","TMGNDF2F",673,0) kill Array("BY TRADE",TMGTradeName,IEN) "RTN","TMGNDF2F",674,0) kill Array("BY GENERIC",TMGGeneric,IEN) "RTN","TMGNDF2F",675,0) "RTN","TMGNDF2F",676,0) quit "RTN","TMGNDF2F",677,0) "RTN","TMGNDF2F",678,0) "RTN","TMGNDF2F",679,0) Fix1From(IEN,vapIEN,Array,NoVerify) "RTN","TMGNDF2F",680,0) ;"Purpose: To take a record in VA PRODUCT file (50.68) and use this to fix record in "RTN","TMGNDF2F",681,0) ;" TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF2F",682,0) ;"Input: IEN -- the IEN in 22706.9, "RTN","TMGNDF2F",683,0) ;" vapIEN -- the IEN in 50.68 to fix from "RTN","TMGNDF2F",684,0) ;" Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",685,0) ;" NoVerify -- OPTIONAL, if value=1 no user verification asked. Default=0 "RTN","TMGNDF2F",686,0) ;"result: 1 if OK to continue, 0 if user abort "RTN","TMGNDF2F",687,0) "RTN","TMGNDF2F",688,0) new result set result=0 ;"default to failure "RTN","TMGNDF2F",689,0) "RTN","TMGNDF2F",690,0) if $get(NoVerify,0)=0,$$VerifySource(vapIEN)=0 goto F1FDone "RTN","TMGNDF2F",691,0) ;"I could put in some undo code here... BUT undoing changes from Copy1 would be HARD "RTN","TMGNDF2F",692,0) if $$Copy1(vapIEN,IEN)=0 goto F1FDone "RTN","TMGNDF2F",693,0) do ArrayKill(IEN,.Array) "RTN","TMGNDF2F",694,0) set result=1 ;"success "RTN","TMGNDF2F",695,0) "RTN","TMGNDF2F",696,0) F1FDone "RTN","TMGNDF2F",697,0) quit result "RTN","TMGNDF2F",698,0) "RTN","TMGNDF2F",699,0) "RTN","TMGNDF2F",700,0) VerifySource(vapIEN) "RTN","TMGNDF2F",701,0) ;"Purpose: to show the drug name, and the drug's ingredients, and ask user to verify choice "RTN","TMGNDF2F",702,0) ;"Input: vapIEN -- IEN in file 50.68 "RTN","TMGNDF2F",703,0) ;"Result: 1 if OK to use this drug. 0 if don't use "RTN","TMGNDF2F",704,0) "RTN","TMGNDF2F",705,0) new PriorErrorFound "RTN","TMGNDF2F",706,0) new result set result=0 "RTN","TMGNDF2F",707,0) write "-------------------------------------------------",! "RTN","TMGNDF2F",708,0) write "Drug Information:",! "RTN","TMGNDF2F",709,0) write "-------------------------------------------------",! "RTN","TMGNDF2F",710,0) ;"write "NAME: ",$$GET1^DIQ(50.68,vapIEN,.01),! "RTN","TMGNDF2F",711,0) write "GENERIC NAME: ",$$GET1^DIQ(50.68,vapIEN,.05),! "RTN","TMGNDF2F",712,0) write "INGREDIENTS:",! "RTN","TMGNDF2F",713,0) new TMGMSG,TMGFDA "RTN","TMGNDF2F",714,0) do LIST^DIC(50.6814,","_vapIEN_",",".01;1","","*",,,,,,"TMGFDA","TMGMSG") "RTN","TMGNDF2F",715,0) if $data(TMGMSG("DIERR"))'=0 do goto VSDone "RTN","TMGNDF2F",716,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2F",717,0) new i "RTN","TMGNDF2F",718,0) for i=1:1:+$get(TMGFDA("DILIST",0)) do "RTN","TMGNDF2F",719,0) . write " ",$get(TMGFDA("DILIST",1,i)),! "RTN","TMGNDF2F",720,0) write "-------------------------------------------------",! "RTN","TMGNDF2F",721,0) write "Use this drug to fix entry in FDA database" "RTN","TMGNDF2F",722,0) new % set %=1 "RTN","TMGNDF2F",723,0) do YN^DICN write ! "RTN","TMGNDF2F",724,0) if %=1 set result=1 "RTN","TMGNDF2F",725,0) "RTN","TMGNDF2F",726,0) VSDone "RTN","TMGNDF2F",727,0) quit result "RTN","TMGNDF2F",728,0) "RTN","TMGNDF2F",729,0) "RTN","TMGNDF2F",730,0) Copy1(vapIEN,IEN) "RTN","TMGNDF2F",731,0) ;"Purpose: to fill in missing answers in the record in 22706.9, from record in 50.68 "RTN","TMGNDF2F",732,0) ;"Input: vapIEN -- IEN in 50.68 "RTN","TMGNDF2F",733,0) ;" IEN -- IEN in 22706.9 "RTN","TMGNDF2F",734,0) ;"Result: 1 if OK to continue, 0 if error "RTN","TMGNDF2F",735,0) "RTN","TMGNDF2F",736,0) new result set result=0 ;"default to failure "RTN","TMGNDF2F",737,0) new error set error=0 "RTN","TMGNDF2F",738,0) new PriorErrorFound "RTN","TMGNDF2F",739,0) "RTN","TMGNDF2F",740,0) new CompFields set CompFields=".08;.05^.09;15" "RTN","TMGNDF2F",741,0) new TMGFDA,TMGMSG "RTN","TMGNDF2F",742,0) new i,TMGField,vapField "RTN","TMGNDF2F",743,0) for i=1:1:$length(CompFields,"^") do "RTN","TMGNDF2F",744,0) . new field1,field2,comp "RTN","TMGNDF2F",745,0) . new Value1,Value2 "RTN","TMGNDF2F",746,0) . set comp=$piece(CompFields,"^",i) "RTN","TMGNDF2F",747,0) . set field1=$piece(comp,";",1) "RTN","TMGNDF2F",748,0) . set field2=$piece(comp,";",2) "RTN","TMGNDF2F",749,0) . set Value1=$$GET1^DIQ(22706.9,IEN,field1) "RTN","TMGNDF2F",750,0) . set Value2=$$GET1^DIQ(50.68,vapIEN,field2) "RTN","TMGNDF2F",751,0) . if (Value1="")&(Value2'="") do "RTN","TMGNDF2F",752,0) . . set TMGFDA(22706.9,IEN_",",field1)=Value2 "RTN","TMGNDF2F",753,0) "RTN","TMGNDF2F",754,0) if $data(TMGFDA) do goto:(error=1) C1Done "RTN","TMGNDF2F",755,0) . do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF2F",756,0) . if $data(TMGMSG("DIERR"))'=0 do "RTN","TMGNDF2F",757,0) . . set error=1 "RTN","TMGNDF2F",758,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2F",759,0) "RTN","TMGNDF2F",760,0) ;"Now prep to copy over ingredients... "RTN","TMGNDF2F",761,0) X1 new Itr,subIEN,IngredArray,tempIEN "RTN","TMGNDF2F",762,0) set subIEN=$$ItrInit^TMGITR(50.6814,.Itr,vapIEN) "RTN","TMGNDF2F",763,0) if subIEN>0 for do quit:($$ItrNext^TMGITR(.Itr,.subIEN)'>0)!(error=1) "RTN","TMGNDF2F",764,0) . set tempIEN=+$piece($get(^PSNDF(50.68,vapIEN,2,subIEN,0)),"^",1) "RTN","TMGNDF2F",765,0) . if tempIEN'>0 quit "RTN","TMGNDF2F",766,0) . kill TMGFDA "RTN","TMGNDF2F",767,0) . do FIND^DIC(22706.916,","_IEN_",",".01","AQ",tempIEN,"*",,,,"TMGFDA","TMGMSG") "RTN","TMGNDF2F",768,0) . if $data(TMGMSG("DIERR"))'=0 do quit "RTN","TMGNDF2F",769,0) . . set error=1 "RTN","TMGNDF2F",770,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2F",771,0) . if $get(TMGFDA("DILIST",0))>0 quit "RTN","TMGNDF2F",772,0) . set IngredArray(tempIEN)="" ;"store ingredients. Next I'll see if they are new "RTN","TMGNDF2F",773,0) "RTN","TMGNDF2F",774,0) set result=$$Add1Ingredients(IEN,.IngredArray) "RTN","TMGNDF2F",775,0) "RTN","TMGNDF2F",776,0) C1Done "RTN","TMGNDF2F",777,0) quit result "RTN","TMGNDF2F",778,0) "RTN","TMGNDF2F",779,0) "RTN","TMGNDF2F",780,0) ManIngredients(Array,Answers,EntryList) "RTN","TMGNDF2F",781,0) ;"Purpose: to Manually Add ingredients to a list of records "RTN","TMGNDF2F",782,0) ;"Input: Array -- PASS BY REFERENCE. Array with data. Format same as for HandleList "RTN","TMGNDF2F",783,0) ;" Answers -- PASS BY REFERENCE, "RTN","TMGNDF2F",784,0) ;" An array that will link display numbers with IENs "RTN","TMGNDF2F",785,0) ;" Answer(count)=IEN "RTN","TMGNDF2F",786,0) ;" EntryList -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF2F",787,0) ;" Format as follows. "RTN","TMGNDF2F",788,0) ;" EntryList(Entry number)="" (same as count above) "RTN","TMGNDF2F",789,0) ;"Result: None "RTN","TMGNDF2F",790,0) "RTN","TMGNDF2F",791,0) new Itr,Count,IEN "RTN","TMGNDF2F",792,0) new IngredArray "RTN","TMGNDF2F",793,0) new result set result=1 "RTN","TMGNDF2F",794,0) "RTN","TMGNDF2F",795,0) set Count=$$ItrAInit^TMGITR("EntryList",.Itr) "RTN","TMGNDF2F",796,0) if Count>0 for do quit:($$ItrANext^TMGITR(.Itr,.Count)'>0) "RTN","TMGNDF2F",797,0) . set IEN=$piece($get(Answers(Count)),"^",1) "RTN","TMGNDF2F",798,0) . if $data(IngredArray)=0 do "RTN","TMGNDF2F",799,0) . . set result=$$AskManIngred(IEN,.IngredArray) "RTN","TMGNDF2F",800,0) . else do "RTN","TMGNDF2F",801,0) . . set result=$$Add1Ingredients(IEN,.IngredArray) "RTN","TMGNDF2F",802,0) . ;"I could put in some undo code here... "RTN","TMGNDF2F",803,0) . if result=0 kill IngredArray quit "RTN","TMGNDF2F",804,0) . do ArrayKill(IEN,.Array) "RTN","TMGNDF2F",805,0) "RTN","TMGNDF2F",806,0) quit "RTN","TMGNDF2F",807,0) "RTN","TMGNDF2F",808,0) "RTN","TMGNDF2F",809,0) AskManIngred(IEN,IngredArray) "RTN","TMGNDF2F",810,0) ;"Purpose: To ask user for a list of ingredients, then add to record in 22706.9 "RTN","TMGNDF2F",811,0) ;"Input: IEN -- the IEN in 22706.9 to have ingredients added to "RTN","TMGNDF2F",812,0) ;" IngredArray -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF2F",813,0) ;" Ised to pass back out list of ingredients, so they can be used for other enteries "RTN","TMGNDF2F",814,0) ;" Any former entries in list will be killed "RTN","TMGNDF2F",815,0) ;"Result: 1 = OK To Continue, 0 if abort "RTN","TMGNDF2F",816,0) "RTN","TMGNDF2F",817,0) new result set result=0 "RTN","TMGNDF2F",818,0) kill IngredArray "RTN","TMGNDF2F",819,0) "RTN","TMGNDF2F",820,0) new DIC,Y "RTN","TMGNDF2F",821,0) set DIC=50.416,DIC(0)="AEQML" "RTN","TMGNDF2F",822,0) set DIC("A")="Enter a drug INGREDIENT to add (^ when done): " "RTN","TMGNDF2F",823,0) "RTN","TMGNDF2F",824,0) for do quit:(+Y'>0) "RTN","TMGNDF2F",825,0) . do ^DIC "RTN","TMGNDF2F",826,0) . if +Y>0 set IngredArray(+Y)="" "RTN","TMGNDF2F",827,0) . else write ! quit "RTN","TMGNDF2F",828,0) . write " ... OK, added.",! "RTN","TMGNDF2F",829,0) "RTN","TMGNDF2F",830,0) if $data(IngredArray)=0 goto AMIDone "RTN","TMGNDF2F",831,0) "RTN","TMGNDF2F",832,0) write "Done adding new ingredients.",!! "RTN","TMGNDF2F",833,0) new % set %=1 "RTN","TMGNDF2F",834,0) write "Ingredient List:",! "RTN","TMGNDF2F",835,0) write "------------------------------",! "RTN","TMGNDF2F",836,0) do ShowIngreds(.IngredArray) "RTN","TMGNDF2F",837,0) write "Add INGREDIENT(S) to selected drugs:" "RTN","TMGNDF2F",838,0) do YN^DICN write ! "RTN","TMGNDF2F",839,0) if %'=1 goto AMIDone "RTN","TMGNDF2F",840,0) "RTN","TMGNDF2F",841,0) set result=$$Add1Ingredients(IEN,.IngredArray) "RTN","TMGNDF2F",842,0) "RTN","TMGNDF2F",843,0) AMIDone "RTN","TMGNDF2F",844,0) quit result "RTN","TMGNDF2F",845,0) "RTN","TMGNDF2F",846,0) "RTN","TMGNDF2F",847,0) ShowIngreds(IngredArray) "RTN","TMGNDF2F",848,0) ;"Purpose: to Show list of ingredients in array "RTN","TMGNDF2F",849,0) "RTN","TMGNDF2F",850,0) new IEN,Itr "RTN","TMGNDF2F",851,0) set IEN=$$ItrAInit^TMGITR("IngredArray",.Itr) "RTN","TMGNDF2F",852,0) if IEN>0 for do quit:($$ItrANext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF2F",853,0) . write " ",$$GET1^DIQ(50.416,IEN,.01),! "RTN","TMGNDF2F",854,0) "RTN","TMGNDF2F",855,0) quit "RTN","TMGNDF2F",856,0) "RTN","TMGNDF2F",857,0) "RTN","TMGNDF2F",858,0) Add1Ingredients(IEN,IngredArray) "RTN","TMGNDF2F",859,0) ;"Purpose: To put a list of ingredients into one (1) record in 22706.9 "RTN","TMGNDF2F",860,0) ;"Input: IEN -- the IEN in 22706.9 to load ingredients into "RTN","TMGNDF2F",861,0) ;" IngredArray -- array with list of ingredients. Format as follows: "RTN","TMGNDF2F",862,0) ;" IngredArray(ingredIEN)="" "RTN","TMGNDF2F",863,0) ;" IngredArray(ingredIEN)="" "RTN","TMGNDF2F",864,0) ;"Output: Ingredients will be added to 22706.9. Note: If ingredients are already present, they "RTN","TMGNDF2F",865,0) ;" will be added a second time. "RTN","TMGNDF2F",866,0) ;" Also, FillGenericName will be called to fill in TMGGeneric Name "RTN","TMGNDF2F",867,0) ;"Results: 1 if OK to continue, 0 if error "RTN","TMGNDF2F",868,0) "RTN","TMGNDF2F",869,0) new Itr,TMGFDA,TMGMSG,tempIEN "RTN","TMGNDF2F",870,0) new result set result=0 ;"default to failure "RTN","TMGNDF2F",871,0) new error set error=0 "RTN","TMGNDF2F",872,0) "RTN","TMGNDF2F",873,0) ;"Cycle through IngredArray, and set up FDA for adding to 22706.9 "RTN","TMGNDF2F",874,0) kill Itr,TMGFDA "RTN","TMGNDF2F",875,0) set tempIEN=$$ItrAInit^TMGITR("IngredArray",.Itr) "RTN","TMGNDF2F",876,0) if tempIEN'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.tempIEN)'>0) "RTN","TMGNDF2F",877,0) . new IENS set IENS="+"_tempIEN_","_IEN_"," ;" +# format with # as arbitrary unique number "RTN","TMGNDF2F",878,0) . set TMGFDA(22706.916,IENS,.01)=tempIEN ;"an arbitrary index number "RTN","TMGNDF2F",879,0) . set TMGFDA(22706.916,IENS,2)=tempIEN ;"a pointer to the ingredent "RTN","TMGNDF2F",880,0) "RTN","TMGNDF2F",881,0) ;"Call UPDATE^DIE with FDA "RTN","TMGNDF2F",882,0) if $data(TMGFDA) do goto:(error=1) ADIDone "RTN","TMGNDF2F",883,0) . new TMGIEN "RTN","TMGNDF2F",884,0) . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2F",885,0) . if $data(TMGMSG("DIERR"))'=0 do "RTN","TMGNDF2F",886,0) . . set error=1 "RTN","TMGNDF2F",887,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2F",888,0) "RTN","TMGNDF2F",889,0) ;"Create a generic name from ingredients "RTN","TMGNDF2F",890,0) do FillGenericName^TMGNDF1C(IEN) "RTN","TMGNDF2F",891,0) "RTN","TMGNDF2F",892,0) set result=1 ;"success "RTN","TMGNDF2F",893,0) ADIDone "RTN","TMGNDF2F",894,0) quit result "RTN","TMGNDF2G") 0^46^B7234 "RTN","TMGNDF2G",1,0) TMGNDF2G ;TMG/kst/FDA Import: Setup shortened drug names ;03/25/06 "RTN","TMGNDF2G",2,0) ;;1.0;TMG-LIB;**1**;02/24/07 "RTN","TMGNDF2G",3,0) "RTN","TMGNDF2G",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF2G",5,0) ;" Creation of shortened version of drug names "RTN","TMGNDF2G",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF2G",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF2G",8,0) ;"2-24-2007 "RTN","TMGNDF2G",9,0) "RTN","TMGNDF2G",10,0) ;"======================================================================= "RTN","TMGNDF2G",11,0) ;" API -- Public Functions. "RTN","TMGNDF2G",12,0) ;"======================================================================= "RTN","TMGNDF2G",13,0) "RTN","TMGNDF2G",14,0) ;"Menu -- Ensure other version of drug names available. "RTN","TMGNDF2G",15,0) "RTN","TMGNDF2G",16,0) ;"======================================================================= "RTN","TMGNDF2G",17,0) ;" Private Functions. "RTN","TMGNDF2G",18,0) ;"======================================================================= "RTN","TMGNDF2G",19,0) ;"MakeAltNames -- scan through all entries and set up shortened names. "RTN","TMGNDF2G",20,0) ;"Make1Alt(IEN) --fix the names for just 1 record in 22706.9 "RTN","TMGNDF2G",21,0) ;"GetIENArray(Array) -- Gather IENS to work on "RTN","TMGNDF2G",22,0) ;"GetPrepArray(IENArray,PrepArray) -- Prepare names for addition into 40 length fields "RTN","TMGNDF2G",23,0) ;"PrepNames(IEN,Value55,Value56,Value75,Value76,PrepArray,AllowCut) -- Get names for IEN "RTN","TMGNDF2G",24,0) ;"AskArray(IENArray,PrepArray) -- get array with possible fixes for 1 record "RTN","TMGNDF2G",25,0) ;"Write1(IEN,name55,name56,name75,namd76) --write 1 record in 22706.9 file "RTN","TMGNDF2G",26,0) ;"DispFixArray(PrepArray,MapArray,compactMode) -- Display values in PrepArray "RTN","TMGNDF2G",27,0) "RTN","TMGNDF2G",28,0) "RTN","TMGNDF2G",29,0) ;"======================================================================= "RTN","TMGNDF2G",30,0) "RTN","TMGNDF2G",31,0) Menu "RTN","TMGNDF2G",32,0) ;"Purpose: -- Ensure shortened version of drug names available. "RTN","TMGNDF2G",33,0) "RTN","TMGNDF2G",34,0) new Menu,UsrSlct "RTN","TMGNDF2G",35,0) set Menu(0)="Pick Option to Ensure All Versions of Names (2G)" "RTN","TMGNDF2G",36,0) set Menu(1)="Ensure all drug names are ready"_$char(9)_"MakeAltNames" "RTN","TMGNDF2G",37,0) set Menu(2)="Check for blank names"_$char(9)_"CheckForBlanks" "RTN","TMGNDF2G",38,0) set Menu(3)="Check for BAD names"_$char(9)_"ScanBadName" "RTN","TMGNDF2G",39,0) set Menu(4)="Ask and fix name for ONE import"_$char(9)_"FixOneName" "RTN","TMGNDF2G",40,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF2G",41,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF2G",42,0) "RTN","TMGNDF2G",43,0) M1 write # "RTN","TMGNDF2G",44,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF2G",45,0) "RTN","TMGNDF2G",46,0) if UsrSlct="MakeAltNames" do MakeAltNames goto M1 "RTN","TMGNDF2G",47,0) if UsrSlct="CheckForBlanks" do CheckForBlanks goto M1 "RTN","TMGNDF2G",48,0) if UsrSlct="FixOneName" do AskMake1 goto M1 "RTN","TMGNDF2G",49,0) if UsrSlct="ScanBadName" do ScanBadName goto M1 "RTN","TMGNDF2G",50,0) if UsrSlct="Prev" goto Menu^TMGNDF2E ;"quit can occur from there... "RTN","TMGNDF2G",51,0) if UsrSlct="Next" goto Menu^TMGNDF2H ;"quit can occur from there... "RTN","TMGNDF2G",52,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF2G",53,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF2G",54,0) goto M1 "RTN","TMGNDF2G",55,0) "RTN","TMGNDF2G",56,0) MenuDone "RTN","TMGNDF2G",57,0) quit "RTN","TMGNDF2G",58,0) "RTN","TMGNDF2G",59,0) ;"======================================================================================= "RTN","TMGNDF2G",60,0) "RTN","TMGNDF2G",61,0) "RTN","TMGNDF2G",62,0) ;"======================================================================================= "RTN","TMGNDF2G",63,0) MakeAltNames "RTN","TMGNDF2G",64,0) ;"Purpose: To scan through all entries and set up alternative names. "RTN","TMGNDF2G",65,0) ;"Input: none "RTN","TMGNDF2G",66,0) ;"Results: none. "RTN","TMGNDF2G",67,0) ;"Output: Fields .055, .056, .075, .076 will be filled "RTN","TMGNDF2G",68,0) ;"Results: none "RTN","TMGNDF2G",69,0) "RTN","TMGNDF2G",70,0) new IENArray,PrepArray "RTN","TMGNDF2G",71,0) write "Scanning existing names of imports not skipped...",! "RTN","TMGNDF2G",72,0) do GetIENArray(.IENArray) "RTN","TMGNDF2G",73,0) "RTN","TMGNDF2G",74,0) write "Preparing suggested names...",! "RTN","TMGNDF2G",75,0) do GetPrepArray(.IENArray,.PrepArray) "RTN","TMGNDF2G",76,0) "RTN","TMGNDF2G",77,0) if $data(PrepArray)=0 do goto MKSNDone "RTN","TMGNDF2G",78,0) . write "No fixes required. Great!",! "RTN","TMGNDF2G",79,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2G",80,0) "RTN","TMGNDF2G",81,0) do AskArray(.IENArray,.PrepArray) "RTN","TMGNDF2G",82,0) "RTN","TMGNDF2G",83,0) MKSNDone "RTN","TMGNDF2G",84,0) write "Goodbye.",! "RTN","TMGNDF2G",85,0) quit "RTN","TMGNDF2G",86,0) "RTN","TMGNDF2G",87,0) "RTN","TMGNDF2G",88,0) AskMake1 "RTN","TMGNDF2G",89,0) ;"Purpose: Ask user for record in 22706.9, and then fix "RTN","TMGNDF2G",90,0) "RTN","TMGNDF2G",91,0) new DIC,X,Y "RTN","TMGNDF2G",92,0) set DIC=22706.9,DIC(0)="MAEQ" "RTN","TMGNDF2G",93,0) do ^DIC write ! "RTN","TMGNDF2G",94,0) if +Y>0 do Make1Alt(+Y) "RTN","TMGNDF2G",95,0) quit "RTN","TMGNDF2G",96,0) "RTN","TMGNDF2G",97,0) "RTN","TMGNDF2G",98,0) Make1Alt(IEN,Option) "RTN","TMGNDF2G",99,0) ;"Purpose: to fix the names for just 1 record in 22706.9 "RTN","TMGNDF2G",100,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF2G",101,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF2G",102,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF2G",103,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF2G",104,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF2G",105,0) ;"Note: ignores if drug is to be skipped. "RTN","TMGNDF2G",106,0) "RTN","TMGNDF2G",107,0) new IENArray,PrepArray "RTN","TMGNDF2G",108,0) "RTN","TMGNDF2G",109,0) set IENArray(IEN,.04)=$piece($get(^TMG(22706.9,IEN,7)),"^",6) ;" .04, LONG NAME "RTN","TMGNDF2G",110,0) set IENArray(IEN,.055)=$piece($get(^TMG(22706.9,IEN,7)),"^",3) ;".055, TRADENAME - 40 "RTN","TMGNDF2G",111,0) set IENArray(IEN,.056)=$piece($get(^TMG(22706.9,IEN,8)),"^",1) ;".056, TRADENAME DOSE UNIT FORM - 40 "RTN","TMGNDF2G",112,0) set IENArray(IEN,.075)=$piece($get(^TMG(22706.9,IEN,7)),"^",4) ;".075, GENERIC NAME - 40 "RTN","TMGNDF2G",113,0) set IENArray(IEN,.076)=$piece($get(^TMG(22706.9,IEN,8)),"^",1) ;".076 GENERICNAME DOSE UNT FORM - 40 "RTN","TMGNDF2G",114,0) "RTN","TMGNDF2G",115,0) do GetPrepArray(.IENArray,.PrepArray,0) ;"0=no allow cut "RTN","TMGNDF2G",116,0) "RTN","TMGNDF2G",117,0) if $data(PrepArray)=0 do goto MKSNDone "RTN","TMGNDF2G",118,0) . write "No drug name fixes required. Great!",! "RTN","TMGNDF2G",119,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2G",120,0) "RTN","TMGNDF2G",121,0) do AskArray(.IENArray,.PrepArray) "RTN","TMGNDF2G",122,0) "RTN","TMGNDF2G",123,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF2G",124,0) . set OPTION("FIX CHAIN","IEN22706d9")=IEN "RTN","TMGNDF2G",125,0) . do Refresh1^TMGNDF3C(IEN22706d9,.Option) "RTN","TMGNDF2G",126,0) "RTN","TMGNDF2G",127,0) M1ADone "RTN","TMGNDF2G",128,0) write "Goodbye.",! "RTN","TMGNDF2G",129,0) quit "RTN","TMGNDF2G",130,0) "RTN","TMGNDF2G",131,0) "RTN","TMGNDF2G",132,0) "RTN","TMGNDF2G",133,0) GetIENArray(Array) "RTN","TMGNDF2G",134,0) ;"Purpose: Gather IENS to work on "RTN","TMGNDF2G",135,0) ;"Input: Array -- PASS BY REFERENCE Output Format: "RTN","TMGNDF2G",136,0) ;" Note: IEN is from file 22706.9 "RTN","TMGNDF2G",137,0) ;" Array(IEN,.04)=currentValue "RTN","TMGNDF2G",138,0) ;" Array(IEN,.05)=currentValue "RTN","TMGNDF2G",139,0) ;" Array(IEN,.055)=currentValue "RTN","TMGNDF2G",140,0) ;" Array(IEN,.056)=currentValue "RTN","TMGNDF2G",141,0) ;" Array(IEN,.07)=currentValue "RTN","TMGNDF2G",142,0) ;" Array(IEN,.075)=currentValue "RTN","TMGNDF2G",143,0) ;" Array(IEN,.076)=currentValue "RTN","TMGNDF2G",144,0) ;"Results: none "RTN","TMGNDF2G",145,0) "RTN","TMGNDF2G",146,0) new Itr,IEN "RTN","TMGNDF2G",147,0) new abort set abort=0 "RTN","TMGNDF2G",148,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2G",149,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2G",150,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF2G",151,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2G",152,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2G",153,0) . new s0,s7,s8 "RTN","TMGNDF2G",154,0) . set s0=$get(^TMG(22706.9,IEN,0)) "RTN","TMGNDF2G",155,0) . set s7=$get(^TMG(22706.9,IEN,7)) "RTN","TMGNDF2G",156,0) . set s8=$get(^TMG(22706.9,IEN,8)) "RTN","TMGNDF2G",157,0) . set Array(IEN,.04)=$piece(s7,"^",6) ;" .04 LONG NAME "RTN","TMGNDF2G",158,0) . set Array(IEN,.05)=$piece(s0,"^",4) ;" .05 TRADENAME "RTN","TMGNDF2G",159,0) . set Array(IEN,.055)=$piece(s7,"^",3) ;".055 TRADENAME - 40 "RTN","TMGNDF2G",160,0) . set Array(IEN,.056)=$piece(s8,"^",1) ;".056 TRADENAME DOSE UNIT FORM - 40 "RTN","TMGNDF2G",161,0) . set Array(IEN,.07)=$piece(s0,"^",6) ;" .07 GENERIC NAME "RTN","TMGNDF2G",162,0) . set Array(IEN,.075)=$piece(s7,"^",4) ;".075 GENERIC NAME - 40 "RTN","TMGNDF2G",163,0) . set Array(IEN,.076)=$piece(s8,"^",2) ;".076 GENERICNAME DOSE UNT FORM - 40 "RTN","TMGNDF2G",164,0) "RTN","TMGNDF2G",165,0) quit "RTN","TMGNDF2G",166,0) "RTN","TMGNDF2G",167,0) "RTN","TMGNDF2G",168,0) GetPrepArray(IENArray,PrepArray,AllowCut) "RTN","TMGNDF2G",169,0) ;"Purpose: Prepare names for addition into .055 (TRADENAME - 40) "RTN","TMGNDF2G",170,0) ;" and .075 (GENERIC NAME - 40) fields "RTN","TMGNDF2G",171,0) ;"Input: IENArray -- PASS BY REFERENCE Format: "RTN","TMGNDF2G",172,0) ;" Array(IEN,.04)=currentValue "RTN","TMGNDF2G",173,0) ;" Array(IEN,.055)=currentValue "RTN","TMGNDF2G",174,0) ;" Array(IEN,.075)=currentValue "RTN","TMGNDF2G",175,0) ;" PrepArray -- PASS BY REFERENCE Format: "RTN","TMGNDF2G",176,0) ;" PrepArray(IEN1,.04)=Name for .04 "RTN","TMGNDF2G",177,0) ;" PrepArray(IEN1,.055)=Name for .055 "RTN","TMGNDF2G",178,0) ;" PrepArray(IEN1,.056)=Name for .056 "RTN","TMGNDF2G",179,0) ;" PrepArray(IEN1,.075)=Name for .075 "RTN","TMGNDF2G",180,0) ;" PrepArray(IEN1,.076)=Name for .076 "RTN","TMGNDF2G",181,0) ;" AllowCut -- OPTIONAL. Default=1. If 1, then automatic shortening of names allowed "RTN","TMGNDF2G",182,0) ;"Output: PrepArray is Filled "RTN","TMGNDF2G",183,0) ;"Results: none "RTN","TMGNDF2G",184,0) "RTN","TMGNDF2G",185,0) set AllowCut=$get(AllowCut,1) "RTN","TMGNDF2G",186,0) new Itr,IEN,abort "RTN","TMGNDF2G",187,0) set abort=0 "RTN","TMGNDF2G",188,0) set IEN=$$ItrAInit^TMGITR("IENArray",.Itr) "RTN","TMGNDF2G",189,0) do PrepProgress^TMGITR(.Itr,20,1,"IEN") "RTN","TMGNDF2G",190,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!abort "RTN","TMGNDF2G",191,0) . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGNDF2G",192,0) . new Cur04Value set Cur04Value=$get(IENArray(IEN,.04)) "RTN","TMGNDF2G",193,0) . new Cur55Value set Cur55Value=$get(IENArray(IEN,.055)) "RTN","TMGNDF2G",194,0) . new Cur56Value set Cur56Value=$get(IENArray(IEN,.056)) "RTN","TMGNDF2G",195,0) . new Cur75Value set Cur75Value=$get(IENArray(IEN,.075)) "RTN","TMGNDF2G",196,0) . new Cur76Value set Cur76Value=$get(IENArray(IEN,.076)) "RTN","TMGNDF2G",197,0) . set abort=$$PrepNames(IEN,Cur04Value,Cur55Value,Cur56Value,Cur75Value,Cur76Value,.PrepArray,AllowCut) "RTN","TMGNDF2G",198,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2G",199,0) "RTN","TMGNDF2G",200,0) quit "RTN","TMGNDF2G",201,0) "RTN","TMGNDF2G",202,0) "RTN","TMGNDF2G",203,0) PrepNames(IEN,Value04,Value55,Value56,Value75,Value76,PrepArray,AllowCut) "RTN","TMGNDF2G",204,0) ;"Purpose: To get names for IEN "RTN","TMGNDF2G",205,0) ;"Input: IEN -- the ien in file 22706.9 "RTN","TMGNDF2G",206,0) ;" Value04 -- the current value for field .04 "RTN","TMGNDF2G",207,0) ;" Value55 -- the current value for field .055 "RTN","TMGNDF2G",208,0) ;" Value56 -- the current value for field .056 "RTN","TMGNDF2G",209,0) ;" Value75 -- the current value for field .075 "RTN","TMGNDF2G",210,0) ;" Value76 -- the current value for field .076 "RTN","TMGNDF2G",211,0) ;" PrepArray -- PASS BY REFERENCE. and OUT PARAMETER. "RTN","TMGNDF2G",212,0) ;" Format: "RTN","TMGNDF2G",213,0) ;" PrepArray(IEN,.04)=Name for .04 "RTN","TMGNDF2G",214,0) ;" PrepArray(IEN,.055)=Name for .055 "RTN","TMGNDF2G",215,0) ;" PrepArray(IEN,.056)=Name for .056 "RTN","TMGNDF2G",216,0) ;" PrepArray(IEN,.075)=Name for .075 "RTN","TMGNDF2G",217,0) ;" PrepArray(IEN,.076)=Name for .076 "RTN","TMGNDF2G",218,0) ;" AllowCut -- OPTIONAL. Default=1. If 1 then user not prompted to shorten names "RTN","TMGNDF2G",219,0) ;"Output: PrepArray is Filled "RTN","TMGNDF2G",220,0) ;"Results: 0=OK to Continue, 1=abort "RTN","TMGNDF2G",221,0) "RTN","TMGNDF2G",222,0) new result set result=0 "RTN","TMGNDF2G",223,0) set AllowCut=$get(AllowCut,1) "RTN","TMGNDF2G",224,0) new MaxLen set MaxLen=40 "RTN","TMGNDF2G",225,0) "RTN","TMGNDF2G",226,0) ;"==Set up .04 Name (LONG NAME) ========================== "RTN","TMGNDF2G",227,0) new New04Value set New04Value=$$MakeName(IEN,63,AllowCut,1) ;",1) Mode=Full Name "RTN","TMGNDF2G",228,0) if New04Value="^" set result=1 goto PNDone "RTN","TMGNDF2G",229,0) if $length(New04Value)>63 do "RTN","TMGNDF2G",230,0) . set New04Value=$extract(New04Value,1,63-3)_"..." "RTN","TMGNDF2G",231,0) if (New04Value["...")&(Value04'["...")&(Value04'="") set New04Value="" "RTN","TMGNDF2G",232,0) if (New04Value'=Value04)&(New04Value'="") do "RTN","TMGNDF2G",233,0) . set PrepArray(IEN,.04)=New04Value "RTN","TMGNDF2G",234,0) "RTN","TMGNDF2G",235,0) ;"==Set up .075 Name (GENERIC NAME & FORM - 40)=========== "RTN","TMGNDF2G",236,0) new New75Value set New75Value=$$MakeName(IEN,MaxLen,AllowCut,5) ;",5) Mode=Generic Name "RTN","TMGNDF2G",237,0) if New75Value="^" set result=1 goto PNDone "RTN","TMGNDF2G",238,0) if $length(New75Value)>MaxLen do "RTN","TMGNDF2G",239,0) . set New75Value=$extract(New75Value,1,MaxLen-3)_"..." "RTN","TMGNDF2G",240,0) if (New75Value["...")&(Value75'["...")&(Value75'="") set New75Value="" "RTN","TMGNDF2G",241,0) if (New75Value'=Value75)&(New75Value'="") do "RTN","TMGNDF2G",242,0) . set PrepArray(IEN,.075)=New75Value "RTN","TMGNDF2G",243,0) "RTN","TMGNDF2G",244,0) ;"==Set up .076 Name (GENERICNAME FORM DOSE UNT - 40) ==== "RTN","TMGNDF2G",245,0) new New76Value set New76Value=$$MakeName(IEN,MaxLen,AllowCut,3) ;"3 -> GenericName DrugForm Strength Units "RTN","TMGNDF2G",246,0) if New76Value="^" set result=1 goto PNDone "RTN","TMGNDF2G",247,0) if $length(New76Value)>MaxLen do "RTN","TMGNDF2G",248,0) . set New76Value=$extract(New76Value,1,MaxLen-3)_"..." "RTN","TMGNDF2G",249,0) if (New76Value["...")&(Value76'["...")&(Value76'="") set New76Value="" "RTN","TMGNDF2G",250,0) if (New76Value'=Value76)&(New76Value'="") do "RTN","TMGNDF2G",251,0) . set PrepArray(IEN,.076)=New76Value "RTN","TMGNDF2G",252,0) "RTN","TMGNDF2G",253,0) ;"==Set up .055 Name (TRADE NAME & FORM - 40) ============ "RTN","TMGNDF2G",254,0) new New55Value set New55Value=$$MakeName(IEN,MaxLen,AllowCut,4) ;",4) Mode=TradeName "RTN","TMGNDF2G",255,0) if New55Value="^" set result=1 goto PNDone "RTN","TMGNDF2G",256,0) if $length(New55Value)>MaxLen do "RTN","TMGNDF2G",257,0) . set New55Value=$extract(New55Value,1,MaxLen-3)_"..." "RTN","TMGNDF2G",258,0) if (New55Value["...")&(Value55'["...")&(Value55'="") set New55Value="" "RTN","TMGNDF2G",259,0) if New55Value=New75Value set New55Value="" ;"WAS "@" "RTN","TMGNDF2G",260,0) if (New55Value'=Value55)&(New55Value'="") do "RTN","TMGNDF2G",261,0) . ;"if (New55Value="@")&(Value55="") quit "RTN","TMGNDF2G",262,0) . set PrepArray(IEN,.055)=New55Value "RTN","TMGNDF2G",263,0) "RTN","TMGNDF2G",264,0) ;"==Set up .056 Name (TRADENAME FORM DOSE UNIT - 40) ==== "RTN","TMGNDF2G",265,0) new New56Value set New56Value=$$MakeName(IEN,MaxLen,AllowCut,6) ;"6 -> TradeName DrugForm Strength Units "RTN","TMGNDF2G",266,0) if New56Value="^" set result=1 goto PNDone "RTN","TMGNDF2G",267,0) if $length(New56Value)>MaxLen do "RTN","TMGNDF2G",268,0) . set New56Value=$extract(New56Value,1,MaxLen-3)_"..." "RTN","TMGNDF2G",269,0) if (New56Value["...")&(Value56'["...")&(Value56'="") set New56Value="" "RTN","TMGNDF2G",270,0) if New56Value=New76Value set New56Value="" ;"WAS "@" "RTN","TMGNDF2G",271,0) if (New56Value'=Value56)&(New56Value'="") do "RTN","TMGNDF2G",272,0) . ;"if (New56Value="@")&(Value56="") quit "RTN","TMGNDF2G",273,0) . set PrepArray(IEN,.056)=New56Value "RTN","TMGNDF2G",274,0) "RTN","TMGNDF2G",275,0) PNDone quit result "RTN","TMGNDF2G",276,0) "RTN","TMGNDF2G",277,0) "RTN","TMGNDF2G",278,0) MakeName(IEN,MaxLen,AllowCut,Mode) "RTN","TMGNDF2G",279,0) ;"Purpose: to make a special name from drug info "RTN","TMGNDF2G",280,0) ;"Input: IEN -- IEN in file 22706.9 "RTN","TMGNDF2G",281,0) ;" MaxLen -- OPTIONAL. default=256. The maximum length "RTN","TMGNDF2G",282,0) ;" AllowCut -- OPTIONAL If 1 then name may be cut off with ... to reach target length "RTN","TMGNDF2G",283,0) ;" If 2 then name will be shorteneded as much as possible, but the "RTN","TMGNDF2G",284,0) ;" name will NOT be cut off to reach MaxLen "RTN","TMGNDF2G",285,0) ;" default=1 "RTN","TMGNDF2G",286,0) ;" Mode -- OPTIONAL. Default=1. "RTN","TMGNDF2G",287,0) ;" //1 -> GenericName (TradeName) Strength Units "RTN","TMGNDF2G",288,0) ;" 1 -> TradeName (GenericName) Strength Units ;changed 10/30/07 "RTN","TMGNDF2G",289,0) ;" 2 -> TradeName Strength Units "RTN","TMGNDF2G",290,0) ;" 3 -> GenericName DrugForm Strength Units "RTN","TMGNDF2G",291,0) ;" 4 -> TradeName (includes Drug Form) "RTN","TMGNDF2G",292,0) ;" 5 -> GenericName DrugForm "RTN","TMGNDF2G",293,0) ;" 6 -> TradeName DrugForm Strength Units "RTN","TMGNDF2G",294,0) ;"results: special composite name, or "^" for user abort "RTN","TMGNDF2G",295,0) "RTN","TMGNDF2G",296,0) set AllowCut=$get(AllowCut,1) "RTN","TMGNDF2G",297,0) set MaxLen=$get(MaxLen,256) "RTN","TMGNDF2G",298,0) set Mode=$get(Mode,1) "RTN","TMGNDF2G",299,0) new TMGunits,TMGstrength,TMGTradeName,tempS "RTN","TMGNDF2G",300,0) new vaGeneric,vagIEN "RTN","TMGNDF2G",301,0) set vagIEN=$piece($get(^TMG(22706.9,IEN,1)),"^",3) ;"VA GENERIC <-Pntr [P50.6'] "RTN","TMGNDF2G",302,0) set vaGeneric=$$GET1^DIQ(50.6,vagIEN,.01) "RTN","TMGNDF2G",303,0) if vaGeneric="" set vaGeneric=$piece($get(^TMG(22706.9,IEN,0)),"^",6) "RTN","TMGNDF2G",304,0) set TMGTradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;".05 TRADENAME [F] ;e.g. DILTIAZEM HCL SR CAPSULES "RTN","TMGNDF2G",305,0) if $extract(TMGTradeName,1)="." set TMGTradeName="0"_TMGTradeName ;".9% saline (rejected) --> 0.9% (acceptible) "RTN","TMGNDF2G",306,0) if TMGTradeName["..." set TMGTradeName=$$Substitute^TMGSTUTL(TMGTradeName,"...","") "RTN","TMGNDF2G",307,0) "RTN","TMGNDF2G",308,0) set TMGstrength=$piece($get(^TMG(22706.9,IEN,0)),"^",2) ;"1 STRENGTH [F] ;e.g. 240 "RTN","TMGNDF2G",309,0) "RTN","TMGNDF2G",310,0) set TMGunits=$piece($get(^TMG(22706.9,IEN,0)),"^",3) ;"2 UNIT [F] ;e.g. MG "RTN","TMGNDF2G",311,0) "RTN","TMGNDF2G",312,0) new vadfIEN set vadfIEN=+$piece($get(^TMG(22706.9,IEN,0)),"^",7) ;"3.5 VA DOSAGE FORM "RTN","TMGNDF2G",313,0) new vaDoseForm "RTN","TMGNDF2G",314,0) if vadfIEN>0 set vaDoseForm=$piece($get(^PS(50.606,vadfIEN,0)),"^",1) ;".01 NAME "RTN","TMGNDF2G",315,0) else set vaDoseForm="" "RTN","TMGNDF2G",316,0) "RTN","TMGNDF2G",317,0) new hideGeneric set hideGeneric=0 "RTN","TMGNDF2G",318,0) new tempS "RTN","TMGNDF2G",319,0) if Mode=1 do ;"1 -> TradeName (GenericName) Strength Units "RTN","TMGNDF2G",320,0) . if $extract(TMGTradeName,1,$length(vaGenericName))=vaGenericName do "RTN","TMGNDF2G",321,0) . . set tempS=TMGTradeName "RTN","TMGNDF2G",322,0) . . if TMGstrength'="" set tempS=tempS_" "_TMGstrength "RTN","TMGNDF2G",323,0) . . if TMGunits'="" set tempS=tempS_" "_TMGunits "RTN","TMGNDF2G",324,0) . . set hideGeneric=1 "RTN","TMGNDF2G",325,0) . else do "RTN","TMGNDF2G",326,0) . . ;"set tempS=vaGeneric_" ("_TMGTradeName_")" "RTN","TMGNDF2G",327,0) . . set tempS=TMGTradeName_" ("_vaGeneric_")" "RTN","TMGNDF2G",328,0) . . if TMGstrength'="" set tempS=tempS_" "_TMGstrength "RTN","TMGNDF2G",329,0) . . if TMGunits'="" set tempS=tempS_" "_TMGunits "RTN","TMGNDF2G",330,0) . if $length(tempS)>MaxLen do "RTN","TMGNDF2G",331,0) . . set tempS=$$ShortNetName^TMGSHORT(vaGeneric,TMGTradeName,TMGstrength,TMGunits,MaxLen,.AllowCut) "RTN","TMGNDF2G",332,0) if Mode=2 do ;"2 -> TradeName Strength Units "RTN","TMGNDF2G",333,0) . set tempS=TMGTradeName "RTN","TMGNDF2G",334,0) . if TMGstrength'="" set tempS=tempS_" "_TMGstrength "RTN","TMGNDF2G",335,0) . if TMGunits'="" set tempS=tempS_" "_TMGunits "RTN","TMGNDF2G",336,0) . if $length(tempS)>MaxLen do "RTN","TMGNDF2G",337,0) . . set tempS=$$ShortNetName^TMGSHORT(,TMGTradeName,TMGstrength,TMGunits,MaxLen,.AllowCut) "RTN","TMGNDF2G",338,0) if Mode=3 do ;"3 -> GenericName DrugForm Strength Units "RTN","TMGNDF2G",339,0) . set tempS=vaGeneric "RTN","TMGNDF2G",340,0) . if vaDoseForm'="" set tempS=tempS_" "_vaDoseForm "RTN","TMGNDF2G",341,0) . if TMGstrength'="" set tempS=tempS_" "_TMGstrength "RTN","TMGNDF2G",342,0) . if TMGunits'="" set tempS=tempS_" "_TMGunits "RTN","TMGNDF2G",343,0) . if $length(tempS)>MaxLen do "RTN","TMGNDF2G",344,0) . . set tempS=$$ShortNetName^TMGSHORT(vaGeneric,,TMGstrength,TMGunits,MaxLen,.AllowCut) "RTN","TMGNDF2G",345,0) if Mode=4 do ;"4 -> TradeName (includes Drug Form) "RTN","TMGNDF2G",346,0) . set tempS=TMGTradeName "RTN","TMGNDF2G",347,0) . if $length(tempS)>MaxLen do "RTN","TMGNDF2G",348,0) . . set tempS=$$ShortNetName^TMGSHORT(,TMGTradeName,,,MaxLen,.AllowCut) "RTN","TMGNDF2G",349,0) if Mode=5 do ;"5 -> GenericName DrugForm "RTN","TMGNDF2G",350,0) . set tempS=vaGeneric "RTN","TMGNDF2G",351,0) . if vaDoseForm'="" set tempS=tempS_" "_vaDoseForm "RTN","TMGNDF2G",352,0) . if $length(tempS)>MaxLen do "RTN","TMGNDF2G",353,0) . . set tempS=$$ShortNetName^TMGSHORT(tempS,,,,MaxLen,.AllowCut) "RTN","TMGNDF2G",354,0) if Mode=6 do ;" 6 -> TradeName DrugForm Strength Units "RTN","TMGNDF2G",355,0) . set tempS=TMGTradeName ;"Note: TradeName includes Drug Form "RTN","TMGNDF2G",356,0) . if TMGstrength'="" set tempS=tempS_" "_TMGstrength "RTN","TMGNDF2G",357,0) . if TMGunits'="" set tempS=tempS_" "_TMGunits "RTN","TMGNDF2G",358,0) . if $length(tempS)>MaxLen do "RTN","TMGNDF2G",359,0) . . set tempS=$$ShortNetName^TMGSHORT(,TMGTradeName,TMGstrength,TMGunits,MaxLen,.AllowCut) "RTN","TMGNDF2G",360,0) "RTN","TMGNDF2G",361,0) set tempS=$$Trim^TMGSTUTL(tempS) "RTN","TMGNDF2G",362,0) if $extract(tempS,1,1)="(" do ;"Input transform doesn't allow first chart to be '(' "RTN","TMGNDF2G",363,0) . ;"NOTE: I should write better code to change only the LAST ) to "", i.e. not cut out ALL ()'s "RTN","TMGNDF2G",364,0) . set tempS=$translate(tempS,"(","") "RTN","TMGNDF2G",365,0) . set tempS=$translate(tempS,")","") "RTN","TMGNDF2G",366,0) if $extract(tempS,1,1)="/" do ;"Input transform doesn't allow first chart to be '/' "RTN","TMGNDF2G",367,0) . set tempS=$extract(tempS,2,999) "RTN","TMGNDF2G",368,0) "RTN","TMGNDF2G",369,0) set tempS=$translate(tempS,";",":") ;"some input transforms don't allow ';' character "RTN","TMGNDF2G",370,0) quit tempS "RTN","TMGNDF2G",371,0) "RTN","TMGNDF2G",372,0) "RTN","TMGNDF2G",373,0) AskArray(IENArray,PrepArray) "RTN","TMGNDF2G",374,0) ;"Purpose: to get array with possible fixes for one record in 22706.9 file "RTN","TMGNDF2G",375,0) ;"Input: Array -- PASS BY REFERENCE (Used if rescanning needed) "RTN","TMGNDF2G",376,0) ;" Array(IEN)="" "RTN","TMGNDF2G",377,0) ;" Array(IEN)="" "RTN","TMGNDF2G",378,0) ;" FixArray -- PASS BY REFERENCE. Format: "RTN","TMGNDF2G",379,0) ;" FixArray(IEN,.04)=Name for .04 "RTN","TMGNDF2G",380,0) ;" FixArray(IEN,.055)=Name for .055 "RTN","TMGNDF2G",381,0) ;" FixArray(IEN,.056)=Name for .056 "RTN","TMGNDF2G",382,0) ;" FixArray(IEN,.075)=Name for .075 "RTN","TMGNDF2G",383,0) ;" FixArray(IEN,.076)=Name for .076 "RTN","TMGNDF2G",384,0) ;"Results: None "RTN","TMGNDF2G",385,0) ;"Output: records in 50.68 will be changed, field .055,.056,.075, and .076 will be checked and fixed "RTN","TMGNDF2G",386,0) "RTN","TMGNDF2G",387,0) new input,list "RTN","TMGNDF2G",388,0) new cmd,nums "RTN","TMGNDF2G",389,0) new compactMode set compactMode=1 "RTN","TMGNDF2G",390,0) new MapArray "RTN","TMGNDF2G",391,0) AA1 "RTN","TMGNDF2G",392,0) do DispFixArray(.PrepArray,.MapArray,compactMode) "RTN","TMGNDF2G",393,0) write !,"E to manually edit entries; D to delete (skip) entries",! "RTN","TMGNDF2G",394,0) write "R to rescan; A To accept entries",! "RTN","TMGNDF2G",395,0) write "C turn Compact display ",$select((compactMode=1):"OFF",1:"ON"),! "RTN","TMGNDF2G",396,0) write "ALL to accept all entries WITHOUT any '...'s",!! "RTN","TMGNDF2G",397,0) read "Enter Option: ^// ",input:$get(DTIME,3600),! "RTN","TMGNDF2G",398,0) if input="" set input="^" "RTN","TMGNDF2G",399,0) set input=$$UP^XLFSTR(input) "RTN","TMGNDF2G",400,0) if input="^" goto AADone "RTN","TMGNDF2G",401,0) set nums="" "RTN","TMGNDF2G",402,0) set cmd=input "RTN","TMGNDF2G",403,0) if cmd="E" do goto AA1 "RTN","TMGNDF2G",404,0) . if nums="" do "RTN","TMGNDF2G",405,0) . . write "Enter number(s) to edit (#,#-#, etc; ^ to quit): " "RTN","TMGNDF2G",406,0) . . read nums:$get(DTIME,3600),! "RTN","TMGNDF2G",407,0) . if '$$MkMultList^TMGMISC(nums,.list) quit "RTN","TMGNDF2G",408,0) . new num set num="" "RTN","TMGNDF2G",409,0) . for set num=$order(list(num)) quit:(num="") do "RTN","TMGNDF2G",410,0) . . new IEN,name04,name55,name75,result "RTN","TMGNDF2G",411,0) . . set IEN=$get(MapArray(num)) if IEN="" quit "RTN","TMGNDF2G",412,0) . . set name04=$get(PrepArray(IEN,.04)) "RTN","TMGNDF2G",413,0) . . set name55=$get(PrepArray(IEN,.055)) "RTN","TMGNDF2G",414,0) . . set name56=$get(PrepArray(IEN,.056)) "RTN","TMGNDF2G",415,0) . . set name75=$get(PrepArray(IEN,.075)) "RTN","TMGNDF2G",416,0) . . set name76=$get(PrepArray(IEN,.076)) "RTN","TMGNDF2G",417,0) AA2 . . set result=$$PrepNames(IEN,name04,name55,name56,name75,name76,.PrepArray,0) "RTN","TMGNDF2G",418,0) . . if result=1 quit "RTN","TMGNDF2G",419,0) . . new new04Name set new04Name=$get(PrepArray(IEN,.004)) "RTN","TMGNDF2G",420,0) . . new new55Name set new55Name=$get(PrepArray(IEN,.055)) "RTN","TMGNDF2G",421,0) . . new new56Name set new56Name=$get(PrepArray(IEN,.056)) "RTN","TMGNDF2G",422,0) . . new new75Name set new75Name=$get(PrepArray(IEN,.075)) "RTN","TMGNDF2G",423,0) . . new new76Name set new76Name=$get(PrepArray(IEN,.076)) "RTN","TMGNDF2G",424,0) . . if new04Name=name04 set new04Name="" "RTN","TMGNDF2G",425,0) . . if new55Name=name55 set new55Name="" "RTN","TMGNDF2G",426,0) . . if new56Name=name56 set new56Name="" "RTN","TMGNDF2G",427,0) . . if new75Name=name75 set new75Name="" "RTN","TMGNDF2G",428,0) . . if new76Name=name76 set new76Name="" "RTN","TMGNDF2G",429,0) . . set result=$$Write1(IEN,new04Name,new55Name,new56Name,new75Name,new76Name) "RTN","TMGNDF2G",430,0) . . if result=0 kill PrepArray(IEN) "RTN","TMGNDF2G",431,0) if cmd="C" do goto AA1 "RTN","TMGNDF2G",432,0) . set compactMode='compactMode "RTN","TMGNDF2G",433,0) if cmd="ALL" do GOTO AA1 "RTN","TMGNDF2G",434,0) . new Itr,IEN,abort "RTN","TMGNDF2G",435,0) . set abort=0 "RTN","TMGNDF2G",436,0) . set IEN=$$ItrAInit^TMGITR("PrepArray",.Itr) "RTN","TMGNDF2G",437,0) . write "Storing accepted names for future use...",! "RTN","TMGNDF2G",438,0) . do PrepProgress^TMGITR(.Itr,20,1,"IEN") "RTN","TMGNDF2G",439,0) . if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!abort "RTN","TMGNDF2G",440,0) . . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGNDF2G",441,0) . . new name04,name55,name56,name75,name76,result "RTN","TMGNDF2G",442,0) . . set name04=$get(PrepArray(IEN,.04)) "RTN","TMGNDF2G",443,0) . . set name55=$get(PrepArray(IEN,.055)) "RTN","TMGNDF2G",444,0) . . set name56=$get(PrepArray(IEN,.056)) "RTN","TMGNDF2G",445,0) . . set name75=$get(PrepArray(IEN,.075)) "RTN","TMGNDF2G",446,0) . . set name76=$get(PrepArray(IEN,.076)) "RTN","TMGNDF2G",447,0) . . if name04["..." set name04="" "RTN","TMGNDF2G",448,0) . . if name55["..." set name55="" "RTN","TMGNDF2G",449,0) . . if name56["..." set name56="" "RTN","TMGNDF2G",450,0) . . if name75["..." set name75="" "RTN","TMGNDF2G",451,0) . . if name76["..." set name76="" "RTN","TMGNDF2G",452,0) . . if (name04="")&(name55="")&(name56="")&(name75="")&(name76="") quit ;"avoid delete of names with ... "RTN","TMGNDF2G",453,0) . . set result=$$Write1(IEN,name04,name55,name56,name75,name76) "RTN","TMGNDF2G",454,0) . . if result=0 kill IENArray(IEN),PrepArray(IEN) "RTN","TMGNDF2G",455,0) . do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2G",456,0) ;"if (cmd="A")!(+cmd=cmd) do goto AA1 "RTN","TMGNDF2G",457,0) if (cmd="A") do goto AA1 "RTN","TMGNDF2G",458,0) . if nums="" do "RTN","TMGNDF2G",459,0) . . write "Enter number(s) to accept (#,#-#, etc; ^ to quit): " "RTN","TMGNDF2G",460,0) . . read nums:$get(DTIME,3600),! "RTN","TMGNDF2G",461,0) . if '$$MkMultList^TMGMISC(nums,.list) quit "RTN","TMGNDF2G",462,0) . new num set num="" "RTN","TMGNDF2G",463,0) . for set num=$order(list(num)) quit:(num="") do "RTN","TMGNDF2G",464,0) . . new IEN set IEN=$get(MapArray(num)) if IEN="" quit "RTN","TMGNDF2G",465,0) . . new name04,name55,name75,result "RTN","TMGNDF2G",466,0) . . set name04=$get(PrepArray(IEN,.04)) "RTN","TMGNDF2G",467,0) . . set name55=$get(PrepArray(IEN,.055)) "RTN","TMGNDF2G",468,0) . . set name56=$get(PrepArray(IEN,.056)) "RTN","TMGNDF2G",469,0) . . set name75=$get(PrepArray(IEN,.075)) "RTN","TMGNDF2G",470,0) . . set name76=$get(PrepArray(IEN,.076)) "RTN","TMGNDF2G",471,0) . . new result set result=$$Write1(IEN,name04,name55,name56,name75,name76) "RTN","TMGNDF2G",472,0) . . if result=0 kill IENArray(IEN),PrepArray(IEN) "RTN","TMGNDF2G",473,0) else if $extract(cmd,1)="D" do goto AA1 "RTN","TMGNDF2G",474,0) . new Perm,% set Perm=0,%=2 "RTN","TMGNDF2G",475,0) . write "Will remove from display list.",! "RTN","TMGNDF2G",476,0) . write "Also perminantly mark drug so be SKIPPED" "RTN","TMGNDF2G",477,0) . do YN^DICN write ! "RTN","TMGNDF2G",478,0) . if %=-1 quit "RTN","TMGNDF2G",479,0) . if %=1 set Perm=1 "RTN","TMGNDF2G",480,0) . set nums=$extract(cmd,2,999) "RTN","TMGNDF2G",481,0) . if nums="" do "RTN","TMGNDF2G",482,0) . . write "Enter number(s) to delete (#,#-#, etc; ^ to quit): " "RTN","TMGNDF2G",483,0) . . read nums:$get(DTIME,3600),! "RTN","TMGNDF2G",484,0) . if '$$MkMultList^TMGMISC(nums,.list) quit "RTN","TMGNDF2G",485,0) . new num set num="" "RTN","TMGNDF2G",486,0) . for set num=$order(list(num)) quit:(num="") do "RTN","TMGNDF2G",487,0) . . new IEN set IEN=+$get(MapArray(num)) if IEN="" quit "RTN","TMGNDF2G",488,0) . . kill PrepArray(IEN),IENArray(IEN) "RTN","TMGNDF2G",489,0) . . if (Perm=1)&(IEN>0) set $piece(^TMG(22706.9,IEN,1),"^",4)=1 ;"1=SKIP "RTN","TMGNDF2G",490,0) else if cmd="R" do goto AA1 "RTN","TMGNDF2G",491,0) . kill PrepArray "RTN","TMGNDF2G",492,0) . do GetPrepArray(.IENArray,.PrepArray) "RTN","TMGNDF2G",493,0) "RTN","TMGNDF2G",494,0) goto AA1 "RTN","TMGNDF2G",495,0) AADone "RTN","TMGNDF2G",496,0) quit "RTN","TMGNDF2G",497,0) "RTN","TMGNDF2G",498,0) "RTN","TMGNDF2G",499,0) Write1(IEN,name04,name55,name56,name75,name76) "RTN","TMGNDF2G",500,0) ;"Purpose to write 1 record in 22706.9 file "RTN","TMGNDF2G",501,0) ;"Input: IEN -- the ien in file 22706.9 "RTN","TMGNDF2G",502,0) ;" name04 -- OPTIONAL name for .04 field "RTN","TMGNDF2G",503,0) ;" name55 -- OPTIONAL name for .055 field "RTN","TMGNDF2G",504,0) ;" name56 -- OPTIONAL name for .056 field "RTN","TMGNDF2G",505,0) ;" name75 -- OPTIONAL name for .075 field "RTN","TMGNDF2G",506,0) ;" name76 -- OPTIONAL name for .076 field "RTN","TMGNDF2G",507,0) ;"Output: records in 22706.9 will be changed, field .055 and .075 will be checked and fixed "RTN","TMGNDF2G",508,0) ;"Results: 0 = OK. -1=error "RTN","TMGNDF2G",509,0) "RTN","TMGNDF2G",510,0) new result set result=0 ;"default to success "RTN","TMGNDF2G",511,0) new TMGFDA,TMGIEN,TMGMSG,IENS "RTN","TMGNDF2G",512,0) set IENS=IEN_"," "RTN","TMGNDF2G",513,0) "RTN","TMGNDF2G",514,0) if $get(name04)'="" set TMGFDA(22706.9,IENS,.04)=name04 "RTN","TMGNDF2G",515,0) if $get(name55)'="" set TMGFDA(22706.9,IENS,.055)=name55 "RTN","TMGNDF2G",516,0) if $get(name56)'="" set TMGFDA(22706.9,IENS,.056)=name56 "RTN","TMGNDF2G",517,0) if $get(name75)'="" set TMGFDA(22706.9,IENS,.075)=name75 "RTN","TMGNDF2G",518,0) if $get(name76)'="" set TMGFDA(22706.9,IENS,.076)=name76 "RTN","TMGNDF2G",519,0) "RTN","TMGNDF2G",520,0) if $data(TMGFDA)>0 do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF2G",521,0) if $data(TMGMSG("DIERR")) do goto W1NDone "RTN","TMGNDF2G",522,0) . set result=-1 "RTN","TMGNDF2G",523,0) . if $get(Quiet)=1 quit "RTN","TMGNDF2G",524,0) . write !,"Error writing names to file 22706.9, record# ",IEN,! "RTN","TMGNDF2G",525,0) . new PriorErrorFound "RTN","TMGNDF2G",526,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2G",527,0) "RTN","TMGNDF2G",528,0) set result=0 "RTN","TMGNDF2G",529,0) "RTN","TMGNDF2G",530,0) W1NDone "RTN","TMGNDF2G",531,0) quit result "RTN","TMGNDF2G",532,0) "RTN","TMGNDF2G",533,0) "RTN","TMGNDF2G",534,0) "RTN","TMGNDF2G",535,0) DispFixArray(PrepArray,MapArray,compactMode) "RTN","TMGNDF2G",536,0) ;"Purpose: to Display values in PrepArray "RTN","TMGNDF2G",537,0) ;"Input: PrepArray array will be filled as follows: "RTN","TMGNDF2G",538,0) ;" PrepArray(IEN1,.04)=Name for .04 "RTN","TMGNDF2G",539,0) ;" PrepArray(IEN1,.055)=Name for .055 "RTN","TMGNDF2G",540,0) ;" PrepArray(IEN1,.056)=Name for .056 "RTN","TMGNDF2G",541,0) ;" PrepArray(IEN1,.075)=Name for .075 "RTN","TMGNDF2G",542,0) ;" PrepArray(IEN1,.076)=Name for .076 "RTN","TMGNDF2G",543,0) ;" MapArray PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF2G",544,0) ;" MapPrep(1)=IEN "RTN","TMGNDF2G",545,0) ;" MapPrep(2)=IEN "RTN","TMGNDF2G",546,0) ;" MapPrep(3)=IEN "RTN","TMGNDF2G",547,0) ;" MapPrep(4)=IEN "RTN","TMGNDF2G",548,0) ;" compactMode -- OPTIONAL. Default=1 "RTN","TMGNDF2G",549,0) ;" if =1, then only end of list shown "RTN","TMGNDF2G",550,0) ;"Output: will dump array "RTN","TMGNDF2G",551,0) ;"Result: none "RTN","TMGNDF2G",552,0) "RTN","TMGNDF2G",553,0) write ! "RTN","TMGNDF2G",554,0) write "--------------------",! "RTN","TMGNDF2G",555,0) kill MapArray "RTN","TMGNDF2G",556,0) new IEN,Num "RTN","TMGNDF2G",557,0) set Num=1 "RTN","TMGNDF2G",558,0) set compactMode=$get(compactMode,1) "RTN","TMGNDF2G",559,0) new someShown set someShown=0 "RTN","TMGNDF2G",560,0) if compactMode=0 do "RTN","TMGNDF2G",561,0) set IEN=$order(PrepArray("")) "RTN","TMGNDF2G",562,0) else do "RTN","TMGNDF2G",563,0) . new i "RTN","TMGNDF2G",564,0) . set IEN="" "RTN","TMGNDF2G",565,0) . for i=1:1:10 do quit:(IEN="") "RTN","TMGNDF2G",566,0) . . set IEN=$order(PrepArray(IEN),-1) "RTN","TMGNDF2G",567,0) . if IEN="" set IEN=$order(PrepArray("")) "RTN","TMGNDF2G",568,0) if +IEN>0 for do quit:(IEN="") "RTN","TMGNDF2G",569,0) . new s,s2,name04,name55,name56,name75,name76 "RTN","TMGNDF2G",570,0) . set MapArray(Num)=IEN "RTN","TMGNDF2G",571,0) . set someShown=1 "RTN","TMGNDF2G",572,0) . set s=Num_". " "RTN","TMGNDF2G",573,0) . set s=s_"["_IEN_"] " ;"temporary "RTN","TMGNDF2G",574,0) . set s2=$extract(" ",1,$length(s)) "RTN","TMGNDF2G",575,0) . set name04=$get(PrepArray(IEN,.04)) "RTN","TMGNDF2G",576,0) . set name55=$get(PrepArray(IEN,.055)) "RTN","TMGNDF2G",577,0) . set name56=$get(PrepArray(IEN,.056)) "RTN","TMGNDF2G",578,0) . set name75=$get(PrepArray(IEN,.075)) "RTN","TMGNDF2G",579,0) . set name76=$get(PrepArray(IEN,.076)) "RTN","TMGNDF2G",580,0) . write s "RTN","TMGNDF2G",581,0) . if name04'="" do "RTN","TMGNDF2G",582,0) . . write name04,! "RTN","TMGNDF2G",583,0) . . if name55'="" write s2 "RTN","TMGNDF2G",584,0) . if name55'="" do "RTN","TMGNDF2G",585,0) . . write name55,! "RTN","TMGNDF2G",586,0) . . if name75'="" write s2 "RTN","TMGNDF2G",587,0) . if name75'="" write name75,! "RTN","TMGNDF2G",588,0) . if name56'="" write name56,! "RTN","TMGNDF2G",589,0) . if name76'="" write name76,! "RTN","TMGNDF2G",590,0) . set IEN=$order(PrepArray(IEN)) "RTN","TMGNDF2G",591,0) . set Num=Num+1 "RTN","TMGNDF2G",592,0) if someShown=0 write " (List is empty)",! "RTN","TMGNDF2G",593,0) write "--------------------",! "RTN","TMGNDF2G",594,0) "RTN","TMGNDF2G",595,0) quit "RTN","TMGNDF2G",596,0) "RTN","TMGNDF2G",597,0) "RTN","TMGNDF2G",598,0) CheckForBlanks "RTN","TMGNDF2G",599,0) new IENArray,BlankArray "RTN","TMGNDF2G",600,0) new PrepArray "RTN","TMGNDF2G",601,0) write "Scanning existing names of imports not skipped...",! "RTN","TMGNDF2G",602,0) do GetIENArray(.IENArray) "RTN","TMGNDF2G",603,0) "RTN","TMGNDF2G",604,0) write "Checking for blank names...",! "RTN","TMGNDF2G",605,0) do Check4Blanks(.IENArray,.BlankArray) "RTN","TMGNDF2G",606,0) "RTN","TMGNDF2G",607,0) new fixNeeded set fixNeeded=0 "RTN","TMGNDF2G",608,0) "RTN","TMGNDF2G",609,0) if $data(BlankArray)'=0 do "RTN","TMGNDF2G",610,0) . write "Preparing suggested names...",! "RTN","TMGNDF2G",611,0) . do GetPrepArray(.BlankArray,.PrepArray) "RTN","TMGNDF2G",612,0) . if $data(PrepArray)'=0 do "RTN","TMGNDF2G",613,0) . . set fixNeeded=1 "RTN","TMGNDF2G",614,0) . . do AskArray(.BlankArray,.PrepArray) "RTN","TMGNDF2G",615,0) "RTN","TMGNDF2G",616,0) if fixNeeded=0 do "RTN","TMGNDF2G",617,0) . write "No fixes required. Great!",! "RTN","TMGNDF2G",618,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2G",619,0) "RTN","TMGNDF2G",620,0) quit "RTN","TMGNDF2G",621,0) "RTN","TMGNDF2G",622,0) "RTN","TMGNDF2G",623,0) Check4Blanks(IENArray,BlankArray) "RTN","TMGNDF2G",624,0) ;"Purpose: Check if any of the fields are blank and allow fixing "RTN","TMGNDF2G",625,0) ;"Input: IENArray -- PASS BY REFERENCE (Used if rescanning needed) "RTN","TMGNDF2G",626,0) ;" IENArray(IEN,.04)=currentValue "RTN","TMGNDF2G",627,0) ;" IENArray(IEN,.055)=currentValue "RTN","TMGNDF2G",628,0) ;" IENArray(IEN,.056)=currentValue "RTN","TMGNDF2G",629,0) ;" IENArray(IEN,.075)=currentValue "RTN","TMGNDF2G",630,0) ;" IENArray(IEN,.076)=currentValue "RTN","TMGNDF2G",631,0) ;" BlankArray -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF2G",632,0) ;" BlankArray(IEN,.04)=Name for .04 "RTN","TMGNDF2G",633,0) ;" BlankArray(IEN,.055)=Name for .055 "RTN","TMGNDF2G",634,0) ;" BlankArray(IEN,.056)=Name for .056 "RTN","TMGNDF2G",635,0) ;" BlankArray(IEN,.075)=Name for .075 "RTN","TMGNDF2G",636,0) ;" BlankArray(IEN,.076)=Name for .076 "RTN","TMGNDF2G",637,0) ;"Results: none "RTN","TMGNDF2G",638,0) "RTN","TMGNDF2G",639,0) new Itr,IEN,abort "RTN","TMGNDF2G",640,0) set abort=0 "RTN","TMGNDF2G",641,0) set IEN=$$ItrAInit^TMGITR("IENArray",.Itr) "RTN","TMGNDF2G",642,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2G",643,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!abort "RTN","TMGNDF2G",644,0) . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGNDF2G",645,0) . new Cur04Value set Cur04Value=$get(IENArray(IEN,.04)) "RTN","TMGNDF2G",646,0) . new Cur55Value set Cur55Value=$get(IENArray(IEN,.055)) "RTN","TMGNDF2G",647,0) . new Cur56Value set Cur56Value=$get(IENArray(IEN,.056)) "RTN","TMGNDF2G",648,0) . new Cur75Value set Cur75Value=$get(IENArray(IEN,.075)) "RTN","TMGNDF2G",649,0) . new Cur76Value set Cur76Value=$get(IENArray(IEN,.076)) "RTN","TMGNDF2G",650,0) . if (Cur04Value="")!(Cur55Value="")!(Cur56Value="")!(Cur75Value="")!(Cur76Value="") do "RTN","TMGNDF2G",651,0) . . write IEN,?8," .04 (LONG NAME) = ",Cur04Value,! "RTN","TMGNDF2G",652,0) . . write ?8,".055 (TRADENAME) = ",Cur55Value,! "RTN","TMGNDF2G",653,0) . . write ?8,".056 (TRADENAME FORM DOSE UNIT)= ",Cur56Value,! "RTN","TMGNDF2G",654,0) . . write ?8,".075 (GENERIC NAME & FORM) = ",Cur75Value,! "RTN","TMGNDF2G",655,0) . . write ?8,".076 (GENERICNAME FORM DOSE UNT) = ",Cur76Value,! "RTN","TMGNDF2G",656,0) . . merge BlankArray(IEN)=IENArray(IEN) "RTN","TMGNDF2G",657,0) "RTN","TMGNDF2G",658,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2G",659,0) "RTN","TMGNDF2G",660,0) quit "RTN","TMGNDF2G",661,0) "RTN","TMGNDF2G",662,0) ;"========================================== "RTN","TMGNDF2G",663,0) "RTN","TMGNDF2G",664,0) ScanBadName "RTN","TMGNDF2G",665,0) ;"Purpose: scan for bad names, and debug the problem. "RTN","TMGNDF2G",666,0) ;"Input: none "RTN","TMGNDF2G",667,0) ;"Results: none "RTN","TMGNDF2G",668,0) "RTN","TMGNDF2G",669,0) new IENArray,PrepArray "RTN","TMGNDF2G",670,0) write "Scanning existing names of imports not skipped...",! "RTN","TMGNDF2G",671,0) do GetIENArray(.IENArray) "RTN","TMGNDF2G",672,0) "RTN","TMGNDF2G",673,0) new Menu,UsrSlct "RTN","TMGNDF2G",674,0) set Menu(0)="Pick Which Name to Examine (2G)" "RTN","TMGNDF2G",675,0) set Menu(1)=" .04 LONG NAME"_$char(9)_"LongName" "RTN","TMGNDF2G",676,0) set Menu(2)=" .05 TRADENAME"_$char(9)_"TradeName" "RTN","TMGNDF2G",677,0) set Menu(3)=".055 TRADE NAME & FORM - 40"_$char(9)_"TradeF" "RTN","TMGNDF2G",678,0) set Menu(4)=".056 TRADENAME FORM DOSE UNIT - 40"_$char(9)_"TradeFDU" "RTN","TMGNDF2G",679,0) set Menu(5)=" .07 GENERIC NAME"_$char(9)_"Generic" "RTN","TMGNDF2G",680,0) set Menu(6)=".075 GENERIC NAME & FORM - 40"_$char(9)_"GenericF" "RTN","TMGNDF2G",681,0) set Menu(7)=".076 GENERICNAME FORM DOSE UNT - 40"_$char(9)_"GenrcFDU" "RTN","TMGNDF2G",682,0) "RTN","TMGNDF2G",683,0) SBN1 write # "RTN","TMGNDF2G",684,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF2G",685,0) "RTN","TMGNDF2G",686,0) if UsrSlct="LongName" do Scan(.IENArray,.04,"LONG NAME") goto SBN1 "RTN","TMGNDF2G",687,0) if UsrSlct="TradeName" do Scan(.IENArray,.055,"TRADENAME") goto SBN1 "RTN","TMGNDF2G",688,0) if UsrSlct="TradeF" do Scan(.IENArray,.055,"TRADE NAME & FORM - 40") goto SBN1 "RTN","TMGNDF2G",689,0) if UsrSlct="TradeFDU" do Scan(.IENArray,.056,"TRADENAME FORM DOSE UNIT - 40") goto SBN1 "RTN","TMGNDF2G",690,0) if UsrSlct="Generic" do Scan(.IENArray,.07,"GENERIC NAME") goto SBN1 "RTN","TMGNDF2G",691,0) if UsrSlct="GenericF" do Scan(.IENArray,.075,"GENERIC NAME & FORM - 40") goto SBN1 "RTN","TMGNDF2G",692,0) if UsrSlct="GenrcFDU" do Scan(.IENArray,.076,"GENERICNAME FORM DOSE UNT - 40") goto SBN1 "RTN","TMGNDF2G",693,0) if UsrSlct="^" goto SBN2 "RTN","TMGNDF2G",694,0) goto SBN1 "RTN","TMGNDF2G",695,0) "RTN","TMGNDF2G",696,0) SBN2 quit "RTN","TMGNDF2G",697,0) "RTN","TMGNDF2G",698,0) "RTN","TMGNDF2G",699,0) Scan(IENArray,FieldNum,FldName) "RTN","TMGNDF2G",700,0) ;"Purpose: to do scan "RTN","TMGNDF2G",701,0) ;"Input: -- IENArray -- PASS BY REFERENCE. Format: "RTN","TMGNDF2G",702,0) ;" Note: IEN is from file 22706.9 "RTN","TMGNDF2G",703,0) ;" Array(IEN,.04)=currentValue "RTN","TMGNDF2G",704,0) ;" Array(IEN,.05)=currentValue "RTN","TMGNDF2G",705,0) ;" Array(IEN,.055)=currentValue "RTN","TMGNDF2G",706,0) ;" Array(IEN,.056)=currentValue "RTN","TMGNDF2G",707,0) ;" Array(IEN,.07)=currentValue "RTN","TMGNDF2G",708,0) ;" Array(IEN,.075)=currentValue "RTN","TMGNDF2G",709,0) ;" Array(IEN,.076)=currentValue "RTN","TMGNDF2G",710,0) "RTN","TMGNDF2G",711,0) new SrchRec "RTN","TMGNDF2G",712,0) new Itr,IEN,abort "RTN","TMGNDF2G",713,0) set abort=0 "RTN","TMGNDF2G",714,0) set IEN=$$ItrAInit^TMGITR("IENArray",.Itr) "RTN","TMGNDF2G",715,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2G",716,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!abort "RTN","TMGNDF2G",717,0) . if $$UserAborted^TMGUSRIF() set abort=1 quit "RTN","TMGNDF2G",718,0) . new s set s=$get(IENArray(IEN,FieldNum)) "RTN","TMGNDF2G",719,0) . if (s="")!(s="") quit "RTN","TMGNDF2G",720,0) . set SrchRec(s_" (#"_IEN_")",IEN_"^22706.9")="" "RTN","TMGNDF2G",721,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2G",722,0) "RTN","TMGNDF2G",723,0) new Results "RTN","TMGNDF2G",724,0) write "Passing off to selector...",! "RTN","TMGNDF2G",725,0) do Slctor2^TMGUSRIF("SrchRec","Results","Pick Example(s) of Bad Drugs Names. [ESC][ESC] when done.") "RTN","TMGNDF2G",726,0) "RTN","TMGNDF2G",727,0) do HandleChain^TMGNDF4G(.Results) ;"Show forward array "RTN","TMGNDF2G",728,0) "RTN","TMGNDF2G",729,0) write "Done.",! "RTN","TMGNDF2G",730,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2G",731,0) "RTN","TMGNDF2G",732,0) quit "RTN","TMGNDF2H") 0^47^B7403 "RTN","TMGNDF2H",1,0) TMGNDF2H ;TMG/kst/FDA Import: Fill VA Product entries ;03/25/06 "RTN","TMGNDF2H",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF2H",3,0) "RTN","TMGNDF2H",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF2H",5,0) ;" Addition of records from TMG FDA IMPORT COMPILED into VA PRODUCT file. "RTN","TMGNDF2H",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF2H",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF2H",8,0) ;"11-21-2006 "RTN","TMGNDF2H",9,0) "RTN","TMGNDF2H",10,0) ;"======================================================================= "RTN","TMGNDF2H",11,0) ;" API -- Public Functions. "RTN","TMGNDF2H",12,0) ;"======================================================================= "RTN","TMGNDF2H",13,0) ;"Menu "RTN","TMGNDF2H",14,0) "RTN","TMGNDF2H",15,0) ;"======================================================================= "RTN","TMGNDF2H",16,0) ;"Link2VAP -- fill file 22706.9, field 5.5 in with link 50.68 with SAME NDC "RTN","TMGNDF2H",17,0) ;"Batch2VAP -- Batch add drugs to VA PRODUCT file (50.68) and NDC/UPC "RTN","TMGNDF2H",18,0) "RTN","TMGNDF2H",19,0) ;"======================================================================= "RTN","TMGNDF2H",20,0) ;" Private Functions. "RTN","TMGNDF2H",21,0) ;"======================================================================= "RTN","TMGNDF2H",22,0) ;"Add2VAProd(IEN,Quiet) "RTN","TMGNDF2H",23,0) ;"EnsureNDC(IEN) Make record in NDC/UPN file (50.67). "RTN","TMGNDF2H",24,0) ;"EnsureUnits(UnitS) -- ensure that the UnitS is valid in file 50.607 "RTN","TMGNDF2H",25,0) ;"Unlock50dot607 "RTN","TMGNDF2H",26,0) ;"Lock50dot607 "RTN","TMGNDF2H",27,0) "RTN","TMGNDF2H",28,0) "RTN","TMGNDF2H",29,0) ;"======================================================================= "RTN","TMGNDF2H",30,0) ;"======================================================================= "RTN","TMGNDF2H",31,0) "RTN","TMGNDF2H",32,0) Menu "RTN","TMGNDF2H",33,0) new Menu,UsrSlct "RTN","TMGNDF2H",34,0) set Menu(0)="Pick Option to Add imports to VA PRODUCT & NDC/UPN file (2H)" "RTN","TMGNDF2H",35,0) set Menu(1)="Link imports to VA PRODUCT via NDC-- *DO THIS FIRST*"_$char(9)_"Link2VAP" "RTN","TMGNDF2H",36,0) set Menu(2)="ADD unlinked imports to VA PRODUCT file."_$char(9)_"Batch2VAP" "RTN","TMGNDF2H",37,0) set Menu(3)="Synchronize VA PRODUCT file with import data."_$char(9)_"Sync2VAP" "RTN","TMGNDF2H",38,0) ;"set Menu(3)="Fix Names with '...'s (SHOULD run AFTER Batch Add)"_$char(9)_"FixNames" "RTN","TMGNDF2H",39,0) ;"set Menu(4)="Check/Fix ALL Names (May be run AFTER Batch Add)"_$char(9)_"FixNames2" "RTN","TMGNDF2H",40,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF2H",41,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF2H",42,0) "RTN","TMGNDF2H",43,0) M1 write # "RTN","TMGNDF2H",44,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF2H",45,0) "RTN","TMGNDF2H",46,0) if UsrSlct="Link2VAP" do Link2VAP goto M1 "RTN","TMGNDF2H",47,0) if UsrSlct="Batch2VAP" do Batch2VAP goto M1 "RTN","TMGNDF2H",48,0) if UsrSlct="Sync2VAP" do Sync2VAP goto M1 "RTN","TMGNDF2H",49,0) ;"if UsrSlct="FixNames" do FixNames(0) goto M1 "RTN","TMGNDF2H",50,0) ;"if UsrSlct="FixNames2" do FixNames(1) goto M1 "RTN","TMGNDF2H",51,0) if UsrSlct="Prev" goto Menu^TMGNDF2G ;"quit can occur from there... "RTN","TMGNDF2H",52,0) if UsrSlct="Next" goto Menu^TMGNDF3A ;"quit can occur from there... "RTN","TMGNDF2H",53,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF2H",54,0) goto M1 "RTN","TMGNDF2H",55,0) "RTN","TMGNDF2H",56,0) MenuDone "RTN","TMGNDF2H",57,0) quit "RTN","TMGNDF2H",58,0) "RTN","TMGNDF2H",59,0) "RTN","TMGNDF2H",60,0) ;"========================================================================== "RTN","TMGNDF2H",61,0) "RTN","TMGNDF2H",62,0) "RTN","TMGNDF2H",63,0) Batch2VAP "RTN","TMGNDF2H",64,0) ;"Purpose: To scan through all records in TMG FDA IMPORT COMPILED, and create an array of "RTN","TMGNDF2H",65,0) ;" possible entries for addition to VA PRODUCT, also creating an entry in "RTN","TMGNDF2H",66,0) ;" the NDC/UPC file. "RTN","TMGNDF2H",67,0) ;"Input: none "RTN","TMGNDF2H",68,0) ;"Output: database will be filled with data (records added to VA PRODUCT file) "RTN","TMGNDF2H",69,0) ;"Results: none "RTN","TMGNDF2H",70,0) "RTN","TMGNDF2H",71,0) ;"Note: After making this function, I changed the function MakeName such that it is better "RTN","TMGNDF2H",72,0) ;" at shortening long names to fit into the field limits. "RTN","TMGNDF2H",73,0) ;" So I wrote the code FixNames to go back and correct the names for better fits. "RTN","TMGNDF2H",74,0) ;" The problem is that it takes user interaction to do this well (asking for abbreviations etc) "RTN","TMGNDF2H",75,0) ;" And this is best done in a batch manner (i.e. not asking each drug, one at a time). "RTN","TMGNDF2H",76,0) ;" So this function was modified such that it shortens the names non-interactively "RTN","TMGNDF2H",77,0) ;" (i.e. AllowCut=1), and then FixNames can be run to review all of the abbreviations "RTN","TMGNDF2H",78,0) ;" are appropriate "RTN","TMGNDF2H",79,0) "RTN","TMGNDF2H",80,0) "RTN","TMGNDF2H",81,0) new AddList "RTN","TMGNDF2H",82,0) do GetAddList(.AddList) "RTN","TMGNDF2H",83,0) new count set count=$$ListCt^TMGMISC("AddList") "RTN","TMGNDF2H",84,0) if count=0 do goto B2VDone "RTN","TMGNDF2H",85,0) . write "No entries need to be be added to VA PRODUCT file.",! "RTN","TMGNDF2H",86,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2H",87,0) write count," entries will now be added to VA PRODUCT file.",! "RTN","TMGNDF2H",88,0) new % set %=1 "RTN","TMGNDF2H",89,0) write "Continue" do YN^DICN write ! "RTN","TMGNDF2H",90,0) if %=1 do DoAdd(.AddList) "RTN","TMGNDF2H",91,0) B2VDone "RTN","TMGNDF2H",92,0) quit "RTN","TMGNDF2H",93,0) "RTN","TMGNDF2H",94,0) "RTN","TMGNDF2H",95,0) Check1(IEN) "RTN","TMGNDF2H",96,0) ;"Purpose: to check one record in TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF2H",97,0) ;"NOTE: this just checks if one exists, NOT if correct link is present. "RTN","TMGNDF2H",98,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF2H",99,0) "RTN","TMGNDF2H",100,0) new AddList,vapIEN,syncList "RTN","TMGNDF2H",101,0) "RTN","TMGNDF2H",102,0) set vapIEN=+$piece($get(^TMG(22706.9,IEN,6)),"^",2) "RTN","TMGNDF2H",103,0) set AddList(IEN)="" "RTN","TMGNDF2H",104,0) if vapIEN=0 set vapIEN=$$Add2VAProd(IEN) "RTN","TMGNDF2H",105,0) set syncList(IEN)=vapIEN "RTN","TMGNDF2H",106,0) do DoSync(.syncList) "RTN","TMGNDF2H",107,0) "RTN","TMGNDF2H",108,0) C1Done quit "RTN","TMGNDF2H",109,0) "RTN","TMGNDF2H",110,0) "RTN","TMGNDF2H",111,0) Sync2VAP "RTN","TMGNDF2H",112,0) ;"Purpose: To scan through all records in TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF2H",113,0) ;" and synchronize data with records in VA PRODUCT. "RTN","TMGNDF2H",114,0) ;"Input: none "RTN","TMGNDF2H",115,0) ;"Output: database will be modified with data from 22706.9 "RTN","TMGNDF2H",116,0) ;"Results: none "RTN","TMGNDF2H",117,0) "RTN","TMGNDF2H",118,0) new SyncList "RTN","TMGNDF2H",119,0) do GetSyncList(.SyncList) "RTN","TMGNDF2H",120,0) new count set count=$$ListCt^TMGMISC("SyncList") "RTN","TMGNDF2H",121,0) if count=0 do goto S2VDone "RTN","TMGNDF2H",122,0) . write "No entries available to update VA PRODUCT file with.",! "RTN","TMGNDF2H",123,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2H",124,0) write count," entries will now be used to update VA PRODUCT file.",! "RTN","TMGNDF2H",125,0) new % set %=1 "RTN","TMGNDF2H",126,0) write "Continue" do YN^DICN write ! "RTN","TMGNDF2H",127,0) if %=1 do DoSync(.SyncList) "RTN","TMGNDF2H",128,0) S2VDone "RTN","TMGNDF2H",129,0) quit "RTN","TMGNDF2H",130,0) "RTN","TMGNDF2H",131,0) "RTN","TMGNDF2H",132,0) GetAddList(AddList) "RTN","TMGNDF2H",133,0) ;"Purpose: to create a list of IEN's that need addition "RTN","TMGNDF2H",134,0) ;"Input: AddList-- PASS BY REFERENCE. An OUT PARAMETER. "RTN","TMGNDF2H",135,0) ;"Output: AddList is filled: Format: "RTN","TMGNDF2H",136,0) ;" AddList(IEN)="" ;IEN is from file 22706.9 "RTN","TMGNDF2H",137,0) ;" AddList(IEN)="" "RTN","TMGNDF2H",138,0) ;"Results: none. "RTN","TMGNDF2H",139,0) "RTN","TMGNDF2H",140,0) write "Scanning for imports to be added into VA PRODUCT file...",! "RTN","TMGNDF2H",141,0) new Itr,IEN,success "RTN","TMGNDF2H",142,0) new abort set abort=0 "RTN","TMGNDF2H",143,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2H",144,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2H",145,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF2H",146,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2H",147,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2H",148,0) . if $piece($get(^TMG(22706.9,IEN,6)),"^",2)>0 quit ;"IEN of linked entry in 50.68 "RTN","TMGNDF2H",149,0) . set AddList(IEN)="" "RTN","TMGNDF2H",150,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2H",151,0) "RTN","TMGNDF2H",152,0) quit "RTN","TMGNDF2H",153,0) "RTN","TMGNDF2H",154,0) "RTN","TMGNDF2H",155,0) GetSyncList(SyncList) "RTN","TMGNDF2H",156,0) ;"Purpose: to create a list of IEN's can be used for syncing data "RTN","TMGNDF2H",157,0) ;"Input: SyncList-- PASS BY REFERENCE. An OUT PARAMETER. "RTN","TMGNDF2H",158,0) ;"Output: SyncList is filled: Format: "RTN","TMGNDF2H",159,0) ;" SyncList(IEN22706d9)=vapIEN "RTN","TMGNDF2H",160,0) ;"Results: none. "RTN","TMGNDF2H",161,0) "RTN","TMGNDF2H",162,0) write "Scanning for imports to be synchronized with VA PRODUCT file...",! "RTN","TMGNDF2H",163,0) new Itr,IEN,success "RTN","TMGNDF2H",164,0) new abort set abort=0 "RTN","TMGNDF2H",165,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2H",166,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2H",167,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF2H",168,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2H",169,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF2H",170,0) . new vapIEN set vapIEN=$piece($get(^TMG(22706.9,IEN,6)),"^",2) ;"IEN of linked entry in 50.68 "RTN","TMGNDF2H",171,0) . if vapIEN=0 quit "RTN","TMGNDF2H",172,0) . set SyncList(IEN)=vapIEN "RTN","TMGNDF2H",173,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2H",174,0) "RTN","TMGNDF2H",175,0) quit "RTN","TMGNDF2H",176,0) "RTN","TMGNDF2H",177,0) "RTN","TMGNDF2H",178,0) DoAdd(AddList) "RTN","TMGNDF2H",179,0) ;"Purpose: To process the AddList, doing actual adds. "RTN","TMGNDF2H",180,0) ;"Input: AddList-- PASS BY REFERENCE. Format: "RTN","TMGNDF2H",181,0) ;" AddList(IEN)="" ;IEN is from file 22706.9 "RTN","TMGNDF2H",182,0) ;" AddList(IEN)="" "RTN","TMGNDF2H",183,0) ;"Results: none. "RTN","TMGNDF2H",184,0) "RTN","TMGNDF2H",185,0) do Unlock50dot607 "RTN","TMGNDF2H",186,0) do Unlock50^TMGNDF3C "RTN","TMGNDF2H",187,0) "RTN","TMGNDF2H",188,0) write "Adding records into VA PRODUCT file from import information...",! "RTN","TMGNDF2H",189,0) new count set count=0 "RTN","TMGNDF2H",190,0) new Itr,IEN,success,addedIEN "RTN","TMGNDF2H",191,0) new abort set abort=0 "RTN","TMGNDF2H",192,0) set IEN=$$ItrAInit^TMGITR("AddList",.Itr) "RTN","TMGNDF2H",193,0) do PrepProgress^TMGITR(.Itr,1,1,"IEN") "RTN","TMGNDF2H",194,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!abort "RTN","TMGNDF2H",195,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2H",196,0) L1 . set addedIEN=$$Add2VAProd(IEN,0,1) ;"0=not quiet, 1=quiet,Allow Cut automatically "RTN","TMGNDF2H",197,0) . if addedIEN>0 do "RTN","TMGNDF2H",198,0) . . set count=count+1 "RTN","TMGNDF2H",199,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF2H",200,0) . . set TMGFDA(22706.9,IEN_",",5.5)=addedIEN "RTN","TMGNDF2H",201,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2H",202,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2H",203,0) . else do "RTN","TMGNDF2H",204,0) . . write !,"Unable to add record# ",IEN," from file 22706.9 to file 50.68.",! "RTN","TMGNDF2H",205,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2H",206,0) "RTN","TMGNDF2H",207,0) do Lock50dot607 "RTN","TMGNDF2H",208,0) do Lock50^TMGNDF3C "RTN","TMGNDF2H",209,0) "RTN","TMGNDF2H",210,0) write count," imports added to VA PRODUCT (file 50.68 )",! "RTN","TMGNDF2H",211,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2H",212,0) "RTN","TMGNDF2H",213,0) quit "RTN","TMGNDF2H",214,0) "RTN","TMGNDF2H",215,0) "RTN","TMGNDF2H",216,0) DoSync(SyncList) "RTN","TMGNDF2H",217,0) ;"Purpose: To process the SyncList, doing actual synchronization. "RTN","TMGNDF2H",218,0) ;"Input: SyncList-- PASS BY REFERENCE. Format: "RTN","TMGNDF2H",219,0) ;" SyncList(IEN)=vapIEN ;IEN is from file 22706.9; vapIEN=IEN 50.68 "RTN","TMGNDF2H",220,0) ;"Results: none. "RTN","TMGNDF2H",221,0) "RTN","TMGNDF2H",222,0) do Unlock50dot607 "RTN","TMGNDF2H",223,0) do Unlock50^TMGNDF3C "RTN","TMGNDF2H",224,0) "RTN","TMGNDF2H",225,0) write "Synchronizing VA PRODUCT file from import information...",! "RTN","TMGNDF2H",226,0) new count set count=0 "RTN","TMGNDF2H",227,0) new Itr,IEN,success "RTN","TMGNDF2H",228,0) new abort set abort=0 "RTN","TMGNDF2H",229,0) set IEN=$$ItrAInit^TMGITR("SyncList",.Itr) "RTN","TMGNDF2H",230,0) do PrepProgress^TMGITR(.Itr,1,1,"IEN") "RTN","TMGNDF2H",231,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!abort "RTN","TMGNDF2H",232,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2H",233,0) . new vapIEN set vapIEN=+$get(SyncList(IEN)) "RTN","TMGNDF2H",234,0) . if +vapIEN=0 quit "RTN","TMGNDF2H",235,0) . set success=$$Sync1Rec(IEN,vapIEN) "RTN","TMGNDF2H",236,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2H",237,0) "RTN","TMGNDF2H",238,0) do Lock50dot607 "RTN","TMGNDF2H",239,0) do Lock50^TMGNDF3C "RTN","TMGNDF2H",240,0) "RTN","TMGNDF2H",241,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2H",242,0) "RTN","TMGNDF2H",243,0) quit "RTN","TMGNDF2H",244,0) "RTN","TMGNDF2H",245,0) "RTN","TMGNDF2H",246,0) Add2VAProd(IEN,Quiet,AllowCut) "RTN","TMGNDF2H",247,0) ;"Purpose: to take drug information from Array and use this to create a new entry "RTN","TMGNDF2H",248,0) ;" in file #50.68 (VA PRODUCT)--and any supporting files needed. "RTN","TMGNDF2H",249,0) ;"Input: IEN -- IEN from file 22706.9 (TMG FDA IMPORT COMPILED) to add "RTN","TMGNDF2H",250,0) ;" Quiet -- OPTIONAL -- default = 1 (quiet), if 1 no output generated to console. "RTN","TMGNDF2H",251,0) ;" AllowCut -- OPTIONAL -- default = 0 (no cut). "RTN","TMGNDF2H",252,0) ;" If value=1 then names will be shortened to needed length without "RTN","TMGNDF2H",253,0) ;" asking user for abbreviations etc. "RTN","TMGNDF2H",254,0) ;"Output: A new record will be created in 50.68, and any supporint files (such as "RTN","TMGNDF2H",255,0) ;" drug manufacturer, package type etc if needed) "RTN","TMGNDF2H",256,0) ;"Result: the IEN in 50.68 of added record, 0 if error "RTN","TMGNDF2H",257,0) "RTN","TMGNDF2H",258,0) "RTN","TMGNDF2H",259,0) new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF2H",260,0) set IENS="+1," "RTN","TMGNDF2H",261,0) do SetupFDA(IEN,IENS,.TMGFDA) "RTN","TMGNDF2H",262,0) "RTN","TMGNDF2H",263,0) ALabel "RTN","TMGNDF2H",264,0) do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2H",265,0) if $data(TMGMSG("DIERR")) do goto A2VPDone "RTN","TMGNDF2H",266,0) . set result=0 "RTN","TMGNDF2H",267,0) . if Quiet=1 quit "RTN","TMGNDF2H",268,0) . write !,"Error adding new record to 50.68",! "RTN","TMGNDF2H",269,0) . new PriorErrorFound "RTN","TMGNDF2H",270,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2H",271,0) "RTN","TMGNDF2H",272,0) ;"Check that record was added, then then add subfile entries: active ingredients... "RTN","TMGNDF2H",273,0) new AddedIEN set AddedIEN=$get(TMGIEN(1)) ;"also used to create NDC/UPC record; "RTN","TMGNDF2H",274,0) if +AddedIEN=0 do goto A2VPDone "RTN","TMGNDF2H",275,0) . set result=0 if Quiet=1 quit "RTN","TMGNDF2H",276,0) . write !,"Can't find record number of added record to 50.68",! "RTN","TMGNDF2H",277,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF2H",278,0) "RTN","TMGNDF2H",279,0) set result=$$EnsureIngredients(IEN,AddedIEN) if result=0 goto A2VPDone "RTN","TMGNDF2H",280,0) "RTN","TMGNDF2H",281,0) BLabel ;"set result=$$Add2NDC(IEN,.DrugInfo) "RTN","TMGNDF2H",282,0) set result=$$EnsureNDC(IEN) if result=0 goto A2VPDone "RTN","TMGNDF2H",283,0) "RTN","TMGNDF2H",284,0) A2VPDone "RTN","TMGNDF2H",285,0) ;"1=OK to continue, 0 if error "RTN","TMGNDF2H",286,0) if result=1 set result=+$get(AddedIEN) "RTN","TMGNDF2H",287,0) quit result ;"changed to return IEN in 50.68 "RTN","TMGNDF2H",288,0) "RTN","TMGNDF2H",289,0) "RTN","TMGNDF2H",290,0) Sync1Rec(IEN,vapIEN) "RTN","TMGNDF2H",291,0) ;"Purpose: to take drug information from Array and use this to create a new entry "RTN","TMGNDF2H",292,0) ;" in file #50.68 (VA PRODUCT)--and any supporting files needed. "RTN","TMGNDF2H",293,0) ;"Input: IEN -- IEN from file 22706.9 (TMG FDA IMPORT COMPILED) to add "RTN","TMGNDF2H",294,0) ;" vapIEN -- IEN in 50.68 that is the target of the synchronization. "RTN","TMGNDF2H",295,0) ;"Output: data in VA PRODUCT will be updated as needed to match the info in "RTN","TMGNDF2H",296,0) ;" file 22706.9 "RTN","TMGNDF2H",297,0) ;"Result: 1 if OK, 0 if error "RTN","TMGNDF2H",298,0) "RTN","TMGNDF2H",299,0) new result set result=0 "RTN","TMGNDF2H",300,0) new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF2H",301,0) set IENS=vapIEN_"," "RTN","TMGNDF2H",302,0) do SetupFDA(IEN,IENS,.TMGFDA) "RTN","TMGNDF2H",303,0) new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF2H",304,0) "RTN","TMGNDF2H",305,0) if $data(TMGFDA) do "RTN","TMGNDF2H",306,0) . do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF2H",307,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2H",308,0) "RTN","TMGNDF2H",309,0) set result=$$EnsureIngredients(IEN,vapIEN) "RTN","TMGNDF2H",310,0) if result=0 goto S2VPDone "RTN","TMGNDF2H",311,0) set result=$$EnsureNDC(IEN) if result=0 goto S2VPDone "RTN","TMGNDF2H",312,0) S2VPDone "RTN","TMGNDF2H",313,0) quit result ;"changed to return IEN in 50.68 "RTN","TMGNDF2H",314,0) "RTN","TMGNDF2H",315,0) "RTN","TMGNDF2H",316,0) SetupFDA(IEN,IENS,TMGFDA,vapIEN) "RTN","TMGNDF2H",317,0) ;"Purpose: to set up FDA for data in a#50.68 (VA PRODUCT) entry "RTN","TMGNDF2H",318,0) ;"Input: IEN -- IEN from file 22706.9 (TMG FDA IMPORT COMPILED) to add "RTN","TMGNDF2H",319,0) ;" IENS -- a standard FM IENS for FDA to use "RTN","TMGNDF2H",320,0) ;" TMGFDA -- PASS BY REFEERNCE. A standard FM FDA "RTN","TMGNDF2H",321,0) ;" vapIEN -- OPTIONAL. If provided, then the FDA wil be trimmed to contain "RTN","TMGNDF2H",322,0) ;" only those fields that need to be changed "RTN","TMGNDF2H",323,0) ;"Output: TMGFDA is filled "RTN","TMGNDF2H",324,0) ;"Result: none "RTN","TMGNDF2H",325,0) "RTN","TMGNDF2H",326,0) ;"NOTE: this function will create an FDA in EXTERNAL form "RTN","TMGNDF2H",327,0) "RTN","TMGNDF2H",328,0) ;"VA PRODUCT FILE RECORD STRUCTURE "RTN","TMGNDF2H",329,0) ;"----------------------------------- "RTN","TMGNDF2H",330,0) ;" .01 NAME [RFa] "RTN","TMGNDF2H",331,0) ;" e.g. NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF2H",332,0) ;" .05 VA GENERIC NAME <-Pntr [P50.6'a] "RTN","TMGNDF2H",333,0) ;" e.g. VA GENERIC NAME: DILTIAZEM "RTN","TMGNDF2H",334,0) ;" 1 DOSAGE FORM <-Pntr [P50.606'a] "RTN","TMGNDF2H",335,0) ;" e.g. DOSAGE FORM: CAP,SA "RTN","TMGNDF2H",336,0) ;" 2 STRENGTH [Fa] "RTN","TMGNDF2H",337,0) ;" e.g. STRENGTH: 240 "RTN","TMGNDF2H",338,0) ;" 3 UNITS <-Pntr [P50.607'a] "RTN","TMGNDF2H",339,0) ;" e.g. UNITS: MG "RTN","TMGNDF2H",340,0) ;" 4 NATIONAL FORMULARY NAME [Fa] "RTN","TMGNDF2H",341,0) ;" e.g. NATIONAL FORMULARY NAME: DILTIAZEM CAP,SA "RTN","TMGNDF2H",342,0) ;" 5 VA PRINT NAME [Fa] "RTN","TMGNDF2H",343,0) ;" e.g. VA PRINT NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF2H",344,0) ;" 6 VA PRODUCT IDENTIFIER [Fa] <--- will use to store "0^TMG ADDED" "RTN","TMGNDF2H",345,0) ;" e.g. VA PRODUCT IDENTIFIER: D0230 "RTN","TMGNDF2H",346,0) ;" 8 VA DISPENSE UNIT <-Pntr [P50.64a] "RTN","TMGNDF2H",347,0) ;" e.g. VA DISPENSE UNIT: CAPNSE UNIT <-Pntr [P50.64a] <-- plan to leave blank, for CMOP use "RTN","TMGNDF2H",348,0) ;" 14 ACTIVE INGREDIENTS W:^ D:^ <-Mult [50.6814P] "RTN","TMGNDF2H",349,0) ;" .01 -ACTIVE INGREDIENTS <-Pntr [P50.416'Xa] "RTN","TMGNDF2H",350,0) ;" e.g. ACTIVE INGREDIENTS: DILTIAZEM HYDROCHLORIDE "RTN","TMGNDF2H",351,0) ;" 1 -STRENGTH [Fa] "RTN","TMGNDF2H",352,0) ;" e.g. STRENGTH: 240 "RTN","TMGNDF2H",353,0) ;" 2 -UNITS <-Pntr [P50.607'a] "RTN","TMGNDF2H",354,0) ;" e.g. UNITS: MG "RTN","TMGNDF2H",355,0) ;" 15 PRIMARY VA DRUG CLASS <-Pntr [P50.605'a] "RTN","TMGNDF2H",356,0) ;" e.g. PRIMARY VA DRUG CLASS: CV200 "RTN","TMGNDF2H",357,0) ;" 16 SECONDARY VA DRUG CLASS W:^ D:^ <-Mult [50.6816P] "RTN","TMGNDF2H",358,0) ;" .01 -SECONDARY VA DRUG CLASS <-Pntr [MP50.605'aX] "RTN","TMGNDF2H",359,0) ;" 17 NATIONAL FORMULARY INDICATOR [Sa] "RTN","TMGNDF2H",360,0) ;" e.g. NATIONAL FORMULARY INDICATOR: NO "RTN","TMGNDF2H",361,0) ;" 18 NATIONAL FORMULARY RESTRICTIONW:^ D:^ <-WP [50.6818] "RTN","TMGNDF2H",362,0) ;" .01 -NATIONAL FORMULARY RESTRICTION [W] "RTN","TMGNDF2H",363,0) ;" 19 CS FEDERAL SCHEDULE [Sa] "RTN","TMGNDF2H",364,0) ;" 20 SINGLE/MULTI SOURCE PRODUCT [Sa] "RTN","TMGNDF2H",365,0) ;" 21 INACTIVATION DATE [Da] "RTN","TMGNDF2H",366,0) ;" 23 EXCLUDE DRG-DRG INTERACTION CK [S] "RTN","TMGNDF2H",367,0) ;" 25 MAX SINGLE DOSE [NJ13,4a] "RTN","TMGNDF2H",368,0) ;" 26 MIN SINGLE DOSE [NJ13,4a] "RTN","TMGNDF2H",369,0) ;" 27 MAX DAILY DOSE [NJ13,4a] "RTN","TMGNDF2H",370,0) ;" 28 MIN DAILY DOSE [NJ13,4a] "RTN","TMGNDF2H",371,0) ;" 29 MAX CUMULATIVE DOSE [NJ13,4a] "RTN","TMGNDF2H",372,0) ;" 30 DSS NUMBER [NJ6,0a] "RTN","TMGNDF2H",373,0) "RTN","TMGNDF2H",374,0) ;"--------------------------------------------------------- "RTN","TMGNDF2H",375,0) "RTN","TMGNDF2H",376,0) "RTN","TMGNDF2H",377,0) ;"File: TMG FDA IMPORT COMPILED Branch: 1 "RTN","TMGNDF2H",378,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGNDF2H",379,0) ;"=============================================================================== "RTN","TMGNDF2H",380,0) ;" 1 0;1 .01 TMG FDA LISTING ENTRY <-Pntr [RP22706.5'] "RTN","TMGNDF2H",381,0) ;" e.g. TMG FDA LISTING ENTRY: 154001 "RTN","TMGNDF2H",382,0) ;" 2 0;4 .05 TRADENAME [F] "RTN","TMGNDF2H",383,0) ;" e.g. TRADENAME: DILTIAZEM HCL SR CAPSULES "RTN","TMGNDF2H",384,0) ;" 3 0;6 .07 GENERIC NAME [F] "RTN","TMGNDF2H",385,0) ;" 4 1;3 .08 VA GENERIC <-Pntr [P50.6'] "RTN","TMGNDF2H",386,0) ;" 5 1;5 .09 VA DRUG CLASS <-Pntr [P50.605'] "RTN","TMGNDF2H",387,0) ;" 6 0;2 1 STRENGTH [F] "RTN","TMGNDF2H",388,0) ;" e.g. STRENGTH: 240 "RTN","TMGNDF2H",389,0) ;" 7 0;3 2 UNIT [F] "RTN","TMGNDF2H",390,0) ;" e.g. UNIT: MG "RTN","TMGNDF2H",391,0) ;" 8 0;5 3 ROUTE [F] "RTN","TMGNDF2H",392,0) ;" e.g. ??? "RTN","TMGNDF2H",393,0) ;" 9 0;7 3.5 DOSAGE FORM <-Pntr [P50.606] "RTN","TMGNDF2H",394,0) ;" 9 1;1 4 NDC [F] "RTN","TMGNDF2H",395,0) ;" e.g. NDC: 053978-3062-*3 "RTN","TMGNDF2H",396,0) ;" 10 1;2 5 NDC 12-DIGIT [F] "RTN","TMGNDF2H",397,0) ;" e.g. NDC: 0539783062*3 "RTN","TMGNDF2H",398,0) ;" 11 1;4 6 SKIP THIS RECORD [S] "RTN","TMGNDF2H",399,0) ;" 12 1;7 7 DONE ADDING TO 50.68 [S] "RTN","TMGNDF2H",400,0) ;" 2;0 14 VA PRODUCT MATCHES <-Mult [22706.914P] "RTN","TMGNDF2H",401,0) ;" 13 -0;1 .01 -ONE MATCH <-Pntr [P50.68'] "RTN","TMGNDF2H",402,0) ;" e.g. ONE MATCH: DILTIAZEM (DILACOR XR) 240MG SA CAP "RTN","TMGNDF2H",403,0) ;" e.g. ONE MATCH: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF2H",404,0) ;" e.g. ONE MATCH: DILTIAZEM (TIAZAC) 240MG SA CAP "RTN","TMGNDF2H",405,0) ;" e.g. ONE MATCH: DILTIAZEM (WATSON-XR) 240MG SA CAP "RTN","TMGNDF2H",406,0) ;" e.g. ONE MATCH: DILTIAZEM (TIAZAC) 240MG SA CAP,UD "RTN","TMGNDF2H",407,0) ;" e.g. ONE MATCH: DILTIAZEM (CARDIZEM CD) 240MG SA CAP,UD "RTN","TMGNDF2H",408,0) ;" 3;0 15 VA PRODUCT POSS MATCH <-Mult [22706.915P] "RTN","TMGNDF2H",409,0) ;" 14 -0;1 .01 -POSS MATCH <-Pntr [P50.68'] "RTN","TMGNDF2H",410,0) ;" 4;0 16 INGREDIENTS <-Mult [22706.916] "RTN","TMGNDF2H",411,0) ;" 15 -0;1 .01 -NUMBER [NJ3,0] "RTN","TMGNDF2H",412,0) ;" e.g. NUMBER: 1 "RTN","TMGNDF2H",413,0) ;" 17 -0;3 2 -INGREDIENT <-Pntr [P50.416'] "RTN","TMGNDF2H",414,0) ;" e.g. INGREDIENT: DILTIAZEM HYDROCHLORIDE "RTN","TMGNDF2H",415,0) ;" 18 -0;4 3 -STRENGTH [F] "RTN","TMGNDF2H",416,0) ;" e.g. STRENGTH: 240 "RTN","TMGNDF2H",417,0) ;" 19 -0;6 5 -UNIT <-Pntr [P50.607'] "RTN","TMGNDF2H",418,0) ;" e.g. ??? "RTN","TMGNDF2H",419,0) ;" "RTN","TMGNDF2H",420,0) ;"=============================================================================== "RTN","TMGNDF2H",421,0) ;"<> 'n',I=FldDD DA=Data F=Find G=Goto N=Node P=Pointer VGL=VGL ?=Help "RTN","TMGNDF2H",422,0) ;" "RTN","TMGNDF2H",423,0) "RTN","TMGNDF2H",424,0) ;"new FDAitemNum "RTN","TMGNDF2H",425,0) ;"set FDAitemNum=$$GET1^DIQ(22706.9,IEN,.01) "RTN","TMGNDF2H",426,0) ;"new DrugInfo "RTN","TMGNDF2H",427,0) ;"set result=$$GetDrugInfo^TMGNDF1A(FDAitemNum,.DrugInfo,"",1) "RTN","TMGNDF2H",428,0) ;"if result=0 do goto A2VPDone "RTN","TMGNDF2H",429,0) ;". if Quiet=1 quit "RTN","TMGNDF2H",430,0) ;". write !,"Unable to Get Drug Info for record: ",FDAitemNum,! "RTN","TMGNDF2H",431,0) "RTN","TMGNDF2H",432,0) ;".01 NAME [RFa] "RTN","TMGNDF2H",433,0) ;" e.g. NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF2H",434,0) set tempS=$piece($get(^TMG(22706.9,IEN,7)),"^",6) ;"7;6= field .04 LONG NAME "RTN","TMGNDF2H",435,0) set TMGFDA(50.68,IENS,.01)=tempS ;".01 NAME [RFa] ;e.g. NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF2H",436,0) ;"set DrugInfo("ADDED","GENERIC+BRAND")=tempS "RTN","TMGNDF2H",437,0) "RTN","TMGNDF2H",438,0) ;".05 VA GENERIC NAME <-Pntr [P50.6'a] "RTN","TMGNDF2H",439,0) ;" e.g. VA GENERIC NAME: DILTIAZEM "RTN","TMGNDF2H",440,0) set TMGFDA(50.68,IENS,.05)=$$GET1^DIQ(22706.9,IEN,.08) "RTN","TMGNDF2H",441,0) "RTN","TMGNDF2H",442,0) ;"1 DOSAGE FORM <-Pntr [P50.606'a] "RTN","TMGNDF2H",443,0) ;" e.g. DOSAGE FORM: CAP,SA "RTN","TMGNDF2H",444,0) set TMGFDA(50.68,IENS,1)=$$GET1^DIQ(22706.9,IEN,3.5) "RTN","TMGNDF2H",445,0) "RTN","TMGNDF2H",446,0) ;"2 STRENGTH [Fa] "RTN","TMGNDF2H",447,0) ;" e.g. STRENGTH: 240 "RTN","TMGNDF2H",448,0) set TMGFDA(50.68,IENS,2)=$$GET1^DIQ(22706.9,IEN,1) "RTN","TMGNDF2H",449,0) "RTN","TMGNDF2H",450,0) ;"3 UNITS <-Pntr [P50.607'a] "RTN","TMGNDF2H",451,0) ;" e.g. UNITS: MG "RTN","TMGNDF2H",452,0) new tempUnits set tempUnits=$$GET1^DIQ(22706.9,IEN,2) "RTN","TMGNDF2H",453,0) if tempUnits'="" do "RTN","TMGNDF2H",454,0) . do EnsureUnits(tempUnits) "RTN","TMGNDF2H",455,0) . set TMGFDA(50.68,IENS,3)=tempUnits "RTN","TMGNDF2H",456,0) "RTN","TMGNDF2H",457,0) ;"5 VA PRINT NAME [Fa] "RTN","TMGNDF2H",458,0) ;" e.g. VA PRINT NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF2H",459,0) ;"set tempS=$$MakeName(IEN,40,AllowCut) "RTN","TMGNDF2H",460,0) ;"if tempS="^" set result=0 goto A2VPDone "RTN","TMGNDF2H",461,0) set tempS=$piece($get(^TMG(22706.9,IEN,7)),"^",3) ;"7;3 = .055 TRADEBANE - 40 "RTN","TMGNDF2H",462,0) set TMGFDA(50.68,IENS,5)=tempS ;" 5=VA PRINT NAME "RTN","TMGNDF2H",463,0) "RTN","TMGNDF2H",464,0) ;"6 VA PRODUCT IDENTIFIER [Fa] <--- will use to store "0;TMG" "RTN","TMGNDF2H",465,0) ;" e.g. VA PRODUCT IDENTIFIER: D0230 "RTN","TMGNDF2H",466,0) set TMGFDA(50.68,IENS,6)="0;TMG" "RTN","TMGNDF2H",467,0) "RTN","TMGNDF2H",468,0) ;"14 ACTIVE INGREDIENTS W:^ D:^ <-Mult [50.6814P] "RTN","TMGNDF2H",469,0) ;"(multiple/subfile, add after this record added) "RTN","TMGNDF2H",470,0) "RTN","TMGNDF2H",471,0) ;"15 PRIMARY VA DRUG CLASS <-Pntr [P50.605'a] "RTN","TMGNDF2H",472,0) ;" e.g. PRIMARY VA DRUG CLASS: CV200 "RTN","TMGNDF2H",473,0) set TMGFDA(50.68,IENS,15)=$$GET1^DIQ(22706.9,IEN,.09) "RTN","TMGNDF2H",474,0) "RTN","TMGNDF2H",475,0) quit "RTN","TMGNDF2H",476,0) "RTN","TMGNDF2H",477,0) "RTN","TMGNDF2H",478,0) EnsureIngredients(fdaIEN,vapIEN) "RTN","TMGNDF2H",479,0) ;"Purpose: to ensure that all the ingredients from the FDA record (22706.9) are in the "RTN","TMGNDF2H",480,0) ;" VA PRODUCT record (50.68) "RTN","TMGNDF2H",481,0) ;"Input: fdaIEN -- the IEN from 22706.9 "RTN","TMGNDF2H",482,0) ;" vapIEN -- the target IEN in 50.68 "RTN","TMGNDF2H",483,0) ;"result: 1= OK to continue, 0=error "RTN","TMGNDF2H",484,0) "RTN","TMGNDF2H",485,0) new result set result=1 ;"default to success "RTN","TMGNDF2H",486,0) new recNum set recNum=1 "RTN","TMGNDF2H",487,0) ;"new IENS set IENS=fdaIEN_"," "RTN","TMGNDF2H",488,0) new IENS set IENS=vapIEN_"," "RTN","TMGNDF2H",489,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF2H",490,0) "RTN","TMGNDF2H",491,0) new subIEN set subIEN=0 ;"INGREDIENTS "RTN","TMGNDF2H",492,0) for set subIEN=+$order(^TMG(22706.9,fdaIEN,4,subIEN)) quit:(+subIEN'>0) do "RTN","TMGNDF2H",493,0) . new node set node=$get(^TMG(22706.9,fdaIEN,4,subIEN,0)) "RTN","TMGNDF2H",494,0) . new pIngredients,strength,units "RTN","TMGNDF2H",495,0) . set pIngredients=$piece(node,"^",3) ;"INGREDIENTS (a POINTER) "RTN","TMGNDF2H",496,0) . set strength=$piece(node,"^",4) ;"STRENGTH "RTN","TMGNDF2H",497,0) . set units=$piece(node,"^",6) ;"UNITS "RTN","TMGNDF2H",498,0) . ;"First search to ensure ingredient is not already present. "RTN","TMGNDF2H",499,0) . new subIEN2 set subIEN2=0 "RTN","TMGNDF2H",500,0) . new found set found=0 "RTN","TMGNDF2H",501,0) . for set subIEN2=$order(^PSNDF(50.68,vapIEN,2,subIEN2)) quit:(+subIEN2'>0)!found do "RTN","TMGNDF2H",502,0) . . new ptr set ptr=$piece($get(^PSNDF(50.68,vapIEN,2,subIEN2,0)),"^",1) "RTN","TMGNDF2H",503,0) . . if ptr=pIngredients set found=1 "RTN","TMGNDF2H",504,0) . if found=1 quit "RTN","TMGNDF2H",505,0) . if pIngredients="" do quit "RTN","TMGNDF2H",506,0) . . write !,"Ingredient entry is missing actual ingredient, so that subpart was DELETED.",! "RTN","TMGNDF2H",507,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF2H",508,0) . . set TMGFDA(22706.916,subIEN_","_fdaIEN_",",.01)="@" ;"delete entry. "RTN","TMGNDF2H",509,0) . . do FILE^DIE("E","TMGFDA","TMGMSG") "RTN","TMGNDF2H",510,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2H",511,0) . set TMGFDA(50.6814,"+"_recNum_","_IENS,.01)=pIngredients "RTN","TMGNDF2H",512,0) . if strength'="" set TMGFDA(50.6814,"+"_recNum_","_IENS,1)=strength "RTN","TMGNDF2H",513,0) . if units'="" set TMGFDA(50.6814,"+"_recNum_","_IENS,2)=units "RTN","TMGNDF2H",514,0) . set recNum=recNum+1 "RTN","TMGNDF2H",515,0) "RTN","TMGNDF2H",516,0) if $data(TMGFDA)=0 goto EIDone "RTN","TMGNDF2H",517,0) do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2H",518,0) if $data(TMGMSG("DIERR")) do goto A2VPDone "RTN","TMGNDF2H",519,0) . set result=0 if $get(Quiet)=1 quit "RTN","TMGNDF2H",520,0) . write !,"Error adding ingredients subrecord. IEN in 22706.9=",fdaIEN,! "RTN","TMGNDF2H",521,0) . new PriorErrorFound "RTN","TMGNDF2H",522,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2H",523,0) EIDone "RTN","TMGNDF2H",524,0) quit result "RTN","TMGNDF2H",525,0) "RTN","TMGNDF2H",526,0) "RTN","TMGNDF2H",527,0) EnsureNDC(IEN) "RTN","TMGNDF2H",528,0) ;"Purpose: Ensure record exists in NDC/UPN file (50.67). "RTN","TMGNDF2H",529,0) ;"Input: IEN -- IEN from file 22706.9 (TMG FDA IMPORT COMPILED) to add from "RTN","TMGNDF2H",530,0) ;"Output: An entry to be added to file 50.67 "RTN","TMGNDF2H",531,0) ;"Result: 1=OK to continue, 0 if error "RTN","TMGNDF2H",532,0) "RTN","TMGNDF2H",533,0) ;"Make record in NDC/UPN file (50.67). "RTN","TMGNDF2H",534,0) ;"File: NDC/UPN Branch: 1 "RTN","TMGNDF2H",535,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGNDF2H",536,0) ;"=============================================================================== "RTN","TMGNDF2H",537,0) ;" 1 0;1 .01 SEQUENCE NUMBER [RNJ9,0aX] "RTN","TMGNDF2H",538,0) ;" 2 0;2 1 NDC [Fa] "RTN","TMGNDF2H",539,0) ;" 3 0;3 2 UPN [Fa] "RTN","TMGNDF2H",540,0) ;" 4 0;4 3 MANUFACTURER <-Pntr [P55.95'a] "RTN","TMGNDF2H",541,0) ;" 5 0;5 4 TRADE NAME [Fa] "RTN","TMGNDF2H",542,0) ;" 6 0;6 5 VA PRODUCT NAME <-Pntr [P50.68'a] "RTN","TMGNDF2H",543,0) ;" 1;0 6 ROUTE OF ADMINISTRATION W:^ D:^ <-Mult [50.676A] "RTN","TMGNDF2H",544,0) ;" 7 -0;1 .01 -ROUTE OF ADMINISTRATION [FaX] "RTN","TMGNDF2H",545,0) ;" 8 0;7 7 INACTIVATION DATE [Da] "RTN","TMGNDF2H",546,0) ;" 9 0;8 8 PACKAGE SIZE <-Pntr [P50.609'a] "RTN","TMGNDF2H",547,0) ;" 10 0;9 9 PACKAGE TYPE <-Pntr [P50.608'a] "RTN","TMGNDF2H",548,0) ;" 11 0;10 10 OTX/RX INDICATOR [Sa] "RTN","TMGNDF2H",549,0) ;" 2;0 11 PREVIOUS NDC W:^ D:^ <-Mult [50.6711A] "RTN","TMGNDF2H",550,0) ;" 12 -0;1 .01 -PREVIOUS NDC [Fa] "RTN","TMGNDF2H",551,0) ;" 3;0 12 PREVIOUS UPN W:^ D:^ <-Mult [50.6712A] "RTN","TMGNDF2H",552,0) ;" 13 -0;1 .01 -PREVIOUS UPN [Fa] "RTN","TMGNDF2H",553,0) ;" <> <> <> "RTN","TMGNDF2H",554,0) "RTN","TMGNDF2H",555,0) new result set result=0 ;" default to failure "RTN","TMGNDF2H",556,0) "RTN","TMGNDF2H",557,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF2H",558,0) "RTN","TMGNDF2H",559,0) new NDC set NDC=$piece($get(^TMG(22706.9,IEN,1)),"^",2) ;"1;2= field 5, NDC 12 digit "RTN","TMGNDF2H",560,0) new ndcIEN set ndcIEN=$order(^PSNDF(50.67,"NDC",NDC,"")) "RTN","TMGNDF2H",561,0) if +ndcIEN>0 set IENS=ndcIEN_"," goto EN1 "RTN","TMGNDF2H",562,0) "RTN","TMGNDF2H",563,0) ;"Below is for NEW records. DINUM at play here... "RTN","TMGNDF2H",564,0) new newIEN set newIEN="" "RTN","TMGNDF2H",565,0) for set newIEN=$order(^PSNDF(50.67,newIEN),-1) quit:(+newIEN=newIEN)!(newIEN="") "RTN","TMGNDF2H",566,0) if +newIEN=0 do write "Unable to create NDF entry for ",IEN,! goto ENDone "RTN","TMGNDF2H",567,0) set newIEN=newIEN+1 "RTN","TMGNDF2H",568,0) set TMGFDA(50.67,IENS,.01)=newIEN ;" .01 SEQUENCE NUMBER "RTN","TMGNDF2H",569,0) set IENS="+1," "RTN","TMGNDF2H",570,0) "RTN","TMGNDF2H",571,0) EN1 if NDC'="" set TMGFDA(50.67,IENS,1)=NDC ;"1=NDC "RTN","TMGNDF2H",572,0) "RTN","TMGNDF2H",573,0) ;"**Must add manufacturer if to be used! "RTN","TMGNDF2H",574,0) ;" 3 MANUFACTURER <-Pntr [P55.95'a] "RTN","TMGNDF2H",575,0) ;"new Firm set Firm=$get(DrugInfo("FIRM","NAME")) "RTN","TMGNDF2H",576,0) ;"if Firm'="" set TMGFDA(50.67,IENS,3)=Firm "RTN","TMGNDF2H",577,0) "RTN","TMGNDF2H",578,0) new tName set tName=$piece($get(^TMG(22706.9,IEN,7)),"^",3) ;"7;3 = TRADE NAME - 40 "RTN","TMGNDF2H",579,0) if tName'="" set TMGFDA(50.67,IENS,4)=tName ;" 4 TRADE NAME "RTN","TMGNDF2H",580,0) "RTN","TMGNDF2H",581,0) new vapIEN set vapIEN=+$piece($get(^TMG(22706.9,IEN,6)),"^",2) ;"6;2=field 5.5, VA PRODUCT LINK "RTN","TMGNDF2H",582,0) if vapIEN>0 set TMGFDA(50.67,IENS,5)=vapIEN;" 5 VA PRODUCT NAME --pointer to newly added 50.68 record "RTN","TMGNDF2H",583,0) "RTN","TMGNDF2H",584,0) ;" 10 OTX/RX INDICATOR "RTN","TMGNDF2H",585,0) new codeOTC set codeOTC=$piece($get(^TMG(22706.9,IEN,7)),"^",5) ;"7;5= field 7, RX or OTC "RTN","TMGNDF2H",586,0) if codeOTC'="" set TMGFDA(50.67,IENS,10)=codeOTC "RTN","TMGNDF2H",587,0) "RTN","TMGNDF2H",588,0) ;"If I decide to add this, must do it after adding parent record. "RTN","TMGNDF2H",589,0) ;" 1;0 6 ROUTE OF ADMINISTRATION W:^ D:^ <-Mult [50.676A] "RTN","TMGNDF2H",590,0) ;" 7 -0;1 .01 -ROUTE OF ADMINISTRATION [FaX] "RTN","TMGNDF2H",591,0) "RTN","TMGNDF2H",592,0) if IENS'["+" do goto EN2 ;"update existing record "RTN","TMGNDF2H",593,0) . new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF2H",594,0) . if $data(TMGFDA)=0 quit "RTN","TMGNDF2H",595,0) . do FILE^DIE("K","TMGFDA","TMGMSG") ;"FDA is in INTERNAL format "RTN","TMGNDF2H",596,0) "RTN","TMGNDF2H",597,0) else do ;"add new record "RTN","TMGNDF2H",598,0) . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF2H",599,0) EN2 "RTN","TMGNDF2H",600,0) if $data(TMGMSG("DIERR")) do goto ENDone "RTN","TMGNDF2H",601,0) . set result=0 "RTN","TMGNDF2H",602,0) . new PriorErrorFound "RTN","TMGNDF2H",603,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF2H",604,0) "RTN","TMGNDF2H",605,0) set result=1 ;"ensure we are at success. "RTN","TMGNDF2H",606,0) "RTN","TMGNDF2H",607,0) ENDone "RTN","TMGNDF2H",608,0) quit result "RTN","TMGNDF2H",609,0) "RTN","TMGNDF2H",610,0) "RTN","TMGNDF2H",611,0) ;"========================================================== "RTN","TMGNDF2H",612,0) ;"========================================================== "RTN","TMGNDF2H",613,0) EnsureUnits(UnitS) "RTN","TMGNDF2H",614,0) ;"Purpose: to ensure that the UnitS is valid in file 50.607 "RTN","TMGNDF2H",615,0) ;"Input: UnitS -- the string such as "mg;mg" "RTN","TMGNDF2H",616,0) ;"Output: If UnitS is not found in 50.607, then it will be added "RTN","TMGNDF2H",617,0) ;"Results: none "RTN","TMGNDF2H",618,0) "RTN","TMGNDF2H",619,0) new TMGROOT,TMGMSG "RTN","TMGNDF2H",620,0) "RTN","TMGNDF2H",621,0) ;"Finish later... "RTN","TMGNDF2H",622,0) "RTN","TMGNDF2H",623,0) ;"do FIND^DIC(50.607,"","","",UnitS,"*",,,,"TMGROOT","TMGMSG") "RTN","TMGNDF2H",624,0) ;"if +$get(TMGROOT("DILIST",0))=1 goto EUDone "RTN","TMGNDF2H",625,0) ;"goto EUDone "RTN","TMGNDF2H",626,0) "RTN","TMGNDF2H",627,0) ;"Note: if there are duplicate entries (i.e. 2 entries for MG/0.5ML), then Y=-1 "RTN","TMGNDF2H",628,0) new X,Y,DIC "RTN","TMGNDF2H",629,0) set DIC=50.607 "RTN","TMGNDF2H",630,0) set DIC(0)="XML" "RTN","TMGNDF2H",631,0) set X=UnitS "RTN","TMGNDF2H",632,0) do ^DIC "RTN","TMGNDF2H",633,0) if +Y'>0 do "RTN","TMGNDF2H",634,0) . if $get(Quiet)=1 quit "RTN","TMGNDF2H",635,0) . write !,"Can't find or add: ",UnitS,! "RTN","TMGNDF2H",636,0) "RTN","TMGNDF2H",637,0) EUDone "RTN","TMGNDF2H",638,0) quit "RTN","TMGNDF2H",639,0) "RTN","TMGNDF2H",640,0) Unlock50dot607 "RTN","TMGNDF2H",641,0) ;"Purpose to allow deletion in file 50.607 "RTN","TMGNDF2H",642,0) "RTN","TMGNDF2H",643,0) kill ^DD(50.607,.01,8.5) "RTN","TMGNDF2H",644,0) kill ^DD(50.607,.01,9) "RTN","TMGNDF2H",645,0) "RTN","TMGNDF2H",646,0) quit "RTN","TMGNDF2H",647,0) "RTN","TMGNDF2H",648,0) Lock50dot607 "RTN","TMGNDF2H",649,0) ;"Purpose: to restore lock on file 50.607 "RTN","TMGNDF2H",650,0) "RTN","TMGNDF2H",651,0) set ^DD(50.607,.01,8.5)="^" "RTN","TMGNDF2H",652,0) set ^DD(50.607,.01,9)="^" "RTN","TMGNDF2H",653,0) "RTN","TMGNDF2H",654,0) quit "RTN","TMGNDF2H",655,0) "RTN","TMGNDF2H",656,0) Link2VAP "RTN","TMGNDF2H",657,0) ;"Purpose: to fill file 22706.9, field 5.5 in with link to a record "RTN","TMGNDF2H",658,0) ;" in VA PRODUCT file (50.68) that has the SAME national drug "RTN","TMGNDF2H",659,0) ;" code (NDC). It checks for and handles situations where there "RTN","TMGNDF2H",660,0) ;" are multiple entries in 50.68 with the same NDC. It picks "RTN","TMGNDF2H",661,0) ;" the entry with the closest name as the one to use. "RTN","TMGNDF2H",662,0) ;" --It also removes such a link from the VA PRODUCT SIMILAR MATCHES "RTN","TMGNDF2H",663,0) ;" field. I.e. it is not a 'similar' match if it is an exact match. "RTN","TMGNDF2H",664,0) ;" --It also removes such a link from the VA PRODUCT POSSIBLE MATCHES "RTN","TMGNDF2H",665,0) ;" field. I.e. it is not a 'possible' match if it is an exact match. "RTN","TMGNDF2H",666,0) ;"Results: none. "RTN","TMGNDF2H",667,0) "RTN","TMGNDF2H",668,0) ;"new pNDCIndex "RTN","TMGNDF2H",669,0) ;"set pNDCIndex=$name(^TMG("TMP","INDEX NDC-->VAP")) "RTN","TMGNDF2H",670,0) set pNDCIndex=$name(^PSNDF(50.67,"NDC")) "RTN","TMGNDF2H",671,0) "RTN","TMGNDF2H",672,0) new Itr,IEN,success "RTN","TMGNDF2H",673,0) new abort set abort=0 "RTN","TMGNDF2H",674,0) new modCount set modCount=0 "RTN","TMGNDF2H",675,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF2H",676,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF2H",677,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF2H",678,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF2H",679,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP THIS RECORD "RTN","TMGNDF2H",680,0) . new NDC set NDC=$piece($get(^TMG(22706.9,IEN,1)),"^",2) "RTN","TMGNDF2H",681,0) . if NDC="" quit ;"Can't link if no NDC. Fix later? "RTN","TMGNDF2H",682,0) . new count set count=$$ListCt^TMGMISC($name(@pNDCIndex@(NDC))) "RTN","TMGNDF2H",683,0) . new VAP set VAP=0 "RTN","TMGNDF2H",684,0) . if count=1 do "RTN","TMGNDF2H",685,0) . . new ndcP1 "RTN","TMGNDF2H",686,0) . . set ndcP1=+$order(@pNDCIndex@(NDC,"")) "RTN","TMGNDF2H",687,0) . . set VAP=+$piece($get(^PSNDF(50.67,ndcP1,0)),"^",6) "RTN","TMGNDF2H",688,0) . else do "RTN","TMGNDF2H",689,0) . . new vap1,s1,fdaS,ndcP1 "RTN","TMGNDF2H",690,0) . . new bestScore set bestScore=0 "RTN","TMGNDF2H",691,0) . . new bestVAP set bestVAP=0 "RTN","TMGNDF2H",692,0) . . new bestS set bestS="" "RTN","TMGNDF2H",693,0) . . set fdaS=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"TradeName, field .05 "RTN","TMGNDF2H",694,0) . . set ndcP1=+$order(@pNDCIndex@(NDC,"")) "RTN","TMGNDF2H",695,0) . . for do set ndcP1=+$order(@pNDCIndex@(NDC,ndcP1)) quit:(+ndcP1'>0) "RTN","TMGNDF2H",696,0) . . . set vap1=+$piece($get(^PSNDF(50.67,ndcP1,0)),"^",6) "RTN","TMGNDF2H",697,0) . . . set s1=$piece($get(^PSNDF(50.68,vap1,0)),"^",1) "RTN","TMGNDF2H",698,0) . . . new tempScore set tempScore=$$Comp2Strs^TMGSTUTL(fdaS,s1) "RTN","TMGNDF2H",699,0) . . . if tempScore>bestScore set bestScore=tempScore,bestVAP=vap1,bestS=s1 "RTN","TMGNDF2H",700,0) . . if bestScore'>1 set bestVAP=0 "RTN","TMGNDF2H",701,0) . . set VAP=bestVAP "RTN","TMGNDF2H",702,0) . if VAP=0 quit "RTN","TMGNDF2H",703,0) . if $piece($get(^TMG(22706.9,IEN,6)),"^",2)'=VAP do "RTN","TMGNDF2H",704,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF2H",705,0) . . set TMGFDA(22706.9,IEN_",",5.5)=VAP "RTN","TMGNDF2H",706,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2H",707,0) . . do ShowIfDIERR^TMGDEBUG("TMGMSG") "RTN","TMGNDF2H",708,0) . . set modCount=modCount+1 "RTN","TMGNDF2H",709,0) . new subIEN set subIEN=0 "RTN","TMGNDF2H",710,0) . for set subIEN=$order(^TMG(22706.9,IEN,2,subIEN)) quit:(+subIEN'>0) do "RTN","TMGNDF2H",711,0) . . new nearVAP set nearVAP=$piece($get(^TMG(22706.9,IEN,2,subIEN,0)),"^",1) "RTN","TMGNDF2H",712,0) . . if nearVAP'=VAP quit "RTN","TMGNDF2H",713,0) . . ;"write "SIMILAR MATCH contains this link. Deleting...",! "RTN","TMGNDF2H",714,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF2H",715,0) . . set TMGFDA(22706.914,subIEN_","_IEN_",",.01)="@" "RTN","TMGNDF2H",716,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2H",717,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2H",718,0) . . set modCount=modCount+1 "RTN","TMGNDF2H",719,0) . for set subIEN=$order(^TMG(22706.9,IEN,3,subIEN)) quit:(+subIEN'>0) do "RTN","TMGNDF2H",720,0) . . new nearVAP set nearVAP=$piece($get(^TMG(22706.9,IEN,3,subIEN,0)),"^",1) "RTN","TMGNDF2H",721,0) . . if nearVAP'=VAP quit "RTN","TMGNDF2H",722,0) . . ;"write "POSS SIMILAR MATCH contains this link. Deleting...",! "RTN","TMGNDF2H",723,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF2H",724,0) . . set TMGFDA(22706.915,subIEN_","_IEN_",",.01)="@" "RTN","TMGNDF2H",725,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF2H",726,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF2H",727,0) . . set modCount=modCount+1 "RTN","TMGNDF2H",728,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF2H",729,0) "RTN","TMGNDF2H",730,0) write modCount," modifications made.",! "RTN","TMGNDF2H",731,0) do PressToCont^TMGUSRIF "RTN","TMGNDF2H",732,0) quit "RTN","TMGNDF2H",733,0) "RTN","TMGNDF3A") 0^48^B12884 "RTN","TMGNDF3A",1,0) TMGNDF3A ;TMG/kst/FDA Import: Drug class stuff ;03/25/06 "RTN","TMGNDF3A",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF3A",3,0) "RTN","TMGNDF3A",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF3A",5,0) ;" Further processing, after functions in TMGNDF2C "RTN","TMGNDF3A",6,0) ;" Primarily working VA DRUG CLASS stuff. "RTN","TMGNDF3A",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDF3A",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF3A",9,0) ;"11-21-2006 "RTN","TMGNDF3A",10,0) "RTN","TMGNDF3A",11,0) ;"======================================================================= "RTN","TMGNDF3A",12,0) ;" API -- Public Functions. "RTN","TMGNDF3A",13,0) ;"======================================================================= "RTN","TMGNDF3A",14,0) ;"Menu "RTN","TMGNDF3A",15,0) ;"======================================================================= "RTN","TMGNDF3A",16,0) ;"FillFromVADrugClass -- ensure that all the entries in TMG FDA IMPORT COMPILED "RTN","TMGNDF3A",17,0) ;" have a value for field VA DRUG CLASS "RTN","TMGNDF3A",18,0) ;"HandleEmptyClasses -- allow classification of all unclassified drugs (ones "RTN","TMGNDF3A",19,0) ;" with no potential match found in VistA database as a "RTN","TMGNDF3A",20,0) ;" starting point) "RTN","TMGNDF3A",21,0) "RTN","TMGNDF3A",22,0) ;"======================================================================= "RTN","TMGNDF3A",23,0) ;" Private Functions. "RTN","TMGNDF3A",24,0) ;"======================================================================= "RTN","TMGNDF3A",25,0) ;"ShowClasses -- Display all the drug classes, in a heirarchy. "RTN","TMGNDF3A",26,0) ;"GetClasses(Array) -- Purpose: To get an array back the shows the heirarchy of all VA DRUG classes "RTN","TMGNDF3A",27,0) ;"KillIntro(Array) One of the drug classes is AA000, INTRODUCTION. This will kill entry from the Array "RTN","TMGNDF3A",28,0) ;"GetClHeirarchy(ClassIEN,Array) -- get an array back the shows the heirarchy of one VA DRUG class "RTN","TMGNDF3A",29,0) ;"FixClasses -- fix VA DRUG CLASS records which are not properly linked into the heirarchy. "RTN","TMGNDF3A",30,0) ;"Fix1Class(IEN) -- fix the parent entry of one erroneous class, in the VA DRUG CLASS heirarchy. "RTN","TMGNDF3A",31,0) ;"GetInfo(IEN,Array) -- fill record from VA DRUG CLASS file into a usable array "RTN","TMGNDF3A",32,0) ;"TestSelectClass "RTN","TMGNDF3A",33,0) ;"$$SelectClass(Array,AskSub) -- Allow user to browse Array and select drug class "RTN","TMGNDF3A",34,0) ;"Search4Class() -- use Fileman to search for a drug class "RTN","TMGNDF3A",35,0) ;"$$SelectFrom(pRef) -- Allow user to browse Array and select drug class "RTN","TMGNDF3A",36,0) ;"SrchItems(input,Items) -- Search through Items array for input, and return index number if found "RTN","TMGNDF3A",37,0) ;"TestGather "RTN","TMGNDF3A",38,0) ;"GatherClasses(Array) "RTN","TMGNDF3A",39,0) ;"GetPossClass(IEN,Array) -- gather, from a list of possible drug matches, a list of possible VA DRUG CLASSESS "RTN","TMGNDF3A",40,0) ;"VerifyClasses(Array) -- allow user to accept or reject proposed drug class for new drugs. "RTN","TMGNDF3A",41,0) ;"ShowInstructions() "RTN","TMGNDF3A",42,0) ;"LookupHelp() "RTN","TMGNDF3A",43,0) ;"FindHelp() "RTN","TMGNDF3A",44,0) ;"SimHelp() "RTN","TMGNDF3A",45,0) ;"ShowList(Array,Answers,CompactMode,ShowBoth) -- To display the list generated by GatherClasses, by class orginization "RTN","TMGNDF3A",46,0) ;"DoSetClass(Array,Answers,List) -- add ClassIEN to field .09 (VA DRUG CLASS) in file TMG FDA IMPORT COMPILED "RTN","TMGNDF3A",47,0) ;"ShowInfo(Array,Answers,Num) -- show more about the specified drug "RTN","TMGNDF3A",48,0) ;"DoRemove(Array,Answers,List,ByTradeName,FromECode,Cancelled) -- remove entries from Array and Answers "RTN","TMGNDF3A",49,0) ;"DoLookup(Array,Answers,Classes,List,Cancelled) -- Manually lookup class for entries "RTN","TMGNDF3A",50,0) ;"WriteClass(ClassIEN,Array,Answers,List) -- do the actual setting of the class "RTN","TMGNDF3A",51,0) ;"ClrAnswers(Array,Answers,List,FromECode,UndoArray) -- remove entries from Array and Answers array. "RTN","TMGNDF3A",52,0) ;"VerifyWrite(ClassName,Answers,List) -- display list of entries and ask user if class set is desired "RTN","TMGNDF3A",53,0) ;"Disp2List(Answers,List,ByTradeName,ShowBoth) -- interfact to DisplayList function, to allow easier input. "RTN","TMGNDF3A",54,0) ;"DisplayList(Answers,List,Piece,AlsoPiece) -- display list of entries "RTN","TMGNDF3A",55,0) ;"SimilarPick(Array,Answers,List,Cancelled) -- allow user to specify that a set of numbers should use the same class as "RTN","TMGNDF3A",56,0) ;"FindPick(Array,Answers,List,FromECode,Cancelled) -- allow user to look up a drug already in the VistA database, and use the "RTN","TMGNDF3A",57,0) "RTN","TMGNDF3A",58,0) ;"GatherEmpties(Array) -- scan through all records in TMG FDA IMPORT COMPILED, and create an array of "RTN","TMGNDF3A",59,0) ;"ShowEList(Array,Answers,CompactMode,ByTradeName,ShowBoth) -- display the list of 'Empty' classes generated by GatherEmpties "RTN","TMGNDF3A",60,0) ;"ClassEClasses(Array) -- allow user to classify drugs with empty (none) VA Drug Class "RTN","TMGNDF3A",61,0) ;"DoGuess(Array,Answers,EntryList,Cancelled,Classes) -- a wrapper for DoEGuess "RTN","TMGNDF3A",62,0) ;"DoEGuess(Array,Answers,List,ByTradeName,ShowBoth,Cancelled,FormECode,Classes) - guess as classification for entries. "RTN","TMGNDF3A",63,0) ;"GGuessList(Array,Answers,List,Results) -- gather a guessing list of possible classes for each entry in List "RTN","TMGNDF3A",64,0) ;"AutoEClassification(Array) -- attempt to automatically classiffy drugs that have not potential match "RTN","TMGNDF3A",65,0) ;"Guess1(Array,Answers,List) -- return a guessed class, IF there is only one possible guess. "RTN","TMGNDF3A",66,0) ;"DoSetTools(Array,Answers,List,EntryS,ByTradeName,ShowBoth) -- tools for managing SETS to be worked on (List) "RTN","TMGNDF3A",67,0) ;"MkSrchList(Answers,List,ByTradeName,ShowBoth) -- search through Answers for string "RTN","TMGNDF3A",68,0) "RTN","TMGNDF3A",69,0) ;"======================================================================= "RTN","TMGNDF3A",70,0) ;"======================================================================= "RTN","TMGNDF3A",71,0) "RTN","TMGNDF3A",72,0) ;"This block of code will deal with establishing the VA DRUG CLASS "RTN","TMGNDF3A",73,0) "RTN","TMGNDF3A",74,0) Menu "RTN","TMGNDF3A",75,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF3A",76,0) "RTN","TMGNDF3A",77,0) new Menu,UsrSlct "RTN","TMGNDF3A",78,0) set Menu(0)="Pick Option for Filling Import Drug Class (3A)" "RTN","TMGNDF3A",79,0) set Menu(1)="Set class by Linked VA PRODUCT entry if Possible"_$char(9)_"FillByLink" "RTN","TMGNDF3A",80,0) set Menu(2)="Fill DRUG class for IMPORT entries from best guess."_$char(9)_"FillFromVADrugClass" "RTN","TMGNDF3A",81,0) set Menu(3)="Fill DRUG class for IMPORT entries with no guess."_$char(9)_"HandleEmptyClasses" "RTN","TMGNDF3A",82,0) set Menu(4)="Use SELECTOR to browse and edit IMPORT classes"_$char(9)_"SelEdClasses" "RTN","TMGNDF3A",83,0) set Menu(5)="Pick just 1 import and edit drug Class"_$char(9)_"Edit1" "RTN","TMGNDF3A",84,0) set Menu(6)="Pick imports to SKIP based on their drug CLASS"_$char(9)_"PickSkips" "RTN","TMGNDF3A",85,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF3A",86,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF3A",87,0) "RTN","TMGNDF3A",88,0) MC1 "RTN","TMGNDF3A",89,0) write # "RTN","TMGNDF3A",90,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF3A",91,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF3A",92,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF3A",93,0) "RTN","TMGNDF3A",94,0) if UsrSlct="FillFromVADrugClass" do FillFromVADrugClass goto MC1 "RTN","TMGNDF3A",95,0) if UsrSlct="HandleEmptyClasses" do HandleEmptyClasses goto MC1 "RTN","TMGNDF3A",96,0) if UsrSlct="FillByLink" do FillByLink goto MC1 "RTN","TMGNDF3A",97,0) if UsrSlct="SelEdClasses" do SelEdClasses goto MC1 "RTN","TMGNDF3A",98,0) if UsrSlct="Edit1" do Ed1Classes goto MC1 "RTN","TMGNDF3A",99,0) "RTN","TMGNDF3A",100,0) if UsrSlct="PickSkips" do PickSkips^TMGNDF3B goto MC1 "RTN","TMGNDF3A",101,0) "RTN","TMGNDF3A",102,0) if UsrSlct="Prev" goto Menu^TMGNDF2H ;"quit can occur from there... "RTN","TMGNDF3A",103,0) if UsrSlct="Next" goto Menu^TMGNDF3C ;"quit can occur from there... "RTN","TMGNDF3A",104,0) "RTN","TMGNDF3A",105,0) goto MC1 "RTN","TMGNDF3A",106,0) MCDone "RTN","TMGNDF3A",107,0) quit "RTN","TMGNDF3A",108,0) "RTN","TMGNDF3A",109,0) "RTN","TMGNDF3A",110,0) "RTN","TMGNDF3A",111,0) FillFromVADrugClass "RTN","TMGNDF3A",112,0) ;"Purpose: to provide a high-level entry point for ensuring that all the entries "RTN","TMGNDF3A",113,0) ;" in TMG FDA IMPORT COMPILED have a value for field VA DRUG CLASS "RTN","TMGNDF3A",114,0) "RTN","TMGNDF3A",115,0) write # "RTN","TMGNDF3A",116,0) write "======================================================",! "RTN","TMGNDF3A",117,0) write "Link FDA import entries to proper VA DRUG CLASS",! "RTN","TMGNDF3A",118,0) write "======================================================",!,! "RTN","TMGNDF3A",119,0) "RTN","TMGNDF3A",120,0) ;"do FillByLink ;"see if any easy links are all ready to go... "RTN","TMGNDF3A",121,0) new list "RTN","TMGNDF3A",122,0) new % set %=2 "RTN","TMGNDF3A",123,0) if $data(^TMG("TMP","DRUGS NEEDING CLASS"))>0 do "RTN","TMGNDF3A",124,0) . write !,"Infomation from a prior run found.",! "RTN","TMGNDF3A",125,0) . write "Use older info (recommended only during the same import cycle)" "RTN","TMGNDF3A",126,0) . set %=1 do YN^DICN write ! "RTN","TMGNDF3A",127,0) . if %=1 do "RTN","TMGNDF3A",128,0) . . write "Loading... " "RTN","TMGNDF3A",129,0) . . merge list=^TMG("TMP","DRUGS NEEDING CLASS") "RTN","TMGNDF3A",130,0) . . write "Done.",! "RTN","TMGNDF3A",131,0) if (%=-1) goto FDCDone "RTN","TMGNDF3A",132,0) if (%=2) do "RTN","TMGNDF3A",133,0) . write "Scanning drug file...",! "RTN","TMGNDF3A",134,0) . do GatherClasses(.list) "RTN","TMGNDF3A",135,0) . do AutoEClassification(.list) "RTN","TMGNDF3A",136,0) do VerifyClasses(.list) "RTN","TMGNDF3A",137,0) "RTN","TMGNDF3A",138,0) set %=1 "RTN","TMGNDF3A",139,0) write "Save information for future use" "RTN","TMGNDF3A",140,0) do YN^DICN write ! "RTN","TMGNDF3A",141,0) if %=1 do SaveList(.list) "RTN","TMGNDF3A",142,0) "RTN","TMGNDF3A",143,0) FDCDone write "Done.",! "RTN","TMGNDF3A",144,0) quit "RTN","TMGNDF3A",145,0) "RTN","TMGNDF3A",146,0) "RTN","TMGNDF3A",147,0) SaveList(List) "RTN","TMGNDF3A",148,0) ;"Purpse: save list "RTN","TMGNDF3A",149,0) kill ^TMG("TMP","DRUGS NEEDING CLASS") "RTN","TMGNDF3A",150,0) merge ^TMG("TMP","DRUGS NEEDING CLASS")=list "RTN","TMGNDF3A",151,0) "RTN","TMGNDF3A",152,0) quit "RTN","TMGNDF3A",153,0) "RTN","TMGNDF3A",154,0) "RTN","TMGNDF3A",155,0) FillByLink "RTN","TMGNDF3A",156,0) ;"Purpose: Fill Drug class for any drug that has an empty class, but points to "RTN","TMGNDF3A",157,0) ;" an entry in 50.68 "RTN","TMGNDF3A",158,0) "RTN","TMGNDF3A",159,0) write "Setting DRUG CLASS of imports from VA PRODUCT link, if possible.",! "RTN","TMGNDF3A",160,0) new count set count=0 "RTN","TMGNDF3A",161,0) new Itr,IEN "RTN","TMGNDF3A",162,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3A",163,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3A",164,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF3A",165,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3A",166,0) . new CurClass,newClass "RTN","TMGNDF3A",167,0) . set CurClass=+$piece($get(^TMG(22706.9,IEN,1)),"^",5) "RTN","TMGNDF3A",168,0) . if CurClass=0 do "RTN","TMGNDF3A",169,0) . . new vapIEN set vapIEN=+$piece($get(^TMG(22706.9,IEN,2,1,0)),"^",1) "RTN","TMGNDF3A",170,0) . . if vapIEN=0 quit "RTN","TMGNDF3A",171,0) . . set newClass=+$piece($get(^PSDNF(50.68,vapIEN,3)),"^",1) "RTN","TMGNDF3A",172,0) . . if newClass'=0 do "RTN","TMGNDF3A",173,0) . . . ;"write IEN," can be loaded with class: ",newClass,! "RTN","TMGNDF3A",174,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDF3A",175,0) . . . set TMGFDA(22706.9,IEN_",",.09)=newClass "RTN","TMGNDF3A",176,0) . . . ;"set $piece(^TMG(22706.9,IEN,1),"^",5)=newClass "RTN","TMGNDF3A",177,0) . . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3A",178,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3A",179,0) . . . set count=count+1 "RTN","TMGNDF3A",180,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3A",181,0) "RTN","TMGNDF3A",182,0) write count," entries modified.",! "RTN","TMGNDF3A",183,0) do PressToCont^TMGUSRIF "RTN","TMGNDF3A",184,0) quit "RTN","TMGNDF3A",185,0) "RTN","TMGNDF3A",186,0) "RTN","TMGNDF3A",187,0) ShowClasses "RTN","TMGNDF3A",188,0) ;"Purpose: to display all the drug classes, in a heirarchy. "RTN","TMGNDF3A",189,0) "RTN","TMGNDF3A",190,0) new Array "RTN","TMGNDF3A",191,0) do GetClasses(.Array) "RTN","TMGNDF3A",192,0) do ArrayDump^TMGDEBUG("Array") "RTN","TMGNDF3A",193,0) quit "RTN","TMGNDF3A",194,0) "RTN","TMGNDF3A",195,0) "RTN","TMGNDF3A",196,0) GetClasses(Array) "RTN","TMGNDF3A",197,0) ;"Purpose: To get an array back the shows the heirarchy of all VA DRUG classes "RTN","TMGNDF3A",198,0) ;" Array -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGNDF3A",199,0) ;"Output: Array will be filled as follows: "RTN","TMGNDF3A",200,0) ;" Array(GGF-IEN)=e.g. ""AD000^ANTIDOTES,DETERRENTS AND POISON CONTROL" "RTN","TMGNDF3A",201,0) ;" Array(GGF-IEN,GF-IEN)=e.g. "AD100^ALCOHOL DETERRENTS" "RTN","TMGNDF3A",202,0) ;" Array(GGF-IEN,GF-IEN,F-IEN)=e.g. "AD150^ALCOHOL DETERRENTS -- GENERAL TYPE 1" "RTN","TMGNDF3A",203,0) ;" Array(GGF-IEN,GF-IEN,F-IEN,IEN)=e.g. "AD152^ALCOHOL DETERRENTS -- GENERAL TYPE 1b" "RTN","TMGNDF3A",204,0) ;" Note: prior entries in Array are NOT killed. "RTN","TMGNDF3A",205,0) ;"Results: none "RTN","TMGNDF3A",206,0) "RTN","TMGNDF3A",207,0) new IEN "RTN","TMGNDF3A",208,0) set IEN=$order(^PS(50.605,0)) "RTN","TMGNDF3A",209,0) if +IEN>0 for do quit:(+IEN'>0) "RTN","TMGNDF3A",210,0) . do GetClHeirarchy(IEN,.Array) "RTN","TMGNDF3A",211,0) . set IEN=$order(^PS(50.605,IEN)) "RTN","TMGNDF3A",212,0) "RTN","TMGNDF3A",213,0) quit "RTN","TMGNDF3A",214,0) "RTN","TMGNDF3A",215,0) KillIntro(Array) "RTN","TMGNDF3A",216,0) ;"Purpose: One of the drug classes is AA000, INTRODUCTION. This will kill this "RTN","TMGNDF3A",217,0) ;" entry from the Array "RTN","TMGNDF3A",218,0) ;"Input: Array -- Array, as created by GetClasses "RTN","TMGNDF3A",219,0) "RTN","TMGNDF3A",220,0) new IEN "RTN","TMGNDF3A",221,0) set IEN=$order(Array("")) "RTN","TMGNDF3A",222,0) if IEN'="" for do quit:(IEN="") "RTN","TMGNDF3A",223,0) . new temp set temp=IEN "RTN","TMGNDF3A",224,0) . set IEN=$order(Array(IEN)) "RTN","TMGNDF3A",225,0) . if $piece(Array(temp),"^",1)="AA000" kill Array(temp) "RTN","TMGNDF3A",226,0) "RTN","TMGNDF3A",227,0) quit "RTN","TMGNDF3A",228,0) "RTN","TMGNDF3A",229,0) "RTN","TMGNDF3A",230,0) GetClHeirarchy(ClassIEN,Array) "RTN","TMGNDF3A",231,0) ;"Purpose: To get an array back the shows the heirarchy of one VA DRUG class "RTN","TMGNDF3A",232,0) ;"Input: ClassIEN -- the IEN in file VA DRUG CLASS (50.605) "RTN","TMGNDF3A",233,0) ;" Array -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGNDF3A",234,0) ;"Output: Array will be filled as follows: "RTN","TMGNDF3A",235,0) ;" Array(GGF-IEN)=e.g. ""AD000^ANTIDOTES,DETERRENTS AND POISON CONTROL" "RTN","TMGNDF3A",236,0) ;" Array(GGF-IEN,GF-IEN)=e.g. "AD100^ALCOHOL DETERRENTS" "RTN","TMGNDF3A",237,0) ;" Array(GGF-IEN,GF-IEN,F-IEN)=e.g. "AD150^ALCOHOL DETERRENTS -- GENERAL TYPE 1" "RTN","TMGNDF3A",238,0) ;" Array(GGF-IEN,GF-IEN,F-IEN,IEN)=e.g. "AD152^ALCOHOL DETERRENTS -- GENERAL TYPE 1b" "RTN","TMGNDF3A",239,0) ;" Note: prior entries in Array are NOT killed. "RTN","TMGNDF3A",240,0) ;"Results: none "RTN","TMGNDF3A",241,0) "RTN","TMGNDF3A",242,0) new ParentClass,indent "RTN","TMGNDF3A",243,0) new ResultArray "RTN","TMGNDF3A",244,0) "RTN","TMGNDF3A",245,0) if (+ClassIEN'=0) for do quit:(+ClassIEN=0) "RTN","TMGNDF3A",246,0) . new tempArray "RTN","TMGNDF3A",247,0) . if $data(ResultArray) do "RTN","TMGNDF3A",248,0) . . new temp merge temp=ResultArray "RTN","TMGNDF3A",249,0) . . kill ResultArray "RTN","TMGNDF3A",250,0) . . merge ResultArray(ClassIEN)=temp "RTN","TMGNDF3A",251,0) . new Curnode,Code,Name,CodeNum "RTN","TMGNDF3A",252,0) . set Curnode=$get(^PS(50.605,ClassIEN,0)) "RTN","TMGNDF3A",253,0) . set Code=$piece(Curnode,"^",1) "RTN","TMGNDF3A",254,0) . set CodeNum=+$extract(Code,3,5) "RTN","TMGNDF3A",255,0) . set Name=$piece(Curnode,"^",2) "RTN","TMGNDF3A",256,0) . set tempArray(ClassIEN)=Code_"^"_Name "RTN","TMGNDF3A",257,0) . set ParentClass=$piece(Curnode,"^",3) "RTN","TMGNDF3A",258,0) . if ParentClass=ClassIEN set ParentClass=0 ;"I found at least one circular ref. "RTN","TMGNDF3A",259,0) . if (ParentClass=0)&(CodeNum'=0) do "RTN","TMGNDF3A",260,0) . . write IEN,": ",Name," appears broken: ",Code," Will fix...",! "RTN","TMGNDF3A",261,0) . . do Fix1Class(IEN) "RTN","TMGNDF3A",262,0) . set ClassIEN=ParentClass "RTN","TMGNDF3A",263,0) . merge ResultArray=tempArray "RTN","TMGNDF3A",264,0) "RTN","TMGNDF3A",265,0) merge Array=ResultArray "RTN","TMGNDF3A",266,0) "RTN","TMGNDF3A",267,0) quit "RTN","TMGNDF3A",268,0) "RTN","TMGNDF3A",269,0) "RTN","TMGNDF3A",270,0) FixClasses "RTN","TMGNDF3A",271,0) ;"Purpose: I have found a few instances in the VA DRUG CLASS file where records are "RTN","TMGNDF3A",272,0) ;" not properly linked into the heirarchy. They either give themselves as "RTN","TMGNDF3A",273,0) ;" their own parents, or list no parent, though one should be present. "RTN","TMGNDF3A",274,0) ;" If any such entries exist, this function will fix them. "RTN","TMGNDF3A",275,0) "RTN","TMGNDF3A",276,0) new IEN "RTN","TMGNDF3A",277,0) set IEN=$order(^PS(50.605,0)) "RTN","TMGNDF3A",278,0) if +IEN>0 for do quit:(+IEN'>0) "RTN","TMGNDF3A",279,0) . new Curnode,Code,CodeNum,Name "RTN","TMGNDF3A",280,0) . set Curnode=$get(^PS(50.605,IEN,0)) "RTN","TMGNDF3A",281,0) . set Code=$piece(Curnode,"^",1) "RTN","TMGNDF3A",282,0) . set CodeNum=+$extract(Code,3,5) "RTN","TMGNDF3A",283,0) . set Name=$piece(Curnode,"^",2) "RTN","TMGNDF3A",284,0) . set ParentClass=+$piece(Curnode,"^",3) "RTN","TMGNDF3A",285,0) . if ParentClass=IEN set ParentClass=0 "RTN","TMGNDF3A",286,0) . if (ParentClass=0)&(CodeNum'=0) do "RTN","TMGNDF3A",287,0) . . write IEN,": ",Name," appears broken: ",Code," Will fix...",! "RTN","TMGNDF3A",288,0) . . do Fix1Class(IEN) "RTN","TMGNDF3A",289,0) . set IEN=$order(^PS(50.605,IEN)) "RTN","TMGNDF3A",290,0) "RTN","TMGNDF3A",291,0) quit "RTN","TMGNDF3A",292,0) "RTN","TMGNDF3A",293,0) "RTN","TMGNDF3A",294,0) Fix1Class(IEN) "RTN","TMGNDF3A",295,0) ;"Purpose: To fix the parent entry of one erroneous class, in the VA DRUG CLASS heirarchy. "RTN","TMGNDF3A",296,0) ;"Input: IEN -- the record number in VA DRUG CLASS to fix "RTN","TMGNDF3A",297,0) ;"Output: the database will be changed "RTN","TMGNDF3A",298,0) ;"Results: none. "RTN","TMGNDF3A",299,0) "RTN","TMGNDF3A",300,0) new Curnode,Code,CodeNum,ParentCode "RTN","TMGNDF3A",301,0) new ParentClass,NewParentClass "RTN","TMGNDF3A",302,0) "RTN","TMGNDF3A",303,0) set Curnode=$get(^PS(50.605,IEN,0)) "RTN","TMGNDF3A",304,0) set Code=$piece(Curnode,"^",1) "RTN","TMGNDF3A",305,0) set ParentClass=+$piece(Curnode,"^",3) "RTN","TMGNDF3A",306,0) "RTN","TMGNDF3A",307,0) set ParentCode=$extract(Code,1,2)_"000" "RTN","TMGNDF3A",308,0) set NewParentClass=+$order(^PS(50.605,"B",ParentCode,"")) "RTN","TMGNDF3A",309,0) "RTN","TMGNDF3A",310,0) if NewParentClass'=0 do "RTN","TMGNDF3A",311,0) . set $piece(^PS(50.605,IEN,0),"^",3)=NewParentClass "RTN","TMGNDF3A",312,0) "RTN","TMGNDF3A",313,0) quit "RTN","TMGNDF3A",314,0) "RTN","TMGNDF3A",315,0) "RTN","TMGNDF3A",316,0) GetInfo(IEN,Array) "RTN","TMGNDF3A",317,0) ;"Purpose: to fill record from VA DRUG CLASS file into a usable array "RTN","TMGNDF3A",318,0) ;"Input: IEN -- the IEN from VA DRUG CLASS file to get info for "RTN","TMGNDF3A",319,0) ;" Array -- PASS BY REFERENCE, to be filled in with data. Old data is KILLED. "RTN","TMGNDF3A",320,0) ;"Output: Array is filled with data: "RTN","TMGNDF3A",321,0) ;" Array("NAME")=name "RTN","TMGNDF3A",322,0) ;" Array("CODE")=code "RTN","TMGNDF3A",323,0) ;" Array("PARENT IEN")=parent IEN "RTN","TMGNDF3A",324,0) ;"Result: none "RTN","TMGNDF3A",325,0) "RTN","TMGNDF3A",326,0) new Curnode "RTN","TMGNDF3A",327,0) kill Array "RTN","TMGNDF3A",328,0) "RTN","TMGNDF3A",329,0) set Curnode=$get(^PS(50.605,IEN,0)) "RTN","TMGNDF3A",330,0) set Array("CODE")=$piece(Curnode,"^",1) "RTN","TMGNDF3A",331,0) set Array("NAME")=$piece(Curnode,"^",2) "RTN","TMGNDF3A",332,0) set Array("PARENT IEN")=+$piece(Curnode,"^",3) "RTN","TMGNDF3A",333,0) "RTN","TMGNDF3A",334,0) quit "RTN","TMGNDF3A",335,0) "RTN","TMGNDF3A",336,0) ;"---------------------- "RTN","TMGNDF3A",337,0) TestSelectClass "RTN","TMGNDF3A",338,0) "RTN","TMGNDF3A",339,0) new Array,IEN "RTN","TMGNDF3A",340,0) "RTN","TMGNDF3A",341,0) do GetClasses(.Array) "RTN","TMGNDF3A",342,0) do KillIntro(.Array) "RTN","TMGNDF3A",343,0) set IEN=$$SelectClass(.Array,1) "RTN","TMGNDF3A",344,0) "RTN","TMGNDF3A",345,0) write "IEN=",IEN,! "RTN","TMGNDF3A",346,0) "RTN","TMGNDF3A",347,0) quit "RTN","TMGNDF3A",348,0) "RTN","TMGNDF3A",349,0) "RTN","TMGNDF3A",350,0) SelectClass(Array,AskSub) "RTN","TMGNDF3A",351,0) ;"Purpose: Allow user to browse Array and select drug class "RTN","TMGNDF3A",352,0) ;"Input: Array -- An Array containing Drug Class info, as created by GetClasses() "RTN","TMGNDF3A",353,0) ;" AskSub -- OPTIONAL. If 1, user is asked if they want to browse sub-class (auto otherwise) "RTN","TMGNDF3A",354,0) ;"Results: Returns IEN of selected class, or 0 if not selected "RTN","TMGNDF3A",355,0) "RTN","TMGNDF3A",356,0) new IEN,done "RTN","TMGNDF3A",357,0) set done=0 "RTN","TMGNDF3A",358,0) set AskSub=$get(AskSub,0) ;"default=automatic browse of subclasses "RTN","TMGNDF3A",359,0) new pRef set pRef=$name(Array) "RTN","TMGNDF3A",360,0) "RTN","TMGNDF3A",361,0) for do quit:(done=1) "RTN","TMGNDF3A",362,0) . set IEN=$$SelectFrom(pRef) "RTN","TMGNDF3A",363,0) . if IEN=0 do quit "RTN","TMGNDF3A",364,0) . . if $qlength(pRef)>0 do "RTN","TMGNDF3A",365,0) . . . set pRef=$name(@pRef,$qlength(pRef)-1) "RTN","TMGNDF3A",366,0) . . else set done=1 "RTN","TMGNDF3A",367,0) . new skipSub set skipSub=0 "RTN","TMGNDF3A",368,0) . if (AskSub=1)&($data(Array(IEN))>1) do "RTN","TMGNDF3A",369,0) . . new % "RTN","TMGNDF3A",370,0) . . write "Browse sub-categories" "RTN","TMGNDF3A",371,0) . . set %=1 do YN^DICN write ! "RTN","TMGNDF3A",372,0) . . if %'=1 set skipSub=1 "RTN","TMGNDF3A",373,0) . if ($data(Array(IEN))>1)&(skipSub=0) set pRef=$name(@pRef@(IEN)) "RTN","TMGNDF3A",374,0) . else do "RTN","TMGNDF3A",375,0) . . new info,% "RTN","TMGNDF3A",376,0) . . do GetInfo(IEN,.info) "RTN","TMGNDF3A",377,0) . . write "Select: ",info("NAME") "RTN","TMGNDF3A",378,0) . . set %=1 do YN^DICN write ! "RTN","TMGNDF3A",379,0) . . if %=1 set done=1 "RTN","TMGNDF3A",380,0) "RTN","TMGNDF3A",381,0) quit IEN "RTN","TMGNDF3A",382,0) "RTN","TMGNDF3A",383,0) "RTN","TMGNDF3A",384,0) Search4Class() "RTN","TMGNDF3A",385,0) ;"Purpose: to use Fileman to search for a drug class "RTN","TMGNDF3A",386,0) ;"Results: Returns IEN of selected class, or 0 if not selected "RTN","TMGNDF3A",387,0) "RTN","TMGNDF3A",388,0) new DIC,X,Y "RTN","TMGNDF3A",389,0) set DIC=50.605 "RTN","TMGNDF3A",390,0) set DIC(0)="AEQM" "RTN","TMGNDF3A",391,0) set DIC("A")="Enter a DRUG CLASS to search for // " "RTN","TMGNDF3A",392,0) do ^DIC write ! "RTN","TMGNDF3A",393,0) new result set result=0 "RTN","TMGNDF3A",394,0) if +Y>0 set result=+Y "RTN","TMGNDF3A",395,0) quit result "RTN","TMGNDF3A",396,0) "RTN","TMGNDF3A",397,0) "RTN","TMGNDF3A",398,0) SelectFrom(pRef) "RTN","TMGNDF3A",399,0) ;"Purpose: Allow user to browse Array and select drug class "RTN","TMGNDF3A",400,0) ;"Input: pRef -- NAME OF part of array to browse, containing Drug Class info "RTN","TMGNDF3A",401,0) ;"Results: Returns IEN of selected class, or 0 if not selected "RTN","TMGNDF3A",402,0) "RTN","TMGNDF3A",403,0) new temp,Items,Answers "RTN","TMGNDF3A",404,0) new i,count "RTN","TMGNDF3A",405,0) new result set result=0 "RTN","TMGNDF3A",406,0) "RTN","TMGNDF3A",407,0) set i=$order(@pRef@("")) "RTN","TMGNDF3A",408,0) if +i>0 for do quit:(+i'>0) "RTN","TMGNDF3A",409,0) . new name set name=$piece($get(@pRef@(i)),"^",2) "RTN","TMGNDF3A",410,0) . new class set class=$piece($get(@pRef@(i)),"^",1) "RTN","TMGNDF3A",411,0) . set temp(name)=i "RTN","TMGNDF3A",412,0) . set temp(name,class)="" "RTN","TMGNDF3A",413,0) . set i=$order(@pRef@(i)) "RTN","TMGNDF3A",414,0) "RTN","TMGNDF3A",415,0) set count=1 "RTN","TMGNDF3A",416,0) new name "RTN","TMGNDF3A",417,0) set name=$order(temp("")) "RTN","TMGNDF3A",418,0) if name'="" for do quit:(name="") "RTN","TMGNDF3A",419,0) . set Items(count)=name "RTN","TMGNDF3A",420,0) . set Items(count,"CLASS")=$order(temp(name,"")) "RTN","TMGNDF3A",421,0) . set Answers(count)=$get(temp(name)) "RTN","TMGNDF3A",422,0) . set count=count+1 "RTN","TMGNDF3A",423,0) . set name=$order(temp(name)) "RTN","TMGNDF3A",424,0) "RTN","TMGNDF3A",425,0) new done set done=0 "RTN","TMGNDF3A",426,0) for do quit:(done=1) "RTN","TMGNDF3A",427,0) . new name set name=$piece($get(@pRef),"^",2) "RTN","TMGNDF3A",428,0) . if name="" set name="Major Drug Classes" "RTN","TMGNDF3A",429,0) . write !,"Select from one of these ",name,! "RTN","TMGNDF3A",430,0) . set i=$order(Items(0)) "RTN","TMGNDF3A",431,0) . if +i>0 for do quit:(+i'>0) "RTN","TMGNDF3A",432,0) . . write i,". " "RTN","TMGNDF3A",433,0) . . new class set class=$get(Items(i,"CLASS")) "RTN","TMGNDF3A",434,0) . . if class'="" write class,": " "RTN","TMGNDF3A",435,0) . . write Items(i),! "RTN","TMGNDF3A",436,0) . . set i=$order(Items(i)) "RTN","TMGNDF3A",437,0) . write !,"Enter # of Drug Class to Pick (^ to Backup, S to Search): ^// " "RTN","TMGNDF3A",438,0) . new input "RTN","TMGNDF3A",439,0) . read input:$get(DTIME,3600),! "RTN","TMGNDF3A",440,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF3A",441,0) . if input="" set input="^" "RTN","TMGNDF3A",442,0) . if input="S" do quit:(done=1) "RTN","TMGNDF3A",443,0) . . new UsrIEN set UsrIEN=$$Search4Class "RTN","TMGNDF3A",444,0) . . if UsrIEN>0 set result=UsrIEN,done=1 "RTN","TMGNDF3A",445,0) . if input="?" do quit "RTN","TMGNDF3A",446,0) . . do LookupHelp() "RTN","TMGNDF3A",447,0) . . new temp read "-- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",448,0) . if input="" set input="^" "RTN","TMGNDF3A",449,0) . if input="^" set done=1 quit "RTN","TMGNDF3A",450,0) . if +input=input do "RTN","TMGNDF3A",451,0) . . set result=Answers(input) "RTN","TMGNDF3A",452,0) . . set done=1 "RTN","TMGNDF3A",453,0) . else do "RTN","TMGNDF3A",454,0) . . new temp set temp=$$SrchItems(input,.Items) "RTN","TMGNDF3A",455,0) . . if +temp>0 set result=Answers(temp),done=1 "RTN","TMGNDF3A",456,0) . . else write "Invalid input. Please try again.",! "RTN","TMGNDF3A",457,0) "RTN","TMGNDF3A",458,0) quit result "RTN","TMGNDF3A",459,0) "RTN","TMGNDF3A",460,0) "RTN","TMGNDF3A",461,0) SrchItems(input,Items) "RTN","TMGNDF3A",462,0) ;"Purpose: to Search through Items array for input, and return index number if found "RTN","TMGNDF3A",463,0) ;"Input: input -- the user input -- may be a partial match for the name. "RTN","TMGNDF3A",464,0) ;" Items -- PASS BY REFERENCE -- Input array, as created in SelectFrom() "RTN","TMGNDF3A",465,0) ;" Items(1)=value "RTN","TMGNDF3A",466,0) ;" Items(2)=value "RTN","TMGNDF3A",467,0) ;" Items(3)=value "RTN","TMGNDF3A",468,0) ;" "RTN","TMGNDF3A",469,0) ;"Result: returns index of the FIRST match "RTN","TMGNDF3A",470,0) "RTN","TMGNDF3A",471,0) new result set result="" "RTN","TMGNDF3A",472,0) new done set done=0 "RTN","TMGNDF3A",473,0) new value "RTN","TMGNDF3A",474,0) set input=$$UP^XLFSTR($get(input)) "RTN","TMGNDF3A",475,0) new i set i=$order(Items("")) "RTN","TMGNDF3A",476,0) if i'="" for do quit:(i="")!(done=1) "RTN","TMGNDF3A",477,0) . set value=$get(Items(i)) "RTN","TMGNDF3A",478,0) . set value=$extract(value,1,$length(input)) "RTN","TMGNDF3A",479,0) . if input=value set result=i,done=1 "RTN","TMGNDF3A",480,0) . set i=$order(Items(i)) "RTN","TMGNDF3A",481,0) "RTN","TMGNDF3A",482,0) quit result "RTN","TMGNDF3A",483,0) "RTN","TMGNDF3A",484,0) "RTN","TMGNDF3A",485,0) ;"============================================= "RTN","TMGNDF3A",486,0) GatherClasses(Array) "RTN","TMGNDF3A",487,0) ;"Purpose: To scan through all records in TMG FDA IMPORT COMPILED, and create an array of "RTN","TMGNDF3A",488,0) ;" possible entries for VA DRUG CLASS "RTN","TMGNDF3A",489,0) ;"Input: Array -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGNDF3A",490,0) ;"Output: Array will be filled as follows: "RTN","TMGNDF3A",491,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode "RTN","TMGNDF3A",492,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode "RTN","TMGNDF3A",493,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",494,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",495,0) ;"Results: none "RTN","TMGNDF3A",496,0) ;"Note: if SKIP THIS RECORD field is set, then record will be skipped. "RTN","TMGNDF3A",497,0) ;" Also, if there is already an antry for the VA DRUG CLASS field, then will be skipped. "RTN","TMGNDF3A",498,0) "RTN","TMGNDF3A",499,0) write "Gathering information about entries with no current DRUG CLASS",! "RTN","TMGNDF3A",500,0) new Itr,IEN "RTN","TMGNDF3A",501,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3A",502,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3A",503,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF3A",504,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3A",505,0) . new PriorClass set PriorClass=+$piece($get(^TMG(22706.9,IEN,1)),"^",5) "RTN","TMGNDF3A",506,0) . if PriorClass>0 quit "RTN","TMGNDF3A",507,0) . new numRecs set numRecs=+$piece($get(^TMG(22706.9,IEN,3,0)),"^",4) ;"VA PRODUCT POSS MATCH "RTN","TMGNDF3A",508,0) . if numRecs=0 quit "RTN","TMGNDF3A",509,0) . do GetPossClass(IEN,.Array) "RTN","TMGNDF3A",510,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3A",511,0) "RTN","TMGNDF3A",512,0) quit "RTN","TMGNDF3A",513,0) "RTN","TMGNDF3A",514,0) "RTN","TMGNDF3A",515,0) GetPossClass(IEN,Array) "RTN","TMGNDF3A",516,0) ;"Purpose: To gather, from a list of possible drug matches, a list of possible VA DRUG CLASSESS "RTN","TMGNDF3A",517,0) ;"Input: IEN -- IEN from TMG FDA IMPORT COMPILED (22706.9) file, to check. "RTN","TMGNDF3A",518,0) ;" Array -- PASS BY REFERENCE. An OUT PARAMETER "RTN","TMGNDF3A",519,0) ;"Output: Array filled as follows: "RTN","TMGNDF3A",520,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",521,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",522,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",523,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",524,0) "RTN","TMGNDF3A",525,0) new subIEN "RTN","TMGNDF3A",526,0) new TMGTradename set TMGTradename=$piece($get(^TMG(22706.9,IEN,0)),"^",4) "RTN","TMGNDF3A",527,0) set subIEN=$order(^TMG(22706.9,IEN,3,0)) "RTN","TMGNDF3A",528,0) new Dose set Dose=$piece($get(^TMG(22706.9,IEN,0)),"^",2) "RTN","TMGNDF3A",529,0) new Units set Units=$piece($get(^TMG(22706.9,IEN,0)),"^",3) "RTN","TMGNDF3A",530,0) "RTN","TMGNDF3A",531,0) if +subIEN>0 for do quit:(+subIEN'>0) "RTN","TMGNDF3A",532,0) . new DrugIEN set DrugIEN=+$get(^TMG(22706.9,IEN,3,subIEN,0)) "RTN","TMGNDF3A",533,0) . set subIEN=$order(^TMG(22706.9,IEN,3,subIEN)) "RTN","TMGNDF3A",534,0) . if DrugIEN=0 set Array(IEN,"?")="" quit "RTN","TMGNDF3A",535,0) . new ClassIEN set ClassIEN=+$get(^PSNDF(50.68,DrugIEN,3)) "RTN","TMGNDF3A",536,0) . if ClassIEN=0 set Array(IEN,"??")="" quit "RTN","TMGNDF3A",537,0) . new Info "RTN","TMGNDF3A",538,0) . do GetInfo(ClassIEN,.Info) "RTN","TMGNDF3A",539,0) . set Array("POSS MATCH",$get(Info("NAME")),TMGTradename,IEN)=ClassIEN_"^"_$get(Info("CODE"))_"^"_Dose_" "_Units "RTN","TMGNDF3A",540,0) else do "RTN","TMGNDF3A",541,0) . set Array(IEN,"?")="" "RTN","TMGNDF3A",542,0) . set Array("?",IEN)="" "RTN","TMGNDF3A",543,0) "RTN","TMGNDF3A",544,0) quit "RTN","TMGNDF3A",545,0) "RTN","TMGNDF3A",546,0) "RTN","TMGNDF3A",547,0) "RTN","TMGNDF3A",548,0) VerifyClasses(Array) "RTN","TMGNDF3A",549,0) ;"Purpose: To allow user to accept or reject proposed drug class for new drugs. "RTN","TMGNDF3A",550,0) ;"Input: Array -- PASS BY REFERENCE the array generated by GatherClasses "RTN","TMGNDF3A",551,0) ;"Output: Database is changed, by adding data to field .09 (VA DRUG CLASS) "RTN","TMGNDF3A",552,0) ;"Results: none "RTN","TMGNDF3A",553,0) "RTN","TMGNDF3A",554,0) new done set done=0 "RTN","TMGNDF3A",555,0) new input set input="R" "RTN","TMGNDF3A",556,0) new Answers "RTN","TMGNDF3A",557,0) new CompactMode set CompactMode=1 ;" (list display mode: 1=compact, 0=verb "RTN","TMGNDF3A",558,0) new ShowBoth set ShowBoth=1 "RTN","TMGNDF3A",559,0) new ByIngred set ByIngred=0 "RTN","TMGNDF3A",560,0) new EntryList,EntryS,Fn,Cancelled "RTN","TMGNDF3A",561,0) set Cancelled=0 "RTN","TMGNDF3A",562,0) "RTN","TMGNDF3A",563,0) new Classes "RTN","TMGNDF3A",564,0) do GetClasses(.Classes) "RTN","TMGNDF3A",565,0) do KillIntro(.Classes) "RTN","TMGNDF3A",566,0) "RTN","TMGNDF3A",567,0) for do quit:(done=1) "RTN","TMGNDF3A",568,0) . if input="R" do "RTN","TMGNDF3A",569,0) . . write !! "RTN","TMGNDF3A",570,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",571,0) . . write "Specify which drugs are in the correct DRUG CLASS",! "RTN","TMGNDF3A",572,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",573,0) . . do ShowList(.Array,.Answers,CompactMode,ShowBoth,ByIngred) "RTN","TMGNDF3A",574,0) . . do SaveList(.Array) ;"1/31/07 I got tired of loosing work after crashes, so will save each time... "RTN","TMGNDF3A",575,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",576,0) . . write "Specify which drugs are in the correct DRUG CLASS",! "RTN","TMGNDF3A",577,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",578,0) . . write " R to refresh, L lookup, ? for instructions, U to undo, V saVe",! "RTN","TMGNDF3A",579,0) . . write " X remove from list, N iNfo, S similar, F find",! "RTN","TMGNDF3A",580,0) . . write " C turn compact display ",$select((CompactMode=1):"OFF",1:"ON"),", B turn show Both names ",$select((ShowBoth=1):"OFF",1:"ON"),! "RTN","TMGNDF3A",581,0) . . write " I turn sort by Ingredients ",$select((ByIngred=1):"OFF",1:"ON")," G Guess class",! "RTN","TMGNDF3A",582,0) . . if $get(EntryS)'="" write " Current SET #'s: ",EntryS,", D to delete SET",! "RTN","TMGNDF3A",583,0) . . write " # or #-# or #,#-#,# etc., ^ done, ",! "RTN","TMGNDF3A",584,0) . write "Enter number(s) to ACCEPT drug class (or codes listed above): ^//" "RTN","TMGNDF3A",585,0) . read input:$get(DTIME,3600),! "RTN","TMGNDF3A",586,0) . if input="" set input="^" "RTN","TMGNDF3A",587,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF3A",588,0) . if input="^" set done=1 quit "RTN","TMGNDF3A",589,0) . else if (input="?") do "RTN","TMGNDF3A",590,0) . . do ShowInstructions() "RTN","TMGNDF3A",591,0) . . set input="R" "RTN","TMGNDF3A",592,0) . else if input="N" do quit "RTN","TMGNDF3A",593,0) . . read "Enter number of drug to get info about: ^//",input,! "RTN","TMGNDF3A",594,0) . . do ShowInfo(.Array,.Answers,+input) "RTN","TMGNDF3A",595,0) . . set input="R" "RTN","TMGNDF3A",596,0) . else if input="C" do quit "RTN","TMGNDF3A",597,0) . . set CompactMode='CompactMode "RTN","TMGNDF3A",598,0) . . set input="R" "RTN","TMGNDF3A",599,0) . else if input="D" do quit;"---- delete set "RTN","TMGNDF3A",600,0) . . kill EntryList,EntryS "RTN","TMGNDF3A",601,0) . . set input="R" "RTN","TMGNDF3A",602,0) . else if input="U" do quit "RTN","TMGNDF3A",603,0) . . do Undo(.Array) "RTN","TMGNDF3A",604,0) . . set input="R" "RTN","TMGNDF3A",605,0) . else if input="V" do quit "RTN","TMGNDF3A",606,0) . . do SaveList(.Array) "RTN","TMGNDF3A",607,0) . . write "List Saved.",! "RTN","TMGNDF3A",608,0) . else if input="I" do quit "RTN","TMGNDF3A",609,0) . . set ByIngred='ByIngred "RTN","TMGNDF3A",610,0) . . set input="R" "RTN","TMGNDF3A",611,0) . else if input="B" do quit "RTN","TMGNDF3A",612,0) . . set ShowBoth='ShowBoth "RTN","TMGNDF3A",613,0) . . set input="R" "RTN","TMGNDF3A",614,0) . else if input="L" do quit;"<----- Lookup manually "RTN","TMGNDF3A",615,0) . . set Fn="do DoLookup(.Array,.Answers,.Classes,.EntryList,0,.Cancelled)" "RTN","TMGNDF3A",616,0) . . do XMenuOption("lookup manually",Fn,"LookupHelp",.EntryList,.EntryS) "RTN","TMGNDF3A",617,0) . else if input="G" do quit;" ---- guess drugs "RTN","TMGNDF3A",618,0) . . set Fn="do DoGuess(.Array,.Answers,.EntryList,.Cancelled,.Classes)" "RTN","TMGNDF3A",619,0) . . do XMenuOption("Guess Class",Fn,"LookupHelp",.EntryList,.EntryS) "RTN","TMGNDF3A",620,0) . else if input="S" do quit "RTN","TMGNDF3A",621,0) . . set Fn="do SimilarPick(.Array,.Answers,.EntryList,.Cancelled)" "RTN","TMGNDF3A",622,0) . . do XMenuOption("classify by SIMILARITY","do SimilarPick(.Array,.Answers,.EntryList)","LookupHelp",.EntryList,.EntryS) "RTN","TMGNDF3A",623,0) . else if input="X" do quit "RTN","TMGNDF3A",624,0) . . set Fn="do DoRemove(.Array,.Answers,.EntryList,0,0,.Cancelled)" "RTN","TMGNDF3A",625,0) . . do XMenuOption("REMOVE from list",Fn,"SimHelp",.EntryList,.EntryS) "RTN","TMGNDF3A",626,0) . else if input="F" do quit "RTN","TMGNDF3A",627,0) . . set Fn="do FindPick(.Array,.Answers,.EntryList,0,.Cancelled)" "RTN","TMGNDF3A",628,0) . . do XMenuOption("classify by FINDING a similar drug",Fn,"FindHelp",.EntryList,.EntryS) "RTN","TMGNDF3A",629,0) . else do ;"default is ACCEPT "RTN","TMGNDF3A",630,0) . . set Cancelled=0 "RTN","TMGNDF3A",631,0) . . set Fn="do DoSetClass(.Array,.Answers,.EntryList)" "RTN","TMGNDF3A",632,0) . . do XMenuOption("",Fn,"",.EntryList,.EntryS) "RTN","TMGNDF3A",633,0) quit "RTN","TMGNDF3A",634,0) "RTN","TMGNDF3A",635,0) XMenuOption(Prompt,FnStr,HlpFn,EntryList,EntryS) "RTN","TMGNDF3A",636,0) ;"Purpose: To carry out the various menu functions "RTN","TMGNDF3A",637,0) ;"Input: Prompt: the message to use to prompt user to enter numbers etc. "RTN","TMGNDF3A",638,0) ;" "Enter the Number(s) to" will be automatically provided "RTN","TMGNDF3A",639,0) ;" and ": (? help) ^// " will be added at end "RTN","TMGNDF3A",640,0) ;" FnStr: -- code to execute, e.g. "do DoLookup(.Array,.Answers,.Classes,.EntryList)" "RTN","TMGNDF3A",641,0) ;" HlpFn: e.g. FindHelp, SimHelp, LookupHelp, etc Don't add () to name "RTN","TMGNDF3A",642,0) ;" EntryList -- PASS BY REFERENCE "RTN","TMGNDF3A",643,0) ;" EntryS -- PASS BY REFERENCE. a string showing current set as a string "RTN","TMGNDF3A",644,0) ;"Note: makes use of global scope of 'input', and 'CompactMode', 'Cancelled' "RTN","TMGNDF3A",645,0) ;"Result: none. "RTN","TMGNDF3A",646,0) "RTN","TMGNDF3A",647,0) if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF3A",648,0) . if Prompt'="" do "RTN","TMGNDF3A",649,0) XMO1 . . write "Enter the Number(s) to ",Prompt,": (? help) ^// " "RTN","TMGNDF3A",650,0) . . read input,! "RTN","TMGNDF3A",651,0) . . if input="?" do goto XMO1 "RTN","TMGNDF3A",652,0) . . . new Code set Code="do "_HlpFn_"()" "RTN","TMGNDF3A",653,0) . . . Xecute code "RTN","TMGNDF3A",654,0) . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF3A",655,0) . if valid set EntryS=input "RTN","TMGNDF3A",656,0) Xecute FnStr "RTN","TMGNDF3A",657,0) if CompactMode=1 set input="R" "RTN","TMGNDF3A",658,0) if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF3A",659,0) "RTN","TMGNDF3A",660,0) quit "RTN","TMGNDF3A",661,0) "RTN","TMGNDF3A",662,0) ShowInstructions() "RTN","TMGNDF3A",663,0) ;"Purpose: to explain the matching proces "RTN","TMGNDF3A",664,0) "RTN","TMGNDF3A",665,0) new temp "RTN","TMGNDF3A",666,0) write !,"Instruction:",!! "RTN","TMGNDF3A",667,0) write "Each drug that is to be added to the VistA database should have a drug CLASS.",! "RTN","TMGNDF3A",668,0) write "This class is used by VistA for drug interaction and drug allergy screening.",! "RTN","TMGNDF3A",669,0) write "As drugs are imported from the FDA database, the program attempts to determine",! "RTN","TMGNDF3A",670,0) write "the class automatically by comparing the drug to other drugs that have already",! "RTN","TMGNDF3A",671,0) write "been classified. This process is far from perfect and often produces incorrect",! "RTN","TMGNDF3A",672,0) write "matches. A knowledgable user (you) must review each of these potential ",! "RTN","TMGNDF3A",673,0) write "classifications and either accept them if accurate, or manually correct them.",!! "RTN","TMGNDF3A",674,0) write "If a match is correct, it may be accepted by simply entering the number of the entry.",! "RTN","TMGNDF3A",675,0) write "Multiple correct entries may be accepted at once by entering a range of numbers,",! "RTN","TMGNDF3A",676,0) write "e.g. 3-18. A list may also be entered, e.g. 3,7,9,15. A combination of these may",! "RTN","TMGNDF3A",677,0) write "also be entered, e.g. 1-20,32-45,50,75-100 etc.",! "RTN","TMGNDF3A",678,0) write ! "RTN","TMGNDF3A",679,0) write "The list of drugs to be reviewed can be quite long (i.e. tens of thousands of ",! "RTN","TMGNDF3A",680,0) write "drugs long), so a 'compact' mode is provided. When compact mode is ON, only",! "RTN","TMGNDF3A",681,0) write "the last classifaction grouping is shown. This mode may be turned on or off by",! "RTN","TMGNDF3A",682,0) write "entering 'C'",! "RTN","TMGNDF3A",683,0) write ! "RTN","TMGNDF3A",684,0) read " --- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",685,0) write # "RTN","TMGNDF3A",686,0) write !,"Instruction (continued):",!! "RTN","TMGNDF3A",687,0) write "Because many drug names may be unfamiliar, one may need to review the details of the",! "RTN","TMGNDF3A",688,0) write "drug entry before being able to classify it. This may be done by typing 'I'. This",! "RTN","TMGNDF3A",689,0) write "makes use of a standard Fileman record inquiry tool. Accept the default answers to",! "RTN","TMGNDF3A",690,0) write "the questions 'STANDARD CAPTIONED OUTPUT?' and 'Include COMPUTED fields?'. The",! "RTN","TMGNDF3A",691,0) write "entry in the file TMG FDA IMPORT COMPILED (a temporary file) will be displayed.",! "RTN","TMGNDF3A",692,0) write "After displaying the info, it will ask to select another entry to display.",! "RTN","TMGNDF3A",693,0) write "Just press enter exit and return to the matching process.",! "RTN","TMGNDF3A",694,0) write ! "RTN","TMGNDF3A",695,0) write "A faster way to review the ingredients of drug entries is to turn on the ingredient-",! "RTN","TMGNDF3A",696,0) write "display mode with 'G'. This will display the ingredient list after each drug in",! "RTN","TMGNDF3A",697,0) write "the display.",! "RTN","TMGNDF3A",698,0) write ! "RTN","TMGNDF3A",699,0) write "Once one is ready to correct a classification, a variety of tools are provided.",! "RTN","TMGNDF3A",700,0) write "Each tool will first ask for the drug entry or entries that are to be classified.",! "RTN","TMGNDF3A",701,0) write ! "RTN","TMGNDF3A",702,0) read " --- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",703,0) write # "RTN","TMGNDF3A",704,0) write !,"Instruction (continued):",!! "RTN","TMGNDF3A",705,0) write "The first classification tool is the 'F' (find) command." "RTN","TMGNDF3A",706,0) do FindHelp() "RTN","TMGNDF3A",707,0) read " --- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",708,0) write # "RTN","TMGNDF3A",709,0) write !,"Instruction (continued):",!! "RTN","TMGNDF3A",710,0) write "The next classification tool is the 'L' (lookup) command.",! "RTN","TMGNDF3A",711,0) do LookupHelp() "RTN","TMGNDF3A",712,0) "RTN","TMGNDF3A",713,0) read " --- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",714,0) write # "RTN","TMGNDF3A",715,0) write !,"Instruction (continued):",!! "RTN","TMGNDF3A",716,0) write "The next tool is the 'S' (similarity) command." "RTN","TMGNDF3A",717,0) do SimHelp() "RTN","TMGNDF3A",718,0) "RTN","TMGNDF3A",719,0) read " --- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",720,0) write # "RTN","TMGNDF3A",721,0) write !,"Instruction (continued):",!! "RTN","TMGNDF3A",722,0) write "And lastly entries may simply be removed from the list with the 'X' command.",! "RTN","TMGNDF3A",723,0) write "They may be removed perminantly from consideration for addition to the Vista",! "RTN","TMGNDF3A",724,0) write "database. This is appropriate for a drug that will never be used at your",! "RTN","TMGNDF3A",725,0) write "location. Or, the drug may be just removed from the current work list.",! "RTN","TMGNDF3A",726,0) write "This will leave the drugs unclassified and may cause DANGEROUS drug interactions",! "RTN","TMGNDF3A",727,0) write "or drug allergies to be UNDETECTED when this drug is prescribed for a patient",! "RTN","TMGNDF3A",728,0) write "later",! "RTN","TMGNDF3A",729,0) write ! "RTN","TMGNDF3A",730,0) read " --- Press ENTER to continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",731,0) "RTN","TMGNDF3A",732,0) quit "RTN","TMGNDF3A",733,0) "RTN","TMGNDF3A",734,0) "RTN","TMGNDF3A",735,0) LookupHelp() "RTN","TMGNDF3A",736,0) ;"Purpose: Show help for the Lookup functionality "RTN","TMGNDF3A",737,0) "RTN","TMGNDF3A",738,0) write "A list of drug classifications is shown to pick from. The VA DRUG CLASS system",! "RTN","TMGNDF3A",739,0) write "arranges drug classes into a heirarchy. And initially only the highest level",! "RTN","TMGNDF3A",740,0) write "classes are shown. Enter the number of a class to select it. If that class has",! "RTN","TMGNDF3A",741,0) write "subclasses, then these will be shown. Select the subclass, and then verify it.",! "RTN","TMGNDF3A",742,0) write "To backup, press ENTER or ^.",! "RTN","TMGNDF3A",743,0) write ! "RTN","TMGNDF3A",744,0) quit "RTN","TMGNDF3A",745,0) "RTN","TMGNDF3A",746,0) "RTN","TMGNDF3A",747,0) FindHelp() "RTN","TMGNDF3A",748,0) ;"Purpose: to show help for the FIND functionality "RTN","TMGNDF3A",749,0) "RTN","TMGNDF3A",750,0) write ! "RTN","TMGNDF3A",751,0) write "This command allows one to find a drug already in the VistA database, and use",! "RTN","TMGNDF3A",752,0) write "it's classification for the new drug in question.",! "RTN","TMGNDF3A",753,0) write "For example, if one is asked to classify POTASSIUM GLUCONATE ELIXIR 20 MEQ,",! "RTN","TMGNDF3A",754,0) write "there is a high likelihood that a similar drug already exists, and the matching",! "RTN","TMGNDF3A",755,0) write "process failed to find it. So search for the drug as follows:",! "RTN","TMGNDF3A",756,0) write "Enter drug name with desired DRUG CLASS// potassium gluc <--partial name entered",! "RTN","TMGNDF3A",757,0) write " 1 POTASSIUM GLUCONATE 2.2MEQ TAB",! "RTN","TMGNDF3A",758,0) write " 2 POTASSIUM GLUCONATE 2.6MEQ TAB",! "RTN","TMGNDF3A",759,0) write " 3 POTASSIUM GLUCONATE 20MEQ/15ML (SF) ELIXIR",! "RTN","TMGNDF3A",760,0) write " 4 POTASSIUM GLUCONATE 20MEQ/15ML ELIXIR",! "RTN","TMGNDF3A",761,0) write " 5 POTASSIUM GLUCONATE 20MEQ/15ML LIQUID",! "RTN","TMGNDF3A",762,0) write " Press to see more, '^' to exit this list, OR",! "RTN","TMGNDF3A",763,0) write " CHOOSE 1-5: 4 POTASSIUM GLUCONATE 20MEQ/15ML ELIXIR <-- 4 entered",! "RTN","TMGNDF3A",764,0) write ! "RTN","TMGNDF3A",765,0) write " DRUG CLASS: POTASSIUM",! "RTN","TMGNDF3A",766,0) write " Use this for drug(s) below?:",! "RTN","TMGNDF3A",767,0) write " entry: POTASSIUM GLUCONATE ELIXIR",! "RTN","TMGNDF3A",768,0) write " --------------------------------------",! "RTN","TMGNDF3A",769,0) write " Use DRUG CLASS [POTASSIUM] for drug(s) above? Yes// (Yes)",!! "RTN","TMGNDF3A",770,0) quit "RTN","TMGNDF3A",771,0) "RTN","TMGNDF3A",772,0) SimHelp() "RTN","TMGNDF3A",773,0) ;"Purpose: To show help for the Find Similar functionality "RTN","TMGNDF3A",774,0) "RTN","TMGNDF3A",775,0) write ! "RTN","TMGNDF3A",776,0) write "This command allows one to set the drug class of the drug in question to be",! "RTN","TMGNDF3A",777,0) write "the same as another drug shown in the display. For example:",! "RTN","TMGNDF3A",778,0) write ! "RTN","TMGNDF3A",779,0) write "CLASS: CEPHALOSPORIN 3RD GENERATION",! "RTN","TMGNDF3A",780,0) write "6068. TAZICEF FOR INJECTION 1 GM/VIAL",! "RTN","TMGNDF3A",781,0) write ! "RTN","TMGNDF3A",782,0) write "CLASS: DENTIFRICES",! "RTN","TMGNDF3A",783,0) write "7113. ALBION D PASTE DESENSITIZING DENTAL PROPHYLACTIC PASTE 8 %",! "RTN","TMGNDF3A",784,0) write "7114. PLUS + WHITE DESENTIZING FLUORIDE TOOTHPASTE",! "RTN","TMGNDF3A",785,0) write "7115. TAZICEF FOR INJECTION 1 GM",! "RTN","TMGNDF3A",786,0) write ! "RTN","TMGNDF3A",787,0) write "Here it would be useful to specify that entry 7115 is SIMILAR to 6068.",! "RTN","TMGNDF3A",788,0) write "This would set the class of 7155 to be CEPHALOSPORIN 3RD GENERATION.",!! "RTN","TMGNDF3A",789,0) quit "RTN","TMGNDF3A",790,0) "RTN","TMGNDF3A",791,0) "RTN","TMGNDF3A",792,0) Undo(Array) "RTN","TMGNDF3A",793,0) ;"Purpose: To allow user to undo an action that was done in error "RTN","TMGNDF3A",794,0) ;"Input: Array -- PASS BY REFERENCE the array containing the data, AND UNDO info "RTN","TMGNDF3A",795,0) ;" Array("UNDO","COUNT")=number of undo steps avail "RTN","TMGNDF3A",796,0) ;" Array("UNDO",Event#,part#)=code to be eXecuted to reverse step. "RTN","TMGNDF3A",797,0) "RTN","TMGNDF3A",798,0) ;"Note: Later, I may allow user to choose which items to undo, but for now, will "RTN","TMGNDF3A",799,0) ;" just undo the very LAST action "RTN","TMGNDF3A",800,0) "RTN","TMGNDF3A",801,0) new UndoCt set UndoCt=$get(Array("UNDO","COUNT")) "RTN","TMGNDF3A",802,0) new i set i=$order(Array("UNDO",UndoCt,"")) "RTN","TMGNDF3A",803,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",804,0) . new code set code=$get(Array("UNDO",UndoCt,i)) "RTN","TMGNDF3A",805,0) . do "RTN","TMGNDF3A",806,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGNDF3A",807,0) . . write code,!! "RTN","TMGNDF3A",808,0) . . xecute code "RTN","TMGNDF3A",809,0) . new oldI set oldI=i "RTN","TMGNDF3A",810,0) . set i=$order(Array("UNDO",UndoCt,i)) "RTN","TMGNDF3A",811,0) . kill Array("UNDO",UndoCt,oldI) "RTN","TMGNDF3A",812,0) . set Array("UNDO","COUNT")=UndoCt-1 "RTN","TMGNDF3A",813,0) "RTN","TMGNDF3A",814,0) quit "RTN","TMGNDF3A",815,0) "RTN","TMGNDF3A",816,0) "RTN","TMGNDF3A",817,0) ShowList(Array,Answers,CompactMode,ShowBoth,ByIngred) "RTN","TMGNDF3A",818,0) ;"Purpose: To display the list generated by GatherClasses, by class orginization "RTN","TMGNDF3A",819,0) ;"Input: Array -- the array containing the data "RTN","TMGNDF3A",820,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",821,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",822,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN,"INGRED")=Ingredients <--- optional "RTN","TMGNDF3A",823,0) ;" Answers -- PASS BY REFERENCE. An array that will like display numbers with IENs "RTN","TMGNDF3A",824,0) ;" Answer(count)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",825,0) ;" Answer(count)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",826,0) ;" CompactMode -- OPTIONAL, if value=1, then only the LAST drug class will be "RTN","TMGNDF3A",827,0) ;" expanded (a potientially long list). Others will just show heading. "RTN","TMGNDF3A",828,0) ;" ShowBoth -- OPTIONAL, if value=1, then VA GENERIC field & Tradename will be shown for each entry "RTN","TMGNDF3A",829,0) ;" ByIngred -- OPTIONAL, if value=1, then list is shown sorted by Generic Name "RTN","TMGNDF3A",830,0) ;"Output: List is shown, and the Answers array is established and passed back. "RTN","TMGNDF3A",831,0) ;" Sometimes array is modified such that ingredient node is added "RTN","TMGNDF3A",832,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN,"INGRED")=Ingredients <--- optional "RTN","TMGNDF3A",833,0) ;"Results: none. "RTN","TMGNDF3A",834,0) "RTN","TMGNDF3A",835,0) new someShown set someShown=0 "RTN","TMGNDF3A",836,0) new count,ClassName,LastClass "RTN","TMGNDF3A",837,0) set count=1 "RTN","TMGNDF3A",838,0) kill Answers "RTN","TMGNDF3A",839,0) set CompactMode=$get(CompactMode,0) "RTN","TMGNDF3A",840,0) set ShowBoth=$get(ShowBoth,0) "RTN","TMGNDF3A",841,0) set ByIngred=$get(ByIngred,0) "RTN","TMGNDF3A",842,0) "RTN","TMGNDF3A",843,0) if ByIngred=0 goto SL1 ;"Rather than try to merge the two processes, I just duplicated and modified "RTN","TMGNDF3A",844,0) "RTN","TMGNDF3A",845,0) ;"Display sorted by ingredients "RTN","TMGNDF3A",846,0) "RTN","TMGNDF3A",847,0) ;"First, resort array, by ingredients "RTN","TMGNDF3A",848,0) ;" IngredArray format: "RTN","TMGNDF3A",849,0) ;" IngredArray(ClassName,Ingred,IEN)=ClassIEN^ClassCode^DrugDose^TradeName "RTN","TMGNDF3A",850,0) ;" IngredArray(ClassName,Ingred,IEN)=ClassIEN^ClassCode^DrugDose^TradeName "RTN","TMGNDF3A",851,0) new IngredArray "RTN","TMGNDF3A",852,0) set LastClass=$order(Array("POSS MATCH",""),-1) "RTN","TMGNDF3A",853,0) set ClassName=$order(Array("POSS MATCH","")) "RTN","TMGNDF3A",854,0) if ClassName'="" for do quit:(ClassName="") "RTN","TMGNDF3A",855,0) . write !,"CLASS: ",ClassName,! "RTN","TMGNDF3A",856,0) . new TMGTradeName "RTN","TMGNDF3A",857,0) . new tempCount set tempCount=0 "RTN","TMGNDF3A",858,0) . set TMGTradeName=$order(Array("POSS MATCH",ClassName,"")) "RTN","TMGNDF3A",859,0) . if (CompactMode=1)&(ClassName'=LastClass) set TMGTradeName="" "RTN","TMGNDF3A",860,0) . if TMGTradeName'="" for do quit:(TMGTradeName="") "RTN","TMGNDF3A",861,0) . . new IEN,ClassIEN "RTN","TMGNDF3A",862,0) . . set IEN=$order(Array("POSS MATCH",ClassName,TMGTradeName,"")) "RTN","TMGNDF3A",863,0) . . if IEN>0 for do quit:(IEN'>0) "RTN","TMGNDF3A",864,0) . . . new Ingred,value,dose "RTN","TMGNDF3A",865,0) . . . set value=$get(Array("POSS MATCH",ClassName,TMGTradeName,IEN)) "RTN","TMGNDF3A",866,0) . . . set Ingred=$get(Array("POSS MATCH",ClassName,TMGTradeName,IEN,"INGRED")) "RTN","TMGNDF3A",867,0) . . . if Ingred="" do "RTN","TMGNDF3A",868,0) . . . . set Ingred=$$GET1^DIQ(22706.9,IEN,.08) "RTN","TMGNDF3A",869,0) . . . . set Array("POSS MATCH",ClassName,TMGTradeName,IEN,"INGRED")=Ingred "RTN","TMGNDF3A",870,0) . . . if Ingred="" do "RTN","TMGNDF3A",871,0) . . . . write "Couldn't find an ingredient name for file 22706.9, IEN=",IEN,! "RTN","TMGNDF3A",872,0) . . . . set Ingred="?" "RTN","TMGNDF3A",873,0) . . . if Ingred'="" do "RTN","TMGNDF3A",874,0) . . . . set IngredArray(ClassName,Ingred,IEN)=value "RTN","TMGNDF3A",875,0) . . . . set $piece(IngredArray(ClassName,Ingred,IEN),"^",4)=TMGTradeName "RTN","TMGNDF3A",876,0) . . . set IEN=$order(Array("POSS MATCH",ClassName,TMGTradeName,IEN)) "RTN","TMGNDF3A",877,0) . . set TMGTradeName=$order(Array("POSS MATCH",ClassName,TMGTradeName)) "RTN","TMGNDF3A",878,0) . set ClassName=$order(Array("POSS MATCH",ClassName)) "RTN","TMGNDF3A",879,0) "RTN","TMGNDF3A",880,0) "RTN","TMGNDF3A",881,0) ;"Now display IngredArray "RTN","TMGNDF3A",882,0) ;" IngredArray format: "RTN","TMGNDF3A",883,0) ;" IngredArray(ClassName,Ingred,IEN)=ClassIEN^ClassCode^DrugDose^TradeName "RTN","TMGNDF3A",884,0) ;" IngredArray(ClassName,Ingred,IEN)=ClassIEN^ClassCode^DrugDose^TradeName "RTN","TMGNDF3A",885,0) set LastClass=$order(IngredArray(""),-1) "RTN","TMGNDF3A",886,0) set ClassName=$order(IngredArray("")) "RTN","TMGNDF3A",887,0) if ClassName'="" for do quit:(ClassName="") "RTN","TMGNDF3A",888,0) . write !,"CLASS: ",ClassName,! "RTN","TMGNDF3A",889,0) . new IngredName "RTN","TMGNDF3A",890,0) . new tempCount set tempCount=0 "RTN","TMGNDF3A",891,0) . set IngredName=$order(IngredArray(ClassName,"")) "RTN","TMGNDF3A",892,0) . if (CompactMode=1)&(ClassName'=LastClass) set IngredName="" "RTN","TMGNDF3A",893,0) . if IngredName'="" for do quit:(IngredName="") "RTN","TMGNDF3A",894,0) . . new IEN,ClassIEN "RTN","TMGNDF3A",895,0) . . set IEN=$order(IngredArray(ClassName,IngredName,"")) "RTN","TMGNDF3A",896,0) . . if IEN>0 for do quit:(IEN'>0) "RTN","TMGNDF3A",897,0) . . . new value,dose,TMGTradeName "RTN","TMGNDF3A",898,0) . . . set value=$get(IngredArray(ClassName,IngredName,IEN)) "RTN","TMGNDF3A",899,0) . . . set ClassIEN=$piece(value,"^",1) "RTN","TMGNDF3A",900,0) . . . set dose=$piece(value,"^",3) "RTN","TMGNDF3A",901,0) . . . set TMGTradeName=$piece(value,"^",4) "RTN","TMGNDF3A",902,0) . . . write count,". ",IngredName," ",dose "RTN","TMGNDF3A",903,0) . . . if ShowBoth write " (#",IEN,")" "RTN","TMGNDF3A",904,0) . . . write ! "RTN","TMGNDF3A",905,0) . . . set tempCount=tempCount+1 "RTN","TMGNDF3A",906,0) . . . if (ShowBoth)&(TMGTradeName'="") write " (",TMGTradeName,")",! "RTN","TMGNDF3A",907,0) . . . set Answers(count)=IEN_"^"_TMGTradeName_"^"_ClassIEN_"^"_ClassName "RTN","TMGNDF3A",908,0) . . . set count=count+1 "RTN","TMGNDF3A",909,0) . . . set someShown=1 "RTN","TMGNDF3A",910,0) . . . set IEN=$order(IngredArray(ClassName,IngredName,IEN)) "RTN","TMGNDF3A",911,0) . . set IngredName=$order(IngredArrayArray(ClassName,IngredName)) "RTN","TMGNDF3A",912,0) . if tempCount>20 do "RTN","TMGNDF3A",913,0) . . write "END CLASS: ",ClassName,! "RTN","TMGNDF3A",914,0) . . set tempCount=0 "RTN","TMGNDF3A",915,0) . set ClassName=$order(IngredArray(ClassName)) "RTN","TMGNDF3A",916,0) "RTN","TMGNDF3A",917,0) goto SL2 "RTN","TMGNDF3A",918,0) "RTN","TMGNDF3A",919,0) SL1 ;"Display sorted by tradename "RTN","TMGNDF3A",920,0) set LastClass=$order(Array("POSS MATCH",""),-1) "RTN","TMGNDF3A",921,0) set ClassName=$order(Array("POSS MATCH","")) "RTN","TMGNDF3A",922,0) if ClassName'="" for do quit:(ClassName="") "RTN","TMGNDF3A",923,0) . write !,"CLASS: ",ClassName,! "RTN","TMGNDF3A",924,0) . new TMGTradeName "RTN","TMGNDF3A",925,0) . new tempCount set tempCount=0 "RTN","TMGNDF3A",926,0) . set TMGTradeName=$order(Array("POSS MATCH",ClassName,"")) "RTN","TMGNDF3A",927,0) . if (CompactMode=1)&(ClassName'=LastClass) set TMGTradeName="" "RTN","TMGNDF3A",928,0) . if TMGTradeName'="" for do quit:(TMGTradeName="") "RTN","TMGNDF3A",929,0) . . new IEN,ClassIEN "RTN","TMGNDF3A",930,0) . . set IEN=$order(Array("POSS MATCH",ClassName,TMGTradeName,"")) "RTN","TMGNDF3A",931,0) . . if IEN>0 for do quit:(IEN'>0) "RTN","TMGNDF3A",932,0) . . . new value set value=$get(Array("POSS MATCH",ClassName,TMGTradeName,IEN)) "RTN","TMGNDF3A",933,0) . . . set ClassIEN=$piece(value,"^",1) "RTN","TMGNDF3A",934,0) . . . new dose set dose=$piece(value,"^",3) "RTN","TMGNDF3A",935,0) . . . ;"write count,". (",IEN,") ",TMGTradeName," ",dose,! "RTN","TMGNDF3A",936,0) . . . write count,". ",TMGTradeName," ",dose "RTN","TMGNDF3A",937,0) . . . if ShowBoth write " (#",IEN,")" "RTN","TMGNDF3A",938,0) . . . write ! "RTN","TMGNDF3A",939,0) . . . set tempCount=tempCount+1 "RTN","TMGNDF3A",940,0) . . . if ShowBoth do "RTN","TMGNDF3A",941,0) . . . . new Ingred "RTN","TMGNDF3A",942,0) . . . . set Ingred=$get(Array("POSS MATCH",ClassName,TMGTradeName,IEN,"INGRED")) "RTN","TMGNDF3A",943,0) . . . . if Ingred="" do "RTN","TMGNDF3A",944,0) . . . . . set Ingred=$$GET1^DIQ(22706.9,IEN,.08) "RTN","TMGNDF3A",945,0) . . . . . set Array("POSS MATCH",ClassName,TMGTradeName,IEN,"INGRED")=Ingred "RTN","TMGNDF3A",946,0) . . . . if Ingred'="" write " (Same class as: ",Ingred,")",! "RTN","TMGNDF3A",947,0) . . . set Answers(count)=IEN_"^"_TMGTradeName_"^"_ClassIEN_"^"_ClassName "RTN","TMGNDF3A",948,0) . . . set count=count+1 "RTN","TMGNDF3A",949,0) . . . set someShown=1 "RTN","TMGNDF3A",950,0) . . . set IEN=$order(Array("POSS MATCH",ClassName,TMGTradeName,IEN)) "RTN","TMGNDF3A",951,0) . . set TMGTradeName=$order(Array("POSS MATCH",ClassName,TMGTradeName)) "RTN","TMGNDF3A",952,0) . if tempCount>20 do "RTN","TMGNDF3A",953,0) . . write "END CLASS: ",ClassName,! "RTN","TMGNDF3A",954,0) . . set tempCount=0 "RTN","TMGNDF3A",955,0) . set ClassName=$order(Array("POSS MATCH",ClassName)) "RTN","TMGNDF3A",956,0) "RTN","TMGNDF3A",957,0) SL2 if 'someShown write " --- (List is Empty) ---",! "RTN","TMGNDF3A",958,0) "RTN","TMGNDF3A",959,0) SLDone quit "RTN","TMGNDF3A",960,0) "RTN","TMGNDF3A",961,0) "RTN","TMGNDF3A",962,0) DoSetClass(Array,Answers,List) "RTN","TMGNDF3A",963,0) ;"Purpose: To add ClassIEN to field .09 (VA DRUG CLASS) in file TMG FDA IMPORT COMPILED "RTN","TMGNDF3A",964,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",965,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",966,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",967,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",968,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",969,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",970,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",971,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",972,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",973,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",974,0) ;" Format as follows. "RTN","TMGNDF3A",975,0) ;" List(Entry number)="" "RTN","TMGNDF3A",976,0) ;" List(Entry number)="" "RTN","TMGNDF3A",977,0) ;"Results: none "RTN","TMGNDF3A",978,0) "RTN","TMGNDF3A",979,0) new DrugIEN,DrugName,ClassIEN,ClassName "RTN","TMGNDF3A",980,0) "RTN","TMGNDF3A",981,0) new i "RTN","TMGNDF3A",982,0) set i=$order(List("")) "RTN","TMGNDF3A",983,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",984,0) . set DrugIEN=+$piece($get(Answers(i)),"^",1) "RTN","TMGNDF3A",985,0) . set DrugName=$piece($get(Answers(i)),"^",2) "RTN","TMGNDF3A",986,0) . set ClassIEN=+$piece($get(Answers(i)),"^",3) "RTN","TMGNDF3A",987,0) . set ClassName=$piece($get(Answers(i)),"^",4) "RTN","TMGNDF3A",988,0) . if (DrugIEN'=0)&(ClassIEN'=0) do "RTN","TMGNDF3A",989,0) . . new UndoCt set UndoCt=+$get(Array("UNDO","COUNT"))+1 "RTN","TMGNDF3A",990,0) . . new OldValue set OldValue=$piece($get(^TMG(22706.9,DrugIEN,1)),"^",5) "RTN","TMGNDF3A",991,0) . . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",992,0) . . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",993,0) . . set Array("UNDO",UndoCt,1)="set $piece(^TMG(22706.9,"_DrugIEN_",1),""^"",5)="_OldValue "RTN","TMGNDF3A",994,0) . . set $piece(^TMG(22706.9,DrugIEN,1),"^",5)=ClassIEN ;"I own file, and there are no XREF, so OK to direct set. "RTN","TMGNDF3A",995,0) . . kill Answers(i) "RTN","TMGNDF3A",996,0) . . set OldValue=$get(Array("POSS MATCH",ClassName,DrugName,DrugIEN)) "RTN","TMGNDF3A",997,0) . . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",998,0) . . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",999,0) . . set Array("UNDO",UndoCt,2)="set Array(""POSS MATCH"","""_ClassName_""","""_DrugName_""","_DrugIEN_")="_OldValue "RTN","TMGNDF3A",1000,0) . . set Array("UNDO","COUNT")=UndoCt "RTN","TMGNDF3A",1001,0) . . kill Array("POSS MATCH",ClassName,DrugName,DrugIEN) "RTN","TMGNDF3A",1002,0) . set i=$order(List(i)) "RTN","TMGNDF3A",1003,0) "RTN","TMGNDF3A",1004,0) quit "RTN","TMGNDF3A",1005,0) "RTN","TMGNDF3A",1006,0) "RTN","TMGNDF3A",1007,0) ShowInfo(Array,Answers,Num) "RTN","TMGNDF3A",1008,0) ;"Purpose: to show more about the specified drug "RTN","TMGNDF3A",1009,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1010,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1011,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1012,0) ;" Num -- entry number to show "RTN","TMGNDF3A",1013,0) "RTN","TMGNDF3A",1014,0) new DrugIEN set DrugIEN=+$piece($get(Answers(Num)),"^",1) "RTN","TMGNDF3A",1015,0) if DrugIEN=0 quit "RTN","TMGNDF3A",1016,0) do DumpRec^TMGDEBUG(22706.9,DrugIEN) "RTN","TMGNDF3A",1017,0) quit "RTN","TMGNDF3A",1018,0) "RTN","TMGNDF3A",1019,0) "RTN","TMGNDF3A",1020,0) DoRemove(Array,Answers,List,ByTradeName,FromECode,Cancelled) "RTN","TMGNDF3A",1021,0) ;"Purpose: To remove entries from Empty-class Array "RTN","TMGNDF3A",1022,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1023,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1024,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1025,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1026,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1027,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1028,0) ;" Array should be the one created by ShowEList "RTN","TMGNDF3A",1029,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1030,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1031,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1032,0) ;" Format as follows. "RTN","TMGNDF3A",1033,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1034,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1035,0) ;" ByTradeName -- OPTIONAL, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",1036,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1037,0) ;" code modules (ie HandleEmptyClasses) "RTN","TMGNDF3A",1038,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF3A",1039,0) ;"Results: none "RTN","TMGNDF3A",1040,0) "RTN","TMGNDF3A",1041,0) set ByTradeName=$get(ByTradeName,0) "RTN","TMGNDF3A",1042,0) set Cancelled=1 ;"default is cancellation "RTN","TMGNDF3A",1043,0) "RTN","TMGNDF3A",1044,0) write !,"Remove these drugs perminantly (i.e. don't add to VistA database)?",! "RTN","TMGNDF3A",1045,0) do Disp2List(.Answers,.List,.ByTradeName) "RTN","TMGNDF3A",1046,0) "RTN","TMGNDF3A",1047,0) write "Remove these drugs perminantly (i.e. don't add to VistA database)" "RTN","TMGNDF3A",1048,0) new % set %=1 do YN^DICN write ! "RTN","TMGNDF3A",1049,0) new SetSkipFlag set SetSkipFlag=(%=1) "RTN","TMGNDF3A",1050,0) "RTN","TMGNDF3A",1051,0) if %=2 do "RTN","TMGNDF3A",1052,0) . write "Temporarily remove drugs from category listing" "RTN","TMGNDF3A",1053,0) . do YN^DICN write ! "RTN","TMGNDF3A",1054,0) if %=2 goto DERMDone "RTN","TMGNDF3A",1055,0) "RTN","TMGNDF3A",1056,0) new UndoArray "RTN","TMGNDF3A",1057,0) new DrugIEN,DrugName,TradeName "RTN","TMGNDF3A",1058,0) new i set i=$order(List("")) "RTN","TMGNDF3A",1059,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",1060,0) . set DrugIEN=+$piece($get(Answers(i)),"^",1) "RTN","TMGNDF3A",1061,0) . new UndoCt set UndoCt=$order(UndoArray(i,""),-1)+1 "RTN","TMGNDF3A",1062,0) . if (DrugIEN>0)&(SetSkipFlag) do "RTN","TMGNDF3A",1063,0) . . new OldValue set OldValue=$piece(^TMG(22706.9,DrugIEN,1),"^",4) "RTN","TMGNDF3A",1064,0) . . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",1065,0) . . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",1066,0) . . set UndoArray(i,UndoCt)="set $piece(^TMG(22706.9,"_DrugIEN_",1),""^"",4)="_OldValue "RTN","TMGNDF3A",1067,0) . . set $piece(^TMG(22706.9,DrugIEN,1),"^",4)=1 ;"I own file, and there are no XREF, so OK to direct set. "RTN","TMGNDF3A",1068,0) . if (SetSkipFlag=0)&(FromECode=0) do "RTN","TMGNDF3A",1069,0) . . set UndoArray(i,UndoCt)="kill Array("_DrugIEN_",""?"")" "RTN","TMGNDF3A",1070,0) . . set UndoArray(i,UndoCt+1)="kill Array(""?"","_DrugIEN_")" "RTN","TMGNDF3A",1071,0) . . set Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1072,0) . . set Array("?",DrugIEN)="" "RTN","TMGNDF3A",1073,0) . set i=$order(List(i)) "RTN","TMGNDF3A",1074,0) "RTN","TMGNDF3A",1075,0) do ClrAnswers(.Array,.Answers,.List,.FromECode,.UndoArray) "RTN","TMGNDF3A",1076,0) "RTN","TMGNDF3A",1077,0) new UndoCt set UndoCt=$get(Array("UNDO","COUNT")) "RTN","TMGNDF3A",1078,0) set i="" "RTN","TMGNDF3A",1079,0) for set i=$order(UndoArray(i)) quit:(i="") do "RTN","TMGNDF3A",1080,0) . merge Array("UNDO",UndoCt)=UndoArray(i) "RTN","TMGNDF3A",1081,0) . set UndoCt=UndoCt+1 "RTN","TMGNDF3A",1082,0) set Array("UNDO","COUNT")=UndoCt "RTN","TMGNDF3A",1083,0) "RTN","TMGNDF3A",1084,0) set Cancelled=0 ;"set success here "RTN","TMGNDF3A",1085,0) "RTN","TMGNDF3A",1086,0) DERMDone "RTN","TMGNDF3A",1087,0) quit "RTN","TMGNDF3A",1088,0) "RTN","TMGNDF3A",1089,0) "RTN","TMGNDF3A",1090,0) DoLookup(Array,Answers,Classes,List,FromECode,Cancelled) "RTN","TMGNDF3A",1091,0) ;"Purpose: To Manually lookup class for entries "RTN","TMGNDF3A",1092,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1093,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1094,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1095,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1096,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",1097,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1098,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1099,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1100,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1101,0) ;" Classes -- PASS BY REFERENCE, an array containing classes "RTN","TMGNDF3A",1102,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1103,0) ;" Format as follows. "RTN","TMGNDF3A",1104,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1105,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1106,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1107,0) ;" code modules (ie HandleEmptyClasses) "RTN","TMGNDF3A",1108,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF3A",1109,0) ;"Results: none "RTN","TMGNDF3A",1110,0) "RTN","TMGNDF3A",1111,0) set Cancelled=1 ;"default to cancellation "RTN","TMGNDF3A",1112,0) "RTN","TMGNDF3A",1113,0) new UsrClassIEN "RTN","TMGNDF3A",1114,0) set UsrClassIEN=$$SelectClass(.Classes) "RTN","TMGNDF3A",1115,0) if UsrClassIEN=0 goto DLUDone "RTN","TMGNDF3A",1116,0) "RTN","TMGNDF3A",1117,0) new ClassName set ClassName=$$GET1^DIQ(50.605,UsrClassIEN,1) "RTN","TMGNDF3A",1118,0) "RTN","TMGNDF3A",1119,0) if $$VerifyWrite(ClassName,.Answers,.List)=0 goto DLUDone "RTN","TMGNDF3A",1120,0) "RTN","TMGNDF3A",1121,0) do WriteClass(UsrClassIEN,.Array,.Answers,.List,.FromECode) "RTN","TMGNDF3A",1122,0) set Cancelled=0 ;"set success here "RTN","TMGNDF3A",1123,0) "RTN","TMGNDF3A",1124,0) DLUDone "RTN","TMGNDF3A",1125,0) quit "RTN","TMGNDF3A",1126,0) "RTN","TMGNDF3A",1127,0) "RTN","TMGNDF3A",1128,0) WriteClass(ClassIEN,Array,Answers,List,FromECode) "RTN","TMGNDF3A",1129,0) ;"Purpose: To do the actual setting of the class "RTN","TMGNDF3A",1130,0) ;"Input: ClassIEN -- the IEN of the class to set. "RTN","TMGNDF3A",1131,0) ;" Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1132,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1133,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1134,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1135,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",1136,0) ;" Note: Only needed to clear out entries that are no longer needed. "RTN","TMGNDF3A",1137,0) ;" OR, if FromECode=1, then this Array format is used: "RTN","TMGNDF3A",1138,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1139,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1140,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1141,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1142,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1143,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1144,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1145,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1146,0) ;" OR, if FromECode=1, then this format is used: "RTN","TMGNDF3A",1147,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1148,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1149,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1150,0) ;" Format as follows. "RTN","TMGNDF3A",1151,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1152,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1153,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1154,0) ;" code modules (ie HandleEmptyClasses) "RTN","TMGNDF3A",1155,0) ;"Output: Data will be altered in file 22706.9 "RTN","TMGNDF3A",1156,0) ;" Array will be modified: Undo information will be added: "RTN","TMGNDF3A",1157,0) ;" Array("UNDO","COUNT")=number of undo steps avail "RTN","TMGNDF3A",1158,0) ;" Array("UNDO",Event#,part#)=code to be eXecuted to reverse step. "RTN","TMGNDF3A",1159,0) ;"Results: none "RTN","TMGNDF3A",1160,0) "RTN","TMGNDF3A",1161,0) new DrugIEN,DrugName,ClassName "RTN","TMGNDF3A",1162,0) new UndoArray set UndoArray("")="" "RTN","TMGNDF3A",1163,0) new i set i=$order(List("")) "RTN","TMGNDF3A",1164,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",1165,0) . set DrugIEN=+$piece($get(Answers(i)),"^",1) "RTN","TMGNDF3A",1166,0) . if DrugIEN=0 goto WC1 "RTN","TMGNDF3A",1167,0) . new UndoCt set UndoCt=$order(UndoArray(i,""))+1 "RTN","TMGNDF3A",1168,0) . new OldValue set OldValue=$piece(^TMG(22706.9,DrugIEN,1),"^",5) "RTN","TMGNDF3A",1169,0) . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",1170,0) . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",1171,0) . set UndoArray(i,UndoCt)="set $piece(^TMG(22706.9,"_DrugIEN_",1),""^"",5)="_OldValue "RTN","TMGNDF3A",1172,0) . set $piece(^TMG(22706.9,DrugIEN,1),"^",5)=ClassIEN ;"I own file, and there are no XREF, so OK to direct set. "RTN","TMGNDF3A",1173,0) WC1 . set i=$order(List(i)) "RTN","TMGNDF3A",1174,0) "RTN","TMGNDF3A",1175,0) do ClrAnswers(.Array,.Answers,.List,.FromECode,.UndoArray) "RTN","TMGNDF3A",1176,0) "RTN","TMGNDF3A",1177,0) set i=$order(UndoArray("")) "RTN","TMGNDF3A",1178,0) new UndoCt set UndoCt=$get(Array("UNDO","COUNT")) "RTN","TMGNDF3A",1179,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",1180,0) . merge Array("UNDO",UndoCt)=UndoArray(i) "RTN","TMGNDF3A",1181,0) . set UndoCt=UndoCt+1 "RTN","TMGNDF3A",1182,0) . set i=$order(UndoArray(i)) "RTN","TMGNDF3A",1183,0) set Array("UNDO","COUNT")=UndoCt "RTN","TMGNDF3A",1184,0) "RTN","TMGNDF3A",1185,0) WCDone "RTN","TMGNDF3A",1186,0) quit "RTN","TMGNDF3A",1187,0) "RTN","TMGNDF3A",1188,0) "RTN","TMGNDF3A",1189,0) ClrAnswers(Array,Answers,List,FromECode,UndoArray) "RTN","TMGNDF3A",1190,0) ;"Purpose: To remove entries from Array and Answers array. "RTN","TMGNDF3A",1191,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1192,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1193,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1194,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1195,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",1196,0) ;" Note: Only needed to clear out entries that are no longer needed. "RTN","TMGNDF3A",1197,0) ;" OR, if FromECode=1, then this Array format is used: "RTN","TMGNDF3A",1198,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1199,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1200,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1201,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1202,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1203,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1204,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1205,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1206,0) ;" OR, if FromECode=1, then this format is used: "RTN","TMGNDF3A",1207,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1208,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1209,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1210,0) ;" Format as follows. "RTN","TMGNDF3A",1211,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1212,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1213,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1214,0) ;" code modules (ie HandleEmptyClasses) "RTN","TMGNDF3A",1215,0) ;" UndoArray -- PASS BY REFERENCE -- an array to be filled with undo info "RTN","TMGNDF3A",1216,0) ;" format as follows: "RTN","TMGNDF3A",1217,0) ;" Array(list#,step#)=CodeToBeExecuted "RTN","TMGNDF3A",1218,0) ;" Array(list#,step#)=CodeToBeExecuted "RTN","TMGNDF3A",1219,0) ;"Output: Entries will be removed from list. "RTN","TMGNDF3A",1220,0) "RTN","TMGNDF3A",1221,0) ;"Results: none "RTN","TMGNDF3A",1222,0) "RTN","TMGNDF3A",1223,0) new DrugIEN,DrugName,ClassName "RTN","TMGNDF3A",1224,0) new i "RTN","TMGNDF3A",1225,0) set i=$order(List("")) "RTN","TMGNDF3A",1226,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",1227,0) . set DrugIEN=+$piece($get(Answers(i)),"^",1) "RTN","TMGNDF3A",1228,0) . if DrugIEN=0 goto CA1 "RTN","TMGNDF3A",1229,0) . new UndoCt set UndoCt=$order(UndoArray(i,""))+1 "RTN","TMGNDF3A",1230,0) . if $get(FromECode)=1 do "RTN","TMGNDF3A",1231,0) . . new GenericName,TradeName "RTN","TMGNDF3A",1232,0) . . set GenericName=$piece($get(Answers(i)),"^",2) "RTN","TMGNDF3A",1233,0) . . set TradeName=$piece($get(Answers(i)),"^",3) "RTN","TMGNDF3A",1234,0) . . ;"save info for possible undo in the future "RTN","TMGNDF3A",1235,0) . . new OldValue set OldValue=$get(Array("GENERIC NAME",GenericName,DrugIEN)) "RTN","TMGNDF3A",1236,0) . . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",1237,0) . . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",1238,0) . . set UndoArray(i,UndoCt)="set Array(""GENERIC NAME"","_GenericName_","_DrugIEN_")="_OldValue "RTN","TMGNDF3A",1239,0) . . set UndoCt=UndoCt+1 "RTN","TMGNDF3A",1240,0) . . new OldValue set OldValue=$get(Array("TRADE NAME",TradeName,DrugIEN)) "RTN","TMGNDF3A",1241,0) . . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",1242,0) . . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",1243,0) . . set UndoArray(i,UndoCt)="set Array(""TRADE NAME"","_TradeName_","_DrugIEN_")="_OldValue "RTN","TMGNDF3A",1244,0) . . ;"Now do real removal "RTN","TMGNDF3A",1245,0) . . kill Array("GENERIC NAME",GenericName,DrugIEN) "RTN","TMGNDF3A",1246,0) . . kill Array("TRADE NAME",TradeName,DrugIEN) "RTN","TMGNDF3A",1247,0) . else do "RTN","TMGNDF3A",1248,0) . . set DrugName=$piece($get(Answers(i)),"^",2) "RTN","TMGNDF3A",1249,0) . . set ClassName=$piece($get(Answers(i)),"^",4) "RTN","TMGNDF3A",1250,0) . . new OldValue set OldValue=$get(Array("POSS MATCH",ClassName,DrugName,DrugIEN)) "RTN","TMGNDF3A",1251,0) . . if OldValue="" set OldValue="""""" "RTN","TMGNDF3A",1252,0) . . if +OldValue'=OldValue set OldValue=""""_OldValue_"""" "RTN","TMGNDF3A",1253,0) . . set UndoArray(i,UndoCt)="set Array(""POSS MATCH"","_ClassName_","_DrugName_","_DrugIEN_")="_OldValue "RTN","TMGNDF3A",1254,0) . . kill Array("POSS MATCH",ClassName,DrugName,DrugIEN) "RTN","TMGNDF3A",1255,0) . kill Answers(i) ;"I'm not sure how to undo this part. I think it's regenerated with each display of list "RTN","TMGNDF3A",1256,0) CA1 . set i=$order(List(i)) "RTN","TMGNDF3A",1257,0) "RTN","TMGNDF3A",1258,0) quit "RTN","TMGNDF3A",1259,0) "RTN","TMGNDF3A",1260,0) "RTN","TMGNDF3A",1261,0) VerifyWrite(ClassName,Answers,List,ByTradeName,ShowBoth) "RTN","TMGNDF3A",1262,0) ;"Purpose: To display list of entries and ask user if class set is desired "RTN","TMGNDF3A",1263,0) ;"Input: ClassName -- the name of the VA DRUG CLASS "RTN","TMGNDF3A",1264,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1265,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1266,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1267,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1268,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1269,0) ;" Format as follows. "RTN","TMGNDF3A",1270,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1271,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1272,0) ;" ByTradeName -- OPTIONAL, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",1273,0) ;" ShowBoth -- OPTIONAL, if value=1 then trade name and generic names both shown. "RTN","TMGNDF3A",1274,0) ;"Result: 1 if writing is OK, other 0 "RTN","TMGNDF3A",1275,0) "RTN","TMGNDF3A",1276,0) write !,"DRUG CLASS: ",ClassName,! "RTN","TMGNDF3A",1277,0) write "Use this for drug(s) below?: ",! "RTN","TMGNDF3A",1278,0) do Disp2List(.Answers,.List,.ByTradeName,.ShowBoth) "RTN","TMGNDF3A",1279,0) write "Use DRUG CLASS [",ClassName,"] for drug(s) above" "RTN","TMGNDF3A",1280,0) new % set %=1 do YN^DICN write ! "RTN","TMGNDF3A",1281,0) "RTN","TMGNDF3A",1282,0) quit (%=1) "RTN","TMGNDF3A",1283,0) "RTN","TMGNDF3A",1284,0) "RTN","TMGNDF3A",1285,0) Disp2List(Answers,List,ByTradeName,ShowBoth) "RTN","TMGNDF3A",1286,0) ;"Purpose: An interfact to DisplayList function, to allow easier input. "RTN","TMGNDF3A",1287,0) ;"Input: Answers -- PASS BY REFERENCE, an array linking display number to IENS. See DisplayList "RTN","TMGNDF3A",1288,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. See DisplayList "RTN","TMGNDF3A",1289,0) ;" ByTradeName -- OPTIONAL, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",1290,0) ;" ShowBoth -- OPTIONAL, if value=1 then trade name and generic names both shown. "RTN","TMGNDF3A",1291,0) "RTN","TMGNDF3A",1292,0) set ByTradeName=$get(ByTradeName,0) "RTN","TMGNDF3A",1293,0) set ShowBoth=$get(ShowBoth,0) "RTN","TMGNDF3A",1294,0) new part,alsoPart "RTN","TMGNDF3A",1295,0) set alsoPart=0 "RTN","TMGNDF3A",1296,0) "RTN","TMGNDF3A",1297,0) if ByTradeName=1 do "RTN","TMGNDF3A",1298,0) . set part=3 ;"i.e. show TradeName "RTN","TMGNDF3A",1299,0) . if ShowBoth set alsoPart=2 "RTN","TMGNDF3A",1300,0) else do "RTN","TMGNDF3A",1301,0) . set part=2 ;"i.e. show GenericName "RTN","TMGNDF3A",1302,0) . if ShowBoth set alsoPart=3 "RTN","TMGNDF3A",1303,0) "RTN","TMGNDF3A",1304,0) do DisplayList(.Answers,.List,part,alsoPart) "RTN","TMGNDF3A",1305,0) "RTN","TMGNDF3A",1306,0) quit "RTN","TMGNDF3A",1307,0) "RTN","TMGNDF3A",1308,0) DisplayList(Answers,List,Piece,AlsoPiece) "RTN","TMGNDF3A",1309,0) ;"Purpose: To display list of entries "RTN","TMGNDF3A",1310,0) ;"Input: Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1311,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1312,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1313,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1314,0) ;" OR, Array as created by ShowEList "RTN","TMGNDF3A",1315,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1316,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1317,0) "RTN","TMGNDF3A",1318,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1319,0) ;" Format as follows. "RTN","TMGNDF3A",1320,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1321,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1322,0) ;" Piece -- OPTIONAL, default=2. The piece number of Answer value to show. "RTN","TMGNDF3A",1323,0) ;" AlsoPiece -- OPTIONAL, default="", If specified, then this piece of the Answer "RTN","TMGNDF3A",1324,0) ;" will also be shown in paretheses under the original answer. "RTN","TMGNDF3A",1325,0) ;"Result: none "RTN","TMGNDF3A",1326,0) "RTN","TMGNDF3A",1327,0) new someShown set someShown=0 "RTN","TMGNDF3A",1328,0) set Piece=$get(Piece,2) "RTN","TMGNDF3A",1329,0) new i "RTN","TMGNDF3A",1330,0) set i=$order(List("")) "RTN","TMGNDF3A",1331,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",1332,0) . write " ",i,". ",$piece($get(Answers(i)),"^",Piece),! "RTN","TMGNDF3A",1333,0) . set someShown=1 "RTN","TMGNDF3A",1334,0) . if +$get(AlsoPiece)>0 do "RTN","TMGNDF3A",1335,0) . . write " (",$piece($get(Answers(i)),"^",AlsoPiece),")",! "RTN","TMGNDF3A",1336,0) . set i=$order(List(i)) "RTN","TMGNDF3A",1337,0) "RTN","TMGNDF3A",1338,0) if someShown=0 write " -- List is EMPTY -- ",! "RTN","TMGNDF3A",1339,0) write "--------------------------------------",! "RTN","TMGNDF3A",1340,0) quit "RTN","TMGNDF3A",1341,0) "RTN","TMGNDF3A",1342,0) "RTN","TMGNDF3A",1343,0) SimilarPick(Array,Answers,List,FromECode,Cancelled) "RTN","TMGNDF3A",1344,0) ;"Purpose: To allow user to specify that a set of numbers should use the same class as "RTN","TMGNDF3A",1345,0) ;" another entry. "RTN","TMGNDF3A",1346,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1347,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1348,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1349,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1350,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",1351,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1352,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1353,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1354,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1355,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1356,0) ;" Format as follows. "RTN","TMGNDF3A",1357,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1358,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1359,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1360,0) ;" code modules (ie HandleEmptyClasses) "RTN","TMGNDF3A",1361,0) ;"Results: none "RTN","TMGNDF3A",1362,0) "RTN","TMGNDF3A",1363,0) set Cancelled=1 ;"default to cancellation "RTN","TMGNDF3A",1364,0) "RTN","TMGNDF3A",1365,0) new input "RTN","TMGNDF3A",1366,0) read "Which entry has the CORRECT CLASS? ",input:$get(DTIME,3600),! "RTN","TMGNDF3A",1367,0) if +input'=input goto SPDone "RTN","TMGNDF3A",1368,0) "RTN","TMGNDF3A",1369,0) new SimClName set SimClName=$piece($get(Answers(input)),"^",4) "RTN","TMGNDF3A",1370,0) new SimClIEN set SimClIEN=+$piece($get(Answers(input)),"^",3) "RTN","TMGNDF3A",1371,0) "RTN","TMGNDF3A",1372,0) if $$VerifyWrite(SimClName,.Answers,.List)=1 goto SPDone "RTN","TMGNDF3A",1373,0) do WriteClass(SimClIEN,.Array,.Answers,.List,.FromECode) "RTN","TMGNDF3A",1374,0) set Cancelled=0 ;"signal success "RTN","TMGNDF3A",1375,0) "RTN","TMGNDF3A",1376,0) SPDone "RTN","TMGNDF3A",1377,0) quit "RTN","TMGNDF3A",1378,0) "RTN","TMGNDF3A",1379,0) "RTN","TMGNDF3A",1380,0) "RTN","TMGNDF3A",1381,0) FindPick(Array,Answers,List,FromECode,Cancelled) "RTN","TMGNDF3A",1382,0) ;"Purpose: To allow user to look up a drug already in the VistA database, and use the "RTN","TMGNDF3A",1383,0) ;" VA DRUG CLASS assigned to that drug. "RTN","TMGNDF3A",1384,0) ;" another entry. "RTN","TMGNDF3A",1385,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1386,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1387,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode^DrugDose "RTN","TMGNDF3A",1388,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1389,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",1390,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1391,0) ;" Array should be the one created by ShowList "RTN","TMGNDF3A",1392,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1393,0) ;" Answer(num)=DrugIEN^DrugName^ClassIEN^ClassName "RTN","TMGNDF3A",1394,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1395,0) ;" Format as follows. "RTN","TMGNDF3A",1396,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1397,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1398,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1399,0) ;" code modules (ie HandleEmptyClasses) "RTN","TMGNDF3A",1400,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF3A",1401,0) ;"Results: none "RTN","TMGNDF3A",1402,0) "RTN","TMGNDF3A",1403,0) set Cancelled=1 ;"default is cancellation "RTN","TMGNDF3A",1404,0) write "Classify drug by finding ANOTHER drug in the SAME CLASS",! "RTN","TMGNDF3A",1405,0) FPLoop "RTN","TMGNDF3A",1406,0) new DIC,X,Y "RTN","TMGNDF3A",1407,0) set DIC=50.68 "RTN","TMGNDF3A",1408,0) set DIC(0)="AEQM" "RTN","TMGNDF3A",1409,0) set DIC("A")="Enter DRUG NAME OF EXAMPLE with desired CLASS// " "RTN","TMGNDF3A",1410,0) do ^DIC write ! "RTN","TMGNDF3A",1411,0) if +Y'>0 do goto FPDone "RTN","TMGNDF3A",1412,0) . write "No usable value found.",! "RTN","TMGNDF3A",1413,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF3A",1414,0) "RTN","TMGNDF3A",1415,0) new SimClName,SimClIEN "RTN","TMGNDF3A",1416,0) set SimClIEN=$$GET1^DIQ(50.68,+Y,15,"I") ;"50.68=VA PRODUCT file "RTN","TMGNDF3A",1417,0) if SimClIEN'>0 do goto FPDone "RTN","TMGNDF3A",1418,0) . write "No usable value found.",! "RTN","TMGNDF3A",1419,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF3A",1420,0) set SimClName=$$GET1^DIQ(50.605,SimClIEN,1) ;"50.605 is VA DRUG CLASS "RTN","TMGNDF3A",1421,0) "RTN","TMGNDF3A",1422,0) new IsOK set IsOK=$$VerifyWrite(SimClName,.Answers,.List) "RTN","TMGNDF3A",1423,0) new TryAgain set TryAgain=0 "RTN","TMGNDF3A",1424,0) if IsOK=1 do "RTN","TMGNDF3A",1425,0) . do WriteClass(SimClIEN,.Array,.Answers,.List,.FromECode) "RTN","TMGNDF3A",1426,0) . set Cancelled=0 ;"set success here "RTN","TMGNDF3A",1427,0) else do "RTN","TMGNDF3A",1428,0) . write "Pick another DRUG CLASS" "RTN","TMGNDF3A",1429,0) . new % set %=1 do YN^DICN write ! "RTN","TMGNDF3A",1430,0) . set TryAgain=(%=1) "RTN","TMGNDF3A",1431,0) if TryAgain=1 goto FPLoop "RTN","TMGNDF3A",1432,0) "RTN","TMGNDF3A",1433,0) FPDone "RTN","TMGNDF3A",1434,0) quit "RTN","TMGNDF3A",1435,0) "RTN","TMGNDF3A",1436,0) ;"======================================================================= "RTN","TMGNDF3A",1437,0) ;"======================================================================= "RTN","TMGNDF3A",1438,0) "RTN","TMGNDF3A",1439,0) HandleEmptyClasses "RTN","TMGNDF3A",1440,0) ;"Purpose: To allow classification of all unclassified drugs (ones with not potential "RTN","TMGNDF3A",1441,0) ;" match found in VistA database as a starting point) "RTN","TMGNDF3A",1442,0) "RTN","TMGNDF3A",1443,0) new array "RTN","TMGNDF3A",1444,0) write "Gathering information...",! "RTN","TMGNDF3A",1445,0) do GatherEmpties(.array) "RTN","TMGNDF3A",1446,0) do ClassEClasses(.array) "RTN","TMGNDF3A",1447,0) "RTN","TMGNDF3A",1448,0) quit "RTN","TMGNDF3A",1449,0) "RTN","TMGNDF3A",1450,0) "RTN","TMGNDF3A",1451,0) "RTN","TMGNDF3A",1452,0) GatherEmpties(Array) "RTN","TMGNDF3A",1453,0) ;"Purpose: To scan through all records in TMG FDA IMPORT COMPILED, and create an array of "RTN","TMGNDF3A",1454,0) ;" possible entries for VA DRUG CLASS, from ones that have NO possible VA PRODUCT MATCH "RTN","TMGNDF3A",1455,0) ;"Input: Array -- PASS BY REFERENCE, and OUT PARAMETER "RTN","TMGNDF3A",1456,0) ;"Output: Array will be filled as follows: "RTN","TMGNDF3A",1457,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1458,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1459,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1460,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1461,0) ;"Results: none "RTN","TMGNDF3A",1462,0) ;"Note: if SKIP THIS RECORD field is set, then record will be skipped. "RTN","TMGNDF3A",1463,0) ;" Also, if there is already an antry for the VA DRUG CLASS field, then will be skipped. "RTN","TMGNDF3A",1464,0) "RTN","TMGNDF3A",1465,0) new Itr,IEN "RTN","TMGNDF3A",1466,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3A",1467,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3A",1468,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGNDF3A",1469,0) . new tempIEN set IEN=IEN "RTN","TMGNDF3A",1470,0) . new skipFlag set skipFlag=+$piece($get(^TMG(22706.9,IEN,1)),"^",4) "RTN","TMGNDF3A",1471,0) . new PriorClass set PriorClass=+$piece($get(^TMG(22706.9,IEN,1)),"^",5) "RTN","TMGNDF3A",1472,0) . ;"write IEN," --> ",PriorClass,! "RTN","TMGNDF3A",1473,0) . if skipFlag=1 quit "RTN","TMGNDF3A",1474,0) . if PriorClass>0 quit "RTN","TMGNDF3A",1475,0) . new TMGGeneric set TMGGeneric=$piece($get(^TMG(22706.9,IEN,0)),"^",6) ;"GENERIC NAME "RTN","TMGNDF3A",1476,0) . new TradeName set TradeName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"TRADENAME "RTN","TMGNDF3A",1477,0) . if TMGGeneric'="" set Array("GENERIC NAME",TMGGeneric,IEN)="" "RTN","TMGNDF3A",1478,0) . if TradeName'="" set Array("TRADE NAME",TradeName,IEN)="" "RTN","TMGNDF3A",1479,0) . if (TMGGeneric'="")&(TradeName'="") do "RTN","TMGNDF3A",1480,0) . . set Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1481,0) . . set Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1482,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3A",1483,0) "RTN","TMGNDF3A",1484,0) quit "RTN","TMGNDF3A",1485,0) "RTN","TMGNDF3A",1486,0) ShowEList(Array,Answers,CompactMode,ByTradeName,ShowBoth) "RTN","TMGNDF3A",1487,0) ;"Purpose: To display the list of 'Empty' classes generated by GatherEmpties "RTN","TMGNDF3A",1488,0) ;"Input: Array -- the array containing the data "RTN","TMGNDF3A",1489,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1490,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1491,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1492,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1493,0) ;" Answers -- PASS BY REFERENCE. An OUT PARAMATER. "RTN","TMGNDF3A",1494,0) ;" Array will receive display numbers with IENs "RTN","TMGNDF3A",1495,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1496,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1497,0) ;" CompactMode -- OPTIONAL, if value=1, then only the LAST drug class will be "RTN","TMGNDF3A",1498,0) ;" expanded (a potientially long list). Others will just show heading. "RTN","TMGNDF3A",1499,0) ;" ByTradeName -- OPTIONAL, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",1500,0) ;" ShowBoth -- OPTIONAL, if value=1 then both Generic and TradeName shown. "RTN","TMGNDF3A",1501,0) ;"Output: List is shown, and the Answers array is established and passed back. "RTN","TMGNDF3A",1502,0) ;"Results: none. "RTN","TMGNDF3A",1503,0) "RTN","TMGNDF3A",1504,0) new someShown set someShown=0 "RTN","TMGNDF3A",1505,0) new count set count=1 "RTN","TMGNDF3A",1506,0) kill Answers "RTN","TMGNDF3A",1507,0) set CompactMode=$get(CompactMode,0) "RTN","TMGNDF3A",1508,0) set ByTradeName=$get(ByTradeName,0) "RTN","TMGNDF3A",1509,0) set ShowBoth=$get(ShowBoth,0) "RTN","TMGNDF3A",1510,0) new IEN "RTN","TMGNDF3A",1511,0) new GenericName,TradeName,DrugName "RTN","TMGNDF3A",1512,0) new CountLimit set CountLimit=99999 "RTN","TMGNDF3A",1513,0) if CompactMode=1 do "RTN","TMGNDF3A",1514,0) . if ShowBoth=1 set CountLimit=8 "RTN","TMGNDF3A",1515,0) . else set CountLimit=10 "RTN","TMGNDF3A",1516,0) new Label set Label="GENERIC NAME" "RTN","TMGNDF3A",1517,0) if ByTradeName=1 set Label="TRADE NAME" "RTN","TMGNDF3A",1518,0) "RTN","TMGNDF3A",1519,0) set DrugName=$order(Array(Label,"")) "RTN","TMGNDF3A",1520,0) if DrugName'="" for do quit:(DrugName="")!(count>CountLimit) "RTN","TMGNDF3A",1521,0) . set IEN=$order(Array(Label,DrugName,"")) "RTN","TMGNDF3A",1522,0) . if IEN'="" for do quit:(IEN="")!(count>CountLimit) "RTN","TMGNDF3A",1523,0) . . write count,". ",DrugName,! "RTN","TMGNDF3A",1524,0) . . new OtherName "RTN","TMGNDF3A",1525,0) . . if ByTradeName=0 do "RTN","TMGNDF3A",1526,0) . . . set GenericName=DrugName "RTN","TMGNDF3A",1527,0) . . . set TradeName=$get(Array("LINK GENERIC TO TRADE",GenericName)) "RTN","TMGNDF3A",1528,0) . . . set OtherName=TradeName "RTN","TMGNDF3A",1529,0) . . else do "RTN","TMGNDF3A",1530,0) . . . set TradeName=DrugName "RTN","TMGNDF3A",1531,0) . . . set GenericName=$get(Array("LINK TRADE TO GENERIC",TradeName)) "RTN","TMGNDF3A",1532,0) . . . set OtherName=GenericName "RTN","TMGNDF3A",1533,0) . . if ShowBoth=1 write " (",OtherName,")",! "RTN","TMGNDF3A",1534,0) . . set Answers(count)=IEN_"^"_GenericName_"^"_TradeName "RTN","TMGNDF3A",1535,0) . . set count=count+1 "RTN","TMGNDF3A",1536,0) . . set IEN=$order(Array(Label,DrugName,IEN)) "RTN","TMGNDF3A",1537,0) . set DrugName=$order(Array(Label,DrugName)) "RTN","TMGNDF3A",1538,0) . set someShown=1 "RTN","TMGNDF3A",1539,0) "RTN","TMGNDF3A",1540,0) if 'someShown write " --- (List is Empty) ---",! "RTN","TMGNDF3A",1541,0) quit "RTN","TMGNDF3A",1542,0) "RTN","TMGNDF3A",1543,0) "RTN","TMGNDF3A",1544,0) "RTN","TMGNDF3A",1545,0) ClassEClasses(Array) "RTN","TMGNDF3A",1546,0) ;"Purpose: To allow user to classify drugs with empty (none) VA Drug Class "RTN","TMGNDF3A",1547,0) ;"Input: Array -- PASS BY REFERENCE the array generated by GatherEmpties "RTN","TMGNDF3A",1548,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1549,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1550,0) ;"Output: Database is changed, by adding data to field .09 (VA DRUG CLASS) "RTN","TMGNDF3A",1551,0) ;"Results: none "RTN","TMGNDF3A",1552,0) "RTN","TMGNDF3A",1553,0) new done set done=0 "RTN","TMGNDF3A",1554,0) new input set input="R" "RTN","TMGNDF3A",1555,0) new Answers "RTN","TMGNDF3A",1556,0) new CompactMode set CompactMode=1 ;" (list display mode: 1=compact, 0=verb "RTN","TMGNDF3A",1557,0) new ShowBoth set ShowBoth=0 "RTN","TMGNDF3A",1558,0) new ByTrade set ByTrade=1 "RTN","TMGNDF3A",1559,0) new EntryList,EntryS "RTN","TMGNDF3A",1560,0) "RTN","TMGNDF3A",1561,0) new Classes "RTN","TMGNDF3A",1562,0) do GetClasses(.Classes) "RTN","TMGNDF3A",1563,0) do KillIntro(.Classes) "RTN","TMGNDF3A",1564,0) "RTN","TMGNDF3A",1565,0) for do quit:(done=1) "RTN","TMGNDF3A",1566,0) . if input="R" do "RTN","TMGNDF3A",1567,0) . . write !! "RTN","TMGNDF3A",1568,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",1569,0) . . write "Pick drug(s) to specify a DRUG CLASS",! "RTN","TMGNDF3A",1570,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",1571,0) . . do ShowEList(.Array,.Answers,CompactMode,ByTrade,ShowBoth) "RTN","TMGNDF3A",1572,0) . . write "--------------------------------------------------",! "RTN","TMGNDF3A",1573,0) . . write "Pick drug(s) to specify a DRUG CLASS",! "RTN","TMGNDF3A",1574,0) . write "--------------------------------------------------",! "RTN","TMGNDF3A",1575,0) . write " R=refresh, ?=instructions, X=remove from list, I=info, F=find",! "RTN","TMGNDF3A",1576,0) . write " G=Guess, L Lookup",! "RTN","TMGNDF3A",1577,0) . write " C=set Compact ",$select((CompactMode=1):"OFF",1:"ON"),", " "RTN","TMGNDF3A",1578,0) . write "T=set TradeName ",$select((ByTrade=1):"OFF",1:"ON"),", B=set Both names ",$select((ShowBoth=1):"OFF",1:"ON") "RTN","TMGNDF3A",1579,0) . write ", ",! "RTN","TMGNDF3A",1580,0) . write " # or #-# or #,#-#,# etc., S=SET tools, ^ done, ",! "RTN","TMGNDF3A",1581,0) . if $get(EntryS)'="" write " Current SET #'s: ",EntryS,", D to delete SET",! "RTN","TMGNDF3A",1582,0) . write "Enter number(s) to LOOKUP drug class (or codes listed above): R//" "RTN","TMGNDF3A",1583,0) . read input:$get(DTIME,3600),! "RTN","TMGNDF3A",1584,0) . if input="" set input="R" "RTN","TMGNDF3A",1585,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF3A",1586,0) . if input="^" set done=1 quit "RTN","TMGNDF3A",1587,0) . else if (input="?") do ;"---- instructions "RTN","TMGNDF3A",1588,0) . . ;"do ShowInstructions() "RTN","TMGNDF3A",1589,0) . . set input="R" "RTN","TMGNDF3A",1590,0) . else if input="I" do ;" ---- drug info "RTN","TMGNDF3A",1591,0) . . read "...Enter number of drug to get info about: ^//",input,! "RTN","TMGNDF3A",1592,0) . . do ShowInfo(.Array,.Answers,+input) "RTN","TMGNDF3A",1593,0) . . set input="R" "RTN","TMGNDF3A",1594,0) . else if input="C" do ;"--- toggle compact mode "RTN","TMGNDF3A",1595,0) . . set CompactMode='CompactMode "RTN","TMGNDF3A",1596,0) . . set input="R" "RTN","TMGNDF3A",1597,0) . else if input="T" do ;"---- toggle display by tradename "RTN","TMGNDF3A",1598,0) . . set ByTrade='ByTrade "RTN","TMGNDF3A",1599,0) . . set input="R" "RTN","TMGNDF3A",1600,0) . else if input="B" do ;" ---- toggle display of both names. "RTN","TMGNDF3A",1601,0) . . set ShowBoth='ShowBoth "RTN","TMGNDF3A",1602,0) . . set input="R" "RTN","TMGNDF3A",1603,0) . else if input="D" do ;"---- delete set "RTN","TMGNDF3A",1604,0) . . kill EntryList,EntryS "RTN","TMGNDF3A",1605,0) . . set input="R" "RTN","TMGNDF3A",1606,0) . else if input="X" do ;" ---- delete entries "RTN","TMGNDF3A",1607,0) . . new valid set valid=1 "RTN","TMGNDF3A",1608,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF3A",1609,0) . . . read "...Enter number(s) to REMOVE from list: ^// ",input,! "RTN","TMGNDF3A",1610,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF3A",1611,0) . . . if valid set EntryS=input "RTN","TMGNDF3A",1612,0) . . if CompactMode=1 set input="R" "RTN","TMGNDF3A",1613,0) . . new Cancelled "RTN","TMGNDF3A",1614,0) . . do DoRemove(.Array,.Answers,.EntryList,ByTrade,1,.Cancelled) "RTN","TMGNDF3A",1615,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF3A",1616,0) . else if input="S" do ;"---- set tools "RTN","TMGNDF3A",1617,0) . . do DoSetTools(.Array,.Answers,.EntryList,.EntryS,.ByTrade,.ShowBoth) "RTN","TMGNDF3A",1618,0) . . if CompactMode=1 set input="R" "RTN","TMGNDF3A",1619,0) . else if input="F" do ;" ---- find drugs "RTN","TMGNDF3A",1620,0) . . new valid set valid=1 "RTN","TMGNDF3A",1621,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF3A",1622,0) EFL . . . read "...Enter number(s) to classify by FINDING a similar drug: (? help) ^// ",input,! "RTN","TMGNDF3A",1623,0) . . . if input="?" do FindHelp() goto EFL "RTN","TMGNDF3A",1624,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF3A",1625,0) . . . if valid set EntryS=input "RTN","TMGNDF3A",1626,0) . . if CompactMode=1 set input="R" "RTN","TMGNDF3A",1627,0) . . new Cancelled "RTN","TMGNDF3A",1628,0) . . do FindPick(.Array,.Answers,.EntryList,1,.Cancelled) "RTN","TMGNDF3A",1629,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF3A",1630,0) . else if (input="L")!(+input>0) do ;" ----- lookup drugs "RTN","TMGNDF3A",1631,0) . . new valid set valid=1 "RTN","TMGNDF3A",1632,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF3A",1633,0) . . . if input="L" read "...Enter number(s) to LOOKUP from list: ^// ",input,! "RTN","TMGNDF3A",1634,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF3A",1635,0) . . . if valid set EntryS=input "RTN","TMGNDF3A",1636,0) . . if CompactMode=1 set input="R" "RTN","TMGNDF3A",1637,0) . . new Cancelled "RTN","TMGNDF3A",1638,0) . . do DoLookup(.Array,.Answers,.Classes,.EntryList,1,.Cancelled) "RTN","TMGNDF3A",1639,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF3A",1640,0) . else if input="G" do ;" ---- guess drugs "RTN","TMGNDF3A",1641,0) . . new valid set valid=1 "RTN","TMGNDF3A",1642,0) . . if $get(EntryS)="" do quit:(valid=0) "RTN","TMGNDF3A",1643,0) EGL . . . read "...Enter number(s) to classify by GUESSING: (? help) ^// ",input,! "RTN","TMGNDF3A",1644,0) . . . if input="?" do FindHelp() goto EFL "RTN","TMGNDF3A",1645,0) . . . set valid=$$MkMultList^TMGMISC(input,.EntryList) "RTN","TMGNDF3A",1646,0) . . . if valid set EntryS=input "RTN","TMGNDF3A",1647,0) . . if CompactMode=1 set input="R" "RTN","TMGNDF3A",1648,0) . . new Cancelled "RTN","TMGNDF3A",1649,0) . . do DoEGuess(.Array,.Answers,.EntryList,ByTrade,ShowBoth,.Cancelled,1,.Classes) "RTN","TMGNDF3A",1650,0) . . if Cancelled=0 kill EntryList,EntryS "RTN","TMGNDF3A",1651,0) . else if input'="R" do ;"---- accept numeric input etc. "RTN","TMGNDF3A",1652,0) . . if $$MkMultList^TMGMISC(input,.EntryList)=0 quit "RTN","TMGNDF3A",1653,0) . . set EntryS=input "RTN","TMGNDF3A",1654,0) . . if CompactMode=1 set input="R" "RTN","TMGNDF3A",1655,0) "RTN","TMGNDF3A",1656,0) quit "RTN","TMGNDF3A",1657,0) "RTN","TMGNDF3A",1658,0) "RTN","TMGNDF3A",1659,0) DoGuess(Array,Answers,EntryList,Cancelled,Classes) "RTN","TMGNDF3A",1660,0) ;"Purpose: A wrapper for DoEGuess, with some automatically provided paremeters "RTN","TMGNDF3A",1661,0) do DoEGuess(.Array,.Answers,.EntryList,0,0,.Cancelled,0,.Classes) "RTN","TMGNDF3A",1662,0) quit "RTN","TMGNDF3A",1663,0) "RTN","TMGNDF3A",1664,0) DoEGuess(Array,Answers,List,ByTradeName,ShowBoth,Cancelled,FromECode,Classes) "RTN","TMGNDF3A",1665,0) ;"Purpose: To guess as classification for entries. "RTN","TMGNDF3A",1666,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by GatherEmpties(Array) "RTN","TMGNDF3A",1667,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1668,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1669,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1670,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1671,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1672,0) ;" Array should be the one created by ShowEList "RTN","TMGNDF3A",1673,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1674,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1675,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1676,0) ;" Format as follows. "RTN","TMGNDF3A",1677,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1678,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1679,0) ;" ByTradeName -- OPTIONAL, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",1680,0) ;" ShowBoth -- OPTIONAL, if value=1 then trade name and generic names both shown. "RTN","TMGNDF3A",1681,0) ;" Cancelled -- OPTIONAL, PASS BY REFERENCE, will be set to 1 if user cancelled. "RTN","TMGNDF3A",1682,0) ;" FromECode -- OPTIONAL, if value=1, then code is handled as if called from the 'empty' "RTN","TMGNDF3A",1683,0) ;" code modules (ie HandleEmptyClasses). Default=0 "RTN","TMGNDF3A",1684,0) ;" Classes -- PASS BY REFERENCE -- An array holding classes. "RTN","TMGNDF3A",1685,0) ;"Results: none "RTN","TMGNDF3A",1686,0) "RTN","TMGNDF3A",1687,0) set FromECode=$get(FromECode,0) "RTN","TMGNDF3A",1688,0) set Cancelled=1 ;"default to cancellation "RTN","TMGNDF3A",1689,0) "RTN","TMGNDF3A",1690,0) new Results "RTN","TMGNDF3A",1691,0) write "Searching for guesses...",$char(10) "RTN","TMGNDF3A",1692,0) "RTN","TMGNDF3A",1693,0) do GGuessList(.Array,.Answers,.List,.Results) "RTN","TMGNDF3A",1694,0) ;" Results(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1695,0) ;" Results(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1696,0) ;" Results(Entry Number,"CLASS",ClassIEN,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1697,0) ;" Results(Entry Number,"CLASS",ClassIEN,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1698,0) ;" Results("ALL CLASSES",ClassIEN)=ClassIEN_"^"_ClassCode_"^"_ClassName "RTN","TMGNDF3A",1699,0) ;" Results("ALL CLASSES",ClassIEN,matchName,vapIEN)="" "RTN","TMGNDF3A",1700,0) "RTN","TMGNDF3A",1701,0) new showExamples set showExamples=1 "RTN","TMGNDF3A",1702,0) "RTN","TMGNDF3A",1703,0) DEGL0 write !,"GUESSES of class for these drugs: ",! "RTN","TMGNDF3A",1704,0) do Disp2List(.Answers,.List,.ByTradeName,.ShowBoth) "RTN","TMGNDF3A",1705,0) "RTN","TMGNDF3A",1706,0) new subAnswers "RTN","TMGNDF3A",1707,0) new someShown set someShown=0 "RTN","TMGNDF3A",1708,0) new count set count=0 "RTN","TMGNDF3A",1709,0) new classIEN set classIEN="" "RTN","TMGNDF3A",1710,0) for set classIEN=+$order(Results("ALL CLASSES",classIEN)) quit:(classIEN'>0) do "RTN","TMGNDF3A",1711,0) . set count=count+1 "RTN","TMGNDF3A",1712,0) . new node set node=$get(Results("ALL CLASSES",classIEN)) "RTN","TMGNDF3A",1713,0) . write " ",count,". CLASS: ",$piece(node,"^",3),! "RTN","TMGNDF3A",1714,0) . set someShown=1 "RTN","TMGNDF3A",1715,0) . set subAnswers(count)=node "RTN","TMGNDF3A",1716,0) . new matchName set matchName="" "RTN","TMGNDF3A",1717,0) . new temp set temp=0 "RTN","TMGNDF3A",1718,0) . for set matchName=$order(Results("ALL CLASSES",classIEN,matchName)) quit:(matchName="")!(temp>5) do "RTN","TMGNDF3A",1719,0) . . new vapIEN set vapIEN="" "RTN","TMGNDF3A",1720,0) . . for set vapIEN=+$order(Results("ALL CLASSES",classIEN,matchName,vapIEN)) quit:(vapIEN'>0)!(temp>5) do "RTN","TMGNDF3A",1721,0) . . . if showExamples=0 quit "RTN","TMGNDF3A",1722,0) . . . write " e.g. ",matchName," (",vapIEN,")",! "RTN","TMGNDF3A",1723,0) . . . set temp=temp+1 "RTN","TMGNDF3A",1724,0) "RTN","TMGNDF3A",1725,0) if someShown=0 do goto DEGDone "RTN","TMGNDF3A",1726,0) . write " -- (None Suggestions found) -- ",!! "RTN","TMGNDF3A",1727,0) . new temp read "Press ENTER to continue.",temp,! "RTN","TMGNDF3A",1728,0) "RTN","TMGNDF3A",1729,0) new input,UsrClassIEN,className "RTN","TMGNDF3A",1730,0) new defInput set defInput="^" "RTN","TMGNDF3A",1731,0) if count=1 set defInput=1 "RTN","TMGNDF3A",1732,0) new fixing "RTN","TMGNDF3A",1733,0) DEGL1 "RTN","TMGNDF3A",1734,0) set fixing=0 "RTN","TMGNDF3A",1735,0) write "[Enter F to fix (change) the class of a drug listed above.]",! "RTN","TMGNDF3A",1736,0) write "[Enter E to toggle Examples ON/OFF]",! "RTN","TMGNDF3A",1737,0) write "Enter number of CLASS to select (^ to abort): "_defInput_"// " "RTN","TMGNDF3A",1738,0) read input:$get(DTIME,3600),! "RTN","TMGNDF3A",1739,0) if input="" set input=defInput "RTN","TMGNDF3A",1740,0) set input=$$UP^XLFSTR(input) "RTN","TMGNDF3A",1741,0) if input="^" goto DEGDone "RTN","TMGNDF3A",1742,0) if input="E" do goto DEGL0 "RTN","TMGNDF3A",1743,0) . set showExamples='showExamples "RTN","TMGNDF3A",1744,0) if input="F" do goto:(input="^") DEGL1 "RTN","TMGNDF3A",1745,0) . set fixing=1 "RTN","TMGNDF3A",1746,0) . write !,"Enter number of CLASS containing erroneously classified drug (^ to abort): "_defInput_"// " "RTN","TMGNDF3A",1747,0) . read input:$get(DTIME,3600) write ! "RTN","TMGNDF3A",1748,0) . if input="" set input=defInput "RTN","TMGNDF3A",1749,0) set UsrClassIEN=+$get(subAnswers(input)) "RTN","TMGNDF3A",1750,0) if UsrClassIEN'>0 goto DEGL1 "RTN","TMGNDF3A",1751,0) if fixing=1 do goto DEGL0 "RTN","TMGNDF3A",1752,0) . do FixBadClass(.Results,UsrClassIEN,.Classes) "RTN","TMGNDF3A",1753,0) set className=$piece($get(subAnswers(input)),"^",3) "RTN","TMGNDF3A",1754,0) write !! "RTN","TMGNDF3A",1755,0) if $$VerifyWrite(className,.Answers,.List,ByTradeName,ShowBoth)=0 goto DEGDone "RTN","TMGNDF3A",1756,0) do WriteClass(UsrClassIEN,.Array,.Answers,.List,FromECode) "RTN","TMGNDF3A",1757,0) set Cancelled=0 ;"set success here. "RTN","TMGNDF3A",1758,0) DEGDone "RTN","TMGNDF3A",1759,0) quit "RTN","TMGNDF3A",1760,0) "RTN","TMGNDF3A",1761,0) "RTN","TMGNDF3A",1762,0) FixBadClass(GuessArray,UsrClassIEN,Classes) "RTN","TMGNDF3A",1763,0) ;"Purpose: If guessing reveals that an existing drug has been misclassified, then "RTN","TMGNDF3A",1764,0) ;" this function will allow correction of that drug (50.68 entry) "RTN","TMGNDF3A",1765,0) ;"Input: GuessArray -- PASS BY REFERENCE. Format: "RTN","TMGNDF3A",1766,0) ;" GuessArray(Entry Number,"NAME",VASimilarDrugName)=ClassIEN^ClassCode^ClassName^vapIEN "RTN","TMGNDF3A",1767,0) ;" GuessArray(Entry Number,"CLASS",ClassIEN)=ClassIEN^ClassCode^ClassName "RTN","TMGNDF3A",1768,0) ;" GuessArray("ALL CLASSES",classIEN)=classIEN_"^"_classCode_"^"_className "RTN","TMGNDF3A",1769,0) ;" GuessArray("ALL CLASSES",classIEN,matchName)=vapIEN "RTN","TMGNDF3A",1770,0) "RTN","TMGNDF3A",1771,0) ;" GuessArray(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1772,0) ;" GuessArray(Entry Number,"CLASS",ClassIEN,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1773,0) ;" GuessArray("ALL CLASSES",ClassIEN)=ClassIEN_"^"_ClassCode_"^"_ClassName "RTN","TMGNDF3A",1774,0) ;" GuessArray("ALL CLASSES",ClassIEN,matchName,vapIEN)="" "RTN","TMGNDF3A",1775,0) "RTN","TMGNDF3A",1776,0) "RTN","TMGNDF3A",1777,0) ;" UsrClassIEN -- The class containing the incorrectly classified drug "RTN","TMGNDF3A",1778,0) ;" Classes -- PASS BY REFERENCE. An array holding classes. "RTN","TMGNDF3A",1779,0) "RTN","TMGNDF3A",1780,0) if $get(UsrClassIEN)="" goto FBCDone "RTN","TMGNDF3A",1781,0) new className "RTN","TMGNDF3A",1782,0) set className=$piece($get(GuessArray("ALL CLASSES",UsrClassIEN)),"^",3) "RTN","TMGNDF3A",1783,0) "RTN","TMGNDF3A",1784,0) new Menu,UsrSlct "RTN","TMGNDF3A",1785,0) new menuNum set menuNum=0 "RTN","TMGNDF3A",1786,0) new matchName set matchName="" "RTN","TMGNDF3A",1787,0) new lastMatchName,lastvapIEN "RTN","TMGNDF3A",1788,0) new AllArray,IENArray,vapIEN "RTN","TMGNDF3A",1789,0) set Menu(0)="Pick Which Drug does NOT belong in class: "_className "RTN","TMGNDF3A",1790,0) for set matchName=$order(GuessArray("ALL CLASSES",UsrClassIEN,matchName)) quit:(matchName="") do "RTN","TMGNDF3A",1791,0) . set vapIEN="" "RTN","TMGNDF3A",1792,0) . for set vapIEN=$order(GuessArray("ALL CLASSES",UsrClassIEN,matchName,vapIEN)) quit:(vapIEN="") do "RTN","TMGNDF3A",1793,0) . . set menuNum=menuNum+1 "RTN","TMGNDF3A",1794,0) . . set Menu(menuNum)=matchName_" (#"_vapIEN_")"_$char(9)_"@^"_vapIEN_"^"_matchName "RTN","TMGNDF3A",1795,0) . . set AllArray(vapIEN)=matchName "RTN","TMGNDF3A",1796,0) . . set AllArray("NAME",matchName,vapIEN)="" "RTN","TMGNDF3A",1797,0) . . set lastMatchName=matchName,lastvapIEN=vapIEN "RTN","TMGNDF3A",1798,0) if menuNum>1 do "RTN","TMGNDF3A",1799,0) . set menuNum=menuNum+1 "RTN","TMGNDF3A",1800,0) . set Menu(menuNum)="ALL of the above drugs"_$char(9)_"ALL" "RTN","TMGNDF3A",1801,0) . if menuNum'>3 quit "RTN","TMGNDF3A",1802,0) . set menuNum=menuNum+1 "RTN","TMGNDF3A",1803,0) . set Menu(menuNum)="OR you may enter #-#, or #,#,#-#,# etc."_$char(9)_"#" "RTN","TMGNDF3A",1804,0) "RTN","TMGNDF3A",1805,0) FBCMC1 "RTN","TMGNDF3A",1806,0) if menuNum>1 do "RTN","TMGNDF3A",1807,0) . write ! set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") ;"@^vapIEN^matchName "RTN","TMGNDF3A",1808,0) else do "RTN","TMGNDF3A",1809,0) . set UsrSlct="@^"_lastvapIEN_"^"_lastMatchName "RTN","TMGNDF3A",1810,0) "RTN","TMGNDF3A",1811,0) if UsrSlct="ALL" do "RTN","TMGNDF3A",1812,0) . merge IENArray=AllArray "RTN","TMGNDF3A",1813,0) else if +UsrSlct>0 do "RTN","TMGNDF3A",1814,0) . new EntryList,Entry "RTN","TMGNDF3A",1815,0) . if $$MkMultList^TMGMISC(UsrSlct,.EntryList)>0 do "RTN","TMGNDF3A",1816,0) . . set Entry="" "RTN","TMGNDF3A",1817,0) . . for set Entry=$order(EntryList(Entry)) quit:(Entry="") do "RTN","TMGNDF3A",1818,0) . . . new vapIEN,vapName,s "RTN","TMGNDF3A",1819,0) . . . set s=$piece(Menu(Entry),$char(9),2) "RTN","TMGNDF3A",1820,0) . . . if s="" quit "RTN","TMGNDF3A",1821,0) . . . set vapIEN=$piece(s,"^",2),vapName=$piece(s,"^",3) "RTN","TMGNDF3A",1822,0) . . . set IENArray(vapIEN)=vapName "RTN","TMGNDF3A",1823,0) . . . set IENArray("NAME",vapIEN)="" "RTN","TMGNDF3A",1824,0) else if $piece(UsrSlct,"^",1)="@" do "RTN","TMGNDF3A",1825,0) . set IENArray($piece(UsrSlct,"^",2))=$piece(UsrSlct,"^",3) "RTN","TMGNDF3A",1826,0) . set IENArray("NAME",$piece(UsrSlct,"^",3),$piece(UsrSlct,"^",2))="" "RTN","TMGNDF3A",1827,0) else if UsrSlct="^" goto FBCDone "RTN","TMGNDF3A",1828,0) else if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF3A",1829,0) else if UsrSlct="??" do goto FBCDone "RTN","TMGNDF3A",1830,0) . write !,"For some reason, IEN of selected drug couldn't be found. Sorry.",! "RTN","TMGNDF3A",1831,0) else if menuNum>1 goto FBCMC1 "RTN","TMGNDF3A",1832,0) else goto FBCDone "RTN","TMGNDF3A",1833,0) "RTN","TMGNDF3A",1834,0) write "Now pick CORRECT drug class for the chosen drug(s)",! "RTN","TMGNDF3A",1835,0) do PressToCont^TMGUSRIF "RTN","TMGNDF3A",1836,0) new newClassIEN set newClassIEN=$$SelectClass(.Classes,0) "RTN","TMGNDF3A",1837,0) if newClassIEN=0 goto FBCDone "RTN","TMGNDF3A",1838,0) ;"new className set className=$$GET1^DIQ(50.605,newClassIEN,1) "RTN","TMGNDF3A",1839,0) ;"write "Set CLASS for VA PRODUCT entry: "_$piece(UsrSlct,"^",2),! "RTN","TMGNDF3A",1840,0) ;"write "to be: ",className,"?" "RTN","TMGNDF3A",1841,0) ;"new % set %=1 "RTN","TMGNDF3A",1842,0) ;"do YN^DICN write ! "RTN","TMGNDF3A",1843,0) ;"if %=-1 goto FBCDone "RTN","TMGNDF3A",1844,0) "RTN","TMGNDF3A",1845,0) new vapName set vapName="" "RTN","TMGNDF3A",1846,0) for set vapName=$order(IENArray("NAME",vapName)) quit:(vapName="") do "RTN","TMGNDF3A",1847,0) . new entryNum set entryNum="" "RTN","TMGNDF3A",1848,0) . ;" GuessArray(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1849,0) . for set entryNum=$order(GuessArray(entryNum)) quit:(+entryNum'>0) do "RTN","TMGNDF3A",1850,0) . . set vapIEN="" "RTN","TMGNDF3A",1851,0) . . for set vapIEN=$order(GuessArray(entryNum,"NAME",vapName,vapIEN)) quit:(vapIEN="") do "RTN","TMGNDF3A",1852,0) . . . new s set s=$get(GuessArray(entryNum,"NAME",vapName,vapIEN)) "RTN","TMGNDF3A",1853,0) . . . if s="" quit "RTN","TMGNDF3A",1854,0) . . . new classIEN set classIEN=+s "RTN","TMGNDF3A",1855,0) . . . if classIEN=newClassIEN quit ;"already at correct class "RTN","TMGNDF3A",1856,0) . . . set IENArray(vapIEN)=vapName "RTN","TMGNDF3A",1857,0) "RTN","TMGNDF3A",1858,0) set vapIEN="" "RTN","TMGNDF3A",1859,0) for set vapIEN=$order(IENArray(vapIEN)) quit:(+vapIEN'>0) do "RTN","TMGNDF3A",1860,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3A",1861,0) . set TMGFDA(50.68,vapIEN_",",15)=newClassIEN ;"className "RTN","TMGNDF3A",1862,0) . do FILE^DIE("I","TMGFDA","TMGMSG") "RTN","TMGNDF3A",1863,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3A",1864,0) . kill GuessArray("ALL CLASSES",UsrClassIEN,$get(IENArray(vapIEN),"xx")) "RTN","TMGNDF3A",1865,0) "RTN","TMGNDF3A",1866,0) FBCDone "RTN","TMGNDF3A",1867,0) quit "RTN","TMGNDF3A",1868,0) "RTN","TMGNDF3A",1869,0) GGuessList(Array,Answers,List,Results) "RTN","TMGNDF3A",1870,0) ;"Purpose: To gather a guessing list of possible classes for each entry in List "RTN","TMGNDF3A",1871,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",1872,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1873,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1874,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1875,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1876,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",1877,0) ;" Array should be the one created by ShowEList "RTN","TMGNDF3A",1878,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1879,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1880,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",1881,0) ;" Format as follows. "RTN","TMGNDF3A",1882,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1883,0) ;" List(Entry number)="" "RTN","TMGNDF3A",1884,0) ;" Results -- PASS BY REFERENCE -- and OUT PARAMETER to receive results, as follows: "RTN","TMGNDF3A",1885,0) ;" Results(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1886,0) ;" Results(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1887,0) ;" Results(Entry Number,"CLASS",ClassIEN,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1888,0) ;" Results(Entry Number,"CLASS",ClassIEN,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",1889,0) ;" Results("ALL CLASSES",ClassIEN)=ClassIEN_"^"_ClassCode_"^"_ClassName "RTN","TMGNDF3A",1890,0) ;" Results("ALL CLASSES",ClassIEN,matchName,vapIEN)="" "RTN","TMGNDF3A",1891,0) ;"Results: none "RTN","TMGNDF3A",1892,0) "RTN","TMGNDF3A",1893,0) new Guesses,GenericName,TradeName "RTN","TMGNDF3A",1894,0) new i "RTN","TMGNDF3A",1895,0) set i=$order(List("")) "RTN","TMGNDF3A",1896,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",1897,0) . set GenericName=$piece($get(Answers(i)),"^",2) "RTN","TMGNDF3A",1898,0) . set TradeName=$piece($get(Answers(i)),"^",3) "RTN","TMGNDF3A",1899,0) . set i=$order(List(i)) "RTN","TMGNDF3A",1900,0) . if $data(Guesses("TRY",TradeName))>0 quit "RTN","TMGNDF3A",1901,0) . set Guesses("TRY",TradeName)=1 "RTN","TMGNDF3A",1902,0) . new name "RTN","TMGNDF3A",1903,0) . new j,p,done set done=0 "RTN","TMGNDF3A",1904,0) . new X,TMGARRAY,TMGMSG "RTN","TMGNDF3A",1905,0) . for j=$length(GenericName,"/"):-1:1 do "RTN","TMGNDF3A",1906,0) . . set name=$piece(GenericName,"/",j) "RTN","TMGNDF3A",1907,0) . . for p=$length(name," "):-1:1 do quit:(done=1) "RTN","TMGNDF3A",1908,0) . . . new TMGSRCH set TMGSRCH=$piece(name," ",1,p) "RTN","TMGNDF3A",1909,0) . . . do FIND^DIC(50.68,"","","",TMGSRCH,"*","","","","TMGARRAY","TMGMSG") "RTN","TMGNDF3A",1910,0) . . . if +$get(TMGARRAY("DILIST",0))>0 do "RTN","TMGNDF3A",1911,0) . . . . merge Guesses("POS MATCH",GenericName,TMGSRCH,"NAME")=TMGARRAY("DILIST",1) "RTN","TMGNDF3A",1912,0) . . . . merge Guesses("POS MATCH",GenericName,TMGSRCH,"IEN")=TMGARRAY("DILIST",2) "RTN","TMGNDF3A",1913,0) . . . . set done=1 "RTN","TMGNDF3A",1914,0) kill Guesses("TRY") ;"temporary use of those items already searched. "RTN","TMGNDF3A",1915,0) "RTN","TMGNDF3A",1916,0) ;"Now convert matching IENs into drug classes. "RTN","TMGNDF3A",1917,0) set GenericName="" "RTN","TMGNDF3A",1918,0) for set GenericName=$order(Guesses("POS MATCH",GenericName)) quit:(GenericName="") do "RTN","TMGNDF3A",1919,0) . new namePart set namePart="" "RTN","TMGNDF3A",1920,0) . for set namePart=$order(Guesses("POS MATCH",GenericName,namePart)) quit:(namePart="") do "RTN","TMGNDF3A",1921,0) . . new j set j=0 "RTN","TMGNDF3A",1922,0) . . for set j=$order(Guesses("POS MATCH",GenericName,namePart,"IEN",j)) quit:(j'>0) do "RTN","TMGNDF3A",1923,0) . . . new vapIEN set vapIEN=+$get(Guesses("POS MATCH",GenericName,namePart,"IEN",j)) "RTN","TMGNDF3A",1924,0) . . . if vapIEN>0 do "RTN","TMGNDF3A",1925,0) . . . . new classIEN,matchName "RTN","TMGNDF3A",1926,0) . . . . set classIEN=+$$GET1^DIQ(50.68,vapIEN,15,"I") "RTN","TMGNDF3A",1927,0) . . . . set matchName=$$GET1^DIQ(50.68,vapIEN,.01) ;"was 5 (print name) "RTN","TMGNDF3A",1928,0) . . . . if (classIEN'>0)!(matchName="") quit "RTN","TMGNDF3A",1929,0) . . . . set Guesses("POS MATCH",GenericName,"CLASS",matchName,classIEN,vapIEN)="" "RTN","TMGNDF3A",1930,0) "RTN","TMGNDF3A",1931,0) ;"Now compose results "RTN","TMGNDF3A",1932,0) set i="" "RTN","TMGNDF3A",1933,0) for set i=$order(List(i)) quit:(i="") do "RTN","TMGNDF3A",1934,0) . set GenericName=$piece($get(Answers(i)),"^",2) "RTN","TMGNDF3A",1935,0) . set TradeName=$piece($get(Answers(i)),"^",3) "RTN","TMGNDF3A",1936,0) . new matchName set matchName="" "RTN","TMGNDF3A",1937,0) . for set matchName=$order(Guesses("POS MATCH",GenericName,"CLASS",matchName)) quit:(matchName="") do "RTN","TMGNDF3A",1938,0) . . new classIEN set classIEN="" "RTN","TMGNDF3A",1939,0) . . for set classIEN=+$order(Guesses("POS MATCH",GenericName,"CLASS",matchName,classIEN)) quit:(classIEN'>0) do "RTN","TMGNDF3A",1940,0) . . . new classCode,className "RTN","TMGNDF3A",1941,0) . . . set classCode=$$GET1^DIQ(50.605,classIEN,.01) "RTN","TMGNDF3A",1942,0) . . . set className=$$GET1^DIQ(50.605,classIEN,1) "RTN","TMGNDF3A",1943,0) . . . new vapIEN set vapIEN="" "RTN","TMGNDF3A",1944,0) . . . for set vapIEN=+$order(Guesses("POS MATCH",GenericName,"CLASS",matchName,classIEN,vapIEN)) quit:(vapIEN'>0) do "RTN","TMGNDF3A",1945,0) . . . . set Results(i,"NAME",matchName,vapIEN)=classIEN_"^"_classCode_"^"_className_"^"_vapIEN "RTN","TMGNDF3A",1946,0) . . . . set Results(i,"CLASS",classIEN,vapIEN)=classIEN_"^"_classCode_"^"_className_"^"_vapIEN "RTN","TMGNDF3A",1947,0) . . . . set Results("ALL CLASSES",classIEN)=classIEN_"^"_classCode_"^"_className "RTN","TMGNDF3A",1948,0) . . . . set Results("ALL CLASSES",classIEN,matchName,vapIEN)="" "RTN","TMGNDF3A",1949,0) "RTN","TMGNDF3A",1950,0) quit "RTN","TMGNDF3A",1951,0) "RTN","TMGNDF3A",1952,0) "RTN","TMGNDF3A",1953,0) "RTN","TMGNDF3A",1954,0) AutoEClassification(Array) "RTN","TMGNDF3A",1955,0) ;"Purpose: To attempt to automatically classify drugs that have not potential match "RTN","TMGNDF3A",1956,0) ;"Input: -- Array PASS BY REFERENCE, an OUT PARAMETER. Prior entries are NOT killed. "RTN","TMGNDF3A",1957,0) ;"Output: Array will be filled as follows: "RTN","TMGNDF3A",1958,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode "RTN","TMGNDF3A",1959,0) ;" Array("POSS MATCH",ClassName,TMGTradename,DrugIEN)=ClassIEN^ClassCode "RTN","TMGNDF3A",1960,0) ;" Array(DrugIEN,"?")="" "RTN","TMGNDF3A",1961,0) ;" Array("?",DrugIEN)="" "RTN","TMGNDF3A",1962,0) ;"Results: none "RTN","TMGNDF3A",1963,0) "RTN","TMGNDF3A",1964,0) new tempArray "RTN","TMGNDF3A",1965,0) new Classes "RTN","TMGNDF3A",1966,0) new Answers "RTN","TMGNDF3A",1967,0) write "Gathering drugs with no CLASS information and no existing match...",! "RTN","TMGNDF3A",1968,0) "RTN","TMGNDF3A",1969,0) new CompactMode set CompactMode=0 ;" (list display mode: 1=compact, 0=verb "RTN","TMGNDF3A",1970,0) new ShowBoth set ShowBoth=0 "RTN","TMGNDF3A",1971,0) new ByTrade set ByTrade=1 "RTN","TMGNDF3A",1972,0) "RTN","TMGNDF3A",1973,0) do GatherEmpties(.tempArray) "RTN","TMGNDF3A",1974,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",1975,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",1976,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",1977,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",1978,0) "RTN","TMGNDF3A",1979,0) do GetClasses(.Classes) "RTN","TMGNDF3A",1980,0) do KillIntro(.Classes) "RTN","TMGNDF3A",1981,0) "RTN","TMGNDF3A",1982,0) do ShowEList(.tempArray,.Answers,CompactMode,ByTrade,ShowBoth) "RTN","TMGNDF3A",1983,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1984,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",1985,0) "RTN","TMGNDF3A",1986,0) write !,"Now scanning unclassified drugs for possible CLASS matches...",! "RTN","TMGNDF3A",1987,0) "RTN","TMGNDF3A",1988,0) new TMGTOTAL set TMGTOTAL=$$ListCt^TMGMISC("Answers") "RTN","TMGNDF3A",1989,0) new TMGCUR "RTN","TMGNDF3A",1990,0) new StartTime set StartTime=$H "RTN","TMGNDF3A",1991,0) new ProgressFn "RTN","TMGNDF3A",1992,0) set ProgressFn="if TMGCUR#10=1 do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",0,TMGTOTAL,,StartTime)" "RTN","TMGNDF3A",1993,0) new abort set abort=0 "RTN","TMGNDF3A",1994,0) new i set i=$order(Answers("")) "RTN","TMGNDF3A",1995,0) if i'="" for do quit:(i="")!abort "RTN","TMGNDF3A",1996,0) . if $$KeyPressed^TMGUSRIF()=27 do quit:abort=1 "RTN","TMGNDF3A",1997,0) . . new % set %=2 "RTN","TMGNDF3A",1998,0) . . write !,"Abort" do YN^DICN write ! "RTN","TMGNDF3A",1999,0) . . if %=1 set abort=1 "RTN","TMGNDF3A",2000,0) . new List set List(i)="" "RTN","TMGNDF3A",2001,0) . new class set class=$$Guess1(.Array,.Answers,.List) "RTN","TMGNDF3A",2002,0) . if +class>0 do "RTN","TMGNDF3A",2003,0) . . new ClassName,ClassCode,ClassIEN,TMGTradeName,DrugIEN "RTN","TMGNDF3A",2004,0) . . set ClassName=$piece(class,"^",3) "RTN","TMGNDF3A",2005,0) . . set ClassCode=$piece(class,"^",2) "RTN","TMGNDF3A",2006,0) . . set ClassIEN=$piece(class,"^",1) "RTN","TMGNDF3A",2007,0) . . set TMGTradeName=$piece(Answers(i),"^",3) "RTN","TMGNDF3A",2008,0) . . set DrugIEN=$piece(Answers(i),"^",1) "RTN","TMGNDF3A",2009,0) . . set Array("POSS MATCH",ClassName,TMGTradeName,DrugIEN)=ClassIEN_"^"_ClassCode "RTN","TMGNDF3A",2010,0) . . do CUU^TMGTERM(2) write ! "RTN","TMGNDF3A",2011,0) . . new s set s="Found: "_TMGTradeName_" --> "_ClassName "RTN","TMGNDF3A",2012,0) . . set s=s_" " "RTN","TMGNDF3A",2013,0) . . write $extract(s,1,79),! "RTN","TMGNDF3A",2014,0) . if $get(ProgressFn)'="" do "RTN","TMGNDF3A",2015,0) . . set TMGCUR=i "RTN","TMGNDF3A",2016,0) . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" "RTN","TMGNDF3A",2017,0) . . xecute ProgressFn "RTN","TMGNDF3A",2018,0) . set i=$order(Answers(i)) "RTN","TMGNDF3A",2019,0) "RTN","TMGNDF3A",2020,0) quit "RTN","TMGNDF3A",2021,0) "RTN","TMGNDF3A",2022,0) "RTN","TMGNDF3A",2023,0) "RTN","TMGNDF3A",2024,0) Guess1(Array,Answers,List) "RTN","TMGNDF3A",2025,0) ;"Purpose: To return a guessed class, IF there is only one possible guess. "RTN","TMGNDF3A",2026,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",2027,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",2028,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",2029,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",2030,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",2031,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",2032,0) ;" Array should be the one created by ShowEList "RTN","TMGNDF3A",2033,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",2034,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",2035,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to process. "RTN","TMGNDF3A",2036,0) ;" Format as follows. "RTN","TMGNDF3A",2037,0) ;" List(Entry number)="" "RTN","TMGNDF3A",2038,0) ;" List(Entry number)="" "RTN","TMGNDF3A",2039,0) ;"Results: If only 1 matching class found, then classIEN^classCode^className, otherwise 0 "RTN","TMGNDF3A",2040,0) "RTN","TMGNDF3A",2041,0) new ResultArray "RTN","TMGNDF3A",2042,0) new result set result=0 "RTN","TMGNDF3A",2043,0) do GGuessList(.Array,.Answers,.List,.ResultArray) "RTN","TMGNDF3A",2044,0) ;" Results(Entry Number,"NAME",VASimilarDrugName)=ClassIEN^ClassCode^ClassName "RTN","TMGNDF3A",2045,0) ;" Results(Entry Number,"CLASS",ClassIEN)=ClassIEN^ClassCode^ClassName "RTN","TMGNDF3A",2046,0) ;" Results("ALL CLASSES",classIEN)=classIEN_"^"_classCode_"^"_className "RTN","TMGNDF3A",2047,0) ;" Results("ALL CLASSES",classIEN,matchName)="" "RTN","TMGNDF3A",2048,0) "RTN","TMGNDF3A",2049,0) ;" Results(Entry Number,"NAME",VASimilarDrugName,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",2050,0) ;" Results(Entry Number,"CLASS",ClassIEN,vapIEN)=ClassIEN^ClassCode^ClassName_vapIEN "RTN","TMGNDF3A",2051,0) ;" Results("ALL CLASSES",ClassIEN)=ClassIEN_"^"_ClassCode_"^"_ClassName "RTN","TMGNDF3A",2052,0) ;" Results("ALL CLASSES",ClassIEN,matchName,vapIEN)="" "RTN","TMGNDF3A",2053,0) "RTN","TMGNDF3A",2054,0) "RTN","TMGNDF3A",2055,0) if $$ListCt^TMGMISC($name(ResultArray("ALL CLASSES")))=1 do "RTN","TMGNDF3A",2056,0) . new classIEN "RTN","TMGNDF3A",2057,0) . set classIEN=$order(ResultArray("ALL CLASSES","")) "RTN","TMGNDF3A",2058,0) . set result=$get(ResultArray("ALL CLASSES",classIEN)) "RTN","TMGNDF3A",2059,0) "RTN","TMGNDF3A",2060,0) quit result "RTN","TMGNDF3A",2061,0) "RTN","TMGNDF3A",2062,0) "RTN","TMGNDF3A",2063,0) DoSetTools(Array,Answers,List,EntryS,ByTradeName,ShowBoth) "RTN","TMGNDF3A",2064,0) ;"Purpose: to provide tools for managing SETS to be worked on (List) "RTN","TMGNDF3A",2065,0) ;"Input: Array -- PASS BY REFERENCE, array holding data, As created by Gather Classes "RTN","TMGNDF3A",2066,0) ;" Array("GENERIC NAME",VA GENERIC Name,DrugIEN)="" "RTN","TMGNDF3A",2067,0) ;" Array("TRADE NAME",TradeName,DrugIEN)="" "RTN","TMGNDF3A",2068,0) ;" Array("LINK GENERIC TO TRADE",TMGGeneric)=TradeName "RTN","TMGNDF3A",2069,0) ;" Array("LINK TRADE TO GENERIC",TradeName)=TMGGeneric "RTN","TMGNDF3A",2070,0) ;" Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",2071,0) ;" Array should be the one created by ShowEList "RTN","TMGNDF3A",2072,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",2073,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",2074,0) ;" List -- PASS BY REFERENCE -- an array of entries (user input values) to modify. "RTN","TMGNDF3A",2075,0) ;" EntryS -- PASS BY REFERENCE -- a string representing the current set. "RTN","TMGNDF3A",2076,0) ;" ByTradeName -- OPTIONAL, PASS BY REFERENCE, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",2077,0) ;" ShowBoth -- OPTIONAL, PASS BY REFERENCE, if value=1 then trade name and generic names both shown. "RTN","TMGNDF3A",2078,0) "RTN","TMGNDF3A",2079,0) set ByTradeName=$get(ByTradeName,0) "RTN","TMGNDF3A",2080,0) set ShowBoth=$get(ShowBoth,0) "RTN","TMGNDF3A",2081,0) "RTN","TMGNDF3A",2082,0) new input,done "RTN","TMGNDF3A",2083,0) set EntryS=$get(EntryS) "RTN","TMGNDF3A",2084,0) set done=0 "RTN","TMGNDF3A",2085,0) "RTN","TMGNDF3A",2086,0) for do quit:(done=1) "RTN","TMGNDF3A",2087,0) . write !,"Tools to modify SET of entry numbers",! "RTN","TMGNDF3A",2088,0) . write "------------------------------------",! "RTN","TMGNDF3A",2089,0) . write "A=Add, X=Remove from SET, C=Clear, D=Display, S=Search, ^ Return",! "RTN","TMGNDF3A",2090,0) . write "T=set TradeName ",$select((ByTrade=1):"OFF",1:"ON"),", B=set Both names ",$select((ShowBoth=1):"OFF",1:"ON"),! "RTN","TMGNDF3A",2091,0) . read "Enter Option: ^// ",input:$get(DTIME,3600),! "RTN","TMGNDF3A",2092,0) . if input="" set input="^" "RTN","TMGNDF3A",2093,0) . set input=$$UP^XLFSTR(input) "RTN","TMGNDF3A",2094,0) . if input="^" write ! set done=1 quit "RTN","TMGNDF3A",2095,0) . if (input="?") do "RTN","TMGNDF3A",2096,0) . . ;"do ShowInstructions() "RTN","TMGNDF3A",2097,0) . . set input="R" "RTN","TMGNDF3A",2098,0) . else if input="A" do "RTN","TMGNDF3A",2099,0) . . read "Enter number(s) to ADD to list: ",input:$get(DTIME,3600),! "RTN","TMGNDF3A",2100,0) . . if $$MkMultList^TMGMISC(input,.List) set EntryS=EntryS_" & "_input "RTN","TMGNDF3A",2101,0) . else if input="X" do "RTN","TMGNDF3A",2102,0) . . new tempList "RTN","TMGNDF3A",2103,0) . . read "Enter number(s) to REMOVE to list: ",input:$get(DTIME,3600),! "RTN","TMGNDF3A",2104,0) . . if $$MkMultList^TMGMISC(input,.tempList)=0 quit "RTN","TMGNDF3A",2105,0) . . new i set i=$order(tempList("")) "RTN","TMGNDF3A",2106,0) . . if i'="" for do quit:(i="") "RTN","TMGNDF3A",2107,0) . . . kill List(i) "RTN","TMGNDF3A",2108,0) . . . set i=$order(tempList(i)) "RTN","TMGNDF3A",2109,0) . . set EntryS=EntryS_" - "_input "RTN","TMGNDF3A",2110,0) . else if input="C" do "RTN","TMGNDF3A",2111,0) . . kill List set EntryS="" "RTN","TMGNDF3A",2112,0) . . set input="D" "RTN","TMGNDF3A",2113,0) . else if input="S" do "RTN","TMGNDF3A",2114,0) . . if $$MkSrchList(.Answers,.List,.ByTradeName,.ShowBoth)=1 do "RTN","TMGNDF3A",2115,0) . . . if EntryS'="" set EntryS=EntryS_" & " "RTN","TMGNDF3A",2116,0) . . . set EntryS=EntryS_" (SEARCH)" "RTN","TMGNDF3A",2117,0) . . set input="D" "RTN","TMGNDF3A",2118,0) . else if input="T" do "RTN","TMGNDF3A",2119,0) . . set ByTrade='ByTrade "RTN","TMGNDF3A",2120,0) . . set input="D" "RTN","TMGNDF3A",2121,0) . else if input="B" do "RTN","TMGNDF3A",2122,0) . . set ShowBoth='ShowBoth "RTN","TMGNDF3A",2123,0) . . set input="D" "RTN","TMGNDF3A",2124,0) . if input="D" do "RTN","TMGNDF3A",2125,0) . . write !,"Here is the current SET: ",EntryS,! "RTN","TMGNDF3A",2126,0) . . do Disp2List(.Answers,.List,.ByTradeName,.ShowBoth) "RTN","TMGNDF3A",2127,0) . . ;"new temp read " -- Press [ENTER] to Continue --",temp:$get(DTIME,3600),! "RTN","TMGNDF3A",2128,0) "RTN","TMGNDF3A",2129,0) quit "RTN","TMGNDF3A",2130,0) "RTN","TMGNDF3A",2131,0) MkSrchList(Answers,List,ByTradeName,ShowBoth) "RTN","TMGNDF3A",2132,0) ;"Purpose: to search through Answers for string "RTN","TMGNDF3A",2133,0) ;"Input: Answers -- PASS BY REFERENCE, an array linking display number to IENS. "RTN","TMGNDF3A",2134,0) ;" Array should be the one created by ShowEList "RTN","TMGNDF3A",2135,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",2136,0) ;" Answer(count)=DrugIEN^GenericDrugName^TradeName "RTN","TMGNDF3A",2137,0) ;" List -- PASS BY REFERENCE -- an OUT PARAMETER, to hold array of entries (user input values) "RTN","TMGNDF3A",2138,0) ;" prior entries are NOT KILLED "RTN","TMGNDF3A",2139,0) ;" ByTradeName -- OPTIONAL, if value=1, then values are shown by TradeName "RTN","TMGNDF3A",2140,0) ;" ShowBoth -- OPTIONAL, if value=1 then trade name and generic names both shown. "RTN","TMGNDF3A",2141,0) ;"Results: 1=some added to list, 0=none added to list. "RTN","TMGNDF3A",2142,0) "RTN","TMGNDF3A",2143,0) set ByTradeName=$get(ByTradeName,0) "RTN","TMGNDF3A",2144,0) set ShowBoth=$get(ShowBoth,0) "RTN","TMGNDF3A",2145,0) new result set result=0 "RTN","TMGNDF3A",2146,0) "RTN","TMGNDF3A",2147,0) new input "RTN","TMGNDF3A",2148,0) write !,"Search in ",$select((ByTradeName=1):"TRADE NAME",1:"GENRIC NAME") "RTN","TMGNDF3A",2149,0) if ShowBoth write " and ",$select((ByTradeName=0):"TRADE NAME",1:"GENRIC NAME") "RTN","TMGNDF3A",2150,0) read !,"Entry text to SEARCH for in entries: ^// ",input:$get(DTIME,3600),! "RTN","TMGNDF3A",2151,0) if input="" set input="^" "RTN","TMGNDF3A",2152,0) set input=$$UP^XLFSTR(input) "RTN","TMGNDF3A",2153,0) if input="^" goto MSLDone "RTN","TMGNDF3A",2154,0) new i set i=$order(Answers("")) "RTN","TMGNDF3A",2155,0) if i'="" for do quit:(i="") "RTN","TMGNDF3A",2156,0) . new TradeName,GenericName "RTN","TMGNDF3A",2157,0) . set GenericName=$$UP^XLFSTR($piece($get(Answers(i)),"^",2)) "RTN","TMGNDF3A",2158,0) . set TradeName=$$UP^XLFSTR($piece($get(Answers(i)),"^",3)) "RTN","TMGNDF3A",2159,0) . if (ByTradeName=1)!(ShowBoth=1) do "RTN","TMGNDF3A",2160,0) . . if TradeName[input set List(i)="",result=1 "RTN","TMGNDF3A",2161,0) . if (ByTradeName=0)!(ShowBoth=1) do "RTN","TMGNDF3A",2162,0) . . if GenericName[input set List(i)="",result=1 "RTN","TMGNDF3A",2163,0) . set i=$order(Answers(i)) "RTN","TMGNDF3A",2164,0) "RTN","TMGNDF3A",2165,0) MSLDone "RTN","TMGNDF3A",2166,0) quit result "RTN","TMGNDF3A",2167,0) "RTN","TMGNDF3A",2168,0) ;"================================================================= "RTN","TMGNDF3A",2169,0) "RTN","TMGNDF3A",2170,0) SelEdClasses "RTN","TMGNDF3A",2171,0) ;"Purpose: Allow user to browse classes with selector "RTN","TMGNDF3A",2172,0) ;"Input: none "RTN","TMGNDF3A",2173,0) ;"Results: none "RTN","TMGNDF3A",2174,0) "RTN","TMGNDF3A",2175,0) new Options,IEN "RTN","TMGNDF3A",2176,0) set Options("FIELDS",1)=".09:1^VA DRUG CLASS^24" "RTN","TMGNDF3A",2177,0) set Options("FIELDS",1,"LOOKUP FN")="$$SECLookup^TMGNDF3A()" "RTN","TMGNDF3A",2178,0) set Options("FIELDS",2)=".05^TRADENAME^24" "RTN","TMGNDF3A",2179,0) set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3A",2180,0) set Options("FIELDS",3)=".07^GENERIC NAME^24" "RTN","TMGNDF3A",2181,0) set Options("FIELDS",3,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3A",2182,0) set Options("FIELDS","MAX NUM")=3 "RTN","TMGNDF3A",2183,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF3A",2184,0) ;"Get all records with SKIP THIS RECORD = 0 (KEEP) "RTN","TMGNDF3A",2185,0) "RTN","TMGNDF3A",2186,0) write "Finding records not marked to be skipped...",! "RTN","TMGNDF3A",2187,0) do GetFldValue^TMGSELED(22706.9,6,0,$name(Options("IEN LIST"))) "RTN","TMGNDF3A",2188,0) "RTN","TMGNDF3A",2189,0) SEC1 "RTN","TMGNDF3A",2190,0) if $$SELED^TMGSELED(.Options)'=2 goto SECDone "RTN","TMGNDF3A",2191,0) if $$GetIENs^TMGSELED(.Options)=0 goto SECDone "RTN","TMGNDF3A",2192,0) goto SEC1 "RTN","TMGNDF3A",2193,0) "RTN","TMGNDF3A",2194,0) SECDone quit "RTN","TMGNDF3A",2195,0) "RTN","TMGNDF3A",2196,0) "RTN","TMGNDF3A",2197,0) Ed1Classes "RTN","TMGNDF3A",2198,0) ;"Purpose: Allow user to browse classes with selector "RTN","TMGNDF3A",2199,0) ;"Input: none "RTN","TMGNDF3A",2200,0) ;"Results: none "RTN","TMGNDF3A",2201,0) "RTN","TMGNDF3A",2202,0) new Options,IEN "RTN","TMGNDF3A",2203,0) set Options("FIELDS",1)=".09:1^VA DRUG CLASS^24" "RTN","TMGNDF3A",2204,0) set Options("FIELDS",1,"LOOKUP FN")="$$SECLookup^TMGNDF3A()" "RTN","TMGNDF3A",2205,0) set Options("FIELDS",2)=".05^TRADENAME^24" "RTN","TMGNDF3A",2206,0) set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3A",2207,0) set Options("FIELDS",3)=".07^GENERIC NAME^24" "RTN","TMGNDF3A",2208,0) set Options("FIELDS",3,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3A",2209,0) set Options("FIELDS","MAX NUM")=3 "RTN","TMGNDF3A",2210,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF3A",2211,0) ;"Get all records with SKIP THIS RECORD = 0 (KEEP) "RTN","TMGNDF3A",2212,0) "RTN","TMGNDF3A",2213,0) new DIC,X,Y "RTN","TMGNDF3A",2214,0) set DIC=22706.9 "RTN","TMGNDF3A",2215,0) set DIC(0)="MAEQ" "RTN","TMGNDF3A",2216,0) do ^DIC write ! "RTN","TMGNDF3A",2217,0) if +Y'>0 goto E1Done "RTN","TMGNDF3A",2218,0) set Options("IEN LIST",+Y)="" "RTN","TMGNDF3A",2219,0) "RTN","TMGNDF3A",2220,0) E1 "RTN","TMGNDF3A",2221,0) if $$SELED^TMGSELED(.Options)'=2 goto E1Done "RTN","TMGNDF3A",2222,0) if $$GetIENs^TMGSELED(.Options)=0 goto E1Done "RTN","TMGNDF3A",2223,0) goto E1 "RTN","TMGNDF3A",2224,0) "RTN","TMGNDF3A",2225,0) E1Done quit "RTN","TMGNDF3A",2226,0) "RTN","TMGNDF3A",2227,0) "RTN","TMGNDF3A",2228,0) SECLookup() "RTN","TMGNDF3A",2229,0) ;"Purpose: A custom call-back function that the selector will use "RTN","TMGNDF3A",2230,0) ;" for looking up class of a given record or list of records. "RTN","TMGNDF3A",2231,0) ;"Input: None (because this is to be used only for ONE field) "RTN","TMGNDF3A",2232,0) ;"Results: Returns IEN for Class, or 0 if not found or abort. "RTN","TMGNDF3A",2233,0) "RTN","TMGNDF3A",2234,0) new Classes,UsrClassIEN "RTN","TMGNDF3A",2235,0) "RTN","TMGNDF3A",2236,0) do GetClasses(.Classes) "RTN","TMGNDF3A",2237,0) do KillIntro(.Classes) "RTN","TMGNDF3A",2238,0) set UsrClassIEN=$$SelectClass(.Classes) "RTN","TMGNDF3A",2239,0) "RTN","TMGNDF3A",2240,0) quit UsrClassIEN "RTN","TMGNDF3B") 0^49^B4797 "RTN","TMGNDF3B",1,0) TMGNDF3B ;TMG/kst/FDA Import: Set skip flag based on drug class ;03/25/06 "RTN","TMGNDF3B",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF3B",3,0) "RTN","TMGNDF3B",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF3B",5,0) ;" Set skip flag based on CLASS "RTN","TMGNDF3B",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF3B",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF3B",8,0) ;"11-21-2006 "RTN","TMGNDF3B",9,0) "RTN","TMGNDF3B",10,0) ;"======================================================================= "RTN","TMGNDF3B",11,0) ;" API -- Public Functions. "RTN","TMGNDF3B",12,0) ;"======================================================================= "RTN","TMGNDF3B",13,0) ;"PickSkips -- allow user to scan for drugs by class and choose which to skip. "RTN","TMGNDF3B",14,0) ;" -- NOTE: This is called from menu in TMGNDF3A "RTN","TMGNDF3B",15,0) "RTN","TMGNDF3B",16,0) ;"======================================================================= "RTN","TMGNDF3B",17,0) ;" Private Functions. "RTN","TMGNDF3B",18,0) ;"======================================================================= "RTN","TMGNDF3B",19,0) ;"GetChildClasses(Array,Result) -- get a child array block showing the heirarchy of all VA DRUG classes "RTN","TMGNDF3B",20,0) ;"GetRxClasses(pList,Array) -- create an array of drug classes for the input List "RTN","TMGNDF3B",21,0) ;"GetMatch(RxClasses,ChildClasses,ClassIEN,Results) -- return those Drugs contained in class IEN "RTN","TMGNDF3B",22,0) ;"WeedClasses(Classes,RxClasses,ChildClasses) -- remove entries from Classes that don't have any children in RxClasses "RTN","TMGNDF3B",23,0) ;"NumDescendents(ClassIEN,Classes,ChildClasses,CountArray) -- return num having class, or descendent class "RTN","TMGNDF3B",24,0) ;"DoWeedBySel(pList,mode) -- remove items, view all drugs, & select to remove "RTN","TMGNDF3B",25,0) ;"GetInfo(IEN,array) -- get all the associated names linked to a DRUG file entry "RTN","TMGNDF3B",26,0) "RTN","TMGNDF3B",27,0) ;"======================================================================= "RTN","TMGNDF3B",28,0) ;"======================================================================= "RTN","TMGNDF3B",29,0) PickSkips "RTN","TMGNDF3B",30,0) ;"Purpose: To allow user to scan for drugs by class and choose which to skip. "RTN","TMGNDF3B",31,0) "RTN","TMGNDF3B",32,0) new List "RTN","TMGNDF3B",33,0) do GetList("List") "RTN","TMGNDF3B",34,0) do WeedByClass("List") "RTN","TMGNDF3B",35,0) "RTN","TMGNDF3B",36,0) quit "RTN","TMGNDF3B",37,0) "RTN","TMGNDF3B",38,0) GetList(pList) "RTN","TMGNDF3B",39,0) ;"Purpose: To create a list of records not currently marked to be skipped "RTN","TMGNDF3B",40,0) ;"Input: pList -- PASS BY NAME -- an OUT PARAMETER. Format: "RTN","TMGNDF3B",41,0) ;" @pList@(DrugName,IENin22706.9)="" "RTN","TMGNDF3B",42,0) ;" @pList@(DrugName,IENin22706.9)="" "RTN","TMGNDF3B",43,0) "RTN","TMGNDF3B",44,0) new Itr,IEN "RTN","TMGNDF3B",45,0) new abort set abort=0 "RTN","TMGNDF3B",46,0) write "Gathering names of the current imports not flagged to be SKIPPED...",! "RTN","TMGNDF3B",47,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3B",48,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3B",49,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF3B",50,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3B",51,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3B",52,0) . new DrugName set DrugName=$piece($get(^TMG(22706.9,IEN,7)),"^",6) "RTN","TMGNDF3B",53,0) . set @pList@(DrugName,IEN)="" "RTN","TMGNDF3B",54,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3B",55,0) "RTN","TMGNDF3B",56,0) quit "RTN","TMGNDF3B",57,0) "RTN","TMGNDF3B",58,0) WeedByClass(pList) "RTN","TMGNDF3B",59,0) ;"Purpose: To allow the user to weed the list of drugs for addition, by drug class "RTN","TMGNDF3B",60,0) ;"Input: pList -- PASS BY NAME -- list of drugs to be added, as created by FillList(pList) "RTN","TMGNDF3B",61,0) ;"Output: the List will be edited. "RTN","TMGNDF3B",62,0) ;"Result: none "RTN","TMGNDF3B",63,0) "RTN","TMGNDF3B",64,0) new Classes,ParentArray,ChildArray,IEN,RxClasses "RTN","TMGNDF3B",65,0) "RTN","TMGNDF3B",66,0) write "Gathering information about drug CLASSES from the imports..." "RTN","TMGNDF3B",67,0) do GetClasses^TMGNDF3A(.Classes) "RTN","TMGNDF3B",68,0) do KillIntro^TMGNDF3A(.Classes) "RTN","TMGNDF3B",69,0) do GetChildClasses(.Classes,.ChildArray) "RTN","TMGNDF3B",70,0) do GetRxClasses(pList,.RxClasses) "RTN","TMGNDF3B",71,0) do WeedClasses(.Classes,.RxClasses,.ChildArray) "RTN","TMGNDF3B",72,0) "RTN","TMGNDF3B",73,0) new done set done=0 "RTN","TMGNDF3B",74,0) for do quit:(done=1) "RTN","TMGNDF3B",75,0) . new classIEN "RTN","TMGNDF3B",76,0) . set classIEN=$$SelectClass^TMGNDF3A(.Classes,1) "RTN","TMGNDF3B",77,0) . if classIEN=0 set done=1 quit "RTN","TMGNDF3B",78,0) . new Match "RTN","TMGNDF3B",79,0) . do GetMatch(.RxClasses,.ChildArray,classIEN,.Match) "RTN","TMGNDF3B",80,0) . if $data(Match) do "RTN","TMGNDF3B",81,0) . . new delList "RTN","TMGNDF3B",82,0) . . do SelRxList("Match","delList","SELECT DRUGS TO BE DELETED. [ESC][ESC] WHEN DONE") "RTN","TMGNDF3B",83,0) . . do DoWeed(pList,"delList") "RTN","TMGNDF3B",84,0) . . new name set name="" "RTN","TMGNDF3B",85,0) . . for set name=$order(delList(name)) quit:(name="") do "RTN","TMGNDF3B",86,0) . . . new IEN set IEN="" "RTN","TMGNDF3B",87,0) . . . for set IEN=$order(delList(name,IEN)) quit:(+IEN'>0) do "RTN","TMGNDF3B",88,0) . . . . new TMGFDA,TMGMSG "RTN","TMGNDF3B",89,0) . . . . set TMGFDA(22706.9,IEN_",",6)=1 ;"1=SKIP "RTN","TMGNDF3B",90,0) . . . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3B",91,0) . . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3B",92,0) . . . . new classIEN set classIEN=$piece($get(^TMG(22706.9,IEN,1)),"^",5) "RTN","TMGNDF3B",93,0) . . . . if $data(RxClasses(classIEN,name,IEN)) do "RTN","TMGNDF3B",94,0) . . . . . kill RxClasses(classIEN,name,IEN) "RTN","TMGNDF3B",95,0) . . ;"kill RxClasses "RTN","TMGNDF3B",96,0) . . ;"write "Gathering drug classes..." "RTN","TMGNDF3B",97,0) . . ;"do GetRxClasses(pList,.RxClasses) "RTN","TMGNDF3B",98,0) . . do WeedClasses(.Classes,.RxClasses,.ChildArray) "RTN","TMGNDF3B",99,0) . else write "(No matches found.)",! "RTN","TMGNDF3B",100,0) "RTN","TMGNDF3B",101,0) ;"write "Counting drugs in list... " "RTN","TMGNDF3B",102,0) ;"set @pList@(-1)=$$ListCt^TMGMISC(pList)-1 ;"recount ItemsCount node "RTN","TMGNDF3B",103,0) "RTN","TMGNDF3B",104,0) quit "RTN","TMGNDF3B",105,0) "RTN","TMGNDF3B",106,0) "RTN","TMGNDF3B",107,0) GetRxClasses(pList,Array) "RTN","TMGNDF3B",108,0) ;"Purpose: To create an array of drug classes for the input List "RTN","TMGNDF3B",109,0) ;"Input: pList -- PASS BY NAME, "RTN","TMGNDF3B",110,0) ;" format: @List@(-1)=ItemsCount <-- REMOVED "RTN","TMGNDF3B",111,0) ;" @List@(DrugName,IEN)="" ;IEN is IEN in file 22706.9 "RTN","TMGNDF3B",112,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF3B",113,0) ;" format: Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",114,0) ;" Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",115,0) ;" Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",116,0) ;"Output: Array -- prior entries are not deleted. "RTN","TMGNDF3B",117,0) ;"Result: none "RTN","TMGNDF3B",118,0) "RTN","TMGNDF3B",119,0) new Itr,DrugName "RTN","TMGNDF3B",120,0) new IEN,ClassIEN "RTN","TMGNDF3B",121,0) new abort set abort=0 "RTN","TMGNDF3B",122,0) set DrugName=$$ItrAInit^TMGITR(pList,.Itr) "RTN","TMGNDF3B",123,0) do PrepProgress^TMGITR(.Itr,20,1,"DrugName") "RTN","TMGNDF3B",124,0) write ! "RTN","TMGNDF3B",125,0) if DrugName'="" for do quit:($$ItrANext^TMGITR(.Itr,.DrugName)="")!abort "RTN","TMGNDF3B",126,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3B",127,0) . set IEN=0 "RTN","TMGNDF3B",128,0) . for set IEN=$order(@pList@(DrugName,IEN)) quit:(+IEN'>0) do "RTN","TMGNDF3B",129,0) . . set ClassIEN=$piece($get(^TMG(22706.9,IEN,1)),"^",5) "RTN","TMGNDF3B",130,0) . . if ClassIEN>0 set Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",131,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3B",132,0) "RTN","TMGNDF3B",133,0) quit "RTN","TMGNDF3B",134,0) "RTN","TMGNDF3B",135,0) "RTN","TMGNDF3B",136,0) "RTN","TMGNDF3B",137,0) GetChildClasses(Array,Result) "RTN","TMGNDF3B",138,0) ;"Purpose: To get a child array block showing the heirarchy of all VA DRUG classes "RTN","TMGNDF3B",139,0) ;"Input: Array -- PASS BY REFERENCE, array as created by GetClasses^TMGNDF3A(.Array) "RTN","TMGNDF3B",140,0) ;" Array(GGF-IEN)=e.g. ""AD000^ANTIDOTES,DETERRENTS AND POISON CONTROL" "RTN","TMGNDF3B",141,0) ;" Array(GGF-IEN,GF-IEN)=e.g. "AD100^ALCOHOL DETERRENTS" "RTN","TMGNDF3B",142,0) ;" Array(GGF-IEN,GF-IEN,F-IEN)=e.g. "AD150^ALCOHOL DETERRENTS -- GENERAL TYPE 1" "RTN","TMGNDF3B",143,0) ;" Array(GGF-IEN,GF-IEN,F-IEN,IEN)=e.g. "AD152^ALCOHOL DETERRENTS -- GENERAL TYPE 1b" "RTN","TMGNDF3B",144,0) ;" Note: There are no more than 3 levels "RTN","TMGNDF3B",145,0) ;" Result -- PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF3B",146,0) ;"Output: Result filled as follows: "RTN","TMGNDF3B",147,0) ;" Note: the IEN's here are IEN's in VA DRUG CLASS file "RTN","TMGNDF3B",148,0) ;" Result (IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",149,0) ;" Result (IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",150,0) ;" Result (IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",151,0) ;" Result (IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",152,0) ;" e.g. ChildArray(1)= 2,3,240, means that 2,3,240 are children of 1 "RTN","TMGNDF3B",153,0) ;"Results: none "RTN","TMGNDF3B",154,0) "RTN","TMGNDF3B",155,0) new parentIEN,IEN "RTN","TMGNDF3B",156,0) "RTN","TMGNDF3B",157,0) new i1,i2,i3,i4 "RTN","TMGNDF3B",158,0) set i1=$order(Array("")) "RTN","TMGNDF3B",159,0) if i1'="" for do quit:(i1="") "RTN","TMGNDF3B",160,0) . set i2=$order(Array(i1,"")) "RTN","TMGNDF3B",161,0) . if i2'="" for do quit:(i2="") "RTN","TMGNDF3B",162,0) . . if $data(Array(i1,i2))#10>0 do "RTN","TMGNDF3B",163,0) . . . set Result(i1)=$get(Result(i1))_i2_"," "RTN","TMGNDF3B",164,0) . . set i3=$order(Array(i1,i2,"")) "RTN","TMGNDF3B",165,0) . . if i3'="" for do quit:(i3="") "RTN","TMGNDF3B",166,0) . . . if $data(Array(i1,i2,i3))#10>0 do "RTN","TMGNDF3B",167,0) . . . . set Result(i1)=$get(Result(i1))_i3_"," "RTN","TMGNDF3B",168,0) . . . set i3=$order(Array(i1,i2,i3)) "RTN","TMGNDF3B",169,0) . . set i2=$order(Array(i1,i2)) "RTN","TMGNDF3B",170,0) . set i1=$order(Array(i1)) "RTN","TMGNDF3B",171,0) "RTN","TMGNDF3B",172,0) quit "RTN","TMGNDF3B",173,0) "RTN","TMGNDF3B",174,0) "RTN","TMGNDF3B",175,0) WeedClasses(Classes,RxClasses,ChildClasses) "RTN","TMGNDF3B",176,0) ;"Purpose: To removed entries from Classes that don't have any children in RxClasses "RTN","TMGNDF3B",177,0) ;"Input: "RTN","TMGNDF3B",178,0) ;" Classes -- PASS BY REFERENCE. Array filled as follows: "RTN","TMGNDF3B",179,0) ;" Array(GGF-IEN)=e.g. ""AD000^ANTIDOTES,DETERRENTS AND POISON CONTROL" "RTN","TMGNDF3B",180,0) ;" Array(GGF-IEN,GF-IEN)=e.g. "AD100^ALCOHOL DETERRENTS" "RTN","TMGNDF3B",181,0) ;" Array(GGF-IEN,GF-IEN,F-IEN)=e.g. "AD150^ALCOHOL DETERRENTS -- GENERAL TYPE 1" "RTN","TMGNDF3B",182,0) ;" Array(GGF-IEN,GF-IEN,F-IEN,IEN)=e.g. "AD152^ALCOHOL DETERRENTS -- GENERAL TYPE 1b" "RTN","TMGNDF3B",183,0) ;" RxClasses: PASS BY REFERENCE "RTN","TMGNDF3B",184,0) ;" format: Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",185,0) ;" Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",186,0) ;" Array(ClassIEN,DrugName,IEN)="" "RTN","TMGNDF3B",187,0) ;" ChildClasses: PASS BY REFERENCE "RTN","TMGNDF3B",188,0) ;" Note: the IEN's here are IEN's in VA DRUG CLASS file "RTN","TMGNDF3B",189,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",190,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",191,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",192,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",193,0) ;" e.g. Array(1)= 2,3,240, means that 2,3,240 are children of 1 "RTN","TMGNDF3B",194,0) ;"Output: Classes Array will be edited with empty clases removed "RTN","TMGNDF3B",195,0) ;"Results: none "RTN","TMGNDF3B",196,0) "RTN","TMGNDF3B",197,0) ;"First count all entries for each drug class IEN "RTN","TMGNDF3B",198,0) "RTN","TMGNDF3B",199,0) new CountArray "RTN","TMGNDF3B",200,0) ;"Format: CountArray(ClassIEN)=CountOfDrugsWithThisClass "RTN","TMGNDF3B",201,0) "RTN","TMGNDF3B",202,0) new count "RTN","TMGNDF3B",203,0) new ClassIEN set ClassIEN=$order(RxClasses("")) "RTN","TMGNDF3B",204,0) if ClassIEN'="" for do quit:(ClassIEN="") "RTN","TMGNDF3B",205,0) . set count=0 "RTN","TMGNDF3B",206,0) . new DrugName set DrugName=$order(RxClasses(ClassIEN,"")) "RTN","TMGNDF3B",207,0) . if DrugName'="" for do quit:(DrugName="") "RTN","TMGNDF3B",208,0) . . new DrugIEN set DrugIEN=$order(RxClasses(ClassIEN,DrugName,"")) "RTN","TMGNDF3B",209,0) . . if DrugIEN'="" for do quit:(DrugIEN="") "RTN","TMGNDF3B",210,0) . . . set count=count+1 "RTN","TMGNDF3B",211,0) . . . set DrugIEN=$order(RxClasses(ClassIEN,DrugName,DrugIEN)) "RTN","TMGNDF3B",212,0) . . set DrugName=$order(RxClasses(ClassIEN,DrugName)) "RTN","TMGNDF3B",213,0) . set CountArray(ClassIEN)=count "RTN","TMGNDF3B",214,0) . set ClassIEN=$order(RxClasses(ClassIEN)) "RTN","TMGNDF3B",215,0) "RTN","TMGNDF3B",216,0) "RTN","TMGNDF3B",217,0) ;"Now remove all ClassIENs that don't have any entries, or children or grandchildren etc. "RTN","TMGNDF3B",218,0) ;" Classes -- Array will be filled as follows: "RTN","TMGNDF3B",219,0) ;" Array(GGF-IEN)=e.g. ""AD000^ANTIDOTES,DETERRENTS AND POISON CONTROL" "RTN","TMGNDF3B",220,0) ;" Array(GGF-IEN,GF-IEN)=e.g. "AD100^ALCOHOL DETERRENTS" "RTN","TMGNDF3B",221,0) ;" Array(GGF-IEN,GF-IEN,F-IEN)=e.g. "AD150^ALCOHOL DETERRENTS -- GENERAL TYPE 1" "RTN","TMGNDF3B",222,0) ;" Array(GGF-IEN,GF-IEN,F-IEN,IEN)=e.g. "AD152^ALCOHOL DETERRENTS -- GENERAL TYPE 1b" "RTN","TMGNDF3B",223,0) "RTN","TMGNDF3B",224,0) new i1,i2,i3,i4 "RTN","TMGNDF3B",225,0) set i1=$order(Classes("")) "RTN","TMGNDF3B",226,0) if i1'="" for do quit:(i1="") "RTN","TMGNDF3B",227,0) . if $$NumDescendents(i1,.Classes,.ChildClasses,.CountArray)=0 do quit "RTN","TMGNDF3B",228,0) . . new temp set temp=i1 "RTN","TMGNDF3B",229,0) . . set i1=$order(Classes(i1)) "RTN","TMGNDF3B",230,0) . . kill Classes(temp) "RTN","TMGNDF3B",231,0) . . ;"write "Removing class ",temp,"... It doesn't have any entries or descendents",! "RTN","TMGNDF3B",232,0) . set i2=$order(Classes(i1,"")) "RTN","TMGNDF3B",233,0) . if i2'="" for do quit:(i2="") "RTN","TMGNDF3B",234,0) . . if $$NumDescendents(i2,.Classes,.ChildClasses,.CountArray)=0 do quit "RTN","TMGNDF3B",235,0) . . . new temp set temp=i2 "RTN","TMGNDF3B",236,0) . . . set i2=$order(Classes(i1,i2)) "RTN","TMGNDF3B",237,0) . . . kill Classes(i1,temp) "RTN","TMGNDF3B",238,0) . . . ;"write "Removing class ",temp,"... It doesn't have any entries or descendents",! "RTN","TMGNDF3B",239,0) . . set i3=$order(Classes(i1,i2,"")) "RTN","TMGNDF3B",240,0) . . if i3'="" for do quit:(i3="") "RTN","TMGNDF3B",241,0) . . . if $$NumDescendents(i3,.Classes,.ChildClasses,.CountArray)=0 do quit "RTN","TMGNDF3B",242,0) . . . . new temp set temp=i3 "RTN","TMGNDF3B",243,0) . . . . set i3=$order(Classes(i1,i2,i3)) "RTN","TMGNDF3B",244,0) . . . . kill Classes(i1,i2,temp) "RTN","TMGNDF3B",245,0) . . . . ;"write "Removing class ",temp,"... It doesn't have any entries or descendents",! "RTN","TMGNDF3B",246,0) . . . set i3=$order(Classes(i1,i2,i3)) "RTN","TMGNDF3B",247,0) . . set i2=$order(Classes(i1,i2)) "RTN","TMGNDF3B",248,0) . set i1=$order(Classes(i1)) "RTN","TMGNDF3B",249,0) "RTN","TMGNDF3B",250,0) quit "RTN","TMGNDF3B",251,0) "RTN","TMGNDF3B",252,0) "RTN","TMGNDF3B",253,0) GetMatch(RxClasses,ChildClasses,ClassIEN,Results) "RTN","TMGNDF3B",254,0) ;"Purpose: To return those Drugs contained in class IEN "RTN","TMGNDF3B",255,0) ;"Input: RxClasses: PASS BY REFERENCE Array as created by GetRxClasses(pList,Array) "RTN","TMGNDF3B",256,0) ;" -- a list of drugs arranged by class "RTN","TMGNDF3B",257,0) ;" ChildClasses: PASS BY REFERENCE Array as created by GetChildClasses(Array,Result) "RTN","TMGNDF3B",258,0) ;" -- a list of child class for any given class IEN "RTN","TMGNDF3B",259,0) ;" ClassIEN: The IEN from file VA DRUG CLASS to match against. "RTN","TMGNDF3B",260,0) ;" Results: PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF3B",261,0) ;"Output: Results -- List of matches, if found. Format as follows: "RTN","TMGNDF3B",262,0) ;" format: Results(-1)=ItemsCount <-- REMOVED "RTN","TMGNDF3B",263,0) ;" Results(DrugName,IEN)="" "RTN","TMGNDF3B",264,0) ;" "RTN","TMGNDF3B",265,0) ;"Results: none "RTN","TMGNDF3B",266,0) "RTN","TMGNDF3B",267,0) ;"First get all matches for ClassIEN "RTN","TMGNDF3B",268,0) merge Results=RxClasses(ClassIEN) "RTN","TMGNDF3B",269,0) "RTN","TMGNDF3B",270,0) ;"Now get matches for all descenents "RTN","TMGNDF3B",271,0) new i,kids "RTN","TMGNDF3B",272,0) set kids=$get(ChildClasses(ClassIEN)) "RTN","TMGNDF3B",273,0) for i=1:1:$length(kids,",") do "RTN","TMGNDF3B",274,0) . new kidIEN set kidIEN=$piece(kids,",",i) "RTN","TMGNDF3B",275,0) . merge Results=RxClasses(kidIEN) "RTN","TMGNDF3B",276,0) quit "RTN","TMGNDF3B",277,0) "RTN","TMGNDF3B",278,0) "RTN","TMGNDF3B",279,0) NumDescendents(ClassIEN,Classes,ChildClasses,CountArray) "RTN","TMGNDF3B",280,0) ;"Purpose: For a given drug class, return the number of drugs that have this class, or one "RTN","TMGNDF3B",281,0) ;" of it's descendent classes as its assigned drug class "RTN","TMGNDF3B",282,0) ;"Input: ClassIEN -- the IEN to evaluate "RTN","TMGNDF3B",283,0) ;" Classes -- Array will be filled as follows: "RTN","TMGNDF3B",284,0) ;" Array(GGF-IEN)=e.g. ""AD000^ANTIDOTES,DETERRENTS AND POISON CONTROL" "RTN","TMGNDF3B",285,0) ;" Array(GGF-IEN,GF-IEN)=e.g. "AD100^ALCOHOL DETERRENTS" "RTN","TMGNDF3B",286,0) ;" Array(GGF-IEN,GF-IEN,F-IEN)=e.g. "AD150^ALCOHOL DETERRENTS -- GENERAL TYPE 1" "RTN","TMGNDF3B",287,0) ;" Array(GGF-IEN,GF-IEN,F-IEN,IEN)=e.g. "AD152^ALCOHOL DETERRENTS -- GENERAL TYPE 1b" "RTN","TMGNDF3B",288,0) ;" ChildClasses: "RTN","TMGNDF3B",289,0) ;" Note: the IEN's here are IEN's in VA DRUG CLASS file "RTN","TMGNDF3B",290,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",291,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",292,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",293,0) ;" Array(IEN)="IEN1,IEN2,IEN3,IEN4,IEN5,IEN6," a list of all child IENs "RTN","TMGNDF3B",294,0) ;" e.g. Array(1)= 2,3,240, means that 2,3,240 are children of 1 "RTN","TMGNDF3B",295,0) ;" CountArray: Array filled with a counting of drugs using each class (pre-counted array) "RTN","TMGNDF3B",296,0) ;" CountArray(ClassIEN)=CountOfDrugsWithThisClass "RTN","TMGNDF3B",297,0) ;" CountArray(ClassIEN)=CountOfDrugsWithThisClass "RTN","TMGNDF3B",298,0) ;" CountArray(ClassIEN)=CountOfDrugsWithThisClass "RTN","TMGNDF3B",299,0) ;"Result: returns the number using this class, or a descendent class. "RTN","TMGNDF3B",300,0) "RTN","TMGNDF3B",301,0) new result "RTN","TMGNDF3B",302,0) set result=+$get(CountArray(ClassIEN)) "RTN","TMGNDF3B",303,0) "RTN","TMGNDF3B",304,0) new ChildList set ChildList=$get(ChildClasses(ClassIEN)) "RTN","TMGNDF3B",305,0) new i for i=1:1:$length(ChildList,",") do "RTN","TMGNDF3B",306,0) . new subClassIEN set subClassIEN=+$piece(ChildList,",",i) "RTN","TMGNDF3B",307,0) . if subClassIEN=0 quit "RTN","TMGNDF3B",308,0) . set result=result+$$NumDescendents(subClassIEN,.Classes,.ChildClasses,.CountArray) "RTN","TMGNDF3B",309,0) "RTN","TMGNDF3B",310,0) quit result "RTN","TMGNDF3B",311,0) "RTN","TMGNDF3B",312,0) "RTN","TMGNDF3B",313,0) "RTN","TMGNDF3B",314,0) SelRxList(pList,pSelList,HdrText,mode) "RTN","TMGNDF3B",315,0) ;"Purpose: To display the Drug list, and allow user to select from the list. "RTN","TMGNDF3B",316,0) ;"Input: pList -- PASS BY NAME -- list of drugs to be added, as created by FillList(pList) "RTN","TMGNDF3B",317,0) ;" @pList@(drugName,IEN)="" "RTN","TMGNDF3B",318,0) ;" pSelList -- PASS BY NAME, an OUT PARAMETER. "RTN","TMGNDF3B",319,0) ;" Returns list of selected items "RTN","TMGNDF3B",320,0) ;" @pSelList@(drugName,IEN)="" ;IEN is from 22706.9 "RTN","TMGNDF3B",321,0) ;" @pSelList@(drugName,IEN)="" "RTN","TMGNDF3B",322,0) ;" HdrText -- optional, some text to show on top of selector "RTN","TMGNDF3B",323,0) ;" mode -- OPTIONAL. Default=1 "RTN","TMGNDF3B",324,0) ;" 1 --> Display by LONG NAME .04 name "RTN","TMGNDF3B",325,0) ;" 2 --> Display by VA PRODUCT (50.68) .01 name "RTN","TMGNDF3B",326,0) ;" 3 --> Display by FDA import name "RTN","TMGNDF3B",327,0) ;" 4 --> Display by VA GENERIC name "RTN","TMGNDF3B",328,0) "RTN","TMGNDF3B",329,0) ;"Results: none "RTN","TMGNDF3B",330,0) "RTN","TMGNDF3B",331,0) new ref set ref="^TMP(""VEE"",$J)" "RTN","TMGNDF3B",332,0) kill @ref "RTN","TMGNDF3B",333,0) new count set count=1 "RTN","TMGNDF3B",334,0) set mode=$get(mode,1) "RTN","TMGNDF3B",335,0) "RTN","TMGNDF3B",336,0) new pNDCIndex "RTN","TMGNDF3B",337,0) set pNDCIndex=$$GetNDCIndex^TMGNDF4A(1) "RTN","TMGNDF3B",338,0) "RTN","TMGNDF3B",339,0) write "Prepping to display list...",! "RTN","TMGNDF3B",340,0) ;"First convert list to a display format "RTN","TMGNDF3B",341,0) new name,IEN,Itr "RTN","TMGNDF3B",342,0) "RTN","TMGNDF3B",343,0) set name=$$ItrAInit^TMGITR(pList,.Itr) "RTN","TMGNDF3B",344,0) do PrepProgress^TMGITR(.Itr,20,1,"name") "RTN","TMGNDF3B",345,0) if name'="" for do quit:($$ItrANext^TMGITR(.Itr,.name)="") "RTN","TMGNDF3B",346,0) . new addedArray,showName "RTN","TMGNDF3B",347,0) . set IEN=0 "RTN","TMGNDF3B",348,0) . for set IEN=$order(@pList@(name,IEN)) quit:(IEN="") do "RTN","TMGNDF3B",349,0) . . new NameInfo do GetInfo(IEN,.NameInfo) "RTN","TMGNDF3B",350,0) . . new IdxName set IdxName=$get(NameInfo("MODES",mode)) "RTN","TMGNDF3B",351,0) . . if mode=3 do ;"Display by FDA import name "RTN","TMGNDF3B",352,0) . . . set showName="" "RTN","TMGNDF3B",353,0) . . . for set showName=$order(NameInfo(IdxName,showName)) quit:(showName="") do "RTN","TMGNDF3B",354,0) . . . . set @ref@(count)=name_"^"_IEN_$char(9)_showName set count=count+1 "RTN","TMGNDF3B",355,0) . . . set showName="" ;"prevent duplicate addition below "RTN","TMGNDF3B",356,0) . . else if (mode>0)&(mode<5) set showName=$order(NameInfo(IdxName,"")) "RTN","TMGNDF3B",357,0) . . if (showName'="") set @ref@(count)=name_"^"_IEN_$char(9)_showName set count=count+1 "RTN","TMGNDF3B",358,0) "RTN","TMGNDF3B",359,0) set @ref@("HD")=$get(HdrText,"MENU") "RTN","TMGNDF3B",360,0) "RTN","TMGNDF3B",361,0) ;"Note: Rules of use: "RTN","TMGNDF3B",362,0) ;" ref must=^TMP("VEE",$J) "RTN","TMGNDF3B",363,0) ;" Each line should be in this format: "RTN","TMGNDF3B",364,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF3B",365,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF3B",366,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF3B",367,0) ;" Results come back in: "RTN","TMGNDF3B",368,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF3B",369,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF3B",370,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGNDF3B",371,0) "RTN","TMGNDF3B",372,0) write !,"Passing off to Selector..." "RTN","TMGNDF3B",373,0) D SELECT^%ZVEMKT(ref) "RTN","TMGNDF3B",374,0) "RTN","TMGNDF3B",375,0) set ref="^TMP(""VPE"",""SELECT"","_$J_")" "RTN","TMGNDF3B",376,0) new number set number="" "RTN","TMGNDF3B",377,0) for set number=$order(@ref@(number)) quit:(number="") do "RTN","TMGNDF3B",378,0) . new ReturnValue set ReturnValue=$piece(@ref@(number),$char(9),1) "RTN","TMGNDF3B",379,0) . new drugName set drugName=$piece(ReturnValue,"^",1) "RTN","TMGNDF3B",380,0) . new IEN set IEN=$piece(ReturnValue,"^",2) "RTN","TMGNDF3B",381,0) . set @pSelList@(drugName,IEN)="" "RTN","TMGNDF3B",382,0) "RTN","TMGNDF3B",383,0) quit "RTN","TMGNDF3B",384,0) "RTN","TMGNDF3B",385,0) "RTN","TMGNDF3B",386,0) DoWeed(pList,pDelList) "RTN","TMGNDF3B",387,0) ;"Purpose: To remove all items in pDelList from pList "RTN","TMGNDF3B",388,0) ;"Input: pList -- PASS BY NAME-- list of drugs to be edited, as created by FillList(pList) "RTN","TMGNDF3B",389,0) ;" format: @pList@(-1)=ItemsCount <-- REMOVED "RTN","TMGNDF3B",390,0) ;" @pList@(DrugName,IEN)="" "RTN","TMGNDF3B",391,0) ;" @pList@(DrugName,IEN)="" "RTN","TMGNDF3B",392,0) ;" pDelList -- PASS BY NAME -- list of drugs to be removed, as created by UsrWeedList "RTN","TMGNDF3B",393,0) ;" format: @pDelList@(DrugName,IEN)="" "RTN","TMGNDF3B",394,0) ;" @pDelList@(DrugName,IEN)="" "RTN","TMGNDF3B",395,0) "RTN","TMGNDF3B",396,0) new % set %=2 "RTN","TMGNDF3B",397,0) if '$data(pDelList) goto DWDone "RTN","TMGNDF3B",398,0) "RTN","TMGNDF3B",399,0) write "Setting selected imports to be SKIPPED... " "RTN","TMGNDF3B",400,0) new drugName "RTN","TMGNDF3B",401,0) set drugName=$order(@pDelList@(0)) "RTN","TMGNDF3B",402,0) if drugName'="" for do quit:(drugName="") "RTN","TMGNDF3B",403,0) . new IEN set IEN=$order(@pDelList@(drugName,0)) "RTN","TMGNDF3B",404,0) . if IEN'="" for do quit:(IEN="") "RTN","TMGNDF3B",405,0) . . kill @pList@(drugName,IEN) "RTN","TMGNDF3B",406,0) . . set IEN=$order(@pDelList@(drugName,IEN)) "RTN","TMGNDF3B",407,0) . set drugName=$order(@pDelList@(drugName)) "RTN","TMGNDF3B",408,0) "RTN","TMGNDF3B",409,0) ;"write "Counting drugs in list... " "RTN","TMGNDF3B",410,0) ;"set @pList@(-1)=$$ListCt^TMGMISC(pList)-1 ;"remove count of ItemsCount node "RTN","TMGNDF3B",411,0) "RTN","TMGNDF3B",412,0) DWDone "RTN","TMGNDF3B",413,0) quit "RTN","TMGNDF3B",414,0) "RTN","TMGNDF3B",415,0) "RTN","TMGNDF3B",416,0) GetInfo(IEN,array) "RTN","TMGNDF3B",417,0) ;"Purpose: to get all the associated names linked to a DRUG file entry "RTN","TMGNDF3B",418,0) ;"Input: IEN -- the IEN in file 22706.9 "RTN","TMGNDF3B",419,0) ;" array -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF3B",420,0) ;" array("DRUG NAME",Name)="" NAME (.04) FROM 22706.9 "RTN","TMGNDF3B",421,0) ;" array("VAP NAME",Name)="" Name from VA PRODUCT file "RTN","TMGNDF3B",422,0) ;" array("FDA IMPORT NAME",Names)="" Name from .05 TRADE NAME IN 22706.9 "RTN","TMGNDF3B",423,0) ;" array("VA GENERIC NAME",Name)="" Name from VA GENERIC file "RTN","TMGNDF3B",424,0) ;" array("MODES",1)="DRUG NAME" "RTN","TMGNDF3B",425,0) ;" array("MODES",2)="VAP NAME" "RTN","TMGNDF3B",426,0) ;" array("MODES",3)="FDA IMPORT NAME" "RTN","TMGNDF3B",427,0) ;" array("MODES",4)="VA GENERIC NAME" "RTN","TMGNDF3B",428,0) ;"results: none "RTN","TMGNDF3B",429,0) "RTN","TMGNDF3B",430,0) new showName "RTN","TMGNDF3B",431,0) kill array "RTN","TMGNDF3B",432,0) "RTN","TMGNDF3B",433,0) set array("MODES",1)="DRUG NAME" "RTN","TMGNDF3B",434,0) set array("MODES",2)="VAP NAME" "RTN","TMGNDF3B",435,0) set array("MODES",3)="FDA IMPORT NAME" "RTN","TMGNDF3B",436,0) set array("MODES",4)="VA GENERIC NAME" "RTN","TMGNDF3B",437,0) "RTN","TMGNDF3B",438,0) ;"new vapIEN set vapIEN=+$piece($get(^PSDRUG(IEN,"ND")),"^",3) "RTN","TMGNDF3B",439,0) new vapIEN set vapIEN=+$piece($get(^TMG(22706.9,IEN,6)),"^",2) "RTN","TMGNDF3B",440,0) if vapIEN'=0 do "RTN","TMGNDF3B",441,0) . set showName=$piece($get(^PSNDF(50.68,vapIEN,0)),"^",1) "RTN","TMGNDF3B",442,0) . set:(showName'="") array("VAP NAME",showName)="" "RTN","TMGNDF3B",443,0) . . else if mode=3 do ;"Display by FDA import name "RTN","TMGNDF3B",444,0) "RTN","TMGNDF3B",445,0) ;"new vagIEN set vagIEN=+$piece($get(^PSNDF(50.68,vapIEN,0)),"^",2) "RTN","TMGNDF3B",446,0) new vagIEN set vagIEN=+$piece($get(^TMG(22706.9,IEN,1)),"^",3) "RTN","TMGNDF3B",447,0) if vagIEN'=0 do "RTN","TMGNDF3B",448,0) . set showName=$piece($get(^PSNDF(50.6,vagIEN,0)),"^",1) "RTN","TMGNDF3B",449,0) . set:(showName'="") array("VA GENERIC NAME",showName)="" "RTN","TMGNDF3B",450,0) "RTN","TMGNDF3B",451,0) ;"set showName=$piece($get(^PSDRUG(IEN,0)),"^",1) "RTN","TMGNDF3B",452,0) set showName=$piece($get(^TMG(22706.9,IEN,7)),"^",6) ;"7;6 = LONG NAME "RTN","TMGNDF3B",453,0) set:(showName'="") array("DRUG NAME",showName)="" "RTN","TMGNDF3B",454,0) "RTN","TMGNDF3B",455,0) set showName=$piece($get(^TMG(22706.9,IEN,0)),"^",4) ;"0;4 = TRADENAME "RTN","TMGNDF3B",456,0) set:(showName'="") array("FDA IMPORT NAME",showName)="" "RTN","TMGNDF3B",457,0) "RTN","TMGNDF3B",458,0) quit "RTN","TMGNDF3B",459,0) "RTN","TMGNDF3B",460,0) "RTN","TMGNDF3B",461,0) "RTN","TMGNDF3B",462,0) "RTN","TMGNDF3C") 0^50^B5446 "RTN","TMGNDF3C",1,0) TMGNDF3C ;TMG/kst/FDA Import: Create DRUG entries ;03/25/06 "RTN","TMGNDF3C",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF3C",3,0) "RTN","TMGNDF3C",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF3C",5,0) ;" Creation of records in file 50 (DRUG file) "RTN","TMGNDF3C",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF3C",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF3C",8,0) ;"11-21-2006 "RTN","TMGNDF3C",9,0) "RTN","TMGNDF3C",10,0) ;"======================================================================= "RTN","TMGNDF3C",11,0) ;" API -- Public Functions. "RTN","TMGNDF3C",12,0) ;"======================================================================= "RTN","TMGNDF3C",13,0) ;"Menu "RTN","TMGNDF3C",14,0) "RTN","TMGNDF3C",15,0) ;"Refresh1(IEN22706d9,Option) -- Refresh one drug from 22706.9 "RTN","TMGNDF3C",16,0) ;"RefreshBatch(IENArray,Option) -- Refres batch entries in 22706.9 "RTN","TMGNDF3C",17,0) "RTN","TMGNDF3C",18,0) ;"======================================================================= "RTN","TMGNDF3C",19,0) ;" Private Functions. "RTN","TMGNDF3C",20,0) ;"======================================================================= "RTN","TMGNDF3C",21,0) ;"RefreshNonSkips -- Refresh all non-skipped records in 22706.9 "RTN","TMGNDF3C",22,0) ;"GetAddList(List): get list of entries in VA PRODUCT (50.68) not having corresponding entry in DRUG file (50) "RTN","TMGNDF3C",23,0) ;"EnsureFromList(List) -- Add to DRUG file (50) from TMG FDA IMPORT COMPILED "RTN","TMGNDF3C",24,0) ;"Update50(IEN50,DrugInfo,Option) -- refresh info in DRUG (50) file, or add if it doesn't exist (or delete if needed) "RTN","TMGNDF3C",25,0) ;"GetTMGDrugInfo(fdaIEN,DrugInfo) -- Create a very abbreviated version of the DrugInfo array "RTN","TMGNDF3C",26,0) ;"Stuff50(IEN50,DrugInfo,Option) -- synch record(s) in the DRUG file, based on entry from VA PRODUCT file "RTN","TMGNDF3C",27,0) ;"SetupFDA(DrugInfo,IENS,TMGFDA) -- setup FDA for data for record in DRUG file "RTN","TMGNDF3C",28,0) ;"AddMsg(IEN50,Msg) -- Add a message in the Activity log field "RTN","TMGNDF3C",29,0) "RTN","TMGNDF3C",30,0) ;"======================================================================= "RTN","TMGNDF3C",31,0) ;"======================================================================= "RTN","TMGNDF3C",32,0) ;"NOTE: Data mapping: "RTN","TMGNDF3C",33,0) ;" File 50, .01 field (name) is filled with data from file 22706.9, from on "RTN","TMGNDF3C",34,0) ;" of two possible fields: "RTN","TMGNDF3C",35,0) ;" If entry in 50 represents a GENERICNAME drug, then .01 <--- .076 "RTN","TMGNDF3C",36,0) ;" If entry in 50 represents a TRADENAME drug, then .01 <--- .056 "RTN","TMGNDF3C",37,0) ;"======================================================================= "RTN","TMGNDF3C",38,0) ;"======================================================================= "RTN","TMGNDF3C",39,0) ;"Q: Where is BatchTo50 (i.e. 50.68-->50)?? "RTN","TMGNDF3C",40,0) ;"A: There are many entries in 50.68 that I don't want put into 50, so I need "RTN","TMGNDF3C",41,0) ;" to do this: 22706.9 --> 50.68 "RTN","TMGNDF3C",42,0) ;" 22706.9 --> 50 "RTN","TMGNDF3C",43,0) ;" instead of this: 22706.9 --> 50.68 --> 50 "RTN","TMGNDF3C",44,0) ;"======================================================================= "RTN","TMGNDF3C",45,0) Menu "RTN","TMGNDF3C",46,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF3C",47,0) "RTN","TMGNDF3C",48,0) new Menu,UsrSlct "RTN","TMGNDF3C",49,0) set Menu(0)="Pick Option for Synchronizing Imports Data to file 50 (3C)" "RTN","TMGNDF3C",50,0) set Menu(1)="Synchronize DRUG file with import data"_$char(9)_"RefreshNonSkips" "RTN","TMGNDF3C",51,0) set Menu(2)="Verify Synchronization"_$char(9)_"VerifySync" "RTN","TMGNDF3C",52,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF3C",53,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF3C",54,0) "RTN","TMGNDF3C",55,0) MC1 write # "RTN","TMGNDF3C",56,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF3C",57,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF3C",58,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF3C",59,0) "RTN","TMGNDF3C",60,0) if UsrSlct="RefreshNonSkips" do RefreshNonSkips goto MC1 "RTN","TMGNDF3C",61,0) if UsrSlct="VerifySync" do VerifySync goto MC1 "RTN","TMGNDF3C",62,0) if UsrSlct="Prev" goto Menu^TMGNDF3A ;"quit can occur from there... "RTN","TMGNDF3C",63,0) if UsrSlct="Next" goto Menu^TMGNDF3D ;"quit can occur from there... "RTN","TMGNDF3C",64,0) goto MC1 "RTN","TMGNDF3C",65,0) "RTN","TMGNDF3C",66,0) MCDone "RTN","TMGNDF3C",67,0) quit "RTN","TMGNDF3C",68,0) "RTN","TMGNDF3C",69,0) "RTN","TMGNDF3C",70,0) RefreshNonSkips "RTN","TMGNDF3C",71,0) ;"Purpose: To work on ALL records in 22706.9 that are not marked to be "RTN","TMGNDF3C",72,0) ;" skipped, and ensure that all is refreshed appropriately "RTN","TMGNDF3C",73,0) "RTN","TMGNDF3C",74,0) new tempList "RTN","TMGNDF3C",75,0) "RTN","TMGNDF3C",76,0) new AddCt,OKCt "RTN","TMGNDF3C",77,0) set AddCt=0,OKCt=0 "RTN","TMGNDF3C",78,0) new Itr,IEN "RTN","TMGNDF3C",79,0) new abort set abort=0 "RTN","TMGNDF3C",80,0) write !,"Gathering list of imports to use (those not marked to be skipped)...",! "RTN","TMGNDF3C",81,0) set IEN22706d9=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3C",82,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF3C",83,0) if IEN22706d9'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF3C",84,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3C",85,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3C",86,0) . new tIEN50 set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDF3C",87,0) . new gIEN50 set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDF3C",88,0) . set tempList(IEN22706d9)="" "RTN","TMGNDF3C",89,0) . if (tIEN50>0)&(gIEN50>0) set OKCt=OKCt+1 "RTN","TMGNDF3C",90,0) . else set AddCt=AddCt+1 "RTN","TMGNDF3C",91,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3C",92,0) "RTN","TMGNDF3C",93,0) write !,AddCt," items may be added to DRUG file (if appropriate).",! "RTN","TMGNDF3C",94,0) write OKCt," items will be refreshed in DRUG file.",! "RTN","TMGNDF3C",95,0) "RTN","TMGNDF3C",96,0) new % set %=1 "RTN","TMGNDF3C",97,0) write "Proceed" do YN^DICN write ! "RTN","TMGNDF3C",98,0) if %'=1 goto RNSDone "RTN","TMGNDF3C",99,0) "RTN","TMGNDF3C",100,0) do EnsureFromList(.tempList) "RTN","TMGNDF3C",101,0) "RTN","TMGNDF3C",102,0) RNSDone "RTN","TMGNDF3C",103,0) quit "RTN","TMGNDF3C",104,0) "RTN","TMGNDF3C",105,0) RefreshBatch(IENArray,Option) "RTN","TMGNDF3C",106,0) ;"Purpose: To take entries in 22706.9 and refresh them "RTN","TMGNDF3C",107,0) ;"Input: IENArray -- PASS BY REFERENCE. Array of IENs from 22706.9 "RTN","TMGNDF3C",108,0) ;" IENArray(IEN22706d9)="" "RTN","TMGNDF3C",109,0) ;" IENArray(IEN22706d9)="" "RTN","TMGNDF3C",110,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF3C",111,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF3C",112,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF3C",113,0) ;" Option("QUIET")=1 "RTN","TMGNDF3C",114,0) "RTN","TMGNDF3C",115,0) ;"Results: none "RTN","TMGNDF3C",116,0) "RTN","TMGNDF3C",117,0) new IEN22706d9,Itr "RTN","TMGNDF3C",118,0) new abort set abort=0 "RTN","TMGNDF3C",119,0) set IEN22706d9=$$ItrAInit^TMGITR("IENArray",.Itr) "RTN","TMGNDF3C",120,0) do PrepProgress^TMGITR(.Itr,1,1,"IEN22706d9") "RTN","TMGNDF3C",121,0) if IEN22706d9'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN22706d9)="")!abort "RTN","TMGNDF3C",122,0) . ;"write !,"Refreshing compiled entry #",IEN227606d9,! "RTN","TMGNDF3C",123,0) . do Refresh1(IEN22706d9,.Option) "RTN","TMGNDF3C",124,0) quit "RTN","TMGNDF3C",125,0) "RTN","TMGNDF3C",126,0) "RTN","TMGNDF3C",127,0) Refresh1(IEN22706d9,Option) "RTN","TMGNDF3C",128,0) ;"Purpose: To take one entry in 22706.9 and refresh it "RTN","TMGNDF3C",129,0) ;"Input: IEN22706d9 -- IEN from 22706.9 "RTN","TMGNDF3C",130,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF3C",131,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF3C",132,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF3C",133,0) ;"Results: none "RTN","TMGNDF3C",134,0) "RTN","TMGNDF3C",135,0) new gIEN50,tIEN50 "RTN","TMGNDF3C",136,0) new skip "RTN","TMGNDF3C",137,0) set skip=($piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1) "RTN","TMGNDF3C",138,0) "RTN","TMGNDF3C",139,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF3C",140,0) . new temp "RTN","TMGNDF3C",141,0) . set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDF3C",142,0) . set Option("IEN50","TRADE")=tIEN50 "RTN","TMGNDF3C",143,0) . set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDF3C",144,0) . set Option("IEN50","GENERIC")=gIEN50 "RTN","TMGNDF3C",145,0) . set Option("FIX CHAIN","IEN22706d9")=IEN22706d9 "RTN","TMGNDF3C",146,0) "RTN","TMGNDF3C",147,0) new List "RTN","TMGNDF3C",148,0) if skip set List(IEN22706d9)="S" "RTN","TMGNDF3C",149,0) else set List(IEN22706d9)="" "RTN","TMGNDF3C",150,0) "RTN","TMGNDF3C",151,0) do EnsureFromList(.List,.Option) "RTN","TMGNDF3C",152,0) "RTN","TMGNDF3C",153,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF3C",154,0) . if tIEN50>0 set temp=$$Fix1Drug^TMGNDF3D(tIEN50,IEN22706d9) "RTN","TMGNDF3C",155,0) . if gIEN50>0 set temp=$$Fix1Drug^TMGNDF3D(gIEN50,IEN22706d9) "RTN","TMGNDF3C",156,0) "RTN","TMGNDF3C",157,0) quit "RTN","TMGNDF3C",158,0) "RTN","TMGNDF3C",159,0) "RTN","TMGNDF3C",160,0) EnsureFromList(List,Option) "RTN","TMGNDF3C",161,0) ;"Purpose: to add entries to, or refresh fields in, DRUG file (50) based on "RTN","TMGNDF3C",162,0) ;" data from TMG FDA IMPORT COMPILED (22706.9), "RTN","TMGNDF3C",163,0) ;" OR to ensure that the linked records are properly refreshed. "RTN","TMGNDF3C",164,0) ;" OR ensure that records liked from a skipped record are deleted "RTN","TMGNDF3C",165,0) ;"Input: List -- PASS BY REFERENCE, format: "RTN","TMGNDF3C",166,0) ;" List(IEN22706d9)="" "RTN","TMGNDF3C",167,0) ;" List(IEN22706d9)="" "RTN","TMGNDF3C",168,0) ;" List(IEN22706d9)="S" <-- record now skipped, so ensure linked records are removed "RTN","TMGNDF3C",169,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF3C",170,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF3C",171,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF3C",172,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF3C",173,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF3C",174,0) ;"Results: none "RTN","TMGNDF3C",175,0) "RTN","TMGNDF3C",176,0) new IEN22706d9,Itr "RTN","TMGNDF3C",177,0) new error set error=0 "RTN","TMGNDF3C",178,0) new abort set abort=0 "RTN","TMGNDF3C",179,0) new ChangeCt set ChangeCt=0 "RTN","TMGNDF3C",180,0) new quiet set quiet=($get(Option("QUIET"))=1) "RTN","TMGNDF3C",181,0) do Unlock50^TMGNDFUT "RTN","TMGNDF3C",182,0) "RTN","TMGNDF3C",183,0) if 'quiet write "Scanning import file, to ensure all records in DRUG file are updated...",! "RTN","TMGNDF3C",184,0) set IEN22706d9=$$ItrAInit^TMGITR("List",.Itr) "RTN","TMGNDF3C",185,0) if 'quiet do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF3C",186,0) if IEN22706d9>0 for do quit:($$ItrANext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF3C",187,0) . new DrugInfo,ndcIEN,tempS,error,temp,vapIEN,temp "RTN","TMGNDF3C",188,0) . new skip set skip=($get(List(IEN22706d9))="S") "RTN","TMGNDF3C",189,0) . set error=0,temp=0,tempS="" "RTN","TMGNDF3C",190,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3C",191,0) . set vapIEN=+$piece($get(^TMG(22706.9,IEN22706d9,6)),"^",2) "RTN","TMGNDF3C",192,0) . if skip=0,vapIEN>0,$data(^PSNDF(50.68,vapIEN))=0 do "RTN","TMGNDF3C",193,0) . . if 'quiet write "Pointer to VA PRODUCT from File 22709.9, IEN# ",IEN22706d9," is invalid. Will delete.",! "RTN","TMGNDF3C",194,0) . . set vapIEN=0 "RTN","TMGNDF3C",195,0) . . new TMGMSG,TMGFDA "RTN","TMGNDF3C",196,0) . . set TMGFDA(22706.9,fdaIEN_",",5.5)="@" "RTN","TMGNDF3C",197,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3C",198,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) ;"show errors, even if quiet "RTN","TMGNDF3C",199,0) . if skip=0,vapIEN'>0 set error=1 quit "RTN","TMGNDF3C",200,0) . set temp=$$GetTMGDrugInfo(IEN22706d9,.DrugInfo) "RTN","TMGNDF3C",201,0) . if skip=0,temp=0 set error=1 quit "RTN","TMGNDF3C",202,0) . if skip=1 set Option("DELETING")=1 "RTN","TMGNDF3C",203,0) . ;"--- work on Trade Name link --- "RTN","TMGNDF3C",204,0) . if ($get(DrugInfo("NAME","TRADE"))=$get(DrugInfo("NAME","GENERIC"))) set DrugInfo("NAME","TRADE")="" "RTN","TMGNDF3C",205,0) . new tIEN50 set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) ;"DRUG TRADENAME LINK "RTN","TMGNDF3C",206,0) . set Option("CUR MODE")="TRADE" "RTN","TMGNDF3C",207,0) . set temp=$$Update50(tIEN50,.DrugInfo,.Option) ;"may chain forward "RTN","TMGNDF3C",208,0) . if temp=1 set ChangeCt=ChangeCt+1 "RTN","TMGNDF3C",209,0) . else if temp=-1 set error=1 ;"quit "RTN","TMGNDF3C",210,0) . ;"--- work on Generic Name link --- "RTN","TMGNDF3C",211,0) . new gIEN50 set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) ;"DRUG GENERIC LINK "RTN","TMGNDF3C",212,0) . if gIEN50=tIEN50 set gIEN50=0 "RTN","TMGNDF3C",213,0) . set Option("CUR MODE")="GENERIC" "RTN","TMGNDF3C",214,0) . set temp=$$Update50(gIEN50,.DrugInfo,.Option) ;"may chain forward "RTN","TMGNDF3C",215,0) . if temp=1 set ChangeCt=ChangeCt+1 "RTN","TMGNDF3C",216,0) . else if temp=-1 set error=1 ;"quit "RTN","TMGNDF3C",217,0) if error write "Error with import : IEN22706d9=",IEN22706d9,! "RTN","TMGNDF3C",218,0) "RTN","TMGNDF3C",219,0) if 'quiet do "RTN","TMGNDF3C",220,0) . write ChangeCt," Records Modified.",! "RTN","TMGNDF3C",221,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF3C",222,0) "RTN","TMGNDF3C",223,0) do Unlock50^TMGNDFUT "RTN","TMGNDF3C",224,0) quit "RTN","TMGNDF3C",225,0) "RTN","TMGNDF3C",226,0) "RTN","TMGNDF3C",227,0) GetTMGDrugInfo(IEN22706d9,DrugInfo) "RTN","TMGNDF3C",228,0) ;"Purpose: Create a very abbreviated version of the DrugInfo array "RTN","TMGNDF3C",229,0) ;" This is because calling GetDrugInfo^TMGNDF1A is unneccesarily SLOW "RTN","TMGNDF3C",230,0) ;" Also, it makes one dependant on FDA primary files. "RTN","TMGNDF3C",231,0) ;"Input: IEN22706d9 -- IEN in file 22706.9 "RTN","TMGNDF3C",232,0) ;" DrugInfo -- PASS BY REFERENCE. Format: "RTN","TMGNDF3C",233,0) ;" DrugInfo("NDC") "RTN","TMGNDF3C",234,0) ;"Output: DrugInfo("NAME","TRADE")=.056 field "RTN","TMGNDF3C",235,0) ;" DrugInfo("NAME","GENERIC")=.076 field "RTN","TMGNDF3C",236,0) ;" DrugInfo("SOURCE IEN")=source IEN in 22706.9 "RTN","TMGNDF3C",237,0) ;" DrugInfo("IEN 50.68")=field 5.5, a pointer to 50.68 (VA PRODUCT) "RTN","TMGNDF3C",238,0) ;"Results: 1=OK to continue, 0=error "RTN","TMGNDF3C",239,0) ;"NOTE: 11/5/07 Modifying to make use of fields .055 and .075, where name is "RTN","TMGNDF3C",240,0) ;" prepaired and stored in a previous step. "RTN","TMGNDF3C",241,0) ;"NOTE: 11/10/07 Modifying to make use of fields .056 and .076, where name is "RTN","TMGNDF3C",242,0) ;" prepaired and stored in a previous step. "RTN","TMGNDF3C",243,0) "RTN","TMGNDF3C",244,0) kill DrugInfo "RTN","TMGNDF3C",245,0) new result set result=1 "RTN","TMGNDF3C",246,0) set DrugInfo("NDC")=$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",1) "RTN","TMGNDF3C",247,0) if DrugInfo("NDC")="" set result=0 "RTN","TMGNDF3C",248,0) "RTN","TMGNDF3C",249,0) set DrugInfo("SOURCE IEN")=IEN22706d9 "RTN","TMGNDF3C",250,0) set DrugInfo("IEN 50.68")=+$piece($get(^TMG(22706.9,IEN22706d9,6)),"^",2) "RTN","TMGNDF3C",251,0) "RTN","TMGNDF3C",252,0) new tempS set tempS=$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",1) ;".056 TRADENAME FORM DOSE UNIT - 40 "RTN","TMGNDF3C",253,0) if tempS'="" set DrugInfo("NAME","TRADE")=tempS "RTN","TMGNDF3C",254,0) "RTN","TMGNDF3C",255,0) new tempS set tempS=$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",2) ;".076 GENERICNAME FORM DOSE UNT - 40 "RTN","TMGNDF3C",256,0) if tempS'="" set DrugInfo("NAME","GENERIC")=tempS "RTN","TMGNDF3C",257,0) "RTN","TMGNDF3C",258,0) GDIDone "RTN","TMGNDF3C",259,0) quit result "RTN","TMGNDF3C",260,0) "RTN","TMGNDF3C",261,0) "RTN","TMGNDF3C",262,0) Update50(IEN50,DrugInfo,Option) "RTN","TMGNDF3C",263,0) ;"Purpose: to refresh info in DRUG file, or add if it doesn't exist (or delete if needed) "RTN","TMGNDF3C",264,0) ;"Input: IEN50: Target IEN to refresh, or 0 if needs to be added "RTN","TMGNDF3C",265,0) ;" DrugInfo -- PASS BY REFERENCE. Format: "RTN","TMGNDF3C",266,0) ;" DrugInfo("NDC") "RTN","TMGNDF3C",267,0) ;" DrugInfo("NAME","TRADE")=.056 field "RTN","TMGNDF3C",268,0) ;" DrugInfo("NAME","GENERIC")=.076 field "RTN","TMGNDF3C",269,0) ;" DrugInfo("SOURCE IEN")=source IEN in 22706.9 "RTN","TMGNDF3C",270,0) ;" DrugInfo("IEN 50.68")=field 5.5, a pointer to 50.68 (VA PRODUCT) "RTN","TMGNDF3C",271,0) ;" Option -- NON-OPTIONAL part. Format: "RTN","TMGNDF3C",272,0) ;" Option("CUR MODE")="TRADE" "RTN","TMGNDF3C",273,0) ;" Option -- OPTIONAL part. Format: "RTN","TMGNDF3C",274,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF3C",275,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF3C",276,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF3C",277,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF3C",278,0) ;" Option("DELETING")=1 <-- deleting chain (not IEN22706d9) "RTN","TMGNDF3C",279,0) ;"Result: -1 = error, 0=info refreshed, 1=record added. "RTN","TMGNDF3C",280,0) "RTN","TMGNDF3C",281,0) new result set result=0 "RTN","TMGNDF3C",282,0) new quiet set quiet=$get(Option("QUIET"))=1 "RTN","TMGNDF3C",283,0) new IEN22706d9 set IEN22706d9=+$get(DrugInfo("SOURCE IEN")) "RTN","TMGNDF3C",284,0) new mode set mode=$get(Option("CUR MODE")) "RTN","TMGNDF3C",285,0) if (mode'="TRADE")&(mode'="GENERIC") set result=-1 goto UDDone "RTN","TMGNDF3C",286,0) "RTN","TMGNDF3C",287,0) new StoreField,node,pce "RTN","TMGNDF3C",288,0) if mode="TRADE" set StoreField=5.6,node=7,pce=1 "RTN","TMGNDF3C",289,0) else set StoreField=5.7,node=7,pce=2 "RTN","TMGNDF3C",290,0) "RTN","TMGNDF3C",291,0) new drugName set drugName=$get(DrugInfo("NAME",mode)) "RTN","TMGNDF3C",292,0) set DrugInfo("NAME",mode)=drugName "RTN","TMGNDF3C",293,0) if (drugName="")!(drugName="")!($get(Option("DELETING"))=1) do goto UDDone "RTN","TMGNDF3C",294,0) . do Kill50^TMGNDFUT(IEN50,IEN22706d9,mode,quiet) ;"is OK if IEN50=0 "RTN","TMGNDF3C",295,0) . set result=-1 "RTN","TMGNDF3C",296,0) "RTN","TMGNDF3C",297,0) if (IEN50>0),$data(^PSDRUG(IEN50))=0 do "RTN","TMGNDF3C",298,0) . set IEN50=0 ;"I found case of dangling pointer "RTN","TMGNDF3C",299,0) "RTN","TMGNDF3C",300,0) if IEN50=0 do ;"Create stub entry with drug name in .01 field "RTN","TMGNDF3C",301,0) . new PSSZ set PSSZ=1 ;"allows code to add entries into DRUG file. "RTN","TMGNDF3C",302,0) . new TMGFDA,TMGMSG,TMGIEN,IENS "RTN","TMGNDF3C",303,0) . set TMGFDA(50,"+1,",.01)=drugName "RTN","TMGNDF3C",304,0) . do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF3C",305,0) . do ShowDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3C",306,0) . set IEN50=+$get(TMGIEN(1)) if IEN50=0 quit "RTN","TMGNDF3C",307,0) . do AddMsg(IEN50,"TMG AUTOADDED FROM FDA") "RTN","TMGNDF3C",308,0) . set Option("IEN50",mode)=IEN50 "RTN","TMGNDF3C",309,0) . set Option("IEN50",mode,"NAME")=drugName "RTN","TMGNDF3C",310,0) "RTN","TMGNDF3C",311,0) set DrugInfo("CUR MODE")=mode "RTN","TMGNDF3C",312,0) set temp=$$Stuff50(IEN50,.DrugInfo,.Option) ;"no chain forward "RTN","TMGNDF3C",313,0) if temp=0 set result=-1 "RTN","TMGNDF3C",314,0) if temp=2 set result=1 "RTN","TMGNDF3C",315,0) "RTN","TMGNDF3C",316,0) ;"Ensure pointer to DRUG (50) is stored in 22706.9 "RTN","TMGNDF3C",317,0) if $piece($get(^TMG(22706.9,IEN22706d9,node)),"^",pce)'=IEN50 do "RTN","TMGNDF3C",318,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3C",319,0) . set TMGFDA(22706.9,IEN22706d9_",",StoreField)=IEN50 "RTN","TMGNDF3C",320,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3C",321,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3C",322,0) . set Option("IEN50",mode)=IEN50 "RTN","TMGNDF3C",323,0) "RTN","TMGNDF3C",324,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF3C",325,0) . new temp set temp=$$POIFromTMG^TMGNDF4A(IEN22706d9,.Option) ;" --> more chain from here "RTN","TMGNDF3C",326,0) . ;"if $get(Option("DELETING"))=1 do "RTN","TMGNDF3C",327,0) . ;". do Kill50^TMGNDFUT(IEN50,IEN22706d9,mode,quiet) ;"is OK if IEN50=0 "RTN","TMGNDF3C",328,0) "RTN","TMGNDF3C",329,0) UDDone "RTN","TMGNDF3C",330,0) quit result "RTN","TMGNDF3C",331,0) "RTN","TMGNDF3C",332,0) "RTN","TMGNDF3C",333,0) Stuff50(IEN50,DrugInfo,Option) "RTN","TMGNDF3C",334,0) ;"Purpose: To synch record(s) in the DRUG file "RTN","TMGNDF3C",335,0) ;"Input: IEN50 -- IEN of record in file 50 to update "RTN","TMGNDF3C",336,0) ;" DrugInfo -- PASS BY REFERENCE -- Drug info array. Format: "RTN","TMGNDF3C",337,0) ;" DrugInfo("NAME","GENERIC")=e.g. NAME: DILTIAZEM 240MG "RTN","TMGNDF3C",338,0) ;" DrugInfo("NAME","TRADE")=e.g. NAME: CARDIZEM CD 240MG "RTN","TMGNDF3C",339,0) ;" DrugInfo("NDC") "RTN","TMGNDF3C",340,0) ;" DrugInfo("SOURCE IEN")=source IEN in 22706.9 "RTN","TMGNDF3C",341,0) ;" DrugInfo("IEN 50.68")=field 5.5, a pointer to 50.68 (VA PRODUCT) "RTN","TMGNDF3C",342,0) ;" Option -- NON-OPTIONAL part. Format: "RTN","TMGNDF3C",343,0) ;" Option("CUR MODE")="TRADE" "RTN","TMGNDF3C",344,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF3C",345,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF3C",346,0) ;" to file 50, POI, OI, OQV etc. "RTN","TMGNDF3C",347,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF3C",348,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF3C",349,0) ;"Output: A record will be added to file DRUG (50) "RTN","TMGNDF3C",350,0) ;"Result: 1=OK to continue, 2=change made, 0 if error "RTN","TMGNDF3C",351,0) "RTN","TMGNDF3C",352,0) ;"Note: must set PSSZ=1 to be allowed to enter entries into DRUG file. "RTN","TMGNDF3C",353,0) "RTN","TMGNDF3C",354,0) new result set result=1 ;"default to success -- don't change. "RTN","TMGNDF3C",355,0) new PSSZ set PSSZ=1 ;"allows code to add entries into DRUG file. "RTN","TMGNDF3C",356,0) "RTN","TMGNDF3C",357,0) ;"Remove any synonyms "RTN","TMGNDF3C",358,0) RF1 new numSyns "RTN","TMGNDF3C",359,0) for do quit:(numSyns'>0) "RTN","TMGNDF3C",360,0) . set numSyns=+$piece($get(^PSDRUG(IEN50,1,0)),"^",4) ;"number of records "RTN","TMGNDF3C",361,0) . if numSyns=0 quit "RTN","TMGNDF3C",362,0) RF2 . set subIEN=$order(^PSDRUG(IEN50,1,0)) "RTN","TMGNDF3C",363,0) . if (subIEN'>0) set numSyns=0 quit "RTN","TMGNDF3C",364,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3C",365,0) . set TMGFDA(50.1,subIEN_","_IEN50_",",.01)="@" "RTN","TMGNDF3C",366,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3C",367,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3C",368,0) . set result=2 "RTN","TMGNDF3C",369,0) "RTN","TMGNDF3C",370,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF3C",371,0) "RTN","TMGNDF3C",372,0) set result=$$SetupFDA(.DrugInfo,IEN50_",",.TMGFDA) "RTN","TMGNDF3C",373,0) if result=0 goto RFDone "RTN","TMGNDF3C",374,0) new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF3C",375,0) if $data(TMGFDA)=0 goto RFDone "RTN","TMGNDF3C",376,0) "RTN","TMGNDF3C",377,0) do FILE^DIE("KS","TMGFDA","TMGMSG") "RTN","TMGNDF3C",378,0) if $data(TMGMSG("DIERR")) do goto RFDone "RTN","TMGNDF3C",379,0) . set result=0 "RTN","TMGNDF3C",380,0) . if $get(Quiet)=1 quit "RTN","TMGNDF3C",381,0) . write !,"Error editing record in file 50",! "RTN","TMGNDF3C",382,0) . new PriorErrorFound "RTN","TMGNDF3C",383,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF3C",384,0) "RTN","TMGNDF3C",385,0) do AddMsg(IEN50,"TMG AUTO UPDATED FROM FDA") "RTN","TMGNDF3C",386,0) set result=2 ;"update made. "RTN","TMGNDF3C",387,0) "RTN","TMGNDF3C",388,0) RFDone quit result "RTN","TMGNDF3C",389,0) "RTN","TMGNDF3C",390,0) "RTN","TMGNDF3C",391,0) AddMsg(IEN50,Msg) "RTN","TMGNDF3C",392,0) ;"Purpose: to Add a message in the Activity log field "RTN","TMGNDF3C",393,0) ;"Input: IEN50 -- the IEN in DRUG file "RTN","TMGNDF3C",394,0) ;" Msg -- the Message to add (a string) "RTN","TMGNDF3C",395,0) ;"results: none. "RTN","TMGNDF3C",396,0) "RTN","TMGNDF3C",397,0) ;"Check that record was added, then then add subfile entries: "RTN","TMGNDF3C",398,0) set IENS="+1,"_IEN50_"," "RTN","TMGNDF3C",399,0) kill TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF3C",400,0) ;" 214 ACTIVITY LOG <-Mult [50.0214DA] "RTN","TMGNDF3C",401,0) ;" .01 -ACTIVITY LOG [D] "RTN","TMGNDF3C",402,0) ;" 1 -REASON [S] "RTN","TMGNDF3C",403,0) ;" 2 -INITIATOR OF ACTIVITY <-Pntr [P200'] "RTN","TMGNDF3C",404,0) ;" 3 -FIELD EDITED [F] "RTN","TMGNDF3C",405,0) ;" 4 -NEW VALUE [F] "RTN","TMGNDF3C",406,0) ;" 5 -NDF UPDATE [F] "RTN","TMGNDF3C",407,0) set TMGFDA(50.0214,IENS,.01)="NOW" "RTN","TMGNDF3C",408,0) set TMGFDA(50.0214,IENS,1)="E" "RTN","TMGNDF3C",409,0) set TMGFDA(50.0214,IENS,2)="`"_DUZ "RTN","TMGNDF3C",410,0) set TMGFDA(50.0214,IENS,3)="ALL FIELDS" "RTN","TMGNDF3C",411,0) set TMGFDA(50.0214,IENS,4)=Msg "RTN","TMGNDF3C",412,0) "RTN","TMGNDF3C",413,0) do UPDATE^DIE("ES","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF3C",414,0) if $get(Quiet)'=1 do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3C",415,0) "RTN","TMGNDF3C",416,0) quit "RTN","TMGNDF3C",417,0) "RTN","TMGNDF3C",418,0) "RTN","TMGNDF3C",419,0) SetupFDA(DrugInfo,IENS,TMGFDA) "RTN","TMGNDF3C",420,0) ;"Purpose: To set up the FDA (Filman data array) for the data that will go into "RTN","TMGNDF3C",421,0) ;" a record to the DRUG file, based on entry from VA PRODUCT file "RTN","TMGNDF3C",422,0) ;"Input: DrugInfo -- PASS BY REFERENCE -- Drug info from array GetTMGDrugInfo, and "RTN","TMGNDF3C",423,0) ;" as modified by Add2VAProd^TMGNDF3A "RTN","TMGNDF3C",424,0) ;" Fields used are: "RTN","TMGNDF3C",425,0) ;" DrugInfo("CUR MODE")="GENERIC" or "TRADE" "RTN","TMGNDF3C",426,0) ;" DrugInfo("NAME","GENERIC")=e.g. NAME: DILTIAZEM 240MG "RTN","TMGNDF3C",427,0) ;" DrugInfo("NAME","TRADE")=e.g. NAME: CARDIZEM CD 240MG "RTN","TMGNDF3C",428,0) ;" DrugInfo("NDC") "RTN","TMGNDF3C",429,0) ;" DrugInfo("SOURCE IEN")=source IEN in 22706.9 "RTN","TMGNDF3C",430,0) ;" DrugInfo("IEN 50.68")=field 5.5, a pointer to 50.68 (VA PRODUCT) "RTN","TMGNDF3C",431,0) ;" IENS -- a standard fileman IENS for this FDA to be created with "RTN","TMGNDF3C",432,0) ;" TMGFDA -- PASS BY REFERENCE -- an OUT PARAMETER. This will be a standard "RTN","TMGNDF3C",433,0) ;" fileman FDA "RTN","TMGNDF3C",434,0) ;"Output: TMGFDA will be filled "RTN","TMGNDF3C",435,0) ;"Result: 1=OK to continue, 0 if error "RTN","TMGNDF3C",436,0) "RTN","TMGNDF3C",437,0) ;"NOTE: The FDA that this function contains will contain INTERNAL values "RTN","TMGNDF3C",438,0) "RTN","TMGNDF3C",439,0) new result set result=1 ;"default to success -- don't change. "RTN","TMGNDF3C",440,0) new mode set mode=$get(DrugInfo("CUR MODE")) "RTN","TMGNDF3C",441,0) if (mode'="TRADE")&(mode'="GENERIC") set result=0 goto SUFDone "RTN","TMGNDF3C",442,0) "RTN","TMGNDF3C",443,0) new TMGMSG,TMGIEN "RTN","TMGNDF3C",444,0) new tempS,tempIEN "RTN","TMGNDF3C",445,0) new IEN22706d9 set IEN22706d9=+$get(DrugInfo("SOURCE IEN")) "RTN","TMGNDF3C",446,0) "RTN","TMGNDF3C",447,0) ;"Example Entry. (Edited for fields I care about) "RTN","TMGNDF3C",448,0) ;"#50 .01 GENERIC NAME: DILTIAZEM CD 120MG CAP "RTN","TMGNDF3C",449,0) ;"#50.68 .01 NAME [RFa] "RTN","TMGNDF3C",450,0) ;"#50.68 e.g. NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF3C",451,0) set tempS=$get(DrugInfo("NAME",mode)) "RTN","TMGNDF3C",452,0) set tempS=$translate(tempS,";",":") ;" for some reason ';' is not allowed in .01 field "RTN","TMGNDF3C",453,0) if $length(tempS)>40 set tempS=$extract(tempS,1,37)_"..." "RTN","TMGNDF3C",454,0) set TMGFDA(50,IENS,.01)=tempS "RTN","TMGNDF3C",455,0) "RTN","TMGNDF3C",456,0) ;"#50 22 PSNDF VA PRODUCT NAME ENTRY: DILTIAZEM (CARDIZEM CD) 120MG SA CAP "RTN","TMGNDF3C",457,0) ;"#50.68 .01 NAME [RFa] "RTN","TMGNDF3C",458,0) ;"#50.68 e.g. NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF3C",459,0) new vapIEN set vapIEN=+$get(DrugInfo("IEN 50.68")) "RTN","TMGNDF3C",460,0) if +vapIEN>0 DO "RTN","TMGNDF3C",461,0) . set TMGFDA(50,IENS,22)=vapIEN "RTN","TMGNDF3C",462,0) . new vapName "RTN","TMGNDF3C",463,0) . set vapName=$$GET1^DIQ(50.68,vapIEN,.01) "RTN","TMGNDF3C",464,0) . ;"#50 21 VA PRODUCT NAME: DILTIAZEM (CARDIZEM CD) 120MG SA CAP "RTN","TMGNDF3C",465,0) . ;"#50.68 .01 NAME [RFa] "RTN","TMGNDF3C",466,0) . ;"#50.68 e.g. NAME: DILTIAZEM (CARDIZEM CD) 240MG SA CAP "RTN","TMGNDF3C",467,0) . set TMGFDA(50,IENS,21)=vapName "RTN","TMGNDF3C",468,0) . ;"set TMGFDA(50,IENS,21)=tempS "RTN","TMGNDF3C",469,0) "RTN","TMGNDF3C",470,0) ;"#50 5 STANDARD SIG: T1 CAP QD "RTN","TMGNDF3C",471,0) ;" plan "USE AS DIRECTED" "RTN","TMGNDF3C",472,0) set TMGFDA(50,IENS,5)="USE AS DIRECTED" "RTN","TMGNDF3C",473,0) "RTN","TMGNDF3C",474,0) ;"#50 20 NATIONAL DRUG FILE ENTRY: DILTIAZEM <-Pntr [P50.6, VA GENERIC] "RTN","TMGNDF3C",475,0) set tempIEN=+$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",3) ;"1;3 = field .08 VA GENERIC "RTN","TMGNDF3C",476,0) if tempIEN>0 set TMGFDA(50,IENS,20)=tempIEN "RTN","TMGNDF3C",477,0) "RTN","TMGNDF3C",478,0) ;"#50 25 NATIONAL DRUG CLASS <-Pntr [P50.605'] "RTN","TMGNDF3C",479,0) ;"#50 2 VA CLASSIFICATION [FX] "RTN","TMGNDF3C",480,0) set tempIEN=+$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",5) ;"1;5 = field .09 VA DRUG CLASS "RTN","TMGNDF3C",481,0) set TMGFDA(50,IENS,25)=tempIEN "RTN","TMGNDF3C",482,0) set tempClass=$$GET1^DIQ(50.605,tempIEN_",",.01) "RTN","TMGNDF3C",483,0) if tempClass'="" set TMGFDA(50,IENS,2)=tempClass "RTN","TMGNDF3C",484,0) "RTN","TMGNDF3C",485,0) ;"#50 29 NATIONAL FORMULARY INDICATOR: NO "RTN","TMGNDF3C",486,0) set TMGFDA(50,IENS,29)=0 ;"0=NO, 1=YES "RTN","TMGNDF3C",487,0) "RTN","TMGNDF3C",488,0) ;"#50 31 NDC: 0088-1795-30 "RTN","TMGNDF3C",489,0) new NDC set NDC=$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",1) "RTN","TMGNDF3C",490,0) set NDC=$extract(NDC,2,20) ;"should be in 5-4-2 format, but must be 11 digits, 1st is not significant "RTN","TMGNDF3C",491,0) if NDC'="" set TMGFDA(50,IENS,31)=NDC "RTN","TMGNDF3C",492,0) "RTN","TMGNDF3C",493,0) ;"#50 901 STRENGTH: 120 "RTN","TMGNDF3C",494,0) new tempStr set tempStr=$piece($get(^TMG(22706.9,IEN22706d9,0)),"^",2) ;"0;2=field 1 STRENGTH "RTN","TMGNDF3C",495,0) if tempStr'="" set TMGFDA(50,IENS,901)=tempStr "RTN","TMGNDF3C",496,0) "RTN","TMGNDF3C",497,0) ;"#50 902 UNIT: MG "RTN","TMGNDF3C",498,0) ;"#50.68 3 UNITS <-Pntr [P50.607'a] "RTN","TMGNDF3C",499,0) ;"#50.68 e.g. UNITS: MG "RTN","TMGNDF3C",500,0) new tempUnit set tempUnit=$$GET1^DIQ(50.68,vapIEN,3,"I") "RTN","TMGNDF3C",501,0) if tempUnit'="" set TMGFDA(50,IENS,902)=tempUnit "RTN","TMGNDF3C",502,0) "RTN","TMGNDF3C",503,0) ;"#50 62.02 UNIT DOSE MED ROUTE <-Pntr [*P51.2'] "RTN","TMGNDF3C",504,0) ;"#22706.9 3.1 VA ROUTE <-Pntr [P51.2'] "RTN","TMGNDF3C",505,0) set tempIEN=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",7) ;"7;7 3.1 VA ROUTE "RTN","TMGNDF3C",506,0) if tempIEN>0 set TMGFDA(50,IENS,62.02)=tempIEN "RTN","TMGNDF3C",507,0) "RTN","TMGNDF3C",508,0) SUFDone "RTN","TMGNDF3C",509,0) quit result "RTN","TMGNDF3C",510,0) "RTN","TMGNDF3C",511,0) "RTN","TMGNDF3C",512,0) VerifySync "RTN","TMGNDF3C",513,0) ;"To verify the synchronization, i.e. looking for dangling pointers etc. "RTN","TMGNDF3C",514,0) "RTN","TMGNDF3C",515,0) new ChangeCt set ChangeCt=0 "RTN","TMGNDF3C",516,0) new Itr,IEN22706d9 "RTN","TMGNDF3C",517,0) new abort set abort=0 "RTN","TMGNDF3C",518,0) write !,"Checking Synchronization",! "RTN","TMGNDF3C",519,0) set IEN22706d9=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3C",520,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF3C",521,0) if IEN22706d9'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF3C",522,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3C",523,0) . ;"if +$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3C",524,0) . new tIEN50 set tIEN50=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDF3C",525,0) . set ChangeCt=ChangeCt+$$Verify1(IEN22706d9,tIEN50,"TRADE") "RTN","TMGNDF3C",526,0) . new gIEN50 set gIEN50=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDF3C",527,0) . set ChangeCt=ChangeCt+$$Verify1(IEN22706d9,gIEN50,"GENERIC") "RTN","TMGNDF3C",528,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3C",529,0) "RTN","TMGNDF3C",530,0) do PressToCont^TMGUSRIF "RTN","TMGNDF3C",531,0) "RTN","TMGNDF3C",532,0) quit "RTN","TMGNDF3C",533,0) "RTN","TMGNDF3C",534,0) Verify1(IEN22706d9,IEN50,mode) "RTN","TMGNDF3C",535,0) ;"To Verify one "RTN","TMGNDF3C",536,0) ;"Input: IEN22706d9 "RTN","TMGNDF3C",537,0) ;" IEN50 -- link to DRUG file (either for Generic Drug, or Trade Drug) "RTN","TMGNDF3C",538,0) ;" mode - "GENERIC" or "TRADE" "RTN","TMGNDF3C",539,0) ;"Result: 0 -- no change, 1= change made "RTN","TMGNDF3C",540,0) "RTN","TMGNDF3C",541,0) new result set result=0 "RTN","TMGNDF3C",542,0) new field50 set field50="" "RTN","TMGNDF3C",543,0) new fieldName set fieldName="" "RTN","TMGNDF3C",544,0) new node,pce set (node,pce)="" "RTN","TMGNDF3C",545,0) if mode="GENERIC" do "RTN","TMGNDF3C",546,0) . set field50=5.7 "RTN","TMGNDF3C",547,0) . set fieldName=.076 "RTN","TMGNDF3C",548,0) . set node=8,pce=2 "RTN","TMGNDF3C",549,0) else if mode="TRADE" do "RTN","TMGNDF3C",550,0) . set field50=5.6 "RTN","TMGNDF3C",551,0) . set fieldName=.056 "RTN","TMGNDF3C",552,0) . set node=8,pce=1 "RTN","TMGNDF3C",553,0) if (field50="") goto V1Done "RTN","TMGNDF3C",554,0) if (IEN50="") goto V1Done "RTN","TMGNDF3C",555,0) "RTN","TMGNDF3C",556,0) new drugName set drugName=$piece($get(^PSDRUG(IEN50,0)),"^",1) "RTN","TMGNDF3C",557,0) new TMGName set TMGName=$piece($get(^TMG(22706.9,IEN22706d9,node)),"^",pce) "RTN","TMGNDF3C",558,0) set TMGName=$translate(TMGName,";",":") "RTN","TMGNDF3C",559,0) "RTN","TMGNDF3C",560,0) if $data(^PSDRUG(+$get(IEN50)))=0 do "RTN","TMGNDF3C",561,0) . write "Bad pointer: ",IEN50 "RTN","TMGNDF3C",562,0) . set IEN50=0 "RTN","TMGNDF3C",563,0) "RTN","TMGNDF3C",564,0) if drugName'=TMGName do "RTN","TMGNDF3C",565,0) . write IEN22706d9," (",$extract(mode,1),"): Name mismatch: ",drugName," vs ",TMGName,! "RTN","TMGNDF3C",566,0) . if TMGName="" set IEN50=0 "RTN","TMGNDF3C",567,0) "RTN","TMGNDF3C",568,0) if $get(IEN50)=0 do goto V1Done "RTN","TMGNDF3C",569,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3C",570,0) . set TMGFDA(22706.9,IEN22706d9_",",field50)="@" "RTN","TMGNDF3C",571,0) . do UPDATE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF3C",572,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3C",573,0) . write " ... fixed.",! "RTN","TMGNDF3C",574,0) . set result=1 "RTN","TMGNDF3C",575,0) "RTN","TMGNDF3C",576,0) "RTN","TMGNDF3C",577,0) V1Done "RTN","TMGNDF3C",578,0) quit result "RTN","TMGNDF3D") 0^51^B9007 "RTN","TMGNDF3D",1,0) TMGNDF3D ;TMG/kst/FDA Import: Ensure Possible DRUG doses ;03/25/06 "RTN","TMGNDF3D",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF3D",3,0) "RTN","TMGNDF3D",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF3D",5,0) ;" Ensuring POSSIBLE DOSAGES field correct for File 50 Entries. "RTN","TMGNDF3D",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF3D",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF3D",8,0) ;"11-21-2006 "RTN","TMGNDF3D",9,0) "RTN","TMGNDF3D",10,0) ;"======================================================================= "RTN","TMGNDF3D",11,0) ;" API -- Public Functions. "RTN","TMGNDF3D",12,0) ;"======================================================================= "RTN","TMGNDF3D",13,0) ;"Menu "RTN","TMGNDF3D",14,0) "RTN","TMGNDF3D",15,0) ;"======================================================================= "RTN","TMGNDF3D",16,0) ;"FixPosDoses -- cycle through all records in file 50 and ensure Possible Doses are "RTN","TMGNDF3D",17,0) ;" as desired, I.e. that field 903 has a listing of possible doses "RTN","TMGNDF3D",18,0) ;" for use in CPRS "RTN","TMGNDF3D",19,0) "RTN","TMGNDF3D",20,0) ;"FixAppUse -- cycle through all records in file 50 and ensure drugs are marked "RTN","TMGNDF3D",21,0) ;" with needed code for Application Use, I.e. that field 63 has "RTN","TMGNDF3D",22,0) ;" a listing of possible doses for use in CPRS "RTN","TMGNDF3D",23,0) "RTN","TMGNDF3D",24,0) ;"FixPkgDoses -- to ensure that a package code has been put in for all possible doses "RTN","TMGNDF3D",25,0) ;" NOTE: FixPosDoses has not yet been fixed so that this is done "RTN","TMGNDF3D",26,0) ;" the first time around. "RTN","TMGNDF3D",27,0) "RTN","TMGNDF3D",28,0) ;"======================================================================= "RTN","TMGNDF3D",29,0) ;" Private Functions. "RTN","TMGNDF3D",30,0) ;"======================================================================= "RTN","TMGNDF3D",31,0) ;"$$Fix1Drug(IEN50,IEN22706d9) -- ensure Possible Doses are as desired for one record "RTN","TMGNDF3D",32,0) ;"FixMissingDoses(IEN,rxDose,rxUnit) "RTN","TMGNDF3D",33,0) ;"EnsureMult(IEN,Mult,UnitDose,IEN50d606) -- ensure that one dosage multiple exists "RTN","TMGNDF3D",34,0) ;"MultExists(IEN,Mult) -- return if one dosage multiple exists "RTN","TMGNDF3D",35,0) ;"AddMult(IEN,Mult) -- add a blank record for later filling "RTN","TMGNDF3D",36,0) ;"CheckForBad(IEN) -- Clear records in multiple field 903 that are duplicates, or have no value for DOSE (1) field "RTN","TMGNDF3D",37,0) ;"Clear1Bad(IEN,subIEN) -- kill Subrecord number subIEN in record IEN "RTN","TMGNDF3D",38,0) ;"Unlock902 -- remove restrictions on field 902 of file 50 "RTN","TMGNDF3D",39,0) ;"Lock902 -- replace restrictions on field 902 of file 50 "RTN","TMGNDF3D",40,0) ;"UL50d68 -- unlock fields 2 & 3 in field 50.68 "RTN","TMGNDF3D",41,0) ;"L50d68 -- restore locks on fields 4 & 5 in field 50.68 "RTN","TMGNDF3D",42,0) "RTN","TMGNDF3D",43,0) "RTN","TMGNDF3D",44,0) ;"======================================================================= "RTN","TMGNDF3D",45,0) ;"======================================================================= "RTN","TMGNDF3D",46,0) Menu "RTN","TMGNDF3D",47,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF3D",48,0) "RTN","TMGNDF3D",49,0) new Menu,UsrSlct "RTN","TMGNDF3D",50,0) set Menu(0)="Pick Option for Ensuring Available Doses in DRUG file (3D)" "RTN","TMGNDF3D",51,0) set Menu(1)="Edit which drug FORMS are dividable"_$char(9)_"EditDividable" "RTN","TMGNDF3D",52,0) set Menu(2)="Setup Possible Doses in DRUG File"_$char(9)_"FixPosDoses" "RTN","TMGNDF3D",53,0) set Menu(3)="Mark DRUGs with proper APPLICATION & PACKAGE codes"_$char(9)_"FixAppUseAndPkg" "RTN","TMGNDF3D",54,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF3D",55,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF3D",56,0) "RTN","TMGNDF3D",57,0) MC1 write # "RTN","TMGNDF3D",58,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF3D",59,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF3D",60,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF3D",61,0) "RTN","TMGNDF3D",62,0) if UsrSlct="FixPosDoses" do FixPosDoses goto MC1 "RTN","TMGNDF3D",63,0) if UsrSlct="FixAppUseAndPkg" do FixAppUseAndPkg goto MC1 "RTN","TMGNDF3D",64,0) if UsrSlct="EditDividable" do EditForms^TMGNDF2A goto MC1 "RTN","TMGNDF3D",65,0) if UsrSlct="Prev" goto Menu^TMGNDF3C ;"quit can occur from there... "RTN","TMGNDF3D",66,0) if UsrSlct="Next" goto Menu^TMGNDF3E ;"quit can occur from there... "RTN","TMGNDF3D",67,0) goto MC1 "RTN","TMGNDF3D",68,0) "RTN","TMGNDF3D",69,0) MCDone "RTN","TMGNDF3D",70,0) quit "RTN","TMGNDF3D",71,0) "RTN","TMGNDF3D",72,0) ;"======================================================================= "RTN","TMGNDF3D",73,0) "RTN","TMGNDF3D",74,0) FixPosDoses "RTN","TMGNDF3D",75,0) ;"Purpose: To cycle through all imports in file 50 and ensure Possible Doses are as desired "RTN","TMGNDF3D",76,0) ;" I.e. that field 903 has a listing of possible doses for use in CPRS "RTN","TMGNDF3D",77,0) ;"Output: Field 903 in all records might be changed "RTN","TMGNDF3D",78,0) ;"Notes: I am going to delete duplicate, unuseful entries in the multiple field 903 "RTN","TMGNDF3D",79,0) ;" *** Also, I am going to add dosing combinations that may not be appriate or correct "RTN","TMGNDF3D",80,0) ;" doses for a particular drug. This is because I don't have a database for maximum "RTN","TMGNDF3D",81,0) ;" doses. In those drugs that already have VA data added, I will still add extra "RTN","TMGNDF3D",82,0) ;" possible combinations. For example, I plan to add ability for the doctor to give "RTN","TMGNDF3D",83,0) ;" 0.25, 0.5, 1, 2, 3, or 4 units together for a given dose (i.e. ibuprofen 200, 4 PO TID) "RTN","TMGNDF3D",84,0) ;" If the dosage form is CAP, CAPSULE, then I won't add 0.25 or 0.5 forms. "RTN","TMGNDF3D",85,0) ;" Addendum: I have added a field (22706.8) to file 50.606 (DRUG FORMS) which "RTN","TMGNDF3D",86,0) ;" will be used to see if the drug is dividable or not (i.e. if to add the 0.25 "RTN","TMGNDF3D",87,0) ;" etc. dose multipliers). "RTN","TMGNDF3D",88,0) "RTN","TMGNDF3D",89,0) do Unlock902 "RTN","TMGNDF3D",90,0) "RTN","TMGNDF3D",91,0) new count set count=0 "RTN","TMGNDF3D",92,0) new Itr,IEN22706d9 "RTN","TMGNDF3D",93,0) new abort set abort=0 "RTN","TMGNDF3D",94,0) new success set success=1 "RTN","TMGNDF3D",95,0) "RTN","TMGNDF3D",96,0) write !,"Prepairing possible doses for DRUG entries from import data...",! "RTN","TMGNDF3D",97,0) set IEN22706d9=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3D",98,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF3D",99,0) if IEN22706d9'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF3D",100,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3D",101,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3D",102,0) . new RxIEN set RxIEN=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDF3D",103,0) . new RxIEN2 set RxIEN2=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDF3D",104,0) . if RxIEN>0 do "RTN","TMGNDF3D",105,0) . . set success=$$Fix1Drug(RxIEN,IEN22706d9) if success=-1 quit "RTN","TMGNDF3D",106,0) . . set count=count+1 "RTN","TMGNDF3D",107,0) . if RxIEN2>0 do "RTN","TMGNDF3D",108,0) . . set success=$$Fix1Drug(RxIEN2,IEN22706d9) if success=-1 quit "RTN","TMGNDF3D",109,0) . . set count=count+1 "RTN","TMGNDF3D",110,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3D",111,0) "RTN","TMGNDF3D",112,0) write count," records updated.",! "RTN","TMGNDF3D",113,0) if success=-1 write "Process ended prematurely due to error.",! "RTN","TMGNDF3D",114,0) "RTN","TMGNDF3D",115,0) do Lock902 "RTN","TMGNDF3D",116,0) "RTN","TMGNDF3D",117,0) quit "RTN","TMGNDF3D",118,0) "RTN","TMGNDF3D",119,0) "RTN","TMGNDF3D",120,0) Fix1Drug(IEN50,IEN22706d9) "RTN","TMGNDF3D",121,0) ;"Purpose: To ensure Possible Doses are as desired for one record "RTN","TMGNDF3D",122,0) ;"Input: IEN50 = IEN in file 50 "RTN","TMGNDF3D",123,0) ;" IEN22706d9 -- IEN in 22706.9, the origin of the import "RTN","TMGNDF3D",124,0) ;"Output: Field 903 might be changed "RTN","TMGNDF3D",125,0) ;"Notes: I am going to delete duplicate, unuseful entries in the multiple field 903 "RTN","TMGNDF3D",126,0) ;" *** Also, I am going to add dosing combinations that may not be appriate or correct "RTN","TMGNDF3D",127,0) ;" doses for a particular drug. This is because I don't have a database for maximum "RTN","TMGNDF3D",128,0) ;" doses. In those drugs that already have VA data added, I will still add extra "RTN","TMGNDF3D",129,0) ;" possible combinations. For example, I plan to add ability for the doctor to give "RTN","TMGNDF3D",130,0) ;" 0.25, 0.5, 1, 2, 3, or 4 units together for a given dose (i.e. ibuprofen 200, 4 PO TID) "RTN","TMGNDF3D",131,0) ;" Note: If the dosage form is CAP, then I won't add 0.25 or 0.5 forms. "RTN","TMGNDF3D",132,0) ;" Also, if there is no dosage strength or unit in the record, but it is available in the "RTN","TMGNDF3D",133,0) ;" linked record in 50.68, then we will copy the information over. "RTN","TMGNDF3D",134,0) ;" ADDENDUM: I will check the drug form to see if it is dividable. "RTN","TMGNDF3D",135,0) ;"Result: 0 if OK to continue. -1 if abort "RTN","TMGNDF3D",136,0) "RTN","TMGNDF3D",137,0) new result set result=0 "RTN","TMGNDF3D",138,0) new Mult,rxDose,rxUnit,vapRxForm,vapIEN "RTN","TMGNDF3D",139,0) new IEN50d606 "RTN","TMGNDF3D",140,0) new abort set abort=0 "RTN","TMGNDF3D",141,0) if +$get(IEN50)=0 goto FODDone "RTN","TMGNDF3D",142,0) if +$get(IEN22706d9)=0 goto FODDone "RTN","TMGNDF3D",143,0) do CheckForBad(IEN50) "RTN","TMGNDF3D",144,0) set rxDose=$piece($get(^PSDRUG(IEN50,"DOS")),"^",1) ;"DOS;1 = field 901; STRENGTH "RTN","TMGNDF3D",145,0) set rxUnit=$$GET1^DIQ(50,IEN50,902) ;"902 = UNIT "RTN","TMGNDF3D",146,0) set IEN50d606=$piece($get(^TMG(22706.9,IEN22706d9,0)),"^",7) "RTN","TMGNDF3D",147,0) if (+rxDose'>0)!(rxUnit="") do "RTN","TMGNDF3D",148,0) FOD1 . set result=$$FixMissingDoses(IEN50,.rxDose,.rxUnit) "RTN","TMGNDF3D",149,0) if result'=0 goto FODDone "RTN","TMGNDF3D",150,0) "RTN","TMGNDF3D",151,0) for Mult=0.25,0.5,1,2,3,4 do quit:(result=-1) "RTN","TMGNDF3D",152,0) . ;"set result=$$EnsureMult(IEN50,Mult,rxDose,rxUnit) "RTN","TMGNDF3D",153,0) . set result=$$EnsureMult(IEN50,Mult,rxDose,IEN50d606) "RTN","TMGNDF3D",154,0) "RTN","TMGNDF3D",155,0) FODDone "RTN","TMGNDF3D",156,0) quit result "RTN","TMGNDF3D",157,0) "RTN","TMGNDF3D",158,0) "RTN","TMGNDF3D",159,0) FixMissingDoses(IEN50,rxDose,rxUnit) "RTN","TMGNDF3D",160,0) ;"Purpose: If there is no dosage strength or unit in the record, but it is available in the "RTN","TMGNDF3D",161,0) ;" linked record in 50.68, then we will copy the information over. "RTN","TMGNDF3D",162,0) ;"Input: IEN50 - IEN in file 50 "RTN","TMGNDF3D",163,0) ;" rxDose -- PASS BY REFERENCE, OUT PARAMETER "RTN","TMGNDF3D",164,0) ;" rxUnit -- PASS BY REFERENCE, OUT PARAMETER "RTN","TMGNDF3D",165,0) ;"Result: 0 if OK to continue. -1 if abort 1=unable to fix "RTN","TMGNDF3D",166,0) "RTN","TMGNDF3D",167,0) new vapRxForm,vapIEN "RTN","TMGNDF3D",168,0) new result set result=1 ;"default to failure "RTN","TMGNDF3D",169,0) new ErrFound set ErrFound=0 "RTN","TMGNDF3D",170,0) "RTN","TMGNDF3D",171,0) set rxDose=$$GET1^DIQ(50,IEN50,901) "RTN","TMGNDF3D",172,0) set rxUnit=$$GET1^DIQ(50,IEN50,902) "RTN","TMGNDF3D",173,0) set vapIEN=$$GET1^DIQ(50,IEN50,22,"I") "RTN","TMGNDF3D",174,0) set vapRxForm=$$GET1^DIQ(50.68,vapIEN,1) ;50.68=VA PRODUCT, field 1=DOSAGE FORM "RTN","TMGNDF3D",175,0) set vapRxStrength=$$GET1^DIQ(50.68,vapIEN,2) ;"50.68=VA PRODUCT, field 2=STRENGTH "RTN","TMGNDF3D",176,0) set vapRxUnits=$$GET1^DIQ(50.68,vapIEN,3) ;"50.68=VA PRODUCT, field 3=UNITS "RTN","TMGNDF3D",177,0) set vapRxIUnits=$$GET1^DIQ(50.68,vapIEN,3,"I") ;"50.68=VA PRODUCT, field 3=UNITS "RTN","TMGNDF3D",178,0) "RTN","TMGNDF3D",179,0) ;"For some reason the units must be put in FIRST "RTN","TMGNDF3D",180,0) if (rxUnit="")&(vapRxUnits'="") do "RTN","TMGNDF3D",181,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3D",182,0) . set TMGFDA(50,IEN50_",",902)=vapRxIUnits "RTN","TMGNDF3D",183,0) . set rxUnit=vapRxUnits "RTN","TMGNDF3D",184,0) . set result=0 ;"set for tenative success "RTN","TMGNDF3D",185,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3D",186,0) . if $data(TMGMSG("DIERR"))'=0 do quit "RTN","TMGNDF3D",187,0) . . set ErrFound=1 "RTN","TMGNDF3D",188,0) . . new PriorErrorFound "RTN","TMGNDF3D",189,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF3D",190,0) . . set result=-1 "RTN","TMGNDF3D",191,0) if ErrFound goto FMDDone "RTN","TMGNDF3D",192,0) "RTN","TMGNDF3D",193,0) if (rxDose="")&(vapRxStrength'="") do "RTN","TMGNDF3D",194,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3D",195,0) . set TMGFDA(50,IEN50_",",901)=vapRxStrength "RTN","TMGNDF3D",196,0) . set rxDose=vapRxStrength "RTN","TMGNDF3D",197,0) . set result=0 ;"set for tenative success "RTN","TMGNDF3D",198,0) . do FILE^DIE("ETK","TMGFDA","TMGMSG") "RTN","TMGNDF3D",199,0) . if $data(TMGMSG("DIERR"))'=0 do quit "RTN","TMGNDF3D",200,0) . . new PriorErrorFound "RTN","TMGNDF3D",201,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF3D",202,0) . . set result=-1 "RTN","TMGNDF3D",203,0) if ErrFound goto FMDDone "RTN","TMGNDF3D",204,0) "RTN","TMGNDF3D",205,0) FMDDone "RTN","TMGNDF3D",206,0) quit result "RTN","TMGNDF3D",207,0) "RTN","TMGNDF3D",208,0) "RTN","TMGNDF3D",209,0) EnsureMult(IEN50,Mult,UnitDose,IEN50d606) "RTN","TMGNDF3D",210,0) ;"Purpose: To ensure that one dosage multiple exists "RTN","TMGNDF3D",211,0) ;"Input: IEN50 - the IEN in file 50 "RTN","TMGNDF3D",212,0) ;" Mult - The unit multiple to be ensured exists (e.g. 0.25, 0.5, 1, 2, 3, 4) "RTN","TMGNDF3D",213,0) ;" UnitDose -- the dose for a Multiple of 1 "RTN","TMGNDF3D",214,0) ;" IEN50d606 -- IEN in 50.606 (DRUG FORMS) "RTN","TMGNDF3D",215,0) ;"Result: 0 if OK to continue. -1 if abort "RTN","TMGNDF3D",216,0) ;"Note: The DRUG FORM is checked for dividability. If the particular dose "RTN","TMGNDF3D",217,0) ;" is not dividable (e.g. a capsule), then it ensures that a divided "RTN","TMGNDF3D",218,0) ;" dose does NOT exist (removing if needed) "RTN","TMGNDF3D",219,0) "RTN","TMGNDF3D",220,0) new result set result=0 "RTN","TMGNDF3D",221,0) new subIEN "RTN","TMGNDF3D",222,0) set subIEN=+$$MultExists(IEN50,Mult) "RTN","TMGNDF3D",223,0) if (Mult<1),($$IsDividable(IEN50d606)=0),(subIEN'=0) do goto EMDone "RTN","TMGNDF3D",224,0) . new temp set temp=$$Clear1Bad(IEN50,subIEN) "RTN","TMGNDF3D",225,0) if subIEN'>0 set subIEN=$$AddMult(IEN50,Mult) "RTN","TMGNDF3D",226,0) ;"if subIEN'>0 set subIEN=$$AddMult(IEN50,Mult,Mult*UnitDose) "RTN","TMGNDF3D",227,0) if subIEN=0 set result=1 goto EMDone "RTN","TMGNDF3D",228,0) new dosage set dosage=$$GetDosage(UnitDose,Mult) "RTN","TMGNDF3D",229,0) set result=$$StuffMult(IEN50,subIEN,Mult,dosage) "RTN","TMGNDF3D",230,0) "RTN","TMGNDF3D",231,0) EMDone quit result "RTN","TMGNDF3D",232,0) "RTN","TMGNDF3D",233,0) "RTN","TMGNDF3D",234,0) IsDividable(IEN50d606) "RTN","TMGNDF3D",235,0) ;"Purpose: to determine if a particular drug form is dividable "RTN","TMGNDF3D",236,0) ;" (as stored in the DRUG FORM file) "RTN","TMGNDF3D",237,0) ;"Results: 1 if dividable, 0 otherwise "RTN","TMGNDF3D",238,0) "RTN","TMGNDF3D",239,0) new result "RTN","TMGNDF3D",240,0) set result=(+$piece($get(^PS(50.606,IEN50d606,"TMG")),"^",1)=1) ;"field 22706.8, DIVIDABLE "RTN","TMGNDF3D",241,0) quit result "RTN","TMGNDF3D",242,0) "RTN","TMGNDF3D",243,0) "RTN","TMGNDF3D",244,0) GetDosage(UnitDose,Mult) "RTN","TMGNDF3D",245,0) ;"Purpose to return UnitDose*Mult, but allow for 160;25 --> 80;12.5 "RTN","TMGNDF3D",246,0) ;"Input: UnitDose -- the dose for a Multiple of 1 "RTN","TMGNDF3D",247,0) ;" Mult - The unit multiple to use (e.g. 0.25, 0.5, 1, 2, 3, 4) "RTN","TMGNDF3D",248,0) ;"Results: returns UnitDose*Mult. "RTN","TMGNDF3D",249,0) ;" E.g. 80 * 2 ==> 160, or "RTN","TMGNDF3D",250,0) ;" 10;12.5 * 2 ==> 20;25 "RTN","TMGNDF3D",251,0) "RTN","TMGNDF3D",252,0) new i,result "RTN","TMGNDF3D",253,0) set result="" "RTN","TMGNDF3D",254,0) for i=1:1:$length(UnitDose,";") do "RTN","TMGNDF3D",255,0) . new oneDose set oneDose=+$piece(UnitDose,";",i) "RTN","TMGNDF3D",256,0) . if i>1 set result=result_";" "RTN","TMGNDF3D",257,0) . set result=result_(oneDose*Mult) "RTN","TMGNDF3D",258,0) "RTN","TMGNDF3D",259,0) quit result "RTN","TMGNDF3D",260,0) "RTN","TMGNDF3D",261,0) MultExists(IEN50,Mult) "RTN","TMGNDF3D",262,0) ;"Purpose: To return if one dosage multiple exists "RTN","TMGNDF3D",263,0) ;"Input: IEN50 - the IEN in file 50 "RTN","TMGNDF3D",264,0) ;" Mult - The unit multiple to be check for (e.g. 0.25, 0.5, 1, 2, 3, 4) "RTN","TMGNDF3D",265,0) ;"Results: subIEN if found, 0 otherwise "RTN","TMGNDF3D",266,0) "RTN","TMGNDF3D",267,0) new result set result=0 "RTN","TMGNDF3D",268,0) new subIEN,Mults "RTN","TMGNDF3D",269,0) new found set found=0 "RTN","TMGNDF3D",270,0) set subIEN=0 "RTN","TMGNDF3D",271,0) for set subIEN=$order(^PSDRUG(IEN50,"DOS1",subIEN)) quit:(+subIEN'>0) do quit:(found>0) "RTN","TMGNDF3D",272,0) . new node set node=$get(^PSDRUG(IEN50,"DOS1",subIEN,0)) "RTN","TMGNDF3D",273,0) . new numUnits set numUnits=$piece(node,"^",1) "RTN","TMGNDF3D",274,0) . if numUnits=Mult set found=1 "RTN","TMGNDF3D",275,0) "RTN","TMGNDF3D",276,0) if (found=1) set result=subIEN "RTN","TMGNDF3D",277,0) quit result "RTN","TMGNDF3D",278,0) "RTN","TMGNDF3D",279,0) "RTN","TMGNDF3D",280,0) AddMult(IEN50,Mult) "RTN","TMGNDF3D",281,0) ;"Purpose: To create a stub-in record for later filling "RTN","TMGNDF3D",282,0) ;"Input: IEN50 - the IEN in file 50 "RTN","TMGNDF3D",283,0) ;" Mult - The unit multiple to be ensured exists (e.g. 0.25, 0.5, 1, 2, 3, 4) "RTN","TMGNDF3D",284,0) ;"Output: Records are added to multiple field 903 "RTN","TMGNDF3D",285,0) ;"Result: returns IEN50 of added record "RTN","TMGNDF3D",286,0) "RTN","TMGNDF3D",287,0) new result set result=0 "RTN","TMGNDF3D",288,0) "RTN","TMGNDF3D",289,0) ;"Force value into DOS;2 to overcome input transform restriction on field .01 "RTN","TMGNDF3D",290,0) ;"(will be removed below) "RTN","TMGNDF3D",291,0) new temp set temp=$piece($get(^PSDRUG(IEN50,"DOS")),"^",2) "RTN","TMGNDF3D",292,0) if temp="" set $piece(^PSDRUG(IEN50,"DOS"),"^",2)="(temp value)" "RTN","TMGNDF3D",293,0) "RTN","TMGNDF3D",294,0) new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF3D",295,0) set TMGFDA(50.0903,"+1,"_IEN50_",",.01)=Mult "RTN","TMGNDF3D",296,0) do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF3D",297,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3D",298,0) "RTN","TMGNDF3D",299,0) ;"remove temporary value forced in above. "RTN","TMGNDF3D",300,0) if temp="" set $piece(^PSDRUG(IEN50,"DOS"),"^",2)="" "RTN","TMGNDF3D",301,0) "RTN","TMGNDF3D",302,0) set result=$get(TMGIEN(1)) ;"get new record number "RTN","TMGNDF3D",303,0) AMDone "RTN","TMGNDF3D",304,0) quit result "RTN","TMGNDF3D",305,0) "RTN","TMGNDF3D",306,0) "RTN","TMGNDF3D",307,0) StuffMult(IEN50,subIEN,Mult,Dosage) "RTN","TMGNDF3D",308,0) ;"Purpose: To add a dosage multiple to IEN50 record "RTN","TMGNDF3D",309,0) ;"Input: IEN50 - the IEN in file 50 "RTN","TMGNDF3D",310,0) ;" subIEN -- the IEN in subfile 50.0903 "RTN","TMGNDF3D",311,0) ;" Dosage - the value to go into field 1 (e.g. 160, or 160;12.5) "RTN","TMGNDF3D",312,0) ;"Output: Records are added to multiple field 903 "RTN","TMGNDF3D",313,0) ;"Result: 0 if OK to continue. -1 if abort "RTN","TMGNDF3D",314,0) ;"Note: if Dosage < 1 then Mult values < 1 will be ignored "RTN","TMGNDF3D",315,0) ;" This is because 0.625*0.25 --> such a small a number that input transform rejects value. "RTN","TMGNDF3D",316,0) "RTN","TMGNDF3D",317,0) new result set result=0 "RTN","TMGNDF3D",318,0) if (Dosage<1)&(Mult<1) goto SMDone "RTN","TMGNDF3D",319,0) set Dosage=$$ClipDDigits^TMGMISC(Dosage,5) "RTN","TMGNDF3D",320,0) "RTN","TMGNDF3D",321,0) new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF3D",322,0) set TMGFDA(50.0903,subIEN_","_IEN50_",",1)=Dosage "RTN","TMGNDF3D",323,0) do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF3D",324,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG,.result) ;"result=1 if error "RTN","TMGNDF3D",325,0) "RTN","TMGNDF3D",326,0) SMDone "RTN","TMGNDF3D",327,0) quit result "RTN","TMGNDF3D",328,0) "RTN","TMGNDF3D",329,0) "RTN","TMGNDF3D",330,0) CheckForBad(IEN50) "RTN","TMGNDF3D",331,0) ;"Purpose: Clear records in multiple field 903 that are duplicates, or have no value for DOSE (1) field "RTN","TMGNDF3D",332,0) ;"Input: IEN50= IEN in file 50 "RTN","TMGNDF3D",333,0) ;"Example: "RTN","TMGNDF3D",334,0) ;" 903-POSSIBLE DOSAGES : "RTN","TMGNDF3D",335,0) ;" Multiple Entry #1 "RTN","TMGNDF3D",336,0) ;" .01-DISPENSE UNITS PER DOSE : 1 <---- no DOSE, so kill "RTN","TMGNDF3D",337,0) ;" 2-PACKAGE : IO "RTN","TMGNDF3D",338,0) ;" Multiple Entry #2 "RTN","TMGNDF3D",339,0) ;" .01-DISPENSE UNITS PER DOSE : 2 <---- no DOSE, so kill "RTN","TMGNDF3D",340,0) ;" 2-PACKAGE : IO "RTN","TMGNDF3D",341,0) ;" Multiple Entry #3 "RTN","TMGNDF3D",342,0) ;" .01-DISPENSE UNITS PER DOSE : 1 "RTN","TMGNDF3D",343,0) ;" 1-DOSE : 250 "RTN","TMGNDF3D",344,0) ;" 2-PACKAGE : IO "RTN","TMGNDF3D",345,0) ;" Multiple Entry #4 "RTN","TMGNDF3D",346,0) ;" .01-DISPENSE UNITS PER DOSE : 2 "RTN","TMGNDF3D",347,0) ;" 1-DOSE : 500 "RTN","TMGNDF3D",348,0) ;" 2-PACKAGE : IO "RTN","TMGNDF3D",349,0) "RTN","TMGNDF3D",350,0) new subIEN,Mults "RTN","TMGNDF3D",351,0) set subIEN=$order(^PSDRUG(IEN50,"DOS1",0)) "RTN","TMGNDF3D",352,0) if subIEN>0 for do quit:(+subIEN'>0) "RTN","TMGNDF3D",353,0) . new deleted set deleted=0 "RTN","TMGNDF3D",354,0) . new node set node=$get(^PSDRUG(IEN50,"DOS1",subIEN,0)) "RTN","TMGNDF3D",355,0) . new dose set dose=$piece(node,"^",2) "RTN","TMGNDF3D",356,0) . if +dose'>0 set deleted=$$Clear1Bad(IEN50,subIEN) "RTN","TMGNDF3D",357,0) . new numUnits set numUnits=$piece(node,"^",1) "RTN","TMGNDF3D",358,0) . if $data(Mults(numUnits))=0 do "RTN","TMGNDF3D",359,0) . . if deleted=1 quit "RTN","TMGNDF3D",360,0) . . set Mults(numUnits)=subIEN "RTN","TMGNDF3D",361,0) . else do ;"here we have a duplicate entry. "RTN","TMGNDF3D",362,0) . . if deleted=1 quit "RTN","TMGNDF3D",363,0) . . set deleted=$$Clear1Bad(IEN50,subIEN) "RTN","TMGNDF3D",364,0) . set subIEN=$order(^PSDRUG(IEN50,"DOS1",subIEN)) "RTN","TMGNDF3D",365,0) "RTN","TMGNDF3D",366,0) quit "RTN","TMGNDF3D",367,0) "RTN","TMGNDF3D",368,0) "RTN","TMGNDF3D",369,0) Clear1Bad(IEN50,subIEN) "RTN","TMGNDF3D",370,0) ;"Purpose: To kill Subrecord number subIEN in record IEN "RTN","TMGNDF3D",371,0) ;"Input: IEN50 = IEN in file 50 "RTN","TMGNDF3D",372,0) ;" subIEN = IEN in subfile for field 903 (50.0903) "RTN","TMGNDF3D",373,0) ;"Results: 1 if kill done, 0 otherwise "RTN","TMGNDF3D",374,0) "RTN","TMGNDF3D",375,0) new DA,DIK "RTN","TMGNDF3D",376,0) set DIK="^PSDRUG("_IEN50_",""DOS1""," "RTN","TMGNDF3D",377,0) set DA=subIEN "RTN","TMGNDF3D",378,0) set DA(1)=IEN50 "RTN","TMGNDF3D",379,0) "RTN","TMGNDF3D",380,0) ;"write "Should delete: IEN50=",IEN50,", subIEN=",subIEN,! "RTN","TMGNDF3D",381,0) do ^DIK "RTN","TMGNDF3D",382,0) "RTN","TMGNDF3D",383,0) quit 1 "RTN","TMGNDF3D",384,0) "RTN","TMGNDF3D",385,0) "RTN","TMGNDF3D",386,0) Unlock902 "RTN","TMGNDF3D",387,0) ;"Purpose: remove restrictions on field 902 of file 50 "RTN","TMGNDF3D",388,0) kill ^DD(50,902,8.5) "RTN","TMGNDF3D",389,0) kill ^DD(50,902,9) "RTN","TMGNDF3D",390,0) quit "RTN","TMGNDF3D",391,0) "RTN","TMGNDF3D",392,0) Lock902 "RTN","TMGNDF3D",393,0) ;"Purpose: replace restrictions on field 902 of file 50 "RTN","TMGNDF3D",394,0) "RTN","TMGNDF3D",395,0) set ^DD(50,902,8.5)="^" "RTN","TMGNDF3D",396,0) set ^DD(50,902,9)="^" "RTN","TMGNDF3D",397,0) quit "RTN","TMGNDF3D",398,0) "RTN","TMGNDF3D",399,0) UL50d68 "RTN","TMGNDF3D",400,0) ;"Purpose: unlock fields 2 & 3 in field 50.68 "RTN","TMGNDF3D",401,0) "RTN","TMGNDF3D",402,0) kill ^DD(50.68,2,8.5) "RTN","TMGNDF3D",403,0) kill ^DD(50.68,2,9) "RTN","TMGNDF3D",404,0) kill ^DD(50.68,3,8.5) "RTN","TMGNDF3D",405,0) kill ^DD(50.68,3,9) "RTN","TMGNDF3D",406,0) "RTN","TMGNDF3D",407,0) quit "RTN","TMGNDF3D",408,0) "RTN","TMGNDF3D",409,0) "RTN","TMGNDF3D",410,0) L50d68 "RTN","TMGNDF3D",411,0) ;"Purpose: restore locks on fields 4 & 5 in field 50.68 "RTN","TMGNDF3D",412,0) "RTN","TMGNDF3D",413,0) set ^DD(50.68,2,8.5)="^" "RTN","TMGNDF3D",414,0) set ^DD(50.68,2,9)="^" "RTN","TMGNDF3D",415,0) set ^DD(50.68,2,8.5)="^" "RTN","TMGNDF3D",416,0) set ^DD(50.68,2,9)="^" "RTN","TMGNDF3D",417,0) "RTN","TMGNDF3D",418,0) quit "RTN","TMGNDF3D",419,0) "RTN","TMGNDF3D",420,0) ;"======================================================================= "RTN","TMGNDF3D",421,0) ;"======================================================================= "RTN","TMGNDF3D",422,0) "RTN","TMGNDF3D",423,0) "RTN","TMGNDF3D",424,0) FixAppUseAndPkg "RTN","TMGNDF3D",425,0) ;"Purpose: To cycle through all records in file 50 and ensure drugs are marked "RTN","TMGNDF3D",426,0) ;" with needed code for Application Use, I.e. that field 63 has "RTN","TMGNDF3D",427,0) ;" a listing of possible doses for use in CPRS "RTN","TMGNDF3D",428,0) ;" ALSO will ensure that Package is properly set. "RTN","TMGNDF3D",429,0) "RTN","TMGNDF3D",430,0) new Itr "RTN","TMGNDF3D",431,0) new NumModified set NumModified=0 "RTN","TMGNDF3D",432,0) new abort set abort=0 "RTN","TMGNDF3D",433,0) "RTN","TMGNDF3D",434,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3D",435,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3D",436,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF3D",437,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3D",438,0) . if +$piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDF3D",439,0) . new IEN50 "RTN","TMGNDF3D",440,0) . set IEN50=$piece($get(^TMG(22706.9,IEN,7)),"^",1) "RTN","TMGNDF3D",441,0) . set NumModified=NumModified+$$Fix1AppUse(IEN50) "RTN","TMGNDF3D",442,0) . set NumModified=NumModified+$$Fix1PkgDoses(IEN50) "RTN","TMGNDF3D",443,0) . set IEN50=$piece($get(^TMG(22706.9,IEN,7)),"^",2) "RTN","TMGNDF3D",444,0) . set NumModified=NumModified+$$Fix1AppUse(IEN50) "RTN","TMGNDF3D",445,0) . set NumModified=NumModified+$$Fix1PkgDoses(IEN50) "RTN","TMGNDF3D",446,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3D",447,0) "RTN","TMGNDF3D",448,0) write NumModified," modifications made in DRUG file.",! "RTN","TMGNDF3D",449,0) do PressToCont^TMGUSRIF "RTN","TMGNDF3D",450,0) "RTN","TMGNDF3D",451,0) quit "RTN","TMGNDF3D",452,0) "RTN","TMGNDF3D",453,0) "RTN","TMGNDF3D",454,0) AskFix1AppUse "RTN","TMGNDF3D",455,0) ;"Purpose: for testing purposes, ask user for 1 drug and fix that one "RTN","TMGNDF3D",456,0) new DIC,Y "RTN","TMGNDF3D",457,0) set DIC(0)="MAEQ" "RTN","TMGNDF3D",458,0) set DIC=50 "RTN","TMGNDF3D",459,0) do ^DIC write ! "RTN","TMGNDF3D",460,0) if +Y>0 do Fix1AppUse(+Y) "RTN","TMGNDF3D",461,0) quit "RTN","TMGNDF3D",462,0) "RTN","TMGNDF3D",463,0) "RTN","TMGNDF3D",464,0) Fix1AppUse(IEN50) "RTN","TMGNDF3D",465,0) ;"Purpose: to Fix one Drug in 50 so that field 63 contains "O" code "RTN","TMGNDF3D",466,0) ;"Result: 1 if modified, 0 if not modified. "RTN","TMGNDF3D",467,0) "RTN","TMGNDF3D",468,0) new result set result=0 "RTN","TMGNDF3D",469,0) if +$get(IEN50)=0 goto F1AD "RTN","TMGNDF3D",470,0) new code set code=$piece($get(^PSDRUG(IEN50,2)),"^",3) "RTN","TMGNDF3D",471,0) new PSIUX,PSIUDA "RTN","TMGNDF3D",472,0) set PSIUDA=+IEN50 "RTN","TMGNDF3D",473,0) if code'["O" do "RTN","TMGNDF3D",474,0) . set PSIUX="O^OUTPATIENT" "RTN","TMGNDF3D",475,0) . do ENPSGIU ;"EN^PSGIU "RTN","TMGNDF3D",476,0) . set result=1 "RTN","TMGNDF3D",477,0) "RTN","TMGNDF3D",478,0) if code'["U" do "RTN","TMGNDF3D",479,0) . set PSIUX="U^U" "RTN","TMGNDF3D",480,0) . do ENPSGIU ;"EN^PSGIU "RTN","TMGNDF3D",481,0) . set result=1 "RTN","TMGNDF3D",482,0) "RTN","TMGNDF3D",483,0) ;"if code'["U" do "RTN","TMGNDF3D",484,0) if code'["I" do "RTN","TMGNDF3D",485,0) . set PSIUX="I^INPATIENT" "RTN","TMGNDF3D",486,0) . do ENPSGIU ;"EN^PSGIU "RTN","TMGNDF3D",487,0) . set result=1 "RTN","TMGNDF3D",488,0) F1AD "RTN","TMGNDF3D",489,0) quit result "RTN","TMGNDF3D",490,0) "RTN","TMGNDF3D",491,0) "RTN","TMGNDF3D",492,0) ENPSGIU "RTN","TMGNDF3D",493,0) ;"Purpose: This code is copied from EN^PSGIU and modified so that it "RTN","TMGNDF3D",494,0) ;" doesn't ask for confirmation, and is easier for me to read "RTN","TMGNDF3D",495,0) ;" It is the 'appropriate' method for setting field 63 in file 50 "RTN","TMGNDF3D",496,0) ;"Input: Expected vars: PSIUDA=IEN in 50 to change "RTN","TMGNDF3D",497,0) ;" PSIUX=Code to add. Format: 'Code^Description' "RTN","TMGNDF3D",498,0) "RTN","TMGNDF3D",499,0) new PSIUA,PSIUQ,PSIUO,PSIUY,PSIUT,% "RTN","TMGNDF3D",500,0) "RTN","TMGNDF3D",501,0) ;"Q:$S('$D(PSIUDA):1,'$D(PSIUX):1,PSIUX'?1E1"^"1.E:1,1:'$D(^PSDRUG(PSIUDA,0))) set PSIUO=$P($G(^(2)),"^",3) set PSIUT=$P(PSIUX,"^",2),PSIUT=$S($E(PSIUT,1,4)="UNIT":"",1:$E("N","AEIOU"[$E(PSIUT)))_" "_PSIUT,(%,PSIUQ)=PSIUO'[$E(PSIUX)+1 "RTN","TMGNDF3D",502,0) if '$D(PSIUDA)!('$D(PSIUX)) quit "RTN","TMGNDF3D",503,0) if (PSIUX'?1E1"^"1.E)!('$D(^PSDRUG(PSIUDA,0))) quit "RTN","TMGNDF3D",504,0) set PSIUO=$P($G(^(2)),"^",3) "RTN","TMGNDF3D",505,0) set PSIUT=$P(PSIUX,"^",2) "RTN","TMGNDF3D",506,0) set PSIUT=$S($E(PSIUT,1,4)="UNIT":"",1:$E("N","AEIOU"[$E(PSIUT)))_" "_PSIUT "RTN","TMGNDF3D",507,0) set (%,PSIUQ)=PSIUO'[$E(PSIUX)+1 "RTN","TMGNDF3D",508,0) ;"F W !!,"A",PSIUT," ITEM" D YN^DICN Q:% D MQ S %=PSIUQ "RTN","TMGNDF3D",509,0) ;"I %<0 set PSIUA="^" G DONE "RTN","TMGNDF3D",510,0) set %=1 ;"//kt added default answer to YES "RTN","TMGNDF3D",511,0) set PSIUA=$E("YN",%) "RTN","TMGNDF3D",512,0) ;"G:%=PSIUQ DONE "RTN","TMGNDF3D",513,0) if %=1 do "RTN","TMGNDF3D",514,0) . new Code set Code=$P(PSIUX,"^") "RTN","TMGNDF3D",515,0) . if PSIUO[Code set Code="" "RTN","TMGNDF3D",516,0) . set PSIUY=PSIUO_Code "RTN","TMGNDF3D",517,0) . set $P(^PSDRUG(PSIUDA,2),"^",3)=PSIUY "RTN","TMGNDF3D",518,0) . if $P(^(0),"^")]"" do "RTN","TMGNDF3D",519,0) . . set ^PSDRUG("AIU"_$P(PSIUX,"^"),$P(^(0),"^"),PSIUDA)="" "RTN","TMGNDF3D",520,0) if %=2 do "RTN","TMGNDF3D",521,0) . set PSIUY=$P(PSIUO,$P(PSIUX,"^"))_$P(PSIUO,$P(PSIUX,"^"),2) "RTN","TMGNDF3D",522,0) . set $P(^PSDRUG(PSIUDA,2),"^",3)=PSIUY "RTN","TMGNDF3D",523,0) . if $P(^(0),"^")]"" do "RTN","TMGNDF3D",524,0) . . kill ^PSDRUG("AIU"_$P(PSIUX,"^"),$P(^(0),"^"),PSIUDA) "RTN","TMGNDF3D",525,0) kill:PSIUO]"" ^PSDRUG("IU",PSIUO,PSIUDA) "RTN","TMGNDF3D",526,0) set:PSIUY]"" ^PSDRUG("IU",PSIUY,PSIUDA)="" "RTN","TMGNDF3D",527,0) ; "RTN","TMGNDF3D",528,0) DONE ; "RTN","TMGNDF3D",529,0) kill PSIU,PSIUO,PSIUQ,PSIUT,PSIUY Q "RTN","TMGNDF3D",530,0) "RTN","TMGNDF3D",531,0) "RTN","TMGNDF3D",532,0) "RTN","TMGNDF3D",533,0) ;"======================================================================= "RTN","TMGNDF3D",534,0) ;"======================================================================= "RTN","TMGNDF3D",535,0) "RTN","TMGNDF3D",536,0) Fix1PkgDoses(IEN50) "RTN","TMGNDF3D",537,0) ;"Purpose: to check all possible doses and ensure proper package codes present "RTN","TMGNDF3D",538,0) ;"Result: 1 if modified, 0 if not modified. "RTN","TMGNDF3D",539,0) "RTN","TMGNDF3D",540,0) new result set result=0 "RTN","TMGNDF3D",541,0) if +$get(IEN50)=0 goto FPDDone "RTN","TMGNDF3D",542,0) new IEN50d0903 set IEN50d0903=0 "RTN","TMGNDF3D",543,0) for set IEN50d0903=$order(^PSDRUG(IEN50,"DOS1",IEN50d0903)) quit:(+IEN50d0903'>0) do "RTN","TMGNDF3D",544,0) . new CurValue set CurValue=$piece(^PSDRUG(IEN50,"DOS1",IEN50d0903,0),"^",3) "RTN","TMGNDF3D",545,0) . if (CurValue["I")&(CurValue["O") quit "RTN","TMGNDF3D",546,0) . if CurValue'["I" set CurValue=CurValue_"I" "RTN","TMGNDF3D",547,0) . if CurValue'["O" set CurValue=CurValue_"O" "RTN","TMGNDF3D",548,0) . set $piece(^PSDRUG(IEN50,"DOS1",IEN50d0903,0),"^",3)=CurValue "RTN","TMGNDF3D",549,0) . set result=1 "RTN","TMGNDF3D",550,0) FPDDone "RTN","TMGNDF3D",551,0) quit result "RTN","TMGNDF3D",552,0) "RTN","TMGNDF3D",553,0) "RTN","TMGNDF3D",554,0) EditDividable "RTN","TMGNDF3D",555,0) ;"Purpose: To edit custom field 22706.8 (TMG DIVIDABLE) in file 50.606 (DOSAGE FORM) "RTN","TMGNDF3D",556,0) ;"Input: none. "RTN","TMGNDF3D",557,0) ;"Output: file 50.606 may be edited. "RTN","TMGNDF3D",558,0) "RTN","TMGNDF3E") 0^52^B4600 "RTN","TMGNDF3E",1,0) TMGNDF3E ;TMG/kst/FDA Import: Inactivate unwanted DRUGs ;03/25/06 "RTN","TMGNDF3E",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF3E",3,0) "RTN","TMGNDF3E",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF3E",5,0) ;" Inactivate DRUG entries not linked to import. "RTN","TMGNDF3E",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF3E",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF3E",8,0) ;"11-21-2006 "RTN","TMGNDF3E",9,0) "RTN","TMGNDF3E",10,0) ;"======================================================================= "RTN","TMGNDF3E",11,0) ;" API -- Public Functions. "RTN","TMGNDF3E",12,0) ;"======================================================================= "RTN","TMGNDF3E",13,0) ;"Menu "RTN","TMGNDF3E",14,0) ;"======================================================================= "RTN","TMGNDF3E",15,0) "RTN","TMGNDF3E",16,0) ;"======================================================================= "RTN","TMGNDF3E",17,0) ;" Private Functions. "RTN","TMGNDF3E",18,0) ;"======================================================================= "RTN","TMGNDF3E",19,0) "RTN","TMGNDF3E",20,0) Menu "RTN","TMGNDF3E",21,0) ;"Purpose: Provide menu to entry points of main routines "RTN","TMGNDF3E",22,0) "RTN","TMGNDF3E",23,0) new Menu,UsrSlct "RTN","TMGNDF3E",24,0) set Menu(0)="Pick Option for Inactivate unused DRUG file entries (3E)" "RTN","TMGNDF3E",25,0) set Menu(1)="Inactivate DRUG entries not linked to import"_$char(9)_"InactivateUnused" "RTN","TMGNDF3E",26,0) set Menu(2)="Kill DRUG entries not linked to import (CAUTION!)"_$char(9)_"KillUnused" "RTN","TMGNDF3E",27,0) set Menu(3)="View DRUG entries that ARE linked to import"_$char(9)_"BrowseUsed" "RTN","TMGNDF3E",28,0) set Menu(4)="Review DRUG entries for bad imports"_$char(9)_"CheckForBad" "RTN","TMGNDF3E",29,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF3E",30,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF3E",31,0) "RTN","TMGNDF3E",32,0) MC1 write # "RTN","TMGNDF3E",33,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF3E",34,0) if UsrSlct="^" goto MCDone "RTN","TMGNDF3E",35,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGNDF3E",36,0) "RTN","TMGNDF3E",37,0) if UsrSlct="InactivateUnused" do InactivateUnused goto MC1 "RTN","TMGNDF3E",38,0) if UsrSlct="KillUnused" do KillUnused goto MC1 "RTN","TMGNDF3E",39,0) if UsrSlct="BrowseUsed" do BrowseUsed goto MC1 "RTN","TMGNDF3E",40,0) if UsrSlct="CheckForBad" do ReviewForBad goto MC1 "RTN","TMGNDF3E",41,0) if UsrSlct="Prev" goto Menu^TMGNDF3D ;"quit can occur from there... "RTN","TMGNDF3E",42,0) if UsrSlct="Next" goto Menu^TMGNDF4A ;"quit can occur from there... "RTN","TMGNDF3E",43,0) goto MC1 "RTN","TMGNDF3E",44,0) "RTN","TMGNDF3E",45,0) MCDone "RTN","TMGNDF3E",46,0) quit "RTN","TMGNDF3E",47,0) "RTN","TMGNDF3E",48,0) ;"======================================================================= "RTN","TMGNDF3E",49,0) "RTN","TMGNDF3E",50,0) InactivateUnused "RTN","TMGNDF3E",51,0) ;"Purpose: To cycle through all DRUG entries and inactivate those "RTN","TMGNDF3E",52,0) ;" not linked to a non-skipped entry in 22706.9 (TMG FDA IMPORT COMPILED) "RTN","TMGNDF3E",53,0) ;"Input: none "RTN","TMGNDF3E",54,0) ;"Results: none. "RTN","TMGNDF3E",55,0) "RTN","TMGNDF3E",56,0) new count set count=0 "RTN","TMGNDF3E",57,0) new OnlyTMG set OnlyTMG=1 "RTN","TMGNDF3E",58,0) new % set %=1 "RTN","TMGNDF3E",59,0) write !,!,"When scanning through records in the DRUG file,",! "RTN","TMGNDF3E",60,0) write "should just entries that this FDA import process",! "RTN","TMGNDF3E",61,0) write "has added (for example, on a previous run), or ",! "RTN","TMGNDF3E",62,0) write "should ALL entries be considered for inactivation?",! "RTN","TMGNDF3E",63,0) write "Inactivate ONLY former FDA imports" do YN^DICN write ! "RTN","TMGNDF3E",64,0) if %=-1 goto IUDone "RTN","TMGNDF3E",65,0) if %=1 goto IU2 "RTN","TMGNDF3E",66,0) set %=1 "RTN","TMGNDF3E",67,0) write "Inactivate ALL DRUG entries" do YN^DICN write ! "RTN","TMGNDF3E",68,0) if %'=1 goto IUDone "RTN","TMGNDF3E",69,0) set OnlyTMG=0 "RTN","TMGNDF3E",70,0) "RTN","TMGNDF3E",71,0) IU2 new Itr,IEN "RTN","TMGNDF3E",72,0) new abort set abort=0 "RTN","TMGNDF3E",73,0) set IEN=$$ItrInit^TMGITR(50,.Itr) "RTN","TMGNDF3E",74,0) write !,"Scanning DRUG entries to find entries to inactivate...",! "RTN","TMGNDF3E",75,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3E",76,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF3E",77,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3E",78,0) . if (OnlyTMG=1),($$TMGAdded(IEN)=0) quit "RTN","TMGNDF3E",79,0) . new fdaIEN set fdaIEN=+$$GetfdaIEN^TMGNDFUT(IEN) "RTN","TMGNDF3E",80,0) . if (fdaIEN'>0)&(OnlyTMG=1) quit "RTN","TMGNDF3E",81,0) . if (fdaIEN>0),($piece($get(^TMG(22706.9,fdaIEN,1)),"^",4)'=1) quit ;" 1=SKIP "RTN","TMGNDF3E",82,0) . new InactiveDate set InactiveDate=$$GET1^DIQ(50,IEN_",",100) "RTN","TMGNDF3E",83,0) . if InactiveDate'="" quit ;"already inactivated. "RTN","TMGNDF3E",84,0) . ;"write "Inactivate-->",$$GET1^DIQ(50,IEN_",",.01),! "RTN","TMGNDF3E",85,0) . do AddMsg^TMGNDF3C(IEN,"TMG INACTIV D/T NO FDA") ;"Add a message in the Activity log field "RTN","TMGNDF3E",86,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3E",87,0) . set TMGFDA(50,IEN_",",100)="NOW" "RTN","TMGNDF3E",88,0) . do FILE^DIE("KE","TMGFDA","TMGMSG") "RTN","TMGNDF3E",89,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3E",90,0) . set count=count+1 "RTN","TMGNDF3E",91,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3E",92,0) "RTN","TMGNDF3E",93,0) IUDone "RTN","TMGNDF3E",94,0) write count," entries inactivated.",! "RTN","TMGNDF3E",95,0) do PressToCont^TMGUSRIF "RTN","TMGNDF3E",96,0) quit "RTN","TMGNDF3E",97,0) "RTN","TMGNDF3E",98,0) "RTN","TMGNDF3E",99,0) KillUnused "RTN","TMGNDF3E",100,0) ;"Purpose: To cycle through all DRUG entries and kill those "RTN","TMGNDF3E",101,0) ;" not linked to a non-skipped entry in 22706.9 (TMG FDA IMPORT COMPILED) "RTN","TMGNDF3E",102,0) ;"Input: none "RTN","TMGNDF3E",103,0) ;"Results: none. "RTN","TMGNDF3E",104,0) "RTN","TMGNDF3E",105,0) new count set count=0 "RTN","TMGNDF3E",106,0) "RTN","TMGNDF3E",107,0) write !,! "RTN","TMGNDF3E",108,0) write "**********************************************************",! "RTN","TMGNDF3E",109,0) write "NOTICE: * IMPORTANT *",! "RTN","TMGNDF3E",110,0) write "This process could delete drugs that are referenced",! "RTN","TMGNDF3E",111,0) write "by an active medical record. As such that would be",! "RTN","TMGNDF3E",112,0) write "an alteration of a record (i.e. illegal).",!,! "RTN","TMGNDF3E",113,0) write "This process should only be used during initial",! "RTN","TMGNDF3E",114,0) write "installation of the drug files (i.e. during debugging etc.)",!,! "RTN","TMGNDF3E",115,0) write "**********************************************************",! "RTN","TMGNDF3E",116,0) write "If you want to continue, type: 'I UNDERSTAND'",! "RTN","TMGNDF3E",117,0) new temp "RTN","TMGNDF3E",118,0) read "> ",temp:($get(DTIME,3600)),! "RTN","TMGNDF3E",119,0) if temp'="I UNDERSTAND" goto KUDone "RTN","TMGNDF3E",120,0) "RTN","TMGNDF3E",121,0) new Itr,IEN "RTN","TMGNDF3E",122,0) new abort set abort=0 "RTN","TMGNDF3E",123,0) set IEN=$$ItrInit^TMGITR(50,.Itr) "RTN","TMGNDF3E",124,0) write !,"Scanning DRUG entries to find unused entries to delete...",! "RTN","TMGNDF3E",125,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3E",126,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF3E",127,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3E",128,0) . new fdaIEN set fdaIEN=+$$GetfdaIEN^TMGNDFUT(IEN) "RTN","TMGNDF3E",129,0) . if (fdaIEN>0),($piece($get(^TMG(22706.9,fdaIEN,1)),"^",4)'=1) quit ;" 1=SKIP "RTN","TMGNDF3E",130,0) . new TMGFDA,TMGMSG "RTN","TMGNDF3E",131,0) . set TMGFDA(50,IEN_",",.01)="@" ;"delete record "RTN","TMGNDF3E",132,0) . do FILE^DIE("KE","TMGFDA","TMGMSG") "RTN","TMGNDF3E",133,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF3E",134,0) . set count=count+1 "RTN","TMGNDF3E",135,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF3E",136,0) "RTN","TMGNDF3E",137,0) KUDone "RTN","TMGNDF3E",138,0) write count," unlinked entries deleted.",! "RTN","TMGNDF3E",139,0) do PressToCont^TMGUSRIF "RTN","TMGNDF3E",140,0) quit "RTN","TMGNDF3E",141,0) "RTN","TMGNDF3E",142,0) "RTN","TMGNDF3E",143,0) "RTN","TMGNDF3E",144,0) TMGAdded(IEN50) "RTN","TMGNDF3E",145,0) ;"Purpose: to determine if the record in 50 is one that this TMG code added. "RTN","TMGNDF3E",146,0) ;"Input: IEN50 -- IEN in file 50 "RTN","TMGNDF3E",147,0) ;"Results: 1 if TMG added, 0 otherwise. "RTN","TMGNDF3E",148,0) "RTN","TMGNDF3E",149,0) new result set result=0 "RTN","TMGNDF3E",150,0) new idx set idx=0 "RTN","TMGNDF3E",151,0) for set idx=$order(^PSDRUG(IEN50,4,idx)) quit:(idx="")!(result=1) do "RTN","TMGNDF3E",152,0) . new msg set msg=$piece($get(^PSDRUG(IEN50,4,idx,0)),"^",5) "RTN","TMGNDF3E",153,0) . if $extract(msg,1,3)="TMG" set result=1 "RTN","TMGNDF3E",154,0) quit result "RTN","TMGNDF3E",155,0) "RTN","TMGNDF3E",156,0) ;"======================== "RTN","TMGNDF3E",157,0) GetUsed(pList,pSource) "RTN","TMGNDF3E",158,0) ;"Purpose: to Get a list of DRUG entries that are linked to from an import that is not SKIPPED "RTN","TMGNDF3E",159,0) ;"Input: pList -- PASS BY NAME. An OUT PARAMETER. Format: "RTN","TMGNDF3E",160,0) ;" @pList@(IEN50)="" "RTN","TMGNDF3E",161,0) ;" @pList@(IEN50)="" "RTN","TMGNDF3E",162,0) ;" pSource -- OPTIONAL. PASS BY NAME. an OUT PARAMETER. Format: "RTN","TMGNDF3E",163,0) ;" @pSource@(IEN50,IEN22706d9)="" "RTN","TMGNDF3E",164,0) ;" @pSource@(IEN50,IEN22706d9)="" "RTN","TMGNDF3E",165,0) ;"Results: None "RTN","TMGNDF3E",166,0) "RTN","TMGNDF3E",167,0) new Itr,IEN "RTN","TMGNDF3E",168,0) new temp "RTN","TMGNDF3E",169,0) set pSource=$get(pSource,"temp") "RTN","TMGNDF3E",170,0) new abort set abort=0 "RTN","TMGNDF3E",171,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF3E",172,0) write !,"Scanning DRUG entries to Browse/View...",! "RTN","TMGNDF3E",173,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF3E",174,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF3E",175,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF3E",176,0) . if $piece($get(^TMG(22706.9,IEN,1)),"^",4)=1 quit ;" 1=SKIP "RTN","TMGNDF3E",177,0) . new gIEN,tIEN "RTN","TMGNDF3E",178,0) . set tIEN=+$piece($get(^TMG(22706.9,IEN,7)),"^",1) "RTN","TMGNDF3E",179,0) . set gIEN=+$piece($get(^TMG(22706.9,IEN,7)),"^",1) "RTN","TMGNDF3E",180,0) . if tIEN>0 set @pList@(tIEN)="",@pSource@(tIEN,IEN)="" "RTN","TMGNDF3E",181,0) . if gIEN>0 set @pList@(gIEN)="",@pSource@(gIEN,IEN)="" "RTN","TMGNDF3E",182,0) "RTN","TMGNDF3E",183,0) quit "RTN","TMGNDF3E",184,0) "RTN","TMGNDF3E",185,0) BrowseUsed "RTN","TMGNDF3E",186,0) ;"Purpose: To Browse DRUG entries that are linked to a used import (not skipped) "RTN","TMGNDF3E",187,0) "RTN","TMGNDF3E",188,0) new List "RTN","TMGNDF3E",189,0) new Options,IEN "RTN","TMGNDF3E",190,0) "RTN","TMGNDF3E",191,0) set Options("FIELDS",1)=".01^GENERIC NAME^41" "RTN","TMGNDF3E",192,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3E",193,0) set Options("FIELDS",2)="31^NDC^16" "RTN","TMGNDF3E",194,0) set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3E",195,0) set Options("FIELDS","MAX NUM")=2 "RTN","TMGNDF3E",196,0) set Options("FILE")="50^DRUG" "RTN","TMGNDF3E",197,0) "RTN","TMGNDF3E",198,0) do GetUsed($name(Options("IEN LIST"))) "RTN","TMGNDF3E",199,0) "RTN","TMGNDF3E",200,0) new temp "RTN","TMGNDF3E",201,0) set temp=$$SELED^TMGSELED(.Options) "RTN","TMGNDF3E",202,0) "RTN","TMGNDF3E",203,0) BUDone quit "RTN","TMGNDF3E",204,0) "RTN","TMGNDF3E",205,0) "RTN","TMGNDF3E",206,0) ;"======================================= "RTN","TMGNDF3E",207,0) ReviewForBad "RTN","TMGNDF3E",208,0) ;"Purpose: To review DRUG entries for bad imports "RTN","TMGNDF3E",209,0) ;"Input: none "RTN","TMGNDF3E",210,0) ;"Output: ... "RTN","TMGNDF3E",211,0) "RTN","TMGNDF3E",212,0) ;"Results: None "RTN","TMGNDF3E",213,0) "RTN","TMGNDF3E",214,0) new List "RTN","TMGNDF3E",215,0) new IEN50List,IEN50,IEN22706d9,SrcList "RTN","TMGNDF3E",216,0) new IENTMGList "RTN","TMGNDF3E",217,0) new resultList "RTN","TMGNDF3E",218,0) "RTN","TMGNDF3E",219,0) do GetUsed("IEN50List","SrcList") "RTN","TMGNDF3E",220,0) "RTN","TMGNDF3E",221,0) do IENSelector^TMGUSRIF("IEN50List","resultList",50,".01",40,"Select any bad names to investigate them. [ESC][ESC] to exit",".01") "RTN","TMGNDF3E",222,0) "RTN","TMGNDF3E",223,0) new Options "RTN","TMGNDF3E",224,0) "RTN","TMGNDF3E",225,0) set IEN50="" "RTN","TMGNDF3E",226,0) for set IEN50=$order(resultList(IEN50)) quit:(IEN50="") do "RTN","TMGNDF3E",227,0) . set IEN22706d9=$order(^TMG(22706.9,"DRUGT",IEN50,"")) "RTN","TMGNDF3E",228,0) . if IEN22706d9'="" set Options("IEN LIST",IEN22706d9)="" "RTN","TMGNDF3E",229,0) . set IEN22706d9=$order(^TMG(22706.9,"DRUG",IEN50,"")) "RTN","TMGNDF3E",230,0) . if IEN22706d9'="" set Options("IEN LIST",IEN22706d9)="" "RTN","TMGNDF3E",231,0) "RTN","TMGNDF3E",232,0) set Options("FIELDS",1)=".055^TRADE NAME & FORM - 40^35" "RTN","TMGNDF3E",233,0) set Options("FIELDS",1,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3E",234,0) set Options("FIELDS",2)=".075^,@pSource@(tIEN,IEN)=""^35" "RTN","TMGNDF3E",235,0) set Options("FIELDS",2,"NO EDIT")=1 ;"i.e. show for browsing, but don't allow edit "RTN","TMGNDF3E",236,0) set Options("FIELDS",3)="6^SKIP THIS RECORD^5" "RTN","TMGNDF3E",237,0) set Options("FIELDS","MAX NUM")=3 "RTN","TMGNDF3E",238,0) set Options("FILE")="22706.9^TMG FDA IMPORT COMPILED" "RTN","TMGNDF3E",239,0) "RTN","TMGNDF3E",240,0) new temp "RTN","TMGNDF3E",241,0) set temp=$$SELED^TMGSELED(.Options) "RTN","TMGNDF3E",242,0) "RTN","TMGNDF3E",243,0) quit "RTN","TMGNDF4A") 0^53^B6524 "RTN","TMGNDF4A",1,0) TMGNDF4A ;TMG/kst/FDA Import: Create POI's from DRUGs ;03/25/06 "RTN","TMGNDF4A",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF4A",3,0) "RTN","TMGNDF4A",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4A",5,0) ;" Creation of records in file 50.7 (PHARMACY ORDERABLE ITEM file) "RTN","TMGNDF4A",6,0) ;" from all records stored in file 50 (DRUG file) "RTN","TMGNDF4A",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4A",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4A",9,0) ;"11-21-2006 "RTN","TMGNDF4A",10,0) "RTN","TMGNDF4A",11,0) ;"======================================================================= "RTN","TMGNDF4A",12,0) ;" API -- Public Functions. "RTN","TMGNDF4A",13,0) ;"======================================================================= "RTN","TMGNDF4A",14,0) ;"Menu "RTN","TMGNDF4A",15,0) "RTN","TMGNDF4A",16,0) ;"======================================================================= "RTN","TMGNDF4A",17,0) ;" Private Functions. "RTN","TMGNDF4A",18,0) ;"======================================================================= "RTN","TMGNDF4A",19,0) ;"InactivatePOIs -- inactivate all POI (entries in PHARMACY ORDERABLE ITEMS) "RTN","TMGNDF4A",20,0) ;"ActivatePOI(IEN50d7) -- remove the inactivation date that is automatically added "RTN","TMGNDF4A",21,0) ;"HandlePOIErr -- error handler for ActivatePOI "RTN","TMGNDF4A",22,0) "RTN","TMGNDF4A",23,0) ;"SyncAllTMG -- Add all relevent TMG entries into POI "RTN","TMGNDF4A",24,0) ;"AddFromTMG(IEN) -- Add/Update ONE entry in POI file "RTN","TMGNDF4A",25,0) ;"Do1POI(DrugNAF,IEN50,IEN50d606,IEN51d2) -- add/refresh one POI entry. "RTN","TMGNDF4A",26,0) "RTN","TMGNDF4A",27,0) ;"============================================================================= "RTN","TMGNDF4A",28,0) ;"============================================================================= "RTN","TMGNDF4A",29,0) "RTN","TMGNDF4A",30,0) Menu "RTN","TMGNDF4A",31,0) new Menu,UsrSlct "RTN","TMGNDF4A",32,0) set Menu(0)="Pick Option to Sync to PHARMACY ORDERABLE ITEMS (4A)" "RTN","TMGNDF4A",33,0) set Menu(1)="Sync Non-Skipped Imports to PHARMACY ORDERABLE ITEMS."_$char(9)_"SyncDRUGs" "RTN","TMGNDF4A",34,0) ;"set Menu(2)="Activate all PHARMACY ORDERABLE ITEMS (do after syncing)"_$char(9)_"ActivateAll" "RTN","TMGNDF4A",35,0) set Menu(3)="Kill all previous PHARMACY ORDERABLE ITEMS (only if needed!)"_$char(9)_"KillAll" "RTN","TMGNDF4A",36,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF4A",37,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF4A",38,0) "RTN","TMGNDF4A",39,0) M1 write # "RTN","TMGNDF4A",40,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4A",41,0) "RTN","TMGNDF4A",42,0) if UsrSlct="SyncDRUGs" do SyncAllTMG goto M1 "RTN","TMGNDF4A",43,0) ;"if UsrSlct="ActivateAll" do ActivAll goto M1 "RTN","TMGNDF4A",44,0) if UsrSlct="KillAll" do KillPOIs goto M1 "RTN","TMGNDF4A",45,0) if UsrSlct="Prev" goto Menu^TMGNDF3E ;"quit can occur from there... "RTN","TMGNDF4A",46,0) if UsrSlct="Next" goto Menu^TMGNDF4B ;"quit can occur from there... "RTN","TMGNDF4A",47,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF4A",48,0) goto M1 "RTN","TMGNDF4A",49,0) "RTN","TMGNDF4A",50,0) MenuDone "RTN","TMGNDF4A",51,0) quit "RTN","TMGNDF4A",52,0) "RTN","TMGNDF4A",53,0) "RTN","TMGNDF4A",54,0) ;"============================================================================= "RTN","TMGNDF4A",55,0) ;"File 50.7 (PHARMACY ORDERABLE ITEM): "RTN","TMGNDF4A",56,0) ;" "RTN","TMGNDF4A",57,0) ;" **A record in 50.7 should be created first. "RTN","TMGNDF4A",58,0) ;" .01 field should be the generic name of the drug. "RTN","TMGNDF4A",59,0) ;" When the record is created, an entry in fle 101.43 (ORDERABLE ITEM) will automatically be made. "RTN","TMGNDF4A",60,0) ;" Also, a record in in ORDER QUICK VIEW will also be created (but it is incomplete--see below.) "RTN","TMGNDF4A",61,0) ;" Note: new drugs may not be added unless PSEDITNM>0. So to setup a drug in fileman, "RTN","TMGNDF4A",62,0) ;" set PSEDITNM=1 from the command-line, then DO D^DI to get into Fileman with vars intact. "RTN","TMGNDF4A",63,0) ;" In the MED ROUTE field, the input transform does not allow an input of "ORAL". (If left "RTN","TMGNDF4A",64,0) ;" blank ORAL will be shown in CPRS) "RTN","TMGNDF4A",65,0) ;" This file can hold the synonyms of a drug etc. "RTN","TMGNDF4A",66,0) ;" When this record is created, for some reason it is automatically given the current "RTN","TMGNDF4A",67,0) ;" date in the INACTIVE DAT "RTN","TMGNDF4A",68,0) ;"Purpose: to Ask E field--meaning it is created in an inactive state. One must "RTN","TMGNDF4A",69,0) ;" go back and edit the record a second time to remove the entry from this field. "RTN","TMGNDF4A",70,0) ;" File 101.43 (ORDERABLE ITEM), field ID holds a text pointer to this file, e.g. "RTN","TMGNDF4A",71,0) ;" '10;99PSP' <---- 10 is IEN in file #50.7 "RTN","TMGNDF4A",72,0) ;" There is no pointer field from file 50.7 up to file 50. The link is FROM file #50 "RTN","TMGNDF4A",73,0) ;" TO #50.7 (via file #50's field 2.1(PHARMACY ORDERABLE ITEM)). HOWEVER, File #50.7's "RTN","TMGNDF4A",74,0) ;" "ASP" cross-reference for the field "PHARMACY ORDERABLE ITEM (#2.1) i.e. "RTN","TMGNDF4A",75,0) ;" ^PSDRUG("ASP",+ID,*), contains list of linked records in file #50 "RTN","TMGNDF4A",76,0) "RTN","TMGNDF4A",77,0) ;"================================================================= "RTN","TMGNDF4A",78,0) "RTN","TMGNDF4A",79,0) SyncAllTMG "RTN","TMGNDF4A",80,0) ;"Purpose: Sync/Add all relevent TMG entries into POI "RTN","TMGNDF4A",81,0) ;"Input:none "RTN","TMGNDF4A",82,0) ;"results: none "RTN","TMGNDF4A",83,0) "RTN","TMGNDF4A",84,0) new IEN,Itr "RTN","TMGNDF4A",85,0) new abort set abort=0 "RTN","TMGNDF4A",86,0) new result set result=0 "RTN","TMGNDF4A",87,0) new repeatNeeded set repeatNeeded=0 "RTN","TMGNDF4A",88,0) "RTN","TMGNDF4A",89,0) SATL1 set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF4A",90,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4A",91,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!(abort=1) "RTN","TMGNDF4A",92,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4A",93,0) . new Option "RTN","TMGNDF4A",94,0) . set Option("CUR MODE")="TRADE" "RTN","TMGNDF4A",95,0) . set result=$$POIFromTMG(IEN,.Option) ;"screen for skip will occur in function "RTN","TMGNDF4A",96,0) . if result=-1 set repeatNeeded=1 "RTN","TMGNDF4A",97,0) . set Option("CUR MODE")="GENERIC" "RTN","TMGNDF4A",98,0) . set result=$$POIFromTMG(IEN,.Option) ;"screen for skip will occur in function "RTN","TMGNDF4A",99,0) . if result=-1 set repeatNeeded=1 "RTN","TMGNDF4A",100,0) "RTN","TMGNDF4A",101,0) new % set %=2 "RTN","TMGNDF4A",102,0) if repeatNeeded do "RTN","TMGNDF4A",103,0) . write !,"Error found and repeat scan needed.",! "RTN","TMGNDF4A",104,0) . write "Repeat scan now" do YN^DICN write ! "RTN","TMGNDF4A",105,0) else do "RTN","TMGNDF4A",106,0) . write ! "RTN","TMGNDF4A",107,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4A",108,0) if %=1 goto SATL1 "RTN","TMGNDF4A",109,0) "RTN","TMGNDF4A",110,0) quit "RTN","TMGNDF4A",111,0) "RTN","TMGNDF4A",112,0) "RTN","TMGNDF4A",113,0) POIFromTMG(IEN22706d9,Option) "RTN","TMGNDF4A",114,0) ;"Purpose: to Add/Update/(or delete) ONE entry in POI (50.7) file "RTN","TMGNDF4A",115,0) ;"Input: IEN22706d9 -- IEN in 22706.9 "RTN","TMGNDF4A",116,0) ;" Option -- NON-OPTIONAL part. Format: "RTN","TMGNDF4A",117,0) ;" Option("CUR MODE")="TRADE" or "GENERIC" "RTN","TMGNDF4A",118,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF4A",119,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF4A",120,0) ;" to file POI, OI, OQV etc. "RTN","TMGNDF4A",121,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF4A",122,0) ;" Option("IEN50","TRADE")=IEN50 for Trade Name "RTN","TMGNDF4A",123,0) ;" Option("IEN50","GENERIC")=IEN50 for Generic Name "RTN","TMGNDF4A",124,0) ;" Option("CUR MODE")="TRADE" or "GENERIC" "RTN","TMGNDF4A",125,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF4A",126,0) ;" Option("DELETING")=1 <-- deleting chain (not IEN22706d9) "RTN","TMGNDF4A",127,0) "RTN","TMGNDF4A",128,0) ;"NOTE: This function does DOES screen for skipped entries, and skips "RTN","TMGNDF4A",129,0) ;" proccessing. BUT, if Deleting, then it is NOT skipped "RTN","TMGNDF4A",130,0) ;"Output: POI records will be added or refreshed (or deleted) "RTN","TMGNDF4A",131,0) ;"Result: 1=OK, 0=Error, -1 process repeat requested "RTN","TMGNDF4A",132,0) "RTN","TMGNDF4A",133,0) new result set result=1 "RTN","TMGNDF4A",134,0) new repeatNeeded set repeatNeeded=0 "RTN","TMGNDF4A",135,0) new TMGA,TMGMSG "RTN","TMGNDF4A",136,0) new IEN50d606,IEN51d2,IEN50d7 "RTN","TMGNDF4A",137,0) "RTN","TMGNDF4A",138,0) if $get(Option("DELETING"))'=1,$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 goto AFTMGDone ;"1=SKIP "RTN","TMGNDF4A",139,0) if +$get(IEN22706d9)=0 goto AFTMGDone "RTN","TMGNDF4A",140,0) "RTN","TMGNDF4A",141,0) new mode set mode=$get(Option("CUR MODE")) "RTN","TMGNDF4A",142,0) if mode="" set result=0 goto AFTMGDone "RTN","TMGNDF4A",143,0) new field,node,pce "RTN","TMGNDF4A",144,0) if mode="GENERIC" set field=5.71,node=8,pce=4 ;"5.71= POI ptr Generic "RTN","TMGNDF4A",145,0) else if mode="TRADE" set field=5.61,node=8,pce=3 ;"5.61 = POI ptr Trade "RTN","TMGNDF4A",146,0) "RTN","TMGNDF4A",147,0) do LoadOption^TMGNDF4C(IEN22706d9,.Option) "RTN","TMGNDF4A",148,0) "RTN","TMGNDF4A",149,0) set IEN50d606=$piece($get(^TMG(22706.9,IEN22706d9,0)),"^",7) "RTN","TMGNDF4A",150,0) set IEN51d2=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",7) "RTN","TMGNDF4A",151,0) new IEN50 set IEN50=+$get(Option("IEN50",mode)) "RTN","TMGNDF4A",152,0) if IEN50=0 set result=0 goto AFTM2 "RTN","TMGNDF4A",153,0) "RTN","TMGNDF4A",154,0) new DrugNAF set DrugNAF=$get(Option("DRUG NAME AND FORM",mode)) "RTN","TMGNDF4A",155,0) if (DrugNAF="")!(DrugNAF="") goto AFTM2 ;"skip these... "RTN","TMGNDF4A",156,0) "RTN","TMGNDF4A",157,0) set IEN50d7=+$get(Option("IEN50.7",mode)) "RTN","TMGNDF4A",158,0) "RTN","TMGNDF4A",159,0) if $get(Option("DELETING"))=1 do goto AFTMGDone "RTN","TMGNDF4A",160,0) . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4A",161,0) . set Option("IEN50.7",mode)="" "RTN","TMGNDF4A",162,0) "RTN","TMGNDF4A",163,0) if IEN50d7=0 set IEN50d7=$$FindPOI^TMGNDFUT(DrugNAF) "RTN","TMGNDF4A",164,0) if IEN50d7=0 do if IEN50d7=0 set result=0 goto AFTM2 "RTN","TMGNDF4A",165,0) . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4A",166,0) . new PSEDITNM set PSEDITNM=1 ;"a key to allow editing data "RTN","TMGNDF4A",167,0) . set TMGFDA(50.7,"+1,",.01)=DrugNAF "RTN","TMGNDF4A",168,0) . set TMGFDA(50.7,"+1,",.02)=IEN50d606 "RTN","TMGNDF4A",169,0) . set TMGFDA(50.7,"+1,",.06)=IEN51d2 "RTN","TMGNDF4A",170,0) . set TMGFDA(50.7,"+1,",.07)="R" "RTN","TMGNDF4A",171,0) . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF4A",172,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",173,0) . . set result=0 "RTN","TMGNDF4A",174,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",175,0) . else set IEN50d7=+$get(TMGIEN(1)) "RTN","TMGNDF4A",176,0) else do "RTN","TMGNDF4A",177,0) . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4A",178,0) . new PSEDITNM set PSEDITNM=1 ;"a key to allow editing data "RTN","TMGNDF4A",179,0) . set TMGFDA(50.7,IEN50d7_",",.01)=DrugNAF "RTN","TMGNDF4A",180,0) . set TMGFDA(50.7,IEN50d7_",",.02)=IEN50d606 "RTN","TMGNDF4A",181,0) . set TMGFDA(50.7,IEN50d7_",",.06)=IEN51d2 "RTN","TMGNDF4A",182,0) . set TMGFDA(50.7,IEN50d7_",",.07)="R" "RTN","TMGNDF4A",183,0) . new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF4A",184,0) . if $data(TMGFDA)=0 quit "RTN","TMGNDF4A",185,0) . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",186,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",187,0) . . set result=0 "RTN","TMGNDF4A",188,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",189,0) . . if $get(TMGMSG("DIERR",1))=601 do ;"601 --> [record doesn't exist] "RTN","TMGNDF4A",190,0) . . . write "Dangling pointer found & removed. ** RUN ENTIRE PROCESS AGAIN **",! "RTN","TMGNDF4A",191,0) . . . set IEN50d7=0 "RTN","TMGNDF4A",192,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDF4A",193,0) . . . set TMGFDA(22706.9,IEN22706d9_",",field)="@" "RTN","TMGNDF4A",194,0) . . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",195,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",196,0) . . . kill TMGFDA,TMGMSG "RTN","TMGNDF4A",197,0) . . . set TMGFDA(50,IEN50_",",2.1)="@" "RTN","TMGNDF4A",198,0) . . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",199,0) . . . set repeatNeeded=1 "RTN","TMGNDF4A",200,0) . . . set result=-1 "RTN","TMGNDF4A",201,0) . . . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",202,0) . . . . if $data(TMGMSG("DIERR","E",120))>0 set result="" quit ;"ignore error if #120 (hook) present. "RTN","TMGNDF4A",203,0) . . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",204,0) "RTN","TMGNDF4A",205,0) set Option("IEN50.7",mode)=IEN50d7 "RTN","TMGNDF4A",206,0) "RTN","TMGNDF4A",207,0) ;"Ensure pointer to POI stored in TMG IMPORT COMPILED "RTN","TMGNDF4A",208,0) if +$piece($get(^TMG(22706.9,IEN22706d9,node)),"^",pce)'=IEN50d7 do "RTN","TMGNDF4A",209,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4A",210,0) . set TMGFDA(22706.9,IEN22706d9_",",field)=IEN50d7 "RTN","TMGNDF4A",211,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4A",212,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",213,0) . set Option("IEN50.7",mode)=IEN50d7 "RTN","TMGNDF4A",214,0) "RTN","TMGNDF4A",215,0) ;"Ensure pointer to POI stored in DRUG file, field 2.1 "RTN","TMGNDF4A",216,0) if +$piece($get(^PSDRUG(IEN50,2)),"^",1)'=IEN50d7 do "RTN","TMGNDF4A",217,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4A",218,0) . set TMGFDA(50,IEN50_",",2.1)=IEN50d7 "RTN","TMGNDF4A",219,0) . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",220,0) . set result=0 "RTN","TMGNDF4A",221,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",222,0) . . if $data(TMGMSG("DIERR","E",120))>0 set result="" quit ;"ignore error if #120 (hook) present. "RTN","TMGNDF4A",223,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",224,0) "RTN","TMGNDF4A",225,0) AFTM2 "RTN","TMGNDF4A",226,0) if $get(Option("FIX CHAIN"))=1 do ;"pass message forward for fix "RTN","TMGNDF4A",227,0) . do Activ1TMG^TMGNDF4B(IEN22706d9) "RTN","TMGNDF4A",228,0) . new temp set temp=$$OIFromTMG^TMGNDF4C(IEN22706d9,.Option) ;" <-- more chaining from this "RTN","TMGNDF4A",229,0) . ;"if $get(Option("DELETING"))=1 do "RTN","TMGNDF4A",230,0) . ;". new IEN50 set IEN50=+$get(Option("IEN50",mode)) "RTN","TMGNDF4A",231,0) . ;". if IEN50=0 write "?? 1 -- In POIFromTMG^TMGNDF4A.",! quit "RTN","TMGNDF4A",232,0) . ;". new IEN50d7 set IEN50d7=+$get(Option("IEN50d7",mode)) "RTN","TMGNDF4A",233,0) . ;". if IEN50d7=0 set IEN50d7=+$piece(^PSDRUG(IEN50,2),"^",1) ;"try a second way "RTN","TMGNDF4A",234,0) . ;". if IEN50d7=0 write "?? 2 -- In POIFromTMG^TMGNDF4A.",! quit "RTN","TMGNDF4A",235,0) . ;". new numRef set numRef=$$ListCt^TMGMISC($name(^PSDRUG("ASP",IEN50d7))) "RTN","TMGNDF4A",236,0) . ;". if numRef>1 quit ;"don't kill POI if another drug in 50 points to it "RTN","TMGNDF4A",237,0) . ;". new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF4A",238,0) . ;". new PSEDITNM set PSEDITNM=1 ;"a key to allow editing data "RTN","TMGNDF4A",239,0) . ;". set TMGFDA(50.7,IEN50d7_",",.01)="@" ;"delete pointer from file 50 "RTN","TMGNDF4A",240,0) . ;". do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF4A",241,0) . ;". if $$ShowIfError^TMGDBAPI(.TMGMSG) quit "RTN","TMGNDF4A",242,0) . ;". ;"Now delete from TMG IMPORT COMPILED "RTN","TMGNDF4A",243,0) . ;". new field "RTN","TMGNDF4A",244,0) . ;". if mode="GENERIC" set field=5.71 "RTN","TMGNDF4A",245,0) . ;". else if mode="TRADE" set field=5.61 "RTN","TMGNDF4A",246,0) . ;". else write "Can't delete pointer to 50.7 from 22706.9.",!,"Can't determine if GENERIC or TRADE mode.",! quit "RTN","TMGNDF4A",247,0) . ;". set TMGFDA(22706.9,IEN22706d9_",",field)="@" ;"delete pointer from TMG IMPORT COMPILED "RTN","TMGNDF4A",248,0) . ;". do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF4A",249,0) . ;". if $$ShowIfError^TMGDBAPI(.TMGMSG) quit "RTN","TMGNDF4A",250,0) "RTN","TMGNDF4A",251,0) AFTMGDone "RTN","TMGNDF4A",252,0) if repeatNeeded=1 set result=-1 "RTN","TMGNDF4A",253,0) quit result "RTN","TMGNDF4A",254,0) "RTN","TMGNDF4A",255,0) ;" === Do1POI is old -- delete later... "RTN","TMGNDF4A",256,0) Do1POI(IEN22706d9,IEN50d606,IEN51d2,Option) "RTN","TMGNDF4A",257,0) ;"Purpose: add/refresh one PHARMACY ORDERABLE ITEM (POI) entry. "RTN","TMGNDF4A",258,0) ;"Input: IEN22706d9 -- IEN in 22706.9 "RTN","TMGNDF4A",259,0) ;" IEN50d606 -- IEN in 50.606 "RTN","TMGNDF4A",260,0) ;" IEN51d2 -- IEN in 51.2 "RTN","TMGNDF4A",261,0) ;" Option -- NON-OPTIONAL PART. Format: "RTN","TMGNDF4A",262,0) ;" Option("CUR MODE")="TRADE" or "GENERIC" "RTN","TMGNDF4A",263,0) ;" Option("IEN50.7","TRADE")=IEN50.7 for Trade Name "RTN","TMGNDF4A",264,0) ;" Option("IEN50.7","GENERIC")=IEN50.7 for Generic Name "RTN","TMGNDF4A",265,0) ;" Option("DRUG NAME AND FORM","TRADE")=Trade Name and Form "RTN","TMGNDF4A",266,0) ;" Option("DRUG NAME AND FORM","GENERIC")=Generic Name and Form "RTN","TMGNDF4A",267,0) ;" Option("IEN50","TRADE")=IEN50 for Trade Name "RTN","TMGNDF4A",268,0) ;" Option("IEN50","GENERIC")=IEN50 for Generic Name "RTN","TMGNDF4A",269,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF4A",270,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF4A",271,0) ;" to file POI, OI, OQV etc. "RTN","TMGNDF4A",272,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF4A",273,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF4A",274,0) ;" Option("DELETING")=1 <-- deleting chain (not IEN22706d9) "RTN","TMGNDF4A",275,0) ;"Result: IEN50d7 if OK, -1 =Error, -2 process repeat requested "RTN","TMGNDF4A",276,0) "RTN","TMGNDF4A",277,0) new result set result="" ;"default to null "RTN","TMGNDF4A",278,0) new TMGA,TMGMSG "RTN","TMGNDF4A",279,0) new IEN50d7 set IEN50d7=-1 ;"default to error "RTN","TMGNDF4A",280,0) new mode set mode=$get(Option("CUR MODE")) "RTN","TMGNDF4A",281,0) if mode="" write "ERROR: in Do1POI^TMGNDF4A. Mode not supplied.",! goto D1PDone "RTN","TMGNDF4A",282,0) new DrugNAF set DrugNAF=$get(Option("DRUG NAME AND FORM",mode)) "RTN","TMGNDF4A",283,0) if (DrugNAF="")!(DrugNAF="") goto D1PDone ;"skip these... "RTN","TMGNDF4A",284,0) new IEN50 set IEN50=+$get(Option("IEN50",mode)) if IEN50=0 set result=-1 goto D1PDone "RTN","TMGNDF4A",285,0) new IEN50d7 set IEN50d7=+$get(Option("IEN50.7",mode)) "RTN","TMGNDF4A",286,0) new field,node,pce "RTN","TMGNDF4A",287,0) if mode="GENERIC" set field=5.71,node=8,pce=4 ;"5.71= POI ptr Generic "RTN","TMGNDF4A",288,0) else if mode="TRADE" set field=5.61,node=8,pce=3 ;"5.61 = POI ptr Trade "RTN","TMGNDF4A",289,0) "RTN","TMGNDF4A",290,0) if IEN50d7=0 set IEN50d7=$$FindPOI^TMGNDFUT(DrugNAF) "RTN","TMGNDF4A",291,0) if IEN50d7=0 do "RTN","TMGNDF4A",292,0) . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4A",293,0) . new PSEDITNM set PSEDITNM=1 ;"a key to allow editing data "RTN","TMGNDF4A",294,0) . set TMGFDA(50.7,"+1,",.01)=DrugNAF "RTN","TMGNDF4A",295,0) . set TMGFDA(50.7,"+1,",.02)=IEN50d606 "RTN","TMGNDF4A",296,0) . set TMGFDA(50.7,"+1,",.06)=IEN51d2 "RTN","TMGNDF4A",297,0) . set TMGFDA(50.7,"+1,",.07)="R" "RTN","TMGNDF4A",298,0) . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF4A",299,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",300,0) . . set result=-1 "RTN","TMGNDF4A",301,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",302,0) . else set IEN50d7=+$get(TMGIEN(1)) "RTN","TMGNDF4A",303,0) else do "RTN","TMGNDF4A",304,0) . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4A",305,0) . new PSEDITNM set PSEDITNM=1 ;"a key to allow editing data "RTN","TMGNDF4A",306,0) . set TMGFDA(50.7,IEN50d7_",",.01)=DrugNAF "RTN","TMGNDF4A",307,0) . set TMGFDA(50.7,IEN50d7_",",.02)=IEN50d606 "RTN","TMGNDF4A",308,0) . set TMGFDA(50.7,IEN50d7_",",.06)=IEN51d2 "RTN","TMGNDF4A",309,0) . set TMGFDA(50.7,IEN50d7_",",.07)="R" "RTN","TMGNDF4A",310,0) . new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF4A",311,0) . if $data(TMGFDA)=0 quit "RTN","TMGNDF4A",312,0) . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",313,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",314,0) . . set result=-1 "RTN","TMGNDF4A",315,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",316,0) . . if $get(TMGMSG("DIERR",1))=601 do ;"601 --> [record doesn't exist] "RTN","TMGNDF4A",317,0) . . . write "Dangling pointer found & removed. ** RUN ENTIRE PROCESS AGAIN **",! "RTN","TMGNDF4A",318,0) . . . set IEN50d7=0 "RTN","TMGNDF4A",319,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDF4A",320,0) . . . set TMGFDA(22706.9,IEN22706d9_",",field)="@" "RTN","TMGNDF4A",321,0) . . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",322,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",323,0) . . . kill TMGFDA,TMGMSG "RTN","TMGNDF4A",324,0) . . . set TMGFDA(50,IEN50_",",2.1)="@" "RTN","TMGNDF4A",325,0) . . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",326,0) . . . set result=-1 "RTN","TMGNDF4A",327,0) . . . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",328,0) . . . . if $data(TMGMSG("DIERR","E",120))>0 set result="" quit ;"ignore error if #120 (hook) present. "RTN","TMGNDF4A",329,0) . . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",330,0) "RTN","TMGNDF4A",331,0) if +IEN50d7=0 set result=-1 goto D1PDone "RTN","TMGNDF4A",332,0) "RTN","TMGNDF4A",333,0) ;"if +$get(Option("IEN50.7",mode))=0 do "RTN","TMGNDF4A",334,0) ;". new TMGFDA,TMGMSG "RTN","TMGNDF4A",335,0) ;". set TMGFDA(22706.9,IEN22706d9_",",field)=IEN50d7 "RTN","TMGNDF4A",336,0) ;". do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",337,0) ;". do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",338,0) ;". set Option("IEN50.7",mode)=IEN50d7 "RTN","TMGNDF4A",339,0) "RTN","TMGNDF4A",340,0) ;"Store pointer to POI in TMG IMPORT COMPILED "RTN","TMGNDF4A",341,0) if +$piece($get(^TMG(22706.9,IEN22706d9,node)),"^",pce)'=IEN50d7 do "RTN","TMGNDF4A",342,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4A",343,0) . set TMGFDA(22706.9,IEN22706d9_",",field)=IEN50d7 "RTN","TMGNDF4A",344,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4A",345,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",346,0) . set Option("IEN50.7",mode)=IEN50d7 "RTN","TMGNDF4A",347,0) "RTN","TMGNDF4A",348,0) if +$piece($get(^PSDRUG(IEN50,2)),"^",1)'=IEN50d7 do "RTN","TMGNDF4A",349,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4A",350,0) . set TMGFDA(50,IEN50_",",2.1)=IEN50d7 "RTN","TMGNDF4A",351,0) . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4A",352,0) . set result=-1 "RTN","TMGNDF4A",353,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4A",354,0) . . if $data(TMGMSG("DIERR","E",120))>0 set result="" quit ;"ignore error if #120 (hook) present. "RTN","TMGNDF4A",355,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",356,0) "RTN","TMGNDF4A",357,0) D1PDone "RTN","TMGNDF4A",358,0) if result="" set result=IEN50d7 "RTN","TMGNDF4A",359,0) quit result "RTN","TMGNDF4A",360,0) "RTN","TMGNDF4A",361,0) ;"================================================================= "RTN","TMGNDF4A",362,0) ;"================================================================= "RTN","TMGNDF4A",363,0) "RTN","TMGNDF4A",364,0) "RTN","TMGNDF4A",365,0) InactivatePOIs "RTN","TMGNDF4A",366,0) ;"Purpose: To inactivate all POI (entries in PHARMACY ORDERABLE ITEMS) "RTN","TMGNDF4A",367,0) ;" This will prevent left-over entries from a prior run to cause problems "RTN","TMGNDF4A",368,0) "RTN","TMGNDF4A",369,0) new Itr,IEN "RTN","TMGNDF4A",370,0) new abort set abort=0 "RTN","TMGNDF4A",371,0) write "Inactivating all prior PHARMACY ORDERABLE ITEMS...",! "RTN","TMGNDF4A",372,0) set IEN=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4A",373,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4A",374,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF4A",375,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4A",376,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4A",377,0) . set TMGFDA(50.7,IEN_",",.04)="NOW" "RTN","TMGNDF4A",378,0) . do FILE^DIE("KE","TMGFDA","TMGMSG") "RTN","TMGNDF4A",379,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4A",380,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4A",381,0) "RTN","TMGNDF4A",382,0) quit "RTN","TMGNDF4A",383,0) "RTN","TMGNDF4A",384,0) "RTN","TMGNDF4A",385,0) ActivAll "RTN","TMGNDF4A",386,0) ;"DISABLED... THIS SHOULD BE DONE IN TMENDF4B... "RTN","TMGNDF4A",387,0) "RTN","TMGNDF4A",388,0) ;"Purpose: to activate all POI's "RTN","TMGNDF4A",389,0) "RTN","TMGNDF4A",390,0) new Itr,IEN "RTN","TMGNDF4A",391,0) new abort set abort=0 "RTN","TMGNDF4A",392,0) set IEN=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4A",393,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4A",394,0) if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF4A",395,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4A",396,0) . new temp "RTN","TMGNDF4A",397,0) . set temp=$$ActivatePOI(IEN) "RTN","TMGNDF4A",398,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4A",399,0) "RTN","TMGNDF4A",400,0) quit "RTN","TMGNDF4A",401,0) "RTN","TMGNDF4A",402,0) "RTN","TMGNDF4A",403,0) "RTN","TMGNDF4A",404,0) ActivatePOI(IEN50d7) "RTN","TMGNDF4A",405,0) ;"Purpose: to remove the inactivation date that is automatically "RTN","TMGNDF4A",406,0) ;" added with editing of the POI record "RTN","TMGNDF4A",407,0) ;"result: 1 = OK, 0=error "RTN","TMGNDF4A",408,0) "RTN","TMGNDF4A",409,0) new result set result=1 "RTN","TMGNDF4A",410,0) "RTN","TMGNDF4A",411,0) new TMGFDA,TMGMSG "RTN","TMGNDF4A",412,0) set TMGFDA(50.7,IEN50d7_",",.04)="@" ;"delete inactivation date field value "RTN","TMGNDF4A",413,0) do "RTN","TMGNDF4A",414,0) . new $etrap set $etrap="do HandlePOIErr^TMGNDF4A quit" "RTN","TMGNDF4A",415,0) . do FILE^DIE("ES","TMGFDA","TMGMSG") "RTN","TMGNDF4A",416,0) if $data(TMGMSG("DIERR"))'=0 do goto APOIDone "RTN","TMGNDF4A",417,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGNDF4A",418,0) . set result=0 "RTN","TMGNDF4A",419,0) . write "Error occurred in function ActivatePOI",! "RTN","TMGNDF4A",420,0) . zwr TMGFDA "RTN","TMGNDF4A",421,0) APOIDone "RTN","TMGNDF4A",422,0) quit result "RTN","TMGNDF4A",423,0) "RTN","TMGNDF4A",424,0) "RTN","TMGNDF4A",425,0) HandlePOIErr "RTN","TMGNDF4A",426,0) ;"Purpose: An error handler for ActivatePOI "RTN","TMGNDF4A",427,0) set $ECODE="" "RTN","TMGNDF4A",428,0) if result=0 quit "RTN","TMGNDF4A",429,0) set result=0 "RTN","TMGNDF4A",430,0) write "Error encountered activating Pharmacy Orderable Item: " "RTN","TMGNDF4A",431,0) write $piece($get(^PS(50.7,IEN50d7,0)),"^",1)," (#",IEN50d7,")",! "RTN","TMGNDF4A",432,0) ;"Note: below won't set needed xrefs etc. "RTN","TMGNDF4A",433,0) ;"set $piece(^PS(50.7,IEN50d7,0),"^",4)="" "RTN","TMGNDF4A",434,0) ;"write "Fixed with low-level removal of inactivation date.",! "RTN","TMGNDF4A",435,0) quit "RTN","TMGNDF4A",436,0) "RTN","TMGNDF4A",437,0) "RTN","TMGNDF4A",438,0) "RTN","TMGNDF4A",439,0) KillPOIs "RTN","TMGNDF4A",440,0) ;"Purpose: to kill all POI's, do allow fresh start (after errors) "RTN","TMGNDF4A",441,0) "RTN","TMGNDF4A",442,0) new % set %=2 "RTN","TMGNDF4A",443,0) write "Are you sure you want to perminantly KILL all PHARMACY ORDERABLE ITEMS" "RTN","TMGNDF4A",444,0) do YN^DICN "RTN","TMGNDF4A",445,0) if %'=1 goto KPOIDone "RTN","TMGNDF4A",446,0) "RTN","TMGNDF4A",447,0) new Itr,IEN50d7 "RTN","TMGNDF4A",448,0) new abort set abort=0 "RTN","TMGNDF4A",449,0) set IEN50d7=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4A",450,0) do PrepProgress^TMGITR(.Itr,2,0,"IEN50d7") "RTN","TMGNDF4A",451,0) if IEN50d7'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN50d7)'>0)!abort "RTN","TMGNDF4A",452,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4A",453,0) . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4A",454,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4A",455,0) "RTN","TMGNDF4A",456,0) KPOIDone "RTN","TMGNDF4A",457,0) quit "RTN","TMGNDF4B") 0^54^B7237 "RTN","TMGNDF4B",1,0) TMGNDF4B ;TMG/kst/FDA Import: Activation of POI's ;03/25/06 "RTN","TMGNDF4B",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF4B",3,0) "RTN","TMGNDF4B",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4B",5,0) ;" Activation of records in PHARMACY ORDERABLE ITEM file "RTN","TMGNDF4B",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4B",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4B",8,0) ;"11-21-2006 "RTN","TMGNDF4B",9,0) "RTN","TMGNDF4B",10,0) ;"======================================================================= "RTN","TMGNDF4B",11,0) ;" API -- Public Functions. "RTN","TMGNDF4B",12,0) ;"======================================================================= "RTN","TMGNDF4B",13,0) ;"Menu "RTN","TMGNDF4B",14,0) "RTN","TMGNDF4B",15,0) ;"ActivAll -- remove the inactive date for all records in 50.7 "RTN","TMGNDF4B",16,0) ;"Activ1TMG(IEN) -- activate records linked from 22706.9 in 50.7 "RTN","TMGNDF4B",17,0) ;"Activ1Rx(IEN50) -- activate records linked from 50 in 50.7 "RTN","TMGNDF4B",18,0) "RTN","TMGNDF4B",19,0) ;"======================================================================= "RTN","TMGNDF4B",20,0) ;" Private Functions. "RTN","TMGNDF4B",21,0) ;"======================================================================= "RTN","TMGNDF4B",22,0) ;"ActivDate(DateAfter) -- remove inactive date if inactive date on/after DateAfter "RTN","TMGNDF4B",23,0) ;"XFormOff -- remove restrinction in input transform that prevents deletion. "RTN","TMGNDF4B",24,0) ;"XFormOn -- restore the input transform to field .04 in file 50.7 "RTN","TMGNDF4B",25,0) ;"SetXForm(code) -- remove the old input transform, and replace with code "RTN","TMGNDF4B",26,0) "RTN","TMGNDF4B",27,0) "RTN","TMGNDF4B",28,0) ;"======================================================================= "RTN","TMGNDF4B",29,0) "RTN","TMGNDF4B",30,0) Menu "RTN","TMGNDF4B",31,0) "RTN","TMGNDF4B",32,0) new Menu,UsrSlct "RTN","TMGNDF4B",33,0) set Menu(0)="Pick Option to Activate PHARMACY ORDERABLE ITEMS (4B)" "RTN","TMGNDF4B",34,0) set Menu(1)="Activate import PHARMACY ORDERABLE ITEMS."_$char(9)_"ActivateImports" "RTN","TMGNDF4B",35,0) set Menu(2)="Inactivate POI's NOT from an active FDA import."_$char(9)_"InactivateNonImports" "RTN","TMGNDF4B",36,0) set Menu(3)="Check for duplicate entries in POI file"_$char(9)_"Check4Dups" "RTN","TMGNDF4B",37,0) set Menu(4)="Check for dangling entries in POI file"_$char(9)_"Check4Dangle" "RTN","TMGNDF4B",38,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF4B",39,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF4B",40,0) "RTN","TMGNDF4B",41,0) M1 write # "RTN","TMGNDF4B",42,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4B",43,0) "RTN","TMGNDF4B",44,0) if UsrSlct="ActivateImports" do ActivRecs(1) goto M1 "RTN","TMGNDF4B",45,0) if UsrSlct="InactivateNonImports" do InactivateNonImports("NOW") goto M1 "RTN","TMGNDF4B",46,0) if UsrSlct="Check4Dups" do Check4Dups goto M1 "RTN","TMGNDF4B",47,0) if UsrSlct="Check4Dangle" do Check4Dangle goto M1 "RTN","TMGNDF4B",48,0) if UsrSlct="Prev" goto Menu^TMGNDF4A ;"quit can occur from there... "RTN","TMGNDF4B",49,0) if UsrSlct="Next" goto Menu^TMGNDF4C ;"quit can occur from there... "RTN","TMGNDF4B",50,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF4B",51,0) goto M1 "RTN","TMGNDF4B",52,0) "RTN","TMGNDF4B",53,0) MenuDone "RTN","TMGNDF4B",54,0) quit "RTN","TMGNDF4B",55,0) "RTN","TMGNDF4B",56,0) ;"============================================================================= "RTN","TMGNDF4B",57,0) "RTN","TMGNDF4B",58,0) ActivRecs(OnlyImports) "RTN","TMGNDF4B",59,0) ;"Purpose: To activate records in 50.7 by removing the inactivation date "RTN","TMGNDF4B",60,0) ;"Input: OnlyImports: if 1 then only records linked to a FDA import will be modified. "RTN","TMGNDF4B",61,0) ;" if 0 then ALL records will be modified. "RTN","TMGNDF4B",62,0) ;"Results: none "RTN","TMGNDF4B",63,0) "RTN","TMGNDF4B",64,0) new date,%T,X,Y "RTN","TMGNDF4B",65,0) set X="1/1/1960" "RTN","TMGNDF4B",66,0) do ^%DT "RTN","TMGNDF4B",67,0) if Y'>0 goto AvADone "RTN","TMGNDF4B",68,0) set date=Y "RTN","TMGNDF4B",69,0) "RTN","TMGNDF4B",70,0) do ActivateImports(date,OnlyImports) "RTN","TMGNDF4B",71,0) AvADone "RTN","TMGNDF4B",72,0) quit "RTN","TMGNDF4B",73,0) "RTN","TMGNDF4B",74,0) "RTN","TMGNDF4B",75,0) Activ1TMG(IEN,Option) "RTN","TMGNDF4B",76,0) ;"Purpose: To activate records linked from 22706.9 in 50.7 by removing the inactivation date "RTN","TMGNDF4B",77,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF4B",78,0) ;"Get 22706.9 --> 50 --> 50.7 "RTN","TMGNDF4B",79,0) ;" --> 50 --> 50.7 "RTN","TMGNDF4B",80,0) new gIEN50,tIEN50 "RTN","TMGNDF4B",81,0) set tIEN50=+$piece($get(^TMG(22706.9,IEN,7)),"^",1) "RTN","TMGNDF4B",82,0) set gIEN50=+$piece($get(^TMG(22706.9,IEN,7)),"^",2) "RTN","TMGNDF4B",83,0) do Activ1Rx(tIEN50) "RTN","TMGNDF4B",84,0) do Activ1Rx(gIEN50) "RTN","TMGNDF4B",85,0) "RTN","TMGNDF4B",86,0) quit "RTN","TMGNDF4B",87,0) "RTN","TMGNDF4B",88,0) "RTN","TMGNDF4B",89,0) Activ1Rx(IEN50) "RTN","TMGNDF4B",90,0) ;"Purpose: To activate records linked from 50 in 50.7 by removing the inactivation date "RTN","TMGNDF4B",91,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF4B",92,0) ;"Result: none "RTN","TMGNDF4B",93,0) "RTN","TMGNDF4B",94,0) new date,%T,X,Y "RTN","TMGNDF4B",95,0) set X="1/1/1960" "RTN","TMGNDF4B",96,0) do ^%DT "RTN","TMGNDF4B",97,0) if Y'>0 goto AvADone "RTN","TMGNDF4B",98,0) set date=Y "RTN","TMGNDF4B",99,0) "RTN","TMGNDF4B",100,0) do XFormOff "RTN","TMGNDF4B",101,0) "RTN","TMGNDF4B",102,0) ;"Get 50 --> 50.7 "RTN","TMGNDF4B",103,0) if +$get(IEN50)'>0 goto A1RxDone "RTN","TMGNDF4B",104,0) new IEN50d7 "RTN","TMGNDF4B",105,0) set IEN50d7=+$piece($get(^PSDRUG(IEN50,2)),"^",1) "RTN","TMGNDF4B",106,0) if IEN50d7=0 quit "RTN","TMGNDF4B",107,0) new temp set temp=$$Active1(IEN50d7,date) "RTN","TMGNDF4B",108,0) "RTN","TMGNDF4B",109,0) do XFormOn "RTN","TMGNDF4B",110,0) "RTN","TMGNDF4B",111,0) A1RxDone "RTN","TMGNDF4B",112,0) quit "RTN","TMGNDF4B",113,0) "RTN","TMGNDF4B",114,0) "RTN","TMGNDF4B",115,0) ActivateImports(DateAfter,OnlyImports) "RTN","TMGNDF4B",116,0) ;"Purpose: To remove inactive date for all records in PHARMACY ORDERABLE ITEM "RTN","TMGNDF4B",117,0) ;" having an inactive date on/after DateAfter "RTN","TMGNDF4B",118,0) ;"Input: DateAfter -- the date to compare the inactive date with. If the "RTN","TMGNDF4B",119,0) ;" inactive date is on/after DateAfter, then inactive date "RTN","TMGNDF4B",120,0) ;" will be deleted. "RTN","TMGNDF4B",121,0) ;" ** Must be in Fileman Date format "RTN","TMGNDF4B",122,0) ;" OnlyImports: if 1 then only records linked to a FDA import will be modified. "RTN","TMGNDF4B",123,0) ;" if 0 then ALL records will be modified. "RTN","TMGNDF4B",124,0) "RTN","TMGNDF4B",125,0) do XFormOff "RTN","TMGNDF4B",126,0) "RTN","TMGNDF4B",127,0) new Itr,IEN,Date,Y,X "RTN","TMGNDF4B",128,0) new count set count=0 "RTN","TMGNDF4B",129,0) new abort set abort=0 "RTN","TMGNDF4B",130,0) "RTN","TMGNDF4B",131,0) write !,!,"Scanning all PHARMACY ORDERABLE ITEMS to activate those",! "RTN","TMGNDF4B",132,0) write " records linked to an active (non-skipped) FDA import...",! "RTN","TMGNDF4B",133,0) set IEN=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4B",134,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4B",135,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!(abort>0) "RTN","TMGNDF4B",136,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",137,0) . if (OnlyImports=1),($$IsImport^TMGNDFUT(IEN)=0) quit "RTN","TMGNDF4B",138,0) . new temp set temp=$$Active1(IEN,DateAfter) "RTN","TMGNDF4B",139,0) . if temp=2 set count=count+1 "RTN","TMGNDF4B",140,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",141,0) "RTN","TMGNDF4B",142,0) do XFormOn "RTN","TMGNDF4B",143,0) kill TMGXFORM "RTN","TMGNDF4B",144,0) "RTN","TMGNDF4B",145,0) write count," records modified.",! "RTN","TMGNDF4B",146,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4B",147,0) "RTN","TMGNDF4B",148,0) quit "RTN","TMGNDF4B",149,0) "RTN","TMGNDF4B",150,0) "RTN","TMGNDF4B",151,0) Active1(IEN,DateAfter) "RTN","TMGNDF4B",152,0) ;"Purpose: To remove inactive date for one records in PHARMACY ORDERABLE ITEM "RTN","TMGNDF4B",153,0) ;" having an inactive date on/after DateAfter "RTN","TMGNDF4B",154,0) ;"Input: IEN -- the IEN from file 50.7 to affect "RTN","TMGNDF4B",155,0) ;" DateAfter -- the date to compare the inactive date with. If the "RTN","TMGNDF4B",156,0) ;" inactive date is on/after DateAfter, then inactive date "RTN","TMGNDF4B",157,0) ;" will be deleted. "RTN","TMGNDF4B",158,0) ;" ** Must be in Fileman Date format "RTN","TMGNDF4B",159,0) ;"Results: 1=OK, 0 error occurred, 2 if modification made "RTN","TMGNDF4B",160,0) ;"NOTE: The XFormOff should be called before this is called, and XFormON called after "RTN","TMGNDF4B",161,0) "RTN","TMGNDF4B",162,0) "RTN","TMGNDF4B",163,0) new Date,Y,X "RTN","TMGNDF4B",164,0) new abort set abort=-5 "RTN","TMGNDF4B",165,0) new TMGFDA,TMGMSG "RTN","TMGNDF4B",166,0) new X1,X2 "RTN","TMGNDF4B",167,0) new result set result=1 "RTN","TMGNDF4B",168,0) "RTN","TMGNDF4B",169,0) set X2=$piece($get(^PS(50.7,IEN,0)),"^",4) ;"0;4 --> inactive date "RTN","TMGNDF4B",170,0) if X2="" goto A1Done "RTN","TMGNDF4B",171,0) ;"set X1=DateAfter "RTN","TMGNDF4B",172,0) ;"do ^%DTC "RTN","TMGNDF4B",173,0) set TMGFDA(50.7,IEN_",",.04)="" ;"kill inactive date "RTN","TMGNDF4B",174,0) new $etrap set $etrap="W ""??ERROR TRAPPED??"",! Q" "RTN","TMGNDF4B",175,0) do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF4B",176,0) new PriorErrorFound "RTN","TMGNDF4B",177,0) if $$ShowIfError^TMGDBAPI(.TMGMSG,.PriorErrorFound) set result=0 goto A1Done "RTN","TMGNDF4B",178,0) set X2=$piece($get(^PS(50.7,IEN,0)),"^",4) ;"0;4 --> inactive date "RTN","TMGNDF4B",179,0) if X2'="" do goto A1Done "RTN","TMGNDF4B",180,0) . write "Deletion of 50.7 inactivation date (",X2,") FAILED in record: ",IEN,! "RTN","TMGNDF4B",181,0) . set result=0 "RTN","TMGNDF4B",182,0) "RTN","TMGNDF4B",183,0) set result=2 "RTN","TMGNDF4B",184,0) A1Done "RTN","TMGNDF4B",185,0) quit result "RTN","TMGNDF4B",186,0) "RTN","TMGNDF4B",187,0) "RTN","TMGNDF4B",188,0) InactivateNonImports(Date) "RTN","TMGNDF4B",189,0) ;"Purpose: To inactive records in PHARMACY ORDERABLE ITEM not linked to a FDA import "RTN","TMGNDF4B",190,0) ;"Input: DateAfter -- OPTIONAL. Default is "NOW" "RTN","TMGNDF4B",191,0) ;" The date to to use for the inactivation "RTN","TMGNDF4B",192,0) ;" ** Must be in EXTERNAL format "RTN","TMGNDF4B",193,0) ;"Results: none "RTN","TMGNDF4B",194,0) "RTN","TMGNDF4B",195,0) do XFormOff "RTN","TMGNDF4B",196,0) "RTN","TMGNDF4B",197,0) new Itr,IEN,Date,Y,X "RTN","TMGNDF4B",198,0) set Date=$get(Date,"NOW") "RTN","TMGNDF4B",199,0) new abort set abort=0 "RTN","TMGNDF4B",200,0) new count set count=0 "RTN","TMGNDF4B",201,0) "RTN","TMGNDF4B",202,0) write !,!,"Scanning all PHARMACY ORDERABLE ITEMS to inactivate those NOT",! "RTN","TMGNDF4B",203,0) write " linked to an active (i.e. non-skipped) FDA import...",! "RTN","TMGNDF4B",204,0) set IEN=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4B",205,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4B",206,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!(abort>0) "RTN","TMGNDF4B",207,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",208,0) . if $$IsImport^TMGNDFUT(IEN)=1 quit "RTN","TMGNDF4B",209,0) . new temp set temp=$$InActv1(IEN,Date) "RTN","TMGNDF4B",210,0) . if temp=2 set count=count+1 "RTN","TMGNDF4B",211,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",212,0) "RTN","TMGNDF4B",213,0) do XFormOn "RTN","TMGNDF4B",214,0) kill TMGXFORM "RTN","TMGNDF4B",215,0) "RTN","TMGNDF4B",216,0) ;"Now check that all skipped imports don't point to POI records. "RTN","TMGNDF4B",217,0) ;"And that pointers point to valid records. "RTN","TMGNDF4B",218,0) new ChangeCt set ChangeCt=0 "RTN","TMGNDF4B",219,0) new Itr,IEN22706d9 "RTN","TMGNDF4B",220,0) new abort set abort=0 "RTN","TMGNDF4B",221,0) write !,"Checking Imports for links to bad POI records",! "RTN","TMGNDF4B",222,0) set IEN22706d9=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF4B",223,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF4B",224,0) if IEN22706d9'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF4B",225,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",226,0) . new tIEN50d7 set tIEN50d7=$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3) "RTN","TMGNDF4B",227,0) . set count=count+$$Verify1(IEN22706d9,tIEN50d7,"TRADE") "RTN","TMGNDF4B",228,0) . new gIEN50d7 set gIEN50d7=$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4) "RTN","TMGNDF4B",229,0) . set count=count+$$Verify1(IEN22706d9,gIEN50d7,"GENERIC") "RTN","TMGNDF4B",230,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",231,0) "RTN","TMGNDF4B",232,0) write count," records modified.",! "RTN","TMGNDF4B",233,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4B",234,0) "RTN","TMGNDF4B",235,0) quit "RTN","TMGNDF4B",236,0) "RTN","TMGNDF4B",237,0) "RTN","TMGNDF4B",238,0) Verify1(IEN22706d9,IEN50d7,mode) "RTN","TMGNDF4B",239,0) ;"To Verify one "RTN","TMGNDF4B",240,0) ;"Input: IEN22706d9 "RTN","TMGNDF4B",241,0) ;" IEN50 -- link to PHARMACY ORDERABLE ITEM file (either for Generic Drug, or Trade Drug) "RTN","TMGNDF4B",242,0) ;" mode - "GENERIC" or "TRADE" "RTN","TMGNDF4B",243,0) ;"Result: 0 -- no change, 1= change made "RTN","TMGNDF4B",244,0) "RTN","TMGNDF4B",245,0) new result set result=0 "RTN","TMGNDF4B",246,0) new field50d7 set field50d7="" "RTN","TMGNDF4B",247,0) new fieldName set fieldName="" "RTN","TMGNDF4B",248,0) new node,pce set (node,pce)="" "RTN","TMGNDF4B",249,0) if mode="GENERIC" do "RTN","TMGNDF4B",250,0) . set field50d7=5.71 "RTN","TMGNDF4B",251,0) . set fieldName=.075 "RTN","TMGNDF4B",252,0) . set node=7,pce=4 "RTN","TMGNDF4B",253,0) else if mode="TRADE" do "RTN","TMGNDF4B",254,0) . set field50d7=5.61 "RTN","TMGNDF4B",255,0) . set fieldName=.055 "RTN","TMGNDF4B",256,0) . set node=7,pce=3 "RTN","TMGNDF4B",257,0) if (field50d7="") goto V1Done "RTN","TMGNDF4B",258,0) if (IEN50d7="") goto V1Done "RTN","TMGNDF4B",259,0) "RTN","TMGNDF4B",260,0) new drugName set drugName=$piece($get(^PS(50.7,IEN50d7,0)),"^",1) "RTN","TMGNDF4B",261,0) new TMGName set TMGName=$piece($get(^TMG(22706.9,IEN22706d9,node)),"^",pce) "RTN","TMGNDF4B",262,0) set TMGName=$translate(TMGName,";",":") "RTN","TMGNDF4B",263,0) "RTN","TMGNDF4B",264,0) if $data(^PS(50.7,+$get(IEN50d7)))=0 do "RTN","TMGNDF4B",265,0) . write "Bad pointer: ",IEN50d7 "RTN","TMGNDF4B",266,0) . set IEN50d7=0 "RTN","TMGNDF4B",267,0) "RTN","TMGNDF4B",268,0) if drugName'=TMGName do "RTN","TMGNDF4B",269,0) . write IEN22706d9," (",$extract(mode,1),"): Name mismatch: ",drugName," vs ",TMGName,! "RTN","TMGNDF4B",270,0) . if TMGName="" set IEN50d7=0 "RTN","TMGNDF4B",271,0) "RTN","TMGNDF4B",272,0) if $get(IEN50d7)=0 do goto V1Done "RTN","TMGNDF4B",273,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4B",274,0) . set TMGFDA(22706.9,IEN22706d9_",",field50d7)="@" "RTN","TMGNDF4B",275,0) . do UPDATE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",276,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",277,0) . write " ... fixed.",! "RTN","TMGNDF4B",278,0) . set result=1 "RTN","TMGNDF4B",279,0) V1Done "RTN","TMGNDF4B",280,0) quit result "RTN","TMGNDF4B",281,0) "RTN","TMGNDF4B",282,0) "RTN","TMGNDF4B",283,0) InActv1(IEN,Date) "RTN","TMGNDF4B",284,0) ;"Purpose: To set inactive date for one records in PHARMACY ORDERABLE ITEM "RTN","TMGNDF4B",285,0) ;" having no inactive date "RTN","TMGNDF4B",286,0) ;"Input: IEN -- the IEN from file 50.7 to affect "RTN","TMGNDF4B",287,0) ;" Date -- the date to set inactive date to. Should be EXTERNAL FORMAT "RTN","TMGNDF4B",288,0) ;"Results: 1=OK, 0 error occurred, 2 if record modified "RTN","TMGNDF4B",289,0) ;"NOTE: The XFormOff should be called before this is called, and XFormON called after "RTN","TMGNDF4B",290,0) "RTN","TMGNDF4B",291,0) new abort set abort=-5 "RTN","TMGNDF4B",292,0) new TMGFDA,TMGMSG "RTN","TMGNDF4B",293,0) new X1,X2 "RTN","TMGNDF4B",294,0) new result set result=1 "RTN","TMGNDF4B",295,0) "RTN","TMGNDF4B",296,0) set X2=$piece($get(^PS(50.7,IEN,0)),"^",4) ;"0;4 --> inactive date "RTN","TMGNDF4B",297,0) if X2'="" goto IA1Done "RTN","TMGNDF4B",298,0) set TMGFDA(50.7,IEN_",",.04)=Date ;"new inactive date "RTN","TMGNDF4B",299,0) new $etrap set $etrap="W ""??ERROR TRAPPED??"",! Q" "RTN","TMGNDF4B",300,0) do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF4B",301,0) new PriorErrorFound "RTN","TMGNDF4B",302,0) if $$ShowIfError^TMGDBAPI(.TMGMSG,.PriorErrorFound) set result=0 goto IA1Done "RTN","TMGNDF4B",303,0) set result=2 "RTN","TMGNDF4B",304,0) IA1Done "RTN","TMGNDF4B",305,0) quit result "RTN","TMGNDF4B",306,0) "RTN","TMGNDF4B",307,0) "RTN","TMGNDF4B",308,0) XFormOff "RTN","TMGNDF4B",309,0) ;"Purpose: to remove restrinction in input transform that prevents deletion. "RTN","TMGNDF4B",310,0) "RTN","TMGNDF4B",311,0) ;"new TMGXFORM ;NOTE: NO new -- will be killed later "RTN","TMGNDF4B",312,0) set TMGXFORM=$piece($get(^DD(50.7,.04,0)),"^",5,99) "RTN","TMGNDF4B",313,0) merge ^TMG("TMP","XREF",50.7,.04,1)=^DD(50.7,.04,1) "RTN","TMGNDF4B",314,0) kill ^DD(50.7,.04,1) ;"kill off the screening xref code "RTN","TMGNDF4B",315,0) do SetXForm("W !,X,! S %DT=""E"" D ^%DT S X=Y S:Y<1 X=""""") "RTN","TMGNDF4B",316,0) "RTN","TMGNDF4B",317,0) quit "RTN","TMGNDF4B",318,0) "RTN","TMGNDF4B",319,0) "RTN","TMGNDF4B",320,0) XFormOn "RTN","TMGNDF4B",321,0) ;"Purpose: to restore the input transform to field .04 in file 50.7 "RTN","TMGNDF4B",322,0) "RTN","TMGNDF4B",323,0) set TMGXFORM=$get(TMGXFORM,"S %DT=""EX"" D ^%DT S X=Y K:Y<1 X") "RTN","TMGNDF4B",324,0) do SetXForm(TMGXFORM) "RTN","TMGNDF4B",325,0) kill ^DD(50.7,.04,1) "RTN","TMGNDF4B",326,0) merge ^DD(50.7,.04,1)=^TMG("TMP","XREF",50.7,.04,1) ;"restore screening xref code "RTN","TMGNDF4B",327,0) quit "RTN","TMGNDF4B",328,0) "RTN","TMGNDF4B",329,0) "RTN","TMGNDF4B",330,0) SetXForm(code) "RTN","TMGNDF4B",331,0) ;"Purpose: to remove the old input transform, and replace with code "RTN","TMGNDF4B",332,0) "RTN","TMGNDF4B",333,0) set $piece(^DD(50.7,.04,0),"^",5,99)="" ;"clear out old stuff "RTN","TMGNDF4B",334,0) set $piece(^DD(50.7,.04,0),"^",5)=code "RTN","TMGNDF4B",335,0) ;"zwr ^DD(50.7,.04,0) "RTN","TMGNDF4B",336,0) quit "RTN","TMGNDF4B",337,0) "RTN","TMGNDF4B",338,0) "RTN","TMGNDF4B",339,0) Check4Dups "RTN","TMGNDF4B",340,0) ;"Purpose: to ensure that there are not two entries in the PHARMACY ORDERABLE ITEM "RTN","TMGNDF4B",341,0) ;" file with the same name. "RTN","TMGNDF4B",342,0) "RTN","TMGNDF4B",343,0) new array,dupArray "RTN","TMGNDF4B",344,0) "RTN","TMGNDF4B",345,0) new Itr,IEN "RTN","TMGNDF4B",346,0) new abort set abort=0 "RTN","TMGNDF4B",347,0) set IEN=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4B",348,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4B",349,0) if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF4B",350,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",351,0) . new name set name=$piece($get(^PS(50.7,IEN,0)),"^",1) "RTN","TMGNDF4B",352,0) . new priorIEN set priorIEN=+$order(array(name,"")) "RTN","TMGNDF4B",353,0) . if priorIEN'=0 do "RTN","TMGNDF4B",354,0) . . write !,name," previously found...",! "RTN","TMGNDF4B",355,0) . . set dupArray(name,priorIEN)="" "RTN","TMGNDF4B",356,0) . . set dupArray(name,IEN)="" "RTN","TMGNDF4B",357,0) . set array(name,IEN)="" "RTN","TMGNDF4B",358,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",359,0) "RTN","TMGNDF4B",360,0) new count set count=0 "RTN","TMGNDF4B",361,0) new fixName set fixName="" "RTN","TMGNDF4B",362,0) for set fixName=$order(dupArray(fixName)) quit:(fixName="") do "RTN","TMGNDF4B",363,0) . new keepIEN set keepIEN=$order(dupArray(fixName,"")) "RTN","TMGNDF4B",364,0) . new IEN50d7 set IEN50d7=keepIEN "RTN","TMGNDF4B",365,0) . for set IEN50d7=$order(dupArray(fixName,IEN50d7)) quit:(IEN50d7="") do "RTN","TMGNDF4B",366,0) . . new IEN50Array "RTN","TMGNDF4B",367,0) . . do GetpDRUGs^TMGNDFUT(IEN50d7,.IEN50Array) "RTN","TMGNDF4B",368,0) . . new IEN50 set IEN50="" "RTN","TMGNDF4B",369,0) . . for set IEN50=+$order(IEN50Array(IEN50)) quit:(IEN50=0) do "RTN","TMGNDF4B",370,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDF4B",371,0) . . . set TMGFDA(50,IEN50_",",2.1)=keepIEN ;"redirect to ONE kept record "RTN","TMGNDF4B",372,0) . . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4B",373,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",374,0) . . kill TMGFDA,TMGMSG "RTN","TMGNDF4B",375,0) . . set TMGFDA(50.7,IEN50d7_",",.01)="@" ;"kill duplicate record "RTN","TMGNDF4B",376,0) . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4B",377,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",378,0) . . set count=count+1 "RTN","TMGNDF4B",379,0) "RTN","TMGNDF4B",380,0) write !,count," Modifications Made.",! "RTN","TMGNDF4B",381,0) "RTN","TMGNDF4B",382,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4B",383,0) quit "RTN","TMGNDF4B",384,0) "RTN","TMGNDF4B",385,0) "RTN","TMGNDF4B",386,0) Check4Dangle "RTN","TMGNDF4B",387,0) ;"Purpose: to ensure that there are no dangling entries in the PHARMACY "RTN","TMGNDF4B",388,0) ;" ORDERABLE ITEM file "RTN","TMGNDF4B",389,0) "RTN","TMGNDF4B",390,0) new fixArray "RTN","TMGNDF4B",391,0) "RTN","TMGNDF4B",392,0) new goodCount set goodCount=0 "RTN","TMGNDF4B",393,0) new badCount set badCount=0 "RTN","TMGNDF4B",394,0) new count set count=0 "RTN","TMGNDF4B",395,0) new Itr,IEN50d7 "RTN","TMGNDF4B",396,0) new abort set abort=0 "RTN","TMGNDF4B",397,0) set IEN50d7=$$ItrInit^TMGITR(50.7,.Itr) "RTN","TMGNDF4B",398,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN50d7") "RTN","TMGNDF4B",399,0) if IEN50d7'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN50d7)'>0)!abort "RTN","TMGNDF4B",400,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",401,0) . new dangle set dangle=1 ;"default to dangle "RTN","TMGNDF4B",402,0) . "RTN","TMGNDF4B",403,0) . new tempC,tempA,IEN50 "RTN","TMGNDF4B",404,0) . merge tempA=^PSDRUG("ASP",IEN50d7) "RTN","TMGNDF4B",405,0) . do GetpDRUGs^TMGNDFUT(IEN50d7,.tempC,1) "RTN","TMGNDF4B",406,0) . "RTN","TMGNDF4B",407,0) . set IEN50="" "RTN","TMGNDF4B",408,0) . for set IEN50=$order(tempC(IEN50)) quit:(IEN50="") kill tempA(IEN50) "RTN","TMGNDF4B",409,0) . set IEN50="" for set IEN50=$order(tempA(IEN50)) quit:(IEN50="") do "RTN","TMGNDF4B",410,0) . . if $piece($get(^PSDRUG(IEN50,"I")),"^",1)'="" kill tempA(IEN50) "RTN","TMGNDF4B",411,0) . "RTN","TMGNDF4B",412,0) . set IEN50="" "RTN","TMGNDF4B",413,0) . for set IEN50=$order(tempA(IEN50)) quit:(IEN50="") do "RTN","TMGNDF4B",414,0) . . write "50 #",IEN50," (",$$GET1^DIQ(50,IEN50_",",.01),") found that",! "RTN","TMGNDF4B",415,0) . . write " --> POI #",IEN50d7,$$GET1^DIQ(50.7,IEN50d7_",",.01),")",! "RTN","TMGNDF4B",416,0) . . new IEN22706d9 "RTN","TMGNDF4B",417,0) . . set IEN22706d9=$order(^TMG(22706.9,"DRUGT",IEN50,"")) "RTN","TMGNDF4B",418,0) . . if IEN22706d9="" do "RTN","TMGNDF4B",419,0) . . . write "But there is no entry in 22706.9 pointing to this #50 record.",! "RTN","TMGNDF4B",420,0) . . . write " ... deleting.",! "RTN","TMGNDF4B",421,0) . . . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4B",422,0) . . else do "RTN","TMGNDF4B",423,0) . . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDF4B",424,0) . . . . write "But the 22706.9 entry pointing to this is SKIPPED",! "RTN","TMGNDF4B",425,0) . . . else do "RTN","TMGNDF4B",426,0) . . . . write "Here is the 22706.9 pointing to it: #",IEN22706d9," ",$$GET1^DIQ(22706.9,IEN22706d9_",",.056),")",! "RTN","TMGNDF4B",427,0) . . . . new POI set POI=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3) "RTN","TMGNDF4B",428,0) . . . . write "And this record points to POI #",POI," ",$$GET1^DIQ(50.7,POI_",",.01),")",! "RTN","TMGNDF4B",429,0) . . set IEN22706d9=$order(^TMG(22706.9,"DRUGG",IEN50,"")) "RTN","TMGNDF4B",430,0) . . if IEN22706d9="" do "RTN","TMGNDF4B",431,0) . . . write "But there is no entry in 22706.9 pointing to this #50 record.",! "RTN","TMGNDF4B",432,0) . . else do "RTN","TMGNDF4B",433,0) . . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDF4B",434,0) . . . . write "But the 22706.9 entry pointing to this is SKIPPED",! "RTN","TMGNDF4B",435,0) . . . else do "RTN","TMGNDF4B",436,0) . . . . write "Here is the 22706.9 pointing to it: #",IEN22706d9," ",$$GET1^DIQ(22706.9,IEN22706d9_",",.056),")",! "RTN","TMGNDF4B",437,0) . . . . new POI set POI=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4) "RTN","TMGNDF4B",438,0) . . . . write "And this record points to POI #",POI," ",$$GET1^DIQ(50.7,POI_",",.01),")",! "RTN","TMGNDF4B",439,0) . "RTN","TMGNDF4B",440,0) . "RTN","TMGNDF4B",441,0) . ;"--------Check trade drug links------------ "RTN","TMGNDF4B",442,0) . new tempA "RTN","TMGNDF4B",443,0) . merge tempA=^TMG(22706.9,"POIT",IEN50d7) "RTN","TMGNDF4B",444,0) . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDF4B",445,0) . for set IEN22706d9=$order(tempA(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDF4B",446,0) . . set dangle=0 ;"at least one link was found, so not dangling. "RTN","TMGNDF4B",447,0) . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDF4B",448,0) . . . write "?? PHARMACY ORDERABLE ITEM #",IEN50d7," points to skipped record!",! "RTN","TMGNDF4B",449,0) . . . set fixArray(IEN50d7)="" "RTN","TMGNDF4B",450,0) . . new tIEN50 set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDF4B",451,0) . . if tIEN50=0 write "??!!??",! quit "RTN","TMGNDF4B",452,0) . . new tempIEN set tempIEN=+$piece($get(^PSDRUG(tIEN50,2)),"^",1) "RTN","TMGNDF4B",453,0) . . if tempIEN=IEN50d7 quit "RTN","TMGNDF4B",454,0) . . write !,"22706.9 #",IEN22706d9," (T) ",$$GET1^DIQ(22706.9,IEN22706d9_",",.056),")",! "RTN","TMGNDF4B",455,0) . . write " --> POI #",IEN50d7," (",$$GET1^DIQ(50.7,IEN50d7_",",.01),")",! "RTN","TMGNDF4B",456,0) . . write " --> 50 #",tIEN50," (",$$GET1^DIQ(50,tIEN50_",",.01),")",! "RTN","TMGNDF4B",457,0) . . write " ---> POI #",tempIEN," (",$$GET1^DIQ(50.7,tempIEN_",",.01),")",! "RTN","TMGNDF4B",458,0) . . write " Fixing this...",! "RTN","TMGNDF4B",459,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF4B",460,0) . . set TMGFDA(50,tIEN50_",",2.1)=IEN50d7 "RTN","TMGNDF4B",461,0) . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",462,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",463,0) . . set count=count+1 "RTN","TMGNDF4B",464,0) . ;"--------Now check generic drug links------------ "RTN","TMGNDF4B",465,0) . kill tempA "RTN","TMGNDF4B",466,0) . merge tempA=^TMG(22706.9,"POIG",IEN50d7) "RTN","TMGNDF4B",467,0) . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDF4B",468,0) . for set IEN22706d9=$order(tempA(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDF4B",469,0) . . set dangle=0 ;"at least one link was found, so not dangling. "RTN","TMGNDF4B",470,0) . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDF4B",471,0) . . . write "?? PHARMACY ORDERABLE ITEM #",IEN50d7," points to skipped 22706.9 record!",! "RTN","TMGNDF4B",472,0) . . . set fixArray(IEN50d7)="" "RTN","TMGNDF4B",473,0) . . new gIEN50 set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDF4B",474,0) . . if gIEN50=0 write "??!!??",! quit "RTN","TMGNDF4B",475,0) . . new tempIEN set tempIEN=+$piece($get(^PSDRUG(gIEN50,2)),"^",1) "RTN","TMGNDF4B",476,0) . . if tempIEN=IEN50d7 quit "RTN","TMGNDF4B",477,0) . . write "22706.9 #",IEN22706d9," (T) ",$$GET1^DIQ(22706.9,IEN22706d9_",",.056),")",! "RTN","TMGNDF4B",478,0) . . write " --> POI #",IEN50d7,$$GET1^DIQ(50.7,IEN50d7_",",.01),")",! "RTN","TMGNDF4B",479,0) . . write " --> 50 #",gIEN50," (",$$GET1^DIQ(50,gIEN50_",",.01),")",! "RTN","TMGNDF4B",480,0) . . write " ---> POI #",tempIEN," (",$$GET1^DIQ(50.7,tempIEN_",",.01),")",! "RTN","TMGNDF4B",481,0) . . write " Fixing this...",! "RTN","TMGNDF4B",482,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF4B",483,0) . . set TMGFDA(50,gIEN50_",",2.1)=IEN50d7 "RTN","TMGNDF4B",484,0) . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",485,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",486,0) . . set count=count+1 "RTN","TMGNDF4B",487,0) . if dangle=1 set badCount=badCount+1 "RTN","TMGNDF4B",488,0) "RTN","TMGNDF4B",489,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",490,0) "RTN","TMGNDF4B",491,0) ;"remove this line later "RTN","TMGNDF4B",492,0) set abort=0 "RTN","TMGNDF4B",493,0) "RTN","TMGNDF4B",494,0) write "Scanning 22706.9 for pointers to non-existant generic POI records",! "RTN","TMGNDF4B",495,0) new IEN50d7 set IEN50d7="" "RTN","TMGNDF4B",496,0) set IEN50d7=$$ItrAInit^TMGITR($name(^TMG(22706.9,"POIG")),.Itr) "RTN","TMGNDF4B",497,0) do PrepProgress^TMGITR(.Itr,20,1,"IEN50d7") "RTN","TMGNDF4B",498,0) if IEN50d7'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN50d7)="")!abort "RTN","TMGNDF4B",499,0) . new Itr2 "RTN","TMGNDF4B",500,0) . set IEN22706d9=$$ItrAInit^TMGITR($name(^TMG(22706.9,"POIG",IEN50d7)),.Itr2) "RTN","TMGNDF4B",501,0) . if IEN22706d9'="" for do quit:($$ItrANext^TMGITR(.Itr2,.IEN22706d9)="")!abort "RTN","TMGNDF4B",502,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",503,0) . . if $data(^PS(50.7,IEN50d7))=0 do "RTN","TMGNDF4B",504,0) . . . write !,"Dangling pointer in 22706.9 #",IEN22706d9," (G)",! "RTN","TMGNDF4B",505,0) . . . write " .. Deleting",! "RTN","TMGNDF4B",506,0) . . . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4B",507,0) . . . set count=count+1 "RTN","TMGNDF4B",508,0) "RTN","TMGNDF4B",509,0) write "Scanning 22706.9 for pointers to non-existant trade POI records",! "RTN","TMGNDF4B",510,0) kill Itr "RTN","TMGNDF4B",511,0) new IEN50d7 set IEN50d7="" "RTN","TMGNDF4B",512,0) set IEN50d7=$$ItrAInit^TMGITR($name(^TMG(22706.9,"POIT")),.Itr) "RTN","TMGNDF4B",513,0) do PrepProgress^TMGITR(.Itr,20,1,"IEN50d7") "RTN","TMGNDF4B",514,0) if IEN50d7'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN50d7)="")!abort "RTN","TMGNDF4B",515,0) . new Itr2 "RTN","TMGNDF4B",516,0) . set IEN22706d9=$$ItrAInit^TMGITR($name(^TMG(22706.9,"POIT",IEN50d7)),.Itr2) "RTN","TMGNDF4B",517,0) . if IEN22706d9'="" for do quit:($$ItrANext^TMGITR(.Itr2,.IEN22706d9)="")!abort "RTN","TMGNDF4B",518,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",519,0) . . if $data(^PS(50.7,IEN50d7))=0 do "RTN","TMGNDF4B",520,0) . . . write !,"Dangling pointer in 22706.9 #",IEN22706d9," (T)",! "RTN","TMGNDF4B",521,0) . . . write " .. Deleting",! "RTN","TMGNDF4B",522,0) . . . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4B",523,0) . . . set count=count+1 "RTN","TMGNDF4B",524,0) "RTN","TMGNDF4B",525,0) goto C4D2 ;"xref not missing it after all. This step not needed "RTN","TMGNDF4B",526,0) ;"For some reason xref is missing a record, so will do brute force search "RTN","TMGNDF4B",527,0) write "Brute force scan of 22706.9...",! "RTN","TMGNDF4B",528,0) kill Itr "RTN","TMGNDF4B",529,0) set IEN22706d9=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF4B",530,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF4B",531,0) if IEN22706d9'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF4B",532,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",533,0) . new tIEN50d7,gIEN50d7 "RTN","TMGNDF4B",534,0) . set tIEN50d7=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3) "RTN","TMGNDF4B",535,0) . set gIEN50d7=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4) "RTN","TMGNDF4B",536,0) . if (tIEN50d7>0),$data(^PS(50.7,tIEN50d7))=0 do "RTN","TMGNDF4B",537,0) . . write !,"Dangling pointer in 22706.9 #",IEN22706d9," (T)",! "RTN","TMGNDF4B",538,0) . . write " .. Deleting",! "RTN","TMGNDF4B",539,0) . . do KillPOI^TMGNDFUT(tIEN50d7) "RTN","TMGNDF4B",540,0) . . set count=count+1 "RTN","TMGNDF4B",541,0) . . set tIEN50d7=0 "RTN","TMGNDF4B",542,0) . if (gIEN50d7>0),$data(^PS(50.7,gIEN50d7))=0 do "RTN","TMGNDF4B",543,0) . . write !,"Dangling pointer in 22706.9 #",IEN22706d9," (G)",! "RTN","TMGNDF4B",544,0) . . write " .. Deleting",! "RTN","TMGNDF4B",545,0) . . do KillPOI^TMGNDFUT(gIEN50d7) "RTN","TMGNDF4B",546,0) . . set count=count+1 "RTN","TMGNDF4B",547,0) . . set gIEN50d7=0 "RTN","TMGNDF4B",548,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4B",549,0) . if tIEN50d7=0 set TMGFDA(22706.9,IEN22706d9_",",5.61)="@" "RTN","TMGNDF4B",550,0) . if gIEN50d7=0 set TMGFDA(22706.9,IEN22706d9_",",5.71)="@" "RTN","TMGNDF4B",551,0) . if $data(TMGFDA) do "RTN","TMGNDF4B",552,0) . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",553,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",554,0) . . set count=count+1 "RTN","TMGNDF4B",555,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",556,0) C4D2 "RTN","TMGNDF4B",557,0) write "Scanning 22706.9 for pointers to non-existant generic OI records",! "RTN","TMGNDF4B",558,0) new IEN101d43 set IEN101d43="" "RTN","TMGNDF4B",559,0) set IEN101d43=$$ItrAInit^TMGITR($name(^TMG(22706.9,"OIG")),.Itr) "RTN","TMGNDF4B",560,0) do PrepProgress^TMGITR(.Itr,20,1,"IEN101d43") "RTN","TMGNDF4B",561,0) if IEN101d43'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN101d43)="")!abort "RTN","TMGNDF4B",562,0) . new Itr2 "RTN","TMGNDF4B",563,0) . set IEN22706d9=$$ItrAInit^TMGITR($name(^TMG(22706.9,"OIG",IEN101d43)),.Itr2) "RTN","TMGNDF4B",564,0) . if IEN22706d9'="" for do quit:($$ItrANext^TMGITR(.Itr2,.IEN22706d9)="")!abort "RTN","TMGNDF4B",565,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",566,0) . . if $data(^ORD(101.43,IEN101d43))=0 do "RTN","TMGNDF4B",567,0) . . . write !,"Dangling pointer in 22706.9 #",IEN22706d9," (G)",! "RTN","TMGNDF4B",568,0) . . . write " ... Deleting",! "RTN","TMGNDF4B",569,0) . . . set TMGFDA(22706.9,IEN22706d9_",",5.711)="@" "RTN","TMGNDF4B",570,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",571,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",572,0) . . . set count=count+1 "RTN","TMGNDF4B",573,0) "RTN","TMGNDF4B",574,0) write "Scanning 22706.9 for pointers to non-existant trade OI records",! "RTN","TMGNDF4B",575,0) new IEN101d43 set IEN101d43="" "RTN","TMGNDF4B",576,0) set IEN101d43=$$ItrAInit^TMGITR($name(^TMG(22706.9,"OIT")),.Itr) "RTN","TMGNDF4B",577,0) do PrepProgress^TMGITR(.Itr,20,1,"IEN101d43") "RTN","TMGNDF4B",578,0) if IEN101d43'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN101d43)="")!abort "RTN","TMGNDF4B",579,0) . new Itr2 "RTN","TMGNDF4B",580,0) . set IEN22706d9=$$ItrAInit^TMGITR($name(^TMG(22706.9,"OIT",IEN101d43)),.Itr2) "RTN","TMGNDF4B",581,0) . if IEN22706d9'="" for do quit:($$ItrANext^TMGITR(.Itr2,.IEN22706d9)="")!abort "RTN","TMGNDF4B",582,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",583,0) . . if $data(^ORD(101.43,IEN101d43))=0 do "RTN","TMGNDF4B",584,0) . . . write !,"Dangling pointer in 22706.9 #",IEN22706d9," (T)",! "RTN","TMGNDF4B",585,0) . . . write " .. Deleting",! "RTN","TMGNDF4B",586,0) . . . set TMGFDA(22706.9,IEN22706d9_",",5.611)="@" "RTN","TMGNDF4B",587,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",588,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",589,0) . . . set count=count+1 "RTN","TMGNDF4B",590,0) "RTN","TMGNDF4B",591,0) write "Scanning 50 for pointers to non-existant POI records",! "RTN","TMGNDF4B",592,0) new IEN50d7 set IEN50d7="" "RTN","TMGNDF4B",593,0) set IEN50d7=$$ItrAInit^TMGITR($name(^PSDRUG("ASP")),.Itr) "RTN","TMGNDF4B",594,0) do PrepProgress^TMGITR(.Itr,20,1,"IEN50d7") "RTN","TMGNDF4B",595,0) if IEN50d7'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN50d7)="")!abort "RTN","TMGNDF4B",596,0) . new Itr2 "RTN","TMGNDF4B",597,0) . set IEN50=$$ItrAInit^TMGITR($name(^PSDRUG("ASP",IEN50d7)),.Itr2) "RTN","TMGNDF4B",598,0) . if IEN50'="" for do quit:($$ItrANext^TMGITR(.Itr2,.IEN50)="")!abort "RTN","TMGNDF4B",599,0) . . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",600,0) . . if $data(^PS(50.7,IEN50d7))=0 do "RTN","TMGNDF4B",601,0) . . . write !,"Dangling pointer in 50 #",IEN50,! "RTN","TMGNDF4B",602,0) . . . write " .. Deleting",! "RTN","TMGNDF4B",603,0) . . . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4B",604,0) . . . set count=count+1 "RTN","TMGNDF4B",605,0) "RTN","TMGNDF4B",606,0) write "Scanning 101.43 for pointers to non-existant POI records",! "RTN","TMGNDF4B",607,0) new ID set ID="" "RTN","TMGNDF4B",608,0) set ID=$$ItrAInit^TMGITR($name(^ORD(101.43,"ID")),.Itr) "RTN","TMGNDF4B",609,0) do PrepProgress^TMGITR(.Itr,20,1,"ID") "RTN","TMGNDF4B",610,0) if ID'="" for do quit:($$ItrANext^TMGITR(.Itr,.ID)="")!abort "RTN","TMGNDF4B",611,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",612,0) . set IEN50d7=$piece(ID,";",1) "RTN","TMGNDF4B",613,0) . if $data(^PS(50.7,IEN50d7))=0 do "RTN","TMGNDF4B",614,0) . . write !,"Dangling pointer in 101.43 #",IEN50,! "RTN","TMGNDF4B",615,0) . . write " .. Deleting",! "RTN","TMGNDF4B",616,0) . . do KillPOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4B",617,0) . . set count=count+1 "RTN","TMGNDF4B",618,0) "RTN","TMGNDF4B",619,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4B",620,0) "RTN","TMGNDF4B",621,0) ;"write goodCount," entries are not dangling.",! "RTN","TMGNDF4B",622,0) write badCount," entries are dangling",! "RTN","TMGNDF4B",623,0) "RTN","TMGNDF4B",624,0) set IEN50d7="" "RTN","TMGNDF4B",625,0) for set IEN50d7=$order(fixArray(IEN50d7)) quit:(IEN50d7="")!abort do "RTN","TMGNDF4B",626,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4B",627,0) . write "Checking POI# ",IEN50d7,! "RTN","TMGNDF4B",628,0) . new temp merge temp=^PSDRUG("ASP",IEN50d7) "RTN","TMGNDF4B",629,0) . new IEN50 set IEN50="" "RTN","TMGNDF4B",630,0) . for set IEN50=$order(temp(IEN50)) quit:(IEN50="") do "RTN","TMGNDF4B",631,0) . . new name set name=$$GET1^DIQ(50,IEN50_",",.01) quit:(name="") "RTN","TMGNDF4B",632,0) . . write " POI #",IEN50d7," IS pointed to from DRUG file, record #",IEN50," ",name,! "RTN","TMGNDF4B",633,0) . . if $$IsImport^TMGNDFUT(IEN50d7) do quit "RTN","TMGNDF4B",634,0) . . . write " (This record IS an active import)",! "RTN","TMGNDF4B",635,0) . . . new tempA "RTN","TMGNDF4B",636,0) . . . merge tempA=^TMG(22706.9,"POIG",IEN50d7) "RTN","TMGNDF4B",637,0) . . . merge tempA=^TMG(22706.9,"POIT",IEN50d7) "RTN","TMGNDF4B",638,0) . . . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDF4B",639,0) . . . for set IEN22706d9=$order(tempA(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDF4B",640,0) . . . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDF4B",641,0) . . . . . write "?? PHARMACY ORDERABLE ITEM #",IEN50d7," points to skipped record!",! "RTN","TMGNDF4B",642,0) . . . . new tIEN50,gIEN50 "RTN","TMGNDF4B",643,0) . . . . set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDF4B",644,0) . . . . if tIEN50>0 do "RTN","TMGNDF4B",645,0) . . . . . write "22706.9 #",IEN22706d9," points to this from trade link",! "RTN","TMGNDF4B",646,0) . . . . set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDF4B",647,0) . . . . if gIEN50>0 do "RTN","TMGNDF4B",648,0) . . . . . write "22706.9 #",IEN22706d9," points to this from generic link",! "RTN","TMGNDF4B",649,0) . . else do "RTN","TMGNDF4B",650,0) . . . write " (This record is NOT an active import)",! "RTN","TMGNDF4B",651,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDF4B",652,0) . . . set TMGFDA(50,IEN50_",",.01)="@" "RTN","TMGNDF4B",653,0) . . . do Unlock50^TMGNDFUT "RTN","TMGNDF4B",654,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",655,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",656,0) . . . do Lock50^TMGNDFUT "RTN","TMGNDF4B",657,0) . . . write "Dangling entry in file 50 REMOVED.",! "RTN","TMGNDF4B",658,0) . . . set count=count+1 "RTN","TMGNDF4B",659,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4B",660,0) . set TMGFDA(50.7,IEN50d7_",",.01)="@" "RTN","TMGNDF4B",661,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4B",662,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4B",663,0) . write "Dangling entries in file 50.7 REMOVED.",! "RTN","TMGNDF4B",664,0) . set count=count+1 "RTN","TMGNDF4B",665,0) "RTN","TMGNDF4B",666,0) "RTN","TMGNDF4B",667,0) write !,count," Modifications Made.",! "RTN","TMGNDF4B",668,0) if count>0 write "Please run this process AGAIN.",! "RTN","TMGNDF4B",669,0) "RTN","TMGNDF4B",670,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4B",671,0) quit "RTN","TMGNDF4C") 0^55^B10766 "RTN","TMGNDF4C",1,0) TMGNDF4C ;TMG/kst/FDA Import: Move drugs from 50.7 --> 101.43 ;03/25/06 "RTN","TMGNDF4C",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF4C",3,0) "RTN","TMGNDF4C",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4C",5,0) ;" Move drugs from 50.7 --> 101.43 "RTN","TMGNDF4C",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4C",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4C",8,0) ;"11-21-2006 "RTN","TMGNDF4C",9,0) "RTN","TMGNDF4C",10,0) ;"Note: The database itself tries to create entries in 101.43 when a drug "RTN","TMGNDF4C",11,0) ;" is added to file 50.7. But I am not happy with the job it does. "RTN","TMGNDF4C",12,0) ;" There are missing records, and it combines various IR, SR, XR "RTN","TMGNDF4C",13,0) ;" into one entry. So I am going to delete the auto-created records "RTN","TMGNDF4C",14,0) ;" and create my own. "RTN","TMGNDF4C",15,0) "RTN","TMGNDF4C",16,0) ;"======================================================================= "RTN","TMGNDF4C",17,0) ;" API -- Public Functions. "RTN","TMGNDF4C",18,0) ;"======================================================================= "RTN","TMGNDF4C",19,0) ;"Menu "RTN","TMGNDF4C",20,0) ;"======================================================================= "RTN","TMGNDF4C",21,0) ;"AddAllTMG -- Add/Refresh all relevent TMG entries into OI "RTN","TMGNDF4C",22,0) ;"OIFromTMG(IEN,Option) -- Add/Update ONE entry in ORDERABLE ITEM (101.43) file "RTN","TMGNDF4C",23,0) "RTN","TMGNDF4C",24,0) ;"======================================================================= "RTN","TMGNDF4C",25,0) ;" Private Functions. "RTN","TMGNDF4C",26,0) ;"======================================================================= "RTN","TMGNDF4C",27,0) ;"VerifySync -- verify correct links PHARMACY ORDERABLE ITEM --> ORDERABLE ITEM "RTN","TMGNDF4C",28,0) ;"OIFromTMG(IEN22706d9,Option) "RTN","TMGNDF4C",29,0) ;"EnsureOI(IEN50d7,Name,Synonyms,Option) -- make sure that there is a corresponding entry "RTN","TMGNDF4C",30,0) ;" in 101.43. If one doesn't already exist, then it will be added. "RTN","TMGNDF4C",31,0) ;"InactivateOI -- cycle through 101.43 and ensure needed records are inactivated. "RTN","TMGNDF4C",32,0) ;"NewOI(Name) -- add one record to file 101.43--stub in an empty record for later stuffing "RTN","TMGNDF4C",33,0) ;"StuffOI(IEN101d43,Name,Synonyms,IEN50d7) -- fill one record to file 101.43 with data "RTN","TMGNDF4C",34,0) "RTN","TMGNDF4C",35,0) "RTN","TMGNDF4C",36,0) ;"ResetFiles -- For debugging purposes, this will reset two files: 101.44, 101.43 "RTN","TMGNDF4C",37,0) "RTN","TMGNDF4C",38,0) "RTN","TMGNDF4C",39,0) ;"======================================================================= "RTN","TMGNDF4C",40,0) "RTN","TMGNDF4C",41,0) Menu "RTN","TMGNDF4C",42,0) "RTN","TMGNDF4C",43,0) new Menu,UsrSlct "RTN","TMGNDF4C",44,0) set Menu(0)="Pick Option to Sync ORDERABLE ITEMS (4C)" "RTN","TMGNDF4C",45,0) set Menu(1)="Sync imports to ORDERABLE ITEMS."_$char(9)_"Sync2OI" "RTN","TMGNDF4C",46,0) ;"set Menu(2)="Inactivate non-FDA-drug-OI's"_$char(9)_"InactivateOI" "RTN","TMGNDF4C",47,0) set Menu(2)="Ensure Activation Status of Import OI's"_$char(9)_"SyncActivOI" "RTN","TMGNDF4C",48,0) set Menu(3)="Verify Sync of PHARMACY ORDERABLE ITEMS --> OI's"_$char(9)_"VerifySync" "RTN","TMGNDF4C",49,0) ;"set Menu(4)="Check for duplicate ORDABLE ITEMS records"_$char(9)_"Check4Dups" "RTN","TMGNDF4C",50,0) set Menu(4)="Check for dangling ORDERABLE ITEMS records"_$char(9)_"CheckDangle" "RTN","TMGNDF4C",51,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF4C",52,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF4C",53,0) "RTN","TMGNDF4C",54,0) M1 write # "RTN","TMGNDF4C",55,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4C",56,0) "RTN","TMGNDF4C",57,0) if UsrSlct="Sync2OI" do AddAllTMG goto M1 "RTN","TMGNDF4C",58,0) ;"if UsrSlct="Sync2OI" do Sync2OI goto M1 "RTN","TMGNDF4C",59,0) ;"if UsrSlct="InactivateOI" do InactivateOI goto M1 "RTN","TMGNDF4C",60,0) if UsrSlct="SyncActivOI" do SyncActivOI goto M1 "RTN","TMGNDF4C",61,0) if UsrSlct="VerifySync" do VerifySync goto M1 "RTN","TMGNDF4C",62,0) ;"if UsrSlct="Check4Dups" do Check4Dups goto M1 "RTN","TMGNDF4C",63,0) if UsrSlct="CheckDangle" do CheckDangle goto M1 "RTN","TMGNDF4C",64,0) "RTN","TMGNDF4C",65,0) if UsrSlct="Prev" goto Menu^TMGNDF4B ;"quit can occur from there... "RTN","TMGNDF4C",66,0) if UsrSlct="Next" goto Menu^TMGNDF4E ;"quit can occur from there... "RTN","TMGNDF4C",67,0) "RTN","TMGNDF4C",68,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF4C",69,0) goto M1 "RTN","TMGNDF4C",70,0) "RTN","TMGNDF4C",71,0) MenuDone "RTN","TMGNDF4C",72,0) quit "RTN","TMGNDF4C",73,0) "RTN","TMGNDF4C",74,0) ;"============================================================================= "RTN","TMGNDF4C",75,0) "RTN","TMGNDF4C",76,0) AddAllTMG "RTN","TMGNDF4C",77,0) ;"Purpose: Add/Refresh all relevent TMG entries into OI "RTN","TMGNDF4C",78,0) ;"Input:none "RTN","TMGNDF4C",79,0) ;"results: none "RTN","TMGNDF4C",80,0) "RTN","TMGNDF4C",81,0) new IEN,Itr "RTN","TMGNDF4C",82,0) new abort set abort=0 "RTN","TMGNDF4C",83,0) new result set result=0 "RTN","TMGNDF4C",84,0) write "Scanning all imports to ensure ORDERABLE ITEMS are set up.",! "RTN","TMGNDF4C",85,0) set IEN=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF4C",86,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4C",87,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!(abort=1) "RTN","TMGNDF4C",88,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4C",89,0) . new Option "RTN","TMGNDF4C",90,0) . set Option("CUR MODE")="TRADE" "RTN","TMGNDF4C",91,0) . set result=$$OIFromTMG(IEN,.Option) ;"screen for skip will occur in function "RTN","TMGNDF4C",92,0) . set Option("CUR MODE")="GENERIC" "RTN","TMGNDF4C",93,0) . set result=$$OIFromTMG(IEN,.Option) ;"screen for skip will occur in function "RTN","TMGNDF4C",94,0) quit "RTN","TMGNDF4C",95,0) "RTN","TMGNDF4C",96,0) "RTN","TMGNDF4C",97,0) OIFromTMG(IEN22706d9,Option,Synonyms) "RTN","TMGNDF4C",98,0) ;"Purpose: to Add/Update ONE entry in ORDERABLE ITEM (101.43) file "RTN","TMGNDF4C",99,0) ;"Input: IEN22706d9 -- IEN in 22706.9 "RTN","TMGNDF4C",100,0) ;" Option -- NON-OPTIONAL part. Format: "RTN","TMGNDF4C",101,0) ;" Option("CUR MODE")="TRADE" "RTN","TMGNDF4C",102,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF4C",103,0) ;" Option("IEN50.7","TRADE")=IEN50d7 "RTN","TMGNDF4C",104,0) ;" Option("IEN50.7","GENERIC")=IEN50d7 "RTN","TMGNDF4C",105,0) ;" Option("IEN101.43","TRADE")=IEN101.43 for Trade Name. May be 0 "RTN","TMGNDF4C",106,0) ;" Option("IEN101.43","GENERIC")=IEN101.43 for Generic Name. May be 0 "RTN","TMGNDF4C",107,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF4C",108,0) ;" to file POI, OI, OQV etc. "RTN","TMGNDF4C",109,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF4C",110,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF4C",111,0) ;" Option("IEN50","TRADE")=IEN50 for Trade Name "RTN","TMGNDF4C",112,0) ;" Option("IEN50","GENERIC")=IEN50 for Generic Name "RTN","TMGNDF4C",113,0) ;" Option("DRUG NAME AND FORM","TRADE")=Trade Name and Form "RTN","TMGNDF4C",114,0) ;" Option("DRUG NAME AND FORM","GENERIC")=Generic Name and Form "RTN","TMGNDF4C",115,0) ;" Option("CUR MODE")="TRADE" or "GENERIC" "RTN","TMGNDF4C",116,0) ;" Option("DELETING")=1 <-- deleting chain (not IEN22706d9) "RTN","TMGNDF4C",117,0) ;" Synonyms --OPTIONAL. PASS BY REFERENCE. Expected format: "RTN","TMGNDF4C",118,0) ;" Synonyms(Name)="" "RTN","TMGNDF4C",119,0) ;" Synonyms(Name)="" "RTN","TMGNDF4C",120,0) ;"NOTE: This function DOES screen for skipped entries, and skips "RTN","TMGNDF4C",121,0) ;" proccessing. BUT, if Deleting, then it is NOT skipped "RTN","TMGNDF4C",122,0) ;"Output: OI records will be added or refreshed, or deleted. "RTN","TMGNDF4C",123,0) ;"Result: 1=Modified, 0=not modified "RTN","TMGNDF4C",124,0) "RTN","TMGNDF4C",125,0) new result set result=0 "RTN","TMGNDF4C",126,0) if $get(Option("DELETING"))'=1,$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 goto EOIDone ;"1=SKIP "RTN","TMGNDF4C",127,0) if +$get(IEN22706d9)=0 goto EOIDone "RTN","TMGNDF4C",128,0) new quiet set quiet=+$get(Option("QUIET")) "RTN","TMGNDF4C",129,0) do LoadOption(IEN22706d9,.Option) "RTN","TMGNDF4C",130,0) "RTN","TMGNDF4C",131,0) new mode set mode=$get(Option("CUR MODE")) if mode="" goto EOIDone "RTN","TMGNDF4C",132,0) new IEN50d7 set IEN50d7=+$get(Option("IEN50.7",mode)) if IEN50d7=0 goto EOIDone "RTN","TMGNDF4C",133,0) new DrugNAF set DrugNAF=$get(Option("DRUG NAME AND FORM",mode)) if DrugNAF="" goto EOIDone "RTN","TMGNDF4C",134,0) "RTN","TMGNDF4C",135,0) new IEN101d43 set IEN101d43=+$get(Option("IEN101.43",mode)) "RTN","TMGNDF4C",136,0) "RTN","TMGNDF4C",137,0) if $get(Option("DELETING"))=1 do goto EOIDone "RTN","TMGNDF4C",138,0) . do KillOI^TMGNDFUT(IEN101d43) "RTN","TMGNDF4C",139,0) . set Option("IEN101.43",mode)="" "RTN","TMGNDF4C",140,0) "RTN","TMGNDF4C",141,0) if (IEN101d43>0),$data(^ORD(101.43,IEN101d43))=0 do "RTN","TMGNDF4C",142,0) . set IEN101d43=0 ;"I found a dangling pointer "RTN","TMGNDF4C",143,0) ;"I am taking line below out because there is supposed to be a 1:1 "RTN","TMGNDF4C",144,0) ;" connection between POI<-->OI. Below might cause cross link of chains "RTN","TMGNDF4C",145,0) ;"if IEN101d43=0 set IEN101d43=$$FindOI^TMGNDFUT(DrugNAF) "RTN","TMGNDF4C",146,0) if IEN101d43=0 do "RTN","TMGNDF4C",147,0) . set IEN101d43=$$NewOI(DrugNAF) "RTN","TMGNDF4C",148,0) . set Option("IEN101.43",mode)=IEN101d43 "RTN","TMGNDF4C",149,0) . set result=1 "RTN","TMGNDF4C",150,0) if IEN101d43=0 set result=0 goto EOIDone "RTN","TMGNDF4C",151,0) "RTN","TMGNDF4C",152,0) set result=$$StuffOI(IEN101d43,DrugNAF,.Synonyms,IEN50d7) ;"result 1=modified "RTN","TMGNDF4C",153,0) "RTN","TMGNDF4C",154,0) ;"Ensure pointer to 101.43 stored in TMG IMPORT COMPILED records "RTN","TMGNDF4C",155,0) if mode="TRADE" do "RTN","TMGNDF4C",156,0) . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDF4C",157,0) . for set IEN22706d9=$order(^TMG(22706.9,"POIT",IEN50d7,IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDF4C",158,0) . . if +$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",5)=IEN101d43 quit "RTN","TMGNDF4C",159,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF4C",160,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.611)=IEN101d43 "RTN","TMGNDF4C",161,0) . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4C",162,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",163,0) if mode="GENERIC" do "RTN","TMGNDF4C",164,0) . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDF4C",165,0) . for set IEN22706d9=$order(^TMG(22706.9,"POIG",IEN50d7,IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDF4C",166,0) . . if +$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",6)=IEN101d43 quit "RTN","TMGNDF4C",167,0) . . new TMGFDA,TMGMSG "RTN","TMGNDF4C",168,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.711)=IEN101d43 "RTN","TMGNDF4C",169,0) . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4C",170,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",171,0) "RTN","TMGNDF4C",172,0) ;"Ensure just 1 link 50.7 --> 101.43 (actually pointer is the other way: 101.43-->50.7) "RTN","TMGNDF4C",173,0) new all,temp "RTN","TMGNDF4C",174,0) set temp=$$GetOI^TMGNDFUT(IEN50d7,.all) "RTN","TMGNDF4C",175,0) OI1 if $$ListCt^TMGMISC("all")>0 do "RTN","TMGNDF4C",176,0) . new IEN set IEN="" "RTN","TMGNDF4C",177,0) . for set IEN=$order(all(IEN)) quit:(IEN="") do "RTN","TMGNDF4C",178,0) . . if IEN=IEN101d43 quit "RTN","TMGNDF4C",179,0) . . if 'quiet write "?? Mult pointers 101.43 --> 50.7 ??. Deleting 101.43 #",IEN,! "RTN","TMGNDF4C",180,0) . . do KillOI^TMGNDFUT(IEN) "RTN","TMGNDF4C",181,0) "RTN","TMGNDF4C",182,0) if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF4C",183,0) . ;"pass message forward for fix "RTN","TMGNDF4C",184,0) . if result=1 do "RTN","TMGNDF4C",185,0) . . new temp set temp=$$Fix1OQV^TMGNDF4E(IEN101d43,.Option) "RTN","TMGNDF4C",186,0) . ;"Delete AFTER above so chain is deleted 101.44-->101.43-->50.7-->50 "RTN","TMGNDF4C",187,0) . ;"if $get(Option("DELETING"))=1 do "RTN","TMGNDF4C",188,0) . ;". do KillOI^TMGNDFUT(IEN101d43) "RTN","TMGNDF4C",189,0) EOIDone "RTN","TMGNDF4C",190,0) quit result "RTN","TMGNDF4C",191,0) "RTN","TMGNDF4C",192,0) "RTN","TMGNDF4C",193,0) LoadOption(IEN22706d9,Option) "RTN","TMGNDF4C",194,0) ;"Purpose: To load up Option array with info "RTN","TMGNDF4C",195,0) ;"Input: IEN22706d9 -- IEN in 22706.9 "RTN","TMGNDF4C",196,0) ;" Option -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF4C",197,0) ;" Option("IEN50.7","TRADE")=IEN50.7 for Trade Name "RTN","TMGNDF4C",198,0) ;" Option("IEN50.7","GENERIC")=IEN50.7 for Generic Name "RTN","TMGNDF4C",199,0) ;" Option("DRUG NAME AND FORM","TRADE")=Trade Name and Form "RTN","TMGNDF4C",200,0) ;" Option("DRUG NAME AND FORM","GENERIC")=Generic Name and Form "RTN","TMGNDF4C",201,0) ;" Option("IEN50","TRADE")=IEN50 for Trade Name "RTN","TMGNDF4C",202,0) ;" Option("IEN50","GENERIC")=IEN50 for Generic Name "RTN","TMGNDF4C",203,0) ;" Option("IEN101.43","TRADE")=IEN50 for Trade Name "RTN","TMGNDF4C",204,0) ;" Option("IEN101.43","GENERIC")=IEN50 for Generic Name "RTN","TMGNDF4C",205,0) ;"Note: May sync pointers in various records "RTN","TMGNDF4C",206,0) ;"Results: none "RTN","TMGNDF4C",207,0) "RTN","TMGNDF4C",208,0) new node7 set node7=$get(^TMG(22706.9,IEN22706d9,7)) "RTN","TMGNDF4C",209,0) set Option("DRUG NAME AND FORM","TRADE")=$piece(node7,"^",3) "RTN","TMGNDF4C",210,0) set Option("DRUG NAME AND FORM","GENERIC")=$piece(node7,"^",4) "RTN","TMGNDF4C",211,0) "RTN","TMGNDF4C",212,0) new tIEN50 set tIEN50=+$get(Option("IEN50","TRADE")) "RTN","TMGNDF4C",213,0) if tIEN50=0 do "RTN","TMGNDF4C",214,0) . new tIEN50 set tIEN50=+$piece(node7,"^",1) "RTN","TMGNDF4C",215,0) . set Option("IEN50","TRADE")=tIEN50 "RTN","TMGNDF4C",216,0) if tIEN50>0 set Option("IEN50","TRADE","NAME")=$piece($get(^PSDRUG(tIEN50,0)),"^",1) "RTN","TMGNDF4C",217,0) "RTN","TMGNDF4C",218,0) new gIEN50 set gIEN50=+$get(Option("IEN50","GENERIC")) "RTN","TMGNDF4C",219,0) if gIEN50=0 do "RTN","TMGNDF4C",220,0) . set gIEN50=+$piece(node7,"^",2) "RTN","TMGNDF4C",221,0) . set Option("IEN50","GENERIC")=gIEN50 "RTN","TMGNDF4C",222,0) if gIEN50>0 set Option("IEN50","GENERIC","NAME")=$piece($get(^PSDRUG(gIEN50,0)),"^",1) "RTN","TMGNDF4C",223,0) "RTN","TMGNDF4C",224,0) new tIEN50d7 set tIEN50d7=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3) "RTN","TMGNDF4C",225,0) if tIEN50'=0 do "RTN","TMGNDF4C",226,0) . if tIEN50d7=0 do "RTN","TMGNDF4C",227,0) . . set tIEN50d7=+$piece($get(^PSDRUG(tIEN50,2)),"^",1) "RTN","TMGNDF4C",228,0) . . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4C",229,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.61)=tIEN50d7 "RTN","TMGNDF4C",230,0) . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4C",231,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",232,0) . else do ;"sync 50 to match TMG COMPILED "RTN","TMGNDF4C",233,0) . . if tIEN50d7=+$piece($get(^PSDRUG(tIEN50,2)),"^",1) quit "RTN","TMGNDF4C",234,0) . . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4C",235,0) . . set TMGFDA(50,tIEN50_",",2.1)=tIEN50d7 "RTN","TMGNDF4C",236,0) . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4C",237,0) . . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4C",238,0) . . . if $data(TMGMSG("DIERR","E",120))>0 quit ;"ignore error if #120 (hook) present. "RTN","TMGNDF4C",239,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",240,0) set Option("IEN50.7","TRADE")=tIEN50d7 ;"may be 0 at this point "RTN","TMGNDF4C",241,0) if tIEN50d7>0 set Option("IEN50.7","TRADE","NAME")=$piece($get(^PS(50.7,tIEN50d7,0)),"^",1) "RTN","TMGNDF4C",242,0) "RTN","TMGNDF4C",243,0) new gIEN50d7 set gIEN50d7=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4) "RTN","TMGNDF4C",244,0) if gIEN50'=0 do "RTN","TMGNDF4C",245,0) . if gIEN50d7=0 do "RTN","TMGNDF4C",246,0) . . set gIEN50d7=+$piece($get(^PSDRUG(gIEN50,2)),"^",1) "RTN","TMGNDF4C",247,0) . . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4C",248,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.71)=gIEN50d7 "RTN","TMGNDF4C",249,0) . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4C",250,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",251,0) . else do ;"sync 50 to match TMG COMPILED "RTN","TMGNDF4C",252,0) . . if gIEN50d7=+$piece($get(^PSDRUG(gIEN50,2)),"^",1) quit "RTN","TMGNDF4C",253,0) . . new TMGFDA,TMGIEN,TMGMSG "RTN","TMGNDF4C",254,0) . . set TMGFDA(50,gIEN50_",",2.1)=gIEN50d7 "RTN","TMGNDF4C",255,0) . . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4C",256,0) . . if $data(TMGMSG("DIERR")) do "RTN","TMGNDF4C",257,0) . . . if $data(TMGMSG("DIERR","E",120))>0 quit ;"ignore error if #120 (hook) present. "RTN","TMGNDF4C",258,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",259,0) set Option("IEN50.7","GENERIC")=gIEN50d7 ;"may be 0 at this point "RTN","TMGNDF4C",260,0) if gIEN50d7>0 set Option("IEN50.7","GENERIC","NAME")=$piece($get(^PS(50.7,gIEN50d7,0)),"^",1) "RTN","TMGNDF4C",261,0) "RTN","TMGNDF4C",262,0) new tradeNameAF set tradeNameAF=$get(Option("DRUG NAME AND FORM","TRADE")) "RTN","TMGNDF4C",263,0) if tradeNameAF="" do "RTN","TMGNDF4C",264,0) . set tradeNameAF=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",3) "RTN","TMGNDF4C",265,0) . set Option("DRUG NAME AND FORM","TRADE")=tradeNameAF "RTN","TMGNDF4C",266,0) "RTN","TMGNDF4C",267,0) new genericNameAF set genericNameAF=$get(Option("DRUG NAME AND FORM","GENERIC")) "RTN","TMGNDF4C",268,0) if genericNameAF="" do "RTN","TMGNDF4C",269,0) . set genericNameAF=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",4) "RTN","TMGNDF4C",270,0) . set Option("DRUG NAME AND FORM","GENERIC")=genericNameAF "RTN","TMGNDF4C",271,0) "RTN","TMGNDF4C",272,0) new tIEN101d43 set tIEN101d43=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",5) "RTN","TMGNDF4C",273,0) if (tIEN101d43=0)&(tIEN50d7'=0) do "RTN","TMGNDF4C",274,0) . set tIEN101d43=$$GetOI^TMGNDFUT(tIEN50d7) "RTN","TMGNDF4C",275,0) . if tIEN101d43'>0 quit "RTN","TMGNDF4C",276,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4C",277,0) . set TMGFDA(22706.9,IEN22706d9_",",5.611)=tIEN101d43 "RTN","TMGNDF4C",278,0) . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4C",279,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",280,0) set Option("IEN101.43","TRADE")=tIEN101d43 ;"could be 0 at this point "RTN","TMGNDF4C",281,0) if tIEN101d43>0 set Option("IEN101.43","TRADE","NAME")=$piece($get(^ORD(101.43,tIEN101d43,0)),"^",1) "RTN","TMGNDF4C",282,0) "RTN","TMGNDF4C",283,0) new gIEN101d43 set gIEN101d43=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",6) "RTN","TMGNDF4C",284,0) if (gIEN101d43=0)&(gIEN50d7'=0) do "RTN","TMGNDF4C",285,0) . set gIEN101d43=$$GetOI^TMGNDFUT(gIEN50d7) "RTN","TMGNDF4C",286,0) . if gIEN101d43=0 quit "RTN","TMGNDF4C",287,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4C",288,0) . set TMGFDA(22706.9,IEN22706d9_",",5.711)=gIEN101d43 "RTN","TMGNDF4C",289,0) . do FILE^DIE("S","TMGFDA","TMGMSG") "RTN","TMGNDF4C",290,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",291,0) set Option("IEN101.43","GENERIC")=gIEN101d43 ;"could be 0 at this point "RTN","TMGNDF4C",292,0) if gIEN101d43>0 set Option("IEN101.43","GENERIC","NAME")=$piece($get(^ORD(101.43,gIEN101d43,0)),"^",1) "RTN","TMGNDF4C",293,0) "RTN","TMGNDF4C",294,0) quit "RTN","TMGNDF4C",295,0) "RTN","TMGNDF4C",296,0) "RTN","TMGNDF4C",297,0) NewOI(Name) "RTN","TMGNDF4C",298,0) ;"Purpose: to add one record to file 101.43--stub in an empty record for later stuffing "RTN","TMGNDF4C",299,0) ;"Input: Name -- the text of the ORDERABLE ITEM (i.e. drug name) to add "RTN","TMGNDF4C",300,0) ;"Results: returns new IEN of added record "RTN","TMGNDF4C",301,0) "RTN","TMGNDF4C",302,0) new newIEN set newIEN=0 "RTN","TMGNDF4C",303,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF4C",304,0) set TMGFDA(101.43,"+1,",.01)=Name "RTN","TMGNDF4C",305,0) do UPDATE^DIE("K","TMGFDA","TMGIEN","TMGMSG") ;"ADD RECORD "RTN","TMGNDF4C",306,0) if $$ShowIfError^TMGDBAPI(.TMGMSG) goto NOIDone "RTN","TMGNDF4C",307,0) set newIEN=+$get(TMGIEN(1)) ;"GET BACK ADDED RECORD NUMBER "RTN","TMGNDF4C",308,0) NOIDone "RTN","TMGNDF4C",309,0) quit newIEN "RTN","TMGNDF4C",310,0) "RTN","TMGNDF4C",311,0) "RTN","TMGNDF4C",312,0) StuffOI(IEN101d43,Name,Synonyms,IEN50d7) "RTN","TMGNDF4C",313,0) ;"Purpose: to fill one record to file 101.43 with data "RTN","TMGNDF4C",314,0) ;"Input: IEN110d43 -- IEN in 101.43 to stuff "RTN","TMGNDF4C",315,0) ;" Name -- the text of the drug name to add "RTN","TMGNDF4C",316,0) ;" Synonyms -- PASS BY REFERENCE. Expected format: "RTN","TMGNDF4C",317,0) ;" Synonyms(Name)="" "RTN","TMGNDF4C",318,0) ;" Synonyms(Name)="" "RTN","TMGNDF4C",319,0) ;" IEN50d7 -- IEN in 50.7 -- the record in PHARMACY ORDERABLE ITEM (50.7) to link to "RTN","TMGNDF4C",320,0) ;"Results: 1 if modified, 0 if not modified "RTN","TMGNDF4C",321,0) "RTN","TMGNDF4C",322,0) ;"Here is an example of a drug that was stuff "RTN","TMGNDF4C",323,0) ;" .01-NAME : BUPROPION TAB "RTN","TMGNDF4C",324,0) ;" 1-SYNONYMS : "RTN","TMGNDF4C",325,0) ;" Multiple Entry #1 .01-SYNONYM : BUDEPRION SR EXT REL TABS "RTN","TMGNDF4C",326,0) ;" Multiple Entry #2 .01-SYNONYM : BUDEPRION SR TABS "RTN","TMGNDF4C",327,0) ;" Multiple Entry #3 .01-SYNONYM : BUPROPION HCL EXT REL TABS "RTN","TMGNDF4C",328,0) ;" Multiple Entry #4 .01-SYNONYM : BUPROPION HCL SR TABS "RTN","TMGNDF4C",329,0) ;" 1.1-PACKAGE NAME : BUPROPION TAB "RTN","TMGNDF4C",330,0) ;" 2-ID : 3267;99PSP <--- 3267 is IEN in 50.7 to link to "RTN","TMGNDF4C",331,0) ;" 5-DISPLAY GROUP : PHARMACY "RTN","TMGNDF4C",332,0) ;" 9-SET MEMBERSHIP : "RTN","TMGNDF4C",333,0) ;" Multiple Entry #1 .01-SET : RX "RTN","TMGNDF4C",334,0) ;" 50.1-INPATIENT MED : NO "RTN","TMGNDF4C",335,0) ;" 50.2-OUTPATIENT MED : NO "RTN","TMGNDF4C",336,0) ;" 50.3-IV BASE : NO "RTN","TMGNDF4C",337,0) ;" 50.4-IV ADDITIVE : NO "RTN","TMGNDF4C",338,0) ;" 50.5-SUPPLY : NO "RTN","TMGNDF4C",339,0) ;" 50.6-NON-FORMULARY : NO "RTN","TMGNDF4C",340,0) ;" 50.7-NON-VA MEDS : NO "RTN","TMGNDF4C",341,0) "RTN","TMGNDF4C",342,0) new result set result=0 "RTN","TMGNDF4C",343,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF4C",344,0) new IENS set IENS=IEN101d43_"," "RTN","TMGNDF4C",345,0) set TMGFDA(101.43,IEN101d43_",",.01)=Name "RTN","TMGNDF4C",346,0) if $piece($get(^ORD(101.43,IEN101d43,.1)),"^",1)'="" do "RTN","TMGNDF4C",347,0) . set TMGFDA(101.43,IENS,.1)="@" ;"delete any inactivation date. "RTN","TMGNDF4C",348,0) set TMGFDA(101.43,IENS,1.1)=Name "RTN","TMGNDF4C",349,0) set TMGFDA(101.43,IENS,2)=IEN50d7_";99PSP" "RTN","TMGNDF4C",350,0) set TMGFDA(101.43,IENS,5)="PHARMACY" "RTN","TMGNDF4C",351,0) set TMGFDA(101.43,IENS,50.1)="NO" "RTN","TMGNDF4C",352,0) set TMGFDA(101.43,IENS,50.2)="YES" "RTN","TMGNDF4C",353,0) set TMGFDA(101.43,IENS,50.3)="NO" "RTN","TMGNDF4C",354,0) set TMGFDA(101.43,IENS,50.4)="NO" "RTN","TMGNDF4C",355,0) set TMGFDA(101.43,IENS,50.5)="NO" "RTN","TMGNDF4C",356,0) set TMGFDA(101.43,IENS,50.6)="NO" "RTN","TMGNDF4C",357,0) set TMGFDA(101.43,IENS,50.7)="NO" "RTN","TMGNDF4C",358,0) "RTN","TMGNDF4C",359,0) new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF4C",360,0) if $data(TMGFDA)=0 goto SOI2 "RTN","TMGNDF4C",361,0) "RTN","TMGNDF4C",362,0) ;"UPDATE RECORD "RTN","TMGNDF4C",363,0) do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGNDF4C",364,0) new PriorErrorFound,newIEN "RTN","TMGNDF4C",365,0) if $$ShowIfError^TMGDBAPI(.TMGMSG,.PriorErrorFound) goto SOIDone "RTN","TMGNDF4C",366,0) set result=1 "RTN","TMGNDF4C",367,0) "RTN","TMGNDF4C",368,0) ;"ADD SET MEMBERSHIP ENTRIES "RTN","TMGNDF4C",369,0) ;"NOTE: It seems that the database adds these automatically "RTN","TMGNDF4C",370,0) ;"kill TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF4C",371,0) ;"set TMGFDA(101.439,"+1,"_newIEN_",",.01)="RX" "RTN","TMGNDF4C",372,0) ;"set TMGFDA(101.439,"+2,"_newIEN_",",.01)="O RX" "RTN","TMGNDF4C",373,0) ;"do UPDATE^DIE("ES","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF4C",374,0) ;"if $$ShowIfError^TMGDBAPI(.TMGMSG,.PriorErrorFound) quit "RTN","TMGNDF4C",375,0) SOI2 "RTN","TMGNDF4C",376,0) new subIEN set subIEN=0 "RTN","TMGNDF4C",377,0) for set subIEN=$order(^ORD(101.43,IEN101d43,2,subIEN)) quit:(+subIEN'>0) do "RTN","TMGNDF4C",378,0) . new syn set syn=$piece($get(^ORD(101.43,IEN101d43,2,subIEN,0)),"^",1) "RTN","TMGNDF4C",379,0) . if $data(Synonyms(syn))'=0 kill Synonyms(syn) quit ;"no need to add, already present "RTN","TMGNDF4C",380,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4C",381,0) . set TMGFDA(101.432,subIEN_","_IEN101d43_",",.01)="@" ;"kill unwanted synonyms "RTN","TMGNDF4C",382,0) . do FILE^DIE("KE","TMGFDA","TMGMSG") "RTN","TMGNDF4C",383,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",384,0) "RTN","TMGNDF4C",385,0) ;"ADD ANY MISSING SYONYMS "RTN","TMGNDF4C",386,0) new SynName set SynName="" "RTN","TMGNDF4C",387,0) for set SynName=$order(Synonyms(SynName)) quit:(SynName="") do "RTN","TMGNDF4C",388,0) . kill TMGIEN,TMGFDA,TMGMSG "RTN","TMGNDF4C",389,0) . set TMGFDA(101.432,"+1,"_IEN101d43_",",.01)=SynName ;"was newIEN, change --> IEN101d43 "RTN","TMGNDF4C",390,0) . do UPDATE^DIE("EKS","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF4C",391,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",392,0) . set result=1 "RTN","TMGNDF4C",393,0) SOIDone "RTN","TMGNDF4C",394,0) quit result "RTN","TMGNDF4C",395,0) "RTN","TMGNDF4C",396,0) "RTN","TMGNDF4C",397,0) InactivateOI "RTN","TMGNDF4C",398,0) ;"Purpose: To cycle through records in 101.43 and ensure needed records are "RTN","TMGNDF4C",399,0) ;" inactivated. "RTN","TMGNDF4C",400,0) "RTN","TMGNDF4C",401,0) write "Scanning entries to ensure inactivation status is synchronized...",! "RTN","TMGNDF4C",402,0) new Itr,IEN50d7 "RTN","TMGNDF4C",403,0) new count set count=0 "RTN","TMGNDF4C",404,0) new abort set abort=0 "RTN","TMGNDF4C",405,0) set IEN101d43=$$ItrInit^TMGITR(101.43,.Itr) "RTN","TMGNDF4C",406,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN101d43") "RTN","TMGNDF4C",407,0) if IEN101d43'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN101d43)'>0)!abort "RTN","TMGNDF4C",408,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4C",409,0) . new IEN50d7 set IEN50d7=$$GetPOI^TMGNDFUT(IEN101d43) ;"(will fix bad records) "RTN","TMGNDF4C",410,0) . if IEN50d7'>0 quit ;"was bad record, non pharmacy item "RTN","TMGNDF4C",411,0) . new date set date=$piece($get(^ORD(101.43,IEN101d43,.1)),"^",1) quit:(date'="") ;"already inactivated "RTN","TMGNDF4C",412,0) . if $$IsImport^TMGNDFUT(IEN50d7)=1 quit ;"is active import --> don't inactivate "RTN","TMGNDF4C",413,0) . new TMGFDA,TMGMSG,X,Y "RTN","TMGNDF4C",414,0) . set X="NOW" do ^%DT ;"results return in Y "RTN","TMGNDF4C",415,0) . set TMGFDA(101.43,IEN101d43_",",.1)=Y "RTN","TMGNDF4C",416,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF4C",417,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",418,0) . set count=count+1 "RTN","TMGNDF4C",419,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4C",420,0) "RTN","TMGNDF4C",421,0) write count," entries modified.",! "RTN","TMGNDF4C",422,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4C",423,0) quit "RTN","TMGNDF4C",424,0) "RTN","TMGNDF4C",425,0) "RTN","TMGNDF4C",426,0) SyncActivOI "RTN","TMGNDF4C",427,0) ;"Purpose: To cycle through records in 101.43 and ensure needed records are "RTN","TMGNDF4C",428,0) ;" Activated or Inactivation. "RTN","TMGNDF4C",429,0) "RTN","TMGNDF4C",430,0) write "Scanning entries to ensure activation/inactivation status is synchronized...",! "RTN","TMGNDF4C",431,0) new Itr,IEN50d7 "RTN","TMGNDF4C",432,0) new count set count=0 "RTN","TMGNDF4C",433,0) new abort set abort=0 "RTN","TMGNDF4C",434,0) set IEN101d43=$$ItrInit^TMGITR(101.43,.Itr) "RTN","TMGNDF4C",435,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN101d43") "RTN","TMGNDF4C",436,0) if IEN101d43'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN101d43)'>0)!abort "RTN","TMGNDF4C",437,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4C",438,0) . new IEN50d7 set IEN50d7=$$GetPOI^TMGNDFUT(IEN101d43) ;"(will fix bad records) "RTN","TMGNDF4C",439,0) . if IEN50d7'>0 quit ;"was bad record, non pharmacy item "RTN","TMGNDF4C",440,0) . new date set date=$piece($get(^ORD(101.43,IEN101d43,.1)),"^",1) "RTN","TMGNDF4C",441,0) . new pastInactiveDate set pastInactiveDate=0 "RTN","TMGNDF4C",442,0) . if date'="" do "RTN","TMGNDF4C",443,0) . . new X,Y set X="NOW" do ^%DT ;"results in Y "RTN","TMGNDF4C",444,0) . . new X1,X2 "RTN","TMGNDF4C",445,0) . . set X1=Y,X2=date "RTN","TMGNDF4C",446,0) . . do ^%DTC ;"result is X=X1-X2 (X=NOW-InactiveDate) X>-1 means past inactive date "RTN","TMGNDF4C",447,0) . . set pastInactiveDate=(X>-1) "RTN","TMGNDF4C",448,0) . if $$IsImport^TMGNDFUT(IEN50d7)=1 do "RTN","TMGNDF4C",449,0) . . if date="" quit "RTN","TMGNDF4C",450,0) . . if 'pastInactiveDate quit "RTN","TMGNDF4C",451,0) . . new TMGFDA,TMGMSG,X,Y "RTN","TMGNDF4C",452,0) . . set TMGFDA(101.43,IEN101d43_",",.1)="@" "RTN","TMGNDF4C",453,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF4C",454,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",455,0) . . set count=count+1 "RTN","TMGNDF4C",456,0) . else do ;"is NOT an active import, so ensure inactivated "RTN","TMGNDF4C",457,0) . . if pastInactiveDate quit "RTN","TMGNDF4C",458,0) . . new TMGFDA,TMGMSG,X,Y "RTN","TMGNDF4C",459,0) . . set X="NOW" do ^%DT ;"results return in Y "RTN","TMGNDF4C",460,0) . . set TMGFDA(101.43,IEN101d43_",",.1)=Y "RTN","TMGNDF4C",461,0) . . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF4C",462,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",463,0) . . set count=count+1 "RTN","TMGNDF4C",464,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4C",465,0) "RTN","TMGNDF4C",466,0) write count," entries modified.",! "RTN","TMGNDF4C",467,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4C",468,0) quit "RTN","TMGNDF4C",469,0) "RTN","TMGNDF4C",470,0) "RTN","TMGNDF4C",471,0) ResetFiles "RTN","TMGNDF4C",472,0) ;"Purpose: For debugging purposes, this will reset two files: "RTN","TMGNDF4C",473,0) ;" 101.44, 101.43 "RTN","TMGNDF4C",474,0) "RTN","TMGNDF4C",475,0) ;"CAUTION: make sure you have saved data in the locations below FIRST... "RTN","TMGNDF4C",476,0) ;"ALSO: There are many pointers IN to file 101.43. So if this function is run "RTN","TMGNDF4C",477,0) ;" in a production system (containing valid patient data), then corruption "RTN","TMGNDF4C",478,0) ;" will be introduced. "RTN","TMGNDF4C",479,0) "RTN","TMGNDF4C",480,0) kill ^TMG("TMP","TEMP BACKUP","^ORD(101.43, 10-16-06") "RTN","TMGNDF4C",481,0) merge ^TMG("TMP","TEMP BACKUP","^ORD(101.43, 10-16-06")=^ORD(101.43) "RTN","TMGNDF4C",482,0) kill ^ORD(101.43) "RTN","TMGNDF4C",483,0) merge ^ORD(101.43)=^TMG("TMP","^ORD(101.43, 10-16-06") "RTN","TMGNDF4C",484,0) "RTN","TMGNDF4C",485,0) kill ^TMG("TMP","TEMP BACKUP","^ORD(101.44, 10-16-06") "RTN","TMGNDF4C",486,0) merge ^TMG("TMP","TEMP BACKUP","^ORD(101.44, 10-16-06")=^ORD(101.44) "RTN","TMGNDF4C",487,0) kill ^ORD(101.44) "RTN","TMGNDF4C",488,0) merge ^ORD(101.44)=^TMG("TMP","^ORD(101.44, 10-16-06") "RTN","TMGNDF4C",489,0) "RTN","TMGNDF4C",490,0) quit "RTN","TMGNDF4C",491,0) "RTN","TMGNDF4C",492,0) ;"----------------------------------- "RTN","TMGNDF4C",493,0) VerifySync "RTN","TMGNDF4C",494,0) ;"Purpose: to verify that links PHARMACY ORDERABLE ITEM --> ORDERABLE ITEM "RTN","TMGNDF4C",495,0) ;" are correct. Link is based on a text pointer (and I think less likely "RTN","TMGNDF4C",496,0) ;" to have been fixed with multiple runs...) "RTN","TMGNDF4C",497,0) "RTN","TMGNDF4C",498,0) new fixArray "RTN","TMGNDF4C",499,0) "RTN","TMGNDF4C",500,0) write "Scanning entries to ensure link is correctly synchronized...",! "RTN","TMGNDF4C",501,0) new Itr,IEN50d7 "RTN","TMGNDF4C",502,0) new abort set abort=0 "RTN","TMGNDF4C",503,0) set IEN101d43=$$ItrInit^TMGITR(101.43,.Itr) "RTN","TMGNDF4C",504,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN101d43") "RTN","TMGNDF4C",505,0) if IEN101d43'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN101d43)'>0)!abort "RTN","TMGNDF4C",506,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4C",507,0) . new date set date=$piece($get(^ORD(101.43,IEN101d43,.1)),"^",1) "RTN","TMGNDF4C",508,0) . if $$OIInactive^TMGNDFUT(IEN101d43) quit ;"ignore inactivate entries "RTN","TMGNDF4C",509,0) . set IEN50d7=$$GetPOI^TMGNDFUT(IEN101d43) ;"(will fix bad records) "RTN","TMGNDF4C",510,0) . if IEN50d7'>0 quit ;"was bad record, non pharmacy item "RTN","TMGNDF4C",511,0) . new OIName set OIName=$piece($get(^ORD(101.43,IEN101d43,0)),"^",1) "RTN","TMGNDF4C",512,0) . new POIName set POIName=$piece($get(^PS(50.7,IEN50d7,0)),"^",1) "RTN","TMGNDF4C",513,0) . if (OIName'=POIName) do "RTN","TMGNDF4C",514,0) . . write !,OIName," (OI #",IEN101d43,") <-- ",POIName," (POI #",IEN50d7,") ??",! "RTN","TMGNDF4C",515,0) . . set fixArray(IEN50d7,IEN101d43)="" "RTN","TMGNDF4C",516,0) . if (OIName="") do "RTN","TMGNDF4C",517,0) . . write !,"NULL NAME. (OI #",IEN101d43,") <-- ",POIName," (POI #",IEN50d7,") ??",! "RTN","TMGNDF4C",518,0) . . set fixArray(IEN50d7,IEN101d43)="" "RTN","TMGNDF4C",519,0) . if $$IsImport^TMGNDFUT(IEN50d7)=0 do "RTN","TMGNDF4C",520,0) . . write " 50.7 #",IEN50d7," ",POIName," is not an active import!",! "RTN","TMGNDF4C",521,0) . . set fixArray(IEN50d7,IEN101d43)="@" "RTN","TMGNDF4C",522,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4C",523,0) "RTN","TMGNDF4C",524,0) new IEN50d7 set IEN50d7="" "RTN","TMGNDF4C",525,0) for set IEN50d7=$order(fixArray(IEN50d7)) quit:(IEN50d7="") do "RTN","TMGNDF4C",526,0) . new POIName set POIName=$piece($get(^PS(50.7,IEN50d7,0)),"^",1) "RTN","TMGNDF4C",527,0) . new IEN50Array "RTN","TMGNDF4C",528,0) . do GetDRUGs^TMGNDFUT(IEN50d7,.IEN50Array,1) "RTN","TMGNDF4C",529,0) . new Name50 set Name50="" "RTN","TMGNDF4C",530,0) . for set Name50=$order(IEN50Array(Name50)) quit:(Name50="") do "RTN","TMGNDF4C",531,0) . . new IEN50 set IEN50="" "RTN","TMGNDF4C",532,0) . . for set IEN50=$order(IEN50Array(Name50,IEN50)) quit:(IEN50="") do "RTN","TMGNDF4C",533,0) . . . write "File 50, #",IEN50,": ",Name50," ",$piece($get(^PSDRUG(IEN50,0)),"^",1)," -->",! "RTN","TMGNDF4C",534,0) . write " POI Name=",POIName," --> ",! "RTN","TMGNDF4C",535,0) . new IEN101d43 set IEN101d43="" "RTN","TMGNDF4C",536,0) . for set IEN101d43=$order(fixArray(IEN50d7,IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDF4C",537,0) . . if $get(fixArray(IEN50d7,IEN101d43))="@" do quit "RTN","TMGNDF4C",538,0) . . . new TMGFDA,TMGMSG,PSEDITNM "RTN","TMGNDF4C",539,0) . . . set PSEDITNM=1 "RTN","TMGNDF4C",540,0) . . . set TMGFDA(50.7,IEN50d7_",",.01)="@" "RTN","TMGNDF4C",541,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4C",542,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",543,0) . . . kill TMGFDA,TMGMSG "RTN","TMGNDF4C",544,0) . . . set TMGFDA(101.43,IEN101d43_",",.01)="@" "RTN","TMGNDF4C",545,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4C",546,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4C",547,0) . . new OIName set OIName=$piece($get(^ORD(101.43,IEN101d43,0)),"^",1) "RTN","TMGNDF4C",548,0) . . write " OI Name=",OIName,! "RTN","TMGNDF4C",549,0) . . new result "RTN","TMGNDF4C",550,0) . . set result=$$StuffOI(IEN101d43,POIName,,IEN50d7) ;"result 1=modified "RTN","TMGNDF4C",551,0) "RTN","TMGNDF4C",552,0) ;"Now verify ID cross reference "RTN","TMGNDF4C",553,0) "RTN","TMGNDF4C",554,0) "RTN","TMGNDF4C",555,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4C",556,0) quit "RTN","TMGNDF4C",557,0) "RTN","TMGNDF4C",558,0) "RTN","TMGNDF4C",559,0) Check4Dups ;"DON'T USE. There are times when the "TRADE" name will actually be a generic "RTN","TMGNDF4C",560,0) ;"name, and then the chains between generic and trade name drugs get crossed. "RTN","TMGNDF4C",561,0) ;"An OI can only point to 1 POI, so one could cause a situation whereby "RTN","TMGNDF4C",562,0) ;"Trade POI --> OI, but OI --> Generic POI (and Trade POI gets lost) "RTN","TMGNDF4C",563,0) "RTN","TMGNDF4C",564,0) ;"Purpose: to ensure that there are not two entries in the ORDERABLE ITEM "RTN","TMGNDF4C",565,0) ;" file with the same name. "RTN","TMGNDF4C",566,0) "RTN","TMGNDF4C",567,0) new array,dupArray "RTN","TMGNDF4C",568,0) "RTN","TMGNDF4C",569,0) new Itr,IEN "RTN","TMGNDF4C",570,0) new abort set abort=0 "RTN","TMGNDF4C",571,0) new count set count=0 "RTN","TMGNDF4C",572,0) set IEN=$$ItrInit^TMGITR(101.43,.Itr) "RTN","TMGNDF4C",573,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4C",574,0) if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort "RTN","TMGNDF4C",575,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4C",576,0) . new name set name=$piece($get(^ORD(101.43,IEN,0)),"^",1) "RTN","TMGNDF4C",577,0) . new priorIEN set priorIEN=+$order(array(name,"")) "RTN","TMGNDF4C",578,0) . if priorIEN'=0 do "RTN","TMGNDF4C",579,0) . . write !,name," previously found...",! "RTN","TMGNDF4C",580,0) . . set dupArray(name,priorIEN)="" "RTN","TMGNDF4C",581,0) . . set dupArray(name,IEN)="" "RTN","TMGNDF4C",582,0) . set array(name,IEN)="" "RTN","TMGNDF4C",583,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4C",584,0) if abort=1 goto C4DDone "RTN","TMGNDF4C",585,0) "RTN","TMGNDF4C",586,0) new Itr,fixName "RTN","TMGNDF4C",587,0) set fixName=$$ItrAInit^TMGITR("dupArray",.Itr) "RTN","TMGNDF4C",588,0) do PrepProgress^TMGITR(.Itr,1,1,"fixName") "RTN","TMGNDF4C",589,0) if fixName'="" for do quit:($$ItrANext^TMGITR(.Itr,.fixName)="")!abort "RTN","TMGNDF4C",590,0) . new IEN101d43 set IEN101d43="" "RTN","TMGNDF4C",591,0) . new keepIEN set keepIEN="" "RTN","TMGNDF4C",592,0) . for set IEN101d43=$order(dupArray(fixName,IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDF4C",593,0) . . if keepIEN="" set keepIEN=IEN101d43 quit ;"use first record as one to keep. "RTN","TMGNDF4C",594,0) . . do RedirOI^TMGNDFUT(IEN101d43,keepIEN) "RTN","TMGNDF4C",595,0) . . do KillOI^TMGNDFUT(IEN101d43) "RTN","TMGNDF4C",596,0) . . set count=count+1 "RTN","TMGNDF4C",597,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4C",598,0) "RTN","TMGNDF4C",599,0) C4DDone "RTN","TMGNDF4C",600,0) write !,count," Modifications Made.",! "RTN","TMGNDF4C",601,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4C",602,0) quit "RTN","TMGNDF4C",603,0) "RTN","TMGNDF4C",604,0) "RTN","TMGNDF4C",605,0) "RTN","TMGNDF4C",606,0) "RTN","TMGNDF4C",607,0) CheckDangle "RTN","TMGNDF4C",608,0) ;"Purpose: to verify that ORDERABLE ITEM records are not dangling records "RTN","TMGNDF4C",609,0) "RTN","TMGNDF4C",610,0) new delArray "RTN","TMGNDF4C",611,0) "RTN","TMGNDF4C",612,0) write "Scanning entries checking for dangling records...",! "RTN","TMGNDF4C",613,0) new Itr,IEN50d7,TMGArray,ID,Info "RTN","TMGNDF4C",614,0) new abort set abort=0 "RTN","TMGNDF4C",615,0) set IEN101d43=$$ItrInit^TMGITR(101.43,.Itr) "RTN","TMGNDF4C",616,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN101d43") "RTN","TMGNDF4C",617,0) if IEN101d43'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN101d43)'>0)!abort "RTN","TMGNDF4C",618,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4C",619,0) . new OIArray "RTN","TMGNDF4C",620,0) . do GetOIInfo^TMGNDFUT(IEN101d43,.OIArray) "RTN","TMGNDF4C",621,0) . if $get(OIArray("IEN 101.43","INACTIVE"))=1 quit ;"ignore inactivated records "RTN","TMGNDF4C",622,0) . new pkg set pkg=$get(OIArray("IEN 101.43","PACKAGE")) "RTN","TMGNDF4C",623,0) . if (pkg'="")&(pkg'["PSP") quit ;" -- not a pharmacy item, so ignore "RTN","TMGNDF4C",624,0) . set IEN50d7=+$get(OIArray("IEN 50.7 from 101.43")) "RTN","TMGNDF4C",625,0) . new OIName set OIName=$get(OIArray("IEN 101.43","NAME")) "RTN","TMGNDF4C",626,0) . ;"if OIName'="" quit ;"temporary.... "RTN","TMGNDF4C",627,0) . new POIName set POIName=$get(OIArray("IEN 50.7 from 101.43","NAME")) "RTN","TMGNDF4C",628,0) . if IEN50d7=0 do "RTN","TMGNDF4C",629,0) . . write !,"Record 101.43 #",IEN101d43," (",OIName,") doesn't point to any PHARMACY ORDERABLE ITEM",! "RTN","TMGNDF4C",630,0) . . set delArray(IEN101d43)="" "RTN","TMGNDF4C",631,0) . else if $$IsImport^TMGNDFUT(IEN50d7)=0 do "RTN","TMGNDF4C",632,0) . . write !,"Record 101.43 #",IEN101d43," (",OIName,") points to PHARMACY ORDERABLE ITEM (50.7)#",IEN50d7,! "RTN","TMGNDF4C",633,0) . . write " But 50.7 #",IEN50d7," (",POIName,") is not an active import!",! "RTN","TMGNDF4C",634,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4C",635,0) "RTN","TMGNDF4C",636,0) new count set count=$$ListCt^TMGMISC("delArray") "RTN","TMGNDF4C",637,0) write count," records to be deleted.",! "RTN","TMGNDF4C",638,0) "RTN","TMGNDF4C",639,0) if count>0 do "RTN","TMGNDF4C",640,0) . new % set %=1 "RTN","TMGNDF4C",641,0) . write "Delete records now" do YN^DICN write ! "RTN","TMGNDF4C",642,0) . if %'=1 quit "RTN","TMGNDF4C",643,0) . set IEN101d43="" "RTN","TMGNDF4C",644,0) . for set IEN101d43=$order(delArray(IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDF4C",645,0) . . do KillOI^TMGNDFUT(IEN101d43) "RTN","TMGNDF4C",646,0) . write "Done.",! "RTN","TMGNDF4C",647,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4C",648,0) else do PressToCont^TMGUSRIF "RTN","TMGNDF4C",649,0) "RTN","TMGNDF4C",650,0) quit "RTN","TMGNDF4C",651,0) "RTN","TMGNDF4C",652,0) "RTN","TMGNDF4C",653,0) "RTN","TMGNDF4D") 0^56^B7415 "RTN","TMGNDF4D",1,0) TMGNDF4D ;TMG/kst/FDA Import: Activate POI's ;03/25/06 "RTN","TMGNDF4D",2,0) ;;1.0;TMG-LIB;**1**;11/21/06 "RTN","TMGNDF4D",3,0) "RTN","TMGNDF4D",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4D",5,0) ;" Activation of records in PHARMACY ORDERABLE ITEM file "RTN","TMGNDF4D",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4D",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4D",8,0) ;"11-21-2006 "RTN","TMGNDF4D",9,0) "RTN","TMGNDF4D",10,0) "RTN","TMGNDF4D",11,0) ;"NOTE: 3/9/07 --DON'T USE THIS FUNCTION. IT IS HANDLED IN TMGNDF4C. "RTN","TMGNDF4D",12,0) "RTN","TMGNDF4D",13,0) ;"======================================================================= "RTN","TMGNDF4D",14,0) ;" API -- Public Functions. "RTN","TMGNDF4D",15,0) ;"======================================================================= "RTN","TMGNDF4D",16,0) ;"ActivAll -- to remove the inactive date for all records in 101.43 "RTN","TMGNDF4D",17,0) "RTN","TMGNDF4D",18,0) ;"======================================================================= "RTN","TMGNDF4D",19,0) ;" Private Functions. "RTN","TMGNDF4D",20,0) ;"======================================================================= "RTN","TMGNDF4D",21,0) ;"ActivDate(DateAfter) -- remove inactive date if inactive date on/after DateAfter "RTN","TMGNDF4D",22,0) ;"XFormOff -- remove restrinction in input transform that prevents deletion. "RTN","TMGNDF4D",23,0) ;"XFormOn -- restore the input transform to field .04 in file 50.7 "RTN","TMGNDF4D",24,0) ;"SetXForm(code) -- remove the old input transform, and replace with code "RTN","TMGNDF4D",25,0) "RTN","TMGNDF4D",26,0) "RTN","TMGNDF4D",27,0) ;"======================================================================= "RTN","TMGNDF4D",28,0) "RTN","TMGNDF4D",29,0) ActivAll "RTN","TMGNDF4D",30,0) ;"Purpose: To active ALL records "RTN","TMGNDF4D",31,0) "RTN","TMGNDF4D",32,0) new date,%T,X,Y "RTN","TMGNDF4D",33,0) set X="1/1/1960" "RTN","TMGNDF4D",34,0) do ^%DT "RTN","TMGNDF4D",35,0) set date=Y "RTN","TMGNDF4D",36,0) if date>-1 do ActivDate(date) "RTN","TMGNDF4D",37,0) "RTN","TMGNDF4D",38,0) write "Done.",! "RTN","TMGNDF4D",39,0) quit "RTN","TMGNDF4D",40,0) "RTN","TMGNDF4D",41,0) "RTN","TMGNDF4D",42,0) ActivDate(DateAfter) "RTN","TMGNDF4D",43,0) ;"Purpose: To remove inactive date for all records in ORDERABLE ITEM "RTN","TMGNDF4D",44,0) ;" having an inactive date on/after DateAfter "RTN","TMGNDF4D",45,0) ;"Input: DateAfter -- the date to compare the inactive date with. If the "RTN","TMGNDF4D",46,0) ;" inactive date is on/after DateAfter, then inactive date "RTN","TMGNDF4D",47,0) ;" will be deleted. "RTN","TMGNDF4D",48,0) ;" ** Must be in Fileman Date format "RTN","TMGNDF4D",49,0) "RTN","TMGNDF4D",50,0) do XFormOff "RTN","TMGNDF4D",51,0) "RTN","TMGNDF4D",52,0) new Itr,IEN,Date,Y,X "RTN","TMGNDF4D",53,0) new abort set abort=-5 "RTN","TMGNDF4D",54,0) set IEN=$$ItrInit^TMGITR(101.43,.Itr) "RTN","TMGNDF4D",55,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGNDF4D",56,0) if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!(abort>0) "RTN","TMGNDF4D",57,0) . set abort=abort+$$Activ1(IEN,DateAfter) "RTN","TMGNDF4D",58,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4D",59,0) "RTN","TMGNDF4D",60,0) do XFormOn "RTN","TMGNDF4D",61,0) kill TMGXFORM "RTN","TMGNDF4D",62,0) "RTN","TMGNDF4D",63,0) quit "RTN","TMGNDF4D",64,0) "RTN","TMGNDF4D",65,0) "RTN","TMGNDF4D",66,0) Activ1(IEN101d43,DateAfter) "RTN","TMGNDF4D",67,0) ;"Purpose: To remove inactive date for all records in ORDERABLE ITEM "RTN","TMGNDF4D",68,0) ;" having an inactive date on/after DateAfter "RTN","TMGNDF4D",69,0) ;"Input: IEN101d43 -- IEN in 101.43 "RTN","TMGNDF4D",70,0) ;" DateAfter -- the date to compare the inactive date with. If the "RTN","TMGNDF4D",71,0) ;" inactive date is on/after DateAfter, then inactive date "RTN","TMGNDF4D",72,0) ;" will be deleted. "RTN","TMGNDF4D",73,0) ;" ** Must be in Fileman Date format "RTN","TMGNDF4D",74,0) ;"NOTE: XFormOff should be called before this function, and when "RTN","TMGNDF4D",75,0) ;" all mods are done, XFormOn should be called. "RTN","TMGNDF4D",76,0) ;"Results: 0 is OK, 1 if error "RTN","TMGNDF4D",77,0) "RTN","TMGNDF4D",78,0) new Itr,IEN,Date,Y,X "RTN","TMGNDF4D",79,0) new result set result=0 "RTN","TMGNDF4D",80,0) "RTN","TMGNDF4D",81,0) new X2 set X2=$piece($get(^ORD(101.43,IEN,.1)),"^",1) ;".1;1 --> inactive date "RTN","TMGNDF4D",82,0) if X2="" goto A1Done "RTN","TMGNDF4D",83,0) new X1 set X1=DateAfter "RTN","TMGNDF4D",84,0) do ^%DTC "RTN","TMGNDF4D",85,0) new TMGFDA,TMGMSG "RTN","TMGNDF4D",86,0) set TMGFDA(101.43,IEN_",",.1)="" ;"kill inactive date "RTN","TMGNDF4D",87,0) new $etrap set $etrap="W ""??ERROR TRAPPED??"",! Q" "RTN","TMGNDF4D",88,0) do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4D",89,0) new PriorErrorFound "RTN","TMGNDF4D",90,0) if $$ShowIfError^TMGDBAPI(.TMGMSG,.PriorErrorFound) goto A1Done "RTN","TMGNDF4D",91,0) set X2=$piece($get(^ORD(101.43,IEN,.1)),"^",1) ;".1;1 --> inactive date "RTN","TMGNDF4D",92,0) if X2'="" do "RTN","TMGNDF4D",93,0) . write "Deletion of 101.43 inactivation date FAILED. [",X2,"]",! "RTN","TMGNDF4D",94,0) . set result=1 "RTN","TMGNDF4D",95,0) "RTN","TMGNDF4D",96,0) A1Done "RTN","TMGNDF4D",97,0) quit result "RTN","TMGNDF4D",98,0) "RTN","TMGNDF4D",99,0) "RTN","TMGNDF4D",100,0) "RTN","TMGNDF4D",101,0) DoFromTMG(IEN,Option) "RTN","TMGNDF4D",102,0) ;"Purpose: to activate ONE entry in ORDERABLE ITEM (101.43) file, linked from 22706.9 "RTN","TMGNDF4D",103,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF4D",104,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF4D",105,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF4D",106,0) ;" to file POI, OI, OQV etc. "RTN","TMGNDF4D",107,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF4D",108,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF4D",109,0) "RTN","TMGNDF4D",110,0) ;"Output: OI records will be added or refreshed. "RTN","TMGNDF4D",111,0) ;"Result: 1=Modified, 0=not modified "RTN","TMGNDF4D",112,0) "RTN","TMGNDF4D",113,0) new result set result=0 "RTN","TMGNDF4D",114,0) if +$get(IEN)=0 goto DFTMGDone "RTN","TMGNDF4D",115,0) "RTN","TMGNDF4D",116,0) new tradePtr,genericPtr "RTN","TMGNDF4D",117,0) "RTN","TMGNDF4D",118,0) new date,%T,X,Y "RTN","TMGNDF4D",119,0) set X="1/1/1960" "RTN","TMGNDF4D",120,0) do ^%DT "RTN","TMGNDF4D",121,0) set date=Y "RTN","TMGNDF4D",122,0) do XFormOff "RTN","TMGNDF4D",123,0) "RTN","TMGNDF4D",124,0) ;"Get 22706.9 --> 50 --> 50.7 --> 101.43 "RTN","TMGNDF4D",125,0) set tradePtr=+$piece($get(^TMG(22706.9,IEN,7)),"^",1) ;" a IEN50d7 ptr "RTN","TMGNDF4D",126,0) set genericPtr=+$piece($get(^TMG(22706.9,IEN,7)),"^",2) ;" a IEN50d7 ptr "RTN","TMGNDF4D",127,0) if tradePtr'=0 do "RTN","TMGNDF4D",128,0) . new IEN50d7 set IEN50d7=+$piece($get(^PSDRUG(tradePtr,2)),"^",1) ;"2;1 = fld 2.1 to POI "RTN","TMGNDF4D",129,0) . if IEN50d7=0 quit "RTN","TMGNDF4D",130,0) . new IEN101d43 set IEN101d43=$$GetOI^TMGNDFUT(IEN50d7) "RTN","TMGNDF4D",131,0) . if IEN101d43=0 quit "RTN","TMGNDF4D",132,0) . do Activ1(IEN101d43,date) "RTN","TMGNDF4D",133,0) . if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF4D",134,0) . . do Fix1OQV^TMGNDF4E(IEN101d43,.Option) "RTN","TMGNDF4D",135,0) "RTN","TMGNDF4D",136,0) if genericPtr'=0 do "RTN","TMGNDF4D",137,0) . new IEN50d7 set IEN50d7=$piece($get(^PSDRUG(genericPtr,2)),"^",1) ;"2;1 = fld 2.1 to POI "RTN","TMGNDF4D",138,0) . if IEN50d7=0 quit "RTN","TMGNDF4D",139,0) . new IEN101d43 set IEN101d43=$$GetOI^TMGNDF4C(IEN50d7) "RTN","TMGNDF4D",140,0) . if IEN101d43=0 quit "RTN","TMGNDF4D",141,0) . do Activ1(IEN101d43,date) "RTN","TMGNDF4D",142,0) . if $get(Option("FIX CHAIN"))=1 do "RTN","TMGNDF4D",143,0) . . do Fix1OQV^TMGNDF4E(IEN101d43,.Option) "RTN","TMGNDF4D",144,0) "RTN","TMGNDF4D",145,0) do XFormOn "RTN","TMGNDF4D",146,0) "RTN","TMGNDF4D",147,0) DFTMGDone "RTN","TMGNDF4D",148,0) quit result "RTN","TMGNDF4D",149,0) "RTN","TMGNDF4D",150,0) "RTN","TMGNDF4D",151,0) "RTN","TMGNDF4D",152,0) XFormOff "RTN","TMGNDF4D",153,0) ;"Purpose: to remove restrinction in input transform that prevents deletion. "RTN","TMGNDF4D",154,0) "RTN","TMGNDF4D",155,0) ;"new TMGXFORM ;NOTE: NO new -- will be killed later "RTN","TMGNDF4D",156,0) set TMGXFORM=$piece($get(^ORD(101.43,.1,0)),"^",5,99) "RTN","TMGNDF4D",157,0) merge ^TMG("TMP","XREF",101.43,.1,1)=^DD(101.43,.1,1) "RTN","TMGNDF4D",158,0) kill ^DD(101.43,.1,1) ;"kill off the screening xref code "RTN","TMGNDF4D",159,0) do SetXForm("W !,X,! S %DT=""E"" D ^%DT S X=Y S:Y<1 X=""""") "RTN","TMGNDF4D",160,0) "RTN","TMGNDF4D",161,0) quit "RTN","TMGNDF4D",162,0) "RTN","TMGNDF4D",163,0) "RTN","TMGNDF4D",164,0) XFormOn "RTN","TMGNDF4D",165,0) ;"Purpose: to restore the input transform to field .04 in file 50.7 "RTN","TMGNDF4D",166,0) "RTN","TMGNDF4D",167,0) set TMGXFORM=$get(TMGXFORM,"S %DT=""ESTX"" D ^%DT S X=Y K:Y<1 X") "RTN","TMGNDF4D",168,0) do SetXForm(TMGXFORM) "RTN","TMGNDF4D",169,0) kill ^DD(101.43,.1,1) "RTN","TMGNDF4D",170,0) merge ^DD(101.43,.1,1)=^TMG("TMP","XREF",101.43,.1,1) ;"restore screening xref code "RTN","TMGNDF4D",171,0) quit "RTN","TMGNDF4D",172,0) "RTN","TMGNDF4D",173,0) "RTN","TMGNDF4D",174,0) SetXForm(code) "RTN","TMGNDF4D",175,0) ;"Purpose: to remove the old input transform, and replace with code "RTN","TMGNDF4D",176,0) "RTN","TMGNDF4D",177,0) set $piece(^DD(101.43,.1,0),"^",5,99)="" ;"clear out old stuff "RTN","TMGNDF4D",178,0) set $piece(^DD(101.43,.1,0),"^",5)=code "RTN","TMGNDF4D",179,0) ;"zwr ^DD(50.7,.04,0) "RTN","TMGNDF4D",180,0) quit "RTN","TMGNDF4E") 0^57^B6240 "RTN","TMGNDF4E",1,0) TMGNDF4E ;TMG/kst/FDA Import -- Copy Orderable --> OQV ;03/25/06 "RTN","TMGNDF4E",2,0) ;;1.0;TMG-LIB;**1**;11/21/07 "RTN","TMGNDF4E",3,0) "RTN","TMGNDF4E",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4E",5,0) ;" Copy of ORDERABLE ITEMS into ORDER QUICK VIEW file "RTN","TMGNDF4E",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4E",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4E",8,0) ;"11-21-2006 "RTN","TMGNDF4E",9,0) "RTN","TMGNDF4E",10,0) ;"======================================================================= "RTN","TMGNDF4E",11,0) ;" API -- Public Functions. "RTN","TMGNDF4E",12,0) ;"======================================================================= "RTN","TMGNDF4E",13,0) ;"Menu "RTN","TMGNDF4E",14,0) "RTN","TMGNDF4E",15,0) ;"Sync2OQV -- ensure ALL ORDERABLE ITEMS (101.43) items are added to the ORDER QUICK VIEW (101.44) "RTN","TMGNDF4E",16,0) ;"Fix1OQV(IEN101d43,Option) -- alter one entry in OQV file to reflect changes in ORDERABLE ITEM file (101.43) "RTN","TMGNDF4E",17,0) "RTN","TMGNDF4E",18,0) ;"======================================================================= "RTN","TMGNDF4E",19,0) ;" Private Functions. "RTN","TMGNDF4E",20,0) ;"======================================================================= "RTN","TMGNDF4E",21,0) ;"MakeNewQOVS -- save the old QUICK ORDER VIEW set, and create a new one. "RTN","TMGNDF4E",22,0) ;"Add(RxSet,pOI) -- add 'name' to ORWDSET O RX record in ORDER QUICK VIEW file "RTN","TMGNDF4E",23,0) ;"KillPrior(RxSet) -- kill ALL records in the RxSet in 101.44 "RTN","TMGNDF4E",24,0) ;"Check4BadOQV -- Scan through all ORDER QUICK VIEWS cheking fro pointers to bad records "RTN","TMGNDF4E",25,0) "RTN","TMGNDF4E",26,0) ;"======================================================================= "RTN","TMGNDF4E",27,0) "RTN","TMGNDF4E",28,0) Menu "RTN","TMGNDF4E",29,0) new Menu,UsrSlct "RTN","TMGNDF4E",30,0) set Menu(0)="Pick Option to Sync ORDER QUICK VIEW (OQV) (4E)" "RTN","TMGNDF4E",31,0) set Menu(1)="Sync imports to ORDER QUICK VIEW."_$char(9)_"Sync2OQV" "RTN","TMGNDF4E",32,0) set Menu(2)="Check for BAD entries in ORDER QUICK VIEW file"_$char(9)_"Check4BadOQV" "RTN","TMGNDF4E",33,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF4E",34,0) set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF4E",35,0) "RTN","TMGNDF4E",36,0) M1 write # "RTN","TMGNDF4E",37,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4E",38,0) "RTN","TMGNDF4E",39,0) if UsrSlct="Sync2OQV" do Sync2OQV goto M1 "RTN","TMGNDF4E",40,0) if UsrSlct="Check4BadOQV" do Check4BadOQV goto M1 "RTN","TMGNDF4E",41,0) if UsrSlct="Prev" goto Menu^TMGNDF4C ;"quit can occur from there... "RTN","TMGNDF4E",42,0) if UsrSlct="Next" goto Menu^TMGNDF4F ;"quit can occur from there... "RTN","TMGNDF4E",43,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF4E",44,0) goto M1 "RTN","TMGNDF4E",45,0) "RTN","TMGNDF4E",46,0) MenuDone "RTN","TMGNDF4E",47,0) quit "RTN","TMGNDF4E",48,0) "RTN","TMGNDF4E",49,0) "RTN","TMGNDF4E",50,0) Sync2OQV "RTN","TMGNDF4E",51,0) ;"Purpose: To cycle through all items in the ORDERABLE ITEMS (101.43) file and "RTN","TMGNDF4E",52,0) ;" ensure that they have been added to the ORDER QUICK VIEW (101.44) file "RTN","TMGNDF4E",53,0) ;"Result: none. "RTN","TMGNDF4E",54,0) "RTN","TMGNDF4E",55,0) ;"NOTE: This function will KILL prior entries in ORWD O RX record "RTN","TMGNDF4E",56,0) ;" There are no pointers IN to this file, so deleting will not "RTN","TMGNDF4E",57,0) ;" leave dangling pointers. "RTN","TMGNDF4E",58,0) "RTN","TMGNDF4E",59,0) ;"NOTE: this function must ensure that the drugs are put into 101.44 "RTN","TMGNDF4E",60,0) ;" in alphabetical order "RTN","TMGNDF4E",61,0) ;" ALSO, drugs should be added both with their generic and brand names. "RTN","TMGNDF4E",62,0) "RTN","TMGNDF4E",63,0) ;"Here is an example of drugs that have been added 'properly' "RTN","TMGNDF4E",64,0) ;" 1) ^ORD(101.44,16,20,0) = ^101.442PA^20^20 "RTN","TMGNDF4E",65,0) ;" 2) ^ORD(101.44,16,20,1,0) = 49^AMITRIPTYLINE TAB "RTN","TMGNDF4E",66,0) ;" 3) ^ORD(101.44,16,20,2,0) = 53^CHLORPROMAZINE TAB "RTN","TMGNDF4E",67,0) ;" 4) ^ORD(101.44,16,20,3,0) = 50^DIGOXIN TAB "RTN","TMGNDF4E",68,0) ;" 5) ^ORD(101.44,16,20,4,0) = 44^DILTIAZEM TAB "RTN","TMGNDF4E",69,0) ;" 6) ^ORD(101.44,16,20,5,0) = 49^ELAVIL "RTN","TMGNDF4E",70,0) ;" 7) ^ORD(101.44,16,20,6,0) = 49^ENDEP "RTN","TMGNDF4E",71,0) ;" 8) ^ORD(101.44,16,20,7,0) = 47^HCTZ "RTN","TMGNDF4E",72,0) ;" 9) ^ORD(101.44,16,20,8,0) = 47^HYDROCHLOROTHIZIDE TAB "RTN","TMGNDF4E",73,0) ;" 10) ^ORD(101.44,16,20,9,0) = 50^LANOXIN "RTN","TMGNDF4E",74,0) ;" 11) ^ORD(101.44,16,20,10,0) = 54^LEVOTHYROXINE TAB "RTN","TMGNDF4E",75,0) ;" 12) ^ORD(101.44,16,20,11,0) = 54^LEVOXYL "RTN","TMGNDF4E",76,0) ;" 13) ^ORD(101.44,16,20,12,0) = 46^LISINOPRIL TAB "RTN","TMGNDF4E",77,0) ;" 14) ^ORD(101.44,16,20,13,0) = 52^PRAZOSIN CAP,ORAL "RTN","TMGNDF4E",78,0) ;" 15) ^ORD(101.44,16,20,14,0) = 46^PRINIVIL "RTN","TMGNDF4E",79,0) ;" 16) ^ORD(101.44,16,20,15,0) = 48^SILDENAFIL TAB "RTN","TMGNDF4E",80,0) ;" 17) ^ORD(101.44,16,20,16,0) = 54^SYNTHROID "RTN","TMGNDF4E",81,0) ;" 18) ^ORD(101.44,16,20,17,0) = 48^VIAGRA "RTN","TMGNDF4E",82,0) ;" 19) ^ORD(101.44,16,20,18,0) = 46^ZESTRIL "RTN","TMGNDF4E",83,0) ;" 20) ^ORD(101.44,16,20,19,0) = 20 "RTN","TMGNDF4E",84,0) ;"21) ^ORD(101.44,16,20,20,0) = 54 "RTN","TMGNDF4E",85,0) ;"22) ^ORD(101.44,16,20,"B",20,19) = "RTN","TMGNDF4E",86,0) ;"23) ^ORD(101.44,16,20,"B",54,20) = "RTN","TMGNDF4E",87,0) ;"24) ^ORD(101.44,16,20,"C","AMITRIPTYLINE TAB ",1) = "RTN","TMGNDF4E",88,0) ;"25) ^ORD(101.44,16,20,"C","CHLORPROMAZINE TAB ",2) = "RTN","TMGNDF4E",89,0) ;"26) ^ORD(101.44,16,20,"C","DIGOXIN TAB ",3) = "RTN","TMGNDF4E",90,0) ;"27) ^ORD(101.44,16,20,"C","DILTIAZEM TAB ",4) = "RTN","TMGNDF4E",91,0) ;"28) ^ORD(101.44,16,20,"C","ELAVIL ",5) = "RTN","TMGNDF4E",92,0) ;"29) ^ORD(101.44,16,20,"C","ENDEP ",6) = "RTN","TMGNDF4E",93,0) ;"30) ^ORD(101.44,16,20,"C","HCTZ ",7) = "RTN","TMGNDF4E",94,0) ;"31) ^ORD(101.44,16,20,"C","HYDROCHLOROTHIZIDE TAB ",8) = "RTN","TMGNDF4E",95,0) ;"32) ^ORD(101.44,16,20,"C","LANOXIN ",9) = "RTN","TMGNDF4E",96,0) ;"33) ^ORD(101.44,16,20,"C","LEVOTHYROXINE TAB ",10) = "RTN","TMGNDF4E",97,0) ;"34) ^ORD(101.44,16,20,"C","LEVOXYL ",11) = "RTN","TMGNDF4E",98,0) ;"35) ^ORD(101.44,16,20,"C","LISINOPRIL TAB ",12) = "RTN","TMGNDF4E",99,0) ;"36) ^ORD(101.44,16,20,"C","PRAZOSIN CAP,ORAL ",13) = "RTN","TMGNDF4E",100,0) ;"37) ^ORD(101.44,16,20,"C","PRINIVIL ",14) = "RTN","TMGNDF4E",101,0) ;"38) ^ORD(101.44,16,20,"C","SILDENAFIL TAB ",15) = "RTN","TMGNDF4E",102,0) ;"39) ^ORD(101.44,16,20,"C","SYNTHROID ",16) = "RTN","TMGNDF4E",103,0) "RTN","TMGNDF4E",104,0) do MakeNewQOVS ;"Get a fresh order set to work in. "RTN","TMGNDF4E",105,0) "RTN","TMGNDF4E",106,0) set RxSet=$$GetOQVSet^TMGNDFUT "RTN","TMGNDF4E",107,0) if RxSet'>0 do goto AADone "RTN","TMGNDF4E",108,0) . write "Can't find record 'ORWDSET O RX' in ORDER QUICK VIEW (101.44) file.",! "RTN","TMGNDF4E",109,0) . write "Aborting.",! "RTN","TMGNDF4E",110,0) "RTN","TMGNDF4E",111,0) ;"Kill all prior display data in ORDER QUICK VIEW file: ORWDSET O RX record "RTN","TMGNDF4E",112,0) do KillPrior(RxSet) "RTN","TMGNDF4E",113,0) "RTN","TMGNDF4E",114,0) new pAddArray set pAddArray=$name(^TMG("TMP","KILL","Add 101.44 Temp")) "RTN","TMGNDF4E",115,0) kill @pAddArray "RTN","TMGNDF4E",116,0) "RTN","TMGNDF4E",117,0) write "Organizing drugs for addition to ORDER QUICK VIEW...",! "RTN","TMGNDF4E",118,0) new Itr,IEN22706d9 "RTN","TMGNDF4E",119,0) new abort set abort=0 "RTN","TMGNDF4E",120,0) set IEN22706d9=$$ItrInit^TMGITR(22706.9,.Itr) "RTN","TMGNDF4E",121,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN22706d9") "RTN","TMGNDF4E",122,0) if IEN22706d9'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN22706d9)'>0)!abort "RTN","TMGNDF4E",123,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4E",124,0) . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 quit ;" 1=skip "RTN","TMGNDF4E",125,0) . new tIEN101d43,gIEN101d43 "RTN","TMGNDF4E",126,0) . set tIEN101d43=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",5) "RTN","TMGNDF4E",127,0) . set gIEN101d43=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",6) "RTN","TMGNDF4E",128,0) . if tIEN101d43>0 do "RTN","TMGNDF4E",129,0) . . new name set name=$piece($get(^ORD(101.43,tIEN101d43,0)),"^",1) "RTN","TMGNDF4E",130,0) . . if (name="")!(name="") do KillOI^TMGNDFUT(tIEN101d43) quit "RTN","TMGNDF4E",131,0) . . set @pAddArray@(name,tIEN101d43)="" "RTN","TMGNDF4E",132,0) . . new SynIEN set SynIEN=0 "RTN","TMGNDF4E",133,0) . . for set SynIEN=$order(^ORD(101.43,tIEN101d43,2,SynIEN)) quit:(+SynIEN'>0) do "RTN","TMGNDF4E",134,0) . . . new SynName set SynName=$get(^ORD(101.43,tIEN101d43,2,SynIEN,0)) "RTN","TMGNDF4E",135,0) . . . set SynName=$$Trim^TMGSTUTL(SynName) "RTN","TMGNDF4E",136,0) . . . set SynName=SynName_" <"_name_">" "RTN","TMGNDF4E",137,0) . . . set @pAddArray@(SynName,tIEN101d43)="" "RTN","TMGNDF4E",138,0) . if gIEN101d43>0 do "RTN","TMGNDF4E",139,0) . . new name set name=$piece($get(^ORD(101.43,gIEN101d43,0)),"^",1) "RTN","TMGNDF4E",140,0) . . if (name="")!(name="") do KillOI^TMGNDFUT(gIEN101d43) quit "RTN","TMGNDF4E",141,0) . . set @pAddArray@(name,gIEN101d43)="" "RTN","TMGNDF4E",142,0) . . new SynIEN set SynIEN=0 "RTN","TMGNDF4E",143,0) . . for set SynIEN=$order(^ORD(101.43,gIEN101d43,2,SynIEN)) quit:(+SynIEN'>0) do "RTN","TMGNDF4E",144,0) . . . new SynName set SynName=$get(^ORD(101.43,gIEN101d43,2,SynIEN,0)) "RTN","TMGNDF4E",145,0) . . . set SynName=$$Trim^TMGSTUTL(SynName) "RTN","TMGNDF4E",146,0) . . . set SynName=SynName_" <"_name_">" "RTN","TMGNDF4E",147,0) . . . set @pAddArray@(SynName,gIEN101d43)="" "RTN","TMGNDF4E",148,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4E",149,0) if abort=1 goto AADone "RTN","TMGNDF4E",150,0) "RTN","TMGNDF4E",151,0) ;"Now add all drugs "RTN","TMGNDF4E",152,0) write "Adding drugs to ORDER QUICK VIEW...",! "RTN","TMGNDF4E",153,0) new Itr,DispName "RTN","TMGNDF4E",154,0) set abort=0 "RTN","TMGNDF4E",155,0) set DispName=$$ItrAInit^TMGITR(pAddArray,.Itr) "RTN","TMGNDF4E",156,0) do PrepProgress^TMGITR(.Itr,20,1,"DispName") "RTN","TMGNDF4E",157,0) if DispName'="" for do quit:($$ItrANext^TMGITR(.Itr,.DispName)="")!abort "RTN","TMGNDF4E",158,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDF4E",159,0) . new IEN set IEN=$order(@pAddArray@(DispName,"")) "RTN","TMGNDF4E",160,0) . set pOQV=$$Add(RxSet,IEN,DispName) "RTN","TMGNDF4E",161,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDF4E",162,0) "RTN","TMGNDF4E",163,0) AADone "RTN","TMGNDF4E",164,0) write "Done.",! "RTN","TMGNDF4E",165,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4E",166,0) quit "RTN","TMGNDF4E",167,0) "RTN","TMGNDF4E",168,0) "RTN","TMGNDF4E",169,0) MakeNewQOVS "RTN","TMGNDF4E",170,0) ;"Purpose: To save the old QUICK ORDER VIEW set, and create a new one. "RTN","TMGNDF4E",171,0) ;"Note: Because the drugs have to be added to the file in alphabetical order, "RTN","TMGNDF4E",172,0) ;" it is required to create a NEW order set. I will save the old one "RTN","TMGNDF4E",173,0) ;" for future reference. "RTN","TMGNDF4E",174,0) "RTN","TMGNDF4E",175,0) new DIC,X,Y,%,RxSet "RTN","TMGNDF4E",176,0) "RTN","TMGNDF4E",177,0) set RxSet=$$GetOQVSet^TMGNDFUT "RTN","TMGNDF4E",178,0) if RxSet'>0 do goto MNQSDone "RTN","TMGNDF4E",179,0) . write "Can't find record 'ORWDSET O RX' in ORDER QUICK VIEW (101.44) file.",! "RTN","TMGNDF4E",180,0) . write "Aborting.",! "RTN","TMGNDF4E",181,0) "RTN","TMGNDF4E",182,0) new nowS "RTN","TMGNDF4E",183,0) do NOW^%DTC "RTN","TMGNDF4E",184,0) S Y=X ;"% current fileman date returned in X (no time) "RTN","TMGNDF4E",185,0) D DD^%DT ;"convert to external format. "RTN","TMGNDF4E",186,0) set nowS=Y "RTN","TMGNDF4E",187,0) "RTN","TMGNDF4E",188,0) new newName set newName="ORWDSET O RX -- "_nowS "RTN","TMGNDF4E",189,0) write "Saving old ORDER QUICK VIEW set as: ",newName,! "RTN","TMGNDF4E",190,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGNDF4E",191,0) set TMGFDA(101.44,RxSet_",",.01)=newName "RTN","TMGNDF4E",192,0) do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDF4E",193,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4E",194,0) "RTN","TMGNDF4E",195,0) set TMGFDA(101.44,"+1,",.01)="ORWDSET O RX" "RTN","TMGNDF4E",196,0) set TMGFDA(101.44,"+1,",6)="NOW" "RTN","TMGNDF4E",197,0) do UPDATE^DIE("EK","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF4E",198,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4E",199,0) "RTN","TMGNDF4E",200,0) MNQSDone "RTN","TMGNDF4E",201,0) quit "RTN","TMGNDF4E",202,0) "RTN","TMGNDF4E",203,0) "RTN","TMGNDF4E",204,0) Add(RxSet,pOI,RxName) "RTN","TMGNDF4E",205,0) ;"Purpose: to add 'name' to ORWDSET O RX record in ORDER QUICK VIEW ('OQV')file "RTN","TMGNDF4E",206,0) ;"Input: RxSet -- the record number in OQV to add records to. "RTN","TMGNDF4E",207,0) ;" pOI -- a pointer to (i.e. the IEN of) record in ORDERABLE ITEM (101.43) file "RTN","TMGNDF4E",208,0) ;" RxName -- The name to display in CPRS "RTN","TMGNDF4E",209,0) ;"Results: returns the IEN of the new record. "RTN","TMGNDF4E",210,0) "RTN","TMGNDF4E",211,0) new TMGFDA,TMGMSG,TMGIEN,PriorErrorFound "RTN","TMGNDF4E",212,0) new result set result=0 "RTN","TMGNDF4E",213,0) "RTN","TMGNDF4E",214,0) if pOI=0 do goto AdDone "RTN","TMGNDF4E",215,0) . write !,"Skipping addition of ",RxName," because it doesn't",! "RTN","TMGNDF4E",216,0) . write "seem linked to a PHARMACY ORDERABLE ITEM.",! "RTN","TMGNDF4E",217,0) set TMGFDA(101.442,"+1,"_RxSet_",",.01)=pOI "RTN","TMGNDF4E",218,0) set TMGFDA(101.442,"+1,"_RxSet_",",2)=RxName "RTN","TMGNDF4E",219,0) "RTN","TMGNDF4E",220,0) new $etrap set $etrap="write !,""ERROR TRAPPED."",! quit" "RTN","TMGNDF4E",221,0) Ad1 do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGNDF4E",222,0) if $$ShowIfError^TMGDBAPI(.TMGMSG,.PriorErrorFound) goto AdDone "RTN","TMGNDF4E",223,0) set result=+$get(TMGIEN(1)) "RTN","TMGNDF4E",224,0) "RTN","TMGNDF4E",225,0) AdDone "RTN","TMGNDF4E",226,0) quit result "RTN","TMGNDF4E",227,0) "RTN","TMGNDF4E",228,0) "RTN","TMGNDF4E",229,0) KillPrior(RxSet) "RTN","TMGNDF4E",230,0) ;"Purpose: To kill ALL records in the RxSet in 101.44 "RTN","TMGNDF4E",231,0) ;"Note: I am fairly certain that no other files point to this file "RTN","TMGNDF4E",232,0) ;" (there are no pointers IN). So I can just kill. "RTN","TMGNDF4E",233,0) ;" CAUTION: this might not be the right thing to do in another system. "RTN","TMGNDF4E",234,0) "RTN","TMGNDF4E",235,0) new temp merge temp=^ORD(101.44,RxSet,20,0) "RTN","TMGNDF4E",236,0) kill ^ORD(101.44,RxSet,20) "RTN","TMGNDF4E",237,0) merge ^ORD(101.44,RxSet,20,0)=temp "RTN","TMGNDF4E",238,0) set $piece(^ORD(101.44,RxSet,20,0),"^",3)=0 ;"most recently assigned IEN "RTN","TMGNDF4E",239,0) set $piece(^ORD(101.44,RxSet,20,0),"^",4)=0 ;"current total number of records "RTN","TMGNDF4E",240,0) "RTN","TMGNDF4E",241,0) quit "RTN","TMGNDF4E",242,0) "RTN","TMGNDF4E",243,0) "RTN","TMGNDF4E",244,0) ;"============================== "RTN","TMGNDF4E",245,0) Fix1OQV(IEN101d43,Option) "RTN","TMGNDF4E",246,0) ;"Purpose: to alter one entry in OQV file to reflect changes "RTN","TMGNDF4E",247,0) ;" in ORDERABLE ITEM file (101.43) "RTN","TMGNDF4E",248,0) ;"Input: IEN101d43 -- IEN in ORDERABLE ITEM file (101.43) "RTN","TMGNDF4E",249,0) ;" Option -- OPTIONAL. Format: "RTN","TMGNDF4E",250,0) ;" Option("FIX CHAIN")=1 <--- changes will be propigate forward "RTN","TMGNDF4E",251,0) ;" to file POI, OI, OQV etc. "RTN","TMGNDF4E",252,0) ;" OPTION("FIX CHAIN","IEN22706d9")=Source IEN "RTN","TMGNDF4E",253,0) ;" Option("QUIET")=1 <-- supress text output "RTN","TMGNDF4E",254,0) ;" Option("IEN50","TRADE")=IEN50 for Trade Name "RTN","TMGNDF4E",255,0) ;" Option("IEN50","GENERIC")=IEN50 for Generic Name "RTN","TMGNDF4E",256,0) ;" Option("DRUG NAME AND FORM","TRADE")=tradeNameAF "RTN","TMGNDF4E",257,0) ;" Option("DRUG NAME AND FORM","GENERIC")=genericNameAF "RTN","TMGNDF4E",258,0) ;" Option("IEN50.7","TRADE")=IEN50d7 "RTN","TMGNDF4E",259,0) ;" Option("IEN50.7","GENERIC")=IEN50d7 "RTN","TMGNDF4E",260,0) ;" Option("IEN101.43","TRADE")=IEN101d43 "RTN","TMGNDF4E",261,0) ;" Option("IEN101.43","GENERIC")=IEN101d43 "RTN","TMGNDF4E",262,0) ;" Option("DELETING")=1 <-- deleting chain (not IEN22706d9) "RTN","TMGNDF4E",263,0) ;"NOTE: The entries in the OQV file have to be set up in ALPHABETICAL order. "RTN","TMGNDF4E",264,0) ;" This function will NOT reorder these. If name is completely changed, then "RTN","TMGNDF4E",265,0) ;" it will likely appear out of alphabetical order. This may hinder finding it. "RTN","TMGNDF4E",266,0) ;" -- Such a problem could be fixed by runnin: Sync2OQV^TMGNDF4E "RTN","TMGNDF4E",267,0) ;"Result: 1 if error, 0 if OK. "RTN","TMGNDF4E",268,0) "RTN","TMGNDF4E",269,0) new result set result=0 "RTN","TMGNDF4E",270,0) new RxSet,quiet "RTN","TMGNDF4E",271,0) set quiet=$get(Option("QUIET"))=1 "RTN","TMGNDF4E",272,0) set RxSet=$$GetOQVSet^TMGNDFUT(quiet) "RTN","TMGNDF4E",273,0) if RxSet=0 goto F1OQVDone "RTN","TMGNDF4E",274,0) "RTN","TMGNDF4E",275,0) new OQVIENS set OQVIENS=$$GetOQVIENS^TMGNDFUT(IEN101d43,RxSet) "RTN","TMGNDF4E",276,0) if OQVIENS=0 do goto F1OQVDone "RTN","TMGNDF4E",277,0) . if quiet quit "RTN","TMGNDF4E",278,0) . write "Can't find link ORDERABLE ITEM--> ORDER QUICK VIEW (OQV).",! "RTN","TMGNDF4E",279,0) . write "Try do a batch add of imports into OQV.",! "RTN","TMGNDF4E",280,0) . write "Can't insert OQV with out reordering...",! "RTN","TMGNDF4E",281,0) "RTN","TMGNDF4E",282,0) new drugName set drugName=$piece($get(^ORD(101.43,IEN101d43,0)),"^",1) "RTN","TMGNDF4E",283,0) if ($get(Option("DELETING"))=1)!(drugName="") set drugName="" "RTN","TMGNDF4E",284,0) "RTN","TMGNDF4E",285,0) new TMGFDA,TMGMSG "RTN","TMGNDF4E",286,0) set TMGFDA(101.442,OQVIENS,2)=drugName "RTN","TMGNDF4E",287,0) new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDF4E",288,0) if $data(TMGFDA) do "RTN","TMGNDF4E",289,0) . do FILE^DIE("KS","TMGFDA","TMGMSG") "RTN","TMGNDF4E",290,0) . set result=$$ShowIfError^TMGDBAPI(.TMGMSG) ;"show FM errors, even if quiet. "RTN","TMGNDF4E",291,0) "RTN","TMGNDF4E",292,0) F1OQVDone "RTN","TMGNDF4E",293,0) quit result "RTN","TMGNDF4E",294,0) "RTN","TMGNDF4E",295,0) "RTN","TMGNDF4E",296,0) Check4BadOQV "RTN","TMGNDF4E",297,0) ;"Purpose: Scan through all ORDER QUICK VIEWS and see if any are pointing "RTN","TMGNDF4E",298,0) ;" to bad records "RTN","TMGNDF4E",299,0) "RTN","TMGNDF4E",300,0) new RxSet set RxSet=$$GetOQVSet^TMGNDFUT "RTN","TMGNDF4E",301,0) if RxSet=0 goto C4BOQVDone "RTN","TMGNDF4E",302,0) new totalCt set totalCt=0 "RTN","TMGNDF4E",303,0) new count set count=0 "RTN","TMGNDF4E",304,0) "RTN","TMGNDF4E",305,0) new index set index=0 "RTN","TMGNDF4E",306,0) for set index=$order(^ORD(101.44,RxSet,20,index)) quit:(+index'>0) do "RTN","TMGNDF4E",307,0) . set totalCt=totalCt+1 "RTN","TMGNDF4E",308,0) . new s set s=$get(^ORD(101.44,RxSet,20,index,0)) "RTN","TMGNDF4E",309,0) . new ptr set ptr=+s "RTN","TMGNDF4E",310,0) . if ptr=0 quit "RTN","TMGNDF4E",311,0) . new name set name=$piece(s,"^",2) "RTN","TMGNDF4E",312,0) . if $piece($get(^ORD(101.43,ptr,0)),"^",1)'="" quit "RTN","TMGNDF4E",313,0) . write !,"BAD: ",name,! "RTN","TMGNDF4E",314,0) . write "OQV 101.44:#",index,",",RxSet,", --> OI 101.43:#",ptr," which is empty",! "RTN","TMGNDF4E",315,0) . do KillOQV^TMGNDFUT(index_","_RxSet_",") "RTN","TMGNDF4E",316,0) . write " ... deleted.",! "RTN","TMGNDF4E",317,0) . set count=count+1 "RTN","TMGNDF4E",318,0) "RTN","TMGNDF4E",319,0) write !,totalCt," entries scanned.",! "RTN","TMGNDF4E",320,0) write count," bad entries found.",! "RTN","TMGNDF4E",321,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4E",322,0) "RTN","TMGNDF4E",323,0) C4BOQVDone "RTN","TMGNDF4E",324,0) quit "RTN","TMGNDF4E",325,0) "RTN","TMGNDF4F") 0^58^B7817 "RTN","TMGNDF4F",1,0) TMGNDF4F ;TMG/kst/FDA Import -- Explore drugs linked to OQV ;03/25/06 "RTN","TMGNDF4F",2,0) ;;1.0;TMG-LIB;**1**;01/10/07 "RTN","TMGNDF4F",3,0) "RTN","TMGNDF4F",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4F",5,0) ;" Exploration of drugs linked to a selected ORDER QUICK VIEW "RTN","TMGNDF4F",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4F",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4F",8,0) ;"1-10-2007 "RTN","TMGNDF4F",9,0) "RTN","TMGNDF4F",10,0) ;"======================================================================= "RTN","TMGNDF4F",11,0) ;" API -- Public Functions. "RTN","TMGNDF4F",12,0) ;"======================================================================= "RTN","TMGNDF4F",13,0) ;"Menu "RTN","TMGNDF4F",14,0) ;"MenuOI(IEN101d43) -- Menu to explore ORDERABLE ITEM "RTN","TMGNDF4F",15,0) ;"MenuPOI(OIArray) -- Menu to explore PHARMACY ORDERABLE ITEM "RTN","TMGNDF4F",16,0) ;"MenuDrug(IEN50) -- Menu to explore DRUG item. "RTN","TMGNDF4F",17,0) ;"MenuFDA(FDA) -- Menu to explore TMG FDA IMPORT COMPILED "RTN","TMGNDF4F",18,0) "RTN","TMGNDF4F",19,0) ;"======================================================================= "RTN","TMGNDF4F",20,0) ;" Private Functions. "RTN","TMGNDF4F",21,0) ;"======================================================================= "RTN","TMGNDF4F",22,0) ;"GetAvail(IEN,Array,sigArray) -- explore the available doses for a given orderable item "RTN","TMGNDF4F",23,0) ;"MenuPickRx(IEN50Array,IEN50) -- allow user to pick which linked DRUG entry to explore "RTN","TMGNDF4F",24,0) ;"Show1Chain(IENOQV) -- show entire chain, as far back as possible "RTN","TMGNDF4F",25,0) ;"ShowAvail(IEN101d43) -- Show available drugs for a given ORDERABLE ITEM (101.43) "RTN","TMGNDF4F",26,0) ;"GetAvail(IEN101d43,Array,sigArray) -- explore the available doses for a given ORDERABLE ITEM (101.43) "RTN","TMGNDF4F",27,0) ;"$$AskOQV(NameOut) -- ask the user for a ORDER QUICK VIEW drug to view. "RTN","TMGNDF4F",28,0) ;"ShowComp(array) -- display all the drugs and sigs for a set of IEN's in 101.43 "RTN","TMGNDF4F",29,0) ;"DispOI(IEN101d43) -- display the relevent parts of the 101.43 (ORDERABLE ITEM) "RTN","TMGNDF4F",30,0) ;"DispPOI(IEN50d7) -- display the relevent parts of the 50.7 (PHARMACY ORDERABLE ITEM) "RTN","TMGNDF4F",31,0) ;"DispOQV(IENS) -- display the relevent parts of the 101.44 (ORDER QUICK VIEW) "RTN","TMGNDF4F",32,0) ;"DispRx(IEN50) -- display the relevent parts of the 50 (DRUG) "RTN","TMGNDF4F",33,0) ;"DispFDA(IEN) -- display the relevent parts of TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF4F",34,0) ;"ShowPIa(IEN101d43,RxSet) -- show all links from 101.44 --> 101.43 "RTN","TMGNDF4F",35,0) ;"PickOI(IENOQV) -- start from a ORDER QUICK VIEW record, and track backwards "RTN","TMGNDF4F",36,0) ;"DispDoses(IEN101d43) -- Display possible dosed for a ORDER QUICK VIEW record "RTN","TMGNDF4F",37,0) "RTN","TMGNDF4F",38,0) "RTN","TMGNDF4F",39,0) "RTN","TMGNDF4F",40,0) ;"======================================================================= "RTN","TMGNDF4F",41,0) Menu "RTN","TMGNDF4F",42,0) ;"Purpose: Menu for exploring 101.44 "RTN","TMGNDF4F",43,0) "RTN","TMGNDF4F",44,0) new RxSet "RTN","TMGNDF4F",45,0) set RxSet=$$GetOQVSet^TMGNDFUT() if RxSet'>0 goto MenuDone "RTN","TMGNDF4F",46,0) "RTN","TMGNDF4F",47,0) new IENS,IEN101d43,IENOQV,OQVName "RTN","TMGNDF4F",48,0) new Menu,UsrSlct,MenuNum "RTN","TMGNDF4F",49,0) "RTN","TMGNDF4F",50,0) M0 kill Menu "RTN","TMGNDF4F",51,0) set Menu(0)="Pick Option to explore ORDER QUICK VIEW (4F)" "RTN","TMGNDF4F",52,0) if $get(OQVName)'="" set Menu(0)=Menu(0)_": "_OQVName "RTN","TMGNDF4F",53,0) set MenuNum=1 "RTN","TMGNDF4F",54,0) if $data(IENOQV)=0 do "RTN","TMGNDF4F",55,0) . set Menu(MenuNum)="Pick ORDER QUICK VIEW"_$char(9)_"PickOQV",MenuNum=MenuNum+1 "RTN","TMGNDF4F",56,0) else do "RTN","TMGNDF4F",57,0) . set Menu(MenuNum)="Pick *NEW* ORDER QUICK VIEW"_$char(9)_"PickOQV",MenuNum=MenuNum+1 "RTN","TMGNDF4F",58,0) . set Menu(MenuNum)="Show current ORDER QUICK VIEW"_$char(9)_"ShowOQV",MenuNum=MenuNum+1 "RTN","TMGNDF4F",59,0) . set Menu(MenuNum)="Show OQV's linked to ORDERABLE ITEM: "_IENOQV("Linked 101.43","Name")_$char(9)_"ShowLinks",MenuNum=MenuNum+1 "RTN","TMGNDF4F",60,0) . set Menu(MenuNum)="Explore linked ORDERABLE ITEM"_$char(9)_"ExploreOI",MenuNum=MenuNum+1 "RTN","TMGNDF4F",61,0) . set Menu(MenuNum)="Show Dump of Doses for Current."_$char(9)_"DispOQV",MenuNum=MenuNum+1 "RTN","TMGNDF4F",62,0) . set Menu(MenuNum)="Show Chain of Linked Files & Entries."_$char(9)_"ShowChain",MenuNum=MenuNum+1 "RTN","TMGNDF4F",63,0) . set Menu(MenuNum)="Fix current ORDER QUICK VIEW"_$char(9)_"FixCurOQV",MenuNum=MenuNum+1 "RTN","TMGNDF4F",64,0) set Menu(MenuNum)="Fix Missing ORDER QUICK VIEW."_$char(9)_"FixMissing",MenuNum=MenuNum+1 "RTN","TMGNDF4F",65,0) set Menu("M")="Show data map"_$char(9)_"Map" "RTN","TMGNDF4F",66,0) set Menu("P")="Prev Stage"_$char(9)_"Prev" "RTN","TMGNDF4F",67,0) ;"set Menu("N")="Next Stage"_$char(9)_"Next" "RTN","TMGNDF4F",68,0) "RTN","TMGNDF4F",69,0) write # "RTN","TMGNDF4F",70,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",71,0) "RTN","TMGNDF4F",72,0) if UsrSlct="PickOQV" do goto M0 "RTN","TMGNDF4F",73,0) . kill OQVIEN "RTN","TMGNDF4F",74,0) . do PickOI(.IENOQV) "RTN","TMGNDF4F",75,0) . if $data(IENOQV)=0 quit "RTN","TMGNDF4F",76,0) . set OQVName=$$GET1^DIQ(101.442,IENOQV("IENS"),2) "RTN","TMGNDF4F",77,0) "RTN","TMGNDF4F",78,0) if UsrSlct="ShowOI" do DispOI(IENOQV("Linked 101.43")) goto M0 "RTN","TMGNDF4F",79,0) if UsrSlct="ShowOQV" do DispOQV(IENOQV("IENS")) goto M0 "RTN","TMGNDF4F",80,0) if UsrSlct="ShowLinks" do ShowPIa(IENOQV("Linked 101.43"),IENOQV(0)) goto M0 "RTN","TMGNDF4F",81,0) if UsrSlct="ExploreOI" do MenuOI(IENOQV("Linked 101.43")) goto M0 "RTN","TMGNDF4F",82,0) if UsrSlct="DispOQV" do DispDoses(IENOQV("Linked 101.43")) goto M0 "RTN","TMGNDF4F",83,0) if UsrSlct="ShowChain" do Show1Chain(.IENOQV) goto M0 "RTN","TMGNDF4F",84,0) if UsrSlct="FixMissing" do FixOQVMissing^TMGNDF4G goto M0 "RTN","TMGNDF4F",85,0) if UsrSlct="FixCurOQV" do FixCurOQV(.IENOQV) goto M0 "RTN","TMGNDF4F",86,0) if UsrSlct="Map" do goto M0 "RTN","TMGNDF4F",87,0) . write "ORDER QUICK VIEW (101.44) --> ORDERABLE ITEM (101.43)",! "RTN","TMGNDF4F",88,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",89,0) if UsrSlct="Prev" goto Menu^TMGNDF4E ;"quit can occur from there... "RTN","TMGNDF4F",90,0) ;"if UsrSlct="Next" goto Menu^TMGNDF2H ;"quit can occur from there... "RTN","TMGNDF4F",91,0) "RTN","TMGNDF4F",92,0) if UsrSlct="^" goto MenuDone "RTN","TMGNDF4F",93,0) goto M0 "RTN","TMGNDF4F",94,0) "RTN","TMGNDF4F",95,0) MenuDone "RTN","TMGNDF4F",96,0) quit "RTN","TMGNDF4F",97,0) "RTN","TMGNDF4F",98,0) MenuOI(IEN101d43) "RTN","TMGNDF4F",99,0) ;"Purpose: Menu to explore ORDERABLE ITEM "RTN","TMGNDF4F",100,0) "RTN","TMGNDF4F",101,0) new OIArray do GetOIInfo^TMGNDFUT(IEN101d43,.OIArray) "RTN","TMGNDF4F",102,0) new OIName set OIName=$get(OIArray("IEN 101.43","NAME")) "RTN","TMGNDF4F",103,0) if OIName="" goto MBDone "RTN","TMGNDF4F",104,0) "RTN","TMGNDF4F",105,0) new IEN50d7 set IEN50d7=$get(OIArray("IEN 50.7 from 101.43")) "RTN","TMGNDF4F",106,0) new POIName set POIName=$get(OIArray("IEN 50.7 from 101.43","NAME")) "RTN","TMGNDF4F",107,0) "RTN","TMGNDF4F",108,0) new Menu,UsrSlct "RTN","TMGNDF4F",109,0) set Menu(0)="Pick Option to explore ORDERABLE ITEM: "_OIName "RTN","TMGNDF4F",110,0) set Menu(1)="Show current ORDERABLE ITEM: "_OIName_$char(9)_"ShowOI" "RTN","TMGNDF4F",111,0) set Menu(2)="Explore linked PHARMACY ORDERABLE ITEM: "_POIName_$char(9)_"Explore" "RTN","TMGNDF4F",112,0) set Menu(3)="Show CPRS function of all avail doses"_$char(9)_"ShowAvail" "RTN","TMGNDF4F",113,0) set Menu(5)="Show Dump of Doses for Current."_$char(9)_"DispOI" "RTN","TMGNDF4F",114,0) set Menu("M")="Show data map"_$char(9)_"Map" "RTN","TMGNDF4F",115,0) "RTN","TMGNDF4F",116,0) MB1 write # "RTN","TMGNDF4F",117,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",118,0) "RTN","TMGNDF4F",119,0) if UsrSlct="ShowOI" do DispOI(IEN101d43) goto MB1 "RTN","TMGNDF4F",120,0) if UsrSlct="Explore" do MenuPOI(.OIArray) goto MB1 "RTN","TMGNDF4F",121,0) if UsrSlct="ShowAvail" do ShowAvail(IEN101d43) goto MPOI1 "RTN","TMGNDF4F",122,0) if UsrSlct="DispOI" do DispDoses(IEN101d43) goto MPOI1 "RTN","TMGNDF4F",123,0) "RTN","TMGNDF4F",124,0) if UsrSlct="Map" do goto MB1 "RTN","TMGNDF4F",125,0) . write "OQV (101.44) --> ORDERABLE ITEM (101.43) --> PHARMACY ORDERABLE ITEM (50.7)",! "RTN","TMGNDF4F",126,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",127,0) if UsrSlct="^" goto MBDone "RTN","TMGNDF4F",128,0) goto MB1 "RTN","TMGNDF4F",129,0) "RTN","TMGNDF4F",130,0) MBDone "RTN","TMGNDF4F",131,0) quit "RTN","TMGNDF4F",132,0) "RTN","TMGNDF4F",133,0) "RTN","TMGNDF4F",134,0) MenuPOI(Array) "RTN","TMGNDF4F",135,0) ;"Purpose: Menu to explore PHARMACY ORDERABLE ITEM "RTN","TMGNDF4F",136,0) ;"INPUT: Array -- PASS BY REFERENCE. Format: (as created by GetOIInfo^TMGNDFUT) "RTN","TMGNDF4F",137,0) ;" Array("IEN 50.7 from 101.43")=IEN50d7 "RTN","TMGNDF4F",138,0) ;" Array("IEN 50.7 from 101.43","NAME")=Name of 50.7, or "" if problem "RTN","TMGNDF4F",139,0) "RTN","TMGNDF4F",140,0) new IEN50d7 set IEN50d7=$get(Array("IEN 50.7 from 101.43")) "RTN","TMGNDF4F",141,0) new POIName set POIName=$get(Array("IEN 50.7 from 101.43","NAME")) "RTN","TMGNDF4F",142,0) if POIName="" set POIName=$$GET1^DIQ(50.7,IEN50d7_",",.01) "RTN","TMGNDF4F",143,0) "RTN","TMGNDF4F",144,0) new IEN50Array "RTN","TMGNDF4F",145,0) do GetDRUGs^TMGNDFUT(IEN50d7,.IEN50Array) "RTN","TMGNDF4F",146,0) new Menu,UsrSlct "RTN","TMGNDF4F",147,0) set Menu(0)="Pick Option to explore PHARMACY ORDERABLE ITEM: "_POIName "RTN","TMGNDF4F",148,0) set Menu(1)="Show current PHARMACY ORDERABLE ITEM: "_POIName_$char(9)_"ShowPOI" "RTN","TMGNDF4F",149,0) set Menu(2)="Explore a linked DRUG item"_$char(9)_"Explore" "RTN","TMGNDF4F",150,0) set Menu("M")="Show data map"_$char(9)_"Map" "RTN","TMGNDF4F",151,0) "RTN","TMGNDF4F",152,0) MPOI1 write # "RTN","TMGNDF4F",153,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",154,0) "RTN","TMGNDF4F",155,0) if UsrSlct="ShowPOI" do DispPOI(IEN50d7) goto MPOI1 "RTN","TMGNDF4F",156,0) if UsrSlct="Explore" do goto MB1 "RTN","TMGNDF4F",157,0) . new IEN50 "RTN","TMGNDF4F",158,0) . do MenuPickRx(.IEN50Array,.IEN50) "RTN","TMGNDF4F",159,0) . if $data(IEN50)=0 quit "RTN","TMGNDF4F",160,0) . do MenuDrug(.IEN50) "RTN","TMGNDF4F",161,0) if UsrSlct="Map" do goto MB1 "RTN","TMGNDF4F",162,0) . write "ORDERABLE ITEM (101.43) --> PHARMACY ORDERABLE ITEM (50.7) --> DRUG (50)",! "RTN","TMGNDF4F",163,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",164,0) "RTN","TMGNDF4F",165,0) if UsrSlct="^" goto MPOIDone "RTN","TMGNDF4F",166,0) goto MB1 "RTN","TMGNDF4F",167,0) "RTN","TMGNDF4F",168,0) MPOIDone "RTN","TMGNDF4F",169,0) quit "RTN","TMGNDF4F",170,0) "RTN","TMGNDF4F",171,0) "RTN","TMGNDF4F",172,0) MenuPickRx(IEN50Array,IEN50) "RTN","TMGNDF4F",173,0) ;"Purpose: To allow user to pick which linked DRUG entry to explore "RTN","TMGNDF4F",174,0) ;"Input: IEN50Array -- PASS BY REFERENCE, Format: "RTN","TMGNDF4F",175,0) ;" IEN50Array(IEN50)=Name (.01 field) of record "RTN","TMGNDF4F",176,0) ;" IEN50Array(IEN50)=Name (.01 field) of record "RTN","TMGNDF4F",177,0) "RTN","TMGNDF4F",178,0) ;" IEN50 -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF4F",179,0) ;" IEN50=IEN in 50 "RTN","TMGNDF4F",180,0) ;" IEN50("NAME")=Name of 50 -- OPTIONAL "RTN","TMGNDF4F",181,0) ;"Results: None "RTN","TMGNDF4F",182,0) "RTN","TMGNDF4F",183,0) new Menu,UsrSlct "RTN","TMGNDF4F",184,0) kill IEN50 "RTN","TMGNDF4F",185,0) set Menu(0)="Pick DRUG" "RTN","TMGNDF4F",186,0) new count set count=1 "RTN","TMGNDF4F",187,0) new name set name="" "RTN","TMGNDF4F",188,0) for set name=$order(IEN50Array(name)) quit:(name="") do "RTN","TMGNDF4F",189,0) . new IEN set IEN="" "RTN","TMGNDF4F",190,0) . for set IEN=$order(IEN50Array(name,IEN)) quit:(IEN="") do "RTN","TMGNDF4F",191,0) . . set Menu(count)=$get(name)_" #"_IEN_$char(9)_IEN "RTN","TMGNDF4F",192,0) . . set count=count+1 "RTN","TMGNDF4F",193,0) "RTN","TMGNDF4F",194,0) MPR1 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",195,0) "RTN","TMGNDF4F",196,0) if +UsrSlct=UsrSlct do goto MPRDone "RTN","TMGNDF4F",197,0) . set IEN50=+UsrSlct "RTN","TMGNDF4F",198,0) . set IEN50("NAME")=$get(IEN50Array(IEN50)) "RTN","TMGNDF4F",199,0) "RTN","TMGNDF4F",200,0) if UsrSlct="^" goto MPRDone "RTN","TMGNDF4F",201,0) goto MPR1 "RTN","TMGNDF4F",202,0) "RTN","TMGNDF4F",203,0) MPRDone "RTN","TMGNDF4F",204,0) quit "RTN","TMGNDF4F",205,0) "RTN","TMGNDF4F",206,0) "RTN","TMGNDF4F",207,0) MenuDrug(IEN50) "RTN","TMGNDF4F",208,0) ;"Purpose: Menu to explore DRUG item. "RTN","TMGNDF4F",209,0) ;"INPUT: IEN50 -- PASS BY REFERENCE. Format: "RTN","TMGNDF4F",210,0) ;" IEN50=IEN in 50 "RTN","TMGNDF4F",211,0) ;" IEN50("NAME")=Name of 50 -- OPTIONAL "RTN","TMGNDF4F",212,0) "RTN","TMGNDF4F",213,0) set IEN50("NAME")=$get(IEN50("NAME")) "RTN","TMGNDF4F",214,0) if IEN50("NAME")="" set IEN50("NAME")=$$GET1^DIQ(50,IEN50_",",.01) "RTN","TMGNDF4F",215,0) "RTN","TMGNDF4F",216,0) new FDA do GetFDA^TMGNDFUT(IEN50,.FDA) "RTN","TMGNDF4F",217,0) "RTN","TMGNDF4F",218,0) new Menu,UsrSlct "RTN","TMGNDF4F",219,0) set Menu(0)="Pick Option to explore DRUG: "_IEN50("NAME") "RTN","TMGNDF4F",220,0) set Menu(1)="Show current DRUG item: "_IEN50("NAME")_$char(9)_"ShowDRUG" "RTN","TMGNDF4F",221,0) set Menu(2)="Edit current DRUG item: "_IEN50("NAME")_$char(9)_"EditDRUG" "RTN","TMGNDF4F",222,0) set Menu(3)="Browse current DRUG item: "_IEN50("NAME")_$char(9)_"Browse" "RTN","TMGNDF4F",223,0) set Menu(4)="Explore linked FDA IMPORT: "_FDA("NAME")_$char(9)_"Explore1" "RTN","TMGNDF4F",224,0) set Menu("M")="Show data map"_$char(9)_"Map" "RTN","TMGNDF4F",225,0) ;"set Menu(2)="Explore linked PHARMACY ORDERABLE ITEM: "_POI("NAME")_$char(9)_"Explore" "RTN","TMGNDF4F",226,0) "RTN","TMGNDF4F",227,0) MRx1 write # "RTN","TMGNDF4F",228,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",229,0) "RTN","TMGNDF4F",230,0) if UsrSlct="ShowDRUG" do DispRx(IEN50) goto MRx1 "RTN","TMGNDF4F",231,0) if UsrSlct="EditDRUG" do Edit50^TMGNDFUT(IEN50) goto MRx1 "RTN","TMGNDF4F",232,0) if UsrSlct="Explore1" do MenuFDA(.FDA) goto MRx1 "RTN","TMGNDF4F",233,0) if UsrSlct="Browse" do Browse^TMGBROWS(50,IEN50,0) goto MRx1 "RTN","TMGNDF4F",234,0) if UsrSlct="Map" do goto MRx1 "RTN","TMGNDF4F",235,0) . write "POI (50.7) --> DRUG (50) --> VA PRODUCT (50.68)",! "RTN","TMGNDF4F",236,0) . write " --> TMG FDA IMPORT COMPILED (22706.9)",! "RTN","TMGNDF4F",237,0) . write " --> NATIONAL DRUG FILE ENTRY (50.6)",! "RTN","TMGNDF4F",238,0) . write " --> TMG FDA IMPORT COMPILED (22706.9)",! "RTN","TMGNDF4F",239,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",240,0) if UsrSlct="^" goto MRxDone "RTN","TMGNDF4F",241,0) goto MB1 "RTN","TMGNDF4F",242,0) "RTN","TMGNDF4F",243,0) MRxDone "RTN","TMGNDF4F",244,0) quit "RTN","TMGNDF4F",245,0) "RTN","TMGNDF4F",246,0) "RTN","TMGNDF4F",247,0) MenuFDA(FDA) "RTN","TMGNDF4F",248,0) ;"Purpose: Menu to explore TMG FDA IMPORT COMPILED "RTN","TMGNDF4F",249,0) ;"INPUT: FDA -- PASS BY REFERENCE. Format: "RTN","TMGNDF4F",250,0) ;" FDA=IEN in 22706.9 "RTN","TMGNDF4F",251,0) ;" FDA("NAME")=Name of 22706.9 "RTN","TMGNDF4F",252,0) "RTN","TMGNDF4F",253,0) new Menu,UsrSlct "RTN","TMGNDF4F",254,0) set Menu(0)="Pick Option to explore TMG FDA IMPORT COMPILED item." "RTN","TMGNDF4F",255,0) set Menu(1)="Show current FDA IMPORT item: "_FDA("NAME")_$char(9)_"ShowFDA" "RTN","TMGNDF4F",256,0) set Menu(2)="Browse current FDA IMPORT item: "_FDA("NAME")_$char(9)_"Browse" "RTN","TMGNDF4F",257,0) set Menu(3)="Explore a linked DRUG item"_$char(9)_"Explore" "RTN","TMGNDF4F",258,0) set Menu("M")="Show data map"_$char(9)_"Map" "RTN","TMGNDF4F",259,0) "RTN","TMGNDF4F",260,0) MF1 write # "RTN","TMGNDF4F",261,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",262,0) "RTN","TMGNDF4F",263,0) if UsrSlct="ShowFDA" do DispFDA(FDA) goto MF1 "RTN","TMGNDF4F",264,0) if UsrSlct="Browse" do Browse^TMGBROWS(22706.9,FDA,0) goto MF1 "RTN","TMGNDF4F",265,0) if UsrSlct="Map" do goto MF1 "RTN","TMGNDF4F",266,0) . write "DRUG (50) --> TMG FDA IMPORT COMPILED (22706.9)",! "RTN","TMGNDF4F",267,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",268,0) "RTN","TMGNDF4F",269,0) if UsrSlct="^" goto MFDone "RTN","TMGNDF4F",270,0) goto MB1 "RTN","TMGNDF4F",271,0) "RTN","TMGNDF4F",272,0) MFDone "RTN","TMGNDF4F",273,0) quit "RTN","TMGNDF4F",274,0) "RTN","TMGNDF4F",275,0) Show1Chain(IENOQV) "RTN","TMGNDF4F",276,0) ;"Purpose: To show entire chain, as far back as possible "RTN","TMGNDF4F",277,0) ;"Input: IENOQV -- PASS BY REFERENCE "RTN","TMGNDF4F",278,0) ;" IENOQV(0)=RxSet, i.e. the IEN in 101.44 containing ORWDSET O RX "RTN","TMGNDF4F",279,0) ;" IENOQV=IEN IN 101.442 "RTN","TMGNDF4F",280,0) ;" IENOQV("IENS")=IENS "RTN","TMGNDF4F",281,0) ;" IENOQV("Name")=Name of ORDER QUICK VIEW "RTN","TMGNDF4F",282,0) ;" IENOQV("Linked 101.43")=IEN of linked 101.43 "RTN","TMGNDF4F",283,0) ;" IENOQV("Linked 101.43","Name")=name "RTN","TMGNDF4F",284,0) "RTN","TMGNDF4F",285,0) ;"results: none. "RTN","TMGNDF4F",286,0) "RTN","TMGNDF4F",287,0) new IEN50Array,IEN101d43,indent,OIArray,POIName "RTN","TMGNDF4F",288,0) set indent=2 "RTN","TMGNDF4F",289,0) write "ORDER QUICK VIEW(101.44): ",IENOQV("Name")," #",IENOQV("IENS"),! "RTN","TMGNDF4F",290,0) set IEN101d43=IENOQV("Linked 101.43") "RTN","TMGNDF4F",291,0) write ?indent,"ORDERABLE ITEM(101.43): ",IENOQV("Linked 101.43","Name")," #",IEN101d43,! "RTN","TMGNDF4F",292,0) set indent=indent+5 "RTN","TMGNDF4F",293,0) do GetOIInfo^TMGNDFUT(IEN101d43,.OIArray) "RTN","TMGNDF4F",294,0) set IEN50d7=$get(OIArray("IEN 50.7 from 101.43")) "RTN","TMGNDF4F",295,0) set POIName=$get(OIArray("IEN 50.7 from 101.43","NAME")) "RTN","TMGNDF4F",296,0) write ?indent,"PHARMACY ORDERABLE ITEM(50.7): ",POIName," #",IEN50d7,! "RTN","TMGNDF4F",297,0) set indent=indent+5 "RTN","TMGNDF4F",298,0) do GetDRUGs^TMGNDFUT(IEN50d7,.IEN50Array) "RTN","TMGNDF4F",299,0) new IEN50,Name50 set IEN50="",Name50="" "RTN","TMGNDF4F",300,0) for set Name50=$order(IEN50Array(Name50)) quit:(Name50="") do "RTN","TMGNDF4F",301,0) . set IEN50=$order(IEN50Array(Name50,"")) "RTN","TMGNDF4F",302,0) . write ?indent,"DRUG(50): ",Name50," #",IEN50,! "RTN","TMGNDF4F",303,0) . new TMGIEN set TMGIEN="" "RTN","TMGNDF4F",304,0) . for set TMGIEN=$order(^TMG(22706.9,"DRUG",IEN50,TMGIEN)) quit:(TMGIEN="") do "RTN","TMGNDF4F",305,0) . . new TMGname set TMGname=$$GET1^DIQ(22706.9,TMGIEN_",",.04) "RTN","TMGNDF4F",306,0) . . if TMGname'="" write ?(indent+5),"TMG(22706.9): ",TMGname," #",TMGIEN,! "RTN","TMGNDF4F",307,0) . set TMGIEN="" "RTN","TMGNDF4F",308,0) . for set TMGIEN=$order(^TMG(22706.9,"DRUGT",IEN50,TMGIEN)) quit:(TMGIEN="") do "RTN","TMGNDF4F",309,0) . . new TMGname set TMGname=$$GET1^DIQ(22706.9,TMGIEN_",",.04) "RTN","TMGNDF4F",310,0) . . if TMGname'="" write ?(indent+5),"TMG(212706.9): ",TMGname," #",TMGIEN,! "RTN","TMGNDF4F",311,0) "RTN","TMGNDF4F",312,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",313,0) "RTN","TMGNDF4F",314,0) quit "RTN","TMGNDF4F",315,0) "RTN","TMGNDF4F",316,0) "RTN","TMGNDF4F",317,0) FixCurOQV(IENOQV) "RTN","TMGNDF4F",318,0) ;"Purpose: To Fix the current OQV "RTN","TMGNDF4F",319,0) ;"Input: IENOQV -- PASS BY REFERENCE "RTN","TMGNDF4F",320,0) ;" IENOQV(0)=RxSet, i.e. the IEN in 101.44 containing ORWDSET O RX "RTN","TMGNDF4F",321,0) ;" IENOQV=IEN IN 101.442 "RTN","TMGNDF4F",322,0) ;" IENOQV("IENS")=IENS "RTN","TMGNDF4F",323,0) ;" IENOQV("Name")=Name of ORDER QUICK VIEW "RTN","TMGNDF4F",324,0) ;" IENOQV("Linked 101.43")=IEN of linked 101.43 "RTN","TMGNDF4F",325,0) ;" IENOQV("Linked 101.43","Name")=name "RTN","TMGNDF4F",326,0) "RTN","TMGNDF4F",327,0) ;"results: none. "RTN","TMGNDF4F",328,0) "RTN","TMGNDF4F",329,0) new IEN50d7,IEN50Array,IEN101d43,chainA "RTN","TMGNDF4F",330,0) set IEN101d43=IENOQV("Linked 101.43") "RTN","TMGNDF4F",331,0) ;"set IEN50d7=$$GetPOI^TMGNDFUT(IEN101d43) <-- not working for some reason "RTN","TMGNDF4F",332,0) new OIArray "RTN","TMGNDF4F",333,0) do GetOIInfo^TMGNDFUT(IEN101d43,.OIArray) "RTN","TMGNDF4F",334,0) set IEN50d7=$get(OIArray("IEN 50.7 from 101.43")) "RTN","TMGNDF4F",335,0) new POIName set POIName=$get(OIArray("IEN 50.7 from 101.43","NAME")) "RTN","TMGNDF4F",336,0) do GetDRUGs^TMGNDFUT(IEN50d7,.IEN50Array) "RTN","TMGNDF4F",337,0) new IEN50,Name50 set IEN50="",Name50="" "RTN","TMGNDF4F",338,0) for set Name50=$order(IEN50Array(Name50)) quit:(Name50="") do "RTN","TMGNDF4F",339,0) . set IEN50=$order(IEN50Array(Name50,"")) "RTN","TMGNDF4F",340,0) . new TMGIEN set TMGIEN="" "RTN","TMGNDF4F",341,0) . for set TMGIEN=$order(^TMG(22706.9,"DRUG",IEN50,TMGIEN)) quit:(TMGIEN="") do "RTN","TMGNDF4F",342,0) . . new TMGname set TMGname=$$GET1^DIQ(22706.9,TMGIEN_",",.04) "RTN","TMGNDF4F",343,0) . . set chainA(TMGname,TMGIEN_"^22706.9")="" "RTN","TMGNDF4F",344,0) . set TMGIEN="" "RTN","TMGNDF4F",345,0) . for set TMGIEN=$order(^TMG(22706.9,"DRUGT",IEN50,TMGIEN)) quit:(TMGIEN="") do "RTN","TMGNDF4F",346,0) . . new TMGname set TMGname=$$GET1^DIQ(22706.9,TMGIEN_",",.04) "RTN","TMGNDF4F",347,0) . . set chainA(TMGname,TMGIEN_"^22706.9")="" "RTN","TMGNDF4F",348,0) "RTN","TMGNDF4F",349,0) if $data(chainA) do "RTN","TMGNDF4F",350,0) . do HandleChain^TMGNDF4G(.chainA) "RTN","TMGNDF4F",351,0) else do "RTN","TMGNDF4F",352,0) . write "Sorry, unable to locate sources in file 22706.9",! "RTN","TMGNDF4F",353,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",354,0) "RTN","TMGNDF4F",355,0) quit "RTN","TMGNDF4F",356,0) "RTN","TMGNDF4F",357,0) ShowAvail(IEN101d43) "RTN","TMGNDF4F",358,0) ;"Purpose: to Show available drugs for a given ORDERABLE ITEM (101.43), "RTN","TMGNDF4F",359,0) ;" As determined by RPC code used by CPRS "RTN","TMGNDF4F",360,0) ;"Input: IEN101d43 -- IEN in 101.43 "RTN","TMGNDF4F",361,0) ;"results: none. "RTN","TMGNDF4F",362,0) "RTN","TMGNDF4F",363,0) new i,DrugIEN "RTN","TMGNDF4F",364,0) new IEN,Y,DIC,drugsArray,sigArray "RTN","TMGNDF4F",365,0) "RTN","TMGNDF4F",366,0) kill drugsArray,sigArray "RTN","TMGNDF4F",367,0) do GetAvail(IEN101d43,.drugsArray,.sigArray) "RTN","TMGNDF4F",368,0) if $data(drugsArray)=0 do goto SAvDone "RTN","TMGNDF4F",369,0) . write "No Drugs to show!",! "RTN","TMGNDF4F",370,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",371,0) "RTN","TMGNDF4F",372,0) ;"write "Here are entries in DRUG file:",! "RTN","TMGNDF4F",373,0) ;"write "-------------------------------",! "RTN","TMGNDF4F",374,0) ;"new IEN set IEN="" "RTN","TMGNDF4F",375,0) ;"for set IEN=$order(drugsArray(IEN)) quit:(IEN="") do "RTN","TMGNDF4F",376,0) ;". write " #",IEN," in File #50: ",drugsArray(IEN),! "RTN","TMGNDF4F",377,0) ;"do PressToCont^TMGUSRIF "RTN","TMGNDF4F",378,0) "RTN","TMGNDF4F",379,0) write "Here are the different sigs:",! "RTN","TMGNDF4F",380,0) write "-------------------------------",! "RTN","TMGNDF4F",381,0) new netDose set netDose="" "RTN","TMGNDF4F",382,0) for set netDose=$order(sigArray(netDose)) quit:(netDose="") do "RTN","TMGNDF4F",383,0) . ;"write "Net Dose: ",netDose,! "RTN","TMGNDF4F",384,0) . new IEN set IEN="" "RTN","TMGNDF4F",385,0) . for set IEN=$order(sigArray(netDose,IEN)) quit:(IEN="") do "RTN","TMGNDF4F",386,0) . . new name set name="" "RTN","TMGNDF4F",387,0) . . for set name=$order(sigArray(netDose,IEN,name)) quit:(name="") do "RTN","TMGNDF4F",388,0) . . . ;"write " #",IEN,": ",name,! "RTN","TMGNDF4F",389,0) . . . new sig set sig="" "RTN","TMGNDF4F",390,0) . . . for set sig=$order(sigArray(netDose,IEN,name,sig)) quit:(sig="") do "RTN","TMGNDF4F",391,0) . . . . new mult set mult=$get(sigArray(netDose,IEN,name,sig)) "RTN","TMGNDF4F",392,0) . . . . write " ",sig,?30,"#",IEN,": ",name," --",mult,! "RTN","TMGNDF4F",393,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",394,0) SAvDone "RTN","TMGNDF4F",395,0) quit "RTN","TMGNDF4F",396,0) "RTN","TMGNDF4F",397,0) "RTN","TMGNDF4F",398,0) GetAvail(IEN101d43,Array,sigArray) "RTN","TMGNDF4F",399,0) ;"Purpose: To explore the available doses for a given ORDERABLE ITEM (101.43) "RTN","TMGNDF4F",400,0) ;"Input: IEN -- the record number for ORDERABLE ITEM (101.43) "RTN","TMGNDF4F",401,0) ;" Array -- pass by REFERENCE, an OUT PARAMETER "RTN","TMGNDF4F",402,0) ;" sigArray -- pass by REFERENCE, an OUT PARAMETER "RTN","TMGNDF4F",403,0) ;"Output: Array format: "RTN","TMGNDF4F",404,0) ;" Array(IEN in 50)=DrugName "RTN","TMGNDF4F",405,0) ;" Array(IEN in 50)=DrugName "RTN","TMGNDF4F",406,0) ;" sigArray format: "RTN","TMGNDF4F",407,0) ;" sigArray(NetDose,IEN in 50,DrugName,sig)=multiplier "RTN","TMGNDF4F",408,0) ;"Result: None "RTN","TMGNDF4F",409,0) "RTN","TMGNDF4F",410,0) new temp,IENs,IENs2 "RTN","TMGNDF4F",411,0) do OISLCT^ORWDPS2(.temp,IEN101d43,0,1,"Y","Y") "RTN","TMGNDF4F",412,0) new i set i="" "RTN","TMGNDF4F",413,0) for set i=$order(temp(i)) quit:(i="")!($get(temp(i))="~Dispense") "RTN","TMGNDF4F",414,0) if i'="" for set i=$order(temp(i)) quit:(i="")!($extract($get(temp(i)),1)="~") do "RTN","TMGNDF4F",415,0) . new s set s=$piece($get(temp(i)),"^",1) "RTN","TMGNDF4F",416,0) . new IEN set IEN=+$extract(s,2,999) "RTN","TMGNDF4F",417,0) . set Array(IEN)=$piece($get(temp(i)),"^",4) "RTN","TMGNDF4F",418,0) "RTN","TMGNDF4F",419,0) set i="" "RTN","TMGNDF4F",420,0) for set i=$order(temp(i)) quit:(i="")!($get(temp(i))="~Dosage") "RTN","TMGNDF4F",421,0) if i'="" for set i=$order(temp(i)) quit:(i="")!($extract($get(temp(i)),1)="~") do "RTN","TMGNDF4F",422,0) . new s set s=$piece($get(temp(i)),"^",4) "RTN","TMGNDF4F",423,0) . new IEN set IEN=+$piece(s,"&",6) "RTN","TMGNDF4F",424,0) . new netDose set netDose=+$piece(s,"&",5) "RTN","TMGNDF4F",425,0) . new drug set drug=$extract($piece($get(temp(i)),"^",1),2,999) "RTN","TMGNDF4F",426,0) . new sig set sig=$piece($get(temp(i)),"^",5) "RTN","TMGNDF4F",427,0) . new mult set mult=$piece(s,"&",3) "RTN","TMGNDF4F",428,0) . set sigArray(netDose,IEN,drug,sig)=mult "RTN","TMGNDF4F",429,0) "RTN","TMGNDF4F",430,0) quit "RTN","TMGNDF4F",431,0) "RTN","TMGNDF4F",432,0) "RTN","TMGNDF4F",433,0) AskOQV(NameOut) "RTN","TMGNDF4F",434,0) ;"Purpose: To ask the user for a ORDER QUICK VIEW drug to view. "RTN","TMGNDF4F",435,0) ;" Note: this is actually a query in the subfile #101.442 "RTN","TMGNDF4F",436,0) ;"Input: NameOut -- PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGNDF4F",437,0) ;" returns the name of the ORDER QUICK VIEW selected "RTN","TMGNDF4F",438,0) ;"Result: an IENS that can be used to get record, or "" if unsuccessful "RTN","TMGNDF4F",439,0) ;" e.g. set Value=$$GET1^DIQ(101.442,IENS,.01) "RTN","TMGNDF4F",440,0) "RTN","TMGNDF4F",441,0) new DIC,X,Y,RxSet,DA "RTN","TMGNDF4F",442,0) new result set result="" "RTN","TMGNDF4F",443,0) set NameOut="" "RTN","TMGNDF4F",444,0) "RTN","TMGNDF4F",445,0) set RxSet=$$GetOQVSet^TMGNDFUT() if RxSet'>0 goto AOQVDone "RTN","TMGNDF4F",446,0) "RTN","TMGNDF4F",447,0) if $data(^ORD(101.44,RxSet,20,"B"))=0 do "RTN","TMGNDF4F",448,0) . ;"Put code here to reindex "B" index (.01 field of field 20) "RTN","TMGNDF4F",449,0) "RTN","TMGNDF4F",450,0) new RxName,TMGDATA,TMGERR "RTN","TMGNDF4F",451,0) read "DRUG NAME (May be partial name): ",RxName:$get(DTIME,3600),! "RTN","TMGNDF4F",452,0) "RTN","TMGNDF4F",453,0) do FIND^DIC(101.442,","_RxSet_",","","M",RxName,"*","B","","","TMGDATA","TMGERR") "RTN","TMGNDF4F",454,0) if +$get(TMGDATA("DILIST",0))>0 do "RTN","TMGNDF4F",455,0) AOQV1 . new found,j,IEN,IEN101d43,Menu,Num,Link,UsrSlct "RTN","TMGNDF4F",456,0) . set Menu(0)="Pick Drug",Num=1 "RTN","TMGNDF4F",457,0) . set j=0 for set j=+$order(TMGDATA("DILIST",2,j)) quit:(j=0) do "RTN","TMGNDF4F",458,0) . . set IEN=$get(TMGDATA("DILIST",2,j)) "RTN","TMGNDF4F",459,0) . . set IEN101d43=$get(TMGDATA("DILIST",1,j)) "RTN","TMGNDF4F",460,0) . . if $data(found(IEN101d43))>0 quit "RTN","TMGNDF4F",461,0) . . set found(IEN101d43)=1 "RTN","TMGNDF4F",462,0) . . set Menu(Num)=$$GET1^DIQ(101.442,IEN_","_RxSet_",",".01")_" --> "_$$GET1^DIQ(101.43,IEN101d43_",",".01")_" #"_IEN101d43 "RTN","TMGNDF4F",463,0) . . set Link(Num)=IEN "RTN","TMGNDF4F",464,0) . . set Num=Num+1 "RTN","TMGNDF4F",465,0) . if Num>2 do "RTN","TMGNDF4F",466,0) . . set Menu(Num)="Compare Drugs and Sigs above."_$char(9)_"COMPARE" "RTN","TMGNDF4F",467,0) . write # "RTN","TMGNDF4F",468,0) . set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") "RTN","TMGNDF4F",469,0) . if UsrSlct="COMPARE" do goto AOQV1 "RTN","TMGNDF4F",470,0) . . do ShowComp(.found) "RTN","TMGNDF4F",471,0) . set result=$get(Link(UsrSlct),-1) "RTN","TMGNDF4F",472,0) . if result>0 set result=result_","_RxSet_"," "RTN","TMGNDF4F",473,0) else do goto:(Y'>-1) AOQVDone "RTN","TMGNDF4F",474,0) . set DA(1)=RxSet "RTN","TMGNDF4F",475,0) . set DIC(0)="MAEQ" "RTN","TMGNDF4F",476,0) . set DIC("A")="Please enter drug name again: ^//" "RTN","TMGNDF4F",477,0) . set DIC="^ORD(101.44,"_DA(1)_",20," "RTN","TMGNDF4F",478,0) . do ^DIC write ! "RTN","TMGNDF4F",479,0) . if Y'>-1 quit "RTN","TMGNDF4F",480,0) . set result=+Y_","_DA(1)_"," "RTN","TMGNDF4F",481,0) "RTN","TMGNDF4F",482,0) AOQVDone "RTN","TMGNDF4F",483,0) if result'="" set NameOut=$$GET1^DIQ(101.442,result,.01) "RTN","TMGNDF4F",484,0) quit result "RTN","TMGNDF4F",485,0) "RTN","TMGNDF4F",486,0) ShowComp(array) "RTN","TMGNDF4F",487,0) ;"Purpose: to display all the drugs and sigs for a set of IEN's in 101.43 "RTN","TMGNDF4F",488,0) ;"Input: array: PASS BY REFERENCE. Format: "RTN","TMGNDF4F",489,0) ;" array(IEN)="" "RTN","TMGNDF4F",490,0) ;" array(IEN)="" "RTN","TMGNDF4F",491,0) ;" array(IEN)="" "RTN","TMGNDF4F",492,0) ;"Output: Will dump out data for all IEN's in list "RTN","TMGNDF4F",493,0) "RTN","TMGNDF4F",494,0) new IEN101d43 "RTN","TMGNDF4F",495,0) set IEN101d43="" for set IEN101d43=$order(array(IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDF4F",496,0) . do ShowAvail(IEN101d43) "RTN","TMGNDF4F",497,0) quit "RTN","TMGNDF4F",498,0) "RTN","TMGNDF4F",499,0) "RTN","TMGNDF4F",500,0) DispOI(IEN101d43) "RTN","TMGNDF4F",501,0) ;"Purpose: To display the relevent parts of the 101.43 (ORDERABLE ITEM) "RTN","TMGNDF4F",502,0) ;" to allow debug tracing. "RTN","TMGNDF4F",503,0) ;"Input: IEN101d43 -- the IEN in file 101.43 "RTN","TMGNDF4F",504,0) ;"Results: none "RTN","TMGNDF4F",505,0) "RTN","TMGNDF4F",506,0) new Fields "RTN","TMGNDF4F",507,0) set Fields(.01)="" ;".01 NAME "RTN","TMGNDF4F",508,0) set Fields(.1)="" ;"1 INACTIVATED "RTN","TMGNDF4F",509,0) set Fields(1)="" ;"1 SYNONYMS "RTN","TMGNDF4F",510,0) set Fields(1.1)="" ;"1.1 PACKAGE NAME "RTN","TMGNDF4F",511,0) set Fields(2)="" ;"2 ID "RTN","TMGNDF4F",512,0) "RTN","TMGNDF4F",513,0) write "File: ORDERABLE ITEM (101.43) " "RTN","TMGNDF4F",514,0) do DumpRec2^TMGDEBUG(101.43,IEN101d43,1,.Fields) "RTN","TMGNDF4F",515,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",516,0) "RTN","TMGNDF4F",517,0) quit "RTN","TMGNDF4F",518,0) "RTN","TMGNDF4F",519,0) "RTN","TMGNDF4F",520,0) DispPOI(IEN50d7) "RTN","TMGNDF4F",521,0) ;"Purpose: To display the relevent parts of the 50.7 (PHARMACY ORDERABLE ITEM) "RTN","TMGNDF4F",522,0) ;" to allow debug tracing. "RTN","TMGNDF4F",523,0) ;"Input: IEN50d7 -- the IEN in file 50d7 "RTN","TMGNDF4F",524,0) ;"Results: none "RTN","TMGNDF4F",525,0) "RTN","TMGNDF4F",526,0) write "File: PHARMACY ORDERABLE ITEM (50.7) " "RTN","TMGNDF4F",527,0) do DumpRec2^TMGDEBUG(50.7,IEN50d7,1) "RTN","TMGNDF4F",528,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",529,0) "RTN","TMGNDF4F",530,0) quit "RTN","TMGNDF4F",531,0) "RTN","TMGNDF4F",532,0) "RTN","TMGNDF4F",533,0) DispOQV(IENS) "RTN","TMGNDF4F",534,0) ;"Purpose: To display the relevent parts of the 101.44 (ORDER QUICK VIEW) "RTN","TMGNDF4F",535,0) ;" to allow debug tracing. "RTN","TMGNDF4F",536,0) ;"Input: IENS -- the IENS to display 101.442, e.g. "1000,23" "RTN","TMGNDF4F",537,0) ;"Results: none "RTN","TMGNDF4F",538,0) "RTN","TMGNDF4F",539,0) write "File: in ORDER QUICK VIEW (101.442) " "RTN","TMGNDF4F",540,0) do DumpRec2^TMGDEBUG(101.442,IENS,1,) "RTN","TMGNDF4F",541,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",542,0) "RTN","TMGNDF4F",543,0) quit "RTN","TMGNDF4F",544,0) "RTN","TMGNDF4F",545,0) DispRx(IEN50) "RTN","TMGNDF4F",546,0) ;"Purpose: To display the relevent parts of the 50 (DRUG) "RTN","TMGNDF4F",547,0) ;" to allow debug tracing. "RTN","TMGNDF4F",548,0) ;"Input: IEN50 -- the IEN to display in 50 "RTN","TMGNDF4F",549,0) ;"Results: none "RTN","TMGNDF4F",550,0) "RTN","TMGNDF4F",551,0) write "File: in DRUG (50) " "RTN","TMGNDF4F",552,0) do DumpRec2^TMGDEBUG(50,IEN50_",",0) "RTN","TMGNDF4F",553,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",554,0) "RTN","TMGNDF4F",555,0) quit "RTN","TMGNDF4F",556,0) "RTN","TMGNDF4F",557,0) "RTN","TMGNDF4F",558,0) DispFDA(IEN) "RTN","TMGNDF4F",559,0) ;"Purpose: To display the relevent parts of TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF4F",560,0) ;" to allow debug tracing. "RTN","TMGNDF4F",561,0) ;"Input: IEN -- the IEN to display in 22706.9 "RTN","TMGNDF4F",562,0) ;"Results: none "RTN","TMGNDF4F",563,0) "RTN","TMGNDF4F",564,0) write "File: in TMG FDA IMPORT COMPILED (22706.9) " "RTN","TMGNDF4F",565,0) do DumpRec2^TMGDEBUG(22706.9,IEN_",",0) "RTN","TMGNDF4F",566,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",567,0) "RTN","TMGNDF4F",568,0) quit "RTN","TMGNDF4F",569,0) "RTN","TMGNDF4F",570,0) "RTN","TMGNDF4F",571,0) ShowPIa(IEN101d43,RxSet) "RTN","TMGNDF4F",572,0) ;"Purpose: To show all links from 101.44 --> 101.43 "RTN","TMGNDF4F",573,0) ;"Input: IEN101d43 -- the IEN from 101d43 "RTN","TMGNDF4F",574,0) ;" RxSet -the IEN in 101.44 containing ORWDSET O RX "RTN","TMGNDF4F",575,0) ;"Results: none "RTN","TMGNDF4F",576,0) "RTN","TMGNDF4F",577,0) new OQVIndex "RTN","TMGNDF4F",578,0) do Index101d44^TMGNDFUT(RxSet,"OQVIndex") "RTN","TMGNDF4F",579,0) "RTN","TMGNDF4F",580,0) new IENOQV set IENOQV="" "RTN","TMGNDF4F",581,0) new someShown set someShown=0 "RTN","TMGNDF4F",582,0) new pauseCount set pauseCount=0 "RTN","TMGNDF4F",583,0) write "Here are all the entries in ORDER QUICK VIEW that point to",! "RTN","TMGNDF4F",584,0) write "ORDERABLE ITEM: ",$$GET1^DIQ(101.43,IEN101d43_",",.01),! "RTN","TMGNDF4F",585,0) write " <--- (IEN in ORDER QUICK VIEW) NAME",! "RTN","TMGNDF4F",586,0) for set IENOQV=$order(OQVIndex(IEN101d43,IENOQV)) quit:(IENOQV'>0) do "RTN","TMGNDF4F",587,0) . write " <--- (#",IENOQV,") " "RTN","TMGNDF4F",588,0) . write $$GET1^DIQ(101.442,IENOQV_","_RxSet_",",2),! "RTN","TMGNDF4F",589,0) . set someShown=1 "RTN","TMGNDF4F",590,0) . set pauseCount=pauseCount+1 "RTN","TMGNDF4F",591,0) . if pauseCount<10 quit "RTN","TMGNDF4F",592,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4F",593,0) . set pauseCount=0 "RTN","TMGNDF4F",594,0) if someShown=0 write " (None)",! "RTN","TMGNDF4F",595,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",596,0) "RTN","TMGNDF4F",597,0) quit "RTN","TMGNDF4F",598,0) "RTN","TMGNDF4F",599,0) "RTN","TMGNDF4F",600,0) PickOI(IENOQV) "RTN","TMGNDF4F",601,0) ;"Purpose: To start from a ORDER QUICK VIEW record, and track backwards "RTN","TMGNDF4F",602,0) ;"Input: IENOQV -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF4F",603,0) ;" IENOQV(0)=RxSet, i.e. the IEN in 101.44 containing ORWDSET O RX "RTN","TMGNDF4F",604,0) ;" IENOQV=IEN IN 101.442 "RTN","TMGNDF4F",605,0) ;" IENOQV("IENS")=IENS "RTN","TMGNDF4F",606,0) ;" IENOQV("Name")=Name of ORDER QUICK VIEW "RTN","TMGNDF4F",607,0) ;" IENOQV("Linked 101.43")=IEN of linked 101.43 "RTN","TMGNDF4F",608,0) ;" IENOQV("Linked 101.43","Name")=name "RTN","TMGNDF4F",609,0) ;"Result: none. "RTN","TMGNDF4F",610,0) "RTN","TMGNDF4F",611,0) new IENS,IEN101d43,OQVName "RTN","TMGNDF4F",612,0) set IENS=$$AskOQV(.OQVName) if IENS="" goto POIDone "RTN","TMGNDF4F",613,0) ;"write "ORDER QUICK VIEW (",IENS,") --> ORDERABLE ITEM ",! "RTN","TMGNDF4F",614,0) set IEN101d43=$$GET1^DIQ(101.442,IENS,.01,"I") "RTN","TMGNDF4F",615,0) set IENOQV=$piece(IENS,",",1) "RTN","TMGNDF4F",616,0) set IENOQV(0)=$piece(IENS,",",2) "RTN","TMGNDF4F",617,0) set IENOQV("IENS")=IENS "RTN","TMGNDF4F",618,0) set IENOQV("Name")=OQVName "RTN","TMGNDF4F",619,0) set IENOQV("Linked 101.43")=IEN101d43 "RTN","TMGNDF4F",620,0) set IENOQV("Linked 101.43","Name")=$$GET1^DIQ(101.43,IEN101d43_",",.01) "RTN","TMGNDF4F",621,0) "RTN","TMGNDF4F",622,0) POIDone "RTN","TMGNDF4F",623,0) quit "RTN","TMGNDF4F",624,0) "RTN","TMGNDF4F",625,0) DispDoses(IEN101d43) "RTN","TMGNDF4F",626,0) ;"Purpose: To Display possible dosed for a ORDER QUICK VIEW record "RTN","TMGNDF4F",627,0) ;"Input: IEN101d43 -- IEN in 101.43 "RTN","TMGNDF4F",628,0) ;"Output: displays possible doses "RTN","TMGNDF4F",629,0) ;"Result: none. "RTN","TMGNDF4F",630,0) "RTN","TMGNDF4F",631,0) new array "RTN","TMGNDF4F",632,0) do OISLCT^ORWDPS2(.array,IEN101d43,"O",0,"Y","N") "RTN","TMGNDF4F",633,0) do ArrayDump^TMGDEBUG("array") "RTN","TMGNDF4F",634,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4F",635,0) "RTN","TMGNDF4F",636,0) quit "RTN","TMGNDF4F",637,0) "RTN","TMGNDF4F",638,0) "RTN","TMGNDF4G") 0^59^B6258 "RTN","TMGNDF4G",1,0) TMGNDF4G ;TMG/kst/FDA Import -- Fix OQV Problems;10/15/07 "RTN","TMGNDF4G",2,0) ;;1.0;TMG-LIB;**1**;10/15/07 "RTN","TMGNDF4G",3,0) "RTN","TMGNDF4G",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDF4G",5,0) ;" Fixing problems with ORDER QUICK VIEW "RTN","TMGNDF4G",6,0) ;"Kevin Toppenberg MD "RTN","TMGNDF4G",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDF4G",8,0) ;"10-15-2007 "RTN","TMGNDF4G",9,0) "RTN","TMGNDF4G",10,0) ;"======================================================================= "RTN","TMGNDF4G",11,0) ;" API -- Public Functions. "RTN","TMGNDF4G",12,0) ;"======================================================================= "RTN","TMGNDF4G",13,0) ;"(No menu -- called from ^TMGNDF4F) "RTN","TMGNDF4G",14,0) ;"AskFix1TMG -- ask user for entry in 22706.9 and allow editing. "RTN","TMGNDF4G",15,0) ;"======================================================================= "RTN","TMGNDF4G",16,0) "RTN","TMGNDF4G",17,0) ;"======================================================================= "RTN","TMGNDF4G",18,0) ;" Private Functions. "RTN","TMGNDF4G",19,0) ;"======================================================================= "RTN","TMGNDF4G",20,0) ;"FixOQVMissing -- fix a missing ORDER QUICK VIEW. "RTN","TMGNDF4G",21,0) ;"FindOQV(Prefix,RxName,RxSet,SrchRec) -- Search ORDER QUICk VIEW for RxName, and return if found "RTN","TMGNDF4G",22,0) ;"FindTMG(Prefix,RxName,RxSet,SrchRec,IgnoreSkipped) -- Scan 22706.9 for RxName, and return if found "RTN","TMGNDF4G",23,0) ;"DoFind(Prefix,RxName,FileNum,Field,SrchRec,index) -- Scam file for RxName, and return if found "RTN","TMGNDF4G",24,0) ;"HandleChain(array) -- Show chain and alow user editing etc. from input entry towards final part of chain (Order Quick View) "RTN","TMGNDF4G",25,0) ;"HandleOne(IEN10144,IEN10143,IEN50d7,IEN50,IEN22706d9,GorT) -- show the user a drug chain and allow manipulation of it "RTN","TMGNDF4G",26,0) ;"Hndl22706d9(IEN,RxSet,OutArray,array1,GorT) -- A brief subroutine to format 22706.9 input "RTN","TMGNDF4G",27,0) ;"Fmt101d43(IEN,RxSet) -- add an entry from file 101.43 to output string "RTN","TMGNDF4G",28,0) ;"Fmt50d7(IEN,RxSet) -- add an entry from file 50.7 to output string "RTN","TMGNDF4G",29,0) ;"Fmt50(IEN,RxSet) -- add an entry from file 50 to output string "RTN","TMGNDF4G",30,0) ;"Fmt22706d9(IEN,RxSet,s) -- add an entry from file 22706.9 to output string "RTN","TMGNDF4G",31,0) ;"EditTMG(IEN) -- to edit the TMG entry in 22706.9 "RTN","TMGNDF4G",32,0) ;"FullEDTMG(IEN) -- allow editing of any field in TMG 22706.9 "RTN","TMGNDF4G",33,0) "RTN","TMGNDF4G",34,0) ;"======================================================================= "RTN","TMGNDF4G",35,0) "RTN","TMGNDF4G",36,0) FixOQVMissing "RTN","TMGNDF4G",37,0) ;"Purpose: to fix a missing ORDER QUICK VIEW. I.e. add entry and "RTN","TMGNDF4G",38,0) ;" and interviening entries needed. "RTN","TMGNDF4G",39,0) ;"Input: none. "RTN","TMGNDF4G",40,0) "RTN","TMGNDF4G",41,0) new RxSet "RTN","TMGNDF4G",42,0) set RxSet=$$GetOQVSet^TMGNDFUT() if RxSet'>0 goto FOQVDone "RTN","TMGNDF4G",43,0) "RTN","TMGNDF4G",44,0) new RxName,SrchRec "RTN","TMGNDF4G",45,0) read "Enter DRUG NAME to FIND/ADD (may be partial name): ",RxName:$get(DTIME,3600),! "RTN","TMGNDF4G",46,0) if (RxName="")!(RxName="^") goto FOQVDone "RTN","TMGNDF4G",47,0) "RTN","TMGNDF4G",48,0) ;"do FindOQV("A. (101.44): ",RxName,RxSet,.SrchRec) ;"ORDER QUICK VIEW "RTN","TMGNDF4G",49,0) ;"do DoFind("B. (101.43): ",RxName,101.43,.01,.SrchRec,"B") ;"ORDERABLE ITEM "RTN","TMGNDF4G",50,0) ;"do DoFind("C. (50.7): ",RxName,50.7,.01,.SrchRec,"B") ;"PHARMACY ORDERABLE ITEM "RTN","TMGNDF4G",51,0) ;"do DoFind("D. (50): ",RxName,50,.01,.SrchRec,"B") ;"DRUG file "RTN","TMGNDF4G",52,0) ;"do DoFind("E. (22706.9): ",RxName,22706.9,.04,.SrchRec,"LN^C") ;"TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF4G",53,0) ;"do DoFind("",RxName,22706.9,.04,.SrchRec,"B^C^D^E^LN") ;"TMG FDA IMPORT COMPILED (22706.9) "RTN","TMGNDF4G",54,0) "RTN","TMGNDF4G",55,0) new % set %=1 "RTN","TMGNDF4G",56,0) write "Ignore drugs marked to be SKIPPED" "RTN","TMGNDF4G",57,0) do YN^DICN write ! "RTN","TMGNDF4G",58,0) if %=-1 goto FOQVDone "RTN","TMGNDF4G",59,0) do FindTMG("",RxName,RxSet,.SrchRec,(%=1)) "RTN","TMGNDF4G",60,0) "RTN","TMGNDF4G",61,0) write !,"Next, select one or more drugs that are ",! "RTN","TMGNDF4G",62,0) write "examples of a drug that is missing.",! "RTN","TMGNDF4G",63,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4G",64,0) "RTN","TMGNDF4G",65,0) new Results "RTN","TMGNDF4G",66,0) do Slctor2^TMGUSRIF("SrchRec","Results","Pick Example(s) of Missing Drugs. [ESC][ESC] when done.") "RTN","TMGNDF4G",67,0) "RTN","TMGNDF4G",68,0) set %=1 "RTN","TMGNDF4G",69,0) write "Automatically Refreshing Selected Before Editing" "RTN","TMGNDF4G",70,0) do YN^DICN write ! "RTN","TMGNDF4G",71,0) if %=-1 goto FOQVDone "RTN","TMGNDF4G",72,0) if %=1 do RefreshChain(.Results) "RTN","TMGNDF4G",73,0) "RTN","TMGNDF4G",74,0) do HandleChain(.Results) ;"Show forward array "RTN","TMGNDF4G",75,0) "RTN","TMGNDF4G",76,0) write "Done.",! "RTN","TMGNDF4G",77,0) do PressToCont^TMGUSRIF "RTN","TMGNDF4G",78,0) "RTN","TMGNDF4G",79,0) FOQVDone "RTN","TMGNDF4G",80,0) quit "RTN","TMGNDF4G",81,0) "RTN","TMGNDF4G",82,0) "RTN","TMGNDF4G",83,0) AskFix1TMG "RTN","TMGNDF4G",84,0) ;"Purpose: ask user for entry in 22706.9 and allow editing. "RTN","TMGNDF4G",85,0) "RTN","TMGNDF4G",86,0) new DIC,X,Y,IEN22706d9 "RTN","TMGNDF4G",87,0) "RTN","TMGNDF4G",88,0) set DIC=22706.9,DIC(0)="MAEQ" "RTN","TMGNDF4G",89,0) do ^DIC "RTN","TMGNDF4G",90,0) if +Y>0 do "RTN","TMGNDF4G",91,0) . new array "RTN","TMGNDF4G",92,0) . set array($piece(Y,"^",2),+Y_"^22706.9")="" "RTN","TMGNDF4G",93,0) . do HandleChain(.array) "RTN","TMGNDF4G",94,0) "RTN","TMGNDF4G",95,0) quit "RTN","TMGNDF4G",96,0) "RTN","TMGNDF4G",97,0) "RTN","TMGNDF4G",98,0) FindOQV(Prefix,RxName,RxSet,SrchRec) "RTN","TMGNDF4G",99,0) ;"Purpose: look through ORDER QUICk VIEW for RxName, and return if found "RTN","TMGNDF4G",100,0) ;"Input: Prefix -- a string to prefix name with in index. "RTN","TMGNDF4G",101,0) ;" RxName -- the string of the Rx name to look for (may be a partial name) "RTN","TMGNDF4G",102,0) ;" RxSet -- IEN of 'ORWDSET O RX' in 101.44 "RTN","TMGNDF4G",103,0) ;" SrchRec -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF4G",104,0) ;" SrchRec(NameFound)=IEN^File# "RTN","TMGNDF4G",105,0) ;" SrchRec(NameFound)=IEN^File# "RTN","TMGNDF4G",106,0) ;"Output: SrchRec is filled. "RTN","TMGNDF4G",107,0) ;"Result: none "RTN","TMGNDF4G",108,0) "RTN","TMGNDF4G",109,0) new TMGDATA,TMGERR "RTN","TMGNDF4G",110,0) do FIND^DIC(101.442,","_RxSet_",","","M",RxName,"*","B","","","TMGDATA","TMGERR") "RTN","TMGNDF4G",111,0) "RTN","TMGNDF4G",112,0) if +$get(TMGDATA("DILIST",0))>0 do "RTN","TMGNDF4G",113,0) . new j,IEN,Name "RTN","TMGNDF4G",114,0) . set j=0 for set j=+$order(TMGDATA("DILIST",2,j)) quit:(j=0) do "RTN","TMGNDF4G",115,0) . . set IEN=$get(TMGDATA("DILIST",2,j)) "RTN","TMGNDF4G",116,0) . . set name=Prefix_$$GET1^DIQ(101.442,IEN_","_RxSet_",",".01") "RTN","TMGNDF4G",117,0) . . set SrchRec(name,IEN_","_RxSet_",^101.442")="" "RTN","TMGNDF4G",118,0) "RTN","TMGNDF4G",119,0) quit "RTN","TMGNDF4G",120,0) "RTN","TMGNDF4G",121,0) "RTN","TMGNDF4G",122,0) FindTMG(Prefix,RxName,RxSet,SrchRec,IgnoreSkipped) "RTN","TMGNDF4G",123,0) ;"Purpose: look through 22706.9 for RxName, and return if found "RTN","TMGNDF4G",124,0) ;"Input: Prefix -- a string to prefix name with in index. "RTN","TMGNDF4G",125,0) ;" RxName -- the string of the Rx name to look for (may be a partial name) "RTN","TMGNDF4G",126,0) ;" RxSet -- IEN of 'ORWDSET O RX' in 101.44 "RTN","TMGNDF4G",127,0) ;" SrchRec -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF4G",128,0) ;" SrchRec(NameFound,IEN^File#)="" "RTN","TMGNDF4G",129,0) ;" SrchRec(NameFound,IEN^File#)="" "RTN","TMGNDF4G",130,0) ;" IgnoreSkipped -- if 1 then only show drugs not marked to be SKIPPED "RTN","TMGNDF4G",131,0) ;"Output: SrchRec is filled. "RTN","TMGNDF4G",132,0) ;"Result: none "RTN","TMGNDF4G",133,0) "RTN","TMGNDF4G",134,0) new TMGDATA,TMGERR "RTN","TMGNDF4G",135,0) ;"do FIND^DIC(22706.9,"","","M",RxName,"*","B^C^D^E^LN","","","TMGDATA","TMGERR") "RTN","TMGNDF4G",136,0) do FIND^DIC(22706.9,"","","M",RxName,"*","B^C^D^LN","","","TMGDATA","TMGERR") "RTN","TMGNDF4G",137,0) "RTN","TMGNDF4G",138,0) if +$get(TMGDATA("DILIST",0))>0 do "RTN","TMGNDF4G",139,0) . new j,IEN,IENS,name,name1,name2,name3,TMGARRAY "RTN","TMGNDF4G",140,0) . set j=0 for set j=+$order(TMGDATA("DILIST",2,j)) quit:(j=0) do "RTN","TMGNDF4G",141,0) . . set IEN=$get(TMGDATA("DILIST",2,j)),IENS=IEN_"," "RTN","TMGNDF4G",142,0) . . do GETS^DIQ(22706.9,IENS,".05;.07;6;.04",,"TMGARRAY","TMGMSG") "RTN","TMGNDF4G",143,0) . . if IgnoreSkipped,($get(TMGARRAY(22706.9,IENS,"6"))="SKIP") quit "RTN","TMGNDF4G",144,0) . . set name1=$get(TMGARRAY(22706.9,IENS,".05")) "RTN","TMGNDF4G",145,0) . . set name2=$get(TMGARRAY(22706.9,IENS,".07")) "RTN","TMGNDF4G",146,0) . . set name3=$get(TMGARRAY(22706.9,IENS,".04")) "RTN","TMGNDF4G",147,0) . . set name=name1_" | "_name2_" | "_name3 "RTN","TMGNDF4G",148,0) . . set name=$extract(name,1,75) "RTN","TMGNDF4G",149,0) . . set SrchRec(name,IENS_"^"_"22706.9")="" "RTN","TMGNDF4G",150,0) "RTN","TMGNDF4G",151,0) quit "RTN","TMGNDF4G",152,0) "RTN","TMGNDF4G",153,0) "RTN","TMGNDF4G",154,0) DoFind(Prefix,RxName,FileNum,Field,SrchRec,index) "RTN","TMGNDF4G",155,0) ;"Purpose: look through file for RxName, and return if found "RTN","TMGNDF4G",156,0) ;"Input: Prefix -- a string to prefix name with in index. "RTN","TMGNDF4G",157,0) ;" RxName -- the string of the Rx name to look for (may be a partial name) "RTN","TMGNDF4G",158,0) ;" FileNum -- The file number to look in. "RTN","TMGNDF4G",159,0) ;" Field -- OPTIONAL. Field to return value in. Default=.01 "RTN","TMGNDF4G",160,0) ;" SrchRec -- PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGNDF4G",161,0) ;" SrchRec(NameFound)=IEN^File# "RTN","TMGNDF4G",162,0) ;" SrchRec(NameFound)=IEN^File# "RTN","TMGNDF4G",163,0) ;" --NOTE: if Name has already been found, it will NOT be overwritten here. "RTN","TMGNDF4G",164,0) ;" index -- OPTIONAL. Index to search. Default="B" "RTN","TMGNDF4G",165,0) ;"Output: SrchRec is filled. "RTN","TMGNDF4G",166,0) ;"Result: none "RTN","TMGNDF4G",167,0) "RTN","TMGNDF4G",168,0) set Field=$get(Field,".01") "RTN","TMGNDF4G",169,0) set index=$get(index,"B") "RTN","TMGNDF4G",170,0) "RTN","TMGNDF4G",171,0) new TMGDATA,TMGERR "RTN","TMGNDF4G",172,0) do FIND^DIC(FileNum,"","","M",RxName,"*",index,"","","TMGDATA","TMGERR") "RTN","TMGNDF4G",173,0) "RTN","TMGNDF4G",174,0) if +$get(TMGDATA("DILIST",0))>0 do "RTN","TMGNDF4G",175,0) . new j,IEN,Name "RTN","TMGNDF4G",176,0) . set j=0 for set j=+$order(TMGDATA("DILIST",2,j)) quit:(j=0) do "RTN","TMGNDF4G",177,0) . . set IEN=$get(TMGDATA("DILIST",2,j)) "RTN","TMGNDF4G",178,0) . . set name=Prefix_$$GET1^DIQ(FileNum,IEN,Field) "RTN","TMGNDF4G",179,0) . . set SrchRec(name,IEN_"^"_FileNum)="" "RTN","TMGNDF4G",180,0) "RTN","TMGNDF4G",181,0) quit "RTN","TMGNDF4G",182,0) "RTN","TMGNDF4G",183,0) "RTN","TMGNDF4G",184,0) RefreshChain(array) "RTN","TMGNDF4G",185,0) ;"Purpose: Refresh entries in 22706.9 "RTN","TMGNDF4G",186,0) ;"Input: -- array: PASS BY REFERENCE. Format: "RTN","TMGNDF4G",187,0) ;" array(DrugName,IEN^File#)="" "RTN","TMGNDF4G",188,0) ;" array(DrugName,IEN^File#)="" "RTN","TMGNDF4G",189,0) ;" Note: it is expected that File# will be: "RTN","TMGNDF4G",190,0) ;" 101.44, 101.43, 50.7, 50, or 22706.9 "RTN","TMGNDF4G",191,0) "RTN","TMGNDF4G",192,0) new name,IENArray "RTN","TMGNDF4G",193,0) set name="" "RTN","TMGNDF4G",194,0) for set name=$order(array(name)) quit:(name="") do "RTN","TMGNDF4G",195,0) . new fInfo set fInfo="" "RTN","TMGNDF4G",196,0) . for set fInfo=$order(array(name,fInfo)) quit:(fInfo="") do "RTN","TMGNDF4G",197,0) . . new IEN,FileNum "RTN","TMGNDF4G",198,0) . . set FileNum=$piece(fInfo,"^",2) "RTN","TMGNDF4G",199,0) . . if FileNum'=22706.9 quit "RTN","TMGNDF4G",200,0) . . set IEN=$piece(fInfo,"^",1) "RTN","TMGNDF4G",201,0) . . set IENArray(+IEN)="" "RTN","TMGNDF4G",202,0) "RTN","TMGNDF4G",203,0) new Option set Option("FIX CHAIN")=1 "RTN","TMGNDF4G",204,0) set Option("QUIET")=1 "RTN","TMGNDF4G",205,0) do RefreshBatch^TMGNDF3C(.IENArray,.Option) "RTN","TMGNDF4G",206,0) "RTN","TMGNDF4G",207,0) quit "RTN","TMGNDF4G",208,0) "RTN","TMGNDF4G",209,0) "RTN","TMGNDF4G",210,0) HandleChain(array) ;"Show forward array "RTN","TMGNDF4G",211,0) ;"Purpose: Show chain from input entry towards final part of chain (Order Quick View) "RTN","TMGNDF4G",212,0) ;"Input: -- array: PASS BY REFERENCE. Format: "RTN","TMGNDF4G",213,0) ;" array(DrugName,IEN^File#)="" "RTN","TMGNDF4G",214,0) ;" array(DrugName,IEN^File#)="" "RTN","TMGNDF4G",215,0) ;" Note: it is expected that File# will be: "RTN","TMGNDF4G",216,0) ;" 101.44, 101.43, 50.7, 50, or 22706.9 "RTN","TMGNDF4G",217,0) "RTN","TMGNDF4G",218,0) new output,RxSet,OutArray "RTN","TMGNDF4G",219,0) "RTN","TMGNDF4G",220,0) set RxSet=$$GetOQVSet^TMGNDFUT() if RxSet'>0 goto HCnDone "RTN","TMGNDF4G",221,0) new IEN10144,IEN10143,IEN50d7,IEN50,IEN22706d9 "RTN","TMGNDF4G",222,0) new array1,array2,num "RTN","TMGNDF4G",223,0) new abort,rescan "RTN","TMGNDF4G",224,0) new name "RTN","TMGNDF4G",225,0) HC1 "RTN","TMGNDF4G",226,0) kill output,array2,array1 "RTN","TMGNDF4G",227,0) set name="" "RTN","TMGNDF4G",228,0) for set name=$order(array(name)) quit:(name="") do "RTN","TMGNDF4G",229,0) . new fInfo set fInfo="" "RTN","TMGNDF4G",230,0) . for set fInfo=$order(array(name,fInfo)) quit:(fInfo="") do "RTN","TMGNDF4G",231,0) . . new IEN,FileNum "RTN","TMGNDF4G",232,0) . . set IEN=$piece(fInfo,"^",1) "RTN","TMGNDF4G",233,0) . . set FileNum=$piece(fInfo,"^",2) "RTN","TMGNDF4G",234,0) . . if FileNum=101.44 set output=IEN "RTN","TMGNDF4G",235,0) . . else if FileNum=101.43 set output=$$Fmt101d43(IEN,RxSet) "RTN","TMGNDF4G",236,0) . . else if FileNum=50.7 set output=$$Fmt50d7(IEN,RxSet) "RTN","TMGNDF4G",237,0) . . else if FileNum=50 set output=$$Fmt50(IEN,RxSet) "RTN","TMGNDF4G",238,0) . . else if FileNum=22706.9 do "RTN","TMGNDF4G",239,0) . . . do Hndl22706d9(IEN,RxSet,.OutArray,.array1,"T") "RTN","TMGNDF4G",240,0) . . . set output=$$Fmt22706d9(IEN,RxSet,"G") "RTN","TMGNDF4G",241,0) . . set IEN10144=+$piece(output,"^",1) "RTN","TMGNDF4G",242,0) . . set IEN10143=+$piece(output,"^",2) "RTN","TMGNDF4G",243,0) . . set IEN50d7=+$piece(output,"^",3) "RTN","TMGNDF4G",244,0) . . set IEN50=+$piece(output,"^",4) "RTN","TMGNDF4G",245,0) . . set IEN22706d9=+$piece(output,"^",5) "RTN","TMGNDF4G",246,0) . . if IEN22706d9=0 quit "RTN","TMGNDF4G",247,0) . . set OutArray(IEN10144,IEN10143,IEN50d7,IEN50,IEN22706d9)="G" "RTN","TMGNDF4G",248,0) . . set array1(IEN22706d9,IEN10144_"^"_IEN10143_"^"_IEN50d7_"^"_IEN50_"^"_IEN22706d9_"^"_"G")="" "RTN","TMGNDF4G",249,0) "RTN","TMGNDF4G",250,0) ;"Now rearrange into a numbered array "RTN","TMGNDF4G",251,0) set num=0,IEN22706d9="" "RTN","TMGNDF4G",252,0) for set IEN22706d9=$order(array1(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDF4G",253,0) . new s set s="" "RTN","TMGNDF4G",254,0) . for set s=$order(array1(IEN22706d9,s)) quit:(s="") do "RTN","TMGNDF4G",255,0) . . set num=num+1 "RTN","TMGNDF4G",256,0) . . set array2(num)=s "RTN","TMGNDF4G",257,0) "RTN","TMGNDF4G",258,0) ;"Now display array -- this setup will allow user to back up in list "RTN","TMGNDF4G",259,0) set abort=0,rescan=0,num=0 "RTN","TMGNDF4G",260,0) for set num=$order(array2(num)) quit:(num="")!(abort=1)!(rescan=1) do "RTN","TMGNDF4G",261,0) . new s set s=$get(array2(num)) "RTN","TMGNDF4G",262,0) . new result "RTN","TMGNDF4G",263,0) . set result=$$HandleOne($piece(s,"^",1),$piece(s,"^",2),$piece(s,"^",3),$piece(s,"^",4),$piece(s,"^",5),$piece(s,"^",6)) "RTN","TMGNDF4G",264,0) . if result="^" set abort=1 quit "RTN","TMGNDF4G",265,0) . else if result=-3 kill array2(num) quit "RTN","TMGNDF4G",266,0) . else if result=-4 set rescan=1 quit "RTN","TMGNDF4G",267,0) . else if result=-1 do quit "RTN","TMGNDF4G",268,0) . . set num=$order(array2(num),-1) "RTN","TMGNDF4G",269,0) . . if num>0 set num=$order(array2(num),-1) "RTN","TMGNDF4G",270,0) "RTN","TMGNDF4G",271,0) if rescan=1 goto HC1 "RTN","TMGNDF4G",272,0) "RTN","TMGNDF4G",273,0) HCnDone "RTN","TMGNDF4G",274,0) quit "RTN","TMGNDF4G",275,0) "RTN","TMGNDF4G",276,0) "RTN","TMGNDF4G",277,0) HandleOne(IEN10144,IEN10143,IEN50d7,IEN50,IEN22706d9,GorT) "RTN","TMGNDF4G",278,0) ;"Purpose: to show the user a drug chain and allow manipulation of it "RTN","TMGNDF4G",279,0) ;"Input: IEN's "RTN","TMGNDF4G",280,0) ;" GorT -- G or T "RTN","TMGNDF4G",281,0) ;"NOTE: makes use of RxSet (a variable globally scoped here) "RTN","TMGNDF4G",282,0) ;"Results: 1: go to next, "RTN","TMGNDF4G",283,0) ;" -1: go back one, "RTN","TMGNDF4G",284,0) ;" ^: abort, "RTN","TMGNDF4G",285,0) ;" -3: delete this record "RTN","TMGNDF4G",286,0) ;" -4: Rescan and re-setup array "RTN","TMGNDF4G",287,0) "RTN","TMGNDF4G",288,0) new input "RTN","TMGNDF4G",289,0) new result set result=1 "RTN","TMGNDF4G",290,0) H1L1 "RTN","TMGNDF4G",291,0) write # "RTN","TMGNDF4G",292,0) write "-- TMG FDA IMPORT COMPILED (22706.9) file, Record# ",IEN22706d9," [",GorT,"] -----------",! "RTN","TMGNDF4G",293,0) new tabCol set tabCol=50 "RTN","TMGNDF4G",294,0) ;"write $extract($$GET1^DIQ(22706.9,IEN22706d9_",",.04),1,48),?50," [.04;22706.9:#",IEN22706d9,"]",! "RTN","TMGNDF4G",295,0) write "1. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.04),?tabCol," [.04; Long]",! "RTN","TMGNDF4G",296,0) write "2. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.05),?tabCol," [.05; Trade (inclds Frm)]",! "RTN","TMGNDF4G",297,0) write "3. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.055),?tabCol," [.055; Trade&Frm]",! "RTN","TMGNDF4G",298,0) write "4. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.056),?tabCol," [.056; Trade,Frm,Dose,Unit]",! "RTN","TMGNDF4G",299,0) write "5. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.07),?tabCol," [.07; Generic]",! "RTN","TMGNDF4G",300,0) write "6. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.075),?tabCol," [.075; Genrc&Frm]",! "RTN","TMGNDF4G",301,0) write "7. ",$$GET1^DIQ(22706.9,IEN22706d9_",",.076),?tabCol," [.076; Generc,Frm,Dose,Unit]",! "RTN","TMGNDF4G",302,0) write "8. +-> [",GorT,"] ",$$GET1^DIQ(50,IEN50_",",.01),?tabCol," [50:#",IEN50,"]",! "RTN","TMGNDF4G",303,0) new vapIEN set vapIEN=+$piece($get(^PSDRUG(IEN50,"ND")),"^",3) "RTN","TMGNDF4G",304,0) if vapIEN>0 write "9. +~~~> 50.68: ",$$GET1^DIQ(50.68,vapIEN_",",.01),! "RTN","TMGNDF4G",305,0) write "10. +->",$$GET1^DIQ(50.7,IEN50d7_",",.01),?tabCol," [50.7:#",IEN50d7,"]",! "RTN","TMGNDF4G",306,0) write "11. +->",$$GET1^DIQ(101.43,IEN10143_",",.01),?tabCol," [101.43:#",IEN10143,"]",! "RTN","TMGNDF4G",307,0) write "12. +->",$$GET1^DIQ(101.442,IEN10144_","_RxSet_",",.01),?tabCol," [101.44:#",IEN10144,"]",! "RTN","TMGNDF4G",308,0) write ! "RTN","TMGNDF4G",309,0) write "'-'=Backward; '+'=Forward; '^'=quit;",! "RTN","TMGNDF4G",310,0) write "F=show FDA source; T=show Compiled record dump",! "RTN","TMGNDF4G",311,0) write "S=mark import to be SKIPPED'",! "RTN","TMGNDF4G",312,0) write "FE=Full edit of Compiled",! "RTN","TMGNDF4G",313,0) write "1..7=Edit Compiled, 8=Edit DRUG (50) record",! "RTN","TMGNDF4G",314,0) write "RC=Recompile; N=Alt Names setup; RDL=Refresh DRUG link",! "RTN","TMGNDF4G",315,0) read "Enter option: +// ",input,! "RTN","TMGNDF4G",316,0) if input="" set input="+" "RTN","TMGNDF4G",317,0) set input=$$UP^XLFSTR(input) "RTN","TMGNDF4G",318,0) if input="^" set result="^" goto HODone "RTN","TMGNDF4G",319,0) if input="-" set result=-1 goto HODone "RTN","TMGNDF4G",320,0) if input="+" set result=1 goto HODone "RTN","TMGNDF4G",321,0) if input="FE" do "RTN","TMGNDF4G",322,0) . do FullEDTMG(IEN22706d9) "RTN","TMGNDF4G",323,0) . set input="RDL" "RTN","TMGNDF4G",324,0) if (+input>0)&(+input<8) do "RTN","TMGNDF4G",325,0) . do EditTMG(IEN22706d9) "RTN","TMGNDF4G",326,0) . set input="RDL" "RTN","TMGNDF4G",327,0) if input="8" do "RTN","TMGNDF4G",328,0) . do Edit50^TMGNDFUT(IEN50) "RTN","TMGNDF4G",329,0) . set input="RDL" "RTN","TMGNDF4G",330,0) if input="9" do "RTN","TMGNDF4G",331,0) . do EditVAP(IEN22706d9) "RTN","TMGNDF4G",332,0) . set input="RDL" "RTN","TMGNDF4G",333,0) if input="F" do goto H1L1 "RTN","TMGNDF4G",334,0) . do Show1Source^TMGNDF1A(IEN22706d9) "RTN","TMGNDF4G",335,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4G",336,0) if input="T" do goto H1L1 "RTN","TMGNDF4G",337,0) . do DumpRec2^TMGDEBUG(22706.9,IEN22706d9,0) "RTN","TMGNDF4G",338,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4G",339,0) if input="S" do goto HODone "RTN","TMGNDF4G",340,0) . new Option "RTN","TMGNDF4G",341,0) . set Option("FIX CHAIN")=1 "RTN","TMGNDF4G",342,0) . set Option("FIX CHAIN","IEN22706d9")=IEN22706d9 "RTN","TMGNDF4G",343,0) . set Option("DELETING")=1 "RTN","TMGNDF4G",344,0) . set Option("QUIET")=1 "RTN","TMGNDF4G",345,0) . do Refresh1^TMGNDF3C(IEN22706d9,.Option) "RTN","TMGNDF4G",346,0) . new TMGFDA,TMGMSG "RTN","TMGNDF4G",347,0) . set TMGFDA(22706.9,IEN22706d9,6)=1 "RTN","TMGNDF4G",348,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDF4G",349,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDF4G",350,0) . ;"set $piece(^TMG(22706.9,IEN22706d9,1),"^",4)=1 ;"set SKIP=true "RTN","TMGNDF4G",351,0) . set result=-3 "RTN","TMGNDF4G",352,0) if input="RC" do goto H1L1 "RTN","TMGNDF4G",353,0) . new Option set Option("FIX CHAIN")=1 "RTN","TMGNDF4G",354,0) . do ReCompOne^TMGNDF1A(IEN22706d9,.Option) "RTN","TMGNDF4G",355,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4G",356,0) if input="N" do goto H1L1 "RTN","TMGNDF4G",357,0) . new Option set Option("FIX CHAIN")=1 "RTN","TMGNDF4G",358,0) . do Make1Alt^TMGNDF2G(IEN22706d9,.Option) "RTN","TMGNDF4G",359,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4G",360,0) if input="RDL" do goto HODone "RTN","TMGNDF4G",361,0) . new Option set Option("FIX CHAIN")=1 "RTN","TMGNDF4G",362,0) . set Option("FIX CHAIN","IEN22706d9")=IEN22706d9 "RTN","TMGNDF4G",363,0) . do Refresh1^TMGNDF3C(IEN22706d9,.Option) "RTN","TMGNDF4G",364,0) . set result=-4 "RTN","TMGNDF4G",365,0) . write "Will now rescan and setup array to detect possible changes.",! "RTN","TMGNDF4G",366,0) . do PressToCont^TMGUSRIF "RTN","TMGNDF4G",367,0) "RTN","TMGNDF4G",368,0) HODone "RTN","TMGNDF4G",369,0) quit result "RTN","TMGNDF4G",370,0) "RTN","TMGNDF4G",371,0) Hndl22706d9(IEN,RxSet,OutArray,array1,GorT) "RTN","TMGNDF4G",372,0) ;"Purpose: A brief subroutine to format 22706.9 input "RTN","TMGNDF4G",373,0) "RTN","TMGNDF4G",374,0) new output "RTN","TMGNDF4G",375,0) new IEN10144,IEN10143,IEN50d7,IEN50,IEN22706d9 "RTN","TMGNDF4G",376,0) set output=$$Fmt22706d9(IEN,RxSet,GorT) "RTN","TMGNDF4G",377,0) set IEN10144=+$piece(output,"^",1) "RTN","TMGNDF4G",378,0) set IEN10143=+$piece(output,"^",2) "RTN","TMGNDF4G",379,0) set IEN50d7=+$piece(output,"^",3) "RTN","TMGNDF4G",380,0) set IEN50=+$piece(output,"^",4) "RTN","TMGNDF4G",381,0) set IEN22706d9=+$piece(output,"^",5) "RTN","TMGNDF4G",382,0) if IEN22706d9=0 quit "RTN","TMGNDF4G",383,0) set OutArray(IEN10144,IEN10143,IEN50d7,IEN50,IEN22706d9)=GorT "RTN","TMGNDF4G",384,0) set array1(IEN22706d9,IEN10144_"^"_IEN10143_"^"_IEN50d7_"^"_IEN50_"^"_IEN22706d9_"^"_GorT)="" "RTN","TMGNDF4G",385,0) quit "RTN","TMGNDF4G",386,0) "RTN","TMGNDF4G",387,0) "RTN","TMGNDF4G",388,0) "RTN","TMGNDF4G",389,0) Fmt101d43(IEN,RxSet) "RTN","TMGNDF4G",390,0) ;"Purpose: to add an entry from file 101.43 to output string "RTN","TMGNDF4G",391,0) ;"Input: IEN -- an IEN from file 101.43 "RTN","TMGNDF4G",392,0) ;" RxSet -- the IEN in 101.44 of the ORWDSET O RX record "RTN","TMGNDF4G",393,0) ;"Result: IEN101.44^IEN101.43 "RTN","TMGNDF4G",394,0) "RTN","TMGNDF4G",395,0) new parentIEN "RTN","TMGNDF4G",396,0) set IEN=+$get(IEN) "RTN","TMGNDF4G",397,0) if IEN>0 do "RTN","TMGNDF4G",398,0) . set parentIEN=+$order(^ORD(101.44,RxSet,20,"B",IEN,"")) "RTN","TMGNDF4G",399,0) else set parentIEN=0 "RTN","TMGNDF4G",400,0) "RTN","TMGNDF4G",401,0) quit parentIEN_"^"_IEN "RTN","TMGNDF4G",402,0) "RTN","TMGNDF4G",403,0) "RTN","TMGNDF4G",404,0) Fmt50d7(IEN,RxSet) "RTN","TMGNDF4G",405,0) ;"Purpose: to add an entry from file 50.7 to output string "RTN","TMGNDF4G",406,0) ;"Input: IEN -- an IEN from file 50.7 "RTN","TMGNDF4G",407,0) ;" RxSet -- the IEN in 101.44 of the ORWDSET O RX record "RTN","TMGNDF4G",408,0) ;"Result: IEN101.44^IEN101.43^IEN50.7 "RTN","TMGNDF4G",409,0) "RTN","TMGNDF4G",410,0) new parentIEN "RTN","TMGNDF4G",411,0) set IEN=+$get(IEN) "RTN","TMGNDF4G",412,0) if IEN>0 do "RTN","TMGNDF4G",413,0) . set parentIEN=$order(^ORD(101.43,"ID",IEN_";99PSP","")) "RTN","TMGNDF4G",414,0) else set parentIEN=0 "RTN","TMGNDF4G",415,0) "RTN","TMGNDF4G",416,0) quit $$Fmt101d43(parentIEN,RxSet)_"^"_IEN "RTN","TMGNDF4G",417,0) "RTN","TMGNDF4G",418,0) "RTN","TMGNDF4G",419,0) Fmt50(IEN,RxSet) "RTN","TMGNDF4G",420,0) ;"Purpose: to add an entry from file 50 to output string "RTN","TMGNDF4G",421,0) ;"Input: IEN -- an IEN from file 50 "RTN","TMGNDF4G",422,0) ;" RxSet -- the IEN in 101.44 of the ORWDSET O RX record "RTN","TMGNDF4G",423,0) ;"Result: IEN101.44^IEN101.43^IEN50.7^IEN50 "RTN","TMGNDF4G",424,0) "RTN","TMGNDF4G",425,0) new parentIEN "RTN","TMGNDF4G",426,0) set IEN=+$get(IEN) "RTN","TMGNDF4G",427,0) if IEN>0 do "RTN","TMGNDF4G",428,0) . set parentIEN=+$piece($get(^PSDRUG(IEN,2)),"^",1) "RTN","TMGNDF4G",429,0) else set parentIEN=0 "RTN","TMGNDF4G",430,0) "RTN","TMGNDF4G",431,0) quit $$Fmt50d7(parentIEN,RxSet)_"^"_IEN "RTN","TMGNDF4G",432,0) "RTN","TMGNDF4G",433,0) "RTN","TMGNDF4G",434,0) Fmt22706d9(IEN,RxSet,s) "RTN","TMGNDF4G",435,0) ;"Purpose: to add an entry from file 22706.9 to output string "RTN","TMGNDF4G",436,0) ;"Input: IEN -- an IEN from file 22706.9 "RTN","TMGNDF4G",437,0) ;" RxSet -- the IEN in 101.44 of the ORWDSET O RX record "RTN","TMGNDF4G",438,0) ;" s -- "G" or "T" for Generic or Trade "RTN","TMGNDF4G",439,0) ;"Result: IEN101.44^IEN101.43^IEN50.7^IEN50^IEN22706.9 "RTN","TMGNDF4G",440,0) "RTN","TMGNDF4G",441,0) new parentIEN set parentIEN=0 "RTN","TMGNDF4G",442,0) new parentS "RTN","TMGNDF4G",443,0) set IEN=+$get(IEN) "RTN","TMGNDF4G",444,0) if IEN>0 do "RTN","TMGNDF4G",445,0) . if $get(s)="T" do "RTN","TMGNDF4G",446,0) . . set parentIEN=+$piece($get(^TMG(22706.9,IEN,7)),"^",1) ;" 7;1 DRUG TRADENAME LINK "RTN","TMGNDF4G",447,0) . else do "RTN","TMGNDF4G",448,0) . . set parentIEN=+$piece($get(^TMG(22706.9,IEN,7)),"^",2) ;" 7;2 DRUG GENERIC LINK "RTN","TMGNDF4G",449,0) "RTN","TMGNDF4G",450,0) if parentIEN>0 do "RTN","TMGNDF4G",451,0) . set parentS=$$Fmt50(parentIEN,RxSet) "RTN","TMGNDF4G",452,0) else do "RTN","TMGNDF4G",453,0) . set parentS="???" "RTN","TMGNDF4G",454,0) "RTN","TMGNDF4G",455,0) quit parentS_"^"_IEN "RTN","TMGNDF4G",456,0) "RTN","TMGNDF4G",457,0) "RTN","TMGNDF4G",458,0) ;"============================================================ "RTN","TMGNDF4G",459,0) "RTN","TMGNDF4G",460,0) EditTMG(IEN) "RTN","TMGNDF4G",461,0) ;"Purpose: to edit the TMG "RTN","TMGNDF4G",462,0) "RTN","TMGNDF4G",463,0) ;"do Edit1^TMGNDF1D(IEN) "RTN","TMGNDF4G",464,0) "RTN","TMGNDF4G",465,0) new Options,IENlist "RTN","TMGNDF4G",466,0) set IENlist(IEN)="" "RTN","TMGNDF4G",467,0) set Options("FILE")=22706.9 "RTN","TMGNDF4G",468,0) set Options("FIELDS",1)=.04 "RTN","TMGNDF4G",469,0) set Options("FIELDS",2)=.05 "RTN","TMGNDF4G",470,0) set Options("FIELDS",3)=.055 "RTN","TMGNDF4G",471,0) set Options("FIELDS",4)=.056 "RTN","TMGNDF4G",472,0) set Options("FIELDS",5)=.07 "RTN","TMGNDF4G",473,0) set Options("FIELDS",6)=.075 "RTN","TMGNDF4G",474,0) set Options("FIELDS",7)=.076 "RTN","TMGNDF4G",475,0) set Options("FIELDS",8)=6 "RTN","TMGNDF4G",476,0) set Options("FIELDS","MAX NUM")=8 "RTN","TMGNDF4G",477,0) "RTN","TMGNDF4G",478,0) new temp set temp=$$EditRecs^TMGSELED("IENlist",.Options) "RTN","TMGNDF4G",479,0) "RTN","TMGNDF4G",480,0) quit "RTN","TMGNDF4G",481,0) "RTN","TMGNDF4G",482,0) "RTN","TMGNDF4G",483,0) FullEDTMG(IEN) "RTN","TMGNDF4G",484,0) ;"Purpose: allow editing of any field in TMG "RTN","TMGNDF4G",485,0) "RTN","TMGNDF4G",486,0) new Options "RTN","TMGNDF4G",487,0) set Options("FILE")=22706.9 "RTN","TMGNDF4G",488,0) if $$GetFields^TMGSELED(.Options)=0 goto FETDone "RTN","TMGNDF4G",489,0) "RTN","TMGNDF4G",490,0) new list set list(IEN)="" "RTN","TMGNDF4G",491,0) new temp set temp=$$EditRecs^TMGSELED("list",.Options) "RTN","TMGNDF4G",492,0) "RTN","TMGNDF4G",493,0) FETDone quit "RTN","TMGNDF4G",494,0) "RTN","TMGNDF4G",495,0) "RTN","TMGNDF4G",496,0) "RTN","TMGNDF4G",497,0) EditVAP(IEN) "RTN","TMGNDF4G",498,0) ;"Purpose: to edit the TMG "RTN","TMGNDF4G",499,0) ;"Input: IEN -- IEN in 22706.9 "RTN","TMGNDF4G",500,0) "RTN","TMGNDF4G",501,0) new Options,IENlist "RTN","TMGNDF4G",502,0) set IENlist(IEN)="" "RTN","TMGNDF4G",503,0) set Options("FILE")=22706.9 "RTN","TMGNDF4G",504,0) set Options("FIELDS",1)=.04 "RTN","TMGNDF4G",505,0) set Options("FIELDS",1,"NO EDIT")=1 "RTN","TMGNDF4G",506,0) set Options("FIELDS",2)=.055 "RTN","TMGNDF4G",507,0) set Options("FIELDS",2,"NO EDIT")=1 "RTN","TMGNDF4G",508,0) set Options("FIELDS",3)=.075 "RTN","TMGNDF4G",509,0) set Options("FIELDS",3,"NO EDIT")=1 "RTN","TMGNDF4G",510,0) set Options("FIELDS",4)=.076 "RTN","TMGNDF4G",511,0) set Options("FIELDS",4,"NO EDIT")=1 "RTN","TMGNDF4G",512,0) set Options("FIELDS",5)=5.5 "RTN","TMGNDF4G",513,0) set Options("FIELDS","MAX NUM")=5 "RTN","TMGNDF4G",514,0) "RTN","TMGNDF4G",515,0) new temp set temp=$$EditRecs^TMGSELED("IENlist",.Options) "RTN","TMGNDF4G",516,0) "RTN","TMGNDF4G",517,0) quit "RTN","TMGNDF4G",518,0) "RTN","TMGNDF4G",519,0) "RTN","TMGNDFK1") 0^60^B4836 "RTN","TMGNDFK1",1,0) TMGNDFK1 ;TMG/kst/FDA Import code -- KIDS Fns ;03/25/06 "RTN","TMGNDFK1",2,0) ;;1.0;TMG-LIB;**1**;03/24/07 "RTN","TMGNDFK1",3,0) "RTN","TMGNDFK1",4,0) ;"FDA - NATIONAL DRUG FILES IMPORT "RTN","TMGNDFK1",5,0) ;"Code to handle KIDS builds "RTN","TMGNDFK1",6,0) "RTN","TMGNDFK1",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDFK1",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDFK1",9,0) ;"3/24/07 "RTN","TMGNDFK1",10,0) "RTN","TMGNDFK1",11,0) ;"======================================================================= "RTN","TMGNDFK1",12,0) ;" API -- Public Functions. "RTN","TMGNDFK1",13,0) ;"======================================================================= "RTN","TMGNDFK1",14,0) "RTN","TMGNDFK1",15,0) ;"======================================================================= "RTN","TMGNDFK1",16,0) ;" Private Functions. "RTN","TMGNDFK1",17,0) ;"======================================================================= "RTN","TMGNDFK1",18,0) ;"======================================================================= "RTN","TMGNDFK1",19,0) "RTN","TMGNDFK1",20,0) CKENV "RTN","TMGNDFK1",21,0) ;"Purpose: Code to check the environment in the target system "RTN","TMGNDFK1",22,0) "RTN","TMGNDFK1",23,0) quit "RTN","TMGNDFK1",24,0) "RTN","TMGNDFK1",25,0) "RTN","TMGNDFK1",26,0) PRETRANS "RTN","TMGNDFK1",27,0) ;"Purpose: Code that will be executed before creating the KIDS "RTN","TMGNDFK1",28,0) "RTN","TMGNDFK1",29,0) quit "RTN","TMGNDFK1",30,0) "RTN","TMGNDFK1",31,0) "RTN","TMGNDFK1",32,0) PREINST "RTN","TMGNDFK1",33,0) ;"Purpose: Code that will be executed on the remote system before the import. "RTN","TMGNDFK1",34,0) "RTN","TMGNDFK1",35,0) quit "RTN","TMGNDFK1",36,0) "RTN","TMGNDFK1",37,0) POSTINST "RTN","TMGNDFK1",38,0) ;"Purpose: Code that will be executed on the remote system after the import. "RTN","TMGNDFK1",39,0) "RTN","TMGNDFK1",40,0) quit "RTN","TMGNDFUT") 0^61^B10639 "RTN","TMGNDFUT",1,0) TMGNDFUT ;TMG/kst/FDA Import -- Fix OQV Problems;11/20/07 "RTN","TMGNDFUT",2,0) ;;1.0;TMG-LIB;**1**;11/20/07 "RTN","TMGNDFUT",3,0) "RTN","TMGNDFUT",4,0) ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS "RTN","TMGNDFUT",5,0) ;" Utility functions "RTN","TMGNDFUT",6,0) "RTN","TMGNDFUT",7,0) ;"Kevin Toppenberg MD "RTN","TMGNDFUT",8,0) ;"GNU General Public License (GPL) applies "RTN","TMGNDFUT",9,0) ;"10-15-2007 "RTN","TMGNDFUT",10,0) "RTN","TMGNDFUT",11,0) ;"======================================================================= "RTN","TMGNDFUT",12,0) ;" API -- Public Functions. "RTN","TMGNDFUT",13,0) ;"======================================================================= "RTN","TMGNDFUT",14,0) "RTN","TMGNDFUT",15,0) ;"Edit50(IEN50) -- launch a screenman form that is designed to edit file 50 records "RTN","TMGNDFUT",16,0) ;"Index101d44(RxSet,pIndex) -- index pointers from 101.44 --> 101.43 "RTN","TMGNDFUT",17,0) ;"GetOI(IEN50d7,Array) -- return linked IEN in the ORDERABLE ITEM file (101.43) from IEN50d7 "RTN","TMGNDFUT",18,0) ;"GetPOI(IEN101d43,POI) -- return linked IEN in PHARMACY ORDERABLE ITEM (POI) file (50.7) "RTN","TMGNDFUT",19,0) ;"$$GetOQVIENS(IEN101d43,RxSet,Array) -- get IEN ORDER QUICK VIEW (101.44) for pointer to 101.43 "RTN","TMGNDFUT",20,0) ;"GetOIInfo(IEN101d43,Array) -- Get info about ORDERABLE ITEM (101.43) record "RTN","TMGNDFUT",21,0) ;"ChkFixOI(Array) -- check and fix pointers into and out of OI record "RTN","TMGNDFUT",22,0) ;"GetDRUGs(IEN50d7,IEN50Array,ActiveOnly) -- For a given IEN in PHARMACY ORDERABLE ITEM, return linked #50 IEN "RTN","TMGNDFUT",23,0) ;"GetpDRUGs(IEN50d7,IEN50Array,ActiveOnly) -- For a given IEN in POI, return linked IEN to DRUG file (50) "RTN","TMGNDFUT",24,0) ;"GetfdaIEN(IEN50) -- return the IEN in 22706.9 that points to IEN50 "RTN","TMGNDFUT",25,0) ;"GetFDA(IEN50,FDA) -- For a given IEN in DRUG file, return linked IEN in TMG FDA IMPORT COMPILED file (22706.9) "RTN","TMGNDFUT",26,0) ;"Unlock50: Unlock fields needed to add data to 50 "RTN","TMGNDFUT",27,0) ;"Lock50: Return locks removed from Unlock50 in file 50 "RTN","TMGNDFUT",28,0) ;"GetpTMG(IEN50d7,TMGArray,ActiveOnly) IENs in 22706.9 pointing to POI (50.7) record "RTN","TMGNDFUT",29,0) ;"Getp1TMG(IEN101d43,TMGArray,ActiveOnly) -- IENS in 22706.9 pointing to OI (101.43) record "RTN","TMGNDFUT",30,0) ;"GetpPOI(IEN50d7,Array,ActiveOnly) -- return all IENs pointing to POI from 22706.9, 50, or 101.43 "RTN","TMGNDFUT",31,0) ;"GetpOI(IEN101d43,Array,ActiveOnly) --return all IENs pointing to OI from 22706.9, 50.7 101.44 "RTN","TMGNDFUT",32,0) ;"KillPOI(IEN50d7) -- remove a POI, along with ptrs from 50, 22706.9, 101.43 "RTN","TMGNDFUT",33,0) ;"KillOI(IEN101d43) -- remove an OI, along with ptrs to it from files 50.7, 22706.9, 101.44 "RTN","TMGNDFUT",34,0) ;"RedirOI(oldIEN,newIEN) -- redirect pointers in ORDERABLE ITEM file from oldIEN to newIEN "RTN","TMGNDFUT",35,0) ;"FindPOI(DrugNAF) -- return IEN in PHARMACY ORDERABLE ITEM (50.7) matching drug name "RTN","TMGNDFUT",36,0) ;"FindOI(DrugNAF) -- return IEN in ORDERABLE ITEM (101.43) matching drug name "RTN","TMGNDFUT",37,0) ;"GetOQVSet(quiet) -- get the active RxSet in OQV file "RTN","TMGNDFUT",38,0) ;"Kill50(IEN50,IEN22706d9,mode,quiet) --delete entry in file 50, and links to it from 22706.9 "RTN","TMGNDFUT",39,0) ;"$$OIInactive(IEN101d43) -- Return if record has a past-due inactive date "RTN","TMGNDFUT",40,0) ;"$$IsImport(IEN50d7) -- determine if the POI record is one linked to a FDA import "RTN","TMGNDFUT",41,0) ;"KillOQV(IENS) -- kill/inactivate entry in ORDER QUICK VIEW (101.44) "RTN","TMGNDFUT",42,0) "RTN","TMGNDFUT",43,0) ;"======================================================================= "RTN","TMGNDFUT",44,0) ;" Private Functions. "RTN","TMGNDFUT",45,0) ;"======================================================================= "RTN","TMGNDFUT",46,0) "RTN","TMGNDFUT",47,0) ;"======================================================================= "RTN","TMGNDFUT",48,0) "RTN","TMGNDFUT",49,0) "RTN","TMGNDFUT",50,0) Edit50(IEN50) "RTN","TMGNDFUT",51,0) ;"Purpose: to launch a screenman form that is designed to edit file 50 records "RTN","TMGNDFUT",52,0) "RTN","TMGNDFUT",53,0) "RTN","TMGNDFUT",54,0) new PSSZ set PSSZ=1 ;"allows editing of .01 field of file 50 "RTN","TMGNDFUT",55,0) if +IEN50>0 do LaunchScreenman^TMGMISC(50,103,IEN50,1) ;"launch screenman form "RTN","TMGNDFUT",56,0) quit "RTN","TMGNDFUT",57,0) "RTN","TMGNDFUT",58,0) "RTN","TMGNDFUT",59,0) "RTN","TMGNDFUT",60,0) Index101d44(RxSet,pIndex) "RTN","TMGNDFUT",61,0) ;"Purpose: index pointers from 101.44 --> 101.43 "RTN","TMGNDFUT",62,0) ;"Input: RxSet -the IEN in 101.44 containing ORWDSET O RX "RTN","TMGNDFUT",63,0) ;" pIndex: PASS BY NAME. An OUT PARAMETER. Format: "RTN","TMGNDFUT",64,0) ;" @pIndex@(IEN101.43,IEN101.44)="" "RTN","TMGNDFUT",65,0) "RTN","TMGNDFUT",66,0) new Itr,subIEN "RTN","TMGNDFUT",67,0) new abort set abort=0 "RTN","TMGNDFUT",68,0) write "Gathering list of links between ORDER QUICK VIEW --> ORDERABLE ITEM...",! "RTN","TMGNDFUT",69,0) set subIEN=$$ItrAInit^TMGITR("^ORD(101.44,"_RxSet_",20)",.Itr) "RTN","TMGNDFUT",70,0) do PrepProgress^TMGITR(.Itr,20,1,"subIEN") "RTN","TMGNDFUT",71,0) if subIEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.subIEN)="")!abort "RTN","TMGNDFUT",72,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGNDFUT",73,0) . new IEN101d43 "RTN","TMGNDFUT",74,0) . set IEN101d43=+$piece($get(^ORD(101.44,RxSet,20,subIEN,0)),"^",1) "RTN","TMGNDFUT",75,0) . if IEN101d43=0 quit "RTN","TMGNDFUT",76,0) . set @pIndex@(IEN101d43,subIEN)=1 "RTN","TMGNDFUT",77,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGNDFUT",78,0) "RTN","TMGNDFUT",79,0) quit "RTN","TMGNDFUT",80,0) "RTN","TMGNDFUT",81,0) "RTN","TMGNDFUT",82,0) "RTN","TMGNDFUT",83,0) GetOI(IEN50d7,Array) "RTN","TMGNDFUT",84,0) ;"Purpose: for a given PHARAMCY ORDERABLE ITEM (50.7), return matching IEN "RTN","TMGNDFUT",85,0) ;" in the ORDERABLE ITEM file (101.43) "RTN","TMGNDFUT",86,0) ;"Input: IEN50d7 -- the IEN in 50.7 "RTN","TMGNDFUT",87,0) ;" Array -- OPTIONAL. PASS BY REFERNCE. An OUT PARAMETER. "RTN","TMGNDFUT",88,0) ;" Will be filled with ALL pointers to 50d7. Format: "RTN","TMGNDFUT",89,0) ;" Array(IEN)="" "RTN","TMGNDFUT",90,0) ;"Results: the IEN in 101.43, or 0 if not found "RTN","TMGNDFUT",91,0) ;"Note: If, for some reason, more than one record in 101.43 points to "RTN","TMGNDFUT",92,0) ;" the specified IEN50d7, then only the first one in the list will be "RTN","TMGNDFUT",93,0) ;" returned, but Array will return all "RTN","TMGNDFUT",94,0) "RTN","TMGNDFUT",95,0) new result set result=0 "RTN","TMGNDFUT",96,0) new tempS set tempS=IEN50d7_";99PSP" "RTN","TMGNDFUT",97,0) "RTN","TMGNDFUT",98,0) new IEN101d43 set IEN101d43="" "RTN","TMGNDFUT",99,0) for set IEN101d43=$order(^ORD(101.43,"ID",tempS,IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDFUT",100,0) . if +IEN101d43=0 quit "RTN","TMGNDFUT",101,0) . if result=0 set result=IEN101d43 "RTN","TMGNDFUT",102,0) . set Array(IEN101d43)="" "RTN","TMGNDFUT",103,0) "RTN","TMGNDFUT",104,0) quit result "RTN","TMGNDFUT",105,0) "RTN","TMGNDFUT",106,0) "RTN","TMGNDFUT",107,0) GetPOI(IEN101d43) ;" !! Note: this is a different function from GetpOI !! "RTN","TMGNDFUT",108,0) ;"Purpose: for a given entry in ORDERABLE ITEM (101.43) file, return matching "RTN","TMGNDFUT",109,0) ;" IEN in PHARMACY ORDERABLE ITEM (POI) file (50.7) "RTN","TMGNDFUT",110,0) ;"Input: IEN101d43 -- IEN in 101.43 "RTN","TMGNDFUT",111,0) ;"Output: bad pointers may be fixed. "RTN","TMGNDFUT",112,0) ;"Result: returns IEN in 50.7, or -1 if NON-PHARMACY entry found, or 0 if problem "RTN","TMGNDFUT",113,0) "RTN","TMGNDFUT",114,0) new Array,result "RTN","TMGNDFUT",115,0) "RTN","TMGNDFUT",116,0) do GetOIInfo(IEN101d43,.Array) "RTN","TMGNDFUT",117,0) "RTN","TMGNDFUT",118,0) new tPOI,gPOI "RTN","TMGNDFUT",119,0) set tPOI=+$get(Array("IEN 50.7 from 22706.9","TRADE")) "RTN","TMGNDFUT",120,0) set gPOI=+$get(Array("IEN 50.7 from 22706.9","GENERIC")) "RTN","TMGNDFUT",121,0) if (tPOI'=0)&(gPOI'=0)&(tPOI'=gPOI) do "RTN","TMGNDFUT",122,0) . do ChkFixOI(.Array) "RTN","TMGNDFUT",123,0) "RTN","TMGNDFUT",124,0) set result=$get(Array("IEN 50.7 from 22706.9","GENERIC")) "RTN","TMGNDFUT",125,0) if result="" set result=$get(Array("IEN 50.7 from 22706.9","TRADE")) "RTN","TMGNDFUT",126,0) if result="" set result=$get(Array("IEN 50.7 from 101.43")) "RTN","TMGNDFUT",127,0) "RTN","TMGNDFUT",128,0) quit +result "RTN","TMGNDFUT",129,0) "RTN","TMGNDFUT",130,0) "RTN","TMGNDFUT",131,0) GetOIInfo(IEN101d43,Array) "RTN","TMGNDFUT",132,0) ;"Purpose: for a given entry in ORDERABLE ITEM (101.43) file, return matching "RTN","TMGNDFUT",133,0) ;" IEN in PHARMACY ORDERABLE ITEM (POI) file (50.7) "RTN","TMGNDFUT",134,0) ;"Input: IEN101d43 -- IEN in 101.43 "RTN","TMGNDFUT",135,0) ;" Array -- OPTIONAL. PASS BY REFERENCE. An OUT PARAMETER. Output format: "RTN","TMGNDFUT",136,0) ;" Array("IEN 101.43")=IEN "RTN","TMGNDFUT",137,0) ;" Array("IEN 101.43","NAME")=Name "RTN","TMGNDFUT",138,0) ;" Array("IEN 101.43","INACTIVE")=0 (or 1 if is inactivated) "RTN","TMGNDFUT",139,0) ;" Array("IEN 101.43","PACKAGE") = package ('99PSP' for pharmacy) "RTN","TMGNDFUT",140,0) ;" Array("IEN 101.44",IENS)="" "RTN","TMGNDFUT",141,0) ;" Array("IEN 50.7 from 22706.9","GENERIC")=IEN50d7 "RTN","TMGNDFUT",142,0) ;" Array("IEN 50.7 from 22706.9","TRADE")=IEN50d7 "RTN","TMGNDFUT",143,0) ;" Array("IEN 50.7 from 22706.9","GENERIC",IEN22706d9)=IEN50d7 "RTN","TMGNDFUT",144,0) ;" Array("IEN 50.7 from 22706.9","TRADE",IEN22706d9)=IEN50d7 "RTN","TMGNDFUT",145,0) ;" Array("IEN 50.7 from 101.43")=IEN50d7 "RTN","TMGNDFUT",146,0) ;" Array("IEN 50.7 from 101.43","NAME")=Name of 50.7, or "" if problem "RTN","TMGNDFUT",147,0) ;" Array("IEN 22706.9","GENERIC",IEN22706d9)="" "RTN","TMGNDFUT",148,0) ;" Array("IEN 22706.9","TRADE",IEN22706d9)="" "RTN","TMGNDFUT",149,0) ;"Output: See Array above. "RTN","TMGNDFUT",150,0) ;"Result: none "RTN","TMGNDFUT",151,0) "RTN","TMGNDFUT",152,0) new POIName set POIName="" "RTN","TMGNDFUT",153,0) new IEN22706d9 "RTN","TMGNDFUT",154,0) "RTN","TMGNDFUT",155,0) set Array("IEN 101.43")=IEN101d43 "RTN","TMGNDFUT",156,0) set Array("IEN 101.43","NAME")=$piece($get(^ORD(101.43,IEN101d43,0)),"^",1) "RTN","TMGNDFUT",157,0) set Array("IEN 101.43","INACTIVE")=$$OIInactive(IEN101d43) "RTN","TMGNDFUT",158,0) "RTN","TMGNDFUT",159,0) set IEN22706d9="" "RTN","TMGNDFUT",160,0) for set IEN22706d9=+$order(^TMG(22706.9,"OIG",IEN101d43,IEN22706d9)) quit:(+IEN22706d9'>0) do "RTN","TMGNDFUT",161,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDFUT",162,0) . new tempPtr set tempPtr=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4) ;" 8;4 =POI GENERIC LINK "RTN","TMGNDFUT",163,0) . set Array("IEN 50.7 from 22706.9","GENERIC",IEN22706d9)=tempPtr "RTN","TMGNDFUT",164,0) . set Array("IEN 22706.9","GENERIC",IEN22706d9)="" "RTN","TMGNDFUT",165,0) . set Array("IEN 50.7 from 22706.9","GENERIC")=tempPtr "RTN","TMGNDFUT",166,0) "RTN","TMGNDFUT",167,0) set IEN22706d9="" "RTN","TMGNDFUT",168,0) for set IEN22706d9=+$order(^TMG(22706.9,"OIT",IEN101d43,IEN22706d9)) quit:(+IEN22706d9'>0) do "RTN","TMGNDFUT",169,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 quit ;"1=SKIP "RTN","TMGNDFUT",170,0) . new tempPtr set tempPtr=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3) ;" 8;3 = POI TRADENAME LINK "RTN","TMGNDFUT",171,0) . set Array("IEN 50.7 from 22706.9","TRADE",IEN22706d9)=tempPtr "RTN","TMGNDFUT",172,0) . set Array("IEN 22706.9","TRADE",IEN22706d9)="" "RTN","TMGNDFUT",173,0) . set Array("IEN 50.7 from 22706.9","TRADE")=tempPtr "RTN","TMGNDFUT",174,0) "RTN","TMGNDFUT",175,0) ;"Get direct pointer to 50.7 "RTN","TMGNDFUT",176,0) new ID set ID=$piece($get(^ORD(101.43,IEN101d43,0)),"^",2) "RTN","TMGNDFUT",177,0) new pkg set pkg=$piece(ID,";",2) "RTN","TMGNDFUT",178,0) set Array("IEN 101.43","PACKAGE")=pkg "RTN","TMGNDFUT",179,0) "RTN","TMGNDFUT",180,0) new IEN50d7 "RTN","TMGNDFUT",181,0) if pkg="99PSP" do "RTN","TMGNDFUT",182,0) . set IEN50d7=+$piece(ID,";",1) "RTN","TMGNDFUT",183,0) . set POIName=$piece($get(^PS(50.7,IEN50d7,0)),"^",1) "RTN","TMGNDFUT",184,0) else do goto GPOIDone ;"not a pharmacy item. "RTN","TMGNDFUT",185,0) . set IEN50d7=0 "RTN","TMGNDFUT",186,0) . set POIName="" "RTN","TMGNDFUT",187,0) set Array("IEN 50.7 from 101.43")=IEN50d7 "RTN","TMGNDFUT",188,0) set Array("IEN 50.7 from 101.43","NAME")=POIName "RTN","TMGNDFUT",189,0) "RTN","TMGNDFUT",190,0) new IENS set IENS=$$GetOQVIENS(IEN101d43) "RTN","TMGNDFUT",191,0) set Array("IEN 101.44",IENS)="" "RTN","TMGNDFUT",192,0) "RTN","TMGNDFUT",193,0) GPOIDone "RTN","TMGNDFUT",194,0) quit "RTN","TMGNDFUT",195,0) "RTN","TMGNDFUT",196,0) "RTN","TMGNDFUT",197,0) ChkFixOI(Array) ;"NOTE: This function is not finished/debugged "RTN","TMGNDFUT",198,0) ;"Purpose: to check and fix pointers into and out of OI record "RTN","TMGNDFUT",199,0) ;"Input -- Array -- PASS BY REFERENCE. An Array as created by GetOIInfo "RTN","TMGNDFUT",200,0) ;" Array("IEN 101.43")=IEN "RTN","TMGNDFUT",201,0) ;" Array("IEN 101.43","NAME")=Name "RTN","TMGNDFUT",202,0) ;" Array("IEN 101.43","INACTIVE")=0 (or 1 if is inactivated) "RTN","TMGNDFUT",203,0) ;" Array("IEN 101.43","PACKAGE") = package ('99PSP' for pharmacy) "RTN","TMGNDFUT",204,0) ;" Array("IEN 101.44",IENS)="" "RTN","TMGNDFUT",205,0) ;" Array("IEN 50.7 from 22706.9","GENERIC")=IEN50d7 "RTN","TMGNDFUT",206,0) ;" Array("IEN 50.7 from 22706.9","TRADE")=IEN50d7 "RTN","TMGNDFUT",207,0) ;" Array("IEN 50.7 from 22706.9","GENERIC",IEN22706d9)=IEN50d7 "RTN","TMGNDFUT",208,0) ;" Array("IEN 50.7 from 22706.9","TRADE",IEN22706d9)=IEN50d7 "RTN","TMGNDFUT",209,0) ;" Array("IEN 50.7 from 101.43")=IEN50d7 "RTN","TMGNDFUT",210,0) ;" Array("IEN 50.7 from 101.43","NAME")=Name of 50.7, or "" if problem "RTN","TMGNDFUT",211,0) ;" Array("IEN 22706.9","GENERIC",IEN22706d9)="" "RTN","TMGNDFUT",212,0) ;" Array("IEN 22706.9","TRADE",IEN22706d9)="" "RTN","TMGNDFUT",213,0) ;"Result: none "RTN","TMGNDFUT",214,0) "RTN","TMGNDFUT",215,0) if $get(Array("IEN 101.43","INACTIVE"))=1 goto COIFDone "RTN","TMGNDFUT",216,0) "RTN","TMGNDFUT",217,0) new IEN101d43 set IEN101d43=+$get(Array("IEN 101.43")) "RTN","TMGNDFUT",218,0) new IEN50d7a set IEN50d7a=+$get(Array("IEN 50.7 from 101.43")) "RTN","TMGNDFUT",219,0) if IEN50d7a=0 do KillOI(IENE101d43) goto COIFDone "RTN","TMGNDFUT",220,0) "RTN","TMGNDFUT",221,0) new POIName set POIName=$get(Array("IEN 50.7 from 101.43","NAME")) "RTN","TMGNDFUT",222,0) new OIName set OIName=$get(Array("IEN 101.43","NAME")) "RTN","TMGNDFUT",223,0) "RTN","TMGNDFUT",224,0) new tPOI,gPOI "RTN","TMGNDFUT",225,0) set tPOI=+$get(Array("IEN 50.7 from 22706.9","TRADE")) "RTN","TMGNDFUT",226,0) set gPOI=+$get(Array("IEN 50.7 from 22706.9","GENERIC")) "RTN","TMGNDFUT",227,0) ;"For a given OI, see if there are two different POI's pointing to it via 22706.9 "RTN","TMGNDFUT",228,0) ;"There should be just TRADE ptrs or GENERIC ptrs, but not both. "RTN","TMGNDFUT",229,0) if (tPOI'=0)&(gPOI'=0)&(tPOI'=gPOI) do goto COIFDone ;"we have crossed chains. "RTN","TMGNDFUT",230,0) . ;"We need to make a new POI. But which chain gets new one? "RTN","TMGNDFUT",231,0) . new gPOIName,tPOIName,OIName "RTN","TMGNDFUT",232,0) . set gPOIName=$piece($get(^PS(50.7,gPOI,0)),"^",1) "RTN","TMGNDFUT",233,0) . set tPOIName=$piece($get(^PS(50.7,tPOI,0)),"^",1) "RTN","TMGNDFUT",234,0) . set OIName=$piece($get(^ORD(101.43,IEN101d43,0)),"^",1) "RTN","TMGNDFUT",235,0) . if gPOIName'=OIName do ;"make a new OI for generic chain "RTN","TMGNDFUT",236,0) . . new newOI set newOI=$$NewOI^TMGNDF4C(gPOIName) "RTN","TMGNDFUT",237,0) . . if newOI=0 quit ;"error "RTN","TMGNDFUT",238,0) . . new result set result=$$StuffOI^TMGNDF4C(newOI,gPOIName,,gPOI) "RTN","TMGNDFUT",239,0) . . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",240,0) . . for set IEN22706d9=$order(Array("IEN 50.7 from 22706.9","GENERIC",IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",241,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDFUT",242,0) . . . set TMGFDA(22706.9,IEN22706d9_",",5.711)=newOI "RTN","TMGNDFUT",243,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",244,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",245,0) . if tPOIName'=OIName do ;"make a new OI for trade chain "RTN","TMGNDFUT",246,0) . . new newOI set newOI=$$NewOI^TMGNDF4C(tPOIName) "RTN","TMGNDFUT",247,0) . . if newOI=0 quit ;"error "RTN","TMGNDFUT",248,0) . . new result set result=$$StuffOI^TMGNDF4C(newOI,tPOIName,,tPOI) "RTN","TMGNDFUT",249,0) . . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",250,0) . . for set IEN22706d9=$order(Array("IEN 50.7 from 22706.9","TRADE",IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",251,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDFUT",252,0) . . . set TMGFDA(22706.9,IEN22706d9_",",5.611)=newOI "RTN","TMGNDFUT",253,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",254,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",255,0) "RTN","TMGNDFUT",256,0) if ($data(Array("IEN 50.7 from 22706.9","GENERIC"))=0)&($data(Array("IEN 50.7 from 22706.9","TRADE"))=0) do "RTN","TMGNDFUT",257,0) . write "A linked record in 22706.9 NOT found pointing to 101.43 #",IEN101d43," (",OIName,")",! "RTN","TMGNDFUT",258,0) else do "RTN","TMGNDFUT",259,0) . new TMGIEN set TMGIEN="" "RTN","TMGNDFUT",260,0) . for set TMGIEN=$order(Array("IEN 50.7 from 22706.9","GENERIC",TMGIEN)) quit:(TMGIEN="") do "RTN","TMGNDFUT",261,0) . . new IEN50d7 set IEN50d7=+$get(Array("IEN 50.7 from 22706.9","GENERIC",TMGIEN)) "RTN","TMGNDFUT",262,0) . . write "Linked record in 22706.9 #",TMGIEN," (GENERIC pointer) points to 50.7 #",IEN50d7,! "RTN","TMGNDFUT",263,0) . set TMGIEN="" "RTN","TMGNDFUT",264,0) . for set TMGIEN=$order(Array("IEN 50.7 from 22706.9","TRADE",TMGIEN)) quit:(TMGIEN="") do "RTN","TMGNDFUT",265,0) . . new IEN50d7 set IEN50d7=+$get(Array("IEN 50.7 from 22706.9","TRADE",TMGIEN)) "RTN","TMGNDFUT",266,0) . . write "Linked record in 22706.9 #",TMGIEN," (TRADE pointer) points to 50.7 #",IEN50d7,! "RTN","TMGNDFUT",267,0) "RTN","TMGNDFUT",268,0) write " 101.43 #",IEN101d43," (",OIName,")",! "RTN","TMGNDFUT",269,0) write " points directly to 50.7 #",IEN50d7a," (",POIName,")",! "RTN","TMGNDFUT",270,0) if (IEN50d7a'=0),$$IsImport^TMGNDF4B(IEN50d7a) do "RTN","TMGNDFUT",271,0) . write " and that IS an active import record.",! "RTN","TMGNDFUT",272,0) . new IEN50Array "RTN","TMGNDFUT",273,0) . do GetDRUGs^TMGNDF4F(IEN50d7a,.IEN50Array,1) "RTN","TMGNDFUT",274,0) . write " Pointed to by these active records:",! "RTN","TMGNDFUT",275,0) . new name set name="" "RTN","TMGNDFUT",276,0) . for set name=$order(IEN50Array(name)) quit:(name="") do "RTN","TMGNDFUT",277,0) . . new IEN50 set IEN50="" "RTN","TMGNDFUT",278,0) . . for set IEN50=$order(IEN50Array(name,IEN50)) quit:(IEN50="") do "RTN","TMGNDFUT",279,0) . . . write " #",IEN50," ",name,! "RTN","TMGNDFUT",280,0) else do "RTN","TMGNDFUT",281,0) . write " and that IS NOT active import record.",! "RTN","TMGNDFUT",282,0) . do KillOI(IEN101d43) "RTN","TMGNDFUT",283,0) . write " .. Record in 101.43 deleted.",! "RTN","TMGNDFUT",284,0) "RTN","TMGNDFUT",285,0) COIFDone "RTN","TMGNDFUT",286,0) quit "RTN","TMGNDFUT",287,0) "RTN","TMGNDFUT",288,0) "RTN","TMGNDFUT",289,0) "RTN","TMGNDFUT",290,0) GetDRUGs(IEN50d7,IEN50Array,ActiveOnly) "RTN","TMGNDFUT",291,0) ;"Purpose: For a given IEN in PHARMACY ORDERABLE ITEM, return linked IEN to "RTN","TMGNDFUT",292,0) ;" DRUG file (50) "RTN","TMGNDFUT",293,0) ;"Input: IEN50d7 -- IEN in file 50.7 "RTN","TMGNDFUT",294,0) ;" IEN50Array -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",295,0) ;" IEN50Array(Name,IEN50)="" Name is from .01 field "RTN","TMGNDFUT",296,0) ;" IEN50Array(Name,IEN50)="" Name is from .01 field "RTN","TMGNDFUT",297,0) ;" ActiveOnly -- OPTIONAL, Default=1 "RTN","TMGNDFUT",298,0) ;"result: none. "RTN","TMGNDFUT",299,0) "RTN","TMGNDFUT",300,0) if +$get(IEN50d7)=0 goto GDsDone "RTN","TMGNDFUT",301,0) new tempA "RTN","TMGNDFUT",302,0) merge tempA=^TMG(22706.9,"POIG",IEN50d7) "RTN","TMGNDFUT",303,0) merge tempA=^TMG(22706.9,"POIT",IEN50d7) "RTN","TMGNDFUT",304,0) new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",305,0) for set IEN22706d9=$order(tempA(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",306,0) . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDFUT",307,0) . . write "?? PHARMACY ORDERABLE ITEM #",IEN50d7," points to skipped record!",! "RTN","TMGNDFUT",308,0) . new tIEN50,gIEN50 "RTN","TMGNDFUT",309,0) . set tIEN50=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDFUT",310,0) . if tIEN50>0 do "RTN","TMGNDFUT",311,0) . . new name set name=$piece($get(^PSDRUG(tIEN50,0)),"^",1) "RTN","TMGNDFUT",312,0) . . set IEN50Array(name,tIEN50)="" "RTN","TMGNDFUT",313,0) . set gIEN50=$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDFUT",314,0) . if gIEN50>0 do "RTN","TMGNDFUT",315,0) . . new name set name=$piece($get(^PSDRUG(gIEN50,0)),"^",1) "RTN","TMGNDFUT",316,0) . . set IEN50Array(name,gIEN50)="" "RTN","TMGNDFUT",317,0) "RTN","TMGNDFUT",318,0) ;"set ActiveOnly=1 "RTN","TMGNDFUT",319,0) ;"kill IEN50Array "RTN","TMGNDFUT",320,0) ;"new temp merge temp=^PSDRUG("ASP",IEN50d7) "RTN","TMGNDFUT",321,0) ;"new IEN set IEN="" "RTN","TMGNDFUT",322,0) ;"for set IEN=$order(temp(IEN)) quit:(IEN="") do "RTN","TMGNDFUT",323,0) ;". new Active set Active=($piece($get(^PSDRUG(IEN,"I")),"^",1)="") "RTN","TMGNDFUT",324,0) ;". if ActiveOnly,(Active=0) quit "RTN","TMGNDFUT",325,0) ;". new name set name=$$GET1^DIQ(50,IEN_",",.01) quit:(name="") "RTN","TMGNDFUT",326,0) ;". ;"set name="(#"_IEN_") "_name "RTN","TMGNDFUT",327,0) ;". new route set route=$$GET1^DIQ(50,IEN_",",62.02) "RTN","TMGNDFUT",328,0) ;". if route'="" set name=name_" "_route "RTN","TMGNDFUT",329,0) ;". set IEN50Array(name,IEN)="" "RTN","TMGNDFUT",330,0) GDsDone "RTN","TMGNDFUT",331,0) quit "RTN","TMGNDFUT",332,0) "RTN","TMGNDFUT",333,0) "RTN","TMGNDFUT",334,0) GetpDRUGs(IEN50d7,IEN50Array,ActiveOnly) "RTN","TMGNDFUT",335,0) ;"Purpose: For a given IEN in PHARMACY ORDERABLE ITEM, return linked IEN to "RTN","TMGNDFUT",336,0) ;" DRUG file (50) "RTN","TMGNDFUT",337,0) ;"Input: IEN50d7 -- IEN in file 50.7 "RTN","TMGNDFUT",338,0) ;" IEN50Array -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",339,0) ;" IEN50Array(IEN50)="" "RTN","TMGNDFUT",340,0) ;" IEN50Array(IEN50)="" "RTN","TMGNDFUT",341,0) ;" ActiveOnly -- OPTIONAL, Default=1 "RTN","TMGNDFUT",342,0) ;"result: none. "RTN","TMGNDFUT",343,0) "RTN","TMGNDFUT",344,0) set ActiveOnly=$get(ActiveOnly,1) "RTN","TMGNDFUT",345,0) new tempA "RTN","TMGNDFUT",346,0) merge tempA=^TMG(22706.9,"POIG",IEN50d7) "RTN","TMGNDFUT",347,0) merge tempA=^TMG(22706.9,"POIT",IEN50d7) "RTN","TMGNDFUT",348,0) new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",349,0) for set IEN22706d9=$order(tempA(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",350,0) . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)=1 do quit; 1= SKIP "RTN","TMGNDFUT",351,0) . . if ActiveOnly=1 quit "RTN","TMGNDFUT",352,0) . . write " Pointer to PHARMACY ORDERABLE ITEM #",IEN50d7," found in skipped 22706.9 #",IEN22706d9," record!",! "RTN","TMGNDFUT",353,0) . new tIEN50,gIEN50 "RTN","TMGNDFUT",354,0) . set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDFUT",355,0) . if tIEN50>0 set IEN50Array(tIEN50)="" "RTN","TMGNDFUT",356,0) . set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDFUT",357,0) . if gIEN50>0 set IEN50Array(gIEN50)="" "RTN","TMGNDFUT",358,0) "RTN","TMGNDFUT",359,0) ;"set ActiveOnly=1 "RTN","TMGNDFUT",360,0) ;"kill IEN50Array "RTN","TMGNDFUT",361,0) ;"new temp merge temp=^PSDRUG("ASP",IEN50d7) "RTN","TMGNDFUT",362,0) ;"new IEN set IEN="" "RTN","TMGNDFUT",363,0) ;"for set IEN=$order(temp(IEN)) quit:(IEN="") do "RTN","TMGNDFUT",364,0) ;". new Active set Active=($piece($get(^PSDRUG(IEN,"I")),"^",1)="") "RTN","TMGNDFUT",365,0) ;". if ActiveOnly,(Active=0) quit "RTN","TMGNDFUT",366,0) ;". set IEN50Array(IEN)="" "RTN","TMGNDFUT",367,0) "RTN","TMGNDFUT",368,0) quit "RTN","TMGNDFUT",369,0) "RTN","TMGNDFUT",370,0) "RTN","TMGNDFUT",371,0) GetfdaIEN(IEN50) "RTN","TMGNDFUT",372,0) ;"Purpose: to return the pointer to the record in 22706.9 that points to IEN50 "RTN","TMGNDFUT",373,0) ;"Input: IEN50 -- IEN in 50 "RTN","TMGNDFUT",374,0) ;"Results: returns a pointer, or 0 if not found "RTN","TMGNDFUT",375,0) "RTN","TMGNDFUT",376,0) new result "RTN","TMGNDFUT",377,0) set result=+$order(^TMG(22706.9,"DRUG",IEN50,"")) "RTN","TMGNDFUT",378,0) if result=0 set result=+$order(^TMG(22706.9,"DRUGT",IEN50,"")) "RTN","TMGNDFUT",379,0) quit result "RTN","TMGNDFUT",380,0) "RTN","TMGNDFUT",381,0) "RTN","TMGNDFUT",382,0) GetFDA(IEN50,FDA) "RTN","TMGNDFUT",383,0) ;"Purpose: For a given IEN in DRUG file, return linked IEN in "RTN","TMGNDFUT",384,0) ;" TMG FDA IMPORT COMPILED file (22706.9) "RTN","TMGNDFUT",385,0) ;"Input: IEN50 -- IEN in file 50 (DRUG) "RTN","TMGNDFUT",386,0) ;" FDA -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",387,0) ;" FDA=IEN in 22706.9 "RTN","TMGNDFUT",388,0) ;" FDA("NAME")=Name "RTN","TMGNDFUT",389,0) ;"result: none. "RTN","TMGNDFUT",390,0) "RTN","TMGNDFUT",391,0) set FDA=$$GetfdaIEN(IEN50) "RTN","TMGNDFUT",392,0) if FDA'=0 set FDA("NAME")=$$GET1^DIQ(22706.9,FDA_",",.04) "RTN","TMGNDFUT",393,0) quit "RTN","TMGNDFUT",394,0) "RTN","TMGNDFUT",395,0) "RTN","TMGNDFUT",396,0) GetDRUGIEN(IEN50d7) ;" -- DEPRECIATED. Use GetDRUGs^TMGNDFUT or GetpDRUGs^TMGNDFUT "RTN","TMGNDFUT",397,0) ;"Purpose: get linked record in DRUG file (50) for given record in 50.7 "RTN","TMGNDFUT",398,0) ;"Input:IEN50d7 -- IEN in 50.7 "RTN","TMGNDFUT",399,0) ;"Results: IEN in 50, or 0 if not found "RTN","TMGNDFUT",400,0) ;"NOTE: there may well be MULTIPLE records in 50 pointing to record in 50.7 "RTN","TMGNDFUT",401,0) ;" This function will only return the FIRST. "RTN","TMGNDFUT",402,0) ;" GetDRUGs^TMGNDF4F(IEN50d7,IEN50Array,ActiveOnly) -- will return ALL entries. "RTN","TMGNDFUT",403,0) "RTN","TMGNDFUT",404,0) new result "RTN","TMGNDFUT",405,0) set result=$order(^PSDRUG("ASP",IEN50d7,"")) "RTN","TMGNDFUT",406,0) quit result "RTN","TMGNDFUT",407,0) "RTN","TMGNDFUT",408,0) "RTN","TMGNDFUT",409,0) GetpTMG(IEN50d7,TMGArray,ActiveOnly) "RTN","TMGNDFUT",410,0) ;"Purpose: For a given IEN in PHARMACY ORDERABLE ITEM, return all IENs "RTN","TMGNDFUT",411,0) ;" in 22706.9 pointing to this "RTN","TMGNDFUT",412,0) ;"Input: IEN50d7 -- IEN in file 50.7 "RTN","TMGNDFUT",413,0) ;" IENTMGArray -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",414,0) ;" TMGArray(IEN22706d9)="" "RTN","TMGNDFUT",415,0) ;" TMGArray(IEN22706d9)="" "RTN","TMGNDFUT",416,0) ;" ActiveOnly -- OPTIONAL, Default=1 Only non-skipped records considered "RTN","TMGNDFUT",417,0) ;"result: none. "RTN","TMGNDFUT",418,0) "RTN","TMGNDFUT",419,0) merge TMGArray=^TMG(22706.9,"POIG",IEN50d7) "RTN","TMGNDFUT",420,0) merge TMGArray=^TMG(22706.9,"POIT",IEN50d7) "RTN","TMGNDFUT",421,0) "RTN","TMGNDFUT",422,0) if $get(ActiveOnly)=1 do "RTN","TMGNDFUT",423,0) . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",424,0) . for set IEN22706d9=$order(TMGArray(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",425,0) . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)'=1 quit ;"1=skip "RTN","TMGNDFUT",426,0) . . kill TMGArray(IEN22706d9) "RTN","TMGNDFUT",427,0) "RTN","TMGNDFUT",428,0) quit "RTN","TMGNDFUT",429,0) "RTN","TMGNDFUT",430,0) "RTN","TMGNDFUT",431,0) Getp1TMG(IEN101d43,TMGArray,ActiveOnly) "RTN","TMGNDFUT",432,0) ;"Purpose: For a given IEN in ORDERABLE ITEM, return all IENs "RTN","TMGNDFUT",433,0) ;" in 22706.9 pointing to this "RTN","TMGNDFUT",434,0) ;"Input: IEN101d43 -- IEN in file 101.43 "RTN","TMGNDFUT",435,0) ;" IENTMGArray -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",436,0) ;" TMGArray(IEN22706d9)="" "RTN","TMGNDFUT",437,0) ;" TMGArray(IEN22706d9)="" "RTN","TMGNDFUT",438,0) ;" ActiveOnly -- OPTIONAL, Default=1 Only non-skipped records considered "RTN","TMGNDFUT",439,0) ;"result: none. "RTN","TMGNDFUT",440,0) "RTN","TMGNDFUT",441,0) merge TMGArray=^TMG(22706.9,"OIG",IEN101d43) "RTN","TMGNDFUT",442,0) merge TMGArray=^TMG(22706.9,"OIT",IEN101d43) "RTN","TMGNDFUT",443,0) "RTN","TMGNDFUT",444,0) if $get(ActiveOnly)=1 do "RTN","TMGNDFUT",445,0) . new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",446,0) . for set IEN22706d9=$order(TMGArray(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",447,0) . . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)'=1 quit ;"1=skip "RTN","TMGNDFUT",448,0) . . kill TMGArray(IEN22706d9) "RTN","TMGNDFUT",449,0) "RTN","TMGNDFUT",450,0) quit "RTN","TMGNDFUT",451,0) "RTN","TMGNDFUT",452,0) Unlock50 "RTN","TMGNDFUT",453,0) ;"Purpose: Unlock fields needed to add data to 50 "RTN","TMGNDFUT",454,0) "RTN","TMGNDFUT",455,0) kill ^DD(50,20,8.5) "RTN","TMGNDFUT",456,0) kill ^DD(50,20,9) "RTN","TMGNDFUT",457,0) "RTN","TMGNDFUT",458,0) kill ^DD(50,21,8.5) "RTN","TMGNDFUT",459,0) kill ^DD(50,21,9) "RTN","TMGNDFUT",460,0) "RTN","TMGNDFUT",461,0) kill ^DD(50,22,8.5) "RTN","TMGNDFUT",462,0) kill ^DD(50,22,9) "RTN","TMGNDFUT",463,0) "RTN","TMGNDFUT",464,0) kill ^DD(50,25,8.5) "RTN","TMGNDFUT",465,0) kill ^DD(50,25,9) "RTN","TMGNDFUT",466,0) "RTN","TMGNDFUT",467,0) kill ^DD(50,29,8.5) "RTN","TMGNDFUT",468,0) kill ^DD(50,29,9) "RTN","TMGNDFUT",469,0) "RTN","TMGNDFUT",470,0) kill ^DD(50,902,8.5) "RTN","TMGNDFUT",471,0) kill ^DD(50,902,9) "RTN","TMGNDFUT",472,0) "RTN","TMGNDFUT",473,0) new node,nodeA,nodeB,node2 "RTN","TMGNDFUT",474,0) set node=$get(^DD(50,901,0)) "RTN","TMGNDFUT",475,0) set nodeA=$piece(node,"^",1,4) "RTN","TMGNDFUT",476,0) set nodeB="K:+X'=X!(X>99999999)!(X<0)!(X?.E1"".""5N.N) X" "RTN","TMGNDFUT",477,0) set node2=nodeA_"^"_nodeB "RTN","TMGNDFUT",478,0) set ^DD(50,901,0)=node2 "RTN","TMGNDFUT",479,0) "RTN","TMGNDFUT",480,0) quit "RTN","TMGNDFUT",481,0) "RTN","TMGNDFUT",482,0) Lock50 "RTN","TMGNDFUT",483,0) ;"Purpose: Return locks removed from Unlock50 in file 50 "RTN","TMGNDFUT",484,0) "RTN","TMGNDFUT",485,0) set ^DD(50,20,8.5)="^" "RTN","TMGNDFUT",486,0) set ^DD(50,20,9)="^" "RTN","TMGNDFUT",487,0) "RTN","TMGNDFUT",488,0) set ^DD(50,21,8.5)="^" "RTN","TMGNDFUT",489,0) set ^DD(50,21,9)="^" "RTN","TMGNDFUT",490,0) "RTN","TMGNDFUT",491,0) set ^DD(50,22,8.5)="^" "RTN","TMGNDFUT",492,0) set ^DD(50,22,9)="^" "RTN","TMGNDFUT",493,0) "RTN","TMGNDFUT",494,0) set ^DD(50,25,8.5)="^" "RTN","TMGNDFUT",495,0) set ^DD(50,25,9)="^" "RTN","TMGNDFUT",496,0) "RTN","TMGNDFUT",497,0) set ^DD(50,29,8.5)="^" "RTN","TMGNDFUT",498,0) set ^DD(50,29,9)="^" "RTN","TMGNDFUT",499,0) "RTN","TMGNDFUT",500,0) set ^DD(50,902,8.5)="^" "RTN","TMGNDFUT",501,0) set ^DD(50,902,9)="^" "RTN","TMGNDFUT",502,0) "RTN","TMGNDFUT",503,0) new node,nodeA,nodeB "RTN","TMGNDFUT",504,0) set node=$get(^DD(50,901,0)) "RTN","TMGNDFUT",505,0) set nodeA=$piece(node,"^",1,4) "RTN","TMGNDFUT",506,0) set nodeB="K:+X'=X!(X>99999999)!(X<0)!(X?.E1"".""5N.N)!('$P($G(^PSDRUG(DA,""DOS"")),""^"",2)) X" "RTN","TMGNDFUT",507,0) set node2=nodeA_"^"_nodeB "RTN","TMGNDFUT",508,0) set ^DD(50,901,0)=node2 "RTN","TMGNDFUT",509,0) "RTN","TMGNDFUT",510,0) quit "RTN","TMGNDFUT",511,0) "RTN","TMGNDFUT",512,0) "RTN","TMGNDFUT",513,0) GetpPOI(IEN50d7,Array,ActiveOnly) ;"!! NOTE: this is DIFFERENT from GetpOI or GetPOI!! "RTN","TMGNDFUT",514,0) ;"Purpose: For a given IEN in PHARMACY ORDERABLE ITEM, return all IENs "RTN","TMGNDFUT",515,0) ;" pointing to this, from 22706.9, 50, or 101.43 "RTN","TMGNDFUT",516,0) ;"Input: IEN50d7 -- IEN in file 50.7 "RTN","TMGNDFUT",517,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",518,0) ;" Array(File,IENS,field)="" "RTN","TMGNDFUT",519,0) ;" Array(File,IENS,field)="" "RTN","TMGNDFUT",520,0) ;" ActiveOnly -- OPTIONAL, Default=1 Only non-skipped records considered "RTN","TMGNDFUT",521,0) ;" *** NOT FULLY IMPLEMENTED YET *** "RTN","TMGNDFUT",522,0) ;"result: none. "RTN","TMGNDFUT",523,0) "RTN","TMGNDFUT",524,0) new TMGFDA,TMGMSG "RTN","TMGNDFUT",525,0) set ActiveOnly=$get(ActiveOnly,0) "RTN","TMGNDFUT",526,0) "RTN","TMGNDFUT",527,0) ;"Get links in 50 to POI record (from 22706.9 Xref) "RTN","TMGNDFUT",528,0) new IEN50Array "RTN","TMGNDFUT",529,0) do GetpDRUGs(IEN50d7,.IEN50Array,0) "RTN","TMGNDFUT",530,0) new IEN50 set IEN50="" "RTN","TMGNDFUT",531,0) for set IEN50=$order(IEN50Array(IEN50)) quit:(IEN50="") do "RTN","TMGNDFUT",532,0) . set Array(50,IEN50_",",2.1)="" "RTN","TMGNDFUT",533,0) "RTN","TMGNDFUT",534,0) ;"Get links in 50 to POI record (from 50 ASP Xref) "RTN","TMGNDFUT",535,0) new temp merge temp=^PSDRUG("ASP",IEN50d7) "RTN","TMGNDFUT",536,0) set IEN50="" "RTN","TMGNDFUT",537,0) for set IEN50=$order(temp(IEN50)) quit:(IEN50="") do "RTN","TMGNDFUT",538,0) . new Active set Active=($piece($get(^PSDRUG(IEN50,"I")),"^",1)="") "RTN","TMGNDFUT",539,0) . if (ActiveOnly=1)&(Active=0) quit "RTN","TMGNDFUT",540,0) . set Array(50,IEN50_",",2.1)="" "RTN","TMGNDFUT",541,0) "RTN","TMGNDFUT",542,0) ;"Get pointers in 22706.9 to POI record "RTN","TMGNDFUT",543,0) new TMGArray "RTN","TMGNDFUT",544,0) do GetpTMG(IEN50d7,.TMGArray,ActiveOnly) "RTN","TMGNDFUT",545,0) new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",546,0) for set IEN22706d9=$order(TMGArray(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",547,0) . if $piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3)=IEN50d7 do "RTN","TMGNDFUT",548,0) . . set Array(22706.9,IEN22706d9_",",5.61)="" "RTN","TMGNDFUT",549,0) . if $piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4)=IEN50d7 do "RTN","TMGNDFUT",550,0) . . set Array(22706.9,IEN22706d9_",",5.71)="" "RTN","TMGNDFUT",551,0) "RTN","TMGNDFUT",552,0) ;"Get text pointers in 101.43 to POI record "RTN","TMGNDFUT",553,0) new ID set ID=IEN50d7_";99PSP" "RTN","TMGNDFUT",554,0) new IEN101d43 set IEN101d43="" "RTN","TMGNDFUT",555,0) for set IEN101d43=$order(^ORD(101.43,"ID",ID,IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDFUT",556,0) . set Array(101.43,IEN101d43_",",2)="@" "RTN","TMGNDFUT",557,0) "RTN","TMGNDFUT",558,0) quit "RTN","TMGNDFUT",559,0) "RTN","TMGNDFUT",560,0) "RTN","TMGNDFUT",561,0) GetpOI(IEN101d43,Array,ActiveOnly) ;"!! NOTE: this is DIFFERENT from GetpPOI!! "RTN","TMGNDFUT",562,0) ;"Purpose: For a given IEN in ORDERABLE ITEM, return all IENs "RTN","TMGNDFUT",563,0) ;" pointing to this, from 22706.9, 50.7 101.44 "RTN","TMGNDFUT",564,0) ;"Input: IEN101d43 -- IEN in file 101.43 "RTN","TMGNDFUT",565,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. Format: "RTN","TMGNDFUT",566,0) ;" Array(File,IENS,field)="" "RTN","TMGNDFUT",567,0) ;" Array(File,IENS,field)="" "RTN","TMGNDFUT",568,0) ;" Array(File,IENS,"N/A")="" for 50.7 'pointers' "RTN","TMGNDFUT",569,0) ;" ActiveOnly -- OPTIONAL, Default=1 Only non-skipped records considered "RTN","TMGNDFUT",570,0) ;" *** NOT FULLY IMPLEMENTED YET *** "RTN","TMGNDFUT",571,0) ;"result: none. "RTN","TMGNDFUT",572,0) ;"Note: there is no direct pointer 50.7 --> 101.43 "RTN","TMGNDFUT",573,0) ;" Will use 101.43 <-- 22706.9 --> 50.7 to get 50.7 --> 101.43 "RTN","TMGNDFUT",574,0) "RTN","TMGNDFUT",575,0) new TMGFDA,TMGMSG "RTN","TMGNDFUT",576,0) set ActiveOnly=$get(ActiveOnly,0) "RTN","TMGNDFUT",577,0) "RTN","TMGNDFUT",578,0) ;"Get Pointers 101.44 --> 101.43 "RTN","TMGNDFUT",579,0) new all "RTN","TMGNDFUT",580,0) if $$GetOQVIENS(IEN101d43,.all)>0 do "RTN","TMGNDFUT",581,0) . new IENS set IENS="" "RTN","TMGNDFUT",582,0) . for set IENS=$order(all(IENS)) quit:(IENS="") do "RTN","TMGNDFUT",583,0) . . set Array(101.442,IENS,.01)="" "RTN","TMGNDFUT",584,0) "RTN","TMGNDFUT",585,0) ;"Get pointers in 22706.9 to 101.43/OI record "RTN","TMGNDFUT",586,0) ;" use to create pseudo pointers 50.7 --> 101.43 "RTN","TMGNDFUT",587,0) new TMGArray "RTN","TMGNDFUT",588,0) do Getp1TMG(IEN101d43,.TMGArray,ActiveOnly) "RTN","TMGNDFUT",589,0) new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",590,0) for set IEN22706d9=$order(TMGArray(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",591,0) . set IEN50d7=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3) ;"TRADE POI "RTN","TMGNDFUT",592,0) . if IEN50d7>0 set Array(50.7,IEN50d7_",","N/A")="" "RTN","TMGNDFUT",593,0) . set IEN50d7=+$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4) ;"GENERIC POI "RTN","TMGNDFUT",594,0) . if IEN50d7>0 set Array(50.7,IEN50d7_",","N/A")="" "RTN","TMGNDFUT",595,0) "RTN","TMGNDFUT",596,0) ;"Get Pointers in 22706.9 --> 101.43 "RTN","TMGNDFUT",597,0) new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",598,0) for set IEN22706d9=$order(TMGArray(IEN22706d9)) quit:(IEN22706d9="") do "RTN","TMGNDFUT",599,0) . if $piece($get(^TMG(22706.9,IEN22706d9,8)),"^",5)=IEN101d43 do "RTN","TMGNDFUT",600,0) . . set Array(22706.9,IEN22706d9_",",5.611)="" "RTN","TMGNDFUT",601,0) . if $piece($get(^TMG(22706.9,IEN22706d9,8)),"^",6)=IEN101d43 do "RTN","TMGNDFUT",602,0) . . set Array(22706.9,IEN22706d9_",",5.711)="" "RTN","TMGNDFUT",603,0) "RTN","TMGNDFUT",604,0) quit "RTN","TMGNDFUT",605,0) "RTN","TMGNDFUT",606,0) "RTN","TMGNDFUT",607,0) RedirOI(oldIEN,newIEN) "RTN","TMGNDFUT",608,0) ;"Purpose: to redirect pointers to ORDERABLE ITEM file from oldIEN to newIEN "RTN","TMGNDFUT",609,0) ;"Input: oldIEN -- IEN in ORDABLE ITEM (101.44) to switch FROM "RTN","TMGNDFUT",610,0) ;" newIEN -- IEN in ORDABLE ITEM (101.44) to switch TO "RTN","TMGNDFUT",611,0) ;"results: none. "RTN","TMGNDFUT",612,0) "RTN","TMGNDFUT",613,0) new Array "RTN","TMGNDFUT",614,0) do GetpOI(oldIEN,.Array) "RTN","TMGNDFUT",615,0) ;"redirect pointers to this record held in other files (50.7, 22706.9, or 101.442) "RTN","TMGNDFUT",616,0) new file set file="" "RTN","TMGNDFUT",617,0) for set file=$order(Array(file)) quit:(file="") do "RTN","TMGNDFUT",618,0) . new IENS set IENS="" "RTN","TMGNDFUT",619,0) . for set IENS=$order(Array(file,IENS)) quit:(IENS="") do "RTN","TMGNDFUT",620,0) . . new field set field="" "RTN","TMGNDFUT",621,0) . . for set field=$order(Array(file,IENS,field)) quit:(field="") do "RTN","TMGNDFUT",622,0) . . . if +field'=field quit ;"avoid "N/A" "RTN","TMGNDFUT",623,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDFUT",624,0) . . . set TMGFDA(file,IENS,field)=newIEN "RTN","TMGNDFUT",625,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",626,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",627,0) "RTN","TMGNDFUT",628,0) quit "RTN","TMGNDFUT",629,0) "RTN","TMGNDFUT",630,0) "RTN","TMGNDFUT",631,0) FindPOI(DrugNAF) "RTN","TMGNDFUT",632,0) ;"Purpose: to return IEN in PHARMACY ORDERABLE ITEM (50.7) matching drug name "RTN","TMGNDFUT",633,0) ;"Input: DrugNAF -- Drug name and form (e.g. LISINOPRIL TAB) "RTN","TMGNDFUT",634,0) ;"results: IEN in 50.7, or 0 if not found "RTN","TMGNDFUT",635,0) ;"Note: this will only return the FIRST such match. "RTN","TMGNDFUT",636,0) ;" Also, this is an EXACT match only. "RTN","TMGNDFUT",637,0) "RTN","TMGNDFUT",638,0) new result "RTN","TMGNDFUT",639,0) set result=+$order(^PS(50.7,"B",DrugNAF,"")) "RTN","TMGNDFUT",640,0) quit result "RTN","TMGNDFUT",641,0) "RTN","TMGNDFUT",642,0) "RTN","TMGNDFUT",643,0) FindOI(DrugNAF) "RTN","TMGNDFUT",644,0) ;"Purpose: to return IEN in ORDERABLE ITEM (101.43) matching drug name "RTN","TMGNDFUT",645,0) ;"Input: DrugNAF -- Drug name and form (e.g. LISINOPRIL TAB) "RTN","TMGNDFUT",646,0) ;"results: IEN in 101.43, or 0 if not found "RTN","TMGNDFUT",647,0) ;"Note: this will only return the FIRST such match. "RTN","TMGNDFUT",648,0) ;" Also, this is an EXACT match only. "RTN","TMGNDFUT",649,0) "RTN","TMGNDFUT",650,0) new result "RTN","TMGNDFUT",651,0) set result=+$order(^ORD(101.43,"B",DrugNAF,"")) "RTN","TMGNDFUT",652,0) quit result "RTN","TMGNDFUT",653,0) "RTN","TMGNDFUT",654,0) "RTN","TMGNDFUT",655,0) Kill50(IEN50,IEN22706d9,mode,quiet) "RTN","TMGNDFUT",656,0) ;"Purpose: to delete entry in file 50, and also links to it from 22706.9 "RTN","TMGNDFUT",657,0) ;"Input: IEN50 -- IEN in file 50 "RTN","TMGNDFUT",658,0) ;" IEN22706d9 -- IEn in 22706.9 "RTN","TMGNDFUT",659,0) ;" mode -- OPTIONAL-- "TRADE" or "GENERIC" "RTN","TMGNDFUT",660,0) ;" quiet -- OPTIONAL -- 1 = no message "RTN","TMGNDFUT",661,0) ;"Results: none "RTN","TMGNDFUT",662,0) ;"NOTE: Since file 50 is the head of a chain of drugs, it does not make "RTN","TMGNDFUT",663,0) ;" sense for 22706.9 to have a 0 pointer to 50, but still have pointers "RTN","TMGNDFUT",664,0) ;" to other entries in the chain (parts of which might be used by other "RTN","TMGNDFUT",665,0) ;" drugs). So I will also delete pointers to 50.7 and 101.43 "RTN","TMGNDFUT",666,0) ;" This could leave dangling records. I guess I will have to deal "RTN","TMGNDFUT",667,0) ;" with this elsewhere. "RTN","TMGNDFUT",668,0) ;" -- I WILL be deleting records in 50.7 (if not pointed to by other drugs) "RTN","TMGNDFUT",669,0) "RTN","TMGNDFUT",670,0) set IEN50=+$get(IEN50) "RTN","TMGNDFUT",671,0) if IEN50=0 goto K50Done "RTN","TMGNDFUT",672,0) "RTN","TMGNDFUT",673,0) set mode=$get(mode) "RTN","TMGNDFUT",674,0) set quiet=$get(quiet) "RTN","TMGNDFUT",675,0) "RTN","TMGNDFUT",676,0) ;"Get pointer to next link in chain, before deleting this link "RTN","TMGNDFUT",677,0) new IEN50d7 ;"50.7 = PHARMACY ORDERABLE ITEM. "RTN","TMGNDFUT",678,0) set IEN50d7=+$piece($get(^PSDRUG(IEN50,2)),"^",1) "RTN","TMGNDFUT",679,0) "RTN","TMGNDFUT",680,0) new TMGFDA,TMGMSG "RTN","TMGNDFUT",681,0) if (IEN50>0)&($data(^PSDRUG(IEN50))>0) do "RTN","TMGNDFUT",682,0) . set TMGFDA(50,IEN50_",",.01)="@" "RTN","TMGNDFUT",683,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDFUT",684,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",685,0) . if 'quiet write !,"DRUG entry (#",IEN50,") deleted: ",$get(DrugInfo("NAME",mode)) "RTN","TMGNDFUT",686,0) "RTN","TMGNDFUT",687,0) if mode="" do "RTN","TMGNDFUT",688,0) . new tIEN50 set tIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1) "RTN","TMGNDFUT",689,0) . new gIEN50 set gIEN50=+$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2) "RTN","TMGNDFUT",690,0) . if tIEN50=IEN50 set mode="TRADE" quit "RTN","TMGNDFUT",691,0) . if gIEN50=IEN50 set mode="GENERIC" quit "RTN","TMGNDFUT",692,0) "RTN","TMGNDFUT",693,0) if mode="TRADE" do "RTN","TMGNDFUT",694,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",1)>0 do "RTN","TMGNDFUT",695,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.6)="@" "RTN","TMGNDFUT",696,0) . . if 'quiet write " Link to trade drug from import #",IEN22706d9," removed.",! "RTN","TMGNDFUT",697,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",3)>0 do "RTN","TMGNDFUT",698,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.61)="@" "RTN","TMGNDFUT",699,0) . . if 'quiet write " Link to trade POI from import #",IEN22706d9," removed.",! "RTN","TMGNDFUT",700,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",5)>0 do "RTN","TMGNDFUT",701,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.611)="@" "RTN","TMGNDFUT",702,0) . . if 'quiet write " Link to trade OI from import #",IEN22706d9," removed.",! "RTN","TMGNDFUT",703,0) . new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDFUT",704,0) . if $data(TMGFDA)=0 quit "RTN","TMGNDFUT",705,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDFUT",706,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",707,0) "RTN","TMGNDFUT",708,0) if mode="GENERIC" do "RTN","TMGNDFUT",709,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,7)),"^",2)>0 do "RTN","TMGNDFUT",710,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.7)="@" "RTN","TMGNDFUT",711,0) . . if 'quiet write " Link to trade drug from import #",IEN22706d9," removed.",! "RTN","TMGNDFUT",712,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",4)>0 do "RTN","TMGNDFUT",713,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.71)="@" "RTN","TMGNDFUT",714,0) . . if 'quiet write " Link to generic POI from import #",IEN22706d9," removed.",! "RTN","TMGNDFUT",715,0) . if +$piece($get(^TMG(22706.9,IEN22706d9,8)),"^",6)>0 do "RTN","TMGNDFUT",716,0) . . set TMGFDA(22706.9,IEN22706d9_",",5.711)="@" "RTN","TMGNDFUT",717,0) . . if 'quiet write " Link to generic OI from import #",IEN22706d9," removed.",! "RTN","TMGNDFUT",718,0) . new temp set temp=$$TrimFDA^TMGDBAPI(.TMGFDA) "RTN","TMGNDFUT",719,0) . if $data(TMGFDA)=0 quit "RTN","TMGNDFUT",720,0) . do FILE^DIE("K","TMGFDA","TMGMSG") "RTN","TMGNDFUT",721,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",722,0) "RTN","TMGNDFUT",723,0) ;"See if any other DRUGs(50) are pointing to POI (50.7). If not kill POI "RTN","TMGNDFUT",724,0) if $order(^PSDRUG("ASP",IEN50d7,""))="" do "RTN","TMGNDFUT",725,0) . do KillPOI(IEN50d7) ;"will link forward to kill the rest of the chain "RTN","TMGNDFUT",726,0) "RTN","TMGNDFUT",727,0) K50Done quit "RTN","TMGNDFUT",728,0) "RTN","TMGNDFUT",729,0) "RTN","TMGNDFUT",730,0) KillPOI(IEN50d7) "RTN","TMGNDFUT",731,0) ;"Purpose: to remove a PHARMACY ORDERABLE ITEM (50.7), along with pointers "RTN","TMGNDFUT",732,0) ;" to it from files 50, 22706.9, 101.43 "RTN","TMGNDFUT",733,0) ;"NOTE: This function will also call subsequent functions to "RTN","TMGNDFUT",734,0) ;" kill records chained records in 101.43,101.44 "RTN","TMGNDFUT",735,0) ;"Results: none "RTN","TMGNDFUT",736,0) "RTN","TMGNDFUT",737,0) set IEN50d7=+$get(IEN50d7) "RTN","TMGNDFUT",738,0) if IEN50d7=0 goto KPOIdone "RTN","TMGNDFUT",739,0) ;"Get array of pointers to OI's from this POI record "RTN","TMGNDFUT",740,0) new OIArray,temp "RTN","TMGNDFUT",741,0) set temp=$$GetOI(IEN50d7,.OIArray) "RTN","TMGNDFUT",742,0) "RTN","TMGNDFUT",743,0) new Array "RTN","TMGNDFUT",744,0) do GetpPOI(IEN50d7,.Array,0) "RTN","TMGNDFUT",745,0) "RTN","TMGNDFUT",746,0) new PSSZ set PSSZ=1 ;"Key for editing 50 (?) "RTN","TMGNDFUT",747,0) do Unlock50 ;"if I relock here, may lock another function out. Will leave unlocked "RTN","TMGNDFUT",748,0) "RTN","TMGNDFUT",749,0) ;"Delete pointers to this record held in other files (50, 22706.9, or 101.43) "RTN","TMGNDFUT",750,0) new file set file="" "RTN","TMGNDFUT",751,0) for set file=$order(Array(file)) quit:(file="") do "RTN","TMGNDFUT",752,0) . if file=101.43 quit ;"ignore these, to be handled below "RTN","TMGNDFUT",753,0) . new IENS set IENS="" "RTN","TMGNDFUT",754,0) . for set IENS=$order(Array(file,IENS)) quit:(IENS="") do "RTN","TMGNDFUT",755,0) . . new field set field="" "RTN","TMGNDFUT",756,0) . . for set field=$order(Array(file,IENS,field)) quit:(field="") do "RTN","TMGNDFUT",757,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDFUT",758,0) . . . set TMGFDA(file,IENS,field)="@" "RTN","TMGNDFUT",759,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",760,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",761,0) "RTN","TMGNDFUT",762,0) ;"Delete the record itself. "RTN","TMGNDFUT",763,0) if $data(^PS(50.7,IEN50d7))'=0 do "RTN","TMGNDFUT",764,0) . new TMGFDA,TMGMSG "RTN","TMGNDFUT",765,0) . set TMGFDA(50.7,IEN50d7_",",.01)="@" "RTN","TMGNDFUT",766,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",767,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",768,0) "RTN","TMGNDFUT",769,0) ;"Kill chained records in OI "RTN","TMGNDFUT",770,0) new IEN101d43 set IEN101d43="" "RTN","TMGNDFUT",771,0) for set IEN101d43=$order(OIArray(IEN101d43)) quit:(IEN101d43="") do "RTN","TMGNDFUT",772,0) . do KillOI(IEN101d43) ;"Will chain forward to delete further records in chain. "RTN","TMGNDFUT",773,0) "RTN","TMGNDFUT",774,0) KPOIdone "RTN","TMGNDFUT",775,0) quit "RTN","TMGNDFUT",776,0) "RTN","TMGNDFUT",777,0) "RTN","TMGNDFUT",778,0) KillOI(IEN101d43) "RTN","TMGNDFUT",779,0) ;"Purpose: to remove an ORDERABLE ITEM, along with pointers to it "RTN","TMGNDFUT",780,0) ;" from files 50.7, 22706.9, 101.44 "RTN","TMGNDFUT",781,0) ;"Results: none "RTN","TMGNDFUT",782,0) "RTN","TMGNDFUT",783,0) set IEN101d43=+$get(IEN101d43) "RTN","TMGNDFUT",784,0) if IEN101d43=0 goto KOIDone "RTN","TMGNDFUT",785,0) "RTN","TMGNDFUT",786,0) new Array "RTN","TMGNDFUT",787,0) do GetpOI(IEN101d43,.Array,0) "RTN","TMGNDFUT",788,0) "RTN","TMGNDFUT",789,0) ;"Delete pointers to this record held in other files (50.7, 22706.9, or 101.442) "RTN","TMGNDFUT",790,0) new file set file="" "RTN","TMGNDFUT",791,0) for set file=$order(Array(file)) quit:(file="") do "RTN","TMGNDFUT",792,0) . if file=101.442 quit ;" ignore these... will handle below "RTN","TMGNDFUT",793,0) . new IENS set IENS="" "RTN","TMGNDFUT",794,0) . for set IENS=$order(Array(file,IENS)) quit:(IENS="") do "RTN","TMGNDFUT",795,0) . . new field set field="" "RTN","TMGNDFUT",796,0) . . for set field=$order(Array(file,IENS,field)) quit:(field="") do "RTN","TMGNDFUT",797,0) . . . if +field'=field quit ;"avoid "N/A" "RTN","TMGNDFUT",798,0) . . . new TMGFDA,TMGMSG "RTN","TMGNDFUT",799,0) . . . set TMGFDA(file,IENS,field)="@" "RTN","TMGNDFUT",800,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",801,0) . . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",802,0) "RTN","TMGNDFUT",803,0) ;"Delete record in 101.43 "RTN","TMGNDFUT",804,0) if $data(^ORD(101.43,IEN101d43))'=0 do "RTN","TMGNDFUT",805,0) . new TMGFDA,TMGMSG "RTN","TMGNDFUT",806,0) . set TMGFDA(101.43,IEN101d43_",",.01)="@" "RTN","TMGNDFUT",807,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",808,0) . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",809,0) "RTN","TMGNDFUT",810,0) ;"Delete chained records in 101.44 "RTN","TMGNDFUT",811,0) new OQVIENS set OQVIENS="" "RTN","TMGNDFUT",812,0) for set OQVIENS=$order(Array(101.442,OQVIENS)) quit:(OQVIENS="") do "RTN","TMGNDFUT",813,0) . do KillOQV(OQVIENS) "RTN","TMGNDFUT",814,0) "RTN","TMGNDFUT",815,0) KOIDone quit "RTN","TMGNDFUT",816,0) "RTN","TMGNDFUT",817,0) "RTN","TMGNDFUT",818,0) KillOQV(IENS) "RTN","TMGNDFUT",819,0) ;"Purpose: to kill/inactivate entry in ORDER QUICK VIEW (101.44) "RTN","TMGNDFUT",820,0) ;"Input: IENS -- the IENS entry locating record to 'kill' "RTN","TMGNDFUT",821,0) ;"Results: none "RTN","TMGNDFUT",822,0) ;"Note: for now, I am not going to actually delete the record, just "RTN","TMGNDFUT",823,0) ;" mark it as deleted "RTN","TMGNDFUT",824,0) "RTN","TMGNDFUT",825,0) new TMGFDA,TMGMSG "RTN","TMGNDFUT",826,0) set TMGFDA(101.442,IENS,.01)=0 "RTN","TMGNDFUT",827,0) set TMGFDA(101.442,IENS,2)="" "RTN","TMGNDFUT",828,0) do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGNDFUT",829,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGNDFUT",830,0) "RTN","TMGNDFUT",831,0) quit "RTN","TMGNDFUT",832,0) "RTN","TMGNDFUT",833,0) "RTN","TMGNDFUT",834,0) GetOQVIENS(IEN101d43,RxSet,Array) "RTN","TMGNDFUT",835,0) ;"Purpose: Scan in ORDER QUICK VIEW (101.44) for pointer to 101.43 "RTN","TMGNDFUT",836,0) ;"Input: IEN101d43 -- IEN in ORDERABLE ITEM (101.43) file "RTN","TMGNDFUT",837,0) ;" RxSet -- OPTIONAL -- the IEN of the ORWDSET O RX record in 101.44 "RTN","TMGNDFUT",838,0) ;" Array -- OPTIONAL. PASS BY REFERNCE. An OUT PARAMETER. "RTN","TMGNDFUT",839,0) ;" Will be filled with ALL pointers to 101.43. Format: "RTN","TMGNDFUT",840,0) ;" Array(IENS)="" "RTN","TMGNDFUT",841,0) ;"Result: IENS pointing to Entry in OQV (e.g. '104,57,'), or 0 if not found "RTN","TMGNDFUT",842,0) "RTN","TMGNDFUT",843,0) ;"If there happened to be 2 pointers to 101.43, this would only return "RTN","TMGNDFUT",844,0) ;" the FIRST one, but Array will return all pointers. "RTN","TMGNDFUT",845,0) "RTN","TMGNDFUT",846,0) ;"On my initial run index was empty. May need to programatically launch reindex in the future "RTN","TMGNDFUT",847,0) "RTN","TMGNDFUT",848,0) new result set result=0 "RTN","TMGNDFUT",849,0) if +$get(RxSet)=0 set RxSet=$$GetOQVSet "RTN","TMGNDFUT",850,0) if RxSet=0 goto GPrDone "RTN","TMGNDFUT",851,0) "RTN","TMGNDFUT",852,0) new IENS set IENS="" "RTN","TMGNDFUT",853,0) new OQVIEN set OQVIEN="" "RTN","TMGNDFUT",854,0) for set OQVIEN=$order(^ORD(101.44,RxSet,20,"B",IEN101d43,OQVIEN)) quit:(OQVIEN="") do "RTN","TMGNDFUT",855,0) . if +OQVIEN=0 quit "RTN","TMGNDFUT",856,0) . new tempIENS set tempIENS=OQVIEN_","_RxSet_"," "RTN","TMGNDFUT",857,0) . if result=0 set result=tempIENS "RTN","TMGNDFUT",858,0) . set Array(tempIENS)="" "RTN","TMGNDFUT",859,0) "RTN","TMGNDFUT",860,0) GPrDone quit result "RTN","TMGNDFUT",861,0) "RTN","TMGNDFUT",862,0) "RTN","TMGNDFUT",863,0) "RTN","TMGNDFUT",864,0) GetOQVSet(quiet) "RTN","TMGNDFUT",865,0) ;"Purpose: get the active RxSet in ORDER QUICK VIEW (101.44) "RTN","TMGNDFUT",866,0) ;"Input: quiet -- OPTIONAL. If 1, then no error message "RTN","TMGNDFUT",867,0) ;"results: returns RxSet, or 0 if problem. "RTN","TMGNDFUT",868,0) "RTN","TMGNDFUT",869,0) set quiet=+$get(quiet) "RTN","TMGNDFUT",870,0) new DIC,X,Y "RTN","TMGNDFUT",871,0) set DIC=101.44 "RTN","TMGNDFUT",872,0) set X="ORWDSET O RX" "RTN","TMGNDFUT",873,0) do ^DIC "RTN","TMGNDFUT",874,0) if +Y'>0 do "RTN","TMGNDFUT",875,0) . if quiet quit "RTN","TMGNDFUT",876,0) . write "Can't find record 'ORWDSET O RX' in ORDER QUICK VIEW (101.44) file.",! "RTN","TMGNDFUT",877,0) "RTN","TMGNDFUT",878,0) quit +Y "RTN","TMGNDFUT",879,0) "RTN","TMGNDFUT",880,0) "RTN","TMGNDFUT",881,0) OIInactive(IEN101d43) "RTN","TMGNDFUT",882,0) ;"Purpose -- Return if record has a past-due inactive date "RTN","TMGNDFUT",883,0) ;"Input: IEN101d43 -- IEn in 101.43 "RTN","TMGNDFUT",884,0) ;"Results: 0 -- not inactive, 1 is inactive "RTN","TMGNDFUT",885,0) "RTN","TMGNDFUT",886,0) new date set date=$piece($get(^ORD(101.43,IEN101d43,.1)),"^",1) "RTN","TMGNDFUT",887,0) new pastInactiveDate set pastInactiveDate=0 "RTN","TMGNDFUT",888,0) if date'="" do "RTN","TMGNDFUT",889,0) . new X,Y set X="NOW" do ^%DT ;"results in Y "RTN","TMGNDFUT",890,0) . new X1,X2 "RTN","TMGNDFUT",891,0) . set X1=Y,X2=date "RTN","TMGNDFUT",892,0) . do ^%DTC ;"result is X=X1-X2 (X=NOW-InactiveDate) X>-1 means past inactive date "RTN","TMGNDFUT",893,0) . set pastInactiveDate=(X>-1) "RTN","TMGNDFUT",894,0) "RTN","TMGNDFUT",895,0) quit pastInactiveDate "RTN","TMGNDFUT",896,0) "RTN","TMGNDFUT",897,0) "RTN","TMGNDFUT",898,0) IsImport(IEN50d7) "RTN","TMGNDFUT",899,0) ;"Purpose: To determine if the POI record is one linked to a FDA import "RTN","TMGNDFUT",900,0) ;"Input: IEN50d7 -- IEN in 50.7 "RTN","TMGNDFUT",901,0) ;"Results: 1 if linked to a DRUG entry that is linked to an NON-SKIPPED "RTN","TMGNDFUT",902,0) ;" record in 22706.9 "RTN","TMGNDFUT",903,0) ;" 0 otherwise "RTN","TMGNDFUT",904,0) ;"Addendum: This function will be changed slightly, to such that it returns "RTN","TMGNDFUT",905,0) ;" 1 if linked to an entry in 22706.9 that is NON-SKIPPED "RTN","TMGNDFUT",906,0) "RTN","TMGNDFUT",907,0) new result set result=0 "RTN","TMGNDFUT",908,0) new IEN22706d9 set IEN22706d9="" "RTN","TMGNDFUT",909,0) for set IEN22706d9=$order(^TMG(22706.9,"POIT",IEN50d7,IEN22706d9)) quit:(IEN22706d9="")!(result=1) do "RTN","TMGNDFUT",910,0) . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)'=1 set result=1 "RTN","TMGNDFUT",911,0) "RTN","TMGNDFUT",912,0) if result=1 goto IIDone "RTN","TMGNDFUT",913,0) "RTN","TMGNDFUT",914,0) for set IEN22706d9=$order(^TMG(22706.9,"POIG",IEN50d7,IEN22706d9)) quit:(IEN22706d9="")!(result=1) do "RTN","TMGNDFUT",915,0) . if $piece($get(^TMG(22706.9,IEN22706d9,1)),"^",4)'=1 set result=1 "RTN","TMGNDFUT",916,0) "RTN","TMGNDFUT",917,0) goto IIDone "RTN","TMGNDFUT",918,0) "RTN","TMGNDFUT",919,0) ;"==== old code, delete later "RTN","TMGNDFUT",920,0) new result set result=0 "RTN","TMGNDFUT",921,0) new IEN50Array "RTN","TMGNDFUT",922,0) do GetpDRUGs^TMGNDFUT(IEN50d7,.IEN50Array,1) "RTN","TMGNDFUT",923,0) new IEN50 set IEN50="" "RTN","TMGNDFUT",924,0) for set IEN50=$order(IEN50Array(IEN50)) quit:(IEN50="")!(result=1) do "RTN","TMGNDFUT",925,0) . new fdaIEN set fdaIEN=$$GetfdaIEN^TMGNDFUT(IEN50) if fdaIEN'>0 quit "RTN","TMGNDFUT",926,0) . if $piece($get(^TMG(22706.9,fdaIEN,1)),"^",4)'=1 set result=1 "RTN","TMGNDFUT",927,0) IIDone "RTN","TMGNDFUT",928,0) quit result "RTN","TMGNDFUT",929,0) "RTN","TMGNDFUT",930,0) "RTN","TMGPRNTR") 0^66^B9035 "RTN","TMGPRNTR",1,0) TMGPRNTR ;TMG/kst/Printer API Fns ;03/25/06 "RTN","TMGPRNTR",2,0) ;;1.0;TMG-LIB;**1**;04/25/04 "RTN","TMGPRNTR",3,0) "RTN","TMGPRNTR",4,0) ;"TMG PRINTER API FUNCTIONS "RTN","TMGPRNTR",5,0) ;"Kevin Toppenberg MD "RTN","TMGPRNTR",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGPRNTR",7,0) "RTN","TMGPRNTR",8,0) ;"======================================================================= "RTN","TMGPRNTR",9,0) ;" API -- Public Functions. "RTN","TMGPRNTR",10,0) ;"======================================================================= "RTN","TMGPRNTR",11,0) "RTN","TMGPRNTR",12,0) ;"MatchPrt(Printers) "RTN","TMGPRNTR",13,0) "RTN","TMGPRNTR",14,0) ;"======================================================================= "RTN","TMGPRNTR",15,0) ;" Functions Used During Printing Process "RTN","TMGPRNTR",16,0) ;"======================================================================= "RTN","TMGPRNTR",17,0) ;"SETJOB(Filename) "RTN","TMGPRNTR",18,0) ;"FINISH(Printer) "RTN","TMGPRNTR",19,0) "RTN","TMGPRNTR",20,0) "RTN","TMGPRNTR",21,0) ;"Dependancies "RTN","TMGPRNTR",22,0) ;" TMGXDLG.m "RTN","TMGPRNTR",23,0) ;"======================================================================= "RTN","TMGPRNTR",24,0) ;"Private Functions "RTN","TMGPRNTR",25,0) ;"======================================================================= "RTN","TMGPRNTR",26,0) ;"GetPrinters^TMGPRNTR(Printers) "RTN","TMGPRNTR",27,0) ;"GetPrtDefs(PrtDefs) "RTN","TMGPRNTR",28,0) ;"PickPrtDef(LinuxPrt,PrtDefs,Output) "RTN","TMGPRNTR",29,0) "RTN","TMGPRNTR",30,0) "RTN","TMGPRNTR",31,0) "RTN","TMGPRNTR",32,0) GetPrinters(Printers) "RTN","TMGPRNTR",33,0) ;"Purpose: To interact with Redhat 9 Linux printer system and get a list "RTN","TMGPRNTR",34,0) ;" of defined printers "RTN","TMGPRNTR",35,0) ;"Input: (Printers is an OUT variable. MUST PASS BY REFERENCE "RTN","TMGPRNTR",36,0) ;"Output: Printers variable will be filled like this: "RTN","TMGPRNTR",37,0) ;" Printers(0,"COUNT")=2 "RTN","TMGPRNTR",38,0) ;" Printers(1)="Deskjet1" "RTN","TMGPRNTR",39,0) ;" Printers(2)="Laser1" "RTN","TMGPRNTR",40,0) ;"result: 1=OkToCont 0=Abort "RTN","TMGPRNTR",41,0) "RTN","TMGPRNTR",42,0) ;"Notes: Here is a simple way to get the available printers from the CUPS system "RTN","TMGPRNTR",43,0) ;"#lpstat -p >/tmp/DefinedPrinters.txt "RTN","TMGPRNTR",44,0) ;"#cat DefinedPrinters.txt "RTN","TMGPRNTR",45,0) ;"printer Laser is idle. enabled since Jan 01 00:00 "RTN","TMGPRNTR",46,0) ;"--notice that in this case "Laser" is the name of the printer. There is only 1 printer. "RTN","TMGPRNTR",47,0) ;"This printer could be used like this: "RTN","TMGPRNTR",48,0) ;"lp -d Laser MyFile.txt "RTN","TMGPRNTR",49,0) "RTN","TMGPRNTR",50,0) "RTN","TMGPRNTR",51,0) new Cmd,HookCmd "RTN","TMGPRNTR",52,0) new FileHandle "RTN","TMGPRNTR",53,0) new CmdResult "RTN","TMGPRNTR",54,0) new lpReport "RTN","TMGPRNTR",55,0) new index,PrtIndex "RTN","TMGPRNTR",56,0) new PrinterCount set PrinterCount=0 "RTN","TMGPRNTR",57,0) new cOKToCont set cOKToCont=1 "RTN","TMGPRNTR",58,0) new cAbort set cAbort=0 "RTN","TMGPRNTR",59,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGPRNTR",60,0) "RTN","TMGPRNTR",61,0) new result set result=cOKToCont "RTN","TMGPRNTR",62,0) "RTN","TMGPRNTR",63,0) if TMGDEBUG>0 do Entry^TMGDEBUG(.DBIndent,"GetPrinters") "RTN","TMGPRNTR",64,0) "RTN","TMGPRNTR",65,0) new CommFPath set CommFPath="/tmp/" "RTN","TMGPRNTR",66,0) new CommFName set CommFName="M_Printer_comm_"_$J_".tmp" "RTN","TMGPRNTR",67,0) new CommFile set CommFile=CommFPath_CommFName "RTN","TMGPRNTR",68,0) "RTN","TMGPRNTR",69,0) set HookCmd="lpstat -p>"_CommFile "RTN","TMGPRNTR",70,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGPRNTR",71,0) zsystem HookCmd "RTN","TMGPRNTR",72,0) "RTN","TMGPRNTR",73,0) set CmdResult=$ZSYSTEM&255 ;"get result of execution. (low byte only) "RTN","TMGPRNTR",74,0) ;"write "CmdResult=",CmdResult,! ;"1=error "RTN","TMGPRNTR",75,0) if CmdResult=0 set result=cOKToCont else set result=cAbort goto GPDone "RTN","TMGPRNTR",76,0) "RTN","TMGPRNTR",77,0) ;"Read output info Results "RTN","TMGPRNTR",78,0) set FileHandle=$$FTG^%ZISH(CommFPath,CommFName,$name(lpReport("LIST")),3) "RTN","TMGPRNTR",79,0) ;"zwr lpReport(*) "RTN","TMGPRNTR",80,0) "RTN","TMGPRNTR",81,0) ;"Now kill the communication file... no longer needed. "RTN","TMGPRNTR",82,0) new FileSpec "RTN","TMGPRNTR",83,0) set FileSpec(CommFile)="" "RTN","TMGPRNTR",84,0) set result=$$DEL^%ZISH(CommFPath,$name(FileSpec)) "RTN","TMGPRNTR",85,0) "RTN","TMGPRNTR",86,0) set index="" "RTN","TMGPRNTR",87,0) for do quit:(index="") "RTN","TMGPRNTR",88,0) . new s "RTN","TMGPRNTR",89,0) . set s=$get(lpReport("LIST",index)) "RTN","TMGPRNTR",90,0) . if s="" quit "RTN","TMGPRNTR",91,0) . new Prt set Prt=$piece(s," ",2) "RTN","TMGPRNTR",92,0) . if Prt'="" do "RTN","TMGPRNTR",93,0) . . set PrinterCount=PrinterCount+1 "RTN","TMGPRNTR",94,0) . . set Printers(PrinterCount)=Prt "RTN","TMGPRNTR",95,0) . set index=$order(lpReport("LIST",index)) "RTN","TMGPRNTR",96,0) "RTN","TMGPRNTR",97,0) ;"if $data(Printers) zwr Printers(*) "RTN","TMGPRNTR",98,0) ;"w "done" "RTN","TMGPRNTR",99,0) "RTN","TMGPRNTR",100,0) GPDone "RTN","TMGPRNTR",101,0) set Printers(0,"COUNT")=PrinterCount "RTN","TMGPRNTR",102,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetPrinters") "RTN","TMGPRNTR",103,0) "RTN","TMGPRNTR",104,0) quit result "RTN","TMGPRNTR",105,0) "RTN","TMGPRNTR",106,0) "RTN","TMGPRNTR",107,0) GetPrtDefs(PrtDefs) "RTN","TMGPRNTR",108,0) ;"Purpose: To get a list of printer definitions (i.e. TERMINAL TYPES) "RTN","TMGPRNTR",109,0) ;"Input: PrtDefs -- SHOULD BE PASSED BY REFERENCE to receive results. "RTN","TMGPRNTR",110,0) ;"Output: (PrtDefs is changed) "RTN","TMGPRNTR",111,0) ;" PrtDefs(0,"COUNT")=12 "RTN","TMGPRNTR",112,0) ;" PrtDefs(1,"NAME")="P-ANADEX" "RTN","TMGPRNTR",113,0) ;" PrtDefs(1,"DESCRIPTION")="ANADEX PRINTER 10P" "RTN","TMGPRNTR",114,0) ;" PrtDefs(2,"NAME")="P-CENT" "RTN","TMGPRNTR",115,0) ;" PrtDefs(2,"DESCRIPTION")="Centronix printer" "RTN","TMGPRNTR",116,0) ;" ... etc. "RTN","TMGPRNTR",117,0) ;"Result: 1=OKToCont 0=Abort "RTN","TMGPRNTR",118,0) "RTN","TMGPRNTR",119,0) ;"TERMINAL TYPE if file 3.2 "RTN","TMGPRNTR",120,0) "RTN","TMGPRNTR",121,0) new cOKToCont set cOKToCont=1 "RTN","TMGPRNTR",122,0) new cAbort set cAbort=0 "RTN","TMGPRNTR",123,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGPRNTR",124,0) "RTN","TMGPRNTR",125,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetPrtDefs") "RTN","TMGPRNTR",126,0) "RTN","TMGPRNTR",127,0) new Matches,Msg "RTN","TMGPRNTR",128,0) if $data(PriorErrorFound)=0 new PriorErrorFound "RTN","TMGPRNTR",129,0) if $data(DBIndent)=0 new DBIndent set DBIndent=0 "RTN","TMGPRNTR",130,0) new NumMatches,index "RTN","TMGPRNTR",131,0) new PrtCount set PrtCount=0 "RTN","TMGPRNTR",132,0) new result set result=cOKToCont "RTN","TMGPRNTR",133,0) new MatchValue set MatchValue="P-" "RTN","TMGPRNTR",134,0) "RTN","TMGPRNTR",135,0) ;"====================================================== "RTN","TMGPRNTR",136,0) ;"Call FIND^DIC "RTN","TMGPRNTR",137,0) ;"====================================================== "RTN","TMGPRNTR",138,0) ;"Params: "RTN","TMGPRNTR",139,0) ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS "RTN","TMGPRNTR",140,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"FIND^DIC") "RTN","TMGPRNTR",141,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(.DBIndent," MatchValue=",MatchValue) "RTN","TMGPRNTR",142,0) do FIND^DIC("3.2","","@;.01","",MatchValue,"*",,"",,"Matches","Msg") "RTN","TMGPRNTR",143,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"FIND^DIC") "RTN","TMGPRNTR",144,0) ;"====================================================== "RTN","TMGPRNTR",145,0) ;"====================================================== "RTN","TMGPRNTR",146,0) "RTN","TMGPRNTR",147,0) if $data(Msg("DIERR"))'=0 do goto GPDDone "RTN","TMGPRNTR",148,0) . do ShowDIERR^TMGDEBUG(.Msg,.PriorErrorFound) "RTN","TMGPRNTR",149,0) . set result=cAbort "RTN","TMGPRNTR",150,0) "RTN","TMGPRNTR",151,0) if $data(Matches) do "RTN","TMGPRNTR",152,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here are Matches entries") "RTN","TMGPRNTR",153,0) . if TMGDEBUG>0 do ArrayDump^TMGDEBUG("Matches") "RTN","TMGPRNTR",154,0) "RTN","TMGPRNTR",155,0) if $data(Matches("DILIST"))=0 goto GPDDone "RTN","TMGPRNTR",156,0) "RTN","TMGPRNTR",157,0) set NumMatches=$piece(Matches("DILIST",0),"^",1) "RTN","TMGPRNTR",158,0) kill PrtDefs "RTN","TMGPRNTR",159,0) set PrtDefs(0,"COUNT")=NumMatches "RTN","TMGPRNTR",160,0) if NumMatches=0 goto GPDDone ;"keep RecNumIEN default of 0 "RTN","TMGPRNTR",161,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here are Matches entries") "RTN","TMGPRNTR",162,0) if TMGDEBUG>0 do ArrayDump^TMGDEBUG("Matches") "RTN","TMGPRNTR",163,0) "RTN","TMGPRNTR",164,0) for index=1:1:NumMatches do "RTN","TMGPRNTR",165,0) . kill OneMatch "RTN","TMGPRNTR",166,0) . new Name,Descr "RTN","TMGPRNTR",167,0) . set Name=$get(Matches("DILIST","ID",index,.01)) "RTN","TMGPRNTR",168,0) . set Descr=$get(^%ZIS(2,index,9)) "RTN","TMGPRNTR",169,0) . set PrtDefs(index,"NAME")=Name "RTN","TMGPRNTR",170,0) . set PrtDefs(index,"DESCRIPTION")=Descr "RTN","TMGPRNTR",171,0) "RTN","TMGPRNTR",172,0) GPDDone "RTN","TMGPRNTR",173,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetPrtDefs") "RTN","TMGPRNTR",174,0) quit result "RTN","TMGPRNTR",175,0) "RTN","TMGPRNTR",176,0) "RTN","TMGPRNTR",177,0) PickPrtDef(LinuxPrt,PrtDefs,Output) "RTN","TMGPRNTR",178,0) ;"Purpose: To show all the printer types (TERMINAL TYPES), and have user pick one "RTN","TMGPRNTR",179,0) ;"Input: LinuxPrt -- name of Linux printer, as retrieved from GetPrinters() "RTN","TMGPRNTR",180,0) ;" PrtDefs -- Array of printer defs, as returned from GetPrtDefs(PrtDefs) "RTN","TMGPRNTR",181,0) ;" Array will not be changed, even if passed by reference. "RTN","TMGPRNTR",182,0) ;" Output -- MUST BE PASSED BY REFERENCE. Will be formated like this: "RTN","TMGPRNTR",183,0) ;" Output(0,"COUNT")=1 "RTN","TMGPRNTR",184,0) ;" Output(1,"LINUX")="Laser1" <----- Prior results "RTN","TMGPRNTR",185,0) ;" Output(1,"TYPE")="P-ANADEX" "RTN","TMGPRNTR",186,0) ;"Output: Output -- MUST BE PASSED BY REFERENCE. Output will be formated like this: "RTN","TMGPRNTR",187,0) ;" Output(0,"COUNT")=2 "RTN","TMGPRNTR",188,0) ;" Output(1,"LINUX")="Laser1" <----- Prior results "RTN","TMGPRNTR",189,0) ;" Output(1,"TYPE")="P-ANADEX" "RTN","TMGPRNTR",190,0) ;" Output(2,"LINUX")="Printer2" <----- Added results "RTN","TMGPRNTR",191,0) ;" Output(2,"TYPE")="P-CENT" "RTN","TMGPRNTR",192,0) ;"Result: 1=OKToCont 0=Abort, OR Cancel pressed. "RTN","TMGPRNTR",193,0) "RTN","TMGPRNTR",194,0) new cOKToCont set cOKToCont=1 "RTN","TMGPRNTR",195,0) new cAbort set cAbort=0 "RTN","TMGPRNTR",196,0) new result set result=cAbort "RTN","TMGPRNTR",197,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGPRNTR",198,0) new tPrtDefs "RTN","TMGPRNTR",199,0) new DefCount,OutCount "RTN","TMGPRNTR",200,0) new index "RTN","TMGPRNTR",201,0) new UserPick "RTN","TMGPRNTR",202,0) "RTN","TMGPRNTR",203,0) set DefCount=$get(PrtDefs(0,"COUNT"),0) "RTN","TMGPRNTR",204,0) if DefCount=0 do goto PPDefDone "RTN","TMGPRNTR",205,0) . write "No printer defs! Quitting!",! "RTN","TMGPRNTR",206,0) set OutCount=$get(Output(0,"COUNT"),0) "RTN","TMGPRNTR",207,0) Set Output(0,"COUNT")=OutCount ;"Ensure this is set before any need to abort "RTN","TMGPRNTR",208,0) "RTN","TMGPRNTR",209,0) for index=1:1:DefCount do "RTN","TMGPRNTR",210,0) . new s,Name,Descr "RTN","TMGPRNTR",211,0) . set s=index_"; " "RTN","TMGPRNTR",212,0) . set Name=$get(PrtDefs(index,"NAME")) "RTN","TMGPRNTR",213,0) . ;"write "converted: ",Name," to " "RTN","TMGPRNTR",214,0) . set Name=$extract(Name,3,128) "RTN","TMGPRNTR",215,0) . ;"write Name,! "RTN","TMGPRNTR",216,0) . set Descr=$get(PrtDefs(index,"DESCRIPTION")) "RTN","TMGPRNTR",217,0) . set s=s_Name "RTN","TMGPRNTR",218,0) . if Descr'="" set s=s_Name_" -- "_Descr "RTN","TMGPRNTR",219,0) . set tPrtDefs(index)=s "RTN","TMGPRNTR",220,0) "RTN","TMGPRNTR",221,0) new s set s="---- Pick VistA driver for printer '"_LinuxPrt_"' ----\n\n" "RTN","TMGPRNTR",222,0) set s=s_"(Note: If you can not find an corresponding driver for your\n" "RTN","TMGPRNTR",223,0) set s=s_"printer, then see your installer regarding adding an\n" "RTN","TMGPRNTR",224,0) set s=s_"appropriate entry to the TERMINAL TYPE file, then retry.)" "RTN","TMGPRNTR",225,0) set UserPick=$$Combo^TMGXDLG(s,80,15,.tPrtDefs) "RTN","TMGPRNTR",226,0) if UserPick="" goto PPDefDone "RTN","TMGPRNTR",227,0) set index=+$piece(UserPick,";",1) "RTN","TMGPRNTR",228,0) if index=0 goto PPDefDone "RTN","TMGPRNTR",229,0) set OutCount=OutCount+1 "RTN","TMGPRNTR",230,0) "RTN","TMGPRNTR",231,0) set Output(OutCount,"LINUX")=LinuxPrt "RTN","TMGPRNTR",232,0) set Output(OutCount,"TYPE")=PrtDefs(index,"NAME") "RTN","TMGPRNTR",233,0) Set Output(0,"COUNT")=OutCount "RTN","TMGPRNTR",234,0) "RTN","TMGPRNTR",235,0) set result=cOKToCont "RTN","TMGPRNTR",236,0) PPDefDone "RTN","TMGPRNTR",237,0) quit result "RTN","TMGPRNTR",238,0) "RTN","TMGPRNTR",239,0) "RTN","TMGPRNTR",240,0) "RTN","TMGPRNTR",241,0) MatchPrt(Output) "RTN","TMGPRNTR",242,0) ;"Purpose: To create match between Linux printers, and definitions "RTN","TMGPRNTR",243,0) ;"Input: Output -- and out parameter. MUST BE PASSED BY REFERENCE "RTN","TMGPRNTR",244,0) ;"Output: (Output is changed) as follows "RTN","TMGPRNTR",245,0) ;" Output(0,"COUNT")=2 "RTN","TMGPRNTR",246,0) ;" Output(1,"LINUX")="Deskjet1" <-- suitable name for linux: lp -p PRINTER "RTN","TMGPRNTR",247,0) ;" Output(1,"TYPE")="P-ANADEX" "RTN","TMGPRNTR",248,0) ;" Output(2,"LINUX")="Laser1" <-- suitable name for linux: lp -p PRINTER "RTN","TMGPRNTR",249,0) ;" Output(2,"TYPE")="P-CENT" "RTN","TMGPRNTR",250,0) "RTN","TMGPRNTR",251,0) new cOKToCont set cOKToCont=1 "RTN","TMGPRNTR",252,0) new cAbort set cAbort=0 "RTN","TMGPRNTR",253,0) if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGPRNTR",254,0) if $data(DispMode)#10=0 new DispMode set DispMode=1 ;"1=GUI, 3=Roll-n-Scroll "RTN","TMGPRNTR",255,0) new result set result=cOKToCont "RTN","TMGPRNTR",256,0) new PrtDefs,Printers "RTN","TMGPRNTR",257,0) new PrtCount set PrtCount=0 "RTN","TMGPRNTR",258,0) kill Output ;"clear any prior entries. "RTN","TMGPRNTR",259,0) "RTN","TMGPRNTR",260,0) if DispMode'=1 do goto SUPDone "RTN","TMGPRNTR",261,0) . write "Currently unable to set up printers in 'Roll-and-Scroll' mode. Quitting.",! "RTN","TMGPRNTR",262,0) "RTN","TMGPRNTR",263,0) set result=$$GetPrinters(.Printers) "RTN","TMGPRNTR",264,0) if result=cAbort do goto SUPDone "RTN","TMGPRNTR",265,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get Printers.") "RTN","TMGPRNTR",266,0) "RTN","TMGPRNTR",267,0) set result=$$GetPrtDefs(.PrtDefs) "RTN","TMGPRNTR",268,0) if result=cAbort do goto SUPDone "RTN","TMGPRNTR",269,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get Printer definitions.") "RTN","TMGPRNTR",270,0) "RTN","TMGPRNTR",271,0) new tPrts "RTN","TMGPRNTR",272,0) new Selected set Selected="" "RTN","TMGPRNTR",273,0) merge tPrts=Printers "RTN","TMGPRNTR",274,0) kill tPrts(0) "RTN","TMGPRNTR",275,0) ;"set tPrts(2)="TestPrinter" ;"temp!!!!! "RTN","TMGPRNTR",276,0) ;"set tPrts(3)="TestPrinter2" ;"temp!!!!! "RTN","TMGPRNTR",277,0) for do quit:Selected="" "RTN","TMGPRNTR",278,0) . ;"write "loop1, selected=",Selected,! "RTN","TMGPRNTR",279,0) . set Selected=$$Combo^TMGXDLG("Select Printer to Setup",,,.tPrts) "RTN","TMGPRNTR",280,0) . if Selected="" quit "RTN","TMGPRNTR",281,0) . ;"write "OK, now to set up printer: ",Selected,! "RTN","TMGPRNTR",282,0) . new tResult set tResult=$$PickPrtDef(Selected,.PrtDefs,.Output) "RTN","TMGPRNTR",283,0) . ;"Note: I am not doing anything if user cancels pick of printer type. "RTN","TMGPRNTR",284,0) . ;"Now remove that printer from list of printers to install. "RTN","TMGPRNTR",285,0) . new index set index=$order(tPrts("")) "RTN","TMGPRNTR",286,0) . new NextIndex set NextIndex="" "RTN","TMGPRNTR",287,0) . for do quit:(index="") "RTN","TMGPRNTR",288,0) . . ;"write "loop2, index=",index,! "RTN","TMGPRNTR",289,0) . . set NextIndex=1 "RTN","TMGPRNTR",290,0) . . if index="" quit "RTN","TMGPRNTR",291,0) . . if $get(tPrts(index))=Selected do quit "RTN","TMGPRNTR",292,0) . . . set NextIndex=$order(tPrts(index)) "RTN","TMGPRNTR",293,0) . . . kill tPrts(index) "RTN","TMGPRNTR",294,0) . . . set index="" "RTN","TMGPRNTR",295,0) . . set index=$order(tPrts(index)) "RTN","TMGPRNTR",296,0) . if $data(tPrts)=0 do quit "RTN","TMGPRNTR",297,0) . . set Selected="" ;"force quit "RTN","TMGPRNTR",298,0) . ;"Now move all entries below this one UP "RTN","TMGPRNTR",299,0) . set index=NextIndex "RTN","TMGPRNTR",300,0) . for do quit:index="" "RTN","TMGPRNTR",301,0) . . ;"write "loop3, index=",index,! "RTN","TMGPRNTR",302,0) . . if index="" quit "RTN","TMGPRNTR",303,0) . . set tPrts(index-1)=tPrts(index) "RTN","TMGPRNTR",304,0) . . new PriorIndex set PriorIndex=index "RTN","TMGPRNTR",305,0) . . set index=$order(tPrts(index)) "RTN","TMGPRNTR",306,0) . . kill tPrts(PriorIndex) "RTN","TMGPRNTR",307,0) . . if $data(tPrts)=0 do "RTN","TMGPRNTR",308,0) . . . set Selected="" "RTN","TMGPRNTR",309,0) . . . set index="" "RTN","TMGPRNTR",310,0) "RTN","TMGPRNTR",311,0) SUPDone "RTN","TMGPRNTR",312,0) quit result "RTN","TMGPRNTR",313,0) "RTN","TMGPRNTR",314,0) "RTN","TMGPRNTR",315,0) SetupPrt "RTN","TMGPRNTR",316,0) ;"To query linux printer system, and create VistA entries for these. "RTN","TMGPRNTR",317,0) "RTN","TMGPRNTR",318,0) "RTN","TMGPRNTR",319,0) new cFile set cFile="FILE" "RTN","TMGPRNTR",320,0) new cEntries set cEntries="Entries" "RTN","TMGPRNTR",321,0) "RTN","TMGPRNTR",322,0) ; new Data "RTN","TMGPRNTR",323,0) ; set Data(0,cFile)="3.5" "RTN","TMGPRNTR",324,0) ; set Data(0,cEntries)=1 "RTN","TMGPRNTR",325,0) ; set Data "RTN","TMGPRNTR",326,0) ; "RTN","TMGPRNTR",327,0) ; 1 0;1 .01 NAME [RFX] "RTN","TMGPRNTR",328,0) ; 2 1;1 .02 LOCATION OF TERMINAL [RF] "RTN","TMGPRNTR",329,0) ; MN;0 .03 MNEMONIC <-Mult [3.501] "RTN","TMGPRNTR",330,0) ; 3 -0;1 .01 -MNEMONIC [MFX] "RTN","TMGPRNTR",331,0) ; 4 1;4 .04 LOCAL SYNONYM [F] "RTN","TMGPRNTR",332,0) ; 5 0;2 1 $I [RFX] "RTN","TMGPRNTR",333,0) ; 6 0;9 1.9 VOLUME SET(CPU) [FX] "RTN","TMGPRNTR",334,0) ; 7 0;11 1.95 SIGN-ON/SYSTEM DEVICE [SX] "RTN","TMGPRNTR",335,0) ; 8 TYPE;1 2 TYPE [RS] "RTN","TMGPRNTR",336,0) ; 9 SUBTYPE;1 3 SUBTYPE <-Pntr [RP3.2] "RTN","TMGPRNTR",337,0) ; 10 0;3 4 ASK DEVICE [S] "RTN","TMGPRNTR",338,0) ; 11 0;4 5 ASK PARAMETERS [S] "RTN","TMGPRNTR",339,0) ; 12 1;5 5.1 ASK HOST FILE [S] "RTN","TMGPRNTR",340,0) ; 13 1;6 5.2 ASK HFS I/O OPERATION [S] "RTN","TMGPRNTR",341,0) ; 14 0;12 5.5 QUEUING [S] "RTN","TMGPRNTR",342,0) ; 15 90;1 6 OUT-OF-SERVICE DATE [D] "RTN","TMGPRNTR",343,0) ; 17 90;3 8 KEY OPERATOR [F] "RTN","TMGPRNTR",344,0) ;18 91;1 9 MARGIN WIDTH [NJ3,0] "RTN","TMGPRNTR",345,0) ; 19 91;3 11 PAGE LENGTH [NJ5,0] "RTN","TMGPRNTR",346,0) ; 20 1;11 11.2 SUPPRESS FORM FEED AT CLOSE [S] "RTN","TMGPRNTR",347,0) ; 27 POX;E1,245 19.7 PRE-OPEN EXECUTE [K] "RTN","TMGPRNTR",348,0) ; 28 PCX;E1,245 19.8 POST-CLOSE EXECUTE [K] "RTN","TMGPRNTR",349,0) ; "RTN","TMGPRNTR",350,0) ; "RTN","TMGPRNTR",351,0) ;NAME: TEST-LINUX-PRINTER $I: "RTN","TMGPRNTR",352,0) ; ASK DEVICE: NO ASK PARAMETERS: NO "RTN","TMGPRNTR",353,0) ; SIGN-ON/SYSTEM DEVICE: NO LOCATION OF TERMINAL: Laughlin_Office "RTN","TMGPRNTR",354,0) ; ASK HOST FILE: NO ASK HFS I/O OPERATION: NO "RTN","TMGPRNTR",355,0) ; NEAREST PHONE: 787-7000 PAGE LENGTH: 80 "RTN","TMGPRNTR",356,0) ; FORM CURRENTLY MOUNTED: Plain paper "RTN","TMGPRNTR",357,0) ; POST-CLOSE EXECUTE: DO FINISH^TMGPRNTR("laughlin_laser") "RTN","TMGPRNTR",358,0) ; PRE-OPEN EXECUTE: DO SETJOB^TMGPRNTR(.IO) ;Note: Change IO (output file) "RTN","TMGPRNTR",359,0) ; SUBTYPE: P-OTH80 TYPE: TERMINAL "RTN","TMGPRNTR",360,0) ; ASK DEVICE TYPE AT SIGN-ON: YES, ASK "RTN","TMGPRNTR",361,0) "RTN","TMGPRNTR",362,0) quit "RTN","TMGPRNTR",363,0) "RTN","TMGPRNTR",364,0) "RTN","TMGPRNTR",365,0) ;"======================================================================= "RTN","TMGPRNTR",366,0) ;"======================================================================= "RTN","TMGPRNTR",367,0) "RTN","TMGPRNTR",368,0) "RTN","TMGPRNTR",369,0) GETJOBNM() "RTN","TMGPRNTR",370,0) ;"Purpose: To create a unique printer job name. This will be used during a printing process "RTN","TMGPRNTR",371,0) ;" that writes the printer file to the host file system, then passes file to Linux "RTN","TMGPRNTR",372,0) ;" printing system. "RTN","TMGPRNTR",373,0) ;"Output: Returns name of file to put output into "RTN","TMGPRNTR",374,0) "RTN","TMGPRNTR",375,0) ;"UNIQUE will generate a filename based on time and job number "RTN","TMGPRNTR",376,0) ;" i.e. 'Print-Job-628233034.tmp "RTN","TMGPRNTR",377,0) "RTN","TMGPRNTR",378,0) ;"write !,"here in GETJOBNM^TMGPRNTR",! "RTN","TMGPRNTR",379,0) new cJobs set cJobs="PRINT JOBS" "RTN","TMGPRNTR",380,0) new Filename set Filename=$$UNIQUE^%ZISUTL("/tmp/Print-Job.tmp") "RTN","TMGPRNTR",381,0) "RTN","TMGPRNTR",382,0) ;"Now store Filename for later transfer to Linux lpr "RTN","TMGPRNTR",383,0) new index set index=$order(^TMP("TMG",cJobs,$J,"")) "RTN","TMGPRNTR",384,0) if index="" set index=1 "RTN","TMGPRNTR",385,0) set ^TMP("TMG",cJobs,$J,index)=Filename "RTN","TMGPRNTR",386,0) "RTN","TMGPRNTR",387,0) ;"write !,"Print job name will be:",Filename,! "RTN","TMGPRNTR",388,0) quit Filename ;"result returned by altering Filename "RTN","TMGPRNTR",389,0) "RTN","TMGPRNTR",390,0) "RTN","TMGPRNTR",391,0) "RTN","TMGPRNTR",392,0) FINISH(Printer) "RTN","TMGPRNTR",393,0) ;"Purpose: to complete the printing process by sending the now-created file "RTN","TMGPRNTR",394,0) ;" to Linux CUPS (the printing system). "RTN","TMGPRNTR",395,0) ;"Note: The lpr system itself will delete this print file when done (option -r) "RTN","TMGPRNTR",396,0) ;"Input: Printer OPTIONAL -- the name of the linux printer to send the job to. "RTN","TMGPRNTR",397,0) "RTN","TMGPRNTR",398,0) new cJobs set cJobs="PRINT JOBS" "RTN","TMGPRNTR",399,0) new index set index=$order(^TMP("TMG",cJobs,$J,"")) "RTN","TMGPRNTR",400,0) new Filename set Filename=$get(^TMP("TMG",cJobs,$J,index)) "RTN","TMGPRNTR",401,0) "RTN","TMGPRNTR",402,0) close IO "RTN","TMGPRNTR",403,0) kill IO(1,IO) "RTN","TMGPRNTR",404,0) "RTN","TMGPRNTR",405,0) kill ^TMP("TMG",cJobs,$J,index) "RTN","TMGPRNTR",406,0) "RTN","TMGPRNTR",407,0) if Filename'="" do "RTN","TMGPRNTR",408,0) . new CmdStr "RTN","TMGPRNTR",409,0) . set CmdStr="lpr " "RTN","TMGPRNTR",410,0) . if $get(Printer)'="" set CmdStr=CmdStr_"-P "_Printer_" " "RTN","TMGPRNTR",411,0) . set CmdStr=CmdStr_"-r " ;"option -r --> lpr deletes file after printing done. "RTN","TMGPRNTR",412,0) . set CmdStr=CmdStr_Filename_" &" "RTN","TMGPRNTR",413,0) . zsystem CmdStr "RTN","TMGPRNTR",414,0) "RTN","TMGPRNTR",415,0) quit "RTN","TMGPRNTR",416,0) "RTN","TMGPRNTR",417,0) "RTN","TMGPRNTR",418,0) "RTN","TMGPRNTR",419,0) "RTN","TMGPRNTR",420,0) "RTN","TMGPRPN") 0^67^B76219 "RTN","TMGPRPN",1,0) TMGPRPN ;TMG/kst/Print Notes Fns. ;03/25/06 "RTN","TMGPRPN",2,0) ;;1.0;TMG-LIB;**1**;04/25/04 "RTN","TMGPRPN",3,0) "RTN","TMGPRPN",4,0) ;"TMG PRINT NOTES FUNCTIONS "RTN","TMGPRPN",5,0) "RTN","TMGPRPN",6,0) ;"======================================================================= "RTN","TMGPRPN",7,0) ;" API -- Public Functions. "RTN","TMGPRPN",8,0) ;"======================================================================= "RTN","TMGPRPN",9,0) ;"CONTPRNT -- print notes for chosed patient, contigiously or divided "RTN","TMGPRPN",10,0) ;"CONTPRN2(PtIEN) -- print notes for specified patient "RTN","TMGPRPN",11,0) ;"PRPNQUIET(OPTIONS) -- print notes based on input options "RTN","TMGPRPN",12,0) "RTN","TMGPRPN",13,0) ;"======================================================================= "RTN","TMGPRPN",14,0) ;"PRIVATE API FUNCTIONS "RTN","TMGPRPN",15,0) ;"======================================================================= "RTN","TMGPRPN",16,0) "RTN","TMGPRPN",17,0) "RTN","TMGPRPN",18,0) ;"======================================================================= "RTN","TMGPRPN",19,0) ;"======================================================================= "RTN","TMGPRPN",20,0) "RTN","TMGPRPN",21,0) CONTPRNT "RTN","TMGPRPN",22,0) ;"Purpose: To ask for patient name, and date range, and output device "RTN","TMGPRPN",23,0) ;" and then print notes contigously (i.e. not a separate page "RTN","TMGPRPN",24,0) ;" for each note), or on separate pages "RTN","TMGPRPN",25,0) ;"Input: none -- will ask user for values "RTN","TMGPRPN",26,0) ;"Output: none -- will print to chosen device based on user preference "RTN","TMGPRPN",27,0) "RTN","TMGPRPN",28,0) new Options "RTN","TMGPRPN",29,0) "RTN","TMGPRPN",30,0) write !,"-- PRINT NOTES FOR A PATIENT, CONTIGIOUSLY -- ",!! "RTN","TMGPRPN",31,0) "RTN","TMGPRPN",32,0) set DIC=2 ;"PATIENT file "RTN","TMGPRPN",33,0) set DIC(0)="MAQE" "RTN","TMGPRPN",34,0) set DIC("A")="Enter name of Patient to print note for (^ to abort): " "RTN","TMGPRPN",35,0) do ^DIC "RTN","TMGPRPN",36,0) "RTN","TMGPRPN",37,0) do CONTPRN2(+Y) "RTN","TMGPRPN",38,0) RADone "RTN","TMGPRPN",39,0) quit "RTN","TMGPRPN",40,0) "RTN","TMGPRPN",41,0) "RTN","TMGPRPN",42,0) CONTPRN2(PtIEN) "RTN","TMGPRPN",43,0) ;"Purpose: For specified patient, ask for date range, output device, "RTN","TMGPRPN",44,0) ;" and if to print notes contigously (i.e. not a separate page "RTN","TMGPRPN",45,0) ;" for each note) or on separate pages, and if to list avail notes. "RTN","TMGPRPN",46,0) ;"Input: PtIEN -- record number in file #2 "RTN","TMGPRPN",47,0) ;"Output: none -- will print to chosen device based on user preference "RTN","TMGPRPN",48,0) "RTN","TMGPRPN",49,0) new Options "RTN","TMGPRPN",50,0) "RTN","TMGPRPN",51,0) write ! "RTN","TMGPRPN",52,0) "RTN","TMGPRPN",53,0) set Options("PATIENT")=$get(PtIEN,-1) "RTN","TMGPRPN",54,0) if Options("PATIENT")'>0 do goto CP2Done "RTN","TMGPRPN",55,0) . write !,"No patient selected. Aborting.",! "RTN","TMGPRPN",56,0) "RTN","TMGPRPN",57,0) new YN,index "RTN","TMGPRPN",58,0) read !,"Show list of available notes? (^ to abort): YES// ",YN:$get(DTIME,3600) "RTN","TMGPRPN",59,0) if YN="" set YN="Y" "RTN","TMGPRPN",60,0) if YN="^" write "Aborting.",! goto CP2Done "RTN","TMGPRPN",61,0) if ($$UP^XLFSTR(YN)["Y") do "RTN","TMGPRPN",62,0) . write !,"Available notes",! "RTN","TMGPRPN",63,0) . write "---------------",! "RTN","TMGPRPN",64,0) . set index=$order(^TIU(8925,"C",PtIEN,""),1) "RTN","TMGPRPN",65,0) . for do quit:(index="") "RTN","TMGPRPN",66,0) . . if index="" quit ;"note index is DocIEN "RTN","TMGPRPN",67,0) . . new S,Date,DateS,DocTIEN,TypeName,X,Y "RTN","TMGPRPN",68,0) . . set Date=$piece($get(^TIU(8925,index,13)),"^",1) "RTN","TMGPRPN",69,0) . . set Y="D" set DateS=$$FMTE^XLFDT(Date) "RTN","TMGPRPN",70,0) . . set DocTIEN=$piece($get(^TIU(8925,index,0)),"^",1) "RTN","TMGPRPN",71,0) . . set TypeName=$piece($get(^TIU(8925.1,DocTIEN,0)),"^",1) "RTN","TMGPRPN",72,0) . . if TypeName="" set TypeName="(Unknown document type): "_DocTIEN "RTN","TMGPRPN",73,0) . . write DateS," -- ",TypeName,! "RTN","TMGPRPN",74,0) . . set index=$order(^TIU(8925,"C",PtIEN,index),1) "RTN","TMGPRPN",75,0) "RTN","TMGPRPN",76,0) new %DT "RTN","TMGPRPN",77,0) set %DT="AEP" "RTN","TMGPRPN",78,0) set %DT("A")="Enter starting date (^ to abort): " "RTN","TMGPRPN",79,0) do ^%DT "RTN","TMGPRPN",80,0) if Y=-1 do goto CP2Done "RTN","TMGPRPN",81,0) . write "Invalid date. Aborting.",! "RTN","TMGPRPN",82,0) set Options("START")=Y "RTN","TMGPRPN",83,0) "RTN","TMGPRPN",84,0) set %DT("A")="Enter ending date (^ to abort): " "RTN","TMGPRPN",85,0) do ^%DT "RTN","TMGPRPN",86,0) if Y=-1 do goto CP2Done "RTN","TMGPRPN",87,0) . write "Invalid date. Aborting report.",! "RTN","TMGPRPN",88,0) set Options("END")=Y "RTN","TMGPRPN",89,0) "RTN","TMGPRPN",90,0) new ContMode "RTN","TMGPRPN",91,0) read !,"Print each note on a separate page? NO// ",ContMode:$get(DTIME,3600),! "RTN","TMGPRPN",92,0) if ContMode="" set ContMode="N" "RTN","TMGPRPN",93,0) set Options("CONTMODE")=($$UP^XLFSTR(ContMode)["N") "RTN","TMGPRPN",94,0) if ContMode="^" write "Aborting.",! goto CP2Done "RTN","TMGPRPN",95,0) "RTN","TMGPRPN",96,0) set %ZIS("A")="Enter output printer or device (^ to abort): " "RTN","TMGPRPN",97,0) do ^%ZIS "RTN","TMGPRPN",98,0) if POP do goto CP2Done "RTN","TMGPRPN",99,0) . write !,"Error selecting output printer or device. Aborting report.",! "RTN","TMGPRPN",100,0) "RTN","TMGPRPN",101,0) use IO "RTN","TMGPRPN",102,0) do PRPNQUIET(.Options) "RTN","TMGPRPN",103,0) use IO(0) "RTN","TMGPRPN",104,0) "RTN","TMGPRPN",105,0) do ^%ZISC "RTN","TMGPRPN",106,0) "RTN","TMGPRPN",107,0) write !,"Done. Good bye!",!! "RTN","TMGPRPN",108,0) CP2Done "RTN","TMGPRPN",109,0) quit "RTN","TMGPRPN",110,0) "RTN","TMGPRPN",111,0) "RTN","TMGPRPN",112,0) PRPNQUIET(OPTIONS) "RTN","TMGPRPN",113,0) ;"Purpose: To create a report on transcription productivity based on "RTN","TMGPRPN",114,0) ;" options specified in OPTIONS. "RTN","TMGPRPN",115,0) ;"Input: The following elements in OPTIONS should be defined "RTN","TMGPRPN",116,0) ;" 0PTIONS("PATIENT") ;"the IEN of the user (IEN from file 200) "RTN","TMGPRPN",117,0) ;" OPTIONS("START") ;"Earliest date of documents, in Fileman internal format "RTN","TMGPRPN",118,0) ;" OPTIONS("END") ;"Latest date of documents, in Fileman internal format "RTN","TMGPRPN",119,0) ;" OPTIONS("CONTMODE") ;"if 1, then notes printed contigiously "RTN","TMGPRPN",120,0) ;"Note: This will create a report by writing to the current device "RTN","TMGPRPN",121,0) ;" If the user wants output to go to a DEVICE, then they should call "RTN","TMGPRPN",122,0) ;" ^%ZIS prior to calling this function, then use IO, "RTN","TMGPRPN",123,0) ;" then when done, use IO(0) and call ^%ZISC to close "RTN","TMGPRPN",124,0) "RTN","TMGPRPN",125,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PRPNQUIET^TMGPRPN") "RTN","TMGPRPN",126,0) "RTN","TMGPRPN",127,0) new PtIEN "RTN","TMGPRPN",128,0) new index set index="" "RTN","TMGPRPN",129,0) "RTN","TMGPRPN",130,0) set PtIEN=+$get(OPTIONS("PATIENT")) "RTN","TMGPRPN",131,0) if PtIEN=0 do goto PQDone "RTN","TMGPRPN",132,0) . write "No patient record number supplied. Aborting.",! "RTN","TMGPRPN",133,0) set StartDT=+$get(OPTIONS("START")) "RTN","TMGPRPN",134,0) if (StartDT=0) do "RTN","TMGPRPN",135,0) . write "No start date specified. Aborting.",! "RTN","TMGPRPN",136,0) set EndDT=+$get(OPTIONS("END")) "RTN","TMGPRPN",137,0) if (EndDT=0) do "RTN","TMGPRPN",138,0) . write "No end date specified. Aborting.",! "RTN","TMGPRPN",139,0) "RTN","TMGPRPN",140,0) kill ^TMP("TIUPR",$J) "RTN","TMGPRPN",141,0) set index=$order(^TIU(8925,"C",PtIEN,"")) "RTN","TMGPRPN",142,0) for do quit:(index="") "RTN","TMGPRPN",143,0) . if index="" quit ;"note index is DocIEN "RTN","TMGPRPN",144,0) . new S,SSN,DATE "RTN","TMGPRPN",145,0) . set SSN=$Piece(^DPT(PtIEN,0),"^",9) "RTN","TMGPRPN",146,0) . Set DATE=$piece($get(^TIU(8925,index,13)),"^",1) "RTN","TMGPRPN",147,0) . if (DATE'EndDT) do "RTN","TMGPRPN",148,0) . . Set ^TMP("TIUPR",$Job,SSN_";"_PtIEN,DATE,index)="VistA EMR" "RTN","TMGPRPN",149,0) . set index=$order(^TIU(8925,"C",PtIEN,index)) "RTN","TMGPRPN",150,0) "RTN","TMGPRPN",151,0) do PRINT^TIUPRPN1(1,1) ;0=> Chart Copy, 1=>Contigious "RTN","TMGPRPN",152,0) "RTN","TMGPRPN",153,0) PQDone "RTN","TMGPRPN",154,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PRPNQUIET^TMGPRPN") "RTN","TMGPRPN",155,0) quit "RTN","TMGPRPN",156,0) "RTN","TMGPRPN",157,0) "RTN","TMGPSSDE") 0^68^B217084810 "RTN","TMGPSSDE",1,0) TMGPSSDE ;TMG/kst/Custom version of PSSDEE ;03/25/06 "RTN","TMGPSSDE",2,0) ;;1.0;TMG-LIB;**1**;04/25/04 "RTN","TMGPSSDE",3,0) "RTN","TMGPSSDE",4,0) PSSDEE ;BIR/WRT-MASTER DRUG ENTER/EDIT ROUTINE ;01/21/00 "RTN","TMGPSSDE",5,0) ;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61**;9/30/97 "RTN","TMGPSSDE",6,0) "RTN","TMGPSSDE",7,0) ;"***************************************************************** "RTN","TMGPSSDE",8,0) ;"* Custom version of code by Kevin Toppenberg, MD "RTN","TMGPSSDE",9,0) ;"* to allow customization of the code. "RTN","TMGPSSDE",10,0) ;"* "RTN","TMGPSSDE",11,0) ;"***************************************************************** "RTN","TMGPSSDE",12,0) "RTN","TMGPSSDE",13,0) ;"Reference to REACT1^PSNOUT supported by DBIA #2080 "RTN","TMGPSSDE",14,0) ;"Reference to $$UP^XLFSTR(X) supported by DBIA #10104 "RTN","TMGPSSDE",15,0) ;"Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531 "RTN","TMGPSSDE",16,0) ; "RTN","TMGPSSDE",17,0) BEGIN set PSSFLAG=0 "RTN","TMGPSSDE",18,0) do ^PSSDEE2 ;"kill vars "RTN","TMGPSSDE",19,0) set PSSZ=1 "RTN","TMGPSSDE",20,0) F PSSXX=1:1 do quit:PSSFLAG "RTN","TMGPSSDE",21,0) . kill DA "RTN","TMGPSSDE",22,0) . do ASK ;" ask users all questions "RTN","TMGPSSDE",23,0) DONE do ^PSSDEE2 ;" kill vars "RTN","TMGPSSDE",24,0) kill PSSFLAG "RTN","TMGPSSDE",25,0) quit "RTN","TMGPSSDE",26,0) ; "RTN","TMGPSSDE",27,0) ;"================================================================= "RTN","TMGPSSDE",28,0) ASK W ! "RTN","TMGPSSDE",29,0) set DIC="^PSDRUG(" "RTN","TMGPSSDE",30,0) set DIC(0)="QEALMNTV" ;"query/echo/ask/learn=OK/multIndex/IntNumOK/T->searchAllIndexes/verify "RTN","TMGPSSDE",31,0) set DLAYGO=50 ;"force allowing adding record to file 50 "RTN","TMGPSSDE",32,0) set DIC("T")="" ;"present every match to the lookup value "RTN","TMGPSSDE",33,0) do ^DIC "RTN","TMGPSSDE",34,0) kill DIC "RTN","TMGPSSDE",35,0) if Y<0 set PSSFLAG=1 quit "RTN","TMGPSSDE",36,0) ; "RTN","TMGPSSDE",37,0) set (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI)=0 "RTN","TMGPSSDE",38,0) kill ^TMP($J,"ADD") "RTN","TMGPSSDE",39,0) kill ^TMP($J,"SOL") "RTN","TMGPSSDE",40,0) ; "RTN","TMGPSSDE",41,0) set DA=+Y "RTN","TMGPSSDE",42,0) set DISPDRG=DA "RTN","TMGPSSDE",43,0) L +^PSDRUG(DISPDRG):0 "RTN","TMGPSSDE",44,0) if '$T W !,$C(7),"Another person is editing this one." quit "RTN","TMGPSSDE",45,0) set PSSHUIDG=1 "RTN","TMGPSSDE",46,0) set PSSNEW=$P(Y,"^",3) "RTN","TMGPSSDE",47,0) do USE "RTN","TMGPSSDE",48,0) do NOPE "RTN","TMGPSSDE",49,0) do COMMON "RTN","TMGPSSDE",50,0) do DEA "RTN","TMGPSSDE",51,0) do MF "RTN","TMGPSSDE",52,0) kill PSSHUIDG "RTN","TMGPSSDE",53,0) do DRG^PSSHUIDG(DISPDRG,PSSNEW) "RTN","TMGPSSDE",54,0) L -^PSDRUG(DISPDRG) "RTN","TMGPSSDE",55,0) kill FLG3,PSSNEW "RTN","TMGPSSDE",56,0) quit "RTN","TMGPSSDE",57,0) ; "RTN","TMGPSSDE",58,0) ;"================================================================= "RTN","TMGPSSDE",59,0) COMMON set DIE="^PSDRUG(" "RTN","TMGPSSDE",60,0) set DR="[PSSCOMMON]" "RTN","TMGPSSDE",61,0) do ^DIE "RTN","TMGPSSDE",62,0) quit:$data(Y)!($data(DTOUT)) "RTN","TMGPSSDE",63,0) W:'$data(Y) !,"PRICE PER DISPENSE UNIT: " "RTN","TMGPSSDE",64,0) S:'$data(^PSDRUG(DA,660)) $P(^PSDRUG(DA,660),"^",6)="" "RTN","TMGPSSDE",65,0) W:'$data(Y) $P(^PSDRUG(DA,660),"^",6) "RTN","TMGPSSDE",66,0) do DEA "RTN","TMGPSSDE",67,0) do CK "RTN","TMGPSSDE",68,0) do ASKND "RTN","TMGPSSDE",69,0) do OIKILL^PSSDEE1 "RTN","TMGPSSDE",70,0) do COMMON1 "RTN","TMGPSSDE",71,0) quit "RTN","TMGPSSDE",72,0) ; "RTN","TMGPSSDE",73,0) COMMON1 W !,"Just a reminder...you are editing ",$P(^PSDRUG(DISPDRG,0),"^"),"." "RTN","TMGPSSDE",74,0) set (PSSVVDA,DA)=DISPDRG "RTN","TMGPSSDE",75,0) do DOSN^PSSDOS "RTN","TMGPSSDE",76,0) set DA=PSSVVDA "RTN","TMGPSSDE",77,0) kill PSSVVDA "RTN","TMGPSSDE",78,0) do USE "RTN","TMGPSSDE",79,0) do APP "RTN","TMGPSSDE",80,0) do ORDITM^PSSDEE1 "RTN","TMGPSSDE",81,0) quit "RTN","TMGPSSDE",82,0) ; "RTN","TMGPSSDE",83,0) CK do DSPY^PSSDEE1 "RTN","TMGPSSDE",84,0) set FLGNDF=0 "RTN","TMGPSSDE",85,0) quit "RTN","TMGPSSDE",86,0) ; "RTN","TMGPSSDE",87,0) ASKND set %=-1 "RTN","TMGPSSDE",88,0) if $data(^XUSEC("PSNMGR",DUZ)) do "RTN","TMGPSSDE",89,0) . do MESSAGE^PSSDEE1 "RTN","TMGPSSDE",90,0) . W !!,"Do you wish to match/rematch to NATIONAL DRUG file" "RTN","TMGPSSDE",91,0) . set %=1 "RTN","TMGPSSDE",92,0) . S:FLGMTH=1 %=2 "RTN","TMGPSSDE",93,0) . do YN^DICN "RTN","TMGPSSDE",94,0) if %=0 W !,"If you answer ""yes"", you will attempt to match to NDF." G ASKND "RTN","TMGPSSDE",95,0) if %=2 kill X,Y quit "RTN","TMGPSSDE",96,0) if %<0 kill X,Y quit "RTN","TMGPSSDE",97,0) if %=1 do "RTN","TMGPSSDE",98,0) . do RSET^PSSDEE1 "RTN","TMGPSSDE",99,0) . do EN1^PSSUTIL(DISPDRG,1) "RTN","TMGPSSDE",100,0) . set X="PSNOUT" "RTN","TMGPSSDE",101,0) . X ^%ZOSF("TEST") "RTN","TMGPSSDE",102,0) . if do "RTN","TMGPSSDE",103,0) . . do REACT1^PSNOUT "RTN","TMGPSSDE",104,0) . . set DA=DISPDRG "RTN","TMGPSSDE",105,0) . . if $data(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)]"" do ONE "RTN","TMGPSSDE",106,0) quit "RTN","TMGPSSDE",107,0) ; "RTN","TMGPSSDE",108,0) ONE set PSNP=$G(^PSDRUG(DA,"I")) "RTN","TMGPSSDE",109,0) if PSNP,PSNP
1 if $data(^PSDRUG(DISPDRG,2)) DO "RTN","TMGPSSDE",401,0) . set PSSOR=$P(^PSDRUG(DISPDRG,2),"^",1) "RTN","TMGPSSDE",402,0) . if PSSOR]"" DO "RTN","TMGPSSDE",403,0) . . DO EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDE",404,0) . . DO EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDE",405,0) quit "RTN","TMGPSSDE",406,0) ; "RTN","TMGPSSDE",407,0) MFA if $P($G(^PS(59.7,1,80)),"^",2)>1 do "RTN","TMGPSSDE",408,0) . set PSSOR=$P(^PS(52.6,ENTRY,0),"^",11) "RTN","TMGPSSDE",409,0) . set PSSDD=$P(^PS(52.6,ENTRY,0),"^",2) "RTN","TMGPSSDE",410,0) . if PSSOR]"" do "RTN","TMGPSSDE",411,0) . . do EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDE",412,0) . . do EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDE",413,0) . . do MFDD "RTN","TMGPSSDE",414,0) quit "RTN","TMGPSSDE",415,0) ; "RTN","TMGPSSDE",416,0) MFS if $P($G(^PS(59.7,1,80)),"^",2)>1 do "RTN","TMGPSSDE",417,0) . set PSSOR=$P(^PS(52.7,ENTRY,0),"^",11) "RTN","TMGPSSDE",418,0) . set PSSDD=$P(^PS(52.7,ENTRY,0),"^",2) "RTN","TMGPSSDE",419,0) . if PSSOR]"" do "RTN","TMGPSSDE",420,0) . . do EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDE",421,0) . . do EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDE",422,0) . . do MFDD "RTN","TMGPSSDE",423,0) quit "RTN","TMGPSSDE",424,0) ; "RTN","TMGPSSDE",425,0) MFDD if $data(^PSDRUG(PSSDD,2)) do "RTN","TMGPSSDE",426,0) . set PSSOR=$P(^PSDRUG(PSSDD,2),"^",1) "RTN","TMGPSSDE",427,0) . if PSSOR]"" do "RTN","TMGPSSDE",428,0) . . do EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDE",429,0) . . do EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDE",430,0) quit "RTN","TMGPSSDE",431,0) ; "RTN","TMGPSSDE",432,0) OPEI if $data(^PSDRUG(DISPDRG,"ND")),$P(^PSDRUG(DISPDRG,"ND"),"^",10)]"" do "RTN","TMGPSSDE",433,0) . set DIE="^PSDRUG(" "RTN","TMGPSSDE",434,0) . set DR="28" "RTN","TMGPSSDE",435,0) . set DA=DISPDRG "RTN","TMGPSSDE",436,0) . do ^DIE "RTN","TMGPSSDE",437,0) quit "RTN","TMGPSSDE",438,0) ; "RTN","TMGPSSDE",439,0) DEA ; "RTN","TMGPSSDE",440,0) if $P($G(^PSDRUG(DISPDRG,3)),"^")=1,($P(^PSDRUG(DISPDRG,0),"^",3)[1!($P(^(0),"^",3)[2)) do DSH "RTN","TMGPSSDE",441,0) quit "RTN","TMGPSSDE",442,0) ; "RTN","TMGPSSDE",443,0) DSH W !!,"****************************************************************************" "RTN","TMGPSSDE",444,0) W !,"This entry contains a ""1"" or a ""2"" in the ""DEA, SPECIAL HDLG""",! "RTN","TMGPSSDE",445,0) w "field, therefore this item has been UNMARKED for CMOP transmission." "RTN","TMGPSSDE",446,0) W !,"****************************************************************************",! "RTN","TMGPSSDE",447,0) S $P(^PSDRUG(DISPDRG,3),"^")=0 "RTN","TMGPSSDE",448,0) kill ^PSDRUG("AQ",DISPDRG) "RTN","TMGPSSDE",449,0) set DA=DISPDRG "RTN","TMGPSSDE",450,0) N % "RTN","TMGPSSDE",451,0) do ^PSSREF "RTN","TMGPSSDE",452,0) quit "RTN","TMGPSSDEE") 0^69^B217084810 "RTN","TMGPSSDEE",1,0) TMGPSSDE ;TMG/kst/Custom version of PSSDEE ;03/25/06 "RTN","TMGPSSDEE",2,0) ;;1.0;TMG-LIB;**1**;04/25/04 "RTN","TMGPSSDEE",3,0) "RTN","TMGPSSDEE",4,0) PSSDEE ;BIR/WRT-MASTER DRUG ENTER/EDIT ROUTINE ;01/21/00 "RTN","TMGPSSDEE",5,0) ;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61**;9/30/97 "RTN","TMGPSSDEE",6,0) "RTN","TMGPSSDEE",7,0) ;"***************************************************************** "RTN","TMGPSSDEE",8,0) ;"* Custom version of code by Kevin Toppenberg, MD "RTN","TMGPSSDEE",9,0) ;"* to allow customization of the code. "RTN","TMGPSSDEE",10,0) ;"* "RTN","TMGPSSDEE",11,0) ;"***************************************************************** "RTN","TMGPSSDEE",12,0) "RTN","TMGPSSDEE",13,0) ;"Reference to REACT1^PSNOUT supported by DBIA #2080 "RTN","TMGPSSDEE",14,0) ;"Reference to $$UP^XLFSTR(X) supported by DBIA #10104 "RTN","TMGPSSDEE",15,0) ;"Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531 "RTN","TMGPSSDEE",16,0) ; "RTN","TMGPSSDEE",17,0) BEGIN set PSSFLAG=0 "RTN","TMGPSSDEE",18,0) do ^PSSDEE2 ;"kill vars "RTN","TMGPSSDEE",19,0) set PSSZ=1 "RTN","TMGPSSDEE",20,0) F PSSXX=1:1 do quit:PSSFLAG "RTN","TMGPSSDEE",21,0) . kill DA "RTN","TMGPSSDEE",22,0) . do ASK ;" ask users all questions "RTN","TMGPSSDEE",23,0) DONE do ^PSSDEE2 ;" kill vars "RTN","TMGPSSDEE",24,0) kill PSSFLAG "RTN","TMGPSSDEE",25,0) quit "RTN","TMGPSSDEE",26,0) ; "RTN","TMGPSSDEE",27,0) ;"================================================================= "RTN","TMGPSSDEE",28,0) ASK W ! "RTN","TMGPSSDEE",29,0) set DIC="^PSDRUG(" "RTN","TMGPSSDEE",30,0) set DIC(0)="QEALMNTV" ;"query/echo/ask/learn=OK/multIndex/IntNumOK/T->searchAllIndexes/verify "RTN","TMGPSSDEE",31,0) set DLAYGO=50 ;"force allowing adding record to file 50 "RTN","TMGPSSDEE",32,0) set DIC("T")="" ;"present every match to the lookup value "RTN","TMGPSSDEE",33,0) do ^DIC "RTN","TMGPSSDEE",34,0) kill DIC "RTN","TMGPSSDEE",35,0) if Y<0 set PSSFLAG=1 quit "RTN","TMGPSSDEE",36,0) ; "RTN","TMGPSSDEE",37,0) set (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI)=0 "RTN","TMGPSSDEE",38,0) kill ^TMP($J,"ADD") "RTN","TMGPSSDEE",39,0) kill ^TMP($J,"SOL") "RTN","TMGPSSDEE",40,0) ; "RTN","TMGPSSDEE",41,0) set DA=+Y "RTN","TMGPSSDEE",42,0) set DISPDRG=DA "RTN","TMGPSSDEE",43,0) L +^PSDRUG(DISPDRG):0 "RTN","TMGPSSDEE",44,0) if '$T W !,$C(7),"Another person is editing this one." quit "RTN","TMGPSSDEE",45,0) set PSSHUIDG=1 "RTN","TMGPSSDEE",46,0) set PSSNEW=$P(Y,"^",3) "RTN","TMGPSSDEE",47,0) do USE "RTN","TMGPSSDEE",48,0) do NOPE "RTN","TMGPSSDEE",49,0) do COMMON "RTN","TMGPSSDEE",50,0) do DEA "RTN","TMGPSSDEE",51,0) do MF "RTN","TMGPSSDEE",52,0) kill PSSHUIDG "RTN","TMGPSSDEE",53,0) do DRG^PSSHUIDG(DISPDRG,PSSNEW) "RTN","TMGPSSDEE",54,0) L -^PSDRUG(DISPDRG) "RTN","TMGPSSDEE",55,0) kill FLG3,PSSNEW "RTN","TMGPSSDEE",56,0) quit "RTN","TMGPSSDEE",57,0) ; "RTN","TMGPSSDEE",58,0) ;"================================================================= "RTN","TMGPSSDEE",59,0) COMMON set DIE="^PSDRUG(" "RTN","TMGPSSDEE",60,0) set DR="[PSSCOMMON]" "RTN","TMGPSSDEE",61,0) do ^DIE "RTN","TMGPSSDEE",62,0) quit:$data(Y)!($data(DTOUT)) "RTN","TMGPSSDEE",63,0) W:'$data(Y) !,"PRICE PER DISPENSE UNIT: " "RTN","TMGPSSDEE",64,0) S:'$data(^PSDRUG(DA,660)) $P(^PSDRUG(DA,660),"^",6)="" "RTN","TMGPSSDEE",65,0) W:'$data(Y) $P(^PSDRUG(DA,660),"^",6) "RTN","TMGPSSDEE",66,0) do DEA "RTN","TMGPSSDEE",67,0) do CK "RTN","TMGPSSDEE",68,0) do ASKND "RTN","TMGPSSDEE",69,0) do OIKILL^PSSDEE1 "RTN","TMGPSSDEE",70,0) do COMMON1 "RTN","TMGPSSDEE",71,0) quit "RTN","TMGPSSDEE",72,0) ; "RTN","TMGPSSDEE",73,0) COMMON1 W !,"Just a reminder...you are editing ",$P(^PSDRUG(DISPDRG,0),"^"),"." "RTN","TMGPSSDEE",74,0) set (PSSVVDA,DA)=DISPDRG "RTN","TMGPSSDEE",75,0) do DOSN^PSSDOS "RTN","TMGPSSDEE",76,0) set DA=PSSVVDA "RTN","TMGPSSDEE",77,0) kill PSSVVDA "RTN","TMGPSSDEE",78,0) do USE "RTN","TMGPSSDEE",79,0) do APP "RTN","TMGPSSDEE",80,0) do ORDITM^PSSDEE1 "RTN","TMGPSSDEE",81,0) quit "RTN","TMGPSSDEE",82,0) ; "RTN","TMGPSSDEE",83,0) CK do DSPY^PSSDEE1 "RTN","TMGPSSDEE",84,0) set FLGNDF=0 "RTN","TMGPSSDEE",85,0) quit "RTN","TMGPSSDEE",86,0) ; "RTN","TMGPSSDEE",87,0) ASKND set %=-1 "RTN","TMGPSSDEE",88,0) if $data(^XUSEC("PSNMGR",DUZ)) do "RTN","TMGPSSDEE",89,0) . do MESSAGE^PSSDEE1 "RTN","TMGPSSDEE",90,0) . W !!,"Do you wish to match/rematch to NATIONAL DRUG file" "RTN","TMGPSSDEE",91,0) . set %=1 "RTN","TMGPSSDEE",92,0) . S:FLGMTH=1 %=2 "RTN","TMGPSSDEE",93,0) . do YN^DICN "RTN","TMGPSSDEE",94,0) if %=0 W !,"If you answer ""yes"", you will attempt to match to NDF." G ASKND "RTN","TMGPSSDEE",95,0) if %=2 kill X,Y quit "RTN","TMGPSSDEE",96,0) if %<0 kill X,Y quit "RTN","TMGPSSDEE",97,0) if %=1 do "RTN","TMGPSSDEE",98,0) . do RSET^PSSDEE1 "RTN","TMGPSSDEE",99,0) . do EN1^PSSUTIL(DISPDRG,1) "RTN","TMGPSSDEE",100,0) . set X="PSNOUT" "RTN","TMGPSSDEE",101,0) . X ^%ZOSF("TEST") "RTN","TMGPSSDEE",102,0) . if do "RTN","TMGPSSDEE",103,0) . . do REACT1^PSNOUT "RTN","TMGPSSDEE",104,0) . . set DA=DISPDRG "RTN","TMGPSSDEE",105,0) . . if $data(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)]"" do ONE "RTN","TMGPSSDEE",106,0) quit "RTN","TMGPSSDEE",107,0) ; "RTN","TMGPSSDEE",108,0) ONE set PSNP=$G(^PSDRUG(DA,"I")) "RTN","TMGPSSDEE",109,0) if PSNP,PSNP
1 if $data(^PSDRUG(DISPDRG,2)) DO "RTN","TMGPSSDEE",401,0) . set PSSOR=$P(^PSDRUG(DISPDRG,2),"^",1) "RTN","TMGPSSDEE",402,0) . if PSSOR]"" DO "RTN","TMGPSSDEE",403,0) . . DO EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDEE",404,0) . . DO EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDEE",405,0) quit "RTN","TMGPSSDEE",406,0) ; "RTN","TMGPSSDEE",407,0) MFA if $P($G(^PS(59.7,1,80)),"^",2)>1 do "RTN","TMGPSSDEE",408,0) . set PSSOR=$P(^PS(52.6,ENTRY,0),"^",11) "RTN","TMGPSSDEE",409,0) . set PSSDD=$P(^PS(52.6,ENTRY,0),"^",2) "RTN","TMGPSSDEE",410,0) . if PSSOR]"" do "RTN","TMGPSSDEE",411,0) . . do EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDEE",412,0) . . do EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDEE",413,0) . . do MFDD "RTN","TMGPSSDEE",414,0) quit "RTN","TMGPSSDEE",415,0) ; "RTN","TMGPSSDEE",416,0) MFS if $P($G(^PS(59.7,1,80)),"^",2)>1 do "RTN","TMGPSSDEE",417,0) . set PSSOR=$P(^PS(52.7,ENTRY,0),"^",11) "RTN","TMGPSSDEE",418,0) . set PSSDD=$P(^PS(52.7,ENTRY,0),"^",2) "RTN","TMGPSSDEE",419,0) . if PSSOR]"" do "RTN","TMGPSSDEE",420,0) . . do EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDEE",421,0) . . do EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDEE",422,0) . . do MFDD "RTN","TMGPSSDEE",423,0) quit "RTN","TMGPSSDEE",424,0) ; "RTN","TMGPSSDEE",425,0) MFDD if $data(^PSDRUG(PSSDD,2)) do "RTN","TMGPSSDEE",426,0) . set PSSOR=$P(^PSDRUG(PSSDD,2),"^",1) "RTN","TMGPSSDEE",427,0) . if PSSOR]"" do "RTN","TMGPSSDEE",428,0) . . do EN^PSSPOIDT(PSSOR) "RTN","TMGPSSDEE",429,0) . . do EN2^PSSHL1(PSSOR,"MUP") "RTN","TMGPSSDEE",430,0) quit "RTN","TMGPSSDEE",431,0) ; "RTN","TMGPSSDEE",432,0) OPEI if $data(^PSDRUG(DISPDRG,"ND")),$P(^PSDRUG(DISPDRG,"ND"),"^",10)]"" do "RTN","TMGPSSDEE",433,0) . set DIE="^PSDRUG(" "RTN","TMGPSSDEE",434,0) . set DR="28" "RTN","TMGPSSDEE",435,0) . set DA=DISPDRG "RTN","TMGPSSDEE",436,0) . do ^DIE "RTN","TMGPSSDEE",437,0) quit "RTN","TMGPSSDEE",438,0) ; "RTN","TMGPSSDEE",439,0) DEA ; "RTN","TMGPSSDEE",440,0) if $P($G(^PSDRUG(DISPDRG,3)),"^")=1,($P(^PSDRUG(DISPDRG,0),"^",3)[1!($P(^(0),"^",3)[2)) do DSH "RTN","TMGPSSDEE",441,0) quit "RTN","TMGPSSDEE",442,0) ; "RTN","TMGPSSDEE",443,0) DSH W !!,"****************************************************************************" "RTN","TMGPSSDEE",444,0) W !,"This entry contains a ""1"" or a ""2"" in the ""DEA, SPECIAL HDLG""",! "RTN","TMGPSSDEE",445,0) w "field, therefore this item has been UNMARKED for CMOP transmission." "RTN","TMGPSSDEE",446,0) W !,"****************************************************************************",! "RTN","TMGPSSDEE",447,0) S $P(^PSDRUG(DISPDRG,3),"^")=0 "RTN","TMGPSSDEE",448,0) kill ^PSDRUG("AQ",DISPDRG) "RTN","TMGPSSDEE",449,0) set DA=DISPDRG "RTN","TMGPSSDEE",450,0) N % "RTN","TMGPSSDEE",451,0) do ^PSSREF "RTN","TMGPSSDEE",452,0) quit "RTN","TMGPUTN0") 0^70^B125965713 "RTN","TMGPUTN0",1,0) TMGPUTN0 ;TMG/kst/TIU Document Upload look-up function ;03/25/06 "RTN","TMGPUTN0",2,0) ;;1.0;TMG-LIB;**1**;04/25/04 "RTN","TMGPUTN0",3,0) "RTN","TMGPUTN0",4,0) ;"TIU Document Upload look-up function "RTN","TMGPUTN0",5,0) "RTN","TMGPUTN0",6,0) ;"Kevin Toppenberg MD "RTN","TMGPUTN0",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGPUTN0",8,0) ;"4-25-2004 "RTN","TMGPUTN0",9,0) "RTN","TMGPUTN0",10,0) "RTN","TMGPUTN0",11,0) LOOKUP(DocTitle,Autosign) ; "RTN","TMGPUTN0",12,0) ;"----------------------------------------------------------------------------------- "RTN","TMGPUTN0",13,0) ;"Upload look-up function "RTN","TMGPUTN0",14,0) ;"by Kevin Toppenberg "RTN","TMGPUTN0",15,0) ;"4-25-2004 "RTN","TMGPUTN0",16,0) ;" "RTN","TMGPUTN0",17,0) ;"PURPOSE: "RTN","TMGPUTN0",18,0) ;"This code is used as look-up code by the TIU document upload routines. "RTN","TMGPUTN0",19,0) ;"It has a very specific purpose. It was written for uploading documents "RTN","TMGPUTN0",20,0) ;" from a Medic EMR system. Notes had been dumped out of that system, and "RTN","TMGPUTN0",21,0) ;" were to be ported into VistA "RTN","TMGPUTN0",22,0) ;"Each note has a header with patient name, dob, ssnum, chart#, provider "RTN","TMGPUTN0",23,0) ;"Addendum -- this code will also work with less extensive patient data. "RTN","TMGPUTN0",24,0) ;" "RTN","TMGPUTN0",25,0) ;"INPUT "RTN","TMGPUTN0",26,0) ;" The variable (with global scope) listed below are expected as input. "RTN","TMGPUTN0",27,0) ;" Not all will be required every time, however. "RTN","TMGPUTN0",28,0) ;" DocTitle -- this is the type of document type. i.e. 'OFFICE VISIT' "RTN","TMGPUTN0",29,0) ;" This will be used so that this code can service multiple "RTN","TMGPUTN0",30,0) ;" types, i.e. NOTE, PRESCRIPTION CALL IN, etc. "RTN","TMGPUTN0",31,0) ;" Autosign -- [OPTIONAL] if value=1 then document will be created as SIGNED "RTN","TMGPUTN0",32,0) ;"Results: Document number that uploaded code should be put into is returned in variable Y "RTN","TMGPUTN0",33,0) ;" "RTN","TMGPUTN0",34,0) ;" "RTN","TMGPUTN0",35,0) ;"*How it works*: "RTN","TMGPUTN0",36,0) ;"A remote computer connects to the server running VistA. This remote computer must be "RTN","TMGPUTN0",37,0) ;" able to upload a file using kermit. The only way I know to do this is to be on a PC "RTN","TMGPUTN0",38,0) ;" using a terminal emulator program that has kermit upload ability. "RTN","TMGPUTN0",39,0) ;"From this remote session, get into the TIU menu system and navigate to the option to "RTN","TMGPUTN0",40,0) ;" upload a document. Note, one's upload parameters must be set up for this to work. "RTN","TMGPUTN0",41,0) ;"The remote user will see a #N3, and use this que to acutally upload the file. "RTN","TMGPUTN0",42,0) ;"After the file is uploaded, it is then processed. Each document specifies what 'type' it is "RTN","TMGPUTN0",43,0) ;" for example 'OFFICE VISIT' "RTN","TMGPUTN0",44,0) ;"The server then loads up the parameters for OFFICE VISIT and processes each item in the header. "RTN","TMGPUTN0",45,0) ;"Here is an example progress note that this file can process "RTN","TMGPUTN0",46,0) ;"-------------------------------------- "RTN","TMGPUTN0",47,0) ;"[NewDict]: OFFICE VISIT "RTN","TMGPUTN0",48,0) ;"Name: JONES,BASKETBALL "RTN","TMGPUTN0",49,0) ;"Alias: JONES,BOB "RTN","TMGPUTN0",50,0) ;"DOB: 4/13/71 "RTN","TMGPUTN0",51,0) ;"Sex: MALE "RTN","TMGPUTN0",52,0) ;"SSNumber: 555 11 9999 "RTN","TMGPUTN0",53,0) ;"ChartNumber: 10034 "RTN","TMGPUTN0",54,0) ;"Date: 7/22/2002 "RTN","TMGPUTN0",55,0) ;"Location: Peds_Office "RTN","TMGPUTN0",56,0) ;"Provider: KEVIN TOPPENBERG MD "RTN","TMGPUTN0",57,0) ;"[TEXT] "RTN","TMGPUTN0",58,0) ;" "RTN","TMGPUTN0",59,0) ;" CHIEF COMPLAINT: Follow up blood clot. "RTN","TMGPUTN0",60,0) ;" "RTN","TMGPUTN0",61,0) ;" HPI: "RTN","TMGPUTN0",62,0) ;" 1. BJ was in the emergency room 3 days ago. He was being "RTN","TMGPUTN0",63,0) ;" evaluated for left lower extremity pain. He said that they did "RTN","TMGPUTN0",64,0) ;" radiographic studies and told him that he had a blood clot in "RTN","TMGPUTN0",65,0) ;" .... (snip) "RTN","TMGPUTN0",66,0) ;" "RTN","TMGPUTN0",67,0) ;"[END] "RTN","TMGPUTN0",68,0) ;"-------------------------------------- "RTN","TMGPUTN0",69,0) ;"[NewDic] tells the system that a document header is starting "RTN","TMGPUTN0",70,0) ;"'Name' is a CAPTION, and the value for this caption is 'JONES,BASKETBALL' "RTN","TMGPUTN0",71,0) ;"The upload system will put this value into a variable. In this case, I specified "RTN","TMGPUTN0",72,0) ;" that the variable name TMGNAME to be used. "RTN","TMGPUTN0",73,0) ;" "RTN","TMGPUTN0",74,0) ;"Here are each caption and its cooresponding Variable: "RTN","TMGPUTN0",75,0) ;"Name <--> TMGNAME "RTN","TMGPUTN0",76,0) ;"DOB <--> TMGDOB "RTN","TMGPUTN0",77,0) ;"Sex <--> TMGSEX "RTN","TMGPUTN0",78,0) ;"SSNumber <--> TMGSSNUM "RTN","TMGPUTN0",79,0) ;"ChartNumber <--> TMGPTNUM "RTN","TMGPUTN0",80,0) ;"Date <--> TIUVDT "RTN","TMGPUTN0",81,0) ;"Provider <--> PERSON "RTN","TMGPUTN0",82,0) ;"Alias <--> TMGALIAS "RTN","TMGPUTN0",83,0) ;"Location: <--> TIULOC "RTN","TMGPUTN0",84,0) ;" "RTN","TMGPUTN0",85,0) ;"Document Title is passed to function as 'DocTitle' "RTN","TMGPUTN0",86,0) ;" "RTN","TMGPUTN0",87,0) ;"After the note has been processed and all the above variables have been set, the server "RTN","TMGPUTN0",88,0) ;"calls a 'look-up' function. This function is supposed to return the document number where the "RTN","TMGPUTN0",89,0) ;"text is supposed to be put (the number should be put in Y) "RTN","TMGPUTN0",90,0) ;" "RTN","TMGPUTN0",91,0) ;"This look-up function has an extra twist. I am using it to register patients on the fly "RTN","TMGPUTN0",92,0) ;" if needed. I am doing this because I had about 30,000 patients in my database to transfer, "RTN","TMGPUTN0",93,0) ;" and I had difficulty getting a separate file with just demographics etc. So, if a patient "RTN","TMGPUTN0",94,0) ;" is not already in the database, they are registered here. "RTN","TMGPUTN0",95,0) ;" "RTN","TMGPUTN0",96,0) ;"Extra note: "RTN","TMGPUTN0",97,0) ;"When this function is called, the TIU upload process has already set up some variables. "RTN","TMGPUTN0",98,0) ;"DA = the IEN in 8925.2, i.e. ^TIU(8925.2,DA,"TEXT",0) that the uploaded text was temporarily store in. "RTN","TMGPUTN0",99,0) ;" In other words, here DA = the serial index number of the document to be uploaded "RTN","TMGPUTN0",100,0) ;" i.e. 1 for the first, 2 for the second etc. "RTN","TMGPUTN0",101,0) ;"TIUI = the line index of the beginning of the report to be processed (i.e. the line "RTN","TMGPUTN0",102,0) ;" that starts with [TEXT] "RTN","TMGPUTN0",103,0) ;"DUZ = Current user number. "RTN","TMGPUTN0",104,0) ;"TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params "RTN","TMGPUTN0",105,0) ;"TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. "RTN","TMGPUTN0",106,0) "RTN","TMGPUTN0",107,0) write "+-------------------------------------+",! "RTN","TMGPUTN0",108,0) write "| Starting upload code... |",! "RTN","TMGPUTN0",109,0) write "+-------------------------------------+",! "RTN","TMGPUTN0",110,0) "RTN","TMGPUTN0",111,0) set BuffNum=$get(DA) ;"Store which upload buffer we are working on. "RTN","TMGPUTN0",112,0) set BuffIdx=$get(TIUI) ;"Store line number (in upload buffer) we are starting with. "RTN","TMGPUTN0",113,0) "RTN","TMGPUTN0",114,0) ;"new cName set cName="NAME" "RTN","TMGPUTN0",115,0) ;"new cDOB set cDOB="DOB" "RTN","TMGPUTN0",116,0) ;"new cSex set cSex="SEX" "RTN","TMGPUTN0",117,0) ;"new cSSNum set cSSNum="SSNUM" "RTN","TMGPUTN0",118,0) ;"new cPtNum set cPtNum="PATIENTNUM" "RTN","TMGPUTN0",119,0) ;"new cAlias set cAlias="ALIAS" "RTN","TMGPUTN0",120,0) ;"new cMissing set cMissing="MISSING" "RTN","TMGPUTN0",121,0) ;"new cExtra set cExtra="EXTRA" "RTN","TMGPUTN0",122,0) ;"new cRecNum set cRecNum="RECNUM" "RTN","TMGPUTN0",123,0) ;"new cProvider set cProvider="PROVIDER" "RTN","TMGPUTN0",124,0) ;"new cProvIEN set cProvIEN="PROVIDER IEN" "RTN","TMGPUTN0",125,0) ;"new cLocation set cLocation="LOCATION" "RTN","TMGPUTN0",126,0) ;"new cTranscript set cTranscript="TRANSCRIPTIONIST" "RTN","TMGPUTN0",127,0) ;"new cBadDate set cBadDate="??/??/??" "RTN","TMGPUTN0",128,0) ;"new cPatIEN set cPatIEN="DFN" ;"DFN = Patient IEN "RTN","TMGPUTN0",129,0) ;"new cAutosign set cAutosign="AUTO SIGN" "RTN","TMGPUTN0",130,0) ;"new cDocIEN set cDocIEN="DOC IEN" "RTN","TMGPUTN0",131,0) ;"new cCharTrans set cCharTrans="CHARACTER COUNT - TRANSCRIPTIONIST'S" "RTN","TMGPUTN0",132,0) ;"new cCharTotal set cCharTotal="CHAR COUNT - TOTAL" "RTN","TMGPUTN0",133,0) ;"new cLineCount set cLineCount="LINE COUNT" "RTN","TMGPUTN0",134,0) new cMaxNoteWidth set cMaxNoteWidth=60 "RTN","TMGPUTN0",135,0) "RTN","TMGPUTN0",136,0) ;"Field (f) constants "RTN","TMGPUTN0",137,0) new fPatient set fPatient=.02 ;"field .02 = PATIENT "RTN","TMGPUTN0",138,0) new fVisit set fVisit=.03 ;"field .03 = VISIT "RTN","TMGPUTN0",139,0) new fParentDoc set fParentDoc=.04 ;"field .04 = PARENT DOCUMENT TYPE "RTN","TMGPUTN0",140,0) new fStatus set fStatus=.05 ;"field .05 = STATUS "RTN","TMGPUTN0",141,0) new fParent set fParent=.06 ;"field .06 = PARENT "RTN","TMGPUTN0",142,0) new fStartDate set fStartDate=.07 ;"EPISODE BEGIN DATE/TIME (field .07) "RTN","TMGPUTN0",143,0) new fEndDate set fEndDate=.08 ;"EPISODE END DATE/TIME (field .08) "RTN","TMGPUTN0",144,0) new fEntryDate set fEntryDate=1201 ;"field 1201 = ENTRY DATE/TIME "RTN","TMGPUTN0",145,0) new fAuthor set fAuthor=1202 ;"field 1202 = PERSON/DICTATOR "RTN","TMGPUTN0",146,0) new fExpSigner set fExpSigner=1204 ;"field 1204 = expected Signer "RTN","TMGPUTN0",147,0) new fHospLoc set fHospLoc=1205 ;"field 1205 = HOSPITAL LOCATION "RTN","TMGPUTN0",148,0) new fExpCosign set fExpCosign=1208 ;"field 1208 = expected cosigner "RTN","TMGPUTN0",149,0) new fAttending set fAttending=1209 ;"field 1209 = ATTENDING "RTN","TMGPUTN0",150,0) new fVisitLoc set fVisitLoc=1211 ;"field 1211 = VISIT LOCATION "RTN","TMGPUTN0",151,0) new fRefDate set fRefDate=1301 ;"field 1301 = REFERENCE DATE "RTN","TMGPUTN0",152,0) new fEnteredBy set fEnteredBy=1302 ;"field 1302 = ENTERED BY (a pointer to file 200) "RTN","TMGPUTN0",153,0) new fCapMethod set fCapMethod=1303 ;"field 1303 = CAPTURE METHOD; U-->'upload' "RTN","TMGPUTN0",154,0) new fService set fService=1404 ;"field 1404 = SERVICE "RTN","TMGPUTN0",155,0) new fSignedBy set fSignedBy=1502 ;"field 1502 = signed by "RTN","TMGPUTN0",156,0) new fNeedCosign set fNeedCosign=1506 ;"field 1506 = cosigniture expected. "RTN","TMGPUTN0",157,0) new fCharTrans set fCharTrans=22711 ;"field 22711 = CHAR COUNT -- TRANSCRIPTIONIST "RTN","TMGPUTN0",158,0) new fLineCount set fLineCout=.1 ;"field .1 = LINE COUNT "RTN","TMGPUTN0",159,0) "RTN","TMGPUTN0",160,0) ;" Piece (p) constants "RTN","TMGPUTN0",161,0) new pPatient set pPatient=2 ;"Node 0,piece 2 = PATIENT (field .02) "RTN","TMGPUTN0",162,0) new pVisit set pVisit=3 ;"Node 0,piece 3 = VISIT (field .03) "RTN","TMGPUTN0",163,0) new pStrtDate set pStrtDate=7 ;"Node 0,piece 7 = EPISODE BEGIN DATE/TIME (field .07) "RTN","TMGPUTN0",164,0) new pEndDate set pEndDate=8 ;"Node 0,piece 8 = EPISODE END DATE/TIME (field .08) "RTN","TMGPUTN0",165,0) new pExpSigner set pExpSigner=4 ;"Node 12,piece 4 = EXPECTED SIGNER (field 1204) "RTN","TMGPUTN0",166,0) new pHospLoc set pHospLoc=5 ;"Node 12,piece 5 = HOSPITAL LOCATION (field 1205) "RTN","TMGPUTN0",167,0) new pExpCosign set pExpCosign=8 ;"Node 12,piece 8 = EXPECTED COSIGNER (field 1210) "RTN","TMGPUTN0",168,0) new pAttending set pAttending=9 ;"Node 12,piece 9 = ATTENDING PHYSICIAN (field 1209) "RTN","TMGPUTN0",169,0) new pService set pService=4 ;"Node 14,piece 4 = SERVICE (field 1404) "RTN","TMGPUTN0",170,0) "RTN","TMGPUTN0",171,0) ;"if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGPUTN0",172,0) new TMGDEBUG "RTN","TMGPUTN0",173,0) ;"set TMGDEBUG=+$piece($get(^TMG(22711,1,0)),"^",2) ;2=to Scrn; 3=to file "RTN","TMGPUTN0",174,0) set TMGDEBUG=0 ;"2=to Scrn; 3=to file "RTN","TMGPUTN0",175,0) "RTN","TMGPUTN0",176,0) ;"if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGPUTN0",177,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGPUTN0",178,0) "RTN","TMGPUTN0",179,0) new DBIndent,PriorErrorFound "RTN","TMGPUTN0",180,0) new Patient "RTN","TMGPUTN0",181,0) new DocIEN set DocIEN=-1 "RTN","TMGPUTN0",182,0) new Document "RTN","TMGPUTN0",183,0) new NewDoc set NewDoc=0 "RTN","TMGPUTN0",184,0) new result set result=1 ;"cOKToCont "RTN","TMGPUTN0",185,0) "RTN","TMGPUTN0",186,0) ;"do OpenLogFile^TMGDEBUG("/tmp/","M_Debug_TIUPUTx.tmp") "RTN","TMGPUTN0",187,0) if $get(TMGDEBUG)>0 do OpenDefLogFile^TMGDEBUG "RTN","TMGPUTN0",188,0) "RTN","TMGPUTN0",189,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent," ^TMGPUTN0 (as close to start as possible)") "RTN","TMGPUTN0",190,0) "RTN","TMGPUTN0",191,0) do PtArrayCreate(.Patient) ;"Load upload info into Patient array "RTN","TMGPUTN0",192,0) set result=$$DocArrayCreate(.Document) ;"Load upload document info into Document array "RTN","TMGPUTN0",193,0) if result=cAbort goto LUDone "RTN","TMGPUTN0",194,0) set Document("DFN")=$$GetDFN^TMGGDFN(.Patient) ;"Store DFN of patient. "RTN","TMGPUTN0",195,0) if Document("DFN")'>0 set result=cAbort goto LUDone ;"Abort. "RTN","TMGPUTN0",196,0) set Document("AUTO SIGN")=$get(Autosign,1) ;"default to YES auto-signing "RTN","TMGPUTN0",197,0) ;"06-19-05 Changed to disable autosigning. If document is "RTN","TMGPUTN0",198,0) ;" autosigned here, then no prompt for printing elsewhere. "RTN","TMGPUTN0",199,0) ;"9-1-05 Resuming autosigning. Currently the outside transcriptionists are already "RTN","TMGPUTN0",200,0) ;" printing the notes before giving them to us for upload. "RTN","TMGPUTN0",201,0) ;" Changed default to be YES autosign "RTN","TMGPUTN0",202,0) ;"set Document("AUTO SIGN")=0 ;"override setting passed in... "RTN","TMGPUTN0",203,0) "RTN","TMGPUTN0",204,0) set Document("CHARACTER COUNT - TRANSCRIPTIONIST'S")=$$BuffCharCount() ;"Count character prior to any wrapping/merging etc. "RTN","TMGPUTN0",205,0) set result=$$PrepUploadBuf() ;"Do any word-wrapping etc needed in upload buffer "RTN","TMGPUTN0",206,0) if result=cAbort goto LUDone "RTN","TMGPUTN0",207,0) set DocIEN=$$PrepDoc(.Document,.NewDoc) ;"Prepair a document to put upload into. Credits transcription "RTN","TMGPUTN0",208,0) "RTN","TMGPUTN0",209,0) set Y=DocIEN "RTN","TMGPUTN0",210,0) merge TMGDOC=Document ;"Create a global -- will kill after followup code "RTN","TMGPUTN0",211,0) LUDone "RTN","TMGPUTN0",212,0) ;"put result into Y. TIU filing system looks for results in Yi "RTN","TMGPUTN0",213,0) if result=cAbort set Y=-1 "RTN","TMGPUTN0",214,0) "RTN","TMGPUTN0",215,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",216,0) . do DebugMsg^TMGDEBUG(.DBIndent,"On exit, Y=",Y) "RTN","TMGPUTN0",217,0) . do DebugExit^TMGDEBUG(.DBIndent," ^TMGPUTN0") "RTN","TMGPUTN0",218,0) "RTN","TMGPUTN0",219,0) quit "RTN","TMGPUTN0",220,0) "RTN","TMGPUTN0",221,0) "RTN","TMGPUTN0",222,0) "RTN","TMGPUTN0",223,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGPUTN0",224,0) ;"==============================================================================================- "RTN","TMGPUTN0",225,0) ;" S U B R O U T I N E S "RTN","TMGPUTN0",226,0) ;"==============================================================================================- "RTN","TMGPUTN0",227,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGPUTN0",228,0) ;"PtArrayCreate(Array) "RTN","TMGPUTN0",229,0) ;"DocArrayCreate(Document) "RTN","TMGPUTN0",230,0) ;"PrepDoc(Document,NewDoc); "RTN","TMGPUTN0",231,0) ;"GetDocTIEN(Title) "RTN","TMGPUTN0",232,0) ;"GetLocIEN(Location) "RTN","TMGPUTN0",233,0) ;"GetService(IEN) "RTN","TMGPUTN0",234,0) ;"GetProvIEN(Provider) "RTN","TMGPUTN0",235,0) ;"GetRecord(Document,NewDoc,AskOK,Editable) "RTN","TMGPUTN0",236,0) ;"DocExists(Document) "RTN","TMGPUTN0",237,0) ;"BuffCharCount() "RTN","TMGPUTN0",238,0) ;"PrepUploadBuf() "RTN","TMGPUTN0",239,0) "RTN","TMGPUTN0",240,0) ;"NeedsReformat(MaxWidth) "RTN","TMGPUTN0",241,0) ;"CutNote(Array) "RTN","TMGPUTN0",242,0) ;"PasteNote(Array,NextNoteI) "RTN","TMGPUTN0",243,0) ;"CompToBuff(ExistingIEN,UplTIEN,UplDate) "RTN","TMGPUTN0",244,0) ;"CreateRec(Document) ; "RTN","TMGPUTN0",245,0) ;"StuffRec(Document,PARENT) "RTN","TMGPUTN0",246,0) ;"MakeVisit(Document) "RTN","TMGPUTN0",247,0) ;"FOLLOWUP(DocIEN) ;Post-filing code for PROGRESS NOTES "RTN","TMGPUTN0",248,0) "RTN","TMGPUTN0",249,0) "RTN","TMGPUTN0",250,0) PtArrayCreate(Array) "RTN","TMGPUTN0",251,0) ;"SCOPE: Private "RTN","TMGPUTN0",252,0) ;"Purpose: To put global scope vars (i.e. TMGNAME,TMGSSNUM etc) into "RTN","TMGPUTN0",253,0) ;" an array for easier portability "RTN","TMGPUTN0",254,0) ;"Input: Array, must be passed by reference "RTN","TMGPUTN0",255,0) ;" The global-scope variables setup by the upload system, and are used here: "RTN","TMGPUTN0",256,0) ;" TMGPTNUM,TMGSSNUM,TMGSSNUM,TMGNAME,TMGDOB,TMGSEX "RTN","TMGPUTN0",257,0) ;"Output: Array is loaded with info, like this: "RTN","TMGPUTN0",258,0) ;" set Array("SSNUM")="123-45-6789" "RTN","TMGPUTN0",259,0) ;" set Array("NAME")="DOE,JOHN" "RTN","TMGPUTN0",260,0) ;" set Array("DOB")=TMGDOB "RTN","TMGPUTN0",261,0) ;" set Array("PATIENTNUM")="12345677" "RTN","TMGPUTN0",262,0) ;" set Array("SEX")="M" "RTN","TMGPUTN0",263,0) ;" set Array("ALIAS")="DOE,JOHNNY" "RTN","TMGPUTN0",264,0) ;"Results: none "RTN","TMGPUTN0",265,0) "RTN","TMGPUTN0",266,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PtArrayCreate") "RTN","TMGPUTN0",267,0) "RTN","TMGPUTN0",268,0) if $data(TMGPTNUM)#10'=0 do "RTN","TMGPUTN0",269,0) . set TMGPTNUM=$translate(TMGPTNUM,"PWCI*","") ;"Clean off alpha characters -- not needed. "RTN","TMGPUTN0",270,0) . ;"set TMGPTNUM=$$Trim^TMGSTUTL(TMGPTNUM) "RTN","TMGPUTN0",271,0) . set TMGPTNUM=$$FORMAT^DPTNAME(.TMGPTNUM,3,30) ;"Use same input transform as for .01 field of PATIENT file "RTN","TMGPUTN0",272,0) . set Array("PATIENTNUM")=TMGPTNUM "RTN","TMGPUTN0",273,0) "RTN","TMGPUTN0",274,0) if $data(TMGSSNUM)#10'=0 do "RTN","TMGPUTN0",275,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TMGSSNUM=",TMGSSNUM) "RTN","TMGPUTN0",276,0) . set TMGSSNUM=$translate(TMGSSNUM," /-","") ;"Clean delimiters "RTN","TMGPUTN0",277,0) . if +TMGSSNUM=0 set TMGSSNUM="" ;was ... "P" "RTN","TMGPUTN0",278,0) . if (TMGSSNUM="P")!(+TMGSSNUM>0) set Array("SSNUM")=TMGSSNUM "RTN","TMGPUTN0",279,0) else do "RTN","TMGPUTN0",280,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No TMGSSNUM found") "RTN","TMGPUTN0",281,0) "RTN","TMGPUTN0",282,0) set Array("NAME")=$$FormatName^TMGMISC(.TMGNAME) "RTN","TMGPUTN0",283,0) "RTN","TMGPUTN0",284,0) if $data(TMGALIAS)#10'=0 do "RTN","TMGPUTN0",285,0) . set TMGALIAS=$translate(TMGALIAS,"*","") "RTN","TMGPUTN0",286,0) . set TMGALIAS=$$FORMAT^DPTNAME(TMGALIAS,3,30) ;"convert to 'internal' format (strip .'s etc) "RTN","TMGPUTN0",287,0) . set Array("ALIAS")=TMGALIAS "RTN","TMGPUTN0",288,0) "RTN","TMGPUTN0",289,0) if $data(TMGSEX)#10'=0 do "RTN","TMGPUTN0",290,0) . set TMGSEX=$$UP^XLFSTR($get(TMGSEX)) "RTN","TMGPUTN0",291,0) . if TMGSEX="M" set TMGSEX="MALE" "RTN","TMGPUTN0",292,0) . else if TMGSEX="F" set TMGSEX="FEMALE" "RTN","TMGPUTN0",293,0) . set Array("SEX")=TMGSEX "RTN","TMGPUTN0",294,0) "RTN","TMGPUTN0",295,0) if $data(TMGDOB)#10'=0 do "RTN","TMGPUTN0",296,0) . if +TMGDOB>0 set Array("DOB")=TMGDOB "RTN","TMGPUTN0",297,0) . else quit "RTN","TMGPUTN0",298,0) . new CurDate,CurYr "RTN","TMGPUTN0",299,0) . do DT^DILF("E","T",.CurDate) "RTN","TMGPUTN0",300,0) . set CurDate=$get(CurDate(0)) "RTN","TMGPUTN0",301,0) . if CurDate="" quit "RTN","TMGPUTN0",302,0) . set CurYr=$piece(CurDate,", ",2) "RTN","TMGPUTN0",303,0) . new DOBYr "RTN","TMGPUTN0",304,0) . set DOBYr=$piece(TMGDOB,"/",3) "RTN","TMGPUTN0",305,0) . if DOBYr>CurYr do ;"we have a Y2K problem "RTN","TMGPUTN0",306,0) . . set DOBYr=DOBYr-100 "RTN","TMGPUTN0",307,0) . . if DOBYr'>0 quit "RTN","TMGPUTN0",308,0) . . set TMGDOB=$piece(TMGDOB,"/",1,2)_"/"_DOBYr "RTN","TMGPUTN0",309,0) . . set Array("DOB")=TMGDOB "RTN","TMGPUTN0",310,0) "RTN","TMGPUTN0",311,0) if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array") "RTN","TMGPUTN0",312,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PtArrayCreate") "RTN","TMGPUTN0",313,0) quit "RTN","TMGPUTN0",314,0) "RTN","TMGPUTN0",315,0) "RTN","TMGPUTN0",316,0) "RTN","TMGPUTN0",317,0) DocArrayCreate(Document) "RTN","TMGPUTN0",318,0) ;"SCOPE: Private "RTN","TMGPUTN0",319,0) ;"Purpose: To put TIUVDT etc. etc into an array for easier portibility "RTN","TMGPUTN0",320,0) ;"Input: Document -- OUT parameter, must be passed by reference "RTN","TMGPUTN0",321,0) ;" The global-scope variables setup by the upload system are used: "RTN","TMGPUTN0",322,0) ;" TIUVDT,PERSON,TIULOC, (and also DocTitle) "RTN","TMGPUTN0",323,0) ;"Output: Document is loaded with info. "RTN","TMGPUTN0",324,0) ;"Results: 1=OKToCont, or cAbort "RTN","TMGPUTN0",325,0) "RTN","TMGPUTN0",326,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocArrayCreate") "RTN","TMGPUTN0",327,0) "RTN","TMGPUTN0",328,0) new result set result=1 ;"cOKToCont "RTN","TMGPUTN0",329,0) "RTN","TMGPUTN0",330,0) set Document("PROVIDER")=$get(PERSON) "RTN","TMGPUTN0",331,0) if Document("PROVIDER")="" do goto DACDone "RTN","TMGPUTN0",332,0) . set result=cAbort "RTN","TMGPUTN0",333,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error!! Missing required provider name.") "RTN","TMGPUTN0",334,0) set Document("PROVIDER IEN")=$$GetProvIEN(Document("PROVIDER")) "RTN","TMGPUTN0",335,0) set Document("LOCATION")=$get(TIULOC,"Main_Office") "RTN","TMGPUTN0",336,0) set Document("DATE")=$get(TIUVDT) "RTN","TMGPUTN0",337,0) set Document("TITLE")=$get(DocTitle,"NOTE") "RTN","TMGPUTN0",338,0) "RTN","TMGPUTN0",339,0) ;"Decide which transcriptionist is. This will be used for crediting productivity. "RTN","TMGPUTN0",340,0) ;"If transcriptionist not specified, current user (DUZ) is assumed. "RTN","TMGPUTN0",341,0) if $data(TMGTRANS)#10=0 set TMGTRANS=$piece($get(^VA(200,DUZ,0)),"^",1) "RTN","TMGPUTN0",342,0) set Document("TRANSCRIPTIONIST")=$$FormatName^TMGMISC(TMGTRANS) "RTN","TMGPUTN0",343,0) "RTN","TMGPUTN0",344,0) if (Document("DATE")="")!(Document("DATE")="00/00/00") do goto DACDone "RTN","TMGPUTN0",345,0) . set result=cAbort "RTN","TMGPUTN0",346,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error!! Bad or missing document date.") "RTN","TMGPUTN0",347,0) "RTN","TMGPUTN0",348,0) if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Document") "RTN","TMGPUTN0",349,0) "RTN","TMGPUTN0",350,0) DACDone "RTN","TMGPUTN0",351,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocArrayCreate") "RTN","TMGPUTN0",352,0) quit result "RTN","TMGPUTN0",353,0) "RTN","TMGPUTN0",354,0) "RTN","TMGPUTN0",355,0) "RTN","TMGPUTN0",356,0) PrepDoc(Document,NewDoc); "RTN","TMGPUTN0",357,0) ;"Scope: PRIVATE. "RTN","TMGPUTN0",358,0) ;" Addendum 7/25/07. Will be called by RPC call BLANKTIU^TMGRPC1 "RTN","TMGPUTN0",359,0) ;" to return a blank document "RTN","TMGPUTN0",360,0) ;"Purpose: Prepair a document to put upload into. "RTN","TMGPUTN0",361,0) ;"Input: Document -- an array as follows: "RTN","TMGPUTN0",362,0) ;" Document("DFN")=DFN, the record number of the patient. "RTN","TMGPUTN0",363,0) ;" Document("PROVIDER IEN")= the IEN of the provider "RTN","TMGPUTN0",364,0) ;" Document("LOCATION")= the location of the visit "RTN","TMGPUTN0",365,0) ;" Document("DATE")= the date of the visit. "RTN","TMGPUTN0",366,0) ;" Document("TITLE")= the title of the note "RTN","TMGPUTN0",367,0) ;" Document(cVisitStr) an OUT PARAMETER "RTN","TMGPUTN0",368,0) ;" Document("TRANSCRIPTIONIST") -- the name of the transcriptionist "RTN","TMGPUTN0",369,0) ;" Document("CHARACTER COUNT - TRANSCRIPTIONIST'S") -- the char count creditable to transcriptionist "RTN","TMGPUTN0",370,0) ;" NewDoc: OPTIONAL flag, passed back with "RTN","TMGPUTN0",371,0) ;" NewDoc = 1 if returned docmt is new "RTN","TMGPUTN0",372,0) ;" NewDoc = 0 if returned docmt already existed, timeout, etc "RTN","TMGPUTN0",373,0) ;"Results: returns record number (IEN) ready to accept upload (or -1 if failure) "RTN","TMGPUTN0",374,0) ;" Also Document("DOC IEN") will have this same IEN "RTN","TMGPUTN0",375,0) ;" NOTE: if result is -1 then errors are passed back in "RTN","TMGPUTN0",376,0) ;" Document("ERROR") node "RTN","TMGPUTN0",377,0) ;" Document("ERROR",n)="ERROR.. Stuffing new document." "RTN","TMGPUTN0",378,0) ;" Document("ERROR","NUM")=n "RTN","TMGPUTN0",379,0) ;" Document("ERROR","FM INFO")=merge with DIERR array "RTN","TMGPUTN0",380,0) "RTN","TMGPUTN0",381,0) ;" PIEN = patient internal entry number "RTN","TMGPUTN0",382,0) ;" Global-Scope variables expected: "RTN","TMGPUTN0",383,0) ;" PERSON, TMGSSNUM etc. defined above "RTN","TMGPUTN0",384,0) ;" TIUVDT expected "RTN","TMGPUTN0",385,0) ;" TIULOC is also expected (i.e. 'LAUGHLIN_OFFICE') "RTN","TMGPUTN0",386,0) ;" "RTN","TMGPUTN0",387,0) ;"Output: will return document number, or -1 if failure. "RTN","TMGPUTN0",388,0) ;"NOTES: This originated from ^TIUPUTPN "RTN","TMGPUTN0",389,0) ;" "RTN","TMGPUTN0",390,0) ;" Look-up code used by router/filer "RTN","TMGPUTN0",391,0) ;" Required variables: TMGSSNUM, TIUVDT "RTN","TMGPUTN0",392,0) ;" i.e., TMGSSNUM (Pt SS-Number) and TIUVDT (visit date) must be set prior to call. "RTN","TMGPUTN0",393,0) ;" "RTN","TMGPUTN0",394,0) "RTN","TMGPUTN0",395,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PrepDoc") "RTN","TMGPUTN0",396,0) "RTN","TMGPUTN0",397,0) new cIntDate set cIntDate="DATE"_"-Internal" "RTN","TMGPUTN0",398,0) new cStartDate set cStartDate="EDT" "RTN","TMGPUTN0",399,0) new cEndDate set cEndDate="LDT" "RTN","TMGPUTN0",400,0) new cService set cService="SVC" "RTN","TMGPUTN0",401,0) new cDocType set cDocType="TYPE" "RTN","TMGPUTN0",402,0) new cDocTIEN set cDocTIEN="TYPE IEN" "RTN","TMGPUTN0",403,0) new cHspLocIEN set cHspLocIEN="LOC" "RTN","TMGPUTN0",404,0) new cVstLocIEN set cVstLocIEN="VLOC" "RTN","TMGPUTN0",405,0) new cVisitStr set cVisitStr="VSTR" "RTN","TMGPUTN0",406,0) new cVisitIEN set cVisitIEN="VISIT" "RTN","TMGPUTN0",407,0) new cStopCode set cStopCode="STOP" "RTN","TMGPUTN0",408,0) "RTN","TMGPUTN0",409,0) new TMG "RTN","TMGPUTN0",410,0) new DFN "RTN","TMGPUTN0",411,0) new TIUDAD,TIUEDIT "RTN","TMGPUTN0",412,0) new TIULDT,TIUXCRP,DocTIEN "RTN","TMGPUTN0",413,0) new LocIEN "RTN","TMGPUTN0",414,0) new result set result=-1 "RTN","TMGPUTN0",415,0) set NewDoc=0 "RTN","TMGPUTN0",416,0) "RTN","TMGPUTN0",417,0) set Document(cStartDate)=$$IDATE^TIULC(Document("DATE")) ;"Convert date into internal format "RTN","TMGPUTN0",418,0) set Document(cEndDate)=Document(cStartDate) ;"For office notes, begin and end dates will be the same. "RTN","TMGPUTN0",419,0) "RTN","TMGPUTN0",420,0) ;"Setup DocTIEN -- to be used below as [MAS Movement event type] "RTN","TMGPUTN0",421,0) ;"Convert Document title into IEN, i.e. OFFICE VISIT --> 128 "RTN","TMGPUTN0",422,0) set DocTIEN=$$GetDocTIEN(Document("TITLE")) "RTN","TMGPUTN0",423,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DocTIEN=",DocTIEN) "RTN","TMGPUTN0",424,0) if +DocTIEN'>0 do goto PrepDocX "RTN","TMGPUTN0",425,0) . set Document("ERROR",1)="ERROR: Unable to determine note type from title: "_Document("TITLE") "RTN","TMGPUTN0",426,0) . set Document("ERROR","NUM")=1 "RTN","TMGPUTN0",427,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,Document("ERROR",1)) "RTN","TMGPUTN0",428,0) "RTN","TMGPUTN0",429,0) ;"Purpose: setup Document(cDocType) -- used below as: Title info variable of form: "RTN","TMGPUTN0",430,0) ;" Setup string in form of: 1^title IEN^title Name "RTN","TMGPUTN0",431,0) ;" e.g.: 1^128^OFFICE VISIT^OFFICE VISIT "RTN","TMGPUTN0",432,0) set Document(cDocTIEN)=DocTIEN "RTN","TMGPUTN0",433,0) set Document(cDocType)=1_"^"_DocTIEN_"^"_$$PNAME^TIULC1(DocTIEN) "RTN","TMGPUTN0",434,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Document('TYPE'): ",Document(cDocType)) "RTN","TMGPUTN0",435,0) "RTN","TMGPUTN0",436,0) ;"do MAIN^TIUVSIT(.TIU,.DFN,TMGSSNUM,Document(cStartDate),Document(cEndDate),"LAST",0,Document("LOCATION")) "RTN","TMGPUTN0",437,0) "RTN","TMGPUTN0",438,0) ;" setup LocIEN from HOSPITAL LOCATION file (#44) "RTN","TMGPUTN0",439,0) ;" This contains entries like 'Laughlin_Office' "RTN","TMGPUTN0",440,0) set LocIEN=+$$GetLocIEN(Document("LOCATION")) "RTN","TMGPUTN0",441,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Now LocIEN=",LocIEN) "RTN","TMGPUTN0",442,0) if '$data(^SC(LocIEN,0)) do goto PrepDocX ;"^SC(*) is file 44, Hospital Location "RTN","TMGPUTN0",443,0) . set Document("ERROR",1)="ERROR: Unable to process location: "_Document("LOCATION") "RTN","TMGPUTN0",444,0) . set Document("ERROR","NUM")=1 "RTN","TMGPUTN0",445,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,Document("ERROR",1)) "RTN","TMGPUTN0",446,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"^SC(",LocIEN,") = ",$get(^SC(LocIEN))) "RTN","TMGPUTN0",447,0) "RTN","TMGPUTN0",448,0) set Document(cService)=$$GetService(Document("PROVIDER IEN")) ;"i.e. FAMILY PRACTICE "RTN","TMGPUTN0",449,0) set Document(cVisitStr)="x;x;"_DocTIEN ;"LOC;VDT;VTYP "RTN","TMGPUTN0",450,0) set Document(cVisitIEN)=0 ;"Visit File IFN "RTN","TMGPUTN0",451,0) set Document(cHspLocIEN)=LocIEN "RTN","TMGPUTN0",452,0) set Document(cVstLocIEN)=LocIEN "RTN","TMGPUTN0",453,0) set Document(cStopCode)=0 ;"0=FALSE, don't worry about stop codes. "RTN","TMGPUTN0",454,0) "RTN","TMGPUTN0",455,0) set result=$$GetRecord(.Document,.NewDoc,0) "RTN","TMGPUTN0",456,0) if result'>0 do goto PrepDocX "RTN","TMGPUTN0",457,0) . new n set n=+$get(Document("ERROR","NUM"))+1 "RTN","TMGPUTN0",458,0) . set Document("ERROR",n)="ERROR.. after creating new document." "RTN","TMGPUTN0",459,0) . set Document("ERROR","NUM")=n "RTN","TMGPUTN0",460,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,Document("ERROR",n)) "RTN","TMGPUTN0",461,0) "RTN","TMGPUTN0",462,0) ;"At this point, any merging has been done (once implemented) "RTN","TMGPUTN0",463,0) ;"So a character count of now will be a total/combined character count "RTN","TMGPUTN0",464,0) set Document("CHAR COUNT - TOTAL")=$$BuffCharCount ;"Count character after any wrapping/merging etc. "RTN","TMGPUTN0",465,0) ;"Now, we need the standard CHARARACTERS/LINE value stored in field .03 of TIU PARAMETERS (in ^TIU(8925.99)) "RTN","TMGPUTN0",466,0) ;"For my setup, I have only have one record for in this file, so I'll use IEN=1. "RTN","TMGPUTN0",467,0) new CharsPerLine set CharsPerLine=$piece($get(^TIU(8925.99,1,0)),"^",3) "RTN","TMGPUTN0",468,0) if CharsPerLine'=0 do "RTN","TMGPUTN0",469,0) . new IntLC,LC,Delta "RTN","TMGPUTN0",470,0) . set LC=Document("CHAR COUNT - TOTAL")\CharsPerLine "RTN","TMGPUTN0",471,0) . set IntLC=Document("CHAR COUNT - TOTAL")\CharsPerLine ;" \ is integer divide "RTN","TMGPUTN0",472,0) . set Delta=(LC-IntLC)*10 "RTN","TMGPUTN0",473,0) . if Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value. "RTN","TMGPUTN0",474,0) . set Document("LINE COUNT")=IntLC "RTN","TMGPUTN0",475,0) "RTN","TMGPUTN0",476,0) set result=$$StuffRec(.Document,0) "RTN","TMGPUTN0",477,0) if +$get(result)'>0 do goto PrepDocX "RTN","TMGPUTN0",478,0) . new n set n=+$get(Document("ERROR","NUM"))+1 "RTN","TMGPUTN0",479,0) . set Document("ERROR",n)="ERROR.. Stuffing new document." "RTN","TMGPUTN0",480,0) . set Document("ERROR","NUM")=n "RTN","TMGPUTN0",481,0) . ;"Note: StuffRec will also load Document("ERROR","FM INFO") with FM errors "RTN","TMGPUTN0",482,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,Document("ERROR",n)) "RTN","TMGPUTN0",483,0) N "RTN","TMGPUTN0",484,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Blank document successfully created. Doc#=",result) "RTN","TMGPUTN0",485,0) "RTN","TMGPUTN0",486,0) PrepDocXN "RTN","TMGPUTN0",487,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",488,0) . do DebugMsg^TMGDEBUG(.DBIndent,"Returning result=",$get(result)) "RTN","TMGPUTN0",489,0) . do DebugExit^TMGDEBUG(.DBIndent,"PrepDoc") "RTN","TMGPUTN0",490,0) quit result ;"result is document # "RTN","TMGPUTN0",491,0) "RTN","TMGPUTN0",492,0) "RTN","TMGPUTN0",493,0) MakeVisit(Document) "RTN","TMGPUTN0",494,0) ;"Purpose -- to create a new entery in the VISIT file, based on info in Document. "RTN","TMGPUTN0",495,0) ;"Input -- Document -- array with following info: "RTN","TMGPUTN0",496,0) ;" Document("DFN")=DFN, the record number of the patient. "RTN","TMGPUTN0",497,0) ;" Document("PROVIDER")= the provider of care for the note "RTN","TMGPUTN0",498,0) ;" Document("PROVIDER IEN")= the IEN of the provider "RTN","TMGPUTN0",499,0) ;" Document("LOCATION")= the location of the visit "RTN","TMGPUTN0",500,0) ;" Document("DATE")= the date of the visit. "RTN","TMGPUTN0",501,0) ;"Result -- returns IEN of visit entry "RTN","TMGPUTN0",502,0) "RTN","TMGPUTN0",503,0) ;"Note -- this function is not now being used... "RTN","TMGPUTN0",504,0) "RTN","TMGPUTN0",505,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"MakeVisit") "RTN","TMGPUTN0",506,0) "RTN","TMGPUTN0",507,0) new TMGFDA "RTN","TMGPUTN0",508,0) "RTN","TMGPUTN0",509,0) ;set TMGFDA(9000010,"?+1,",.01)= ;".01=VISIT/ADMIT DATE&TIME "RTN","TMGPUTN0",510,0) ;set TMGFDA(9000010,"?+1,",.02)= ;".02=DATE VISIT CREATED "RTN","TMGPUTN0",511,0) ;set TMGFDA(9000010,"?+1,",.03)="O" ;".02=VISIT TYPE -- O=Other "RTN","TMGPUTN0",512,0) ;set TMGFDA(9000010,"?+1,",.05)= ;".05=PATIENT NAME "RTN","TMGPUTN0",513,0) ;set TMGFDA(9000010,"?+1,",15001)="10C1-TEST" ;"15001=VISIT ID "RTN","TMGPUTN0",514,0) ;LOCATION NAME --> Medical Group of Greeneville "RTN","TMGPUTN0",515,0) ;SERVICE CATEGORY: A --> AMBULATORY "RTN","TMGPUTN0",516,0) ;DSS ID: PRIMARY CARE/MEDICINE "RTN","TMGPUTN0",517,0) ;HOSPITAL LOCATION: Laughlin_Office "RTN","TMGPUTN0",518,0) ;Created by user: DUZ "RTN","TMGPUTN0",519,0) "RTN","TMGPUTN0",520,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"MakeVisit") "RTN","TMGPUTN0",521,0) quit "RTN","TMGPUTN0",522,0) "RTN","TMGPUTN0",523,0) "RTN","TMGPUTN0",524,0) GetDocTIEN(Title) "RTN","TMGPUTN0",525,0) ;"Purpose: To return IEN for document *type defination* / Identify document title "RTN","TMGPUTN0",526,0) ;"Input Title -- the Text Title to look up "RTN","TMGPUTN0",527,0) ;"Results: Returns the document definition IFN (i.e. Y) "RTN","TMGPUTN0",528,0) "RTN","TMGPUTN0",529,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetDocTIEN") "RTN","TMGPUTN0",530,0) "RTN","TMGPUTN0",531,0) new DIC,Y,X "RTN","TMGPUTN0",532,0) new TIUFPRIV set TIUFPRIV=1 "RTN","TMGPUTN0",533,0) "RTN","TMGPUTN0",534,0) set DIC=8925.1 "RTN","TMGPUTN0",535,0) set DIC(0)="M" "RTN","TMGPUTN0",536,0) set DIC("S")="IF $PIECE(^TIU(8925.1,+Y,0),""^"",4)=""DOC""" "RTN","TMGPUTN0",537,0) set X=Title "RTN","TMGPUTN0",538,0) do ^DIC "RTN","TMGPUTN0",539,0) kill DIC("S") "RTN","TMGPUTN0",540,0) if $find(Y,"^")>0 set Y=$piece(Y,"^",1) "RTN","TMGPUTN0",541,0) "RTN","TMGPUTN0",542,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IEN for document type: ",Title," = ",Y) "RTN","TMGPUTN0",543,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetDocTIEN") "RTN","TMGPUTN0",544,0) quit Y "RTN","TMGPUTN0",545,0) "RTN","TMGPUTN0",546,0) "RTN","TMGPUTN0",547,0) GetLocIEN(Location) "RTN","TMGPUTN0",548,0) ;"Scope: PRIVATE "RTN","TMGPUTN0",549,0) ;"Purpose: To return IEN for location "RTN","TMGPUTN0",550,0) ;"Input: Location -- the Location to look up. "RTN","TMGPUTN0",551,0) ;"Results: returns LocationIEN (i.e. Y) "RTN","TMGPUTN0",552,0) "RTN","TMGPUTN0",553,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetLocIEN") "RTN","TMGPUTN0",554,0) new DIC,X,Y "RTN","TMGPUTN0",555,0) set DIC=44 ;"file 44 is HOSPITAL LOCATION "RTN","TMGPUTN0",556,0) set DIC(0)="M" "RTN","TMGPUTN0",557,0) set X=Location "RTN","TMGPUTN0",558,0) do ^DIC ;" do a , value is returned in Y "RTN","TMGPUTN0",559,0) if $find(Y,"^")>0 set Y=$piece(Y,"^",1) "RTN","TMGPUTN0",560,0) "RTN","TMGPUTN0",561,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Location IEN for ",Location," = ",Y) "RTN","TMGPUTN0",562,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetLocIEN") "RTN","TMGPUTN0",563,0) quit Y "RTN","TMGPUTN0",564,0) "RTN","TMGPUTN0",565,0) "RTN","TMGPUTN0",566,0) GetService(IEN) "RTN","TMGPUTN0",567,0) ;"Scope: PRIVATE "RTN","TMGPUTN0",568,0) ;"Purpose: Get the Service for the Provider "RTN","TMGPUTN0",569,0) ;"Input: IEN -- the IEN of the Provider to look up. "RTN","TMGPUTN0",570,0) ;"Results: returns the Name of the Service for provider, or "" if not found "RTN","TMGPUTN0",571,0) "RTN","TMGPUTN0",572,0) new result set result="" "RTN","TMGPUTN0",573,0) new node,SvIEN "RTN","TMGPUTN0",574,0) "RTN","TMGPUTN0",575,0) if IEN=-1 goto GtSvDone "RTN","TMGPUTN0",576,0) set node=$get(^VA(200,IEN,5)) ;"^VA(200, is NEW PERSON file "RTN","TMGPUTN0",577,0) set SvIEN=+$piece(node,"^",1) "RTN","TMGPUTN0",578,0) if SvIEN=0 goto GtSvDone "RTN","TMGPUTN0",579,0) set node=$get(^DIC(49,SvIEN,0)) ;"^DIC(49, is the SERVICE/SECTION file "RTN","TMGPUTN0",580,0) set result=$piece(node,"^",1) "RTN","TMGPUTN0",581,0) "RTN","TMGPUTN0",582,0) GtSvDone "RTN","TMGPUTN0",583,0) quit result "RTN","TMGPUTN0",584,0) "RTN","TMGPUTN0",585,0) "RTN","TMGPUTN0",586,0) GetProvIEN(Provider) "RTN","TMGPUTN0",587,0) ;"Scope: PRIVATE "RTN","TMGPUTN0",588,0) ;"Purpose: To return IEN for Provider "RTN","TMGPUTN0",589,0) ;"Input: Provider -- the Provider to look up. "RTN","TMGPUTN0",590,0) ;"Results: returns Provider's IEN (i.e. Y), or -1 if not found "RTN","TMGPUTN0",591,0) "RTN","TMGPUTN0",592,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetProvIEN") "RTN","TMGPUTN0",593,0) new DIC,X,Y "RTN","TMGPUTN0",594,0) set DIC=200 ;"file 200 is NEW PERSON "RTN","TMGPUTN0",595,0) set DIC(0)="M" "RTN","TMGPUTN0",596,0) set X=Provider "RTN","TMGPUTN0",597,0) do ^DIC ;" do a , value is returned in Y "RTN","TMGPUTN0",598,0) if $find(Y,"^")>0 set Y=$piece(Y,"^",1) "RTN","TMGPUTN0",599,0) "RTN","TMGPUTN0",600,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetProvIEN") "RTN","TMGPUTN0",601,0) quit Y "RTN","TMGPUTN0",602,0) "RTN","TMGPUTN0",603,0) "RTN","TMGPUTN0",604,0) GetRecord(Document,NewDoc,AskOK,Editable) "RTN","TMGPUTN0",605,0) ;"Scope: PRIVATE "RTN","TMGPUTN0",606,0) ;"PURPOSE: "RTN","TMGPUTN0",607,0) ;" To get a record--either via creating a new one, or returning an existing one "RTN","TMGPUTN0",608,0) ;" Note: If an existing one is returned, it will be emptied first... "RTN","TMGPUTN0",609,0) ;" "RTN","TMGPUTN0",610,0) ;" Note: If I want to merge part of what the doctor creates with what the "RTN","TMGPUTN0",611,0) ;" transcriptionist uploads, here what I should do "RTN","TMGPUTN0",612,0) ;" 1. Look for an existing document with same date as document being uploaded. "RTN","TMGPUTN0",613,0) ;" 2. If found, look in existing document for merge symbols (i.e. {{1}} } "RTN","TMGPUTN0",614,0) ;" 3. If found, then take code from existing document and current part "RTN","TMGPUTN0",615,0) ;" of upload buffer, and create a merged document. "RTN","TMGPUTN0",616,0) ;" 4. Put this merged document back into the upload buffer. "RTN","TMGPUTN0",617,0) ;" 5. Empty the existing document, and return its IEN from this function "RTN","TMGPUTN0",618,0) ;" "RTN","TMGPUTN0",619,0) ;"INPUT: Document -- array with Document("DFN"), Document(cDocType) are REQUIRED. "RTN","TMGPUTN0",620,0) ;" [Document] --> Visit info array -- SHOULD PASS BE REFERENCE. "RTN","TMGPUTN0",621,0) ;" Document("DFN") = patient DFN "RTN","TMGPUTN0",622,0) ;" Document(cVisitStr) = LOC;VDT;VTYP e.g. 'x;x;OFFICE VISIT' "RTN","TMGPUTN0",623,0) ;" Document(cVisitIEN) = VISIT file IFN e.g. 0, used for field .03 in file 8925. Pointer to file #9000010 "RTN","TMGPUTN0",624,0) ;" Document(cHspLocIEN) i.e. Hospital location IEN. Used for field 1205 in 8925. Pointer to file #44 "RTN","TMGPUTN0",625,0) ;" Document(cVstLocIEN) i.e. visit location IEN. Used for field 1211 in 8925. Pointer to file #44 "RTN","TMGPUTN0",626,0) ;" Document(cStopCode) = mark to defer workload e.g. 0/FALSE=don't worry about stop codes. "RTN","TMGPUTN0",627,0) ;" USED FOR: Mark record for deferred crediting of stop code (fld #.11) "RTN","TMGPUTN0",628,0) ;" This boolean field (.11) indicates whether the stop code associated with a new "RTN","TMGPUTN0",629,0) ;" visit should be credited when the note is completed. "RTN","TMGPUTN0",630,0) ;" Note: if Document('STOP')="", then not processed. "RTN","TMGPUTN0",631,0) ;" Document(cDocType)=1^title DA^title Name i.e.: 1^128^OFFICE VISIT^OFFICE VISIT "RTN","TMGPUTN0",632,0) ;" Document(cDocTIEN)=DocTIEN (a.k.a. title DA) e.g. 128 "RTN","TMGPUTN0",633,0) ;" Document(cService) e.g.FAMILY PRACTICE "RTN","TMGPUTN0",634,0) ;" Document(cStartDate) i.e. event begin time "RTN","TMGPUTN0",635,0) ;" Document(cEndDate) i.e. event end time "RTN","TMGPUTN0",636,0) ;" [NewDoc] --> flag, passed back with "RTN","TMGPUTN0",637,0) ;" NewDoc = 1 if returned docmt is new "RTN","TMGPUTN0",638,0) ;" NewDoc = 0 if returned docmt already existed, timeout, etc "RTN","TMGPUTN0",639,0) ;" [AskOK] --> Ask user flag, where "RTN","TMGPUTN0",640,0) ;" AskOK = 1: ask re edit/addend existing docmt "RTN","TMGPUTN0",641,0) ;" (Interactive List Manager options, TRY docmt def) "RTN","TMGPUTN0",642,0) ;" AskOK = 0: don't ask (Upload & GUI options) "RTN","TMGPUTN0",643,0) ;" [Editable]-->flag, passed back with Editable = 1 if returned "RTN","TMGPUTN0",644,0) ;" PREEXISTING docmt can be edited by Provider. If "RTN","TMGPUTN0",645,0) ;" preexisting docmt returned and 'Editable, then "RTN","TMGPUTN0",646,0) ;" docmt cannot be edited by Provider. "RTN","TMGPUTN0",647,0) ;" "RTN","TMGPUTN0",648,0) ;"Results: Returns DocIEN -- IEN of document to use, or -1 if error etc. "RTN","TMGPUTN0",649,0) ;" Also, Document("DOC IEN") is set to DocIEN "RTN","TMGPUTN0",650,0) ;" Errors will be returned in Document("ERROR") "RTN","TMGPUTN0",651,0) ;" "RTN","TMGPUTN0",652,0) ;"Note: Code originally from GETRECNM^TIUEDI3 -- KT 5/25/04 "RTN","TMGPUTN0",653,0) "RTN","TMGPUTN0",654,0) "RTN","TMGPUTN0",655,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetRecord") "RTN","TMGPUTN0",656,0) "RTN","TMGPUTN0",657,0) new MultOK set MultOK=1 "RTN","TMGPUTN0",658,0) new DocIEN set DocIEN=-1 "RTN","TMGPUTN0",659,0) set NewDoc=0 "RTN","TMGPUTN0",660,0) "RTN","TMGPUTN0",661,0) if +$get(BuffNum)'=0 set DocIEN=$$DocExists(.Document) ;"avoid error with RPC calls "RTN","TMGPUTN0",662,0) else set DocIEN=0 "RTN","TMGPUTN0",663,0) set Document("DOC IEN")=DocIEN "RTN","TMGPUTN0",664,0) if DocIEN>0 do goto GRDone ;"DocIEN>0 means that the TEXT of the report is an exact match "RTN","TMGPUTN0",665,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Found a prior matching document that will be overwriten") "RTN","TMGPUTN0",666,0) . kill ^TIU(8925,DocIEN,"TEXT") ;"Kill the TEXT prior report, so we can overwrite it "RTN","TMGPUTN0",667,0) else do "RTN","TMGPUTN0",668,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No prior matching document found. No overwrite planned.") "RTN","TMGPUTN0",669,0) . set DocIEN=$$CreateRec(.Document) "RTN","TMGPUTN0",670,0) . set NewDoc=1 "RTN","TMGPUTN0",671,0) "RTN","TMGPUTN0",672,0) GRDone ; "RTN","TMGPUTN0",673,0) if NewDoc,DocIEN'>0 set NewDoc=0 "RTN","TMGPUTN0",674,0) set Document("DOC IEN")=DocIEN "RTN","TMGPUTN0",675,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Return DocIEN (record#)=",DocIEN) "RTN","TMGPUTN0",676,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetRecord") "RTN","TMGPUTN0",677,0) quit DocIEN ;"DocIEN is document number "RTN","TMGPUTN0",678,0) "RTN","TMGPUTN0",679,0) "RTN","TMGPUTN0",680,0) DocExists(Document) "RTN","TMGPUTN0",681,0) ;"PURPOSE: To return document IEN, if it already EXISTS for the "RTN","TMGPUTN0",682,0) ;" given patient, title, and visit. "RTN","TMGPUTN0",683,0) ;"INPUT: Document -- see documentation of format in $$GetRecord "RTN","TMGPUTN0",684,0) ;"Results: returns a value for document (i.e. DocIEN), or -1 if no prior doc is found. "RTN","TMGPUTN0",685,0) ;" "RTN","TMGPUTN0",686,0) ;"Note: The following documents are ignored: "RTN","TMGPUTN0",687,0) ;" - docmts of status deleted or retracted "RTN","TMGPUTN0",688,0) ;" - all docmts if run across a docmt w/ requesting pkg "RTN","TMGPUTN0",689,0) ;" - If REQEDIT, then also ignore docmts PERSON cannot edit. "RTN","TMGPUTN0",690,0) ;"Note: If there are more than one, get the smallest DA. "RTN","TMGPUTN0",691,0) "RTN","TMGPUTN0",692,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocExists") "RTN","TMGPUTN0",693,0) "RTN","TMGPUTN0",694,0) new DocIEN set DocIEN=-1 "RTN","TMGPUTN0",695,0) new index "RTN","TMGPUTN0",696,0) "RTN","TMGPUTN0",697,0) ;"After uploading old progress notes, I should restore code that sees if I SHOULD be editing. "RTN","TMGPUTN0",698,0) "RTN","TMGPUTN0",699,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Upload Buffer") "RTN","TMGPUTN0",700,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("^TIU(8925.2,BuffNum)") "RTN","TMGPUTN0",701,0) "RTN","TMGPUTN0",702,0) if $data(^TIU(8925,"C",Document("DFN")))=0 goto DEDone "RTN","TMGPUTN0",703,0) ;"Scan through all documents for patient (DFN) "RTN","TMGPUTN0",704,0) set index=$order(^TIU(8925,"C",Document("DFN"),"")) "RTN","TMGPUTN0",705,0) if index="" goto DEDone "RTN","TMGPUTN0",706,0) for do quit:(index="") "RTN","TMGPUTN0",707,0) . new DocCompValue "RTN","TMGPUTN0",708,0) . ;"new KeyIn ;temp --removed 7/30/07 to avoid RPC error "RTN","TMGPUTN0",709,0) . ;"read *KeyIn:0 "RTN","TMGPUTN0",710,0) . ;"if KeyIn=" " set index="" quit "RTN","TMGPUTN0",711,0) . set DocCompValue=$$CompToBuff(index,Document(cDocTIEN),Document(cStartDate)) "RTN","TMGPUTN0",712,0) . if DocCompValue=2 do quit ;"i.e. documents are an exact match "RTN","TMGPUTN0",713,0) . . ;"For below, the document is the same as the upload buffer. "RTN","TMGPUTN0",714,0) . . ;"We have found our answer. "RTN","TMGPUTN0",715,0) . . ;" "RTN","TMGPUTN0",716,0) . . ;"Below is code I can use to check to see if I SHOULD be editing. "RTN","TMGPUTN0",717,0) . . ;"------------------------------------------------------ "RTN","TMGPUTN0",718,0) . . ;"new CANEDIT,CANDel "RTN","TMGPUTN0",719,0) . . ;"set CANEDIT=+$$CANDO^TIULP(index,"EDIT RECORD",Document("PROVIDER IEN")) "RTN","TMGPUTN0",720,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent," Editable?=",CANEDIT "RTN","TMGPUTN0",721,0) . . ;"set CANDel=+$$CANDO^TIULP(index,"DELETE RECORD",Document("PROVIDER IEN")) "RTN","TMGPUTN0",722,0) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent," Deletable?=",CANDel) "RTN","TMGPUTN0",723,0) . . ;"if +CANEDIT>0 set DocIEN=index "RTN","TMGPUTN0",724,0) . . set DocIEN=index set index="" quit "RTN","TMGPUTN0",725,0) . set index=$order(^TIU(8925,"C",Document("DFN"),index)) "RTN","TMGPUTN0",726,0) "RTN","TMGPUTN0",727,0) DEDone "RTN","TMGPUTN0",728,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"resulting DocIEN=",DocIEN) "RTN","TMGPUTN0",729,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocExists") "RTN","TMGPUTN0",730,0) quit DocIEN "RTN","TMGPUTN0",731,0) "RTN","TMGPUTN0",732,0) "RTN","TMGPUTN0",733,0) BuffCharCount() "RTN","TMGPUTN0",734,0) ;"Purpose: To count the number of characters in the current upload buffer, for the "RTN","TMGPUTN0",735,0) ;" current document. The upload buffer puts all the documents being uploaded "RTN","TMGPUTN0",736,0) ;" into one big WP array. This function will count down until the text "RTN","TMGPUTN0",737,0) ;" signal is found to start the next documnent (e.g. '[NewDict]') "RTN","TMGPUTN0",738,0) ;"Input: none. However, several global-scope variables are used. "RTN","TMGPUTN0",739,0) ;" By tracing through the upload code I know that "RTN","TMGPUTN0",740,0) ;" the following variables are set: "RTN","TMGPUTN0",741,0) ;" (I saved DA as BuffNum, and TIUI as BuffIdx) "RTN","TMGPUTN0",742,0) ;" TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params "RTN","TMGPUTN0",743,0) ;" TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. "RTN","TMGPUTN0",744,0) ;" BuffIdx = the line index of the beginning of the report to be processed (i.e. the line "RTN","TMGPUTN0",745,0) ;" that starts with [TEXT] "RTN","TMGPUTN0",746,0) ;" BuffNum = the index in 8925.2, i.e. ^TIU(8925.2,BuffNum,"TEXT",0) "RTN","TMGPUTN0",747,0) ;" In other words, here BuffNum = the serial index number of the document to "RTN","TMGPUTN0",748,0) ;" be uploaded i.e. 1 for the first, 2 for the second etc. "RTN","TMGPUTN0",749,0) ;"Notes "RTN","TMGPUTN0",750,0) ;" 8925.2 is file: TIU UPLOAD BUFFER "RTN","TMGPUTN0",751,0) ;" To detect the beginning of the next document, use "RTN","TMGPUTN0",752,0) ;" if MyLine[TIUHSIG then abort "RTN","TMGPUTN0",753,0) ;" I trim of leading and trailing white-space before counting. "RTN","TMGPUTN0",754,0) ;" But, otherwise spaces will be counted "RTN","TMGPUTN0",755,0) ;" "RTN","TMGPUTN0",756,0) ;"Results: Returns character count, or 0 if none found. "RTN","TMGPUTN0",757,0) "RTN","TMGPUTN0",758,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"BuffCharCount") "RTN","TMGPUTN0",759,0) "RTN","TMGPUTN0",760,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Scan ^TIU(8925.2,",BuffNum,",TEXT) starting at index: ",BuffIdx) "RTN","TMGPUTN0",761,0) "RTN","TMGPUTN0",762,0) new index "RTN","TMGPUTN0",763,0) new result set result=0 "RTN","TMGPUTN0",764,0) if $get(TIUHSIG)="" do goto BuffCDone "RTN","TMGPUTN0",765,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TIUHSIG=''! No further search possible") "RTN","TMGPUTN0",766,0) "RTN","TMGPUTN0",767,0) set index=$order(^TIU(8925.2,BuffNum,"TEXT",BuffIdx)) "RTN","TMGPUTN0",768,0) for do quit:(index="") "RTN","TMGPUTN0",769,0) . if index="" quit "RTN","TMGPUTN0",770,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index=",index) "RTN","TMGPUTN0",771,0) . new s set s=$get(^TIU(8925.2,BuffNum,"TEXT",index,0)) "RTN","TMGPUTN0",772,0) . if s="" set index="" quit "RTN","TMGPUTN0",773,0) . if s[TIUHSIG set index="" quit "RTN","TMGPUTN0",774,0) . set s=$$Trim^TMGSTUTL(.s) "RTN","TMGPUTN0",775,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"s=",s) "RTN","TMGPUTN0",776,0) . set result=result+$length(s) "RTN","TMGPUTN0",777,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result (char count)=",result) "RTN","TMGPUTN0",778,0) . set index=$order(^TIU(8925.2,BuffNum,"TEXT",index)) "RTN","TMGPUTN0",779,0) "RTN","TMGPUTN0",780,0) BuffCDone "RTN","TMGPUTN0",781,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result (char count)=",result) "RTN","TMGPUTN0",782,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"BuffCharCount") "RTN","TMGPUTN0",783,0) quit result "RTN","TMGPUTN0",784,0) "RTN","TMGPUTN0",785,0) "RTN","TMGPUTN0",786,0) "RTN","TMGPUTN0",787,0) PrepUploadBuf() "RTN","TMGPUTN0",788,0) ;"Purpose: Ensure upload buffer is ready for processing "RTN","TMGPUTN0",789,0) ;"Background: Transcriptionist will upload a large document containing "RTN","TMGPUTN0",790,0) ;" multiple notes for different patients etc. This entire large "RTN","TMGPUTN0",791,0) ;" document is stored in the TIU UPLOAD BUFFER file (8925.2) "RTN","TMGPUTN0",792,0) ;" When this filer code is called, the TIU upload process has already "RTN","TMGPUTN0",793,0) ;" set up some variables. "RTN","TMGPUTN0",794,0) ;" DA = the IEN in 8925.2, i.e. ^TIU(8925.2,DA,"TEXT",0) that "RTN","TMGPUTN0",795,0) ;" the uploaded text was temporarily store in. "RTN","TMGPUTN0",796,0) ;" (I save DA as BuffNum) "RTN","TMGPUTN0",797,0) ;" TIUI = the line index of the beginning of the report to "RTN","TMGPUTN0",798,0) ;" be processed (i.e. the line that starts with [TEXT]) "RTN","TMGPUTN0",799,0) ;" (I save TIUI as BuffIdx) "RTN","TMGPUTN0",800,0) ;" TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params "RTN","TMGPUTN0",801,0) ;" TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. "RTN","TMGPUTN0",802,0) ;" "RTN","TMGPUTN0",803,0) ;" I found that transcriptionists were using word-processors that automatically "RTN","TMGPUTN0",804,0) ;" wrapped the text to a next line. Thus paragraphs were being uploaded as "RTN","TMGPUTN0",805,0) ;" one very long line. Rather than try to reeducate them to consistantly hit "RTN","TMGPUTN0",806,0) ;" enter at the end of every line, I chose to automatically wrap the text to "RTN","TMGPUTN0",807,0) ;" a set width. "RTN","TMGPUTN0",808,0) ;" "RTN","TMGPUTN0",809,0) ;" A global-scope var: cMaxNoteWidth is expected to be defined/ "RTN","TMGPUTN0",810,0) ;" "RTN","TMGPUTN0",811,0) ;" So, to prepair the upload buffer, I use these steps: "RTN","TMGPUTN0",812,0) ;" 1. Scan the part of the upload buffer pertaining to the "RTN","TMGPUTN0",813,0) ;" current note being processed "RTN","TMGPUTN0",814,0) ;" - This starts with line BuffIdx, and ends with... "RTN","TMGPUTN0",815,0) ;" - the line containing TIUHSIG (or end of buffer) "RTN","TMGPUTN0",816,0) ;" See if any line is longer than cMaxNoteWidth characters. "RTN","TMGPUTN0",817,0) ;" If so, mark for wrapping. "RTN","TMGPUTN0",818,0) ;" 2. If wrapping needed, extract note to a temporary array "RTN","TMGPUTN0",819,0) ;" 3. Perform reformatting/wrapping on temp array. "RTN","TMGPUTN0",820,0) ;" 4. Put temp array back into Upload buffer "RTN","TMGPUTN0",821,0) ;" "RTN","TMGPUTN0",822,0) ;"Input: None, but global-scope vars used (see above) "RTN","TMGPUTN0",823,0) ;"Output: Upload buffer may be changed "RTN","TMGPUTN0",824,0) ;"Result: 1=OKToCont or cAbort "RTN","TMGPUTN0",825,0) "RTN","TMGPUTN0",826,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PrepUploadBuf") "RTN","TMGPUTN0",827,0) "RTN","TMGPUTN0",828,0) new result set result=1 ;"cOKToCont "RTN","TMGPUTN0",829,0) "RTN","TMGPUTN0",830,0) if $$NeedsReformat(cMaxNoteWidth) do "RTN","TMGPUTN0",831,0) . new CurNote "RTN","TMGPUTN0",832,0) . new NextNoteI "RTN","TMGPUTN0",833,0) . new DoSpecialIndent set DoSpecialIndent=1 ;"I.e. use hanging indents.) "RTN","TMGPUTN0",834,0) . set NextNoteI=$$CutNote(.CurNote) "RTN","TMGPUTN0",835,0) . do WordWrapArray^TMGSTUTL(.CurNote,cMaxNoteWidth,DoSpecialIndent) "RTN","TMGPUTN0",836,0) . set result=$$PasteNote(.CurNote,NextNoteI) "RTN","TMGPUTN0",837,0) ;" SEEMS TO BE STRAY CHARS ELH --> 0c "RTN","TMGPUTN0",838,0) PULBFDone "RTN","TMGPUTN0",839,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PrepUploadBuf") "RTN","TMGPUTN0",840,0) quit result "RTN","TMGPUTN0",841,0) "RTN","TMGPUTN0",842,0) "RTN","TMGPUTN0",843,0) NeedsReformat(MaxWidth) "RTN","TMGPUTN0",844,0) ;"Purpose: To scan the single note being processed, to see if "RTN","TMGPUTN0",845,0) ;" it is too wide (i.e. any line of length > MaxWidth "RTN","TMGPUTN0",846,0) ;" I had to do this because transcriptionists were using "RTN","TMGPUTN0",847,0) ;" a wordprocessor that wrapped lines. Then when uploaded "RTN","TMGPUTN0",848,0) ;" each paragraph became one long line. "RTN","TMGPUTN0",849,0) ;" Also, will fix extended ASCII characters "RTN","TMGPUTN0",850,0) ;"Input: MaxWidth The max length of any line (i.e. 80 for 80 chars) "RTN","TMGPUTN0",851,0) ;" Also depends on global-scope vars "RTN","TMGPUTN0",852,0) ;"Result: 1= A line was found that is > MaxWidth "RTN","TMGPUTN0",853,0) ;" 0= no long lines found "RTN","TMGPUTN0",854,0) "RTN","TMGPUTN0",855,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"NeedsReformat") "RTN","TMGPUTN0",856,0) "RTN","TMGPUTN0",857,0) new index "RTN","TMGPUTN0",858,0) new result set result=0 "RTN","TMGPUTN0",859,0) if $get(TIUHSIG)="" goto NRFMDone "RTN","TMGPUTN0",860,0) if $get(MaxWidth)'>0 goto NRFMDone "RTN","TMGPUTN0",861,0) "RTN","TMGPUTN0",862,0) set index=$order(^TIU(8925.2,BuffNum,"TEXT",BuffIdx)) "RTN","TMGPUTN0",863,0) if index'="" for do quit:(index="") "RTN","TMGPUTN0",864,0) . new s "RTN","TMGPUTN0",865,0) . set s=$get(^TIU(8925.2,BuffNum,"TEXT",index,0)) "RTN","TMGPUTN0",866,0) . if s="" set index="" quit "RTN","TMGPUTN0",867,0) . ;"9/19/06 Added to remove extended ASCII characters "RTN","TMGPUTN0",868,0) . ;"set s=$translate(s,$c(146)_$c(246)_$c(150)_$c(147)_$c(148),"'--""""") "RTN","TMGPUTN0",869,0) . if s[TIUHSIG set index="" quit "RTN","TMGPUTN0",870,0) . if $length(s)>MaxWidth do quit "RTN","TMGPUTN0",871,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Line length found > ",MaxWidth) "RTN","TMGPUTN0",872,0) . . set result=1 "RTN","TMGPUTN0",873,0) . . set index="" "RTN","TMGPUTN0",874,0) . set index=$order(^TIU(8925.2,BuffNum,"TEXT",index)) "RTN","TMGPUTN0",875,0) else do "RTN","TMGPUTN0",876,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Upload unexpectedly empty!") "RTN","TMGPUTN0",877,0) "RTN","TMGPUTN0",878,0) NRFMDone "RTN","TMGPUTN0",879,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) "RTN","TMGPUTN0",880,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"NeedsReformat") "RTN","TMGPUTN0",881,0) quit result "RTN","TMGPUTN0",882,0) "RTN","TMGPUTN0",883,0) "RTN","TMGPUTN0",884,0) CutNote(Array) "RTN","TMGPUTN0",885,0) ;"Purpose: To extract the current note out of the entire upload buffer "RTN","TMGPUTN0",886,0) ;"Input: Array -- MUST BE PASSED BY REFERENCE. This is an OUT parameter "RTN","TMGPUTN0",887,0) ;" Array will be loaded with the note, with the first line being "RTN","TMGPUTN0",888,0) ;" put into Array(1) "RTN","TMGPUTN0",889,0) ;" Depends on global-scope vars BuffIdx, BuffNum, TIUHSIG, set up elsewhere. "RTN","TMGPUTN0",890,0) ;"Note: This function empties the lines in TIU UPLOAD BUFFER as it cuts out note. "RTN","TMGPUTN0",891,0) ;"Result: Returns: "RTN","TMGPUTN0",892,0) ;" #: index of line containing start of next note. "RTN","TMGPUTN0",893,0) ;" -1: Error "RTN","TMGPUTN0",894,0) ;" 0: Note is the last one in the upload buffer, so no next note found "RTN","TMGPUTN0",895,0) "RTN","TMGPUTN0",896,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CutNote") "RTN","TMGPUTN0",897,0) "RTN","TMGPUTN0",898,0) new index "RTN","TMGPUTN0",899,0) new LastI set LastI=0 "RTN","TMGPUTN0",900,0) new result set result=-1 "RTN","TMGPUTN0",901,0) kill Array "RTN","TMGPUTN0",902,0) if $get(TIUHSIG)="" goto ExNDone "RTN","TMGPUTN0",903,0) new ArrayI set ArrayI=0 "RTN","TMGPUTN0",904,0) new s "RTN","TMGPUTN0",905,0) new Done set Done=0 "RTN","TMGPUTN0",906,0) "RTN","TMGPUTN0",907,0) set index=$order(^TIU(8925.2,BuffNum,"TEXT",BuffIdx)) "RTN","TMGPUTN0",908,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ready for loop. index=",index) "RTN","TMGPUTN0",909,0) "RTN","TMGPUTN0",910,0) if index'="" for do quit:(index="")!(Done=1) "RTN","TMGPUTN0",911,0) . set s=$get(^TIU(8925.2,BuffNum,"TEXT",index,0)) "RTN","TMGPUTN0",912,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"s='",s,"'") "RTN","TMGPUTN0",913,0) . if s[TIUHSIG set Done=1 quit "RTN","TMGPUTN0",914,0) . set ArrayI=ArrayI+1 "RTN","TMGPUTN0",915,0) . set Array(ArrayI)=s "RTN","TMGPUTN0",916,0) . kill ^TIU(8925.2,BuffNum,"TEXT",index) "RTN","TMGPUTN0",917,0) . set LastI=index "RTN","TMGPUTN0",918,0) . set index=$order(^TIU(8925.2,BuffNum,"TEXT",index)) "RTN","TMGPUTN0",919,0) else do "RTN","TMGPUTN0",920,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Can't find text in buffer!") "RTN","TMGPUTN0",921,0) "RTN","TMGPUTN0",922,0) if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array") "RTN","TMGPUTN0",923,0) set result=+index "RTN","TMGPUTN0",924,0) if result=0 set result=LastI "RTN","TMGPUTN0",925,0) ExNDone "RTN","TMGPUTN0",926,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result='",result,"'") "RTN","TMGPUTN0",927,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CutNote") "RTN","TMGPUTN0",928,0) quit result "RTN","TMGPUTN0",929,0) "RTN","TMGPUTN0",930,0) "RTN","TMGPUTN0",931,0) "RTN","TMGPUTN0",932,0) PasteNote(Array,NextNoteI) "RTN","TMGPUTN0",933,0) ;"Purpose: To put Array back into the upload buffer, at the correct location, "RTN","TMGPUTN0",934,0) ;"Input: Array -- Best if PASSED BY REFERENCE. "RTN","TMGPUTN0",935,0) ;" Array is expected to be loaded with the note, with the first line Array(1) "RTN","TMGPUTN0",936,0) ;" NextNoteI: This is the index, in upload buffer, of the start of the next note. "RTN","TMGPUTN0",937,0) ;"Depends on global-scope vars BuffIdx, BuffNum, TIUHSIG, set up elsewhere. "RTN","TMGPUTN0",938,0) ;"Result: 1=OKToCont if all OK, or cAbort if error "RTN","TMGPUTN0",939,0) "RTN","TMGPUTN0",940,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PasteNote") "RTN","TMGPUTN0",941,0) "RTN","TMGPUTN0",942,0) new EntireBuf "RTN","TMGPUTN0",943,0) new IndexInc set IndexInc=0.01 ;"WP^DIE does not require integer indexes. "RTN","TMGPUTN0",944,0) new ArrayI,PasteI "RTN","TMGPUTN0",945,0) new s "RTN","TMGPUTN0",946,0) new Done set Done=0 "RTN","TMGPUTN0",947,0) new result set result=cAbort "RTN","TMGPUTN0",948,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NextNoteI='",$get(NextNoteI),"'") "RTN","TMGPUTN0",949,0) "RTN","TMGPUTN0",950,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ready for merge.") "RTN","TMGPUTN0",951,0) "RTN","TMGPUTN0",952,0) merge EntireBuf=^TIU(8925.2,BuffNum,"TEXT") "RTN","TMGPUTN0",953,0) kill EntireBuf(0) ;"remove ^^^^^^ "RTN","TMGPUTN0",954,0) "RTN","TMGPUTN0",955,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("EntireBuf") "RTN","TMGPUTN0",956,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array") "RTN","TMGPUTN0",957,0) "RTN","TMGPUTN0",958,0) set ArrayI=$order(Array("")) "RTN","TMGPUTN0",959,0) set PasteI=BuffIdx+1 "RTN","TMGPUTN0",960,0) for do quit:((Done=1)!(ArrayI="")) "RTN","TMGPUTN0",961,0) . if $data(Array(ArrayI))#10=0 set Done=1 quit "RTN","TMGPUTN0",962,0) . set s=Array(ArrayI) "RTN","TMGPUTN0",963,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"s=",s) "RTN","TMGPUTN0",964,0) . set EntireBuff(PasteI,0)=s "RTN","TMGPUTN0",965,0) . set PasteI=PasteI+IndexInc "RTN","TMGPUTN0",966,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"PasteI=",PasteI) "RTN","TMGPUTN0",967,0) . if PasteI>NextNoteI do quit "RTN","TMGPUTN0",968,0) . . do ShowError^TMGDEBUG(PriorErrorFound,"Insufficient room to put note back into upload buffer.") "RTN","TMGPUTN0",969,0) . . set Done=1 "RTN","TMGPUTN0",970,0) . set ArrayI=$order(Array(ArrayI)) "RTN","TMGPUTN0",971,0) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ArrayI=",ArrayI) "RTN","TMGPUTN0",972,0) "RTN","TMGPUTN0",973,0) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("EntireBuff") "RTN","TMGPUTN0",974,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ready to call WriteWP") "RTN","TMGPUTN0",975,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"BuffNum=",$get(BuffNum)) "RTN","TMGPUTN0",976,0) "RTN","TMGPUTN0",977,0) Set result=$$WriteWP^TMGDBAPI(8925.2,BuffNum,1,.EntireBuff) "RTN","TMGPUTN0",978,0) "RTN","TMGPUTN0",979,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PasteNote") "RTN","TMGPUTN0",980,0) quit result "RTN","TMGPUTN0",981,0) "RTN","TMGPUTN0",982,0) "RTN","TMGPUTN0",983,0) CompToBuff(ExistingIEN,UplTIEN,UplDate) "RTN","TMGPUTN0",984,0) ;"PURPOSE: To compare the document being uploaded (i.e. in the file 8925.2, TIU upload buffer) "RTN","TMGPUTN0",985,0) ;" to documents already existing in database "RTN","TMGPUTN0",986,0) ;"Input: ExistingIEN -- the document IEN of a pre-existing document in the database. "RTN","TMGPUTN0",987,0) ;" i.e. ^TIU(8925,ExistingIEN,*) "RTN","TMGPUTN0",988,0) ;" UplTIEN=The type number of document being uploaded "RTN","TMGPUTN0",989,0) ;" UplDate -- the date of the document being uploaded. "RTN","TMGPUTN0",990,0) ;" NOTE: See also global-scope variables below that are REQUIRED "RTN","TMGPUTN0",991,0) ;" "RTN","TMGPUTN0",992,0) ;"Output: returns 0 if TEXT or Date different "RTN","TMGPUTN0",993,0) ;" 1 if TEXT only is the same (Title is different) "RTN","TMGPUTN0",994,0) ;" 2 if TEXT & Title are same "RTN","TMGPUTN0",995,0) ;" "RTN","TMGPUTN0",996,0) ;"------------------------------------------------------------------------------------ "RTN","TMGPUTN0",997,0) ;"Programming Note: By tracing through the upload code I know that "RTN","TMGPUTN0",998,0) ;" the following variables are set: "RTN","TMGPUTN0",999,0) ;" (I saved DA as BuffNum, and TIUI as BuffIdx) "RTN","TMGPUTN0",1000,0) ;"TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params "RTN","TMGPUTN0",1001,0) ;"TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. "RTN","TMGPUTN0",1002,0) ;"BuffIdx = the line index of the beginning of the report to be processed (i.e. the line "RTN","TMGPUTN0",1003,0) ;" that starts with [TEXT] "RTN","TMGPUTN0",1004,0) ;"BuffNum = the index in 8925.2, i.e. ^TIU(8925.2,BuffNum,"TEXT",0) "RTN","TMGPUTN0",1005,0) ;" In other words, here BuffNum = the serial index number of the document to be uploaded "RTN","TMGPUTN0",1006,0) ;" i.e. 1 for the first, 2 for the second etc. "RTN","TMGPUTN0",1007,0) ;" Note 8925.2 is file: TIU UPLOAD BUFFER "RTN","TMGPUTN0",1008,0) ;"Note "RTN","TMGPUTN0",1009,0) ;" To detect the beginning of the next document, use "RTN","TMGPUTN0",1010,0) ;" if MyLine[TIUHSIG then abort "RTN","TMGPUTN0",1011,0) "RTN","TMGPUTN0",1012,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompToBuff") "RTN","TMGPUTN0",1013,0) "RTN","TMGPUTN0",1014,0) new MaxUplLine "RTN","TMGPUTN0",1015,0) new DocLine,UplLine "RTN","TMGPUTN0",1016,0) new DocData,UplData "RTN","TMGPUTN0",1017,0) new result set result=0 "RTN","TMGPUTN0",1018,0) new MaxDocLine,CompLine "RTN","TMGPUTN0",1019,0) new DocType,DocName "RTN","TMGPUTN0",1020,0) new Break set Break=0 "RTN","TMGPUTN0",1021,0) new DocDate "RTN","TMGPUTN0",1022,0) "RTN","TMGPUTN0",1023,0) ;"First, see if dates are the same. If not, bail out. "RTN","TMGPUTN0",1024,0) set DocDate=$piece(^TIU(8925,ExistingIEN,0),"^",7) "RTN","TMGPUTN0",1025,0) if DocDate'=UplDate goto CompExit ;"Quit with result=0 "RTN","TMGPUTN0",1026,0) "RTN","TMGPUTN0",1027,0) set MaxUplLine=$piece($get(^TIU(8925.2,BuffNum,"TEXT",0)),"^",3) "RTN","TMGPUTN0",1028,0) if MaxUplLine="" goto CompExit "RTN","TMGPUTN0",1029,0) set MaxDocLine=$piece($get(^TIU(8925,ExistingIEN,"TEXT",0)),"^",3) "RTN","TMGPUTN0",1030,0) if MaxDocLine="" goto CompExit "RTN","TMGPUTN0",1031,0) "RTN","TMGPUTN0",1032,0) set UplLine=BuffIdx "RTN","TMGPUTN0",1033,0) set DocLine=0 "RTN","TMGPUTN0",1034,0) "RTN","TMGPUTN0",1035,0) ;"Compare the two documents line by line. "RTN","TMGPUTN0",1036,0) for i=1:1:(MaxUplLine-UplLine) do if Break goto CompExit "RTN","TMGPUTN0",1037,0) . set UplData=$get(^TIU(8925.2,BuffNum,"TEXT",UplLine+i,0)) "RTN","TMGPUTN0",1038,0) . set DocData=$get(^TIU(8925,ExistingIEN,"TEXT",DocLine+i,0),"x") "RTN","TMGPUTN0",1039,0) . if UplData[TIUHSIG set i=MaxUplLine quit "RTN","TMGPUTN0",1040,0) . if UplData'=DocData set Break=1 quit "RTN","TMGPUTN0",1041,0) . quit "RTN","TMGPUTN0",1042,0) "RTN","TMGPUTN0",1043,0) ;"If we have gotten this far, then the text is an identical match. "RTN","TMGPUTN0",1044,0) set result=1 "RTN","TMGPUTN0",1045,0) "RTN","TMGPUTN0",1046,0) ;"Now check to see if the dictation type is the same. "RTN","TMGPUTN0",1047,0) set DocType=$piece($get(^TIU(8925,ExistingIEN,0)),"^",1) "RTN","TMGPUTN0",1048,0) if DocType=UplTIEN set result=2 "RTN","TMGPUTN0",1049,0) "RTN","TMGPUTN0",1050,0) CompExit "RTN","TMGPUTN0",1051,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompToBuff") "RTN","TMGPUTN0",1052,0) quit result "RTN","TMGPUTN0",1053,0) "RTN","TMGPUTN0",1054,0) "RTN","TMGPUTN0",1055,0) ;------------------------------------------------------------------------ "RTN","TMGPUTN0",1056,0) CreateRec(Document) ; "RTN","TMGPUTN0",1057,0) ;"Purpose: Create document record - Returns DA "RTN","TMGPUTN0",1058,0) ;"Input: Document -- an array with document info. See GetRecord for documentation "RTN","TMGPUTN0",1059,0) ;"Ouput: DocIEN (internal entry number) of entry created, or -1 if failure "RTN","TMGPUTN0",1060,0) ;" Errors (if any) returned in Document("ERROR") "RTN","TMGPUTN0",1061,0) ;" "RTN","TMGPUTN0",1062,0) ;"Note: This was originally taken from TIUEDI3 "RTN","TMGPUTN0",1063,0) "RTN","TMGPUTN0",1064,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CreateRec") "RTN","TMGPUTN0",1065,0) "RTN","TMGPUTN0",1066,0) ;"new cOKToCont set cOKToCont=1 "RTN","TMGPUTN0",1067,0) new cAbort set cAbort=0 "RTN","TMGPUTN0",1068,0) new result set result=1; "cOKToCont "RTN","TMGPUTN0",1069,0) "RTN","TMGPUTN0",1070,0) new DIC,DLAYGO,X,Y,DIE,DR "RTN","TMGPUTN0",1071,0) "RTN","TMGPUTN0",1072,0) new DocIEN set DocIEN=-1 "RTN","TMGPUTN0",1073,0) new TMGFDA,RecNum,TMGMsg,Flags "RTN","TMGPUTN0",1074,0) set TMGFDA(8925,"+1,",.01)="`"_Document(cDocTIEN) "RTN","TMGPUTN0",1075,0) set Flags="E" "RTN","TMGPUTN0",1076,0) "RTN","TMGPUTN0",1077,0) ;"====================================================== "RTN","TMGPUTN0",1078,0) ;"Call UPDATE^DIE -- add new entries in files or subfiles. "RTN","TMGPUTN0",1079,0) ;"====================================================== "RTN","TMGPUTN0",1080,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",1081,0) . do DebugEntry^TMGDEBUG(.DBIndent,"TMGPOUTN0::UPDATE^DIE") "RTN","TMGPUTN0",1082,0) . if $data(TMGFDA)'=0 do ArrayDump^TMGDEBUG("TMGFDA") "RTN","TMGPUTN0",1083,0) . do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",Flags) "RTN","TMGPUTN0",1084,0) do "RTN","TMGPUTN0",1085,0) . new $etrap set $etrap="do ErrTrp^TMGDBAPI" "RTN","TMGPUTN0",1086,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, UPDATE^DIE adds new entries in files or subfiles.") "RTN","TMGPUTN0",1087,0) . set ^TMP("TMG",$J,"ErrorTrap")=result "RTN","TMGPUTN0",1088,0) . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" "RTN","TMGPUTN0",1089,0) . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMsg") "RTN","TMGPUTN0",1090,0) . set result=^TMP("TMG",$J,"ErrorTrap") "RTN","TMGPUTN0",1091,0) . kill ^TMP("TMG",$J,"ErrorTrap") "RTN","TMGPUTN0",1092,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGPOUTN0::UPDATE^DIE") "RTN","TMGPUTN0",1093,0) ;"====================================================== "RTN","TMGPUTN0",1094,0) ;"====================================================== "RTN","TMGPUTN0",1095,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",1096,0) . do ArrayDump^TMGDEBUG("RecNum") "RTN","TMGPUTN0",1097,0) . do ArrayDump^TMGDEBUG("TMGMsg") "RTN","TMGPUTN0",1098,0) "RTN","TMGPUTN0",1099,0) if result'=1 goto CRDone ;"1=cOKToCont "RTN","TMGPUTN0",1100,0) if $data(TMGMsg("DIERR")) do goto CRDone "RTN","TMGPUTN0",1101,0) . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGPUTN0",1102,0) . set DocIEN=-1 "RTN","TMGPUTN0",1103,0) . merge Document("ERROR","DIERR")=TMGMsg "RTN","TMGPUTN0",1104,0) do "RTN","TMGPUTN0",1105,0) . new index set index=$order(RecNum("")) "RTN","TMGPUTN0",1106,0) . if index'="" set DocIEN=+$get(RecNum(index)) "RTN","TMGPUTN0",1107,0) if DocIEN=0 set DocIEN=-1 "RTN","TMGPUTN0",1108,0) "RTN","TMGPUTN0",1109,0) CRDone "RTN","TMGPUTN0",1110,0) ;"Now check for failure. DocIEN will equal record number, or -1 if failure "RTN","TMGPUTN0",1111,0) if DocIEN'>0 do goto CRDone "RTN","TMGPUTN0",1112,0) . new n set n=+$get(Document("ERROR","NUM"))+1 "RTN","TMGPUTN0",1113,0) . set Document("ERROR",n)=$piece(Document(cDocType),"^",3)_" record could not be created." "RTN","TMGPUTN0",1114,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,Document("ERROR",n)) "RTN","TMGPUTN0",1115,0) set Document("DOC IEN")=DocIEN "RTN","TMGPUTN0",1116,0) "RTN","TMGPUTN0",1117,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",1118,0) . do DebugMsg^TMGDEBUG(.DBIndent,"Leaving Create record. Our record number is ",DocIEN) "RTN","TMGPUTN0",1119,0) . do DebugExit^TMGDEBUG(.DBIndent,"CreateRec") "RTN","TMGPUTN0",1120,0) quit DocIEN "RTN","TMGPUTN0",1121,0) "RTN","TMGPUTN0",1122,0) "RTN","TMGPUTN0",1123,0) "RTN","TMGPUTN0",1124,0) ;------------------------------------------------------------------------ "RTN","TMGPUTN0",1125,0) StuffRec(Document,PARENT) "RTN","TMGPUTN0",1126,0) ;"Purpose: Stuff fixed field data "RTN","TMGPUTN0",1127,0) ;"INPUT: "RTN","TMGPUTN0",1128,0) ;" Document = An array containing information to put into document. "RTN","TMGPUTN0",1129,0) ;" The array should contain the following: "RTN","TMGPUTN0",1130,0) ;" Document("DOC IEN") -- the document IEN "RTN","TMGPUTN0",1131,0) ;" Document("PROVIDER IEN") -- the IEN of the provider "RTN","TMGPUTN0",1132,0) ;" Document("DFN") -- the patient IEN "RTN","TMGPUTN0",1133,0) ;" Document(cVisitIEN) -- a link to a visit entry "RTN","TMGPUTN0",1134,0) ;" Document(cStartDate) -- episode begin date/time "RTN","TMGPUTN0",1135,0) ;" Document(cEndDate) -- episode end date/time "RTN","TMGPUTN0",1136,0) ;" Document(cHspLocIEN) -- hospital location (Document(cVstLocIEN) used NULL) "RTN","TMGPUTN0",1137,0) ;" Document(cVstLocIEN) -- visit location. "RTN","TMGPUTN0",1138,0) ;" Document(cService) -- service (i.e. FAMILY PRACTICE) "RTN","TMGPUTN0",1139,0) ;" Document(cVisitStr) "RTN","TMGPUTN0",1140,0) ;" Document("TRANSCRIPTIONIST") -- the name of the transcriptionist "RTN","TMGPUTN0",1141,0) ;" Document("CHARACTER COUNT - TRANSCRIPTIONIST'S") -- the char count creditable to transcriptionist "RTN","TMGPUTN0",1142,0) ;" Document("LINE COUNT") -- Total line count "RTN","TMGPUTN0",1143,0) ;" PARENT: If we are working with an addendum to a document, then "RTN","TMGPUTN0",1144,0) ;" parent is the internal entry number of the original parent document "RTN","TMGPUTN0",1145,0) ;" Note:DocID can be null if not needed. "RTN","TMGPUTN0",1146,0) ;" Note: I don't ever pass a parent, currently "RTN","TMGPUTN0",1147,0) ;" "RTN","TMGPUTN0",1148,0) ;"NOTE: The following global-scope variables are also referenced "RTN","TMGPUTN0",1149,0) ;" TIUDDT "RTN","TMGPUTN0",1150,0) ;"Results: Passes back document IEN, or -1 if error. "RTN","TMGPUTN0",1151,0) ;" NOTE: if result is -1 then errors are passed back in "RTN","TMGPUTN0",1152,0) ;" Document("ERROR") node "RTN","TMGPUTN0",1153,0) ;" Document("ERROR",n)="ERROR.. Stuffing new document." "RTN","TMGPUTN0",1154,0) ;" Document("ERROR","NUM")=n "RTN","TMGPUTN0",1155,0) ;" Document("ERROR","FM INFO")=merge with DIERR array "RTN","TMGPUTN0",1156,0) "RTN","TMGPUTN0",1157,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"StuffRec") "RTN","TMGPUTN0",1158,0) "RTN","TMGPUTN0",1159,0) new TMGFDA,TMGMsg "RTN","TMGPUTN0",1160,0) new RefDate "RTN","TMGPUTN0",1161,0) new result set result=1 ;"cOKToCont "RTN","TMGPUTN0",1162,0) new DocIEN set DocIEN=$get(Document("DOC IEN"),-1) "RTN","TMGPUTN0",1163,0) if DocIEN=-1 goto SfRecDone "RTN","TMGPUTN0",1164,0) new ParentDocType "RTN","TMGPUTN0",1165,0) "RTN","TMGPUTN0",1166,0) ;"Field (f) constants "RTN","TMGPUTN0",1167,0) new fPatient set fPatient=.02 ;"field .02 = PATIENT "RTN","TMGPUTN0",1168,0) new fVisit set fVisit=.03 ;"field .03 = VISIT "RTN","TMGPUTN0",1169,0) new fParentDoc set fParentDoc=.04 ;"field .04 = PARENT DOCUMENT TYPE "RTN","TMGPUTN0",1170,0) new fStatus set fStatus=.05 ;"field .05 = STATUS "RTN","TMGPUTN0",1171,0) new fParent set fParent=.06 ;"field .06 = PARENT "RTN","TMGPUTN0",1172,0) new fStartDate set fStartDate=.07 ;"EPISODE BEGIN DATE/TIME (field .07) "RTN","TMGPUTN0",1173,0) new fEndDate set fEndDate=.08 ;"EPISODE END DATE/TIME (field .08) "RTN","TMGPUTN0",1174,0) new fEntryDate set fEntryDate=1201 ;"field 1201 = ENTRY DATE/TIME "RTN","TMGPUTN0",1175,0) new fAuthor set fAuthor=1202 ;"field 1202 = PERSON/DICTATOR "RTN","TMGPUTN0",1176,0) new fExpSigner set fExpSigner=1204 ;"field 1204 = expected Signer "RTN","TMGPUTN0",1177,0) new fHospLoc set fHospLoc=1205 ;"field 1205 = HOSPITAL LOCATION "RTN","TMGPUTN0",1178,0) new fExpCosign set fExpCosign=1208 ;"field 1208 = expected cosigner "RTN","TMGPUTN0",1179,0) new fAttending set fAttending=1209 ;"field 1209 = ATTENDING "RTN","TMGPUTN0",1180,0) new fVisitLoc set fVisitLoc=1211 ;"field 1211 = VISIT LOCATION "RTN","TMGPUTN0",1181,0) new fRefDate set fRefDate=1301 ;"field 1301 = REFERENCE DATE "RTN","TMGPUTN0",1182,0) new fEnteredBy set fEnteredBy=1302 ;"field 1302 = ENTERED BY (a pointer to file 200) "RTN","TMGPUTN0",1183,0) new fCapMethod set fCapMethod=1303 ;"field 1303 = CAPTURE METHOD; U-->'upload' "RTN","TMGPUTN0",1184,0) new fService set fService=1404 ;"field 1404 = SERVICE "RTN","TMGPUTN0",1185,0) new fSignedBy set fSignedBy=1502 ;"field 1502 = signed by "RTN","TMGPUTN0",1186,0) new fNeedCosign set fNeedCosign=1506 ;"field 1506 = cosigniture expected. "RTN","TMGPUTN0",1187,0) new fCharTrans set fCharTrans=22711 ;"field 22711 = CHAR COUNT -- TRANSCRIPTIONIST "RTN","TMGPUTN0",1188,0) new fLineCount set fLineCout=.1 ;"field .1 = LINE COUNT "RTN","TMGPUTN0",1189,0) "RTN","TMGPUTN0",1190,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",1191,0) . do DebugMsg^TMGDEBUG(.DBIndent,"Here the the Document array received") "RTN","TMGPUTN0",1192,0) . do ArrayDump^TMGDEBUG("Document") "RTN","TMGPUTN0",1193,0) "RTN","TMGPUTN0",1194,0) ;"8925=TIU DOCUMENT, the file we will edit "RTN","TMGPUTN0",1195,0) do Set8925Value(Document("DFN"),fPatient,1) "RTN","TMGPUTN0",1196,0) do Set8925Value(Document(cVisitIEN),fVisit,1) "RTN","TMGPUTN0",1197,0) do Set8925Value(Document("PROVIDER IEN"),fAuthor,1) "RTN","TMGPUTN0",1198,0) do Set8925Value(Document("PROVIDER IEN"),fExpSigner,1) "RTN","TMGPUTN0",1199,0) do Set8925Value(Document("PROVIDER IEN"),fAttending,1) "RTN","TMGPUTN0",1200,0) do Set8925Value(Document(cHspLocIEN),fHospLoc,1) "RTN","TMGPUTN0",1201,0) do Set8925Value(Document(cVstLocIEN),fVisitLoc,1) "RTN","TMGPUTN0",1202,0) do Set8925Value(Document("TRANSCRIPTIONIST"),fEnteredBy,0) ;"VA transcriptionist field "RTN","TMGPUTN0",1203,0) do Set8925Value(Document("CHARACTER COUNT - TRANSCRIPTIONIST'S"),fCharTrans,0) "RTN","TMGPUTN0",1204,0) "RTN","TMGPUTN0",1205,0) if $data(Document("LINE COUNT")) do "RTN","TMGPUTN0",1206,0) . do Set8925Value(Document("LINE COUNT"),fLineCount,0) "RTN","TMGPUTN0",1207,0) "RTN","TMGPUTN0",1208,0) set ParentDocType=$$DOCCLASS^TIULC1(+$piece(DocIEN,"^",2)) "RTN","TMGPUTN0",1209,0) if +ParentDocType>0 do Set8925Value(ParentDocType,fParentDoc,1) "RTN","TMGPUTN0",1210,0) "RTN","TMGPUTN0",1211,0) if $get(Document("AUTO SIGN"))=1 do "RTN","TMGPUTN0",1212,0) . do Set8925Value("COMPLETED",fStatus,0) "RTN","TMGPUTN0",1213,0) . do Set8925Value(Document("PROVIDER IEN"),fSignedBy,1) "RTN","TMGPUTN0",1214,0) else do "RTN","TMGPUTN0",1215,0) . do Set8925Value("UNSIGNED",fStatus,0) "RTN","TMGPUTN0",1216,0) "RTN","TMGPUTN0",1217,0) if +$get(PARENT)'>0 do "RTN","TMGPUTN0",1218,0) . do Set8925Value(Document("DFN"),fPatient,1) "RTN","TMGPUTN0",1219,0) . do Set8925Value(Document(cVisitIEN),fVisit,1) "RTN","TMGPUTN0",1220,0) . do Set8925Value(Document(cStartDate),fStartDate,0) "RTN","TMGPUTN0",1221,0) . do Set8925Value(Document(cEndDate),fEndDate,0) "RTN","TMGPUTN0",1222,0) . do Set8925Value(Document(cService),fService,0) "RTN","TMGPUTN0",1223,0) if +$get(PARENT)>0 do "RTN","TMGPUTN0",1224,0) . new NodeZero set NodeZero=$get(^TIU(8925,+PARENT,0)) "RTN","TMGPUTN0",1225,0) . new Node12 set Node12=$get(^TIU(8925,+PARENT,12)) "RTN","TMGPUTN0",1226,0) . new Node14 set Node14=$get(^TIU(8925,+PARENT,14)) "RTN","TMGPUTN0",1227,0) . ;" "RTN","TMGPUTN0",1228,0) . do Set8925Value(PARENT,fParent,1) "RTN","TMGPUTN0",1229,0) . do Set8925Value($piece(NodeZero,"^",pPatient),fPatient,1) "RTN","TMGPUTN0",1230,0) . do Set8925Value($piece(NodeZero,"^",pVisit),fVisit,1) "RTN","TMGPUTN0",1231,0) . do Set8925Value($piece(NodeZero,"^",pStrtDate),fStartDate,0) "RTN","TMGPUTN0",1232,0) . do Set8925Value($piece(NodeZero,"^",pEndDate),fEndDate,0) "RTN","TMGPUTN0",1233,0) . do Set8925Value($piece(Node12,"^",pHospLoc),fHospLoc,1) "RTN","TMGPUTN0",1234,0) . do Set8925Value($piece(Node14,"^",pService),fService,0) "RTN","TMGPUTN0",1235,0) "RTN","TMGPUTN0",1236,0) do Set8925Value($$NOW^TIULC,fEntryDate,0) "RTN","TMGPUTN0",1237,0) do Set8925Value(Document(cHspLocIEN),fHospLoc,1) "RTN","TMGPUTN0",1238,0) do Set8925Value(Document(cVstLocIEN),fVisitLoc,1) "RTN","TMGPUTN0",1239,0) do Set8925Value(Document(cStartDate),fRefDate,0) "RTN","TMGPUTN0",1240,0) do Set8925Value("U",fCapMethod,0) ;" U-->'upload' "RTN","TMGPUTN0",1241,0) ;"do Set8925Value(3,fStatus,0) "RTN","TMGPUTN0",1242,0) "RTN","TMGPUTN0",1243,0) new ErrArray "RTN","TMGPUTN0",1244,0) set result=$$dbWrite^TMGDBAPI(.TMGFDA,1,,,.ErrArray) "RTN","TMGPUTN0",1245,0) "RTN","TMGPUTN0",1246,0) ;" -- [Mark record for deferred crediting of stop code (fld #.11)]: -- "RTN","TMGPUTN0",1247,0) if +$get(Document("STOP")) do "RTN","TMGPUTN0",1248,0) . do DEFER^TIUVSIT(DocIEN,+$get(Document("STOP"))) "RTN","TMGPUTN0",1249,0) "RTN","TMGPUTN0",1250,0) SfRecDone "RTN","TMGPUTN0",1251,0) if result'=1 do "RTN","TMGPUTN0",1252,0) . set DocIEN=-1 ;"1=cOKToCont "RTN","TMGPUTN0",1253,0) . merge Document("ERROR","FM INFO")=ErrArray "RTN","TMGPUTN0",1254,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"On exiting, result=",result," DocIEN=",DocIEN) "RTN","TMGPUTN0",1255,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"StuffRec") "RTN","TMGPUTN0",1256,0) quit DocIEN "RTN","TMGPUTN0",1257,0) "RTN","TMGPUTN0",1258,0) "RTN","TMGPUTN0",1259,0) Set8925Value(Value,Field,IsIEN) "RTN","TMGPUTN0",1260,0) ;"Purpose: To provide a clean means of loading values into fields, into TMGFDA(8925,DOCIEN) "RTN","TMGPUTN0",1261,0) ;"Input: Value -- the value to load "RTN","TMGPUTN0",1262,0) ;" Field -- the field "RTN","TMGPUTN0",1263,0) ;" IsIEN = 1 if value is an IEN "RTN","TMGPUTN0",1264,0) ;"Note: DEPENDS ON GLOBAL-SCOPE VARIABLES: "RTN","TMGPUTN0",1265,0) ;" TMGFDA,DocIEN,Document "RTN","TMGPUTN0",1266,0) "RTN","TMGPUTN0",1267,0) new tempDB set tempDB=$get(TMGDEBUG) "RTN","TMGPUTN0",1268,0) set TMGDEBUG=0 ;"This is a temporary shutting OFF of debug system (original value restored below) "RTN","TMGPUTN0",1269,0) "RTN","TMGPUTN0",1270,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"Set8925Value") "RTN","TMGPUTN0",1271,0) "RTN","TMGPUTN0",1272,0) if ($get(Value)'="")&($data(Field)>0) do "RTN","TMGPUTN0",1273,0) . if $get(IsIEN)>0 set Value="`"_+Value "RTN","TMGPUTN0",1274,0) . if Value'="`0" do "RTN","TMGPUTN0",1275,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Setting field ",Field," to ",Value) "RTN","TMGPUTN0",1276,0) . . set TMGFDA(8925,DocIEN_",",Field)=Value "RTN","TMGPUTN0",1277,0) . else do "RTN","TMGPUTN0",1278,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Field ",Field," was `0, so skipping.") "RTN","TMGPUTN0",1279,0) else do "RTN","TMGPUTN0",1280,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Skipping: Value='",$get(Value),"' Field='",$get(Field),"'") "RTN","TMGPUTN0",1281,0) "RTN","TMGPUTN0",1282,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"Set8925Value") "RTN","TMGPUTN0",1283,0) "RTN","TMGPUTN0",1284,0) set TMGDEBUG=tempDB "RTN","TMGPUTN0",1285,0) quit "RTN","TMGPUTN0",1286,0) "RTN","TMGPUTN0",1287,0) "RTN","TMGPUTN0",1288,0) "RTN","TMGPUTN0",1289,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGPUTN0",1290,0) ;"==============================================================================================- "RTN","TMGPUTN0",1291,0) ;" F O L L O W - U P C O D E "RTN","TMGPUTN0",1292,0) ;"==============================================================================================- "RTN","TMGPUTN0",1293,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGPUTN0",1294,0) "RTN","TMGPUTN0",1295,0) FOLLOWUP(DocIEN) ;" Post-filing code for PROGRESS NOTES "RTN","TMGPUTN0",1296,0) ;"PURPOSE: "RTN","TMGPUTN0",1297,0) ;" This function is called by the TIU upload document facilities. "RTN","TMGPUTN0",1298,0) ;" it is called after the text has been put into the document "RTN","TMGPUTN0",1299,0) ;" "RTN","TMGPUTN0",1300,0) ;"INPUT: "RTN","TMGPUTN0",1301,0) ;" DocIEN -- is passed a value held in TIUREC("#"), i.e. "RTN","TMGPUTN0",1302,0) ;" do FOLLOWUP^TIUPUTN1(TIUREC("#")). "RTN","TMGPUTN0",1303,0) "RTN","TMGPUTN0",1304,0) write ! "RTN","TMGPUTN0",1305,0) write "+-------------------------------------+",! "RTN","TMGPUTN0",1306,0) write "| Starting Follow-up code... |",! "RTN","TMGPUTN0",1307,0) write "+-------------------------------------+",! "RTN","TMGPUTN0",1308,0) "RTN","TMGPUTN0",1309,0) new TMGDEBUG "RTN","TMGPUTN0",1310,0) set TMGDEBUG=+$piece($get(^TMG(22711,1,0)),"^",2) ;"2=to Scrn; 3=to file "RTN","TMGPUTN0",1311,0) ;"if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 "RTN","TMGPUTN0",1312,0) "RTN","TMGPUTN0",1313,0) ;"9-1-05 -- turn off debug info "RTN","TMGPUTN0",1314,0) set TMGDEBUG=0 ;"2=to Scrn; 3=to file "RTN","TMGPUTN0",1315,0) "RTN","TMGPUTN0",1316,0) if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 "RTN","TMGPUTN0",1317,0) if $data(cAbort)#10=0 new cAbort set cAbort=0 "RTN","TMGPUTN0",1318,0) "RTN","TMGPUTN0",1319,0) new DBIndent,PriorErrorFound "RTN","TMGPUTN0",1320,0) new result set result=1 ;" 1=cOKToCont "RTN","TMGPUTN0",1321,0) "RTN","TMGPUTN0",1322,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FOLLOWUP^TMGPUTN0 (as close to start as possible)") "RTN","TMGPUTN0",1323,0) "RTN","TMGPUTN0",1324,0) new Document merge Document=TMGDOC "RTN","TMGPUTN0",1325,0) if $get(TMGDEBUG)>0 do "RTN","TMGPUTN0",1326,0) . do DebugMsg^TMGDEBUG(.DBIndent,"Here the the Document array received") "RTN","TMGPUTN0",1327,0) . do ArrayDump^TMGDEBUG("Document") "RTN","TMGPUTN0",1328,0) . do DebugMsg^TMGDEBUG(.DBIndent,"The value of DocIEN (i.e. document#) that is passed is: ",DocIEN) "RTN","TMGPUTN0",1329,0) "RTN","TMGPUTN0",1330,0) new cStartDate set cStartDate="EDT" "RTN","TMGPUTN0",1331,0) new cEndDate set cEndDate="LDT" "RTN","TMGPUTN0",1332,0) new cService set cService="SVC" "RTN","TMGPUTN0",1333,0) new cDocType set cDocType="TYPE" "RTN","TMGPUTN0",1334,0) new cDocTIEN set cDocTIEN="TYPE IEN" "RTN","TMGPUTN0",1335,0) ;"new cDocIEN set cDocIEN="DOC IEN" "RTN","TMGPUTN0",1336,0) ;"new cPatIEN set cPatIEN="DFN" ;"DFN = Patient IEN "RTN","TMGPUTN0",1337,0) new cHspLocIEN set cHspLocIEN="LOC" "RTN","TMGPUTN0",1338,0) new cVstLocIEN set cVstLocIEN="VLOC" "RTN","TMGPUTN0",1339,0) new cVisitStr set cVisitStr="VSTR" "RTN","TMGPUTN0",1340,0) new cVisitIEN set cVisitIEN="VISIT" "RTN","TMGPUTN0",1341,0) new cStopCode set cStopCode="STOP" "RTN","TMGPUTN0",1342,0) "RTN","TMGPUTN0",1343,0) ;" 'p constants "RTN","TMGPUTN0",1344,0) new pPatient set pPatient=2 ;"Node 0,piece 2 = PATIENT (field .02) "RTN","TMGPUTN0",1345,0) new pVisit set pVisit=3 ;"Node 0,piece 3 = VISIT (field .03) "RTN","TMGPUTN0",1346,0) new pStrtDate set pStrtDate=7 ;"Node 0,piece 7 = EPISODE BEGIN DATE/TIME (field .07) "RTN","TMGPUTN0",1347,0) new pEndDate set pEndDate=8 ;"Node 0,piece 8 = EPISODE END DATE/TIME (field .08) "RTN","TMGPUTN0",1348,0) "RTN","TMGPUTN0",1349,0) new pAuthor set pAuthor=2 ;"Node 12,piece 2 = AUTHOR/DICTATOR (field 1202) "RTN","TMGPUTN0",1350,0) new pExpSigner set pExpSigner=4 ;"Node 12,piece 4 = EXPECTED SIGNER (field 1204) "RTN","TMGPUTN0",1351,0) new pHospLoc set pHospLoc=5 ;"Node 12,piece 5 = field 1205 = HOSPITAL LOCATION "RTN","TMGPUTN0",1352,0) new pAttending set pAttending=9 ;"Node 12,piece 9 = ATTENDING PHYSICIAN (field 1209) "RTN","TMGPUTN0",1353,0) new pExpCosign set pExpCosign=8 ;"Node 12,piece 8 = EXPECTED COSIGNER (field 1210) "RTN","TMGPUTN0",1354,0) new pVstLoc set pVstLoc=11 ;"Node 12,piece 11 = field 1211 = VISIT LOCATION "RTN","TMGPUTN0",1355,0) "RTN","TMGPUTN0",1356,0) ;"Field (f) constants "RTN","TMGPUTN0",1357,0) new fPatient set fPatient=.02 ;"field .02 = PATIENT "RTN","TMGPUTN0",1358,0) new fVisit set fVisit=.03 ;"field .03 = VISIT "RTN","TMGPUTN0",1359,0) new fParentDoc set fParentDoc=.04 ;"field .04 = PARENT DOCUMENT TYPE "RTN","TMGPUTN0",1360,0) new fStatus set fStatus=.05 ;"field .05 = STATUS "RTN","TMGPUTN0",1361,0) new fParent set fParent=.06 ;"field .06 = PARENT "RTN","TMGPUTN0",1362,0) new fStartDate set fStartDate=.07 ;"EPISODE BEGIN DATE/TIME (field .07) "RTN","TMGPUTN0",1363,0) new fEndDate set fEndDate=.08 ;"EPISODE END DATE/TIME (field .08) "RTN","TMGPUTN0",1364,0) new fEntryDate set fEntryDate=1201 ;"field 1201 = ENTRY DATE/TIME "RTN","TMGPUTN0",1365,0) new fAuthor set fAuthor=1202 ;"field 1202 = AUTHOR/DICTATOR "RTN","TMGPUTN0",1366,0) new fExpSigner set fExpSigner=1204 ;"field 1204 = expected Signer "RTN","TMGPUTN0",1367,0) new fHospLoc set fHospLoc=1205 ;"field 1205 = HOSPITAL LOCATION "RTN","TMGPUTN0",1368,0) new fExpCosign set fExpCosign=1208 ;"field 1208 = expected cosigner "RTN","TMGPUTN0",1369,0) new fVisitLoc set fVisitLoc=1211 ;"field 1211 = VISIT LOCATION "RTN","TMGPUTN0",1370,0) new fRefDate set fRefDate=1301 ;"field 1301 = REFERENCE DATE "RTN","TMGPUTN0",1371,0) new fCapMethod set fCapMethod=1303 ;"field 1303 = CAPTURE METHOD; U-->'upload' "RTN","TMGPUTN0",1372,0) new fService set fService=1404 ;"field 1404 = SERVICE "RTN","TMGPUTN0",1373,0) new fNeedCosign set fNeedCosign=1506 ;"field 1506 = cosigniture expected. "RTN","TMGPUTN0",1374,0) new fSignedBy set fSignedBy=1502 ;"field 1502 = signed by "RTN","TMGPUTN0",1375,0) "RTN","TMGPUTN0",1376,0) new TMGFDA,TMGMsg "RTN","TMGPUTN0",1377,0) new DFN "RTN","TMGPUTN0",1378,0) new Attending,ExpSigner,ExpCosign,Author "RTN","TMGPUTN0",1379,0) new BailOut set BailOut=0 "RTN","TMGPUTN0",1380,0) new Node12 set Node12=$get(^TIU(8925,DocIEN,12)) "RTN","TMGPUTN0",1381,0) new NodeZero set NodeZero=$get(^TIU(8925,DocIEN,0)) "RTN","TMGPUTN0",1382,0) if $data(Document)=0 new Document "RTN","TMGPUTN0",1383,0) "RTN","TMGPUTN0",1384,0) set Author=+$piece(Node12,"^",pAuthor) "RTN","TMGPUTN0",1385,0) set Attending=+$piece(Node12,"^",pAttending) "RTN","TMGPUTN0",1386,0) set ExpCosign=+$piece(Node12,"^",pExpCosign) "RTN","TMGPUTN0",1387,0) set ExpSigner=+$piece(Node12,"^",pExpSigner) "RTN","TMGPUTN0",1388,0) "RTN","TMGPUTN0",1389,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Author=",Author) "RTN","TMGPUTN0",1390,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Attending=",Attending) "RTN","TMGPUTN0",1391,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ExpCosign=",ExpCosign) "RTN","TMGPUTN0",1392,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ExpSigner=",ExpSigner) "RTN","TMGPUTN0",1393,0) "RTN","TMGPUTN0",1394,0) do "RTN","TMGPUTN0",1395,0) . new Signer set Signer=$$WHOSIGNS^TIULC1(DocIEN) "RTN","TMGPUTN0",1396,0) . do Set8925Value($$WHOSIGNS^TIULC1(DocIEN),fExpSigner,1) "RTN","TMGPUTN0",1397,0) "RTN","TMGPUTN0",1398,0) if (Attending>0)&(ExpCosign=0) do "RTN","TMGPUTN0",1399,0) . do Set8925Value($$WHOCOSIG^TIULC1(DocIEN),fExpCosign,1) "RTN","TMGPUTN0",1400,0) "RTN","TMGPUTN0",1401,0) if (ExpCosign>0)&(ExpSigner'=ExpCosign) do "RTN","TMGPUTN0",1402,0) . do Set8925Value(1,fNeedCosign,0) "RTN","TMGPUTN0",1403,0) "RTN","TMGPUTN0",1404,0) set result=$$dbWrite^TMGDBAPI(.TMGFDA,1) "RTN","TMGPUTN0",1405,0) if result=-1 goto FUDone "RTN","TMGPUTN0",1406,0) "RTN","TMGPUTN0",1407,0) do RELEASE^TIUT(DocIEN,1) ;"Call function to 'Release Document from transcription' "RTN","TMGPUTN0",1408,0) do AUDIT^TIUEDI1(DocIEN,0,$$CHKSUM^TIULC("^TIU(8925,"_+DocIEN_",""TEXT"")")) ;"Update audit trail "RTN","TMGPUTN0",1409,0) "RTN","TMGPUTN0",1410,0) if '$data(Document) do if (BailOut=1) goto FUDone "RTN","TMGPUTN0",1411,0) . new VstLocIEN,HspLocIEN,StartDate,EndDate "RTN","TMGPUTN0",1412,0) . if $data(NodeZero)#10=0 do quit "RTN","TMGPUTN0",1413,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"MISSING DATA. QUITING...") "RTN","TMGPUTN0",1414,0) . . set BailOut=1 "RTN","TMGPUTN0",1415,0) . set DFN=+$piece(NodeZero,"^",pPatient) "RTN","TMGPUTN0",1416,0) . set StartDate=+$piece(NodeZero,"^",pStrtDate) "RTN","TMGPUTN0",1417,0) . set EndDate=$$FMADD^XLFDT(StartDate,1) "RTN","TMGPUTN0",1418,0) . set Document(cHspLocIEN)=+$piece(Node12,"^",pHospLoc) "RTN","TMGPUTN0",1419,0) . set Document(cVstLocIEN)=+$piece(Node12,"^",pVstLoc) "RTN","TMGPUTN0",1420,0) . set VstLocIEN=Document(cVstLocIEN) "RTN","TMGPUTN0",1421,0) . if VstLocIEN'>0 set VstLocIEN=Document(cHspLocIEN) "RTN","TMGPUTN0",1422,0) . if (DFN>0)&(StartDate>0)&(EndDate>0)&(VstLocIEN>0) do "RTN","TMGPUTN0",1423,0) . . ;"This is an interactive visit .... "RTN","TMGPUTN0",1424,0) . . do MAIN^TIUVSIT(.Document,DFN,"",StartDate,EndDate,"LAST",0,VstLocIEN) "RTN","TMGPUTN0",1425,0) "RTN","TMGPUTN0",1426,0) if $data(Document)=0 goto FUDone "RTN","TMGPUTN0",1427,0) if $data(Document(cVisitStr))#10=0 goto FUDone "RTN","TMGPUTN0",1428,0) if $data(DFN)=0 set DFN=$get(Document("DFN")) if DFN="" goto FUDone "RTN","TMGPUTN0",1429,0) "RTN","TMGPUTN0",1430,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ENQ^TIUPXAP1") "RTN","TMGPUTN0",1431,0) ;"Note: reviewing the code for ENQ^TIUPXAP1, it appears the following is expected: "RTN","TMGPUTN0",1432,0) ;" .TIU array "RTN","TMGPUTN0",1433,0) ;" DFN -- the patient IEN "RTN","TMGPUTN0",1434,0) ;" DA -- the IEN of the document to work on. "RTN","TMGPUTN0",1435,0) ;" TIUDA -- the doc IEN that was passed to this function. "RTN","TMGPUTN0",1436,0) ;" Note, I'm not sure how DA and TIUDA are used differently. "RTN","TMGPUTN0",1437,0) ;" In fact, if $data(TIUDA)=0, then function uses DA. "RTN","TMGPUTN0",1438,0) ;" Unless I kill TIUDA (which might cause other problems), I don't "RTN","TMGPUTN0",1439,0) ;" know if TIUDA will hold an abherent value. So I'll set to DA "RTN","TMGPUTN0",1440,0) do "RTN","TMGPUTN0",1441,0) . new TIUDA set TIUDA=DocIEN "RTN","TMGPUTN0",1442,0) . new DA set DA=DocIEN "RTN","TMGPUTN0",1443,0) . new TIU merge TIU=Document "RTN","TMGPUTN0",1444,0) . do ENQ^TIUPXAP1 ;" Get/file VISIT "RTN","TMGPUTN0",1445,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ENQ^TIUPXAP1") "RTN","TMGPUTN0",1446,0) "RTN","TMGPUTN0",1447,0) FUDone ; "RTN","TMGPUTN0",1448,0) kill TMGDOC "RTN","TMGPUTN0",1449,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FOLLOWUP") "RTN","TMGPUTN0",1450,0) "RTN","TMGPUTN0",1451,0) quit "RTN","TMGPUTN0",1452,0) "RTN","TMGPUTN0",1453,0) "RTN","TMGPUTN0",1454,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGPUTN0",1455,0) ;"==============================================================================================- "RTN","TMGPUTN0",1456,0) ;" R E - F I L I N G C O D E "RTN","TMGPUTN0",1457,0) ;"==============================================================================================- "RTN","TMGPUTN0",1458,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGPUTN0",1459,0) "RTN","TMGPUTN0",1460,0) REFILE "RTN","TMGPUTN0",1461,0) ;"Purpose: Somtimes the upload process fails because of an error in the "RTN","TMGPUTN0",1462,0) ;" upload filing code. Rather than require a re-upload of the file, "RTN","TMGPUTN0",1463,0) ;" this function will trigger a retry of filing the TIU UPLOAD BUFFER "RTN","TMGPUTN0",1464,0) ;" (file 8925.2) "RTN","TMGPUTN0",1465,0) ;"This function is called by menu option TMG REFILE UPLOAD "RTN","TMGPUTN0",1466,0) "RTN","TMGPUTN0",1467,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"REFILE^TMGPUTN0") "RTN","TMGPUTN0",1468,0) "RTN","TMGPUTN0",1469,0) new TIUDA set TIUDA="" "RTN","TMGPUTN0",1470,0) new job "RTN","TMGPUTN0",1471,0) new DoRetry set DoRetry="" "RTN","TMGPUTN0",1472,0) new Abort set Abort=0 "RTN","TMGPUTN0",1473,0) new Found set Found=0 "RTN","TMGPUTN0",1474,0) "RTN","TMGPUTN0",1475,0) write !,! "RTN","TMGPUTN0",1476,0) write "------------------------------------------------",! "RTN","TMGPUTN0",1477,0) write " Refiler for failed uploads (i.e. a second try.)",! "RTN","TMGPUTN0",1478,0) write "------------------------------------------------",!,! "RTN","TMGPUTN0",1479,0) "RTN","TMGPUTN0",1480,0) write "Here are all the failed uploads:",!,! "RTN","TMGPUTN0",1481,0) set job=$order(^TIU(8925.2,"B","")) "RTN","TMGPUTN0",1482,0) for do quit:(job="") "RTN","TMGPUTN0",1483,0) . new Buff,NextBuff "RTN","TMGPUTN0",1484,0) . if job="" quit "RTN","TMGPUTN0",1485,0) . set Buff=$order(^TIU(8925.2,"B",job,"")) "RTN","TMGPUTN0",1486,0) . for do quit:(Buff="") "RTN","TMGPUTN0",1487,0) . . if Buff="" quit "RTN","TMGPUTN0",1488,0) . . write "Buffer #"_Buff_" (created by process #"_job_")",! "RTN","TMGPUTN0",1489,0) . . set Found=1 "RTN","TMGPUTN0",1490,0) . . set Buff=$order(^TIU(8925.2,"B",job,Buff)) "RTN","TMGPUTN0",1491,0) . set job=$order(^TIU(8925.2,"B",job)) "RTN","TMGPUTN0",1492,0) "RTN","TMGPUTN0",1493,0) if Found=0 write "(There are no failed uploads to process... Great!)",! "RTN","TMGPUTN0",1494,0) else write "------------------------------------------------",! "RTN","TMGPUTN0",1495,0) "RTN","TMGPUTN0",1496,0) set job=$order(^TIU(8925.2,"B","")) "RTN","TMGPUTN0",1497,0) for do quit:(job="")!(Abort=1) "RTN","TMGPUTN0",1498,0) . new Buff,NextBuff "RTN","TMGPUTN0",1499,0) . if job="" quit "RTN","TMGPUTN0",1500,0) . set Buff=$order(^TIU(8925.2,"B",job,"")) "RTN","TMGPUTN0",1501,0) . for do quit:(Buff="")!(Abort=1) "RTN","TMGPUTN0",1502,0) . . if Buff="" quit "RTN","TMGPUTN0",1503,0) . . if DoRetry'="all" do "RTN","TMGPUTN0",1504,0) . . . write !,"Refile upload buffer #"_Buff_" (created by process #"_job_")? (y/n/all/^) " "RTN","TMGPUTN0",1505,0) . . . read DoRetry:$get(DTIME,300),! "RTN","TMGPUTN0",1506,0) . . else do "RTN","TMGPUTN0",1507,0) . . . new GetKey "RTN","TMGPUTN0",1508,0) . . . read *GetKey:0 "RTN","TMGPUTN0",1509,0) . . . if $get(GetKey)=27 set DoRetry="n" "RTN","TMGPUTN0",1510,0) . . . else write !,!,"Processing upload buffer #",Buff,! "RTN","TMGPUTN0",1511,0) . . if DoRetry="^" set Abort=1 quit "RTN","TMGPUTN0",1512,0) . . if (DoRetry["y")!(DoRetry["Y")!(DoRetry="all") do "RTN","TMGPUTN0",1513,0) . . . set TIUDA=Buff "RTN","TMGPUTN0",1514,0) . . . ;"These is an edited form of MAIN^TIUUPLD "RTN","TMGPUTN0",1515,0) . . . N EOM,TIUERR,TIUHDR,TIULN,TIUSRC,X "RTN","TMGPUTN0",1516,0) . . . I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE "RTN","TMGPUTN0",1517,0) . . . S TIUSRC=$P($G(TIUPRM0),U,9),EOM=$P($G(TIUPRM0),U,11) "RTN","TMGPUTN0",1518,0) . . . I EOM']"",($P(TIUPRM0,U,17)'="k") do quit "RTN","TMGPUTN0",1519,0) . . . . W !,$C(7),$C(7),$C(7),"No End of Message Signal Defined - Contact IRM.",! "RTN","TMGPUTN0",1520,0) . . . S:TIUSRC']"" TIUSRC="R" "RTN","TMGPUTN0",1521,0) . . . S TIUHDR=$P(TIUPRM0,U,10) "RTN","TMGPUTN0",1522,0) . . . I TIUHDR']"" do quit "RTN","TMGPUTN0",1523,0) . . . . W $C(7),$C(7),$C(7),"No Record Header Signal Defined - Contact IRM.",! "RTN","TMGPUTN0",1524,0) . . . new temp set temp=$order(^TIU(8925.2,TIUDA,"TEXT",0)) "RTN","TMGPUTN0",1525,0) . . . write "First line of TEXT=",temp,! "RTN","TMGPUTN0",1526,0) . . . I +$O(^TIU(8925.2,TIUDA,"TEXT",0))>0 do "RTN","TMGPUTN0",1527,0) . . . . write "Calling FILE^TIUUPLD("_TIUDA_")",! "RTN","TMGPUTN0",1528,0) . . . . D FILE^TIUUPLD(TIUDA) "RTN","TMGPUTN0",1529,0) . . . I +$O(^TIU(8925.2,TIUDA,"TEXT",0))'>0 D BUFPURGE^TIUPUTC(TIUDA) "RTN","TMGPUTN0",1530,0) . . set Buff=$order(^TIU(8925.2,"B",job,Buff)) "RTN","TMGPUTN0",1531,0) . set job=$order(^TIU(8925.2,"B",job)) "RTN","TMGPUTN0",1532,0) "RTN","TMGPUTN0",1533,0) write !,"------------------------------------------------",! "RTN","TMGPUTN0",1534,0) write " All done with Refiler",! "RTN","TMGPUTN0",1535,0) write "------------------------------------------------",!,! "RTN","TMGPUTN0",1536,0) "RTN","TMGPUTN0",1537,0) RFDone "RTN","TMGPUTN0",1538,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"REFILE^TMGPUTN0") "RTN","TMGPUTN0",1539,0) Q "RTN","TMGPUTN0",1540,0) "RTN","TMGPUTN0",1541,0) "RTN","TMGPUTN0",1542,0) "RTN","TMGPUTN0",1543,0) "RTN","TMGQIO") 0^71^B78392 "RTN","TMGQIO",1,0) TMGQIO ;TMG/kst/Quiet IO routines ;03/25/06 "RTN","TMGQIO",2,0) ;;1.0;TMG-LIB;**1**;11/01/04 "RTN","TMGQIO",3,0) "RTN","TMGQIO",4,0) ;"'QUIET IO To provide routines for quite (non-interactive) IO that programs can call. "RTN","TMGQIO",5,0) ;"============================================================================= "RTN","TMGQIO",6,0) ;"Kevin Toppenberg, MD 11-04 "RTN","TMGQIO",7,0) ;" "RTN","TMGQIO",8,0) ;"'QUIET IO" "RTN","TMGQIO",9,0) ;" "RTN","TMGQIO",10,0) ;"Purpose: "RTN","TMGQIO",11,0) ;" To provide routines for quite (non-interactive) IO that programs can call. "RTN","TMGQIO",12,0) ;" i.e. replacement routines for READ and WRITE "RTN","TMGQIO",13,0) ;" "RTN","TMGQIO",14,0) ;"Functions: "RTN","TMGQIO",15,0) ;" OUTP(SILENT,A,B,C,D,E,F,G,H,I,J) "RTN","TMGQIO",16,0) ;" WOUT(S) "RTN","TMGQIO",17,0) ;" SILENTW(S) -- puts output into INFO("TEXT") "RTN","TMGQIO",18,0) ;" INP(VAR,SILENT,TIMEOUT,SILNTVAL,A,B,C,D,E,F,G,H,I,J) "RTN","TMGQIO",19,0) ;" "RTN","TMGQIO",20,0) ;"Dependancies: "RTN","TMGQIO",21,0) ;" if TMGDEBUG defined, then requires TMGDEBUG.m "RTN","TMGQIO",22,0) ;"============================================================================= "RTN","TMGQIO",23,0) "RTN","TMGQIO",24,0) OUTP(SILENT,A,B,C,D,E,F,G,H,I,J) "RTN","TMGQIO",25,0) ;"Purpose: To provide an output channel for this program module. Will allow "RTN","TMGQIO",26,0) ;" converting to a "SILENT-OUTPUT" mode. "RTN","TMGQIO",27,0) ; "RTN","TMGQIO",28,0) ;"IF $GET(TMGDEBUG)>0 DO DebugEntry^TMGDEBUG(.DBIndent,"OUTP^TMGQIO") "RTN","TMGQIO",29,0) IF $GET(SILENT,0)=1 DO GOTO OPQUIT "RTN","TMGQIO",30,0) . IF '$$SILENTW(.A) QUIT "RTN","TMGQIO",31,0) . IF '$$SILENTW(.B) QUIT "RTN","TMGQIO",32,0) . IF '$$SILENTW(.C) QUIT "RTN","TMGQIO",33,0) . IF '$$SILENTW(.D) QUIT "RTN","TMGQIO",34,0) . IF '$$SILENTW(.E) QUIT "RTN","TMGQIO",35,0) . IF '$$SILENTW(.F) QUIT "RTN","TMGQIO",36,0) . IF '$$SILENTW(.G) QUIT "RTN","TMGQIO",37,0) . IF '$$SILENTW(.H) QUIT "RTN","TMGQIO",38,0) . IF '$$SILENTW(.I) QUIT "RTN","TMGQIO",39,0) . IF '$$SILENTW(.J) QUIT "RTN","TMGQIO",40,0) ELSE DO GOTO OPQUIT "RTN","TMGQIO",41,0) . IF '$$WOUT(.A) QUIT "RTN","TMGQIO",42,0) . IF '$$WOUT(.B) QUIT "RTN","TMGQIO",43,0) . IF '$$WOUT(.C) QUIT "RTN","TMGQIO",44,0) . IF '$$WOUT(.D) QUIT "RTN","TMGQIO",45,0) . IF '$$WOUT(.E) QUIT "RTN","TMGQIO",46,0) . IF '$$WOUT(.F) QUIT "RTN","TMGQIO",47,0) . IF '$$WOUT(.G) QUIT "RTN","TMGQIO",48,0) . IF '$$WOUT(.H) QUIT "RTN","TMGQIO",49,0) . IF '$$WOUT(.I) QUIT "RTN","TMGQIO",50,0) . IF '$$WOUT(.J) QUIT "RTN","TMGQIO",51,0) ; "RTN","TMGQIO",52,0) OPQUIT "RTN","TMGQIO",53,0) ;"IF $GET(TMGDEBUG)>0 DO DebugExit^TMGDEBUG(.DBIndent,"OUTP^TMGQIO") "RTN","TMGQIO",54,0) QUIT "RTN","TMGQIO",55,0) ; "RTN","TMGQIO",56,0) ; "RTN","TMGQIO",57,0) WOUT(S) "RTN","TMGQIO",58,0) ;"Purpose: To write out S, or newline if "!" passed "RTN","TMGQIO",59,0) ;"Result: 1 if text output, 0 if it wasn't "RTN","TMGQIO",60,0) ; "RTN","TMGQIO",61,0) ;"IF $GET(TMGDEBUG)>0 DO DebugEntry^TMGDEBUG(.DBIndent,"WOUT^TMGQIO") "RTN","TMGQIO",62,0) ;"IF $GET(TMGDEBUG)>0 DO DebugMsg^TMGDEBUG(.DBIndent,"S='",$GET(S),"'") "RTN","TMGQIO",63,0) NEW RESULT SET RESULT=0 "RTN","TMGQIO",64,0) IF $DATA(S)'=0 DO "RTN","TMGQIO",65,0) . SET RESULT=1 "RTN","TMGQIO",66,0) . IF S="!" WRITE ! QUIT "RTN","TMGQIO",67,0) . IF ($EXTRACT(S,1)="?")&(+$EXTRACT(S,2,256)>0) DO "RTN","TMGQIO",68,0) . . NEW INDENT,I "RTN","TMGQIO",69,0) . . SET INDENT=+$EXTRACT(S,2,256) "RTN","TMGQIO",70,0) . . FOR I=1:1:INDENT WRITE " " "RTN","TMGQIO",71,0) . ELSE WRITE S "RTN","TMGQIO",72,0) ;"IF $GET(TMGDEBUG)>0 DO DebugExit^TMGDEBUG(.DBIndent,"WOUT^TMGQIO") "RTN","TMGQIO",73,0) QUIT RESULT "RTN","TMGQIO",74,0) ; "RTN","TMGQIO",75,0) ; "RTN","TMGQIO",76,0) SILENTW(S) "RTN","TMGQIO",77,0) ;"Purpose: To take text and put in INFO Array "RTN","TMGQIO",78,0) ;"Result: 1 if text output, 0 if it wasn't "RTN","TMGQIO",79,0) ; "RTN","TMGQIO",80,0) IF $GET(TMGDEBUG)>0 DO DebugEntry^TMGDEBUG(.DBIndent,"SILENTW^TMGQIO") "RTN","TMGQIO",81,0) NEW RESULT SET RESULT=0 "RTN","TMGQIO",82,0) IF $DATA(S)=0 GOTO SWQ "RTN","TMGQIO",83,0) NEW LINE "RTN","TMGQIO",84,0) SET LINE=$get(INFO("TEXT","LINES"),1) "RTN","TMGQIO",85,0) DO DebugMsg^TMGDEBUG(.DBIndent,"s=",S) "RTN","TMGQIO",86,0) IF S="!" DO "RTN","TMGQIO",87,0) . IF $DATA(INFO("TEXT",LINE))=0 SET INFO("TEXT",LINE)=" " "RTN","TMGQIO",88,0) . SET INFO("TEXT","LINES")=LINE+1 "RTN","TMGQIO",89,0) ELSE DO "RTN","TMGQIO",90,0) . IF $EXTRACT(S,1)="?" set S="" ;"Ignore ?x's "RTN","TMGQIO",91,0) . SET INFO("TEXT",LINE)=$get(INFO("TEXT",LINE)," ")_S "RTN","TMGQIO",92,0) SET RESULT=1 "RTN","TMGQIO",93,0) SWQ "RTN","TMGQIO",94,0) IF $GET(TMGDEBUG)>0 DO DebugExit^TMGDEBUG(.DBIndent,"SILENTW^TMGQIO") "RTN","TMGQIO",95,0) QUIT RESULT "RTN","TMGQIO",96,0) ; "RTN","TMGQIO",97,0) ; "RTN","TMGQIO",98,0) INP(VAR,SILENT,TIMEOUT,SILNTVAL,A,B,C,D,E,F,G,H,I,J) "RTN","TMGQIO",99,0) ;"Purpose: To provide an input that may or may not be silent "RTN","TMGQIO",100,0) ;"Input VAR: variable to input. SHOULD PASS BY REFERENCE "RTN","TMGQIO",101,0) ;" SILENT: 1=silent (will get value from SILNTVAL), 0=interactive "RTN","TMGQIO",102,0) ;" TIMEOUT: value to timeout user input (optional, will default to 120) "RTN","TMGQIO",103,0) ;" SILNTVAL: the value to use to assign VAR if SILENT=1 "RTN","TMGQIO",104,0) ;" A..J: optional prompts for input if not in silent mode "RTN","TMGQIO",105,0) IF $GET(TMGDEBUG)>0 DO DebugEntry^TMGDEBUG(.DBIndent,"INP^TMGQIO") "RTN","TMGQIO",106,0) "RTN","TMGQIO",107,0) SET SILENT=$get(SILENT,0) "RTN","TMGQIO",108,0) IF SILENT=1 DO "RTN","TMGQIO",109,0) . SET VAR=$get(SILNTVAL) "RTN","TMGQIO",110,0) . IF $GET(TMGDEBUG)>0 DO DebugMsg^TMGDEBUG(.DBIndent,"Silent input used=",VAR) "RTN","TMGQIO",111,0) . DO OUTP(SILNTOUT,VAR,"!") ;//to show log the value used. "RTN","TMGQIO",112,0) ELSE DO "RTN","TMGQIO",113,0) . DO OUTP(SILNTOUT,.A,.B,.C,.D,.E,.F,.G,.H,.I,.J) "RTN","TMGQIO",114,0) . SET TIMEOUT=$get(TIMEOUT,120) "RTN","TMGQIO",115,0) . READ VAR:TIMEOUT "RTN","TMGQIO",116,0) . DO OUTP(SILNTOUT,"!") "RTN","TMGQIO",117,0) ; "RTN","TMGQIO",118,0) IF $GET(TMGDEBUG)>0 DO DebugExit^TMGDEBUG(.DBIndent,"INP^TMGQIO") "RTN","TMGQIO",119,0) QUIT "RTN","TMGQIO",120,0) ; "RTN","TMGQIO",121,0) ; "RTN","TMGRPC1") 0^72^B6434 "RTN","TMGRPC1",1,0) TMGRPC1 ;TMG/kst-RPC Functions ;03/25/06 "RTN","TMGRPC1",2,0) ;;1.0;TMG-LIB;**1**;06/04/08 "RTN","TMGRPC1",3,0) "RTN","TMGRPC1",4,0) ;"TMG RPC FUNCTIONS "RTN","TMGRPC1",5,0) "RTN","TMGRPC1",6,0) ;"Kevin Toppenberg MD "RTN","TMGRPC1",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGRPC1",8,0) ;"3/24/07 "RTN","TMGRPC1",9,0) "RTN","TMGRPC1",10,0) ;"======================================================================= "RTN","TMGRPC1",11,0) ;" RPC -- Public Functions. "RTN","TMGRPC1",12,0) ;"======================================================================= "RTN","TMGRPC1",13,0) ;"DOWNLOAD(GREF,FPATH,FNAME,LOCIEN) "RTN","TMGRPC1",14,0) ;"UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) "RTN","TMGRPC1",15,0) ;"DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) -- Download drop box file "RTN","TMGRPC1",16,0) ;"UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) -- Upload Dropbox File "RTN","TMGRPC1",17,0) ;"GETLONG(GREF,IMAGEIEN) "RTN","TMGRPC1",18,0) ;"GETDFN(RESULT,RECNUM,RECFIELD,LNAME,FNAME,MNAME,DOB,SEX,SSNUM) "RTN","TMGRPC1",19,0) ;"BLANKTIU(RESULT,DFN,PERSON,LOC,DOS,TITLE) "RTN","TMGRPC1",20,0) ;"AUTOSIGN(RESULT,DOCIEN) "RTN","TMGRPC1",21,0) ;"FNINFO(RESULT,DFN) -- GET PATIENT DEMOGRAPHICS "RTN","TMGRPC1",22,0) ;"PTADD(RESULT,INFO) -- ADD PATIENT "RTN","TMGRPC1",23,0) ;"STPTINFO(RESULT,DFN,INFO) -- SET PATIENT DEMOGRAPHICS "RTN","TMGRPC1",24,0) ;"GETURLS(RESULT) -- TMG CPRS GET URL LIST "RTN","TMGRPC1",25,0) "RTN","TMGRPC1",26,0) ;"======================================================================= "RTN","TMGRPC1",27,0) ;"PRIVATE API FUNCTIONS "RTN","TMGRPC1",28,0) ;"======================================================================= "RTN","TMGRPC1",29,0) ;"ENCODE(GRef,incSubscr,encodeFn) "RTN","TMGRPC1",30,0) ;"DECODE(GRef,incSubscr,decodeFn) "RTN","TMGRPC1",31,0) ;"$$HEXCODER(INPUT) ;"encode the input string. Currently using simple hex encoding/ "RTN","TMGRPC1",32,0) ;"$$B64CODER(INPUT) ;"encode the input string via UUENCODE (actually Base64) "RTN","TMGRPC1",33,0) ;"$$B64DECODER(INPUT) ;"encode the input string via UUDECODE (actually Base64) "RTN","TMGRPC1",34,0) "RTN","TMGRPC1",35,0) ;"======================================================================= "RTN","TMGRPC1",36,0) ;"======================================================================= "RTN","TMGRPC1",37,0) ;"Dependencies: "RTN","TMGRPC1",38,0) ;"TMGBINF "RTN","TMGRPC1",39,0) ;"TMGSTUTL "RTN","TMGRPC1",40,0) ;"RGUTUU "RTN","TMGRPC1",41,0) ;"======================================================================= "RTN","TMGRPC1",42,0) ;"======================================================================= "RTN","TMGRPC1",43,0) "RTN","TMGRPC1",44,0) DOWNLOAD(GREF,FPATH,FNAME,LOCIEN) "RTN","TMGRPC1",45,0) ;"SCOPE: Public "RTN","TMGRPC1",46,0) ;"Purpose: To provide an entry point for a RPC call from a client. The client "RTN","TMGRPC1",47,0) ;" will ask for a given file, and it will be passed back in the form "RTN","TMGRPC1",48,0) ;" of an array (in BASE64 ascii encoding) "RTN","TMGRPC1",49,0) ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) "RTN","TMGRPC1",50,0) ;" FPATH -- the file path up to, but not including, the filename "RTN","TMGRPC1",51,0) ;" Use '/' to NOT specify any subdirectory "RTN","TMGRPC1",52,0) ;" FNAME -- the name of the file to pass back "RTN","TMGRPC1",53,0) ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from "RTN","TMGRPC1",54,0) ;" default value is 1 "RTN","TMGRPC1",55,0) ;" Note: For security reasons, all path requests will be considered relative to a root path. "RTN","TMGRPC1",56,0) ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "RTN","TMGRPC1",57,0) ;" /var/local/Dir1/Dir2/download/SomeFile.jpg "RTN","TMGRPC1",58,0) ;" This root path is found in custom field 22701 in file 2005.2 "RTN","TMGRPC1",59,0) ;"Output: results are passed out in @GREF "RTN","TMGRPC1",60,0) ;" @GREF@(0)=success; 1=success, 0=failure "RTN","TMGRPC1",61,0) ;" @GREF@(1..xxx) = actual data "RTN","TMGRPC1",62,0) "RTN","TMGRPC1",63,0) set FPATH=$get(FPATH) "RTN","TMGRPC1",64,0) set FNAME=$get(FNAME) "RTN","TMGRPC1",65,0) set LOCIEN=$GET(LOCIEN,1) "RTN","TMGRPC1",66,0) "RTN","TMGRPC1",67,0) new PathRoot "RTN","TMGRPC1",68,0) set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) ;"NOTE: CUSTOM FIELD "RTN","TMGRPC1",69,0) "RTN","TMGRPC1",70,0) new NodeDiv "RTN","TMGRPC1",71,0) set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" NOTE: CUSTOM FIELD "RTN","TMGRPC1",72,0) "RTN","TMGRPC1",73,0) new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot)) "RTN","TMGRPC1",74,0) new StartPath set StartPath=$extract(FPATH,1) "RTN","TMGRPC1",75,0) "RTN","TMGRPC1",76,0) if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do "RTN","TMGRPC1",77,0) . set FPATH=$extract(FPATH,2,1024) "RTN","TMGRPC1",78,0) else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do "RTN","TMGRPC1",79,0) . set PathRoot=PathRoot_NodeDiv "RTN","TMGRPC1",80,0) "RTN","TMGRPC1",81,0) set FPATH=PathRoot_FPATH "RTN","TMGRPC1",82,0) "RTN","TMGRPC1",83,0) set GREF="^TMP(""DOWNLOAD^TMGRPC1"","_$J_")" "RTN","TMGRPC1",84,0) "RTN","TMGRPC1",85,0) kill @GREF "RTN","TMGRPC1",86,0) set @GREF@(0)=$$BFTG^TMGBINF(.FPATH,.FNAME,$name(@GREF@(1)),3) "RTN","TMGRPC1",87,0) "RTN","TMGRPC1",88,0) do ENCODE($name(@GREF@(1)),3) "RTN","TMGRPC1",89,0) "RTN","TMGRPC1",90,0) quit "RTN","TMGRPC1",91,0) "RTN","TMGRPC1",92,0) "RTN","TMGRPC1",93,0) UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) "RTN","TMGRPC1",94,0) ;"SCOPE: Public "RTN","TMGRPC1",95,0) ;"RPC That calls this: TMG UPLOAD FILE "RTN","TMGRPC1",96,0) ;"Purpose: To provide an entry point for a RPC call from a client. The client "RTN","TMGRPC1",97,0) ;" will provide a file for upload (in BASE64 ascii encoding) "RTN","TMGRPC1",98,0) ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) "RTN","TMGRPC1",99,0) ;" FPATH -- the file path up to, but not including, the filename "RTN","TMGRPC1",100,0) ;" Use '/' to NOT specify any subdirectory "RTN","TMGRPC1",101,0) ;" FNAME -- the name of the file to pass back "RTN","TMGRPC1",102,0) ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to "RTN","TMGRPC1",103,0) ;" default value is 1 "RTN","TMGRPC1",104,0) ;" Note: For security reasons, all path requests will be considered relative to a root path. "RTN","TMGRPC1",105,0) ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "RTN","TMGRPC1",106,0) ;" /var/local/Dir1/Dir2/download/SomeFile.jpg "RTN","TMGRPC1",107,0) ;" This root path is found in custom field 22701 in file 2005.2 "RTN","TMGRPC1",108,0) ;" ARRAY -- the array that will hold the file, in BASE64 ascii encoding "RTN","TMGRPC1",109,0) ;"Output: results are passed out in RESULT: 1^SuccessMessage or 0^FailureMessage "RTN","TMGRPC1",110,0) "RTN","TMGRPC1",111,0) new result "RTN","TMGRPC1",112,0) new resultMsg set resultMsg="1^Successful Upload" "RTN","TMGRPC1",113,0) "RTN","TMGRPC1",114,0) set ^TMP("UPLOAD^TMGRPC1",$J,"FPATH")=$GET(FPATH) "RTN","TMGRPC1",115,0) set ^TMP("UPLOAD^TMGRPC1",$J,"FNAME")=$GET(FNAME) "RTN","TMGRPC1",116,0) set ^TMP("UPLOAD^TMGRPC1",$J,"LOCIEN")=$GET(LOCIEN) "RTN","TMGRPC1",117,0) "RTN","TMGRPC1",118,0) if $data(ARRAY)=0 set resultMsg="0^No data received to upload" goto UpDone "RTN","TMGRPC1",119,0) set FPATH=$get(FPATH) "RTN","TMGRPC1",120,0) if FPATH="" set resultMsg="0^No file path received" goto UpDone "RTN","TMGRPC1",121,0) set FNAME=$get(FNAME) "RTN","TMGRPC1",122,0) if FNAME="" set resultMsg="0^No file name received" goto UpDone "RTN","TMGRPC1",123,0) set LOCIEN=$GET(LOCIEN,1); "RTN","TMGRPC1",124,0) new GREF "RTN","TMGRPC1",125,0) "RTN","TMGRPC1",126,0) new PathRoot "RTN","TMGRPC1",127,0) set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) "RTN","TMGRPC1",128,0) "RTN","TMGRPC1",129,0) new NodeDiv "RTN","TMGRPC1",130,0) set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" "RTN","TMGRPC1",131,0) "RTN","TMGRPC1",132,0) new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot)) "RTN","TMGRPC1",133,0) new StartPath set StartPath=$extract(FPATH,1) "RTN","TMGRPC1",134,0) if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do "RTN","TMGRPC1",135,0) . set FPATH=$extract(FPATH,2,1024) "RTN","TMGRPC1",136,0) else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do "RTN","TMGRPC1",137,0) . set PathRoot=PathRoot_NodeDiv "RTN","TMGRPC1",138,0) "RTN","TMGRPC1",139,0) set FPATH=PathRoot_FPATH "RTN","TMGRPC1",140,0) "RTN","TMGRPC1",141,0) merge ^TMP("UPLOAD^TMGRPC1",$J,"ENCODED")=ARRAY ;"//TEMP "RTN","TMGRPC1",142,0) do DECODE("ARRAY(0)",1) "RTN","TMGRPC1",143,0) merge ^TMP("UPLOAD^TMGRPC1",$J,"DECODED")=ARRAY ;"//TEMP "RTN","TMGRPC1",144,0) "RTN","TMGRPC1",145,0) if $$GTBF^TMGBINF("ARRAY(0)",1,FPATH,FNAME)=0 do "RTN","TMGRPC1",146,0) . set resultMsg="0^Error while saving file" "RTN","TMGRPC1",147,0) "RTN","TMGRPC1",148,0) UpDone "RTN","TMGRPC1",149,0) set RESULT=resultMsg "RTN","TMGRPC1",150,0) quit "RTN","TMGRPC1",151,0) "RTN","TMGRPC1",152,0) "RTN","TMGRPC1",153,0) DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Download drop box file "RTN","TMGRPC1",154,0) ;"SCOPE: Public "RTN","TMGRPC1",155,0) ;"RPC That calls this: TMG DOWNLOAD FILE DROPBOX "RTN","TMGRPC1",156,0) ;"Purpose: To provide an entry point for a RPC call from a client. The client "RTN","TMGRPC1",157,0) ;" will request for the file to be placed into in a 'dropbox' file "RTN","TMGRPC1",158,0) ;" location that both the client and server can access. File may be "RTN","TMGRPC1",159,0) ;" moved from there to its final destination by the client. "RTN","TMGRPC1",160,0) ;" This method alloows file-hiding ability on the server side. "RTN","TMGRPC1",161,0) ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) "RTN","TMGRPC1",162,0) ;" FPATH -- the file path up to, but not including, the filename. This "RTN","TMGRPC1",163,0) ;" is the path that the file is stored at (relative to a root path, "RTN","TMGRPC1",164,0) ;" see comments below). It is NOT the path of the dropbox. "RTN","TMGRPC1",165,0) ;" Use '/' to NOT specify any subdirectory "RTN","TMGRPC1",166,0) ;" FNAME -- the name of the file to be uploaded. Note: This is also the "RTN","TMGRPC1",167,0) ;" name of the file to be put into the dropbox. It is the "RTN","TMGRPC1",168,0) ;" responsibility of the client to ensure that there is not already "RTN","TMGRPC1",169,0) ;" a similarly named file in the dropbox before requesting a file "RTN","TMGRPC1",170,0) ;" be put there. It is the responsibility of the client to delete "RTN","TMGRPC1",171,0) ;" the file from the drop box. "RTN","TMGRPC1",172,0) ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from "RTN","TMGRPC1",173,0) ;" default value is 1 "RTN","TMGRPC1",174,0) ;" Note: For security reasons, all path requests will be considered relative to a root path. "RTN","TMGRPC1",175,0) ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "RTN","TMGRPC1",176,0) ;" /var/local/Dir1/Dir2/download/SomeFile.jpg "RTN","TMGRPC1",177,0) ;" This root path is found in custom field 22701 in file 2005.2 "RTN","TMGRPC1",178,0) ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2 "RTN","TMGRPC1",179,0) ;"NOTE RE DROPBOX: "RTN","TMGRPC1",180,0) ;" This system is designed for a system where by the server and the client have a "RTN","TMGRPC1",181,0) ;" shared filesystem, but the directory paths will be different. For example: "RTN","TMGRPC1",182,0) ;" Linux server has dropbox at: /mnt/WinServer/dropbox/ "RTN","TMGRPC1",183,0) ;" Windows Client has access to dropbox at: V:\Dropbox\ "RTN","TMGRPC1",184,0) "RTN","TMGRPC1",185,0) ;"Output: results are 1^Success, or 0^Error Message "RTN","TMGRPC1",186,0) "RTN","TMGRPC1",187,0) new resultMsg set resultMsg="1^Successful Download" "RTN","TMGRPC1",188,0) "RTN","TMGRPC1",189,0) set FPATH=$get(FPATH) "RTN","TMGRPC1",190,0) if FPATH="" set resultMsg="0^No file path received" goto DnDBxDone "RTN","TMGRPC1",191,0) set FNAME=$get(FNAME) "RTN","TMGRPC1",192,0) if FNAME="" set resultMsg="0^No file name received" goto DnDBxDone "RTN","TMGRPC1",193,0) set LOCIEN=$GET(LOCIEN,1); "RTN","TMGRPC1",194,0) new GREF "RTN","TMGRPC1",195,0) "RTN","TMGRPC1",196,0) new PathRoot "RTN","TMGRPC1",197,0) set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) "RTN","TMGRPC1",198,0) "RTN","TMGRPC1",199,0) new NodeDiv "RTN","TMGRPC1",200,0) set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" "RTN","TMGRPC1",201,0) "RTN","TMGRPC1",202,0) new DropBox "RTN","TMGRPC1",203,0) set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1) "RTN","TMGRPC1",204,0) if DropBox="" do goto UpDBxDone "RTN","TMGRPC1",205,0) . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702" "RTN","TMGRPC1",206,0) ;"Ensure DropBox ends in a node divider "RTN","TMGRPC1",207,0) if $extract(DropBox,$length(DropBox))'=NodeDiv do "RTN","TMGRPC1",208,0) . set DropBox=DropBox_NodeDiv "RTN","TMGRPC1",209,0) "RTN","TMGRPC1",210,0) ;"Ensure PathRoot ends in a node divider "RTN","TMGRPC1",211,0) if $extract(PathRoot,$length(PathRoot))'=NodeDiv do "RTN","TMGRPC1",212,0) . set PathRoot=PathRoot_NodeDiv "RTN","TMGRPC1",213,0) "RTN","TMGRPC1",214,0) ;"Ensure Fpath does NOT start in a node divider "RTN","TMGRPC1",215,0) if $extract(FPATH,1)=NodeDiv do "RTN","TMGRPC1",216,0) . set FPATH=$extract(FPATH,2,1024) "RTN","TMGRPC1",217,0) "RTN","TMGRPC1",218,0) set FPATH=PathRoot_FPATH "RTN","TMGRPC1",219,0) "RTN","TMGRPC1",220,0) new SrcNamePath set SrcNamePath=FPATH_FNAME "RTN","TMGRPC1",221,0) ;"new DestNamePath set DestNamePath=DropBox_FNAME "RTN","TMGRPC1",222,0) "RTN","TMGRPC1",223,0) new moveResult "RTN","TMGRPC1",224,0) set moveResult=$$Copy^TMGKERNL(SrcNamePath,DropBox) "RTN","TMGRPC1",225,0) if moveResult>0 do "RTN","TMGRPC1",226,0) . set resultMsg="0^Move failed, returning OS error code: "_moveResult "RTN","TMGRPC1",227,0) "RTN","TMGRPC1",228,0) DnDBxDone "RTN","TMGRPC1",229,0) set RESULT=resultMsg "RTN","TMGRPC1",230,0) quit "RTN","TMGRPC1",231,0) "RTN","TMGRPC1",232,0) "RTN","TMGRPC1",233,0) UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Upload Dropbox File "RTN","TMGRPC1",234,0) ;"SCOPE: Public "RTN","TMGRPC1",235,0) ;"RPC That calls this: TMG UPLOAD FILE DROPBOX "RTN","TMGRPC1",236,0) ;"Purpose: To provide an entry point for a RPC call from a client. The client "RTN","TMGRPC1",237,0) ;" will put the file in a 'dropbox' file location that both the client "RTN","TMGRPC1",238,0) ;" and server can access. File will be moved from there to its final "RTN","TMGRPC1",239,0) ;" destination. This will provide file-hiding ability on the server side. "RTN","TMGRPC1",240,0) ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) "RTN","TMGRPC1",241,0) ;" FPATH -- the file path up to, but not including, the filename. This "RTN","TMGRPC1",242,0) ;" is the path to store the file at. (relative to a root path, "RTN","TMGRPC1",243,0) ;" see comments below). It is NOT the path of the dropbox. "RTN","TMGRPC1",244,0) ;" Use '/' to NOT specify any subdirectory "RTN","TMGRPC1",245,0) ;" FNAME -- the name of the file to be uploaded. Note: This is also the "RTN","TMGRPC1",246,0) ;" name of the file to be pulled from the dropbox. It is the "RTN","TMGRPC1",247,0) ;" responsibility of the client to ensure that there is not already "RTN","TMGRPC1",248,0) ;" a similarly named file in the dropbox before depositing a file there. "RTN","TMGRPC1",249,0) ;" The server will remove the file from the dropbox, unless there is "RTN","TMGRPC1",250,0) ;" an error with the host OS (which will be returned as an error message) "RTN","TMGRPC1",251,0) ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to "RTN","TMGRPC1",252,0) ;" default value is 1 "RTN","TMGRPC1",253,0) ;" Note: For security reasons, all path requests will be considered relative to a root path. "RTN","TMGRPC1",254,0) ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: "RTN","TMGRPC1",255,0) ;" /var/local/Dir1/Dir2/download/SomeFile.jpg "RTN","TMGRPC1",256,0) ;" This root path is found in custom field 22700 in file 2005.2 "RTN","TMGRPC1",257,0) ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2 "RTN","TMGRPC1",258,0) ;"NOTE RE DROPBOX: "RTN","TMGRPC1",259,0) ;" This system is designed for a system where by the server and the client have a "RTN","TMGRPC1",260,0) ;" shared filesystem, but the directory paths will be different. For example: "RTN","TMGRPC1",261,0) ;" Linux server has dropbox at: /mnt/WinServer/dropbox/ "RTN","TMGRPC1",262,0) ;" Windows Client has access to dropbox at: V:\Dropbox\ "RTN","TMGRPC1",263,0) "RTN","TMGRPC1",264,0) ;"Output: results are passed out in RESULT: "RTN","TMGRPC1",265,0) ;" 1^SuccessMessage or 0^FailureMessage "RTN","TMGRPC1",266,0) "RTN","TMGRPC1",267,0) new result "RTN","TMGRPC1",268,0) new resultMsg set resultMsg="1^Successful Upload" "RTN","TMGRPC1",269,0) "RTN","TMGRPC1",270,0) set FPATH=$get(FPATH) "RTN","TMGRPC1",271,0) if FPATH="" set resultMsg="0^No file path received" goto UpDBxDone "RTN","TMGRPC1",272,0) set FNAME=$get(FNAME) "RTN","TMGRPC1",273,0) if FNAME="" set resultMsg="0^No file name received" goto UpDBxDone "RTN","TMGRPC1",274,0) set LOCIEN=$GET(LOCIEN,1); "RTN","TMGRPC1",275,0) new GREF "RTN","TMGRPC1",276,0) "RTN","TMGRPC1",277,0) new PathRoot "RTN","TMGRPC1",278,0) set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) "RTN","TMGRPC1",279,0) "RTN","TMGRPC1",280,0) new NodeDiv "RTN","TMGRPC1",281,0) set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" "RTN","TMGRPC1",282,0) "RTN","TMGRPC1",283,0) new DropBox "RTN","TMGRPC1",284,0) set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1) "RTN","TMGRPC1",285,0) if DropBox="" do goto UpDBxDone "RTN","TMGRPC1",286,0) . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702" "RTN","TMGRPC1",287,0) ;"Ensure DropBox ends in a node divider "RTN","TMGRPC1",288,0) if $extract(DropBox,$length(DropBox))'=NodeDiv do "RTN","TMGRPC1",289,0) . set DropBox=DropBox_NodeDiv "RTN","TMGRPC1",290,0) "RTN","TMGRPC1",291,0) ;"Ensure PathRoot ends in a node divider "RTN","TMGRPC1",292,0) if $extract(PathRoot,$length(PathRoot))'=NodeDiv do "RTN","TMGRPC1",293,0) . set PathRoot=PathRoot_NodeDiv "RTN","TMGRPC1",294,0) "RTN","TMGRPC1",295,0) ;"Ensure Fpath does NOT start in a node divider "RTN","TMGRPC1",296,0) if $extract(FPATH,1)=NodeDiv do "RTN","TMGRPC1",297,0) . set FPATH=$extract(FPATH,2,1024) "RTN","TMGRPC1",298,0) "RTN","TMGRPC1",299,0) set FPATH=PathRoot_FPATH "RTN","TMGRPC1",300,0) "RTN","TMGRPC1",301,0) new SrcNamePath,DestNamePath "RTN","TMGRPC1",302,0) set SrcNamePath=DropBox_FNAME "RTN","TMGRPC1",303,0) set DestNamePath=FPATH_FNAME "RTN","TMGRPC1",304,0) "RTN","TMGRPC1",305,0) new moveResult "RTN","TMGRPC1",306,0) set moveResult=$$Move^TMGKERNL(SrcNamePath,DestNamePath) "RTN","TMGRPC1",307,0) if moveResult>0 do "RTN","TMGRPC1",308,0) . set resultMsg="0^Move failed, returning OS error code: "_moveResult "RTN","TMGRPC1",309,0) "RTN","TMGRPC1",310,0) UpDBxDone "RTN","TMGRPC1",311,0) set RESULT=resultMsg "RTN","TMGRPC1",312,0) quit "RTN","TMGRPC1",313,0) "RTN","TMGRPC1",314,0) "RTN","TMGRPC1",315,0) ENCODE(GRef,incSubscr,encodeFn) "RTN","TMGRPC1",316,0) ;"Purpose: ENCODE a BINARY GLOBAL. "RTN","TMGRPC1",317,0) ;"Input: "RTN","TMGRPC1",318,0) ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved "RTN","TMGRPC1",319,0) ;" (closed root) format. "RTN","TMGRPC1",320,0) ;" Note: "RTN","TMGRPC1",321,0) ;" At least one subscript must be numeric. This will be the incrementing "RTN","TMGRPC1",322,0) ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment "RTN","TMGRPC1",323,0) ;" to store each new global node). This subscript need not be the final "RTN","TMGRPC1",324,0) ;" subscript. For example, to load into a WORD PROCESSING field, the "RTN","TMGRPC1",325,0) ;" incrementing node is the second-to-last subscript; the final subscript "RTN","TMGRPC1",326,0) ;" is always zero. "RTN","TMGRPC1",327,0) ;" REQUIRED "RTN","TMGRPC1",328,0) ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global "RTN","TMGRPC1",329,0) ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and "RTN","TMGRPC1",330,0) ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third "RTN","TMGRPC1",331,0) ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global "RTN","TMGRPC1",332,0) ;" reference, such as ^TMP(115,1,x,0). "RTN","TMGRPC1",333,0) ;" REQUIRED "RTN","TMGRPC1",334,0) ;" encodeFn- (OPTIONAL) the name of a function that will encode a line of data. "RTN","TMGRPC1",335,0) ;" e.g. "CODER^ZZZCODER" or "LOCALCODER". The function should "RTN","TMGRPC1",336,0) ;" take one input variable (the line of raw binary data), and return a converted "RTN","TMGRPC1",337,0) ;" line. e.g. "RTN","TMGRPC1",338,0) ;" CODER(INPUT) "RTN","TMGRPC1",339,0) ;" ... ;"convert INPUT to RESULT "RTN","TMGRPC1",340,0) ;" QUIT RESULT "RTN","TMGRPC1",341,0) ;" default value is B64CODER^TMGRPC1 "RTN","TMGRPC1",342,0) ;" "RTN","TMGRPC1",343,0) ;"Output: @GRef is converted to encoded data "RTN","TMGRPC1",344,0) ;"Result: None "RTN","TMGRPC1",345,0) "RTN","TMGRPC1",346,0) if $get(GRef)="" goto EncodeDone "RTN","TMGRPC1",347,0) if $get(incSubscr)="" goto EncodeDone "RTN","TMGRPC1",348,0) "RTN","TMGRPC1",349,0) set encodeFn=$get(encodeFn,"B64CODER") "RTN","TMGRPC1",350,0) "RTN","TMGRPC1",351,0) new encoder "RTN","TMGRPC1",352,0) set encoder="set temp=$$"_encodeFn_"(.temp)" "RTN","TMGRPC1",353,0) "RTN","TMGRPC1",354,0) for do quit:(GRef="") "RTN","TMGRPC1",355,0) . new temp "RTN","TMGRPC1",356,0) . set temp=$get(@GRef) "RTN","TMGRPC1",357,0) . if temp="" set GRef="" quit "RTN","TMGRPC1",358,0) . xecute encoder ;"i.e. set temp=$$encoderFn(.temp) "RTN","TMGRPC1",359,0) . set @GRef=temp "RTN","TMGRPC1",360,0) . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1) "RTN","TMGRPC1",361,0) "RTN","TMGRPC1",362,0) EncodeDone "RTN","TMGRPC1",363,0) quit "RTN","TMGRPC1",364,0) "RTN","TMGRPC1",365,0) "RTN","TMGRPC1",366,0) HEXCODER(INPUT) "RTN","TMGRPC1",367,0) ;"Purpose: to encode the input string. Currently using simple hex encoding/ "RTN","TMGRPC1",368,0) quit $$STRB2H^TMGSTUTL(.INPUT,0,1) "RTN","TMGRPC1",369,0) "RTN","TMGRPC1",370,0) "RTN","TMGRPC1",371,0) B64CODER(INPUT) "RTN","TMGRPC1",372,0) ;"Purpose: to encode the input string via UUENCODE (actually Base64) "RTN","TMGRPC1",373,0) quit $$ENCODE^RGUTUU(.INPUT) "RTN","TMGRPC1",374,0) "RTN","TMGRPC1",375,0) B64DECODER(INPUT) "RTN","TMGRPC1",376,0) ;"Purpose: to encode the input string via UUENCODE (actually Base64) "RTN","TMGRPC1",377,0) quit $$DECODE^RGUTUU(.INPUT) "RTN","TMGRPC1",378,0) "RTN","TMGRPC1",379,0) "RTN","TMGRPC1",380,0) DECODE(GRef,incSubscr,decodeFn) "RTN","TMGRPC1",381,0) ;"Purpose: ENCODE a BINARY GLOBAL. "RTN","TMGRPC1",382,0) ;"Input: "RTN","TMGRPC1",383,0) ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved "RTN","TMGRPC1",384,0) ;" (closed root) format. "RTN","TMGRPC1",385,0) ;" Note: "RTN","TMGRPC1",386,0) ;" At least one subscript must be numeric. This will be the incrementing "RTN","TMGRPC1",387,0) ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment "RTN","TMGRPC1",388,0) ;" to store each new global node). This subscript need not be the final "RTN","TMGRPC1",389,0) ;" subscript. For example, to load into a WORD PROCESSING field, the "RTN","TMGRPC1",390,0) ;" incrementing node is the second-to-last subscript; the final subscript "RTN","TMGRPC1",391,0) ;" is always zero. "RTN","TMGRPC1",392,0) ;" REQUIRED "RTN","TMGRPC1",393,0) ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global "RTN","TMGRPC1",394,0) ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and "RTN","TMGRPC1",395,0) ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third "RTN","TMGRPC1",396,0) ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global "RTN","TMGRPC1",397,0) ;" reference, such as ^TMP(115,1,x,0). "RTN","TMGRPC1",398,0) ;" REQUIRED "RTN","TMGRPC1",399,0) ;" decodeFn- (OPTIONAL) the name of a function that will decode a line of data. "RTN","TMGRPC1",400,0) ;" e.g. "DECODER^ZZZCODER" or "DECODER". The function should take "RTN","TMGRPC1",401,0) ;" one input variable (the line of encoded data), and return a decoded line. e.g. "RTN","TMGRPC1",402,0) ;" DECODER(INPUT) "RTN","TMGRPC1",403,0) ;" ... ;"convert INPUT to RESULT "RTN","TMGRPC1",404,0) ;" QUIT RESULT "RTN","TMGRPC1",405,0) ;" default value is B64DECODER^TMGRPC1 "RTN","TMGRPC1",406,0) ;" "RTN","TMGRPC1",407,0) ;"Output: @GRef is converted to decoded data "RTN","TMGRPC1",408,0) ;"Result: None "RTN","TMGRPC1",409,0) "RTN","TMGRPC1",410,0) if $get(GRef)="" goto DecodeDone "RTN","TMGRPC1",411,0) if $get(incSubscr)="" goto DecodeDone "RTN","TMGRPC1",412,0) set decodeFn=$get(decodeFn,"B64DECODER") "RTN","TMGRPC1",413,0) "RTN","TMGRPC1",414,0) new decoder "RTN","TMGRPC1",415,0) set decoder="set temp=$$"_decodeFn_"(.temp)" "RTN","TMGRPC1",416,0) "RTN","TMGRPC1",417,0) for do quit:(GRef="") "RTN","TMGRPC1",418,0) . new temp "RTN","TMGRPC1",419,0) . set temp=$get(@GRef) "RTN","TMGRPC1",420,0) . if temp="" set GRef="" quit "RTN","TMGRPC1",421,0) . xecute decoder ;"i.e. set temp=$$decoderFn(.temp) "RTN","TMGRPC1",422,0) . set @GRef=temp "RTN","TMGRPC1",423,0) . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1) "RTN","TMGRPC1",424,0) "RTN","TMGRPC1",425,0) DecodeDone "RTN","TMGRPC1",426,0) quit "RTN","TMGRPC1",427,0) "RTN","TMGRPC1",428,0) "RTN","TMGRPC1",429,0) GETLONG(GREF,IMAGEIEN) "RTN","TMGRPC1",430,0) ;"SCOPE: Public "RTN","TMGRPC1",431,0) ;"Purpose: To provide an entry point for a RPC call from a client. "RTN","TMGRPC1",432,0) ;" Will return results of field 11 (LONG DESCRIPTION) from file IMAGE(2005) "RTN","TMGRPC1",433,0) ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) "RTN","TMGRPC1",434,0) ;" IMAGEIEN-- The IEN (record number) from file 2005 (IMAGE) "RTN","TMGRPC1",435,0) ;"Output: results are passed out in @GREF "RTN","TMGRPC1",436,0) ;" @GREF@(0) = WP header line: format is: ^^MaxLine^MaxLine^TimeStamp(FM Date/Time Format) "RTN","TMGRPC1",437,0) ;" @GREF@(1) = WP line 1 "RTN","TMGRPC1",438,0) ;" @GREF@(2) = WP line 2 "RTN","TMGRPC1",439,0) ;" @GREF@(3) = WP line 3 "RTN","TMGRPC1",440,0) ;" @GREF@(4) = WP line 4 ... etc. "RTN","TMGRPC1",441,0) "RTN","TMGRPC1",442,0) set GREF="^TMP(""GETLONG^TMGRPC1"","_$J_")" "RTN","TMGRPC1",443,0) "RTN","TMGRPC1",444,0) kill @GREF "RTN","TMGRPC1",445,0) "RTN","TMGRPC1",446,0) new i,s,MaxLines,header "RTN","TMGRPC1",447,0) set header="" "RTN","TMGRPC1",448,0) if +$get(IMAGEIEN)>0 do "RTN","TMGRPC1",449,0) . set header=$get(^MAG(2005,IMAGEIEN,3,0)) ;"NOTE: Field 11 held in node 3;0 "RTN","TMGRPC1",450,0) set @GREF@(0)=header "RTN","TMGRPC1",451,0) set MaxLines=+$piece(header,"^",3) "RTN","TMGRPC1",452,0) for i=1:1:MaxLines do "RTN","TMGRPC1",453,0) . set @GREF@(i)=$get(^MAG(2005,IMAGEIEN,3,i,0)) "RTN","TMGRPC1",454,0) "RTN","TMGRPC1",455,0) quit "RTN","TMGRPC1",456,0) "RTN","TMGRPC1",457,0) "RTN","TMGRPC1",458,0) "RTN","TMGRPC1",459,0) GETDFN(RESULT,RECNUM,PMS,FNAME,LNAME,MNAME,DOB,SEX,SSNUM,AUTOADD) "RTN","TMGRPC1",460,0) ;"Purpose: This is a RPC entry point for looking up a patient. "RTN","TMGRPC1",461,0) ;"Input: "RTN","TMGRPC1",462,0) ;" RESULT -- an OUT PARAMETER "RTN","TMGRPC1",463,0) ;" RECNUM -- Record number from a PMS "RTN","TMGRPC1",464,0) ;" PMS -- Which PMS RECNUM refers to (1=Medic,2=Sequel,3=Paradigm) "RTN","TMGRPC1",465,0) ;" FNAME -- First Name "RTN","TMGRPC1",466,0) ;" LNAME -- Last name "RTN","TMGRPC1",467,0) ;" MNAME -- Middle Name or initial "RTN","TMGRPC1",468,0) ;" DOB -- Date of birth in EXTERNAL format "RTN","TMGRPC1",469,0) ;" SEX -- Patient sex: M or F "RTN","TMGRPC1",470,0) ;" SSNUM -- Social security number (digits only) "RTN","TMGRPC1",471,0) ;" AUTOADD -- Automatically register patient if needed (if value=1) "RTN","TMGRPC1",472,0) ;"Output: Patient may be added to database if AUTOADD=1 "RTN","TMGRPC1",473,0) ;"Results: Returns DFN (i.e. IEN in PATIENT file) or -1 if not found or error "RTN","TMGRPC1",474,0) "RTN","TMGRPC1",475,0) new Patient,TMGFREG "RTN","TMGRPC1",476,0) set RESULT=-1 ;"default to not found "RTN","TMGRPC1",477,0) "RTN","TMGRPC1",478,0) if $get(LNAME)'="" do "RTN","TMGRPC1",479,0) . set Patient("NAME")=$get(LNAME) "RTN","TMGRPC1",480,0) . if $get(FNAME)'="" set Patient("NAME")=Patient("NAME")_","_FNAME "RTN","TMGRPC1",481,0) . if $get(MNAME)'="" set Patient("NAME")=Patient("NAME")_" "_MNAME "RTN","TMGRPC1",482,0) set Patient("DOB")=$get(DOB) "RTN","TMGRPC1",483,0) set Patient("SEX")=$get(SEX) "RTN","TMGRPC1",484,0) set Patient("SSNUM")=$get(SSNUM) "RTN","TMGRPC1",485,0) test if $get(AUTOADD)=1 set TMGFREG=1 "RTN","TMGRPC1",486,0) "RTN","TMGRPC1",487,0) if $get(PMS)=1 set Patient("PATIENTNUM")=$get(RECNUM) ;" <-- Medic account number "RTN","TMGRPC1",488,0) if $get(PMS)=2 set Patient("SEQUELNUM")=$get(RECNUM) ;" <-- Sequel or other account number "RTN","TMGRPC1",489,0) if $get(PMS)=3 set Patient("PARADIGMNUM")=$get(RECNUM) ;" <-- Paradigm or other account number "RTN","TMGRPC1",490,0) "RTN","TMGRPC1",491,0) ;"temp "RTN","TMGRPC1",492,0) ;"merge ^TMG("TMP","GETDFN","KILLLATER")=Patient "RTN","TMGRPC1",493,0) ;"set ^TMG("TMP","GETDFN","KILLLATER","FNAME")=FNAME "RTN","TMGRPC1",494,0) ;"set ^TMG("TMP","GETDFN","KILLLATER","LNAME")=LNAME "RTN","TMGRPC1",495,0) ;"set ^TMG("TMP","GETDFN","KILLLATER","MNAME")=MNAME "RTN","TMGRPC1",496,0) "RTN","TMGRPC1",497,0) set RESULT=$$GetDFN^TMGGDFN(.Patient) "RTN","TMGRPC1",498,0) "RTN","TMGRPC1",499,0) quit "RTN","TMGRPC1",500,0) "RTN","TMGRPC1",501,0) "RTN","TMGRPC1",502,0) BLANKTIU(RESULT,DFN,PERSON,LOC,DOS,TITLE) "RTN","TMGRPC1",503,0) ;"Purpose: To create a new, blank TIU note and return it's IEN "RTN","TMGRPC1",504,0) ;"Input: DFN -- IEN in PATIENT file of patient "RTN","TMGRPC1",505,0) ;" PERSON -- Provider NAME "RTN","TMGRPC1",506,0) ;" LOC -- Location for new document "RTN","TMGRPC1",507,0) ;" DOS -- Date of Service "RTN","TMGRPC1",508,0) ;" TITLE -- Title of new document "RTN","TMGRPC1",509,0) ;"Results: IEN in file 8925 is returned in RESULT, "RTN","TMGRPC1",510,0) ;" or -1^ErrMsg1;ErrMsg2... if failure "RTN","TMGRPC1",511,0) ;"Note: This functionality probably duplicates that of RPC call: "RTN","TMGRPC1",512,0) ;" TIU CREATE NOTE -- found after writing this... "RTN","TMGRPC1",513,0) "RTN","TMGRPC1",514,0) new Document,Flag "RTN","TMGRPC1",515,0) "RTN","TMGRPC1",516,0) set Document("DFN")=DFN "RTN","TMGRPC1",517,0) set Document("PROVIDER IEN")=$$GetProvIEN^TMGPUTN0(PERSON) "RTN","TMGRPC1",518,0) set Document("LOCATION")=$get(LOC) "RTN","TMGRPC1",519,0) set Document("DATE")=$get(DOS) "RTN","TMGRPC1",520,0) set Document("TITLE")=$get(TITLE) "RTN","TMGRPC1",521,0) set Document("TRANSCRIPTIONIST")="" "RTN","TMGRPC1",522,0) set Document("CHARACTER COUNT - TRANSCRIPTIONIST'S")=0 "RTN","TMGRPC1",523,0) "RTN","TMGRPC1",524,0) set RESULT=$$PrepDoc^TMGPUTN0(.Document) "RTN","TMGRPC1",525,0) if +RESULT>0 do ;"change capture method from Upload (default) to RPC "RTN","TMGRPC1",526,0) . new TMGFDA,TMGMSG "RTN","TMGRPC1",527,0) . set TMGFDA(8925,RESULT_",",1303)="R" ;"1303 = capture method. "R" = RPC "RTN","TMGRPC1",528,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;"ignore any errors. "RTN","TMGRPC1",529,0) else do "RTN","TMGRPC1",530,0) . new i,ErrMsg set ErrMsg="" "RTN","TMGRPC1",531,0) . for i=1:1:+$get(Document("ERROR","NUM")) do "RTN","TMGRPC1",532,0) . . set ErrMsg=ErrMsg_$get(Document("ERROR",i))_" ||" "RTN","TMGRPC1",533,0) . if $data(Document("ERROR","FM INFO"))>0 do "RTN","TMGRPC1",534,0) . . new ref set ref="Document(""ERROR"",""FM INFO"")" "RTN","TMGRPC1",535,0) . . set ErrMsg=ErrMsg_"FILEMAN SAYS:" "RTN","TMGRPC1",536,0) . . for set ref=$query(@ref) quit:(ref="")!(ref'["FM INFO") do "RTN","TMGRPC1",537,0) . . . if ErrMsg'="" set ErrMsg=ErrMsg_" ||" "RTN","TMGRPC1",538,0) . . . set ErrMsg=ErrMsg_$piece(ref,"DIERR",2)_"="_$get(@ref) "RTN","TMGRPC1",539,0) . if ErrMsg="" set ErrMsg="Unknown error" "RTN","TMGRPC1",540,0) . set ErrMsg=$translate(ErrMsg,"^","@") "RTN","TMGRPC1",541,0) . set $piece(RESULT,"^",2)=ErrMsg "RTN","TMGRPC1",542,0) "RTN","TMGRPC1",543,0) ;"temp "RTN","TMGRPC1",544,0) merge ^TMG("TMP","BLANKTIU","RESULT")=RESULT "RTN","TMGRPC1",545,0) merge ^TMG("TMP","BLANKTIU","Document")=Document "RTN","TMGRPC1",546,0) "RTN","TMGRPC1",547,0) "RTN","TMGRPC1",548,0) quit "RTN","TMGRPC1",549,0) "RTN","TMGRPC1",550,0) "RTN","TMGRPC1",551,0) AUTOSIGN(RESULT,DOCIEN) "RTN","TMGRPC1",552,0) ;"Purpose: To automatically sign TIU note (8925). "RTN","TMGRPC1",553,0) ;"Input: DOCIEN -- the IEN in 8925 of the file to be automatically signed. "RTN","TMGRPC1",554,0) ;"Note: This function will not succeed unless field 1303 holds "R" "RTN","TMGRPC1",555,0) ;" and an Author found for note "RTN","TMGRPC1",556,0) ;"Results: Results passed back in RESULT(0) ARRAY "RTN","TMGRPC1",557,0) ;" -1 = failure. 1= success "RTN","TMGRPC1",558,0) ;" Any error message is passed back in RESULT("DIERR") "RTN","TMGRPC1",559,0) ;"Note: This differs from RPC CALL: TIU SIGN RECORD in that a signiture "RTN","TMGRPC1",560,0) ;" code is NOT required "RTN","TMGRPC1",561,0) "RTN","TMGRPC1",562,0) new TMGFDA,TMGMSG "RTN","TMGRPC1",563,0) new AuthorIEN,AuthorName "RTN","TMGRPC1",564,0) new CaptureMethod "RTN","TMGRPC1",565,0) "RTN","TMGRPC1",566,0) set DOCIEN=+$get(DOCIEN) "RTN","TMGRPC1",567,0) set RESULT=-1 ;"default to failure "RTN","TMGRPC1",568,0) "RTN","TMGRPC1",569,0) set CaptureMethod=$piece($get(^TIU(8925,DOCIEN,13)),"^",3) "RTN","TMGRPC1",570,0) if CaptureMethod'="R" do goto ASDone "RTN","TMGRPC1",571,0) . set RESULT("DIERR")="Unable to auto-sign. Upload-Method was not 'R'." "RTN","TMGRPC1",572,0) set AuthorIEN=$piece($get(^TIU(8925,DOCIEN,12)),"^",2) "RTN","TMGRPC1",573,0) if AuthorIEN'>0 do goto ASDone "RTN","TMGRPC1",574,0) . set RESULT("DIERR")="Unable to find author of document." "RTN","TMGRPC1",575,0) set AuthorName=$piece($get(^VA(200,AuthorIEN,0)),"^",1) "RTN","TMGRPC1",576,0) "RTN","TMGRPC1",577,0) set TMGFDA(8925,DOCIEN_",",.05)="COMPLETED" ;"field .05 = STATUS "RTN","TMGRPC1",578,0) set TMGFDA(8925,DOCIEN_",",1501)="NOW" ;"field 1501 = Signed date "RTN","TMGRPC1",579,0) set TMGFDA(8925,DOCIEN_",",1502)="`"_AuthorIEN ;"field 1502 = signed by "RTN","TMGRPC1",580,0) set TMGFDA(8925,DOCIEN_",",1503)=AuthorName ;"field 1503 = Signature block name "RTN","TMGRPC1",581,0) set TMGFDA(8925,DOCIEN_",",1504)="[Scanned image auto-signed]" ;"field 1504 = Signature block title "RTN","TMGRPC1",582,0) set TMGFDA(8925,DOCIEN_",",1505)="C" ;C=Chart ;"field 1505 = Signature mode "RTN","TMGRPC1",583,0) do FILE^DIE("E","TMGFDA","TMGMSG") "RTN","TMGRPC1",584,0) if $data(TMGMSG("DIERR")) do goto ASDone "RTN","TMGRPC1",585,0) . merge RESULT("DIERR")=TMGMSG("DIERR") "RTN","TMGRPC1",586,0) "RTN","TMGRPC1",587,0) set RESULT(0)=1 ;"set success if we got this far. "RTN","TMGRPC1",588,0) ASDone "RTN","TMGRPC1",589,0) quit "RTN","TMGRPC1",590,0) "RTN","TMGRPC1",591,0) "RTN","TMGRPC1",592,0) DFNINFO(RESULT,DFN) "RTN","TMGRPC1",593,0) ;"Purpose: To return array with demographcs details about patient "RTN","TMGRPC1",594,0) ;"Input: RESULT (this is the output array) "RTN","TMGRPC1",595,0) ;" DFN : The record number in file #2 of the patient to inquire about. "RTN","TMGRPC1",596,0) ;"Results: Results passed back in RESULT array. Format as follows: "RTN","TMGRPC1",597,0) ;" The results are in format: KeyName=Value, "RTN","TMGRPC1",598,0) ;" There is no set order these will appear. "RTN","TMGRPC1",599,0) ;" Here are the KeyName names that will be provided. "RTN","TMGRPC1",600,0) ;" If the record has no value, then value will be empty "RTN","TMGRPC1",601,0) ;" IEN=record# "RTN","TMGRPC1",602,0) ;" COMBINED_NAME= "RTN","TMGRPC1",603,0) ;" LNAME= "RTN","TMGRPC1",604,0) ;" FNAME= "RTN","TMGRPC1",605,0) ;" MNAME= "RTN","TMGRPC1",606,0) ;" PREFIX= "RTN","TMGRPC1",607,0) ;" SUFFIX= "RTN","TMGRPC1",608,0) ;" DEGREE "RTN","TMGRPC1",609,0) ;" DOB= "RTN","TMGRPC1",610,0) ;" SEX= "RTN","TMGRPC1",611,0) ;" SS_NUM= "RTN","TMGRPC1",612,0) ;" ADDRESS_LINE_1= "RTN","TMGRPC1",613,0) ;" ADDRESS_LINE_2= "RTN","TMGRPC1",614,0) ;" ADDRESS_LINE_3= "RTN","TMGRPC1",615,0) ;" CITY= "RTN","TMGRPC1",616,0) ;" STATE= "RTN","TMGRPC1",617,0) ;" ZIP4= "RTN","TMGRPC1",618,0) ;" BAD_ADDRESS= "RTN","TMGRPC1",619,0) ;" TEMP_ADDRESS_LINE_1= "RTN","TMGRPC1",620,0) ;" TEMP_ADDRESS_LINE_2= "RTN","TMGRPC1",621,0) ;" TEMP_ADDRESS_LINE_3= "RTN","TMGRPC1",622,0) ;" TEMP_CITY= "RTN","TMGRPC1",623,0) ;" TEMP_STATE= "RTN","TMGRPC1",624,0) ;" TEMP_ZIP4= "RTN","TMGRPC1",625,0) ;" TEMP_STARTING_DATE= "RTN","TMGRPC1",626,0) ;" TEMP_ENDING_DATE= "RTN","TMGRPC1",627,0) ;" TEMP_ADDRESS_ACTIVE= "RTN","TMGRPC1",628,0) ;" CONF_ADDRESS_LINE_1= "RTN","TMGRPC1",629,0) ;" CONF_ADDRESS_LINE_2= "RTN","TMGRPC1",630,0) ;" CONF_ADDRESS_LINE_3= "RTN","TMGRPC1",631,0) ;" CONF_CITY= "RTN","TMGRPC1",632,0) ;" CONF_STATE= "RTN","TMGRPC1",633,0) ;" CONF_ZIP4= "RTN","TMGRPC1",634,0) ;" CONF_STARTING_DATE= "RTN","TMGRPC1",635,0) ;" CONF_ENDING_DATE= "RTN","TMGRPC1",636,0) ;" CONF_ADDRESS_ACTIVE= "RTN","TMGRPC1",637,0) ;" PHONE_RESIDENCE= "RTN","TMGRPC1",638,0) ;" PHONE_WORK= "RTN","TMGRPC1",639,0) ;" PHONE_CELL= "RTN","TMGRPC1",640,0) ;" PHONE_TEMP= "RTN","TMGRPC1",641,0) "RTN","TMGRPC1",642,0) ;"Note, for the following, there may be multiple entries. # is record number "RTN","TMGRPC1",643,0) ;" ALIAS # NAME "RTN","TMGRPC1",644,0) ;" ALIAS # SSN "RTN","TMGRPC1",645,0) "RTN","TMGRPC1",646,0) new TMGFDA,TMGMSG,IENS "RTN","TMGRPC1",647,0) set IENS="" "RTN","TMGRPC1",648,0) new ptrParts set ptrParts=0 "RTN","TMGRPC1",649,0) set DFN=+$get(DFN) "RTN","TMGRPC1",650,0) if DFN>0 do "RTN","TMGRPC1",651,0) . set ptrParts=+$piece($get(^DPT(DFN,"NAME")),"^",1) ;"ptr to file #20, NAME COMPONENTS "RTN","TMGRPC1",652,0) . set IENS=DFN_"," "RTN","TMGRPC1",653,0) . do GETS^DIQ(2,IENS,"**","N","TMGFDA","TMGMSG") "RTN","TMGRPC1",654,0) "RTN","TMGRPC1",655,0) new line set line=0 "RTN","TMGRPC1",656,0) set RESULT(line)="IEN="_DFN set line=line+1 "RTN","TMGRPC1",657,0) set RESULT(line)="COMBINED_NAME="_$get(TMGFDA(2,IENS,.01)) set line=line+1 "RTN","TMGRPC1",658,0) new s set s="" "RTN","TMGRPC1",659,0) if ptrParts>0 set s=$get(^VA(20,ptrParts,1)) "RTN","TMGRPC1",660,0) set RESULT(line)="LNAME="_$piece(s,"^",1) set line=line+1 "RTN","TMGRPC1",661,0) set RESULT(line)="FNAME="_$piece(s,"^",2) set line=line+1 "RTN","TMGRPC1",662,0) set RESULT(line)="MNAME="_$piece(s,"^",3) set line=line+1 "RTN","TMGRPC1",663,0) set RESULT(line)="PREFIX="_$piece(s,"^",4) set line=line+1 "RTN","TMGRPC1",664,0) set RESULT(line)="SUFFIX="_$piece(s,"^",5) set line=line+1 "RTN","TMGRPC1",665,0) set RESULT(line)="DEGREE="_$piece(s,"^",5) set line=line+1 "RTN","TMGRPC1",666,0) set RESULT(line)="DOB="_$get(TMGFDA(2,IENS,.03)) set line=line+1 "RTN","TMGRPC1",667,0) set RESULT(line)="SEX="_$get(TMGFDA(2,IENS,.02)) set line=line+1 "RTN","TMGRPC1",668,0) set RESULT(line)="SS_NUM="_$get(TMGFDA(2,IENS,.09)) set line=line+1 "RTN","TMGRPC1",669,0) set RESULT(line)="ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.111)) set line=line+1 "RTN","TMGRPC1",670,0) set RESULT(line)="ADDRESS_LINE_2="_$get(TMGFDA(2,IENS,.112)) set line=line+1 "RTN","TMGRPC1",671,0) set RESULT(line)="ADDRESS_LINE_3="_$get(TMGFDA(2,IENS,.113)) set line=line+1 "RTN","TMGRPC1",672,0) set RESULT(line)="CITY="_$get(TMGFDA(2,IENS,.114)) set line=line+1 "RTN","TMGRPC1",673,0) set RESULT(line)="STATE="_$get(TMGFDA(2,IENS,.115)) set line=line+1 "RTN","TMGRPC1",674,0) if $get(TMGFDA(2,IENS,.1112))'="" do "RTN","TMGRPC1",675,0) . set RESULT(line)="ZIP4="_$get(TMGFDA(2,IENS,.1112)) set line=line+1 "RTN","TMGRPC1",676,0) else if $get(TMGFDA(2,IENS,.1116))'="" do "RTN","TMGRPC1",677,0) . set RESULT(line)="ZIP4="_$get(TMGFDA(2,IENS,.1116)) set line=line+1 "RTN","TMGRPC1",678,0) set RESULT(line)="BAD_ADDRESS="_$get(TMGFDA(2,IENS,.121)) set line=line+1 "RTN","TMGRPC1",679,0) set RESULT(line)="TEMP_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1211)) set line=line+1 "RTN","TMGRPC1",680,0) set RESULT(line)="TEMP_ADDRESS_LINE_2="_$get(TMGFDA(2,IENS,.1212)) set line=line+1 "RTN","TMGRPC1",681,0) set RESULT(line)="TEMP_ADDRESS_LINE_3="_$get(TMGFDA(2,IENS,.1213)) set line=line+1 "RTN","TMGRPC1",682,0) set RESULT(line)="TEMP_CITY="_$get(TMGFDA(2,IENS,.1214)) set line=line+1 "RTN","TMGRPC1",683,0) set RESULT(line)="TEMP_STATE="_$get(TMGFDA(2,IENS,.1215)) set line=line+1 "RTN","TMGRPC1",684,0) set RESULT(line)="TEMP_ZIP4="_$get(TMGFDA(2,IENS,.1216)) set line=line+1 "RTN","TMGRPC1",685,0) set RESULT(line)="TEMP_STARTING_DATE="_$get(TMGFDA(2,IENS,.1217)) set line=line+1 "RTN","TMGRPC1",686,0) set RESULT(line)="TEMP_ENDING_DATE="_$get(TMGFDA(2,IENS,.1218)) set line=line+1 "RTN","TMGRPC1",687,0) set RESULT(line)="TEMP_ADDRESS_ACTIVE="_$get(TMGFDA(2,IENS,.12105)) set line=line+1 "RTN","TMGRPC1",688,0) set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1411)) set line=line+1 "RTN","TMGRPC1",689,0) set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1412)) set line=line+1 "RTN","TMGRPC1",690,0) set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1413)) set line=line+1 "RTN","TMGRPC1",691,0) set RESULT(line)="CONF_CITY="_$get(TMGFDA(2,IENS,.1414)) set line=line+1 "RTN","TMGRPC1",692,0) set RESULT(line)="CONF_STATE="_$get(TMGFDA(2,IENS,.1415)) set line=line+1 "RTN","TMGRPC1",693,0) set RESULT(line)="CONF_ZIP4="_$get(TMGFDA(2,IENS,.1416)) set line=line+1 "RTN","TMGRPC1",694,0) set RESULT(line)="CONF_STARTING_DATE="_$get(TMGFDA(2,IENS,.1417)) set line=line+1 "RTN","TMGRPC1",695,0) set RESULT(line)="CONF_ENDING_DATE="_$get(TMGFDA(2,IENS,.1418)) set line=line+1 "RTN","TMGRPC1",696,0) set RESULT(line)="CONF_ADDRESS_ACTIVE="_$get(TMGFDA(2,IENS,.14105)) set line=line+1 "RTN","TMGRPC1",697,0) set RESULT(line)="PHONE_RESIDENCE="_$get(TMGFDA(2,IENS,.131)) set line=line+1 "RTN","TMGRPC1",698,0) set RESULT(line)="PHONE_WORK="_$get(TMGFDA(2,IENS,.132)) set line=line+1 "RTN","TMGRPC1",699,0) set RESULT(line)="PHONE_CELL="_$get(TMGFDA(2,IENS,.133)) set line=line+1 "RTN","TMGRPC1",700,0) set RESULT(line)="PHONE_TEMP="_$get(TMGFDA(2,IENS,.1219)) set line=line+1 "RTN","TMGRPC1",701,0) "RTN","TMGRPC1",702,0) ;"the GETS doesn't return ALIAS entries, so will do manually: "RTN","TMGRPC1",703,0) new Itr,IEN "RTN","TMGRPC1",704,0) set IEN=$$ItrInit^TMGITR(2.01,.Itr,DFN_",") "RTN","TMGRPC1",705,0) if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0) "RTN","TMGRPC1",706,0) . new s set s=$get(^DPT(DFN,.01,IEN,0)) "RTN","TMGRPC1",707,0) . if s="" quit "RTN","TMGRPC1",708,0) . set RESULT(line)="ALIAS "_IEN_" NAME="_$piece(s,"^",1) set line=line+1 "RTN","TMGRPC1",709,0) . set RESULT(line)="ALIAS "_IEN_" SSN="_$piece(s,"^",2) set line=line+1 "RTN","TMGRPC1",710,0) . ;"maybe later do something with NAME COMPONENTS in Alias. "RTN","TMGRPC1",711,0) "RTN","TMGRPC1",712,0) quit "RTN","TMGRPC1",713,0) "RTN","TMGRPC1",714,0) "RTN","TMGRPC1",715,0) STPTINFO(RESULT,DFN,INFO) ;" SET PATIENT INFO "RTN","TMGRPC1",716,0) ;"Purpose: To set demographcs details about patient "RTN","TMGRPC1",717,0) ;"Input: RESULT (this is the output array) "RTN","TMGRPC1",718,0) ;" DFN : The record number in file #2 of the patient to inquire about. "RTN","TMGRPC1",719,0) ;" INFO: Format as follows: "RTN","TMGRPC1",720,0) ;" The results are in format: INFO("KeyName")=Value, "RTN","TMGRPC1",721,0) ;" There is no set order these will appear. "RTN","TMGRPC1",722,0) ;" Here are the KeyName names that will be provided. "RTN","TMGRPC1",723,0) ;" If the record has no value, then value will be empty "RTN","TMGRPC1",724,0) ;" If a record should be deleted, its value will be @ "RTN","TMGRPC1",725,0) ;" INFO("COMBINED_NAME")= "RTN","TMGRPC1",726,0) ;" INFO("PREFIX")= "RTN","TMGRPC1",727,0) ;" INFO("SUFFIX")= "RTN","TMGRPC1",728,0) ;" INFO("DEGREE")= "RTN","TMGRPC1",729,0) ;" INFO("DOB")= "RTN","TMGRPC1",730,0) ;" INFO("SEX")= "RTN","TMGRPC1",731,0) ;" INFO("SS_NUM")= "RTN","TMGRPC1",732,0) ;" INFO("ADDRESS_LINE_1")= "RTN","TMGRPC1",733,0) ;" INFO("ADDRESS_LINE_2")= "RTN","TMGRPC1",734,0) ;" INFO("ADDRESS_LINE_3")= "RTN","TMGRPC1",735,0) ;" INFO("CITY")= "RTN","TMGRPC1",736,0) ;" INFO("STATE")= "RTN","TMGRPC1",737,0) ;" INFO("ZIP4")= "RTN","TMGRPC1",738,0) ;" INFO("BAD_ADDRESS")= "RTN","TMGRPC1",739,0) ;" INFO("TEMP_ADDRESS_LINE_1")= "RTN","TMGRPC1",740,0) ;" INFO("TEMP_ADDRESS_LINE_2")= "RTN","TMGRPC1",741,0) ;" INFO("TEMP_ADDRESS_LINE_3")= "RTN","TMGRPC1",742,0) ;" INFO("TEMP_CITY")= "RTN","TMGRPC1",743,0) ;" INFO("TEMP_STATE")= "RTN","TMGRPC1",744,0) ;" INFO("TEMP_ZIP4")= "RTN","TMGRPC1",745,0) ;" INFO("TEMP_STARTING_DATE")= "RTN","TMGRPC1",746,0) ;" INFO("TEMP_ENDING_DATE")= "RTN","TMGRPC1",747,0) ;" INFO("TEMP_ADDRESS_ACTIVE")= "RTN","TMGRPC1",748,0) ;" INFO("CONF_ADDRESS_LINE_1")= "RTN","TMGRPC1",749,0) ;" INFO("CONF_ADDRESS_LINE_2")= "RTN","TMGRPC1",750,0) ;" INFO("CONF_ADDRESS_LINE_3")= "RTN","TMGRPC1",751,0) ;" INFO("CONF_CITY")= "RTN","TMGRPC1",752,0) ;" INFO("CONF_STATE")= "RTN","TMGRPC1",753,0) ;" INFO("CONF_ZIP4")= "RTN","TMGRPC1",754,0) ;" INFO("CONF_STARTING_DATE")= "RTN","TMGRPC1",755,0) ;" INFO("CONF_ENDING_DATE")= "RTN","TMGRPC1",756,0) ;" INFO("CONF_ADDRESS_ACTIVE")= "RTN","TMGRPC1",757,0) ;" INFO("PHONE_RESIDENCE")= "RTN","TMGRPC1",758,0) ;" INFO("PHONE_WORK")= "RTN","TMGRPC1",759,0) ;" INFO("PHONE_CELL")= "RTN","TMGRPC1",760,0) ;" INFO("PHONE_TEMP")= "RTN","TMGRPC1",761,0) ;"Note, for the following, there may be multiple entries. # is record number "RTN","TMGRPC1",762,0) ;" If a record should be added, it will be marked +1, +2 etc. "RTN","TMGRPC1",763,0) ;" INFO("ALIAS # NAME")= "RTN","TMGRPC1",764,0) ;" INFO("ALIAS # SSN")= "RTN","TMGRPC1",765,0) ;" "RTN","TMGRPC1",766,0) ;"Results: Results passed back in RESULT string: "RTN","TMGRPC1",767,0) ;" 1 = success "RTN","TMGRPC1",768,0) ;" -1^Message = failure "RTN","TMGRPC1",769,0) "RTN","TMGRPC1",770,0) set RESULT=1 ;"default to success "RTN","TMGRPC1",771,0) "RTN","TMGRPC1",772,0) ;"kill ^TMG("TMP","RPC") "RTN","TMGRPC1",773,0) ;"merge ^TMG("TMP","RPC")=INFO ;"temp... remove later "RTN","TMGRPC1",774,0) "RTN","TMGRPC1",775,0) new TMGFDA,TMGMSG,IENS "RTN","TMGRPC1",776,0) set IENS=DFN_"," "RTN","TMGRPC1",777,0) new key set key="" "RTN","TMGRPC1",778,0) for set key=$order(INFO(key)) quit:(key="") do "RTN","TMGRPC1",779,0) . if key="COMBINED_NAME" set TMGFDA(2,IENS,.01)=INFO("COMBINED_NAME") "RTN","TMGRPC1",780,0) . else if key="DOB" set TMGFDA(2,IENS,.03)=INFO("DOB") "RTN","TMGRPC1",781,0) . else if key="SEX" set TMGFDA(2,IENS,.02)=INFO("SEX") "RTN","TMGRPC1",782,0) . else if key="SS_NUM" set TMGFDA(2,IENS,.09)=INFO("SS_NUM") "RTN","TMGRPC1",783,0) . else if key="ADDRESS_LINE_1" set TMGFDA(2,IENS,.111)=INFO("ADDRESS_LINE_1") "RTN","TMGRPC1",784,0) . else if key="ADDRESS_LINE_2" set TMGFDA(2,IENS,.112)=INFO("ADDRESS_LINE_2") "RTN","TMGRPC1",785,0) . else if key="ADDRESS_LINE_3" set TMGFDA(2,IENS,.113)=INFO("ADDRESS_LINE_3") "RTN","TMGRPC1",786,0) . else if key="CITY" set TMGFDA(2,IENS,.114)=INFO("CITY") "RTN","TMGRPC1",787,0) . else if key="STATE" set TMGFDA(2,IENS,.115)=INFO("STATE") "RTN","TMGRPC1",788,0) . else if key="ZIP4" set TMGFDA(2,IENS,.1122)=INFO("ZIP4") "RTN","TMGRPC1",789,0) . else if key="BAD_ADDRESS" set TMGFDA(2,IENS,.121)=INFO("BAD_ADDRESS") "RTN","TMGRPC1",790,0) . else if key="TEMP_ADDRESS_LINE_1" set TMGFDA(2,IENS,.1211)=INFO("TEMP_ADDRESS_LINE_1") "RTN","TMGRPC1",791,0) . else if key="TEMP_ADDRESS_LINE_2" set TMGFDA(2,IENS,.1212)=INFO("TEMP_ADDRESS_LINE_2") "RTN","TMGRPC1",792,0) . else if key="TEMP_ADDRESS_LINE_3" set TMGFDA(2,IENS,.1213)=INFO("TEMP_ADDRESS_LINE_3") "RTN","TMGRPC1",793,0) . else if key="TEMP_CITY" set TMGFDA(2,IENS,.1214)=INFO("TEMP_CITY") "RTN","TMGRPC1",794,0) . else if key="TEMP_STATE" set TMGFDA(2,IENS,.1215)=INFO("TEMP_STATE") "RTN","TMGRPC1",795,0) . else if key="TEMP_ZIP4" set TMGFDA(2,IENS,.1216)=INFO("TEMP_ZIP4") "RTN","TMGRPC1",796,0) . else if key="TEMP_STARTING_DATE" set TMGFDA(2,IENS,.1217)=INFO("TEMP_STARTING_DATE") "RTN","TMGRPC1",797,0) . else if key="TEMP_ENDING_DATE" set TMGFDA(2,IENS,.1218)=INFO("TEMP_ENDING_DATE") "RTN","TMGRPC1",798,0) . else if key="TEMP_ADDRESS_ACTIVE" set TMGFDA(2,IENS,.12105)=INFO("TEMP_ADDRESS_ACTIVE") "RTN","TMGRPC1",799,0) . else if key="CONF_ADDRESS_LINE_1" set TMGFDA(2,IENS,.1411)=INFO("CONF_ADDRESS_LINE_1") "RTN","TMGRPC1",800,0) . else if key="CONF_ADDRESS_LINE_2" set TMGFDA(2,IENS,.1412)=INFO("CONF_ADDRESS_LINE_2") "RTN","TMGRPC1",801,0) . else if key="CONF_ADDRESS_LINE_3" set TMGFDA(2,IENS,.1413)=INFO("CONF_ADDRESS_LINE_3") "RTN","TMGRPC1",802,0) . else if key="CONF_CITY" set TMGFDA(2,IENS,.1414)=INFO("CONF_CITY") "RTN","TMGRPC1",803,0) . else if key="CONF_STATE" set TMGFDA(2,IENS,.1415)=INFO("CONF_STATE") "RTN","TMGRPC1",804,0) . else if key="CONF_ZIP4" set TMGFDA(2,IENS,.1416)=INFO("CONF_ZIP4") "RTN","TMGRPC1",805,0) . else if key="CONF_STARTING_DATE" set TMGFDA(2,IENS,.1417)=INFO("CONF_STARTING_DATE") "RTN","TMGRPC1",806,0) . else if key="CONF_ENDING_DATE" set TMGFDA(2,IENS,.1418)=INFO("CONF_ENDING_DATE") "RTN","TMGRPC1",807,0) . else if key="CONF_ADDRESS_ACTIVE" set TMGFDA(2,IENS,.14105)=INFO("CONF_ADDRESS_ACTIVE") "RTN","TMGRPC1",808,0) . else if key="PHONE_RESIDENCE" set TMGFDA(2,IENS,.131)=INFO("PHONE_RESIDENCE") "RTN","TMGRPC1",809,0) . else if key="PHONE_WORK" set TMGFDA(2,IENS,.132)=INFO("PHONE_WORK") "RTN","TMGRPC1",810,0) . else if key="PHONE_CELL" set TMGFDA(2,IENS,.133)=INFO("PHONE_CELL") "RTN","TMGRPC1",811,0) . else if key="PHONE_TEMP" set TMGFDA(2,IENS,.1219)=INFO("PHONE_TEMP") "RTN","TMGRPC1",812,0) "RTN","TMGRPC1",813,0) if $data(TMGFDA) do "RTN","TMGRPC1",814,0) . do FILE^DIE("EKST","TMGFDA","TMGMSG") "RTN","TMGRPC1",815,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGRPC1",816,0) . . set RESULT="-1^Filing Error Occured: "_$get(TMGMSG("DIERR",1,"TEXT",1)) "RTN","TMGRPC1",817,0) . . ;"merge ^TMG("TMP","RPC","DIERR")=TMGMSG("DIERR") "RTN","TMGRPC1",818,0) . . ;"merge ^TMG("TMP","RPC","FDA")=TMGFDA "RTN","TMGRPC1",819,0) "RTN","TMGRPC1",820,0) ;"now file Alias info separately "RTN","TMGRPC1",821,0) if RESULT=1 do "RTN","TMGRPC1",822,0) . new tempArray,index,key2 "RTN","TMGRPC1",823,0) . new key set key="" "RTN","TMGRPC1",824,0) . for set key=$order(INFO(key)) quit:(key="") do "RTN","TMGRPC1",825,0) . . if key["ALIAS" do "RTN","TMGRPC1",826,0) . . . set index=$piece(key," ",2) quit:(index="") "RTN","TMGRPC1",827,0) . . . set key2=$piece(key," ",3) "RTN","TMGRPC1",828,0) . . . set tempArray(index,key2)=INFO(key) "RTN","TMGRPC1",829,0) . set index=0 for set index=$order(tempArray(index)) quit:(index="")!(RESULT'=1) do "RTN","TMGRPC1",830,0) . . new TMGFDA,TMGMSG,TMGIEN,newRec "RTN","TMGRPC1",831,0) . . set newRec=0 "RTN","TMGRPC1",832,0) . . set key="" for set key=$order(tempArray(index,key)) quit:(key="")!(RESULT'=1) do "RTN","TMGRPC1",833,0) . . . if key="NAME" set TMGFDA(2.01,index_","_DFN_",",.01)=$get(tempArray(index,"NAME")) "RTN","TMGRPC1",834,0) . . . if key="SSN" set TMGFDA(2.01,index_","_DFN_",",1)=$get(tempArray(index,"SSN")) "RTN","TMGRPC1",835,0) . . . if index["+" set newRec=1 "RTN","TMGRPC1",836,0) . . if $data(TMGFDA) do "RTN","TMGRPC1",837,0) . . . if newRec=0 do FILE^DIE("EKST","TMGFDA","TMGMSG") "RTN","TMGRPC1",838,0) . . . else do UPDATE^DIE("ES","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGRPC1",839,0) . . if $data(TMGMSG("DIERR")) do "RTN","TMGRPC1",840,0) . . . set RESULT="-1^Filing Error Occured: "_$get(TMGMSG("DIERR",1,"TEXT",1)) "RTN","TMGRPC1",841,0) . . . ;"merge ^TMG("TMP","RPC","DIERR")=TMGMSG("DIERR") "RTN","TMGRPC1",842,0) . . . ;"merge ^TMG("TMP","RPC","FDA")=TMGFDA "RTN","TMGRPC1",843,0) "RTN","TMGRPC1",844,0) quit "RTN","TMGRPC1",845,0) "RTN","TMGRPC1",846,0) PTADD(RESULT,INFO) ;" ADD PATIENT "RTN","TMGRPC1",847,0) ;"Purpose: To add a patient "RTN","TMGRPC1",848,0) ;"Input: RESULT (this is the output array) "RTN","TMGRPC1",849,0) ;" "RTN","TMGRPC1",850,0) ;" INFO: Format as follows: "RTN","TMGRPC1",851,0) ;" The results are in format: INFO("KeyName")=Value, "RTN","TMGRPC1",852,0) ;" There is no set order these will appear. "RTN","TMGRPC1",853,0) ;" Here are the KeyName names that will be provided. "RTN","TMGRPC1",854,0) ;" If the record has no value, then value will be empty "RTN","TMGRPC1",855,0) ;" If a record should be deleted, its value will be @ "RTN","TMGRPC1",856,0) ;" INFO("COMBINED_NAME")= "RTN","TMGRPC1",857,0) ;" INFO("DOB")= "RTN","TMGRPC1",858,0) ;" INFO("SEX")= "RTN","TMGRPC1",859,0) ;" INFO("SS_NUM")= "RTN","TMGRPC1",860,0) ;" INFO("Veteran")= "RTN","TMGRPC1",861,0) ;" INFO("PtType")= "RTN","TMGRPC1",862,0) ;"Results: Results passed back in RESULT string: "RTN","TMGRPC1",863,0) ;" DFN = success "RTN","TMGRPC1",864,0) ;" -1^Message = failure "RTN","TMGRPC1",865,0) ;" 0^DFN = already exists "RTN","TMGRPC1",866,0) "RTN","TMGRPC1",867,0) set RESULT=1 ;"default to success "RTN","TMGRPC1",868,0) "RTN","TMGRPC1",869,0) kill ^TMG("TMP","RPC") "RTN","TMGRPC1",870,0) merge ^TMG("TMP","RPC")=INFO ;"temp... remove later "RTN","TMGRPC1",871,0) "RTN","TMGRPC1",872,0) new TMGFDA,TMGMSG,IENS,PATIENT,DFN,TMGFREG "RTN","TMGRPC1",873,0) ;" set IENS=DFN_"," "RTN","TMGRPC1",874,0) new key set key="" "RTN","TMGRPC1",875,0) for set key=$order(INFO(key)) quit:(key="") do "RTN","TMGRPC1",876,0) . if key="COMBINED_NAME" set PATIENT("NAME")=INFO("COMBINED_NAME") "RTN","TMGRPC1",877,0) . else if key="DOB" set PATIENT("DOB")=INFO("DOB") "RTN","TMGRPC1",878,0) . else if key="SEX" set PATIENT("SEX")=INFO("SEX") "RTN","TMGRPC1",879,0) . else if key="SS_NUM" set PATIENT("SSNUM")=INFO("SS_NUM") "RTN","TMGRPC1",880,0) . else if key="Veteran" set PATIENT("VETERAN")=INFO("Veteran") "RTN","TMGRPC1",881,0) . else if key="PtType" set PATIENT("PT_TYPE")=INFO("PtType") "RTN","TMGRPC1",882,0) set DFN=$$GetDFN^TMGGDFN(.PATIENT) "RTN","TMGRPC1",883,0) if DFN=-1 do "RTN","TMGRPC1",884,0) . new Entry,result,ErrMsg "RTN","TMGRPC1",885,0) . do Pat2Entry^TMGGDFN(.PATIENT,.Entry) "RTN","TMGRPC1",886,0) . set DFN=$$AddNewPt^TMGGDFN(.Entry,.ErrMsg) "RTN","TMGRPC1",887,0) . ;"set DFN=$$GetDFN^TMGGDFN(.PATIENT) "RTN","TMGRPC1",888,0) . if DFN'>0 do "RTN","TMGRPC1",889,0) . . set RESULT="-1^ERROR ADDING" ;"should use ErrMsg from above. Fix later "RTN","TMGRPC1",890,0) . . set RESULT=RESULT_". "_$$GetErrStr^TMGDEBUG(.ErrMsg) "RTN","TMGRPC1",891,0) . else do "RTN","TMGRPC1",892,0) .. set RESULT=DFN "RTN","TMGRPC1",893,0) else do "RTN","TMGRPC1",894,0) . set RESULT="0^"_DFN "RTN","TMGRPC1",895,0) "RTN","TMGRPC1",896,0) quit "RTN","TMGRPC1",897,0) "RTN","TMGRPC1",898,0) "RTN","TMGRPC1",899,0) GETBARCD(GREF,MESSAGE,OPTION) "RTN","TMGRPC1",900,0) ;"SCOPE: Public "RTN","TMGRPC1",901,0) ;"RPC that calls this: TMG BARCODE ENCODE "RTN","TMGRPC1",902,0) ;"Purpose: To provide an entry point for a RPC call from a client. "RTN","TMGRPC1",903,0) ;" A 2D DataMatrix Bar Code will be create and passed to client. "RTN","TMGRPC1",904,0) ;" It will not be stored on server "RTN","TMGRPC1",905,0) ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) "RTN","TMGRPC1",906,0) ;" MESSAGE-- The text to use to create the barcode "RTN","TMGRPC1",907,0) ;" OPTION -- Array that may hold optional settings, as follows: "RTN","TMGRPC1",908,0) ;" OPTION("IMAGE TYPE")="jpg" <-- if not specified, then default is "png" "RTN","TMGRPC1",909,0) ;"Output: results are passed out in @GREF "RTN","TMGRPC1",910,0) ;" @GREF@(0)=success; 1=success, 0=failure "RTN","TMGRPC1",911,0) ;" @GREF@(1..xxx) = actual data "RTN","TMGRPC1",912,0) "RTN","TMGRPC1",913,0) ;"NOTE: dmtxread must be installed on linux host. "RTN","TMGRPC1",914,0) ;" I found source code here: "RTN","TMGRPC1",915,0) ;" http://sourceforge.net/projects/libdmtx/ "RTN","TMGRPC1",916,0) ;" After installing (./configure --> make --> make install), I "RTN","TMGRPC1",917,0) ;" copied dmtxread and dmtxwrite, which were found in the "RTN","TMGRPC1",918,0) ;" (installdir)/util/dmtxread/.libs and (installdir)/util/dmtxwrite/.libs "RTN","TMGRPC1",919,0) ;" folders, into a folder on the system path. I chose /usr/bin/ "RTN","TMGRPC1",920,0) ;" Also, to achieve compile of above, I had to install required libs. "RTN","TMGRPC1",921,0) ;" See notes included with dmtx source code. "RTN","TMGRPC1",922,0) "RTN","TMGRPC1",923,0) new FileSpec "RTN","TMGRPC1",924,0) new file "RTN","TMGRPC1",925,0) new FName,FPath "RTN","TMGRPC1",926,0) "RTN","TMGRPC1",927,0) set GREF="^TMP(""GETBARCD^TMGRPC1"","_$J_")" "RTN","TMGRPC1",928,0) kill @GREF "RTN","TMGRPC1",929,0) set @GREF@(0)="" ;"default to failure "RTN","TMGRPC1",930,0) set MESSAGE=$get(MESSAGE) "RTN","TMGRPC1",931,0) if MESSAGE="" goto GBCDone "RTN","TMGRPC1",932,0) "RTN","TMGRPC1",933,0) ;"Create the barcode and get file name and path "RTN","TMGRPC1",934,0) set file=$$MAKEBC^TMGBARC(MESSAGE,.OPTION) "RTN","TMGRPC1",935,0) do SplitFNamePath^TMGIOUTL(file,.FPath,.FName,"/") "RTN","TMGRPC1",936,0) "RTN","TMGRPC1",937,0) ;"Load binary image into global array "RTN","TMGRPC1",938,0) set @GREF@(0)=$$BFTG^TMGBINF(.FPath,.FName,$name(@GREF@(1)),3) "RTN","TMGRPC1",939,0) "RTN","TMGRPC1",940,0) ;"convert binary data to ascii encoded data "RTN","TMGRPC1",941,0) do ENCODE($name(@GREF@(1)),3) "RTN","TMGRPC1",942,0) "RTN","TMGRPC1",943,0) ;"delete temp image file "RTN","TMGRPC1",944,0) do SplitFNamePath^TMGIOUTL(file,.FPath,.FName,"/") "RTN","TMGRPC1",945,0) set FileSpec(FName)="" "RTN","TMGRPC1",946,0) new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") "RTN","TMGRPC1",947,0) "RTN","TMGRPC1",948,0) GBCDone "RTN","TMGRPC1",949,0) quit "RTN","TMGRPC1",950,0) "RTN","TMGRPC1",951,0) "RTN","TMGRPC1",952,0) DECODEBC(RESULT,ARRAY,IMGTYPE) "RTN","TMGRPC1",953,0) ;"SCOPE: Public "RTN","TMGRPC1",954,0) ;"RPC that calls this: TMG BARCODE DECODE "RTN","TMGRPC1",955,0) ;"Purpose: To provide an entry point for a RPC call from a client. The client "RTN","TMGRPC1",956,0) ;" will upload an image file (.png format only) of a barcode (Datamatrix "RTN","TMGRPC1",957,0) ;" format) for decoding. Decoded message is passed back. "RTN","TMGRPC1",958,0) ;"Input: RESULT -- an OUT PARAMETER. See output below. "RTN","TMGRPC1",959,0) ;" ARRAY -- the array that will hold the image file, in BASE64 ascii encoding "RTN","TMGRPC1",960,0) ;" IMGTYPE -- Image type, e.g. "jpg" (Note: don't include any '.') "RTN","TMGRPC1",961,0) ;"Output: results are passed out in RESULT: 1^Decoded Message or 0^FailureMessage "RTN","TMGRPC1",962,0) "RTN","TMGRPC1",963,0) ;"NOTE: dmtxread must be installed on linux host. "RTN","TMGRPC1",964,0) ;" I found source code here: "RTN","TMGRPC1",965,0) ;" http://sourceforge.net/projects/libdmtx/ "RTN","TMGRPC1",966,0) ;" After installing (./configure --> make --> make install), I "RTN","TMGRPC1",967,0) ;" copied dmtxread and dmtxwrite, which were found in the "RTN","TMGRPC1",968,0) ;" (installdir)/util/dmtxread/.libs and (installdir)/util/dmtxwrite/.libs "RTN","TMGRPC1",969,0) ;" folders, into a folder on the system path. I chose /usr/bin/ "RTN","TMGRPC1",970,0) ;" Also, to achieve compile of above, I had to install required libs. "RTN","TMGRPC1",971,0) ;" See notes included with dmtx source code. "RTN","TMGRPC1",972,0) ;"NOTE: if image types other than .png will be uploaded, then the linux host "RTN","TMGRPC1",973,0) ;" must have ImageMagick utility 'convert' installed for conversion "RTN","TMGRPC1",974,0) ;" between image types. "RTN","TMGRPC1",975,0) "RTN","TMGRPC1",976,0) kill ^TMG("TMP","BARCODE") "RTN","TMGRPC1",977,0) ;"set ^TMG("TMP","BARCODE","LOG")=1 ;"temp "RTN","TMGRPC1",978,0) "RTN","TMGRPC1",979,0) ;"new Stack do GetStackInfo^TMGIDE2(.Stack) "RTN","TMGRPC1",980,0) ;"merge ^TMG("TMP","BARCODE","STACK")=Stack "RTN","TMGRPC1",981,0) "RTN","TMGRPC1",982,0) new resultMsg "RTN","TMGRPC1",983,0) if $data(ARRAY)=0 set resultMsg="0^No image data received to decode" goto DBCDone "RTN","TMGRPC1",984,0) "RTN","TMGRPC1",985,0) new imageType set imageType=$$LOW^XLFSTR($get(IMGTYPE)) "RTN","TMGRPC1",986,0) if imageType="" set resultMsg="0^Image type not specified" goto DBCDone "RTN","TMGRPC1",987,0) "RTN","TMGRPC1",988,0) new imageFName set imageFName="/tmp/barcode."_imageType "RTN","TMGRPC1",989,0) set imageFName=$$UNIQUE^%ZISUTL(imageFName) "RTN","TMGRPC1",990,0) new FName,FPath,FileSpec "RTN","TMGRPC1",991,0) do SplitFNamePath^TMGIOUTL(imageFName,.FPath,.FName,"/") "RTN","TMGRPC1",992,0) set FileSpec(FName)="" "RTN","TMGRPC1",993,0) "RTN","TMGRPC1",994,0) ;"temp... "RTN","TMGRPC1",995,0) ;"merge ^TMG("TMP","BARCODE","DATA")=ARRAY "RTN","TMGRPC1",996,0) ;"merge ^TMG("TMP","BARCODE","IMGTYPE")=IMGTYPE "RTN","TMGRPC1",997,0) "RTN","TMGRPC1",998,0) ;"set ^TMG("TMP","BARCODE","LOG")=2 ;"temp "RTN","TMGRPC1",999,0) ;"Remove BASE64 ascii encoding "RTN","TMGRPC1",1000,0) do DECODE("ARRAY(0)",1) "RTN","TMGRPC1",1001,0) "RTN","TMGRPC1",1002,0) ;"set ^TMG("TMP","BARCODE","LOG")=3 ;"temp "RTN","TMGRPC1",1003,0) ;"set ^TMG("TMP","BARCODE","LOG","Orig file: "_FPath_FName)="" "RTN","TMGRPC1",1004,0) "RTN","TMGRPC1",1005,0) ;"Save to host file system "RTN","TMGRPC1",1006,0) if $$GTBF^TMGBINF("ARRAY(0)",1,FPath,FName)=0 do goto DBCDone "RTN","TMGRPC1",1007,0) . set resultMsg="0^Error while saving file to HFS" "RTN","TMGRPC1",1008,0) "RTN","TMGRPC1",1009,0) ;"set ^TMG("TMP","BARCODE","LOG")=4 ;"temp "RTN","TMGRPC1",1010,0) "RTN","TMGRPC1",1011,0) ;"convert image file to .png format, if needed "RTN","TMGRPC1",1012,0) if imageType'="png" do "RTN","TMGRPC1",1013,0) . set imageFName=$$Convert^TMGKERNL(imageFName,"png") "RTN","TMGRPC1",1014,0) . if imageFName="" do quit "RTN","TMGRPC1",1015,0) . . set resultMsg="0^Error while converting image from ."_imageType_" to .png format." "RTN","TMGRPC1",1016,0) . do SplitFNamePath^TMGIOUTL(imageFName,.FPath,.FName,"/") "RTN","TMGRPC1",1017,0) . set FileSpec(FName)="" "RTN","TMGRPC1",1018,0) if imageFName="" goto DBCDone "RTN","TMGRPC1",1019,0) "RTN","TMGRPC1",1020,0) ;"set ^TMG("TMP","BARCODE","LOG")=5 ;"temp "RTN","TMGRPC1",1021,0) "RTN","TMGRPC1",1022,0) ;"Decode the barcode.png image "RTN","TMGRPC1",1023,0) new result set result=$$READBC^TMGBARC(imageFName) "RTN","TMGRPC1",1024,0) if result'="" set resultMsg="1^"_result "RTN","TMGRPC1",1025,0) else set resultMsg="0^Unable to Decode Image" "RTN","TMGRPC1",1026,0) "RTN","TMGRPC1",1027,0) ;"delete temp image file "RTN","TMGRPC1",1028,0) ;"temp REMOVE COMMENTS LATER TO DELETE FILE. !!!!! "RTN","TMGRPC1",1029,0) ;"set result=$$DEL^%ZISH(FPath,"FileSpec") "RTN","TMGRPC1",1030,0) "RTN","TMGRPC1",1031,0) DBCDone "RTN","TMGRPC1",1032,0) ;"set ^TMG("TMP","BARCODE","LOG")=6 ;"temp "RTN","TMGRPC1",1033,0) "RTN","TMGRPC1",1034,0) set RESULT=resultMsg "RTN","TMGRPC1",1035,0) quit "RTN","TMGRPC1",1036,0) "RTN","TMGRPC1",1037,0) ;"-------------------- "RTN","TMGRPC1",1038,0) GETURLS(RESULT) "RTN","TMGRPC1",1039,0) ;"SCOPE: Public "RTN","TMGRPC1",1040,0) ;"RPC that calls this: TMG CPRS GET URL LIST "RTN","TMGRPC1",1041,0) ;"Purpose: To provide an entry point for a RPC call from a client. The client "RTN","TMGRPC1",1042,0) ;" will request URLs to display in custom tabs inside CPRS, in an "RTN","TMGRPC1",1043,0) ;" imbedded web browser "RTN","TMGRPC1",1044,0) ;"Input: RESULT -- an OUT PARAMETER. See output below. "RTN","TMGRPC1",1045,0) ;"Output: results are passed out in RESULT: "RTN","TMGRPC1",1046,0) ;" RESULT(0)="1^Success" or "0^SomeFailureMessage" "RTN","TMGRPC1",1047,0) ;" RESULT(1)="Name1^URL#1" ; shows URL#1 in tab #1, named 'Name1' "RTN","TMGRPC1",1048,0) ;" RESULT(2)="Name2^URL#2" ; etc. "RTN","TMGRPC1",1049,0) ;" RESULT(3)="Name3^URL#3" "RTN","TMGRPC1",1050,0) ;" "RTN","TMGRPC1",1051,0) ;" E.g. RESULT(1)="cnn^www.cnn.com" "RTN","TMGRPC1",1052,0) ;" RESULT(2)="INFO^192.168.0.1/home.html" "RTN","TMGRPC1",1053,0) ;" "RTN","TMGRPC1",1054,0) ;" The number of allowed tabs is determined by code in CPRS "RTN","TMGRPC1",1055,0) ;" Reference to tab numbers > specified in CPRS will be ignored by CPRS "RTN","TMGRPC1",1056,0) ;" If a web tab is NOT specified, then the page previously "RTN","TMGRPC1",1057,0) ;" displayed will be left in place. It will not be cleared. "RTN","TMGRPC1",1058,0) ;" To clear a given page, a url of "about:blank" will cause a "RTN","TMGRPC1",1059,0) ;" blank page to be displayed. e.g. "RTN","TMGRPC1",1060,0) ;" RESULT(3)="^about:blank" "RTN","TMGRPC1",1061,0) ;" To HIDE a tab on CPRS use this: "RTN","TMGRPC1",1062,0) ;" RESULT(3)="" ;triggers tab #3 to be hidden "RTN","TMGRPC1",1063,0) "RTN","TMGRPC1",1064,0) ;"Notice to others: Below is where code should be added to return "RTN","TMGRPC1",1065,0) ;" proper URL's to CPRS. This will be called whenever a new patient "RTN","TMGRPC1",1066,0) ;" is opened, or a Refresh Information is requested. "RTN","TMGRPC1",1067,0) ;" FYI, 'DFN' should be defined as a globally-scoped variable that can be used "RTN","TMGRPC1",1068,0) ;" to pass back URLS specific for a given patient. "RTN","TMGRPC1",1069,0) "RTN","TMGRPC1",1070,0) set RESULT(0)="1^Success" "RTN","TMGRPC1",1071,0) set RESULT(1)="Yahoo^www.yahoo.com" "RTN","TMGRPC1",1072,0) set RESULT(2)="(x)^about:blank" "RTN","TMGRPC1",1073,0) set RESULT(3)="^" "RTN","TMGRPC1",1074,0) "RTN","TMGRPC1",1075,0) ;"kill RESULT "RTN","TMGRPC1",1076,0) ;"merge RESULT=^TMG("TMP","URLS") ;"TEMP!!! "RTN","TMGRPC1",1077,0) "RTN","TMGRPC1",1078,0) quit "RTN","TMGSELED") 0^73^B10024 "RTN","TMGSELED",1,0) TMGSELED ;TMG/kst/Group record selected editer ;03/25/06 "RTN","TMGSELED",2,0) ;;1.0;TMG-LIB;**1**;01/25/07 "RTN","TMGSELED",3,0) "RTN","TMGSELED",4,0) ;"TMG -- Group record selected editer "RTN","TMGSELED",5,0) ;"Kevin Toppenberg MD "RTN","TMGSELED",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGSELED",7,0) ;"1-25-2007 "RTN","TMGSELED",8,0) "RTN","TMGSELED",9,0) ;"======================================================================= "RTN","TMGSELED",10,0) ;" API -- Public Functions. "RTN","TMGSELED",11,0) ;"======================================================================= "RTN","TMGSELED",12,0) ;"ASKSELED -- A record group selecter/editor, with asking user for options "RTN","TMGSELED",13,0) ;"ASK1ED -- A record editor "RTN","TMGSELED",14,0) ;"$$SELED(Options) -- entry point for group selecting and editing of records "RTN","TMGSELED",15,0) ;" Options -- PASS BY REFERENCE. Format: "RTN","TMGSELED",16,0) ;" Options("FILE")=Filenumber^FileName "RTN","TMGSELED",17,0) ;" Options("FIELDS","MAX NUM")=MaxDisplaySequenceNumber "RTN","TMGSELED",18,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",19,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",20,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",21,0) ;" Options("IEN LIST",IEN in FILE)="" "RTN","TMGSELED",22,0) ;" Options("IEN LIST",IEN in FILE)="" "RTN","TMGSELED",23,0) ;" Options("IEN LIST",IEN in FILE,"SEL")="" ;"<-- Optional. Makes preselected "RTN","TMGSELED",24,0) ;" Note: alternative Format "RTN","TMGSELED",25,0) ;" Options("FIELDS",DisplaySequence)=FldNum:FldNum2:FldNum3^Width "RTN","TMGSELED",26,0) ;" FldNum:FldNum2:FldNum3 means FldNum is ptr to file2, and "RTN","TMGSELED",27,0) ;" FldNum2 is in file2. This value is a pointer to file3, and "RTN","TMGSELED",28,0) ;" FldNum3 is a value in file3 "RTN","TMGSELED",29,0) ;" "RTN","TMGSELED",30,0) ;"$$EditRecs(pList,Options,LookupFn) -- get new values for fields in records "RTN","TMGSELED",31,0) ;"$$GetFields(Options) -- Interact with user to choose fields, and their display widths "RTN","TMGSELED",32,0) "RTN","TMGSELED",33,0) ;"======================================================================= "RTN","TMGSELED",34,0) ;" Private Functions. "RTN","TMGSELED",35,0) ;"======================================================================= "RTN","TMGSELED",36,0) ;"GetIENs(Options) -- Interact with user to choose IENs to be edited "RTN","TMGSELED",37,0) "RTN","TMGSELED",38,0) ;"GetFldVScreen(File,FieldNum,ScrnCode,pResults,Flags) -- get List of IENs in File matching ScreenCode "RTN","TMGSELED",39,0) ;"GetFldValue(File,FieldNum,Value,pResults) --get List of IENs in File with missing Field "RTN","TMGSELED",40,0) ;"FixValue(pList,FileNum,FieldNum) -- Ask user for a valid value & apply to all entries in pList "RTN","TMGSELED",41,0) "RTN","TMGSELED",42,0) "RTN","TMGSELED",43,0) "RTN","TMGSELED",44,0) ASKSELED "RTN","TMGSELED",45,0) ;"Scope: PUBLIC "RTN","TMGSELED",46,0) ;"Purpose: A record group selecter/editor "RTN","TMGSELED",47,0) ;"Input: None "RTN","TMGSELED",48,0) ;"Output: Data in database may be edited. "RTN","TMGSELED",49,0) ;"Results: none "RTN","TMGSELED",50,0) "RTN","TMGSELED",51,0) write !,"Group Select-and-Edit Routine",! "RTN","TMGSELED",52,0) write "-------------------------------",! "RTN","TMGSELED",53,0) write "Here are the steps we will go through . . .",! "RTN","TMGSELED",54,0) write "Step #1. Pick FILE to browse",! "RTN","TMGSELED",55,0) write "Step #2. Pick FIELDS to show when browsing",! "RTN","TMGSELED",56,0) write "Step #3. Pick Records to browse from",! "RTN","TMGSELED",57,0) write "Step #4. Select sepecific Records to edit",! "RTN","TMGSELED",58,0) write "Step #5. Edit values in selected records",! "RTN","TMGSELED",59,0) write "Loop back to Step #4",! "RTN","TMGSELED",60,0) "RTN","TMGSELED",61,0) new DIC,X,Y "RTN","TMGSELED",62,0) new FileNum,IEN "RTN","TMGSELED",63,0) new UseDefault set UseDefault=1 "RTN","TMGSELED",64,0) "RTN","TMGSELED",65,0) ;"Pick file to edit from "RTN","TMGSELED",66,0) ASK1 set DIC=1 "RTN","TMGSELED",67,0) set DIC(0)="AEQM" "RTN","TMGSELED",68,0) if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called "RTN","TMGSELED",69,0) . do ^DICRW ;" ^DICRW has default value of user's last response "RTN","TMGSELED",70,0) else do ^DIC ;"^DIC doesn't use a default value... "RTN","TMGSELED",71,0) write ! "RTN","TMGSELED",72,0) if +Y'>0 write ! goto ASKDone "RTN","TMGSELED",73,0) "RTN","TMGSELED",74,0) new Options "RTN","TMGSELED",75,0) set Options("FILE")=Y "RTN","TMGSELED",76,0) if $$GetFields(.Options)=0 goto ASKDone "RTN","TMGSELED",77,0) if $$GetWidths(.Options)=0 goto ASKDone "RTN","TMGSELED",78,0) "RTN","TMGSELED",79,0) ASK2 if $$GetIENs(.Options)=0 goto ASKDone "RTN","TMGSELED",80,0) "RTN","TMGSELED",81,0) if $$SELED(.Options)=2 goto ASK2 "RTN","TMGSELED",82,0) "RTN","TMGSELED",83,0) ASKDone "RTN","TMGSELED",84,0) quit "RTN","TMGSELED",85,0) "RTN","TMGSELED",86,0) "RTN","TMGSELED",87,0) ASK1ED "RTN","TMGSELED",88,0) ;"Scope: PUBLIC "RTN","TMGSELED",89,0) ;"Purpose: A record editor "RTN","TMGSELED",90,0) ;"Input: None "RTN","TMGSELED",91,0) ;"Output: Data in database may be edited. "RTN","TMGSELED",92,0) ;"Results: none "RTN","TMGSELED",93,0) "RTN","TMGSELED",94,0) new DIC,X,Y "RTN","TMGSELED",95,0) new FileNum,IEN "RTN","TMGSELED",96,0) new UseDefault set UseDefault=0 "RTN","TMGSELED",97,0) "RTN","TMGSELED",98,0) ;"Pick file to edit from "RTN","TMGSELED",99,0) AK1 kill DIC "RTN","TMGSELED",100,0) set DIC=1 "RTN","TMGSELED",101,0) set DIC(0)="AEQM" "RTN","TMGSELED",102,0) set DIC("A")="Enter Name of File Containing Record to Edit: ^// " "RTN","TMGSELED",103,0) if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called "RTN","TMGSELED",104,0) . do ^DICRW ;" ^DICRW has default value of user's last response "RTN","TMGSELED",105,0) else do ^DIC ;"^DIC doesn't use a default value... "RTN","TMGSELED",106,0) write ! "RTN","TMGSELED",107,0) if +Y'>0 write ! goto AKDone "RTN","TMGSELED",108,0) "RTN","TMGSELED",109,0) new Options "RTN","TMGSELED",110,0) set Options("FILE")=Y "RTN","TMGSELED",111,0) if $$GetFields(.Options)=0 goto AKDone "RTN","TMGSELED",112,0) "RTN","TMGSELED",113,0) AK2 kill DIC "RTN","TMGSELED",114,0) set DIC("A")="Enter Record in "_$piece(Y,"^",2)_" to Edit: ^// " "RTN","TMGSELED",115,0) set DIC=+Y "RTN","TMGSELED",116,0) set DIC(0)="AEQM" "RTN","TMGSELED",117,0) do ^DIC "RTN","TMGSELED",118,0) if Y=-1 goto AK1 "RTN","TMGSELED",119,0) new list set list(+Y)="" "RTN","TMGSELED",120,0) if $$EditRecs("list",.Options)=1 goto AK2 "RTN","TMGSELED",121,0) "RTN","TMGSELED",122,0) AKDone "RTN","TMGSELED",123,0) quit "RTN","TMGSELED",124,0) "RTN","TMGSELED",125,0) "RTN","TMGSELED",126,0) GetFields(Options) "RTN","TMGSELED",127,0) ;"Purpose: Interact with user to choose fields, and their display widths "RTN","TMGSELED",128,0) ;"Input: Options -- PASS BY REFERENCE, (used for input and as OUT PARAMETER) "RTN","TMGSELED",129,0) ;" Note: prior entries are NOT KILLED "RTN","TMGSELED",130,0) ;" Options("FILE")=Filenumber^FileName "RTN","TMGSELED",131,0) ;" Options("FILE")=Filenumber <---- FileName will be filled in. "RTN","TMGSELED",132,0) ;"Output: Options is filled as follows: "RTN","TMGSELED",133,0) ;" Options("FILE")=Filenumber^FileName <-- left in from input "RTN","TMGSELED",134,0) ;" Options("FIELDS","MAX NUM")=MaxDisplaySequenceNumber "RTN","TMGSELED",135,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",136,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",137,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",138,0) ;"Results: 1=OK To continue, 0=abort "RTN","TMGSELED",139,0) "RTN","TMGSELED",140,0) new result set result=1 "RTN","TMGSELED",141,0) new DIC,X,Y "RTN","TMGSELED",142,0) new SeqNum set SeqNum=1 "RTN","TMGSELED",143,0) new Field "RTN","TMGSELED",144,0) "RTN","TMGSELED",145,0) new FName set FName=$piece($get(Options("FILE")),"^",2) "RTN","TMGSELED",146,0) new FileNum set FileNum=+$get(Options("FILE")) "RTN","TMGSELED",147,0) if FileNum=0 set result=0 goto GFDone "RTN","TMGSELED",148,0) if FName="" do "RTN","TMGSELED",149,0) . set FName=$$GetFName^TMGDBAPI(FileNum) "RTN","TMGSELED",150,0) . set $piece(Options("FILE"),"^",2)=FName "RTN","TMGSELED",151,0) set DIC="^DD("_FileNum_"," "RTN","TMGSELED",152,0) set DIC(0)="MEQ" "RTN","TMGSELED",153,0) GFLoop "RTN","TMGSELED",154,0) write "Enter " "RTN","TMGSELED",155,0) if SeqNum=1 write "first " "RTN","TMGSELED",156,0) else write "next " "RTN","TMGSELED",157,0) write "field to display/edit (^ to abort): " "RTN","TMGSELED",158,0) read Field:$get(DTIME,3600) "RTN","TMGSELED",159,0) if Field="^" set result=0 goto GFDone "RTN","TMGSELED",160,0) if Field="" goto GFDone "RTN","TMGSELED",161,0) if Field[":" do "RTN","TMGSELED",162,0) . new i,CurFile,abort "RTN","TMGSELED",163,0) . new NewField set NewField="" "RTN","TMGSELED",164,0) . new NewFldNames set NewFldNames="" "RTN","TMGSELED",165,0) . set CurFile=FileNum,abort=0 "RTN","TMGSELED",166,0) . for i=1:1:$length(Field,":") do quit:(abort=1) "RTN","TMGSELED",167,0) . . new fld,DIC,X,Y "RTN","TMGSELED",168,0) . . set fld=$piece(Field,":",i) "RTN","TMGSELED",169,0) . . set DIC="^DD("_CurFile_"," "RTN","TMGSELED",170,0) . . set DIC(0)="MEQ" "RTN","TMGSELED",171,0) . . set X=fld "RTN","TMGSELED",172,0) . . do ^DIC "RTN","TMGSELED",173,0) . . if Y=-1 set abort=1 quit "RTN","TMGSELED",174,0) . . if NewField'="" set NewField=NewField_":" "RTN","TMGSELED",175,0) . . if NewFldNames'="" set NewFldNames=NewFldNames_":" "RTN","TMGSELED",176,0) . . set NewField=NewField_+Y "RTN","TMGSELED",177,0) . . set NewFldNames=NewFldNames_$piece(Y,"^",2) "RTN","TMGSELED",178,0) . . new FldInfo set FldInfo=$piece($get(^DD(CurFile,+Y,0)),"^",2) "RTN","TMGSELED",179,0) . . if FldInfo["P" do "RTN","TMGSELED",180,0) . . . set CurFile=+$piece(FldInfo,"P",2) "RTN","TMGSELED",181,0) . . . write "->" "RTN","TMGSELED",182,0) . set Field=NewField_"^"_NewFldNames "RTN","TMGSELED",183,0) . if Field="^" set Field="" "RTN","TMGSELED",184,0) . write ! "RTN","TMGSELED",185,0) else do "RTN","TMGSELED",186,0) . set X=Field "RTN","TMGSELED",187,0) . do ^DIC write ! "RTN","TMGSELED",188,0) . if +Y>0 set Field=Y "RTN","TMGSELED",189,0) . ;"NOTE: I need to ask for subfield if PTR to another file. "RTN","TMGSELED",190,0) . else do "RTN","TMGSELED",191,0) . . ;"if Field'["?" write "??",! "RTN","TMGSELED",192,0) . . set Field="" "RTN","TMGSELED",193,0) if Field="" goto GFLoop "RTN","TMGSELED",194,0) set Options("FIELDS",SeqNum)=Field "RTN","TMGSELED",195,0) set Options("FIELDS","MAX NUM")=SeqNum "RTN","TMGSELED",196,0) new % set %=2 "RTN","TMGSELED",197,0) write " DISPLAY only (i.e. don't allow edit)" do YN^DICN write ! "RTN","TMGSELED",198,0) if %=1 set Options("FIELDS",SeqNum,"NO EDIT")=1 "RTN","TMGSELED",199,0) if %=-1 goto GFDone "RTN","TMGSELED",200,0) set SeqNum=SeqNum+1 "RTN","TMGSELED",201,0) goto GFLoop "RTN","TMGSELED",202,0) "RTN","TMGSELED",203,0) GFDone "RTN","TMGSELED",204,0) write ! "RTN","TMGSELED",205,0) quit result "RTN","TMGSELED",206,0) "RTN","TMGSELED",207,0) "RTN","TMGSELED",208,0) GetWidths(Options) "RTN","TMGSELED",209,0) ;"Purpose: Interact with user to choose adjust widths of displayed fields "RTN","TMGSELED",210,0) ;"Input: Options -- PASS BY REFERENCE, (used for input and as OUT PARAMETER) "RTN","TMGSELED",211,0) ;" Note: prior entries are NOT KILLED "RTN","TMGSELED",212,0) ;" Options("FILE")=Filenumber^FileName "RTN","TMGSELED",213,0) ;" Options("FIELDS","MAX NUM")=MaxDisplaySequenceNumber "RTN","TMGSELED",214,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName "RTN","TMGSELED",215,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName "RTN","TMGSELED",216,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName "RTN","TMGSELED",217,0) ;"Output: Options is filled as follows: "RTN","TMGSELED",218,0) ;" Options("FILE")=Filenumber^FileName <-- left in from input "RTN","TMGSELED",219,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",220,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",221,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",222,0) ;"Results: 1=OK To continue, 0=abort "RTN","TMGSELED",223,0) "RTN","TMGSELED",224,0) ;"Note: Later I could rewrite this function to allow a more graphical "RTN","TMGSELED",225,0) ;" resizing of the fields, by displaying the line with one field "RTN","TMGSELED",226,0) ;" in reverse colors, indicating that it has been selected. Then "RTN","TMGSELED",227,0) ;" left-right would adjust size, and TAB would rotate to next field. "RTN","TMGSELED",228,0) "RTN","TMGSELED",229,0) new result set result=1 "RTN","TMGSELED",230,0) new LMargin set LMargin=6 "RTN","TMGSELED",231,0) new TMGMINW set TMGMINW=3 "RTN","TMGSELED",232,0) new FldCount set FldCount=$get(Options("FIELDS","MAX NUM"),0) "RTN","TMGSELED",233,0) if FldCount=0 set result=0 goto GWDone "RTN","TMGSELED",234,0) new ScrnWidth set ScrnWidth=$get(IOM,80)-LMargin-1 ;"leave room for selector numbers "RTN","TMGSELED",235,0) new tempW set tempW=ScrnWidth\FldCount "RTN","TMGSELED",236,0) "RTN","TMGSELED",237,0) ;"Set default values "RTN","TMGSELED",238,0) new i for i=1:1:FldCount set $piece(Options("FIELDS",i),"^",3)=tempW "RTN","TMGSELED",239,0) "RTN","TMGSELED",240,0) write !,$$GetDispStr(.Options),! "RTN","TMGSELED",241,0) "RTN","TMGSELED",242,0) new %,i,Num,TMGW,Delta,MinW,TMGMAXW "RTN","TMGSELED",243,0) new SufferCol,SufferW "RTN","TMGSELED",244,0) new Menu,UsrSlct,MenuCount,MenuDflt "RTN","TMGSELED",245,0) set MenuCount=1 "RTN","TMGSELED",246,0) set MenuDflt=1 "RTN","TMGSELED",247,0) new DIR,FldName "RTN","TMGSELED",248,0) "RTN","TMGSELED",249,0) set Menu(0)="Pick Option" "RTN","TMGSELED",250,0) for i=1:1:FldCount do "RTN","TMGSELED",251,0) . set Menu(MenuCount)="Adjust ["_$piece(Options("FIELDS",i),"^",2)_"]"_$char(9)_i "RTN","TMGSELED",252,0) . set MenuCount=MenuCount+1 "RTN","TMGSELED",253,0) set Menu(MenuCount)="Enter ^ to abort"_$char(9)_"^" "RTN","TMGSELED",254,0) "RTN","TMGSELED",255,0) GWLoop "RTN","TMGSELED",256,0) set %=2 ;"default to 'NO' the first time into loop. "RTN","TMGSELED",257,0) write "Adjust column widths" "RTN","TMGSELED",258,0) do YN^DICN write ! "RTN","TMGSELED",259,0) if %=2 goto GWDone "RTN","TMGSELED",260,0) "RTN","TMGSELED",261,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,MenuDflt,.MenuDflt) "RTN","TMGSELED",262,0) if (UsrSlct="^")!(UsrSlct="") goto GWDone "RTN","TMGSELED",263,0) "RTN","TMGSELED",264,0) set Num=+UsrSlct "RTN","TMGSELED",265,0) set TMGW=$piece($get(Options("FIELDS",Num)),"^",3) "RTN","TMGSELED",266,0) set FldName=$piece($get(Options("FIELDS",Num)),"^",2) "RTN","TMGSELED",267,0) "RTN","TMGSELED",268,0) ;"Determine which column will have compensatory changes as Column is changed "RTN","TMGSELED",269,0) set SufferCol=FldCount "RTN","TMGSELED",270,0) if Num1 set SufferCol=Num-1 "RTN","TMGSELED",272,0) set SufferW=$piece($get(Options("FIELDS",SufferCol)),"^",3) "RTN","TMGSELED",273,0) "RTN","TMGSELED",274,0) set TMGMAXW=ScrnWidth-((FldCount-1)*TMGMINW) ;"min colum width is 3 "RTN","TMGSELED",275,0) if TMGMAXWTMGMAXW) X" "RTN","TMGSELED",277,0) set DIR("A")="Enter amount to adjust "_FldName_" width by" "RTN","TMGSELED",278,0) set DIR("B")="" "RTN","TMGSELED",279,0) "RTN","TMGSELED",280,0) write $$GetDispStr(.Options) "RTN","TMGSELED",281,0) do ^DIR write ! "RTN","TMGSELED",282,0) if (Y="")!(Y["^") goto GWDone "RTN","TMGSELED",283,0) "RTN","TMGSELED",284,0) set delta=+Y "RTN","TMGSELED",285,0) if delta'=0 do "RTN","TMGSELED",286,0) . do AdjCol(.Options,Num,delta) "RTN","TMGSELED",287,0) . do AdjCol(.Options,SufferCol,-delta) "RTN","TMGSELED",288,0) "RTN","TMGSELED",289,0) ;"write # "RTN","TMGSELED",290,0) write $$GetDispStr(.Options),! "RTN","TMGSELED",291,0) "RTN","TMGSELED",292,0) goto GWLoop "RTN","TMGSELED",293,0) GWDone "RTN","TMGSELED",294,0) quit result "RTN","TMGSELED",295,0) "RTN","TMGSELED",296,0) AdjCol(Options,Num,Delta) "RTN","TMGSELED",297,0) ;"Purpose: To adust one column width "RTN","TMGSELED",298,0) ;"Input: Options -- PASS BY REFERENCE, (used for input and as OUT PARAMETER) "RTN","TMGSELED",299,0) ;" Note: prior entries are NOT KILLED "RTN","TMGSELED",300,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName "RTN","TMGSELED",301,0) ;"Output:Width for one column is changed. No check for total width made "RTN","TMGSELED",302,0) ;"Results: none "RTN","TMGSELED",303,0) "RTN","TMGSELED",304,0) new W "RTN","TMGSELED",305,0) set W=$piece($get(Options("FIELDS",Num)),"^",3) "RTN","TMGSELED",306,0) set W=W+Delta "RTN","TMGSELED",307,0) set $piece(Options("FIELDS",Num),"^",3)=W "RTN","TMGSELED",308,0) quit "RTN","TMGSELED",309,0) "RTN","TMGSELED",310,0) "RTN","TMGSELED",311,0) GetDispStr(Options) "RTN","TMGSELED",312,0) ;"Purpose: get a display representation of widths "RTN","TMGSELED",313,0) ;"Input: Options -- PASS BY REFERENCE "RTN","TMGSELED",314,0) ;" Options("FIELDS","MAX NUM")=MaxDisplaySequenceNumber "RTN","TMGSELED",315,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",316,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",317,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",318,0) ;"Results: returns a display string "RTN","TMGSELED",319,0) "RTN","TMGSELED",320,0) new outS set $piece(outS," ",LMargin)="" "RTN","TMGSELED",321,0) ;"Display current widths "RTN","TMGSELED",322,0) for i=1:1:FldCount do "RTN","TMGSELED",323,0) . new W set W=$piece(Options("FIELDS",i),"^",3) "RTN","TMGSELED",324,0) . new name set name=$piece($get(Options("FIELDS",i)),"^",2) "RTN","TMGSELED",325,0) . set name=$extract(name,1,W-2) "RTN","TMGSELED",326,0) . set name=$$LJ^XLFSTR(name,W-2,".") if name="" set name="!" "RTN","TMGSELED",327,0) . set outS=outS_"["_name_"]" "RTN","TMGSELED",328,0) "RTN","TMGSELED",329,0) quit outS "RTN","TMGSELED",330,0) "RTN","TMGSELED",331,0) "RTN","TMGSELED",332,0) GetIENs(Options) "RTN","TMGSELED",333,0) ;"Purpose: Interact with user to choose IENs to be edited "RTN","TMGSELED",334,0) ;" User will be able to pick IENs from a SORT TEMPLATE, or "RTN","TMGSELED",335,0) ;" a custom search. "RTN","TMGSELED",336,0) ;"Input: Options -- PASS BY REFERENCE, (used for input and as OUT PARAMETER) "RTN","TMGSELED",337,0) ;" Note: prior entries are NOT KILLED "RTN","TMGSELED",338,0) ;" Options("FILE")=Filenumber^FileName "RTN","TMGSELED",339,0) ;"Output: Options is filled as follows: "RTN","TMGSELED",340,0) ;" Options("FILE")=Filenumber^FileName <-- left from input "RTN","TMGSELED",341,0) ;" Options("IEN LIST",IEN in FILE)="" "RTN","TMGSELED",342,0) ;" Options("IEN LIST",IEN in FILE)="" "RTN","TMGSELED",343,0) ;"Results: 1=OK To continue, 0=abort "RTN","TMGSELED",344,0) "RTN","TMGSELED",345,0) new Menu,UsrSlct "RTN","TMGSELED",346,0) new FileNum set FileNum=$piece($get(Options("FILE")),"^",1) "RTN","TMGSELED",347,0) new FileName set FileName=$piece($get(Options("FILE")),"^",2) "RTN","TMGSELED",348,0) new result set result=1 "RTN","TMGSELED",349,0) "RTN","TMGSELED",350,0) set Menu(0)="Pick Records from "_FileName_" to Browse" "RTN","TMGSELED",351,0) set Menu(1)="Choose a TEMPLATE from a former FILEMAN SEARCH"_$char(9)_"TEMPLATE" "RTN","TMGSELED",352,0) set Menu(2)="Browse ALL records"_$char(9)_"ALL" "RTN","TMGSELED",353,0) set Menu(3)="Browse records with a given Field VALUE"_$char(9)_"SCREEN" "RTN","TMGSELED",354,0) set Menu(4)="Enter ^ to abort"_$char(9)_"^" "RTN","TMGSELED",355,0) ;"write # "RTN","TMGSELED",356,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu,1) "RTN","TMGSELED",357,0) if UsrSlct="^" set result=0 goto GIDone "RTN","TMGSELED",358,0) if UsrSlct=0 set UsrSlct="" "RTN","TMGSELED",359,0) "RTN","TMGSELED",360,0) new abort set abort=0 "RTN","TMGSELED",361,0) if UsrSlct="TEMPLATE" do "RTN","TMGSELED",362,0) . new DIC,Y "RTN","TMGSELED",363,0) . set DIC=.401 "RTN","TMGSELED",364,0) . set DIC(0)="MAEQ" "RTN","TMGSELED",365,0) TPLOOP . write "Select a TEMPLATE Containing Records for Browsing.",! "RTN","TMGSELED",366,0) . set DIC("A")="Enter Template (^ to abort): " "RTN","TMGSELED",367,0) . do ^DIC write ! "RTN","TMGSELED",368,0) . if +Y'>0 set abort=1 quit "RTN","TMGSELED",369,0) . new node set node=$get(^DIBT(+Y,0)) "RTN","TMGSELED",370,0) . if $piece(node,"^",4)'=FileNum do goto TPLOOP "RTN","TMGSELED",371,0) . . set Y=0 ;"signal to try again "RTN","TMGSELED",372,0) . . new PriorErrorFound "RTN","TMGSELED",373,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: That template doesn't contain records from "_FileName_". Please select another.") "RTN","TMGSELED",374,0) . . do PressToCont^TMGUSRIF "RTN","TMGSELED",375,0) . if (+Y>0)&($data(^DIBT(+Y,1))>1) do "RTN","TMGSELED",376,0) . . merge Options("IEN LIST")=^DIBT(+Y,1) "RTN","TMGSELED",377,0) "RTN","TMGSELED",378,0) else if UsrSlct="ALL" do "RTN","TMGSELED",379,0) . do GetFldValue(FileNum,.01,"ALL",$name(Options("IEN LIST"))) "RTN","TMGSELED",380,0) "RTN","TMGSELED",381,0) else if UsrSlct="SCREEN" do "RTN","TMGSELED",382,0) . new DIC,X,Y,DIR,FldNum,Value "RTN","TMGSELED",383,0) . set DIC="^DD("_FileNum_"," "RTN","TMGSELED",384,0) . set DIC(0)="MAEQ" "RTN","TMGSELED",385,0) . set DIC("A")="Enter FIELD to use for SCREEN: " "RTN","TMGSELED",386,0) . do ^DIC write ! "RTN","TMGSELED",387,0) . if Y=-1 quit "RTN","TMGSELED",388,0) . set FldNum=+Y "RTN","TMGSELED",389,0) . set DIR(0)=FileNum_","_FldNum "RTN","TMGSELED",390,0) . set DIR("?",1)="Enter value to search for. Records will be included" "RTN","TMGSELED",391,0) . set DIR("?",2)="if the field chosed contains the value entered here." "RTN","TMGSELED",392,0) . set DIR("?",3)="A @ may be entered to represent a NULL value for a field." "RTN","TMGSELED",393,0) . set DIR("?",4)="For more complex searches, use Fileman search function," "RTN","TMGSELED",394,0) . set DIR("?",5)="store results in a template, and then chose that template" "RTN","TMGSELED",395,0) . set DIR("?",6)="as the input source instead of choosing a screening value." "RTN","TMGSELED",396,0) . do ^DIR write ! "RTN","TMGSELED",397,0) . if X="@" set Y="@" "RTN","TMGSELED",398,0) . if Y="" quit "RTN","TMGSELED",399,0) . set Value=$piece(Y,"^",1) "RTN","TMGSELED",400,0) . do GetFldValue(FileNum,FldNum,Value,$name(Options("IEN LIST"))) "RTN","TMGSELED",401,0) "RTN","TMGSELED",402,0) if abort=1 set result=0 "RTN","TMGSELED",403,0) GIDone "RTN","TMGSELED",404,0) quit result "RTN","TMGSELED",405,0) "RTN","TMGSELED",406,0) "RTN","TMGSELED",407,0) GetFldVScreen(File,FieldNum,ScrnCode,pResults,Flags) "RTN","TMGSELED",408,0) ;"Purpose: get List of IENs in File with matching Field "RTN","TMGSELED",409,0) ;"Input: File -- the File to scan "RTN","TMGSELED",410,0) ;" FieldNum -- the Field number to get from file "RTN","TMGSELED",411,0) ;" ScrnCode -- Screening code to be executed.... "RTN","TMGSELED",412,0) ;" Format: '$$MyFn^MyModule()', or "RTN","TMGSELED",413,0) ;" '(some test)' such that the following is valid code: "RTN","TMGSELED",414,0) ;" set @("flagToSkip="_ScrnCode) "RTN","TMGSELED",415,0) ;" ---> If flagToSkip=1, then record is NOT selected "RTN","TMGSELED",416,0) ;" The following variables will be available for use: "RTN","TMGSELED",417,0) ;" File -- the File name or number "RTN","TMGSELED",418,0) ;" FieldNum -- the field number "RTN","TMGSELED",419,0) ;" IEN -- the IEN of the current record. "RTN","TMGSELED",420,0) ;" RecValue -- the current value of the field "RTN","TMGSELED",421,0) ;" pResults -- PASS BY NAME, an OUT PARAMETER. "RTN","TMGSELED",422,0) ;" Flags -- OPTIONAL. Possible Flags "RTN","TMGSELED",423,0) ;" "E" search for external forms (default is internal forms) "RTN","TMGSELED",424,0) ;"Output: @pResults is filled as following. Note: prior results are not killed "RTN","TMGSELED",425,0) ;" @pResults@(IEN)="" "RTN","TMGSELED",426,0) ;" @pResults@(IEN)="" "RTN","TMGSELED",427,0) ;"Results: none "RTN","TMGSELED",428,0) "RTN","TMGSELED",429,0) new Itr,IEN,RecValue,FMFlag "RTN","TMGSELED",430,0) new abort set abort=0 "RTN","TMGSELED",431,0) set FMFlag="I" if $get(Flags)["E" set FMFlag="" "RTN","TMGSELED",432,0) "RTN","TMGSELED",433,0) set RecValue=$$ItrFInit^TMGITR(File,.Itr,.IEN,FieldNum,,FMFlag) "RTN","TMGSELED",434,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGSELED",435,0) for do quit:(($$ItrFNext^TMGITR(.Itr,.IEN,.RecValue)="@@@@@@@@")!(+IEN=0))!abort "RTN","TMGSELED",436,0) . if $$UserAborted^TMGUSRIF set abort=1 quit "RTN","TMGSELED",437,0) . new flagToSkip set @("flagToSkip="_ScrnCode) "RTN","TMGSELED",438,0) . if flagToSkip quit "RTN","TMGSELED",439,0) . set @pResults@(IEN)="" "RTN","TMGSELED",440,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGSELED",441,0) "RTN","TMGSELED",442,0) quit "RTN","TMGSELED",443,0) "RTN","TMGSELED",444,0) "RTN","TMGSELED",445,0) GetFldValue(File,FieldNum,Value,pResults,Flags) "RTN","TMGSELED",446,0) ;"Purpose: get List of IENs in File with matching Field "RTN","TMGSELED",447,0) ;"Input: File -- the File to scan "RTN","TMGSELED",448,0) ;" FieldNum -- the Field number to get from file "RTN","TMGSELED",449,0) ;" Value -- the value to compare against. Poss Values "RTN","TMGSELED",450,0) ;" VALUE: if field=VALUE, then record selected "RTN","TMGSELED",451,0) ;" "@": if field=null (empty), then record selected "RTN","TMGSELED",452,0) ;" "ALL": all records are selected "RTN","TMGSELED",453,0) ;" pResults -- PASS BY NAME, an OUT PARAMETER. "RTN","TMGSELED",454,0) ;" Flags -- OPTIONAL. Possible Flags "RTN","TMGSELED",455,0) ;" "E" search for external forms (default is internal forms) "RTN","TMGSELED",456,0) ;"Output: @pResults is filled as following. Note: prior results are not killed "RTN","TMGSELED",457,0) ;" @pResults@(IEN)="" "RTN","TMGSELED",458,0) ;" @pResults@(IEN)="" "RTN","TMGSELED",459,0) ;"Results: none "RTN","TMGSELED",460,0) "RTN","TMGSELED",461,0) "RTN","TMGSELED",462,0) new Itr,IEN,RecValue,FMFlag "RTN","TMGSELED",463,0) if $get(Value)="ALL" goto GFV3 "RTN","TMGSELED",464,0) "RTN","TMGSELED",465,0) GFV1 set FMFlag="I" if $get(Flags)["E" set FMFlag="" "RTN","TMGSELED",466,0) set RecValue=$$ItrFInit^TMGITR(File,.Itr,.IEN,FieldNum,,FMFlag) "RTN","TMGSELED",467,0) do PrepProgress^TMGITR(.Itr,20,0,"IEN") "RTN","TMGSELED",468,0) for do quit:(($$ItrFNext^TMGITR(.Itr,.IEN,.RecValue)="@@@@@@@@")!(+IEN=0)) "RTN","TMGSELED",469,0) . if (RecValue=Value)!((Value="@")&(RecValue="")) do "RTN","TMGSELED",470,0) . . set @pResults@(IEN)="" "RTN","TMGSELED",471,0) write ! "RTN","TMGSELED",472,0) goto GFVDone "RTN","TMGSELED",473,0) "RTN","TMGSELED",474,0) GFV3 write "Gathering ALL records...",! "RTN","TMGSELED",475,0) set IEN=$$ItrInit^TMGITR(File,.Itr,.IEN) "RTN","TMGSELED",476,0) do PrepProgress^TMGITR(.Itr,100,0,"IEN") "RTN","TMGSELED",477,0) for do quit:($$ItrNext^TMGITR(.Itr,.IEN)="") "RTN","TMGSELED",478,0) . if +IEN'=IEN quit "RTN","TMGSELED",479,0) . set @pResults@(IEN)="" "RTN","TMGSELED",480,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGSELED",481,0) GFVDone "RTN","TMGSELED",482,0) quit "RTN","TMGSELED",483,0) "RTN","TMGSELED",484,0) "RTN","TMGSELED",485,0) SELED(Options) "RTN","TMGSELED",486,0) ;"Scope: PUBLIC "RTN","TMGSELED",487,0) ;"Purpose: the entry point for group selecting and editing of recrods "RTN","TMGSELED",488,0) ;" Note: this can be used as an API entry point "RTN","TMGSELED",489,0) ;"Input: Options -- PASS BY REFERENCE "RTN","TMGSELED",490,0) ;" Format: "RTN","TMGSELED",491,0) ;" Options("FILE")=Filenumber^FileName "RTN","TMGSELED",492,0) ;" Options("FIELDS","MAX NUM")=MaxDisplaySequenceNumber "RTN","TMGSELED",493,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",494,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",495,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width "RTN","TMGSELED",496,0) ;" Options("FIELDS",DisplaySequence,"LOOKUP FN") -- OPTIONAL "RTN","TMGSELED",497,0) ;" A function for looking up new values. "RTN","TMGSELED",498,0) ;" Must be in format like this: "RTN","TMGSELED",499,0) ;" Options("FIELDS",DisplaySequence,"LOOKUP FN")="$$MyFn^MyModule(File,FldNum)" "RTN","TMGSELED",500,0) ;" i.e. must be a function name. Function may take passed "RTN","TMGSELED",501,0) ;" parameters 'File' and 'FldNum' "RTN","TMGSELED",502,0) ;" Default value="$$ValueLookup(File,FldNum)" "RTN","TMGSELED",503,0) ;" Options("IEN LIST",IEN in FILE)="" "RTN","TMGSELED",504,0) ;" Options("IEN LIST",IEN in FILE)="" "RTN","TMGSELED",505,0) ;" Options("IEN LIST",IEN in FILE,"SEL")="" ;"<-- optional. Makes preselected "RTN","TMGSELED",506,0) ;" Note: alternative Format "RTN","TMGSELED",507,0) ;" Options("FIELDS",DisplaySequence)=FldNum:FldNum2:FldNum3^Width "RTN","TMGSELED",508,0) ;" FldNum:FldNum2:FldNum3 means FldNum is ptr to file2, and "RTN","TMGSELED",509,0) ;" FldNum2 is in file2. This value is a pointer to file3, and "RTN","TMGSELED",510,0) ;" FldNum3 is a value in file3 "RTN","TMGSELED",511,0) ;"Output: Data in database may be edited. "RTN","TMGSELED",512,0) ;"Results: 1=Normal exit, 2=Needs rescan and recall "RTN","TMGSELED",513,0) "RTN","TMGSELED",514,0) new result set result=1 "RTN","TMGSELED",515,0) new SelList,pList,pIENList "RTN","TMGSELED",516,0) set pList=$name(SelList) "RTN","TMGSELED",517,0) set pIENList=$name(Options("IEN LIST")) "RTN","TMGSELED",518,0) "RTN","TMGSELED",519,0) new Fields,Widths "RTN","TMGSELED",520,0) set Fields="",Widths="" "RTN","TMGSELED",521,0) "RTN","TMGSELED",522,0) new File set File=+$get(Options("FILE")) "RTN","TMGSELED",523,0) if File="" goto SEDone "RTN","TMGSELED",524,0) "RTN","TMGSELED",525,0) new i for i=1:1:$get(Options("FIELDS","MAX NUM")) do "RTN","TMGSELED",526,0) . set Fields=Fields_$piece($get(Options("FIELDS",i)),"^",1)_";" "RTN","TMGSELED",527,0) . set Widths=Widths_$piece($get(Options("FIELDS",i)),"^",3)_";" "RTN","TMGSELED",528,0) "RTN","TMGSELED",529,0) new tempResult "RTN","TMGSELED",530,0) new pSaveArray ;"will store ref of stored display array --> faster "RTN","TMGSELED",531,0) SLoop kill @pList "RTN","TMGSELED",532,0) "RTN","TMGSELED",533,0) ;"Later change this to allow custom order of sort fields. "RTN","TMGSELED",534,0) do IENSelector^TMGUSRIF(pIENList,pList,File,Fields,Widths,"Pick Records to Edit. [ESC],[ESC] when done",Fields,.pSaveArray) "RTN","TMGSELED",535,0) new count set count=$$ListCt^TMGMISC(pList) "RTN","TMGSELED",536,0) write count," items selected.",! "RTN","TMGSELED",537,0) "RTN","TMGSELED",538,0) if count>0 set tempResult=$$EditRecs(pList,.Options) "RTN","TMGSELED",539,0) "RTN","TMGSELED",540,0) write !,"Fix more" "RTN","TMGSELED",541,0) new % set %=1 "RTN","TMGSELED",542,0) if count=0 set %=2 "RTN","TMGSELED",543,0) do YN^DICN write ! "RTN","TMGSELED",544,0) if %'=1 goto SEDone "RTN","TMGSELED",545,0) if $data(@pList)=0 goto SLoop "RTN","TMGSELED",546,0) "RTN","TMGSELED",547,0) new needsRepack set needsRepack=0 "RTN","TMGSELED",548,0) write "Removing fixed items from list. Here are the old entries...",! "RTN","TMGSELED",549,0) if $get(pSaveArray)="" do "RTN","TMGSELED",550,0) . do ListNot^TMGMISC(pIENList,pList) ;"<-- probably a bug in this function "RTN","TMGSELED",551,0) else do "RTN","TMGSELED",552,0) . new Itr,IEN,DispLineNum "RTN","TMGSELED",553,0) . ;"zwr @pList "RTN","TMGSELED",554,0) . set IEN=$$ItrAInit^TMGITR(pList,.Itr) "RTN","TMGSELED",555,0) . if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="") "RTN","TMGSELED",556,0) . . set DispLineNum=+$get(@pList@(IEN)) "RTN","TMGSELED",557,0) . . if DispLineNum=0 quit "RTN","TMGSELED",558,0) . . new tempS "RTN","TMGSELED",559,0) . . set tempS=$get(@pSaveArray@(DispLineNum)) "RTN","TMGSELED",560,0) . . set tempS=$piece(tempS,$char(9),2) "RTN","TMGSELED",561,0) . . write " --",tempS,! "RTN","TMGSELED",562,0) . . kill @pSaveArray@(DispLineNum) "RTN","TMGSELED",563,0) . . set needsRepack=1 "RTN","TMGSELED",564,0) . write ! "RTN","TMGSELED",565,0) write ! "RTN","TMGSELED",566,0) ;"IMPORTANT NOTE: It seems that that after deleting items in pSaveArray, the ordering "RTN","TMGSELED",567,0) ;" gets out of sync, such that the display number is NOT the same as the index "RTN","TMGSELED",568,0) ;" and the wrong references can be used!!! Must renumber somehow... "RTN","TMGSELED",569,0) "RTN","TMGSELED",570,0) set %=2 "RTN","TMGSELED",571,0) write "Rescan file (slow)" "RTN","TMGSELED",572,0) do YN^DICN write ! "RTN","TMGSELED",573,0) if %=1 set result=2 goto SEDone "RTN","TMGSELED",574,0) if %=-1 goto SEDone "RTN","TMGSELED",575,0) "RTN","TMGSELED",576,0) write "Packing display list..." "RTN","TMGSELED",577,0) do ListPack^TMGMISC(pSaveArray) "RTN","TMGSELED",578,0) write ! "RTN","TMGSELED",579,0) "RTN","TMGSELED",580,0) goto SLoop "RTN","TMGSELED",581,0) SEDone "RTN","TMGSELED",582,0) quit result "RTN","TMGSELED",583,0) "RTN","TMGSELED",584,0) EditRecs(pList,Options,LookupFn) "RTN","TMGSELED",585,0) ;"Purpose: To get new values for display fields in records "RTN","TMGSELED",586,0) ;"Input: pList -- PASS BY NAME. A list of IENs to process "RTN","TMGSELED",587,0) ;" @pList@(IEN)=IgnoredValue "RTN","TMGSELED",588,0) ;" @pList@(IEN)=IgnoredValue "RTN","TMGSELED",589,0) ;" @pList@(IEN)=IgnoredValue "RTN","TMGSELED",590,0) ;" Options -- PASS BY REFERENCE. Format: "RTN","TMGSELED",591,0) ;" Options("FILE")=Filenumber^FileName "RTN","TMGSELED",592,0) ;" Options("FIELDS","MAX NUM")=MaxDisplaySequenceNumber "RTN","TMGSELED",593,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width <-- Width is ignored "RTN","TMGSELED",594,0) ;" Options("FIELDS",DisplaySequence)=FldNum^FldName^Width <-- Width is ignored "RTN","TMGSELED",595,0) ;" Options("FIELDS",DisplaySequence)=FldNum <-- FldName OPTIONAL "RTN","TMGSELED",596,0) ;" Options("FIELDS",DisplaySequence,"LOOKUP FN") -- OPTIONAL "RTN","TMGSELED",597,0) ;" A function for looking up new values. "RTN","TMGSELED",598,0) ;" Must be in format like this: "RTN","TMGSELED",599,0) ;" Options("FIELDS",DisplaySequence,"LOOKUP FN")="$$MyFn^MyModule(File,FldNum)" "RTN","TMGSELED",600,0) ;" i.e. must be a function name. Function may take passed "RTN","TMGSELED",601,0) ;" parameters 'File' and 'FldNum' "RTN","TMGSELED",602,0) ;" Default value="$$ValueLookup(File,FldNum)" "RTN","TMGSELED",603,0) ;" Options("FIELDS",DisplaySequence,"NO EDIT")=1 <-- indicates this field NOT to be edited. "RTN","TMGSELED",604,0) ;" Note: alternative Format "RTN","TMGSELED",605,0) ;" Options("FIELDS",DisplaySequence)=FldNum:FldNum2:FldNum3^Width "RTN","TMGSELED",606,0) ;" FldNum:FldNum2:FldNum3 means FldNum is ptr to file2, and "RTN","TMGSELED",607,0) ;" FldNum2 is in file2. This value is a pointer to file3, and "RTN","TMGSELED",608,0) ;" FldNum3 is a value in file3 "RTN","TMGSELED",609,0) ;" "RTN","TMGSELED",610,0) ;"Results: 1=OK to continue, 0 if error "RTN","TMGSELED",611,0) "RTN","TMGSELED",612,0) new result set result=0 ;"default to error "RTN","TMGSELED",613,0) new Menu,UsrSlct,MenuCount,FldCount,File "RTN","TMGSELED",614,0) new TMGFDA,TMGMSG "RTN","TMGSELED",615,0) set FldCount=+$get(Options("FIELDS","MAX NUM")) if FldCount=0 goto GNVDone "RTN","TMGSELED",616,0) set File=+$get(Options("FILE")) if File=0 goto GNVDone "RTN","TMGSELED",617,0) new LookupFn "RTN","TMGSELED",618,0) new DIR,FldNum,NewValue "RTN","TMGSELED",619,0) "RTN","TMGSELED",620,0) GNVL1 kill Menu "RTN","TMGSELED",621,0) set Menu(0)="Pick Field to EDIT" "RTN","TMGSELED",622,0) set MenuCount=1 "RTN","TMGSELED",623,0) for i=1:1:FldCount do "RTN","TMGSELED",624,0) . new CommonValue,FieldNum,FieldName "RTN","TMGSELED",625,0) . if $get(Options("FIELDS",i,"NO EDIT"))=1 quit ;"don't edit this field "RTN","TMGSELED",626,0) . set FieldNum=$piece($get(Options("FIELDS",i)),"^",1) "RTN","TMGSELED",627,0) . set FieldName=$piece($get(Options("FIELDS",i)),"^",2) "RTN","TMGSELED",628,0) . if FieldName="" set FieldName=$$GetFldName^TMGDBAPI(File,FieldNum) "RTN","TMGSELED",629,0) . set CommonValue=$$GetCommonValue(File,FieldNum,pList) "RTN","TMGSELED",630,0) . set Menu(MenuCount)=FieldName_": ["_CommonValue_"]"_$char(9)_i "RTN","TMGSELED",631,0) . set MenuCount=MenuCount+1 "RTN","TMGSELED",632,0) ;"set Menu(MenuCount)="Enter ^ to abort"_$char(9)_"^" "RTN","TMGSELED",633,0) "RTN","TMGSELED",634,0) GNVL2 "RTN","TMGSELED",635,0) set UsrSlct=$$Menu^TMGUSRIF(.Menu) "RTN","TMGSELED",636,0) ;"if FldCount>1 do "RTN","TMGSELED",637,0) ;". set UsrSlct=$$Menu^TMGUSRIF(.Menu) "RTN","TMGSELED",638,0) ;"else set UsrSlct=1 ;"If only 1 option, then auto-select "RTN","TMGSELED",639,0) if (UsrSlct="^")!(UsrSlct="") goto GWDone "RTN","TMGSELED",640,0) "RTN","TMGSELED",641,0) set LookupFn=$get(Options("FIELDS",UsrSlct,"LOOKUP FN"),"$$ValueLookup(File,FldNum)") "RTN","TMGSELED",642,0) "RTN","TMGSELED",643,0) kill DIR,NewValue "RTN","TMGSELED",644,0) set FldNum=+$piece($get(Options("FIELDS",UsrSlct)),"^",1) "RTN","TMGSELED",645,0) if FldNum=0 goto GNVDone "RTN","TMGSELED",646,0) "RTN","TMGSELED",647,0) set @("Y="_LookupFn) "RTN","TMGSELED",648,0) ;"write !,"Enter new value for field below." "RTN","TMGSELED",649,0) ;"set DIR(0)=File_","_FldNum "RTN","TMGSELED",650,0) ;"do ^DIR write ! "RTN","TMGSELED",651,0) "RTN","TMGSELED",652,0) if Y="" goto GNVL2 "RTN","TMGSELED",653,0) if Y="^" goto GNVDone "RTN","TMGSELED",654,0) set NewValue=$piece(Y,"^",1) "RTN","TMGSELED",655,0) if NewValue=+NewValue do "RTN","TMGSELED",656,0) . new array "RTN","TMGSELED",657,0) . do GetFieldInfo^TMGDBAPI(File,FldNum,"array") "RTN","TMGSELED",658,0) . if $get(array("SPECIFIER"))["S" quit ;"check if field is a SET, if so, don't add ` mark "RTN","TMGSELED",659,0) . set NewValue="`"_NewValue ;"indicate that number is a pointer "RTN","TMGSELED",660,0) "RTN","TMGSELED",661,0) new Itr,IEN,Value,results "RTN","TMGSELED",662,0) set result=1 "RTN","TMGSELED",663,0) set IEN=$$ItrAInit^TMGITR(pList,.Itr) "RTN","TMGSELED",664,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="") "RTN","TMGSELED",665,0) . kill TMGFDA,TMGMSG "RTN","TMGSELED",666,0) . set TMGFDA(File,IEN_",",FldNum)=NewValue "RTN","TMGSELED",667,0) . do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGSELED",668,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGSELED",669,0) . . set result=0 "RTN","TMGSELED",670,0) . . new PriorErrorFound "RTN","TMGSELED",671,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSELED",672,0) "RTN","TMGSELED",673,0) goto GNVL1 "RTN","TMGSELED",674,0) "RTN","TMGSELED",675,0) GNVDone "RTN","TMGSELED",676,0) quit result "RTN","TMGSELED",677,0) "RTN","TMGSELED",678,0) "RTN","TMGSELED",679,0) ValueLookup(File,FldNum) "RTN","TMGSELED",680,0) ;"Purpose: To interact with user and obtain a value for field in file "RTN","TMGSELED",681,0) ;"Input: File: A valid file number "RTN","TMGSELED",682,0) ;" FldNum: A valid field number in File "RTN","TMGSELED",683,0) ;"Result: Returns value of user input. "RTN","TMGSELED",684,0) "RTN","TMGSELED",685,0) new DIR "RTN","TMGSELED",686,0) write !,"Enter new value for field below." "RTN","TMGSELED",687,0) set DIR(0)=File_","_FldNum "RTN","TMGSELED",688,0) do ^DIR write ! "RTN","TMGSELED",689,0) quit Y "RTN","TMGSELED",690,0) "RTN","TMGSELED",691,0) "RTN","TMGSELED",692,0) GetCommonValue(File,Field,pList,Flags) "RTN","TMGSELED",693,0) ;"Purpose: Return a value held by all records in pList, or "" if mixed values "RTN","TMGSELED",694,0) ;"Input: File -- file number "RTN","TMGSELED",695,0) ;" Field -- field number or 'num:num2:num3" etc "RTN","TMGSELED",696,0) ;" Flags -- value to pass to GET1^DIQ during lookup "RTN","TMGSELED",697,0) ;"Output: returns a common value, or "" if not common value "RTN","TMGSELED",698,0) "RTN","TMGSELED",699,0) new Itr,IEN,Value,abort,result "RTN","TMGSELED",700,0) set abort=0,result="" "RTN","TMGSELED",701,0) "RTN","TMGSELED",702,0) new Itr,IEN,Value,abort "RTN","TMGSELED",703,0) set abort=0 "RTN","TMGSELED",704,0) set IEN=$$ItrAInit^TMGITR(pList,.Itr) "RTN","TMGSELED",705,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1) "RTN","TMGSELED",706,0) . set Value=$$GET1^DIQ(File,IEN_",",Field) "RTN","TMGSELED",707,0) . if result="" set result=Value "RTN","TMGSELED",708,0) . if Value'=result set result="",abort=1 "RTN","TMGSELED",709,0) "RTN","TMGSELED",710,0) quit result "RTN","TMGSELED",711,0) "RTN","TMGSELED",712,0) "RTN","TMGSELED",713,0) "RTN","TMGSEQL1") 0^74^B44760 "RTN","TMGSEQL1",1,0) TMGSEQL1 ;TMG/kst/Interface with SequelSystems PMS ;03/25/06 "RTN","TMGSEQL1",2,0) ;;1.0;TMG-LIB;**1**;01/09/06 "RTN","TMGSEQL1",3,0) "RTN","TMGSEQL1",4,0) ;"TMG SEQUEL IMPORT FUNCTIONS "RTN","TMGSEQL1",5,0) ;"Kevin Toppenberg MD "RTN","TMGSEQL1",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGSEQL1",7,0) ;"1-9-2006 "RTN","TMGSEQL1",8,0) "RTN","TMGSEQL1",9,0) "RTN","TMGSEQL1",10,0) ;"======================================================================= "RTN","TMGSEQL1",11,0) ;" API -- Public Functions. "RTN","TMGSEQL1",12,0) ;"======================================================================= "RTN","TMGSEQL1",13,0) ;"ASKIMPORT "RTN","TMGSEQL1",14,0) ;"RUNNOW provide an entry point for running import NOW. This will delete prior alerts "RTN","TMGSEQL1",15,0) ;"AUTOIN ;"entry point for scheduled task "RTN","TMGSEQL1",16,0) ;"QUIETIN "RTN","TMGSEQL1",17,0) "RTN","TMGSEQL1",18,0) ;"$$IMPORTFILE(FilePath,FileName,F2Name,ErrArray,ChgLog,PrgCallback,F2Path,DelFiles,UserID) "RTN","TMGSEQL1",19,0) ;"$$IMPORTGLOBAL(GRef,G2Ref,ErrArray,ChgLog,PrgCallback,UserID) "RTN","TMGSEQL1",20,0) "RTN","TMGSEQL1",21,0) ;"======================================================================= "RTN","TMGSEQL1",22,0) ;"PRIVATE API FUNCTIONS "RTN","TMGSEQL1",23,0) ;"======================================================================= "RTN","TMGSEQL1",24,0) ;"$$ProcessPt(OneLine,ErrArray,ChgLog,SSNArray,DUZ) "RTN","TMGSEQL1",25,0) ;"$$ParseLine(OneLine,Array,SSNArray) "RTN","TMGSEQL1",26,0) ;"UpdateDB(PtInfo,AutoRegister,ErrArray,ChgLog) "RTN","TMGSEQL1",27,0) ;"$$InactivePt(PMSAcctNum,SSNArray) "RTN","TMGSEQL1",28,0) ;"$$InvalidProvider(SequelProvider) "RTN","TMGSEQL1",29,0) ;"$$InvalPtName(FName,LName) "RTN","TMGSEQL1",30,0) "RTN","TMGSEQL1",31,0) "RTN","TMGSEQL1",32,0) ;"======================================================================= "RTN","TMGSEQL1",33,0) ;"DEPENDENCIES "RTN","TMGSEQL1",34,0) ;"TMGIOUTL "RTN","TMGSEQL1",35,0) ;"TMGMISC "RTN","TMGSEQL1",36,0) ;"======================================================================= "RTN","TMGSEQL1",37,0) ;"======================================================================= "RTN","TMGSEQL1",38,0) "RTN","TMGSEQL1",39,0) "RTN","TMGSEQL1",40,0) "RTN","TMGSEQL1",41,0) ;"======================================================================= "RTN","TMGSEQL1",42,0) ;" Below are three custom files that are used by the TMGSEQL* code "RTN","TMGSEQL1",43,0) ;"======================================================================= "RTN","TMGSEQL1",44,0) "RTN","TMGSEQL1",45,0) "RTN","TMGSEQL1",46,0) ;"File: 22706 TMG DEMOGRAPHICS IMPORT ERRORS Branch: 1 "RTN","TMGSEQL1",47,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGSEQL1",48,0) ;"=============================================================================== "RTN","TMGSEQL1",49,0) ;" 1 0;1 .01 ACCOUNT NUMBER [RNJ9,0] "RTN","TMGSEQL1",50,0) ;" 2 4;1 .02 CREATION DATE [D] "RTN","TMGSEQL1",51,0) ;" 3 4;2 .03 PATIENT NAME [F] "RTN","TMGSEQL1",52,0) ;" 4 0;2 1 MESSAGE [F] "RTN","TMGSEQL1",53,0) ;" 2;0 2 IMPORT DATA <-WP [22706.02] "RTN","TMGSEQL1",54,0) ;" 5 -0;1 .01 -IMPORT DATA [W] "RTN","TMGSEQL1",55,0) ;" 3;0 3 DIERR MESSAGE <-WP [22706.03] "RTN","TMGSEQL1",56,0) ;" 6 -0;1 .01 -DIERR MESSAGE [W] "RTN","TMGSEQL1",57,0) ;" 7 4;3 4 ALERT IEN [NJ9,0] "RTN","TMGSEQL1",58,0) ;" <> <> <> "RTN","TMGSEQL1",59,0) ;" A.) FILE NAME:------------- TMG DEMOGRAPHICS IMPORT ERRORS "RTN","TMGSEQL1",60,0) ;" F.) FILE ACCESS: "RTN","TMGSEQL1",61,0) ;" B.) FILE NUMBER:----------- 22706 DD______ @ "RTN","TMGSEQL1",62,0) ;" Read____ @ "RTN","TMGSEQL1",63,0) ;" C.) NUM OF FLDS:----------- 9 Write___ @ "RTN","TMGSEQL1",64,0) ;" Delete__ @ "RTN","TMGSEQL1",65,0) ;" D.) DATA GLOBAL:----------- ^TMG(22706, Laygo___ @ "RTN","TMGSEQL1",66,0) ;" "RTN","TMGSEQL1",67,0) ;" E.) TOTAL GLOBAL ENTRIES:-- 76 G.) PRINTING STATUS:-- Off "RTN","TMGSEQL1",68,0) ;"================================================================================ "RTN","TMGSEQL1",69,0) "RTN","TMGSEQL1",70,0) "RTN","TMGSEQL1",71,0) "RTN","TMGSEQL1",72,0) ;"File: 22707 TMG NAME SEX Branch: 1 "RTN","TMGSEQL1",73,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGSEQL1",74,0) ;"=============================================================================== "RTN","TMGSEQL1",75,0) ;" 1 0;1 .01 FIRST NAME [RF] "RTN","TMGSEQL1",76,0) ;" 2 0;2 1 SEX [S] "RTN","TMGSEQL1",77,0) ;"<> <> <> "RTN","TMGSEQL1",78,0) ;" A.) FILE NAME:------------- TMG NAME SEX "RTN","TMGSEQL1",79,0) ;" F.) FILE ACCESS: "RTN","TMGSEQL1",80,0) ;" B.) FILE NUMBER:----------- 22707 DD______ @ "RTN","TMGSEQL1",81,0) ;" Read____ @ "RTN","TMGSEQL1",82,0) ;" C.) NUM OF FLDS:----------- 2 Write___ @ "RTN","TMGSEQL1",83,0) ;" Delete__ @ "RTN","TMGSEQL1",84,0) ;" D.) DATA GLOBAL:----------- ^TMG(22707, Laygo___ @ "RTN","TMGSEQL1",85,0) ;" "RTN","TMGSEQL1",86,0) ;" E.) TOTAL GLOBAL ENTRIES:-- 698 G.) PRINTING STATUS:-- Off "RTN","TMGSEQL1",87,0) ;"================================================================================ "RTN","TMGSEQL1",88,0) "RTN","TMGSEQL1",89,0) "RTN","TMGSEQL1",90,0) "RTN","TMGSEQL1",91,0) ;"File: 22711 TMG UPLOAD SETTINGS Branch: 1 "RTN","TMGSEQL1",92,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGSEQL1",93,0) ;"=============================================================================== "RTN","TMGSEQL1",94,0) ;" 1 0;1 .01 NAME [RFX] "RTN","TMGSEQL1",95,0) ;" 2 0;2 1 DEBUG SHOW [NJ1,0X] "RTN","TMGSEQL1",96,0) ;" 3 1;1 1.1 DEBUG OUTPUT FILE [F] "RTN","TMGSEQL1",97,0) ;" 4 2;1 1.15 DEBUG OUTPUT PATH [F] "RTN","TMGSEQL1",98,0) ;" 5 1;2 1.2 DEBUG CUMULATIVE [NJ1,0] "RTN","TMGSEQL1",99,0) ;" 6 3;1 2 IMPORT DATAFILE NAME [F] "RTN","TMGSEQL1",100,0) ;" 7 5;1 2.1 IMPORT DATAFILE 2 NAME [F] "RTN","TMGSEQL1",101,0) ;" 8 4;1 2.5 IMPORT DATAFILE PATH [F] "RTN","TMGSEQL1",102,0) ;" 9 6;1 3 ALERT RECIPIENT <-Pntr [P200'] "RTN","TMGSEQL1",103,0) ;" 10 6;2 4 LAST IMPORT DATE [D] "RTN","TMGSEQL1",104,0) ;" 11 6;3 5 DELETE DATAFILE AFTER IMPORT? [S] "RTN","TMGSEQL1",105,0) ;" 12 6;4 6 PICK GENDER FROM NAME? [S] "RTN","TMGSEQL1",106,0) ;" 13 6;5 7 IMPORT FREQUENCY (IN HOURS) [NJ4,0] "RTN","TMGSEQL1",107,0) ;" <> <> <> "RTN","TMGSEQL1",108,0) ;" A.) FILE NAME:------------- TMG UPLOAD SETTINGS "RTN","TMGSEQL1",109,0) ;" F.) FILE ACCESS: "RTN","TMGSEQL1",110,0) ;" B.) FILE NUMBER:----------- 22711 DD______ @ "RTN","TMGSEQL1",111,0) ;" Read____ @ "RTN","TMGSEQL1",112,0) ;" C.) NUM OF FLDS:----------- 12 Write___ @ "RTN","TMGSEQL1",113,0) ;" Delete__ @ "RTN","TMGSEQL1",114,0) ;" D.) DATA GLOBAL:----------- ^TMG(22711, Laygo___ @ "RTN","TMGSEQL1",115,0) ;" "RTN","TMGSEQL1",116,0) ;" E.) TOTAL GLOBAL ENTRIES:-- 1 G.) PRINTING STATUS:-- Off "RTN","TMGSEQL1",117,0) ;"================================================================================ "RTN","TMGSEQL1",118,0) "RTN","TMGSEQL1",119,0) "RTN","TMGSEQL1",120,0) "RTN","TMGSEQL1",121,0) "RTN","TMGSEQL1",122,0) ASKIMPORT "RTN","TMGSEQL1",123,0) ;"Purpose: To ask user for filename and then import data. "RTN","TMGSEQL1",124,0) ;"Input: None "RTN","TMGSEQL1",125,0) ;"Output: Database is updated with data from file. "RTN","TMGSEQL1",126,0) ;"Result: None "RTN","TMGSEQL1",127,0) "RTN","TMGSEQL1",128,0) new DiscardName "RTN","TMGSEQL1",129,0) new DefPath set DefPath="/tmp/" "RTN","TMGSEQL1",130,0) new DefFName set DefFName="demographics.csv" "RTN","TMGSEQL1",131,0) new DefF2Name set DefF2Name="demographics2.csv" "RTN","TMGSEQL1",132,0) new FPath,FName,F2Name "RTN","TMGSEQL1",133,0) new ErrArray,ChLog "RTN","TMGSEQL1",134,0) new result "RTN","TMGSEQL1",135,0) "RTN","TMGSEQL1",136,0) new PrgsFn set PrgsFn="do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",1,TMGMAX,,TMGSTART)" "RTN","TMGSEQL1",137,0) set PrgsFn=PrgsFn_" read *TMGkeyin:0 set:(TMGkeyin=27) TMGABORT=1" "RTN","TMGSEQL1",138,0) "RTN","TMGSEQL1",139,0) set DiscardName=$$GetFName^TMGIOUTL("Please enter file to import.",.DefPath,.DefFName,,.FPath,.FName) "RTN","TMGSEQL1",140,0) if DiscardName="" goto AIDone "RTN","TMGSEQL1",141,0) "RTN","TMGSEQL1",142,0) set DiscardName=$$GetFName^TMGIOUTL("Please enter 2nd file to import.",.DefPath,.DefF2Name,,.FPath,.F2Name) "RTN","TMGSEQL1",143,0) if DiscardName="" goto AIDone "RTN","TMGSEQL1",144,0) "RTN","TMGSEQL1",145,0) set result=$$IMPORTFILE(FPath,FName,F2Name,.ErrArray,.ChLog,PrgsFn) "RTN","TMGSEQL1",146,0) "RTN","TMGSEQL1",147,0) AIDone "RTN","TMGSEQL1",148,0) quit "RTN","TMGSEQL1",149,0) "RTN","TMGSEQL1",150,0) "RTN","TMGSEQL1",151,0) RUNNOW "RTN","TMGSEQL1",152,0) ;"Purpose: To provide an entry point for running import NOW. This will delete prior alerts "RTN","TMGSEQL1",153,0) ;"Input: none. Settings stored in File 22711 are used "RTN","TMGSEQL1",154,0) ;"Output: None. Progress shown to console. The database should be updated "RTN","TMGSEQL1",155,0) ;"Results: none "RTN","TMGSEQL1",156,0) "RTN","TMGSEQL1",157,0) write !!,"Import Sequel Demographics Now...",! "RTN","TMGSEQL1",158,0) "RTN","TMGSEQL1",159,0) new FName,F2Name,FPath "RTN","TMGSEQL1",160,0) new result "RTN","TMGSEQL1",161,0) new ErrArray,ChLog "RTN","TMGSEQL1",162,0) new DelFiles "RTN","TMGSEQL1",163,0) new UserID "RTN","TMGSEQL1",164,0) "RTN","TMGSEQL1",165,0) set FName=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE NAME") "RTN","TMGSEQL1",166,0) set F2Name=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE 2 NAME") "RTN","TMGSEQL1",167,0) set FPath=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE PATH") "RTN","TMGSEQL1",168,0) set DelFiles=+$$GET1^DIQ(22711,"1,","DELETE DATAFILE AFTER IMPORT?","I") "RTN","TMGSEQL1",169,0) set UserID=$$GET1^DIQ(22711,"1,","ALERT RECIPIENT","I") "RTN","TMGSEQL1",170,0) "RTN","TMGSEQL1",171,0) new PrgsFn set PrgsFn="do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",1,TMGMAX,,TMGSTART)" "RTN","TMGSEQL1",172,0) set PrgsFn=PrgsFn_" read *TMGkeyin:0 set:(TMGkeyin=27) TMGABORT=1" "RTN","TMGSEQL1",173,0) "RTN","TMGSEQL1",174,0) set result=$$IMPORTFILE(FPath,FName,F2Name,,,PrgsFn,,DelFiles,UserID) "RTN","TMGSEQL1",175,0) "RTN","TMGSEQL1",176,0) quit "RTN","TMGSEQL1",177,0) "RTN","TMGSEQL1",178,0) "RTN","TMGSEQL1",179,0) AUTOIN "RTN","TMGSEQL1",180,0) ;"Purpose: To provide an entry point for a scheduled task. This will delete prior alerts "RTN","TMGSEQL1",181,0) ;"Input: none. Settings stored in File 22711 are used "RTN","TMGSEQL1",182,0) ;"Output: None. There should be no console output. The database should be updated "RTN","TMGSEQL1",183,0) ;"Results: none "RTN","TMGSEQL1",184,0) "RTN","TMGSEQL1",185,0) new InitTime set InitTime=$H "RTN","TMGSEQL1",186,0) "RTN","TMGSEQL1",187,0) new UserID set UserID=$$GET1^DIQ(22711,"1,","ALERT RECIPIENT","I") "RTN","TMGSEQL1",188,0) "RTN","TMGSEQL1",189,0) do ;"clear out 'next run task number' "RTN","TMGSEQL1",190,0) . new TMGFDA,TMGMSG "RTN","TMGSEQL1",191,0) . set TMGFDA(22711,"1,",8)="@" ;"#4 = TASK FOR NEXT RUN "RTN","TMGSEQL1",192,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;" note: ignores TMGMSG or errors. "RTN","TMGSEQL1",193,0) "RTN","TMGSEQL1",194,0) new temp set temp=$$QuietClear^TMGSEQL3(UserID) ;"clear prior alerts & errors "RTN","TMGSEQL1",195,0) do QUIETIN ;" do import "RTN","TMGSEQL1",196,0) "RTN","TMGSEQL1",197,0) ;"Here I schedule the next task to run again. "RTN","TMGSEQL1",198,0) new HrInterval set HrInterval=$$GET1^DIQ(22711,"1,","IMPORT FREQUENCY (IN HOURS)","I") "RTN","TMGSEQL1",199,0) if +HrInterval>0 do "RTN","TMGSEQL1",200,0) . new time set time=$$HADD^XLFDT(InitTime,0,HrInterval,0) "RTN","TMGSEQL1",201,0) . new task set task=$$Schedule^TMGSEQL3(time,"AUTOIN^TMGSEQL1","Import of demographic data from Sequel billing system.") "RTN","TMGSEQL1",202,0) . ;"store 'next run task number' "RTN","TMGSEQL1",203,0) . set TMGFDA(22711,"1,",8)="`"_task ;"#4 = TASK FOR NEXT RUN "RTN","TMGSEQL1",204,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;" note: ignores TMGMSG or errors. "RTN","TMGSEQL1",205,0) "RTN","TMGSEQL1",206,0) quit "RTN","TMGSEQL1",207,0) "RTN","TMGSEQL1",208,0) "RTN","TMGSEQL1",209,0) QUIETIN "RTN","TMGSEQL1",210,0) ;"Purpose: To import data based on settings, with no user interaction (in or out) "RTN","TMGSEQL1",211,0) ;"Input: none. Settings stored in File 22711 are used "RTN","TMGSEQL1",212,0) ;"Output: None. There should be no console output. The database should be updated "RTN","TMGSEQL1",213,0) ;"Results: none "RTN","TMGSEQL1",214,0) "RTN","TMGSEQL1",215,0) new FName,F2Name,FPath "RTN","TMGSEQL1",216,0) new result "RTN","TMGSEQL1",217,0) new ErrArray,ChLog "RTN","TMGSEQL1",218,0) new DelFiles "RTN","TMGSEQL1",219,0) new UserID "RTN","TMGSEQL1",220,0) "RTN","TMGSEQL1",221,0) set FName=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE NAME") "RTN","TMGSEQL1",222,0) set F2Name=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE 2 NAME") "RTN","TMGSEQL1",223,0) set FPath=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE PATH") "RTN","TMGSEQL1",224,0) set DelFiles=+$$GET1^DIQ(22711,"1,","DELETE DATAFILE AFTER IMPORT?","I") "RTN","TMGSEQL1",225,0) set UserID=$$GET1^DIQ(22711,"1,","ALERT RECIPIENT","I") "RTN","TMGSEQL1",226,0) "RTN","TMGSEQL1",227,0) set result=$$IMPORTFILE(FPath,FName,F2Name,,,,,DelFiles,UserID) "RTN","TMGSEQL1",228,0) "RTN","TMGSEQL1",229,0) quit "RTN","TMGSEQL1",230,0) "RTN","TMGSEQL1",231,0) "RTN","TMGSEQL1",232,0) IMPORTFILE(FilePath,FileName,F2Name,ErrArray,ChgLog,PrgCallback,F2Path,DelFiles,UserID) "RTN","TMGSEQL1",233,0) ;"Purpose: To import data from file specified. "RTN","TMGSEQL1",234,0) ;"Input: FilePath: Path of file to input. "RTN","TMGSEQL1",235,0) ;" FileName: The Name of file of file to input. "RTN","TMGSEQL1",236,0) ;" Note: This is written to import a specific file "RTN","TMGSEQL1",237,0) ;" created by SequelMed Systems, filled with "RTN","TMGSEQL1",238,0) ;" patient demographics, in CVS format "RTN","TMGSEQL1",239,0) ;" Note: This file will be DELETED if DelFiles=1 "RTN","TMGSEQL1",240,0) ;" F2Name : the name of the second demographics file in input "RTN","TMGSEQL1",241,0) ;" The reason for 2 files is because Sequel doesn't report the SSN in the "RTN","TMGSEQL1",242,0) ;" primary demographics report. So a second report must be used, and these "RTN","TMGSEQL1",243,0) ;" two files are merged to provide complete patient demographics. "RTN","TMGSEQL1",244,0) ;" Note: This file will be DELETED if DelFiles=1 "RTN","TMGSEQL1",245,0) ;" ErrArray: PASS BY REFERENCE. Array to receive failed data lines. "RTN","TMGSEQL1",246,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1",247,0) ;" PrgCallback: OPTIONAL -- if supplied, then M code contained in this string "RTN","TMGSEQL1",248,0) ;" will be xecuted periodically, to allow display of a progress bar etc. "RTN","TMGSEQL1",249,0) ;" Note: the following variables with global scope will be declared and "RTN","TMGSEQL1",250,0) ;" available for use: TMGCUR (current count), TMGMAX (max count), "RTN","TMGSEQL1",251,0) ;" TMGSTART (the start time "RTN","TMGSEQL1",252,0) ;" External function can signal a request an abort by setting TMGABORT=1 "RTN","TMGSEQL1",253,0) ;" F2Path: OPTIONAL -- path of 2nd demographics file. Default=FilePath "RTN","TMGSEQL1",254,0) ;" DelFiles: OPTIONAL -- if 1, then source files (FileName and F2Name) are deleted after import "RTN","TMGSEQL1",255,0) ;" UserID : OPTIONAL -- user to receive alerts regarding errors. Default is current user (DUZ) "RTN","TMGSEQL1",256,0) ;"Note: I have learned that SequelMed billing system exports ALL patients in the primary "RTN","TMGSEQL1",257,0) ;" export file, including one that have been marked inactive do to invalid data etc. "RTN","TMGSEQL1",258,0) ;" Thus, while the second file (F2Name) has limited info, it contains the list of "RTN","TMGSEQL1",259,0) ;" ACTIVE patients. So if a name is not included in the 2nd file, then its info will "RTN","TMGSEQL1",260,0) ;" be ignored in the 1st file. "RTN","TMGSEQL1",261,0) ;"Output: Database is updated with data from file. "RTN","TMGSEQL1",262,0) ;"Result: 1 successful completion, 0=error "RTN","TMGSEQL1",263,0) "RTN","TMGSEQL1",264,0) new GRef,GRef1 "RTN","TMGSEQL1",265,0) new G2Ref,G2Ref1 "RTN","TMGSEQL1",266,0) new result "RTN","TMGSEQL1",267,0) "RTN","TMGSEQL1",268,0) set F2Path=$get(F2Path,FilePath) "RTN","TMGSEQL1",269,0) "RTN","TMGSEQL1",270,0) set GRef=$name(^TMP("TMG","SEQUELIMPORT","DATA",1,$J)) ;"I use this to process array "RTN","TMGSEQL1",271,0) set GRef1=$name(@GRef@(1)) ;"I use this to load file "RTN","TMGSEQL1",272,0) kill @GRef "RTN","TMGSEQL1",273,0) set result=$$FTG^%ZISH(FilePath,FileName,GRef1,6) ;"load file into a global "RTN","TMGSEQL1",274,0) if result=0 goto IFDONE "RTN","TMGSEQL1",275,0) "RTN","TMGSEQL1",276,0) set G2Ref=$name(^TMP("TMG","SEQUELIMPORT","DATA",2,$J)) ;"I use this to process array "RTN","TMGSEQL1",277,0) set G2Ref1=$name(@G2Ref@(1)) ;"I use this to load file "RTN","TMGSEQL1",278,0) kill @G2Ref "RTN","TMGSEQL1",279,0) set result=$$FTG^%ZISH(F2Path,F2Name,G2Ref1,6) ;"load file into a global "RTN","TMGSEQL1",280,0) if result=0 goto IFDONE "RTN","TMGSEQL1",281,0) "RTN","TMGSEQL1",282,0) set UserID=$get(UserID,+$get(DUZ)) "RTN","TMGSEQL1",283,0) "RTN","TMGSEQL1",284,0) set result=$$IMPORTGLOBAL(GRef,G2Ref,.ErrArray,.ChLog,.PrgCallback,UserID) "RTN","TMGSEQL1",285,0) "RTN","TMGSEQL1",286,0) ;"Note: @GRef, @G2Ref killed at end of $$IMPORTGLOBAL() "RTN","TMGSEQL1",287,0) "RTN","TMGSEQL1",288,0) do ;"record the current time as the time of last import "RTN","TMGSEQL1",289,0) . do NOW^%DTC "RTN","TMGSEQL1",290,0) . new TMGFDA,TMGMSG "RTN","TMGSEQL1",291,0) . set TMGFDA(22711,"1,",4)=% ;"#4 = LAST IMPORT DATE "RTN","TMGSEQL1",292,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;" note: ignores TMGMSG or errors. "RTN","TMGSEQL1",293,0) "RTN","TMGSEQL1",294,0) if $get(DelFiles)=1 do "RTN","TMGSEQL1",295,0) . ;"Notice: After I implemented this, I realized that I have a permissions problem "RTN","TMGSEQL1",296,0) . ;" at my site... the uploaded files belong to the uploaded user, and deletion by "RTN","TMGSEQL1",297,0) . ;" this user is being blocked. I'll leave in for now... "RTN","TMGSEQL1",298,0) . new temp "RTN","TMGSEQL1",299,0) . set temp=$$DelFile^TMGIOUTL(FilePath_FileName) "RTN","TMGSEQL1",300,0) . set temp=$$DelFile^TMGIOUTL(F2Path_F2Name) "RTN","TMGSEQL1",301,0) "RTN","TMGSEQL1",302,0) IFDONE "RTN","TMGSEQL1",303,0) quit result "RTN","TMGSEQL1",304,0) "RTN","TMGSEQL1",305,0) IMPORTGLOBAL(GRef,G2Ref,ErrArray,ChLog,PrgCallback,UserID) "RTN","TMGSEQL1",306,0) ;"Purpose: To import data from global specified. "RTN","TMGSEQL1",307,0) ;"Input: GRef -- the NAME of array holding the data to import (1st file) "RTN","TMGSEQL1",308,0) ;" Format: @GRef@(1)=OneLine "RTN","TMGSEQL1",309,0) ;" @GRef@(2)=OneLine .. etc. "RTN","TMGSEQL1",310,0) ;" Note: This is written to import a specific file "RTN","TMGSEQL1",311,0) ;" created by SequelMed Systems, filled with "RTN","TMGSEQL1",312,0) ;" patient demographics, in CVS format "RTN","TMGSEQL1",313,0) ;" Note: Array will be KILLED at the end of this function. "RTN","TMGSEQL1",314,0) ;" G2Ref -- the NAME of array holding the data to import (2nd file) "RTN","TMGSEQL1",315,0) ;" Note: Array will be KILLED at the end of this function. "RTN","TMGSEQL1",316,0) ;" ErrArray: PASS BY REFERENCE. Array to receive failed data lines. "RTN","TMGSEQL1",317,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1",318,0) ;" PrgCallback: OPTIONAL -- if supplied, then M code contained in this string "RTN","TMGSEQL1",319,0) ;" will be xecuted periodically, to allow display of a progress bar etc. "RTN","TMGSEQL1",320,0) ;" Note: the following variables with global scope will be declared and "RTN","TMGSEQL1",321,0) ;" available for use: TMGCUR (current count), TMGMAX (max count), "RTN","TMGSEQL1",322,0) ;" TMGSTART (the start time "RTN","TMGSEQL1",323,0) ;" External function can signal a request an abort by setting TMGABORT=1 "RTN","TMGSEQL1",324,0) ;" UserID : OPTIONAL -- user to receive alerts regarding errors. Default is current user (DUZ) "RTN","TMGSEQL1",325,0) ;"Output: Database is updated with data from file. "RTN","TMGSEQL1",326,0) ;"Result: 1 successful completion, 0=error "RTN","TMGSEQL1",327,0) "RTN","TMGSEQL1",328,0) new TMGInvalid ;"Will be used as a globally-scoped variable in the module "RTN","TMGSEQL1",329,0) new result set result=1 "RTN","TMGSEQL1",330,0) new delay set delay=0 "RTN","TMGSEQL1",331,0) new TMGCUR,TMGMAX,TMGSTART,TMGABORT ;"avail for PrgCallback function "RTN","TMGSEQL1",332,0) set TMGABORT=0 "RTN","TMGSEQL1",333,0) set TMGMAX=+$order(@GRef@(""),-1) "RTN","TMGSEQL1",334,0) set TMGSTART=$H ;"store starting time. "RTN","TMGSEQL1",335,0) set UserID=$get(UserID,+$get(DUZ)) "RTN","TMGSEQL1",336,0) "RTN","TMGSEQL1",337,0) new SSNArray "RTN","TMGSEQL1",338,0) do XtractSSNum(G2Ref,.SSNArray) "RTN","TMGSEQL1",339,0) "RTN","TMGSEQL1",340,0) set TMGCUR=$order(@GRef@("")) "RTN","TMGSEQL1",341,0) if TMGCUR'="" for do quit:(TMGCUR="")!(TMGABORT=1) "RTN","TMGSEQL1",342,0) . new OneLine "RTN","TMGSEQL1",343,0) . set OneLine=$get(@GRef@(TMGCUR)) "RTN","TMGSEQL1",344,0) . set result=$$ProcessPt(OneLine,.ErrArray,.ChgLog,.SSNArray,UserID) "RTN","TMGSEQL1",345,0) . set delay=delay+1 "RTN","TMGSEQL1",346,0) . if (delay>30),$get(PrgCallback)'="" do ;"update progress bar every 30 cycles "RTN","TMGSEQL1",347,0) . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGSEQL1",348,0) . . xecute PrgCallback ;"call the specified progress code. "RTN","TMGSEQL1",349,0) . . set delay=0 "RTN","TMGSEQL1",350,0) . set TMGCUR=$order(@GRef@(TMGCUR)) "RTN","TMGSEQL1",351,0) "RTN","TMGSEQL1",352,0) kill @GRef "RTN","TMGSEQL1",353,0) kill @G2Ref "RTN","TMGSEQL1",354,0) quit result "RTN","TMGSEQL1",355,0) "RTN","TMGSEQL1",356,0) "RTN","TMGSEQL1",357,0) "RTN","TMGSEQL1",358,0) ProcessPt(OneLine,ErrArray,ChgLog,SSNArray,DUZ,InputFn) "RTN","TMGSEQL1",359,0) ;"Purpose: To process one line from patient demographics file. "RTN","TMGSEQL1",360,0) ;"Input: OneLine-- One line from CVS demographics file. "RTN","TMGSEQL1",361,0) ;" Format is as follows, *** all on one line (comma delimited) "RTN","TMGSEQL1",362,0) ;" 01- patient_seq_num, "RTN","TMGSEQL1",363,0) ;" 02- facility_short_name, "RTN","TMGSEQL1",364,0) ;" 03- pat_last_name, "RTN","TMGSEQL1",365,0) ;" 04- pat_first_name, "RTN","TMGSEQL1",366,0) ;" 05- pat_account_num, "RTN","TMGSEQL1",367,0) ;" 06- pat_address, "RTN","TMGSEQL1",368,0) ;" 07- state, "RTN","TMGSEQL1",369,0) ;" 08- resp_last_name, "RTN","TMGSEQL1",370,0) ;" 09- resp_first_name, "RTN","TMGSEQL1",371,0) ;" 10- facility_seq_num, "RTN","TMGSEQL1",372,0) ;" 11- register_date, "RTN","TMGSEQL1",373,0) ;" 12- location_name, "RTN","TMGSEQL1",374,0) ;" 13- city, "RTN","TMGSEQL1",375,0) ;" 14- provider_short_name, "RTN","TMGSEQL1",376,0) ;" 15- zipcode, "RTN","TMGSEQL1",377,0) ;" 16- class_name, "RTN","TMGSEQL1",378,0) ;" 17- pat_dob, "RTN","TMGSEQL1",379,0) ;" 18- ref_prov_short_name, "RTN","TMGSEQL1",380,0) ;" 19- pat_tel_num, "RTN","TMGSEQL1",381,0) ;" 20- last_visit_days, "RTN","TMGSEQL1",382,0) ;" 21- name, "RTN","TMGSEQL1",383,0) ;" 22- description "RTN","TMGSEQL1",384,0) ;" ADDENDUM: "RTN","TMGSEQL1",385,0) ;" sometimes SEX will be appended to line. Format: "RTN","TMGSEQL1",386,0) ;" previous data^MALE or previous data^FEMALE "RTN","TMGSEQL1",387,0) ;" sometimes SSN will be appended to line. Format: "RTN","TMGSEQL1",388,0) ;" previous data^(sex)^SSNUM "RTN","TMGSEQL1",389,0) ;" ErrArray: PASS BY REFERENCE. Array to receive failed data lines. "RTN","TMGSEQL1",390,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1",391,0) ;" SSNArray: OPTIONAL -- PASS BY REFERENCE. An array with social security numbers, "RTN","TMGSEQL1",392,0) ;" as created by XtractSSNum() "RTN","TMGSEQL1",393,0) ;" DUZ: The user who will recieve alerts of errors "RTN","TMGSEQL1",394,0) ;" InputFn: OPTIONAL-- the name of a function to turn parse on csv line "RTN","TMGSEQL1",395,0) ;" default value is "ParseLine" "RTN","TMGSEQL1",396,0) ;" e.g. "MyFn" or "MyFn^MyRoutine". Must take same params as ParseLine "RTN","TMGSEQL1",397,0) ;" This will allow this code to be used on a variety of .csv files, with "RTN","TMGSEQL1",398,0) ;" different data-formats--each one with its own parser funtion. "RTN","TMGSEQL1",399,0) ;"Output: Data is put into database, if it is not there already. "RTN","TMGSEQL1",400,0) ;"Result: 1=OK To continue; 0=abort or bad data "RTN","TMGSEQL1",401,0) "RTN","TMGSEQL1",402,0) new XFn "RTN","TMGSEQL1",403,0) new PtInfo,OneErrArray "RTN","TMGSEQL1",404,0) new result set result=1 "RTN","TMGSEQL1",405,0) new AutoRegister set AutoRegister=1 "RTN","TMGSEQL1",406,0) set InputFn=$get(InputFn,"ParseLine") "RTN","TMGSEQL1",407,0) "RTN","TMGSEQL1",408,0) set XFn="set result=$$"_InputFn_"(.OneLine,.PtInfo,.SSNArray)" "RTN","TMGSEQL1",409,0) xecute XFn ;"old -- set result=$$ParseLine(.OneLine,.PtInfo,.SSNArray) "RTN","TMGSEQL1",410,0) if result'>0 goto PPtDone "RTN","TMGSEQL1",411,0) if $get(PtInfo("FACILITY"))="SAMPLE" goto PPtDone "RTN","TMGSEQL1",412,0) "RTN","TMGSEQL1",413,0) if $$UpdateDB(.PtInfo,AutoRegister,.OneErrArray,.ChgLog)=0 do "RTN","TMGSEQL1",414,0) . new count set count=+$get(ErrArray)+1 "RTN","TMGSEQL1",415,0) . set ErrArray=count "RTN","TMGSEQL1",416,0) . set ErrArray(count)=OneLine "RTN","TMGSEQL1",417,0) . merge ErrArray(count,"INFO")=OneErrArray "RTN","TMGSEQL1",418,0) . ;"------ "RTN","TMGSEQL1",419,0) . do AlertError^TMGSEQL2(OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL1",420,0) "RTN","TMGSEQL1",421,0) PPtDone "RTN","TMGSEQL1",422,0) quit result "RTN","TMGSEQL1",423,0) "RTN","TMGSEQL1",424,0) "RTN","TMGSEQL1",425,0) ParseLine(OneLine,Array,SSNArray) "RTN","TMGSEQL1",426,0) ;"Purpose: To process one line from patient demographics file. "RTN","TMGSEQL1",427,0) ;" Also gets data into an acceptible format. "RTN","TMGSEQL1",428,0) ;"Input: OneLine -- One line from CVS demographics file. (Format as per ProcessPt) "RTN","TMGSEQL1",429,0) ;" NOTE: if PASSED BY REFERENCE, then line may be altered such that SSN is "RTN","TMGSEQL1",430,0) ;" added as a 3rd piece, using ^ as a delimiter. (2nd piece used elsewhere "RTN","TMGSEQL1",431,0) ;" to store sex. "RTN","TMGSEQL1",432,0) ;" When processing line, if SSNArray doesn't provide a SSN for patient, then "RTN","TMGSEQL1",433,0) ;" this 3rd piece can provide the SSN "RTN","TMGSEQL1",434,0) ;" Array -- PASS BY REFERENCE. And OUT parameter. Any prior data killed. "RTN","TMGSEQL1",435,0) ;" Note: uses TMGInvalid (globally scoped var defined in this module) "RTN","TMGSEQL1",436,0) ;" SSNArray: OPTIONAL -- PASS BY REFERENCE. An array with social security numbers, "RTN","TMGSEQL1",437,0) ;" as created by XtractSSNum() "RTN","TMGSEQL1",438,0) ;"Output: Array is filled with Format as follows (note not all data used): "RTN","TMGSEQL1",439,0) ;" Array("FACILITY"), to hold 02- facility_short_name "RTN","TMGSEQL1",440,0) ;" Array("LAST NAME"), to hold 03- pat_last_name, "RTN","TMGSEQL1",441,0) ;" Array("FIRST NAME"), to hold 04- pat_first_name, "RTN","TMGSEQL1",442,0) ;" Array("PMS ACCOUNT NUM"), to hold 05- pat_account_num, "RTN","TMGSEQL1",443,0) ;" Array("ADDRESS1"), to hold 06- pat_address, "RTN","TMGSEQL1",444,0) ;" Array("ADDRESS2"), to hold 06- pat_address, "RTN","TMGSEQL1",445,0) ;" Array("ADDRESS3"), to hold 06- pat_address, "RTN","TMGSEQL1",446,0) ;" Array("STATE"), to hold 07- state, "RTN","TMGSEQL1",447,0) ;" Array("RESP LAST NAME"), to hold 08- resp_last_name, "RTN","TMGSEQL1",448,0) ;" Array("RESP FIRST NAME"), to hold 09- resp_first_name, "RTN","TMGSEQL1",449,0) ;" Array("CITY"), to hold 13- city, "RTN","TMGSEQL1",450,0) ;" Array("PROVIDER"), to hold 14- provider_short_name, "RTN","TMGSEQL1",451,0) ;" Array("ZIP CODE"), to hold 15- zipcode, "RTN","TMGSEQL1",452,0) ;" Array("DOB"), to hold 17- pat_dob, "RTN","TMGSEQL1",453,0) ;" Array("PHONE NUM"), to hold 19- pat_tel_num, "RTN","TMGSEQL1",454,0) ;" Array("SEX"), to hold Patient sex, if provided. "RTN","TMGSEQL1",455,0) ;" Array("SSNUM")=Social security number "RTN","TMGSEQL1",456,0) ;" Array("FULL NAME")=FIRSTNAME LASTNAME (DOB) "RTN","TMGSEQL1",457,0) ;" Array("FULL NAME2")=LASTNAME,FIRSTNAME (DOB) "RTN","TMGSEQL1",458,0) ;" Array("FULL NAME3")=LASTNAME,FIRSTNAME "RTN","TMGSEQL1",459,0) ;"Result: 1=OK To continue; 0=abort or bad data; -1 skip, but don't store as error "RTN","TMGSEQL1",460,0) "RTN","TMGSEQL1",461,0) new temp "RTN","TMGSEQL1",462,0) new result set result=1 "RTN","TMGSEQL1",463,0) "RTN","TMGSEQL1",464,0) set OneLine=$translate($get(OneLine),"""","'") ;" convert " to ' to avoid fileman error "RTN","TMGSEQL1",465,0) "RTN","TMGSEQL1",466,0) kill Array "RTN","TMGSEQL1",467,0) set Array("FACILITY")=$piece(OneLine,",",2) "RTN","TMGSEQL1",468,0) set Array("LAST NAME")=$$Trim^TMGSTUTL($piece(OneLine,",",3)) "RTN","TMGSEQL1",469,0) set Array("FIRST NAME")=$$Trim^TMGSTUTL($piece(OneLine,",",4)) "RTN","TMGSEQL1",470,0) set Array("PMS ACCOUNT NUM")=$piece(OneLine,",",5) "RTN","TMGSEQL1",471,0) set Array("ADDRESS1")=$piece(OneLine,",",6) "RTN","TMGSEQL1",472,0) set Array("STATE")=$piece(OneLine,",",7) "RTN","TMGSEQL1",473,0) set Array("RESP LAST NAME")=$piece(OneLine,",",8) "RTN","TMGSEQL1",474,0) set Array("RESP FIRST NAME")=$piece(OneLine,",",9) "RTN","TMGSEQL1",475,0) set Array("CITY")=$$Trim^TMGSTUTL($piece(OneLine,",",13),"""") "RTN","TMGSEQL1",476,0) set Array("PROVIDER")=$piece(OneLine,",",14) "RTN","TMGSEQL1",477,0) set Array("ZIP CODE")=$piece(OneLine,",",15) "RTN","TMGSEQL1",478,0) new DOB set DOB=$piece(OneLine,",",17) "RTN","TMGSEQL1",479,0) set DOB=$$Trim^TMGSTUTL(DOB) "RTN","TMGSEQL1",480,0) set DOB=$piece(DOB," ",1) ;" '03/09/05 00:00' --> '03/09/05' "RTN","TMGSEQL1",481,0) set Array("DOB")=DOB "RTN","TMGSEQL1",482,0) set Array("PHONE NUM")=$piece(OneLine,",",19) "RTN","TMGSEQL1",483,0) set Array("SEX")=$piece(OneLine,"^",2) "RTN","TMGSEQL1",484,0) "RTN","TMGSEQL1",485,0) set Array("FULL NAME")=Array("FIRST NAME")_" "_Array("LAST NAME")_" ("_Array("DOB")_")" "RTN","TMGSEQL1",486,0) set Array("FULL NAME2")=Array("LAST NAME")_","_Array("FIRST NAME")_" ("_Array("DOB")_")" "RTN","TMGSEQL1",487,0) set Array("FULL NAME3")=Array("LAST NAME")_","_Array("FIRST NAME") "RTN","TMGSEQL1",488,0) "RTN","TMGSEQL1",489,0) ;"do a lookup on abreviattion for ALL states, convert to external format "RTN","TMGSEQL1",490,0) new DIC,X,Y "RTN","TMGSEQL1",491,0) set DIC=5 ;"STATE file "RTN","TMGSEQL1",492,0) set DIC(0)="M" "RTN","TMGSEQL1",493,0) set X=Array("STATE") "RTN","TMGSEQL1",494,0) do ^DIC "RTN","TMGSEQL1",495,0) set Array("STATE")=$piece(Y,"^",2) "RTN","TMGSEQL1",496,0) "RTN","TMGSEQL1",497,0) ;"convert Sequel format to VistA format "RTN","TMGSEQL1",498,0) if Array("PROVIDER")'="" do "RTN","TMGSEQL1",499,0) . set Array("PROVIDER")=$$ConvProvider(Array("PROVIDER")) "RTN","TMGSEQL1",500,0) if Array("PROVIDER")="SKIP" set result=0 goto PLDone "RTN","TMGSEQL1",501,0) "RTN","TMGSEQL1",502,0) ;" VistA address allows for: "RTN","TMGSEQL1",503,0) ;" .111 -- address line 1 "RTN","TMGSEQL1",504,0) ;" .112 -- address line 2 "RTN","TMGSEQL1",505,0) ;" .113 -- address line 3 "RTN","TMGSEQL1",506,0) ;" BUT, each line must be 3-35 characters "RTN","TMGSEQL1",507,0) ;" Sequel puts this all on one line. "RTN","TMGSEQL1",508,0) ;" SO, I need to divide the Sequel line if not 3-35 "RTN","TMGSEQL1",509,0) new value set value=Array("ADDRESS1") "RTN","TMGSEQL1",510,0) if $length(value)'<35 do "RTN","TMGSEQL1",511,0) . new s1,s2 "RTN","TMGSEQL1",512,0) . do NiceSplit^TMGSTUTL(value,35,.s1,.s2,3) "RTN","TMGSEQL1",513,0) . set Array("ADDRESS1")=s1 "RTN","TMGSEQL1",514,0) . if $length(s2)'<35 do "RTN","TMGSEQL1",515,0) . . do NiceSplit^TMGSTUTL(s1,35,.s1,.s2,3) "RTN","TMGSEQL1",516,0) . . set Array("ADDRESS2")=s1 ;"<-- is this correct? "RTN","TMGSEQL1",517,0) . . if s2'="" set Array("ADDRESS3")=$extract(s2,1,35) "RTN","TMGSEQL1",518,0) . else set Array("ADDRESS2")=s2 "RTN","TMGSEQL1",519,0) "RTN","TMGSEQL1",520,0) ;"Ensure proper length of city. "RTN","TMGSEQL1",521,0) set Array("CITY")=$extract(Array("CITY"),1,15) "RTN","TMGSEQL1",522,0) if $length(Array("CITY"))=1 set Array("CITY")=Array("CITY")_" " "RTN","TMGSEQL1",523,0) "RTN","TMGSEQL1",524,0) ;"Ensure proper length of phone "RTN","TMGSEQL1",525,0) if $length(Array("PHONE NUM"))<7 kill Array("PHONE NUM") "RTN","TMGSEQL1",526,0) "RTN","TMGSEQL1",527,0) new AcctNum set AcctNum=$get(Array("PMS ACCOUNT NUM")) "RTN","TMGSEQL1",528,0) new SSNum set SSNum=$get(SSNArray(AcctNum)) "RTN","TMGSEQL1",529,0) if SSNum=999999999 set SSNum=0 "RTN","TMGSEQL1",530,0) if +SSNum=0 do ;"see if 3rd ^ piece holds SSNum data "RTN","TMGSEQL1",531,0) . set SSNum=$piece(OneLine,"^",3) ;"note this won't overwrite valid data from SSNArray() "RTN","TMGSEQL1",532,0) if SSNum>0 do "RTN","TMGSEQL1",533,0) . set Array("SSNUM")=SSNum "RTN","TMGSEQL1",534,0) . set $piece(OneLine,"^",3)=SSNum "RTN","TMGSEQL1",535,0) "RTN","TMGSEQL1",536,0) if result'=0 do "RTN","TMGSEQL1",537,0) . if $$InvalPtName(Array("FIRST NAME"),Array("LAST NAME"))=1 set result=-1 quit "RTN","TMGSEQL1",538,0) . if $$InactivePt(Array("PMS ACCOUNT NUM"),.SSNArray)=1 do "RTN","TMGSEQL1",539,0) xx . . set result=-1 "RTN","TMGSEQL1",540,0) . . ;"write !,"Skipping: ",Array("FULL NAME3"),! ;"temp "RTN","TMGSEQL1",541,0) "RTN","TMGSEQL1",542,0) PLDone "RTN","TMGSEQL1",543,0) quit result "RTN","TMGSEQL1",544,0) "RTN","TMGSEQL1",545,0) "RTN","TMGSEQL1",546,0) ConvProvider(SequelProvider) "RTN","TMGSEQL1",547,0) ;"Purpose: To convert Sequel provider shortname to VistA file 200 name. "RTN","TMGSEQL1",548,0) ;"Input: SequelProvider "RTN","TMGSEQL1",549,0) ;"Result: VistA provider name (string), or "" if not found, or "SKIP" if not to be used "RTN","TMGSEQL1",550,0) "RTN","TMGSEQL1",551,0) new result set result="" "RTN","TMGSEQL1",552,0) "RTN","TMGSEQL1",553,0) if $$InvalidProvider(SequelProvider) set result="SKIP" goto ConPrDone "RTN","TMGSEQL1",554,0) if SequelProvider="SAMPLE" set result="SKIP" goto ConPrDone "RTN","TMGSEQL1",555,0) "RTN","TMGSEQL1",556,0) "RTN","TMGSEQL1",557,0) new TMGARRAY,TMGMSG "RTN","TMGSEQL1",558,0) do FIND^DIC(200,,".01",,SequelProvider,"*","TMG",,,"TMGARRAY","TMGMSG") "RTN","TMGSEQL1",559,0) if +TMGARRAY("DILIST",0)>0 do "RTN","TMGSEQL1",560,0) . set result=TMGARRAY("DILIST",1,1) "RTN","TMGSEQL1",561,0) else do "RTN","TMGSEQL1",562,0) . new DIC "RTN","TMGSEQL1",563,0) . set DIC=200 "RTN","TMGSEQL1",564,0) . ;"try converting name and doing quiet lookup (KTOPPEN->TOPPEN,K) "RTN","TMGSEQL1",565,0) . set X=$extract(SequelProvider,2,99)_","_$extract(SequelProvider,1) "RTN","TMGSEQL1",566,0) . do ^DIC "RTN","TMGSEQL1",567,0) . if (+Y=-1)&(1=0) do ;"<--- FEATURE TURNED OFF. If not found, don't ask (no longer needed) "RTN","TMGSEQL1",568,0) . . if $data(TMGInvalid(SequelProvider))'=0 quit "RTN","TMGSEQL1",569,0) . . write !,"Please help match the Sequel 'shortname' to a VistA provider name.",! "RTN","TMGSEQL1",570,0) . . write "This should have to be done only once.",! "RTN","TMGSEQL1",571,0) . . write "Enter ^ if the provider name is not valid.",! "RTN","TMGSEQL1",572,0) . . write "Please enter VistA provider name for: '",SequelProvider,"'",! "RTN","TMGSEQL1",573,0) . . set DIC(0)="AEQM" "RTN","TMGSEQL1",574,0) . . do ^DIC "RTN","TMGSEQL1",575,0) . . write ! "RTN","TMGSEQL1",576,0) . if +Y>-1 do "RTN","TMGSEQL1",577,0) . . new DFN set DFN=+Y "RTN","TMGSEQL1",578,0) . . new TMGFDA set TMGFDA(200,DFN_",",22702)=SequelProvider "RTN","TMGSEQL1",579,0) . . kill TMGMSG "RTN","TMGSEQL1",580,0) . . do FILE^DIE(,"TMGFDA","TMGMSG") ;"ignore errors "RTN","TMGSEQL1",581,0) . . set result=$piece(Y,"^",2) "RTN","TMGSEQL1",582,0) . else do "RTN","TMGSEQL1",583,0) . . set TMGInvalid(SequelProvider)="" "RTN","TMGSEQL1",584,0) ConPrDone "RTN","TMGSEQL1",585,0) quit result "RTN","TMGSEQL1",586,0) "RTN","TMGSEQL1",587,0) "RTN","TMGSEQL1",588,0) InvalPtName(FName,LName) "RTN","TMGSEQL1",589,0) ;"Purpose: To determine if the Patient name is invalid (i.e. CAP TOPPENBERG, or INSURANCE INSURANCE etc.) "RTN","TMGSEQL1",590,0) ;"Input: FName,LName -- the first and last names "RTN","TMGSEQL1",591,0) ;"Result: 1 if name is invalid, 0 if OK name "RTN","TMGSEQL1",592,0) "RTN","TMGSEQL1",593,0) new result set result=0 "RTN","TMGSEQL1",594,0) "RTN","TMGSEQL1",595,0) if FName="CAP" do ;"screen out 'CAP TOPPENBERG' etc ?? entries ?? "RTN","TMGSEQL1",596,0) . new DIC set DIC=200 "RTN","TMGSEQL1",597,0) . set DIC(0)="M" "RTN","TMGSEQL1",598,0) . set X=LName "RTN","TMGSEQL1",599,0) . do ^DIC "RTN","TMGSEQL1",600,0) . if +Y>0 set result=1 "RTN","TMGSEQL1",601,0) "RTN","TMGSEQL1",602,0) if (FName="INSURANCE")&(LName="INSURANCE") set result=1 "RTN","TMGSEQL1",603,0) "RTN","TMGSEQL1",604,0) quit result "RTN","TMGSEQL1",605,0) "RTN","TMGSEQL1",606,0) "RTN","TMGSEQL1",607,0) InactivePt(PMSAcctNum,SSNArray) "RTN","TMGSEQL1",608,0) ;"Purpose: to determine if patient is inactive, and should be skipped. "RTN","TMGSEQL1",609,0) ;" This is determined by testing for existence of AccountNumber in SSNArray. "RTN","TMGSEQL1",610,0) ;" SSNArray is created from the 2nd demographics file. This is a list of ACTIVE patients, "RTN","TMGSEQL1",611,0) ;" which is different from the 1st demographics file--which holds ALL patients. "RTN","TMGSEQL1",612,0) ;"Input: PMSAcctNum -- as stored in PtInfo("PMS ACCOUNT NUM") "RTN","TMGSEQL1",613,0) ;" SSNArray: PASS BY REFERENCE. An array with social security numbers, as created by XtractSSNum() "RTN","TMGSEQL1",614,0) ;"Result: 1 if patient is INACTIVE, and should be skipped. "RTN","TMGSEQL1",615,0) ;" 0 if OK to use "RTN","TMGSEQL1",616,0) "RTN","TMGSEQL1",617,0) new result "RTN","TMGSEQL1",618,0) set result=+$get(SSNArray(PMSAcctNum))'>0 "RTN","TMGSEQL1",619,0) quit result "RTN","TMGSEQL1",620,0) "RTN","TMGSEQL1",621,0) "RTN","TMGSEQL1",622,0) InvalidProvider(SequelProvider) "RTN","TMGSEQL1",623,0) ;"Purpose: To return if provider should not be used (i.e. cause data to be skipped) "RTN","TMGSEQL1",624,0) ;"Input: SequelProvider "RTN","TMGSEQL1",625,0) ;"Result: 0: OK to use provider "RTN","TMGSEQL1",626,0) ;" 1: Don't use provider "RTN","TMGSEQL1",627,0) "RTN","TMGSEQL1",628,0) new result set result=0 "RTN","TMGSEQL1",629,0) "RTN","TMGSEQL1",630,0) if SequelProvider="SAMPLE" set result=1 "RTN","TMGSEQL1",631,0) if SequelProvider="GREENEVILLE" set result=1 "RTN","TMGSEQL1",632,0) if SequelProvider="AFOSTER" set result=1 "RTN","TMGSEQL1",633,0) if SequelProvider="AFTON" set result=1 "RTN","TMGSEQL1",634,0) if SequelProvider="JWRIGHT" set result=1 ;"not an active provider "RTN","TMGSEQL1",635,0) ;"These providers are leaving group, so don't import their data. "RTN","TMGSEQL1",636,0) if SequelProvider="CPERRY" set result=1 "RTN","TMGSEQL1",637,0) if SequelProvider="OSWARNER" set result=1 "RTN","TMGSEQL1",638,0) if SequelProvider="SGILES" set result=1 "RTN","TMGSEQL1",639,0) if SequelProvider="SPENNY" set result=1 "RTN","TMGSEQL1",640,0) if SequelProvider="TFULLER" set result=1 "RTN","TMGSEQL1",641,0) "RTN","TMGSEQL1",642,0) quit result "RTN","TMGSEQL1",643,0) "RTN","TMGSEQL1",644,0) "RTN","TMGSEQL1",645,0) UpdateDB(PtInfo,AutoRegister,ErrArray,ChgLog) "RTN","TMGSEQL1",646,0) ;"Purpose: To put that data from the PtInfo array into the database (if needed) "RTN","TMGSEQL1",647,0) ;"Input: PtInfo -- array (PASS BY REFERENCE), with the following items being used: "RTN","TMGSEQL1",648,0) ;" PtInfo("LAST NAME"), to hold 03- pat_last_name, "RTN","TMGSEQL1",649,0) ;" PtInfo("FIRST NAME"), to hold 04- pat_first_name, "RTN","TMGSEQL1",650,0) ;" PtInfo("PMS ACCOUNT NUM") ----> field 22701 (custom field) "RTN","TMGSEQL1",651,0) ;" PtInfo("ADDRESS") ----> field .111 "RTN","TMGSEQL1",652,0) ;" PtInfo("STATE") ----> field .115 "RTN","TMGSEQL1",653,0) ;" PtInfo("CITY") ----> field .114 "RTN","TMGSEQL1",654,0) ;" PtInfo("ZIP CODE") ----> field .1112 "RTN","TMGSEQL1",655,0) ;" PtInfo("PHONE NUM") ----> field .131 "RTN","TMGSEQL1",656,0) ;" PtInfo("PROVIDER") ----> field .1041 "RTN","TMGSEQL1",657,0) ;" PtInfo("SSNUM") ----> field .09 "RTN","TMGSEQL1",658,0) ;" AutoRegister: if 1, then patient will be automatically added/registered "RTN","TMGSEQL1",659,0) ;" ErrArray -- PASS BY REFERENCE. And OUT parameter to get back error info. "RTN","TMGSEQL1",660,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1",661,0) ;"Output: Data is put into database, if it is not there already. "RTN","TMGSEQL1",662,0) ;"Result: 1 successful completion, 0=error "RTN","TMGSEQL1",663,0) "RTN","TMGSEQL1",664,0) new Entry "RTN","TMGSEQL1",665,0) new result set result=1 "RTN","TMGSEQL1",666,0) new Name,TMGDOB,DFN "RTN","TMGSEQL1",667,0) new TMGARRAY,TMGMSG "RTN","TMGSEQL1",668,0) new PriorErrorFound "RTN","TMGSEQL1",669,0) new NewInfo "RTN","TMGSEQL1",670,0) new IENS "RTN","TMGSEQL1",671,0) new index "RTN","TMGSEQL1",672,0) kill ErrArray "RTN","TMGSEQL1",673,0) new TMGDEBUG set TMGDEBUG=-1 ;"//EXTRA QUIET mode --> shut down TMGDBAPI messages "RTN","TMGSEQL1",674,0) "RTN","TMGSEQL1",675,0) "RTN","TMGSEQL1",676,0) ;"NOTE: I need to have some method such that IF a patient is positively matched "RTN","TMGSEQL1",677,0) ;" (i.e. via SSNUM or PMS Account number), THEN changes in spelling of name, or "RTN","TMGSEQL1",678,0) ;" DOB on Sequel side should be reflected in VistA. Currently, I don't this "RTN","TMGSEQL1",679,0) ;" this happens. "RTN","TMGSEQL1",680,0) "RTN","TMGSEQL1",681,0) new Fields "RTN","TMGSEQL1",682,0) set Fields(22701)="PMS ACCOUNT NUM" "RTN","TMGSEQL1",683,0) set Fields(.111)="ADDRESS1" "RTN","TMGSEQL1",684,0) set Fields(.112)="ADDRESS2" "RTN","TMGSEQL1",685,0) set Fields(.113)="ADDRESS3" "RTN","TMGSEQL1",686,0) set Fields(.115)="STATE" "RTN","TMGSEQL1",687,0) set Fields(.114)="CITY" "RTN","TMGSEQL1",688,0) set Fields(.1112)="ZIP CODE" "RTN","TMGSEQL1",689,0) set Fields(.131)="PHONE NUM" "RTN","TMGSEQL1",690,0) set Fields(.1041)="PROVIDER" "RTN","TMGSEQL1",691,0) set Fields(.02)="SEX" "RTN","TMGSEQL1",692,0) set Fields(.09)="SSNUM" "RTN","TMGSEQL1",693,0) set Fields="22701;.111;.112;.113;.115;.114;.1112;.131;.1041;.09" "RTN","TMGSEQL1",694,0) "RTN","TMGSEQL1",695,0) set Name=$get(PtInfo("LAST NAME"))_","_$get(PtInfo("FIRST NAME")) "RTN","TMGSEQL1",696,0) set Name=$$FormatName^TMGMISC(Name) "RTN","TMGSEQL1",697,0) set TMGDOB=$get(PtInfo("DOB")) "RTN","TMGSEQL1",698,0) "RTN","TMGSEQL1",699,0) set Entry(.01)=Name "RTN","TMGSEQL1",700,0) set Entry(.03)=TMGDOB "RTN","TMGSEQL1",701,0) if $get(PtInfo("SEX"))'="" set Entry(.02)=$get(PtInfo("SEX")) "RTN","TMGSEQL1",702,0) set Entry(.09)=$get(PtInfo("SSNUM")) "RTN","TMGSEQL1",703,0) "RTN","TMGSEQL1",704,0) set DFN=$$GetDFN(.PtInfo) "RTN","TMGSEQL1",705,0) "RTN","TMGSEQL1",706,0) if (DFN=0)&($get(AutoRegister)=1) do "RTN","TMGSEQL1",707,0) . set ErrArray=-1 ;"extra quiet mode. "RTN","TMGSEQL1",708,0) . if $get(Entry(.02))="" do ;"autopick gender if missing "RTN","TMGSEQL1",709,0) . . new AutoPick "RTN","TMGSEQL1",710,0) . . set AutoPick=$$GET1^DIQ(22711,"1,","PICK GENDER FROM NAME?","I") "RTN","TMGSEQL1",711,0) . . if AutoPick'=1 quit "RTN","TMGSEQL1",712,0) . . set Entry(.02)=$$GetSex^TMGSEQL2($get(PtInfo("FIRST NAME"))) "RTN","TMGSEQL1",713,0) . ;"OK, can't find, so will add new patient. "RTN","TMGSEQL1",714,0) . set DFN=+$$AddNewPt^TMGGDFN(.Entry,.ErrArray) "RTN","TMGSEQL1",715,0) . if DFN'=0 set ChLog(Name_" "_TMGDOB,0)="ADDED PATIENT: "_Name_" "_TMGDOB "RTN","TMGSEQL1",716,0) if DFN=0 do goto UDBDone ;"failure "RTN","TMGSEQL1",717,0) . set result=0 "RTN","TMGSEQL1",718,0) . set ErrArray(0)=$$NameError^TMGSEQL2(.ErrArray) ;"get name if DIERR encountered. "RTN","TMGSEQL1",719,0) . if ErrArray(0)["DOB" do "RTN","TMGSEQL1",720,0) . . ;"write !,"DOB error found for: ",PtInfo("FULL NAME"),! "RTN","TMGSEQL1",721,0) . if ErrArray(0)="" do "RTN","TMGSEQL1",722,0) . . set ErrArray(0)="PATIENT NOT IN DATABASE:" ;"if changed, also change in TMGSEQL2.m "RTN","TMGSEQL1",723,0) set IENS=DFN_"," "RTN","TMGSEQL1",724,0) "RTN","TMGSEQL1",725,0) ;"use DFN(IEN in file 2) to get data into database "RTN","TMGSEQL1",726,0) do GETS^DIQ(2,IENS,Fields,"","TMGARRAY","TMGMSG") "RTN","TMGSEQL1",727,0) "RTN","TMGSEQL1",728,0) ;"check for errors. "RTN","TMGSEQL1",729,0) if $data(TMGMSG("DIERR"))'=0 do goto UDBDone "RTN","TMGSEQL1",730,0) . set result=0 "RTN","TMGSEQL1",731,0) . merge ErrArray=TMGMSG("DIERR") "RTN","TMGSEQL1",732,0) . ;"do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSEQL1",733,0) kill TMGMSG "RTN","TMGSEQL1",734,0) "RTN","TMGSEQL1",735,0) ;"If any data in data base differs from Array, setup NewInfo "RTN","TMGSEQL1",736,0) new UpdateNeeded set UpdateNeeded=0 "RTN","TMGSEQL1",737,0) new abort set abort=0 "RTN","TMGSEQL1",738,0) set index=$order(Fields("")) "RTN","TMGSEQL1",739,0) for do quit:(+index'>0)!(abort=1) "RTN","TMGSEQL1",740,0) . new field set field=Fields(index) "RTN","TMGSEQL1",741,0) . if $data(PtInfo(field)),$get(TMGARRAY(2,IENS,index))'=$get(PtInfo(field)) do "RTN","TMGSEQL1",742,0) . . new value set value=$get(PtInfo(field)) "RTN","TMGSEQL1",743,0) . . if index=.1112 do "RTN","TMGSEQL1",744,0) . . . if +value'=0 set NewInfo(index)=value "RTN","TMGSEQL1",745,0) . . else if (index=.09)&(+value'=0)&(+TMGARRAY(2,IENS,index)'=0) do "RTN","TMGSEQL1",746,0) . . . if TMGARRAY(2,IENS,index)["P" do quit "RTN","TMGSEQL1",747,0) . . . . set NewInfo(index)=value "RTN","TMGSEQL1",748,0) . . . ;"we have CONFLICTING SOCIAL SECURITY NUMBERS --> PROBLEM... "RTN","TMGSEQL1",749,0) . . . set ErrArray(0)="CONFLICTING SS-NUMBERS: " ;"NOTE! if error message format is changed, also change in TMGSEQL2 "RTN","TMGSEQL1",750,0) . . . set ErrArray(0)=ErrArray(0)_"Sequel#="_PtInfo(field)_" vs. VistA#="_TMGARRAY(2,IENS,index) "RTN","TMGSEQL1",751,0) . . . set abort=1,result=0 "RTN","TMGSEQL1",752,0) . . else set NewInfo(index)=value "RTN","TMGSEQL1",753,0) . . set UpdateNeeded=1 "RTN","TMGSEQL1",754,0) . set index=$order(Fields(index)) "RTN","TMGSEQL1",755,0) "RTN","TMGSEQL1",756,0) if (UpdateNeeded=0)!(abort=1) goto UDBDone "RTN","TMGSEQL1",757,0) "RTN","TMGSEQL1",758,0) ;"Setup FDA array for database update "RTN","TMGSEQL1",759,0) new TMGFDA "RTN","TMGSEQL1",760,0) set index=$order(NewInfo("")) "RTN","TMGSEQL1",761,0) if index'="" do "RTN","TMGSEQL1",762,0) . for do quit:(+index'>0) "RTN","TMGSEQL1",763,0) . . set TMGFDA(2,IENS,index)=NewInfo(index) "RTN","TMGSEQL1",764,0) . . set index=$order(NewInfo(index)) "RTN","TMGSEQL1",765,0) . ; "RTN","TMGSEQL1",766,0) . do FILE^DIE("E","TMGFDA","TMGMSG") "RTN","TMGSEQL1",767,0) . if $data(TMGMSG("DIERR"))'=0 do ;"goto UDBDone "RTN","TMGSEQL1",768,0) . . set result=0 "RTN","TMGSEQL1",769,0) . . merge ErrArray=TMGMSG("DIERR") "RTN","TMGSEQL1",770,0) "RTN","TMGSEQL1",771,0) merge ChLog($get(Name,"?")_" "_$get(TMGDOB,"?"),1)=NewInfo "RTN","TMGSEQL1",772,0) "RTN","TMGSEQL1",773,0) UDBDone "RTN","TMGSEQL1",774,0) quit result "RTN","TMGSEQL1",775,0) "RTN","TMGSEQL1",776,0) "RTN","TMGSEQL1",777,0) GetDFN(PtInfo) "RTN","TMGSEQL1",778,0) ;"Purpose: Serve as interface to ^TMGGDFN functions (using PtInfo as input) "RTN","TMGSEQL1",779,0) ;"Input: PtInfo, Array of PtInfo, as defined in UpdateDB, and created by ParseLine "RTN","TMGSEQL1",780,0) ;"Result: the IEN in file 2 (i.e. DFN) if found, otherwise 0 if not found. "RTN","TMGSEQL1",781,0) "RTN","TMGSEQL1",782,0) new Entry,Name,DOB,DFN "RTN","TMGSEQL1",783,0) "RTN","TMGSEQL1",784,0) set Name=$get(PtInfo("LAST NAME"))_","_$get(PtInfo("FIRST NAME")) "RTN","TMGSEQL1",785,0) set Name=$$FormatName^TMGMISC(Name) "RTN","TMGSEQL1",786,0) set DOB=$get(PtInfo("DOB")) "RTN","TMGSEQL1",787,0) "RTN","TMGSEQL1",788,0) set Entry(.01)=Name "RTN","TMGSEQL1",789,0) set Entry(.03)=DOB "RTN","TMGSEQL1",790,0) set Entry(.02)=$get(PtInfo("SEX")) "RTN","TMGSEQL1",791,0) set Entry(.09)=$get(PtInfo("SSNUM")) "RTN","TMGSEQL1",792,0) set DFN=+$$LookupPatient^TMGGDFN(.Entry) ;"get IEN in file 2 of patient "RTN","TMGSEQL1",793,0) ;"do an extended search with increasing intensity. "RTN","TMGSEQL1",794,0) if +DFN=0 set DFN=$$ExtraLookup^TMGGDFN(.Entry,1) "RTN","TMGSEQL1",795,0) if +DFN=0 set DFN=$$ExtraLookup^TMGGDFN(.Entry,2) "RTN","TMGSEQL1",796,0) if +DFN=0 set DFN=$$ExtraLookup^TMGGDFN(.Entry,3) "RTN","TMGSEQL1",797,0) "RTN","TMGSEQL1",798,0) quit DFN "RTN","TMGSEQL1",799,0) "RTN","TMGSEQL1",800,0) "RTN","TMGSEQL1",801,0) "RTN","TMGSEQL1",802,0) XtractSSNum(G2Ref,SSNArray) "RTN","TMGSEQL1",803,0) ;"Purpose: To extract info from 2nd demographics file into an array of SSNums. "RTN","TMGSEQL1",804,0) ;"Input: G2Ref - Name of global array holding 2nd demographics file "RTN","TMGSEQL1",805,0) ;" Note: Format of each line is as follows: "RTN","TMGSEQL1",806,0) ;" scratchNum,AccountNumber,LastName,FirstName,SSNUM ... (other data is redundant) "RTN","TMGSEQL1",807,0) ;" i.e. SSNUM is the 5th piece "RTN","TMGSEQL1",808,0) ;" SSNArray -- PASS BY REFERENCE. An OUT parameter. See format below "RTN","TMGSEQL1",809,0) ;"Output: SSNArray will be filled as follows: "RTN","TMGSEQL1",810,0) ;" SSNArray(SequelAccountNumber)=SSNum "RTN","TMGSEQL1",811,0) ;"Result: None "RTN","TMGSEQL1",812,0) ;"Note: 3/2/06 modification: "RTN","TMGSEQL1",813,0) ;" An entry for every SequelAccountNumber will be created. If SSNum is invalid, it will "RTN","TMGSEQL1",814,0) ;" be converted to 0, but an entry will still be created, i.e. "RTN","TMGSEQL1",815,0) ;" SSNArray(SequelAccountNumber)=0 "RTN","TMGSEQL1",816,0) "RTN","TMGSEQL1",817,0) "RTN","TMGSEQL1",818,0) new i "RTN","TMGSEQL1",819,0) "RTN","TMGSEQL1",820,0) set i=$order(@G2Ref@("")) "RTN","TMGSEQL1",821,0) if i'="" for do quit:(i="") "RTN","TMGSEQL1",822,0) . new OneLine,AcctNum,SSNum "RTN","TMGSEQL1",823,0) . set OneLine=$get(@G2Ref@(i)) "RTN","TMGSEQL1",824,0) . set AcctNum=$piece(OneLine,",",2) "RTN","TMGSEQL1",825,0) . set SSNum=$$Trim^TMGSTUTL($piece(OneLine,",",5)) "RTN","TMGSEQL1",826,0) . new value set value=0 ;"default value "RTN","TMGSEQL1",827,0) . if +SSNum'<999999 do ;"force at least 6 digits --> allow 0000 11 1111 "RTN","TMGSEQL1",828,0) . . if $length(SSNum)'=9 do "RTN","TMGSEQL1",829,0) . . . set SSNArray("ERRORS",AcctNum)=SSNum ;"leaves value="" --> not used "RTN","TMGSEQL1",830,0) . . else do "RTN","TMGSEQL1",831,0) . . . ;"set SSNArray(AcctNum)=SSNum "RTN","TMGSEQL1",832,0) . . . set value=SSNum "RTN","TMGSEQL1",833,0) . set SSNArray(AcctNum)=value "RTN","TMGSEQL1",834,0) . set i=$order(@G2Ref@(i)) "RTN","TMGSEQL1",835,0) "RTN","TMGSEQL1",836,0) quit "RTN","TMGSEQL1",837,0) "RTN","TMGSEQL1",838,0) "RTN","TMGSEQL1B") 0^75^B44760 "RTN","TMGSEQL1B",1,0) TMGSEQL1 ;TMG/kst/Interface with SequelSystems PMS ;03/25/06 "RTN","TMGSEQL1B",2,0) ;;1.0;TMG-LIB;**1**;01/09/06 "RTN","TMGSEQL1B",3,0) "RTN","TMGSEQL1B",4,0) ;"TMG SEQUEL IMPORT FUNCTIONS "RTN","TMGSEQL1B",5,0) ;"Kevin Toppenberg MD "RTN","TMGSEQL1B",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGSEQL1B",7,0) ;"1-9-2006 "RTN","TMGSEQL1B",8,0) "RTN","TMGSEQL1B",9,0) "RTN","TMGSEQL1B",10,0) ;"======================================================================= "RTN","TMGSEQL1B",11,0) ;" API -- Public Functions. "RTN","TMGSEQL1B",12,0) ;"======================================================================= "RTN","TMGSEQL1B",13,0) ;"ASKIMPORT "RTN","TMGSEQL1B",14,0) ;"RUNNOW provide an entry point for running import NOW. This will delete prior alerts "RTN","TMGSEQL1B",15,0) ;"AUTOIN ;"entry point for scheduled task "RTN","TMGSEQL1B",16,0) ;"QUIETIN "RTN","TMGSEQL1B",17,0) "RTN","TMGSEQL1B",18,0) ;"$$IMPORTFILE(FilePath,FileName,F2Name,ErrArray,ChgLog,PrgCallback,F2Path,DelFiles,UserID) "RTN","TMGSEQL1B",19,0) ;"$$IMPORTGLOBAL(GRef,G2Ref,ErrArray,ChgLog,PrgCallback,UserID) "RTN","TMGSEQL1B",20,0) "RTN","TMGSEQL1B",21,0) ;"======================================================================= "RTN","TMGSEQL1B",22,0) ;"PRIVATE API FUNCTIONS "RTN","TMGSEQL1B",23,0) ;"======================================================================= "RTN","TMGSEQL1B",24,0) ;"$$ProcessPt(OneLine,ErrArray,ChgLog,SSNArray,DUZ) "RTN","TMGSEQL1B",25,0) ;"$$ParseLine(OneLine,Array,SSNArray) "RTN","TMGSEQL1B",26,0) ;"UpdateDB(PtInfo,AutoRegister,ErrArray,ChgLog) "RTN","TMGSEQL1B",27,0) ;"$$InactivePt(PMSAcctNum,SSNArray) "RTN","TMGSEQL1B",28,0) ;"$$InvalidProvider(SequelProvider) "RTN","TMGSEQL1B",29,0) ;"$$InvalPtName(FName,LName) "RTN","TMGSEQL1B",30,0) "RTN","TMGSEQL1B",31,0) "RTN","TMGSEQL1B",32,0) ;"======================================================================= "RTN","TMGSEQL1B",33,0) ;"DEPENDENCIES "RTN","TMGSEQL1B",34,0) ;"TMGIOUTL "RTN","TMGSEQL1B",35,0) ;"TMGMISC "RTN","TMGSEQL1B",36,0) ;"======================================================================= "RTN","TMGSEQL1B",37,0) ;"======================================================================= "RTN","TMGSEQL1B",38,0) "RTN","TMGSEQL1B",39,0) "RTN","TMGSEQL1B",40,0) "RTN","TMGSEQL1B",41,0) ;"======================================================================= "RTN","TMGSEQL1B",42,0) ;" Below are three custom files that are used by the TMGSEQL* code "RTN","TMGSEQL1B",43,0) ;"======================================================================= "RTN","TMGSEQL1B",44,0) "RTN","TMGSEQL1B",45,0) "RTN","TMGSEQL1B",46,0) ;"File: 22706 TMG DEMOGRAPHICS IMPORT ERRORS Branch: 1 "RTN","TMGSEQL1B",47,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGSEQL1B",48,0) ;"=============================================================================== "RTN","TMGSEQL1B",49,0) ;" 1 0;1 .01 ACCOUNT NUMBER [RNJ9,0] "RTN","TMGSEQL1B",50,0) ;" 2 4;1 .02 CREATION DATE [D] "RTN","TMGSEQL1B",51,0) ;" 3 4;2 .03 PATIENT NAME [F] "RTN","TMGSEQL1B",52,0) ;" 4 0;2 1 MESSAGE [F] "RTN","TMGSEQL1B",53,0) ;" 2;0 2 IMPORT DATA <-WP [22706.02] "RTN","TMGSEQL1B",54,0) ;" 5 -0;1 .01 -IMPORT DATA [W] "RTN","TMGSEQL1B",55,0) ;" 3;0 3 DIERR MESSAGE <-WP [22706.03] "RTN","TMGSEQL1B",56,0) ;" 6 -0;1 .01 -DIERR MESSAGE [W] "RTN","TMGSEQL1B",57,0) ;" 7 4;3 4 ALERT IEN [NJ9,0] "RTN","TMGSEQL1B",58,0) ;" <> <> <> "RTN","TMGSEQL1B",59,0) ;" A.) FILE NAME:------------- TMG DEMOGRAPHICS IMPORT ERRORS "RTN","TMGSEQL1B",60,0) ;" F.) FILE ACCESS: "RTN","TMGSEQL1B",61,0) ;" B.) FILE NUMBER:----------- 22706 DD______ @ "RTN","TMGSEQL1B",62,0) ;" Read____ @ "RTN","TMGSEQL1B",63,0) ;" C.) NUM OF FLDS:----------- 9 Write___ @ "RTN","TMGSEQL1B",64,0) ;" Delete__ @ "RTN","TMGSEQL1B",65,0) ;" D.) DATA GLOBAL:----------- ^TMG(22706, Laygo___ @ "RTN","TMGSEQL1B",66,0) ;" "RTN","TMGSEQL1B",67,0) ;" E.) TOTAL GLOBAL ENTRIES:-- 76 G.) PRINTING STATUS:-- Off "RTN","TMGSEQL1B",68,0) ;"================================================================================ "RTN","TMGSEQL1B",69,0) "RTN","TMGSEQL1B",70,0) "RTN","TMGSEQL1B",71,0) "RTN","TMGSEQL1B",72,0) ;"File: 22707 TMG NAME SEX Branch: 1 "RTN","TMGSEQL1B",73,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGSEQL1B",74,0) ;"=============================================================================== "RTN","TMGSEQL1B",75,0) ;" 1 0;1 .01 FIRST NAME [RF] "RTN","TMGSEQL1B",76,0) ;" 2 0;2 1 SEX [S] "RTN","TMGSEQL1B",77,0) ;"<> <> <> "RTN","TMGSEQL1B",78,0) ;" A.) FILE NAME:------------- TMG NAME SEX "RTN","TMGSEQL1B",79,0) ;" F.) FILE ACCESS: "RTN","TMGSEQL1B",80,0) ;" B.) FILE NUMBER:----------- 22707 DD______ @ "RTN","TMGSEQL1B",81,0) ;" Read____ @ "RTN","TMGSEQL1B",82,0) ;" C.) NUM OF FLDS:----------- 2 Write___ @ "RTN","TMGSEQL1B",83,0) ;" Delete__ @ "RTN","TMGSEQL1B",84,0) ;" D.) DATA GLOBAL:----------- ^TMG(22707, Laygo___ @ "RTN","TMGSEQL1B",85,0) ;" "RTN","TMGSEQL1B",86,0) ;" E.) TOTAL GLOBAL ENTRIES:-- 698 G.) PRINTING STATUS:-- Off "RTN","TMGSEQL1B",87,0) ;"================================================================================ "RTN","TMGSEQL1B",88,0) "RTN","TMGSEQL1B",89,0) "RTN","TMGSEQL1B",90,0) "RTN","TMGSEQL1B",91,0) ;"File: 22711 TMG UPLOAD SETTINGS Branch: 1 "RTN","TMGSEQL1B",92,0) ;"REF NODE;PIECE FLD NUM FIELD NAME "RTN","TMGSEQL1B",93,0) ;"=============================================================================== "RTN","TMGSEQL1B",94,0) ;" 1 0;1 .01 NAME [RFX] "RTN","TMGSEQL1B",95,0) ;" 2 0;2 1 DEBUG SHOW [NJ1,0X] "RTN","TMGSEQL1B",96,0) ;" 3 1;1 1.1 DEBUG OUTPUT FILE [F] "RTN","TMGSEQL1B",97,0) ;" 4 2;1 1.15 DEBUG OUTPUT PATH [F] "RTN","TMGSEQL1B",98,0) ;" 5 1;2 1.2 DEBUG CUMULATIVE [NJ1,0] "RTN","TMGSEQL1B",99,0) ;" 6 3;1 2 IMPORT DATAFILE NAME [F] "RTN","TMGSEQL1B",100,0) ;" 7 5;1 2.1 IMPORT DATAFILE 2 NAME [F] "RTN","TMGSEQL1B",101,0) ;" 8 4;1 2.5 IMPORT DATAFILE PATH [F] "RTN","TMGSEQL1B",102,0) ;" 9 6;1 3 ALERT RECIPIENT <-Pntr [P200'] "RTN","TMGSEQL1B",103,0) ;" 10 6;2 4 LAST IMPORT DATE [D] "RTN","TMGSEQL1B",104,0) ;" 11 6;3 5 DELETE DATAFILE AFTER IMPORT? [S] "RTN","TMGSEQL1B",105,0) ;" 12 6;4 6 PICK GENDER FROM NAME? [S] "RTN","TMGSEQL1B",106,0) ;" 13 6;5 7 IMPORT FREQUENCY (IN HOURS) [NJ4,0] "RTN","TMGSEQL1B",107,0) ;" <> <> <> "RTN","TMGSEQL1B",108,0) ;" A.) FILE NAME:------------- TMG UPLOAD SETTINGS "RTN","TMGSEQL1B",109,0) ;" F.) FILE ACCESS: "RTN","TMGSEQL1B",110,0) ;" B.) FILE NUMBER:----------- 22711 DD______ @ "RTN","TMGSEQL1B",111,0) ;" Read____ @ "RTN","TMGSEQL1B",112,0) ;" C.) NUM OF FLDS:----------- 12 Write___ @ "RTN","TMGSEQL1B",113,0) ;" Delete__ @ "RTN","TMGSEQL1B",114,0) ;" D.) DATA GLOBAL:----------- ^TMG(22711, Laygo___ @ "RTN","TMGSEQL1B",115,0) ;" "RTN","TMGSEQL1B",116,0) ;" E.) TOTAL GLOBAL ENTRIES:-- 1 G.) PRINTING STATUS:-- Off "RTN","TMGSEQL1B",117,0) ;"================================================================================ "RTN","TMGSEQL1B",118,0) "RTN","TMGSEQL1B",119,0) "RTN","TMGSEQL1B",120,0) "RTN","TMGSEQL1B",121,0) "RTN","TMGSEQL1B",122,0) ASKIMPORT "RTN","TMGSEQL1B",123,0) ;"Purpose: To ask user for filename and then import data. "RTN","TMGSEQL1B",124,0) ;"Input: None "RTN","TMGSEQL1B",125,0) ;"Output: Database is updated with data from file. "RTN","TMGSEQL1B",126,0) ;"Result: None "RTN","TMGSEQL1B",127,0) "RTN","TMGSEQL1B",128,0) new DiscardName "RTN","TMGSEQL1B",129,0) new DefPath set DefPath="/tmp/" "RTN","TMGSEQL1B",130,0) new DefFName set DefFName="demographics.csv" "RTN","TMGSEQL1B",131,0) new DefF2Name set DefF2Name="demographics2.csv" "RTN","TMGSEQL1B",132,0) new FPath,FName,F2Name "RTN","TMGSEQL1B",133,0) new ErrArray,ChLog "RTN","TMGSEQL1B",134,0) new result "RTN","TMGSEQL1B",135,0) "RTN","TMGSEQL1B",136,0) new PrgsFn set PrgsFn="do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",1,TMGMAX,,TMGSTART)" "RTN","TMGSEQL1B",137,0) set PrgsFn=PrgsFn_" read *TMGkeyin:0 set:(TMGkeyin=27) TMGABORT=1" "RTN","TMGSEQL1B",138,0) "RTN","TMGSEQL1B",139,0) set DiscardName=$$GetFName^TMGIOUTL("Please enter file to import.",.DefPath,.DefFName,,.FPath,.FName) "RTN","TMGSEQL1B",140,0) if DiscardName="" goto AIDone "RTN","TMGSEQL1B",141,0) "RTN","TMGSEQL1B",142,0) set DiscardName=$$GetFName^TMGIOUTL("Please enter 2nd file to import.",.DefPath,.DefF2Name,,.FPath,.F2Name) "RTN","TMGSEQL1B",143,0) if DiscardName="" goto AIDone "RTN","TMGSEQL1B",144,0) "RTN","TMGSEQL1B",145,0) set result=$$IMPORTFILE(FPath,FName,F2Name,.ErrArray,.ChLog,PrgsFn) "RTN","TMGSEQL1B",146,0) "RTN","TMGSEQL1B",147,0) AIDone "RTN","TMGSEQL1B",148,0) quit "RTN","TMGSEQL1B",149,0) "RTN","TMGSEQL1B",150,0) "RTN","TMGSEQL1B",151,0) RUNNOW "RTN","TMGSEQL1B",152,0) ;"Purpose: To provide an entry point for running import NOW. This will delete prior alerts "RTN","TMGSEQL1B",153,0) ;"Input: none. Settings stored in File 22711 are used "RTN","TMGSEQL1B",154,0) ;"Output: None. Progress shown to console. The database should be updated "RTN","TMGSEQL1B",155,0) ;"Results: none "RTN","TMGSEQL1B",156,0) "RTN","TMGSEQL1B",157,0) write !!,"Import Sequel Demographics Now...",! "RTN","TMGSEQL1B",158,0) "RTN","TMGSEQL1B",159,0) new FName,F2Name,FPath "RTN","TMGSEQL1B",160,0) new result "RTN","TMGSEQL1B",161,0) new ErrArray,ChLog "RTN","TMGSEQL1B",162,0) new DelFiles "RTN","TMGSEQL1B",163,0) new UserID "RTN","TMGSEQL1B",164,0) "RTN","TMGSEQL1B",165,0) set FName=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE NAME") "RTN","TMGSEQL1B",166,0) set F2Name=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE 2 NAME") "RTN","TMGSEQL1B",167,0) set FPath=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE PATH") "RTN","TMGSEQL1B",168,0) set DelFiles=+$$GET1^DIQ(22711,"1,","DELETE DATAFILE AFTER IMPORT?","I") "RTN","TMGSEQL1B",169,0) set UserID=$$GET1^DIQ(22711,"1,","ALERT RECIPIENT","I") "RTN","TMGSEQL1B",170,0) "RTN","TMGSEQL1B",171,0) new PrgsFn set PrgsFn="do ProgressBar^TMGUSRIF(TMGCUR,""Progress"",1,TMGMAX,,TMGSTART)" "RTN","TMGSEQL1B",172,0) set PrgsFn=PrgsFn_" read *TMGkeyin:0 set:(TMGkeyin=27) TMGABORT=1" "RTN","TMGSEQL1B",173,0) "RTN","TMGSEQL1B",174,0) set result=$$IMPORTFILE(FPath,FName,F2Name,,,PrgsFn,,DelFiles,UserID) "RTN","TMGSEQL1B",175,0) "RTN","TMGSEQL1B",176,0) quit "RTN","TMGSEQL1B",177,0) "RTN","TMGSEQL1B",178,0) "RTN","TMGSEQL1B",179,0) AUTOIN "RTN","TMGSEQL1B",180,0) ;"Purpose: To provide an entry point for a scheduled task. This will delete prior alerts "RTN","TMGSEQL1B",181,0) ;"Input: none. Settings stored in File 22711 are used "RTN","TMGSEQL1B",182,0) ;"Output: None. There should be no console output. The database should be updated "RTN","TMGSEQL1B",183,0) ;"Results: none "RTN","TMGSEQL1B",184,0) "RTN","TMGSEQL1B",185,0) new InitTime set InitTime=$H "RTN","TMGSEQL1B",186,0) "RTN","TMGSEQL1B",187,0) new UserID set UserID=$$GET1^DIQ(22711,"1,","ALERT RECIPIENT","I") "RTN","TMGSEQL1B",188,0) "RTN","TMGSEQL1B",189,0) do ;"clear out 'next run task number' "RTN","TMGSEQL1B",190,0) . new TMGFDA,TMGMSG "RTN","TMGSEQL1B",191,0) . set TMGFDA(22711,"1,",8)="@" ;"#4 = TASK FOR NEXT RUN "RTN","TMGSEQL1B",192,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;" note: ignores TMGMSG or errors. "RTN","TMGSEQL1B",193,0) "RTN","TMGSEQL1B",194,0) new temp set temp=$$QuietClear^TMGSEQL3(UserID) ;"clear prior alerts & errors "RTN","TMGSEQL1B",195,0) do QUIETIN ;" do import "RTN","TMGSEQL1B",196,0) "RTN","TMGSEQL1B",197,0) ;"Here I schedule the next task to run again. "RTN","TMGSEQL1B",198,0) new HrInterval set HrInterval=$$GET1^DIQ(22711,"1,","IMPORT FREQUENCY (IN HOURS)","I") "RTN","TMGSEQL1B",199,0) if +HrInterval>0 do "RTN","TMGSEQL1B",200,0) . new time set time=$$HADD^XLFDT(InitTime,0,HrInterval,0) "RTN","TMGSEQL1B",201,0) . new task set task=$$Schedule^TMGSEQL3(time,"AUTOIN^TMGSEQL1","Import of demographic data from Sequel billing system.") "RTN","TMGSEQL1B",202,0) . ;"store 'next run task number' "RTN","TMGSEQL1B",203,0) . set TMGFDA(22711,"1,",8)="`"_task ;"#4 = TASK FOR NEXT RUN "RTN","TMGSEQL1B",204,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;" note: ignores TMGMSG or errors. "RTN","TMGSEQL1B",205,0) "RTN","TMGSEQL1B",206,0) quit "RTN","TMGSEQL1B",207,0) "RTN","TMGSEQL1B",208,0) "RTN","TMGSEQL1B",209,0) QUIETIN "RTN","TMGSEQL1B",210,0) ;"Purpose: To import data based on settings, with no user interaction (in or out) "RTN","TMGSEQL1B",211,0) ;"Input: none. Settings stored in File 22711 are used "RTN","TMGSEQL1B",212,0) ;"Output: None. There should be no console output. The database should be updated "RTN","TMGSEQL1B",213,0) ;"Results: none "RTN","TMGSEQL1B",214,0) "RTN","TMGSEQL1B",215,0) new FName,F2Name,FPath "RTN","TMGSEQL1B",216,0) new result "RTN","TMGSEQL1B",217,0) new ErrArray,ChLog "RTN","TMGSEQL1B",218,0) new DelFiles "RTN","TMGSEQL1B",219,0) new UserID "RTN","TMGSEQL1B",220,0) "RTN","TMGSEQL1B",221,0) set FName=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE NAME") "RTN","TMGSEQL1B",222,0) set F2Name=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE 2 NAME") "RTN","TMGSEQL1B",223,0) set FPath=$$GET1^DIQ(22711,"1,","IMPORT DATAFILE PATH") "RTN","TMGSEQL1B",224,0) set DelFiles=+$$GET1^DIQ(22711,"1,","DELETE DATAFILE AFTER IMPORT?","I") "RTN","TMGSEQL1B",225,0) set UserID=$$GET1^DIQ(22711,"1,","ALERT RECIPIENT","I") "RTN","TMGSEQL1B",226,0) "RTN","TMGSEQL1B",227,0) set result=$$IMPORTFILE(FPath,FName,F2Name,,,,,DelFiles,UserID) "RTN","TMGSEQL1B",228,0) "RTN","TMGSEQL1B",229,0) quit "RTN","TMGSEQL1B",230,0) "RTN","TMGSEQL1B",231,0) "RTN","TMGSEQL1B",232,0) IMPORTFILE(FilePath,FileName,F2Name,ErrArray,ChgLog,PrgCallback,F2Path,DelFiles,UserID) "RTN","TMGSEQL1B",233,0) ;"Purpose: To import data from file specified. "RTN","TMGSEQL1B",234,0) ;"Input: FilePath: Path of file to input. "RTN","TMGSEQL1B",235,0) ;" FileName: The Name of file of file to input. "RTN","TMGSEQL1B",236,0) ;" Note: This is written to import a specific file "RTN","TMGSEQL1B",237,0) ;" created by SequelMed Systems, filled with "RTN","TMGSEQL1B",238,0) ;" patient demographics, in CVS format "RTN","TMGSEQL1B",239,0) ;" Note: This file will be DELETED if DelFiles=1 "RTN","TMGSEQL1B",240,0) ;" F2Name : the name of the second demographics file in input "RTN","TMGSEQL1B",241,0) ;" The reason for 2 files is because Sequel doesn't report the SSN in the "RTN","TMGSEQL1B",242,0) ;" primary demographics report. So a second report must be used, and these "RTN","TMGSEQL1B",243,0) ;" two files are merged to provide complete patient demographics. "RTN","TMGSEQL1B",244,0) ;" Note: This file will be DELETED if DelFiles=1 "RTN","TMGSEQL1B",245,0) ;" ErrArray: PASS BY REFERENCE. Array to receive failed data lines. "RTN","TMGSEQL1B",246,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1B",247,0) ;" PrgCallback: OPTIONAL -- if supplied, then M code contained in this string "RTN","TMGSEQL1B",248,0) ;" will be xecuted periodically, to allow display of a progress bar etc. "RTN","TMGSEQL1B",249,0) ;" Note: the following variables with global scope will be declared and "RTN","TMGSEQL1B",250,0) ;" available for use: TMGCUR (current count), TMGMAX (max count), "RTN","TMGSEQL1B",251,0) ;" TMGSTART (the start time "RTN","TMGSEQL1B",252,0) ;" External function can signal a request an abort by setting TMGABORT=1 "RTN","TMGSEQL1B",253,0) ;" F2Path: OPTIONAL -- path of 2nd demographics file. Default=FilePath "RTN","TMGSEQL1B",254,0) ;" DelFiles: OPTIONAL -- if 1, then source files (FileName and F2Name) are deleted after import "RTN","TMGSEQL1B",255,0) ;" UserID : OPTIONAL -- user to receive alerts regarding errors. Default is current user (DUZ) "RTN","TMGSEQL1B",256,0) ;"Note: I have learned that SequelMed billing system exports ALL patients in the primary "RTN","TMGSEQL1B",257,0) ;" export file, including one that have been marked inactive do to invalid data etc. "RTN","TMGSEQL1B",258,0) ;" Thus, while the second file (F2Name) has limited info, it contains the list of "RTN","TMGSEQL1B",259,0) ;" ACTIVE patients. So if a name is not included in the 2nd file, then its info will "RTN","TMGSEQL1B",260,0) ;" be ignored in the 1st file. "RTN","TMGSEQL1B",261,0) ;"Output: Database is updated with data from file. "RTN","TMGSEQL1B",262,0) ;"Result: 1 successful completion, 0=error "RTN","TMGSEQL1B",263,0) "RTN","TMGSEQL1B",264,0) new GRef,GRef1 "RTN","TMGSEQL1B",265,0) new G2Ref,G2Ref1 "RTN","TMGSEQL1B",266,0) new result "RTN","TMGSEQL1B",267,0) "RTN","TMGSEQL1B",268,0) set F2Path=$get(F2Path,FilePath) "RTN","TMGSEQL1B",269,0) "RTN","TMGSEQL1B",270,0) set GRef=$name(^TMP("TMG","SEQUELIMPORT","DATA",1,$J)) ;"I use this to process array "RTN","TMGSEQL1B",271,0) set GRef1=$name(@GRef@(1)) ;"I use this to load file "RTN","TMGSEQL1B",272,0) kill @GRef "RTN","TMGSEQL1B",273,0) set result=$$FTG^%ZISH(FilePath,FileName,GRef1,6) ;"load file into a global "RTN","TMGSEQL1B",274,0) if result=0 goto IFDONE "RTN","TMGSEQL1B",275,0) "RTN","TMGSEQL1B",276,0) set G2Ref=$name(^TMP("TMG","SEQUELIMPORT","DATA",2,$J)) ;"I use this to process array "RTN","TMGSEQL1B",277,0) set G2Ref1=$name(@G2Ref@(1)) ;"I use this to load file "RTN","TMGSEQL1B",278,0) kill @G2Ref "RTN","TMGSEQL1B",279,0) set result=$$FTG^%ZISH(F2Path,F2Name,G2Ref1,6) ;"load file into a global "RTN","TMGSEQL1B",280,0) if result=0 goto IFDONE "RTN","TMGSEQL1B",281,0) "RTN","TMGSEQL1B",282,0) set UserID=$get(UserID,+$get(DUZ)) "RTN","TMGSEQL1B",283,0) "RTN","TMGSEQL1B",284,0) set result=$$IMPORTGLOBAL(GRef,G2Ref,.ErrArray,.ChLog,.PrgCallback,UserID) "RTN","TMGSEQL1B",285,0) "RTN","TMGSEQL1B",286,0) ;"Note: @GRef, @G2Ref killed at end of $$IMPORTGLOBAL() "RTN","TMGSEQL1B",287,0) "RTN","TMGSEQL1B",288,0) do ;"record the current time as the time of last import "RTN","TMGSEQL1B",289,0) . do NOW^%DTC "RTN","TMGSEQL1B",290,0) . new TMGFDA,TMGMSG "RTN","TMGSEQL1B",291,0) . set TMGFDA(22711,"1,",4)=% ;"#4 = LAST IMPORT DATE "RTN","TMGSEQL1B",292,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;" note: ignores TMGMSG or errors. "RTN","TMGSEQL1B",293,0) "RTN","TMGSEQL1B",294,0) if $get(DelFiles)=1 do "RTN","TMGSEQL1B",295,0) . ;"Notice: After I implemented this, I realized that I have a permissions problem "RTN","TMGSEQL1B",296,0) . ;" at my site... the uploaded files belong to the uploaded user, and deletion by "RTN","TMGSEQL1B",297,0) . ;" this user is being blocked. I'll leave in for now... "RTN","TMGSEQL1B",298,0) . new temp "RTN","TMGSEQL1B",299,0) . set temp=$$DelFile^TMGIOUTL(FilePath_FileName) "RTN","TMGSEQL1B",300,0) . set temp=$$DelFile^TMGIOUTL(F2Path_F2Name) "RTN","TMGSEQL1B",301,0) "RTN","TMGSEQL1B",302,0) IFDONE "RTN","TMGSEQL1B",303,0) quit result "RTN","TMGSEQL1B",304,0) "RTN","TMGSEQL1B",305,0) IMPORTGLOBAL(GRef,G2Ref,ErrArray,ChLog,PrgCallback,UserID) "RTN","TMGSEQL1B",306,0) ;"Purpose: To import data from global specified. "RTN","TMGSEQL1B",307,0) ;"Input: GRef -- the NAME of array holding the data to import (1st file) "RTN","TMGSEQL1B",308,0) ;" Format: @GRef@(1)=OneLine "RTN","TMGSEQL1B",309,0) ;" @GRef@(2)=OneLine .. etc. "RTN","TMGSEQL1B",310,0) ;" Note: This is written to import a specific file "RTN","TMGSEQL1B",311,0) ;" created by SequelMed Systems, filled with "RTN","TMGSEQL1B",312,0) ;" patient demographics, in CVS format "RTN","TMGSEQL1B",313,0) ;" Note: Array will be KILLED at the end of this function. "RTN","TMGSEQL1B",314,0) ;" G2Ref -- the NAME of array holding the data to import (2nd file) "RTN","TMGSEQL1B",315,0) ;" Note: Array will be KILLED at the end of this function. "RTN","TMGSEQL1B",316,0) ;" ErrArray: PASS BY REFERENCE. Array to receive failed data lines. "RTN","TMGSEQL1B",317,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1B",318,0) ;" PrgCallback: OPTIONAL -- if supplied, then M code contained in this string "RTN","TMGSEQL1B",319,0) ;" will be xecuted periodically, to allow display of a progress bar etc. "RTN","TMGSEQL1B",320,0) ;" Note: the following variables with global scope will be declared and "RTN","TMGSEQL1B",321,0) ;" available for use: TMGCUR (current count), TMGMAX (max count), "RTN","TMGSEQL1B",322,0) ;" TMGSTART (the start time "RTN","TMGSEQL1B",323,0) ;" External function can signal a request an abort by setting TMGABORT=1 "RTN","TMGSEQL1B",324,0) ;" UserID : OPTIONAL -- user to receive alerts regarding errors. Default is current user (DUZ) "RTN","TMGSEQL1B",325,0) ;"Output: Database is updated with data from file. "RTN","TMGSEQL1B",326,0) ;"Result: 1 successful completion, 0=error "RTN","TMGSEQL1B",327,0) "RTN","TMGSEQL1B",328,0) new TMGInvalid ;"Will be used as a globally-scoped variable in the module "RTN","TMGSEQL1B",329,0) new result set result=1 "RTN","TMGSEQL1B",330,0) new delay set delay=0 "RTN","TMGSEQL1B",331,0) new TMGCUR,TMGMAX,TMGSTART,TMGABORT ;"avail for PrgCallback function "RTN","TMGSEQL1B",332,0) set TMGABORT=0 "RTN","TMGSEQL1B",333,0) set TMGMAX=+$order(@GRef@(""),-1) "RTN","TMGSEQL1B",334,0) set TMGSTART=$H ;"store starting time. "RTN","TMGSEQL1B",335,0) set UserID=$get(UserID,+$get(DUZ)) "RTN","TMGSEQL1B",336,0) "RTN","TMGSEQL1B",337,0) new SSNArray "RTN","TMGSEQL1B",338,0) do XtractSSNum(G2Ref,.SSNArray) "RTN","TMGSEQL1B",339,0) "RTN","TMGSEQL1B",340,0) set TMGCUR=$order(@GRef@("")) "RTN","TMGSEQL1B",341,0) if TMGCUR'="" for do quit:(TMGCUR="")!(TMGABORT=1) "RTN","TMGSEQL1B",342,0) . new OneLine "RTN","TMGSEQL1B",343,0) . set OneLine=$get(@GRef@(TMGCUR)) "RTN","TMGSEQL1B",344,0) . set result=$$ProcessPt(OneLine,.ErrArray,.ChgLog,.SSNArray,UserID) "RTN","TMGSEQL1B",345,0) . set delay=delay+1 "RTN","TMGSEQL1B",346,0) . if (delay>30),$get(PrgCallback)'="" do ;"update progress bar every 30 cycles "RTN","TMGSEQL1B",347,0) . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGSEQL1B",348,0) . . xecute PrgCallback ;"call the specified progress code. "RTN","TMGSEQL1B",349,0) . . set delay=0 "RTN","TMGSEQL1B",350,0) . set TMGCUR=$order(@GRef@(TMGCUR)) "RTN","TMGSEQL1B",351,0) "RTN","TMGSEQL1B",352,0) kill @GRef "RTN","TMGSEQL1B",353,0) kill @G2Ref "RTN","TMGSEQL1B",354,0) quit result "RTN","TMGSEQL1B",355,0) "RTN","TMGSEQL1B",356,0) "RTN","TMGSEQL1B",357,0) "RTN","TMGSEQL1B",358,0) ProcessPt(OneLine,ErrArray,ChgLog,SSNArray,DUZ,InputFn) "RTN","TMGSEQL1B",359,0) ;"Purpose: To process one line from patient demographics file. "RTN","TMGSEQL1B",360,0) ;"Input: OneLine-- One line from CVS demographics file. "RTN","TMGSEQL1B",361,0) ;" Format is as follows, *** all on one line (comma delimited) "RTN","TMGSEQL1B",362,0) ;" 01- patient_seq_num, "RTN","TMGSEQL1B",363,0) ;" 02- facility_short_name, "RTN","TMGSEQL1B",364,0) ;" 03- pat_last_name, "RTN","TMGSEQL1B",365,0) ;" 04- pat_first_name, "RTN","TMGSEQL1B",366,0) ;" 05- pat_account_num, "RTN","TMGSEQL1B",367,0) ;" 06- pat_address, "RTN","TMGSEQL1B",368,0) ;" 07- state, "RTN","TMGSEQL1B",369,0) ;" 08- resp_last_name, "RTN","TMGSEQL1B",370,0) ;" 09- resp_first_name, "RTN","TMGSEQL1B",371,0) ;" 10- facility_seq_num, "RTN","TMGSEQL1B",372,0) ;" 11- register_date, "RTN","TMGSEQL1B",373,0) ;" 12- location_name, "RTN","TMGSEQL1B",374,0) ;" 13- city, "RTN","TMGSEQL1B",375,0) ;" 14- provider_short_name, "RTN","TMGSEQL1B",376,0) ;" 15- zipcode, "RTN","TMGSEQL1B",377,0) ;" 16- class_name, "RTN","TMGSEQL1B",378,0) ;" 17- pat_dob, "RTN","TMGSEQL1B",379,0) ;" 18- ref_prov_short_name, "RTN","TMGSEQL1B",380,0) ;" 19- pat_tel_num, "RTN","TMGSEQL1B",381,0) ;" 20- last_visit_days, "RTN","TMGSEQL1B",382,0) ;" 21- name, "RTN","TMGSEQL1B",383,0) ;" 22- description "RTN","TMGSEQL1B",384,0) ;" ADDENDUM: "RTN","TMGSEQL1B",385,0) ;" sometimes SEX will be appended to line. Format: "RTN","TMGSEQL1B",386,0) ;" previous data^MALE or previous data^FEMALE "RTN","TMGSEQL1B",387,0) ;" sometimes SSN will be appended to line. Format: "RTN","TMGSEQL1B",388,0) ;" previous data^(sex)^SSNUM "RTN","TMGSEQL1B",389,0) ;" ErrArray: PASS BY REFERENCE. Array to receive failed data lines. "RTN","TMGSEQL1B",390,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1B",391,0) ;" SSNArray: OPTIONAL -- PASS BY REFERENCE. An array with social security numbers, "RTN","TMGSEQL1B",392,0) ;" as created by XtractSSNum() "RTN","TMGSEQL1B",393,0) ;" DUZ: The user who will recieve alerts of errors "RTN","TMGSEQL1B",394,0) ;" InputFn: OPTIONAL-- the name of a function to turn parse on csv line "RTN","TMGSEQL1B",395,0) ;" default value is "ParseLine" "RTN","TMGSEQL1B",396,0) ;" e.g. "MyFn" or "MyFn^MyRoutine". Must take same params as ParseLine "RTN","TMGSEQL1B",397,0) ;" This will allow this code to be used on a variety of .csv files, with "RTN","TMGSEQL1B",398,0) ;" different data-formats--each one with its own parser funtion. "RTN","TMGSEQL1B",399,0) ;"Output: Data is put into database, if it is not there already. "RTN","TMGSEQL1B",400,0) ;"Result: 1=OK To continue; 0=abort or bad data "RTN","TMGSEQL1B",401,0) "RTN","TMGSEQL1B",402,0) new XFn "RTN","TMGSEQL1B",403,0) new PtInfo,OneErrArray "RTN","TMGSEQL1B",404,0) new result set result=1 "RTN","TMGSEQL1B",405,0) new AutoRegister set AutoRegister=1 "RTN","TMGSEQL1B",406,0) set InputFn=$get(InputFn,"ParseLine") "RTN","TMGSEQL1B",407,0) "RTN","TMGSEQL1B",408,0) set XFn="set result=$$"_InputFn_"(.OneLine,.PtInfo,.SSNArray)" "RTN","TMGSEQL1B",409,0) xecute XFn ;"old -- set result=$$ParseLine(.OneLine,.PtInfo,.SSNArray) "RTN","TMGSEQL1B",410,0) if result'>0 goto PPtDone "RTN","TMGSEQL1B",411,0) if $get(PtInfo("FACILITY"))="SAMPLE" goto PPtDone "RTN","TMGSEQL1B",412,0) "RTN","TMGSEQL1B",413,0) if $$UpdateDB(.PtInfo,AutoRegister,.OneErrArray,.ChgLog)=0 do "RTN","TMGSEQL1B",414,0) . new count set count=+$get(ErrArray)+1 "RTN","TMGSEQL1B",415,0) . set ErrArray=count "RTN","TMGSEQL1B",416,0) . set ErrArray(count)=OneLine "RTN","TMGSEQL1B",417,0) . merge ErrArray(count,"INFO")=OneErrArray "RTN","TMGSEQL1B",418,0) . ;"------ "RTN","TMGSEQL1B",419,0) . do AlertError^TMGSEQL2(OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL1B",420,0) "RTN","TMGSEQL1B",421,0) PPtDone "RTN","TMGSEQL1B",422,0) quit result "RTN","TMGSEQL1B",423,0) "RTN","TMGSEQL1B",424,0) "RTN","TMGSEQL1B",425,0) ParseLine(OneLine,Array,SSNArray) "RTN","TMGSEQL1B",426,0) ;"Purpose: To process one line from patient demographics file. "RTN","TMGSEQL1B",427,0) ;" Also gets data into an acceptible format. "RTN","TMGSEQL1B",428,0) ;"Input: OneLine -- One line from CVS demographics file. (Format as per ProcessPt) "RTN","TMGSEQL1B",429,0) ;" NOTE: if PASSED BY REFERENCE, then line may be altered such that SSN is "RTN","TMGSEQL1B",430,0) ;" added as a 3rd piece, using ^ as a delimiter. (2nd piece used elsewhere "RTN","TMGSEQL1B",431,0) ;" to store sex. "RTN","TMGSEQL1B",432,0) ;" When processing line, if SSNArray doesn't provide a SSN for patient, then "RTN","TMGSEQL1B",433,0) ;" this 3rd piece can provide the SSN "RTN","TMGSEQL1B",434,0) ;" Array -- PASS BY REFERENCE. And OUT parameter. Any prior data killed. "RTN","TMGSEQL1B",435,0) ;" Note: uses TMGInvalid (globally scoped var defined in this module) "RTN","TMGSEQL1B",436,0) ;" SSNArray: OPTIONAL -- PASS BY REFERENCE. An array with social security numbers, "RTN","TMGSEQL1B",437,0) ;" as created by XtractSSNum() "RTN","TMGSEQL1B",438,0) ;"Output: Array is filled with Format as follows (note not all data used): "RTN","TMGSEQL1B",439,0) ;" Array("FACILITY"), to hold 02- facility_short_name "RTN","TMGSEQL1B",440,0) ;" Array("LAST NAME"), to hold 03- pat_last_name, "RTN","TMGSEQL1B",441,0) ;" Array("FIRST NAME"), to hold 04- pat_first_name, "RTN","TMGSEQL1B",442,0) ;" Array("PMS ACCOUNT NUM"), to hold 05- pat_account_num, "RTN","TMGSEQL1B",443,0) ;" Array("ADDRESS1"), to hold 06- pat_address, "RTN","TMGSEQL1B",444,0) ;" Array("ADDRESS2"), to hold 06- pat_address, "RTN","TMGSEQL1B",445,0) ;" Array("ADDRESS3"), to hold 06- pat_address, "RTN","TMGSEQL1B",446,0) ;" Array("STATE"), to hold 07- state, "RTN","TMGSEQL1B",447,0) ;" Array("RESP LAST NAME"), to hold 08- resp_last_name, "RTN","TMGSEQL1B",448,0) ;" Array("RESP FIRST NAME"), to hold 09- resp_first_name, "RTN","TMGSEQL1B",449,0) ;" Array("CITY"), to hold 13- city, "RTN","TMGSEQL1B",450,0) ;" Array("PROVIDER"), to hold 14- provider_short_name, "RTN","TMGSEQL1B",451,0) ;" Array("ZIP CODE"), to hold 15- zipcode, "RTN","TMGSEQL1B",452,0) ;" Array("DOB"), to hold 17- pat_dob, "RTN","TMGSEQL1B",453,0) ;" Array("PHONE NUM"), to hold 19- pat_tel_num, "RTN","TMGSEQL1B",454,0) ;" Array("SEX"), to hold Patient sex, if provided. "RTN","TMGSEQL1B",455,0) ;" Array("SSNUM")=Social security number "RTN","TMGSEQL1B",456,0) ;" Array("FULL NAME")=FIRSTNAME LASTNAME (DOB) "RTN","TMGSEQL1B",457,0) ;" Array("FULL NAME2")=LASTNAME,FIRSTNAME (DOB) "RTN","TMGSEQL1B",458,0) ;" Array("FULL NAME3")=LASTNAME,FIRSTNAME "RTN","TMGSEQL1B",459,0) ;"Result: 1=OK To continue; 0=abort or bad data; -1 skip, but don't store as error "RTN","TMGSEQL1B",460,0) "RTN","TMGSEQL1B",461,0) new temp "RTN","TMGSEQL1B",462,0) new result set result=1 "RTN","TMGSEQL1B",463,0) "RTN","TMGSEQL1B",464,0) set OneLine=$translate($get(OneLine),"""","'") ;" convert " to ' to avoid fileman error "RTN","TMGSEQL1B",465,0) "RTN","TMGSEQL1B",466,0) kill Array "RTN","TMGSEQL1B",467,0) set Array("FACILITY")=$piece(OneLine,",",2) "RTN","TMGSEQL1B",468,0) set Array("LAST NAME")=$$Trim^TMGSTUTL($piece(OneLine,",",3)) "RTN","TMGSEQL1B",469,0) set Array("FIRST NAME")=$$Trim^TMGSTUTL($piece(OneLine,",",4)) "RTN","TMGSEQL1B",470,0) set Array("PMS ACCOUNT NUM")=$piece(OneLine,",",5) "RTN","TMGSEQL1B",471,0) set Array("ADDRESS1")=$piece(OneLine,",",6) "RTN","TMGSEQL1B",472,0) set Array("STATE")=$piece(OneLine,",",7) "RTN","TMGSEQL1B",473,0) set Array("RESP LAST NAME")=$piece(OneLine,",",8) "RTN","TMGSEQL1B",474,0) set Array("RESP FIRST NAME")=$piece(OneLine,",",9) "RTN","TMGSEQL1B",475,0) set Array("CITY")=$$Trim^TMGSTUTL($piece(OneLine,",",13),"""") "RTN","TMGSEQL1B",476,0) set Array("PROVIDER")=$piece(OneLine,",",14) "RTN","TMGSEQL1B",477,0) set Array("ZIP CODE")=$piece(OneLine,",",15) "RTN","TMGSEQL1B",478,0) new DOB set DOB=$piece(OneLine,",",17) "RTN","TMGSEQL1B",479,0) set DOB=$$Trim^TMGSTUTL(DOB) "RTN","TMGSEQL1B",480,0) set DOB=$piece(DOB," ",1) ;" '03/09/05 00:00' --> '03/09/05' "RTN","TMGSEQL1B",481,0) set Array("DOB")=DOB "RTN","TMGSEQL1B",482,0) set Array("PHONE NUM")=$piece(OneLine,",",19) "RTN","TMGSEQL1B",483,0) set Array("SEX")=$piece(OneLine,"^",2) "RTN","TMGSEQL1B",484,0) "RTN","TMGSEQL1B",485,0) set Array("FULL NAME")=Array("FIRST NAME")_" "_Array("LAST NAME")_" ("_Array("DOB")_")" "RTN","TMGSEQL1B",486,0) set Array("FULL NAME2")=Array("LAST NAME")_","_Array("FIRST NAME")_" ("_Array("DOB")_")" "RTN","TMGSEQL1B",487,0) set Array("FULL NAME3")=Array("LAST NAME")_","_Array("FIRST NAME") "RTN","TMGSEQL1B",488,0) "RTN","TMGSEQL1B",489,0) ;"do a lookup on abreviattion for ALL states, convert to external format "RTN","TMGSEQL1B",490,0) new DIC,X,Y "RTN","TMGSEQL1B",491,0) set DIC=5 ;"STATE file "RTN","TMGSEQL1B",492,0) set DIC(0)="M" "RTN","TMGSEQL1B",493,0) set X=Array("STATE") "RTN","TMGSEQL1B",494,0) do ^DIC "RTN","TMGSEQL1B",495,0) set Array("STATE")=$piece(Y,"^",2) "RTN","TMGSEQL1B",496,0) "RTN","TMGSEQL1B",497,0) ;"convert Sequel format to VistA format "RTN","TMGSEQL1B",498,0) if Array("PROVIDER")'="" do "RTN","TMGSEQL1B",499,0) . set Array("PROVIDER")=$$ConvProvider(Array("PROVIDER")) "RTN","TMGSEQL1B",500,0) if Array("PROVIDER")="SKIP" set result=0 goto PLDone "RTN","TMGSEQL1B",501,0) "RTN","TMGSEQL1B",502,0) ;" VistA address allows for: "RTN","TMGSEQL1B",503,0) ;" .111 -- address line 1 "RTN","TMGSEQL1B",504,0) ;" .112 -- address line 2 "RTN","TMGSEQL1B",505,0) ;" .113 -- address line 3 "RTN","TMGSEQL1B",506,0) ;" BUT, each line must be 3-35 characters "RTN","TMGSEQL1B",507,0) ;" Sequel puts this all on one line. "RTN","TMGSEQL1B",508,0) ;" SO, I need to divide the Sequel line if not 3-35 "RTN","TMGSEQL1B",509,0) new value set value=Array("ADDRESS1") "RTN","TMGSEQL1B",510,0) if $length(value)'<35 do "RTN","TMGSEQL1B",511,0) . new s1,s2 "RTN","TMGSEQL1B",512,0) . do NiceSplit^TMGSTUTL(value,35,.s1,.s2,3) "RTN","TMGSEQL1B",513,0) . set Array("ADDRESS1")=s1 "RTN","TMGSEQL1B",514,0) . if $length(s2)'<35 do "RTN","TMGSEQL1B",515,0) . . do NiceSplit^TMGSTUTL(s1,35,.s1,.s2,3) "RTN","TMGSEQL1B",516,0) . . set Array("ADDRESS2")=s1 ;"<-- is this correct? "RTN","TMGSEQL1B",517,0) . . if s2'="" set Array("ADDRESS3")=$extract(s2,1,35) "RTN","TMGSEQL1B",518,0) . else set Array("ADDRESS2")=s2 "RTN","TMGSEQL1B",519,0) "RTN","TMGSEQL1B",520,0) ;"Ensure proper length of city. "RTN","TMGSEQL1B",521,0) set Array("CITY")=$extract(Array("CITY"),1,15) "RTN","TMGSEQL1B",522,0) if $length(Array("CITY"))=1 set Array("CITY")=Array("CITY")_" " "RTN","TMGSEQL1B",523,0) "RTN","TMGSEQL1B",524,0) ;"Ensure proper length of phone "RTN","TMGSEQL1B",525,0) if $length(Array("PHONE NUM"))<7 kill Array("PHONE NUM") "RTN","TMGSEQL1B",526,0) "RTN","TMGSEQL1B",527,0) new AcctNum set AcctNum=$get(Array("PMS ACCOUNT NUM")) "RTN","TMGSEQL1B",528,0) new SSNum set SSNum=$get(SSNArray(AcctNum)) "RTN","TMGSEQL1B",529,0) if SSNum=999999999 set SSNum=0 "RTN","TMGSEQL1B",530,0) if +SSNum=0 do ;"see if 3rd ^ piece holds SSNum data "RTN","TMGSEQL1B",531,0) . set SSNum=$piece(OneLine,"^",3) ;"note this won't overwrite valid data from SSNArray() "RTN","TMGSEQL1B",532,0) if SSNum>0 do "RTN","TMGSEQL1B",533,0) . set Array("SSNUM")=SSNum "RTN","TMGSEQL1B",534,0) . set $piece(OneLine,"^",3)=SSNum "RTN","TMGSEQL1B",535,0) "RTN","TMGSEQL1B",536,0) if result'=0 do "RTN","TMGSEQL1B",537,0) . if $$InvalPtName(Array("FIRST NAME"),Array("LAST NAME"))=1 set result=-1 quit "RTN","TMGSEQL1B",538,0) . if $$InactivePt(Array("PMS ACCOUNT NUM"),.SSNArray)=1 do "RTN","TMGSEQL1B",539,0) xx . . set result=-1 "RTN","TMGSEQL1B",540,0) . . ;"write !,"Skipping: ",Array("FULL NAME3"),! ;"temp "RTN","TMGSEQL1B",541,0) "RTN","TMGSEQL1B",542,0) PLDone "RTN","TMGSEQL1B",543,0) quit result "RTN","TMGSEQL1B",544,0) "RTN","TMGSEQL1B",545,0) "RTN","TMGSEQL1B",546,0) ConvProvider(SequelProvider) "RTN","TMGSEQL1B",547,0) ;"Purpose: To convert Sequel provider shortname to VistA file 200 name. "RTN","TMGSEQL1B",548,0) ;"Input: SequelProvider "RTN","TMGSEQL1B",549,0) ;"Result: VistA provider name (string), or "" if not found, or "SKIP" if not to be used "RTN","TMGSEQL1B",550,0) "RTN","TMGSEQL1B",551,0) new result set result="" "RTN","TMGSEQL1B",552,0) "RTN","TMGSEQL1B",553,0) if $$InvalidProvider(SequelProvider) set result="SKIP" goto ConPrDone "RTN","TMGSEQL1B",554,0) if SequelProvider="SAMPLE" set result="SKIP" goto ConPrDone "RTN","TMGSEQL1B",555,0) "RTN","TMGSEQL1B",556,0) "RTN","TMGSEQL1B",557,0) new TMGARRAY,TMGMSG "RTN","TMGSEQL1B",558,0) do FIND^DIC(200,,".01",,SequelProvider,"*","TMG",,,"TMGARRAY","TMGMSG") "RTN","TMGSEQL1B",559,0) if +TMGARRAY("DILIST",0)>0 do "RTN","TMGSEQL1B",560,0) . set result=TMGARRAY("DILIST",1,1) "RTN","TMGSEQL1B",561,0) else do "RTN","TMGSEQL1B",562,0) . new DIC "RTN","TMGSEQL1B",563,0) . set DIC=200 "RTN","TMGSEQL1B",564,0) . ;"try converting name and doing quiet lookup (KTOPPEN->TOPPEN,K) "RTN","TMGSEQL1B",565,0) . set X=$extract(SequelProvider,2,99)_","_$extract(SequelProvider,1) "RTN","TMGSEQL1B",566,0) . do ^DIC "RTN","TMGSEQL1B",567,0) . if (+Y=-1)&(1=0) do ;"<--- FEATURE TURNED OFF. If not found, don't ask (no longer needed) "RTN","TMGSEQL1B",568,0) . . if $data(TMGInvalid(SequelProvider))'=0 quit "RTN","TMGSEQL1B",569,0) . . write !,"Please help match the Sequel 'shortname' to a VistA provider name.",! "RTN","TMGSEQL1B",570,0) . . write "This should have to be done only once.",! "RTN","TMGSEQL1B",571,0) . . write "Enter ^ if the provider name is not valid.",! "RTN","TMGSEQL1B",572,0) . . write "Please enter VistA provider name for: '",SequelProvider,"'",! "RTN","TMGSEQL1B",573,0) . . set DIC(0)="AEQM" "RTN","TMGSEQL1B",574,0) . . do ^DIC "RTN","TMGSEQL1B",575,0) . . write ! "RTN","TMGSEQL1B",576,0) . if +Y>-1 do "RTN","TMGSEQL1B",577,0) . . new DFN set DFN=+Y "RTN","TMGSEQL1B",578,0) . . new TMGFDA set TMGFDA(200,DFN_",",22702)=SequelProvider "RTN","TMGSEQL1B",579,0) . . kill TMGMSG "RTN","TMGSEQL1B",580,0) . . do FILE^DIE(,"TMGFDA","TMGMSG") ;"ignore errors "RTN","TMGSEQL1B",581,0) . . set result=$piece(Y,"^",2) "RTN","TMGSEQL1B",582,0) . else do "RTN","TMGSEQL1B",583,0) . . set TMGInvalid(SequelProvider)="" "RTN","TMGSEQL1B",584,0) ConPrDone "RTN","TMGSEQL1B",585,0) quit result "RTN","TMGSEQL1B",586,0) "RTN","TMGSEQL1B",587,0) "RTN","TMGSEQL1B",588,0) InvalPtName(FName,LName) "RTN","TMGSEQL1B",589,0) ;"Purpose: To determine if the Patient name is invalid (i.e. CAP TOPPENBERG, or INSURANCE INSURANCE etc.) "RTN","TMGSEQL1B",590,0) ;"Input: FName,LName -- the first and last names "RTN","TMGSEQL1B",591,0) ;"Result: 1 if name is invalid, 0 if OK name "RTN","TMGSEQL1B",592,0) "RTN","TMGSEQL1B",593,0) new result set result=0 "RTN","TMGSEQL1B",594,0) "RTN","TMGSEQL1B",595,0) if FName="CAP" do ;"screen out 'CAP TOPPENBERG' etc ?? entries ?? "RTN","TMGSEQL1B",596,0) . new DIC set DIC=200 "RTN","TMGSEQL1B",597,0) . set DIC(0)="M" "RTN","TMGSEQL1B",598,0) . set X=LName "RTN","TMGSEQL1B",599,0) . do ^DIC "RTN","TMGSEQL1B",600,0) . if +Y>0 set result=1 "RTN","TMGSEQL1B",601,0) "RTN","TMGSEQL1B",602,0) if (FName="INSURANCE")&(LName="INSURANCE") set result=1 "RTN","TMGSEQL1B",603,0) "RTN","TMGSEQL1B",604,0) quit result "RTN","TMGSEQL1B",605,0) "RTN","TMGSEQL1B",606,0) "RTN","TMGSEQL1B",607,0) InactivePt(PMSAcctNum,SSNArray) "RTN","TMGSEQL1B",608,0) ;"Purpose: to determine if patient is inactive, and should be skipped. "RTN","TMGSEQL1B",609,0) ;" This is determined by testing for existence of AccountNumber in SSNArray. "RTN","TMGSEQL1B",610,0) ;" SSNArray is created from the 2nd demographics file. This is a list of ACTIVE patients, "RTN","TMGSEQL1B",611,0) ;" which is different from the 1st demographics file--which holds ALL patients. "RTN","TMGSEQL1B",612,0) ;"Input: PMSAcctNum -- as stored in PtInfo("PMS ACCOUNT NUM") "RTN","TMGSEQL1B",613,0) ;" SSNArray: PASS BY REFERENCE. An array with social security numbers, as created by XtractSSNum() "RTN","TMGSEQL1B",614,0) ;"Result: 1 if patient is INACTIVE, and should be skipped. "RTN","TMGSEQL1B",615,0) ;" 0 if OK to use "RTN","TMGSEQL1B",616,0) "RTN","TMGSEQL1B",617,0) new result "RTN","TMGSEQL1B",618,0) set result=+$get(SSNArray(PMSAcctNum))'>0 "RTN","TMGSEQL1B",619,0) quit result "RTN","TMGSEQL1B",620,0) "RTN","TMGSEQL1B",621,0) "RTN","TMGSEQL1B",622,0) InvalidProvider(SequelProvider) "RTN","TMGSEQL1B",623,0) ;"Purpose: To return if provider should not be used (i.e. cause data to be skipped) "RTN","TMGSEQL1B",624,0) ;"Input: SequelProvider "RTN","TMGSEQL1B",625,0) ;"Result: 0: OK to use provider "RTN","TMGSEQL1B",626,0) ;" 1: Don't use provider "RTN","TMGSEQL1B",627,0) "RTN","TMGSEQL1B",628,0) new result set result=0 "RTN","TMGSEQL1B",629,0) "RTN","TMGSEQL1B",630,0) if SequelProvider="SAMPLE" set result=1 "RTN","TMGSEQL1B",631,0) if SequelProvider="GREENEVILLE" set result=1 "RTN","TMGSEQL1B",632,0) if SequelProvider="AFOSTER" set result=1 "RTN","TMGSEQL1B",633,0) if SequelProvider="AFTON" set result=1 "RTN","TMGSEQL1B",634,0) if SequelProvider="JWRIGHT" set result=1 ;"not an active provider "RTN","TMGSEQL1B",635,0) ;"These providers are leaving group, so don't import their data. "RTN","TMGSEQL1B",636,0) if SequelProvider="CPERRY" set result=1 "RTN","TMGSEQL1B",637,0) if SequelProvider="OSWARNER" set result=1 "RTN","TMGSEQL1B",638,0) if SequelProvider="SGILES" set result=1 "RTN","TMGSEQL1B",639,0) if SequelProvider="SPENNY" set result=1 "RTN","TMGSEQL1B",640,0) if SequelProvider="TFULLER" set result=1 "RTN","TMGSEQL1B",641,0) "RTN","TMGSEQL1B",642,0) quit result "RTN","TMGSEQL1B",643,0) "RTN","TMGSEQL1B",644,0) "RTN","TMGSEQL1B",645,0) UpdateDB(PtInfo,AutoRegister,ErrArray,ChgLog) "RTN","TMGSEQL1B",646,0) ;"Purpose: To put that data from the PtInfo array into the database (if needed) "RTN","TMGSEQL1B",647,0) ;"Input: PtInfo -- array (PASS BY REFERENCE), with the following items being used: "RTN","TMGSEQL1B",648,0) ;" PtInfo("LAST NAME"), to hold 03- pat_last_name, "RTN","TMGSEQL1B",649,0) ;" PtInfo("FIRST NAME"), to hold 04- pat_first_name, "RTN","TMGSEQL1B",650,0) ;" PtInfo("PMS ACCOUNT NUM") ----> field 22701 (custom field) "RTN","TMGSEQL1B",651,0) ;" PtInfo("ADDRESS") ----> field .111 "RTN","TMGSEQL1B",652,0) ;" PtInfo("STATE") ----> field .115 "RTN","TMGSEQL1B",653,0) ;" PtInfo("CITY") ----> field .114 "RTN","TMGSEQL1B",654,0) ;" PtInfo("ZIP CODE") ----> field .1112 "RTN","TMGSEQL1B",655,0) ;" PtInfo("PHONE NUM") ----> field .131 "RTN","TMGSEQL1B",656,0) ;" PtInfo("PROVIDER") ----> field .1041 "RTN","TMGSEQL1B",657,0) ;" PtInfo("SSNUM") ----> field .09 "RTN","TMGSEQL1B",658,0) ;" AutoRegister: if 1, then patient will be automatically added/registered "RTN","TMGSEQL1B",659,0) ;" ErrArray -- PASS BY REFERENCE. And OUT parameter to get back error info. "RTN","TMGSEQL1B",660,0) ;" ChgLog: PASS BY REFERENCE. An array to receive record of changes made to database "RTN","TMGSEQL1B",661,0) ;"Output: Data is put into database, if it is not there already. "RTN","TMGSEQL1B",662,0) ;"Result: 1 successful completion, 0=error "RTN","TMGSEQL1B",663,0) "RTN","TMGSEQL1B",664,0) new Entry "RTN","TMGSEQL1B",665,0) new result set result=1 "RTN","TMGSEQL1B",666,0) new Name,TMGDOB,DFN "RTN","TMGSEQL1B",667,0) new TMGARRAY,TMGMSG "RTN","TMGSEQL1B",668,0) new PriorErrorFound "RTN","TMGSEQL1B",669,0) new NewInfo "RTN","TMGSEQL1B",670,0) new IENS "RTN","TMGSEQL1B",671,0) new index "RTN","TMGSEQL1B",672,0) kill ErrArray "RTN","TMGSEQL1B",673,0) new TMGDEBUG set TMGDEBUG=-1 ;"//EXTRA QUIET mode --> shut down TMGDBAPI messages "RTN","TMGSEQL1B",674,0) "RTN","TMGSEQL1B",675,0) "RTN","TMGSEQL1B",676,0) ;"NOTE: I need to have some method such that IF a patient is positively matched "RTN","TMGSEQL1B",677,0) ;" (i.e. via SSNUM or PMS Account number), THEN changes in spelling of name, or "RTN","TMGSEQL1B",678,0) ;" DOB on Sequel side should be reflected in VistA. Currently, I don't this "RTN","TMGSEQL1B",679,0) ;" this happens. "RTN","TMGSEQL1B",680,0) "RTN","TMGSEQL1B",681,0) new Fields "RTN","TMGSEQL1B",682,0) set Fields(22701)="PMS ACCOUNT NUM" "RTN","TMGSEQL1B",683,0) set Fields(.111)="ADDRESS1" "RTN","TMGSEQL1B",684,0) set Fields(.112)="ADDRESS2" "RTN","TMGSEQL1B",685,0) set Fields(.113)="ADDRESS3" "RTN","TMGSEQL1B",686,0) set Fields(.115)="STATE" "RTN","TMGSEQL1B",687,0) set Fields(.114)="CITY" "RTN","TMGSEQL1B",688,0) set Fields(.1112)="ZIP CODE" "RTN","TMGSEQL1B",689,0) set Fields(.131)="PHONE NUM" "RTN","TMGSEQL1B",690,0) set Fields(.1041)="PROVIDER" "RTN","TMGSEQL1B",691,0) set Fields(.02)="SEX" "RTN","TMGSEQL1B",692,0) set Fields(.09)="SSNUM" "RTN","TMGSEQL1B",693,0) set Fields="22701;.111;.112;.113;.115;.114;.1112;.131;.1041;.09" "RTN","TMGSEQL1B",694,0) "RTN","TMGSEQL1B",695,0) set Name=$get(PtInfo("LAST NAME"))_","_$get(PtInfo("FIRST NAME")) "RTN","TMGSEQL1B",696,0) set Name=$$FormatName^TMGMISC(Name) "RTN","TMGSEQL1B",697,0) set TMGDOB=$get(PtInfo("DOB")) "RTN","TMGSEQL1B",698,0) "RTN","TMGSEQL1B",699,0) set Entry(.01)=Name "RTN","TMGSEQL1B",700,0) set Entry(.03)=TMGDOB "RTN","TMGSEQL1B",701,0) if $get(PtInfo("SEX"))'="" set Entry(.02)=$get(PtInfo("SEX")) "RTN","TMGSEQL1B",702,0) set Entry(.09)=$get(PtInfo("SSNUM")) "RTN","TMGSEQL1B",703,0) "RTN","TMGSEQL1B",704,0) set DFN=$$GetDFN(.PtInfo) "RTN","TMGSEQL1B",705,0) "RTN","TMGSEQL1B",706,0) if (DFN=0)&($get(AutoRegister)=1) do "RTN","TMGSEQL1B",707,0) . set ErrArray=-1 ;"extra quiet mode. "RTN","TMGSEQL1B",708,0) . if $get(Entry(.02))="" do ;"autopick gender if missing "RTN","TMGSEQL1B",709,0) . . new AutoPick "RTN","TMGSEQL1B",710,0) . . set AutoPick=$$GET1^DIQ(22711,"1,","PICK GENDER FROM NAME?","I") "RTN","TMGSEQL1B",711,0) . . if AutoPick'=1 quit "RTN","TMGSEQL1B",712,0) . . set Entry(.02)=$$GetSex^TMGSEQL2($get(PtInfo("FIRST NAME"))) "RTN","TMGSEQL1B",713,0) . ;"OK, can't find, so will add new patient. "RTN","TMGSEQL1B",714,0) . set DFN=+$$AddNewPt^TMGGDFN(.Entry,.ErrArray) "RTN","TMGSEQL1B",715,0) . if DFN'=0 set ChLog(Name_" "_TMGDOB,0)="ADDED PATIENT: "_Name_" "_TMGDOB "RTN","TMGSEQL1B",716,0) if DFN=0 do goto UDBDone ;"failure "RTN","TMGSEQL1B",717,0) . set result=0 "RTN","TMGSEQL1B",718,0) . set ErrArray(0)=$$NameError^TMGSEQL2(.ErrArray) ;"get name if DIERR encountered. "RTN","TMGSEQL1B",719,0) . if ErrArray(0)["DOB" do "RTN","TMGSEQL1B",720,0) . . ;"write !,"DOB error found for: ",PtInfo("FULL NAME"),! "RTN","TMGSEQL1B",721,0) . if ErrArray(0)="" do "RTN","TMGSEQL1B",722,0) . . set ErrArray(0)="PATIENT NOT IN DATABASE:" ;"if changed, also change in TMGSEQL2.m "RTN","TMGSEQL1B",723,0) set IENS=DFN_"," "RTN","TMGSEQL1B",724,0) "RTN","TMGSEQL1B",725,0) ;"use DFN(IEN in file 2) to get data into database "RTN","TMGSEQL1B",726,0) do GETS^DIQ(2,IENS,Fields,"","TMGARRAY","TMGMSG") "RTN","TMGSEQL1B",727,0) "RTN","TMGSEQL1B",728,0) ;"check for errors. "RTN","TMGSEQL1B",729,0) if $data(TMGMSG("DIERR"))'=0 do goto UDBDone "RTN","TMGSEQL1B",730,0) . set result=0 "RTN","TMGSEQL1B",731,0) . merge ErrArray=TMGMSG("DIERR") "RTN","TMGSEQL1B",732,0) . ;"do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSEQL1B",733,0) kill TMGMSG "RTN","TMGSEQL1B",734,0) "RTN","TMGSEQL1B",735,0) ;"If any data in data base differs from Array, setup NewInfo "RTN","TMGSEQL1B",736,0) new UpdateNeeded set UpdateNeeded=0 "RTN","TMGSEQL1B",737,0) new abort set abort=0 "RTN","TMGSEQL1B",738,0) set index=$order(Fields("")) "RTN","TMGSEQL1B",739,0) for do quit:(+index'>0)!(abort=1) "RTN","TMGSEQL1B",740,0) . new field set field=Fields(index) "RTN","TMGSEQL1B",741,0) . if $data(PtInfo(field)),$get(TMGARRAY(2,IENS,index))'=$get(PtInfo(field)) do "RTN","TMGSEQL1B",742,0) . . new value set value=$get(PtInfo(field)) "RTN","TMGSEQL1B",743,0) . . if index=.1112 do "RTN","TMGSEQL1B",744,0) . . . if +value'=0 set NewInfo(index)=value "RTN","TMGSEQL1B",745,0) . . else if (index=.09)&(+value'=0)&(+TMGARRAY(2,IENS,index)'=0) do "RTN","TMGSEQL1B",746,0) . . . if TMGARRAY(2,IENS,index)["P" do quit "RTN","TMGSEQL1B",747,0) . . . . set NewInfo(index)=value "RTN","TMGSEQL1B",748,0) . . . ;"we have CONFLICTING SOCIAL SECURITY NUMBERS --> PROBLEM... "RTN","TMGSEQL1B",749,0) . . . set ErrArray(0)="CONFLICTING SS-NUMBERS: " ;"NOTE! if error message format is changed, also change in TMGSEQL2 "RTN","TMGSEQL1B",750,0) . . . set ErrArray(0)=ErrArray(0)_"Sequel#="_PtInfo(field)_" vs. VistA#="_TMGARRAY(2,IENS,index) "RTN","TMGSEQL1B",751,0) . . . set abort=1,result=0 "RTN","TMGSEQL1B",752,0) . . else set NewInfo(index)=value "RTN","TMGSEQL1B",753,0) . . set UpdateNeeded=1 "RTN","TMGSEQL1B",754,0) . set index=$order(Fields(index)) "RTN","TMGSEQL1B",755,0) "RTN","TMGSEQL1B",756,0) if (UpdateNeeded=0)!(abort=1) goto UDBDone "RTN","TMGSEQL1B",757,0) "RTN","TMGSEQL1B",758,0) ;"Setup FDA array for database update "RTN","TMGSEQL1B",759,0) new TMGFDA "RTN","TMGSEQL1B",760,0) set index=$order(NewInfo("")) "RTN","TMGSEQL1B",761,0) if index'="" do "RTN","TMGSEQL1B",762,0) . for do quit:(+index'>0) "RTN","TMGSEQL1B",763,0) . . set TMGFDA(2,IENS,index)=NewInfo(index) "RTN","TMGSEQL1B",764,0) . . set index=$order(NewInfo(index)) "RTN","TMGSEQL1B",765,0) . ; "RTN","TMGSEQL1B",766,0) . do FILE^DIE("E","TMGFDA","TMGMSG") "RTN","TMGSEQL1B",767,0) . if $data(TMGMSG("DIERR"))'=0 do ;"goto UDBDone "RTN","TMGSEQL1B",768,0) . . set result=0 "RTN","TMGSEQL1B",769,0) . . merge ErrArray=TMGMSG("DIERR") "RTN","TMGSEQL1B",770,0) "RTN","TMGSEQL1B",771,0) merge ChLog($get(Name,"?")_" "_$get(TMGDOB,"?"),1)=NewInfo "RTN","TMGSEQL1B",772,0) "RTN","TMGSEQL1B",773,0) UDBDone "RTN","TMGSEQL1B",774,0) quit result "RTN","TMGSEQL1B",775,0) "RTN","TMGSEQL1B",776,0) "RTN","TMGSEQL1B",777,0) GetDFN(PtInfo) "RTN","TMGSEQL1B",778,0) ;"Purpose: Serve as interface to ^TMGGDFN functions (using PtInfo as input) "RTN","TMGSEQL1B",779,0) ;"Input: PtInfo, Array of PtInfo, as defined in UpdateDB, and created by ParseLine "RTN","TMGSEQL1B",780,0) ;"Result: the IEN in file 2 (i.e. DFN) if found, otherwise 0 if not found. "RTN","TMGSEQL1B",781,0) "RTN","TMGSEQL1B",782,0) new Entry,Name,DOB,DFN "RTN","TMGSEQL1B",783,0) "RTN","TMGSEQL1B",784,0) set Name=$get(PtInfo("LAST NAME"))_","_$get(PtInfo("FIRST NAME")) "RTN","TMGSEQL1B",785,0) set Name=$$FormatName^TMGMISC(Name) "RTN","TMGSEQL1B",786,0) set DOB=$get(PtInfo("DOB")) "RTN","TMGSEQL1B",787,0) "RTN","TMGSEQL1B",788,0) set Entry(.01)=Name "RTN","TMGSEQL1B",789,0) set Entry(.03)=DOB "RTN","TMGSEQL1B",790,0) set Entry(.02)=$get(PtInfo("SEX")) "RTN","TMGSEQL1B",791,0) set Entry(.09)=$get(PtInfo("SSNUM")) "RTN","TMGSEQL1B",792,0) set DFN=+$$LookupPatient^TMGGDFN(.Entry) ;"get IEN in file 2 of patient "RTN","TMGSEQL1B",793,0) ;"do an extended search with increasing intensity. "RTN","TMGSEQL1B",794,0) if +DFN=0 set DFN=$$ExtraLookup^TMGGDFN(.Entry,1) "RTN","TMGSEQL1B",795,0) if +DFN=0 set DFN=$$ExtraLookup^TMGGDFN(.Entry,2) "RTN","TMGSEQL1B",796,0) if +DFN=0 set DFN=$$ExtraLookup^TMGGDFN(.Entry,3) "RTN","TMGSEQL1B",797,0) "RTN","TMGSEQL1B",798,0) quit DFN "RTN","TMGSEQL1B",799,0) "RTN","TMGSEQL1B",800,0) "RTN","TMGSEQL1B",801,0) "RTN","TMGSEQL1B",802,0) XtractSSNum(G2Ref,SSNArray) "RTN","TMGSEQL1B",803,0) ;"Purpose: To extract info from 2nd demographics file into an array of SSNums. "RTN","TMGSEQL1B",804,0) ;"Input: G2Ref - Name of global array holding 2nd demographics file "RTN","TMGSEQL1B",805,0) ;" Note: Format of each line is as follows: "RTN","TMGSEQL1B",806,0) ;" scratchNum,AccountNumber,LastName,FirstName,SSNUM ... (other data is redundant) "RTN","TMGSEQL1B",807,0) ;" i.e. SSNUM is the 5th piece "RTN","TMGSEQL1B",808,0) ;" SSNArray -- PASS BY REFERENCE. An OUT parameter. See format below "RTN","TMGSEQL1B",809,0) ;"Output: SSNArray will be filled as follows: "RTN","TMGSEQL1B",810,0) ;" SSNArray(SequelAccountNumber)=SSNum "RTN","TMGSEQL1B",811,0) ;"Result: None "RTN","TMGSEQL1B",812,0) ;"Note: 3/2/06 modification: "RTN","TMGSEQL1B",813,0) ;" An entry for every SequelAccountNumber will be created. If SSNum is invalid, it will "RTN","TMGSEQL1B",814,0) ;" be converted to 0, but an entry will still be created, i.e. "RTN","TMGSEQL1B",815,0) ;" SSNArray(SequelAccountNumber)=0 "RTN","TMGSEQL1B",816,0) "RTN","TMGSEQL1B",817,0) "RTN","TMGSEQL1B",818,0) new i "RTN","TMGSEQL1B",819,0) "RTN","TMGSEQL1B",820,0) set i=$order(@G2Ref@("")) "RTN","TMGSEQL1B",821,0) if i'="" for do quit:(i="") "RTN","TMGSEQL1B",822,0) . new OneLine,AcctNum,SSNum "RTN","TMGSEQL1B",823,0) . set OneLine=$get(@G2Ref@(i)) "RTN","TMGSEQL1B",824,0) . set AcctNum=$piece(OneLine,",",2) "RTN","TMGSEQL1B",825,0) . set SSNum=$$Trim^TMGSTUTL($piece(OneLine,",",5)) "RTN","TMGSEQL1B",826,0) . new value set value=0 ;"default value "RTN","TMGSEQL1B",827,0) . if +SSNum'<999999 do ;"force at least 6 digits --> allow 0000 11 1111 "RTN","TMGSEQL1B",828,0) . . if $length(SSNum)'=9 do "RTN","TMGSEQL1B",829,0) . . . set SSNArray("ERRORS",AcctNum)=SSNum ;"leaves value="" --> not used "RTN","TMGSEQL1B",830,0) . . else do "RTN","TMGSEQL1B",831,0) . . . ;"set SSNArray(AcctNum)=SSNum "RTN","TMGSEQL1B",832,0) . . . set value=SSNum "RTN","TMGSEQL1B",833,0) . set SSNArray(AcctNum)=value "RTN","TMGSEQL1B",834,0) . set i=$order(@G2Ref@(i)) "RTN","TMGSEQL1B",835,0) "RTN","TMGSEQL1B",836,0) quit "RTN","TMGSEQL1B",837,0) "RTN","TMGSEQL1B",838,0) "RTN","TMGSEQL2") 0^76^B11873 "RTN","TMGSEQL2",1,0) TMGSEQL2 ;TMG/kst/Interface with SequelSystems PMS (Error Hndlng) ;03/25/06 "RTN","TMGSEQL2",2,0) ;;1.0;TMG-LIB;**1**;01/09/06 "RTN","TMGSEQL2",3,0) "RTN","TMGSEQL2",4,0) ;"TMG SEQUEL IMPORT ERROR-HANDLING FUNCTIONS "RTN","TMGSEQL2",5,0) ;"Kevin Toppenberg MD "RTN","TMGSEQL2",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGSEQL2",7,0) ;"1-9-2006 "RTN","TMGSEQL2",8,0) "RTN","TMGSEQL2",9,0) "RTN","TMGSEQL2",10,0) ;"======================================================================= "RTN","TMGSEQL2",11,0) ;" API -- Public Functions. "RTN","TMGSEQL2",12,0) ;"======================================================================= "RTN","TMGSEQL2",13,0) ;"AlertError(OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",14,0) ;"HANDLE "RTN","TMGSEQL2",15,0) "RTN","TMGSEQL2",16,0) "RTN","TMGSEQL2",17,0) ;"======================================================================= "RTN","TMGSEQL2",18,0) ;"PRIVATE API FUNCTIONS "RTN","TMGSEQL2",19,0) ;"======================================================================= "RTN","TMGSEQL2",20,0) ;"EditOneLine(LineIn,LineOut) "RTN","TMGSEQL2",21,0) ;"MakeErrAlert(IEN,User,PtInfo) "RTN","TMGSEQL2",22,0) ;"$$StoreError(OneLine,PtInfo,ErrArray) "RTN","TMGSEQL2",23,0) ;"ErrRefile(OneLine,PtInfo,OneErrArray,DUZ) "RTN","TMGSEQL2",24,0) "RTN","TMGSEQL2",25,0) ;"$$FixRegProblem(PtInfo,OneLine,DelError) "RTN","TMGSEQL2",26,0) ;"$$FixGenProblem(PtInfo,ErrMsg,OneLine,ErrIEN,DelError) "RTN","TMGSEQL2",27,0) ;"$$FixSSNProblem(PtInfo,ErrMsg,OneLine,DelError) "RTN","TMGSEQL2",28,0) ;"$$FixDOBProblem(.PtInfo,ErrMsg,.OneLine,.DelError) "RTN","TMGSEQL2",29,0) "RTN","TMGSEQL2",30,0) ;"$$GetSex(Name) "RTN","TMGSEQL2",31,0) ;"$$SetSex(Name,Sex) "RTN","TMGSEQL2",32,0) ;"$$NameError(OneErrArray) "RTN","TMGSEQL2",33,0) "RTN","TMGSEQL2",34,0) ;"$$IsMissingSex(ErrArray) "RTN","TMGSEQL2",35,0) ;"$$GetSexMissing(PtInfo) "RTN","TMGSEQL2",36,0) "RTN","TMGSEQL2",37,0) ;"======================================================================= "RTN","TMGSEQL2",38,0) ;"DEPENDENCIES "RTN","TMGSEQL2",39,0) ;"TMGSEQL1 "RTN","TMGSEQL2",40,0) ;"TMGSTUTL "RTN","TMGSEQL2",41,0) ;"TMGDEBUG "RTN","TMGSEQL2",42,0) ;"======================================================================= "RTN","TMGSEQL2",43,0) ;"======================================================================= "RTN","TMGSEQL2",44,0) "RTN","TMGSEQL2",45,0) "RTN","TMGSEQL2",46,0) EditOneLine(LineIn,LineOut) "RTN","TMGSEQL2",47,0) ;"Purpose: To allow modification of a line to allow filing. "RTN","TMGSEQL2",48,0) ;"Input: LineIn -- The CSV line to modify. "RTN","TMGSEQL2",49,0) ;" LineOut -- PASS BY REFERENCE, the variable to receive changes "RTN","TMGSEQL2",50,0) ;"Result: 1 if changes made, 0 if no changes made, -1 if abort "RTN","TMGSEQL2",51,0) "RTN","TMGSEQL2",52,0) new tempArray "RTN","TMGSEQL2",53,0) new done set done=0 "RTN","TMGSEQL2",54,0) new abort set abort=0 "RTN","TMGSEQL2",55,0) set LineOut=$get(LineIn) "RTN","TMGSEQL2",56,0) new SavedInput set SavedInput=LineIn "RTN","TMGSEQL2",57,0) new result set result=0 "RTN","TMGSEQL2",58,0) new temp "RTN","TMGSEQL2",59,0) "RTN","TMGSEQL2",60,0) if $get(LineIn)="" do goto EOLDone "RTN","TMGSEQL2",61,0) . write !,"?? No data supplied to edit!",! "RTN","TMGSEQL2",62,0) "RTN","TMGSEQL2",63,0) for do quit:(done)!(abort) "RTN","TMGSEQL2",64,0) . write !,"CSV Line Editor:",! "RTN","TMGSEQL2",65,0) . write "------------------",! "RTN","TMGSEQL2",66,0) . write "1. Show raw CSV line data.",! "RTN","TMGSEQL2",67,0) . write "2. Show resulting parsed array from data.",! "RTN","TMGSEQL2",68,0) . write "3. Modify a specified piece (part) of data.",! "RTN","TMGSEQL2",69,0) . write "4. Display number of pieces, and current values.",! "RTN","TMGSEQL2",70,0) . write "5. Quit.",! "RTN","TMGSEQL2",71,0) . write "^. Abort changes.",! "RTN","TMGSEQL2",72,0) . read !,"Enter Choice: ^// ",temp:$get(DTIME,3600),! "RTN","TMGSEQL2",73,0) . if temp="" set temp="^" "RTN","TMGSEQL2",74,0) . if temp=1 do "RTN","TMGSEQL2",75,0) . . write OneLine,! "RTN","TMGSEQL2",76,0) . else if temp=2 do "RTN","TMGSEQL2",77,0) . . new Array,prsResult "RTN","TMGSEQL2",78,0) . . set prsResult=$$ParseLine^TMGSEQL1(LineOut,.Array) "RTN","TMGSEQL2",79,0) . . if prsResult'=0 do ArrayDump^TMGDEBUG("Array") "RTN","TMGSEQL2",80,0) . . ;"else if prsResult=0 write "There was either a problem parsing this info",! "RTN","TMGSEQL2",81,0) . . ;"else if prsResult-1 write "This patient is inactive, and should be ignored",! "RTN","TMGSEQL2",82,0) . else if temp=3 do "RTN","TMGSEQL2",83,0) . . new P,value "RTN","TMGSEQL2",84,0) . . write "Which piece do you want to edit? (i.e. 1 for first CSV value, 2 for the second etc.)",! "RTN","TMGSEQL2",85,0) . . read "Which piece?: ",P:$get(DTIME,3600),! "RTN","TMGSEQL2",86,0) . . if P="^" set abort=1 quit "RTN","TMGSEQL2",87,0) . . if +P=0 write "Please enter a numeric value.",! quit "RTN","TMGSEQL2",88,0) . . write "The current value for this piece is: ",$piece(LineOut,",",P),! "RTN","TMGSEQL2",89,0) . . read "Enter new value (^ to abort): ",value,! "RTN","TMGSEQL2",90,0) . . if value="^" quit "RTN","TMGSEQL2",91,0) . . set $piece(LineOut,",",P)=value "RTN","TMGSEQL2",92,0) . . set result=1 "RTN","TMGSEQL2",93,0) . else if temp=4 do "RTN","TMGSEQL2",94,0) . . new i for i=1:1:20 do "RTN","TMGSEQL2",95,0) . . . write "Piece #",i," = ",$piece(LineOut,",",i),! "RTN","TMGSEQL2",96,0) . else if temp=5 do "RTN","TMGSEQL2",97,0) . . set done=1 "RTN","TMGSEQL2",98,0) . else if temp="^" do "RTN","TMGSEQL2",99,0) . . set abort=1 "RTN","TMGSEQL2",100,0) . else do quit "RTN","TMGSEQL2",101,0) . . write "Please enter a valid choice, or ^ to abort.",! "RTN","TMGSEQL2",102,0) "RTN","TMGSEQL2",103,0) "RTN","TMGSEQL2",104,0) EOLDone "RTN","TMGSEQL2",105,0) if abort do "RTN","TMGSEQL2",106,0) . set result=-1 "RTN","TMGSEQL2",107,0) . set LineOut=SavedInput "RTN","TMGSEQL2",108,0) "RTN","TMGSEQL2",109,0) quit result "RTN","TMGSEQL2",110,0) "RTN","TMGSEQL2",111,0) "RTN","TMGSEQL2",112,0) AlertError(OneLine,PtInfo,OneErrArray,DUZ) "RTN","TMGSEQL2",113,0) ;"Purpose: To put the error information info into TMG DEMOGRAPHICS IMPORT ERRORS (22706) "RTN","TMGSEQL2",114,0) ;" and to create a corresponding alert "RTN","TMGSEQL2",115,0) ;"Input: OneLine -- The original CVS format data line "RTN","TMGSEQL2",116,0) ;" PtInfo -- PASS BY REFERENCE. an array containing patient info, as created by ParseLine() "RTN","TMGSEQL2",117,0) ;" ErrArray -- PASS BY REFERENCE. The Array containing the error information, "RTN","TMGSEQL2",118,0) ;" with following format: "RTN","TMGSEQL2",119,0) ;" ErrArray(0)=local message (if any) "RTN","TMGSEQL2",120,0) ;" ErrArray("DIERR")=Standard fileman DIERR array. "RTN","TMGSEQL2",121,0) ;" User -- the IEN in file 200 (i.e. DUZ) of user to receive alert. "RTN","TMGSEQL2",122,0) ;"Output: new record is created in file 22706 "RTN","TMGSEQL2",123,0) ;"Result: none "RTN","TMGSEQL2",124,0) "RTN","TMGSEQL2",125,0) new IEN,Msg "RTN","TMGSEQL2",126,0) set IEN=$$StoreError^TMGSEQL2(OneLine,.PtInfo,.OneErrArray) "RTN","TMGSEQL2",127,0) set Msg=$get(OneErrArray(0),"Problem with upload of Sequel data for:") "RTN","TMGSEQL2",128,0) set Msg=$piece(Msg,":",1) "RTN","TMGSEQL2",129,0) set Msg=Msg_" "_$get(PtInfo("FULL NAME")) "RTN","TMGSEQL2",130,0) do MakeErrAlert^TMGSEQL2(IEN,DUZ,Msg) "RTN","TMGSEQL2",131,0) "RTN","TMGSEQL2",132,0) quit "RTN","TMGSEQL2",133,0) "RTN","TMGSEQL2",134,0) "RTN","TMGSEQL2",135,0) StoreError(OneLine,PtInfo,ErrArray) "RTN","TMGSEQL2",136,0) ;"Purpose: To put the error information info into TMG DEMOGRAPHICS IMPORT ERRORS (22706) "RTN","TMGSEQL2",137,0) ;"Input: OneLine -- The original CVS format data line "RTN","TMGSEQL2",138,0) ;" PtInfo -- PASS BY REFERENCE. an array containing patient info, as created by ParseLine() "RTN","TMGSEQL2",139,0) ;" ErrArray -- PASS BY REFERENCE. The Array containing the error information, "RTN","TMGSEQL2",140,0) ;" with following format: "RTN","TMGSEQL2",141,0) ;" ErrArray(0)=local message (if any) "RTN","TMGSEQL2",142,0) ;" ErrArray("DIERR")=Standard fileman DIERR array. "RTN","TMGSEQL2",143,0) ;"Output: new record is created in file 22706 "RTN","TMGSEQL2",144,0) ;"Result: IEN of newly created record (or 0 if error). "RTN","TMGSEQL2",145,0) "RTN","TMGSEQL2",146,0) new result set result=0 "RTN","TMGSEQL2",147,0) new TMGFDA,Name "RTN","TMGSEQL2",148,0) set Name=$get(PtInfo("FULL NAME3")) "RTN","TMGSEQL2",149,0) set Msg=$get(ErrArray(0)) "RTN","TMGSEQL2",150,0) "RTN","TMGSEQL2",151,0) set TMGFDA(22706,"+1,",.01)=$get(PtInfo("SEQUEL ACCOUNT NUM")) ;".01=ACCOUNT NUMBER "RTN","TMGSEQL2",152,0) set TMGFDA(22706,"+1,",.02)="NOW" ;".02=CREATION DATE "RTN","TMGSEQL2",153,0) set TMGFDA(22706,"+1,",.03)=Name ;".03=PATIENT NAME "RTN","TMGSEQL2",154,0) if Msg'="" set TMGFDA(22706,"+1,",1)=Msg ;"1=MESSAGE "RTN","TMGSEQL2",155,0) new TMGIENA,TMGERR "RTN","TMGSEQL2",156,0) do UPDATE^DIE("E","TMGFDA","TMGIENA","TMGERR") "RTN","TMGSEQL2",157,0) new IEN set IEN=$get(TMGIENA(1)) "RTN","TMGSEQL2",158,0) "RTN","TMGSEQL2",159,0) new TMGWP "RTN","TMGSEQL2",160,0) new TMGDIERR merge TMGDIERR("DIERR")=ErrArray("DIERR") "RTN","TMGSEQL2",161,0) new ErrStr set ErrStr=$$GetErrStr^TMGDEBUG(.TMGDIERR) "RTN","TMGSEQL2",162,0) if ErrStr'="" do "RTN","TMGSEQL2",163,0) . do StrToWP^TMGSTUTL(ErrStr,"TMGWP",60," ") "RTN","TMGSEQL2",164,0) . if +IEN>0 do "RTN","TMGSEQL2",165,0) . . do WP^DIE(22706,IEN_",",3,,"TMGWP","TMGERR") ;"3=DIERR MESSAGE "RTN","TMGSEQL2",166,0) . . new PriorErrorFound set PriorErrorFound=0 "RTN","TMGSEQL2",167,0) . . if $data(TMGERR("DIERR")) do ShowDIERR^TMGDEBUG(.TMGERR,.PriorErrorFound) "RTN","TMGSEQL2",168,0) "RTN","TMGSEQL2",169,0) kill TMGWP "RTN","TMGSEQL2",170,0) do StrToWP^TMGSTUTL(OneLine,"TMGWP",60,",") "RTN","TMGSEQL2",171,0) if +IEN>0 do "RTN","TMGSEQL2",172,0) . do WP^DIE(22706,IEN_",",2,,"TMGWP","TMGERR") ;"2=IMPORT DATA "RTN","TMGSEQL2",173,0) . new PriorErrorFound set PriorErrorFound=0 "RTN","TMGSEQL2",174,0) . if $data(TMGERR("DIERR")) do ShowDIERR^TMGDEBUG(.TMGERR,.PriorErrorFound) "RTN","TMGSEQL2",175,0) "RTN","TMGSEQL2",176,0) set result=IEN "RTN","TMGSEQL2",177,0) "RTN","TMGSEQL2",178,0) quit result "RTN","TMGSEQL2",179,0) "RTN","TMGSEQL2",180,0) "RTN","TMGSEQL2",181,0) MakeErrAlert(IEN,User,Message) "RTN","TMGSEQL2",182,0) ;"Purpose: To create an alert regarding upload error "RTN","TMGSEQL2",183,0) ;"Input: IEN -- The IEN of the error, stored in file 22706 "RTN","TMGSEQL2",184,0) ;" User -- the IEN in file 200 (i.e. DUZ) of user to receive alert. "RTN","TMGSEQL2",185,0) ;" Message -- the Message of the alert "RTN","TMGSEQL2",186,0) ;"Output: An alert will be created in send to User "RTN","TMGSEQL2",187,0) ;"Result: none "RTN","TMGSEQL2",188,0) "RTN","TMGSEQL2",189,0) new XQA,XQAMSG,XQAID "RTN","TMGSEQL2",190,0) new XQAOPT ;" ensure no residual menu option specified "RTN","TMGSEQL2",191,0) "RTN","TMGSEQL2",192,0) set XQA(User)="" "RTN","TMGSEQL2",193,0) set XQAMSG=Message "RTN","TMGSEQL2",194,0) set XQAID="TMGSQLIMPORT" "RTN","TMGSEQL2",195,0) set XQADATA=IEN "RTN","TMGSEQL2",196,0) set XQAROU="HANDLE^TMGSEQL2" "RTN","TMGSEQL2",197,0) "RTN","TMGSEQL2",198,0) do SETUP^XQALERT "RTN","TMGSEQL2",199,0) "RTN","TMGSEQL2",200,0) quit "RTN","TMGSEQL2",201,0) "RTN","TMGSEQL2",202,0) ErrRefile(OneLine,PtInfo,OneErrArray,DUZ) "RTN","TMGSEQL2",203,0) ;"Purpose: A common point to process errors encountering errors on refilling "RTN","TMGSEQL2",204,0) ;"Input: OneLine -- the originial CSV data line. "RTN","TMGSEQL2",205,0) ;" PtInfo -- PASS BY REFERENCE -- the Patient Info array, as created by ParseLine^TMGSEQL1 "RTN","TMGSEQL2",206,0) ;" OneErrArray -- PASS BY REFERENCE -- The error array encountered, returned from Fileman "RTN","TMGSEQL2",207,0) ;" DUZ -- the user IEN (from file 2) to recieve alert "RTN","TMGSEQL2",208,0) ;"Output: A new alert will be created, and messages written to screen "RTN","TMGSEQL2",209,0) ;"Result : none "RTN","TMGSEQL2",210,0) "RTN","TMGSEQL2",211,0) write "There is still an error:",! "RTN","TMGSEQL2",212,0) zwr OneErrArray(*) "RTN","TMGSEQL2",213,0) write "A new alert will be made to handle this new error.",! "RTN","TMGSEQL2",214,0) set OneErrArray(0)=$$NameError(.OneErrArray) "RTN","TMGSEQL2",215,0) write OneErrArray(0),! "RTN","TMGSEQL2",216,0) do AlertError^TMGSEQL2(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",217,0) "RTN","TMGSEQL2",218,0) quit "RTN","TMGSEQL2",219,0) "RTN","TMGSEQL2",220,0) HANDLE "RTN","TMGSEQL2",221,0) ;"Purpose: This is called by the alert system to handle the error alert "RTN","TMGSEQL2",222,0) ;"Input: All the inputs are via variables with global scope. Details below "RTN","TMGSEQL2",223,0) ;" XQADATA-- the IEN in file 22706 "RTN","TMGSEQL2",224,0) ;" XQAKILL-- 1 --> kill when done. To alter behavior, this function can change "RTN","TMGSEQL2",225,0) ;" (to prevent deletion when done, then KILL XQAKILL) "RTN","TMGSEQL2",226,0) ;"Output: Allows user to edit data and reattempt filing of data "RTN","TMGSEQL2",227,0) ;"Result: none. "RTN","TMGSEQL2",228,0) "RTN","TMGSEQL2",229,0) "RTN","TMGSEQL2",230,0) new Fixed set Fixed=0 "RTN","TMGSEQL2",231,0) "RTN","TMGSEQL2",232,0) new OneLine,PtInfo "RTN","TMGSEQL2",233,0) new TMGWP,TMGMSG "RTN","TMGSEQL2",234,0) new tempResult "RTN","TMGSEQL2",235,0) new ErrIEN "RTN","TMGSEQL2",236,0) new DelError set DelError=0 "RTN","TMGSEQL2",237,0) "RTN","TMGSEQL2",238,0) if $get(XQADATA)'>0 do goto HndDone "RTN","TMGSEQL2",239,0) . write !!,"No value in XQADATA, so quitting.",! "RTN","TMGSEQL2",240,0) . write "(Deleting alert.)",! "RTN","TMGSEQL2",241,0) . set Fixed=1,DelError=1 "RTN","TMGSEQL2",242,0) set ErrIEN=XQADATA "RTN","TMGSEQL2",243,0) "RTN","TMGSEQL2",244,0) write !!,"Problem with upload of Sequel data. ",! "RTN","TMGSEQL2",245,0) "RTN","TMGSEQL2",246,0) ;"temp "RTN","TMGSEQL2",247,0) write "IEN in file# 22706=",ErrIEN,! "RTN","TMGSEQL2",248,0) "RTN","TMGSEQL2",249,0) new x set x=$$GET1^DIQ(22706,ErrIEN_",",2,"","TMGWP","TMGMSG") "RTN","TMGSEQL2",250,0) if $data(TMGMSG("DIERR"))'=0 do goto HndDone "RTN","TMGSEQL2",251,0) . new PriorErrorFound "RTN","TMGSEQL2",252,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSEQL2",253,0) . set Fixed=1,DelError=1 "RTN","TMGSEQL2",254,0) set OneLine=$$WPToStr^TMGSTUTL("TMGWP","") "RTN","TMGSEQL2",255,0) if $$ParseLine^TMGSEQL1(OneLine,.PtInfo)=0 do goto HndDone "RTN","TMGSEQL2",256,0) . write "Error parsing Alert data into patient data.",! "RTN","TMGSEQL2",257,0) write $get(PtInfo("FULL NAME")),! "RTN","TMGSEQL2",258,0) "RTN","TMGSEQL2",259,0) new ErrMsg set ErrMsg=$$GET1^DIQ(22706,ErrIEN_",",1) "RTN","TMGSEQL2",260,0) write ErrMsg,! "RTN","TMGSEQL2",261,0) "RTN","TMGSEQL2",262,0) kill TMGWP,TMGMSG "RTN","TMGSEQL2",263,0) new x set x=$$GET1^DIQ(22706,ErrIEN_",",3,"","TMGWP","TMGMSG") "RTN","TMGSEQL2",264,0) if $data(TMGMSG("DIERR"))'=0 do goto HndDone "RTN","TMGSEQL2",265,0) . new PriorErrorFound "RTN","TMGSEQL2",266,0) . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) "RTN","TMGSEQL2",267,0) . set Fixed=1,DelError=1 "RTN","TMGSEQL2",268,0) if $data(TMGWP) do "RTN","TMGSEQL2",269,0) . do WriteWP^TMGSTUTL("TMGWP") "RTN","TMGSEQL2",270,0) "RTN","TMGSEQL2",271,0) if ErrMsg["PATIENT NOT IN DATABASE" do "RTN","TMGSEQL2",272,0) . set Fixed=$$FixRegProblem(.PtInfo,.OneLine,.DelError) "RTN","TMGSEQL2",273,0) else if ErrMsg["INVALID/MISSING GENDER" do "RTN","TMGSEQL2",274,0) . set Fixed=$$FixRegProblem(.PtInfo,.OneLine,.DelError) "RTN","TMGSEQL2",275,0) else if ErrMsg["CONFLICTING SS-NUMBERS" do "RTN","TMGSEQL2",276,0) . set Fixed=$$FixSSNProblem(.PtInfo,ErrMsg,.OneLine,.DelError) "RTN","TMGSEQL2",277,0) else if ErrMsg["INVALID DOB ERROR" do "RTN","TMGSEQL2",278,0) . write "Date of birth (DOB) is incorrect for this patient.",! "RTN","TMGSEQL2",279,0) . write "Note: The recommended method of correcting this problem is",! "RTN","TMGSEQL2",280,0) . write " to fix the problem in Sequel, not here. Otherwise",! "RTN","TMGSEQL2",281,0) . write " the same error will be encountered with each demographics",! "RTN","TMGSEQL2",282,0) . write " upload.",!! "RTN","TMGSEQL2",283,0) . set Fixed=$$FixGenProblem(.PtInfo,ErrMsg,.OneLine,.DelError) "RTN","TMGSEQL2",284,0) else do "RTN","TMGSEQL2",285,0) . set Fixed=$$FixGenProblem(.PtInfo,ErrMsg,.OneLine,.DelError,ErrIEN) "RTN","TMGSEQL2",286,0) "RTN","TMGSEQL2",287,0) if DelError=1 do "RTN","TMGSEQL2",288,0) . new temp,ErrArray "RTN","TMGSEQL2",289,0) . set temp=$$DelIEN^TMGDBAPI(22706,ErrIEN,.ErrArray) ;"success, so kill error entry in 22706 "RTN","TMGSEQL2",290,0) "RTN","TMGSEQL2",291,0) HndDone "RTN","TMGSEQL2",292,0) ;"if Fixed=1 write !,"SUCCESS!" "RTN","TMGSEQL2",293,0) "RTN","TMGSEQL2",294,0) if (Fixed=0)!(DelError=0) do ;"<------------- this logic may be off... "RTN","TMGSEQL2",295,0) . kill XQAKILL ;"--> don't delete alert "RTN","TMGSEQL2",296,0) . write "(Saving alert...)",! "RTN","TMGSEQL2",297,0) "RTN","TMGSEQL2",298,0) quit "RTN","TMGSEQL2",299,0) "RTN","TMGSEQL2",300,0) "RTN","TMGSEQL2",301,0) FixRegProblem(PtInfo,OneLine,DelError) "RTN","TMGSEQL2",302,0) ;"Purpose: To fix problems where patient couldn't be added to the database "RTN","TMGSEQL2",303,0) ;"Input: PtInfo -- PASS BY REFERENCE -- the Patient Info array, as created by ParseLine^TMGSEQL1 "RTN","TMGSEQL2",304,0) ;" OneLine -- the originial CSV data line. Passed to this function in case a new Alert "RTN","TMGSEQL2",305,0) ;" must be created, in which case it is stored in the new error message. "RTN","TMGSEQL2",306,0) ;" DelError -- and OUT parameter. Set to 1 will signal the deletion of the error "RTN","TMGSEQL2",307,0) ;" record in file 22706 "RTN","TMGSEQL2",308,0) ;"Output: Patient may be added to FILE 2, or file updated. If succesfull, record of error "RTN","TMGSEQL2",309,0) ;" in file 22706 will deleted "RTN","TMGSEQL2",310,0) ;"Result: 1=problem fixed, 0=not fixed. "RTN","TMGSEQL2",311,0) "RTN","TMGSEQL2",312,0) new Fixed set Fixed=0 "RTN","TMGSEQL2",313,0) set DelError=0 "RTN","TMGSEQL2",314,0) new TMGRemSex,InitRemSex "RTN","TMGSEQL2",315,0) set TMGRemSex=+$$GET1^DIQ(22711,"1,","PICK GENDER FROM NAME?","I") "RTN","TMGSEQL2",316,0) set InitRemSex=TMGRemSex "RTN","TMGSEQL2",317,0) "RTN","TMGSEQL2",318,0) new AutoRegister set AutoRegister=1 ;"automatically add patient to database if not found "RTN","TMGSEQL2",319,0) new OneErrArray,ChgLog "RTN","TMGSEQL2",320,0) new done set done=0 "RTN","TMGSEQL2",321,0) for do quit:(done=1) "RTN","TMGSEQL2",322,0) . kill OneErrArray,ChgLog "RTN","TMGSEQL2",323,0) . new tempResult "RTN","TMGSEQL2",324,0) . set tempResult=$$UpdateDB^TMGSEQL1(.PtInfo,AutoRegister,.OneErrArray,.ChgLog) ;"0=error "RTN","TMGSEQL2",325,0) . set DelError=1 "RTN","TMGSEQL2",326,0) . set Fixed=1 "RTN","TMGSEQL2",327,0) . set done=1 "RTN","TMGSEQL2",328,0) . if tempResult=0 do "RTN","TMGSEQL2",329,0) . . if $$IsMissingSex(.OneErrArray)=1 do "RTN","TMGSEQL2",330,0) . . . if $$GetSexMissing(.PtInfo,.TMGRemSex)=0 do "RTN","TMGSEQL2",331,0) . . . . set done=1 ;"0=failed "RTN","TMGSEQL2",332,0) . . . . set Fixed=0 "RTN","TMGSEQL2",333,0) . . else do "RTN","TMGSEQL2",334,0) . . . write "There is still an error:",! "RTN","TMGSEQL2",335,0) . . . ;"zwr OneErrArray(*) "RTN","TMGSEQL2",336,0) . . . write "A new alert will be made to handle this new error.",! "RTN","TMGSEQL2",337,0) . . . do ErrRefile(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",338,0) . . . ;"set OneErrArray(0)=$$NameError(.OneErrArray) "RTN","TMGSEQL2",339,0) . . . ;"write OneErrArray(0),! "RTN","TMGSEQL2",340,0) . . . ;"do AlertError^TMGSEQL2(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",341,0) "RTN","TMGSEQL2",342,0) if TMGRemSex'=InitRemSex do ;"if status of auto-pick gender was changed in GetSexMissing, store in settings. "RTN","TMGSEQL2",343,0) . new TMGFDA,TMGMSG "RTN","TMGSEQL2",344,0) . set TMGFDA(22711,"1,",6)=TMGRemSex ;"field# 6='PICK GENDER FROM NAME?' "RTN","TMGSEQL2",345,0) . do FILE^DIE("E","TMGFDA","TMGMSG") ;"note TMGMSG is ignored here... "RTN","TMGSEQL2",346,0) "RTN","TMGSEQL2",347,0) quit Fixed "RTN","TMGSEQL2",348,0) "RTN","TMGSEQL2",349,0) IsMissingSex(ErrArray) "RTN","TMGSEQL2",350,0) ;"Purpose: To analyze a Fileman error array and see if field .02 (SEX) is missing, causing problem "RTN","TMGSEQL2",351,0) ;"Input: ErrArray -- PASS BY REFERENCE, an error message, as created by Fileman while adding patient. "RTN","TMGSEQL2",352,0) ;"Result: 1=missing sex (.02 field), other 0 "RTN","TMGSEQL2",353,0) ;"Note: this only reviews error #1 (ignores other errors, if present. So, if missing sex error "RTN","TMGSEQL2",354,0) ;" was in position #2, this function WOULD RETURN AN ERRORONEOUS ANSWER. "RTN","TMGSEQL2",355,0) "RTN","TMGSEQL2",356,0) new result set result=0 "RTN","TMGSEQL2",357,0) "RTN","TMGSEQL2",358,0) if $data(ErrArray("DIERR","E",311,1)) do ;"311=The record lacks some required identifiers. "RTN","TMGSEQL2",359,0) . if $get(ErrArray("DIERR",1,"PARAM","FIELD"))'=.02 quit "RTN","TMGSEQL2",360,0) . if $get(ErrArray("DIERR",1,"PARAM","FILE"))'=2 quit "RTN","TMGSEQL2",361,0) . set result=1 "RTN","TMGSEQL2",362,0) "RTN","TMGSEQL2",363,0) quit result "RTN","TMGSEQL2",364,0) "RTN","TMGSEQL2",365,0) "RTN","TMGSEQL2",366,0) "RTN","TMGSEQL2",367,0) "RTN","TMGSEQL2",368,0) GetSexMissing(PtInfo,TMGRemSex) "RTN","TMGSEQL2",369,0) ;"Purpose: To correct the PtInfo Array so that SEX is supplied answer. "RTN","TMGSEQL2",370,0) ;"Input: PtInfo -- PASS BY REFERENCE -- the Patient Info array, as created by ParseLine^TMGSEQL1 "RTN","TMGSEQL2",371,0) ;" TMGRemSex --PASS BY REFERENCE -- 1 if OK to automatically pick sex based on gender of name "RTN","TMGSEQL2",372,0) ;"Output: PtInfo should be filled with SEX of patient "RTN","TMGSEQL2",373,0) ;"Result: 1=OK to continue, 0=failed to get SEX "RTN","TMGSEQL2",374,0) "RTN","TMGSEQL2",375,0) new result set result=0 ;"default to failure "RTN","TMGSEQL2",376,0) new temp set temp="" "RTN","TMGSEQL2",377,0) new Abort set Abort=0 "RTN","TMGSEQL2",378,0) "RTN","TMGSEQL2",379,0) if $get(PtInfo("SEX"))'="" set result=1 goto GSMDone "RTN","TMGSEQL2",380,0) if $get(PtInfo("FULL NAME"))="" goto GSMDone "RTN","TMGSEQL2",381,0) new FName set FName=$get(PtInfo("FIRST NAME")) "RTN","TMGSEQL2",382,0) if FName="" goto GSMDone "RTN","TMGSEQL2",383,0) "RTN","TMGSEQL2",384,0) for do quit:(temp'="")!(Abort=1) "RTN","TMGSEQL2",385,0) . new presumedSex,RemName "RTN","TMGSEQL2",386,0) . set CurrentSex="" "RTN","TMGSEQL2",387,0) . set TMGRemSex=$get(TMGRemSex,0) "RTN","TMGSEQL2",388,0) . write "Trying to determine the SEX of: ",PtInfo("FULL NAME"),!! "RTN","TMGSEQL2",389,0) . write "OPTIONS:",! "RTN","TMGSEQL2",390,0) . write "-----------------",! "RTN","TMGSEQL2",391,0) . write "M or MALE --> Name is MALE",! "RTN","TMGSEQL2",392,0) . write "M! or MALE! --> ALWAYS consider this name as MALE",! "RTN","TMGSEQL2",393,0) . write "F or FEMALE --> Name is FEMALE",! "RTN","TMGSEQL2",394,0) . write "F! or FEMALE! --> ALWAYS consider this name as FEMALE",! "RTN","TMGSEQL2",395,0) . write "AUTO --> Turn auto-pick-gender: ",$select(TMGRemSex=1:"OFF",1:"ON"),! "RTN","TMGSEQL2",396,0) . write "^ Abort",! "RTN","TMGSEQL2",397,0) . set presumedSex=$$GetSex(FName) "RTN","TMGSEQL2",398,0) . write "Is ",FName," MALE or FEMALE? ",presumedSex,"//" "RTN","TMGSEQL2",399,0) . if (TMGRemSex=1)&(presumedSex'="") set temp=presumedSex "RTN","TMGSEQL2",400,0) . else read temp:$get(DTIME,3600) "RTN","TMGSEQL2",401,0) . if temp="" set temp=presumedSex "RTN","TMGSEQL2",402,0) . set RemName=(temp["!") "RTN","TMGSEQL2",403,0) . set temp=$translate(temp,"!","") "RTN","TMGSEQL2",404,0) . set temp=$$UP^XLFSTR(temp) "RTN","TMGSEQL2",405,0) . if (temp="M")!(temp="MALE") set CurrentSex="MALE" "RTN","TMGSEQL2",406,0) . else if (temp="F")!(temp="FEMALE") set CurrentSex="FEMALE" "RTN","TMGSEQL2",407,0) . else if temp="^" do quit "RTN","TMGSEQL2",408,0) . . write "aborting..",! "RTN","TMGSEQL2",409,0) . . set Abort=1 "RTN","TMGSEQL2",410,0) . else if temp="AUTO" do "RTN","TMGSEQL2",411,0) . . set TMGRemSex='(TMGRemSex) "RTN","TMGSEQL2",412,0) . if CurrentSex'="" do quit "RTN","TMGSEQL2",413,0) . . write " ",CurrentSex,! "RTN","TMGSEQL2",414,0) . . set PtInfo("SEX")=CurrentSex "RTN","TMGSEQL2",415,0) . . set result=1 "RTN","TMGSEQL2",416,0) . . if RemName do "RTN","TMGSEQL2",417,0) . . . new temp set temp=$$SetSex(FName,CurrentSex) "RTN","TMGSEQL2",418,0) . set temp="" ;" a signal to try again. "RTN","TMGSEQL2",419,0) "RTN","TMGSEQL2",420,0) GSMDone "RTN","TMGSEQL2",421,0) quit result "RTN","TMGSEQL2",422,0) "RTN","TMGSEQL2",423,0) "RTN","TMGSEQL2",424,0) FixSSNProblem(PtInfo,ErrMsg,OneLine,DelError) "RTN","TMGSEQL2",425,0) ;"Purpose: To fix problems of conflicting SS numbers "RTN","TMGSEQL2",426,0) ;"Input: PtInfo -- PASS BY REFERENCE -- the Patient Info array, as created by ParseLine^TMGSEQL1 "RTN","TMGSEQL2",427,0) ;" ErrMsg -- the message that holds the conflicting SSNums "RTN","TMGSEQL2",428,0) ;" OneLine -- the originial CSV data line. Passed to this function in case a new Alert "RTN","TMGSEQL2",429,0) ;" must be created, in which case it is stored in the new error message. "RTN","TMGSEQL2",430,0) ;" DelError -- and OUT parameter. Set to 1 will signal the deletion of the error "RTN","TMGSEQL2",431,0) ;" record in file 22706 "RTN","TMGSEQL2",432,0) ;"Output: Patient may be added to FILE 2, or file updated. If succesfull, record of error "RTN","TMGSEQL2",433,0) ;" in file 22706 will deleted "RTN","TMGSEQL2",434,0) ;"Result: 1=problem fixed, 0=not fixed. "RTN","TMGSEQL2",435,0) "RTN","TMGSEQL2",436,0) new sqSSNum,vSSNum "RTN","TMGSEQL2",437,0) new Fixed set Fixed=0 "RTN","TMGSEQL2",438,0) new done set done=0 "RTN","TMGSEQL2",439,0) set DelError=0 "RTN","TMGSEQL2",440,0) "RTN","TMGSEQL2",441,0) if $get(ErrMsg)="" goto FSNPDone "RTN","TMGSEQL2",442,0) "RTN","TMGSEQL2",443,0) if ErrMsg["(Sequel#)" do ;"old format "RTN","TMGSEQL2",444,0) . set sqSSN=$piece(ErrMsg,"SS-NUMBERS: ",2) "RTN","TMGSEQL2",445,0) . set sqSSN=$piece(sqSSN," ",1) "RTN","TMGSEQL2",446,0) . set vSSN=$piece(ErrMsg,"vs. ",2) "RTN","TMGSEQL2",447,0) . set vSSN=$piece(vSSN," ",1) "RTN","TMGSEQL2",448,0) else do "RTN","TMGSEQL2",449,0) . set sqSSN=$piece(ErrMsg,"Sequel#=",2) "RTN","TMGSEQL2",450,0) . set sqSSN=$piece(sqSSN," ",1) "RTN","TMGSEQL2",451,0) . set vSSN=$piece(ErrMsg,"VistA#=",2) "RTN","TMGSEQL2",452,0) . set vSSN=$piece(vSSN," ",1) "RTN","TMGSEQL2",453,0) "RTN","TMGSEQL2",454,0) new vFullName "RTN","TMGSEQL2",455,0) do ;"get actual full name & DOB for VistA SSN "RTN","TMGSEQL2",456,0) . new vName,vDOB "RTN","TMGSEQL2",457,0) . new tempDFN set tempDFN=$$SSNumLookup^TMGGDFN(vSSN) "RTN","TMGSEQL2",458,0) . new TMGMSG,TMGERR,IENS "RTN","TMGSEQL2",459,0) . set IENS=+tempDFN_"," "RTN","TMGSEQL2",460,0) . do GETS^DIQ(2,IENS,".01;.03","E","TMGMSG","TMGERR") "RTN","TMGSEQL2",461,0) . if $data(TMGERR("DIERR")) do "RTN","TMGSEQL2",462,0) . . new PriorErrorFound "RTN","TMGSEQL2",463,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSEQL2",464,0) . set vName=$get(TMGMSG(2,IENS,.01,"E")) "RTN","TMGSEQL2",465,0) . set vDOB=$get(TMGMSG(2,IENS,.03,"E")) "RTN","TMGSEQL2",466,0) . set vFullName=vName_" ("_vDOB_")" "RTN","TMGSEQL2",467,0) "RTN","TMGSEQL2",468,0) write ! "RTN","TMGSEQL2",469,0) "RTN","TMGSEQL2",470,0) for do quit:(done=1) "RTN","TMGSEQL2",471,0) . write "There is a conflict between Social Security Numbers (SSN):",! "RTN","TMGSEQL2",472,0) . write "1. ",sqSSN," is the Sequel SSN for: ",$get(PtInfo("FULL NAME2")),! "RTN","TMGSEQL2",473,0) . write "2. ",vSSN," is the VistA SSN for: ",$get(vFullName),! "RTN","TMGSEQL2",474,0) . write "3. (Don't change either one, but remove alert)",! "RTN","TMGSEQL2",475,0) . write !,"Which SSN is correct? (1, 2, 3, or ^ to abort)? // " "RTN","TMGSEQL2",476,0) . new temp read temp:$get(DTIME,3600),! "RTN","TMGSEQL2",477,0) . if temp="^" set done=1 quit ;"quit, error unfixed. "RTN","TMGSEQL2",478,0) . if temp=3 do quit ;"keep both "RTN","TMGSEQL2",479,0) . . write "OK, no data changes made. Will delete alert.",! "RTN","TMGSEQL2",480,0) . . set Fixed=1,done=1 "RTN","TMGSEQL2",481,0) . if temp=2 do quit ;"keep VistA, advice manual fix in Sequel database, delete alert. "RTN","TMGSEQL2",482,0) . . write "OK. Please manually alter the SSN in the Sequel Database. This should then be",! "RTN","TMGSEQL2",483,0) . . write "reflected in the next demographic data upload cycle.",! "RTN","TMGSEQL2",484,0) . . set Fixed=1 ;"This will signal the deletion of the alert "RTN","TMGSEQL2",485,0) . . set done=1 "RTN","TMGSEQL2",486,0) . if temp=1 do ;"keep Sequel, delete VistA SSN "RTN","TMGSEQL2",487,0) . . set done=1 "RTN","TMGSEQL2",488,0) . . set Fixed=1 "RTN","TMGSEQL2",489,0) . . set DelError=1 "RTN","TMGSEQL2",490,0) . . new DFN set DFN=$$GetDFN^TMGSEQL1(.PtInfo) "RTN","TMGSEQL2",491,0) . . new TMGFDA,TMGMSG,tempResult "RTN","TMGSEQL2",492,0) . . set TMGFDA(2,DFN_",",.09)="@" ;"delete .09 field (SSN) "RTN","TMGSEQL2",493,0) . . set tempResult=$$dbWrite^TMGDBAPI(.TMGFDA,1,,,.TMGMSG) "RTN","TMGSEQL2",494,0) . . if tempResult=0 quit ;"error found, so quit "RTN","TMGSEQL2",495,0) . . ;"Now try filing again. "RTN","TMGSEQL2",496,0) . . new OneErrErray,ChgLog "RTN","TMGSEQL2",497,0) . . new AutoRegister set AutoRegister=0 ;"should need to add patient, as must exist to confilict in first place! "RTN","TMGSEQL2",498,0) . . set tempResult=$$UpdateDB^TMGSEQL1(.PtInfo,AutoRegister,.OneErrArray,.ChgLog) ;"0=error "RTN","TMGSEQL2",499,0) . . if tempResult=0 do "RTN","TMGSEQL2",500,0) . . . do ErrRefile(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",501,0) . . . ;"write "There is still an error:",! "RTN","TMGSEQL2",502,0) . . . ;"zwr OneErrArray(*) "RTN","TMGSEQL2",503,0) . . . ;"write "A new alert will be made to handle this new error.",! "RTN","TMGSEQL2",504,0) . . . ;"set OneErrArray(0)=$$NameError(.OneErrArray) "RTN","TMGSEQL2",505,0) . . . ;"write OneErrArray(0),! "RTN","TMGSEQL2",506,0) . . . ;"do AlertError^TMGSEQL2(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",507,0) "RTN","TMGSEQL2",508,0) FSNPDone "RTN","TMGSEQL2",509,0) quit Fixed "RTN","TMGSEQL2",510,0) "RTN","TMGSEQL2",511,0) "RTN","TMGSEQL2",512,0) "RTN","TMGSEQL2",513,0) GetSex(Name) "RTN","TMGSEQL2",514,0) ;"Purpose: To return gender of Name, as stored in file 22707 "RTN","TMGSEQL2",515,0) ;"Input: Name - a FIRST name "RTN","TMGSEQL2",516,0) ;"Result: Returns MALE, FEMALE, or "" if not found "RTN","TMGSEQL2",517,0) "RTN","TMGSEQL2",518,0) new result set result="" "RTN","TMGSEQL2",519,0) if $get(Name)="" goto GSDone "RTN","TMGSEQL2",520,0) new DIC,X,Y "RTN","TMGSEQL2",521,0) set DIC=22707 "RTN","TMGSEQL2",522,0) set DIC(0)="M" "RTN","TMGSEQL2",523,0) set X=Name "RTN","TMGSEQL2",524,0) do ^DIC "RTN","TMGSEQL2",525,0) if +Y'>0 goto GSDone "RTN","TMGSEQL2",526,0) set result=$$GET1^DIQ(22707,+Y_",",1) "RTN","TMGSEQL2",527,0) "RTN","TMGSEQL2",528,0) GSDone "RTN","TMGSEQL2",529,0) quit result "RTN","TMGSEQL2",530,0) "RTN","TMGSEQL2",531,0) "RTN","TMGSEQL2",532,0) "RTN","TMGSEQL2",533,0) SetSex(Name,Sex) "RTN","TMGSEQL2",534,0) ;"Purpose: To create a new record in file 22707 to store gender of name "RTN","TMGSEQL2",535,0) ;"Input: Name -- a FIRST name to store gender for "RTN","TMGSEQL2",536,0) ;" Sex -- should be "MALE", or "FEMALE" "RTN","TMGSEQL2",537,0) ;"Note: Will not do anything if a record for name already exists "RTN","TMGSEQL2",538,0) ;"Result: 1=OK to continue 0=some error "RTN","TMGSEQL2",539,0) "RTN","TMGSEQL2",540,0) new result set result=1 "RTN","TMGSEQL2",541,0) if '$data(Name)!'$data(Sex) goto SSxDone "RTN","TMGSEQL2",542,0) if $$GetSex(Name)'="" goto SSxDone "RTN","TMGSEQL2",543,0) new TMGFDA "RTN","TMGSEQL2",544,0) set TMGFDA(22707,"+1,",.01)=Name "RTN","TMGSEQL2",545,0) set TMGFDA(22707,"+1,",1)=Sex "RTN","TMGSEQL2",546,0) set result=$$dbWrite^TMGDBAPI(.TMGFDA,0) "RTN","TMGSEQL2",547,0) "RTN","TMGSEQL2",548,0) SSxDone "RTN","TMGSEQL2",549,0) quit result "RTN","TMGSEQL2",550,0) "RTN","TMGSEQL2",551,0) "RTN","TMGSEQL2",552,0) NameError(OneErrArray) "RTN","TMGSEQL2",553,0) ;"Purpose: to review a fileman "DIERR" array and pick out common problems "RTN","TMGSEQL2",554,0) ;"Input: OneErrArray -- a fileman array containing "DIERR" message "RTN","TMGSEQL2",555,0) ;"Result: return a name for error "RTN","TMGSEQL2",556,0) "RTN","TMGSEQL2",557,0) new result set result="" "RTN","TMGSEQL2",558,0) "RTN","TMGSEQL2",559,0) new Array "RTN","TMGSEQL2",560,0) if $data(OneErrArray("DIERR"))>1 do "RTN","TMGSEQL2",561,0) . merge Array=OneErrArray("DIERR") "RTN","TMGSEQL2",562,0) else do "RTN","TMGSEQL2",563,0) . merge Array=OneErrArray "RTN","TMGSEQL2",564,0) "RTN","TMGSEQL2",565,0) new field set field=$get(Array(1,"PARAM","FIELD")) "RTN","TMGSEQL2",566,0) "RTN","TMGSEQL2",567,0) if $data(Array)>0 do "RTN","TMGSEQL2",568,0) . new FileNum set FileNum=+$get(Array(1,"PARAM","FILE")) "RTN","TMGSEQL2",569,0) . if (FileNum>0)&(FileNum'=2) quit "RTN","TMGSEQL2",570,0) . if field>0 set result="FILEMAN ERROR:" "RTN","TMGSEQL2",571,0) . if field=.03 do "RTN","TMGSEQL2",572,0) . . set result="INVALID DOB ERROR:" "RTN","TMGSEQL2",573,0) . if field=.02 do "RTN","TMGSEQL2",574,0) . . set result="INVALID/MISSING GENDER:" "RTN","TMGSEQL2",575,0) . if $data(Array(1,"TEXT")) do "RTN","TMGSEQL2",576,0) . . new s set s=$get(Array(1,"TEXT",1)) "RTN","TMGSEQL2",577,0) . . set result=result_$extract(s,1,80)_"..." "RTN","TMGSEQL2",578,0) . if result["CONFLICTING SS-NUMBERS" do "RTN","TMGSEQL2",579,0) . . set result="CONFLICTING SS-NUMBERS: " "RTN","TMGSEQL2",580,0) "RTN","TMGSEQL2",581,0) if result="" set result=$get(Array(0),"Sequel Import Error:") "RTN","TMGSEQL2",582,0) "RTN","TMGSEQL2",583,0) quit result "RTN","TMGSEQL2",584,0) "RTN","TMGSEQL2",585,0) "RTN","TMGSEQL2",586,0) FixGenProblem(PtInfo,ErrMsg,OneLine,DelError,ErrIEN) "RTN","TMGSEQL2",587,0) ;"Purpose: To fix a generic (no specified) error "RTN","TMGSEQL2",588,0) ;"Input: PtInfo -- PASS BY REFERENCE -- the Patient Info array, as created by ParseLine^TMGSEQL1 "RTN","TMGSEQL2",589,0) ;" ErrMsg -- the message that holds the conflicting SSNums "RTN","TMGSEQL2",590,0) ;" OneLine -- the originial CSV data line. Passed to this function in case a new Alert "RTN","TMGSEQL2",591,0) ;" must be created, in which case it is stored in the new error message. "RTN","TMGSEQL2",592,0) ;" DelError -- and OUT parameter. Set to 1 will signal the deletion of the error "RTN","TMGSEQL2",593,0) ;" record in file 22706 "RTN","TMGSEQL2",594,0) ;" ErrIEN -- the IEN in file 22706 containing full error info. "RTN","TMGSEQL2",595,0) ;"Output: Patient may be added to FILE 2, or file updated. If succesfull, record of error "RTN","TMGSEQL2",596,0) ;" in file 22706 will deleted "RTN","TMGSEQL2",597,0) ;"Result: 1=problem fixed, 0=not fixed. "RTN","TMGSEQL2",598,0) "RTN","TMGSEQL2",599,0) new Fixed set Fixed=0 "RTN","TMGSEQL2",600,0) new done set done=0 "RTN","TMGSEQL2",601,0) set DelError=0 "RTN","TMGSEQL2",602,0) new done set done=0 "RTN","TMGSEQL2",603,0) new AutoRegister set AutoRegister=1 ;"automatically add patient to database if not found "RTN","TMGSEQL2",604,0) "RTN","TMGSEQL2",605,0) new temp "RTN","TMGSEQL2",606,0) set temp="?" "RTN","TMGSEQL2",607,0) for do quit:(done=1) "RTN","TMGSEQL2",608,0) . if temp="?" do quit "RTN","TMGSEQL2",609,0) . . write "Options:",! "RTN","TMGSEQL2",610,0) . . write "-----------------",! "RTN","TMGSEQL2",611,0) . . write "D Show the data line from the other computer (Sequel)",! "RTN","TMGSEQL2",612,0) . . write "E Edit data line.",! "RTN","TMGSEQL2",613,0) . . write "R Retry filing data into database to get more information.",! "RTN","TMGSEQL2",614,0) . . write "S Show parsed patient information.",! "RTN","TMGSEQL2",615,0) . . write "X Delete this Alert.",! "RTN","TMGSEQL2",616,0) . . write "Q Query the database to see existing entries.",! "RTN","TMGSEQL2",617,0) . . write "^ Abort.",! "RTN","TMGSEQL2",618,0) . . set temp="" "RTN","TMGSEQL2",619,0) . else if temp="Q" do quit "RTN","TMGSEQL2",620,0) . . new DIC set DIC=2 "RTN","TMGSEQL2",621,0) . . set DIC(0)="AEQM" "RTN","TMGSEQL2",622,0) . . do ^DIC "RTN","TMGSEQL2",623,0) . . set temp="" "RTN","TMGSEQL2",624,0) . else if temp="D" do quit "RTN","TMGSEQL2",625,0) . . write !,OneLine,! "RTN","TMGSEQL2",626,0) . . set temp="" "RTN","TMGSEQL2",627,0) . else if temp="S" do quit "RTN","TMGSEQL2",628,0) . . zwr PtInfo(*) "RTN","TMGSEQL2",629,0) . . set temp="" "RTN","TMGSEQL2",630,0) . else if temp="E" do quit "RTN","TMGSEQL2",631,0) . . new r,NewLine "RTN","TMGSEQL2",632,0) . . set r=$$EditOneLine(OneLine,.NewLine) "RTN","TMGSEQL2",633,0) . . if r=1 set OneLine=NewLine ;"NOTE: later I will save old line to keep from having to process each update cycle "RTN","TMGSEQL2",634,0) . . kill PtInfo "RTN","TMGSEQL2",635,0) . . if $$ParseLine^TMGSEQL1(OneLine,.PtInfo)=0 do quit "RTN","TMGSEQL2",636,0) . . . write "There was a problem processing this line after your edit. Sorry!",! "RTN","TMGSEQL2",637,0) . . write "OK, now try refilling data into database.",! "RTN","TMGSEQL2",638,0) . . set temp="?" "RTN","TMGSEQL2",639,0) . else if temp="^" do quit "RTN","TMGSEQL2",640,0) . . write "aborting..",! "RTN","TMGSEQL2",641,0) . . set done=1 "RTN","TMGSEQL2",642,0) . else if temp="X" do quit "RTN","TMGSEQL2",643,0) . . write "OK, will delete this alert.",! "RTN","TMGSEQL2",644,0) . . ;"Note: do something to delete alert. "RTN","TMGSEQL2",645,0) . . set done=1,DelError=1,Fixed=1 "RTN","TMGSEQL2",646,0) . else if temp="R" do quit "RTN","TMGSEQL2",647,0) . . new OneErrErray,ChgLog "RTN","TMGSEQL2",648,0) . . set tempResult=$$UpdateDB^TMGSEQL1(.PtInfo,AutoRegister,.OneErrArray,.ChgLog) ;"0=error "RTN","TMGSEQL2",649,0) . . set DelError=1 "RTN","TMGSEQL2",650,0) . . set Fixed=1 ;"consider 'fixed' so alert will be deleted "RTN","TMGSEQL2",651,0) . . set done=1 "RTN","TMGSEQL2",652,0) . . if tempResult=0 do "RTN","TMGSEQL2",653,0) . . . do ErrRefile(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",654,0) . . . ;"write "There is still an error:",! "RTN","TMGSEQL2",655,0) . . . ;"zwr OneErrArray(*) "RTN","TMGSEQL2",656,0) . . . ;"write "A new alert will be made to handle this new error.",! "RTN","TMGSEQL2",657,0) . . . ;"set OneErrArray(0)=$$NameError(.OneErrArray) "RTN","TMGSEQL2",658,0) . . . ;"write OneErrArray(0),! "RTN","TMGSEQL2",659,0) . . . ;"do AlertError^TMGSEQL2(.OneLine,.PtInfo,.OneErrArray,DUZ) "RTN","TMGSEQL2",660,0) . read !,"Enter Option: ?//",temp:$get(DTIME,3600),! "RTN","TMGSEQL2",661,0) . if temp="" set temp="?" "RTN","TMGSEQL2",662,0) . set temp=$$UP^XLFSTR(temp) "RTN","TMGSEQL2",663,0) . quit "RTN","TMGSEQL2",664,0) "RTN","TMGSEQL2",665,0) FGPDone "RTN","TMGSEQL2",666,0) quit Fixed "RTN","TMGSEQL2",667,0) "RTN","TMGSEQL2",668,0) "RTN","TMGSEQL2",669,0) "RTN","TMGSEQL3") 0^77^B11370 "RTN","TMGSEQL3",1,0) TMGSEQL3 ;TMG/kst/Code to interface with SequelSystems PMS ;03/25/06 "RTN","TMGSEQL3",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGSEQL3",3,0) "RTN","TMGSEQL3",4,0) ;"TMG SEQUEL IMPORT UTILITY FUNCTIONS "RTN","TMGSEQL3",5,0) ;"Kevin Toppenberg MD "RTN","TMGSEQL3",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGSEQL3",7,0) ;"1-9-2006 "RTN","TMGSEQL3",8,0) "RTN","TMGSEQL3",9,0) "RTN","TMGSEQL3",10,0) ;"======================================================================= "RTN","TMGSEQL3",11,0) ;" API -- Public Functions. "RTN","TMGSEQL3",12,0) ;"======================================================================= "RTN","TMGSEQL3",13,0) ;"RPTSSNCF ;"i.e. Report SSN Conflict "RTN","TMGSEQL3",14,0) ;"RPTDOBER ;"i.e. Report DOB Errors "RTN","TMGSEQL3",15,0) ;"CLEARALL "RTN","TMGSEQL3",16,0) "RTN","TMGSEQL3",17,0) "RTN","TMGSEQL3",18,0) ;"FIXERRORS --OLD "RTN","TMGSEQL3",19,0) ;"FixOneError(OneLine,OneErr,OneChLog) -- OLD "RTN","TMGSEQL3",20,0) ;"tempMakeAlerts "RTN","TMGSEQL3",21,0) "RTN","TMGSEQL3",22,0) ;"======================================================================= "RTN","TMGSEQL3",23,0) ;"PRIVATE API FUNCTIONS "RTN","TMGSEQL3",24,0) ;"======================================================================= "RTN","TMGSEQL3",25,0) ;"ShowOneConflict(IEN,ErrMsg) "RTN","TMGSEQL3",26,0) ;"$$QuietClear(DUZ) "RTN","TMGSEQL3",27,0) "RTN","TMGSEQL3",28,0) "RTN","TMGSEQL3",29,0) ;"======================================================================= "RTN","TMGSEQL3",30,0) ;"DEPENDENCIES "RTN","TMGSEQL3",31,0) ;"TMGSEQL1 "RTN","TMGSEQL3",32,0) ;"TMGSEQL2 "RTN","TMGSEQL3",33,0) ;"TMGSTUTL "RTN","TMGSEQL3",34,0) ;"TMGGDFN "RTN","TMGSEQL3",35,0) ;"TMGDEBUG "RTN","TMGSEQL3",36,0) ;"======================================================================= "RTN","TMGSEQL3",37,0) ;"======================================================================= "RTN","TMGSEQL3",38,0) "RTN","TMGSEQL3",39,0) "RTN","TMGSEQL3",40,0) "RTN","TMGSEQL3",41,0) tempMakeAlerts "RTN","TMGSEQL3",42,0) ;"Purpose: To creat alerts for all entries in file 22706 "RTN","TMGSEQL3",43,0) ;"Input: none "RTN","TMGSEQL3",44,0) ;"Output: This will generate Alerts, sent to the current user (DUZ) "RTN","TMGSEQL3",45,0) ;"Result: none "RTN","TMGSEQL3",46,0) "RTN","TMGSEQL3",47,0) new i,OneLine "RTN","TMGSEQL3",48,0) "RTN","TMGSEQL3",49,0) set i=$order(^TMG(22706,0)) "RTN","TMGSEQL3",50,0) if +i>0 for do quit:(+i'>0) "RTN","TMGSEQL3",51,0) . new ref,IEN "RTN","TMGSEQL3",52,0) . set IEN=i "RTN","TMGSEQL3",53,0) . set i=$order(^TMG(22706,i)) "RTN","TMGSEQL3",54,0) . set ref="^TMG(22706,"_IEN_",2)" "RTN","TMGSEQL3",55,0) . set OneLine=$$WPToStr^TMGSTUTL(ref) "RTN","TMGSEQL3",56,0) . set Msg="Problem with upload of Sequel data" "RTN","TMGSEQL3",57,0) . do MakeErrAlert^TMGSEQL2(IEN,DUZ,Msg) "RTN","TMGSEQL3",58,0) "RTN","TMGSEQL3",59,0) quit "RTN","TMGSEQL3",60,0) "RTN","TMGSEQL3",61,0) "RTN","TMGSEQL3",62,0) FIXERRORS ;"NOTE-- this is an OLD function, not being used "RTN","TMGSEQL3",63,0) ;"Purpose: To handles errors encountered during the ASKIMPORT function "RTN","TMGSEQL3",64,0) ;"Input: none "RTN","TMGSEQL3",65,0) ;"Output: the database is modified "RTN","TMGSEQL3",66,0) ;"Results: none "RTN","TMGSEQL3",67,0) "RTN","TMGSEQL3",68,0) new index "RTN","TMGSEQL3",69,0) new Abort set Abort=0 "RTN","TMGSEQL3",70,0) new NewArray,newI "RTN","TMGSEQL3",71,0) new NewErrArray,NewChgLog "RTN","TMGSEQL3",72,0) new MaxCount "RTN","TMGSEQL3",73,0) new TMGRemSex "RTN","TMGSEQL3",74,0) set TMGRemSex=$$GET1^DIQ(22711,"1,",6,"I") ;"6=PICK GENDER FROM NAME? "RTN","TMGSEQL3",75,0) "RTN","TMGSEQL3",76,0) new Ref set Ref=$name(^TMP("TMG","SEQUELIMPORT","ERRORS")) "RTN","TMGSEQL3",77,0) set MaxCount=$order(@Ref@(""),-1) "RTN","TMGSEQL3",78,0) "RTN","TMGSEQL3",79,0) set index=$order(@Ref@("")) "RTN","TMGSEQL3",80,0) if index'="" for do quit:(+index'>0)!(Abort) "RTN","TMGSEQL3",81,0) . new result "RTN","TMGSEQL3",82,0) . new OneErrArray,OneChLog "RTN","TMGSEQL3",83,0) . merge OneErrArray=@Ref@(index) "RTN","TMGSEQL3",84,0) . new OneLine set OneLine=$get(@Ref@(index)) "RTN","TMGSEQL3",85,0) . write "(",index,"/",MaxCount,") " "RTN","TMGSEQL3",86,0) . set result=$$FixOneError^TMGSEQL2(OneLine,.OneErrArray,.OneChLog) "RTN","TMGSEQL3",87,0) . if result=-1 set Abort=1 quit "RTN","TMGSEQL3",88,0) . if result>0 do "RTN","TMGSEQL3",89,0) . . ;"merge NewChgLog(index)=OneChLog "RTN","TMGSEQL3",90,0) . . merge ^TMP("TMG","SEQUELIMPORT","CHANGES",$H,index)=OneChLog "RTN","TMGSEQL3",91,0) . else do "RTN","TMGSEQL3",92,0) . . kill @Ref@(index) "RTN","TMGSEQL3",93,0) . . merge @Ref@(index)=OneErrArray(1) "RTN","TMGSEQL3",94,0) . set index=$order(@Ref@(index)) "RTN","TMGSEQL3",95,0) "RTN","TMGSEQL3",96,0) if 1=0 do "RTN","TMGSEQL3",97,0) . set newI=$get(newI)+1 "RTN","TMGSEQL3",98,0) . set NewArray(newI)=OneLine "RTN","TMGSEQL3",99,0) . if $$ProcessPt^TMGSEQL1(OneLine,.NewErrArray,.NewChgLog) do "RTN","TMGSEQL3",100,0) . . MERGE ^TMP("TMG","SEQUELIMPORT","CHANGES",$H)=NewChgLog "RTN","TMGSEQL3",101,0) . . if $data(NewErrArray) do "RTN","TMGSEQL3",102,0) . . . MERGE ^TMP("TMG","SEQUELIMPORT","ERRORS")=NewErrArray "RTN","TMGSEQL3",103,0) . . . write "Here is the info about adding that patient:",! "RTN","TMGSEQL3",104,0) . . . zwr NewErrArray(*) "RTN","TMGSEQL3",105,0) . . . write !! "RTN","TMGSEQL3",106,0) . . . kill NewErrArray "RTN","TMGSEQL3",107,0) . . ;"write "killing: ",Ref,"(",Idx,")",! "RTN","TMGSEQL3",108,0) . . kill @Ref@(Idx) "RTN","TMGSEQL3",109,0) "RTN","TMGSEQL3",110,0) "RTN","TMGSEQL3",111,0) write !,"Goodbye.",! "RTN","TMGSEQL3",112,0) FEDone "RTN","TMGSEQL3",113,0) quit "RTN","TMGSEQL3",114,0) "RTN","TMGSEQL3",115,0) "RTN","TMGSEQL3",116,0) FixOneError(OneLine,OneErr,OneChLog) ;"NOTE-- this is an OLD function, not being used "RTN","TMGSEQL3",117,0) ;"Purpose: to Fix one filing error "RTN","TMGSEQL3",118,0) ;"Input: OneLine -- the original data line in CVS format. "RTN","TMGSEQL3",119,0) ;" OneErr -- PASS BY REFERENCE "RTN","TMGSEQL3",120,0) ;" coming in, it will pass the original error. "RTN","TMGSEQL3",121,0) ;" passed back out, it will contain any new errors. "RTN","TMGSEQL3",122,0) ;" OneChLog -- PASS BY REFERENCE "RTN","TMGSEQL3",123,0) ;" This will contain messages about changes made. "RTN","TMGSEQL3",124,0) ;" Note: uses var with global scipe: TMGRemSex "RTN","TMGSEQL3",125,0) ;"Result: 1 = error fixed "RTN","TMGSEQL3",126,0) ;" 0 = error NOT fixed "RTN","TMGSEQL3",127,0) ;" -1 = aborted "RTN","TMGSEQL3",128,0) "RTN","TMGSEQL3",129,0) new Abort set Abort=0 "RTN","TMGSEQL3",130,0) new NewArray,newI "RTN","TMGSEQL3",131,0) new NewErrArray,NewChgLog "RTN","TMGSEQL3",132,0) new result set result=0 "RTN","TMGSEQL3",133,0) "RTN","TMGSEQL3",134,0) new Len set Len=$length(OneLine) "RTN","TMGSEQL3",135,0) if $extract(OneLine,Len)=$char(13) set OneLine=$extract(OneLine,1,Len-1) "RTN","TMGSEQL3",136,0) "RTN","TMGSEQL3",137,0) new Info merge Info=OneErr("INFO") "RTN","TMGSEQL3",138,0) new DIERR merge DIERR=OneErr("INFO","DIERR") "RTN","TMGSEQL3",139,0) if OneLine="" goto FOEDone "RTN","TMGSEQL3",140,0) "RTN","TMGSEQL3",141,0) new LName,FName,DOB,SID "RTN","TMGSEQL3",142,0) set LName=$piece(OneLine,",",3) "RTN","TMGSEQL3",143,0) set FName=$piece(OneLine,",",4) "RTN","TMGSEQL3",144,0) set DOB=$piece($piece(OneLine,",",17)," ",1) "RTN","TMGSEQL3",145,0) set SID=$piece(OneLine,",",5) "RTN","TMGSEQL3",146,0) write FName," ",LName," ("_DOB_"); #",SID,"): " "RTN","TMGSEQL3",147,0) new Prov set Prov=$piece(OneLine,",",14) "RTN","TMGSEQL3",148,0) new skip set skip=0 "RTN","TMGSEQL3",149,0) new temp set temp="" "RTN","TMGSEQL3",150,0) "RTN","TMGSEQL3",151,0) if $$InvalPtName^TMGSEQL1(FName,LName) do goto FOEDone "RTN","TMGSEQL3",152,0) . write !,"Skipping and deleting, because name is: ",FName," ",LName,! "RTN","TMGSEQL3",153,0) . set result=0 "RTN","TMGSEQL3",154,0) "RTN","TMGSEQL3",155,0) if $$InvalidProvider^TMGSEQL1(Prov) do goto FOEDone "RTN","TMGSEQL3",156,0) . write !,"Skipping and deleting, because provider is: ",Prov,! "RTN","TMGSEQL3",157,0) . set result=0 "RTN","TMGSEQL3",158,0) "RTN","TMGSEQL3",159,0) if ($get(DIERR(1))=311)&($get(Info(0))="PATIENT NOT IN DATABASE")&($get(DIERR(1,"PARAM","FIELD"))=.02) do "RTN","TMGSEQL3",160,0) . set temp="" "RTN","TMGSEQL3",161,0) . for do quit:(temp'="")!(Abort=1) "RTN","TMGSEQL3",162,0) . . set skip=0 "RTN","TMGSEQL3",163,0) . . if TMGRemSex=1 set temp=$$GetSex^TMGSEQL2(FName) "RTN","TMGSEQL3",164,0) . . if temp="" read "MALE/FEMALE? ?// ",temp:$get(DTIME,3600) "RTN","TMGSEQL3",165,0) . . if temp="" set temp="?" "RTN","TMGSEQL3",166,0) . . set temp=$$UP^XLFSTR(temp) "RTN","TMGSEQL3",167,0) . . if temp="?" do quit "RTN","TMGSEQL3",168,0) . . . write "Options:",! "RTN","TMGSEQL3",169,0) . . . write "-----------------",! "RTN","TMGSEQL3",170,0) . . . write "M Name is MALE (and remember in future).",! "RTN","TMGSEQL3",171,0) . . . write "F Name is FEMALE (and remember in future).",! "RTN","TMGSEQL3",172,0) . . . write "D Show the data line from the other computer (Sequel)",! "RTN","TMGSEQL3",173,0) . . . ;"write "S Turn automatic selecting SEX based on first name: " "RTN","TMGSEQL3",174,0) . . . ;"write $select(TMGRemSex=1:"OFF",TMGRemSex=0:"ON"),! "RTN","TMGSEQL3",175,0) . . . write "x Skip this patient.",! "RTN","TMGSEQL3",176,0) . . . write "Q Query the database to see existing entries.",! "RTN","TMGSEQL3",177,0) . . . write "^ Abort.",! "RTN","TMGSEQL3",178,0) . . . set temp="" "RTN","TMGSEQL3",179,0) . . if temp="Q" do quit "RTN","TMGSEQL3",180,0) . . . new DIC set DIC=2 "RTN","TMGSEQL3",181,0) . . . set DIC(0)="AEQM" "RTN","TMGSEQL3",182,0) . . . do ^DIC "RTN","TMGSEQL3",183,0) . . . set temp="" "RTN","TMGSEQL3",184,0) . . if temp="S" do quit "RTN","TMGSEQL3",185,0) . . . ;"set TMGRemSex='TMGRemSex "RTN","TMGSEQL3",186,0) . . if temp="D" do quit "RTN","TMGSEQL3",187,0) . . . write !,OneLine,! "RTN","TMGSEQL3",188,0) . . . set temp="" "RTN","TMGSEQL3",189,0) . . if ("MALE"[temp)&(temp'="FEMALE") do quit "RTN","TMGSEQL3",190,0) . . . write "MALE",! "RTN","TMGSEQL3",191,0) . . . set OneLine=OneLine_"^MALE" "RTN","TMGSEQL3",192,0) . . . if TMGRemSex=1 do "RTN","TMGSEQL3",193,0) . . . . new temp "RTN","TMGSEQL3",194,0) . . . . set temp=$$SetSex^TMGSEQL2(FName,"MALE") "RTN","TMGSEQL3",195,0) . . else if "FEMALE"[temp do quit "RTN","TMGSEQL3",196,0) . . . write "FEMALE",! "RTN","TMGSEQL3",197,0) . . . set OneLine=OneLine_"^FEMALE" "RTN","TMGSEQL3",198,0) . . . if TMGRemSex=1 do "RTN","TMGSEQL3",199,0) . . . . new temp "RTN","TMGSEQL3",200,0) . . . . set temp=$$SetSex^TMGSEQL2(FName,"FEMALE") "RTN","TMGSEQL3",201,0) . . else if temp="^" do quit "RTN","TMGSEQL3",202,0) . . . write "aborting..",! "RTN","TMGSEQL3",203,0) . . . set Abort=1 "RTN","TMGSEQL3",204,0) . . else do quit "RTN","TMGSEQL3",205,0) . . . write "skip...",! "RTN","TMGSEQL3",206,0) . . . set skip=1,temp="x" "RTN","TMGSEQL3",207,0) else do "RTN","TMGSEQL3",208,0) . write "??",! "RTN","TMGSEQL3",209,0) . write "Here is info array. I don't know how to fix this:",! "RTN","TMGSEQL3",210,0) . zwr Info(*) "RTN","TMGSEQL3",211,0) . set temp="?" "RTN","TMGSEQL3",212,0) . for do quit:(temp'="")!(Abort=1) "RTN","TMGSEQL3",213,0) . . set skip=0 "RTN","TMGSEQL3",214,0) . . if temp="?" do quit "RTN","TMGSEQL3",215,0) . . . write "Options:",! "RTN","TMGSEQL3",216,0) . . . write "-----------------",! "RTN","TMGSEQL3",217,0) . . . write "D Show the data line from the other computer (Sequel)",! "RTN","TMGSEQL3",218,0) . . . write "E Edit data line.",! "RTN","TMGSEQL3",219,0) . . . write "x Skip this patient.",! "RTN","TMGSEQL3",220,0) . . . write "Q Query the database to see existing entries.",! "RTN","TMGSEQL3",221,0) . . . write "^ Abort.",! "RTN","TMGSEQL3",222,0) . . . set temp="" "RTN","TMGSEQL3",223,0) . . else if temp="Q" do quit "RTN","TMGSEQL3",224,0) . . . new DIC set DIC=2 "RTN","TMGSEQL3",225,0) . . . set DIC(0)="AEQM" "RTN","TMGSEQL3",226,0) . . . do ^DIC "RTN","TMGSEQL3",227,0) . . . set temp="" "RTN","TMGSEQL3",228,0) . . else if temp="S" do "RTN","TMGSEQL3",229,0) . . . set TMGRemSex='TMGRemSex "RTN","TMGSEQL3",230,0) . . else if temp="D" do quit "RTN","TMGSEQL3",231,0) . . . write !,OneLine,! "RTN","TMGSEQL3",232,0) . . . set temp="" "RTN","TMGSEQL3",233,0) . . else if temp="E" do "RTN","TMGSEQL3",234,0) . . . new r,NewLine "RTN","TMGSEQL3",235,0) . . . set r=$$EditOneLine^TMGSEQL2(OneLine,NewLine) "RTN","TMGSEQL3",236,0) . . . if r=1 set OneLine=NewLine ;"NOTE: later I will save old line to keep from having to process each update cycle "RTN","TMGSEQL3",237,0) . . else if temp="^" do quit "RTN","TMGSEQL3",238,0) . . . write "aborting..",! "RTN","TMGSEQL3",239,0) . . . set Abort=1 "RTN","TMGSEQL3",240,0) . . else do quit "RTN","TMGSEQL3",241,0) . . . write "skip...",! "RTN","TMGSEQL3",242,0) . . . set skip=1 "RTN","TMGSEQL3",243,0) . . read !,"Enter Option: ?//",temp:$get(DTIME,3600),! "RTN","TMGSEQL3",244,0) . . if temp="" set temp="?" "RTN","TMGSEQL3",245,0) . . set temp=$$UP^XLFSTR(temp) "RTN","TMGSEQL3",246,0) "RTN","TMGSEQL3",247,0) if skip=0 do "RTN","TMGSEQL3",248,0) . kill OneErr "RTN","TMGSEQL3",249,0) . if $$ProcessPt^TMGSEQL1(OneLine,.OneErr,.OneChLog) do "RTN","TMGSEQL3",250,0) . . if $data(OneErr) do "RTN","TMGSEQL3",251,0) . . . write "Here is the info about adding that patient:",! "RTN","TMGSEQL3",252,0) . . . zwr OneErr(*) "RTN","TMGSEQL3",253,0) . . . write !! "RTN","TMGSEQL3",254,0) . . else set result=1 "RTN","TMGSEQL3",255,0) "RTN","TMGSEQL3",256,0) FOEDone "RTN","TMGSEQL3",257,0) if Abort set result=-1 "RTN","TMGSEQL3",258,0) quit result "RTN","TMGSEQL3",259,0) "RTN","TMGSEQL3",260,0) "RTN","TMGSEQL3",261,0) "RTN","TMGSEQL3",262,0) RPTSSNCF ;"i.e. Report SSN Conflict "RTN","TMGSEQL3",263,0) ;"Purpose: to output a report of all instances of conflicted SSNum's "RTN","TMGSEQL3",264,0) "RTN","TMGSEQL3",265,0) do RptMsg("CONFLICTING SS-NUMBERS") "RTN","TMGSEQL3",266,0) quit "RTN","TMGSEQL3",267,0) "RTN","TMGSEQL3",268,0) "RTN","TMGSEQL3",269,0) RPTDOBER ;"i.e. Report DOB Errors "RTN","TMGSEQL3",270,0) ;"Purpose: to output a report of all instances of conflicted SSNum's "RTN","TMGSEQL3",271,0) "RTN","TMGSEQL3",272,0) do RptMsg("DOB") "RTN","TMGSEQL3",273,0) quit "RTN","TMGSEQL3",274,0) "RTN","TMGSEQL3",275,0) "RTN","TMGSEQL3",276,0) RptMsg(MatchMsg) ;"i.e. Alerts with matching message "RTN","TMGSEQL3",277,0) ;"Purpose: to output a report of all instances of errors with matching message "RTN","TMGSEQL3",278,0) ;"input: MatchMsg -- A message of error to match for. "RTN","TMGSEQL3",279,0) ;" e.g. CONFLICTING SS-NUMBERS "RTN","TMGSEQL3",280,0) "RTN","TMGSEQL3",281,0) set %ZIS("A")="Enter output printer or device (^ to abort): " "RTN","TMGSEQL3",282,0) do ^%ZIS "RTN","TMGSEQL3",283,0) if POP do goto RpmDone "RTN","TMGSEQL3",284,0) . write !,"Error selecting output printer or device. Aborting report.",! "RTN","TMGSEQL3",285,0) use IO "RTN","TMGSEQL3",286,0) "RTN","TMGSEQL3",287,0) new IEN,count "RTN","TMGSEQL3",288,0) set count=0 "RTN","TMGSEQL3",289,0) set IEN=$order(^TMG(22706,0)) "RTN","TMGSEQL3",290,0) if +IEN'=0 for do quit:(+IEN'>0) "RTN","TMGSEQL3",291,0) . new Node0 set Node0=$get(^TMG(22706,IEN,0)) "RTN","TMGSEQL3",292,0) . new SQLNum set SQLNum=$piece(Node0,"^",1) "RTN","TMGSEQL3",293,0) . new Msg set Msg=$piece(Node0,"^",2) "RTN","TMGSEQL3",294,0) . if Msg[MatchMsg do "RTN","TMGSEQL3",295,0) . . do ShowOneConflict(IEN,Msg) "RTN","TMGSEQL3",296,0) . . set count=count+1 "RTN","TMGSEQL3",297,0) . set IEN=$order(^TMG(22706,IEN)) "RTN","TMGSEQL3",298,0) "RTN","TMGSEQL3",299,0) write count," conflicts found." "RTN","TMGSEQL3",300,0) "RTN","TMGSEQL3",301,0) use IO(0) "RTN","TMGSEQL3",302,0) do ^%ZISC "RTN","TMGSEQL3",303,0) "RTN","TMGSEQL3",304,0) RpmDone "RTN","TMGSEQL3",305,0) write !,"Goodbye.",! "RTN","TMGSEQL3",306,0) quit "RTN","TMGSEQL3",307,0) "RTN","TMGSEQL3",308,0) "RTN","TMGSEQL3",309,0) "RTN","TMGSEQL3",310,0) "RTN","TMGSEQL3",311,0) ShowOneConflict(IEN,ErrMsg) "RTN","TMGSEQL3",312,0) ;"Purpose: to output one conflict "RTN","TMGSEQL3",313,0) ;"Input: IEN, the IEN from file 22706 "RTN","TMGSEQL3",314,0) "RTN","TMGSEQL3",315,0) new OneLine,TMGWP,TMGMSG,PtInfo "RTN","TMGSEQL3",316,0) new sqSSNum,vSSNum "RTN","TMGSEQL3",317,0) "RTN","TMGSEQL3",318,0) new x set x=$$GET1^DIQ(22706,IEN_",",2,"","TMGWP","TMGMSG") "RTN","TMGSEQL3",319,0) if $data(TMGMSG("DIERR"))'=0 do goto SOCDone "RTN","TMGSEQL3",320,0) . new PriorErrorFound "RTN","TMGSEQL3",321,0) . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSEQL3",322,0) set OneLine=$$WPToStr^TMGSTUTL("TMGWP","") "RTN","TMGSEQL3",323,0) if $$ParseLine^TMGSEQL1(OneLine,.PtInfo)=0 do goto SOCDone "RTN","TMGSEQL3",324,0) . write "Error parsing Alert data into patient data.",! "RTN","TMGSEQL3",325,0) "RTN","TMGSEQL3",326,0) if $get(ErrMsg)="" goto SOCDone "RTN","TMGSEQL3",327,0) "RTN","TMGSEQL3",328,0) set sqSSN=$piece(ErrMsg,"Sequel#=",2) "RTN","TMGSEQL3",329,0) set sqSSN=$piece(sqSSN," ",1) "RTN","TMGSEQL3",330,0) set vSSN=$piece(ErrMsg,"VistA#=",2) "RTN","TMGSEQL3",331,0) set vSSN=$piece(vSSN," ",1) "RTN","TMGSEQL3",332,0) "RTN","TMGSEQL3",333,0) new vFullName "RTN","TMGSEQL3",334,0) do ;"get actual full name & DOB for VistA SSN "RTN","TMGSEQL3",335,0) . new vName,vDOB "RTN","TMGSEQL3",336,0) . new tempDFN set tempDFN=$$SSNumLookup^TMGGDFN(vSSN) "RTN","TMGSEQL3",337,0) . new TMGMSG,TMGERR,IENS "RTN","TMGSEQL3",338,0) . set IENS=+tempDFN_"," "RTN","TMGSEQL3",339,0) . do GETS^DIQ(2,IENS,".01;.03","E","TMGMSG","TMGERR") "RTN","TMGSEQL3",340,0) . if $data(TMGERR("DIERR")) do "RTN","TMGSEQL3",341,0) . . new PriorErrorFound "RTN","TMGSEQL3",342,0) . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGSEQL3",343,0) . set vName=$get(TMGMSG(2,IENS,.01,"E")) "RTN","TMGSEQL3",344,0) . set vDOB=$get(TMGMSG(2,IENS,.03,"E")) "RTN","TMGSEQL3",345,0) . set vFullName=vName_" ("_vDOB_")" "RTN","TMGSEQL3",346,0) "RTN","TMGSEQL3",347,0) write sqSSN," is Sequel SSN for: ",$get(PtInfo("FULL NAME2"))," phone: ",$get(PtInfo("PHONE NUM")),! "RTN","TMGSEQL3",348,0) write vSSN," is VistA SSN for: ",$get(vFullName),! "RTN","TMGSEQL3",349,0) write ! "RTN","TMGSEQL3",350,0) "RTN","TMGSEQL3",351,0) SOCDone "RTN","TMGSEQL3",352,0) quit "RTN","TMGSEQL3",353,0) "RTN","TMGSEQL3",354,0) "RTN","TMGSEQL3",355,0) "RTN","TMGSEQL3",356,0) CLEARALL "RTN","TMGSEQL3",357,0) ;"Purpose: Wrapper for QuietClear (which clears all entries in file 22706 and all alerts.) "RTN","TMGSEQL3",358,0) ;"Input: none, DUZ (in global scope) is used "RTN","TMGSEQL3",359,0) ;"Output: All entries in the file and all associated Alerts are deleted "RTN","TMGSEQL3",360,0) ;"Results: none "RTN","TMGSEQL3",361,0) "RTN","TMGSEQL3",362,0) new TMGLIST "RTN","TMGSEQL3",363,0) new i,count "RTN","TMGSEQL3",364,0) set count=0 "RTN","TMGSEQL3",365,0) "RTN","TMGSEQL3",366,0) write !,"-==Error Deleater==-",! "RTN","TMGSEQL3",367,0) write "This will delete all error alerts related to",! "RTN","TMGSEQL3",368,0) write "importing demographics from Sequel system",!! "RTN","TMGSEQL3",369,0) "RTN","TMGSEQL3",370,0) set count=$$QuietClear(DUZ) "RTN","TMGSEQL3",371,0) "RTN","TMGSEQL3",372,0) write count," data import errors " "RTN","TMGSEQL3",373,0) if count>0 write "deleted.",! "RTN","TMGSEQL3",374,0) else write "to delete.",! "RTN","TMGSEQL3",375,0) "RTN","TMGSEQL3",376,0) write !,"Goodbye.",! "RTN","TMGSEQL3",377,0) "RTN","TMGSEQL3",378,0) quit "RTN","TMGSEQL3",379,0) "RTN","TMGSEQL3",380,0) "RTN","TMGSEQL3",381,0) QuietClear(DUZ) "RTN","TMGSEQL3",382,0) ;"Purpose: To clear all entries in file 22706 and all alerts. "RTN","TMGSEQL3",383,0) ;"Input: DUZ, the user to delete alerts for. "RTN","TMGSEQL3",384,0) ;"Output: All entries in the file and all associated Alerts are deleted "RTN","TMGSEQL3",385,0) ;"Results: count of errors deleted. "RTN","TMGSEQL3",386,0) "RTN","TMGSEQL3",387,0) new TMGLIST "RTN","TMGSEQL3",388,0) new i,count "RTN","TMGSEQL3",389,0) set count=0 "RTN","TMGSEQL3",390,0) "RTN","TMGSEQL3",391,0) do USER^XQALERT("TMGLIST",DUZ) "RTN","TMGSEQL3",392,0) "RTN","TMGSEQL3",393,0) set i=$order(TMGLIST("")) "RTN","TMGSEQL3",394,0) if i'="" for do quit:(+i'>0) "RTN","TMGSEQL3",395,0) . new alertID,IEN,TMGDATA,line "RTN","TMGSEQL3",396,0) . set line=$get(TMGLIST(i)) "RTN","TMGSEQL3",397,0) . set i=$order(TMGLIST(i)) "RTN","TMGSEQL3",398,0) . set alertID=$piece(line,"^",2) "RTN","TMGSEQL3",399,0) . if $piece(alertID,";",1)'="TMGSQLIMPORT" quit "RTN","TMGSEQL3",400,0) . new XQAID "RTN","TMGSEQL3",401,0) . do GETACT^XQALERT(alertID) ;"loads XQADATA, XQAID "RTN","TMGSEQL3",402,0) . if +XQADATA>0 do "RTN","TMGSEQL3",403,0) . . new TMGERR,result "RTN","TMGSEQL3",404,0) . . set count=count+1 "RTN","TMGSEQL3",405,0) . . ;"write "Deleting from file 22706, IEN=",XQADATA,! "RTN","TMGSEQL3",406,0) . . set result=$$DelIEN^TMGDBAPI(22706,XQADATA,.TMGERR) "RTN","TMGSEQL3",407,0) . . if result=0 do ShowDIERR^TMGDEBUG(.TMGERR) "RTN","TMGSEQL3",408,0) . . else do "RTN","TMGSEQL3",409,0) . . . ;"write $piece(line,"^",1),!! "RTN","TMGSEQL3",410,0) . . . do DELETE^XQALERT "RTN","TMGSEQL3",411,0) . ;"else write "?? XQADATA ??",! "RTN","TMGSEQL3",412,0) "RTN","TMGSEQL3",413,0) quit count "RTN","TMGSEQL3",414,0) "RTN","TMGSEQL3",415,0) "RTN","TMGSEQL3",416,0) "RTN","TMGSEQL3",417,0) Schedule(Time,Routine,Descr) "RTN","TMGSEQL3",418,0) ;"Purpose: to schedule a task at the given time, to run the specified routine "RTN","TMGSEQL3",419,0) ;"Input: Time: The time to run the task, in FileMan or $HOROLOG format "RTN","TMGSEQL3",420,0) ;" Routine: the routine to run. E.g. "TEST^TMGSEQL3" "RTN","TMGSEQL3",421,0) ;" Descr: Task description (don't include package name) "RTN","TMGSEQL3",422,0) ;"Output: Will shedule the task with TaskMan "RTN","TMGSEQL3",423,0) ;"Result: returns the task number "RTN","TMGSEQL3",424,0) "RTN","TMGSEQL3",425,0) new result "RTN","TMGSEQL3",426,0) set result="" "RTN","TMGSEQL3",427,0) "RTN","TMGSEQL3",428,0) ;"New all vars used by taskman scheduler, to ensure to use of unexpected values "RTN","TMGSEQL3",429,0) new ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU "RTN","TMGSEQL3",430,0) new ZTPRI,ZTSAVE,ZTKIL,ZTSYNC "RTN","TMGSEQL3",431,0) "RTN","TMGSEQL3",432,0) set ZTRTN=$get(Routine) "RTN","TMGSEQL3",433,0) set ZTDESC="TMG SEQUELIMPORTER "_$get(Descr) "RTN","TMGSEQL3",434,0) set ZTDTH=$get(Time) "RTN","TMGSEQL3",435,0) set ZTIO="" "RTN","TMGSEQL3",436,0) "RTN","TMGSEQL3",437,0) do ^%ZTLOAD "RTN","TMGSEQL3",438,0) "RTN","TMGSEQL3",439,0) set result=$get(ZTSK) "RTN","TMGSEQL3",440,0) "RTN","TMGSEQL3",441,0) SchDone "RTN","TMGSEQL3",442,0) quit result "RTN","TMGSEQL3",443,0) "RTN","TMGSEQL3",444,0) "RTN","TMGSEQL3",445,0) SHOWTIME "RTN","TMGSEQL3",446,0) ;"Purpose: to show the last time that the import task was run "RTN","TMGSEQL3",447,0) ;"Input: none "RTN","TMGSEQL3",448,0) ;"Output: will write to screen "RTN","TMGSEQL3",449,0) ;"Result: none "RTN","TMGSEQL3",450,0) "RTN","TMGSEQL3",451,0) new time "RTN","TMGSEQL3",452,0) "RTN","TMGSEQL3",453,0) write !!,"SEQUEL BILLING SYSTEM DEMOGRAPHICS IMPORT",! "RTN","TMGSEQL3",454,0) write "Last demographics import date/time was: " "RTN","TMGSEQL3",455,0) set time=$$GET1^DIQ(22711,"1,","LAST IMPORT DATE","I") "RTN","TMGSEQL3",456,0) write $$FMTE^XLFDT(time,"P"),! "RTN","TMGSEQL3",457,0) "RTN","TMGSEQL3",458,0) new task "RTN","TMGSEQL3",459,0) set task=$$GET1^DIQ(22711,"1,","TASK FOR NEXT RUN","I") "RTN","TMGSEQL3",460,0) if +task>0 do "RTN","TMGSEQL3",461,0) . write "Next demographics import date/time is: " "RTN","TMGSEQL3",462,0) . set time=$$GET1^DIQ(14.4,task_",","Scheduled Run Time ($H)") "RTN","TMGSEQL3",463,0) . write $$HTE^XLFDT(time,"P"),! "RTN","TMGSEQL3",464,0) "RTN","TMGSEQL3",465,0) quit "RTN","TMGSEQL3",466,0) "RTN","TMGSHORT") 0^78^B7015 "RTN","TMGSHORT",1,0) TMGSHORT ;TMG/kst/Code to Shorten Names ;03/25/06 "RTN","TMGSHORT",2,0) ;;1.0;TMG-LIB;**1**;12/23/06 "RTN","TMGSHORT",3,0) "RTN","TMGSHORT",4,0) ;" SHORTEN NAMES code "RTN","TMGSHORT",5,0) "RTN","TMGSHORT",6,0) ;"Kevin Toppenberg MD "RTN","TMGSHORT",7,0) ;"GNU General Public License (GPL) applies "RTN","TMGSHORT",8,0) ;"12-23-2006 "RTN","TMGSHORT",9,0) "RTN","TMGSHORT",10,0) ;"======================================================================= "RTN","TMGSHORT",11,0) ;" API -- Public Functions. "RTN","TMGSHORT",12,0) ;"======================================================================= "RTN","TMGSHORT",13,0) ;"ShortNetName(GenericName,TradeName,Strength,Units,MaxLen) "RTN","TMGSHORT",14,0) ;"$$ShortenArray(Names,Dividers,MaxLen,AllowCut) -- core menus for shortening name "RTN","TMGSHORT",15,0) ;"$$PShortName(Name,Length,AskUser) -- shorten the drug smartly, using abbreviations "RTN","TMGSHORT",16,0) ;"$$ShortName(Name,Length,AskUser,DivStr) -- shorten the drug smartly, using abbreviations "RTN","TMGSHORT",17,0) ;"$$Short2Name(Name,Div1,Div2,.Words,.Dividers) -- Shorten a name to shortest form possible "RTN","TMGSHORT",18,0) ;"$$Short1Name(Name,MaxLen,Div1,Div2,Words,Dividers) -- An interactive editing of one name "RTN","TMGSHORT",19,0) ;"$$Cut1Name(Name,MaxLen,Div1,Div2,Words,Dividers) -- A non-interactive cut of one name "RTN","TMGSHORT",20,0) "RTN","TMGSHORT",21,0) ;"======================================================================= "RTN","TMGSHORT",22,0) ;" Private Functions. "RTN","TMGSHORT",23,0) ;"======================================================================= "RTN","TMGSHORT",24,0) ;"$$ReadJoin(JoinNum,Len,Words,Dividers) -- read out a phrase of joined words, Len words long "RTN","TMGSHORT",25,0) ;"SetJoin(JoinNum,Len,Words,Dividers) -- reform the Word and Dividers arrays such that "RTN","TMGSHORT",26,0) ;" words are joined together. E.g. #1='One' #2='Minute' ==> #1='One Minute' "RTN","TMGSHORT",27,0) ;"SubDivArray(Words,Dividers,Div1,Div2) -- check and handle if words in Words array need subdivision "RTN","TMGSHORT",28,0) ;"PackArrays(pNames,pDividers) -- pack the arrays, after items had been deleted. "RTN","TMGSHORT",29,0) ;"CompArray(Names,Dividers) -- reconstruct the resulting sentence from words in array. "RTN","TMGSHORT",30,0) ;"AutoShortenArray(.Names,.Dividers,MaxLen,Div1,Div2) -- automatically shorten the words in the array "RTN","TMGSHORT",31,0) ;"$$CutName(.Names,.Dividers,MaxLen) -- return a non-interactive shortened ('cut') name "RTN","TMGSHORT",32,0) "RTN","TMGSHORT",33,0) ;"======================================================================= "RTN","TMGSHORT",34,0) ;"======================================================================= "RTN","TMGSHORT",35,0) "RTN","TMGSHORT",36,0) ShortNetName(GenericName,TradeName,Strength,Units,MaxLen,AllowCut) "RTN","TMGSHORT",37,0) ;"Purpose: to create a shortened name from parts, not longer than MaxLen "RTN","TMGSHORT",38,0) ;"Input: GenericName -- Generic portion of name "RTN","TMGSHORT",39,0) ;" TradeName -- Tradename portion of name "RTN","TMGSHORT",40,0) ;" Strength -- OPTIONAL Strength portion of name "RTN","TMGSHORT",41,0) ;" Units -- OPTIONAL units portion of name "RTN","TMGSHORT",42,0) ;" MaxLen -- the maximum length "RTN","TMGSHORT",43,0) ;" AllowCut -- OPTIONAL If 1 then name may be cut off with ... to reach target length "RTN","TMGSHORT",44,0) ;" and user will not be asked for input "RTN","TMGSHORT",45,0) ;" If 2 then name wil be shortened as far as possible, but it "RTN","TMGSHORT",46,0) ;" wil not be cut off "RTN","TMGSHORT",47,0) ;"Result: Returns new shortened name, or "^" for user abort "RTN","TMGSHORT",48,0) "RTN","TMGSHORT",49,0) new result,temp "RTN","TMGSHORT",50,0) set GenericName=$get(GenericName) "RTN","TMGSHORT",51,0) set TradeName=$get(TradeName) "RTN","TMGSHORT",52,0) set Strength=$get(Strength) "RTN","TMGSHORT",53,0) set Units=$get(Units) "RTN","TMGSHORT",54,0) set MaxLen=$get(MaxLen,16) "RTN","TMGSHORT",55,0) set AllowCut=$get(AllowCut,0) "RTN","TMGSHORT",56,0) "RTN","TMGSHORT",57,0) new Names,Dividers "RTN","TMGSHORT",58,0) new unitsIdx,GenericIdx set GenericIdx=0,unitsIdx=0 "RTN","TMGSHORT",59,0) ;"sometimes 'Trade Name' is actually an expanded form of the Generic name "RTN","TMGSHORT",60,0) ;"e.g. ACETAZOLAMIDE (ACETAZOLAMIDE CAP USP) 250 "RTN","TMGSHORT",61,0) ;"In these cases I will delete the duplication "RTN","TMGSHORT",62,0) SNN0 if $extract(TradeName,1,$length(GenericName))=GenericName set GenericName="" "RTN","TMGSHORT",63,0) if (TradeName="")!(GenericName="") do "RTN","TMGSHORT",64,0) . new i set i=0 "RTN","TMGSHORT",65,0) . if TradeName'="" set i=i+1,Names(i)=TradeName,Dividers(i)=" " "RTN","TMGSHORT",66,0) . if GenericName'="" set i=i+1,Names(i)=GenericName,Dividers(i)=" ",GenericIdx=i "RTN","TMGSHORT",67,0) . ;"set Names(i)=TradeName,Dividers(i)=" ",i=i+1 "RTN","TMGSHORT",68,0) . if Strength'="" set i=i+1,Names(i)=Strength,Dividers(i)=" " "RTN","TMGSHORT",69,0) . if Units'="" set i=i+1,Names(i)=Units,unitsIdx=i,Dividers(i)="" "RTN","TMGSHORT",70,0) . set Names("MAXNODE")=i,Dividers("MAXNODE")=i "RTN","TMGSHORT",71,0) else do "RTN","TMGSHORT",72,0) . new i set i=0 "RTN","TMGSHORT",73,0) . set i=i+1,Names(i)=TradeName,Dividers(i)=" (" "RTN","TMGSHORT",74,0) . set i=i+1,Names(i)=GenericName,GenericIdx=i,Dividers(i)=") " "RTN","TMGSHORT",75,0) . ;"set i=i+1,Names(i)=GenericName,GenericIdx=i,Dividers(i)=" (" ;changed 10-30-07 "RTN","TMGSHORT",76,0) . ;"set i=i+1,Names(i)=TradeName,Dividers(i)=") " "RTN","TMGSHORT",77,0) . if Strength'="" set i=i+1,Names(i)=Strength,Dividers(i)=" " "RTN","TMGSHORT",78,0) . if Units'="" set i=i+1,Names(i)=Units,unitsIdx=i,Dividers(i)="" "RTN","TMGSHORT",79,0) . set Names("MAXNODE")=i,Dividers("MAXNODE")=i "RTN","TMGSHORT",80,0) "RTN","TMGSHORT",81,0) for i=1:1:Names("MAXNODE")-1 do ;"don't cleave units (e.g. MG/ML) "RTN","TMGSHORT",82,0) . set:(i>1) Names(i)=$translate(Names(i),"/","|") "RTN","TMGSHORT",83,0) do SubDivArray(.Names,.Dividers," ","/") "RTN","TMGSHORT",84,0) "RTN","TMGSHORT",85,0) set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut) "RTN","TMGSHORT",86,0) if result=0 kill Names,Dividers goto SNN0 ;"honor requested retry "RTN","TMGSHORT",87,0) "RTN","TMGSHORT",88,0) ;"If shortening required "...", see if removing parts of name allow goal. "RTN","TMGSHORT",89,0) if (AllowCut=1)&(result["...") do "RTN","TMGSHORT",90,0) SNN1 . ;"try removing units first "RTN","TMGSHORT",91,0) . kill Names(unitsIdx),Dividers(unitsIdx) "RTN","TMGSHORT",92,0) . do PackArrays("Names","Dividers") "RTN","TMGSHORT",93,0) . set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut) "RTN","TMGSHORT",94,0) . if result'["..." quit "RTN","TMGSHORT",95,0) . if GenericIdx'=0 do "RTN","TMGSHORT",96,0) . . kill Names(GenericIdx) "RTN","TMGSHORT",97,0) . . if Dividers(GenericIdx)=" (" set Dividers(GenericIdx+1)=" " "RTN","TMGSHORT",98,0) . . kill Dividers(GenericIdx) "RTN","TMGSHORT",99,0) . . do PackArrays("Names","Dividers") "RTN","TMGSHORT",100,0) . . set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut) "RTN","TMGSHORT",101,0) . if result'["..." quit "RTN","TMGSHORT",102,0) . ;"more later... ? "RTN","TMGSHORT",103,0) "RTN","TMGSHORT",104,0) SNNDone "RTN","TMGSHORT",105,0) set result=$$Trim^TMGSTUTL(result) "RTN","TMGSHORT",106,0) if $extract(result,1,1)="(" do ;"Input transform doesn't allow first chart to be '(' "RTN","TMGSHORT",107,0) . ;"NOTE: I should write better code to change only the LAST ) to "", i.e. not cut out ALL ()'s "RTN","TMGSHORT",108,0) . set result=$translate(result,"(","") "RTN","TMGSHORT",109,0) . set result=$translate(result,")","") "RTN","TMGSHORT",110,0) if (result[")")&(result'["(") set result=$translate(result,")","") "RTN","TMGSHORT",111,0) set result=$translate(result,"|","/") "RTN","TMGSHORT",112,0) quit result "RTN","TMGSHORT",113,0) "RTN","TMGSHORT",114,0) "RTN","TMGSHORT",115,0) ShortenArray(Names,Dividers,MaxLen,AllowCut) "RTN","TMGSHORT",116,0) ;"Purpose: shorten name "RTN","TMGSHORT",117,0) ;"Input: Names -- PASS BY REFERENCE. An array containing the words "RTN","TMGSHORT",118,0) ;" Dividers -- PASS BY REFERENCE. An array containing the bits between words "RTN","TMGSHORT",119,0) ;" MaxLen -- OPTIONAL. Default=1. The length that words must fit within "RTN","TMGSHORT",120,0) ;" AllowCut -- OPTIONAL. Default=0. Set 1 if automatic shortening is allowed. "RTN","TMGSHORT",121,0) ;" If 1, MaxLen value SHOULD BE supplied "RTN","TMGSHORT",122,0) ;" If 2 then name wil be shortened as far as possible, but it "RTN","TMGSHORT",123,0) ;" wil not be cut off. User will not be asked. "RTN","TMGSHORT",124,0) "RTN","TMGSHORT",125,0) ;"Result: returns the shortened name, or "^" for abort, or 0 for requested retry. "RTN","TMGSHORT",126,0) "RTN","TMGSHORT",127,0) new result set result="" "RTN","TMGSHORT",128,0) set MaxLen=$get(MaxLen,1) "RTN","TMGSHORT",129,0) set AllowCut=$get(AllowCut,0) "RTN","TMGSHORT",130,0) new UserAsked set UserAsked=0 "RTN","TMGSHORT",131,0) new StartOver set StartOver=0 "RTN","TMGSHORT",132,0) new OrigName set OrigName=$$CompArray(.Names,.Dividers) "RTN","TMGSHORT",133,0) "RTN","TMGSHORT",134,0) ;"First try a non-interactive shortening "RTN","TMGSHORT",135,0) set result=$$AutoShortenArray(.Names,.Dividers,MaxLen,"/"," ") "RTN","TMGSHORT",136,0) if (AllowCut'=1)&(result["...") goto SNA0 "RTN","TMGSHORT",137,0) if $length(result)'>MaxLen goto SNA1Done "RTN","TMGSHORT",138,0) "RTN","TMGSHORT",139,0) SNA0 if AllowCut=1 set result=$$CutName(.Names,.Dividers,MaxLen) goto SNA1Done "RTN","TMGSHORT",140,0) if AllowCut=2 set result=$$CompArray(.Names,.Dividers) goto SNA1Done "RTN","TMGSHORT",141,0) "RTN","TMGSHORT",142,0) SNA1 if result=0 goto SNA2Done ;"requesting retry. "RTN","TMGSHORT",143,0) set result=$$Trim^TMGSTUTL($$CompArray(.Names,.Dividers)) "RTN","TMGSHORT",144,0) if $length(result)'>MaxLen goto SNA1Done "RTN","TMGSHORT",145,0) "RTN","TMGSHORT",146,0) write OrigName,"-->",! "RTN","TMGSHORT",147,0) write "Current Name:",! "RTN","TMGSHORT",148,0) write result,! "RTN","TMGSHORT",149,0) if MaxLen>1 do "RTN","TMGSHORT",150,0) . new tempS set tempS="Shorten to ---> |" "RTN","TMGSHORT",151,0) . for i=1:1:MaxLen-$length(tempS) write " " "RTN","TMGSHORT",152,0) . write tempS "RTN","TMGSHORT",153,0) . for i=1:1:$length(result)-MaxLen write "x" "RTN","TMGSHORT",154,0) . write ! "RTN","TMGSHORT",155,0) "RTN","TMGSHORT",156,0) write "-----------------------",! "RTN","TMGSHORT",157,0) for i=1:1:Names("MAXNODE") do "RTN","TMGSHORT",158,0) . if $get(Names(i))="" quit "RTN","TMGSHORT",159,0) . write i,". ",Names(i) "RTN","TMGSHORT",160,0) . new temp set temp=$$GetAbvr^TMGABV(Names(i),0) "RTN","TMGSHORT",161,0) . if (temp'="")&(temp'=Names(i)) write " (<-- Quick Fix: ",temp,")" "RTN","TMGSHORT",162,0) . write ! "RTN","TMGSHORT",163,0) write "-----------------------",! "RTN","TMGSHORT",164,0) write " # (or #-#) -- Shorten name(s) Q# (or #-#) -- Use Quick FiX",! "RTN","TMGSHORT",165,0) write " S# -- Sub-edit name T -- Free text for ALL",! "RTN","TMGSHORT",166,0) write " S?# -- Sub-edit name (ask for divider character)",! "RTN","TMGSHORT",167,0) write " Sx# -- Sub-edit name (use any character (i.e. replace 'x') as divider)",! "RTN","TMGSHORT",168,0) write " J# -- Join word # to word #+1 F# -- Fix erroneous abbrev",! "RTN","TMGSHORT",169,0) write " D# (or D#-#) -- Delete # X# -- Kill Quick Fix",! "RTN","TMGSHORT",170,0) write " ! -- toggle debug mode ",$select(($get(TMGDBABV)=1):"OFF",1:"ON"),! "RTN","TMGSHORT",171,0) write " C -- cut to: ",$$CutName(.Names,.Dividers,MaxLen),! "RTN","TMGSHORT",172,0) ;"write " ^^ -- Abort",! "RTN","TMGSHORT",173,0) write "(^ to quit, ^^ to abort): ^//" "RTN","TMGSHORT",174,0) set UserAsked=1 "RTN","TMGSHORT",175,0) read temp:$get(DTIME,3600),! "RTN","TMGSHORT",176,0) set temp=$$UP^XLFSTR(temp) "RTN","TMGSHORT",177,0) if temp="" set temp="^" do goto SNA1Done "RTN","TMGSHORT",178,0) . set result=$$CompArray(.Names,.Dividers) "RTN","TMGSHORT",179,0) if temp="^^" set result="^" goto SNA2Done "RTN","TMGSHORT",180,0) if temp="C" set AllowCut=1 goto SNA0 "RTN","TMGSHORT",181,0) if "S"[$extract(temp,1) do "RTN","TMGSHORT",182,0) . new num1,s "RTN","TMGSHORT",183,0) . new nodeDiv set nodeDiv=" " "RTN","TMGSHORT",184,0) . set s=$extract(temp,2) "RTN","TMGSHORT",185,0) . if +s'=s do quit:(nodeDiv="^") "RTN","TMGSHORT",186,0) . . if s="?" do quit:(nodeDiv="^") "RTN","TMGSHORT",187,0) . . . write "Enter character that divides words (e.g. '/' ',' '|' ';' ' ' etc.)",! "RTN","TMGSHORT",188,0) . . . read "Divider character? ' '// ",nodeDiv,! "RTN","TMGSHORT",189,0) . . . if nodeDiv="" set nodeDiv=" " "RTN","TMGSHORT",190,0) . . else set nodeDiv=s "RTN","TMGSHORT",191,0) . . set num1=+$extract(temp,3,99) "RTN","TMGSHORT",192,0) . else set num1=+$extract(temp,2,99) "RTN","TMGSHORT",193,0) . if num1=0 read "Enter NUMBER of name to edit: ",num1:$get(DTIME,3600),! "RTN","TMGSHORT",194,0) . set num1=+num1 "RTN","TMGSHORT",195,0) . if (num1'>0)!(num1>Names("MAXNODE")) quit "RTN","TMGSHORT",196,0) . new temp set temp=$$Short1Name(Names(num1),$length(Names(num1))-1,nodeDiv) "RTN","TMGSHORT",197,0) . if (temp="^")!(temp="")!(temp=Names(num1)) quit "RTN","TMGSHORT",198,0) . do Write^TMGABV(Names(num1),temp,,1) ;"1=> confirm "RTN","TMGSHORT",199,0) . set Names(num1)=temp "RTN","TMGSHORT",200,0) if temp="T" do goto SNA1Done "RTN","TMGSHORT",201,0) TX1 . write "Enter text for ENTIRE name (combining all shown parts) (^ to abort):",! "RTN","TMGSHORT",202,0) . read "> ",input:$get(DTIME,3600),! "RTN","TMGSHORT",203,0) . if input="^" quit "RTN","TMGSHORT",204,0) . ;"kill Words,Dividers "RTN","TMGSHORT",205,0) . kill Names,Dividers "RTN","TMGSHORT",206,0) . ;"set Words(1)=input,Words("MAXNODE")=1,Dividers(1)="" "RTN","TMGSHORT",207,0) . set Names(1)=input,Names("MAXNODE")=1,Dividers(1)="" "RTN","TMGSHORT",208,0) if "J"[$extract(temp,1) do "RTN","TMGSHORT",209,0) . new JoinNum "RTN","TMGSHORT",210,0) . set JoinNum=+$extract(temp,2,99) "RTN","TMGSHORT",211,0) . if JoinNum'>0 read "Enter # to join: ",JoinNum:$get(DTIME,3600),! "RTN","TMGSHORT",212,0) . if +JoinNum'>0 quit "RTN","TMGSHORT",213,0) . ;"if JoinNum=Words("MAXNODE") do quit "RTN","TMGSHORT",214,0) . if JoinNum=Names("MAXNODE") do quit "RTN","TMGSHORT",215,0) . . write "Enter the # of the FIRST word to be joined.",! "RTN","TMGSHORT",216,0) JL1 . ;"do SetJoin(JoinNum,2,.Words,.Dividers) "RTN","TMGSHORT",217,0) . do SetJoin(JoinNum,2,.Names,.Dividers) "RTN","TMGSHORT",218,0) if (temp="D")!(temp?1"D".N)!(temp?1"D".N1"-".N) do goto SNA1 "RTN","TMGSHORT",219,0) JL2 . new delNum,delNum2,i "RTN","TMGSHORT",220,0) . set temp=$extract(temp,2,99) "RTN","TMGSHORT",221,0) . ;"if Words("MAXNODE")=1 set delNum=1,delNum2=1 "RTN","TMGSHORT",222,0) . if $get(Names("MAXNODE"))=1 set delNum=1,delNum2=1 "RTN","TMGSHORT",223,0) . else do "RTN","TMGSHORT",224,0) . . set delNum=+$piece(temp,"-",1) "RTN","TMGSHORT",225,0) . . set delNum2=+$piece(temp,"-",2) "RTN","TMGSHORT",226,0) . . if delNum20 quit "RTN","TMGSHORT",228,0) . . read "Enter # (or #-#) to delete: ",temp:$get(DTIME,3600),! "RTN","TMGSHORT",229,0) . . set delNum=+$piece(temp,"-",1) "RTN","TMGSHORT",230,0) . . set delNum2=+$piece(temp,"-",2) "RTN","TMGSHORT",231,0) . . if delNum20 kill Words(i),Dividers(i) "RTN","TMGSHORT",234,0) . . if +i>0 kill Names(i),Dividers(i) "RTN","TMGSHORT",235,0) . ;"do PackArrays("Words","Dividers") "RTN","TMGSHORT",236,0) . do PackArrays("Names","Dividers") "RTN","TMGSHORT",237,0) if "X"[$extract(temp,1) do "RTN","TMGSHORT",238,0) . new delNum "RTN","TMGSHORT",239,0) . ;"if Words("MAXNODE")=1 set delNum=1 "RTN","TMGSHORT",240,0) . if Names("MAXNODE")=1 set delNum=1 "RTN","TMGSHORT",241,0) . else do "RTN","TMGSHORT",242,0) . . set delNum=+$extract(temp,2,99) "RTN","TMGSHORT",243,0) . . if delNum>0 quit "RTN","TMGSHORT",244,0) . . read "Enter # of Quick Fix to delete: ",delNum:$get(DTIME,3600),! "RTN","TMGSHORT",245,0) . ;"if +delNum>0 do Del^TMGABV(Words(delNum)) "RTN","TMGSHORT",246,0) . if +delNum>0 do Del^TMGABV(Names(delNum)) "RTN","TMGSHORT",247,0) if (temp?.N)!(temp?.N1"-".N) do goto SNA1 "RTN","TMGSHORT",248,0) . new num1,num2 "RTN","TMGSHORT",249,0) . set num1=+$piece(temp,"-",1) "RTN","TMGSHORT",250,0) . set num2=+$piece(temp,"-",2) "RTN","TMGSHORT",251,0) . if num2=0 set num2=num1 "RTN","TMGSHORT",252,0) . new tempS set tempS="" "RTN","TMGSHORT",253,0) . for i=num1:1:num2 set tempS=tempS_Names(i)_" " "RTN","TMGSHORT",254,0) . set tempS=$$Trim^TMGSTUTL(tempS) "RTN","TMGSHORT",255,0) . set tempS=$$GetAbvr^TMGABV(tempS,1) "RTN","TMGSHORT",256,0) . for i=num1+1:1:num2 kill Names(i) "RTN","TMGSHORT",257,0) . for i=num1:1:(num2-1) kill Dividers(i) "RTN","TMGSHORT",258,0) . set Names(num1)=tempS "RTN","TMGSHORT",259,0) . do PackArrays("Names","Dividers") "RTN","TMGSHORT",260,0) if (temp="Q")!(temp?1"Q".N)!(temp?1"Q".N1"-".N) do goto SNA1 "RTN","TMGSHORT",261,0) . new num1,num2 "RTN","TMGSHORT",262,0) . set num1=+$extract(temp,2,99) "RTN","TMGSHORT",263,0) . if num1=0 do quit:(+num1=0) "RTN","TMGSHORT",264,0) . . read "Enter NUMBER(S) of Quick Fix to use: ",temp:$get(DTIME,3600),! "RTN","TMGSHORT",265,0) . . set num1=+$piece(temp,"-",1) "RTN","TMGSHORT",266,0) . . set num2=+$piece(temp,"-",2) "RTN","TMGSHORT",267,0) . if +$get(num2)=0 set num2=num1 "RTN","TMGSHORT",268,0) . for i=num1:1:num2 do "RTN","TMGSHORT",269,0) . . set Names(i)=$$GetAbvr^TMGABV(Names(i),0) "RTN","TMGSHORT",270,0) if (temp="F")!(temp?1"F"1N) do goto SNA1 "RTN","TMGSHORT",271,0) . new num1 set num1=+$extract(temp,2,99) "RTN","TMGSHORT",272,0) . if num1=0 do quit:(+num1=0) "RTN","TMGSHORT",273,0) . . read "Enter NUMBER of abbreviation to fix: ",temp:$get(DTIME,3600),! "RTN","TMGSHORT",274,0) . . set num1=+temp "RTN","TMGSHORT",275,0) . new s set s=$$Fix^TMGABV(Names(num1),OrigName) "RTN","TMGSHORT",276,0) . if s=0 set result=0 quit ;"signal retry "RTN","TMGSHORT",277,0) . set Names(num1)=s "RTN","TMGSHORT",278,0) . if Names(num1)="" do "RTN","TMGSHORT",279,0) . . kill Names(num1) "RTN","TMGSHORT",280,0) . . ;"do PackArrays("Words","Dividers") "RTN","TMGSHORT",281,0) . . do PackArrays("Names","Dividers") "RTN","TMGSHORT",282,0) if (temp="!") do goto SNA1 "RTN","TMGSHORT",283,0) JL5 . if $get(TMGDBABV)=1 kill TMGDBABV "RTN","TMGSHORT",284,0) . else set TMGDBABV=1 "RTN","TMGSHORT",285,0) . set result=0 ;"signal request for retry. "RTN","TMGSHORT",286,0) goto SNA1 "RTN","TMGSHORT",287,0) "RTN","TMGSHORT",288,0) SNA1Done set result=$$Trim^TMGSTUTL(result) "RTN","TMGSHORT",289,0) SNA2Done "RTN","TMGSHORT",290,0) if (UserAsked=1)&(+result'=0) write "Using: ",result,! "RTN","TMGSHORT",291,0) quit result "RTN","TMGSHORT",292,0) "RTN","TMGSHORT",293,0) "RTN","TMGSHORT",294,0) ReadJoin(JoinNum,Len,Words,Dividers) "RTN","TMGSHORT",295,0) ;"Purpose: To read out a phrase of joined words, Len words long "RTN","TMGSHORT",296,0) ;"Input: JoinNum -- the index in Words where joining begins "RTN","TMGSHORT",297,0) ;" Len -- the length to return. e.g. 2 --> two words joined "RTN","TMGSHORT",298,0) ;" Words -- PASS BY REFERENCE. Array holding words "RTN","TMGSHORT",299,0) ;" Dividers -- PASS BY REFERENCE. Array holding dividers between words "RTN","TMGSHORT",300,0) ;"Results: returns string of joined words "RTN","TMGSHORT",301,0) "RTN","TMGSHORT",302,0) new result set result="" "RTN","TMGSHORT",303,0) if (JoinNum+Len-1)>Words("MAXNODE") goto RJDone "RTN","TMGSHORT",304,0) set result=$get(Words(JoinNum)) "RTN","TMGSHORT",305,0) new i for i=JoinNum:1:(JoinNum+Len-2) do "RTN","TMGSHORT",306,0) . set result=result_Dividers(i)_$get(Words(i+1)) "RTN","TMGSHORT",307,0) RJDone quit result "RTN","TMGSHORT",308,0) "RTN","TMGSHORT",309,0) "RTN","TMGSHORT",310,0) SetJoin(JoinNum,Len,Words,Dividers) "RTN","TMGSHORT",311,0) ;"Purpose: To reform the Word and Dividers arrays such that words are "RTN","TMGSHORT",312,0) ;" joined together. E.g. #1='One' #2='Minute' ==> #1='One Minute' "RTN","TMGSHORT",313,0) ;"Input: JoinNum -- the index in Words where joining begins "RTN","TMGSHORT",314,0) ;" Len -- the length to return. e.g. 2 --> two words joined "RTN","TMGSHORT",315,0) ;" Words -- PASS BY REFERENCE. Array holding words "RTN","TMGSHORT",316,0) ;" Dividers -- PASS BY REFERENCE. Array holding dividers between words "RTN","TMGSHORT",317,0) ;"Results: None "RTN","TMGSHORT",318,0) "RTN","TMGSHORT",319,0) new temp set temp=$$ReadJoin^TMGSHORT(JoinNum,Len,.Words,.Dividers) "RTN","TMGSHORT",320,0) new i for i=JoinNum:1:(JoinNum+Len-1) do "RTN","TMGSHORT",321,0) . if i'=JoinNum kill Words(i) "RTN","TMGSHORT",322,0) . if i'=(JoinNum+Len-1) kill Dividers(i) "RTN","TMGSHORT",323,0) "RTN","TMGSHORT",324,0) set Words(JoinNum)=temp "RTN","TMGSHORT",325,0) do PackArrays("Words","Dividers") "RTN","TMGSHORT",326,0) "RTN","TMGSHORT",327,0) quit "RTN","TMGSHORT",328,0) "RTN","TMGSHORT",329,0) "RTN","TMGSHORT",330,0) Short1Name(Name,MaxLen,Div1,Div2,Words,Dividers) "RTN","TMGSHORT",331,0) ;"Purpose: An interactive editing of one name "RTN","TMGSHORT",332,0) ;"Input: Name -- the name (string) to shorten. "RTN","TMGSHORT",333,0) ;" MaxLen -- OPTIONAL. The Max length of the string. "RTN","TMGSHORT",334,0) ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " " "RTN","TMGSHORT",335,0) ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/" "RTN","TMGSHORT",336,0) ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words "RTN","TMGSHORT",337,0) ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words "RTN","TMGSHORT",338,0) ;"Results: returns shortened name, or "^" for user abort "RTN","TMGSHORT",339,0) "RTN","TMGSHORT",340,0) set Div1=$get(Div1," ") "RTN","TMGSHORT",341,0) set Div2=$get(Div2) "RTN","TMGSHORT",342,0) "RTN","TMGSHORT",343,0) S1N0 do CleaveToArray^TMGSTUTL(Name,Div1,.Words) "RTN","TMGSHORT",344,0) for i=1:1:Words("MAXNODE") set Dividers(i)=Div1 "RTN","TMGSHORT",345,0) set Dividers(Words("MAXNODE"))="" "RTN","TMGSHORT",346,0) if Div2'="" do SubDivArray(.Words,.Dividers,Div1,Div2) "RTN","TMGSHORT",347,0) "RTN","TMGSHORT",348,0) set result=$$ShortenArray^TMGSHORT(.Words,.Dividers,MaxLen,0) "RTN","TMGSHORT",349,0) if result=0 kill Words,Dividers goto S1N0 "RTN","TMGSHORT",350,0) "RTN","TMGSHORT",351,0) quit result "RTN","TMGSHORT",352,0) "RTN","TMGSHORT",353,0) "RTN","TMGSHORT",354,0) Cut1Name(Name,MaxLen,Div1,Div2,Words,Dividers) "RTN","TMGSHORT",355,0) ;"Purpose: A non-interactive cut of one name "RTN","TMGSHORT",356,0) ;"Input: Name -- the name (string) to shorten. "RTN","TMGSHORT",357,0) ;" MaxLen -- The length of the string to cut to. "RTN","TMGSHORT",358,0) ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " " "RTN","TMGSHORT",359,0) ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/" "RTN","TMGSHORT",360,0) ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words "RTN","TMGSHORT",361,0) ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words "RTN","TMGSHORT",362,0) ;"Results: returns cut name "RTN","TMGSHORT",363,0) "RTN","TMGSHORT",364,0) set Div1=$get(Div1," ") "RTN","TMGSHORT",365,0) set Div2=$get(Div2) "RTN","TMGSHORT",366,0) "RTN","TMGSHORT",367,0) do CleaveToArray^TMGSTUTL(Name,Div1,.Words) "RTN","TMGSHORT",368,0) for i=1:1:Words("MAXNODE") set Dividers(i)=Div1 "RTN","TMGSHORT",369,0) set Dividers(Words("MAXNODE"))="" "RTN","TMGSHORT",370,0) if Div2'="" do SubDivArray(.Words,.Dividers,Div1,Div2) "RTN","TMGSHORT",371,0) "RTN","TMGSHORT",372,0) set result=$$CutName(.Words,.Dividers,MaxLen) "RTN","TMGSHORT",373,0) "RTN","TMGSHORT",374,0) quit result "RTN","TMGSHORT",375,0) "RTN","TMGSHORT",376,0) "RTN","TMGSHORT",377,0) Short2Name(Name,Div1,Div2,Words,Dividers,Category) "RTN","TMGSHORT",378,0) ;"Purpose: Shorten a name, using abbreviations etc. to shortest form possible "RTN","TMGSHORT",379,0) ;" Will separate name into individual words, separated by spaces "RTN","TMGSHORT",380,0) ;" and try to abbreviate each one. "RTN","TMGSHORT",381,0) ;"Input: Name -- name to shorten "RTN","TMGSHORT",382,0) ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " " "RTN","TMGSHORT",383,0) ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/" "RTN","TMGSHORT",384,0) ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words "RTN","TMGSHORT",385,0) ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words "RTN","TMGSHORT",386,0) ;" Category -- OPTIONAL. a category to look for phrases in "RTN","TMGSHORT",387,0) ;"Result: returns a shortened form of name "RTN","TMGSHORT",388,0) ;"Note: no testing of length done. "RTN","TMGSHORT",389,0) ;"Note: this function is NOT interactive with the user "RTN","TMGSHORT",390,0) ;"Note: This functions should be called repetatively,using the output from "RTN","TMGSHORT",391,0) ;" the last run as the input for the next run, until there is not further "RTN","TMGSHORT",392,0) ;" change, to get the best results. "RTN","TMGSHORT",393,0) "RTN","TMGSHORT",394,0) new temp,result,i "RTN","TMGSHORT",395,0) set result="" "RTN","TMGSHORT",396,0) if $get(Name)="" goto SN2Don2 "RTN","TMGSHORT",397,0) "RTN","TMGSHORT",398,0) set result=$$GetAbvr^TMGABV(Name,0) "RTN","TMGSHORT",399,0) if (result'="")&(result'=Name) goto SN2Done "RTN","TMGSHORT",400,0) "RTN","TMGSHORT",401,0) set Div1=$get(Div1," ") if Div1="" set Div1="@@@@" "RTN","TMGSHORT",402,0) set Div2=$get(Div2,"/") if Div2="" set Div2="@@@@" "RTN","TMGSHORT",403,0) "RTN","TMGSHORT",404,0) kill Words,Dividers "RTN","TMGSHORT",405,0) do CleaveToArray^TMGSTUTL(Name,Div1,.Words) "RTN","TMGSHORT",406,0) for i=1:1:Words("MAXNODE") set Dividers(i)=Div1 "RTN","TMGSHORT",407,0) set Dividers(Words("MAXNODE"))="" ;"//kt added 10/27/06 "RTN","TMGSHORT",408,0) "RTN","TMGSHORT",409,0) ;"Note: This purposefully does not keep rechecking for ever shortening "RTN","TMGSHORT",410,0) ;" Abreviations (or abrv of abrv's) so that the calling function "RTN","TMGSHORT",411,0) ;" can concat the results from this onto others and determine a "RTN","TMGSHORT",412,0) ;" total length, and then recall if needed. "RTN","TMGSHORT",413,0) new count set count=Words("MAXNODE") "RTN","TMGSHORT",414,0) for i=1:1:count do "RTN","TMGSHORT",415,0) . new temp,temp2 "RTN","TMGSHORT",416,0) . if Words(i)[Div2 set temp=$$Short2Name(Words(i),Div2) "RTN","TMGSHORT",417,0) . else set temp=$$GetAbvr^TMGABV(Words(i),0) "RTN","TMGSHORT",418,0) . set Words(i)=temp "RTN","TMGSHORT",419,0) "RTN","TMGSHORT",420,0) ;"Now look for double word matches "RTN","TMGSHORT",421,0) set Category=$get(Category,0) "RTN","TMGSHORT",422,0) SNL0 for i=1:1:count do "RTN","TMGSHORT",423,0) . new temp,temp2 "RTN","TMGSHORT",424,0) . set temp=$$ReadJoin^TMGSHORT(i,2,.Words,.Dividers) "RTN","TMGSHORT",425,0) . set temp2=$$GetAbvr^TMGABV(temp,Category) "RTN","TMGSHORT",426,0) . if (temp2'="")&(temp'=temp2) do "RTN","TMGSHORT",427,0) SNL1 . . ;"write "Found double word match: ",temp,"-->",temp2,! "RTN","TMGSHORT",428,0) . . do SetJoin^TMGSHORT(i,2,.Words,.Dividers) "RTN","TMGSHORT",429,0) . . set Words(i)=temp2 "RTN","TMGSHORT",430,0) . . ;"zwr Words(*) "RTN","TMGSHORT",431,0) . . set i=0,count=Words("MAXNODE") "RTN","TMGSHORT",432,0) "RTN","TMGSHORT",433,0) set result=$$CompArray(.Words,.Dividers) "RTN","TMGSHORT",434,0) "RTN","TMGSHORT",435,0) SN2Done set result=$$Trim^TMGSTUTL(result) "RTN","TMGSHORT",436,0) if (Name'=result) do Write^TMGABV(Name,result) "RTN","TMGSHORT",437,0) "RTN","TMGSHORT",438,0) SN2Don2 quit result "RTN","TMGSHORT",439,0) "RTN","TMGSHORT",440,0) "RTN","TMGSHORT",441,0) SubDivArray(Words,Dividers,Div1,Div2) "RTN","TMGSHORT",442,0) ;"Purpose: To see if any words in Words array needs to be subdivided, "RTN","TMGSHORT",443,0) ;" and to handle if needed. "RTN","TMGSHORT",444,0) ;"Input: Words -- PASS BY REFERENCE. Array of words "RTN","TMGSHORT",445,0) ;" Dividers -- PASS BY REFERENCE. Array of dividing parts "RTN","TMGSHORT",446,0) ;" Div1 -- the first division character, e.g. "/" or " " "RTN","TMGSHORT",447,0) ;" Div2 -- the second division character, e.g. " " or "/" "RTN","TMGSHORT",448,0) ;"Results: none "RTN","TMGSHORT",449,0) "RTN","TMGSHORT",450,0) new i "RTN","TMGSHORT",451,0) for i=1:1:Words("MAXNODE") do "RTN","TMGSHORT",452,0) . if Words(i)[Div2 do "RTN","TMGSHORT",453,0) . . new tempWords,j "RTN","TMGSHORT",454,0) . . do CleaveToArray^TMGSTUTL(Words(i),Div2,.tempWords) "RTN","TMGSHORT",455,0) . . for j=1:1:tempWords("MAXNODE") do "RTN","TMGSHORT",456,0) . . . set Words(+(i_"."_j))=tempWords(j) "RTN","TMGSHORT",457,0) . . . if j'=tempWords("MAXNODE") set Dividers(+(i_"."_j))=Div2 "RTN","TMGSHORT",458,0) . . . else set Dividers(+(i_"."_j))=Div1 "RTN","TMGSHORT",459,0) . . kill Words(i),Dividers(i) "RTN","TMGSHORT",460,0) do PackArrays("Words","Dividers") "RTN","TMGSHORT",461,0) "RTN","TMGSHORT",462,0) quit "RTN","TMGSHORT",463,0) "RTN","TMGSHORT",464,0) "RTN","TMGSHORT",465,0) PackArrays(pNames,pDividers) "RTN","TMGSHORT",466,0) ;"Purpose: to pack the arrays, after items had been deleted. "RTN","TMGSHORT",467,0) ;"Input: Names -- PASS BY NAME. Array of words "RTN","TMGSHORT",468,0) ;" Dividers -- PASS BY NAME. Array of dividing parts "RTN","TMGSHORT",469,0) ;"Result: none "RTN","TMGSHORT",470,0) "RTN","TMGSHORT",471,0) do ListPack^TMGMISC(pNames) "RTN","TMGSHORT",472,0) do ListPack^TMGMISC(pDividers) "RTN","TMGSHORT",473,0) set @pNames@("MAXNODE")=$$ListCt^TMGMISC(pNames) "RTN","TMGSHORT",474,0) set @pDividers@("MAXNODE")=$$ListCt^TMGMISC(pDividers) "RTN","TMGSHORT",475,0) quit "RTN","TMGSHORT",476,0) "RTN","TMGSHORT",477,0) "RTN","TMGSHORT",478,0) CompArray(Names,Dividers) "RTN","TMGSHORT",479,0) ;"Purpose: to reconstruct the resulting sentence from words in array. "RTN","TMGSHORT",480,0) ;"Input: Names -- PASS BY REFERENCE. Array of words "RTN","TMGSHORT",481,0) ;" Dividers -- PASS BY REFERENCE. Array of dividing parts "RTN","TMGSHORT",482,0) ;"Result: returns the compiled result "RTN","TMGSHORT",483,0) "RTN","TMGSHORT",484,0) new result,j "RTN","TMGSHORT",485,0) set result="" "RTN","TMGSHORT",486,0) for j=1:1:Names("MAXNODE") do "RTN","TMGSHORT",487,0) . set result=result_Names(j) "RTN","TMGSHORT",488,0) . if Names(j)'="" set result=result_Dividers(j) "RTN","TMGSHORT",489,0) quit result "RTN","TMGSHORT",490,0) "RTN","TMGSHORT",491,0) "RTN","TMGSHORT",492,0) AutoShortenArray(Names,Dividers,MaxLen,Div1,Div2) "RTN","TMGSHORT",493,0) ;"Purpose: To automatically shorten the words in the array "RTN","TMGSHORT",494,0) ;"Input: Names -- PASS BY REFERENCE. Array of words "RTN","TMGSHORT",495,0) ;" Dividers -- PASS BY REFERENCE. Array of dividing parts "RTN","TMGSHORT",496,0) ;" Div1 -- the first division character, e.g. "/" or " " "RTN","TMGSHORT",497,0) ;" Div2 -- the second division character, e.g. " " or "/" "RTN","TMGSHORT",498,0) "RTN","TMGSHORT",499,0) new result,newName,changeMade "RTN","TMGSHORT",500,0) set result="" "RTN","TMGSHORT",501,0) "RTN","TMGSHORT",502,0) new temp set temp=$$CompArray(.Names,.Dividers) "RTN","TMGSHORT",503,0) set result=$$GetAbvr^TMGABV(temp,0) "RTN","TMGSHORT",504,0) if result="^" set result="" do Del^TMGABV(temp) "RTN","TMGSHORT",505,0) if (result'="")&($length(result)'>MaxLen) goto ASADone "RTN","TMGSHORT",506,0) "RTN","TMGSHORT",507,0) for do quit:(changeMade=0)!($length(result)'>MaxLen) "RTN","TMGSHORT",508,0) . set changeMade=0 "RTN","TMGSHORT",509,0) . for i=1:1:Names("MAXNODE") do "RTN","TMGSHORT",510,0) . . set newName=$$Short2Name(Names(i),.Div1,.Div2) "RTN","TMGSHORT",511,0) . . ;"there was a loop where a name was repeatitively being replace with longer names --> crash "RTN","TMGSHORT",512,0) . . if (newName'=Names(i))&($length(newName)<$length(Names(i))) do "RTN","TMGSHORT",513,0) . . . set Names(i)=newName "RTN","TMGSHORT",514,0) . . . set changeMade=1 "RTN","TMGSHORT",515,0) . set result=$$CompArray(.Names,.Dividers) "RTN","TMGSHORT",516,0) "RTN","TMGSHORT",517,0) ASADone "RTN","TMGSHORT",518,0) quit result "RTN","TMGSHORT",519,0) "RTN","TMGSHORT",520,0) "RTN","TMGSHORT",521,0) CutName(Names,Dividers,MaxLen) "RTN","TMGSHORT",522,0) ;"Purpose: To return a non-interactive shortened ('cut') name "RTN","TMGSHORT",523,0) ;"Input: Names - PASS BY REFERENCE. As created in ShortNetName "RTN","TMGSHORT",524,0) ;" This is an array with the various words in the name "RTN","TMGSHORT",525,0) ;" Dividers -- PASS BY REFERENCE As created in ShortNetName "RTN","TMGSHORT",526,0) ;" This is an array with the spaces or punctiation separating words "RTN","TMGSHORT",527,0) ;" MaxLen -- The target length for result "RTN","TMGSHORT",528,0) ;"Result: returns the shortened name "RTN","TMGSHORT",529,0) "RTN","TMGSHORT",530,0) new partA,partB,Max,i,lenA "RTN","TMGSHORT",531,0) new result "RTN","TMGSHORT",532,0) "RTN","TMGSHORT",533,0) set Max=$get(Names("MAXNODE")) "RTN","TMGSHORT",534,0) "RTN","TMGSHORT",535,0) if Max'>3 do goto CutDone "RTN","TMGSHORT",536,0) . set result=$$CompArray(.Names,.Dividers) "RTN","TMGSHORT",537,0) . set result=$extract(result,1,MaxLen) "RTN","TMGSHORT",538,0) "RTN","TMGSHORT",539,0) set partB=$get(Dividers(Max-3)) "RTN","TMGSHORT",540,0) for i=Max-2:1:Max do "RTN","TMGSHORT",541,0) . set partB=partB_Names(i) "RTN","TMGSHORT",542,0) . if Names(i)'="" set partB=partB_Dividers(i) "RTN","TMGSHORT",543,0) set partB=$$Trim^TMGSTUTL(partB) "RTN","TMGSHORT",544,0) set partA="" "RTN","TMGSHORT",545,0) for i=1:1:Max-3 set partA=partA_Names(i) set:(i<(Max-3))&(Names(i)'="") partA=partA_Dividers(i) "RTN","TMGSHORT",546,0) new allowedALen set allowedALen=MaxLen-$length(partB) "RTN","TMGSHORT",547,0) set lenA=$length(partA) "RTN","TMGSHORT",548,0) if lenA>allowedALen do "RTN","TMGSHORT",549,0) . set allowedALen=allowedALen-4 "RTN","TMGSHORT",550,0) . if lenA=0 set partA="" quit "RTN","TMGSHORT",551,0) . if (allowedALen/lenA)<0.4 set partA="" quit "RTN","TMGSHORT",552,0) . if allowedALen<4 set partA="" quit "RTN","TMGSHORT",553,0) . set partA=$extract(partA,1,allowedALen)_"... " "RTN","TMGSHORT",554,0) set result=$$Trim^TMGSTUTL(partA_partB) "RTN","TMGSHORT",555,0) if $length(result)>MaxLen do "RTN","TMGSHORT",556,0) . if partA="" do "RTN","TMGSHORT",557,0) . . set partB="" ;"$get(Dividers(Max-2)) "RTN","TMGSHORT",558,0) . . for i=Max-1:1:Max do "RTN","TMGSHORT",559,0) . . . set partB=partB_Names(i) "RTN","TMGSHORT",560,0) . . . if Names(i)'="" set partB=partB_Dividers(i) "RTN","TMGSHORT",561,0) . . set partB=$$Trim^TMGSTUTL(partB) "RTN","TMGSHORT",562,0) . . set partA=Names(Max-2) "RTN","TMGSHORT",563,0) . . new allowedALen set allowedALen=MaxLen-$length(partB)-4 "RTN","TMGSHORT",564,0) . . set partA=$extract(partA,1,allowedALen)_"... " "RTN","TMGSHORT",565,0) . . set result=partA_partB "RTN","TMGSHORT",566,0) . else set result=$extract(result,1,MaxLen) "RTN","TMGSHORT",567,0) "RTN","TMGSHORT",568,0) CutDone "RTN","TMGSHORT",569,0) quit result "RTN","TMGSHORT",570,0) "RTN","TMGSHORT",571,0) "RTN","TMGSHORT",572,0) PShortName(Name,Length,AskUser) "RTN","TMGSHORT",573,0) ;"Purpose: To shorten the drug smartly, using abbreviations "RTN","TMGSHORT",574,0) ;" This function differs from ShortName (see below) because it smartly "RTN","TMGSHORT",575,0) ;" 'P'icks whether to use '/' or ' ' as a divider str. "RTN","TMGSHORT",576,0) ;"Input: Name -- the drug name to shorten "RTN","TMGSHORT",577,0) ;" Expected format is that found in file 50.6 field .01, "RTN","TMGSHORT",578,0) ;" i.e. INGREDIENT/INGREDIENT/INGREDIENT... "RTN","TMGSHORT",579,0) ;" Length -- The desired string length "RTN","TMGSHORT",580,0) ;" AskUser -- OPTIONAL. Default=0. "RTN","TMGSHORT",581,0) ;" If 1 then user is asked to supply abreviations if needed. "RTN","TMGSHORT",582,0) ;" If 2 then name is shortened as much as possible, but it "RTN","TMGSHORT",583,0) ;" might be longer than Length, it is not cut, and user is "RTN","TMGSHORT",584,0) ;" not asked. "RTN","TMGSHORT",585,0) ;"Result : returns shortened name, "^" for abort. "RTN","TMGSHORT",586,0) "RTN","TMGSHORT",587,0) new DivStr,result "RTN","TMGSHORT",588,0) if $length(Name,"/")>2 set DivStr="/" "RTN","TMGSHORT",589,0) else set DivStr=" " "RTN","TMGSHORT",590,0) "RTN","TMGSHORT",591,0) set result=$$ShortName(.Name,.Length,.AskUser,DivStr) "RTN","TMGSHORT",592,0) quit result "RTN","TMGSHORT",593,0) "RTN","TMGSHORT",594,0) ShortName(Name,Length,AskUser,DivStr) "RTN","TMGSHORT",595,0) ;"Purpose: To shorten the drug smartly, using abbreviations "RTN","TMGSHORT",596,0) ;"Input: Name -- the drug name to shorten "RTN","TMGSHORT",597,0) ;" Expected format is that found in file 50.6 field .01, "RTN","TMGSHORT",598,0) ;" i.e. INGREDIENT/INGREDIENT/INGREDIENT... "RTN","TMGSHORT",599,0) ;" Length -- The desired string length "RTN","TMGSHORT",600,0) ;" AskUser -- OPTIONAL. Default=0. "RTN","TMGSHORT",601,0) ;" If 1 then user is asked to supply abreviations if needed. "RTN","TMGSHORT",602,0) ;" If 2 then name is shortened as much as possible, but it "RTN","TMGSHORT",603,0) ;" might be longer than Length, it is not cut, and user is "RTN","TMGSHORT",604,0) ;" not asked. "RTN","TMGSHORT",605,0) ;" DivStr -- the divider that separates parts. Default="/" "RTN","TMGSHORT",606,0) ;"Result : returns shortened name, "^" for abort. "RTN","TMGSHORT",607,0) "RTN","TMGSHORT",608,0) new temp,Words,Dividers "RTN","TMGSHORT",609,0) set AskUser=$get(AskUser,0) "RTN","TMGSHORT",610,0) set DivStr=$get(DivStr,"/") "RTN","TMGSHORT",611,0) "RTN","TMGSHORT",612,0) if Name="" set temp="^" goto SNDone "RTN","TMGSHORT",613,0) set temp=$$Read^TMGABV(Name,Length) "RTN","TMGSHORT",614,0) "RTN","TMGSHORT",615,0) if (temp'="")&($length(temp)'>Length) goto SNDone "RTN","TMGSHORT",616,0) "RTN","TMGSHORT",617,0) ;"Note: $$ShortName does NOT check length "RTN","TMGSHORT",618,0) new oldTemp,done "RTN","TMGSHORT",619,0) set temp=Name,done=0 "RTN","TMGSHORT",620,0) for do quit:done!($length(temp)'>Length) "RTN","TMGSHORT",621,0) . set oldTemp=temp "RTN","TMGSHORT",622,0) . set temp=$$Short2Name(temp,DivStr,"",.Words,.Dividers,Length) "RTN","TMGSHORT",623,0) . if temp=oldTemp set done=1 quit "RTN","TMGSHORT",624,0) . if ($length(temp)'>Length) set done=1 ;"don't quit yet "RTN","TMGSHORT",625,0) . if (temp["...")&(AskUser=1) write !,"Remove '...' from name",! set done=0 "RTN","TMGSHORT",626,0) "RTN","TMGSHORT",627,0) if (($length(temp)>Length)&(AskUser=1)) do "RTN","TMGSHORT",628,0) SNm0 . new killthis set killthis=0 "RTN","TMGSHORT",629,0) . write "IEN 50.6=",$get(IEN50d6,"?")," IEN 50.606=",$get(IEN50d606,"?") "RTN","TMGSHORT",630,0) . write " Dose=",$get(Dose,"?")," IEN 50=",$get(IEN50,"?"),! "RTN","TMGSHORT",631,0) . write Name,! "RTN","TMGSHORT",632,0) SNm1 . set temp=$$Short1Name(temp,Length,DivStr,"",.Words,.Dividers) "RTN","TMGSHORT",633,0) . if (temp'="")&(temp'="^")&(temp'=Name) do "RTN","TMGSHORT",634,0) . . do Write^TMGABV(Name,temp,Length,(AskUser=1)) "RTN","TMGSHORT",635,0) . write ! "RTN","TMGSHORT",636,0) "RTN","TMGSHORT",637,0) if ($length(temp)>Length)&(AskUser'=2) do "RTN","TMGSHORT",638,0) . if ($data(Words)=0)!($data(Dividers)=0) do quit "RTN","TMGSHORT",639,0) . . set temp=$extract(temp,1,Length) "RTN","TMGSHORT",640,0) . set temp=$$CutName(.Words,.Dividers,Length) "RTN","TMGSHORT",641,0) SNDone "RTN","TMGSHORT",642,0) if $extract(temp,1)="/" set temp=$extract(temp,2,Length) "RTN","TMGSHORT",643,0) quit temp "RTN","TMGSHORT",644,0) "RTN","TMGSHORT",645,0) "RTN","TMGSTUTL") 0^79^B14081 "RTN","TMGSTUTL",1,0) TMGSTUTL ;TMG/kst/String Utilities and Library ;03/25/06 "RTN","TMGSTUTL",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGSTUTL",3,0) "RTN","TMGSTUTL",4,0) ;"TMG STRING UTILITIES "RTN","TMGSTUTL",5,0) "RTN","TMGSTUTL",6,0) ;"======================================================================= "RTN","TMGSTUTL",7,0) ;" API -- Public Functions. "RTN","TMGSTUTL",8,0) ;"======================================================================= "RTN","TMGSTUTL",9,0) ;"CleaveToArray^TMGSTUTL(Text,Divider,Array) "RTN","TMGSTUTL",10,0) ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 "RTN","TMGSTUTL",11,0) ;"CleaveStr^TMGSTUTL(Text,Divider,PartB) "RTN","TMGSTUTL",12,0) ;"SplitStr^TMGSTUTL(Text,Width,PartB) "RTN","TMGSTUTL",13,0) ;"SetStrLen^TMGSTUTL(Text,Width) "RTN","TMGSTUTL",14,0) ;"$$NestSplit^TMGSTUTL(Text,OpenBracket,CloseBracket,SBefore,S,SAfter) "RTN","TMGSTUTL",15,0) ;"$$Substitute^TMGSTUTL(S,Match,NewValue) "RTN","TMGSTUTL",16,0) ;"$$FormatArray^TMGSTUTL(InArray,OutArray,Divider) "RTN","TMGSTUTL",17,0) ;"$$Trim^TMGSTUTL(S,TrimCh) "RTN","TMGSTUTL",18,0) ;"$$TrimL^TMGSTUTL(S,TrimCh) "RTN","TMGSTUTL",19,0) ;"$$TrimR^TMGSTUTL(S,TrimCh) "RTN","TMGSTUTL",20,0) ;"$$NumLWS^TMGSTUTL(S) "RTN","TMGSTUTL",21,0) ;"$$MakeWS^TMGSTUTL(n) "RTN","TMGSTUTL",22,0) ;"WordWrapArray^TMGSTUTL(.Array,Width,SpecialIndent) "RTN","TMGSTUTL",23,0) ;"SplitLine^TMGSTUTL(s,.LineArray,Width) "RTN","TMGSTUTL",24,0) ;"WriteWP^TMGSTUTL(NodeRef) "RTN","TMGSTUTL",25,0) ;"$$LPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below "RTN","TMGSTUTL",26,0) ;"$$RPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below "RTN","TMGSTUTL",27,0) ;"$$Center^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below "RTN","TMGSTUTL",28,0) ;"$$Clip^TMGSTUTL(S,width) "RTN","TMGSTUTL",29,0) ;"$$STRB2H^TMGSTUTL(s,F) Convert a string to hex characters "RTN","TMGSTUTL",30,0) ;"$$CapWords^TMGSTUTL(S,Divider) ;"capitalize the first character of each word in a string "RTN","TMGSTUTL",31,0) ;"$$LinuxStr^TMGSTUTL(S) ;"Convert string to a valid linux filename "RTN","TMGSTUTL",32,0) ;"StrToWP^TMGSTUTL(s,pArray,width,DivCh,InitLine) ;"wrap long string into a WP array "RTN","TMGSTUTL",33,0) ;"$$WPToStr^TMGSTUTL(pArray,DivCh,MaxLen,InitLine) "RTN","TMGSTUTL",34,0) ;"Comp2Strs(s1,s2) -- compare two strings and assign an arbritrary score to their similarity "RTN","TMGSTUTL",35,0) ;"$$PosNum(s,[Num],LeadingSpace) -- return position of a number in a string "RTN","TMGSTUTL",36,0) ;"IsNumeric(s) -- deterimine if word s is a numeric "RTN","TMGSTUTL",37,0) ;"ScrubNumeric(s) -- remove numeric words from a sentence "RTN","TMGSTUTL",38,0) ;"Pos(subStr,s,count) -- return the beginning position of subStr in s "RTN","TMGSTUTL",39,0) ;"DiffPos(s1,s2) -- Return the position of the first difference between s1 and s2 "RTN","TMGSTUTL",40,0) ;"DiffWords(Words1,Words2) -- Return index of first different word between Words arrays "RTN","TMGSTUTL",41,0) ;"SimStr(s1,p1,s2,p2) -- return matching string in s1 and s2, starting at position p1,p2 "RTN","TMGSTUTL",42,0) ;"SimWord(Words1,p1,Words2,p2) -- return the matching words in both words array 1 and 2, starting "RTN","TMGSTUTL",43,0) ;" at word positions p1 and p2. "RTN","TMGSTUTL",44,0) ;"SimPos(s1,s2) -- return the first position that two strings are similar. "RTN","TMGSTUTL",45,0) ;"SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) -- return the first position that two word arrays "RTN","TMGSTUTL",46,0) ;" are similar. This means the first index in Words array 1 that matches to words in Words array 2. "RTN","TMGSTUTL",47,0) ;"DiffStr(s1,s2,DivChr) -- Return how s1 differs from s2. "RTN","TMGSTUTL",48,0) ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 "RTN","TMGSTUTL",49,0) ;"$$QtProtect(s) -- Protects quotes by converting all quotes do double quotes (" --> "") "RTN","TMGSTUTL",50,0) "RTN","TMGSTUTL",51,0) "RTN","TMGSTUTL",52,0) ;"======================================================================= "RTN","TMGSTUTL",53,0) ;"Dependancies "RTN","TMGSTUTL",54,0) ;" uses TMGDEBUG for debug messaging. "RTN","TMGSTUTL",55,0) ;"======================================================================= "RTN","TMGSTUTL",56,0) ;"======================================================================= "RTN","TMGSTUTL",57,0) "RTN","TMGSTUTL",58,0) ;"------------------------------------------------------------------------ "RTN","TMGSTUTL",59,0) ;"FYI, String functions in XLFSTR module: "RTN","TMGSTUTL",60,0) ;"------------------------------------------------------------------------ "RTN","TMGSTUTL",61,0) ;"$$CJ^XLFSTR(s,i[,p]) -- Returns a center-justified string "RTN","TMGSTUTL",62,0) ;" s=string, i=field size, p(optional)=pad character "RTN","TMGSTUTL",63,0) ;"$$LJ^XLFSTR(s,i[,p]) -- Returns a left-justified string "RTN","TMGSTUTL",64,0) ;" s=string, i=field size, p(optional)=pad character "RTN","TMGSTUTL",65,0) ;"$$RJ^XLFSTR(s,i[,p]) -- Returns a right-justified string "RTN","TMGSTUTL",66,0) ;" s=string, i=field size, p(optional)=pad character "RTN","TMGSTUTL",67,0) ;"$$INVERT^XLFSTR(s) -- returns an inverted string (i.e. "ABC"-->"CBA") "RTN","TMGSTUTL",68,0) ;"$$LOW^XLFSTR(s) -- returns string with all letters converted to lower-case "RTN","TMGSTUTL",69,0) ;"$$UP^XLFSTR(s) -- returns string with all letters converted to upper-case "RTN","TMGSTUTL",70,0) ;"$$REPEAT^XLFSTR(s,Count) -- returns a string that is a repeat of s Count times "RTN","TMGSTUTL",71,0) ;"$$REPLACE^XLFSTR(s,.spec) -- Uses a multi-character $TRanslate to return a "RTN","TMGSTUTL",72,0) ;" string with the specified string replaced "RTN","TMGSTUTL",73,0) ;" s=input string, spec=array passed by reference "RTN","TMGSTUTL",74,0) ;" spec format: "RTN","TMGSTUTL",75,0) ;" spec("Any_Search_String")="Replacement_String" "RTN","TMGSTUTL",76,0) ;"$$STRIP^XLFSTR(s,Char) -- returns string striped of all instances of Char "RTN","TMGSTUTL",77,0) "RTN","TMGSTUTL",78,0) ;"======================================================================= "RTN","TMGSTUTL",79,0) "RTN","TMGSTUTL",80,0) CleaveToArray(Text,Divider,Array,InitIndex) "RTN","TMGSTUTL",81,0) ;"Purpose: To take a string, delineated by 'divider' and "RTN","TMGSTUTL",82,0) ;" to split it up into all its parts, putting each part "RTN","TMGSTUTL",83,0) ;" into an array. e.g.: "RTN","TMGSTUTL",84,0) ;" This/Is/A/Test, with '/' divider would result in "RTN","TMGSTUTL",85,0) ;" Array(1)="This" "RTN","TMGSTUTL",86,0) ;" Array(2)="Is" "RTN","TMGSTUTL",87,0) ;" Array(3)="A" "RTN","TMGSTUTL",88,0) ;" Array(4)="Test" "RTN","TMGSTUTL",89,0) ;" Array(cMaxNode)=4 ;cMaxNode="MAXNODE" "RTN","TMGSTUTL",90,0) ;"Input: Text - the input string -- should NOT be passed by reference. "RTN","TMGSTUTL",91,0) ;" Divider - the delineating string "RTN","TMGSTUTL",92,0) ;" Array - The array to receive output **SHOULD BE PASSED BY REFERENCE. "RTN","TMGSTUTL",93,0) ;" InitIndex - OPTIONAL -- The index of the array to start with, i.e. 0 or 1. Default=1 "RTN","TMGSTUTL",94,0) ;"Output: Array is changed, as outlined above "RTN","TMGSTUTL",95,0) ;"Result: none "RTN","TMGSTUTL",96,0) ;"Notes: Note -- Text is NOT changed (unless passed by reference, in "RTN","TMGSTUTL",97,0) ;" which case the next to the last piece is put into Text) "RTN","TMGSTUTL",98,0) ;" Array is killed, the filled with data **ONLY** IF DIVISIONS FOUND "RTN","TMGSTUTL",99,0) ;" Limit of 256 nodes "RTN","TMGSTUTL",100,0) ;" if cMaxNode is not defined, "MAXNODE" will be used "RTN","TMGSTUTL",101,0) "RTN","TMGSTUTL",102,0) set DBIndent=$get(DBIndent,0) "RTN","TMGSTUTL",103,0) do DebugEntry^TMGDEBUG(.DBIndent,"CleaveToArray") "RTN","TMGSTUTL",104,0) "RTN","TMGSTUTL",105,0) set InitIndex=$get(InitIndex,1) "RTN","TMGSTUTL",106,0) new PartB "RTN","TMGSTUTL",107,0) new count set count=InitIndex "RTN","TMGSTUTL",108,0) set cMaxNode=$get(cMaxNode,"MAXNODE") "RTN","TMGSTUTL",109,0) "RTN","TMGSTUTL",110,0) kill Array ;"Clear out any old data "RTN","TMGSTUTL",111,0) "RTN","TMGSTUTL",112,0) C2ArLoop "RTN","TMGSTUTL",113,0) if '(Text[Divider) do goto C2ArDone "RTN","TMGSTUTL",114,0) . set Array(count)=Text ;"put it all into first line. "RTN","TMGSTUTL",115,0) . set Array(cMaxNode)=1 "RTN","TMGSTUTL",116,0) do CleaveStr(.Text,Divider,.PartB) "RTN","TMGSTUTL",117,0) set Array(count)=Text "RTN","TMGSTUTL",118,0) set Array(cMaxNode)=count "RTN","TMGSTUTL",119,0) set count=count+1 "RTN","TMGSTUTL",120,0) if '(PartB[Divider) do goto C2ArDone "RTN","TMGSTUTL",121,0) . set Array(count)=PartB "RTN","TMGSTUTL",122,0) . set Array(cMaxNode)=count "RTN","TMGSTUTL",123,0) else do goto C2ArLoop "RTN","TMGSTUTL",124,0) . set Text=$get(PartB) "RTN","TMGSTUTL",125,0) . set PartB="" "RTN","TMGSTUTL",126,0) "RTN","TMGSTUTL",127,0) C2ArDone "RTN","TMGSTUTL",128,0) do DebugExit^TMGDEBUG(.DBIndent,"CleaveToArray") "RTN","TMGSTUTL",129,0) quit "RTN","TMGSTUTL",130,0) "RTN","TMGSTUTL",131,0) "RTN","TMGSTUTL",132,0) CleaveStr(Text,Divider,PartB) "RTN","TMGSTUTL",133,0) ;"Purpse: To take a string, delineated by 'Divider' "RTN","TMGSTUTL",134,0) ;" and to split it into two parts: Text and PartB "RTN","TMGSTUTL",135,0) ;" e.g. Text="Hello\nThere" "RTN","TMGSTUTL",136,0) ;" Divider="\n" "RTN","TMGSTUTL",137,0) ;" Function will result in: Text="Hello", PartB="There" "RTN","TMGSTUTL",138,0) ;"Input: Text - the input string **SHOULD BE PASSED BY REFERENCE. "RTN","TMGSTUTL",139,0) ;" Divider - the delineating string "RTN","TMGSTUTL",140,0) ;" PartB - the string to get second part **SHOULD BE PASSED BY REFERENCE. "RTN","TMGSTUTL",141,0) ;"Output: Text and PartB will be changed "RTN","TMGSTUTL",142,0) ;" Function will result in: Text="Hello", PartB="There" "RTN","TMGSTUTL",143,0) ;"Result: none "RTN","TMGSTUTL",144,0) "RTN","TMGSTUTL",145,0) set DBIndent=$get(DBIndent,0) "RTN","TMGSTUTL",146,0) do DebugEntry^TMGDEBUG(.DBIndent,"CleaveStr") "RTN","TMGSTUTL",147,0) "RTN","TMGSTUTL",148,0) do DebugMsg^TMGDEBUG(DBIndent,"Text=",Text) "RTN","TMGSTUTL",149,0) "RTN","TMGSTUTL",150,0) if '$data(Text) goto CSDone "RTN","TMGSTUTL",151,0) if '$Data(Divider) goto CSDone "RTN","TMGSTUTL",152,0) set PartB="" "RTN","TMGSTUTL",153,0) "RTN","TMGSTUTL",154,0) new PartA "RTN","TMGSTUTL",155,0) "RTN","TMGSTUTL",156,0) if Text[Divider do "RTN","TMGSTUTL",157,0) . set PartA=$piece(Text,Divider,1) "RTN","TMGSTUTL",158,0) . set PartB=$piece(Text,Divider,2,256) "RTN","TMGSTUTL",159,0) . set Text=PartA "RTN","TMGSTUTL",160,0) "RTN","TMGSTUTL",161,0) do DebugMsg^TMGDEBUG(DBIndent,"After Processing, Text='",Text,"', and PartB='",PartB,"'") "RTN","TMGSTUTL",162,0) CSDone "RTN","TMGSTUTL",163,0) do DebugExit^TMGDEBUG(.DBIndent,"CleaveStr") "RTN","TMGSTUTL",164,0) quit "RTN","TMGSTUTL",165,0) "RTN","TMGSTUTL",166,0) "RTN","TMGSTUTL",167,0) SplitStr(Text,Width,PartB) "RTN","TMGSTUTL",168,0) ;"PUBLIC FUNCTION "RTN","TMGSTUTL",169,0) ;"Purpose: To a string into two parts. The first part will fit within 'Width' "RTN","TMGSTUTL",170,0) ;" the second part is what is left over "RTN","TMGSTUTL",171,0) ;" The split will be inteligent, so words are not divided (splits at a space) "RTN","TMGSTUTL",172,0) ;"Input: Text = input text. **Should be passed by reference "RTN","TMGSTUTL",173,0) ;" Width = the constraining width "RTN","TMGSTUTL",174,0) ;" PartB = the left over part. **Should be passed by reference "RTN","TMGSTUTL",175,0) ;"output: Text and PartB are modified "RTN","TMGSTUTL",176,0) ;"result: none. "RTN","TMGSTUTL",177,0) "RTN","TMGSTUTL",178,0) new Len "RTN","TMGSTUTL",179,0) set Width=$get(Width,80) "RTN","TMGSTUTL",180,0) new SpaceFound set SpaceFound=0 "RTN","TMGSTUTL",181,0) new SplitPoint set SplitPoint=Width "RTN","TMGSTUTL",182,0) set Text=$get(Text) "RTN","TMGSTUTL",183,0) set PartB="" "RTN","TMGSTUTL",184,0) "RTN","TMGSTUTL",185,0) set Len=$length(Text) "RTN","TMGSTUTL",186,0) if Len>Width do "RTN","TMGSTUTL",187,0) . new Ch "RTN","TMGSTUTL",188,0) . for SplitPoint=SplitPoint:-1:1 do quit:SpaceFound "RTN","TMGSTUTL",189,0) . . set Ch=$extract(Text,SplitPoint,SplitPoint) "RTN","TMGSTUTL",190,0) . . set SpaceFound=(Ch=" ") "RTN","TMGSTUTL",191,0) . if 'SpaceFound set SplitPoint=Width "RTN","TMGSTUTL",192,0) . set s1=$extract(Text,1,SplitPoint) "RTN","TMGSTUTL",193,0) . set PartB=$extract(Text,SplitPoint+1,1024) ;"max String length=1024 "RTN","TMGSTUTL",194,0) . set Text=s1 "RTN","TMGSTUTL",195,0) else do "RTN","TMGSTUTL",196,0) "RTN","TMGSTUTL",197,0) quit "RTN","TMGSTUTL",198,0) "RTN","TMGSTUTL",199,0) "RTN","TMGSTUTL",200,0) "RTN","TMGSTUTL",201,0) SetStrLen(Text,Width) "RTN","TMGSTUTL",202,0) ;"PUBLIC FUNCTION "RTN","TMGSTUTL",203,0) ;"Purpose: To make string exactly Width in length "RTN","TMGSTUTL",204,0) ;" Shorten as needed, or pad with terminal spaces as needed. "RTN","TMGSTUTL",205,0) ;"Input: Text -- should be passed as reference. This is string to alter. "RTN","TMGSTUTL",206,0) ;" Width -- the desired width "RTN","TMGSTUTL",207,0) ;"Results: none. "RTN","TMGSTUTL",208,0) "RTN","TMGSTUTL",209,0) set Text=$get(Text) "RTN","TMGSTUTL",210,0) set Width=$get(Width,80) "RTN","TMGSTUTL",211,0) new result set result=Text "RTN","TMGSTUTL",212,0) new i,Len "RTN","TMGSTUTL",213,0) "RTN","TMGSTUTL",214,0) set Len=$length(result) "RTN","TMGSTUTL",215,0) if Len>Width do "RTN","TMGSTUTL",216,0) . set result=$extract(result,1,Width) "RTN","TMGSTUTL",217,0) else if Len "ABC$$$DEF" "RTN","TMGSTUTL",304,0) ;" Substitute("ABC###DEF","###","$") --> "ABC$DEF" "RTN","TMGSTUTL",305,0) ;"Result: returns altered string (if any alterations indicated) "RTN","TMGSTUTL",306,0) ;"Output: S is altered, if passed by reference. "RTN","TMGSTUTL",307,0) "RTN","TMGSTUTL",308,0) ;"!!BUG NOTICE: "RTN","TMGSTUTL",309,0) ;" w $$Substitute("a b c "," ","\ ") --> endless loop and stack overflow "RTN","TMGSTUTL",310,0) ;"Note: Fixed by just using REPLACE^XLFSTR "RTN","TMGSTUTL",311,0) "RTN","TMGSTUTL",312,0) ;"do DebugEntry^TMGDEBUG(.DBIndent,"Substitute") "RTN","TMGSTUTL",313,0) "RTN","TMGSTUTL",314,0) new spec "RTN","TMGSTUTL",315,0) set spec($get(Match))=$get(NewValue) "RTN","TMGSTUTL",316,0) set S=$$REPLACE^XLFSTR(S,.spec) "RTN","TMGSTUTL",317,0) goto SbstDone "RTN","TMGSTUTL",318,0) "RTN","TMGSTUTL",319,0) ;"Code below not used. Delete later... "RTN","TMGSTUTL",320,0) SbstLoop "RTN","TMGSTUTL",321,0) if $data(S)#10=0 goto SbstDone "RTN","TMGSTUTL",322,0) do DebugMsg^TMGDEBUG(.DBIndent,S,"[",.Match,"=",S[Match) "RTN","TMGSTUTL",323,0) if '(S[Match) goto SbstDone "RTN","TMGSTUTL",324,0) new PartA,PartB "RTN","TMGSTUTL",325,0) set PartA=$piece(S,Match,1) "RTN","TMGSTUTL",326,0) set PartB=$piece(S,Match,2,999) "RTN","TMGSTUTL",327,0) set S=PartA_NewValue_PartB "RTN","TMGSTUTL",328,0) goto SbstLoop "RTN","TMGSTUTL",329,0) ;"End of part not used... "RTN","TMGSTUTL",330,0) "RTN","TMGSTUTL",331,0) SbstDone "RTN","TMGSTUTL",332,0) ;"do DebugExit^TMGDEBUG(.DBIndent,"Substitute") "RTN","TMGSTUTL",333,0) quit S "RTN","TMGSTUTL",334,0) "RTN","TMGSTUTL",335,0) "RTN","TMGSTUTL",336,0) "RTN","TMGSTUTL",337,0) FormatArray(InArray,OutArray,Divider) "RTN","TMGSTUTL",338,0) ;"PUBLIC FUNCTION "RTN","TMGSTUTL",339,0) ;"Purpose: The XML parser does not recognize whitespace, or end-of-line "RTN","TMGSTUTL",340,0) ;" characters. Thus many lines get lumped together. However, if there "RTN","TMGSTUTL",341,0) ;" is a significant amount of text, then the parser will put the text into "RTN","TMGSTUTL",342,0) ;" several lines (when get attrib text called etc.) "RTN","TMGSTUTL",343,0) ;" SO, this function is to take an array composed of input lines (each "RTN","TMGSTUTL",344,0) ;" with multiple sublines clumped together), and format it such that each "RTN","TMGSTUTL",345,0) ;" line is separated in the array. "RTN","TMGSTUTL",346,0) ;" e.g. Take this input array" "RTN","TMGSTUTL",347,0) ;" InArray(cText,1)="line one\nline two\nline three\n "RTN","TMGSTUTL",348,0) ;" InArray(cText,2)="line four\nline five\nline six\n "RTN","TMGSTUTL",349,0) ;" and convert to: "RTN","TMGSTUTL",350,0) ;" OutArray(1)="line one" "RTN","TMGSTUTL",351,0) ;" OutArray(2)="line two" "RTN","TMGSTUTL",352,0) ;" OutArray(3)="line three" "RTN","TMGSTUTL",353,0) ;" OutArray(4)="line four" "RTN","TMGSTUTL",354,0) ;" OutArray(5)="line five" "RTN","TMGSTUTL",355,0) ;" OutArray(6)="line six" "RTN","TMGSTUTL",356,0) ;"Input: InArray, best if passed by reference (faster) -- see example above "RTN","TMGSTUTL",357,0) ;" Note: expected to be in format: InArray(cText,n) "RTN","TMGSTUTL",358,0) ;" OutArray, must be passed by reference-- see example above "RTN","TMGSTUTL",359,0) ;" Divider: the character(s) that divides lines ("\n" in this example) "RTN","TMGSTUTL",360,0) ;"Note: It is expected that InArray will be index by integers (i.e. 1, 2, 3) "RTN","TMGSTUTL",361,0) ;" And this should be the case, as that is how XML functions pass back. "RTN","TMGSTUTL",362,0) ;" Limit of 256 separate lines on any one InArray line "RTN","TMGSTUTL",363,0) ;"Output: OutArray is set, any prior data is killed "RTN","TMGSTUTL",364,0) ;"result: 1=OK to continue, 0=abort "RTN","TMGSTUTL",365,0) "RTN","TMGSTUTL",366,0) set DEBUG=$get(DEBUG,0) "RTN","TMGSTUTL",367,0) set cOKToCont=$get(cOKToCont,1) "RTN","TMGSTUTL",368,0) set cAbort=$get(cAbort,0) "RTN","TMGSTUTL",369,0) "RTN","TMGSTUTL",370,0) if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatArray") "RTN","TMGSTUTL",371,0) "RTN","TMGSTUTL",372,0) new result set result=cOKToCont "RTN","TMGSTUTL",373,0) new InIndex "RTN","TMGSTUTL",374,0) new OutIndex set OutIndex=1 "RTN","TMGSTUTL",375,0) new TempArray "RTN","TMGSTUTL",376,0) new Done "RTN","TMGSTUTL",377,0) "RTN","TMGSTUTL",378,0) kill OutArray ;"remove any prior data "RTN","TMGSTUTL",379,0) "RTN","TMGSTUTL",380,0) if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Input array:") "RTN","TMGSTUTL",381,0) if DEBUG do ArrayDump^TMGDEBUG("InArray") "RTN","TMGSTUTL",382,0) "RTN","TMGSTUTL",383,0) if $data(Divider)=0 do goto FADone "RTN","TMGSTUTL",384,0) . set result=cAbort "RTN","TMGSTUTL",385,0) "RTN","TMGSTUTL",386,0) set Done=0 "RTN","TMGSTUTL",387,0) for InIndex=1:1 do quit:Done "RTN","TMGSTUTL",388,0) . if $data(InArray(cText,InIndex))=0 set Done=1 quit "RTN","TMGSTUTL",389,0) . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Converting line: ",InArray(cText,InIndex)) "RTN","TMGSTUTL",390,0) . do CleaveToArray^TMGSTUTL(InArray(cText,InIndex),Divider,.TempArray,OutIndex) "RTN","TMGSTUTL",391,0) . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Resulting temp array:") "RTN","TMGSTUTL",392,0) . if DEBUG do ArrayDump^TMGDEBUG("TempArray") "RTN","TMGSTUTL",393,0) . set OutIndex=TempArray(cMaxNode)+1 "RTN","TMGSTUTL",394,0) . kill TempArray(cMaxNode) "RTN","TMGSTUTL",395,0) . merge OutArray=TempArray "RTN","TMGSTUTL",396,0) . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"OutArray so far:") "RTN","TMGSTUTL",397,0) . if DEBUG do ArrayDump^TMGDEBUG("OutArray") "RTN","TMGSTUTL",398,0) "RTN","TMGSTUTL",399,0) FADone "RTN","TMGSTUTL",400,0) if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatArray") "RTN","TMGSTUTL",401,0) quit result "RTN","TMGSTUTL",402,0) "RTN","TMGSTUTL",403,0) "RTN","TMGSTUTL",404,0) "RTN","TMGSTUTL",405,0) TrimL(S,TrimCh) "RTN","TMGSTUTL",406,0) ;"Purpose: To a trip a string of leading white space "RTN","TMGSTUTL",407,0) ;" i.e. convert " hello" into "hello" "RTN","TMGSTUTL",408,0) ;"Input: S -- the string to convert. Won't be changed if passed by reference "RTN","TMGSTUTL",409,0) ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " "RTN","TMGSTUTL",410,0) ;"Results: returns modified string "RTN","TMGSTUTL",411,0) ;"Note: processing limitation is string length=1024 "RTN","TMGSTUTL",412,0) "RTN","TMGSTUTL",413,0) set DEBUG=$get(DEBUG,0) "RTN","TMGSTUTL",414,0) set cOKToCont=$get(cOKToCont,1) "RTN","TMGSTUTL",415,0) set cAbort=$get(cAbort,0) "RTN","TMGSTUTL",416,0) set TrimCh=$get(TrimCh," ") "RTN","TMGSTUTL",417,0) "RTN","TMGSTUTL",418,0) new result set result=$get(S) "RTN","TMGSTUTL",419,0) new Ch set Ch="" "RTN","TMGSTUTL",420,0) "RTN","TMGSTUTL",421,0) for do quit:(Ch'=TrimCh) "RTN","TMGSTUTL",422,0) . set Ch=$extract(result,1,1) "RTN","TMGSTUTL",423,0) . if Ch=TrimCh set result=$extract(result,2,1024) "RTN","TMGSTUTL",424,0) "RTN","TMGSTUTL",425,0) quit result "RTN","TMGSTUTL",426,0) "RTN","TMGSTUTL",427,0) "RTN","TMGSTUTL",428,0) TrimR(S,TrimCh) "RTN","TMGSTUTL",429,0) ;"Purpose: To a trip a string of trailing white space "RTN","TMGSTUTL",430,0) ;" i.e. convert "hello " into "hello" "RTN","TMGSTUTL",431,0) ;"Input: S -- the string to convert. Won't be changed if passed by reference "RTN","TMGSTUTL",432,0) ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " "RTN","TMGSTUTL",433,0) ;"Results: returns modified string "RTN","TMGSTUTL",434,0) ;"Note: processing limitation is string length=1024 "RTN","TMGSTUTL",435,0) "RTN","TMGSTUTL",436,0) set DEBUG=$get(DEBUG,0) "RTN","TMGSTUTL",437,0) set cOKToCont=$get(cOKToCont,1) "RTN","TMGSTUTL",438,0) set cAbort=$get(cAbort,0) "RTN","TMGSTUTL",439,0) set TrimCh=$get(TrimCh," ") "RTN","TMGSTUTL",440,0) "RTN","TMGSTUTL",441,0) if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"TrimR") "RTN","TMGSTUTL",442,0) "RTN","TMGSTUTL",443,0) new result set result=$get(S) "RTN","TMGSTUTL",444,0) new Ch set Ch="" "RTN","TMGSTUTL",445,0) new L "RTN","TMGSTUTL",446,0) "RTN","TMGSTUTL",447,0) for do quit:(Ch'=TrimCh) "RTN","TMGSTUTL",448,0) . set L=$length(result) "RTN","TMGSTUTL",449,0) . set Ch=$extract(result,L,L) "RTN","TMGSTUTL",450,0) . if Ch=TrimCh do "RTN","TMGSTUTL",451,0) . . set result=$extract(result,1,L-1) "RTN","TMGSTUTL",452,0) "RTN","TMGSTUTL",453,0) if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"TrimR") "RTN","TMGSTUTL",454,0) quit result "RTN","TMGSTUTL",455,0) "RTN","TMGSTUTL",456,0) Trim(S,TrimCh) "RTN","TMGSTUTL",457,0) ;"Purpose: To a trip a string of leading and trailing white space "RTN","TMGSTUTL",458,0) ;" i.e. convert " hello " into "hello" "RTN","TMGSTUTL",459,0) ;"Input: S -- the string to convert. Won't be changed if passed by reference "RTN","TMGSTUTL",460,0) ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " "RTN","TMGSTUTL",461,0) ;"Results: returns modified string "RTN","TMGSTUTL",462,0) ;"Note: processing limitation is string length=1024 "RTN","TMGSTUTL",463,0) "RTN","TMGSTUTL",464,0) ;"NOTE: this function could be replaced with $$TRIM^XLFSTR "RTN","TMGSTUTL",465,0) "RTN","TMGSTUTL",466,0) set DEBUG=$get(DEBUG,0) "RTN","TMGSTUTL",467,0) set cOKToCont=$get(cOKToCont,1) "RTN","TMGSTUTL",468,0) set cAbort=$get(cAbort,0) "RTN","TMGSTUTL",469,0) set TrimCh=$get(TrimCh," ") "RTN","TMGSTUTL",470,0) "RTN","TMGSTUTL",471,0) if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"Trim") "RTN","TMGSTUTL",472,0) "RTN","TMGSTUTL",473,0) new result set result=$get(S) "RTN","TMGSTUTL",474,0) set result=$$TrimL(.result,TrimCh) "RTN","TMGSTUTL",475,0) set result=$$TrimR(.result,TrimCh) "RTN","TMGSTUTL",476,0) "RTN","TMGSTUTL",477,0) if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"Trim") "RTN","TMGSTUTL",478,0) quit result "RTN","TMGSTUTL",479,0) "RTN","TMGSTUTL",480,0) "RTN","TMGSTUTL",481,0) NumLWS(S) "RTN","TMGSTUTL",482,0) ;"Scopt: PUBLIC FUNCTION "RTN","TMGSTUTL",483,0) ;":Purpose: To count the number of white space characters on the left "RTN","TMGSTUTL",484,0) ;" side of the string "RTN","TMGSTUTL",485,0) "RTN","TMGSTUTL",486,0) new result set result=0 "RTN","TMGSTUTL",487,0) new i,ch "RTN","TMGSTUTL",488,0) set S=$get(S) "RTN","TMGSTUTL",489,0) "RTN","TMGSTUTL",490,0) for i=1:1:$length(S) do quit:(ch'=" ") "RTN","TMGSTUTL",491,0) . set ch=$extract(S,i,i) "RTN","TMGSTUTL",492,0) . if ch=" " set result=result+1 "RTN","TMGSTUTL",493,0) "RTN","TMGSTUTL",494,0) quit result "RTN","TMGSTUTL",495,0) "RTN","TMGSTUTL",496,0) "RTN","TMGSTUTL",497,0) MakeWS(n) "RTN","TMGSTUTL",498,0) ;"Scope: PUBLIC FUNCTION "RTN","TMGSTUTL",499,0) ;"Purpose: Return a whitespace string that is n characters long "RTN","TMGSTUTL",500,0) "RTN","TMGSTUTL",501,0) new result set result="" "RTN","TMGSTUTL",502,0) set n=$get(n,0) "RTN","TMGSTUTL",503,0) if n'>0 goto MWSDone "RTN","TMGSTUTL",504,0) "RTN","TMGSTUTL",505,0) new i "RTN","TMGSTUTL",506,0) for i=1:1:n set result=result_" " "RTN","TMGSTUTL",507,0) "RTN","TMGSTUTL",508,0) MWSDone "RTN","TMGSTUTL",509,0) quit result "RTN","TMGSTUTL",510,0) "RTN","TMGSTUTL",511,0) "RTN","TMGSTUTL",512,0) WordWrapArray(Array,Width,SpecialIndent) "RTN","TMGSTUTL",513,0) ;"Scope: PUBLIC FUNCTION "RTN","TMGSTUTL",514,0) ;"Purpose: To take an array and perform word wrapping such that "RTN","TMGSTUTL",515,0) ;" no line is longer than Width. "RTN","TMGSTUTL",516,0) ;" This function is really designed for reformatting a Fileman WP field "RTN","TMGSTUTL",517,0) ;"Input: Array MUST BE PASSED BY REFERENCE. This contains the array "RTN","TMGSTUTL",518,0) ;" to be reformatted. Changes will be made to this array. "RTN","TMGSTUTL",519,0) ;" It is expected that Array will be in this format: "RTN","TMGSTUTL",520,0) ;" Array(1)="Some text on the first line." "RTN","TMGSTUTL",521,0) ;" Array(2)="Some text on the second line." "RTN","TMGSTUTL",522,0) ;" Array(3)="Some text on the third line." "RTN","TMGSTUTL",523,0) ;" Array(4)="Some text on the fourth line." "RTN","TMGSTUTL",524,0) ;" or "RTN","TMGSTUTL",525,0) ;" Array(1,0)="Some text on the first line." "RTN","TMGSTUTL",526,0) ;" Array(2,0)="Some text on the second line." "RTN","TMGSTUTL",527,0) ;" Array(3,0)="Some text on the third line." "RTN","TMGSTUTL",528,0) ;" Array(4,0)="Some text on the fourth line." "RTN","TMGSTUTL",529,0) ;" Width -- the limit on the length of any line. Default value=70 "RTN","TMGSTUTL",530,0) ;" SpecialIndent : if 1, then wrapping is done like this: "RTN","TMGSTUTL",531,0) ;" " This is a very long line......" "RTN","TMGSTUTL",532,0) ;" will be wrapped like this: "RTN","TMGSTUTL",533,0) ;" " This is a very "RTN","TMGSTUTL",534,0) ;" " long line ... "RTN","TMGSTUTL",535,0) ;" Notice that the leading space is copied subsequent line. "RTN","TMGSTUTL",536,0) ;" Also, a line like this: "RTN","TMGSTUTL",537,0) ;" " 1. Here is the beginning of a paragraph that is very long..." "RTN","TMGSTUTL",538,0) ;" will be wrapped like this: "RTN","TMGSTUTL",539,0) ;" " 1. Here is the beginning of a paragraph "RTN","TMGSTUTL",540,0) ;" " that is very long..." "RTN","TMGSTUTL",541,0) ;" Notice that a pattern '#. ' causes the wrapping to match the start of "RTN","TMGSTUTL",542,0) ;" of the text on the line above. "RTN","TMGSTUTL",543,0) ;" The exact rules for matching this are as follows: "RTN","TMGSTUTL",544,0) ;" (FirstWord?.N1".")!(FirstWord?1.3E1".") "RTN","TMGSTUTL",545,0) ;" i.e. any number of digits, followed by "." "RTN","TMGSTUTL",546,0) ;" OR 1-4 all upper-case characters followed by a "." "RTN","TMGSTUTL",547,0) ;" This will allow "VIII. " pattern but not "viii. " "RTN","TMGSTUTL",548,0) ;" HOWEVER, might get confused with a word, like "NOTE. " "RTN","TMGSTUTL",549,0) ;" "RTN","TMGSTUTL",550,0) ;" This, below, is not dependant on SpecialIndent setting "RTN","TMGSTUTL",551,0) ;" Also, because some of the lines have already partly wrapped, like this: "RTN","TMGSTUTL",552,0) ;" " 1. Here is the beginning of a paragraph that is very long..." "RTN","TMGSTUTL",553,0) ;" "and this is a line that has already wrapped. "RTN","TMGSTUTL",554,0) ;" So when the first line is wrapped, it would look like this: "RTN","TMGSTUTL",555,0) ;" " 1. Here is the beginning of a paragraph "RTN","TMGSTUTL",556,0) ;" " that is very long..." "RTN","TMGSTUTL",557,0) ;" "and this is a line that has already wrapped. "RTN","TMGSTUTL",558,0) ;" But is should look like this: "RTN","TMGSTUTL",559,0) ;" " 1. Here is the beginning of a paragraph "RTN","TMGSTUTL",560,0) ;" " that is very long...and this is a line "RTN","TMGSTUTL",561,0) ;" " that has already wrapped. "RTN","TMGSTUTL",562,0) ;" But the next line SHOULD NOT be pulled up if it is the start "RTN","TMGSTUTL",563,0) ;" of a new paragraph. I will tell by looking for #. paattern. "RTN","TMGSTUTL",564,0) "RTN","TMGSTUTL",565,0) "RTN","TMGSTUTL",566,0) ;"Result -- none "RTN","TMGSTUTL",567,0) "RTN","TMGSTUTL",568,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WordWrapArray^TMGSTUTL") "RTN","TMGSTUTL",569,0) new tempArray set tempArray="" ;"holds result during work. "RTN","TMGSTUTL",570,0) new tindex set tindex=0 "RTN","TMGSTUTL",571,0) new index "RTN","TMGSTUTL",572,0) set index=$order(Array("")) "RTN","TMGSTUTL",573,0) new s "RTN","TMGSTUTL",574,0) new residualS set residualS="" "RTN","TMGSTUTL",575,0) new AddZero set AddZero=0 "RTN","TMGSTUTL",576,0) set Width=$get(Width,70) "RTN","TMGSTUTL",577,0) "RTN","TMGSTUTL",578,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop") "RTN","TMGSTUTL",579,0) "RTN","TMGSTUTL",580,0) if index'="" for do quit:((index="")&(residualS="")) "RTN","TMGSTUTL",581,0) . set s=$get(Array(index)) "RTN","TMGSTUTL",582,0) . if s="" do "RTN","TMGSTUTL",583,0) . . set s=$get(Array(index,0)) "RTN","TMGSTUTL",584,0) . . set AddZero=1 "RTN","TMGSTUTL",585,0) . if residualS'="" do ;"See if should join to next line. Don't if '#. ' pattern "RTN","TMGSTUTL",586,0) . . new FirstWord set FirstWord=$piece($$Trim(s)," ",1) "RTN","TMGSTUTL",587,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"First Word: ",FirstWord) "RTN","TMGSTUTL",588,0) . . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern "RTN","TMGSTUTL",589,0) . . . ;"Here we have the next line is a new paragraph, so don't link to residualS "RTN","TMGSTUTL",590,0) . . . set tindex=tindex+1 "RTN","TMGSTUTL",591,0) . . . if AddZero=0 set tempArray(tindex)=residualS "RTN","TMGSTUTL",592,0) . . . else set tempArray(tindex,0)=residualS "RTN","TMGSTUTL",593,0) . . . set residualS="" "RTN","TMGSTUTL",594,0) . if $length(residualS)+$length(s)'<256 do "RTN","TMGSTUTL",595,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ERROR -- string too long.") "RTN","TMGSTUTL",596,0) . set s=residualS_s "RTN","TMGSTUTL",597,0) . set residualS="" "RTN","TMGSTUTL",598,0) . if $length(s)>Width do "RTN","TMGSTUTL",599,0) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Long line: ",s) "RTN","TMGSTUTL",600,0) . . new LineArray "RTN","TMGSTUTL",601,0) . . new NumLines "RTN","TMGSTUTL",602,0) . . set NumLines=$$SplitLine(.s,.LineArray,Width,.SpecialIndent) "RTN","TMGSTUTL",603,0) . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("LineArray") "RTN","TMGSTUTL",604,0) . . set s="" "RTN","TMGSTUTL",605,0) . . new LineIndex "RTN","TMGSTUTL",606,0) . . for LineIndex=1:1:NumLines do "RTN","TMGSTUTL",607,0) . . . set tindex=tindex+1 "RTN","TMGSTUTL",608,0) . . . if AddZero=0 set tempArray(tindex)=LineArray(LineIndex) "RTN","TMGSTUTL",609,0) . . . else set tempArray(tindex,0)=LineArray(LineIndex) "RTN","TMGSTUTL",610,0) . . ;"long wrap probably continues into next paragraph, so link together. "RTN","TMGSTUTL",611,0) . . if NumLines>2 do "RTN","TMGSTUTL",612,0) . . . if AddZero=0 set residualS=tempArray(tindex) set tempArray(tindex)="" "RTN","TMGSTUTL",613,0) . . . else set residualS=tempArray(tindex,0) set tempArray(tindex,0)="" "RTN","TMGSTUTL",614,0) . . . set tindex=tindex-1 "RTN","TMGSTUTL",615,0) . else do "RTN","TMGSTUTL",616,0) . . set tindex=tindex+1 "RTN","TMGSTUTL",617,0) . . if AddZero=0 set tempArray(tindex)=s "RTN","TMGSTUTL",618,0) . . else set tempArray(tindex,0)=s "RTN","TMGSTUTL",619,0) . set index=$order(Array(index)) "RTN","TMGSTUTL",620,0) else do "RTN","TMGSTUTL",621,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Array appears empty") "RTN","TMGSTUTL",622,0) "RTN","TMGSTUTL",623,0) "RTN","TMGSTUTL",624,0) kill Array "RTN","TMGSTUTL",625,0) merge Array=tempArray "RTN","TMGSTUTL",626,0) "RTN","TMGSTUTL",627,0) if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array") "RTN","TMGSTUTL",628,0) "RTN","TMGSTUTL",629,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent," WordWrapArray^TMGSTUTL") "RTN","TMGSTUTL",630,0) quit "RTN","TMGSTUTL",631,0) "RTN","TMGSTUTL",632,0) "RTN","TMGSTUTL",633,0) SplitLine(s,LineArray,Width,SpecialIndent,Indent) "RTN","TMGSTUTL",634,0) ;"Scope: PUBLIC FUNCTION "RTN","TMGSTUTL",635,0) ;"Purpose: To take a long line, and wrap into an array, such that each "RTN","TMGSTUTL",636,0) ;" line is not longer than Width. "RTN","TMGSTUTL",637,0) ;" Line breaks will be made at spaces, unless there are no spaces in "RTN","TMGSTUTL",638,0) ;" the entire line (in which case, the line will be divided at Width). "RTN","TMGSTUTL",639,0) ;"Input: s= string with the long line. **If passed by reference**, then "RTN","TMGSTUTL",640,0) ;" it WILL BE CHANGED to equal the last line of array. "RTN","TMGSTUTL",641,0) ;" LineArray -- MUST BE PASSED BY REFERENCE. This OUT variable will "RTN","TMGSTUTL",642,0) ;" receive the resulting array. "RTN","TMGSTUTL",643,0) ;" Width = the desired wrap width. "RTN","TMGSTUTL",644,0) ;" SpecialIndent [OPTIONAL]: if 1, then wrapping is done like this: "RTN","TMGSTUTL",645,0) ;" " This is a very long line......" "RTN","TMGSTUTL",646,0) ;" will be wrapped like this: "RTN","TMGSTUTL",647,0) ;" " This is a very "RTN","TMGSTUTL",648,0) ;" " long line ... "RTN","TMGSTUTL",649,0) ;" Notice that the leading space is copied subsequent line. "RTN","TMGSTUTL",650,0) ;" Also, a line like this: "RTN","TMGSTUTL",651,0) ;" " 1. Here is the beginning of a paragraph that is very long..." "RTN","TMGSTUTL",652,0) ;" will be wrapped like this: "RTN","TMGSTUTL",653,0) ;" " 1. Here is the beginning of a paragraph "RTN","TMGSTUTL",654,0) ;" " that is very long..." "RTN","TMGSTUTL",655,0) ;" Notice that a pattern '#. ' causes the wrapping to match the start "RTN","TMGSTUTL",656,0) ;" of the text on the line above. "RTN","TMGSTUTL",657,0) ;" Indent [OPTIONAL]: Any absolute amount that all lines should be indented by. "RTN","TMGSTUTL",658,0) ;" This could be used if this long line is continuation of an "RTN","TMGSTUTL",659,0) ;" indentation above it. "RTN","TMGSTUTL",660,0) ;"Result: resulting number of lines (1 if no wrap needed). "RTN","TMGSTUTL",661,0) "RTN","TMGSTUTL",662,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SplitLine") "RTN","TMGSTUTL",663,0) "RTN","TMGSTUTL",664,0) new result set result=0 "RTN","TMGSTUTL",665,0) kill LineArray "RTN","TMGSTUTL",666,0) if ($get(s)="")!($get(Width)'>0) goto SPDone "RTN","TMGSTUTL",667,0) new index set index=0 "RTN","TMGSTUTL",668,0) new p,tempS,splitPoint "RTN","TMGSTUTL",669,0) "RTN","TMGSTUTL",670,0) new PreSpace set PreSpace=$$NeededWS(s,.SpecialIndent,.Indent) "RTN","TMGSTUTL",671,0) "RTN","TMGSTUTL",672,0) if ($length(s)>Width) for do quit:($length(s)'>Width) "RTN","TMGSTUTL",673,0) . for splitPoint=1:1:Width do quit:($length(tempS)>Width) "RTN","TMGSTUTL",674,0) . . set tempS=$piece(s," ",1,splitPoint) "RTN","TMGSTUTL",675,0) . . ;"write "tempS>",tempS,! "RTN","TMGSTUTL",676,0) . if splitPoint>1 do "RTN","TMGSTUTL",677,0) . . set tempS=$piece(s," ",1,splitPoint-1) "RTN","TMGSTUTL",678,0) . . set s=$piece(s," ",splitPoint,Width) "RTN","TMGSTUTL",679,0) . else do "RTN","TMGSTUTL",680,0) . . ;"We must have a word > Width with no spaces--so just divide "RTN","TMGSTUTL",681,0) . . set tempS=$extract(s,1,Width) "RTN","TMGSTUTL",682,0) . . set s=$extract(s,Width+1,999) "RTN","TMGSTUTL",683,0) . set index=index+1 "RTN","TMGSTUTL",684,0) . set LineArray(index)=tempS "RTN","TMGSTUTL",685,0) . set s=PreSpace_s "RTN","TMGSTUTL",686,0) . ;"write "tempS>",tempS,! "RTN","TMGSTUTL",687,0) . ;"write "s>",s,! "RTN","TMGSTUTL",688,0) "RTN","TMGSTUTL",689,0) set index=index+1 "RTN","TMGSTUTL",690,0) set LineArray(index)=s "RTN","TMGSTUTL",691,0) "RTN","TMGSTUTL",692,0) set result=index "RTN","TMGSTUTL",693,0) "RTN","TMGSTUTL",694,0) SPDone "RTN","TMGSTUTL",695,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SplitLine") "RTN","TMGSTUTL",696,0) quit result "RTN","TMGSTUTL",697,0) "RTN","TMGSTUTL",698,0) "RTN","TMGSTUTL",699,0) "RTN","TMGSTUTL",700,0) NeededWS(S,SpecialIndent,Indent) "RTN","TMGSTUTL",701,0) ;"Scope: PRIVATE "RTN","TMGSTUTL",702,0) ;"Purpose: Evaluate the line, and create the white space string "RTN","TMGSTUTL",703,0) ;" need for wrapped lines "RTN","TMGSTUTL",704,0) ;"Input: s -- the string to eval. i.e. "RTN","TMGSTUTL",705,0) ;" " John is very happy today ... .. .. .. .." "RTN","TMGSTUTL",706,0) ;" or " 1. John is very happy today ... .. .. .. .." "RTN","TMGSTUTL",707,0) ;" SpecialIndent -- See SplitLine() discussion "RTN","TMGSTUTL",708,0) ;" Indent -- See SplitLine() discussion "RTN","TMGSTUTL",709,0) "RTN","TMGSTUTL",710,0) new result set result="" "RTN","TMGSTUTL",711,0) if $get(S)="" goto NdWSDone "RTN","TMGSTUTL",712,0) "RTN","TMGSTUTL",713,0) new WSNum "RTN","TMGSTUTL",714,0) set WSNum=+$get(Indent,0) "RTN","TMGSTUTL",715,0) set WSNum=WSNum+$$NumLWS(S) "RTN","TMGSTUTL",716,0) "RTN","TMGSTUTL",717,0) if $get(SpecialIndent)=1 do "RTN","TMGSTUTL",718,0) . new ts,FirstWord "RTN","TMGSTUTL",719,0) . set ts=$$TrimL(.S) "RTN","TMGSTUTL",720,0) . set FirstWord=$piece(ts," ",1) "RTN","TMGSTUTL",721,0) . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern "RTN","TMGSTUTL",722,0) . . set WSNum=WSNum+$length(FirstWord) "RTN","TMGSTUTL",723,0) . . set ts=$piece(ts," ",2,9999) "RTN","TMGSTUTL",724,0) . . set WSNum=WSNum+$$NumLWS(.ts)+1 "RTN","TMGSTUTL",725,0) "RTN","TMGSTUTL",726,0) set result=$$MakeWS(WSNum) "RTN","TMGSTUTL",727,0) "RTN","TMGSTUTL",728,0) NdWSDone "RTN","TMGSTUTL",729,0) quit result "RTN","TMGSTUTL",730,0) "RTN","TMGSTUTL",731,0) "RTN","TMGSTUTL",732,0) WriteWP(NodeRef) "RTN","TMGSTUTL",733,0) ;"Purpose: Given a reference to a WP field, this function will print it out. "RTN","TMGSTUTL",734,0) ;"INput: NodeRef -- the name of the node to print out. "RTN","TMGSTUTL",735,0) ;" For example, "^PS(50.605,1,1)" "RTN","TMGSTUTL",736,0) ;"Modification: 2/10/06 -- I removed need for @NodeRef@(0) to contain data. "RTN","TMGSTUTL",737,0) "RTN","TMGSTUTL",738,0) new i "RTN","TMGSTUTL",739,0) ;"if $get(@NodeRef@(0))="" goto WWPDone "RTN","TMGSTUTL",740,0) set i=$order(@NodeRef@(0)) "RTN","TMGSTUTL",741,0) if i'="" for do quit:(i="") "RTN","TMGSTUTL",742,0) . new OneLine "RTN","TMGSTUTL",743,0) . set OneLine=$get(@NodeRef@(i)) "RTN","TMGSTUTL",744,0) . if OneLine="" set OneLine=$get(@NodeRef@(i,0)) "RTN","TMGSTUTL",745,0) . write OneLine,! "RTN","TMGSTUTL",746,0) . set i=$order(@NodeRef@(i)) "RTN","TMGSTUTL",747,0) "RTN","TMGSTUTL",748,0) WWPDone quit "RTN","TMGSTUTL",749,0) "RTN","TMGSTUTL",750,0) "RTN","TMGSTUTL",751,0) LPad(S,width) "RTN","TMGSTUTL",752,0) ;"Purpose: To add space ("pad") string S such that final width is per specified with. "RTN","TMGSTUTL",753,0) ;" space is added to left side of string "RTN","TMGSTUTL",754,0) ;"Input: S : the string to pad. "RTN","TMGSTUTL",755,0) ;" width : the desired final width "RTN","TMGSTUTL",756,0) ;"result: returns resulting string "RTN","TMGSTUTL",757,0) ;"Example: LPad("$5.23",7)=" $5.23" "RTN","TMGSTUTL",758,0) "RTN","TMGSTUTL",759,0) quit $$RJ^XLFSTR(.S,.width," ") "RTN","TMGSTUTL",760,0) "RTN","TMGSTUTL",761,0) RPad(S,width) "RTN","TMGSTUTL",762,0) ;"Purpose: To add space ("pad") string S such that final width is per specified with. "RTN","TMGSTUTL",763,0) ;" space is added to right side of string "RTN","TMGSTUTL",764,0) ;"Input: S : the string to pad. "RTN","TMGSTUTL",765,0) ;" width : the desired final width "RTN","TMGSTUTL",766,0) ;"result: returns resulting string "RTN","TMGSTUTL",767,0) ;"Example: RPad("$5.23",7)="$5.23 " "RTN","TMGSTUTL",768,0) "RTN","TMGSTUTL",769,0) quit $$LJ^XLFSTR(.S,.width," ") "RTN","TMGSTUTL",770,0) "RTN","TMGSTUTL",771,0) Center(S,width) "RTN","TMGSTUTL",772,0) ;"Purpose: to return a center justified string "RTN","TMGSTUTL",773,0) "RTN","TMGSTUTL",774,0) quit $$CJ^XLFSTR(.S,.width," ") "RTN","TMGSTUTL",775,0) "RTN","TMGSTUTL",776,0) Clip(S,width) "RTN","TMGSTUTL",777,0) ;"Purpose: to ensure that string S is no longer than width "RTN","TMGSTUTL",778,0) "RTN","TMGSTUTL",779,0) new result set result=$get(S) "RTN","TMGSTUTL",780,0) if result'="" set result=$extract(S,1,width) "RTN","TMGSTUTL",781,0) ClipDone "RTN","TMGSTUTL",782,0) quit result "RTN","TMGSTUTL",783,0) "RTN","TMGSTUTL",784,0) "RTN","TMGSTUTL",785,0) STRB2H(s,F,noSpace) "RTN","TMGSTUTL",786,0) ;"Convert a string to hex characters) "RTN","TMGSTUTL",787,0) ;"Input: s -- the input string (need not be ascii characters) "RTN","TMGSTUTL",788,0) ;" F -- (optional) if F>0 then will append an ascii display of string. "RTN","TMGSTUTL",789,0) ;" noSpace -- (Optional) if >0 then characters NOT separated by spaces "RTN","TMGSTUTL",790,0) ;"result -- the converted string "RTN","TMGSTUTL",791,0) "RTN","TMGSTUTL",792,0) new i,ch "RTN","TMGSTUTL",793,0) new result set result="" "RTN","TMGSTUTL",794,0) "RTN","TMGSTUTL",795,0) for i=1:1:$length(s) do "RTN","TMGSTUTL",796,0) . set ch=$extract(s,i) "RTN","TMGSTUTL",797,0) . set result=result_$$HEXCHR^TMGMISC($ascii(ch)) "RTN","TMGSTUTL",798,0) . if +$get(noSpace)=0 set result=result_" " "RTN","TMGSTUTL",799,0) "RTN","TMGSTUTL",800,0) if $get(F)>0 set result=result_" "_$$HIDECTRLS^TMGSTUTL(s) "RTN","TMGSTUTL",801,0) quit result "RTN","TMGSTUTL",802,0) "RTN","TMGSTUTL",803,0) "RTN","TMGSTUTL",804,0) HIDECTRLS(s) "RTN","TMGSTUTL",805,0) ;"hide all unprintable characters from a string "RTN","TMGSTUTL",806,0) new i,ch,byte "RTN","TMGSTUTL",807,0) new result set result="" "RTN","TMGSTUTL",808,0) for i=1:1:$length(s) do "RTN","TMGSTUTL",809,0) . set ch=$e(s,i) "RTN","TMGSTUTL",810,0) . set byte=$ascii(ch) "RTN","TMGSTUTL",811,0) . if (byte<32)!(byte>122) set result=result_"." "RTN","TMGSTUTL",812,0) . else set result=result_ch "RTN","TMGSTUTL",813,0) "RTN","TMGSTUTL",814,0) quit result "RTN","TMGSTUTL",815,0) "RTN","TMGSTUTL",816,0) "RTN","TMGSTUTL",817,0) "RTN","TMGSTUTL",818,0) CapWords(S,Divider) "RTN","TMGSTUTL",819,0) ;"Purpose: convert each word in the string: 'test string' --> 'Test String', 'TEST STRING' --> 'Test String' "RTN","TMGSTUTL",820,0) "RTN","TMGSTUTL",821,0) ;"Input: S -- the string to convert "RTN","TMGSTUTL",822,0) ;" Divider -- [OPTIONAL] the character used to separate string (default is ' ' [space]) "RTN","TMGSTUTL",823,0) ;"Result: returns the converted string "RTN","TMGSTUTL",824,0) "RTN","TMGSTUTL",825,0) new s2,part "RTN","TMGSTUTL",826,0) new result set result="" "RTN","TMGSTUTL",827,0) set Divider=$get(Divider," ") "RTN","TMGSTUTL",828,0) "RTN","TMGSTUTL",829,0) set s2=$$LOW^XLFSTR(S) "RTN","TMGSTUTL",830,0) "RTN","TMGSTUTL",831,0) for i=1:1 do quit:part="" "RTN","TMGSTUTL",832,0) . set part=$piece(s2,Divider,i) "RTN","TMGSTUTL",833,0) . if part="" quit "RTN","TMGSTUTL",834,0) . set $extract(part,1)=$$UP^XLFSTR($extract(part,1)) "RTN","TMGSTUTL",835,0) . if result'="" set result=result_Divider "RTN","TMGSTUTL",836,0) . set result=result_part "RTN","TMGSTUTL",837,0) "RTN","TMGSTUTL",838,0) quit result "RTN","TMGSTUTL",839,0) "RTN","TMGSTUTL",840,0) "RTN","TMGSTUTL",841,0) LinuxStr(S) "RTN","TMGSTUTL",842,0) ;"Purpose: convert string to a valid linux filename "RTN","TMGSTUTL",843,0) ;" e.g. 'File Name' --> 'File\ Name' "RTN","TMGSTUTL",844,0) "RTN","TMGSTUTL",845,0) quit $$Substitute(.S," ","\ ") "RTN","TMGSTUTL",846,0) "RTN","TMGSTUTL",847,0) "RTN","TMGSTUTL",848,0) "RTN","TMGSTUTL",849,0) NiceSplit(S,Len,s1,s2,s2Min,DivCh) "RTN","TMGSTUTL",850,0) ;"Purpose: to split S into two strings, s1 & s2 "RTN","TMGSTUTL",851,0) ;" Furthermore, s1's length must be <= length. "RTN","TMGSTUTL",852,0) ;" and the split will be made at spaces "RTN","TMGSTUTL",853,0) ;"Input: S -- the string to split "RTN","TMGSTUTL",854,0) ;" Len -- the length limit of s1 "RTN","TMGSTUTL",855,0) ;" s1 -- PASS BY REFERENCE, an OUT parameter "RTN","TMGSTUTL",856,0) ;" receives first part of split "RTN","TMGSTUTL",857,0) ;" s2 -- PASS BY REFERENCE, an OUT parameter "RTN","TMGSTUTL",858,0) ;" receives the rest of string "RTN","TMGSTUTL",859,0) ;" s2Min -- OPTIONAL -- the minimum that "RTN","TMGSTUTL",860,0) ;" length of s2 can be. Note, if s2 "RTN","TMGSTUTL",861,0) ;" is "", then this is not applied "RTN","TMGSTUTL",862,0) ;" DivCH -- OPTIONAL, default is " ". "RTN","TMGSTUTL",863,0) ;" This is the character to split words by "RTN","TMGSTUTL",864,0) ;"Output: s1 and s2 is filled with data "RTN","TMGSTUTL",865,0) ;"Result: none "RTN","TMGSTUTL",866,0) "RTN","TMGSTUTL",867,0) set (s1,s2)="" "RTN","TMGSTUTL",868,0) if $get(DivCh)="" set DivCh=" " "RTN","TMGSTUTL",869,0) "RTN","TMGSTUTL",870,0) if $length(S)'>Len do goto NSpDone "RTN","TMGSTUTL",871,0) . set s1=S "RTN","TMGSTUTL",872,0) "RTN","TMGSTUTL",873,0) new i "RTN","TMGSTUTL",874,0) new done "RTN","TMGSTUTL",875,0) for i=200:-1:1 do quit:(done) "RTN","TMGSTUTL",876,0) . set s1=$piece(S,DivCh,1,i)_DivCh "RTN","TMGSTUTL",877,0) . set s2=$piece(S,DivCh,i+1,999) "RTN","TMGSTUTL",878,0) . set done=($length(s1)'>Len) "RTN","TMGSTUTL",879,0) . if done,+$get(s2Min)>0 do "RTN","TMGSTUTL",880,0) . . if s2="" quit "RTN","TMGSTUTL",881,0) . . set done=($length(s2)'0) "RTN","TMGSTUTL",941,0) . set OneLine=$get(@pArray@(i)) "RTN","TMGSTUTL",942,0) . if OneLine="" set OneLine=$get(@pArray@(i,0)) "RTN","TMGSTUTL",943,0) . if OneLine="" quit "RTN","TMGSTUTL",944,0) . set Len=$length(result)+$length(DivCh) "RTN","TMGSTUTL",945,0) . if Len+$length(OneLine)>MaxLen do "RTN","TMGSTUTL",946,0) . . set OneLine=$extract(OneLine,1,(MaxLen-Len)) "RTN","TMGSTUTL",947,0) . set result=result_OneLine_DivCh "RTN","TMGSTUTL",948,0) . set Len=Len+$length(OneLine) "RTN","TMGSTUTL",949,0) . set i=$order(@pArray@(i)) "RTN","TMGSTUTL",950,0) "RTN","TMGSTUTL",951,0) quit result; "RTN","TMGSTUTL",952,0) "RTN","TMGSTUTL",953,0) "RTN","TMGSTUTL",954,0) Comp2Strs(s1,s2) "RTN","TMGSTUTL",955,0) ;"Purpose: To compare two strings and assign an arbritrary score to their similarity "RTN","TMGSTUTL",956,0) ;"Input: s1,s2 -- The two strings to compare "RTN","TMGSTUTL",957,0) ;"Result: a score comparing the two strings "RTN","TMGSTUTL",958,0) ;" 0.5 point for every word in s1 that is also in s2 (case specific) "RTN","TMGSTUTL",959,0) ;" 0.25 point for every word in s1 that is also in s2 (not case specific) "RTN","TMGSTUTL",960,0) ;" 0.5 point for every word in s2 that is also in s1 (case specific) "RTN","TMGSTUTL",961,0) ;" 0.25 point for every word in s2 that is also in s1 (not case specific) "RTN","TMGSTUTL",962,0) ;" 1 points if same number of words in string (compared each way) "RTN","TMGSTUTL",963,0) ;" 2 points for each word that is in the same position in each string (case specific) "RTN","TMGSTUTL",964,0) ;" 1.5 points for each word that is in the same position in each string (not case specific) "RTN","TMGSTUTL",965,0) "RTN","TMGSTUTL",966,0) new score set score=0 "RTN","TMGSTUTL",967,0) new Us1 set Us1=$$UP^XLFSTR(s1) "RTN","TMGSTUTL",968,0) new Us2 set Us2=$$UP^XLFSTR(s2) "RTN","TMGSTUTL",969,0) "RTN","TMGSTUTL",970,0) new i "RTN","TMGSTUTL",971,0) for i=1:1:$length(s1," ") do "RTN","TMGSTUTL",972,0) . if s2[$piece(s1," ",i) set score=score+0.5 "RTN","TMGSTUTL",973,0) . else if Us2[$piece(Us1," ",i) set score=score+0.25 "RTN","TMGSTUTL",974,0) . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1 "RTN","TMGSTUTL",975,0) . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5 "RTN","TMGSTUTL",976,0) "RTN","TMGSTUTL",977,0) for i=1:1:$length(s2," ") do "RTN","TMGSTUTL",978,0) . if s1[$piece(s2," ",i) set score=score+0.5 "RTN","TMGSTUTL",979,0) . else if Us1[$piece(Us2," ",i) set score=score+0.25 "RTN","TMGSTUTL",980,0) . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1 "RTN","TMGSTUTL",981,0) . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5 "RTN","TMGSTUTL",982,0) "RTN","TMGSTUTL",983,0) if $length(s1," ")=$length(s2," ") set score=score+2 "RTN","TMGSTUTL",984,0) "RTN","TMGSTUTL",985,0) quit score "RTN","TMGSTUTL",986,0) "RTN","TMGSTUTL",987,0) "RTN","TMGSTUTL",988,0) PosNum(s,Num,LeadingSpace) "RTN","TMGSTUTL",989,0) ;"Purpose: To return the position of the first Number in a string "RTN","TMGSTUTL",990,0) ;"Input: S -- string to check "RTN","TMGSTUTL",991,0) ;" Num -- OPTIONAL, default is 0-9 numbers. number to look for. "RTN","TMGSTUTL",992,0) ;" LeadingSpace -- OPTIONAL. If 1 then looks for " #" or " .#", not just "#" "RTN","TMGSTUTL",993,0) ;"Results: -1 if not found, otherwise position of found digit. "RTN","TMGSTUTL",994,0) "RTN","TMGSTUTL",995,0) new result set result=-1 "RTN","TMGSTUTL",996,0) new Leader set Leader="" "RTN","TMGSTUTL",997,0) if $get(LeadingSpace)=1 set Leader=" " "RTN","TMGSTUTL",998,0) "RTN","TMGSTUTL",999,0) if $get(Num) do goto PNDone "RTN","TMGSTUTL",1000,0) . set result=$find(s,Leader_Num)-1 "RTN","TMGSTUTL",1001,0) "RTN","TMGSTUTL",1002,0) new temp,i,decimalFound "RTN","TMGSTUTL",1003,0) for i=0:1:9 do "RTN","TMGSTUTL",1004,0) . set decimalFound=0 "RTN","TMGSTUTL",1005,0) . set temp=$find(s,Leader_i) "RTN","TMGSTUTL",1006,0) . if (temp=0)&(Leader'="") do "RTN","TMGSTUTL",1007,0) . . set temp=$find(s,Leader_"."_i) "RTN","TMGSTUTL",1008,0) . . if temp>-1 set decimalFound=1 "RTN","TMGSTUTL",1009,0) . if temp>-1 set temp=temp-$length(Leader_i) "RTN","TMGSTUTL",1010,0) . if decimalFound set temp=temp-1 "RTN","TMGSTUTL",1011,0) . if (temp>0)&((temp0)&(Leader=" ") set result=result+1 "RTN","TMGSTUTL",1015,0) quit result "RTN","TMGSTUTL",1016,0) "RTN","TMGSTUTL",1017,0) "RTN","TMGSTUTL",1018,0) IsNumeric(s) "RTN","TMGSTUTL",1019,0) ;"Purpose: To deterimine if word s is a numeric "RTN","TMGSTUTL",1020,0) ;" Examples of numeric words: "RTN","TMGSTUTL",1021,0) ;" 10, N-100, 0.5%, 50000UNT/ML "RTN","TMGSTUTL",1022,0) ;" the test will be if the word contains any digit 0-9 "RTN","TMGSTUTL",1023,0) ;"Results: 1 if is a numeric word, 0 if not. "RTN","TMGSTUTL",1024,0) "RTN","TMGSTUTL",1025,0) quit ($$PosNum(.s)>0) "RTN","TMGSTUTL",1026,0) "RTN","TMGSTUTL",1027,0) "RTN","TMGSTUTL",1028,0) ScrubNumeric(s) "RTN","TMGSTUTL",1029,0) ;"Purpose: This is a specialty function designed to remove numeric words "RTN","TMGSTUTL",1030,0) ;" from a sentence. E.g. "RTN","TMGSTUTL",1031,0) ;" BELLADONNA ALK 0.3/PHENOBARB 16MG CHW TB --> BELLADONNA ALK /PHENOBARB CHW TB "RTN","TMGSTUTL",1032,0) ;" ESTROGENS,CONJUGATED 2MG/ML INJ (IN OIL) --> ESTROGENS,CONJUGATED INJ (IN OIL) "RTN","TMGSTUTL",1033,0) "RTN","TMGSTUTL",1034,0) new Array,i,result "RTN","TMGSTUTL",1035,0) set s=$$Substitute(s,"/MG","") "RTN","TMGSTUTL",1036,0) set s=$$Substitute(s,"/ML","") "RTN","TMGSTUTL",1037,0) set s=$$Substitute(s,"/"," / ") "RTN","TMGSTUTL",1038,0) set s=$$Substitute(s,"-"," - ") "RTN","TMGSTUTL",1039,0) do CleaveToArray(s," ",.Array) "RTN","TMGSTUTL",1040,0) new ToKill "RTN","TMGSTUTL",1041,0) set i=0 for set i=$order(Array(i)) quit:+i'>0 do "RTN","TMGSTUTL",1042,0) . if (Array(i)="MG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit "RTN","TMGSTUTL",1043,0) . if (Array(i)="MCG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit "RTN","TMGSTUTL",1044,0) . if (Array(i)="MEQ")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit "RTN","TMGSTUTL",1045,0) . if (Array(i)="%")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit "RTN","TMGSTUTL",1046,0) . if (Array(i)="MM")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit "RTN","TMGSTUTL",1047,0) . if $$IsNumeric(Array(i))=0 quit "RTN","TMGSTUTL",1048,0) . set ToKill(i)=1 "RTN","TMGSTUTL",1049,0) . new tempS set tempS=$get(Array(i-1)) "RTN","TMGSTUTL",1050,0) . if (tempS="/")!(tempS="-") set ToKill(i-1)=1 "RTN","TMGSTUTL",1051,0) . if (tempS="NO")!(tempS="#") set ToKill(i-1)=1 "RTN","TMGSTUTL",1052,0) "RTN","TMGSTUTL",1053,0) set i=0 for set i=$order(Array(i)) quit:+i'>0 do "RTN","TMGSTUTL",1054,0) . if $get(ToKill(i))=1 kill Array(i) "RTN","TMGSTUTL",1055,0) "RTN","TMGSTUTL",1056,0) set i="",result="" "RTN","TMGSTUTL",1057,0) for set i=$order(Array(i)) quit:+i'>0 do "RTN","TMGSTUTL",1058,0) . set result=result_Array(i)_" " "RTN","TMGSTUTL",1059,0) "RTN","TMGSTUTL",1060,0) set result=$$Trim(result) "RTN","TMGSTUTL",1061,0) set result=$$Substitute(result," / ","/") "RTN","TMGSTUTL",1062,0) set result=$$Substitute(result," - ","-") "RTN","TMGSTUTL",1063,0) "RTN","TMGSTUTL",1064,0) quit result "RTN","TMGSTUTL",1065,0) "RTN","TMGSTUTL",1066,0) "RTN","TMGSTUTL",1067,0) Pos(subStr,s,count) "RTN","TMGSTUTL",1068,0) ;"Purpose: return the beginning position of subStr in s "RTN","TMGSTUTL",1069,0) ;"Input: subStr -- the string to be searched for in s "RTN","TMGSTUTL",1070,0) ;" s -- the string to search "RTN","TMGSTUTL",1071,0) ;" count -- OPTIONAL, the instance to return pos of (1=1st, 2=2nd, etc.) "RTN","TMGSTUTL",1072,0) ;" if count=2 and only 1 instance exists, then 0 returned "RTN","TMGSTUTL",1073,0) ;"Result: the beginning position, or 0 if not found "RTN","TMGSTUTL",1074,0) ;"Note: This function differs from $find in that $find returns the pos of the "RTN","TMGSTUTL",1075,0) ;" first character AFTER the subStr "RTN","TMGSTUTL",1076,0) "RTN","TMGSTUTL",1077,0) set count=$get(count,1) "RTN","TMGSTUTL",1078,0) new result set result=0 "RTN","TMGSTUTL",1079,0) new instance set instance=1 "RTN","TMGSTUTL",1080,0) PS1 "RTN","TMGSTUTL",1081,0) set result=$find(s,subStr,result+1) "RTN","TMGSTUTL",1082,0) if result>0 set result=result-$length(subStr) "RTN","TMGSTUTL",1083,0) if count>instance set instance=instance+1 goto PS1 "RTN","TMGSTUTL",1084,0) "RTN","TMGSTUTL",1085,0) quit result "RTN","TMGSTUTL",1086,0) "RTN","TMGSTUTL",1087,0) "RTN","TMGSTUTL",1088,0) ArrayPos(array,s) "RTN","TMGSTUTL",1089,0) ;"Purpose: return the index position of s in array "RTN","TMGSTUTL",1090,0) "RTN","TMGSTUTL",1091,0) ;"... "RTN","TMGSTUTL",1092,0) "RTN","TMGSTUTL",1093,0) quit "RTN","TMGSTUTL",1094,0) "RTN","TMGSTUTL",1095,0) DiffPos(s1,s2) "RTN","TMGSTUTL",1096,0) ;"Purpose: Return the position of the first difference between s1 and s2 "RTN","TMGSTUTL",1097,0) ;"Input -- s1, s2 : The strings to compare. "RTN","TMGSTUTL",1098,0) ;"result: the position (in s1) of the first difference, or 0 if no difference "RTN","TMGSTUTL",1099,0) "RTN","TMGSTUTL",1100,0) new l set l=$length(s1) "RTN","TMGSTUTL",1101,0) if $length(s2)>l set l=$length(s2) "RTN","TMGSTUTL",1102,0) new done set done=0 "RTN","TMGSTUTL",1103,0) new i for i=1:1:l do quit:(done=1) "RTN","TMGSTUTL",1104,0) . set done=($extract(s1,1,i)'=$extract(s2,1,i)) "RTN","TMGSTUTL",1105,0) new result set result=0 "RTN","TMGSTUTL",1106,0) if done=1 set result=i "RTN","TMGSTUTL",1107,0) quit result "RTN","TMGSTUTL",1108,0) "RTN","TMGSTUTL",1109,0) "RTN","TMGSTUTL",1110,0) DiffWPos(Words1,Words2) "RTN","TMGSTUTL",1111,0) ;"Purpose: Return the index of the first different word between Words arrays "RTN","TMGSTUTL",1112,0) ;"Input: Words1,Words2 -- the array of words, such as would be made "RTN","TMGSTUTL",1113,0) ;" by CleaveToArray^TMGSTUTL "RTN","TMGSTUTL",1114,0) ;"Returns: Index of first different word in Words1, or 0 if no difference "RTN","TMGSTUTL",1115,0) "RTN","TMGSTUTL",1116,0) new l set l=+$get(Words1("MAXNODE")) "RTN","TMGSTUTL",1117,0) if +$get(Words2("MAXNODE"))>l set l=+$get(Words2("MAXNODE")) "RTN","TMGSTUTL",1118,0) new done set done=0 "RTN","TMGSTUTL",1119,0) new i for i=1:1:l do quit:(done=1) "RTN","TMGSTUTL",1120,0) . set done=($get(Words1(i))'=$get(Words2(i))) "RTN","TMGSTUTL",1121,0) new result "RTN","TMGSTUTL",1122,0) if done=1 set result=i "RTN","TMGSTUTL",1123,0) else set result=0 "RTN","TMGSTUTL",1124,0) quit result "RTN","TMGSTUTL",1125,0) "RTN","TMGSTUTL",1126,0) "RTN","TMGSTUTL",1127,0) SimStr(s1,p1,s2,p2) "RTN","TMGSTUTL",1128,0) ;"Purpose: return the matching string in both s1 and s2, starting "RTN","TMGSTUTL",1129,0) ;" at positions p1 and p2. "RTN","TMGSTUTL",1130,0) ;" Example: s1='Tom is 12 years old', p1=7 "RTN","TMGSTUTL",1131,0) ;" s2='Bill will be 12 years young tomorrow' p2=13 "RTN","TMGSTUTL",1132,0) ;" would return ' 12 years ' "RTN","TMGSTUTL",1133,0) "RTN","TMGSTUTL",1134,0) new ch1,ch2,offset,result,done "RTN","TMGSTUTL",1135,0) set result="",done=0 "RTN","TMGSTUTL",1136,0) for offset=0:1:9999 do quit:(done=1) "RTN","TMGSTUTL",1137,0) . set ch1=$extract(s1,p1+offset) "RTN","TMGSTUTL",1138,0) . set ch2=$extract(s2,p2+offset) "RTN","TMGSTUTL",1139,0) . if (ch1=ch2) set result=result_ch1 "RTN","TMGSTUTL",1140,0) . else set done=1 "RTN","TMGSTUTL",1141,0) quit result "RTN","TMGSTUTL",1142,0) "RTN","TMGSTUTL",1143,0) "RTN","TMGSTUTL",1144,0) SimWord(Words1,p1,Words2,p2) "RTN","TMGSTUTL",1145,0) ;"Purpose: return the matching words in both words array 1 and 2, starting "RTN","TMGSTUTL",1146,0) ;" at word positions p1 and p2. This function is different from "RTN","TMGSTUTL",1147,0) ;" SimStr in that it works with whole words "RTN","TMGSTUTL",1148,0) ;" Example: "RTN","TMGSTUTL",1149,0) ;" Words1(1)=Tom Words2(1)=Bill "RTN","TMGSTUTL",1150,0) ;" Words1(2)=is Words2(2)=will "RTN","TMGSTUTL",1151,0) ;" Words1(3)=12 Words2(3)=be "RTN","TMGSTUTL",1152,0) ;" Words1(4)=years Words2(4)=12 "RTN","TMGSTUTL",1153,0) ;" Words1(5)=old Words2(5)=years "RTN","TMGSTUTL",1154,0) ;" Words1("MAXNODE")=5 Words2(6)=young "RTN","TMGSTUTL",1155,0) ;" Words2(7)=tomorrow "RTN","TMGSTUTL",1156,0) ;" Words1("MAXNODE")=7 "RTN","TMGSTUTL",1157,0) ;" This will return 3, (where '12 years' starts) "RTN","TMGSTUTL",1158,0) ;" if p1=3 and p2=4 would return '12 years' "RTN","TMGSTUTL",1159,0) ;"Note: A '|' will be used as word separator when constructing result "RTN","TMGSTUTL",1160,0) ;"Input: Words1,Words2 -- the array of words, such as would be made "RTN","TMGSTUTL",1161,0) ;" by CleaveToArray^TMGSTUTL. e.g. "RTN","TMGSTUTL",1162,0) ;" p1,p2 -- the index of the word in Words array to start with "RTN","TMGSTUTL",1163,0) ;"result: (see example) "RTN","TMGSTUTL",1164,0) "RTN","TMGSTUTL",1165,0) new w1,w2,offset,result,done "RTN","TMGSTUTL",1166,0) set result="",done=0 "RTN","TMGSTUTL",1167,0) for offset=0:1:$get(Words1("MAXNODE")) do quit:(done=1) "RTN","TMGSTUTL",1168,0) . set w1=$get(Words1(offset+p1)) "RTN","TMGSTUTL",1169,0) . set w2=$get(Words2(offset+p2)) "RTN","TMGSTUTL",1170,0) . if (w1=w2)&(w1'="") do "RTN","TMGSTUTL",1171,0) . . if (result'="") set result=result_"|" "RTN","TMGSTUTL",1172,0) . . set result=result_w1 "RTN","TMGSTUTL",1173,0) . else set done=1 "RTN","TMGSTUTL",1174,0) quit result "RTN","TMGSTUTL",1175,0) "RTN","TMGSTUTL",1176,0) "RTN","TMGSTUTL",1177,0) SimPos(s1,s2,DivStr,pos1,pos2,MatchStr) "RTN","TMGSTUTL",1178,0) ;"Purpose: return the first position that two strings are similar. This means "RTN","TMGSTUTL",1179,0) ;" the first position in string s1 that characters match in s2. A "RTN","TMGSTUTL",1180,0) ;" match will be set to mean 3 or more characters being the same. "RTN","TMGSTUTL",1181,0) ;" Example: s1='Tom is 12 years old' "RTN","TMGSTUTL",1182,0) ;" s2='Bill will be 12 years young tomorrow' "RTN","TMGSTUTL",1183,0) ;" This will return 7, (where '12 years' starts) "RTN","TMGSTUTL",1184,0) ;"Input: s1,s2 -- the two strings to compare "RTN","TMGSTUTL",1185,0) ;" DivStr -- OPTIONAL, the character to use to separate the answers "RTN","TMGSTUTL",1186,0) ;" in the return string. Default is '^' "RTN","TMGSTUTL",1187,0) ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result "RTN","TMGSTUTL",1188,0) ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result "RTN","TMGSTUTL",1189,0) ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result "RTN","TMGSTUTL",1190,0) ;"Results: Pos1^Pos2^MatchStr Pos1=position in s1, Pos2=position in s2, "RTN","TMGSTUTL",1191,0) ;" MatchStr=the matching Str "RTN","TMGSTUTL",1192,0) "RTN","TMGSTUTL",1193,0) set DivStr=$get(DivStr,"^") "RTN","TMGSTUTL",1194,0) new startPos,subStr,found,s2Pos "RTN","TMGSTUTL",1195,0) set found=0,s2Pos=0 "RTN","TMGSTUTL",1196,0) for startPos=1:1:$length(s1) do quit:(found=1) "RTN","TMGSTUTL",1197,0) . set subStr=$extract(s1,startPos,startPos+3) "RTN","TMGSTUTL",1198,0) . set s2Pos=$$Pos(subStr,s2) "RTN","TMGSTUTL",1199,0) . set found=(s2Pos>0) "RTN","TMGSTUTL",1200,0) "RTN","TMGSTUTL",1201,0) new result "RTN","TMGSTUTL",1202,0) if found=1 do "RTN","TMGSTUTL",1203,0) . set pos1=startPos,pos2=s2Pos "RTN","TMGSTUTL",1204,0) . set MatchStr=$$SimStr(s1,startPos,s2,s2Pos) "RTN","TMGSTUTL",1205,0) else do "RTN","TMGSTUTL",1206,0) . set pos1=0,pos2=0,MatchStr="" "RTN","TMGSTUTL",1207,0) "RTN","TMGSTUTL",1208,0) set result=pos1_DivStr_pos2_DivStr_MatchStr "RTN","TMGSTUTL",1209,0) "RTN","TMGSTUTL",1210,0) quit result "RTN","TMGSTUTL",1211,0) "RTN","TMGSTUTL",1212,0) "RTN","TMGSTUTL",1213,0) SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) "RTN","TMGSTUTL",1214,0) ;"Purpose: return the first position that two word arrays are similar. This means "RTN","TMGSTUTL",1215,0) ;" the first index in Words array 1 that matches to words in Words array 2. "RTN","TMGSTUTL",1216,0) ;" A match will be set to mean the two words are equal "RTN","TMGSTUTL",1217,0) ;" Example: "RTN","TMGSTUTL",1218,0) ;" Words1(1)=Tom Words2(1)=Bill "RTN","TMGSTUTL",1219,0) ;" Words1(2)=is Words2(2)=will "RTN","TMGSTUTL",1220,0) ;" Words1(3)=12 Words2(3)=be "RTN","TMGSTUTL",1221,0) ;" Words1(4)=years Words2(4)=12 "RTN","TMGSTUTL",1222,0) ;" Words1(5)=old Words2(5)=years "RTN","TMGSTUTL",1223,0) ;" Words1("MAXNODE")=5 Words2(6)=young "RTN","TMGSTUTL",1224,0) ;" Words2(7)=tomorrow "RTN","TMGSTUTL",1225,0) ;" Words2("MAXNODE")=7 "RTN","TMGSTUTL",1226,0) ;" This will return 3, (where '12 years' starts) "RTN","TMGSTUTL",1227,0) ;"Input: Words1,Words2 -- the two arrays to compare "RTN","TMGSTUTL",1228,0) ;" DivStr -- OPTIONAL, the character to use to separate the answers "RTN","TMGSTUTL",1229,0) ;" in the return string. Default is '^' "RTN","TMGSTUTL",1230,0) ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result "RTN","TMGSTUTL",1231,0) ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result "RTN","TMGSTUTL",1232,0) ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result "RTN","TMGSTUTL",1233,0) ;"Results: Pos1^Pos2^MatchStr Pos1=position in Words1, Pos2=position in Words2, "RTN","TMGSTUTL",1234,0) ;" MatchStr=the first matching Word or phrase "RTN","TMGSTUTL",1235,0) ;" Note: | will be used as a word separator for phrases. "RTN","TMGSTUTL",1236,0) "RTN","TMGSTUTL",1237,0) set DivStr=$get(DivStr,"^") "RTN","TMGSTUTL",1238,0) new startPos,word1,found,w2Pos "RTN","TMGSTUTL",1239,0) set found=0,s2Pos=0 "RTN","TMGSTUTL",1240,0) for startPos=1:1:+$get(Words1("MAXNODE")) do quit:(found=1) "RTN","TMGSTUTL",1241,0) . set word1=$get(Words1(startPos)) "RTN","TMGSTUTL",1242,0) . set w2Pos=$$IndexOf^TMGMISC($name(Words2),word1) "RTN","TMGSTUTL",1243,0) . set found=(w2Pos>0) "RTN","TMGSTUTL",1244,0) "RTN","TMGSTUTL",1245,0) if found=1 do "RTN","TMGSTUTL",1246,0) . set p1=startPos,p2=w2Pos "RTN","TMGSTUTL",1247,0) . set MatchStr=$$SimWord(.Words1,p1,.Words2,p2) "RTN","TMGSTUTL",1248,0) else do "RTN","TMGSTUTL",1249,0) . set p1=0,p2=0,MatchStr="" "RTN","TMGSTUTL",1250,0) "RTN","TMGSTUTL",1251,0) new result set result=p1_DivStr_p2_DivStr_MatchStr "RTN","TMGSTUTL",1252,0) "RTN","TMGSTUTL",1253,0) quit result "RTN","TMGSTUTL",1254,0) "RTN","TMGSTUTL",1255,0) "RTN","TMGSTUTL",1256,0) DiffStr(s1,s2,DivChr) "RTN","TMGSTUTL",1257,0) ;"Purpose: Return how s1 differs from s2. E.g. "RTN","TMGSTUTL",1258,0) ;" s1='Today was the birthday of Bill and John' "RTN","TMGSTUTL",1259,0) ;" s2='Yesterday was the birthday of Tom and Sue' "RTN","TMGSTUTL",1260,0) ;" results='Today^1^Bill^26^John^35' "RTN","TMGSTUTL",1261,0) ;" This means that 'Today', starting at pos 1 in s1 differs "RTN","TMGSTUTL",1262,0) ;" from s2. And 'Bill' starting at pos 26 differs from s2 etc.. "RTN","TMGSTUTL",1263,0) ;"Input: s1,s2 -- the two strings to compare "RTN","TMGSTUTL",1264,0) ;" DivStr -- OPTIONAL, the character to use to separate the answers "RTN","TMGSTUTL",1265,0) ;" in the return string. Default is '^' "RTN","TMGSTUTL",1266,0) ;"Results: DiffStr1^pos1^DiffStr2^pos2^... "RTN","TMGSTUTL",1267,0) "RTN","TMGSTUTL",1268,0) set DivChr=$get(DivChr,"^") "RTN","TMGSTUTL",1269,0) new result set result="" "RTN","TMGSTUTL",1270,0) new offset set offset=0 "RTN","TMGSTUTL",1271,0) new p1,p2,matchStr,matchLen "RTN","TMGSTUTL",1272,0) new diffStr,temp "RTN","TMGSTUTL",1273,0) DSLoop "RTN","TMGSTUTL",1274,0) set temp=$$SimPos(s1,s2,DivChr,.p1,.p2,.matchStr) "RTN","TMGSTUTL",1275,0) ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str "RTN","TMGSTUTL",1276,0) if p1=0 set:(s1'="") result=result_s1_DivChr_(+offset) goto DSDone "RTN","TMGSTUTL",1277,0) "RTN","TMGSTUTL",1278,0) set matchLen=$length(matchStr) "RTN","TMGSTUTL",1279,0) "RTN","TMGSTUTL",1280,0) if p1>1 do "RTN","TMGSTUTL",1281,0) . set diffStr=$extract(s1,1,p1-1) "RTN","TMGSTUTL",1282,0) . set result=result_diffStr_DivChr_(1+offset)_DivChr "RTN","TMGSTUTL",1283,0) set offset=offset+(p1+matchLen-1) "RTN","TMGSTUTL",1284,0) set s1=$extract(s1,p1+matchLen,9999) ;"trim s1 "RTN","TMGSTUTL",1285,0) set s2=$extract(s2,p2+matchLen,9999) ;"trim s2 "RTN","TMGSTUTL",1286,0) goto DSLoop "RTN","TMGSTUTL",1287,0) DSDone "RTN","TMGSTUTL",1288,0) quit result "RTN","TMGSTUTL",1289,0) "RTN","TMGSTUTL",1290,0) "RTN","TMGSTUTL",1291,0) DiffWords(Words1,Words2,DivChr) "RTN","TMGSTUTL",1292,0) ;"Purpose: Return how Word arrays Words1 differs from Words2. E.g. "RTN","TMGSTUTL",1293,0) ;" Example: "RTN","TMGSTUTL",1294,0) ;" Words1(1)=Tom Words2(1)=Bill "RTN","TMGSTUTL",1295,0) ;" Words1(2)=is Words2(2)=will "RTN","TMGSTUTL",1296,0) ;" Words1(3)=12 Words2(3)=be "RTN","TMGSTUTL",1297,0) ;" Words1(4)=years Words2(4)=12 "RTN","TMGSTUTL",1298,0) ;" Words1(5)=old Words2(5)=years "RTN","TMGSTUTL",1299,0) ;" Words1("MAXNODE")=5 Words2(6)=young "RTN","TMGSTUTL",1300,0) ;" Words2(7)=tomorrow "RTN","TMGSTUTL",1301,0) ;" Words1("MAXNODE")=7 "RTN","TMGSTUTL",1302,0) ;" "RTN","TMGSTUTL",1303,0) ;" s1='Today was the birthday of Bill and John' "RTN","TMGSTUTL",1304,0) ;" s2='Yesterday was the birthday of Tom and Sue' "RTN","TMGSTUTL",1305,0) ;" results='Tom is^1^old^5' "RTN","TMGSTUTL",1306,0) ;" This means that 'Tom is', starting at pos 1 in Words1 differs "RTN","TMGSTUTL",1307,0) ;" from Words2. And 'old' starting at pos 5 differs from Words2 etc.. "RTN","TMGSTUTL",1308,0) ;"Input: Words1,Words2 -- PASS BY REFERENCE. The two word arrays to compare "RTN","TMGSTUTL",1309,0) ;" DivStr -- OPTIONAL, the character to use to separate the answers "RTN","TMGSTUTL",1310,0) ;" in the return string. Default is '^' "RTN","TMGSTUTL",1311,0) ;"Note: The words in DiffStr are divided by "|" "RTN","TMGSTUTL",1312,0) ;"Results: DiffStr1A>DiffStr1B^pos1>pos2^DiffStr2A>DiffStr2B^pos1>pos2^... "RTN","TMGSTUTL",1313,0) ;" The A DiffStr would be what the value is in Words1, and "RTN","TMGSTUTL",1314,0) ;" the B DiffStr would be what the value is in Words2, or @ if deleted. "RTN","TMGSTUTL",1315,0) "RTN","TMGSTUTL",1316,0) set DivChr=$get(DivChr,"^") "RTN","TMGSTUTL",1317,0) new result set result="" "RTN","TMGSTUTL",1318,0) new trimmed1,trimmed2 set trimmed1=0,trimmed2=0 "RTN","TMGSTUTL",1319,0) new p1,p2,matchStr,matchLen "RTN","TMGSTUTL",1320,0) new diffStr1,diffStr2,temp "RTN","TMGSTUTL",1321,0) new tWords1,tWords2 "RTN","TMGSTUTL",1322,0) merge tWords1=Words1 "RTN","TMGSTUTL",1323,0) merge tWords2=Words2 "RTN","TMGSTUTL",1324,0) new i,len1,len2,trimLen1,trimLen2 "RTN","TMGSTUTL",1325,0) new diffPos1,diffPos2 "RTN","TMGSTUTL",1326,0) set len1=+$get(tWords1("MAXNODE")) "RTN","TMGSTUTL",1327,0) set len2=+$get(tWords2("MAXNODE")) "RTN","TMGSTUTL",1328,0) DWLoop "RTN","TMGSTUTL",1329,0) set temp=$$SimWPos(.tWords1,.tWords2,DivChr,.p1,.p2,.matchStr) "RTN","TMGSTUTL",1330,0) ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str "RTN","TMGSTUTL",1331,0) "RTN","TMGSTUTL",1332,0) ;"Possible return options: "RTN","TMGSTUTL",1333,0) ;" p1=p2=0 -- two strings have nothing in common "RTN","TMGSTUTL",1334,0) ;" p1=p2=1 -- first word of each string is the same "RTN","TMGSTUTL",1335,0) ;" p1=p2=X -- words 1..(X-1) differ from each other. "RTN","TMGSTUTL",1336,0) ;" p1>p2 -- e.g. EXT REL TAB --> XR TAB "RTN","TMGSTUTL",1337,0) ;" p1 EXT REL TAB "RTN","TMGSTUTL",1338,0) "RTN","TMGSTUTL",1339,0) if (p1=0)&(p2=0) do "RTN","TMGSTUTL",1340,0) . set diffStr1=$$CatArray(.tWords1,1,len1,"|") "RTN","TMGSTUTL",1341,0) . set diffStr2=$$CatArray(.tWords2,1,len2,"|") "RTN","TMGSTUTL",1342,0) . set trimLen1=len1,trimLen2=len2 "RTN","TMGSTUTL",1343,0) . set diffPos1=1+trimmed1 "RTN","TMGSTUTL",1344,0) . set diffPos2=1+trimmed2 "RTN","TMGSTUTL",1345,0) else if (p1=1)&(p2=1) do "RTN","TMGSTUTL",1346,0) . set diffStr1="@",diffStr2="@" "RTN","TMGSTUTL",1347,0) . set trimLen1=1,trimLen2=1 "RTN","TMGSTUTL",1348,0) . set diffPos1=0,diffPos2=0 "RTN","TMGSTUTL",1349,0) else do "RTN","TMGSTUTL",1350,0) . set diffStr1=$$CatArray(.tWords1,1,p1-1,"|") "RTN","TMGSTUTL",1351,0) . set diffStr2=$$CatArray(.tWords2,1,p2-1,"|") "RTN","TMGSTUTL",1352,0) . set trimLen1=p1-1,trimLen2=p2-1 "RTN","TMGSTUTL",1353,0) . set diffPos1=1+trimmed1,diffPos2=1+trimmed2 "RTN","TMGSTUTL",1354,0) "RTN","TMGSTUTL",1355,0) if diffStr1="" set diffStr1="@" "RTN","TMGSTUTL",1356,0) if diffStr2="" set diffStr2="@" "RTN","TMGSTUTL",1357,0) "RTN","TMGSTUTL",1358,0) if '((diffStr1="@")&(diffStr1="@")) do "RTN","TMGSTUTL",1359,0) . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr "RTN","TMGSTUTL",1360,0) . set result=result_diffStr1_">"_diffStr2_DivChr "RTN","TMGSTUTL",1361,0) . set result=result_diffPos1_">"_diffPos2 "RTN","TMGSTUTL",1362,0) "RTN","TMGSTUTL",1363,0) do ListTrim^TMGMISC("tWords1",1,trimLen1,"MAXNODE") "RTN","TMGSTUTL",1364,0) do ListTrim^TMGMISC("tWords2",1,trimLen2,"MAXNODE") "RTN","TMGSTUTL",1365,0) set trimmed1=trimmed1+trimLen1 "RTN","TMGSTUTL",1366,0) set trimmed2=trimmed2+trimLen2 "RTN","TMGSTUTL",1367,0) "RTN","TMGSTUTL",1368,0) if ($get(tWords1("MAXNODE"))=0)&($get(tWords2("MAXNODE"))=0) goto DWDone "RTN","TMGSTUTL",1369,0) goto DWLoop "RTN","TMGSTUTL",1370,0) "RTN","TMGSTUTL",1371,0) DWDone "RTN","TMGSTUTL",1372,0) quit result "RTN","TMGSTUTL",1373,0) "RTN","TMGSTUTL",1374,0) CatArray(Words,i1,i2,DivChr) "RTN","TMGSTUTL",1375,0) ;"Purpose: For given word array, return contatenated results from index1 to index2 "RTN","TMGSTUTL",1376,0) ;"Input: Words -- PASS BY REFERENCE. Array of Words, as might be created by CleaveToArray "RTN","TMGSTUTL",1377,0) ;" i1 -- the index to start concat at "RTN","TMGSTUTL",1378,0) ;" i2 -- the last index to include in concat "RTN","TMGSTUTL",1379,0) ;" DivChr -- OPTIONAL. The character to used to separate words. Default=" " "RTN","TMGSTUTL",1380,0) "RTN","TMGSTUTL",1381,0) new result set result="" "RTN","TMGSTUTL",1382,0) set DivChr=$get(DivChr," ") "RTN","TMGSTUTL",1383,0) new i for i=i1:1:i2 do "RTN","TMGSTUTL",1384,0) . new word set word=$get(Words(i)) "RTN","TMGSTUTL",1385,0) . if word="" quit "RTN","TMGSTUTL",1386,0) . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr "RTN","TMGSTUTL",1387,0) . set result=result_word "RTN","TMGSTUTL",1388,0) quit result "RTN","TMGSTUTL",1389,0) "RTN","TMGSTUTL",1390,0) "RTN","TMGSTUTL",1391,0) QtProtect(s) "RTN","TMGSTUTL",1392,0) ;"Purpose: Protects quotes by converting all quotes do double quotes (" --> "") "RTN","TMGSTUTL",1393,0) ;"Input : s -- The string to be modified. Original string is unchanged. "RTN","TMGSTUTL",1394,0) ;"Result: returns a string with all instances of single instances of quotes "RTN","TMGSTUTL",1395,0) ;" being replaced with two quotes. "RTN","TMGSTUTL",1396,0) "RTN","TMGSTUTL",1397,0) new tempS "RTN","TMGSTUTL",1398,0) set tempS=$$Substitute($get(s),"""""","<^@^>") ;"protect original double quotes "RTN","TMGSTUTL",1399,0) set tempS=$$Substitute(tempS,"""","""""") "RTN","TMGSTUTL",1400,0) set tempS=$$Substitute(tempS,"<^@^>","""""") ;"reverse protection "RTN","TMGSTUTL",1401,0) quit tempS "RTN","TMGTERM") 0^80^B16915 "RTN","TMGTERM",1,0) TMGTERM ;TMG/kst/Terminal interface (ANSI sequences) ;03/25/06 "RTN","TMGTERM",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGTERM",3,0) "RTN","TMGTERM",4,0) ;"Terminal interface "RTN","TMGTERM",5,0) ;"ANSI Standard (X3.64) Control Sequences for Video Terminals and Peripherals "RTN","TMGTERM",6,0) ;" in alphabetic order by mnemonic "RTN","TMGTERM",7,0) "RTN","TMGTERM",8,0) ;"Terminal interface "RTN","TMGTERM",9,0) ;"ANSI Standard (X3.64) Control Sequences for Video Terminals and Peripherals "RTN","TMGTERM",10,0) ;" in alphabetic order by mnemonic "RTN","TMGTERM",11,0) "RTN","TMGTERM",12,0) ;"CBT(Pn) ;CBT Cursor Backward Tab Esc [ Pn Z "RTN","TMGTERM",13,0) ;"CCH ;Cancel Previous Character Esc T "RTN","TMGTERM",14,0) ;"CHA(Pn) ;Cursor Horzntal Absolute Esc [ Pn G "RTN","TMGTERM",15,0) ;"CHT(Pn) ;Cursor Horizontal Tab Esc [ Pn I "RTN","TMGTERM",16,0) ;"CNL(Pn) ;Cursor Next Line Esc [ Pn E "RTN","TMGTERM",17,0) ;"CPL(Pn) ;Cursor Preceding Line Esc [ Pn F "RTN","TMGTERM",18,0) ;"CPR(Pn,P2) ;Cursor Position Report Esc [ Pn ; Pn R VT100 "RTN","TMGTERM",19,0) ;"CTC(Pn) ;Cursor Tab Control Esc [ Ps W "RTN","TMGTERM",20,0) ;"CUB(Pn) ;Cursor Backward Esc [ Pn D VT100 "RTN","TMGTERM",21,0) ;"CUD(Pn) ;Cursor Down Esc [ Pn B VT100 "RTN","TMGTERM",22,0) ;"CUF(Pn) ;Cursor Forward Esc [ Pn C VT100 "RTN","TMGTERM",23,0) ;"CUP(X,Y) ;Cursor Position Esc [ Pn ; Pn H VT100 "RTN","TMGTERM",24,0) ;"HOME ;Cursor Home Esc [ H ('home' is top left) "RTN","TMGTERM",25,0) ;"CUU(Pn) ;Cursor Up Esc [ Pn A VT100 "RTN","TMGTERM",26,0) ;"CVT(Pn) ;Cursor Vertical Tab Esc [ Pn Y "RTN","TMGTERM",27,0) ;"DCH(Pn) ;Delete Character Esc [ Pn P "RTN","TMGTERM",28,0) ;"DL(Pn) ;Delete Line Esc [ Pn M "RTN","TMGTERM",29,0) ;"EA(Pn) ;Erase in Area Esc [ Ps O "RTN","TMGTERM",30,0) ;"ECH(Pn) ;Erase Character Esc [ Pn X "RTN","TMGTERM",31,0) ;"ED(Pn) ;Erase in Display Esc [ Ps J VT100 "RTN","TMGTERM",32,0) ;"EF(Pn) ;Erase in Field Esc [ Ps N "RTN","TMGTERM",33,0) ;"EL(Pn) ;Erase in Line Esc [ Ps K VT100 "RTN","TMGTERM",34,0) ;"EPA ;End of Protected Area Esc W "RTN","TMGTERM",35,0) ;"ESA ;End of Selected Area Esc G "RTN","TMGTERM",36,0) ;"FNT(Pn,P2) ;Font Selection Esc [ Pn ; Pn Space D "RTN","TMGTERM",37,0) ;"GSM(Pn,P2) ;Graphic Size Modify Esc [ Pn ; Pn Space B "RTN","TMGTERM",38,0) ;"GSS(Pn) ;Graphic Size Selection Esc [ Pn Space C "RTN","TMGTERM",39,0) ;"HPA(Pn) ;Horz Position Absolute Esc [ Pn ` "RTN","TMGTERM",40,0) ;"HPR(Pn) ;Horz Position Relative Esc [ Pn a "RTN","TMGTERM",41,0) ;"HTJ ;Horz Tab w/Justification Esc I "RTN","TMGTERM",42,0) ;"HTS ;Horizontal Tab Set Esc H VT100 "RTN","TMGTERM",43,0) ;"HVP(Pn,P2) ;Horz & Vertical Position Esc [ Pn ; Pn f VT100 "RTN","TMGTERM",44,0) ;"ICH(Pn) ;Insert Character Esc [ Pn @ "RTN","TMGTERM",45,0) ;"IL(Pn) ;Insert Line Esc [ Pn L "RTN","TMGTERM",46,0) ;"IND ;Index Esc D VT100 "RTN","TMGTERM",47,0) ;"NEL ;Next Line Esc E VT100 "RTN","TMGTERM",48,0) ;"NP(Pn) ;Next Page Esc [ Pn U "RTN","TMGTERM",49,0) ;"PP(Pn) ;Preceding Page Esc [ Pn V "RTN","TMGTERM",50,0) ;"IS ;Reset to Initial State Esc c "RTN","TMGTERM",51,0) ;"RM(Pn) ;Reset Mode Esc [ Ps l VT100 "RTN","TMGTERM",52,0) ;"SD(Pn) ;Scroll Down Esc [ Pn T "RTN","TMGTERM",53,0) ;"SL(Pn) ;Scroll Left Esc [ Pn Space @ "RTN","TMGTERM",54,0) ;"SM(Pn) ;Select Mode Esc [ Ps h VT100 "RTN","TMGTERM",55,0) ;"SPA ;Start of Protected Area Esc V "RTN","TMGTERM",56,0) ;"SPI(Pn,P2) ;Spacing Increment Esc [ Pn ; Pn Space G "RTN","TMGTERM",57,0) ;"SR(Pn) ;Scroll Right Esc [ Pn Space A "RTN","TMGTERM",58,0) ;"SA ;Start of Selected Area Esc F "RTN","TMGTERM",59,0) ;"ST ;String Terminator Esc \ "RTN","TMGTERM",60,0) ;"SU(Pn) ;Scroll Up Esc [ Pn S "RTN","TMGTERM",61,0) ;"TBC(Pn) ;Tab Clear Esc [ Ps g VT100 "RTN","TMGTERM",62,0) ;"VPA(Pn) ;Vert Position Absolute Esc [ Pn d "RTN","TMGTERM",63,0) ;"VPR(Pn) ;Vert Position Relative Esc [ Pn e "RTN","TMGTERM",64,0) ;"VCULOAD ;Unsave Cursor ESC [ u "RTN","TMGTERM",65,0) ;"VCUSAV2 ;Save Cursor & Attrs ESC 7 "RTN","TMGTERM",66,0) ;"VCULOAD2 ;Restore Cursor & Attrs ESC 8 "RTN","TMGTERM",67,0) "RTN","TMGTERM",68,0) ;"VT100 specific calls "RTN","TMGTERM",69,0) ;"-------------------- "RTN","TMGTERM",70,0) ;"VCEL ;Erase from cursor to end of line Esc [ 0 K or Esc [ K "RTN","TMGTERM",71,0) ;"VCBL ;Erase from beginning of line to cursor Esc [ 1 K "RTN","TMGTERM",72,0) ;"VEL ;Erase line containing cursor Esc [ 2 K "RTN","TMGTERM",73,0) ;"VCES ;Erase from cursor to end of screen Esc [ 0 J or Esc [ J "RTN","TMGTERM",74,0) ;"VCBS ;Erase from beginning of screen to cursor Esc [ 1 J "RTN","TMGTERM",75,0) ;"VCS ;Erase entire screen Esc [ 2 J "RTN","TMGTERM",76,0) ;"VCUSAV ;Save Cursor ESC [ s "RTN","TMGTERM",77,0) ;"VTATRIB(n) ;Set Text attributes [{attr1};...;{attrn}m "RTN","TMGTERM",78,0) ;"VFGCOLOR(n);Set Text Foreground Color [{attr1};...;{attrn}m "RTN","TMGTERM",79,0) ;"VBGCOLOR(n);Set Text Background Color [{attr1};...;{attrn}m "RTN","TMGTERM",80,0) ;"VCOLORS(FG,BG) ;Set Text Colors [{attr1};...;{attrn}m "RTN","TMGTERM",81,0) ;"SetGlobals "RTN","TMGTERM",82,0) ;"KillGlobals "RTN","TMGTERM",83,0) ;"DemoColors "RTN","TMGTERM",84,0) ;"DemoClr2 "RTN","TMGTERM",85,0) "RTN","TMGTERM",86,0) "RTN","TMGTERM",87,0) ;"===================================================== "RTN","TMGTERM",88,0) "RTN","TMGTERM",89,0) "RTN","TMGTERM",90,0) EscN(Num,N2,Cmd) "RTN","TMGTERM",91,0) new tempX,tempY "RTN","TMGTERM",92,0) set tempX=$X "RTN","TMGTERM",93,0) set tempY=$Y "RTN","TMGTERM",94,0) set $X=1 ;"ensure escape chars don't cause a wrap. "RTN","TMGTERM",95,0) write $char(27,91)_Num "RTN","TMGTERM",96,0) if $data(N2) write ";"_N2 "RTN","TMGTERM",97,0) if $data(Cmd) write Cmd "RTN","TMGTERM",98,0) ;"reset $X,$Y so that escape characters aren't counted for line wrapping "RTN","TMGTERM",99,0) set $X=tempX "RTN","TMGTERM",100,0) set $Y=tempY "RTN","TMGTERM",101,0) quit "RTN","TMGTERM",102,0) "RTN","TMGTERM",103,0) CBT(Pn) ;"CBT Cursor Backward Tab Esc [ Pn Z "RTN","TMGTERM",104,0) do EscN(.Pn,,"Z") "RTN","TMGTERM",105,0) quit "RTN","TMGTERM",106,0) "RTN","TMGTERM",107,0) CCH ;"Cancel Previous Character Esc T "RTN","TMGTERM",108,0) write $char(27)_"T" "RTN","TMGTERM",109,0) "RTN","TMGTERM",110,0) CHA(Pn) ;"Cursor Horzntal Absolute Esc [ Pn G "RTN","TMGTERM",111,0) do EscN(.Pn,,"G") "RTN","TMGTERM",112,0) set $X=Pn "RTN","TMGTERM",113,0) quit "RTN","TMGTERM",114,0) "RTN","TMGTERM",115,0) CHT(Pn) ;"Cursor Horizontal Tab Esc [ Pn I "RTN","TMGTERM",116,0) do EscN(.Pn,,"I") quit "RTN","TMGTERM",117,0) "RTN","TMGTERM",118,0) CNL(Pn) ;"Cursor Next Line Esc [ Pn E "RTN","TMGTERM",119,0) do EscN(.Pn,,"E") "RTN","TMGTERM",120,0) set $Y=$Y+1 "RTN","TMGTERM",121,0) quit "RTN","TMGTERM",122,0) "RTN","TMGTERM",123,0) CPL(Pn) ;"Cursor Preceding Line Esc [ Pn F "RTN","TMGTERM",124,0) do EscN(.Pn,,"F") "RTN","TMGTERM",125,0) if $Y>0 set $Y=$Y-1 "RTN","TMGTERM",126,0) quit "RTN","TMGTERM",127,0) "RTN","TMGTERM",128,0) CPR(Pn,P2) ;"Cursor Position Report Esc [ Pn ; Pn R VT100 "RTN","TMGTERM",129,0) do EscN(.Pn,.P2,"R") quit "RTN","TMGTERM",130,0) "RTN","TMGTERM",131,0) CTC(Pn) ;"Cursor Tab Control Esc [ Ps W "RTN","TMGTERM",132,0) do EscN(.Pn,,"W") quit "RTN","TMGTERM",133,0) "RTN","TMGTERM",134,0) CUB(Pn) ;"Cursor Backward Esc [ Pn D VT100 "RTN","TMGTERM",135,0) do EscN(.Pn,,"D") "RTN","TMGTERM",136,0) set $X=$X-1 "RTN","TMGTERM",137,0) quit "RTN","TMGTERM",138,0) "RTN","TMGTERM",139,0) CUD(Pn) ;"Cursor Down Esc [ Pn B VT100 "RTN","TMGTERM",140,0) do EscN(.Pn,,"B") "RTN","TMGTERM",141,0) set $Y=$Y+1 "RTN","TMGTERM",142,0) quit "RTN","TMGTERM",143,0) "RTN","TMGTERM",144,0) CUF(Pn) ;"Cursor Forward Esc [ Pn C VT100 "RTN","TMGTERM",145,0) do EscN(.Pn,,"C") "RTN","TMGTERM",146,0) set $X=$X+1 "RTN","TMGTERM",147,0) quit "RTN","TMGTERM",148,0) "RTN","TMGTERM",149,0) CUP(X,Y) ;"Cursor Position Esc [ Pn ; Pn H VT100 "RTN","TMGTERM",150,0) do EscN(.Y,.X,"H") "RTN","TMGTERM",151,0) set $X=X "RTN","TMGTERM",152,0) set $Y=Y "RTN","TMGTERM",153,0) quit "RTN","TMGTERM",154,0) "RTN","TMGTERM",155,0) HOME ;"Cursor Home Esc [ H ('home' is top left) "RTN","TMGTERM",156,0) set $X=1 ;"ensure characters below don't cause a wrap. "RTN","TMGTERM",157,0) w $char(27,91)_"H" "RTN","TMGTERM",158,0) set $X=1 ;"now set $X to home value. "RTN","TMGTERM",159,0) set $Y=1 "RTN","TMGTERM",160,0) quit "RTN","TMGTERM",161,0) "RTN","TMGTERM",162,0) CUU(Pn) ;"Cursor Up Esc [ Pn A VT100 "RTN","TMGTERM",163,0) do EscN(.Pn,,"A") "RTN","TMGTERM",164,0) set $Y=$Y-1 "RTN","TMGTERM",165,0) quit "RTN","TMGTERM",166,0) "RTN","TMGTERM",167,0) CVT(Pn) ;"Cursor Vertical Tab Esc [ Pn Y "RTN","TMGTERM",168,0) do EscN(.Pn,,"Y") quit "RTN","TMGTERM",169,0) "RTN","TMGTERM",170,0) DCH(Pn) ;"Delete Character Esc [ Pn P "RTN","TMGTERM",171,0) do EscN(.Pn,,"P") quit "RTN","TMGTERM",172,0) "RTN","TMGTERM",173,0) DL(Pn) ;"Delete Line Esc [ Pn M "RTN","TMGTERM",174,0) do EscN(.Pn,,"M") quit "RTN","TMGTERM",175,0) "RTN","TMGTERM",176,0) EA(Pn) ;"Erase in Area Esc [ Ps O "RTN","TMGTERM",177,0) do EscN(.Pn,,"O") quit "RTN","TMGTERM",178,0) "RTN","TMGTERM",179,0) ECH(Pn) ;"Erase Character Esc [ Pn X "RTN","TMGTERM",180,0) do EscN(.Pn,,"X") quit "RTN","TMGTERM",181,0) "RTN","TMGTERM",182,0) ED(Pn) ;"Erase in Display Esc [ Ps J VT100 "RTN","TMGTERM",183,0) do EscN(.Pn,,"J") quit "RTN","TMGTERM",184,0) "RTN","TMGTERM",185,0) EF(Pn) ;"Erase in Field Esc [ Ps N "RTN","TMGTERM",186,0) do EscN(.Pn,,"N") quit "RTN","TMGTERM",187,0) "RTN","TMGTERM",188,0) EL(Pn) ;"Erase in Line Esc [ Ps K VT100 "RTN","TMGTERM",189,0) do EscN(.Pn,,"K") quit "RTN","TMGTERM",190,0) "RTN","TMGTERM",191,0) EPA ;"End of Protected Area Esc W "RTN","TMGTERM",192,0) w $char(27)_"W" quit "RTN","TMGTERM",193,0) "RTN","TMGTERM",194,0) ESA ;"End of Selected Area Esc G "RTN","TMGTERM",195,0) w $char(27)_"G" quit "RTN","TMGTERM",196,0) "RTN","TMGTERM",197,0) FNT(Pn,P2) ;"Font Selection Esc [ Pn ; Pn Space D "RTN","TMGTERM",198,0) do EscN(.Pn,P2,"D") quit "RTN","TMGTERM",199,0) "RTN","TMGTERM",200,0) GSM(Pn,P2) ;"Graphic Size Modify Esc [ Pn ; Pn Space B "RTN","TMGTERM",201,0) do EscN(.Pn,P2,"B") quit "RTN","TMGTERM",202,0) "RTN","TMGTERM",203,0) GSS(Pn) ;"Graphic Size Selection Esc [ Pn Space C "RTN","TMGTERM",204,0) do EscN(.Pn,,"C") quit "RTN","TMGTERM",205,0) "RTN","TMGTERM",206,0) HPA(Pn) ;"Horz Position Absolute Esc [ Pn ` "RTN","TMGTERM",207,0) do EscN(.Pn,,"`") quit "RTN","TMGTERM",208,0) "RTN","TMGTERM",209,0) HPR(Pn) ;"Horz Position Relative Esc [ Pn a "RTN","TMGTERM",210,0) do EscN(.Pn,,"a") quit "RTN","TMGTERM",211,0) "RTN","TMGTERM",212,0) HTJ ;"Horz Tab w/Justification Esc I "RTN","TMGTERM",213,0) w $char(27)_"I" quit "RTN","TMGTERM",214,0) "RTN","TMGTERM",215,0) HTS ;"Horizontal Tab Set Esc H VT100 "RTN","TMGTERM",216,0) w $char(27)_"H" quit "RTN","TMGTERM",217,0) "RTN","TMGTERM",218,0) HVP(Pn,P2) ;"Horz & Vertical Position Esc [ Pn ; Pn f VT100 "RTN","TMGTERM",219,0) do EscN(.Pn,P2,"A") quit "RTN","TMGTERM",220,0) "RTN","TMGTERM",221,0) ICH(Pn) ;"Insert Character Esc [ Pn @ "RTN","TMGTERM",222,0) do EscN(.Pn,,"@") quit "RTN","TMGTERM",223,0) "RTN","TMGTERM",224,0) IL(Pn) ;"Insert Line Esc [ Pn L "RTN","TMGTERM",225,0) do EscN(.Pn,,"L") quit "RTN","TMGTERM",226,0) "RTN","TMGTERM",227,0) IND ;"Index Esc D VT100 "RTN","TMGTERM",228,0) w $char(27)_"D" quit "RTN","TMGTERM",229,0) "RTN","TMGTERM",230,0) NEL ;"Next Line Esc E VT100 "RTN","TMGTERM",231,0) w $char(27)_"E" quit "RTN","TMGTERM",232,0) "RTN","TMGTERM",233,0) NP(Pn) ;"Next Page Esc [ Pn U "RTN","TMGTERM",234,0) do EscN(.Pn,,"U") quit "RTN","TMGTERM",235,0) "RTN","TMGTERM",236,0) PP(Pn) ;"Preceding Page Esc [ Pn V "RTN","TMGTERM",237,0) do EscN(.Pn,,"V") quit "RTN","TMGTERM",238,0) "RTN","TMGTERM",239,0) IS ;"Reset to Initial State Esc c "RTN","TMGTERM",240,0) w $char(27)_"c" quit "RTN","TMGTERM",241,0) "RTN","TMGTERM",242,0) RM(Pn) ;"Reset Mode Esc [ Ps l VT100 "RTN","TMGTERM",243,0) do EscN(.Pn,,"l") quit "RTN","TMGTERM",244,0) "RTN","TMGTERM",245,0) SD(Pn) ;"Scroll Down Esc [ Pn T "RTN","TMGTERM",246,0) do EscN(.Pn,,"T") quit "RTN","TMGTERM",247,0) "RTN","TMGTERM",248,0) SL(Pn) ;"Scroll Left Esc [ Pn Space @ "RTN","TMGTERM",249,0) do EscN(.Pn,," @") quit "RTN","TMGTERM",250,0) "RTN","TMGTERM",251,0) SM(Pn) ;"Select Mode Esc [ Ps h VT100 "RTN","TMGTERM",252,0) do EscN(.Pn,,"h") quit "RTN","TMGTERM",253,0) "RTN","TMGTERM",254,0) SPA ;"Start of Protected Area Esc V "RTN","TMGTERM",255,0) w $char(27)_"V" quit "RTN","TMGTERM",256,0) "RTN","TMGTERM",257,0) SPI(Pn,P2) ;"Spacing Increment Esc [ Pn ; Pn Space G "RTN","TMGTERM",258,0) do EscN(.Pn,P2," G") quit "RTN","TMGTERM",259,0) "RTN","TMGTERM",260,0) SR(Pn) ;"Scroll Right Esc [ Pn Space A "RTN","TMGTERM",261,0) do EscN(.Pn,," A") quit "RTN","TMGTERM",262,0) "RTN","TMGTERM",263,0) SA ;"Start of Selected Area Esc F "RTN","TMGTERM",264,0) w $char(27)_"F" quit "RTN","TMGTERM",265,0) "RTN","TMGTERM",266,0) ST ;"String Terminator Esc \ "RTN","TMGTERM",267,0) w $char(27)_"\" quit "RTN","TMGTERM",268,0) "RTN","TMGTERM",269,0) SU(Pn) ;"Scroll Up Esc [ Pn S "RTN","TMGTERM",270,0) do EscN(.Pn,,"S") quit "RTN","TMGTERM",271,0) "RTN","TMGTERM",272,0) TBC(Pn) ;"Tab Clear Esc [ Ps g VT100 "RTN","TMGTERM",273,0) do EscN(.Pn,,"g") quit "RTN","TMGTERM",274,0) "RTN","TMGTERM",275,0) VPA(Pn) ;"Vert Position Absolute Esc [ Pn d "RTN","TMGTERM",276,0) do EscN(.Pn,,"d") quit "RTN","TMGTERM",277,0) "RTN","TMGTERM",278,0) VPR(Pn) ;"Vert Position Relative Esc [ Pn e "RTN","TMGTERM",279,0) do EscN(.Pn,,"e") quit "RTN","TMGTERM",280,0) "RTN","TMGTERM",281,0) "RTN","TMGTERM",282,0) VCULOAD ;"Unsave Cursor ESC [ u "RTN","TMGTERM",283,0) w $char(27,91)_"u" quit "RTN","TMGTERM",284,0) "RTN","TMGTERM",285,0) VCUSAV2 ;"Save Cursor & Attrs ESC 7 "RTN","TMGTERM",286,0) w $char(27)_"7" quit "RTN","TMGTERM",287,0) "RTN","TMGTERM",288,0) VCULOAD2 ;"Restore Cursor & Attrs ESC 8 "RTN","TMGTERM",289,0) w $char(27)_"8" quit "RTN","TMGTERM",290,0) "RTN","TMGTERM",291,0) "RTN","TMGTERM",292,0) ;"-------------------------------------------------------------- "RTN","TMGTERM",293,0) ;"VT100 specific calls "RTN","TMGTERM",294,0) ;"Terminal interface "RTN","TMGTERM",295,0) "RTN","TMGTERM",296,0) VCEL ;"Erase from cursor to end of line Esc [ 0 K or Esc [ K "RTN","TMGTERM",297,0) do EscN("0",,"K") quit "RTN","TMGTERM",298,0) "RTN","TMGTERM",299,0) VCBL ;"Erase from beginning of line to cursor Esc [ 1 K "RTN","TMGTERM",300,0) do EscN("1",,"K") quit "RTN","TMGTERM",301,0) "RTN","TMGTERM",302,0) VEL ;"Erase line containing cursor Esc [ 2 K "RTN","TMGTERM",303,0) do EscN("2",,"K") quit "RTN","TMGTERM",304,0) "RTN","TMGTERM",305,0) VCES ;"Erase from cursor to end of screen Esc [ 0 J or Esc [ J "RTN","TMGTERM",306,0) do EscN("0",,"J") quit "RTN","TMGTERM",307,0) "RTN","TMGTERM",308,0) VCBS ;"Erase from beginning of screen to cursor Esc [ 1 J "RTN","TMGTERM",309,0) do EscN("1",,"J") quit "RTN","TMGTERM",310,0) "RTN","TMGTERM",311,0) VCS ;"Erase entire screen Esc [ 2 J "RTN","TMGTERM",312,0) do EscN("2",,"J") quit "RTN","TMGTERM",313,0) "RTN","TMGTERM",314,0) VCUSAV ;"Save Cursor ESC [ s "RTN","TMGTERM",315,0) w $char(27,91)_"s" quit "RTN","TMGTERM",316,0) "RTN","TMGTERM",317,0) ;"VCULOAD ;"Unsave Cursor ESC [ u "RTN","TMGTERM",318,0) ;" w $char(27,91)_"u" quit "RTN","TMGTERM",319,0) "RTN","TMGTERM",320,0) ;"VCUSAV2 ;"Save Cursor & Attrs ESC 7 "RTN","TMGTERM",321,0) ;" w $char(27)_"7" quit "RTN","TMGTERM",322,0) "RTN","TMGTERM",323,0) ;"VCULOAD2 ;"Restore Cursor & Attrs ESC 8 "RTN","TMGTERM",324,0) ;" w $char(27)_"8" quit "RTN","TMGTERM",325,0) "RTN","TMGTERM",326,0) VTATRIB(n) ;"Set Text attributes [{attr1};...;{attrn}m "RTN","TMGTERM",327,0) ;"0-Reset all attributes "RTN","TMGTERM",328,0) ;"1-Bright "RTN","TMGTERM",329,0) ;"2-Dim "RTN","TMGTERM",330,0) ;"4-Underscore "RTN","TMGTERM",331,0) ;"5-Blink "RTN","TMGTERM",332,0) ;"7-Reverse "RTN","TMGTERM",333,0) ;"8-Hidden "RTN","TMGTERM",334,0) do EscN(n,,"m") quit "RTN","TMGTERM",335,0) "RTN","TMGTERM",336,0) VFGCOLOR(n) ;"Set Text Foreground Color [{attr1};...;{attrn}m "RTN","TMGTERM",337,0) ;"See note about colors in VCOLORS "RTN","TMGTERM",338,0) do VTATRIB(0) "RTN","TMGTERM",339,0) if n>7 do "RTN","TMGTERM",340,0) . do VTATRIB(1) "RTN","TMGTERM",341,0) . set n=n-7 "RTN","TMGTERM",342,0) set n=n+30 "RTN","TMGTERM",343,0) do EscN(n,,"m") quit "RTN","TMGTERM",344,0) "RTN","TMGTERM",345,0) VBGCOLOR(n) ;"Set Text Background Color [{attr1};...;{attrn}m "RTN","TMGTERM",346,0) ;"See note about colors in VCOLORS "RTN","TMGTERM",347,0) do VTATRIB(0) "RTN","TMGTERM",348,0) if n>7 do "RTN","TMGTERM",349,0) . do VTATRIB(1) "RTN","TMGTERM",350,0) . set n=n-7 "RTN","TMGTERM",351,0) set n=n+40 "RTN","TMGTERM",352,0) do EscN(n,,"m") quit "RTN","TMGTERM",353,0) "RTN","TMGTERM",354,0) VCOLORS(FG,BG) ;Set Text Colors [{attr1};...;{attrn}m "RTN","TMGTERM",355,0) ;"Note: 5/29/06 I don't know if the color numbers are working "RTN","TMGTERM",356,0) ;" correctly. The best way to determine what the color should "RTN","TMGTERM",357,0) ;" be is to run DemoColor and pick the numbers wanted for desired colors "RTN","TMGTERM",358,0) do VTATRIB(0) "RTN","TMGTERM",359,0) if FG>7 do "RTN","TMGTERM",360,0) . do VTATRIB(1) "RTN","TMGTERM",361,0) . set FG=FG-7 "RTN","TMGTERM",362,0) if BG>7 do "RTN","TMGTERM",363,0) . do VTATRIB(1) "RTN","TMGTERM",364,0) . set BG=BG-7 "RTN","TMGTERM",365,0) "RTN","TMGTERM",366,0) set FG=FG+30 "RTN","TMGTERM",367,0) set BG=BG+40 "RTN","TMGTERM",368,0) do EscN(FG,BG,"m") quit "RTN","TMGTERM",369,0) quit "RTN","TMGTERM",370,0) "RTN","TMGTERM",371,0) SetGlobals "RTN","TMGTERM",372,0) set TMGcBlack=0 "RTN","TMGTERM",373,0) set TMGcRed=1 "RTN","TMGTERM",374,0) set TMGcGreen=2 "RTN","TMGTERM",375,0) set TMGcYellow=3 "RTN","TMGTERM",376,0) set TMGcBlue=4 "RTN","TMGTERM",377,0) set TMGcMagenta=5 "RTN","TMGTERM",378,0) set TMGcCyan=6 "RTN","TMGTERM",379,0) set TMGcGrey=7 "RTN","TMGTERM",380,0) "RTN","TMGTERM",381,0) set TMGcBRed=8 "RTN","TMGTERM",382,0) set TMGcBGreen=9 "RTN","TMGTERM",383,0) set TMGcBYellow=10 "RTN","TMGTERM",384,0) set TMGcBBlue=11 "RTN","TMGTERM",385,0) set TMGcBMagenta=12 "RTN","TMGTERM",386,0) set TMGcBCyan=13 "RTN","TMGTERM",387,0) set TMGcBGrey=14 "RTN","TMGTERM",388,0) set TMGcWhite=15 "RTN","TMGTERM",389,0) "RTN","TMGTERM",390,0) quit "RTN","TMGTERM",391,0) "RTN","TMGTERM",392,0) KillGlobals "RTN","TMGTERM",393,0) kill TMGcBlack "RTN","TMGTERM",394,0) kill TMGcRed "RTN","TMGTERM",395,0) kill TMGcGreen "RTN","TMGTERM",396,0) kill TMGcYellow "RTN","TMGTERM",397,0) kill TMGcBlue "RTN","TMGTERM",398,0) kill TMGcMagenta "RTN","TMGTERM",399,0) kill TMGcCyan "RTN","TMGTERM",400,0) kill TMGcGrey "RTN","TMGTERM",401,0) "RTN","TMGTERM",402,0) kill TMGcBRed "RTN","TMGTERM",403,0) kill TMGcBGreen "RTN","TMGTERM",404,0) kill TMGcBYellow "RTN","TMGTERM",405,0) kill TMGcBBlue "RTN","TMGTERM",406,0) kill TMGcBMagenta "RTN","TMGTERM",407,0) kill TMGcBCyan "RTN","TMGTERM",408,0) kill TMGcBGrey "RTN","TMGTERM",409,0) kill TMGcWhite "RTN","TMGTERM",410,0) "RTN","TMGTERM",411,0) quit "RTN","TMGTERM",412,0) "RTN","TMGTERM",413,0) DemoColors "RTN","TMGTERM",414,0) ;"Purpose: to write a grid on the screen, showing all the color combos "RTN","TMGTERM",415,0) "RTN","TMGTERM",416,0) do VTATRIB(1) "RTN","TMGTERM",417,0) new fg,bg "RTN","TMGTERM",418,0) for bg=1:1:14 do "RTN","TMGTERM",419,0) . for fg=1:1:14 do "RTN","TMGTERM",420,0) . . if fg=6 quit "RTN","TMGTERM",421,0) . . do VCUSAV2 "RTN","TMGTERM",422,0) . . do VCOLORS(fg,bg) "RTN","TMGTERM",423,0) . . write "/fg=",fg,";bg=",bg,"/ ",! "RTN","TMGTERM",424,0) . . do VCULOAD2 "RTN","TMGTERM",425,0) . write ! "RTN","TMGTERM",426,0) "RTN","TMGTERM",427,0) do VCOLORS(4,7) "RTN","TMGTERM",428,0) quit "RTN","TMGTERM",429,0) "RTN","TMGTERM",430,0) "RTN","TMGTERM",431,0) DemoClr2 "RTN","TMGTERM",432,0) ;"Purpose: to write a grid on the screen, showing all the color combos "RTN","TMGTERM",433,0) "RTN","TMGTERM",434,0) do VCUSAV2 "RTN","TMGTERM",435,0) "RTN","TMGTERM",436,0) new fg,bg "RTN","TMGTERM",437,0) for bg=1:1:14 do "RTN","TMGTERM",438,0) . for fg=1:1:14 do "RTN","TMGTERM",439,0) . . do VCOLORS(fg,bg) "RTN","TMGTERM",440,0) . . write "Text with background color #",bg," and foreground color #",fg "RTN","TMGTERM",441,0) . . do VTATRIB(0) "RTN","TMGTERM",442,0) . . write ! "RTN","TMGTERM",443,0) "RTN","TMGTERM",444,0) do VCULOAD2 "RTN","TMGTERM",445,0) quit "RTN","TMGTERM",446,0) "RTN","TMGTIUOJ") 0^82^B11722 "RTN","TMGTIUOJ",1,0) TMGTIUOJ ;TMG/kst-Text objects for use in CPRS ;03/25/06 "RTN","TMGTIUOJ",2,0) ;;1.0;TMG-LIB;**1**;05/28/08 "RTN","TMGTIUOJ",3,0) "RTN","TMGTIUOJ",4,0) ;"TMG text objects "RTN","TMGTIUOJ",5,0) ;" "RTN","TMGTIUOJ",6,0) ;"These are bits of code that return text to be included in progress notes etc. "RTN","TMGTIUOJ",7,0) ;"They are called when the user puts text like this in a note: "RTN","TMGTIUOJ",8,0) ;" ... Mrs. Jone's vitals today are |VITALS|, measured in the office... "RTN","TMGTIUOJ",9,0) ;" 'VITALS' would be a TIU TEXT OBJECT, managed through menu option TIUFJ CREATE OBJECTS MGR "RTN","TMGTIUOJ",10,0) "RTN","TMGTIUOJ",11,0) ;"--------------------------------------------------------------------------- "RTN","TMGTIUOJ",12,0) ;"PUBLIC FUNCTIONS "RTN","TMGTIUOJ",13,0) ;"--------------------------------------------------------------------------- "RTN","TMGTIUOJ",14,0) "RTN","TMGTIUOJ",15,0) ;"$$VITALS(DFN,.TIU) "RTN","TMGTIUOJ",16,0) ;"$$NICENAME(DFN) "RTN","TMGTIUOJ",17,0) ;"$$FNAME(DFN) "RTN","TMGTIUOJ",18,0) ;"$$MNAME(DFN) "RTN","TMGTIUOJ",19,0) ;"$$LNAME(DFN) "RTN","TMGTIUOJ",20,0) ;"$$PHONENUM(DFN) "RTN","TMGTIUOJ",21,0) ;"$$GETTABLX(DFN,LABEL) "RTN","TMGTIUOJ",22,0) ;"$$WTTREND(DFN,.TIU) return text showing patient's trend in change of weight. "RTN","TMGTIUOJ",23,0) ;"$$WTDELTA(DFN,.TIU) return text showing patient's change in weight. "RTN","TMGTIUOJ",24,0) "RTN","TMGTIUOJ",25,0) "RTN","TMGTIUOJ",26,0) ;"--------------------------------------------------------------------------- "RTN","TMGTIUOJ",27,0) ;"PRIVATE FUNCTIONS "RTN","TMGTIUOJ",28,0) ;"--------------------------------------------------------------------------- "RTN","TMGTIUOJ",29,0) ;"FormatVitals(result,s,Label,CurDT,NoteDT) "RTN","TMGTIUOJ",30,0) ;"RemoveDT(S,DT) "RTN","TMGTIUOJ",31,0) ;"RemoveTime(DT) "RTN","TMGTIUOJ",32,0) ;"DateDelta(RefDT,DT) "RTN","TMGTIUOJ",33,0) ;"FormatHeight(HtS,PtAge) remove centimeters from patient's height for adults "RTN","TMGTIUOJ",34,0) ;"TMGVISDT(TIU) Return a string for date of visit "RTN","TMGTIUOJ",35,0) ;"GetLast2(Array,NTLast,Last) Returns last 2 values in array (as created by GetPriorVital) "RTN","TMGTIUOJ",36,0) ;"GetPriorVital(DFN,Date,Vital,Array) retrieve a list of prior vital entries for a patient "RTN","TMGTIUOJ",37,0) "RTN","TMGTIUOJ",38,0) ;"GetNotesList(DFN,List,IncDays) "RTN","TMGTIUOJ",39,0) ;"ExtractSpecial(IEN8925,StartMarkerS,EndMarkerS,Array) "RTN","TMGTIUOJ",40,0) ;"MergeInto(partArray,masterArray) "RTN","TMGTIUOJ",41,0) ;"GetSpecial(DFN,StartMarkerS,EndMarkerS,Months,Array,Mode) "RTN","TMGTIUOJ",42,0) "RTN","TMGTIUOJ",43,0) ;"Array2Str(Array) convert Array (as created by GetSpecial) into one long string "RTN","TMGTIUOJ",44,0) ;"AddIfAbsent(Array,Key,Pivot,Value) add one (empty) entry, if a value for this doesn't already exist. "RTN","TMGTIUOJ",45,0) ;"StubRecommendations(DFN,Array,Label) add stubs for recommended studies to Array "RTN","TMGTIUOJ",46,0) "RTN","TMGTIUOJ",47,0) ;"--------------------------------------------------------------------------- "RTN","TMGTIUOJ",48,0) ;"--------------------------------------------------------------------------- "RTN","TMGTIUOJ",49,0) "RTN","TMGTIUOJ",50,0) VITALS(DFN,TIU) "RTN","TMGTIUOJ",51,0) ;"Purpose: Return a composite Vitals string like this: "RTN","TMGTIUOJ",52,0) ;" T: 98.6 BP: 112/78 R: 17 P: 68 Wt.: 190 Ht.: 76 "RTN","TMGTIUOJ",53,0) ;"Input: DFN -- the patient's unique ID (record#) "RTN","TMGTIUOJ",54,0) ;" TIU -- this is an array created by TIU system that "RTN","TMGTIUOJ",55,0) ;" contains information about the document being "RTN","TMGTIUOJ",56,0) ;" edited/created. I believe it has this structure: "RTN","TMGTIUOJ",57,0) ;" TIU("VSTR") = LOC;VDT;VTYP "RTN","TMGTIUOJ",58,0) ;" TIU("VISIT") = Visit File IFN^date? "RTN","TMGTIUOJ",59,0) ;" TIU("LOC") "RTN","TMGTIUOJ",60,0) ;" TIU("VLOC") "RTN","TMGTIUOJ",61,0) ;" TIU("STOP") = mark to defer workload "RTN","TMGTIUOJ",62,0) ;" TIU("TYPE")=1^title DA^title Name i.e.: 1^128^OFFICE VISIT^OFFICE VISIT "RTN","TMGTIUOJ",63,0) ;" TIU("SVC")=service, e.g. "FAMILY PRACTICE" "RTN","TMGTIUOJ",64,0) ;" TIU("EDT")=TIUEDT^DateStr = event begin time: FMDate^DateStr "RTN","TMGTIUOJ",65,0) ;" TIU("LDT")=TIULDT^DateStr = event end time: FMDate^DateStr "RTN","TMGTIUOJ",66,0) ;" TIU("VSTR")=LOC;VDT;VTYP e.g. "x;x;OFFICE VISIT" "RTN","TMGTIUOJ",67,0) ;" TIU("VISIT")=Visit File IFN "RTN","TMGTIUOJ",68,0) ;" TIU("LOC")=TIULOC "RTN","TMGTIUOJ",69,0) ;" TIU("VLOC")=TIULOC "RTN","TMGTIUOJ",70,0) ;" TIU("STOP")=0 ;"0=FALSE, don't worry about stop codes. "RTN","TMGTIUOJ",71,0) ;"Output: returns result "RTN","TMGTIUOJ",72,0) "RTN","TMGTIUOJ",73,0) new result set result="" "RTN","TMGTIUOJ",74,0) new CurDT set CurDT="" "RTN","TMGTIUOJ",75,0) new NoteDT set NoteDT="" "RTN","TMGTIUOJ",76,0) "RTN","TMGTIUOJ",77,0) new PtAge "RTN","TMGTIUOJ",78,0) do "RTN","TMGTIUOJ",79,0) . new IENS,TMGARRAY "RTN","TMGTIUOJ",80,0) . set IENS=$get(DFN)_"," "RTN","TMGTIUOJ",81,0) . do GETS^DIQ(2,IENS,.033,"TMGARRAY") ;".033 is computed patient age "RTN","TMGTIUOJ",82,0) . set PtAge=+$get(TMGARRAY(2,IENS,.033)) ;"will return 0 if not found "RTN","TMGTIUOJ",83,0) "RTN","TMGTIUOJ",84,0) new Wt,Ht "RTN","TMGTIUOJ",85,0) set NoteDT=$$VISDATE^TIULO1(.TIU) ;"Get date of current note (in MM/DD/YY HR:MIN) "RTN","TMGTIUOJ",86,0) set NoteDT=$piece(NoteDT," ",1) ;"Drop time "RTN","TMGTIUOJ",87,0) set CurDT=NoteDT "RTN","TMGTIUOJ",88,0) "RTN","TMGTIUOJ",89,0) ;"set result="Resp="_$$RESP^TIULO(+$get(DFN))_", " "RTN","TMGTIUOJ",90,0) ;"set result="Pulse="_$$PULSE^TIULO(+$get(DFN))_", " "RTN","TMGTIUOJ",91,0) "RTN","TMGTIUOJ",92,0) do FormatVitals(.result,$$TEMP^TIULO(+$get(DFN)),"T",.CurDT,.NoteDT) "RTN","TMGTIUOJ",93,0) do FormatVitals(.result,$$BP^TIULO(+$get(DFN)),"BP",.CurDT,.NoteDT) "RTN","TMGTIUOJ",94,0) do FormatVitals(.result,$$RESP^TIULO(+$get(DFN)),"R",.CurDT,.NoteDT) "RTN","TMGTIUOJ",95,0) do FormatVitals(.result,$$PULSE^TIULO(+$get(DFN)),"P",.CurDT,.NoteDT) "RTN","TMGTIUOJ",96,0) set Wt=$$WEIGHT^TIULO(+$get(DFN)) "RTN","TMGTIUOJ",97,0) set Ht=$$HEIGHT^TIULO(+$get(DFN)) "RTN","TMGTIUOJ",98,0) set Ht=$$FormatHeight(Ht,.PtAge) "RTN","TMGTIUOJ",99,0) do FormatVitals(.result,Wt,"Wt",.CurDT,.NoteDT,1) "RTN","TMGTIUOJ",100,0) if (Wt'="")&(Ht'="") set result=result_$char(10)_$char(9) "RTN","TMGTIUOJ",101,0) do FormatVitals(.result,Ht,"Ht",.CurDT,.NoteDT,1) "RTN","TMGTIUOJ",102,0) ;"set result=result_";" ;temp!! "RTN","TMGTIUOJ",103,0) "RTN","TMGTIUOJ",104,0) ;"Now calculate BMI if Wt & Ht available "RTN","TMGTIUOJ",105,0) ;" BMI=kg/meters^2 "RTN","TMGTIUOJ",106,0) if (Wt'="")&(Ht'="") do "RTN","TMGTIUOJ",107,0) . new sWt,sHt "RTN","TMGTIUOJ",108,0) . new nWt,nHt,s1,BMI "RTN","TMGTIUOJ",109,0) . set sWt=$$RemoveDT(Wt) "RTN","TMGTIUOJ",110,0) . set sHt=$$RemoveDT(Ht) "RTN","TMGTIUOJ",111,0) . set s1=$piece(sWt,"[",2) ;"convert '200 lb [91.2 kg]' --> '91.2 kg]' "RTN","TMGTIUOJ",112,0) . set nWt=+$piece(s1," ",1) ;"convert '91.2 kg]' --> 91.2 "RTN","TMGTIUOJ",113,0) . set s1=$piece(sHt,"[",2) ;"convert '56 in [130 cm]' --> '130 cm]' "RTN","TMGTIUOJ",114,0) . set nHt=+$piece(s1," ",1) ;"convert '130 cm]' --> 130 "RTN","TMGTIUOJ",115,0) . set nHt=nHt/100 ;"convert centimeters to meters "RTN","TMGTIUOJ",116,0) . if nHt>0 do "RTN","TMGTIUOJ",117,0) . . new tempBMI,iBMI,Digit "RTN","TMGTIUOJ",118,0) . . new MSqr set MSqr=(nHt*nHt) "RTN","TMGTIUOJ",119,0) . . set tempBMI=(nWt/MSqr) "RTN","TMGTIUOJ",120,0) . . set Digit=(((tempBMI-(tempBMI\1))*10)\1)/10 "RTN","TMGTIUOJ",121,0) . . set BMI=(tempBMI\1)+Digit "RTN","TMGTIUOJ",122,0) . . do FormatVitals(.result,BMI,"BMI",.CurDT) "RTN","TMGTIUOJ",123,0) . . if BMI<18.5 do "RTN","TMGTIUOJ",124,0) . . . set result=result_" (<18.5 = ""UNDER-WT"")" "RTN","TMGTIUOJ",125,0) . . else if BMI<25.01 do "RTN","TMGTIUOJ",126,0) . . . set result=result_" (18.5-25 = ""HEALTHY"")" "RTN","TMGTIUOJ",127,0) . . else if BMI<30.01 do "RTN","TMGTIUOJ",128,0) . . . set result=result_" (25-30 = ""OVER-WT"")" "RTN","TMGTIUOJ",129,0) . . else if BMI<40.01 do "RTN","TMGTIUOJ",130,0) . . . set result=result_" (30-40 = ""OBESE"")" "RTN","TMGTIUOJ",131,0) . . else do "RTN","TMGTIUOJ",132,0) . . . set result=result_" (>40 = ""VERY OBESE"")" "RTN","TMGTIUOJ",133,0) . . new idealLb1,idealLb2 "RTN","TMGTIUOJ",134,0) . . set idealLb1=((18.5*MSqr)*2.2)\1 "RTN","TMGTIUOJ",135,0) . . set idealLb2=((25*MSqr)*2.2)\1 "RTN","TMGTIUOJ",136,0) . . set result=result_$char(10)_$char(9)_"(Ideal Wt="_idealLb1_"-"_idealLb2_" lbs" "RTN","TMGTIUOJ",137,0) . . if Wt>idealLb2 set result=result_"; "_(Wt-idealLb2)_" lbs over weight)" "RTN","TMGTIUOJ",138,0) . . else if Wt0)&($get(NoteDT)'="")&($get(ForceShow)'=1) quit ;"If NoteDT specified, don't allow delta>0 "RTN","TMGTIUOJ",173,0) . . if (result'="")&($extract(result,$length(result))'=$char(9)) set result=result_", " "RTN","TMGTIUOJ",174,0) . . set CurDT=DT "RTN","TMGTIUOJ",175,0) . . if (Delta>0)&(DT'="") set result=result_"("_DT_") " "RTN","TMGTIUOJ",176,0) . . set result=result_Label_" "_s "RTN","TMGTIUOJ",177,0) FVDone "RTN","TMGTIUOJ",178,0) quit "RTN","TMGTIUOJ",179,0) "RTN","TMGTIUOJ",180,0) "RTN","TMGTIUOJ",181,0) RemoveDT(S,DT) "RTN","TMGTIUOJ",182,0) ;"Purpose: to remove a date-Time string, and return in DT "RTN","TMGTIUOJ",183,0) ;" i.e. turn this: "RTN","TMGTIUOJ",184,0) ;" 127/56 (12/25/04 16:50) "RTN","TMGTIUOJ",185,0) ;" into these: "RTN","TMGTIUOJ",186,0) ;" '127/56' and '12/25/04 16:50' "RTN","TMGTIUOJ",187,0) ;"Input: S -- a string as above "RTN","TMGTIUOJ",188,0) ;" DT -- [Optional] an OUT parameter... must PASS BY REFERENCE "RTN","TMGTIUOJ",189,0) ;"result: returns input string with (date-time) removed "RTN","TMGTIUOJ",190,0) ;" Date-Time is returned in DT if passed by reference. "RTN","TMGTIUOJ",191,0) "RTN","TMGTIUOJ",192,0) new result set result=$get(S) "RTN","TMGTIUOJ",193,0) if result="" goto RDTDone "RTN","TMGTIUOJ",194,0) "RTN","TMGTIUOJ",195,0) set result=$piece(S,"(",1) "RTN","TMGTIUOJ",196,0) set result=$$Trim^TMGSTUTL(.result) "RTN","TMGTIUOJ",197,0) set DT=$piece(S,"(",2) "RTN","TMGTIUOJ",198,0) set DT=$piece(DT,")",1) "RTN","TMGTIUOJ",199,0) set DT=$$Trim^TMGSTUTL(.DT) "RTN","TMGTIUOJ",200,0) "RTN","TMGTIUOJ",201,0) quit result "RTN","TMGTIUOJ",202,0) "RTN","TMGTIUOJ",203,0) "RTN","TMGTIUOJ",204,0) RDTDone "RTN","TMGTIUOJ",205,0) quit result "RTN","TMGTIUOJ",206,0) "RTN","TMGTIUOJ",207,0) RemoveTime(DT) "RTN","TMGTIUOJ",208,0) ;"Purpose: to remove the time from a date/time string "RTN","TMGTIUOJ",209,0) ;"Input: DT -- the date/time string, i.e. '2/24/05 16:50' "RTN","TMGTIUOJ",210,0) ;"result: returns just the date, i.e. '2/25/05' "RTN","TMGTIUOJ",211,0) "RTN","TMGTIUOJ",212,0) new result "RTN","TMGTIUOJ",213,0) "RTN","TMGTIUOJ",214,0) set result=$piece(DT," ",1) "RTN","TMGTIUOJ",215,0) "RTN","TMGTIUOJ",216,0) quit result "RTN","TMGTIUOJ",217,0) "RTN","TMGTIUOJ",218,0) "RTN","TMGTIUOJ",219,0) FormatHeight(HtS,PtAge) "RTN","TMGTIUOJ",220,0) ;"Purpose: to remove centimeters from patient's height for adults "RTN","TMGTIUOJ",221,0) ;"Input: Ht, a height string, e.g. '74 in [154 cm]' "RTN","TMGTIUOJ",222,0) ;" PtAge, patient's age in years "RTN","TMGTIUOJ",223,0) ;"Result: returns patient height, with [154 cm] removed, if age > 16 "RTN","TMGTIUOJ",224,0) "RTN","TMGTIUOJ",225,0) new result set result=$get(HtS) "RTN","TMGTIUOJ",226,0) "RTN","TMGTIUOJ",227,0) if $get(PtAge)'<16 do "RTN","TMGTIUOJ",228,0) . set result=$piece(HtS,"[",1) "RTN","TMGTIUOJ",229,0) "RTN","TMGTIUOJ",230,0) quit result "RTN","TMGTIUOJ",231,0) "RTN","TMGTIUOJ",232,0) "RTN","TMGTIUOJ",233,0) DateDelta(RefDT,DT) "RTN","TMGTIUOJ",234,0) ;"Purpose: To determine the number of days between DT and now "RTN","TMGTIUOJ",235,0) ;" i.e. How many days DT was before RefDT. "RTN","TMGTIUOJ",236,0) ;"Input:RefDT -- a reference/baseline date/time string "RTN","TMGTIUOJ",237,0) ;" if not supplied, Current date/time used as default. "RTN","TMGTIUOJ",238,0) ;" DT -- a date/time string (i.e. '12/25/04 16:50') "RTN","TMGTIUOJ",239,0) ;"Result: Return number of days between DT and RefDT "RTN","TMGTIUOJ",240,0) ;" Positive numbers used when DT occured before current date "RTN","TMGTIUOJ",241,0) ;" i.e. result=RefDT-DT "RTN","TMGTIUOJ",242,0) "RTN","TMGTIUOJ",243,0) new iNowDT,iRefDT,iDT ;internal format of dates "RTN","TMGTIUOJ",244,0) new result set result=0 "RTN","TMGTIUOJ",245,0) "RTN","TMGTIUOJ",246,0) ;"write "DT='",DT,"'",! "RTN","TMGTIUOJ",247,0) ;"set iDT=$$IDATE^TIULC(.DT) ;"Convert date into internal "RTN","TMGTIUOJ",248,0) ;"write "iDT=",iDT,! "RTN","TMGTIUOJ",249,0) set X=DT do ^%DT set iDT=Y ;"Convert date into internal "RTN","TMGTIUOJ",250,0) if $get(RefDT)="" set iRefDT=$$DT^XLFDT "RTN","TMGTIUOJ",251,0) else set X=RefDT do ^%DT set iRefDT=Y ;"Convert date into internal "RTN","TMGTIUOJ",252,0) ;"write "iDT=",iDT,! "RTN","TMGTIUOJ",253,0) ;"set iNowDT=$$DT^XLFDT "RTN","TMGTIUOJ",254,0) ;"write "iNowDT=",iNowDT,! "RTN","TMGTIUOJ",255,0) ;"set result=$$FMDIFF^XLFDT(iNowDT,iDT) "RTN","TMGTIUOJ",256,0) set result=$$FMDIFF^XLFDT(iRefDT,iDT) "RTN","TMGTIUOJ",257,0) "RTN","TMGTIUOJ",258,0) quit result "RTN","TMGTIUOJ",259,0) "RTN","TMGTIUOJ",260,0) "RTN","TMGTIUOJ",261,0) "RTN","TMGTIUOJ",262,0) TMGVISDT(TIU) ; Visit date "RTN","TMGTIUOJ",263,0) ;"Purpose: Return a string for date of visit "RTN","TMGTIUOJ",264,0) ;"Note: This is based on the function VISDATE^TIULO1(TIU) "RTN","TMGTIUOJ",265,0) ;" However, that function seemed to return the appointment date associated "RTN","TMGTIUOJ",266,0) ;" with a note, rather than the specified date of the note "RTN","TMGTIUOJ",267,0) ;" Also, this will return date only--not time. "RTN","TMGTIUOJ",268,0) ;"Input: TIU -- this is an array created by TIU system that "RTN","TMGTIUOJ",269,0) ;" contains information about the document being "RTN","TMGTIUOJ",270,0) ;" edited/created. I believe it has this this structure: "RTN","TMGTIUOJ",271,0) ;" TIU("VSTR") = LOC;VDT;VTYP "RTN","TMGTIUOJ",272,0) ;" TIU("VISIT") = Visit File IFN^date? "RTN","TMGTIUOJ",273,0) ;" TIU("LOC") "RTN","TMGTIUOJ",274,0) ;" TIU("VLOC") "RTN","TMGTIUOJ",275,0) ;" TIU("STOP") = mark to defer workload "RTN","TMGTIUOJ",276,0) ;" TIU("TYPE")=1^title DA^title Name i.e.: 1^128^OFFICE VISIT^OFFICE VISIT "RTN","TMGTIUOJ",277,0) ;" TIU("SVC")=service, e.g. "FAMILY PRACTICE" "RTN","TMGTIUOJ",278,0) ;" TIU("EDT")=TIUEDT^DateStr = event begin time: FMDate^DateStr "RTN","TMGTIUOJ",279,0) ;" TIU("LDT")=TIULDT^DateStr = event end time: FMDate^DateStr "RTN","TMGTIUOJ",280,0) ;" TIU("VSTR")=LOC;VDT;VTYP e.g. "x;x;OFFICE VISIT" "RTN","TMGTIUOJ",281,0) ;" TIU("VISIT")=Visit File IFN "RTN","TMGTIUOJ",282,0) ;" TIU("LOC")=TIULOC "RTN","TMGTIUOJ",283,0) ;" TIU("VLOC")=TIULOC "RTN","TMGTIUOJ",284,0) ;" TIU("STOP")=0 ;"0=FALSE, don't worry about stop codes. "RTN","TMGTIUOJ",285,0) ;"Output: returns result "RTN","TMGTIUOJ",286,0) "RTN","TMGTIUOJ",287,0) N TIUX,TIUY "RTN","TMGTIUOJ",288,0) new result "RTN","TMGTIUOJ",289,0) "RTN","TMGTIUOJ",290,0) ;set result="VISIT="_$get(TIU("VISIT"))_" " "RTN","TMGTIUOJ",291,0) ;set result=result_"VSTR="_$get(TIU("VSTR"))_" " "RTN","TMGTIUOJ",292,0) ;set result=result_"EDT="_$get(TIU("EDT"))_" " "RTN","TMGTIUOJ",293,0) ;set result=result_"LDT="_$get(TIU("LDT"))_" " "RTN","TMGTIUOJ",294,0) "RTN","TMGTIUOJ",295,0) if $get(TIU("VISIT"))'="" do "RTN","TMGTIUOJ",296,0) . set result=$piece(TIU("VISIT"),U,2) "RTN","TMGTIUOJ",297,0) else if $get(TIU("VSTR"))'="" do "RTN","TMGTIUOJ",298,0) . set result=$piece(TIU("VSTR"),";",2) "RTN","TMGTIUOJ",299,0) else do "RTN","TMGTIUOJ",300,0) . set result="(Visit Date Unknown)" "RTN","TMGTIUOJ",301,0) "RTN","TMGTIUOJ",302,0) if +result>0 do "RTN","TMGTIUOJ",303,0) . set result=$$DATE^TIULS(result,"MM/DD/YY HR:MIN") "RTN","TMGTIUOJ",304,0) . set result=$piece(result," ",1) ;"cut off time. "RTN","TMGTIUOJ",305,0) "RTN","TMGTIUOJ",306,0) VDDone quit result "RTN","TMGTIUOJ",307,0) "RTN","TMGTIUOJ",308,0) "RTN","TMGTIUOJ",309,0) FNAME(DFN) "RTN","TMGTIUOJ",310,0) ;"Purpose: Return Patient's first name "RTN","TMGTIUOJ",311,0) ;"Input: DFN -- the patient's unique ID (record#) "RTN","TMGTIUOJ",312,0) ;"Output: returns result "RTN","TMGTIUOJ",313,0) new name "RTN","TMGTIUOJ",314,0) "RTN","TMGTIUOJ",315,0) set name=$piece($get(^DPT(DFN,0)),"^",1) "RTN","TMGTIUOJ",316,0) set name=$piece(name,",",2) "RTN","TMGTIUOJ",317,0) set name=$piece(name," ",1) "RTN","TMGTIUOJ",318,0) set name=$$CapWords^TMGSTUTL(name) "RTN","TMGTIUOJ",319,0) "RTN","TMGTIUOJ",320,0) quit name "RTN","TMGTIUOJ",321,0) "RTN","TMGTIUOJ",322,0) "RTN","TMGTIUOJ",323,0) MNAME(DFN) "RTN","TMGTIUOJ",324,0) ;"Purpose: Return Patient's middle name(s) "RTN","TMGTIUOJ",325,0) ;"Input: DFN -- the patient's unique ID (record#) "RTN","TMGTIUOJ",326,0) ;"Output: returns result "RTN","TMGTIUOJ",327,0) new name "RTN","TMGTIUOJ",328,0) "RTN","TMGTIUOJ",329,0) set name=$piece($get(^DPT(DFN,0)),"^",1) "RTN","TMGTIUOJ",330,0) set name=$piece(name,",",2) "RTN","TMGTIUOJ",331,0) set name=$piece(name," ",2,100) "RTN","TMGTIUOJ",332,0) set name=$$CapWords^TMGSTUTL(name) "RTN","TMGTIUOJ",333,0) "RTN","TMGTIUOJ",334,0) quit name "RTN","TMGTIUOJ",335,0) "RTN","TMGTIUOJ",336,0) "RTN","TMGTIUOJ",337,0) LNAME(DFN) "RTN","TMGTIUOJ",338,0) ;"Purpose: Return Patient's last name "RTN","TMGTIUOJ",339,0) ;"Input: DFN -- the patient's unique ID (record#) "RTN","TMGTIUOJ",340,0) ;"Output: returns result "RTN","TMGTIUOJ",341,0) "RTN","TMGTIUOJ",342,0) new name "RTN","TMGTIUOJ",343,0) "RTN","TMGTIUOJ",344,0) set name=$piece($get(^DPT(DFN,0)),"^",1) "RTN","TMGTIUOJ",345,0) set name=$piece(name,",",1) "RTN","TMGTIUOJ",346,0) set name=$$CapWords^TMGSTUTL(name) "RTN","TMGTIUOJ",347,0) "RTN","TMGTIUOJ",348,0) quit name "RTN","TMGTIUOJ",349,0) "RTN","TMGTIUOJ",350,0) "RTN","TMGTIUOJ",351,0) NICENAME(DFN) "RTN","TMGTIUOJ",352,0) ;"Purpose: Return Patient's name format: Firstname Middlename Lastname "RTN","TMGTIUOJ",353,0) ;" only the first letter of each name capitalized. "RTN","TMGTIUOJ",354,0) ;"Input: DFN -- the patient's unique ID (record#) "RTN","TMGTIUOJ",355,0) ;"Output: returns result "RTN","TMGTIUOJ",356,0) "RTN","TMGTIUOJ",357,0) new name "RTN","TMGTIUOJ",358,0) "RTN","TMGTIUOJ",359,0) set name=$piece($get(^DPT(DFN,0)),"^",1) "RTN","TMGTIUOJ",360,0) set name=$piece(name,",",2)_" "_$piece(name,",",1) ;"put first name first "RTN","TMGTIUOJ",361,0) set name=$$CapWords^TMGSTUTL(name) "RTN","TMGTIUOJ",362,0) "RTN","TMGTIUOJ",363,0) quit name "RTN","TMGTIUOJ",364,0) "RTN","TMGTIUOJ",365,0) "RTN","TMGTIUOJ",366,0) PHONENUM(DFN) "RTN","TMGTIUOJ",367,0) ;"Purpose: to return the patient's phone number "RTN","TMGTIUOJ",368,0) ;"Input: DFN -- the patient's unique ID (record#) "RTN","TMGTIUOJ",369,0) ;"Output: returns result "RTN","TMGTIUOJ",370,0) "RTN","TMGTIUOJ",371,0) new result set result="" "RTN","TMGTIUOJ",372,0) if +$get(DFN)=0 goto PNDone "RTN","TMGTIUOJ",373,0) "RTN","TMGTIUOJ",374,0) set result=$$GET1^DIQ(2,DFN_",",.131) "RTN","TMGTIUOJ",375,0) "RTN","TMGTIUOJ",376,0) set result=$translate(result," ","") "RTN","TMGTIUOJ",377,0) if $length(result)=10 do "RTN","TMGTIUOJ",378,0) . new temp set temp=result "RTN","TMGTIUOJ",379,0) . set result="("_$extract(result,1,3)_") "_$extract(result,4,6)_"-"_$extract(result,7,10) "RTN","TMGTIUOJ",380,0) "RTN","TMGTIUOJ",381,0) if $length(result)=7 do "RTN","TMGTIUOJ",382,0) . new temp set temp=result "RTN","TMGTIUOJ",383,0) . set result=$extract(result,1,3)_"-"_$extract(result,4,7) "RTN","TMGTIUOJ",384,0) "RTN","TMGTIUOJ",385,0) PNDone "RTN","TMGTIUOJ",386,0) quit result "RTN","TMGTIUOJ",387,0) "RTN","TMGTIUOJ",388,0) "RTN","TMGTIUOJ",389,0) ;"------------------------------------------------------------- "RTN","TMGTIUOJ",390,0) ;"------------------------------------------------------------- "RTN","TMGTIUOJ",391,0) WTTREND(DFN,TIU) "RTN","TMGTIUOJ",392,0) ;"Purpose: return text showing patient's trend in change of weight. "RTN","TMGTIUOJ",393,0) ;" e.g. 215 <== 212 <== 256 <== 278 "RTN","TMGTIUOJ",394,0) ;"Input: DFN=the Patient's IEN in file #2 "RTN","TMGTIUOJ",395,0) ;" TIU=PASS BY REFERENCE. Should be an Array of TIU note info "RTN","TMGTIUOJ",396,0) ;" See documentation in VITALS(DFN,TIU) "RTN","TMGTIUOJ",397,0) ;"Results: Returns string describing changes in weight. "RTN","TMGTIUOJ",398,0) "RTN","TMGTIUOJ",399,0) new result set result="" "RTN","TMGTIUOJ",400,0) new Date set Date=$get(TIU("EDT")) "RTN","TMGTIUOJ",401,0) if +Date'>0 do "RTN","TMGTIUOJ",402,0) . set result="(No wts available)" "RTN","TMGTIUOJ",403,0) . goto WTTRDone "RTN","TMGTIUOJ",404,0) "RTN","TMGTIUOJ",405,0) new Array "RTN","TMGTIUOJ",406,0) do GetPriorVital(.DFN,Date,"WEIGHT",.Array) "RTN","TMGTIUOJ",407,0) "RTN","TMGTIUOJ",408,0) new Date set Date="" "RTN","TMGTIUOJ",409,0) for set Date=$order(Array(Date),-1) quit:(+Date'>0) do "RTN","TMGTIUOJ",410,0) . if result'="" set result=result_" <== " "RTN","TMGTIUOJ",411,0) . set result=result_$order(Array(Date,"")) "RTN","TMGTIUOJ",412,0) "RTN","TMGTIUOJ",413,0) set result="Wt trend: "_result "RTN","TMGTIUOJ",414,0) "RTN","TMGTIUOJ",415,0) WTTRDone quit result "RTN","TMGTIUOJ",416,0) "RTN","TMGTIUOJ",417,0) "RTN","TMGTIUOJ",418,0) WTDELTA(DFN,TIU) "RTN","TMGTIUOJ",419,0) ;"Purpose: return text showing patient's change in weight. "RTN","TMGTIUOJ",420,0) ;"Input: DFN=the Patient's IEN in file #2 "RTN","TMGTIUOJ",421,0) ;" TIU=PASS BY REFERENCE. Should be an Array of TIU note info "RTN","TMGTIUOJ",422,0) ;" See documentation in VITALS(DFN,TIU) "RTN","TMGTIUOJ",423,0) ;"Results: Returns string describing change in weight. "RTN","TMGTIUOJ",424,0) "RTN","TMGTIUOJ",425,0) new result set result="Weight " "RTN","TMGTIUOJ",426,0) new delta "RTN","TMGTIUOJ",427,0) new Date set Date=$get(TIU("EDT")) ;"Episode date "RTN","TMGTIUOJ",428,0) if +Date'>0 do goto WTDDone "RTN","TMGTIUOJ",429,0) . set result=result_"change: ?" "RTN","TMGTIUOJ",430,0) "RTN","TMGTIUOJ",431,0) new Array "RTN","TMGTIUOJ",432,0) do GetPriorVital(.DFN,Date,"WEIGHT",.Array) "RTN","TMGTIUOJ",433,0) "RTN","TMGTIUOJ",434,0) new NTLast,Last "RTN","TMGTIUOJ",435,0) do GetLast2(.Array,.NTLast,.Last) "RTN","TMGTIUOJ",436,0) set Last=+Last "RTN","TMGTIUOJ",437,0) set NTLast=+NTLast "RTN","TMGTIUOJ",438,0) set delta=Last-NTLast "RTN","TMGTIUOJ",439,0) if delta>0 set result=result_"up "_delta_" lbs. " "RTN","TMGTIUOJ",440,0) else if delta<0 set result=result_"down "_-delta_" lbs. " "RTN","TMGTIUOJ",441,0) else do "RTN","TMGTIUOJ",442,0) . if Last=0 set result=result_"change: ?" quit "RTN","TMGTIUOJ",443,0) . set result=result_"unchanged. " "RTN","TMGTIUOJ",444,0) "RTN","TMGTIUOJ",445,0) if (Last>0)&(NTLast>0) do "RTN","TMGTIUOJ",446,0) . set result=result_"("_Last_" <== "_NTLast_" prior wt)" "RTN","TMGTIUOJ",447,0) "RTN","TMGTIUOJ",448,0) WTDDone quit result "RTN","TMGTIUOJ",449,0) "RTN","TMGTIUOJ",450,0) "RTN","TMGTIUOJ",451,0) GetLast2(Array,NTLast,Last) "RTN","TMGTIUOJ",452,0) ;"Purpose: Returns last 2 values in array (as created by GetPriorVital) "RTN","TMGTIUOJ",453,0) ;"Input: Array -- PASS BY REFERENCE. Array as created by GetPriorVital "RTN","TMGTIUOJ",454,0) ;" Array(FMDate,Value)="" "RTN","TMGTIUOJ",455,0) ;" Array(FMDate,Value)="" "RTN","TMGTIUOJ",456,0) ;" NTLast --PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGTIUOJ",457,0) ;" Next-To-Last value in array list (sorted by ascending date) "RTN","TMGTIUOJ",458,0) ;" Last -- PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGTIUOJ",459,0) ;" Last value in array list (sorted by ascending date) "RTN","TMGTIUOJ",460,0) ;"Results: None "RTN","TMGTIUOJ",461,0) "RTN","TMGTIUOJ",462,0) new NTLastDate,LastDate "RTN","TMGTIUOJ",463,0) set LastDate="" "RTN","TMGTIUOJ",464,0) set LastDate=$order(Array(""),-1) "RTN","TMGTIUOJ",465,0) set Last=$order(Array(LastDate,"")) "RTN","TMGTIUOJ",466,0) "RTN","TMGTIUOJ",467,0) set NTLastDate=$order(Array(LastDate),-1) "RTN","TMGTIUOJ",468,0) set NTLast=$order(Array(NTLastDate,"")) "RTN","TMGTIUOJ",469,0) "RTN","TMGTIUOJ",470,0) quit "RTN","TMGTIUOJ",471,0) "RTN","TMGTIUOJ",472,0) "RTN","TMGTIUOJ",473,0) GetPriorVital(DFN,Date,Vital,Array) "RTN","TMGTIUOJ",474,0) ;"Purpose: To retrieve a list of prior vital entries for a patient "RTN","TMGTIUOJ",475,0) ;" Note: entries up to *AND INCLUDING* the current day will be retrieved "RTN","TMGTIUOJ",476,0) ;"Input: DFN: the IEN of the patient, in file #2 (PATIENT) "RTN","TMGTIUOJ",477,0) ;" Date: Date (in FM format) of the current event. Entries up to "RTN","TMGTIUOJ",478,0) ;" AND INCLUDING this date will be retrieved. "RTN","TMGTIUOJ",479,0) ;" Vital: Vital to retrieve, GMRV VITAL TYPE file (#120.51) "RTN","TMGTIUOJ",480,0) ;" Must be .01 value of a valid record "RTN","TMGTIUOJ",481,0) ;" E.g. "ABDOMINAL GIRTH","BLOOD PRESSURE","HEIGHT", etc. "RTN","TMGTIUOJ",482,0) ;" Array: PASS BY REFERENCE, an OUT PARAMETER. Prior values killed. Format as below. "RTN","TMGTIUOJ",483,0) ;"Output: Array is filled as follows: "RTN","TMGTIUOJ",484,0) ;" Array(FMDate,Value)="" "RTN","TMGTIUOJ",485,0) ;" Array(FMDate,Value)="" "RTN","TMGTIUOJ",486,0) ;" Or array will be empty if no values found. "RTN","TMGTIUOJ",487,0) ;"Result: None "RTN","TMGTIUOJ",488,0) "RTN","TMGTIUOJ",489,0) if +$get(DFN)=0 goto GPVDone "RTN","TMGTIUOJ",490,0) if +$get(Date)=0 goto GPVDone "RTN","TMGTIUOJ",491,0) if $get(Vital)="" goto GPVDone "RTN","TMGTIUOJ",492,0) new VitalTIEN "RTN","TMGTIUOJ",493,0) set VitalTIEN=+$order(^GMRD(120.51,"B",Vital,"")) "RTN","TMGTIUOJ",494,0) if VitalTIEN'>0 goto GPVDone "RTN","TMGTIUOJ",495,0) kill Array "RTN","TMGTIUOJ",496,0) "RTN","TMGTIUOJ",497,0) new IEN set IEN="" "RTN","TMGTIUOJ",498,0) new X,X1,X2,%Y "RTN","TMGTIUOJ",499,0) for set IEN=$order(^GMR(120.5,"C",DFN,IEN)) quit:(+IEN'>0) do "RTN","TMGTIUOJ",500,0) . new s set s=$get(^GMR(120.5,IEN,0)) "RTN","TMGTIUOJ",501,0) . if +$piece(s,"^",3)'=VitalTIEN quit "RTN","TMGTIUOJ",502,0) . set X1=Date "RTN","TMGTIUOJ",503,0) . set X2=+$piece(s,"^",1) "RTN","TMGTIUOJ",504,0) . do ^%DTC ;"date delta "RTN","TMGTIUOJ",505,0) . if %Y'=1 quit ;"data unworkable "RTN","TMGTIUOJ",506,0) . if X>-1 set Array(+$piece(s,"^",1),+$piece(s,"^",8))="" "RTN","TMGTIUOJ",507,0) "RTN","TMGTIUOJ",508,0) GPVDone quit "RTN","TMGTIUOJ",509,0) "RTN","TMGTIUOJ",510,0) ;"------------------------------------------------------------- "RTN","TMGTIUOJ",511,0) ;"------------------------------------------------------------- "RTN","TMGTIUOJ",512,0) "RTN","TMGTIUOJ",513,0) GetNotesList(DFN,List,IncDays) "RTN","TMGTIUOJ",514,0) ;"Purpose: Return a list of notes for patient in given time span "RTN","TMGTIUOJ",515,0) ;"Input: DFN -- IEN in PATIENT file (the patient record number) "RTN","TMGTIUOJ",516,0) ;" List -- PASS BY REFERENCE, an OUT PARAMETER. (Format below) "RTN","TMGTIUOJ",517,0) ;" IncDays -- Number of DAYS to search in. "RTN","TMGTIUOJ",518,0) ;" E.g. 4 --> get notes from last 4 days "RTN","TMGTIUOJ",519,0) ;"Output: List format: "RTN","TMGTIUOJ",520,0) ;" List(FMTimeOfNote,IEN8925)="" "RTN","TMGTIUOJ",521,0) ;" List(FMTimeOfNote,IEN8925)="" "RTN","TMGTIUOJ",522,0) ;" List(FMTimeOfNote,IEN8925)="" "RTN","TMGTIUOJ",523,0) ;" If no notes found, then array is left blank. Prior entries KILLED "RTN","TMGTIUOJ",524,0) ;"Results: none "RTN","TMGTIUOJ",525,0) "RTN","TMGTIUOJ",526,0) kill List "RTN","TMGTIUOJ",527,0) set DFN=+$get(DFN) "RTN","TMGTIUOJ",528,0) if DFN'>0 goto GNLDone "RTN","TMGTIUOJ",529,0) set IncDays=+$get(IncDays) "RTN","TMGTIUOJ",530,0) new temp,i "RTN","TMGTIUOJ",531,0) merge temp=^TIU(8925,"C",DFN) "RTN","TMGTIUOJ",532,0) set IEN="" "RTN","TMGTIUOJ",533,0) for set IEN=$order(temp(IEN)) quit:(IEN="") do "RTN","TMGTIUOJ",534,0) . new X,X1,X2,%Y,StartDate "RTN","TMGTIUOJ",535,0) . do NOW^%DTC set X1=X "RTN","TMGTIUOJ",536,0) . set StartDate=$piece($get(^TIU(8925,IEN,0)),"^",7) "RTN","TMGTIUOJ",537,0) . set X2=StartDate "RTN","TMGTIUOJ",538,0) . do ^%DTC ;"calculate X=X1-X2. Returns #days between "RTN","TMGTIUOJ",539,0) . if X>IncDays quit "RTN","TMGTIUOJ",540,0) . set List(StartDate,IEN)="" "RTN","TMGTIUOJ",541,0) "RTN","TMGTIUOJ",542,0) GNLDone quit "RTN","TMGTIUOJ",543,0) "RTN","TMGTIUOJ",544,0) "RTN","TMGTIUOJ",545,0) ExtractSpecial(IEN8925,StartMarkerS,EndMarkerS,Array) "RTN","TMGTIUOJ",546,0) ;"Purpose: To scan the REPORT TEXT field in given document and return "RTN","TMGTIUOJ",547,0) ;" paragraph of text that is started by StartMarkerS, and ended by EndMarkerS. "RTN","TMGTIUOJ",548,0) ;" I.E. Search for a line that contains MarkerS. Return that line and "RTN","TMGTIUOJ",549,0) ;" all following lines until line found with EndMarkerS, or "RTN","TMGTIUOJ",550,0) ;" end of text. "RTN","TMGTIUOJ",551,0) ;"Input: IEN8925 -- IEN in file 8925 (TIU DOCUMENT) "RTN","TMGTIUOJ",552,0) ;" StartMarkerS -- the string to search for that indicates start of block "RTN","TMGTIUOJ",553,0) ;" EndMarkerS -- the string to search for that indicates the end of block. "RTN","TMGTIUOJ",554,0) ;" NOTE: if EndMarkerS="BLANK_LINE", then search is "RTN","TMGTIUOJ",555,0) ;" ended when a blank line is encountered. "RTN","TMGTIUOJ",556,0) ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. Prior values killed. "RTN","TMGTIUOJ",557,0) ;" Format: Array(0)=MaxLineCount "RTN","TMGTIUOJ",558,0) ;" Array(1)="Text line 1" "RTN","TMGTIUOJ",559,0) ;" Array(2)="Text line 2" ... "RTN","TMGTIUOJ",560,0) ;"Result: 1 if data found, otherwise 0 "RTN","TMGTIUOJ",561,0) "RTN","TMGTIUOJ",562,0) new result set result=0 "RTN","TMGTIUOJ",563,0) kill Array "RTN","TMGTIUOJ",564,0) set IEN8925=+$get(IEN8925) "RTN","TMGTIUOJ",565,0) if IEN8925'>0 goto ESDone "RTN","TMGTIUOJ",566,0) if $data(^TIU(8925,IEN8925,"TEXT"))'>0 goto ESDone "RTN","TMGTIUOJ",567,0) if $get(StartMarkerS)="" goto ESDone "RTN","TMGTIUOJ",568,0) if $get(EndMarkerS)="" goto ESDone "RTN","TMGTIUOJ",569,0) new line,i,BlockFound,Done "RTN","TMGTIUOJ",570,0) set line=0,i=0,BlockFound=0,Done=0 "RTN","TMGTIUOJ",571,0) for set line=$order(^TIU(8925,IEN8925,"TEXT",line)) quit:(line="")!Done do "RTN","TMGTIUOJ",572,0) . new lineS set lineS=$get(^TIU(8925,IEN8925,"TEXT",line,0)) "RTN","TMGTIUOJ",573,0) . if (BlockFound=0) do quit ;"don't include header line with output "RTN","TMGTIUOJ",574,0) . . if lineS[StartMarkerS set BlockFound=1 "RTN","TMGTIUOJ",575,0) . if (BlockFound=1) do "RTN","TMGTIUOJ",576,0) . . set i=i+1,Array(0)=i "RTN","TMGTIUOJ",577,0) . . new s2 set s2=$$Trim^TMGSTUTL(lineS," ") "RTN","TMGTIUOJ",578,0) . . set s2=$$Trim^TMGSTUTL(s2,$char(9)) "RTN","TMGTIUOJ",579,0) . . set Array(i)=lineS "RTN","TMGTIUOJ",580,0) . . if s2="" set Array(i)=s2 "RTN","TMGTIUOJ",581,0) . . set result=1 "RTN","TMGTIUOJ",582,0) . . if (EndMarkerS="BLANK_LINE")&(s2="") set BlockFound=0,Done=1 quit "RTN","TMGTIUOJ",583,0) . . if lineS[EndMarkerS set BlockFound=0,Done=1 quit ;"include line with END marker "RTN","TMGTIUOJ",584,0) "RTN","TMGTIUOJ",585,0) ESDone quit result "RTN","TMGTIUOJ",586,0) "RTN","TMGTIUOJ",587,0) "RTN","TMGTIUOJ",588,0) MergeInto(partArray,masterArray) "RTN","TMGTIUOJ",589,0) ;"Purpose: to combine partArray into MasterArray. "RTN","TMGTIUOJ",590,0) ;"Input: partArray -- PASS BY REFERENCE "RTN","TMGTIUOJ",591,0) ;" masterArray -- PASS BY REFERENCE "RTN","TMGTIUOJ",592,0) ;"Note: Arrays are combine in a 'transparent' manner such that newer entries "RTN","TMGTIUOJ",593,0) ;" will overwrite older entries only for identical values. For example: "RTN","TMGTIUOJ",594,0) ;" -- BLOCK -- <--- MasterArray "RTN","TMGTIUOJ",595,0) ;" TSH = 1.56 "RTN","TMGTIUOJ",596,0) ;" LDL = 140 "RTN","TMGTIUOJ",597,0) ;" -- END BLOCK -- "RTN","TMGTIUOJ",598,0) ;" "RTN","TMGTIUOJ",599,0) ;" -- BLOCK -- <--- partArray "RTN","TMGTIUOJ",600,0) ;" LDL = 150 "RTN","TMGTIUOJ",601,0) ;" -- END BLOCK -- "RTN","TMGTIUOJ",602,0) ;" "RTN","TMGTIUOJ",603,0) ;" The above two blocks will result in this final array "RTN","TMGTIUOJ",604,0) ;" -- BLOCK -- "RTN","TMGTIUOJ",605,0) ;" TSH = 1.56 "RTN","TMGTIUOJ",606,0) ;" LDL = 150 <--- this value overwrote older entry "RTN","TMGTIUOJ",607,0) ;" -- END BLOCK -- "RTN","TMGTIUOJ",608,0) ;" "RTN","TMGTIUOJ",609,0) ;" In this mode, only data that is in a LABEL <--> VALUE format "RTN","TMGTIUOJ",610,0) ;" will be checked for newer vs older entries. All other "RTN","TMGTIUOJ",611,0) ;" lines will simply be included in one large summation block. "RTN","TMGTIUOJ",612,0) ;" And the allowed format for LABEL <--> VALUE will be: "RTN","TMGTIUOJ",613,0) ;" Label = value or "RTN","TMGTIUOJ",614,0) ;" Label : value "RTN","TMGTIUOJ",615,0) ;" "RTN","TMGTIUOJ",616,0) ;"Output: MasterArray will be filled as follows: "RTN","TMGTIUOJ",617,0) ;" Array("text line")="" "RTN","TMGTIUOJ",618,0) ;" Array("text line")="" "RTN","TMGTIUOJ",619,0) ;" Array("KEY-VALUE",KeyName)=Value "RTN","TMGTIUOJ",620,0) ;" Array("KEY-VALUE",KeyName,"LINE")=original line "RTN","TMGTIUOJ",621,0) "RTN","TMGTIUOJ",622,0) new lineNum set lineNum=0 "RTN","TMGTIUOJ",623,0) for set lineNum=$order(tempArray(lineNum)) quit:(+lineNum'>0) do "RTN","TMGTIUOJ",624,0) . new line set line=$get(tempArray(lineNum)) "RTN","TMGTIUOJ",625,0) . if (line["=")!(line[":") do "RTN","TMGTIUOJ",626,0) . . new key,shortKey,value,pivot "RTN","TMGTIUOJ",627,0) . . if line["=" set pivot="=" "RTN","TMGTIUOJ",628,0) . . else set pivot=":" "RTN","TMGTIUOJ",629,0) . . set key=$piece(line,pivot,1) "RTN","TMGTIUOJ",630,0) . . set shortKey=$$UP^XLFSTR($$Trim^TMGSTUTL(key)) "RTN","TMGTIUOJ",631,0) . . set value=$piece(line,pivot,2,999) "RTN","TMGTIUOJ",632,0) . . set Array("KEY-VALUE",shortKey)=value "RTN","TMGTIUOJ",633,0) . . set Array("KEY-VALUE",shortKey,"LINE")=line "RTN","TMGTIUOJ",634,0) . else do "RTN","TMGTIUOJ",635,0) . . if line="" quit "RTN","TMGTIUOJ",636,0) . . set Array(line)="" "RTN","TMGTIUOJ",637,0) "RTN","TMGTIUOJ",638,0) quit "RTN","TMGTIUOJ",639,0) "RTN","TMGTIUOJ",640,0) "RTN","TMGTIUOJ",641,0) GetSpecial(DFN,StartMarkerS,EndMarkerS,Months,Array,Mode) "RTN","TMGTIUOJ",642,0) ;"Purpose: to return a block of text from notes for patient, starting with "RTN","TMGTIUOJ",643,0) ;" StartMarkerS, and ending with EndMarkerS, searching backwards "RTN","TMGTIUOJ",644,0) ;" within time period of 'Months'. "RTN","TMGTIUOJ",645,0) ;"Input: DFN -- IEN of patient in PATIENT file. "RTN","TMGTIUOJ",646,0) ;" StartMarkerS -- the string to search for that indicates start of block "RTN","TMGTIUOJ",647,0) ;" EndMarkerS -- the string to search for that indicates the end of block. "RTN","TMGTIUOJ",648,0) ;" NOTE: if EndMarkerS="BLANK_LINE", then search is "RTN","TMGTIUOJ",649,0) ;" ended when a blank line is encountered. "RTN","TMGTIUOJ",650,0) ;" Months -- Number of Months to search in. "RTN","TMGTIUOJ",651,0) ;" E.g. 4 --> search in notes from last 4 months "RTN","TMGTIUOJ",652,0) ;" Array -- PASS BY REFERENCE. an OUT PARAMETER. Old values killed. Format below "RTN","TMGTIUOJ",653,0) ;" Mode: operation mode. As follows: "RTN","TMGTIUOJ",654,0) ;" 1 = return only block from most recent match "RTN","TMGTIUOJ",655,0) ;" 2 = compile all. "RTN","TMGTIUOJ",656,0) ;" In this mode, the search is carried out from oldest to most "RTN","TMGTIUOJ",657,0) ;" recent, and newer blocks overlay older ones in a 'transparent' "RTN","TMGTIUOJ",658,0) ;" manner such that newer entries will overwrite older entries "RTN","TMGTIUOJ",659,0) ;" only for identical values. For example: "RTN","TMGTIUOJ",660,0) ;" -- BLOCK -- <--- from date 1/1/1980 "RTN","TMGTIUOJ",661,0) ;" TSH = 1.56 "RTN","TMGTIUOJ",662,0) ;" LDL = 140 "RTN","TMGTIUOJ",663,0) ;" -- END BLOCK -- "RTN","TMGTIUOJ",664,0) ;" "RTN","TMGTIUOJ",665,0) ;" -- BLOCK -- <--- from date 2/1/1980 "RTN","TMGTIUOJ",666,0) ;" LDL = 150 "RTN","TMGTIUOJ",667,0) ;" -- END BLOCK -- "RTN","TMGTIUOJ",668,0) ;" "RTN","TMGTIUOJ",669,0) ;" The above two blocks will result in this final block "RTN","TMGTIUOJ",670,0) ;" -- BLOCK -- "RTN","TMGTIUOJ",671,0) ;" TSH = 1.56 "RTN","TMGTIUOJ",672,0) ;" LDL = 150 <--- this value overwrote older entry "RTN","TMGTIUOJ",673,0) ;" -- END BLOCK -- "RTN","TMGTIUOJ",674,0) ;" "RTN","TMGTIUOJ",675,0) ;" In this mode, only data that is in a LABEL <--> VALUE format "RTN","TMGTIUOJ",676,0) ;" will be checked for newer vs older entries. All other "RTN","TMGTIUOJ",677,0) ;" lines will simply be included in one large summation block. "RTN","TMGTIUOJ",678,0) ;" And the allowed format for LABEL <--> VALUE will be: "RTN","TMGTIUOJ",679,0) ;" Label = value or "RTN","TMGTIUOJ",680,0) ;" Label : value "RTN","TMGTIUOJ",681,0) ;" "RTN","TMGTIUOJ",682,0) ;"Output: Array will be filled as follows: "RTN","TMGTIUOJ",683,0) ;" Array("text line")="" "RTN","TMGTIUOJ",684,0) ;" Array("text line")="" "RTN","TMGTIUOJ",685,0) ;" Array("KEY-VALUE",KeyName)=Value "RTN","TMGTIUOJ",686,0) ;" Array("KEY-VALUE",KeyName,"LINE")=original line "RTN","TMGTIUOJ",687,0) "RTN","TMGTIUOJ",688,0) ;"Results: none "RTN","TMGTIUOJ",689,0) "RTN","TMGTIUOJ",690,0) new NotesList "RTN","TMGTIUOJ",691,0) kill Array "RTN","TMGTIUOJ",692,0) set DFN=+$get(DFN) "RTN","TMGTIUOJ",693,0) if DFN'>0 goto GSDone "RTN","TMGTIUOJ",694,0) "RTN","TMGTIUOJ",695,0) new IncDays set IncDays=+$get(Months)*30 "RTN","TMGTIUOJ",696,0) do GetNotesList(DFN,.NotesList,IncDays) "RTN","TMGTIUOJ",697,0) "RTN","TMGTIUOJ",698,0) new direction "RTN","TMGTIUOJ",699,0) if Mode=2 set direction=-1 "RTN","TMGTIUOJ",700,0) new Done set Done=0 "RTN","TMGTIUOJ",701,0) new StartTime set StartTime="" "RTN","TMGTIUOJ",702,0) for set StartTime=$order(NotesList(StartTime),direction) quit:(StartTime="")!Done do "RTN","TMGTIUOJ",703,0) . new IEN8925 set IEN8925="" "RTN","TMGTIUOJ",704,0) . for set IEN8925=$order(NotesList(StartTime,IEN8925)) quit:(+IEN8925'>0)!Done do "RTN","TMGTIUOJ",705,0) . . new tempArray "RTN","TMGTIUOJ",706,0) . . if $$ExtractSpecial(IEN8925,.StartMarkerS,.EndMarkerS,.tempArray)=1 do "RTN","TMGTIUOJ",707,0) . . . if Mode=1 do "RTN","TMGTIUOJ",708,0) . . . . merge Array=tempArray "RTN","TMGTIUOJ",709,0) . . . . set Done=1 "RTN","TMGTIUOJ",710,0) . . . else do "RTN","TMGTIUOJ",711,0) . . . . do MergeInto(.tempArray,.Array) "RTN","TMGTIUOJ",712,0) "RTN","TMGTIUOJ",713,0) GSDone "RTN","TMGTIUOJ",714,0) quit "RTN","TMGTIUOJ",715,0) "RTN","TMGTIUOJ",716,0) "RTN","TMGTIUOJ",717,0) Array2Str(Array) "RTN","TMGTIUOJ",718,0) ;"Purpose: to convert Array (as created by GetSpecial) into one long string "RTN","TMGTIUOJ",719,0) ;"Input: Array. Format as follows: "RTN","TMGTIUOJ",720,0) ;" Array("text line")="" "RTN","TMGTIUOJ",721,0) ;" Array("text line")="" "RTN","TMGTIUOJ",722,0) ;" Array("KEY-VALUE",KeyName)=Value "RTN","TMGTIUOJ",723,0) ;" Array("KEY-VALUE",KeyName,"LINE")=original line "RTN","TMGTIUOJ",724,0) "RTN","TMGTIUOJ",725,0) new result set result="" "RTN","TMGTIUOJ",726,0) new keyName set keyName="" "RTN","TMGTIUOJ",727,0) "RTN","TMGTIUOJ",728,0) ;"First, put in key-value lines "RTN","TMGTIUOJ",729,0) for set keyName=$order(Array("KEY-VALUE",keyName)) quit:(keyName="") do "RTN","TMGTIUOJ",730,0) . new line "RTN","TMGTIUOJ",731,0) . set line=$get(Array("KEY-VALUE",keyName,"LINE")) "RTN","TMGTIUOJ",732,0) . if result'="" set result=result_$char(13)_$char(10) "RTN","TMGTIUOJ",733,0) . set result=result_line "RTN","TMGTIUOJ",734,0) kill Array("KEY-VALUE") "RTN","TMGTIUOJ",735,0) "RTN","TMGTIUOJ",736,0) ;"Next, put standard lines "RTN","TMGTIUOJ",737,0) new line set line="" "RTN","TMGTIUOJ",738,0) for set line=$order(Array(line)) quit:(line="") do "RTN","TMGTIUOJ",739,0) . if result'="" set result=result_$char(13)_$char(10) "RTN","TMGTIUOJ",740,0) . set result=result_line "RTN","TMGTIUOJ",741,0) "RTN","TMGTIUOJ",742,0) quit result "RTN","TMGTIUOJ",743,0) "RTN","TMGTIUOJ",744,0) "RTN","TMGTIUOJ",745,0) AddIfAbsent(Array,Key,Pivot,Value) "RTN","TMGTIUOJ",746,0) ;"Purpose: to add one (empty) entry, if a value for this doesn't already exist. "RTN","TMGTIUOJ",747,0) ;"Input: Array. Format as follows: "RTN","TMGTIUOJ",748,0) ;" Array("text line")="" "RTN","TMGTIUOJ",749,0) ;" Array("text line")="" "RTN","TMGTIUOJ",750,0) ;" Array("KEY-VALUE",KeyName)=Value "RTN","TMGTIUOJ",751,0) ;" Array("KEY-VALUE",KeyName,"LINE")=original line "RTN","TMGTIUOJ",752,0) ;" Key -- the name of the study "RTN","TMGTIUOJ",753,0) ;" Pivot -- ":", or "=" OPTIONAL. Default = ":" "RTN","TMGTIUOJ",754,0) ;" Value -- the description of the needed value. OPTIONAL. "RTN","TMGTIUOJ",755,0) ;" default value = '' "RTN","TMGTIUOJ",756,0) "RTN","TMGTIUOJ",757,0) "RTN","TMGTIUOJ",758,0) set Pivot=$get(Pivot,":") "RTN","TMGTIUOJ",759,0) set Value=$get(Value,"") "RTN","TMGTIUOJ",760,0) if $get(Key)="" goto AIADone "RTN","TMGTIUOJ",761,0) new UpKey set UpKey=$$UP^XLFSTR(Key) "RTN","TMGTIUOJ",762,0) if $data(Array("KEY-VALUE",UpKey))>0 goto AIADone "RTN","TMGTIUOJ",763,0) "RTN","TMGTIUOJ",764,0) set Array("KEY-VALUE",UpKey)=$get(Value) "RTN","TMGTIUOJ",765,0) new line set line=" "_$get(Key)_" "_$get(Pivot)_" "_$get(Value) "RTN","TMGTIUOJ",766,0) set Array("KEY-VALUE",UpKey,"LINE")=line "RTN","TMGTIUOJ",767,0) "RTN","TMGTIUOJ",768,0) AIADone "RTN","TMGTIUOJ",769,0) quit "RTN","TMGTIUOJ",770,0) "RTN","TMGTIUOJ",771,0) "RTN","TMGTIUOJ",772,0) StubRecommendations(DFN,Array,Label) "RTN","TMGTIUOJ",773,0) ;"Purpose: to add stubs for recommended studies to Array "RTN","TMGTIUOJ",774,0) "RTN","TMGTIUOJ",775,0) ;"Get age from DFN "RTN","TMGTIUOJ",776,0) if +$get(DFN)=0 goto SRDone "RTN","TMGTIUOJ",777,0) new Age set Age=+$$GET1^DIQ(2,DFN,.033) "RTN","TMGTIUOJ",778,0) new Sex set Sex=$$GET1^DIQ(2,DFN,.02) "RTN","TMGTIUOJ",779,0) "RTN","TMGTIUOJ",780,0) if Label="[STUDIES]" do "RTN","TMGTIUOJ",781,0) . if (Sex="FEMALE") do "RTN","TMGTIUOJ",782,0) . . if (Age>39) do AddIfAbsent(.Array,"Mammogram") "RTN","TMGTIUOJ",783,0) . . if (Age>49) do AddIfAbsent(.Array,"Bone Density") "RTN","TMGTIUOJ",784,0) . . do AddIfAbsent(.Array,"Pap") "RTN","TMGTIUOJ",785,0) . . if (Age>8)&(Age<27) do AddIfAbsent(.Array,"Gardasil",":","#1 ; #2 ; #3 ") "RTN","TMGTIUOJ",786,0) . if (Sex="MALE")&(Age>49) do AddIfAbsent(.Array,"PSA") "RTN","TMGTIUOJ",787,0) . if Age>64 do AddIfAbsent(.Array,"Pneumovax") "RTN","TMGTIUOJ",788,0) . if (Age>18) do AddIfAbsent(.Array,"Advance Directives") "RTN","TMGTIUOJ",789,0) . if (Age>49) do AddIfAbsent(.Array,"Td") "RTN","TMGTIUOJ",790,0) . if (Age>67) do AddIfAbsent(.Array,"Zostavax") "RTN","TMGTIUOJ",791,0) . if (Age>1)&(Age<21) do AddIfAbsent(.Array,"Varivax",":","#1 ; #2 ") "RTN","TMGTIUOJ",792,0) . if (Age>10)&(Age<50) do AddIfAbsent(.Array,"TdaP / Td") "RTN","TMGTIUOJ",793,0) . if (Age>10)&(Age<23) do AddIfAbsent(.Array,"MCV4 (Menactra)") "RTN","TMGTIUOJ",794,0) . if (Age>50) do AddIfAbsent(.Array,"Colonoscopy") "RTN","TMGTIUOJ",795,0) else if Label="[DIABETIC STUDIES]" do "RTN","TMGTIUOJ",796,0) . do AddIfAbsent(.Array,"HgbA1c","=") "RTN","TMGTIUOJ",797,0) . do AddIfAbsent(.Array,"Diabetic Eye Exam") "RTN","TMGTIUOJ",798,0) . do AddIfAbsent(.Array,"Urine Microalbumin") "RTN","TMGTIUOJ",799,0) . do AddIfAbsent(.Array,"Diabetic Foot Exam") "RTN","TMGTIUOJ",800,0) . do AddIfAbsent(.Array,"EKG") "RTN","TMGTIUOJ",801,0) else if Label="[LIPIDS]" do "RTN","TMGTIUOJ",802,0) . do AddIfAbsent(.Array,"Total Cholesterol","=") "RTN","TMGTIUOJ",803,0) . do AddIfAbsent(.Array,"LDL Cholesterol","=") "RTN","TMGTIUOJ",804,0) . do AddIfAbsent(.Array,"HDL Cholesterol","=") "RTN","TMGTIUOJ",805,0) . do AddIfAbsent(.Array,"Triglycerides","=") "RTN","TMGTIUOJ",806,0) else if Label="[SOCIAL]" do "RTN","TMGTIUOJ",807,0) . do AddIfAbsent(.Array,"Tobacco") "RTN","TMGTIUOJ",808,0) . do AddIfAbsent(.Array,"EtOH") "RTN","TMGTIUOJ",809,0) "RTN","TMGTIUOJ",810,0) SRDone "RTN","TMGTIUOJ",811,0) quit "RTN","TMGTIUOJ",812,0) "RTN","TMGTIUOJ",813,0) "RTN","TMGTIUOJ",814,0) GETTABLX(DFN,LABEL) "RTN","TMGTIUOJ",815,0) ;"Purpose: A call point for TIU objects, to return a table comprised from "RTN","TMGTIUOJ",816,0) ;" prior notes. "RTN","TMGTIUOJ",817,0) "RTN","TMGTIUOJ",818,0) new Array,result "RTN","TMGTIUOJ",819,0) if $get(LABEL)="" goto GTXDone "RTN","TMGTIUOJ",820,0) set result=" -- "_LABEL_" ---------"_$CHAR(13)_$CHAR(10) "RTN","TMGTIUOJ",821,0) do GetSpecial(DFN,LABEL,"BLANK_LINE",13,.Array,2) "RTN","TMGTIUOJ",822,0) do StubRecommendations(.DFN,.Array,LABEL) "RTN","TMGTIUOJ",823,0) set result=result_$$Array2Str(.Array) "RTN","TMGTIUOJ",824,0) GTXDone "RTN","TMGTIUOJ",825,0) quit result "RTN","TMGTIUOJ",826,0) "RTN","TMGTRAN1") 0^83^B2382006 "RTN","TMGTRAN1",1,0) TMGTRAN1 ;TMG/kst/TRANSCRIPTION REPORT FUNCTIONS -- UI ;03/25/06 "RTN","TMGTRAN1",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGTRAN1",3,0) "RTN","TMGTRAN1",4,0) ;" TRANSCRIPTION REPORT FUNCTIONS "RTN","TMGTRAN1",5,0) "RTN","TMGTRAN1",6,0) ;"======================================================================= "RTN","TMGTRAN1",7,0) ;" API -- Public Functions. "RTN","TMGTRAN1",8,0) ;"======================================================================= "RTN","TMGTRAN1",9,0) ;"RPTCUR "RTN","TMGTRAN1",10,0) ;"RPTASK "RTN","TMGTRAN1",11,0) ;"RPTQUIET(OPTIONS) "RTN","TMGTRAN1",12,0) ;"FREECUR "RTN","TMGTRAN1",13,0) ;"FREEASK "RTN","TMGTRAN1",14,0) ;"ScanSign(OPTIONS,SIGNED) "RTN","TMGTRAN1",15,0) ;"PWDSNOOP(IEN) "RTN","TMGTRAN1",16,0) ;"SHOWUNSIGNED "RTN","TMGTRAN1",17,0) ;"SIGNDOC(DocIEN,OPTIONS) "RTN","TMGTRAN1",18,0) ;"PRINT(DocArray) ; Prompt and print, or array "RTN","TMGTRAN1",19,0) "RTN","TMGTRAN1",20,0) "RTN","TMGTRAN1",21,0) "RTN","TMGTRAN1",22,0) ;"======================================================================= "RTN","TMGTRAN1",23,0) ;" Private Functions. "RTN","TMGTRAN1",24,0) ;"======================================================================= "RTN","TMGTRAN1",25,0) ;"AskDatesRPT(Options) "RTN","TMGTRAN1",26,0) ;"FreeDocs(AuthorIEN,ShowDetails) "RTN","TMGTRAN1",27,0) "RTN","TMGTRAN1",28,0) ;"======================================================================= "RTN","TMGTRAN1",29,0) RPTCUR "RTN","TMGTRAN1",30,0) ;"SCOPE: PUBLIC "RTN","TMGTRAN1",31,0) ;"Purpose: To report transcription productivity for the current user (DUZ) "RTN","TMGTRAN1",32,0) ;"Input: none. User will be asked for start and end dates "RTN","TMGTRAN1",33,0) ;"Output: Produces a report to choses output channel. "RTN","TMGTRAN1",34,0) "RTN","TMGTRAN1",35,0) new Options "RTN","TMGTRAN1",36,0) "RTN","TMGTRAN1",37,0) write !,"-- TRANSCRIPTION PRODUCTIVITY CREDIT REPORT -- ",!! "RTN","TMGTRAN1",38,0) write "Showing credit for: ",$piece($get(^VA(200,DUZ,0)),"^",1),!! "RTN","TMGTRAN1",39,0) "RTN","TMGTRAN1",40,0) set Options("TRANS")=DUZ "RTN","TMGTRAN1",41,0) do AskDatesRPT(.Options) "RTN","TMGTRAN1",42,0) "RTN","TMGTRAN1",43,0) quit "RTN","TMGTRAN1",44,0) "RTN","TMGTRAN1",45,0) RPTASK "RTN","TMGTRAN1",46,0) ;"SCOPE: PUBLIC "RTN","TMGTRAN1",47,0) ;"Purpose: To report transcription productivity for a chosen user "RTN","TMGTRAN1",48,0) ;"Input: none. User will be asked for the user to report on, and also "RTN","TMGTRAN1",49,0) ;" start and end dates "RTN","TMGTRAN1",50,0) ;"Output: Produces a report to choses output channel. "RTN","TMGTRAN1",51,0) "RTN","TMGTRAN1",52,0) new Options "RTN","TMGTRAN1",53,0) "RTN","TMGTRAN1",54,0) ;"set TMGDEBUG=1 ;"TEMP!!! "RTN","TMGTRAN1",55,0) "RTN","TMGTRAN1",56,0) write !,"-- TRANSCRIPTION PRODUCTIVITY CREDIT REPORT -- ",!! "RTN","TMGTRAN1",57,0) "RTN","TMGTRAN1",58,0) set DIC=200 ;"NEW PERSON file "RTN","TMGTRAN1",59,0) set DIC(0)="MAQE" "RTN","TMGTRAN1",60,0) set DIC("A")="Enter name of transcriptionist (^ to abort): " "RTN","TMGTRAN1",61,0) do ^DIC "RTN","TMGTRAN1",62,0) if +Y=-1 do goto RADone "RTN","TMGTRAN1",63,0) . write !,"No transcriptionist selected. Aborting report.",! "RTN","TMGTRAN1",64,0) "RTN","TMGTRAN1",65,0) set Options("TRANS")=+Y "RTN","TMGTRAN1",66,0) "RTN","TMGTRAN1",67,0) do AskDatesRPT(.Options) "RTN","TMGTRAN1",68,0) RADone "RTN","TMGTRAN1",69,0) quit "RTN","TMGTRAN1",70,0) "RTN","TMGTRAN1",71,0) RPTCURA "RTN","TMGTRAN1",72,0) ;"SCOPE: PUBLIC "RTN","TMGTRAN1",73,0) ;"Purpose: To report current user's (DUZ) cost for all transcriptionists "RTN","TMGTRAN1",74,0) ;"Input: none. User will be asked for start and end dates "RTN","TMGTRAN1",75,0) ;"Output: Produces a report to choses output channel. "RTN","TMGTRAN1",76,0) "RTN","TMGTRAN1",77,0) new Options "RTN","TMGTRAN1",78,0) "RTN","TMGTRAN1",79,0) write !,"-- TRANSCRIPTION COST REPORT -- ",!! "RTN","TMGTRAN1",80,0) write "Showing cost for: ",$piece($get(^VA(200,DUZ,0)),"^",1),!! "RTN","TMGTRAN1",81,0) "RTN","TMGTRAN1",82,0) set Options("AUTHOR")=DUZ "RTN","TMGTRAN1",83,0) do AskDatesRPT(.Options) "RTN","TMGTRAN1",84,0) "RTN","TMGTRAN1",85,0) quit "RTN","TMGTRAN1",86,0) "RTN","TMGTRAN1",87,0) RPTASKA "RTN","TMGTRAN1",88,0) ;"SCOPE: PUBLIC "RTN","TMGTRAN1",89,0) ;"Purpose: To report transcription costs for a chosen user "RTN","TMGTRAN1",90,0) ;"Input: none. User will be asked for the user to report on, and also "RTN","TMGTRAN1",91,0) ;" start and end dates "RTN","TMGTRAN1",92,0) ;"Output: Produces a report to choses output channel. "RTN","TMGTRAN1",93,0) "RTN","TMGTRAN1",94,0) new Options "RTN","TMGTRAN1",95,0) "RTN","TMGTRAN1",96,0) write !,"-- TRANSCRIPTION COST REPORT -- ",!! "RTN","TMGTRAN1",97,0) "RTN","TMGTRAN1",98,0) set DIC=200 ;"NEW PERSON file "RTN","TMGTRAN1",99,0) set DIC(0)="MAQE" "RTN","TMGTRAN1",100,0) set DIC("A")="Enter name of author (^ to abort): " "RTN","TMGTRAN1",101,0) do ^DIC "RTN","TMGTRAN1",102,0) if +Y=-1 do goto RAADone "RTN","TMGTRAN1",103,0) . write !,"No author selected. Aborting report.",! "RTN","TMGTRAN1",104,0) "RTN","TMGTRAN1",105,0) set Options("AUTHOR")=+Y "RTN","TMGTRAN1",106,0) "RTN","TMGTRAN1",107,0) do AskDatesRPT(.Options) "RTN","TMGTRAN1",108,0) RAADone "RTN","TMGTRAN1",109,0) quit "RTN","TMGTRAN1",110,0) "RTN","TMGTRAN1",111,0) "RTN","TMGTRAN1",112,0) "RTN","TMGTRAN1",113,0) AskDatesRPT(Options) "RTN","TMGTRAN1",114,0) ;"SCOPE: PUBLIC "RTN","TMGTRAN1",115,0) ;"Purpose: to finish the interactive report process. "RTN","TMGTRAN1",116,0) ;"Input: An array that should contain Options("TRANS")=IEN "RTN","TMGTRAN1",117,0) "RTN","TMGTRAN1",118,0) write !!! "RTN","TMGTRAN1",119,0) write "NOTE: Enter date range for note ENTRY into system, not date of service.",! "RTN","TMGTRAN1",120,0) new %DT "RTN","TMGTRAN1",121,0) set %DT="AEP" "RTN","TMGTRAN1",122,0) set %DT("A")="Enter starting date (^ to abort): " "RTN","TMGTRAN1",123,0) do ^%DT "RTN","TMGTRAN1",124,0) if Y=-1 do goto ADRDone "RTN","TMGTRAN1",125,0) . write "Invalid date. Aborting report.",! "RTN","TMGTRAN1",126,0) set Options("START")=Y "RTN","TMGTRAN1",127,0) "RTN","TMGTRAN1",128,0) set %DT("A")="Enter ending date (^ to abort): " "RTN","TMGTRAN1",129,0) do ^%DT "RTN","TMGTRAN1",130,0) if Y=-1 do goto ADRDone "RTN","TMGTRAN1",131,0) . write "Invalid date. Aborting report.",! "RTN","TMGTRAN1",132,0) set Options("END")=Y "RTN","TMGTRAN1",133,0) "RTN","TMGTRAN1",134,0) new YN "RTN","TMGTRAN1",135,0) read !,"Show Details? YES// ",YN:$get(DTIME,3600) "RTN","TMGTRAN1",136,0) if YN="" set YN="Y" "RTN","TMGTRAN1",137,0) set Options("DETAILS")=($$UP^XLFSTR(YN)["Y") "RTN","TMGTRAN1",138,0) if YN="^" write "Aborting.",! goto ADRDone "RTN","TMGTRAN1",139,0) "RTN","TMGTRAN1",140,0) set %ZIS("A")="Enter output printer or device (^ to abort): " "RTN","TMGTRAN1",141,0) do ^%ZIS "RTN","TMGTRAN1",142,0) if POP do goto ADRDone "RTN","TMGTRAN1",143,0) . write !,"Error selecting output printer or device. Aborting report.",! "RTN","TMGTRAN1",144,0) "RTN","TMGTRAN1",145,0) use IO "RTN","TMGTRAN1",146,0) do RPTQUIET(.Options) "RTN","TMGTRAN1",147,0) use IO(0) "RTN","TMGTRAN1",148,0) "RTN","TMGTRAN1",149,0) do ^%ZISC "RTN","TMGTRAN1",150,0) "RTN","TMGTRAN1",151,0) ADRDone "RTN","TMGTRAN1",152,0) quit "RTN","TMGTRAN1",153,0) "RTN","TMGTRAN1",154,0) "RTN","TMGTRAN1",155,0) RPTQUIET(OPTIONS) "RTN","TMGTRAN1",156,0) ;"SCOPE: PUBLIC "RTN","TMGTRAN1",157,0) ;"Purpose: To create a report on transcription productivity based on "RTN","TMGTRAN1",158,0) ;" options specified in OPTIONS. "RTN","TMGTRAN1",159,0) ;"Input: The following elements in OPTIONS should be defined "RTN","TMGTRAN1",160,0) ;" 0PTIONS("TRANS") ;"the IEN of the transcriptionst (IEN from file 200) "RTN","TMGTRAN1",161,0) ;" This term is to limit the search. If all transcriptionsts are "RTN","TMGTRAN1",162,0) ;" wanted, then don't define OPTIONS("TRANS") "RTN","TMGTRAN1",163,0) ;" If multiple transcriptionists need to be specified, use this format: "RTN","TMGTRAN1",164,0) ;" OPTIONS("TRANS")="*" "RTN","TMGTRAN1",165,0) ;" OPTIONS("TRANS",1)=IEN#1 "RTN","TMGTRAN1",166,0) ;" OPTIONS("TRANS",2)=IEN#2 "RTN","TMGTRAN1",167,0) ;" OPTIONS("TRANS",3)=IEN#3 "RTN","TMGTRAN1",168,0) ;" 0PTIONS("AUTHOR") ;"the IEN of the author (IEN from file 200) "RTN","TMGTRAN1",169,0) ;" This term is to limit the search. If all authors are "RTN","TMGTRAN1",170,0) ;" wanted, then don't define OPTIONS("AUTHOR") "RTN","TMGTRAN1",171,0) ;" If multiple authors need to be specified, use this format: "RTN","TMGTRAN1",172,0) ;" OPTIONS("AUTHOR")="*" "RTN","TMGTRAN1",173,0) ;" OPTIONS("AUTHOR",1)=IEN#1 "RTN","TMGTRAN1",174,0) ;" OPTIONS("AUTHOR",2)=IEN#2 "RTN","TMGTRAN1",175,0) ;" OPTIONS("AUTHOR",3)=IEN#3 "RTN","TMGTRAN1",176,0) ;" OPTIONS("START") ;"Earliest date of documents, in Fileman internal format "RTN","TMGTRAN1",177,0) ;" OPTIONS("END") ;"Latest date of documents, in Fileman internal format "RTN","TMGTRAN1",178,0) ;" OPTIONS("DETAILS") ;"if 1, then each document showed "RTN","TMGTRAN1",179,0) ;"Note: This will create a report by writing to the current device "RTN","TMGTRAN1",180,0) ;" If the user wants output to go to a DEVICE, then they should call "RTN","TMGTRAN1",181,0) ;" ^%ZIS prior to calling this function, and call ^%ZISC aftewards to close "RTN","TMGTRAN1",182,0) "RTN","TMGTRAN1",183,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"RPTQUIET^TMGTRANS1") "RTN","TMGTRAN1",184,0) "RTN","TMGTRAN1",185,0) new index "RTN","TMGTRAN1",186,0) new TransIEN,AuthorIEN "RTN","TMGTRAN1",187,0) new TransArrayP set TransArrayP="OPTIONS(""TRANS"")" "RTN","TMGTRAN1",188,0) new AuthorArrayP set AuthorArrayP="OPTIONS(""AUTHOR"")" "RTN","TMGTRAN1",189,0) new ChrCt set ChrCt=0 "RTN","TMGTRAN1",190,0) new LineCt set LineCt=0 "RTN","TMGTRAN1",191,0) new StartDT,EndDT "RTN","TMGTRAN1",192,0) new CtAuthor ;"An array to subdivide lines to each doctor's account "RTN","TMGTRAN1",193,0) new CtTrans ;"An array to track transcriptionists lines and income "RTN","TMGTRAN1",194,0) new AuthorInitials,TransInitials "RTN","TMGTRAN1",195,0) new ShowDetails set ShowDetails=+$get(OPTIONS("DETAILS")) "RTN","TMGTRAN1",196,0) "RTN","TMGTRAN1",197,0) set StartDT=+$get(OPTIONS("START")) "RTN","TMGTRAN1",198,0) if (StartDT=0) do goto RQDone "RTN","TMGTRAN1",199,0) . write "No start date specified. Aborting.",! "RTN","TMGTRAN1",200,0) set EndDT=+$get(OPTIONS("END"))\1 ;" \1 removes time from date "RTN","TMGTRAN1",201,0) if (EndDT=0) do goto RQDone "RTN","TMGTRAN1",202,0) . write "No end date specified. Aborting.",! "RTN","TMGTRAN1",203,0) "RTN","TMGTRAN1",204,0) new CharsPerLine set CharsPerLine=+$piece($get(^TIU(8925.99,1,0)),"^",3) "RTN","TMGTRAN1",205,0) if CharsPerLine=0 set CharsPerLine=65 "RTN","TMGTRAN1",206,0) "RTN","TMGTRAN1",207,0) write !!," Visit;" "RTN","TMGTRAN1",208,0) write $$RJ^XLFSTR("Entry Date;",15) "RTN","TMGTRAN1",209,0) write $$RJ^XLFSTR("Lines@Rate=$Cost",23),"; " "RTN","TMGTRAN1",210,0) write "Trn; Ath; Sgn; Patient",! "RTN","TMGTRAN1",211,0) write "------------------------------------------------------------------------------",! "RTN","TMGTRAN1",212,0) set index=$order(^TIU(8925,0)) "RTN","TMGTRAN1",213,0) for do quit:(index="") "RTN","TMGTRAN1",214,0) . ;"write "." "RTN","TMGTRAN1",215,0) . if index="" quit "RTN","TMGTRAN1",216,0) . new k "RTN","TMGTRAN1",217,0) . use IO(0) read *k:0 use IO "RTN","TMGTRAN1",218,0) . if k=27 do quit "RTN","TMGTRAN1",219,0) . . set index="" "RTN","TMGTRAN1",220,0) . . write "Report aborted by ESC from user.",! "RTN","TMGTRAN1",221,0) . new tDate set tDate=$piece($get(^TIU(8925,index,12)),"^",1) "RTN","TMGTRAN1",222,0) . set tDate=tDate\1 ;"remove time from date "RTN","TMGTRAN1",223,0) . ;"set mC=mC+1 set tC=tC+1 if tC>100 write mC," " set tC=0 "RTN","TMGTRAN1",224,0) . if (tDate'EndDT) do "RTN","TMGTRAN1",225,0) . . set TransIEN=+$piece($get(^TIU(8925,index,13)),"^",2) ;"field 1302 "RTN","TMGTRAN1",226,0) . . ;"write "index=",index," " "RTN","TMGTRAN1",227,0) . . ;"write "TransIEN='" "RTN","TMGTRAN1",228,0) . . ;"write TransIEN,"'" "RTN","TMGTRAN1",229,0) . . if ($data(OPTIONS("TRANS"))=0)!($$InList^TMGMISC(TransIEN,TransArrayP)=1) do "RTN","TMGTRAN1",230,0) . . . set AuthorIEN=$piece($get(^TIU(8925,index,12)),"^",2) ;field 1202 "RTN","TMGTRAN1",231,0) . . . if ($data(OPTIONS("AUTHOR"))=0)!($$InList^TMGMISC(AuthorIEN,AuthorArrayP)=1) do "RTN","TMGTRAN1",232,0) . . . . new tCharCt,tLineCt,Date,DateS,Pt "RTN","TMGTRAN1",233,0) . . . . new VDate,VDateSi "RTN","TMGTRAN1",234,0) . . . . new pStatus "RTN","TMGTRAN1",235,0) . . . . new Status set Status="N" "RTN","TMGTRAN1",236,0) . . . . new Patient set Patient="" "RTN","TMGTRAN1",237,0) . . . . set tCharCt=+$piece($get(^TIU(8925,index,"TMG")),"^",2);"field 22711=char count "RTN","TMGTRAN1",238,0) . . . . set tLineCt=+$piece($get(^TIU(8925,index,0)),"^",10) ;"field .1 = line count "RTN","TMGTRAN1",239,0) . . . . set pStatus=$piece($get(^TIU(8925,index,0)),"^",5) ;"field .05 is status file pointer "RTN","TMGTRAN1",240,0) . . . . if +pStatus'=0 do "RTN","TMGTRAN1",241,0) . . . . . set Status=$piece($get(^TIU(8925.6,pStatus,0)),"^",2) ;"8925.6=TIU Status. field .02=symbol "RTN","TMGTRAN1",242,0) . . . . . if Status="c" set Status="Y" "RTN","TMGTRAN1",243,0) . . . . . else set Status="N" "RTN","TMGTRAN1",244,0) . . . . if (tLineCt=0)!(tCharCt=0) do "RTN","TMGTRAN1",245,0) . . . . . if (tLineCt=0)&(tCharCt'=0) do "RTN","TMGTRAN1",246,0) . . . . . . set tLineCt=(((tCharCt/CharsPerLine)*10)\1)/10 "RTN","TMGTRAN1",247,0) . . . . . else if (tCharCt=0)&(tLineCt'=0) do "RTN","TMGTRAN1",248,0) . . . . . . set tCharCt=tLineCt*CharsPerLine "RTN","TMGTRAN1",249,0) . . . . . else do "RTN","TMGTRAN1",250,0) . . . . . . set tLineCt=$$DocLines^TMGMISC(index,.tCharCt) "RTN","TMGTRAN1",251,0) . . . . . . if tLineCt=0 set tLineCt=(((tCharCt/CharsPerLine)*10)\1)/10 "RTN","TMGTRAN1",252,0) . . . . . set tLineCt=$$Round^TMGMISC(tLineCt) "RTN","TMGTRAN1",253,0) . . . . . set tCharCt=$$Round^TMGMISC(tCharCt) "RTN","TMGTRAN1",254,0) . . . . . ;"Store values, so next time we won't have to calculate it. "RTN","TMGTRAN1",255,0) . . . . . set $piece(^TIU(8925,index,0),"^",10)=+tLineCt ;"field .1 = line count "RTN","TMGTRAN1",256,0) . . . . . set $piece(^TIU(8925,index,"TMG"),"^",2)=tCharCt ;"field 22711 = char count "RTN","TMGTRAN1",257,0) . . . . set Date=$piece($get(^TIU(8925,index,12)),"^",1) ;"field 1201 = Entry Date "RTN","TMGTRAN1",258,0) . . . . ;"set DateS=$$FMTE^XLFDT(Date,"D") "RTN","TMGTRAN1",259,0) . . . . set DateS=$$DTFormat^TMGMISC(Date,"ww mm/dd/yy") "RTN","TMGTRAN1",260,0) . . . . set VDate=$piece($get(^TIU(8925,index,13)),"^",1) ;"field 1301=Ref/Visit Date "RTN","TMGTRAN1",261,0) . . . . ;"set VDateS=$$FMTE^XLFDT(VDate,"D") "RTN","TMGTRAN1",262,0) . . . . set VDateS=$$DTFormat^TMGMISC(VDate,"mm/dd/yy") "RTN","TMGTRAN1",263,0) . . . . set AuthorInitials=$piece($get(^VA(200,AuthorIEN,0)),"^",2) "RTN","TMGTRAN1",264,0) . . . . set TransInitials=$piece($get(^VA(200,TransIEN,0)),"^",2) ;"field 1 = initials "RTN","TMGTRAN1",265,0) . . . . set CtAuthor(AuthorIEN,"LINES")=$get(CtAuthor(AuthorIEN,"LINES"))+tLineCt "RTN","TMGTRAN1",266,0) . . . . set CtAuthor(AuthorIEN,"NOTES")=+$get(CtAuthor(AuthorIEN,"NOTES"))+1 "RTN","TMGTRAN1",267,0) . . . . set CtTrans(TransIEN,"LINES")=$get(CtTrans(TransIEN,"LINES"))+tLineCt "RTN","TMGTRAN1",268,0) . . . . set CtTrans(TransIEN,"NOTES")=+$get(CtTrans(TransIEN,"NOTES"))+1 "RTN","TMGTRAN1",269,0) . . . . set Pt=+$piece($get(^TIU(8925,index,0)),"^",2) ;"field .02 = patient "RTN","TMGTRAN1",270,0) . . . . if Pt'=0 set Patient=$piece($get(^DPT(Pt,0)),"^",1) ;"field .01 = name "RTN","TMGTRAN1",271,0) . . . . new NoteBonus set NoteBonus=0 "RTN","TMGTRAN1",272,0) . . . . new PayRate set PayRate=$$PayRate(TransIEN,Date,.NoteBonus) "RTN","TMGTRAN1",273,0) . . . . ;"new LineCost set LineCost=$$RoundDn^TMGMISC(tLineCt*PayRate) "RTN","TMGTRAN1",274,0) . . . . ;"new LineCost set LineCost=(tLineCt*PayRate) "RTN","TMGTRAN1",275,0) . . . . new LineCost set LineCost=(tLineCt*PayRate)+NoteBonus "RTN","TMGTRAN1",276,0) . . . . set CtAuthor(AuthorIEN,"COST")=+$get(CtAuthor(AuthorIEN,"COST"))+LineCost "RTN","TMGTRAN1",277,0) . . . . set CtAuthor(AuthorIEN,"BONUS")=+$get(CtAuthor(AuthorIEN,"BONUS"))+NoteBonus "RTN","TMGTRAN1",278,0) . . . . set CtTrans(TransIEN,"COST")=+$get(CtTrans(TransIEN,"COST"))+LineCost "RTN","TMGTRAN1",279,0) . . . . set CtTrans(TransIEN,"BONUS")=+$get(CtTrans(TransIEN,"BONUS"))+NoteBonus "RTN","TMGTRAN1",280,0) . . . . if ShowDetails do "RTN","TMGTRAN1",281,0) . . . . . write VDateS,"; " "RTN","TMGTRAN1",282,0) . . . . . write $$RJ^XLFSTR(DateS,13),";" "RTN","TMGTRAN1",283,0) . . . . . new tS set tS=tLineCt_" @"_PayRate "RTN","TMGTRAN1",284,0) . . . . . if NoteBonus>0 set tS=tS_")+"_NoteBonus "RTN","TMGTRAN1",285,0) . . . . . write $$RJ^XLFSTR(.tS,15) "RTN","TMGTRAN1",286,0) . . . . . set tS=" =$"_LineCost_"; " "RTN","TMGTRAN1",287,0) . . . . . write $$RJ^XLFSTR(.tS,10) "RTN","TMGTRAN1",288,0) . . . . . write TransInitials,"; ",AuthorInitials,"; " "RTN","TMGTRAN1",289,0) . . . . . write " ",Status,"; " "RTN","TMGTRAN1",290,0) . . . . . write $$Clip^TMGSTUTL(Patient,15),! "RTN","TMGTRAN1",291,0) . . . . set LineCt=LineCt+tLineCt "RTN","TMGTRAN1",292,0) . set index=+$order(^TIU(8925,index)) "RTN","TMGTRAN1",293,0) . if index=0 set index="" "RTN","TMGTRAN1",294,0) "RTN","TMGTRAN1",295,0) write !,"Transcriptionist breakdown",! "RTN","TMGTRAN1",296,0) write "-----------------------------",! "RTN","TMGTRAN1",297,0) set index=$order(CtTrans("")) "RTN","TMGTRAN1",298,0) for do quit:(index="") "RTN","TMGTRAN1",299,0) . new TransS,Lines,Notes "RTN","TMGTRAN1",300,0) . if index="" quit "RTN","TMGTRAN1",301,0) . set TransS=$piece($get(^VA(200,index,0)),"^",1) "RTN","TMGTRAN1",302,0) . if TransS="" set TransS="(Unknown Transcriptionist)" "RTN","TMGTRAN1",303,0) . set Lines=+$get(CtTrans(index,"LINES")) "RTN","TMGTRAN1",304,0) . set Notes=+$get(CtTrans(index,"NOTES")) "RTN","TMGTRAN1",305,0) . write " ",TransS,": ",Lines," lines in ",Notes," notes." "RTN","TMGTRAN1",306,0) . write " $",$get(CtTrans(index,"COST")) "RTN","TMGTRAN1",307,0) . write " (income)",! "RTN","TMGTRAN1",308,0) . if +$get(CtTrans(index,"BONUS"))>0 do "RTN","TMGTRAN1",309,0) . . new c set c=+$get(CtTrans(index,"COST")) "RTN","TMGTRAN1",310,0) . . new b set b=$get(CtTrans(index,"BONUS")) "RTN","TMGTRAN1",311,0) . . write ?15,"$",c," = $",(c-b)," + $",b," per-note bonus.",! "RTN","TMGTRAN1",312,0) . set index=$order(CtTrans(index)) "RTN","TMGTRAN1",313,0) "RTN","TMGTRAN1",314,0) write !,"Author breakdown",! "RTN","TMGTRAN1",315,0) write "--------------------",! "RTN","TMGTRAN1",316,0) set index=$order(CtAuthor("")) "RTN","TMGTRAN1",317,0) for do quit:(index="") "RTN","TMGTRAN1",318,0) . new AuthorS,Lines,Notes "RTN","TMGTRAN1",319,0) . if index="" quit "RTN","TMGTRAN1",320,0) . set AuthorS=$piece($get(^VA(200,index,0)),"^",1) "RTN","TMGTRAN1",321,0) . if AuthorS="" set AuthorS="(Unknown Author)" "RTN","TMGTRAN1",322,0) . set Lines=+$get(CtAuthor(index,"LINES")) "RTN","TMGTRAN1",323,0) . set Notes=+$get(CtAuthor(index,"NOTES")) "RTN","TMGTRAN1",324,0) . write " ",AuthorS,": ",Lines," lines in ",Notes," notes." "RTN","TMGTRAN1",325,0) . write " $",$get(CtAuthor(index,"COST"))," (expense)",! "RTN","TMGTRAN1",326,0) . if +$get(CtAuthor(index,"BONUS"))>0 do "RTN","TMGTRAN1",327,0) . . new c set c=+$get(CtAuthor(index,"COST")) "RTN","TMGTRAN1",328,0) . . new b set b=$get(CtAuthor(index,"BONUS")) "RTN","TMGTRAN1",329,0) . . write ?15,"$",c," = $",(c-b)," + $",b," per-note bonus.",! "RTN","TMGTRAN1",330,0) . set index=$order(CtAuthor(index)) "RTN","TMGTRAN1",331,0) "RTN","TMGTRAN1",332,0) write !!,"Done.",! "RTN","TMGTRAN1",333,0) "RTN","TMGTRAN1",334,0) RQDone "RTN","TMGTRAN1",335,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"RPTQUIET^TMGTRANS1") "RTN","TMGTRAN1",336,0) quit "RTN","TMGTRAN1",337,0) "RTN","TMGTRAN1",338,0) "RTN","TMGTRAN1",339,0) PayRateE(TransIEN,Date) "RTN","TMGTRAN1",340,0) ;"Purpose: To provide a 'shell' for PayRate below, except external "RTN","TMGTRAN1",341,0) ;" format of date alowed "RTN","TMGTRAN1",342,0) "RTN","TMGTRAN1",343,0) new IDate "RTN","TMGTRAN1",344,0) "RTN","TMGTRAN1",345,0) set X=$get(Date) "RTN","TMGTRAN1",346,0) ;"set IDate= "RTN","TMGTRAN1",347,0) "RTN","TMGTRAN1",348,0) ;"COMPLETE FUNCTION LATER... "RTN","TMGTRAN1",349,0) "RTN","TMGTRAN1",350,0) quit "RTN","TMGTRAN1",351,0) "RTN","TMGTRAN1",352,0) "RTN","TMGTRAN1",353,0) PayRate(TransIEN,Date,NoteBonus) "RTN","TMGTRAN1",354,0) ;"Purpose: Get payrate in effect at time of Date "RTN","TMGTRAN1",355,0) ;"Input: TransIEN -- the record number in file 200 "RTN","TMGTRAN1",356,0) ;" Date: reference date to lookup, ** in internal fileman format ** "RTN","TMGTRAN1",357,0) ;" NoteBonus -- [OPTIONAL] This is an out parameter. See below. "RTN","TMGTRAN1",358,0) ;"Result: The payrate found in file TMG TRANSCRIPTION PAYRATE file "RTN","TMGTRAN1",359,0) ;" This is dollars/line "RTN","TMGTRAN1",360,0) ;" If NoteBonus was passed by reference, then the value of the "RTN","TMGTRAN1",361,0) ;" NOTE BONUS field (field #3) is returned, or 0 if not found. "RTN","TMGTRAN1",362,0) ;" Note: a result of 0 is returned if TransIEN not found, or "RTN","TMGTRAN1",363,0) ;" no date range covers Date "RTN","TMGTRAN1",364,0) "RTN","TMGTRAN1",365,0) new result set result=0 "RTN","TMGTRAN1",366,0) new bonusresult set bonusresult=0 "RTN","TMGTRAN1",367,0) new RateIEN "RTN","TMGTRAN1",368,0) new index "RTN","TMGTRAN1",369,0) "RTN","TMGTRAN1",370,0) if (+$get(TransIEN)=0)!(+$get(Date)=0) goto PRDone "RTN","TMGTRAN1",371,0) set Date=Date\1 "RTN","TMGTRAN1",372,0) set RateIEN=+$order(^TMG(22704,"B",TransIEN,"")) "RTN","TMGTRAN1",373,0) if RateIEN=0 goto PRDone "RTN","TMGTRAN1",374,0) merge PayRates=^TMG(22704,RateIEN,1) "RTN","TMGTRAN1",375,0) set index=$order(^TMG(22704,RateIEN,1,0)) "RTN","TMGTRAN1",376,0) for do quit:(index="") "RTN","TMGTRAN1",377,0) . if index="" quit "RTN","TMGTRAN1",378,0) . new Rate set Rate=$get(^TMG(22704,RateIEN,1,index,0)) "RTN","TMGTRAN1",379,0) . if Rate'="" do "RTN","TMGTRAN1",380,0) . . new StartDate,EndDate "RTN","TMGTRAN1",381,0) . . set StartDate=$piece(Rate,"^",2) "RTN","TMGTRAN1",382,0) . . set EndDate=$piece(Rate,"^",3) "RTN","TMGTRAN1",383,0) . . if DateEndDate) do quit "RTN","TMGTRAN1",386,0) . . . ;"write "Date=",Date," EndDate=",EndDate,! "RTN","TMGTRAN1",387,0) . . set result=$piece(Rate,"^",1) "RTN","TMGTRAN1",388,0) . . set bonusresult=$piece(Rate,"^",4) ;"field#3 (NOTE BONUS) "RTN","TMGTRAN1",389,0) . if result'=0 set index="" quit "RTN","TMGTRAN1",390,0) . set index=$order(^TMG(22704,RateIEN,1,index)) "RTN","TMGTRAN1",391,0) "RTN","TMGTRAN1",392,0) if result=0 do "RTN","TMGTRAN1",393,0) . ;"write !,"TransIEN=",TransIEN," Date=",Date,! "RTN","TMGTRAN1",394,0) PRDone "RTN","TMGTRAN1",395,0) set NoteBonus=bonusresult "RTN","TMGTRAN1",396,0) quit result "RTN","TMGTRAN1",397,0) "RTN","TMGTRAN1",398,0) ;"======================================================================= "RTN","TMGTRAN1",399,0) "RTN","TMGTRAN1",400,0) FREECUR "RTN","TMGTRAN1",401,0) ;"Purpose: For current user, cycle through all alerts regarding "RTN","TMGTRAN1",402,0) ;" documents needing to be signed, and automatically sign "RTN","TMGTRAN1",403,0) ;" them, then print if user wants. "RTN","TMGTRAN1",404,0) ;"Input: none. User will be asked for signature password, "RTN","TMGTRAN1",405,0) ;" and if they want documents printed. "RTN","TMGTRAN1",406,0) ;"Output: Produces a report to chosen output channel. "RTN","TMGTRAN1",407,0) "RTN","TMGTRAN1",408,0) ;"write @IOF "RTN","TMGTRAN1",409,0) write !!,"-- RELEASE UNSIGNED DOCUMENTS -- ",!! "RTN","TMGTRAN1",410,0) write "Releasing transcription for: ",$piece($get(^VA(200,DUZ,0)),"^",1),!! "RTN","TMGTRAN1",411,0) "RTN","TMGTRAN1",412,0) do FreeDocs(DUZ,1) "RTN","TMGTRAN1",413,0) "RTN","TMGTRAN1",414,0) write !,"Goodbye.",! "RTN","TMGTRAN1",415,0) "RTN","TMGTRAN1",416,0) quit "RTN","TMGTRAN1",417,0) "RTN","TMGTRAN1",418,0) "RTN","TMGTRAN1",419,0) FREEASK "RTN","TMGTRAN1",420,0) ;"Purpose: Ask for chosen user, then cycle through all alerts "RTN","TMGTRAN1",421,0) ;" regarding documents needing to be signed, and automatically "RTN","TMGTRAN1",422,0) ;" sign them, then print if user wants. "RTN","TMGTRAN1",423,0) ;"Input: none. User will be asked for signature password, "RTN","TMGTRAN1",424,0) ;" and if they want documents printed. "RTN","TMGTRAN1",425,0) ;"Output: Produces a report to choses output channel. "RTN","TMGTRAN1",426,0) "RTN","TMGTRAN1",427,0) new Y,DIC,TransIEN,DocIEN "RTN","TMGTRAN1",428,0) set TransIEN=-1 "RTN","TMGTRAN1",429,0) "RTN","TMGTRAN1",430,0) ;"write @IOF "RTN","TMGTRAN1",431,0) write !!,"-- RELEASE UNSIGNED DOCUMENTS -- ",!! "RTN","TMGTRAN1",432,0) "RTN","TMGTRAN1",433,0) set DIC=200 ;"NEW PERSON file "RTN","TMGTRAN1",434,0) set DIC(0)="MAQE" "RTN","TMGTRAN1",435,0) set DIC("A")="Enter name of author (^ to abort): " "RTN","TMGTRAN1",436,0) do ^DIC "RTN","TMGTRAN1",437,0) if +Y'>0 do goto RADone "RTN","TMGTRAN1",438,0) . write !,"No author selected. Aborting report.",! "RTN","TMGTRAN1",439,0) set DocIEN=+Y "RTN","TMGTRAN1",440,0) "RTN","TMGTRAN1",441,0) write !!,"OPTIONAL-- Enter name of transcriptionist to screen for. If specified, ",! "RTN","TMGTRAN1",442,0) write "only notes entered by this transcriptionist will be signed and released." "RTN","TMGTRAN1",443,0) set DIC("A")="Enter name of transcriptionist (ENTER or ^ to skip): " "RTN","TMGTRAN1",444,0) do ^DIC "RTN","TMGTRAN1",445,0) write !! "RTN","TMGTRAN1",446,0) if +Y'>0 set TransIEN=+Y "RTN","TMGTRAN1",447,0) "RTN","TMGTRAN1",448,0) do FreeDocs(DocIEN,1,TransIEN) "RTN","TMGTRAN1",449,0) "RTN","TMGTRAN1",450,0) write !,"Goodbye.",! "RTN","TMGTRAN1",451,0) "RTN","TMGTRAN1",452,0) FADone "RTN","TMGTRAN1",453,0) quit "RTN","TMGTRAN1",454,0) "RTN","TMGTRAN1",455,0) "RTN","TMGTRAN1",456,0) FreeDocs(AuthorIEN,ShowDetails,TransIEN) "RTN","TMGTRAN1",457,0) ;"Purpose: to finish the interactive release documents process. "RTN","TMGTRAN1",458,0) ;" This separate entry point allows restriction of the author "RTN","TMGTRAN1",459,0) ;" whose's documents are to be released. "RTN","TMGTRAN1",460,0) ;"Input: AuthorIEN, the record number of the author in file 200 "RTN","TMGTRAN1",461,0) ;" ShowDetails: optional. Default is to show details (1) "RTN","TMGTRAN1",462,0) ;" 0=don't show, 1=show "RTN","TMGTRAN1",463,0) ;" TransIEN: OPTIONAL -- the IEN of the transcriptionist. "RTN","TMGTRAN1",464,0) ;" IF specified, then ONLY those notes created by this "RTN","TMGTRAN1",465,0) ;" transcriptionist will be finished/released "RTN","TMGTRAN1",466,0) "RTN","TMGTRAN1",467,0) new Signed "RTN","TMGTRAN1",468,0) new abort set abort=0 "RTN","TMGTRAN1",469,0) new Options "RTN","TMGTRAN1",470,0) new PrintAfter "RTN","TMGTRAN1",471,0) new YN "RTN","TMGTRAN1",472,0) new SignAll "RTN","TMGTRAN1",473,0) "RTN","TMGTRAN1",474,0) set Options("AUTHOR")=+$get(AuthorIEN) "RTN","TMGTRAN1",475,0) set Options("SIG")=0 "RTN","TMGTRAN1",476,0) set Options("DETAILS")=$get(ShowDetails,1) "RTN","TMGTRAN1",477,0) if +$get(TransIEN)>0 set Options("TRANS")=+TransIEN "RTN","TMGTRAN1",478,0) "RTN","TMGTRAN1",479,0) do "RTN","TMGTRAN1",480,0) . write "Enter 'your' (meaning author's) signature code below." "RTN","TMGTRAN1",481,0) . new DUZ "RTN","TMGTRAN1",482,0) . set DUZ=+$get(AuthorIEN) "RTN","TMGTRAN1",483,0) . if DUZ=0 quit "RTN","TMGTRAN1",484,0) . do SIG^XUSESIG "RTN","TMGTRAN1",485,0) . write ! "RTN","TMGTRAN1",486,0) . if X1'="" set Options("SIG")=1 "RTN","TMGTRAN1",487,0) if Options("SIG")'=1 do goto FADDone "RTN","TMGTRAN1",488,0) . write "Signature code incorrect. Aborting.",! "RTN","TMGTRAN1",489,0) "RTN","TMGTRAN1",490,0) read "Sign all notes at once (^/Y/N): YES// ",SignAll:$get(DTIME,3600),! "RTN","TMGTRAN1",491,0) if SignAll="" set SignAll="Y" "RTN","TMGTRAN1",492,0) if SignAll="^" write "Aborting.",! goto ADRDone "RTN","TMGTRAN1",493,0) set Options("SIGN ALL")=($$UP^XLFSTR(SignAll)["Y") "RTN","TMGTRAN1",494,0) "RTN","TMGTRAN1",495,0) write !,"Print Notes after signing? (^/Y/N): YES// " "RTN","TMGTRAN1",496,0) read YN:$get(DTIME,3600),! "RTN","TMGTRAN1",497,0) if YN="^" write "Aborting.",! goto ADRDone "RTN","TMGTRAN1",498,0) if YN="" set YN="Y" "RTN","TMGTRAN1",499,0) set PrintAfter=($$UP^XLFSTR(YN)["Y") "RTN","TMGTRAN1",500,0) "RTN","TMGTRAN1",501,0) do AlertSign(.Options,.Signed) "RTN","TMGTRAN1",502,0) "RTN","TMGTRAN1",503,0) write "Now look at ALL documents to find any unsigned ones.",! "RTN","TMGTRAN1",504,0) set Options("START")="0001111" "RTN","TMGTRAN1",505,0) do NOW^%DTC "RTN","TMGTRAN1",506,0) set Options("END")=X "RTN","TMGTRAN1",507,0) do ScanSign(.Options,.Signed) "RTN","TMGTRAN1",508,0) "RTN","TMGTRAN1",509,0) merge ^TMG("BATCH SIGNED DOCS",$J)=Signed "RTN","TMGTRAN1",510,0) "RTN","TMGTRAN1",511,0) if PrintAfter do PRINT(.Signed) "RTN","TMGTRAN1",512,0) "RTN","TMGTRAN1",513,0) FADDone "RTN","TMGTRAN1",514,0) quit "RTN","TMGTRAN1",515,0) "RTN","TMGTRAN1",516,0) "RTN","TMGTRAN1",517,0) ScanSign(OPTIONS,SIGNED) "RTN","TMGTRAN1",518,0) ;"Purpose: To scan through all TIU DOCUMENTS, and release those "RTN","TMGTRAN1",519,0) ;" that have a status of unsigned to completed "RTN","TMGTRAN1",520,0) ;"Input: The following elements in OPTIONS should be defined "RTN","TMGTRAN1",521,0) ;" 0PTIONS("AUTHOR") ;"the IEN of the user (IEN from file 200) "RTN","TMGTRAN1",522,0) ;" OPTIONS("START") ;"Earliest date of documents, in Fileman internal format "RTN","TMGTRAN1",523,0) ;" ;"Note if not specified, then all dates are matched "RTN","TMGTRAN1",524,0) ;" OPTIONS("END") ;"Latest date of documents, in Fileman internal format "RTN","TMGTRAN1",525,0) ;" ;"Note if not specified, then all dates are matched "RTN","TMGTRAN1",526,0) ;" OPTIONS("DETAILS") ;"if 1, then each document is shown as signed (not quiet) "RTN","TMGTRAN1",527,0) ;" OPTIONS("SIG") ;"1 if signature has been verified. "RTN","TMGTRAN1",528,0) ;" -----------Optional OPTIONS below--------------- "RTN","TMGTRAN1",529,0) ;" OPTIONS("TRANS") ;"the IEN of note. If specified, then note will not be signed "RTN","TMGTRAN1",530,0) ;" ;"unless the transcriptionist (i.e. ENTERED BY field) = this IEN "RTN","TMGTRAN1",531,0) ;" ------------------------------------------------------- "RTN","TMGTRAN1",532,0) ;" SIGNED: OPTIONAL. This is an OUT PARAMETER -- must be passed by reference "RTN","TMGTRAN1",533,0) ;" This will contain list of documents freed/signed, in this format: "RTN","TMGTRAN1",534,0) ;" SIGNED(1234)=1234 with 1234 being IEN of document signed. "RTN","TMGTRAN1",535,0) ;" SIGNED(1235)=1235 with 1235 being IEN of document signed. "RTN","TMGTRAN1",536,0) ;" SIGNED(1236)=1236 with 1235 being IEN of document signed. "RTN","TMGTRAN1",537,0) "RTN","TMGTRAN1",538,0) new index "RTN","TMGTRAN1",539,0) new DocAuth,Status,EnteredBy "RTN","TMGTRAN1",540,0) new User,initials "RTN","TMGTRAN1",541,0) new NeedsCR set NeedsCR=1 "RTN","TMGTRAN1",542,0) new StartDT,EndDT "RTN","TMGTRAN1",543,0) new ShowDetails set ShowDetails=+$get(OPTIONS("DETAILS")) "RTN","TMGTRAN1",544,0) "RTN","TMGTRAN1",545,0) if +$get(OPTIONS("START"))=0 do "RTN","TMGTRAN1",546,0) . new %DT "RTN","TMGTRAN1",547,0) . set %DT="AEP" "RTN","TMGTRAN1",548,0) . set %DT("A")="Enter starting date (^ to abort): " "RTN","TMGTRAN1",549,0) . do ^%DT "RTN","TMGTRAN1",550,0) . set OPTIONS("START")=Y "RTN","TMGTRAN1",551,0) if $get(OPTIONS("START"))'>0 do goto SSDone "RTN","TMGTRAN1",552,0) . if ShowDetails write "START date invalid. Aborting.",! "RTN","TMGTRAN1",553,0) "RTN","TMGTRAN1",554,0) if +$get(OPTIONS("END"))=0 do "RTN","TMGTRAN1",555,0) . set %DT("A")="Enter ending date (^ to abort): " "RTN","TMGTRAN1",556,0) . do ^%DT "RTN","TMGTRAN1",557,0) . set OPTIONS("END")=Y "RTN","TMGTRAN1",558,0) if $get(OPTIONS("END"))'>0 do goto SSDone "RTN","TMGTRAN1",559,0) . if ShowDetails write "END date invalid. Aborting.",! "RTN","TMGTRAN1",560,0) "RTN","TMGTRAN1",561,0) set User=+$get(OPTIONS("AUTHOR")) "RTN","TMGTRAN1",562,0) if User=0 do goto RQDone "RTN","TMGTRAN1",563,0) . if $get(OPTIONS("DETAILS")) write "No author IEN supplied. Aborting.",! "RTN","TMGTRAN1",564,0) set StartDT=+$get(OPTIONS("START")) "RTN","TMGTRAN1",565,0) set EndDT=+$get(OPTIONS("END")) "RTN","TMGTRAN1",566,0) "RTN","TMGTRAN1",567,0) if $get(OPTIONS("DETAILS")) do "RTN","TMGTRAN1",568,0) . write !,"------------------------------------------------",! "RTN","TMGTRAN1",569,0) . write "Starting scan of all documents. [ESC] will abort.",! "RTN","TMGTRAN1",570,0) . write "------------------------------------------------",! "RTN","TMGTRAN1",571,0) "RTN","TMGTRAN1",572,0) set initials=$piece($get(^VA(200,User,0)),"^",2) ;"field 1 = initials "RTN","TMGTRAN1",573,0) new sUnsigned set sUnsigned=$order(^TIU(8925.6,"B","UNSIGNED","")) "RTN","TMGTRAN1",574,0) new sUnverified set sUnverified=$order(^TIU(8925.6,"B","UNVERIFIED","")) "RTN","TMGTRAN1",575,0) "RTN","TMGTRAN1",576,0) set index=$order(^TIU(8925,0)) "RTN","TMGTRAN1",577,0) for do quit:(index="") "RTN","TMGTRAN1",578,0) . if index="" quit "RTN","TMGTRAN1",579,0) . new k read *k:0 "RTN","TMGTRAN1",580,0) . if k=27 do quit "RTN","TMGTRAN1",581,0) . . set index="" "RTN","TMGTRAN1",582,0) . . if $get(OPTIONS("DETAILS")) write "Release aborted by ESC from user.",! "RTN","TMGTRAN1",583,0) . set DocAuth=$piece($get(^TIU(8925,index,12)),"^",2) ;"field 1202 = Author "RTN","TMGTRAN1",584,0) . set EnteredBy=$piece($get(^TIU(8925,index,13)),"^",2) ;"field 1302 = Entered By "RTN","TMGTRAN1",585,0) . if (DocAuth=$get(OPTIONS("AUTHOR"))) do "RTN","TMGTRAN1",586,0) . . if $data(OPTIONS("TRANS"))&($get(OPTIONS("TRANS"))'=EnteredBy) quit "RTN","TMGTRAN1",587,0) . . set Status=$piece($get(^TIU(8925,index,0)),"^",5) ;"field .05 = Status "RTN","TMGTRAN1",588,0) . . if (Status=sUnsigned)!(Status=sUnverified) do ;"*** What else should go here?!! "RTN","TMGTRAN1",589,0) . . . new tDate "RTN","TMGTRAN1",590,0) . . . set tDate=$piece($get(^TIU(8925,index,12)),"^",1) "RTN","TMGTRAN1",591,0) . . . set tDate=tDate\1 ;"integer round down (removes time decimal amount) "RTN","TMGTRAN1",592,0) . . . if (StartDT=0)!(EndDT=0)!((tDate'EndDT)) do "RTN","TMGTRAN1",593,0) . . . . if $$SIGNDOC(index,.OPTIONS) do "RTN","TMGTRAN1",594,0) . . . . . set SIGNED(index)=index "RTN","TMGTRAN1",595,0) . set index=+$order(^TIU(8925,index)) "RTN","TMGTRAN1",596,0) . if index=0 set index="" "RTN","TMGTRAN1",597,0) "RTN","TMGTRAN1",598,0) SSDone "RTN","TMGTRAN1",599,0) if $get(OPTIONS("DETAILS")) write !,"Done scanning all documents.",! "RTN","TMGTRAN1",600,0) "RTN","TMGTRAN1",601,0) quit "RTN","TMGTRAN1",602,0) "RTN","TMGTRAN1",603,0) "RTN","TMGTRAN1",604,0) AlertSign(OPTIONS,SIGNED) "RTN","TMGTRAN1",605,0) ;"Purpose: To cycle through all alerts for AUTHOR, and release TIU DOCUMENTS "RTN","TMGTRAN1",606,0) ;" needing signature. "RTN","TMGTRAN1",607,0) ;"Input: The following elements in OPTIONS should be defined "RTN","TMGTRAN1",608,0) ;" 0PTIONS("AUTHOR") ;"the IEN of the user (IEN from file 200) "RTN","TMGTRAN1",609,0) ;" OPTIONS("DETAILS") ;"if 1, then each document is shown as signed (not quiet) "RTN","TMGTRAN1",610,0) ;" OPTIONS("SIG") ;"1 if signature has been verified. "RTN","TMGTRAN1",611,0) ;" OPTIONS("SIGN ALL");"if 1, then all are signed without asking each one. "RTN","TMGTRAN1",612,0) ;" SIGNED: OPTIONAL. This is an OUT PARAMETER -- must be passed by reference "RTN","TMGTRAN1",613,0) ;" This will contain list of documents freed/signed, in this format: "RTN","TMGTRAN1",614,0) ;" SIGNED(1234)=1234 with 1234 being IEN of document signed. "RTN","TMGTRAN1",615,0) ;" SIGNED(1235)=1235 with 1235 being IEN of document signed. "RTN","TMGTRAN1",616,0) ;" SIGNED(1236)=1236 with 1235 being IEN of document signed. "RTN","TMGTRAN1",617,0) "RTN","TMGTRAN1",618,0) new index "RTN","TMGTRAN1",619,0) new Abort set Abort=0 "RTN","TMGTRAN1",620,0) new Alert "RTN","TMGTRAN1",621,0) new DocIEN "RTN","TMGTRAN1",622,0) new NumFound set NumFound=0 "RTN","TMGTRAN1",623,0) new SignAll set SignAll=+$get(OPTIONS("SIGN ALL")) "RTN","TMGTRAN1",624,0) "RTN","TMGTRAN1",625,0) set User=+$get(OPTIONS("AUTHOR")) "RTN","TMGTRAN1",626,0) if User=0 do goto RQDone "RTN","TMGTRAN1",627,0) . if $get(OPTIONS("DETAILS")) write "No author IEN supplied. Aborting.",! "RTN","TMGTRAN1",628,0) "RTN","TMGTRAN1",629,0) if $get(OPTIONS("DETAILS")) do "RTN","TMGTRAN1",630,0) . write !,"-------------------------------------------------------",! "RTN","TMGTRAN1",631,0) . write "Search for 'signature-needed' alerts. [ESC] will abort.",! "RTN","TMGTRAN1",632,0) . write "-------------------------------------------------------",! "RTN","TMGTRAN1",633,0) "RTN","TMGTRAN1",634,0) if SignAll'=1 do if NumFound=0 goto ASgn2 "RTN","TMGTRAN1",635,0) . write !!,"-------- List of Documents to be Signed --------",! "RTN","TMGTRAN1",636,0) . set index=$order(^XTV(8992,User,"XQA",0)) "RTN","TMGTRAN1",637,0) . for do quit:(index="") "RTN","TMGTRAN1",638,0) . . if index="" quit "RTN","TMGTRAN1",639,0) . . new k read *k:0 "RTN","TMGTRAN1",640,0) . . if k=27 do quit "RTN","TMGTRAN1",641,0) . . . set index="" "RTN","TMGTRAN1",642,0) . . . if $get(OPTIONS("DETAILS")) write "List aborted by ESC from user.",! "RTN","TMGTRAN1",643,0) . . set Alert=$get(^XTV(8992,User,"XQA",index,0)) "RTN","TMGTRAN1",644,0) . . if $piece(Alert,"^",3)["available for SIGNATURE" do "RTN","TMGTRAN1",645,0) . . . write $piece(Alert,"^",3),! "RTN","TMGTRAN1",646,0) . . . set NumFound=NumFound+1 "RTN","TMGTRAN1",647,0) . . set index=$order(^XTV(8992,User,"XQA",index)) "RTN","TMGTRAN1",648,0) . write "-----------------------------------------------",! "RTN","TMGTRAN1",649,0) . write !,NumFound," documents needing signature.",!! "RTN","TMGTRAN1",650,0) . if NumFound=0 do quit "RTN","TMGTRAN1",651,0) . . write "No alerts for a missing signature found.!",! "RTN","TMGTRAN1",652,0) "RTN","TMGTRAN1",653,0) ;"WRITE "STARTING SIGN LOOP",! "RTN","TMGTRAN1",654,0) set NumFound=0 "RTN","TMGTRAN1",655,0) set index=$order(^XTV(8992,User,"XQA",0)) "RTN","TMGTRAN1",656,0) for do quit:(index="")!(Abort=1) "RTN","TMGTRAN1",657,0) . new Title,YN "RTN","TMGTRAN1",658,0) . if index="" quit "RTN","TMGTRAN1",659,0) . set Alert=$get(^XTV(8992,User,"XQA",index,0)) "RTN","TMGTRAN1",660,0) . set Title=$piece(Alert,"^",3) "RTN","TMGTRAN1",661,0) . if Title["available for SIGNATURE" do "RTN","TMGTRAN1",662,0) . . set NumFound=NumFound+1 "RTN","TMGTRAN1",663,0) . . if SignAll'=1 do "RTN","TMGTRAN1",664,0) . . . write "Sign: ",$piece(Title," ",1),"? (Y/N/ALL): ALL// " "RTN","TMGTRAN1",665,0) . . . read YN:$get(DTIME,3600),! "RTN","TMGTRAN1",666,0) . . . set YN=$$UP^XLFSTR(YN) "RTN","TMGTRAN1",667,0) . . else set YN="Y" "RTN","TMGTRAN1",668,0) . . if YN="" set YN="ALL" write "ALL",! "RTN","TMGTRAN1",669,0) . . if YN="ALL" set SignAll=1 set YN="Y" "RTN","TMGTRAN1",670,0) . . else if YN["^" write !,"Aborting.",! set Abort=1 quit "RTN","TMGTRAN1",671,0) . . if YN["Y" do "RTN","TMGTRAN1",672,0) . . . set DocIEN=+$get(^XTV(8992,User,"XQA",index,1)) "RTN","TMGTRAN1",673,0) . . . if DocIEN'=0 do "RTN","TMGTRAN1",674,0) . . . . if $$SIGNDOC(DocIEN,.OPTIONS) do "RTN","TMGTRAN1",675,0) . . . . . set SIGNED(DocIEN)=DocIEN "RTN","TMGTRAN1",676,0) . set index=$order(^XTV(8992,User,"XQA",index)) "RTN","TMGTRAN1",677,0) "RTN","TMGTRAN1",678,0) if $get(OPTIONS("DETAILS")) do "RTN","TMGTRAN1",679,0) . write !!,"Done searching for 'needed-signature' alerts.",! "RTN","TMGTRAN1",680,0) "RTN","TMGTRAN1",681,0) ASgn2 "RTN","TMGTRAN1",682,0) if (1=0) do ;"if (NumFound=0) do "RTN","TMGTRAN1",683,0) . if $get(OPTIONS("DETAILS")) do "RTN","TMGTRAN1",684,0) . . write "No alert indicating a signature is needed was found....",! "RTN","TMGTRAN1",685,0) . . write "...So starting a scan of all documents to look for unsigned documents.",! "RTN","TMGTRAN1",686,0) . set OPTIONS("START")="0001111" "RTN","TMGTRAN1",687,0) . do NOW^%DTC "RTN","TMGTRAN1",688,0) . set OPTIONS("END")=X "RTN","TMGTRAN1",689,0) . do ScanSign(.OPTIONS,.Signed) "RTN","TMGTRAN1",690,0) "RTN","TMGTRAN1",691,0) ASgnDone "RTN","TMGTRAN1",692,0) quit "RTN","TMGTRAN1",693,0) "RTN","TMGTRAN1",694,0) "RTN","TMGTRAN1",695,0) SIGNDOC(DocIEN,OPTIONS) "RTN","TMGTRAN1",696,0) ;"Purpose: To sign one document "RTN","TMGTRAN1",697,0) ;"Input: DocIEN -- the record number of the document to sign "RTN","TMGTRAN1",698,0) ;" OPTIONS -- An array with input values. The following are used: "RTN","TMGTRAN1",699,0) ;" 0PTIONS("AUTHOR") ;"the IEN of the user (IEN from file 200) "RTN","TMGTRAN1",700,0) ;" OPTIONS("DETAILS") ;"if 1, then each document showed "RTN","TMGTRAN1",701,0) ;" OPTIONS("SIG") ;"1 if signature has been verified. "RTN","TMGTRAN1",702,0) ;"Results: 1 = successful sign. 0 = failure "RTN","TMGTRAN1",703,0) "RTN","TMGTRAN1",704,0) new result set result=0 ;"default to failure "RTN","TMGTRAN1",705,0) new Node0 "RTN","TMGTRAN1",706,0) new sCompleted set sCompleted=$order(^TIU(8925.6,"B","COMPLETED","")) "RTN","TMGTRAN1",707,0) new NewStatus "RTN","TMGTRAN1",708,0) if $get(OPTIONS("SIG"))'=1 goto SDCDone "RTN","TMGTRAN1",709,0) if +$get(OPTIONS("AUTHOR"))'>0 goto SDCDone "RTN","TMGTRAN1",710,0) if $get(DocIEN)="" goto SDCDone "RTN","TMGTRAN1",711,0) "RTN","TMGTRAN1",712,0) new SignerS "RTN","TMGTRAN1",713,0) set SignerS=1_"^"_$piece($get(^VA(200,+OPTIONS("AUTHOR"),20)),"^",2,3) "RTN","TMGTRAN1",714,0) if $data(^TIU(8925,DocIEN,0))=0 do goto SDCDone "RTN","TMGTRAN1",715,0) . write "Unable to sign document #",DocIEN," because it doesn't seem to exist.",! "RTN","TMGTRAN1",716,0) do ES^TIURS(DocIEN,SignerS) "RTN","TMGTRAN1",717,0) ;"Note: alert(s) r.e. "Note available for signature" are automatically removed "RTN","TMGTRAN1",718,0) "RTN","TMGTRAN1",719,0) SDLoop "RTN","TMGTRAN1",720,0) set Node0=$get(^TIU(8925,DocIEN,0)) "RTN","TMGTRAN1",721,0) set NewStatus=$piece(Node0,"^",5) ;"field .05 = Status "RTN","TMGTRAN1",722,0) "RTN","TMGTRAN1",723,0) new Date,DateS,Pt "RTN","TMGTRAN1",724,0) set Date=$piece(Node0,"^",7) ;"field .07 = Episode begin date/time "RTN","TMGTRAN1",725,0) set DateS=$$FMTE^XLFDT(Date,"D") "RTN","TMGTRAN1",726,0) set Pt=+$piece(Node0,"^",2) ;"field .02 = patient "RTN","TMGTRAN1",727,0) if Pt'=0 set Patient=$piece($get(^DPT(Pt,0)),"^",1) ;"field .01 = name "RTN","TMGTRAN1",728,0) if OPTIONS("DETAILS")=1 do "RTN","TMGTRAN1",729,0) . write DateS," -- ",Patient "RTN","TMGTRAN1",730,0) "RTN","TMGTRAN1",731,0) if NewStatus'=sCompleted do goto SDLoop "RTN","TMGTRAN1",732,0) . if OPTIONS("DETAILS")=1 do "RTN","TMGTRAN1",733,0) . . new s "RTN","TMGTRAN1",734,0) . . set s=$piece($get(^TIU(8925.6,NewStatus,0)),"^",1) "RTN","TMGTRAN1",735,0) . . write " NOT completed. Status=",s "RTN","TMGTRAN1",736,0) . . write !," TRYING AGAIN. (utilizing a lower-level signature method.)",! "RTN","TMGTRAN1",737,0) . . set $piece(^TIU(8925,DocIEN,0),"^",5)=sCompleted "RTN","TMGTRAN1",738,0) "RTN","TMGTRAN1",739,0) if OPTIONS("DETAILS")=1 do "RTN","TMGTRAN1",740,0) . write " Released (auto-'signed')",! "RTN","TMGTRAN1",741,0) "RTN","TMGTRAN1",742,0) set result=1 ;"success "RTN","TMGTRAN1",743,0) "RTN","TMGTRAN1",744,0) SDCDone "RTN","TMGTRAN1",745,0) quit result "RTN","TMGTRAN1",746,0) "RTN","TMGTRAN1",747,0) "RTN","TMGTRAN1",748,0) PRINT(DocArray) ; Prompt and print, or array "RTN","TMGTRAN1",749,0) ;"This function was copied from PRINT^TIUEPRNT, to allow modification "RTN","TMGTRAN1",750,0) ;"Function modification: changed to allow array input. "RTN","TMGTRAN1",751,0) ;" DocArray: This will contain list of documents to print, in this format: "RTN","TMGTRAN1",752,0) ;" DocArray(1234)=1234 with 1234 being IEN of document to be printed. "RTN","TMGTRAN1",753,0) ;" DocArray(1235)=1235 with 1235 being IEN of document to be printed. "RTN","TMGTRAN1",754,0) ;" DocArray(1236)=1236 with 1235 being IEN of document to be printed. "RTN","TMGTRAN1",755,0) ;" Note: Is appears that DocArray(IEN)="" is the needed format. "RTN","TMGTRAN1",756,0) "RTN","TMGTRAN1",757,0) New TIUDEV,TIUTYP,DFN,TIUPMTHD,TIUD0,TIUMSG,TIUPR,TIUDARR,TIUDPRM "RTN","TMGTRAN1",758,0) new TIUFLAG set TIUFLAG="x" "RTN","TMGTRAN1",759,0) New TIUPGRP,TIUPFHDR,TIUPFNBR "RTN","TMGTRAN1",760,0) "RTN","TMGTRAN1",761,0) new index set index=$order(DocArray("")) "RTN","TMGTRAN1",762,0) if index="" goto PRINT1X "RTN","TMGTRAN1",763,0) for do quit:(index="") "RTN","TMGTRAN1",764,0) . set DocIEN=index "RTN","TMGTRAN1",765,0) . ; "RTN","TMGTRAN1",766,0) . If +$$ISADDNDM^TIULC1(DocIEN) Set DocIEN=$Piece($Get(^TIU(8925,+DocIEN,0)),U,6) "RTN","TMGTRAN1",767,0) . If $Get(^TIU(8925,DocIEN,21)) Set DocIEN=^TIU(8925,DocIEN,21) "RTN","TMGTRAN1",768,0) . Set TIUD0=$Get(^TIU(8925,DocIEN,0)) "RTN","TMGTRAN1",769,0) . Set TIUTYP=$Piece(TIUD0,U) "RTN","TMGTRAN1",770,0) . Set DFN=$Piece(TIUD0,U,2) "RTN","TMGTRAN1",771,0) . If +TIUTYP'>0 Quit "RTN","TMGTRAN1",772,0) . ; "RTN","TMGTRAN1",773,0) . Set TIUPMTHD=$$PRNTMTHD^TIULG(+TIUTYP) "RTN","TMGTRAN1",774,0) . Set TIUPGRP=$$PRNTGRP^TIULG(+TIUTYP) "RTN","TMGTRAN1",775,0) . Set TIUPFHDR=$$PRNTHDR^TIULG(+TIUTYP) "RTN","TMGTRAN1",776,0) . Set TIUPFNBR=$$PRNTNBR^TIULG(+TIUTYP) "RTN","TMGTRAN1",777,0) . ; "RTN","TMGTRAN1",778,0) . Do DOCPRM^TIULC1(+TIUTYP,.TIUDPRM,DocIEN) "RTN","TMGTRAN1",779,0) . ; "RTN","TMGTRAN1",780,0) . If +$Piece($Get(TIUDPRM(0)),U,9) do "RTN","TMGTRAN1",781,0) . . if TIUFLAG="x" Set TIUFLAG=$$FLAG^TIUPRPN3 ;"Asks Chart vs. Work Copy? only ONCE "RTN","TMGTRAN1",782,0) . If ($Get(TIUPMTHD)]"")&(+$Get(TIUPGRP))&($Get(TIUPFHDR)]"")&($Get(TIUPFNBR)]"") do "RTN","TMGTRAN1",783,0) . . Set TIUDARR(TIUPMTHD,$Get(TIUPGRP)_"$"_TIUPFHDR_";"_DFN,1,DocIEN)=TIUPFNBR "RTN","TMGTRAN1",784,0) . Else Set TIUDARR(TIUPMTHD,DFN,1,DocIEN)="" "RTN","TMGTRAN1",785,0) . ; "RTN","TMGTRAN1",786,0) . If $Get(TIUPMTHD)']"" do ;"Goto PRINT1X "RTN","TMGTRAN1",787,0) . . if OPTIONS("DETAILS")=1 do "RTN","TMGTRAN1",788,0) . . . Write !,$Char(7),"No Print Method Defined for " "RTN","TMGTRAN1",789,0) . . . write $Piece($Get(^TIU(8925.1,+TIUTYP,0)),U) "RTN","TMGTRAN1",790,0) . . ;"Hang 2 "RTN","TMGTRAN1",791,0) . ; "RTN","TMGTRAN1",792,0) . set index=$order(DocArray(index)) "RTN","TMGTRAN1",793,0) "RTN","TMGTRAN1",794,0) Set TIUDEV=$$DEVICE^TIUDEV(.IO) ; Get Device/allow queueing "RTN","TMGTRAN1",795,0) If ($Get(IO)']"")!(TIUDEV']"") Do ^%ZISC Quit "RTN","TMGTRAN1",796,0) If $Data(IO("Q")) Do QUE^TIUDEV("PRINTQ^TIUEPRNT",TIUDEV) Goto PRINT1X "RTN","TMGTRAN1",797,0) Do PRINTQ^TIUEPRNT "RTN","TMGTRAN1",798,0) Do ^%ZISC "RTN","TMGTRAN1",799,0) "RTN","TMGTRAN1",800,0) PRINT1X ; Exit single document print "RTN","TMGTRAN1",801,0) Quit "RTN","TMGTRAN1",802,0) "RTN","TMGTRAN1",803,0) "RTN","TMGTRAN1",804,0) SHOWUNSIGNED "RTN","TMGTRAN1",805,0) ;"Purpose: to scan through all documents and show any that are unsigned "RTN","TMGTRAN1",806,0) "RTN","TMGTRAN1",807,0) new index "RTN","TMGTRAN1",808,0) new DocAuth,Status,Patient,PtName "RTN","TMGTRAN1",809,0) new TransIEN,TransInit "RTN","TMGTRAN1",810,0) new User,initials,AuthName "RTN","TMGTRAN1",811,0) new NeedsCR set NeedsCR=1 "RTN","TMGTRAN1",812,0) new StartDT,EndDT "RTN","TMGTRAN1",813,0) "RTN","TMGTRAN1",814,0) write !,"----------------------------------------------",! "RTN","TMGTRAN1",815,0) write "Starting scan of documents. [ESC] will abort.",! "RTN","TMGTRAN1",816,0) write "----------------------------------------------",! "RTN","TMGTRAN1",817,0) "RTN","TMGTRAN1",818,0) new sUnsigned set sUnsigned=$order(^TIU(8925.6,"B","UNSIGNED","")) "RTN","TMGTRAN1",819,0) new sCompleted set sCompleted=$order(^TIU(8925.6,"B","COMPLETED","")) "RTN","TMGTRAN1",820,0) "RTN","TMGTRAN1",821,0) set index=$order(^TIU(8925,0)) "RTN","TMGTRAN1",822,0) for do quit:(index="") "RTN","TMGTRAN1",823,0) . if index="" quit "RTN","TMGTRAN1",824,0) . new k read *k:0 "RTN","TMGTRAN1",825,0) . if k=27 do quit "RTN","TMGTRAN1",826,0) . . set index="" "RTN","TMGTRAN1",827,0) . . if $get(OPTIONS("DETAILS")) write "Scan aborted by ESC from user.",! "RTN","TMGTRAN1",828,0) . set Status=$piece($get(^TIU(8925,index,0)),"^",5) ;"field .05 = Status "RTN","TMGTRAN1",829,0) . if (Status'=sCompleted) do "RTN","TMGTRAN1",830,0) . . ;"write ! "RTN","TMGTRAN1",831,0) . . new tDate "RTN","TMGTRAN1",832,0) . . set tDate=$piece($get(^TIU(8925,index,12)),"^",1) "RTN","TMGTRAN1",833,0) . . set DocAuth=$piece($get(^TIU(8925,index,12)),"^",2) ;"field 1202 = Author "RTN","TMGTRAN1",834,0) . . set initials=$piece($get(^VA(200,DocAuth,0)),"^",2) ;"field .02 = initials "RTN","TMGTRAN1",835,0) . . set AuthName=$piece($get(^VA(200,DocAuth,0)),"^",1) ;"field .01 = Name "RTN","TMGTRAN1",836,0) . . set Patient=$piece($get(^TIU(8925,index,0)),"^",2) ;"field .02 = patient IEN "RTN","TMGTRAN1",837,0) . . set TransIEN=$piece($get(^TIU(8925,index,13)),"^",2) ;"field 1302 = Entered by IEN "RTN","TMGTRAN1",838,0) . . if +TransIEN'=0 set TransInit=$piece($get(^VA(200,TransIEN,0)),"^",2) ;" field .02 = initials "RTN","TMGTRAN1",839,0) . . else set TransInit="???" "RTN","TMGTRAN1",840,0) . . if +Patient'=0 set PtName=$piece($get(^DPT(Patient,0)),"^",1) ;"field .01 is patient name "RTN","TMGTRAN1",841,0) . . else set Patient="Name Unknown(?)" "RTN","TMGTRAN1",842,0) . . set DateS=$$DTFormat^TMGMISC(tDate,"ww mm/dd/yy") "RTN","TMGTRAN1",843,0) . . write "NOT COMPLETED. " "RTN","TMGTRAN1",844,0) . . write $$RJ^XLFSTR(AuthName_"; ",20) "RTN","TMGTRAN1",845,0) . . write $$RJ^XLFSTR(DateS_"; ",15) "RTN","TMGTRAN1",846,0) . . write $$RJ^XLFSTR(TransInit_"; ",5) "RTN","TMGTRAN1",847,0) . . write $$Clip^TMGSTUTL(PtName,20),! "RTN","TMGTRAN1",848,0) . ;"else write "." "RTN","TMGTRAN1",849,0) . set index=+$order(^TIU(8925,index)) "RTN","TMGTRAN1",850,0) . if index=0 set index="" "RTN","TMGTRAN1",851,0) "RTN","TMGTRAN1",852,0) write !,"Done scanning documents.",! "RTN","TMGTRAN1",853,0) "RTN","TMGTRAN1",854,0) quit "RTN","TMGTRAN1",855,0) "RTN","TMGTRAN1",856,0) "RTN","TMGTRAN1",857,0) "RTN","TMGTRAN1",858,0) PWDSNOOP(IEN) "RTN","TMGTRAN1",859,0) ;"Purpose: To show private info for a given user "RTN","TMGTRAN1",860,0) ;"NOTICE: This function MUST be used responsibly "RTN","TMGTRAN1",861,0) ;"Input: IEN -- [OPTIONAL] the record number of the user to snoop on "RTN","TMGTRAN1",862,0) "RTN","TMGTRAN1",863,0) write !!,"------------------------------------------------------------------",! "RTN","TMGTRAN1",864,0) write "Notice: This function will unmask private password codes.",! "RTN","TMGTRAN1",865,0) write "These codes can be used spoof this EMR system. Note",! "RTN","TMGTRAN1",866,0) write "that impersonating another user can be a CRIME.",!,! "RTN","TMGTRAN1",867,0) "RTN","TMGTRAN1",868,0) if $data(IEN) goto IS2 "RTN","TMGTRAN1",869,0) "RTN","TMGTRAN1",870,0) set DIC=200 ;"NEW PERSON file "RTN","TMGTRAN1",871,0) set DIC(0)="MAQE" "RTN","TMGTRAN1",872,0) set DIC("A")="Enter name of user to unmask codes for (^ to abort): " "RTN","TMGTRAN1",873,0) do ^DIC "RTN","TMGTRAN1",874,0) if +Y=-1 do goto ISPDone "RTN","TMGTRAN1",875,0) . write !,"No user selected. Aborting report.",! "RTN","TMGTRAN1",876,0) "RTN","TMGTRAN1",877,0) write !,! "RTN","TMGTRAN1",878,0) set IEN=+Y "RTN","TMGTRAN1",879,0) "RTN","TMGTRAN1",880,0) IS2 "RTN","TMGTRAN1",881,0) new VerHash,AccHash,ESig "RTN","TMGTRAN1",882,0) if '$data(IEN) goto ISPDone "RTN","TMGTRAN1",883,0) "RTN","TMGTRAN1",884,0) set VerHash=$piece($get(^VA(200,IEN,.1)),"^",2) "RTN","TMGTRAN1",885,0) set AccHash=$piece($get(^VA(200,IEN,0)),"^",3) "RTN","TMGTRAN1",886,0) set ESig=$piece($get(^VA(200,IEN,20)),"^",4) "RTN","TMGTRAN1",887,0) "RTN","TMGTRAN1",888,0) write "Access Code=",$$UN^XUSHSH(AccHash),! "RTN","TMGTRAN1",889,0) write "Verify Code=",$$UN^XUSHSH(VerHash),! "RTN","TMGTRAN1",890,0) write "Electronic Signature=",ESig,!! "RTN","TMGTRAN1",891,0) "RTN","TMGTRAN1",892,0) write "Remember, you are morally, ethically, and LEGALLY required to use",! "RTN","TMGTRAN1",893,0) write "this information only in an appropriate manner.",! "RTN","TMGTRAN1",894,0) write "------------------------------------------------------------------",! "RTN","TMGTRAN1",895,0) write "Goodbye.",!! "RTN","TMGTRAN1",896,0) "RTN","TMGTRAN1",897,0) ISPDone "RTN","TMGTRAN1",898,0) quit "RTN","TMGTRAN1",899,0) "RTN","TMGTRAN1",900,0) "RTN","TMGTRAN1",901,0) "RTN","TMGTRAN1",902,0) "RTN","TMGTRAN1",903,0) "RTN","TMGTREE") 0^84^B4518 "RTN","TMGTREE",1,0) TMGTREE ;TMG/kst/Text tree user interface ;03/25/06 "RTN","TMGTREE",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGTREE",3,0) "RTN","TMGTREE",4,0) ;"======================================================================= "RTN","TMGTREE",5,0) ;" API -- Public Functions. "RTN","TMGTREE",6,0) ;"======================================================================= "RTN","TMGTREE",7,0) ;"BrowseBy(CompArray,ByTag) "RTN","TMGTREE",8,0) ;"ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen,dSelected) "RTN","TMGTREE",9,0) "RTN","TMGTREE",10,0) ;"======================================================================= "RTN","TMGTREE",11,0) ;" Private Functions. "RTN","TMGTREE",12,0) ;"======================================================================= "RTN","TMGTREE",13,0) "RTN","TMGTREE",14,0) "RTN","TMGTREE",15,0) "RTN","TMGTREE",16,0) BrowseBy(CompArray,ByTag) "RTN","TMGTREE",17,0) ;"Purpose: Allow a user to interact with dynamic text tree "RTN","TMGTREE",18,0) ;" that will open and close nodes. "RTN","TMGTREE",19,0) ;"Input: CompArray -- array to browse. Should be in this format "RTN","TMGTREE",20,0) ;" CompArray("opening tag",a,b,c,d) "RTN","TMGTREE",21,0) ;" ByTag -- the name to use in for "opening tag") "RTN","TMGTREE",22,0) ;"Results: returns Batch/job number, or 0 if none selected "RTN","TMGTREE",23,0) "RTN","TMGTREE",24,0) new aOpen set aOpen=0 "RTN","TMGTREE",25,0) new bOpen set bOpen=0 "RTN","TMGTREE",26,0) new cOpen set cOpen=0 "RTN","TMGTREE",27,0) new dSelected set dSelected=0 "RTN","TMGTREE",28,0) "RTN","TMGTREE",29,0) new done set done=0 "RTN","TMGTREE",30,0) "RTN","TMGTREE",31,0) new input "RTN","TMGTREE",32,0) new result set result=0 "RTN","TMGTREE",33,0) "RTN","TMGTREE",34,0) for do quit:(done=1) "RTN","TMGTREE",35,0) . set result=$$ShowBy(.CompArray,ByTag,aOpen,bOpen,cOpen,dSelected) "RTN","TMGTREE",36,0) . if result>0 set done=1 quit "RTN","TMGTREE",37,0) . read !,"Enter Number to Browse ([Enter] to backup, ^ to Quit): ",input:$get(DTIME,3600),! "RTN","TMGTREE",38,0) . if input="" set input=0 "RTN","TMGTREE",39,0) . if +input>0 do "RTN","TMGTREE",40,0) . . if aOpen=0 do "RTN","TMGTREE",41,0) . . . set aOpen=input,bOpen=0,cOpen=0 "RTN","TMGTREE",42,0) . . else if bOpen=0 do "RTN","TMGTREE",43,0) . . . set bOpen=input,cOpen=0 "RTN","TMGTREE",44,0) . . else if cOpen=0 set cOpen=input "RTN","TMGTREE",45,0) . . else set dSelected=input "RTN","TMGTREE",46,0) . else if input=0 do "RTN","TMGTREE",47,0) . . if cOpen'=0 set cOpen=0,dSelected=0 quit "RTN","TMGTREE",48,0) . . if bOpen'=0 set bOpen=0 quit "RTN","TMGTREE",49,0) . . if aOpen'=0 set aOpen=0 quit "RTN","TMGTREE",50,0) . . if aOpen=0 set input="^" "RTN","TMGTREE",51,0) . if input="^" set done=1 "RTN","TMGTREE",52,0) "RTN","TMGTREE",53,0) quit result "RTN","TMGTREE",54,0) "RTN","TMGTREE",55,0) "RTN","TMGTREE",56,0) ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen,dSelected) "RTN","TMGTREE",57,0) ;"Purpose: Draw current state of text tree "RTN","TMGTREE",58,0) ;"Input: CompArray -- array to browse. Should be in this format "RTN","TMGTREE",59,0) ;" CompArray("opening tag",a,b,c,d) "RTN","TMGTREE",60,0) ;" ByTag -- the name to use in for "opening tag") "RTN","TMGTREE",61,0) ;"Result: if aOpen,bOpen, and cOpen,dSelected are valid values, then "RTN","TMGTREE",62,0) ;" will return value from CompArray, i.e. "RTN","TMGTREE",63,0) ;" CompArray("opening tag",a,b,c,d)="x" <--- will return "x" "RTN","TMGTREE",64,0) ;" otherwise returns 0 "RTN","TMGTREE",65,0) "RTN","TMGTREE",66,0) new a,b,c,d "RTN","TMGTREE",67,0) new acount set acount=0 "RTN","TMGTREE",68,0) new bcount set bcount=0 "RTN","TMGTREE",69,0) new ccount set ccount=0 "RTN","TMGTREE",70,0) new dcount set dcount=0 "RTN","TMGTREE",71,0) new result set result=0 "RTN","TMGTREE",72,0) "RTN","TMGTREE",73,0) write #,! "RTN","TMGTREE",74,0) "RTN","TMGTREE",75,0) set a=$order(CompArray(ByTag,"")) "RTN","TMGTREE",76,0) if a'="" for do quit:(a="") "RTN","TMGTREE",77,0) . set acount=acount+1 "RTN","TMGTREE",78,0) . new nexta set nexta=$order(CompArray(ByTag,a)) "RTN","TMGTREE",79,0) . new Aindent "RTN","TMGTREE",80,0) . if (aOpen=0) do "RTN","TMGTREE",81,0) . . if acount<10 write "0" "RTN","TMGTREE",82,0) . . write acount,". " "RTN","TMGTREE",83,0) . else write "... " "RTN","TMGTREE",84,0) . write a,! "RTN","TMGTREE",85,0) . set b=$order(CompArray(ByTag,a,"")) "RTN","TMGTREE",86,0) . if (aOpen=acount)&(b'="") for do quit:(b="") "RTN","TMGTREE",87,0) . . set bcount=bcount+1 "RTN","TMGTREE",88,0) . . new nextb set nextb=$order(CompArray(ByTag,a,b)) "RTN","TMGTREE",89,0) . . new Bindent "RTN","TMGTREE",90,0) . . write " +--" "RTN","TMGTREE",91,0) . . if (bOpen=0) do "RTN","TMGTREE",92,0) . . . if bcount<10 write "0" "RTN","TMGTREE",93,0) . . . write bcount,". " "RTN","TMGTREE",94,0) . . else write "... " "RTN","TMGTREE",95,0) . . write b,! "RTN","TMGTREE",96,0) . . if nextb'="" set Aindent=" | " "RTN","TMGTREE",97,0) . . else set Aindent=" " "RTN","TMGTREE",98,0) . . set c=$order(CompArray(ByTag,a,b,"")) "RTN","TMGTREE",99,0) . . if (bOpen=bcount)&(c'="") for do quit:(c="") "RTN","TMGTREE",100,0) . . . set ccount=ccount+1 "RTN","TMGTREE",101,0) . . . new nextc set nextc=$order(CompArray(ByTag,a,b,c)) "RTN","TMGTREE",102,0) . . . if nextc'="" set Bindent=" | " "RTN","TMGTREE",103,0) . . . else set Bindent=" " "RTN","TMGTREE",104,0) . . . write Aindent," +--" "RTN","TMGTREE",105,0) . . . if (cOpen=0) do "RTN","TMGTREE",106,0) . . . . if ccount<10 write "0" "RTN","TMGTREE",107,0) . . . . write ccount,". " "RTN","TMGTREE",108,0) . . . else write "... " "RTN","TMGTREE",109,0) . . . write c,! "RTN","TMGTREE",110,0) . . . set d=$order(CompArray(ByTag,a,b,c,"")) "RTN","TMGTREE",111,0) . . . if (cOpen=ccount)&(d'="") for do quit:(d="") "RTN","TMGTREE",112,0) . . . . set dcount=dcount+1 "RTN","TMGTREE",113,0) . . . . write Aindent,Bindent," +-- " "RTN","TMGTREE",114,0) . . . . if dcount<10 write "0" "RTN","TMGTREE",115,0) . . . . write dcount,". " "RTN","TMGTREE",116,0) . . . . write d,! "RTN","TMGTREE",117,0) . . . . if dcount=dSelected set result=$get(CompArray(ByTag,a,b,c,d)) "RTN","TMGTREE",118,0) . . . . set d=$order(CompArray(ByTag,a,b,c,d)) "RTN","TMGTREE",119,0) . . . set c=nextc "RTN","TMGTREE",120,0) . . set b=nextb "RTN","TMGTREE",121,0) . set a=nexta "RTN","TMGTREE",122,0) "RTN","TMGTREE",123,0) SBDone "RTN","TMGTREE",124,0) quit result "RTN","TMGTREE",125,0) "RTN","TMGTREE",126,0) "RTN","TMGTRNRP") 0^85^B1962236 "RTN","TMGTRNRP",1,0) TMGTRNRP ;TMG/kst/TRANSCRIPTION REPRINT REPORT FUNCTIONS ;03/25/06 "RTN","TMGTRNRP",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGTRNRP",3,0) "RTN","TMGTRNRP",4,0) ;" TRANSCRIPTION REPRINT REPORT FUNCTIONS "RTN","TMGTRNRP",5,0) "RTN","TMGTRNRP",6,0) ;"======================================================================= "RTN","TMGTRNRP",7,0) ;" API -- Public Functions. "RTN","TMGTRNRP",8,0) ;"======================================================================= "RTN","TMGTRNRP",9,0) ;"REPRINTSET "RTN","TMGTRNRP",10,0) ;"PRTEMPL -- RE-PRINT TEMPLATE "RTN","TMGTRNRP",11,0) "RTN","TMGTRNRP",12,0) ;"======================================================================= "RTN","TMGTRNRP",13,0) ;" Private Functions. "RTN","TMGTRNRP",14,0) ;"======================================================================= "RTN","TMGTRNRP",15,0) ;"LoadBatches(CompArray) "RTN","TMGTRNRP",16,0) ;"ShowBatchInfo(Info) "RTN","TMGTRNRP",17,0) ;"ShowSummary(Summary) "RTN","TMGTRNRP",18,0) ;"OneLineSummary(Summary,Array,Batch) "RTN","TMGTRNRP",19,0) ;"SummarizeBatchInfo(Info,Summary) "RTN","TMGTRNRP",20,0) ;"GetBatchInfo(Job,Info) "RTN","TMGTRNRP",21,0) ;"GetDocInfo(DocIEN,Info) "RTN","TMGTRNRP",22,0) "RTN","TMGTRNRP",23,0) "RTN","TMGTRNRP",24,0) "RTN","TMGTRNRP",25,0) REPRINTSET "RTN","TMGTRNRP",26,0) ;"Purpose: In our setting, we have the transcriptionists signing documents for the physicians, "RTN","TMGTRNRP",27,0) ;" because they won't sign them for themselves. A problem arose where the notes "RTN","TMGTRNRP",28,0) ;" were not properly printed at the time of signing. So this function allows a user "RTN","TMGTRNRP",29,0) ;" to browse through the batches of signed documents, and reprint them. "RTN","TMGTRNRP",30,0) "RTN","TMGTRNRP",31,0) new CompArray "RTN","TMGTRNRP",32,0) new SelectedBatch set SelectedBatch=0 "RTN","TMGTRNRP",33,0) new done set done=0 "RTN","TMGTRNRP",34,0) "RTN","TMGTRNRP",35,0) write #,! "RTN","TMGTRNRP",36,0) write " --------------------------------------------------",! "RTN","TMGTRNRP",37,0) write " Re-Print Documents that were Batch-Signed.",! "RTN","TMGTRNRP",38,0) write " --------------------------------------------------",! "RTN","TMGTRNRP",39,0) write !,"Scanning documents... Please wait.",! "RTN","TMGTRNRP",40,0) "RTN","TMGTRNRP",41,0) do LoadBatches(.CompArray) "RTN","TMGTRNRP",42,0) "RTN","TMGTRNRP",43,0) Loop1 "RTN","TMGTRNRP",44,0) write #,! "RTN","TMGTRNRP",45,0) write " --------------------------------------------------",! "RTN","TMGTRNRP",46,0) write " Re-Print Documents that were Batch-Signed.",! "RTN","TMGTRNRP",47,0) write " --------------------------------------------------",! "RTN","TMGTRNRP",48,0) write " How would you like to search for the correct batch?",! "RTN","TMGTRNRP",49,0) write " 1. By Date Signed.",! "RTN","TMGTRNRP",50,0) write " 2. By Transcriptionist.",! "RTN","TMGTRNRP",51,0) write " 3. By Author.",! "RTN","TMGTRNRP",52,0) write " 4. By Visit date.",! "RTN","TMGTRNRP",53,0) write " 5. Exit",!! "RTN","TMGTRNRP",54,0) "RTN","TMGTRNRP",55,0) new input "RTN","TMGTRNRP",56,0) read "Enter Number of Option: ",input:$get(DTIME,3600),! "RTN","TMGTRNRP",57,0) if (input="")!(input="^") set input="5" "RTN","TMGTRNRP",58,0) "RTN","TMGTRNRP",59,0) if input="1" do "RTN","TMGTRNRP",60,0) . set SelectedBatch=$$BrowseBy^TMGTREE(.CompArray,"BY-SIGNED") "RTN","TMGTRNRP",61,0) else if input="2" do "RTN","TMGTRNRP",62,0) . set SelectedBatch=$$BrowseBy^TMGTREE(.CompArray,"BY-TRANS") "RTN","TMGTRNRP",63,0) else if input="3" do "RTN","TMGTRNRP",64,0) . set SelectedBatch=$$BrowseBy^TMGTREE(.CompArray,"BY-AUTHOR") "RTN","TMGTRNRP",65,0) else if input="4" do "RTN","TMGTRNRP",66,0) . set SelectedBatch=$$BrowseBy^TMGTREE(.CompArray,"BY-VISITDATE") "RTN","TMGTRNRP",67,0) else if input="5" set done=1 "RTN","TMGTRNRP",68,0) "RTN","TMGTRNRP",69,0) if SelectedBatch>0 do "RTN","TMGTRNRP",70,0) . set done=$$PrintBatch(SelectedBatch) "RTN","TMGTRNRP",71,0) "RTN","TMGTRNRP",72,0) if done=0 goto Loop1 "RTN","TMGTRNRP",73,0) "RTN","TMGTRNRP",74,0) RPSDone "RTN","TMGTRNRP",75,0) write !,"Goodbye.",! "RTN","TMGTRNRP",76,0) quit "RTN","TMGTRNRP",77,0) "RTN","TMGTRNRP",78,0) "RTN","TMGTRNRP",79,0) PrintBatch(SelectedBatch) "RTN","TMGTRNRP",80,0) ;"Purpose: To reprint a set of batch signed documents "RTN","TMGTRNRP",81,0) ;"Input: the SelectedBatch (really a job number) to print "RTN","TMGTRNRP",82,0) ;"Result: 1 if print OK. 0 if user cancels "RTN","TMGTRNRP",83,0) "RTN","TMGTRNRP",84,0) new result set result=0 "RTN","TMGTRNRP",85,0) "RTN","TMGTRNRP",86,0) write !,"Great, you have selected batch: #",SelectedBatch,! "RTN","TMGTRNRP",87,0) new Info,input "RTN","TMGTRNRP",88,0) if $$GetBatchInfo(SelectedBatch,.Info) do "RTN","TMGTRNRP",89,0) . do ShowBatchInfo(.Info) "RTN","TMGTRNRP",90,0) . read !,"Reprint this batch? YES// ",input:$get(DTIME,3600),! "RTN","TMGTRNRP",91,0) . if input="" set input="Y" "RTN","TMGTRNRP",92,0) . if ("YesyesYES"[input)=0 quit "RTN","TMGTRNRP",93,0) . new PrintArray "RTN","TMGTRNRP",94,0) . merge PrintArray=^TMG("BATCH SIGNED DOCS",SelectedBatch) "RTN","TMGTRNRP",95,0) . do PRINT^TMGTRAN1(.PrintArray) "RTN","TMGTRNRP",96,0) . set result=1 "RTN","TMGTRNRP",97,0) "RTN","TMGTRNRP",98,0) PBDone "RTN","TMGTRNRP",99,0) quit result "RTN","TMGTRNRP",100,0) "RTN","TMGTRNRP",101,0) "RTN","TMGTRNRP",102,0) LoadBatches(CompArray) "RTN","TMGTRNRP",103,0) ;"Purpose: to browse through the batches, and allow user to select one "RTN","TMGTRNRP",104,0) ;"Input: compArray -- PASS BY REFERENCE -- an array to put composite into "RTN","TMGTRNRP",105,0) ;"Results: returns a batch/job number "RTN","TMGTRNRP",106,0) "RTN","TMGTRNRP",107,0) new cTmp set cTmp="BATCH SIGNED DOCS" "RTN","TMGTRNRP",108,0) new Batch "RTN","TMGTRNRP",109,0) "RTN","TMGTRNRP",110,0) set Batch=$order(^TMG(cTmp,"")) "RTN","TMGTRNRP",111,0) if Batch'="" for do quit:(Batch="") "RTN","TMGTRNRP",112,0) . new Info,Summary "RTN","TMGTRNRP",113,0) . if $$GetBatchInfo(Batch,.Info) do "RTN","TMGTRNRP",114,0) . . do SummarizeBatch(.Info,.Summary) "RTN","TMGTRNRP",115,0) . . new OneLine "RTN","TMGTRNRP",116,0) . . set OneLine=$$OneLineSummary(.Summary,.CompArray,Batch) "RTN","TMGTRNRP",117,0) . set Batch=$order(^TMG(cTmp,Batch)) "RTN","TMGTRNRP",118,0) "RTN","TMGTRNRP",119,0) ;"zwr CompArray(*) "RTN","TMGTRNRP",120,0) "RTN","TMGTRNRP",121,0) BBDone "RTN","TMGTRNRP",122,0) quit "RTN","TMGTRNRP",123,0) "RTN","TMGTRNRP",124,0) "RTN","TMGTRNRP",125,0) ShowBatchInfo(Info) "RTN","TMGTRNRP",126,0) ;"Purpose: To Display the info retrieved by GetBatchInfo "RTN","TMGTRNRP",127,0) "RTN","TMGTRNRP",128,0) new DocIEN,i "RTN","TMGTRNRP",129,0) "RTN","TMGTRNRP",130,0) write "Visit Date; Transcr Date; Signed Date; Transcr, Author; Patient",! "RTN","TMGTRNRP",131,0) for i=1:1:60 write "-" "RTN","TMGTRNRP",132,0) write ! "RTN","TMGTRNRP",133,0) set DocIEN=$order(Info("")) "RTN","TMGTRNRP",134,0) if +DocIEN>0 for do quit:(+DocIEN=0) "RTN","TMGTRNRP",135,0) . new tDate "RTN","TMGTRNRP",136,0) . set tDate=$get(Info(DocIEN,"VISIT DATE")) "RTN","TMGTRNRP",137,0) . write $$DTFormat^TMGMISC(tDate,"ww mm/dd/yy"),"; " "RTN","TMGTRNRP",138,0) . set tDate=$get(Info(DocIEN,"TRANS DATE")) "RTN","TMGTRNRP",139,0) . write $$DTFormat^TMGMISC(tDate,"ww mm/dd/yy"),"; " "RTN","TMGTRNRP",140,0) . set tDate=$get(Info(DocIEN,"DATE SIGNED")) "RTN","TMGTRNRP",141,0) . write $$DTFormat^TMGMISC(tDate,"ww mm/dd/yy"),"; " "RTN","TMGTRNRP",142,0) . write $get(Info(DocIEN,"TRANS","INITS")),"; " "RTN","TMGTRNRP",143,0) . write $get(Info(DocIEN,"AUTHOR","INITS")),"; " "RTN","TMGTRNRP",144,0) . write $get(Info(DocIEN,"PATIENT","NAME")),"; " "RTN","TMGTRNRP",145,0) . write ! "RTN","TMGTRNRP",146,0) . set DocIEN=$order(Info(DocIEN)) "RTN","TMGTRNRP",147,0) "RTN","TMGTRNRP",148,0) SBIDone "RTN","TMGTRNRP",149,0) quit "RTN","TMGTRNRP",150,0) "RTN","TMGTRNRP",151,0) "RTN","TMGTRNRP",152,0) ShowSummary(Summary) "RTN","TMGTRNRP",153,0) ;"Purpose: to Display the Summary retrieved by SummarizeBatchInfo "RTN","TMGTRNRP",154,0) "RTN","TMGTRNRP",155,0) new ts,tDate,tCount "RTN","TMGTRNRP",156,0) "RTN","TMGTRNRP",157,0) set ts=$order(Summary("TRANS","INITS","")) "RTN","TMGTRNRP",158,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",159,0) . set tCount=$get(Summary("TRANS","INITS",ts)) "RTN","TMGTRNRP",160,0) . write tCount," patients transcribed by ",ts,! "RTN","TMGTRNRP",161,0) . set ts=$order(Summary("TRANS","INITS",ts)) "RTN","TMGTRNRP",162,0) "RTN","TMGTRNRP",163,0) set ts=$order(Summary("AUTHOR","NAME","")) "RTN","TMGTRNRP",164,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",165,0) . set tCount=$get(Summary("AUTHOR","NAME",ts)) "RTN","TMGTRNRP",166,0) . write tCount," patients with author: ",ts,! "RTN","TMGTRNRP",167,0) . set ts=$order(Summary("AUTHOR","NAME",ts)) "RTN","TMGTRNRP",168,0) "RTN","TMGTRNRP",169,0) set ts=$order(Summary("DATE SIGNED","")) "RTN","TMGTRNRP",170,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",171,0) . set tCount=$get(Summary("DATE SIGNED",ts)) "RTN","TMGTRNRP",172,0) . set tDate=$$DTFormat^TMGMISC(ts,"ww mm/dd/yy") "RTN","TMGTRNRP",173,0) . write +tCount," patients with date signed: ",tDate,! "RTN","TMGTRNRP",174,0) . set ts=$order(Summary("DATE SIGNED",ts)) "RTN","TMGTRNRP",175,0) "RTN","TMGTRNRP",176,0) set ts=$order(Summary("VISIT DATE","")) "RTN","TMGTRNRP",177,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",178,0) . set tCount=$get(Summary("VISIT DATE",ts)) "RTN","TMGTRNRP",179,0) . set tDate=$$DTFormat^TMGMISC(ts,"ww mm/dd/yy") "RTN","TMGTRNRP",180,0) . write +tCount," patients with visit date: ",tDate,! "RTN","TMGTRNRP",181,0) . set ts=$order(Summary("VISIT DATE",ts)) "RTN","TMGTRNRP",182,0) "RTN","TMGTRNRP",183,0) set ts=$order(Summary("TRANS DATE","")) "RTN","TMGTRNRP",184,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",185,0) . set tCount=$get(Summary("TRANS DATE",ts)) "RTN","TMGTRNRP",186,0) . set tDate=$$DTFormat^TMGMISC(ts,"ww mm/dd/yy") "RTN","TMGTRNRP",187,0) . write +tCount," patients with transcription date: ",tDate,! "RTN","TMGTRNRP",188,0) . set ts=$order(Summary("TRANS DATE",ts)) "RTN","TMGTRNRP",189,0) "RTN","TMGTRNRP",190,0) write "--------------------------------------------------",! "RTN","TMGTRNRP",191,0) quit "RTN","TMGTRNRP",192,0) "RTN","TMGTRNRP",193,0) "RTN","TMGTRNRP",194,0) OneLineSummary(Summary,Array,Batch) "RTN","TMGTRNRP",195,0) ;"Purpose: to Display the Summary retrieved by SummarizeBatchInfo "RTN","TMGTRNRP",196,0) ;"Input: Summary -- the array to display info from "RTN","TMGTRNRP",197,0) ;" Array - PASS BY REFERENCE an out parameter "RTN","TMGTRNRP",198,0) ;" Will put results into array, if passed "RTN","TMGTRNRP",199,0) ;" Format: "RTN","TMGTRNRP",200,0) ;" Array(DateSigned,TransInitials,AuthorName,VisitDate) "RTN","TMGTRNRP",201,0) ;" Batch: number of batchused to label line "RTN","TMGTRNRP",202,0) ;"Results: a one line summary. If multiple entries, just picks larges. "RTN","TMGTRNRP",203,0) "RTN","TMGTRNRP",204,0) new ts,tDate,date,tCount,count,S,entries "RTN","TMGTRNRP",205,0) new DateSigned,TransInitials,AuthorName,VisitDate "RTN","TMGTRNRP",206,0) new result set result="" "RTN","TMGTRNRP",207,0) "RTN","TMGTRNRP",208,0) set S="",count=0,entries=0 "RTN","TMGTRNRP",209,0) set ts=$order(Summary("DATE SIGNED","")) "RTN","TMGTRNRP",210,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",211,0) . set entries=entries+1 "RTN","TMGTRNRP",212,0) . set tCount=$get(Summary("DATE SIGNED",ts)) "RTN","TMGTRNRP",213,0) . if tCount>count do "RTN","TMGTRNRP",214,0) . . set count=tCount "RTN","TMGTRNRP",215,0) . . set S="Signed "_$$DTFormat^TMGMISC(ts,"mm/dd/yy") "RTN","TMGTRNRP",216,0) . set ts=$order(Summary("DATE SIGNED",ts)) "RTN","TMGTRNRP",217,0) if entries>1 set S=S_"+" "RTN","TMGTRNRP",218,0) set DateSigned=S "RTN","TMGTRNRP",219,0) set result=result_S "RTN","TMGTRNRP",220,0) set result=result_"; " "RTN","TMGTRNRP",221,0) "RTN","TMGTRNRP",222,0) set S="",count=0 "RTN","TMGTRNRP",223,0) set ts=$order(Summary("TRANS","NAME","")) "RTN","TMGTRNRP",224,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",225,0) . set entries=entries+1 "RTN","TMGTRNRP",226,0) . set tCount=$get(Summary("TRANS","NAME",ts)) "RTN","TMGTRNRP",227,0) . if tCount>count do "RTN","TMGTRNRP",228,0) . . set count=tCount "RTN","TMGTRNRP",229,0) . . set S=ts "RTN","TMGTRNRP",230,0) . set ts=$order(Summary("TRANS","NAME",ts)) "RTN","TMGTRNRP",231,0) if entries>1 set S=S_"+" "RTN","TMGTRNRP",232,0) set TransInitials=S "RTN","TMGTRNRP",233,0) set result=result_S "RTN","TMGTRNRP",234,0) set result=result_"; " "RTN","TMGTRNRP",235,0) "RTN","TMGTRNRP",236,0) set S="",count=0 "RTN","TMGTRNRP",237,0) set ts=$order(Summary("AUTHOR","NAME","")) "RTN","TMGTRNRP",238,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",239,0) . set entries=entries+1 "RTN","TMGTRNRP",240,0) . set tCount=$get(Summary("AUTHOR","NAME",ts)) "RTN","TMGTRNRP",241,0) . if tCount>count do "RTN","TMGTRNRP",242,0) . . set count=tCount "RTN","TMGTRNRP",243,0) . . set S=ts "RTN","TMGTRNRP",244,0) . set ts=$order(Summary("AUTHOR","NAME",ts)) "RTN","TMGTRNRP",245,0) if entries>1 set S=S_"+" "RTN","TMGTRNRP",246,0) set AuthorName=S "RTN","TMGTRNRP",247,0) set result=result_S "RTN","TMGTRNRP",248,0) set result=result_"; " "RTN","TMGTRNRP",249,0) "RTN","TMGTRNRP",250,0) set S="",count=0 "RTN","TMGTRNRP",251,0) set ts=$order(Summary("VISIT DATE","")) "RTN","TMGTRNRP",252,0) if ts'="" for do quit:(ts="") "RTN","TMGTRNRP",253,0) . set entries=entries+1 "RTN","TMGTRNRP",254,0) . set tCount=$get(Summary("VISIT DATE",ts)) "RTN","TMGTRNRP",255,0) . if tCount>count do "RTN","TMGTRNRP",256,0) . . set count=tCount "RTN","TMGTRNRP",257,0) . . set S=$$DTFormat^TMGMISC(ts,"ww mm/dd/yy") "RTN","TMGTRNRP",258,0) . set ts=$order(Summary("VISIT DATE",ts)) "RTN","TMGTRNRP",259,0) if entries>1 set S=S_"+" "RTN","TMGTRNRP",260,0) set VisitDate=S "RTN","TMGTRNRP",261,0) set result=result_"Visit date: "_S "RTN","TMGTRNRP",262,0) set result=result_"; " "RTN","TMGTRNRP",263,0) "RTN","TMGTRNRP",264,0) set Array("BY-SIGNED",DateSigned,TransInitials,AuthorName,VisitDate)=$get(Batch) "RTN","TMGTRNRP",265,0) set Array("BY-TRANS",TransInitials,DateSigned,AuthorName,VisitDate)=$get(Batch) "RTN","TMGTRNRP",266,0) set Array("BY-AUTHOR",AuthorName,DateSigned,TransInitials,VisitDate)=$get(Batch) "RTN","TMGTRNRP",267,0) set Array("BY-VISITDATE",VisitDate,DateSigned,TransInitials,AuthorName)=$get(Batch) "RTN","TMGTRNRP",268,0) "RTN","TMGTRNRP",269,0) quit result "RTN","TMGTRNRP",270,0) "RTN","TMGTRNRP",271,0) "RTN","TMGTRNRP",272,0) SummarizeBatchInfo(Info,Summary) "RTN","TMGTRNRP",273,0) ;"Purpose: To summarize info retrieved by GetBatchInfo "RTN","TMGTRNRP",274,0) ;"Input: Info -- PASS BY REFERENCE -- the info array to display "RTN","TMGTRNRP",275,0) ;" Summary -- PASS BY REFERENCE -- the array to contain summary info. "RTN","TMGTRNRP",276,0) ;" Format as follows: "RTN","TMGTRNRP",277,0) ;" Summary("TRANS","INITS","nlx")=count "RTN","TMGTRNRP",278,0) ;" Summary("TRANS","NAME","Nancy L. Xavier")=count "RTN","TMGTRNRP",279,0) ;" Summary("DATE SIGNED", FMDate)=count "RTN","TMGTRNRP",280,0) ;" Summary("AUTHOR","NAME","Marcus M. Welby")=count "RTN","TMGTRNRP",281,0) ;" Summary("AUTHOR","INITS","mmw")=count "RTN","TMGTRNRP",282,0) ;" Summary("PATIENTS")=count "RTN","TMGTRNRP",283,0) ;" Summary("VISIT DATE",FMDate)=count "RTN","TMGTRNRP",284,0) ;" Summary("TRANS DATE",FMDate)=count "RTN","TMGTRNRP",285,0) "RTN","TMGTRNRP",286,0) new DocIEN "RTN","TMGTRNRP",287,0) set DocIEN=$order(Info("")) "RTN","TMGTRNRP",288,0) if +DocIEN>0 for do quit:(+DocIEN=0) "RTN","TMGTRNRP",289,0) . new tDate,tInits,tName "RTN","TMGTRNRP",290,0) . set tDate=$get(Info(DocIEN,"VISIT DATE"))\1 "RTN","TMGTRNRP",291,0) . set Summary("VISIT DATE",tDate)=$get(Summary("VISIT DATE",tDate))+1 "RTN","TMGTRNRP",292,0) . set tDate=$get(Info(DocIEN,"TRANS DATE"))\1 "RTN","TMGTRNRP",293,0) . set Summary("TRANS DATE",tDate)=$get(Summary("TRANS DATE",tDate))+1 "RTN","TMGTRNRP",294,0) . set tDate=$get(Info(DocIEN,"DATE SIGNED"))\1 "RTN","TMGTRNRP",295,0) . set Summary("DATE SIGNED",tDate)=$get(Summary("DATE SIGNED",tDate))+1 "RTN","TMGTRNRP",296,0) . set tInits=$get(Info(DocIEN,"TRANS","INITS")) "RTN","TMGTRNRP",297,0) . set Summary("TRANS","INITS",tInits)=$get(Summary("TRANS","INITS",tInits))+1 "RTN","TMGTRNRP",298,0) . set tName=$get(Info(DocIEN,"TRANS","NAME")) "RTN","TMGTRNRP",299,0) . set Summary("TRANS","NAME",tName)=$get(Summary("TRANS","NAME",tName))+1 "RTN","TMGTRNRP",300,0) . set tInits=$get(Info(DocIEN,"AUTHOR","INITS")) "RTN","TMGTRNRP",301,0) . set Summary("AUTHOR","INITS",tInits)=$get(Summary("AUTHOR","INITS",tInits))+1 "RTN","TMGTRNRP",302,0) . set tName=$get(Info(DocIEN,"AUTHOR","NAME")) "RTN","TMGTRNRP",303,0) . set Summary("AUTHOR","NAME",tName)=$get(Summary("AUTHOR","NAME",tName))+1 "RTN","TMGTRNRP",304,0) . set Summary("PATIENTS")=$get(Summary("PATIENTS"))+1 "RTN","TMGTRNRP",305,0) . set DocIEN=$order(Info(DocIEN)) "RTN","TMGTRNRP",306,0) "RTN","TMGTRNRP",307,0) SmBIDone "RTN","TMGTRNRP",308,0) quit "RTN","TMGTRNRP",309,0) "RTN","TMGTRNRP",310,0) GetBatchInfo(Job,Info) "RTN","TMGTRNRP",311,0) ;"Purpose: to return stats for a given sign batch "RTN","TMGTRNRP",312,0) ;"Input: Job: the job number to investigate "RTN","TMGTRNRP",313,0) ;" Info -- PASS BY REFERENCE.. an out parameter "RTN","TMGTRNRP",314,0) ;" Format: Returns an aggregate array of all the docs "RTN","TMGTRNRP",315,0) ;" Info(DocIEN,"TRANS","INITS")="nlx" "RTN","TMGTRNRP",316,0) ;" Info(DocIEN,"TRANS","NAME")="Nancy L. Xavier" "RTN","TMGTRNRP",317,0) ;" Info(DocIEN,"TRANS","IEN")=1234 "RTN","TMGTRNRP",318,0) ;" Info(DocIEN,"DATE SIGNED")=FMDate "RTN","TMGTRNRP",319,0) ;" Info(DocIEN,"AUTHOR","NAME")="Marcus M. Welby" "RTN","TMGTRNRP",320,0) ;" Info(DocIEN,"AUTHOR","INITS")="mmw" "RTN","TMGTRNRP",321,0) ;" Info(DocIEN,"AUTHOR","IEN")="1234 "RTN","TMGTRNRP",322,0) ;" Info(DocIEN,"PATIENT","NAME")="Doe,John G" "RTN","TMGTRNRP",323,0) ;" Info(DocIEN,"VISIT DATE")=FMDate "RTN","TMGTRNRP",324,0) ;" Info(DocIEN,"TRANS DATE")=FMDate "RTN","TMGTRNRP",325,0) ;"Result: 0 if failure, otherwise 1 "RTN","TMGTRNRP",326,0) "RTN","TMGTRNRP",327,0) new result set result=0 "RTN","TMGTRNRP",328,0) new cTmp set cTmp="BATCH SIGNED DOCS" "RTN","TMGTRNRP",329,0) new DocInfo "RTN","TMGTRNRP",330,0) if +$get(Job)=0 goto GBIDone "RTN","TMGTRNRP",331,0) "RTN","TMGTRNRP",332,0) new DocIEN set DocIEN=$order(^TMG(cTmp,Job,0)) "RTN","TMGTRNRP",333,0) if +DocIEN>0 for do quit:(+DocIEN=0) "RTN","TMGTRNRP",334,0) . set result=$$GetDocInfo(DocIEN,.Info) "RTN","TMGTRNRP",335,0) . set DocIEN=$order(^TMG(cTmp,Job,DocIEN)) "RTN","TMGTRNRP",336,0) "RTN","TMGTRNRP",337,0) GBIDone "RTN","TMGTRNRP",338,0) quit result "RTN","TMGTRNRP",339,0) "RTN","TMGTRNRP",340,0) "RTN","TMGTRNRP",341,0) GetDocInfo(DocIEN,Info) "RTN","TMGTRNRP",342,0) ;"Purpose: to get information on a given documen "RTN","TMGTRNRP",343,0) ;"Input: DocIEN - the IEN number of the document to investigate "RTN","TMGTRNRP",344,0) ;" Info -- PASS BY REFERENCE an out parameter "RTN","TMGTRNRP",345,0) ;" Format as follows: "RTN","TMGTRNRP",346,0) ;" Info(DocIEN,"TRANS","INITS")="nlx" "RTN","TMGTRNRP",347,0) ;" Info(DocIEN,"TRANS","NAME")="Nancy L. Xavier" "RTN","TMGTRNRP",348,0) ;" Info(DocIEN,"TRANS","IEN")=1234 "RTN","TMGTRNRP",349,0) ;" Info(DocIEN,"DATE SIGNED")=FMDate "RTN","TMGTRNRP",350,0) ;" Info(DocIEN,"AUTHOR","NAME")="Marcus M. Welby" "RTN","TMGTRNRP",351,0) ;" Info(DocIEN,"AUTHOR","INITS")="mmw" "RTN","TMGTRNRP",352,0) ;" Info(DocIEN,"AUTHOR","IEN")="1234 "RTN","TMGTRNRP",353,0) ;" Info(DocIEN,"PATIENT","NAME")="Doe,John G" "RTN","TMGTRNRP",354,0) ;" Info(DocIEN,"VISIT DATE")=FMDate "RTN","TMGTRNRP",355,0) ;" Info(DocIEN,"TRANS DATE")=FMDate "RTN","TMGTRNRP",356,0) ;"Result: 0 if failure, 1 if success "RTN","TMGTRNRP",357,0) "RTN","TMGTRNRP",358,0) new result set result=0 "RTN","TMGTRNRP",359,0) if $get(DocIEN)=0 goto GDIDone "RTN","TMGTRNRP",360,0) if $get(^TIU(8925,DocIEN,0))="" goto GDIDone "RTN","TMGTRNRP",361,0) "RTN","TMGTRNRP",362,0) new AuthIEN,initials,AuthName,PatIEN,TransIEN,TransInit "RTN","TMGTRNRP",363,0) "RTN","TMGTRNRP",364,0) set Info(DocIEN,"TRANS DATE")=$piece($get(^TIU(8925,DocIEN,12)),"^",1) "RTN","TMGTRNRP",365,0) set Info(DocIEN,"VISIT DATE")=$piece($get(^TIU(8925,DocIEN,0)),"^",7) "RTN","TMGTRNRP",366,0) set Info(DocIEN,"DATE SIGNED")=$piece($get(^TIU(8925,DocIEN,15)),"^",1) "RTN","TMGTRNRP",367,0) set AuthIEN=$piece($get(^TIU(8925,DocIEN,12)),"^",2) ;"field 1202 = Author "RTN","TMGTRNRP",368,0) if +AuthIEN'=0 do "RTN","TMGTRNRP",369,0) . set Info(DocIEN,"AUTHOR","INITS")=$piece($get(^VA(200,AuthIEN,0)),"^",2) ;"field .02 = initials "RTN","TMGTRNRP",370,0) . set Info(DocIEN,"AUTHOR","NAME")=$piece($get(^VA(200,AuthIEN,0)),"^",1) ;"field .01 = Name "RTN","TMGTRNRP",371,0) else do "RTN","TMGTRNRP",372,0) . set Info(DocIEN,"AUTHOR","INITS")="???" "RTN","TMGTRNRP",373,0) . set Info(DocIEN,"AUTHOR","NAME")="???" "RTN","TMGTRNRP",374,0) set PatIEN=$piece($get(^TIU(8925,DocIEN,0)),"^",2) ;"field .02 = patient IEN "RTN","TMGTRNRP",375,0) if +PatIEN'=0 do "RTN","TMGTRNRP",376,0) . set Info(DocIEN,"PATIENT","NAME")=$piece($get(^DPT(PatIEN,0)),"^",1) ;"field .01 is patient name "RTN","TMGTRNRP",377,0) else do "RTN","TMGTRNRP",378,0) . set Info(DocIEN,"PATIENT","NAME")="???" "RTN","TMGTRNRP",379,0) set TransIEN=$piece($get(^TIU(8925,DocIEN,13)),"^",2) ;"field 1302 = Entered by IEN "RTN","TMGTRNRP",380,0) if +TransIEN'=0 do "RTN","TMGTRNRP",381,0) . set Info(DocIEN,"TRANS","INITS")=$piece($get(^VA(200,TransIEN,0)),"^",2) ;" field .02 = initials "RTN","TMGTRNRP",382,0) . set Info(DocIEN,"TRANS","NAME")=$piece($get(^VA(200,TransIEN,0)),"^",1) ;"field .01 = Name "RTN","TMGTRNRP",383,0) else do "RTN","TMGTRNRP",384,0) . set Info(DocIEN,"TRANS","INITS")="???" "RTN","TMGTRNRP",385,0) . set Info(DocIEN,"TRANS","NAME")="???" "RTN","TMGTRNRP",386,0) "RTN","TMGTRNRP",387,0) "RTN","TMGTRNRP",388,0) set result=1 "RTN","TMGTRNRP",389,0) "RTN","TMGTRNRP",390,0) GDIDone "RTN","TMGTRNRP",391,0) quit result "RTN","TMGTRNRP",392,0) "RTN","TMGTRNRP",393,0) "RTN","TMGTRNRP",394,0) FindBatch(DocIEN) "RTN","TMGTRNRP",395,0) ;"Purpose: given a DocIEN, find the batch number it was printed in "RTN","TMGTRNRP",396,0) "RTN","TMGTRNRP",397,0) new result set result=0 "RTN","TMGTRNRP",398,0) new batch "RTN","TMGTRNRP",399,0) set batch=$order(^TMG("BATCH SIGNED DOCS","")) "RTN","TMGTRNRP",400,0) if batch'="" for do quit:(index="") "RTN","TMGTRNRP",401,0) . if $data(^TMG("BATCH SIGNED DOCS",batch,DocIEN))#10=1 do "RTN","TMGTRNRP",402,0) . . write "Printed in batch: ",batch,! "RTN","TMGTRNRP",403,0) . . set result=batch "RTN","TMGTRNRP",404,0) . set batch=$order(^TMG("BATCH SIGNED DOCS",batch)) "RTN","TMGTRNRP",405,0) "RTN","TMGTRNRP",406,0) quit result "RTN","TMGTRNRP",407,0) "RTN","TMGTRNRP",408,0) "RTN","TMGTRNRP",409,0) PRTEMPL ;"i.e. RE-PRINT TEMPLATE "RTN","TMGTRNRP",410,0) ;"Purpose: To ask for a SORT TEMPLATE that contains documents to reprint. "RTN","TMGTRNRP",411,0) "RTN","TMGTRNRP",412,0) write !,!,"This will allow printing of documents stored in a TEMPLATE.",! "RTN","TMGTRNRP",413,0) write "This TEMPLATE should have been already created by a Fileman SEARCH.",! "RTN","TMGTRNRP",414,0) "RTN","TMGTRNRP",415,0) new DIC,Y "RTN","TMGTRNRP",416,0) set DIC=.401 "RTN","TMGTRNRP",417,0) set DIC(0)="MAEQ" "RTN","TMGTRNRP",418,0) do ^DIC "RTN","TMGTRNRP",419,0) if +Y>0 do "RTN","TMGTRNRP",420,0) . new PrintArray "RTN","TMGTRNRP",421,0) . if $piece($get(^DIBT(+Y,0)),"^",4)'=8925 do quit "RTN","TMGTRNRP",422,0) . . write "That template is for another file. Sorry.",! "RTN","TMGTRNRP",423,0) . merge PrintArray=^DIBT(+Y,1) "RTN","TMGTRNRP",424,0) . if $data(PrintArray)=0 do quit "RTN","TMGTRNRP",425,0) . . write "That template doesn't contain any documents to print.",! "RTN","TMGTRNRP",426,0) . do PRINT^TMGTRAN1(.PrintArray) "RTN","TMGTRNRP",427,0) "RTN","TMGTRNRP",428,0) quit "RTN","TMGUPLD") 0^86^B4904 "RTN","TMGUPLD",1,0) TMGUPLD ;TMG/kst/CUSTOM VERSION OF TIUUPLD (PARTIAL) ;03/25/06 "RTN","TMGUPLD",2,0) ;;1.0;TMG-LIB;**1**;09/01/05 "RTN","TMGUPLD",3,0) "RTN","TMGUPLD",4,0) ;"CUSTOM VERSION OF TIUUPLD (PARTIAL) "RTN","TMGUPLD",5,0) ;"Kevin Toppenberg MD "RTN","TMGUPLD",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGUPLD",7,0) ;"9-1-2005 "RTN","TMGUPLD",8,0) "RTN","TMGUPLD",9,0) ;"======================================================================= "RTN","TMGUPLD",10,0) ;" API -- Public Functions. "RTN","TMGUPLD",11,0) ;"======================================================================= "RTN","TMGUPLD",12,0) ;"MAIN ;" upload a batch of *.vista files that contain transcribed notes "RTN","TMGUPLD",13,0) ;"LoadTIUBuf(DA,FPName,DestDir) ;"ask for filename, and load into a TIU buffer "RTN","TMGUPLD",14,0) ;"ERRORS ;"replacement function for DISPLAY^TIUEVNT "RTN","TMGUPLD",15,0) "RTN","TMGUPLD",16,0) ;"======================================================================= "RTN","TMGUPLD",17,0) ;"PRIVATE API FUNCTIONS "RTN","TMGUPLD",18,0) ;"======================================================================= "RTN","TMGUPLD",19,0) "RTN","TMGUPLD",20,0) "RTN","TMGUPLD",21,0) ;"======================================================================= "RTN","TMGUPLD",22,0) MAIN "RTN","TMGUPLD",23,0) ;"Purpose: To upload a batch of *.vista files that contain transcribed notes "RTN","TMGUPLD",24,0) ;"Input: None "RTN","TMGUPLD",25,0) ;"Results: None "RTN","TMGUPLD",26,0) "RTN","TMGUPLD",27,0) new EOM,TIUDA,TIUERR,TIUHDR,TIULN,TIUSRC,X "RTN","TMGUPLD",28,0) "RTN","TMGUPLD",29,0) if '$data(TIUPRM0)!'$data(TIUPRM1) do SETPARM^TIULE "RTN","TMGUPLD",30,0) set TIUSRC=$piece($get(TIUPRM0),U,9) "RTN","TMGUPLD",31,0) set EOM=$piece($get(TIUPRM0),U,11) "RTN","TMGUPLD",32,0) "RTN","TMGUPLD",33,0) if EOM']"",($piece(TIUPRM0,U,17)'="k") do quit "RTN","TMGUPLD",34,0) . write !,$C(7),$C(7),$C(7),"No End of Message Signal Defined - Contact IRM.",! "RTN","TMGUPLD",35,0) "RTN","TMGUPLD",36,0) set:TIUSRC']"" TIUSRC="R" "RTN","TMGUPLD",37,0) set TIUHDR=$piece(TIUPRM0,U,10) "RTN","TMGUPLD",38,0) if TIUHDR']"" do quit "RTN","TMGUPLD",39,0) . write $C(7),$C(7),$C(7),"No Record Header Signal Defined - Contact IRM.",! "RTN","TMGUPLD",40,0) "RTN","TMGUPLD",41,0) new done set done=1 "RTN","TMGUPLD",42,0) new FPName set FPName="" "RTN","TMGUPLD",43,0) new DoAll "RTN","TMGUPLD",44,0) new TMGMask,TMGFiles "RTN","TMGUPLD",45,0) new JustFile,JustPath "RTN","TMGUPLD",46,0) set JustFile="",JustPath="" "RTN","TMGUPLD",47,0) new NoDestDir set NoDestDir=" " "RTN","TMGUPLD",48,0) new DestDir set DestDir=NoDestDir "RTN","TMGUPLD",49,0) new SrcDir set SrcDir="" "RTN","TMGUPLD",50,0) new defPath set defPath="/var/local/OpenVistA_UserData/transcription" "RTN","TMGUPLD",51,0) new s "RTN","TMGUPLD",52,0) set s="Enter name of directory containing transcription"_$char(10)_$char(13) "RTN","TMGUPLD",53,0) set FPName=$$GetFName^TMGIOUTL(s,defPath,"","",.SrcDir,,"Enter Directory Name (? for Help): ") "RTN","TMGUPLD",54,0) "RTN","TMGUPLD",55,0) new mask set mask="*.vista" "RTN","TMGUPLD",56,0) new result "RTN","TMGUPLD",57,0) set TMGMask(mask)="" "RTN","TMGUPLD",58,0) set result=$$LIST^%ZISH(SrcDir,"TMGMask","TMGFiles") "RTN","TMGUPLD",59,0) new tempFName set tempFName=$order(TMGFiles("")) "RTN","TMGUPLD",60,0) if tempFName'="" for do quit:(tempFName="") "RTN","TMGUPLD",61,0) . if $$IsDir^TMGIOUTL(tempFName) kill TMGFiles(tempFName) "RTN","TMGUPLD",62,0) . set tempFName=$order(TMGFiles(tempFName)) "RTN","TMGUPLD",63,0) "RTN","TMGUPLD",64,0) set s="Enter DESTINATION directory to move file(s) into after upload."_$char(10)_$char(13) "RTN","TMGUPLD",65,0) new Discard "RTN","TMGUPLD",66,0) set Discard=$$GetFName^TMGIOUTL(s,defPath_"/uploaded","","",.DestDir,,"Enter Directory Name (? for Help): ") "RTN","TMGUPLD",67,0) write ! "RTN","TMGUPLD",68,0) if DestDir=JustPath set DestDir=NoDestDir "RTN","TMGUPLD",69,0) "RTN","TMGUPLD",70,0) set JustFile=$order(TMGFiles("")) ;"array holds only file names, not path "RTN","TMGUPLD",71,0) "RTN","TMGUPLD",72,0) ;"--------- loop here -------------- "RTN","TMGUPLD",73,0) for do quit:(JustFile="") "RTN","TMGUPLD",74,0) . set TIUDA=$$MAKEBUF^TIUUPLD "RTN","TMGUPLD",75,0) . if +TIUDA'>0 do quit "RTN","TMGUPLD",76,0) . . write $C(7),$C(7),$C(7),"Unable to create a Buffer File Record - Contact IRM.",! "RTN","TMGUPLD",77,0) . . set FPName="" "RTN","TMGUPLD",78,0) . ;" "RTN","TMGUPLD",79,0) . if TIUSRC="R" D REMOTE^TIUUPLD(TIUDA) "RTN","TMGUPLD",80,0) . set FPName=SrcDir_JustFile "RTN","TMGUPLD",81,0) . if TIUSRC="H" D LoadTIUBuf(TIUDA,.FPName,.DestDir) "RTN","TMGUPLD",82,0) . if +$get(TIUERR) do quit "RTN","TMGUPLD",83,0) . . write $C(7),$C(7),$C(7),!,"File Transfer Error: ",$get(TIUERR),!!,"Please re-transmit the file...",! "RTN","TMGUPLD",84,0) . . set FPName="" "RTN","TMGUPLD",85,0) . ;" "RTN","TMGUPLD",86,0) . ;" Set $ZB to MAIN+14^TIUUPLD:2 "RTN","TMGUPLD",87,0) . if +$order(^TIU(8925.2,TIUDA,"TEXT",0))>0,'+$get(TIUERR) do "RTN","TMGUPLD",88,0) . . do FILE^TIUUPLD(TIUDA) "RTN","TMGUPLD",89,0) . ;" "RTN","TMGUPLD",90,0) . if +$order(^TIU(8925.2,TIUDA,"TEXT",0))'>0!+$get(TIUERR) do "RTN","TMGUPLD",91,0) . . do BUFPURGE^TIUPUTC(TIUDA) "RTN","TMGUPLD",92,0) . ;" "RTN","TMGUPLD",93,0) . write !! "RTN","TMGUPLD",94,0) . if '($get(DestDir)="")&'(DestDir=" ") do "RTN","TMGUPLD",95,0) . . new Dest set Dest=DestDir_JustFile "RTN","TMGUPLD",96,0) . . if $$Move^TMGIOUTL(FPName,Dest)=0 do "RTN","TMGUPLD",97,0) . . . write "Moved ",JustFile,!," to: ",Dest,! "RTN","TMGUPLD",98,0) . . else do "RTN","TMGUPLD",99,0) . . . write "Unable to Move ",JustFile,!," to: ",Dest,! "RTN","TMGUPLD",100,0) . ;" "RTN","TMGUPLD",101,0) . write "Done processing: ",JustFile,! "RTN","TMGUPLD",102,0) . new KeyCont read "Press Any Key to Continue (^ to Abort)",KeyCont:$get(DTIME,3600),! "RTN","TMGUPLD",103,0) . set JustFile=$order(TMGFiles(JustFile)) "RTN","TMGUPLD",104,0) . if KeyCont="^" set JustFile="" "RTN","TMGUPLD",105,0) "RTN","TMGUPLD",106,0) quit "RTN","TMGUPLD",107,0) "RTN","TMGUPLD",108,0) "RTN","TMGUPLD",109,0) "RTN","TMGUPLD",110,0) LoadTIUBuf(DA,FPName,DestDir) "RTN","TMGUPLD",111,0) ;"Purpose: to ask user for filename, and then load this into a "RTN","TMGUPLD",112,0) ;" TIU buffer (that already has been created) "RTN","TMGUPLD",113,0) ;"Input: DA : the IEN (record number) in file ^TIU(8925.2), i.e. "RTN","TMGUPLD",114,0) ;" in file TIU UPLOAD BUFFER, that the file is "RTN","TMGUPLD",115,0) ;" to be loaded into. "RTN","TMGUPLD",116,0) ;" FPName: OPTIONAL -- a FilePathName. If supplied then user will not be "RTN","TMGUPLD",117,0) ;" prompted to chose a file name to load "RTN","TMGUPLD",118,0) ;" If passed by reference, then chosen file "RTN","TMGUPLD",119,0) ;" will be passed back out. "RTN","TMGUPLD",120,0) ;" DestDir: OPTIONAL -- a directory to move file into after upload "RTN","TMGUPLD",121,0) ;" if not provided, or if value=" ", then don't move file "RTN","TMGUPLD",122,0) ;" Will not move file if upload was unsucessful "RTN","TMGUPLD",123,0) ;"Results: none "RTN","TMGUPLD",124,0) "RTN","TMGUPLD",125,0) ;"***NOTICE !!!!!!! "RTN","TMGUPLD",126,0) ;" This file is called from TIUUPLD. If this function is broken, then "RTN","TMGUPLD",127,0) ;" the upload process will be broken. So, caution! "RTN","TMGUPLD",128,0) "RTN","TMGUPLD",129,0) if '$data(TIUPRM0)!'$data(TIUPRM1) do SETPARM^TIULE "RTN","TMGUPLD",130,0) write @IOF,! "RTN","TMGUPLD",131,0) do JUSTIFY^TIUU($$TITLE^TIUU("ASCII UPLOAD"),"C") "RTN","TMGUPLD",132,0) write ! "RTN","TMGUPLD",133,0) "RTN","TMGUPLD",134,0) new defPath "RTN","TMGUPLD",135,0) new result set result=0 "RTN","TMGUPLD",136,0) "RTN","TMGUPLD",137,0) if $get(FPName)="" do "RTN","TMGUPLD",138,0) . set defPath="/var/local/OpenVistA_UserData/transcription" "RTN","TMGUPLD",139,0) . set FPName=$$GetFName^TMGIOUTL("Enter name of file containing transcription",defPath) "RTN","TMGUPLD",140,0) "RTN","TMGUPLD",141,0) if FPName'="" do "RTN","TMGUPLD",142,0) . if $$Dos2Unix^TMGIOUTL(FPName)>0 quit ;"error on conversion prob means file doesn't exist. "RTN","TMGUPLD",143,0) . new name,path,BuffP "RTN","TMGUPLD",144,0) . do SplitFNamePath^TMGIOUTL(FPName,.path,.name) "RTN","TMGUPLD",145,0) . if ($get(path)="")!($get(name)="") quit "RTN","TMGUPLD",146,0) . set BuffP="^TIU(8925.2,"_DA_",""TEXT"",1,0)" "RTN","TMGUPLD",147,0) . if $$FTG^%ZISH(path,name,BuffP,4) do "RTN","TMGUPLD",148,0) . . set result=1 "RTN","TMGUPLD",149,0) . . new MaxLine set MaxLine=$order(^TIU(8925.2,DA,"TEXT",""),-1) "RTN","TMGUPLD",150,0) . . set ^TIU(8925.2,DA,"TEXT",0)="^^"_+MaxLine_"^"_+MaxLine_"^"_DT_"^^^^" "RTN","TMGUPLD",151,0) . . new index set index=$order(^TIU(8925.2,DA,"TEXT",0)) "RTN","TMGUPLD",152,0) . . for do quit:index="" "RTN","TMGUPLD",153,0) . . . if index="" quit "RTN","TMGUPLD",154,0) . . . new s set s=$$STRIP^TIUUPLD(^TIU(8925.2,DA,"TEXT",index,0)) "RTN","TMGUPLD",155,0) . . . set ^TIU(8925.2,DA,"TEXT",index,0)=s "RTN","TMGUPLD",156,0) . . . set index=$order(^TIU(8925.2,DA,"TEXT",index)) "RTN","TMGUPLD",157,0) "RTN","TMGUPLD",158,0) if result=0 do "RTN","TMGUPLD",159,0) . write "Unsuccessful upload.",! "RTN","TMGUPLD",160,0) "RTN","TMGUPLD",161,0) quit "RTN","TMGUPLD",162,0) "RTN","TMGUPLD",163,0) "RTN","TMGUPLD",164,0) "RTN","TMGUPLD",165,0) ERRORS "RTN","TMGUPLD",166,0) ;"Purpose: This is replacement function of for DISPLAY^TIUEVNT "RTN","TMGUPLD",167,0) ;" This function is used in processing Alerts created from failed document "RTN","TMGUPLD",168,0) ;" uploads. This function is wedged into DISPLAY^TIUEVNT to allow "RTN","TMGUPLD",169,0) ;" customization. "RTN","TMGUPLD",170,0) ;"Input: none. "RTN","TMGUPLD",171,0) ;" global scope variables are used: "RTN","TMGUPLD",172,0) ;" XQX1 "RTN","TMGUPLD",173,0) ;" TIUPRM0,TIUPRM1 "RTN","TMGUPLD",174,0) ;" DIRUT "RTN","TMGUPLD",175,0) ;" XQADATA , e.g.: 349;FILING ERROR: NOTE Record could not be found or created.;30853;1302 "RTN","TMGUPLD",176,0) ;" 349 --> TIUBUF "RTN","TMGUPLD",177,0) ;" 30853 --> TIUEVNT and EVNTDA "RTN","TMGUPLD",178,0) ;" 1302 --> TIUTYPE "RTN","TMGUPLD",179,0) "RTN","TMGUPLD",180,0) new DIC,INQUIRE,RETRY,DWPK,EVNTDA,TIU K XQAKILL,RESCODE,TIUTYPE "RTN","TMGUPLD",181,0) new TIUDONE ;"<-- this is changed elsewhere... where? "RTN","TMGUPLD",182,0) new TIUEVNT,TIUSKIP,TIUBUF "RTN","TMGUPLD",183,0) "RTN","TMGUPLD",184,0) write !,"TMG Custom Upload Error Handler.",! "RTN","TMGUPLD",185,0) write "---------------------------------------",!! "RTN","TMGUPLD",186,0) "RTN","TMGUPLD",187,0) if '$data(TIUPRM0)!'$data(TIUPRM1) do SETPARM^TIULE "RTN","TMGUPLD",188,0) "RTN","TMGUPLD",189,0) ;" Set EVNTDA for backward compatibility, TIUEVNT for PN resolve code "RTN","TMGUPLD",190,0) set (EVNTDA,TIUEVNT)=+$piece(XQADATA,";",3) "RTN","TMGUPLD",191,0) "RTN","TMGUPLD",192,0) ;" Set TIUBUF for similarity w TIURE. DON'T set BUFDA since "RTN","TMGUPLD",193,0) ;" old code interprets that as set by TIURE only: "RTN","TMGUPLD",194,0) set TIUBUF=+XQADATA "RTN","TMGUPLD",195,0) set TIUTYPE=+$piece(XQADATA,";",4) "RTN","TMGUPLD",196,0) set TIUSKIP=($data(DIRUT)>0) "RTN","TMGUPLD",197,0) "RTN","TMGUPLD",198,0) if TIUTYPE>0 set RESCODE=$$FIXCODE^TIULC1(TIUTYPE) "RTN","TMGUPLD",199,0) "RTN","TMGUPLD",200,0) new defInput set defInput="1" "RTN","TMGUPLD",201,0) new input "RTN","TMGUPLD",202,0) for do quit:(+input<1)!(+input>5) "RTN","TMGUPLD",203,0) . do WRITEHDR^TIUPEVNT(TIUEVNT) "RTN","TMGUPLD",204,0) . write !,$piece(XQADATA,";",2),! "RTN","TMGUPLD",205,0) . write "OPTIONS:",! "RTN","TMGUPLD",206,0) . write "1. Inquire to patient record.",! "RTN","TMGUPLD",207,0) . write "2. Create/edit patient record.",! "RTN","TMGUPLD",208,0) . write "3. Mark note for automatic patient registration.",! "RTN","TMGUPLD",209,0) . ;"write "4. Show note header again.",! "RTN","TMGUPLD",210,0) . write "5. Edit erroneous note.",! "RTN","TMGUPLD",211,0) . write "6. Retry filing buffer (and quit)",! "RTN","TMGUPLD",212,0) . write "7. Abort",! "RTN","TMGUPLD",213,0) . write ! "RTN","TMGUPLD",214,0) . write "Select option (1-7,?,^): ",defInput,"// " "RTN","TMGUPLD",215,0) . read input:$get(DTIME,3600),! "RTN","TMGUPLD",216,0) . if input="" set input=defInput "RTN","TMGUPLD",217,0) . if input["?" do quit "RTN","TMGUPLD",218,0) . . write "--Regarding option 1:" "RTN","TMGUPLD",219,0) . . do INQRHELP^TIUPEVNT write !! "RTN","TMGUPLD",220,0) . . write "--Regarding option 2:",! "RTN","TMGUPLD",221,0) . . write "To directly edit the patient name, DOB etc, select this.",! "RTN","TMGUPLD",222,0) . . write "(Caution: only change patient entry if you are SURE information is incorrect.)",!! "RTN","TMGUPLD",223,0) . . write "--Regarding option 3",! "RTN","TMGUPLD",224,0) . . write "This will cause the the information in the note to be used to automatically",! "RTN","TMGUPLD",225,0) . . write "register the patient. Caution! Be careful to not cause a duplicate entry",! "RTN","TMGUPLD",226,0) . . write "in the database. Only use this option if you are SURE the patient is NOT",! "RTN","TMGUPLD",227,0) . . write "already registered. Don't use if patient is in database, but with incorrect",! "RTN","TMGUPLD",228,0) . . write "information.",!! "RTN","TMGUPLD",229,0) . . ;"write "--Regarding option 4:",! "RTN","TMGUPLD",230,0) . . ;"write "This will display the header the filer found initially.",!! "RTN","TMGUPLD",231,0) . . write "--Regarding option 5:",! "RTN","TMGUPLD",232,0) . . write "Select this option to launch a text editor to correct note",!! "RTN","TMGUPLD",233,0) . . write "--Regarding option 6:" "RTN","TMGUPLD",234,0) . . write "--Regarding option 7:",! "RTN","TMGUPLD",235,0) . . write "This will abort process. Error and Alert will remain unchanged.",!! "RTN","TMGUPLD",236,0) . . write ! "RTN","TMGUPLD",237,0) . . set input=1 ;"just to allow loop to continue "RTN","TMGUPLD",238,0) . . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),! "RTN","TMGUPLD",239,0) . if +input=1 do quit ;"1. Inquire to patient record." "RTN","TMGUPLD",240,0) . . if $get(RESCODE)="" do quit "RTN","TMGUPLD",241,0) . . . write !!,"Filing error resolution code could not be found for this document type.",! "RTN","TMGUPLD",242,0) . . . write "Please edit the buffered data directly and refile.",! "RTN","TMGUPLD",243,0) . . . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),! "RTN","TMGUPLD",244,0) . . . set defInput=5 "RTN","TMGUPLD",245,0) . . do WRITEHDR^TIUPEVNT(TIUEVNT) "RTN","TMGUPLD",246,0) . . xecute RESCODE "RTN","TMGUPLD",247,0) . else if +input=2 do quit ;"2. Create/edit patient record." "RTN","TMGUPLD",248,0) . . do WRITEHDR^TIUPEVNT(TIUEVNT) "RTN","TMGUPLD",249,0) . . write "Hint: if entering a patient's name brings up the wrong patient, then",! "RTN","TMGUPLD",250,0) . . write " enter name in quotes (e.g. ""DOE,JOHN"") to force addition of a new",! "RTN","TMGUPLD",251,0) . . write " patient with a same name as one alread registered." "RTN","TMGUPLD",252,0) . . do EDITPT^TMGMISC(1) "RTN","TMGUPLD",253,0) . . set defInput=6 "RTN","TMGUPLD",254,0) . else if +input=3 do quit ;"3. Mark note for automatic patient registration." "RTN","TMGUPLD",255,0) . . ;"TMGSEX is a variable with global scope used by filer. "RTN","TMGUPLD",256,0) . . for do quit:(TMGSEX'="") "RTN","TMGUPLD",257,0) . . . read "Is patient MALE or FEMALE? (M/F) // ",TMGSEX:$get(DTIME,3600),! "RTN","TMGUPLD",258,0) . . . set TMGSEX=$$UP^XLFSTR(TMGSEX) "RTN","TMGUPLD",259,0) . . . if (TMGSEX="MALE")!(TMGSEX="M") set TMGSEX="MALE" "RTN","TMGUPLD",260,0) . . . else if (TMGSEX="FEMALE")!(TMGSEX="F") set TMGSEX="FEMALE" "RTN","TMGUPLD",261,0) . . . else if TMGSEX="^" quit "RTN","TMGUPLD",262,0) . . . else set TMGSEX="" write "?? Please enter MALE or FEMALE (or ^ to abort)",! "RTN","TMGUPLD",263,0) . . if TMGSEX="^" set TMGSEX="" quit "RTN","TMGUPLD",264,0) . . set TMGFREG=1 ;"this is a signal for TMGGDFN to register patient if not otherwise found. "RTN","TMGUPLD",265,0) . . write "Patient is marked for AUTOMATIC REGISTRATION.",! "RTN","TMGUPLD",266,0) . . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),! "RTN","TMGUPLD",267,0) . . set defInput=6 "RTN","TMGUPLD",268,0) . ;"else if +input=4 do quit ;"4. Show note header again." "RTN","TMGUPLD",269,0) . ;". do WRITEHDR^TIUPEVNT(TIUEVNT) "RTN","TMGUPLD",270,0) . else if +input=5 do quit ;"5. Edit buffer." "RTN","TMGUPLD",271,0) . . set DIC="^TIU(8925.2,"_TIUBUF_",""TEXT""," "RTN","TMGUPLD",272,0) . . set DWPK=1 "RTN","TMGUPLD",273,0) . . do EN^DIWE "RTN","TMGUPLD",274,0) . . set defInput=6 "RTN","TMGUPLD",275,0) . else if +input=6 do quit ;"6. Retry filing buffer (and quit)" "RTN","TMGUPLD",276,0) . . do ALERTDEL^TIUPEVNT(TIUBUF) "RTN","TMGUPLD",277,0) . . do RESOLVE^TIUPEVNT(TIUEVNT,1) "RTN","TMGUPLD",278,0) . . do FILE^TIUUPLD(TIUBUF) "RTN","TMGUPLD",279,0) . else do quit "RTN","TMGUPLD",280,0) "RTN","TMGUPLD",281,0) ;" Redundant if all RESCODEs do RESOLVE: "RTN","TMGUPLD",282,0) if +$get(TIUDONE),+$get(TIUEVNT) do RESOLVE^TIUPEVNT(+$get(TIUEVNT)) "RTN","TMGUPLD",283,0) "RTN","TMGUPLD",284,0) kill TMGFREG "RTN","TMGUPLD",285,0) "RTN","TMGUPLD",286,0) DISPX "RTN","TMGUPLD",287,0) kill XQX1 "RTN","TMGUPLD",288,0) quit "RTN","TMGUPLD",289,0) "RTN","TMGUSRIF") 0^87^B7202 "RTN","TMGUSRIF",1,0) TMGUSRIF ;TMG/kst/USER INTERFACE API FUNCTIONS ;03/25/06 "RTN","TMGUSRIF",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGUSRIF",3,0) "RTN","TMGUSRIF",4,0) ;"TMG USER INTERFACE API FUNCTIONS "RTN","TMGUSRIF",5,0) ;"Kevin Toppenberg MD "RTN","TMGUSRIF",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGUSRIF",7,0) ;"7-12-2005 "RTN","TMGUSRIF",8,0) "RTN","TMGUSRIF",9,0) ;"======================================================================= "RTN","TMGUSRIF",10,0) ;" API -- Public Functions. "RTN","TMGUSRIF",11,0) ;"======================================================================= "RTN","TMGUSRIF",12,0) "RTN","TMGUSRIF",13,0) ;"PopupArray^TMGUSRIF(IndentW,Width,Array,Modal) "RTN","TMGUSRIF",14,0) ;"PopupBox^TMGUSRIF(Header,Text,[Width]) "RTN","TMGUSRIF",15,0) ;"ProgressBar^TMGUSRIF(value,label,min,max,width,startTime) "RTN","TMGUSRIF",16,0) ;"PressToCont^TMGUSRIF "RTN","TMGUSRIF",17,0) ;"$$KeyPressed^TMGUSRIF(wantChar,waitTime) "RTN","TMGUSRIF",18,0) ;"$$Read^TMGUSRIF(Terminators,timeOut,Num,initialVal) -- custom read function with custom terminators "RTN","TMGUSRIF",19,0) ;"$$UserAborted^TMGUSRIF() "RTN","TMGUSRIF",20,0) ;"Selector(pArray,pResults,Header) -- select from an array "RTN","TMGUSRIF",21,0) ;"Slctor2(pArray,pResults,Header) -- select from an array (different input) "RTN","TMGUSRIF",22,0) ;"IENSelector(pIENArray,pResults,File,Field,Header,Sort) "RTN","TMGUSRIF",23,0) ;"Menu(Options,defChoice,.UserRaw) "RTN","TMGUSRIF",24,0) "RTN","TMGUSRIF",25,0) ;"======================================================================= "RTN","TMGUSRIF",26,0) ;"Private Functions "RTN","TMGUSRIF",27,0) ;"======================================================================= "RTN","TMGUSRIF",28,0) ;"XPopupArray(Array,Modal) "RTN","TMGUSRIF",29,0) ;"ProgTest "RTN","TMGUSRIF",30,0) "RTN","TMGUSRIF",31,0) ;"======================================================================= "RTN","TMGUSRIF",32,0) ;"======================================================================= "RTN","TMGUSRIF",33,0) ;"DEPENDENCIES "RTN","TMGUSRIF",34,0) ;"TMGDEBUG,TMGSTUTL,TMGXDLG "RTN","TMGUSRIF",35,0) ;"======================================================================= "RTN","TMGUSRIF",36,0) "RTN","TMGUSRIF",37,0) PopupArray(IndentW,Width,Array,Modal) "RTN","TMGUSRIF",38,0) ;"PUBLIC FUNCTION "RTN","TMGUSRIF",39,0) ;"Purpose: To draw a box, of specified Width, and display text "RTN","TMGUSRIF",40,0) ;"Input: IndentW = width of indent amount (how far from left margin) "RTN","TMGUSRIF",41,0) ;" Width = desired width of box. "RTN","TMGUSRIF",42,0) ;" Header = one line of text to put in header of popup box "RTN","TMGUSRIF",43,0) ;" Array: an array in following format: "RTN","TMGUSRIF",44,0) ;" Array(0)=Header "RTN","TMGUSRIF",45,0) ;" Array(1)=Text line 1 "RTN","TMGUSRIF",46,0) ;" Array(2)=Text line 2 "RTN","TMGUSRIF",47,0) ;" ... "RTN","TMGUSRIF",48,0) ;" Array(n)=Text line n "RTN","TMGUSRIF",49,0) ;" Modal - really only has meaning for those time when "RTN","TMGUSRIF",50,0) ;" box will be passed to GUI X dialog box. "RTN","TMGUSRIF",51,0) ;" Modal=1 means stays in foreground, "RTN","TMGUSRIF",52,0) ;" 0 means leave box up, continue script execution. "RTN","TMGUSRIF",53,0) ;"Note: Text will be clipped to fit in box. "RTN","TMGUSRIF",54,0) "RTN","TMGUSRIF",55,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupArray") "RTN","TMGUSRIF",56,0) "RTN","TMGUSRIF",57,0) set cModal=$get(cModal,"MODAL") "RTN","TMGUSRIF",58,0) set cDialog=$get(cModal,"UseDialog") "RTN","TMGUSRIF",59,0) "RTN","TMGUSRIF",60,0) set Modal=$get(Modal,cModal) "RTN","TMGUSRIF",61,0) "RTN","TMGUSRIF",62,0) new Header "RTN","TMGUSRIF",63,0) new Text set Text="" "RTN","TMGUSRIF",64,0) new index "RTN","TMGUSRIF",65,0) new i "RTN","TMGUSRIF",66,0) new S "RTN","TMGUSRIF",67,0) "RTN","TMGUSRIF",68,0) ;"Scan array for any needed data substitution i.e. {{...}} "RTN","TMGUSRIF",69,0) new tempresult "RTN","TMGUSRIF",70,0) set index=$order(Array("")) "RTN","TMGUSRIF",71,0) for do quit:index="" "RTN","TMGUSRIF",72,0) . set S=Array(index) "RTN","TMGUSRIF",73,0) . ;"set tempresult=$$CheckSubstituteData(.S) ;"Do any data lookup needed "RTN","TMGUSRIF",74,0) . set Array(index)=S "RTN","TMGUSRIF",75,0) . set index=$order(Array(index)) "RTN","TMGUSRIF",76,0) "RTN","TMGUSRIF",77,0) if $get(DispMode(cDialog)) do goto PUADone "RTN","TMGUSRIF",78,0) . do XPopupArray(.Array,Modal) "RTN","TMGUSRIF",79,0) "RTN","TMGUSRIF",80,0) set IndentW=$get(IndentW,1) ;"default indent=1 "RTN","TMGUSRIF",81,0) set Header=$get(Array(0)," ") "RTN","TMGUSRIF",82,0) set Width=$get(Width,40) ;"default=40 "RTN","TMGUSRIF",83,0) "RTN","TMGUSRIF",84,0) write ! "RTN","TMGUSRIF",85,0) ;"Draw top line "RTN","TMGUSRIF",86,0) for i=1:1:IndentW write " " "RTN","TMGUSRIF",87,0) write "+" "RTN","TMGUSRIF",88,0) for i=1:1:(Width-2) write "=" "RTN","TMGUSRIF",89,0) write "+",! "RTN","TMGUSRIF",90,0) "RTN","TMGUSRIF",91,0) ;"Draw Header line "RTN","TMGUSRIF",92,0) do SetStrLen^TMGSTUTL(.Header,Width-4) "RTN","TMGUSRIF",93,0) for i=1:1:IndentW write " " "RTN","TMGUSRIF",94,0) write "| ",Header," |..",! "RTN","TMGUSRIF",95,0) "RTN","TMGUSRIF",96,0) ;"Draw divider line "RTN","TMGUSRIF",97,0) for i=1:1:IndentW write " " "RTN","TMGUSRIF",98,0) write "+" "RTN","TMGUSRIF",99,0) for i=1:1:(Width-2) write "-" "RTN","TMGUSRIF",100,0) write "+ :",! "RTN","TMGUSRIF",101,0) "RTN","TMGUSRIF",102,0) ;"Put out message "RTN","TMGUSRIF",103,0) set index=$order(Array(0)) "RTN","TMGUSRIF",104,0) PUBLoop "RTN","TMGUSRIF",105,0) if index="" goto BtmLine "RTN","TMGUSRIF",106,0) set S=$get(Array(index)," ") "RTN","TMGUSRIF",107,0) do SetStrLen^TMGSTUTL(.S,Width-4) "RTN","TMGUSRIF",108,0) for i=1:1:IndentW write " " "RTN","TMGUSRIF",109,0) write "| ",S," | :",! "RTN","TMGUSRIF",110,0) set index=$order(Array(index)) "RTN","TMGUSRIF",111,0) goto PUBLoop "RTN","TMGUSRIF",112,0) "RTN","TMGUSRIF",113,0) BtmLine "RTN","TMGUSRIF",114,0) ;"Draw Bottom line "RTN","TMGUSRIF",115,0) for i=1:1:IndentW write " " "RTN","TMGUSRIF",116,0) write "+" "RTN","TMGUSRIF",117,0) for i=1:1:(Width-2) write "=" "RTN","TMGUSRIF",118,0) write "+ :",! "RTN","TMGUSRIF",119,0) "RTN","TMGUSRIF",120,0) ;"Draw bottom shaddow "RTN","TMGUSRIF",121,0) for i=1:1:IndentW write " " "RTN","TMGUSRIF",122,0) write " " "RTN","TMGUSRIF",123,0) write ":" "RTN","TMGUSRIF",124,0) for i=1:1:(Width-2) write "." "RTN","TMGUSRIF",125,0) write ".",! "RTN","TMGUSRIF",126,0) "RTN","TMGUSRIF",127,0) write ! "RTN","TMGUSRIF",128,0) "RTN","TMGUSRIF",129,0) PUADone "RTN","TMGUSRIF",130,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupArray") "RTN","TMGUSRIF",131,0) quit "RTN","TMGUSRIF",132,0) "RTN","TMGUSRIF",133,0) "RTN","TMGUSRIF",134,0) "RTN","TMGUSRIF",135,0) XPopupArray(Array,Modal) "RTN","TMGUSRIF",136,0) ;"Purpose -- to pass the older text popup box onto a X GUI box "RTN","TMGUSRIF",137,0) "RTN","TMGUSRIF",138,0) new Title "RTN","TMGUSRIF",139,0) new Text "RTN","TMGUSRIF",140,0) new index "RTN","TMGUSRIF",141,0) new S set S="" "RTN","TMGUSRIF",142,0) new OneLine "RTN","TMGUSRIF",143,0) new result "RTN","TMGUSRIF",144,0) "RTN","TMGUSRIF",145,0) set cOKToCont=$get(cOKToCont,1) "RTN","TMGUSRIF",146,0) set cAbort=$get(cAbort,0) "RTN","TMGUSRIF",147,0) set cModal=$get(cModal,"MODAL") "RTN","TMGUSRIF",148,0) "RTN","TMGUSRIF",149,0) "RTN","TMGUSRIF",150,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"XPopupArray") "RTN","TMGUSRIF",151,0) "RTN","TMGUSRIF",152,0) set Title=$get(Array(0)) "RTN","TMGUSRIF",153,0) set index=$order(Array(0)) "RTN","TMGUSRIF",154,0) set Modal=$get(Modal,cModalMode) "RTN","TMGUSRIF",155,0) XPL1 "RTN","TMGUSRIF",156,0) if index="" goto XPL2 "RTN","TMGUSRIF",157,0) set OneLine=$get(Array(index)," ") "RTN","TMGUSRIF",158,0) set OneLine=$translate(OneLine,"""","'") "RTN","TMGUSRIF",159,0) set S=S_OneLine_"\n" "RTN","TMGUSRIF",160,0) set index=$order(Array(index)) "RTN","TMGUSRIF",161,0) goto XPL1 "RTN","TMGUSRIF",162,0) XPL2 "RTN","TMGUSRIF",163,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Title=",Title) "RTN","TMGUSRIF",164,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Text=",S) "RTN","TMGUSRIF",165,0) set result=$$Msg^TMGXDLG(Title,S,0,0,Modal) "RTN","TMGUSRIF",166,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"XPopupArray") "RTN","TMGUSRIF",167,0) quit "RTN","TMGUSRIF",168,0) "RTN","TMGUSRIF",169,0) "RTN","TMGUSRIF",170,0) "RTN","TMGUSRIF",171,0) "RTN","TMGUSRIF",172,0) PopupBox(Header,Text,Width) "RTN","TMGUSRIF",173,0) ;"PUBLIC FUNCTION "RTN","TMGUSRIF",174,0) ;"Purpose: To provide easy text output box "RTN","TMGUSRIF",175,0) ;"Input: Header -- a short string for header "RTN","TMGUSRIF",176,0) ;" Text - the text to display "RTN","TMGUSRIF",177,0) ;" [Width] -- optional width specifier. Value=0 same as not specified "RTN","TMGUSRIF",178,0) ;" (DBIndent) -- uses a var with global scope (if defined) for indent amount "RTN","TMGUSRIF",179,0) ;"Note: If text width not specified, and Text is <= 60, "RTN","TMGUSRIF",180,0) ;" then all will be put on one line. "RTN","TMGUSRIF",181,0) ;" Otherwise, width is set to 60, and text is wrapped. "RTN","TMGUSRIF",182,0) ;" Also, text of the message can contain "\n", which will be interpreted "RTN","TMGUSRIF",183,0) ;" as a new-line character. "RTN","TMGUSRIF",184,0) ;"Result: none "RTN","TMGUSRIF",185,0) "RTN","TMGUSRIF",186,0) "RTN","TMGUSRIF",187,0) ;"Note: This function can't be exported to a separate package because of dependancies "RTN","TMGUSRIF",188,0) "RTN","TMGUSRIF",189,0) "RTN","TMGUSRIF",190,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupBox") "RTN","TMGUSRIF",191,0) "RTN","TMGUSRIF",192,0) set cNewLn=$get(cNewLn,"\n") "RTN","TMGUSRIF",193,0) new TextOut "RTN","TMGUSRIF",194,0) new TextI set TextI=0 "RTN","TMGUSRIF",195,0) new PartB set PartB="" "RTN","TMGUSRIF",196,0) new PartB1 set PartB1="" "RTN","TMGUSRIF",197,0) set Width=+$get(Width,0) "RTN","TMGUSRIF",198,0) "RTN","TMGUSRIF",199,0) set TextOut(TextI)=Header "RTN","TMGUSRIF",200,0) set TextI=TextI+1 "RTN","TMGUSRIF",201,0) "RTN","TMGUSRIF",202,0) if Width=0 do "RTN","TMGUSRIF",203,0) . new HeaderBased "RTN","TMGUSRIF",204,0) . new NumLines "RTN","TMGUSRIF",205,0) . new HLen set HLen=$length(Header)+4 "RTN","TMGUSRIF",206,0) . new TLen set TLen=$length(Text)+4 "RTN","TMGUSRIF",207,0) . if TLen>HLen do "RTN","TMGUSRIF",208,0) . . set Width=TLen "RTN","TMGUSRIF",209,0) . . set HeaderBased=0 "RTN","TMGUSRIF",210,0) . else do "RTN","TMGUSRIF",211,0) . . set Width=HLen "RTN","TMGUSRIF",212,0) . . set HeaderBased=1 "RTN","TMGUSRIF",213,0) . if Width>75 set Width=75 "RTN","TMGUSRIF",214,0) . set NumLines=TLen/Width "RTN","TMGUSRIF",215,0) . if TLen#Width>0 set NumLines=NumLines+1 "RTN","TMGUSRIF",216,0) . if (NumLines>1)&(HeaderBased=0) do "RTN","TMGUSRIF",217,0) . . set Width=(TLen\NumLines)+4 "RTN","TMGUSRIF",218,0) . . if Width75 set Width=75 "RTN","TMGUSRIF",220,0) "RTN","TMGUSRIF",221,0) PUWBLoop ;"Load string up into Text array, to pass to PopupArray "RTN","TMGUSRIF",222,0) if Text[cNewLn do "RTN","TMGUSRIF",223,0) . do CleaveStr^TMGSTUTL(.Text,cNewLn,.PartB1) "RTN","TMGUSRIF",224,0) do SplitStr^TMGSTUTL(.Text,(Width-4),.PartB) "RTN","TMGUSRIF",225,0) set PartB=PartB_PartB1 set PartB1="" "RTN","TMGUSRIF",226,0) set TextOut(TextI)=Text "RTN","TMGUSRIF",227,0) set TextI=TextI+1 "RTN","TMGUSRIF",228,0) if $length(PartB)>0 do goto PUWBLoop "RTN","TMGUSRIF",229,0) . set Text=PartB "RTN","TMGUSRIF",230,0) . set PartB="" "RTN","TMGUSRIF",231,0) "RTN","TMGUSRIF",232,0) do PopupArray(.DBIndent,Width,.TextOut) "RTN","TMGUSRIF",233,0) "RTN","TMGUSRIF",234,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupBox") "RTN","TMGUSRIF",235,0) quit "RTN","TMGUSRIF",236,0) "RTN","TMGUSRIF",237,0) "RTN","TMGUSRIF",238,0) ProgressBar(value,label,min,max,width,startTime) "RTN","TMGUSRIF",239,0) ;"Purpose: to draw a progress bar on a line of the screen "RTN","TMGUSRIF",240,0) ;"Input: "RTN","TMGUSRIF",241,0) ;" value -- the current value to graph out "RTN","TMGUSRIF",242,0) ;" label -- OPTIONAL -- a label to describe progres. Default="Progress" "RTN","TMGUSRIF",243,0) ;" max -- OPTIONAL -- the max number that value will be. Default is 100 "RTN","TMGUSRIF",244,0) ;" min -- OPTIONAL -- the minimal number that value will be. Default is 0 "RTN","TMGUSRIF",245,0) ;" width -- OPTIONAL -- the number of characters that the progress bar "RTN","TMGUSRIF",246,0) ;" will be in width. Default is 70 "RTN","TMGUSRIF",247,0) ;" startTime -- OPTIONAL -- start time of process. If provided, it will "RTN","TMGUSRIF",248,0) ;" be used to determine remaining time. Format should be same as $H "RTN","TMGUSRIF",249,0) ;"Note: will use global ^TMP("TMG","PROGRESS-BAR",$J) "RTN","TMGUSRIF",250,0) ;"Note: bar will look like this: "RTN","TMGUSRIF",251,0) ;" Progress: 27%-------->|-----------------------------------| "RTN","TMGUSRIF",252,0) ;" "RTN","TMGUSRIF",253,0) "RTN","TMGUSRIF",254,0) ;"FYI -- The preexisting way to do this, from Dave Whitten "RTN","TMGUSRIF",255,0) ;" "RTN","TMGUSRIF",256,0) ;"Did you try using the already existing function to do this? "RTN","TMGUSRIF",257,0) ;"ie: try out this 'mini program' "RTN","TMGUSRIF",258,0) ;">; need to set up vars like DUZ,DTIME, IO, IO(0), etc. "RTN","TMGUSRIF",259,0) ;" D INIT^XPDID "RTN","TMGUSRIF",260,0) ;" S XPDIDTOT=100 "RTN","TMGUSRIF",261,0) ;" D TITLE^XPDID("hello world") "RTN","TMGUSRIF",262,0) ;" D UPDATE^XPDID(50) "RTN","TMGUSRIF",263,0) ;" F AJJ=90:1:100 D UPDATE^XPDID(I) "RTN","TMGUSRIF",264,0) ;" D EXIT^XPDID() "RTN","TMGUSRIF",265,0) ;" "RTN","TMGUSRIF",266,0) ;"The XPDID routine does modify the scroll region and make the "RTN","TMGUSRIF",267,0) ;"application seem a bit more "GUI"-like, by the way... "RTN","TMGUSRIF",268,0) ;" "RTN","TMGUSRIF",269,0) ;"David "RTN","TMGUSRIF",270,0) "RTN","TMGUSRIF",271,0) do ;"Turn off cursor display, to prevent flickering "RTN","TMGUSRIF",272,0) . new $etrap set $etrap="" "RTN","TMGUSRIF",273,0) . xecute ^%ZOSF("TRMOFF") "RTN","TMGUSRIF",274,0) "RTN","TMGUSRIF",275,0) set max=+$get(max,100) "RTN","TMGUSRIF",276,0) set min=+$get(min,0) "RTN","TMGUSRIF",277,0) set width=+$get(width,70) "RTN","TMGUSRIF",278,0) set label=$get(label,"Progress") "RTN","TMGUSRIF",279,0) "RTN","TMGUSRIF",280,0) new premark,i,postmark "RTN","TMGUSRIF",281,0) new pct "RTN","TMGUSRIF",282,0) if (max-min)=0 set pct=0 "RTN","TMGUSRIF",283,0) else set pct=(value-min)/(max-min) "RTN","TMGUSRIF",284,0) if pct>1 set pct=1 "RTN","TMGUSRIF",285,0) if pct<0 set pct=0 "RTN","TMGUSRIF",286,0) "RTN","TMGUSRIF",287,0) if (pct<1)&($get(startTime)="") set startTime=$H "RTN","TMGUSRIF",288,0) "RTN","TMGUSRIF",289,0) ;"set startTime=+$get(startTime) "RTN","TMGUSRIF",290,0) set startTime=$get(startTime) ;" +$get 61053,61748 --> 61053 "RTN","TMGUSRIF",291,0) new pRefCt set pRefCt=$name(^TMP("TMG","PROGRESS-BAR",$J)) "RTN","TMGUSRIF",292,0) new curRate set curRate="" "RTN","TMGUSRIF",293,0) if $get(@pRefCt@("START-TIME"))=startTime do "RTN","TMGUSRIF",294,0) . new interval set interval=$get(@pRefCt@("SAMPLING","INTERVAL"),10) "RTN","TMGUSRIF",295,0) . set curRate=$get(@pRefCt@("LATEST-RATE")) "RTN","TMGUSRIF",296,0) . new count set count=$get(@pRefCt@("SAMPLING","COUNT"))+1 "RTN","TMGUSRIF",297,0) . if count#interval=0 do "RTN","TMGUSRIF",298,0) . . new deltaT,deltaV "RTN","TMGUSRIF",299,0) . . set deltaT=$$HDIFF^XLFDT($H,$get(@pRefCt@("SAMPLING","REF-TIME")),2) "RTN","TMGUSRIF",300,0) . . if deltaT=0 set interval=interval*2 "RTN","TMGUSRIF",301,0) . . else if deltaT>1000 set interval=interval\1.5 "RTN","TMGUSRIF",302,0) . . set deltaV=value-$get(@pRefCt@("SAMPLING","VALUE COUNT")) "RTN","TMGUSRIF",303,0) . . if deltaV>0 set curRate=deltaT/deltaV ;"dT/dValue "RTN","TMGUSRIF",304,0) . . else set curRate="" "RTN","TMGUSRIF",305,0) . . set @pRefCt@("LATEST-RATE")=curRate "RTN","TMGUSRIF",306,0) . . set @pRefCt@("SAMPLING","REF-TIME")=$H "RTN","TMGUSRIF",307,0) . . set @pRefCt@("SAMPLING","VALUE COUNT")=value "RTN","TMGUSRIF",308,0) . set @pRefCt@("SAMPLING","COUNT")=count#interval "RTN","TMGUSRIF",309,0) . set @pRefCt@("SAMPLING","INTERVAL")=interval "RTN","TMGUSRIF",310,0) else do "RTN","TMGUSRIF",311,0) . kill @pRefCt "RTN","TMGUSRIF",312,0) . set @pRefCt@("START-TIME")=startTime "RTN","TMGUSRIF",313,0) . set @pRefCt@("SAMPLING","COUNT")=0 "RTN","TMGUSRIF",314,0) . set @pRefCt@("SAMPLING","REF-TIME")=$H "RTN","TMGUSRIF",315,0) . set @pRefCt@("SAMPLING","VALUE COUNT")=value "RTN","TMGUSRIF",316,0) "RTN","TMGUSRIF",317,0) new timeStr set timeStr=" " "RTN","TMGUSRIF",318,0) new remainingT set remainingT="" "RTN","TMGUSRIF",319,0) new delta set delta=0 "RTN","TMGUSRIF",320,0) "RTN","TMGUSRIF",321,0) if curRate'="" do "RTN","TMGUSRIF",322,0) . new remainV set remainV=(max-value) "RTN","TMGUSRIF",323,0) . if remainV'<0 do "RTN","TMGUSRIF",324,0) . . set remainingT=curRate*remainV "RTN","TMGUSRIF",325,0) . else do "RTN","TMGUSRIF",326,0) . . set delta=-1,remainingT=$$HDIFF^XLFDT($H,startTime,2) "RTN","TMGUSRIF",327,0) else if $data(startTime) do "RTN","TMGUSRIF",328,0) . if pct=0 quit "RTN","TMGUSRIF",329,0) . set timeStr="" "RTN","TMGUSRIF",330,0) . set delta=$$HDIFF^XLFDT($H,startTime,2) "RTN","TMGUSRIF",331,0) . if delta<0 set remainingT=-delta ;"just report # sec's overrun. "RTN","TMGUSRIF",332,0) . set remainingT=delta*((1/pct)-1) "RTN","TMGUSRIF",333,0) "RTN","TMGUSRIF",334,0) if remainingT'="" do "RTN","TMGUSRIF",335,0) . new days set days=remainingT\86400 ;"86400 sec per day. "RTN","TMGUSRIF",336,0) . if days>5 set timeStr=" " quit "RTN","TMGUSRIF",337,0) . set remainingT=remainingT#86400 "RTN","TMGUSRIF",338,0) . new hours set hours=remainingT\3600 ;"3600 sec per hour "RTN","TMGUSRIF",339,0) . set remainingT=remainingT#3600 "RTN","TMGUSRIF",340,0) . new mins set mins=remainingT\60 ;"60 sec per min "RTN","TMGUSRIF",341,0) . new secs set secs=(remainingT#60)\1 "RTN","TMGUSRIF",342,0) . if days>0 set timeStr=timeStr_days_"d, " "RTN","TMGUSRIF",343,0) . if hours>0 set timeStr=timeStr_hours_"h:" "RTN","TMGUSRIF",344,0) . if (min=0)&(secs=0) do "RTN","TMGUSRIF",345,0) . . set timeStr=" " "RTN","TMGUSRIF",346,0) . else do "RTN","TMGUSRIF",347,0) . . set timeStr=timeStr_mins_":" "RTN","TMGUSRIF",348,0) . . if secs<10 set timeStr=timeStr_"0" "RTN","TMGUSRIF",349,0) . . set timeStr=timeStr_secs_" " "RTN","TMGUSRIF",350,0) . if delta<0 set timeStr="+"_timeStr ;"just report # sec's overrun. "RTN","TMGUSRIF",351,0) "RTN","TMGUSRIF",352,0) ;"set width=width-$length(label)-10 ;"was 9 "RTN","TMGUSRIF",353,0) set width=width-$length(label)-($length(timeStr)+1) "RTN","TMGUSRIF",354,0) set premark=(width*pct)\1 "RTN","TMGUSRIF",355,0) set postmark=width-premark "RTN","TMGUSRIF",356,0) "RTN","TMGUSRIF",357,0) new barberPole set barberPole=+$get(@pRefCt@("BARBER POLE")) "RTN","TMGUSRIF",358,0) if $get(@pRefCt@("BARBER POLE","LAST INC"))'=$H do "RTN","TMGUSRIF",359,0) . set barberPole=(barberPole-1)#4 "RTN","TMGUSRIF",360,0) . set @pRefCt@("BARBER POLE")=barberPole ;"should be 0,1,2, or 3) "RTN","TMGUSRIF",361,0) . set @pRefCt@("BARBER POLE","LAST INC")=$H "RTN","TMGUSRIF",362,0) "RTN","TMGUSRIF",363,0) write label,":" "RTN","TMGUSRIF",364,0) if pct<1 write " " "RTN","TMGUSRIF",365,0) if pct<0.1 write " " "RTN","TMGUSRIF",366,0) write (pct*100)\1,"% " "RTN","TMGUSRIF",367,0) for i=0:1:premark-1 do "RTN","TMGUSRIF",368,0) . if (barberPole+i)#4=0 write "~" "RTN","TMGUSRIF",369,0) . else write "-" "RTN","TMGUSRIF",370,0) write ">|" "RTN","TMGUSRIF",371,0) for i=1:1:(postmark-1) write "-" "RTN","TMGUSRIF",372,0) if postmark>0 write "| " "RTN","TMGUSRIF",373,0) write timeStr "RTN","TMGUSRIF",374,0) "RTN","TMGUSRIF",375,0) ;"write $char(13) set $X=0 "RTN","TMGUSRIF",376,0) write ! "RTN","TMGUSRIF",377,0) do CUU^TMGTERM(1) "RTN","TMGUSRIF",378,0) "RTN","TMGUSRIF",379,0) PBDone "RTN","TMGUSRIF",380,0) do ;"Turn cursor display back on. "RTN","TMGUSRIF",381,0) . new $etrap set $etrap="" "RTN","TMGUSRIF",382,0) . ;"xecute ^%ZOSF("TRMON") "RTN","TMGUSRIF",383,0) . ;"U $I:(TERMINATOR=$C(13,127)) "RTN","TMGUSRIF",384,0) quit "RTN","TMGUSRIF",385,0) "RTN","TMGUSRIF",386,0) "RTN","TMGUSRIF",387,0) PressToCont "RTN","TMGUSRIF",388,0) ;"Purpose: to provide a 'press key to continue' action "RTN","TMGUSRIF",389,0) "RTN","TMGUSRIF",390,0) write "----- Press Key To Continue -----" "RTN","TMGUSRIF",391,0) new ch set ch=$$KeyPressed^TMGUSRIF(0,240) "RTN","TMGUSRIF",392,0) write ! "RTN","TMGUSRIF",393,0) quit "RTN","TMGUSRIF",394,0) "RTN","TMGUSRIF",395,0) "RTN","TMGUSRIF",396,0) UserAborted() "RTN","TMGUSRIF",397,0) ;"Purpose: Checks if user pressed ESC key. If so, then ask if abort wanted "RTN","TMGUSRIF",398,0) ;"Note: return is immediate. "RTN","TMGUSRIF",399,0) ;"Returns: 1 if user aborted, 0 if not. "RTN","TMGUSRIF",400,0) "RTN","TMGUSRIF",401,0) new result set result=0 "RTN","TMGUSRIF",402,0) if $$KeyPressed=27 do "RTN","TMGUSRIF",403,0) . new % set %=2 "RTN","TMGUSRIF",404,0) . write !,"Abort" do YN^DICN write ! "RTN","TMGUSRIF",405,0) . set result=(%=1) "RTN","TMGUSRIF",406,0) "RTN","TMGUSRIF",407,0) quit result "RTN","TMGUSRIF",408,0) "RTN","TMGUSRIF",409,0) "RTN","TMGUSRIF",410,0) KeyPressed(wantChar,waitTime) "RTN","TMGUSRIF",411,0) ;"Purpose: to check for a keypress "RTN","TMGUSRIF",412,0) ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value "RTN","TMGUSRIF",413,0) ;" waitTime -- OPTIONAL, default is 0 (immediate return) "RTN","TMGUSRIF",414,0) ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1) "RTN","TMGUSRIF",415,0) ;"Note: this does NOT wait for user to press key "RTN","TMGUSRIF",416,0) "RTN","TMGUSRIF",417,0) new temp "RTN","TMGUSRIF",418,0) set waitTime=$get(waitTime,0) "RTN","TMGUSRIF",419,0) read *temp:waitTime "RTN","TMGUSRIF",420,0) if $get(wantChar)=1 set temp=$char(temp) "RTN","TMGUSRIF",421,0) quit temp "RTN","TMGUSRIF",422,0) "RTN","TMGUSRIF",423,0) "RTN","TMGUSRIF",424,0) Read(Terminators,timeOut,Num,initialVal) "RTN","TMGUSRIF",425,0) ;"Purpose: a custom read function with custom terminators "RTN","TMGUSRIF",426,0) ;"Input: Terminators -- OPTIONAL Flags to specify characters that will signal that "RTN","TMGUSRIF",427,0) ;" the user is done with input. Flags as follows: "RTN","TMGUSRIF",428,0) ;" r = return/enter "RTN","TMGUSRIF",429,0) ;" t = tab "RTN","TMGUSRIF",430,0) ;" s = space "RTN","TMGUSRIF",431,0) ;" e = escape "RTN","TMGUSRIF",432,0) ;" b = backspace "RTN","TMGUSRIF",433,0) ;" NONE = no terminators "RTN","TMGUSRIF",434,0) ;" e.g. 'rte' means that if user enters a return, tab, or escape "RTN","TMGUSRIF",435,0) ;" then input it ended, and characters (up to, but not including "RTN","TMGUSRIF",436,0) ;" terminator) entered are returned. "RTN","TMGUSRIF",437,0) ;" e.g. 'NONE' --> NO terminators. NOTE: MUST supply a number "RTN","TMGUSRIF",438,0) ;" characters to read, or endless loop will result. "RTN","TMGUSRIF",439,0) ;" If Terminator="", then default value of 'r' is used "RTN","TMGUSRIF",440,0) ;" timeOut -- Optional -- the allowed lengh of time to wait before timeout. "RTN","TMGUSRIF",441,0) ;" default value is 999,999 seconds (~11 days) "RTN","TMGUSRIF",442,0) ;" Num -- OPTIONAL -- a number of characters to read, e.g. 5 to read just "RTN","TMGUSRIF",443,0) ;" 5 characters (or less than 5 if terminator encountered) "RTN","TMGUSRIF",444,0) ;" initialVal -- OPTIONAL -- This can be a value that presents the output "RTN","TMGUSRIF",445,0) ;" It also allows editing of former inputs. Note: this funtion "RTN","TMGUSRIF",446,0) ;" assumes that initialValue has been printed to the screen before "RTN","TMGUSRIF",447,0) ;" calling this function. "RTN","TMGUSRIF",448,0) ;" "RTN","TMGUSRIF",449,0) ;"Result: returns characters read. "RTN","TMGUSRIF",450,0) "RTN","TMGUSRIF",451,0) new result set result=$get(initialValue) "RTN","TMGUSRIF",452,0) set timeOut=+$get(timeOut,999999) "RTN","TMGUSRIF",453,0) new len set len=0 "RTN","TMGUSRIF",454,0) set Num=$get(Num) "RTN","TMGUSRIF",455,0) set Terminators=$get(Terminators) "RTN","TMGUSRIF",456,0) if Terminators="" set Terminators="r" "RTN","TMGUSRIF",457,0) else if Terminators="NONE" set Terminators="" "RTN","TMGUSRIF",458,0) new temp "RTN","TMGUSRIF",459,0) new done set done=0 "RTN","TMGUSRIF",460,0) "RTN","TMGUSRIF",461,0) RLoop xecute ^%ZOSF("EOFF") "RTN","TMGUSRIF",462,0) read *temp:timeOut ;"reads the ascii number of key (92, instead of 'a') "RTN","TMGUSRIF",463,0) xecute ^%ZOSF("EON") "RTN","TMGUSRIF",464,0) if (temp=13)&(Terminators["r") do "RTN","TMGUSRIF",465,0) . set done=1 "RTN","TMGUSRIF",466,0) else if (temp=9)&(Terminators["t") do "RTN","TMGUSRIF",467,0) . set done=1 "RTN","TMGUSRIF",468,0) else if (temp=32)&(Terminators["s") do "RTN","TMGUSRIF",469,0) . set done=1 "RTN","TMGUSRIF",470,0) else if (temp=27)&(Terminators["e") do "RTN","TMGUSRIF",471,0) . set done=1 "RTN","TMGUSRIF",472,0) else if (temp=127)&(Terminators["b") do "RTN","TMGUSRIF",473,0) . set done=1 "RTN","TMGUSRIF",474,0) else if (temp'=-1) do "RTN","TMGUSRIF",475,0) . if temp=127 do quit "RTN","TMGUSRIF",476,0) . . if result="" quit "RTN","TMGUSRIF",477,0) . . set result=$extract(result,1,$length(result)-1) "RTN","TMGUSRIF",478,0) . . write $char(8)," ",$char(8) "RTN","TMGUSRIF",479,0) . set result=result_$char(temp) "RTN","TMGUSRIF",480,0) . write $char(temp) "RTN","TMGUSRIF",481,0) . if Num="" quit "RTN","TMGUSRIF",482,0) . if $length(result)'<+Num set done=1 "RTN","TMGUSRIF",483,0) "RTN","TMGUSRIF",484,0) if 'done goto RLoop "RTN","TMGUSRIF",485,0) "RTN","TMGUSRIF",486,0) quit result "RTN","TMGUSRIF",487,0) "RTN","TMGUSRIF",488,0) "RTN","TMGUSRIF",489,0) IENSelector(pIENArray,pResults,File,Fields,Widths,Header,SortFlds,SaveArray) "RTN","TMGUSRIF",490,0) ;"Purpose: to allow selecting records from an IEN array "RTN","TMGUSRIF",491,0) ;"Input: pIENArray, PASS BY NAME. An array of IENS to select from "RTN","TMGUSRIF",492,0) ;" format: "RTN","TMGUSRIF",493,0) ;" @pIENArray@(IEN)="" "RTN","TMGUSRIF",494,0) ;" @pIENArray@(IEN)="" "RTN","TMGUSRIF",495,0) ;" @pIENArray@(IEN,"SEL")="" ;"<-- Optional marker to have this preselected "RTN","TMGUSRIF",496,0) ;" pResults -- NAME OF array to have results returned in "RTN","TMGUSRIF",497,0) ;" ** Note: Prior contents of array WILL be KILLED first "RTN","TMGUSRIF",498,0) ;" Format of returned array: Only those valuse that user selected will "RTN","TMGUSRIF",499,0) ;" be aded to list "RTN","TMGUSRIF",500,0) ;" @pResults@(IEN)=DisplayLineNumber "RTN","TMGUSRIF",501,0) ;" @pResults@(IEN)=DisplayLineNumber "RTN","TMGUSRIF",502,0) ;" File: The file that IEN's are from. "RTN","TMGUSRIF",503,0) ;" Fields: OPTIONAL. The Field(s) that should be shown for record. .01 is Default "RTN","TMGUSRIF",504,0) ;" Fields may also be a ';' delimited list of Fields, e.g. ".01;.02;1". "RTN","TMGUSRIF",505,0) ;" Widths: Optional. The widths of the columns to display Fields in. "RTN","TMGUSRIF",506,0) ;" Format: e.g. "10;12;24" for three colums of widths: "RTN","TMGUSRIF",507,0) ;" Sequence must match sequence given in Fields "RTN","TMGUSRIF",508,0) ;" Default is to evenly space colums "RTN","TMGUSRIF",509,0) ;" Header -- OPTIONAL -- A header text to show. "RTN","TMGUSRIF",510,0) ;" SortFlds -- OPTIONAL -- Provide sorting fields "RTN","TMGUSRIF",511,0) ;" Format: 'FldNum1;FldNum2;FldNum3...' "RTN","TMGUSRIF",512,0) ;" SaveArray -- OPTIONAL -- PASS BY REFERENCE, "RTN","TMGUSRIF",513,0) ;" This variable will be filled with the NAME of the array "RTN","TMGUSRIF",514,0) ;" used for displaying the array. The FIRST time this function "RTN","TMGUSRIF",515,0) ;" is called, this variable should = "". On SUBSEQUENT calls, "RTN","TMGUSRIF",516,0) ;" if this variable holds the name of a variable (a reference), then "RTN","TMGUSRIF",517,0) ;" that array will be used, rather than taking the time to create "RTN","TMGUSRIF",518,0) ;" the display array again. Format of array: "RTN","TMGUSRIF",519,0) ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... "RTN","TMGUSRIF",520,0) ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... "RTN","TMGUSRIF",521,0) ;" Note: The LineNumber is the same number as the DisplayLineNumber "RTN","TMGUSRIF",522,0) ;" returned in @pResults@(IEN)=DisplayLineNUmber "RTN","TMGUSRIF",523,0) ;"Results: none "RTN","TMGUSRIF",524,0) "RTN","TMGUSRIF",525,0) if $get(pResults)'="" kill @pResults "RTN","TMGUSRIF",526,0) new PreSelArray "RTN","TMGUSRIF",527,0) new ref "RTN","TMGUSRIF",528,0) if $get(SaveArray)="" do "RTN","TMGUSRIF",529,0) . set ref=$name(^TMP("VEE",$J)) "RTN","TMGUSRIF",530,0) . kill @ref "RTN","TMGUSRIF",531,0) . set SaveArray=ref "RTN","TMGUSRIF",532,0) else do goto IS1 ;"Skip recreating array if SaveArray holds reference "RTN","TMGUSRIF",533,0) . set ref=SaveArray "RTN","TMGUSRIF",534,0) "RTN","TMGUSRIF",535,0) new ref2 set ref2=$name(^TMG("TMP",$J,"IEN-SELECT")) "RTN","TMGUSRIF",536,0) kill @ref2 "RTN","TMGUSRIF",537,0) if $get(Header)'="" set @ref@("HD")=Header "RTN","TMGUSRIF",538,0) set Sort=$get(Sort,0) "RTN","TMGUSRIF",539,0) set IOM=$get(IOM,80) "RTN","TMGUSRIF",540,0) set Fields=$get(Fields,".01") "RTN","TMGUSRIF",541,0) set Widths=$get(Widths) "RTN","TMGUSRIF",542,0) new Sort set Sort=($data(SortFlds)'=0) "RTN","TMGUSRIF",543,0) "RTN","TMGUSRIF",544,0) ;"Setup FldArray. Format: "RTN","TMGUSRIF",545,0) ;" FldArray=number of colums "RTN","TMGUSRIF",546,0) ;" FldArray(Sequence#)=field;fieldWidth "RTN","TMGUSRIF",547,0) ;" FldArray(Sequence#)=field;fieldWidth "RTN","TMGUSRIF",548,0) ;" FldArray(Sequence#)=field;fieldWidth "RTN","TMGUSRIF",549,0) new FldArray,i "RTN","TMGUSRIF",550,0) set FldArray=0 "RTN","TMGUSRIF",551,0) new WRemain set WRemain=IOM "RTN","TMGUSRIF",552,0) for i=1:1:$length(Fields,";") do "RTN","TMGUSRIF",553,0) . new Fld,W "RTN","TMGUSRIF",554,0) . set Fld=$piece(Fields,";",i) "RTN","TMGUSRIF",555,0) . if Fld="" quit "RTN","TMGUSRIF",556,0) . set W=+$piece(Widths,";",i) "RTN","TMGUSRIF",557,0) . if W=0 do "RTN","TMGUSRIF",558,0) . . if FldArray>0 set W=IOM/FldArray "RTN","TMGUSRIF",559,0) . . else set W=20 ;"some arbitrary number "RTN","TMGUSRIF",560,0) . if W>WRemain set W=WRemain ;"this isn't perfect "RTN","TMGUSRIF",561,0) . set WRemain=WRemain-W "RTN","TMGUSRIF",562,0) . if WRemain<1 set WRemain=1 "RTN","TMGUSRIF",563,0) . set FldArray(i)=Fld_";"_W "RTN","TMGUSRIF",564,0) . set FldArray=FldArray+1 "RTN","TMGUSRIF",565,0) "RTN","TMGUSRIF",566,0) new Itr,IEN,name,PriorErrorFound "RTN","TMGUSRIF",567,0) new abort set abort=0 "RTN","TMGUSRIF",568,0) new order set order=1 "RTN","TMGUSRIF",569,0) new IENPreSelected "RTN","TMGUSRIF",570,0) write "Prepairing list to display..." "RTN","TMGUSRIF",571,0) set IEN=$$ItrAInit^TMGITR(pIENArray,.Itr) "RTN","TMGUSRIF",572,0) do PrepProgress^TMGITR(.Itr,100,0,"IEN") "RTN","TMGUSRIF",573,0) write ! "RTN","TMGUSRIF",574,0) if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1) "RTN","TMGUSRIF",575,0) . new TMGOUT,TMGMSG,IENS,showS,i "RTN","TMGUSRIF",576,0) . set showS="" "RTN","TMGUSRIF",577,0) . set IENS=IEN_"," "RTN","TMGUSRIF",578,0) . new tempFields "RTN","TMGUSRIF",579,0) . set IENPreSelected=($data(@pIENArray@(IEN,"SEL"))>0) "RTN","TMGUSRIF",580,0) . new i for i=1:1:FldArray do "RTN","TMGUSRIF",581,0) . . if showS'="" set showS=showS_"|" "RTN","TMGUSRIF",582,0) . . new Fld,tempS "RTN","TMGUSRIF",583,0) . . set Fld=$piece(FldArray(i),";",1) "RTN","TMGUSRIF",584,0) . . set tempS=$$GET1^DIQ(File,IENS,Fld,,"TMGOUT","TMGMSG") "RTN","TMGUSRIF",585,0) . . if $data(TMGMSG("DIERR")) do set abort=1 quit "RTN","TMGUSRIF",586,0) . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) "RTN","TMGUSRIF",587,0) . . new W set W=$piece(FldArray(i),";",2) "RTN","TMGUSRIF",588,0) . . set tempS=$extract(tempS,1,W) "RTN","TMGUSRIF",589,0) . . if Sort set tempFields(Fld)=tempS "RTN","TMGUSRIF",590,0) . . set showS=showS_$$LJ^XLFSTR(tempS,W," ") "RTN","TMGUSRIF",591,0) . if Sort=0 do "RTN","TMGUSRIF",592,0) . . set @ref@(order)=IEN_$char(9)_showS "RTN","TMGUSRIF",593,0) . . if IENPreSelected set PreSelArray(order)="" "RTN","TMGUSRIF",594,0) . . set order=order+1 "RTN","TMGUSRIF",595,0) . else do "RTN","TMGUSRIF",596,0) . . new tempRef set tempRef=ref2 "RTN","TMGUSRIF",597,0) . . for i=1:1:$length(SortFlds,";") do "RTN","TMGUSRIF",598,0) . . . new oneFld set oneFld=$piece(SortFlds,";",i) "RTN","TMGUSRIF",599,0) . . . new F set F=$get(tempFields(oneFld)) "RTN","TMGUSRIF",600,0) . . . if F="" quit "RTN","TMGUSRIF",601,0) . . . set tempRef=$name(@tempRef@(F)) "RTN","TMGUSRIF",602,0) . . set @tempRef@(IEN)=IEN_$char(9)_showS "RTN","TMGUSRIF",603,0) . . if IENPreSelected set @tempRef@(IEN,"SEL")="" "RTN","TMGUSRIF",604,0) . . ;"Sets up sorted variable as follows: "RTN","TMGUSRIF",605,0) . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' "RTN","TMGUSRIF",606,0) . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' "RTN","TMGUSRIF",607,0) . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' "RTN","TMGUSRIF",608,0) do ProgressDone^TMGITR(.Itr) "RTN","TMGUSRIF",609,0) write ! "RTN","TMGUSRIF",610,0) "RTN","TMGUSRIF",611,0) if abort=1 goto ISDone "RTN","TMGUSRIF",612,0) "RTN","TMGUSRIF",613,0) IES1 if Sort=1 do "RTN","TMGUSRIF",614,0) . write "Sorting... " "RTN","TMGUSRIF",615,0) . set order=1 "RTN","TMGUSRIF",616,0) . new tempRef2 set tempRef2=ref2 "RTN","TMGUSRIF",617,0) . new showS,NumNodes,Done "RTN","TMGUSRIF",618,0) . set Done=0 "RTN","TMGUSRIF",619,0) . for do quit:(tempRef2="")!(Done=1) "RTN","TMGUSRIF",620,0) . . set tempRef2=$query(@tempRef2) "RTN","TMGUSRIF",621,0) . . if (tempRef2="") quit "RTN","TMGUSRIF",622,0) . . if $qsubscript(tempRef2,$qlength(tempRef2))="SEL" do quit "RTN","TMGUSRIF",623,0) . . . set PreSelArray(order-1)="" "RTN","TMGUSRIF",624,0) . . if (tempRef2'[$$OREF^DILF(ref2)) set Done=1 quit "RTN","TMGUSRIF",625,0) . . set showS=$get(@tempRef2) "RTN","TMGUSRIF",626,0) . . set @ref@(order)=showS "RTN","TMGUSRIF",627,0) . . set order=order+1 "RTN","TMGUSRIF",628,0) "RTN","TMGUSRIF",629,0) ;"Note: Rules of use: "RTN","TMGUSRIF",630,0) ;" ref must=^TMP("VEE",$J) "RTN","TMGUSRIF",631,0) ;" Each line should be in this format: "RTN","TMGUSRIF",632,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",633,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",634,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",635,0) ;" Note: if DisplayValue is to be divided into colums, then "RTN","TMGUSRIF",636,0) ;" use | character to separate "RTN","TMGUSRIF",637,0) ;" @ref@("HD")=Header to display "RTN","TMGUSRIF",638,0) ;" Results come back in: "RTN","TMGUSRIF",639,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",640,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",641,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",642,0) ;" To preselect entries, provide an array like this: "RTN","TMGUSRIF",643,0) ;" array(number)="" <-- number is same number as above, shows selected "RTN","TMGUSRIF",644,0) ;" array(number)="" "RTN","TMGUSRIF",645,0) ;" array(number)="" "RTN","TMGUSRIF",646,0) ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") "RTN","TMGUSRIF",647,0) IS1 "RTN","TMGUSRIF",648,0) new NumberLines set NumberLines=0 ;"1--> number each line "RTN","TMGUSRIF",649,0) new AddNew set AddNew=0 ;"1-> Allow adding new entry "RTN","TMGUSRIF",650,0) "RTN","TMGUSRIF",651,0) write "Passing off to selector..." "RTN","TMGUSRIF",652,0) D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") "RTN","TMGUSRIF",653,0) "RTN","TMGUSRIF",654,0) ;"Format results "RTN","TMGUSRIF",655,0) new Itr2,index "RTN","TMGUSRIF",656,0) set index=$$ItrAInit^TMGITR($name(^TMP("VPE","SELECT",$J)),.Itr2) "RTN","TMGUSRIF",657,0) if index'="" for do quit:($$ItrANext^TMGITR(.Itr2,.index)="") "RTN","TMGUSRIF",658,0) . new s set s=$piece($get(^TMP("VPE","SELECT",$J,index)),$char(9),1) "RTN","TMGUSRIF",659,0) . set @pResults@(s)=index "RTN","TMGUSRIF",660,0) "RTN","TMGUSRIF",661,0) kill ^TMP("VPE","SELECT",$J) "RTN","TMGUSRIF",662,0) if $get(ref2) kill @ref2 ;"i.e. ^TMG("TMP",$J,"IEN-SELECT") "RTN","TMGUSRIF",663,0) "RTN","TMGUSRIF",664,0) ISDone "RTN","TMGUSRIF",665,0) quit "RTN","TMGUSRIF",666,0) "RTN","TMGUSRIF",667,0) "RTN","TMGUSRIF",668,0) Selector(pArray,pResults,Header) "RTN","TMGUSRIF",669,0) ;"Purpose: Interface with VPE Selector code to select from an array "RTN","TMGUSRIF",670,0) ;"Input: pArray -- NAME OF array holding items to be selected from "RTN","TMGUSRIF",671,0) ;" Expected format: "RTN","TMGUSRIF",672,0) ;" @pArray@("Display Choice Words")=ReturnValue <-- ReturnValue is optional "RTN","TMGUSRIF",673,0) ;" @pArray@("Display Choice Words")=ReturnValue "RTN","TMGUSRIF",674,0) ;" @pArray@("Display Choice Words")=ReturnValue "RTN","TMGUSRIF",675,0) ;" @pArray@("Display Choice Words","SEL")="" <-- optional preselection indicator "RTN","TMGUSRIF",676,0) ;" pResults -- NAME OF array to have results returned in "RTN","TMGUSRIF",677,0) ;" ** Note: Prior contents of array will NOT be KILLED first "RTN","TMGUSRIF",678,0) ;" Format of returned array: Only those valuse that user selected will be returned "RTN","TMGUSRIF",679,0) ;" @pResults@("Display Choice Words")=ReturnValue <-- ReturnValue is optional "RTN","TMGUSRIF",680,0) ;" @pResults@("Display Choice Words")=ReturnValue "RTN","TMGUSRIF",681,0) ;" @pResults@("Display Choice Words")=ReturnValue "RTN","TMGUSRIF",682,0) ;" Header -- OPTIONAL -- A header text to show. "RTN","TMGUSRIF",683,0) "RTN","TMGUSRIF",684,0) new ref set ref=$name(^TMP("VEE",$J)) "RTN","TMGUSRIF",685,0) kill @ref "RTN","TMGUSRIF",686,0) if $get(pArray)="" goto SelDone "RTN","TMGUSRIF",687,0) if $get(pResults)="" goto SelDone "RTN","TMGUSRIF",688,0) "RTN","TMGUSRIF",689,0) new PreSelArray "RTN","TMGUSRIF",690,0) "RTN","TMGUSRIF",691,0) ;"First set up array of options "RTN","TMGUSRIF",692,0) new DispWords,RtnValue "RTN","TMGUSRIF",693,0) new order set order=1 "RTN","TMGUSRIF",694,0) set DispWords=$order(@pArray@("")) "RTN","TMGUSRIF",695,0) if DispWords'="" for do quit:(DispWords="") "RTN","TMGUSRIF",696,0) . set RtnValue=$get(@pArray@(DispWords),"") "RTN","TMGUSRIF",697,0) . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) "RTN","TMGUSRIF",698,0) . if $data(@pArray@(DispWords,"SEL")) set PreSelArray(order)="" ;"mark as preselected "RTN","TMGUSRIF",699,0) . set order=order+1 "RTN","TMGUSRIF",700,0) . set DispWords=$order(@pArray@(DispWords)) "RTN","TMGUSRIF",701,0) "RTN","TMGUSRIF",702,0) if $get(Header)'="" set @ref@("HD")=Header "RTN","TMGUSRIF",703,0) "RTN","TMGUSRIF",704,0) ;"Note: Rules of use: "RTN","TMGUSRIF",705,0) ;" ref must=^TMP("VEE",$J) "RTN","TMGUSRIF",706,0) ;" Each line should be in this format: "RTN","TMGUSRIF",707,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",708,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",709,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",710,0) ;" Note: if DisplayValue is to be divided into colums, then "RTN","TMGUSRIF",711,0) ;" use | character to separate "RTN","TMGUSRIF",712,0) ;" Results come back in: "RTN","TMGUSRIF",713,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",714,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",715,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",716,0) ;" To preselect entries, provide an array like this: "RTN","TMGUSRIF",717,0) ;" array(number)="" <-- number is same number as above, shows selected "RTN","TMGUSRIF",718,0) ;" array(number)="" "RTN","TMGUSRIF",719,0) ;" array(number)="" "RTN","TMGUSRIF",720,0) ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") "RTN","TMGUSRIF",721,0) "RTN","TMGUSRIF",722,0) new NumberLines set NumberLines=0 ;"1--> number each line "RTN","TMGUSRIF",723,0) new AddNew set AddNew=0 ;"1-> Allow adding new entry "RTN","TMGUSRIF",724,0) "RTN","TMGUSRIF",725,0) D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") "RTN","TMGUSRIF",726,0) "RTN","TMGUSRIF",727,0) ;"Format selected options. "RTN","TMGUSRIF",728,0) new index set index=$order(^TMP("VPE","SELECT",$J,"")) "RTN","TMGUSRIF",729,0) if index'="" for do quit:(index="") "RTN","TMGUSRIF",730,0) . new s,s1,s2 "RTN","TMGUSRIF",731,0) . set s=$get(^TMP("VPE","SELECT",$J,index)) "RTN","TMGUSRIF",732,0) . set s1=$piece(s,$char(9),1) "RTN","TMGUSRIF",733,0) . set s2=$piece(s,$char(9),2) "RTN","TMGUSRIF",734,0) . set @pResults@(s2)=s1 "RTN","TMGUSRIF",735,0) . set index=$order(^TMP("VPE","SELECT",$J,index)) "RTN","TMGUSRIF",736,0) "RTN","TMGUSRIF",737,0) kill ^TMP("VPE","SELECT",$J) "RTN","TMGUSRIF",738,0) kill @ref "RTN","TMGUSRIF",739,0) "RTN","TMGUSRIF",740,0) SelDone "RTN","TMGUSRIF",741,0) quit "RTN","TMGUSRIF",742,0) "RTN","TMGUSRIF",743,0) "RTN","TMGUSRIF",744,0) Slctor2(pArray,pResults,Header) "RTN","TMGUSRIF",745,0) ;"Purpose: Interface with VPE Selector code to select from an array "RTN","TMGUSRIF",746,0) ;" Note: This allows a different format of input. In Selector() above, "RTN","TMGUSRIF",747,0) ;" it is NOT possible to have two similar Display Words with "RTN","TMGUSRIF",748,0) ;" different return values. E.g. two drugs with LISINOPRIL, but "RTN","TMGUSRIF",749,0) ;" different IEN return values. This fn allows this "RTN","TMGUSRIF",750,0) ;"Input: pArray -- NAME OF array holding items to be selected from "RTN","TMGUSRIF",751,0) ;" Expected format: "RTN","TMGUSRIF",752,0) ;" @pArray@("Display Choice Words",ReturnValue)="" <-- return value IS required "RTN","TMGUSRIF",753,0) ;" @pArray@("Display Choice Words",ReturnValue)="" "RTN","TMGUSRIF",754,0) ;" @pArray@("Display Choice Words",ReturnValue)="" "RTN","TMGUSRIF",755,0) ;" @pArray@("Display Choice Words",ReturnValue,"SEL")="" <-- optional preselection indicator "RTN","TMGUSRIF",756,0) ;" pResults -- NAME OF array to have results returned in "RTN","TMGUSRIF",757,0) ;" ** Note: Prior contents of array will NOT be KILLED first "RTN","TMGUSRIF",758,0) ;" Format of returned array: Only those values that user selected will be returned "RTN","TMGUSRIF",759,0) ;" @pResults@("Display Choice Words",ReturnValue)="" "RTN","TMGUSRIF",760,0) ;" @pResults@("Display Choice Words",ReturnValue)="" "RTN","TMGUSRIF",761,0) ;" @pResults@("Display Choice Words",ReturnValue)="" "RTN","TMGUSRIF",762,0) ;" Header -- OPTIONAL -- A header text to show. "RTN","TMGUSRIF",763,0) "RTN","TMGUSRIF",764,0) new ref set ref=$name(^TMP("VEE",$J)) "RTN","TMGUSRIF",765,0) kill @ref "RTN","TMGUSRIF",766,0) if $get(pArray)="" goto Sl2Done "RTN","TMGUSRIF",767,0) if $get(pResults)="" goto Sl2Done "RTN","TMGUSRIF",768,0) "RTN","TMGUSRIF",769,0) new PreSelArray "RTN","TMGUSRIF",770,0) "RTN","TMGUSRIF",771,0) ;"First set up array of options "RTN","TMGUSRIF",772,0) new DispWords,RtnValue "RTN","TMGUSRIF",773,0) new order set order=1 "RTN","TMGUSRIF",774,0) set DispWords="" "RTN","TMGUSRIF",775,0) for set DispWords=$order(@pArray@(DispWords)) quit:(DispWords="") do "RTN","TMGUSRIF",776,0) . set RtnValue="" "RTN","TMGUSRIF",777,0) . for set RtnValue=$order(@pArray@(DispWords,RtnValue)) quit:(RtnValue="") do "RTN","TMGUSRIF",778,0) . . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) "RTN","TMGUSRIF",779,0) . . if $data(@pArray@(DispWords,RtnValue,"SEL")) set PreSelArray(order)="" ;"mark as preselected "RTN","TMGUSRIF",780,0) . . set order=order+1 "RTN","TMGUSRIF",781,0) "RTN","TMGUSRIF",782,0) if $get(Header)'="" set @ref@("HD")=Header "RTN","TMGUSRIF",783,0) "RTN","TMGUSRIF",784,0) ;"Note: Rules of use: "RTN","TMGUSRIF",785,0) ;" ref must=^TMP("VEE",$J) "RTN","TMGUSRIF",786,0) ;" Each line should be in this format: "RTN","TMGUSRIF",787,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",788,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",789,0) ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",790,0) ;" Note: if DisplayValue is to be divided into colums, then "RTN","TMGUSRIF",791,0) ;" use | character to separate "RTN","TMGUSRIF",792,0) ;" Results come back in: "RTN","TMGUSRIF",793,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",794,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",795,0) ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue "RTN","TMGUSRIF",796,0) ;" To preselect entries, provide an array like this: "RTN","TMGUSRIF",797,0) ;" array(number)="" <-- number is same number as above, shows selected "RTN","TMGUSRIF",798,0) ;" array(number)="" "RTN","TMGUSRIF",799,0) ;" array(number)="" "RTN","TMGUSRIF",800,0) ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") "RTN","TMGUSRIF",801,0) "RTN","TMGUSRIF",802,0) new NumberLines set NumberLines=0 ;"1--> number each line "RTN","TMGUSRIF",803,0) new AddNew set AddNew=0 ;"1-> Allow adding new entry "RTN","TMGUSRIF",804,0) "RTN","TMGUSRIF",805,0) D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") "RTN","TMGUSRIF",806,0) "RTN","TMGUSRIF",807,0) ;"Format selected options. "RTN","TMGUSRIF",808,0) new index set index=$order(^TMP("VPE","SELECT",$J,"")) "RTN","TMGUSRIF",809,0) if index'="" for do quit:(index="") "RTN","TMGUSRIF",810,0) . new s,s1,s2 "RTN","TMGUSRIF",811,0) . set s=$get(^TMP("VPE","SELECT",$J,index)) "RTN","TMGUSRIF",812,0) . set s1=$piece(s,$char(9),1) "RTN","TMGUSRIF",813,0) . set s2=$piece(s,$char(9),2) "RTN","TMGUSRIF",814,0) . set @pResults@(s2,s1)="" "RTN","TMGUSRIF",815,0) . set index=$order(^TMP("VPE","SELECT",$J,index)) "RTN","TMGUSRIF",816,0) "RTN","TMGUSRIF",817,0) kill ^TMP("VPE","SELECT",$J) "RTN","TMGUSRIF",818,0) kill @ref "RTN","TMGUSRIF",819,0) "RTN","TMGUSRIF",820,0) Sl2Done "RTN","TMGUSRIF",821,0) quit "RTN","TMGUSRIF",822,0) "RTN","TMGUSRIF",823,0) "RTN","TMGUSRIF",824,0) "RTN","TMGUSRIF",825,0) "RTN","TMGUSRIF",826,0) Menu(Options,defChoice,UserRaw) "RTN","TMGUSRIF",827,0) ;"Purpose: to provide a simple menuing system "RTN","TMGUSRIF",828,0) ;"Input: Options -- PASS BY REFERENCE "RTN","TMGUSRIF",829,0) ;" Format: "RTN","TMGUSRIF",830,0) ;" Options(0)=Header Text <--- optional, default is MENU "RTN","TMGUSRIF",831,0) ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue <-- _$C(9)_ReturnValue OPTIONAL, default is DispNumber "RTN","TMGUSRIF",832,0) ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue "RTN","TMGUSRIF",833,0) ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue "RTN","TMGUSRIF",834,0) ;" defChoice: OPTIONAL, the default menu value "RTN","TMGUSRIF",835,0) ;" UserRaw : OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER. Returns users raw input "RTN","TMGUSRIF",836,0) ;"Results: The selected ReturnValue (or DispNumber if no ReturnValue provided), or ^ for abort "RTN","TMGUSRIF",837,0) "RTN","TMGUSRIF",838,0) new result set result="^" "RTN","TMGUSRIF",839,0) MNU1 "RTN","TMGUSRIF",840,0) write "====================================================",! "RTN","TMGUSRIF",841,0) write $get(Options(0),"MENU"),! "RTN","TMGUSRIF",842,0) write "====================================================",! "RTN","TMGUSRIF",843,0) write "Options:",! "RTN","TMGUSRIF",844,0) "RTN","TMGUSRIF",845,0) new s "RTN","TMGUSRIF",846,0) new DispNumber set DispNumber=$order(Options(0)) "RTN","TMGUSRIF",847,0) if DispNumber'="" for do quit:(DispNumber="") "RTN","TMGUSRIF",848,0) . set s=$get(Options(DispNumber)) "RTN","TMGUSRIF",849,0) . write " ",DispNumber,".",$char(9),$piece(s,$char(9),1),! "RTN","TMGUSRIF",850,0) . set DispNumber=$order(Options(DispNumber)) "RTN","TMGUSRIF",851,0) "RTN","TMGUSRIF",852,0) write "====================================================",!! "RTN","TMGUSRIF",853,0) "RTN","TMGUSRIF",854,0) set defChoice=$get(defChoice,"^") "RTN","TMGUSRIF",855,0) new input "RTN","TMGUSRIF",856,0) write "Enter selection (^ to abort): ",defChoice,"// " "RTN","TMGUSRIF",857,0) read input:$get(DTIME,3600),! "RTN","TMGUSRIF",858,0) if input="" set input=defChoice "RTN","TMGUSRIF",859,0) set UserRaw=input "RTN","TMGUSRIF",860,0) if input="^" goto MNUDone "RTN","TMGUSRIF",861,0) "RTN","TMGUSRIF",862,0) set s=$get(Options(input)) "RTN","TMGUSRIF",863,0) if s="" set s=$get(Options($$UP^XLFSTR(input))) "RTN","TMGUSRIF",864,0) ;"if s="" write "??",!! goto MNU1 "RTN","TMGUSRIF",865,0) set result=$piece(s,$char(9),2) "RTN","TMGUSRIF",866,0) if result="" set result=input "RTN","TMGUSRIF",867,0) "RTN","TMGUSRIF",868,0) MNUDone "RTN","TMGUSRIF",869,0) quit result "RTN","TMGUSRIF",870,0) "RTN","TMGUSRIF",871,0) "RTN","TMGUSRIF",872,0) ProgTest "RTN","TMGUSRIF",873,0) ;"Purpose: test progress bar. "RTN","TMGUSRIF",874,0) "RTN","TMGUSRIF",875,0) new i,u,max "RTN","TMGUSRIF",876,0) set max=1000 "RTN","TMGUSRIF",877,0) for i=0:1:max do "RTN","TMGUSRIF",878,0) . do ProgressBar(i,"%",1,max) "RTN","TMGUSRIF",879,0) "RTN","TMGUSRIF",880,0) for i=0:1:max do "RTN","TMGUSRIF",881,0) . do ProgressBar(i,"%",1,max) "RTN","TMGUSRIF",882,0) "RTN","TMGUSRIF",883,0) quit "RTN","TMGVPE") 0^88^B112139 "RTN","TMGVPE",1,0) TMGVPE ;TMG/kst/Simple VPE launcher ;03/25/06 "RTN","TMGVPE",2,0) ;;1.0;TMG-LIB;**1**;09/21/04 "RTN","TMGVPE",3,0) "RTN","TMGVPE",4,0) "RTN","TMGVPE",5,0) x ^%ZVEMS "RTN","TMGVPE",6,0) quit "RTN","TMGXDLG") 0^97^B61415 "RTN","TMGXDLG",1,0) TMGXDLG ;TMG/kst/M <--> Xdialog Interface ;03/25/06 "RTN","TMGXDLG",2,0) ;;1.0;TMG-LIB;**1**;09/21/04 "RTN","TMGXDLG",3,0) "RTN","TMGXDLG",4,0) ;"M <--> Xdialog Interface "RTN","TMGXDLG",5,0) "RTN","TMGXDLG",6,0) ;"+------------------------------------------------------------+ "RTN","TMGXDLG",7,0) ;"| O P E N - V I S T A C O D E |.. "RTN","TMGXDLG",8,0) ;"+------------------------------------------------------------+ : "RTN","TMGXDLG",9,0) ;"| | : "RTN","TMGXDLG",10,0) ;"| M <--> Xdialog Interface | : "RTN","TMGXDLG",11,0) ;"| | : "RTN","TMGXDLG",12,0) ;"| Kevin Toppenberg,MD | : "RTN","TMGXDLG",13,0) ;"| Started 9-21-04 | : "RTN","TMGXDLG",14,0) ;"| GNU License Applies | : "RTN","TMGXDLG",15,0) ;"| | : "RTN","TMGXDLG",16,0) ;"| Purpose: Linux command 'Xdialog' (and 'dialog') | : "RTN","TMGXDLG",17,0) ;"| provide a convenient graphic interface that | : "RTN","TMGXDLG",18,0) ;"| can be accessed in GT.M via the ZSYSTEM command | : "RTN","TMGXDLG",19,0) ;"| This library is a wrapper for Xdialog. | : "RTN","TMGXDLG",20,0) ;"| Note: Xdialog requires the X display system. This is a | : "RTN","TMGXDLG",21,0) ;"| true GIU interface. 'dialog' provides the same | : "RTN","TMGXDLG",22,0) ;"| functionality in a character-based environment | : "RTN","TMGXDLG",23,0) ;"| The command Xdialog should be in /usr/bin. If not, | : "RTN","TMGXDLG",24,0) ;"| it may simply be copied into place. | : "RTN","TMGXDLG",25,0) ;"| A good web site that documents Xdialog is: | : "RTN","TMGXDLG",26,0) ;"| http://xdialog.dyns.net/ and | : "RTN","TMGXDLG",27,0) ;"| http://thgodef.nerim.net/xdialog/doc/index.html | : "RTN","TMGXDLG",28,0) ;"| http://linuxgazette.net/101/sunil.html | : "RTN","TMGXDLG",29,0) ;"+------------------------------------------------------------+ : "RTN","TMGXDLG",30,0) ;" :............................................................: "RTN","TMGXDLG",31,0) "RTN","TMGXDLG",32,0) ;"Note: Some of the following names are longer than 8 characters. "RTN","TMGXDLG",33,0) ;" However, the first 8 characters are . You may leave "RTN","TMGXDLG",34,0) ;" off all characters > 8 -- but I put them in for 'beauty' "RTN","TMGXDLG",35,0) "RTN","TMGXDLG",36,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",37,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",38,0) "RTN","TMGXDLG",39,0) ;"Higher-level Interface (API) "RTN","TMGXDLG",40,0) ;"------------------------------- "RTN","TMGXDLG",41,0) "RTN","TMGXDLG",42,0) ;"SetupConsts() "RTN","TMGXDLG",43,0) ;"KillConsts() "RTN","TMGXDLG",44,0) ;"ChClrScr() "RTN","TMGXDLG",45,0) "RTN","TMGXDLG",46,0) ;"$$YesNo^TMGXDLG(Text,width,height) "RTN","TMGXDLG",47,0) ;"$$Msg^TMGXDLG(Title,Text,width,height,Modal,x,y) "RTN","TMGXDLG",48,0) ;"$$Info^TMGXDLG(Text,width,height,timeout,Modal,x,y) "RTN","TMGXDLG",49,0) ;"$$Edit^TMGXDLG(file,width,height,Results,x,y) "RTN","TMGXDLG",50,0) ;"$$Log^TMGXDLG(file,width,height,Modal,x,y) "RTN","TMGXDLG",51,0) ;"$$Text^TMGXDLG(file,width,height,Modal,x,y) "RTN","TMGXDLG",52,0) ;"$$Tail^TMGXDLG(file,width,height,Modal,x,y) "RTN","TMGXDLG",53,0) ;"$$Input^TMGXDLG(Title,width,height,InitText,Result,x,y) "RTN","TMGXDLG",54,0) ;"$$Input2^TMGXDLG(Title,width,height,Label1,Init1Text,Label2,Init2Text,Result2,x,y) "RTN","TMGXDLG",55,0) ;"$$Input3^TMGXDLG(Title,width,height,Label1,Init1Text,Label2,Init2Text,Label3,Init3Text,Result2,Result3,x,y) "RTN","TMGXDLG",56,0) ;"$$RadioList^TMGXDLG(Text,List,width,height,x,y) "RTN","TMGXDLG",57,0) ;"$$FileSel^TMGXDLG(Title,InitFile,width,height,x,y) "RTN","TMGXDLG",58,0) ;"$$DirSel^TMGXDLG(Title,InitDir,width,height,x,y) "RTN","TMGXDLG",59,0) ;"$$DateSel^TMGXDLG(Text,width,height,InitDay,InitMonth,InitYear,x,y) "RTN","TMGXDLG",60,0) ;"$$TimeSel^TMGXDLG(Text,width,height,InitHour,InitMinute,InitSecond,x,y) "RTN","TMGXDLG",61,0) ;"$$FontSel^TMGXDLG(InitFont,width,height,x,y) "RTN","TMGXDLG",62,0) ;"$$Combo^TMGXDLG(Text,width,height,List,x,y) "RTN","TMGXDLG",63,0) ;"$$Range^TMGXDLG(Text,width,height,min,max,init,x,y) "RTN","TMGXDLG",64,0) ;"$$Range2^TMGXDLG(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,Result2,x,y) "RTN","TMGXDLG",65,0) ;"$$Range3^TMGXDLG(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,label3,min3,max3,init3,Result2,Result3,x,y) "RTN","TMGXDLG",66,0) ;"$$Spin^TMGXDLG(Text,width,height,min,max,label,init,x,y) "RTN","TMGXDLG",67,0) ;"$$Spin2^TMGXDLG(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,Result2,x,y) "RTN","TMGXDLG",68,0) ;"$$Spin3^TMGXDLG(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,label3,min3,max3,init3,Result2,Result3,x,y) "RTN","TMGXDLG",69,0) "RTN","TMGXDLG",70,0) "RTN","TMGXDLG",71,0) "RTN","TMGXDLG",72,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",73,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",74,0) "RTN","TMGXDLG",75,0) "RTN","TMGXDLG",76,0) ;"Lower-level Interface (API) "RTN","TMGXDLG",77,0) ;"------------------------------- "RTN","TMGXDLG",78,0) ;"xyesno(Options,Results,Modal) "RTN","TMGXDLG",79,0) ;"xmsg(Options,Results,Modal) "RTN","TMGXDLG",80,0) ;"xinfo(Options,Results,Modal) "RTN","TMGXDLG",81,0) ;"xguage(Options,Results,Modal) "RTN","TMGXDLG",82,0) ;"xprogress(Options,Results,Modal) "RTN","TMGXDLG",83,0) ;"xinput(Options,Results,Modal) "RTN","TMGXDLG",84,0) ;"x2inputs(Options,Results,Modal) "RTN","TMGXDLG",85,0) ;"x3inputs(Options,Results,Modal) "RTN","TMGXDLG",86,0) ;"xcombo(Options,Results,Modal) "RTN","TMGXDLG",87,0) ;"xrange(Options,Results,Modal) "RTN","TMGXDLG",88,0) ;"x2range(Options,Results,Modal) "RTN","TMGXDLG",89,0) ;"x3range(Options,Results,Modal) "RTN","TMGXDLG",90,0) ;"xspin(Options,Results,Modal) "RTN","TMGXDLG",91,0) ;"x2spin(Options,Results,Modal) "RTN","TMGXDLG",92,0) ;"x3spin(Options,Results,Modal) "RTN","TMGXDLG",93,0) ;"xlog(Options,Results,Modal) "RTN","TMGXDLG",94,0) ;"xedit(Options,Results,Modal) "RTN","TMGXDLG",95,0) ;"xtext(Options,Results,Modal) "RTN","TMGXDLG",96,0) ;"xtail(Options,Results,Modal) "RTN","TMGXDLG",97,0) ;"xchecklist(Options,Results,Modal) "RTN","TMGXDLG",98,0) ;"xradiolist(Options,Results,Modal) "RTN","TMGXDLG",99,0) ;"xmenu(Options,Results,Modal) "RTN","TMGXDLG",100,0) ;"xtreeview(Options,Results,Modal) "RTN","TMGXDLG",101,0) ;"xfilesel(Options,Results,Modal) "RTN","TMGXDLG",102,0) ;"xdirsel(Options,Results,Modal) "RTN","TMGXDLG",103,0) ;"xcalendarsel(Options,Results,Modal) "RTN","TMGXDLG",104,0) ;"xtimesel(Options,Results,Modal) "RTN","TMGXDLG",105,0) ;"xbuildlist(Options,Results,Modal) "RTN","TMGXDLG",106,0) ;"xcolorsel(Options,Results,Modal) "RTN","TMGXDLG",107,0) ;"xfontsel(Options,Results,Modal) "RTN","TMGXDLG",108,0) "RTN","TMGXDLG",109,0) "RTN","TMGXDLG",110,0) ;"Expected format for Options: "RTN","TMGXDLG",111,0) "RTN","TMGXDLG",112,0) ;"The documentation for these options may be found at: "RTN","TMGXDLG",113,0) ;"http://thgodef.nerim.net/xdialog/doc/index.html "RTN","TMGXDLG",114,0) "RTN","TMGXDLG",115,0) ;"Options should be an array inthe following format: "RTN","TMGXDLG",116,0) ;" "RTN","TMGXDLG",117,0) ;" Options(xcCommon,xcWMClass)= "RTN","TMGXDLG",118,0) ;" Options(xcCommon,xcRxcFile)= "RTN","TMGXDLG",119,0) ;" Options(xcCommon,xcBackTitle)= "RTN","TMGXDLG",120,0) ;" Options(xcCommon,xcTitle"= "RTN","TMGXDLG",121,0) ;" Options(xcCommon,xcAllowClose)=1 } A. "RTN","TMGXDLG",122,0) ;" Options(xcCommon,xcNoClose)=1 } B. A & B are opposites "RTN","TMGXDLG",123,0) ;" Options(xcCommon,xcScreenCenter)=1 } A. "RTN","TMGXDLG",124,0) ;" Options(xcCommon,xcUnderMouse)=1 } B. "RTN","TMGXDLG",125,0) ;" Options(xcCommon,xcAutoPlacement)=1 } C. A,B & C are mutually exclusive options "RTN","TMGXDLG",126,0) ;" Options(xcCommon,xcCenter)=1 } A. "RTN","TMGXDLG",127,0) ;" Options(xcCommon,xcRight)=1 } B. "RTN","TMGXDLG",128,0) ;" Options(xcCommon,xcLeft)=1 } C. "RTN","TMGXDLG",129,0) ;" Options(xcCommon,xcFill)=1 } D. A,B,C & D are mutually exclusive options "RTN","TMGXDLG",130,0) ;" Options(xcCommon,xcNoWrap)=1 } A "RTN","TMGXDLG",131,0) ;" Options(xcCommon,xcWrap)=1 } B A & B are opposites "RTN","TMGXDLG",132,0) ;" Options(xcCommon,xcCRWrap)=1 } A. "RTN","TMGXDLG",133,0) ;" Options(xcCommon,xcNoCRWrap)=1 } B. A & B are opposites "RTN","TMGXDLG",134,0) ;" Options(xcCommon,xcStdErr)=1 } A. "RTN","TMGXDLG",135,0) ;" Options(xcCommon,xcStdOut)=1 } B. A & B are opposites "RTN","TMGXDLG",136,0) ;" Options(xcCommon,xcSeparator)=<character> } A. "RTN","TMGXDLG",137,0) ;" Options(xcCommon,xcSeparateOutput)=1 } B. A & B are opposites. "RTN","TMGXDLG",138,0) ;" Options(xcCommon,xcButtonsStyle)="default" or "icon" or "text" (only one of these three values) "RTN","TMGXDLG",139,0) ;" Options(xcTransient,xcFixedFont)=1 "RTN","TMGXDLG",140,0) ;" Options(xcTransient,xcPassword)=1 "RTN","TMGXDLG",141,0) ;" Options(xcTransient,xcEditable)=1 "RTN","TMGXDLG",142,0) ;" Options(xcTransient,xcTimeStamp)=1 } A. "RTN","TMGXDLG",143,0) ;" Options(xcTransient,xcDateStamp)=1 } B. A & B are mutually exclusive "RTN","TMGXDLG",144,0) ;" Options(xcTransient,xcReverse)=1 "RTN","TMGXDLG",145,0) ;" Options(xcTransient,xcKeepColors)=1 "RTN","TMGXDLG",146,0) ;" Options(xcTransient,xcInterval)=<timeout> "RTN","TMGXDLG",147,0) ;" Options(xcTransient,xcNotags)=1 "RTN","TMGXDLG",148,0) ;" Options(xcTransient,xxcItemHelp)=1 "RTN","TMGXDLG",149,0) ;" Options(xcTransient,xxcDefaultItem)=<tag> "RTN","TMGXDLG",150,0) ;" Options(xcTransient,xcIcon)=<xpm filename> "RTN","TMGXDLG",151,0) ;" Options(xcTransient,xcNook)=1 "RTN","TMGXDLG",152,0) ;" Options(xcTransient,xcNoCancel)=1 "RTN","TMGXDLG",153,0) ;" Options(xcTransient,xcNoButtons)=1 "RTN","TMGXDLG",154,0) ;" Options(xcTransient,xxcDefaultNo)=1 "RTN","TMGXDLG",155,0) ;" Options(xcTransient,xcWizard)=1 "RTN","TMGXDLG",156,0) ;" Options(xcTransient,xcHelp)=<help> "RTN","TMGXDLG",157,0) ;" Options(xcTransient,xcPrint)=<printer> "RTN","TMGXDLG",158,0) ;" Options(xcTransient,xcCheck)=<label [<status>]> "RTN","TMGXDLG",159,0) ;" Options(xcTransient,xcOKLabel)=<label> "RTN","TMGXDLG",160,0) ;" Options(xcTransient,xcCancelLabel)=<label> "RTN","TMGXDLG",161,0) ;" Options(xcTransient,xcBeep)=1 "RTN","TMGXDLG",162,0) ;" Options(xcTransient,xcBeepafter)=1 "RTN","TMGXDLG",163,0) ;" Options(xcTransient,xcBegin)= <Yorg Xorg> "RTN","TMGXDLG",164,0) ;" Options(xcTransient,xcIgnoreEOF)=1 "RTN","TMGXDLG",165,0) ;" Options(xcTransient,xcSmooth)=1 "RTN","TMGXDLG",166,0) ;" Options(xcBox,xcText)=<value> "RTN","TMGXDLG",167,0) ;" Options(xcBox,xcHeight)=<value> "RTN","TMGXDLG",168,0) ;" Options(xcBox,xcWidth)=<value> "RTN","TMGXDLG",169,0) ;" Options(xcBox,xcTimeOut)=<value> "RTN","TMGXDLG",170,0) ;" Options(xcBox,xcPercent)=<value> "RTN","TMGXDLG",171,0) ;" Options(xcBox,xxcMaxDots)=<value> "RTN","TMGXDLG",172,0) ;" Options(xcBox,xcMsgLen)=<value> "RTN","TMGXDLG",173,0) ;" Options(xcBox,xcInit)=<value> "RTN","TMGXDLG",174,0) ;" Options(xcBox,xcLabel,N)=<value> "RTN","TMGXDLG",175,0) ;" Options(xcBox,xcInit,N)=<value> "RTN","TMGXDLG",176,0) ;" Options(xcBox,xcMin,N)=<value> "RTN","TMGXDLG",177,0) ;" Options(xcBox,xcMax,N)=<value> "RTN","TMGXDLG",178,0) ;" Options(xcBox,xcDefault,N)=<value "RTN","TMGXDLG",179,0) ;" Options(xcBox,xcFile)=<value> "RTN","TMGXDLG",180,0) ;" Options(xcBox,xcDirectory)=<value> "RTN","TMGXDLG",181,0) ;" Options(xcBox,xcFontName)=<value> "RTN","TMGXDLG",182,0) ;" Options(xcBox,xcDay)=<value> "RTN","TMGXDLG",183,0) ;" Options(xcBox,xcMonth)=<value> "RTN","TMGXDLG",184,0) ;" Options(xcBox,xcYear)=<value> "RTN","TMGXDLG",185,0) ;" Options(xcBox,xcHours)=<value> "RTN","TMGXDLG",186,0) ;" Options(xcBox,xcMinutes)=<value> "RTN","TMGXDLG",187,0) ;" Options(xcBox,xcSeconds)=<value> "RTN","TMGXDLG",188,0) ;" Options(xcBox,xcTag,N)=<value> "RTN","TMGXDLG",189,0) ;" Options(xcBox,xcItem,N)=<value> "RTN","TMGXDLG",190,0) ;" Options(xcBox,xcHelp,N)=<value> "RTN","TMGXDLG",191,0) ;" Options(xcBox,xcStatus,N)=<value> {"on", "off", or "unavailable"} "RTN","TMGXDLG",192,0) ;" Options(xcBox,xcListHeight)=<value> "RTN","TMGXDLG",193,0) ;" Options(xcBox,xcItemdepth,N)=<value> "RTN","TMGXDLG",194,0) "RTN","TMGXDLG",195,0) ;"Notes: "RTN","TMGXDLG",196,0) ;" - Not all options will apply to all dialogs, but if the "RTN","TMGXDLG",197,0) ;" option is desired, it should be in the above format. "RTN","TMGXDLG",198,0) ;" - No syntax checking is performed. The options are simply "RTN","TMGXDLG",199,0) ;" passed to the Xdialog command in the proper order. "RTN","TMGXDLG",200,0) ;" - Everything below should be considered CASE-SENSITIVE. "RTN","TMGXDLG",201,0) ;" - Notice that the indexes used are constants (i.e. xcCommon) "RTN","TMGXDLG",202,0) ;" these are set up by SetupConsts(), and may later be killed "RTN","TMGXDLG",203,0) ;" via KillConsts(). Their use will avoid spelling errors "RTN","TMGXDLG",204,0) ;" resulting in a missed parameter. "RTN","TMGXDLG",205,0) "RTN","TMGXDLG",206,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",207,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",208,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",209,0) "RTN","TMGXDLG",210,0) "RTN","TMGXDLG",211,0) SetupConsts() "RTN","TMGXDLG",212,0) set vDialog="Xdialog" "RTN","TMGXDLG",213,0) set xcCommon="common" "RTN","TMGXDLG",214,0) set xcWMClass="wmclass" "RTN","TMGXDLG",215,0) set xcRxcFile="rxcFile" "RTN","TMGXDLG",216,0) set xcBackTitle="backtitle" "RTN","TMGXDLG",217,0) set xcTitle="title" "RTN","TMGXDLG",218,0) set xcAllowClose="allow-close" "RTN","TMGXDLG",219,0) set xcNoClose="no-close" "RTN","TMGXDLG",220,0) set xcScreenCenter="cscreen-center" "RTN","TMGXDLG",221,0) set xcUnderMouse="under-mouse" "RTN","TMGXDLG",222,0) set xcAutoPlacement="autoplacement" "RTN","TMGXDLG",223,0) set xcCenter="center" "RTN","TMGXDLG",224,0) set xcRight="right" "RTN","TMGXDLG",225,0) set xcLeft="left" "RTN","TMGXDLG",226,0) set xcFill="fill" "RTN","TMGXDLG",227,0) set xcNoWrap="no-wrap" "RTN","TMGXDLG",228,0) set xcWrap="wrap" "RTN","TMGXDLG",229,0) set xcCRWrap="cr-wrap" "RTN","TMGXDLG",230,0) set xcNoCRWrap="no-cr-wrap" "RTN","TMGXDLG",231,0) set xcStdErr="stderr" "RTN","TMGXDLG",232,0) set xcStdOut="stdout" "RTN","TMGXDLG",233,0) set xcSeparator="separator" "RTN","TMGXDLG",234,0) set xcSeparateOutput="separate-output" "RTN","TMGXDLG",235,0) set xcButtonsStyle="buttons-style" "RTN","TMGXDLG",236,0) set xcTransient="transient" "RTN","TMGXDLG",237,0) set xcFixedFont="fixed-font" "RTN","TMGXDLG",238,0) set xcPassword="password" "RTN","TMGXDLG",239,0) set xcEditable="editable" "RTN","TMGXDLG",240,0) set xcTimeStamp="time-stamp" "RTN","TMGXDLG",241,0) set xcDateStamp="date-stamp" "RTN","TMGXDLG",242,0) set xcReverse="reverse" "RTN","TMGXDLG",243,0) set xcKeepColors="keep-colors" "RTN","TMGXDLG",244,0) set xcInterval="interval" "RTN","TMGXDLG",245,0) set xcNotags="no-tags" "RTN","TMGXDLG",246,0) set xxcItemHelp="item-help" "RTN","TMGXDLG",247,0) set xxcDefaultItem="default-item" "RTN","TMGXDLG",248,0) set xcIcon="icon" "RTN","TMGXDLG",249,0) set xcNook="no-ok" "RTN","TMGXDLG",250,0) set xcNoCancel="no-cancel" "RTN","TMGXDLG",251,0) set xcNoButtons="no-buttons" "RTN","TMGXDLG",252,0) set xxcDefaultNo="default-no" "RTN","TMGXDLG",253,0) set xcWizard="wizard" "RTN","TMGXDLG",254,0) set xcHelp="help" "RTN","TMGXDLG",255,0) set xcPrint="print" "RTN","TMGXDLG",256,0) set xcCheck="check" "RTN","TMGXDLG",257,0) set xcOKLabel="ok-label" "RTN","TMGXDLG",258,0) set xcCancelLabel="cancel-label" "RTN","TMGXDLG",259,0) set xcBeep="beep" "RTN","TMGXDLG",260,0) set xcBeepafter="beep-after" "RTN","TMGXDLG",261,0) set xcBegin="begin" "RTN","TMGXDLG",262,0) set xcIgnoreEOF="ignore-eof" "RTN","TMGXDLG",263,0) set xcSmooth="smooth" "RTN","TMGXDLG",264,0) set xcBox="box" "RTN","TMGXDLG",265,0) set xcText="text" "RTN","TMGXDLG",266,0) set xcHeight="height" "RTN","TMGXDLG",267,0) set xcWidth="width" "RTN","TMGXDLG",268,0) set xcTimeOut="timeout" "RTN","TMGXDLG",269,0) set xcPercent="percent" "RTN","TMGXDLG",270,0) set xxcMaxDots="maxdots" "RTN","TMGXDLG",271,0) set xcMsgLen="msglen" "RTN","TMGXDLG",272,0) set xcInit="init" "RTN","TMGXDLG",273,0) set xcLabel="label" "RTN","TMGXDLG",274,0) set xcMin="min" "RTN","TMGXDLG",275,0) set xcMax="max" "RTN","TMGXDLG",276,0) set xcDefault="default" "RTN","TMGXDLG",277,0) set xcFile="file" "RTN","TMGXDLG",278,0) set xcDirectory="directory" "RTN","TMGXDLG",279,0) set xcFontName="font name" "RTN","TMGXDLG",280,0) set xcDay="day" "RTN","TMGXDLG",281,0) set xcMonth="month" "RTN","TMGXDLG",282,0) set xcYear="year" "RTN","TMGXDLG",283,0) set xcHours="hours" "RTN","TMGXDLG",284,0) set xcMinutes="minutes" "RTN","TMGXDLG",285,0) set xcSeconds="seconds" "RTN","TMGXDLG",286,0) set xcTag="tag" "RTN","TMGXDLG",287,0) set xcItem="item" "RTN","TMGXDLG",288,0) set xcHelp="help" "RTN","TMGXDLG",289,0) set xcStatus="status" "RTN","TMGXDLG",290,0) set xcListHeight="list height" "RTN","TMGXDLG",291,0) set xcItemdepth="item depth" "RTN","TMGXDLG",292,0) set xcCmdLine="command_line_params" "RTN","TMGXDLG",293,0) set xcCmdArray="Array" "RTN","TMGXDLG",294,0) set xcCmdMaxLine="Max_line" "RTN","TMGXDLG",295,0) set xcDlgResult="Dialog Result" "RTN","TMGXDLG",296,0) set xcDlgOutput="Dialog Output" "RTN","TMGXDLG",297,0) set xcModalMode=1 "RTN","TMGXDLG",298,0) set xcNonModal=0 "RTN","TMGXDLG",299,0) set xcOptional=1 "RTN","TMGXDLG",300,0) set xcNotOptional=0 "RTN","TMGXDLG",301,0) set xcAddQuote=1 "RTN","TMGXDLG",302,0) set xcNoQuote=0 "RTN","TMGXDLG",303,0) set mrYes=0 "RTN","TMGXDLG",304,0) set mrOK=0 "RTN","TMGXDLG",305,0) set mrNext=0 "RTN","TMGXDLG",306,0) set mrNo=1 "RTN","TMGXDLG",307,0) set mrCancel=1 "RTN","TMGXDLG",308,0) set mrHelp=2 "RTN","TMGXDLG",309,0) set mrPrev=3 "RTN","TMGXDLG",310,0) set mrError=255 "RTN","TMGXDLG",311,0) quit "RTN","TMGXDLG",312,0) "RTN","TMGXDLG",313,0) "RTN","TMGXDLG",314,0) KillConstants() "RTN","TMGXDLG",315,0) kill vDialog "RTN","TMGXDLG",316,0) kill xcCommon "RTN","TMGXDLG",317,0) kill xcWMClass "RTN","TMGXDLG",318,0) kill xcRxcFile "RTN","TMGXDLG",319,0) kill xcBackTitle "RTN","TMGXDLG",320,0) kill xcTitle "RTN","TMGXDLG",321,0) kill xcAllowClose "RTN","TMGXDLG",322,0) kill xcNoClose "RTN","TMGXDLG",323,0) kill xcScreenCenter "RTN","TMGXDLG",324,0) kill xcUnderMouse "RTN","TMGXDLG",325,0) kill xcAutoPlacement "RTN","TMGXDLG",326,0) kill xcCenter "RTN","TMGXDLG",327,0) kill xcRight "RTN","TMGXDLG",328,0) kill xcLeft "RTN","TMGXDLG",329,0) kill xcFill "RTN","TMGXDLG",330,0) kill xcNoWrap "RTN","TMGXDLG",331,0) kill xcWrap "RTN","TMGXDLG",332,0) kill xcCRWrap "RTN","TMGXDLG",333,0) kill xcNoCRWrap "RTN","TMGXDLG",334,0) kill xcStdErr "RTN","TMGXDLG",335,0) kill xcStdOut "RTN","TMGXDLG",336,0) kill xcSeparator "RTN","TMGXDLG",337,0) kill xcSeparateOutput "RTN","TMGXDLG",338,0) kill xcButtonsStyle "RTN","TMGXDLG",339,0) kill xcTransient "RTN","TMGXDLG",340,0) kill xcFixedFont "RTN","TMGXDLG",341,0) kill xcPassword "RTN","TMGXDLG",342,0) kill xcEditable "RTN","TMGXDLG",343,0) kill xcTimeStamp "RTN","TMGXDLG",344,0) kill xcDateStamp "RTN","TMGXDLG",345,0) kill xcReverse "RTN","TMGXDLG",346,0) kill xcKeepColors "RTN","TMGXDLG",347,0) kill xcInterval "RTN","TMGXDLG",348,0) kill xcNotags "RTN","TMGXDLG",349,0) kill xxcItemHelp "RTN","TMGXDLG",350,0) kill xxcDefaultItem "RTN","TMGXDLG",351,0) kill xcIcon "RTN","TMGXDLG",352,0) kill xcNook "RTN","TMGXDLG",353,0) kill xcNoCancel "RTN","TMGXDLG",354,0) kill xcNoButtons "RTN","TMGXDLG",355,0) kill xxcDefaultNo "RTN","TMGXDLG",356,0) kill xcWizard "RTN","TMGXDLG",357,0) kill xcHelp "RTN","TMGXDLG",358,0) kill xcPrint "RTN","TMGXDLG",359,0) kill xcCheck "RTN","TMGXDLG",360,0) kill xcOKLabel "RTN","TMGXDLG",361,0) kill xcCancelLabel "RTN","TMGXDLG",362,0) kill xcBeep "RTN","TMGXDLG",363,0) kill xcBeepafter "RTN","TMGXDLG",364,0) kill xcBegin "RTN","TMGXDLG",365,0) kill xcIgnoreEOF "RTN","TMGXDLG",366,0) kill xcSmooth "RTN","TMGXDLG",367,0) kill xcBox "RTN","TMGXDLG",368,0) kill xcText "RTN","TMGXDLG",369,0) kill xcHeight "RTN","TMGXDLG",370,0) kill xcWidth "RTN","TMGXDLG",371,0) kill xcTimeOut "RTN","TMGXDLG",372,0) kill xcPercent "RTN","TMGXDLG",373,0) kill xxcMaxDots "RTN","TMGXDLG",374,0) kill xcMsgLen "RTN","TMGXDLG",375,0) kill xcLabel "RTN","TMGXDLG",376,0) kill xcInit "RTN","TMGXDLG",377,0) kill xcMin "RTN","TMGXDLG",378,0) kill xcMax "RTN","TMGXDLG",379,0) kill xcDefault "RTN","TMGXDLG",380,0) kill xcFile "RTN","TMGXDLG",381,0) kill xcDirectory "RTN","TMGXDLG",382,0) kill xcFontName "RTN","TMGXDLG",383,0) kill xcDay "RTN","TMGXDLG",384,0) kill xcMonth "RTN","TMGXDLG",385,0) kill xcYear "RTN","TMGXDLG",386,0) kill xcHours "RTN","TMGXDLG",387,0) kill xcMinutes "RTN","TMGXDLG",388,0) kill xcSeconds "RTN","TMGXDLG",389,0) kill xcTag "RTN","TMGXDLG",390,0) kill xcItem "RTN","TMGXDLG",391,0) kill xcHelp "RTN","TMGXDLG",392,0) kill xcStatus "RTN","TMGXDLG",393,0) kill xcListHeight "RTN","TMGXDLG",394,0) kill xcItemdepth "RTN","TMGXDLG",395,0) kill xcCmdLine "RTN","TMGXDLG",396,0) kill xcCmdMaxLine "RTN","TMGXDLG",397,0) kill xcCmdArray "RTN","TMGXDLG",398,0) kill xcDlgResult "RTN","TMGXDLG",399,0) kill xcModalMode "RTN","TMGXDLG",400,0) kill xcNonModal "RTN","TMGXDLG",401,0) kill xcOptional "RTN","TMGXDLG",402,0) kill xcNotOptional "RTN","TMGXDLG",403,0) kill xcAddQuote "RTN","TMGXDLG",404,0) kill xcNoQuote "RTN","TMGXDLG",405,0) kill xcDlgOutput "RTN","TMGXDLG",406,0) kill mrYes "RTN","TMGXDLG",407,0) kill mrOK "RTN","TMGXDLG",408,0) kill mrNo "RTN","TMGXDLG",409,0) kill mrAbort "RTN","TMGXDLG",410,0) kill mrCancel "RTN","TMGXDLG",411,0) kill mrNext "RTN","TMGXDLG",412,0) kill mrHelp "RTN","TMGXDLG",413,0) kill mrPrev "RTN","TMGXDLG",414,0) kill mrError "RTN","TMGXDLG",415,0) "RTN","TMGXDLG",416,0) quit "RTN","TMGXDLG",417,0) "RTN","TMGXDLG",418,0) SetGUI(UseGUI) "RTN","TMGXDLG",419,0) ;"For those who do not have an X system (i.e. a graphic display for unix/linux) "RTN","TMGXDLG",420,0) ;" then there is a backup plan that can do most of these functions "RTN","TMGXDLG",421,0) ;" on a text display (cool, eh?) "RTN","TMGXDLG",422,0) ;"Input: UseGUI -- if 1 (the default), then the graphic method is used "RTN","TMGXDLG",423,0) ;" if 0, then the character (text drawing) based method is used "RTN","TMGXDLG",424,0) "RTN","TMGXDLG",425,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",426,0) "RTN","TMGXDLG",427,0) set UseGUI=$get(UseGUI,1) "RTN","TMGXDLG",428,0) if UseGUI=0 set vDialog="dialog" "RTN","TMGXDLG",429,0) else set vDialog="Xdialog" "RTN","TMGXDLG",430,0) quit "RTN","TMGXDLG",431,0) "RTN","TMGXDLG",432,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",433,0) "RTN","TMGXDLG",434,0) YesNo(Text,width,height,x,y) "RTN","TMGXDLG",435,0) ;"Purpose: To provide an easier access to xyesnot "RTN","TMGXDLG",436,0) ;"Input: Text to display "RTN","TMGXDLG",437,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",438,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",439,0) ;"Output: (none) "RTN","TMGXDLG",440,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",441,0) ;"Notes: (none) "RTN","TMGXDLG",442,0) "RTN","TMGXDLG",443,0) new Options "RTN","TMGXDLG",444,0) new Results,result "RTN","TMGXDLG",445,0) "RTN","TMGXDLG",446,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",447,0) "RTN","TMGXDLG",448,0) set Options(xcBox,xcText)=Text "RTN","TMGXDLG",449,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",450,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",451,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",452,0) "RTN","TMGXDLG",453,0) do xyesno(.Options,.Results,xcModalMode) ;"Force won't return until dialog closed. "RTN","TMGXDLG",454,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",455,0) "RTN","TMGXDLG",456,0) quit result; "RTN","TMGXDLG",457,0) "RTN","TMGXDLG",458,0) "RTN","TMGXDLG",459,0) xyesno(Options,Results,Modal) "RTN","TMGXDLG",460,0) ;" --yesno <text> <height> <width> "RTN","TMGXDLG",461,0) new Added "RTN","TMGXDLG",462,0) "RTN","TMGXDLG",463,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",464,0) do SetCommons(.Options) "RTN","TMGXDLG",465,0) do SetTrans(.Options) "RTN","TMGXDLG",466,0) do ParamTextAdd(.Options," --yesno ") "RTN","TMGXDLG",467,0) "RTN","TMGXDLG",468,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",469,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",470,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",471,0) "RTN","TMGXDLG",472,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",473,0) "RTN","TMGXDLG",474,0) quit "RTN","TMGXDLG",475,0) "RTN","TMGXDLG",476,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",477,0) "RTN","TMGXDLG",478,0) Msg(Title,Text,width,height,Modal,x,y) "RTN","TMGXDLG",479,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",480,0) ;"Input: Text to display "RTN","TMGXDLG",481,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",482,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",483,0) ;" Modal: if true, function does not return until dialog is closed. "RTN","TMGXDLG",484,0) ;" if false, function returns immediately, and functions do NOT "RTN","TMGXDLG",485,0) ;" reflect the user's button press. "RTN","TMGXDLG",486,0) ;"Output: (none) "RTN","TMGXDLG",487,0) ;"Results: Returns results of box closure (see Modal note above) "RTN","TMGXDLG",488,0) ;"Notes: (none) "RTN","TMGXDLG",489,0) "RTN","TMGXDLG",490,0) new Options "RTN","TMGXDLG",491,0) new Results,result "RTN","TMGXDLG",492,0) "RTN","TMGXDLG",493,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",494,0) if $data(Title) set Options(xcCommon,xcTitle)=Title "RTN","TMGXDLG",495,0) set Options(xcBox,xcText)=Text "RTN","TMGXDLG",496,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",497,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",498,0) set Modal=$get(Modal,xcNonModal) "RTN","TMGXDLG",499,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",500,0) "RTN","TMGXDLG",501,0) do xmsg(.Options,.Results,Modal) "RTN","TMGXDLG",502,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",503,0) "RTN","TMGXDLG",504,0) quit result; "RTN","TMGXDLG",505,0) "RTN","TMGXDLG",506,0) "RTN","TMGXDLG",507,0) xmsg(Options,Results,Modal) "RTN","TMGXDLG",508,0) ;" --msgbox <text> <height> <width> "RTN","TMGXDLG",509,0) new Added "RTN","TMGXDLG",510,0) "RTN","TMGXDLG",511,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",512,0) do SetCommons(.Options) "RTN","TMGXDLG",513,0) do SetTrans(.Options) "RTN","TMGXDLG",514,0) do ParamTextAdd(.Options," --msgbox ") "RTN","TMGXDLG",515,0) "RTN","TMGXDLG",516,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",517,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",518,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",519,0) "RTN","TMGXDLG",520,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",521,0) "RTN","TMGXDLG",522,0) quit "RTN","TMGXDLG",523,0) "RTN","TMGXDLG",524,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",525,0) "RTN","TMGXDLG",526,0) Info(Text,width,height,timeout,Modal,x,y) "RTN","TMGXDLG",527,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",528,0) ;"Input: Text to display "RTN","TMGXDLG",529,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",530,0) ;" [timeout]: time (in sec) delay until box automatically closes. "RTN","TMGXDLG",531,0) ;" OPTIONAL--default=1 "RTN","TMGXDLG",532,0) ;" [Modal]: if true, function does not return until dialog is closed. "RTN","TMGXDLG",533,0) ;" if false, function returns immediately, and functions do NOT "RTN","TMGXDLG",534,0) ;" reflect the user's button press. OPTIONAL -- default=xcNonModal "RTN","TMGXDLG",535,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",536,0) ;"Output: (none) "RTN","TMGXDLG",537,0) ;"Results: Returns results of box closure (see Modal note above) "RTN","TMGXDLG",538,0) ;"Notes: (none) "RTN","TMGXDLG",539,0) "RTN","TMGXDLG",540,0) new Options "RTN","TMGXDLG",541,0) new Results,result "RTN","TMGXDLG",542,0) "RTN","TMGXDLG",543,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",544,0) "RTN","TMGXDLG",545,0) set Options(xcBox,xcText)=Text "RTN","TMGXDLG",546,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",547,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",548,0) set Modal=$get(Modal,xcNonModal) "RTN","TMGXDLG",549,0) if $data(timeout) set Options(xcBox,xcTimeOut)=timeout*1000 "RTN","TMGXDLG",550,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",551,0) "RTN","TMGXDLG",552,0) do xinfo(.Options,.Results,Modal) "RTN","TMGXDLG",553,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",554,0) "RTN","TMGXDLG",555,0) quit result; "RTN","TMGXDLG",556,0) "RTN","TMGXDLG",557,0) "RTN","TMGXDLG",558,0) xinfo(Options,Results,Modal) "RTN","TMGXDLG",559,0) ;" --infobox <text> <height> <width> [<timeout>] "RTN","TMGXDLG",560,0) new Added "RTN","TMGXDLG",561,0) "RTN","TMGXDLG",562,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",563,0) do SetCommons(.Options) "RTN","TMGXDLG",564,0) do SetTrans(.Options) "RTN","TMGXDLG",565,0) do ParamTextAdd(.Options," --infobox ") "RTN","TMGXDLG",566,0) "RTN","TMGXDLG",567,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",568,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",569,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",570,0) set Added=$$AddParam(.Options,,xcTimeOut,1) "RTN","TMGXDLG",571,0) "RTN","TMGXDLG",572,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",573,0) "RTN","TMGXDLG",574,0) quit "RTN","TMGXDLG",575,0) "RTN","TMGXDLG",576,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",577,0) ;"NOT WORKING -- SEE NOTES ON GuageUpdate below... "RTN","TMGXDLG",578,0) "RTN","TMGXDLG",579,0) Guage(Text,width,height,Percent,x,y) "RTN","TMGXDLG",580,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",581,0) ;" This is called to first display a guage dialog. "RTN","TMGXDLG",582,0) ;"Input: Text to display "RTN","TMGXDLG",583,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",584,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",585,0) ;" Percent -- Percentage of progress bar to show "RTN","TMGXDLG",586,0) ;"Output: (none) "RTN","TMGXDLG",587,0) ;"Results: Returns a handle that is used in GuageUpdate "RTN","TMGXDLG",588,0) ;"Notes: Box is left open unless Percent is > 100% "RTN","TMGXDLG",589,0) ;"NOTICE: This function is not working. "RTN","TMGXDLG",590,0) new Options "RTN","TMGXDLG",591,0) new Results,result "RTN","TMGXDLG",592,0) "RTN","TMGXDLG",593,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",594,0) "RTN","TMGXDLG",595,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",596,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",597,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",598,0) set Options(xcBox,xcPercent)=$get(Percent,0) "RTN","TMGXDLG",599,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",600,0) "RTN","TMGXDLG",601,0) do xguage(.Options,.Results,xcNonModal) ;"note: Xdialog will show box as non-modal regardless (I think) "RTN","TMGXDLG",602,0) set result=$get(Text)_"^"_$get(height)_"^"_$get(width) ;"This will be used as a handle. "RTN","TMGXDLG",603,0) "RTN","TMGXDLG",604,0) quit result; "RTN","TMGXDLG",605,0) "RTN","TMGXDLG",606,0) GuageUpdate(Handle,Percent) "RTN","TMGXDLG",607,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",608,0) ;" This is called to update the percentage on an existing form. "RTN","TMGXDLG",609,0) ;"Input: Handle -- the handle returned from original call to Guage "RTN","TMGXDLG",610,0) ;" Percent -- Percentage of progress bar to show "RTN","TMGXDLG",611,0) ;"Output: (none) "RTN","TMGXDLG",612,0) ;"Results: 'StillActive' i.e. 1: box still open. 0:box closed "RTN","TMGXDLG",613,0) ;"Notes: Box is left open unless Percent is > 100% "RTN","TMGXDLG",614,0) ;"NOTICE: This function is not working. To update a guage, the dialog is setup to accept new values "RTN","TMGXDLG",615,0) ;" on stdin. I'm not sure how to do this from inside M.... "RTN","TMGXDLG",616,0) ;" Perhaps I could redirect stdin to a file, then write values out to that file... "RTN","TMGXDLG",617,0) ;" However, when EOF is reached, then box is closed.... "RTN","TMGXDLG",618,0) "RTN","TMGXDLG",619,0) new Text "RTN","TMGXDLG",620,0) new height "RTN","TMGXDLG",621,0) new width "RTN","TMGXDLG",622,0) set Handle=$get(Handle) "RTN","TMGXDLG",623,0) set Percent=$get(Percent) "RTN","TMGXDLG",624,0) "RTN","TMGXDLG",625,0) set Text=$piece(Handle,"^",1) "RTN","TMGXDLG",626,0) set height=$piece(Handle,"^",2) "RTN","TMGXDLG",627,0) set width=$piece(Handle,"^",3) "RTN","TMGXDLG",628,0) "RTN","TMGXDLG",629,0) new dump "RTN","TMGXDLG",630,0) set dump=$$Guage(Text,width,height,Percent) "RTN","TMGXDLG",631,0) "RTN","TMGXDLG",632,0) quit '(Percent>100) "RTN","TMGXDLG",633,0) "RTN","TMGXDLG",634,0) "RTN","TMGXDLG",635,0) xguage(Options,Results,Modal) "RTN","TMGXDLG",636,0) ;" --gauge <text> <height> <width> [<percent>] "RTN","TMGXDLG",637,0) new Added "RTN","TMGXDLG",638,0) "RTN","TMGXDLG",639,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",640,0) do SetCommons(.Options) "RTN","TMGXDLG",641,0) do SetTrans(.Options) "RTN","TMGXDLG",642,0) do ParamTextAdd(.Options," --gauge ") "RTN","TMGXDLG",643,0) "RTN","TMGXDLG",644,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",645,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",646,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",647,0) set Added=$$AddParam(.Options,,xcPercent) "RTN","TMGXDLG",648,0) "RTN","TMGXDLG",649,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",650,0) "RTN","TMGXDLG",651,0) quit "RTN","TMGXDLG",652,0) "RTN","TMGXDLG",653,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",654,0) ;"TO BE COMPLETED "RTN","TMGXDLG",655,0) ;"Note: I will have the same problems with this function as I did with Guage... "RTN","TMGXDLG",656,0) ;" So for now, I WON'T IMPLEMENT THIS... "RTN","TMGXDLG",657,0) "RTN","TMGXDLG",658,0) xprogress(Options,Results,Modal) "RTN","TMGXDLG",659,0) ;"Purpose: "RTN","TMGXDLG",660,0) ;"Input: "RTN","TMGXDLG",661,0) ;"Output: "RTN","TMGXDLG",662,0) ;"Results: "RTN","TMGXDLG",663,0) ;"Notes: "RTN","TMGXDLG",664,0) ;" --progress <text> <height> <width> [<maxdots> [[-]<msglen>]] "RTN","TMGXDLG",665,0) "RTN","TMGXDLG",666,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",667,0) Input(Title,width,height,InitText,Result,x,y) "RTN","TMGXDLG",668,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",669,0) ;"Input: Title -- text of input prompt to display "RTN","TMGXDLG",670,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",671,0) ;" InitText -- default value [optional] "RTN","TMGXDLG",672,0) ;" Result -- a variable to put input into for return. PASS BY REFERENCE "RTN","TMGXDLG",673,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",674,0) ;"Output: The user input value is return in Result "RTN","TMGXDLG",675,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",676,0) ;"Notes: (none) "RTN","TMGXDLG",677,0) "RTN","TMGXDLG",678,0) new Options "RTN","TMGXDLG",679,0) new Results,result "RTN","TMGXDLG",680,0) "RTN","TMGXDLG",681,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",682,0) "RTN","TMGXDLG",683,0) set Options(xcBox,xcText)=$get(Title) "RTN","TMGXDLG",684,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",685,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",686,0) if $data(InitText) set Options(xcBox,xcInit)=InitText "RTN","TMGXDLG",687,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",688,0) "RTN","TMGXDLG",689,0) do xinput(.Options,.Results,xcModalMode) "RTN","TMGXDLG",690,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",691,0) "RTN","TMGXDLG",692,0) ;"zwr Results(*) "RTN","TMGXDLG",693,0) "RTN","TMGXDLG",694,0) set Result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",695,0) "RTN","TMGXDLG",696,0) quit result; "RTN","TMGXDLG",697,0) "RTN","TMGXDLG",698,0) xinput(Options,Results,Modal) "RTN","TMGXDLG",699,0) ;" --inputbox <text> <height> <width> [<init>] "RTN","TMGXDLG",700,0) "RTN","TMGXDLG",701,0) new Added "RTN","TMGXDLG",702,0) "RTN","TMGXDLG",703,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",704,0) do SetCommons(.Options) "RTN","TMGXDLG",705,0) do SetTrans(.Options) "RTN","TMGXDLG",706,0) do ParamTextAdd(.Options," --inputbox ") "RTN","TMGXDLG",707,0) "RTN","TMGXDLG",708,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",709,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",710,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",711,0) set Added=$$AddParam(.Options,,xcInit) "RTN","TMGXDLG",712,0) "RTN","TMGXDLG",713,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",714,0) "RTN","TMGXDLG",715,0) quit "RTN","TMGXDLG",716,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",717,0) Input2(Title,width,height,Label1,Init1Text,Label2,Init2Text,Result1,Result2,x,y) "RTN","TMGXDLG",718,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",719,0) ;"Input: Title -- text of input prompt to display "RTN","TMGXDLG",720,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",721,0) ;" Label1 -- text of label for input 1 [optional] "RTN","TMGXDLG",722,0) ;" Init1Text -- default value [optional] "RTN","TMGXDLG",723,0) ;" Label2 -- text of label for input 2 [optional] "RTN","TMGXDLG",724,0) ;" Init2Text -- default value [optional] "RTN","TMGXDLG",725,0) ;" Result1 -- a variable to put first input into for return. PASS BY REFERENCE "RTN","TMGXDLG",726,0) ;" Result2 -- a variable to put second input into for return. PASS BY REFERENCE "RTN","TMGXDLG",727,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",728,0) ;"Output: The user input value is return in Result1 "RTN","TMGXDLG",729,0) ;" result of 2nd user-input put into Result2 "RTN","TMGXDLG",730,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",731,0) ;"Notes: (none) "RTN","TMGXDLG",732,0) "RTN","TMGXDLG",733,0) new Options "RTN","TMGXDLG",734,0) new Results,result "RTN","TMGXDLG",735,0) "RTN","TMGXDLG",736,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",737,0) "RTN","TMGXDLG",738,0) set Options(xcCommon,xcSeparator)="^" "RTN","TMGXDLG",739,0) set Options(xcBox,xcText)=$get(Title) "RTN","TMGXDLG",740,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",741,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",742,0) set Options(xcBox,xcLabel,1)=$get(Label1," ") "RTN","TMGXDLG",743,0) set Options(xcBox,xcInit,1)=$get(Init1Text," ") "RTN","TMGXDLG",744,0) set Options(xcBox,xcLabel,2)=$get(Label2," ") "RTN","TMGXDLG",745,0) set Options(xcBox,xcInit,2)=$get(Init2Text," ") "RTN","TMGXDLG",746,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",747,0) "RTN","TMGXDLG",748,0) do x2inputs(.Options,.Results,xcModalMode) "RTN","TMGXDLG",749,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",750,0) "RTN","TMGXDLG",751,0) set Result1=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",752,0) set Result2=$get(Results(xcDlgOutput,1)) "RTN","TMGXDLG",753,0) "RTN","TMGXDLG",754,0) quit result; "RTN","TMGXDLG",755,0) "RTN","TMGXDLG",756,0) "RTN","TMGXDLG",757,0) x2inputs(Options,Results,Modal) "RTN","TMGXDLG",758,0) ;" --2inputsbox <text> <height> <width> <label1> <init1> <label2> <init2> "RTN","TMGXDLG",759,0) new Added "RTN","TMGXDLG",760,0) "RTN","TMGXDLG",761,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",762,0) do SetCommons(.Options) "RTN","TMGXDLG",763,0) do SetTrans(.Options) "RTN","TMGXDLG",764,0) do ParamTextAdd(.Options," --2inputsbox ") "RTN","TMGXDLG",765,0) "RTN","TMGXDLG",766,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",767,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",768,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",769,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",770,0) set Added=$$AddParam(.Options,1,xcInit,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",771,0) set Added=$$AddParam(.Options,2,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",772,0) set Added=$$AddParam(.Options,2,xcInit,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",773,0) "RTN","TMGXDLG",774,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",775,0) "RTN","TMGXDLG",776,0) quit "RTN","TMGXDLG",777,0) "RTN","TMGXDLG",778,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",779,0) Input3(Title,width,height,Label1,Init1Text,Label2,Init2Text,Label3,Init3Text,Result1,Result2,Result3,x,y) "RTN","TMGXDLG",780,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",781,0) ;"Input: Title -- text of input prompt to display "RTN","TMGXDLG",782,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",783,0) ;" Label1 -- text of label for input 1 "RTN","TMGXDLG",784,0) ;" Init1Text -- default value "RTN","TMGXDLG",785,0) ;" Label2 -- text of label for input 2 "RTN","TMGXDLG",786,0) ;" Init2Text -- default value "RTN","TMGXDLG",787,0) ;" Label3 -- text of label for input 3 "RTN","TMGXDLG",788,0) ;" Init3Text -- default value "RTN","TMGXDLG",789,0) ;" Result1 -- a variable to put first input into for return. PASS BY REFERENCE "RTN","TMGXDLG",790,0) ;" Result2 -- a variable to put second input into for return. PASS BY REFERENCE "RTN","TMGXDLG",791,0) ;" Result3 -- a variable to put third input into for return. PASS BY REFERENCE "RTN","TMGXDLG",792,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",793,0) ;"Output: The user input value is return in Result1 "RTN","TMGXDLG",794,0) ;" result of 2nd user-input put into Result2 "RTN","TMGXDLG",795,0) ;" result of 3rd user-input put into Result3 "RTN","TMGXDLG",796,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",797,0) ;"Notes: (none) "RTN","TMGXDLG",798,0) "RTN","TMGXDLG",799,0) new Options "RTN","TMGXDLG",800,0) new Results,result "RTN","TMGXDLG",801,0) "RTN","TMGXDLG",802,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",803,0) "RTN","TMGXDLG",804,0) set Options(xcCommon,xcSeparator)="^" "RTN","TMGXDLG",805,0) set Options(xcBox,xcText)=$get(Title) "RTN","TMGXDLG",806,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",807,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",808,0) set Options(xcBox,xcLabel,1)=$get(Label1," ") "RTN","TMGXDLG",809,0) set Options(xcBox,xcInit,1)=$get(Init1Text," ") "RTN","TMGXDLG",810,0) set Options(xcBox,xcLabel,2)=$get(Label2," ") "RTN","TMGXDLG",811,0) set Options(xcBox,xcInit,2)=$get(Init2Text," ") "RTN","TMGXDLG",812,0) set Options(xcBox,xcLabel,3)=$get(Label3," ") "RTN","TMGXDLG",813,0) set Options(xcBox,xcInit,3)=$get(Init3Text," ") "RTN","TMGXDLG",814,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",815,0) "RTN","TMGXDLG",816,0) do x3inputs(.Options,.Results,xcModalMode) "RTN","TMGXDLG",817,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",818,0) "RTN","TMGXDLG",819,0) set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",820,0) set Result2=$get(Results(xcDlgOutput,1)) "RTN","TMGXDLG",821,0) set Result3=$get(Results(xcDlgOutput,2)) "RTN","TMGXDLG",822,0) "RTN","TMGXDLG",823,0) quit result; "RTN","TMGXDLG",824,0) "RTN","TMGXDLG",825,0) "RTN","TMGXDLG",826,0) x3inputs(Options,Results,Modal) "RTN","TMGXDLG",827,0) ;" --3inputsbox <text> <height> <width> <label1> <init1> <label2> <init2> <label3> <init3> "RTN","TMGXDLG",828,0) new Added "RTN","TMGXDLG",829,0) "RTN","TMGXDLG",830,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",831,0) do SetCommons(.Options) "RTN","TMGXDLG",832,0) do SetTrans(.Options) "RTN","TMGXDLG",833,0) do ParamTextAdd(.Options," --3inputsbox ") "RTN","TMGXDLG",834,0) "RTN","TMGXDLG",835,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",836,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",837,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",838,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",839,0) set Added=$$AddParam(.Options,1,xcInit,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",840,0) set Added=$$AddParam(.Options,2,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",841,0) set Added=$$AddParam(.Options,2,xcInit,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",842,0) set Added=$$AddParam(.Options,3,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",843,0) set Added=$$AddParam(.Options,3,xcInit,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",844,0) "RTN","TMGXDLG",845,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",846,0) "RTN","TMGXDLG",847,0) quit "RTN","TMGXDLG",848,0) "RTN","TMGXDLG",849,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",850,0) Combo(Text,width,height,List,x,y) "RTN","TMGXDLG",851,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",852,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",853,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",854,0) ;" List -- Best if passed by reference. Holds list of options to be displayed as follows: "RTN","TMGXDLG",855,0) ;" List(1)=<Selection Option> "RTN","TMGXDLG",856,0) ;" List(2)=<Selection Option> "RTN","TMGXDLG",857,0) ;" List(3)=<Selection Option> "RTN","TMGXDLG",858,0) ;" ... etc up to any number N "RTN","TMGXDLG",859,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",860,0) ;"Output: (none) "RTN","TMGXDLG",861,0) ;"Results: Returns text of selected option. "RTN","TMGXDLG",862,0) ;"Notes: (none) "RTN","TMGXDLG",863,0) "RTN","TMGXDLG",864,0) new Options "RTN","TMGXDLG",865,0) new Results "RTN","TMGXDLG",866,0) set result="" "RTN","TMGXDLG",867,0) new i,Done "RTN","TMGXDLG",868,0) new status,help "RTN","TMGXDLG",869,0) "RTN","TMGXDLG",870,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",871,0) "RTN","TMGXDLG",872,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",873,0) "RTN","TMGXDLG",874,0) set Done=0 "RTN","TMGXDLG",875,0) for i=1:1 do quit:Done "RTN","TMGXDLG",876,0) . if $data(List(i))=0 set Done=1 quit "RTN","TMGXDLG",877,0) . set Options(xcBox,xcItem,i)=$get(List(i)) "RTN","TMGXDLG",878,0) "RTN","TMGXDLG",879,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",880,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",881,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",882,0) "RTN","TMGXDLG",883,0) do xcombo(.Options,.Results,xcModalMode) "RTN","TMGXDLG",884,0) "RTN","TMGXDLG",885,0) set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",886,0) quit result; "RTN","TMGXDLG",887,0) "RTN","TMGXDLG",888,0) "RTN","TMGXDLG",889,0) xcombo(Options,Results,Modal) "RTN","TMGXDLG",890,0) ;" --combobox <text> <height> <width> <item1> ... <itemN> "RTN","TMGXDLG",891,0) new Added,GroupAdded "RTN","TMGXDLG",892,0) new N "RTN","TMGXDLG",893,0) "RTN","TMGXDLG",894,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",895,0) do SetCommons(.Options) "RTN","TMGXDLG",896,0) do SetTrans(.Options) "RTN","TMGXDLG",897,0) do ParamTextAdd(.Options," --combobox ") "RTN","TMGXDLG",898,0) "RTN","TMGXDLG",899,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",900,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",901,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",902,0) set N=1 "RTN","TMGXDLG",903,0) xcl1 if $data(Options(xcBox,xcItem,N))=0 goto xcl2 "RTN","TMGXDLG",904,0) set GroupAdded=$$AddParam(.Options,N,xcItem,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",905,0) if GroupAdded=0 goto xcl2 "RTN","TMGXDLG",906,0) set N=N+1 goto xcl1 "RTN","TMGXDLG",907,0) xcl2 "RTN","TMGXDLG",908,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",909,0) "RTN","TMGXDLG",910,0) quit "RTN","TMGXDLG",911,0) "RTN","TMGXDLG",912,0) "RTN","TMGXDLG",913,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",914,0) Range(Text,width,height,min,max,init,x,y) "RTN","TMGXDLG",915,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",916,0) ;" A range dialog presents a horizontal slider bar to user "RTN","TMGXDLG",917,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",918,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",919,0) ;" min -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",920,0) ;" max -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",921,0) ;" init -- the initial input value -- (default = 50) "RTN","TMGXDLG",922,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",923,0) ;"Output: (none) "RTN","TMGXDLG",924,0) ;"Results: Returns input value "RTN","TMGXDLG",925,0) ;"Notes: (none) "RTN","TMGXDLG",926,0) "RTN","TMGXDLG",927,0) new Options "RTN","TMGXDLG",928,0) new Results,result "RTN","TMGXDLG",929,0) "RTN","TMGXDLG",930,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",931,0) "RTN","TMGXDLG",932,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",933,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",934,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",935,0) set Options(xcBox,xcMin,1)=$get(min,0) "RTN","TMGXDLG",936,0) set Options(xcBox,xcMax,1)=$get(max,100) "RTN","TMGXDLG",937,0) set Options(xcBox,xcDefault,1)=$get(init,50) "RTN","TMGXDLG",938,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",939,0) "RTN","TMGXDLG",940,0) do xrange(.Options,.Results,xcModalMode) "RTN","TMGXDLG",941,0) "RTN","TMGXDLG",942,0) set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",943,0) "RTN","TMGXDLG",944,0) quit result; "RTN","TMGXDLG",945,0) "RTN","TMGXDLG",946,0) "RTN","TMGXDLG",947,0) xrange(Options,Results,Modal) "RTN","TMGXDLG",948,0) ;" --rangebox <text> <height> <width> <min value> <max value> [<default value>] "RTN","TMGXDLG",949,0) new Added "RTN","TMGXDLG",950,0) "RTN","TMGXDLG",951,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",952,0) do SetCommons(.Options) "RTN","TMGXDLG",953,0) do SetTrans(.Options) "RTN","TMGXDLG",954,0) do ParamTextAdd(.Options," --rangebox ") "RTN","TMGXDLG",955,0) "RTN","TMGXDLG",956,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",957,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",958,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",959,0) set Added=$$AddParam(.Options,1,xcMin,xcNotOptional) "RTN","TMGXDLG",960,0) set Added=$$AddParam(.Options,1,xcMax,xcNotOptional) "RTN","TMGXDLG",961,0) set Added=$$AddParam(.Options,1,xcDefault,xcOptional) "RTN","TMGXDLG",962,0) "RTN","TMGXDLG",963,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",964,0) "RTN","TMGXDLG",965,0) quit "RTN","TMGXDLG",966,0) "RTN","TMGXDLG",967,0) "RTN","TMGXDLG",968,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",969,0) Range2(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,Result2,x,y) "RTN","TMGXDLG",970,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",971,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",972,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",973,0) ;" label1 -- the label to show for range "RTN","TMGXDLG",974,0) ;" min1 -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",975,0) ;" max1 -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",976,0) ;" init1 -- the initial input value -- (default = 50) "RTN","TMGXDLG",977,0) ;" label2 -- the label to show for range "RTN","TMGXDLG",978,0) ;" min2 -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",979,0) ;" max2 -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",980,0) ;" init2 -- the initial input value -- (default = 50) "RTN","TMGXDLG",981,0) ;" Result2 -- a variable to put second input into for return. PASS BY REFERENCE "RTN","TMGXDLG",982,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",983,0) ;"Output: (none) "RTN","TMGXDLG",984,0) ;"Results: returns result of 1st user-input. result of 2nd user-input put into Result2 "RTN","TMGXDLG",985,0) ;"Notes: (none) "RTN","TMGXDLG",986,0) "RTN","TMGXDLG",987,0) new Options "RTN","TMGXDLG",988,0) new Results,result "RTN","TMGXDLG",989,0) "RTN","TMGXDLG",990,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",991,0) "RTN","TMGXDLG",992,0) set Options(xcCommon,xcSeparator)="^" "RTN","TMGXDLG",993,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",994,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",995,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",996,0) set Options(xcBox,xcLabel,1)=$get(label1,"") "RTN","TMGXDLG",997,0) set Options(xcBox,xcMin,1)=$get(min1,0) "RTN","TMGXDLG",998,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",999,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1000,0) set Options(xcBox,xcDefault,1)=$get(init1,50) "RTN","TMGXDLG",1001,0) set Options(xcBox,xcLabel,2)=$get(label2,"") "RTN","TMGXDLG",1002,0) set Options(xcBox,xcMin,2)=$get(min2,0) "RTN","TMGXDLG",1003,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1004,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1005,0) set Options(xcBox,xcDefault,2)=$get(init2,50) "RTN","TMGXDLG",1006,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1007,0) "RTN","TMGXDLG",1008,0) do x2range(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1009,0) "RTN","TMGXDLG",1010,0) set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1011,0) set Result2=$get(Results(xcDlgOutput,1)) "RTN","TMGXDLG",1012,0) "RTN","TMGXDLG",1013,0) quit result; "RTN","TMGXDLG",1014,0) "RTN","TMGXDLG",1015,0) "RTN","TMGXDLG",1016,0) x2range(Options,Results,Modal) "RTN","TMGXDLG",1017,0) ;" --2rangesbox <text> <height> <width> <label1> <min1> <max1> <def1> <label2> <min2> <max2> <def2> "RTN","TMGXDLG",1018,0) new Added "RTN","TMGXDLG",1019,0) "RTN","TMGXDLG",1020,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1021,0) do SetCommons(.Options) "RTN","TMGXDLG",1022,0) do SetTrans(.Options) "RTN","TMGXDLG",1023,0) do ParamTextAdd(.Options," --2rangesbox ") "RTN","TMGXDLG",1024,0) "RTN","TMGXDLG",1025,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1026,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1027,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1028,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1029,0) set Added=$$AddParam(.Options,1,xcMin,xcNotOptional) "RTN","TMGXDLG",1030,0) set Added=$$AddParam(.Options,1,xcMax,xcNotOptional) "RTN","TMGXDLG",1031,0) set Added=$$AddParam(.Options,1,xcDefault,xcNotOptional) "RTN","TMGXDLG",1032,0) set Added=$$AddParam(.Options,2,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1033,0) set Added=$$AddParam(.Options,2,xcMin,xcNotOptional) "RTN","TMGXDLG",1034,0) set Added=$$AddParam(.Options,2,xcMax,xcNotOptional) "RTN","TMGXDLG",1035,0) set Added=$$AddParam(.Options,2,xcDefault,xcNotOptional) "RTN","TMGXDLG",1036,0) "RTN","TMGXDLG",1037,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1038,0) "RTN","TMGXDLG",1039,0) quit "RTN","TMGXDLG",1040,0) "RTN","TMGXDLG",1041,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1042,0) Range3(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,label3,min3,max3,init3,Result2,Result3,x,y) "RTN","TMGXDLG",1043,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1044,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",1045,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",1046,0) ;" labelN -- the title to show for the range. "RTN","TMGXDLG",1047,0) ;" minN -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",1048,0) ;" maxN -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",1049,0) ;" initN -- the initial input value -- (default = 50) "RTN","TMGXDLG",1050,0) ;" Result2 -- a variable to put second input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1051,0) ;" Result3 -- a variable to put third input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1052,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1053,0) ;"Output: (none) "RTN","TMGXDLG",1054,0) ;"Results: returns result of 1st user-input. "RTN","TMGXDLG",1055,0) ;" result of 2nd user-input put into Result2 "RTN","TMGXDLG",1056,0) ;" result of 3rd user-input put into Result3 "RTN","TMGXDLG",1057,0) ;"Notes: (none) "RTN","TMGXDLG",1058,0) "RTN","TMGXDLG",1059,0) new Options "RTN","TMGXDLG",1060,0) new Results,result "RTN","TMGXDLG",1061,0) "RTN","TMGXDLG",1062,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1063,0) "RTN","TMGXDLG",1064,0) set Options(xcCommon,xcSeparator)="^" "RTN","TMGXDLG",1065,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",1066,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1067,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1068,0) set Options(xcBox,xcLabel,1)=$get(label1,"") "RTN","TMGXDLG",1069,0) set Options(xcBox,xcMin,1)=$get(min1,0) "RTN","TMGXDLG",1070,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1071,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1072,0) set Options(xcBox,xcDefault,1)=$get(init1,50) "RTN","TMGXDLG",1073,0) set Options(xcBox,xcLabel,2)=$get(label2,"") "RTN","TMGXDLG",1074,0) set Options(xcBox,xcMin,2)=$get(min2,0) "RTN","TMGXDLG",1075,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1076,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1077,0) set Options(xcBox,xcDefault,2)=$get(init2,50) "RTN","TMGXDLG",1078,0) set Options(xcBox,xcLabel,3)=$get(label3,"") "RTN","TMGXDLG",1079,0) set Options(xcBox,xcMin,3)=$get(min3,0) "RTN","TMGXDLG",1080,0) set Options(xcBox,xcMax,3)=$get(max3,100) "RTN","TMGXDLG",1081,0) set Options(xcBox,xcMax,3)=$get(max3,100) "RTN","TMGXDLG",1082,0) set Options(xcBox,xcDefault,3)=$get(init3,50) "RTN","TMGXDLG",1083,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1084,0) "RTN","TMGXDLG",1085,0) do x3range(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1086,0) "RTN","TMGXDLG",1087,0) set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1088,0) set Result2=$get(Results(xcDlgOutput,1)) "RTN","TMGXDLG",1089,0) set Result3=$get(Results(xcDlgOutput,2)) "RTN","TMGXDLG",1090,0) "RTN","TMGXDLG",1091,0) quit result; "RTN","TMGXDLG",1092,0) "RTN","TMGXDLG",1093,0) "RTN","TMGXDLG",1094,0) x3range(Options,Results,Modal) "RTN","TMGXDLG",1095,0) ;" --3rangesbox <text> <height> <width> <label1> <min1> <max1> <def1> <label2> <min2> <max2> <def2> <label3> <min3> <max3> <def3> "RTN","TMGXDLG",1096,0) new Added "RTN","TMGXDLG",1097,0) "RTN","TMGXDLG",1098,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1099,0) do SetCommons(.Options) "RTN","TMGXDLG",1100,0) do SetTrans(.Options) "RTN","TMGXDLG",1101,0) do ParamTextAdd(.Options," --3rangesbox ") "RTN","TMGXDLG",1102,0) "RTN","TMGXDLG",1103,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1104,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1105,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1106,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1107,0) set Added=$$AddParam(.Options,1,xcMin,xcNotOptional) "RTN","TMGXDLG",1108,0) set Added=$$AddParam(.Options,1,xcMax,xcNotOptional) "RTN","TMGXDLG",1109,0) set Added=$$AddParam(.Options,1,xcDefault,xcNotOptional) "RTN","TMGXDLG",1110,0) set Added=$$AddParam(.Options,2,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1111,0) set Added=$$AddParam(.Options,2,xcMin,xcNotOptional) "RTN","TMGXDLG",1112,0) set Added=$$AddParam(.Options,2,xcMax,xcNotOptional) "RTN","TMGXDLG",1113,0) set Added=$$AddParam(.Options,2,xcDefault,xcNotOptional) "RTN","TMGXDLG",1114,0) set Added=$$AddParam(.Options,3,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1115,0) set Added=$$AddParam(.Options,3,xcMin,xcNotOptional) "RTN","TMGXDLG",1116,0) set Added=$$AddParam(.Options,3,xcMax,xcNotOptional) "RTN","TMGXDLG",1117,0) set Added=$$AddParam(.Options,3,xcDefault,xcNotOptional) "RTN","TMGXDLG",1118,0) "RTN","TMGXDLG",1119,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1120,0) "RTN","TMGXDLG",1121,0) quit "RTN","TMGXDLG",1122,0) "RTN","TMGXDLG",1123,0) "RTN","TMGXDLG",1124,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1125,0) Spin(Text,width,height,label,min,max,init,Result,x,y) "RTN","TMGXDLG",1126,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1127,0) ;" A spinner is a dialable number input dialog. "RTN","TMGXDLG",1128,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",1129,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",1130,0) ;" min -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",1131,0) ;" max -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",1132,0) ;" init -- the initial input value -- (default = 50) "RTN","TMGXDLG",1133,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1134,0) ;"Output: The user input value is return in Result "RTN","TMGXDLG",1135,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",1136,0) ;"Notes: (none) "RTN","TMGXDLG",1137,0) "RTN","TMGXDLG",1138,0) new Options "RTN","TMGXDLG",1139,0) new Results,result "RTN","TMGXDLG",1140,0) "RTN","TMGXDLG",1141,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1142,0) "RTN","TMGXDLG",1143,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",1144,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1145,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1146,0) set Options(xcBox,xcMin,1)=$get(min,0) "RTN","TMGXDLG",1147,0) set Options(xcBox,xcMax,1)=$get(max,100) "RTN","TMGXDLG",1148,0) set Options(xcBox,xcMax,1)=$get(max,100) "RTN","TMGXDLG",1149,0) set Options(xcBox,xcLabel,1)=$get(label,"") "RTN","TMGXDLG",1150,0) set Options(xcBox,xcDefault,1)=$get(init,50) "RTN","TMGXDLG",1151,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1152,0) "RTN","TMGXDLG",1153,0) do xspin(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1154,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1155,0) "RTN","TMGXDLG",1156,0) set Result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1157,0) "RTN","TMGXDLG",1158,0) quit result; "RTN","TMGXDLG",1159,0) "RTN","TMGXDLG",1160,0) "RTN","TMGXDLG",1161,0) xspin(Options,Results,Modal) "RTN","TMGXDLG",1162,0) ;" --spinbox <text> <height> <width> <min> <max> <def> <label> "RTN","TMGXDLG",1163,0) new Added "RTN","TMGXDLG",1164,0) "RTN","TMGXDLG",1165,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1166,0) do SetCommons(.Options) "RTN","TMGXDLG",1167,0) do SetTrans(.Options) "RTN","TMGXDLG",1168,0) do ParamTextAdd(.Options," --spinbox ") "RTN","TMGXDLG",1169,0) "RTN","TMGXDLG",1170,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1171,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1172,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1173,0) set Added=$$AddParam(.Options,1,xcMin,xcNotOptional) "RTN","TMGXDLG",1174,0) set Added=$$AddParam(.Options,1,xcMax,xcNotOptional) "RTN","TMGXDLG",1175,0) set Added=$$AddParam(.Options,1,xcDefault,xcOptional) "RTN","TMGXDLG",1176,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1177,0) "RTN","TMGXDLG",1178,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1179,0) "RTN","TMGXDLG",1180,0) quit "RTN","TMGXDLG",1181,0) "RTN","TMGXDLG",1182,0) "RTN","TMGXDLG",1183,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1184,0) Spin2(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,Result1,Result2,x,y) "RTN","TMGXDLG",1185,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1186,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",1187,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",1188,0) ;" label1 -- the label to show for range "RTN","TMGXDLG",1189,0) ;" min1 -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",1190,0) ;" max1 -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",1191,0) ;" init1 -- the initial input value -- (default = 50) "RTN","TMGXDLG",1192,0) ;" label2 -- the label to show for range "RTN","TMGXDLG",1193,0) ;" min2 -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",1194,0) ;" max2 -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",1195,0) ;" init2 -- the initial input value -- (default = 50) "RTN","TMGXDLG",1196,0) ;" Result1 -- a variable to put first input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1197,0) ;" Result2 -- a variable to put second input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1198,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1199,0) ;"Output: The user input value is return in Result1 "RTN","TMGXDLG",1200,0) ;" result of 2nd user-input put into Result2 "RTN","TMGXDLG",1201,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",1202,0) ;"Notes: (none) "RTN","TMGXDLG",1203,0) new Options "RTN","TMGXDLG",1204,0) new Results,result "RTN","TMGXDLG",1205,0) "RTN","TMGXDLG",1206,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1207,0) "RTN","TMGXDLG",1208,0) set Options(xcCommon,xcSeparator)="^" "RTN","TMGXDLG",1209,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",1210,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1211,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1212,0) set Options(xcBox,xcLabel,1)=$get(label1,"") "RTN","TMGXDLG",1213,0) set Options(xcBox,xcMin,1)=$get(min1,0) "RTN","TMGXDLG",1214,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1215,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1216,0) set Options(xcBox,xcDefault,1)=$get(init1,50) "RTN","TMGXDLG",1217,0) set Options(xcBox,xcLabel,2)=$get(label2,"") "RTN","TMGXDLG",1218,0) set Options(xcBox,xcMin,2)=$get(min2,0) "RTN","TMGXDLG",1219,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1220,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1221,0) set Options(xcBox,xcDefault,2)=$get(init2,50) "RTN","TMGXDLG",1222,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1223,0) "RTN","TMGXDLG",1224,0) do x2spin(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1225,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1226,0) "RTN","TMGXDLG",1227,0) set Result1=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1228,0) set Result2=$get(Results(xcDlgOutput,1)) "RTN","TMGXDLG",1229,0) "RTN","TMGXDLG",1230,0) quit result; "RTN","TMGXDLG",1231,0) "RTN","TMGXDLG",1232,0) "RTN","TMGXDLG",1233,0) x2spin(Options,Results,Modal) "RTN","TMGXDLG",1234,0) ;" --2spinsbox <text> <height> <width> <min1> <max1> <def1> <label1> <min2> <max2> <def2> <label2> "RTN","TMGXDLG",1235,0) new Added "RTN","TMGXDLG",1236,0) "RTN","TMGXDLG",1237,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1238,0) do SetCommons(.Options) "RTN","TMGXDLG",1239,0) do SetTrans(.Options) "RTN","TMGXDLG",1240,0) "RTN","TMGXDLG",1241,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1242,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1243,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1244,0) set Added=$$AddParam(.Options,1,xcMin,xcNotOptional) "RTN","TMGXDLG",1245,0) set Added=$$AddParam(.Options,1,xcMax,xcNotOptional) "RTN","TMGXDLG",1246,0) set Added=$$AddParam(.Options,1,xcDefault,xcNotOptional) "RTN","TMGXDLG",1247,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1248,0) set Added=$$AddParam(.Options,2,xcMin,xcNotOptional) "RTN","TMGXDLG",1249,0) set Added=$$AddParam(.Options,2,xcMax,xcNotOptional) "RTN","TMGXDLG",1250,0) set Added=$$AddParam(.Options,2,xcDefault,xcNotOptional) "RTN","TMGXDLG",1251,0) set Added=$$AddParam(.Options,2,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1252,0) "RTN","TMGXDLG",1253,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1254,0) "RTN","TMGXDLG",1255,0) quit "RTN","TMGXDLG",1256,0) "RTN","TMGXDLG",1257,0) "RTN","TMGXDLG",1258,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1259,0) Spin3(Text,width,height,label1,min1,max1,init1,label2,min2,max2,init2,label3,min3,max3,init3,Result1,Result2,Result3,x,y) "RTN","TMGXDLG",1260,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1261,0) ;"Input: Text -- text of input prompt to display "RTN","TMGXDLG",1262,0) ;" width,height of dialog -- [optional] "RTN","TMGXDLG",1263,0) ;" labelN -- the title to show for the range. "RTN","TMGXDLG",1264,0) ;" minN -- the minimum possible range of input value (default = 0) "RTN","TMGXDLG",1265,0) ;" maxN -- the minimum possible range of input value (default = 100) "RTN","TMGXDLG",1266,0) ;" initN -- the initial input value -- (default = 50) "RTN","TMGXDLG",1267,0) ;" Result1 -- a variable to put first input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1268,0) ;" Result2 -- a variable to put second input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1269,0) ;" Result3 -- a variable to put third input into for return. PASS BY REFERENCE "RTN","TMGXDLG",1270,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1271,0) ;"Output: The user input value is return in Result1 "RTN","TMGXDLG",1272,0) ;" result of 2nd user-input put into Result2 "RTN","TMGXDLG",1273,0) ;" result of 3rd user-input put into Result3 "RTN","TMGXDLG",1274,0) ;"Results: returns results of box closure. "RTN","TMGXDLG",1275,0) ;"Notes: (none) "RTN","TMGXDLG",1276,0) "RTN","TMGXDLG",1277,0) new Options "RTN","TMGXDLG",1278,0) new Results,result "RTN","TMGXDLG",1279,0) "RTN","TMGXDLG",1280,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1281,0) "RTN","TMGXDLG",1282,0) set Options(xcCommon,xcSeparator)="^" "RTN","TMGXDLG",1283,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",1284,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1285,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1286,0) set Options(xcBox,xcLabel,1)=$get(label1,"") "RTN","TMGXDLG",1287,0) set Options(xcBox,xcMin,1)=$get(min1,0) "RTN","TMGXDLG",1288,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1289,0) set Options(xcBox,xcMax,1)=$get(max1,100) "RTN","TMGXDLG",1290,0) set Options(xcBox,xcDefault,1)=$get(init1,50) "RTN","TMGXDLG",1291,0) set Options(xcBox,xcLabel,2)=$get(label2,"") "RTN","TMGXDLG",1292,0) set Options(xcBox,xcMin,2)=$get(min2,0) "RTN","TMGXDLG",1293,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1294,0) set Options(xcBox,xcMax,2)=$get(max2,100) "RTN","TMGXDLG",1295,0) set Options(xcBox,xcDefault,2)=$get(init2,50) "RTN","TMGXDLG",1296,0) set Options(xcBox,xcLabel,3)=$get(label3,"") "RTN","TMGXDLG",1297,0) set Options(xcBox,xcMin,3)=$get(min3,0) "RTN","TMGXDLG",1298,0) set Options(xcBox,xcMax,3)=$get(max3,100) "RTN","TMGXDLG",1299,0) set Options(xcBox,xcMax,3)=$get(max3,100) "RTN","TMGXDLG",1300,0) set Options(xcBox,xcDefault,3)=$get(init3,50) "RTN","TMGXDLG",1301,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1302,0) "RTN","TMGXDLG",1303,0) do x3spin(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1304,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1305,0) "RTN","TMGXDLG",1306,0) set Result1=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1307,0) set Result2=$get(Results(xcDlgOutput,1)) "RTN","TMGXDLG",1308,0) set Result3=$get(Results(xcDlgOutput,2)) "RTN","TMGXDLG",1309,0) "RTN","TMGXDLG",1310,0) quit result; "RTN","TMGXDLG",1311,0) "RTN","TMGXDLG",1312,0) "RTN","TMGXDLG",1313,0) x3spin(Options,Results,Modal) "RTN","TMGXDLG",1314,0) ;" --3spinsbox <text> <height> <width> <text> <height> <width> <min1> <max1> <def1> <label1> <min2> <max2> <def2> <label2> <min3> <max3> <def3> <label3> "RTN","TMGXDLG",1315,0) new Added "RTN","TMGXDLG",1316,0) "RTN","TMGXDLG",1317,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1318,0) do SetCommons(.Options) "RTN","TMGXDLG",1319,0) do SetTrans(.Options) "RTN","TMGXDLG",1320,0) do ParamTextAdd(.Options," --2spinsbox ") "RTN","TMGXDLG",1321,0) "RTN","TMGXDLG",1322,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1323,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1324,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1325,0) set Added=$$AddParam(.Options,1,xcMin,xcNotOptional) "RTN","TMGXDLG",1326,0) set Added=$$AddParam(.Options,1,xcMax,xcNotOptional) "RTN","TMGXDLG",1327,0) set Added=$$AddParam(.Options,1,xcDefault,xcNotOptional) "RTN","TMGXDLG",1328,0) set Added=$$AddParam(.Options,1,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1329,0) set Added=$$AddParam(.Options,2,xcMin,xcNotOptional) "RTN","TMGXDLG",1330,0) set Added=$$AddParam(.Options,2,xcMax,xcNotOptional) "RTN","TMGXDLG",1331,0) set Added=$$AddParam(.Options,2,xcDefault,xcNotOptional) "RTN","TMGXDLG",1332,0) set Added=$$AddParam(.Options,2,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1333,0) set Added=$$AddParam(.Options,3,xcMin,xcNotOptional) "RTN","TMGXDLG",1334,0) set Added=$$AddParam(.Options,3,xcMax,xcNotOptional) "RTN","TMGXDLG",1335,0) set Added=$$AddParam(.Options,3,xcDefault,xcNotOptional) "RTN","TMGXDLG",1336,0) set Added=$$AddParam(.Options,3,xcLabel,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1337,0) "RTN","TMGXDLG",1338,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1339,0) "RTN","TMGXDLG",1340,0) quit "RTN","TMGXDLG",1341,0) "RTN","TMGXDLG",1342,0) "RTN","TMGXDLG",1343,0) "RTN","TMGXDLG",1344,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1345,0) "RTN","TMGXDLG",1346,0) Log(file,width,height,Modal,x,y) "RTN","TMGXDLG",1347,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1348,0) ;"Input: file to display "RTN","TMGXDLG",1349,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",1350,0) ;" [Modal]: if true, function does not return until dialog is closed. "RTN","TMGXDLG",1351,0) ;" if false, function returns immediately, and functions do NOT "RTN","TMGXDLG",1352,0) ;" reflect the user's button press. OPTIONAL -- default=xcNonModal "RTN","TMGXDLG",1353,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1354,0) ;"Output: (none) "RTN","TMGXDLG",1355,0) ;"Results: Returns results of box closure (see Modal note above) "RTN","TMGXDLG",1356,0) ;"Notes: (none) "RTN","TMGXDLG",1357,0) "RTN","TMGXDLG",1358,0) new Options "RTN","TMGXDLG",1359,0) new Results,result "RTN","TMGXDLG",1360,0) "RTN","TMGXDLG",1361,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1362,0) "RTN","TMGXDLG",1363,0) set Options(xcBox,xcFile)=$get(file) "RTN","TMGXDLG",1364,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1365,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1366,0) set Modal=$get(Modal,xcNonModal) "RTN","TMGXDLG",1367,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1368,0) "RTN","TMGXDLG",1369,0) do xlog(.Options,.Results,Modal) "RTN","TMGXDLG",1370,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1371,0) "RTN","TMGXDLG",1372,0) quit result; "RTN","TMGXDLG",1373,0) "RTN","TMGXDLG",1374,0) "RTN","TMGXDLG",1375,0) xlog(Options,Results,Modal) "RTN","TMGXDLG",1376,0) ;" --logbox <file> <height> <width> "RTN","TMGXDLG",1377,0) new Added "RTN","TMGXDLG",1378,0) "RTN","TMGXDLG",1379,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1380,0) do SetCommons(.Options) "RTN","TMGXDLG",1381,0) do SetTrans(.Options) "RTN","TMGXDLG",1382,0) do ParamTextAdd(.Options," --logbox ") "RTN","TMGXDLG",1383,0) "RTN","TMGXDLG",1384,0) "RTN","TMGXDLG",1385,0) set Added=$$AddParam(.Options,,xcFile,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1386,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1387,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1388,0) "RTN","TMGXDLG",1389,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1390,0) "RTN","TMGXDLG",1391,0) quit "RTN","TMGXDLG",1392,0) "RTN","TMGXDLG",1393,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1394,0) "RTN","TMGXDLG",1395,0) Edit(file,width,height,Results,x,y) "RTN","TMGXDLG",1396,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1397,0) ;"Input: file to display for editing, "RTN","TMGXDLG",1398,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",1399,0) ;" Results -- the array to put results into. MUST BE PASSED BY REFERENCE. "RTN","TMGXDLG",1400,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1401,0) ;"Output: The modified text is put into Results "RTN","TMGXDLG",1402,0) ;" Example of returned results after editing a script file.: "RTN","TMGXDLG",1403,0) ;" Results("Dialog Output",1)="<!DOCTYPE INSTALL_SCRIPT>" "RTN","TMGXDLG",1404,0) ;" Results("Dialog Output",2)="<INSTALL_SCRIPT>" "RTN","TMGXDLG",1405,0) ;" Results("Dialog Output",3)="<Script>" "RTN","TMGXDLG",1406,0) ;" Results("Dialog Output",4)=" <Show>This is a test script system.</Show>" "RTN","TMGXDLG",1407,0) ;" Results("Dialog Output",5)="</Script>" "RTN","TMGXDLG",1408,0) ;"Results: Returns results of box closure (see Modal note above) "RTN","TMGXDLG",1409,0) ;"Notes: If dialog is not closed with an OK, then changes are NOT returned in Results "RTN","TMGXDLG",1410,0) "RTN","TMGXDLG",1411,0) new Options "RTN","TMGXDLG",1412,0) new Results,result "RTN","TMGXDLG",1413,0) "RTN","TMGXDLG",1414,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1415,0) "RTN","TMGXDLG",1416,0) set Options(xcBox,xcFile)=$get(file) "RTN","TMGXDLG",1417,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1418,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1419,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1420,0) "RTN","TMGXDLG",1421,0) do xedit(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1422,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1423,0) "RTN","TMGXDLG",1424,0) quit result; "RTN","TMGXDLG",1425,0) "RTN","TMGXDLG",1426,0) "RTN","TMGXDLG",1427,0) xedit(Options,Results,Modal) "RTN","TMGXDLG",1428,0) ;" --editbox <file> <height> <width> "RTN","TMGXDLG",1429,0) new Added "RTN","TMGXDLG",1430,0) "RTN","TMGXDLG",1431,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1432,0) do SetCommons(.Options) "RTN","TMGXDLG",1433,0) do SetTrans(.Options) "RTN","TMGXDLG",1434,0) do ParamTextAdd(.Options," --editbox ") "RTN","TMGXDLG",1435,0) "RTN","TMGXDLG",1436,0) set Added=$$AddParam(.Options,,xcFile,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1437,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1438,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1439,0) "RTN","TMGXDLG",1440,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1441,0) "RTN","TMGXDLG",1442,0) quit "RTN","TMGXDLG",1443,0) "RTN","TMGXDLG",1444,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1445,0) "RTN","TMGXDLG",1446,0) Text(file,width,height,Modal,x,y) "RTN","TMGXDLG",1447,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1448,0) ;"Input: file to display "RTN","TMGXDLG",1449,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",1450,0) ;" [Modal]: if true, function does not return until dialog is closed. "RTN","TMGXDLG",1451,0) ;" if false, function returns immediately, and functions do NOT "RTN","TMGXDLG",1452,0) ;" reflect the user's button press. OPTIONAL -- default=xcNonModal "RTN","TMGXDLG",1453,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1454,0) ;"Output: (none) "RTN","TMGXDLG",1455,0) ;"Results: Returns results of box closure (see Modal note above) "RTN","TMGXDLG",1456,0) ;"Notes: (none) "RTN","TMGXDLG",1457,0) "RTN","TMGXDLG",1458,0) new Options "RTN","TMGXDLG",1459,0) new Results,result "RTN","TMGXDLG",1460,0) "RTN","TMGXDLG",1461,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1462,0) "RTN","TMGXDLG",1463,0) set Options(xcBox,xcFile)=$get(file) "RTN","TMGXDLG",1464,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1465,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1466,0) set Modal=$get(Modal,xcNonModal) "RTN","TMGXDLG",1467,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1468,0) "RTN","TMGXDLG",1469,0) do xtext(.Options,.Results,Modal) "RTN","TMGXDLG",1470,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1471,0) "RTN","TMGXDLG",1472,0) quit result; "RTN","TMGXDLG",1473,0) "RTN","TMGXDLG",1474,0) "RTN","TMGXDLG",1475,0) xtext(Options,Results,Modal) "RTN","TMGXDLG",1476,0) ;" --textbox <file> <height> <width> "RTN","TMGXDLG",1477,0) new Added "RTN","TMGXDLG",1478,0) "RTN","TMGXDLG",1479,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1480,0) do SetCommons(.Options) "RTN","TMGXDLG",1481,0) do SetTrans(.Options) "RTN","TMGXDLG",1482,0) do ParamTextAdd(.Options," --textbox ") "RTN","TMGXDLG",1483,0) "RTN","TMGXDLG",1484,0) set Added=$$AddParam(.Options,,xcFile,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1485,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1486,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1487,0) "RTN","TMGXDLG",1488,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1489,0) "RTN","TMGXDLG",1490,0) quit "RTN","TMGXDLG",1491,0) "RTN","TMGXDLG",1492,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1493,0) "RTN","TMGXDLG",1494,0) Tail(file,width,height,Modal,x,y) "RTN","TMGXDLG",1495,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1496,0) ;" A tailbox is one that keeps at the bottom, updating as the file is updated. "RTN","TMGXDLG",1497,0) ;"Input: file to display "RTN","TMGXDLG",1498,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",1499,0) ;" [Modal]: if true, function does not return until dialog is closed. "RTN","TMGXDLG",1500,0) ;" if false, function returns immediately, and functions do NOT "RTN","TMGXDLG",1501,0) ;" reflect the user's button press. OPTIONAL -- default=xcNonModal "RTN","TMGXDLG",1502,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1503,0) ;"Output: (none) "RTN","TMGXDLG",1504,0) ;"Results: Returns results of box closure (see Modal note above) "RTN","TMGXDLG",1505,0) ;"Notes: (none) "RTN","TMGXDLG",1506,0) "RTN","TMGXDLG",1507,0) new Options "RTN","TMGXDLG",1508,0) new Results,result "RTN","TMGXDLG",1509,0) "RTN","TMGXDLG",1510,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1511,0) "RTN","TMGXDLG",1512,0) set Options(xcBox,xcFile)=$get(file) "RTN","TMGXDLG",1513,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1514,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1515,0) set Modal=$get(Modal,xcNonModal) "RTN","TMGXDLG",1516,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1517,0) "RTN","TMGXDLG",1518,0) do xtail(.Options,.Results,Modal) "RTN","TMGXDLG",1519,0) set result=Results(xcDlgResult) "RTN","TMGXDLG",1520,0) "RTN","TMGXDLG",1521,0) quit result; "RTN","TMGXDLG",1522,0) "RTN","TMGXDLG",1523,0) "RTN","TMGXDLG",1524,0) xtail(Options,Results,Modal) "RTN","TMGXDLG",1525,0) ;" --tailbox <file> <height> <width> "RTN","TMGXDLG",1526,0) new Added "RTN","TMGXDLG",1527,0) "RTN","TMGXDLG",1528,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1529,0) do SetCommons(.Options) "RTN","TMGXDLG",1530,0) do SetTrans(.Options) "RTN","TMGXDLG",1531,0) do ParamTextAdd(.Options," --tailbox ") "RTN","TMGXDLG",1532,0) "RTN","TMGXDLG",1533,0) set Added=$$AddParam(.Options,,xcFile,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1534,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1535,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1536,0) "RTN","TMGXDLG",1537,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1538,0) "RTN","TMGXDLG",1539,0) quit "RTN","TMGXDLG",1540,0) "RTN","TMGXDLG",1541,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1542,0) ;"TO BE COMPLETED "RTN","TMGXDLG",1543,0) "RTN","TMGXDLG",1544,0) xchecklist(Options,Results,Modal) "RTN","TMGXDLG",1545,0) ;" --checklist <text> <height> <width> <list height> <tag1> <item1> <status1> {<help1>}... "RTN","TMGXDLG",1546,0) "RTN","TMGXDLG",1547,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1548,0) "RTN","TMGXDLG",1549,0) RadioList(Text,List,width,height,x,y) "RTN","TMGXDLG",1550,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1551,0) ;" A tailbox is one that keeps at the bottom, updating as the file is updated. "RTN","TMGXDLG",1552,0) ;"Input: Text -- title text. "RTN","TMGXDLG",1553,0) ;" List -- Best if passed by reference. Holds radio list as follows: "RTN","TMGXDLG",1554,0) ;" List(1,xcTag)=<return value> -- the output the be returned if selected. "RTN","TMGXDLG",1555,0) ;" List(1,xcItem)=<text of radio item> "RTN","TMGXDLG",1556,0) ;" List(1,xcStatus)=<status> must be: {"on", "off", or "unavailable"} "RTN","TMGXDLG",1557,0) ;" List(1,xcHelp)=<hover tip> -- [optional] "RTN","TMGXDLG",1558,0) ;" List(2,xcTag)=<return value> -- the output the be returned if selected. "RTN","TMGXDLG",1559,0) ;" List(2,xcItem)=<text of radio item> "RTN","TMGXDLG",1560,0) ;" List(2,xcStatus)=<status> must be: {"on", "off", or "unavailable"} "RTN","TMGXDLG",1561,0) ;" List(2,xcHelp)=<hover tip> -- [optional] "RTN","TMGXDLG",1562,0) ;" ... etc up to any number N "RTN","TMGXDLG",1563,0) ;" height & width of dialog -- [optional] "RTN","TMGXDLG",1564,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1565,0) ;"Output: (none) "RTN","TMGXDLG",1566,0) ;"Results: Returns selected 'tag'. If cancel pressed, then returns "" "RTN","TMGXDLG",1567,0) ;"Notes: (none) "RTN","TMGXDLG",1568,0) "RTN","TMGXDLG",1569,0) new Options "RTN","TMGXDLG",1570,0) new Results "RTN","TMGXDLG",1571,0) set result="" "RTN","TMGXDLG",1572,0) new i,Done "RTN","TMGXDLG",1573,0) new status,help "RTN","TMGXDLG",1574,0) "RTN","TMGXDLG",1575,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1576,0) "RTN","TMGXDLG",1577,0) set Options(xcBox,xcText)=$get(Text) "RTN","TMGXDLG",1578,0) "RTN","TMGXDLG",1579,0) set Done=0 "RTN","TMGXDLG",1580,0) for i=1:1 do quit:Done "RTN","TMGXDLG",1581,0) . if $data(List(i,xcTag))=0 set Done=1 quit "RTN","TMGXDLG",1582,0) . set Options(xcBox,xcTag,i)=$get(List(i,xcTag)) "RTN","TMGXDLG",1583,0) . set Options(xcBox,xcItem,i)=$get(List(i,xcItem)) "RTN","TMGXDLG",1584,0) . set status=$get(List(i,xcStatus)) "RTN","TMGXDLG",1585,0) . if (status'="on")&(status'="unavailable") set status="off" "RTN","TMGXDLG",1586,0) . set Options(xcBox,xcStatus,i)=status "RTN","TMGXDLG",1587,0) . set help=$get(List(i,xcHelp,i)) "RTN","TMGXDLG",1588,0) . if help'="" set Options(xcTransient,xxcItemHelp)=1 "RTN","TMGXDLG",1589,0) . set help=($get(Options(xcTransient,xxcItemHelp))=1) "RTN","TMGXDLG",1590,0) . if help set Options(xcBox,xcHelp,i)=$get(List(i,xcHelp)) "RTN","TMGXDLG",1591,0) "RTN","TMGXDLG",1592,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1593,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1594,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1595,0) "RTN","TMGXDLG",1596,0) do xradiolist(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1597,0) "RTN","TMGXDLG",1598,0) set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1599,0) quit result; "RTN","TMGXDLG",1600,0) "RTN","TMGXDLG",1601,0) "RTN","TMGXDLG",1602,0) xradiolist(Options,Results,Modal) "RTN","TMGXDLG",1603,0) ;" --radiolist <text> <height> <width> <list height> <tag1> <item1> <status1> {<help1>}... "RTN","TMGXDLG",1604,0) new Added,GroupAdded "RTN","TMGXDLG",1605,0) new N "RTN","TMGXDLG",1606,0) "RTN","TMGXDLG",1607,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1608,0) do SetCommons(.Options) "RTN","TMGXDLG",1609,0) do SetTrans(.Options) "RTN","TMGXDLG",1610,0) do ParamTextAdd(.Options," --radiolist ") "RTN","TMGXDLG",1611,0) "RTN","TMGXDLG",1612,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1613,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1614,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1615,0) set Added=$$AddParam(.Options,,xcListHeight) "RTN","TMGXDLG",1616,0) set N=1 "RTN","TMGXDLG",1617,0) xrl1 set GroupAdded=$$AddParam(.Options,N,xcTag,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1618,0) if GroupAdded=0 goto xrl2 "RTN","TMGXDLG",1619,0) set Added=$$AddParam(.Options,N,xcItem,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1620,0) set Added=$$AddParam(.Options,N,xcStatus,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1621,0) if (Added=1)&($get(Option(xcTransient,xxcItemHelp))=1) do "RTN","TMGXDLG",1622,0) . set Added=$$AddParam(.Options,N,xcHelp,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1623,0) set N=N+1 goto xrl1 "RTN","TMGXDLG",1624,0) xrl2 "RTN","TMGXDLG",1625,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1626,0) "RTN","TMGXDLG",1627,0) quit "RTN","TMGXDLG",1628,0) "RTN","TMGXDLG",1629,0) "RTN","TMGXDLG",1630,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1631,0) ;"TO BE COMPLETED "RTN","TMGXDLG",1632,0) "RTN","TMGXDLG",1633,0) xmenu(Options,Results,Modal) "RTN","TMGXDLG",1634,0) ;" --menubox <text> <height> <width> <menu height> <tag1> <item1> {<help1>}... "RTN","TMGXDLG",1635,0) "RTN","TMGXDLG",1636,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1637,0) ;"TO BE COMPLETED "RTN","TMGXDLG",1638,0) "RTN","TMGXDLG",1639,0) xtreeview(Options,Results,Modal) "RTN","TMGXDLG",1640,0) ;" --treeview <text> <height> <width> <list height> <tag1> <item1> <status1> <item_depth1> {<help1>}... "RTN","TMGXDLG",1641,0) "RTN","TMGXDLG",1642,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1643,0) "RTN","TMGXDLG",1644,0) FileSel(Title,InitFile,width,height,x,y) "RTN","TMGXDLG",1645,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1646,0) ;" A tailbox is one that keeps at the bottom, updating as the file is updated. "RTN","TMGXDLG",1647,0) ;"Input: InitFile. The initial file to select, and the default file. [optional] "RTN","TMGXDLG",1648,0) ;" width,height -- the initial size of box. [Optional] "RTN","TMGXDLG",1649,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1650,0) ;"Output:(none) "RTN","TMGXDLG",1651,0) ;"Results: returns the selected filename "RTN","TMGXDLG",1652,0) ;"Notes: (none) "RTN","TMGXDLG",1653,0) "RTN","TMGXDLG",1654,0) new Options "RTN","TMGXDLG",1655,0) new Results "RTN","TMGXDLG",1656,0) new result set result="" "RTN","TMGXDLG",1657,0) "RTN","TMGXDLG",1658,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1659,0) if $data(Title) set Options(xcCommon,xcTitle)=Title "RTN","TMGXDLG",1660,0) set Options(xcBox,xcFile)=$get(InitFile,"") "RTN","TMGXDLG",1661,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1662,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1663,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1664,0) "RTN","TMGXDLG",1665,0) do xfilesel(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1666,0) "RTN","TMGXDLG",1667,0) if Results(xcDlgResult)=0 set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1668,0) "RTN","TMGXDLG",1669,0) quit result; "RTN","TMGXDLG",1670,0) "RTN","TMGXDLG",1671,0) xfilesel(Options,Results,Modal) "RTN","TMGXDLG",1672,0) ;" --fselect <file> <height> <width> "RTN","TMGXDLG",1673,0) new Added "RTN","TMGXDLG",1674,0) "RTN","TMGXDLG",1675,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1676,0) do SetCommons(.Options) "RTN","TMGXDLG",1677,0) do SetTrans(.Options) "RTN","TMGXDLG",1678,0) do ParamTextAdd(.Options," --fselect ") "RTN","TMGXDLG",1679,0) "RTN","TMGXDLG",1680,0) set Added=$$AddParam(.Options,,xcFile,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1681,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1682,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1683,0) "RTN","TMGXDLG",1684,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1685,0) "RTN","TMGXDLG",1686,0) quit "RTN","TMGXDLG",1687,0) "RTN","TMGXDLG",1688,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1689,0) "RTN","TMGXDLG",1690,0) DirSel(Title,InitDir,width,height,x,y) "RTN","TMGXDLG",1691,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1692,0) ;" A tailbox is one that keeps at the bottom, updating as the file is updated. "RTN","TMGXDLG",1693,0) ;"Input: InitDir: The initial file to select, and the default file. [optional] "RTN","TMGXDLG",1694,0) ;" width,height -- the initial size of box. [Optional] "RTN","TMGXDLG",1695,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1696,0) ;"Output:(none) "RTN","TMGXDLG",1697,0) ;"Results: returns the selected directory "RTN","TMGXDLG",1698,0) ;"Notes: (none) "RTN","TMGXDLG",1699,0) "RTN","TMGXDLG",1700,0) new Options "RTN","TMGXDLG",1701,0) new Results "RTN","TMGXDLG",1702,0) new result set result="" "RTN","TMGXDLG",1703,0) "RTN","TMGXDLG",1704,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1705,0) if $data(Title) set Options(xcCommon,xcTitle)=Title "RTN","TMGXDLG",1706,0) set Options(xcBox,xcDirectory)=$get(InitDir,"") "RTN","TMGXDLG",1707,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1708,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1709,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1710,0) "RTN","TMGXDLG",1711,0) do xdirsel(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1712,0) "RTN","TMGXDLG",1713,0) if Results(xcDlgResult)=0 set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1714,0) "RTN","TMGXDLG",1715,0) quit result; "RTN","TMGXDLG",1716,0) "RTN","TMGXDLG",1717,0) "RTN","TMGXDLG",1718,0) xdirsel(Options,Results,Modal) "RTN","TMGXDLG",1719,0) ;" --dselect <directory> <height> <width> "RTN","TMGXDLG",1720,0) new Added "RTN","TMGXDLG",1721,0) "RTN","TMGXDLG",1722,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1723,0) do SetCommons(.Options) "RTN","TMGXDLG",1724,0) do SetTrans(.Options) "RTN","TMGXDLG",1725,0) do ParamTextAdd(.Options," --dselect ") "RTN","TMGXDLG",1726,0) "RTN","TMGXDLG",1727,0) "RTN","TMGXDLG",1728,0) set Added=$$AddParam(.Options,,xcDirectory,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1729,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1730,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1731,0) "RTN","TMGXDLG",1732,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1733,0) "RTN","TMGXDLG",1734,0) quit "RTN","TMGXDLG",1735,0) "RTN","TMGXDLG",1736,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1737,0) "RTN","TMGXDLG",1738,0) DateSel(Text,width,height,InitDay,InitMonth,InitYear,x,y) "RTN","TMGXDLG",1739,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1740,0) ;" Shows a calendar and allows user to select date. "RTN","TMGXDLG",1741,0) ;"Input: Text -- a title / msg to show. "RTN","TMGXDLG",1742,0) ;" width,height -- the initial size of box. [Optional] "RTN","TMGXDLG",1743,0) ;" InitDay/Month/Year -- Initial date to show. "RTN","TMGXDLG",1744,0) ;" NOTE: These three variables are optional BUT if InitDay given all 3 should be present. "RTN","TMGXDLG",1745,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1746,0) ;"Output:(none) "RTN","TMGXDLG",1747,0) ;"Results: returns the selected date "RTN","TMGXDLG",1748,0) ;"Notes: (none) "RTN","TMGXDLG",1749,0) "RTN","TMGXDLG",1750,0) new Options "RTN","TMGXDLG",1751,0) new Results "RTN","TMGXDLG",1752,0) new result set result="" "RTN","TMGXDLG",1753,0) "RTN","TMGXDLG",1754,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1755,0) "RTN","TMGXDLG",1756,0) set Options(xcBox,xcText)=$get(Text,"") "RTN","TMGXDLG",1757,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1758,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1759,0) if $data(InitDay) do "RTN","TMGXDLG",1760,0) . set Options(xcBox,xcDay)=InitDay "RTN","TMGXDLG",1761,0) . set Options(xcBox,xcMonth)=$get(InitMonth,0) "RTN","TMGXDLG",1762,0) . set Options(xcBox,xcYear)=$get(InitYear,0) "RTN","TMGXDLG",1763,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1764,0) "RTN","TMGXDLG",1765,0) do xcalendarsel(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1766,0) "RTN","TMGXDLG",1767,0) if Results(xcDlgResult)=0 set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1768,0) "RTN","TMGXDLG",1769,0) quit result; "RTN","TMGXDLG",1770,0) "RTN","TMGXDLG",1771,0) xcalendarsel(Options,Results,Modal) "RTN","TMGXDLG",1772,0) ;" --calendar <text> <height> <width> [<day> <month> <year>] "RTN","TMGXDLG",1773,0) "RTN","TMGXDLG",1774,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1775,0) do SetCommons(.Options) "RTN","TMGXDLG",1776,0) do SetTrans(.Options) "RTN","TMGXDLG",1777,0) do ParamTextAdd(.Options," --calendar ") "RTN","TMGXDLG",1778,0) "RTN","TMGXDLG",1779,0) set Added=$$AddParam(.Options,,xcText,xcAddQuote) "RTN","TMGXDLG",1780,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1781,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1782,0) if $data(Options(xcDay)) do "RTN","TMGXDLG",1783,0) . set Added=$$AddParam(.Options,,xcDay,xcNotOptional) "RTN","TMGXDLG",1784,0) . set Added=$$AddParam(.Options,,xcMonth,xcNotOptional) "RTN","TMGXDLG",1785,0) . set Added=$$AddParam(.Options,,xcYear,xcNotOptional) "RTN","TMGXDLG",1786,0) "RTN","TMGXDLG",1787,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1788,0) "RTN","TMGXDLG",1789,0) quit "RTN","TMGXDLG",1790,0) "RTN","TMGXDLG",1791,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1792,0) "RTN","TMGXDLG",1793,0) TimeSel(Text,width,height,InitHour,InitMinute,InitSecond,x,y) "RTN","TMGXDLG",1794,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1795,0) ;" Shows a calendar and allows user to select date. "RTN","TMGXDLG",1796,0) ;"Input: Text -- a title / msg to show. "RTN","TMGXDLG",1797,0) ;" width,height -- the initial size of box. [Optional] "RTN","TMGXDLG",1798,0) ;" InitHour/Minute/Second -- Initial time to show. "RTN","TMGXDLG",1799,0) ;" NOTE: These three variables are optional BUT if InitDay given all 3 should be present. "RTN","TMGXDLG",1800,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1801,0) ;"Output:(none) "RTN","TMGXDLG",1802,0) ;"Results: returns the selected date "RTN","TMGXDLG",1803,0) ;"Notes: (none) "RTN","TMGXDLG",1804,0) "RTN","TMGXDLG",1805,0) new Options "RTN","TMGXDLG",1806,0) new Results "RTN","TMGXDLG",1807,0) new result set result="" "RTN","TMGXDLG",1808,0) "RTN","TMGXDLG",1809,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1810,0) "RTN","TMGXDLG",1811,0) set Options(xcBox,xcText)=$get(Text,"") "RTN","TMGXDLG",1812,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1813,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1814,0) if $data(InitHour) do "RTN","TMGXDLG",1815,0) . set Options(xcBox,xcHours)=InitDay "RTN","TMGXDLG",1816,0) . set Options(xcBox,xcMinutes)=$get(InitMinute,0) "RTN","TMGXDLG",1817,0) . set Options(xcBox,xcSeconds)=$get(InitSecond,0) "RTN","TMGXDLG",1818,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1819,0) "RTN","TMGXDLG",1820,0) do xtimesel(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1821,0) "RTN","TMGXDLG",1822,0) if Results(xcDlgResult)=0 set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1823,0) "RTN","TMGXDLG",1824,0) quit result; "RTN","TMGXDLG",1825,0) "RTN","TMGXDLG",1826,0) xtimesel(Options,Results,Modal) "RTN","TMGXDLG",1827,0) ;" --timebox <text> <height> <width> [<hours> <minutes> <seconds>] "RTN","TMGXDLG",1828,0) "RTN","TMGXDLG",1829,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1830,0) do SetCommons(.Options) "RTN","TMGXDLG",1831,0) do SetTrans(.Options) "RTN","TMGXDLG",1832,0) do ParamTextAdd(.Options," --timebox ") "RTN","TMGXDLG",1833,0) "RTN","TMGXDLG",1834,0) set Added=$$AddParam(.Options,,xcText,xcAddQuote) "RTN","TMGXDLG",1835,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1836,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1837,0) if $data(Options(xcHours)) do "RTN","TMGXDLG",1838,0) . set Added=$$AddParam(.Options,,xcHours,xcNotOptional) "RTN","TMGXDLG",1839,0) . set Added=$$AddParam(.Options,,xcMinutes,xcNotOptional) "RTN","TMGXDLG",1840,0) . set Added=$$AddParam(.Options,,xcSeconds,xcNotOptional) "RTN","TMGXDLG",1841,0) "RTN","TMGXDLG",1842,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1843,0) "RTN","TMGXDLG",1844,0) quit "RTN","TMGXDLG",1845,0) "RTN","TMGXDLG",1846,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1847,0) ;"TO BE COMPLETED "RTN","TMGXDLG",1848,0) "RTN","TMGXDLG",1849,0) xbuildlist(Options,Results,Modal) "RTN","TMGXDLG",1850,0) ;" --buildlist <text> <height> <width> <list height> <tag1> <item1> <status1> {<help1>}... "RTN","TMGXDLG",1851,0) "RTN","TMGXDLG",1852,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1853,0) ;"TO BE COMPLETED "RTN","TMGXDLG",1854,0) "RTN","TMGXDLG",1855,0) xcolorsel(Options,Results,Modal) "RTN","TMGXDLG",1856,0) ;" --colorsel <text> <height> <width> "RTN","TMGXDLG",1857,0) new Added "RTN","TMGXDLG",1858,0) "RTN","TMGXDLG",1859,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1860,0) do SetCommons(.Options) "RTN","TMGXDLG",1861,0) do SetTrans(.Options) "RTN","TMGXDLG",1862,0) do ParamTextAdd(.Options," --colorsel ") "RTN","TMGXDLG",1863,0) "RTN","TMGXDLG",1864,0) set Added=$$AddParam(.Options,,xcText,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1865,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1866,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1867,0) "RTN","TMGXDLG",1868,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1869,0) "RTN","TMGXDLG",1870,0) quit "RTN","TMGXDLG",1871,0) "RTN","TMGXDLG",1872,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1873,0) FontSel(InitFont,width,height,x,y) "RTN","TMGXDLG",1874,0) ;"Purpose: To provide an easier access to Xdialog function "RTN","TMGXDLG",1875,0) ;" Shows a font-pick "RTN","TMGXDLG",1876,0) ;"Input: InitFont -- name of initial font to show [Optional] "RTN","TMGXDLG",1877,0) ;" width,height -- the initial size of box. [Optional] "RTN","TMGXDLG",1878,0) ;" x,y -- the display location of the dialog [optional] "RTN","TMGXDLG",1879,0) ;"Output:(none) "RTN","TMGXDLG",1880,0) ;"Results: returns the selected date "RTN","TMGXDLG",1881,0) ;"Notes: (none) "RTN","TMGXDLG",1882,0) "RTN","TMGXDLG",1883,0) new Options "RTN","TMGXDLG",1884,0) new Results "RTN","TMGXDLG",1885,0) new result set result="" "RTN","TMGXDLG",1886,0) "RTN","TMGXDLG",1887,0) if $data(xcCommon)=0 do SetupConsts() "RTN","TMGXDLG",1888,0) "RTN","TMGXDLG",1889,0) set Options(xcBox,xcFontName)=$get(InitFont,"") "RTN","TMGXDLG",1890,0) set Options(xcBox,xcHeight)=$get(height,0) "RTN","TMGXDLG",1891,0) set Options(xcBox,xcWidth)=$get(width,0) "RTN","TMGXDLG",1892,0) if $data(x) set Options(xcTransient,xcBegin)=x_" "_$get(y,0) "RTN","TMGXDLG",1893,0) "RTN","TMGXDLG",1894,0) do xfontsel(.Options,.Results,xcModalMode) "RTN","TMGXDLG",1895,0) "RTN","TMGXDLG",1896,0) if Results(xcDlgResult)=0 set result=$get(Results(xcDlgOutput,"")) "RTN","TMGXDLG",1897,0) "RTN","TMGXDLG",1898,0) quit result; "RTN","TMGXDLG",1899,0) "RTN","TMGXDLG",1900,0) "RTN","TMGXDLG",1901,0) xfontsel(Options,Results,Modal) "RTN","TMGXDLG",1902,0) ;" --fontsel <font name> <height> <width> "RTN","TMGXDLG",1903,0) new Added "RTN","TMGXDLG",1904,0) "RTN","TMGXDLG",1905,0) do ParamTextAdd(.Options,vDialog) "RTN","TMGXDLG",1906,0) do SetCommons(.Options) "RTN","TMGXDLG",1907,0) do SetTrans(.Options) "RTN","TMGXDLG",1908,0) do ParamTextAdd(.Options," --fontsel ") "RTN","TMGXDLG",1909,0) "RTN","TMGXDLG",1910,0) set Added=$$AddParam(.Options,,xcFontName,xcNotOptional,xcAddQuote) "RTN","TMGXDLG",1911,0) set Added=$$AddParam(.Options,,xcHeight) "RTN","TMGXDLG",1912,0) set Added=$$AddParam(.Options,,xcWidth) "RTN","TMGXDLG",1913,0) "RTN","TMGXDLG",1914,0) do LaunchCmd(.Options,.Results,.Modal) "RTN","TMGXDLG",1915,0) "RTN","TMGXDLG",1916,0) quit "RTN","TMGXDLG",1917,0) "RTN","TMGXDLG",1918,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1919,0) ChClrScr() "RTN","TMGXDLG",1920,0) ;"Purpose: When working with text menus, after the dialog exits, "RTN","TMGXDLG",1921,0) ;" it leaves the drawing of the menu on the text screen. "RTN","TMGXDLG",1922,0) ;" So I'll have a function that clears the screen. "RTN","TMGXDLG",1923,0) ;"Note: I can't depend on the VistA system to have set up "RTN","TMGXDLG",1924,0) ;" variables that will clear the screen. So I'll do it quick and dirty "RTN","TMGXDLG",1925,0) ;" by many newline characters. "RTN","TMGXDLG",1926,0) "RTN","TMGXDLG",1927,0) new count "RTN","TMGXDLG",1928,0) "RTN","TMGXDLG",1929,0) for count=1:1:50 write ! "RTN","TMGXDLG",1930,0) "RTN","TMGXDLG",1931,0) quit "RTN","TMGXDLG",1932,0) "RTN","TMGXDLG",1933,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1934,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1935,0) "RTN","TMGXDLG",1936,0) SetCommons(Options) "RTN","TMGXDLG",1937,0) ;"Purpose: to put common options into a parameter string that will be sent to Xdialog "RTN","TMGXDLG",1938,0) ;"Input: Options -- MUST BE PASSED BY REFERENCE "RTN","TMGXDLG",1939,0) ;" See docs re. Options above. "RTN","TMGXDLG",1940,0) ;"Output: The Options array will contain an entry containing output string: "RTN","TMGXDLG",1941,0) ;" Options(xcCmdLine)=<composite options> "RTN","TMGXDLG",1942,0) "RTN","TMGXDLG",1943,0) new i "RTN","TMGXDLG",1944,0) new s set s=" " "RTN","TMGXDLG",1945,0) new AddQuote set AddQuote=0 "RTN","TMGXDLG",1946,0) "RTN","TMGXDLG",1947,0) if $data(xcCommon)=0 do SetupConsts() ;"Ensure constants created. "RTN","TMGXDLG",1948,0) "RTN","TMGXDLG",1949,0) "RTN","TMGXDLG",1950,0) set i=$order(Options(xcCommon,"")) "RTN","TMGXDLG",1951,0) for do q:i="" "RTN","TMGXDLG",1952,0) . if i=xcCmdLine quit "RTN","TMGXDLG",1953,0) . if (i'=xcCmdLine)&($data(Options(xcCommon,i))'=0) do "RTN","TMGXDLG",1954,0) . . set s=s_"--"_i_" " "RTN","TMGXDLG",1955,0) . . if $get(Options(xcCommon,i))'=1 do "RTN","TMGXDLG",1956,0) . . . set s=s_""""_Options(xcCommon,i)_""" " "RTN","TMGXDLG",1957,0) . set i=$order(Options(xcCommon,i)) "RTN","TMGXDLG",1958,0) "RTN","TMGXDLG",1959,0) ;"set Options(xcCmdLine)=s "RTN","TMGXDLG",1960,0) do ParamTextAdd(.Options,s) "RTN","TMGXDLG",1961,0) "RTN","TMGXDLG",1962,0) quit "RTN","TMGXDLG",1963,0) "RTN","TMGXDLG",1964,0) "RTN","TMGXDLG",1965,0) SetTrans(Options) "RTN","TMGXDLG",1966,0) ;"Purpose: to put transient options into a parameter string that will be sent to Xdialog "RTN","TMGXDLG",1967,0) ;"Input: Options -- MUST BE PASSED BY REFERENCE "RTN","TMGXDLG",1968,0) ;" See docs re. Options above. "RTN","TMGXDLG",1969,0) ;"Output: The Options array will contain an entry containing output string: "RTN","TMGXDLG",1970,0) ;" Options(xcCmdLine)=<composite options> "RTN","TMGXDLG",1971,0) ;"Note: This function should be called AFTER SetCommons() "RTN","TMGXDLG",1972,0) "RTN","TMGXDLG",1973,0) new i "RTN","TMGXDLG",1974,0) ;"new s set s=$get(Options(xcCmdLine)) "RTN","TMGXDLG",1975,0) new s set s=" " "RTN","TMGXDLG",1976,0) "RTN","TMGXDLG",1977,0) set i=$order(Options(xcTransient,"")) "RTN","TMGXDLG",1978,0) for do q:i="" "RTN","TMGXDLG",1979,0) . if i=xcCmdLine quit "RTN","TMGXDLG",1980,0) . if (i'=xcCmdLine)&($data(Options(xcTransient,i))'=0) do "RTN","TMGXDLG",1981,0) . . set s=s_"--"_i_" " "RTN","TMGXDLG",1982,0) . . if $get(Options(xcTransient,i))'=1 set s=s_Options(xcTransient,i)_" " "RTN","TMGXDLG",1983,0) . set i=$order(Options(xcTransient,i)) "RTN","TMGXDLG",1984,0) "RTN","TMGXDLG",1985,0) ;"set Options(xcCmdLine)=$get(Options(xcCmdLine))_s "RTN","TMGXDLG",1986,0) do ParamTextAdd(.Options,s) "RTN","TMGXDLG",1987,0) "RTN","TMGXDLG",1988,0) quit "RTN","TMGXDLG",1989,0) "RTN","TMGXDLG",1990,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",1991,0) "RTN","TMGXDLG",1992,0) AddParam(Options,N,index,optional,AddQuote) "RTN","TMGXDLG",1993,0) ;"Purpose: to add index'd box parameter to the composite parameters "RTN","TMGXDLG",1994,0) ;"Input: Options -- see above. MUST BE PASSED BY REFERENCE "RTN","TMGXDLG",1995,0) ;" N -- should NOT be passed, unless index item has a 'subscript', i.e.: "RTN","TMGXDLG",1996,0) ;" Options(xcBox,xcItem,1)="Bill" "RTN","TMGXDLG",1997,0) ;" Options(xcBox,xcItem,2)="Bill" "RTN","TMGXDLG",1998,0) ;" Options(xcBox,xcItem,3)="Bill" "RTN","TMGXDLG",1999,0) ;" index -- specifies which parameter to add (if found) "RTN","TMGXDLG",2000,0) ;" optional -- specifies if parameter is optional "RTN","TMGXDLG",2001,0) ;" default=not optional (0). Value of 1=is optional "RTN","TMGXDLG",2002,0) ;" AddQuote -- if parameter should be in quotes -- default is 0 / no "RTN","TMGXDLG",2003,0) ;"results: returns if data was added. (1=added, 0=not added) "RTN","TMGXDLG",2004,0) "RTN","TMGXDLG",2005,0) new result set result=0 "RTN","TMGXDLG",2006,0) new s,sCurrent "RTN","TMGXDLG",2007,0) new CurLine "RTN","TMGXDLG",2008,0) new Param "RTN","TMGXDLG",2009,0) "RTN","TMGXDLG",2010,0) set optional=$get(optional,xcNotOptional) "RTN","TMGXDLG",2011,0) if optional'=xcNotOptional set optional=xcOptional "RTN","TMGXDLG",2012,0) set AddQuote=$get(AddQuote,xcNoQuote) "RTN","TMGXDLG",2013,0) "RTN","TMGXDLG",2014,0) ;"write "Starting AddParam",! "RTN","TMGXDLG",2015,0) "RTN","TMGXDLG",2016,0) set s="" "RTN","TMGXDLG",2017,0) "RTN","TMGXDLG",2018,0) if $data(N) do ;"i.e. user is looking for a subscripted element... "RTN","TMGXDLG",2019,0) . set Param=$get(Options(xcBox,index,N)) "RTN","TMGXDLG",2020,0) else do ;"i.e. user is NOT looking for a subscripted element... "RTN","TMGXDLG",2021,0) . set Param=$get(Options(xcBox,index)) "RTN","TMGXDLG",2022,0) "RTN","TMGXDLG",2023,0) if Param'="" do ;"Parameter found. "RTN","TMGXDLG",2024,0) . if AddQuote set s=s_"""" "RTN","TMGXDLG",2025,0) . set s=s_Param "RTN","TMGXDLG",2026,0) . set result=1 "RTN","TMGXDLG",2027,0) else do ;"There has not been any parameter found. "RTN","TMGXDLG",2028,0) . if $data(N) quit ;"If user was looking for (absent) subscripted param, then ignore NotOptional "RTN","TMGXDLG",2029,0) . if (optional=xcNotOptional) do "RTN","TMGXDLG",2030,0) . . if AddQuote set s=s_"""" "RTN","TMGXDLG",2031,0) . . set s=s_"0" ;"put in a 0 for non-optional values. "RTN","TMGXDLG",2032,0) . . set result=1 "RTN","TMGXDLG",2033,0) "RTN","TMGXDLG",2034,0) if result=1 do "RTN","TMGXDLG",2035,0) . if (AddQuote=xcAddQuote) set s=s_""" " "RTN","TMGXDLG",2036,0) . else set s=s_" " "RTN","TMGXDLG",2037,0) "RTN","TMGXDLG",2038,0) do ParamTextAdd(.Options,s) "RTN","TMGXDLG",2039,0) "RTN","TMGXDLG",2040,0) "RTN","TMGXDLG",2041,0) quit result "RTN","TMGXDLG",2042,0) "RTN","TMGXDLG",2043,0) ParamTextAdd(Options,Text) "RTN","TMGXDLG",2044,0) ;"Purpose: to actually add the text of the new parameter etc "RTN","TMGXDLG",2045,0) ;" into the Options variable "RTN","TMGXDLG",2046,0) ;"Input: Options .. same as variable used everywhere else "RTN","TMGXDLG",2047,0) ;" MUST BE PASSED BY REFERENCE "RTN","TMGXDLG",2048,0) ;" Text -- the text to add "RTN","TMGXDLG",2049,0) "RTN","TMGXDLG",2050,0) new sCurrent "RTN","TMGXDLG",2051,0) new CurLine "RTN","TMGXDLG",2052,0) "RTN","TMGXDLG",2053,0) ;"First the simple way -- with max of ~230 characters "RTN","TMGXDLG",2054,0) set Options(xcCmdLine)=$get(Options(xcCmdLine))_Text "RTN","TMGXDLG",2055,0) "RTN","TMGXDLG",2056,0) ;"Next, array method, with unlimited length. "RTN","TMGXDLG",2057,0) set CurLine=$get(Options(xcCmdLine,xcCmdArray,xcCmdMaxLine),0) "RTN","TMGXDLG",2058,0) set sCurrent=$get(Options(xcCmdLine,xcCmdArray,CurLine)) "RTN","TMGXDLG",2059,0) if $length(sCurrent)>80 do "RTN","TMGXDLG",2060,0) . set CurLine=CurLine+1 "RTN","TMGXDLG",2061,0) . set sCurrent="" "RTN","TMGXDLG",2062,0) "RTN","TMGXDLG",2063,0) set sCurrent=sCurrent_Text "RTN","TMGXDLG",2064,0) ;"write "After additions, sCurrent=",sCurrent,! "RTN","TMGXDLG",2065,0) set Options(xcCmdLine,xcCmdArray,CurLine)=sCurrent "RTN","TMGXDLG",2066,0) set Options(xcCmdLine,xcCmdArray,xcCmdMaxLine)=CurLine "RTN","TMGXDLG",2067,0) quit "RTN","TMGXDLG",2068,0) "RTN","TMGXDLG",2069,0) "RTN","TMGXDLG",2070,0) LaunchCmd(Options,Results,Modal) "RTN","TMGXDLG",2071,0) ;"Purpose: To actually launch the dialog, and to retrieve results "RTN","TMGXDLG",2072,0) ;"Input: Options -- see Docs above. The only part of the Options array "RTN","TMGXDLG",2073,0) ;" that is used here is Options(xcCmdLine) "RTN","TMGXDLG",2074,0) ;" Results -- an array to pass results back in. "RTN","TMGXDLG",2075,0) ;" Modal -- if =xcModalMode, then execution does not continue until dialog is closed "RTN","TMGXDLG",2076,0) ;" if xcNonModal, then execution immediately continues. Note in this "RTN","TMGXDLG",2077,0) ;" case the result of the execution will be 0 (unless an error "RTN","TMGXDLG",2078,0) ;" occurs creating the dialog.) It will NOT be the result of "RTN","TMGXDLG",2079,0) ;" the user's button press. "RTN","TMGXDLG",2080,0) "RTN","TMGXDLG",2081,0) new Cmd,HookCmd "RTN","TMGXDLG",2082,0) new FileHandle "RTN","TMGXDLG",2083,0) new CommFPath set CommFPath="/tmp/" "RTN","TMGXDLG",2084,0) new CommFName set CommFName="M_xdialog_comm_"_$J_".tmp" "RTN","TMGXDLG",2085,0) new CommFile set CommFile=CommFPath_CommFName "RTN","TMGXDLG",2086,0) "RTN","TMGXDLG",2087,0) ;"set Cmd=vDialog_" "_$get(Options(xcCmdLine)) "RTN","TMGXDLG",2088,0) ;"set Cmd=Cmd_" 2>"_CommFile "RTN","TMGXDLG",2089,0) do ParamTextAdd(.Options," 2>"_CommFile) "RTN","TMGXDLG",2090,0) "RTN","TMGXDLG",2091,0) set Modal=$get(Modal,xcNonModal) "RTN","TMGXDLG",2092,0) if (Modal=xcNonModal) do "RTN","TMGXDLG",2093,0) . do ParamTextAdd(.Options," & ") "RTN","TMGXDLG",2094,0) "RTN","TMGXDLG",2095,0) new result,killme "RTN","TMGXDLG",2096,0) new FRef "RTN","TMGXDLG",2097,0) ;"write "--------------------------------------------------",! "RTN","TMGXDLG",2098,0) ;"zwr Options(xcCmdLine,xcCmdArray,*) "RTN","TMGXDLG",2099,0) set FRef=$name(Options(xcCmdLine,xcCmdArray,0)) "RTN","TMGXDLG",2100,0) set result=$$GTF^%ZISH(FRef,3,CommFPath,CommFName) "RTN","TMGXDLG",2101,0) "RTN","TMGXDLG",2102,0) ;"set HookCmd="cat "_CommFile "RTN","TMGXDLG",2103,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGXDLG",2104,0) ;"zsystem HookCmd "RTN","TMGXDLG",2105,0) "RTN","TMGXDLG",2106,0) ;"Explaination of following line: "RTN","TMGXDLG",2107,0) ;"I can't always pass the command in one string, because of limitation of string length "RTN","TMGXDLG",2108,0) ;"So I am writing out the command as a text file (to CommFile)--which will have the long "RTN","TMGXDLG",2109,0) ;"string divided up into multiple lines. However, the bash command shell "RTN","TMGXDLG",2110,0) ;"can't deal with the command split up like this. "RTN","TMGXDLG",2111,0) ;"I have researched to find this method of stripping newlines from the end of "RTN","TMGXDLG",2112,0) ;"a line--there are probably 8 other ways to do this too. :-) "RTN","TMGXDLG",2113,0) ;" echo `<file` >file "RTN","TMGXDLG",2114,0) ;"I then execute the file by typing: "RTN","TMGXDLG",2115,0) ;" sh file "RTN","TMGXDLG",2116,0) ;"And the two commands are separated on the line by a ";" "RTN","TMGXDLG",2117,0) ;"So the composite is: "RTN","TMGXDLG",2118,0) ;" echo `<file` >file ; sh file "RTN","TMGXDLG",2119,0) ;"Note that the instructions contained in 'file' include an instruction to put "RTN","TMGXDLG",2120,0) ;" the output from the dialog back into 'file'. This is ok, because it won't "RTN","TMGXDLG",2121,0) ;" be overwriten until after the command has started to execute. "RTN","TMGXDLG",2122,0) "RTN","TMGXDLG",2123,0) ;"set HookCmd="echo `<"_CommFile_"` >"_CommFile_" ; sh "_CommFile "RTN","TMGXDLG",2124,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGXDLG",2125,0) ;"zsystem HookCmd "RTN","TMGXDLG",2126,0) "RTN","TMGXDLG",2127,0) set HookCmd="echo `<"_CommFile_"` >"_CommFile "RTN","TMGXDLG",2128,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGXDLG",2129,0) zsystem HookCmd "RTN","TMGXDLG",2130,0) "RTN","TMGXDLG",2131,0) ;"set HookCmd="cat "_CommFile "RTN","TMGXDLG",2132,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGXDLG",2133,0) ;"zsystem HookCmd "RTN","TMGXDLG",2134,0) "RTN","TMGXDLG",2135,0) set HookCmd="sh "_CommFile "RTN","TMGXDLG",2136,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGXDLG",2137,0) zsystem HookCmd "RTN","TMGXDLG",2138,0) "RTN","TMGXDLG",2139,0) "RTN","TMGXDLG",2140,0) set Results(xcDlgResult)=$ZSYSTEM&255 ;"get result of execution. (low byte only) "RTN","TMGXDLG",2141,0) "RTN","TMGXDLG",2142,0) ;"Read output info Results "RTN","TMGXDLG",2143,0) ;"set HookCmd="cat "_CommFile "RTN","TMGXDLG",2144,0) ;"write "Here is hook command",!,!,HookCmd,!,! "RTN","TMGXDLG",2145,0) ;"zsystem HookCmd "RTN","TMGXDLG",2146,0) set FileHandle=$$FTG^%ZISH(CommFPath,CommFName,$name(Results(xcDlgOutput)),3) "RTN","TMGXDLG",2147,0) ;"zwr Results(*) "RTN","TMGXDLG",2148,0) "RTN","TMGXDLG",2149,0) ;"Now kill the communication file... no longer needed. "RTN","TMGXDLG",2150,0) new FileSpec "RTN","TMGXDLG",2151,0) set FileSpec(CommFile)="" "RTN","TMGXDLG",2152,0) set result=$$DEL^%ZISH(CommFPath,$name(FileSpec)) "RTN","TMGXDLG",2153,0) "RTN","TMGXDLG",2154,0) quit "RTN","TMGXDLG",2155,0) "RTN","TMGXDLG",2156,0) "RTN","TMGXDLG",2157,0) "RTN","TMGXDLG",2158,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",2159,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",2160,0) "RTN","TMGXDLG",2161,0) Demo "RTN","TMGXDLG",2162,0) ;"Purpose: To show the functionality of the library, and "RTN","TMGXDLG",2163,0) ;" to give a programming demo. "RTN","TMGXDLG",2164,0) "RTN","TMGXDLG",2165,0) "RTN","TMGXDLG",2166,0) new result "RTN","TMGXDLG",2167,0) new Feedback "RTN","TMGXDLG",2168,0) new s "RTN","TMGXDLG",2169,0) new UserPick,filename "RTN","TMGXDLG",2170,0) new UseGUI "RTN","TMGXDLG",2171,0) "RTN","TMGXDLG",2172,0) set UseGUI=0 "RTN","TMGXDLG",2173,0) "RTN","TMGXDLG",2174,0) do SetupConsts() "RTN","TMGXDLG",2175,0) "RTN","TMGXDLG",2176,0) do SetGUI(UseGUI) "RTN","TMGXDLG",2177,0) "RTN","TMGXDLG",2178,0) new List "RTN","TMGXDLG",2179,0) set List(1,xcTag)="Graphic" "RTN","TMGXDLG",2180,0) set List(1,xcItem)="Select this for full X-system GUI" "RTN","TMGXDLG",2181,0) set List(1,xcStatus)="on" "RTN","TMGXDLG",2182,0) set List(2,xcTag)="Text" "RTN","TMGXDLG",2183,0) set List(2,xcItem)="Select this for character interface" "RTN","TMGXDLG",2184,0) set List(2,xcStatus)="off" "RTN","TMGXDLG",2185,0) set UserPick=$$RadioList("Which type of boxes would you like to use?",.List) "RTN","TMGXDLG",2186,0) "RTN","TMGXDLG",2187,0) do ChClrScr^TMGXDLG() "RTN","TMGXDLG",2188,0) "RTN","TMGXDLG",2189,0) if UserPick="Graphic" do "RTN","TMGXDLG",2190,0) . set UseGUI=1 "RTN","TMGXDLG",2191,0) . do SetGUI(UseGUI) "RTN","TMGXDLG",2192,0) "RTN","TMGXDLG",2193,0) if UseGUI=0 goto l1 "RTN","TMGXDLG",2194,0) "RTN","TMGXDLG",2195,0) set s="Welcome to the Xdialog Demo \nThis box is 'non-modal' " "RTN","TMGXDLG",2196,0) set s=s_"so its program can continue without" "RTN","TMGXDLG",2197,0) set s=s_"waiting for a user response." "RTN","TMGXDLG",2198,0) set result=$$Msg("Welcome",s,0,0,xcNonModal,1,2) ;"height&width of 0,0 means "auto size" "RTN","TMGXDLG",2199,0) "RTN","TMGXDLG",2200,0) l1 "RTN","TMGXDLG",2201,0) set result=$$YesNo^TMGXDLG("Do you want to see a demo \n of this Xdialog wrapper library?") "RTN","TMGXDLG",2202,0) if result'=mrYes goto DemoDone "RTN","TMGXDLG",2203,0) "RTN","TMGXDLG",2204,0) ;"Note: This don't seem to work in character mode... "RTN","TMGXDLG",2205,0) set s="OK, Check out this 'Info' box. It will auto close in 6 seconds" "RTN","TMGXDLG",2206,0) set result=$$Info(s,0,0,6,xcModalMode) "RTN","TMGXDLG",2207,0) "RTN","TMGXDLG",2208,0) new List "RTN","TMGXDLG",2209,0) set List(1,xcTag)="Edit box" "RTN","TMGXDLG",2210,0) set List(1,xcItem)="Select this for an Edit Box" "RTN","TMGXDLG",2211,0) set List(1,xcStatus)="on" "RTN","TMGXDLG",2212,0) set List(2,xcTag)="Log box" "RTN","TMGXDLG",2213,0) set List(2,xcItem)="Select this for a Log Box" "RTN","TMGXDLG",2214,0) set List(2,xcStatus)="off" "RTN","TMGXDLG",2215,0) set List(3,xcTag)="Text box" "RTN","TMGXDLG",2216,0) set List(3,xcItem)="Select this for a Text Box" "RTN","TMGXDLG",2217,0) set List(3,xcStatus)="off" "RTN","TMGXDLG",2218,0) set List(4,xcTag)="Tail box" "RTN","TMGXDLG",2219,0) set List(4,xcItem)="Select this for a Tail Box" "RTN","TMGXDLG",2220,0) set List(4,xcStatus)="off" "RTN","TMGXDLG",2221,0) set UserPick=$$RadioList("Select Tool to See",.List) "RTN","TMGXDLG",2222,0) "RTN","TMGXDLG",2223,0) write "You selected: ",UserPick,! "RTN","TMGXDLG",2224,0) "RTN","TMGXDLG",2225,0) ;"Note: This don't seem to work in character mode... "RTN","TMGXDLG",2226,0) if UserPick'="" do "RTN","TMGXDLG",2227,0) . set filename=$$FileSel("Select a file to load") "RTN","TMGXDLG",2228,0) . if UserPick="Edit box" do quit "RTN","TMGXDLG",2229,0) . . set result=$$Edit(filename,0,0,.Feedback) "RTN","TMGXDLG",2230,0) . if UserPick="Log box" do quit "RTN","TMGXDLG",2231,0) . . set result=$$Log(filename,0,0,xcModalMode) "RTN","TMGXDLG",2232,0) . if UserPick="Text box" do quit "RTN","TMGXDLG",2233,0) . . set result=$$Text(filename,0,0,xcModalMode) "RTN","TMGXDLG",2234,0) . if UserPick="Tail box" do quit "RTN","TMGXDLG",2235,0) . . set result=$$Tail(filename,0,0,xcModalMode) "RTN","TMGXDLG",2236,0) "RTN","TMGXDLG",2237,0) new FName,LName,Zip "RTN","TMGXDLG",2238,0) new DumpVar "RTN","TMGXDLG",2239,0) "RTN","TMGXDLG",2240,0) set result=$$Input("Enter Name",0,0,"John",.FName) "RTN","TMGXDLG",2241,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2242,0) write "Here is name:",FName,! "RTN","TMGXDLG",2243,0) ;"read "Press any key to coninue",*DumpVar,! "RTN","TMGXDLG",2244,0) "RTN","TMGXDLG",2245,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2246,0) set result=$$Input2("Enter Name",0,0,"First","John","Last","Smith",.FName,.LName) "RTN","TMGXDLG",2247,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2248,0) write "Here is name:",FName," ",LName,! "RTN","TMGXDLG",2249,0) ;"read "Press any key to coninue",*DumpVar,! "RTN","TMGXDLG",2250,0) "RTN","TMGXDLG",2251,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2252,0) set result=$$Input3("Enter Name",0,0,"First","John","Last","Smith","Zip","12345",.FName,.LName,.Zip) "RTN","TMGXDLG",2253,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2254,0) write "Here is name:",FName," ",LName,! "RTN","TMGXDLG",2255,0) write "zip: ",Zip,! "RTN","TMGXDLG",2256,0) "RTN","TMGXDLG",2257,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2258,0) kill List "RTN","TMGXDLG",2259,0) set List(1)="Cookies" "RTN","TMGXDLG",2260,0) set List(2)="Ice Cream" "RTN","TMGXDLG",2261,0) set List(3)="Cake" "RTN","TMGXDLG",2262,0) set result=$$Combo("Pick your favorite dessert:",0,0,.List) "RTN","TMGXDLG",2263,0) write "You picked: ",result,! "RTN","TMGXDLG",2264,0) "RTN","TMGXDLG",2265,0) new Result1,Result2,Result3 "RTN","TMGXDLG",2266,0) "RTN","TMGXDLG",2267,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2268,0) set result=$$Range("Enter some numbers",0,0,25,250,100,.Result1) "RTN","TMGXDLG",2269,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2270,0) write "$=",Result1,! "RTN","TMGXDLG",2271,0) "RTN","TMGXDLG",2272,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2273,0) set result=$$Range2("Enter some numbers",0,0,"$",25,250,100,"%",33,66,44,.Result1,.Result2) "RTN","TMGXDLG",2274,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2275,0) write "$=",Result1," and %=",Result2,! "RTN","TMGXDLG",2276,0) "RTN","TMGXDLG",2277,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2278,0) set result=$$Range3("Enter some numbers",0,0,"$",25,250,100,"%",33,66,44,"#",1000,2000,1500,.Result1,.Result2,.Result3) "RTN","TMGXDLG",2279,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2280,0) write "$=",Result1," and %=",Result2," and #=",Result3,! "RTN","TMGXDLG",2281,0) "RTN","TMGXDLG",2282,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2283,0) set result=$$Spin("Enter a number",0,0,"$",25,250,100,.Result1) "RTN","TMGXDLG",2284,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2285,0) write "$=",Result1,! "RTN","TMGXDLG",2286,0) "RTN","TMGXDLG",2287,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2288,0) set result=$$Spin2("Enter some numbers",0,0,"$",25,250,100,"%",33,66,44,.Result1,.Result2) "RTN","TMGXDLG",2289,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2290,0) write "$=",Result1," and %=",Result2,! "RTN","TMGXDLG",2291,0) "RTN","TMGXDLG",2292,0) ;"Note: This not supported in character mode... "RTN","TMGXDLG",2293,0) set result=$$Spin3("Enter some numbers",0,0,"$",25,250,100,"%",33,66,44,"#",1000,2000,1500,.Result1,.Result2,.Result3) "RTN","TMGXDLG",2294,0) if result=mrCancel goto GBye "RTN","TMGXDLG",2295,0) write "$=",Result1," and %=",Result2," and #=",Result3,! "RTN","TMGXDLG",2296,0) "RTN","TMGXDLG",2297,0) GBye "RTN","TMGXDLG",2298,0) set result=$$Msg("Goodbye","That''s all for now folks!",0,0,xcModalMode) "RTN","TMGXDLG",2299,0) "RTN","TMGXDLG",2300,0) if UseGUI=0 do ChClrScr^TMGXDLG() "RTN","TMGXDLG",2301,0) "RTN","TMGXDLG",2302,0) DemoDone "RTN","TMGXDLG",2303,0) quit "RTN","TMGXDLG",2304,0) "RTN","TMGXDLG",2305,0) "RTN","TMGXDLG",2306,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXDLG",2307,0) ;"Progress Notes: "RTN","TMGXDLG",2308,0) ;"9-26-04 On my server, Xdialog was missing. I had to simply copy the "RTN","TMGXDLG",2309,0) ;" Xdialog file into /usr/bin ... I ought to have some way to "RTN","TMGXDLG",2310,0) ;" check for existance of file and give message if it is absent. "RTN","TMGXDLG",2311,0) ;"=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- "RTN","TMGXGF") 0^98^B43054173 "RTN","TMGXGF",1,0) TMGXGF ;SFISC/VYD - Graphics Functions ;11/06/2002 11:10 "RTN","TMGXGF",2,0) ;;8.0;KERNEL;**269**;5/5/07 by kt "RTN","TMGXGF",3,0) ; "RTN","TMGXGF",4,0) PREP ;prepair graphics environment "RTN","TMGXGF",5,0) D PREP^XGSETUP "RTN","TMGXGF",6,0) D CLRCLIP ;"//kt 5/5/07 added "RTN","TMGXGF",7,0) Q "RTN","TMGXGF",8,0) ; "RTN","TMGXGF",9,0) ; "RTN","TMGXGF",10,0) IOXY(R,C) ;cursor positioning R:row, C:col "RTN","TMGXGF",11,0) D ADJRC "RTN","TMGXGF",12,0) ;"//kt 5/6/07 modification. "RTN","TMGXGF",13,0) ;"Although this XGF system allows for off-screen coordinates, the underlying "RTN","TMGXGF",14,0) ;" M systems will not. So trying to position cursor to (-4,-5) MUST result "RTN","TMGXGF",15,0) ;" in cursor being put at (0,0). This may be worked around by not depending "RTN","TMGXGF",16,0) ;" on the current $X,$Y for writing etc. Instead, always specify coordinates. "RTN","TMGXGF",17,0) S:R<0 R=0 ;"//kt "RTN","TMGXGF",18,0) S:C<0 C=0 ;"//kt "RTN","TMGXGF",19,0) d CLIOXY^TMGXGS(R,C,"") "RTN","TMGXGF",20,0) S $Y=R,$X=C "RTN","TMGXGF",21,0) Q "RTN","TMGXGF",22,0) ; "RTN","TMGXGF",23,0) ; "RTN","TMGXGF",24,0) SAY(R,C,S,A) ;coordinate output instead of WRITE "RTN","TMGXGF",25,0) D ADJRC "RTN","TMGXGF",26,0) ;"//kt 5/6/07 mod. Clipping to occur in CLIOXY^TMGXGS() "RTN","TMGXGF",27,0) ;"S:C+$L(S)>IOM S=$E(S,1,IOM-C) ;truncate if longer than screen "RTN","TMGXGF",28,0) I $L($G(A)) S A=$$UP^XLFSTR(A) D SAY^TMGXGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1 "RTN","TMGXGF",29,0) E D SAY^TMGXGS(R,C,S) "RTN","TMGXGF",30,0) Q "RTN","TMGXGF",31,0) ; "RTN","TMGXGF",32,0) ; "RTN","TMGXGF",33,0) VSAY(R,C,S,A) ;coordinate output instead of WRITE: Vertical write ;"//kt added 5/10/07 "RTN","TMGXGF",34,0) D ADJRC "RTN","TMGXGF",35,0) I $L($G(A)) S A=$$UP^XLFSTR(A) D VSAY^TMGXGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1 "RTN","TMGXGF",36,0) E D VSAY^TMGXGS(R,C,S) "RTN","TMGXGF",37,0) Q "RTN","TMGXGF",38,0) ; "RTN","TMGXGF",39,0) ; "RTN","TMGXGF",40,0) SAYU(R,C,S,A) ;coordinate output w/ underline instead of WRITE "RTN","TMGXGF",41,0) D ADJRC "RTN","TMGXGF",42,0) I $L($G(A)) S A=$$UP^XLFSTR(A) D SAYU^TMGXGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1 "RTN","TMGXGF",43,0) E D SAYU^TMGXGS(R,C,S) "RTN","TMGXGF",44,0) Q "RTN","TMGXGF",45,0) ; "RTN","TMGXGF",46,0) ; "RTN","TMGXGF",47,0) ADJRC ;adjust row and column R and C are assumed to exist "RTN","TMGXGF",48,0) S R=$S($G(R)="":$Y,1:R),C=$S($G(C)="":$X,1:C) ;use current coords if none are passed "RTN","TMGXGF",49,0) ;"//kt 5/6/07 modified. NOTE: it seems that code was written to allow coords "RTN","TMGXGF",50,0) ;" to be specified as relative to $X,$Y. E.g. SAY(+4,-2,'HELLO'). "RTN","TMGXGF",51,0) ;" I must remove this functionality so that I can allow specifying coordinates that "RTN","TMGXGF",52,0) ;" are offscreen. Thus if the left-hand part of a window is a bit off the left "RTN","TMGXGF",53,0) ;" side of the screen, then C will be -2 etc. "RTN","TMGXGF",54,0) ;"S:"+-"[$E(R) R=$Y+$S(R="+":1,R="-":-1,1:R) ;increment/decrement "RTN","TMGXGF",55,0) ;"S:"+-"[$E(C) C=$X+$S(C="+":1,C="-":-1,1:C) "RTN","TMGXGF",56,0) ;"S R=$S(R<0:0,1:R\1),C=$S(C<0:0,1:C\1) ;make sure only pos int "RTN","TMGXGF",57,0) ;"//kt modified line below "RTN","TMGXGF",58,0) S R=R\1,C=C\1 ;"make sure only integer values (clipping will occur in CLIOXY()) "RTN","TMGXGF",59,0) Q "RTN","TMGXGF",60,0) ; "RTN","TMGXGF",61,0) ; "RTN","TMGXGF",62,0) SETA(XGATR) ;set screen attribute(s) regardless of previous state "RTN","TMGXGF",63,0) ;XGATR=1 char when converted to binary represents all new attr "RTN","TMGXGF",64,0) N XGOLDX,XGOLDY "RTN","TMGXGF",65,0) S XGOLDX=$X,XGOLDY=$Y ;save $X $Y "RTN","TMGXGF",66,0) W $$SET^XGSA(XGATR) "RTN","TMGXGF",67,0) S $X=XGOLDX,$Y=XGOLDY ;restore $X $Y "RTN","TMGXGF",68,0) Q "RTN","TMGXGF",69,0) ; "RTN","TMGXGF",70,0) ; "RTN","TMGXGF",71,0) CHGA(XGATR) ;change screen attribute(s) w/ respect to previous state "RTN","TMGXGF",72,0) ;XGNEWATR=string of attr to change eg. "B0U1" or "E1" "RTN","TMGXGF",73,0) N XGOLDX,XGOLDY,XGSYNTX,XGACODE,% "RTN","TMGXGF",74,0) S XGATR=$$UP^XLFSTR(XGATR) ;make sure all attr codes are in upper case "RTN","TMGXGF",75,0) D:$$ATRSYNTX(XGATR) "RTN","TMGXGF",76,0) . S XGOLDX=$X,XGOLDY=$Y ;save $X $Y "RTN","TMGXGF",77,0) . W $$CHG^XGSA(XGATR) "RTN","TMGXGF",78,0) . S $X=XGOLDX,$Y=XGOLDY ;restore $X $Y "RTN","TMGXGF",79,0) Q "RTN","TMGXGF",80,0) ; "RTN","TMGXGF",81,0) ; "RTN","TMGXGF",82,0) ATRSYNTX(XGATR) ;check attribute code syntax "RTN","TMGXGF",83,0) ;proper attr is 1 or more (char from {BIRGUE} concat w/ 1 or 0) "RTN","TMGXGF",84,0) N XGSYNTX,% "RTN","TMGXGF",85,0) S XGSYNTX=$S($L(XGATR)&($L(XGATR)#2=0):1,1:0) ;even # of chars "RTN","TMGXGF",86,0) F %=1:2:$L(XGATR) S:"B1B0I1I0R1R0G1G0U1U0E1"'[$E(XGATR,%,%+1) XGSYNTX=0 "RTN","TMGXGF",87,0) Q XGSYNTX "RTN","TMGXGF",88,0) ; "RTN","TMGXGF",89,0) ; "RTN","TMGXGF",90,0) RESTORE(S) ;restore screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT "RTN","TMGXGF",91,0) D RESTORE^TMGXGSW(S) Q "RTN","TMGXGF",92,0) K @S "RTN","TMGXGF",93,0) ; "RTN","TMGXGF",94,0) ; "RTN","TMGXGF",95,0) SAVE(T,L,B,R,S) ;save screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT "RTN","TMGXGF",96,0) D SAVE^TMGXGSW(T,L,B,R,S) Q "RTN","TMGXGF",97,0) ; "RTN","TMGXGF",98,0) ; "RTN","TMGXGF",99,0) WIN(T,L,B,R,S) ;put up a window TOP,LEFT,BOTTOM,RIGHT[,SAVE ROOT] "RTN","TMGXGF",100,0) ;window style is not yet implemented "RTN","TMGXGF",101,0) I $L($G(S)) D WIN^TMGXGSW(T,L,B,R,S) I 1 "RTN","TMGXGF",102,0) E D WIN^TMGXGSW(T,L,B,R) "RTN","TMGXGF",103,0) Q "RTN","TMGXGF",104,0) ; "RTN","TMGXGF",105,0) ; "RTN","TMGXGF",106,0) FRAME(T,L,B,R) ;put a frame without clearing the inside TOP,LEFT,BOTTOM,RIGHT "RTN","TMGXGF",107,0) D FRAME^TMGXSBOX(T,L,B,R) Q "RTN","TMGXGF",108,0) ; "RTN","TMGXGF",109,0) ; "RTN","TMGXGF",110,0) CLEAR(T,L,B,R) ;clear screen portion TOP,LEFT,BOTTOM,RIGHT "RTN","TMGXGF",111,0) D CLEAR^TMGXSBOX(T,L,B,R) Q "RTN","TMGXGF",112,0) ; "RTN","TMGXGF",113,0) ; "RTN","TMGXGF",114,0) CLEAN ;clean up and destroy graphics environment "RTN","TMGXGF",115,0) D CLEAN^XGSETUP Q "RTN","TMGXGF",116,0) ; "RTN","TMGXGF",117,0) ; "RTN","TMGXGF",118,0) INITKB(XGTRM) ;initialize keyboard "RTN","TMGXGF",119,0) ;turn escape processing on, turn on passed terminators (if any) "RTN","TMGXGF",120,0) D INIT^XGKB($G(XGTRM)) Q "RTN","TMGXGF",121,0) ; "RTN","TMGXGF",122,0) ; "RTN","TMGXGF",123,0) READ(XGCHARS,XGTO) ;read the keyboard "RTN","TMGXGF",124,0) ;XGCHARS:number of chars to read, XGTO:timeout "RTN","TMGXGF",125,0) ;"//kt 5/5/07 modified to allow putting characters back. "RTN","TMGXGF",126,0) new TMGRESLT set TMGRESLT="" "RTN","TMGXGF",127,0) if ($get(TMGWCBUF)="")&($get(TMGWXGRT)="") do "RTN","TMGXGF",128,0) . set TMGRESLT=$$READ^XGKB($G(XGCHARS),$G(XGTO)) "RTN","TMGXGF",129,0) else do "RTN","TMGXGF",130,0) . set TMGRESLT=$get(TMGWCBUF) set TMGWCBUF="" "RTN","TMGXGF",131,0) . set XGRT=$get(TMGWXGRT) set TMGWXGRT="" "RTN","TMGXGF",132,0) quit TMGRESLT "RTN","TMGXGF",133,0) ; "RTN","TMGXGF",134,0) ; "RTN","TMGXGF",135,0) UNREAD(XGCHARS,XGRT) ;"//kt 5/5/07 added. "RTN","TMGXGF",136,0) ;Purpose: to put characters back into read stream after a READ "RTN","TMGXGF",137,0) ; Note: may only be called once before a subsequent READ, or will overwrite "RTN","TMGXGF",138,0) ;Input: XGCHARS -- the character(s) to put back into stream "RTN","TMGXGF",139,0) ; XGRT -- the command characters to put back into stream (i.e. XGRT) "RTN","TMGXGF",140,0) set TMGWCBUF=XGCHARS "RTN","TMGXGF",141,0) set TMGWXGRT=XGRT "RTN","TMGXGF",142,0) quit "RTN","TMGXGF",143,0) ; "RTN","TMGXGF",144,0) ; "RTN","TMGXGF",145,0) RESETKB ;reset keyboard(escape processing off, terminators off) "RTN","TMGXGF",146,0) D EXIT^XGKB Q "RTN","TMGXGF",147,0) ; "RTN","TMGXGF",148,0) ; "RTN","TMGXGF",149,0) SETCLIP(T,L,B,R) ;"//kt 5/5/07 added "RTN","TMGXGF",150,0) ;Pupose: define a clipping area. XGF writes clipped to area "RTN","TMGXGF",151,0) ;Input: TOP,LEFT,BOTTOM,ROGHT "RTN","TMGXGF",152,0) set TMGCLT=+$get(T),TMGCLL=$get(L) "RTN","TMGXGF",153,0) set TMGCLB=+$get(B),TMGCLR=$get(R) "RTN","TMGXGF",154,0) quit "RTN","TMGXGF",155,0) ; "RTN","TMGXGF",156,0) ; "RTN","TMGXGF",157,0) CLRCLIP ;"//kt 5/5/07 added "RTN","TMGXGF",158,0) ;Pupose: clear clipping area. "RTN","TMGXGF",159,0) set TMGCLT=0,TMGCLL=0 "RTN","TMGXGF",160,0) set TMGCLB=IOSL-1,TMGCLR=IOM-1 "RTN","TMGXGF",161,0) quit "RTN","TMGXGS") 0^99^B32818030 "RTN","TMGXGS",1,0) TMGXGS ;SFISC/VYD - SCREEN PRIMITIVES ;03/16/95 11:00 "RTN","TMGXGS",2,0) ;;8.0;KERNEL;;5/7/07 by //kt "RTN","TMGXGS",3,0) SAY(R,C,S,A) ;use this for coordinate output instead of WRITE "RTN","TMGXGS",4,0) ;output to screen and update virtual screen (XGSCRN) "RTN","TMGXGS",5,0) ;params: Row (0-IOSL),Col (0-IOM),string, "RTN","TMGXGS",6,0) ;scrn attrib ie. I1R0B1 (optional) "RTN","TMGXGS",7,0) N XGSAVATR,XGESC,XGOUTPUT ;save attribute,escape str,output stream "RTN","TMGXGS",8,0) N % "RTN","TMGXGS",9,0) ;set output stream to either XGSCRN (virtual screen) or some window "RTN","TMGXGS",10,0) S XGOUTPUT=$S($G(XGFLAG("PAINT"),21)=21:"XGSCRN",1:$NA(^TMP("XGS",$J,XGW1))) "RTN","TMGXGS",11,0) S XGSAVATR=XGCURATR ;preserve current attribute to restore later "RTN","TMGXGS",12,0) S $X=C+$L(S) "RTN","TMGXGS",13,0) S XGESC=$S($L($G(A)):$$CHG^XGSA(A),1:"") "RTN","TMGXGS",14,0) S $E(@XGOUTPUT@(R,0),(C+1),$X)=S "RTN","TMGXGS",15,0) S $E(@XGOUTPUT@(R,1),(C+1),$X)=$TR($J("",$L(S))," ",XGCURATR) "RTN","TMGXGS",16,0) ;S $P(%,XGCURATR,$L(S)+1)="",$E(@XGOUTPUT@(R,1),(C+1),$X)=% "RTN","TMGXGS",17,0) I XGOUTPUT="XGSCRN" D I 1 ;if screen painting is to occur "RTN","TMGXGS",18,0) . ;output string in a proper place in proper attribute and restore attr "RTN","TMGXGS",19,0) . ;;W $$IOXY(R,C)_XGESC_S_$S($L($G(A)):$$SET^XGSA(XGSAVATR),1:"") "RTN","TMGXGS",20,0) . ;W $$IOXY(R,C)_XGESC_S_$S(XGSAVATR'=XGCURATR:$$SET^XGSA(XGSAVATR),1:"") "RTN","TMGXGS",21,0) . DO CLIOXY(R,C,XGESC_S_$S(XGSAVATR'=XGCURATR:$$SET^XGSA(XGSAVATR),1:"")) "RTN","TMGXGS",22,0) . S $Y=R,$X=C+$L(S)-1 "RTN","TMGXGS",23,0) E S XGCURATR=XGSAVATR "RTN","TMGXGS",24,0) Q "RTN","TMGXGS",25,0) ; "RTN","TMGXGS",26,0) ; "RTN","TMGXGS",27,0) VSAY(R,C,S,A) ;"//kt added 5/10/07 "RTN","TMGXGS",28,0) ;use this for coordinate output instead of WRITE ("Vertical write") "RTN","TMGXGS",29,0) ;output to screen and update virtual screen (XGSCRN) "RTN","TMGXGS",30,0) ;params: Row (0-IOSL),Col (0-IOM),string, "RTN","TMGXGS",31,0) ;scrn attrib ie. I1R0B1 (optional) "RTN","TMGXGS",32,0) ;"Note: write is from top to bottom "RTN","TMGXGS",33,0) N XGSAVATR,XGESC,XGOUTPUT ;save attribute,escape str,output stream "RTN","TMGXGS",34,0) N % "RTN","TMGXGS",35,0) ;set output stream to either XGSCRN (virtual screen) or some window "RTN","TMGXGS",36,0) S XGOUTPUT=$S($G(XGFLAG("PAINT"),21)=21:"XGSCRN",1:$NA(^TMP("XGS",$J,XGW1))) "RTN","TMGXGS",37,0) S XGSAVATR=XGCURATR ;preserve current attribute to restore later "RTN","TMGXGS",38,0) new TMGi "RTN","TMGXGS",39,0) for TMGi=1:1:$L(S) do ;"write each character sequentially "RTN","TMGXGS",40,0) . new SS set SS=$E(S,TMGi) "RTN","TMGXGS",41,0) . S XGESC=$S($L($G(A)):$$CHG^XGSA(A),1:"") "RTN","TMGXGS",42,0) . S $X=C+1 "RTN","TMGXGS",43,0) . S $E(@XGOUTPUT@(R,0),(C+1),$X)=SS "RTN","TMGXGS",44,0) . S $E(@XGOUTPUT@(R,1),(C+1),$X)=$TR(" "," ",XGCURATR) ;"<-- '??' "RTN","TMGXGS",45,0) . I XGOUTPUT="XGSCRN" D I 1 ;if screen painting is to occur "RTN","TMGXGS",46,0) . . ;output string in a proper place in proper attribute and restore attr "RTN","TMGXGS",47,0) . . DO CLIOXY(R,C,XGESC_SS_$S(XGSAVATR'=XGCURATR:$$SET^XGSA(XGSAVATR),1:"")) "RTN","TMGXGS",48,0) . . if TMGi'=$L(S) S R=R+1 "RTN","TMGXGS",49,0) . . set $X=C,$Y=R "RTN","TMGXGS",50,0) . E S XGCURATR=XGSAVATR "RTN","TMGXGS",51,0) Q "RTN","TMGXGS",52,0) ; "RTN","TMGXGS",53,0) ; "RTN","TMGXGS",54,0) SAYU(R,C,S,A) ;use this for coordinate output instead of WRITE "RTN","TMGXGS",55,0) ;output to screen and update virtual screen (XGSCRN) "RTN","TMGXGS",56,0) ;params: Row (0-IOSL),Col (0-IOM),string, "RTN","TMGXGS",57,0) ;scrn attrib ie. I1R0B1 (optional) "RTN","TMGXGS",58,0) N XGSAVATR,XGESC,XGOUTPUT ;save attribute,escape str,output stream "RTN","TMGXGS",59,0) N %,%S,P,P1,P2,X ;P1:piece before &, P2:piece from & to the end "RTN","TMGXGS",60,0) N XGATR "RTN","TMGXGS",61,0) ;set output stream to either XGSCRN (virtual screen) or some window "RTN","TMGXGS",62,0) S XGOUTPUT=$S($G(XGFLAG("PAINT"),21)=21:"XGSCRN",1:$NA(^TMP("XGS",$J,XGW1))) "RTN","TMGXGS",63,0) S P=$L(S,"&&") "RTN","TMGXGS",64,0) F %=1:1:P S $P(X,$C(1),%)=$P(S,"&&",%) ;replace all && with $C(1) "RTN","TMGXGS",65,0) I X["&",$G(A)'["U1",'$$STAT^XGSA("U")!($G(A)["U0") D I 1 "RTN","TMGXGS",66,0) . S XGSAVATR=XGCURATR ;preserve current attribute to restore later "RTN","TMGXGS",67,0) . S XGESC=$S($L($G(A)):$$CHG^XGSA(A),1:"") "RTN","TMGXGS",68,0) . S XGATR=XGCURATR ;get pre-underline attributes "RTN","TMGXGS",69,0) . S $X=C+$L(X)-1 ;adjust for a single &, which is not printable "RTN","TMGXGS",70,0) . ;S $E(XGSCRN(R,0),(C+1),$X)=$TR($TR(X,"&",""),$C(1),"&") "RTN","TMGXGS",71,0) . S $E(@XGOUTPUT@(R,0),(C+1),$X)=$TR($P(X,"&")_$P(X,"&",2,999),$C(1),"&") "RTN","TMGXGS",72,0) . S $E(@XGOUTPUT@(R,1),(C+1),$X)=$TR($J("",$X-C)," ",XGCURATR) "RTN","TMGXGS",73,0) . S P1=$TR($P(X,"&"),$C(1),"&"),P2=$TR($P(X,"&",2,999),$C(1),"&") "RTN","TMGXGS",74,0) . S %S=P1_$$CHG^XGSA("U1")_$E(P2) ;preunderline_underlinechar "RTN","TMGXGS",75,0) . S $E(@XGOUTPUT@(R,1),(C+1+$L(P1)))=XGCURATR ;record underlinechar "RTN","TMGXGS",76,0) . ;S %S=%S_$$CHG^XGSA("U0")_$E(P2,2,999) ;%S_postunderline "RTN","TMGXGS",77,0) . S %S=%S_$$SET^XGSA(XGATR)_$E(P2,2,999) ;%S_postunderline "RTN","TMGXGS",78,0) . I XGOUTPUT="XGSCRN" D I 1 "RTN","TMGXGS",79,0) . . ;output string in a proper place in proper attribute and restore attr "RTN","TMGXGS",80,0) . . ;;W $$IOXY(R,C)_XGESC_%S_$S($L($G(A)):$$SET^XGSA(XGSAVATR),1:"") "RTN","TMGXGS",81,0) . . ;W $$IOXY(R,C)_XGESC_%S_$S(XGCURATR'=XGSAVATR:$$SET^XGSA(XGSAVATR),1:"") "RTN","TMGXGS",82,0) . . DO CLIOXY(R,C,XGESC_%S_$S(XGCURATR'=XGSAVATR:$$SET^XGSA(XGSAVATR),1:"")) "RTN","TMGXGS",83,0) . . S $Y=R,$X=C+$L(X)-2 "RTN","TMGXGS",84,0) . E S XGCURATR=XGSAVATR "RTN","TMGXGS",85,0) E D SAY(R,C,$TR(S,"&"),A):$D(A),SAY(R,C,$TR(S,"&")):'$D(A) "RTN","TMGXGS",86,0) Q "RTN","TMGXGS",87,0) ; "RTN","TMGXGS",88,0) ; "RTN","TMGXGS",89,0) IOXY(R,C) ;cursor positioning WRITE argument instead of execute "RTN","TMGXGS",90,0) ;Row,Col "RTN","TMGXGS",91,0) Q $C(27,91)_((R+1))_$C(59)_((C+1))_$C(72) "RTN","TMGXGS",92,0) ; "RTN","TMGXGS",93,0) ; "RTN","TMGXGS",94,0) CLIOXY(R,C,S) ;"5/5/07 //kt added "RTN","TMGXGS",95,0) ;Purpose: a unified function for writing to screen, that also handles clipping "RTN","TMGXGS",96,0) ;Input: R,C -- row and column "RTN","TMGXGS",97,0) ; S -- TEXT to put to screen. "RTN","TMGXGS",98,0) I (R<TMGCLT)!(R>TMGCLB) GOTO CLDONE "RTN","TMGXGS",99,0) I (C>TMGCLR) GOTO CLDONE "RTN","TMGXGS",100,0) I (C<TMGCLL) DO ;clip leftward "RTN","TMGXGS",101,0) . new ESC set ESC="" "RTN","TMGXGS",102,0) . if $EXTRACT(S,1)=$CHAR(27) do "RTN","TMGXGS",103,0) CL1 . . do CLIPESC(.S,.ESC) ;"remove leading escape sequences prior to clipping. "RTN","TMGXGS",104,0) . NEW TMGCLIP SET TMGCLIP=TMGCLL-C "RTN","TMGXGS",105,0) . SET S=ESC_$EXTRACT(S,1+TMGCLIP,9999) "RTN","TMGXGS",106,0) . SET C=TMGCLL "RTN","TMGXGS",107,0) "RTN","TMGXGS",108,0) WRITE $$IOXY(R,C) ;position to R,C "RTN","TMGXGS",109,0) NEW TMGSPL S TMGSPL=TMGCLR-C+1 ;find space left to clipping margin "RTN","TMGXGS",110,0) WRITE $EXTRACT(S,1,TMGSPL) "RTN","TMGXGS",111,0) CLDONE "RTN","TMGXGS",112,0) quit "RTN","TMGXGS",113,0) "RTN","TMGXGS",114,0) CLIPESC(S,ESC) ;"5/26/07 //kt added "RTN","TMGXGS",115,0) ;Purpose: to separate an escape sequence from the beginning of a string "RTN","TMGXGS",116,0) ;Input: S -- the string to work on "RTN","TMGXGS",117,0) ; ESC -- PASS BY REFERENCE, an OUT PARAMETER "RTN","TMGXGS",118,0) ; Note: prior entries in ESC will NOT be killed. Results will be appended "RTN","TMGXGS",119,0) ;Output: if S has one more leading escape sequences, these will be removed "RTN","TMGXGS",120,0) ;results: none "RTN","TMGXGS",121,0) ;Note: The rule that will be used to determine the end of the escape sequence "RTN","TMGXGS",122,0) ; will be when an uppercase letter is encountered, or another ESC(#27) is found "RTN","TMGXGS",123,0) "RTN","TMGXGS",124,0) if $extract(S,1)'=$char(27) goto CEDone "RTN","TMGXGS",125,0) set ESC=$get(ESC)_$char(27) "RTN","TMGXGS",126,0) new p set p=2 "RTN","TMGXGS",127,0) new done set done=0 "RTN","TMGXGS",128,0) for do quit:(done=1) "RTN","TMGXGS",129,0) . new ch,chNum set ch=$extract(S,p),chNum=$ascii(ch) "RTN","TMGXGS",130,0) . if chNum=27 set done=1 quit "RTN","TMGXGS",131,0) . if (chNum'<$ascii("A"))&(chNum'>$ascii("Z")) set done=1 quit "RTN","TMGXGS",132,0) . set ESC=ESC_ch "RTN","TMGXGS",133,0) . set p=p+1 "RTN","TMGXGS",134,0) set S=$extract(S,p,9999) "RTN","TMGXGS",135,0) do CLIPESC(.S,.ESC) ;"check for further escape sequences "RTN","TMGXGS",136,0) CEDone "RTN","TMGXGS",137,0) quit "RTN","TMGXGSW") 0^100^B23984227 "RTN","TMGXGSW",1,0) TMGXGSW ;SFISC/VYD - screen window primitives ;01/11/95 15:58 "RTN","TMGXGSW",2,0) ;;8.0;KERNEL;;5/7/07 by //kt "RTN","TMGXGSW",3,0) ; "RTN","TMGXGSW",4,0) WIN(T,L,B,R,S) ;draw a bordered window "RTN","TMGXGSW",5,0) ;top,left,bottom,right,screen root "RTN","TMGXGSW",6,0) ;"//kt 5/5/07 removed next two lines. CLIOXY will do clipping. "RTN","TMGXGSW",7,0) ;"S:B'<IOSL B=IOSL-1,XGFLAG("TOO LONG")=1 ;adjust if longer than screen "RTN","TMGXGSW",8,0) ;"S:R'<IOM R=IOM-1,XGFLAG("TOO WIDE")=1 ;adjust if wider than screen "RTN","TMGXGSW",9,0) D:$D(S) SAVE(T,L,B,R,S) "RTN","TMGXGSW",10,0) N L2,R2,%MIDDLE,%MID0,%MID1,XGSAVATR,%S,Y "RTN","TMGXGSW",11,0) N XGGR0 ;graphics attribute off "RTN","TMGXGSW",12,0) S XGSAVATR=XGCURATR ;save current attr "RTN","TMGXGSW",13,0) W $$CHG^XGSA("G0") S XGGR0=XGCURATR ;store attributes w/out graphics "RTN","TMGXGSW",14,0) W $$CHG^XGSA("G1") ;now turn on gr attr and leave it on "RTN","TMGXGSW",15,0) S %MIDDLE=R-L-1 "RTN","TMGXGSW",16,0) S %MID0=IOVL_$J("",%MIDDLE)_$S($D(XGFLAG("TOO WIDE")):" ",1:IOVL) "RTN","TMGXGSW",17,0) S %MID1=XGCURATR_$TR($J("",%MIDDLE)," ",XGGR0)_$S($D(XGFLAG("TOO WIDE")):XGGR0,1:XGCURATR) "RTN","TMGXGSW",18,0) S L2=L+1,R2=R+1 "RTN","TMGXGSW",19,0) ;if window for LISTBUTTON gadget, don't draw top of frame "RTN","TMGXGSW",20,0) I $L($G(XGW)),$L($G(XGG)),$G(^TMP("XGW",$J,XGW,"G",XGG,"TYPE"))="LISTBUTTON",$G(XGMENU)="" D "RTN","TMGXGSW",21,0) . S $E(XGSCRN(T,0),L2,R2)=%MID0,%S=%MID0,$E(XGSCRN(T,1),L2,R2)=%MID1 "RTN","TMGXGSW",22,0) E D ;draw the top of the box "RTN","TMGXGSW",23,0) . S %S=IOTLC_$TR($J("",%MIDDLE)," ",IOHL)_$S($D(XGFLAG("TOO WIDE")):IOHL,1:IOTRC) "RTN","TMGXGSW",24,0) . S $E(XGSCRN(T,0),L2,R2)=%S "RTN","TMGXGSW",25,0) . S $E(XGSCRN(T,1),L2,R2)=$TR($J("",(R-L+1))," ",XGCURATR) "RTN","TMGXGSW",26,0) ;W $$IOXY^TMGXGS(T,L)_%S "RTN","TMGXGSW",27,0) do CLIOXY^TMGXGS(T,L,%S) "RTN","TMGXGSW",28,0) F Y=T+1:1:$S($D(XGFLAG("TOO LONG")):B,1:B-1) D "RTN","TMGXGSW",29,0) . S $E(XGSCRN(Y,0),L2,R2)=%MID0 "RTN","TMGXGSW",30,0) . S $E(XGSCRN(Y,1),L2,R2)=%MID1 "RTN","TMGXGSW",31,0) . ;W $$IOXY^TMGXGS(Y,L)_%MID0 "RTN","TMGXGSW",32,0) . DO CLIOXY^TMGXGS(Y,L,%MID0) "RTN","TMGXGSW",33,0) S %S=$S($D(XGFLAG("TOO LONG")):%MID0,1:IOBLC_$TR($J("",%MIDDLE)," ",IOHL)_$S($D(XGFLAG("TOO WIDE")):IOHL,1:IOBRC)) "RTN","TMGXGSW",34,0) S $E(XGSCRN(B,0),L2,R2)=%S "RTN","TMGXGSW",35,0) S $E(XGSCRN(B,1),L2,R2)=$S($D(XGFLAG("TOO LONG")):%MID1,1:$TR($J("",(R-L+1))," ",XGCURATR)) "RTN","TMGXGSW",36,0) ;W $$IOXY^TMGXGS(B,L)_%S "RTN","TMGXGSW",37,0) DO CLIOXY^TMGXGS(B,L,%S) "RTN","TMGXGSW",38,0) W $$SET^XGSA(XGSAVATR) "RTN","TMGXGSW",39,0) K XGFLAG("TOO LONG"),XGFLAG("TOO WIDE") "RTN","TMGXGSW",40,0) S $Y=B,$X=R "RTN","TMGXGSW",41,0) Q "RTN","TMGXGSW",42,0) ; "RTN","TMGXGSW",43,0) ; "RTN","TMGXGSW",44,0) RESTORE(S) ;restore portion of screen "RTN","TMGXGSW",45,0) ;if S="XGSCRN" then simply refresh the entire screen "RTN","TMGXGSW",46,0) N %,X,Y,%ROW,L2,R2 ;L2 left position in $E R2 right position in $E "RTN","TMGXGSW",47,0) N T,L,B,R "RTN","TMGXGSW",48,0) N %RCOUNT,%CP,%S,A ;row counter,char pos,string,attr "RTN","TMGXGSW",49,0) N XGSAVATR,XGWIDTH "RTN","TMGXGSW",50,0) S T=$P(@S@("COORDS"),U,1),L2=$P(@S@("COORDS"),U,2) "RTN","TMGXGSW",51,0) S B=$P(@S@("COORDS"),U,3),R2=$P(@S@("COORDS"),U,4) "RTN","TMGXGSW",52,0) S %RCOUNT=0,XGSAVATR=XGCURATR "RTN","TMGXGSW",53,0) S XGWIDTH=R2-L2+1 "RTN","TMGXGSW",54,0) F %ROW=T:1:B D "RTN","TMGXGSW",55,0) . S Y=$S($D(T):(T+%RCOUNT),1:%ROW) "RTN","TMGXGSW",56,0) . S XGFLAG("UPDATE")=$S(S="XGSCRN":1,1:0) "RTN","TMGXGSW",57,0) . ;check to see if a line from window needs to be placed on screen "RTN","TMGXGSW",58,0) . ; and if S="XGSCRN" then don't bother checking, refresh screen anyway "RTN","TMGXGSW",59,0) . I S'="XGSCRN" F X=0,1 I $E(XGSCRN(Y,X),L2,R2)'=$E(@S@(Y,X),L2,R2) S XGFLAG("UPDATE")=1 Q "RTN","TMGXGSW",60,0) . D:XGFLAG("UPDATE") ;if what's on screen is different from window "RTN","TMGXGSW",61,0) . . I $E(@S@(Y,1),L2,R2)=$TR($J("",XGWIDTH)," ",XGCURATR)&('$D(XGWSTAMP)) S %S=$E(@S@(Y,0),L2,R2) "RTN","TMGXGSW",62,0) . . E S %S="",%=L2,A=XGCURATR D "RTN","TMGXGSW",63,0) . . . F %CP=L2:1:R2 D:$E(@S@(Y,1),%CP)'=A "RTN","TMGXGSW",64,0) . . . . S A=$E(@S@(Y,1),%CP),%S=%S_$E(@S@(Y,0),%,%CP-1)_$$SET^XGSA(A),%=%CP "RTN","TMGXGSW",65,0) . . . S %S=%S_$E(@S@(Y,0),%,%CP) "RTN","TMGXGSW",66,0) . . S X=$S($D(L):L,1:L2-1) "RTN","TMGXGSW",67,0) . . ;W $$IOXY^TMGXGS(Y,X)_%S "RTN","TMGXGSW",68,0) . . DO CLIOXY^TMGXGS(Y,X,%S) "RTN","TMGXGSW",69,0) . . ;-------------------- put data, attributes and window stamps back "RTN","TMGXGSW",70,0) . . I S'="XGSCRN" F %=0,1 S $E(XGSCRN(Y,%),L2,R2)=$E(@S@(Y,%),L2,R2) "RTN","TMGXGSW",71,0) . S %RCOUNT=%RCOUNT+1 "RTN","TMGXGSW",72,0) W $$SET^XGSA(XGSAVATR) ;reset screen & XGCURATR to original "RTN","TMGXGSW",73,0) K XGFLAG("UPDATE") "RTN","TMGXGSW",74,0) ;S $Y=B,$X=R "RTN","TMGXGSW",75,0) Q "RTN","TMGXGSW",76,0) ; "RTN","TMGXGSW",77,0) ; "RTN","TMGXGSW",78,0) SAVE(T,L,B,R,S) ;save portion of screen "RTN","TMGXGSW",79,0) N %,Y "RTN","TMGXGSW",80,0) K @S ;clean out the root "RTN","TMGXGSW",81,0) D ADJUST(T,L,B,R,S) ;adjust and save the coordinates "RTN","TMGXGSW",82,0) S B=$P(@S@("COORDS"),U,3),R=$P(@S@("COORDS"),U,4) ;get new adj coords "RTN","TMGXGSW",83,0) F Y=T:1:B F %=0,1 S @S@(Y,%)=XGSCRN(Y,%) "RTN","TMGXGSW",84,0) Q "RTN","TMGXGSW",85,0) ; "RTN","TMGXGSW",86,0) ; "RTN","TMGXGSW",87,0) ADJUST(T,L,B,R,S) ;adjust the coordinates of screen region and if S "RTN","TMGXGSW",88,0) ;is passed, save the coordinates of a window into COORDS node "RTN","TMGXGSW",89,0) ;NOTE: T,L,B,R may be passed by reference "RTN","TMGXGSW",90,0) S:B'<IOSL B=IOSL-1 ;adjust if longer than screen "RTN","TMGXGSW",91,0) S:R'<IOM R=IOM-1 ;adjust if wider than screen "RTN","TMGXGSW",92,0) ;"//kt added 5/6/07 -- next line only "RTN","TMGXGSW",93,0) S:T<0 T=0 S:L<0 L=0 "RTN","TMGXGSW",94,0) S L=L+1 ;adjust for $E to work correctly "RTN","TMGXGSW",95,0) S R=R+1 ;adjust for $E to work correctly "RTN","TMGXGSW",96,0) S:$L($G(S)) @S@("COORDS")=T_U_L_U_B_U_R ;save "RTN","TMGXGSW",97,0) Q "RTN","TMGXINST") 0^101^B16647 "RTN","TMGXINST",1,0) TMGXINST ;TMG/kst/XML Configuration Scripting System ;03/25/06 "RTN","TMGXINST",2,0) ;;1.0;TMG-LIB;**1**;07/12/04 "RTN","TMGXINST",3,0) "RTN","TMGXINST",4,0) ;" XML Configuration Scripting System "RTN","TMGXINST",5,0) ;" "RTN","TMGXINST",6,0) ;" K. Toppenberg, MD "RTN","TMGXINST",7,0) ;" 7-12-04 "RTN","TMGXINST",8,0) ;" "RTN","TMGXINST",9,0) ;"Purpose: Intrepret a specially-prepaired XML file, designed "RTN","TMGXINST",10,0) ;" for configuring VistA "RTN","TMGXINST",11,0) "RTN","TMGXINST",12,0) ;"Dependancy: Requires TMGXDLG.m, TMGSTUTL.m, TMGDEBUG.m "RTN","TMGXINST",13,0) "RTN","TMGXINST",14,0) ;"------------------------------------------------------------- "RTN","TMGXINST",15,0) ;"CHANGE LOG "RTN","TMGXINST",16,0) ;"10-17-04: Got WP fields to upload properly. Created FormatArray function. "RTN","TMGXINST",17,0) ;"10-15-04: Forgot to log several days. Created <FileUtility>. Ensured data substitution "RTN","TMGXINST",18,0) ;" more widely implemented. Worked more on script. Tracked down modal dialog "RTN","TMGXINST",19,0) ;" box bug (conflicting globals in two different modules). "RTN","TMGXINST",20,0) ;"10-5-04: Learned that WP fields must be treated differently, so worked on support. "RTN","TMGXINST",21,0) ;" Had trouble with a locked record after a crash. Learn about GTM lke utility. "RTN","TMGXINST",22,0) ;"10-4-04: Tracked down apparent bug in FILE^DIE that doesn't allow upload to a word "RTN","TMGXINST",23,0) ;" processor field. Also allowed redirection of debug output to a file or to "RTN","TMGXINST",24,0) ;" an X graphic tail box. "RTN","TMGXINST",25,0) ;"10-2-05: Changed record node divider character from "/" to "|" because I could not "RTN","TMGXINST",26,0) ;" ever remember to protect the / as // and I'm sure others wouldn't remember "RTN","TMGXINST",27,0) ;" either. Fixed bug that caused crash when showing error box before XML "RTN","TMGXINST",28,0) ;" parse was complete, and datanode contained valid data. Changed UploadFile "RTN","TMGXINST",29,0) ;" to UploadRecord with <Record></Record> syntax "RTN","TMGXINST",30,0) ;"10-1-04: Fixed bug with line wrapping disordering in dialog boxes. Fixed bug "RTN","TMGXINST",31,0) ;" preventing non-modal dialog boxes ("&"-->" &") NOTE: ??working? "RTN","TMGXINST",32,0) ;"9-30-04: Allowed data substitution {{...}} to be used in Show and message boxes. "RTN","TMGXINST",33,0) ;" Fixed bug to allow multiple data substitutions on one line. "RTN","TMGXINST",34,0) ;"9-27-04: "RTN","TMGXINST",35,0) ;" Ran a test menu upload and got Adam and TMG Text menu to upload "RTN","TMGXINST",36,0) ;" Cleaned up error reporting. Discovered that including the ` character "RTN","TMGXINST",37,0) ;" in upload data causes an error... haven't tracked down reason yet. "RTN","TMGXINST",38,0) ;"9-26-04: "RTN","TMGXINST",39,0) ;" Started this change log "RTN","TMGXINST",40,0) ;" Change parameter system so that unlimited number of params allowed "RTN","TMGXINST",41,0) ;" Cleaned up command execution and passing of parameters "RTN","TMGXINST",42,0) ;" Got X graphic dialogs working -- can call from XML script. "RTN","TMGXINST",43,0) ;" Added options for a variety of user interfaces: GUI,CHUI,Roll "RTN","TMGXINST",44,0) ;" Changed log in process so that user #1 is used (MGR,IRM on my system) "RTN","TMGXINST",45,0) ;"2/9/2008: Moved some functions out into TMGXMLT for reuse by other code. "RTN","TMGXINST",46,0) "RTN","TMGXINST",47,0) "RTN","TMGXINST",48,0) ;"------------------------------------------------------------- "RTN","TMGXINST",49,0) ;"Public Functions "RTN","TMGXINST",50,0) "RTN","TMGXINST",51,0) ;"Run(DispMode,DebugMode,UserPath,UserFName) "RTN","TMGXINST",52,0) "RTN","TMGXINST",53,0) ;"------------------------------------------------------------- "RTN","TMGXINST",54,0) ;"Private Functions "RTN","TMGXINST",55,0) ;" "RTN","TMGXINST",56,0) ;"ShowWelcome() "RTN","TMGXINST",57,0) ;"GetFName(Path,Filename) "RTN","TMGXINST",58,0) ;"LoadFile(Path,Filename) "RTN","TMGXINST",59,0) ;"ShutDown "RTN","TMGXINST",60,0) ;"InitVars() "RTN","TMGXINST",61,0) ;"CMDProcess(Command,Params) "RTN","TMGXINST",62,0) ;"DoComment(Params) "RTN","TMGXINST",63,0) ;"DoShow(Params) "RTN","TMGXINST",64,0) ;"DoM(Params) "RTN","TMGXINST",65,0) ;"DoMenu(Params) "RTN","TMGXINST",66,0) ;"DoLookup(Params) -- take data from XML file, and look up if it is already in database "RTN","TMGXINST",67,0) ;"DoValueLookup(Params) -- look for a value of a given value in a given record in given file. "RTN","TMGXINST",68,0) ;"DoFileUtility(Params) "RTN","TMGXINST",69,0) ;"DoSearchRec(Params) "RTN","TMGXINST",70,0) ;"DoUpload(Params) "RTN","TMGXINST",71,0) ;"GetRInfo(ID,Data) -- get record info from the <DATA> section and store it in the Data variable. "RTN","TMGXINST",72,0) ;"ProcessRNode(DataP,Field,Text,EntryNumber,FileNumber,DoingSubNodes,Flags) -- Allow for recursive calling when doing GetRInfo "RTN","TMGXINST",73,0) ;"WPHandle(DataP,EntryNumber,FieldNumber,Text) -- process word-processing fields for ProcessRNode() "RTN","TMGXINST",74,0) ;"CheckArraySubst(TextArray) "RTN","TMGXINST",75,0) ;"ParamSubstitute(Params) "RTN","TMGXINST",76,0) ;"CheckSubstituteData(Text) "RTN","TMGXINST",77,0) ;"DoJump(Params) "RTN","TMGXINST",78,0) ;"GetLabelNode(Label) "RTN","TMGXINST",79,0) ;"GetData(Ref) "RTN","TMGXINST",80,0) ;"ParseSeg(Ref,ID) "RTN","TMGXINST",81,0) ;"GetDescIDNode(ParentNode,Name,ID) "RTN","TMGXINST",82,0) ;"GetCMDLine(ExecNode,Command,Params) "RTN","TMGXINST",83,0) ;"GetNextCMD(ExecNode) "RTN","TMGXINST",84,0) ;"RunScript(ExecNode) "RTN","TMGXINST",85,0) ;"GetDispMode() "RTN","TMGXINST",86,0) ;"DoMsgBox(Params) "RTN","TMGXINST",87,0) ;"================================================================= "RTN","TMGXINST",88,0) ;"================================================================= "RTN","TMGXINST",89,0) "RTN","TMGXINST",90,0) "RTN","TMGXINST",91,0) Run(DispMode,DebugMode,UserPath,UserFName) "RTN","TMGXINST",92,0) ;"Purpose: To use given XML filename to process "RTN","TMGXINST",93,0) ;"Input: "RTN","TMGXINST",94,0) ;" DispMode: OPTIONAL -- If not given, will ask user. Should be "RTN","TMGXINST",95,0) ;" 1 for GUI "RTN","TMGXINST",96,0) ;" 2 for CHUI "RTN","TMGXINST",97,0) ;" 3 for Roll-n-Scroll "RTN","TMGXINST",98,0) ;" DebugMode: OPTIONAL -- If not given, will ask user. Should be: "RTN","TMGXINST",99,0) ;" 0 for none, "RTN","TMGXINST",100,0) ;" 1 for To Screen "RTN","TMGXINST",101,0) ;" 2 for To File "RTN","TMGXINST",102,0) ;" 3 for To Tail (only valid if DispMode="GUI") "RTN","TMGXINST",103,0) ;" UserPath: OPTIONAL --Directory to load from "RTN","TMGXINST",104,0) ;" UserFName: OPTIONAL --the full filename. If not given, will ask user "RTN","TMGXINST",105,0) "RTN","TMGXINST",106,0) ;"Set up some global variables. "RTN","TMGXINST",107,0) "RTN","TMGXINST",108,0) new TMGDEBUG set TMGDEBUG=0 ;"Note: user could change this at runtime... "RTN","TMGXINST",109,0) new DBIndent set DBIndent=0 "RTN","TMGXINST",110,0) new PriorErrorFound set PriorErrorFound=0 "RTN","TMGXINST",111,0) ;"new DispMode "RTN","TMGXINST",112,0) new cGUI set cGUI="GUI" "RTN","TMGXINST",113,0) new cCHUI set cCHUI="CHUI" "RTN","TMGXINST",114,0) new cRoll set cRoll="Roll-n-Scroll" "RTN","TMGXINST",115,0) new DModes "RTN","TMGXINST",116,0) new cDialog set cDialog="UseDialog" "RTN","TMGXINST",117,0) set DModes(0)="x" "RTN","TMGXINST",118,0) set DModes(1)=cGUI "RTN","TMGXINST",119,0) set DModes(2)=cCHUI "RTN","TMGXINST",120,0) set DModes(3)=cRoll "RTN","TMGXINST",121,0) set DModes(4)="x" "RTN","TMGXINST",122,0) "RTN","TMGXINST",123,0) new ExecNode ;"This is the execution point "RTN","TMGXINST",124,0) new DataNode ;"A handle to <Data> node "RTN","TMGXINST",125,0) new ScriptNode ;"A handle to <Script> node "RTN","TMGXINST",126,0) new TopNode ;"A handle to top level node <CONFIG_SCRIPT> "RTN","TMGXINST",127,0) new XMLHandle ;"Handle referring to current XML document "RTN","TMGXINST",128,0) "RTN","TMGXINST",129,0) new cNodeDiv set cNodeDiv="|" "RTN","TMGXINST",130,0) new c2NodeDiv set c2NodeDiv=cNodeDiv_cNodeDiv "RTN","TMGXINST",131,0) "RTN","TMGXINST",132,0) new cProtect set cProtect="~~" "RTN","TMGXINST",133,0) new cDataOpen set cDataOpen="{{" "RTN","TMGXINST",134,0) new cDataClose set cDataClose="}}" "RTN","TMGXINST",135,0) new cNewLn set cNewLn="\n" "RTN","TMGXINST",136,0) new cEntries set cEntries="Entries" "RTN","TMGXINST",137,0) new cGlobal set cGlobal="GLOBAL" "RTN","TMGXINST",138,0) new cOpen set cOpen="OPEN" "RTN","TMGXINST",139,0) new cParentIENS set cParentIENS="ParentIENS" "RTN","TMGXINST",140,0) new cTrue set cTrue=1 "RTN","TMGXINST",141,0) new cFalse set cFalse=0 "RTN","TMGXINST",142,0) new cdbNone set cdbNone=0 "RTN","TMGXINST",143,0) new cdbToScrn set cdbToScrn=1 ;"was 2 "RTN","TMGXINST",144,0) new cdbToFile set cdbToFile=2 ;"was 3 "RTN","TMGXINST",145,0) new cdbToTail set cdbToTail=3 ;"was 4 "RTN","TMGXINST",146,0) new cdbAbort set cdbAbort=-1 "RTN","TMGXINST",147,0) new cOKToCont set cOKToCont=1 "RTN","TMGXINST",148,0) new cAbort set cAbort=0 "RTN","TMGXINST",149,0) "RTN","TMGXINST",150,0) new cScript set cScript="SCRIPT" ;"Script" "RTN","TMGXINST",151,0) new cData set cData="DATA" ;"Data" "RTN","TMGXINST",152,0) new cMVar set cMVar="MVAR" ;"MVar" "RTN","TMGXINST",153,0) new cOption set cOption="OPTION" ;"option" "RTN","TMGXINST",154,0) new cCondition set cCondition="CONDITION" ;"condition" "RTN","TMGXINST",155,0) new cMatchThis set cMatchThis="MATCHTHIS" ;"MatchThis" "RTN","TMGXINST",156,0) new cMatchValue set cMatchValue="MATCHVALUE" ;"MatchValue "RTN","TMGXINST",157,0) new cField set cField="FIELD" ;"Field" "RTN","TMGXINST",158,0) new cFile set cFile="FILE" ;"File" "RTN","TMGXINST",159,0) new cRecNum set cRecNum="RECNUM" ;"RecNum "RTN","TMGXINST",160,0) new cRecord set cRecord="RECORD" ;"Record" "RTN","TMGXINST",161,0) new cId set cId="ID" ;"id" "RTN","TMGXINST",162,0) new cOutput set cOutput="OUTVAR" ;"OutVar" "RTN","TMGXINST",163,0) new cInput set cInput="INVAR" ;"InVar "RTN","TMGXINST",164,0) new cShow set cShow="SHOW" ;"Show" "RTN","TMGXINST",165,0) new cM set cM="M" ;"M" "RTN","TMGXINST",166,0) new cMenu set cMenu="DOMENUOPTION" ;"DoMenuOption" "RTN","TMGXINST",167,0) new cUpload set cUpload="UPLOADRECORD" ;"UploadRecord" "RTN","TMGXINST",168,0) new cLookup set cLookup="LOOKUPFILEINFO" ;"LookupFileInfo" "RTN","TMGXINST",169,0) new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" "RTN","TMGXINST",170,0) new cSearchRec set cSearchRec="SEARCHREC" ;"SearchRec "RTN","TMGXINST",171,0) new cFileUtility set cFileUtility="FILEUTILITY" ;"FileUtility "RTN","TMGXINST",172,0) new cMsgBox set cMsgBox="MSGBOX" ;"MsgBox "RTN","TMGXINST",173,0) new cHeader set cHeader="HEADER" ;"Header "RTN","TMGXINST",174,0) new cText set cText="TEXT" ;"Text "RTN","TMGXINST",175,0) new cJump set cJump="JUMP" ;"Jump" "RTN","TMGXINST",176,0) new cRemark set cRemark="REM" ;"Rem" "RTN","TMGXINST",177,0) new cLabel set cLabel="LABEL" ;"Label" "RTN","TMGXINST",178,0) new cFlags set cFlags="FLAGS" ;"Flags" "RTN","TMGXINST",179,0) new cWidth set cWidth="WIDTH" ;"Width "RTN","TMGXINST",180,0) new cModal set cModal="MODAL" ;"Modal" "RTN","TMGXINST",181,0) new cFn set cFn="FN" ;"Fn "RTN","TMGXINST",182,0) new cInfo set cInfo="INFO" ;"Info "RTN","TMGXINST",183,0) new cDelete set cDelete="DELETE" ;"Delete "RTN","TMGXINST",184,0) new cNextRec set cNextRec="NEXTREC" "RTN","TMGXINST",185,0) new cPrev set cPrev="PREV" "RTN","TMGXINST",186,0) new cNumRecs set cNumRecs="NUMRECS" "RTN","TMGXINST",187,0) new cFirstRec set cFirstRec="FIRSTREC" "RTN","TMGXINST",188,0) new cLastRec set cLastRec="LASTREC" "RTN","TMGXINST",189,0) new cRef set cRef="Ref" "RTN","TMGXINST",190,0) new cNonModal set cNonModal="0" "RTN","TMGXINST",191,0) new cModalMode set cModalMode="1" "RTN","TMGXINST",192,0) ;"Field flags "RTN","TMGXINST",193,0) new cHack set cHack="H" "RTN","TMGXINST",194,0) new cNoOverwrite set cNoOverwrite="N" "RTN","TMGXINST",195,0) new cEncrypt set cEncrypt="E" "RTN","TMGXINST",196,0) ;"---------- "RTN","TMGXINST",197,0) new cUpperCase set cUpperCase="UpperCase" "RTN","TMGXINST",198,0) new cName set cName="Name" "RTN","TMGXINST",199,0) new cValue set cValue="VALUE" "RTN","TMGXINST",200,0) new cSet set cSet="SET" "RTN","TMGXINST",201,0) new cNull set cNull="(none)" "RTN","TMGXINST",202,0) new cMaxNode set cMaxNode="Max Node Num" "RTN","TMGXINST",203,0) new Filename "RTN","TMGXINST",204,0) new DebugFPath "RTN","TMGXINST",205,0) new DebugFName "RTN","TMGXINST",206,0) new DebugFile "RTN","TMGXINST",207,0) "RTN","TMGXINST",208,0) new result "RTN","TMGXINST",209,0) new FileSpec "RTN","TMGXINST",210,0) "RTN","TMGXINST",211,0) new ProcTable "RTN","TMGXINST",212,0) set ProcTable(cRemark)="DoComment" ;"a do-nothing function "RTN","TMGXINST",213,0) set ProcTable(cLabel)="DoComment" ;"a do-nothing function "RTN","TMGXINST",214,0) set ProcTable(cShow)="DoShow" "RTN","TMGXINST",215,0) set ProcTable(cM)="DoM" "RTN","TMGXINST",216,0) set ProcTable(cMenu)="DoMenu" "RTN","TMGXINST",217,0) set ProcTable(cUpload)="DoUpload" "RTN","TMGXINST",218,0) set ProcTable(cJump)="DoJump" "RTN","TMGXINST",219,0) set ProcTable(cLookup)="DoLookup" "RTN","TMGXINST",220,0) set ProcTable(cMsgBox)="DoMsgBox" "RTN","TMGXINST",221,0) set ProcTable(cValueLookup)="DoValueLookup" "RTN","TMGXINST",222,0) set ProcTable(cFileUtility)="DoFileUtility" "RTN","TMGXINST",223,0) set ProcTable(cSearchRec)="DoSearchRec" "RTN","TMGXINST",224,0) "RTN","TMGXINST",225,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"Main Run") "RTN","TMGXINST",226,0) "RTN","TMGXINST",227,0) if $get(WelcomeShown)'=1 do ShowWelcome() "RTN","TMGXINST",228,0) "RTN","TMGXINST",229,0) ;"A local code login function. "RTN","TMGXINST",230,0) if $$XUP^TMGXUP()=0 do goto RunDone "RTN","TMGXINST",231,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error setting up a user privilages for configuration.") "RTN","TMGXINST",232,0) "RTN","TMGXINST",233,0) if ($data(DispMode)#10=0)!($get(DispMode)>3)!($get(DispMode)<1) do "RTN","TMGXINST",234,0) . set DispMode=$$GetDispMode() "RTN","TMGXINST",235,0) set DispMode=DModes(DispMode) "RTN","TMGXINST",236,0) if DispMode="x" goto RunDone "RTN","TMGXINST",237,0) set DispMode(cDialog)=(DispMode'=cRoll) "RTN","TMGXINST",238,0) "RTN","TMGXINST",239,0) if ($data(DebugMode)#10=0)!($get(DebugMode)<0)!($get(DebugMode)>3)!(($get(DebugMode)=1)&(DispMode'=cGUI)) do "RTN","TMGXINST",240,0) . set TMGDEBUG=$$GetDebugMode^TMGDEBUG(2) ;"2=default to File output "RTN","TMGXINST",241,0) else set TMGDEBUG=DebugMode "RTN","TMGXINST",242,0) if TMGDEBUG=cdbAbort goto RunDone "RTN","TMGXINST",243,0) "RTN","TMGXINST",244,0) do "RTN","TMGXINST",245,0) . new DefPath set DefPath="/tmp/" "RTN","TMGXINST",246,0) . new DefName set DefName="XMLInst_DebugLog.tmp" "RTN","TMGXINST",247,0) . new DefFName set DefFName=DefPath_DefName "RTN","TMGXINST",248,0) . do OpenLogFile^TMGDEBUG(DefPath,DefName) "RTN","TMGXINST",249,0) . if TMGDEBUG=cdbToTail do "RTN","TMGXINST",250,0) . . set result=$$Tail^TMGXDLG(DefFName,0,0,0) "RTN","TMGXINST",251,0) "RTN","TMGXINST",252,0) if ($data(UserPath)#10=0)!($data(UserFName)#10=0) do "RTN","TMGXINST",253,0) . "RTN","TMGXINST",254,0) . set result=$$GetFName(.UserPath,.UserFName) "RTN","TMGXINST",255,0) . if result=cAbort do PopupBox^TMGUSRIF("<!> No script file selected.","Come back again soon!") "RTN","TMGXINST",256,0) else set result=cOKToCont "RTN","TMGXINST",257,0) if (result=cAbort)!($data(UserPath)=0)!($data(UserFName)=0) goto RunDone "RTN","TMGXINST",258,0) "RTN","TMGXINST",259,0) set Filename=UserPath_UserFName "RTN","TMGXINST",260,0) "RTN","TMGXINST",261,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Let's go! Cranking up system!...") "RTN","TMGXINST",262,0) "RTN","TMGXINST",263,0) kill ^TMP("TMG",$J) "RTN","TMGXINST",264,0) set XML1Ref=$name(^TMP("TMG",$J,1)) ;"I have to use this to load file "RTN","TMGXINST",265,0) set XMLRef=$name(^TMP("TMG",$J)) ;"I have to pass this to XML parser "RTN","TMGXINST",266,0) "RTN","TMGXINST",267,0) set XMLHandle=$$LoadFile(UserPath,UserFName) "RTN","TMGXINST",268,0) "RTN","TMGXINST",269,0) if XMLHandle=0 do goto RunDone "RTN","TMGXINST",270,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to load/parse file") "RTN","TMGXINST",271,0) "RTN","TMGXINST",272,0) if '$$InitVars do goto RunDone "RTN","TMGXINST",273,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error setting up script system (InitVars procedure).") "RTN","TMGXINST",274,0) "RTN","TMGXINST",275,0) if TMGDEBUG do "RTN","TMGXINST",276,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling ArrayDump") "RTN","TMGXINST",277,0) . do ArrayDump^TMGDEBUG("^TMP(""TMG"")",$J) "RTN","TMGXINST",278,0) "RTN","TMGXINST",279,0) new Text "RTN","TMGXINST",280,0) set Text(0)="[*] XML Script" "RTN","TMGXINST",281,0) set Text(1)="Beginning execution of user XML script:" "RTN","TMGXINST",282,0) set Text(2)=Filename "RTN","TMGXINST",283,0) set Text(2)=" " "RTN","TMGXINST",284,0) set Text(3)="This could be the beginning of " "RTN","TMGXINST",285,0) set Text(4)="something wonderful..." "RTN","TMGXINST",286,0) do PopupArray^TMGUSRIF(5,45,.Text) "RTN","TMGXINST",287,0) "RTN","TMGXINST",288,0) new RunResult "RTN","TMGXINST",289,0) set RunResult=$$RunScript(.ExecNode) "RTN","TMGXINST",290,0) "RTN","TMGXINST",291,0) new Text "RTN","TMGXINST",292,0) set Text(0)="[*] XML Script" "RTN","TMGXINST",293,0) set Text(1)="Done with execution of user XML script." "RTN","TMGXINST",294,0) set Text(2)=" " "RTN","TMGXINST",295,0) set Text(3)="See you later..." "RTN","TMGXINST",296,0) if RunResult=cAbort do "RTN","TMGXINST",297,0) . set Text(4)="Note: Script was not completed." "RTN","TMGXINST",298,0) do PopupArray^TMGUSRIF(5,45,.Text) "RTN","TMGXINST",299,0) "RTN","TMGXINST",300,0) RunDone "RTN","TMGXINST",301,0) do ShutDown "RTN","TMGXINST",302,0) "RTN","TMGXINST",303,0) write "Clean shutdown completed. Goodbye.",!,! "RTN","TMGXINST",304,0) "RTN","TMGXINST",305,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"Main Run") "RTN","TMGXINST",306,0) "RTN","TMGXINST",307,0) quit "RTN","TMGXINST",308,0) "RTN","TMGXINST",309,0) "RTN","TMGXINST",310,0) ;"================================================================= "RTN","TMGXINST",311,0) ;" Subroutines "RTN","TMGXINST",312,0) ;"================================================================= "RTN","TMGXINST",313,0) "RTN","TMGXINST",314,0) ShowWelcome() "RTN","TMGXINST",315,0) ;"Purpose: To show a splash for program "RTN","TMGXINST",316,0) "RTN","TMGXINST",317,0) write !,! "RTN","TMGXINST",318,0) "RTN","TMGXINST",319,0) new Text "RTN","TMGXINST",320,0) set Text(0)="XML Configurator for VistA on GT.M" "RTN","TMGXINST",321,0) set Text(1)=" " "RTN","TMGXINST",322,0) set Text(2)="WELCOME..." "RTN","TMGXINST",323,0) set Text(3)=" " "RTN","TMGXINST",324,0) set Text(4)="Interpreter created by: Kevin Toppenberg, MD" "RTN","TMGXINST",325,0) set Text(5)="GNU General Public License, 7/2004" "RTN","TMGXINST",326,0) set Text(6)=" " "RTN","TMGXINST",327,0) do PopupArray^TMGUSRIF(5,55,.Text) "RTN","TMGXINST",328,0) "RTN","TMGXINST",329,0) quit "RTN","TMGXINST",330,0) "RTN","TMGXINST",331,0) "RTN","TMGXINST",332,0) GetFName(Path,Filename) "RTN","TMGXINST",333,0) ;"Purpose: Interact with user to get path and filename "RTN","TMGXINST",334,0) ;"Input: Path--should be passed by reference, used to pass back result "RTN","TMGXINST",335,0) ;" Filename--should be passed by reference, used to pass back result "RTN","TMGXINST",336,0) ;"Output: Results passed in Path and Filename "RTN","TMGXINST",337,0) ;" Function will result in 0 if user 'cancelled', 1 otherwise "RTN","TMGXINST",338,0) "RTN","TMGXINST",339,0) new result set result=cAbort "RTN","TMGXINST",340,0) new FullNamePath "RTN","TMGXINST",341,0) new PathNode "RTN","TMGXINST",342,0) set Path="/" "RTN","TMGXINST",343,0) set Filename="" "RTN","TMGXINST",344,0) "RTN","TMGXINST",345,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFName") "RTN","TMGXINST",346,0) "RTN","TMGXINST",347,0) if DispMode=cRoll goto GFNRoll "RTN","TMGXINST",348,0) "RTN","TMGXINST",349,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling $$FileSel()") "RTN","TMGXINST",350,0) set FullNamePath=$$FileSel^TMGXDLG("Please select script to process . . .","~/XMLScript") "RTN","TMGXINST",351,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Results=",FullNamePath) "RTN","TMGXINST",352,0) if FullNamePath="" goto GFNDone ;"result=cAbort still --> cancelled. "RTN","TMGXINST",353,0) "RTN","TMGXINST",354,0) ;"Separate path from filename "RTN","TMGXINST",355,0) GFNL1 "RTN","TMGXINST",356,0) if '(FullNamePath["/") set Filename=FullNamePath goto GFNL2 "RTN","TMGXINST",357,0) set PathNode=$piece(FullNamePath,"/",1) "RTN","TMGXINST",358,0) set Path=Path_PathNode_"/" "RTN","TMGXINST",359,0) set $piece(FullNamePath,"/",1)="" "RTN","TMGXINST",360,0) set FullNamePath=$extract(FullNamePath,2,255) "RTN","TMGXINST",361,0) goto GFNL1 "RTN","TMGXINST",362,0) GFNL2 "RTN","TMGXINST",363,0) set result=cOKToCont "RTN","TMGXINST",364,0) goto GFNDone "RTN","TMGXINST",365,0) "RTN","TMGXINST",366,0) GFNRoll "RTN","TMGXINST",367,0) new DefFName set DefFName="XMLScript" "RTN","TMGXINST",368,0) new DefPath set DefPath="/home/kdtop/OpenVistA_UserData/r" "RTN","TMGXINST",369,0) new Msg set Msg="Select script file:" "RTN","TMGXINST",370,0) new tempName "RTN","TMGXINST",371,0) "RTN","TMGXINST",372,0) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Will new file picker work?") "RTN","TMGXINST",373,0) "RTN","TMGXINST",374,0) set tempName=$$GetFName^TMGIOUTL(.Msg,.DefPath,.DefFName,"/",.Path,.Filename) "RTN","TMGXINST",375,0) write "Path=",$get(Path)," and Filename=",$get(Filename),! "RTN","TMGXINST",376,0) if tempName'="" set result=cOKToCont "RTN","TMGXINST",377,0) goto GFNDone "RTN","TMGXINST",378,0) "RTN","TMGXINST",379,0) ;"write !,"------------------------------------------",! "RTN","TMGXINST",380,0) write ! "RTN","TMGXINST",381,0) write "Enter script filename with path:",! "RTN","TMGXINST",382,0) write " ['^'] = Abort",! "RTN","TMGXINST",383,0) write " [Enter] = '",DefPath,"/",DefFName,"'",! "RTN","TMGXINST",384,0) write "> " "RTN","TMGXINST",385,0) read Filename:240 "RTN","TMGXINST",386,0) write ! "RTN","TMGXINST",387,0) if Filename="^" goto GFNDone "RTN","TMGXINST",388,0) if Filename="" do "RTN","TMGXINST",389,0) . set Filename=DefFName "RTN","TMGXINST",390,0) . set Path=DefPath "RTN","TMGXINST",391,0) . write "Using default: ",Path,"/",Filename,!,!,! "RTN","TMGXINST",392,0) set result=cOKToCont "RTN","TMGXINST",393,0) "RTN","TMGXINST",394,0) GFNDone "RTN","TMGXINST",395,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFName") "RTN","TMGXINST",396,0) quit result "RTN","TMGXINST",397,0) "RTN","TMGXINST",398,0) "RTN","TMGXINST",399,0) "RTN","TMGXINST",400,0) LoadFile(Path,Filename) "RTN","TMGXINST",401,0) ;"Purpose: To load the file and check for XML validity "RTN","TMGXINST",402,0) ;" Also check for DOCTYPE = 'CONFIG_SCRIPT' and other "RTN","TMGXINST",403,0) ;" possible validity tests. "RTN","TMGXINST",404,0) ;"Input: FullFile: full filename with path, ready to pass to Host file system. "RTN","TMGXINST",405,0) ;"NOTE: uses XML1Ref and XMLRef vars with global scope "RTN","TMGXINST",406,0) ;"Returns: 0 if fails, otherwise XML file handle. "RTN","TMGXINST",407,0) "RTN","TMGXINST",408,0) new FileHandle "RTN","TMGXINST",409,0) set XMLHandle=0 "RTN","TMGXINST",410,0) "RTN","TMGXINST",411,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"LoadFile") "RTN","TMGXINST",412,0) set FileHandle=$$FTG^%ZISH(Path,Filename,XML1Ref,3) "RTN","TMGXINST",413,0) if FileHandle=0 do goto QLoad "RTN","TMGXINST",414,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening file. Path="_Path_", Filename="_Filename) "RTN","TMGXINST",415,0) else do "RTN","TMGXINST",416,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"File Loaded... Handle#="_FileHandle) "RTN","TMGXINST",417,0) "RTN","TMGXINST",418,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling EN^MXMLDOM") "RTN","TMGXINST",419,0) write "Parsing XML File. Please wait . . .",! "RTN","TMGXINST",420,0) set XMLHandle=$$EN^MXMLDOM(XMLRef,"") "RTN","TMGXINST",421,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Back from calling EN^MXMLDOM. XMLHandle="_XMLHandle) "RTN","TMGXINST",422,0) if XMLHandle=0 do "RTN","TMGXINST",423,0) . new ErrMsg "RTN","TMGXINST",424,0) . set ErrMsg="Error parsing XML document.\n\n" "RTN","TMGXINST",425,0) . set ErrMsg=ErrMsg_"Now analyzing XML file to determine problem...\n" "RTN","TMGXINST",426,0) . do ShowError^TMGDEBUG(.PriorErrorFound,ErrMsg) "RTN","TMGXINST",427,0) . do DetailParse^TMGXMLP() "RTN","TMGXINST",428,0) "RTN","TMGXINST",429,0) QLoad "RTN","TMGXINST",430,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"LoadFile") "RTN","TMGXINST",431,0) quit XMLHandle "RTN","TMGXINST",432,0) "RTN","TMGXINST",433,0) ShutDown "RTN","TMGXINST",434,0) ;"Purpose: to do any cleanup needed to exit system cleanly "RTN","TMGXINST",435,0) "RTN","TMGXINST",436,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Freeing vars...") "RTN","TMGXINST",437,0) "RTN","TMGXINST",438,0) if $get(XMLHandle) do DELETE^MXMLDOM(XMLHandle) "RTN","TMGXINST",439,0) kill ^TMP("TMG",$J) "RTN","TMGXINST",440,0) "RTN","TMGXINST",441,0) ;"Kill a few variables. The others should be automatically freed "RTN","TMGXINST",442,0) ;" when they go out of scope as the program exits. "RTN","TMGXINST",443,0) kill TMGDEBUG "RTN","TMGXINST",444,0) kill LoggedUsr "RTN","TMGXINST",445,0) kill SubMarkNum "RTN","TMGXINST",446,0) "RTN","TMGXINST",447,0) if $data(DebugFile) close DebugFile "RTN","TMGXINST",448,0) "RTN","TMGXINST",449,0) write "Exiting XML Scripter.",!,! "RTN","TMGXINST",450,0) "RTN","TMGXINST",451,0) quit "RTN","TMGXINST",452,0) "RTN","TMGXINST",453,0) "RTN","TMGXINST",454,0) InitVars() "RTN","TMGXINST",455,0) ;"Purpose: Initialize variables "RTN","TMGXINST",456,0) ;"Input: None: "RTN","TMGXINST",457,0) ;"Output: Global (program-wide) variables are set up. "RTN","TMGXINST",458,0) ;" Return value is 0 if an error occurs. "RTN","TMGXINST",459,0) "RTN","TMGXINST",460,0) new result "RTN","TMGXINST",461,0) set result=cAbort "RTN","TMGXINST",462,0) set TopNode=1 "RTN","TMGXINST",463,0) "RTN","TMGXINST",464,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Entry InitVars()",1) "RTN","TMGXINST",465,0) "RTN","TMGXINST",466,0) set ScriptNode=$$GetDescNode^TMGXMLT(XMLHandle,TopNode,cScript) "RTN","TMGXINST",467,0) if ScriptNode=0 do goto QInitVar "RTN","TMGXINST",468,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find node: '"_cScript_"'.") "RTN","TMGXINST",469,0) "RTN","TMGXINST",470,0) set ExecNode=$$CHILD^MXMLDOM(XMLHandle,ScriptNode) "RTN","TMGXINST",471,0) if ExecNode=0 do goto QInitVar "RTN","TMGXINST",472,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error finding first child of ScriptNode (#"_ScriptNode_").") "RTN","TMGXINST",473,0) "RTN","TMGXINST",474,0) set DataNode=$$GetDescNode^TMGXMLT(XMLHandle,TopNode,cData) "RTN","TMGXINST",475,0) if DataNode=0 do goto QInitVar "RTN","TMGXINST",476,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find node: '"_cData_"'") "RTN","TMGXINST",477,0) "RTN","TMGXINST",478,0) set result=cOKToCont "RTN","TMGXINST",479,0) "RTN","TMGXINST",480,0) QInitVar "RTN","TMGXINST",481,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Exit InitVars()",1) "RTN","TMGXINST",482,0) quit result "RTN","TMGXINST",483,0) "RTN","TMGXINST",484,0) "RTN","TMGXINST",485,0) CMDProcess(Command,Params) "RTN","TMGXINST",486,0) ;"Purpose: Take allowed command, and carry out appropriate action "RTN","TMGXINST",487,0) ;"Input: Command: One of following allowed commands: "RTN","TMGXINST",488,0) ;" Show,M,DoMenuOption,UploadRecord,Jump "RTN","TMGXINST",489,0) ;" Params: An array holding parameters. See GetParams() for format. "RTN","TMGXINST",490,0) ;" Note: if node had no parameters, this array will be undefined. "RTN","TMGXINST",491,0) ;"Note: Not all commands will have valid data for all attribs. "RTN","TMGXINST",492,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",493,0) "RTN","TMGXINST",494,0) new OKToCont set OKToCont=1 "RTN","TMGXINST",495,0) "RTN","TMGXINST",496,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"CMDProcess") "RTN","TMGXINST",497,0) "RTN","TMGXINST",498,0) if $data(ProcTable(Command)) do "RTN","TMGXINST",499,0) . new Cmd set Cmd=ProcTable(Command) "RTN","TMGXINST",500,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"CMD=",Cmd) "RTN","TMGXINST",501,0) . set @("OKToCont=$$"_Cmd_"(.Params)") "RTN","TMGXINST",502,0) "RTN","TMGXINST",503,0) goto CMDQuit "RTN","TMGXINST",504,0) "RTN","TMGXINST",505,0) CMDQuit "RTN","TMGXINST",506,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"CMDProcess") "RTN","TMGXINST",507,0) quit OKToCont "RTN","TMGXINST",508,0) "RTN","TMGXINST",509,0) "RTN","TMGXINST",510,0) DoComment(Params) "RTN","TMGXINST",511,0) ;"Purpose: To provide a function for doing nothing.... for comments in the code. "RTN","TMGXINST",512,0) quit 1 "RTN","TMGXINST",513,0) "RTN","TMGXINST",514,0) DoShow(Params) "RTN","TMGXINST",515,0) ;"Purpose: execute Show command "RTN","TMGXINST",516,0) ;"Syntax: e.g. <Show>This is a test script system.</Show> "RTN","TMGXINST",517,0) ;"Input: Params -- an array that holds all parameters (or is undefined if there were none) "RTN","TMGXINST",518,0) ;" if there is text to be show, it should be in "RTN","TMGXINST",519,0) ;" Params(cText) "RTN","TMGXINST",520,0) ;"Input: TextArray: a reference to global array, holding the text found between tags "RTN","TMGXINST",521,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",522,0) "RTN","TMGXINST",523,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoShow") "RTN","TMGXINST",524,0) "RTN","TMGXINST",525,0) new done "RTN","TMGXINST",526,0) new lineI "RTN","TMGXINST",527,0) new OneLine "RTN","TMGXINST",528,0) new result set result=cOKToCont "RTN","TMGXINST",529,0) "RTN","TMGXINST",530,0) new TextArray "RTN","TMGXINST",531,0) "RTN","TMGXINST",532,0) if $data(Params(cText))=0 do goto DSDone "RTN","TMGXINST",533,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Asked to show text, but none found!") "RTN","TMGXINST",534,0) . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Params") ;"zwr Params(*) "RTN","TMGXINST",535,0) merge TextArray=Params(cText) "RTN","TMGXINST",536,0) if TMGDEBUG do ArrayDump^TMGDEBUG("TextArray") ;"zwr TextArray(*) "RTN","TMGXINST",537,0) "RTN","TMGXINST",538,0) set result=$$CheckArraySubst(.TextArray) "RTN","TMGXINST",539,0) "RTN","TMGXINST",540,0) set lineI=$Order(TextArray("")) "RTN","TMGXINST",541,0) for do quit:(lineI="")!(result=cAbort) "RTN","TMGXINST",542,0) . set OneLine=TextArray(lineI) "RTN","TMGXINST",543,0) . write OneLine,! "RTN","TMGXINST",544,0) . set lineI=$Order(TextArray(lineI)) "RTN","TMGXINST",545,0) "RTN","TMGXINST",546,0) DSDone "RTN","TMGXINST",547,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoShow") "RTN","TMGXINST",548,0) "RTN","TMGXINST",549,0) quit result "RTN","TMGXINST",550,0) "RTN","TMGXINST",551,0) DoM(Params) "RTN","TMGXINST",552,0) ;"Purpose: execute a single line of M code "RTN","TMGXINST",553,0) ;"Syntax: e.g. <M>write "This is a test of M code"</M> "RTN","TMGXINST",554,0) ;" e.g. <M>set XMLData={{Data.Site.Office[Kevin].Field[Doctor]}}</M> "RTN","TMGXINST",555,0) ;"Input: Params -- an array that holds all parameters (or is undefined if there were none) "RTN","TMGXINST",556,0) ;" if there is code to be executed, it should be in "RTN","TMGXINST",557,0) ;" Params(cText,1) "RTN","TMGXINST",558,0) ;"Note: If a {{...}} pair is found, then the contents between the braces will "RTN","TMGXINST",559,0) ;" be interpreted as a data reference, and the value will be looked up. "RTN","TMGXINST",560,0) ;" The references are read-only. Attempts to write to them will only "RTN","TMGXINST",561,0) ;" create an unused variable by the name of the data result. Will likely "RTN","TMGXINST",562,0) ;" cause an error. "RTN","TMGXINST",563,0) ;" Note: This code could be anything. Script execution will only continue "RTN","TMGXINST",564,0) ;" after M code execution is complete. "RTN","TMGXINST",565,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",566,0) "RTN","TMGXINST",567,0) new RefB "RTN","TMGXINST",568,0) new Abort "RTN","TMGXINST",569,0) new result set result=cOKToCont "RTN","TMGXINST",570,0) new OrigCode "RTN","TMGXINST",571,0) "RTN","TMGXINST",572,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoM") "RTN","TMGXINST",573,0) "RTN","TMGXINST",574,0) new Code set Code=$get(Params(cText,1)) "RTN","TMGXINST",575,0) if Code="" do goto DMDone "RTN","TMGXINST",576,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"No M code found to execute!") "RTN","TMGXINST",577,0) "RTN","TMGXINST",578,0) ;"Check if Code contains a data reference. Replace with data if found "RTN","TMGXINST",579,0) set OrigCode=Code "RTN","TMGXINST",580,0) set result=$$CheckSubstituteData(.Code) "RTN","TMGXINST",581,0) if result=cAbort do goto DMDone "RTN","TMGXINST",582,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"UNABLE to execute this code: "_OrigCode) "RTN","TMGXINST",583,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"After lookup, code was:"_Code) "RTN","TMGXINST",584,0) "RTN","TMGXINST",585,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"execute:> "_Code) "RTN","TMGXINST",586,0) "RTN","TMGXINST",587,0) ;"Note: Here I trap execution errors, and return 0 if error encountered "RTN","TMGXINST",588,0) do "RTN","TMGXINST",589,0) . new $etrap set $etrap="do DoMErrTrap^TMGXINST" "RTN","TMGXINST",590,0) . set ^TMP("TMG",$J,"trap")=cOKToCont "RTN","TMGXINST",591,0) . xecute Code "RTN","TMGXINST",592,0) . set result=^TMP("TMG",$J,"trap") "RTN","TMGXINST",593,0) . if result=cAbort do "RTN","TMGXINST",594,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error executing code: \n"_Code) "RTN","TMGXINST",595,0) "RTN","TMGXINST",596,0) DMDone "RTN","TMGXINST",597,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoM") "RTN","TMGXINST",598,0) quit result "RTN","TMGXINST",599,0) "RTN","TMGXINST",600,0) "RTN","TMGXINST",601,0) ;"========================================================= "RTN","TMGXINST",602,0) ;"DoM Error trap routine "RTN","TMGXINST",603,0) ;"========================================================= "RTN","TMGXINST",604,0) DoMErrTrap "RTN","TMGXINST",605,0) set $etrap="" "RTN","TMGXINST",606,0) set $ecode="" "RTN","TMGXINST",607,0) set ^TMP("TMG",$J,"trap")=cAbort "RTN","TMGXINST",608,0) quit "RTN","TMGXINST",609,0) ;"========================================================= "RTN","TMGXINST",610,0) ;"DoM End of Error trap routine "RTN","TMGXINST",611,0) ;"========================================================= "RTN","TMGXINST",612,0) "RTN","TMGXINST",613,0) "RTN","TMGXINST",614,0) DoMenu(Params) "RTN","TMGXINST",615,0) ;"Purpose: To execute a menu option inside the VistA system "RTN","TMGXINST",616,0) ;"Syntax: e.g. <DoMenuOption option="DIUSER"></DoMenuOption> "RTN","TMGXINST",617,0) ;"Input: Params -- an array that holds all parameters (or is undefined if there were none) "RTN","TMGXINST",618,0) ;" if there is code to be executed, it should be in "RTN","TMGXINST",619,0) ;" Params(cOption) "RTN","TMGXINST",620,0) ;" This should be a valid VistA menu option name. "RTN","TMGXINST",621,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",622,0) "RTN","TMGXINST",623,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoMenu") "RTN","TMGXINST",624,0) "RTN","TMGXINST",625,0) set result=$$DoShow(.Params) ;"Show any associated text as a message "RTN","TMGXINST",626,0) "RTN","TMGXINST",627,0) new MenuOption "RTN","TMGXINST",628,0) set MenuOption=$get(Params(cOption)) ;"note use of attrib value with case UN-MODIFIED "RTN","TMGXINST",629,0) if MenuOption="" do goto DoMenuQ "RTN","TMGXINST",630,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"No menu option found to execute!") "RTN","TMGXINST",631,0) "RTN","TMGXINST",632,0) new Text "RTN","TMGXINST",633,0) set Text(0)="<!> Notice:" "RTN","TMGXINST",634,0) set Text(1)=" " "RTN","TMGXINST",635,0) set Text(2)="Temporarily leaving XML Script Configurator" "RTN","TMGXINST",636,0) set Text(3)="to run VistA menu option system...." "RTN","TMGXINST",637,0) set Text(4)="This script will return to this point when" "RTN","TMGXINST",638,0) set Text(5)="VistA menu option exited." "RTN","TMGXINST",639,0) set Text(6)=" " "RTN","TMGXINST",640,0) do PopupArray^TMGUSRIF(5,55,.Text) "RTN","TMGXINST",641,0) "RTN","TMGXINST",642,0) new result "RTN","TMGXINST",643,0) set result=cOKToCont "RTN","TMGXINST",644,0) "RTN","TMGXINST",645,0) set DIC=19 ;"File 19 is the OPTION file "RTN","TMGXINST",646,0) set DIC(0)="M" ;"M=Multiple index lookup allowed "RTN","TMGXINST",647,0) set X=MenuOption "RTN","TMGXINST",648,0) do ^DIC ;"Do lookup for variable X. Result returns in Y "RTN","TMGXINST",649,0) if Y<0 do quit "RTN","TMGXINST",650,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Menu option '"_MenuOption_"' wasn't found.\nTry specifying a more specific name, or check spelling.") "RTN","TMGXINST",651,0) "RTN","TMGXINST",652,0) ;"Note: DIC is already set to 19 "RTN","TMGXINST",653,0) set X=$piece(Y,"^",1) ;"X=Menu option IEN to execute "RTN","TMGXINST",654,0) "RTN","TMGXINST",655,0) ;Note: If the OPTION is a run routine, then this won't work. I could "RTN","TMGXINST",656,0) ; Get the run routine my self, but I would also need to do the "RTN","TMGXINST",657,0) ; entry and exit points etc. etc., so I am not now going to. "RTN","TMGXINST",658,0) "RTN","TMGXINST",659,0) do EN^XQOR ;"call standard entry point to run menu/option X "RTN","TMGXINST",660,0) "RTN","TMGXINST",661,0) new Text "RTN","TMGXINST",662,0) set Text(0)="<!> Notice:" "RTN","TMGXINST",663,0) set Text(1)=" " "RTN","TMGXINST",664,0) set Text(2)="Re-entering XML Script Configurator" "RTN","TMGXINST",665,0) set Text(3)="(Back from VistA menu option system)" "RTN","TMGXINST",666,0) set Text(4)="Script continuing..." "RTN","TMGXINST",667,0) set Text(5)=" " "RTN","TMGXINST",668,0) do PopupArray^TMGUSRIF(5,55,.Text) "RTN","TMGXINST",669,0) "RTN","TMGXINST",670,0) "RTN","TMGXINST",671,0) ;"Note: Here I could do some error checking, and return "RTN","TMGXINST",672,0) ;" result=cAbort if we need to abort. "RTN","TMGXINST",673,0) DoMenuQ "RTN","TMGXINST",674,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoMenu") "RTN","TMGXINST",675,0) quit result "RTN","TMGXINST",676,0) "RTN","TMGXINST",677,0) "RTN","TMGXINST",678,0) DoLookup(Params) "RTN","TMGXINST",679,0) ;"Purpose: To take data from XML file, and look if it is already in database "RTN","TMGXINST",680,0) ;" -- if so, then put RecNum-IEN of record into variable pointed to by OutVarP "RTN","TMGXINST",681,0) ;"Syntax: e.g. <LookupFileInfo id="Kevin" OutVar="MyVar"></LookupFileInfo> "RTN","TMGXINST",682,0) ;"Input: Params -- an array loaded with expected parameters. I.e.: "RTN","TMGXINST",683,0) ;" Params(cId): the ID of the <Record> data entry. "RTN","TMGXINST",684,0) ;" Params(cId)="Kevin" in our example "RTN","TMGXINST",685,0) ;" Params(cOutput)=the NAME of a variable to put RecNum-IEN into. "RTN","TMGXINST",686,0) ;" Params(cOutput)="MyVar" in example "RTN","TMGXINST",687,0) ;"Output: OutVarP is loaded with data, i.e.: "RTN","TMGXINST",688,0) ;" @OutVarP@(cRecNum)=81 "RTN","TMGXINST",689,0) ;" @OutVarP@(cFile)=200 "RTN","TMGXINST",690,0) ;" @OutVarP@(cGlobal)="^VA(200)" "RTN","TMGXINST",691,0) ;" @OutVarP@(cGlobal,cOpen)="^VA(200," "RTN","TMGXINST",692,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",693,0) ;"Note: Even if <Record> specifies a RecNum="2", this function will STILL do a "RTN","TMGXINST",694,0) ;" search and return THAT value, not the "2" in this example. "RTN","TMGXINST",695,0) "RTN","TMGXINST",696,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoLookup") "RTN","TMGXINST",697,0) "RTN","TMGXINST",698,0) new Data "RTN","TMGXINST",699,0) new RecNumIEN "RTN","TMGXINST",700,0) new result set result=cOKToCont "RTN","TMGXINST",701,0) new ID set ID=$get(Params(cId)) "RTN","TMGXINST",702,0) new OutVarP set OutVarP=$get(Params(cOutput)) "RTN","TMGXINST",703,0) "RTN","TMGXINST",704,0) set result=$$DoShow(.Params) ;"Show any associated text as a message "RTN","TMGXINST",705,0) "RTN","TMGXINST",706,0) if OutVarP="" goto LkDone "RTN","TMGXINST",707,0) "RTN","TMGXINST",708,0) ;"Parse XML data into a usable form. Verification is done. "RTN","TMGXINST",709,0) if '$$GetRInfo(ID,.Data) do goto LkDone "RTN","TMGXINST",710,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to process <Record> section with id='"_ID_"'.") "RTN","TMGXINST",711,0) . set result=cAbort ;"0=Abort "RTN","TMGXINST",712,0) "RTN","TMGXINST",713,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Parsed data.") "RTN","TMGXINST",714,0) set @OutVarP@(cFile)=$get(Data(0,cFile)) "RTN","TMGXINST",715,0) set @OutVarP@(cGlobal)=$get(Data(0,cFile,cGlobal)) "RTN","TMGXINST",716,0) set @OutVarP@(cGlobal,cOpen)=$get(Data(0,cFile,cGlobal,cOpen)) "RTN","TMGXINST",717,0) "RTN","TMGXINST",718,0) set result=$$GetRecMatch^TMGDBAPI(.Data,.RecNumIEN) ;"if no prior record, returns 0 "RTN","TMGXINST",719,0) ;"set RecNumIEN=$$GetRecMatch^TMGDBAPI(.Data) ;"if no prior record, returns 0 "RTN","TMGXINST",720,0) set @OutVarP@(cRecNum)=RecNumIEN "RTN","TMGXINST",721,0) "RTN","TMGXINST",722,0) LkDone "RTN","TMGXINST",723,0) set result=(+result>0) ;"Change RecNum-IEN into boolean 1 or 0 "RTN","TMGXINST",724,0) if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Lookup command failed.") "RTN","TMGXINST",725,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoLookup") "RTN","TMGXINST",726,0) quit result "RTN","TMGXINST",727,0) "RTN","TMGXINST",728,0) "RTN","TMGXINST",729,0) DoValueLookup(Params) "RTN","TMGXINST",730,0) ;"Purpose: To look for a value of a given value in a given record in given file. "RTN","TMGXINST",731,0) ;"Syntax: e.g. <LookupFieldValue File="NEW PERSON" RecNum="1" Field=".01" OutVar="MyVar"> "RTN","TMGXINST",732,0) ;"Input: Params -- an array loaded with expected parameters. I.e.: "RTN","TMGXINST",733,0) ;" Params(cFile)="NEW PERSON" in our example "RTN","TMGXINST",734,0) ;" Params(cRecNum)="1" in example "RTN","TMGXINST",735,0) ;" Params(cField)=".01" in our example (could be Name of field) "RTN","TMGXINST",736,0) ;" Params(cOutput)="MyVar" "RTN","TMGXINST",737,0) ;"Output: MyVar is loaded with data, i.e.: "RTN","TMGXINST",738,0) ;" MyVar(cFile)=200 "RTN","TMGXINST",739,0) ;" MyVar(cGlobal)="^VA(200)" "RTN","TMGXINST",740,0) ;" MyVar(cGlobal,cOpen)="^VA(200," "RTN","TMGXINST",741,0) ;" MyVar(cRecNum)=1 "RTN","TMGXINST",742,0) ;" MyVar(cField)=.01 "RTN","TMGXINST",743,0) ;" MyVar(cValue)=xxx <-- the looked-up value "RTN","TMGXINST",744,0) ;"Returns: If should continue execution: 1=OK to continue. 0=unsuccessful lookup "RTN","TMGXINST",745,0) ;"Note: I am getting values by directly looking into database, rather than use "RTN","TMGXINST",746,0) ;" the usual lookup commands. I am doing this so that there will be no "RTN","TMGXINST",747,0) ;" 'hidden' data, based on security etc. "RTN","TMGXINST",748,0) "RTN","TMGXINST",749,0) new result "RTN","TMGXINST",750,0) "RTN","TMGXINST",751,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoValueLookup") "RTN","TMGXINST",752,0) "RTN","TMGXINST",753,0) set result=$$ParamSubstitute(.Params) "RTN","TMGXINST",754,0) if result=cAbort goto DVLDone "RTN","TMGXINST",755,0) "RTN","TMGXINST",756,0) set result=$$ValueLookup^TMGDBAPI(.Params) "RTN","TMGXINST",757,0) "RTN","TMGXINST",758,0) DVLDone "RTN","TMGXINST",759,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoValueLookup") "RTN","TMGXINST",760,0) quit result "RTN","TMGXINST",761,0) "RTN","TMGXINST",762,0) "RTN","TMGXINST",763,0) DoFileUtility(Params) "RTN","TMGXINST",764,0) ;"Purpose: To provide file access/manipulation utilities to script user "RTN","TMGXINST",765,0) ;"syntax: "RTN","TMGXINST",766,0) ;" <FileUtility File="NEW PERSON" Fn="xxx" RecNum="1" Field=".01" OutVar"MyOutVar" Value="xx" > "RTN","TMGXINST",767,0) ;" File: The name of the file to act upon. "RTN","TMGXINST",768,0) ;" File may have subnodes (i.e. "NEW PERSON|ALIAS|TITLE") "RTN","TMGXINST",769,0) ;" **BUT**, any deletion or set values will only work on top level (i.e. "NEW PERSON") "RTN","TMGXINST",770,0) ;" Fn can be on of the following [OPTIONAL]. (Data substitution is allowed) "RTN","TMGXINST",771,0) ;" Fn="delete" If Field is not specified: "RTN","TMGXINST",772,0) ;" Will cause record RecNum to be deleted. "RTN","TMGXINST",773,0) ;" MyOutVar("DELETED")=RecNum of deleted record, or "RTN","TMGXINST",774,0) ;" 0 if not found. "RTN","TMGXINST",775,0) ;" If Field IS specified: "RTN","TMGXINST",776,0) ;" Will delete the value in field, in record RecNum "RTN","TMGXINST",777,0) ;" Note: delete is intended only for the highest-level records "RTN","TMGXINST",778,0) ;" (i.e. not subfiels, or multiple fields) "RTN","TMGXINST",779,0) ;" Note: delete method uses ^DIK to delete the record "RTN","TMGXINST",780,0) ;" Fn="info" Will just fill in info below. "RTN","TMGXINST",781,0) ;" If Fn not specified, this is default "RTN","TMGXINST",782,0) ;" Fn="set" Will put Value into Field, in RecNum, in File (all required) "RTN","TMGXINST",783,0) ;" RecNum: [OPTIONAL] Specifies which record to act on. If not "RTN","TMGXINST",784,0) ;" specified, then just file info is returned. Data substitution is allowed "RTN","TMGXINST",785,0) ;" Field: [OPTIONAL] Specifies which field to act on. Data substitution is allowed "RTN","TMGXINST",786,0) ;" OutVar: Needed to get information back from function (but still Optional) "RTN","TMGXINST",787,0) ;" Gives name of variable to put info into. "RTN","TMGXINST",788,0) ;" Data substitution is allowed. "RTN","TMGXINST",789,0) ;"Input: Params -- an array loaded with expected parameters. I.e.: "RTN","TMGXINST",790,0) ;" Params(cFile)="NEW PERSON" in our example "RTN","TMGXINST",791,0) ;" Params(cFn)="info" or "delete", or "set" "RTN","TMGXINST",792,0) ;" Params(cRecNum)="1" in example "RTN","TMGXINST",793,0) ;" Params(cField)=".01" in our example (could be Name of field) "RTN","TMGXINST",794,0) ;" Params(cOutput)="MyVar" "RTN","TMGXINST",795,0) ;"Output: MyVar is loaded with data, i.e. "RTN","TMGXINST",796,0) ;" i.e. MyOutVar("FILE")=Filenumber "RTN","TMGXINST",797,0) ;" MyOutVar("FILE","FILE")=SubFilenumber <-- only if subnodes input in File name (e.g."ALIAS") "RTN","TMGXINST",798,0) ;" MyOutVar("FILE","FILE","FILE")=SubSubFilenumber <-- only if subnodes input in File name (e.g."TITLE") "RTN","TMGXINST",799,0) ;" MyOutVar("GLOBAL")="^VA(200)" "RTN","TMGXINST",800,0) ;" MyOutVar("GLOBAL, OPEN")="^VA(200," "RTN","TMGXINST",801,0) ;" MyOutVar("RECNUM")=record number "RTN","TMGXINST",802,0) ;" MyOutVar("FIELD")=Filenumber "RTN","TMGXINST",803,0) ;" MyOutVar("VALUE")=xxxx <=== value of field (PRIOR TO deletion, if deleted) "RTN","TMGXINST",804,0) ;" MyOutVar("NEXTREC")=record number after RecNum, or "" if none "RTN","TMGXINST",805,0) ;" MyOutVar("PREVREC")=record number before RecNum, or "" if none "RTN","TMGXINST",806,0) ;" MyOutVar("FN")=the function executed "RTN","TMGXINST",807,0) ;" MyOutVar("NUMRECS")=Number of records in file PRIOR to any deletions "RTN","TMGXINST",808,0) ;" MyOutVar("FIRSTREC")=Rec number of first record in file "RTN","TMGXINST",809,0) ;" MyOutVar("LASTREC")=Rec number of last record in file "RTN","TMGXINST",810,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort "RTN","TMGXINST",811,0) ;"Note: I am getting values by directly looking into database, rather than use "RTN","TMGXINST",812,0) ;" the usual lookup commands. I am doing this so that there will be no "RTN","TMGXINST",813,0) ;" 'hidden' data, based on security etc. "RTN","TMGXINST",814,0) "RTN","TMGXINST",815,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoFileUtility") "RTN","TMGXINST",816,0) "RTN","TMGXINST",817,0) new result "RTN","TMGXINST",818,0) "RTN","TMGXINST",819,0) set result=$$ParamSubstitute(.Params) "RTN","TMGXINST",820,0) if result=cAbort goto DFUTDone "RTN","TMGXINST",821,0) "RTN","TMGXINST",822,0) set result=$$FileUtility^TMGDBAPI(.Params) "RTN","TMGXINST",823,0) "RTN","TMGXINST",824,0) DFUTDone "RTN","TMGXINST",825,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoFileUtility") "RTN","TMGXINST",826,0) quit result "RTN","TMGXINST",827,0) "RTN","TMGXINST",828,0) "RTN","TMGXINST",829,0) DoSearchRec(Params) "RTN","TMGXINST",830,0) ;"Purpose: To allow the user to search for a specif record number "RTN","TMGXINST",831,0) ;"Syntax: <SearchRec File="PERSON CLASS" InVar="MyInput" OutVar="MyOutput"></SearchRec> "RTN","TMGXINST",832,0) ;" File: The name of the file to act upon. "RTN","TMGXINST",833,0) ;" InVar: the name of a variable with global scope that will hold lookup info "RTN","TMGXINST",834,0) ;" OutVar: the name of variable to receive results "RTN","TMGXINST",835,0) ;"Input: Params -- an array loaded with expected parameters. I.e.: "RTN","TMGXINST",836,0) ;" Params(cFile)="NEW PERSON" in our example "RTN","TMGXINST",837,0) ;" Params(cOutput)="MyOutput" "RTN","TMGXINST",838,0) ;" Params(cInput)="MyInput" "RTN","TMGXINST",839,0) ;"Note: The format of the input params variable (e.g. 'MyInput') should be as follows: "RTN","TMGXINST",840,0) ;" MyInput(FieldNum)=ValueToSearchFor "RTN","TMGXINST",841,0) ;" MyInput(FieldNum)=ValueToSearchFor "RTN","TMGXINST",842,0) ;" MyInput(FieldNum)=ValueToSearchFor "RTN","TMGXINST",843,0) ;" ... etc. "RTN","TMGXINST",844,0) ;"Output: MyVar is loaded with data, i.e. "RTN","TMGXINST",845,0) ;" MyOutVar("RECNUM")=record number, or 0 if not found "RTN","TMGXINST",846,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort "RTN","TMGXINST",847,0) "RTN","TMGXINST",848,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoSearchRec") "RTN","TMGXINST",849,0) "RTN","TMGXINST",850,0) new result set result=cAbort "RTN","TMGXINST",851,0) new SrchParams,RecNum,OutVar "RTN","TMGXINST",852,0) new MyInput,MyOutput "RTN","TMGXINST",853,0) "RTN","TMGXINST",854,0) if $$DoShow(.Params)=0 goto DSRDone ;"Show any associated text as a message "RTN","TMGXINST",855,0) "RTN","TMGXINST",856,0) if TMGDEBUG>0 do ArrayDump^TMGDEBUG("Params") ;"zwr Params(*) "RTN","TMGXINST",857,0) "RTN","TMGXINST",858,0) set MyInput=$get(Params(cInput)) "RTN","TMGXINST",859,0) set MyOutput=$get(Params(cOutput)) "RTN","TMGXINST",860,0) if (MyOutput="")!(MyInput="") goto DSRDone ;"result=cAbort be default "RTN","TMGXINST",861,0) "RTN","TMGXINST",862,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"MyInput=",MyInput) "RTN","TMGXINST",863,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"MyOutput=",MyOutput) "RTN","TMGXINST",864,0) merge SrchParams=@MyInput "RTN","TMGXINST",865,0) set SrchParams(0,cFile)=$get(Params(cFile)) "RTN","TMGXINST",866,0) set RecNum=$$RecFind^TMGDBAPI(.SrchParams) "RTN","TMGXINST",867,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Found record number: ",RecNum) "RTN","TMGXINST",868,0) set @MyOutput@(cRecNum)=RecNum "RTN","TMGXINST",869,0) if RecNum=0 goto DSRDone "RTN","TMGXINST",870,0) set result=cOKToCont "RTN","TMGXINST",871,0) "RTN","TMGXINST",872,0) DSRDone "RTN","TMGXINST",873,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoSearchRec") "RTN","TMGXINST",874,0) quit result "RTN","TMGXINST",875,0) "RTN","TMGXINST",876,0) "RTN","TMGXINST",877,0) DoUpload(Params) "RTN","TMGXINST",878,0) ;"Purpose: To take data from XML file, and get it up into the VistA database "RTN","TMGXINST",879,0) ;"Syntax: e.g. <UploadRecord id="Kevin"></UploadRecord> "RTN","TMGXINST",880,0) ;"Note: ***See documentation in GetRInfo for expected formats "RTN","TMGXINST",881,0) ;"Input: Params -- an array that holds all parameters (or is undefined if there were none) "RTN","TMGXINST",882,0) ;" Params(cId,cUpperCase) -- the ID ofthe data to upload "RTN","TMGXINST",883,0) ;" Expected ID -- the ID of the <Record> data entry. e.g. "Kevin" in our example "RTN","TMGXINST",884,0) ;" Params(cOutput)=the NAME of a variable to put RecNum-IEN into. (Optional) "RTN","TMGXINST",885,0) ;" i.g. Params(cOutput)="MyVar" will cause MyVar=IEN "RTN","TMGXINST",886,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",887,0) "RTN","TMGXINST",888,0) new Data "RTN","TMGXINST",889,0) new result set result=cOKToCont "RTN","TMGXINST",890,0) new RecNumIEN "RTN","TMGXINST",891,0) "RTN","TMGXINST",892,0) new OutVarP set OutVarP=$get(Params(cOutput)) "RTN","TMGXINST",893,0) "RTN","TMGXINST",894,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoUpload") "RTN","TMGXINST",895,0) "RTN","TMGXINST",896,0) set result=$$DoShow(.Params) ;"Show any associated text as a message "RTN","TMGXINST",897,0) "RTN","TMGXINST",898,0) new ID "RTN","TMGXINST",899,0) set ID=$get(Params(cId,cUpperCase)) "RTN","TMGXINST",900,0) if ID="" do goto ULDone "RTN","TMGXINST",901,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get ID of file to upload!") "RTN","TMGXINST",902,0) "RTN","TMGXINST",903,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Uploading file info -- id="_ID) "RTN","TMGXINST",904,0) "RTN","TMGXINST",905,0) ;"Parse XML data into a usable form. Verification is done. "RTN","TMGXINST",906,0) if '$$GetRInfo(ID,.Data) do goto ULDone "RTN","TMGXINST",907,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to process <Record> section with id='"_ID_"'.") "RTN","TMGXINST",908,0) . set result=cAbort ;"0=Abort "RTN","TMGXINST",909,0) "RTN","TMGXINST",910,0) set RecNumIEN=$get(Data(0,cRecNum),0) ;"Get user-specified Record Num(IEN), or null "RTN","TMGXINST",911,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"User-requested recordnum is (0=not requested): ",RecNumIEN) "RTN","TMGXINST",912,0) set result=$$UploadData^TMGDBAPI(.Data,.RecNumIEN) "RTN","TMGXINST",913,0) if OutVarP'="" do "RTN","TMGXINST",914,0) . set @OutVarP@(cRecNum)=RecNumIEN "RTN","TMGXINST",915,0) "RTN","TMGXINST",916,0) ULDone "RTN","TMGXINST",917,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Result = ",result) "RTN","TMGXINST",918,0) if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Error uploading data.") "RTN","TMGXINST",919,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoUpload") "RTN","TMGXINST",920,0) quit result "RTN","TMGXINST",921,0) "RTN","TMGXINST",922,0) "RTN","TMGXINST",923,0) "RTN","TMGXINST",924,0) GetRInfo(ID,Data) "RTN","TMGXINST",925,0) ;"Purpose: To get record info from the <DATA> section of the XML file, "RTN","TMGXINST",926,0) ;" and to store it in the Data variable. "RTN","TMGXINST",927,0) ;"Input: ID: The name of the record info to get. "RTN","TMGXINST",928,0) ;" e.g. to get the info for this entry: "RTN","TMGXINST",929,0) ;" <Record id="Kevin" File="1234.1"> "RTN","TMGXINST",930,0) ;" Then ID should = "Kevin" (no extra quotes) "RTN","TMGXINST",931,0) ;" Data: This is to be an array that is passed by reference "RTN","TMGXINST",932,0) ;" Any preexisting contents will be deleted "RTN","TMGXINST",933,0) ;" See output below. "RTN","TMGXINST",934,0) ;"Note: The syntax of the <Record> block is as follows. Note, <Record> "RTN","TMGXINST",935,0) ;" should be a child (i.e. not a grandchild) of the <DATA> block. "RTN","TMGXINST",936,0) ;" example: "RTN","TMGXINST",937,0) ;" <Record id="InstFile" File="1234.1"> "RTN","TMGXINST",938,0) ;" or <Record id="InstFile" File="NEW PERSON"> "RTN","TMGXINST",939,0) ;" or <Record id="InstFile" File="NEW PERSON" RecNum="1"> "RTN","TMGXINST",940,0) ;" <Field id=".01" MatchThis="true">MyData1</Field> "RTN","TMGXINST",941,0) ;" <Field id=".02" MatchValue="John">Bill</Field> "RTN","TMGXINST",942,0) ;" <Field id=".03">MyData3</Field> "RTN","TMGXINST",943,0) ;" <Field id=".04">MyData4</Field> "RTN","TMGXINST",944,0) ;" <Field id="NAME">MyData5</Field> "RTN","TMGXINST",945,0) ;" <Field id="ITEM/.01">SubEntry1</Field> "RTN","TMGXINST",946,0) ;" <Field id="ITEM/SYNONYM">SE1</Field> ;"Note: SYNONYM here is field .02 "RTN","TMGXINST",947,0) ;" <Field id="ITEM/INFO">'Some Info'</Field> ;"Note: INFO here is field .03 "RTN","TMGXINST",948,0) ;" <Field id="ITEM/MENU">SubEntry2</Field> <-- start of 2nd subfile entry "RTN","TMGXINST",949,0) ;" <Field id="ITEM/TEXT/INITS">JD</Field> ;"TEXT=.4; INITS=.1 "RTN","TMGXINST",950,0) ;" <Field id="ITEM/TEXT/CREATOR">Doe,John</Field> ;"CREATOR is field .2 "RTN","TMGXINST",951,0) ;" </Record> "RTN","TMGXINST",952,0) ;" "RTN","TMGXINST",953,0) ;" 'id': specifies a name that is used in <UploadRecord> command "RTN","TMGXINST",954,0) ;" 'File': specifies the filenumber or formal file name to put info into "RTN","TMGXINST",955,0) ;" 'RecNum': an OPTIONAL parameter. If specified, data will be forced into the "RTN","TMGXINST",956,0) ;" specified record number. If not specified, then data matching is used "RTN","TMGXINST",957,0) ;" to determine where to put record. Data substitution is allowed. "RTN","TMGXINST",958,0) ;" A value of 0 will be treated as if no value specified. "RTN","TMGXINST",959,0) ;" "RTN","TMGXINST",960,0) ;" At least one (and likely many) <Field> entries must exist in the <Record> block "RTN","TMGXINST",961,0) ;" Syntax: "RTN","TMGXINST",962,0) ;" <Field id=".01">MyDataplacing</Field> "RTN","TMGXINST",963,0) ;" <Field id="NAME" MatchThis="true">MyDataplacing</Field> "RTN","TMGXINST",964,0) ;" <Field id="ITEM/SYNONYM">M1</Field> "RTN","TMGXINST",965,0) ;" "RTN","TMGXINST",966,0) ;" 'id' gives the field number or name "RTN","TMGXINST",967,0) ;" Multiple field names/numbers may be included here. "RTN","TMGXINST",968,0) ;" "ITEM/SYNONYM" means that SYNONYM is a field within "RTN","TMGXINST",969,0) ;" the ITEM subfile (a field with multiple entries). Thus "RTN","TMGXINST",970,0) ;" field ITEM would be located, then SYNONYM subfield. "RTN","TMGXINST",971,0) ;" To have a '/' character as part of the field name, and not "RTN","TMGXINST",972,0) ;" to be interpreted as a node divider, then use '//', this will "RTN","TMGXINST",973,0) ;" be replaced with '/'. "RTN","TMGXINST",974,0) ;" Note: When a field allows multiple entries (like "ITEM" above), "RTN","TMGXINST",975,0) ;" then there must be a way to determine group of the data into "RTN","TMGXINST",976,0) ;" one entry or another. The field ".01" (or a name that resolves "RTN","TMGXINST",977,0) ;" to ".01" will serve this purpose. For example: "RTN","TMGXINST",978,0) ;" ITEM|.01 <---- the beginning of one entry "RTN","TMGXINST",979,0) ;" ITEM|SYNONYM "RTN","TMGXINST",980,0) ;" ITEM|INFO "RTN","TMGXINST",981,0) ;" ITEM|MENU <---- beginning of the next entry. (MENU=.01) "RTN","TMGXINST",982,0) ;" ITEM|TEXT|INITS "RTN","TMGXINST",983,0) ;" ITEM|TEXT|CREATOR "RTN","TMGXINST",984,0) ;" 'MatchThis': if value="true", then this entry will be used to "RTN","TMGXINST",985,0) ;" search for preexisting record in file. Should only be "RTN","TMGXINST",986,0) ;" used for highest levels, i.e. match in subfields not supported "RTN","TMGXINST",987,0) ;" 'MatchValue': if specified, then value of entry will be used to "RTN","TMGXINST",988,0) ;" search for preexisting record in file. Should only be "RTN","TMGXINST",989,0) ;" used for highest levels, i.e. match in subfields not supported "RTN","TMGXINST",990,0) ;" "RTN","TMGXINST",991,0) ;" The data is found between the <Field></Field> tags. "RTN","TMGXINST",992,0) ;" Note: The data values may contain lookup codes. For example "RTN","TMGXINST",993,0) ;" <Field id="ITEM|CREATOR">{{Data.Site.Office[EastSide].Field[Doctor]}}</Field> "RTN","TMGXINST",994,0) ;" would cause the {{..}} value to be looked up in the corresponding "RTN","TMGXINST",995,0) ;" section in the XML file and replaced. Thus the line would be converted to: "RTN","TMGXINST",996,0) ;" <Field id="ITEM|CREATOR">Kevin</Field> "RTN","TMGXINST",997,0) ;" "RTN","TMGXINST",998,0) ;"Output: The Data array will be filed with data. Thus for above example: "RTN","TMGXINST",999,0) ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion "RTN","TMGXINST",1000,0) ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," "RTN","TMGXINST",1001,0) ;" Data(0,cRecNum)=2 <-- only if user-specified. "RTN","TMGXINST",1002,0) ;" Data(0,cEntries)=1 "RTN","TMGXINST",1003,0) ;" Data(1,".01")="MyData1" "RTN","TMGXINST",1004,0) ;" Data(1,".01",cMatchValue)="MyData1" "RTN","TMGXINST",1005,0) ;" Data(1,".02")="Bill" "RTN","TMGXINST",1006,0) ;" Data(1,".02",cMatchValue)="John" "RTN","TMGXINST",1007,0) ;" Data(1,".03")="MyData3" "RTN","TMGXINST",1008,0) ;" Data(1,".04")="MyData4" "RTN","TMGXINST",1009,0) ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" "RTN","TMGXINST",1010,0) ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" "RTN","TMGXINST",1011,0) ;" Data(1,".07",1,".01")="SubEntry1" "RTN","TMGXINST",1012,0) ;" Data(1,".07",1,".02")="SE1" "RTN","TMGXINST",1013,0) ;" Data(1,".07",1,".03")="'Some Info'" "RTN","TMGXINST",1014,0) ;" Data(1,".07",2,".01")="SubEntry2" "RTN","TMGXINST",1015,0) ;" Data(1,".07",2,".02")="SE2" "RTN","TMGXINST",1016,0) ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 "RTN","TMGXINST",1017,0) ;" Data(1,".07",2,".04",1,".01")="JD" "RTN","TMGXINST",1018,0) ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" "RTN","TMGXINST",1019,0) ;" ADDENDUM "RTN","TMGXINST",1020,0) ;" Data(1,".01",cFlags)=any flags specified for given field. "RTN","TMGXINST",1021,0) ;" only present if user specified. "RTN","TMGXINST",1022,0) "RTN","TMGXINST",1023,0) "RTN","TMGXINST",1024,0) ;" Note: The output is somewhat validated, in that if file NAME is given "RTN","TMGXINST",1025,0) ;" instead of a number, the name will be converted. The same applies "RTN","TMGXINST",1026,0) ;" for field NUMBERS. This ensures that the file exists, and "RTN","TMGXINST",1027,0) ;" puts the global reference in the array "RTN","TMGXINST",1028,0) ;"Result: 1 if valid data in Data, 0 if data invalid "RTN","TMGXINST",1029,0) "RTN","TMGXINST",1030,0) new result "RTN","TMGXINST",1031,0) new ChildNode "RTN","TMGXINST",1032,0) new FileNode "RTN","TMGXINST",1033,0) new Text,TextArray "RTN","TMGXINST",1034,0) new NodeName,AtrN,AtrVal "RTN","TMGXINST",1035,0) new AtrMatch,MatchValue "RTN","TMGXINST",1036,0) new MatchThis "RTN","TMGXINST",1037,0) new Entries set Entries=0 "RTN","TMGXINST",1038,0) new Field,FieldNumber "RTN","TMGXINST",1039,0) new RecNum "RTN","TMGXINST",1040,0) new Flags "RTN","TMGXINST",1041,0) set result=cOKToCont "RTN","TMGXINST",1042,0) set ChildNode=0 "RTN","TMGXINST",1043,0) set Entries=0 "RTN","TMGXINST",1044,0) new FileNumber,FileName,File "RTN","TMGXINST",1045,0) new index "RTN","TMGXINST",1046,0) new DataP set DataP="Data" "RTN","TMGXINST",1047,0) new EntryNumber set EntryNumber=0 ;"was 1 "RTN","TMGXINST",1048,0) "RTN","TMGXINST",1049,0) new InitDebug set InitDebug=TMGDEBUG "RTN","TMGXINST",1050,0) ;"set TMGDEBUG=0 ;"Force this function to not put out TMGDEBUG info. "RTN","TMGXINST",1051,0) "RTN","TMGXINST",1052,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetRInfo") "RTN","TMGXINST",1053,0) "RTN","TMGXINST",1054,0) if $data(ID)'=0 do "RTN","TMGXINST",1055,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"var ID=",ID) "RTN","TMGXINST",1056,0) else do "RTN","TMGXINST",1057,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"var ID=(empty)") "RTN","TMGXINST",1058,0) "RTN","TMGXINST",1059,0) if $data(ID)'=0 do "RTN","TMGXINST",1060,0) . set FileNode=$$GetDescIDNode(DataNode,cRecord,ID) "RTN","TMGXINST",1061,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Node with ",cRecord,"=",FileNode) "RTN","TMGXINST",1062,0) else do "RTN","TMGXINST",1063,0) . set FileNode=0 "RTN","TMGXINST",1064,0) if FileNode=0 do goto GInfPast "RTN","TMGXINST",1065,0) . set result=cAbort "RTN","TMGXINST",1066,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"File entry named '"_ID_"' not found.") "RTN","TMGXINST",1067,0) "RTN","TMGXINST",1068,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Looking for user-specified record number in node: ",FileNode) "RTN","TMGXINST",1069,0) set RecNum=$$GetAtrVal^TMGXMLT(XMLHandle,FileNode,cRecNum) ;"get user-specified RecNum IEN (optional) "RTN","TMGXINST",1070,0) set result=$$CheckSubstituteData(.RecNum) "RTN","TMGXINST",1071,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Specified RecNum='",RecNum,"'") "RTN","TMGXINST",1072,0) if +RecNum>0 set Data(0,cRecNum)=RecNum "RTN","TMGXINST",1073,0) "RTN","TMGXINST",1074,0) set File=$$GetAtrVal^TMGXMLT(XMLHandle,FileNode,cFile) "RTN","TMGXINST",1075,0) set Data(0,cFile)=File "RTN","TMGXINST",1076,0) set result=$$SetupFileNum^TMGDBAPI(.Data) "RTN","TMGXINST",1077,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Setup file number result=",result) "RTN","TMGXINST",1078,0) if result=cAbort do goto GInfPast "RTN","TMGXINST",1079,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to set up file '"_File_"'.") "RTN","TMGXINST",1080,0) set FileNumber=$get(Data(0,cFile),-1) "RTN","TMGXINST",1081,0) if FileNumber=-1 do goto GInfQuit "RTN","TMGXINST",1082,0) . set result=cAbort "RTN","TMGXINST",1083,0) "RTN","TMGXINST",1084,0) GInfLoop "RTN","TMGXINST",1085,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Starting GInfLoop") "RTN","TMGXINST",1086,0) set ChildNode=$$CHILD^MXMLDOM(XMLHandle,FileNode,ChildNode) "RTN","TMGXINST",1087,0) if ChildNode=0 goto GInfPast "RTN","TMGXINST",1088,0) set NodeName=$$GetNName^TMGXMLT(XMLHandle,ChildNode) "RTN","TMGXINST",1089,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Name="_NodeName) "RTN","TMGXINST",1090,0) if NodeName'=cField goto GInfLoop "RTN","TMGXINST",1091,0) set Text=$$Get1NText^TMGXMLT(XMLHandle,ChildNode,.TextArray) "RTN","TMGXINST",1092,0) if $data(TextArray(2)) do "RTN","TMGXINST",1093,0) . merge Text(cText)=TextArray "RTN","TMGXINST",1094,0) "RTN","TMGXINST",1095,0) if $$UP^XLFSTR($$GetAtrVal^TMGXMLT(XMLHandle,ChildNode,cMatchThis))=cTrue do "RTN","TMGXINST",1096,0) . set MatchValue=Text "RTN","TMGXINST",1097,0) set MatchValue=$get(MatchValue) "RTN","TMGXINST",1098,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Attrib Match value='",MatchValue,"'") "RTN","TMGXINST",1099,0) set Entries=Entries+1 "RTN","TMGXINST",1100,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Entries='",Entries,"'") "RTN","TMGXINST",1101,0) "RTN","TMGXINST",1102,0) set Field=$$GetAtrVal^TMGXMLT(XMLHandle,ChildNode,cId) ;"May get either a name or a number "RTN","TMGXINST",1103,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Field='",Field,"'") "RTN","TMGXINST",1104,0) "RTN","TMGXINST",1105,0) ;"Protect any //'s by converting to ~~'s "RTN","TMGXINST",1106,0) set Field=$$Substitute^TMGSTUTL(.Field,c2NodeDiv,cProtect) "RTN","TMGXINST",1107,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"After substitution, Field '",cId,"'=",Field) "RTN","TMGXINST",1108,0) "RTN","TMGXINST",1109,0) set Flags=$$GetAtrVal^TMGXMLT(XMLHandle,ChildNode,cFlags) ;"Get any flags that might exist. "RTN","TMGXINST",1110,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Flags for node #",ChildNode," = '",Flags,"'") "RTN","TMGXINST",1111,0) "RTN","TMGXINST",1112,0) ;"Allow recursive calls via ProcessRNode "RTN","TMGXINST",1113,0) set result=$$ProcessRNode(DataP,Field,.Text,.EntryNumber,FileNumber,0,MatchValue,Flags) "RTN","TMGXINST",1114,0) if result=cAbort goto GInfQuit "RTN","TMGXINST",1115,0) ;"temp ... set EntryNumber=EntryNumber+1 "RTN","TMGXINST",1116,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"EntryNumber=",EntryNumber) "RTN","TMGXINST",1117,0) "RTN","TMGXINST",1118,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Completed loop cycle (maybe there will be more to come)") "RTN","TMGXINST",1119,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"------------") "RTN","TMGXINST",1120,0) goto GInfLoop "RTN","TMGXINST",1121,0) "RTN","TMGXINST",1122,0) GInfPast "RTN","TMGXINST",1123,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Done with loop") "RTN","TMGXINST",1124,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"------------") "RTN","TMGXINST",1125,0) "RTN","TMGXINST",1126,0) if $data(Data(0,cEntries))=0 do goto GInfQuit "RTN","TMGXINST",1127,0) . set result=cAbort "RTN","TMGXINST",1128,0) "RTN","TMGXINST",1129,0) ;"Ensure that there is at least a .01 field. Required for every record "RTN","TMGXINST",1130,0) ;"Note: I think that other files have multiple KEY fields.... I am not checking "RTN","TMGXINST",1131,0) ;" for this (perhaps I should later??) "RTN","TMGXINST",1132,0) new bFound set bFound=0 "RTN","TMGXINST",1133,0) for index=1:1:Data(0,cEntries) do quit:bFound "RTN","TMGXINST",1134,0) . ;"if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Data(",index,",.01)='",$get(Data(index,".01")),"'") "RTN","TMGXINST",1135,0) . if $data(Data(index,".01")) set bFound=1 "RTN","TMGXINST",1136,0) "RTN","TMGXINST",1137,0) if bFound=0 do goto GInfQuit "RTN","TMGXINST",1138,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Data entry did not specify any entry for field .01") "RTN","TMGXINST",1139,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Here is data:") "RTN","TMGXINST",1140,0) . if TMGDEBUG do ArrayDump^TMGDEBUG("Data") ;"zwr Data(*) "RTN","TMGXINST",1141,0) . set result=cAbort "RTN","TMGXINST",1142,0) "RTN","TMGXINST",1143,0) GInfQuit "RTN","TMGXINST",1144,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetRInfo") "RTN","TMGXINST",1145,0) set TMGDEBUG=InitDebug "RTN","TMGXINST",1146,0) quit result "RTN","TMGXINST",1147,0) "RTN","TMGXINST",1148,0) "RTN","TMGXINST",1149,0) ProcessRNode(DataP,Field,Text,EntryNumber,FileNumber,DoingSubNodes,MatchValue,Flags) "RTN","TMGXINST",1150,0) ;"Purpose: Allow for recursive calling when doing GetRInfo "RTN","TMGXINST",1151,0) ;" This takes one entry and processes it. "RTN","TMGXINST",1152,0) ;"Input: DataP: The 'name' of the data array -- like this: "Data(1)" "RTN","TMGXINST",1153,0) ;" Field: a field name with 0..n subnodes "RTN","TMGXINST",1154,0) ;" i.e. "ITEM", OR "ITEM|NUMBER", OR "ITEM|NUMBER|ID" "RTN","TMGXINST",1155,0) ;" Text: the value that should be put into field. should be passed by REFERENCE "RTN","TMGXINST",1156,0) ;" Text will have the following format: "RTN","TMGXINST",1157,0) ;" Text="First line of text" "RTN","TMGXINST",1158,0) ;" Text(cText,1)="First line of text" <-- only present if multiple "RTN","TMGXINST",1159,0) ;" Text(cText,2)="Second line of text" lines of text present. "RTN","TMGXINST",1160,0) ;" EntryNumber: The current entry number. Should be passed by REFERENCE "RTN","TMGXINST",1161,0) ;" FileNumber: the current file number, or sub-filenumber. DON'T PASS BY REFERENCE "RTN","TMGXINST",1162,0) ;" The first node (i.e. "ITEM") should be field in FileNumber "RTN","TMGXINST",1163,0) ;" DoingSubNodes: 1 if true (changes behavior or entry numbering for subnodes), 0 otherwise "RTN","TMGXINST",1164,0) ;" //AtrMatch: if this field should be matched for during DB lookup "RTN","TMGXINST",1165,0) ;" MatchValue: Value to looking in database when finding matching record. "RTN","TMGXINST",1166,0) ;" Flags: any user specified flags for field "RTN","TMGXINST",1167,0) ;"Result: Returns success 1=OK to continue. 0=Abort "RTN","TMGXINST",1168,0) "RTN","TMGXINST",1169,0) ;"Note: This entry--><Field id="ITEM|TEXT|CREATOR">Doe,John</Field> "RTN","TMGXINST",1170,0) ;"Should result it--> Data(6,".07",2,".04",1,".02")="DOE,JOHN" "RTN","TMGXINST",1171,0) ;"See data format description in GetRInfo "RTN","TMGXINST",1172,0) "RTN","TMGXINST",1173,0) new PartA,PartB "RTN","TMGXINST",1174,0) new tempA,tempB "RTN","TMGXINST",1175,0) new result set result=cOKToCont "RTN","TMGXINST",1176,0) new cFieldNumber set cFieldNumber="Field Number" "RTN","TMGXINST",1177,0) "RTN","TMGXINST",1178,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"ProcessRNode") "RTN","TMGXINST",1179,0) "RTN","TMGXINST",1180,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"DataP='",$get(DataP),"'") "RTN","TMGXINST",1181,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"File number=",$get(FileNumber)) "RTN","TMGXINST",1182,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Field=",$get(Field)) "RTN","TMGXINST",1183,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"EntryNumber=",$get(EntryNumber)) "RTN","TMGXINST",1184,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"MatchValue='",$get(MatchValue),"'") "RTN","TMGXINST",1185,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Flags='",$get(Flags),"'") "RTN","TMGXINST",1186,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"DoingSubNodes=",$get(DoingSubNodes)) "RTN","TMGXINST",1187,0) "RTN","TMGXINST",1188,0) new SpliceArray "RTN","TMGXINST",1189,0) new temp "RTN","TMGXINST",1190,0) "RTN","TMGXINST",1191,0) if Field[cNodeDiv do ;"Parse 'ITEM|NUMBER|ID' into 'ITEM', 'NUMBER', 'ID' "RTN","TMGXINST",1192,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Multiple nodes found for field. Processing...") "RTN","TMGXINST",1193,0) . do CleaveStr^TMGSTUTL(.Field,cNodeDiv,.PartB) "RTN","TMGXINST",1194,0) . set FieldNumber=$$GetNumField^TMGDBAPI(FileNumber,Field) "RTN","TMGXINST",1195,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Parsed off first part of Field. Looking at only '",Field,"'") "RTN","TMGXINST",1196,0) . ;"Note: this does NOT handle processesing of more than 2 nodes. "RTN","TMGXINST",1197,0) . if PartB'=cNull do ;"If PartB has data, then PartB(cFieldNumber) will also have data "RTN","TMGXINST",1198,0) . . if PartB=".01" do "RTN","TMGXINST",1199,0) . . . set PartB(cFieldNumber)=".01" "RTN","TMGXINST",1200,0) . . else do "RTN","TMGXINST",1201,0) . . . new BFileNumber "RTN","TMGXINST",1202,0) . . . set BFileNumber=$$GetSubFileNumber^TMGDBAPI(FileNumber,FieldNumber) ;"get 'file number' of subfile "RTN","TMGXINST",1203,0) . . . if BFileNumber'=0 do "RTN","TMGXINST",1204,0) . . . . set PartB(cFieldNumber)=$$GetNumField^TMGDBAPI(BFileNumber,PartB) "RTN","TMGXINST",1205,0) . . . else set PartB(cFieldNumber)=0 "RTN","TMGXINST",1206,0) . . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Will deal with '",PartB,"' later") "RTN","TMGXINST",1207,0) "RTN","TMGXINST",1208,0) set Field=$$Substitute^TMGSTUTL(.Field,cProtect,cNodeDiv) ;"convert protected ||'s back from }}'s to single | "RTN","TMGXINST",1209,0) if $data(PartB) set PartB=$$Substitute^TMGSTUTL(.PartB,cProtect,cNodeDiv) "RTN","TMGXINST",1210,0) "RTN","TMGXINST",1211,0) set FieldNumber=+Field "RTN","TMGXINST",1212,0) if FieldNumber=0 do "RTN","TMGXINST",1213,0) . set FieldNumber=$$GetNumField^TMGDBAPI(FileNumber,Field) "RTN","TMGXINST",1214,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Converted '",Field,"' to field number ",FieldNumber) "RTN","TMGXINST",1215,0) else if $$VFIELD^DILFD(FileNumber,Field)=0 do goto PFNDone "RTN","TMGXINST",1216,0) . do ShowError^TMGDEBUG(.PriorErrorFound,Field_" is not a valid field number in file "_FileNumber) "RTN","TMGXINST",1217,0) . set result=cAbort "RTN","TMGXINST",1218,0) if FieldNumber=0 do goto PFNDone "RTN","TMGXINST",1219,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to convert field '"_Field_"' to a field number. (Hint: If this name is supposed to contain multiple nodes, did you use '"_cNodeDiv_"' as a divider?)") "RTN","TMGXINST",1220,0) . set result=cAbort "RTN","TMGXINST",1221,0) "RTN","TMGXINST",1222,0) if FieldNumber=.01 do "RTN","TMGXINST",1223,0) . set EntryNumber=EntryNumber+1 ;"Test this!! "RTN","TMGXINST",1224,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Found .01 field. Incrementing EntryNumber to "_EntryNumber) "RTN","TMGXINST",1225,0) "RTN","TMGXINST",1226,0) "RTN","TMGXINST",1227,0) if $data(PartB) do "RTN","TMGXINST",1228,0) . ;"If there are subnodes, then search if current entry should be under a prior entry "RTN","TMGXINST",1229,0) . if $data(@DataP@(EntryNumber-1,FieldNumber,0,cEntries)) do "RTN","TMGXINST",1230,0) . . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"EntryNumber=",EntryNumber) "RTN","TMGXINST",1231,0) . . ;"set EntryNumber=EntryNumber-1 "RTN","TMGXINST",1232,0) . . set DoingSubNodes=1 "RTN","TMGXINST",1233,0) . . ;"if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Attaching current data as a subnode of prior entry.") "RTN","TMGXINST",1234,0) . . ;"if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Changing EntryNumber to ",EntryNumber) "RTN","TMGXINST",1235,0) "RTN","TMGXINST",1236,0) if DoingSubNodes=0 goto PFNPast "RTN","TMGXINST",1237,0) if (EntryNumber=0) do goto PFNDone "RTN","TMGXINST",1238,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"No '.01' field found yet, so skipping processing.") "RTN","TMGXINST",1239,0) "RTN","TMGXINST",1240,0) PFNPast "RTN","TMGXINST",1241,0) if $data(PartB)=0 do "RTN","TMGXINST",1242,0) . set result=$$CheckSubstituteData(.Text) ;"Do any data lookup needed "RTN","TMGXINST",1243,0) . if result=cAbort do "RTN","TMGXINST",1244,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to do data lookup: "_Text) "RTN","TMGXINST",1245,0) . else do "RTN","TMGXINST",1246,0) . . ;"HERE IS WHERE WE PUT THE INFO INTO THE DATA ARRAY. "RTN","TMGXINST",1247,0) . . set @DataP@(EntryNumber,FieldNumber)=Text "RTN","TMGXINST",1248,0) . . set @DataP@(EntryNumber,FieldNumber,"FieldName")=$get(Field) ;"mainly for debugging. "RTN","TMGXINST",1249,0) . . if Flags'=" " set @DataP@(EntryNumber,FieldNumber,cFlags)=Flags "RTN","TMGXINST",1250,0) . . new FieldInfo "RTN","TMGXINST",1251,0) . . do GetFieldInfo^TMGDBAPI(FileNumber,FieldNumber,"FieldInfo") "RTN","TMGXINST",1252,0) . . if $get(FieldInfo("TYPE"))="WORD-PROCESSING" do "RTN","TMGXINST",1253,0) . . . do WPHandle(DataP,EntryNumber,FieldNumber,.Text) "RTN","TMGXINST",1254,0) . . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Setting ",DataP,"(",EntryNumber,",",FieldNumber,")=",Text) "RTN","TMGXINST",1255,0) . . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Flags were: '",Flags,"'") "RTN","TMGXINST",1256,0) else do "RTN","TMGXINST",1257,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"DoingSubNodes=",DoingSubNodes,", PartB='",$get(PartB),"'") "RTN","TMGXINST",1258,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Doing subnodes, so did NOT set ",DataP,"(",EntryNumber,",",FieldNumber,")=",Text) "RTN","TMGXINST",1259,0) "RTN","TMGXINST",1260,0) if result=cAbort goto PFNDone "RTN","TMGXINST",1261,0) "RTN","TMGXINST",1262,0) if FieldNumber=.01 set MatchValue=Text "RTN","TMGXINST",1263,0) "RTN","TMGXINST",1264,0) if (MatchValue'="")!(FieldNumber=.01) do "RTN","TMGXINST",1265,0) . ;"set @DataP@(EntryNumber,FieldNumber,cMatchThis)=1 ;"i.e. true "RTN","TMGXINST",1266,0) . set @DataP@(EntryNumber,FieldNumber,cMatchValue)=MatchValue "RTN","TMGXINST",1267,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Setting ",DataP,"(",EntryNumber,",",FieldNumber,",",cMatchValue,")=",MatchValue) "RTN","TMGXINST",1268,0) "RTN","TMGXINST",1269,0) set @DataP@(0,cEntries)=EntryNumber "RTN","TMGXINST",1270,0) set @DataP@(0,cFile)=FileNumber "RTN","TMGXINST",1271,0) "RTN","TMGXINST",1272,0) if $data(PartB) do ;"I.e. we have subnodes. -- process "RTN","TMGXINST",1273,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Subnodes detected. Here is where we deal with that '",PartB,"'") "RTN","TMGXINST",1274,0) . new SubEntryNumber "RTN","TMGXINST",1275,0) . set SubEntryNumber=$get(@DataP@(EntryNumber,FieldNumber,0,cEntries),0) "RTN","TMGXINST",1276,0) . if (PartB(cFieldNumber)=".01")!(SubEntryNumber=0) do "RTN","TMGXINST",1277,0) . . ;"test ... set SubEntryNumber=SubEntryNumber+1 "RTN","TMGXINST",1278,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"SubEntryNumber=",SubEntryNumber) "RTN","TMGXINST",1279,0) . set FileNumber=$$GetSubFileNumber^TMGDBAPI(FileNumber,FieldNumber) ;"get 'file number' of subfile "RTN","TMGXINST",1280,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"file number=",FileNumber) "RTN","TMGXINST",1281,0) . if FileNumber=0 quit "RTN","TMGXINST",1282,0) . set DataP=$name(@DataP@(EntryNumber,FieldNumber)) "RTN","TMGXINST",1283,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling self recursively") "RTN","TMGXINST",1284,0) . new SubFlags set SubFlags=Flags ;"SubFlags=" " "RTN","TMGXINST",1285,0) . new SubMatchValue set SubMatchValue="" "RTN","TMGXINST",1286,0) . set result=$$ProcessRNode(DataP,PartB,.Text,.SubEntryNumber,FileNumber,1,SubMatchValue,SubFlags) ;"Call self recursively "RTN","TMGXINST",1287,0) "RTN","TMGXINST",1288,0) PFNDone "RTN","TMGXINST",1289,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"ProcessRNode") "RTN","TMGXINST",1290,0) quit result "RTN","TMGXINST",1291,0) "RTN","TMGXINST",1292,0) WPHandle(DataP,EntryNumber,FieldNumber,Text) "RTN","TMGXINST",1293,0) ;"Purpose: to process word-processing fields for ProcessRNode() "RTN","TMGXINST",1294,0) ;" It will get text into form ready for use by FILE^DIE "RTN","TMGXINST",1295,0) ;"Input: DataP: The 'name' of the data array -- like this: "Data(1)" "RTN","TMGXINST",1296,0) ;" EntryNumber: The current entry number. Should be passed by REFERENCE "RTN","TMGXINST",1297,0) ;" FileNumber: the current file number, or sub-filenumber. DON'T PASS BY REFERENCE "RTN","TMGXINST",1298,0) ;" The first node (i.e. "ITEM") should be field in FileNumber "RTN","TMGXINST",1299,0) ;" Text: the value that should be put into field. should be passed by REFERENCE "RTN","TMGXINST",1300,0) ;" Text will have the following format: "RTN","TMGXINST",1301,0) ;" Text="First line of text" "RTN","TMGXINST",1302,0) ;" Text(cText,1)="First line of text" <-- only present if multiple "RTN","TMGXINST",1303,0) ;" Text(cText,2)="Second line of text" lines of text present. "RTN","TMGXINST",1304,0) ;"Result: none "RTN","TMGXINST",1305,0) "RTN","TMGXINST",1306,0) new Array,temp "RTN","TMGXINST",1307,0) new result "RTN","TMGXINST",1308,0) "RTN","TMGXINST",1309,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"WPHandle") "RTN","TMGXINST",1310,0) "RTN","TMGXINST",1311,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Here is Text to use to put into WP field:") "RTN","TMGXINST",1312,0) if TMGDEBUG do ArrayDump^TMGDEBUG("Text") "RTN","TMGXINST",1313,0) if $data(Text(cText)) do "RTN","TMGXINST",1314,0) . set result=$$FormatArray^TMGSTUTL(.Text,.Array,"\n") "RTN","TMGXINST",1315,0) else do "RTN","TMGXINST",1316,0) . do CleaveToArray^TMGSTUTL(Text,"\n",.Array,1) "RTN","TMGXINST",1317,0) "RTN","TMGXINST",1318,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Here is array after processing, ready to put into WP field:") "RTN","TMGXINST",1319,0) if TMGDEBUG do ArrayDump^TMGDEBUG("Array") "RTN","TMGXINST",1320,0) "RTN","TMGXINST",1321,0) merge @DataP@(EntryNumber,FieldNumber,"WP")=Array "RTN","TMGXINST",1322,0) set @DataP@(EntryNumber,FieldNumber)=$name(@DataP@(EntryNumber,FieldNumber,"WP")) "RTN","TMGXINST",1323,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Setting: ",DataP,"(",EntryNumber,",",FieldNumber,")=",$name(@DataP@(EntryNumber,FieldNumber,"WP"))) "RTN","TMGXINST",1324,0) "RTN","TMGXINST",1325,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"WPHandle") "RTN","TMGXINST",1326,0) quit "RTN","TMGXINST",1327,0) "RTN","TMGXINST",1328,0) "RTN","TMGXINST",1329,0) CheckArraySubst(TextArray) "RTN","TMGXINST",1330,0) ;"Purpose: Accept a text array, and scan all lines for any needed data substitution "RTN","TMGXINST",1331,0) ;"Input: TextArray -- should be passed by reference. "RTN","TMGXINST",1332,0) ;" any number scheme of lines may be used. "RTN","TMGXINST",1333,0) ;"Output -- Text array is changed, if passed by reference "RTN","TMGXINST",1334,0) ;"Result: 1=OK to continue, 0=Error (data requested, but not found) "RTN","TMGXINST",1335,0) "RTN","TMGXINST",1336,0) new lineI,Count "RTN","TMGXINST",1337,0) new OneLine "RTN","TMGXINST",1338,0) new result set result=cOKToCont "RTN","TMGXINST",1339,0) "RTN","TMGXINST",1340,0) if $data(TextArray)'=10 goto CKASq "RTN","TMGXINST",1341,0) "RTN","TMGXINST",1342,0) set lineI=$Order(TextArray("")) "RTN","TMGXINST",1343,0) for do quit:(lineI="")!(result=cAbort) "RTN","TMGXINST",1344,0) . set OneLine=TextArray(lineI) "RTN","TMGXINST",1345,0) . set result=$$CheckSubstituteData(.OneLine) ;"Do any data lookup needed "RTN","TMGXINST",1346,0) . set TextArray(lineI)=OneLine "RTN","TMGXINST",1347,0) . set lineI=$Order(TextArray(lineI)) "RTN","TMGXINST",1348,0) "RTN","TMGXINST",1349,0) CKASq "RTN","TMGXINST",1350,0) quit result "RTN","TMGXINST",1351,0) "RTN","TMGXINST",1352,0) ParamSubstitute(Params) "RTN","TMGXINST",1353,0) ;"Purpose: To accept an array of parameters, and do data substitution on all entries "RTN","TMGXINST",1354,0) ;"Input: Params: an array of parameters "RTN","TMGXINST",1355,0) ;"Result: 1=OK to continue, 0=Error (data requested, but not found) "RTN","TMGXINST",1356,0) "RTN","TMGXINST",1357,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"ParamSubstitute") "RTN","TMGXINST",1358,0) "RTN","TMGXINST",1359,0) new result set result=cAbort "RTN","TMGXINST",1360,0) if $data(Params)=0 goto PStDone "RTN","TMGXINST",1361,0) new index "RTN","TMGXINST",1362,0) "RTN","TMGXINST",1363,0) set index=$order(Params("")) "RTN","TMGXINST",1364,0) for do quit:(index="")!(result=cAbort) "RTN","TMGXINST",1365,0) . if index="" quit "RTN","TMGXINST",1366,0) . new s "RTN","TMGXINST",1367,0) . if $data(Params(index))#10'=0 do "RTN","TMGXINST",1368,0) . . set s=Params(index) "RTN","TMGXINST",1369,0) . . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Looking at Param(",index,")=",s) "RTN","TMGXINST",1370,0) . . set result=$$CheckSubstituteData(.s) "RTN","TMGXINST",1371,0) . . if result=cAbort quit "RTN","TMGXINST",1372,0) . . set Params(index)=s "RTN","TMGXINST",1373,0) . else do "RTN","TMGXINST",1374,0) . . new subindex "RTN","TMGXINST",1375,0) . . set subindex=$order(Params(index,"")) "RTN","TMGXINST",1376,0) . . for do quit:(subindex="")!(result=cAbort) "RTN","TMGXINST",1377,0) . . . set s=Params(index,subindex) "RTN","TMGXINST",1378,0) . . . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Looking at Param("_index_","_subindex_")=",s) "RTN","TMGXINST",1379,0) . . . set result=$$CheckSubstituteData(.s) "RTN","TMGXINST",1380,0) . . . if result=cAbort quit "RTN","TMGXINST",1381,0) . . . set Params(index)=s "RTN","TMGXINST",1382,0) . . . set subindex=$order(Params(index,subindex)) "RTN","TMGXINST",1383,0) . set index=$order(Params(index)) "RTN","TMGXINST",1384,0) "RTN","TMGXINST",1385,0) PStDone "RTN","TMGXINST",1386,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"ParamSubstitute") "RTN","TMGXINST",1387,0) quit result "RTN","TMGXINST",1388,0) "RTN","TMGXINST",1389,0) CheckSubstituteData(Text) "RTN","TMGXINST",1390,0) ;"Purpose: To look for data-substitution codes (i.e. {{...}}), and if "RTN","TMGXINST",1391,0) ;" found, to replace with data from XML file "RTN","TMGXINST",1392,0) ;"Input: A line of text that may or may not have codes. ** Should be passed by reference "RTN","TMGXINST",1393,0) ;"Output: Text is modified if passed by reference "RTN","TMGXINST",1394,0) ;"Result: 1=OK to continue, 0=Error (data requested, but not found, or error occured) "RTN","TMGXINST",1395,0) ;"Note: Nesting is allowed, and all instances of {{...}} will be substituted "RTN","TMGXINST",1396,0) "RTN","TMGXINST",1397,0) new PartA,PartB,PartC,RefB "RTN","TMGXINST",1398,0) new result set result=cOKToCont "RTN","TMGXINST",1399,0) "RTN","TMGXINST",1400,0) new InitDebug set InitDebug=TMGDEBUG "RTN","TMGXINST",1401,0) set TMGDEBUG=0 ;"Force this function to not put out TMGDEBUG info. "RTN","TMGXINST",1402,0) "RTN","TMGXINST",1403,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"CheckSubstituteData") "RTN","TMGXINST",1404,0) "RTN","TMGXINST",1405,0) CKSubL1 ;"Check if Code contains a data reference "RTN","TMGXINST",1406,0) if $$NestSplit^TMGSTUTL(.Text,cDataOpen,cDataClose,.PartA,.PartB,.PartC)=0 goto CkSubDone "RTN","TMGXINST",1407,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Reference to data found... replacing now.") "RTN","TMGXINST",1408,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Initline: '",Text,"'") "RTN","TMGXINST",1409,0) "RTN","TMGXINST",1410,0) set RefB=$$GetData(PartB) "RTN","TMGXINST",1411,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Looked up data: '",RefB,"'") "RTN","TMGXINST",1412,0) if RefB="" do goto CkSubDone "RTN","TMGXINST",1413,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error. Unable to find data reference: "_PartB) "RTN","TMGXINST",1414,0) . set result=cAbort "RTN","TMGXINST",1415,0) set Text=PartA_RefB_PartC ;"reassemble new code line "RTN","TMGXINST",1416,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"After replacement, line='",Text,"'") "RTN","TMGXINST",1417,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"---------------------") "RTN","TMGXINST",1418,0) goto CKSubL1 "RTN","TMGXINST",1419,0) "RTN","TMGXINST",1420,0) CkSubDone "RTN","TMGXINST",1421,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"CheckSubstituteData") "RTN","TMGXINST",1422,0) set TMGDEBUG=InitDebug "RTN","TMGXINST",1423,0) quit result "RTN","TMGXINST",1424,0) "RTN","TMGXINST",1425,0) "RTN","TMGXINST",1426,0) DoJump(Params) "RTN","TMGXINST",1427,0) ;"Purpose: To allow limited program flow control "RTN","TMGXINST",1428,0) ;"Syntax: e.g. <Jump condition="if State=1" label="C"></Jump> "RTN","TMGXINST",1429,0) ;"Input: Params -- an array containg parameters to run "RTN","TMGXINST",1430,0) ;" Params(cCondition): M code executed to determine whether to jump "RTN","TMGXINST",1431,0) ;" e.g. Params(cCondition)="if State=2" "RTN","TMGXINST",1432,0) ;" Params(cLabel): The name of the block to jump to. "RTN","TMGXINST",1433,0) ;" Params(cLabel)="TargetLabel" "RTN","TMGXINST",1434,0) ;"Note: The expected syntax of the label is: <Label>B</Label> "RTN","TMGXINST",1435,0) ;" In this example, the label name is "B" "RTN","TMGXINST",1436,0) ;"Returns: If should continue execution: 1=OK to continue. 0=abort. "RTN","TMGXINST",1437,0) "RTN","TMGXINST",1438,0) new result "RTN","TMGXINST",1439,0) set result=cOKToCont "RTN","TMGXINST",1440,0) new CondBool set CondBool=1 "RTN","TMGXINST",1441,0) "RTN","TMGXINST",1442,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoJump") "RTN","TMGXINST",1443,0) "RTN","TMGXINST",1444,0) new CondCode set CondCode=$get(Params(cCondition)) "RTN","TMGXINST",1445,0) set result=$$CheckSubstituteData(.CondCode) "RTN","TMGXINST",1446,0) if result=cAbort goto DJDone "RTN","TMGXINST",1447,0) new Label set Label=$get(Params(cLabel)) "RTN","TMGXINST",1448,0) set result=$$CheckSubstituteData(.Label) "RTN","TMGXINST",1449,0) if result=cAbort goto DJDone "RTN","TMGXINST",1450,0) "RTN","TMGXINST",1451,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Condition code='"_CondCode_"'") "RTN","TMGXINST",1452,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Label="_Label) "RTN","TMGXINST",1453,0) "RTN","TMGXINST",1454,0) ;"Note: Here I trap errors that might be returned from xecute, "RTN","TMGXINST",1455,0) ;" and set result=cAbort to cause script abort "RTN","TMGXINST",1456,0) if CondCode'="" do "RTN","TMGXINST",1457,0) . new $etrap set $etrap="do DoJErrTrap^TMGXINST" "RTN","TMGXINST",1458,0) . set ^TMP("TMG",$J,"trap")=cOKToCont "RTN","TMGXINST",1459,0) . xecute CondCode "RTN","TMGXINST",1460,0) . set CondBool=$TEST "RTN","TMGXINST",1461,0) . set result=^TMP("TMG",$J,"trap") "RTN","TMGXINST",1462,0) . if result=cAbort do "RTN","TMGXINST",1463,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error executing Jump conditional code: \n"_CondCode) "RTN","TMGXINST",1464,0) else do "RTN","TMGXINST",1465,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"No condition code given, so should already have set bool") "RTN","TMGXINST",1466,0) "RTN","TMGXINST",1467,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"CondBool",CondBool) "RTN","TMGXINST",1468,0) "RTN","TMGXINST",1469,0) if (CondBool)&(Label'="")&(result=cOKToCont) do "RTN","TMGXINST",1470,0) . set result=$$DoShow(.Params) ;"Show any associated text as a message "RTN","TMGXINST",1471,0) . new OldNode set OldNode=ExecNode "RTN","TMGXINST",1472,0) . set ExecNode=$$GetLabelNode(Label) "RTN","TMGXINST",1473,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Changed point of execution from ",OldNode," to ",ExecNode) "RTN","TMGXINST",1474,0) . if ExecNode=0 do "RTN","TMGXINST",1475,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"In Jump instruction, label '"_Label_"' not found.") "RTN","TMGXINST",1476,0) . . set result=cAbort ;"i.e. abort "RTN","TMGXINST",1477,0) else do "RTN","TMGXINST",1478,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Jump not done.") "RTN","TMGXINST",1479,0) "RTN","TMGXINST",1480,0) DJDone "RTN","TMGXINST",1481,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoJump") "RTN","TMGXINST",1482,0) if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Jump command failed.") "RTN","TMGXINST",1483,0) "RTN","TMGXINST",1484,0) quit result "RTN","TMGXINST",1485,0) "RTN","TMGXINST",1486,0) "RTN","TMGXINST",1487,0) ;"========================================================= "RTN","TMGXINST",1488,0) ;"DoJump Error trap routine "RTN","TMGXINST",1489,0) ;"========================================================= "RTN","TMGXINST",1490,0) DoJErrTrap "RTN","TMGXINST",1491,0) set $etrap="" "RTN","TMGXINST",1492,0) set $ecode="" "RTN","TMGXINST",1493,0) set ^TMP("TMG",$J,"trap")=cAbort "RTN","TMGXINST",1494,0) quit "RTN","TMGXINST",1495,0) ;"========================================================= "RTN","TMGXINST",1496,0) ;"DoJump End of Error trap routine "RTN","TMGXINST",1497,0) ;"========================================================= "RTN","TMGXINST",1498,0) "RTN","TMGXINST",1499,0) "RTN","TMGXINST",1500,0) "RTN","TMGXINST",1501,0) GetLabelNode(Label) "RTN","TMGXINST",1502,0) ;"Purpose: Scan through <Script> section for a <Label> that matches "RTN","TMGXINST",1503,0) ;"Input: Label: the name to search for (case insensitive) "RTN","TMGXINST",1504,0) ;"Results: the handle of the node sought, or 0 if not found "RTN","TMGXINST",1505,0) "RTN","TMGXINST",1506,0) new ChildNode "RTN","TMGXINST",1507,0) set ChildNode=0 "RTN","TMGXINST",1508,0) "RTN","TMGXINST",1509,0) GLNLoop set ChildNode=$$CHILD^MXMLDOM(XMLHandle,ScriptNode,ChildNode) "RTN","TMGXINST",1510,0) if ChildNode=0 goto GLNQuit "RTN","TMGXINST",1511,0) if $$UP^XLFSTR($$Get1NText^TMGXMLT(XMLHandle,ChildNode))=$$UP^XLFSTR(Label) goto GLNQuit "RTN","TMGXINST",1512,0) goto GLNLoop "RTN","TMGXINST",1513,0) "RTN","TMGXINST",1514,0) GLNQuit quit ChildNode "RTN","TMGXINST",1515,0) "RTN","TMGXINST",1516,0) "RTN","TMGXINST",1517,0) GetData(Ref) "RTN","TMGXINST",1518,0) ;"Purpose: To get data from the <DATA> section of the XML file "RTN","TMGXINST",1519,0) ;"Input: Ref: the refrence path. "RTN","TMGXINST",1520,0) ;" e.g. Data.Site.Office[EastSide].Field[OpenDate], "RTN","TMGXINST",1521,0) ;" when used with the following data section... "RTN","TMGXINST",1522,0) ;" <Data> "RTN","TMGXINST",1523,0) ;" <Site> "RTN","TMGXINST",1524,0) ;" <Office id="EastSide"> "RTN","TMGXINST",1525,0) ;" <Field id="Doctor">Kevin</Field> "RTN","TMGXINST",1526,0) ;" <Field id="OpenDate">12/1/04</Field> "RTN","TMGXINST",1527,0) ;" </Office> "RTN","TMGXINST",1528,0) ;" </Site> "RTN","TMGXINST",1529,0) ;" </Data> "RTN","TMGXINST",1530,0) ;" will return the value of '12/1/04' "RTN","TMGXINST",1531,0) ;" "RTN","TMGXINST",1532,0) ;" Alternative acceptible input: "RTN","TMGXINST",1533,0) ;" e.g. MVar.SomeVar "RTN","TMGXINST",1534,0) ;" This will retrieve the value of variable 'SomeVar' "RTN","TMGXINST",1535,0) ;" that is defined in the M language, i.e. a local variable "RTN","TMGXINST",1536,0) ;" that might have been set in some M code. "RTN","TMGXINST",1537,0) ;" The name for SomeVar is case-specific. "RTN","TMGXINST",1538,0) ;" "RTN","TMGXINST",1539,0) ;"Note: The first node must be 'Data' or 'MVar' "RTN","TMGXINST",1540,0) ;"Returns: the value requested, or "" if not found. "RTN","TMGXINST",1541,0) "RTN","TMGXINST",1542,0) new result set result="" "RTN","TMGXINST",1543,0) "RTN","TMGXINST",1544,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetData") "RTN","TMGXINST",1545,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Ref to search for="_Ref) "RTN","TMGXINST",1546,0) "RTN","TMGXINST",1547,0) if $data(Ref)=0 goto QGetDat "RTN","TMGXINST",1548,0) "RTN","TMGXINST",1549,0) new Segment "RTN","TMGXINST",1550,0) new SegNode "RTN","TMGXINST",1551,0) new ID "RTN","TMGXINST",1552,0) "RTN","TMGXINST",1553,0) set Segment=$$ParseSeg(.Ref,.ID) "RTN","TMGXINST",1554,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Segment="_Segment) "RTN","TMGXINST",1555,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"ID=["_ID_"]") "RTN","TMGXINST",1556,0) if $$UP^XLFSTR(Segment)=cData goto GetData1 "RTN","TMGXINST",1557,0) if $$UP^XLFSTR(Segment)='cMVar goto QGetDat "RTN","TMGXINST",1558,0) "RTN","TMGXINST",1559,0) ;"Here we are dealing with {{MVar.SomeVar}} pattern "RTN","TMGXINST",1560,0) ;"Get name of variable to access. "RTN","TMGXINST",1561,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Found request to access M variable: ",ID) "RTN","TMGXINST",1562,0) set Segment=$$ParseSeg(.Ref,.ID) ;"ID to be ignored. "RTN","TMGXINST",1563,0) set result=$get(@Segment) "RTN","TMGXINST",1564,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Requested variable: ",Segment,"= '",result,"'") "RTN","TMGXINST",1565,0) goto QGetDat "RTN","TMGXINST",1566,0) "RTN","TMGXINST",1567,0) GetData1 "RTN","TMGXINST",1568,0) if $data(DataNode)=0 goto QGetDat ;"Occurs if error box occurs before full XML parse "RTN","TMGXINST",1569,0) set SegNode=DataNode "RTN","TMGXINST",1570,0) GetData2 "RTN","TMGXINST",1571,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Getting ready to parse segment....") "RTN","TMGXINST",1572,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Ref="_Ref) "RTN","TMGXINST",1573,0) set Segment=$$ParseSeg(.Ref,.ID) "RTN","TMGXINST",1574,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Segment="_Segment) "RTN","TMGXINST",1575,0) set SegNode=$$GetDescIDNode(SegNode,Segment,ID) "RTN","TMGXINST",1576,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"SegNode=#"_SegNode) "RTN","TMGXINST",1577,0) if SegNode=0 goto QGetDat "RTN","TMGXINST",1578,0) "RTN","TMGXINST",1579,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"?ready to loop? Ref='"_Ref_"'") "RTN","TMGXINST",1580,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Ref='' is "_Ref="") "RTN","TMGXINST",1581,0) if Ref="" goto QGetDat1 "RTN","TMGXINST",1582,0) "RTN","TMGXINST",1583,0) goto GetData2 "RTN","TMGXINST",1584,0) "RTN","TMGXINST",1585,0) QGetDat1 "RTN","TMGXINST",1586,0) ;"If we get here, must have found correct node "RTN","TMGXINST",1587,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Success. data node found. SegNode="_SegNode) "RTN","TMGXINST",1588,0) set result=$$Get1NText^TMGXMLT(XMLHandle,SegNode) "RTN","TMGXINST",1589,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Result="_result) "RTN","TMGXINST",1590,0) "RTN","TMGXINST",1591,0) QGetDat "RTN","TMGXINST",1592,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetData") "RTN","TMGXINST",1593,0) quit result "RTN","TMGXINST",1594,0) "RTN","TMGXINST",1595,0) "RTN","TMGXINST",1596,0) ParseSeg(Ref,ID) "RTN","TMGXINST",1597,0) ;"Purpose: to parse a line in the following format "RTN","TMGXINST",1598,0) ;" Data.Site.Office[EastSide].Field[OpenDate] "RTN","TMGXINST",1599,0) ;" Function will return the next segment (divided "RTN","TMGXINST",1600,0) ;" by '.', left-to-right "RTN","TMGXINST",1601,0) ;"Input: Ref: Should be passed by reference . text of line, as described above "RTN","TMGXINST",1602,0) ;" ID: Should be passed by reference. An OUT parameter (not used for input) "RTN","TMGXINST",1603,0) ;"Output: Ref is changed (shortened). When all done, Ref will equal " " "RTN","TMGXINST",1604,0) ;" If an ID is found (i.e. 'EastSide' in above example), then ID will "RTN","TMGXINST",1605,0) ;" will be set, otherwise " " "RTN","TMGXINST",1606,0) ;"Result: The leftmost section, or " " if none found "RTN","TMGXINST",1607,0) "RTN","TMGXINST",1608,0) new result "RTN","TMGXINST",1609,0) set result=" " "RTN","TMGXINST",1610,0) set ID=" " "RTN","TMGXINST",1611,0) new PartA,PartB,PartC "RTN","TMGXINST",1612,0) "RTN","TMGXINST",1613,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"ParseSeg") "RTN","TMGXINST",1614,0) "RTN","TMGXINST",1615,0) ;"If no more pieces, just return input "RTN","TMGXINST",1616,0) if 'Ref["." do goto Parse2 "RTN","TMGXINST",1617,0) . set result=Ref "RTN","TMGXINST",1618,0) . set Ref=" " "RTN","TMGXINST",1619,0) "RTN","TMGXINST",1620,0) set result=$piece(Ref,".",1) "RTN","TMGXINST",1621,0) set result=$get(result," ") "RTN","TMGXINST",1622,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Result="_result) "RTN","TMGXINST",1623,0) set PartB=$piece(Ref,".",2,100) "RTN","TMGXINST",1624,0) set PartB=$get(PartB," ") "RTN","TMGXINST",1625,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"PartB="_PartB) "RTN","TMGXINST",1626,0) set Ref=PartB "RTN","TMGXINST",1627,0) "RTN","TMGXINST",1628,0) Parse2 ;"If Office[EastSide] pattern found, separate parts "RTN","TMGXINST",1629,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Here is result: "_result_" Will now look for '['") "RTN","TMGXINST",1630,0) if (result["[")&(result["]") do "RTN","TMGXINST",1631,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"... found.") "RTN","TMGXINST",1632,0) . set PartA=$piece(result,"[",1) "RTN","TMGXINST",1633,0) . set PartB=$piece(result,"[",2) "RTN","TMGXINST",1634,0) . set PartC=$piece(PartB,"]",1) "RTN","TMGXINST",1635,0) . set result=PartA "RTN","TMGXINST",1636,0) . set ID=PartC "RTN","TMGXINST",1637,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Result now ="_result_" ID="_ID) "RTN","TMGXINST",1638,0) "RTN","TMGXINST",1639,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"ParseSeg") "RTN","TMGXINST",1640,0) quit result "RTN","TMGXINST",1641,0) "RTN","TMGXINST",1642,0) "RTN","TMGXINST",1643,0) GetDescIDNode(ParentNode,Name,ID) "RTN","TMGXINST",1644,0) ;"Purpose: get a descendant node that matches Name and ID "RTN","TMGXINST",1645,0) ;"Input: ParentNode node handle of parent "RTN","TMGXINST",1646,0) ;" Name is name of node "RTN","TMGXINST",1647,0) ;" ID, the ID to match against. ID is an attrib of "id" "RTN","TMGXINST",1648,0) ;"e.g. Look for <Field id="Doctor">Kevin</Field> type pattern. "RTN","TMGXINST",1649,0) ;" Here, Name='Field', ID='Doctor' "RTN","TMGXINST",1650,0) ;"Note: only immediate children (not grandchildren) are searched. "RTN","TMGXINST",1651,0) ;"Returns: the handle of the sought node, or 0 if not found. "RTN","TMGXINST",1652,0) "RTN","TMGXINST",1653,0) new ChildNode "RTN","TMGXINST",1654,0) set ChildNode=0 "RTN","TMGXINST",1655,0) new NodeName,AtrVal "RTN","TMGXINST",1656,0) "RTN","TMGXINST",1657,0) new InitDebug set InitDebug=TMGDEBUG "RTN","TMGXINST",1658,0) set TMGDEBUG=0 ;"Force this function to not put out TMGDEBUG info. "RTN","TMGXINST",1659,0) "RTN","TMGXINST",1660,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetDescIDNode") "RTN","TMGXINST",1661,0) "RTN","TMGXINST",1662,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Looking for children of node="_ParentNode) "RTN","TMGXINST",1663,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"with name="_Name_" ID="_ID) "RTN","TMGXINST",1664,0) ;"if ID=" " write "ID=space (null)",! "RTN","TMGXINST",1665,0) ;"else write "ID is something other than space. ",! "RTN","TMGXINST",1666,0) "RTN","TMGXINST",1667,0) GDILoop set ChildNode=$$CHILD^MXMLDOM(XMLHandle,ParentNode,ChildNode) "RTN","TMGXINST",1668,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Looking at child node #"_ChildNode) "RTN","TMGXINST",1669,0) ;"if TMGDEBUG>0 do ShowXMLNode(ChildNode) "RTN","TMGXINST",1670,0) if ChildNode=0 goto GDIQuit "RTN","TMGXINST",1671,0) set NodeName=$$GetNName^TMGXMLT(XMLHandle,ChildNode) ;"Returns result in UPPERCASE "RTN","TMGXINST",1672,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Name="_NodeName) "RTN","TMGXINST",1673,0) if NodeName'=$$UP^XLFSTR(Name) goto GDILoop "RTN","TMGXINST",1674,0) if ID=" " goto GDIQuit ;"if no ID specified, then match based on Name only. "RTN","TMGXINST",1675,0) set AtrVal=$$GetAtrVal^TMGXMLT(XMLHandle,ChildNode,cId) "RTN","TMGXINST",1676,0) set AtrVal=$$UP^XLFSTR(AtrVal) "RTN","TMGXINST",1677,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Value: ",AtrVal) "RTN","TMGXINST",1678,0) if AtrVal'=$$UP^XLFSTR(ID) goto GDILoop "RTN","TMGXINST",1679,0) ;"If we get here, we have a match "RTN","TMGXINST",1680,0) "RTN","TMGXINST",1681,0) GDIQuit "RTN","TMGXINST",1682,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Success! Node: ",ChildNode) "RTN","TMGXINST",1683,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetDescIDNode") "RTN","TMGXINST",1684,0) "RTN","TMGXINST",1685,0) set TMGDEBUG=InitDebug "RTN","TMGXINST",1686,0) quit ChildNode "RTN","TMGXINST",1687,0) "RTN","TMGXINST",1688,0) "RTN","TMGXINST",1689,0) GetCMDLine(ExecNode,Command,Params) "RTN","TMGXINST",1690,0) ;"Purpose: Load elements needed to execute line "RTN","TMGXINST",1691,0) ;"Input: ExecNode, the node to be executed... "RTN","TMGXINST",1692,0) ;" Other parameters are OUT params... should be passed by reference "RTN","TMGXINST",1693,0) ;"Output: Command -- the command of the line "RTN","TMGXINST",1694,0) ;" Params -- PASS BY REFERENCE-- to accept back the parameters "RTN","TMGXINST",1695,0) ;"Results: 1=if valid info; 0=should NOT be executed (i.e. abort) "RTN","TMGXINST",1696,0) "RTN","TMGXINST",1697,0) new result set result=cOKToCont "RTN","TMGXINST",1698,0) "RTN","TMGXINST",1699,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetCMDLine") "RTN","TMGXINST",1700,0) "RTN","TMGXINST",1701,0) set Command=$$GetNName^TMGXMLT(XMLHandle,ExecNode) "RTN","TMGXINST",1702,0) set Command=$$UP^XLFSTR(Command) ;"convert to uppercase "RTN","TMGXINST",1703,0) "RTN","TMGXINST",1704,0) if $data(ProcTable(Command)) goto GCOK "RTN","TMGXINST",1705,0) else do goto GCDone "RTN","TMGXINST",1706,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Command '"_Command_"' is invalid.") "RTN","TMGXINST",1707,0) . set result=cAbort "RTN","TMGXINST",1708,0) "RTN","TMGXINST",1709,0) GCOK "RTN","TMGXINST",1710,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"CMD Command=",Command) "RTN","TMGXINST",1711,0) "RTN","TMGXINST",1712,0) new TextArray,ValidText "RTN","TMGXINST",1713,0) set ValidText=$$GetNText^TMGXMLT(XMLHandle,ExecNode,.TextArray) "RTN","TMGXINST",1714,0) ;"if result=cAbort do goto GCDone "RTN","TMGXINST",1715,0) ;". do ShowError^TMGDEBUG(.PriorErrorFound,"Error retrieving text into array.") "RTN","TMGXINST",1716,0) if ValidText merge Params(cText)=TextArray "RTN","TMGXINST",1717,0) "RTN","TMGXINST",1718,0) set result=$$GetParams^TMGXMLT(XMLHandle,ExecNode,.Params) "RTN","TMGXINST",1719,0) if result=cAbort do "RTN","TMGXINST",1720,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error getting parameters") "RTN","TMGXINST",1721,0) "RTN","TMGXINST",1722,0) GCDone "RTN","TMGXINST",1723,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetCMDLine") "RTN","TMGXINST",1724,0) quit result "RTN","TMGXINST",1725,0) "RTN","TMGXINST",1726,0) "RTN","TMGXINST",1727,0) GetNextCMD(ExecNode) "RTN","TMGXINST",1728,0) ;"Purpose: Advance execution point "RTN","TMGXINST",1729,0) ;"Input: ExecNode: the current execution point, should be passed by reference "RTN","TMGXINST",1730,0) ;"Output: ExecNode is changed "RTN","TMGXINST",1731,0) ;" returns 0 if end of program, otherwise positive number (i.e. ExecNode) "RTN","TMGXINST",1732,0) "RTN","TMGXINST",1733,0) set ExecNode=$$CHILD^MXMLDOM(XMLHandle,ScriptNode,ExecNode) "RTN","TMGXINST",1734,0) "RTN","TMGXINST",1735,0) quit ExecNode "RTN","TMGXINST",1736,0) "RTN","TMGXINST",1737,0) "RTN","TMGXINST",1738,0) RunScript(ExecNode) "RTN","TMGXINST",1739,0) ;"Purpose: To run the entire script "RTN","TMGXINST",1740,0) ;"Input: ExecNode, should be passed by reference "RTN","TMGXINST",1741,0) ;"Assumptions: That ExecNode points to first line of script. "RTN","TMGXINST",1742,0) ;"Result: 1: quit normally. 0=error exit. "RTN","TMGXINST",1743,0) "RTN","TMGXINST",1744,0) new Command "RTN","TMGXINST",1745,0) new Params "RTN","TMGXINST",1746,0) new OKToCont set OKToCont=1 ;"1=OK to continue 0=should abort "RTN","TMGXINST",1747,0) "RTN","TMGXINST",1748,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"RunScript") "RTN","TMGXINST",1749,0) RunLoop "RTN","TMGXINST",1750,0) if ExecNode=0 goto RSDone "RTN","TMGXINST",1751,0) "RTN","TMGXINST",1752,0) ;"Get current command line information "RTN","TMGXINST",1753,0) ;"if TMGDEBUG>0 do ShowXMLNode(ExecNode) "RTN","TMGXINST",1754,0) kill Params "RTN","TMGXINST",1755,0) "RTN","TMGXINST",1756,0) set OKToCont=$$GetCMDLine(ExecNode,.Command,.Params) "RTN","TMGXINST",1757,0) if OKToCont=0 do goto RSDone ;"If error, then quit execution. "RTN","TMGXINST",1758,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error parsing command line.") "RTN","TMGXINST",1759,0) . if TMGDEBUG>0 do ShowXMLNode^TMGXMLT(ExecNode) "RTN","TMGXINST",1760,0) "RTN","TMGXINST",1761,0) set OKToCont=$$CMDProcess(Command,.Params) "RTN","TMGXINST",1762,0) if OKToCont=0 do goto RSDone ;"If error, then quit execution. "RTN","TMGXINST",1763,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error executing command.") "RTN","TMGXINST",1764,0) . if TMGDEBUG>0 do ShowXMLNode^TMGXMLT(ExecNode) "RTN","TMGXINST",1765,0) "RTN","TMGXINST",1766,0) ;"Look for ESC that will cause loop abort "RTN","TMGXINST",1767,0) ;"write "#" "RTN","TMGXINST",1768,0) read *CheckKey:0 "RTN","TMGXINST",1769,0) if CheckKey=27 do goto RSDone "RTN","TMGXINST",1770,0) . write !,!,"Escape key pressed. Aborting script.",!,! "RTN","TMGXINST",1771,0) "RTN","TMGXINST",1772,0) ;"Advance to next command line "RTN","TMGXINST",1773,0) set OKToCont=$$GetNextCMD(.ExecNode) "RTN","TMGXINST",1774,0) if OKToCont'=0 goto RunLoop "RTN","TMGXINST",1775,0) set OKToCont=1 ;"At this point, exit is normal. "RTN","TMGXINST",1776,0) "RTN","TMGXINST",1777,0) RSDone "RTN","TMGXINST",1778,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"RunScript") "RTN","TMGXINST",1779,0) quit OKToCont "RTN","TMGXINST",1780,0) "RTN","TMGXINST",1781,0) ;"------------------------------------------------------------------------ "RTN","TMGXINST",1782,0) ;"======================================================================== "RTN","TMGXINST",1783,0) ;"------------------------------------------------------------------------ "RTN","TMGXINST",1784,0) GetDispMode() "RTN","TMGXINST",1785,0) ;"Purpose: To determine with form of input user wants "RTN","TMGXINST",1786,0) ;"Results: 1=GUI,2=CHUI,3=RollNScroll,0=abort "RTN","TMGXINST",1787,0) new Input "RTN","TMGXINST",1788,0) new result set result=cAbort "RTN","TMGXINST",1789,0) new Default set Default=3 ;"If changed, change(1) below "RTN","TMGXINST",1790,0) "RTN","TMGXINST",1791,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetDispMode") "RTN","TMGXINST",1792,0) "RTN","TMGXINST",1793,0) write "Select interface option:",! "RTN","TMGXINST",1794,0) write " 0. Quit. (Goodbye!)",! "RTN","TMGXINST",1795,0) write " 1. Linux X graphics/ 'GUI' (Recommended)",! "RTN","TMGXINST",1796,0) write " 2. Text graphics / 'CHUI' (Incomplete)",! "RTN","TMGXINST",1797,0) write " 3. Line-by-Line / 'Roll-and-scroll'",! "RTN","TMGXINST",1798,0) "RTN","TMGXINST",1799,0) write "Enter option number ("_Default_"): " "RTN","TMGXINST",1800,0) read Input,! "RTN","TMGXINST",1801,0) if Input="" do "RTN","TMGXINST",1802,0) . ;"write "Defaulting to: ",Default,! "RTN","TMGXINST",1803,0) . set Input=Default "RTN","TMGXINST",1804,0) else if +Input>4 do "RTN","TMGXINST",1805,0) . set Input=Default "RTN","TMGXINST",1806,0) "RTN","TMGXINST",1807,0) set result=+Input "RTN","TMGXINST",1808,0) if (Input=1)!(Input=2) do "RTN","TMGXINST",1809,0) . do SetupConsts^TMGXDLG() "RTN","TMGXINST",1810,0) . do SetGUI^TMGXDLG(Input=1) "RTN","TMGXINST",1811,0) ;"if Input=2 do goto GIMDone "RTN","TMGXINST",1812,0) ;". do SetupConsts^TMGXDLG() "RTN","TMGXINST",1813,0) ;". do SetGUI^TMGXDLG(0) "RTN","TMGXINST",1814,0) "RTN","TMGXINST",1815,0) GIMDone "RTN","TMGXINST",1816,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Display mode set at: ",result) "RTN","TMGXINST",1817,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"GetDispMode") "RTN","TMGXINST",1818,0) quit result "RTN","TMGXINST",1819,0) "RTN","TMGXINST",1820,0) "RTN","TMGXINST",1821,0) "RTN","TMGXINST",1822,0) DoMsgBox(Params) "RTN","TMGXINST",1823,0) ;"Purpose: To provide a method for script users to "RTN","TMGXINST",1824,0) ;" show a message box "RTN","TMGXINST",1825,0) ;"Input: Params -- an array loaded with needed values: "RTN","TMGXINST",1826,0) ;" Params(cHeader): Header text "RTN","TMGXINST",1827,0) ;" Params(cText,*): Array containing text "RTN","TMGXINST",1828,0) ;" i.e. Params(cText,1)="text of line 1" "RTN","TMGXINST",1829,0) ;" i.e. Params(cText,2)="text of line 2" "RTN","TMGXINST",1830,0) ;" i.e. Params(cText,3)="text of line 3" "RTN","TMGXINST",1831,0) ;" i.e. Params(cText,4)="text of line 4" "RTN","TMGXINST",1832,0) ;"Result: 1=ok to continue, 0=abort "RTN","TMGXINST",1833,0) "RTN","TMGXINST",1834,0) if TMGDEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoMsgBox") "RTN","TMGXINST",1835,0) "RTN","TMGXINST",1836,0) new Width "RTN","TMGXINST",1837,0) new Text,S,PartB,PartB1 "RTN","TMGXINST",1838,0) new index,j "RTN","TMGXINST",1839,0) new Modal "RTN","TMGXINST",1840,0) new result set result=cOKToCont "RTN","TMGXINST",1841,0) "RTN","TMGXINST",1842,0) if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Here is a dump of the params") "RTN","TMGXINST",1843,0) if TMGDEBUG do ArrayDump^TMGDEBUG("Params") ;"zwr Params(*) "RTN","TMGXINST",1844,0) "RTN","TMGXINST",1845,0) set Text(0)=$get(Params(cHeader),"Message:") "RTN","TMGXINST",1846,0) set Width=$get(Params(cWidth,cUpperCase),0) "RTN","TMGXINST",1847,0) set Modal=$get(Params(cModal),cModalMode) "RTN","TMGXINST",1848,0) set index=$order(Params(cText,"")) "RTN","TMGXINST",1849,0) set j=1 "RTN","TMGXINST",1850,0) DMSGLoop "RTN","TMGXINST",1851,0) if index="" goto DMSGPast "RTN","TMGXINST",1852,0) set S=$get(Params(cText,index)) "RTN","TMGXINST",1853,0) set result=$$CheckSubstituteData(.S) "RTN","TMGXINST",1854,0) if result=cAbort goto DMSGQuit "RTN","TMGXINST",1855,0) DMSG2Loop ;"Load string up into Text array, to pass to PopupArray "RTN","TMGXINST",1856,0) if S[cNewLn do "RTN","TMGXINST",1857,0) . do CleaveStr^TMGSTUTL(.S,cNewLn,.PartB1) "RTN","TMGXINST",1858,0) do SplitStr^TMGSTUTL(.S,(Width-4),.PartB) "RTN","TMGXINST",1859,0) set PartB=PartB_PartB1 set PartB1="" "RTN","TMGXINST",1860,0) set Text(j)=S "RTN","TMGXINST",1861,0) set j=j+1 "RTN","TMGXINST",1862,0) if $length(PartB)>0 do goto DMSG2Loop "RTN","TMGXINST",1863,0) . set S=PartB "RTN","TMGXINST",1864,0) . set PartB="" "RTN","TMGXINST",1865,0) "RTN","TMGXINST",1866,0) set index=$order(Params(cText,index)) "RTN","TMGXINST",1867,0) goto DMSGLoop "RTN","TMGXINST",1868,0) "RTN","TMGXINST",1869,0) DMSGPast "RTN","TMGXINST",1870,0) if TMGDEBUG do "RTN","TMGXINST",1871,0) . if TMGDEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Here is Text array to send to PopupArray:") "RTN","TMGXINST",1872,0) . do ArrayDump^TMGDEBUG("Text") ;"zwr Text(*) "RTN","TMGXINST",1873,0) "RTN","TMGXINST",1874,0) do PopupArray^TMGUSRIF(2,Width,.Text,Modal) "RTN","TMGXINST",1875,0) DMSGQuit "RTN","TMGXINST",1876,0) if TMGDEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"DoMsgBox") "RTN","TMGXINST",1877,0) quit result "RTN","TMGXINST",1878,0) "RTN","TMGXINST",1879,0) "RTN","TMGXML1") 0^102^B7775128 "RTN","TMGXML1",1,0) TMGXML1 ;TMG/kst/XML Exporter -- Testing code ;03/25/06 "RTN","TMGXML1",2,0) ;;1.0;TMG-LIB;**1**;07/09/05 "RTN","TMGXML1",3,0) "RTN","TMGXML1",4,0) ;"This is a test file for working with XML Documents "RTN","TMGXML1",5,0) Start ; "RTN","TMGXML1",6,0) "RTN","TMGXML1",7,0) ;"Kevin Toppenberg, MD 7-9-04 "RTN","TMGXML1",8,0) ;"This is a test file for working with XML Documents "RTN","TMGXML1",9,0) "RTN","TMGXML1",10,0) new Y,PATH,FILE,GBLREF "RTN","TMGXML1",11,0) kill ^TMP("KT",$J) "RTN","TMGXML1",12,0) "RTN","TMGXML1",13,0) set PATH="/home/kdtop" "RTN","TMGXML1",14,0) "RTN","TMGXML1",15,0) write "-----------------------",! "RTN","TMGXML1",16,0) read "Enter Filename:",FILE "RTN","TMGXML1",17,0) write ! "RTN","TMGXML1",18,0) if FILE="^" quit "RTN","TMGXML1",19,0) if FILE="" set FILE="XMLSample#2.xml" write "Using default: ",FILE,! "RTN","TMGXML1",20,0) "RTN","TMGXML1",21,0) set GBLREF="^TMP(""KT"","_$J_",0)" "RTN","TMGXML1",22,0) set Y=$$FTG^%ZISH(PATH,FILE,GBLREF,3) "RTN","TMGXML1",23,0) if 'Y write "error opening file.",! quit "RTN","TMGXML1",24,0) "RTN","TMGXML1",25,0) ;zwr ^TMP("KT",$JOB,*) "RTN","TMGXML1",26,0) "RTN","TMGXML1",27,0) ;"do EN^MXMLTEST($NAME(^TMP("KT",$J)),"V") "RTN","TMGXML1",28,0) "RTN","TMGXML1",29,0) write "---------------------------",! "RTN","TMGXML1",30,0) write "Part #2",!,! "RTN","TMGXML1",31,0) "RTN","TMGXML1",32,0) new FileName "RTN","TMGXML1",33,0) set FileName=PATH_"/"_FILE "RTN","TMGXML1",34,0) ;write "FileName=",FileName,! "RTN","TMGXML1",35,0) "RTN","TMGXML1",36,0) new FnArray "RTN","TMGXML1",37,0) set FnArray="Array of Callback Functions" "RTN","TMGXML1",38,0) set FnArray("STARTDOCUMENT")="StartDoc^TMGXML1" "RTN","TMGXML1",39,0) set FnArray("ENDDOCUMENT")="EndDoc^TMGXML1" "RTN","TMGXML1",40,0) set FnArray("DOCTYPE")="DocType^TMGXML1" "RTN","TMGXML1",41,0) set FnArray("STARTELEMENT")="StartElement^TMGXML1" "RTN","TMGXML1",42,0) set FnArray("ENDELEMENT")="EndElement^TMGXML1" "RTN","TMGXML1",43,0) set FnArray("CHARACTERS")="Chars^TMGXML1" "RTN","TMGXML1",44,0) "RTN","TMGXML1",45,0) ;write "Here is FnArray",! "RTN","TMGXML1",46,0) ;zwr FnArray(*) "RTN","TMGXML1",47,0) "RTN","TMGXML1",48,0) write "Calling EN^MXMLPRSE",! "RTN","TMGXML1",49,0) do EN^MXMLPRSE($NAME(^TMP("KT",$J)),.FnArray) "RTN","TMGXML1",50,0) ;do EN^MXMLPRSE(FileName,.FnArray) "RTN","TMGXML1",51,0) write "Done calling EN^MXMLPRSE",! "RTN","TMGXML1",52,0) "RTN","TMGXML1",53,0) write "---------------------------",! "RTN","TMGXML1",54,0) write "Part #3",!,! "RTN","TMGXML1",55,0) "RTN","TMGXML1",56,0) new ParseHandle "RTN","TMGXML1",57,0) write "Calling EN^MXMLDOM",! "RTN","TMGXML1",58,0) set ParseHandle=$$EN^MXMLDOM($NAME(^TMP("KT",$J)),"V") "RTN","TMGXML1",59,0) write "Done calling EN^MXMLDOM",! "RTN","TMGXML1",60,0) write "Handle=",ParseHandle,! "RTN","TMGXML1",61,0) "RTN","TMGXML1",62,0) do ShowNode(1,0) "RTN","TMGXML1",63,0) do ListChildren(1,1) "RTN","TMGXML1",64,0) "RTN","TMGXML1",65,0) "RTN","TMGXML1",66,0) do DELETE^MXMLDOM(ParseHandle) "RTN","TMGXML1",67,0) "RTN","TMGXML1",68,0) kill ^TMP("KT",$J) "RTN","TMGXML1",69,0) write "********************",! "RTN","TMGXML1",70,0) write "Quiting normally",! "RTN","TMGXML1",71,0) "RTN","TMGXML1",72,0) QuitLabel quit "RTN","TMGXML1",73,0) "RTN","TMGXML1",74,0) "RTN","TMGXML1",75,0) ;"------------------------------------------------------------- "RTN","TMGXML1",76,0) "RTN","TMGXML1",77,0) StartDoc "RTN","TMGXML1",78,0) write "##Starting Document Processing##",! "RTN","TMGXML1",79,0) quit "RTN","TMGXML1",80,0) "RTN","TMGXML1",81,0) EndDoc "RTN","TMGXML1",82,0) write "##End of Document Processing##",! "RTN","TMGXML1",83,0) quit "RTN","TMGXML1",84,0) "RTN","TMGXML1",85,0) "RTN","TMGXML1",86,0) DocType(ROOT,PUBID,SYSID) "RTN","TMGXML1",87,0) write "Doctype encountered.",! "RTN","TMGXML1",88,0) write "ROOT=",ROOT,! "RTN","TMGXML1",89,0) write "PUBID=",PUBID,! "RTN","TMGXML1",90,0) write "SYSID=",SYSID,! "RTN","TMGXML1",91,0) quit "RTN","TMGXML1",92,0) "RTN","TMGXML1",93,0) "RTN","TMGXML1",94,0) StartElement(NAME,ATTRLIST) "RTN","TMGXML1",95,0) write "Attrib:" "RTN","TMGXML1",96,0) write "Name=",NAME,! "RTN","TMGXML1",97,0) if $data(ATTRLIST) do "RTN","TMGXML1",98,0) . write "AttrList:" "RTN","TMGXML1",99,0) . zwr ATTRLIST "RTN","TMGXML1",100,0) quit "RTN","TMGXML1",101,0) "RTN","TMGXML1",102,0) EndElement(NAME) "RTN","TMGXML1",103,0) write "End Attrib:" "RTN","TMGXML1",104,0) write NAME,! "RTN","TMGXML1",105,0) quit "RTN","TMGXML1",106,0) "RTN","TMGXML1",107,0) Chars(TEXT) "RTN","TMGXML1",108,0) write "TEXT:",TEXT,! "RTN","TMGXML1",109,0) quit "RTN","TMGXML1",110,0) "RTN","TMGXML1",111,0) "RTN","TMGXML1",112,0) ;"------------------------------------------------------------- "RTN","TMGXML1",113,0) "RTN","TMGXML1",114,0) ListChildren(Node,IndentN) "RTN","TMGXML1",115,0) new ChildNode "RTN","TMGXML1",116,0) set ChildNode=$$CHILD^MXMLDOM(ParseHandle,Node,0) "RTN","TMGXML1",117,0) if ChildNode=0 quit "RTN","TMGXML1",118,0) "RTN","TMGXML1",119,0) new loop "RTN","TMGXML1",120,0) for loop=1:1 do if ChildNode=0 quit "RTN","TMGXML1",121,0) . do ShowNode(ChildNode,IndentN) "RTN","TMGXML1",122,0) . do ListChildren(ChildNode,IndentN+1) "RTN","TMGXML1",123,0) . set ChildNode=$$CHILD^MXMLDOM(ParseHandle,Node,ChildNode) "RTN","TMGXML1",124,0) "RTN","TMGXML1",125,0) quit "RTN","TMGXML1",126,0) "RTN","TMGXML1",127,0) ShowNode(Node,IndentN) "RTN","TMGXML1",128,0) new NodeText "RTN","TMGXML1",129,0) new AttribText "RTN","TMGXML1",130,0) "RTN","TMGXML1",131,0) do Indent(IndentN) "RTN","TMGXML1",132,0) write $$NAME^MXMLDOM(ParseHandle,Node),! "RTN","TMGXML1",133,0) if $$CMNT^MXMLDOM(ParseHandle,Node,$NAME(NodeText)) do "RTN","TMGXML1",134,0) . do Indent(IndentN) "RTN","TMGXML1",135,0) . write " Comment: ",NodeText(1),! "RTN","TMGXML1",136,0) if $$TEXT^MXMLDOM(ParseHandle,Node,$NAME(NodeText)) do "RTN","TMGXML1",137,0) . do Indent(IndentN) "RTN","TMGXML1",138,0) . write " '",NodeText(1),"'",! "RTN","TMGXML1",139,0) set AttribText=$$ATTRIB^MXMLDOM(ParseHandle,Node) "RTN","TMGXML1",140,0) if $data(AttribText),AttribText'="" do "RTN","TMGXML1",141,0) . do Indent(IndentN) "RTN","TMGXML1",142,0) . write " Attrib: ",AttribText,"=" "RTN","TMGXML1",143,0) . write $$VALUE^MXMLDOM(ParseHandle,Node,AttribText),! "RTN","TMGXML1",144,0) "RTN","TMGXML1",145,0) quit "RTN","TMGXML1",146,0) "RTN","TMGXML1",147,0) "RTN","TMGXML1",148,0) Indent(IndentN) "RTN","TMGXML1",149,0) for i=1:1:IndentN write " " "RTN","TMGXML1",150,0) "RTN","TMGXMLE2") 0^103^B27375 "RTN","TMGXMLE2",1,0) TMGXMLE2 ;TMG/kst/XML Exporter -- Core functionality ;03/25/06 "RTN","TMGXMLE2",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGXMLE2",3,0) "RTN","TMGXMLE2",4,0) ;"TMG XML EXPORT FUNCTIONS (CORE FUNCTIONALITY) "RTN","TMGXMLE2",5,0) ;"Kevin Toppenberg MD "RTN","TMGXMLE2",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGXMLE2",7,0) ;"7-12-2005 "RTN","TMGXMLE2",8,0) ;"======================================================================= "RTN","TMGXMLE2",9,0) ;" API -- Public Functions. "RTN","TMGXMLE2",10,0) ;"======================================================================= "RTN","TMGXMLE2",11,0) ;"WriteXMLData(pArray,Flags,IndentS) "RTN","TMGXMLE2",12,0) ;"Write1File(File,Recs,Flags,IndentS,SavFieldInfo) "RTN","TMGXMLE2",13,0) ;"Write1Rec(File,IEN,Fields,Flags,SRef,IENS,IndentS,RWriter,FWriter,LWriter,WPLWriter,SavFieldInfo) "RTN","TMGXMLE2",14,0) ;"Write1Fld(FileNum,IEN,Field,Fields,Flags,SRef,IENS,IndentS,RWriter,FWriter,LWriter,WPLWriter,SavFieldInfo) "RTN","TMGXMLE2",15,0) "RTN","TMGXMLE2",16,0) ;"======================================================================= "RTN","TMGXMLE2",17,0) ;"PRIVATE API FUNCTIONS "RTN","TMGXMLE2",18,0) ;"======================================================================= "RTN","TMGXMLE2",19,0) "RTN","TMGXMLE2",20,0) "RTN","TMGXMLE2",21,0) ;"======================================================================= "RTN","TMGXMLE2",22,0) ;"DEPENDENCIES "RTN","TMGXMLE2",23,0) ;" TMGDBAPI,TMGDEBUG,TMGMISC,TMGUSRIF "RTN","TMGXMLE2",24,0) ;"======================================================================= "RTN","TMGXMLE2",25,0) ;"======================================================================= "RTN","TMGXMLE2",26,0) "RTN","TMGXMLE2",27,0) ;"The basic format is to be as follows: "RTN","TMGXMLE2",28,0) "RTN","TMGXMLE2",29,0) ;"Array(File,Record,Field,subRec,SubField...)="" <--- means export this entry to XML "RTN","TMGXMLE2",30,0) ;"Array(File,"TEMPLATE",Field) "RTN","TMGXMLE2",31,0) ;"Array(File,"TEMPLATE","ORDER",OrderNum)=Field "RTN","TMGXMLE2",32,0) ;"Array(File,"TEMPLATE","TAG NAME",FieldNumber)="Custom field name to put in XML file" "RTN","TMGXMLE2",33,0) ;"Array("FLAGS","b")="" b -- show tags for ALL fields, even if field has no data "RTN","TMGXMLE2",34,0) ;"Array("FLAGS","i")="" i -- indent tags for pretty, but technically useless, file formating. "RTN","TMGXMLE2",35,0) ;"Array("FLAGS","I")="" I -- output INTERNAL values "RTN","TMGXMLE2",36,0) ;"Array("FLAGS","D")="" D -- output the data dictionary "RTN","TMGXMLE2",37,0) ;"Array("!DOCTYPE")=MyLabel "RTN","TMGXMLE2",38,0) ;"Array("EXPORT_SYSTEM_NAME")=LabelForExportingSystem -- OPTIONAL "RTN","TMGXMLE2",39,0) ;" "RTN","TMGXMLE2",40,0) ;"----------------------------------------------------------------------------------------------- "RTN","TMGXMLE2",41,0) ;"Note: File numbers can be replaces with full FILE NAMES, e.g. "RTN","TMGXMLE2",42,0) ;" Array("NEW PERSON",1234,.01)="" "RTN","TMGXMLE2",43,0) ;" "RTN","TMGXMLE2",44,0) ;"Example: For ALL records, output ALL fields, and ALL subfields "RTN","TMGXMLE2",45,0) ;" Array(8925,"*")="" <--- this is default if Recs is not specified/passed "RTN","TMGXMLE2",46,0) ;" "RTN","TMGXMLE2",47,0) ;"Example: to print from: "RTN","TMGXMLE2",48,0) ;" file 8925, records 1234,1235,1236,1237 "RTN","TMGXMLE2",49,0) ;" file 200, ALL records "RTN","TMGXMLE2",50,0) ;" file 22705, records 3,5 "RTN","TMGXMLE2",51,0) ;" file 2, ALL records "RTN","TMGXMLE2",52,0) ;" "RTN","TMGXMLE2",53,0) ;" Array(8925,1234)="" "RTN","TMGXMLE2",54,0) ;" Array(8925,1235)="" "RTN","TMGXMLE2",55,0) ;" Array(8925,1236)="" "RTN","TMGXMLE2",56,0) ;" Array(8925,1237)="" "RTN","TMGXMLE2",57,0) ;" Array(200,"*")="" "RTN","TMGXMLE2",58,0) ;" Array(22705,3)="" "RTN","TMGXMLE2",59,0) ;" Array(22705,5)="" "RTN","TMGXMLE2",60,0) ;" Array(2,"*")="" "RTN","TMGXMLE2",61,0) ;" "RTN","TMGXMLE2",62,0) ;"Example: Output extra info in record node "RTN","TMGXMLE2",63,0) ;" Array(8925,1232)="tag=value^tag2=value2" <-- optional extra info for record "RTN","TMGXMLE2",64,0) ;" e.g. --> <Record id=1232 tag="value" tag2="value2"> "RTN","TMGXMLE2",65,0) ;" "RTN","TMGXMLE2",66,0) ;"Example: For record 1231, output fields .01 and .02 "RTN","TMGXMLE2",67,0) ;" For record 1232, output field .01 only "RTN","TMGXMLE2",68,0) ;" For record 1234, output field "NAME" only "RTN","TMGXMLE2",69,0) ;" For record 1235, output ALL fields "RTN","TMGXMLE2",70,0) ;" Array(8925,1231,.01)="" "RTN","TMGXMLE2",71,0) ;" Array(8925,1231,.02)="" "RTN","TMGXMLE2",72,0) ;" Array(8925,1232,.01)="" "RTN","TMGXMLE2",73,0) ;" Array(8925,1234,"NAME")="" "RTN","TMGXMLE2",74,0) ;" Array(8925,1235,"*")="" "RTN","TMGXMLE2",75,0) ;" "RTN","TMGXMLE2",76,0) ;"Example: "RTN","TMGXMLE2",77,0) ;" Array(8925,"TEMPLATE",.01)="" <-- define a template for file 8925, with fields .01,.02,.03 "RTN","TMGXMLE2",78,0) ;" Array(8925,"TEMPLATE",.02)="" "RTN","TMGXMLE2",79,0) ;" Array(8925,"TEMPLATE",.03)="" "RTN","TMGXMLE2",80,0) ;" Array(8925,1234) <-- print record 1234 (will use the template) "RTN","TMGXMLE2",81,0) ;" Array(8925,1235) <-- print record 1235 "RTN","TMGXMLE2",82,0) ;" "RTN","TMGXMLE2",83,0) ;"Example: "RTN","TMGXMLE2",84,0) ;" Array(8925,"TEMPLATE","*"))="" <-- include all fields in template "RTN","TMGXMLE2",85,0) ;" Array(8925,"TEMPLATE","Field Exclude",.04)="" <-- but exclude field .04 "RTN","TMGXMLE2",86,0) ;" Array(8925,1235) <-- print record 1235, all fields but .04 "RTN","TMGXMLE2",87,0) ;" "RTN","TMGXMLE2",88,0) ;"Example: For all records, output fields .01 and .02 and "NAME" "RTN","TMGXMLE2",89,0) ;" Array(8925,"*",.01)="" "RTN","TMGXMLE2",90,0) ;" Array(8925,"*",.02)="" "RTN","TMGXMLE2",91,0) ;" Array(8925,"*","NAME")="" "RTN","TMGXMLE2",92,0) ;" "RTN","TMGXMLE2",93,0) ;"Example: "RTN","TMGXMLE2",94,0) ;" Array(8925,1231,"*")="" <--- indicates that ALL fields, ALL subrecs,and ALL subfields are wanted "RTN","TMGXMLE2",95,0) ;" "RTN","TMGXMLE2",96,0) ;"Example: For all records, output field "ENTRY", which is a multiple. In "RTN","TMGXMLE2",97,0) ;" subfile, output all records, fields .01, and .02 "RTN","TMGXMLE2",98,0) ;" Array(8925,"*","ENTRY","*",.01)="" "RTN","TMGXMLE2",99,0) ;" Array(8925,"*","ENTRY","*",.02)="" "RTN","TMGXMLE2",100,0) ;" "RTN","TMGXMLE2",101,0) ;"Example: For ALL records, output ALL fields, and ALL subfields, with 2 exceptions "RTN","TMGXMLE2",102,0) ;" Array(8925,"Rec Exclude",1234)="" <-- All records except 1234 & 1235 will be output "RTN","TMGXMLE2",103,0) ;" Array(8925,"Rec Exclude",1235)="" "RTN","TMGXMLE2",104,0) ;" Array(8925,"*")="" "RTN","TMGXMLE2",105,0) ;" "RTN","TMGXMLE2",106,0) ;"Example: "RTN","TMGXMLE2",107,0) ;" Array(8925,"TEMPLATE","Field Exclude",.04)="" <-- don't show field .04 "RTN","TMGXMLE2",108,0) ;" Array(8925,"TEMPLATE","Field Exclude","STATE")="" <-- don't show field "STATE" "RTN","TMGXMLE2",109,0) ;" Array(8925,1231,"*")="" <-- in record 1231, show all fields but .04 and "STATE" "RTN","TMGXMLE2",110,0) ;" "RTN","TMGXMLE2",111,0) ;"Example: Field .04 is multiple. ALL sub records and ALL subfields to be written "RTN","TMGXMLE2",112,0) ;" Array(8925,1231,.04,"*","*")="" "RTN","TMGXMLE2",113,0) ;" Array(8925,1231,.04,"*")="" <--- "*" assumed for subfields "RTN","TMGXMLE2",114,0) ;" Array(8925,1231,.04)="" <-- "*" assumed for subrecords and subfields. "RTN","TMGXMLE2",115,0) ;" "RTN","TMGXMLE2",116,0) ;"Example: Field .03 is multiple. All sub records to be written (except for #5) , and .01 and .02 fields to be written "RTN","TMGXMLE2",117,0) ;" Array(8925,1231,.03,"*",.01)="" <-- In all sub recs, sub field .01 is to be written "RTN","TMGXMLE2",118,0) ;" Array(8925,1231,.03,"*",.02)="" <-- In all sub recs, sub field .02 is to be written "RTN","TMGXMLE2",119,0) ;" Array(8925,1231,.03,"Rec Exclude",5)="" <-- Exclude subrec 5 "RTN","TMGXMLE2",120,0) ;" "RTN","TMGXMLE2",121,0) ;"Example: Field .03 is multiple. All sub records to be written, and .01 and .02 fields to be written "RTN","TMGXMLE2",122,0) ;" Array(8925,1231,"TEMPLATE",.03,"*","TEMPLATE",.01)="" <-- In all sub recs, sub field .01 is to be written "RTN","TMGXMLE2",123,0) ;" Array(8925,1231,"TEMPLATE",.03,"*","TEMPLATE",.02)="" <-- In all sub recs, sub field .02 is to be written "RTN","TMGXMLE2",124,0) "RTN","TMGXMLE2",125,0) ;"Example: Field .03 is multiple. Sub records 1,2,3 to be written, fields as below "RTN","TMGXMLE2",126,0) ;" Array(8925,1231,.03,1,.01)="" <-- In sub rec 1, sub field .01 is to be written "RTN","TMGXMLE2",127,0) ;" Array(8925,1231,.03,1,.02)="" <-- In sub rec 1, sub field .02 is to be written "RTN","TMGXMLE2",128,0) ;" Array(8925,1231,.03,2,.01)="" <-- In sub rec 2, sub field .01 is to be written "RTN","TMGXMLE2",129,0) ;" Array(8925,1231,.03,3,"*")="" <-- In sub rec 3, all sub fields are to be written "RTN","TMGXMLE2",130,0) ;" Array(8925,1231,.03,4)="" <-- In sub rec 4, all sub fields are to be written (defalt) "RTN","TMGXMLE2",131,0) ;" Array(8925,1231,.03,5,"*")="" <-- In sub rec 5, all sub fields are to be written, with one exception "RTN","TMGXMLE2",132,0) ;" Array(8925,1231,.03,5,"Field Exclude",.01)="" <-- In sub rec 5, sub fields .01 is not to be written. "RTN","TMGXMLE2",133,0) ;" "RTN","TMGXMLE2",134,0) ;"Example: Shows optional substitution of a new tag name for a given field "RTN","TMGXMLE2",135,0) ;" Array(8925,"TEMPLATE","TAG NAME",.01)="Patent Name" <-- use "Patient Name" instead of field name for .01 field "RTN","TMGXMLE2",136,0) ;" Array(8925,"TEMPLATE","TAG NAME",.02)="City" <-- use "City" instead of field name for .02 field "RTN","TMGXMLE2",137,0) ;" "RTN","TMGXMLE2",138,0) ;"Note: pattern continues for sub-sub-multiples etc. "RTN","TMGXMLE2",139,0) ;" "RTN","TMGXMLE2",140,0) ;"Example: "RTN","TMGXMLE2",141,0) ;" Array(8925,1231,.01)="" "RTN","TMGXMLE2",142,0) ;" Array(8925,1231,.02)="" "RTN","TMGXMLE2",143,0) ;" Array(8925,1231,"NAME")="" <--- note that field name is allowed in place of number "RTN","TMGXMLE2",144,0) ;" Array(8925,1231,.03,1,.01)="" <-- In sub rec 1, sub field .01 is to be written "RTN","TMGXMLE2",145,0) ;" Array(8925,1231,.03,1,.02)="" <-- In sub rec 1, sub field .02 is to be written "RTN","TMGXMLE2",146,0) ;" Array(8925,1231,.03,2,.01)="" <-- In sub rec 2, sub field .01 is to be written "RTN","TMGXMLE2",147,0) ;" Array(8925,1231,.03,3,"*")="" <-- In sub rec 3, all sub fields are to be written "RTN","TMGXMLE2",148,0) ;" Array(8925,1231,.03,4)="" <-- In sub rec 4, all sub fields are to be written (defalt) "RTN","TMGXMLE2",149,0) ;" "RTN","TMGXMLE2",150,0) ;"Example: Field .03 is a multiple "RTN","TMGXMLE2",151,0) ;" Array(8925,1231,.03,"TEMPLATE",.01)="" "RTN","TMGXMLE2",152,0) ;" Array(8925,1231,.03,"TEMPLATE",.02)="" "RTN","TMGXMLE2",153,0) ;" Array(8925,1231,.03,1)="" <-- In sub rec 1, export fields .01,.02 from template "RTN","TMGXMLE2",154,0) ;" Array(8925,1231,.03,2)="" <-- In sub rec 2, export fields .01,.02 from template "RTN","TMGXMLE2",155,0) ;" Array(8925,1231,.03,4)="" <-- In sub rec 4, export fields .01,.02 from template "RTN","TMGXMLE2",156,0) ;" "RTN","TMGXMLE2",157,0) ;"Example: "RTN","TMGXMLE2",158,0) ;" Array(8925,"TEMPLATE","ORDER",1)=.03 <-- 1st field to output "RTN","TMGXMLE2",159,0) ;" Array(8925,"TEMPLATE","ORDER",2)=.02 <-- 2nd field to output "RTN","TMGXMLE2",160,0) ;" Array(8925,"TEMPLATE","ORDER",3)="NAME" <-- 3rd field to output "RTN","TMGXMLE2",161,0) ;" Array(8925,"TEMPLATE","ORDER",4)=.01 <-- 4th field to output "RTN","TMGXMLE2",162,0) ;" Note: Specifying an 'ORDER' is not compatible with specifying "*" fields "RTN","TMGXMLE2",163,0) ;" If "ORDER" is specified, only fields with a given order will be output "RTN","TMGXMLE2",164,0) ;" Both Field("ORDER",x)=FieldNum *AND* Field(FieldNum)="" should be defined "RTN","TMGXMLE2",165,0) ;" This will be primarily important for fields that are multiples, with sub recs. "RTN","TMGXMLE2",166,0) ;" "RTN","TMGXMLE2",167,0) ;"Example: "RTN","TMGXMLE2",168,0) ;" Array(8925,"TEMPLATE","TRANSFORM",.01)="write ""Custom .01 output transform M code here...""" "RTN","TMGXMLE2",169,0) ;" Array(8925,"TEMPLATE","TRANSFORM",.02)="write ""Custom .02 output transform M code here...""" "RTN","TMGXMLE2",170,0) "RTN","TMGXMLE2",171,0) "RTN","TMGXMLE2",172,0) "RTN","TMGXMLE2",173,0) WriteXMLData(pArray,Flags,IndentS,ShowProgress) "RTN","TMGXMLE2",174,0) ;"Scope: PUBLIC "RTN","TMGXMLE2",175,0) ;"Purpose: to dump out a specified set of files and records in XML Format "RTN","TMGXMLE2",176,0) ;"Input: pArray -- pointer to (i.e. name of) array containting formatting/output info. "RTN","TMGXMLE2",177,0) ;" REQUIRED An array specifying which files and records to display "RTN","TMGXMLE2",178,0) ;" Format as follows: "RTN","TMGXMLE2",179,0) ;" ;"----------------------------------------- "RTN","TMGXMLE2",180,0) ;" Array(File,IEN,FieldInfo) ; For FieldInfo, see Write1File, and Write1Rec "RTN","TMGXMLE2",181,0) ;" Array(File,["TEMPLATE"],...) ;For Template info see function Write1File "RTN","TMGXMLE2",182,0) ;" Array("FLAGS","b")="" b -- show tags for ALL fields, even if field has no data "RTN","TMGXMLE2",183,0) ;" Array("FLAGS","i")="" i -- indent tags for pretty, but technically useless, file formating. "RTN","TMGXMLE2",184,0) ;" Array("FLAGS","I")="" I -- output INTERNAL values "RTN","TMGXMLE2",185,0) ;" Array("FLAGS","D")="" D -- output the data dictionary "RTN","TMGXMLE2",186,0) ;" Array("FLAGS","S")="" S -- output export settings. "RTN","TMGXMLE2",187,0) ;" Array("!DOCTYPE")=MyLabel "RTN","TMGXMLE2",188,0) ;" Array("EXPORT_SYSTEM_NAME")=LabelForExportingSystem -- OPTIONAL "RTN","TMGXMLE2",189,0) ;" ;"----------------------------------------- "RTN","TMGXMLE2",190,0) ;" "RTN","TMGXMLE2",191,0) ;" e.g. Array(8925,1234)="" "RTN","TMGXMLE2",192,0) ;" Array(8925,1235)="" "RTN","TMGXMLE2",193,0) ;" Array(8925,1236)="" "RTN","TMGXMLE2",194,0) ;" Array(8925,1237)="" "RTN","TMGXMLE2",195,0) ;" Array(8925,1232)="tag=value^tag2=value2" <-- optional extra info for record "RTN","TMGXMLE2",196,0) ;" e.g. --> <Record id=1232 tag="value" tag2="value2"> "RTN","TMGXMLE2",197,0) ;" Array(200,"*")="" "RTN","TMGXMLE2",198,0) ;" Array(22705,3)="" "RTN","TMGXMLE2",199,0) ;" Array(22705,5)="" "RTN","TMGXMLE2",200,0) ;" Array(2,"*")="" "RTN","TMGXMLE2",201,0) ;" "RTN","TMGXMLE2",202,0) ;" This would print from: "RTN","TMGXMLE2",203,0) ;" file 8925, records 1234,1235,1236,1237 "RTN","TMGXMLE2",204,0) ;" file 200, ALL records "RTN","TMGXMLE2",205,0) ;" file 22705, records 3,5 "RTN","TMGXMLE2",206,0) ;" file 2, ALL records "RTN","TMGXMLE2",207,0) ;" "RTN","TMGXMLE2",208,0) ;" Example: "RTN","TMGXMLE2",209,0) ;" Array(8925,"TEMPLATE",.01)="" <-- define a template for file 8925 "RTN","TMGXMLE2",210,0) ;" Array(8925,"TEMPLATE",.02)="" "RTN","TMGXMLE2",211,0) ;" Array(8925,"TEMPLATE",.02)="" "RTN","TMGXMLE2",212,0) ;" Array(8925,1234) <-- print record 1234 "RTN","TMGXMLE2",213,0) ;" Array(8925,1235) <-- print record 1235 "RTN","TMGXMLE2",214,0) ;" "RTN","TMGXMLE2",215,0) ;" Example: "RTN","TMGXMLE2",216,0) ;" Array(8925,1234) <-- print record 1234 "RTN","TMGXMLE2",217,0) ;" Array(8925,1235) <-- print record 1235 "RTN","TMGXMLE2",218,0) ;" "RTN","TMGXMLE2",219,0) ;" Example: "RTN","TMGXMLE2",220,0) ;" Array(8925,1234,.01) <-- print record 1234, only field .01 "RTN","TMGXMLE2",221,0) ;" Array(8925,1235,.04) <-- print record 1235, only field .04 "RTN","TMGXMLE2",222,0) ;" "RTN","TMGXMLE2",223,0) ;" Note: File numbers can be replaces with full FILE NAMES, e.g. "RTN","TMGXMLE2",224,0) ;" Array("NEW PERSON","*")="" "RTN","TMGXMLE2",225,0) ;" "RTN","TMGXMLE2",226,0) ;" Note: All File numbers and field numbers can be replaced with NAMES "RTN","TMGXMLE2",227,0) ;" "RTN","TMGXMLE2",228,0) ;" Flags -- OPTIONAL (Note Flags can also be specified with a "FLAGS" node) "RTN","TMGXMLE2",229,0) ;" b -- show tags for ALL fields, even if field has no data "RTN","TMGXMLE2",230,0) ;" i -- indent tags for pretty, but technically useless, file formating. "RTN","TMGXMLE2",231,0) ;" I -- output INTERNAL values "RTN","TMGXMLE2",232,0) ;" D -- output Data dictionary "RTN","TMGXMLE2",233,0) ;" e.g. Flags="b" or "bi" or "ib" or "iI" etc. "RTN","TMGXMLE2",234,0) ;" IndentS -- OPTIONAL -- current string to write to indent line. "RTN","TMGXMLE2",235,0) ;" IndentS("IncIndent")=IncIndent "RTN","TMGXMLE2",236,0) ;" ShowProgress -- OPTIONAL -- if =1, then a progress bar will be shown. "RTN","TMGXMLE2",237,0) ;"Output: results are written to the current device. "RTN","TMGXMLE2",238,0) ;"result : none "RTN","TMGXMLE2",239,0) "RTN","TMGXMLE2",240,0) new File,tArray,SavFieldInfo "RTN","TMGXMLE2",241,0) merge tArray=@pArray "RTN","TMGXMLE2",242,0) set Flags=$get(Flags) "RTN","TMGXMLE2",243,0) new IncIndent set IncIndent=$get(IndentS("IncIndent")," ") "RTN","TMGXMLE2",244,0) "RTN","TMGXMLE2",245,0) if ($data(tArray("FLAGS","b"))>0)&(Flags'["b") set Flags=Flags_"b" "RTN","TMGXMLE2",246,0) if ($data(tArray("FLAGS","i"))>0)&(Flags'["i") set Flags=Flags_"i" "RTN","TMGXMLE2",247,0) if ($data(tArray("FLAGS","I"))>0)&(Flags'["I") set Flags=Flags_"I" "RTN","TMGXMLE2",248,0) if ($data(tArray("FLAGS","D"))>0)&(Flags'["D") set Flags=Flags_"D" "RTN","TMGXMLE2",249,0) if ($data(tArray("FLAGS","S"))>0)&(Flags'["S") set Flags=Flags_"S" "RTN","TMGXMLE2",250,0) "RTN","TMGXMLE2",251,0) do WriteHeader "RTN","TMGXMLE2",252,0) write "<!DOCTYPE "_$get(tArray("!DOCTYPE"),"UNDEFINED"),">",! "RTN","TMGXMLE2",253,0) new SrcName set SrcName=$get(tArray("EXPORT_SYSTEM_NAME"),"?Unnamed?") "RTN","TMGXMLE2",254,0) write "<EXPORT source=""",$$SYMENC^MXMLUTL(SrcName),""">",! "RTN","TMGXMLE2",255,0) set IndentS=$get(IndentS)_IncIndent "RTN","TMGXMLE2",256,0) if Flags["S" do WriteSettings(.Flags,.IndentS) ;"output writing settings "RTN","TMGXMLE2",257,0) "RTN","TMGXMLE2",258,0) set File="" "RTN","TMGXMLE2",259,0) for set File=$order(tArray(File)) quit:(+File'>0) do "RTN","TMGXMLE2",260,0) . new IEN,Template,Recs "RTN","TMGXMLE2",261,0) . merge Template=tArray(File,"TEMPLATE") "RTN","TMGXMLE2",262,0) . kill tArray(File,"TEMPLATE") "RTN","TMGXMLE2",263,0) . merge Recs=tArray(File) "RTN","TMGXMLE2",264,0) . set IEN=$order(tArray(File,"")) "RTN","TMGXMLE2",265,0) . if IEN'="" do "RTN","TMGXMLE2",266,0) . . if $data(TMGXDEBUG) do "RTN","TMGXMLE2",267,0) . . . use $P write "Writing file: ",File,! use IO "RTN","TMGXMLE2",268,0) . . if IEN="*" do "RTN","TMGXMLE2",269,0) . . . do Write1File(File,.Recs,.Flags,.IndentS,.Template,.ShowProgress,,,,,.SavFieldInfo) "RTN","TMGXMLE2",270,0) . . else do "RTN","TMGXMLE2",271,0) . . . new Recs merge Recs=tArray(File) "RTN","TMGXMLE2",272,0) . . . do Write1File(File,.Recs,.Flags,.IndentS,,.ShowProgress,,,,,.SavFieldInfo) "RTN","TMGXMLE2",273,0) "RTN","TMGXMLE2",274,0) write "</EXPORT>",! "RTN","TMGXMLE2",275,0) "RTN","TMGXMLE2",276,0) quit "RTN","TMGXMLE2",277,0) "RTN","TMGXMLE2",278,0) "RTN","TMGXMLE2",279,0) WriteHeader "RTN","TMGXMLE2",280,0) ;"Scope: PUBLIC "RTN","TMGXMLE2",281,0) ;"Purpose: A shell to write out a proper XML header. This should be done prior "RTN","TMGXMLE2",282,0) ;" to writing out XML formatted data to a device "RTN","TMGXMLE2",283,0) ;"Output: Header is output to current device "RTN","TMGXMLE2",284,0) ;"Results: none "RTN","TMGXMLE2",285,0) "RTN","TMGXMLE2",286,0) new s "RTN","TMGXMLE2",287,0) set s=$$XMLHDR^MXMLUTL "RTN","TMGXMLE2",288,0) write s,! "RTN","TMGXMLE2",289,0) quit "RTN","TMGXMLE2",290,0) "RTN","TMGXMLE2",291,0) "RTN","TMGXMLE2",292,0) Write1File(File,Recs,Flags,IndentS,Template,ShowProgress,RWriter,FWriter,LWriter,WPLWriter,SavFieldInfo) "RTN","TMGXMLE2",293,0) ;"Scope: PUBLIC "RTN","TMGXMLE2",294,0) ;"Purpose: to dump out (in XML) one file, for specified records "RTN","TMGXMLE2",295,0) ;"Input: File -- name or number of file to dump "RTN","TMGXMLE2",296,0) ;" Recs -- OPTIONAL. PASS BY REFERENCE (default is to write ALL records) "RTN","TMGXMLE2",297,0) ;" To specify records to write out, use Recs array with following format: "RTN","TMGXMLE2",298,0) ;" ------------------------------------------------------------------- "RTN","TMGXMLE2",299,0) ;" Recs(IEN,Field,FieldInfo); (Default for all is "*") "RTN","TMGXMLE2",300,0) ;" For format of FieldInfo, see function Write1Rec "RTN","TMGXMLE2",301,0) ;" Recs("Rec Exclude",IEN) <-- exclude IEN from output "RTN","TMGXMLE2",302,0) ;" ------------------------------------------------------------------- "RTN","TMGXMLE2",303,0) ;" Example: "RTN","TMGXMLE2",304,0) ;" Recs(1231)="" "RTN","TMGXMLE2",305,0) ;" Recs(1232)="" "RTN","TMGXMLE2",306,0) ;" Recs(1234)="" this would be used to print records 1231,1232,1234 "RTN","TMGXMLE2",307,0) ;" Recs(1232)="tag=value^tag2=value2" <-- optional extra info for record "RTN","TMGXMLE2",308,0) ;" e.g. <Record id=1232 tag="value" tag2="value2"> "RTN","TMGXMLE2",309,0) ;" "RTN","TMGXMLE2",310,0) ;" Example: For ALL records, output ALL fields, and ALL subfields "RTN","TMGXMLE2",311,0) ;" Recs("*")="" <--- this is default if Recs is not specified/passed "RTN","TMGXMLE2",312,0) ;" Example: For all records, output fields .01 and .02 and "NAME" "RTN","TMGXMLE2",313,0) ;" Recs("*",.01)="" "RTN","TMGXMLE2",314,0) ;" Recs("*",.02)="" "RTN","TMGXMLE2",315,0) ;" Recs("*","NAME")="" "RTN","TMGXMLE2",316,0) ;" Example: For record 1231, output fields .01 and .02 "RTN","TMGXMLE2",317,0) ;" For record 1232, output field .01 only "RTN","TMGXMLE2",318,0) ;" For record 1234, output field "NAME" only "RTN","TMGXMLE2",319,0) ;" For record 1235, output ALL fields "RTN","TMGXMLE2",320,0) ;" Recs(1231,.01)="" "RTN","TMGXMLE2",321,0) ;" Recs(1231,.02)="" "RTN","TMGXMLE2",322,0) ;" Recs(1232,.01)="" "RTN","TMGXMLE2",323,0) ;" Recs(1234,"NAME")="" "RTN","TMGXMLE2",324,0) ;" Recs(1235,"*")="" "RTN","TMGXMLE2",325,0) ;" Example: For all records, output field "ENTRY", which is a multiple. In "RTN","TMGXMLE2",326,0) ;" subfile, output records .01, and .02 "RTN","TMGXMLE2",327,0) ;" Recs("*","ENTRY",.01)="" "RTN","TMGXMLE2",328,0) ;" Recs("*","ENTRY",.02)="" "RTN","TMGXMLE2",329,0) ;" Example: For ALL records, output ALL fields, and ALL subfields, with 2 exceptions "RTN","TMGXMLE2",330,0) ;" Recs("*")="" "RTN","TMGXMLE2",331,0) ;" Recs("Rec Exclude",1234)="" <-- All records except 1234 & 1235 will be output "RTN","TMGXMLE2",332,0) ;" Recs("Rec Exclude",1235)="" "RTN","TMGXMLE2",333,0) ;" Flags -- OPTIONAL "RTN","TMGXMLE2",334,0) ;" b -- show tags for ALL fields, even if field has no data "RTN","TMGXMLE2",335,0) ;" i -- indent tags for pretty, but technically useless, file formating. "RTN","TMGXMLE2",336,0) ;" I -- output INTERNAL values "RTN","TMGXMLE2",337,0) ;" D -- include data dictionary for file. "RTN","TMGXMLE2",338,0) ;" S -- output export settings "RTN","TMGXMLE2",339,0) ;" IndentS -- OPTIONAL -- current string to write to indent line. "RTN","TMGXMLE2",340,0) ;" IndentS("IncIndent")=IncIndent "RTN","TMGXMLE2",341,0) ;" Template -- OPTIONAL. PASS BY REFERENCE "RTN","TMGXMLE2",342,0) ;" This can be used for instances where the same set of fields are desired for "RTN","TMGXMLE2",343,0) ;" multiple records. "RTN","TMGXMLE2",344,0) ;" Example: "RTN","TMGXMLE2",345,0) ;" Recs(1231)="" "RTN","TMGXMLE2",346,0) ;" Recs(1232)="" "RTN","TMGXMLE2",347,0) ;" Recs(1234)="" "RTN","TMGXMLE2",348,0) ;" with Template(.01)="" "RTN","TMGXMLE2",349,0) ;" Template(.02)="" "RTN","TMGXMLE2",350,0) ;" Is the same as specifying: "RTN","TMGXMLE2",351,0) ;" Recs(1231,.01)="" "RTN","TMGXMLE2",352,0) ;" Recs(1231,.02)="" "RTN","TMGXMLE2",353,0) ;" Recs(1232,.01)="" "RTN","TMGXMLE2",354,0) ;" Recs(1232,.02)="" "RTN","TMGXMLE2",355,0) ;" Recs(1234,.01)="" "RTN","TMGXMLE2",356,0) ;" Recs(1234,.02)="" "RTN","TMGXMLE2",357,0) ;" ShowProgress -- OPTIONAL -- if >0, then a progress bar will be shown. "RTN","TMGXMLE2",358,0) ;" RWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",359,0) ;" actual starting and ending <record> </record>. e.g. "RTN","TMGXMLE2",360,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",361,0) ;" as custom function must accept same parameters as WriteRLabel "RTN","TMGXMLE2",362,0) ;" FWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",363,0) ;" actual line of text out. e.g. "WriteFLabel" or "RTN","TMGXMLE2",364,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",365,0) ;" LWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",366,0) ;" actual line of text out for WP fields. e.g. "WriteLine" or "RTN","TMGXMLE2",367,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",368,0) ;" as custom function must accept same parameters as WriteLine "RTN","TMGXMLE2",369,0) ;" as custom function must accept same parameters as WriteFLabel "RTN","TMGXMLE2",370,0) ;" WPLWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",371,0) ;" actual line of text out for WP fields. If not provided, then "RTN","TMGXMLE2",372,0) ;" LWriter will be used instead. "RTN","TMGXMLE2",373,0) ;" e.g. "WriteWPLine" or "MyWPCustomFn". Note do NOT include parameters. "RTN","TMGXMLE2",374,0) ;" Function named as custom function must accept same parameters as WriteLine "RTN","TMGXMLE2",375,0) ;" SavFieldInfo -- OPTIONAL -- PASS BY REFERENCE. An array to hold lookup values about "RTN","TMGXMLE2",376,0) ;" fields, so it doesn't have to be done each time (faster) "RTN","TMGXMLE2",377,0) ;"Output: results are written to the current device. "RTN","TMGXMLE2",378,0) ;"result : none "RTN","TMGXMLE2",379,0) "RTN","TMGXMLE2",380,0) new ORoot,GRef "RTN","TMGXMLE2",381,0) new FileNum,FName "RTN","TMGXMLE2",382,0) new prgsCt set prgsCt=0 "RTN","TMGXMLE2",383,0) new prgsMax "RTN","TMGXMLE2",384,0) "RTN","TMGXMLE2",385,0) new IncIndent set IncIndent=$get(IndentS("IncIndent")," ") "RTN","TMGXMLE2",386,0) if $data(Template)=0 set Template("*")="" "RTN","TMGXMLE2",387,0) new RecsSpecified set RecsSpecified=(($data(Recs)>1)&($data(Recs("*"))=0)) "RTN","TMGXMLE2",388,0) new keyin set keyin=32 "RTN","TMGXMLE2",389,0) new startTime set startTime=$H "RTN","TMGXMLE2",390,0) set RWriter=$get(RWriter,"WriteRLabel") "RTN","TMGXMLE2",391,0) set IndentS=$get(IndentS) "RTN","TMGXMLE2",392,0) "RTN","TMGXMLE2",393,0) set FileNum=+$get(File) "RTN","TMGXMLE2",394,0) if FileNum=0 do "RTN","TMGXMLE2",395,0) . set FileNum=$$GetFileNum^TMGDBAPI(.File) "RTN","TMGXMLE2",396,0) . set FName=File "RTN","TMGXMLE2",397,0) else do "RTN","TMGXMLE2",398,0) . set FName=$order(^DD(FileNum,0,"NM","")) "RTN","TMGXMLE2",399,0) if FileNum=0 do goto WFDone "RTN","TMGXMLE2",400,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") "RTN","TMGXMLE2",401,0) "RTN","TMGXMLE2",402,0) set ORoot=$$GET1^DID(FileNum,"","","GLOBAL NAME") ;" Get global root (Thanks, Don Donati...) "RTN","TMGXMLE2",403,0) set GRef=$$CREF^DILF(ORoot) ;" Convert open to closed root "RTN","TMGXMLE2",404,0) "RTN","TMGXMLE2",405,0) if $get(ShowProgress) do "RTN","TMGXMLE2",406,0) . if RecsSpecified do "RTN","TMGXMLE2",407,0) . . set prgsMax=$$ListCt^TMGMISC("Recs") "RTN","TMGXMLE2",408,0) . else do "RTN","TMGXMLE2",409,0) . . set prgsMax=0 "RTN","TMGXMLE2",410,0) . . set IEN=$order(@GRef@("")) ;"count ALL records in file. "RTN","TMGXMLE2",411,0) . . for do quit:(IEN'>0) "RTN","TMGXMLE2",412,0) . . . set IEN=$order(@GRef@(IEN)) "RTN","TMGXMLE2",413,0) . . . if +IEN>0 set prgsMax=prgsMax+1 "RTN","TMGXMLE2",414,0) "RTN","TMGXMLE2",415,0) set Flags=$get(Flags) "RTN","TMGXMLE2",416,0) if Flags["i" write IndentS "RTN","TMGXMLE2",417,0) write "<FILE id=""",FileNum,""" label=""",$$SYMENC^MXMLUTL(FName),""">",! "RTN","TMGXMLE2",418,0) "RTN","TMGXMLE2",419,0) if Flags["D" do WriteDD(FileNum,Flags,IndentS_IncIndent) ;"write out data dictionary file "RTN","TMGXMLE2",420,0) "RTN","TMGXMLE2",421,0) new IndS2 set IndS2=IndentS_IncIndent "RTN","TMGXMLE2",422,0) new IEN set IEN=0 "RTN","TMGXMLE2",423,0) for do quit:(IEN'>0) "RTN","TMGXMLE2",424,0) . if $data(Fields)'>1 set Fields("*")="" "RTN","TMGXMLE2",425,0) . if RecsSpecified do "RTN","TMGXMLE2",426,0) . . set IEN=$order(Recs(IEN)) ;"Cycle through specified records "RTN","TMGXMLE2",427,0) . . new Extra set Extra=$get(Recs(IEN)) "RTN","TMGXMLE2",428,0) . . if Extra'="" do ;"parse extra info into IEN array for output "RTN","TMGXMLE2",429,0) . . . new s,n,tag,value "RTN","TMGXMLE2",430,0) . . . for n=1:1:$length(Extra,"^") do "RTN","TMGXMLE2",431,0) . . . . set s=$piece(Extra,"^",n) "RTN","TMGXMLE2",432,0) . . . . if s'["=" quit "RTN","TMGXMLE2",433,0) . . . . set tag=$piece(s,"=",1) "RTN","TMGXMLE2",434,0) . . . . set value=$piece(s,"=",2) "RTN","TMGXMLE2",435,0) . . . . set IEN(tag)=value "RTN","TMGXMLE2",436,0) . else do "RTN","TMGXMLE2",437,0) . . set IEN=$order(@GRef@(IEN)) ;"Cycle through ALL records in file. "RTN","TMGXMLE2",438,0) . if (IEN'>0) quit "RTN","TMGXMLE2",439,0) . if $data(Recs("Rec Exclude",IEN)) quit ;"skip excluded records "RTN","TMGXMLE2",440,0) . new Fields merge Fields=Recs(IEN) "RTN","TMGXMLE2",441,0) . if $data(Fields)'>1 merge Fields=Template "RTN","TMGXMLE2",442,0) . if $get(Flags)["i" write $get(IndS2) "RTN","TMGXMLE2",443,0) . new exFn set exFn="do "_RWriter_"(.IEN,0)" "RTN","TMGXMLE2",444,0) . xecute exFn "RTN","TMGXMLE2",445,0) . if $data(TMGXDEBUG) do "RTN","TMGXMLE2",446,0) . . use $P "RTN","TMGXMLE2",447,0) . . write "Writing record: ",IEN," prgsCt=",prgsCt," prgsMax=",prgsMax,! "RTN","TMGXMLE2",448,0) . . use IO "RTN","TMGXMLE2",449,0) . do Write1Rec(FileNum,IEN,.Fields,.Flags,"","",IndS2_IncIndent,.RWriter,.FWriter,.LWriter,.WPLWriter,.SavFieldInfo) "RTN","TMGXMLE2",450,0) . if $get(Flags)["i" write $get(IndS2) "RTN","TMGXMLE2",451,0) . set exFn="do "_RWriter_"(.IEN,1)" "RTN","TMGXMLE2",452,0) . xecute exFn "RTN","TMGXMLE2",453,0) . set prgsCt=prgsCt+1 "RTN","TMGXMLE2",454,0) . if $get(ShowProgress)&(prgsCt#2=1) do "RTN","TMGXMLE2",455,0) . . use $P "RTN","TMGXMLE2",456,0) . . do ProgressBar^TMGUSRIF(prgsCt,"Writing "_FName,1,prgsMax,,startTime) "RTN","TMGXMLE2",457,0) . . use IO "RTN","TMGXMLE2",458,0) . ;"use $P read *keyin use IO "RTN","TMGXMLE2",459,0) . if keyin=27 do "RTN","TMGXMLE2",460,0) . . new Abort "RTN","TMGXMLE2",461,0) . . use $P "RTN","TMGXMLE2",462,0) . . write prgsCt," records written so far...",! "RTN","TMGXMLE2",463,0) . . write !,"Do you want to abort XML export? NO// " "RTN","TMGXMLE2",464,0) . . read Abort:$get(DTIME,3600),! "RTN","TMGXMLE2",465,0) . . if Abort="" set Abort="NO" "RTN","TMGXMLE2",466,0) . . if "YESyesYes"[Abort set IEN=0 ;"abort signal "RTN","TMGXMLE2",467,0) . . write "OK. Continuing...",! "RTN","TMGXMLE2",468,0) . . use IO "RTN","TMGXMLE2",469,0) "RTN","TMGXMLE2",470,0) if $get(Flags)["i" write IndentS "RTN","TMGXMLE2",471,0) write "</FILE>",! "RTN","TMGXMLE2",472,0) "RTN","TMGXMLE2",473,0) if $get(ShowProgress) do "RTN","TMGXMLE2",474,0) . use $P "RTN","TMGXMLE2",475,0) . do ProgressBar^TMGUSRIF(100,"Writing "_FName,1,100) "RTN","TMGXMLE2",476,0) . use IO "RTN","TMGXMLE2",477,0) "RTN","TMGXMLE2",478,0) WFDone "RTN","TMGXMLE2",479,0) quit "RTN","TMGXMLE2",480,0) "RTN","TMGXMLE2",481,0) WriteSettings(Flags,IndentS) "RTN","TMGXMLE2",482,0) ;"Scope: PRIVATE "RTN","TMGXMLE2",483,0) ;"Purpose: to output XML output settings. "RTN","TMGXMLE2",484,0) ;"Input: Flags -- flags as declared above. Only "i" used here "RTN","TMGXMLE2",485,0) ;" IndentS -- OPTIONAL -- current string to write to indent line. "RTN","TMGXMLE2",486,0) ;" IndentS("IncIndent")=IncIndent "RTN","TMGXMLE2",487,0) "RTN","TMGXMLE2",488,0) ;"NOTE: Uses GLOBAL SCOPED IncIndent variable. But setting this is OPTIONAL. "RTN","TMGXMLE2",489,0) ;"Results: none "RTN","TMGXMLE2",490,0) "RTN","TMGXMLE2",491,0) set IndentS=$get(IndentS) "RTN","TMGXMLE2",492,0) set Flags=$get(Flags) "RTN","TMGXMLE2",493,0) new IncIndent set IncIndent=$get(IndentS("IncIndent")," ") "RTN","TMGXMLE2",494,0) "RTN","TMGXMLE2",495,0) if Flags["i" write IndentS "RTN","TMGXMLE2",496,0) write "<ExportSettings>",! "RTN","TMGXMLE2",497,0) "RTN","TMGXMLE2",498,0) new fArray,fl "RTN","TMGXMLE2",499,0) set fArray("i")="Indent_Output" "RTN","TMGXMLE2",500,0) set fArray("b")="Output_Blanks" "RTN","TMGXMLE2",501,0) set fArray("I")="Output_Internal_Values" "RTN","TMGXMLE2",502,0) set fArray("D")="Output_Data_Dictionary" "RTN","TMGXMLE2",503,0) "RTN","TMGXMLE2",504,0) set fl="" "RTN","TMGXMLE2",505,0) for set fl=$order(fArray(fl)) quit:(fl="") do "RTN","TMGXMLE2",506,0) . if Flags["i" write IndentS_IncIndent "RTN","TMGXMLE2",507,0) . write "<Setting id=""",$$SYMENC^MXMLUTL($get(fArray(fl))),""">" "RTN","TMGXMLE2",508,0) . write $select((Flags[fl):"TRUE",1:"FALSE") "RTN","TMGXMLE2",509,0) . write "</Setting>",! "RTN","TMGXMLE2",510,0) "RTN","TMGXMLE2",511,0) if Flags["i" write IndentS "RTN","TMGXMLE2",512,0) write "</ExportSettings>",! "RTN","TMGXMLE2",513,0) "RTN","TMGXMLE2",514,0) quit "RTN","TMGXMLE2",515,0) "RTN","TMGXMLE2",516,0) WriteDD(FileNum,Flags,IndentS) "RTN","TMGXMLE2",517,0) ;"Scope: PRIVATE "RTN","TMGXMLE2",518,0) ;"Purpose: to write out data dictionary file, ^DIC,and file Header in XML format "RTN","TMGXMLE2",519,0) ;"Input: FileNum -- the file number (not name) of the data dictionary to export "RTN","TMGXMLE2",520,0) ;" Flags -- flags as declared above. Only "i" used here "RTN","TMGXMLE2",521,0) ;" IndentS -- OPTIONAL -- current string to write to indent line. "RTN","TMGXMLE2",522,0) ;"NOTE: Uses GLOBAL SCOPED IncIndent variable. But setting this is OPTIONAL. "RTN","TMGXMLE2",523,0) ;"Results: none "RTN","TMGXMLE2",524,0) "RTN","TMGXMLE2",525,0) new ProgressFn "RTN","TMGXMLE2",526,0) use $P write ! use IO "RTN","TMGXMLE2",527,0) set IncIndent=$get(IncIndent," ") "RTN","TMGXMLE2",528,0) "RTN","TMGXMLE2",529,0) set ProgressFn="use $P do ProgressBar^TMGUSRIF(IncVar,""^DD("_FileNum_")"",0,100000,,"""_$H_""") use IO" "RTN","TMGXMLE2",530,0) do WriteArray^TMGXMLT($name(^DD(FileNum)),"DataDictionary",FileNum,.Flags,.IndentS,.IncIndent,.ProgressFn) "RTN","TMGXMLE2",531,0) "RTN","TMGXMLE2",532,0) set ProgressFn="use $P do ProgressBar^TMGUSRIF(IncVar,""^(DIC("_FileNum_")"",0,1000000,,"""_$H_""") use IO" "RTN","TMGXMLE2",533,0) new DIC ;"Pull just the fileman nodes. ^DIC also contains some full files... "RTN","TMGXMLE2",534,0) merge DIC(FileNum,0)=^DIC(FileNum,0) "RTN","TMGXMLE2",535,0) merge DIC(FileNum,"%")=^DIC(FileNum,"%") "RTN","TMGXMLE2",536,0) merge DIC(FileNum,"%A")=^DIC(FileNum,"%A") "RTN","TMGXMLE2",537,0) merge DIC(FileNum,"%D")=^DIC(FileNum,"%D") "RTN","TMGXMLE2",538,0) do WriteArray^TMGXMLT("DIC("_FileNum_")","DIC_File",FileNum,.Flags,.IndentS,.IncIndent,.ProgressFn) "RTN","TMGXMLE2",539,0) "RTN","TMGXMLE2",540,0) do "RTN","TMGXMLE2",541,0) . new Ref set Ref=$get(^DIC(FileNum,0,"GL")) "RTN","TMGXMLE2",542,0) . set Ref=$$CREF^DILF(Ref) ;" Convert open to closed root "RTN","TMGXMLE2",543,0) . if $get(Flags)["i" write IndentS "RTN","TMGXMLE2",544,0) . write "<FILE_HEADER id=""",FileNum,""">",! "RTN","TMGXMLE2",545,0) . if $get(Flags)["i" write IndentS "RTN","TMGXMLE2",546,0) . write $get(@Ref@(0)),! "RTN","TMGXMLE2",547,0) . if $get(Flags)["i" write IndentS "RTN","TMGXMLE2",548,0) . write "</FILE_HEADER>",! "RTN","TMGXMLE2",549,0) "RTN","TMGXMLE2",550,0) ;"use $P write ! use IO "RTN","TMGXMLE2",551,0) quit "RTN","TMGXMLE2",552,0) "RTN","TMGXMLE2",553,0) "RTN","TMGXMLE2",554,0) Write1Rec(File,IEN,Fields,Flags,SRef,IENS,IndentS,RWriter,FWriter,LWriter,WPLWriter,SavFieldInfo) "RTN","TMGXMLE2",555,0) ;"Scope: PUBLIC "RTN","TMGXMLE2",556,0) ;"Purpose: To dump one record out in XML format "RTN","TMGXMLE2",557,0) ;"Input: File -- name or number of file to dump "RTN","TMGXMLE2",558,0) ;" IEN -- Record number (IEN) to dump (see also IENS below) "RTN","TMGXMLE2",559,0) ;" Fields -- OPTIONAL. PASS BY REFERENCE. Array of fields to write, format at follows "RTN","TMGXMLE2",560,0) ;" Fields(Field,[SubRecNums,[SubFields,...]])="" "RTN","TMGXMLE2",561,0) ;" Fields(Field,["Rec Exclude",Excluded IEN])="" "RTN","TMGXMLE2",562,0) ;" Fields("Field Exclude",ExcludedField)="" <-- OPTIONAL "RTN","TMGXMLE2",563,0) ;" Fields("ORDER",OrderNum)=Field <-- OPTIONAL "RTN","TMGXMLE2",564,0) ;" Fields("TAG NAME",FieldNumber)="Custom field name to put in XML file" <-- OPTIONAL "RTN","TMGXMLE2",565,0) ;" "RTN","TMGXMLE2",566,0) ;" Example: "RTN","TMGXMLE2",567,0) ;" Fields(.01)="" "RTN","TMGXMLE2",568,0) ;" Fields(.02)="" "RTN","TMGXMLE2",569,0) ;" Fields("NAME")="" <--- note that field name is allowed in place of number "RTN","TMGXMLE2",570,0) ;" Fields(.03)="" "RTN","TMGXMLE2",571,0) ;" "RTN","TMGXMLE2",572,0) ;" Example: "RTN","TMGXMLE2",573,0) ;" Fields("*")="" <--- indicates that ALL fields, ALL subrecs,and ALL subfields are wanted "RTN","TMGXMLE2",574,0) ;" "RTN","TMGXMLE2",575,0) ;" Example: "RTN","TMGXMLE2",576,0) ;" Fields("*")="" "RTN","TMGXMLE2",577,0) ;" Fields("Field Exclude",.04)="" <-- don't show field .04 "RTN","TMGXMLE2",578,0) ;" Fields("Field Exclude","STATE")="" <-- don't show field "STATE" "RTN","TMGXMLE2",579,0) ;" "RTN","TMGXMLE2",580,0) ;" Example: Field .04 is multiple. ALL sub records and ALL subfields to be written "RTN","TMGXMLE2",581,0) ;" Fields(.04,"*","*")="" "RTN","TMGXMLE2",582,0) ;" Fields(.04,"*")="" <--- "*" assumed for subfields "RTN","TMGXMLE2",583,0) ;" Fields(.04)="" <-- "*" assumed for subrecords and subfields. "RTN","TMGXMLE2",584,0) ;" "RTN","TMGXMLE2",585,0) ;" Example: Field .03 is multiple. All sub records to be written, and .01 and .02 fields to be written "RTN","TMGXMLE2",586,0) ;" Fields(.03,"*",.01)="" <-- In all sub recs, sub field .01 is to be written "RTN","TMGXMLE2",587,0) ;" Fields(.03,"*",.02)="" <-- In all sub recs, sub field .02 is to be written "RTN","TMGXMLE2",588,0) ;" Fields(.03,"Rec Exclude",5)="" <-- Exclude subrec 5 "RTN","TMGXMLE2",589,0) ;" "RTN","TMGXMLE2",590,0) ;" Example: Field .03 is multiple. Sub records 1,2,3 to be written, fields as below "RTN","TMGXMLE2",591,0) ;" Fields(.03,1,.01)="" <-- In sub rec 1, sub field .01 is to be written "RTN","TMGXMLE2",592,0) ;" Fields(.03,1,.02)="" <-- In sub rec 1, sub field .02 is to be written "RTN","TMGXMLE2",593,0) ;" Fields(.03,2,.01)="" <-- In sub rec 2, sub field .01 is to be written "RTN","TMGXMLE2",594,0) ;" Fields(.03,3,"*")="" <-- In sub rec 3, all sub fields are to be written "RTN","TMGXMLE2",595,0) ;" Fields(.03,4)="" <-- In sub rec 4, all sub fields are to be written (defalt) "RTN","TMGXMLE2",596,0) ;" Fields(.03,5,"*")="" <-- In sub rec 5, all sub fields are to be written, with one exception "RTN","TMGXMLE2",597,0) ;" Fields(.03,5,"Field Exclude",.01)="" <-- In sub rec 5, sub fields .01 is not to be written. "RTN","TMGXMLE2",598,0) ;" "RTN","TMGXMLE2",599,0) ;" Example: Shows optional substitution of a new tag name for a given field "RTN","TMGXMLE2",600,0) ;" Fields("TAG NAME",.01)="Patent Name" <-- use "Patient Name" instead of field name for .01 field "RTN","TMGXMLE2",601,0) ;" Fields("TAG NAME",.02)="City" <-- use "City" instead of field name for .02 field "RTN","TMGXMLE2",602,0) ;" "RTN","TMGXMLE2",603,0) ;" Example: "RTN","TMGXMLE2",604,0) ;" Array("TRANSFORM",.01)="write ""Custom .01 output transform M code here...""" "RTN","TMGXMLE2",605,0) ;" Array("TRANSFORM",.02)="write ""Custom .02 output transform M code here...""" "RTN","TMGXMLE2",606,0) ;" "RTN","TMGXMLE2",607,0) ;" Note: pattern continues for sub-sub-multiples etc. "RTN","TMGXMLE2",608,0) ;" "RTN","TMGXMLE2",609,0) ;" Example: "RTN","TMGXMLE2",610,0) ;" Fields(.01)="" "RTN","TMGXMLE2",611,0) ;" Fields(.02)="" "RTN","TMGXMLE2",612,0) ;" Fields("NAME")="" <--- note that field name is allowed in place of number "RTN","TMGXMLE2",613,0) ;" Fields(.03,1,.01)="" <-- In sub rec 1, sub field .01 is to be written "RTN","TMGXMLE2",614,0) ;" Fields(.03,1,.02)="" <-- In sub rec 1, sub field .02 is to be written "RTN","TMGXMLE2",615,0) ;" Fields(.03,2,.01)="" <-- In sub rec 2, sub field .01 is to be written "RTN","TMGXMLE2",616,0) ;" Fields(.03,3,"*")="" <-- In sub rec 3, all sub fields are to be written "RTN","TMGXMLE2",617,0) ;" Fields(.03,4)="" <-- In sub rec 4, all sub fields are to be written (defalt) "RTN","TMGXMLE2",618,0) ;" Fields("ORDER",1)=.03 <-- 1st field to output "RTN","TMGXMLE2",619,0) ;" Fields("ORDER",2)=.02 <-- 2nd field to output "RTN","TMGXMLE2",620,0) ;" Fields("ORDER",3)="NAME" <-- 3rd field to output "RTN","TMGXMLE2",621,0) ;" Fields("ORDER",4)=.01 <-- 4th field to output "RTN","TMGXMLE2",622,0) ;" Note: Specifying an 'ORDER' is not compatible with specifying "*" fields "RTN","TMGXMLE2",623,0) ;" If "ORDER" is specified, only fields with a given order will be output "RTN","TMGXMLE2",624,0) ;" Both Field("ORDER",x)=FieldNum *AND* Field(FieldNum)="" should be defined "RTN","TMGXMLE2",625,0) ;" This will be primarily important for fields that are multiples, with sub recs. "RTN","TMGXMLE2",626,0) ;" "RTN","TMGXMLE2",627,0) ;" Flags -- OPTIONAL "RTN","TMGXMLE2",628,0) ;" b -- show tags for fields, even if field has no data "RTN","TMGXMLE2",629,0) ;" i -- indent tags for pretty, but technically useless, file formating. "RTN","TMGXMLE2",630,0) ;" I -- output INTERNAL values "RTN","TMGXMLE2",631,0) ;" SRef -- OPTIONAL (Used only when calling self recursively) "RTN","TMGXMLE2",632,0) ;" IENS -- OPTIONAL a standard IENS string "RTN","TMGXMLE2",633,0) ;" e.g. "IEN,parent-IEN,grandparent-IEN," etc. "RTN","TMGXMLE2",634,0) ;" This is used when calling self recursively, to handle subfiles "RTN","TMGXMLE2",635,0) ;" IndentS -- OPTIONAL -- current string to write to indent line. "RTN","TMGXMLE2",636,0) ;" RWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",637,0) ;" actual starting and ending <record> </record>. e.g. "RTN","TMGXMLE2",638,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",639,0) ;" as custom function must accept same parameters as WriteRLabel "RTN","TMGXMLE2",640,0) ;" FWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",641,0) ;" actual line of text out. e.g. "WriteFLabel" or "RTN","TMGXMLE2",642,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",643,0) ;" as custom function must accept same parameters as WriteFLabel "RTN","TMGXMLE2",644,0) ;" LWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",645,0) ;" actual line of text out for fields. e.g. "WriteLine" or "RTN","TMGXMLE2",646,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",647,0) ;" as custom function must accept same parameters as WriteLine "RTN","TMGXMLE2",648,0) ;" WPLWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",649,0) ;" actual line of text out for WP fields. If not provided, then "RTN","TMGXMLE2",650,0) ;" LWriter will be used instead. "RTN","TMGXMLE2",651,0) ;" e.g. "WriteWPLine" or "MyWPCustomFn". Note do NOT include parameters. "RTN","TMGXMLE2",652,0) ;" Function named as custom function must accept same parameters as WriteLine "RTN","TMGXMLE2",653,0) ;" SavFieldInfo -- OPTIONAL -- PASS BY REFERENCE. An array to hold lookup values about "RTN","TMGXMLE2",654,0) ;" fields, so it doesn't have to be done each time (faster) "RTN","TMGXMLE2",655,0) "RTN","TMGXMLE2",656,0) ;"Output: Values are written to the current device "RTN","TMGXMLE2",657,0) ;"Results: None "RTN","TMGXMLE2",658,0) ;"Note: this code began its life as a function written by Greg Woodhouse (thanks Greg!) "RTN","TMGXMLE2",659,0) "RTN","TMGXMLE2",660,0) new Field,FldType,FieldInfo "RTN","TMGXMLE2",661,0) new StoreLoc,Node,Pos "RTN","TMGXMLE2",662,0) new IntValue,ORoot,GRef "RTN","TMGXMLE2",663,0) new Range,FIRST,LAST "RTN","TMGXMLE2",664,0) new SubFile,SRoot,CRoot "RTN","TMGXMLE2",665,0) new SubRec,VAL2,Label "RTN","TMGXMLE2",666,0) new FileNum "RTN","TMGXMLE2",667,0) new IncIndent set IncIndent=" " "RTN","TMGXMLE2",668,0) if $data(Fields)<10 set Fields("*")="" "RTN","TMGXMLE2",669,0) new AllFields set AllFields=($data(Fields("*"))>0) "RTN","TMGXMLE2",670,0) new OrdFields,OrdIndex set OrdFields=0,OrdIndex=0 "RTN","TMGXMLE2",671,0) if $order(Fields("ORDER"))>1 set AllFields=0,OrdFields=1 "RTN","TMGXMLE2",672,0) "RTN","TMGXMLE2",673,0) new LastFileName "RTN","TMGXMLE2",674,0) "RTN","TMGXMLE2",675,0) set FileNum=+$get(File) "RTN","TMGXMLE2",676,0) if FileNum=0 set FileNum=$$GetFileNum^TMGDBAPI(.File) "RTN","TMGXMLE2",677,0) if FileNum=0 do goto WRDone "RTN","TMGXMLE2",678,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") "RTN","TMGXMLE2",679,0) "RTN","TMGXMLE2",680,0) if $get(IENS)="" set IENS=IEN_"," "RTN","TMGXMLE2",681,0) "RTN","TMGXMLE2",682,0) set Field=0 "RTN","TMGXMLE2",683,0) set LastFileName=Field "RTN","TMGXMLE2",684,0) "RTN","TMGXMLE2",685,0) ;"Ensure all text exclusion fields are converted to numeric ones. "RTN","TMGXMLE2",686,0) if $data(Fields("Field Exclude"))>0 do "RTN","TMGXMLE2",687,0) . new field "RTN","TMGXMLE2",688,0) . set field=$order(Fields("Field Exclude","")) "RTN","TMGXMLE2",689,0) . if field'="" for do quit:(field="") "RTN","TMGXMLE2",690,0) . . if +field'=field do "RTN","TMGXMLE2",691,0) . . . new tempField "RTN","TMGXMLE2",692,0) . . . set tempField=$$GetNumField^TMGDBAPI(FileNum,field) "RTN","TMGXMLE2",693,0) . . . set Fields("Field Exclude",tempField)="" "RTN","TMGXMLE2",694,0) . . set field=$order(Fields("Field Exclude",field)) "RTN","TMGXMLE2",695,0) "RTN","TMGXMLE2",696,0) ;"Ensure all custom tag field names are converted to numeric ones. "RTN","TMGXMLE2",697,0) if $data(Fields("TAG NAME"))>0 do "RTN","TMGXMLE2",698,0) . new field "RTN","TMGXMLE2",699,0) . set field=$order(Fields("TAG NAME","")) "RTN","TMGXMLE2",700,0) . if field'="" for do quit:(field="") "RTN","TMGXMLE2",701,0) . . if +field'=field do "RTN","TMGXMLE2",702,0) . . . new tempField "RTN","TMGXMLE2",703,0) . . . set tempField=$$GetNumField^TMGDBAPI(FileNum,field) "RTN","TMGXMLE2",704,0) . . . set Fields("TAG NAME",tempField)=Fields("TAG NAME",field) "RTN","TMGXMLE2",705,0) . . set field=$order(Fields("TAG NAME",field)) "RTN","TMGXMLE2",706,0) "RTN","TMGXMLE2",707,0) ;"Ensure all custom TRANSFORM field names are converted to numeric ones. "RTN","TMGXMLE2",708,0) if $data(Fields("TRANSFORM"))>0 do "RTN","TMGXMLE2",709,0) . new field "RTN","TMGXMLE2",710,0) . set field=$order(Fields("TRANSFORM","")) "RTN","TMGXMLE2",711,0) . if field'="" for do quit:(field="") "RTN","TMGXMLE2",712,0) . . if +field'=field do "RTN","TMGXMLE2",713,0) . . . new tempField "RTN","TMGXMLE2",714,0) . . . set tempField=$$GetNumField^TMGDBAPI(FileNum,field) "RTN","TMGXMLE2",715,0) . . . set Fields("TRANSFORM",tempField)=Fields("TRANSFORM",field) "RTN","TMGXMLE2",716,0) . . set field=$order(Fields("TRANSFORM",field)) "RTN","TMGXMLE2",717,0) "RTN","TMGXMLE2",718,0) ;"NOTE: It is ineffecient to call a function for each field. That requires "RTN","TMGXMLE2",719,0) ;" the field function to call $$GET1^DIQ. A more effecient way would "RTN","TMGXMLE2",720,0) ;" be to call GETS^DIQ to get ALL the field's values at once, and then "RTN","TMGXMLE2",721,0) ;" pass the value to the field function. FIX LATER... "RTN","TMGXMLE2",722,0) "RTN","TMGXMLE2",723,0) for do quit:(+Field'>0) "RTN","TMGXMLE2",724,0) . if AllFields do "RTN","TMGXMLE2",725,0) . . set Field=$order(^DD(FileNum,Field)) "RTN","TMGXMLE2",726,0) . else if OrdFields do quit:(Field="") "RTN","TMGXMLE2",727,0) . . set OrdIndex=$order(Fields("ORDER",OrdIndex)) "RTN","TMGXMLE2",728,0) . . set Field=$get(Fields("ORDER",OrdIndex)) "RTN","TMGXMLE2",729,0) . else do quit:(+Field'>0) "RTN","TMGXMLE2",730,0) . . set Field=$order(Fields(LastFileName)) "RTN","TMGXMLE2",731,0) . set LastFileName=Field "RTN","TMGXMLE2",732,0) . if +Field=0 set Field=$$GetNumField^TMGDBAPI(FileNum,Field) "RTN","TMGXMLE2",733,0) . if $data(Fields("Field Exclude",Field))>0 quit "RTN","TMGXMLE2",734,0) . if +Field=0 quit "RTN","TMGXMLE2",735,0) . do Write1Fld(FileNum,IEN,Field,.Fields,.Flags,.SRef,.IENS,.IndentS,.RWriter,.FWriter,.LWriter,.WPLWriter,.SavFieldInfo) "RTN","TMGXMLE2",736,0) "RTN","TMGXMLE2",737,0) WRDone "RTN","TMGXMLE2",738,0) quit "RTN","TMGXMLE2",739,0) "RTN","TMGXMLE2",740,0) "RTN","TMGXMLE2",741,0) Write1Fld(FileNum,IEN,Field,Fields,Flags,SRef,IENS,IndentS,RWriter,FWriter,LWriter,WPLWriter,SavFieldInfo) "RTN","TMGXMLE2",742,0) ;"Scope: PUBLIC "RTN","TMGXMLE2",743,0) ;"Purpose: To dump one field out in XML format "RTN","TMGXMLE2",744,0) ;"Input: FileNum -- number of file containing field "RTN","TMGXMLE2",745,0) ;" IEN -- Record number (IEN) to dump (see also IENS below). Ignored if IENS supplied "RTN","TMGXMLE2",746,0) ;" Field -- The field number to write from array below. "RTN","TMGXMLE2",747,0) ;" Fields -- The field to write. "RTN","TMGXMLE2",748,0) ;" Flags -- OPTIONAL "RTN","TMGXMLE2",749,0) ;" b -- show tags for fields, even if field has no data "RTN","TMGXMLE2",750,0) ;" i -- indent tags for pretty, but technically useless, file formating. "RTN","TMGXMLE2",751,0) ;" I -- output INTERNAL values "RTN","TMGXMLE2",752,0) ;" SRef -- OPTIONAL (Used only when calling self recursively) "RTN","TMGXMLE2",753,0) ;" IENS -- OPTIONAL a standard IENS string "RTN","TMGXMLE2",754,0) ;" e.g. "IEN,parent-IEN,grandparent-IEN," etc. "RTN","TMGXMLE2",755,0) ;" This is used when calling self recursively, to handle subfiles "RTN","TMGXMLE2",756,0) ;" Late Note: if IENS is supplied, then IEN is ignored "RTN","TMGXMLE2",757,0) ;" IndentS -- OPTIONAL -- current string to write to indent line. "RTN","TMGXMLE2",758,0) ;" RWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",759,0) ;" actual starting and ending <record> </record>. e.g. "RTN","TMGXMLE2",760,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",761,0) ;" as custom function must accept same parameters as WriteRLabel "RTN","TMGXMLE2",762,0) ;" FWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",763,0) ;" actual line of text out. e.g. "WriteFLabel" or "RTN","TMGXMLE2",764,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",765,0) ;" as custom function must accept same parameters as WriteFLabel "RTN","TMGXMLE2",766,0) ;" LWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",767,0) ;" actual line of text out for WP fields. e.g. "WriteLine" or "RTN","TMGXMLE2",768,0) ;" "MyCustomFn". Note do NOT include parameters. Function named "RTN","TMGXMLE2",769,0) ;" as custom function must accept same parameters as WriteLine "RTN","TMGXMLE2",770,0) ;" WPLWriter -- OPTIONAL -- the name of a custom function to use for writing "RTN","TMGXMLE2",771,0) ;" actual line of text out for WP fields. If not provided, then "RTN","TMGXMLE2",772,0) ;" LWriter will be used instead. "RTN","TMGXMLE2",773,0) ;" e.g. "WriteWPLine" or "MyWPCustomFn". Note do NOT include parameters. "RTN","TMGXMLE2",774,0) ;" Function named as custom function must accept same parameters as WriteLine "RTN","TMGXMLE2",775,0) ;" SavFieldInfo -- OPTIONAL -- PASS BY REFERENCE. An array to hold lookup values about "RTN","TMGXMLE2",776,0) ;" fields, so it doesn't have to be done each time (faster) "RTN","TMGXMLE2",777,0) ;"Output: Values are written to the current device "RTN","TMGXMLE2",778,0) ;"Results: None "RTN","TMGXMLE2",779,0) ;"Note: this code began its life as a function written by Greg Woodhouse (thanks Greg!) "RTN","TMGXMLE2",780,0) "RTN","TMGXMLE2",781,0) new FldType,Label "RTN","TMGXMLE2",782,0) new FieldInfo "RTN","TMGXMLE2",783,0) "RTN","TMGXMLE2",784,0) if $get(IENS)="" set IENS=IEN_"," "RTN","TMGXMLE2",785,0) if +$get(Field)=0 goto W1FDone "RTN","TMGXMLE2",786,0) set FWriter=$get(FWriter,"WriteFLabel") "RTN","TMGXMLE2",787,0) set RWriter=$get(RWriter,"WriteRLabel") "RTN","TMGXMLE2",788,0) set LWriter=$get(LWriter,"WriteLine") "RTN","TMGXMLE2",789,0) set WPLWriter=$get(WPLWriter,LWriter) "RTN","TMGXMLE2",790,0) set Flags=$get(Flags) "RTN","TMGXMLE2",791,0) "RTN","TMGXMLE2",792,0) if 1=1 do "RTN","TMGXMLE2",793,0) . if $data(SavFieldInfo(FileNum,Field))>0 do "RTN","TMGXMLE2",794,0) . . merge FieldInfo=SavFieldInfo(FileNum,Field) "RTN","TMGXMLE2",795,0) . else do "RTN","TMGXMLE2",796,0) . . do GetFieldInfo^TMGDBAPI(FileNum,Field,"FieldInfo","LABEL") "RTN","TMGXMLE2",797,0) . . merge SavFieldInfo(FileNum,Field)=FieldInfo "RTN","TMGXMLE2",798,0) else if 1=0 do "RTN","TMGXMLE2",799,0) . ;"try to get info directly to speed things up.... FINISH LATER "RTN","TMGXMLE2",800,0) . new node set node=$get(^DD(FileNum,Field,0)) "RTN","TMGXMLE2",801,0) . set FieldInfo("SPECIFIER")=$piece(node,"^",2) "RTN","TMGXMLE2",802,0) . set FieldInfo("LABEL")=$piece(node,"^",1) "RTN","TMGXMLE2",803,0) . set FieldInfo("MULTIPLE-VALUED")=(+FieldInfo("SPECIFIER")>0) "RTN","TMGXMLE2",804,0) . if FieldInfo("SPECIFIER")["W" set FieldInfo("TYPE")="WORD-PROCESSING" "RTN","TMGXMLE2",805,0) . else if FieldInfo("SPECIFIER")["D" set FieldInfo("TYPE")="DATE" "RTN","TMGXMLE2",806,0) . else if FieldInfo("SPECIFIER")["F" set FieldInfo("TYPE")="FREE TEXT" "RTN","TMGXMLE2",807,0) . else if FieldInfo("SPECIFIER")["P" set FieldInfo("TYPE")="POINTER" "RTN","TMGXMLE2",808,0) . else if FieldInfo("SPECIFIER")["N" set FieldInfo("TYPE")="NUMERIC" "RTN","TMGXMLE2",809,0) . else if FieldInfo("SPECIFIER")["S" set FieldInfo("TYPE")="SET" "RTN","TMGXMLE2",810,0) . else set FieldInfo("TYPE")=FieldInfo("SPECIFIER") "RTN","TMGXMLE2",811,0) "RTN","TMGXMLE2",812,0) set FldType=FieldInfo("SPECIFIER") "RTN","TMGXMLE2",813,0) if $data(Fields("TAG NAME",Field))#10>1 set Label=Fields("TAG NAME",Field) "RTN","TMGXMLE2",814,0) else set Label=FieldInfo("LABEL") "RTN","TMGXMLE2",815,0) "RTN","TMGXMLE2",816,0) if $get(FieldInfo("MULTIPLE-VALUED"))=1 do "RTN","TMGXMLE2",817,0) . if $get(FieldInfo("TYPE"))="WORD-PROCESSING" do "RTN","TMGXMLE2",818,0) . . new TMGWP,TMGMsg,result "RTN","TMGXMLE2",819,0) . . set result=$$ReadWP^TMGDBAPI(FileNum,IENS,Field,.TMGWP) "RTN","TMGXMLE2",820,0) . . if result=1 do "RTN","TMGXMLE2",821,0) . . . new i set i=$order(TMGWP("")) "RTN","TMGXMLE2",822,0) . . . if i="" quit "RTN","TMGXMLE2",823,0) . . . if Flags["i" write $get(IndentS) "RTN","TMGXMLE2",824,0) . . . new exFn set exFn="do "_FWriter_"(Label,"""_$$QtProtect^TMGSTUTL(Field)_""","""_FieldInfo("TYPE")_""",0)" "RTN","TMGXMLE2",825,0) . . . xecute exFn "RTN","TMGXMLE2",826,0) . . . write ! ;"so first <LINE> will be on a separate line "RTN","TMGXMLE2",827,0) . . . for do quit:(i="") "RTN","TMGXMLE2",828,0) . . . . new line set line=$get(TMGWP(i)) "RTN","TMGXMLE2",829,0) . . . . if Flags["i" write $get(IndentS)_IncIndent "RTN","TMGXMLE2",830,0) . . . . if "RTN","TMGXMLE2",831,0) . . . . set exFn="do "_WPLWriter_"("""_$$QtProtect^TMGSTUTL(line)_""")" "RTN","TMGXMLE2",832,0) . . . . xecute exFn "RTN","TMGXMLE2",833,0) . . . . set i=$order(TMGWP(i)) "RTN","TMGXMLE2",834,0) . . . if Flags["i" write $get(IndentS) "RTN","TMGXMLE2",835,0) . . . set exFn="do "_FWriter_"(Label,"""_$$QtProtect^TMGSTUTL(Field)_""","""_FieldInfo("TYPE")_""",1)" "RTN","TMGXMLE2",836,0) . . . xecute exFn "RTN","TMGXMLE2",837,0) . else do ;"Other multiple (subfile) "RTN","TMGXMLE2",838,0) . . set SubFile=+FldType "RTN","TMGXMLE2",839,0) . . new AllSubRecs,tempField "RTN","TMGXMLE2",840,0) . . new ORoot,Node "RTN","TMGXMLE2",841,0) . . if $get(SRef)'="" set ORoot=SRef "RTN","TMGXMLE2",842,0) . . else set ORoot=$get(^DIC(FileNum,0,"GL")) "RTN","TMGXMLE2",843,0) . . if ORoot="" quit "RTN","TMGXMLE2",844,0) . . if AllFields set tempField="*" "RTN","TMGXMLE2",845,0) . . else set tempField=LastFileName "RTN","TMGXMLE2",846,0) . . set AllSubRecs=($data(Fields(tempField,"*"))>0)!($order(Fields(tempField,""))="") "RTN","TMGXMLE2",847,0) . . set Node=$piece($get(FieldInfo("StoreLoc")),";",1) "RTN","TMGXMLE2",848,0) . . if Node="" quit ;"skip computed fields "RTN","TMGXMLE2",849,0) . . if (+Node'=Node) set Node=""""_Node_"""" ;" enclose text indices with quotes "RTN","TMGXMLE2",850,0) . . set SRoot=ORoot_IEN_","_Node_"," ;"open root "RTN","TMGXMLE2",851,0) . . set CRoot=ORoot_IEN_","_Node_")" ;"closed root "RTN","TMGXMLE2",852,0) . . set SubRec=$order(@CRoot@(0)) "RTN","TMGXMLE2",853,0) . . if (SubRec'="")!(Flags["b") do "RTN","TMGXMLE2",854,0) . . . if Flags["i" write $get(IndentS) "RTN","TMGXMLE2",855,0) . . . new exFn set exFn="do "_FWriter_"("""_$$QtProtect^TMGSTUTL(Label)_""","""_$$QtProtect^TMGSTUTL(Field)_""","""_FieldInfo("TYPE")_""",0)" "RTN","TMGXMLE2",856,0) . . . xecute exFn "RTN","TMGXMLE2",857,0) . . . write ! "RTN","TMGXMLE2",858,0) . . . new IndS2 set IndS2=$get(IndentS)_IncIndent "RTN","TMGXMLE2",859,0) . . . if +SubRec>0 for do quit:+SubRec'>0 "RTN","TMGXMLE2",860,0) . . . . ;"descend into subfile (if allowed subrecord #) "RTN","TMGXMLE2",861,0) . . . . if (AllSubRecs)!($data(Fields(tempField,SubRec))>0) do "RTN","TMGXMLE2",862,0) . . . . . if $data(Fields(tempField,"Rec Exclude",SubRec))>0 quit "RTN","TMGXMLE2",863,0) . . . . . new SubIENS,SubFields,tempSR "RTN","TMGXMLE2",864,0) . . . . . if AllSubRecs set tempSR="*" "RTN","TMGXMLE2",865,0) . . . . . else set tempSR=SubRec "RTN","TMGXMLE2",866,0) . . . . . set SubIENS=SubRec_","_IENS "RTN","TMGXMLE2",867,0) . . . . . merge SubFields=Fields(tempField,tempSR) "RTN","TMGXMLE2",868,0) . . . . . if (AllFields)!($data(SubFields)=0) set SubFields("*")="" "RTN","TMGXMLE2",869,0) . . . . . if Flags["i" write $get(IndS2) "RTN","TMGXMLE2",870,0) . . . . . new exFn set exFn="do "_RWriter_"("_$$QtProtect^TMGSTUTL(SubRec)_",0)" "RTN","TMGXMLE2",871,0) . . . . . xecute exFn "RTN","TMGXMLE2",872,0) . . . . . do Write1Rec(SubFile,SubRec,.SubFields,Flags,SRoot,SubIENS,IndS2_IncIndent,.RWriter,.FWriter,.LWriter,.WPLWriter,.SavFieldInfo) "RTN","TMGXMLE2",873,0) . . . . . if Flags["i" write $get(IndS2) "RTN","TMGXMLE2",874,0) . . . . . new exFn set exFn="do "_RWriter_"("_$$QtProtect^TMGSTUTL(SubRec)_",1)" "RTN","TMGXMLE2",875,0) . . . . . xecute exFn "RTN","TMGXMLE2",876,0) . . . . set SubRec=$order(@CRoot@(SubRec)) "RTN","TMGXMLE2",877,0) . . . if Flags["i" write $get(IndentS) "RTN","TMGXMLE2",878,0) . . . set exFn="do "_FWriter_"("""_$$QtProtect^TMGSTUTL(Label)_""","""_$$QtProtect^TMGSTUTL(Field)_""","""_FieldInfo("TYPE")_""",1)" "RTN","TMGXMLE2",879,0) . . . xecute exFn "RTN","TMGXMLE2",880,0) else do ;"the usual case here... "RTN","TMGXMLE2",881,0) . new line set line="" "RTN","TMGXMLE2",882,0) . new CustXForm set CustXForm=$get(Fields("TRANSFORM",Field)) "RTN","TMGXMLE2",883,0) . if CustXForm'="" do "RTN","TMGXMLE2",884,0) . . new Pos,GRef,Node "RTN","TMGXMLE2",885,0) . . new FILE,FIELD,X,Y "RTN","TMGXMLE2",886,0) . . new IntValue set IntValue="" "RTN","TMGXMLE2",887,0) . . if $get(SRef)'="" set ORoot=SRef "RTN","TMGXMLE2",888,0) . . else set ORoot=$get(^DIC(FileNum,0,"GL")) "RTN","TMGXMLE2",889,0) . . if ORoot="" quit "RTN","TMGXMLE2",890,0) . . set Node=$piece($get(FieldInfo("StoreLoc")),";",1) "RTN","TMGXMLE2",891,0) . . if Node="" quit ;"skip computed fields "RTN","TMGXMLE2",892,0) . . if (+Node'=Node) set Node=""""_Node_"""" ;" enclose text indices with quotes "RTN","TMGXMLE2",893,0) . . set Pos=$piece($get(FieldInfo("StoreLoc")),";",2) "RTN","TMGXMLE2",894,0) . . set GRef=ORoot_IEN_","_Node_")" "RTN","TMGXMLE2",895,0) . . if +Pos>0 set IntValue=$piece($get(@GRef),"^",Pos) "RTN","TMGXMLE2",896,0) . . ;"Set up variables for use by transform code "RTN","TMGXMLE2",897,0) . . set FILE=FileNum "RTN","TMGXMLE2",898,0) . . set FIELD=+Field "RTN","TMGXMLE2",899,0) . . set X=IntValue "RTN","TMGXMLE2",900,0) . . set Y="" "RTN","TMGXMLE2",901,0) . . new $etrap set $etrap="set Y=""(Invalid custom transform M code!. Error Trapped.)"" set $etrap="""",$ecode=""""" "RTN","TMGXMLE2",902,0) . . xecute CustXForm "RTN","TMGXMLE2",903,0) . . set line=Y "RTN","TMGXMLE2",904,0) . else do "RTN","TMGXMLE2",905,0) . . new GetFlag set GetFlag="" "RTN","TMGXMLE2",906,0) . . if Flags["I" set GetFlag="I" "RTN","TMGXMLE2",907,0) . . set line=$$GET1^DIQ(FileNum,IENS,Field,GetFlag) "RTN","TMGXMLE2",908,0) . if (line="")&(Flags'["b") quit "RTN","TMGXMLE2",909,0) . if Flags["i" write $get(IndentS) "RTN","TMGXMLE2",910,0) . new exFn set exFn="do "_FWriter_"("""_$$QtProtect^TMGSTUTL(Label)_""","""_$$QtProtect^TMGSTUTL(Field)_""","""_FieldInfo("TYPE")_""",0)" "RTN","TMGXMLE2",911,0) . xecute exFn "RTN","TMGXMLE2",912,0) . set exFn="do "_LWriter_"(.line)" "RTN","TMGXMLE2",913,0) . xecute exFn ;"write line "RTN","TMGXMLE2",914,0) . if Flags["i" write $get(IndentS) "RTN","TMGXMLE2",915,0) . set exFn="do "_FWriter_"("""_$$QtProtect^TMGSTUTL(Label)_""","""_$$QtProtect^TMGSTUTL(Field)_""","""_FieldInfo("TYPE")_""",1)" "RTN","TMGXMLE2",916,0) . xecute exFn "RTN","TMGXMLE2",917,0) "RTN","TMGXMLE2",918,0) W1FDone "RTN","TMGXMLE2",919,0) quit "RTN","TMGXMLE2",920,0) "RTN","TMGXMLE2",921,0) "RTN","TMGXMLE2",922,0) "RTN","TMGXMLE2",923,0) WriteRLabel(IEN,Ender) "RTN","TMGXMLE2",924,0) ;"Purpose: To actually write out labels for record starting and ending. "RTN","TMGXMLE2",925,0) ;" IEN -- the IEN (record number) of the record "RTN","TMGXMLE2",926,0) ;" Optional extra informat: "RTN","TMGXMLE2",927,0) ;" IEN(tag)=value "RTN","TMGXMLE2",928,0) ;" IEN(tag2)=value2 "RTN","TMGXMLE2",929,0) ;" If provided, will be added to output as follows: "RTN","TMGXMLE2",930,0) ;" <Record id="IEN" tag="value" tag2="value2"> "RTN","TMGXMLE2",931,0) ;" Ender -- OPTIONAL if 1, then ends field. "RTN","TMGXMLE2",932,0) ;"Results: none. "RTN","TMGXMLE2",933,0) ;"Note: This is a separate function so that a different callback function can replace it "RTN","TMGXMLE2",934,0) "RTN","TMGXMLE2",935,0) if +$get(Ender)>0 write "</Record>",! "RTN","TMGXMLE2",936,0) else do "RTN","TMGXMLE2",937,0) . write "<Record id=""",IEN,""" " "RTN","TMGXMLE2",938,0) . new tag set tag="" "RTN","TMGXMLE2",939,0) . for set tag=$order(IEN(tag)) quit:(tag="") do "RTN","TMGXMLE2",940,0) . . write tag,"=""",$get(IEN(tag)),""" " "RTN","TMGXMLE2",941,0) . write ">",! "RTN","TMGXMLE2",942,0) "RTN","TMGXMLE2",943,0) quit "RTN","TMGXMLE2",944,0) "RTN","TMGXMLE2",945,0) WriteFLabel(Label,Field,Type,Ender) "RTN","TMGXMLE2",946,0) ;"Purpose: This is the code that actually does writing of labels etc for output "RTN","TMGXMLE2",947,0) ;"Input: Label -- OPTIONAL -- Name of label, to write after 'label=' "RTN","TMGXMLE2",948,0) ;" Field -- OPTIONAL -- Name of field, to write after 'id=' "RTN","TMGXMLE2",949,0) ;" Type -- OPTIONAL -- Typeof field, to write after 'type=' "RTN","TMGXMLE2",950,0) ;" Ender -- OPTIONAL if 1, then ends field. "RTN","TMGXMLE2",951,0) ;"Results: none. "RTN","TMGXMLE2",952,0) ;"Note: This is a separate function so that a different callback function can replace it "RTN","TMGXMLE2",953,0) "RTN","TMGXMLE2",954,0) ;"To write out <Field label="NAME" id=".01" type="FREE TEXT"> or </Field> "RTN","TMGXMLE2",955,0) "RTN","TMGXMLE2",956,0) if +$get(Ender)>0 do "RTN","TMGXMLE2",957,0) . write "</Field>",! "RTN","TMGXMLE2",958,0) else do "RTN","TMGXMLE2",959,0) . write "<Field " "RTN","TMGXMLE2",960,0) . if $get(Field)'="" write "id=""",$$SYMENC^MXMLUTL(Field),""" " "RTN","TMGXMLE2",961,0) . if $get(Label)'="" write "label=""",$$SYMENC^MXMLUTL(Label),""" " "RTN","TMGXMLE2",962,0) . if $get(Type)'="" write "type=""",$$SYMENC^MXMLUTL(Type),""" " "RTN","TMGXMLE2",963,0) . write ">" "RTN","TMGXMLE2",964,0) "RTN","TMGXMLE2",965,0) quit "RTN","TMGXMLE2",966,0) "RTN","TMGXMLE2",967,0) WriteLine(Line) "RTN","TMGXMLE2",968,0) ;"Purpose: This is the code that actually does writing of labels etc for output "RTN","TMGXMLE2",969,0) ;"Input: Line -- the line of text to write out. "RTN","TMGXMLE2",970,0) ;"Results: none "RTN","TMGXMLE2",971,0) ;"Note: This is a separate function so that a different callback function can replace it "RTN","TMGXMLE2",972,0) "RTN","TMGXMLE2",973,0) set Line=$$SYMENC^MXMLUTL(Line) "RTN","TMGXMLE2",974,0) write "<LINE>",Line,"</LINE>",! "RTN","TMGXMLE2",975,0) quit "RTN","TMGXMLE2",976,0) "RTN","TMGXMLE2",977,0) "RTN","TMGXMLE2",978,0) ConvertLabel(Label) "RTN","TMGXMLE2",979,0) ;"Note: This function is no longer being used... "RTN","TMGXMLE2",980,0) "RTN","TMGXMLE2",981,0) ;"To convert the XML tag into an acceptible format for XML "RTN","TMGXMLE2",982,0) ;" "RTN","TMGXMLE2",983,0) new i "RTN","TMGXMLE2",984,0) new result set result="" "RTN","TMGXMLE2",985,0) "RTN","TMGXMLE2",986,0) for i=1:1:$length(Label) do "RTN","TMGXMLE2",987,0) . new ch set ch=$ascii($extract(Label,i)) "RTN","TMGXMLE2",988,0) . if ((ch>64)&(ch<91))!((ch>96)&(ch<123)) do quit "RTN","TMGXMLE2",989,0) . . set result=result_$char(ch) "RTN","TMGXMLE2",990,0) . if (ch=32) set result=result_"_" "RTN","TMGXMLE2",991,0) . else do "RTN","TMGXMLE2",992,0) . . set result=result_"x" "RTN","TMGXMLE2",993,0) "RTN","TMGXMLE2",994,0) quit result "RTN","TMGXMLE2",995,0) "RTN","TMGXMLEX") 0^104^B11237 "RTN","TMGXMLEX",1,0) TMGXMLEX ;TMG/kst/XML Exporter ;03/25/06 "RTN","TMGXMLEX",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGXMLEX",3,0) "RTN","TMGXMLEX",4,0) ;"TMG XML EXPORT FUNCTION "RTN","TMGXMLEX",5,0) ;"Kevin Toppenberg MD "RTN","TMGXMLEX",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGXMLEX",7,0) ;"7-12-2005 "RTN","TMGXMLEX",8,0) "RTN","TMGXMLEX",9,0) ;"======================================================================= "RTN","TMGXMLEX",10,0) ;" API -- Public Functions. "RTN","TMGXMLEX",11,0) ;"======================================================================= "RTN","TMGXMLEX",12,0) "RTN","TMGXMLEX",13,0) ;"======================================================================= "RTN","TMGXMLEX",14,0) ;"PRIVATE API FUNCTIONS "RTN","TMGXMLEX",15,0) ;"======================================================================= "RTN","TMGXMLEX",16,0) "RTN","TMGXMLEX",17,0) ;"======================================================================= "RTN","TMGXMLEX",18,0) ;"Dependencies (duplicates shown in parenthesies) "RTN","TMGXMLEX",19,0) ;"TMGXMLUI "RTN","TMGXMLEX",20,0) ;"--XLFSTR "RTN","TMGXMLEX",21,0) ;"--TMGDBAPI "RTN","TMGXMLEX",22,0) ;"----TMGDEBUG "RTN","TMGXMLEX",23,0) ;"------TMGUSRIF "RTN","TMGXMLEX",24,0) ;"--------(TMGDEBUG) "RTN","TMGXMLEX",25,0) ;"--------TMGSTUTL "RTN","TMGXMLEX",26,0) ;"----------(TMGDEBUG) "RTN","TMGXMLEX",27,0) ;"--------TMGXDLG "RTN","TMGXMLEX",28,0) ;"----(TMGUSRIF) "RTN","TMGXMLEX",29,0) ;"----(TMGSTUTL) "RTN","TMGXMLEX",30,0) ;"--(TMGDEBUG) "RTN","TMGXMLEX",31,0) ;"-- TMGMISC "RTN","TMGXMLEX",32,0) ;"----(TMGDBAPI) "RTN","TMGXMLEX",33,0) ;"----TMGIOUTL "RTN","TMGXMLEX",34,0) ;"----(TMGDEBUG) "RTN","TMGXMLEX",35,0) ;"----(TMGSTUTL) "RTN","TMGXMLEX",36,0) ;"TMGXMLE2 "RTN","TMGXMLEX",37,0) ;"--(TMGDBAPI) "RTN","TMGXMLEX",38,0) ;"--(TMGDEBUG) "RTN","TMGXMLEX",39,0) ;"--(TMGMISC) "RTN","TMGXMLEX",40,0) ;"--(TMGUSRIF) "RTN","TMGXMLEX",41,0) ;"TMGIOUTL "RTN","TMGXMLEX",42,0) ;"--(TMGUSRIF) "RTN","TMGXMLEX",43,0) ;"--(TMGDEBUG) "RTN","TMGXMLEX",44,0) ;"--(TMGSTUTL) "RTN","TMGXMLEX",45,0) ;"--(TMGMISC) "RTN","TMGXMLEX",46,0) "RTN","TMGXMLEX",47,0) "RTN","TMGXMLEX",48,0) ;"TMGDEBUG "RTN","TMGXMLEX",49,0) ;"======================================================================= "RTN","TMGXMLEX",50,0) ;"======================================================================= "RTN","TMGXMLEX",51,0) "RTN","TMGXMLEX",52,0) "RTN","TMGXMLEX",53,0) EXPORT "RTN","TMGXMLEX",54,0) ;"Purpose: To ask for parameters, select output, and do actual export "RTN","TMGXMLEX",55,0) "RTN","TMGXMLEX",56,0) new XMLarray "RTN","TMGXMLEX",57,0) new pArray set pArray=$name(XMLarray) "RTN","TMGXMLEX",58,0) new fileName,PriorErrorFound "RTN","TMGXMLEX",59,0) "RTN","TMGXMLEX",60,0) if $$UI^TMGXMLUI(pArray)=0 goto ExDone "RTN","TMGXMLEX",61,0) "RTN","TMGXMLEX",62,0) if (1=0) do if fileName="" do goto ExDone "RTN","TMGXMLEX",63,0) . write "Please select an output file for the XML export",! "RTN","TMGXMLEX",64,0) . set fileName=$$GetFName^TMGIOUTL() "RTN","TMGXMLEX",65,0) . ;"Here I need to select IO channel "RTN","TMGXMLEX",66,0) . if fileName="" quit "RTN","TMGXMLEX",67,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"No file selected, so aborting.") "RTN","TMGXMLEX",68,0) . set %ZIS("HFSNAME")=fileName "RTN","TMGXMLEX",69,0) . set %ZIS="Q" ;"queing allowed "RTN","TMGXMLEX",70,0) . set %ZIS("HFSMODE")="W" ;"write mode "RTN","TMGXMLEX",71,0) . set IOP="HFS" "RTN","TMGXMLEX",72,0) else do "RTN","TMGXMLEX",73,0) . write "Select device to output XML data to.",! "RTN","TMGXMLEX",74,0) . write "HFS (i.e. Host File System) will allow output to a file.",! "RTN","TMGXMLEX",75,0) . write "(A file name will be asked after HFS is chosen)." "RTN","TMGXMLEX",76,0) . set %ZIS("A")="Enter Output Device: " "RTN","TMGXMLEX",77,0) . set %ZIS("B")="HFS" "RTN","TMGXMLEX",78,0) "RTN","TMGXMLEX",79,0) do ^%ZIS ;"standard device call "RTN","TMGXMLEX",80,0) if POP do goto ExDone "RTN","TMGXMLEX",81,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output file. Aborting.") "RTN","TMGXMLEX",82,0) use IO "RTN","TMGXMLEX",83,0) "RTN","TMGXMLEX",84,0) do WriteXMLData^TMGXMLE2(pArray,,,1) "RTN","TMGXMLEX",85,0) do ^%ZISC ;" Close the output device "RTN","TMGXMLEX",86,0) "RTN","TMGXMLEX",87,0) write !,"(Data written to ouput file)",! "RTN","TMGXMLEX",88,0) "RTN","TMGXMLEX",89,0) ExDone "RTN","TMGXMLEX",90,0) kill TMGXDEBUG "RTN","TMGXMLEX",91,0) write !,"Leaving XML Exporter. Goodbye.",! "RTN","TMGXMLEX",92,0) quit "RTN","TMGXMLUI") 0^105^B8350 "RTN","TMGXMLUI",1,0) TMGXMLUI ;TMG/kst/XML Exporter -- User Interface ;03/25/06 "RTN","TMGXMLUI",2,0) ;;1.0;TMG-LIB;**1**;07/12/05 "RTN","TMGXMLUI",3,0) "RTN","TMGXMLUI",4,0) ;"TMG XML EXPORT -- USER INTERFACE FUNCTIONS "RTN","TMGXMLUI",5,0) ;"Kevin Toppenberg MD "RTN","TMGXMLUI",6,0) ;"GNU General Public License (GPL) applies "RTN","TMGXMLUI",7,0) ;"7-12-2005 "RTN","TMGXMLUI",8,0) "RTN","TMGXMLUI",9,0) ;"======================================================================= "RTN","TMGXMLUI",10,0) ;" API -- Public Functions. "RTN","TMGXMLUI",11,0) ;"======================================================================= "RTN","TMGXMLUI",12,0) ;"UI "RTN","TMGXMLUI",13,0) "RTN","TMGXMLUI",14,0) ;"======================================================================= "RTN","TMGXMLUI",15,0) ;"PRIVATE API FUNCTIONS "RTN","TMGXMLUI",16,0) ;"======================================================================= "RTN","TMGXMLUI",17,0) ;"Welcome() "RTN","TMGXMLUI",18,0) ;"ProcessFile(pArray,indent) "RTN","TMGXMLUI",19,0) ;"GetRecs(File,pRecs,indent) "RTN","TMGXMLUI",20,0) ;"GetTemplateRecs(File,pRecs,s) "RTN","TMGXMLUI",21,0) ;"GetManualRecs(File,pRecs,s) "RTN","TMGXMLUI",22,0) ;"GetFields(File,pArray,indent) "RTN","TMGXMLUI",23,0) ;"GetManFields(File,pArray,s) "RTN","TMGXMLUI",24,0) ;"AskCustomTag(File,field,pArray,indent) "RTN","TMGXMLUI",25,0) ;"AskCustTransform(File,field,pArray,indent) "RTN","TMGXMLUI",26,0) ;"$$FMGetField(FileNumber) "RTN","TMGXMLUI",27,0) ;"$$AskGetField(FileNumber,indent) "RTN","TMGXMLUI",28,0) ;"$$PickUnselField(FileNumber,pArray,indent) "RTN","TMGXMLUI",29,0) ;"CfgOrderFields(File,pArray) "RTN","TMGXMLUI",30,0) ;"ShowArray(indent) "RTN","TMGXMLUI",31,0) ;"Pause "RTN","TMGXMLUI",32,0) ;"WriteHeader(pHeader) "RTN","TMGXMLUI",33,0) ;"HdrAddLine(pHeader,Line) "RTN","TMGXMLUI",34,0) ;"HdrDelLine(pHeader,index) "RTN","TMGXMLUI",35,0) ;"Spaces(Num) "RTN","TMGXMLUI",36,0) "RTN","TMGXMLUI",37,0) ;"======================================================================= "RTN","TMGXMLUI",38,0) ;"Dependencies "RTN","TMGXMLUI",39,0) ;"XLFSTR "RTN","TMGXMLUI",40,0) ;"TMGDBAPI, TMGDEBUG, TMGMISC "RTN","TMGXMLUI",41,0) ;"======================================================================= "RTN","TMGXMLUI",42,0) ;"======================================================================= "RTN","TMGXMLUI",43,0) "RTN","TMGXMLUI",44,0) "RTN","TMGXMLUI",45,0) UI(pArray) "RTN","TMGXMLUI",46,0) ;"Purpose: To create a User Interface (UI) for creating array needed to "RTN","TMGXMLUI",47,0) ;" export XML data from Fileman. "RTN","TMGXMLUI",48,0) ;"Input: pArray -- pointer to (i.e. name of) array to put data into "RTN","TMGXMLUI",49,0) ;"Output: values will be put into pArray. See TMGXMLEX for format "RTN","TMGXMLUI",50,0) ;"Result: 1 if OK to continue, 0 if error or abort "RTN","TMGXMLUI",51,0) "RTN","TMGXMLUI",52,0) new result set result=1 "RTN","TMGXMLUI",53,0) "RTN","TMGXMLUI",54,0) if $data(IOF)=0 do goto UIDone "RTN","TMGXMLUI",55,0) . write "This function requires the VistA environment to be setup first.",! "RTN","TMGXMLUI",56,0) . write "Terminating. This may be achieved via DO ^XUP, then dropping",! "RTN","TMGXMLUI",57,0) . write "back to the command line and trying to run this again.",! "RTN","TMGXMLUI",58,0) . set result=0 "RTN","TMGXMLUI",59,0) "RTN","TMGXMLUI",60,0) new done set done=0 "RTN","TMGXMLUI",61,0) new HeaderArray "RTN","TMGXMLUI",62,0) new pHeader set pHeader="HeaderArray" "RTN","TMGXMLUI",63,0) set pArray=$get(pArray,"TMGArray") "RTN","TMGXMLUI",64,0) new TMGxmlArray set TMGxmlArray=pArray "RTN","TMGXMLUI",65,0) new indent set indent=0 "RTN","TMGXMLUI",66,0) new TabInc set TabInc=5 "RTN","TMGXMLUI",67,0) "RTN","TMGXMLUI",68,0) do HdrAddLine(pHeader," XML Export Assistant.") "RTN","TMGXMLUI",69,0) do HdrAddLine(pHeader,"=========================") "RTN","TMGXMLUI",70,0) "RTN","TMGXMLUI",71,0) set result=$$Welcome "RTN","TMGXMLUI",72,0) if result=0 goto UIDone "RTN","TMGXMLUI",73,0) set result=$$ProcessFile(pArray,indent+TabInc) "RTN","TMGXMLUI",74,0) if result=0 goto UIDone "RTN","TMGXMLUI",75,0) "RTN","TMGXMLUI",76,0) UIDone "RTN","TMGXMLUI",77,0) quit result "RTN","TMGXMLUI",78,0) "RTN","TMGXMLUI",79,0) "RTN","TMGXMLUI",80,0) Welcome() "RTN","TMGXMLUI",81,0) ;"Purpose: Decribe the wizard "RTN","TMGXMLUI",82,0) ;"Input: none "RTN","TMGXMLUI",83,0) ;"Result: 1 if OK to continue. 0 if user abort requested. "RTN","TMGXMLUI",84,0) ;"Note: uses global pHeader "RTN","TMGXMLUI",85,0) "RTN","TMGXMLUI",86,0) new result set result=1 "RTN","TMGXMLUI",87,0) do WriteHeader(pHeader) "RTN","TMGXMLUI",88,0) write "Welcome. I'll walk you through the process",! "RTN","TMGXMLUI",89,0) write "of choosing the data you wish to export to an ",! "RTN","TMGXMLUI",90,0) write "XML file.",!! "RTN","TMGXMLUI",91,0) write "Overview of planned steps:",! "RTN","TMGXMLUI",92,0) write "Step 1. Pick 1st Fileman file to export.",! "RTN","TMGXMLUI",93,0) write "Step 2. Pick records in file to export.",! "RTN","TMGXMLUI",94,0) write "Step 3. Pick fields in records to export.",! "RTN","TMGXMLUI",95,0) write "Step 4. Pick 2nd Fileman file to export.",! "RTN","TMGXMLUI",96,0) write " ... repeat cycle until done.",!! "RTN","TMGXMLUI",97,0) write "To back out, enter '^' at any prompt.",!! "RTN","TMGXMLUI",98,0) WcLoop "RTN","TMGXMLUI",99,0) write "Are you ready to begin? (Y/N/^) YES//" "RTN","TMGXMLUI",100,0) new input "RTN","TMGXMLUI",101,0) read input:$get(DTIME,3600),! "RTN","TMGXMLUI",102,0) if $TEST=0 set input="N" "RTN","TMGXMLUI",103,0) if input="" set input="Y" "RTN","TMGXMLUI",104,0) set input=$$UP^XLFSTR(input) "RTN","TMGXMLUI",105,0) if (input'["Y")!(input["^") do goto WcmDone "RTN","TMGXMLUI",106,0) . ;"write "Goodbye.",! "RTN","TMGXMLUI",107,0) . set result=0 "RTN","TMGXMLUI",108,0) if (input["?") do goto WcLoop "RTN","TMGXMLUI",109,0) . write " Enter Y or YES to continue.",! "RTN","TMGXMLUI",110,0) . write " Enter N or No or ^ to exit.",!! "RTN","TMGXMLUI",111,0) . do Pause() "RTN","TMGXMLUI",112,0) "RTN","TMGXMLUI",113,0) WcmDone "RTN","TMGXMLUI",114,0) quit result "RTN","TMGXMLUI",115,0) "RTN","TMGXMLUI",116,0) "RTN","TMGXMLUI",117,0) ProcessFile(pArray,indent) "RTN","TMGXMLUI",118,0) ;"Purpose: To add export options for one file, or edit previous choices "RTN","TMGXMLUI",119,0) ;"Input: pArray -- pointer to (i.e. name of) array to fill with info. "RTN","TMGXMLUI",120,0) ;" indent -- amount to indent from left margin "RTN","TMGXMLUI",121,0) ;"Output: Array will be filled with data in appropriate format (See docs in TMGXMLEX.m) "RTN","TMGXMLUI",122,0) ;"Result: 1 if OK to continue, 0 if aborted "RTN","TMGXMLUI",123,0) ;"note: uses global variable pHeader,TabInc "RTN","TMGXMLUI",124,0) "RTN","TMGXMLUI",125,0) new DIC,File "RTN","TMGXMLUI",126,0) new Y set Y=0 "RTN","TMGXMLUI",127,0) new ref "RTN","TMGXMLUI",128,0) new result set result=1 "RTN","TMGXMLUI",129,0) new Records "RTN","TMGXMLUI",130,0) if $get(pArray)="" set result=0 goto SUFDone "RTN","TMGXMLUI",131,0) "RTN","TMGXMLUI",132,0) do HdrAddLine(pHeader,$$Spaces(indent)_"Step 1. Pick a FILE for export to XML.") "RTN","TMGXMLUI",133,0) "RTN","TMGXMLUI",134,0) new Another set Another=0 "RTN","TMGXMLUI",135,0) for do quit:(+Y'>0)!(result=0) "RTN","TMGXMLUI",136,0) . do WriteHeader(pHeader,1) "RTN","TMGXMLUI",137,0) . if Another do quit:(result=0)!(Y'>0) "RTN","TMGXMLUI",138,0) . . write !,?indent,"Add another file for export? (Y/N/^) NO//" "RTN","TMGXMLUI",139,0) . . new input read input:$get(DTIME,3600),! "RTN","TMGXMLUI",140,0) . . if input="^" set Y=0,result=0 quit "RTN","TMGXMLUI",141,0) . . if input="" set input="N" "RTN","TMGXMLUI",142,0) . . set input=$$UP^XLFSTR(input) "RTN","TMGXMLUI",143,0) . . if input'["Y" set Y=0 quit ;"signal to quit "RTN","TMGXMLUI",144,0) . . set Y=1 "RTN","TMGXMLUI",145,0) . set DIC=1 "RTN","TMGXMLUI",146,0) . set DIC(0)="AEQ" "RTN","TMGXMLUI",147,0) . set DIC("A")=$$Spaces(indent)_"Enter Fileman file for XML export (^ to quit): ^// " "RTN","TMGXMLUI",148,0) . do ^DIC "RTN","TMGXMLUI",149,0) . write ! "RTN","TMGXMLUI",150,0) . set File=+Y "RTN","TMGXMLUI",151,0) . if File'>0 set result=0 quit "RTN","TMGXMLUI",152,0) . set ref=$name(@pArray@(File)) "RTN","TMGXMLUI",153,0) . if $$GetRecs(File,ref,indent)=0 set Y=0,result=0 quit "RTN","TMGXMLUI",154,0) . set Another=1 "RTN","TMGXMLUI",155,0) "RTN","TMGXMLUI",156,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",157,0) "RTN","TMGXMLUI",158,0) if result=0 goto SUFDone "RTN","TMGXMLUI",159,0) "RTN","TMGXMLUI",160,0) write !,?indent,"Also export pointed-to records (Y/N/^) YES// " "RTN","TMGXMLUI",161,0) new input read input:$get(DTIME,3600),! "RTN","TMGXMLUI",162,0) if input="^" set result=0 goto SUFDone "RTN","TMGXMLUI",163,0) if input="" set input="Y" "RTN","TMGXMLUI",164,0) set input=$$UP^XLFSTR(input) "RTN","TMGXMLUI",165,0) if input["Y" do "RTN","TMGXMLUI",166,0) . do ExpandPtrs(pArray) "RTN","TMGXMLUI",167,0) "RTN","TMGXMLUI",168,0) set result=$$AskFlags(pArray,indent) "RTN","TMGXMLUI",169,0) SUFDone "RTN","TMGXMLUI",170,0) quit result "RTN","TMGXMLUI",171,0) "RTN","TMGXMLUI",172,0) "RTN","TMGXMLUI",173,0) AskFlags(pArray,indent) "RTN","TMGXMLUI",174,0) ;"Purpose: To ask user if various flags are desired "RTN","TMGXMLUI",175,0) ;"Input: pArray -- pointer to (i.e. name of) array to put data into "RTN","TMGXMLUI",176,0) ;" indent -- amount to indent from left margin "RTN","TMGXMLUI",177,0) ;"Note: uses global variable pHeader "RTN","TMGXMLUI",178,0) ;"Result: 1 if OK to continue, 0 if aborted "RTN","TMGXMLUI",179,0) "RTN","TMGXMLUI",180,0) new input "RTN","TMGXMLUI",181,0) set indent=$get(indent,0) "RTN","TMGXMLUI",182,0) new result set result=1 "RTN","TMGXMLUI",183,0) if $get(pArray)="" set result=0 goto AFlgDone "RTN","TMGXMLUI",184,0) new defLabel set defLabel="TMG_VISTA_XML_EXPORT" "RTN","TMGXMLUI",185,0) "RTN","TMGXMLUI",186,0) new SysName,Y "RTN","TMGXMLUI",187,0) set SysName=$get(^TMG("XML EXPORTER","EXPORT_SYSTEM_NAME")) "RTN","TMGXMLUI",188,0) if SysName="" do "RTN","TMGXMLUI",189,0) . do GETENV^%ZOSV "RTN","TMGXMLUI",190,0) . set SysName=$piece(Y,"^",4) "RTN","TMGXMLUI",191,0) set @pArray@("EXPORT_SYSTEM_NAME")=SysName "RTN","TMGXMLUI",192,0) "RTN","TMGXMLUI",193,0) do WriteHeader(pHeader) "RTN","TMGXMLUI",194,0) "RTN","TMGXMLUI",195,0) write ?indent,"Formatting Options:",! "RTN","TMGXMLUI",196,0) write ?indent,"----------------------",!! "RTN","TMGXMLUI",197,0) "RTN","TMGXMLUI",198,0) write ?indent,"Use Default export settings? (Y/N,^) YES// " "RTN","TMGXMLUI",199,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",200,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",201,0) if input="" set input="Y" "RTN","TMGXMLUI",202,0) if "YesyesYES"[input do goto AFlgDone "RTN","TMGXMLUI",203,0) . set @pArray@("FLAGS","i")="" ;"<-- default value of indenting "RTN","TMGXMLUI",204,0) . set @pArray@("!DOCTYPE")=defLabel "RTN","TMGXMLUI",205,0) . new SysName,Y "RTN","TMGXMLUI",206,0) . set SysName=$get(^TMG("XML EXPORTER","EXPORT_SYSTEM_NAME")) "RTN","TMGXMLUI",207,0) "RTN","TMGXMLUI",208,0) write ?indent,"During export to XML file, do you want empty fields to be",! "RTN","TMGXMLUI",209,0) write ?indent,"reported (vs. no data --> tag not written)? (Y/N,^) NO// " "RTN","TMGXMLUI",210,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",211,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",212,0) if input="" set input="N" "RTN","TMGXMLUI",213,0) if "YesyesYES"[input do "RTN","TMGXMLUI",214,0) . set @pArray@("FLAGS","b")="" "RTN","TMGXMLUI",215,0) "RTN","TMGXMLUI",216,0) write ?indent,"Do you want the XML file to have entries indented for visual",! "RTN","TMGXMLUI",217,0) write ?indent,"organization? This will have no meaning to another program",! "RTN","TMGXMLUI",218,0) write ?indent,"importing the XML file, but is easier for humans to read it ",! "RTN","TMGXMLUI",219,0) write ?indent,"this way. Indent entries? (Y/N,^) YES// " "RTN","TMGXMLUI",220,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",221,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",222,0) if input="" set input="Y" "RTN","TMGXMLUI",223,0) if "YesyesYES"[input do "RTN","TMGXMLUI",224,0) . set @pArray@("FLAGS","i")="" "RTN","TMGXMLUI",225,0) "RTN","TMGXMLUI",226,0) write ?indent,"Do you want the exported entries to be INTERNAL Fileman values?",! "RTN","TMGXMLUI",227,0) write ?indent,"Export INTERNAL entries? (Y/N,^) NO// " "RTN","TMGXMLUI",228,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",229,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",230,0) if input="" set input="N" "RTN","TMGXMLUI",231,0) if "YesyesYES"[input do "RTN","TMGXMLUI",232,0) . set @pArray@("FLAGS","I")="" "RTN","TMGXMLUI",233,0) "RTN","TMGXMLUI",234,0) write ?indent,"Do you want the export the Fileman data dictionary? (Y/N,^) NO// " "RTN","TMGXMLUI",235,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",236,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",237,0) if input="" set input="N" "RTN","TMGXMLUI",238,0) if "YesyesYES"[input do "RTN","TMGXMLUI",239,0) . set @pArray@("FLAGS","D")="" "RTN","TMGXMLUI",240,0) "RTN","TMGXMLUI",241,0) write ?indent,"Output export settings? (Y/N,^) YES// " "RTN","TMGXMLUI",242,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",243,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",244,0) if input="" set input="Y" "RTN","TMGXMLUI",245,0) if "YesyesYES"[input do "RTN","TMGXMLUI",246,0) . set @pArray@("FLAGS","S")="" "RTN","TMGXMLUI",247,0) "RTN","TMGXMLUI",248,0) new defLabel set defLabel="TMG_VISTA_XML_EXPORT" "RTN","TMGXMLUI",249,0) write ?indent,"Use default XML !DOCTYPE '"_defLabel_"' label? (Y/N,^) YES// " "RTN","TMGXMLUI",250,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",251,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",252,0) if input="" set input="Y" "RTN","TMGXMLUI",253,0) if "YesyesYES"[input do "RTN","TMGXMLUI",254,0) . set @pArray@("!DOCTYPE")=defLabel "RTN","TMGXMLUI",255,0) else do goto:(result=0) AFlgDone "RTN","TMGXMLUI",256,0) . write ?indent,"Specify a *custom* XML !DOCTYPE label? (Y/N,^) NO// " "RTN","TMGXMLUI",257,0) . read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",258,0) . if input="^" set result=0 quit "RTN","TMGXMLUI",259,0) . if input="" set input="Y" "RTN","TMGXMLUI",260,0) . if "YesyesYES"[input do "RTN","TMGXMLUI",261,0) . . write "Enter label for <!DOCTYPE YourInputGoesHere>",! "RTN","TMGXMLUI",262,0) . . write "Enter Label: //" "RTN","TMGXMLUI",263,0) . . read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",264,0) . . if input="^" set result=0 quit "RTN","TMGXMLUI",265,0) . . if input'="" set @pArray@("!DOCTYPE")=input "RTN","TMGXMLUI",266,0) "RTN","TMGXMLUI",267,0) write ?indent,"Enter a name for this VistA installation. ",SysName,"// " "RTN","TMGXMLUI",268,0) read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",269,0) if input="^" set result=0 goto AFlgDone "RTN","TMGXMLUI",270,0) if input="" set input=SysName "RTN","TMGXMLUI",271,0) set SysName=input "RTN","TMGXMLUI",272,0) set ^TMG("XML EXPORTER","EXPORT_SYSTEM_NAME")=SysName "RTN","TMGXMLUI",273,0) set @pArray@("EXPORT_SYSTEM_NAME")=SysName "RTN","TMGXMLUI",274,0) "RTN","TMGXMLUI",275,0) AFlgDone "RTN","TMGXMLUI",276,0) quit result "RTN","TMGXMLUI",277,0) "RTN","TMGXMLUI",278,0) "RTN","TMGXMLUI",279,0) ;"NOTE: I need to notice if File has already been set (i.e. user choosing file a second time "RTN","TMGXMLUI",280,0) ;" If so give option to erase old choices and choose again "RTN","TMGXMLUI",281,0) GetRecs(File,pRecs,indent) "RTN","TMGXMLUI",282,0) ;"Purpose: For a given file, allow selection of records to export. "RTN","TMGXMLUI",283,0) ;"Input: File -- the File (name or number) to select from. "RTN","TMGXMLUI",284,0) ;" pRec -- Pointer to (i.e. name of) array to fill with records nums "RTN","TMGXMLUI",285,0) ;" indent -- a value to indent from left margin "RTN","TMGXMLUI",286,0) ;"Result: 1 if OK to continue, 0 if user aborted. "RTN","TMGXMLUI",287,0) ;"Note: uses global variable pHeader,TabInc "RTN","TMGXMLUI",288,0) "RTN","TMGXMLUI",289,0) new result set result=1 "RTN","TMGXMLUI",290,0) new input set input="" "RTN","TMGXMLUI",291,0) new FileNumber,FileName "RTN","TMGXMLUI",292,0) if ($get(File)="")!($get(pRecs)="") set result=0 goto GRDone "RTN","TMGXMLUI",293,0) new defValue set defValue="X" "RTN","TMGXMLUI",294,0) "RTN","TMGXMLUI",295,0) if +File=File do "RTN","TMGXMLUI",296,0) . set FileNumber=File "RTN","TMGXMLUI",297,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",298,0) else do "RTN","TMGXMLUI",299,0) . set FileName=File "RTN","TMGXMLUI",300,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",301,0) "RTN","TMGXMLUI",302,0) do HdrAddLine(pHeader,$$Spaces(indent)_"Step 2. Which RECORDS to export from file "_FileName_"?") "RTN","TMGXMLUI",303,0) "RTN","TMGXMLUI",304,0) for do quit:(input="^")!(result=0) "RTN","TMGXMLUI",305,0) . do WriteHeader(pHeader) "RTN","TMGXMLUI",306,0) . write ?indent,"1. Export ALL records (exclusions allowed).",! "RTN","TMGXMLUI",307,0) . write ?indent,"2. Select a Search/Sort TEMPLATE to specify records.",! "RTN","TMGXMLUI",308,0) . write ?indent,"3. Select SPECIFIC records",! "RTN","TMGXMLUI",309,0) . write ?indent,"4. Select records to EXCLUDE",! "RTN","TMGXMLUI",310,0) . write ?indent,"5. View selections so far.",! "RTN","TMGXMLUI",311,0) . write ?indent,"X. Done here.",!! "RTN","TMGXMLUI",312,0) . write ?indent,"Select option (1-5 or X or ? or ^): "_defValue_"// " "RTN","TMGXMLUI",313,0) . read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",314,0) . if $TEST=0 set input="^" "RTN","TMGXMLUI",315,0) . if input="" set input=defValue "RTN","TMGXMLUI",316,0) . if ("Xx"[input) do quit "RTN","TMGXMLUI",317,0) . . if $data(@pRecs)'>1 do quit:(input="") "RTN","TMGXMLUI",318,0) . . . write ?indent,"NOTE: No records were chosen for export in file: ",FileName,! "RTN","TMGXMLUI",319,0) . . . write ?indent,"This means that nothing will be exported to the XML file.",!! "RTN","TMGXMLUI",320,0) . . . write ?indent,"Do you still want to stop selecting records? (Y,N,^) NO// " "RTN","TMGXMLUI",321,0) . . . new Done read Done:$get(DTIME,3600),! "RTN","TMGXMLUI",322,0) . . . if $TEST=0 set Done="^" "RTN","TMGXMLUI",323,0) . . . if (Done="")!("NOnoNo"[Done) set input="" "RTN","TMGXMLUI",324,0) . . set input="^" "RTN","TMGXMLUI",325,0) . if input="^" set result=0 quit "RTN","TMGXMLUI",326,0) . if (input>0)&(input<6) set defValue=input "RTN","TMGXMLUI",327,0) . if input="?" do quit "RTN","TMGXMLUI",328,0) . . write ! "RTN","TMGXMLUI",329,0) . . write ?indent," Enter '1' if you wish to export ALL records in this file.",! "RTN","TMGXMLUI",330,0) . . write ?indent," You can still specify records to exclude after this option.",! "RTN","TMGXMLUI",331,0) . . write ?indent," Enter '2' if you wish to use a pre-existing Search/Sort TEMPLATE",! "RTN","TMGXMLUI",332,0) . . write ?indent," to select files. A Search/Sort TEMPLATE can be generated",! "RTN","TMGXMLUI",333,0) . . write ?indent," through the Fileman Search function.",! "RTN","TMGXMLUI",334,0) . . write ?indent," Enter '3' if you know the record nubmers (IEN values) for the",! "RTN","TMGXMLUI",335,0) . . write ?indent," records you wish to export, and want to enter them",! "RTN","TMGXMLUI",336,0) . . write ?indent," manually.",! "RTN","TMGXMLUI",337,0) . . write ?indent," Enter '4' if you have records to EXCLUDE. If a record is excluded,",! "RTN","TMGXMLUI",338,0) . . write ?indent," then it will NOT be output, even if it was specified ",! "RTN","TMGXMLUI",339,0) . . write ?indent," manually or was included from a Search/Sort TEMPLATE.",! "RTN","TMGXMLUI",340,0) . . write ?indent," Enter '5' to view array containing settings so far.",! "RTN","TMGXMLUI",341,0) . . write ?indent," Enter 'X' to exit..",! "RTN","TMGXMLUI",342,0) . . write ?indent," Enter '^' to abort entire process.",! "RTN","TMGXMLUI",343,0) . . do Pause(indent) "RTN","TMGXMLUI",344,0) . if input=1 do "RTN","TMGXMLUI",345,0) . . set @pRecs@("*")="" "RTN","TMGXMLUI",346,0) . . write ?indent,"OK. Will export all records in file: ",FileName,".",! "RTN","TMGXMLUI",347,0) . . set defValue="X" "RTN","TMGXMLUI",348,0) . . do Pause(indent) "RTN","TMGXMLUI",349,0) . if input=2 set result=$$GetTemplateRecs(File,pRecs,"for INCLUSION ",indent+TabInc) set defValue="X" "RTN","TMGXMLUI",350,0) . if input=3 set result=$$GetManualRecs(File,pRecs,"for INCLUSION ",indent+TabInc) set defValue="X" "RTN","TMGXMLUI",351,0) . if input=4 set result=$$GetExclRecs(File,pRecs,indent+TabInc) set defValue="X" "RTN","TMGXMLUI",352,0) . if input=5 do ShowArray(indent) "RTN","TMGXMLUI",353,0) "RTN","TMGXMLUI",354,0) GRDone "RTN","TMGXMLUI",355,0) if $data(@pRecs)'>1 do "RTN","TMGXMLUI",356,0) . write ?indent,"NOTE: No records were chosen. Aborting.",! "RTN","TMGXMLUI",357,0) . set result=0 "RTN","TMGXMLUI",358,0) else do "RTN","TMGXMLUI",359,0) . write ?indent,"Done chosing records...",! "RTN","TMGXMLUI",360,0) "RTN","TMGXMLUI",361,0) write ?indent,"Now on to picking FIELDS to export.",! "RTN","TMGXMLUI",362,0) do Pause(indent) "RTN","TMGXMLUI",363,0) if $$GetFields(File,ref,indent)=0 set Y=0,result=0 "RTN","TMGXMLUI",364,0) write ! "RTN","TMGXMLUI",365,0) "RTN","TMGXMLUI",366,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",367,0) "RTN","TMGXMLUI",368,0) quit result "RTN","TMGXMLUI",369,0) "RTN","TMGXMLUI",370,0) "RTN","TMGXMLUI",371,0) GetExclRecs(File,pRecs,indent) "RTN","TMGXMLUI",372,0) ;"Purpose: to allow user to enter records to exclude "RTN","TMGXMLUI",373,0) ;"Input: File -- the File (name or number) to select from. "RTN","TMGXMLUI",374,0) ;" pRec -- Pointer to (i.e. name of) array to fill with records nums "RTN","TMGXMLUI",375,0) ;" indent -- a value to indent from left margin "RTN","TMGXMLUI",376,0) ;"Result: 1 if OK to continue, 0 if user aborted. "RTN","TMGXMLUI",377,0) ;"Note: uses global variable pHeader,TabInc "RTN","TMGXMLUI",378,0) "RTN","TMGXMLUI",379,0) new result set result=1 "RTN","TMGXMLUI",380,0) new FileNumber,FileName "RTN","TMGXMLUI",381,0) new input set input="" "RTN","TMGXMLUI",382,0) if ($get(File)="")!($get(pRecs)="") set result=0 goto GRDone "RTN","TMGXMLUI",383,0) new defValue set defValue="X" "RTN","TMGXMLUI",384,0) "RTN","TMGXMLUI",385,0) if +File=File do "RTN","TMGXMLUI",386,0) . set FileNumber=File "RTN","TMGXMLUI",387,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",388,0) else do "RTN","TMGXMLUI",389,0) . set FileName=File "RTN","TMGXMLUI",390,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",391,0) set indent=+$get(indent,0) "RTN","TMGXMLUI",392,0) "RTN","TMGXMLUI",393,0) do HdrAddLine(pHeader,$$Spaces(indent)_"To EXCLUDE records in file "_FileName_", choose:") "RTN","TMGXMLUI",394,0) "RTN","TMGXMLUI",395,0) for do quit:(input="")!(result=0) "RTN","TMGXMLUI",396,0) . new ExRecs,i "RTN","TMGXMLUI",397,0) . do WriteHeader(pHeader) "RTN","TMGXMLUI",398,0) . write ?indent,"1. Select a Search/Sort TEMPLATE to specify records to EXCLUDE.",! "RTN","TMGXMLUI",399,0) . write ?indent,"2. Select SPECIFIC record numbers to EXCLUDE.",! "RTN","TMGXMLUI",400,0) . write ?indent,"3. View all the records excluded so far.",! "RTN","TMGXMLUI",401,0) . write ?indent,"X. Done here.",!! "RTN","TMGXMLUI",402,0) . write ?indent,"Select option (1-3 or X or ? or ^) "_defValue_"// " "RTN","TMGXMLUI",403,0) . read input:$get(DTIME,3600),! "RTN","TMGXMLUI",404,0) . if $TEST=0 set input="^" "RTN","TMGXMLUI",405,0) . if input="" set input=defValue "RTN","TMGXMLUI",406,0) . if ("Xx"[input) set input="" "RTN","TMGXMLUI",407,0) . if input="^" set result=0 quit "RTN","TMGXMLUI",408,0) . if (input>0)&(input<4) set defValue=input "RTN","TMGXMLUI",409,0) . if input="?" do "RTN","TMGXMLUI",410,0) . . write !,?indent," By excluding just certain records, you can export every record",! "RTN","TMGXMLUI",411,0) . . write ?indent," EXCEPT those you specify.",! "RTN","TMGXMLUI",412,0) . . do Pause(indent) "RTN","TMGXMLUI",413,0) . if input=1 do "RTN","TMGXMLUI",414,0) . . new pArray set pArray=$name(@pRecs@("Rec Exclude")) "RTN","TMGXMLUI",415,0) . . set result=$$GetTemplateRecs(File,pArray,"for EXCLUSION ",indent+TabInc) "RTN","TMGXMLUI",416,0) . if input=2 do "RTN","TMGXMLUI",417,0) . . new pArray set pArray=$name(@pRecs@("Rec Exclude")) "RTN","TMGXMLUI",418,0) . . set result=$$GetManualRecs(File,pArray,"for EXCLUSION ",indent+TabInc) "RTN","TMGXMLUI",419,0) . if input=3 do ShowArray(indent) "RTN","TMGXMLUI",420,0) "RTN","TMGXMLUI",421,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",422,0) "RTN","TMGXMLUI",423,0) GERDone "RTN","TMGXMLUI",424,0) quit result "RTN","TMGXMLUI",425,0) "RTN","TMGXMLUI",426,0) "RTN","TMGXMLUI",427,0) GetTemplateRecs(File,pRecs,s,indent) "RTN","TMGXMLUI",428,0) ;"Purpose: to ask user for a search/sort template to inport records from "RTN","TMGXMLUI",429,0) ;"Input -- File -- the file name or number to work with "RTN","TMGXMLUI",430,0) ;" pRecs -- pointer to (i.e. name of) array to fill "RTN","TMGXMLUI",431,0) ;" will probably be passed with "Array(12345)" "RTN","TMGXMLUI",432,0) ;" s -- OPTIONAL -- e.g. "for INCLUSION " or "for EXCLUSION " -- part of title. "RTN","TMGXMLUI",433,0) ;" indent -- OPTIONAL -- a value to indent from left margin "RTN","TMGXMLUI",434,0) ;"Output: Data is put into pRecs like this: "RTN","TMGXMLUI",435,0) ;" @pRecs@(IEN1)="" "RTN","TMGXMLUI",436,0) ;" @pRecs@(IEN2)="" "RTN","TMGXMLUI",437,0) ;" @pRecs@(IEN3)="" "RTN","TMGXMLUI",438,0) ;"Result: 1 if OK to continue, 0 if user aborted. "RTN","TMGXMLUI",439,0) ;"Note: uses global variable pHeader (if available) "RTN","TMGXMLUI",440,0) "RTN","TMGXMLUI",441,0) new FileNumber,FileName,Y "RTN","TMGXMLUI",442,0) if ($get(File)="")!($get(pRecs)="") goto GTRDone "RTN","TMGXMLUI",443,0) new tempH set pHeader=$get(pHeader,"tempH") "RTN","TMGXMLUI",444,0) new result set result=1 "RTN","TMGXMLUI",445,0) "RTN","TMGXMLUI",446,0) if +File=File do "RTN","TMGXMLUI",447,0) . set FileNumber=File "RTN","TMGXMLUI",448,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",449,0) else do "RTN","TMGXMLUI",450,0) . set FileName=File "RTN","TMGXMLUI",451,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",452,0) if FileNumber'>0 do goto GTRDone "RTN","TMGXMLUI",453,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") "RTN","TMGXMLUI",454,0) . set result=0 "RTN","TMGXMLUI",455,0) "RTN","TMGXMLUI",456,0) set indent=+$get(indent,0) "RTN","TMGXMLUI",457,0) "RTN","TMGXMLUI",458,0) do HdrAddLine(pHeader,$$Spaces(indent)_"Select records for export from a Template") "RTN","TMGXMLUI",459,0) "RTN","TMGXMLUI",460,0) for do quit:((+Y>0)!(+Y=-1)) "RTN","TMGXMLUI",461,0) . do WriteHeader(pHeader) "RTN","TMGXMLUI",462,0) . new DIC "RTN","TMGXMLUI",463,0) . set DIC=.401 "RTN","TMGXMLUI",464,0) . set DIC(0)="AEQ" "RTN","TMGXMLUI",465,0) . write $$Spaces(indent)_"Select a Template containing records for import. ",! "RTN","TMGXMLUI",466,0) . write $$Spaces(indent)_"(? for list, ^ to quit) " "RTN","TMGXMLUI",467,0) . set DIC("A")=$$Spaces(indent)_"Enter Template: " "RTN","TMGXMLUI",468,0) . set DIC("S")="IF $P($G(^DIBT(+Y,0)),""^"",4)="_FileNumber ;"screen for Templates by file "RTN","TMGXMLUI",469,0) . do ^DIC "RTN","TMGXMLUI",470,0) . write ! "RTN","TMGXMLUI",471,0) . if +Y'>0 quit ;"set result=0 "RTN","TMGXMLUI",472,0) . new node set node=$get(^DIBT(+Y,0)) "RTN","TMGXMLUI",473,0) . if $piece(node,"^",4)'=FileNumber do quit "RTN","TMGXMLUI",474,0) . . set Y=0 ;"signal to try again "RTN","TMGXMLUI",475,0) . . new PriorErrorFound "RTN","TMGXMLUI",476,0) . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: That template doesn't contain records from "_File_". Please select another.") "RTN","TMGXMLUI",477,0) . . do Pause(indent) "RTN","TMGXMLUI",478,0) "RTN","TMGXMLUI",479,0) if result=0 goto GTRL1 "RTN","TMGXMLUI",480,0) "RTN","TMGXMLUI",481,0) new count set count=0 "RTN","TMGXMLUI",482,0) if (+Y>0)&($data(^DIBT(+Y,1))>1) do "RTN","TMGXMLUI",483,0) . new index set index=$order(^DIBT(+Y,1,0)) "RTN","TMGXMLUI",484,0) . if index'="" for do quit:(index="") "RTN","TMGXMLUI",485,0) . . set @pRecs@(index)="" "RTN","TMGXMLUI",486,0) . . set count=count+1 "RTN","TMGXMLUI",487,0) . . set index=$order(^DIBT(+Y,1,index)) "RTN","TMGXMLUI",488,0) "RTN","TMGXMLUI",489,0) write ?indent,count," Records imported.",! "RTN","TMGXMLUI",490,0) do Pause(indent) "RTN","TMGXMLUI",491,0) "RTN","TMGXMLUI",492,0) GTRL1 "RTN","TMGXMLUI",493,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",494,0) "RTN","TMGXMLUI",495,0) GTRDone "RTN","TMGXMLUI",496,0) quit result "RTN","TMGXMLUI",497,0) "RTN","TMGXMLUI",498,0) "RTN","TMGXMLUI",499,0) GetManualRecs(File,pRecs,s,indent) "RTN","TMGXMLUI",500,0) ;"Purpose: to ask user for a series of IEN values "RTN","TMGXMLUI",501,0) ;"Input: File -- name or number, file to get IENS's for "RTN","TMGXMLUI",502,0) ;" pRecs -- a pointer to (i.e. Name of) array to put IEN's into "RTN","TMGXMLUI",503,0) ;" s -- OPTIONAL -- e.g. "for INCLUSION " or "for EXCLUSION " -- part of title. "RTN","TMGXMLUI",504,0) ;"Output: Data is put into pRecs like this: "RTN","TMGXMLUI",505,0) ;" @pRecs@(IEN1)="" "RTN","TMGXMLUI",506,0) ;" @pRecs@(IEN2)="" "RTN","TMGXMLUI",507,0) ;" @pRecs@(IEN3)="" "RTN","TMGXMLUI",508,0) ;"Result: 1 if OK to continue, 0 if user aborted. "RTN","TMGXMLUI",509,0) ;"Note: uses global variable pHeader "RTN","TMGXMLUI",510,0) "RTN","TMGXMLUI",511,0) new PriorErrorFound "RTN","TMGXMLUI",512,0) new FileNumber,FileName "RTN","TMGXMLUI",513,0) new result set result=1 "RTN","TMGXMLUI",514,0) if ($get(File)="")!($get(pRecs)="") set result=0 goto GRDone "RTN","TMGXMLUI",515,0) "RTN","TMGXMLUI",516,0) if +File=File do "RTN","TMGXMLUI",517,0) . set FileNumber=File "RTN","TMGXMLUI",518,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",519,0) else do "RTN","TMGXMLUI",520,0) . set FileName=File "RTN","TMGXMLUI",521,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",522,0) if FileNumber'>0 do goto GMRDone "RTN","TMGXMLUI",523,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") "RTN","TMGXMLUI",524,0) . do Pause(indent) "RTN","TMGXMLUI",525,0) . set result=0 "RTN","TMGXMLUI",526,0) "RTN","TMGXMLUI",527,0) new ORef "RTN","TMGXMLUI",528,0) set ORef=$get(^DIC(FileNumber,0,"GL")) "RTN","TMGXMLUI",529,0) if ORef="" do goto GRDone "RTN","TMGXMLUI",530,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Can't find global reference for file: "_FileNumber_".") "RTN","TMGXMLUI",531,0) . do Pause(indent) "RTN","TMGXMLUI",532,0) . set result=0 "RTN","TMGXMLUI",533,0) "RTN","TMGXMLUI",534,0) new defValue set defValue="X" "RTN","TMGXMLUI",535,0) "RTN","TMGXMLUI",536,0) do HdrAddLine(pHeader,$$Spaces(indent)_"Select specific record "_$get(s)_"in file "_FileName) "RTN","TMGXMLUI",537,0) "RTN","TMGXMLUI",538,0) new input "RTN","TMGXMLUI",539,0) for do quit:(input="")!(result=0) "RTN","TMGXMLUI",540,0) . do WriteHeader(pHeader) "RTN","TMGXMLUI",541,0) . write ?indent,"1. Use Fileman to find record.",! "RTN","TMGXMLUI",542,0) . write ?indent,"2. Enter record number by hand.",! "RTN","TMGXMLUI",543,0) . write ?indent,"3. View all the records selected so far.",! "RTN","TMGXMLUI",544,0) . write ?indent,"X. Done here.",! "RTN","TMGXMLUI",545,0) . write !,?indent,"Select Option (1-3 or X or ^) "_defValue_"//" "RTN","TMGXMLUI",546,0) . read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",547,0) . if $TEST=0 set input="^" "RTN","TMGXMLUI",548,0) . if input="" set input=defValue "RTN","TMGXMLUI",549,0) . if "Xx"[input set input="" quit "RTN","TMGXMLUI",550,0) . if input="^" set result=0 quit "RTN","TMGXMLUI",551,0) . if (input>0)&(input<4) set defValue=input "RTN","TMGXMLUI",552,0) . if input=1 do "RTN","TMGXMLUI",553,0) . . new DIC "RTN","TMGXMLUI",554,0) . . set DIC=File "RTN","TMGXMLUI",555,0) . . set DIC(0)="AEQ" "RTN","TMGXMLUI",556,0) . . set DIC("A")=$$Spaces(indent)_"Select record in "_FileName_" (? for list, ^ to quit): " "RTN","TMGXMLUI",557,0) . . do ^DIC "RTN","TMGXMLUI",558,0) . . write ! "RTN","TMGXMLUI",559,0) . . if +Y>0 do "RTN","TMGXMLUI",560,0) . . . write !,?indent,"O.K. You selected record number (IEN): ",+Y,! "RTN","TMGXMLUI",561,0) . . . set @pRecs@(+Y)="" "RTN","TMGXMLUI",562,0) . . . do Pause(indent) "RTN","TMGXMLUI",563,0) . . ;" else set result=0 quit "RTN","TMGXMLUI",564,0) . if input=2 do "RTN","TMGXMLUI",565,0) . . new IEN "RTN","TMGXMLUI",566,0) . . read ?indent,"Enter record number (a.k.a. IEN) (^ to abort): ",IEN:$get(DTIME,3600),! "RTN","TMGXMLUI",567,0) . . if $TEST=0 set EIN="^" "RTN","TMGXMLUI",568,0) . . if IEN="^" set result=0 quit "RTN","TMGXMLUI",569,0) . . if +IEN>0 do "RTN","TMGXMLUI",570,0) . . . new ref set ref=ORef_IEN_")" "RTN","TMGXMLUI",571,0) . . . if $data(@ref)'>0 do quit "RTN","TMGXMLUI",572,0) . . . . write ?indent,"Sorry. That record number (IEN) doesn't exist.",! "RTN","TMGXMLUI",573,0) . . . . do Pause(indent) "RTN","TMGXMLUI",574,0) . . . set @pRecs@(IEN)="" "RTN","TMGXMLUI",575,0) . . . write ?indent,"O.K. You selected record number (IEN): ",IEN,! "RTN","TMGXMLUI",576,0) . . . do Pause(indent) "RTN","TMGXMLUI",577,0) . if input=3 do ShowArray(indent) "RTN","TMGXMLUI",578,0) "RTN","TMGXMLUI",579,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",580,0) "RTN","TMGXMLUI",581,0) GMRDone "RTN","TMGXMLUI",582,0) quit result "RTN","TMGXMLUI",583,0) "RTN","TMGXMLUI",584,0) "RTN","TMGXMLUI",585,0) GetFields(File,pArray,indent) "RTN","TMGXMLUI",586,0) ;"Purpose: To query the user as to which fields to export for records "RTN","TMGXMLUI",587,0) ;"Input: File -- the File number or name to work with. "RTN","TMGXMLUI",588,0) ;" pArray -- point to (i.e. name of) Array to work with. Format discussed in TMGXMLEX.m "RTN","TMGXMLUI",589,0) ;" will likely be equal to "Array(FileNumber)" "RTN","TMGXMLUI",590,0) ;" indent -- a value to indent from left margin "RTN","TMGXMLUI",591,0) ;"Result: 1 if OK to continue. 0 if user aborted. "RTN","TMGXMLUI",592,0) ;"Note: uses global variable pHeader,TabInc "RTN","TMGXMLUI",593,0) "RTN","TMGXMLUI",594,0) new result set result=1 "RTN","TMGXMLUI",595,0) new FileNumber,FileName "RTN","TMGXMLUI",596,0) if ($get(File)="")!($get(pArray)="") set result=0 goto GRDone "RTN","TMGXMLUI",597,0) "RTN","TMGXMLUI",598,0) if +File=File do "RTN","TMGXMLUI",599,0) . set FileNumber=File "RTN","TMGXMLUI",600,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",601,0) else do "RTN","TMGXMLUI",602,0) . set FileName=File "RTN","TMGXMLUI",603,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",604,0) if FileNumber'>0 do "RTN","TMGXMLUI",605,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") "RTN","TMGXMLUI",606,0) "RTN","TMGXMLUI",607,0) do HdrAddLine(pHeader,$$Spaces(indent)_"Step 3. Which FIELDS to export from file "_FileName_"?") "RTN","TMGXMLUI",608,0) "RTN","TMGXMLUI",609,0) new defValue set defValue=1 "RTN","TMGXMLUI",610,0) new input "RTN","TMGXMLUI",611,0) for do quit:(input="")!(result=0) "RTN","TMGXMLUI",612,0) . do WriteHeader(pHeader) "RTN","TMGXMLUI",613,0) . write ?indent,"1. Export ALL fields (exclusions allowed).",! "RTN","TMGXMLUI",614,0) . write ?indent,"2. Select SPECIFIC field numbers.",! "RTN","TMGXMLUI",615,0) . write ?indent,"3. Select fields to EXCLUDE",! "RTN","TMGXMLUI",616,0) . write ?indent,"4. View selections so far.",! "RTN","TMGXMLUI",617,0) . write ?indent,"X. Done here.",!! "RTN","TMGXMLUI",618,0) . write ?indent,"Select option (1-4 or X or ? or ^): "_defValue_"// " "RTN","TMGXMLUI",619,0) . read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",620,0) . if $TEST=0 set input="^" "RTN","TMGXMLUI",621,0) . if input="" set input=defValue "RTN","TMGXMLUI",622,0) . if ("Xx"[input) set input="" "RTN","TMGXMLUI",623,0) . if input="^" set result=0 quit "RTN","TMGXMLUI",624,0) . if (input>0)&(input<5) set defValue=input "RTN","TMGXMLUI",625,0) . if input="?" do quit "RTN","TMGXMLUI",626,0) . . write ! "RTN","TMGXMLUI",627,0) . . write ?indent," Enter '1' if you wish to export ALL fields for this file.",! "RTN","TMGXMLUI",628,0) . . write ?indent," You can still specify fields to exclude after this option.",! "RTN","TMGXMLUI",629,0) . . write ?indent," Enter '2' if you know the field numbers you wish to export,",! "RTN","TMGXMLUI",630,0) . . write ?indent," and want to enter them manually.",! "RTN","TMGXMLUI",631,0) . . write ?indent," Enter '3' if you have fields to EXCLUDE. If a field is excluded,",! "RTN","TMGXMLUI",632,0) . . write ?indent," then it will NOT be output, even if it was specified manually.",! "RTN","TMGXMLUI",633,0) . . write ?indent," Enter '4' to view array containing settings so far.",! "RTN","TMGXMLUI",634,0) . . write ?indent," Enter 'X' to exit..",! "RTN","TMGXMLUI",635,0) . . write ?indent," Enter '^' to abort entire process.",! "RTN","TMGXMLUI",636,0) . . do Pause(indent) "RTN","TMGXMLUI",637,0) . if input=1 do quit "RTN","TMGXMLUI",638,0) . . set @pArray@("TEMPLATE","*")="" "RTN","TMGXMLUI",639,0) . . write ?indent,"OK. Will export all fields (and any sub-fields) in file ",FileName,".",! "RTN","TMGXMLUI",640,0) . . do Pause(indent) "RTN","TMGXMLUI",641,0) . . set defValue="X" "RTN","TMGXMLUI",642,0) . if input=2 do quit "RTN","TMGXMLUI",643,0) . . new temp set temp=$name(@pArray@("TEMPLATE")) "RTN","TMGXMLUI",644,0) . . set result=$$GetManFields(File,temp,"for INCLUSION ",indent+TabInc) "RTN","TMGXMLUI",645,0) . if input=3 do quit "RTN","TMGXMLUI",646,0) . . new temp set temp=$name(@pArray@("TEMPLATE","Field Exclude")) "RTN","TMGXMLUI",647,0) . . set result=$$GetManFields(File,temp,"for EXCLUSION ",indent+TabInc) "RTN","TMGXMLUI",648,0) . if input=4 do ShowArray(indent) "RTN","TMGXMLUI",649,0) "RTN","TMGXMLUI",650,0) write ?indent,"Done choosing FIELDS.",! "RTN","TMGXMLUI",651,0) "RTN","TMGXMLUI",652,0) new ref "RTN","TMGXMLUI",653,0) ;"set ref=$name(@pArray@(File,"TEMPLATE")) "RTN","TMGXMLUI",654,0) set ref=$name(@pArray@("TEMPLATE")) "RTN","TMGXMLUI",655,0) set result=$$CfgOrderFields(File,ref,indent) "RTN","TMGXMLUI",656,0) if result=0 set Y=0 quit "RTN","TMGXMLUI",657,0) "RTN","TMGXMLUI",658,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",659,0) quit result "RTN","TMGXMLUI",660,0) "RTN","TMGXMLUI",661,0) "RTN","TMGXMLUI",662,0) GetManFields(File,pArray,s,indent) "RTN","TMGXMLUI",663,0) ;"Purpose: to ask user for a series of field values "RTN","TMGXMLUI",664,0) ;"Input: File -- name or number, file to get field numbers for "RTN","TMGXMLUI",665,0) ;" pArray -- a pointer to (i.e. Name of) array to put field numbers into "RTN","TMGXMLUI",666,0) ;" will probably be something one of the following: "RTN","TMGXMLUI",667,0) ;" "Array(FileNumber,"TEMPLATE")" "RTN","TMGXMLUI",668,0) ;" "Array(FileNumber,"TEMPLATE","Field Exclude")" "RTN","TMGXMLUI",669,0) ;" "Array(FileNumber,RecNumber)" "RTN","TMGXMLUI",670,0) ;" s -- OPTIONAL -- e.g. "for INCLUSION " or "for EXCLUSION " -- part of title. "RTN","TMGXMLUI",671,0) ;" indend -- optional -- a value to indent from left margin "RTN","TMGXMLUI",672,0) ;"Output: Data is put into pArray "RTN","TMGXMLUI",673,0) ;"Result: 1 if OK to continue. 0 if user aborted. "RTN","TMGXMLUI",674,0) ;"Note: uses global variable pHeader,TabInc "RTN","TMGXMLUI",675,0) "RTN","TMGXMLUI",676,0) new PriorErrorFound "RTN","TMGXMLUI",677,0) new FileNumber,FileName "RTN","TMGXMLUI",678,0) new result set result=1 "RTN","TMGXMLUI",679,0) if ($get(File)="")!($get(pArray)="") set result=0 goto GRDone "RTN","TMGXMLUI",680,0) set indent=$get(indent,0) "RTN","TMGXMLUI",681,0) new defValue set defValue="X" "RTN","TMGXMLUI",682,0) "RTN","TMGXMLUI",683,0) if +File=File do "RTN","TMGXMLUI",684,0) . set FileNumber=File "RTN","TMGXMLUI",685,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",686,0) else do "RTN","TMGXMLUI",687,0) . set FileName=File "RTN","TMGXMLUI",688,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",689,0) if FileNumber'>0 do goto GRDone "RTN","TMGXMLUI",690,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") "RTN","TMGXMLUI",691,0) . set result=0 "RTN","TMGXMLUI",692,0) "RTN","TMGXMLUI",693,0) do HdrAddLine(pHeader,$$Spaces(indent)_"Which SPECIFIC FIELDS "_$get(s)_"to export?") "RTN","TMGXMLUI",694,0) "RTN","TMGXMLUI",695,0) new input "RTN","TMGXMLUI",696,0) for do quit:(input="")!(result=0) "RTN","TMGXMLUI",697,0) . new field set field=0 "RTN","TMGXMLUI",698,0) . do WriteHeader(pHeader) "RTN","TMGXMLUI",699,0) . write ?indent,"1. Select ALL fields.",! "RTN","TMGXMLUI",700,0) . write ?indent,"2. Use Fileman to find FIELD number.",! "RTN","TMGXMLUI",701,0) . write ?indent,"3. Enter FIELD by hand.",! "RTN","TMGXMLUI",702,0) . write ?indent,"4. Pick an UNSELECTED field.",! "RTN","TMGXMLUI",703,0) . write ?indent,"5. View all the FIELDS selected so far.",! "RTN","TMGXMLUI",704,0) . write ?indent,"X. Done here.",! "RTN","TMGXMLUI",705,0) . write !,?indent,"Select Option (1-5 or X or ^) ",defValue,"//" "RTN","TMGXMLUI",706,0) . read input:$get(DTIME,3600),!! "RTN","TMGXMLUI",707,0) . if $TEST=0 set input="^" "RTN","TMGXMLUI",708,0) . if input="" set input=defValue "RTN","TMGXMLUI",709,0) . if "Xx"[input set input="" quit "RTN","TMGXMLUI",710,0) . if input="^" set result=0 quit "RTN","TMGXMLUI",711,0) . if (input>0)&(input<6) set defValue=input "RTN","TMGXMLUI",712,0) . if input="5" do quit "RTN","TMGXMLUI",713,0) . . do ShowArray(indent) "RTN","TMGXMLUI",714,0) . if input="1" do "RTN","TMGXMLUI",715,0) . . write "OK All fields selected.",! "RTN","TMGXMLUI",716,0) . . set @pArray@("*")="" "RTN","TMGXMLUI",717,0) . if input="2" set field=$$FMGetField(FileNumber,indent) "RTN","TMGXMLUI",718,0) . if input="3" set field=$$AskGetField(FileNumber,indent) "RTN","TMGXMLUI",719,0) . if input="4" set field=$$PickUnselField(FileNumber,pArray,indent) "RTN","TMGXMLUI",720,0) . if field=-1 set result=0 quit "RTN","TMGXMLUI",721,0) . if field>0 do "RTN","TMGXMLUI",722,0) . . set @pArray@(field)="" "RTN","TMGXMLUI",723,0) . . if $get(s)'="for EXCLUSION " do quit:(result=0) "RTN","TMGXMLUI",724,0) . . . set result=$$AskCustomTag(FileNumber,field,pArray,indent) "RTN","TMGXMLUI",725,0) . . . if result=0 quit "RTN","TMGXMLUI",726,0) . . . set result=$$AskCustTransform(FileNumber,field,pArray,indent) "RTN","TMGXMLUI",727,0) . . . if result=0 quit "RTN","TMGXMLUI",728,0) . . ;"Now, determine if we need to do sub-fields "RTN","TMGXMLUI",729,0) . . new fieldInfo "RTN","TMGXMLUI",730,0) . . do GetFieldInfo^TMGDBAPI(FileNumber,field,"fieldInfo","LABEL") "RTN","TMGXMLUI",731,0) . . if $get(fieldInfo("MULTIPLE-VALUED"))>0 do "RTN","TMGXMLUI",732,0) . . . if $get(fieldInfo("TYPE"))="WORD PROCESSING" quit "RTN","TMGXMLUI",733,0) . . . new subFile set subFile=+$get(fieldInfo("SPECIFIER")) "RTN","TMGXMLUI",734,0) . . . if subFile=0 quit "RTN","TMGXMLUI",735,0) . . . new fieldLst if $$GetFldList^TMGDBAPI(subFile,"fieldLst")=0 quit "RTN","TMGXMLUI",736,0) . . . new subArray set subArray=$name(@pArray@(field,"TEMPLATE")) "RTN","TMGXMLUI",737,0) . . . if $$ListCt^TMGMISC("fieldLst")=1 do quit "RTN","TMGXMLUI",738,0) . . . . new subField set subField=$order(fieldLst("")) "RTN","TMGXMLUI",739,0) . . . . new subFName set subFName=$$GetFldName^TMGDBAPI(subFile,subField) "RTN","TMGXMLUI",740,0) . . . . write ?indent,"Field ",$get(fieldInfo("LABEL"))," (#",field,") has exactly 1 sub-field (",subFName,")",! "RTN","TMGXMLUI",741,0) . . . . write ?indent,"It has been automatically selected for you.",! "RTN","TMGXMLUI",742,0) . . . . set @subArray@(subField)="" "RTN","TMGXMLUI",743,0) . . . . if $get(s)'="for EXCLUSION " do quit:(result=0) "RTN","TMGXMLUI",744,0) . . . . . set result=$$AskCustomTag(subFile,subField,subArray,indent) "RTN","TMGXMLUI",745,0) . . . . . if result=0 quit "RTN","TMGXMLUI",746,0) . . . . . set result=$$AskCustTransform(subFile,subField,subArray,indent) "RTN","TMGXMLUI",747,0) . . . . . if result=0 quit "RTN","TMGXMLUI",748,0) . . . write ?indent,"Field ",$get(fieldInfo("LABEL"))," (#",field,") has sub-fields. We'll select those next.",! "RTN","TMGXMLUI",749,0) . . . do Pause(indent) "RTN","TMGXMLUI",750,0) . . . set result=$$GetManFields(subFile,subArray,s,indent+TabInc) "RTN","TMGXMLUI",751,0) . do Pause(indent) "RTN","TMGXMLUI",752,0) "RTN","TMGXMLUI",753,0) do HdrDelLine(pHeader) "RTN","TMGXMLUI",754,0) "RTN","TMGXMLUI",755,0) GMFDone "RTN","TMGXMLUI",756,0) quit result "RTN","TMGXMLUI",757,0) "RTN","TMGXMLUI",758,0) "RTN","TMGXMLUI",759,0) AskCustomTag(File,field,pArray,indent) "RTN","TMGXMLUI",760,0) ;"Purpose: Ask user if they want a custom output tag for a field "RTN","TMGXMLUI",761,0) ;"Input: FileNumber -- the name or number of the file to work with "RTN","TMGXMLUI",762,0) ;" field -- the number of the field to work with "RTN","TMGXMLUI",763,0) ;" pArray -- the array to put answer in. "RTN","TMGXMLUI",764,0) ;" value passed will probably be like this: "RTN","TMGXMLUI",765,0) ;" e.g. array(22704,"TEMPLATE") or "RTN","TMGXMLUI",766,0) ;" e.g. array(22704,"TEMPLATE",2,"TEMPLATE") "RTN","TMGXMLUI",767,0) ;" indent -- the indent value from left margin "RTN","TMGXMLUI",768,0) ;"Output: value is put in, if user wants, like this "RTN","TMGXMLUI",769,0) ;" e.g. array(22704,"TEMPLATE","TAG NAME",.01)="Custom name" "RTN","TMGXMLUI",770,0) ;" e.g. array(22704,"TEMPLATE",2,"TEMPLATE","TRANSFORM",.01)="Custom name" "RTN","TMGXMLUI",771,0) ;"Result: 1 if OK to continue. 0 if user aborted. "RTN","TMGXMLUI",772,0) "RTN","TMGXMLUI",773,0) new result set result=1 "RTN","TMGXMLUI",774,0) if (+$get(File)=0)!($get(field)="")!($get(pArray)="") set result=0 goto ACTDone "RTN","TMGXMLUI",775,0) set indent=$get(indent,0) "RTN","TMGXMLUI",776,0) "RTN","TMGXMLUI",777,0) new defTag set defTag=$get(@pArray@("TAG NAME",field)) "RTN","TMGXMLUI",778,0) if defTag="" set defTag=$$GetFldName^TMGDBAPI(File,field) "RTN","TMGXMLUI",779,0) write ?indent,"Tag name to use in XML file? ",defTag,"// " "RTN","TMGXMLUI",780,0) new tagName read tagName:$get(DTIME,3600),! "RTN","TMGXMLUI",781,0) if tagName="^" set result=0 "RTN","TMGXMLUI",782,0) if (tagName'="")&(tagName'="^") set @pArray@("TAG NAME",field)=tagName "RTN","TMGXMLUI",783,0) "RTN","TMGXMLUI",784,0) ACTDone "RTN","TMGXMLUI",785,0) quit result "RTN","TMGXMLUI",786,0) "RTN","TMGXMLUI",787,0) "RTN","TMGXMLUI",788,0) AskCustTransform(File,field,pArray,indent) "RTN","TMGXMLUI",789,0) ;"Purpose: Ask user if they want a custom output transform "RTN","TMGXMLUI",790,0) ;"Input: FileNumber -- the name or number of the file to work with "RTN","TMGXMLUI",791,0) ;" field -- the number of the field to work with "RTN","TMGXMLUI",792,0) ;" pArray -- the array to put answer in. "RTN","TMGXMLUI",793,0) ;" value passed will probably be like this: "RTN","TMGXMLUI",794,0) ;" e.g. array(22704,"TEMPLATE") or "RTN","TMGXMLUI",795,0) ;" e.g. array(22704,"TEMPLATE",2,"TEMPLATE") "RTN","TMGXMLUI",796,0) ;" indent -- the indent value from left margin "RTN","TMGXMLUI",797,0) ;"Output: value is put in, if user wants, like this "RTN","TMGXMLUI",798,0) ;" e.g. array(22704,"TEMPLATE","TRANSFORM",.01)="Custom name" "RTN","TMGXMLUI",799,0) ;" e.g. array(22704,"TEMPLATE",2,"TRANSFORM","TAG NAME",.01)="Custom name" "RTN","TMGXMLUI",800,0) ;"Result: 1 if OK to continue. 0 if user aborted. "RTN","TMGXMLUI",801,0) "RTN","TMGXMLUI",802,0) new result set result=1 "RTN","TMGXMLUI",803,0) if (+$get(File)=0)!($get(field)="")!($get(pArray)="") set result=0 goto ACXDone "RTN","TMGXMLUI",804,0) set indent=$get(indent,0) "RTN","TMGXMLUI",805,0) "RTN","TMGXMLUI",806,0) new defXForm "RTN","TMGXMLUI",807,0) new XForm set XForm="" "RTN","TMGXMLUI",808,0) "RTN","TMGXMLUI",809,0) set defXForm=$get(@pArray@("TRANSFORM",field)) "RTN","TMGXMLUI",810,0) for do quit:(XForm'="")!(result=0) "RTN","TMGXMLUI",811,0) . if defXForm'="" write ?indent,defXForm,! "RTN","TMGXMLUI",812,0) . write ?indent,"Custom output transform for field? (?,^) ^//" "RTN","TMGXMLUI",813,0) . read XForm:$get(DTIME,3600),! "RTN","TMGXMLUI",814,0) . if XForm="" set XForm="^" "RTN","TMGXMLUI",815,0) . if XForm="^" set result=0 quit "RTN","TMGXMLUI",816,0) . if XForm="?" do quit "RTN","TMGXMLUI",817,0) . . write ! "RTN","TMGXMLUI",818,0) . . write ?indent,"OPTION FOR ADVANCED USERS ONLY",! "RTN","TMGXMLUI",819,0) . . write ?indent,"An output transform is custom Mumps code that converts",! "RTN","TMGXMLUI",820,0) . . write ?indent,"internally stored database values into information readable",! "RTN","TMGXMLUI",821,0) . . write ?indent,"by end users. If you don't understand this, just leave this",! "RTN","TMGXMLUI",822,0) . . write ?indent,"option blank (i.e., just hit [ENTER])",! "RTN","TMGXMLUI",823,0) . . write ?indent,"The following variables will be set up:",! "RTN","TMGXMLUI",824,0) . . write ?indent," X -- the value stored in the database",! "RTN","TMGXMLUI",825,0) . . write ?indent," IENS -- a standard Fileman IENS",! "RTN","TMGXMLUI",826,0) . . write ?indent," FILENUM -- the number of the current file or subfile",! "RTN","TMGXMLUI",827,0) . . write ?indent," FIELD -- the number of the current file",! "RTN","TMGXMLUI",828,0) . . write ?indent,"The resulting value (that should be written to the XML",! "RTN","TMGXMLUI",829,0) . . write ?indent,"file) should be put into Y",!! "RTN","TMGXMLUI",830,0) . . do Pause(indent) "RTN","TMGXMLUI",831,0) . . set XForm="" "RTN","TMGXMLUI",832,0) . ;"Note I should run some check here for valid code. "RTN","TMGXMLUI",833,0) . set @pArray@("TRANSFORM",field)=XForm "RTN","TMGXMLUI",834,0) "RTN","TMGXMLUI",835,0) ACXDone "RTN","TMGXMLUI",836,0) quit result "RTN","TMGXMLUI",837,0) "RTN","TMGXMLUI",838,0) "RTN","TMGXMLUI",839,0) FMGetField(FileNumber,indent) "RTN","TMGXMLUI",840,0) ;"Purpose: To use Fileman to pick a field "RTN","TMGXMLUI",841,0) ;"Input: File -- Number of file to get field numbers for "RTN","TMGXMLUI",842,0) ;"Result -- The file number selected, or 0 if none or abort "RTN","TMGXMLUI",843,0) "RTN","TMGXMLUI",844,0) new result set result=0 "RTN","TMGXMLUI",845,0) if +$get(FileNumber)'>0 goto FMGFDone "RTN","TMGXMLUI",846,0) new DIC "RTN","TMGXMLUI",847,0) set DIC="^DD("_FileNumber_"," "RTN","TMGXMLUI",848,0) set DIC(0)="AEQ" "RTN","TMGXMLUI",849,0) set DIC("A")=$$Spaces(.indent)_"Select field (? for list, ^ to abort): " "RTN","TMGXMLUI",850,0) do ^DIC "RTN","TMGXMLUI",851,0) write ! "RTN","TMGXMLUI",852,0) if +Y>0 set result=+Y "RTN","TMGXMLUI",853,0) "RTN","TMGXMLUI",854,0) FMGFDone "RTN","TMGXMLUI",855,0) quit result "RTN","TMGXMLUI",856,0) "RTN","TMGXMLUI",857,0) "RTN","TMGXMLUI",858,0) AskGetField(FileNumber,indent) "RTN","TMGXMLUI",859,0) ;"Purpose: To ask user for a field number, then verify it exists. "RTN","TMGXMLUI",860,0) ;"Input: File -- Number of file to get field numbers for "RTN","TMGXMLUI",861,0) ;" indent -- OPTIONAL -- a number of spaces to indent. "RTN","TMGXMLUI",862,0) ;"Result -- The file number selected, or 0 if none, or -1 if abort "RTN","TMGXMLUI",863,0) "RTN","TMGXMLUI",864,0) new result set result=0 "RTN","TMGXMLUI",865,0) new fieldName,field "RTN","TMGXMLUI",866,0) set indent=$get(indent,0) "RTN","TMGXMLUI",867,0) if +$get(FileNumber)'>0 goto AGFDone "RTN","TMGXMLUI",868,0) "RTN","TMGXMLUI",869,0) write ?indent "RTN","TMGXMLUI",870,0) read "Enter field number or name: ",field:$get(DTIME,3600) "RTN","TMGXMLUI",871,0) if field="^" set result=-1 goto AGFDone "RTN","TMGXMLUI",872,0) if +field=0 do quit:(+field=0) "RTN","TMGXMLUI",873,0) . set fieldName=field "RTN","TMGXMLUI",874,0) . set field=$$GetNumField^TMGDBAPI(FileNumber,field) ;"Convert Field Name to Field Number "RTN","TMGXMLUI",875,0) . write " (# ",field,")",! "RTN","TMGXMLUI",876,0) else do "RTN","TMGXMLUI",877,0) . set fieldName=$$GetFldName^TMGDBAPI(FileNumber,field) ;"Convert Field Number to Field Name "RTN","TMGXMLUI",878,0) . write " (",fieldName,")",! "RTN","TMGXMLUI",879,0) if +field>0 do "RTN","TMGXMLUI",880,0) . new ref set ref="^DD("_FileNumber_","_field_",0)" "RTN","TMGXMLUI",881,0) . if $data(@ref)'>0 do "RTN","TMGXMLUI",882,0) . . write ?indent,"Sorry. That field number doesn't exist.",! "RTN","TMGXMLUI",883,0) . . set field=0 "RTN","TMGXMLUI",884,0) . else do "RTN","TMGXMLUI",885,0) . . set result=field "RTN","TMGXMLUI",886,0) "RTN","TMGXMLUI",887,0) AGFDone "RTN","TMGXMLUI",888,0) quit result "RTN","TMGXMLUI",889,0) "RTN","TMGXMLUI",890,0) "RTN","TMGXMLUI",891,0) PickUnselField(FileNumber,pArray,indent) "RTN","TMGXMLUI",892,0) ;"Purpose: To allow the user to pick those fields not already selected. "RTN","TMGXMLUI",893,0) ;"Input: FileNumber -- the file number to work from "RTN","TMGXMLUI",894,0) ;" pArray -- a pointer to (i.e. name of) array to work from. Format same as other functions in this module "RTN","TMGXMLUI",895,0) ;" indent -- OPTIONAL -- a number of spaces to indent. "RTN","TMGXMLUI",896,0) ;"Result -- The file number selected, or 0 if none, or -1 if abort "RTN","TMGXMLUI",897,0) "RTN","TMGXMLUI",898,0) new result set result=0 "RTN","TMGXMLUI",899,0) new fieldName,field,index "RTN","TMGXMLUI",900,0) set indent=$get(indent,0) "RTN","TMGXMLUI",901,0) if (+$get(FileNumber)'>0)!($get(pArray)="") goto AGFDone "RTN","TMGXMLUI",902,0) "RTN","TMGXMLUI",903,0) ;"Get list of available fields. "RTN","TMGXMLUI",904,0) new allFields "RTN","TMGXMLUI",905,0) new pickArray "RTN","TMGXMLUI",906,0) new pickCt set pickCt=0 "RTN","TMGXMLUI",907,0) if $$GetFldList^TMGDBAPI(FileNumber,"allFields")=0 goto PUFDone "RTN","TMGXMLUI",908,0) set field=0 "RTN","TMGXMLUI",909,0) for do quit:(+field'>0) "RTN","TMGXMLUI",910,0) . new fieldName "RTN","TMGXMLUI",911,0) . set field=$order(allFields(field)) "RTN","TMGXMLUI",912,0) . if (+field>0)&($data(@pArray@(field))=0) do "RTN","TMGXMLUI",913,0) . . set pickCt=pickCt+1 "RTN","TMGXMLUI",914,0) . . set pickArray(pickCt)=field "RTN","TMGXMLUI",915,0) . . set fieldName=$$GetFldName^TMGDBAPI(FileNumber,field) ;"Convert Field Number to Field Name "RTN","TMGXMLUI",916,0) . . write ?indent,pickCt,". ",fieldName," (",field,")",! "RTN","TMGXMLUI",917,0) . if (pickCt>0)&(((pickCt\10)=(pickCt/10))!(+field'>0)) do "RTN","TMGXMLUI",918,0) . . new input "RTN","TMGXMLUI",919,0) . . write !,?indent,"Select entry (NOT field number) (1-",pickCt,",^), ",! "RTN","TMGXMLUI",920,0) . . write ?indent,"or ENTER to continue: // " "RTN","TMGXMLUI",921,0) . . read input:$get(DTIME,3600),! "RTN","TMGXMLUI",922,0) . . if $TEST=0 set input="^" "RTN","TMGXMLUI",923,0) . . if input="^" set field=-1 quit "RTN","TMGXMLUI",924,0) . . if (+input>0)&(+input<(pickCt+1)) do "RTN","TMGXMLUI",925,0) . . . set result=pickArray(+input) "RTN","TMGXMLUI",926,0) . . . set field=0 ;"signal Done "RTN","TMGXMLUI",927,0) "RTN","TMGXMLUI",928,0) if pickCt=0 write ?indent,"(All fields have already been selected.)",! "RTN","TMGXMLUI",929,0) PUFDone "RTN","TMGXMLUI",930,0) quit result "RTN","TMGXMLUI",931,0) "RTN","TMGXMLUI",932,0) "RTN","TMGXMLUI",933,0) CfgOrderFields(File,pArray,indent) "RTN","TMGXMLUI",934,0) ;"Purpose: To allow customization of fields ORDER "RTN","TMGXMLUI",935,0) ;"Input: File -- name or number, file to get field numbers for "RTN","TMGXMLUI",936,0) ;" pArray -- a pointer to (i.e. Name of) array to put field numbers into "RTN","TMGXMLUI",937,0) ;" will probably be something one of the following: "RTN","TMGXMLUI",938,0) ;" "Array(FileNumber,"TEMPLATE")" "RTN","TMGXMLUI",939,0) ;" "Array(FileNumber,RecNumber)" "RTN","TMGXMLUI",940,0) ;" indent -- a value to indent from the left margin "RTN","TMGXMLUI",941,0) ;"Output: Data is put into pArray "RTN","TMGXMLUI",942,0) ;"Result: 1 if OK to continue. 0 if user aborted. "RTN","TMGXMLUI",943,0) "RTN","TMGXMLUI",944,0) new PriorErrorFound "RTN","TMGXMLUI",945,0) new FileNumber,FileName "RTN","TMGXMLUI",946,0) new field,count,index "RTN","TMGXMLUI",947,0) new input "RTN","TMGXMLUI",948,0) new DoneArray set DoneArray="" "RTN","TMGXMLUI",949,0) new result set result=1 "RTN","TMGXMLUI",950,0) if ($get(File)="")!($get(pArray)="") set result=0 goto COFDone "RTN","TMGXMLUI",951,0) "RTN","TMGXMLUI",952,0) "RTN","TMGXMLUI",953,0) if +File=File do "RTN","TMGXMLUI",954,0) . set FileNumber=File "RTN","TMGXMLUI",955,0) . set FileName=$$GetFName^TMGDBAPI(File) "RTN","TMGXMLUI",956,0) else do "RTN","TMGXMLUI",957,0) . set FileName=File "RTN","TMGXMLUI",958,0) . set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",959,0) if FileNumber'>0 do goto COFDone "RTN","TMGXMLUI",960,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") "RTN","TMGXMLUI",961,0) set indent=+$get(indent,0) "RTN","TMGXMLUI",962,0) "RTN","TMGXMLUI",963,0) if $data(@pArray)'>1 set @pArray@("*")="" "RTN","TMGXMLUI",964,0) ;"if $data(@pArray@("*"))>0 do goto COFDone ;"ORDER not allowed if all records requested. "RTN","TMGXMLUI",965,0) ;". write ?indent,"Note: skipping option for field ordering because ALL fields",! "RTN","TMGXMLUI",966,0) ;". write ?indent,"were selected for export.",! "RTN","TMGXMLUI",967,0) ;". write ?indent,"(This is a technical limitation of this routine.)",!! "RTN","TMGXMLUI",968,0) "RTN","TMGXMLUI",969,0) COFLoop "RTN","TMGXMLUI",970,0) write ?indent,"Do you wish to customize the ORDER that ",! "RTN","TMGXMLUI",971,0) write ?indent,"fields will appear in the XML file? (Y/N,^) NO// " "RTN","TMGXMLUI",972,0) new input read input:$get(DTIME,3600),! "RTN","TMGXMLUI",973,0) if $TEST=0 set input="^" "RTN","TMGXMLUI",974,0) if input="^" set result=0 goto COFDone "RTN","TMGXMLUI",975,0) if input="" set input="N" "RTN","TMGXMLUI",976,0) set input=$$UP^XLFSTR(input) "RTN","TMGXMLUI",977,0) if input'["Y" goto COFDone "RTN","TMGXMLUI",978,0) if input="?" do goto COFLoop "RTN","TMGXMLUI",979,0) . write ?indent,"If you want to specify the order that the fields will be exported, enter YES.",! "RTN","TMGXMLUI",980,0) "RTN","TMGXMLUI",981,0) COFL1 "RTN","TMGXMLUI",982,0) new maxNum set maxNum=0 "RTN","TMGXMLUI",983,0) set index=$order(@pArray@("ORDER","")) "RTN","TMGXMLUI",984,0) if index'="" for do quit:(index="") "RTN","TMGXMLUI",985,0) . new n set n=@pArray@("ORDER",index) "RTN","TMGXMLUI",986,0) . if index>maxNum set maxNum=index "RTN","TMGXMLUI",987,0) . set index=$order(@pArray@("ORDER",index)) "RTN","TMGXMLUI",988,0) "RTN","TMGXMLUI",989,0) set field=$order(@pArray@("")) "RTN","TMGXMLUI",990,0) set count=0 "RTN","TMGXMLUI",991,0) new CountArray "RTN","TMGXMLUI",992,0) if field'="" do "RTN","TMGXMLUI",993,0) . write ?indent,"Choose one of the following fields:",! "RTN","TMGXMLUI",994,0) if field'="" for do quit:(+field'>0) "RTN","TMGXMLUI",995,0) . if $data(DoneArray(field))=0 do "RTN","TMGXMLUI",996,0) . . set count=count+1 "RTN","TMGXMLUI",997,0) . . set CountArray(count)=field "RTN","TMGXMLUI",998,0) . . write ?indent,count,". Field: ",field "RTN","TMGXMLUI",999,0) . . if +field=field do "RTN","TMGXMLUI",1000,0) . . . write " (",$$GetFldName^TMGDBAPI(File,field),")",! "RTN","TMGXMLUI",1001,0) . . else write ! "RTN","TMGXMLUI",1002,0) . set field=$order(@pArray@(field)) "RTN","TMGXMLUI",1003,0) if count=0 do goto COFDone "RTN","TMGXMLUI",1004,0) . write ?indent,"All done specifying field order.",!! "RTN","TMGXMLUI",1005,0) . do Pause() "RTN","TMGXMLUI",1006,0) "RTN","TMGXMLUI",1007,0) COFL2 "RTN","TMGXMLUI",1008,0) if count>1 do "RTN","TMGXMLUI",1009,0) . write ?indent,"Note: Don't enter actual field number.",! "RTN","TMGXMLUI",1010,0) . write ?indent,"Which field should come " "RTN","TMGXMLUI",1011,0) . if maxNum=0 write "first." "RTN","TMGXMLUI",1012,0) . else write "next." "RTN","TMGXMLUI",1013,0) . write "? (1-"_count_",^ to abort) " "RTN","TMGXMLUI",1014,0) . read input,!! "RTN","TMGXMLUI",1015,0) . if $TEST=0 set input="^" "RTN","TMGXMLUI",1016,0) else do "RTN","TMGXMLUI",1017,0) . write ?indent,"Only one option left, so I'll enter it for you...",! "RTN","TMGXMLUI",1018,0) . set input=1 "RTN","TMGXMLUI",1019,0) if ((input<1)!(input>count))&(input'="^") goto COFL2 "RTN","TMGXMLUI",1020,0) if input="^" do set result=0 goto COFDone "RTN","TMGXMLUI",1021,0) . kill @pArray@("ORDER") "RTN","TMGXMLUI",1022,0) . write ?indent,"Because the process of specifying an order",! "RTN","TMGXMLUI",1023,0) . write ?indent,"for the fields wasn't completed, the partial ",! "RTN","TMGXMLUI",1024,0) . write ?indent,"order information was deleted.",! "RTN","TMGXMLUI",1025,0) . do Pause(indent) "RTN","TMGXMLUI",1026,0) set maxNum=maxNum+1 "RTN","TMGXMLUI",1027,0) new tempField set tempField=$get(CountArray(input)) "RTN","TMGXMLUI",1028,0) set @pArray@("ORDER",maxNum)=tempField "RTN","TMGXMLUI",1029,0) set DoneArray(tempField)="" "RTN","TMGXMLUI",1030,0) goto COFL1 "RTN","TMGXMLUI",1031,0) "RTN","TMGXMLUI",1032,0) COFDone "RTN","TMGXMLUI",1033,0) quit result "RTN","TMGXMLUI",1034,0) "RTN","TMGXMLUI",1035,0) "RTN","TMGXMLUI",1036,0) ShowArray(indent) "RTN","TMGXMLUI",1037,0) ;"Purpose: To show the array that composes the XML export request "RTN","TMGXMLUI",1038,0) if ($data(TMGxmlArray)>0)&($data(@TMGxmlArray)) do "RTN","TMGXMLUI",1039,0) . write ! "RTN","TMGXMLUI",1040,0) . new i for i=1:1:indent set indent(i)=0 "RTN","TMGXMLUI",1041,0) . do ArrayDump^TMGDEBUG(TMGxmlArray,,.indent) "RTN","TMGXMLUI",1042,0) . ;"zwr @TMGxmlArray "RTN","TMGXMLUI",1043,0) . write ! "RTN","TMGXMLUI",1044,0) do Pause(.indent) "RTN","TMGXMLUI",1045,0) quit "RTN","TMGXMLUI",1046,0) "RTN","TMGXMLUI",1047,0) "RTN","TMGXMLUI",1048,0) Pause(indent) "RTN","TMGXMLUI",1049,0) ;"Purpose: To prompt user to hit enter to continue "RTN","TMGXMLUI",1050,0) ;"Input: indent -- OPTIONAL -- number of spaces to indent from left margin. "RTN","TMGXMLUI",1051,0) ;" Note: to call with no value for indent, use "do Pause()" "RTN","TMGXMLUI",1052,0) "RTN","TMGXMLUI",1053,0) new temp "RTN","TMGXMLUI",1054,0) set indent=$get(indent,0) "RTN","TMGXMLUI",1055,0) write ?indent "RTN","TMGXMLUI",1056,0) read "Press [Enter] to continue...",temp:$get(DTIME,3600),! "RTN","TMGXMLUI",1057,0) quit "RTN","TMGXMLUI",1058,0) "RTN","TMGXMLUI",1059,0) WriteHeader(pHeader,SuppressLF) "RTN","TMGXMLUI",1060,0) ;"Purpose: to put a header at the top of the screen "RTN","TMGXMLUI",1061,0) ;" The screen will be cleared "RTN","TMGXMLUI",1062,0) ;"Note: because global variable IOF is used, the VistA environement must be setup first. "RTN","TMGXMLUI",1063,0) ;"Input: pHeader -- expected format: "RTN","TMGXMLUI",1064,0) ;" pHeader(1)="First Line" "RTN","TMGXMLUI",1065,0) ;" pHeader(2)="Second Line" "RTN","TMGXMLUI",1066,0) ;" pHeader("MAX LINE")=2 "RTN","TMGXMLUI",1067,0) ;" SuppressLF -- OPTIONAL if =1, then extra LF suppressed "RTN","TMGXMLUI",1068,0) ;"Result: none "RTN","TMGXMLUI",1069,0) "RTN","TMGXMLUI",1070,0) write @IOF "RTN","TMGXMLUI",1071,0) if $get(pHeader)="" goto WHDone "RTN","TMGXMLUI",1072,0) new max set max=+$get(@pHeader@("MAX LINE")) "RTN","TMGXMLUI",1073,0) if max=0 goto WHDone "RTN","TMGXMLUI",1074,0) for index=1:1:max do "RTN","TMGXMLUI",1075,0) . if $data(@pHeader@(index))=0 quit "RTN","TMGXMLUI",1076,0) . new line set line=$get(@pHeader@(index)) "RTN","TMGXMLUI",1077,0) . if (line[" Step") do "RTN","TMGXMLUI",1078,0) . . if (index<max) do "RTN","TMGXMLUI",1079,0) . . . set line=$$Substitute^TMGSTUTL(line," Step","(X) Step") "RTN","TMGXMLUI",1080,0) . . else do "RTN","TMGXMLUI",1081,0) . . . set line=$$Substitute^TMGSTUTL(line," Step","(_) Step") "RTN","TMGXMLUI",1082,0) . write line,! "RTN","TMGXMLUI",1083,0) "RTN","TMGXMLUI",1084,0) if $get(SuppressLF)'=0 write ! "RTN","TMGXMLUI",1085,0) "RTN","TMGXMLUI",1086,0) WHDone "RTN","TMGXMLUI",1087,0) quit "RTN","TMGXMLUI",1088,0) "RTN","TMGXMLUI",1089,0) HdrAddLine(pHeader,Line) "RTN","TMGXMLUI",1090,0) ;"Purpose: To add Line to end of header array "RTN","TMGXMLUI",1091,0) ;"Input: pHeader -- expected format: (it is OK to pass an empty array to be filled) "RTN","TMGXMLUI",1092,0) ;" pHeader(1)="First Line" "RTN","TMGXMLUI",1093,0) ;" pHeader(2)="Second Line" "RTN","TMGXMLUI",1094,0) ;" pHeader("MAX LINE")=2 "RTN","TMGXMLUI",1095,0) ;" Line -- a string to be added. "RTN","TMGXMLUI",1096,0) ;"result: none "RTN","TMGXMLUI",1097,0) "RTN","TMGXMLUI",1098,0) if $get(pHeader)="" goto HALDone "RTN","TMGXMLUI",1099,0) if $get(Line)="" goto HALDone "RTN","TMGXMLUI",1100,0) new max set max=+$get(@pHeader@("MAX LINE")) "RTN","TMGXMLUI",1101,0) "RTN","TMGXMLUI",1102,0) set max=max+1 "RTN","TMGXMLUI",1103,0) set @pHeader@(max)=Line "RTN","TMGXMLUI",1104,0) set @pHeader@("MAX LINE")=max "RTN","TMGXMLUI",1105,0) "RTN","TMGXMLUI",1106,0) HALDone "RTN","TMGXMLUI",1107,0) quit "RTN","TMGXMLUI",1108,0) "RTN","TMGXMLUI",1109,0) "RTN","TMGXMLUI",1110,0) HdrDelLine(pHeader,index) "RTN","TMGXMLUI",1111,0) ;"Purpose: To delete a line from the header "RTN","TMGXMLUI",1112,0) ;"Input: pHeader -- expected format: (it is OK to pass an empty array to be filled) "RTN","TMGXMLUI",1113,0) ;" pHeader(1)="First Line" "RTN","TMGXMLUI",1114,0) ;" pHeader(2)="Second Line" "RTN","TMGXMLUI",1115,0) ;" pHeader("MAX LINE")=2 "RTN","TMGXMLUI",1116,0) ;" index -- OPTIONAL -- default is to be the last line "RTN","TMGXMLUI",1117,0) "RTN","TMGXMLUI",1118,0) if $get(pHeader)="" goto HDLDone "RTN","TMGXMLUI",1119,0) new max set max=+$get(@pHeader@("MAX LINE")) "RTN","TMGXMLUI",1120,0) if max=0 goto HDLDone "RTN","TMGXMLUI",1121,0) set index=$get(index,0) "RTN","TMGXMLUI",1122,0) if index=0 set index=max "RTN","TMGXMLUI",1123,0) kill @pHeader@(index) "RTN","TMGXMLUI",1124,0) if index<max for index=index:1:(max-1) do "RTN","TMGXMLUI",1125,0) . set @pHeader@(index)=$get(@pHeader@(index+1)) "RTN","TMGXMLUI",1126,0) . kill @pHeader@(index+1) "RTN","TMGXMLUI",1127,0) "RTN","TMGXMLUI",1128,0) set @pHeader@("MAX LINE")=max-1 "RTN","TMGXMLUI",1129,0) "RTN","TMGXMLUI",1130,0) HDLDone "RTN","TMGXMLUI",1131,0) quit "RTN","TMGXMLUI",1132,0) "RTN","TMGXMLUI",1133,0) Spaces(Num) "RTN","TMGXMLUI",1134,0) ;"purpose to return Num number of spaces "RTN","TMGXMLUI",1135,0) new result set result="" "RTN","TMGXMLUI",1136,0) set Num=+$get(Num,0) "RTN","TMGXMLUI",1137,0) if Num=0 goto SPCDone "RTN","TMGXMLUI",1138,0) new i "RTN","TMGXMLUI",1139,0) for i=1:1:Num set result=result_" " "RTN","TMGXMLUI",1140,0) "RTN","TMGXMLUI",1141,0) SPCDone "RTN","TMGXMLUI",1142,0) quit result "RTN","TMGXMLUI",1143,0) "RTN","TMGXMLUI",1144,0) "RTN","TMGXMLUI",1145,0) "RTN","TMGXMLUI",1146,0) ;"=================================================== "RTN","TMGXMLUI",1147,0) "RTN","TMGXMLUI",1148,0) GetPtrsOut(File,Array) "RTN","TMGXMLUI",1149,0) ;"Purpose: to return a list of all possible pointers out, for a given file "RTN","TMGXMLUI",1150,0) ;"Input: File -- name or number of file to investigate "RTN","TMGXMLUI",1151,0) ;" Array -- PASS BY REFERENCE. Output format: "RTN","TMGXMLUI",1152,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1153,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1154,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1155,0) ;"Results: 1 if some found, 0 if no pointers out. "RTN","TMGXMLUI",1156,0) "RTN","TMGXMLUI",1157,0) new FileNumber "RTN","TMGXMLUI",1158,0) kill Array "RTN","TMGXMLUI",1159,0) new found set found=0 "RTN","TMGXMLUI",1160,0) "RTN","TMGXMLUI",1161,0) if +File=File set FileNumber=File "RTN","TMGXMLUI",1162,0) else set FileNumber=$$GetFileNum^TMGDBAPI(File) "RTN","TMGXMLUI",1163,0) "RTN","TMGXMLUI",1164,0) new field set field=0 "RTN","TMGXMLUI",1165,0) for set field=$order(^DD(FileNumber,field)) quit:(field'>0) do "RTN","TMGXMLUI",1166,0) . new fldInfo set fldInfo=$piece($get(^DD(FileNumber,field,0)),"^",2) "RTN","TMGXMLUI",1167,0) . if fldInfo'["P" quit "RTN","TMGXMLUI",1168,0) . new otherFile set otherFile=+$piece(fldInfo,"P",2) "RTN","TMGXMLUI",1169,0) . if $$GetFName^TMGDBAPI(otherFile)="" do quit "RTN","TMGXMLUI",1170,0) . set Array(FileNumber,"POINTERS OUT",field,otherFile)="" "RTN","TMGXMLUI",1171,0) . set found=1 "RTN","TMGXMLUI",1172,0) "RTN","TMGXMLUI",1173,0) quit found "RTN","TMGXMLUI",1174,0) "RTN","TMGXMLUI",1175,0) "RTN","TMGXMLUI",1176,0) CustPtrOuts(Array,RecsArray) "RTN","TMGXMLUI",1177,0) ;"Purpose: Given an array of pointers out (as created by GetPtrsOut), look at the "RTN","TMGXMLUI",1178,0) ;" specific group of records (provided in RecsArray) and trim out theoretical "RTN","TMGXMLUI",1179,0) ;" pointers, and only leave actual pointers in the list. "RTN","TMGXMLUI",1180,0) ;"Input: Array PASS BY REFERENCE. Format: "RTN","TMGXMLUI",1181,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1182,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1183,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1184,0) ;" RecsArray "RTN","TMGXMLUI",1185,0) ;" RecsArray(FileNumber,IENinFile)="" "RTN","TMGXMLUI",1186,0) ;" RecsArray(FileNumber,IENinFile)="" "RTN","TMGXMLUI",1187,0) ;" RecsArray(FileNumber,IENinFile)="" "RTN","TMGXMLUI",1188,0) ;" Note: Array may well have other information in it. "RTN","TMGXMLUI",1189,0) ;"Output: Array pointer will be trimmed such that every pointer listed exists "RTN","TMGXMLUI",1190,0) ;" in at least of the records in RecsArray "RTN","TMGXMLUI",1191,0) "RTN","TMGXMLUI",1192,0) new fileNum,fieldNum,IEN "RTN","TMGXMLUI",1193,0) set fileNum="" "RTN","TMGXMLUI",1194,0) for set fileNum=$order(Array(fileNum)) quit:(+fileNum'>0) do "RTN","TMGXMLUI",1195,0) . set fieldNum="" "RTN","TMGXMLUI",1196,0) . for set fieldNum=$order(Array(fileNum,"POINTERS OUT",fieldNum)) quit:(+fieldNum'>0) do "RTN","TMGXMLUI",1197,0) . . ;"Now, for given file:field, do any records in RecsArray contain a value? "RTN","TMGXMLUI",1198,0) . . new ref set ref=$get(^DIC(fileNum,0,"GL")) ;"record global ref string (open ended) "RTN","TMGXMLUI",1199,0) . . new node set node=$get(^DD(fileNum,fieldNum,0)) ;"node=entire 0 node "RTN","TMGXMLUI",1200,0) . . new np set np=$piece(node,"^",4) ;"get node;piece "RTN","TMGXMLUI",1201,0) . . new n set n=$piece(np,";",1) ;"n=node "RTN","TMGXMLUI",1202,0) . . new p set p=$piece(np,";",2) ;"p=piece "RTN","TMGXMLUI",1203,0) . . set IEN="" "RTN","TMGXMLUI",1204,0) . . new found set found=0 "RTN","TMGXMLUI",1205,0) . . for set IEN=$order(RecsArray(fileNum,IEN)) quit:(+IEN'>0)!(found=1) do "RTN","TMGXMLUI",1206,0) . . . new tempRef set tempRef=ref_IEN_","""_n_""")" "RTN","TMGXMLUI",1207,0) . . . new line set line=$get(@tempRef) "RTN","TMGXMLUI",1208,0) . . . new ptr set ptr=+$piece(line,"^",p) ;"get data from database "RTN","TMGXMLUI",1209,0) . . . if ptr>0 set found=1 quit ;"found at least one record in group has an actual pointer "RTN","TMGXMLUI",1210,0) . . if found=1 quit ;"don't cut out the theoritical pointers (but no actual data) "RTN","TMGXMLUI",1211,0) . . kill Array(fileNum,"POINTERS OUT",fieldNum) "RTN","TMGXMLUI",1212,0) "RTN","TMGXMLUI",1213,0) quit "RTN","TMGXMLUI",1214,0) "RTN","TMGXMLUI",1215,0) "RTN","TMGXMLUI",1216,0) TrimPtrOut(Array) "RTN","TMGXMLUI",1217,0) ;"Purpose: Given array of pointers out (as created by GetPtrsOut, or CustPtrsOut), ask which "RTN","TMGXMLUI",1218,0) ;" other files should be ignored. "RTN","TMGXMLUI",1219,0) ;"Input: Array. PASS BY REFERENCE. Format: "RTN","TMGXMLUI",1220,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1221,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1222,0) ;"Output: for those pointers out that can be ignored, entries will be changed: "RTN","TMGXMLUI",1223,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="-" <-- Ignore flag "RTN","TMGXMLUI",1224,0) ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="+" <-- Confirmed flag "RTN","TMGXMLUI",1225,0) "RTN","TMGXMLUI",1226,0) ;"first, make a temp array that groups pointers out. "RTN","TMGXMLUI",1227,0) "RTN","TMGXMLUI",1228,0) new Array2 "RTN","TMGXMLUI",1229,0) new fileNum set fileNum=0 "RTN","TMGXMLUI",1230,0) for set fileNum=$order(Array(fileNum)) quit:(+fileNum'>0) do "RTN","TMGXMLUI",1231,0) . new fieldNum set fieldNum=0 "RTN","TMGXMLUI",1232,0) . new ref "RTN","TMGXMLUI",1233,0) . for set fieldNum=$order(Array(fileNum,"POINTERS OUT",fieldNum)) quit:(+fieldNum'>0) do "RTN","TMGXMLUI",1234,0) . . new otherFileNum set otherFileNum=$order(Array(fileNum,"POINTERS OUT",fieldNum,"")) "RTN","TMGXMLUI",1235,0) . . if +otherFileNum'>0 quit "RTN","TMGXMLUI",1236,0) . . new ref set ref=$name(Array(fileNum,"POINTERS OUT",fieldNum,otherFileNum)) "RTN","TMGXMLUI",1237,0) . . new IEN set IEN=$order(^TMG(22708,"B",otherFileNum,"")) "RTN","TMGXMLUI",1238,0) . . if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=0 do quit "RTN","TMGXMLUI",1239,0) . . . set Array(fileNum,"POINTERS OUT",fieldNum,otherFileNum)="-" "RTN","TMGXMLUI",1240,0) . . if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=1 do quit "RTN","TMGXMLUI",1241,0) . . . set Array(fileNum,"POINTERS OUT",fieldNum,otherFileNum)="+" "RTN","TMGXMLUI",1242,0) . . set Array2(otherFileNum,ref)="" "RTN","TMGXMLUI",1243,0) "RTN","TMGXMLUI",1244,0) new menu,count "RTN","TMGXMLUI",1245,0) new UsrInput,IEN "RTN","TMGXMLUI",1246,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGXMLUI",1247,0) new ref,%,otherFileNum "RTN","TMGXMLUI",1248,0) new otherFileNum "RTN","TMGXMLUI",1249,0) "RTN","TMGXMLUI",1250,0) if $data(Array2)=0 goto TPODone "RTN","TMGXMLUI",1251,0) "RTN","TMGXMLUI",1252,0) set menu(0)="Pick Which Pointers are NOT to User Data" "RTN","TMGXMLUI",1253,0) set count=1 "RTN","TMGXMLUI",1254,0) set otherFileNum=0 "RTN","TMGXMLUI",1255,0) for set otherFileNum=$order(Array2(otherFileNum)) quit:(otherFileNum="") do "RTN","TMGXMLUI",1256,0) . set menu(count)=$$GetFName^TMGDBAPI(otherFileNum)_$char(9)_otherFileNum_"^"_count "RTN","TMGXMLUI",1257,0) . set count=count+1 "RTN","TMGXMLUI",1258,0) "RTN","TMGXMLUI",1259,0) TPO set UsrInput=$$Menu^TMGUSRIF(.menu) "RTN","TMGXMLUI",1260,0) if "x^"[UsrInput goto TPODone "RTN","TMGXMLUI",1261,0) if UsrInput["?" do goto TPO "RTN","TMGXMLUI",1262,0) . write "Explore which entry above? //" "RTN","TMGXMLUI",1263,0) . new temp read temp:$get(DTIME,3600),! "RTN","TMGXMLUI",1264,0) . set temp=$piece($get(menu(temp)),$char(9),2) "RTN","TMGXMLUI",1265,0) . set temp=$piece(temp,"^",1) "RTN","TMGXMLUI",1266,0) . if temp="" quit "RTN","TMGXMLUI",1267,0) . new DIC,X,Y "RTN","TMGXMLUI",1268,0) . set DIC(0)="MAEQ" "RTN","TMGXMLUI",1269,0) . set DIC=+temp "RTN","TMGXMLUI",1270,0) . write "Here you can use Fileman to look at entries in file #",temp "RTN","TMGXMLUI",1271,0) . do ^DIC write ! "RTN","TMGXMLUI",1272,0) set ref="" "RTN","TMGXMLUI",1273,0) set count=$piece(UsrInput,"^",2) "RTN","TMGXMLUI",1274,0) set UsrInput=$piece(UsrInput,"^",1) "RTN","TMGXMLUI",1275,0) for set ref=$order(Array2(UsrInput,ref)) quit:(ref="") do "RTN","TMGXMLUI",1276,0) . set @ref="-" "RTN","TMGXMLUI",1277,0) . kill menu(count) "RTN","TMGXMLUI",1278,0) . set otherFileNum=+$piece(ref,",",4) "RTN","TMGXMLUI",1279,0) set %=1 "RTN","TMGXMLUI",1280,0) set IEN=$order(^TMG(22708,"B",otherFileNum,"")) "RTN","TMGXMLUI",1281,0) if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=0 goto TPO "RTN","TMGXMLUI",1282,0) write "Remember that ",$$GetFName^TMGDBAPI(otherFileNum)," DOESN'T contain ",! "RTN","TMGXMLUI",1283,0) WRITE " site-specific data (stored in File #22708)" "RTN","TMGXMLUI",1284,0) do YN^DICN write ! "RTN","TMGXMLUI",1285,0) if %'=1 goto TPO "RTN","TMGXMLUI",1286,0) kill TMGMSG,TMGFDA,TMGIEN "RTN","TMGXMLUI",1287,0) if +IEN>0 do "RTN","TMGXMLUI",1288,0) . set TMGFDA(22708,IEN_",",1)=0 "RTN","TMGXMLUI",1289,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGXMLUI",1290,0) else do "RTN","TMGXMLUI",1291,0) . set TMGFDA(22708,"+1,",.01)=otherFileNum "RTN","TMGXMLUI",1292,0) . set TMGFDA(22708,"+1,",1)=0 "RTN","TMGXMLUI",1293,0) . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGXMLUI",1294,0) do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGXMLUI",1295,0) goto TPO "RTN","TMGXMLUI",1296,0) "RTN","TMGXMLUI",1297,0) TPODone "RTN","TMGXMLUI",1298,0) if $data(menu)=0 goto TPOQ "RTN","TMGXMLUI",1299,0) if $order(menu(0))="" goto TPOQ "RTN","TMGXMLUI",1300,0) new Entry set Entry=0 "RTN","TMGXMLUI",1301,0) for set Entry=$order(menu(Entry)) quit:(Entry="") do "RTN","TMGXMLUI",1302,0) . write " -- ",$piece(menu(Entry),$char(9),1),! "RTN","TMGXMLUI",1303,0) write "Perminantly mark these files as CONTAINING site specific data" "RTN","TMGXMLUI",1304,0) set %=1 "RTN","TMGXMLUI",1305,0) do YN^DICN write ! "RTN","TMGXMLUI",1306,0) if %=1 do "RTN","TMGXMLUI",1307,0) . set Entry=0 "RTN","TMGXMLUI",1308,0) . for set Entry=$order(menu(Entry)) quit:(Entry="") do "RTN","TMGXMLUI",1309,0) . . set UsrInput=$piece(menu(Entry),$char(9),2) "RTN","TMGXMLUI",1310,0) . . set otherFileNum=$piece(UsrInput,"^",1) "RTN","TMGXMLUI",1311,0) . . set ref="" "RTN","TMGXMLUI",1312,0) . . for set ref=$order(Array2(otherFileNum,ref)) quit:(ref="") do "RTN","TMGXMLUI",1313,0) . . . set @ref="+" "RTN","TMGXMLUI",1314,0) . . set IEN=$order(^TMG(22708,"B",otherFileNum,"")) "RTN","TMGXMLUI",1315,0) . . if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=1 quit "RTN","TMGXMLUI",1316,0) . . if +IEN>0 do "RTN","TMGXMLUI",1317,0) . . . set TMGFDA(22708,IEN_",",1)=1 "RTN","TMGXMLUI",1318,0) . . . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGXMLUI",1319,0) . . else do "RTN","TMGXMLUI",1320,0) . . . kill TMGIEN "RTN","TMGXMLUI",1321,0) . . . set TMGFDA(22708,"+1,",.01)=otherFileNum "RTN","TMGXMLUI",1322,0) . . . set TMGFDA(22708,"+1,",1)=1 "RTN","TMGXMLUI",1323,0) . . . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGXMLUI",1324,0) . . do ShowIfDIERR^TMGDEBUG(.TMGMSG) "RTN","TMGXMLUI",1325,0) "RTN","TMGXMLUI",1326,0) TPOQ "RTN","TMGXMLUI",1327,0) quit "RTN","TMGXMLUI",1328,0) "RTN","TMGXMLUI",1329,0) "RTN","TMGXMLUI",1330,0) GetRecsOut(RecsArray,PtrsArray,Array) "RTN","TMGXMLUI",1331,0) ;"Purpose: For a given set of records in a file, determine the linked-to record #'s "RTN","TMGXMLUI",1332,0) ;" in other files through pointers out. This will return the actual IEN's "RTN","TMGXMLUI",1333,0) ;" in other files that are being pointed to. "RTN","TMGXMLUI",1334,0) ;"Input -- PtrsArray. PASS BY REFERENCE. Format: "RTN","TMGXMLUI",1335,0) ;" RecsArray(FileNumber,IENinFile)="" "RTN","TMGXMLUI",1336,0) ;" RecsArray(FileNumber,IENinFile)="" "RTN","TMGXMLUI",1337,0) ;" RecsArray(FileNumber,IENinFile)="" "RTN","TMGXMLUI",1338,0) ;" Note: Array may well have other information in it. "RTN","TMGXMLUI",1339,0) ;" RecsArray. PASS BY REFERENCE. Format: "RTN","TMGXMLUI",1340,0) ;" PtrsArray(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1341,0) ;" PtrsArray(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="-" <-- flag to ignore "RTN","TMGXMLUI",1342,0) ;" PtrsArray(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="" "RTN","TMGXMLUI",1343,0) ;" Array. PASS BY REFERENCE. An OUT PARAMETER. Format: "RTN","TMGXMLUI",1344,0) ;" Array(FileNumber,IEN,FieldNum,"LINKED TO",OtherFileNum,OtherIEN)="" "RTN","TMGXMLUI",1345,0) ;" Array(FileNumber,IEN,FieldNum,"LINKED TO",OtherFileNum,OtherIEN)="" "RTN","TMGXMLUI",1346,0) ;" Array(FileNumber,IEN,FieldNum,"LINKED TO",OtherFileNum,OtherIEN)="" "RTN","TMGXMLUI",1347,0) ;" Array("X1",OtherFileNum,OtherIEN)="" "RTN","TMGXMLUI",1348,0) ;" Array("X1",OtherFileNum,OtherIEN)="" "RTN","TMGXMLUI",1349,0) ;"Output: Array is filled as above. "RTN","TMGXMLUI",1350,0) ;"Results: None "RTN","TMGXMLUI",1351,0) "RTN","TMGXMLUI",1352,0) new fileNum set fileNum=0 "RTN","TMGXMLUI",1353,0) for set fileNum=$order(PtrsArray(fileNum)) quit:(+fileNum'>0) do "RTN","TMGXMLUI",1354,0) . new IEN set IEN=0 "RTN","TMGXMLUI",1355,0) . for set IEN=$order(RecsArray(fileNum,IEN)) quit:(+IEN'>0) do "RTN","TMGXMLUI",1356,0) . . new fieldNum set fieldNum=0 "RTN","TMGXMLUI",1357,0) . . for set fieldNum=$order(PtrsArray(fileNum,"POINTERS OUT",fieldNum)) quit:(+fieldNum'>0) do "RTN","TMGXMLUI",1358,0) . . . new otherFileNum set otherFileNum=$order(PtrsArray(fileNum,"POINTERS OUT",fieldNum,"")) "RTN","TMGXMLUI",1359,0) . . . if +otherFileNum'>0 quit "RTN","TMGXMLUI",1360,0) . . . new flag set flag=$get(PtrsArray(fileNum,"POINTERS OUT",fieldNum,otherFileNum)) "RTN","TMGXMLUI",1361,0) . . . if flag="-" quit "RTN","TMGXMLUI",1362,0) . . . new otherIEN set otherIEN=$$GET1^DIQ(fileNum,IEN_",",fieldNum,"I") "RTN","TMGXMLUI",1363,0) . . . if +otherIEN'>0 quit "RTN","TMGXMLUI",1364,0) . . . set Array(fileNum,IEN,fieldNum,"LINKED TO",otherFileNum,otherIEN)="" "RTN","TMGXMLUI",1365,0) . . . if $data(RecsArray(otherFileNum,otherIEN))=0 do "RTN","TMGXMLUI",1366,0) . . . . set Array("X1",otherFileNum,otherIEN)="tag=POINTED_TO_RECORD" "RTN","TMGXMLUI",1367,0) "RTN","TMGXMLUI",1368,0) quit "RTN","TMGXMLUI",1369,0) "RTN","TMGXMLUI",1370,0) "RTN","TMGXMLUI",1371,0) "RTN","TMGXMLUI",1372,0) ExpandPtrs(pRecsArray) "RTN","TMGXMLUI",1373,0) ;"Purpose: To take selected record set and include records from other files that "RTN","TMGXMLUI",1374,0) ;" the selected records point to. Only records in files that marked as holding "RTN","TMGXMLUI",1375,0) ;" site-specific data will be added "RTN","TMGXMLUI",1376,0) ;" "RTN","TMGXMLUI",1377,0) new changed "RTN","TMGXMLUI",1378,0) new RecsArray "RTN","TMGXMLUI",1379,0) new PtrsArray,Array "RTN","TMGXMLUI",1380,0) merge RecsArray=@pRecsArray "RTN","TMGXMLUI",1381,0) T1 "RTN","TMGXMLUI",1382,0) set changed=0 "RTN","TMGXMLUI",1383,0) set fileNum=0 "RTN","TMGXMLUI",1384,0) for set fileNum=$order(RecsArray(fileNum)) quit:(fileNum="") do "RTN","TMGXMLUI",1385,0) . if $$GetPtrsOut(fileNum,.PtrsArray)=0 goto TQuit "RTN","TMGXMLUI",1386,0) . do CustPtrOuts(.PtrsArray,.RecsArray) "RTN","TMGXMLUI",1387,0) . do TrimPtrOut(.PtrsArray) "RTN","TMGXMLUI",1388,0) . do GetRecsOut(.RecsArray,.PtrsArray,.Array) "RTN","TMGXMLUI",1389,0) . if $data(Array("X1")) do "RTN","TMGXMLUI",1390,0) . . merge RecsArray=Array("X1") "RTN","TMGXMLUI",1391,0) . . set changed=1 "RTN","TMGXMLUI",1392,0) . . kill Array("X1") "RTN","TMGXMLUI",1393,0) if changed=1 goto T1 "RTN","TMGXMLUI",1394,0) "RTN","TMGXMLUI",1395,0) TQuit "RTN","TMGXMLUI",1396,0) merge @pRecsArray=RecsArray "RTN","TMGXMLUI",1397,0) quit "RTN","TMGXMLUI",1398,0) "RTN","TMGXMLUI",1399,0) "RTN","TMGXMLUI",1400,0) Test "RTN","TMGXMLUI",1401,0) new Recs,fileNum "RTN","TMGXMLUI",1402,0) "RTN","TMGXMLUI",1403,0) if $data(^TMG("TMP","KILLTHIS"))=0 do "RTN","TMGXMLUI",1404,0) . if $$UI^TMGXMLUI("RecsArray")=0 quit "RTN","TMGXMLUI",1405,0) . merge ^TMG("TMP","KILLTHIS")=Recs "RTN","TMGXMLUI",1406,0) else do "RTN","TMGXMLUI",1407,0) . merge Recs=^TMG("TMP","KILLTHIS") "RTN","TMGXMLUI",1408,0) "RTN","TMGXMLUI",1409,0) do ExpandPtrs("Recs") "RTN","TMGXMLUI",1410,0) "RTN","TMGXMLUI",1411,0) quit "RTN","TMGXMLUI",1412,0) "RTN","TMGXMLUI",1413,0) "RTN","TMGXPDR") 0^106^B20281682 "RTN","TMGXPDR",1,0) TMGXPDR ;TMG/kst/Altered version of XPDR ;03/25/06 "RTN","TMGXPDR",2,0) ;;1.0;TMG-LIB;**1**;7/25/05 "RTN","TMGXPDR",3,0) "RTN","TMGXPDR",4,0) ;"TMGXPDR -- a custom version of XPDR "RTN","TMGXPDR",5,0) ;"K. Toppenberg, MD 7-25-05 "RTN","TMGXPDR",6,0) "RTN","TMGXPDR",7,0) XPDR ;SFISC/RSD - Routine File Edit ;09/17/96 10:05 "RTN","TMGXPDR",8,0) ;;8.0;KERNEL;**1,2,44**;Jul 10, 1995 "RTN","TMGXPDR",9,0) Q "RTN","TMGXPDR",10,0) "RTN","TMGXPDR",11,0) UPDT ;update routine file "RTN","TMGXPDR",12,0) new DIR,DIRUT,XPD,XPDI,XPDJ "RTN","TMGXPDR",13,0) new XPDN ;"array of included (1 node) and excluded (0 node) namespaces "RTN","TMGXPDR",14,0) new X,X1,Y,Y1,% "RTN","TMGXPDR",15,0) new addCount set addCount=0 "RTN","TMGXPDR",16,0) "RTN","TMGXPDR",17,0) write !! "RTN","TMGXPDR",18,0) write "** ROUTINE File Updater **",! "RTN","TMGXPDR",19,0) write "(Allows addition of selected routines to ROUTINE file)",! "RTN","TMGXPDR",20,0) write "-----------------------------------------------------------",! "RTN","TMGXPDR",21,0) write ! "RTN","TMGXPDR",22,0) write "Enter namespace of routines to add (e.g. TIU), or",! "RTN","TMGXPDR",23,0) write "routines to exclude from addition (e.g. -TIU)",!! "RTN","TMGXPDR",24,0) "RTN","TMGXPDR",25,0) set DIR(0)="FO^1:9^K:X'?.1""-""1U.7UNP X" "RTN","TMGXPDR",26,0) set DIR("A")="Routine Namespace ([ENTER] if done)" "RTN","TMGXPDR",27,0) set DIR("?")="Enter 1 to 8 characters, preceed with ""-"" to exclude namespace" "RTN","TMGXPDR",28,0) "RTN","TMGXPDR",29,0) ;"XPDN(0=excluded names or 1=include names, namespace)="" "RTN","TMGXPDR",30,0) for do quit:$data(DIRUT) "RTN","TMGXPDR",31,0) . do ^DIR "RTN","TMGXPDR",32,0) . quit:$data(DIRUT) "RTN","TMGXPDR",33,0) . set X=($extract(Y,$L(Y))="*") "RTN","TMGXPDR",34,0) . set %=($extract(Y)="-") "RTN","TMGXPDR",35,0) . set XPDN('%,$extract(Y,%+1,$length(Y)-X))="" "RTN","TMGXPDR",36,0) "RTN","TMGXPDR",37,0) if ('$data(XPDN))!($data(DTOUT))!($data(DUOUT)) write ! goto UPDTQ "RTN","TMGXPDR",38,0) ;"quit:'$data(XPDN)!$data(DTOUT)!$data(DUOUT) "RTN","TMGXPDR",39,0) write !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------" "RTN","TMGXPDR",40,0) set (X,Y)="" "RTN","TMGXPDR",41,0) set (X1,Y1)=1 "RTN","TMGXPDR",42,0) for do write !?11,X,?35,Y quit:'X1&'Y1 "RTN","TMGXPDR",43,0) . set:X1 X=$O(XPDN(1,X)),X1=X]"" "RTN","TMGXPDR",44,0) . set:Y1 Y=$O(XPDN(0,Y)),Y1=Y]"" "RTN","TMGXPDR",45,0) "RTN","TMGXPDR",46,0) kill DIR "RTN","TMGXPDR",47,0) set DIR(0)="Y" "RTN","TMGXPDR",48,0) set DIR("A")="OK to continue" "RTN","TMGXPDR",49,0) set DIR("B")="YES" "RTN","TMGXPDR",50,0) do ^DIR "RTN","TMGXPDR",51,0) "RTN","TMGXPDR",52,0) quit:'Y!$data(DIRUT) "RTN","TMGXPDR",53,0) write ! "RTN","TMGXPDR",54,0) set DIR(0)="Y" "RTN","TMGXPDR",55,0) set DIR("A")="Want me to clean up the Routine File before updating" "RTN","TMGXPDR",56,0) set DIR("?")="YES means you want to go throught the Routine file and delete any routine name that no longer exists on the system." "RTN","TMGXPDR",57,0) do ^DIR "RTN","TMGXPDR",58,0) "RTN","TMGXPDR",59,0) quit:$data(DIRUT) "RTN","TMGXPDR",60,0) do WAIT^DICD "RTN","TMGXPDR",61,0) write ! "RTN","TMGXPDR",62,0) do DELRTN:Y "RTN","TMGXPDR",63,0) "RTN","TMGXPDR",64,0) ;"---------------------------------------------------------------------------- "RTN","TMGXPDR",65,0) ;"Replacement code for below... "RTN","TMGXPDR",66,0) new XPDArray "RTN","TMGXPDR",67,0) merge XPDArray=XPDN(1) ;"node 1=>included namespaces "RTN","TMGXPDR",68,0) ;"ensure that all entries end with "*" (e.g. "TMG*" not "TMG") "RTN","TMGXPDR",69,0) set XPDI=$order(XPDArray("")) "RTN","TMGXPDR",70,0) if XPDI'="" for do quit:XPDI="" "RTN","TMGXPDR",71,0) . new node set node=XPDI "RTN","TMGXPDR",72,0) . set XPDI=$order(XPDArray(node)) "RTN","TMGXPDR",73,0) . if ($extract(node,$length(node))'="*") do "RTN","TMGXPDR",74,0) . . kill XPDArray(node) "RTN","TMGXPDR",75,0) . . set XPDArray(node_"*")="" "RTN","TMGXPDR",76,0) "RTN","TMGXPDR",77,0) do NOINT^%RSEL("XPDArray") ;"creates %ZR - an array of existing routines matching input request "RTN","TMGXPDR",78,0) set XPDJ="" "RTN","TMGXPDR",79,0) for do quit:XPDJ="" "RTN","TMGXPDR",80,0) . set XPDJ=$order(%ZR(XPDJ)) "RTN","TMGXPDR",81,0) . if XPDJ="" quit "RTN","TMGXPDR",82,0) . if $data(XPDN(0,XPDJ)) quit ;"if name XPDJ is in the exclude list, skip "RTN","TMGXPDR",83,0) . if $order(^DIC(9.8,"B",XPDJ,0)) quit ;"if name XPDJ is already in Routine file, skip "RTN","TMGXPDR",84,0) . ;"check if XPDJ is refered in the EXCLUDED namespace by checking the subscript before XPDJ "RTN","TMGXPDR",85,0) . set %=$order(XPDN(0,XPDJ),-1) "RTN","TMGXPDR",86,0) . ;"if sub exist and $piece(XPDJ,sub)="" then it is part of the namespace, quit "RTN","TMGXPDR",87,0) . if ($length(%)>0)&($piece(XPDJ,%)="") quit "RTN","TMGXPDR",88,0) . ;"Add routine to ROUTINE file "RTN","TMGXPDR",89,0) . new XPD "RTN","TMGXPDR",90,0) . set XPD(9.8,"+1,",.01)=XPDJ "RTN","TMGXPDR",91,0) . set XPD(9.8,"+1,",1)="R" "RTN","TMGXPDR",92,0) . do ADD^DICA("","XPD") "RTN","TMGXPDR",93,0) . write "Added: ",XPDJ,! "RTN","TMGXPDR",94,0) . set addCount=addCount+1 "RTN","TMGXPDR",95,0) UPDTQ "RTN","TMGXPDR",96,0) write " ...Done.",! "RTN","TMGXPDR",97,0) if addCount=0 write "ROUTINE file already up to date. No additions needed.",! "RTN","TMGXPDR",98,0) else write addCount," entries added to ROUTINE file.",! "RTN","TMGXPDR",99,0) write "Leaving ROUTINE File Updater.",! "RTN","TMGXPDR",100,0) quit "RTN","TMGXPDR",101,0) "RTN","TMGXPDR",102,0) ;"---------------------------------------------------------------------------- "RTN","TMGXPDR",103,0) "RTN","TMGXPDR",104,0) ;"loop thru include list XPDN(1,*), i.e. included nodes-->requested namespaces "RTN","TMGXPDR",105,0) ;"Goal: to consider each requested namespace... "RTN","TMGXPDR",106,0) "RTN","TMGXPDR",107,0) ;"Pseudocode: "RTN","TMGXPDR",108,0) ;" loop (through all requested namespaces) "RTN","TMGXPDR",109,0) ;" XPDI = currently considered namespace "RTN","TMGXPDR",110,0) ;" loop (through all available routines--starting at XPDI) "RTN","TMGXPDR",111,0) ;" XPDJ is current routine name being considered -- from all available routines "RTN","TMGXPDR",112,0) ;" if current routine name (XPDJ) is in exclude list, skip "RTN","TMGXPDR",113,0) ;" if current routine name (XPDJ) is already in the ROUTINE file, then skip "RTN","TMGXPDR",114,0) ;" ... (to be completed) "RTN","TMGXPDR",115,0) "RTN","TMGXPDR",116,0) ;set XPDI="" "RTN","TMGXPDR",117,0) ;for do quit:XPDI="" "RTN","TMGXPDR",118,0) ;. set XPDI=$order(XPDN(1,XPDI)) "RTN","TMGXPDR",119,0) ;. quit:XPDI="" "RTN","TMGXPDR",120,0) ;. set XPDJ=XPDI "RTN","TMGXPDR",121,0) ;. if '$data(^$routine(XPDJ)) quit "RTN","TMGXPDR",122,0) ;. for set XPDJ=$order(^$routine(XPDJ)) quit:(XPDJ="")!($piece(XPDJ,XPDI)]"") do "RTN","TMGXPDR",123,0) ;. . if $data(XPDN(0,XPDJ)) quit ;"if name XPDJ is in the exclude list, XPDN(0,XPDJ) quit "RTN","TMGXPDR",124,0) ;. . if $order(^DIC(9.8,"B",XPDJ,0)) quit ;"if name XPDJ is in Routine file, quit "RTN","TMGXPDR",125,0) ;. . ;"check if XPDJ is refered in the EXCLUDED namespace by checking the subscript before XPDJ "RTN","TMGXPDR",126,0) ;. . set %=$order(XPDN(0,XPDJ),-1) "RTN","TMGXPDR",127,0) ;. . ;"if sub exist and $piece(XPDJ,sub)="" then it is part of the namespace, quit "RTN","TMGXPDR",128,0) ;. . if ($length(%)>0)&($piece(XPDJ,%)="") quit ;"e.g $piece("TMGTEST", "RTN","TMGXPDR",129,0) ;. . new XPD "RTN","TMGXPDR",130,0) ;. . set XPD(9.8,"+1,",.01)=XPDJ "RTN","TMGXPDR",131,0) ;. . set XPD(9.8,"+1,",1)="R" "RTN","TMGXPDR",132,0) ;. . do ADD^DICA("","XPD") "RTN","TMGXPDR",133,0) ;write " ...Done.",! "RTN","TMGXPDR",134,0) ;quit "RTN","TMGXPDR",135,0) "RTN","TMGXPDR",136,0) VER ;verify Routine file "RTN","TMGXPDR",137,0) N DIR,DIRUT,X,Y "RTN","TMGXPDR",138,0) W !,"I will delete all entries in the ROUTINE file in which",!,"the Routine no longer exist on this system!",! "RTN","TMGXPDR",139,0) S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR "RTN","TMGXPDR",140,0) Q:'Y!$D(DIRUT) D DELRTN "RTN","TMGXPDR",141,0) W " ...Done.",! "RTN","TMGXPDR",142,0) Q "RTN","TMGXPDR",143,0) DELRTN ;delete routine file entries "RTN","TMGXPDR",144,0) N DA,DIK,Y,count,max,delNum "RTN","TMGXPDR",145,0) S DIK="^DIC(9.8,",DA=0,count=0,max=0,delNum=0 "RTN","TMGXPDR",146,0) ;" F S DA=$O(^DIC(9.8,DA)) Q:'DA S Y=$G(^(DA,0)) I $P(Y,U,2)="R",$T(^@$P(Y,U))="" D ^DIK "RTN","TMGXPDR",147,0) do INIT^XPDID "RTN","TMGXPDR",148,0) for set DA=$order(^DIC(9.8,DA)) quit:'DA set max=max+1 "RTN","TMGXPDR",149,0) if max=0 set max=1 "RTN","TMGXPDR",150,0) set XPDIDTOT=max "RTN","TMGXPDR",151,0) do TITLE^XPDID("Scanning for Entries to Remove...") "RTN","TMGXPDR",152,0) set DA=0 "RTN","TMGXPDR",153,0) write !,"Starting search...",! "RTN","TMGXPDR",154,0) for set DA=$order(^DIC(9.8,DA)) quit:'DA do "RTN","TMGXPDR",155,0) . set count=count+1 "RTN","TMGXPDR",156,0) . if count#50=0 do UPDATE^XPDID(count) "RTN","TMGXPDR",157,0) . set Y=$G(^(DA,0)) "RTN","TMGXPDR",158,0) . if ($piece(Y,U,2)="R")&($text(^@$piece(Y,U))="") do "RTN","TMGXPDR",159,0) . . write "Removing: ",$piece(Y,U),! "RTN","TMGXPDR",160,0) . . set delNum=delNum+1 "RTN","TMGXPDR",161,0) . . do ^DIK "RTN","TMGXPDR",162,0) write ! "RTN","TMGXPDR",163,0) if delNum>0 do "RTN","TMGXPDR",164,0) . new temp "RTN","TMGXPDR",165,0) . write "Done scanning. ",delNum," Entries removed.",! "RTN","TMGXPDR",166,0) . read "Please press [ENTER] to continue.",temp:$get(DTIME,3600),! "RTN","TMGXPDR",167,0) do EXIT^XPDID() "RTN","TMGXPDR",168,0) quit "RTN","TMGXPDR",169,0) PURGE ;purge file "RTN","TMGXPDR",170,0) N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z "RTN","TMGXPDR",171,0) S DIR("?")="Enter the file you want to purge the data from.",DIR(0)="SM^B:Build;I:Install;ALL:Build & Install",DIR("A")="Purge from what file(s)" "RTN","TMGXPDR",172,0) D ^DIR Q:$D(DIRUT) "RTN","TMGXPDR",173,0) S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7 "RTN","TMGXPDR",174,0) K DIR S DIR("?")="Enter the number of Versions to keep in the file, for each package",DIR(0)="N^0:100:0",DIR("A")="Versions to Retain",DIR("B")=1 "RTN","TMGXPDR",175,0) D ^DIR Q:$D(DIRUT) S XPDN=Y "RTN","TMGXPDR",176,0) K DIR "RTN","TMGXPDR",177,0) S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL" "RTN","TMGXPDR",178,0) F D ^DIR Q:$D(DIRUT) S XPD(X)="" Q:X="ALL" K DIR("B") S DIR("A")="Another Package Name" "RTN","TMGXPDR",179,0) Q:'$D(XPD) "RTN","TMGXPDR",180,0) ;if they want all, make sure all is the only one "RTN","TMGXPDR",181,0) I $D(XPD("ALL")) K XPD S XPD("ALL")="" "RTN","TMGXPDR",182,0) ;XPDF(1) is defined if doing both files, do purge twice "RTN","TMGXPDR",183,0) K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1)) "RTN","TMGXPDR",184,0) I '$D(^TMP($J)) W !!,"No match found" Q "RTN","TMGXPDR",185,0) K XPD,DIR "RTN","TMGXPDR",186,0) S DIR(0)="E",$P(XPDUL,"-",IOM)="" "RTN","TMGXPDR",187,0) ;if ALL, reset XPDF to next file and Do, then reset back to 9.6 "RTN","TMGXPDR",188,0) D I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D S XPDF=9.6 "RTN","TMGXPDR",189,0) .S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1 "RTN","TMGXPDR",190,0) .W @IOF D HDR "RTN","TMGXPDR",191,0) .;loop thru ^TMP($J,file,package) & show list, quit if user "^" "RTN","TMGXPDR",192,0) .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D Q:'Y "RTN","TMGXPDR",193,0) ..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):" (duplicates)",1:""),! Q:$Y<(IOSL-4) "RTN","TMGXPDR",194,0) ..D ^DIR Q:'Y "RTN","TMGXPDR",195,0) ..S XPDPG=XPDPG+1 W @IOF D HDR "RTN","TMGXPDR",196,0) S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO" "RTN","TMGXPDR",197,0) W !! D ^DIR "RTN","TMGXPDR",198,0) I $D(DIRUT)!'Y W !!,"Nothing Purged" Q "RTN","TMGXPDR",199,0) ;loop thru and delete "RTN","TMGXPDR",200,0) D I $D(XPDF(1)) S XPDF=XPDF(1) D "RTN","TMGXPDR",201,0) .S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS) "RTN","TMGXPDR",202,0) .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D "RTN","TMGXPDR",203,0) ..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA D ^DIK "RTN","TMGXPDR",204,0) Q "RTN","TMGXPDR",205,0) ; "RTN","TMGXPDR",206,0) PURGE1(XPDF) ;XPDF=file # "RTN","TMGXPDR",207,0) N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z "RTN","TMGXPDR",208,0) W "." "RTN","TMGXPDR",209,0) ;if All, loop thru B x-ref "RTN","TMGXPDR",210,0) I $D(XPD("ALL")) D "RTN","TMGXPDR",211,0) .S XPDI="" "RTN","TMGXPDR",212,0) .F S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI="" D "RTN","TMGXPDR",213,0) ..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X) "RTN","TMGXPDR",214,0) ..W "." "RTN","TMGXPDR",215,0) E S XPDI="" F S XPDI=$O(XPD(XPDI)) Q:XPDI="" D "RTN","TMGXPDR",216,0) .D PURGE2(XPDI) "RTN","TMGXPDR",217,0) .W "." "RTN","TMGXPDR",218,0) ;loop thru each package, XPDP=package name "RTN","TMGXPDR",219,0) S XPDP="" F S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP="" D "RTN","TMGXPDR",220,0) .S XPDV="",XPDL=XPDN "RTN","TMGXPDR",221,0) .;the last is the most recent, XPDN = number to retain, XPDV=version "RTN","TMGXPDR",222,0) .;XPDS=type (T/V/Z) "RTN","TMGXPDR",223,0) .F S XPDV=$O(^TMP($J,XPDF,XPDP,XPDV),-1),XPDS="" Q:'XPDV!'XPDL F S XPDS=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS),-1) Q:XPDS=""!'XPDL D "RTN","TMGXPDR",224,0) ..S Y="" F S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL D "RTN","TMGXPDR",225,0) ...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q "RTN","TMGXPDR",226,0) ...S Z="" F S Z=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y,Z),-1) Q:Z=""!'XPDL K ^(Z) S XPDL=XPDL-1 "RTN","TMGXPDR",227,0) Q "RTN","TMGXPDR",228,0) ; "RTN","TMGXPDR",229,0) PURGE2(XPDX) ;XPDX=package name "RTN","TMGXPDR",230,0) ;XPDFL=1 this is not a patch, quit when we find a patch during loop "RTN","TMGXPDR",231,0) S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*" "RTN","TMGXPDR",232,0) ;loop and find matches "RTN","TMGXPDR",233,0) D F S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0)) D "RTN","TMGXPDR",234,0) .S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y "RTN","TMGXPDR",235,0) .Q:'$D(^XPD(XPDF,Y,0)) S Z=^(0),Y=XPDS_"^"_Y "RTN","TMGXPDR",236,0) .;can't delete Installs that status isn't 'Install Completed' "RTN","TMGXPDR",237,0) .I XPDF=9.7 Q:$P(Z,U,9)<3 "RTN","TMGXPDR",238,0) .S XPDV=$$VER^XPDUTL(XPDS) "RTN","TMGXPDR",239,0) .;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs "RTN","TMGXPDR",240,0) .I XPDS["*" D Q "RTN","TMGXPDR",241,0) ..I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","TMGXPDR",242,0) ..I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$P(XPDV,"T",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","TMGXPDR",243,0) ..I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$P(XPDV,"V",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","TMGXPDR",244,0) ..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) "RTN","TMGXPDR",245,0) .;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs "RTN","TMGXPDR",246,0) .I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","TMGXPDR",247,0) .;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs "RTN","TMGXPDR",248,0) .I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","TMGXPDR",249,0) .I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","TMGXPDR",250,0) Q "RTN","TMGXPDR",251,0) PURGEH ;executable help from DIR call at PURGE+8 "RTN","TMGXPDR",252,0) W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or" "RTN","TMGXPDR",253,0) W !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0 will purge version 8.0Tx and 8.0Vx",!," XU*8.0 will purge all patches for 8.0",! "RTN","TMGXPDR",254,0) N DIR,X,Y "RTN","TMGXPDR",255,0) S DIR(0)="Y",DIR("A")="Want to see the "_$S(XPDF=9.7:"Install File",$D(XPDF(1)):"Build & Install Files",1:"Build File")_" List",DIR("B")="Y" "RTN","TMGXPDR",256,0) D ^DIR Q:'Y!$D(DIRUT) "RTN","TMGXPDR",257,0) D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1)) "RTN","TMGXPDR",258,0) Q "RTN","TMGXPDR",259,0) ; "RTN","TMGXPDR",260,0) DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien "RTN","TMGXPDR",261,0) ;returns Y=DA^dup DA^dup DA... "RTN","TMGXPDR",262,0) N Y S Y="" "RTN","TMGXPDR",263,0) F S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1 S Y=Y_"^"_Z1 "RTN","TMGXPDR",264,0) Q Y "RTN","TMGXPDR",265,0) ; "RTN","TMGXPDR",266,0) PURGEH1(DIC) ; "RTN","TMGXPDR",267,0) W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File" "RTN","TMGXPDR",268,0) S DIC(0)="QE",X="??" D ^DIC "RTN","TMGXPDR",269,0) Q "RTN","TMGXPDR",270,0) ; "RTN","TMGXPDR",271,0) HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, " "RTN","TMGXPDR",272,0) I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions") "RTN","TMGXPDR",273,0) E W "Don't retain any versions" "RTN","TMGXPDR",274,0) W ?70,"PAGE ",XPDPG,!,XPDUL,! "RTN","TMGXPDR",275,0) Q "RTN","TMGXSBOX") 0^107^B6893011 "RTN","TMGXSBOX",1,0) TMGXGSBOX ;SFISC/VYD - screen rectengular region primitives ;10/31/94 15:38 "RTN","TMGXSBOX",2,0) ;;8.0;KERNEL;;5/5/2007 by //kt "RTN","TMGXSBOX",3,0) ; "RTN","TMGXSBOX",4,0) FRAME(T,L,B,R,A,C) ;draw a border "RTN","TMGXSBOX",5,0) ;TOP,LEFT,BOTTOM,RIGHT,ATTRIBUTE,frame character "RTN","TMGXSBOX",6,0) N %,%L2,%R2,M,S,X,Y ;M=middle S=string "RTN","TMGXSBOX",7,0) N XGSAVATR "RTN","TMGXSBOX",8,0) I B'>T N IOBLC,IOBRC S (IOBLC,IOBRC)=IOHL ;to draw horizontal line "RTN","TMGXSBOX",9,0) I R'>L N IOTRC,IOBRC S (IOTRC,IOBRC)=IOVL ;to draw vertical line "RTN","TMGXSBOX",10,0) S M=R-L-1 "RTN","TMGXSBOX",11,0) S %L2=L+1,%R2=R+1 "RTN","TMGXSBOX",12,0) ;if frame character passed set frame parts to it, disable graphics "RTN","TMGXSBOX",13,0) S:$L($G(C)) (IOBLC,IOBRC,IOHL,IOTLC,IOTRC,IOVL)=C "RTN","TMGXSBOX",14,0) S XGSAVATR=XGCURATR ;save current screen attributes "RTN","TMGXSBOX",15,0) W $$CHG^XGSA($G(A)_$S($L($G(C)):"",1:"G1")) ;turn on gr attr & leave on "RTN","TMGXSBOX",16,0) S S=IOTLC_$TR($J("",M)," ",IOHL)_IOTRC "RTN","TMGXSBOX",17,0) S $E(XGSCRN(T,0),%L2,%R2)=S "RTN","TMGXSBOX",18,0) S $E(XGSCRN(T,1),%L2,%R2)=$TR($J("",(R-L+1))," ",XGCURATR) "RTN","TMGXSBOX",19,0) ;W $$IOXY^TMGXGS(T,L)_S ;top line with corners ;"//kt "RTN","TMGXSBOX",20,0) DO CLIOXY^TMGXGS(T,L,S) ;top line with corners ;"//kt "RTN","TMGXSBOX",21,0) F Y=T+1:1:B-1 D "RTN","TMGXSBOX",22,0) . F X=%L2,%R2 S $E(XGSCRN(Y,0),X)=IOVL,$E(XGSCRN(Y,1),X)=XGCURATR "RTN","TMGXSBOX",23,0) . ;W $$IOXY^TMGXGS(Y,L)_IOVL_$$IOXY^TMGXGS(Y,R)_IOVL ;"//kt "RTN","TMGXSBOX",24,0) . DO CLIOXY^TMGXGS(Y,L,IOVL) DO CLIOXY^TMGXGS(Y,R,IOVL) ;"//kt "RTN","TMGXSBOX",25,0) S S=IOBLC_$TR($J("",M)," ",IOHL)_IOBRC "RTN","TMGXSBOX",26,0) S $E(XGSCRN(B,0),%L2,%R2)=S "RTN","TMGXSBOX",27,0) S $E(XGSCRN(B,1),%L2,%R2)=$TR($J("",(R-L+1))," ",XGCURATR) "RTN","TMGXSBOX",28,0) ;W $$IOXY^TMGXGS(B,L)_S ;bottom line with corners ;"//kt "RTN","TMGXSBOX",29,0) DO CLIOXY^TMGXGS(B,L,S) ;bottom line with corners ;"//kt "RTN","TMGXSBOX",30,0) W $$SET^XGSA(XGSAVATR) ;restore previous attributes "RTN","TMGXSBOX",31,0) D:$L($G(C)) GSET^%ZISS ;restore line drawing characters "RTN","TMGXSBOX",32,0) S $Y=B,$X=R "RTN","TMGXSBOX",33,0) Q "RTN","TMGXSBOX",34,0) ; "RTN","TMGXSBOX",35,0) CLEAR(T,L,B,R) ;clear a portion of the screen "RTN","TMGXSBOX",36,0) N %L2,%R2,I,M ;M=length of middle "RTN","TMGXSBOX",37,0) S %L2=L+1,%R2=R+1,M=R-L+1 "RTN","TMGXSBOX",38,0) F I=T:1:B D "RTN","TMGXSBOX",39,0) . S $E(XGSCRN(I,0),%L2,%R2)=$J("",M) "RTN","TMGXSBOX",40,0) . S $E(XGSCRN(I,1),%L2,%R2)=$TR($J("",M)," ",XGCURATR) "RTN","TMGXSBOX",41,0) . ;W $$IOXY^TMGXGS(I,L)_$J("",M) ;"//kt "RTN","TMGXSBOX",42,0) . DO CLIOXY^TMGXGS(I,L,$J("",M)) ;"//kt "RTN","TMGXSBOX",43,0) S $Y=B,$X=R "RTN","TMGXSBOX",44,0) Q "RTN","TMGXUP") 0^108^B98358 "RTN","TMGXUP",1,0) TMGXUP ;TMG/kst/Altered version of XUP ;03/25/06 "RTN","TMGXUP",2,0) ;;1.0;TMG-LIB;**1**;12/23/05 "RTN","TMGXUP",3,0) "RTN","TMGXUP",4,0) ;"Customized version of Vista XUP module "RTN","TMGXUP",5,0) ;"=================================================================================== "RTN","TMGXUP",6,0) ;"The following section started as essentially a copy of ^XUP code, to allow me to "RTN","TMGXUP",7,0) ;" use just part of it to set up the programmers environment "RTN","TMGXUP",8,0) ;"...As time has gone on, though, I have added more tweaks... "RTN","TMGXUP",9,0) ;"=================================================================================== "RTN","TMGXUP",10,0) XUP() "RTN","TMGXUP",11,0) ;"Purpose: Because this configurator will be working with the database, "RTN","TMGXUP",12,0) ;" it must have a proper environment setup. And user must have "RTN","TMGXUP",13,0) ;" proper access. So this function will set up everything needed. "RTN","TMGXUP",14,0) ;"Output: Environmental variables are setup. "RTN","TMGXUP",15,0) ;"Result: 1=OK to continue. 0=Abort "RTN","TMGXUP",16,0) "RTN","TMGXUP",17,0) ;"Consider: "RTN","TMGXUP",18,0) ;"DT^DICRW: Required Variables "RTN","TMGXUP",19,0) ;"Sets up the required variables of VA FileMan. There are no input variables; "RTN","TMGXUP",20,0) ;"simply call the routine at this entry point. "RTN","TMGXUP",21,0) ;"NOTE: This entry point kills the variables DIC and DIK. "RTN","TMGXUP",22,0) "RTN","TMGXUP",23,0) new result set result=cOKToCont "RTN","TMGXUP",24,0) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"^XUP") "RTN","TMGXUP",25,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Inside XML Scripter, setting up programmer environment.") "RTN","TMGXUP",26,0) "RTN","TMGXUP",27,0) ;"MSC/SGS: added to allow processes to be interrupted "RTN","TMGXUP",28,0) set $ZINT="X ^%ZOSF(""INTERRUPT"")" "RTN","TMGXUP",29,0) Set U="^" "RTN","TMGXUP",30,0) "RTN","TMGXUP",31,0) goto XLp2 ;"bypass next section "RTN","TMGXUP",32,0) ;"-------------------------------------------------------------------- "RTN","TMGXUP",33,0) ;"Set up user info. "RTN","TMGXUP",34,0) set DIC=200 ;"file 200 = ^VA(200,*) "RTN","TMGXUP",35,0) set DIC(0)="MZ" ;" "AEQMZ" "RTN","TMGXUP",36,0) set X="TMGXINST,BOT" "RTN","TMGXUP",37,0) ;"set X="Dodd,Norman" ;"Note: came pre-installed in OpenVistA "RTN","TMGXUP",38,0) do ^DIC "RTN","TMGXUP",39,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Y=",Y) "RTN","TMGXUP",40,0) if Y<0 set result=cAbort goto XUPDone "RTN","TMGXUP",41,0) kill DIC "RTN","TMGXUP",42,0) set DUZ=+Y "RTN","TMGXUP",43,0) set DUZ(0)=$piece(Y(0),U,4) "RTN","TMGXUP",44,0) set DTIME=600 "RTN","TMGXUP",45,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"DUZ(0)=",DUZ(0)) "RTN","TMGXUP",46,0) if DUZ(0)'="@" do goto XUPAbort "RTN","TMGXUP",47,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to setup a user with programmer's access privilages.") "RTN","TMGXUP",48,0) ;"-------------------------------------------------------------------- "RTN","TMGXUP",49,0) "RTN","TMGXUP",50,0) XLp2 "RTN","TMGXUP",51,0) new User,UName "RTN","TMGXUP",52,0) set User=$get(^VA(200,1,0)) "RTN","TMGXUP",53,0) if User="" do goto XUPAbort "RTN","TMGXUP",54,0) . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to access user #1 (expected to be IRM,MGR). The installer should be modified to log in as another user. Sorry. Quiting.") "RTN","TMGXUP",55,0) set UName=$piece(User,"^",1) "RTN","TMGXUP",56,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Logging in as user: ",UName) "RTN","TMGXUP",57,0) set LoggedUsr=UName ;" setup global-scope variable that script can access "RTN","TMGXUP",58,0) set UName=$piece(User,"^",1) "RTN","TMGXUP",59,0) kill DIC "RTN","TMGXUP",60,0) set DUZ=1 "RTN","TMGXUP",61,0) set DUZ(0)=$piece(User,"^",4) "RTN","TMGXUP",62,0) set DTIME=600 "RTN","TMGXUP",63,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"DUZ(0)=",DUZ(0)) "RTN","TMGXUP",64,0) if DUZ(0)'="@" do "RTN","TMGXUP",65,0) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Temporarily giving install-user '@' privilages.") "RTN","TMGXUP",66,0) . set DUZ(0)="@" "RTN","TMGXUP",67,0) "RTN","TMGXUP",68,0) XLp3 "RTN","TMGXUP",69,0) do HOME^%ZIS ;"Reset Home Device IO Variables "RTN","TMGXUP",70,0) "RTN","TMGXUP",71,0) new $ESTACK,$ETRAP "RTN","TMGXUP",72,0) set $ECODE="",$ETRAP="" ;"Clear and error trap "RTN","TMGXUP",73,0) xecute ^%ZOSF("TYPE-AHEAD") "RTN","TMGXUP",74,0) "RTN","TMGXUP",75,0) kill ^UTILITY($J) "RTN","TMGXUP",76,0) kill ^XUTL("XQ",$J) "RTN","TMGXUP",77,0) do KILL1 ;"do KILL1^XUSCLEAN "RTN","TMGXUP",78,0) "RTN","TMGXUP",79,0) set DT=$$DT^XLFDT ;"DT is a system=wide date variable "RTN","TMGXUP",80,0) "RTN","TMGXUP",81,0) set XUEOFF=^%ZOSF("EOFF") "RTN","TMGXUP",82,0) set XUEON=^%ZOSF("EON") "RTN","TMGXUP",83,0) set U="^" "RTN","TMGXUP",84,0) set XUTT=0 "RTN","TMGXUP",85,0) set XUIOP="" "RTN","TMGXUP",86,0) do GETENV^%ZOSV "RTN","TMGXUP",87,0) set XUENV=Y "RTN","TMGXUP",88,0) set XUVOL=$piece(Y,U,2) "RTN","TMGXUP",89,0) set XUCI=$piece(Y,U,1) "RTN","TMGXUP",90,0) "RTN","TMGXUP",91,0) ;"Get user info "RTN","TMGXUP",92,0) if $get(DUZ)>0 do "RTN","TMGXUP",93,0) . kill XUDUZ "RTN","TMGXUP",94,0) . if $data(DUZ(0)) set XUDUZ=DUZ(0) "RTN","TMGXUP",95,0) . do DUZ^XUP(DUZ) "RTN","TMGXUP",96,0) . if $data(XUDUZ) set DUZ(0)=XUDUZ "RTN","TMGXUP",97,0) . kill XUDUZ "RTN","TMGXUP",98,0) "RTN","TMGXUP",99,0) if ($get(DUZ)'>0)!(('$data(DUZ(0)))) do ASKDUZ^XUP goto:Y'>0 XUPAbort "RTN","TMGXUP",100,0) "RTN","TMGXUP",101,0) if '$data(XQUSER) set XQUSER=$S($data(^VA(200,DUZ,20)):$piece(^(20),"^",2),1:"Unk") "RTN","TMGXUP",102,0) set DTIME=600 ;Set a temp DTIME "RTN","TMGXUP",103,0) "RTN","TMGXUP",104,0) ;"Getting Terminal Type "RTN","TMGXUP",105,0) ;"if XUTT do ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2 "RTN","TMGXUP",106,0) if 'XUTT goto ZIS2a "RTN","TMGXUP",107,0) do ENQ^XUS1 "RTN","TMGXUP",108,0) if $data(XUIOP(1)) goto ZIS2 "RTN","TMGXUP",109,0) set Y=0 "RTN","TMGXUP",110,0) do TT^XUS3 "RTN","TMGXUP",111,0) if Y>0 set XUIOP(1)=$P(XUIOP,";",2) "RTN","TMGXUP",112,0) goto ZIS2 "RTN","TMGXUP",113,0) ZIS2a "RTN","TMGXUP",114,0) set X="`"_+$G(^VA(200,DUZ,1.2)) "RTN","TMGXUP",115,0) set DIC="^%ZIS(2," "RTN","TMGXUP",116,0) set DIC(0)="MQ"_$S(X]"`0":"",1:"AE") "RTN","TMGXUP",117,0) do ^DIC "RTN","TMGXUP",118,0) if Y'>0 goto XUPAbort "RTN","TMGXUP",119,0) set XUIOP(1)=$P(Y,U,2) "RTN","TMGXUP",120,0) if DIC(0)["A",$get(^VA(200,+DUZ,0))]"" set $piece(^VA(200,DUZ,1.2),U,1)=+Y "RTN","TMGXUP",121,0) "RTN","TMGXUP",122,0) ZIS2 "RTN","TMGXUP",123,0) set %ZIS="L" ;"will cause IO("ZIO") to contain static physical port name "RTN","TMGXUP",124,0) set IOP="HOME;"_XUIOP(1) "RTN","TMGXUP",125,0) do ^%ZIS ;"Set up device handler "RTN","TMGXUP",126,0) if POP goto XUPAbort ;"POP has error from ^%ZIS "RTN","TMGXUP",127,0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Using terminal type: ",IOST) "RTN","TMGXUP",128,0) set DTIME=$$DTIME^XUP(DUZ,IOS) "RTN","TMGXUP",129,0) set DUZ("BUF")=1 "RTN","TMGXUP",130,0) set XUDEV=IOS "RTN","TMGXUP",131,0) "RTN","TMGXUP",132,0) ;"Save info, Set last sign-on "RTN","TMGXUP",133,0) do SAVE^XUS1 "RTN","TMGXUP",134,0) set $piece(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT ;DT "RTN","TMGXUP",135,0) "RTN","TMGXUP",136,0) ;"Setup error trap "RTN","TMGXUP",137,0) if $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") set $ETRAP="D ERR^XUP" "RTN","TMGXUP",138,0) ;do KILL1 ;"do KILL1^XUSCLEAN "RTN","TMGXUP",139,0) set $piece(XQXFLG,U,3)="XUP" "RTN","TMGXUP",140,0) "RTN","TMGXUP",141,0) ;"D ^XQ1 ;<----- one major change made to this code... "RTN","TMGXUP",142,0) "RTN","TMGXUP",143,0) XUPDone "RTN","TMGXUP",144,0) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"^XUP") "RTN","TMGXUP",145,0) quit result "RTN","TMGXUP",146,0) "RTN","TMGXUP",147,0) XUPAbort "RTN","TMGXUP",148,0) do KILL1 ;"do KILL1^XUSCLEAN "RTN","TMGXUP",149,0) kill XQY,XQY0 "RTN","TMGXUP",150,0) if $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$data(^%ZVEMS) xecute ^%ZVEMS ;"Run VPE "RTN","TMGXUP",151,0) "RTN","TMGXUP",152,0) set result=cAbort "RTN","TMGXUP",153,0) goto XUPDone "RTN","TMGXUP",154,0) "RTN","TMGXUP",155,0) KILL1 "RTN","TMGXUP",156,0) ;"-------------------------------- "RTN","TMGXUP",157,0) ;"KILL1^XUSCLEAN is included and modified below. "RTN","TMGXUP",158,0) ;"Purpose: To clean up ALL but kernel variables. "RTN","TMGXUP",159,0) ;"------------------------------- "RTN","TMGXUP",160,0) If $$BROKER^XWBLIB do "RTN","TMGXUP",161,0) . set %2=$piece($text(VARLST^XWBLIB),";;",2) "RTN","TMGXUP",162,0) . if %2]"" new @%2 ;"Protect Broker variables. "RTN","TMGXUP",163,0) "RTN","TMGXUP",164,0) new KWAPI,XGWIN,XGDI,XGEVENT "RTN","TMGXUP",165,0) new XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID "RTN","TMGXUP",166,0) "RTN","TMGXUP",167,0) kill IO("C"),IO("Q") "RTN","TMGXUP",168,0) "RTN","TMGXUP",169,0) ;"Note: kill (x) mean kill everything EXCEPT x "RTN","TMGXUP",170,0) ;"I can't kill everthing because it will crash my script--so I'll just not do it. "RTN","TMGXUP",171,0) ;"kill (DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,U,DUZ,DUZ,DTIME,DT) "RTN","TMGXUP",172,0) "RTN","TMGXUP",173,0) quit "RTN","TMGXUP",174,0) "RTN","TMGXUP",175,0) ;"=================================================================================== "RTN","TMGXUS2") 0^109^B55991259 "RTN","TMGXUS2",1,0) TMGXUS2 ;TMG/kst/Altered version of XUS2 ;03/25/06 "RTN","TMGXUS2",2,0) ;;1.0;TMG-LIB;**1**;12/23/05 "RTN","TMGXUS2",3,0) "RTN","TMGXUS2",4,0) XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;07/15/2003 12:20 "RTN","TMGXUS2",5,0) ;;8.0;KERNEL;**59,180,313**;Jul 10, 1995 "RTN","TMGXUS2",6,0) G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY "RTN","TMGXUS2",7,0) USER G USER^XUVERIFY "RTN","TMGXUS2",8,0) EDIT G EDIT^XUVERIFY "RTN","TMGXUS2",9,0) Q "RTN","TMGXUS2",10,0) ; "RTN","TMGXUS2",11,0) ACCED ; ACCESS CODE EDIT from DD "RTN","TMGXUS2",12,0) N DIR,DIR0,XUAUTO I "Nn"[$E(X,1) S X="" Q "RTN","TMGXUS2",13,0) I "Yy"'[$E(X,1) K X Q "RTN","TMGXUS2",14,0) S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH="" "RTN","TMGXUS2",15,0) AC1 D CLR,AUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH) "RTN","TMGXUS2",16,0) G OUT "RTN","TMGXUS2",17,0) ; "RTN","TMGXUS2",18,0) AASK N X,XUU X ^%ZOSF("EOFF") "RTN","TMGXUS2",19,0) AASK1 W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT) "RTN","TMGXUS2",20,0) I X="@" D DEL G:Y'=1 DIRUT S XUH="" Q "RTN","TMGXUS2",21,0) ;"K. Toppenberg modified 11-19-04 to relax requirements "RTN","TMGXUS2",22,0) I X[$C(34)!(X[";")!(X["^")!(X[":")!($L(X)>20)!($L(X)<5)!(X="MAIL-BOX") D CLR W *7,$$AVHLPTXT(1) D AHELP G AASK1 "RTN","TMGXUS2",23,0) ;"//kt I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W *7,$$AVHLPTXT(1) D AHELP G AASK1 "RTN","TMGXUS2",24,0) ;"//kt I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W *7,"ACCESS CODE must be a mix of alpha and numerics.",! G AASK1 "RTN","TMGXUS2",25,0) S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) "RTN","TMGXUS2",26,0) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB "RTN","TMGXUS2",27,0) I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W *7,"This has been used previously as an ACCESS CODE.",! G AASK1 "RTN","TMGXUS2",28,0) Q "RTN","TMGXUS2",29,0) ; "RTN","TMGXUS2",30,0) REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF") "RTN","TMGXUS2",31,0) F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X) D CLR W "This doesn't match. Try again!",!,*7 "RTN","TMGXUS2",32,0) S:XUH'=X XUK=0 "RTN","TMGXUS2",33,0) Q "RTN","TMGXUS2",34,0) ; "RTN","TMGXUS2",35,0) AST(XUH) ;Change ACCESS CODE and index. "RTN","TMGXUS2",36,0) W "OK, Access code has been changed!" "RTN","TMGXUS2",37,0) ;S XUU=$P(^VA(200,DA,0),"^",3),$P(^VA(200,DA,0),"^",3)=XUH "RTN","TMGXUS2",38,0) ;I XUU]"" F XUI=0:0 S X=XUU S XUI=$O(^DD(200,2,1,XUI)) Q:XUI'>0 X ^(XUI,2) "RTN","TMGXUS2",39,0) ;I XUH]"" F XUI=0:0 S X=XUH S XUI=$O(^DD(200,2,1,XUI)) Q:XUI'>0 X ^(XUI,1) "RTN","TMGXUS2",40,0) N FDA,IEN,ERR "RTN","TMGXUS2",41,0) S IEN=DA_"," "RTN","TMGXUS2",42,0) S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR") "RTN","TMGXUS2",43,0) W !,"The VERIFY CODE has been deleted as a security measure.",!,"The user will have to enter a new one the next time they sign-on.",*7 D VST("",1) "RTN","TMGXUS2",44,0) I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox "RTN","TMGXUS2",45,0) Q "RTN","TMGXUS2",46,0) ; "RTN","TMGXUS2",47,0) GET ;Get the user input and convert case. "RTN","TMGXUS2",48,0) S X=$$ACCEPT^XUS Q:X="@" G:(X["^")!('$L(X)) DIRUT "RTN","TMGXUS2",49,0) S X=$$UP^XLFSTR(X) "RTN","TMGXUS2",50,0) Q "RTN","TMGXUS2",51,0) ; "RTN","TMGXUS2",52,0) DIRUT S DIRUT=1 "RTN","TMGXUS2",53,0) Q "RTN","TMGXUS2",54,0) ; "RTN","TMGXUS2",55,0) CLR I '$D(DDS) W ! Q "RTN","TMGXUS2",56,0) N DX,DY "RTN","TMGXUS2",57,0) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY "RTN","TMGXUS2",58,0) Q "RTN","TMGXUS2",59,0) ; "RTN","TMGXUS2",60,0) NEWCODE D REASK I XUK W !,"OK, remember this code for next time!" "RTN","TMGXUS2",61,0) G OUT "RTN","TMGXUS2",62,0) ; "RTN","TMGXUS2",63,0) CVC ;From XUS1 "RTN","TMGXUS2",64,0) W !,"You must change your VERIFY CODE at this time." S DA=DUZ,X="Y" "RTN","TMGXUS2",65,0) VERED ; VERIFY CODE EDIT From DD "RTN","TMGXUS2",66,0) N DIR,DIR0 I "Nn"[$E(X,1) S X="" Q "RTN","TMGXUS2",67,0) I "Yy"'[$E(X,1) K X Q "RTN","TMGXUS2",68,0) S XUH="" "RTN","TMGXUS2",69,0) VC1 D CLR,VASK G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1) "RTN","TMGXUS2",70,0) D CALL^XUSERP(DA,2) "RTN","TMGXUS2",71,0) G OUT "RTN","TMGXUS2",72,0) ; "RTN","TMGXUS2",73,0) VASK N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR "RTN","TMGXUS2",74,0) VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT) "RTN","TMGXUS2",75,0) I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q "RTN","TMGXUS2",76,0) D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W *7,$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1 "RTN","TMGXUS2",77,0) Q "RTN","TMGXUS2",78,0) ; "RTN","TMGXUS2",79,0) VCHK(S,EC) ;Call with String and Encripted versions "RTN","TMGXUS2",80,0) ;Updated per VHA directive 6210 Strong Passwords "RTN","TMGXUS2",81,0) ;"Kevin Toppenberg modified this 11-19-04 to relax password ("verify code") requirements. "RTN","TMGXUS2",82,0) ;" .. now it must just be length 8-20 "RTN","TMGXUS2",83,0) N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/" "RTN","TMGXUS2",84,0) S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA) "RTN","TMGXUS2",85,0) I ($L(S)<5)!($L(S)>20)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT "RTN","TMGXUS2",86,0) ;"//I ($L(S)<8)!($L(S)>20)!(S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT "RTN","TMGXUS2",87,0) ;"//kt I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation." "RTN","TMGXUS2",88,0) ;"//kt I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one." "RTN","TMGXUS2",89,0) ;"//kt I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE." "RTN","TMGXUS2",90,0) ;"//kt I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE." "RTN","TMGXUS2",91,0) ;"//kt I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code." "RTN","TMGXUS2",92,0) Q 0 "RTN","TMGXUS2",93,0) ; "RTN","TMGXUS2",94,0) VST(XUH,%) W:$L(XUH)&% !,"OK, Verify code has been changed!" "RTN","TMGXUS2",95,0) ;S XUU=$P($G(^VA(200,DA,.1)),U,2) S $P(^VA(200,DA,.1),"^",1,2)=$H_"^"_XUH "RTN","TMGXUS2",96,0) ;I XUU]"" F XUI=0:0 S X=XUU S XUI=$O(^DD(200,11,1,XUI)) Q:XUI'>0 X ^(XUI,2) "RTN","TMGXUS2",97,0) ;I XUH]"" F XUI=0:0 S X=XUH S XUI=$O(^DD(200,11,1,XUI)) Q:XUI'>0 X ^(XUI,1) "RTN","TMGXUS2",98,0) N FDA,IEN,ERR S IEN=DA_"," "RTN","TMGXUS2",99,0) S:XUH="" XUH="@" ;11.2 get triggerd "RTN","TMGXUS2",100,0) S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR") "RTN","TMGXUS2",101,0) I $D(ERR) D ^%ZTER "RTN","TMGXUS2",102,0) S:DA=DUZ DUZ("NEWCODE")=XUH Q "RTN","TMGXUS2",103,0) ; "RTN","TMGXUS2",104,0) DEL ; "RTN","TMGXUS2",105,0) X ^%ZOSF("EON") W "@",*7 S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W *7," <Nothing Deleted>" "RTN","TMGXUS2",106,0) Q "RTN","TMGXUS2",107,0) ; "RTN","TMGXUS2",108,0) AUTO ; "RTN","TMGXUS2",109,0) X ^%ZOSF("EON") F XUK=1:1:3 D GEN Q:(Y=1)!($D(DIRUT)) "RTN","TMGXUS2",110,0) K DIR "RTN","TMGXUS2",111,0) Q "RTN","TMGXUS2",112,0) ; "RTN","TMGXUS2",113,0) GEN ;Generate a ACCESS code "RTN","TMGXUS2",114,0) S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G GEN "RTN","TMGXUS2",115,0) D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries." "RTN","TMGXUS2",116,0) YN S Y=1 Q:XUK=3 S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!" "RTN","TMGXUS2",117,0) D ^DIR Q:(Y=1)!$D(DIRUT) D CLR W:XUK=2 "O.K. You'll have to keep the next one!",! "RTN","TMGXUS2",118,0) Q "RTN","TMGXUS2",119,0) ; "RTN","TMGXUS2",120,0) AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP "RTN","TMGXUS2",121,0) W !,"Here is an example of an acceptable Access Code: ",XUU,! "RTN","TMGXUS2",122,0) Q "RTN","TMGXUS2",123,0) ; "RTN","TMGXUS2",124,0) VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP "RTN","TMGXUS2",125,0) W !,"Here is an example of an acceptable Verify Code: ",XUU,! "RTN","TMGXUS2",126,0) Q "RTN","TMGXUS2",127,0) ; "RTN","TMGXUS2",128,0) OUT ; "RTN","TMGXUS2",129,0) K DUOUT S:$D(DIRUT) DUOUT=1 "RTN","TMGXUS2",130,0) X ^%ZOSF("EON") W ! "RTN","TMGXUS2",131,0) K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X="" "RTN","TMGXUS2",132,0) Q "RTN","TMGXUS2",133,0) ; "RTN","TMGXUS2",134,0) CHKCUR() ;Check user knows current code, Return 1 if OK to continue "RTN","TMGXUS2",135,0) Q:DA'=DUZ 1 ;Only ask user "RTN","TMGXUS2",136,0) Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one "RTN","TMGXUS2",137,0) S XUK=0 D CLR "RTN","TMGXUS2",138,0) CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0 "RTN","TMGXUS2",139,0) I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1 "RTN","TMGXUS2",140,0) D CLR W "Sorry that is not correct!",! "RTN","TMGXUS2",141,0) S XUK=XUK+1 G:XUK<3 CHK1 "RTN","TMGXUS2",142,0) Q 0 "RTN","TMGXUS2",143,0) ; "RTN","TMGXUS2",144,0) BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad. "RTN","TMGXUS2",145,0) N XUU,XUH "RTN","TMGXUS2",146,0) Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2) "RTN","TMGXUS2",147,0) I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code" "RTN","TMGXUS2",148,0) S Y=$$VCHK(XV2,XUH) Q:Y Y "RTN","TMGXUS2",149,0) D VST(XUH,0),CALL^XUSERP(DA,2) "RTN","TMGXUS2",150,0) Q 0 "RTN","TMGXUS2",151,0) ; "RTN","TMGXUS2",152,0) AVHLPTXT(%) ; "RTN","TMGXUS2",153,0) Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')." "RTN","TMGXUS2",154,0) ; "SEC","^DIC",22706.1,22706.1,0,"AUDIT") @ "SEC","^DIC",22706.1,22706.1,0,"DD") @ "SEC","^DIC",22706.1,22706.1,0,"DEL") @ "SEC","^DIC",22706.1,22706.1,0,"LAYGO") @ "SEC","^DIC",22706.1,22706.1,0,"RD") @ "SEC","^DIC",22706.1,22706.1,0,"WR") @ "SEC","^DIC",22706.2,22706.2,0,"AUDIT") @ "SEC","^DIC",22706.2,22706.2,0,"DD") @ "SEC","^DIC",22706.2,22706.2,0,"DEL") @ "SEC","^DIC",22706.2,22706.2,0,"LAYGO") @ "SEC","^DIC",22706.2,22706.2,0,"RD") @ "SEC","^DIC",22706.2,22706.2,0,"WR") @ "SEC","^DIC",22706.3,22706.3,0,"AUDIT") @ "SEC","^DIC",22706.3,22706.3,0,"DD") @ "SEC","^DIC",22706.3,22706.3,0,"DEL") @ "SEC","^DIC",22706.3,22706.3,0,"LAYGO") @ "SEC","^DIC",22706.3,22706.3,0,"RD") @ "SEC","^DIC",22706.3,22706.3,0,"WR") @ "SEC","^DIC",22706.4,22706.4,0,"AUDIT") @ "SEC","^DIC",22706.4,22706.4,0,"DD") @ "SEC","^DIC",22706.4,22706.4,0,"DEL") @ "SEC","^DIC",22706.4,22706.4,0,"LAYGO") @ "SEC","^DIC",22706.4,22706.4,0,"RD") @ "SEC","^DIC",22706.4,22706.4,0,"WR") @ "SEC","^DIC",22706.5,22706.5,0,"AUDIT") @ "SEC","^DIC",22706.5,22706.5,0,"DD") @ "SEC","^DIC",22706.5,22706.5,0,"DEL") @ "SEC","^DIC",22706.5,22706.5,0,"LAYGO") @ "SEC","^DIC",22706.5,22706.5,0,"RD") @ "SEC","^DIC",22706.5,22706.5,0,"WR") @ "SEC","^DIC",22706.6,22706.6,0,"AUDIT") @ "SEC","^DIC",22706.6,22706.6,0,"DD") @ "SEC","^DIC",22706.6,22706.6,0,"DEL") @ "SEC","^DIC",22706.6,22706.6,0,"LAYGO") @ "SEC","^DIC",22706.6,22706.6,0,"RD") @ "SEC","^DIC",22706.6,22706.6,0,"WR") @ "SEC","^DIC",22706.7,22706.7,0,"AUDIT") @ "SEC","^DIC",22706.7,22706.7,0,"DD") @ "SEC","^DIC",22706.7,22706.7,0,"DEL") @ "SEC","^DIC",22706.7,22706.7,0,"LAYGO") @ "SEC","^DIC",22706.7,22706.7,0,"RD") @ "SEC","^DIC",22706.7,22706.7,0,"WR") @ "SEC","^DIC",22706.8,22706.8,0,"AUDIT") @ "SEC","^DIC",22706.8,22706.8,0,"DD") @ "SEC","^DIC",22706.8,22706.8,0,"DEL") @ "SEC","^DIC",22706.8,22706.8,0,"LAYGO") @ "SEC","^DIC",22706.8,22706.8,0,"RD") @ "SEC","^DIC",22706.8,22706.8,0,"WR") @ "SEC","^DIC",22706.82,22706.82,0,"AUDIT") @ "SEC","^DIC",22706.82,22706.82,0,"DD") @ "SEC","^DIC",22706.82,22706.82,0,"DEL") @ "SEC","^DIC",22706.82,22706.82,0,"LAYGO") @ "SEC","^DIC",22706.82,22706.82,0,"RD") @ "SEC","^DIC",22706.82,22706.82,0,"WR") @ "SEC","^DIC",22706.9,22706.9,0,"AUDIT") @ "SEC","^DIC",22706.9,22706.9,0,"DD") @ "SEC","^DIC",22706.9,22706.9,0,"DEL") @ "SEC","^DIC",22706.9,22706.9,0,"LAYGO") @ "SEC","^DIC",22706.9,22706.9,0,"RD") @ "SEC","^DIC",22706.9,22706.9,0,"WR") @ "VER") 8.0^22.0 "^DD",2005.2,2005.2,22700,0) TMG PRIVATE PHYSICAL REFERENCE^F^^22700;1^K:$L(X)>250!($L(X)<1) X "^DD",2005.2,2005.2,22700,3) Answer must be 1-250 characters in length "^DD",2005.2,2005.2,22700,21,0) ^^4^4^3080131^^ "^DD",2005.2,2005.2,22700,21,1,0) This field was added by TMG site to allow for a private network location "^DD",2005.2,2005.2,22700,21,2,0) that is different from the physical location specified by field#1. "^DD",2005.2,2005.2,22700,21,3,0) "^DD",2005.2,2005.2,22700,21,4,0) Enter ??? for more information. "^DD",2005.2,2005.2,22700,23,0) ^^45^45^3080131^^ "^DD",2005.2,2005.2,22700,23,1,0) This field allows for a private network address that may be different from "^DD",2005.2,2005.2,22700,23,2,0) the public physical location store in field #1 (PHYSICAL REFERENCE). "^DD",2005.2,2005.2,22700,23,3,0) "^DD",2005.2,2005.2,22700,23,4,0) For example, if field #1 is specified to be \\imageserver\images\ , then "^DD",2005.2,2005.2,22700,23,5,0) when images are stored (using data from this NETWORK LOCATION file), the "^DD",2005.2,2005.2,22700,23,6,0) location name passed to the client might be as follows: "^DD",2005.2,2005.2,22700,23,7,0) "^DD",2005.2,2005.2,22700,23,8,0) \\imageserver\images\IMAGE0001.JPG "^DD",2005.2,2005.2,22700,23,9,0) "^DD",2005.2,2005.2,22700,23,10,0) But if, instead, one wanted to keep the actual location of the files stored "^DD",2005.2,2005.2,22700,23,11,0) private, then one could put "\" into field #1, and then the actual location "^DD",2005.2,2005.2,22700,23,12,0) into this field (TMG PRIVATE PHYSICAL REFERENCE). This is dependent on using "^DD",2005.2,2005.2,22700,23,13,0) TMG UPLOAD and DOWNLOAD RPC calls that utilize this field. "^DD",2005.2,2005.2,22700,23,14,0) "^DD",2005.2,2005.2,22700,23,15,0) This field was developed by the TMG site during customization of the VistA "^DD",2005.2,2005.2,22700,23,16,0) Imaging system into a document-imaging system. The prior method used by "^DD",2005.2,2005.2,22700,23,17,0) VistA was to pass the filepath and filename that had been set up on a "^DD",2005.2,2005.2,22700,23,18,0) Windows server. The client was required to be part of this same filesystem. "^DD",2005.2,2005.2,22700,23,19,0) And the client would then store files directly. "^DD",2005.2,2005.2,22700,23,20,0) "^DD",2005.2,2005.2,22700,23,21,0) The TMG site, however, wanted to use a linux server that did not setup "^DD",2005.2,2005.2,22700,23,22,0) directory shares, and thus were not accessible to windows clients. Transfer "^DD",2005.2,2005.2,22700,23,23,0) code was created to pass binary files through the RPC Broker (using BASE64 "^DD",2005.2,2005.2,22700,23,24,0) ascii armour encoding). Thus when the client asks to save a file, it would "^DD",2005.2,2005.2,22700,23,25,0) be a security violation to allow any arbitrary directory (including "^DD",2005.2,2005.2,22700,23,26,0) sensitive locations.) "^DD",2005.2,2005.2,22700,23,27,0) "^DD",2005.2,2005.2,22700,23,28,0) Thus at the TMG site, RPC routines such as MAGGADDIMAGE (client asks to upload a file, and "^DD",2005.2,2005.2,22700,23,29,0) server prepares an appropriate filename for it) would use field #1 (PHYSICAL "^DD",2005.2,2005.2,22700,23,30,0) REFERENCE... SET TO "/") and pass back a file name like this: "^DD",2005.2,2005.2,22700,23,31,0) /FILE0001.JPG "^DD",2005.2,2005.2,22700,23,32,0) The server upload code (UPLOAD^TMGRPC1) would use TMG PRIVATE PHYSICAL "^DD",2005.2,2005.2,22700,23,33,0) REFERENCE (of '/var/local/images/') to actually store the file to: "^DD",2005.2,2005.2,22700,23,34,0) e.g. /var/local/images/FILE0001.JPG "^DD",2005.2,2005.2,22700,23,35,0) "^DD",2005.2,2005.2,22700,23,36,0) The actual file location is then a concatenation of: "^DD",2005.2,2005.2,22700,23,37,0) TMG PRIVATE PHYSICAL REFERENCE + PHYSICAL REFERENCE "^DD",2005.2,2005.2,22700,23,38,0) "^DD",2005.2,2005.2,22700,23,39,0) During use, UPLOAD^TMGRPC1 will make sure that //'s don't occur. I.e. if: "^DD",2005.2,2005.2,22700,23,40,0) TMG PRIVATE PHYSICAL REFERENCE = "/var/local/server/" and "^DD",2005.2,2005.2,22700,23,41,0) PHYSICAL REFERENCE = "/images/" "^DD",2005.2,2005.2,22700,23,42,0) then final result would be "^DD",2005.2,2005.2,22700,23,43,0) "/var/local/server/images/" "^DD",2005.2,2005.2,22700,23,44,0) not "^DD",2005.2,2005.2,22700,23,45,0) "/var/local/server//images/" "^DD",2005.2,2005.2,22700,"DT") 3050927 "^DD",2005.2,2005.2,22701,0) TMG NODE DIVIDER SYMBOL^F^^22701;1^K:$L(X)>1!($L(X)<1)!'((X="\")!(X="/")) X "^DD",2005.2,2005.2,22701,3) Answer must be 1 character in length. "^DD",2005.2,2005.2,22701,21,0) ^^7^7^3050927^^ "^DD",2005.2,2005.2,22701,21,1,0) Enter the symbol used by the file system to used directories. "^DD",2005.2,2005.2,22701,21,2,0) "^DD",2005.2,2005.2,22701,21,3,0) i.e. for Windows, would be \ "^DD",2005.2,2005.2,22701,21,4,0) and for Unix, would be / "^DD",2005.2,2005.2,22701,21,5,0) "^DD",2005.2,2005.2,22701,21,6,0) e.g. Windows: c:\dir1\dir2 "^DD",2005.2,2005.2,22701,21,7,0) Unix /dir1/dir2 "^DD",2005.2,2005.2,22701,"DT") 3050927 "^DD",2005.2,2005.2,22702,0) TMG DROPBOX PHYSICAL REFERENCE^F^^22702;1^K:$L(X)>250!($L(X)<1) X "^DD",2005.2,2005.2,22702,3) Answer must be 1-250 characters in length. "^DD",2005.2,2005.2,22702,21,0) ^^2^2^3080131^^ "^DD",2005.2,2005.2,22702,21,1,0) This should be the path that the server may use to obtain "^DD",2005.2,2005.2,22702,21,2,0) a file from the dropbox. ?? for more help. "^DD",2005.2,2005.2,22702,23,0) ^^41^41^3080131^^ "^DD",2005.2,2005.2,22702,23,1,0) Enter the name of the folder that the server will use as a drop "^DD",2005.2,2005.2,22702,23,2,0) box location. "^DD",2005.2,2005.2,22702,23,3,0) e.g.: "^DD",2005.2,2005.2,22702,23,4,0) /mnt/Winserver/dropbox/ "^DD",2005.2,2005.2,22702,23,5,0) "^DD",2005.2,2005.2,22702,23,6,0) This custom field was added at the TMG site to allow uploading "^DD",2005.2,2005.2,22702,23,7,0) of files via a 'drop box' method. "^DD",2005.2,2005.2,22702,23,8,0) "^DD",2005.2,2005.2,22702,23,9,0) Background: The original VistA setup was to have the client and "^DD",2005.2,2005.2,22702,23,10,0) server to share a custom filesystem. During requests to upload "^DD",2005.2,2005.2,22702,23,11,0) a file from CPRS, the server would pass a file path+name to CPRS "^DD",2005.2,2005.2,22702,23,12,0) and the client would directly write to the location. TMG felt "^DD",2005.2,2005.2,22702,23,13,0) this to represent poor security, as anyone on a client machine "^DD",2005.2,2005.2,22702,23,14,0) could browse the image directory directly (with a file browser) "^DD",2005.2,2005.2,22702,23,15,0) and see private images. "^DD",2005.2,2005.2,22702,23,16,0) "^DD",2005.2,2005.2,22702,23,17,0) So a RPC call was created to upload the file to the server through "^DD",2005.2,2005.2,22702,23,18,0) the RPC broker, using ASCII Armour Encoding to pass binary files. "^DD",2005.2,2005.2,22702,23,19,0) This was OK, but each file transfer took 1-10 seconds, and was too "^DD",2005.2,2005.2,22702,23,20,0) slow for higher volume settings. "^DD",2005.2,2005.2,22702,23,21,0) "^DD",2005.2,2005.2,22702,23,22,0) So this method now uses a secure 'drop box' method. It does require "^DD",2005.2,2005.2,22702,23,23,0) a shared filesystem between server and client, but ensures that the "^DD",2005.2,2005.2,22702,23,24,0) client can not browse files on the server after uploading them. "^DD",2005.2,2005.2,22702,23,25,0) The client does a file copy to the drop box drive location, and then "^DD",2005.2,2005.2,22702,23,26,0) notifies the server. The server then moves the file to a secure "^DD",2005.2,2005.2,22702,23,27,0) private location. Later, when the client needs the file back, the "^DD",2005.2,2005.2,22702,23,28,0) process is reversed: the server is asked for the file, the file is "^DD",2005.2,2005.2,22702,23,29,0) moved to the drop box, and the client moves it to its needed location. "^DD",2005.2,2005.2,22702,23,30,0) "^DD",2005.2,2005.2,22702,23,31,0) This will still be slightly slower than direct access, but provides "^DD",2005.2,2005.2,22702,23,32,0) more security. It depends on the client to delete the file from the "^DD",2005.2,2005.2,22702,23,33,0) dropbox, and from its local client location after finishing use. "^DD",2005.2,2005.2,22702,23,34,0) "^DD",2005.2,2005.2,22702,23,35,0) Note: the client will probably have a different name for the drop box "^DD",2005.2,2005.2,22702,23,36,0) location, and client configuration will be required as well. "^DD",2005.2,2005.2,22702,23,37,0) E.g. "^DD",2005.2,2005.2,22702,23,38,0) Linux server has dropbox at /mnt/Winserver/dropbox/ "^DD",2005.2,2005.2,22702,23,39,0) Windows Client has access to dropbox at V:\Dropbox\ "^DD",2005.2,2005.2,22702,23,40,0) "^DD",2005.2,2005.2,22702,23,41,0) This field stores only the server dropbox location. "^DD",2005.2,2005.2,22702,"DT") 3080131 "^DD",8925.1,8925.1,0) FIELD^^99^48 "^DD",8925.1,8925.1,0,"DDA") N "^DD",8925.1,8925.1,0,"DT") 2970227 "^DD",8925.1,8925.1,0,"ID","W.04") W " ",@("$P($P($C(59)_$S($D(^DD(8925.1,.04,0)):$P(^(0),U,3),1:0)_$E("_DIC_"Y,0),0),$C(59)_$P(^(0),U,4)_"":"",2),$C(59),1)") "^DD",8925.1,8925.1,0,"IX","AC",8925.1,.06) "^DD",8925.1,8925.1,0,"IX","ACL",8925.1,.01) "^DD",8925.1,8925.1,0,"IX","ACL02",8925.1,.02) "^DD",8925.1,8925.1,0,"IX","ACL03",8925.1,.03) "^DD",8925.1,8925.1,0,"IX","ACL07",8925.1,.07) "^DD",8925.1,8925.1,0,"IX","ACL1001",8925.14,.01) "^DD",8925.1,8925.1,0,"IX","AD",8925.14,.01) "^DD",8925.1,8925.1,0,"IX","AM",8925.1,99) "^DD",8925.1,8925.1,0,"IX","AM1",8925.1,.03) "^DD",8925.1,8925.1,0,"IX","AMM",8925.14,.01) "^DD",8925.1,8925.1,0,"IX","AMM2",8925.14,2) "^DD",8925.1,8925.1,0,"IX","AMM3",8925.14,3) "^DD",8925.1,8925.1,0,"IX","AMM4",8925.14,4) "^DD",8925.1,8925.1,0,"IX","AP",8925.1,.05) "^DD",8925.1,8925.1,0,"IX","APOST",8925.1,.14) "^DD",8925.1,8925.1,0,"IX","AS",8925.1,.07) "^DD",8925.1,8925.1,0,"IX","AT",8925.1,.04) "^DD",8925.1,8925.1,0,"IX","B",8925.1,.01) "^DD",8925.1,8925.1,0,"IX","C",8925.1,.02) "^DD",8925.1,8925.1,0,"IX","D",8925.1,.03) "^DD",8925.1,8925.1,0,"IX","E",8925.1,.01) "^DD",8925.1,8925.1,0,"NM","TIU DOCUMENT DEFINITION") "^DD",8925.1,8925.1,0,"PT",142.14,.01) "^DD",8925.1,8925.1,0,"PT",783.9,.04) "^DD",8925.1,8925.1,0,"PT",783.9,.05) "^DD",8925.1,8925.1,0,"PT",783.9,.06) "^DD",8925.1,8925.1,0,"PT",8925,.01) "^DD",8925.1,8925.1,0,"PT",8925,.04) "^DD",8925.1,8925.1,0,"PT",8925.14,.01) "^DD",8925.1,8925.1,0,"PT",8925.95,.01) "^DD",8925.1,8925.1,0,"PT",8925.98,.02) "^DD",8925.1,8925.1,0,"PT",8925.98,.03) "^DD",8925.1,8925.1,0,"PT",8925.9801,.01) "^DD",8925.1,8925.1,0,"PT",8927,.19) "^DD",8925.1,8925.1,0,"PT",8930.1,.01) "^DD",8925.1,8925.1,0,"VRPK") TEXT INTEGRATION UTILITIES "^DD",8925.1,8925.1,.01,0) NAME^RFX^^0;1^S:$L($T(^TIULS)) X=$$UPPER^TIULS(X) K:$L(X)>60!($L(X)<3)!'(X'?1P.E) X I $D(X),+$G(DA) K:$$BADNAP^TIUFLF1(X,+$G(DA)) X "^DD",8925.1,8925.1,.01,.1) "^DD",8925.1,8925.1,.01,1,0) ^.1 "^DD",8925.1,8925.1,.01,1,1,0) 8925.1^B "^DD",8925.1,8925.1,.01,1,1,1) S ^TIU(8925.1,"B",$E(X,1,60),DA)="" "^DD",8925.1,8925.1,.01,1,1,2) K ^TIU(8925.1,"B",$E(X,1,60),DA) "^DD",8925.1,8925.1,.01,1,2,0) 8925.1^E^KWIC "^DD",8925.1,8925.1,.01,1,2,1) S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I "(,.?! '-/&:;)"[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2,^DD("KWIC")'[I S ^TIU(8925.1,"E",I,DA)="" "^DD",8925.1,8925.1,.01,1,2,2) S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I "(,.?! '-/&:;)"[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2 K ^TIU(8925.1,"E",I,DA) "^DD",8925.1,8925.1,.01,1,2,"%D",0) ^^2^2^2960302^ "^DD",8925.1,8925.1,.01,1,2,"%D",1,0) This KWIK cross-reference on document name will allow look-up based on "^DD",8925.1,8925.1,.01,1,2,"%D",2,0) sub-names, etc. "^DD",8925.1,8925.1,.01,1,2,"DT") 2960302 "^DD",8925.1,8925.1,.01,1,3,0) 8925.1^ACL^MUMPS "^DD",8925.1,8925.1,.01,1,3,1) D SACL^TIUDD1(X,.01) "^DD",8925.1,8925.1,.01,1,3,2) D KACL^TIUDD1(X,.01) "^DD",8925.1,8925.1,.01,1,3,"%D",0) ^^2^2^2971016^ "^DD",8925.1,8925.1,.01,1,3,"%D",1,0) This complex cross-reference by class and name will help optimize the "^DD",8925.1,8925.1,.01,1,3,"%D",2,0) title look-up for the GUI. "^DD",8925.1,8925.1,.01,1,3,"DT") 2971016 "^DD",8925.1,8925.1,.01,3) This is the technical name, 3-60 characters, not starting with punctuation. If OBJECT, Name must be unique among all object Names, Abbreviations, and Print Names. "^DD",8925.1,8925.1,.01,4) D NAME^TIUFXHLX:$G(TIUFXNOD)["Add/Create"&($G(TIUFSTMP)="T") "^DD",8925.1,8925.1,.01,21,0) ^.001^51^51^3030625^^^^ "^DD",8925.1,8925.1,.01,21,1,0) The name of a Document Definition entry (.01 field) must be between 3 "^DD",8925.1,8925.1,.01,21,2,0) and 60 characters long and may not begin with a punctuation character. "^DD",8925.1,8925.1,.01,21,3,0) Although names can be entered in any case, they are transformed to "^DD",8925.1,8925.1,.01,21,4,0) upper case before being stored. "^DD",8925.1,8925.1,.01,21,5,0) "^DD",8925.1,8925.1,.01,21,6,0) It functions as the Technical Name of the entry. Some sites have put KWIC "^DD",8925.1,8925.1,.01,21,7,0) cross references on it to get, say, all Titles from a given Service. "^DD",8925.1,8925.1,.01,21,8,0) "^DD",8925.1,8925.1,.01,21,9,0) Name can be used when entering documents as the name of the Title being "^DD",8925.1,8925.1,.01,21,10,0) entered. Print Name and Abbreviation will also be accepted. "^DD",8925.1,8925.1,.01,21,11,0) "^DD",8925.1,8925.1,.01,21,12,0) Since it is the Technical, .01 Name, the Document Definition Utility "^DD",8925.1,8925.1,.01,21,13,0) (TIUF) uses this name throughout. "^DD",8925.1,8925.1,.01,21,14,0) "^DD",8925.1,8925.1,.01,21,15,0) The .01 name differs from the Print Name, which appears in lists of "^DD",8925.1,8925.1,.01,21,16,0) documents and functions as the Title of the document. "^DD",8925.1,8925.1,.01,21,17,0) "^DD",8925.1,8925.1,.01,21,18,0) It also differs from Item Menu Text (1-20 characters), which is used when "^DD",8925.1,8925.1,.01,21,19,0) selecting documents from 3-COLUMN MENUS. "^DD",8925.1,8925.1,.01,21,20,0) "^DD",8925.1,8925.1,.01,21,21,0) The ORDER of names in TIUF options Edit Document Definitions and Create "^DD",8925.1,8925.1,.01,21,22,0) Document Definitions is by Item Sequence under the parent. Order is "^DD",8925.1,8925.1,.01,21,23,0) alphabetic by Menu Text if an Item has no Item Sequence. "^DD",8925.1,8925.1,.01,21,24,0) "^DD",8925.1,8925.1,.01,21,25,0) When a new entry is added to file 8925.1, the Document Definition Utility "^DD",8925.1,8925.1,.01,21,26,0) (TIUF) enters the Name as the default Print Name. The Print Name can be "^DD",8925.1,8925.1,.01,21,27,0) edited if a different Print Name is desired. "^DD",8925.1,8925.1,.01,21,28,0) "^DD",8925.1,8925.1,.01,21,29,0) File 8925.1 permits more than 1 entry with the same name as long as they "^DD",8925.1,8925.1,.01,21,30,0) don't have the same Type. In that sense, NAMES are reusable. However, "^DD",8925.1,8925.1,.01,21,31,0) ENTRIES are NOT reusable (except specially marked Components): an entry is "^DD",8925.1,8925.1,.01,21,32,0) NOT allowed to be an item under more than one parent unless it is a Shared "^DD",8925.1,8925.1,.01,21,33,0) Component. (See Type Component.) "^DD",8925.1,8925.1,.01,21,34,0) "^DD",8925.1,8925.1,.01,21,35,0) Name is a BASIC Field. "^DD",8925.1,8925.1,.01,21,36,0) "^DD",8925.1,8925.1,.01,21,37,0) OBJECT Name "^DD",8925.1,8925.1,.01,21,38,0) Object Names, like any other names are 3-60 characters, not starting with "^DD",8925.1,8925.1,.01,21,39,0) punctuation. Sites may want to namespace object names, use the object "^DD",8925.1,8925.1,.01,21,40,0) Print Name as a more familiar name, and use object Abbreviation as a short "^DD",8925.1,8925.1,.01,21,41,0) name to embed in boilerplate text. Unlike other Types, Object "^DD",8925.1,8925.1,.01,21,42,0) Abbreviation and Print Name as well as Name must be uppercase. "^DD",8925.1,8925.1,.01,21,43,0) "^DD",8925.1,8925.1,.01,21,44,0) Object Name, Abbreviation, or Print Name can be embedded in boilerplate "^DD",8925.1,8925.1,.01,21,45,0) text. Since TIU must be able to determine from this which object is "^DD",8925.1,8925.1,.01,21,46,0) intended, object Names, Abbreviations, and Print Names must be unique. In "^DD",8925.1,8925.1,.01,21,47,0) fact, an object Name must differ not only from every other object name, "^DD",8925.1,8925.1,.01,21,48,0) but also from every other object Abbreviation and from every other object "^DD",8925.1,8925.1,.01,21,49,0) Print Name. Same for Abbreviations and Print Names. For example, if some "^DD",8925.1,8925.1,.01,21,50,0) object has abbreviation 'CND', then 'CND' cannot be used for any other "^DD",8925.1,8925.1,.01,21,51,0) object Name, Abbreviation, or Print Name. "^DD",8925.1,8925.1,.01,"AUDIT") "^DD",8925.1,8925.1,.01,"DEL",.01,0) I 1 "^DD",8925.1,8925.1,.01,"DT") 3030527 "^DD",8925.1,8925.1,.02,0) ABBREVIATION^FX^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>4!($L(X)<2)!'(X?2.4A) X I $D(X),+$G(DA) K:($P(^TIU(8925.1,DA,0),U,4)="O")&('(X?2.4U)!'$D(TIUFPRIV)) X I $D(X),+$G(DA) K:$$BADNAP^TIUFLF1(X,DA) X "^DD",8925.1,8925.1,.02,1,0) ^.1 "^DD",8925.1,8925.1,.02,1,1,0) 8925.1^C "^DD",8925.1,8925.1,.02,1,1,1) S ^TIU(8925.1,"C",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.02,1,1,2) K ^TIU(8925.1,"C",$E(X,1,30),DA) "^DD",8925.1,8925.1,.02,1,1,"%D",0) ^^2^2^2940711^ "^DD",8925.1,8925.1,.02,1,1,"%D",1,0) This cross reference will be used by the router/filer to identify a given "^DD",8925.1,8925.1,.02,1,1,"%D",2,0) report type. "^DD",8925.1,8925.1,.02,1,1,"DT") 2921020 "^DD",8925.1,8925.1,.02,1,2,0) 8925.1^ACL02^MUMPS "^DD",8925.1,8925.1,.02,1,2,1) D SACL^TIUDD1(X,.02) "^DD",8925.1,8925.1,.02,1,2,2) D KACL^TIUDD1(X,.02) "^DD",8925.1,8925.1,.02,1,2,"%D",0) ^^2^2^3010417^ "^DD",8925.1,8925.1,.02,1,2,"%D",1,0) This complex cross-reference by class and name will help optimize the "^DD",8925.1,8925.1,.02,1,2,"%D",2,0) title look-up for the GUI. "^DD",8925.1,8925.1,.02,1,2,"DT") 3010417 "^DD",8925.1,8925.1,.02,3) Enter from 2 to 4 letters. If OBJECT, Abbreviation must be unique among all object Names, Abbreviations, and Print Names, and must be uppercase. "^DD",8925.1,8925.1,.02,21,0) ^^3^3^2990504^^^^ "^DD",8925.1,8925.1,.02,21,1,0) Abbreviation can be entered at the Title: prompt when entering a document. "^DD",8925.1,8925.1,.02,21,2,0) Since all Titles with that abbreviation will then be listed, Abbreviation "^DD",8925.1,8925.1,.02,21,3,0) can serve to group Titles. BASIC Field. For Objects, see NAME. "^DD",8925.1,8925.1,.02,"DT") 3020107 "^DD",8925.1,8925.1,.03,0) PRINT NAME^FX^^0;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>60!($L(X)<3) X I $D(X),+$G(DA) K:($P(^TIU(8925.1,DA,0),U,4)="O")&('(X?3.60UPN)!'$D(TIUFPRIV)) X I $D(X),+$G(DA) K:$$BADNAP^TIUFLF1(X,DA) X "^DD",8925.1,8925.1,.03,1,0) ^.1 "^DD",8925.1,8925.1,.03,1,1,0) 8925.1^AM1^MUMPS "^DD",8925.1,8925.1,.03,1,1,1) D REDO^TIUDD "^DD",8925.1,8925.1,.03,1,1,2) D REDO^TIUDD "^DD",8925.1,8925.1,.03,1,1,"%D",0) ^^2^2^2950911^^^ "^DD",8925.1,8925.1,.03,1,1,"%D",1,0) This MUMPS-type cross-reference is used to update the TIMESTAMP on both "^DD",8925.1,8925.1,.03,1,1,"%D",2,0) the current document, and its parents, when its PRINT NAME changes. "^DD",8925.1,8925.1,.03,1,1,"DT") 2940720 "^DD",8925.1,8925.1,.03,1,2,0) 8925.1^D "^DD",8925.1,8925.1,.03,1,2,1) S ^TIU(8925.1,"D",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.03,1,2,2) K ^TIU(8925.1,"D",$E(X,1,30),DA) "^DD",8925.1,8925.1,.03,1,2,"%D",0) ^^1^1^2950126^ "^DD",8925.1,8925.1,.03,1,2,"%D",1,0) This REGULAR FileMan cross-reference by PRINT NAME will facilitate look-up. "^DD",8925.1,8925.1,.03,1,2,"DT") 2950126 "^DD",8925.1,8925.1,.03,1,3,0) 8925.1^ACL03^MUMPS "^DD",8925.1,8925.1,.03,1,3,1) D SACL^TIUDD1(X,.03) "^DD",8925.1,8925.1,.03,1,3,2) D KACL^TIUDD1(X,.03) "^DD",8925.1,8925.1,.03,1,3,"%D",0) ^^2^2^3010417^ "^DD",8925.1,8925.1,.03,1,3,"%D",1,0) This complex cross-reference by class and name will help optimize the "^DD",8925.1,8925.1,.03,1,3,"%D",2,0) title look-up for the GUI. "^DD",8925.1,8925.1,.03,1,3,"DT") 3010417 "^DD",8925.1,8925.1,.03,3) Print Name is used in lists of documents and as document Title in the Patient Chart. 3-60 Characters. If OBJECT, Print Name must be unique among object Names/Abbreviations/PrintNames, and uppercase. "^DD",8925.1,8925.1,.03,21,0) ^^3^3^2990504^^^^ "^DD",8925.1,8925.1,.03,21,1,0) Print Name is the name used in lists of documents. For entries of Type "^DD",8925.1,8925.1,.03,21,2,0) Title, Print Name is used as the document Title in the Patient Chart. "^DD",8925.1,8925.1,.03,21,3,0) BASIC field. For Objects, see NAME. "^DD",8925.1,8925.1,.03,"DT") 3020107 "^DD",8925.1,8925.1,.04,0) TYPE^RSX^CL:CLASS;DC:DOCUMENT CLASS;DOC:TITLE;CO:COMPONENT;O:OBJECT;^0;4^K:'$G(TIUFPRIV) X "^DD",8925.1,8925.1,.04,1,0) ^.1 "^DD",8925.1,8925.1,.04,1,1,0) 8925.1^AT "^DD",8925.1,8925.1,.04,1,1,1) S ^TIU(8925.1,"AT",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.04,1,1,2) K ^TIU(8925.1,"AT",$E(X,1,30),DA) "^DD",8925.1,8925.1,.04,1,1,3) Please don't delete! "^DD",8925.1,8925.1,.04,1,1,"%D",0) ^^2^2^2950615^ "^DD",8925.1,8925.1,.04,1,1,"%D",1,0) This regular cross reference is used for listing Document Definitions by "^DD",8925.1,8925.1,.04,1,1,"%D",2,0) Type. "^DD",8925.1,8925.1,.04,1,1,"DT") 2950615 "^DD",8925.1,8925.1,.04,3) Types Class and Document Class group documents. Titles are used to enter documents. Components are sections of documents. Objects are M code for use in Boilerplate Text. "^DD",8925.1,8925.1,.04,4) "^DD",8925.1,8925.1,.04,21,0) ^^99^99^2970521^^ "^DD",8925.1,8925.1,.04,21,1,0) Type determines the nature of the entry and what sort of items the entry "^DD",8925.1,8925.1,.04,21,2,0) may have. There are 5 possible types: "^DD",8925.1,8925.1,.04,21,3,0) "^DD",8925.1,8925.1,.04,21,4,0) CL CLASS: Classes group documents. "^DD",8925.1,8925.1,.04,21,5,0) "^DD",8925.1,8925.1,.04,21,6,0) Example: "Progress Notes" is a class with many kinds of progress notes "^DD",8925.1,8925.1,.04,21,7,0) under it. "^DD",8925.1,8925.1,.04,21,8,0) "^DD",8925.1,8925.1,.04,21,9,0) Classes may themselves be subdivided into items of Type Class or may have "^DD",8925.1,8925.1,.04,21,10,0) items of Type Document Class if no further Class subdivisions are desired. "^DD",8925.1,8925.1,.04,21,11,0) "^DD",8925.1,8925.1,.04,21,12,0) If a hierarchy deeper than Class-Document Class-Title is desired, Class is "^DD",8925.1,8925.1,.04,21,13,0) the place to insert another level into the hierarchy: Class-Class-Document "^DD",8925.1,8925.1,.04,21,14,0) Class-Title. "^DD",8925.1,8925.1,.04,21,15,0) "^DD",8925.1,8925.1,.04,21,16,0) Besides grouping documents, Classes also store behavior which is then "^DD",8925.1,8925.1,.04,21,17,0) inherited by lower level entries. "^DD",8925.1,8925.1,.04,21,18,0) "^DD",8925.1,8925.1,.04,21,19,0) DC DOCUMENT CLASS: Document Classes group documents. Document Class is "^DD",8925.1,8925.1,.04,21,20,0) the lowest level of class, and has items of Type Title under it. "^DD",8925.1,8925.1,.04,21,21,0) "^DD",8925.1,8925.1,.04,21,22,0) Example: "Day Pass Note" could be a Document Class under class Progress "^DD",8925.1,8925.1,.04,21,23,0) Note. "^DD",8925.1,8925.1,.04,21,24,0) "^DD",8925.1,8925.1,.04,21,25,0) Document Classes also store behavior which is then inherited by lower "^DD",8925.1,8925.1,.04,21,26,0) entries. "^DD",8925.1,8925.1,.04,21,27,0) "^DD",8925.1,8925.1,.04,21,28,0) TL TITLE: Titles are used to enter documents. They store the behavior "^DD",8925.1,8925.1,.04,21,29,0) of the documents which use them. "^DD",8925.1,8925.1,.04,21,30,0) "^DD",8925.1,8925.1,.04,21,31,0) Titles may have predefined boilerplate ("Overprint") text. They may have "^DD",8925.1,8925.1,.04,21,32,0) Components as items. Boilerplate Text can have objects in it. "^DD",8925.1,8925.1,.04,21,33,0) "^DD",8925.1,8925.1,.04,21,34,0) Examples: "Routine Day Pass Note" could be a Title under document class "^DD",8925.1,8925.1,.04,21,35,0) Day Pass Note. Another example might be "Exceptional Circumstances Day "^DD",8925.1,8925.1,.04,21,36,0) Pass Note." "^DD",8925.1,8925.1,.04,21,37,0) "^DD",8925.1,8925.1,.04,21,38,0) Titles store their own behavior. They also inherit behavior from higher "^DD",8925.1,8925.1,.04,21,39,0) levels of the hierarchy. However, behavior stored in the Title itself "^DD",8925.1,8925.1,.04,21,40,0) overrides inherited behavior. "^DD",8925.1,8925.1,.04,21,41,0) "^DD",8925.1,8925.1,.04,21,42,0) CO COMPONENT: Components are "sections" or "pieces" of documents. "^DD",8925.1,8925.1,.04,21,43,0) In the Hierarchy, Components are hung as items from Titles. "^DD",8925.1,8925.1,.04,21,44,0) "^DD",8925.1,8925.1,.04,21,45,0) Examples: "Reason for Pass" could be a component of Routine Day Pass Note. "^DD",8925.1,8925.1,.04,21,46,0) Subjective is a component of a SOAP Note. "^DD",8925.1,8925.1,.04,21,47,0) "^DD",8925.1,8925.1,.04,21,48,0) Components may have (sub)Components as items. They may have Boilerplate "^DD",8925.1,8925.1,.04,21,49,0) Text. Components may be designated Shared (see Field Description for "^DD",8925.1,8925.1,.04,21,50,0) Shared). Shared Components are shown in Document Definition Utility "^DD",8925.1,8925.1,.04,21,51,0) Displays as Type: 'CO S'. "^DD",8925.1,8925.1,.04,21,52,0) "^DD",8925.1,8925.1,.04,21,53,0) There are advantages and disadvantages in splitting a document up into "^DD",8925.1,8925.1,.04,21,54,0) separate components (rather than writing sections into the Boilerplate "^DD",8925.1,8925.1,.04,21,55,0) Text of the Title): Since Components are stored as separate file entries, "^DD",8925.1,8925.1,.04,21,56,0) they are inherently accessable and even 'moveable'. Using Fileman, sites "^DD",8925.1,8925.1,.04,21,57,0) can access components of documents the same way they can access documents "^DD",8925.1,8925.1,.04,21,58,0) for reports, etc.. Also, in the future, TIU may have options to move/copy "^DD",8925.1,8925.1,.04,21,59,0) certain components from one document into another. The disadvantage is "^DD",8925.1,8925.1,.04,21,60,0) speed: Components make the structure more complex and therefore slow down "^DD",8925.1,8925.1,.04,21,61,0) processing. "^DD",8925.1,8925.1,.04,21,62,0) "^DD",8925.1,8925.1,.04,21,63,0) O OBJECT: Objects are names which may be embedded in the predefined "^DD",8925.1,8925.1,.04,21,64,0) boilerplate text of Titles. Example: 'PATIENT AGE'. Objects are typed "^DD",8925.1,8925.1,.04,21,65,0) into the boilerplate text of a Title, enclosed by '|'s. For example, "^DD",8925.1,8925.1,.04,21,66,0) suppose a Title has boilerplate text: "^DD",8925.1,8925.1,.04,21,67,0) "^DD",8925.1,8925.1,.04,21,68,0) Patient is a healthy |PATIENT AGE| year old male ... "^DD",8925.1,8925.1,.04,21,69,0) "^DD",8925.1,8925.1,.04,21,70,0) Then a user who enters such a note for a patient known by the system to be "^DD",8925.1,8925.1,.04,21,71,0) 56 years old would be presented with the text: "^DD",8925.1,8925.1,.04,21,72,0) "^DD",8925.1,8925.1,.04,21,73,0) Patient is a healthy 56 year old male ... "^DD",8925.1,8925.1,.04,21,74,0) "^DD",8925.1,8925.1,.04,21,75,0) The user can then add to the text and or edit the text, including the age "^DD",8925.1,8925.1,.04,21,76,0) (56) of the patient. From this point on, the patient age (56) is regular "^DD",8925.1,8925.1,.04,21,77,0) text and is not updated in this note. "^DD",8925.1,8925.1,.04,21,78,0) "^DD",8925.1,8925.1,.04,21,79,0) Objects must always have uppercase names, abbreviations, and print names. "^DD",8925.1,8925.1,.04,21,80,0) When embedding objects in boilerplate text, users may embed any of these "^DD",8925.1,8925.1,.04,21,81,0) three (name, abbreviation, print name) in boilerplate text, enclosed by "^DD",8925.1,8925.1,.04,21,82,0) '|'s. Objects must always be embedded in uppercase. "^DD",8925.1,8925.1,.04,21,83,0) "^DD",8925.1,8925.1,.04,21,84,0) Objects are stored in the Document Definition File, but are not part of "^DD",8925.1,8925.1,.04,21,85,0) the Hierarchy. They are accessible through the Option Create Objects. "^DD",8925.1,8925.1,.04,21,86,0) (They are also accessible through the Option Sort Document Definitions, by "^DD",8925.1,8925.1,.04,21,87,0) selecting Sort by Type and selecting Type Object.) "^DD",8925.1,8925.1,.04,21,88,0) "^DD",8925.1,8925.1,.04,21,89,0) TIU exports a small library of objects. Sites can also create their own. "^DD",8925.1,8925.1,.04,21,90,0) "^DD",8925.1,8925.1,.04,21,91,0) Only an owner can edit an object and should do so only after consulting "^DD",8925.1,8925.1,.04,21,92,0) with others who use it. The object must be inactive for editing. It "^DD",8925.1,8925.1,.04,21,93,0) should be thoroughly tested. See Object Status, under Status. "^DD",8925.1,8925.1,.04,21,94,0) "^DD",8925.1,8925.1,.04,21,95,0) Entries of type Object cannot be changed to any other type. Entries of "^DD",8925.1,8925.1,.04,21,96,0) type Class, Document Class, Title, or Component cannot be changed to type "^DD",8925.1,8925.1,.04,21,97,0) Object. "^DD",8925.1,8925.1,.04,21,98,0) "^DD",8925.1,8925.1,.04,21,99,0) Type is a BASIC field. "^DD",8925.1,8925.1,.04,"DT") 2970114 "^DD",8925.1,8925.1,.05,0) PERSONAL OWNER^P200'X^VA(200,^0;5^Q "^DD",8925.1,8925.1,.05,1,0) ^.1 "^DD",8925.1,8925.1,.05,1,1,0) 8925.1^AP "^DD",8925.1,8925.1,.05,1,1,1) S ^TIU(8925.1,"AP",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.05,1,1,2) K ^TIU(8925.1,"AP",$E(X,1,30),DA) "^DD",8925.1,8925.1,.05,1,1,3) Please don't delete! "^DD",8925.1,8925.1,.05,1,1,"%D",0) ^^2^2^2950615^ "^DD",8925.1,8925.1,.05,1,1,"%D",1,0) This regular cross reference is used for listing Document Definitions by "^DD",8925.1,8925.1,.05,1,1,"%D",2,0) Personal Owner. "^DD",8925.1,8925.1,.05,1,1,"DT") 2950615 "^DD",8925.1,8925.1,.05,3) Enter Person who can edit entry. If owned by Class rather than Person, delete Personal Owner by typing '@' at Personal Owner prompt, and then enter Class Owner. "^DD",8925.1,8925.1,.05,4) "^DD",8925.1,8925.1,.05,21,0) ^^41^41^2970520^ "^DD",8925.1,8925.1,.05,21,1,0) Document Definition Ownership has nothing to do with who can USE the entry "^DD",8925.1,8925.1,.05,21,2,0) to enter a document. It determines responsibilty for the Document "^DD",8925.1,8925.1,.05,21,3,0) Definition itself. "^DD",8925.1,8925.1,.05,21,4,0) "^DD",8925.1,8925.1,.05,21,5,0) An entry can be EDITED by its owner. (The Manager menu permits override of "^DD",8925.1,8925.1,.05,21,6,0) ownership so that Ownership can be assigned to a clinician who can then "^DD",8925.1,8925.1,.05,21,7,0) fill in boilerplate text with the Clinician menu, while the Manager can "^DD",8925.1,8925.1,.05,21,8,0) still edit the entry, since there are many fields the clinician does not "^DD",8925.1,8925.1,.05,21,9,0) have access to.) Exception: the Manager menu does NOT override ownership "^DD",8925.1,8925.1,.05,21,10,0) of Objects or of Shared Components. Only owners can edit Objects and "^DD",8925.1,8925.1,.05,21,11,0) Shared Components, regardless of menu. "^DD",8925.1,8925.1,.05,21,12,0) "^DD",8925.1,8925.1,.05,21,13,0) If Title owner edits the boilerplate text of the Title, that person can "^DD",8925.1,8925.1,.05,21,14,0) edit the boilerplate text of all components of the Title as well, without "^DD",8925.1,8925.1,.05,21,15,0) regard to component ownership. In order to edit components individually, "^DD",8925.1,8925.1,.05,21,16,0) however, the user must own the component. This allows users to assign "^DD",8925.1,8925.1,.05,21,17,0) ownership of components to different people, for example, for (future) "^DD",8925.1,8925.1,.05,21,18,0) multidisciplinary documents. "^DD",8925.1,8925.1,.05,21,19,0) "^DD",8925.1,8925.1,.05,21,20,0) A PERSONAL OWNER is a person who uniquely owns the entry. An entry may "^DD",8925.1,8925.1,.05,21,21,0) have a Personal Owner OR a Class Owner but not both. When entering a "^DD",8925.1,8925.1,.05,21,22,0) Personal Owner, be sure to delete any existing Class Owner. "^DD",8925.1,8925.1,.05,21,23,0) "^DD",8925.1,8925.1,.05,21,24,0) The Document Definition Utility TIUF uses the term 'Individual Owner'. "^DD",8925.1,8925.1,.05,21,25,0) Someone is an Individual Owner of an entry if s/he is the personal owner "^DD",8925.1,8925.1,.05,21,26,0) OR, if the entry is CLASS Owned, if s/he belongs to the Owner Class. "^DD",8925.1,8925.1,.05,21,27,0) "^DD",8925.1,8925.1,.05,21,28,0) The Document Definition Utility TIUF enters the user as the Personal Owner "^DD",8925.1,8925.1,.05,21,29,0) if a user enters a new entry without assigning ownership. This person can "^DD",8925.1,8925.1,.05,21,30,0) then reassign ownership if they choose. "^DD",8925.1,8925.1,.05,21,31,0) "^DD",8925.1,8925.1,.05,21,32,0) If the person responsible for an entry plays a role corresponding to a "^DD",8925.1,8925.1,.05,21,33,0) User Class, e.g. Clinical Coordinator, it may be more efficient to assign "^DD",8925.1,8925.1,.05,21,34,0) ownership to the class rather than to the person. Owners are then "^DD",8925.1,8925.1,.05,21,35,0) automatically updated as the class is updated. "^DD",8925.1,8925.1,.05,21,36,0) "^DD",8925.1,8925.1,.05,21,37,0) Editing privilege is affected not only by Owner but also by Status, by "^DD",8925.1,8925.1,.05,21,38,0) Shared, by In Use, and by menu. Manager menus, for example, provide "^DD",8925.1,8925.1,.05,21,39,0) fuller editing capabilities than Clinician menus. "^DD",8925.1,8925.1,.05,21,40,0) "^DD",8925.1,8925.1,.05,21,41,0) Personal Owner is a BASIC field. "^DD",8925.1,8925.1,.05,"DT") 2961022 "^DD",8925.1,8925.1,.06,0) CLASS OWNER^P8930'X^USR(8930,^0;6^Q "^DD",8925.1,8925.1,.06,1,0) ^.1 "^DD",8925.1,8925.1,.06,1,1,0) 8925.1^AC "^DD",8925.1,8925.1,.06,1,1,1) S ^TIU(8925.1,"AC",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.06,1,1,2) K ^TIU(8925.1,"AC",$E(X,1,30),DA) "^DD",8925.1,8925.1,.06,1,1,3) Please don't delete! "^DD",8925.1,8925.1,.06,1,1,"%D",0) ^^2^2^2950615^ "^DD",8925.1,8925.1,.06,1,1,"%D",1,0) This regular cross reference is used to list Document Definitions by Class "^DD",8925.1,8925.1,.06,1,1,"%D",2,0) Owner. "^DD",8925.1,8925.1,.06,1,1,"DT") 2950615 "^DD",8925.1,8925.1,.06,3) If owned by Class rather than by Person enter User Class whose members may edit entry. If owned by Person, delete Class Owner by entering '@' at Class Owner prompt. "^DD",8925.1,8925.1,.06,4) "^DD",8925.1,8925.1,.06,21,0) ^^31^31^2970227^ "^DD",8925.1,8925.1,.06,21,1,0) Document Definition Ownership has nothing to do with who can USE the entry "^DD",8925.1,8925.1,.06,21,2,0) to enter a document. It determines responsibility for the Document "^DD",8925.1,8925.1,.06,21,3,0) Definition itself. "^DD",8925.1,8925.1,.06,21,4,0) "^DD",8925.1,8925.1,.06,21,5,0) An entry can be EDITED by its owner. (The Manager menu permits override "^DD",8925.1,8925.1,.06,21,6,0) of ownership so that ownership can be assigned to a clinician (person with "^DD",8925.1,8925.1,.06,21,7,0) Clinician Menu) who can then fill in boilerplate text, while the manager "^DD",8925.1,8925.1,.06,21,8,0) can still edit the entry, since there are many fields the clinician does "^DD",8925.1,8925.1,.06,21,9,0) not have access to.) Exception: the Manager menu does NOT override "^DD",8925.1,8925.1,.06,21,10,0) ownership of Objects or of Shared Components. These can ONLY be edited by "^DD",8925.1,8925.1,.06,21,11,0) an owner, regardless of menu. "^DD",8925.1,8925.1,.06,21,12,0) "^DD",8925.1,8925.1,.06,21,13,0) If a Title owner edits the boilerplate text of the Title, that person can "^DD",8925.1,8925.1,.06,21,14,0) edit the boilerplate text of all components of the title as well, without "^DD",8925.1,8925.1,.06,21,15,0) regard to component ownership. However, the user must own the component "^DD",8925.1,8925.1,.06,21,16,0) in order to edit it individually, permitting separate ownership of "^DD",8925.1,8925.1,.06,21,17,0) components. "^DD",8925.1,8925.1,.06,21,18,0) "^DD",8925.1,8925.1,.06,21,19,0) A Class Owner is a User Class from the USR CLASS file whose members may "^DD",8925.1,8925.1,.06,21,20,0) edit the entry. An entry may have a Personal OR a Class Owner (not both). "^DD",8925.1,8925.1,.06,21,21,0) The Document Definition Utility TIUF does not prompt for Class Owner if "^DD",8925.1,8925.1,.06,21,22,0) the entry has a Personal Owner. To change to Class Owner, first delete "^DD",8925.1,8925.1,.06,21,23,0) the Personal Owner by entering '@' at the Personal Owner prompt. "^DD",8925.1,8925.1,.06,21,24,0) "^DD",8925.1,8925.1,.06,21,25,0) For new entries, users are prompted to enter the Class Owner Clinical "^DD",8925.1,8925.1,.06,21,26,0) Coordinator as the default. To enter a different Class Owner, enter the "^DD",8925.1,8925.1,.06,21,27,0) appropriate class after the //'s. If there are no //'s and the "^DD",8925.1,8925.1,.06,21,28,0) Replace...with editor is being used, enter ... to replace the whole "^DD",8925.1,8925.1,.06,21,29,0) class and then enter the appropriate class. "^DD",8925.1,8925.1,.06,21,30,0) "^DD",8925.1,8925.1,.06,21,31,0) Class Owner is a BASIC field. "^DD",8925.1,8925.1,.06,"DT") 2961022 "^DD",8925.1,8925.1,.07,0) STATUS^*P8925.6'X^TIU(8925.6,^0;7^K:'$G(TIUFPRIV) X Q:'$D(X) S DIC("S")="I 1 X $$STATSCRN^TIUFLF5" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",8925.1,8925.1,.07,1,0) ^.1 "^DD",8925.1,8925.1,.07,1,1,0) 8925.1^AS "^DD",8925.1,8925.1,.07,1,1,1) S ^TIU(8925.1,"AS",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.07,1,1,2) K ^TIU(8925.1,"AS",$E(X,1,30),DA) "^DD",8925.1,8925.1,.07,1,1,3) Please don't delete! "^DD",8925.1,8925.1,.07,1,1,"%D",0) ^^2^2^2950615^ "^DD",8925.1,8925.1,.07,1,1,"%D",1,0) This regular cross reference is used to list Document Definitions by "^DD",8925.1,8925.1,.07,1,1,"%D",2,0) Status. "^DD",8925.1,8925.1,.07,1,1,"DT") 2950615 "^DD",8925.1,8925.1,.07,1,2,0) 8925.1^ACL07^MUMPS "^DD",8925.1,8925.1,.07,1,2,1) D SACL^TIUDD1(X,.07) "^DD",8925.1,8925.1,.07,1,2,2) D KACL^TIUDD1(X,.07) "^DD",8925.1,8925.1,.07,1,2,"%D",0) ^^2^2^2971016^ "^DD",8925.1,8925.1,.07,1,2,"%D",1,0) This MUMPS-type cross-reference on STATUS support the identification of "^DD",8925.1,8925.1,.07,1,2,"%D",2,0) Active and TEST Titles within a given class. "^DD",8925.1,8925.1,.07,1,2,"DT") 2971016 "^DD",8925.1,8925.1,.07,3) Documents can be entered on ACTIVE Titles. Only the Owner can enter a document on TEST Titles. Only INACTIVE Document Definitions can be edited. "^DD",8925.1,8925.1,.07,4) "^DD",8925.1,8925.1,.07,12) STATSCRN limits Status to Status file entries that are appropriate for Document Definitions: Active, Inactive, and Test. "^DD",8925.1,8925.1,.07,12.1) S DIC("S")="I 1 X $$STATSCRN^TIUFLF5" "^DD",8925.1,8925.1,.07,21,0) ^^183^183^2990225^^^ "^DD",8925.1,8925.1,.07,21,1,0) Status provides a way of making Document Definitions 'Offline' to "^DD",8925.1,8925.1,.07,21,2,0) documents. Document Definitions need to be 'Offline' if they are new and "^DD",8925.1,8925.1,.07,21,3,0) not ready for use, if they are being edited, or if they are retired from "^DD",8925.1,8925.1,.07,21,4,0) further use. "^DD",8925.1,8925.1,.07,21,5,0) "^DD",8925.1,8925.1,.07,21,6,0) Status is limited to those Statuses in the Status File which apply to "^DD",8925.1,8925.1,.07,21,7,0) Document Definitions: Inactive, Test, and Active. The Document Definition "^DD",8925.1,8925.1,.07,21,8,0) Utility TIUF further limits Statuses to those appropriate for the entry "^DD",8925.1,8925.1,.07,21,9,0) Type (see below), limits the Status of entries with Inactive ancestors to "^DD",8925.1,8925.1,.07,21,10,0) Inactive, and limits the Status of faulty entries to Inactive. "^DD",8925.1,8925.1,.07,21,11,0) "^DD",8925.1,8925.1,.07,21,12,0) Status applies to all Document Definitions, but its meaning and possible "^DD",8925.1,8925.1,.07,21,13,0) values vary somewhat with the Document Definition Type. Exception: Shared "^DD",8925.1,8925.1,.07,21,14,0) Components: See COMPONENT STATUS, below. "^DD",8925.1,8925.1,.07,21,15,0) "^DD",8925.1,8925.1,.07,21,16,0) Status is a BASIC field. "^DD",8925.1,8925.1,.07,21,17,0) "^DD",8925.1,8925.1,.07,21,18,0) TITLE STATUS "^DD",8925.1,8925.1,.07,21,19,0) "^DD",8925.1,8925.1,.07,21,20,0) Status has its most basic meaning for Titles [Document Definitions of Type "^DD",8925.1,8925.1,.07,21,21,0) Title]: "^DD",8925.1,8925.1,.07,21,22,0) "^DD",8925.1,8925.1,.07,21,23,0) A Title can have Status Inactive, Test, or Active. If it has Status "^DD",8925.1,8925.1,.07,21,24,0) Inactive, it cannot be used to enter documents (EXCEPT through the "^DD",8925.1,8925.1,.07,21,25,0) Try Action, which deletes the document when done). If it has Status "^DD",8925.1,8925.1,.07,21,26,0) Test, it can be used to enter documents only by its Owner. Titles should "^DD",8925.1,8925.1,.07,21,27,0) be tested (and Tried) using TEST PATIENTS ONLY. If a Title has Status "^DD",8925.1,8925.1,.07,21,28,0) Active, it can be used to enter documents by any one with access and "^DD",8925.1,8925.1,.07,21,29,0) authorization. "^DD",8925.1,8925.1,.07,21,30,0) "^DD",8925.1,8925.1,.07,21,31,0) *************** "^DD",8925.1,8925.1,.07,21,32,0) NOTE on Availability of Titles for entering documents: "^DD",8925.1,8925.1,.07,21,33,0) Although Status affects availability for entering documents, there are "^DD",8925.1,8925.1,.07,21,34,0) other factors which also affect availability: A Document Definition is not "^DD",8925.1,8925.1,.07,21,35,0) available to a given user for entering documents (excepting the Document "^DD",8925.1,8925.1,.07,21,36,0) Definition Utility Try Action) unless all of the following 3 criteria are "^DD",8925.1,8925.1,.07,21,37,0) met: "^DD",8925.1,8925.1,.07,21,38,0) "^DD",8925.1,8925.1,.07,21,39,0) 1) It is a Document Definition of Type Title. "^DD",8925.1,8925.1,.07,21,40,0) "^DD",8925.1,8925.1,.07,21,41,0) 2) It has Status Active or Test. If it has Status Test, the user "^DD",8925.1,8925.1,.07,21,42,0) entering a document must own the Title. "^DD",8925.1,8925.1,.07,21,43,0) "^DD",8925.1,8925.1,.07,21,44,0) 3) If authorization for using the Title to enter documents is restricted "^DD",8925.1,8925.1,.07,21,45,0) by Business Rules, the user must be a member of the authorized user "^DD",8925.1,8925.1,.07,21,46,0) class. "^DD",8925.1,8925.1,.07,21,47,0) "^DD",8925.1,8925.1,.07,21,48,0) Unless these criteria are all met, users trying to enter documents will "^DD",8925.1,8925.1,.07,21,49,0) not SEE the Document Definition. Therefore it is wise to warn users when "^DD",8925.1,8925.1,.07,21,50,0) taking definitions offline for edit, and/or to do so at nonpeak hours for "^DD",8925.1,8925.1,.07,21,51,0) entering documents. "^DD",8925.1,8925.1,.07,21,52,0) "^DD",8925.1,8925.1,.07,21,53,0) The above description applies to document entry BOTH manually through "^DD",8925.1,8925.1,.07,21,54,0) menu options AND via upload. It does NOT apply to autoentry of documents "^DD",8925.1,8925.1,.07,21,55,0) via the TIU application interface. Adverse Reaction/Allergy notes entered "^DD",8925.1,8925.1,.07,21,56,0) by the Allergy package are an example of such autoentry. The TIU "^DD",8925.1,8925.1,.07,21,57,0) application interface for autoentering documents disregards Title status "^DD",8925.1,8925.1,.07,21,58,0) and Business Rules. "^DD",8925.1,8925.1,.07,21,59,0) ******************* "^DD",8925.1,8925.1,.07,21,60,0) "^DD",8925.1,8925.1,.07,21,61,0) When being upgraded to Status Active or Test, a Title is examined for "^DD",8925.1,8925.1,.07,21,62,0) rudimentary completeness and must be judged OK before the upgrade takes "^DD",8925.1,8925.1,.07,21,63,0) place. If desired, users can perform the same examination themselves by "^DD",8925.1,8925.1,.07,21,64,0) selecting action TRY. For Titles, Action TRY also permits the user to "^DD",8925.1,8925.1,.07,21,65,0) enter a document on the entry. The document is deleted immediately after "^DD",8925.1,8925.1,.07,21,66,0) the trial. "^DD",8925.1,8925.1,.07,21,67,0) "^DD",8925.1,8925.1,.07,21,68,0) Availability for entering documents is the central meaning of Status. "^DD",8925.1,8925.1,.07,21,69,0) However, Status also controls edit/deletion of Document Definitions: A "^DD",8925.1,8925.1,.07,21,70,0) Title can be edited ONLY if it has Status Inactive, ensuring that no one "^DD",8925.1,8925.1,.07,21,71,0) is using it to enter a document while its behavior is changing. Titles "^DD",8925.1,8925.1,.07,21,72,0) can be deleted only with Status Inactive. "^DD",8925.1,8925.1,.07,21,73,0) "^DD",8925.1,8925.1,.07,21,74,0) NOTE: Although Status affects Editing ability, it is not the only factor "^DD",8925.1,8925.1,.07,21,75,0) affecting editing: If an entry is already IN USE by documents, "^DD",8925.1,8925.1,.07,21,76,0) editing/deletion is restricted to aspects which will not harm existing "^DD",8925.1,8925.1,.07,21,77,0) TIU documents. "^DD",8925.1,8925.1,.07,21,78,0) "^DD",8925.1,8925.1,.07,21,79,0) Components under a Title have the same status as the Title: When a Title's "^DD",8925.1,8925.1,.07,21,80,0) status is changed, the statuses of its descendant Components are "^DD",8925.1,8925.1,.07,21,81,0) automatically changed with it. (Shared Components are an exception: see "^DD",8925.1,8925.1,.07,21,82,0) COMPONENT STATUS, below.) "^DD",8925.1,8925.1,.07,21,83,0) "^DD",8925.1,8925.1,.07,21,84,0) CLASS/DOCUMENT CLASS STATUS "^DD",8925.1,8925.1,.07,21,85,0) "^DD",8925.1,8925.1,.07,21,86,0) A Document Definition of Type Class or Document Class can have Status "^DD",8925.1,8925.1,.07,21,87,0) Inactive or Active. "^DD",8925.1,8925.1,.07,21,88,0) "^DD",8925.1,8925.1,.07,21,89,0) Basics for a Class or Document Class cannot be edited (except for Owner "^DD",8925.1,8925.1,.07,21,90,0) and Status) unless it is Inactive. Since Inactivating a Class/Document "^DD",8925.1,8925.1,.07,21,91,0) Class automatically inactivates its descendants, this ensures that all "^DD",8925.1,8925.1,.07,21,92,0) Titles which inherit behavior from it are neither Active nor Test, and are "^DD",8925.1,8925.1,.07,21,93,0) thus 'Offline' while inherited behavior is edited. "^DD",8925.1,8925.1,.07,21,94,0) "^DD",8925.1,8925.1,.07,21,95,0) In contrast to Basics, the ability to add/edit ITEMS of a Class/Document "^DD",8925.1,8925.1,.07,21,96,0) Class depends on the Status of the item, not the parent: it is NOT "^DD",8925.1,8925.1,.07,21,97,0) necessary to Inactivate a Class such as Progress Notes in order to "^DD",8925.1,8925.1,.07,21,98,0) edit/add items. "^DD",8925.1,8925.1,.07,21,99,0) "^DD",8925.1,8925.1,.07,21,100,0) Activating a Class/Document Class differs from Inactivating the "^DD",8925.1,8925.1,.07,21,101,0) Class/Document Class: When a Class/Document Class is ACTIVATED, its "^DD",8925.1,8925.1,.07,21,102,0) descendants may have any Status which their Type permits: they are not "^DD",8925.1,8925.1,.07,21,103,0) REQUIRED to be Active. Hence, they are not automatically Activated when "^DD",8925.1,8925.1,.07,21,104,0) the parent is Activated. "^DD",8925.1,8925.1,.07,21,105,0) "^DD",8925.1,8925.1,.07,21,106,0) COMPONENT STATUS "^DD",8925.1,8925.1,.07,21,107,0) "^DD",8925.1,8925.1,.07,21,108,0) A Document Definition of Type Component has the same status as its parent: "^DD",8925.1,8925.1,.07,21,109,0) Its status can be changed only by changing the Status of its Parent, if it "^DD",8925.1,8925.1,.07,21,110,0) has one. Components without parents are always Inactive. "^DD",8925.1,8925.1,.07,21,111,0) "^DD",8925.1,8925.1,.07,21,112,0) NOTE: The above implies that Test or Active Titles cannot have Inactive "^DD",8925.1,8925.1,.07,21,113,0) Components. In other words, Inactivating a Component is NOT a way of "^DD",8925.1,8925.1,.07,21,114,0) retiring it. If a Component is no longer a useful section of a Title, it "^DD",8925.1,8925.1,.07,21,115,0) should be edited so as to make it useful, or it should be deleted AS AN "^DD",8925.1,8925.1,.07,21,116,0) ITEM from the Title of which it is a part. As with all retired Document "^DD",8925.1,8925.1,.07,21,117,0) Definitions, it should NOT be deleted FROM THE FILE if it has been used by "^DD",8925.1,8925.1,.07,21,118,0) documents. "^DD",8925.1,8925.1,.07,21,119,0) "^DD",8925.1,8925.1,.07,21,120,0) Components can be edited only if they have status Inactive. This ensures "^DD",8925.1,8925.1,.07,21,121,0) that all Titles using them are offline while the components are being "^DD",8925.1,8925.1,.07,21,122,0) edited. "^DD",8925.1,8925.1,.07,21,123,0) "^DD",8925.1,8925.1,.07,21,124,0) Shared Components are a special case since they can have multiple parents. "^DD",8925.1,8925.1,.07,21,125,0) They DO NOT HAVE A STATUS. They can be edited only when all parent Titles "^DD",8925.1,8925.1,.07,21,126,0) have Status Inactive. (The Detailed Display screen shows parents.) This "^DD",8925.1,8925.1,.07,21,127,0) ensures that all parent Titles of Shared Components are offline while the "^DD",8925.1,8925.1,.07,21,128,0) component is being edited. Edit of Shared Components is permitted only "^DD",8925.1,8925.1,.07,21,129,0) through the Option Sort Document Definitions. "^DD",8925.1,8925.1,.07,21,130,0) "^DD",8925.1,8925.1,.07,21,131,0) Edit of Shared Components is severely restricted by Ownership, since they "^DD",8925.1,8925.1,.07,21,132,0) may be used multiple times and across the site. Even an Inactive Status "^DD",8925.1,8925.1,.07,21,133,0) does not permit a manager (person with Manager menu) to override ownership "^DD",8925.1,8925.1,.07,21,134,0) and edit a Shared Component they don't own. See Shared Components, under "^DD",8925.1,8925.1,.07,21,135,0) Description of Type. See Description of Shared. "^DD",8925.1,8925.1,.07,21,136,0) "^DD",8925.1,8925.1,.07,21,137,0) OBJECT STATUS "^DD",8925.1,8925.1,.07,21,138,0) "^DD",8925.1,8925.1,.07,21,139,0) Document Definitions of Type Object have Status Inactive or Active. "^DD",8925.1,8925.1,.07,21,140,0) "^DD",8925.1,8925.1,.07,21,141,0) Only ACTIVE objects function. That is, if a user enters a document on a "^DD",8925.1,8925.1,.07,21,142,0) Title with boilerplate text containing an inactive object, the object "^DD",8925.1,8925.1,.07,21,143,0) doesn't do anything; the user sees the name of the object and an error "^DD",8925.1,8925.1,.07,21,144,0) message in place of the object data. "^DD",8925.1,8925.1,.07,21,145,0) "^DD",8925.1,8925.1,.07,21,146,0) Only ACTIVE objects should be embedded in boilerplate text. Exception: "^DD",8925.1,8925.1,.07,21,147,0) owners who are creating/editing objects. Others should NOT embed inactive "^DD",8925.1,8925.1,.07,21,148,0) objects in boilerplate text since they may not be ready for use and since "^DD",8925.1,8925.1,.07,21,149,0) they do not function when users enter documents against them. Titles whose "^DD",8925.1,8925.1,.07,21,150,0) boilerplate text contains inactive objects cannot be activated. (This "^DD",8925.1,8925.1,.07,21,151,0) does NOT imply that active titles never have inactive objects embedded in "^DD",8925.1,8925.1,.07,21,152,0) them since users can, after a warning, inactivate objects even when they "^DD",8925.1,8925.1,.07,21,153,0) are embedded in active titles.) "^DD",8925.1,8925.1,.07,21,154,0) "^DD",8925.1,8925.1,.07,21,155,0) Only INACTIVE objects can be edited (and only by an owner). Only an owner "^DD",8925.1,8925.1,.07,21,156,0) can activate/inactivate an object. (Exception: if a user owns an object "^DD",8925.1,8925.1,.07,21,157,0) and edits the owner to someone else, the user is not prevented from going "^DD",8925.1,8925.1,.07,21,158,0) on to edit the status in the same edit session since they WERE the owner a "^DD",8925.1,8925.1,.07,21,159,0) few seconds ago.) Active objects are assumed to be ready for use in any "^DD",8925.1,8925.1,.07,21,160,0) boilerplate text. "^DD",8925.1,8925.1,.07,21,161,0) "^DD",8925.1,8925.1,.07,21,162,0) Since the owner is essentially caretaker of the object for the entire "^DD",8925.1,8925.1,.07,21,163,0) site, the owner should consult with all who use it before editing it. An "^DD",8925.1,8925.1,.07,21,164,0) object can be tested by embedding it in the boilerplate text of a Title "^DD",8925.1,8925.1,.07,21,165,0) and selecting action Try for the Title. It need not have status Active "^DD",8925.1,8925.1,.07,21,166,0) for this testing (and SHOULD not have status Active until testing is "^DD",8925.1,8925.1,.07,21,167,0) complete). Owners who inactivate objects for editing should make SURE to "^DD",8925.1,8925.1,.07,21,168,0) reactivate them if they are being used. "^DD",8925.1,8925.1,.07,21,169,0) "^DD",8925.1,8925.1,.07,21,170,0) Sites should either inactivate relevant Titles before editing objects or "^DD",8925.1,8925.1,.07,21,171,0) edit objects only when users are not likely to be ENTERING documents since "^DD",8925.1,8925.1,.07,21,172,0) Inactive objects do not function. "^DD",8925.1,8925.1,.07,21,173,0) "^DD",8925.1,8925.1,.07,21,174,0) If a site changes the name or behavior of an Object, it is up to the SITE "^DD",8925.1,8925.1,.07,21,175,0) to change the name wherever it has already been embedded in Boilerplate "^DD",8925.1,8925.1,.07,21,176,0) Text, and to inform users of the change. "^DD",8925.1,8925.1,.07,21,177,0) "^DD",8925.1,8925.1,.07,21,178,0) An object which is no longer wanted for future documents can be removed "^DD",8925.1,8925.1,.07,21,179,0) from the boilerplate text of all Titles and Components and then deleted "^DD",8925.1,8925.1,.07,21,180,0) from file 8925.1. Only an owner can delete it. All of the documents that "^DD",8925.1,8925.1,.07,21,181,0) used it have already got it in hard words so there is no need to keep it "^DD",8925.1,8925.1,.07,21,182,0) for their sake. Old Objects should be edited so they are useful or "^DD",8925.1,8925.1,.07,21,183,0) deleted, not kept around forever as Inactive. "^DD",8925.1,8925.1,.07,"DT") 2971016 "^DD",8925.1,8925.1,.08,0) IN USE^CJ6^^ ; ^S X=$S($L($T(^TIUFLF)):$$DDEFUSED^TIUFLF(D0),1:"?") "^DD",8925.1,8925.1,.08,.1) "^DD",8925.1,8925.1,.08,9) ^ "^DD",8925.1,8925.1,.08,9.01) "^DD",8925.1,8925.1,.08,9.1) S X=$S($L($T(^TIUFLF)):$$DDEFUSED^TIUFLF(D0),1:"?") "^DD",8925.1,8925.1,.08,21,0) ^^55^55^2970125^ "^DD",8925.1,8925.1,.08,21,1,0) IN USE applies to all entries except those of Type Object. It cannot be "^DD",8925.1,8925.1,.08,21,2,0) edited since it gets its value automatically. "^DD",8925.1,8925.1,.08,21,3,0) "^DD",8925.1,8925.1,.08,21,4,0) IN USE may have values 'Yes', 'No', or '?'. "^DD",8925.1,8925.1,.08,21,5,0) "^DD",8925.1,8925.1,.08,21,6,0) A Document Definition of Type Title or Component is In Use (Yes) if there "^DD",8925.1,8925.1,.08,21,7,0) are entries IN THE TIU DOCUMENT file which store it as their Document "^DD",8925.1,8925.1,.08,21,8,0) Definition. If not, it is NOT used (No). "^DD",8925.1,8925.1,.08,21,9,0) "^DD",8925.1,8925.1,.08,21,10,0) NOTE: It is possible for Document Definitions to be used by documents in "^DD",8925.1,8925.1,.08,21,11,0) files other than the TIU Document file and still be NOT In Use since In "^DD",8925.1,8925.1,.08,21,12,0) Use means in use by documents in the TIU Document Definition file. See "^DD",8925.1,8925.1,.08,21,13,0) Warning, below. "^DD",8925.1,8925.1,.08,21,14,0) "^DD",8925.1,8925.1,.08,21,15,0) A Document Definition of Type Class or Document Class is In Use (Yes) if "^DD",8925.1,8925.1,.08,21,16,0) it has children of Type Title which are In Use. That is, it is Used by "^DD",8925.1,8925.1,.08,21,17,0) Documents (Yes) if there are entries in the TIU Document file which "^DD",8925.1,8925.1,.08,21,18,0) inherit behavior from it. If not, it is NOT used (No). "^DD",8925.1,8925.1,.08,21,19,0) "^DD",8925.1,8925.1,.08,21,20,0) IN USE has value '?' for a Document Definition File entry if routine "^DD",8925.1,8925.1,.08,21,21,0) TIUFLF is missing or if the program encounters a nonexistent item and the "^DD",8925.1,8925.1,.08,21,22,0) entry is not In Use so far as the check has been able to go. "^DD",8925.1,8925.1,.08,21,23,0) "^DD",8925.1,8925.1,.08,21,24,0) Note: Since Shared Components can be items of more than one Title, a "^DD",8925.1,8925.1,.08,21,25,0) Shared Component may be In Use even when a particular parent Title is "^DD",8925.1,8925.1,.08,21,26,0) NOT In Use. This simply means that it is also a Component of another "^DD",8925.1,8925.1,.08,21,27,0) Title which IS In Use. "^DD",8925.1,8925.1,.08,21,28,0) "^DD",8925.1,8925.1,.08,21,29,0) If IN USE has the explicit value 'No' for a particular Document Definition "^DD",8925.1,8925.1,.08,21,30,0) entry, the entry can be deleted by the Owner without harming documents IN "^DD",8925.1,8925.1,.08,21,31,0) TIU DOCUMENT FILE 8925. Deleting it will, however, orphan any descendant "^DD",8925.1,8925.1,.08,21,32,0) Document Definitions. "^DD",8925.1,8925.1,.08,21,33,0) "^DD",8925.1,8925.1,.08,21,34,0) WARNING: If a site is using TIU to upload documents into a file other than "^DD",8925.1,8925.1,.08,21,35,0) the TIU Document file, it may create Document Definition entries to store "^DD",8925.1,8925.1,.08,21,36,0) upload information. For example, it may create an Operative Reports title "^DD",8925.1,8925.1,.08,21,37,0) containing instructions for uploading documents into the Surgery file. "^DD",8925.1,8925.1,.08,21,38,0) These document definitions will be orphans and will be NOT In Use, since "^DD",8925.1,8925.1,.08,21,39,0) documents using them are not stored in the TIU Document file. They must "^DD",8925.1,8925.1,.08,21,40,0) NOT be deleted from the Document Definition file. "^DD",8925.1,8925.1,.08,21,41,0) "^DD",8925.1,8925.1,.08,21,42,0) Note: Deleting Objects will not harm existing documents, but WILL HARM "^DD",8925.1,8925.1,.08,21,43,0) future documents if the Object is embedded in existing Document Definition "^DD",8925.1,8925.1,.08,21,44,0) Boilerplate Text. "^DD",8925.1,8925.1,.08,21,45,0) "^DD",8925.1,8925.1,.08,21,46,0) If IN USE has value 'Yes' or '?', the Document Definition Utility TIUF "^DD",8925.1,8925.1,.08,21,47,0) does not permit the entry to be deleted. Deleting the entry would cause "^DD",8925.1,8925.1,.08,21,48,0) documents in file 8925 not to function. This is true even if the entry "^DD",8925.1,8925.1,.08,21,49,0) has status 'Inactive' and documents are no longer being written on the "^DD",8925.1,8925.1,.08,21,50,0) entry. "^DD",8925.1,8925.1,.08,21,51,0) "^DD",8925.1,8925.1,.08,21,52,0) Technical Note: A Document Definition of Type Title or Component is IN "^DD",8925.1,8925.1,.08,21,53,0) USE if and only if it appears in file 8925's 'B' Cross Reference. "^DD",8925.1,8925.1,.08,21,54,0) "^DD",8925.1,8925.1,.08,21,55,0) In Use is a BASIC field. "^DD",8925.1,8925.1,.08,"DT") 2960618 "^DD",8925.1,8925.1,.1,0) SHARED^SX^1:YES;0:NO;^0;10^K:'$G(TIUFPRIV) X "^DD",8925.1,8925.1,.1,.1) SHARED COMPONENT "^DD",8925.1,8925.1,.1,3) Enter Y for YES if this Component is intended for broad use across the site, i.e., it can be used more than once, and need not be owned by the user. "^DD",8925.1,8925.1,.1,21,0) ^^48^48^2970220^ "^DD",8925.1,8925.1,.1,21,1,0) Applies to entries of Type Component only. "^DD",8925.1,8925.1,.1,21,2,0) "^DD",8925.1,8925.1,.1,21,3,0) Document Definitions of Type Component may be designated SHARED by Owners "^DD",8925.1,8925.1,.1,21,4,0) who have the Manager menu. This means the Component can be an item under "^DD",8925.1,8925.1,.1,21,5,0) multiple parents, and any user who owns a Title can add it as an item. "^DD",8925.1,8925.1,.1,21,6,0) "^DD",8925.1,8925.1,.1,21,7,0) Shared Components are the ONLY members of the Document Definition "^DD",8925.1,8925.1,.1,21,8,0) hierarchy which can appear in more than one place in the hierarchy. "^DD",8925.1,8925.1,.1,21,9,0) (Objects can be used in multiple entries, but are not members of the "^DD",8925.1,8925.1,.1,21,10,0) hierarchy.) "^DD",8925.1,8925.1,.1,21,11,0) "^DD",8925.1,8925.1,.1,21,12,0) Shared Components are intended for broad use across the site. An example "^DD",8925.1,8925.1,.1,21,13,0) might be a Privacy Act Component. Since a Shared Component may be used in "^DD",8925.1,8925.1,.1,21,14,0) many different Document Definitions, its Owner is essentially caretaker "^DD",8925.1,8925.1,.1,21,15,0) for it, hospital wide, and must take into account all users before editing "^DD",8925.1,8925.1,.1,21,16,0) it. Users who disagree with a proposed change can opt to create and use "^DD",8925.1,8925.1,.1,21,17,0) their own copy instead of using the Shared Component. "^DD",8925.1,8925.1,.1,21,18,0) "^DD",8925.1,8925.1,.1,21,19,0) Parents of a Shared Component are listed in the Detailed Display Screen. "^DD",8925.1,8925.1,.1,21,20,0) "^DD",8925.1,8925.1,.1,21,21,0) Shared Field values are 1 for YES and 0 for NO, with a default value of "^DD",8925.1,8925.1,.1,21,22,0) 0 for NO if the field is empty. "^DD",8925.1,8925.1,.1,21,23,0) "^DD",8925.1,8925.1,.1,21,24,0) An entry may not be designated Shared unless it is of Type Component. Only "^DD",8925.1,8925.1,.1,21,25,0) a Manager (person with Manager menu) and only an Owner can designate a "^DD",8925.1,8925.1,.1,21,26,0) Component as Shared. Only an OWNER can edit it. (Normally Managers can "^DD",8925.1,8925.1,.1,21,27,0) override ownership and edit entries. Manager Options do NOT override "^DD",8925.1,8925.1,.1,21,28,0) Ownership for editing Shared Components). Shared Components can only be "^DD",8925.1,8925.1,.1,21,29,0) edited from the Sort Document Definitions Option. "^DD",8925.1,8925.1,.1,21,30,0) "^DD",8925.1,8925.1,.1,21,31,0) Shared Components cannot be deleted. If they do not have multiple "^DD",8925.1,8925.1,.1,21,32,0) parents, they can, however, be edited to NOT shared and THEN deleted, "^DD",8925.1,8925.1,.1,21,33,0) assuming they are not In Use by documents and the parent is Inactive. "^DD",8925.1,8925.1,.1,21,34,0) "^DD",8925.1,8925.1,.1,21,35,0) Shared Components do NOT HAVE a Status. They can be edited only if all "^DD",8925.1,8925.1,.1,21,36,0) parent Titles are Inactive. This ensures that parent Titles are offline "^DD",8925.1,8925.1,.1,21,37,0) for entering documents while their components are being edited. Parents "^DD",8925.1,8925.1,.1,21,38,0) are listed on the Detailed Display Screen. "^DD",8925.1,8925.1,.1,21,39,0) "^DD",8925.1,8925.1,.1,21,40,0) If a Shared Component has subcomponents, they are automatically Shared, "^DD",8925.1,8925.1,.1,21,41,0) since they, with their parents, can be used in more than one place in the "^DD",8925.1,8925.1,.1,21,42,0) hierarchy. "^DD",8925.1,8925.1,.1,21,43,0) "^DD",8925.1,8925.1,.1,21,44,0) Sharing of Document Definitions other than Components is not permitted "^DD",8925.1,8925.1,.1,21,45,0) because it unduly restricts the owner's right to edit/delete the Document "^DD",8925.1,8925.1,.1,21,46,0) Definition and adds undue complexity to the Hierarchy. "^DD",8925.1,8925.1,.1,21,47,0) "^DD",8925.1,8925.1,.1,21,48,0) Shared is a BASIC field. "^DD",8925.1,8925.1,.1,"DT") 2961022 "^DD",8925.1,8925.1,.11,0) ORPHAN^CJ8^^ ; ^S X=$S($L($T(^TIUFLF4)):$$ORPHAN^TIUFLF4(D0,^TIU(8925.1,D0,0)),1:"?") "^DD",8925.1,8925.1,.11,9) ^ "^DD",8925.1,8925.1,.11,9.01) "^DD",8925.1,8925.1,.11,9.1) S X=$S($L($T(^TIUFLF4)):$$ORPHAN^TIUFLF4(D0,^TIU(8925.1,D0,0)),1:"?") "^DD",8925.1,8925.1,.11,21,0) ^^57^57^2970220^ "^DD",8925.1,8925.1,.11,21,1,0) Orphan applies to Document Definitions of all Types except Objects "^DD",8925.1,8925.1,.11,21,2,0) and Shared Components. "^DD",8925.1,8925.1,.11,21,3,0) "^DD",8925.1,8925.1,.11,21,4,0) Orphan is not editable since it gets its value automatically. "^DD",8925.1,8925.1,.11,21,5,0) "^DD",8925.1,8925.1,.11,21,6,0) Document Definitions are Orphans if they do not belong to the Clinical "^DD",8925.1,8925.1,.11,21,7,0) Documents Hierarchy, i.e., they cannot trace their ancestry all the way "^DD",8925.1,8925.1,.11,21,8,0) back to the Class Clinical Documents. If an Orphan is not In Use, it "^DD",8925.1,8925.1,.11,21,9,0) may be "dead wood" which should be deleted from the file. Orphans not In "^DD",8925.1,8925.1,.11,21,10,0) Use which SHOULD NOT BE DELETED include those being kept for later "^DD",8925.1,8925.1,.11,21,11,0) possible use, those temporarily orphaned in order to move them around in "^DD",8925.1,8925.1,.11,21,12,0) the hierarchy, and those used for uploading documents into files other "^DD",8925.1,8925.1,.11,21,13,0) than the TIU Document file. "^DD",8925.1,8925.1,.11,21,14,0) "^DD",8925.1,8925.1,.11,21,15,0) (Orphan does not apply to Objects since they don't ever belong to the "^DD",8925.1,8925.1,.11,21,16,0) hierarchy. Orphan does not apply to Shared Components since they may "^DD",8925.1,8925.1,.11,21,17,0) have more than one line of ancestry.) "^DD",8925.1,8925.1,.11,21,18,0) "^DD",8925.1,8925.1,.11,21,19,0) Warning: The DOCUMENT DEFINITION file may contain orphan entries which "^DD",8925.1,8925.1,.11,21,20,0) are not used by documents in the TIU Document file but which contain "^DD",8925.1,8925.1,.11,21,21,0) upload instructions for storing documents somewhere else. For example, if "^DD",8925.1,8925.1,.11,21,22,0) a site is uploading Operative Reports into the Surgery file, there may be "^DD",8925.1,8925.1,.11,21,23,0) an orphan Operative Report Document Definition in the DOCUMENT DEFINITION "^DD",8925.1,8925.1,.11,21,24,0) file. These should NOT be deleted just because they are orphans. Such "^DD",8925.1,8925.1,.11,21,25,0) entries can be identified by edit/viewing them through the Sort Option "^DD",8925.1,8925.1,.11,21,26,0) and looking for Upload fields. "^DD",8925.1,8925.1,.11,21,27,0) "^DD",8925.1,8925.1,.11,21,28,0) NOTE: Orphan as used in the Document Definition Utility TIUF does NOT mean "^DD",8925.1,8925.1,.11,21,29,0) having no parents. For example, suppose Exceptional Day Pass Note has "^DD",8925.1,8925.1,.11,21,30,0) parent Day Pass Note. If Day Pass Note has no parent, then Exceptional "^DD",8925.1,8925.1,.11,21,31,0) Day Pass Note cannot trace its ancestry back to Clinical Documents and is "^DD",8925.1,8925.1,.11,21,32,0) an Orphan even though it has a parent. "^DD",8925.1,8925.1,.11,21,33,0) "^DD",8925.1,8925.1,.11,21,34,0) Orphans are invisible to TIU users and cannot be used to enter documents. "^DD",8925.1,8925.1,.11,21,35,0) "^DD",8925.1,8925.1,.11,21,36,0) When an item under a non-orphan is deleted as an item, it becomes an "^DD",8925.1,8925.1,.11,21,37,0) orphan along with all of its descendants. TIUF, the Document Definition "^DD",8925.1,8925.1,.11,21,38,0) Utility, does not permit non-orphan Titles to become orphaned if they are "^DD",8925.1,8925.1,.11,21,39,0) In Use. Titles already used but being retired from further use should "^DD",8925.1,8925.1,.11,21,40,0) be Inactivated, NOT orphaned. Components are a different story; "^DD",8925.1,8925.1,.11,21,41,0) components being retired from further use can and should be orphaned "^DD",8925.1,8925.1,.11,21,42,0) (deleted as items from the Title). "^DD",8925.1,8925.1,.11,21,43,0) "^DD",8925.1,8925.1,.11,21,44,0) Reason: Titles inherit attributes and therefore require a complete "^DD",8925.1,8925.1,.11,21,45,0) ancestry in order to process existing documents. Since components, on the "^DD",8925.1,8925.1,.11,21,46,0) other hand, do not inherit attributes, they do NOT require a complete "^DD",8925.1,8925.1,.11,21,47,0) ancestry to process existing documents (although they must remain in the "^DD",8925.1,8925.1,.11,21,48,0) file.) "^DD",8925.1,8925.1,.11,21,49,0) "^DD",8925.1,8925.1,.11,21,50,0) Since Orphans do not belong to the Hierarchy, they do NOT appear on the "^DD",8925.1,8925.1,.11,21,51,0) Edit Document Definitions Option. They can be accessed through the Sort "^DD",8925.1,8925.1,.11,21,52,0) Document Definitions Option. "^DD",8925.1,8925.1,.11,21,53,0) "^DD",8925.1,8925.1,.11,21,54,0) The field Orphan may have values 'Yes', 'No', or '?'. Orphan has value '?' "^DD",8925.1,8925.1,.11,21,55,0) if there are technical errors making its value unknown. "^DD",8925.1,8925.1,.11,21,56,0) "^DD",8925.1,8925.1,.11,21,57,0) Orphan is a BASIC field. "^DD",8925.1,8925.1,.11,"DT") 2960201 "^DD",8925.1,8925.1,.12,0) HAS BOILTXT^CJ7^^ ; ^S TIUFBTXT=$S($L($T(^TIUFLF)):$$HASBOIL^TIUFLF(D0,^TIU(8925.1,D0,0)),1:"UNKNOWN"),X=$S(TIUFBTXT:"YES",TIUFBTXT=0:"NO",1:TIUFBTXT) K TIUFBTXT "^DD",8925.1,8925.1,.12,.1) HAS BOILERPLATE TEXT "^DD",8925.1,8925.1,.12,9) ^ "^DD",8925.1,8925.1,.12,9.01) "^DD",8925.1,8925.1,.12,9.1) S TIUFBTXT=$S($L($T(^TIUFLF)):$$HASBOIL^TIUFLF(D0,^TIU(8925.1,D0,0)),1:"UNKNOWN"),X=$S(TIUFBTXT:"YES",TIUFBTXT=0:"NO",1:TIUFBTXT) K TIUFBTXT "^DD",8925.1,8925.1,.12,21,0) ^^3^3^2970128^ "^DD",8925.1,8925.1,.12,21,1,0) Applies to Types Title and Component only. Cannot be edited since value "^DD",8925.1,8925.1,.12,21,2,0) is automatic. A Document Definition Has Boiltxt if it or its descendant "^DD",8925.1,8925.1,.12,21,3,0) Components have Boilerplate Text (Field 3). BASIC field. "^DD",8925.1,8925.1,.12,"DT") 2960118 "^DD",8925.1,8925.1,.13,0) NATIONAL STANDARD^SX^1:YES;0:NO;^0;13^K:'$G(TIUFPRIV) X "^DD",8925.1,8925.1,.13,3) Enter YES if entry is Standard across the nation, i.e. sites mustn't edit "^DD",8925.1,8925.1,.13,4) "^DD",8925.1,8925.1,.13,21,0) ^^47^47^2990223^ "^DD",8925.1,8925.1,.13,21,1,0) Some Document Definitions, for example, CWAD's, are developed nationally "^DD",8925.1,8925.1,.13,21,2,0) and sent out as standardized entries across the nation. TIU and other "^DD",8925.1,8925.1,.13,21,3,0) packages depend on their standard definition, and they must not be edited "^DD",8925.1,8925.1,.13,21,4,0) by sites but only by the persons who are nationally responsible for them. "^DD",8925.1,8925.1,.13,21,5,0) "^DD",8925.1,8925.1,.13,21,6,0) Such entries are marked NATIONAL STANDARD (field has value 1 for YES), "^DD",8925.1,8925.1,.13,21,7,0) which generally prevents sites from editing the entry. "^DD",8925.1,8925.1,.13,21,8,0) "^DD",8925.1,8925.1,.13,21,9,0) In two cases, sites are permitted to edit National Standard entries. The "^DD",8925.1,8925.1,.13,21,10,0) first case concerns Titles. Sites can edit Status and Abbreviation for "^DD",8925.1,8925.1,.13,21,11,0) National Titles. Status INACTIVE for a National Title prevents manual and "^DD",8925.1,8925.1,.13,21,12,0) upload entry of documents for the Title, while continuing to permit "^DD",8925.1,8925.1,.13,21,13,0) automatic entry for the Title via the TIU application interface for new "^DD",8925.1,8925.1,.13,21,14,0) notes. (Example: Adverse Reaction/Allergy notes are automatically "^DD",8925.1,8925.1,.13,21,15,0) entered by the Allergy package.) Editing Abbreviation gives sites a means "^DD",8925.1,8925.1,.13,21,16,0) of grouping national titles with other National and non-National Titles as "^DD",8925.1,8925.1,.13,21,17,0) they please. "^DD",8925.1,8925.1,.13,21,18,0) "^DD",8925.1,8925.1,.13,21,19,0) The second case where edit of National entries is permitted concerns the "^DD",8925.1,8925.1,.13,21,20,0) Item Multiple: "^DD",8925.1,8925.1,.13,21,21,0) "^DD",8925.1,8925.1,.13,21,22,0) If a National Standard entry has Type Class or Document Class, sites can "^DD",8925.1,8925.1,.13,21,23,0) add/delete Nonnational items as they please, and can edit ALL items AS "^DD",8925.1,8925.1,.13,21,24,0) ITEMS (e.g. Item Sequence, etc.). Sites CANNOT add/delete National items. "^DD",8925.1,8925.1,.13,21,25,0) "^DD",8925.1,8925.1,.13,21,26,0) If a National Standard entry has Type Title or Component, sites "^DD",8925.1,8925.1,.13,21,27,0) cannot add or delete items, but can still edit items AS ITEMS. "^DD",8925.1,8925.1,.13,21,28,0) "^DD",8925.1,8925.1,.13,21,29,0) Sites cannot add National Standard entries as Items to parents. There is "^DD",8925.1,8925.1,.13,21,30,0) one exception: Sites can add National Shared Components to (nonnational) "^DD",8925.1,8925.1,.13,21,31,0) Titles if they wish. Sites can delete National Standard Items from "^DD",8925.1,8925.1,.13,21,32,0) nonnational parents. (Unless there has been a mistake, such items will be "^DD",8925.1,8925.1,.13,21,33,0) limited to Shared Components only.) "^DD",8925.1,8925.1,.13,21,34,0) "^DD",8925.1,8925.1,.13,21,35,0) Field is NOT heritable. If field has no value for an entry, value is 0 by "^DD",8925.1,8925.1,.13,21,36,0) default. This means that entries created by sites are NOT National "^DD",8925.1,8925.1,.13,21,37,0) Standard. "^DD",8925.1,8925.1,.13,21,38,0) "^DD",8925.1,8925.1,.13,21,39,0) Technical Note: "^DD",8925.1,8925.1,.13,21,40,0) "^DD",8925.1,8925.1,.13,21,41,0) National entries (except for Shared Components) must have National "^DD",8925.1,8925.1,.13,21,42,0) ancestors: if a National entry has a nonNational ancestor, the "^DD",8925.1,8925.1,.13,21,43,0) Document Definition Utility TIUF does not permit it to be activated. "^DD",8925.1,8925.1,.13,21,44,0) (Shared Components need not have National ancestors, and do not have a "^DD",8925.1,8925.1,.13,21,45,0) Status.) "^DD",8925.1,8925.1,.13,21,46,0) "^DD",8925.1,8925.1,.13,21,47,0) National Standard is a BASIC field. "^DD",8925.1,8925.1,.13,"DT") 2970128 "^DD",8925.1,8925.1,.14,0) POSTING INDICATOR^S^C:crisis note;W:warning;A:allergy/ADR;D:directive;^0;14^Q "^DD",8925.1,8925.1,.14,1,0) ^.1 "^DD",8925.1,8925.1,.14,1,1,0) 8925.1^APOST "^DD",8925.1,8925.1,.14,1,1,1) S ^TIU(8925.1,"APOST",$E(X,1,30),DA)="" "^DD",8925.1,8925.1,.14,1,1,2) K ^TIU(8925.1,"APOST",$E(X,1,30),DA) "^DD",8925.1,8925.1,.14,1,1,"%D",0) ^^3^3^2970227^ "^DD",8925.1,8925.1,.14,1,1,"%D",1,0) This REGULAR FileMan Cross-reference by Posting Indicator will help to "^DD",8925.1,8925.1,.14,1,1,"%D",2,0) identify which Document Classes are associated with each of the currently "^DD",8925.1,8925.1,.14,1,1,"%D",3,0) supported Posting Types. "^DD",8925.1,8925.1,.14,1,1,"DT") 2970227 "^DD",8925.1,8925.1,.14,3) Please choose an indicator corresponding to the Posting Type "^DD",8925.1,8925.1,.14,21,0) ^^2^2^2970515^ "^DD",8925.1,8925.1,.14,21,1,0) This field is used to help identify indicators of the Patient Posting Type "^DD",8925.1,8925.1,.14,21,2,0) to which the Document Definition should be ascribed. "^DD",8925.1,8925.1,.14,"DT") 2970227 "^DD",8925.1,8925.1,1,0) UPLOAD DELIMITED ASCII HEADER^8925.11I^^ITEM;0 "^DD",8925.1,8925.1,1,21,0) ^^7^7^2970108^^ "^DD",8925.1,8925.1,1,21,1,0) This multiple contains the upload record header format of the Document "^DD",8925.1,8925.1,1,21,2,0) Definition, to be used by the upload/router/filer when the preferred "^DD",8925.1,8925.1,1,21,3,0) header format is Delimited string (as opposed to captioned). "^DD",8925.1,8925.1,1,21,4,0) "^DD",8925.1,8925.1,1,21,5,0) Delimited string is useful only if the site has a way of automating "^DD",8925.1,8925.1,1,21,6,0) creation of upload record headers. If they are being created by a human "^DD",8925.1,8925.1,1,21,7,0) transcriber, use Captioned Record Headers instead. "^DD",8925.1,8925.1,1,"DT") 2960729 "^DD",8925.1,8925.1,1.01,0) UPLOAD TARGET FILE^*P1'^DIC(^1;1^S DIC("S")="I $D(^DIC(+Y,""%"",""B"",""TIU""))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",8925.1,8925.1,1.01,3) Select the DHCP file in which the document will be stored. "^DD",8925.1,8925.1,1.01,12) Only files with the "TIU" application group may be selected. "^DD",8925.1,8925.1,1.01,12.1) S DIC("S")="I $D(^DIC(+Y,""%"",""B"",""TIU""))" "^DD",8925.1,8925.1,1.01,21,0) ^^20^20^2970506^ "^DD",8925.1,8925.1,1.01,21,1,0) ------------- "^DD",8925.1,8925.1,1.01,21,2,0) NOTE ON UPLOAD: "^DD",8925.1,8925.1,1.01,21,3,0) Upload fields (Upload Target File, Laygo Allowed, Target Text Field "^DD",8925.1,8925.1,1.01,21,4,0) Subscript, Upload Look-Up Method, Upload Post-Filing Code, Upload Filing "^DD",8925.1,8925.1,1.01,21,5,0) Error Code, and multiple fields Upload Delimited ASCII Header and Upload "^DD",8925.1,8925.1,1.01,21,6,0) Captioned ASCII Header) apply to Document Definitions of Type Class, "^DD",8925.1,8925.1,1.01,21,7,0) Document Class, and Title. Multiple fields Upload Delimited ASCII Header "^DD",8925.1,8925.1,1.01,21,8,0) and Upload Captioned ASCII Header are heritable AS A GROUP. Do NOT set "^DD",8925.1,8925.1,1.01,21,9,0) partial information at a lower level; if you set ANY information at a "^DD",8925.1,8925.1,1.01,21,10,0) lower level, it should be COMPLETE. For information on editing heritable "^DD",8925.1,8925.1,1.01,21,11,0) fields, see Technical field: Edit Template. "^DD",8925.1,8925.1,1.01,21,12,0) "^DD",8925.1,8925.1,1.01,21,13,0) TIUF, the Document Definition Utility does NOT display inherited Upload "^DD",8925.1,8925.1,1.01,21,14,0) information. To see/edit existing upload information, edit/view at the "^DD",8925.1,8925.1,1.01,21,15,0) level it is set. "^DD",8925.1,8925.1,1.01,21,16,0) "^DD",8925.1,8925.1,1.01,21,17,0) -------------- "^DD",8925.1,8925.1,1.01,21,18,0) The UPLOAD TARGET FILE is the VA FileMan file in which fixed-field header "^DD",8925.1,8925.1,1.01,21,19,0) information and associated text will be stored. Only files which include "^DD",8925.1,8925.1,1.01,21,20,0) the TIU Application Group may be selected. "^DD",8925.1,8925.1,1.01,"DT") 2960729 "^DD",8925.1,8925.1,1.02,0) LAYGO ALLOWED^S^0:NO;1:YES;^1;2^Q "^DD",8925.1,8925.1,1.02,3) Please indicate whether new entries may be added to the TARGET FILE. "^DD",8925.1,8925.1,1.02,21,0) ^^2^2^2970128^ "^DD",8925.1,8925.1,1.02,21,1,0) This field indicates whether or not a new entry can be created in "^DD",8925.1,8925.1,1.02,21,2,0) the TARGET FILE for documents defined by this Document Definition. "^DD",8925.1,8925.1,1.02,"DT") 2970128 "^DD",8925.1,8925.1,1.03,0) TARGET TEXT FIELD SUBSCRIPT^F^^1;3^K:$L(X)>15!($L(X)<1) X "^DD",8925.1,8925.1,1.03,3) Select the Word-processing field in the target file. "^DD",8925.1,8925.1,1.03,21,0) ^^2^2^2970620^^ "^DD",8925.1,8925.1,1.03,21,1,0) This is the subscript of the word-processing field in the TARGET FILE, in "^DD",8925.1,8925.1,1.03,21,2,0) which the body of the narrative report will be stored. "^DD",8925.1,8925.1,1.03,"DT") 2940331 "^DD",8925.1,8925.1,1.04,0) BOILERPLATE ON UPLOAD ENABLED^S^0:NO;1:YES;^1;4^Q "^DD",8925.1,8925.1,1.04,3) Indicate whether boilerplate logic will be executed on upload "^DD",8925.1,8925.1,1.04,21,0) ^^2^2^2961210^ "^DD",8925.1,8925.1,1.04,21,1,0) This field determines whether the filer will attempt to execute "^DD",8925.1,8925.1,1.04,21,2,0) boilerplate logic for uploaded documents. Not used in version 1. "^DD",8925.1,8925.1,1.04,"DT") 2951016 "^DD",8925.1,8925.1,2,0) UPLOAD CAPTIONED ASCII HEADER^8925.12A^^HEAD;0 "^DD",8925.1,8925.1,2,21,0) ^^11^11^2970506^^ "^DD",8925.1,8925.1,2,21,1,0) This multiple contains the upload record header format of the Document "^DD",8925.1,8925.1,2,21,2,0) Definition, to be used by the upload/router/filer when the preferred "^DD",8925.1,8925.1,2,21,3,0) header format is captioned (as opposed to delimited string). "^DD",8925.1,8925.1,2,21,4,0) "^DD",8925.1,8925.1,2,21,5,0) Under captioned header format, header items are distinguished from each "^DD",8925.1,8925.1,2,21,6,0) other by captions such as SSN which are entered by the transcriber, "^DD",8925.1,8925.1,2,21,7,0) followed by the data. "^DD",8925.1,8925.1,2,21,8,0) "^DD",8925.1,8925.1,2,21,9,0) Use the captioned header format if documents are transcribed by a human "^DD",8925.1,8925.1,2,21,10,0) transcriber. Delimited format is useful only if the site has some way of "^DD",8925.1,8925.1,2,21,11,0) automatically generating upload record headers. "^DD",8925.1,8925.1,2,"DT") 2960729 "^DD",8925.1,8925.1,3,0) BOILERPLATE TEXT^8925.13^^DFLT;0 "^DD",8925.1,8925.1,3,"DT") 2950421 "^DD",8925.1,8925.1,3.02,0) OK TO DISTRIBUTE^S^1:YES;0:NO;^3;2^Q "^DD",8925.1,8925.1,3.02,3) Enter 1 for YES if entry should be included when this file is exported with data. Enter 0 for NO or leave blank if entry is for local use only. "^DD",8925.1,8925.1,3.02,21,0) ^^13^13^2970224^^ "^DD",8925.1,8925.1,3.02,21,1,0) Presently applies only to National Programmers; does not appear on "^DD",8925.1,8925.1,3.02,21,2,0) Manager or Clinician Menus. "^DD",8925.1,8925.1,3.02,21,3,0) "^DD",8925.1,8925.1,3.02,21,4,0) If field is 1 for YES, then entry should be included for export. If field "^DD",8925.1,8925.1,3.02,21,5,0) has no value or has value 0, entry should not be included for export. "^DD",8925.1,8925.1,3.02,21,6,0) "^DD",8925.1,8925.1,3.02,21,7,0) Since TIU is hierarchical, the entry's behavior depends on entries above "^DD",8925.1,8925.1,3.02,21,8,0) it in the hierarchy. It is the responsibility of the exporter to make "^DD",8925.1,8925.1,3.02,21,9,0) sure all ancestors which are necessary for the proper behavior of an "^DD",8925.1,8925.1,3.02,21,10,0) exported entry are also exported with it (or are already present at sites "^DD",8925.1,8925.1,3.02,21,11,0) receiving the exported entries). "^DD",8925.1,8925.1,3.02,21,12,0) "^DD",8925.1,8925.1,3.02,21,13,0) Field is NOT heritable. BASIC field. "^DD",8925.1,8925.1,3.02,"DT") 2970128 "^DD",8925.1,8925.1,3.03,0) SUPPRESS VISIT SELECTION^S^1:YES;0:NO;^3;3^Q "^DD",8925.1,8925.1,3.03,3) Enter 1 for YES ONLY IF this is an administrative note which creates its own historical visit. You will NOT receive workload credit for such visits. "^DD",8925.1,8925.1,3.03,21,0) ^^17^17^2970220^ "^DD",8925.1,8925.1,3.03,21,1,0) Applies to entries of Type Class, Document Class, and Title. "^DD",8925.1,8925.1,3.03,21,2,0) "^DD",8925.1,8925.1,3.03,21,3,0) For most documents it is very important that the user entering a document "^DD",8925.1,8925.1,3.03,21,4,0) select the appropriate visit to link the document with. However, "^DD",8925.1,8925.1,3.03,21,5,0) certain administrative documents for outpatients have no particular visit "^DD",8925.1,8925.1,3.03,21,6,0) that they should be linked with. For example, a clinician could have a "^DD",8925.1,8925.1,3.03,21,7,0) chance encounter with a patient in the corridor and want to document the "^DD",8925.1,8925.1,3.03,21,8,0) discussion, or a clinician could simply want to remind him/herself of "^DD",8925.1,8925.1,3.03,21,9,0) something for a given patient. Documents for such purposes can be set to "^DD",8925.1,8925.1,3.03,21,10,0) automatically create their own historical visit when they are entered, so "^DD",8925.1,8925.1,3.03,21,11,0) that the user is not asked to select a visit. "^DD",8925.1,8925.1,3.03,21,12,0) "^DD",8925.1,8925.1,3.03,21,13,0) Warning: Such documents DO NOT GIVE WORKLOAD CREDIT. "^DD",8925.1,8925.1,3.03,21,14,0) "^DD",8925.1,8925.1,3.03,21,15,0) Heritable. BASIC field. If field has no value and there is no value "^DD",8925.1,8925.1,3.03,21,16,0) to inherit, default value is NO. For information on editing heritable "^DD",8925.1,8925.1,3.03,21,17,0) fields, see Technical Field Edit Template. "^DD",8925.1,8925.1,3.03,"DT") 2970124 "^DD",8925.1,8925.1,4,0) UPLOAD LOOK-UP METHOD^K^^4;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4,3) Please enter the MUMPS code to be executed for record location. "^DD",8925.1,8925.1,4,9) @ "^DD",8925.1,8925.1,4,21,0) ^^12^12^2970107^^ "^DD",8925.1,8925.1,4,21,1,0) Sometimes when an entry is uploaded into the target file, a new entry is "^DD",8925.1,8925.1,4,21,2,0) created for it. However, in other cases such as for Operative Reports, or "^DD",8925.1,8925.1,4,21,3,0) for an addendum, the file entry already exists and must be looked-up and "^DD",8925.1,8925.1,4,21,4,0) edited. "^DD",8925.1,8925.1,4,21,5,0) "^DD",8925.1,8925.1,4,21,6,0) Look-Up Method is the MUMPS code invoked to perform such a look-up on the "^DD",8925.1,8925.1,4,21,7,0) target file. If a look-up is necessary and this field is blank, a regular "^DD",8925.1,8925.1,4,21,8,0) DIC lookup is performed. If the regular DIC lookup is not sufficient to "^DD",8925.1,8925.1,4,21,9,0) locate the appropriate entry, this field should contain the lookup. It "^DD",8925.1,8925.1,4,21,10,0) should expect any look-up special variables named in the header fields as "^DD",8925.1,8925.1,4,21,11,0) input variables, and should return the variable Y in DIC-compatible format "^DD",8925.1,8925.1,4,21,12,0) (i.e., IEN^EXTERNAL VALUE[^1]). "^DD",8925.1,8925.1,4,"DT") 2960729 "^DD",8925.1,8925.1,4.1,0) COMMIT ACTION^K^^4.1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.1,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.1,9) @ "^DD",8925.1,8925.1,4.1,21,0) ^^3^3^2980122^ "^DD",8925.1,8925.1,4.1,21,1,0) This M-Code is executed when the TIU document is "committed" to the "^DD",8925.1,8925.1,4.1,21,2,0) database (i.e., when the document is saved, and prior to release, "^DD",8925.1,8925.1,4.1,21,3,0) verification, or signature). Heritable. TECHNICAL field. "^DD",8925.1,8925.1,4.1,"DT") 2971126 "^DD",8925.1,8925.1,4.2,0) RELEASE ACTION^K^^4.2;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.2,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.2,9) @ "^DD",8925.1,8925.1,4.2,21,0) ^^2^2^2980126^^ "^DD",8925.1,8925.1,4.2,21,1,0) This M-Code is executed upon Release of the document. Heritable. "^DD",8925.1,8925.1,4.2,21,2,0) TECHNICAL field. "^DD",8925.1,8925.1,4.2,"DT") 2971126 "^DD",8925.1,8925.1,4.3,0) VERIFICATION ACTION^K^^4.3;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.3,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.3,9) @ "^DD",8925.1,8925.1,4.3,21,0) ^^2^2^2980122^ "^DD",8925.1,8925.1,4.3,21,1,0) This M-Code is executed upon Verification of the document. Heritable. "^DD",8925.1,8925.1,4.3,21,2,0) TECHNICAL field. "^DD",8925.1,8925.1,4.3,"DT") 2971126 "^DD",8925.1,8925.1,4.4,0) DELETE ACTION^K^^4.4;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.4,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.4,9) @ "^DD",8925.1,8925.1,4.4,21,0) ^^2^2^2980122^ "^DD",8925.1,8925.1,4.4,21,1,0) This M-Code is executed upon Deletion of the document. Heritable. "^DD",8925.1,8925.1,4.4,21,2,0) TECHNICAL field. "^DD",8925.1,8925.1,4.4,"DT") 2971126 "^DD",8925.1,8925.1,4.45,0) PACKAGE REASSIGNMENT ACTION^K^^4.45;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.45,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.45,9) @ "^DD",8925.1,8925.1,4.45,21,0) ^^2^2^2980122^ "^DD",8925.1,8925.1,4.45,21,1,0) This M-Code is executed when a document with a link to a client "^DD",8925.1,8925.1,4.45,21,2,0) application is Reassigned. Heritable. TECHNICAL field. "^DD",8925.1,8925.1,4.45,"DT") 2971202 "^DD",8925.1,8925.1,4.5,0) UPLOAD POST-FILING CODE^K^^4.5;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.5,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.5,9) @ "^DD",8925.1,8925.1,4.5,21,0) ^^4^4^2970522^ "^DD",8925.1,8925.1,4.5,21,1,0) This field specifies code to be executed following the successful filing "^DD",8925.1,8925.1,4.5,21,2,0) of an uploaded record. It may be used to send bulletins or alerts, "^DD",8925.1,8925.1,4.5,21,3,0) evaluate expected signers/cosigners, trigger events, update statuses, or "^DD",8925.1,8925.1,4.5,21,4,0) whatever the designer of the application deems appropriate. "^DD",8925.1,8925.1,4.5,"DT") 2960729 "^DD",8925.1,8925.1,4.6,0) ENTRY ACTION^KX^^4.6;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.6,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.6,9) @ "^DD",8925.1,8925.1,4.6,21,0) ^^3^3^2980126^^ "^DD",8925.1,8925.1,4.6,21,1,0) This M-Code is executed during the Entry/Editing of a document, after "^DD",8925.1,8925.1,4.6,21,2,0) selection of the Title, and prior to selection of the Patient. It may be "^DD",8925.1,8925.1,4.6,21,3,0) used to set up environmental variables, etc. Heritable. TECHNICAL field. "^DD",8925.1,8925.1,4.6,"DT") 2961022 "^DD",8925.1,8925.1,4.7,0) EXIT ACTION^KX^^4.7;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.7,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.7,9) @ "^DD",8925.1,8925.1,4.7,21,0) ^^3^3^2980126^^ "^DD",8925.1,8925.1,4.7,21,1,0) This M-Code is executed just prior to Exit from the entry/edit process "^DD",8925.1,8925.1,4.7,21,2,0) for a document. It may be used to send alerts or bulletins, clean up "^DD",8925.1,8925.1,4.7,21,3,0) temporary global variables, etc. Heritable. TECHNICAL field. "^DD",8925.1,8925.1,4.7,"DT") 2961022 "^DD",8925.1,8925.1,4.8,0) UPLOAD FILING ERROR CODE^K^^4.8;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.8,.1) UPLOAD FILING ERROR RESOLUTION CODE "^DD",8925.1,8925.1,4.8,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.8,9) @ "^DD",8925.1,8925.1,4.8,21,0) ^^6^6^2970106^ "^DD",8925.1,8925.1,4.8,21,1,0) This MUMPS-type field specifies the code to be executed when the user "^DD",8925.1,8925.1,4.8,21,2,0) attempts to resolve a filing error. Filing Errors may be resolved either "^DD",8925.1,8925.1,4.8,21,3,0) by responding to a Filing Error Alert or through the option to Review "^DD",8925.1,8925.1,4.8,21,4,0) Upload Events. Typically, the code will offer the user an opportunity to "^DD",8925.1,8925.1,4.8,21,5,0) look up online information necessary to resolve the error (e.g., "^DD",8925.1,8925.1,4.8,21,6,0) demographic, or case-related information). "^DD",8925.1,8925.1,4.8,"DT") 2960729 "^DD",8925.1,8925.1,4.9,0) POST-SIGNATURE CODE^K^^4.9;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,4.9,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,4.9,9) @ "^DD",8925.1,8925.1,4.9,21,0) ^^2^2^2980126^^ "^DD",8925.1,8925.1,4.9,21,1,0) This M-Code is executed following Signature (or Cosignature) of a TIU "^DD",8925.1,8925.1,4.9,21,2,0) document. Heritable. TECHNICAL field. "^DD",8925.1,8925.1,4.9,"DT") 2971001 "^DD",8925.1,8925.1,5,0) EDIT TEMPLATE^FX^^5;E1,245^K:$L(X)>60!($L(X)<2) X "^DD",8925.1,8925.1,5,3) Enter the name of the Input Template for documents defined by this entry. "^DD",8925.1,8925.1,5,4) D HELP1^TIUFXHLX(5) "^DD",8925.1,8925.1,5,9) @ "^DD",8925.1,8925.1,5,21,0) ^^19^19^2980126^^ "^DD",8925.1,8925.1,5,21,1,0) Applies to Classes, Document Classes, Titles. This is the Input Template "^DD",8925.1,8925.1,5,21,2,0) for Entering/Editing documents defined by this entry. Template "^DD",8925.1,8925.1,5,21,3,0) includes fixed field information such as Patient, etc. Enter Edit "^DD",8925.1,8925.1,5,21,4,0) Template in Format [TEMPLATE NAME], or as a "field-string" (e.g., "^DD",8925.1,8925.1,5,21,5,0) .01;1;3;5). Heritable. TECHNICAL field. "^DD",8925.1,8925.1,5,21,6,0) "^DD",8925.1,8925.1,5,21,7,0) NOTE on editing heritable fields: "^DD",8925.1,8925.1,5,21,8,0) "^DD",8925.1,8925.1,5,21,9,0) When editing heritable fields, the user is presented with the EFFECTIVE "^DD",8925.1,8925.1,5,21,10,0) value of the field as the default (e.g. NO//). This is the same as the "^DD",8925.1,8925.1,5,21,11,0) value shown in the display and is the field's own value if it has one, the "^DD",8925.1,8925.1,5,21,12,0) inherited value if the field does not have its own value, or the default "^DD",8925.1,8925.1,5,21,13,0) for the field if the field has neither its own nor an inherited value. If "^DD",8925.1,8925.1,5,21,14,0) the user accepts this default by pressing return, the value is made "^DD",8925.1,8925.1,5,21,15,0) explicit, i.e., entered into the field. If a user does NOT want to make "^DD",8925.1,8925.1,5,21,16,0) the value explicit, the user should enter @, which leaves a blank field "^DD",8925.1,8925.1,5,21,17,0) blank. If the user want to delete an explicit value, the user should "^DD",8925.1,8925.1,5,21,18,0) enter @, which deletes the field value, leaving TIU to use the effective "^DD",8925.1,8925.1,5,21,19,0) value for the field. "^DD",8925.1,8925.1,5,"DT") 2961022 "^DD",8925.1,8925.1,6,0) PRINT METHOD^KX^^6;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,6,3) Please enter the MUMPS code to be executed to print a record. "^DD",8925.1,8925.1,6,4) D HELP1^TIUFXHLX(6) "^DD",8925.1,8925.1,6,9) @ "^DD",8925.1,8925.1,6,21,0) ^^5^5^2980126^^ "^DD",8925.1,8925.1,6,21,1,0) Applies to Types Class, Document Class, Title. This M-Code is executed "^DD",8925.1,8925.1,6,21,2,0) when a document is Printed from the TIU List Manager screen (as opposed to "^DD",8925.1,8925.1,6,21,3,0) a separate print option which may have its own code.) Heritable. TECHNICAL "^DD",8925.1,8925.1,6,21,4,0) field. For more information on editing heritable fields, see Technical "^DD",8925.1,8925.1,6,21,5,0) field Edit Template. "^DD",8925.1,8925.1,6,"DT") 2961022 "^DD",8925.1,8925.1,6.1,0) PRINT FORM HEADER^FX^^6.1;1^K:$L(X)>40!($L(X)<3) X "^DD",8925.1,8925.1,6.1,3) Answer must be 3-40 characters in length. "^DD",8925.1,8925.1,6.1,4) D HELP1^TIUFXHLX(6.1) "^DD",8925.1,8925.1,6.1,21,0) ^^12^12^2970108^^ "^DD",8925.1,8925.1,6.1,21,1,0) For basic information on Print Form Header see Technical field Allow "^DD",8925.1,8925.1,6.1,21,2,0) Custom Form Headers. "^DD",8925.1,8925.1,6.1,21,3,0) "^DD",8925.1,8925.1,6.1,21,4,0) The Print Form Header is the official medical record title of the document "^DD",8925.1,8925.1,6.1,21,5,0) which has been approved by the Medical Record Committee based on national "^DD",8925.1,8925.1,6.1,21,6,0) guidelines. "^DD",8925.1,8925.1,6.1,21,7,0) "^DD",8925.1,8925.1,6.1,21,8,0) Examples: Progress Notes, Physical Examination, History - Part 1, etc. "^DD",8925.1,8925.1,6.1,21,9,0) "^DD",8925.1,8925.1,6.1,21,10,0) This field is heritable with lower level values overriding higher ones AS "^DD",8925.1,8925.1,6.1,21,11,0) LONG AS the field is applicable. See Allow Custom Form Headers. Print "^DD",8925.1,8925.1,6.1,21,12,0) Form Header is a TECHNICAL field. "^DD",8925.1,8925.1,6.1,23,0) ^^6^6^2970108^^^^ "^DD",8925.1,8925.1,6.1,23,1,0) The narrative stored in this field will display as the form header of a "^DD",8925.1,8925.1,6.1,23,2,0) document. If entered at a CLASS level such as FORMS, all forms documents "^DD",8925.1,8925.1,6.1,23,3,0) will display entered header as the form header of the document. If "^DD",8925.1,8925.1,6.1,23,4,0) the free text is entered at a lower level (i.e., TITLE), this form header "^DD",8925.1,8925.1,6.1,23,5,0) will override the one entered at the higher level and will be displayed on "^DD",8925.1,8925.1,6.1,23,6,0) the form. "^DD",8925.1,8925.1,6.1,"DT") 2961022 "^DD",8925.1,8925.1,6.12,0) PRINT FORM NUMBER^FX^^6.1;2^K:$L(X)>20!($L(X)<3) X "^DD",8925.1,8925.1,6.12,3) Answer must be 3-20 characters in length. "^DD",8925.1,8925.1,6.12,4) D HELP1^TIUFXHLX(6.12) "^DD",8925.1,8925.1,6.12,21,0) ^^13^13^2970106^ "^DD",8925.1,8925.1,6.12,21,1,0) For basic information on Print Form Number see Technical field Allow "^DD",8925.1,8925.1,6.12,21,2,0) Custom Form Headers. "^DD",8925.1,8925.1,6.12,21,3,0) "^DD",8925.1,8925.1,6.12,21,4,0) The Print Form Number is the official medical record form number of the "^DD",8925.1,8925.1,6.12,21,5,0) document which has been approved by the Medical Record Committee based "^DD",8925.1,8925.1,6.12,21,6,0) on national guidelines. "^DD",8925.1,8925.1,6.12,21,7,0) "^DD",8925.1,8925.1,6.12,21,8,0) Example: Progress Note - Vice SF 509, Consult - SF 513, Physicial "^DD",8925.1,8925.1,6.12,21,9,0) Examination - SF 506. "^DD",8925.1,8925.1,6.12,21,10,0) "^DD",8925.1,8925.1,6.12,21,11,0) Field is heritable with lower level values overriding higher ones AS LONG "^DD",8925.1,8925.1,6.12,21,12,0) AS the field is applicable. See field Allow Custom Form Headers. Print "^DD",8925.1,8925.1,6.12,21,13,0) Form Header is a TECHNICAL field. "^DD",8925.1,8925.1,6.12,23,0) ^^6^6^2970106^^^^ "^DD",8925.1,8925.1,6.12,23,1,0) The free text stored in this field will be displayed as the form number of "^DD",8925.1,8925.1,6.12,23,2,0) a document. If entered at a CLASS level such as Forms, all Forms "^DD",8925.1,8925.1,6.12,23,3,0) documents will display the entered value as the form number of the "^DD",8925.1,8925.1,6.12,23,4,0) document. If the free text is entered at a lower level (i.e., TITLE), "^DD",8925.1,8925.1,6.12,23,5,0) this value will override the one entered at the higher level and will be "^DD",8925.1,8925.1,6.12,23,6,0) displayed on the form. "^DD",8925.1,8925.1,6.12,"DT") 2961022 "^DD",8925.1,8925.1,6.13,0) PRINT GROUP^NJ2,0X^^6.1;3^K:+X'=X!(X>10)!(X<1)!(X?.E1"."1N.N) X "^DD",8925.1,8925.1,6.13,3) Type a Number between 1 and 10, 0 Decimal Digits. Enter ?? for help. "^DD",8925.1,8925.1,6.13,4) D HELP1^TIUFXHLX(6.13) "^DD",8925.1,8925.1,6.13,21,0) ^^19^19^2970106^ "^DD",8925.1,8925.1,6.13,21,1,0) For basic information on Print Group see Technical field Allow Custom Form "^DD",8925.1,8925.1,6.13,21,2,0) Headers. "^DD",8925.1,8925.1,6.13,21,3,0) "^DD",8925.1,8925.1,6.13,21,4,0) Print Group is an integer number which serves to group by print form "^DD",8925.1,8925.1,6.13,21,5,0) headers/numbers related documents that share a common print method; e.g., "^DD",8925.1,8925.1,6.13,21,6,0) Progress Notes, H&P's, and other documents may share a common print "^DD",8925.1,8925.1,6.13,21,7,0) method, but have differing form headers/numbers and should each print in "^DD",8925.1,8925.1,6.13,21,8,0) their own, separate collation. Specifying a common print group for "^DD",8925.1,8925.1,6.13,21,9,0) documents with the same headers/numbers (for example, Progress Notes have "^DD",8925.1,8925.1,6.13,21,10,0) Print Group 2, H&P's might have Print Group 7) causes such documents "^DD",8925.1,8925.1,6.13,21,11,0) from each print group to collate together when a mixed print is called "^DD",8925.1,8925.1,6.13,21,12,0) for. "^DD",8925.1,8925.1,6.13,21,13,0) "^DD",8925.1,8925.1,6.13,21,14,0) Since documents collate first by print method, then by print group, print "^DD",8925.1,8925.1,6.13,21,15,0) group is not necessary unless documents share a common print method. "^DD",8925.1,8925.1,6.13,21,16,0) "^DD",8925.1,8925.1,6.13,21,17,0) Print Group is heritable with lower level values overriding higher ones AS "^DD",8925.1,8925.1,6.13,21,18,0) LONG AS the field is applicable. See Allow Custom Form Headers. Print "^DD",8925.1,8925.1,6.13,21,19,0) Group is a TECHNICAL field. "^DD",8925.1,8925.1,6.13,"DT") 2961022 "^DD",8925.1,8925.1,6.14,0) ALLOW CUSTOM FORM HEADERS^SX^1:YES;0:NO;^6.1;4^Q "^DD",8925.1,8925.1,6.14,.1) ALLOW CUSTOM FORM HEADERS/NUMBERS AT LOWER LEVELS "^DD",8925.1,8925.1,6.14,3) May be set for Types CL and DC only. Enter 1 for YES if descendent Titles can have individual (Custom) Form Headers/Numbers within their Document Class. Otherwise enter 0. "^DD",8925.1,8925.1,6.14,4) D CUSTOM^TIUFXHLX "^DD",8925.1,8925.1,6.14,21,0) ^^69^69^2980122^ "^DD",8925.1,8925.1,6.14,21,1,0) Allow Custom Form Headers may be set for entries of Type Class or Document "^DD",8925.1,8925.1,6.14,21,2,0) Class and affects DESCENDANTS of the entry for which it is set. "^DD",8925.1,8925.1,6.14,21,3,0) "^DD",8925.1,8925.1,6.14,21,4,0) Information on Form Headers, Form Numbers, Print Group, and Allow Custom "^DD",8925.1,8925.1,6.14,21,5,0) Form Headers: "^DD",8925.1,8925.1,6.14,21,6,0) "^DD",8925.1,8925.1,6.14,21,7,0) Some clinical documents use Forms with Form Headers and Form Numbers, for "^DD",8925.1,8925.1,6.14,21,8,0) example, Progress Note Forms have Header 'Progress Notes' and Number 'Vice "^DD",8925.1,8925.1,6.14,21,9,0) SF 509.' "^DD",8925.1,8925.1,6.14,21,10,0) "^DD",8925.1,8925.1,6.14,21,11,0) The Owner of a Document Definition must decide whether all documents "^DD",8925.1,8925.1,6.14,21,12,0) descending from the entry will have the SAME Header/Number, or whether to "^DD",8925.1,8925.1,6.14,21,13,0) allow CUSTOM (varying) Headers/Numbers at lower levels. "^DD",8925.1,8925.1,6.14,21,14,0) "^DD",8925.1,8925.1,6.14,21,15,0) Allow Custom Headers holds the decision: If the field has value 0 for NO, "^DD",8925.1,8925.1,6.14,21,16,0) then ALL descendant documents use a COMMON Header/Number (or perhaps they "^DD",8925.1,8925.1,6.14,21,17,0) all use NO Header/Number); they also collate together in printouts. "^DD",8925.1,8925.1,6.14,21,18,0) "^DD",8925.1,8925.1,6.14,21,19,0) For example, Class Progress Notes does NOT Allow Custom Form Headers. This "^DD",8925.1,8925.1,6.14,21,20,0) means that ALL Progress Note Titles have the same header and the same form "^DD",8925.1,8925.1,6.14,21,21,0) number. For Class Progress Notes, Field Print Form Header holds the "^DD",8925.1,8925.1,6.14,21,22,0) header 'Progress Notes', Field Print Form Number holds Form Number 'Vice "^DD",8925.1,8925.1,6.14,21,23,0) SF 509', and Field Print Group holds '2'. Since Class Progress Notes does "^DD",8925.1,8925.1,6.14,21,24,0) not Allow Custom Form Headers, these field values apply for ALL Progress "^DD",8925.1,8925.1,6.14,21,25,0) Note Titles. That is, all Progress Notes have header 'Progress Notes', "^DD",8925.1,8925.1,6.14,21,26,0) Form Number 'Vice SF 509', and collate together in printouts. "^DD",8925.1,8925.1,6.14,21,27,0) "^DD",8925.1,8925.1,6.14,21,28,0) Field Allow Custom Field Headers also determines whether or not related "^DD",8925.1,8925.1,6.14,21,29,0) Fields Print Form Header, Print Form Number, Print Group, (and even Allow "^DD",8925.1,8925.1,6.14,21,30,0) Custom Field Headers) are applicable at lower levels. If an entry at a "^DD",8925.1,8925.1,6.14,21,31,0) particular level DOES allow Custom Form Headers, then these related fields "^DD",8925.1,8925.1,6.14,21,32,0) DO APPLY to descendants at the next lower level. If an entry at a "^DD",8925.1,8925.1,6.14,21,33,0) particular level DOES NOT allow Custom Form Headers, then ALL LOWER LEVELS "^DD",8925.1,8925.1,6.14,21,34,0) inherit the the prohibition, and the related fields DO NOT APPLY at ANY "^DD",8925.1,8925.1,6.14,21,35,0) lower levels. "^DD",8925.1,8925.1,6.14,21,36,0) "^DD",8925.1,8925.1,6.14,21,37,0) Example: Since Class Progress Notes does NOT Allow Custom Form Headers, "^DD",8925.1,8925.1,6.14,21,38,0) fields Print Form Header, Print Form Number, Print Group, and Allow Custom "^DD",8925.1,8925.1,6.14,21,39,0) Field Headers DO NOT APPLY to Document Classes or Titles under Progress "^DD",8925.1,8925.1,6.14,21,40,0) Notes. This means that Document Definitions for documents requiring "^DD",8925.1,8925.1,6.14,21,41,0) different Form Headers/Numbers must be placed under a separate line of "^DD",8925.1,8925.1,6.14,21,42,0) descent in the hierarchy; they cannot be under Progress Notes. "^DD",8925.1,8925.1,6.14,21,43,0) "^DD",8925.1,8925.1,6.14,21,44,0) Example: Class Clinical Documents, the Mother of all Document Definitions, "^DD",8925.1,8925.1,6.14,21,45,0) does not want to REQUIRE all Document Definitions under it to use one "^DD",8925.1,8925.1,6.14,21,46,0) common Header. So Clinical Documents DOES Allow Custom Form Headers. "^DD",8925.1,8925.1,6.14,21,47,0) Classes/Document Classes UNDER CLinical Documents can decide for "^DD",8925.1,8925.1,6.14,21,48,0) themselves whether or not to Allow Custom Headers for their own Items. "^DD",8925.1,8925.1,6.14,21,49,0) "^DD",8925.1,8925.1,6.14,21,50,0) Example: Class DISCHARGE SUMMARY has only one Form Header and Number which "^DD",8925.1,8925.1,6.14,21,51,0) is used by all Discharge Summary documents. So Class Discharge Summary "^DD",8925.1,8925.1,6.14,21,52,0) does NOT Allow Custom Headers. "^DD",8925.1,8925.1,6.14,21,53,0) "^DD",8925.1,8925.1,6.14,21,54,0) Example: Class FORMS might contain miscellaneous documents, each using "^DD",8925.1,8925.1,6.14,21,55,0) a different Form with its own Form Header and Form Number. So Class Forms "^DD",8925.1,8925.1,6.14,21,56,0) would Allow Custom Headers. "^DD",8925.1,8925.1,6.14,21,57,0) "^DD",8925.1,8925.1,6.14,21,58,0) Field Allow Custom Form Headers may be set for Document Definitions of "^DD",8925.1,8925.1,6.14,21,59,0) Type Class or Document Class only, and affects the DESCENDANTS of the "^DD",8925.1,8925.1,6.14,21,60,0) entry for which it is set. "^DD",8925.1,8925.1,6.14,21,61,0) "^DD",8925.1,8925.1,6.14,21,62,0) If a DOCUMENT CLASS Allows Custom Form Headers, then TIUF, the Document "^DD",8925.1,8925.1,6.14,21,63,0) Definition Utility, does not permit a descendant Title to be activated "^DD",8925.1,8925.1,6.14,21,64,0) unless fields Print Form Header, Print Form Number, and Print Group have a "^DD",8925.1,8925.1,6.14,21,65,0) value (of their own or inherited). If NO Header, or Number is desired, "^DD",8925.1,8925.1,6.14,21,66,0) enter 'NONE'. If NO Print Group is desired, enter '0'. "^DD",8925.1,8925.1,6.14,21,67,0) "^DD",8925.1,8925.1,6.14,21,68,0) For information on editing heritable fields, see Technical field Edit "^DD",8925.1,8925.1,6.14,21,69,0) Template. "^DD",8925.1,8925.1,6.14,"DT") 2970128 "^DD",8925.1,8925.1,7,0) VISIT LINKAGE METHOD^KX^^7;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,7,3) Please enter the MUMPS code to be executed to establish Visit Linkage. "^DD",8925.1,8925.1,7,4) D HELP1^TIUFXHLX(7) "^DD",8925.1,8925.1,7,9) @ "^DD",8925.1,8925.1,7,21,0) ^^6^6^2980122^ "^DD",8925.1,8925.1,7,21,1,0) Applies to Types Class, Document Class, Title. This M-Code is executed to "^DD",8925.1,8925.1,7,21,2,0) establish Visit Linkage, usually displaying appropriate visits and "^DD",8925.1,8925.1,7,21,3,0) prompting the user to select the correct one. "^DD",8925.1,8925.1,7,21,4,0) "^DD",8925.1,8925.1,7,21,5,0) Heritable. TECHNICAL Field. For information on editing heritable fields, "^DD",8925.1,8925.1,7,21,6,0) see Technical Field Edit Template. "^DD",8925.1,8925.1,7,"DT") 2961022 "^DD",8925.1,8925.1,8,0) VALIDATION METHOD^KX^^8;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,8,3) Please enter the MUMPS code to be executed to validate the selection of patient and Visit/Admission. "^DD",8925.1,8925.1,8,4) D HELP1^TIUFXHLX(8) "^DD",8925.1,8925.1,8,9) @ "^DD",8925.1,8925.1,8,21,0) ^^7^7^2980126^^ "^DD",8925.1,8925.1,8,21,1,0) Applies to Types Class, Document Class, Title. This is the M-Code to be "^DD",8925.1,8925.1,8,21,2,0) invoked when Validating the visit and other fixed field information on a "^DD",8925.1,8925.1,8,21,3,0) record during entry/edit. User is asked to OK or to correct the "^DD",8925.1,8925.1,8,21,4,0) information. "^DD",8925.1,8925.1,8,21,5,0) "^DD",8925.1,8925.1,8,21,6,0) Heritable. TECHNICAL field. For information on editing heritable fields, "^DD",8925.1,8925.1,8,21,7,0) see Technical field Edit Template. "^DD",8925.1,8925.1,8,"DT") 2961022 "^DD",8925.1,8925.1,9,0) OBJECT METHOD^KX^^9;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.1,9,3) This is Standard MUMPS code. "^DD",8925.1,8925.1,9,9) @ "^DD",8925.1,8925.1,9,21,0) ^^3^3^2980122^ "^DD",8925.1,8925.1,9,21,1,0) Applies to Objects. This M-Code is invoked when a document is entered "^DD",8925.1,8925.1,9,21,2,0) whose boilerplate text contains the object. Extracted data are inserted "^DD",8925.1,8925.1,9,21,3,0) into document text. Author then edits/adds to text. TECHNICAL field. "^DD",8925.1,8925.1,9,"DT") 2961022 "^DD",8925.1,8925.1,10,0) ITEM^8925.14P^^10;0 "^DD",8925.1,8925.1,11,0) STAT AUTO PRINT EVENT^8925.111SA^^11;0 "^DD",8925.1,8925.1,11,21,0) ^^35^35^2970220^ "^DD",8925.1,8925.1,11,21,1,0) This parameter applies only to stat documents. "^DD",8925.1,8925.1,11,21,2,0) "^DD",8925.1,8925.1,11,21,3,0) This parameter determines at what stage(s) a document should be "^DD",8925.1,8925.1,11,21,4,0) automatically printed for chart, either singly when document is ready, or "^DD",8925.1,8925.1,11,21,5,0) in batch mode. "^DD",8925.1,8925.1,11,21,6,0) "^DD",8925.1,8925.1,11,21,7,0) Some documents will need to be printed for chart only when they are "^DD",8925.1,8925.1,11,21,8,0) complete, ie have obtained all expected signatures and cosignatures. "^DD",8925.1,8925.1,11,21,9,0) Others should perhaps be printed for chart at an earlier stage, allowing "^DD",8925.1,8925.1,11,21,10,0) earlier chart access, and then be reprinted when complete. Documents may "^DD",8925.1,8925.1,11,21,11,0) also need to be reprinted AFTER completion for certain events such as "^DD",8925.1,8925.1,11,21,12,0) amendment. "^DD",8925.1,8925.1,11,21,13,0) "^DD",8925.1,8925.1,11,21,14,0) Any event which should trigger auto printing of the document should be "^DD",8925.1,8925.1,11,21,15,0) entered as an auto print event. "^DD",8925.1,8925.1,11,21,16,0) "^DD",8925.1,8925.1,11,21,17,0) - SIGNED means firstline signature, as opposed to secondline cosignature. "^DD",8925.1,8925.1,11,21,18,0) - COSIGNED, OPTIONAL, INCOMPLETE means when an incomplete document obtains "^DD",8925.1,8925.1,11,21,19,0) an optional cosignature. "^DD",8925.1,8925.1,11,21,20,0) - COSIGNED, OPTIONAL, COMPLETED means when a previously completed "^DD",8925.1,8925.1,11,21,21,0) document obtains an optional cosignature, namely, a walkup. "^DD",8925.1,8925.1,11,21,22,0) - COMPLETED means when some event occurs that completes the document, for "^DD",8925.1,8925.1,11,21,23,0) example the document obtains its last expected optional cosignature. "^DD",8925.1,8925.1,11,21,24,0) "^DD",8925.1,8925.1,11,21,25,0) If one event occurs to a document and corresponds to two selected print "^DD",8925.1,8925.1,11,21,26,0) events (such as COMPLETED and COSIGNED OPTIONAL INCOMPLETE), the document "^DD",8925.1,8925.1,11,21,27,0) will only print once. "^DD",8925.1,8925.1,11,21,28,0) "^DD",8925.1,8925.1,11,21,29,0) If parameter is not entered and Document Definition has no ancestor to "^DD",8925.1,8925.1,11,21,30,0) inherit from, parameter assumes default value N for NONE. If parameter is "^DD",8925.1,8925.1,11,21,31,0) not entered and Document Definition has a parent to inherit from, then "^DD",8925.1,8925.1,11,21,32,0) parameter assumes value (assumed or explicit) of parent print events. If "^DD",8925.1,8925.1,11,21,33,0) parameter is non applicable because Document Definition does not allow "^DD",8925.1,8925.1,11,21,34,0) stat documents, or because Document Definition does not allow auto "^DD",8925.1,8925.1,11,21,35,0) printing, enter N for NONE. "^DD",8925.1,8925.1,11,"DT") 2940621 "^DD",8925.1,8925.1,12,0) ROUTINE AUTO PRINT EVENT^8925.112SA^^12;0 "^DD",8925.1,8925.1,12,21,0) ^^5^5^2970220^ "^DD",8925.1,8925.1,12,21,1,0) This parameter applies to routine (non-stat) documents only. Documents "^DD",8925.1,8925.1,12,21,2,0) whose Document Definitions do not allow stat documents are considered "^DD",8925.1,8925.1,12,21,3,0) routine. "^DD",8925.1,8925.1,12,21,4,0) "^DD",8925.1,8925.1,12,21,5,0) See parameter STAT AUTO PRINT EVENT for description. "^DD",8925.1,8925.1,13,0) PROCESSING STEPS^8925.113P^^13;0 "^DD",8925.1,8925.1,13,21,0) ^^3^3^2950216^^ "^DD",8925.1,8925.1,13,21,1,0) This sub-file contains the optional and required steps for processing any "^DD",8925.1,8925.1,13,21,2,0) document, along with the states (e.g., unverified -> unsigned) that a given "^DD",8925.1,8925.1,13,21,3,0) step (e.g., verification) moves the document between. "^DD",8925.1,8925.1,14,0) DIALOG^8925.114^^DIALOG;0 "^DD",8925.1,8925.1,14,21,0) ^^2^2^2950606^ "^DD",8925.1,8925.1,14,21,1,0) This sub-file contains the data necessary to handle server-based definition "^DD",8925.1,8925.1,14,21,2,0) for fixed-field data capture in TIU. "^DD",8925.1,8925.1,99,0) TIMESTAMP^F^^99;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>15!($L(X)<1) X "^DD",8925.1,8925.1,99,1,0) ^.1 "^DD",8925.1,8925.1,99,1,1,0) 8925.1^AM^MUMPS "^DD",8925.1,8925.1,99,1,1,1) D SET^TIUDD "^DD",8925.1,8925.1,99,1,1,2) D KILL^TIUDD "^DD",8925.1,8925.1,99,1,1,"%D",0) ^^2^2^2950911^^^ "^DD",8925.1,8925.1,99,1,1,"%D",1,0) This cross-reference invokes menu compilation in ^XUTL("XQORM", "^DD",8925.1,8925.1,99,1,1,"%D",2,0) DA;TIU(8925.1, when the TIMESTAMP field is modified. "^DD",8925.1,8925.1,99,1,1,"DT") 2940720 "^DD",8925.1,8925.1,99,3) Answer must be 1-15 characters in length. "^DD",8925.1,8925.1,99,"DT") 2940720 "^DD",8925.1,8925.11,0) UPLOAD DELIMITED ASCII HEADER SUB-FIELD^^1^8 "^DD",8925.1,8925.11,0,"DT") 2951004 "^DD",8925.1,8925.11,0,"ID",.02) W " ",$P(^(0),U,2) "^DD",8925.1,8925.11,0,"IX","B",8925.11,.01) "^DD",8925.1,8925.11,0,"IX","C",8925.11,.02) "^DD",8925.1,8925.11,0,"IX","D",8925.11,.03) "^DD",8925.1,8925.11,0,"IX","E",8925.11,.04) "^DD",8925.1,8925.11,0,"NM","UPLOAD DELIMITED ASCII HEADER") "^DD",8925.1,8925.11,0,"UP") 8925.1 "^DD",8925.1,8925.11,.01,0) HEADER PIECE^MNJ2,0X^^0;1^K:+X'=X!(X>30)!(X<1)!(X?.E1"."1N.N) X S:$D(X) DINUM=X "^DD",8925.1,8925.11,.01,1,0) ^.1 "^DD",8925.1,8925.11,.01,1,1,0) 8925.11^B "^DD",8925.1,8925.11,.01,1,1,1) S ^TIU(8925.1,DA(1),"ITEM","B",$E(X,1,30),DA)="" "^DD",8925.1,8925.11,.01,1,1,2) K ^TIU(8925.1,DA(1),"ITEM","B",$E(X,1,30),DA) "^DD",8925.1,8925.11,.01,3) Enter the delimiter-piece for the next header item. "^DD",8925.1,8925.11,.01,21,0) ^^2^2^2970107^ "^DD",8925.1,8925.11,.01,21,1,0) This is the number for this piece (item) of the header. Start with "^DD",8925.1,8925.11,.01,21,2,0) number 1 for the first piece. "^DD",8925.1,8925.11,.01,"DT") 2921021 "^DD",8925.1,8925.11,.02,0) ITEM NAME^F^^0;2^K:$L(X)>30!($L(X)<2) X "^DD",8925.1,8925.11,.02,1,0) ^.1 "^DD",8925.1,8925.11,.02,1,1,0) 8925.11^C "^DD",8925.1,8925.11,.02,1,1,1) S ^TIU(8925.1,DA(1),"ITEM","C",$E(X,1,30),DA)="" "^DD",8925.1,8925.11,.02,1,1,2) K ^TIU(8925.1,DA(1),"ITEM","C",$E(X,1,30),DA) "^DD",8925.1,8925.11,.02,1,1,"%D",0) ^^2^2^2921021^ "^DD",8925.1,8925.11,.02,1,1,"%D",1,0) This REGULAR FileMan cross-reference on the ITEM NAME is used in the "^DD",8925.1,8925.11,.02,1,1,"%D",2,0) look-up and edit process. "^DD",8925.1,8925.11,.02,1,1,"DT") 2920605 "^DD",8925.1,8925.11,.02,3) Enter the name of the header item. "^DD",8925.1,8925.11,.02,21,0) ^^2^2^2970107^ "^DD",8925.1,8925.11,.02,21,1,0) This is the name of the item in the ASCII message header. Item Name is "^DD",8925.1,8925.11,.02,21,2,0) used in help messages for the person dictating a document. "^DD",8925.1,8925.11,.02,"DT") 2921021 "^DD",8925.1,8925.11,.03,0) FIELD NUMBER^F^^0;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>10!($L(X)<1) X "^DD",8925.1,8925.11,.03,1,0) ^.1 "^DD",8925.1,8925.11,.03,1,1,0) 8925.11^D "^DD",8925.1,8925.11,.03,1,1,1) S ^TIU(8925.1,DA(1),"ITEM","D",$E(X,1,30),DA)="" "^DD",8925.1,8925.11,.03,1,1,2) K ^TIU(8925.1,DA(1),"ITEM","D",$E(X,1,30),DA) "^DD",8925.1,8925.11,.03,1,1,"%D",0) ^^3^3^2921021^ "^DD",8925.1,8925.11,.03,1,1,"%D",1,0) This REGULAR FileMan cross-reference by field number is used by the "^DD",8925.1,8925.11,.03,1,1,"%D",2,0) filer/router to identify header-pieces with field numbers in the target "^DD",8925.1,8925.11,.03,1,1,"%D",3,0) file. "^DD",8925.1,8925.11,.03,1,1,"DT") 2921021 "^DD",8925.1,8925.11,.03,3) Enter the FIELD # of the item in the target file. "^DD",8925.1,8925.11,.03,21,0) ^^2^2^2970107^ "^DD",8925.1,8925.11,.03,21,1,0) This is the field number in the target file which corresponds to this "^DD",8925.1,8925.11,.03,21,2,0) header item. "^DD",8925.1,8925.11,.03,"DT") 2921021 "^DD",8925.1,8925.11,.04,0) LOOKUP LOCAL VARIABLE NAME^F^^0;4^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>8!($L(X)<1)!'(X?1A1.7E) X "^DD",8925.1,8925.11,.04,1,0) ^.1 "^DD",8925.1,8925.11,.04,1,1,0) 8925.11^E "^DD",8925.1,8925.11,.04,1,1,1) S ^TIU(8925.1,DA(1),"ITEM","E",$E(X,1,30),DA)="" "^DD",8925.1,8925.11,.04,1,1,2) K ^TIU(8925.1,DA(1),"ITEM","E",$E(X,1,30),DA) "^DD",8925.1,8925.11,.04,1,1,"%D",0) ^^3^3^2921109^ "^DD",8925.1,8925.11,.04,1,1,"%D",1,0) This cross-reference is used by the router/filer to determine which pieces "^DD",8925.1,8925.11,.04,1,1,"%D",2,0) of the header should be set into special variables which may be required by "^DD",8925.1,8925.11,.04,1,1,"%D",3,0) the lookup routine. "^DD",8925.1,8925.11,.04,1,1,"DT") 2921109 "^DD",8925.1,8925.11,.04,3) Enter the required local variable into which this piece will be set. "^DD",8925.1,8925.11,.04,21,0) ^^11^11^2970107^ "^DD",8925.1,8925.11,.04,21,1,0) This field specifies the local variable name into which this piece of the "^DD",8925.1,8925.11,.04,21,2,0) message header will be set. The local variable is used by the Look-Up "^DD",8925.1,8925.11,.04,21,3,0) Method. For example, if this piece of the header is the patient social "^DD",8925.1,8925.11,.04,21,4,0) security number, the Lookup Local Variable Name might be TIUSSN. The "^DD",8925.1,8925.11,.04,21,5,0) social security number as written by the transcriptionist is first "^DD",8925.1,8925.11,.04,21,6,0) transformed by any existing Transform Code, and then set into this "^DD",8925.1,8925.11,.04,21,7,0) variable (e.g. TIUSSN) for use in Look-Up Method code. "^DD",8925.1,8925.11,.04,21,8,0) "^DD",8925.1,8925.11,.04,21,9,0) Lookup Local Variable Name is necessary only if the information in this "^DD",8925.1,8925.11,.04,21,10,0) piece is required in order to look up the appropriate entry in the target "^DD",8925.1,8925.11,.04,21,11,0) file. "^DD",8925.1,8925.11,.04,"DT") 2921109 "^DD",8925.1,8925.11,.05,0) EXAMPLE ENTRY^F^^0;5^K:$L(X)>39!($L(X)<2) X "^DD",8925.1,8925.11,.05,3) Answer must be 2-39 characters in length. "^DD",8925.1,8925.11,.05,21,0) ^^10^10^2970108^^ "^DD",8925.1,8925.11,.05,21,1,0) This field is used to store sample data for this item in the form the "^DD",8925.1,8925.11,.05,21,2,0) transcriptionist is expected to use when transcribing it. For example, if "^DD",8925.1,8925.11,.05,21,3,0) a patient has Social Security Number 555-12-1212, and the transcriptionist "^DD",8925.1,8925.11,.05,21,4,0) is expected to write 555-12-1212, then an Example Entry should have the "^DD",8925.1,8925.11,.05,21,5,0) form 555-12-1212. "^DD",8925.1,8925.11,.05,21,6,0) "^DD",8925.1,8925.11,.05,21,7,0) The Transform Code, if it exists, then transforms the transcribed Social "^DD",8925.1,8925.11,.05,21,8,0) Security Number 555-12-1212 into the appropriate format for the target "^DD",8925.1,8925.11,.05,21,9,0) file before using the Social Security Number to look-up the appropriate "^DD",8925.1,8925.11,.05,21,10,0) target file entry and/or before entering it in the target file. "^DD",8925.1,8925.11,.05,"DT") 2930224 "^DD",8925.1,8925.11,.06,0) CLINICIAN MUST DICTATE^S^1:YES;0:NO;^0;6^Q "^DD",8925.1,8925.11,.06,3) Answer yes if this field needs to be dictated by the clinician "^DD",8925.1,8925.11,.06,21,0) ^^5^5^2970108^ "^DD",8925.1,8925.11,.06,21,1,0) States whether or not this piece of the header should be dictated by the "^DD",8925.1,8925.11,.06,21,2,0) Clinician. Will be used by the Clinician Help routine to determine if "^DD",8925.1,8925.11,.06,21,3,0) this field should be shown as data that should be dictated. (Some pieces "^DD",8925.1,8925.11,.06,21,4,0) can be entered by the transcriber without being dictated, such as the "^DD",8925.1,8925.11,.06,21,5,0) transcriber identification). "^DD",8925.1,8925.11,.06,"DT") 2930423 "^DD",8925.1,8925.11,.07,0) REQUIRED FIELD?^S^1:YES;0:NO;^0;7^Q "^DD",8925.1,8925.11,.07,3) Please indicate whether the field is required. "^DD",8925.1,8925.11,.07,21,0) ^^5^5^2970108^ "^DD",8925.1,8925.11,.07,21,1,0) This field is used to determine whether a given header piece is required "^DD",8925.1,8925.11,.07,21,2,0) by the application (e.g., Author and Attending Physician may be required "^DD",8925.1,8925.11,.07,21,3,0) for the ongoing processing of a Discharge Summary). Records lacking "^DD",8925.1,8925.11,.07,21,4,0) required fields WILL be entered if possible into the target file but will "^DD",8925.1,8925.11,.07,21,5,0) generate Missing Field Error Alerts. "^DD",8925.1,8925.11,.07,"DT") 2951004 "^DD",8925.1,8925.11,1,0) TRANSFORM CODE^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.11,1,3) This is Standard MUMPS code. "^DD",8925.1,8925.11,1,9) @ "^DD",8925.1,8925.11,1,21,0) ^^11^11^2970108^ "^DD",8925.1,8925.11,1,21,1,0) This standard MUMPS code transforms the transcribed value of the header "^DD",8925.1,8925.11,1,21,2,0) piece into a format acceptable to FileMan (e.g., patient social security "^DD",8925.1,8925.11,1,21,3,0) number 555-12-1212 must be transformed to 555121212 or to whatever "^DD",8925.1,8925.11,1,21,4,0) (external) format FileMan accepts when a user edits the social security "^DD",8925.1,8925.11,1,21,5,0) number field in the target file). "^DD",8925.1,8925.11,1,21,6,0) "^DD",8925.1,8925.11,1,21,7,0) Field values are transformed before being set into Special Lookup "^DD",8925.1,8925.11,1,21,8,0) Variables and before being set into Target Text File Fields. "^DD",8925.1,8925.11,1,21,9,0) "^DD",8925.1,8925.11,1,21,10,0) Field is necessary only if transcribed piece is not in the format Fileman "^DD",8925.1,8925.11,1,21,11,0) accepts for the target file. "^DD",8925.1,8925.11,1,"DT") 2930219 "^DD",8925.1,8925.111,0) STAT AUTO PRINT EVENT SUB-FIELD^^.01^1 "^DD",8925.1,8925.111,0,"DT") 2940621 "^DD",8925.1,8925.111,0,"IX","B",8925.111,.01) "^DD",8925.1,8925.111,0,"NM","STAT AUTO PRINT EVENT") "^DD",8925.1,8925.111,0,"UP") 8925.1 "^DD",8925.1,8925.111,.01,0) STAT AUTO PRINT EVENT^MS^N:NONE;T:TRANSCRIBED;R:RELEASED;V:VERIFIED;S:SIGNED;CSR:COSIGNED, REQUIRED;CSOINC:COSIGNED, OPTIONAL, INCOMPLETE;CSOCP:COSIGNED, OPTIONAL, COMPLETED;CP:COMLETED;AD:ADDENDUM ADDED;AM:AMENDED;^0;1^Q "^DD",8925.1,8925.111,.01,1,0) ^.1 "^DD",8925.1,8925.111,.01,1,1,0) 8925.111^B "^DD",8925.1,8925.111,.01,1,1,1) S ^TIU(8925.1,DA(1),11,"B",$E(X,1,30),DA)="" "^DD",8925.1,8925.111,.01,1,1,2) K ^TIU(8925.1,DA(1),11,"B",$E(X,1,30),DA) "^DD",8925.1,8925.111,.01,3) Enter every event which should trigger auto printing of document whenever the event occurs. "^DD",8925.1,8925.111,.01,"DT") 2941027 "^DD",8925.1,8925.112,0) ROUTINE AUTO PRINT EVENT SUB-FIELD^^.01^1 "^DD",8925.1,8925.112,0,"DT") 2940621 "^DD",8925.1,8925.112,0,"IX","B",8925.112,.01) "^DD",8925.1,8925.112,0,"NM","ROUTINE AUTO PRINT EVENT") "^DD",8925.1,8925.112,0,"UP") 8925.1 "^DD",8925.1,8925.112,.01,0) ROUTINE AUTO PRINT EVENT^MS^N:NONE;T:TRANSCRIBED;R:RELEASED;V:VERIFIED;S:SIGNED;CSR:COSIGNED, REQUIRED;CSOINC:COSIGNED, OPTIONAL, INCOMPLETE;CP:COMPLETED;CSOCP:CONSIGNED, OPTIONAL, COMPLETED;AD:ADDENDUM ADDED;AM:AMENDED;^0;1^Q "^DD",8925.1,8925.112,.01,1,0) ^.1 "^DD",8925.1,8925.112,.01,1,1,0) 8925.112^B "^DD",8925.1,8925.112,.01,1,1,1) S ^TIU(8925.1,DA(1),12,"B",$E(X,1,30),DA)="" "^DD",8925.1,8925.112,.01,1,1,2) K ^TIU(8925.1,DA(1),12,"B",$E(X,1,30),DA) "^DD",8925.1,8925.112,.01,3) Enter an event which should trigger auto printing of routine documents. "^DD",8925.1,8925.112,.01,"DT") 2940621 "^DD",8925.1,8925.113,0) PROCESSING STEPS SUB-FIELD^^.05^5 "^DD",8925.1,8925.113,0,"DT") 2950216 "^DD",8925.1,8925.113,0,"IX","B",8925.113,.01) "^DD",8925.1,8925.113,0,"NM","PROCESSING STEPS") "^DD",8925.1,8925.113,0,"UP") 8925.1 "^DD",8925.1,8925.113,.01,0) PROCESSING STEP^MP8930.8'^USR(8930.8,^0;1^Q "^DD",8925.1,8925.113,.01,1,0) ^.1 "^DD",8925.1,8925.113,.01,1,1,0) 8925.113^B "^DD",8925.1,8925.113,.01,1,1,1) S ^TIU(8925.1,DA(1),13,"B",$E(X,1,30),DA)="" "^DD",8925.1,8925.113,.01,1,1,2) K ^TIU(8925.1,DA(1),13,"B",$E(X,1,30),DA) "^DD",8925.1,8925.113,.01,3) Please indicate a step involved in processing this document. "^DD",8925.1,8925.113,.01,21,0) ^^2^2^2950216^ "^DD",8925.1,8925.113,.01,21,1,0) This is a step or action (e.g., verification) in the processing of a document "^DD",8925.1,8925.113,.01,21,2,0) that moves it from one state (e.g., unverified) to another (e.g., unsigned). "^DD",8925.1,8925.113,.01,"DT") 2950216 "^DD",8925.1,8925.113,.02,0) SEQUENCE^NJ3,0^^0;2^K:+X'=X!(X>999)!(X<0)!(X?.E1"."1N.N) X "^DD",8925.1,8925.113,.02,3) Indicate the order in processing this document where this step should occur. "^DD",8925.1,8925.113,.02,21,0) ^^4^4^2950216^ "^DD",8925.1,8925.113,.02,21,1,0) This is the serial sequence in the processing of the document in which the "^DD",8925.1,8925.113,.02,21,2,0) current step should ordinarily occur. This field is only necessary when the "^DD",8925.1,8925.113,.02,21,3,0) process in question must occur in a particular sequence (e.g., to insure "^DD",8925.1,8925.113,.02,21,4,0) that a document is always released from draft before it is verified). "^DD",8925.1,8925.113,.02,"DT") 2950216 "^DD",8925.1,8925.113,.03,0) REQUIRED?^S^1:REQUIRED;0:OPTIONAL;^0;3^Q "^DD",8925.1,8925.113,.03,3) Indicate whether the step is required or optional "^DD",8925.1,8925.113,.03,21,0) ^^4^4^2950216^ "^DD",8925.1,8925.113,.03,21,1,0) This field specifies whether the step is required or optional for completion "^DD",8925.1,8925.113,.03,21,2,0) of the document (e.g., Dictation and transcription is the typical means by "^DD",8925.1,8925.113,.03,21,3,0) which Discharge Summaries are acquired, but they may be entered directly by "^DD",8925.1,8925.113,.03,21,4,0) the provider, if preferred). "^DD",8925.1,8925.113,.03,"DT") 2950216 "^DD",8925.1,8925.113,.04,0) RESULTING STATUS^P8930.6'^USR(8930.6,^0;4^Q "^DD",8925.1,8925.113,.04,3) Indicate the status resulting from the step being taken. "^DD",8925.1,8925.113,.04,21,0) ^^4^4^2950216^ "^DD",8925.1,8925.113,.04,21,1,0) This is the status of the document following completion of the step in "^DD",8925.1,8925.113,.04,21,2,0) question. For instance, if a discharge summary is to be registered as "^DD",8925.1,8925.113,.04,21,3,0) unsigned following verification, this would be indicated in the RESULTING "^DD",8925.1,8925.113,.04,21,4,0) STATUS field. "^DD",8925.1,8925.113,.04,"DT") 2950216 "^DD",8925.1,8925.113,.05,0) CONDITION TEXT^F^^0;5^K:$L(X)>40!($L(X)<3) X "^DD",8925.1,8925.113,.05,3) Condition under which the step will result in the status as indicated. "^DD",8925.1,8925.113,.05,"DT") 2950216 "^DD",8925.1,8925.114,0) DIALOG SUB-FIELD^^117^12 "^DD",8925.1,8925.114,0,"DT") 2951002 "^DD",8925.1,8925.114,0,"IX","AS",8925.114,.03) "^DD",8925.1,8925.114,0,"IX","B",8925.114,.01) "^DD",8925.1,8925.114,0,"NM","DIALOG") "^DD",8925.1,8925.114,0,"UP") 8925.1 "^DD",8925.1,8925.114,.01,0) PROMPT^MF^^0;1^K:$L(X)>30!($L(X)<2) X "^DD",8925.1,8925.114,.01,1,0) ^.1 "^DD",8925.1,8925.114,.01,1,1,0) 8925.114^B "^DD",8925.1,8925.114,.01,1,1,1) S ^TIU(8925.1,DA(1),"DIALOG","B",$E(X,1,30),DA)="" "^DD",8925.1,8925.114,.01,1,1,2) K ^TIU(8925.1,DA(1),"DIALOG","B",$E(X,1,30),DA) "^DD",8925.1,8925.114,.01,3) Enter the caption with which the user will be prompted. "^DD",8925.1,8925.114,.01,21,0) ^^2^2^2950606^^^ "^DD",8925.1,8925.114,.01,21,1,0) This is the prompt with which the user will be presented during interactive "^DD",8925.1,8925.114,.01,21,2,0) entry of the document. "^DD",8925.1,8925.114,.01,"DT") 2950606 "^DD",8925.1,8925.114,.02,0) ITEM NAME^F^^0;2^K:$L(X)>50!($L(X)<2) X "^DD",8925.1,8925.114,.02,3) Answer must be 2-50 characters in length. "^DD",8925.1,8925.114,.02,21,0) ^^2^2^2950606^^ "^DD",8925.1,8925.114,.02,21,1,0) This is a descriptive name for the datum which will help descibe the prompt "^DD",8925.1,8925.114,.02,21,2,0) for the user. "^DD",8925.1,8925.114,.02,"DT") 2950606 "^DD",8925.1,8925.114,.03,0) SEQUENCE^NJ3,0^^0;3^K:+X'=X!(X>999)!(X<1)!(X?.E1"."1N.N) X "^DD",8925.1,8925.114,.03,1,0) ^.1 "^DD",8925.1,8925.114,.03,1,1,0) 8925.114^AS "^DD",8925.1,8925.114,.03,1,1,1) S ^TIU(8925.1,DA(1),"DIALOG","AS",$E(X,1,30),DA)="" "^DD",8925.1,8925.114,.03,1,1,2) K ^TIU(8925.1,DA(1),"DIALOG","AS",$E(X,1,30),DA) "^DD",8925.1,8925.114,.03,1,1,"%D",0) ^^2^2^2950606^ "^DD",8925.1,8925.114,.03,1,1,"%D",1,0) This REGULAR FileMan Cross-reference on the sequence sub-field of the "^DD",8925.1,8925.114,.03,1,1,"%D",2,0) Dialog Multiple will facilitate appropriate serialization of prompts. "^DD",8925.1,8925.114,.03,1,1,"DT") 2950606 "^DD",8925.1,8925.114,.03,3) Type a Number between 1 and 999, 0 Decimal Digits "^DD",8925.1,8925.114,.03,21,0) ^^2^2^2950606^ "^DD",8925.1,8925.114,.03,21,1,0) This is the sequence of the prompt within the dialog. On the Windows Client "^DD",8925.1,8925.114,.03,21,2,0) this will correspond with the Tab Order Property of the prompt. "^DD",8925.1,8925.114,.03,"DT") 2950606 "^DD",8925.1,8925.114,.04,0) FIELD^FX^^0;4^K:$L(X)>10!($L(X)<1)!(+X<0) X "^DD",8925.1,8925.114,.04,3) Enter the field in the TARGET FILE in which the response is to be stored. "^DD",8925.1,8925.114,.04,4) "^DD",8925.1,8925.114,.04,21,0) ^^2^2^2970116^^ "^DD",8925.1,8925.114,.04,21,1,0) This is the field in the target file in which the user's response will be "^DD",8925.1,8925.114,.04,21,2,0) stored. "^DD",8925.1,8925.114,.04,"DT") 2970116 "^DD",8925.1,8925.114,.05,0) REQUIRED^S^1:YES;0:NO;^0;5^Q "^DD",8925.1,8925.114,.05,3) Indicate whether a response is required. "^DD",8925.1,8925.114,.05,21,0) ^^2^2^2950607^ "^DD",8925.1,8925.114,.05,21,1,0) Please indicate whether a response to this prompt is required, in order to "^DD",8925.1,8925.114,.05,21,2,0) complete the dialog. "^DD",8925.1,8925.114,.05,"DT") 2950607 "^DD",8925.1,8925.114,.06,0) VISIBLE^S^0:NO;1:YES;^0;6^Q "^DD",8925.1,8925.114,.06,3) Indicate wheter the prompt will be visible to the user. "^DD",8925.1,8925.114,.06,21,0) ^^2^2^2950607^ "^DD",8925.1,8925.114,.06,21,1,0) This field specifies whether a given datum will be prompted for, or "^DD",8925.1,8925.114,.06,21,2,0) "stuffed," based on execution of the SET METHOD for a given prompt. "^DD",8925.1,8925.114,.06,"DT") 2950607 "^DD",8925.1,8925.114,1,0) SET METHOD^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.114,1,3) This is Standard MUMPS code. "^DD",8925.1,8925.114,1,9) @ "^DD",8925.1,8925.114,1,21,0) ^^5^5^2950607^^^ "^DD",8925.1,8925.114,1,21,1,0) This is the mumps code for determining the default value of an interactive "^DD",8925.1,8925.114,1,21,2,0) ("visible") prompt, and for setting the value to be non-interactively "^DD",8925.1,8925.114,1,21,3,0) "stuffed" on invokation of an "invisible" prompt. Regardless of the "^DD",8925.1,8925.114,1,21,4,0) syntactic approach (e.g., subroutine or extrinsic function, the return "^DD",8925.1,8925.114,1,21,5,0) value of the method should be placed in the local varible X. "^DD",8925.1,8925.114,1,"DT") 2950607 "^DD",8925.1,8925.114,101,0) WINDOWS CONTROL^S^1:LongList;2:SimpleList;3:Edit;4:Memo;^W;1^Q "^DD",8925.1,8925.114,101,3) Enter the Windows control appropriate for this prompt "^DD",8925.1,8925.114,101,21,0) ^^2^2^2950907^ "^DD",8925.1,8925.114,101,21,1,0) Stores the type of Windows control necessary to get the data for this "^DD",8925.1,8925.114,101,21,2,0) prompt. "^DD",8925.1,8925.114,101,"DT") 2950907 "^DD",8925.1,8925.114,102,0) API NAME^F^^W;2^K:$L(X)>30!($L(X)<3) X "^DD",8925.1,8925.114,102,3) Answer must be 3-30 characters in length. "^DD",8925.1,8925.114,102,21,0) ^^3^3^2950907^ "^DD",8925.1,8925.114,102,21,1,0) This is the API that should be called by the broker when the control is "^DD",8925.1,8925.114,102,21,2,0) used. How the API is used varies with the control. Examples are: "^DD",8925.1,8925.114,102,21,3,0) filling list boxes, getting boilerplate text, etc. "^DD",8925.1,8925.114,102,"DT") 2951002 "^DD",8925.1,8925.114,103,0) API PARAMETER #1^F^^W;3^K:$L(X)>30!($L(X)<1) X "^DD",8925.1,8925.114,103,3) Answer must be 1-30 characters in length. "^DD",8925.1,8925.114,103,21,0) ^^1^1^2950907^ "^DD",8925.1,8925.114,103,21,1,0) A parameter that is used by the API may be stored here. "^DD",8925.1,8925.114,103,"DT") 2950907 "^DD",8925.1,8925.114,113,0) WINDOWS CONDITION^K^^W3;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.114,113,3) This is Standard MUMPS code. "^DD",8925.1,8925.114,113,9) @ "^DD",8925.1,8925.114,113,21,0) ^^3^3^2950907^ "^DD",8925.1,8925.114,113,21,1,0) This is silent code which is executed when building the dialog for "^DD",8925.1,8925.114,113,21,2,0) Windows. It identifies which prompts should be included in the dialog. "^DD",8925.1,8925.114,113,21,3,0) The condition should leave $T failse if the prompt should not be asked. "^DD",8925.1,8925.114,113,"DT") 2950907 "^DD",8925.1,8925.114,117,0) WINDOWS DEFAULT^K^^W7;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.114,117,3) This is Standard MUMPS code. "^DD",8925.1,8925.114,117,9) @ "^DD",8925.1,8925.114,117,21,0) ^^2^2^2950907^ "^DD",8925.1,8925.114,117,21,1,0) This code should silently set the default value of a prompt when it is "^DD",8925.1,8925.114,117,21,2,0) selected. "^DD",8925.1,8925.114,117,"DT") 2950907 "^DD",8925.1,8925.12,0) UPLOAD CAPTIONED ASCII HEADER SUB-FIELD^^1^8 "^DD",8925.1,8925.12,0,"DT") 2951004 "^DD",8925.1,8925.12,0,"IX","B",8925.12,.01) "^DD",8925.1,8925.12,0,"IX","C",8925.12,.02) "^DD",8925.1,8925.12,0,"IX","D",8925.12,.03) "^DD",8925.1,8925.12,0,"IX","E",8925.12,.04) "^DD",8925.1,8925.12,0,"NM","UPLOAD CAPTIONED ASCII HEADER") "^DD",8925.1,8925.12,0,"UP") 8925.1 "^DD",8925.1,8925.12,.01,0) CAPTION^MF^^0;1^K:$L(X)>40!($L(X)<2) X "^DD",8925.1,8925.12,.01,1,0) ^.1 "^DD",8925.1,8925.12,.01,1,1,0) 8925.12^B "^DD",8925.1,8925.12,.01,1,1,1) S ^TIU(8925.1,DA(1),"HEAD","B",$E(X,1,30),DA)="" "^DD",8925.1,8925.12,.01,1,1,2) K ^TIU(8925.1,DA(1),"HEAD","B",$E(X,1,30),DA) "^DD",8925.1,8925.12,.01,3) Answer must be 2-40 characters in length. "^DD",8925.1,8925.12,.01,21,0) ^^7^7^2970108^ "^DD",8925.1,8925.12,.01,21,1,0) NOTE: Users can choose between two possible kinds of Upload Record "^DD",8925.1,8925.12,.01,21,2,0) Headers: Captioned or Delimited. Captioned headers should be used UNLESS "^DD",8925.1,8925.12,.01,21,3,0) the site has a way to generate upload headers automatically. "^DD",8925.1,8925.12,.01,21,4,0) "^DD",8925.1,8925.12,.01,21,5,0) CAPTION is the caption which the transcriber enters into the captioned "^DD",8925.1,8925.12,.01,21,6,0) upload record header immediately preceeding the item data. It serves to "^DD",8925.1,8925.12,.01,21,7,0) distinguish one item of data from the next. Example: PATIENT NAME "^DD",8925.1,8925.12,.01,"DT") 2930218 "^DD",8925.1,8925.12,.02,0) ITEM NAME^F^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<2) X "^DD",8925.1,8925.12,.02,1,0) ^.1 "^DD",8925.1,8925.12,.02,1,1,0) 8925.12^C "^DD",8925.1,8925.12,.02,1,1,1) S ^TIU(8925.1,DA(1),"HEAD","C",$E(X,1,30),DA)="" "^DD",8925.1,8925.12,.02,1,1,2) K ^TIU(8925.1,DA(1),"HEAD","C",$E(X,1,30),DA) "^DD",8925.1,8925.12,.02,1,1,"%D",0) ^^2^2^2930122^ "^DD",8925.1,8925.12,.02,1,1,"%D",1,0) This REGULAR FileMan cross-reference on the ITEM NAME is used in the look-up "^DD",8925.1,8925.12,.02,1,1,"%D",2,0) and filing processes. "^DD",8925.1,8925.12,.02,1,1,"DT") 2930122 "^DD",8925.1,8925.12,.02,3) Enter the name of the header item. "^DD",8925.1,8925.12,.02,21,0) ^^2^2^2970108^ "^DD",8925.1,8925.12,.02,21,1,0) This is the name of the item in the ASCII message header. Item Name is "^DD",8925.1,8925.12,.02,21,2,0) used in help messages for the person dictating a document. "^DD",8925.1,8925.12,.02,"DT") 2930122 "^DD",8925.1,8925.12,.03,0) FIELD NUMBER^F^^0;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>10!($L(X)<1) X "^DD",8925.1,8925.12,.03,1,0) ^.1 "^DD",8925.1,8925.12,.03,1,1,0) 8925.12^D "^DD",8925.1,8925.12,.03,1,1,1) S ^TIU(8925.1,DA(1),"HEAD","D",$E(X,1,30),DA)="" "^DD",8925.1,8925.12,.03,1,1,2) K ^TIU(8925.1,DA(1),"HEAD","D",$E(X,1,30),DA) "^DD",8925.1,8925.12,.03,1,1,"%D",0) ^^2^2^2930122^ "^DD",8925.1,8925.12,.03,1,1,"%D",1,0) This REGULAR FileMan cross-reference is used by the filer router to identify "^DD",8925.1,8925.12,.03,1,1,"%D",2,0) header fields with field numbers in the target file. "^DD",8925.1,8925.12,.03,1,1,"DT") 2930122 "^DD",8925.1,8925.12,.03,3) Enter the FIELD # of the item in the target file. "^DD",8925.1,8925.12,.03,21,0) ^^2^2^2970108^ "^DD",8925.1,8925.12,.03,21,1,0) This is the FIELD # in the target file which corresponds to this header "^DD",8925.1,8925.12,.03,21,2,0) item and where this item of data will be stored. "^DD",8925.1,8925.12,.03,"DT") 2930122 "^DD",8925.1,8925.12,.04,0) LOOKUP LOCAL VARIABLE NAME^F^^0;4^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>8!($L(X)<1)!'(X?1A1.7E) X "^DD",8925.1,8925.12,.04,1,0) ^.1 "^DD",8925.1,8925.12,.04,1,1,0) 8925.12^E "^DD",8925.1,8925.12,.04,1,1,1) S ^TIU(8925.1,DA(1),"HEAD","E",$E(X,1,30),DA)="" "^DD",8925.1,8925.12,.04,1,1,2) K ^TIU(8925.1,DA(1),"HEAD","E",$E(X,1,30),DA) "^DD",8925.1,8925.12,.04,1,1,"%D",0) ^^3^3^2930122^ "^DD",8925.1,8925.12,.04,1,1,"%D",1,0) This REGULAR FileMan cross-reference is used by the router/filer to determine "^DD",8925.1,8925.12,.04,1,1,"%D",2,0) which fields of the header should be set into special variables which may be "^DD",8925.1,8925.12,.04,1,1,"%D",3,0) required by the lookup routine. "^DD",8925.1,8925.12,.04,1,1,"DT") 2930122 "^DD",8925.1,8925.12,.04,3) Enter the required local variable into which this item will be set. "^DD",8925.1,8925.12,.04,21,0) ^^11^11^2970108^ "^DD",8925.1,8925.12,.04,21,1,0) This field specifies the local variable name into which this item of the "^DD",8925.1,8925.12,.04,21,2,0) upload header will be set. The local variable is used by the Look-Up "^DD",8925.1,8925.12,.04,21,3,0) Method. For example, if this item of the header is the patient social "^DD",8925.1,8925.12,.04,21,4,0) security number, the Lookup Local Variable Name might be TIUSSN. The "^DD",8925.1,8925.12,.04,21,5,0) social security number as written by the transcriptionist is first "^DD",8925.1,8925.12,.04,21,6,0) transformed by any existing Transform Code, and then set into this "^DD",8925.1,8925.12,.04,21,7,0) variable (e.g. TIUSSN) for use in Look-Up Method code. "^DD",8925.1,8925.12,.04,21,8,0) "^DD",8925.1,8925.12,.04,21,9,0) Lookup Local Variable Name is necessary only if the information in this "^DD",8925.1,8925.12,.04,21,10,0) piece is required in order to look up the appropriate entry in the target "^DD",8925.1,8925.12,.04,21,11,0) file. "^DD",8925.1,8925.12,.04,"DT") 2930122 "^DD",8925.1,8925.12,.05,0) EXAMPLE ENTRY^F^^0;5^K:$L(X)>80!($L(X)<2) X "^DD",8925.1,8925.12,.05,3) Answer must be 2-80 characters in length. "^DD",8925.1,8925.12,.05,21,0) ^^9^9^2970108^ "^DD",8925.1,8925.12,.05,21,1,0) This field is used to store sample data for this item in the form the "^DD",8925.1,8925.12,.05,21,2,0) transcriptionist is expected to use when transcribing it. For example, if "^DD",8925.1,8925.12,.05,21,3,0) a patient has social security number 555-12-1212, and the transcriptionist "^DD",8925.1,8925.12,.05,21,4,0) is expected to write 555-12-1212, than an Example Entry should have the "^DD",8925.1,8925.12,.05,21,5,0) form 555-12-1212. "^DD",8925.1,8925.12,.05,21,6,0) "^DD",8925.1,8925.12,.05,21,7,0) The Upload needs to know the exact form the transcriptionist is expected "^DD",8925.1,8925.12,.05,21,8,0) to use in case it needs to transform it to make it acceptable to FileMan. "^DD",8925.1,8925.12,.05,21,9,0) In this case, the transcriptionist also needs to know the exact form. "^DD",8925.1,8925.12,.05,"DT") 2930224 "^DD",8925.1,8925.12,.06,0) CLINICIAN MUST DICTATE^S^1:YES;0:NO;^0;6^Q "^DD",8925.1,8925.12,.06,3) Answer yes if this field needs to be dictated by the clinician. "^DD",8925.1,8925.12,.06,21,0) ^^5^5^2970108^ "^DD",8925.1,8925.12,.06,21,1,0) States whether or not this item should be dictated by the Clinician. Will "^DD",8925.1,8925.12,.06,21,2,0) be used by the Clinician Help routine to determine if this field should be "^DD",8925.1,8925.12,.06,21,3,0) shown as data that should be dictated. (Some items can be entered by the "^DD",8925.1,8925.12,.06,21,4,0) transcriber without being dictated, such as the transcriber "^DD",8925.1,8925.12,.06,21,5,0) identification). "^DD",8925.1,8925.12,.06,"DT") 2930423 "^DD",8925.1,8925.12,.07,0) REQUIRED FIELD?^S^1:YES;0:NO;^0;7^Q "^DD",8925.1,8925.12,.07,3) Please indicate whether field is required by application. "^DD",8925.1,8925.12,.07,21,0) ^^5^5^2970108^ "^DD",8925.1,8925.12,.07,21,1,0) This field is used to determine whether a given header item is required "^DD",8925.1,8925.12,.07,21,2,0) by the application (e.g., Author and Attending Physician may be required "^DD",8925.1,8925.12,.07,21,3,0) for the ongoing processing of a Discharge Summary). Records lacking "^DD",8925.1,8925.12,.07,21,4,0) required fields WILL be entered into the target file, if possible, but "^DD",8925.1,8925.12,.07,21,5,0) will generate Missing Field Error Alerts. "^DD",8925.1,8925.12,.07,"DT") 2951004 "^DD",8925.1,8925.12,1,0) TRANSFORM CODE^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",8925.1,8925.12,1,3) This is Standard MUMPS code. "^DD",8925.1,8925.12,1,9) @ "^DD",8925.1,8925.12,1,21,0) ^^11^11^2970108^ "^DD",8925.1,8925.12,1,21,1,0) This standard MUMPS code transforms the transcribed value of the header "^DD",8925.1,8925.12,1,21,2,0) item into a format acceptable to FileMan (e.g., patient social security "^DD",8925.1,8925.12,1,21,3,0) number 555-12-1212 must be transformed to 555121212 or to whatever "^DD",8925.1,8925.12,1,21,4,0) (external) format FileMan accepts when a user edits the social security "^DD",8925.1,8925.12,1,21,5,0) number field in the target file). "^DD",8925.1,8925.12,1,21,6,0) "^DD",8925.1,8925.12,1,21,7,0) Field values are transformed before being set into Special Lookup "^DD",8925.1,8925.12,1,21,8,0) Variables and before being set into target file fields. "^DD",8925.1,8925.12,1,21,9,0) "^DD",8925.1,8925.12,1,21,10,0) Field is necessary only if transcribed item is not in the format Fileman "^DD",8925.1,8925.12,1,21,11,0) accepts for the target file. "^DD",8925.1,8925.12,1,"DT") 2930219 "^DD",8925.1,8925.13,0) BOILERPLATE TEXT SUB-FIELD^^.01^1 "^DD",8925.1,8925.13,0,"NM","BOILERPLATE TEXT") "^DD",8925.1,8925.13,0,"UP") 8925.1 "^DD",8925.1,8925.13,.01,0) BOILERPLATE TEXT^WL^^0;1^Q "^DD",8925.1,8925.13,.01,3) Enter default Report Format "^DD",8925.1,8925.13,.01,21,0) ^^51^51^2970506^ "^DD",8925.1,8925.13,.01,21,1,0) Applies to Titles and Components. "^DD",8925.1,8925.13,.01,21,2,0) "^DD",8925.1,8925.13,.01,21,3,0) Site can preload the text field of a document with default text/default "^DD",8925.1,8925.13,.01,21,4,0) format/overprint data which is presented to the user when entering the "^DD",8925.1,8925.13,.01,21,5,0) document. User can then edit and/or add to the boilerplate text. "^DD",8925.1,8925.13,.01,21,6,0) "^DD",8925.1,8925.13,.01,21,7,0) If document is formatted into columns, users entering documents should use "^DD",8925.1,8925.13,.01,21,8,0) replace mode rather than insert mode (or Find/RePlace Text) to preserve "^DD",8925.1,8925.13,.01,21,9,0) the columns. "^DD",8925.1,8925.13,.01,21,10,0) "^DD",8925.1,8925.13,.01,21,11,0) Boilerplate Text may be used as an alternative to components to split a "^DD",8925.1,8925.13,.01,21,12,0) document up into sections, but such sections are stored together and "^DD",8925.1,8925.13,.01,21,13,0) cannot be separately accessed the way components can. See Type Component, "^DD",8925.1,8925.13,.01,21,14,0) under Basic field Type. "^DD",8925.1,8925.13,.01,21,15,0) "^DD",8925.1,8925.13,.01,21,16,0) Titles/Components must be inactive in order to edit boilerplate text. "^DD",8925.1,8925.13,.01,21,17,0) "^DD",8925.1,8925.13,.01,21,18,0) Boilerplate Text is the place to embed objects which go fetch data. For "^DD",8925.1,8925.13,.01,21,19,0) example, suppose a Title has boilerplate text: "^DD",8925.1,8925.13,.01,21,20,0) "^DD",8925.1,8925.13,.01,21,21,0) Patient is a healthy |PATIENT AGE| year old male... "^DD",8925.1,8925.13,.01,21,22,0) "^DD",8925.1,8925.13,.01,21,23,0) Then a user who enters such a note for a patient known by the system to be "^DD",8925.1,8925.13,.01,21,24,0) 56 years old would be presented with the text: "^DD",8925.1,8925.13,.01,21,25,0) "^DD",8925.1,8925.13,.01,21,26,0) Patient is a healthy 56 year old male... "^DD",8925.1,8925.13,.01,21,27,0) "^DD",8925.1,8925.13,.01,21,28,0) The user can then add to the text and/or edit the text, including the age "^DD",8925.1,8925.13,.01,21,29,0) (56) of the patient. From this point on, the patient age (56) is regular "^DD",8925.1,8925.13,.01,21,30,0) text and is not updated in this note. "^DD",8925.1,8925.13,.01,21,31,0) "^DD",8925.1,8925.13,.01,21,32,0) If a user enters a document when an embedded object is Inactive, the "^DD",8925.1,8925.13,.01,21,33,0) object does not function; the user sees the object name and an error "^DD",8925.1,8925.13,.01,21,34,0) message. Similarly, if an object has been misspelled in the boilerplate "^DD",8925.1,8925.13,.01,21,35,0) text, or deleted from the file, or if the object name in the boilerplate "^DD",8925.1,8925.13,.01,21,36,0) text is not unique among objects, the object does not function. "^DD",8925.1,8925.13,.01,21,37,0) "^DD",8925.1,8925.13,.01,21,38,0) When embedding objects in boilerplate text, users should make sure the "^DD",8925.1,8925.13,.01,21,39,0) entire object name is on one line rather than split between two lines. "^DD",8925.1,8925.13,.01,21,40,0) Split names generate "NOT found" error messages. Users must also allow "^DD",8925.1,8925.13,.01,21,41,0) enough white space in the boilerplate text for whatever data the object "^DD",8925.1,8925.13,.01,21,42,0) imports. Users can check boilerplate text using action TRY. "^DD",8925.1,8925.13,.01,21,43,0) "^DD",8925.1,8925.13,.01,21,44,0) Any user who can edit boilerplate text can embed any object in it. "^DD",8925.1,8925.13,.01,21,45,0) However, except for object owners who are testing an object, USERS SHOULD "^DD",8925.1,8925.13,.01,21,46,0) EMBED ONLY ACTIVE OBJECTS in boilerplate text. An object can be embedded "^DD",8925.1,8925.13,.01,21,47,0) in as many different Document Definitions as desired. "^DD",8925.1,8925.13,.01,21,48,0) "^DD",8925.1,8925.13,.01,21,49,0) A document with multiple components can have boilerplate text in the entry "^DD",8925.1,8925.13,.01,21,50,0) itself and/or in any component. Boilerplate text in the entry itself "^DD",8925.1,8925.13,.01,21,51,0) appears first. "^DD",8925.1,8925.13,.01,"DT") 2930305 "^DD",8925.1,8925.14,0) ITEM SUB-FIELD^^4^4 "^DD",8925.1,8925.14,0,"DT") 2970212 "^DD",8925.1,8925.14,0,"IX","AC",8925.14,3) "^DD",8925.1,8925.14,0,"IX","B",8925.14,.01) "^DD",8925.1,8925.14,0,"IX","C",8925.14,4) "^DD",8925.1,8925.14,0,"NM","ITEM") "^DD",8925.1,8925.14,0,"UP") 8925.1 "^DD",8925.1,8925.14,.01,0) ITEM^M*P8925.1'X^TIU(8925.1,^0;1^S DIC("S")="I $G(TIUFPRIV) X:$D(TIUFISCR) ""I Y=TIUFISCR""" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",8925.1,8925.14,.01,1,0) ^.1 "^DD",8925.1,8925.14,.01,1,1,0) 8925.14^B "^DD",8925.1,8925.14,.01,1,1,1) S ^TIU(8925.1,DA(1),10,"B",$E(X,1,30),DA)="" "^DD",8925.1,8925.14,.01,1,1,2) K ^TIU(8925.1,DA(1),10,"B",$E(X,1,30),DA) "^DD",8925.1,8925.14,.01,1,2,0) 8925.1^AD "^DD",8925.1,8925.14,.01,1,2,1) S ^TIU(8925.1,"AD",$E(X,1,30),DA(1),DA)="" "^DD",8925.1,8925.14,.01,1,2,2) K ^TIU(8925.1,"AD",$E(X,1,30),DA(1),DA) "^DD",8925.1,8925.14,.01,1,2,"%D",0) ^^2^2^2940719^ "^DD",8925.1,8925.14,.01,1,2,"%D",1,0) This cross-reference facilitates traversal from child to parent, up the "^DD",8925.1,8925.14,.01,1,2,"%D",2,0) class hierarchy. "^DD",8925.1,8925.14,.01,1,2,"DT") 2940719 "^DD",8925.1,8925.14,.01,1,3,0) 8925.1^AMM^MUMPS "^DD",8925.1,8925.14,.01,1,3,1) D REDOX^TIUDD "^DD",8925.1,8925.14,.01,1,3,2) D REDOX^TIUDD "^DD",8925.1,8925.14,.01,1,3,"%D",0) ^^2^2^2940720^^ "^DD",8925.1,8925.14,.01,1,3,"%D",1,0) This MUMPS-type cross-reference will update the timestamp on the parent "^DD",8925.1,8925.14,.01,1,3,"%D",2,0) document when the ITEM, MNEMONIC, or SEQUENCE changes. "^DD",8925.1,8925.14,.01,1,3,"DT") 2940720 "^DD",8925.1,8925.14,.01,1,4,0) 8925.1^ACL1001^MUMPS "^DD",8925.1,8925.14,.01,1,4,1) D SACL^TIUDD1(X,10.01) "^DD",8925.1,8925.14,.01,1,4,2) D KACL^TIUDD1(X,10.01) "^DD",8925.1,8925.14,.01,1,4,"%D",0) ^^2^2^2971016^ "^DD",8925.1,8925.14,.01,1,4,"%D",1,0) This MUMPS-type cross-reference by class and name will help to identify "^DD",8925.1,8925.14,.01,1,4,"%D",2,0) the titles within a given class. "^DD",8925.1,8925.14,.01,1,4,"DT") 2971016 "^DD",8925.1,8925.14,.01,3) ITEM must be a new or pre-existing Document Definition with appropriate Type which you own, which is not already an Item elsewhere. "^DD",8925.1,8925.14,.01,4) D NAME^TIUFXHLX "^DD",8925.1,8925.14,.01,12) See Technical Description. "^DD",8925.1,8925.14,.01,12.1) S DIC("S")="I $G(TIUFPRIV) X:$D(TIUFISCR) ""I Y=TIUFISCR""" "^DD",8925.1,8925.14,.01,21,0) ^^6^6^2970304^^^^ "^DD",8925.1,8925.14,.01,21,1,0) Items are themselves Document Definitions. The Type of the parent entry "^DD",8925.1,8925.14,.01,21,2,0) determines what Types of items it has. A parent entry of type Class has "^DD",8925.1,8925.14,.01,21,3,0) items of type Class or Document Class. A Document Class entry has items "^DD",8925.1,8925.14,.01,21,4,0) of type Title. If a Title entry has more than a single section, it has "^DD",8925.1,8925.14,.01,21,5,0) items of type Component. Components may also be multi-section with items "^DD",8925.1,8925.14,.01,21,6,0) of type Component. Objects do not have items. "^DD",8925.1,8925.14,.01,23,0) ^^8^8^2970304^^^^ "^DD",8925.1,8925.14,.01,23,1,0) The Item subfield of Item Field 10 in File 8925.1 is screened when using "^DD",8925.1,8925.14,.01,23,2,0) the TIUF Document Definition Utility to add items (i.e. when variable "^DD",8925.1,8925.14,.01,23,3,0) TIUFISCR is defined. "^DD",8925.1,8925.14,.01,23,4,0) "^DD",8925.1,8925.14,.01,23,5,0) This screen is needed in ADDTEN^TIUFLF4, which noninteractively adds an "^DD",8925.1,8925.14,.01,23,6,0) item to the Item multiple. The screen limits the lookup to the 8925.1 IFN "^DD",8925.1,8925.14,.01,23,7,0) of the item being added to the Item multiple. Without the screen, the "^DD",8925.1,8925.14,.01,23,8,0) lookup fails when there are multiple 8925.1 entries of the same name. "^DD",8925.1,8925.14,.01,"DEL",.01,0) I 1 "^DD",8925.1,8925.14,.01,"DT") 2971016 "^DD",8925.1,8925.14,2,0) MNEMONIC^F^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>4!($L(X)<1) X "^DD",8925.1,8925.14,2,1,0) ^.1 "^DD",8925.1,8925.14,2,1,1,0) 8925.1^AMM2^MUMPS "^DD",8925.1,8925.14,2,1,1,1) D REDOX^TIUDD "^DD",8925.1,8925.14,2,1,1,2) D REDOX^TIUDD "^DD",8925.1,8925.14,2,1,1,"%D",0) ^^2^2^2961210^^^^ "^DD",8925.1,8925.14,2,1,1,"%D",1,0) This MUMPS-type cross-reference will update the TIMESTAMP on the parent "^DD",8925.1,8925.14,2,1,1,"%D",2,0) document when either the ITEM, MNEMONIC, or SEQUENCE changes. "^DD",8925.1,8925.14,2,1,1,"DT") 2940720 "^DD",8925.1,8925.14,2,3) Mnemonic is a handle by which to select Classes/Document Classes from a menu. Enter the Sequence number, or 1-4 letters, or nothing if you don't want mnemonics. "^DD",8925.1,8925.14,2,21,0) ^^3^3^2970127^ "^DD",8925.1,8925.14,2,21,1,0) Item Mnemonic is a handle by which to select Classes/Document Classes from "^DD",8925.1,8925.14,2,21,2,0) a menu. 1-4 characters long. Mnemonic is usually numeric with the same "^DD",8925.1,8925.14,2,21,3,0) value as the Sequence. Alpha mnemonics are permitted if preferred. "^DD",8925.1,8925.14,2,"DT") 2940720 "^DD",8925.1,8925.14,3,0) SEQUENCE^NJ6,2^^0;3^K:+X'=X!(X>999)!(X<.01)!(X?.E1"."3N.N) X "^DD",8925.1,8925.14,3,1,0) ^.1 "^DD",8925.1,8925.14,3,1,1,0) 8925.1^AMM3^MUMPS "^DD",8925.1,8925.14,3,1,1,1) D REDOX^TIUDD "^DD",8925.1,8925.14,3,1,1,2) D REDOX^TIUDD "^DD",8925.1,8925.14,3,1,1,"%D",0) ^^2^2^2940720^^ "^DD",8925.1,8925.14,3,1,1,"%D",1,0) This MUMPS-type cross-reference will update the TIMESTAMP of the parent "^DD",8925.1,8925.14,3,1,1,"%D",2,0) document when the ITEM, MNEMONIC, or SEQUENCE change. "^DD",8925.1,8925.14,3,1,1,"DT") 2940720 "^DD",8925.1,8925.14,3,1,2,0) 8925.14^AC "^DD",8925.1,8925.14,3,1,2,1) S ^TIU(8925.1,DA(1),10,"AC",$E(X,1,30),DA)="" "^DD",8925.1,8925.14,3,1,2,2) K ^TIU(8925.1,DA(1),10,"AC",$E(X,1,30),DA) "^DD",8925.1,8925.14,3,1,2,3) Please don't delete! "^DD",8925.1,8925.14,3,1,2,"%D",0) ^^2^2^2950412^^^ "^DD",8925.1,8925.14,3,1,2,"%D",1,0) This REGULAR Fileman cross reference is used to list items by sequence "^DD",8925.1,8925.14,3,1,2,"%D",2,0) number. "^DD",8925.1,8925.14,3,1,2,"DT") 2950410 "^DD",8925.1,8925.14,3,3) Item Sequence determines display order under the parent. For alphabetic order, do not enter sequences. Sequence is between .01 and 999, 2 Decimal Digits. "^DD",8925.1,8925.14,3,21,0) ^^3^3^2970102^^^ "^DD",8925.1,8925.14,3,21,1,0) Item Sequence, if entered, determines item's order under its parent. If "^DD",8925.1,8925.14,3,21,2,0) items have no sequence, item order is alphabetic by item Menu Text. "^DD",8925.1,8925.14,3,21,3,0) Sequence must be between .01 and 999. "^DD",8925.1,8925.14,3,"DT") 2961021 "^DD",8925.1,8925.14,4,0) MENU TEXT^RFX^^0;4^K:X[""""!($A(X)=45)!($A(X)=32) X I $D(X) K:$L(X)>20!($L(X)<1) X I $D(X) K:$$UPPER^TIULS($E(X,1,3))="ALL" X "^DD",8925.1,8925.14,4,1,0) ^.1 "^DD",8925.1,8925.14,4,1,1,0) 8925.1^AMM4^MUMPS "^DD",8925.1,8925.14,4,1,1,1) D REDOX^TIUDD "^DD",8925.1,8925.14,4,1,1,2) D REDOX^TIUDD "^DD",8925.1,8925.14,4,1,1,"%D",0) ^^2^2^2940720^ "^DD",8925.1,8925.14,4,1,1,"%D",1,0) This MUMPS-type cross-reference updates the TIMESTAMP on the parent "^DD",8925.1,8925.14,4,1,1,"%D",2,0) document when the DISPLAY NAME changes. "^DD",8925.1,8925.14,4,1,1,"DT") 2940720 "^DD",8925.1,8925.14,4,1,2,0) 8925.14^C^MUMPS "^DD",8925.1,8925.14,4,1,2,1) S ^TIU(8925.1,DA(1),10,"C",$E(X,1,30),DA)="" "^DD",8925.1,8925.14,4,1,2,2) K ^TIU(8925.1,DA(1),10,"C",$E(X,1,30),DA) "^DD",8925.1,8925.14,4,1,2,"%D",0) ^^3^3^2961210^^ "^DD",8925.1,8925.14,4,1,2,"%D",1,0) This M cross reference could have been regular. It is used to display "^DD",8925.1,8925.14,4,1,2,"%D",2,0) items with no sequence in alpha order by Menu Text. "^DD",8925.1,8925.14,4,1,2,"DT") 2961210 "^DD",8925.1,8925.14,4,3) This is the short name of the entry, used in 3 column menus. 1 to 20 characters. Must not begin with 'All', or with a space. "^DD",8925.1,8925.14,4,4) "^DD",8925.1,8925.14,4,21,0) ^^20^20^2990114^^ "^DD",8925.1,8925.14,4,21,1,0) Item Menu Text is the short name users will see for Classes and Document "^DD",8925.1,8925.14,4,21,2,0) Classes when selecting them from 3-COLUMN MENUS. Document Definitions are "^DD",8925.1,8925.14,4,21,3,0) selected from 3-column menus when viewing documents across many patients "^DD",8925.1,8925.14,4,21,4,0) and when viewing many kinds of documents at the same time (e.g. Progress "^DD",8925.1,8925.14,4,21,5,0) Notes and Discharge Summaries). "^DD",8925.1,8925.14,4,21,6,0) "^DD",8925.1,8925.14,4,21,7,0) To edit the Menu Text of a Document Definition, you must be viewing the "^DD",8925.1,8925.14,4,21,8,0) Document Definition as an ITEM of its PARENT. Select 'Detailed Display' "^DD",8925.1,8925.14,4,21,9,0) for the PARENT and then 'Items'. "^DD",8925.1,8925.14,4,21,10,0) "^DD",8925.1,8925.14,4,21,11,0) Menu Text has 1 - 20 characters. Menu Text must not begin with a space or "^DD",8925.1,8925.14,4,21,12,0) with 'All'. The Document Definition Utility TIUF automatically sets the "^DD",8925.1,8925.14,4,21,13,0) Item Menu Text to the first 20 characters of the Item's Name when an entry "^DD",8925.1,8925.14,4,21,14,0) is first added as an item. (If an entry's Name begins with 'All' its Menu "^DD",8925.1,8925.14,4,21,15,0) Text is given 'AlX' as its first 3 characters.) The utility does NOT "^DD",8925.1,8925.14,4,21,16,0) update Menu Text if the entry Name is later changed, since this would "^DD",8925.1,8925.14,4,21,17,0) overwrite what a site may have carefully set up. Menu Text is required. "^DD",8925.1,8925.14,4,21,18,0) "^DD",8925.1,8925.14,4,21,19,0) Menu Text can affect item order under a parent since order is alphabetic "^DD",8925.1,8925.14,4,21,20,0) by menu text if items do not have sequence numbers. "^DD",8925.1,8925.14,4,23,0) ^^10^10^2990114^^^^ "^DD",8925.1,8925.14,4,23,1,0) Menu Text cannot begin with 'All' because XQOR, the Unwinder Utility, "^DD",8925.1,8925.14,4,23,2,0) misinterprets it. The result (for titles) is that when a user selects a "^DD",8925.1,8925.14,4,23,3,0) Document Class of titles to view from a three column menu, and one of the "^DD",8925.1,8925.14,4,23,4,0) titles has menu text starting with 'All,' then no documents are found for "^DD",8925.1,8925.14,4,23,5,0) titles AFTER the title starting with 'All', even though such documents may "^DD",8925.1,8925.14,4,23,6,0) exist. Similar problems occur with types other than titles. "^DD",8925.1,8925.14,4,23,7,0) "^DD",8925.1,8925.14,4,23,8,0) Menu Text cannot begin with a space because such Menu Text cannot be used "^DD",8925.1,8925.14,4,23,9,0) to select the entry from a menu: if the space is left off, it is "^DD",8925.1,8925.14,4,23,10,0) questioned, and if the space is left in, it is still questioned. "^DD",8925.1,8925.14,4,"DT") 2990121 "^DD",22706.1,22706.1,0) FIELD^^2^3 "^DD",22706.1,22706.1,0,"DT") 3051125 "^DD",22706.1,22706.1,0,"IX","B",22706.1,.01) "^DD",22706.1,22706.1,0,"NM","TMG FDA APPLICATION") "^DD",22706.1,22706.1,.01,0) LISTING^RP22706.5'^TMG(22706.5,^0;1^Q "^DD",22706.1,22706.1,.01,1,0) ^.1 "^DD",22706.1,22706.1,.01,1,1,0) 22706.1^B "^DD",22706.1,22706.1,.01,1,1,1) S ^TMG(22706.1,"B",$E(X,1,30),DA)="" "^DD",22706.1,22706.1,.01,1,1,2) K ^TMG(22706.1,"B",$E(X,1,30),DA) "^DD",22706.1,22706.1,.01,3) NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION "^DD",22706.1,22706.1,.01,21,0) ^^1^1^3051125^^ "^DD",22706.1,22706.1,.01,21,1,0) Linking field to LISTINGS. "^DD",22706.1,22706.1,.01,"DT") 3051125 "^DD",22706.1,22706.1,1,0) APPLICATION^F^^0;2^K:$L(X)>8!($L(X)<1) X "^DD",22706.1,22706.1,1,3) Answer must be 1-8 characters in length "^DD",22706.1,22706.1,1,21,0) ^^1^1^3051125^^ "^DD",22706.1,22706.1,1,21,1,0) Number of New Drug Application if applicable. "^DD",22706.1,22706.1,1,"DT") 3051125 "^DD",22706.1,22706.1,2,0) PRODUCT NUMBER^NJ3,0^^0;3^K:+X'=X!(X>999)!(X<1)!(X?.E1"."1.N) X "^DD",22706.1,22706.1,2,3) Type a number between 1 and 999, 0 Decimal Digits "^DD",22706.1,22706.1,2,21,0) ^^1^1^3051125^^ "^DD",22706.1,22706.1,2,21,1,0) Number used to identify the products of a New Drug Application. "^DD",22706.1,22706.1,2,"DT") 3051125 "^DD",22706.2,22706.2,0) FIELD^^3^4 "^DD",22706.2,22706.2,0,"DT") 3060427 "^DD",22706.2,22706.2,0,"IX","B",22706.2,.01) "^DD",22706.2,22706.2,0,"IX","C",22706.2,2) "^DD",22706.2,22706.2,0,"NM","TMG FDA DOSAGE FORM") "^DD",22706.2,22706.2,.01,0) LISTING^RP22706.5'^TMG(22706.5,^0;1^Q "^DD",22706.2,22706.2,.01,1,0) ^.1 "^DD",22706.2,22706.2,.01,1,1,0) 22706.2^B "^DD",22706.2,22706.2,.01,1,1,1) S ^TMG(22706.2,"B",$E(X,1,30),DA)="" "^DD",22706.2,22706.2,.01,1,1,2) K ^TMG(22706.2,"B",$E(X,1,30),DA) "^DD",22706.2,22706.2,.01,1,1,"DT") 3060430 "^DD",22706.2,22706.2,.01,3) NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION "^DD",22706.2,22706.2,.01,21,0) ^^1^1^3051125^^ "^DD",22706.2,22706.2,.01,21,1,0) Linking field to LISTINGS. "^DD",22706.2,22706.2,.01,"DT") 3060430 "^DD",22706.2,22706.2,1,0) DOSE FORM^F^^0;2^K:$L(X)>32!($L(X)<1) X "^DD",22706.2,22706.2,1,3) Answer must be 1-32 characters in length "^DD",22706.2,22706.2,1,"DT") 3051125 "^DD",22706.2,22706.2,2,0) DOSAGE NAME^F^^1;1^K:$L(X)>239!($L(X)<1) X "^DD",22706.2,22706.2,2,1,0) ^.1 "^DD",22706.2,22706.2,2,1,1,0) 22706.2^C "^DD",22706.2,22706.2,2,1,1,1) S ^TMG(22706.2,"C",$E(X,1,30),DA)="" "^DD",22706.2,22706.2,2,1,1,2) K ^TMG(22706.2,"C",$E(X,1,30),DA) "^DD",22706.2,22706.2,2,1,1,"DT") 3060427 "^DD",22706.2,22706.2,2,3) Answer must be 1-239 characters in length "^DD",22706.2,22706.2,2,"DT") 3060427 "^DD",22706.2,22706.2,3,0) VA DOSAGE FORM^P50.606'^PS(50.606,^1;2^Q "^DD",22706.2,22706.2,3,"DT") 3060427 "^DD",22706.3,22706.3,0) FIELD^^10^11 "^DD",22706.3,22706.3,0,"DT") 3051125 "^DD",22706.3,22706.3,0,"IX","B",22706.3,.01) "^DD",22706.3,22706.3,0,"IX","C",22706.3,1) "^DD",22706.3,22706.3,0,"NM","TMG FDA FIRMS") "^DD",22706.3,22706.3,0,"PT",22706.5,6) "^DD",22706.3,22706.3,.01,0) NAME^RF^^0;1^K:$L(X)>65!($L(X)<1) X "^DD",22706.3,22706.3,.01,1,0) ^.1 "^DD",22706.3,22706.3,.01,1,1,0) 22706.3^B "^DD",22706.3,22706.3,.01,1,1,1) S ^TMG(22706.3,"B",$E(X,1,30),DA)="" "^DD",22706.3,22706.3,.01,1,1,2) K ^TMG(22706.3,"B",$E(X,1,30),DA) "^DD",22706.3,22706.3,.01,3) Answer must be 1-65 characters in length "^DD",22706.3,22706.3,.01,"DT") 3051125 "^DD",22706.3,22706.3,1,0) LABEL CODE^RNJ6,0^^0;2^K:+X'=X!(X>999999)!(X<0)!(X?.E1"."1.N) X "^DD",22706.3,22706.3,1,1,0) ^.1 "^DD",22706.3,22706.3,1,1,1,0) 22706.3^C "^DD",22706.3,22706.3,1,1,1,1) S ^TMG(22706.3,"C",$E(X,1,30),DA)="" "^DD",22706.3,22706.3,1,1,1,2) K ^TMG(22706.3,"C",$E(X,1,30),DA) "^DD",22706.3,22706.3,1,1,1,"%D",0) ^^2^2^3070116^^ "^DD",22706.3,22706.3,1,1,1,"%D",1,0) This is an index of the records based on label code. "^DD",22706.3,22706.3,1,1,1,"%D",2,0) This is the primary key used by the FDA to index firms "^DD",22706.3,22706.3,1,1,1,"DT") 3070116 "^DD",22706.3,22706.3,1,3) Type a number between 0 and 999999, 0 Decimal Digits "^DD",22706.3,22706.3,1,"DT") 3070116 "^DD",22706.3,22706.3,2,0) ADDRESS HEADER^F^^0;3^K:$L(X)>45!($L(X)<1) X "^DD",22706.3,22706.3,2,3) Answer must be 1-45 characters in length "^DD",22706.3,22706.3,2,"DT") 3051125 "^DD",22706.3,22706.3,3,0) STREET^F^^0;4^K:$L(X)>45!($L(X)<1) X "^DD",22706.3,22706.3,3,3) Answer must be 1-45 characters in length "^DD",22706.3,22706.3,3,"DT") 3051125 "^DD",22706.3,22706.3,4,0) PO BOX^F^^0;5^K:$L(X)>8!($L(X)<1) X "^DD",22706.3,22706.3,4,3) Answer must be 1-8 characters in length "^DD",22706.3,22706.3,4,"DT") 3051125 "^DD",22706.3,22706.3,5,0) FOREIGN ADDRESS^F^^0;6^K:$L(X)>40!($L(X)<1) X "^DD",22706.3,22706.3,5,3) Answer must be 1-40 characters in length "^DD",22706.3,22706.3,5,"DT") 3051125 "^DD",22706.3,22706.3,6,0) CITY^F^^0;7^K:$L(X)>30!($L(X)<1) X "^DD",22706.3,22706.3,6,3) Answer must be 1-30 characters in length "^DD",22706.3,22706.3,6,"DT") 3051125 "^DD",22706.3,22706.3,7,0) STATE^F^^0;8^K:$L(X)>2!($L(X)<1) X "^DD",22706.3,22706.3,7,3) Answer must be 1-2 characters in length "^DD",22706.3,22706.3,7,"DT") 3051125 "^DD",22706.3,22706.3,8,0) ZIP^F^^1;1^K:$L(X)>9!($L(X)<1) X "^DD",22706.3,22706.3,8,3) Answer must be 1-9 characters in length "^DD",22706.3,22706.3,8,"DT") 3051125 "^DD",22706.3,22706.3,9,0) PROVINCE^F^^1;2^K:$L(X)>30!($L(X)<1) X "^DD",22706.3,22706.3,9,3) Answer must be 1-30 characters in length "^DD",22706.3,22706.3,9,"DT") 3051125 "^DD",22706.3,22706.3,10,0) COUNTRY^F^^1;3^K:$L(X)>40!($L(X)<1) X "^DD",22706.3,22706.3,10,3) Answer must be 1-40 characters in length "^DD",22706.3,22706.3,10,"DT") 3051125 "^DD",22706.4,22706.4,0) FIELD^^3^4 "^DD",22706.4,22706.4,0,"DDA") N "^DD",22706.4,22706.4,0,"DT") 3051125 "^DD",22706.4,22706.4,0,"IX","B",22706.4,.01) "^DD",22706.4,22706.4,0,"IX","ING",22706.4,3) "^DD",22706.4,22706.4,0,"NM","TMG FDA FORMULATION") "^DD",22706.4,22706.4,.01,0) LISTING^RP22706.5'^TMG(22706.5,^0;1^Q "^DD",22706.4,22706.4,.01,1,0) ^.1 "^DD",22706.4,22706.4,.01,1,1,0) 22706.4^B "^DD",22706.4,22706.4,.01,1,1,1) S ^TMG(22706.4,"B",$E(X,1,30),DA)="" "^DD",22706.4,22706.4,.01,1,1,2) K ^TMG(22706.4,"B",$E(X,1,30),DA) "^DD",22706.4,22706.4,.01,3) Answer must be 1-30 characters in length "^DD",22706.4,22706.4,.01,21,0) ^^1^1^3051125^^ "^DD",22706.4,22706.4,.01,21,1,0) Linking field to LISTINGS. "^DD",22706.4,22706.4,.01,"DT") 3051125 "^DD",22706.4,22706.4,1,0) STRENGTH^F^^0;2^K:$L(X)>10!($L(X)<1) X "^DD",22706.4,22706.4,1,3) Answer must be 1-10 characters in length "^DD",22706.4,22706.4,1,21,0) ^^1^1^3051125^^ "^DD",22706.4,22706.4,1,21,1,0) This is the potency of the active ingredient. "^DD",22706.4,22706.4,1,"DT") 3051125 "^DD",22706.4,22706.4,2,0) UNIT^F^^0;3^K:$L(X)>8!($L(X)<1) X "^DD",22706.4,22706.4,2,3) Answer must be 1-8 characters in length "^DD",22706.4,22706.4,2,21,0) ^^1^1^3051125^^ "^DD",22706.4,22706.4,2,21,1,0) Unit of measure corresponding to strength. "^DD",22706.4,22706.4,2,"DT") 3051125 "^DD",22706.4,22706.4,3,0) INGREDIENT NAME^F^^0;4^K:$L(X)>100!($L(X)<1) X "^DD",22706.4,22706.4,3,1,0) ^.1 "^DD",22706.4,22706.4,3,1,1,0) 22706.4^ING "^DD",22706.4,22706.4,3,1,1,1) S ^TMG(22706.4,"ING",$E(X,1,64),DA)="" "^DD",22706.4,22706.4,3,1,1,2) K ^TMG(22706.4,"ING",$E(X,1,64),DA) "^DD",22706.4,22706.4,3,1,1,"%D",0) ^^1^1^3071024^^ "^DD",22706.4,22706.4,3,1,1,"%D",1,0) This is a cross reference on the text name of the ingredient used. "^DD",22706.4,22706.4,3,1,1,"DT") 3071024 "^DD",22706.4,22706.4,3,3) Answer must be 1-100 characters in length "^DD",22706.4,22706.4,3,21,0) ^^1^1^3051125^^ "^DD",22706.4,22706.4,3,21,1,0) Truncated preferred term for the active ingredient. "^DD",22706.4,22706.4,3,"DT") 3071024 "^DD",22706.5,22706.5,0) FIELD^^8^9 "^DD",22706.5,22706.5,0,"DT") 3070119 "^DD",22706.5,22706.5,0,"IX","B",22706.5,.01) "^DD",22706.5,22706.5,0,"IX","C",22706.5,8) "^DD",22706.5,22706.5,0,"NM","TMG FDA LISTING") "^DD",22706.5,22706.5,0,"PT",22706.1,.01) "^DD",22706.5,22706.5,0,"PT",22706.2,.01) "^DD",22706.5,22706.5,0,"PT",22706.4,.01) "^DD",22706.5,22706.5,0,"PT",22706.6,.01) "^DD",22706.5,22706.5,0,"PT",22706.7,.01) "^DD",22706.5,22706.5,0,"PT",22706.9,.01) "^DD",22706.5,22706.5,.01,0) LISTING NUMBER^RNJ7,0^^0;1^K:+X'=X!(X>9999999)!(X<1)!(X?.E1"."1.N) X "^DD",22706.5,22706.5,.01,1,0) ^.1 "^DD",22706.5,22706.5,.01,1,1,0) 22706.5^B "^DD",22706.5,22706.5,.01,1,1,1) S ^TMG(22706.5,"B",$E(X,1,30),DA)="" "^DD",22706.5,22706.5,.01,1,1,2) K ^TMG(22706.5,"B",$E(X,1,30),DA) "^DD",22706.5,22706.5,.01,3) Type a number between 1 and 9999999, 0 Decimal Digits "^DD",22706.5,22706.5,.01,21,0) ^^1^1^3051125^^ "^DD",22706.5,22706.5,.01,21,1,0) FDA generated unique identification number for each product. "^DD",22706.5,22706.5,.01,"DT") 3051125 "^DD",22706.5,22706.5,1,0) LABEL CODE^F^^0;2^K:$L(X)>6!($L(X)<1) X "^DD",22706.5,22706.5,1,3) Answer must be 1-6 characters in length "^DD",22706.5,22706.5,1,21,0) ^^4^4^3051125^^ "^DD",22706.5,22706.5,1,21,1,0) Labeler code portion of NDC; assigned by FDA to firm. The labeler code is "^DD",22706.5,22706.5,1,21,2,0) the first segment of the National Drug Code (NDC). For labeler codes 2 "^DD",22706.5,22706.5,1,21,3,0) through 9999, it is 4 digits; for labeler codes 10,000 through 99,999 it is "^DD",22706.5,22706.5,1,21,4,0) 5 digits. "^DD",22706.5,22706.5,1,"DT") 3051125 "^DD",22706.5,22706.5,2,0) PRODUCT CODE^F^^0;3^K:$L(X)>4!($L(X)<1) X "^DD",22706.5,22706.5,2,3) Answer must be 1-4 characters in length "^DD",22706.5,22706.5,2,21,0) ^^3^3^3051125^^ "^DD",22706.5,22706.5,2,21,1,0) Product code assigned by firm. The prodcode is the second segment of the "^DD",22706.5,22706.5,2,21,2,0) National Drug Code (NDC). It may be a 3-digit or 4-digit code depending upon "^DD",22706.5,22706.5,2,21,3,0) the NDC configuration selected by the firm. "^DD",22706.5,22706.5,2,"DT") 3051125 "^DD",22706.5,22706.5,3,0) STRENGTH^F^^0;4^K:$L(X)>10!($L(X)<1) X "^DD",22706.5,22706.5,3,3) Answer must be 1-10 characters in length "^DD",22706.5,22706.5,3,21,0) ^^3^3^3051125^^ "^DD",22706.5,22706.5,3,21,1,0) For single entity products, this is the potency of the active ingredient. "^DD",22706.5,22706.5,3,21,2,0) For combination products, it may be null or a number or combination of "^DD",22706.5,22706.5,3,21,3,0) numbers, e.g., Inderide 40/25. "^DD",22706.5,22706.5,3,"DT") 3051125 "^DD",22706.5,22706.5,4,0) UNIT^F^^0;5^K:$L(X)>10!($L(X)<1) X "^DD",22706.5,22706.5,4,3) Answer must be 1-10 characters in length "^DD",22706.5,22706.5,4,21,0) ^^2^2^3051125^^ "^DD",22706.5,22706.5,4,21,1,0) Unit of measure corresponding to strength. This non-mandatory field "^DD",22706.5,22706.5,4,21,2,0) contains the unit code for a single entity product, e.g., MG, %VV. "^DD",22706.5,22706.5,4,"DT") 3051125 "^DD",22706.5,22706.5,5,0) RX OR OTC^S^R:PRESCRIPTION (R);O:OVER THE COUNTER / OTC (0);^0;6^Q "^DD",22706.5,22706.5,5,21,0) ^^1^1^3051125^^ "^DD",22706.5,22706.5,5,21,1,0) Indicates whether product is labeled for rx or OTC use "^DD",22706.5,22706.5,5,"DT") 3051125 "^DD",22706.5,22706.5,6,0) FIRM^RP22706.3'^TMG(22706.3,^0;7^Q "^DD",22706.5,22706.5,6,21,0) ^^1^1^3051125^^ "^DD",22706.5,22706.5,6,21,1,0) FDA generated unique identification number for each firm "^DD",22706.5,22706.5,6,"DT") 3051125 "^DD",22706.5,22706.5,7,0) TRADENAME^RF^^0;8^K:$L(X)>100!($L(X)<1) X "^DD",22706.5,22706.5,7,3) Answer must be 1-100 characters in length "^DD",22706.5,22706.5,7,21,0) ^^1^1^3051125^^ "^DD",22706.5,22706.5,7,21,1,0) Product's name as it appears on the labeling "^DD",22706.5,22706.5,7,"DT") 3051125 "^DD",22706.5,22706.5,8,0) COMPILED^P22706.9'^TMG(22706.9,^0;9^Q "^DD",22706.5,22706.5,8,1,0) ^.1 "^DD",22706.5,22706.5,8,1,1,0) 22706.5^C "^DD",22706.5,22706.5,8,1,1,1) S ^TMG(22706.5,"C",$E(X,1,30),DA)="" "^DD",22706.5,22706.5,8,1,1,2) K ^TMG(22706.5,"C",$E(X,1,30),DA) "^DD",22706.5,22706.5,8,1,1,"DT") 3070119 "^DD",22706.5,22706.5,8,21,0) ^^1^1^3070119^^ "^DD",22706.5,22706.5,8,21,1,0) This will be a pointer to the resulting, compiled entry in TMG FDA IMPORT COMPILED "^DD",22706.5,22706.5,8,"DT") 3070119 "^DD",22706.6,22706.6,0) FIELD^^3^4 "^DD",22706.6,22706.6,0,"DT") 3051125 "^DD",22706.6,22706.6,0,"IX","B",22706.6,.01) "^DD",22706.6,22706.6,0,"NM","TMG FDA PACKAGES") "^DD",22706.6,22706.6,.01,0) LISTING^RP22706.5'^TMG(22706.5,^0;1^Q "^DD",22706.6,22706.6,.01,1,0) ^.1 "^DD",22706.6,22706.6,.01,1,1,0) 22706.6^B "^DD",22706.6,22706.6,.01,1,1,1) S ^TMG(22706.6,"B",$E(X,1,30),DA)="" "^DD",22706.6,22706.6,.01,1,1,2) K ^TMG(22706.6,"B",$E(X,1,30),DA) "^DD",22706.6,22706.6,.01,3) NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION "^DD",22706.6,22706.6,.01,21,0) ^^1^1^3051125^^ "^DD",22706.6,22706.6,.01,21,1,0) Linking field to LISTINGS. "^DD",22706.6,22706.6,.01,"DT") 3051125 "^DD",22706.6,22706.6,1,0) CODE^F^^0;2^K:$L(X)>2!($L(X)<1) X "^DD",22706.6,22706.6,1,3) Answer must be 1-2 characters in length "^DD",22706.6,22706.6,1,21,0) ^^2^2^3051125^^ "^DD",22706.6,22706.6,1,21,1,0) The package code portion of NDC code. The package code is the last segment "^DD",22706.6,22706.6,1,21,2,0) of the NDC. "^DD",22706.6,22706.6,1,"DT") 3051125 "^DD",22706.6,22706.6,2,0) SIZE^RF^^0;3^K:$L(X)>25!($L(X)<1) X "^DD",22706.6,22706.6,2,3) Answer must be 1-25 characters in length "^DD",22706.6,22706.6,2,21,0) ^^1^1^3051125^^ "^DD",22706.6,22706.6,2,21,1,0) The unit or number of units which make up a package. "^DD",22706.6,22706.6,2,"DT") 3051125 "^DD",22706.6,22706.6,3,0) TYPE^RF^^0;4^K:$L(X)>25!($L(X)<1) X "^DD",22706.6,22706.6,3,3) Answer must be 1-25 characters in length "^DD",22706.6,22706.6,3,21,0) ^^1^1^3051125^^ "^DD",22706.6,22706.6,3,21,1,0) Package type, i.e., box, bottle, vial, plastic, or glass. "^DD",22706.6,22706.6,3,"DT") 3051125 "^DD",22706.7,22706.7,0) FIELD^^2^3 "^DD",22706.7,22706.7,0,"DT") 3051125 "^DD",22706.7,22706.7,0,"IX","B",22706.7,.01) "^DD",22706.7,22706.7,0,"NM","TMG FDA ROUTES") "^DD",22706.7,22706.7,.01,0) LISTING^RP22706.5'^TMG(22706.5,^0;1^Q "^DD",22706.7,22706.7,.01,1,0) ^.1 "^DD",22706.7,22706.7,.01,1,1,0) 22706.7^B "^DD",22706.7,22706.7,.01,1,1,1) S ^TMG(22706.7,"B",$E(X,1,30),DA)="" "^DD",22706.7,22706.7,.01,1,1,2) K ^TMG(22706.7,"B",$E(X,1,30),DA) "^DD",22706.7,22706.7,.01,3) Type a number between 1 and 9999999, 0 Decimal Digits "^DD",22706.7,22706.7,.01,21,0) ^^1^1^3051125^^ "^DD",22706.7,22706.7,.01,21,1,0) Linking field to LISTINGS. "^DD",22706.7,22706.7,.01,"DT") 3051125 "^DD",22706.7,22706.7,1,0) CODE^NJ3,0^^0;2^K:+X'=X!(X>999)!(X<1)!(X?.E1"."1.N) X "^DD",22706.7,22706.7,1,3) Type a number between 1 and 999, 0 Decimal Digits "^DD",22706.7,22706.7,1,21,0) ^^2^2^3051125^^ "^DD",22706.7,22706.7,1,21,1,0) The code for the route of administration. File will allow all assigned "^DD",22706.7,22706.7,1,21,2,0) values for this element. "^DD",22706.7,22706.7,1,"DT") 3051125 "^DD",22706.7,22706.7,2,0) NAME^F^^1;1^K:$L(X)>240!($L(X)<1) X "^DD",22706.7,22706.7,2,3) Answer must be 1-240 characters in length "^DD",22706.7,22706.7,2,21,0) ^^1^1^3051125^^ "^DD",22706.7,22706.7,2,21,1,0) The translation for the route of administration code. "^DD",22706.7,22706.7,2,"DT") 3051125 "^DD",22706.8,22706.8,0) FIELD^^2^3 "^DD",22706.8,22706.8,0,"DDA") N "^DD",22706.8,22706.8,0,"DT") 3070226 "^DD",22706.8,22706.8,0,"IX","B",22706.8,.01) "^DD",22706.8,22706.8,0,"NM","TMG FDA FORMS VISTA EQUIVALENTS") "^DD",22706.8,22706.8,.01,0) FDA FORM^RF^^0;1^K:$L(X)>64!($L(X)<1) X "^DD",22706.8,22706.8,.01,1,0) ^.1 "^DD",22706.8,22706.8,.01,1,1,0) 22706.8^B "^DD",22706.8,22706.8,.01,1,1,1) S ^TMG(22706.8,"B",$E(X,1,30),DA)="" "^DD",22706.8,22706.8,.01,1,1,2) K ^TMG(22706.8,"B",$E(X,1,30),DA) "^DD",22706.8,22706.8,.01,3) Answer must be 1-64 characters in length "^DD",22706.8,22706.8,.01,21,0) ^^1^1^3070121^^ "^DD",22706.8,22706.8,.01,21,1,0) This field will hold the FDA name for the Unit. "^DD",22706.8,22706.8,.01,"DT") 3070127 "^DD",22706.8,22706.8,1,0) VISTA FORM^P50.606^PS(50.606,^0;2^Q "^DD",22706.8,22706.8,1,3) Answer must be 1-128 characters in length "^DD",22706.8,22706.8,1,21,0) ^^2^2^3070121^^ "^DD",22706.8,22706.8,1,21,1,0) This field will hold a pointer to the entry in file 50.607 (DRUG UNITS) "^DD",22706.8,22706.8,1,21,2,0) which is the equivalent the the name in the .01 field. "^DD",22706.8,22706.8,1,"DT") 3070126 "^DD",22706.8,22706.8,2,0) VISTA ROUTE^P51.2'^PS(51.2,^0;3^Q "^DD",22706.8,22706.8,2,10) 0 "^DD",22706.8,22706.8,2,21,0) ^^5^5^3070226^^ "^DD",22706.8,22706.8,2,21,1,0) This field will hold an associated ROUTE "^DD",22706.8,22706.8,2,21,2,0) that is appropriate for a given drug FORM. "^DD",22706.8,22706.8,2,21,3,0) E.g. "^DD",22706.8,22706.8,2,21,4,0) TAB --> PO "^DD",22706.8,22706.8,2,21,5,0) SUPP--> PR etc. "^DD",22706.8,22706.8,2,"DT") 3070226 "^DD",22706.82,22706.82,0) FIELD^^1^2 "^DD",22706.82,22706.82,0,"DT") 3070227 "^DD",22706.82,22706.82,0,"IX","B",22706.82,.01) "^DD",22706.82,22706.82,0,"NM","TMG FDA ROUTES VISTA EQUIVALENTS") "^DD",22706.82,22706.82,.01,0) FDA ROUTE^RF^^0;1^K:$L(X)>64!($L(X)<3) X "^DD",22706.82,22706.82,.01,1,0) ^.1 "^DD",22706.82,22706.82,.01,1,1,0) 22706.82^B "^DD",22706.82,22706.82,.01,1,1,1) S ^TMG(22706.82,"B",$E(X,1,30),DA)="" "^DD",22706.82,22706.82,.01,1,1,2) K ^TMG(22706.82,"B",$E(X,1,30),DA) "^DD",22706.82,22706.82,.01,3) Answer must be 3-64 characters in length "^DD",22706.82,22706.82,.01,10) 1 "^DD",22706.82,22706.82,.01,21,0) ^^1^1^3070227^^ "^DD",22706.82,22706.82,.01,21,1,0) This will store the ROUTE, as provided in the FDA database "^DD",22706.82,22706.82,.01,"DT") 3070227 "^DD",22706.82,22706.82,1,0) VISTA ROUTE^P51.2'^PS(51.2,^0;2^Q "^DD",22706.82,22706.82,1,10) 1 "^DD",22706.82,22706.82,1,21,0) ^^2^2^3070227^^ "^DD",22706.82,22706.82,1,21,1,0) This will contain a pointer to the VA record containing "^DD",22706.82,22706.82,1,21,2,0) the equivalence for the FDA ROUTE. "^DD",22706.82,22706.82,1,"DT") 3070227 "^DD",22706.9,22706.9,0) FIELD^^5.711^31 "^DD",22706.9,22706.9,0,"DDA") N "^DD",22706.9,22706.9,0,"DT") 3071117 "^DD",22706.9,22706.9,0,"IX","B",22706.9,.01) "^DD",22706.9,22706.9,0,"IX","C",22706.9,.05) "^DD",22706.9,22706.9,0,"IX","D",22706.9,.07) "^DD",22706.9,22706.9,0,"IX","DRUG",22706.9,5.7) "^DD",22706.9,22706.9,0,"IX","DRUGT",22706.9,5.6) "^DD",22706.9,22706.9,0,"IX","E",22706.9,.08) "^DD",22706.9,22706.9,0,"IX","LN",22706.9,.04) "^DD",22706.9,22706.9,0,"IX","NDC",22706.9,4) "^DD",22706.9,22706.9,0,"IX","NDC12",22706.9,5) "^DD",22706.9,22706.9,0,"IX","NDC2",22706.9,4) "^DD",22706.9,22706.9,0,"IX","OIG",22706.9,5.711) "^DD",22706.9,22706.9,0,"IX","OIT",22706.9,5.611) "^DD",22706.9,22706.9,0,"IX","POIG",22706.9,5.71) "^DD",22706.9,22706.9,0,"IX","POIT",22706.9,5.61) "^DD",22706.9,22706.9,0,"IX","ROUTE",22706.9,3) "^DD",22706.9,22706.9,0,"IX","SKIP",22706.9,6) "^DD",22706.9,22706.9,0,"IX","TMG",22706.916,.01) "^DD",22706.9,22706.9,0,"IX","VAP",22706.914,.01) "^DD",22706.9,22706.9,0,"IX","VAP1",22706.9,5.5) "^DD",22706.9,22706.9,0,"NM","TMG FDA IMPORT COMPILED") "^DD",22706.9,22706.9,0,"PT",22706.5,8) "^DD",22706.9,22706.9,.01,0) TMG FDA LISTING ENTRY^RP22706.5'^TMG(22706.5,^0;1^Q "^DD",22706.9,22706.9,.01,1,0) ^.1 "^DD",22706.9,22706.9,.01,1,1,0) 22706.9^B "^DD",22706.9,22706.9,.01,1,1,1) S ^TMG(22706.9,"B",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,.01,1,1,2) K ^TMG(22706.9,"B",$E(X,1,30),DA) "^DD",22706.9,22706.9,.01,3) Answer must be 3-60 characters in length "^DD",22706.9,22706.9,.01,10) 1 "^DD",22706.9,22706.9,.01,"DT") 3060318 "^DD",22706.9,22706.9,.04,0) LONG NAME^F^^7;6^K:$L(X)>63!($L(X)<3) X "^DD",22706.9,22706.9,.04,1,0) ^.1 "^DD",22706.9,22706.9,.04,1,1,0) 22706.9^LN "^DD",22706.9,22706.9,.04,1,1,1) S ^TMG(22706.9,"LN",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,.04,1,1,2) K ^TMG(22706.9,"LN",$E(X,1,30),DA) "^DD",22706.9,22706.9,.04,1,1,"DT") 3071015 "^DD",22706.9,22706.9,.04,3) Answer must be 3-63 characters in length "^DD",22706.9,22706.9,.04,10) 7 "^DD",22706.9,22706.9,.04,21,0) ^^2^2^3070225^^ "^DD",22706.9,22706.9,.04,21,1,0) This will be a full name in this format: "^DD",22706.9,22706.9,.04,21,2,0) Generic Name (Trade Name) Strength Units "^DD",22706.9,22706.9,.04,"DT") 3071015 "^DD",22706.9,22706.9,.05,0) TRADENAME^F^^0;4^K:$L(X)>64!($L(X)<2) X "^DD",22706.9,22706.9,.05,1,0) ^.1^^-1 "^DD",22706.9,22706.9,.05,1,1,0) 22706.9^C "^DD",22706.9,22706.9,.05,1,1,1) S ^TMG(22706.9,"C",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,.05,1,1,2) K ^TMG(22706.9,"C",$E(X,1,30),DA) "^DD",22706.9,22706.9,.05,1,1,"DT") 3060325 "^DD",22706.9,22706.9,.05,3) Answer must be 2-64 characters in length "^DD",22706.9,22706.9,.05,"DT") 3070114 "^DD",22706.9,22706.9,.055,0) TRADE NAME & FORM - 40^F^^7;3^K:$L(X)>40!($L(X)<3) X "^DD",22706.9,22706.9,.055,3) Answer must be 3-40 characters in length "^DD",22706.9,22706.9,.055,10) 7 "^DD",22706.9,22706.9,.055,21,0) ^^21^21^3070224^^ "^DD",22706.9,22706.9,.055,21,1,0) The tradename stored in field .05 has a length limit of 64 characters. "^DD",22706.9,22706.9,.055,21,2,0) However, this name must ultimately be used in other files that have "^DD",22706.9,22706.9,.055,21,3,0) shorter field lengths. For example, here are the field lengths "^DD",22706.9,22706.9,.055,21,4,0) of other fields that this tradename will be used to populate: "^DD",22706.9,22706.9,.055,21,5,0) "^DD",22706.9,22706.9,.055,21,6,0) DRUG file 50, .01 -- GENERIC NAME field length=1-40 "^DD",22706.9,22706.9,.055,21,7,0) DRUG file 50, 21 -- VA PRODUCT NAME field length=1-70 "^DD",22706.9,22706.9,.055,21,8,0) DRUG file 50, 9:.01 -- SYNONYM field length=1-40 "^DD",22706.9,22706.9,.055,21,9,0) VA PRODUCT file 50.68, .01 -- NAME field length=3-64 "^DD",22706.9,22706.9,.055,21,10,0) VA PRODUCT file 50.68, 5 -- VA PRINT NAME field length=1-40 "^DD",22706.9,22706.9,.055,21,11,0) PHARMACY ORDERABLE ITEM file 50.7, .01 -- NAME field length=3-40 "^DD",22706.9,22706.9,.055,21,12,0) ORDERABLE ITEM file 101.43, .01 -- NAME field length=3-63 "^DD",22706.9,22706.9,.055,21,13,0) "^DD",22706.9,22706.9,.055,21,14,0) So it is helpful to prepare a shorter version of the name and store it for "^DD",22706.9,22706.9,.055,21,15,0) future use. "^DD",22706.9,22706.9,.055,21,16,0) "^DD",22706.9,22706.9,.055,21,17,0) This field will store a version of the name that is 40 characters in length. "^DD",22706.9,22706.9,.055,21,18,0) "^DD",22706.9,22706.9,.055,21,19,0) NOTE: This name will be comprised of Tradename, Strength, and Units. "^DD",22706.9,22706.9,.055,21,20,0) This is different from field .05 TRADENAME, which is supposed "^DD",22706.9,22706.9,.055,21,21,0) to contain just the name. "^DD",22706.9,22706.9,.055,"DT") 3070306 "^DD",22706.9,22706.9,.056,0) TRADENAME FORM DOSE UNIT - 40^F^^8;1^K:$L(X)>40!($L(X)<3) X "^DD",22706.9,22706.9,.056,3) Answer must be 3-40 characters in length. "^DD",22706.9,22706.9,.056,21,0) ^^2^2^3071105^^ "^DD",22706.9,22706.9,.056,21,1,0) This name will be used to populate the .01 field of DRUG file entries. "^DD",22706.9,22706.9,.056,21,2,0) It should consist of TradeName Dose Units Form, and be 3-40 chars long. "^DD",22706.9,22706.9,.056,"DT") 3071106 "^DD",22706.9,22706.9,.07,0) GENERIC NAME^F^^0;6^K:$L(X)>64!($L(X)<3) X "^DD",22706.9,22706.9,.07,1,0) ^.1 "^DD",22706.9,22706.9,.07,1,1,0) 22706.9^D "^DD",22706.9,22706.9,.07,1,1,1) S ^TMG(22706.9,"D",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,.07,1,1,2) K ^TMG(22706.9,"D",$E(X,1,30),DA) "^DD",22706.9,22706.9,.07,1,1,"DT") 3060530 "^DD",22706.9,22706.9,.07,3) Answer must be 3-64 characters in length "^DD",22706.9,22706.9,.07,"DT") 3070224 "^DD",22706.9,22706.9,.075,0) GENERIC NAME & FORM - 40^F^^7;4^K:$L(X)>40!($L(X)<3) X "^DD",22706.9,22706.9,.075,3) Answer must be 3-40 characters in length "^DD",22706.9,22706.9,.075,10) 7 "^DD",22706.9,22706.9,.075,21,0) ^^22^22^3070224^^ "^DD",22706.9,22706.9,.075,21,1,0) The GENERIC NAME stored in field .07 has a length limit of 64 characters. "^DD",22706.9,22706.9,.075,21,2,0) However, this name must ultimately be used in other files that have "^DD",22706.9,22706.9,.075,21,3,0) shorter field lengths. For example, here are the field lengths "^DD",22706.9,22706.9,.075,21,4,0) of other fields that this tradename will be used to populate: "^DD",22706.9,22706.9,.075,21,5,0) "^DD",22706.9,22706.9,.075,21,6,0) DRUG file 50, .01 -- GENERIC NAME field length=1-40 "^DD",22706.9,22706.9,.075,21,7,0) DRUG file 50, 21 -- VA PRODUCT NAME field length=1-70 "^DD",22706.9,22706.9,.075,21,8,0) DRUG file 50, 9:.01 -- SYNONYM field length=1-40 "^DD",22706.9,22706.9,.075,21,9,0) VA PRODUCT file 50.68, .01 -- NAME field length=3-64 "^DD",22706.9,22706.9,.075,21,10,0) VA PRODUCT file 50.68, 5 -- VA PRINT NAME field length=1-40 "^DD",22706.9,22706.9,.075,21,11,0) PHARMACY ORDERABLE ITEM file 50.7, .01 -- NAME field length=3-40 "^DD",22706.9,22706.9,.075,21,12,0) ORDERABLE ITEM file 101.43, .01 -- NAME field length=3-63 "^DD",22706.9,22706.9,.075,21,13,0) "^DD",22706.9,22706.9,.075,21,14,0) So it is helpful to prepare a shorter version of the name and store it for "^DD",22706.9,22706.9,.075,21,15,0) future use. "^DD",22706.9,22706.9,.075,21,16,0) "^DD",22706.9,22706.9,.075,21,17,0) This field will store a version of the name that is 40 characters in length. "^DD",22706.9,22706.9,.075,21,18,0) "^DD",22706.9,22706.9,.075,21,19,0) NOTE: This name will be comprised of Generic name, Strength, and Units. "^DD",22706.9,22706.9,.075,21,20,0) This is different from field .07 GENERIC NAME, which is supposed "^DD",22706.9,22706.9,.075,21,21,0) to contain just the name. "^DD",22706.9,22706.9,.075,21,22,0) "^DD",22706.9,22706.9,.075,"DT") 3070306 "^DD",22706.9,22706.9,.076,0) GENERICNAME FORM DOSE UNT - 40^F^^8;2^K:$L(X)>40!($L(X)<3) X "^DD",22706.9,22706.9,.076,3) Answer must be 3-40 characters in length. "^DD",22706.9,22706.9,.076,21,0) ^^3^3^3071105^^ "^DD",22706.9,22706.9,.076,21,1,0) This will be used to fill the .01 field of DRUG file entries. "^DD",22706.9,22706.9,.076,21,2,0) It should consist of the Generic Name, dose strengh, units, form. "^DD",22706.9,22706.9,.076,21,3,0) It should be 3-40 characters in length. "^DD",22706.9,22706.9,.076,"DT") 3071105 "^DD",22706.9,22706.9,.08,0) VA GENERIC^P50.6'^PSNDF(50.6,^1;3^Q "^DD",22706.9,22706.9,.08,1,0) ^.1 "^DD",22706.9,22706.9,.08,1,1,0) 22706.9^E "^DD",22706.9,22706.9,.08,1,1,1) S ^TMG(22706.9,"E",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,.08,1,1,2) K ^TMG(22706.9,"E",$E(X,1,30),DA) "^DD",22706.9,22706.9,.08,1,1,"DT") 3060530 "^DD",22706.9,22706.9,.08,"DT") 3060530 "^DD",22706.9,22706.9,.09,0) VA DRUG CLASS^P50.605'^PS(50.605,^1;5^Q "^DD",22706.9,22706.9,.09,"DT") 3060416 "^DD",22706.9,22706.9,1,0) STRENGTH^F^^0;2^K:$L(X)>32!($L(X)<1) X "^DD",22706.9,22706.9,1,3) Answer must be 1-32 characters in length "^DD",22706.9,22706.9,1,"DT") 3060318 "^DD",22706.9,22706.9,2,0) UNIT^F^^0;3^K:$L(X)>32!($L(X)<1) X "^DD",22706.9,22706.9,2,3) Answer must be 1-32 characters in length "^DD",22706.9,22706.9,2,"DT") 3060322 "^DD",22706.9,22706.9,3,0) FDA ROUTE^F^^0;5^K:$L(X)>16!($L(X)<2) X "^DD",22706.9,22706.9,3,1,0) ^.1 "^DD",22706.9,22706.9,3,1,1,0) 22706.9^ROUTE "^DD",22706.9,22706.9,3,1,1,1) S ^TMG(22706.9,"ROUTE",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,3,1,1,2) K ^TMG(22706.9,"ROUTE",$E(X,1,30),DA) "^DD",22706.9,22706.9,3,1,1,"DT") 3070227 "^DD",22706.9,22706.9,3,3) Answer must be 2-16 characters in length "^DD",22706.9,22706.9,3,"DT") 3070227 "^DD",22706.9,22706.9,3.1,0) VA ROUTE^P51.2'^PS(51.2,^7;7^Q "^DD",22706.9,22706.9,3.1,21,0) ^^1^1^3070227^^ "^DD",22706.9,22706.9,3.1,21,1,0) This will contain a pointer to the equivalent ROUTE in the VA system. "^DD",22706.9,22706.9,3.1,"DT") 3070227 "^DD",22706.9,22706.9,3.4,0) FDA DOSAGE FORM^F^^6;1^K:$L(X)>240!($L(X)<1) X "^DD",22706.9,22706.9,3.4,3) Answer must be 1-240 characters in length "^DD",22706.9,22706.9,3.4,21,0) ^^1^1^3070127^^ "^DD",22706.9,22706.9,3.4,21,1,0) This will be the text for the dosage form, as provided by the FDA database. "^DD",22706.9,22706.9,3.4,"DT") 3070127 "^DD",22706.9,22706.9,3.5,0) VA DOSAGE FORM^P50.606^PS(50.606,^0;7^Q "^DD",22706.9,22706.9,3.5,"DT") 3070227 "^DD",22706.9,22706.9,4,0) NDC^F^^1;1^K:$L(X)>14!($L(X)<12) X "^DD",22706.9,22706.9,4,1,0) ^.1 "^DD",22706.9,22706.9,4,1,1,0) 22706.9^NDC "^DD",22706.9,22706.9,4,1,1,1) S ^TMG(22706.9,"NDC",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,4,1,1,2) K ^TMG(22706.9,"NDC",$E(X,1,30),DA) "^DD",22706.9,22706.9,4,1,1,"%D",0) ^^3^3^3060318^^ "^DD",22706.9,22706.9,4,1,1,"%D",1,0) This is an index based on NDC (National drug code), with format like this: "^DD",22706.9,22706.9,4,1,1,"%D",2,0) "^DD",22706.9,22706.9,4,1,1,"%D",3,0) Producer/Packager-Product Code-Package Code "^DD",22706.9,22706.9,4,1,1,"DT") 3060318 "^DD",22706.9,22706.9,4,1,2,0) 22706.9^NDC2 "^DD",22706.9,22706.9,4,1,2,1) S X=$TR(X,"-","") S ^TMG(22706.9,"NDC2",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,4,1,2,2) K ^TMG(22706.9,"NDC2",$E(X,1,30),DA) "^DD",22706.9,22706.9,4,1,2,"%D",0) ^^1^1^3061207^^ "^DD",22706.9,22706.9,4,1,2,"%D",1,0) This index is of the NDC (national drug code) with hyphens removed. "^DD",22706.9,22706.9,4,1,2,"DT") 3061207 "^DD",22706.9,22706.9,4,3) Answer must be 12-14 characters in length "^DD",22706.9,22706.9,4,"DT") 3061207 "^DD",22706.9,22706.9,5,0) NDC 12-DIGIT^F^^1;2^K:$L(X)>12!($L(X)<12) X "^DD",22706.9,22706.9,5,1,0) ^.1 "^DD",22706.9,22706.9,5,1,1,0) 22706.9^NDC12 "^DD",22706.9,22706.9,5,1,1,1) S ^TMG(22706.9,"NDC12",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5,1,1,2) K ^TMG(22706.9,"NDC12",$E(X,1,30),DA) "^DD",22706.9,22706.9,5,1,1,"%D",0) ^^1^1^3060318^^ "^DD",22706.9,22706.9,5,1,1,"%D",1,0) This is an index on the 12digit format of the National Drug Code "^DD",22706.9,22706.9,5,1,1,"DT") 3060318 "^DD",22706.9,22706.9,5,3) Answer must be 12 characters in length "^DD",22706.9,22706.9,5,"DT") 3060318 "^DD",22706.9,22706.9,5.5,0) VA PRODUCT LINK^P50.68'^PSNDF(50.68,^6;2^Q "^DD",22706.9,22706.9,5.5,1,0) ^.1 "^DD",22706.9,22706.9,5.5,1,1,0) 22706.9^VAP1 "^DD",22706.9,22706.9,5.5,1,1,1) S ^TMG(22706.9,"VAP1",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.5,1,1,2) K ^TMG(22706.9,"VAP1",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.5,1,1,"DT") 3070217 "^DD",22706.9,22706.9,5.5,10) 18 "^DD",22706.9,22706.9,5.5,21,0) ^.001^2^2^3070211^^^ "^DD",22706.9,22706.9,5.5,21,1,0) This will hold a pointer to an entry in the VA PRODUCT file "^DD",22706.9,22706.9,5.5,21,2,0) that has the same national drug code (NDC) "^DD",22706.9,22706.9,5.5,"DT") 3070217 "^DD",22706.9,22706.9,5.6,0) DRUG TRADENAME LINK^P50'^PSDRUG(^7;1^Q "^DD",22706.9,22706.9,5.6,1,0) ^.1^^-1 "^DD",22706.9,22706.9,5.6,1,1,0) 22706.9^DRUGT "^DD",22706.9,22706.9,5.6,1,1,1) S ^TMG(22706.9,"DRUGT",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.6,1,1,2) K ^TMG(22706.9,"DRUGT",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.6,1,1,"DT") 3070217 "^DD",22706.9,22706.9,5.6,10) 63 "^DD",22706.9,22706.9,5.6,21,0) ^^24^24^3070217^^ "^DD",22706.9,22706.9,5.6,21,1,0) This will contain a link the entry in the DRUG file that contains "^DD",22706.9,22706.9,5.6,21,2,0) the Trade name of a drug. "^DD",22706.9,22706.9,5.6,21,3,0) "^DD",22706.9,22706.9,5.6,21,4,0) A given entry in TMG FDA IMPORT COMPILED will generate TWO entries in "^DD",22706.9,22706.9,5.6,21,5,0) the DRUG file, one with a name of the Trade name, and one with a name "^DD",22706.9,22706.9,5.6,21,6,0) of the Generic name. "^DD",22706.9,22706.9,5.6,21,7,0) "^DD",22706.9,22706.9,5.6,21,8,0) It is the name stored in the .01 field (the 'GENERIC NAME' field) that "^DD",22706.9,22706.9,5.6,21,9,0) is considered the true name of a drug entry. The standard way that "^DD",22706.9,22706.9,5.6,21,10,0) drugs are entered in the VA is to put the generic name in the .01 field "^DD",22706.9,22706.9,5.6,21,11,0) and then put the brand name in the SYNONYM field. Then, in CPRS, both "^DD",22706.9,22706.9,5.6,21,12,0) the .01 field, and also any synonyms are displayed. But when one "^DD",22706.9,22706.9,5.6,21,13,0) views the drug, to pick the strength and requency, then it is the "^DD",22706.9,22706.9,5.6,21,14,0) generic name this is display. And I assume that this generic name is "^DD",22706.9,22706.9,5.6,21,15,0) what will be printed out. "^DD",22706.9,22706.9,5.6,21,16,0) "^DD",22706.9,22706.9,5.6,21,17,0) For example, if one wants to create a prescription for ZOCOR, it would "^DD",22706.9,22706.9,5.6,21,18,0) normally come out as SIMVASTATIN. "^DD",22706.9,22706.9,5.6,21,19,0) "^DD",22706.9,22706.9,5.6,21,20,0) To overcome this, drugs will be entered differently than is done at the VA. "^DD",22706.9,22706.9,5.6,21,21,0) A drug entry will be created for both ZOCOR and SIMVASTATIN. "^DD",22706.9,22706.9,5.6,21,22,0) "^DD",22706.9,22706.9,5.6,21,23,0) Field 5.6 will contain a link to the DRUG record containing the trade name. "^DD",22706.9,22706.9,5.6,21,24,0) Field 5.7 will contain a link to the DRUG record containing the brand name. "^DD",22706.9,22706.9,5.6,"DT") 3071104 "^DD",22706.9,22706.9,5.61,0) POI TRADENAME LINK^P50.7'^PS(50.7,^8;3^Q "^DD",22706.9,22706.9,5.61,1,0) ^.1 "^DD",22706.9,22706.9,5.61,1,1,0) 22706.9^POIT "^DD",22706.9,22706.9,5.61,1,1,1) S ^TMG(22706.9,"POIT",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.61,1,1,2) K ^TMG(22706.9,"POIT",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.61,1,1,"%D",0) ^^2^2^3071118^^ "^DD",22706.9,22706.9,5.61,1,1,"%D",1,0) This cross references the pointer to the PHARMACY "^DD",22706.9,22706.9,5.61,1,1,"%D",2,0) ORDERABLE ITEM FILE (#50.7) for Trade name drugs. "^DD",22706.9,22706.9,5.61,1,1,"DT") 3071118 "^DD",22706.9,22706.9,5.61,21,0) ^^1^1^3071117^^ "^DD",22706.9,22706.9,5.61,21,1,0) This will contain a pointer to the PHARMACY ORDERABLE ITEM used for this record. "^DD",22706.9,22706.9,5.61,"DT") 3071118 "^DD",22706.9,22706.9,5.611,0) OI TRADENAME LINK^P101.43'^ORD(101.43,^8;5^Q "^DD",22706.9,22706.9,5.611,1,0) ^.1 "^DD",22706.9,22706.9,5.611,1,1,0) 22706.9^OIT "^DD",22706.9,22706.9,5.611,1,1,1) S ^TMG(22706.9,"OIT",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.611,1,1,2) K ^TMG(22706.9,"OIT",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.611,1,1,"%D",0) ^^2^2^3071118^^ "^DD",22706.9,22706.9,5.611,1,1,"%D",1,0) This is a cross reference of the ORDERABLE ITEM to be used "^DD",22706.9,22706.9,5.611,1,1,"%D",2,0) for this record. "^DD",22706.9,22706.9,5.611,1,1,"DT") 3071118 "^DD",22706.9,22706.9,5.611,"DT") 3071118 "^DD",22706.9,22706.9,5.7,0) DRUG GENERIC LINK^P50'^PSDRUG(^7;2^Q "^DD",22706.9,22706.9,5.7,1,0) ^.1^^-1 "^DD",22706.9,22706.9,5.7,1,1,0) 22706.9^DRUG "^DD",22706.9,22706.9,5.7,1,1,1) S ^TMG(22706.9,"DRUG",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.7,1,1,2) K ^TMG(22706.9,"DRUG",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.7,1,1,"DT") 3070217 "^DD",22706.9,22706.9,5.7,10) 7 "^DD",22706.9,22706.9,5.7,21,0) ^^24^24^3070217^^ "^DD",22706.9,22706.9,5.7,21,1,0) This will contain a link the entry in the DRUG file that contains "^DD",22706.9,22706.9,5.7,21,2,0) the Generic name of a drug. "^DD",22706.9,22706.9,5.7,21,3,0) "^DD",22706.9,22706.9,5.7,21,4,0) A given entry in TMG FDA IMPORT COMPILED will generate TWO entries in "^DD",22706.9,22706.9,5.7,21,5,0) the DRUG file, one with a name of the Trade name, and one with a name "^DD",22706.9,22706.9,5.7,21,6,0) of the Generic name. "^DD",22706.9,22706.9,5.7,21,7,0) "^DD",22706.9,22706.9,5.7,21,8,0) It is the name stored in the .01 field (the 'GENERIC NAME' field) that "^DD",22706.9,22706.9,5.7,21,9,0) is considered the true name of a drug entry. The standard way that "^DD",22706.9,22706.9,5.7,21,10,0) drugs are entered in the VA is to put the generic name in the .01 field "^DD",22706.9,22706.9,5.7,21,11,0) and then put the brand name in the SYNONYM field. Then, in CPRS, both "^DD",22706.9,22706.9,5.7,21,12,0) the .01 field, and also any synonyms are displayed. But when one "^DD",22706.9,22706.9,5.7,21,13,0) views the drug, to pick the strength and requency, then it is the "^DD",22706.9,22706.9,5.7,21,14,0) generic name this is display. And I assume that this generic name is "^DD",22706.9,22706.9,5.7,21,15,0) what will be printed out. "^DD",22706.9,22706.9,5.7,21,16,0) "^DD",22706.9,22706.9,5.7,21,17,0) For example, if one wants to create a prescription for ZOCOR, it would "^DD",22706.9,22706.9,5.7,21,18,0) normally come out as SIMVASTATIN. "^DD",22706.9,22706.9,5.7,21,19,0) "^DD",22706.9,22706.9,5.7,21,20,0) To overcome this, drugs will be entered differently than is done at the VA. "^DD",22706.9,22706.9,5.7,21,21,0) A drug entry will be created for both ZOCOR and SIMVASTATIN. "^DD",22706.9,22706.9,5.7,21,22,0) "^DD",22706.9,22706.9,5.7,21,23,0) Field 5.6 will contain a link to the DRUG record containing the trade name. "^DD",22706.9,22706.9,5.7,21,24,0) Field 5.7 will contain a link to the DRUG record containing the brand name. "^DD",22706.9,22706.9,5.7,"DT") 3071104 "^DD",22706.9,22706.9,5.71,0) POI GENERIC LINK^P50.7'^PS(50.7,^8;4^Q "^DD",22706.9,22706.9,5.71,1,0) ^.1 "^DD",22706.9,22706.9,5.71,1,1,0) 22706.9^POIG "^DD",22706.9,22706.9,5.71,1,1,1) S ^TMG(22706.9,"POIG",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.71,1,1,2) K ^TMG(22706.9,"POIG",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.71,1,1,"%D",0) ^^2^2^3071118^^ "^DD",22706.9,22706.9,5.71,1,1,"%D",1,0) This will cross reference pointers to the PHARMACY "^DD",22706.9,22706.9,5.71,1,1,"%D",2,0) ORDERABLE ITEM file (#50.7) for Generic name drugs. "^DD",22706.9,22706.9,5.71,1,1,"DT") 3071118 "^DD",22706.9,22706.9,5.71,21,0) ^^1^1^3071117^^ "^DD",22706.9,22706.9,5.71,21,1,0) This will be a link to the PHARMACY ORDERABLE ITEM uses for this record "^DD",22706.9,22706.9,5.71,"DT") 3071118 "^DD",22706.9,22706.9,5.711,0) OI GENERIC LINK^P101.43'^ORD(101.43,^8;6^Q "^DD",22706.9,22706.9,5.711,1,0) ^.1 "^DD",22706.9,22706.9,5.711,1,1,0) 22706.9^OIG "^DD",22706.9,22706.9,5.711,1,1,1) S ^TMG(22706.9,"OIG",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,5.711,1,1,2) K ^TMG(22706.9,"OIG",$E(X,1,30),DA) "^DD",22706.9,22706.9,5.711,1,1,"%D",0) ^^2^2^3071118^^ "^DD",22706.9,22706.9,5.711,1,1,"%D",1,0) This is the cross refernce of the ORDERABLE item to be used "^DD",22706.9,22706.9,5.711,1,1,"%D",2,0) for this record, for Generic name drugs. "^DD",22706.9,22706.9,5.711,1,1,"DT") 3071118 "^DD",22706.9,22706.9,5.711,"DT") 3071118 "^DD",22706.9,22706.9,6,0) SKIP THIS RECORD^S^1:SKIP;0:KEEP;^1;4^Q "^DD",22706.9,22706.9,6,1,0) ^.1 "^DD",22706.9,22706.9,6,1,1,0) 22706.9^SKIP "^DD",22706.9,22706.9,6,1,1,1) S ^TMG(22706.9,"SKIP",$E(X,1,30),DA)="" "^DD",22706.9,22706.9,6,1,1,2) K ^TMG(22706.9,"SKIP",$E(X,1,30),DA) "^DD",22706.9,22706.9,6,1,1,"%D",0) ^^2^2^3070301^^ "^DD",22706.9,22706.9,6,1,1,"%D",1,0) This will be a cross reference of all the "^DD",22706.9,22706.9,6,1,1,"%D",2,0) records on the SKIP THIS RECORD field. "^DD",22706.9,22706.9,6,1,1,"DT") 3070301 "^DD",22706.9,22706.9,6,"DT") 3070301 "^DD",22706.9,22706.9,7,0) RX OR OTC^S^R:RX;O:OTC;^7;5^Q "^DD",22706.9,22706.9,7,10) 7 "^DD",22706.9,22706.9,7,21,0) ^^4^4^3070225^^ "^DD",22706.9,22706.9,7,21,1,0) If a drug is available over the counter (without a prescription) it should "^DD",22706.9,22706.9,7,21,2,0) be marked as OTC (code O). "^DD",22706.9,22706.9,7,21,3,0) "^DD",22706.9,22706.9,7,21,4,0) If a prescription is required, it should be marked as RX (code R) "^DD",22706.9,22706.9,7,"DT") 3070225 "^DD",22706.9,22706.9,14,0) VA PRODUCT SIMILAR MATCHES^22706.914P^^2;0 "^DD",22706.9,22706.9,14,21,0) ^^10^10^3070211^^ "^DD",22706.9,22706.9,14,21,1,0) This field will hold pointers to entries in the VA PRODUCT file "^DD",22706.9,22706.9,14,21,2,0) that have similar ingredients and doses etc. I.e. these are "^DD",22706.9,22706.9,14,21,3,0) the closest matches that the algorhythm can find. "^DD",22706.9,22706.9,14,21,4,0) "^DD",22706.9,22706.9,14,21,5,0) However, it is intended that this list will NOT hold the pointer "^DD",22706.9,22706.9,14,21,6,0) to the EXACT match, i.e. the one that has the same national drug "^DD",22706.9,22706.9,14,21,7,0) code (NDC). A separate field will hold that link. "^DD",22706.9,22706.9,14,21,8,0) "^DD",22706.9,22706.9,14,21,9,0) Essentially this field holds a one-to-many linkage between this "^DD",22706.9,22706.9,14,21,10,0) import from the FDA database and entries in the VA PRODUCT file. "^DD",22706.9,22706.9,14,"DT") 3070211 "^DD",22706.9,22706.9,15,0) VA PRODUCT POSSIBLE MATCHES^22706.915P^^3;0 "^DD",22706.9,22706.9,15,21,0) ^^10^10^3070211^^ "^DD",22706.9,22706.9,15,21,1,0) This field will hold linkages to entries in the VA PRODUCT file that "^DD",22706.9,22706.9,15,21,2,0) have some similarities to the FDA import, but differ in some way. "^DD",22706.9,22706.9,15,21,3,0) "^DD",22706.9,22706.9,15,21,4,0) Sometimes the algorhythm works well and these entries are actually "^DD",22706.9,22706.9,15,21,5,0) a close match. Other times it is completely wrong. For example, "^DD",22706.9,22706.9,15,21,6,0) it might include an entry here because both contain SODIUM CHLORIDE "^DD",22706.9,22706.9,15,21,7,0) and overlook that the major ingredients are different. "^DD",22706.9,22706.9,15,21,8,0) "^DD",22706.9,22706.9,15,21,9,0) So the links in this field should not be used for any automatic "^DD",22706.9,22706.9,15,21,10,0) filling of missing data without human intervention. "^DD",22706.9,22706.9,15,"DT") 3070211 "^DD",22706.9,22706.9,16,0) INGREDIENTS^22706.916^^4;0 "^DD",22706.9,22706.9,20,0) COMMENT^22706.9001^^5;0 "^DD",22706.9,22706.9001,0) COMMENT SUB-FIELD^^1^2 "^DD",22706.9,22706.9001,0,"DT") 3070119 "^DD",22706.9,22706.9001,0,"IX","B",22706.9001,.01) "^DD",22706.9,22706.9001,0,"NM","COMMENT") "^DD",22706.9,22706.9001,0,"UP") 22706.9 "^DD",22706.9,22706.9001,.01,0) COMMENT^F^^0;1^K:$L(X)>200!($L(X)<1) X "^DD",22706.9,22706.9001,.01,1,0) ^.1 "^DD",22706.9,22706.9001,.01,1,1,0) 22706.9001^B "^DD",22706.9,22706.9001,.01,1,1,1) S ^TMG(22706.9,DA(1),5,"B",$E(X,1,30),DA)="" "^DD",22706.9,22706.9001,.01,1,1,2) K ^TMG(22706.9,DA(1),5,"B",$E(X,1,30),DA) "^DD",22706.9,22706.9001,.01,3) Answer must be 1-200 characters in length "^DD",22706.9,22706.9001,.01,21,0) ^^1^1^3070119^^ "^DD",22706.9,22706.9001,.01,21,1,0) This will be used to store 1 line comments about record "^DD",22706.9,22706.9001,.01,23,0) ^^2^2^3070119^^ "^DD",22706.9,22706.9001,.01,23,1,0) This field may be 1-200 characters long. It can store comments about when "^DD",22706.9,22706.9001,.01,23,2,0) field was edited, and why etc. "^DD",22706.9,22706.9001,.01,"DT") 3070119 "^DD",22706.9,22706.9001,1,0) DATE^D^^0;2^S %DT="E" D ^%DT S X=Y K:X<1 X "^DD",22706.9,22706.9001,1,3) (No range limit on date) "^DD",22706.9,22706.9001,1,21,0) ^^1^1^3070119^^ "^DD",22706.9,22706.9001,1,21,1,0) This is the date for the comment. "^DD",22706.9,22706.9001,1,"DT") 3070119 "^DD",22706.9,22706.914,0) VA PRODUCT SIMILAR MATCHES SUB-FIELD^^.01^1 "^DD",22706.9,22706.914,0,"DT") 3060318 "^DD",22706.9,22706.914,0,"IX","B",22706.914,.01) "^DD",22706.9,22706.914,0,"NM","VA PRODUCT SIMILAR MATCHES") "^DD",22706.9,22706.914,0,"UP") 22706.9 "^DD",22706.9,22706.914,.01,0) ONE MATCH^P50.68'^PSNDF(50.68,^0;1^Q "^DD",22706.9,22706.914,.01,1,0) ^.1^^-1 "^DD",22706.9,22706.914,.01,1,1,0) 22706.914^B "^DD",22706.9,22706.914,.01,1,1,1) S ^TMG(22706.9,DA(1),2,"B",$E(X,1,30),DA)="" "^DD",22706.9,22706.914,.01,1,1,2) K ^TMG(22706.9,DA(1),2,"B",$E(X,1,30),DA) "^DD",22706.9,22706.914,.01,1,2,0) 22706.9^VAP "^DD",22706.9,22706.914,.01,1,2,1) S ^TMG(22706.9,"VAP",$E(X,1,30),DA(1),DA)="" "^DD",22706.9,22706.914,.01,1,2,2) K ^TMG(22706.9,"VAP",$E(X,1,30),DA(1),DA) "^DD",22706.9,22706.914,.01,1,2,"%D",0) ^^2^2^3060921^^ "^DD",22706.9,22706.914,.01,1,2,"%D",1,0) This is a cross reference between records in TMG FDA IMPORT COMPILED "^DD",22706.9,22706.914,.01,1,2,"%D",2,0) (the data from the FDA database) and records in the VA PRODUCT file "^DD",22706.9,22706.914,.01,1,2,"DT") 3060921 "^DD",22706.9,22706.914,.01,"DT") 3061120 "^DD",22706.9,22706.915,0) VA PRODUCT POSSIBLE MATCHES SUB-FIELD^^.01^1 "^DD",22706.9,22706.915,0,"DT") 3060318 "^DD",22706.9,22706.915,0,"IX","B",22706.915,.01) "^DD",22706.9,22706.915,0,"NM","VA PRODUCT POSSIBLE MATCHES") "^DD",22706.9,22706.915,0,"UP") 22706.9 "^DD",22706.9,22706.915,.01,0) POSS MATCH^P50.68'^PSNDF(50.68,^0;1^Q "^DD",22706.9,22706.915,.01,1,0) ^.1 "^DD",22706.9,22706.915,.01,1,1,0) 22706.915^B "^DD",22706.9,22706.915,.01,1,1,1) S ^TMG(22706.9,DA(1),3,"B",$E(X,1,30),DA)="" "^DD",22706.9,22706.915,.01,1,1,2) K ^TMG(22706.9,DA(1),3,"B",$E(X,1,30),DA) "^DD",22706.9,22706.915,.01,"DT") 3060324 "^DD",22706.9,22706.916,0) INGREDIENTS SUB-FIELD^^5^4 "^DD",22706.9,22706.916,0,"DT") 3060318 "^DD",22706.9,22706.916,0,"IX","B",22706.916,.01) "^DD",22706.9,22706.916,0,"IX","C",22706.916,2) "^DD",22706.9,22706.916,0,"NM","INGREDIENTS") "^DD",22706.9,22706.916,0,"UP") 22706.9 "^DD",22706.9,22706.916,.01,0) NUMBER^NJ3,0^^0;1^K:+X'=X!(X>999)!(X<0)!(X?.E1"."1.N) X "^DD",22706.9,22706.916,.01,1,0) ^.1 "^DD",22706.9,22706.916,.01,1,1,0) 22706.916^B "^DD",22706.9,22706.916,.01,1,1,1) S ^TMG(22706.9,DA(1),4,"B",$E(X,1,30),DA)="" "^DD",22706.9,22706.916,.01,1,1,2) K ^TMG(22706.9,DA(1),4,"B",$E(X,1,30),DA) "^DD",22706.9,22706.916,.01,1,2,0) 22706.9^TMG "^DD",22706.9,22706.916,.01,1,2,1) S ^TMG(22706.9,"TMG",$E(X,1,30),DA(1),DA)="" "^DD",22706.9,22706.916,.01,1,2,2) K ^TMG(22706.9,"TMG",$E(X,1,30),DA(1),DA) "^DD",22706.9,22706.916,.01,1,2,"DT") 3060323 "^DD",22706.9,22706.916,.01,3) Type a number between 0 and 999, 0 Decimal Digits "^DD",22706.9,22706.916,.01,"DT") 3060323 "^DD",22706.9,22706.916,2,0) INGREDIENT^P50.416'^PS(50.416,^0;3^Q "^DD",22706.9,22706.916,2,1,0) ^.1 "^DD",22706.9,22706.916,2,1,1,0) 22706.916^C "^DD",22706.9,22706.916,2,1,1,1) S ^TMG(22706.9,DA(1),4,"C",$E(X,1,30),DA)="" "^DD",22706.9,22706.916,2,1,1,2) K ^TMG(22706.9,DA(1),4,"C",$E(X,1,30),DA) "^DD",22706.9,22706.916,2,1,1,"DT") 3060820 "^DD",22706.9,22706.916,2,"DT") 3060820 "^DD",22706.9,22706.916,3,0) STRENGTH^F^^0;4^K:$L(X)>16!($L(X)<1) X "^DD",22706.9,22706.916,3,3) Answer must be 1-16 characters in length "^DD",22706.9,22706.916,3,"DT") 3060318 "^DD",22706.9,22706.916,5,0) UNIT^P50.607'^PS(50.607,^0;6^Q "^DD",22706.9,22706.916,5,"DT") 3060318 "^DIC",8925.1,8925.1,0) TIU DOCUMENT DEFINITION^8925.1 "^DIC",8925.1,8925.1,0,"GL") ^TIU(8925.1, "^DIC",8925.1,8925.1,"%",0) ^1.005^2^1 "^DIC",8925.1,8925.1,"%",2,0) GMTS "^DIC",8925.1,8925.1,"%","B","GMTS",2) "^DIC",8925.1,8925.1,"%D",0) ^^76^76^2970604^^^ "^DIC",8925.1,8925.1,"%D",1,0) This file stores Document Definitions, which identify and define behavior "^DIC",8925.1,8925.1,"%D",2,0) for documents stored in the TIU DOCUMENTS FILE (#8925). For consistency "^DIC",8925.1,8925.1,"%D",3,0) with the V-file schema, it may be viewed as the "Attribute Dictionary" for "^DIC",8925.1,8925.1,"%D",4,0) the Text Integration Utilities. "^DIC",8925.1,8925.1,"%D",5,0) "^DIC",8925.1,8925.1,"%D",6,0) It also stores Objects, which can be embedded in a Document Definition's "^DIC",8925.1,8925.1,"%D",7,0) Boilerplate Text (Overprint). Objects contain M code which gets a piece of "^DIC",8925.1,8925.1,"%D",8,0) data and inserts it in the document's Boilerplate Text when a document is "^DIC",8925.1,8925.1,"%D",9,0) entered. "^DIC",8925.1,8925.1,"%D",10,0) "^DIC",8925.1,8925.1,"%D",11,0) Warning: objects embedded in boilerplate text are looked up by multiple "^DIC",8925.1,8925.1,"%D",12,0) index (i.e. DIC(0) contains 'M'). Current code (see routine CHECK^TIUFLF3) "^DIC",8925.1,8925.1,"%D",13,0) checks all present indexes to make sure object names, abbreviations and "^DIC",8925.1,8925.1,"%D",14,0) print names are not ambiguous for this lookup. If new indexes are added, "^DIC",8925.1,8925.1,"%D",15,0) this code MUST BE UPDATED to check the new index as well. "^DIC",8925.1,8925.1,"%D",16,0) "^DIC",8925.1,8925.1,"%D",17,0) Some entries in this file are developed Nationally and exported across the "^DIC",8925.1,8925.1,"%D",18,0) country. Others are created by local sites. Entries in the first "^DIC",8925.1,8925.1,"%D",19,0) category are marked National Standard and are not editable by sites. "^DIC",8925.1,8925.1,"%D",20,0) "^DIC",8925.1,8925.1,"%D",21,0) This file does NOT allow multiple entries OF THE SAME TYPE with the same "^DIC",8925.1,8925.1,"%D",22,0) name. That is, within a given Type, there are no duplicate names. (This "^DIC",8925.1,8925.1,"%D",23,0) refers to the .01 field, the Technical name of the entry.) "^DIC",8925.1,8925.1,"%D",24,0) "^DIC",8925.1,8925.1,"%D",25,0) This file does not allow a parent to have items with the same name, even "^DIC",8925.1,8925.1,"%D",26,0) if the items have different internal file numbers (i.e. are different file "^DIC",8925.1,8925.1,"%D",27,0) entries). Again, this refers to the .01 Technical name of the entry. "^DIC",8925.1,8925.1,"%D",28,0) "^DIC",8925.1,8925.1,"%D",29,0) Because of ownership considerations, the file does NOT allow an entry to "^DIC",8925.1,8925.1,"%D",30,0) be an item under more than 1 parent. If the same item is desired under "^DIC",8925.1,8925.1,"%D",31,0) more than 1 parent, the item must be copied into a new entry. There is "^DIC",8925.1,8925.1,"%D",32,0) one exception: Document Definitions of Type Component which have been "^DIC",8925.1,8925.1,"%D",33,0) marked Shared may have more than one parent. "^DIC",8925.1,8925.1,"%D",34,0) "^DIC",8925.1,8925.1,"%D",35,0) The Document Definition Utility TIUF categorizes certain fields as Basic, "^DIC",8925.1,8925.1,"%D",36,0) Technical, or Upload, and displays these fields together as a group when "^DIC",8925.1,8925.1,"%D",37,0) user edits or views a Document Definition. BASIC fields include Name, "^DIC",8925.1,8925.1,"%D",38,0) Abbreviation, Print Name, Type, Personal Owner, Class Owner, Status, In "^DIC",8925.1,8925.1,"%D",39,0) Use, Shared, Orphan, Has Boiltxt, National Standard, OK to Distribute, and "^DIC",8925.1,8925.1,"%D",40,0) Suppress Visit Selection. TECHNICAL fields include Entry Action, Exit "^DIC",8925.1,8925.1,"%D",41,0) Action, Edit Template, Print Method, Print Form Header, Print Form Number, "^DIC",8925.1,8925.1,"%D",42,0) Print Group, Allow Custom Form Headers, Visit Linkage Method, Validation "^DIC",8925.1,8925.1,"%D",43,0) Method, and Object Method. UPLOAD fields include Upload Target File, Laygo "^DIC",8925.1,8925.1,"%D",44,0) Allowed, Target Text Field Subscript, Upload Look-up Method, Upload "^DIC",8925.1,8925.1,"%D",45,0) Post-Filing Code, Upload Filing Error Code, and multiples Upload Captioned "^DIC",8925.1,8925.1,"%D",46,0) ASCII Header and Upload Delimited ASCII Header. "^DIC",8925.1,8925.1,"%D",47,0) "^DIC",8925.1,8925.1,"%D",48,0) The Document Definition file contains extensive, detailed field "^DIC",8925.1,8925.1,"%D",49,0) descriptions. Likewise, some protocols (File 101) used in TIU have "^DIC",8925.1,8925.1,"%D",50,0) extensive and careful descriptions in the Protocol file. Many of these "^DIC",8925.1,8925.1,"%D",51,0) descriptions are used in TIU for online help. If it becomes necessary for "^DIC",8925.1,8925.1,"%D",52,0) a national programmer to edit these descriptions, the programmer should "^DIC",8925.1,8925.1,"%D",53,0) check to make sure all online help is still displayed properly. "^DIC",8925.1,8925.1,"%D",54,0) "^DIC",8925.1,8925.1,"%D",55,0) Users are expected to use the Document Definition Utility TIUF to enter, "^DIC",8925.1,8925.1,"%D",56,0) edit, and delete file entries. In fact, the file prohibits the deletion "^DIC",8925.1,8925.1,"%D",57,0) of entries through generic Fileman Options. It also prohibits the edit "^DIC",8925.1,8925.1,"%D",58,0) through generic Fileman of a few critical fields: Type, Status, Shared, "^DIC",8925.1,8925.1,"%D",59,0) and National Standard. Adding and Deleting (but not editing) Items is "^DIC",8925.1,8925.1,"%D",60,0) also prohibited through generic Fileman options. Abbreviation and Print "^DIC",8925.1,8925.1,"%D",61,0) Name of OBJECTS cannot be edited through generic Fileman Options. "^DIC",8925.1,8925.1,"%D",62,0) "^DIC",8925.1,8925.1,"%D",63,0) This does NOT imply that it is SAFE to use generic Fileman to edit other "^DIC",8925.1,8925.1,"%D",64,0) fields. Users are cautioned that edit through generic Fileman bypasses "^DIC",8925.1,8925.1,"%D",65,0) many safeguards built in to the Document Definition Utility and can create "^DIC",8925.1,8925.1,"%D",66,0) havoc unless the user THOROUGHLY UNDERSTANDS the File and its uses. "^DIC",8925.1,8925.1,"%D",67,0) "^DIC",8925.1,8925.1,"%D",68,0) If users find needs which are not met through TIUF, please communicate "^DIC",8925.1,8925.1,"%D",69,0) them to the TIU development team. "^DIC",8925.1,8925.1,"%D",70,0) "^DIC",8925.1,8925.1,"%D",71,0) ***************** "^DIC",8925.1,8925.1,"%D",72,0) "^DIC",8925.1,8925.1,"%D",73,0) WARNING: Using generic Fileman options to edit entries can cause SERIOUS "^DIC",8925.1,8925.1,"%D",74,0) database problems. "^DIC",8925.1,8925.1,"%D",75,0) "^DIC",8925.1,8925.1,"%D",76,0) **************** "^DIC",8925.1,"B","TIU DOCUMENT DEFINITION",8925.1) "^DIC",22706.1,22706.1,0) TMG FDA APPLICATION^22706.1 "^DIC",22706.1,22706.1,0,"GL") ^TMG(22706.1, "^DIC",22706.1,"B","TMG FDA APPLICATION",22706.1) "^DIC",22706.2,22706.2,0) TMG FDA DOSAGE FORM^22706.2 "^DIC",22706.2,22706.2,0,"GL") ^TMG(22706.2, "^DIC",22706.2,"B","TMG FDA DOSAGE FORM",22706.2) "^DIC",22706.3,22706.3,0) TMG FDA FIRMS^22706.3 "^DIC",22706.3,22706.3,0,"GL") ^TMG(22706.3, "^DIC",22706.3,"B","TMG FDA FIRMS",22706.3) "^DIC",22706.4,22706.4,0) TMG FDA FORMULATION^22706.4 "^DIC",22706.4,22706.4,0,"GL") ^TMG(22706.4, "^DIC",22706.4,22706.4,"%",0) ^1.005^^ "^DIC",22706.4,"B","TMG FDA FORMULATION",22706.4) "^DIC",22706.5,22706.5,0) TMG FDA LISTING^22706.5 "^DIC",22706.5,22706.5,0,"GL") ^TMG(22706.5, "^DIC",22706.5,"B","TMG FDA LISTING",22706.5) "^DIC",22706.6,22706.6,0) TMG FDA PACKAGES^22706.6 "^DIC",22706.6,22706.6,0,"GL") ^TMG(22706.6, "^DIC",22706.6,"B","TMG FDA PACKAGES",22706.6) "^DIC",22706.7,22706.7,0) TMG FDA ROUTES^22706.7 "^DIC",22706.7,22706.7,0,"GL") ^TMG(22706.7, "^DIC",22706.7,"B","TMG FDA ROUTES",22706.7) "^DIC",22706.8,22706.8,0) TMG FDA FORMS VISTA EQUIVALENTS^22706.8 "^DIC",22706.8,22706.8,0,"GL") ^TMG(22706.8, "^DIC",22706.8,22706.8,"%",0) ^1.005^^ "^DIC",22706.8,22706.8,"%D",0) ^1.001^3^3^3070126^^^ "^DIC",22706.8,22706.8,"%D",1,0) This file will hold linkages between FDA units and equivalents entries in "^DIC",22706.8,22706.8,"%D",2,0) file 50.607 (DRUG UNITS) "^DIC",22706.8,22706.8,"%D",3,0) ) "^DIC",22706.8,"B","TMG FDA FORMS VISTA EQUIVALENTS",22706.8) "^DIC",22706.82,22706.82,0) TMG FDA ROUTES VISTA EQUIVALENTS^22706.82 "^DIC",22706.82,22706.82,0,"GL") ^TMG(22706.82, "^DIC",22706.82,"B","TMG FDA ROUTES VISTA EQUIVALENTS",22706.82) "^DIC",22706.9,22706.9,0) TMG FDA IMPORT COMPILED^22706.9 "^DIC",22706.9,22706.9,0,"GL") ^TMG(22706.9, "^DIC",22706.9,22706.9,"%D",0) ^1.001^3^3^3071101^^^^ "^DIC",22706.9,22706.9,"%D",1,0) This file holds a compilation of the individual files put out by the FDA. "^DIC",22706.9,22706.9,"%D",2,0) After the data in the various files has been compiled into this file, it "^DIC",22706.9,22706.9,"%D",3,0) is then used to populate VistA drug files. "^DIC",22706.9,"B","TMG FDA IMPORT COMPILED",22706.9) **END** **END**