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","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 "
",!
"RTN","TMGHTML1",368,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)
;;