iSharkFly-Open
/
VistA-BMXNET_RPMS_dotNET_UTILITIES-BMX
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial Import of BMX.net code

This commit is contained in:
sam 2009-12-07 19:21:15 +00:00
commit 782d05d287
69 changed files with 34908 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
cs/BMXNet20.dll Normal file
View File

Binary file not shown.

96
cs/bmxTesterForVista_0200.cs Executable file
View File

@ -0,0 +1,96 @@
using System;
using IndianHealthService.BMXNet;
namespace SamsStuff.IHS.BMX
{
class MyFirstApp
{
static void Main()
{
BMXNetLib ConnectionManager = new BMXNetLib();
Console.Write("Enter IP Address of Server: ");
string ip = Console.ReadLine();
Console.Write("Enter the listener port: ");
string port = Console.ReadLine();
int portno = int.Parse(port);
Console.Write("Enter your Access Code: ");
string accessCode = Console.ReadLine();
Console.Write("Enter your Verify Code: ");
string verifyCode = Console.ReadLine();
ConnectionManager.MServerPort = portno;
bool success = ConnectionManager.OpenConnection(ip, accessCode, verifyCode);
Console.WriteLine("Connected: " + success.ToString() + " DUZ: " + ConnectionManager.DUZ);
ConnectionManager.AppContext = "BMXRPC";
string result = ConnectionManager.TransmitRPC("BMX USER", ConnectionManager.DUZ);
Console.WriteLine("Simple RPC: User Name: " + result);
ConnectionManager.AppContext = "OR CPRS GUI CHART";
result = ConnectionManager.TransmitRPC("ORWU NEWPERS","A^1");
Console.WriteLine("CPRS RPC with Parameters: ");
Console.WriteLine(result);
Console.WriteLine();
Console.WriteLine("SQL Statement");
string cmd = "SELECT NAME,SEX,DATE_OF_BIRTH FROM PATIENT";
RPMSDb dbTables = new RPMSDb(ConnectionManager);
RPMSDb.RPMSDbResultSet rs = new RPMSDb.RPMSDbResultSet();
dbTables.Execute(cmd, out rs);
for (int i = 0; i < rs.data.GetLength(0); i++ )
for (int j = 0; j < rs.data.GetLength(1); j++)
{
Console.WriteLine(rs.data[i, j].ToString());
}
Console.WriteLine();
Console.WriteLine("BMX Schema RPC");
ConnectionManager.AppContext = "BMXRPC";
BMXNetConnection conn = new BMXNetConnection(ConnectionManager);
BMXNetCommand cmd2 = (BMXNetCommand) conn.CreateCommand();
cmd2.CommandText = "BMX DEMO^S^10";
BMXNetDataAdapter da = new BMXNetDataAdapter();
da.SelectCommand = cmd2;
System.Data.DataSet ds = new System.Data.DataSet();
da.Fill(ds,"BMXNetTable1");
System.Data.DataTable dt = new System.Data.DataTable();
dt = ds.Tables["BMXNetTable1"];
System.Text.StringBuilder sb = new System.Text.StringBuilder();
for (int i = 0; i < dt.Rows.Count; i++)
{
for (int j = 0; j < dt.Columns.Count; j++)
{
sb.Append(dt.Rows[i][j]);
sb.Append("\t");
}
sb.Append("\n");
}
Console.WriteLine();
Console.Write(sb);
Console.WriteLine();
Console.WriteLine("More complicated SQL\n");
BMXNetCommand cmd3 = (BMXNetCommand)conn.CreateCommand();
cmd3.CommandText = @"SELECT PATIENT.NAME 'NAME', PATIENT.STATE 'STATE',
STATE.ABBREVIATION 'ABBR', PATIENT.AGE 'AGE' FROM PATIENT, STATE
WHERE INTERNAL[PATIENT.STATE] = STATE.BMXIEN MAXRECORDS:5";
da.SelectCommand = cmd3;
da.Fill(ds, "BMXNetTable2");
System.Data.DataTable dt2 = new System.Data.DataTable();
dt2 = ds.Tables["BMXNetTable2"];
System.Text.StringBuilder sb2 = new System.Text.StringBuilder();
for (int i = 0; i < dt2.Columns.Count; i++)
{
sb2.Append(dt2.Columns[i].ColumnName);
sb2.Append("\t");
}
sb2.Append("\n");
for (int i = 0; i < dt2.Rows.Count; i++)
{
for (int j = 0; j < dt2.Columns.Count; j++)
{
sb2.Append(dt2.Rows[i][j]);
sb2.Append("\t");
}
sb2.Append("\n");
}
Console.Write(sb2);
Console.ReadKey();
ConnectionManager.CloseConnection();
}
}
}

BIN
cs/bmxTesterForVista_0200.exe Executable file
View File

Binary file not shown.

388
doc/bmx0210.n Normal file
View File

@ -0,0 +1,388 @@
Release notes for BMX 2.1 - released July 22, 2009
*** IMPORTANT ***
DO NOT INSTALL ON RPMS. THIS RELEASE IS FOR VISTA SYSTEMS!
*****************
BMX.net is a broker and a software library that allows programs in .net to communicate with Vista. BMX.net support regular RPC's, SQL statements, and ADO.net updatable datasets. The user is referred to Indian Health Service's documentation for BMX:
- Installation manual for Cache 5.x and above: http://www.ihs.gov/Cio/RPMS/PackageDocs/bmx/bmx_020i.pdf
- Programming manual: http://www.ihs.gov/Cio/RPMS/PackageDocs/bmx/bmx_020u.pdf
- Technical manual: http://www.ihs.gov/Cio/RPMS/PackageDocs/bmx/bmx_020t.pdf
Release 2.1 adds support for GT.M.
*** IMPORTANT ***
BMX support for GT.M uses xinetd listeners; not listeners managed by the Mumps environment. As such, the installation instructions provided by IHS won't work for GT.M.
*****************
Pre-requisites:
Fileman v22
Kernel v8
XB/ZIB v3
XWB 1.1 patch 100001 (optional - to enable a unified listener for all brokers)
Pre-requisites are examined by the environment check routine.
Installation Instructions
=========================
Installation of BMX.net 2.1 consists of 6 steps.
1. Install BMX in Vista
2. Install Xinetd
3. Configure listener in Xinetd
4. Configure shell script that that is called by Xinetd
5. Users who don't hold XUPROGMODE will need BMXPRC assigned as an option. If you assign it as part of their primary menu, make sure to rebuild the menu before proceeding.
6. (optional) Install XWB 1.1 patch 100001
1. Install BMX in Vista
=========================
GTM>s DUZ=9 D ^XUP
Setting up programmer environment
This is a TEST account.
Terminal Type set to: C-VT100
You have 46 new messages.
Select OPTION NAME: xpd main Kernel Installation & Distribution System
Edits and Distribution ...
Utilities ...
Installation ...
Patch Monitor Main Menu ...
Select Kernel Installation & Distribution System Option: INStallation
1 Load a Distribution
2 Verify Checksums in Transport Global
3 Print Transport Global
4 Compare Transport Global to Current System
5 Backup a Transport Global
6 Install Package(s)
Restart Install of Package(s)
Unload a Distribution
Checksum/2nd Line Lists
Directory Listing to MailMan
Find/Delete File in Download Directory
Select Installation Option: 1 Load a Distribution
Enter a Host File: /opt/wv/k/bmx0210.k
KIDS Distribution saved on Jul 22, 2009@13:07:52
Comment: BMX.net 2.1; add support for GT.M
This Distribution contains Transport Globals for the following Package(s):
BMX 2.1
Distribution OK!
Want to Continue with Load? YES//
Loading Distribution...
Build BMX 2.1 has an Enviromental Check Routine
Want to RUN the Environment Check Routine? YES//
BMX 2.1
Will first run the Environment Check Routine, BMXE01
Hello, FIVE COORDINATOR
Checking Environment for Install of Version 2.0 of BMX.
Need at least FileMan 22.....FileMan 22.0 Present
Need at least Kernel 8.0.....Kernel 8.0 Present
Need at least XB/ZIB 3.....XB/ZIB 4.0 Present
Use INSTALL NAME: BMX 2.1 to install this Distribution.
1 Load a Distribution
2 Verify Checksums in Transport Global
3 Print Transport Global
4 Compare Transport Global to Current System
5 Backup a Transport Global
6 Install Package(s)
Restart Install of Package(s)
Unload a Distribution
Checksum/2nd Line Lists
Directory Listing to MailMan
Find/Delete File in Download Directory
Select Installation Option: 6 Install Package(s)
Select INSTALL NAME: BMX 2.1 Loaded from Distribution Loaded from Dis
tribution 7/22/09@13:22:57
=> BMX.net 2.1; add support for GT.M ;Created on Jul 22, 2009@13:07:52
This Distribution was loaded on Jul 22, 2009@13:22:57 with header of
BMX.net 2.1; add support for GT.M ;Created on Jul 22, 2009@13:07:52
It consisted of the following Install(s):
BMX 2.1
Checking BMX 2.1 for overlap with VOE 1.0 ...... OK
No overlap found
Checking BMX 2.1 for overlap with VOE 1.1 ...... OK
No overlap found
Checking BMX 2.1 for overlap with NO HOME 1.0 ...... OK
No overlap found
Checking Install for Package BMX 2.1
Will first run the Environment Check Routine, BMXE01
Hello, FIVE COORDINATOR
Checking Environment for Install of Version 2.0 of BMX.
Need at least FileMan 22.....FileMan 22.0 Present
Need at least Kernel 8.0.....Kernel 8.0 Present
Need at least XB/ZIB 3.....XB/ZIB 4.0 Present
Install Questions for BMX 2.1
Incoming Files:
90093.1 BMX USER
90093.2 BMX APPLICATION
90093.5 BMXNET MONITOR
90093.9 BMX GUI REPORT
90093.98 BMX ADO LOG
90093.99 BMX ADO SCHEMA (including data)
Want KIDS to Rebuild Menu Trees Upon Completion of Install? NO//
Want KIDS to INHIBIT LOGONs during the install? NO//
Want to DISABLE Scheduled Options, Menu Options, and Protocols? NO//
Enter the Device you want to print the Install messages.
Enter a '^' to abort the install.
DEVICE: HOME// ;80;999999
<compilation errors pass by -- that's normal>
Install Completed
2. Install Xinetd
=================
User is referred to their OS's documentation
3. Configure listener in Xinetd
===============================
Create a file in /etc/xinetd.d, with whatever name you like. I called mine BMX10502, because that's the port I am going to use. Here are the contents (don't include my comments)
service BMX10502
{
socket_type = stream
type = UNLISTED
port = 10502 (that can be whatever you want it to be)
protocol = tcp
user = xxxxxxxx (that's a unix user who has access to run GT.M)
wait = no
disable = no
server = /bin/sh
server_args = /opt/wv2/BMX10502 (that's the location of the script that this listener will launch when it gets a TCP call on 10502)
}
4. Configure shell script that that is called by Xinetd
=======================================================
Create a script that looks like this.
The essential lines are the ones defining gtm_dist, gtmgbldir, gtmroutines, and $gtm_dist/mumps - run XINETD^BMXMON. XINETD^BMXMON is the entry point responsible for receiving TCP calls from XINETD.
#!/bin/bash
# BMX Broker started by Xinet.d
cd /opt/wv2
date >> /opt/wv2/bmx.log
# Get GT.M profile
export vista_home="/opt/wv2"
export gtm_dist="/opt/gtm"
export gtmgbldir="$vista_home/g/mumps.gld"
export gtmroutines="$vista_home/o($vista_home/p) $vista_home/o($vista_home/r) $gtm_dist"
# Run
$gtm_dist/mumps -run XINETD^BMXMON 2>>/opt/wv2/bmx.log
exit
Note: If you install XWB 1.1 patch 100001, you can use the CPRS listener. XWBTCPM will decide which protocol it is and route it accordingly.
5. Add BMXRPC to the user's menu
================================
GTM>D P^DI
VA FileMan 22.0
Select OPTION: ENTER OR EDIT FILE ENTRIES
INPUT TO WHAT FILE: PACKAGE// 200 NEW PERSON (77 entries)
EDIT WHICH FIELD: ALL// SECONDARY MENU OPTIONS (multiple)
EDIT WHICH SECONDARY MENU OPTIONS SUB-FIELD: ALL// .01 SECONDARY MENU OPTION
S
THEN EDIT SECONDARY MENU OPTIONS SUB-FIELD:
THEN EDIT FIELD:
Select NEW PERSON NAME: CLERK,EIGHT Medical Clerk
Select SECONDARY MENU OPTIONS: OR CPRS GUI CHART//
SECONDARY MENU OPTIONS: OR CPRS GUI CHART//
Select SECONDARY MENU OPTIONS: BMXRPC BMX Procedure Calls
Are you adding 'BMXRPC' as a new SECONDARY MENU OPTIONS (the 2ND for this NEW
PERSON)? No// Y (Yes)
Select SECONDARY MENU OPTIONS:
6. (optional) Install XWB 1.1 patch 100001
==========================================
This patch allows you to use the CPRS listener for BMX.
GTM>d ^XPDIL
Enter a Host File: /opt/wv/k/xwb0110_100001.k
KIDS Distribution saved on Jul 22, 2009@13:55:06
Comment: XWB patch to support BMX.net calls
This Distribution contains Transport Globals for the following Package(s):
XWB*1.1*100001
Distribution OK!
Want to Continue with Load? YES//
Loading Distribution...
XWB*1.1*100001
Use INSTALL NAME: XWB*1.1*100001 to install this Distribution.
GTM>d ^XPDI
Select INSTALL NAME: XWB*1.1*100001 Loaded from Distribution Loaded f
rom Distribution 7/22/09@13:56:39
=> XWB patch to support BMX.net calls ;Created on Jul 22, 2009@13:55:06
This Distribution was loaded on Jul 22, 2009@13:56:39 with header of
XWB patch to support BMX.net calls ;Created on Jul 22, 2009@13:55:06
It consisted of the following Install(s):
XWB*1.1*100001
Checking XWB*1.1*100001 for overlap with VOE 1.0 .. OK
No overlap found
Install Completed.
TESTING BMX.net
===============
In the package, there is a C# file called bmxTesterForVista_0200.cs and a .Net dll called BMXNet20.dll.
To compile the file on Mono, use the generics Mono C# compiler (gmcs), referencing BMXNet20.dll and System.Data.dll. To compile on Windows, use csc with the same arguments.
gmcs /r:BMXNet20.dll,System.Data.dll bmxTesterForVista_0200.cs
Then you can execute it:
mono bmxTesterForVista_0200.exe
Enter IP Address of Server: 127.0.0.1
Enter the listener port: 9260
Enter your Access Code: vistais#1
Enter your Verify Code: catdog.22
Connected: True DUZ: 47
Simple RPC: User Name: CLERK,EIGHT
CPRS RPC with Parameters:
14^Administrator,System
65^Analyst,One^- ANALYST
66^Analyst,Three^- ANALYST
69^Analyst,Two^- ANALYST
47^Clerk,Eight^- Medical Clerk
50^Clerk,Eleven^- Medical Clerk
54^Clerk,Fifteen^- Medical Clerk
44^Clerk,Five^- Medical Clerk
43^Clerk,Four^- Medical Clerk
53^Clerk,Fourteen^- Medical Clerk
48^Clerk,Nine^- Medical Clerk
46^Clerk,Seven^- Medical Clerk
45^Clerk,Six^- Medical Clerk
49^Clerk,Ten^- Medical Clerk
52^Clerk,Thirteen^- Medical Clerk
42^Clerk,Three^- Medical Clerk
51^Clerk,Twelve^- Medical Clerk
41^Clerk,Two^- Medical Clerk
58^Coordinator,Clinical^- CLINICAL COORDINATOR
9^Coordinator,Five^- ANALYST
3^Coordinator,Four
2^Coordinator,Nine
63^Coordinator,One^- ANALYST
64^Coordinator,Seven
60^Coordinator,Six^- CLINICAL COORDINATOR
67^Coordinator,Three^- ANALYST
68^Coordinator,Two^- ANALYST
21^Doctor,Eight^- Physician
24^Doctor,Eleven^- Physician
18^Doctor,Five^- Physician
17^Doctor,Four^- Physician
22^Doctor,Nine^- Physician
11^Doctor,One^- Physician
20^Doctor,Seven^- Physician
19^Doctor,Six^- Physician
23^Doctor,Ten^- Physician
16^Doctor,Three^- Physician
26^Doctor,Twelve^- Physician
15^Doctor,Two^- Physician
62^Lab,Superuser^- ANALYST
8^Manager,System^- System Manager
33^Nurse,Eight^- Nurse
36^Nurse,Eleven^- Nurse
40^Nurse,Fifteen^- Nurse
SQL Statement
ZZ PATIENT,TEST ONE
FEMALE
1/24/1945 12:00:00 AM
ZZ PATIENT,TEST THREE
MALE
1/15/1968 12:00:00 AM
ZZ PATIENT,TEST TWO
MALE
12/25/1957 12:00:00 AM
BMX Schema RPC
ZZ PATIENT,TEST ONEF1/24/1945 12:00:00 AM
ZZ PATIENT,TEST THREEM1/15/1968 12:00:00 AM
ZZ PATIENT,TEST TWOM12/25/1957 12:00:00 AM
More complicated SQL
NAMESTATEABBRAGE
ZZ PATIENT,TEST ONENEW YORKNY64
ZZ PATIENT,TEST THREEINDIANAIN41
ZZ PATIENT,TEST TWOKANSASKS51
If this doesn't work, you will get error messages like this:
Unhandled Exception: IndianHealthService.BMXNet.BMXNetException: Connection refused at System.Net.Sockets.Socket.Connect (System.Net.EndPoint remote_end) [0x00000]
at System.Net.Sockets.TcpClient.Connect (System.Net.IPEndPoint remote_end_point) [0x00000]
at System.Net.Sockets.TcpClient.Connect (System.Net.IPAddress[] ipAddresses, Int32 port) [0x00000]
at IndianHealthService.BMXNet.BMXNetLib.a (System.String A_0) [0x00000]
You may get Connection refused; connection timed out, not a valid access/verify code, verify code must be changed now, and User doesn't have access to Context BMXRPC, etc.

BIN
doc/bmx_020i.pdf Normal file
View File

Binary file not shown.

BIN
doc/bmx_020t.pdf Normal file
View File

Binary file not shown.

BIN
doc/bmx_020u.pdf Normal file
View File

Binary file not shown.

23582
k/bmx0210t2WV.k Normal file
View File

File diff suppressed because it is too large Load Diff

706
k/xwb_0110_113102.k Normal file
View File

@ -0,0 +1,706 @@
KIDS Distribution saved on Dec 07, 2009@11:11:21
Modified XWB Routine to correct $$OS bug and support BMX.net
**KIDS**:XWB*1.1*113102^
**INSTALL NAME**
XWB*1.1*113102
"BLD",7415,0)
XWB*1.1*113102^RPC BROKER^0^3091207^n
"BLD",7415,1,0)
^9.61A^9^9^3091207^^
"BLD",7415,1,1,0)
This patch adds support to XWB of routing BMX Broker messages to the
"BLD",7415,1,2,0)
BMXMON routine. As such, it provides a uniform entry point for all broker
"BLD",7415,1,3,0)
messaging.
"BLD",7415,1,4,0)
"BLD",7415,1,5,0)
Produced on July 22 2009 by Sam Habiel for WorldVista.
"BLD",7415,1,6,0)
"BLD",7415,1,7,0)
Licensed under WorldVista global license, currently GPL 2.
"BLD",7415,1,8,0)
"BLD",7415,1,9,0)
**updated on Aug 29th to handle IPv6 addresses for GT.M**
"BLD",7415,4,0)
^9.64PA^^
"BLD",7415,6.3)
6
"BLD",7415,"KRN",0)
^9.67PA^8989.52^19
"BLD",7415,"KRN",.4,0)
.4
"BLD",7415,"KRN",.401,0)
.401
"BLD",7415,"KRN",.402,0)
.402
"BLD",7415,"KRN",.403,0)
.403
"BLD",7415,"KRN",.5,0)
.5
"BLD",7415,"KRN",.84,0)
.84
"BLD",7415,"KRN",3.6,0)
3.6
"BLD",7415,"KRN",3.8,0)
3.8
"BLD",7415,"KRN",9.2,0)
9.2
"BLD",7415,"KRN",9.8,0)
9.8
"BLD",7415,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",7415,"KRN",9.8,"NM",1,0)
XWBTCPM^^0^B56820596
"BLD",7415,"KRN",9.8,"NM","B","XWBTCPM",1)
"BLD",7415,"KRN",19,0)
19
"BLD",7415,"KRN",19.1,0)
19.1
"BLD",7415,"KRN",101,0)
101
"BLD",7415,"KRN",409.61,0)
409.61
"BLD",7415,"KRN",771,0)
771
"BLD",7415,"KRN",870,0)
870
"BLD",7415,"KRN",8989.51,0)
8989.51
"BLD",7415,"KRN",8989.52,0)
8989.52
"BLD",7415,"KRN",8994,0)
8994
"BLD",7415,"KRN","B",.4,.4)
"BLD",7415,"KRN","B",.401,.401)
"BLD",7415,"KRN","B",.402,.402)
"BLD",7415,"KRN","B",.403,.403)
"BLD",7415,"KRN","B",.5,.5)
"BLD",7415,"KRN","B",.84,.84)
"BLD",7415,"KRN","B",3.6,3.6)
"BLD",7415,"KRN","B",3.8,3.8)
"BLD",7415,"KRN","B",9.2,9.2)
"BLD",7415,"KRN","B",9.8,9.8)
"BLD",7415,"KRN","B",19,19)
"BLD",7415,"KRN","B",19.1,19.1)
"BLD",7415,"KRN","B",101,101)
"BLD",7415,"KRN","B",409.61,409.61)
"BLD",7415,"KRN","B",771,771)
"BLD",7415,"KRN","B",870,870)
"BLD",7415,"KRN","B",8989.51,8989.51)
"BLD",7415,"KRN","B",8989.52,8989.52)
"BLD",7415,"KRN","B",8994,8994)
"BLD",7415,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",7415,"QUES",0)
^9.62^^
"MBREQ")
0
"PKG",70,-1)
1^1
"PKG",70,0)
RPC BROKER^XWB^Remote Procedure Call Broker
"PKG",70,20,0)
^9.402P^^
"PKG",70,22,0)
^9.49I^1^1
"PKG",70,22,1,0)
1.1^3020529^2971118^1
"PKG",70,22,1,"PAH",1,0)
113102^3091207
"PKG",70,22,1,"PAH",1,1,0)
^^9^9^3091207
"PKG",70,22,1,"PAH",1,1,1,0)
This patch adds support to XWB of routing BMX Broker messages to the
"PKG",70,22,1,"PAH",1,1,2,0)
BMXMON routine. As such, it provides a uniform entry point for all broker
"PKG",70,22,1,"PAH",1,1,3,0)
messaging.
"PKG",70,22,1,"PAH",1,1,4,0)
"PKG",70,22,1,"PAH",1,1,5,0)
Produced on July 22 2009 by Sam Habiel for WorldVista.
"PKG",70,22,1,"PAH",1,1,6,0)
"PKG",70,22,1,"PAH",1,1,7,0)
Licensed under WorldVista global license, currently GPL 2.
"PKG",70,22,1,"PAH",1,1,8,0)
"PKG",70,22,1,"PAH",1,1,9,0)
**updated on Aug 29th to handle IPv6 addresses for GT.M**
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")
"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
1
"RTN","XWBTCPM")
0^1^B56820596
"RTN","XWBTCPM",1,0)
XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ; 12/7/09 10:30am
"RTN","XWBTCPM",2,0)
;;1.1;RPC BROKER;**35,43,49**;Mar 28, 1997;Build 6
"RTN","XWBTCPM",3,0)
;Local patch 113102 by WV/SMH for BMX.net support
"RTN","XWBTCPM",4,0)
;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
"RTN","XWBTCPM",5,0)
;Changed to be started by UCX or %ZISTCPS
"RTN","XWBTCPM",6,0)
;
"RTN","XWBTCPM",7,0)
DSM ;DSM called from ucx, % passed in with device.
"RTN","XWBTCPM",8,0)
D ESET
"RTN","XWBTCPM",9,0)
;Open the device
"RTN","XWBTCPM",10,0)
S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
"RTN","XWBTCPM",11,0)
;Go find the connection type
"RTN","XWBTCPM",12,0)
U XWBTDEV
"RTN","XWBTCPM",13,0)
G CONNTYPE
"RTN","XWBTCPM",14,0)
;
"RTN","XWBTCPM",15,0)
CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
"RTN","XWBTCPM",16,0)
D ESET
"RTN","XWBTCPM",17,0)
S XWBTDEV="SYS$NET"
"RTN","XWBTCPM",18,0)
; **Cache'/VMS specific code**
"RTN","XWBTCPM",19,0)
O XWBTDEV::5
"RTN","XWBTCPM",20,0)
X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
"RTN","XWBTCPM",21,0)
G CONNTYPE
"RTN","XWBTCPM",22,0)
;
"RTN","XWBTCPM",23,0)
NT ;entry from ZISTCPS
"RTN","XWBTCPM",24,0)
;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
"RTN","XWBTCPM",25,0)
D ESET
"RTN","XWBTCPM",26,0)
S XWBTDEV=IO
"RTN","XWBTCPM",27,0)
G CONNTYPE
"RTN","XWBTCPM",28,0)
;
"RTN","XWBTCPM",29,0)
GTMUCX(%) ;From ucx ZFOO
"RTN","XWBTCPM",30,0)
;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
"RTN","XWBTCPM",31,0)
D ESET
"RTN","XWBTCPM",32,0)
;GTM specific code
"RTN","XWBTCPM",33,0)
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
"RTN","XWBTCPM",34,0)
S XWBTDEV=% X "O %:(RECORDSIZE=512)"
"RTN","XWBTCPM",35,0)
G CONNTYPE
"RTN","XWBTCPM",36,0)
;
"RTN","XWBTCPM",37,0)
GTMLNX ;From Linux xinetd script
"RTN","XWBTCPM",38,0)
D ESET
"RTN","XWBTCPM",39,0)
;GTM specific code
"RTN","XWBTCPM",40,0)
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
"RTN","XWBTCPM",41,0)
S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
"RTN","XWBTCPM",42,0)
S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
"RTN","XWBTCPM",43,0)
I %["::ffff:" S IO("GTM-IP")=$P(%,"::ffff:",2) ; fake ipv6 support
"RTN","XWBTCPM",44,0)
G CONNTYPE
"RTN","XWBTCPM",45,0)
;
"RTN","XWBTCPM",46,0)
ESET ;Set inital error trap
"RTN","XWBTCPM",47,0)
S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
"RTN","XWBTCPM",48,0)
S X="",@^%ZOSF("TRAP") ;Clear old trap
"RTN","XWBTCPM",49,0)
Q
"RTN","XWBTCPM",50,0)
;Find the type of connection and jump to the processing routine.
"RTN","XWBTCPM",51,0)
CONNTYPE ;
"RTN","XWBTCPM",52,0)
N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
"RTN","XWBTCPM",53,0)
N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
"RTN","XWBTCPM",54,0)
N SOCK,TYPE
"RTN","XWBTCPM",55,0)
D INIT
"RTN","XWBTCPM",56,0)
S XWB=$$BREAD^XWBRW(5,XWBTIME)
"RTN","XWBTCPM",57,0)
D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="{BMX}":"BMX",1:"Unk"))
"RTN","XWBTCPM",58,0)
I XWB["[XWB]" G NEW
"RTN","XWBTCPM",59,0)
I XWB["{XWB}" G OLD^XWBTCPM1
"RTN","XWBTCPM",60,0)
I XWB["<?xml" G M2M
"RTN","XWBTCPM",61,0)
I XWB["{BMX}" G GTMLNX^BMXMON
"RTN","XWBTCPM",62,0)
I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
"RTN","XWBTCPM",63,0)
D LOG("Prefix not known: "_XWB)
"RTN","XWBTCPM",64,0)
Q
"RTN","XWBTCPM",65,0)
;
"RTN","XWBTCPM",66,0)
NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
"RTN","XWBTCPM",67,0)
N X,Y,J,XWBVOL
"RTN","XWBTCPM",68,0)
D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
"RTN","XWBTCPM",69,0)
S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),J=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
"RTN","XWBTCPM",70,0)
I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
"RTN","XWBTCPM",71,0)
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
"RTN","XWBTCPM",72,0)
Q 1
"RTN","XWBTCPM",73,0)
;
"RTN","XWBTCPM",74,0)
M2M ;M2M Broker
"RTN","XWBTCPM",75,0)
S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
"RTN","XWBTCPM",76,0)
Q
"RTN","XWBTCPM",77,0)
;
"RTN","XWBTCPM",78,0)
NEW ;New broker
"RTN","XWBTCPM",79,0)
S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
"RTN","XWBTCPM",80,0)
D SETTIME(1) ;Setup for sign-on timeout
"RTN","XWBTCPM",81,0)
U XWBTDEV D
"RTN","XWBTCPM",82,0)
. N XWB,ERR,NATIP,I
"RTN","XWBTCPM",83,0)
. S ERR=$$PRSP^XWBPRS
"RTN","XWBTCPM",84,0)
. S ERR=$$PRSM^XWBPRS
"RTN","XWBTCPM",85,0)
. S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
"RTN","XWBTCPM",86,0)
. S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
"RTN","XWBTCPM",87,0)
. ;Get the peer and save that IP.
"RTN","XWBTCPM",88,0)
. S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
"RTN","XWBTCPM",89,0)
. I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
"RTN","XWBTCPM",90,0)
. Q
"RTN","XWBTCPM",91,0)
S X=$$NEWJOB() D:'X LOG("No New Connects")
"RTN","XWBTCPM",92,0)
I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
"RTN","XWBTCPM",93,0)
D QSND^XWBRW("accept"),LOG("accept") ;Ack
"RTN","XWBTCPM",94,0)
S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
"RTN","XWBTCPM",95,0)
S XWBTIP=$G(IO("IP"))
"RTN","XWBTCPM",96,0)
;start RUM for Broker Handler XWB*1.1*5
"RTN","XWBTCPM",97,0)
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
"RTN","XWBTCPM",98,0)
;GTM
"RTN","XWBTCPM",99,0)
I $G(XWBT("PCNT")) D
"RTN","XWBTCPM",100,0)
. S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
"RTN","XWBTCPM",101,0)
. D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
"RTN","XWBTCPM",102,0)
;We don't use a callback
"RTN","XWBTCPM",103,0)
K XWB,CON,LEN,MSG ;Clean up
"RTN","XWBTCPM",104,0)
;Attempt to share license, Must have TCP port open first.
"RTN","XWBTCPM",105,0)
U XWBTDEV ;D SHARELIC^%ZOSV(1)
"RTN","XWBTCPM",106,0)
;setup null device "NULL"
"RTN","XWBTCPM",107,0)
S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q
"RTN","XWBTCPM",108,0)
D SAVDEV^%ZISUTL("XWBNULL")
"RTN","XWBTCPM",109,0)
;change process name
"RTN","XWBTCPM",110,0)
D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
"RTN","XWBTCPM",111,0)
;
"RTN","XWBTCPM",112,0)
RESTART ;The error trap returns to here
"RTN","XWBTCPM",113,0)
N $ESTACK S $ETRAP="D ETRAP^XWBTCPM"
"RTN","XWBTCPM",114,0)
S DT=$$DT^XLFDT,DTIME=30
"RTN","XWBTCPM",115,0)
U XWBTDEV D MAIN
"RTN","XWBTCPM",116,0)
D LOG("Exit: "_XWBTBUF)
"RTN","XWBTCPM",117,0)
;Turn off the error trap for the exit
"RTN","XWBTCPM",118,0)
S $ETRAP=""
"RTN","XWBTCPM",119,0)
D EXIT ;Logout
"RTN","XWBTCPM",120,0)
K XWBR,XWBARY
"RTN","XWBTCPM",121,0)
;stop RUM for handler XWB*1.1*5
"RTN","XWBTCPM",122,0)
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
"RTN","XWBTCPM",123,0)
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
"RTN","XWBTCPM",124,0)
;Close in the calling script
"RTN","XWBTCPM",125,0)
K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
"RTN","XWBTCPM",126,0)
Q
"RTN","XWBTCPM",127,0)
;
"RTN","XWBTCPM",128,0)
MAIN ; -- main message processing loop. debug at MAIN+1
"RTN","XWBTCPM",129,0)
F D Q:XWBTBUF="#BYE#"
"RTN","XWBTCPM",130,0)
. ;Setup
"RTN","XWBTCPM",131,0)
. S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
"RTN","XWBTCPM",132,0)
. K XWBR,XWBARY,XWBPRT
"RTN","XWBTCPM",133,0)
. ; -- read client request
"RTN","XWBTCPM",134,0)
. S XR=$$BREAD^XWBRW(1,XWBTIME,1)
"RTN","XWBTCPM",135,0)
. I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
"RTN","XWBTCPM",136,0)
. S XR=XR_$$BREAD^XWBRW(4)
"RTN","XWBTCPM",137,0)
. I XR="#BYE#" D Q ;Check for exit
"RTN","XWBTCPM",138,0)
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
"RTN","XWBTCPM",139,0)
. . Q
"RTN","XWBTCPM",140,0)
. S TYPE=(XR="[XWB]") ;check HDR
"RTN","XWBTCPM",141,0)
. I 'TYPE D LOG("Bad Header: "_XR) Q
"RTN","XWBTCPM",142,0)
. D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
"RTN","XWBTCPM",143,0)
. IF XWBTCMD="#BYE#" D Q
"RTN","XWBTCPM",144,0)
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
"RTN","XWBTCPM",145,0)
. . Q
"RTN","XWBTCPM",146,0)
. U XWBTDEV
"RTN","XWBTCPM",147,0)
. S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
"RTN","XWBTCPM",148,0)
. ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
"RTN","XWBTCPM",149,0)
. I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
"RTN","XWBTCPM",150,0)
Q ;End Of Main
"RTN","XWBTCPM",151,0)
;
"RTN","XWBTCPM",152,0)
;
"RTN","XWBTCPM",153,0)
ETRAP ; -- on trapped error, send error info to client
"RTN","XWBTCPM",154,0)
N XWBERC,XWBERR
"RTN","XWBTCPM",155,0)
;Change trapping during trap.
"RTN","XWBTCPM",156,0)
S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT"
"RTN","XWBTCPM",157,0)
S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
"RTN","XWBTCPM",158,0)
I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
"RTN","XWBTCPM",159,0)
D ^%ZTER ;%ZTER clears $ZE and $ZCODE
"RTN","XWBTCPM",160,0)
D LOG("In ETRAP: "_XWBERC) ;Log
"RTN","XWBTCPM",161,0)
I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT HALT
"RTN","XWBTCPM",162,0)
U XWBTDEV
"RTN","XWBTCPM",163,0)
I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
"RTN","XWBTCPM",164,0)
E L ;Clear Locks
"RTN","XWBTCPM",165,0)
;I XWBOS'="DSM" D
"RTN","XWBTCPM",166,0)
S XWBPTYPE=1 ;So SNDERR won't check XWBR
"RTN","XWBTCPM",167,0)
;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4))
"RTN","XWBTCPM",168,0)
D ESND^XWBRW($C(24)_XWBERR_$C(4))
"RTN","XWBTCPM",169,0)
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
"RTN","XWBTCPM",170,0)
Q
"RTN","XWBTCPM",171,0)
;
"RTN","XWBTCPM",172,0)
CLEANP ;Clean up the partion
"RTN","XWBTCPM",173,0)
N XWBTDEV,XWBNULL D KILL^XUSCLEAN
"RTN","XWBTCPM",174,0)
Q
"RTN","XWBTCPM",175,0)
;
"RTN","XWBTCPM",176,0)
STYPE(X,WRAP) ;For backward compatability only
"RTN","XWBTCPM",177,0)
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
"RTN","XWBTCPM",178,0)
Q $$RTRNFMT^XWBLIB(X)
"RTN","XWBTCPM",179,0)
;
"RTN","XWBTCPM",180,0)
BREAD(L,T) ;read tcp buffer, L is length
"RTN","XWBTCPM",181,0)
Q $$BREAD^XWBRW(L,$G(T))
"RTN","XWBTCPM",182,0)
;
"RTN","XWBTCPM",183,0)
CHPRN(N) ;change process name
"RTN","XWBTCPM",184,0)
;Change process name to N
"RTN","XWBTCPM",185,0)
D SETNM^%ZOSV($E(N,1,15))
"RTN","XWBTCPM",186,0)
Q
"RTN","XWBTCPM",187,0)
;
"RTN","XWBTCPM",188,0)
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
"RTN","XWBTCPM",189,0)
S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2
"RTN","XWBTCPM",190,0)
I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
"RTN","XWBTCPM",191,0)
Q
"RTN","XWBTCPM",192,0)
TIMEOUT ;Do this on MAIN loop timeout
"RTN","XWBTCPM",193,0)
I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
"RTN","XWBTCPM",194,0)
;Sign-on timeout
"RTN","XWBTCPM",195,0)
S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
"RTN","XWBTCPM",196,0)
D SND^XWBRW
"RTN","XWBTCPM",197,0)
Q
"RTN","XWBTCPM",198,0)
;
"RTN","XWBTCPM",199,0)
OS() ;Return the OS
"RTN","XWBTCPM",200,0)
; Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM") //SMH
"RTN","XWBTCPM",201,0)
Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["GT.M":"GT.M",^("OS")["OpenM":"OpenM",1:"MSM")
"RTN","XWBTCPM",202,0)
;
"RTN","XWBTCPM",203,0)
INIT ;Setup
"RTN","XWBTCPM",204,0)
S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
"RTN","XWBTCPM",205,0)
S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
"RTN","XWBTCPM",206,0)
S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
"RTN","XWBTCPM",207,0)
S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
"RTN","XWBTCPM",208,0)
D LOGSTART^XWBDLOG("XWBTCPM")
"RTN","XWBTCPM",209,0)
Q
"RTN","XWBTCPM",210,0)
;
"RTN","XWBTCPM",211,0)
DEBUG ;Entry point for debug, Build a server to get the connect
"RTN","XWBTCPM",212,0)
;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1"
"RTN","XWBTCPM",213,0)
W !,"Before running this entry point set your debugger to stop at"
"RTN","XWBTCPM",214,0)
W !,"the place you want to debug. Some spots to use:"
"RTN","XWBTCPM",215,0)
W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
"RTN","XWBTCPM",216,0)
W !,"or location of your choice.",!
"RTN","XWBTCPM",217,0)
W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^")
"RTN","XWBTCPM",218,0)
;Use %ZISTCP to do a single server
"RTN","XWBTCPM",219,0)
D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
"RTN","XWBTCPM",220,0)
U $P W !,"Done"
"RTN","XWBTCPM",221,0)
Q
"RTN","XWBTCPM",222,0)
SERV ;Callback from the server
"RTN","XWBTCPM",223,0)
S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
"RTN","XWBTCPM",224,0)
S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
"RTN","XWBTCPM",225,0)
D NEW
"RTN","XWBTCPM",226,0)
S IO("C")=1 ;Cause the Listenr to stop
"RTN","XWBTCPM",227,0)
Q
"RTN","XWBTCPM",228,0)
;
"RTN","XWBTCPM",229,0)
EXIT ;Close out
"RTN","XWBTCPM",230,0)
I $G(DUZ) D LOGOUT^XUSRB
"RTN","XWBTCPM",231,0)
I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
"RTN","XWBTCPM",232,0)
Q
"RTN","XWBTCPM",233,0)
;
"RTN","XWBTCPM",234,0)
LOG(MSG) ;Record Debug Info
"RTN","XWBTCPM",235,0)
D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
"RTN","XWBTCPM",236,0)
Q
"RTN","XWBTCPM",237,0)
;
"VER")
8.0^22.0
**END**
**END**

83
m/BMXADE1.m Normal file
View File

@ -0,0 +1,83 @@
BMXADE1 ; IHS/OIT/HMW - BMXNet ADO.NET PROVIDER ;
;;2.1;BMX;;Jul 26, 2009
;
;
;Dental Excel report demo
;
BMXADE(BMXGBL,BMXBEG,BMXEND) ;EP
;Returns recordset containing services and minutes by reporting facility, patient's community and service unit
;
N BMXBEGDT,BMXENDDT,BMXTMP,BMXDT,BMXRD,BMXIEN,BMXNOD,BMXPAT,BMXCOM,BMXFAC,BMXSU,BMXCOMP,BMXSUP,BMXFACP,BMXSVC,BMXMIN,BMXFEE
S U="^",BMXRD=$C(30)
K ^BMXTEMP($J),^BMXTMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S ^BMXTEMP($J,0)="T00030FACILITY^T00030PT_COMMUNITY^T00030PT_SERVICE_UNIT^I00030SERVICES^I00030MINUTES^I00030FEE"_BMXRD
S X=BMXBEG,%DT="P" D ^%DT S BMXBEGDT=Y
S X=BMXEND,%DT="P" D ^%DT S BMXENDDT=Y
I BMXENDDT<BMXBEGDT S BMXTMP=BMXENDDT,BMXENDDT=BMXBEGDT,BMXBEGDT=BMXTMP
S BMXBEGDT=$P(BMXBEGDT,".")
S BMXENDDT=$P(BMXENDDT,"."),$P(BMXENDDT,".",2)=99999
;
;$O Thru ADEPCD("AC" DATE X-REF
;Temp global is (FAC,COMM)=SVCS^MINS
;
S BMXDT=BMXBEGDT F S BMXDT=$O(^ADEPCD("AC",BMXDT)) Q:'+BMXDT Q:BMXDT>BMXENDDT D
. S BMXIEN=0 F S BMXIEN=$O(^ADEPCD("AC",BMXDT,BMXIEN)) Q:'+BMXIEN D
. . Q:'$D(^ADEPCD(BMXIEN,0))
. . S BMXNOD=^ADEPCD(BMXIEN,0)
. . S BMXPAT=$P(BMXNOD,U)
. . S BMXFACP=+$P(BMXNOD,U,3)
. . S BMXCOMP=$$GETCOMP(BMXPAT)
. . D CALCMIN(BMXIEN,.BMXSVC,.BMXMIN,.BMXFEE)
. . Q:BMXSVC=0
. . S:'$D(^BMXTMP($J,BMXFACP,BMXCOMP)) ^BMXTMP($J,BMXFACP,BMXCOMP)="0^0^0"
. . S $P(^BMXTMP($J,BMXFACP,BMXCOMP),U)=$P(^(BMXCOMP),U)+BMXSVC
. . S $P(^BMXTMP($J,BMXFACP,BMXCOMP),U,2)=$P(^(BMXCOMP),U,2)+BMXMIN
. . S $P(^BMXTMP($J,BMXFACP,BMXCOMP),U,3)=$P(^(BMXCOMP),U,3)+BMXFEE
. . Q
. Q
;
;Traverse ^BMXTMP and fill in ^BMXTEMP
S BMXI=0
S BMXFACP=-1 F S BMXFACP=$O(^BMXTMP($J,BMXFACP)) Q:BMXFACP="" D
. I BMXFACP=0 S BMXFAC="UNKNOWN"
. E S BMXFAC=$P($G(^DIC(4,BMXFACP,0)),U) S:BMXFAC="" BMXFAC="UNKNOWN"
. S BMXCOMP=-1 F S BMXCOMP=$O(^BMXTMP($J,BMXFACP,BMXCOMP)) Q:BMXCOMP="" D
. . I BMXCOMP=0 S BMXCOM="UNKNOWN"
. . E S BMXCOM=$P($G(^AUTTCOM(BMXCOMP,0)),U) S:BMXCOM="" BMXCOM="UNKNOWN"
. . S BMXSU=+$P($G(^AUTTCOM(BMXCOMP,0)),U,5)
. . I BMXSU=0 S BMXSU="UNKNOWN"
. . E S BMXSU=$P($G(^AUTTSU(BMXSU,0)),U)
. . S BMXI=BMXI+1
. . S BMXSVC=$P(^BMXTMP($J,BMXFACP,BMXCOMP),U)
. . S BMXMIN=$P(^BMXTMP($J,BMXFACP,BMXCOMP),U,2)
. . S BMXFEE=$P(^BMXTMP($J,BMXFACP,BMXCOMP),U,3)
. . S ^BMXTEMP($J,BMXI)=BMXFAC_U_BMXCOM_U_BMXSU_U_BMXSVC_U_BMXMIN_U_BMXFEE_BMXRD
. . Q
. Q
S BMXI=BMXI+1
S ^BMXTEMP($J,BMXI)=$C(31)
Q
;
GETCOMP(BMXPAT) ;
;Returns Patient Community Pointer
I '$D(^AUPNPAT(BMXPAT,11)) Q 0
Q +$P(^AUPNPAT(BMXPAT,11),U,17)
;
CALCMIN(BMXIEN,BMXSVC,BMXMIN,BMXFEE) ;
;Returns count of lvl 1 - 6 services and minutes for entry BMXIEN
;Uses ANMC rogue FEE field in AUTTADA to calculate FEE data
N BMXA,BMXCOD,BMXALVL
S BMXSVC=0,BMXMIN=0,BMXFEE=0
Q:'$D(^ADEPCD(BMXIEN,"ADA"))
S BMXA=0 F S BMXA=$O(^ADEPCD(BMXIEN,"ADA",BMXA)) Q:'+BMXA D
. S BMXCOD=+^ADEPCD(BMXIEN,"ADA",BMXA,0)
. Q:'$D(^AUTTADA(BMXCOD,0))
. S BMXANOD=^AUTTADA(BMXCOD,0)
. S BMXALVL=$P(BMXANOD,U,5)
. Q:BMXALVL=0
. Q:BMXALVL>6
. S BMXSVC=BMXSVC+1
. S BMXMIN=BMXMIN+$P(BMXANOD,U,4)
. S BMXFEE=BMXFEE+$P(BMXANOD,U,12)
Q
Side by Side

After

Width:  |  Height:  |  Size: 3.0 KiB

90
m/BMXADE2.m Normal file
View File

@ -0,0 +1,90 @@
BMXADE2 ; IHS/OIT/HMW - BMXNet ADO.NET PROVIDER ;
;;2.1;BMX;;Jul 26, 2009
;
;
;Dental Excel report demo
;
BMXADE(BMXGBL,BMXBEG,BMXEND) ;EP
;Returns recordset containing services and minutes by reporting facility, Provider, and ADA Code
;
N BMXBEGDT,BMXENDDT,BMXTMP,BMXDT,BMXRD,BMXIEN,BMXNOD,BMXCOM,BMXFAC,BMXSU,BMXCOMP,BMXSUP,BMXFACP,BMXSVC,BMXMIN,BMXLVL,BMXFEE
S U="^",BMXRD=$C(30)
K ^BMXTEMP($J),^BMXTMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S ^BMXTEMP($J,0)="T00030FACILITY^T00030PROVIDER^T00030ADA_CODE^T00030LEVEL^I00030SERVICES^I00030MINUTES^I00030FEE"_BMXRD
S X=BMXBEG,%DT="P" D ^%DT S BMXBEGDT=Y
S X=BMXEND,%DT="P" D ^%DT S BMXENDDT=Y
I BMXENDDT<BMXBEGDT S BMXTMP=BMXENDDT,BMXENDDT=BMXBEGDT,BMXBEGDT=BMXTMP
S BMXBEGDT=$P(BMXBEGDT,".")
S BMXENDDT=$P(BMXENDDT,"."),$P(BMXENDDT,".",2)=99999
;
;$O Thru ADEPCD("AC" DATE X-REF
;Temp global is (FAC,PROV,CODE)=SVCS^MINS
;
S BMXDT=BMXBEGDT F S BMXDT=$O(^ADEPCD("AC",BMXDT)) Q:'+BMXDT Q:BMXDT>BMXENDDT D
. S BMXIEN=0 F S BMXIEN=$O(^ADEPCD("AC",BMXDT,BMXIEN)) Q:'+BMXIEN D
. . Q:'$D(^ADEPCD(BMXIEN,0))
. . S BMXNOD=^ADEPCD(BMXIEN,0)
. . S BMXFACP=+$P(BMXNOD,U,3)
. . S BMXPRVP=+$P(BMXNOD,U,4)
. . S BMXCODP=0 F S BMXCODP=$O(^ADEPCD(BMXIEN,"ADA","B",BMXCODP)) Q:'+BMXCODP D
. . . D CALCMIN(BMXCODP,.BMXMIN)
. . . D CALCFEE(BMXCODP,.BMXFEE)
. . . S BMXCODPS=0,BMXSVC=0 F S BMXCODPS=$O(^ADEPCD(BMXIEN,"ADA","B",BMXCODP,BMXCODPS)) Q:'+BMXCODPS D
. . . . S BMXSVC=BMXSVC+1
. . . S:'$D(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP)) ^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP)="0^0"
. . . S $P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U)=$P(^(BMXCODP),U)+BMXSVC
. . . S $P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,2)=$P(^(BMXCODP),U,2)+(BMXSVC*BMXMIN)
. . . S $P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,3)=$P(^(BMXCODP),U,3)+(BMXSVC*BMXFEE)
. . . Q
. . Q
. Q
;
;Traverse ^BMXTMP and fill in ^BMXTEMP
S BMXI=0
S BMXFACP=-1 F S BMXFACP=$O(^BMXTMP($J,BMXFACP)) Q:BMXFACP="" D
. I BMXFACP=0 S BMXFAC="UNKNOWN"
. E S BMXFAC=$P($G(^DIC(4,BMXFACP,0)),U) S:BMXFAC="" BMXFAC="UNKNOWN"
. S BMXPRVP=-1 F S BMXPRVP=$O(^BMXTMP($J,BMXFACP,BMXPRVP)) Q:BMXPRVP="" D
. . S BMXPRV=$P($G(^DIC(16,BMXPRVP,0)),U) S:BMXPRV="" BMXPRV="UNKNOWN"
. . S BMXCODP=-1 F S BMXCODP=$O(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP)) Q:'+BMXCODP D
. . . D CODLVL(BMXCODP,.BMXCOD,.BMXLVL)
. . . S BMXI=BMXI+1
. . . S BMXSVC=$P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U)
. . . S BMXMIN=$P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,2)
. . . S BMXFEE=$P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,3)
. . . S ^BMXTEMP($J,BMXI)=BMXFAC_U_BMXPRV_U_BMXCOD_U_BMXLVL_U_BMXSVC_U_BMXMIN_U_BMXFEE_BMXRD
. . . Q
. . Q
. Q
S BMXI=BMXI+1
S ^BMXTEMP($J,BMXI)=$C(31)
Q
;
CALCMIN(BMXCODP,BMXMIN) ;
;Returns Minutes for code BMXCOD
N BMXANOD
S BMXMIN=0
Q:'$D(^AUTTADA(BMXCODP,0))
S BMXANOD=^AUTTADA(BMXCODP,0)
;S BMXLVL=$P(BMXANOD,U,5)
S BMXMIN=$P(BMXANOD,U,4)
Q
;
CALCFEE(BMXCODP,BMXFEE) ;
;Returns FEE for code BMXCOD. Only works for ANMC local fee field
N BMXANOD
S BMXFEE=0
Q:'$D(^AUTTADA(BMXCODP,0))
S BMXANOD=^AUTTADA(BMXCODP,0)
S BMXFEE=+$P(BMXANOD,U,12)
Q
;
CODLVL(BMXCODP,BMXCOD,BMXLVL) ;
;Returns Name and Level of code at ADACODP
N BMXANOD
S BMXCOD="",BMXLVL=""
Q:'$D(^AUTTADA(BMXCODP,0))
S BMXANOD=^AUTTADA(BMXCODP,0)
S BMXCOD=$P(BMXANOD,U)
S BMXLVL=$P(BMXANOD,U,5)
Side by Side

After

Width:  |  Height:  |  Size: 3.3 KiB

157
m/BMXADO.m Normal file
View File

@ -0,0 +1,157 @@
BMXADO ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ;
;;2.1;BMX;;Jul 26, 2009
; SS^BMXADO: RPC EP FROM WINDOWS/WEB APP TO GENERATE A SCHEMEA STRING (& OPTIONALLY, A DATA SET AS WELL)
; THE SCHEMA DEFINITION AND MAP IS STORED IN THE 'BMX ADO SCHEMA' FILE
; THIS ROUTINE GENERATES THE SCHEMA STRING. BMXADOV GENERATES THE DATA SET THAT GOES WITH THE SCHEMA STRING.
; IF THERE IS AN ERROR, XXX(1) WILL CONTAIN "ERROR|msg"_$C(30) WHERE 'msg' IS THE ERROR MESSAGE
; E.G."ERROR|Invalid schema IEN"
;
;
SSD(OUT,SIEN,DAS,VSTG,JSTG) ;Debug entry point
D DEBUG^%Serenji("SS^BMXADO(.OUT,SIEN,DAS,VSTG,JSTG)") ; DEBUGGER ENTRY POINT
Q
;
;
SS(OUT,SIEN,DAS,VSTG,JSTG) ; EP - RETURN THE SCHEMA STRING IN AN ARRAY
; OUT=OUTPUT VARIABLE (PASSED BY REFERENCE)
; THE OUTPUT ARRAY IS GENERATED FROM DATA IN THE 'BMX ADO SCHEMA' FILE AND THE FILEMAN DATABASE
; RECORDS ARE SEPARATED WITH $C(30). FIELDS ARE SEPARATED BY "^". FIELD PROPERTIES ARE SEPARATED BY "|".
; ONE RECORD PER OUTPUT NODE.
; 1ST RECORD IS THE "INTRODUCTION RECORD": "@@@meta@@@BMXIEN|FILE #|DA STRING"
; THE SECOND RECORD IS THE HEADER RECORD. THE REST ARE THE DATA RECORDS
; RECORD FORMAT: FILE#|FIELD#|DATA TYPE|LENGTH|FIELDNAME|READONLY|KEYFIELD|NULLOK_$C(30)
; SIEN=SCHEMA NAME OR IEN FROM BMX ADO SCHEMA FILE
; DAS= "DA" STRING: STRING FOR DEFINING PARENT FILES
; EXAMPLE: "4,8," CORRESPONDS TO DA(2), DA(1).
; PRIMARILY USED AS A "SEED" FOR RE-ENTRY - IF INDEX IS PRESENT.
; IF NOT A SEED, DO NOT INCLUDE THE BOTTOM LEVEL IEN: DA; E.G., "4,8,"
; DO NOT CONFUSE WITH "IENS STRING" OF FILEMAN SILENT CALLS
; VSTG=VIEW STRING INSTRUCTIONS (SEE BMXADOV FOR DETAILS)
; JSTG=JOIN STRING INSTRUCTIONS (SEE BMXADOVJ FOR DETAILS)
;
N X,Y,DIC,ERR
S OUT=$NA(^TMP("BMX ADO",$J)) K @OUT ; DEFINE THE OUTPUT ARRAY CLOSED REFERENCE
X ("S "_$C(68)_"UZ(0)=$C(64)") ; INSURE PRIVELEGES
S X="MERR^BMXADO",@^%ZOSF("TRAP") ; SET MUMPS ERROR TRAP
I '$L(SIEN) S ERR="Missing schema ID" D ERR(ERR) Q
I 'SIEN S DIC="^BMXADO(",DIC(0)="M",X=SIEN D ^DIC S SIEN=+Y I Y=-1 S ERR="Invalid schema ID" D ERR(ERR) Q
I '$D(^BMXADO(SIEN,0)) S ERR="Invalid/missing schema" D ERR(ERR) Q ; SCHEMA MUST EXIST
N FIEN,FLDIEN,TOT,STG,B,C,X,%,LEVEL,Y,SF
S FIEN=$P(^BMXADO(SIEN,0),U,2)
I '$D(^DD(FIEN,0)) S ERR="Invalid/missing file number in schema file" D ERR(ERR) Q ; INVALID FILE NUMBER
S SF=$$CKSUB(FIEN,DAS) I SF=-1 S ERR="Invalid DA string" D ERR(ERR) Q ; INVALID DA STRING
S C=",",B="|",TOT=0 ; THESE LOCALS, ALONG WITH KERNEL VARIABLES, ARE ALWAYS AVAILABLE TO ALL ROUTINES AND SUBROUTINES
JEP ; EP-RECURSION RE-ENTRY POINT FOR JOINS
I $G(SUB),$G(SF) S ERR="Invalid request" D ERR(ERR) Q ; CAN'T DO JOIN WITH A SUBFILE AS THE PRIMARY FILE
S TOT=TOT+1,@OUT@(TOT)="@@@meta@@@BMXIEN"_B_FIEN_B_DAS_U
I $G(SUB) S TOT=TOT+1,@OUT@(TOT)=FIEN_"|.0001|N|15|DA(1)|TRUE|FALSE|FALSE^"
I $G(SF) D SFH(SF) ; SUBFILE HEADERS
S TOT=TOT+1,@OUT@(TOT)=FIEN_"|.001|N|15|BMXIEN|TRUE|TRUE|FALSE^" ; KEY FIELD PART OF HEADER RECORD
S FLDIEN=0
F S FLDIEN=$O(^BMXADO(SIEN,1,FLDIEN)) Q:'FLDIEN S STG=$G(^BMXADO(SIEN,1,FLDIEN,0)) I $L(STG) D ; REST OF HEADER RECORD
. S X=FIEN_B_$P(STG,U)_B_$P(STG,U,2)_B_$P(STG,U,3)_B_$P(STG,U,4)_B
. S %=$S($P(STG,U,5):"TRUE",$P($G(^BMXADO(+$G(IEN),0)),U,3):"TRUE",1:"FALSE") S X=X_%_B ; READ ONLY
. S %=$S($P(STG,U,6):"TRUE",1:"FALSE") S X=X_%_B ; THIS IS A KEY FIELD
. S %=$S($P(STG,U,7):"TRUE",1:"FALSE") S X=X_%_U ; NULL VALUE IS OK (NOT MANDATORY FOR TRANSACTION)
. S TOT=TOT+1
. S @OUT@(TOT)=X
. Q
I TOT'>2 Q ; NOTHING TO PROCESS
S %=@OUT@(TOT) I $E(%,$L(%))=U S $E(%,$L(%))=$C(30),@OUT@(TOT)=% ; END OF RECORD MARKER
I $G(VSTG)="",$G(DFLD)=.001 S VSTG="~~~" ; SIMPLE LOOKUP INTO DETAILS FILE BY IEN
I '$L($G(VSTG)) Q ; REQUEST IS FOR SCHEMA ONLY - NO DATA
DATASET S VSTG=SIEN_"~"_DAS_"~"_VSTG
I $O(^TMP("BMX JOIN",$J,1,+$G(SDETAIL),0)) D JVIEW Q ; JOIN ITERATION ; NO SUPPORT FOR EXTENDED JOINS
D VIEW^BMXADOV(.OUT,VSTG,.TOT) ; APPEND A DATA SET TO A SCHEMA STRING
I '$L($G(JSTG)) S JSTG=$P(VSTG,"~",11,999) ; INCLUDED FOR BKWD COMPATIBILITY ;JOIN INSTRUCTIONS SPAN MULTIPLE ~ PIECES (11,999) BECAUSE OF POSSIBLE NESTED VSTG
I $L(JSTG) D JOIN^BMXADOVJ(SIEN,JSTG) ; ADD DATA SET(S) TO FULFIL THE JOIN REQUEST
Q
;
JVIEW ; JOIN VIEW - SET XCNT AND RESET THE VSTG
N XCNT,DA,NODE,%
S NODE=999999999999
F S NODE=$O(@OUT@(NODE),-1) Q:'NODE I @OUT@(NODE)["|.001|" Q
I 'NODE Q ; INVALID SCHEMA - JOIN CANCELLED
I '$L($P(VSTG,"~",3)),'$G(SUB),$G(DFLD)'=.001 Q ; THERE MUST BE AN INDEX OR SUBFILE FOR A JOIN TO TAKE PLACE
D JFLD^BMXADOVJ ; STUFF VALUES FOR JOIN FLDS INTO INTRO SEGMENT OF THE SCHEMA
S XCNT=NODE
S DA=0
F S DA=$O(^TMP("BMX JOIN",$J,1,SDETAIL,DA)) Q:'DA D D VIEW^BMXADOV(.OUT,VSTG,.TOT) ; APPEND JOINED DATA SETS TO A SCHEMA STRING
. I $P(VSTG,"~",3)="AA",$L($P(VSTG,"~",10)) D Q
.. S %=$P(VSTG,"~",10)
.. S $P(%,"|",1)=DA
.. S $P(VSTG,"~",10)=%
.. Q
. I $G(SUB) S DAS=DA_",",VSTG=SDETAIL_"~"_DA_",~~" Q ; SUBFILE ITERATOR
. I $P(VSTG,"~",3)="AA",$G(FIEN)=9000011 S $P(VSTG,"~",4,5)=DA_"~"_DA Q ; PROBLEM LIST ITERATOR
. S $P(VSTG,"~",4,5)=DA_"~"_DA ; SINGLE IEN ITERATOR
. Q
Q
;
SFH(DAS) ; SUBFILE HEADERS
N L,LEV,PCE,X,%,Z,FLD
S Z="000000000",L=$L(DAS,",")
F PCE=1:1:L-1 D
. S LEV=(L+1)-PCE
. S FLD="."_$E(Z,1,LEV+1)_1
. S TOT=TOT+1
. S @OUT@(TOT)=FIEN_B_FLD_"|I|10|BMXIEN"_(LEV-1)_"|TRUE|TRUE|FALSE"_U ; FIX
. Q
Q
;
CKSUB(FILE,DAS) ; CHECK THE DA STRING FOR VALIDITY AND MAKE THE DA ARRAY
N LEVEL,FIEN
S FIEN=FILE
F LEVEL=1:1 S FIEN=$G(^DD(FIEN,0,"UP")) Q:'FIEN ; COUNT THE LEVELS
I LEVEL'=$L($G(DAS),",") Q -1 ; LEVEL MATCHES DA STRING
I LEVEL=1 Q "" ; INVALID DA STRING
Q DAS
;
LINE(FILE) ; GET FIELD VALUES
N LINE,NODE,STG,DIR,FLD,PF,SET,X,DS,DP
S LINE=""
S NODE=2,Y="" F S NODE=$O(ARR(NODE)) Q:'NODE S STG=ARR(NODE) I $L(STG) D I Y=U Q
. S FLD=$P(STG,B,2) I 'FLD S Y=U Q
. I $P(STG,B,6)="TRUE" Q ; READ ONLY
. S DIR("A")=$P(STG,B,5) I '$L(DIR("A")) S Y=U Q
. S X=$P($G(^DD(+$G(FILE),FLD,0)),U,2)
. I X["P" D Q
.. S PF=+$P(X,"P",2) I 'PF S Y=U Q
.. S DIR(0)="P^"_PF_":EQMZ"
.. D DIR
.. Q
. I X["S" D Q
.. S DIR(0)="S^"_$P(^DD(FILE,FLD,0),U,3)
.. D DIR
.. Q
. I X["D" D Q
.. S DS=$P(^DD(FILE,FLD,0),U,5)
.. I DS'["%DT=""" S DIR(0)="D^::EX" D DIR Q
.. S DP=$P(DS,"%DT="_$C(34),2) S DP=$P(DP,$C(34,32),1)
.. S DIR(0)="D^::"_DP
.. D DIR
.. Q
. S DIR="F"
. D DIR
. Q
Q LINE
;
DIR D ^DIR
I Y?1."^" S Y=U Q
I Y?1.N1"^".E S Y="`"_+Y
S LINE=LINE_U_Y
Q
;
MERR ; MUMPS ERROR TRAP
N X
X ("S X=$"_"ZE")
S X="MUMPS error: """_X_""""
D ERR(X)
Q
;
ERR(ERR) ;EP - BMX ADO SCHEMA ERROR PROCESSOR
N X
S X="ERROR|"_ERR_$C(30)
S @OUT@(1)=X
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 6.5 KiB

80
m/BMXADO2.m Normal file
View File

@ -0,0 +1,80 @@
BMXADO2 ; IHS/CIHA/GIS - BMX ADO RECORDSET UTILS ;
;;2.1;BMX;;Jul 26, 2009
;
;
GEN(BMXY,BMXF) ;EP - Generate an ADO Schema string from a list of fields
;BMXY Is an out-parameter called by reference.
;On return, BMXY will be a zero-based one-dimensional array each node of which will
;contain the schema corresponding to the fields info in BMXF
;
;BMXF is an in-parameter called by reference.
;On input, BMXF will contain the field info on which to build the schema string.
;
;Field info in BMXF is arranged in a zero-based one-dimensional array.
;Node 0 of BMXF contains the KEYFIELDNAME^FILENUMBER^READONLY
;where KEYFIELDNAME is the name of the unique key field in the database and
;FILENUMBER is the FileMan file number and
;READONLY denotes whether the entire recordset is updateable.
;
;Each subsequent node of the BMXF arrray contains field info in the form
;1FILE#^2FIELD#^3LENGTH^4DATATYPE^5ALIAS^6READONLY^7KEYFIELD^8NULLOK
;If FILE# AND FIELD# are defined, the LENGTH and DATATYPE will be taken from the FileMan data dictionary
;If ALIAS is defined, the schema string will use ALIAS as the column name
;READONLY, KEYFIELD and NULLOK are binary fields. Note that there should be only one field
;in the recordset having KEYFIELD=TRUE
;
;New column info format is @@@meta@@@KEYFIELD|FILE#
; For each field: ^1FILE#|2FIELD#|3DATATYPE|4LENGTH|5FIELDNAME|6READONLY|7KEYFIELD|8NULL ALLOWED
;example:
;BMXY(0)="@@@meta@@@BMXIEN|2160010^"
;BMXY(1)="2160010|.001|I|10|BMXIEN|TRUE|TRUE|FALSE^"
;
S BMXY(0)="@@@meta@@@"_$G(BMXF(0))
N BMXI,BMXS,BMXFM,BMXDD,BMXTYP,BMXLEN,BMXLEN2,BMXNAM,BMXKEY,BMXREAD,BMXNULL
S BMXI=0
F S BMXI=$O(BMXF(BMXI)) Q:'+BMXI D
. N BMXFM,BMXDD,BMXTYP,BMXLEN,BMXLEN2,BMXNAM,BMXKEY,BMXREAD,BMXNULL
. S (BMXDD,BMXTYP,BMXLEN,BMXLEN2,BMXNAM,BMXKEY,BMXREAD,BMXNULL)=""
. S BMXFM=0 ;Flag indicating whether BMXF(BMXI) is a FileMan field
. S BMXY(BMXI)=""
. I BMXF(BMXI) S BMXY(BMXI)=$P(BMXF(BMXI),U,1,2) S BMXFM=1
. I BMXFM D ;Look in ^DD for attributes
. . S BMXDD=$G(^DD($P(BMXF(BMXI),U),$P(BMXF(BMXI),U,2),0))
. . ;column name
. . S BMXNAM=$P(BMXDD,U)
. . S BMXNAM=$TR(BMXNAM," ","_")
. . ;Data type
. . I $P(BMXDD,U,2)["P" S BMXDD=$$PTYPE(BMXDD)
. . S BMXTYP=$P(BMXDD,U,2)
. . S BMXTYP=$S(BMXTYP["F":"T",BMXTYP["S":"T",BMXTYP["D":"D")
. . I BMXTYP["N" S BMXTYP=$S($P(BMXTYP,",",2)>0:"N",1:"I")
. . ;default columnn lengths based on type
. . I BMXTYP="N"!(BMXTYP="I") S BMXLEN=$P(BMXDD,U,2),BMXLEN=$P(BMXLEN,","),BMXLEN=$E(BMXLEN,3,$L(BMXLEN))
. . I BMXTYP="I" S BMXLEN2=$P(BMXDD,U,2),BMXLEN2=$P(BMXLEN,",",2),BMXLEN=BMXLEN+BMXLEN2+1
. . I BMXTYP="T" S BMXLEN=0
. . I BMXTYP="D" S BMXLEN=30
. . S BMXNULL="TRUE" S:$P(BMXDD,U,2)["R" BMXNULL="FALSE"
. ;Look in BMXF for user-specified attributes
. S:$P(BMXF(BMXI),U,5)]"" BMXNAM=$P(BMXF(BMXI),U,5) ;Alias
. ;Set KEY, NULL and READONLY
. S BMXNULL="TRUE",BMXREAD="TRUE",BMXKEY="FALSE"
. I $P(BMXF(BMXI),U,7)="TRUE" S BMXKEY="TRUE",BMXNULL="FALSE",BMXREAD="TRUE"
. E S:$P(BMXF(BMXI),U,8)]"" BMXNULL=$P(BMXF(BMXI),U,8) S:$P(BMXF(BMXI),U,6)]"" BMXREAD=$P(BMXF(BMXI),U,6)
. ;Set BMXY node
. S $P(BMXY(BMXI),"|",3)=BMXTYP
. S $P(BMXY(BMXI),"|",4)=BMXLEN
. S $P(BMXY(BMXI),"|",5)=BMXNAM
. S $P(BMXY(BMXI),"|",6)=BMXREAD
. S $P(BMXY(BMXI),"|",7)=BMXKEY
. S $P(BMXY(BMXI),"|",8)=BMXNULL
;
Q
PTYPE(BMXDD) ;
;Traverse pointer chain to retrieve data type of pointed-to field
N BMXFILE
I $P(BMXDD,U,2)'["P" Q BMXDD
S BMXFILE=$P(BMXDD,U,2)
S BMXFILE=+$P(BMXFILE,"P",2)
S BMXDD=$G(^DD(BMXFILE,".01",0))
S BMXDD=$$PTYPE(BMXDD)
Q BMXDD
Side by Side

After

Width:  |  Height:  |  Size: 3.5 KiB

228
m/BMXADOF.m Normal file
View File

@ -0,0 +1,228 @@
BMXADOF ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
;;2.1;BMX;;Jul 26, 2009
; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
; VISIT FILE UPDATES REPRESENT A SPECIAL CASE HTAT IS MANAGED IN BMXADOF1
; INCLUDES TRANSACTION CONTROLS
;
;
;
N DAS,FILE,DATA,OUT S DAS=7,FILE=19707.82,DATA="2.02|120/83" D FILE(.OUT,FILE,DAS,DATA) W !,OUT Q
;
FILED(OUT,FILE,DAS,DATA) ; RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY
D DEBUG^%Serenji("FILE^BMXADOF(.OUT,FILE,DAS,DATA)") ; DEBUGGER ENTRY POINT
; K ^GREG S ^GREG("OUT")=$G(OUT),^("FILE")=$G(FILE),^("DAS")=$G(DAS),^("DATA")=$G(DATA) D FILE(.OUT,FILE,DAS,DATA)
Q
;
FILEX(OUT,FILE,DAS,DATA) ; EP - RPC CALL: INSURES THAT BMXIEN IS VALID - MOJO ONLY
I '$L($G(DATA)) D
. S DATA="",%=""
. F S %=$O(DATA(%)) Q:'% S DATA=DATA_DATA(%) ; CONVERT DATA ARRAY INTO A DATA STRING
. Q
I '$L(DATA) Q
I DATA["999|" S DAS=+$P(DATA,"999|",2) I 'DAS S DAS="" ; FORCE NEW ENTRY
D FILE(.OUT,FILE,$G(DAS),DATA)
Q
;
FILE(OUT,FILE,DAS,DATA) ;EP - RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY
;
; OUT = OUTBOUND MESSAGE RETURNED TO CALLINING APP. 'OK'=SUCCESSFUL TRANSACTION, 'OK|5' NEW RECORD DAS=5 ADDED
; IF TRANSACTION FAILS, AN ERROR MESSAGE IS PASSED
; FILE = VALID FILEMAN FILE OR SUB-FILE NUMBER - WHERE UPDATE IS TO OCCUR
; DAS = THE DA STRING - TYPICALLY THE FILE INTERNAL ENTRY NUMBER OF THE RECORD TO BE UPDATED
; IF THIS IS A SUB-FILE, DAS MUST BE PRECEDED BY PARENT DAS(S) IN COMMA SEPARATED STRING - TOP TO BOTTOM ORDER
; DAS MAY BE PRECEDED BY '+' = ALL FIELDS ARE MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THIS ENTRY
; IF DAS STRING = NULL OR = '+', THIS MEANS ADD A NEW RECORD WITH DATA SUPPLIED IN DATA PARAMETER
; EXAMPLES OF DAS STRINGS: '1' (EDIT RECORD #1), '5,2,-7' (DELETE RECORD #7 IN 3RD LEVEL SUBFILE)
; DATA = DATA STRING OR ARRAY REFERENCE. DATA CAN BE PASSED USING THE .PARAM SYNTAX
; DATA STRING FORMAT: FIELD#|VALUE_$C(30)_FIELD#|VALUE_$C(30)_...FIELD#|VALUE_$C(30)
; $C(30) [AKA EOR] IS THE DATA ELEMENT SEPARATOR
; $C(30) IS USED AS THE DATA DELIMITER BECAUSE OTHER CHARACTERS LIKE '^' COULD APPEAR IN THE VALUE PIECE!
; EA FIELD# MAY BE PRECEED BY '+' = MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THE VALUE OF THIS FIELD
; EXAMPLE: ".03|1/5/46"_EOR_"-.02|"_EOR_"+.09|139394444"_EOR NOTE -.02| IS SAME AS .02|@ OR .02|
; '+' IN FRONT OF THE DAS IS THE SAME AS PUTTING A '+' IN FRONT OF EVERY FIELD# IN THE DATA STRING
;
;
;
N VENDUZ,VUZ
M VENDUZ=DUZ S VUZ=$C(68,85,90)
N OREF,CREF,DIC,DIE,DA,DR,X,Y,%,I,FLD,CNT,FNO,VAL,@VUZ,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG,LVLS,IENS
I $G(FILE)=9000010 N AUPNPAT,AUPNDOB,AUPNDOD,AUPNVSIT,AUPNTALK,APCDOVRR S (APCDOVRR,AUPNTALK)=1 ; THE VISIT FILE IS UPDATED IN THIS TRANSACTION
X ("M "_$C(68,85,90)_"=VENDUZ S "_$C(68,85,90)_"(0)="_$C(34,64,34)) K VENDUZ ; ELININATES PERMISSION PROBLEMS
S OUT="",FLD="",GTFLG=0,GDFLG=0
S X="MERR^BMXADOF",@^%ZOSF("TRAP") ; SET MUMPS ERROR TRAP
I '$D(^DD(+$G(FILE))) S OUT="Invalid file number" Q ; FILE # MUST BE VALID
S DAS=$G(DAS) I $E(DAS)="," S DAS=$E(DAS,2,99) ; ACCURATE IF NON SUB-FILE DAS STRING DOSN'T CONTAIN A ","
S LVLS=$L(DAS,",")
S %=FILE F CNT=1:1 S %=$G(^DD(%,0,"UP")) I '% Q ; COUNT FILE/SUB-FILE LEVELS IN THE DATA DICTIONARY
I LVLS'=CNT S OUT="Invalid DAS string" Q ; LEVELS IN DAS STRING MUST MATCH LEVELS IN THE DATA DICTIONARY
I $E(DAS)="-" S DAS=$E(DAS,2,99),GDFLG=1 ; GLOBAL DELETE FLAG
I $E(DAS)="+" S DAS=$E(DAS,2,99),GTFLG=1 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE
I LVLS>1 F I=1:1:LVLS D I DAS="ERR" S OUT="Invalid DAS string" Q ; MAKE DAS ARRAY. MIRRORS THE DA() ARRAY
. I I=LVLS S DAS=$P(DAS,",",I) Q ; SET DAS OF SUBFILE
. S %=$P(DAS,",",I) I '% S DAS="ERR" Q
. S DAS(LVLS-I)=% ; SET DAS(S) OF PARENT FILE(S). LIKE DA(), THE LARGER THE DAS SUBSCRIPT, THE HIGHER THE LEVEL
. Q
I DAS="ERR" S OUT="Update cancelled. Invalid DAS string" Q
I DAS="Add"!(DAS="ADD") S DAS=""
S %=$E(DAS) I %="-" S GDFLG=1,DAS=$E(DAS,2,99) ; YET ANOTHER WAY TO SET GLOBAL DELETE FLAG
S %=$$REF(FILE,.DAS) ; GET OPEN REF, CLOSED REF, AND IENS STRING
S OREF=$P(%,"|"),CREF=$P(%,"|",2),IENS=$P(%,"|",3) I $L(OREF),$L(CREF)
E S OUT="Update cancelled. Invalid file definition/global reference" Q ; ERROR REPORT
I DAS,'$D(@CREF@(DAS)) S OUT="Update cancelled. Invalid DAS" Q ; IF THERE IS AN DAS, IT MUST BE VALID
I '$G(DAS),FILE=9000010,'$$VVAR^BMXADOF2(DATA) Q ; VISIT FILE ADD REQUIRES THAT SPECIAL VARIABLES BE PRESENT AND VALID
I 'GDFLG,DAS,DATA[".01|@" S GDFLG=1 ; ALTERNATE WAY TO SET GLOBAL DELETE FLAG: REMOVE .01 FIELD
I GDFLG,'DAS S OUT="Deletion cancelled. Missing DAS" Q ; CAN'T DO DELETE WITHOUT AN DAS
I GDFLG D DIK(OREF,DAS) S OUT="Record deleted|"_DAS Q ; DELETE AND QUIT
S UFLG=$S($G(DAS):"E",1:"A") ; SET UPDATE FLAG: ADD OR EDIT
I '$L($G(DATA)) D I '$L($G(DATA)) S OUT="Update cancelled. Missing/invalid data string" Q ; COMPRESS DATA ARRAY INTO A SINGLE STRING
. S DATA="",%=""
. F S %=$O(DATA(%)) Q:'% S DATA=DATA_DATA(%) ; CONVERT DATA ARRAY INTO A DATA STRING
. Q
S %=$L(DATA) S %=$E(DATA,%-1,%) D ; CHECK FOR PROPER TERMINATION OF DATA STRING
. I %=$C(30,31) Q ; PROPER TERMINATION
. I $E(%,2)=$C(30) S DATA=DATA_$C(31) Q
. I $E(%,2)=$C(31) S DATA=$E(DATA,1,$L(DATA-1))_$C(30,31)
. S DATA=DATA_$C(30,31)
. Q
S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. Missing data string" Q
SPEC S DATA=$$SPEC^BMXADOFS(FILE,DATA,UFLG) ; BASED ON FILE IEN, SPECIAL MODS MAY BE MADE TO THE DATA STRING
S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. SPEC analysis failed." Q
F CNT=1:1:TOT S %=$P(DATA,$C(30),CNT) I $L(%) S DATA(CNT)=% ; BUILD PRIMARY FIELD ARRAY
S %=$G(DATA(1)) I %=""!(%=$C(31)) S OUT="Update cancelled. Missing data string" Q
S %=DATA(CNT) I %[$C(31) S %=$P(%,$C(31),1),DATA(CNT)=% ; STRIP OFF END OF FILE MARKER
F CNT=1:1:TOT S X=$G(DATA(CNT)) I $L(X) D ; BUILD SECONDARY FIELD ARRAY
. S TFLG=0,DFLG=0
. I $E(X)="+" S TFLG=1,X=$E(X,2,999),$P(FLD,U)=1
. I $E(X)="-" S DFLG=1,X=$E(X,2,999)
. S FNO=$P(X,"|"),VAL=$P(X,"|",2)
. I '$D(^DD(FILE,+$G(FNO),0)) S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid field number" Q
. I DFLG,VAL'="" S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid deletion syntax" Q ; CANT DELETE IF A VALUE IS SENT
. I VAL="@" S DFLG=1 ; SYNC DFLG AND VAL
. S FLD(FNO)=VAL_U_TFLG_U_DFLG
. I FNO=.01,TFLG S $P(FLD,U,2)=1
. Q
I $P($G(FLD(.01)),U,3),UFLG="A" S OUT="Record deletion cancelled. Missing DAS" Q ; CAN'T DELETE A RECORD WITHOUT A VALID DAS
I $P($G(FLD(.01)),U,3)!($G(GDFLG)) S UFLG="D" ; DELETION
DELREC I UFLG="D" D DIK(OREF,DAS) S OUT="OK" Q ; DELETE THE RECORD
I UFLG="A",'$L($P($G(FLD(.01)),U)) S OUT="Record addition cancelled. Missing .01 field" Q ; CAN'T ADD A RECORD WITHOUT A VALID .01 FIELD
DINUM I UFLG="A",$G(^DD(FILE,.01,0))["DINUM=X" D ; IF DINUM'D RECORD EXISTS, SWITCH TO MOD MODE
. S %=FLD(.01)
. I $E(%)="`" S %=+$E(%,2,99)
. I '$D(@CREF@(%,0)) Q ; OK TO ADD BRAND NEW RECORD BUT EXISTING RECORDS MUST BE EDITED
. K FLD(.01)
. S DAS=%,UFLG="E"
. Q
ADDREC I UFLG="A" D ADD(OREF) Q ; ADD A NEW ENTRY TO A FILE
EDITREC I UFLG="E" D EDIT(OREF,DAS) Q ; EDIT AN EXISTING RECORD
Q
;
DIK(DIK,DA) ; DELETE A RECORD
; PATCHED BY GIS 9/28/04 TO FIX PROBLEMS WITH SUBFILE DELETION
I '$G(DAS(1)) G DIK1 ; CHECK FOR SUBFILE DELETION
N DA,IENS,I,DIK
I '$G(FILE) Q
S I=0,IENS=DAS_","
M DA=DAS
F S I=$O(DAS(I)) Q:'I S IENS=IENS_DAS(I)_","
S DIK=$$ROOT^DILFD(FILE,IENS) I '$L(DIK) Q
DIK1 D ^DIK
D ^XBFMK
Q
;
ADD(DIC) ; ADD A NEW ENTRY TO A FILE
N X,Y,%,DA,DN,UP,SB,DNODE,ERR
S X=$P($G(FLD(.01)),U) I '$L(X) S OUT="Unable to add a new record" Q
S X=$$POINT(FILE,.01,X) ; ADD ACCENT GRAV IF NECESSARY
S X=""""_X_"""" ; FORCE A NEW ENTRY
S DIC(0)="L"
I $O(DAS(0)) D I $G(ERR) S Y=-1 G AFAIL ; GET DIC("P") IF NECESSARY
. S %=0 F S %=$O(DAS(%)) Q:'% S DA(%)=DAS(%) ; CREATE THE DA ARRAY
. S UP=$G(^DD(FILE,0,"UP")) I 'UP S ERR=1 Q
. S SB=$O(^DD(UP,"SB",FILE,0)) I 'SB S ERR=1 Q
. S DIC("P")=$P($G(^DD(UP,SB,0)),U,2) I '$L(DIC("P")) S ERR=1 Q
. S DN=DIC_"1,0)" I $D(DN) Q
. S @DN=(U_DIC("P")_U_U) ; CREATE THE DICTIONARY NODE
. Q
ADIC D ^DIC
AFAIL I Y=-1 S OUT="Unable to add a new record" G AX
I $O(FLD(0)) D EDIT(DIC,+Y) Q
S OUT="OK"_"|"_+Y
AX D ^XBFMK
Q
;
EDIT(DIE,DA) ; EDIT AN EXISTING RECORD
N DR,RFLG,ERR,FNO,VAL,TFLG,RESULT,MSG,DIERR,DISYS,SF,APCDALVR
S FNO=0,DR="",APCDALVR=""
I UFLG="A" S OUT="OK New record added|"_DA
F S FNO=$O(FLD(FNO)) Q:'FNO S X=FLD(FNO) I $L(X) D I $G(RFLG) Q ; CHECK EA FIELD AND BUILD THE DR STRING AND ERROR STRING
. S VAL(FNO)=$P(X,U),TFLG=$P(X,U,2) I '$L(VAL(FNO)) Q
. S SF=$$WP(FILE,FNO)
. I SF D WORD(FILE,DA,FNO,CREF,VAL(FNO)) Q ; WORD PROCESSING FIELDS MANAGED SEPARATELY
. S VAL(FNO)=$$POINT(FILE,FNO,VAL(FNO)) ; ADD ACCENT GRAV IF NECESSARY
. K ERR,RESULT
. I VAL(FNO)="@"!(VAL(FNO)="") S RESULT="@"
. I FNO=.01,UFLG="A" S:$E(VAL(.01))="`" VAL(.01)=$E(VAL(.01),2,999) Q ; NO NEED TO EDIT THE .01 FIELD OF A RECORD THAT HAS JUST BEEN CREATED
. I FILE\1=9000010,$L($P(FILE,".",2))=2,UFLG="E",(FNO=.02!(FNO=.03)) Q ; CAN'T EDIT EXISTING PT AND VISIT FIELDS OF V FILES
. I FILE\1=9000010,$L($P(FILE,".",2))=2,UFLG="A",FNO=.03,VAL(.03)?1"`"1.N S %=+$E(VAL(.03),2,99) I $D(^AUPNVSIT(%,0)) S RESULT=% G E1
. I FILE=9000011,FNO=.07,VAL(.07)?1.N S RESULT=VAL(.07) G E1 ; THE VALIDITY CHECK FAILS - SO BYPASS THIS
CHK . I VAL(FNO)'="@" D CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,.ERR)
E1 . I RESULT=U D Q
.. S MSG=$G(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation")
.. I $L(OUT) S OUT=OUT_"~"
.. I TFLG!GTFLG S RFLG=1,OUT=FNO_"|"_MSG Q
.. S OUT=OUT_FNO_"|"_MSG
.. Q
. S VAL(FNO)=RESULT
. I $L(DR) S DR=DR_";"
. I RESULT="@" S DR=DR_FNO_"////@" Q ; DELETE THIS VALUE
. S DR=DR_FNO_"////^S X=VAL("_FNO_")" ; BUILD DR STRING
. Q
I $G(RFLG) D:UFLG="A" DIK(DIE,DA) S OUT="Record update cancelled"_"|"_OUT G EX ; TRANSACTION ROLLBACK FLAG IS SET, ENTRY DELETED (ADD MODE) OR UPDATE CANCELLED (EDIT MODE)
S %=0 F S %=$O(DAS(%)) Q:'% S DA(%)=DAS(%) ; JUST IN CASE THIS IS A MILTIPLE, CREATE THE DA ARRAY
DIE L +@CREF@(DA):2 I $T D ^DIE L -@CREF@(DA) G:OUT["valid" EX S OUT="OK" S:UFLG="A" OUT=OUT_"|"_DA G EX ; SUCCESS!!!!
S OUT="Update cancelled. File locked" ; FILE LOCKED. UNABLE TO UPDATE
I $L(FLD),UFLG="A" D DIK(DIE,DA) ; ROLLBACK THE NEW RECORD
EX D ^XBFMK ; CLEANUP
Q
;
REF(FILE,DAS) ; GIVEN A FILE/SUBFILE NUMBER & DAS ARRAY, RETURN THE FM GLOBAL REFERENCE INFO: OREF|CREF|IENS
N OREF,CREF,IENS,I,X
S IENS=$$IENS^DILF(.DAS) I '$L(IENS) Q ""
S OREF=$$ROOT^DILFD(FILE,IENS) I '$L(OREF) Q ""
S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""
Q (OREF_"|"_CREF_"|"_IENS)
;
POINT(FILE,FNO,VAL) ; ADD ACCENT GRAV IF NECESSARY
I $E(VAL)="`" Q VAL
I $P($G(^DD(FILE,FNO,0)),U,2)["P",VAL=+VAL,VAL\1=VAL S VAL="`"_VAL
Q VAL
;
WP(FILE,FLD) ; RETURN THE SUBFILE NUMBER IF IT IS A WORD PROCESSING FIELD
N SF,DTYPE
S SF=$P($G(^DD(+$G(FILE),+$G(FLD),0)),U,2) I 'SF Q 0
S DTYPE=$P($G(^DD(SF,.01,0)),U,2)
I DTYPE["W" Q SF
Q 0
;
WORD(FILE,DA,FLD,CREF,VAL) ; SUFF TEXT ENTRY INTO THE WP MULTIPLE FIELD
N SS,TOT,A,B,I
S SS=+$P($G(^DD(FILE,FLD,0)),U,4) I SS="" Q
I VAL="@"!(VAL="") K @CREF@(DA,SS) Q ; DELETE THE WP RECORD: REMOVE DICTIONARY NODE AND DATA
S TOT=0
F Q:'$L(VAL) D
. S A=$E(VAL,1,80),VAL=$E(VAL,81,999999) ; PEEL OFF AN 80 CHARACTER DATA BLOCK FROM THE FRONT OF THE TEXT STRING
. I $L(A) S TOT=TOT+1,B(TOT)=A ; BUILD THE TEMP ARRAY
. Q
I '$D(B(1)) Q ; NOTHING TO STORE SO QUIT
S @CREF@(DA,SS,0)="^^"_TOT_U_TOT_U_DT ; SET DICTIONARY NODE
F I=1:1:TOT S @CREF@(DA,SS,I,0)=B(I) ; SET DATA NODES
Q
;
MERR ; MUMPS ERROR TRAP
N ERR,X
X ("S X=$"_"ZE")
S ERR="M ERROR: "_X
S ^GREG("ERR")=ERR
S OUT=ERR
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 12 KiB

75
m/BMXADOF1.m Normal file
View File

@ -0,0 +1,75 @@
BMXADOF1 ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
;;2.1;BMX;;Jul 26, 2009
; UPDATE FILEMAN WITH AN ADO RECORD SET FROM A WINDOWS/WEB APPLICATION
;
;
D BAFM(.OUT,$NA(^TMP("BMX ADO",6))) ; W !!! ZW OUT K OUT Q
;
BAFM(OUT,CREF) ; EP- RPC: PASS DATA FROM A STD BROKER ADO ARRAY TO FILEMAN AND RETURN THE ACK MSG IN 'OUT' ARRAY
I '$L($G(CREF)) Q ; REFERENCE MUST EXIST
I '$D(@CREF) Q ; DATASET MUST EXIST
N NODE,STG,DATA,SCHEMA,X,ECNT,CNT
S OUT="DONE",ECNT=0,CNT=0
PEEL S NODE=0,STG="" ; PEEL DATA OFF THE ARRAY AND FILE IT
F S NODE=$O(@CREF@(NODE)) Q:'NODE D ; LOOP THRU THE NODES TO BUILD A STRING.
. S X=@CREF@(NODE) I X="" Q
. S STG=STG_X
. I STG[$C(30) D S STG="" Q ; WHEN YOU HIT $C(30), PROCESS THE CURRENT STRING, AND THEN START A NEW STRING.
.. S STG=$TR(STG,$C(30),"") ; REMOVE THE EOR CHARACTER $C(30) FROM THE END OF THE STRING
.. I STG["@@@meta@@@" S SCHEMA=STG Q ; GET SCHEMA STRING. THEN KEEP LOOPING TO GET THE DATA STRINGS
.. D PREP(.OUT,SCHEMA,STG) ; PREP DATA STRING FOR FILING, AND THEN FILE THE DATA
.. Q
. Q
K @CREF ; CLEAN UP
I ECNT=0 S OUT(0)="OK" Q ; SUMMARY NODE OF THE OUTPUT ARRAY
S OUT(0)=ECNT_" error(s) detected in this transaction"
Q
;
PREP(OUT,SCHEMA,DATA) ; PREPARE DATA FOR THE ADO FILER
N TOP,LEV,C,B,%,DA,DAS,PCE,MAX,S,D,FILE,DSTG,MAND,FLD,VAL,MSG
S C=",",B="|",DAS=""
S %=$P(SCHEMA,U,2) S TOP=$P(%,B,2)
S LEV=$L(TOP)-3 I LEV=2 S DAS=+DATA_C
S SCHEMA=$P(SCHEMA,U,2,999)
S MAX=$L(SCHEMA,U)
S FILE=+SCHEMA I '$D(^DD(FILE,0)) S ERR="Update failed. Missing/invalid file number" D ERR(ERR) Q
SPEC ; CHECK FOR SPECIAL CASES
I FILE=9000011,SCHEMA'["|.05|" G DSTG
I FILE=9000010.07,SCHEMA'["|.04|" G DSTG
I FILE=9000010.18,SCHEMA'["|.04|" G DSTG
I FILE=9000013,SCHEMA'["|.04|" G DSTG
I FILE=9000014,SCHEMA'["|.04|" G DSTG
I FILE'=9000010.07,FILE'=9000011,FILE'=9000013,FILE'=9000014,FILE'=9000010.18
E I '$$NARR^BMXADOF2 Q ; GET IEN OF PROVIDER NARRATIVE AND SUBSTITUE THIS VALUE IN THE DATA STG
DSTG ; BUILD THE ADD/UPDATE STRING FOR THE EBCU FILER
S DA=+DATA,DAS=DAS_DA,DSTG=""
F PCE=2:1:MAX D
. S S=$P(SCHEMA,U,PCE),VAL=$P(DATA,U,PCE)
. I $P(S,B,6)="TRUE" Q ; READ ONLY
. S FLD=$P(S,B,2) I 'FLD Q ; INVALID SCHEMA PIECE
. I $E(FLD,1,3)=".00" Q ; IEN NOT DATA
. I FLD["ID" Q ; DON'T FILE THE IDENTIFIERS
. I SCHEMA[(B_FLD_"IEN"),FLD'["IEN",$L(VAL) Q ; WAIT FOR THE LOOKUP VALUE, BYPASS CURRENT FIELD
. S FLD=+FLD
. I $P(S,B,8)'="TRUE" S FLD="+"_FLD ; MANDATORY FIELD
. E I VAL="" S FLD="-"_FLD ; DELETE THE VALUE
. I FLD?.1E1".01" D Q ; MAKE SURE THAT THE .01 FIELD IS FIRST!
.. I $L(DSTG) S DSTG=FLD_B_VAL_$C(30)_DSTG Q ; APPEND .01 FIELD TO THE FRONT OF AN EXISTING UPDATE STRING
.. S DSTG=FLD_B_VAL ; START A NEW UPDATE STRING WITH THE .01 FIELD
.. Q
. I $L(DSTG) S DSTG=DSTG_$C(30) ; $C(30) IS THE "COLUMN" DELIMITER FOR DATA TO BE ENETERED IN THE TABLE
. S DSTG=DSTG_FLD_B_VAL ; "|" IS THE DATA ELEMENT DELIMITER, SEPARATING FIELD NAME AND FIELD VALUE
. Q
FILE D FILE^BMXADOF(.MSG,FILE,DAS,DSTG) ; THE DATA STRING IS PREPARED. NOW SEND IT TO THE EBCU FILER.
I $E(MSG,1,2)'="OK" S ECNT=ECNT+1
S CNT=CNT+1 S OUT(CNT)=MSG
; S DSTG=$TR(DSTG,$C(30),"}") W !,DSTG ; TEMP OUTPUT - REMOVE THIS LINE AFTER TESTING COMPLETED!
Q
;
ERR(ERR) ;
I '$L($G(ERR)) Q
S ECNT=$G(ECNT)+1
S CNT=CNT+1
S OUT(CNT)=ERR
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 3.3 KiB

57
m/BMXADOF2.m Normal file
View File

@ -0,0 +1,57 @@
BMXADOF2 ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
;;2.1;BMX;;Jul 26, 2009
; THIS ROUTINE CONTAINS SPECIAL ENTRY POINTS FOR UPDATING RPMS
;
;
;
VVAR(DATA) ; EP-CHECK SPECIAL VARIABLES REQUIRED FOR UPDATING THE VISIT FILE
I '$L(DATA) S OUT="Update cancelled. Missing data string" Q 0
N X,I,Y,VDATE,%DT
K AUPNPAT,AUPNDOB,AUPNDOD,AUPNVSIT ; THE VARS ARE NOT NEW'D SINCE THEY WILL BE USED BY THE CALLING ROUTINE
S AUPNTALK=1,AUPNOVRR=1
S X=DATA S X=$TR(X,($C(30)_"+"),$C(30)) S X=$TR(X,($C(30)_"-"),$C(30)) S X=$TR(X,($C(30)_"`"),$C(30)) S DATA=X ; STRIP OFF TRANSACTION FLAGS FROM FIELD NUMBERS
S X=$P(DATA,"|",2),X=$P(X,$C(30)),VDATE=-1
I $E(X,1,7)?7N S VDATE=X
E S %DT="T" D ^%DT S VDATE=Y
I VDATE=-1 S OUT="Update cancelled. Visit timestamp misssing/invalid" Q 0
S Y=+$P(DATA,($C(30)_".05|"),2) I 'Y S OUT="Update cancelled. Patient data missing" Q 0 ; FAILED TO FIND THE PATIENT IEN
S AUPNPAT=Y
S AUPNDOB=$P($G(^DPT(AUPNPAT,0)),U,3) I 'AUPNDOB S OUT="Update cancelled. Missing DOB" Q 0
I AUPNDOB>VDATE S OUT="Update cancelled. Patient born afer visit date???" Q 0
S AUPNDOD=$P($G(^DPT(AUPNPAT,.35)),U)
I AUPNDOD,AUPNDOD<VDATE S OUT="Update cancelled. Patient died before this visit date" Q
Q 1
;
NARR() ;EP - GET IEN OF PROVIDER NARR & UPDATE DATA STG FOR PROBLEM FILE
N PCE,NARR,NIEN,IPCE,%,I,NN,DIC,X,Y,FLD,FIEN
S PCE=0,FIEN=+SCHEMA,NIEN=""
F I=3:1:$L(SCHEMA,U) D I PCE Q
. S %=$P(SCHEMA,U,I)
. S FLD=$P(%,"|",2)
. I 'FLD Q
. I $P($G(^DD(FIEN,FLD,0)),U,2)["P9999999.27" S PCE=I
. Q
I 'PCE Q ""
S NARR=$P(DATA,U,PCE) I NARR="" Q ""
S NIEN=$$XMATCH(NARR)
I 'NIEN D ; CREATE A NEW ENTRY IN THE PROVIDER NARRATIVE FILE
. S DIC=9999999.27
. S DIC(0)="L"
. S X=""""_NARR_""""
. D ^DIC I Y=-1 Q
. S NIEN=+Y
. Q
I 'NIEN Q ""
S $P(DATA,U,PCE)="`"_NIEN ; STUFF THE NARRATIVE LOOKUP VALUE INTO THE DATA STRING
Q NIEN
;
XMATCH(NARR) ; IF THERE IS AN EXACT MATCH IN THE PROVIDER NARRATIVE FILE, RETURN THE IEN
N IX,X,Y,%
S IX=$E(NARR,1,30)
S %=$O(^AUTNPOV("B",IX,0))
I '% Q ""
I %,'$O(^AUTNPOV("B",IX,%)) Q %
S Y=""
S %=0 F S %=$O(^AUTNPOV("B",IX,%)) Q:'% S X=$P($G(^AUTNPOV(%,0)),U) I X=NARR S Y=% Q
Q Y
;
Side by Side

After

Width:  |  Height:  |  Size: 2.1 KiB

84
m/BMXADOFD.m Normal file
View File

@ -0,0 +1,84 @@
BMXADOFD ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
;;2.1;BMX;;Jul 26, 2009
; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
; CONTAINS SPECIAL ENTRY POINT FOR RPMS DATA ENTRY
;
;
;
; D SS^BMXADO(.XXX,53,"","~~~~~VMEAS~BMXADOFD~1.244A||PU\60|WT\175|HT\70") Q
; D SS^BMXADO(.XXX,58,"X","AC~53~53~~~NOTES~BMXADOFD~53") Q
N FILE,DAS,DATA S FILE=9000010.07,DAS="+"
S DATA=".01|`8718"_$C(30)_".02|`1"_$C(30)_".03|`71168"_$C(30)_".04|DM--2"_$C(30,31)
D FILE^BMXADOF(.XXX,FILE,DAS,DATA) Q
;
VMEAS(DATA,IENS,MAX,OUT,TOT) ; VIEW MEASUREMENTS: CUSTOM ITERATOR
; DATA=VCN|ALL|MTYPE1\VAL1|MTYPE2\VAL2|...|MTYPEn\VALn
N VAL,CNT,P,S,PTIEN,VIEN,%,X,Y,TYPE,N,ALL,STG,MEAS,MIEN,IX
S P="|",S="\",N=0
I '$G(TOT) Q ""
I '$L(OUT) Q ""
S VIEN=$P(DATA,P) I '$L(VCN) Q ""
S PTIEN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'PTIEN Q ""
F CNT=2:1 S X=$P(DATA,P,CNT) Q:'$L(X) D ; CREATE PRELIMINARY DATA ARRAYS
. S VAL=$P(X,S,2) ; VALUE MUST EXIST
. I '$L(VAL) Q
. S TYPE=$P(X,S) ; TYPE MUST EXIST
. I '$L(TYPE) Q
. S MIEN=$O(^AUTTMSR("B",TYPE,0)) I 'MIEN Q
. S MEAS=$P($G(^AUTTMSR(MIEN,0)),U,2) I '$L(MEAS) Q
. S N=N+1
. S VAL(N)=VAL
. S TYPE(N)=MIEN_U_TYPE_U_MEAS
. S IX(MIEN)=N
. Q
MG S N=0 F S N=$O(VAL(N)) Q:'N D
. S TOT=TOT+1
. S @OUT@(TOT)=+TYPE(N)_U_$P(TYPE(N),U,2)_U_"`"_PTIEN_U_"`"_VIEN_U_VAL(N)_U_$P(TYPE(N),U,3)_$C(30)
. Q
Q ""
;
ICDVAL(CODE) ; EP-RPC-VERIFY ICD CODE BY RETURNING ITS IEN
I '$L($G(CODE)) Q ""
N IEN
S IEN=$O(^ICD9("BA",CODE_" ",0))
I 'IEN Q ""
Q IEN
;
FACNIEN(PIEN,FIEN) ;EP - GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN
I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
I '$D(^DIC(4,+$G(FIEN),0)) Q ""
N NFIEN
S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT
; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE
S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1
S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN
S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^"
S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)=""
Q FNIEN
;
NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY
N MAX,PIEN,X,Y
S MAX=0,PIEN=0
F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D ; FIND ALL PROBLEMS FOR THIS PATIENT
. S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q ""
. I $P(X,U,6)'=FIEN Q ; ONLY CHECK NUMBERS AT THIS FACILITY
. S Y=$P(X,U,7)
. I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR
. Q
S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER
Q MAX
;
NN W $$NEXTNOTE(221,4585) Q
NEXTNOTE(PIEN,FIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY
I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
I '$D(^DIC(4,+$G(FIEN),0)) Q ""
N MAX,NIEN,FNIEN,X,Y
S MAX=0,NIEN=0
S FNIEN=$$FACNIEN^BMXADOFD(PIEN,FIEN) I 'FNIEN Q ""
F S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN D
. S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q
. S Y=+X
. I Y>MAX S MAX=Y
. Q
S MAX=MAX+1
Q MAX
Side by Side

After

Width:  |  Height:  |  Size: 2.8 KiB

204
m/BMXADOFS.m Normal file
View File

@ -0,0 +1,204 @@
BMXADOFS ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
;;2.1;BMX;;Jul 26, 2009
; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
; CONTAINS SPECIAL CODE RELATED TO FILING PROPLEMS, POVS, FAMILY HX, PERSONAL HX AND NOTES.
;
;
;
PAT ; TEST PROBLEM ADD
S DATA=".01|`8257"_$C(30)_".02|`53"_$C(30)_".03|"_DT_$C(30)_".05|C-POX"_$C(30)_".06|`4585"_$C(30)_".12|I"_$C(30,31)
D FILE^BMXADOF(.XXX,9000011,"",DATA) W !,XXX K XXX,DATA Q
;
PET ; TEST PROB EDIT
S DATA=".01|250.00"_$C(30)_".03|"_DT_$C(30)_".05|HI MOM"_$C(30)_".12|I"_$C(30,31)
D FILE^BMXADOF(.XXX,9000011,"1757",DATA) W !,XXX K XXX,DATA Q
;
TDP ; TEST PROBLEM DELETE
S DATA=$C(31)
D FILE^BMXADOF(.XXX,9000011,"-1757",DATA) W !,XXX K XXX,DATA Q
;
TPOV ; ADD POV TEST
S DATA=".01|`8718"_$C(30)_".02|`53"_$C(30)_".03|`3909"_$C(30)_".04|DM---I"_$C(30)_".12|P"_$C(30,31)
D FILE^BMXADOF(.XXX,9000010.07,"",DATA) W !,XXX K XXX,DATA Q
;
TH ; HX TEST
S DATA=".01|250.00"_$C(30)_".02|`53"_$C(30)_".03|JUL 15,2004"_$C(30)_".04|FAMILY HX OF LUNG CA"_$C(30,31)
D FILE^BMXADOF(.XXX,9000014,"",DATA) W !,XXX K XXX,DATA Q
;
TNOTE ; TEST ADDING A NOTE TO A PROBLEM
N DATA,XXX,PROBIEN,FACNIEN,FACIEN,DAS
S PROBIEN=3,FACIEN=4587
S FACNIEN=$$FACNIEN(PROBIEN,FACIEN) ; YOU MUST SPECIFY THE PROBLEM IEN AND THE FACILITY IEN
S DAS=PROBIEN_","_FACNIEN_","
S DATA=".03|NEW NOTE #2"_$C(30,31) ; THE DATA STRING JUST CONTAINS THE NOTE FIELD.
; THE OTHER FIELDS (INCLUDING .01) ARE ADDED BY BMXADOF
D FILE^BMXADOF(.XXX,9000011.1111,DAS,DATA) W !,XXX
Q
;
; -----------------------------------------------------------------------------------------------------
;
SPEC(FILE,DATA,UFLG) ;EP - SPECIAL DATA MODS FOR SPECIFIC FILES
I FILE=9000010.07 S DATA=$$POV(DATA) Q DATA
I FILE=9000011 S DATA=$$PROB(DATA,$G(UFLG)) Q DATA
I FILE=9000013!(FILE=9000014) S DATA=$$HX(DATA) Q DATA
I FILE=9000011.1111 S DATA=$$NOTE(DATA,$G(DAS(2)),$G(DAS(1))) Q DATA
; I FILE=9000010.18,DATA'["|.04|" G DSTG
Q DATA
;
HX(DATA) ; INPUT STRING TRANSFORM FOR PHX AND FHX
N NARR,NIEN,%,A,B,X,Y,%DT
I DATA[".01|`" G HNARR
S DATA=$$ICD(DATA,.01) I DATA="" Q ""
HNARR I DATA'[".04|'" G HDT
S DATA=$$NARR(DATA,.04)
HDT I DATA'[".03|" Q DATA
S X=+$P(DATA,".03|",2) I X?7N Q DATA
S %DT="" D ^%DT
I Y'?7N Q DATA
S A=$P(DATA,".03|")
S B=$P(DATA,".03|",2) S B=$P(B,$C(30),2)
S DATA=A_".03|"_Y
I $L(B) S DATA=DATA_$C(30)_B
Q DATA
;
POV(DATA) ; POV INPUT STRING TRANSFORM
N NARR,NIEN,%
I DATA[".01|`" G PVNARR
S DATA=$$ICD(DATA,.01) I DATA="" Q ""
PVNARR I DATA'[".04|'" Q DATA
S DATA=$$NARR(DATA,.04)
Q DATA
;
PROB(DATA,UFLG) ; PROBLEM LIST INPUT STRING TRANSFORM
N NARR,NIEN,%,PNUM,FACIEN,DFN,X,A,B
PNARR I DATA'[".05|" G PICD
S %=$P(DATA,".05|",2)
S NARR=$P(%,$C(30))
I NARR'?1"`"1.N S DATA=$$NARR(DATA,.05) ; STUFF THE NARR LOOKUP VALUE IN THE DATA STRING
I '$L(DATA) Q ""
PICD S %=$P(DATA,"|") I %'=.01,DATA'[($C(30)_".01|") G PNUM
S DATA=$$ICD(DATA,.01) I DATA="" Q ""
PNUM I $G(UFLG)="E" Q DATA ; STOP HERE IF IN EDIT MODE
I $P(DATA,($C(30)_".07|"),2) G TODAY ; GET NEXT PROB NUM
S DFN=+$P(DATA,".02|`",2)
I 'DFN S DATA="" Q ""
S FACIEN=+$P(DATA,".06|`",2)
I 'FACIEN Q ""
S PNUM=$$NEXTPBN(DFN,FACIEN)
I 'PNUM Q ""
S X=$L(DATA,$C(30))
S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X)
S DATA=A_$C(30)_".07|"_PNUM_$C(30)_B
TODAY I $P(DATA,($C(30)_".08|"),2) Q DATA ; GET TODAY'S DATE
S X=$L(DATA,$C(30))
S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X)
S DATA=A_$C(30)_".08|"_$G(DT)_$C(30)_B
Q DATA
;
NOTE(DATA,PIEN,FNIEN) ; GIVEN A DATA STRING CONTAINING THE NOTE, THE PROBLEM IEN, AND THE FAC-NOTE IEN:
; ADD NOTE # AND STATUS TO THE DATA STRING
I $G(DATA)'[".03|" Q ""
I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q ""
N NUM
I DATA'[".04|" S DATA=".04|A"_$C(30)_DATA
I DATA'[".01|" D
. S NUM=$$NEXTNOTE(PIEN,FNIEN)
. I 'NUM Q
. S DATA=".01|"_NUM_$C(30)_DATA
Q DATA
;
TI N XXX S XXX=$$ICD(".01|250.00"_$C(30)_".02|123"_$C(30)_".03|ABC",.01) W !,$TR(XXX,$C(30),"{") Q
ICD(DATA,FLD) ; VERIFY ICD CODE AND GET LOOKUP VALUE
I '$G(FLD) Q ""
I '$L($G(DATA)) Q ""
N %,A,B
S %=$P(DATA,"|")
I %=FLD D Q DATA
. S %=$P(DATA,"|",2)
. S %=$P(%,$C(30))
. I %?1"`"1.N Q
. S %=$O(^ICD9("BA",%_" ",0))
. I '% S DATA="" Q
. S A=$P(DATA,"|")
. S B=$P(DATA,"|",2,999)
. S B=$P(B,$C(30),2,999)
. S DATA=A_"|`"_%
. I $L(B) S DATA=DATA_$C(30)_B
. Q
S %=$P(DATA,($C(30)_FLD_"|"),2) D
. S %=$P(%,$C(30))
. I %?1"`"1.N Q DATA
. S %=$O(^ICD9("BA",%_" ",0))
. I '% S DATA="" Q
. S A=$P(DATA,($C(30)_FLD_"|"))
. S B=$P(DATA,($C(30)_FLD_"|"),2,999)
. S B=$P(B,$C(30),2,999)
. S DATA=A_$C(30)_FLD_"|`"_%
. I $L(B) S DATA=DATA_$C(30)_B
. Q
Q DATA
;
NARR(DATA,FLD) ; SUBSTITUTE A LOOKUP VALUE FOR NARRATIVE DATA IN THE DATA STRING
N A,B,C,X,Y,DIC,Z
I '$G(FLD) Q ""
I '$L($G(DATA)) Q ""
S Z=FLD_"|"
S A=$P(DATA,Z)
S B=$P(DATA,Z,2)
S NARR=$P(B,$C(30))
S NARR=$$UP^XLFSTR(NARR) ; CONVERT ALL NARRATIVE TO UPPERCASE
S C=$P(B,$C(30),2,999)
S DIC="^AUTNPOV(",DIC(0)="L",X=NARR
D ^DIC I Y=-1 Q ""
S DATA=A_FLD_"|`"_+Y
I $L(C) S DATA=DATA_$C(30)_C
D ^XBFMK
Q DATA
;
FACNIEN(PIEN,FIEN) ; GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN
I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
I '$D(^DIC(4,+$G(FIEN),0)) Q ""
N FNIEN
S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT
; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE
S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1
S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN
S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^"
S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)=""
Q FNIEN
;
NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY
N MAX,PIEN,X,Y
S MAX=0,PIEN=0
F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D ; FIND ALL PROBLEMS FOR THIS PATIENT
. S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q ""
. I $P(X,U,6)'=FIEN Q ; ONLY CHECK NUMBERS AT THIS FACILITY
. S Y=$P(X,U,7)
. I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR
. Q
S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER
Q MAX
;
NN W $$NEXTNOTE(3,1) Q
NEXTNOTE(PIEN,FNIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY-NOTE IEN
I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q ""
N MAX,NIEN,X,Y
S MAX=0,NIEN=0
F S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN D
. S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q
. S Y=+X
. I Y>MAX S MAX=Y
. Q
S MAX=MAX+1
Q MAX
;
PIENN(PIEN) ; GIVEN A PROBLEM IEN, RETURN PROBLEM NARRATIVE (ICD)
N X,IIEN,NIEN,NARR,ICD
S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q ""
S IIEN=$P(X,U) I 'IIEN Q ""
S NIEN=$P(X,U,5) I 'NIEN Q ""
S ICD=$P($G(^ICD9(IIEN,0)),U) I '$L(ICD) Q ""
S NARR=$P($G(^AUTNPOV(NIEN,0)),U) I '$L(NARR) Q ""
S X=NARR_" ("_ICD_")"
Q X
;
Side by Side

After

Width:  |  Height:  |  Size: 6.6 KiB

82
m/BMXADOI.m Normal file
View File

@ -0,0 +1,82 @@
BMXADOI ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ;
;;2.1;BMX;;Jul 26, 2009
; CUSTOM IDENTIFIERS
;
;
;
DEMOID(DA) ; EP-RETURN RPMS DEMOGRAPHIC INFO FOR IDENTIFIER FIELD
N SEX,DOB,CHART,AGE,TRIBE,CC,X,Y,%,STG,FMDOB,NAME,S,SSN,CSTG,LOC,ABB
I '$D(^DPT(+$G(DA),0)) Q ""
S S=" "
S X=$G(^DPT(DA,0)),SEX=$P(X,U,2),Y=$P(X,U,3),NAME=$P(X,U),SSN=$P(X,U,9)
I '$L(NAME) Q ""
I Y,$G(DT) S AGE=(DT-Y)\10000
I Y X ^DD("DD") S DOB=Y
S LOC=0,CSTG=""
F S LOC=$O(^AUPNPAT(DA,41,"B",LOC)) Q:'LOC D ; GET ALL THE CHART NUMBERS
. S CHART=$O(^AUPNPAT(DA,41,"B",LOC,0)) I '$L(CHART) Q
. S ABB=$P($G(^AUTTLOC(LOC,0)),U,7) I '$L(ABB) Q
. I $L(CSTG) S CSTG=CSTG_", "
. S CSTG=CSTG_ABB_" #"_CHART
. Q
I $G(DUZ(2)) S CHART=$P($G(^AUPNPAT(DA,41,DUZ(2),0)),U,2)
S %=$P($G(^AUPNPAT(DA,11)),U,8) I % S TRIBE=$P($G(^AUTTTRI(%,0)),U)
S CC=$P($G(^AUPNPAT(DA,11)),U,18)
S STG=NAME
I $L(CSTG) S STG=STG_CSTG_" --"
I $G(AGE),$L(SEX) S STG=STG_S_AGE_" y/o "_SEX
I '$G(AGE),$L(SEX) S STG=STG_S_SEX
I $L($G(DOB)) S STG=STG_S_DOB
I $L($G(SSN)) S STG=STG_S_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
I $L($G(TRIBE)) S STG=STG_S_TRIBE
I $L($G(CC)) S STG=STG_S_CC
Q STG
;
DATE(DATE) ; TEST TRIGGER
Q DATE
;
NAME(VIEN) ; RETURN THE PATIENT'S NAME
I '$G(VIEN) Q ""
N DFN
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q ""
Q $$GET1^DIQ(2,DFN_",",.01)
;
SEX(VIEN) ; RETURN THE PATIENT'S SEX
I '$G(VIEN) Q ""
N DFN
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q ""
Q $$GET1^DIQ(2,DFN_",",.02)
;
HRN(VIEN) ; RETURN THE CHART NUMBER FOR VISIT TRIGGER
I '$G(VIEN) Q ""
N DFN,LOC
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q ""
S LOC=$P($G(^AUPNVSIT(VIEN,0)),U,6) I 'LOC Q ""
Q $$HRN^AUPNPAT(DFN,LOC,2)
;
DOB(VIEN) ; RETURN THE PATIENT'S DOB
I '$G(VIEN) Q ""
N DFN,LOC
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q ""
Q $$DOB^AUPNPAT(DFN,"E")
;
SSN(VIEN) ; RETURN THE PATIENTS DOB
I '$G(VIEN) Q ""
N DFN,LOC
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q ""
Q $$SSN^AUPNPAT(DFN)
;
VISDATE(VIEN) ; RETURN THE DATE OF THE VISIT
I '$G(VIEN) Q ""
N FMDT
S FMDT=+$G(^AUPNVSIT(VIEN,0))\1 I 'FMDT Q ""
S %=$$FMTE^XLFDT(FMDT,1)
G TD1
;
TODAY(VIEN) ; RETURN TODAY'S DATE
I '$G(DT) Q ""
S %=$$FMTE^XLFDT(DT,1)
TD1 S %=$$UP^XLFSTR(%)
S %=$P(%," ",1,2)_$P(%," ",3)
Q %
;
Side by Side

After

Width:  |  Height:  |  Size: 2.2 KiB

264
m/BMXADOS.m Normal file
View File

@ -0,0 +1,264 @@
BMXADOS ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE ;
;;2.1;BMX;;Jul 26, 2009
; ENABLES NAVIGATION TO SUBFILES PRIOR TO UPDATING THE SCHEMA FILE ENTRY
;
;
;
UPDATE ; UPDATE THE SCHEMA FILE
N DIC,X,Y,%,STOP,FIEN,FNAME,SNAME,SIEN
UDIC S DIC("A")="Enter schema name: " ; EP FROM VENPCCTU
S DIC(0)="AEQLM",DIC="^BMXADO("
D ^DIC I Y=-1 G FIN
SCHEMA S SNAME=$P(Y,U,2),SIEN=+Y
S FIEN=$$FILE(SIEN) I 'FIEN G FIN
I FIEN'=$P($G(^BMXADO(SIEN,0)),U,2) S DIE=DIC,DA=SIEN,DR=".02////^S X=FIEN" D ^DIE
F D FLD(FIEN,SIEN) I $G(STOP) Q ; GET FIELD INFO
FIN D ^XBFMK
Q
;
FLD(FIEN,SIEN) ; GET THE FIELD
N DIC,X,Y,DIE,DA,DR,FLDIEN,FLDNAME,FLDTYPE,FDEF,TRANS
N %,%Y,HDR,DTYPE,LEN,FARR,I,TOT,PAUSE,PFLAG,IFLAG,IMSG,STG,READ
D FLIST(.FARR,FIEN,0)
S TOT=$O(FARR(9999),-1) I 'TOT S STOP=1 Q
W !,"Select a field from this "_$S($D(^DD(FIEN,0,"UP")):"sub-",1:"")_"file: "
S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I)
I $G(PAUSE)=U S STOP=1 Q
I $G(PAUSE) S Y=PAUSE G FLD1
S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a field from the list" K DA D ^DIR K DIR
I 'Y S STOP=1 Q
FLD1 S %=FARR(+Y)
S FLDIEN=+$P(%," [",2),FLDNAME=$P(%," [")
I $$FDEL(SIEN,FLDIEN) Q ; FIELD DELETED
S X=$$FDEF(FIEN,FLDIEN) I '$L(X) W " ??" Q
S DTYPE=$E(X),LEN=+$E(X,2,6)
S DIR(0)="F^1:30",DIR("A")="Column header",DIR("B")=FLDNAME D ^DIR K DIR
S HDR=Y,TRANS=0
S %=$P($G(^DD(FIEN,FLDIEN,0)),U,2) ; CHECK FM DD TO SEE IF FIELD IS REQUIRED
I %["R" W !,"FileMan requires a non-null value for this field" S %=2
E W !,"Is null allowed" S %=$S(FLDIEN=.01:2,1:1) D YN^DICN I %Y?1."^" Q
I %=2 S TRANS=1 ; NON NULL VALUE REQUIRED TO COMPLETE THE TRANSACTION OR THERE WILL BE ROLLBACK
I $G(PFLAG) D ; IF POINTER, ASK IF USER WANTS TO AUTOMATICALLY INSERT THE LOOKUP VALUE FIELD IN THE SCHEMA
. W !,"This field is a pointer value (IEN)."
. W !,"Want to automatically insert the lookup value in the schema"
. S %=2 D YN^DICN W ! I %=1 S PFLAG=2
. Q
IFLG I $G(IFLAG) D ; NON-POINTER .01 FIELD. ASK IF USER WANTS TO REFERENCE IDENTIFIER EP
. W !,"Want to display identifiers with this field"
. S %=2 D YN^DICN W ! I %'=1 Q
. S IMSG="Respond with a valid entry point in the format 'TAG^ROUTINE'."
. W !,"Entry Point to generate Identifiers: " R Y:$G(DTIME,60) E Q
. I Y?1."^" Q
. I Y?1."?" W !,IMSG S IFLAG(0)="!" Q
. I Y'?1U.7UN1"^"1U.7UN S IFLAG(0)="!" W " ??"
. I $L(Y)>2 S IFLAG(0)=Y,IFLAG=2
. Q
I $G(IFLAG(0))="!" W !,IMSG K IPFLAG(0),IMSG W !!! G IFLG
S DA(1)=SIEN,DIC="^BMXADO("_DA(1)_",1,"
S DIC("P")=90093.991,DIC(0)="L",X=FLDIEN
I '$D(^BMXADO(SIEN,1,0)) S ^BMXADO(SIEN,1,0)="^90093.991^^"
D ^DIC I Y=-1 Q
S READ=($P($G(^DD(FIEN,FLDIEN,0)),U,2)["C") ; COMPUTED FIELDS ARE READ ONLY!
S DIE=DIC,DA=+Y
S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
D ^DIE
I $G(IFLAG)=2 D ID
I $G(PFLAG)'=2 Q
LKUP ; AUTOMATICALLY ADD A LOOKUP FIELD TO THE SCHEMA
S X=FLDIEN_"IEN"
D ^DIC I Y=-1 Q
W !,"The LOOKUP field '"_X_"' has been added to the schema",!
S HDR=HDR_"_IEN",DTYPE="I",LEN="00009"
S DIE=DIC,DA=+Y
S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
D ^DIE
Q
;
ID ; AUTOMATICALLY ADD AN IDENTIFIER REFERENCE
N X,Y,DIE,DR,DA,REF
S X=".01ID",DA(1)=SIEN
S REF=IFLAG(0) I '$L(REF) Q
D ^DIC I Y=-1 Q
W !,"The identifier field '"_X_"' has been added to the schema",!
S HDR=HDR_"_ID",DTYPE="T",LEN="00017"
S DIE=DIC,DA=+Y
S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS);1///^S X=REF"
D ^DIE
Q
;
FDEL(SIEN,FIELD) ; DELETE AN EXISTING ENTRY FROM THE 'FIELD' MULTIPLE. RETURN '1' IF THE RECORD WAS DELETED
N FIEN,DA,DIK
S FIEN=$O(^BMXADO(SIEN,1,"B",FIELD,0)) I 'FIEN Q 0 ; THIS IS A NEW ENTRY
W !,"This field already is attached to the schema. Want to delete it"
S %=2 D YN^DICN
I %'=1 Q 0
S DA(1)=SIEN,DIK="^BMXADO("_DA(1)_",1,",DA=FIEN
D ^DIK
S FIEN=$O(^BMXADO(SIEN,1,"B",(FIELD_"IEN"),0))
I FIEN S DA=FIEN D ^DIK ; DELETE LOOKUP VALUE FIELD AS WELL
W " Done!",!
Q 1
;
FDEF(FILE,FIELD) ;EP - GIVEN A FILEMAN FILE AND FIELD, RETURN THE DATA DEFINITION IN ADO FORMAT
N %,X,Y,Z,STG,I,DTYPE,FNAME,LEN,DNAME
I '$D(^DD(+$G(FILE),+$G(FIELD),0)) Q ""
S STG=$G(^DD(FILE,FIELD,0)) I '$L(STG) Q "" ; GET DATA DEF STRING
DTYPE S %="DNSFWCPVM",X=$P(STG,U,2),DTYPE="" ; GET DATA TYPE
F I=1:1:$L(%) S Y=$E(%,I) I X[Y S DTYPE=Y Q
I DTYPE="" Q ""
FNAME S DNAME=$P(STG,U) I '$L(DNAME) Q "" ; FIELD NAME
DDA ; ADO FORMAT
I DTYPE="D" D Q "D"_LEN_DNAME
. S LEN="00021"
. I STG["S %DT=" S %=$P(STG,"S %DT=",2),%=$P(%,$C(34))
. I $G(FLDIEN)=.01 S IFLAG=1
. I %["S" S LEN="00019" Q
. I %["T" S LEN="00018" Q
. Q
I DTYPE="N",STG["1N.N" D Q:'LEN "" Q "I"_LEN_DNAME ; INTEGER
. S %=+$P(STG,"K:+X'=X!(X>",2)
. S Y=$L(%)
. S LEN=$E("00000",1,5-$L(Y))_Y
. Q
I DTYPE="N" D Q:'LEN "" Q "N"_LEN_DNAME ; NUMBER (COULD HAVE A DECIMAL VALUE)
. S %=+$P(STG,"!(X?.E1"".""",2)
. S X=+$P(STG,"K:+X'=X!(X>",2)
. S Y=%+($L(+X))
. S LEN=$E("00000",1,5-$L(Y))_Y
. Q
I DTYPE="F" D Q:'LEN "" Q "T"_LEN_DNAME
. S Y=+$P(STG,"K:$L(X)>",2)
. S LEN=$E("00000",1,5-$L(Y))_Y
. I 'LEN S LEN="00030"
. I $G(FLDIEN)=.01 S IFLAG=1
. Q
I DTYPE="S" D Q:'LEN "" Q "T"_LEN_DNAME
. S X=$P(STG,U,3),Y=0
. F I=1:1:$L(X,":") S Z=$P(X,":",2),Z=$P(Z,";"),%=$L(Z) I %>Y S Y=%
. S LEN=$E("00000",1,5-$L(Y))_Y
. Q
I DTYPE="P" S PFLAG=1 Q "T00030"_DNAME
I DTYPE="W" Q "T05000"_DNAME
I DTYPE="V" Q ""
Q "T00250"_DNAME
;
FILE(SIEN) ; GET THE FILE OR SUBFILE NUMBER
N FNO,FIEN,DIC,X,Y,%,FILE,NSTG,GBL,FNAME,SUB,FARR,TOT,I
S (FILE,FNO)=$P(^BMXADO(SIEN,0),U,2)
OLD I FNO D I $G(FIEN) Q FIEN
. S NSTG=$O(^DD(FNO,0,"NM",""))
. F S FNO=$G(^DD(FNO,0,"UP")) Q:'FNO S NSTG=$O(^DD(FNO,0,"NM",""))_"/"_NSTG
OLD1 . W !,$S(NSTG["/":"Sub-",1:""),"File #",FILE," (",NSTG,") is linked to this schema."
. W !,"Want to keep it" S %=1
. D YN^DICN I %'=2 W:%=1 " OK" S FIEN=FILE Q
. W !!,"If you change or delete this file number,",!,"all the information in this schema will be deleted."
. W !,"Are you sure you want to do this" S %=2 D YN^DICN
. I %'=1 W !! G OLD1
. S GBL="^BMXADO("_SIEN_")"
. K @GBL@(1),@GBL@(2)
. S $P(@GBL@(0),U,2)=""
. W !,"This schema definition has been deleted. You may redefine it now"
. Q
NEW S DIC=1,DIC(0)="AEQM" D ^DIC I Y=-1 Q ""
S FNO=+Y,FNAME=$P(Y,U,2)
NEW1 D SC(.FARR,FNO,1)
S TOT=$O(FARR(999999),-1) I 'TOT Q FNO ; NO SUBFILES FOUND
W !!,"The ",FNAME," file contains the following sub-file" I TOT>1 W "s"
W !
S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I)
I $G(PAUSE)=U Q ""
I $G(PAUSE) S Y=PAUSE G NEW2
W !!,"Is the schema linked to a sub-file in this list"
S %=2 D YN^DICN I %=2 Q FNO
S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a sub-file from the list" K DA D ^DIR K DIR
I 'Y Q ""
NEW2 Q +$P(FARR(+Y)," (",2)
;
PAUSE(I) ; SCROLL CHECK
N %
W !
I (I#20) Q ""
W "Select a number from the list (1-",(I-1),") or press <ENTER> to continue: "
R %:$G(DTIME,60) E Q ""
I %?1."^" Q U
I $L(%),$D(FARR(I)) Q %
I $L(%) W " ??" H 2
W $C(13),?79,$C(13)
Q ""
;
SC(OUT,FILE,MODE) ;EP - SUB CRAWLER. GIVEN A FILE NUMBER RETURN ALL OF ITS DESCENDANT FILES IN AN ARRAY
I '$D(^DD(FILE,"SB")) Q ; NO DESCENDANTS
N TOT,FNO,FNAME,FIEN,LEVEL,NODE,SARR,STG,X,%,UP,ARR
S FIEN=FILE,TOT=0
D PASS1
I '$O(ARR(0)) Q
SC2 ; SECOND PASS. BUILD THE INTERMEDIATE ARRAY
S FNO=0 F S FNO=$O(ARR(FNO)) Q:'FNO D
. I $P($G(^DD(FNO,.01,0)),U,2)["W" K ARR(FNO) Q ; WORD PROCESSING FIELDS DO NOT COUNT
. S STG=FNO,UP=FNO
. F S UP=$G(^DD(UP,0,"UP")) Q:'UP S STG=UP_","_STG ; BUILD DESCENDANT STRING
. I $G(MODE) S STG=$$ASTG(STG)
. S STG=$P(STG,",",2,99) ; DONT NEED TOP LEVEL FILE
. I '$L(STG) Q ; SOMETHING IS SCREWED UP
. S LEVEL=$L(STG,",")
. S FNAME=$O(^DD(FNO,0,"NM",""))
. S X="SARR("_STG_")"
. S @X=FNAME_U_LEVEL_U_FNO
. K ARR(FNO)
. Q
SC3 ; 3RD PASS. BUILD OUTPUT ARAY
S NODE="SARR"
F S NODE=$Q(@NODE) Q:NODE="" D
. S X=@NODE
. S TOT=TOT+1
. S FNAME=$P(X,U)
. S LEVEL=$P(X,U,2)
. S FNO=$P(X,U,3)
. S OUT(TOT)=$E(" ",1,LEVEL)_FNAME_" ("_FNO_")"
. Q
Q
;
PASS1 ; PASS 1. BUILD THE ARRAY OF ALL SUBFILES
N FNO S FNO=0
F S FNO=$O(^DD(FIEN,"SB",FNO)) Q:'FNO D
. S ARR(FNO)=""
. I '$D(^DD(FNO,"SB")) Q
. N FIEN S FIEN=FNO
. D PASS1 ; RECURSION!!
. Q
Q
;
ASTG(STG) ; CONVERT STRING FROM FILE NUMBERS TO FILE NAMES
N PCE,LEV,FNO,NAME
S LEV=$L(STG,",")
F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D I '$L(STG) Q ""
. S NAME=$O(^DD(FNO,0,"NM",""))
. I $E(NAME)="*" S NAME=$E(NAME,2,99)
. I '$L(NAME) S STG="" Q
. S $P(STG,",",PCE)=""""_NAME_""""
. Q
Q STG
;
FLIST(OUT,FILE,MODE) ;EP - GIVEN A FILE RETURN THE FILEDS IN AN ARRAY MODE=0: NUMERIC ORDER, MODE=1: ALPHA ORDER
; ONLY NON MULTIPLES AND WORD PROCESSING FIELDS ARE LISTED
N FLD,TOT,NAME,ARR,SS,%,WP
S FLD=0,TOT=0
F1 F S FLD=$O(^DD(FILE,FLD)) Q:'FLD D ; PASS 1
. S STG=$G(^DD(FILE,FLD,0)) I '$L(STG) Q
. S %=$P(STG,U,2)
. I %,$P($G(^DD(%,.01,0)),U,2)'["W" Q ; EXCLUDE ALL MULTIPLE FIELDS EXCEPT WORD PROCESSING FIELDS
. S WP=0 I % S WP=1
. S NAME=$P(STG,U)
. S SS=FLD
. I $G(MODE)=1 S %=NAME S:$E(%)="*" %=$E(%,2,99) S SS=%
. S ARR(SS)=FLD_U_NAME_U_WP
. Q
F2 S SS=""
F S SS=$O(ARR(SS)) Q:SS="" D
. S TOT=TOT+1
. S %=ARR(SS)
. S OUT(TOT)=$P(%,U,2)_" ["_+%_"]"_$S($P(%,U,3):" (word processing)",1:"")
. K ARR(SS)
. Q
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 9.2 KiB

106
m/BMXADOS1.m Normal file
View File

@ -0,0 +1,106 @@
BMXADOS1 ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE GUI VERSION ;
;;2.1;BMX;;Jul 26, 2009
; RPC CALLS
;
;
;
DISP(OUT) ; TEMP DISPLAY
N I,X
S I=0 W !
F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X
Q
;
SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN
N IEN
S IEN=$O(^BMXADO("B",NAME,0))
Q IEN
;
FILE ; RETURN A LIST OF FILES
N OUT,%,SIEN
S SIEN=$$SCHEMA("FILEMAN FILES")
D SS^BMXADO(.OUT,SIEN,"","B~B~C~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
SF ; RETURN A LIST OF SUBFILES
N OUT,%,SIEN
S SIEN=$$SCHEMA("SUBFILES")
D SS^BMXADO(.OUT,SIEN,"","~~~~~SFIT~BMXADOS1~2~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
FLD ; RETURN LIST OF FIELDS FOR A FILE OR SUBFILE
N OUT,%,SIEN
S SIEN=$$SCHEMA("FIELDS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~FLDIT~BMXADOS1~2~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
SCH ; RETURN A LIST OF SCHEMAS
N OUT,%,SIEN
S SIEN=$$SCHEMA("SCHEMAS")
D SS^BMXADO(.OUT,SIEN,"","B~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
SD ; RETURN THE SCHEMA DEFINITION
N OUT,%,SIEN
S SIEN=$$SCHEMA("SCHEMA DEFINITION")
D SS^BMXADO(.OUT,SIEN,"52,","~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
FLDIT(PARAM,IENS,MAX,OUT,TOT) ; CUSTOM ITERATOR TO DISPLAY FIELDS
N SFARR,CNT,DEL,NUM,NAME,DDT,DLEN,DHDR,DRO,DKEY,DNA,X,Y
D FLIST^BMXADOS(.SFARR,PARAM)
S CNT=0,DEL=" ["
F S CNT=$O(SFARR(CNT)) Q:'CNT D
. S X=SFARR(CNT) I '$L(X) Q
. S NAME=$P(X,DEL)
. ; F Q:$E(NAME)'=" " S NAME=$E(NAME,2,999)
. I '$L(NAME) Q
. S NUM=+$P(X,DEL,2) I 'NUM Q
. S TOT=TOT+1
. S Y=$$FDEF^BMXADOS(PARAM,NUM) I '$L(Y) Q ; ""
. S DDT=$E(Y),DLEN=+$E(Y,2,6),DHDR=$E(Y,7,99)
. S DRO="NO" S DKEY="NO" S DNA="YES"
. S ^TMP("BMX ADO",$J,TOT)=NUM_U_NAME_U_DDT_U_DLEN_U_DHDR_U_DRO_U_DKEY_U_DNA_$C(30)
Q ""
;
FNIT(PARAM,IENS,MAX,OUT,TOT) ; CUSTOM ITERATOR TO DISPLAY FILE OR SUBFILE NAME GIVEN FILE NUMBER
N NUM,NAME
S NUM=+PARAM
S NAME=""
Q:'$D(^DD(NUM,0,"NM")) ""
S NAME=$O(^DD(NUM,0,"NM",0))
S TOT=TOT+1
S ^TMP("BMX ADO",$J,TOT)=NUM_U_NAME_$C(30)
Q ""
;
SFIT(PARAM,IENS,MAX,OUT,TOT) ; CUSTOM ITERATOR TO DISPLAY SUBFILES
N SFARR,CNT,DEL,NUM,NAME
D SC^BMXADOS(.SFARR,PARAM)
S CNT=0,DEL=" ("
F S CNT=$O(SFARR(CNT)) Q:'CNT D
. S X=SFARR(CNT) I '$L(X) Q
. S NAME=$P(X,DEL)
. ; F Q:$E(NAME)'=" " S NAME=$E(NAME,2,999)
. I '$L(NAME) Q
. S NUM=+$P(X,DEL,2) I 'NUM Q
. S TOT=TOT+1
. S ^TMP("BMX ADO",$J,TOT)=NUM_U_NAME_$C(30)
Q ""
;
SFT(FNAME) ; TRIGGER "YES" TO INDICATE THAT A SUBFILE IS PRESENT WITHIN A FILE
I '$L($G(FNAME)) Q ""
N FIEN
S FIEN=$O(^DIC("B",FNAME,0))
I 'FIEN Q ""
I '$O(^DD(FIEN,"SB",0)) Q ""
Q "+"
;
Side by Side

After

Width:  |  Height:  |  Size: 2.6 KiB

122
m/BMXADOV.m Normal file
View File

@ -0,0 +1,122 @@
BMXADOV ; CIHA/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET
;;2.1;BMX;;Jul 26, 2009
;
;
;
; VSTG = VIEW STRING: SCHEMA NAME OR IEN~DAS~INDEX~START~STOP~MAX~FORMAT~TAG~ROUTINE~PARAM~JOIN
; SCHEMA NAME/IEN: FROM THE BMX ADO SCHEMA FILE
; DAS: THE DA STRING. HIGHEST LEVEL IS FIRST, FOLLOWED BY SUBFILE IENS. CAN BE CONVERTED TO AN 'IENS' STRING.
; IF THE LAST ',' PIECE OF DAS IS DEFINED, THAT IS USED AS THE CURRENT STARTING SEED POINT FOR THE ITERATOR
; THE NEXT INDEX VALUE AFTER THE SEED POINT WILL BE THE FIRST ENTRY SELECTED FOR THE CURRENT TRANSACTION
; INDEX: THE INDEX THAT RUNS THE ITERATOR. IF NULL, THE ITERATOR WULL CYCLE BY IEN
; START: STARTING LOOKUP VALUE IN THE OVERALL ITERATION (THE FIRST VALUE THAT CAN BE USED IN SPECIFIED INDEX)
; STOP: THE LAST LOOKUP VALUE IN THE OVERALL ITERATION (THE LAST VALUE USED IN SPECIFIED INDEX)
; START AND STOP MUST BE IN THE FORMAT (INTERNAL OR EXTERNAL) USED BY THE INDEX
; IF THE INDEX IS ON A POINTER FIELD, AND POINTED TO FILED IS DINUMNED, THEN THE EXTERNAL VALUE CAN BE USED
; MAX: MAXIMUM NUMBER OF ENTRIES REURNED IN THE TRANSACTION
; FORMAT: RETURN INTERNAL OR EXTERNAL VALUES IN THE DATASET
; TAG AND ROUTINE: ENTRY POINT FOR CUSTOM/COMPLEX ITERATION
; PARAM: PARAMETER STRING PASSED TO THE ITERATOR ENTRY POINT.
; ALSO USED WITH THE AA INDEX TO DEFINE PATIENT DFN, V FILE ATTRIBUTE TYPE AND SORT ORDER (C OR R)
; E.G., 1|WT|R COULD BE PATIENT #1, MEASUREMENT TYPE="WEIGHT" AND REVERSE CHRONOLICAL PRESENTATION OF DATA
; JOIN: JOIN INSTRUCTIONS; E.G., ...~2,4,.04|2,5,.07|4,9,SUB"
;
;
VIEW(OUT,VSTG,TOT) ; EP-VIEW A DATA SET ; GATEWAY TO ALL ITERATORS
;
; DON'T CALL THIS EP UNLESS YOU WANT DATA RETURNED WITH THE SCHEMA!
; INPUT: VSTG AND THE TOTAL NUMBER OF NODES IN THE SCHEMA ARRAY
; OUTPUT: THE DATA NODES AND THE SEED (SEED IS STUFFED INTO 3RD PIECE OF INTRODUCTORY NODE OF SCHEMA ARRAY)
; RETURNS THE ADO DATASET IN THE ARRAY SPECIFIED BY 'OUT'
; THE SEED IS ALWAYS RETURNED IN 'LDA' REGARDLESS OF WHAT ITERATOR IS USED
; IF ITERATION IS COMPLETED THE SEED WILL HAVE A NULL VALUE
;
;
;
N DAS,DA,IX,START,STOP,MAX,FMT,EP,IENS,OREF,CREF,FIEN,TAG,ROUTINE,X,Y,%,PARAM,NUM,FINFO,LIEN,LDA,LFILE,%DT,T
S SIEN=+$G(VSTG) I SIEN,'$D(^BMXADO(SIEN,0)) S ERR="Invalid schema IEN" D ERR^BMXADO(ERR) Q
I $G(TOT)<2 S ERR="Missing schema string" D ERR^BMXADO(ERR) Q ; MUST HAVE A VALID SCHEMA STRING FOR EACH TRANSACTION
INIT ; INITIALIZE VARIABLES
S T="~"
S FIEN=$P(^BMXADO(SIEN,0),U,2) I '$D(^DD(FIEN,0)) S ERR="Invalid file number in schema file" D ERR^BMXADO(ERR) Q
S DAS=$P(VSTG,T,2),IX=$P(VSTG,T,3)
S START=$P(VSTG,T,4),STOP=$P(VSTG,T,5),MAX=$P(VSTG,T,6)
I $L(START),$L(STOP),START,START=+START,STOP,STOP=+STOP
S %=$T ; NUMERIC START AND STOP
I %,START>STOP S ERR="Invalid start stop pair" D ERR^BMXADO(ERR) Q
I '%,$L(START),$L(STOP),START]STOP S ERR="Invalid start stop pair" D ERR^BMXADO(ERR) Q
I $L(MAX),(MAX'>0!(MAX'=MAX\1)) S ERR="Invalid MAX parameter" D ERR^BMXADO(ERR) Q
S FMT=$P(VSTG,T,7),TAG=$P(VSTG,T,8),ROUTINE=$P(VSTG,T,9),PARAM=$P(VSTG,T,10),NUM=0
I $L(TAG),'$L(ROUTINE) S ERR="Invalid EP info" D ERR^BMXADO(ERR) Q
S EP=TAG_U_ROUTINE I EP=U S EP=""
I $L(EP) X ("S %=$L($T("_EP_"))") I '% S ERR="Invalid EP info" D ERR^BMXADO(ERR) Q
I FMT='"I" S FMT=""
I MAX="" S MAX=100
I $G(JOIN) S MAX=999999999 ; MAX IS UNLIMITED FOR SECONDARY DATA SETS DURING JOINS
S IENS=$$IENS(DAS) ; CONVERT DA STRING TO IEN STRING ; DAS AND IENS MUST BE AVAILABLE TO ALL ITERATORS
S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) S ERR="Unable to generate a vaild open reference" D ERR^BMXADO(ERR) Q
S CREF=$$CREF^DILF(OREF) I '$L(CREF) S ERR="Unable to generate a vaild closed reference" D ERR^BMXADO(ERR) Q
DATA ; GET DATA
SPEC I $L(EP) D Q ; SPECIAL CASE: USE CUSTOM ITERATOR
. I '$G(LDA) S LDA=""
. X ("S LDA=$$"_EP_"(PARAM,IENS,MAX,.OUT,.TOT)")
. D SEED(LDA)
. Q
I IX="" S LDA=$$NUMIT^BMXADOV1(+$G(DA)) D SEED(LDA) Q ; NO INDEX USED: ITERATE IN IEN ORDER
I IX="AA",FIEN=9000013!(FIEN=9000019) S IX="AC" ; 'AA' ITERATION UNNECESSARY FOR SOME FILES. BETTER TO USE 'AC'
I '$L($O(@CREF@(IX,""))) Q ; NO INDEXED DATA AVAILABLE, SO QUIT NOW
I IX="AA" D Q ; SPECIAL CASE: AA INDEX
. I FIEN=9000011 S LDA=$$AAP^BMXADOV1 Q ; THE AA INDEX FOR 'PROBLEMS'; LDA ALWAYS NULL
. S LDA=$$AA^BMXADOV1 D SEED(LDA) ; THE VISIT/V-FILE AA INDEX
. Q
S FINFO=$$IXFLD(FIEN,IX) I FINFO="" Q ; FILE INFO: IX FIELD NUMBER, TYPE, AND DINUM SUBTYPE
I $P(FINFO,U,2)="D" D ; PREP FOR DATE INDEX LOOKUP
. I $L(START) S X=START D ^%DT S START=+Y
. I $L(STOP) S X=STOP D ^%DT S STOP=+Y
. Q
I $P(FINFO,U,2)="P",$E(START)="`" D Q ; SPECIAL CASE: SHORTCUT TO POINTER LOOKUP FOR A SINGLE, SPECIFIC IEN.
. S LIEN=+$E(START,2,99)
. S LDA=$$LOOK^BMXADOV1(LIEN)
. D SEED(LDA)
. Q
I $P(FINFO,U,4) S LFILE=$P(FINFO,U,3) I LFILE D Q ; SPECIAL CASE: DINUM -> TEXT LOOKUP.
. S LDA=$$LOOK2^BMXADOV1(LFILE)
. D SEED(LDA)
. Q
S LDA=$$LOOK1^BMXADOV1 ; STD INDEX LOOKUP: START FROM SCRATCH
D SEED(LDA) ; CAPTURE RE-ENTRY SEED
Q
;
SEED(LDA) ; UPDATE THE SCHEMA STRING WITH THE SEED PARAMETER
N X,Y
S X=@OUT@(1)
S Y=$P(X,U)
S $P(Y,"|",3)=LDA
S $P(X,U,1)=Y
S @OUT@(1)=X
Q
;
IENS(DAS) ;EP - CONVERT DAS STRING TO IENS STRING
N I,L,IENS
S DAS=$G(DAS)
S DAS=$TR(DAS,"+","")
S DAS=$TR(DAS,"-","")
I '$L(DAS) Q ","
I DAS="," S DAS=""
S L=$L(DAS,C)
S IENS=""
F I=L:-1:1 S IENS=IENS_$P(DAS,C,I)_C
Q IENS
;
IXFLD(FIEN,IX) ;EP - GIVEN AN FILE NUMMER AND INDEX NAME, RETURIN THE FIELD NUMBER, TYPE, AND DINUM SUBTYPE
N FLD,TYPES,T,X,I
I '$G(FIEN) Q ""
I '$L($G(IX)) Q ""
S FLD=$O(^DD(FIEN,0,"IX",IX,FIEN,0))
I 'FLD Q FLD
S TYPES="DNSFWCPVM",T=$P($G(^DD(FIEN,FLD,0)),U,2)
F I=1:1 S X=$E(TYPES,I) Q:'$L(X) I T[X Q
I X="P" S X=X_U_+$P(T,"P",2) I $P(^DD(FIEN,FLD,0),U,5)["DINUM" S X=X_U_1
S FLD=FLD_U_X
Q FLD
;
Side by Side

After

Width:  |  Height:  |  Size: 5.7 KiB

229
m/BMXADOV1.m Normal file
View File

@ -0,0 +1,229 @@
BMXADOV1 ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ;
;;2.1;BMX;;Jul 26, 2009
; CONTINUATION FILE FOR BMXADOV
; MANAGES ITERATION FOR INDIVIDUAL INDEX TYPES
; ASSUMES CERTAIN LOCAL VARS: CREF,FIEN,IENS,DAS (<-THESE CAN'T BE NULL),START,STOP,MAX,TOT,NUM,IX
;
;
;
DATA(IENS,DA,XCNT) ;EP - ADD DATA NODES TO ARRAY
; ASSUMES THAT VSTG VARIABLES AND THE OUT ARRAY ARE PRESENT
I '$G(DA) Q
I '$L(IENS) Q
S $P(IENS,C)=DA
N STG,X,Y,%,FLD,STOP,VAL,CNT,FIEN,LINE,IFLAG,IDEP,TFLD,TNO,TEF
S STG=DA
I $G(DAS),$E(DAS,$L(DAS))="," S STG=$TR(DAS,",",U)_STG ; FIX FOR SUBFILE
S CNT=$L(IENS,",") ; START AFTER THE .001 FIELD
I $G(SUB) S STG=$P(IENS,C,2)_U_DA ; MAKE DAS FOR A SUBFILE. THIS WILL BE THE IST PIECE OF THE DATA STRING
I $G(XCNT) S CNT=XCNT ; USED WITH JOINS
F S CNT=$O(@OUT@(CNT)) Q:'CNT Q:$G(STOP) D I @OUT@(CNT)[$C(30) Q ; LOOP TO CREATE THE DATA STRING
. K IFLAG,IDEP
. S FIEN=+@OUT@(CNT) I '$D(^DD(FIEN,0)) S STOP=1 Q
. S FLD=$P(@OUT@(CNT),B,2)
. I FLD=".01ID" D Q ; PROCESS THE IDENTIFIER FIELD
.. I '$G(SIEN) Q
.. S %=$O(^BMXADO(SIEN,1,"B",".01ID",0)) I '% Q
.. S IDEP=$G(^BMXADO(SIEN,1,%,1)) I '$L(IDEP) Q
.. X ("S VAL=$$"_IDEP_"("_+STG_")") ; PASS THE DA TO THE IDENTIFIER EXTRINSIC FUNCTION, RETURN IDENTIFIERS
.. S VAL=$TR(VAL,"^",""),VAL=$TR(VAL,B,"")
.. S STG=STG_U_VAL
.. Q
. I $G(SIEN),FLD S %=$O(^BMXADO(SIEN,1,"B",FLD,0)) I %,$P($G(^BMXADO(SIEN,1,%,0)),U,9) S IFLAG=1 ; SCHEMA FILE SAYS FORCE INTERNAL VALUE FOR THIS FIELD
. K TFLD
. I FLD["TRIGGER" S TFLD=FLD,FLD=+FLD,IFLAG=1
. I FLD["IEN" S FLD=+FLD,IFLAG=1 ; LOOKUP VALUE FIELD (IEN)
. I '$D(^DD(FIEN,FLD,0)),FLD'=.001 S STOP=1 Q
. I $D(TFLD),FLD=.001 S VAL=+IENS
. E S VAL=$$GET1^DIQ(FIEN,IENS,FLD,$S($G(IFLAG):"I",$G(TFLAG):"I",1:$G(FMT)))
. I $G(TFLD) D S STG=STG_U_VAL Q ; GENERATE A TRIGGERED VALUE FOR THIS FIELD
.. S TNO=$O(^BMXADO(SIEN,1,"B",TFLD,0)) I 'TNO S VAL="" Q
.. S TEF=$G(^BMXADO(SIEN,1,TNO,3)) I '$L(TEF) S VAL="" Q ; GET EXTR FUNCT THAT GENERATES A SECONDARY VALUE
.. X ("S VAL=$$"_TEF_"(VAL)")
.. Q
. I FLD=.01,VAL="" S STOP=1 Q ; INVALID FILEMAN ENTRY! SKIP IT
. S VAL=$TR(VAL,"^",""),VAL=$TR(VAL,B,"")
. S STG=STG_U_VAL
. Q
I $G(STOP) Q ; DON'T ADD NODE IF DD INFO IS INVALID
F S LINE=$E(STG,1,250),STG=$E(STG,251,999999) D I '$L(STG) Q ; PREVENTS DATA LENGTH FROM EXCEEDING 250 BYTES
. S TOT=TOT+1
. I '$L(STG) S LINE=LINE_$C(30),NUM=NUM+1 ; END OF RECORD, RECORD TOTAL IS UPDATED
. S @OUT@(TOT)=LINE ; NODE IS ADDED
. Q
Q
;
NUMIT(DA) ; EP-ITERATE BY NUMBER
N XIT,LDA
I IENS S DA=+IENS ; RE-ENTRY FROM SEED
I '$G(DA),$G(START) S DA=START-1
I '$G(DA) S DA=0
S LDA=""
F S DA=$O(@CREF@(DA)) D I $G(XIT) Q
. I 'DA S XIT=1,LDA="" Q ; NO MORE IENS - THE END OF THE LINE
. D DATA(IENS,DA,+$G(XCNT))
. I $G(STOP),$O(@CREF@(DA))>STOP S LDA="",XIT=1 Q ; AS FAR AS YOU ARE ALLOWED TO GO FOR NUMBER ITERATION
. I NUM=MAX S LDA=DA,XIT=1 Q ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME
. Q
I LDA,'$O(@CREF@(LDA)) S LDA="" ; END OF THE LINE SO SET LDA TO NULL
Q LDA
;
LOOK(LIEN) ; EP-ITERATE BY A SINGLE STANDARD INDEX THAT IS A POINTER VALUE
N XIT,LDA
S DA=+IENS
F S DA=$O(@CREF@(IX,LIEN,DA)) D I $G(XIT) Q
. I 'DA S XIT=1,LDA="" Q ; NO MORE IENS - THE END OF THE LINE
. D DATA(IENS,DA,$G(XCNT))
. I NUM=MAX S LDA=DA,XIT=1 Q ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME
. Q
I '$O(@CREF@(IX,LIEN,DA)) Q ""
Q LDA
;
LOOK1() ; EP-ITERATE USING A STANDARD INDEX
N XIT,LDA,VAL,DA,%
S DA=+IENS I 'DA G SCRATCH ; CHECK FOR RE-RENTRY
REENTER ; RE-ENTER STD ITERATION USING DA AS THE SEED
S %=$$IXVAL(FIEN,IX,DAS) I '$L(%) Q "" ; GET STARTUP INFO
LR S VAL=$P(%,B,3)
I VAL="" Q "" ; NO VAL FOUND FOR INITIAL ITERATION, SO QUIT
F S DA=$O(@CREF@(IX,VAL,DA)) Q:'DA D DATA(IENS,DA,+$G(XCNT)) I NUM=MAX S LDA=DA,XIT=1 Q ; SWEEP UP ALL THE REMAINING DAS UNDER THE CURRENT VALUE
I $G(XIT) Q:'$O(@CREF@(IX,VAL,LDA)) "" Q LDA ; IF NO MORE AFTER MAX, SET LDA = NULL
G LOOK1R ; SEED IS DEFINED
SCRATCH S VAL="" ; STD LOOKUP STARTING FROM SCRATCH
I $L(START) S VAL=$O(@CREF@(IX,START),-1) ; GET SEED FOR ITERATION
LOOK1R F S VAL=$O(@CREF@(IX,VAL)) D I $G(XIT) Q ; EP - RE-ENTRY POINT IF SEED IS DEFINED
. I VAL="" S LDA="",XIT=1 Q ; END OF THE LINE
. I STOP=+STOP,VAL=+VAL,VAL>STOP S LDA="",XIT=1 Q
. I $L(STOP),VAL]STOP S LDA="",XIT=1 Q ; LOOKUP LIMITS
. S DA=0
. F S DA=$O(@CREF@(IX,VAL,DA)) Q:'DA D I $G(XIT) Q
.. D DATA(IENS,DA,+$G(XCNT))
.. I NUM=MAX S LDA=DA,XIT=1 D ; TRANSACTION LIMIT ; CHECK FOR MORE
... I $O(@CREF@(IX,VAL,DA)) Q
... S %=$O(@CREF@(IX,VAL)) I %="" S LDA="" Q
... I $L(STOP),%]STOP S LDA="" Q
... I '$O(@CREF@(IX,%,0)) S LDA="" Q
... Q
.. Q
. Q
Q LDA
;
LOOK2(LFILE) ; EP-TEXT POINTER LOOKUP
; CHANGE THE GLOBAL REFERENCE FOR THE LOOKUP TO THE POINTED-TO FILE BEFORE PROCEEDING
N XIT,LDA,OREF,CREF,VAL,DA
S OREF=$$ROOT^DILFD(LFILE,IENS) I '$L(OREF) Q ""
S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""
S DA=+IENS
I '$G(DA) G SCRATCH ; START FROM SCRATCH
S %=$$IXVAL(LFILE,IX,DAS) I '$L(%) Q ""
G LR ; RE-ENTER
;
IXVAL(FIEN,IX,DAS) ; GIVEN A FILE IEN, INDEX NAME, AND DAS STRING, RETURN THE VALUE USED IN THE INDEX
N DA,FLD,IENS,OREF,CREF,XREF,VAL,UP,LEV,L
I '$D(^DD(+$G(FIEN),0)) Q "" ; MISSING OR INVALID FILE NUMBER
I '$L($G(IX)) Q "" ; NO INDEX SPECIFIED
S UP=FIEN F LEV=1:1 S UP=$G(^DD(UP,0,"UP")) Q:'UP
I LEV'=$L(DAS,C) Q "" ; DAS LEVELS MUST MATCH FILE OR SUBFILE LEVEL
S IENS=$$IENS^BMXADOV($G(DAS)) I IENS=U Q ""
S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) Q ""
S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""
I '$D(@CREF@(IX)) Q CREF_"||" ; NO INDEX VALUES TO CHECK
S XREF=OREF_IX_")"
S DA=+IENS I 'DA Q CREF_"||"
I '$D(@CREF@(DA)) Q CREF_"||" ; NO ENTRY EXISTS
I IX="AA" G AA
S FLD=+$$IXFLD^BMXADOV(FIEN,IX) I 'FLD Q "" ; INVALID DD
S VAL=$$GET1^DIQ(FIEN,IENS,FLD,"I") I VAL="" Q "" ; VALUE IS NULL - NOTHING TO INDEX
I '$D(@CREF@(IX,VAL,DA)) Q "" ; INVALID INDEX
Q XREF_B_DA_B_VAL
;
AA() ;EP - VISIT/V-FILE ITERATION USING THE 'AA' INDEX
N LDA,XIT,AAINFO,DA,%,X,Y,DFN,TYPE,ORD,ISTART,ISTOP,IDT,AAREF,%DT,DIC
S X=OREF_"""AA"")",%=$Q(@X) I %="" Q ""
S TYPE="" I $L(%,C)=5 S TYPE=$P(PARAM,B,2) I TYPE="" Q "" ; FOR CERTAIN V FILES, TYPE MUST BE DEFINED
I $E(TYPE)="`" S TYPE=$E(TYPE,2,99) I 'TYPE Q "" ; REMOVE ` FROM TYPE IEN
I $L(TYPE),'TYPE D I TYPE'>0 Q "" ; QUIT IF INVALID TYPE
. S %=$P($G(^DD(FIEN,.01,0)),U,2)
. S DIC=+$P(%,"P",2) I '$D(^DD(DIC,.01,0)) Q
. S X=TYPE,DIC(0)="M" D ^DIC I Y=-1 Q
. S TYPE=+Y
. Q
S DFN=+PARAM
I '$D(^DPT(DFN,0)) Q "" ; PATIENT DFN MUST BE DEFINED
I 'TYPE S AAREF=OREF_"""AA"","_DFN_")"
E S AAREF=OREF_"""AA"","_DFN_","_TYPE_")"
I '$D(@AAREF) Q "" ; IF NOTHING UNDER AA INDEX, DON'T BOTHER LOOKING
S ISTART=9999999 I START S X=START,%DT="P" D ^%DT S ISTART=9999999-Y
S ISTOP=0 I STOP S X=STOP,%DT="P" D ^%DT S ISTOP=9999999-Y
S ORD=-1 I $P(PARAM,B,$L(PARAM,B))="R" S ORD=1 ; SORT IN CHRONOLOGICAL OR REVERSE CHRONOLOGICAL ORDER
I ORD=-1 S X=$G(ISTART),Y=$G(ISTOP),ISTOP=X,ISTART=Y ; CHANGES REQUIRED TO PRESENT DATA IN CHRONOLIGICAL ORDER
S IDT=0,LDA=""
I ISTOP S IDT=ISTOP-.0000001
S DA=+IENS
I DA S IDT=$$AAR I 'IDT Q LDA ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY
F S IDT=$O(@AAREF@(IDT),ORD) Q:'IDT D I $G(XIT) Q
. I ORD=1,IDT>ISTART S LDA="",XIT=1 Q
. I ORD=-1,IDT<ISTART S LDA="",XIT=1 Q
. S DA=0
. F S DA=$O(@AAREF@(IDT,DA)) Q:'DA D I $G(XIT) Q
.. D DATA(IENS,DA,+$G(XCNT))
.. I NUM=MAX S LDA=DA,XIT=1 I '$$AAMORE S LDA="" ; TRANSACTION LIMIT
.. Q
. Q
Q LDA
;
AAR() ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY
N %,X,Y,XIT
S %=$$AAVAL(FIEN,DAS) I '$L(%) Q ""
S IDT=$P(%,B,5) I 'IDT Q ""
F S DA=$O(@AAREF@(IDT,DA)) Q:'DA D I $G(XIT) Q
. D DATA(IENS,DA,+$G(XCNT))
. I NUM=MAX S LDA=DA,IDT="",XIT="" I '$$AAMORE S LDA=""
. Q
Q IDT
;
AAMORE() ; RETURN A '1' IF MORE ITERATION IS POSSIBLE
N X
I $O(@AAREF@(IDT,DA)) Q 1
S X=$O(@AAREF@(IDT),ORD) I 'X Q 0
I $O(@AAREF@(X,0)) Q 1
Q 0
;
AAVAL(FIEN,DAS) ; GIVEN A FILE AND DAS, RETURN INFO NECESSARY TO RE-CREATE THE 'AA' INDEX
N DATE,IDT,DFN,TYPE,VIEN,%,OREF,CREF,DA,IENS
I '$D(^DD(FIEN,.01,0)) Q ""
S IENS=$$IENS^BMXADOV($G(DAS)) I IENS=U Q ""
S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) Q ""
S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""
S DA=+IENS I '$D(@CREF@(DA)) Q ""
I FIEN=9000010 S DFN=$P(@CREF@(DA,0),U,5),VIEN=DA
E S DFN=$P(@CREF@(DA,0),U,2),VIEN=$P(@CREF@(DA,0),U,3)
I $D(^DPT(DFN,0)),$D(^AUPNVSIT(VIEN,0))
E Q ""
S DATE=+$P($G(^AUPNVSIT(VIEN,0)),U) I 'DATE Q ""
S IDT=(9999999-(DATE\1))
S %=$P(DATE,".",2) I % S IDT=+(IDT_"."_%) I 'IDT Q ""
S X=OREF_"""AA"")",%=$Q(@X) I %="" Q ""
S TYPE="" I $L(%,C)=5 S TYPE=$P(@CREF@(DA,0),U)
Q X_B_DA_B_DFN_B_TYPE_B_IDT
;
AAP() ;EP - ITERATOR FOR PROBLEM FILE: AA INDEX
I '$D(^AUPNPROB("AA",+$G(START))) Q ""
N LOC,PNUM,DFN,IEN
S LOC=0,DFN=START
F S LOC=$O(^AUPNPROB("AA",DFN,LOC)) Q:'LOC D
. S PNUM=""
. F S PNUM=$O(^AUPNPROB("AA",DFN,LOC,PNUM)) Q:PNUM="" D
.. S IEN=0
.. F S IEN=$O(^AUPNPROB("AA",DFN,LOC,PNUM,IEN)) Q:'IEN D DATA(",",IEN,+$G(XCNT))
.. Q
.Q
Q ""
;
TESTID(DA) ; TEST IDENTIFIERS
N %,Y,SEX
S %=$G(^DIZ(2160010,+$G(DA),0)) I '$L(%) Q ""
S SEX=$P(%,U,2) I '$L(SEX) S SEX="??"
S Y=$P(%,U,3) X ^DD("DD")
Q (SEX_" "_Y)
;
Side by Side

After

Width:  |  Height:  |  Size: 9.1 KiB

137
m/BMXADOV2.m Normal file
View File

@ -0,0 +1,137 @@
BMXADOV2 ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ;
;;2.1;BMX;;Jul 26, 2009
; CUSTOM ITERATORS FOR RPMS
;
;
;
MEDICARE(PARAM,IENS,MAX,OUT,TOT) ;
; NO PARAM REQUIRED BUT SINCE THIS IS A SUBFILE, THE PATIENT IEN MUST BE IH IENS
; FETCHES THE MOST RECENT MEDICARE RECORD FOR THE PATIENT
N DFN,DA,X,Y,%,LIM,DATE,MAX
S LIM=DT-10000,DA=0,DATE=0,MAX=0
S DFN=$P(IENS,C,2) I 'DFN Q ""
F S DA=$O(^AUPNMCR(DFN,11,DA)) Q:'DA D
. S X=$G(^AUPNMCR(DFN,11,DA,0))
. I +X>DATE S DATE=+X,MAX=DA
. Q
I 'MAX Q ""
S DA=MAX
D DATA^BMXADOV1(IENS,DA)
Q ""
;
MCDIEN(DFN) ; EP-GIVEN A PATIENT IEN, RETRUN THE IEN OF THAT PT'S MOST RECENT RECORD IN MEDICAID ELIGIBILITY FILE
N MIEN,DA,DATE,MAX,X
S DFN=+$G(DFN),MAX="",DATE=0
S MIEN=0 F S MIEN=$O(^AUPNMCD("B",DFN,MIEN)) Q:'MIEN D
. S DA=0 F S DA=$O(^AUPNMCD(MIEN,11,DA)) Q:'DA D
.. S X=+$P($G(^AUPNMCD(MIEN,11,DA,0)),U,2)
.. I X>DATE S DATE=X,MAX=MIEN
.. Q
. Q
Q MAX
;
MEDICAID(PARAM,IENS,MAX,OUT,TOT) ;
; NO PARAM REQUIRED BUT SINCE THIS IS A SUBFILE, THE PATIENT IEN MUST BE IH IENS
; FETCHES THE MOST RECENT MEDICARE RECORD FOR THE PATIENT
N MIEN,DA,X,Y,%,LIM,DATE,MAX
S LIM=DT-10000,DA=0,DATE=0,MAX=0
S MIEN=$P(IENS,C,2) I 'MIEN Q ""
F S DA=$O(^AUPNMCD(MIEN,11,DA)) Q:'DA D
. S X=$G(^AUPNMCD(MIEN,11,DA,0))
. I +X>DATE S DATE=+X,MAX=DA
. Q
I 'MAX Q ""
S DA=MAX
D DATA^BMXADOV1(IENS,DA)
Q ""
;
PT(VAL,IENS,MAX,OUT,TOT) ; EP - PATIENT LOOKUP ; GIVEN A LOOKUP VALUE, GENERATE A LIST OF PATIENTS
N DFN,BMXNOID,DA,X,Y,%,LIM,FILE,NUM,IXS,GBL,CNT,SS
I $G(VAL)="" Q ""
S BMXNOID=1
I '$G(MAX) S MAX=999
I $G(^DD("2","0","ID","IHS0"))="D ^AUPNLKID" S ^("IHS0")="D:'$G(BMXNOID) ^AUPNLKID" ; MUST BE A SILENT CALL
S SS="BMX DFN2",GBL=$NA(^TMP(SS,$J)) K @GBL
S CNT=0,DFN=0
F S DFN=$O(^AUPNPAT("D",VAL,DFN)) Q:'DFN S CNT=CNT+1 S @GBL@("DILIST",2,CNT)=DFN ; FIRST, TRY TO MATCH CHART NUMBER
I CNT G PTIT
I VAL?3N1"-"2N1"-"4N S VAL=$TR(VAL,"-","") ; TRANSFORM SSN
I VAL?9N G PT1
S %=$L(VAL),X=$E(VAL,%-1,%)
I X?2N S X=VAL,%DT="P" D ^%DT S VAL=Y ; TRANSFORM DATE TO INTERNAL VALUE
PT1 K @GBL S SS="BMX DFN1",GBL=$NA(^TMP(SS,$J)) K @GBL
D FIND^DIC(2,"","","",VAL,999,"B^ADOB^SSN","","",GBL,"")
I '$D(^TMP(SS,$J,"DILIST",2)) Q "" ; UNSUCCESSFUL LOOKUP
PTIT ; ITERATE
S CNT=0,NUM=0
F S CNT=$O(^TMP(SS,$J,"DILIST",2,CNT)) Q:'CNT S DA=^(CNT) I DA D DATA^BMXADOV1(IENS,DA)
I $G(^DD("2","0","ID","IHS0"))="D:'$G(BMXNOID) ^AUPNLKID" S ^("IHS0")="D ^AUPNLKID" ; RESTORE DD NODE
; K @GBL ; CLEANUP
Q ""
;
HRN(DFN) ; EP - GIVEN A PATIENT DFN, RETURN THE LOCAL CHART NUMBER
Q $P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),U,2)
;
PVTINS ;
; NO PARAM REQUIRED BUT SINCE THIS IS A SUBFILE, THE PATIENT IEN MUST BE IH IENS
N DFN,DA,X,Y,%,LIM
S LIM=DT-10000,DA=0
S DFN=$P(IENS,C,2) I 'DFN Q ""
F S DA=$O(^AUPNPRVT(DFN,11,DA)) Q:'DA D
. S X=$G(^AUPNPRVT(DFN,11,DA,0))
. I '$L(X) Q
. S %=$P(X,U,7)
. I '%!(%>LIM) D DATA^BMXADOV1(IENS,DA)
. Q
Q ""
;
DUPV(PARAM,IENS,MAX,OUT,TOT) ; EP - DUPLICATE VISIT ITERATION
; PARAM: 'DFN|VISIT TIMESTAMP|TYPE|LOCATION|CATEGORY
; PATIENT DFN AND VISIT TIMESTAMP (EXTERNAL DATE FORMAT) MUST EXIST.
; THE OTHER 3 DUP PARAMETERS WILL BE CHECKED ONLY IF THEY ARE DEFINED.
; ALL DUPS ARE RETURNED. MAX,START,STOP ARE IGNORED
N DFN,TIME,TYPE,LOC,CAT,IDT,VIEN,DAY,X,PATIENT,Y,%DT,FMTIME,DA,IENS
S DFN=+PARAM,TIME=$P(PARAM,B,2),TYPE=$P(PARAM,B,3),LOC=$P(PARAM,B,4),CAT=$P(PARAM,B,5)
I $D(^DPT(+$G(DFN),0)),$L($G(TIME))
E Q ""
S X=TIME,%DT="T" D ^%DT I Y=-1 Q
S FMTIME=Y
S (IDT,DAY)=9999999-(FMTIME\1),IDT=IDT-.0000001
F S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:$E(IDT,1,7)'=DAY S VIEN=999999999999 F S VIEN=$O(^AUPNVSIT("AA",DFN,IDT,VIEN),-1) Q:'VIEN D
. S X=$G(^AUPNVSIT(VIEN,0)) I '$L(X) Q ; VISIT DATA MUST EXIT
. I $P(X,U,11) Q ; MUST BE AN 'ACTIVE' VISIT - NOT 'DELETED'
. I $L(TYPE),TYPE'=$P(X,U,3) Q
. I $L(LOC),LOC'=$P(X,U,6) Q
. I $L(CAT),CAT'=$P(X,U,7) Q
. S DA=VIEN,IENS=DA_C
. D DATA^BMXADOV1(IENS,DA)
. Q
Q ""
;
DAIT(DSTG,IENS,MAX,OUT,TOT) ; EP - SET OF IENS ITERATION.
; THE DSTG CONTAINS A "|" SET OF DAS STRINGS
; ALL VALUES ARE RETURNED. MAX IS NOT CHECKED. START AND STOP ARE IRRELEVANT
N PCE,DA,XIT,IENS,L,DAS
S L=$L(DSTG,B)
F PCE=1:1:L S DAS=$P(DSTG,B,PCE) D I $G(XIT) Q
. I 'DAS S XIT=1 Q ; NO MORE IENS - THE END OF THE LINE
. I DAS'[C S IENS=DAS_C
. E S IENS=$$IENS^BMXADOV(DAS)
. S DA=+IENS
. D DATA^BMXADOV1(IENS,DA)
. Q
Q ""
;
APRV(PARAM,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF ALL ACTIVE PROVIDERS
; ALL VALUES ARE RETURNED. MAX IS NOT CHECKED. START AND STOP ARE IRRELEVANT
N NAME,DA,STG
S NAME=""
F S NAME=$O(^VA(200,"B",NAME)) Q:NAME="" D
. S DA=0
. F S DA=$O(^VA(200,"B",NAME,DA)) Q:'DA D
.. I $P($G(^VA(200,DA,"PS")),U,4) Q ; CHECK INACTIVE DATE FIELD
.. D DATA^BMXADOV1(IENS,DA)
.. Q
. Q
Q ""
;
Side by Side

After

Width:  |  Height:  |  Size: 4.7 KiB

78
m/BMXADOVJ.m Normal file
View File

@ -0,0 +1,78 @@
BMXADOVJ ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ;
;;2.1;BMX;;Jul 26, 2009
; THIS ROUTINE MANAGES THE JOINS
;
;
;
; THE FIFTH PARAMETER OF SS^BMXADO CONTAINS THE JOIN INSTRUCTIONS
; SYNTAX: DESCENDANT SCHEMA IEN (DETAILS FILE), JOIN FIELD FROM MASTER FILE
; THE FIRST "," PIECE STATES THAT THE MASTER FILE IS JOINED BY ITS .02 FIELD TO THE DETAILS FILE
; THE SECOND "," PIECE STARTES THAT THE DETAILS FILE IS DEFINED BY SCHEMA #6
; AN OPTIONAL 3RD "," PIECE MAY CONTAIN A SECONDARY VSTG TO MORE PRECISELY DEFINE JOIN ITERATION
; E.G., "...~6.,.02,AA~1/1/2004~2/1/2004~~~~~|WT|R"
; IN THIS CASE, THE SECONDARY VSTG SPECIFIES THAT THE AA INDEX BE USED TO CONTROL THE ITERATOR
; THE START AND STOP DATES ARE IN EFFECT BUT MAX IS IGNORED/IRRELEVANT
; THE 1ST "|" PIECE OF THE PARAM SECTION WILL BE AUTOMATICALLY STUFFED WITH PATEINT DFN(S) DURING ITERATION
; IF MULTIPLE JOINS ARE REQUESTED, THEY ARE SPARATED BY THE '@JOIN@' DELIMTER
; "E.G., 6,.02@JOIN@1,.03@JOIN@2,.02@JOIN@9,SUB"
; IN THIS EXAPLE THE MASTER FILE IS JOIND TO THE DETAILS FILES ASSOCIATED WITH SCHEMAS 6, 1, AND 9
; NOTE THAT THE 3RD JOIN DEINED IN THE STRING SPECIFIES A SUBFILE REALTION RATHER THAN A "POINTER" RELATION
; IF A SECOND RECORD SET IS CREATED TO FULFILL A JOIN REQUEST, IT WILL ONLY CONTAIN THE ROWS NECESSARY TO COMPLETE THE JOIN
;
JOIN(SMASTER,JSTG) ;EP - APPEND ADDITIONAL ANRS TO FULFILL JOIN REQUESTS
N TMP,JOIN,JINST,FMASTER
I '$L($G(JSTG)) Q ; JOIN STRING MUST NOT BE NULL
S FMASTER=$P($G(^BMXADO(+$G(SMASTER),0)),U,2) I 'FMASTER Q ; MASTER SCHEMA & FILE MUST EXIST
S TMP=$NA(^TMP("BMX JOIN",$J)) K @TMP ; JOIN INFO TEMP STORAGE ARRAY
S @TMP@(0,SMASTER)=$$RANGE ; GET DATA NODE RANGE FOR THE MASTER ANR
I '$D(@TMP@(0)) Q ; DATA MUST EXIST IN THE MASTER FILE OR QUIT
F JOIN=1:1 S JINST=$P(JSTG,"@JOIN@",JOIN) Q:JINST="" D J(SMASTER,JINST) ; MAIN LOOP FOR DOING JOINS
K @TMP
Q
;
RANGE() ; GET DATA NODE RANGE FOR LAST SCHEMA ENTERED
N X,FIRST,LAST,Y
S (X,LAST)=$O(@OUT@(999999999),-1)
F S X=$O(@OUT@(X),-1) Q:'X S Y=@OUT@(X) Q:Y'[$C(30) S FIRST=X
I '$G(FIRST) Q ""
S FIRST=FIRST+1
Q (FIRST_U_LAST)
;
J(SMASTER,JSTG) ; JOIN DETAILS FILE TO MASTER FILE
; SMASTER=MASTER SCHMA IEN, SDETAIL=DETAILS SCHEMA IEN
N JARR,SEC,ERR,JIEN,SUB,IX,PARENT,JFLD,DFLD,NODE,X,STOP,VSTG2,SDETAIL,JFLD
S SDETAIL=$P(JSTG,C),JFLD=$P(JSTG,C,2),DFLD=$P(JSTG,C,3),VSTG2=$P(JSTG,C,4,999)
I JFLD="SUB" S JFLD=.001,DFLD=.0001
I JFLD=.001,DFLD=.0001 S SUB=1,VSTG2="~~~~~SIT~BMXADOVJ~" ; MAKE SUBFILE ITERATOR VSTG
D IEN(SMASTER,SDETAIL,JFLD) ; GET A LIST OF JOIN IENS FROM THE MASTER FILE
I '$D(@TMP@(1)) Q ; NO MASTER FILE IENS FOR JOINS, SO QUIT
N FIEN,DAS,SIEN,VSTG,JSTG
S DAS="",SIEN=SDETAIL,VSTG=VSTG2
S FIEN=$P($G(^BMXADO(SIEN,0)),U,2) I 'FIEN Q
D JEP^BMXADO ; BUILD THE JOIN ANR
Q
;
IEN(SMASTER,SDETAIL,JFLD) ; GET THE MASTER FILE IENS FOR BUILDING THE JOIN DATA SET
N FIEN,%,FIRST,LAST,NODE,DA,IEN
I JFLD["IEN" S JFLD=+JFLD
S FIEN=$P($G(^BMXADO(SMASTER,0)),U,2) I 'FIEN Q
S %=$G(@TMP@(0,SMASTER)) I '$L(%) Q
S FIRST=+%,LAST=$P(%,U,2),NODE=FIRST-.1
F S NODE=$O(@OUT@(NODE)) Q:'NODE Q:NODE>LAST D
. S DA=+@OUT@(NODE)
. I 'DA Q
. I JFLD=.001 S @TMP@(1,SDETAIL,DA)="" Q
. S IEN=$$GET1^DIQ(FIEN,(DA_C),JFLD,"I") I 'IEN Q
. S @TMP@(1,SDETAIL,IEN)=""
. Q
Q
;
JFLD ; EP-STUFF JOIN FIELD IDS INTO THE INTRO SEGMENT OF THE SCHEMA
N NODE,%
S NODE=999999999999
F S NODE=$O(@OUT@(NODE),-1) Q:'NODE I ^(NODE)["@@@meta@@@" Q
I 'NODE Q
S %=$P(@OUT@(NODE),U),$P(%,"|",4)=$G(JFLD),$P(%,"|",5)=$G(DFLD)
S @OUT@(NODE)=%_U
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 3.5 KiB

501
m/BMXADOX.m Normal file
View File

@ -0,0 +1,501 @@
BMXADOX ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ;
;;2.1;BMX;;Jul 26, 2009
; EXMAPLES OF RPMS SCHEMAE GENERATION
;
;
DISP(OUT) ;EP - TEMP DISPLAY
N I,X
S I=0 W !
F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X
Q
;
SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN
N IEN
S IEN=$O(^BMXADO("B",NAME,0))
Q IEN
;
NEXTNUM(DFN,LOC) ; RETURN THE NEXT PROBLEM NUMBER FOR A PATIENT
N X,LAST,MAX,NUM
S NUM=0,MAX=""
F S NUM=$O(^AUPNPROB("AA",DFN,LOC,NUM)) Q:NUM="" S X=$E(NUM,2,99) I +X>MAX S MAX=+X
I 'MAX Q 1
S X=X+1 S X=X\1
Q X
;
DEMOG ; VIEW DEMOGRAPHICS
N OUT,%,DFN,MAX,SIEN
S DFN=1,MAX=1000
S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS")
D SS^BMXADO(.OUT,SIEN,"",("~"_DFN_"~"_DFN_"~"_MAX))
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MEDICARE ; UPDATE MEDICARE DATES/INFO
N OUT,%,DAS,PIEN,JIEN,DFN,MAX
S DFN=1,MAX=1000
S DAS=DFN_","
S PIEN=$$SCHEMA("UPDATE MEDICARE DATES")
S JIEN=$$SCHEMA("UPDATE MEDICARE INFO")
D SS^BMXADO(.OUT,PIEN,DAS,("~"_DFN_"~"_DFN_"~"_MAX_"~~"_"MEDICARE~BMXADOV2~~"_JIEN_",PARENT"))
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MEDICAID ; VIEW MEDICAID DATES/INFO
N OUT,%,DAS,PIEN,JIEN,DFN,DA
S DFN=3
S DA(1)=$$MCDIEN^BMXADOV2(DFN) I 'DA(1) Q
S DAS=DA(1)_","
S PIEN=$$SCHEMA("UPDATE MEDICAID DATES")
S JIEN=$$SCHEMA("UPDATE MEDICAID INFO")
D SS^BMXADO(.OUT,PIEN,DAS,("~~~~~MEDICAID~BMXADOV2~~"_JIEN_",PARENT"))
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PVTINS ; VIEW PRIVATE INSURANCE DATES/INFO
N OUT,%,DAS,SIEN,DFN
S DFN=1
S DAS=DFN_","
S SIEN=$$SCHEMA("UPDATE PVT INSURANCE INFO")
D SS^BMXADO(.OUT,SIEN,DAS,"~~~~~PVTINS~BMXADOV2~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
VISIT ; VIEW VISITS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~100~~~~1|R")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
DUPVIS ; DISPLAY POSSIBLE DUPLICATE VISITS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~1|4/19/04@1PM|I|4585|A~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDVIS ; ADD A NEW VISIT
N OUT,%,SIEN,DFN,NODE
S DFN=3
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^JUN 03, 2004@09:32^I^`3^`4585^A^`1"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
POV ; DISPLAY POVS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VIEW POVS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~100~~~~1|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
FLDS ; GET FILEMAN FIELDS
N OUT,%,SIEN,DFN
S SIEN=$$SCHEMA("FIELDS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~FLDIT~BMXADOS1~3.7~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
FINFO ; GET FILEMAN FILEINFO
N OUT,%,SIEN,DFN
S SIEN=$$SCHEMA("FILEMAN FILEINFO")
D SS^BMXADO(.OUT,SIEN,"","~~~~~FNIT~BMXADOS1~3.7~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPOV ; ADD A POV TO AN EXISITING VISIT
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE POVS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`8718^`1^`71164^DM II ON NEW MEDS^2^P"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
EDITPOV ; ADD A POV TO AN EXISITING VISIT
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE POVS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="100123^`8718^`1^`71164^DM II ON SPECIAL MEDS^2^P"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PROB ; DISPLAY PROBLEMS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VIEW PROBLEMS")
D SS^BMXADO(.OUT,SIEN,"","AA~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPROB ; ADD A PROBLEM TO THE PROBLEM LIST
N OUT,%,SIEN,DFN,NODE,NUM,LOC,ICD,TEXT,AIR,IEN
S ICD=2477
S TEXT="HYPERTENSION ON SPECIAL MEDS"
S DFN=1,LOC=DUZ(2),AIR="A"
S SIEN=$$SCHEMA("UPDATE PROBLEMS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)=U_"`"_ICD_U_"`"_DFN_U_DT_U_U_TEXT_U_"`"_LOC_U_DT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
S IEN=+$P(OUT(1),"|",2) I '$D(^AUPNPROB(IEN,0)) Q
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
K OUT
S NUM=$$NEXTNUM(DFN,LOC) I 'NUM Q ; PROBLEM NUMBER & STATUS MUST BE ADDED SEPARATELY
S SIEN=$$SCHEMA("UPDATE PROBLEM NUMBER")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)=IEN_U_NUM_U_"A"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
MEAS ; DISPLAY MEASUREMENTS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VIEW MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~10~~~~"_DFN_"|WT|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDMEAS ; UPDATE V MEASUREMENT FILE
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`2^`"_DFN_"^`71164^177.5^`6"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
MEDS ; DISPLAY MEDS
N OUT,%,SIEN,DFN
S DFN=3
S SIEN=$$SCHEMA("VIEW MEDS")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1989~12/31/1990~10~~~~"_DFN_"|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDMEDS ; UPDATE V MED FILE
N OUT,%,SIEN,DFN,NODE
S DFN=3
S SIEN=$$SCHEMA("UPDATE MEDS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`305^`"_DFN_"^`71164^T1T QID^40"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
LAB ; DISPLAY LAB TEST RESULTS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VIEW LABS")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1985~12/31/1987~10~~~~"_DFN_"|175|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDLAB ; UPDATE V LAB
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE LABS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`175^`"_DFN_"^`71164^216"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
EXAMS ; DISPLAY EXAMS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VIEW EXAMS")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1986~12/31/1990~10~~~~"_DFN_"|6|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDEXAMS ; UPDATE V EXAM
S DFN=1
S SIEN=$$SCHEMA("UPDATE EXAMS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`6^`"_DFN_"^`71164^NORMAL"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
IMM ; DISPLAY IMMUNIZATIONS
N OUT,%,SIEN,DFN
S DFN=2
S SIEN=$$SCHEMA("VIEW IMM")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1986~12/31/1988~10~~~~"_DFN_"|12|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDIMM ; UPDATE V IMMUNIZATION FILE
S DFN=2
S SIEN=$$SCHEMA("UPDATE IMM")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`12^`"_DFN_"^`71164^2"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PROV ; DISPLAY PROVIDERS FOR A VISIT
N OUT,%,SIEN,VIEN
S VIEN=11
S SIEN=$$SCHEMA("VIEW PROV")
D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPROV ; UPDATE V PROVIDER FILE
N OUT,%,SIEN,NODE,PIEN,DFN
S PIEN=5,DFN=1
I $P(^DD(9000010.06,.01,0),U,3)["DIC(6" S PIEN=$P(^VA(200,PIEN,0),U,16) ; CONVERT FILE 200 TO FILE 16 IF NECESS.
S SIEN=$$SCHEMA("UPDATE PROV")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`"_PIEN_"^`"_DFN_"^`71164^P"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PROC ; DISPLAY PROCEDURES
N OUT,%,SIEN,DFN
S DFN=4
S SIEN=$$SCHEMA("VIEW PROCEDURES")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1985~12/31/1985~10~~~~"_DFN_"|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPROC ; UPDATE V PROCEDURES FILE
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE PROCEDURES")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`2198^`"_DFN_"^`71164^`8718"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
CPT ; DISPLAY CPT CODES
N OUT,%,SIEN,DFN
S VIEN=71164
S SIEN=$$SCHEMA("VIEW CPT")
D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDCPT ; UPDATE V CPT FILE
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE CPT")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`10000^`"_DFN_"^`71164^WOUND CARE"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PH ; DISPLAY PERSONAL HISTORY
N OUT,%,SIEN,DFN
S DFN=632
S SIEN=$$SCHEMA("VIEW PERSONAL HISTORY")
D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPH ; UPDATE PERSONAL HX
N OUT,%,SIEN,DFN,NODE,ICD,TEXT
S ICD=2477
S TEXT="PERSONAL HISTORY OF SERIOUS PROBLEMS"
S DFN=632
S SIEN=$$SCHEMA("UPDATE PERSONAL HISTORY")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`11353^`"_DFN_"^2851219^"_TEXT_"^2810303"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
FH ; DISPLAY FAMILY HX
N OUT,%,SIEN,DFN
S DFN=631
S SIEN=$$SCHEMA("VIEW FAMILY HISTORY")
D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDFH ; UPDATE FAMILY HISTORY
N OUT,%,SIEN,DFN,NODE,ICD,TEXT
S ICD=2477
S TEXT="FAMILY HISTORY OF SERIOUS PROBLEMS"
S DFN=631
S SIEN=$$SCHEMA("UPDATE FAMILY HISTORY")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`7571^`"_DFN_"^2851219^"_TEXT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
HF ; DISPLAY HEALTH FACTORS
N OUT,%,SIEN,DFN
S DFN=1
S SIEN=$$SCHEMA("VIEW HEALTH FACTORS")
D SS^BMXADO(.OUT,SIEN,"","AC"_"~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDHF ; UPDATE HEALTH FACTORS FILE
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE HEALTH FACTORS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`3^`"_DFN_U_DT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
REPRO ; DISPLAY REPRODUCTIVE FACTORS
N OUT,%,SIEN,DFN
S DFN=5
S SIEN=$$SCHEMA("VIEW REPRODUCTIVE FACTORS")
D SS^BMXADO(.OUT,SIEN,"","B"_"~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDREPRO ; UPDATE REPRODUCTIVE FACTORS
; THE .O1 FIELD IS DINUMED
; THEREFORE, THE FILER WILL AUTOMATICALLY SWITCH TO MOD MODE IF A RECORD ALREADY EXISTS FOR THIS PATIENT
N OUT,%,SIEN,DFN,NODE
S DFN=5
; I $D(^AUPNREP(DFN)) G ERF
S SIEN=$$SCHEMA("ADD REPRODUCTIVE FACTORS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`"_DFN_"^G5P4LC3SA1TA0^"_DT_"^2^3040101^"_DT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
; ---------------------------------- GRIDS ---------------------------------------------
;
GRID ; POPULATE THE INTRO GRID
N OUT,%,SIEN,NODE,NEXT
S NEXT="70470;0"
S SIEN=$$SCHEMA("VEN MOJO DE INTRO")
D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MGRID ; POPULATE THE MEASUREMENT GRID
N OUT,%,SIEN,NODE,NEXT,START,STOP
S NEXT="70470;2"
S SIEN=$$SCHEMA("VEN MOJO DE MEASUREMENT")
; D SS^BMXADO(.OUT,SIEN,"","~~~~~GRIDIT~VENPCCTG~"_NEXT) ; GET SCHEMA
D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA
D DISP(OUT) R %:$G(DTIME,60)
; K ^TMP("BMX ADO",$J)
Q
;
PRVGRID ; POPULATE THE PROVIDER GRID
N OUT,%,SIEN,NODE,NEXT
S NEXT="70470;4"
S SIEN=$$SCHEMA("VEN MOJO DE PROVIDER")
D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
CLGRID ; POPULATE THE CLINIC GRID
N OUT,%,SIEN,NODE,NEXT
S NEXT="70470;8"
S SIEN=$$SCHEMA("VEN MOJO DE CLINIC")
D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
DXGRID ; POPULATE THE DX GRID
N OUT,%,SIEN,NODE,NEXT
S NEXT="70470;1"
S SIEN=$$SCHEMA("VEN MOJO DE DX DXHX")
D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

325
m/BMXADOX1.m Normal file
View File

@ -0,0 +1,325 @@
BMXADOX1 ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ;
;;2.1;BMX;;Jul 26, 2009
; EXMAPLES OF FILEMAN SCHEMA GENERATION
;
;
; N OUT,DAX,% S DAX=0 D SS^BMXADO(.OUT,1,DAX,"^^^5^I^^^^3,XSUB,2160010.03") D DISP(OUT) Q ; TEST EXTENDED SUBJOIN
;
DISP(OUT) ;
D DISP^BMXADOX(OUT)
Q
;
SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN
N IEN
S IEN=$O(^BMXADO("B",NAME,0))
Q IEN
;
NUM ; ITERATE BY IEN
; IX="",START WITH IEN=1, STOP AFTER IEN=20, MAX # RECORDS RETURNED = 5
; TO VIEW INTERNAL VALUES SET VSTG="~1~20~5~I"
N OUT,%,SIEN
S SIEN=$$SCHEMA("IHS PATIENT")
D SS^BMXADO(.OUT,SIEN,"","~1~20~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
IX ; ITERATE BY INDEX
; ITERATE USING THE "B" INDEX
; START WITH PT NAME "C", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5
N OUT,%,SIEN
S SIEN=$$SCHEMA("IHS PATIENT")
D SS^BMXADO(.OUT,SIEN,"","B~C~D~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
VCN ; SHOW VALUES FOR A SINGLE VISIT THAT AS A DEFINED VCN
N OUT,%,SIEN
S SIEN=$$SCHEMA("BMXADO DATA ENTRY IDENTIFIERS")
D SS^BMXADO(.OUT,SIEN,"","VCN~1.242A~1.242A~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MT ; MEASUREMNT TYPES
N OUT,%,SIEN
S SIEN=$$SCHEMA("BMXADO MEASUREMENT TYPES")
D SS^BMXADO(.OUT,SIEN,"","B~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PROB ; PATIENT PROBLEMS
N OUT,%,SIEN
S SIEN=$$SCHEMA("BMXADO PROBLEMS")
D SS^BMXADO(.OUT,SIEN,"","AA~53~53")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PB1 ; ALT PROB RETRIEVAL TEST
N OUT,%,SIEN
S SIEN=$$SCHEMA("BMXADO PROBLEMS")
D SS^BMXADO(.OUT,SIEN,"","~221~221~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
POV ; RETURN THE POV SCHEMA
N OUT,%,SIEN
S SIEN=$$SCHEMA("BMXADO ADD POV")
D SS^BMXADO(.OUT,SIEN,"","")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
NOTES ; RETURN NOTES FOR A SPECIFIC PATIENT PROBLEMS
N OUT,%,SIEN
S SIEN=$$SCHEMA("BMXADO NOTES")
D SS^BMXADO(.OUT,SIEN,"","~~~~~NOTES~BMXADOFD~53")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
RENT ; ITERATE IN CHUNKS
; RE-ITERATE USING THE "B" INDEX
; START WITH PT IEN 5 AS THE "SEED", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5
N OUT,%,SIEN,SEED,LSEED,X,Y
S SEED=0,LSEED=""
S SIEN=$$SCHEMA("IHS PATIENT")
RIT F D I '$G(SEED) Q
. ; D SS^BMXADO(.OUT,SIEN,SEED,"B~CA~CB~5")
. D SS^BMXADO(.OUT,SIEN,SEED,"~~~5")
. D DISP(OUT) R %:$G(DTIME,60) E S SEED="" Q
. I %?1"^" S SEED="" Q
. S X=$P(@OUT@(1),U,1)
. S SEED=$P(X,"|",3)
. I SEED=LSEED S SEED="" Q
. S LSEED=SEED
. K ^TMP("BMX ADO",$J)
. Q
Q
;
SUB ; SUBFILE ITERATION
; THE SCHEMA IS ATTACHED TO THE MEDICARE ELIGIBILITY FILE/ELIG DATE SUBFILE
; THE DA STRING HAS A VALUE OF '1,',: THE IEN IN THE PARENT FILE.
; NOTE THE COMMA IN THE DA STRING. THIS INDICATES THAT THE FILE IEN IS 1 BUT THE SUBFILE IEN IS UNSPECIFIED
N OUT,%,SIEN
S SIEN=$$SCHEMA("UPDATE MEDICARE DATES")
D SS^BMXADO(.OUT,SIEN,"1,","~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
DINUM ; DINUMED POINTER ITERATION
; THE SCHEMA IS ATTACHED TO THE IHS PATIENT FILE (9000001)
; THE IHS PATIENT FILE IS DINUM'D AND ITS .01 FIELD POINTS TO THE VA PATIENT FILE (2)
; BECAUSE OF THE SPECIAL RELATIONSHIP BETWEEN THE FILES, WE CAN USE THE B INDEX OF FILE 2 TO ITERATE FILE 9000001.
N OUT,%,SIEN
S SIEN=$$SCHEMA("IHS PATIENT")
D SS^BMXADO(.OUT,SIEN,"","B~A~B~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
IXP ; INDEXED POINTER ITERATION
; THE SCHEMA IS ATTACHED TO THE V POV FILE
; THE AC CROSS REFERENCE INDEXES THE PATIENT FIELD
; BY STARTING AND STOPING WITH PATIENT 1 (MAX=5) WE COLLECT THE FIRST 5 POVS FOR PATIENT 1 IN THE FILE
N OUT,%,SIEN
S SIEN=$$SCHEMA("VIEW POVS")
D SS^BMXADO(.OUT,SIEN,"","AC~1~1~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
AA ; ITERATE USING AA INDEX
; INDEX IS 'AA" THE START AND STOP DATES ARE SPECIFIED IN EXTERNAL FORMAT. MAX=10
; THE FOLLOWING FILTERS ARE SPECIFIED IN THE LAST PARAMETER ("1|WT|C"):
; 1=PATIENT DFN #1
; WT=RETURN ONLY WEIGHTS. MEASUREMENT TYPE MUST BE SPECIFIED WITH A VALID, UNAMBIGUOUS LOOKUP VALUE.
; C=RETRUN VALUES IN CHRONOLOGICAL ORDER USE 'R' INSTEAD OF 'C' FOR REVERSE CHRONOLOGICAL ORDER. DEFAULT=C
; THE SEED PARAMTER IS SET AND CAN BE USED TO RETURN DATA IN CHUNKS
N OUT,%,SIEN
S SIEN=$$SCHEMA("VIEW MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~5~~~~1|WT|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
AA2 ; ITERATE USING AA INDEX
; THIS SCHEMA IS ATTACHED TO THE VISIT FILE (9000010)
; IN THIS CASE THERE IS NO ATTRIBUTE TYPE SO THE FILTER PARAM HAS ONLY 2 PIECES "1|R"
; 1=PATIENT DFN
; R=RETURN DATA IN REVERSE CHRONOLOGICAL ORDER
N OUT,%,SIEN
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~5~~~~1|R")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
CIT ; CUSTOM ITERATOR
; IF COMPLEX OR UNUSUAL SORTING/FILTERING IS REQUITED, USE A CUSTOM ITERATOR
; THE CUSTOM ITERATOR IS DEFINED BY 6TH, 7TH AND 8TH PIECES IN THE VSTG
; PIECE 8=TAG, PIECE 9=ROUTINE, PIECE 8=A PARAMETER PASSED TO THE ENTRY POINT
; THE 9TH PIECE CONTAINS PT DFN, TIMESTAMP, VISIT TYPE, LOC IEN, AND SERVICE CATEGORY IN A "|" DELIMTED STRING
; THE ITERATOR CALL TAG^ROUTINE(PARAM) TO GENERATE IENS
; IN THIS CASE THE SCHEMA IS ATTACHED TO THE VISIT FILE.
; GIVEN THE INFORMATION IN THE PARAMETER, THE CUSTOM ITERATOR RETURNS POSSIBLE DUPLICATE VISITS
N OUT,%,SIEN
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~1|4/19/04@1PM|I|4585|A~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
TRIGGER ; TEXT TRIGGER FUNCTION
N OUT,%,SIEN
S SIEN=$$SCHEMA("PATIENT DEMOGRAPHICS")
D SS^BMXADO(.OUT,SIEN,"","~1~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ID ; IDENTIFIER FIELD
; THE SCHEMA IS ATTACHED TO THE VA PATIENT FILE (2)
; THE SCHEMA HAS A BUILT IN FIELD (.01ID) THAT RETURNS THE IDENTIFIERS
; THE ENTRY POINT THAT GENERATES THE IDETIFIERS IS STORED IN THE BMX ADO SCHEMA FILE
N OUT,%,SIEN
S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS")
D SS^BMXADO(.OUT,SIEN,"","~1~1~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JMD ; JOIN MASTER TO DETAIL
N OUT,%,SIEN1,SIEN2,VSTG,SIEN3,JSTG
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
S SIEN2=$$SCHEMA("VIEW MEASUREMENTS")
S SIEN3=$$SCHEMA("VIEW MEDS")
S VSTG="~1~5" ; INSTRUCTIONS FOR GATHERING DATA SET FOR PTS 1-5 FROM THE MASTER FILE
S JSTG=SIEN3_",.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C" ; + INSTRUCTIONS FOR 1ST JOIN TO GET MEDS
S JSTG=JSTG_"@JOIN@"_SIEN2_",.001,.02IEN,AA~1/1/1988~12/31/1988~~~~~|WT|R" ; + INSTRUCTIONS FOR 2ND JOIN TO GET MSRMNTS
D SS^BMXADO(.OUT,SIEN1,"",VSTG,JSTG)
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JVPT ; JOIN PT DEMOG TO VISIT
N OUT,%,SIEN1,SIEN2,VSTG,JSTG
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
S SIEN2=$$SCHEMA("VISITS")
S VSTG="~1~1" ; INSTRUCTIONS FOR GATHERING DATA SET FOR PT 5 FROM THE MASTER FILE
S JSTG=SIEN2_",.05IEN,.001,AC" ; + INSTRUCTIONS FOR 1ST JOIN TO GET VISIT INFO
D SS^BMXADO(.OUT,SIEN1,"",VSTG,JSTG)
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JAC ; TEST AC INDEX
N OUT,%,SIEN1,SIEN2
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
S SIEN2=$$SCHEMA("VIEW LABS")
S SIEN3=$$SCHEMA("VIEW MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN1,"","~3~5~~~~~~"_SIEN2_",.001,.02IEN,AC@JOIN@"_SIEN3_",.001,.02IEN,AC")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JPB ; TEST AA INDEX JOINS FOR PROBLEM LIST
N OUT,%,SIEN1,SIEN2
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
S SIEN2=$$SCHEMA("VIEW PROBLEMS")
D SS^BMXADO(.OUT,SIEN1,"","~1~5~~~~~~"_SIEN2_",.001,.02IEN,AA")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JSUB ; SUBFILE JOIN
; IN THIS CASE THE RECORDS IN A PARENT FILE ARE "JOINED" TO THE RECORDS IN ONE OF ITS SUB FILES
; THE SCHEMA IS ATTACHED TO THE "MEDICARE ELIGIBLE" FILE
; IT IS JOINED TO ITS SUBFILE, "ELIG DATES", VIA THE UPDATE MEDICARE DATES SCHEMA
N OUT,%,SIEN1,SIEN2
S SIEN1=$$SCHEMA("UPDATE MEDICARE INFO")
S SIEN2=$$SCHEMA("UPDATE MEDICARE DATES")
D SS^BMXADO(.OUT,SIEN1,"","~1~5~~~~~~"_SIEN2_",SUB")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADD ; ADD A NEW ENTRY
; THIS IS A 2 STEP PROCESS:
; FIRST GET THE SCHEMA FOR THE FILE YOU WISH TO UPDATE
; THIS SCHEMA TYPICALLY BEGINS WITH THE WORD "UPDATE"
; IT CONTAINS NO ID IR IEN FIELDS
; SECOND ADD THE DATA NODE TO THE ARRAY
; IT HAS THE SAME FORMAT AS A DATA STRING ASSOCIATED WITH THE SCHEMA EXCEPT THE FIRST "^" PIECE IS NULL
; THIS PIECE CORRESPONDS TO THE IEN OF THE RECORD. SINCE THE RECORD HASNOT BEEN ADDED YET, IT IS NULL.
; IN THE DATA STRING, ALL POINTER VALUES ARE PRECEDED BY THE '`' CHARACTER AND EA. STRING ENDS IN $C(30)
; MULTIPLE DATA STRINGS CAN BE APPENDED AS NEW NODES AT THE BOTTOM OF THE ARRAY
; IN THIS CASE WE ARE ADDING A RECORD TO THE V MEASUREMENT FILE
; DATA STRING="^MEASUREMENT TYPE IEN^PATIENT DFN^VISIT IEN^RESULT"_$C(30)
; THERE ARE 2 INPUT PARAMS:
; THE CLOSED REF WHERE THE INPUT ARRAY IS STORED
; SINCE IT IS PASSED BY REFERENCE "OUT" CAN BE NULL OR UNDEFIEND.
; OUT WILL BE DEFINED AT THE CONCLUSION OF THE TRANSACTION.
; THE OUTPUT IS IN THE OUT ARRAY
; OUT(1)="OK|ien" WHERE ien IS THE IEN OF THE RECORD THAT HAS BEE ADDED.
; IF THE TRANSACTION FAILED, AN ERROR MSG WILL BE IN THE OUT ARRAY
;
N OUT,%,SIEN,NODE
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`2^`1^`71164^175.75"_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
DELREC ; DELETE AN ENTRY
; THE SIMPLEST WAY TO DELETE AN ENTRY IS TO PUT THE RECORD IEN IN THE DA STRING PRECEDED BY A MINUS SIGN
; YOU CAN ALSO SET THE VALUE OF THE .01 FIELD TO "@"
; IF THE VALUE OF THE .01 FIELD IS NULL AND THE DA STRING IS NOT PRECEDED BY A MINUS SIGN, THE TRANSACTION WILL BE CANCELLED
; IF THE DA STRING IS NULL, THE TRANSACTION WILL BE CANCELLED
N OUT,%,SIEN,NODE,DEL
S DEL=51385
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="-"_DEL_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
EDIT ; EDIT AN EXISTING ENTRY
; SIMILAR TO ABOVE EXCEPT THAT THE FIRST "^" PIECE OF THE DATA NODE IS THE IEN OF THE RECORD TO BE EDITIED
; NOTE THAT THERE IS NO '`' IN FRONT OF THE FIRST PIECE. IT IS A PURE INTEGER
N OUT,%,SIEN,NODE
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="51385^^^^176^`6"_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
DELVAL ; DELETE A VALUE IN A FIELD
; SIMILAR TO EDIT EXCEPT THE VALUE IS "@"
N OUT,%,SIEN,NODE
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="51385^^^^^@"_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
Side by Side

After

Width:  |  Height:  |  Size: 12 KiB

123
m/BMXADOX2.m Normal file
View File

@ -0,0 +1,123 @@
BMXADOX2 ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ;
;;2.1;BMX;;Jul 26, 2009
; EXMAPLES OF FILEMAN SCHEMA GENERATION
;
DISP(OUT) ;
D DISP^BMXADOX(OUT)
Q
;
SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN
N IEN
S IEN=$O(^BMXADO("B",NAME,0))
Q IEN
;
; ---------------------------------------- LISTS ------------------------------------------
;
FIFOLIST N OUT,%,SIEN,NODE,NEXT
S NEXT="70470;8"
S SIEN=$$SCHEMA("VEN MOJO LIST DE FIFO")
D SS^BMXADO(.OUT,SIEN,"","~~~") ; GET ENCOUNTER LIST TO BE PROCESSED BY DATA ENTRY
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PROBLIST ; LIST PROBLEMS
S SIEN=$$SCHEMA("VEN MOJO DE DX PROBLEM")
D SS^BMXADO(.OUT,SIEN,"","AC~5~5~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PTLIST ; LIST PATIENT WITH A SPECIFIC LOOKUP VALUE
N VAL
R "PATIENT: ",VAL:DTIME E Q
I '$L(VAL) Q
I VAL?1."^" Q
S SIEN=$$SCHEMA("VEN MOJO LIST PATIENTS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~PT~BMXADOV2~"_VAL)
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
CLINLIST ; LIST CLINICS
S SIEN=$$SCHEMA("VEN MOJO LIST CLINICS")
D SS^BMXADO(.OUT,SIEN,"","B~~~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
SEGLIST ; LIST DE SEGMENTS
S SIEN=$$SCHEMA("VEN MOJO DE SEGMENT")
D SS^BMXADO(.OUT,SIEN,"","~~~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
NOTELIST ; LIST NOTES
;N SIEN
;D NOTELIST^VENPCCTG(.OUT,"70470")
;D DISP(OUT) R %:$G(DTIME,60)
;K ^TMP("BMX ADO",$J)
Q
;
PRVLIST ; PROVIDER LIST
N SIEN,OUT
S SIEN=$$SCHEMA("VEN MOJO LIST PROVIDERS")
D SS^BMXADO(.OUT,SIEN,"","B~~~5000") ; GET NOTE LIST TO BE PROCESSED BY DATA ENTRY
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MLIST ; LIST MEASUREMNTS
S SIEN=$$SCHEMA("VEN MOJO LIST MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","B~~~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
RXLIST ; A RX LIST FOR A PATIENT
N SIEN,OUT
S SIEN=$$SCHEMA("VEN MOJO RX LIST")
D SS^BMXADO(.OUT,SIEN,"","~~~~~MED~MOJORX~3") ; GET RX LIST
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
TQLIST ; TABLET QUEUE LIST
N SIEN,OUT
S SIEN=$$SCHEMA("VEN MOJO LIST TABLET QUEUE")
D SS^BMXADO(.OUT,SIEN,"","ATS~~~") ; GET PATIENT LIST
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
UHCLIST ; LIST HIDDEN COLUMNS
N SIEN,OUT
; S SIEN=$$SCHEMA("VEN MOJO DE GFMT UHC")
D SS^BMXADO(.OUT,"VEN MOJO DE FMT GRID","","~~~") ; GET RX LIST
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
GSEGLIST ; LIST GRID PROPERTIES FOR SEGMENTS
N SIEN,OUT
D SS^BMXADO(.OUT,"VEN MOJO DE GRID FMT","","B~~~") ; GET RX LIST
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ICDLIST ; LIST ICD CODE MATCHES
;N NARR,OUT
;W !,"Provider narrative: " R NARR:60 E Q
;I '$L(NARR) Q
;D ICDMATCH^VENPCCTP(.OUT,NARR) W !!
;D DISP(OUT) R %:$G(DTIME,60)
;K ^TMP("BMX ADO",$J)
Q
;
IMAGE ; LIST SEGMENT IMAGE CONTROL PARAMETERS
N SIEN,OUT
D SS^BMXADO(.OUT,"VEN MOJO DE SEG IMAGE","1,","~~~") ; GET RX LIST
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
Side by Side

After

Width:  |  Height:  |  Size: 3.2 KiB

439
m/BMXADOXX.m Normal file
View File

@ -0,0 +1,439 @@
BMXADOXX ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ;
;;2.1;BMX;;Jul 26, 2009
; EXMAPLES OF RPMS SCHEMAE GENERATION
;
;
ADDPAT ;
N OUT,%,SIEN,DFN,NODE
;S DFN=9285
S SIEN=$$SCHEMA("UPDATE VA PATIENT")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^KANGAROO,KAP^M^1-1-83^151515555"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
;
Q
;
DISP(OUT) ; TEMP DISPLAY
N I,X
S I=0 W !
F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X
Q
;
SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN
N IEN
S IEN=$O(^BMXADO("B",NAME,0))
Q IEN
;
NEXTNUM(DFN,LOC) ; RETURN THE NEXT PROBLEM NUMBER FOR A PATIENT
N X,LAST,MAX,NUM
S NUM=0,MAX=""
F S NUM=$O(^AUPNPROB("AA",DFN,LOC,NUM)) Q:NUM="" S X=$E(NUM,2,99) I +X>MAX S MAX=+X
I 'MAX Q 1
S X=X+1 S X=X\1
Q X
;
DEMOG ; VIEW DEMOGRAPHICS
N OUT,%,DFN,MAX,SIEN
S DFN=1373,MAX=1000
S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS")
D SS^BMXADO(.OUT,SIEN,"",("~"_DFN_"~"_DFN_"~"_MAX))
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MEDICARE ; UPDATE MEDICARE DATES/INFO
N OUT,%,DAS,PIEN,JIEN,DFN,MAX
S DFN=1,MAX=1000
S DAS=DFN_","
S PIEN=$$SCHEMA("UPDATE MEDICARE DATES")
S JIEN=$$SCHEMA("UPDATE MEDICARE INFO")
D SS^BMXADO(.OUT,PIEN,DAS,("~"_DFN_"~"_DFN_"~"_MAX_"~~"_"MEDICARE~BMXADOV2~~"_JIEN_",PARENT"))
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
MEDICAID ; VIEW MEDICAID DATES/INFO
N OUT,%,DAS,PIEN,JIEN,DFN,DA
S DFN=322
S DA(1)=$$MCDIEN^BMXADOV2(DFN) I 'DA(1) Q
S DAS=DA(1)_","
S PIEN=$$SCHEMA("UPDATE MEDICAID DATES")
S JIEN=$$SCHEMA("UPDATE MEDICAID INFO")
D SS^BMXADO(.OUT,PIEN,DAS,("~~~~~MEDICAID~BMXADOV2~~"_JIEN_",PARENT"))
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PVTINS ; VIEW PRIVATE INSURANCE DATES/INFO
N OUT,%,DAS,SIEN,DFN
S DFN=96
S DAS=DFN_","
S SIEN=$$SCHEMA("UPDATE PVT INSURANCE INFO")
D SS^BMXADO(.OUT,SIEN,DAS,"~~~~~PVTINS~BMXADOV2~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
VISIT ; VIEW VISITS
N OUT,%,SIEN,DFN
S DFN=9285
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1968~6/4/2004~100~~~~9285|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
DUPVIS ; DISPLAY POSSIBLE DUPLICATE VISITS
N OUT,%,SIEN,DFN
S DFN=9285
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~9285|5/24/04@1PM|I|516|~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDVIS ; ADD A NEW VISIT
N OUT,%,SIEN,DFN,NODE
S DFN=9285
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^JUN 03, 2004@01:32^I^`9285^`516^A^`2"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
POV ; DISPLAY POVS
N OUT,%,SIEN,DFN
S DFN=9285
S SIEN=$$SCHEMA("VIEW POVS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~100~~~~9285|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPOV ; ADD A POV TO AN EXISITING VISIT
N OUT,%,SIEN,DFN,NODE
S DFN=9285
S SIEN=$$SCHEMA("UPDATE POVS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`8718^`9285^`8337^DM II ON EXPMTL MEDS^2^P"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
EDITPOV ; ADD A POV TO AN EXISITING VISIT
N OUT,%,SIEN,DFN,NODE
S DFN=1
S SIEN=$$SCHEMA("UPDATE POVS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="2815^`8718^`9285^`8337^DM II ON SPECIAL MEDS^2^P"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PROB ; DISPLAY PROBLEMS
N OUT,%,SIEN,DFN
S DFN=1373
S SIEN=$$SCHEMA("VIEW PROBLEMS")
D SS^BMXADO(.OUT,SIEN,"","AA~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPROB ; ADD A PROBLEM TO THE PROBLEM LIST
N OUT,%,SIEN,DFN,NODE,NUM,LOC,ICD,TEXT,AIR,IEN
S ICD=2477
S TEXT="HYPERTENSION ON SPECIAL MEDS"
S DFN=1373,LOC=DUZ(2)
S SIEN=$$SCHEMA("UPDATE PROBLEMS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)=U_"`"_ICD_U_"`"_DFN_U_DT_U_U_TEXT_U_"`"_LOC_U_DT_U_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
S IEN=+$P(OUT(1),"|",2) I '$D(^AUPNPROB(IEN,0)) Q
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
K OUT
S NUM=$$NEXTNUM(DFN,LOC) I 'NUM Q
S SIEN=$$SCHEMA("UPDATE PROBLEM NUMBER")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)=IEN_U_NUM_U_"A"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
MEAS ; DISPLAY MEASUREMENTS
N OUT,%,SIEN,DFN
S DFN=2
S SIEN=$$SCHEMA("VIEW MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~10~~~~"_DFN_"|WT|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDMEAS ; UPDATE V MEASUREMENT FILE
N OUT,%,SIEN,DFN,NODE
S DFN=2
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`2^`"_DFN_"^`7806^172.75"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
MEDS ; DISPLAY MEDS
N OUT,%,SIEN,DFN
S DFN=152
S SIEN=$$SCHEMA("VIEW MEDS")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1969~12/31/2004~10~~~~"_DFN_"|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDMEDS ; UPDATE V MED FILE
N OUT,%,SIEN,DFN,NODE
S DFN=2
S SIEN=$$SCHEMA("UPDATE MEDS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`305^`"_DFN_"^`7806^T1T QID^40"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
LAB ; DISPLAY LAB TEST RESULTS
N OUT,%,SIEN,DFN
S DFN=280
S SIEN=$$SCHEMA("VIEW LABS")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1965~12/31/2003~10~~~~"_DFN_"|175|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDLAB ; UPDATE V LAB
N OUT,%,SIEN,DFN,NODE
S DFN=2
S SIEN=$$SCHEMA("UPDATE LABS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`175^`"_DFN_"^`7806^216"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
EXAMS ; DISPLAY EXAMS
N OUT,%,SIEN,DFN
S DFN=1373
S SIEN=$$SCHEMA("VIEW EXAMS")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1966~12/31/2003~10~~~~"_DFN_"|6|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDEXAMS ; UPDATE V EXAM
S DFN=2
S SIEN=$$SCHEMA("UPDATE EXAMS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`6^`"_DFN_"^`7806^NORMAL"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
IMM ; DISPLAY IMMUNIZATIONS
N OUT,%,SIEN,DFN
S DFN=54
S SIEN=$$SCHEMA("VIEW IMM")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1966~12/31/2003~10~~~~"_DFN_"|101|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
PROV ; DISPLAY PROVIDERS FOR A VISIT
N OUT,%,SIEN,VIEN
S VIEN=4703
S SIEN=$$SCHEMA("VIEW PROV")
D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPROV ; UPDATE V PROVIDER FILE
N OUT,%,SIEN,NODE,PIEN,DFN
S PIEN=DUZ,DFN=2
I $P(^DD(9000010.06,.01,0),U,3)["DIC(6" S PIEN=$P(^VA(200,PIEN,0),U,16) ; CONVERT FILE 200 TO FILE 16 IF NECESS.
S SIEN=$$SCHEMA("UPDATE PROV")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`"_PIEN_"^`"_DFN_"^`7806^P"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PROC ; DISPLAY PROCEDURES
N OUT,%,SIEN,DFN
S DFN=235
S SIEN=$$SCHEMA("VIEW PROCEDURES")
D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1965~12/31/2003~10~~~~"_DFN_"|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPROC ; UPDATE V PROCEDURES FILE
N OUT,%,SIEN,DFN,NODE
S DFN=2
S SIEN=$$SCHEMA("UPDATE PROCEDURES")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`2198^`"_DFN_"^`7806^`8718"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
CPT ; DISPLAY CPT CODES
N OUT,%,SIEN,DFN
S VIEN=8082
S SIEN=$$SCHEMA("VIEW CPT")
D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDCPT ; UPDATE V CPT FILE
N OUT,%,SIEN,DFN,NODE
S DFN=2
S SIEN=$$SCHEMA("UPDATE CPT")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`10000^`"_DFN_"^`7806"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
PH ; DISPLAY PERSONAL HISTORY
N OUT,%,SIEN,DFN
S DFN=1373
S SIEN=$$SCHEMA("VIEW PERSONAL HISTORY")
D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDPH ; UPDATE PERSONAL HX
N OUT,%,SIEN,DFN,NODE,ICD,TEXT
S ICD=2477
S TEXT="PERSONAL HISTORY OF SERIOUS PROBLEMS"
S DFN=2
S SIEN=$$SCHEMA("UPDATE PERSONAL HISTORY")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`11353^`"_DFN_"^2851219^"_TEXT_"^2810303"_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
FH ; DISPLAY FAMILY HX
N OUT,%,SIEN,DFN
S DFN=631
S SIEN=$$SCHEMA("VIEW FAMILY HISTORY")
D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDFH ; UPDATE FAMILY HISTORY
N OUT,%,SIEN,DFN,NODE,ICD,TEXT
S ICD=2477
S TEXT="FAMILY HISTORY OF SERIOUS PROBLEMS"
S DFN=2
S SIEN=$$SCHEMA("UPDATE FAMILY HISTORY")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`7571^`"_DFN_"^2851219^"_TEXT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
HF ; DISPLAY HEALTH FACTORS
N OUT,%,SIEN,DFN
S DFN=2390
S SIEN=$$SCHEMA("VIEW HEALTH FACTORS")
D SS^BMXADO(.OUT,SIEN,"","AC"_"~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDHF ; UPDATE HEALTH FACTORS FILE
N OUT,%,SIEN,DFN,NODE
S DFN=2
S SIEN=$$SCHEMA("UPDATE HEALTH FACTORS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`3^`"_DFN_U_DT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
REPRO ; DISPLAY REPRODUCTIVE FACTORS
N OUT,%,SIEN,DFN
S DFN=1373
S SIEN=$$SCHEMA("VIEW REPRODUCTIVE FACTORS")
D SS^BMXADO(.OUT,SIEN,"","B"_"~"_DFN_"~"_DFN_"~~~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADDREPRO ; UPDATE REPRODUCTIVE FACTORS
; THE .O1 FIELD IS DINUMED
; THEREFORE, THE FILER WILL AUTOMATICALLY SWITCH TO MOD MODE IF A RECORD ALREADY EXISTS FOR THIS PATIENT
N OUT,%,SIEN,DFN,NODE
S DFN=2
; I $D(^AUPNREP(DFN)) G ERF
S SIEN=$$SCHEMA("UPDATE REPRODUCTIVE FACTORS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`"_DFN_"^G5P4LC3SA1TA0^"_DT_"^2^3040101^"_DT_$C(30)
D DISP(OUT) R %:$G(DTIME,60)
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J)))
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%)
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 12 KiB

296
m/BMXADOXY.m Normal file
View File

@ -0,0 +1,296 @@
BMXADOXY ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ;
;;2.1;BMX;;Jul 26, 2009
; EXMAPLES OF FILEMAN SCHEMA GENERATION
;
;
;
DISP(OUT) ; TEMP DISPLAY OF THE ANR
N I,X
S I=0 W !
F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X
Q
;
SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN
N IEN
S IEN=$O(^BMXADO("B",NAME,0))
Q IEN
;
NUM ; ITERATE BY IEN
; IX="",START WITH IEN=1, STOP AFTER IEN=20, MAX # RECORDS RETURNED = 5
; TO VIEW INTERNAL VALUES SET VSTG="~1~20~5~I"
N OUT,%,SIEN
S SIEN=$$SCHEMA("IHS PATIENT")
D SS^BMXADO(.OUT,SIEN,"","~1~20~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
IX ; ITERATE BY INDEX
; ITERATE USING THE "B" INDEX
; START WITH PT NAME "C", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5
N OUT,%,SIEN
S SIEN=$$SCHEMA("IHS PATIENT")
D SS^BMXADO(.OUT,SIEN,"","B~C~D~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
RENT ; ITERATE IN CHUNKS
; RE-ITERATE USING THE "B" INDEX
; START WITH PT IEN 5 AS THE "SEED", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5
N OUT,%,SIEN,SEED,LSEED,X,Y
S SEED=0,LSEED=""
S SIEN=$$SCHEMA("IHS PATIENT")
RIT F D I '$G(SEED) Q
. D SS^BMXADO(.OUT,SIEN,SEED,"B~CA~CB~5")
. D DISP(OUT) R %:$G(DTIME,60) E S SEED="" Q
. I %?1"^" S SEED="" Q
. S X=$P(@OUT@(1),U,1)
. S SEED=$P(X,"|",3)
. I SEED=LSEED S SEED="" Q
. S LSEED=SEED
. K ^TMP("BMX ADO",$J)
. Q
Q
;
SUB ; SUBFILE ITERATION
; THE SCHEMA IS ATTACHED TO THE MEDICARE ELIGIBILITY FILE/ELIG DATE SUBFILE
; THE DA STRING HAS A VALUE OF '4,',: THE IEN IN THE PARENT FILE (PATIENT DFN).
; NOTE THE COMMA IN THE DA STRING. THIS INDICATES THAT THE FILE IEN IS 4 BUT THE SUBFILE IEN IS UNSPECIFIED
N OUT,%,SIEN
S SIEN=$$SCHEMA("UPDATE MEDICARE DATES")
;D SS^BMXADO(.OUT,SIEN,"1,","~~~")
D SS^BMXADO(.OUT,18,"1,","~~~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
DINUM ; DINUMED POINTER ITERATION
; THE SCHEMA IS ATTACHED TO THE PATIENT FILE (9000001)
; THE PATIENT FILE IS DINUM'D AND ITS .01 FIELD POINTS TO THE VA PATIENT FILE (2)
; BECAUSE OF THE SPECIAL RELATIONSHIP BETWEEN THE FILES, WE CAN USE THE B INDEX OF FILE 2 TO ITERATE FILE 9000001.
N OUT,%,SIEN
S SIEN=$$SCHEMA("IHS PATIENT")
D SS^BMXADO(.OUT,SIEN,"","B~A~B~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
IXP ; INDEXED POINTER ITERATION
; THE SCHEMA IS ATTACHED TO THE V POV FILE
; THE AC CROSS REFERENCE INDEXES THE PATIENT FIELD
; BY STARTING AND STOPING WITH PATIENT 235 (MAX=5) WE COLLECT THE FIRST 5 POVS FOR PATIENT 235 IN THE FILE
N OUT,%,SIEN
S SIEN=$$SCHEMA("VIEW POVS")
D SS^BMXADO(.OUT,SIEN,"","AC~235~235~5")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
AA ; ITERATE USING AA INDEX
; INDEX IS 'AA" THE START AND STOP DATES ARE SPECIFIED IN EXTERNAL FORMAT. MAX=10
; THE FOLLOWING FILTERS ARE SPECIFIED IN THE LAST PARAMETER ("235|WT|C"):
; 235=PATIENT DFN #235
; WT=RETURN ONLY WEIGHTS. MEASUREMENT TYPE MUST BE SPECIFIED WITH A VALID, UNAMBIGUOUS LOOKUP VALUE.
; C=RETRUN VALUES IN CHRONOLOGICAL ORDER USE 'R' INSTEAD OF 'C' FOR REVERSE CHRONOLOGICAL ORDER. DEFAULT=C
; THE SEED PARAMTER IS SET AND CAN BE USED TO RETURN DATA IN CHUNKS
N OUT,%,SIEN
S SIEN=$$SCHEMA("VIEW MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~5~~~~235|WT|C")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
AA2 ; ITERATE USING AA INDEX
; THIS SCHEMA IS ATTACHED TO THE VISIT FILE (9000010)
; IN THIS CASE THERE IS NO ATTRIBUTE TYPE SO THE FILTER PARAM HAS ONLY 2 PIECES "1|R"
; 235=PATIENT DFN
; R=RETURN DATA IN REVERSE CHRONOLOGICAL ORDER
N OUT,%,SIEN
S SIEN=$$SCHEMA("VISITS") ;12
D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~5~~~~235|R")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
CIT ; CUSTOM ITERATOR
; IF COMPLEX OR UNUSUAL SORTING/FILTERING IS REQUITED, USE A CUSTOM ITERATOR
; THE CUSTOM ITERATOR IS DEFINED BY 6TH, 7TH AND 8TH PIECES IN THE VSTG
; PIECE 8=TAG, PIECE 9=ROUTINE, PIECE 8=A PARAMETER PASSED TO THE ENTRY POINT
; THE 9TH PIECE CONTAINS PT DFN, TIMESTAMP, VISIT TYPE, LOC IEN, AND SERVICE CATEGORY IN A "|" DELIMTED STRING
; THE ITERATOR CALL TAG^ROUTINE(PARAM) TO GENERATE IENS
; IN THIS CASE THE SCHEMA IS ATTACHED TO THE VISIT FILE.
; GIVEN THE INFORMATION IN THE PARAMETER, THE CUSTOM ITERATOR RETURNS POSSIBLE DUPLICATE VISITS
N OUT,%,SIEN
S SIEN=$$SCHEMA("VISITS")
D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~9285|5/24/04@1PM|I|516|~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ID ; IDENTIFIER FIELD
; THE SCHEMA IS ATTACHED TO THE VA PATIENT FILE (2)
; THE SCHEMA HAS A BUILT IN FIELD (.01ID) THAT RETURNS THE IDENTIFIERS
; THE ENTRY POINT THAT GENERATES THE IDETIFIERS IS STORED IN THE BMX ADO SCHEMA FILE
; PATIENT DFN=235
N OUT,%,SIEN
S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS")
D SS^BMXADO(.OUT,SIEN,"","~235~235~")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JSTD ; STANDARD JOIN
; BY SPECIFYING A JOIN IN THE VSTG, MULTIPLE SCHEMAE AND DATA SETS ARE RETURNED IN ONE PASS
; THE SCHEMA IS ATTACHED TO THE V MEASUREMENT FILE
; THIS IS JOINED TO A SECOND FILE, THE VA PATIENT FILE VIA A JOIN
; THE JOIN IS BASTED ON THE FACT THAT THE PATIENT FIELD (.02) IN THE V MEASUREMENT FILE POINTS TO THE VA PATIENT FILE
; THE JOIN PARAMETER IS THE 9TH PIECE OF THE VSTG. IT CONSISTS OF 2 PIECES DELIMITED BY A ","
; PIECE 1 IS THE SCHEMA THAT YOU ARE JOINING TO
; PIECE 2 IS THE FIELD IN THE PRIMARY FILE THAT ENABLES THE JOIN
; THE DATA SET FROM THE SECOND (JOIN) FILE CONTAINS ONLY THOSE RECORDS NECESSARY TO COMPLETE THE JOIN
; PATIENT DFN=235, INDEX=AA, MAX=5, START=3/21/65, STOP=6/4/04
N OUT,%,SIEN1,SIEN2
S SIEN2=$$SCHEMA("VIEW MEASUREMENTS")
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
;SIEN1=23, SIEN2=11
;D SS^BMXADO(.OUT,SIEN1,"","AA~3/21/1965~6/4/2004~5~~~~234|WT|C~"_SIEN2_",.02")
D SS^BMXADO(.OUT,SIEN1,"","~234~236~~~~~~"_SIEN2_",.01")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
HWSTD ;
; PATIENT DFN=235, INDEX=AA, MAX=5, START=3/21/65, STOP=6/4/04
N OUT,%,SIEN1,SIEN2
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
S SIEN2=$$SCHEMA("VIEW MEASUREMENTS")
;SIEN2=23, SIEN1=11
D SS^BMXADO(.OUT,SIEN1,"","~235~250~~~~~~"_SIEN2_",.01")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JMD ;JOIN MASTER TO DETAIL
N OUT,%,SIEN1,SIEN2,SIEN3,VSTG
S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS")
S SIEN2=$$SCHEMA("VIEW MEASUREMENTS")
S SIEN3=$$SCHEMA("VIEW MEDS")
S VSTG="~1~5~~~~~~"
;S VSTG=VSTG_SIEN3_",.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C"
S VSTG=VSTG_SIEN3_",.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C"
;S VSTG="~1~5~~~~~~23,.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|WT|C"
;BMX ADO SS^11^^~1~5~~~~~~23,.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|WT|C
;BMX ADO SS^11^^~1~5~~~~~~25,.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C
D SS^BMXADO(.OUT,SIEN1,"",VSTG)
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JSUB ; SUBFILE JOIN
; IN THIS CASE THE RECORDS IN A PARENT FILE ARE "JOINED" TO THE RECORDS IN ONE OF ITS SUB FILES
; THE SCHEMA IS ATTACHED TO THE "MEDICARE ELIGIBLE" FILE
; IT IS JOINED TO ITS SUBFILE, "ELIG DATES", VIA THE UPDATE MEDICARE DATES SCHEMA
; THE SYNTAX FOR THE JOIN PIECE IS "sien2,SUB" WHERE sien2=IEN OF SECOND SCHEMA
; PATIENT DFN=4
N OUT,%,SIEN1,SIEN2
S SIEN1=$$SCHEMA("UPDATE MEDICARE INFO") ;17
S SIEN2=$$SCHEMA("UPDATE MEDICARE DATES") ;18
;BMX ADO SS^17^^~4~5~~~~~~18,SUB
D SS^BMXADO(.OUT,SIEN1,"","~4~5~~~~~~"_SIEN2_",SUB")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
JPAR ; PARENT FILE JOIN
; SIMILAR TO A SUBFILE JOIN EXCEPT THE SUB-FILE IS TREATED AS THE PRIMARY FILE AND IT IS JOINED TO ITS PARENT
; BECAUSE WE ARE STARTING IN A SUBFILE, THE DA STRING CONTAINS THE IEN OF THE PARENT FILE ("4,"
; THE SYNTAX OF THE 9TH PIECE IS "sien2,PARENT" WHERE sien2 IS THE IEN OF THE SECONDARY SCHEMA
; PATIENT DFN=4
N OUT,%,SIEN1,SIEN2
S SIEN1=$$SCHEMA("UPDATE MEDICARE DATES")
S SIEN2=$$SCHEMA("UPDATE MEDICARE INFO")
D SS^BMXADO(.OUT,SIEN1,"4,","~~~5~~~~~"_SIEN2_",PARENT")
D DISP(OUT) R %:$G(DTIME,60)
K ^TMP("BMX ADO",$J)
Q
;
ADD ; ADD A NEW ENTRY
; THIS IS A 2 STEP PROCESS:
; FIRST GET THE SCHEMA FOR THE FILE YOU WISH TO UPDATE
; THIS SCHEMA'S NAME TYPICALLY BEGINS WITH THE WORD "UPDATE"
; IT CONTAINS NO ID OR IEN FIELDS
; SECOND ADD THE DATA NODE TO THE ARRAY
; IT HAS THE SAME FORMAT AS A DATA STRING ASSOCIATED WITH THE SCHEMA EXCEPT THE FIRST "^" PIECE IS NULL
; THIS PIECE CORRESPONDS TO THE IEN OF THE RECORD. SINCE THE RECORD HAS NOT BEEN ADDED YET, IT IS NULL.
; IN THE DATA STRING, ALL POINTER VALUES ARE PRECEDED BY THE '`' CHARACTER AND EA. STRING ENDS IN $C(30)
; MULTIPLE DATA STRINGS CAN BE APPENDED AS NEW NODES AT THE BOTTOM OF THE ARRAY
; IN THIS CASE WE ARE ADDING A RECORD TO THE V MEASUREMENT FILE
; DATA STRING="^MEASUREMENT TYPE IEN^PATIENT DFN^VISIT IEN^RESULT"_$C(30)
; THERE ARE 2 INPUT PARAMS:
; THE CLOSED REF WHERE THE INPUT ARRAY IS STORED
; SINCE IT IS PASSED BY REFERENCE "OUT" CAN BE NULL OR UNDEFIEND.
; OUT WILL BE DEFINED AT THE CONCLUSION OF THE TRANSACTION.
; THE OUTPUT IS IN THE OUT ARRAY
; OUT(1)="OK|ien" WHERE ien IS THE IEN OF THE RECORD THAT HAS BEE ADDED.
; IF THE TRANSACTION FAILED, AN ERROR MSG WILL BE IN THE OUT ARRAY
; MEASUREMENT TYPE=2, PATIENT DFN=2, VISIT IEN=7806, PATIENT'S WEIGHT=172.75
N OUT,%,SIEN,NODE,DFN
S DFN=2
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="^`2^`"_DFN_"^`7806^172.75"_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
DEL ; DELETE A RECORD
; THE SIPLEST WAY TO DELETE AN ENTRY IS TO PUT THE RECORD IEN IN THE DA STRING PRECEDED BY A MINUS SIGN
; YOU CAN ALSO SET THE VALUE OF THE .01 FIELD TO "@"
; IF THE VALUE OF THE .01 FIELD IS NULL AND THE DA STRING IS NOT PRECEDED BY A MINUS SIGN, THE TRANSACTION WILL BE CANCELLED
; IF THE DA STRING IS NULL, THE TRANSACTION WILL BE CANCELLED
; IN THIS EXAMPLE, WE DELETE A V MEASUREMENT RECORD THAT WAS JUST ADDED
N OUT,%,SIEN,NODE,DEL
S DEL=1621
S SIEN=$$SCHEMA("UPDATE MEASUREMENTS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="-"_DEL_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
EDIT ; EDIT AN EXISTING ENTRY
; SIMILAR TO ABOVE EXCEPT THAT THE FIRST "^" PIECE OF THE DATA NODE IS THE IEN OF THE RECORD TO BE EDITIED
; NOTE THAT THERE IS NO '`' IN FRONT OF THE FIRST PIECE. IT IS A PURE INTEGER
; LAB TEST=175, PATIENT DFN=2, VISIT IEN=8040, PT'S GLUCOSE=276, ANORMAL="ABNORMAL"
N OUT,%,SIEN,NODE
S SIEN=$$SCHEMA("UPDATE LABS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="279^`175^`2^`8040^280^H"_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
DELVAL ; DELETE A VALUE IN A FIELD
; SIMILAR TO EDIT EXCEPT THE VALUE IS "@"
; DELETE WILL BE ABORTED IF IF FILEMAN SAYS THIS IS A REQUIRED FIELD
N OUT,%,SIEN,NODE
S SIEN=$$SCHEMA("UPDATE LABS")
D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA
S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1
S ^TMP("BMX ADO",$J,NODE)="279^`175^`2^`8040^^@"_$C(30)
D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD
D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD
K ^TMP("BMX ADO",$J)
W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 12 KiB

57
m/BMXE01.m Normal file
View File

@ -0,0 +1,57 @@
BMXE01 ; IHS/OIT/FJE - ENVIRONMENT CHECK FOR BMX 2.0 ;
;;2.1;BMX;;Jul 26, 2009
;
S $P(LINE,"*",81)=""
S XPDNOQUE="NO QUE" ;NO QUEUING ALLOWED
S XPDABORT=0
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." S XPX="DUZ" D SORRY Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." S XPX="DUZ" D SORRY Q
;
D HOME^%ZIS,DT^DICRW
S X=$P($G(^VA(200,DUZ,0)),U)
I $G(X)="" W !,"Who are you????" S XPX="DUZ" D SORRY Q
W !,"Hello, "_$P(X,",",2)_" "_$P(X,",")
W !!,"Checking Environment for Install of Version "_$P($T(+2),";",3)_" of "_$P($T(+2),";",4)_"."
;
S X=$G(^DD("VERSION"))
W !!,"Need at least FileMan 22.....FileMan "_X_" Present"
I X<22 S XPX="FM" D SORRY Q
;
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XU",0)),"VERSION"))
W !!,"Need at least Kernel 8.0.....Kernel "_X_" Present"
I +X<8 S XPX="KERNEL" D SORRY Q
;
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XB",0)),"VERSION"))
W !!,"Need at least XB/ZIB 3.....XB/ZIB "_X_" Present"
I +X<2 S XPX="XB" D SORRY Q
q
ENVOK ; If this is just an environ check, end here.
W !!,"ENVIRONMENT OK."
;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
I $G(XPDENV)=1 D ;Updates BMX Version file
.S X="2",DIC="^BMXAPPL(",DLAYGO=90093.2,DIC(0)="E" K DD,D0 D FILE^DICN
.S DA=+Y
.S:+DA DIE="^BMXAPPL(",DR=".02///0;.03////"_DT D ^DIE
.K DIE,DA
Q
SORRY ;
K DIFQ
S XPDABORT=1
W *7,!!!,"Sorry....something is wrong with your environment"
W !,"Aborting BMX Version 2.0 Install!"
W !,"Correct error and reinstall otherwise"
W !,"please print/capture this screen and notify"
W !,"technical support."
W !!,LINE
D BMES^XPDUTL("Sorry....something is wrong with your environment")
D BMES^XPDUTL("Enviroment ERROR "_$G(XPX))
D BMES^XPDUTL("Aborting BMX 2.0 install!")
D BMES^XPDUTL("Correct error and reinstall otherwise")
D BMES^XPDUTL("please print/capture this screen and notify")
D BMES^XPDUTL("technical support.")
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 1.9 KiB

260
m/BMXFIND.m Normal file
View File

@ -0,0 +1,260 @@
BMXFIND ; IHS/OIT/HMW - BMX GENERIC FIND ;
;;2.1;BMX;;Jul 26, 2009
;
;
TABLE(BMXGBL,BMXFL) ;EP
;
;---> If file number not provided check for file name.
;S ^HW("BMXTABLE")=BMXFL
S BMX31=$C(31)_$C(31)
I +BMXFL'=BMXFL D
. S BMXFL=$TR(BMXFL,"_"," ")
. I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
. S BMXFL=$O(^DIC("B",BMXFL,0))
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
D FIND(.BMXGBL,BMXFL,"*",,,10,,,,1)
Q
;
FIND(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC,BMXNUM) ;EP
;
;TODO:
; -- Return column info even if no rows returned
;
;---> Places matching records from requested file into a
;---> result global, ^BMXTEMP($J). The exact global name
;---> is returned in the first parameter (BMXGBL).
;---> Records are returned one per node in the result global.
;---> Each record is terminated with a $C(30), for parsing out
;---> on the VB side, since the Broker concatenates all nodes
;---> into a single string when passing the data out of M.
;---> Requested fields within records are delimited by "^".
;---> NOTE: The first "^"-piece of every node is the IEN of
;---> that entry in its file; the requested fields follow.
;---> The final record (node) contains Error Delimiter,
; $C(31)_$C(31), followed by error text, if any.
;
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXFL (req) File for lookup.
; 3 - BMXFLDS (opt) Fields to return w/each entry.
; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent.
; 5 - BMXIN (opt) Input to match on (see Algorithm below).
; 6 - BMXMX (opt) Maximum number of entries to return.
; 7 - BMXIX (opt) Indexes to search.
; 8 - BMXSCR (opt) Screen/filter (M code).
; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
; (Converts data in uppercase to mixed case.)
; 10 - BMXNUM (opt) Include IEN in returned recordset (1=true)
;
;---> Set variables, kill temp globals.
;N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC)
S BMX31=$C(31)_$C(31)
S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^"
K ^BMXTMP($J),^BMXTEMP($J)
;
;---> If file number not provided check for file name.
I +BMXFL'=BMXFL D
. I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
. S BMXFL=$O(^DIC("B",BMXFL,0))
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
;
;---> If no fields provided, pass .01.
;---> NOTE: If .01 is NOT included, but the Index to lookup on is
;---> NOT on the .01, then the .01 will be returned
;---> automatically as the second ^-piece of data in the
;---> Result Global.
;---> So it would be: IEN^.01^requested fields...
I $G(BMXFLDS)="" S BMXFLDS=".01"
;
;---> If no index or flag provided, set flag="M".
I $G(BMXFLG)="" D
.I $G(BMXIX)="" S BMXFLG="M" Q
.S BMXFLG=""
;
;---> If no Maximum Number provided, set it to 200.
I '$G(BMXMX) S BMXMX=200
;
;---> Define index and screen.
S:'$D(BMXIX) BMXIX=""
S:'$D(BMXSCR) BMXSCR=""
;
;---> Set Target Global for output and errors.
S BMXG="^BMXTMP($J)"
;
;---> If Mixed Case not set, set to No Change.
I '$D(BMXMC) S BMXMC=0
;
;---> If Return IEN not set, set to No
I '$D(BMXNUM) S BMXNUM=0
S BMXNUM=+BMXNUM
;
;---> Silent Fileman call.
D
.I $G(BMXIN)="" D Q
..D LIST^DIC(BMXFL,,,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG)
.D FIND^DIC(BMXFL,,,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG)
;
D WRITE
Q
;
;
;----------
WRITE ;EP
;---> Collect data for matching records and write in result global.
;
;---> First, check for errors.
;---> If errors exist, write them and quit.
N I,N,X
I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q
.S N=0,X=""
.F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D
..N M S M=0
..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D
...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" "
.D ERROUT(X,1)
;
;
;---> Write valid results.
;---> Loop through the IEN node (...2,N) of the temp global.
; and call GETS^DIQ for each record
N I,N,X S N=0
S BMXA="A"
;B
S I=0
S BMXFLDF=0
RESULTS F S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D
. S X=^BMXTMP($J,"DILIST",2,N)
. S I=I+1
. K A
. D GETS^DIQ(BMXFL,X_",",BMXFLDS,,BMXA,BMXA)
. ;--->Once only, write field names
. D:'BMXFLDF FIELDS
. ;
. ;
. ;---> Loop through results global
. S F=0,BMXCNT=0
. F S F=$O(A(BMXFL,X_",",F)) Q:'F S BMXCNT=BMXCNT+1
. S F=0
. S BMXREC=""
. S:BMXNUM ^BMXTEMP($J,I)=X_"^"
. S BMXCNTB=0
. S BMXORD=BMXNUM
. F S F=$O(A(BMXFL,X_",",F)) Q:'F S BMXCNTB=BMXCNTB+1 D S:BMXCNTB<BMXCNT ^BMXTEMP($J,I)=^BMXTEMP($J,I)_U
. . S BMXORD=BMXORD+1
. . I $P(^DD(BMXFL,F,0),U,2) D I 1 ;Multiple or WP
. . . ;Get the subfile number into FL1
. . . S FL1=+$P(^DD(BMXFL,F,0),U,2)
. . . S FLD1=$O(^DD(FL1,0))
. . . I $P(^DD(FL1,FLD1,0),U,2)["W" D ;WP
. . . . S WPL=0,BMXLTMP=0
. . . . F S WPL=$O(A(BMXFL,X_",",F,WPL)) Q:'WPL S I=I+1 D
. . . . . S ^BMXTEMP($J,I)=A(BMXFL,X_",",F,WPL)_" "
. . . . . S BMXLTMP=BMXLTMP+$L(A(BMXFL,X_",",F,WPL))+1
. . . . . Q
. . . . S:BMXLTMP>BMXLEN(BMXORD) BMXLEN(BMXORD)=BMXLTMP
. . . . Q
. . . D ;It's a multiple. Implement in next phase
. . . . Q ;
. . . Q
. . E D ;Not a multiple
. . . S I=I+1
. . . S ^BMXTEMP($J,I)=A(BMXFL,X_",",F)
. . . S:$L(A(BMXFL,X_",",F))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFL,X_",",F))
. . . Q
. . Q
. ;---> Convert data to mixed case if BMXMC=1.
. ;S:BMXMC BMXREC=$$T^BMXTRS(BMXREC)
. ;---> Set data in result global.
. S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_$C(30)
;
;---> If no results, report it as an error.
D:'$O(^BMXTEMP($J,0))
.I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q
.S BMXERR="Either the lookup file is empty"
.S BMXERR=BMXERR_" or all entries are screened (software error)."
;
;---> Tack on Error Delimiter and any error.
S I=I+1
S ^BMXTEMP($J,I)=BMX31_BMXERR
;---> Column types and widths
S C=0
F S C=$O(BMXLEN(C)) Q:'C D
. I BMXLEN(C)>99999 S BMXLEN(C)=99999
. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
Q
;
;
NUMCHAR(BMXN) ;EP
;---> Returns Field Length left-padded with 0
;
N BMXC
S BMXC="00000"_BMXN
Q $E(BMXC,$L(BMXC)-4,$L(BMXC))
;
;---> Dead code follows
N C,BMXC,F,N,J
S BMXC=""
S N=BMXN
S:N>99999 N=99999
S:N<0 N=0
F J=1:1:$L(N) D
. S F=10**(J-1)
. S C=65+(N-((N\(10*F))*(10*F))\F)
. S C=$C(C)
. S BMXC=C_BMXC
S BMXC="AAAAA"_BMXC
Q $E(BMXC,$L(BMXC)-4,$L(BMXC))
;
;
FIELDS ;---> Write Field Names
;Field name is TAAAAANAME
;Where T is the field type (T=Text; D=Date)
; AAAAA is the field size (see NUMCHAR routine)
; NAME is the field name
S BMXFLDF=1
K BMXLEN,BMXTYP
D:$D(A)
. I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number
. S ASDXFNUM=0
. S BMXIENS=$O(A(BMXFL,0))
. F S ASDXFNUM=$O(A(BMXFL,BMXIENS,ASDXFNUM)) Q:'ASDXFNUM D
. . S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^") ;Get type here
. . S ASDXFNAM=$TR(ASDXFNAM," ","_")
. . S BMXTYP(I)="T"
. . S BMXLEN(I)=0 ;Start with length zero
. . S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_I
. . S ^BMXTEMP($J,I)=ASDXFNAM_"^"
. . S I=I+1
. S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30)
Q
;
;----------
ERROUT(BMXERR,I) ;EP
;---> Save next line for Error Code File if ever used.
;---> If necessary, use I>1 to avoid overwriting valid data.
S:'$G(I) I=1
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
PASSERR(BMXGBL,BMXERR) ;EP
;---> If the RPC routine calling the BMX Generic Lookup above
;---> detects a specific error prior to the call and wants to pass
;---> that error in the result global rather than a generic error,
;---> then a call to this function (PASSERR) can be made.
;---> This call will store the error text passed in the result global.
;---> The calling routine should then quit (abort its call to the
;---> BMX Generic Lookup function above).
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXERR (req) Text of error to be stored in result global.
;
S:$G(BMXERR)="" BMXERR="Error not passed (software error)."
;
N BMX31 S BMX31=$C(31)_$C(31)
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S ^BMXTEMP($J,1)=BMX31_BMXERR
Q
Side by Side

After

Width:  |  Height:  |  Size: 8.0 KiB

54
m/BMXG.m Normal file
View File

@ -0,0 +1,54 @@
BMXG ; IHS/OIT/HMW - UTIL: GET DATA ;
;;2.1;BMX;;Jul 26, 2009
;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;
;
;----------
GET(FILE,Y,PC) ;EP
;---> Return text of .01 Field of an entry in a file.
;---> Parameters:
; 1 - FILE (req) Number corresponding to desired file:
; 1 = State File, #5
; 2 = Community File, #9999999.5
; 3 = Employer File, #9999999.75
; 4 = Beneficiary File, #9999999.25
; 5 = Tribe File, #9999999.03
; 6 = Insurer File, #9999999.18
; 7 = Suffix File, #9999999.32
; 8 = Employer Group Insurance File, #9999999.77
; 9 = Medicare Eligible File, #9000003
; 10 = Medicaid Eligible File, #9000004
; 11 = Private Insurance Eligible File, #9000006
; 12 = Patient File, #9000001
; 13 = VA Patient File, #2
; 14 = Policy Holder File, #9000003.1
; 15 = Relationship File, #9999999.36
;
; 2 - Y (req) IEN in the File storing the desired entry.
; 3 - PC (opt) Piece of 0-Node to return (default=1).
; If PC=0 return entire 0-node.
;
Q:($G(Y)'?1N.N) ""
Q:'$G(FILE) ""
S:$G(PC)="" PC=1 S U="^"
;
D
.I FILE=1 S GLB="^DIC(5,"_Y_",0)" Q
.I FILE=2 S GLB="^AUTTCOM("_Y_",0)" Q
.I FILE=3 S GLB="^AUTNEMPL("_Y_",0)" Q
.I FILE=4 S GLB="^AUTTBEN("_Y_",0)" Q
.I FILE=5 S GLB="^AUTTTRI("_Y_",0)" Q
.I FILE=6 S GLB="^AUTNINS("_Y_",0)" Q
.I FILE=7 S GLB="^AUTTMCS("_Y_",0)" Q
.I FILE=8 S GLB="^AUTNEGRP("_Y_",0)" Q
.I FILE=9 S GLB="^AUPNMCR("_Y_",0)" Q
.I FILE=10 S GLB="^AUPNMCD("_Y_",0)" Q
.I FILE=11 S GLB="^AUPNPRVT("_Y_",0)" Q
.I FILE=12 S GLB="^AUPNPAT("_Y_",0)" Q
.I FILE=13 S GLB="^DPT("_Y_",0)" Q
.I FILE=14 S GLB="^AUPN3PPH("_Y_",0)" Q
.I FILE=15 S GLB="^AUTTRLSH("_Y_",0)" Q
;
Q:'FILE ""
Q:PC=0 $G(@GLB)
Q $P($G(@GLB),U,PC)
Side by Side

After

Width:  |  Height:  |  Size: 2.0 KiB

146
m/BMXGETS.m Normal file
View File

@ -0,0 +1,146 @@
BMXGETS ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;;Horace Whitt
;;Interface to GETS^DIQ
;
;----------
GETS(BMXGBL,BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXMC,BMXNUM) ;EP
;---> The final record (node) contains Error Delimiter,
; $C(31)_$C(31), followed by error text, if any.
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXFL (req) File number for lookup.
; 3 - BMXFLDS (req) Fields to return w/each entry in IENS format.
; 4 - BMXFLG (opt) Flags - See GETS^DIQ documentation
; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
; (Converts data in uppercase to mixed case.)
; 6 - BMXNUM (opt) Include IEN as first returned field (1=true)
;
;---> Set variables, kill temp globals.
N BMX31
S BMX31=$C(31)_$C(31)
S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^"
K ^BMXTMP($J),^BMXTEMP($J)
;
;---> If file number not provided, return error.
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
;
I $G(BMXFLDS)="" S BMXFLDS=".01"
;
;---> Set Target Global for output and errors.
S BMXG="^BMXTMP($J)"
;
;---> If Mixed Case not set, set to No Change.
I '$D(BMXMC) S BMXMC=0
;
;---> If Return IEN not set, set to No
I '$D(BMXNUM) S BMXNUM=0
S BMXNUM=+BMXNUM
;
;---> Fileman call
D GETS^DIQ(BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXG,BMXG)
;
D WRITE
Q
;
;
;----------
WRITE ;EP
;---> Collect data for matching records and write in result global.
;
;---> First, check for errors.
;---> If errors exist, write them and quit.
N I,N,X,F,ASDX,ASDC,ASDXFNUM,ASDXFNAM
I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q
.S N=0,X=""
.F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D
..N M S M=0
..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D
...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" "
.D ERROUT(X,1)
;
;
;---> Write Field Names
I BMXNUM S $P(ASDX,"^",1)="IEN"
;F ASDC=1:1:$L(BMXFLDS,";") D
S ASDC=1
S ASDXFNUM=0
F S ASDXFNUM=$O(^BMXTMP($J,BMXFL,BMXIENS,ASDXFNUM)) Q:'ASDXFNUM D
. ;S ASDXFNUM=$P(BMXFLDS,";",ASDC)
. S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^")
. S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC
. S $P(ASDX,"^",ASDC+BMXNUM)=ASDXFNAM
. S ASDC=ASDC+1
S ^BMXTEMP($J,1)=ASDX_$C(30)
;---> Write valid results.
AAA ;---> Loop through results global
S I=2,N=0 F S N=$O(^BMXTMP($J,BMXFL,N)) Q:'N D
. S X="",F=0
. I BMXNUM S X=+N
. F S F=$O(^BMXTMP($J,BMXFL,N,F)) Q:'F D
. . S:X'="" X=X_U
. . I $P(^DD(BMXFL,F,0),U,2) D I 1 ;Multiple or WP
. . . ;Get the subfile number into FL1
. . . S FL1=+$P(^DD(BMXFL,F,0),U,2)
. . . S FLD1=$O(^DD(FL1,0))
. . . I $P(^DD(FL1,FLD1,0),U,2)["W" D ;WP
. . . . S WPL=0 F S WPL=$O(^BMXTMP($J,BMXFL,N,F,WPL)) Q:'WPL D
. . . . . S X=X_^BMXTMP($J,BMXFL,N,F,WPL)_" "
. . . . . Q
. . . . Q
. . . D ;It's a multiple. Implement in next phase
. . . . Q ;
. . . Q
. . E D ;Not a multiple
. . . S X=X_^BMXTMP($J,BMXFL,N,F)
. . . Q
. . Q
. ;---> Convert data to mixed case if BMXMC=1.
ZZZ . S:BMXMC X=$$T^BMXTRS(X)
. ;
. ;---> Set data in result global.
. S ^BMXTEMP($J,I)=X_$C(30)
. S I=I+1
;
;---> If no results, report it as an error.
D:'$O(^BMXTEMP($J,0))
.I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q
.S BMXERR="Either the lookup file is empty"
.S BMXERR=BMXERR_" or all entries are screened (software error)."
;
;---> Tack on Error Delimiter and any error.
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
;----------
ERROUT(BMXERR,I) ;EP
;---> Save next line for Error Code File if ever used.
;---> If necessary, use I>1 to avoid overwriting valid data.
S:'$G(I) I=1
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
PASSERR(BMXGBL,BMXERR) ;EP
;---> If the RPC routine calling the BMX Generic Lookup above
;---> detects a specific error prior to the call and wants to pass
;---> that error in the result global rather than a generic error,
;---> then a call to this function (PASSERR) can be made.
;---> This call will store the error text passed in the result global.
;---> The calling routine should then quit (abort its call to the
;---> BMX Generic Lookup function above).
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXERR (req) Text of error to be stored in result global.
;
S:$G(BMXERR)="" BMXERR="Error not passed (software error)."
;
N BMX31 S BMX31=$C(31)_$C(31)
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S ^BMXTEMP($J,1)=BMX31_BMXERR
Q
Side by Side

After

Width:  |  Height:  |  Size: 4.4 KiB

216
m/BMXMBRK.m Normal file
View File

@ -0,0 +1,216 @@
BMXMBRK ; IHS/OIT/HMW - BMXNet MONITOR ;
;;2.1;BMX;;Jul 26, 2009
;
;
PRSP(P) ;EP -Parse Protocol
;M Extrinsic Function
;
;Inputs
;P Protocol string with the form
; Protocol := Protocol Header^Message where
; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
; LLL := length of protocol header (3 numeric)
; WKID := Workstation ID (ALPHA)
; WINH := Window handle (ALPHA)
; PRCH := Process handle (ALPHA)
; WISH := Window server handle (ALPHA)
; MESG := Unparsed message
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N ERR,C,M,R,X
S R=0,C=";",ERR=0,M=512 ;Maximum buffer input
IF $E(P,1,5)="{BMX}" S P=$E(P,6,$L(P)) ;drop out prefix
IF '+$G(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S BMXZ(R,"LENG")=+$E(P,1,3)
. S X=$E(P,4,BMXZ(R,"LENG")+3)
. S BMXZ(R,"MESG")=$E(P,BMXZ(R,"LENG")+4,M)
. S BMXZ(R,"WKID")=$P(X,C)
. S BMXZ(R,"WINH")=$P(X,C,2)
. S BMXZ(R,"PRCH")=$P(X,C,3)
. S BMXZ(R,"WISH")=$P(X,C,4)
Q ERR
;
PRSM(P) ;EP - Parse message
;M Extrinsic Function
;
;Inputs
;P Message string with the form
; Message := Header^Content
; Header := LLL;FLAG
; LLL := length of entire message (3 numeric)
; FLAG := 1 indicates variables follow
; Content := Contains API call information
;Outputs
;ERR 0 for success, "-1^Text" if error
N C,ERR,M,R,X,U
S U="^",R=1,C=";",ERR=0,M=512 ;Max buffer
IF '+$G(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S BMXZ(R,"LENG")=+$E(P,1,5)
. S BMXZ(R,"FLAG")=$E(P,6,6)
. S BMXZ(R,"TEXT")=$E(P,7,M)
Q ERR
;
PRSA(P) ;EP - Parse API information, get calling info
;M Extrinsic Function
;Inputs
;P Content := API Name^Param string
; API := .01 field of API file
; Param := Parameter information
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N C,DR,ERR,M,R,T,X,U
S U="^",R=2,C=";",ERR=0,M=512 ;Max buffer
IF '+$L(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S BMXZ(R,"CAPI")=$P(P,U)
. S BMXZ(R,"PARM")=$E(P,$F(P,U),M)
. S T=$O(^XWB(8994,"B",BMXZ(R,"CAPI"),0))
. I '+T S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc
. S T(0)=$G(^XWB(8994,T,0))
. I $P(T(0),U,6)=1!($P(T(0),U,6)=2) S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' cannot be run at this time." Q ;P10. Check INACTIVE field. - dpc.
. S BMXZ(R,"NAME")=$P(T(0),"^")
. S BMXZ(R,"RTAG")=$P(T(0),"^",2)
. S BMXZ(R,"RNAM")=$P(T(0),"^",3)
. S BMXPTYPE=$P(T(0),"^",4)
. S BMXWRAP=+$P(T(0),"^",8)
Q ERR
;
PRSB(P) ;EP - Parse Parameter information
;M Extrinsic Function
;Inputs
;P Param := M parameter list
; Param := LLL,Name,Value
; LLL := length of variable name and value
; Name := name of M variable
; Value := a string
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R
S R=3,MAXP=+$E(P,1,5)
S P1=$E(P,6,MAXP+5) ;only param string
S ERR=0,F=3,M=512
IF '+$D(P) S ERR="-1^Required input reference is NULL"
S FL=+$G(BMXZ(1,"FLAG"))
S I=0
IF '+ERR D
. IF 'FL,+MAXP=0 S P1="",ERR=1 Q
. F D Q:P1=""
. . Q:P1=""
. . S L=+$E(P1,1,3)-1
. . S P3=+$E(P1,4,4)
. . S P1=$E(P1,5,MAXP)
. . S BMXZ(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV($E(P1,1,L)))
. . IF FL=1,P3=2 D ;XWB*1.1*2
. . . S A=$$OARY^BMXMBRK2,BMXARY=A
. . . S BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I))
. . S P1=$E(P1,L+1,MAXP)
. . S K=I,I=I+1
. IF 'FL Q
. S P3=P
. S L=+$E(P3,1,5)
. S P1=$E(P3,F+3,L+F)
. S P2=$E(P3,L+F+3,M)
. ;instantiate array
. F D Q:+L=0
. . S L=$$BREAD(3) Q:+L=0 S P3=$$BREAD(L)
. . S L=$$BREAD(3) IF +L'=0 S P4=$$BREAD(L)
. . IF +L=0 Q
. . IF P3=0,P4=0 S L=0 Q
. . IF FL=1 D LINST(A,P3,P4)
. . IF FL=2 D GINST
IF ERR Q P1
S P1=""
D Q P1
. F I=0:1:K D
. . IF FL,$E(BMXZ(R,"P",I),1,5)=".BMXS" D Q ;XWB*1.1*2
. . . S P1=P1_"."_$E(BMXZ(R,"P",I),2,$L(BMXZ(R,"P",I)))
. . . IF I'=K S P1=P1_","
. . S P1=P1_"BMXZ("_R_",""P"","_I_")"
. . IF I'=K S P1=P1_","
IF '+ERR Q P1
Q ERR
;
BREAD(L) ;read tcp buffer, L is length
N E,X,DONE
S (E,DONE)=0
R X#L:BMXDTIME(1)
S E=X
IF $L(E)<L F D Q:'DONE
. IF $L(E)=L S DONE=1 Q
. R X#(L-$L(E)):BMXDTIME(1)
. S E=E_X
Q E
;
CALLP(BMXP,P,DEBUG) ;EP - make API call using Protocol string
N ERR,S
S ERR=0
IF '$D(DEBUG) S DEBUG=0
S ERR=$$PRSP(P)
IF '+ERR S ERR=$$PRSM(BMXZ(0,"MESG"))
IF '+ERR S ERR=$$PRSA(BMXZ(1,"TEXT")) ;I $G(BMXZ(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q
I +ERR S BMXSEC=$P(ERR,U,2) ;P10 -- dpc
IF '+ERR S S=$$PRSB(BMXZ(2,"PARM"))
;IF (+S=0)!(+S>0) D
I '+ERR D CHKPRMIT^BMXMSEC(BMXZ(2,"CAPI")) ;checks if RPC allowed to run
S:$L($G(BMXSEC)) ERR="-1^"_BMXSEC
;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
IF '+ERR,(+S=0)!(+S>0) D
. D CAPI^BMXMBRK2(.BMXP,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
E D CLRBUF ;p10
IF 'DEBUG K BMXZ
IF $D(BMXARY) K @BMXARY,BMXARY
Q
;
LINST(A,X,BMXY) ;instantiate local array
IF BMXY=$C(1) S BMXY=""
S X=A_"("_X_")"
S @X=BMXY
Q
GINST ;instantiate global
N DONE,N,T,T1
S (DONE,I)=0
;find piece with global ref - recover $C(44)
S REF=$TR(REF,$C(23),$C(44))
F D Q:DONE
. S N=$NA(^TMP("BMXZ",$J,$P($H,",",2)))
. S BMXZ("FRM")=REF
. S BMXZ("TO")=N
. IF '$D(@N) S DONE=1 Q
;loop through all and instantiate
S DONE=0
F D Q:DONE
. S T=$E(@REF@(I),4,M)
. IF T="" S DONE=1 Q
. S @N@("BMXZ")="" ;set naked indicator
. S @T
. S I=I+1
K @N@("BMXZ")
Q
;
GETV(V) ;get value of V - reference parameter
N X
S X=V
IF $E(X,1,2)="$$" Q ""
IF $C(34,36)[$E(V) X "S V="_$$VCHK(V)
E S V=@V
Q V
;
VCHK(S) ;Parse string for first argument
N C,I,P
F I=1:1 S C=$E(S,I) D VCHKP:C="(",VCHKQ:C=$C(34) Q:" ,"[C
Q $E(S,1,I-1)
VCHKP S P=1 ;Find closing paren
F I=I+1:1 S C=$E(S,I) Q:P=0!(C="") I "()"""[C D VCHKQ:C=$C(34) S P=P+$S("("[C:1,")"[C:-1,1:0)
Q
VCHKQ ;Find closing quote
F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34))
Q
CLRBUF ;p10 Empties Input buffer
N %
F R %#1:BMXDTIME(1) Q:%=""
Q
Side by Side

After

Width:  |  Height:  |  Size: 6.0 KiB

171
m/BMXMBRK2.m Normal file
View File

@ -0,0 +1,171 @@
BMXMBRK2 ; IHS/OIT/HMW - BMXNet MONITOR ;
;;2.1;BMX;;Jul 26, 2009
;
;
CAPI(BMXY,TAG,NAM,PAR) ;EP - make API call
N R,T,DX,DY
IF BMXZ(1,"FLAG")=2 D
. S PAR=$P(PAR,BMXZ("FRM"))_BMXZ("TO")_$P(PAR,BMXZ("FRM"),2)
S R=$S(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.BMXY)",1:TAG_"^"_NAM_"(.BMXY,"_PAR_")")
U IO
D @R
; D DEBUG^%Serenji("@R","10.10.10.104")
U $P
Q
;
BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header
N S,L
S S=""
S S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"
S L=$L(S)
S S=$E("000"_L,$L(L)+1,$L(L)+3)_S
Q S
;
BARY(A,R,V) ;add array elements+values to storage array
IF A'["BMXS" Q "-1^ARRAY NAME MUST BE BMXS"
S @A@(R)=V
Q 0
;
BLDB(P) ;Build formatted string
N L
S L=$L(P)
Q $E("000"_L,$L(L)+1,$L(L)+3)_P
;
BLDA(N,P) ;Build API string
;M Extrinsic Function
;Inputs
;N API name
;P Comma delimited parameter string
;Outputs
;String API string if successful, "-1^Text" if error
;
N I,F,L,T,U,T1,T2
IF '+$D(N) Q "-1^Required input reference is NULL"
S U="^"
S (F,T,Y)=0
IF '$D(P) S P=""
IF P'="" D
. S L=$L(P)-$L($TR(P,$C(44)))+1
. IF L=0 S L=1
. F I=1:1:L D Q:T
. . S T1=$P(P,",",I)
. . S T2=$E(T1,1,1)="."
. . IF T1=+T1 Q
. . IF $E(T1,1,1)="^" S F=2,T=1 Q
. . IF T2&($E(T1,2,$L(T1))?.ANP) S F=1,T=1 Q
S P=$$BLDB(P)
S L=$L(P)+$L(P)-3
S P=F_N_U_P
S L=$L(P)
Q $E("000"_L,$L(L)+1,$L(L)+3)_P
;
BLDS(R) ;Build a parameter string from an array
N L,T,Y
S Y=""
F D Q:R=""
. S R=$Q(@R)
. IF R="" Q
. S L=$L(R)+$L(@R)+1
. S T=@R
. S T=$TR(T,$C(44),$C(23))
. S Y=Y_$E("000"_L,$L(L)+1,$L(L)+3)_R_"="_T
Q Y_"000"
;
BLDU(R) ;Build a parameter string from a scalar
N DONE,L,N,N1,P1
IF R=+R Q R
S N=$F(R,$C(34))
IF N=0 Q $C(34)_R_$C(34)
S P1=$E(R,1,N-2)
S (L,DONE)=0
F D Q:DONE
. S N1=$F(R,$C(34),N)
. IF N1=0 S L=$L(R)+2,N1=L
. S P1=P1_$C(34,34)_$E(R,N,N1-2)
. IF N1=L S DONE=1,P1=$C(34)_P1_$C(34) Q
. S N=N1
Q $TR(P1,$C(44),$C(23))
;
BLDG(R) ;build a parameter string from a global reference
N I,L,L1,M,T,T1,T2,Y
K ^TMP("BMXZ",$J)
IF '$D(R) Q "-1^Reference does not exist"
S Y=$NA(^TMP("BMXZ",$J,$P($H,",",2)))
S I=0
S M=512
S T1=$P(R,")")
S L1=$L($P(R,"("))
F D Q:R=""
. S R=$Q(@R)
. S T2=$F(R,"(")
. IF R=""!(R'[T1) Q
. S L=$L(R)+$L(@R)-L1
. S T=@R
. S T=$TR(T,$C(44),$C(23))
. S @Y@(I)=$E("000"_L,$L(L)+1,$L(L)+3)_"^("_$E(R,T2,M)_"="_$$BLDU(T)
. S I=I+1
S @Y@(I)="000"
S Y=$TR(Y,$C(44),$C(23))
Q Y
;
OARY() ;EP - create storage array
N A,DONE,I
S (DONE,I)=0
F I=1:1 D Q:DONE
. S A="BMXS"_I
. K @A ;temp fix for single array
. IF '$D(@A) S DONE=1
S @A="" ;set naked
Q A
;
CREF(R,P) ;EP - Convert array contained in P to reference A
N I,X,DONE,F1,S
S DONE=0
S S=""
F I=1:1 D Q:DONE
. IF $P(P,",",I)="" S DONE=1 Q
. S X(I)=$P(P,",",I)
. IF X(I)?1"."1A.E D
. . S F1=$F(X(I),".")
. . S X(I)="."_R
. S S=S_X(I)_","
Q $E(S,1,$L(S)-1)
;
GETP(P) ;returns various parameters out of the Protocol string
N M,T,BMXZ
S M=512
S T=$$PRSP^BMXMBRK(P)
IF '+T D
. S T=$$PRSM^BMXMBRK(BMXZ(0,"MESG"))
. IF '+T S T=BMXZ(0,"WKID")_";"_BMXZ(0,"WINH")_";"_BMXZ(0,"PRCH")_";"_BMXZ(0,"WISH")_";"_$P(BMXZ(1,"TEXT"),"^")
Q T
;
CALLM(X,P,DEBUG) ;make call using Message string
N ERR,S
S X="",ERR=0
S ERR=$$PRSM^BMXMBRK(P)
IF '+ERR S ERR=$$PRSA^BMXMBRK(BMXZ(1,"TEXT"))
IF '+ERR S S=$$PRSB^BMXMBRK(BMXZ(2,"PARM"))
IF (+S=0)!(+S>0) D
. D CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
IF 'DEBUG K BMXZ
K @(X("BMXS")),X("BMXS")
Q
;
CALLA(X,P,DEBUG) ;make call using API string
N ERR,S
S X="",ERR=0
S ERR=$$PRSA^BMXMBRK(P)
IF '+ERR S S=$$PRSB^BMXMBRK(BMXZ(2,"PARM"))
IF (+S=0)!(+S>0) D
. D CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
IF 'DEBUG K BMXZ
K @(X("BMXS")),X("BMXS")
Q
;
TRANSPRT() ;Determine the Transport Method
;DDP is local :=0
;TCP/IP is remote :=1
;Serial/RS-232 is remote :=2
Q 1
;Q 0 ;Do DDP for Now
Side by Side

After

Width:  |  Height:  |  Size: 3.7 KiB

252
m/BMXMEVN.m Normal file
View File

@ -0,0 +1,252 @@
BMXMEVN ; IHS/OIT/HMW - BMXNet MONITOR ;
;;2.1;BMX;;Jul 26, 2009
;
Q
;
REGET ;EP
;Error trap from REGEVNT, RAISEVNT, and UNREG
;
I '$D(BMXI) N BMXI S BMXI=999
S BMXI=BMXI+1
D REGERR(BMXI,99)
Q
;
REGERR(BMXI,BMXERID) ;Error processing
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)=BMXERID_$C(30)
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)=$C(31)
Q
;
REGEVNT(BMXY,BMXEVENT) ;EP
;RPC Called by BMX REGISTER EVENT to inform RPMS server
;of client's interest in BMXEVENT
;Returns RECORDSET with field ERRORID.
;If everything ok then ERRORID = 0;
;
N BMXI
S BMXI=0
S X="REGET^BMXMEVN",@^%ZOSF("TRAP")
S BMXY=$NA(^TMP("BMX",$J)) K @BMXY
S ^TMP("BMX",$J,0)="I00020ERRORID"_$C(30)
S ^TMP("BMX EVENT",$J,BMXEVENT)=$G(DUZ)
;
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)="0"_$C(30)_$C(31)
Q
;
RAISEVNT(BMXY,BMXEVENT,BMXPARAM,BMXBACK,BMXKEY) ;EP
;RPC Called to raise event BMXEVENT with parameter BMXPARAM
;If BMXBACK = 'TRUE' then event will be raised back to originator
;Calls EVENT
;Returns a RECORDSET wit the field ERRORID.
;If everything ok then ERRORID = 0;
;
N BMXI,BMXORIG
S BMXI=0
S BMXORIG=$S($G(BMXBACK)="TRUE":"",1:$J)
S BMXY=$NA(^TMP("BMX",$J)) K @BMXY
S ^TMP("BMX",$J,0)="I00020ERRORID"_$C(30)
S X="REGET^BMXMEVN",@^%ZOSF("TRAP")
;
D EVENT(BMXEVENT,BMXPARAM,BMXORIG,$G(BMXKEY))
;
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)="0"_$C(30)_$C(31)
Q
;
EVENT(BMXEVENT,BMXPARAM,BMXORIG,BMXKEY) ;PEP - Raise event to interested clients
;Clients are listed in ^TMP("BMX EVENT",BMXEVENT,BMXSESS)=DUZ
;BMXORIG represents the event originator's session
;The event will not be raised back to the originator if BMXORIG is the session of the originator
;BMXKEY is a ~-delimited list of security keys. Only holders of one of these keys
;will receive event notification. If BMXKEY is "" then all registered sessions
;will be notified.
;
L +^TMP("BMX EVENT RAISED"):30
N BMXSESS,BMXINC
S BMXSESS=0 F S BMXSESS=$O(^TMP("BMX EVENT",BMXSESS)) Q:'+BMXSESS D
. I BMXSESS=$G(BMXORIG) Q
. I '$D(^TMP("BMX EVENT",BMXSESS,BMXEVENT)) Q
. ;S BMXDUZ=^TMP("BMX EVENT",BMXEVENT,BMXSESS)
. S BMXDUZ=^TMP("BMX EVENT",BMXSESS,BMXEVENT)
. ;TODO: Test if DUZ holds at least one of the keys in BMXKEY
. S BMXINC=$O(^TMP("BMX EVENT RAISED",BMXSESS,BMXEVENT,99999999),-1)
. S:BMXINC="" BMXINC=0
. ;S ^TMP("BMXTRACK",$P($H,",",2))="Job "_$J_" Set "_$NA(^TMP("BMX EVENT RAISED",BMXSESS,BMXEVENT,BMXINC+1))_"="_$G(BMXPARAM)
. S ^TMP("BMX EVENT RAISED",BMXSESS,BMXEVENT,BMXINC+1)=$G(BMXPARAM) ;IHS/OIT/HMW SAC Exemption Applied For
. Q
L -^TMP("BMX EVENT RAISED")
Q
;
POLLD(BMXY) ;EP
;Debug Entry Point
D DEBUG^%Serenji("POLL^BMXMEVN(.BMXY)")
Q
;
POLL(BMXY) ;EP
;Check event queue for events of interest to current session
;Return DataSet of events and parameters
;Called by BMX EVENT POLL
;
N BMXI,BMXEVENT
S BMXI=0
S X="POLLET^BMXMEVN",@^%ZOSF("TRAP")
S BMXY=$NA(^TMP("BMX",$J)) K @BMXY
S ^TMP("BMX",$J,0)="T00030EVENT"_U_"T00030PARAM"_$C(30)
L +^TMP("BMX EVENT RAISED"):1 G:'$T POLLEND
;
G:'$D(^TMP("BMX EVENT RAISED",$J)) POLLEND
S BMXEVENT=0 F S BMXEVENT=$O(^TMP("BMX EVENT RAISED",$J,BMXEVENT)) Q:BMXEVENT']"" D
. N BMXINC
. S BMXINC=0
. F S BMXINC=$O(^TMP("BMX EVENT RAISED",$J,BMXEVENT,BMXINC)) Q:'+BMXINC D
. . ;Set output array node
. . S BMXPARAM=$G(^TMP("BMX EVENT RAISED",$J,BMXEVENT,BMXINC))
. . S BMXI=BMXI+1
. . S ^TMP("BMX",$J,BMXI)=BMXEVENT_U_BMXPARAM_$C(30)
. . Q
. Q
;S ^TMP("BMXTRACK",$P($H,",",2))="Job "_$J_" Killed "_$NA(^TMP("BMX EVENT RAISED",$J))
K ^TMP("BMX EVENT RAISED",$J)
;
POLLEND S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)=$C(31)
L -^TMP("BMX EVENT RAISED")
Q
;
TTESTD(BMXY,BMXTIME) ;Debug entry point
;
D DEBUG^%Serenji("TTEST^BMXMEVN(.BMXY,BMXTIME)")
Q
;
TTEST(BMXY,BMXTIME) ;EP Timer Test
;
S X="REGET^BMXMEVN",@^%ZOSF("TRAP")
S BMXY=$NA(^BMXTMP("BMX",$J)) K @BMXY
S ^BMXTMP("BMX",$J,0)="I00020HANGTIME"_$C(30)
I +BMXTIME H BMXTIME
;
S BMXI=1
S BMXI=BMXI+1
S ^BMXTMP("BMX",$J,BMXI)=BMXTIME_$C(30)_$C(31)
;
Q
;
UNREGALL ;EP
;Unregister all events for current session
;Called on exit of each session
;
N BMXEVENT
S BMXEVENT=""
K ^TMP("BMX EVENT",$J)
Q
;
UNREG(BMXY,BMXEVENT) ;EP
;RPC Called by client to Unregister client's interest in BMXEVENT
;Returns RECORDSET with field ERRORID.
;If everything ok then ERRORID = 0;
;
N BMXI
S BMXI=0
S X="REGET^BMXMEVN",@^%ZOSF("TRAP")
S BMXY=$NA(^TMP("BMX",$J)) K @BMXY
S ^TMP("BMX",$J,0)="I00020ERRORID"_$C(30)
K ^TMP("BMX EVENT",$J,BMXEVENT)
;
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)="0"_$C(30)_$C(31)
Q
;
POLLET ;EP
;Error trap from REGEVNT, RAISEVNT, ASYNCQUE and UNREG
;
I '$D(BMXI) N BMXI S BMXI=999
S BMXI=BMXI+1
D POLLERR(BMXI,99)
Q
;
POLLERR(BMXI,BMXERID) ;Error processing
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)=BMXERID_U_$C(30)
S BMXI=BMXI+1
S ^TMP("BMX",$J,BMXI)=$C(31)
Q
;
ASYNCQUE(BMXY,BMXRPC,BMXEVN) ;EP
;RPC Queues taskman to job wrapper ASYNCZTM
;
;RETURNS EVENT NAME, ZTSK in PARAM
S X="POLLET^BMXMEVN",@^%ZOSF("TRAP")
S BMXY=$NA(^TMP("BMX ASYNC QUEUE",$J)) K @BMXY
S ^TMP("BMX ASYNC QUEUE",$J,0)="I00030ERRORID"_U_"I00030PARAM"_$C(30)
;
;K ZTSK
N ZTSK,ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTDTH
;S ZTRTN="ASYNCZTD^BMXMEVN" ;Debugging call
S ZTRTN="ASYNCZTM^BMXMEVN"
S BMXRPC=$TR(BMXRPC,"~",$C(30))
S ZTSAVE("BMXRPC")=""
S ZTSAVE("BMXEVN")=""
S ZTDESC="BMX ASYNC JOB"
S ZTIO="",ZTDTH=DT
D ^%ZTLOAD
;D @ZTRTN ;Debugging call
;
S ^TMP("BMX ASYNC QUEUE",$J,1)=1_U_$G(ZTSK)_$C(30)
S ^TMP("BMX ASYNC QUEUE",$J,2)=$C(31)
Q
;
ASYNCZTD ;EP Debug entry point
D DEBUG^%Serenji("ASYNCZTM^BMXMEVN")
Q
;
ASYNCZTM ;EP
;Called by Taskman with BMXRPC and BMXEVN defined to
; 1) invoke the BMXRPC (RPC NAME^PARAM1^...^PARAMN)
; 2) when done, raises event BMXEVN with ZTSK^$J in BMXPARAM
;
N BMXRTN,BMXTAG,BMXRPCD,BMXCALL,BMXJ,BMXY,BMXNOD,BMXY
N BMXT S BMXT=$C(30)
I $E(BMXRPC,1,6)="SELECT" S BMXRPC="BMX SQL"_$C(30)_BMXRPC
S BMXRPCD=$O(^XWB(8994,"B",$P(BMXRPC,BMXT),0))
S BMXNOD=^XWB(8994,BMXRPCD,0)
S BMXRTN=$P(BMXNOD,U,3)
S BMXTAG=$P(BMXNOD,U,2)
S BMXCALL="D "_BMXTAG_"^"_BMXRTN_"(.BMXY,"
F BMXJ=2:1:$L(BMXRPC,BMXT) D
. S BMXCALL=BMXCALL_$C(34)_$P(BMXRPC,BMXT,BMXJ)_$C(34)
. S:BMXJ<$L(BMXRPC,BMXT) BMXCALL=BMXCALL_","
. Q
S BMXCALL=BMXCALL_")"
X BMXCALL
D EVENT(BMXEVN,$G(ZTSK)_"~"_$P($G(BMXY),U,2),$J,"")
Q
;
;
;Windows event handler:
;Catches event with ZTSK^DataLocation parameter
;Matches ZTSK to process that called event
;Calls ASYNCGET rpc with DATALOCATION parameter
;
ASYNCGET(BMXY,BMXDATA) ;EP
;RPC Retrieves data queued by ASYNCZTM
;by setting BMXY to BMXDATA
;
S BMXY="^"_BMXDATA
Q
;
ASYNCET ;EP
;Error trap from ASYNCQUE
;
I '$D(BMXI) N BMXI S BMXI=999
S BMXI=BMXI+1
D ASYNCERR(BMXI,0)
Q
;
ASYNCERR(BMXI,BMXERID) ;Error processing
S BMXI=BMXI+1
S ^TMP("BMX ASYNC QUEUE",$J,BMXI)=BMXERID_U_$C(30)
S BMXI=BMXI+1
S ^TMP("BMX ASYNC QUEUE",$J,BMXI)=$C(31)
Q
Side by Side

After

Width:  |  Height:  |  Size: 6.7 KiB

354
m/BMXMON.m Normal file
View File

@ -0,0 +1,354 @@
BMXMON ; IHS/OIT/HMW - BMXNet MONITOR ; 7/20/2009
;;2.1;BMX;;Jul 26, 2009
;
;IHS/OIT/HMW Patch 1 added validity check for passed-in namespace
; 7/20/2009: Release of patch to support GT.M WV/SMH
; Changes:
; Addition of XINETD and GTMLNX entry points for support of GT.M
; Changes of W *-3 (which only works on Cache) to W !
;
STRT(BMXPORT,NS,IS,VB) ;EP
;Interactive monitor start
;Optional NS = namespace. If undefined, start in current ns
;Optional IS = Integrated Security. Default is 1
;Optional VB = Verbose. Default is 1
;
N Y,BMXNS,BMXWIN
;
;Verbose
S BMXVB=$G(VB,1)
;
;Check if port already running
I '$$SEMAPHOR(BMXPORT,"LOCK") W:BMXVB "BMXNet Monitor on port "_BMXPORT_" appears to be running already.",! Q
S %=$$SEMAPHOR(BMXPORT,"UNLOCK")
;
D MARKER(BMXPORT,1) ;record problem marker
; -- start the monitor
;
;Namespace
X ^%ZOSF("UCI")
S BMXNS=$G(NS,$P(Y,","))
;
;Integrated security
S BMXWIN=$G(IS,1)
;
;J DEBUG^%Serenji("MON^BMXMON("_BMXPORT_","_BMXNS_","_BMXWIN_")")
J MON^BMXMON(BMXPORT,BMXNS,BMXWIN)::5 I '$T W:BMXVB "Unable to run BMXNet Monitor in background.",! Q ;IHS/OIT/HMW SAC Exemption Applied For
F %=1:1:5 D Q:%=0
. W:BMXVB "Checking if BMXNet Monitor has started...",!
. H 1
. S:'$$MARKER(BMXPORT,0) %=0
I $$MARKER(BMXPORT,0) D
. W:BMXVB !,"BMXNet Monitor could not be started!",!
. W:BMXVB "Check if port "_BMXPORT_" is busy on this CPU.",!
. D MARKER(BMXPORT,-1) ;clear marker
E W:BMXVB "BMXNet Monitor started successfully."
;
Q
;
RESTART ;EP
;Stop and Start all monitors in BMX MONITOR file
;Called by option BMX MONITOR START
;
D STOPALL
D STRTALL
Q
;
STRTALL ;EP
;Start all monitors in BMX MONITOR file
;
N BMXIEN
S BMXIEN=0 F S BMXIEN=$O(^BMXMON(BMXIEN)) Q:'+BMXIEN D
. S BMXNOD=$G(^BMXMON(BMXIEN,0))
. Q:'+BMXNOD
. Q:'+$P(BMXNOD,U,2)
. S BMXWIN=$P(BMXNOD,U,3)
. S BMXNS=$P(BMXNOD,U,4)
. D STRT($P(BMXNOD,U),BMXNS,BMXWIN,0)
. Q
Q
;
STOPALL ;EP
;Stop all monitors in BMXNET MONITOR file
;
N BMXIEN,BMXPORT
S BMXIEN=0 F S BMXIEN=$O(^BMXMON(BMXIEN)) Q:'+BMXIEN D
. S BMXNOD=$G(^BMXMON(BMXIEN,0))
. Q:'+BMXNOD
. S BMXPORT=+BMXNOD
. D STOP(BMXPORT,0)
Q
;
STOP(BMXPORT,VB) ;EP Stop monitor on BMXPORT
;Open a channel to monitor on BMXPORT and send shutdown request
;Optional VB = Verbose. Default is 1
;
N IP,REF,X,DEV
S U="^" D HOME^%ZIS
;
;Verbose
S BMXVB=$G(VB,1)
;
D:BMXVB EN^DDIOL("Stop BMXNet Monitor...")
X ^%ZOSF("UCI") S REF=Y
S IP="0.0.0.0" ;get server IP
IF $G(BMXPORT)="" S BMXPORT=9200
; -- make sure the listener is running
I $$SEMAPHOR(BMXPORT,"LOCK") D Q
. S %=$$SEMAPHOR(BMXPORT,"UNLOCK")
. D:BMXVB EN^DDIOL("BMXNet Monitor does not appear to be running.")
; -- send the shutdown message to the TCP Listener process
D CALL^%ZISTCP("127.0.0.1",BMXPORT) I POP D Q
. S %=$$SEMAPHOR(BMXPORT,"UNLOCK")
. D:BMXVB EN^DDIOL("BMXNet Monitor does not appear to be running.")
U IO
S X=$T(+2),X=$P(X,";;",2),X=$P(X,";")
IF X="" S X=0
S X=$C($L(X))_X
W "{BMX}00011TCPshutdown",!
R X#3:5
D CLOSE^%ZISTCP
I X="ack" D:BMXVB EN^DDIOL("BMXNet Monitor has been shutdown.")
E D:BMXVB EN^DDIOL("Shutdown Failed!")
;change process name
D CHPRN($J)
Q
;
MON(BMXPORT,NS,IS) ;Monitor port for connection & shutdown requests
;NS = Namespace to Start monitor
;IS = 1: Enable integrated security
;
N BMXDEV,BMXQUIT,BMXDTIME,BMXLEN,BMXACT,BMXWIN,BMXNS
S BMXQUIT=0,BMXDTIME=999999
;
;Set lock
Q:'$$SEMAPHOR(BMXPORT,"LOCK")
;Clear problem marker
D MARKER(BMXPORT,-1)
;H 1
;
;Namespace
X ^%ZOSF("UCI")
S BMXNS=$G(NS,$P(Y,","))
;
;Integrated security
S BMXWIN=$G(IS,1)
;
;Open server port;
S BMXDEV="|TCP|"_BMXPORT
C BMXDEV ;IHS/OIT/HMW SAC Exemption Applied For
O BMXDEV:(:BMXPORT:"S"):5 I '$T Q ;IHS/OIT/HMW SAC Exemption Applied For
;
;S BMXDTIME(1)=BMXDTIME ; TODO: Set timeouts
S BMXDTIME(1)=.5 ;HMW 20050120
U BMXDEV
F D Q:BMXQUIT
. R BMXACT#5:BMXDTIME ;Read first 5 chars from TCP buffer, timeout=BMXDTIME
. I BMXACT'="{BMX}" S BMXQUIT=1 Q
. R BMXACT#5:BMXDTIME ;Read next 5 chars - message length
. S BMXLEN=+BMXACT
. R BMXACT#BMXLEN:BMXDTIME
. I $P(BMXACT,"^")="TCPconnect" D Q
. . ;IHS/OIT/HMW added validity check for namespace
. . N BMXNSJ,X,Y
. . S BMXNSJ=$P(BMXACT,"^",2) ;Namespace
. . S BMXNSJ=$P(BMXNSJ,",")
. . ;if passed in namespace is invalid, new job will start in listener namespace
. . I BMXNSJ]"" S X=BMXNSJ X ^%ZOSF("UCICHECK") S:Y=0 BMXNSJ=BMXNS
. . ;Job another MONITOR using concurrent connection
. . ;J DEBUG^%Serenji("SESSION^BMXMON("_BMXWIN_")"):(:5:BMXDEV:BMXDEV):5
. . ;J SESSION^BMXMON(BMXWIN)[$P(BMXNS,",")]:(:5:BMXDEV:BMXDEV):5 ;IHS/OIT/HMW SAC Exemption Applied For
. . J SESSION^BMXMON(BMXWIN)[BMXNSJ]:(:5:BMXDEV:BMXDEV):5 ;IHS/OIT/HMW SAC Exemption Applied For
. I $P(BMXACT,"^")="TCPshutdown" S BMXQUIT=1 W "ack",!
S %=$$SEMAPHOR(BMXPORT,"UNLOCK") ; destroy 'running flag'
Q
;
XINETD ;PEP Directly from xinetd or inetd for GT.M
N BMXDEV
S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
S $ZT="" ;Clear old trap
; GT.M specific error and device code
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
S BMXDEV=$P X "U BMXDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
I %["::ffff:" S IO("GTM-IP")=$P(%,"::ffff:",2) ; IPv6 support
; Read message type
N BMXACT,BMXDTIME
S BMXDTIME=999999
R BMXACT#5:BMXDTIME
Q:BMXACT'="{BMX}" ; Not a BMX message - quit.
; Fall through to below...
GTMLNX ;EP from XWBTCPM for GT.M
; not implementing NS and integrated authentication
; Vars: Read timeout, msg len, msg, windows auth, Namespace
N BMXDTIME,BMXLEN,BMXACT,BMXWIN,BMXNS
S BMXNSJ="",BMXWIN=0 ; No NS on GT.M, no Windows Authentication
S BMXDTIME(1)=.5,BMXDTIME=999999
R BMXACT#5:BMXDTIME ;Read next 5 chars - message length
S BMXLEN=+BMXACT
R BMXACT#BMXLEN:BMXDTIME
I $P(BMXACT,"^")="TCPconnect" G SESSRES
I $P(BMXACT,"^")="TCPshutdown" W "ack",! Q
Q ; Should't hit this quit, but just in case
;
SESSION(BMXWIN) ;EP
;Start session monitor
;BMXWIN = 1: Enable integrated security
SESSRES ;EP - reentry point from trap
;IHS/OIT/HMW SAC Exemption Applied For
N $ESTACK S $ETRAP="D ETRAP^BMXMON"
S DIQUIET=1,U="^" D DT^DICRW
D UNREGALL^BMXMEVN ;Unregister all events for this session
U $P D SESSMAIN
;Turn off the error trap for the exit
S $ETRAP=""
I $G(DUZ) D LOGOUT^XUSRB
K BMXR,BMXARY
C $P ;IHS/OIT/HMW SAC Exemption Applied For
Q
;
SESSMAIN ;
N BMXTBUF
D SETUP^BMXMSEC(.RET) ;Setup required system vars
S U="^"
U $P
F D Q:BMXTBUF="#BYE#"
. R BMXTBUF#11:BMXDTIME IF '$T D TIMEOUT S BMXTBUF="#BYE#" Q
. I BMXTBUF["XQKEY" S HWMP=1
. I BMXTBUF="#BYE#" Q
. S BMXHTYPE=$S($E(BMXTBUF,1,5)="{BMX}":1,1:0) ;check HDR
. I 'BMXHTYPE S BMXTBUF="#BYE#" D SNDERR W BMXTBUF,$C(4),! Q
. S BMXTLEN=$E(BMXTBUF,6,10),L=$E(BMXTBUF,11,11)
. R BMXTBUF#4:BMXDTIME(1) S BMXTBUF=L_BMXTBUF
. S BMXPLEN=BMXTBUF
. R BMXTBUF#BMXPLEN:BMXDTIME(1)
. I $P(BMXTBUF,U)="TCPconnect" D Q
. . D SNDERR W "accept",$C(4),! ;Ack
. IF BMXHTYPE D
. . K BMXR,BMXARY
. . IF BMXTBUF="#BYE#" D SNDERR W "#BYE#",$C(4),! Q
. . S BMXTLEN=BMXTLEN-15
. . D CALLP^BMXMBRK(.BMXR,BMXTBUF)
. . S BMXPTYPE=$S('$D(BMXPTYPE):1,BMXPTYPE<1:1,BMXPTYPE>6:1,1:BMXPTYPE)
. IF BMXTBUF="#BYE#" Q
. U $P
. D SNDERR ;Clears SNDERR parameters
. D SND
. D WRITE($C(4)) W ! ;send eot and flush buffer
D UNREGALL^BMXMEVN ;Unregister all events for this session
Q ;End Of Main
;
SNDERR ;send error information
;BMXSEC is the security packet, BMXERROR is application packet
N X
S X=$E($G(BMXSEC),1,255)
W $C($L(X))_X W !
S X=$E($G(BMXERROR),1,255)
W $C($L(X))_X W !
S BMXERROR="",BMXSEC="" ;clears parameters
Q
;
WRITE(BMXSTR) ;Write a data string
;
I $L(BMXSTR)<511 W ! W BMXSTR Q
;Handle a long string
W ! ;Flush the buffer
F Q:'$L(BMXSTR) W $E(BMXSTR,1,510),! S BMXSTR=$E(BMXSTR,511,99999)
Q
SND ; -- send data for all, Let WRITE sort it out
N I,T
;
; -- error or abort occurred, send null
IF $L(BMXSEC)>0 D WRITE("") Q
; -- single value
IF BMXPTYPE=1 S BMXR=$G(BMXR) D WRITE(BMXR) Q
; -- table delimited by CR+LF
IF BMXPTYPE=2 D Q
. S I="" F S I=$O(BMXR(I)) Q:I="" D WRITE(BMXR(I)),WRITE($C(13,10))
; -- word processing
IF BMXPTYPE=3 D Q
. S I="" F S I=$O(BMXR(I)) Q:I="" D WRITE(BMXR(I)) D:BMXWRAP WRITE($C(13,10))
; -- global array
IF BMXPTYPE=4 D Q
. S I=$G(BMXR) Q:I="" S T=$E(I,1,$L(I)-1) D:$D(@I)>10 WRITE(@I)
. F S I=$Q(@I) Q:I=""!(I'[T) W ! W @I W:BMXWRAP&(@I'=$C(13,10)) $C(13,10)
. IF $D(@BMXR) K @BMXR
; -- global instance
IF BMXPTYPE=5 S BMXR=$G(@BMXR) D WRITE(BMXR) Q
; -- variable length records only good upto 255 char)
IF BMXPTYPE=6 S I="" F S I=$O(BMXR(I)) Q:I="" D WRITE($C($L(BMXR(I)))),WRITE(BMXR(I))
Q
;
TIMEOUT ;Do this on MAIN loop timeout
I $G(DUZ)>0 D SNDERR,WRITE("#BYE#"_$C(4)) Q
;Sign-on timeout
S BMXR(0)=0,BMXR(1)=1,BMXR(2)="",BMXR(3)="TIME-OUT",BMXPTYPE=2
D SNDERR,SND,WRITE($C(4))
Q
;
SEMAPHOR(BMXTSKT,BMXACT) ;Lock/Unlock BMXMON semaphore
N RESULT
S U="^",RESULT=1
D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
I BMXACT="LOCK" D
. L +^BMXMON("BMXMON",$P(Y,U,2),$P(Y,U),$P(Y,U,4),BMXTSKT):1
. S RESULT=$T
E L -^BMXMON("BMXMON",$P(Y,U,2),$P(Y,U),$P(Y,U,4),BMXTSKT)
Q RESULT
;
CHPRN(N) ;Change process name to N.
D SETNM^%ZOSV($E(N,1,15))
Q
;
MARKER(BMXPORT,BMXMODE) ;Set/Test/Clear Problem Marker, BMXMODE=0 is a function
N IP,Y,%,REF X ^%ZOSF("UCI") S REF=Y,IP="0.0.0.0",%=0
L +^BMX(IP,REF,BMXPORT,"PROBLEM MARKER"):1
I BMXMODE=1 S ^BMX(IP,REF,BMXPORT,"PROBLEM MARKER")=1
I BMXMODE=0 S:$D(^BMX(IP,REF,BMXPORT,"PROBLEM MARKER")) %=1
I BMXMODE=-1 K ^BMX(IP,REF,BMXPORT,"PROBLEM MARKER")
L -^BMX(IP,REF,BMXPORT,"PROBLEM MARKER")
Q:BMXMODE=0 % Q
;
ETRAP ; -- on trapped error, send error info to client
N BMXERC,BMXERR,BMXLGR
;Change trapping during trap.
S $ETRAP="D ^%ZTER HALT"
S BMXERC=$$EC^%ZOSV
S BMXERR="M ERROR="_BMXERC_$C(13,10)_"LAST REF="
S BMXLGR=$$LGR^%ZOSV_$C(4)
S BMXERR=BMXERR_BMXLGR
D ^%ZTER ;%ZTER clears $ZE and $ECODE
I (BMXERC["READ")!(BMXERC["WRITE")!(BMXERC["SYSTEM-F") D:$G(DUZ) LOGOUT^XUSRB HALT
U $P
D SNDERR,WRITE(BMXERR) W !
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G SESSRES^BMXMON",$ECODE=",U99,"
Q
;
MENU ;EP - ENTRY ACTION FROM BMXMENU OPTION
;
N BMX,BMXVER
;VERSION
D
. S BMXN="BMXNET ADO.NET DATA PROVIDER" I $D(^DIC(9.4,"B",BMXN)) Q
. S BMXN="BMXNET RPMS .NET UTILITIES" I $D(^DIC(9.4,"B",BMXN)) Q
. S BMXN=""
. Q
;
S BMXVER=""
I BMXN]"",$D(^DIC(9.4,"B",BMXN)) D
. S BMX=$O(^DIC(9.4,"B",BMXN,0))
. I $D(^DIC(9.4,BMX,"VERSION")) S BMXVER=$P(^DIC(9.4,BMX,"VERSION"),"^")
. E S BMXVER="VERSION NOT FOUND"
S:BMXVER="" BMXVER="VERSION NOT FOUND"
;
;LOCATION
N BMXLOC
S BMXLOC=""
I $G(DUZ(2)),$D(^DIC(4,DUZ(2),0)) S BMXLOC=$P(^DIC(4,DUZ(2),0),"^")
S:BMXLOC="" BMXLOC="LOCATION NOT FOUND"
;
;WRITE
W !
W !,"BMXNet Version: ",BMXVER
W !,"Location: ",BMXLOC
Q
Side by Side

After

Width:  |  Height:  |  Size: 11 KiB

77
m/BMXMSEC.m Normal file
View File

@ -0,0 +1,77 @@
BMXMSEC ; IHS/OIT/HMW - BMXNet MONITOR ; 7/20/2009
;;2.1;BMX;;Jul 26, 2009
; Edit History
; Line SETUP+2 has been changed to support GT.M //SMH 7/5/09
; Per Wally Fort's GT.M code in XWBTCPM, IP for GT.M is stored
; in IP("GTM-IP"). Changes in BMXMON and here follow that model.
;
CHKPRMIT(BMXRP) ;EP - checks to see if remote procedure is permited to run
;Input: BMXRP - Remote procedure to check
Q:$$KCHK("XUPROGMODE")
N ERR,BMXALLOW
S U="^",BMXSEC="" ;clear
;
;In the beginning, when no DUZ is defined and no context exist, setup
;default signon context
S:'$G(DUZ) DUZ=0,XQY0="XUS SIGNON" ;set up default context
;
I BMXRP'="XWB IM HERE",BMXRP'="XWB CREATE CONTEXT",BMXRP'="XWB RPC LIST",BMXRP'="BMX AV CODE" D ;check exemptions. new exemption for XWB*1.1*6 - dpc
. I $G(XQY0)'="" D
. . S BMXALLOW=$$CHK^XQCS(DUZ,$P(XQY0,U),BMXRP) ;do the check
. . S:'BMXALLOW BMXSEC=BMXALLOW
. E S BMXSEC="Application context has not been created!"
Q
;
OWNSKEY(RET,LIST) ;EP Does user have Key
N I,K S I=""
I $G(DUZ)'>0 S RET(0)=0 Q
I $O(LIST(""))="" S RET(0)=$$KCHK(LIST) Q
F S I=$O(LIST(I)) Q:I="" S RET(I)=$$KCHK(LIST(I))
Q
KCHK(%) Q $S($G(DUZ)>0:$D(^XUSEC(%,DUZ)),1:0) ;EP Key Check
;
;
SETUP(RET) ;EP - sets up environment for GUI signon
;
K ^TMP("XQCS",$J)
; S IO("IP")=$P D ZIO^%ZIS4 ;IHS/OIT/HMW SAC Exemption Applied For
; --> Begin new code
I $$OS^XWBTCPM="GT.M" S IO("IP")=IO("GTM-IP")
I $$OS^XWBTCPM="OpenM" S IO("IP")=$P
D ZIO^%ZIS4
; <-- End new code //SMH
D SET1(0),SET^BMXMSEC("XUS XOPT",XOPT),SET^BMXMSEC("XUS CNT",0)
S %ZIS="0H",IOP="NULL" D ^%ZIS
;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen
S RET(0)=$P(XUENV,U,3),RET(1)=$P(XUVOL,U),RET(2)=XUCI
S RET(3)=$I,RET(4)=$P(XOPT,U,2),RET(5)=0 ;IHS/OIT/HMW SAC Exemption Applied For
I $$INHIBIT() Q
Q
;
SET1(FLAG) ;Setup parameters
D GETENV^%ZOSV S U="^",XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2),XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I)
Q
;
INHIBIT() ;Is Logon to this system Inhibited?
I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q 1
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(XUVOL,U,3),($P(XUVOL,U,3)'>Y) Q 2
Q 0
;
NOW S U="^",XUNOW=$$NOW^XLFDT(),DT=$P(XUNOW,"."),XUDEV=0
Q
;
STATE(%) ;Return a state value
;XWBSTATE is required by XUSRB
Q:'$L($G(%)) $G(XWBSTATE)
Q $G(XWBSTATE(%))
;
;
SET(%,VALUE) ;Set the state variable
I $G(%)="" S XWBSTATE=VALUE
S XWBSTATE(%)=VALUE
Q
KILL(%) ;Kill state variable
I $L($G(%)) K XWBSTATE(%)
Q
Side by Side

After

Width:  |  Height:  |  Size: 2.7 KiB

78
m/BMXNTEG.m Normal file
View File

@ -0,0 +1,78 @@
BMXNTEG ;INTEGRITY CHECKER;FEB 26, 2007
;;2.1;BMX;;Jul 26, 2009
;
START ;
NEW BYTE,COUNT,RTN
K ^UTILITY($J)
F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C
F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBSUMBLD("_I_")=X")
X XBSUMBLD(1)
Q
;
LINE1 ;;X XBSUMBLD(2),XBSUMBLD(6)
LINE2 ;;S RTN=0 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBSUMBLD(4),XBSUMBLD(3),XBSUMBLD(5)
LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBSUMBLD(4)
LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y)
LINE5 ;;S B=$P(^UTILITY($J,RTN),"^",1),C=$P(^(RTN),"^",2) I B'=BYTE!(C'=COUNT) W " has been modified"
LINE6 ;;K XBSUMBLD,B,C,I,J,R,X,Y
;
LIST ;
;;BMXADE1^3028^202865
;;BMXADE2^3250^215372
;;BMXADO^6547^418026
;;BMXADO2^3489^255546
;;BMXADOF^11562^731974
;;BMXADOF1^3281^207224
;;BMXADOF2^2138^139496
;;BMXADOFD^2831^178610
;;BMXADOFS^6515^393782
;;BMXADOI^2215^134605
;;BMXADOS^9145^575000
;;BMXADOS1^2590^161592
;;BMXADOV^5739^373823
;;BMXADOV1^9072^554887
;;BMXADOV2^4690^289898
;;BMXADOVJ^3530^225534
;;BMXADOX^13904^870277
;;BMXADOX1^11753^751110
;;BMXADOX2^3126^199406
;;BMXADOXX^12226^762799
;;BMXADOXY^11992^769511
;;BMXE01^2111^148783
;;BMXFIND^7919^562996
;;BMXG^1970^120467
;;BMXGETS^4309^308726
;;BMXMBRK^5919^389568
;;BMXMBRK2^3621^233089
;;BMXMEVN^6627^468908
;;BMXMON^9356^664477
;;BMXMSEC^2302^160584
;;BMXNTEG^2045^127438
;;BMXPO^1522^101987
;;BMXPRS^2153^134429
;;BMXRPC^5716^425699
;;BMXRPC1^7622^559198
;;BMXRPC2^3531^243875
;;BMXRPC3^6466^450166
;;BMXRPC4^4967^312485
;;BMXRPC5^3896^288926
;;BMXRPC6^3757^270667
;;BMXRPC7^5687^404431
;;BMXRPC8^2236^165523
;;BMXRPC9^6408^421855
;;BMXSQL^10869^727499
;;BMXSQL1^9921^616204
;;BMXSQL2^2748^183754
;;BMXSQL3^13516^868578
;;BMXSQL4^1313^88477
;;BMXSQL5^6648^433290
;;BMXSQL6^10606^683062
;;BMXSQL7^8102^528283
;;BMXSQL91^4328^281351
;;BMXTABLE^159^9961
;;BMXTRS^1300^81264
;;BMXUTL1^7818^520369
;;BMXUTL2^900^60457
;;BMXUTL5^5330^358866
;;BMXUTL6^942^62126
;;BMXUTL7^163^10646
Side by Side

After

Width:  |  Height:  |  Size: 2.1 KiB

71
m/BMXPO.m Normal file
View File

@ -0,0 +1,71 @@
BMXPO ; IHS/CMI/MAW - Populate appcontext with all namespaced RPC's ;
;;2.1;BMX;;Jul 26, 2009
;
;
MAIN ;EP - this is the main routine driver
N BMXQFLG
D ASK
I $G(BMXQFLG) D XIT Q
;D CLEAN(BMXAPP)
D POP(BMXAPP,BMXNS)
D XIT
Q
;
GUIEP(RETVAL,BMXSTR) ;EP - gui entry point
N P,BMXAPP,BMXNS
S P="|"
S BMXGUI=1
S BMXAPP=$P(BMXSTR,P)
S BMXNS=$P(BMXSTR,P,2)
K ^BMXTMP($J)
S RETVAL="^BMXTMP("_$J_")"
S ^BMXTMP($J,0)="T00250DATA"_$C(30)
;D CLEAN(BMXAPP)
D POP(BMXAPP,BMXNS)
D XIT
Q
;
ASK ;-- ask the name of the OPTION to populate
W !
S DIC=19,DIC(0)="AEMQZ",DIC("A")="Populate which Application Context: "
D ^DIC
I '$G(Y) S BMXQFLG=1 Q
S BMXAPP=+Y
W !
K DIC
S DIR(0)="F^1:3",DIR("A")="Populate RPC's from which Namespace: "
D ^DIR
I $D(DIRUT) S BMXQFLG=1 Q
S BMXNS=$G(Y)
Q
;
CLEAN(APP) ;-- clean out the RPC multiple first
S DA(1)=APP
S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
N BMXDA
S BMXDA=0 F S BDMDA=$O(^DIC(19,APP,"RPC",BMXDA)) Q:'BMXDA D
. S DA=BMXDA
. D ^DIK
K ^DIC(19,APP,"RPC","B")
Q
;
POP(APP,NS) ;populate the app context with RPC's
I '$G(BMXGUI) W !,"Populating Application Context"
N BMXDA
S BMXDA=NS
F S BMXDA=$O(^XWB(8994,"B",BMXDA)) Q:BMXDA=""!($E(BMXDA,1,3)'=NS) D
. N BMXIEN
. S BMXIEN=0 F S BMXIEN=$O(^XWB(8994,"B",BMXDA,BMXIEN)) Q:'BMXIEN D
.. Q:$O(^DIC(19,APP,"RPC","B",BMXIEN,0))
.. N BDMIENS,BDMFDA,BDMERR
.. S BDMIENS(1)=APP
.. S BDMIENS="+2,"_APP_","
.. S BDMFDA(19.05,BDMIENS,.01)=BMXIEN
.. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
.. I '$G(BMXGUI) W "."
Q
;
XIT ;-- clean vars
D EN^XBVK("BMX")
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

104
m/BMXPRS.m Normal file
View File

@ -0,0 +1,104 @@
BMXPRS ; IHS/OIT/HMW - BMX WINDOWS UTILS ;
;;2.1;BMX;;Jul 26, 2009
;
;
PARSE(X) ;EP-Parse SQL Statement into array
;Input SQL statement as X
;Returns BMXTK() array
;Errors returned in BMXERR
;
D PRE
Q:$D(BMXERR)
D POST
Q
;
POST2 ;EP - Remove commas from BMXTK
N J,K
S J=0 F S J=$O(BMXTK(J)) Q:'+J D
. S K=$O(BMXTK(J))
. I +K,","=$G(BMXTK(K)) D
. . K BMXTK(K)
. . D PACK(J)
. . Q
. Q
Q
;
POST ;
;Combine multi-character operators
N J
S J=0 F S J=$O(BMXTK(J)) Q:'+J D
. I ">"=BMXTK(J) D Q
. . I "="[$G(BMXTK(J+1)) D Q
. . . S BMXTK(J)=BMXTK(J)_"="
. . . K BMXTK(J+1)
. . . D PACK(J)
. . I "<"[$G(BMXTK(J+1)) D Q
. . . S BMXTK(J)="<"_BMXTK(J)
. . . K BMXTK(J+1)
. . . D PACK(J)
. I "<"=BMXTK(J) D Q
. . I "=>"[$G(BMXTK(J+1)) D
. . . S BMXTK(J)=BMXTK(J)_BMXTK(J+1)
. . . K BMXTK(J+1)
. . . D PACK(J)
. I "="=BMXTK(J) D Q
. . I "<>"[$G(BMXTK(J+1)) D
. . . S BMXTK(J)=BMXTK(J+1)_BMXTK(J)
. . . K BMXTK(J+1)
. . . D PACK(J)
Q
;
PACK(J) ;
F S J=$O(BMXTK(J)) Q:'+J D
. S BMXTK(J-1)=BMXTK(J)
. K BMXTK(J)
Q
;
PRE N P,T,Q,Q1,A,B S (P,T,Q)=0,BMXTK="",A=0
START S A=A+1
S B=$E(X,A)
I B="" G B5
I 'Q G QUOTE
I B=$C(39) G QUOTE
S BMXTK=BMXTK_B G START
QUOTE I B'=$C(39) G SPACE
I Q G QUOTE2
;S Q=1,BMXTK=B G START
S Q=1,BMXTK=BMXTK_B G START
QUOTE2 S Q1=B,A=A+1,B=$E(X,A)
I B']"" G QUOTE3
I B'=$C(39) G QUOTE3
S BMXTK=BMXTK_Q1_B G START
QUOTE3 S A=A-1,B=Q1,BMXTK=BMXTK_B,Q=0 G START
SPACE I B'=" " G OP
I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK=""
G START
OP I "=><"'[B G OPAREN
I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK=""
S T=T+1,BMXTK(T)=B,BMXTK=""
G START
OPAREN I B'="(" G CPAREN
S P=P+1
I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK=""
S T=T+1,BMXTK(T)=B G START
CPAREN I B'=")" G B2
I P G B1
G B0
;
B0 S BMXERR="SQL SYNTAX ERROR" D ERROR G B5
B1 S P=P-1
I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK=""
S T=T+1,BMXTK(T)=B G START
B2 I B'="," G B3
S T=T+1,BMXTK(T)=BMXTK,T=T+1,BMXTK(T)=",",BMXTK="" G START
B3 S BMXTK=BMXTK_B
B4 G START
B5 I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK
I $D(BMXERR) G B6
I P S BMXERR="SQL SYNTAX ERROR: MATCHING PARENTHESIS NOT FOUND" D ERROR
E I Q S BMXERR="SQL SYNTAX ERROR: MATCHING QUOTE NOT FOUND" D ERROR
I P>0 G START
B6 Q
;
ERROR ;W !,"ERROR=",BMXERR,! Q
Q
Side by Side

After

Width:  |  Height:  |  Size: 2.2 KiB

167
m/BMXRPC.m Normal file
View File

@ -0,0 +1,167 @@
BMXRPC ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; GENERIC LOOKUP UTILITY FOR RETURNING MATCHING RECORDS
;; OR TABLES TO RPC'S.
;
; *** NOTE: I have discovered a number of cases where these calls
; produce errors (with error messages to IO) or simply
; do not work correctly. ANY CALL to this utility
; should be thoroughly tested in the M environment
; before being used as an RPC.
;
;----------
LOOKUP(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;EP
;---> Places matching records from requested file into a
;---> result global, ^BMXTEMP($J). The exact global name
;---> is returned in the first parameter (BMXGBL).
;---> Records are returned one per node in the result global.
;---> Each record is terminated with a $C(30), for parsing out
;---> on the VB side, since the Broker concatenates all nodes
;---> into a single string when passing the data out of M.
;---> Requested fields within records are delimited by "^".
;---> NOTE: The first "^"-piece of every node is the IEN of
;---> that entry in its file; the requested fields follow.
;---> The final record (node) contains Error Delimiter,
; $C(31)_$C(31), followed by error text, if any.
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXFL (req) File for lookup.
; 3 - BMXFLDS (opt) Fields to return w/each entry.
; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent.
; 5 - BMXIN (opt) Input to match on (see Algorithm below).
; 6 - BMXMX (opt) Maximum number of entries to return.
; 7 - BMXIX (opt) Indexes to search.
; 8 - BMXSCR (opt) Screen/filter (M code).
; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
; (Converts data in uppercase to mixed case.)
;
;---> Set variables, kill temp globals.
N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC)
S BMX31=$C(31)_$C(31)
S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^"
K ^BMXTMP($J),^BMXTEMP($J)
;
;---> If file number not provided, return error.
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
;
;---> If no fields provided, pass .01.
;---> IEN will always be the first piece of data returned.
;---> NOTE: If .01 is NOT included, but the Index to lookup on is
;---> NOT on the .01, then the .01 will be returned
;---> automatically as the second ^-piece of data in the
;---> Result Global.
;---> So it would be: IEN^.01^requested fields...
I $G(BMXFLDS)="" S BMXFLDS=".01"
;
;---> If no index or flag provided, set flag="M".
I $G(BMXFLG)="" D
.I $G(BMXIX)="" S BMXFLG="M" Q
.S BMXFLG=""
;
;---> If no Maximum Number provided, set it to 200.
I '$G(BMXMX) S BMXMX=200
;
;---> Define index and screen.
S:'$D(BMXIX) BMXIX=""
S:'$D(BMXSCR) BMXSCR=""
;
;---> Set Target Global for output and errors.
S BMXG="^BMXTMP($J)"
;
;---> If Mixed Case not set, set to No Change.
I '$D(BMXMC) S BMXMC=0
;
;---> Silent Fileman call.
D
.I $G(BMXIN)="" D Q
..D LIST^DIC(BMXFL,,BMXFLDS,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG)
.D FIND^DIC(BMXFL,,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG)
;
D WRITE
Q
;
;
;----------
WRITE ;EP
;---> Collect data for matching records and write in result global.
;
;---> First, check for errors.
;---> If errors exist, write them and quit.
N I,N,X
I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q
.S N=0,X=""
.F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D
..N M S M=0
..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D
...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" "
.D ERROUT(X,1)
;
;
;---> Write Field Names
S $P(ASDX,"^",1)="IEN"
F ASDC=1:1:$L(BMXFLDS,";") D
. S ASDXFNUM=$P(BMXFLDS,";",ASDC)
. S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^")
. S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC
. S $P(ASDX,"^",ASDC+1)=ASDXFNAM
S ^BMXTEMP($J,1)=ASDX_$C(30)
;---> Write valid results.
;---> Loop through the IEN node (...2,N) of the temp global.
N I,N,X S N=0
F I=2:1 S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D
.;---> Always set first piece of X=IEN of entry.
.S X=^BMXTMP($J,"DILIST",2,N)
.;
.;---> Collect other fields and concatenate to X.
.N M S M=0
.F S M=$O(^BMXTMP($J,"DILIST","ID",N,M)) Q:'M D
..S X=X_U_^BMXTMP($J,"DILIST","ID",N,M)
.;
.;---> Convert data to mixed case if BMXMC=1.
.S:BMXMC X=$$T^BMXTRS(X)
.;
.;---> Set data in result global.
.S ^BMXTEMP($J,I)=X_$C(30)
;
;---> If no results, report it as an error.
D:'$O(^BMXTEMP($J,0))
.I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q
.S BMXERR="Either the lookup file is empty"
.S BMXERR=BMXERR_" or all entries are screened (software error)."
;
;---> Tack on Error Delimiter and any error.
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
;----------
ERROUT(BMXERR,I) ;EP
;---> Save next line for Error Code File if ever used.
;---> If necessary, use I>1 to avoid overwriting valid data.
S:'$G(I) I=1
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
PASSERR(BMXGBL,BMXERR) ;EP
;---> If the RPC routine calling the BMX Generic Lookup above
;---> detects a specific error prior to the call and wants to pass
;---> that error in the result global rather than a generic error,
;---> then a call to this function (PASSERR) can be made.
;---> This call will store the error text passed in the result global.
;---> The calling routine should then quit (abort its call to the
;---> BMX Generic Lookup function above).
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXERR (req) Text of error to be stored in result global.
;
S:$G(BMXERR)="" BMXERR="Error not passed (software error)."
;
N BMX31 S BMX31=$C(31)_$C(31)
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S ^BMXTEMP($J,1)=BMX31_BMXERR
Q
Side by Side

After

Width:  |  Height:  |  Size: 5.7 KiB

238
m/BMXRPC1.m Normal file
View File

@ -0,0 +1,238 @@
BMXRPC1 ; IHS/OIT/HMW - UTIL: REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: CODE FOR REMOTE PROCEDURE CALLS.
;; RETURNS PATIENT DATA, HEALTH SUMMARY, FACE SHEET.
;
;
;----------
PDATA(BMXDATA,BMXDFN) ;EP
;---> Return Patient Data in 5 ^-delimited pieces:
;---> 1 - DOB in format: OCT 01,1994.
;---> 2 - Age in format: 35 Months.
;---> 3 - Text of Patient's sex.
;---> 4 - HRCN in the format XX-XX-XX.
;---> 5 - Text of ACTIVE/INACTIVE Status.
;---> Parameters:
; 1 - BMXDATA (ret) String of patient data||error.
; 2 - BMXDFN (req) DFN of patient.
;
;---> Delimiter to pass error with result to GUI.
N BMX31,BMXERR S BMX31=$C(31)_$C(31)
S BMXDATA="",BMXERR=""
;
;---> If DFN not supplied, set Error Code and quit.
I '$G(BMXDFN) D Q
.;D ERRCD^BMXUTL2(201,.BMXERR) S BMXDATA=BMX31_BMXERR
;
;---> DOB.
S BMXDATA=$$TXDT1^BMXUTL5($$DOB^BMXUTL1(BMXDFN))
;
;---> Age.
S BMXDATA=BMXDATA_U_$$AGEF^BMXUTL1(BMXDFN)
;
;---> Text of sex.
S BMXDATA=BMXDATA_U_$$SEXW^BMXUTL1(BMXDFN)
;
;---> HRCN, format XX-XX-XX.
S BMXDATA=BMXDATA_U_$$HRCN^BMXUTL1(BMXDFN)
;
;---> Active/Inactive Status.
;S BMXDATA=BMXDATA_U_$$ACTIVE^BMXUTL1(BMXDFN)
;
S BMXDATA=BMXDATA_BMX31
;
Q
;
;
;----------
HS(BMXGBL,BMXDFN) ;EP
;---> Return patient's Health Summary in global array, ^BMXTEMP($J,"HS".
;---> Lines delimited by "^".
;---> Called by RPC: BMX IMMSERVE PT PROFILE
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global containing patient's
; Health Summary, passed to Broker.
; 2 - BMXDFN (req) DFN of patient.
;
;---> Delimiter to pass error with result to GUI.
N BMX30,BMX31,BMXERR,X
S BMX30=$C(30),BMX31=$C(31)_$C(31)
S BMXGBL="^BMXTEMP("_$J_",""HS"")",BMXERR=""
K ^BMXTEMP($J,"HS")
;
;---> If DFN not supplied, set Error Code and quit.
I '$G(BMXDFN) D Q
.;D ERRCD^BMXUTL2(201,.BMXERR) S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
;---> If patient does not exist, set Error Code and quit.
I '$D(^AUPNPAT(BMXDFN,0)) D Q
.;D ERRCD^BMXUTL2(203,.BMXERR) S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
N APCHSPAT,APCHSTYP
S APCHSPAT=BMXDFN,APCHSTYP=7
;---> Doesn't work from Device 56.
;D GUIR^XBLM("EN^APCHS","^TMP(""BMXHS"",$J,")
;
;---> Generate a host file name.
N BMXFN S BMXFN="XB"_$J
;
D
.;---> Important to preserve IO variables for when $I returns to 56.
.N IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY
.;
.;---> Open host file to receive legacy code display.
.;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"W")
.;
.;---> Call to legacy code for Health Summary display.
.D EN^APCHS
.;---> Write End of File (EOF) marker.
.W $C(9)
.;
.;---> %ZISC doesn't close Device 51 when called from TCPIP socket?
.;D ^%ZISC
.;---> Buffer won't write out to file until the device is closed
.;---> or the buffer is flushed by some other command.
.;---> At this point, host file exists but has 0 bytes.
.;C 51
.;---> Now host file contains legacy code display data.
.;
.;---> For some reason %ZISH cannot open the host file a second time.
.;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"R")
.;O 51:($$HFSPATH^BMXUTL1_BMXFN:"R")
.;U 51
.;
.;---> Read in the host file.
.D
..;---> Stop reading Host File if line contains EOF $C(9).
..;N I,Y F I=1:1 R Y Q:Y[$C(9) S ^TMP("BMXHS",$J,I)=Y
.;
.;---> %ZISC doesn't close Device 51 when called from TCPIP socket?
.;D ^%ZISC
.;C 51
;
;---> At this point $I=1. The job has "forgotten" its $I, even
;---> though %SS shows 56 as the current device. $I=1 causes a
;---> <NOPEN> at CAPI+10^XWBBRK2. A simple USE 56 command
;---> appears to "remind" the job its $I is 56, and it works.
;---> Possibly this is something %ZISC ordinarily does.
;U 56
;
;---> Copy Health Summary to global array for passing back to GUI.
N I,N,U,X S U="^"
S N=0
F I=1:1 S N=$O(^TMP("BMXHS",$J,N)) Q:'N D
.;---> Set null lines (line breaks) equal to one space, so that
.;---> Windows reader will quit only at the final "null" line.
.S X=^TMP("BMXHS",$J,N) S:X="" X=" "
.S ^BMXTEMP($J,"HS",I)=X_BMX30
;
;---> If no Health Summary produced, report it as an error.
D:'$O(^BMXTEMP($J,"HS",0))
.;D ERRCD^BMXUTL2(407,.BMXERR) S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
;---> Tack on Error Delimiter and any error.
S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
;---> This works; host file gets deleted.
;S Y=$$DEL^%ZISH($$HFSPATH^BMXUTL1,BMXFN)
K ^TMP("BMXHS",$J)
Q
;
;
;----------
FACE(BMXGBL,BMXDFN) ;EP
;---> Return patient's Face Sheet in global array, ^BMXTEMP($J,"FACE".
;---> Lines delimited by "^".
;---> Called by RPC: BMX IMMSERVE PT PROFILE
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global containing patient's
; Face Sheet, passed to Broker.
; 2 - BMXDFN (req) DFN of patient.
;
;---> Delimiter to pass error with result to GUI.
N BMX30,BMX31,BMXERR,X
S BMX30=$C(30),BMX31=$C(31)_$C(31)
S BMXGBL="^BMXTEMP("_$J_",""FACE"")",BMXERR=""
K ^BMXTEMP($J,"FACE")
;
;---> If DFN not supplied, set Error Code and quit.
I '$G(BMXDFN) D Q
.;D ERRCD^BMXUTL2(201,.BMXERR) S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR
;
;---> If patient does not exist, set Error Code and quit.
I '$D(^AUPNPAT(BMXDFN,0)) D Q
.;D ERRCD^BMXUTL2(203,.BMXERR) S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR
;
N DFN S DFN=BMXDFN
;---> Doesn't work from Device 56.
;---> Generate a host file name.
N BMXFN S BMXFN="XB"_$J
;
D
.;---> Important to preserve IO variables for when $I returns to 56.
.N IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY
.;
.;---> Open host file to receive legacy code display.
.;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"W")
.;
.;---> Call to legacy code for Face Sheet display.
.U 51
.;D ^BMXFACE
.;---> Write End of File (EOF) marker.
.W $C(9)
.;
.;---> %ZISC doesn't close Device 51 when called from TCPIP socket?
.;D ^%ZISC
.;---> Buffer won't write out to file until the device is closed
.;---> or the buffer is flushed by some other command.
.;---> At this point, host file exists but has 0 bytes.
.;C 51
.;---> Now host file contains legacy code display data.
.;
.;---> For some reason %ZISH cannot open the host file a second time.
.;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"R")
.;O 51:($$HFSPATH^BMXUTL1_BMXFN:"R")
.U 51
.;
.;---> Read in the host file.
.D
..;---> Need some way to mark the end of legacy code output.
..;---> Stop reading Host File if line contains EOF $C(9).
..;---> (I added $C(9) above, after ^BMXFACE completed.)
..;N I,Y F I=1:1 R Y Q:Y[$C(9) S ^TMP("BMXFACE",$J,I)=Y
.;
.;---> %ZISC doesn't close Device 51 when called from TCPIP socket?
.;D ^%ZISC
.;C 51
;
;---> At this point $I=1. The job has "forgotten" its $I, even
;---> though %SS shows 56 as the current device. $I=1 causes a
;---> <NOPEN> at CAPI+10^XWBBRK2. A simple USE 56 command
;---> appears to "remind" the job its $I is 56, and it works.
;---> Possibly this is something %ZISC ordinarily does.
U 56
;
;---> Copy Face Sheet to global array for passing back to GUI.
N I,N,U,X S U="^"
S N=0
F I=1:1 S N=$O(^TMP("BMXFACE",$J,N)) Q:'N D
.;---> Set null lines (line breaks) equal to one space, so that
.;---> Windows reader will quit only at the final "null" line.
.S X=^TMP("BMXFACE",$J,N) S:X="" X=" "
.;---> Remove Carriage Return (13)_Formfeed (12) characters.
.I X[$C(13)_$C(12) S X=$P(X,$C(13)_$C(12),2)
.;
.S ^BMXTEMP($J,"FACE",I)=X_BMX30
;
;---> If no Health Summary produced, report it as an error.
D:'$O(^BMXTEMP($J,"FACE",0))
.;D ERRCD^BMXUTL2(408,.BMXERR) S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR
;
;---> Tack on Error Delimiter and any error.
S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR
;
;---> This works; host file gets deleted.
;S Y=$$DEL^%ZISH($$HFSPATH^BMXUTL1,BMXFN)
K ^TMP("BMXFACE",$J)
Q
Side by Side

After

Width:  |  Height:  |  Size: 7.7 KiB

112
m/BMXRPC2.m Normal file
View File

@ -0,0 +1,112 @@
BMXRPC2 ; IHS/OIT/HMW - FIELD LIST ;
;;2.1;BMX;;Jul 26, 2009
;
FLDLIST(BMXGBL,BMXFL,BMXATTR,BMXSCR) ;EP
;TODO: Change all this to be a hard-coded $O thru ^DD
;Returns info in BMXATTR for all fields in file number BMXFL
;BMXSCR is executable code to set $T
; When BMXSCR is executed, the field number is in BMXFLD
;See FileMan documentation for FIELD^DD for description
;of Attributes
;
;---> Set variables, kill temp globals.
;S ^HW("F",BMXFL)=""
;S ^HW("F",BMXATTR)=""
N BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT
S BMX31=$C(31)_$C(31)
S BMXGBL="BMXTMP("_$J_")",BMXERR="",U="^"
K BMXTMP($J)
;
;---> If file number not provided, return error.
;I '+BMXFL D ERROUT^BMXRPC("File number not provided.",1) Q
;---> If file number not provided check for file name.
I +BMXFL'=BMXFL D
. S BMXFL=$TR(BMXFL,"_"," ")
. I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
. S BMXFL=$O(^DIC("B",BMXFL,0))
I '$G(BMXFL) D ERROUT^BMXRPC("File number not provided.",1) Q
;
;---> If no such file, return error.
I '$D(^DD(BMXFL,0)) D ERROUT^BMXRPC("File does not exist.",1) Q
;
;---> Validate screen code
I $G(BMXSCR)="" S BMXSCR="I 1"
S X=$G(BMXSCR)
I X]"" D ^DIM
I '$D(X) S BMXSCR="I 1" ;Default to no screen
;
;---> Set Target Global for output and errors.
S BMXG="BMXTMP($J,""DID"")"
;
;---> Loop through ^DD(FileNumber,FieldNumber,0) to get field names
K BMXTMP($J)
I $G(BMXATTR)="" S BMXATTR="LABEL" ;Changed from NAME to LABEL
;---> Attribute Names
F I=1:1:$L(BMXATTR,";") S BMXT($P(BMXATTR,";",I))=""
S (BMX,BMXC)=0 F S BMX=$O(BMXT(BMX)) Q:BMX="" D
. S BMXC=BMXC+1
. S $P(BMXT,U,BMXC)="T00030"_BMX
S BMXTMP($J,1)="T00030NUMBER"_U_BMXT_$C(30)
;
;S BMXFLD=0 F I=2:1 S BMXFLD=$O(^DD(BMXFL,BMXFLD)) Q:'+BMXFLD D
S BMXTMP($J,2)=".001^BMXIEN"_$C(30)
S BMXFLDN=0 F I=3:1 S BMXFLDN=$O(^DD(BMXFL,"B",BMXFLDN)) Q:BMXFLDN="" D
. S BMXFLD=$O(^DD(BMXFL,"B",BMXFLDN,0)) Q:'+BMXFLD
. X BMXSCR Q:'$T
. D FIELD^DID(BMXFL,BMXFLD,,BMXATTR,BMXG,BMXG)
. K BMXT S (BMXC,BMX)=0
. F S BMX=$O(BMXTMP($J,"DID",BMX)) Q:BMX="" D
. . S BMXC=BMXC+1
. . S $P(BMXT,U,BMXC)=BMXTMP($J,"DID",BMX)
. S BMXTMP($J,I)=BMXFLD_U_$TR(BMXT," ","_")_$C(30)
;S I=I+1,BMXTMP($J,I)=".001^BMXIEN"_$C(30)
S I=I+1
K BMXTMP($J,"DID")
;---> Tack on Error Delimiter and any error.
S BMXTMP($J,I)=BMX31_BMXERR
Q
;
MLTLIST(BMXGBL,BMXFL,BMXONEOK) ;EP
;Returns list of multiple fields in file BMXFL, returns only one field
;if BMXONEOK is TRUE
;S ^HW($H,"MLTLIST","FL")=BMXFL
;S ^HW($H,"MLTLIST","ONE")=BMXONEOK
N BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT,I
S BMX31=$C(31)_$C(31)
S BMXGBL="BMXTMP("_$J_")",BMXERR="",U="^"
K BMXTMP($J)
;
;---> If file number not provided check for file name.
I +BMXFL'=BMXFL D
. S BMXFL=$TR(BMXFL,"_"," ")
. I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
. S BMXFL=$O(^DIC("B",BMXFL,0))
I '$G(BMXFL) D ERROUT^BMXRPC("File number not provided.",1) Q
;
;---> If no such file, return error.
I '$D(^DD(BMXFL,0)) D ERROUT^BMXRPC("File does not exist.",1) Q
;
;---> Column Headers
S BMXTMP($J,1)="T00030NUMBER"_U_"T00030NAME"_$C(30)
;
;---> $O thru ^DD(BMXFL,"SB" to get subfile numbers and names
S I=2
N BMXSB,BMXSBN,BMXSBF,BMXFOUND
S BMXFOUND=0
I $D(^DD(BMXFL,"SB")) D
. S BMXSB=0
. F S BMXSB=$O(^DD(BMXFL,"SB",BMXSB)) Q:'+BMXSB D I BMXFOUND Q:BMXONEOK=1
. . S BMXSBF=$O(^DD(BMXFL,"SB",BMXSB,0))
. . Q:'+BMXSBF
. . S BMXSBN=$G(^DD(BMXFL,BMXSBF,0))
. . Q:BMXSBN=""
. . S BMXZ=$G(^DD(BMXSB,.01,0))
. . Q:$P(BMXZ,U,2)["W"
. . S BMXFOUND=1
. . S BMXSBN=$P(BMXSBN,U)
. . S BMXTMP($J,I)=BMXSB_U_BMXSBN_$C(30)
. . S I=I+1
;
;---> Tack on Error Delimiter and any error.
S BMXTMP($J,I)=BMX31_BMXERR
Q
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

240
m/BMXRPC3.m Normal file
View File

@ -0,0 +1,240 @@
BMXRPC3 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;Mods by WV/SMH
;7/26/09 Removed references to ^AUTTSITE, an IHS file in GETFAC*
;
;
VARVAL(RESULT,VARIABLE) ;returns value of passed in variable
S VARIABLE=$TR(VARIABLE,"~","^")
S RESULT=VARIABLE ;can do this with the REFERENCE type parameter
Q
;See GETV^XWBBRK for how we get the REFERENCE type parameter
;
USER(RESULT,D) ;
;
I '+D S RESULT="" Q
S RESULT=$P($G(^VA(200,D,0)),"^")
Q
;
NTUSER(BMXY,BMXNTUSER) ;EP
;Old code. Retain for reference
;Returns NTDomain^NTUserName^RPMSName for user having DUZ=D
;TODO: Move ANMC NT USERS file
;from AZZWNT to BMX namespace and numberspace
;
;N BMX,BMXNOD,BMXDOM,BMXNAM,BMXCOL,BMXRNAM
;S (BMXDOM,BMXNAM,BMXRNAM)=""
;S U="^"
;I '+D S RESULT="" Q
;S BMXRNAM=$G(^VA(200,D,0)),BMXRNAM=$P(BMXRNAM,U)
;I '$D(^AZZWNT("DUZ",D)) D NTU1 Q
;S BMX=$O(^AZZWNT("DUZ",D,0))
;I '+BMX D NTU1 Q
;I '$D(^AZZWNT(BMX,0)) D NTU1 Q
;S BMXNOD=^AZZWNT(BMX,0)
;S BMXDOM=$P(BMXNOD,U,2)
;S BMXNAM=$P(BMXNOD,U) ;,4)
;D NTU1
Q
;
;
NTUGETD(BMXY,BMXNTNAME) ;EP
;Entry point for debugging
;
D DEBUG^%Serenji("NTUGET^BMXRPC3(.BMXY,BMXNTNAME)")
Q
;
NTUGET(BMXY,BMXNTNAME) ;EP
;
;Returns A ENCRYPTED and V ENCRYPTED for NT User BMXNTNAME
;Called by RPC BMXNetGetCodes
N BMXI,BMXNTID,BMXNTID,BMXNOD,BMXA,BMXV
S BMXI=0
S BMXY="^BMXTMP("_$J_")"
S X="NTUET^BMXRPC3",@^%ZOSF("TRAP")
S BMXI=BMXI+1
I BMXNTNAME="" S ^BMXTMP($J,BMXI)="^" Q
S BMXNTID=$O(^BMXUSER("B",BMXNTNAME,0))
I '+BMXNTID S ^BMXTMP($J,BMXI)="^" Q
S BMXNOD=$G(^BMXUSER(BMXNTID,0))
S BMXA=$P(BMXNOD,U,2)
S BMXV=$P(BMXNOD,U,3)
S ^BMXTMP($J,BMXI)=BMXA_"^"_BMXV_"^"
Q
;
WINUGET(BMXWINID) ;EP
;Returns DUZ for user having Windows Identity BMXWINID
;Returns 0 if no Windows user found
;
N BMXIEN,BMXNOD,BMXDUZ
I BMXWINID="" Q 0
S BMXIEN=$O(^BMXUSER("B",BMXWINID,0))
I '+BMXIEN Q 0
S BMXNOD=$G(^BMXUSER(BMXIEN,0))
S BMXDUZ=$P(BMXNOD,U,2)
Q BMXDUZ
;
NTUSETD(BMXY,BMXNTNAME) ;EP
;Entry point for debugging
;
D DEBUG^%Serenji("NTUSET^BMXRPC3(.BMXY,BMXNTNAME)")
Q
;
NTUSET(BMXY,BMXNTNAME) ;EP
;Sets NEW PERSON map entry for Windows Identity BMXNTNAME
;Returns ERRORID 0 if all ok
;Called by RPC BMXNetSetUser
;
;
N BMXI,BMXNTID,BMXFDA,BMXF,BMXIEN,BMXMSG,BMXAPPTID
S BMXI=0
S BMXY="^BMXTMP("_$J_")"
S X="NTUET^BMXRPC3",@^%ZOSF("TRAP")
S BMXI=BMXI+1
; Quit with error if no DUZ exists
I '+$G(DUZ) D NTUERR(BMXI,500) Q
; Create entry or file in existing entry in BMX USER
I $D(^BMXUSER("B",BMXNTNAME)) S BMXF="?1,"
E S BMXF="+1,"
S BMXFDA(90093.1,BMXF,.01)=BMXNTNAME
S BMXFDA(90093.1,BMXF,.02)=$G(DUZ)
K BMXIEN,BMXMSG
D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG")
S BMXAPPTID=+$G(BMXIEN(1))
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)=BMXAPPTID_"^0"
Q
;
NTUET ;EP
;Error trap from REGEVNT
;
I '$D(BMXI) N BMXI S BMXI=999
S BMXI=BMXI+1
D NTUERR(BMXI,99)
Q
;
NTUERR(BMXI,BMXERID) ;Error processing
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)="^"_BMXERID
Q
;
;
NTU1 ;S BMXCOL="T00030NT_DOMAIN^T00030NT_USERNAME^T00030RPMS_USERNAME"_$C(30)
;S RESULT=BMXCOL_BMXDOM_U_BMXNAM_U_BMXRNAM_$C(30)_$C(31)
Q
;
GETFC(BMXFACS,DUZ) ;Gets all facilities for a user
; Input DUZ - user IEN from the NEW PERSON FILE
; Output - Number of facilities;facility1 name&facility1 IEN;...facilityN&facilityN IEN
N BMXFN,BMXN
S BMXFN=0,BMXFACS=""
F BMXN=1:1 S BMXFN=$O(^VA(200,DUZ,2,BMXFN)) Q:BMXFN="" D
. S:BMXN>1 BMXFACS=BMXFACS_";" S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN
;//smh I BMXN=1 S BMXFN=$P(^AUTTSITE(1,0),U,1) D
;//smh . S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN
S BMXFACS=BMXN-(BMXN>1)_";"_BMXFACS
Q
;
GETFCRS(BMXFACS,BMXDUZ) ;Gets all facilities for a user - returns RECORDSET
;
;TODO: return as global array, add error checking
N BMXFN,BMXN,BMXSUB,BMXRCNT
S BMXDUZ=$TR(BMXDUZ,$C(13),"")
S BMXDUZ=$TR(BMXDUZ,$C(10),"")
S BMXDUZ=$TR(BMXDUZ,$C(9),"")
S BMXFN=0
S BMXSUB="^VA(200,"_BMXDUZ_",2,"
S BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
;F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:BMXFN="" D
S BMXRCNT=0 ;cmi/maw mod 10/17/2006
F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:'BMXFN D ;IHS/ANMC/LJF 8/9/01
. ;S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_$C(30)
. S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN
. ;S BMXRCNT=0 ;cmi/maw orig
. ;I $D(^DISV(BMXDUZ,BMXSUB)),^DISV(BMXDUZ,BMXSUB)=BMXFN S BMXRCNT=1
. ;I $G(DUZ(2))=BMXFN S BMXRCNT=1 ;cmi/maw orig
. S BMXRCNT=BMXRCNT+1 ;cmi/maw mod
. S BMXFACS=BMXFACS_"^"_BMXRCNT_$C(30)
;//smh I BMXN=1 S BMXFN=$P(^AUTTSITE(1,0),U,1) D
;//smh . S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_"^"_1_$C(30)
S BMXFACS=BMXFACS_$C(31)
Q
;
SETFCRS(BMXY,BMXFAC) ;
;
;Sets DUZ(2) to value in BMXFAC
;Fails if BMXFAC is not one of the current user's divisions
;Returns Recordset
;
S X="ERFC^BMXRPC3",@^%ZOSF("TRAP")
S BMXY="T00030DUZ^T00030FACILITY_IEN^T00030FACILITY_NAME"_$C(30)
N BMXSUB,BMXFACN
I '+DUZ S BMXY=BMXY_0_"^"_0_"^"_0_$C(30)_$C(31) Q
I '+BMXFAC S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q
I '$D(^VA(200,DUZ,2,+BMXFAC)) S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q
S DUZ(2)=BMXFAC ;IHS/OIT/HMW SAC Exemption Applied For
S BMXFACN=$G(^DIC(4,+DUZ(2),0))
S BMXFACN=$P(BMXFACN,"^")
S BMXSUB="^VA(200,"_DUZ_",2,"
S ^DISV(DUZ,BMXSUB)=BMXFAC
S BMXY=BMXY_DUZ_"^"_BMXFAC_"^"_BMXFACN_$C(30)_$C(31)
Q
;
ERFC ;
D ^%ZTER
S BMXY=$G(BMXY)_0_"^"_0_$C(30)_$C(31) Q
Q
;
SETFC(BMXY,BMXFAC) ;
;Sets DUZ(2) to value in BMXFAC
;Fails if BMXFAC is not one of the current user's divisions
;Returns 1 if successful, 0 if failed
;
S BMXY=0
N BMXSUB
I '+DUZ S BMXY=0 Q
I '+BMXFAC S BMXY=0 Q
I '$D(^VA(200,DUZ,2,+BMXFAC)) S BMXY=0 Q
S DUZ(2)=BMXFAC ;IHS/OIT/HMW SAC Exemption Applied For
S BMXSUB="^VA(200,"_DUZ_",2,"
S ^DISV(DUZ,BMXSUB)=BMXFAC
S BMXY=1
Q
;
APSEC(BMXY,BMXKEY) ;EP
;Return IHSCD_SUCCEEDED (-1) if user has key BMXKEY
;OR if user has key XUPROGMODE
;Otherwise, returns IHSCD_FAILED (0)
N BMXIEN,BMXPROG,BMXPKEY
I '$G(DUZ) S BMXY=0 Q
I BMXKEY="" S BMXY=0 Q
;
;Test for programmer mode key
S BMXPROG=0
I $D(^DIC(19.1,"B","XUPROGMODE")) D
. S BMXPKEY=$O(^DIC(19.1,"B","XUPROGMODE",0))
. I '+BMXPKEY Q
. I '$D(^VA(200,DUZ,51,BMXPKEY,0)) Q
. S BMXPROG=1
I BMXPROG S BMXY=-1 Q
;
I '$D(^DIC(19.1,"B",BMXKEY)) S BMXY=0 Q
S BMXIEN=$O(^DIC(19.1,"B",BMXKEY,0))
I '+BMXIEN S BMXY=0 Q
I '$D(^VA(200,DUZ,51,BMXIEN,0)) S BMXY=0 Q
S BMXY=-1
Q
;
SIGCHK(BMXY,BMXSIG) ;EP
;Checks BMXSIG against hashed value in NEW PERSON
;Return IHSCD_SUCCEEDED (-1) if BMXSIG matches
;Otherwise, returns IHSCD_FAILED (0)
N X
S BMXY=0
I '$G(DUZ) Q
I '$D(^VA(200,DUZ,20)) Q ;TODO What if no signature?
S BMXHSH=$P(^VA(200,DUZ,20),U,4)
S X=$G(BMXSIG)
D HASH^XUSHSHP
I X=BMXHSH S BMXY=-1
Q
Side by Side

After

Width:  |  Height:  |  Size: 6.7 KiB

148
m/BMXRPC4.m Normal file
View File

@ -0,0 +1,148 @@
BMXRPC4 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
PTINFORS(BMXY,BMXIEN) ;EP Patient Info Recordset
;
N BMXDPT,BMXZ,BMXDLIM,BMXXX,BMXRET,BMXAGE,BMXNEXT,BMXSEX,BMXERR,BMXHRN
S BMXDLIM="^",BMXERR=""
S BMXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00020AGE^T00080NEXT_APPT^T00010SEX"_$C(30)
I '$D(DUZ(2)) S BMXY=BMXRET_$C(31)_"No DUZ2" Q
I +$G(DUZ) D
. S ^DISV(DUZ,"^AUPNPAT(")=BMXIEN
. S ^DISV(DUZ,"^DPT(")=BMXIEN
I '$D(^DPT(BMXIEN)) S BMXY=BMXRET_$C(31)_"No such patient" Q
S BMXDPT=$G(^DPT(BMXIEN,0))
S BMXZ=$P(BMXDPT,U) ;NAME
;S $P(BMXZ,BMXDLIM,2)=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
;I BMXHRN="" Q ;NO CHART AT THIS DUZ2
I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)"
S $P(BMXZ,BMXDLIM,2)=BMXHRN
;
S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN
S Y=$P(BMXDPT,U,3) X ^DD("DD")
S $P(BMXZ,BMXDLIM,4)=Y ;DOB
S $P(BMXZ,BMXDLIM,5)=BMXIEN
S BMXAGE=$$AGEF^BMXUTL1(BMXIEN)
S $P(BMXZ,BMXDLIM,6)=BMXAGE
S BMXNEXT=$$NEXTAPPT^BMXUTL2(BMXIEN)
S $P(BMXZ,BMXDLIM,7)=BMXNEXT
S BMXSEX=$$SEXW^BMXUTL1(BMXIEN)
S $P(BMXZ,BMXDLIM,8)=BMXSEX
S BMXRET=BMXRET_BMXZ
S BMXY=BMXRET_$C(30)_$C(31)_BMXERR
Q
;
PTLOOKRS(BMXY,BMXP,BMXC) ;EP Patient Lookup
;
;Find up to BMXC patients matching BMXP*
;Supports DOB Lookup, SSN Lookup
;
;S ^HW("PTLOOK","INPUT")=BMXP
;S ^HW("PTLOOK","DUZ2")=$G(DUZ(2))
S BMXP=$TR(BMXP,$C(13),"")
S BMXP=$TR(BMXP,$C(10),"")
S BMXP=$TR(BMXP,$C(9),"")
S:BMXC="" BMXC=10
N BMXHRN,BMXZ,BMXDLIM,BMXRET
S BMXDLIM="^"
S BMXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)
I '+$G(DUZ) S BMXY=BMXRET_$C(31) Q
I '$D(DUZ(2)) S BMXY=BMXRET_$C(31) Q
DOB ;DOB Lookup
I +DUZ(2),((BMXP?1.2N1"/"1.2N1"/"1.4N)!(BMXP?1.2N1" "1.2N1" "1.4N)!(BMXP?1.2N1"-"1.2N1"-"1.4N)) D S BMXY=BMXRET_$C(31) Q
. S X=BMXP S %DT="P" D ^%DT S BMXP=Y Q:'+Y
. Q:'$D(^DPT("ADOB",BMXP))
. S BMXIEN=0,BMXXX=1 F S BMXIEN=$O(^DPT("ADOB",BMXP,BMXIEN)) Q:'+BMXIEN D
. . Q:'$D(^DPT(BMXIEN,0))
. . S BMXDPT=$G(^DPT(BMXIEN,0))
. . S BMXZ=$P(BMXDPT,U) ;NAME
. . ;S $P(BMXZ,BMXDLIM,2)=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
. . S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
. . I BMXHRN="" Q ;NO CHART AT THIS DUZ2
. . I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)"
. . S $P(BMXZ,BMXDLIM,2)=BMXHRN
. . ;
. . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN
. . S Y=$P(BMXDPT,U,3) X ^DD("DD")
. . S $P(BMXZ,BMXDLIM,4)=Y ;DOB
. . S $P(BMXZ,BMXDLIM,5)=BMXIEN
. . S BMXXX=BMXXX+1
. . ;S $P(BMXRET,$C(30),BMXXX)=BMXZ
. . S BMXRET=BMXRET_BMXZ_$C(30)
. . Q
. Q
;
;Chart# Lookup
I +DUZ(2),BMXP]"",$D(^AUPNPAT("D",BMXP)) D S BMXY=BMXRET_$C(30)_$C(31) Q
. S BMXIEN=0 F S BMXIEN=$O(^AUPNPAT("D",BMXP,BMXIEN)) Q:'+BMXIEN I $D(^AUPNPAT("D",BMXP,BMXIEN,DUZ(2))) D Q
. . Q:'$D(^DPT(BMXIEN,0))
. . S BMXDPT=$G(^DPT(BMXIEN,0))
. . S BMXZ=$P(BMXDPT,U) ;NAME
. . ;S $P(BMXZ,BMXDLIM,2)=BMXP ;CHART
. . S BMXHRN=BMXP ;CHART
. . I $D(^AUPNPAT(BMXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BMXHRN=BMXHRN_"(*)"
. . S $P(BMXZ,BMXDLIM,2)=BMXHRN
. . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN
. . S Y=$P(BMXDPT,U,3) X ^DD("DD")
. . S $P(BMXZ,BMXDLIM,4)=Y ;DOB
. . S $P(BMXZ,BMXDLIM,5)=BMXIEN
. . S $P(BMXRET,$C(30),2)=BMXZ
. . Q
. Q
;
;SSN Lookup
I (BMXP?9N)!(BMXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BMXP)) D S BMXY=BMXRET_$C(30)_$C(31) Q
. S BMXIEN=0 F S BMXIEN=$O(^DPT("SSN",BMXP,BMXIEN)) Q:'+BMXIEN D Q
. . Q:'$D(^DPT(BMXIEN,0))
. . S BMXDPT=$G(^DPT(BMXIEN,0))
. . S BMXZ=$P(BMXDPT,U) ;NAME
. . S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
. . I BMXHRN="" Q ;NO CHART AT THIS DUZ2
. . I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)"
. . S $P(BMXZ,BMXDLIM,2)=BMXHRN
. . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN
. . S Y=$P(BMXDPT,U,3) X ^DD("DD")
. . S $P(BMXZ,BMXDLIM,4)=Y ;DOB
. . S $P(BMXZ,BMXDLIM,5)=BMXIEN
. . S $P(BMXRET,$C(30),2)=BMXZ
. . Q
. Q
;
S BMXFILE=9000001
S BMXIENS=""
S BMXFIELDS=".01"
S BMXFLAGS="M"
S BMXVALUE=BMXP
S BMXNUMBER=BMXC
S BMXINDEXES=""
S BMXSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
;I BMXSCREEN]"" S DIC("S")=BMXSCREEN
;S BMXSCREEN="I 0"
S BMXIDEN=""
S BMXTARG="BMXRSLT"
S BMXMSG=""
D FIND^DIC(BMXFILE,BMXIENS,BMXFIELDS,BMXFLAGS,BMXVALUE,BMXNUMBER,BMXINDEXES,BMXSCREEN,BMXIDEN,BMXTARG,BMXMSG)
;S BMXRET=""
;B
I '+$G(BMXRSLT("DILIST",0)) S BMXY=BMXRET_$C(31) Q
F BMXX=1:1:$P(BMXRSLT("DILIST",0),U) D
. ;B
. S BMXIEN=BMXRSLT("DILIST",2,BMXX)
. S BMXZ=BMXRSLT("DILIST","ID",BMXX,.01) ;NAME
. ;S $P(BMXZ,BMXDLIM,2)=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
. S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART
. I BMXHRN="" Q ;NO CHART AT THIS DUZ2
. I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)"
. S $P(BMXZ,BMXDLIM,2)=BMXHRN
. S BMXDPT=$G(^DPT(BMXIEN,0))
. S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN
. S Y=$P(BMXDPT,U,3) X ^DD("DD")
. S $P(BMXZ,BMXDLIM,4)=Y ;DOB
. S $P(BMXZ,BMXDLIM,5)=BMXIEN
. S $P(BMXRET,$C(30),BMXX+1)=BMXZ
. Q
;K BMXRSLT
S BMXY=BMXRET_$C(30)_$C(31)
Q
ZZZ ;
Side by Side

After

Width:  |  Height:  |  Size: 5.0 KiB

124
m/BMXRPC5.m Normal file
View File

@ -0,0 +1,124 @@
BMXRPC5 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;Stolen from Mike Remillard. If it doesn't work, it's his fault.
HS(BMXGBL,BMXDFN,BMXTYPE,BMXRDL,BMXFDL) ;EP
;---> Return patient's Health Summary in global array, ^BMXTEMP($J,"HS"
;---> Lines delimited by BMXRDL
;---> File delimited by BMXFDL
;---> Called by RPC: BMX HEALTH SUMMARY
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global containing patient's
; Health Summary, passed to Broker.
; 2 - BMXDFN (req) DFN of patient.
;
;---> Delimiter to pass error with result to GUI.
N BMX30,BMX31,BMXERR,X
;S BMX30=$C(30),BMX31=$C(31)_$C(31)
S BMX30=$G(BMXRDL)
I BMX30="" S BMX30=$C(13)_$C(10)
S BMX31=$G(BMXFDL)
S BMXGBL="^BMXTEMP("_$J_",""HS"")",BMXERR=""
K ^BMXTEMP($J,"HS")
;
N BMXPATH
;---> Should get path from a Site Parameter. For now, use MSM default.
S BMXPATH="/usr/spool/uucppublic/"
;S BMXPATH="C:\MSM\" ;TODO: Change to site parameter
;--->Flag to test whether running as broker job:
N BMXSOCK
S BMXSOCK=0
;I $I=56 S BMXSOCK=1
;
;---> If DFN not supplied, set Error Code and quit.
I '$G(BMXDFN) D Q
. S BMXERR="No Patient DFN" S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
;---> If patient does not exist, set Error Code and quit.
I '$D(^AUPNPAT(BMXDFN,0)) D Q
. S BMXERR="Patient DFN does not exist" S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
N APCHSPAT,APCHSTYP
S APCHSPAT=BMXDFN
S APCHSTYP=$G(BMXTYPE)
S:'+APCHSTYP APCHSTYP=7
;S APCHSTYP=9
;---> Doesn't work from Device 56.
;D GUIR^XBLM("EN^APCHS","^TMP(""BMXHS"",$J,")
;
;---> Generate a host file name.
N BMXFN S BMXFN="XB"_$J
;
D
.;---> Important to preserve IO variables for when $I returns to 56.
.N IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY
.;
.;---> Open host file to receive legacy code display.
.S Y=$$OPEN^%ZISH(BMXPATH,BMXFN,"W")
.;O 51:(BMXPATH_BMXFN:"W")
.;S IO=51,IOST="P-OTHER80"
.;K ^HW("HS")
.;S ^HW("HS","IOST")=$G(IOST)
.;S ^HW("HS","IO")=$G(IO)
.;
.;---> Call to legacy code for Health Summary display.
.S IOSL=999,IOM=80
.D EN^APCHS
.;---> Write End of File (EOF) marker.
.W $C(9)
.;
.;---> %ZISC doesn't close Device 51 when called from TCPIP socket?
.;D ^%ZISC
.;---> Buffer won't write out to file until the device is closed
.;---> or the buffer is flushed by some other command.
.;---> At this point, host file exists but has 0 bytes.
.;C 51
.;---> Now host file contains legacy code display data.
.;
.;---> For some reason %ZISH cannot open the host file a second time.
.;S Y=$$OPEN^%ZISH(BMXPATH,BMXFN,"R")
.;O 51:(BMXPATH_BMXFN:"R")
.U 51
.;
.;---> Read in the host file.
.D
..;---> Stop reading Host File if line contains EOF $C(9).
..;N I,Y F I=1:1 R Y Q:Y[$C(9) S ^TMP("BMXHS",$J,I)=Y
.;
.;---> %ZISC doesn't close Device 51 when called from TCPIP socket?
.;D ^%ZISC
.;C 51
;
;---> At this point $I=1. The job has "forgotten" its $I, even
;---> though %SS shows 56 as the current device. $I=1 causes a
;---> <NOPEN> at CAPI+10^XWBBRK2. A simple USE 56 command
;---> appears to "remind" the job its $I is 56, and it works.
;---> Possibly this is something %ZISC ordinarily does.
I BMXSOCK U 56
;U 56
;
;---> Copy Health Summary to global array for passing back to GUI.
N I,N,U,X S U="^"
S N=0
F I=1:1 S N=$O(^TMP("BMXHS",$J,N)) Q:'N D
.;---> Set null lines (line breaks) equal to one space, so that
.;---> Windows reader will quit only at the final "null" line.
.S X=^TMP("BMXHS",$J,N) S:X="" X=" "
.S ^BMXTEMP($J,"HS",I)=X_BMX30
;
;---> If no Health Summary produced, report it as an error.
D:'$O(^BMXTEMP($J,"HS",0))
. S BMXERR="No Health Summary produced" S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
;---> Tack on Error Delimiter and any error.
S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR
;
;---> Delete host file.
;---> This doesn't work.
S Y=$$DEL^%ZISH(BMXPATH,BMXFN)
;---> Call system command.
;S ^MIKE(1)=BMXPATH
;S ^MIKE(2)=BMXFN
;S Y=$ZOS(2,BMXPATH_BMXFN)
K ^TMP("BMXHS",$J)
Q
Side by Side

After

Width:  |  Height:  |  Size: 3.9 KiB

112
m/BMXRPC6.m Normal file
View File

@ -0,0 +1,112 @@
BMXRPC6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
USRKEYRS(BMXY,BMXDUZ) ;EP - Returns recordset of user's keys
;
N BMXDPT,BMXZ,BMXDLIM,BMXXX,BMXRET,BMXAGE,BMXNEXT,BMXSEX,BMXERR
S BMXDLIM="^",BMXERR=""
S BMXRET="T00050KEY"_$C(30)
I '$D(DUZ(2)) S BMXY=BMXRET_$C(31)_"No DUZ2" Q
;Strip CRLFs from parameter
S BMXCRLF=$C(13)_$C(10)
S BMXDUZ=$TR(BMXDUZ,BMXCRLF,"")
I '$D(^VA(200,BMXDUZ)) S BMXY=BMXRET_$C(31)_"No such user" Q
S BMXK=0 F S BMXK=$O(^VA(200,BMXDUZ,51,BMXK)) Q:'+BMXK D
. S BMXKEY=$G(^VA(200,BMXDUZ,51,BMXK,0))
. Q:BMXKEY=""
. S BMXKEY=$P(BMXKEY,BMXDLIM)
. Q:'+BMXKEY
. Q:'$D(^DIC(19.1,BMXKEY,0))
. S BMXKEY=$P(^DIC(19.1,BMXKEY,0),BMXDLIM)
. Q:BMXKEY']""
. S BMXRET=BMXRET_BMXKEY_$C(30)
S BMXY=BMXRET_$C(30)_$C(31)_BMXERR
Q
;
PDATA(BMXY,BMXP) ;-EP Returns patient demographics for pt with
;health record number BMXP at the current DUZ(2)
N BMXIEN,BMXDUZ2,BMXSQL
;Strip CR, LF, TAB, SPACE
S BMXP=$TR(BMXP,$C(13),"")
S BMXP=$TR(BMXP,$C(10),"")
S BMXP=$TR(BMXP,$C(9),"")
S BMXP=$TR(BMXP,$C(32),"")
S BMXDUZ2=$G(DUZ(2)),BMXDUZ2=+BMXDUZ2
S BMXIEN=0
I +BMXDUZ2 F S BMXIEN=$O(^AUPNPAT("D",BMXP,BMXIEN)) Q:'+BMXIEN I $D(^AUPNPAT("D",BMXP,BMXIEN,BMXDUZ2)) Q
S BMXSQL="SELECT NAME 'Name', DOB 'DateOfBirth', TRIBE_OF_MEMBERSHIP 'Tribe', MAILING_ADDRESS-STREET 'Street',"
S BMXSQL=BMXSQL_" MAILING_ADDRESS-CITY 'City', MAILING_ADDRESS-STATE 'State', MAILING_ADDRESS-ZIP 'Zip', HOME_PHONE 'HomePhone', OFFICE_PHONE 'WorkPhone' FROM PATIENT WHERE BMXIEN='"_+BMXIEN_"'"
D SQL^BMXSQL(.BMXY,BMXSQL)
S @BMXY@(.5)="T00015Chart^"
I $D(@BMXY@(10)) S @BMXY@(10)=BMXP_"^"_@BMXY@(10)
;
Q
;
PDEMOD(BMXY,BMXPAT,BMXCOUNT) ;EP
;Entry point for Serenji debugging
;
D DEBUG^%Serenji("PDEMO^BMXRPC6(.BMXY,BMXPAT,BMXCOUNT)")
Q
;
PDEMO(BMXY,BMXPAT,BMXCOUNT) ;EP
;This simple RPC demonstrates how to format data
;for the BMXNet ADO.NET data provider
;
;Returns a maximum of BMXCOUNT records from the
;VA PATIENT file whose names begin with BMXPAT
;
N BMXI,BMXD,BMXC,BMXNODE,BMXDOB
;
;When the VA BROKER calls this routine, BMXY is passed by reference
;We set BMXY to the value of the variable in which we will return
;our data:
;S BMXY="^TMP(""BMX"","_$J_")"
N BMXUID
S BMXUID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S BMXY=$NA(^BMXTMP("BMXTEST",BMXUID))
K ^BMXTMP("BMXTEST",BMXUID)
;
;The first subnode of the data global contains the column header information
;in the form "TxxxxxCOLUMN1NAME^txxxxxCOLUMN2NAME"_$C(30)
;where T is the column data type and can be either T for text, I for numeric or D for date/time.
;xxxxx is the length of the column in characters:
;
S BMXI=0,BMXC=0
S ^BMXTMP("BMXTEST",BMXUID,BMXI)="T00030NAME^T00010SEX^D00020DOB"_$C(30)
;
;You MUST set an error trap:
S X="PDERR^BMXRPC6",@^%ZOSF("TRAP")
;
;Strip CR, LF, TAB, SPACE from BMXCOUNT parameter
S BMXCOUNT=$TR(BMXCOUNT,$C(13),"")
S BMXCOUNT=$TR(BMXCOUNT,$C(10),"")
S BMXCOUNT=$TR(BMXCOUNT,$C(9),"")
S BMXCOUNT=$TR(BMXCOUNT,$C(32),"")
;
;Iterate through the global and set the data nodes:
S:BMXPAT="" BMXPAT="A"
S BMXPAT=$O(^DPT("B",BMXPAT),-1)
S BMXD=0
F S BMXPAT=$O(^DPT("B",BMXPAT)) Q:BMXPAT="" S BMXD=$O(^DPT("B",BMXPAT,0)) I +BMXD S BMXC=BMXC+1 Q:(BMXCOUNT)&(BMXC>BMXCOUNT) D
. Q:'$D(^DPT(BMXD,0))
. S BMXI=BMXI+1
. S BMXNODE=^DPT(BMXD,0)
. ;Convert the DOB from FM date
. S Y=$P(BMXNODE,U,3)
. I +Y X ^DD("DD")
. S BMXDOB=Y
. ;The data node fields are in the same order as the column header, i.e. NAME^SEX^DOB
. ;and terminated with a $C(30)
. S ^BMXTMP("BMXTEST",BMXUID,BMXI)=$P(BMXNODE,U)_U_$P(BMXNODE,U,2)_U_BMXDOB_$C(30)
;
;After all the data nodes have been set, set the final node to $C(31) to indicate
;the end of the recordset
S BMXI=BMXI+1
S ^BMXTMP("BMXTEST",BMXUID,BMXI)=$C(31)
Q
;
PDERR ;Error trap for PDEMO
;
S ^BMXTMP("BMXTEST",BMXUID,BMXI+1)=$C(31)
Q
Side by Side

After

Width:  |  Height:  |  Size: 3.8 KiB

134
m/BMXRPC7.m Normal file
View File

@ -0,0 +1,134 @@
BMXRPC7 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
WINVAL(BMXRET,BMXWINID) ;EP
;Validates user based on Windows Identity
;
;Return R(0)=DUZ, R(1)=(0=OK, 1,2...=Can't sign-on for some reason)
; R(2)=verify needs changing, R(3)=Message, R(4)=0, R(5)=msg cnt, R(5+n)
; R(R(5)+6)=# div user must select from, R(R(5)+6+n)=div
I $$NEWERR^%ZTER N $ETRAP S $ETRAP=""
N X,BMXUSER,BMXUNOW,BMXUM,BMXUMSG,BMXVCOK K DUZ
S BMXRET(0)=0,BMXRET(5)=0,BMXUM=0,BMXUMSG=0
S DUZ=0,DUZ(0)="",BMXVCOK=0 D NOW ;IHS/OIT/HMW SAC Exemption Applied For
S BMXUMSG=$$INHIBIT() I BMXUMSG S BMXUM=1 G VAX ;Logon inhibited
;
S DUZ=$$WINUGET^BMXRPC3(BMXWINID) ;IHS/OIT/HMW SAC Exemption Applied For
I DUZ>0 D USER(DUZ)
S BMXUMSG=$$UVALID() G:BMXUMSG VAX
I DUZ>0 S BMXUMSG=$$POST(1)
VAX S:BMXUMSG>0 DUZ=0 D:DUZ>0 POST2
S BMXRET(0)=DUZ,BMXRET(1)=BMXUM,BMXRET(2)=BMXVCOK,BMXRET(3)=$S(BMXUMSG:$$TXT(BMXUMSG),1:""),BMXRET(4)=0
Q
;
NOW S U="^",BMXUNOW=$$NOW^XLFDT(),DT=$P(BMXUNOW,".")
Q
;
USER(IX) ;Build USER
S BMXUSER(0)=$G(^VA(200,+IX,0)),BMXUSER(1)=$G(^(.1))
Q
;
POST(CVC) ;Finish setup partition, I CVC don't log get
N X,BMXUM
K ^UTILITY($J),^TMP($J)
I '$D(USER(0)),DUZ D USER(DUZ)
S BMXUM=$$USER1A Q:BMXUM>0 BMXUM ;User can't sign on for some reason.
S BMXRET(5)=0 ;The next line sends the post sign-on msg
F BMXPT=1:1 Q:'$D(BMXUTEXT(BMXPT)) S BMXRET(5+BMXPT)=$E(BMXUTEXT(BMXPT),2,256),BMXRET(5)=BMXPT
S BMXRET(5)=0 ;This line stops the display of the msg. Remove this line to allow.
D:'$G(CVC) POST2
Q 0
POST2 D:'$D(BMXUNOW) NOW
D DUZ ;^XUS1A ;,SAVE^XUS1,LOG^XUS1,ABT^XQ12
K BMXUTEXT,BMXOPT,BMXUER ;XUEON,XUEOFF,XUTT
Q
;
DUZ ;Setup DUZ. SAC exemption applied for.
S:'$D(BMXUSER(0)) BMXUSER(0)=^VA(200,DUZ,0) D:$D(BMXOPT)[0 BMXOPT
S DUZ(0)=$P(BMXUSER(0),U,4),DUZ(1)="",DUZ("AUTO")=$P(BMXOPT,"^",6) ;IHS/OIT/HMW SAC Exemption Applied For
S DUZ(2)=$S($G(DUZ(2))>0:DUZ(2),1:+$P(BMXOPT,U,17)) ;IHS/OIT/HMW SAC Exemption Applied For
S X=$P($G(^DIC(4,DUZ(2),99)),U,5),DUZ("AG")=$S(X]"":X,1:$P(^XTV(8989.3,1,0),U,8))
S DUZ("BUF")=($P(BMXOPT,U,9)="Y"),DUZ("LANG")=$P(BMXOPT,U,7) ;IHS/OIT/HMW SAC Exemption Applied For
Q
;
USER1A() ;
N BMXPTB,BMXPTE,BMXPTT
S BMXUTEXT=0,DUZ(2)=0
F I=0:0 S I=$O(^XTV(8989.3,1,"POST",I)) Q:I'>0 D SET("!"_$G(^(I,0)))
D SET("!"),BMXOPT
S BMXPTH=$P($H,",",2)
D SET("!Good "_$S(BMXPTH<43200:"morning ",BMXPTH<61200:"afternoon ",1:"evening ")_$S($P(BMXUSER(1),U,4)]"":$P(BMXUSER(1),U,4),1:$P(BMXUSER(0),U,1)))
S BMXI1=$G(^VA(200,DUZ,1.1)),X=(+BMXI1_"0000")
I X D SET("! You last signed on "_$S(X\1=DT:"today",X\1+1=DT:"yesterday",1:$$DD(X))_" at "_$E(X,9,10)_":"_$E(X,11,12))
I $P(BMXI1,"^",2) S I=$P(BMXI1,"^",2) D SET("!There "_$S(I>1:"were ",1:"was ")_I_" unsuccessful attempt"_$S(I>1:"s",1:"")_" since you last signed on.")
I $P(BMXUSER(0),U,12),$$PROHIBIT(BMXPTH,$P(BMXUSER(0),U,12)) Q 17 ;Time frame
I +$P(BMXOPT,U,15) S BMXPT=$P(BMXOPT,U,15)-($H-BMXUSER(1)) I BMXPT<6,BMXPT>0 D SET("! Your Verify code will expire in "_BMXPT_" days")
S:$P(BMXOPT,"^",5) XUTT=1 S:'$D(DTIME) DTIME=$P(BMXOPT,U,10)
I ('X)!$P(BMXOPT,U,4) Q 0
Q 9
;
BMXOPT ;Build the BMXOPT string
N X,I
S:'$D(BMXOPT) BMXOPT=$G(^XTV(8989.3,1,"XUS"))
S X=$G(^VA(200,DUZ,200))
F I=4:1:7,9,10 I $P(X,U,I)]"" S $P(BMXOPT,"^",I)=$P(X,U,I)
Q
;
SET(V) ;Set into BMXUTEXT(BMXUTEXT)
S BMXUTEXT=$G(BMXUTEXT)+1,BMXUTEXT(BMXUTEXT)=V
Q
;
PROHIBIT(BMXPTT,BMXPTR) ;See if a prohibited time, (Current time, restrict range)
N XMSG,BMXPTB,BMXPTE
S BMXPTT=BMXPTT\60#60+(BMXPTT\3600*100),BMXPTB=$P(BMXPTR,"-",1),BMXPTE=$P(BMXPTR,"-",2)
S XMSG=$P($$FMTE^XLFDT(DT_"."_BMXPTB,"2P")," ",2,3)_" thru "_$P($$FMTE^XLFDT(DT_"."_BMXPTE,"2P")," ",2,3)
I $S(BMXPTE'<BMXPTB:BMXPTT'>BMXPTE&(BMXPTT'<BMXPTB),1:BMXPTT>BMXPTB!(BMXPTT<BMXPTE)) S BMXUM(0)=XMSG Q 1 ;No
D SET("!")
D SET("! Your access is restricted during this time frame "_XMSG)
Q 0
;
INHIBIT() ;Is Logon to this system Inhibited?
N BMXENV,BMXCI,BMXQVOL,BMXVOL
D GETENV^%ZOSV S U="^",BMXENV=Y,BMXCI=$P(Y,U,1),BMXQVOL=$P(Y,U,2)
S X=$O(^XTV(8989.3,1,4,"B",BMXQVOL,0)),BMXVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:BMXQVOL_"^y^1") S:$P(BMXVOL,U,6)="y" XRTL=BMXCI_","_BMXQVOL
;I '$D(BMXQVOL) Q 0
;I '$D(BMXVOL) Q 0
I $G(^%ZIS(14.5,"LOGON",BMXQVOL)) Q 1
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(BMXVOL,U,3),($P(BMXVOL,U,3)'>Y) Q 2
Q 0
;
;
UVALID() ;EF. Is it valid for this user to sign on?
I '+$G(BMXWIN) Q 18
I DUZ'>0 Q 4
I $P(BMXUSER(0),U,11),$P(BMXUSER(0),U,11)'>DT Q 11 ;Access Terminated
I $P(BMXUSER(0),U,7) Q 5 ;Disuser flag set
Q 0
;
DD(Y) Q $S($E(Y,4,5):$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)
Q
;
TXT(BMXPT) ;
S BMXPT=$T(ZZ+BMXPT)
S BMXPT=$P(BMXPT,";",4,9) I BMXPT["|" S BMXPT=$P(BMXPT,"|",1)_$G(BMXUM(0))_$P(BMXPT,"|",2)
Q BMXPT
ZZ ;;Halt;Error Messages
1 ;;1;Signons not currently allowed on this processor.
2 ;;1;Maximum number of users already signed on to this processor.
3 ;;1;This device has not been defined to the system -- contact system manager.
4 ;;0;Not a valid Windows Identity map value.
5 ;;0;No Access Allowed for this User.
6 ;;0;Invalid device password.
7 ;;0;Device locked due to too many invalid sign-on attempts.
8 ;;1;This device is out of service.
9 ;;0;*** MULTIPLE SIGN-ONS NOT ALLOWED ***
10 ;;1;You don't have access to this device!
11 ;;0;Your access code has been terminated. Please see your site manager!
12 ;;0;VERIFY CODE MUST be changed before continued use.
13 ;;1;This device may only be used outside of this time frame |
14 ;;0;'|' is not a valid UCI!
15 ;;0;'|' is not a valid program name!
16 ;;0;No PRIMARY MENU assigned to user or User is missing KEY to menu!
17 ;;0;Your access to the system is prohibited from |.
18 ;;0;Windows Integrated Security Not Allowed on this port.
Side by Side

After

Width:  |  Height:  |  Size: 5.7 KiB

89
m/BMXRPC8.m Normal file
View File

@ -0,0 +1,89 @@
BMXRPC8 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
BMXLOCKD(BMXY,BMXVAR,BMXINC,BMXTIME) ;EP
;Entry point for debugging
;
D DEBUG^%Serenji("BMXLOCK^BMXRPC8(.BMXY,BMXVAR,BMXINC,BMXTIME)")
Q
;
BMXLOCK(BMXY,BMXVAR,BMXINC,BMXTIME) ;EP
;Called by BMX LOCK rpc to lock variable BMXVAR
;If BMXVAR = "", argumentless lock is performed to release all locks
;BMXINC = increment lock if "+", decrement if "-"
;BMXTIME = lock timeout
;Returns 1 if lock successful, otherwise 0;
;
S X="ERR^BMXRPC8",@^%ZOSF("TRAP")
;
N BMXC
S:$E(BMXVAR,1,1)="~" BMXVAR="^"_$E(BMXVAR,2,$L(BMXVAR))
S:BMXTIME="" BMXTIME=0
I BMXVAR="" X "L" S BMXY=1 Q
S BMXC="L "
S BMXC=BMXC_$S(BMXINC="+":"+",BMXINC="-":"-",1:"")
S BMXC=BMXC_BMXVAR_":"_+BMXTIME
X BMXC
S BMXY=$T
Q
;
ERR ;Error processing
S BMXY=0
Q
;
BMXVERD(BMXY,BMXNS,BMXLOC) ;EP
;Entry point for debugging
;
D DEBUG^%Serenji("BMXVER^BMXRPC8(.BMXY,BMXNS,BMXLOC)")
Q
;
BMXVER(BMXY,BMXNS,BMXLOC) ;EP
;
;Called by BMX VERSION INFO rpc
;Returns recordset of version info for server components in namespace BMXNS.
;If BMXLOC is "", then the version info is assumed to be stored in piece 1-3 of
;^<BMXNS>APPL(1,0)
;
;TODO:
;BMXLOC, if not null, is either a global reference such that $P(@BMXLOC,U,1,3) returns
;MAJOR^MINOR^BUILD
;Or BMXLOC can be an extrinsic function call that returns MAJOR^MINOR^BUILD.
;
;The returned error field is either "" or contains a text error message.
;
N X,BMXI,BMXNOD,BMXDAT
;
S X="VETRAP^BMXRPC8",@^%ZOSF("TRAP")
S BMXI=0
K ^BMXTMP($J)
S BMXY="^BMXTMP("_$J_")"
S ^BMXTMP($J,BMXI)="T00030ERROR^T00030MAJOR_VERSION^T00030MINOR_VERSION^T00030BUILD"_$C(30)
S BMXI=BMXI+1
I BMXNS="" D VERR(BMXI,"BMXRPC8: Invalid Null Application Namespace") Q
S BMXNOD="^"_BMXNS_"APPL(1,0)"
S BMXDAT=$G(@BMXNOD)
I BMXNS="" D VERR(BMXI,"BMXRPC8: No version info for Application Namespace") Q
S ^BMXTMP($J,BMXI)="^"_$P(BMXDAT,U,1,3)_$C(30)
Q
;
;
VERR(BMXI,BMXERR) ;Error processing
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)=BMXERR_"^^^"_$C(30)
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)=$C(31)
Q
;
VETRAP ;EP Error trap entry
D ^%ZTER
I '$D(BMXI) N BMXI S BMXI=999999
S BMXI=BMXI+1
D VERR(BMXI,"BMXRPC8 Error: "_$G(%ZTERROR))
Q
;
IMHERE(BMXRES) ;EP
;Entry point for BMX IM HERE remote procedure
S BMXRES=1
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 2.3 KiB

165
m/BMXRPC9.m Normal file
View File

@ -0,0 +1,165 @@
BMXRPC9 ; IHS/OIT/HMW - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ;
;;2.1;BMX;;Jul 26, 2009
; UPDATE FILEMAN WITH AN ADO RECORD SET FROM A WINDOWS APPLICATION
;
;
;
SONLY(BMXY,BMXVAL) ;EP Schema Only
;
I BMXVAL="TRUE" S BMX("SCHEMA ONLY")=1
E S BMX("SCHEMA ONLY")=0
S BMXY=BMX("SCHEMA ONLY")
;
Q
;
TESTRPC(BMXGBL,BMXSQL) ;
;Test retrieval/update statement
;
N BMXI,BMXERR,BMXN,BMXNOD,BMXNAM,BMXSEX,BMXDOB,BMXFAC,BMXTMP,BMXJ
S X="ETRAP^BMXRPC9",@^%ZOSF("TRAP")
S BMXGBL="^BMXTMP("_$J_")",BMXERR="",U="^"
K ^BMXTMP($J)
S BMXI=0
;
;Old column info format:
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="I00010BMXIEN"_U_"D00010DOB"_U_"T00030LOCAL_FACLILITY"_U_"T00030NAME"_U_"T00010SEX"_$C(30)
;
;New column info format is @@@meta@@@KEYFIELD|FILE#
; For each field: ^FILE#|FIELD#|DATATYPE|LENGTH|FIELDNAME|READONLY|KEYFIELD|NULL ALLOWED
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="@@@meta@@@"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="BMXIEN|2160010^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.001|I|10|BMXIEN|TRUE|TRUE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.03|D|10|DOB|FALSE|FALSE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.04|T|60|LOCAL_FACILITY|FALSE|FALSE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.01|T|30|NAME|FALSE|FALSE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.02|T|10|SEX|FALSE|FALSE"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)=$C(30)
;
D SS^BMXADO(.BMXTMP,"","TEST1")
I $G(BMXTMP)=$C(30) D ERR(99,"SCHEMA GENERATION FAILED") Q
S BMXJ=0 F S BMXJ=$O(BMXTMP(BMXJ)) Q:'+BMXJ D
. S BMXI=BMXI+1
. S ^BMXTMP($J,BMXI)=BMXTMP(BMXJ)
I +$G(BMX("SCHEMA ONLY")) D Q
. S BMXI=BMXI+1
. S ^BMXTMP($J,BMXI)=$C(31)
. Q
S BMXN=0
F S BMXN=$O(^DIZ(2160010,BMXN)) Q:'+BMXN D
. Q:'$D(^DIZ(2160010,BMXN,0))
. S BMXNOD=^DIZ(2160010,BMXN,0)
. S BMXNAM=$P(BMXNOD,U)
. S BMXSEX=$P(BMXNOD,U,2)
. S BMXDOB=$P(BMXNOD,U,3)
. S Y=BMXDOB X ^DD("DD") S BMXDOB=Y
. S BMXFAC=$P(BMXNOD,U,4)
. S:+BMXFAC BMXFAC=$P($G(^DIC(4,BMXFAC,0)),U)
. S BMXI=BMXI+1
. S ^BMXTMP($J,BMXI)=BMXN_U_BMXDOB_U_BMXFAC_U_BMXNAM_U_BMXSEX_$C(30)
. Q
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)=$C(31)
Q
;
ERR(BMXID,BMXERR) ;Error processing
K ^BMXTMP($J)
S ^BMXTMP($J,0)="I00030ERRORID^T00030ERRORMSG"_$C(30)
S ^BMXTMP($J,1)=BMXID_"^"_BMXERR_$C(30)
S ^BMXTMP($J,2)=$C(31)
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
D ERR(99,"BMXRPC9 Error: "_$G(%ZTERROR))
Q
;
TEST N OUT S OUT="" D ADO(.OUT,2160010,"1",(".01|A,A"_$C(30)_".02|M"_$C(30)_".03|1/5/1946"_$C(30)_".04|SAN XAVIER"_$C(31))) W !,OUT
Q
;
ADOX(OUT,FILE,IEN,DATA) ;
;
D DEBUG^%Serenji("ADOX^BMXRPC9(.OUT,FILE,IEN,DATA)")
;
Q
;
ADO(OUT,FILE,IEN,DATA) ; RPC CALL: OUT = OUTBOUND MESSAGE, FILE = FILEMAN FILE NUMBER, IEN = FILE INTERNAL ENTRY NUMBER, DATA = DATA STRING
N OREF,CREF,DIC,DIE,DA,DR,X,Y,%,FLD,CNT,FNO,VAL,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG
S OUT="",FLD="",GTFLG=0,GDFLG=0
S IEN=$G(IEN)
I $E(IEN)="-" S IEN=$E(IEN,2,99),GDFLG=1 ; GLOBAL DELETE FLAG
I $E(IEN)="+" S IEN=$E(IEN,2,99),GTFLG=1 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE
I IEN="Add"!(IEN="ADD") S IEN=""
I '$D(^DIC(+$G(FILE),0,"GL")) S OUT="Update cancelled. Invalid FILE number" Q
S OREF=^DIC(FILE,0,"GL") I '$L(OREF) S OUT="Update cancelled. Invalid file definition" Q
S CREF=$E(OREF,1,$L(OREF)-1) I $E(OREF,$L(OREF))="," S CREF=CREF_")" ; CONVERT OREF TO CREF
I IEN,'$D(@CREF@(IEN)) S OUT="Update cancelled. Invalid IEN" Q
I 'GDFLG,IEN,(DATA["-.01|"!(DATA[".01|@")) S GDFLG=1
I GDFLG,'IEN S OUT="Deletion cancelled. Missing IEN" Q
I GDFLG D DIK(OREF,IEN) S OUT="Record deleted|"_IEN Q
S UFLG=$S($G(IEN):"E",1:"A") ; UPDATE FLAG: ADD OR EDIT
I '$L($G(DATA)) S OUT="Update cancelled. Missing/invalid data string" Q
S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. Missing data string" Q
F CNT=1:1:TOT S DATA(CNT)=$P(DATA,$C(30),CNT) ; BUILD PRIMARY FIELD ARRAY
S %=DATA(1) I %=""!(%=$C(31)) S OUT="Update cancelled. Missing data string" Q
S %=DATA(CNT) I %[$C(31) S %=$P(%,$C(31),1),DATA(CNT)=% ; STRIP OFF END OF FILE MARKER
F CNT=1:1:TOT S X=DATA(CNT) I $L(X) D ; BUILD SECONDARY FIELD ARRAY
. S TFLG=0,DFLG=0
. I $E(X)="+" S TFLG=1,X=$E(X,2,999),$P(FLD,U)=1
. I $E(X)="-" S DFLG=1,X=$E(X,2,999)
. S FNO=$P(X,"|"),VAL=$P(X,"|",2)
. I '$D(^DD(FILE,+$G(FNO),0)) S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid field number" Q
. I DFLG,VAL'="" S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid deletion syntax" Q ; CANT DELETE IF A VALUE IS SENT
. I DFLG!(VAL="") S VAL="@" ; SYNC DFLG AND VAL
. I VAL="@" S DFLG=1 ; SYNC DFLG AND VAL
. S FLD(FNO)=VAL_U_TFLG_U_DFLG
. I FNO=.01,TFLG S $P(FLD,U,2)=1 ;
. Q
I $P($G(FLD(.01)),U,3),UFLG="A" S OUT="Record deletion cancelled. Missing IEN" Q ; CAN'T DELETE A RECORD WITHOUT A VALID IEN
DELREC I $P($G(FLD(.01)),U,3) D DIK(OREF,IEN) S OUT="OK" Q ; DELETE THE RECORD
I UFLG="A",'$L($P($G(FLD(.01)),U)) S OUT="Record addition cancelled. Missing .01 field" Q ; CAN'T ADD A RECORD WITHOUT A VALID .01 FIELD
ADDREC I UFLG="A" D ADD(OREF) Q ; ADD A NEW ENTRY TO A FILE
EDITREC I UFLG="E" D EDIT(OREF,IEN) Q ; EDIT AN EXISTING RECORD
Q
;
DIK(DIK,DA) ; DELETE A RECORD
D ^DIK
D ^XBFMK
Q
;
ADD(DIC) ; ADD A NEW ENTRY TO A FILE
N X,Y
S X=""""_$P($G(FLD(.01)),U)_""""
S DIC(0)="L"
D ^DIC
I Y=-1 S OUT="Unable to add a new record" G AX
I $O(FLD(.01)) D EDIT(DIC,+Y) Q
S OUT="OK"_"|"_+Y
AX D ^XBFMK
Q
;
EDIT(DIE,DA) ; EDIT AN EXISTING RECORD
N DR,RFLG,ERR,FNO,VAL,TFLG,RESULT,MSG,DIERR,DISYS
S FNO=$O(FLD(.01),-1),DR="" ;HMW Changed to include .01 in DR string
I UFLG="A" S OUT="New record added|"_DA
F S FNO=$O(FLD(FNO)) Q:'FNO S X=FLD(FNO) I $L(X) D I $G(RFLG) Q ; CHECK EA FIELD AND BUILD THE DR STRING AND ERROR STRING
. S VAL(FNO)=$P(X,U),TFLG=$P(X,U,2) I '$L(VAL(FNO)) Q
. K ERR,RESULT
. I VAL(FNO)="@"!(VAL(FNO)="") S RESULT="@"
. E D CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,"ERR")
. I RESULT=U D Q
.. S MSG=$G(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation")
.. I $L(OUT) S OUT=OUT_"~"
.. I TFLG!GTFLG S RFLG=1,OUT=FNO_"|"_MSG Q
.. S OUT=OUT_FNO_"|"_MSG
.. Q
. S VAL(FNO)=RESULT
. I $L(DR) S DR=DR_";"
. S DR=DR_FNO_"////^S X=VAL("_FNO_")" ; BUILD DR STRING
. Q
I $G(RFLG) D:UFLG="A" DIK(DIE,DA) S OUT="Record update cancelled"_"|"_OUT G EX ; TRANSACTION ROLLBACK FLAG IS SET, ENTRY DELETED (ADD MODE) OR UPDATE CANCELLED (EDIT MODE)
L +@CREF@(DA):2 I $T D ^DIE L -@CREF@(DA) G:OUT["valid" EX S OUT="OK" S:UFLG="A" OUT=OUT_"|"_DA G EX ; SUCCESS!!!!
S OUT="Update cancelled. File locked" ; FILE LOCKED. UNABLE TO UPDATE
I $L(FLD),UFLG="A" D DIK(DIE,DA) ; ROLLBACK THE NEW RECORD
EX D ^XBFMK ; CLEANUP
Q
;
Side by Side

After

Width:  |  Height:  |  Size: 6.4 KiB

406
m/BMXSQL.m Normal file
View File

@ -0,0 +1,406 @@
BMXSQL ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
Q
;
FLDNDX(BMXGBL,BMXFL,BMXFLD) ;
;Returns index name and set code for all indexes on field
;on field BMXFLD in file BMXFL
S BMX31=$C(31)_$C(31)
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
I +BMXFL'=BMXFL D
. S BMXFL=$TR(BMXFL,"_"," ")
. I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
. S BMXFL=$O(^DIC("B",BMXFL,0))
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
;
;Check for field name
I +BMXFLD'=BMXFLD D
. S BMXFLD=$TR(BMXFLD,"_"," ")
. I '$D(^DD(BMXFL,"B",BMXFLD)) S BMXFLD="" Q
. S BMXFLD=$O(^DD(BMXFL,"B",BMXFLD,0))
I '$G(BMXFLD) D ERROUT("Field not provided",1) Q
;
;Set up Column names
S ^BMXTEMP($J,0)="T"_$$NUMCHAR(30)_"INDEX^T"_$$NUMCHAR(200)_"CODE"_$C(30)
;
;Write field data to BMXTEMP
S BMXI=0,I=0
N BMXNAM,BMXCOD,BMXNOD,BMXTYP
F S BMXI=$O(^DD(BMXFL,BMXFLD,1,BMXI)) Q:'+BMXI Q:$D(BMXERR) D
. S I=I+1
. S BMXNOD=$G(^DD(BMXFL,BMXFLD,1,BMXI,0))
. S BMXNAM=$P(BMXNOD,U,2)
. S BMXTYP=$P(BMXNOD,U,3)
. S:BMXTYP="" BMXTYP="REGULAR"
. S BMXCOD=$G(^DD(BMXFL,BMXFLD,1,BMXI,1))
. S BMXCOD=$TR(BMXCOD,"^","~")
. S ^BMXTEMP($J,I)=BMXNAM_U_BMXTYP_U_BMXCOD_$C(30)
Q
;
TLIST(BMXGBL,BMXFROM,BMXTO) ;
;Returns list of Fileman files to which user has READ access
;TODO: Pass in type of access (RD,DL,WR) in BMXPAR
;
N A,F,BMXF,BMXFLD,D0,BMXU,I,BMXCNT,BMXMFL,BMXRD,BMXMAX
S U="^"
S:$G(BMXFROM)="RD" BMXFROM=""
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S BMXF=1
S BMXF("FILE")=1
S BMXFLD("FILE")="1^.01"
S BMXFLD("NUMBER")="1^.001" ;ADDED
S BMXFLDN=$P(BMXFLD("FILE"),"^",2)
S BMXFLDN(1,BMXFLDN)="FILE"
S BMXFLDN=$P(BMXFLD("NUMBER"),"^",2) ;ADDED
S BMXFLDN(1,BMXFLDN)="NUMBER" ;ADDED
S BMXFLDO=2 ;CHANGED FROM 1 TO 2
S BMXFLDO(0)="1^.01"
S BMXFLDOX(1,.01,"E")=0
S BMXFLDO(1)="1^.001" ;ADDED
S BMXFLDOX(1,.001,"E")=1 ;ADDED
S BMXFNX(1)="FILE"
S BMXFO(1)="1"
S BMXU=$G(DUZ(0))
S BMXRD=$C(30)
S ^BMXTEMP($J,0)="T00030FILE^N00010NUMBER"_BMXRD
S BMXSET="S I=I+1,^BMXTEMP($J,I)=$P($G(^DIC(D0,0)),U)_U_D0_BMXRD,BMXCNT=BMXCNT+1"
S D0=0,I=0,BMXCNT=0,BMXMAX=2000
S BMXFROM=$G(BMXFROM),BMXTO=$G(BMXTO)
I +BMXFROM=BMXFROM D ;BMXFROM is a filenumber
. S F=(+BMXFROM-1),T=+BMXTO
. S:BMXTO<BMXFROM BMXTO=BMXFROM+1
. S D0=F F S D0=$O(^DIC(D0)) Q:'+D0 Q:D0>T Q:BMXCNT>BMXMAX I $D(^DD(D0)) D TLIST1
I +BMXFROM'=BMXFROM D ;F is a filename or is null
. S F="",T="zzzzzzz"
. S:$G(BMXFROM)]"" F=$O(^DIC("B",BMXFROM),-1)
. S:$G(BMXTO)]"" T=BMXTO
. F S F=$O(^DIC("B",F)) Q:F="" Q:F]T Q:BMXCNT>BMXMAX D
. . S D0=0 F S D0=$O(^DIC("B",F,D0)) Q:'+D0 D TLIST1
;
S I=I+1,^BMXTEMP($J,I)=$C(31)
Q
;
TLIST1 ;
I BMXU="@" X BMXSET Q
Q:$D(^DIC(D0,0))'=11
S A=$G(^DIC(D0,0,"RD"))
I $D(^VA(200,DUZ,"FOF",D0,0)) D Q
. ;I $P(^(0),U,5)="1" X BMXSET Q
. I $P(^VA(200,DUZ,"FOF",D0,0),U,5)="1" X BMXSET Q
F J=1:1:$L(A) I DUZ(0)[$E(A,J) X BMXSET
Q
;
SQLCOL(BMXGBL,BMXSQL) ;EP
D INTSQL(.BMXGBL,.BMXSQL,1)
Q
;
SQLD(BMXGBL,BMXSQL) ;EP Serenji Debug Entrypoint
D DEBUG^%Serenji("SQL^BMXSQL(.BMXGBL,.BMXSQL)","10.10.10.104")
Q
;
SQL(BMXGBL,BMXSQL) ;EP
D INTSQL(.BMXGBL,.BMXSQL,0)
Q
;
INTSQL(BMXGBL,BMXSQL,BMXCOL) ;EP
;
;SQL Top Wait for debug break
;D
;. F J=1:1:10 S K=$H H 1
;. Q
;
S X="ERRTRAP^BMXSQL",@^%ZOSF("TRAP")
I $G(BMXSQL)="" S BMXSQL="" D
. N C S C=0 F S C=$O(BMXSQL(C)) Q:'+C D
. . S BMXSQL=BMXSQL_BMXSQL(C)
;
I BMXSQL["call SHAPE" S BMXSQL="SELECT JUNKNAME, MULTCOLOR FROM JUNKMULT"
; Global-scope variables
K BMXTK
N BMXF,BMXTK,T,BMXFLD,BMXTMP,BMXM,BMXXMAX,BMXFLDN,BMXV
N BMXX,BMXFG,BMXFF,BMXSCR,BMXPFP
N BMXERR,BMXFLDO,BMXFLDOX,BMXFJ,BMXFO,BMXFNX
N BMXMFL,BMXFLDA
D ^XBKVAR
S U="^"
I $D(^%ZOSF("MAXSIZ")) S X=640 X ^%ZOSF("MAXSIZ")
K ^BMXTMP($J),^BMXTEMP($J),^BMXTMPD($J)
S BMXGBL="^BMXTEMP("_$J_")"
;Remove CR and LF from BMXSQL
S BMXSQL=$TR(BMXSQL,$C(13)," ")
S BMXSQL=$TR(BMXSQL,$C(10)," ")
S BMXSQL=$TR(BMXSQL,$C(9)," ")
S BMXSQL=$TR(BMXSQL,$C(34),"")
D PARSE^BMXPRS(BMXSQL)
S BMXXMAX=1000000 ;Default Maximum records to return.
D KW^BMXSQL1(.BMXTK)
Q:$D(BMXERR)
;
;Get file names into BMXF("NAME")="NUMBER"
;Get file numbers into BMXFNX(NUMBER)="NAME"
; Files are ordered in BMXFO(order)="NUMBER"
;
FROM S T=$G(BMXTK("FROM"))
I '+T S BMXERR="'FROM' CLAUSE NOT FOUND" D ERROR Q
S BMXF=0
F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("WHERE")) Q:T=$G(BMXTK("ORDER BY")) Q:T=$G(BMXTK("GROUP BY")) D Q:$D(BMXERR)
. Q:BMXTK(T)=","
. N BMXFNT
. I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2)
. S BMXTK(T)=$TR(BMXTK(T),"_"," ")
. I '(BMXTK(T)?.N),'$D(^DIC("B",BMXTK(T))) S BMXERR="FILE NOT FOUND" D ERROR Q
. S BMXF=BMXF+1
. I BMXTK(T)?.N S BMXFNT=BMXTK(T)
. E S BMXFNT=$O(^DIC("B",BMXTK(T),0))
. S BMXMFL(BMXFNT,"GLOC")=^DIC(BMXFNT,0,"GL")
. D F1(BMXF,BMXTK(T),BMXFNT)
. I '+BMXF(BMXTK(T)) S BMXERR="FILE NUMBER NOT FOUND" D ERROR Q
. D ;Test alias
. . Q:'+$O(BMXTK(T))
. . N V
. . S V=T+1
. . Q:$G(BMXTK(V))=","
. . Q:V=$G(BMXTK("WHERE"))
. . Q:V=$G(BMXTK("ORDER BY"))
. . Q:V=$G(BMXTK("GROUP BY"))
. . S BMXTK(T,"ALIAS")=BMXTK(V)
. . K BMXTK(V)
. . Q
. Q
;
D SELECT^BMXSQL5
I $D(BMXERR) G END
D POST2^BMXPRS ;Remove commas from BMXTK
D KW^BMXSQL1(.BMXTK)
;
D WHERE^BMXSQL7
;
;Find the first WHERE field that has an index
I $D(BMXERR) G END
;
D INDEX(.BMXFF,.BMXX,.BMXTMP)
;
S:BMXTMP BMXX=BMXTMP
;
;Set up screen logic for where fields
D SCREEN^BMXSQL1
D SETX^BMXSQL2(.BMXX,.BMXFG,.BMXSCR)
;
;
EXEC ;Execute enumerator and screen code to call Output routine
;
N BMXOUT,J,BMXC
S BMXOUT=0
;Debug lines (retain):
;K ^HW("BMXX") S J=0 F S J=$O(BMXX(J)) Q:'+J S ^HW("BMXX",J)=BMXX(J)
;K ^HW("BMXSCR") S ^HW("BMXSCR")=$G(BMXSCR) S J=0 F S J=$O(BMXSCR(J)) Q:'+J S ^HW("BMXSCR",J)=BMXSCR(J)
;Test for SHOWPLAN
I $G(BMXTK("SHOWPLAN"))="TRUE" D WPLAN Q
S BMXM=0
I 'BMXCOL S J=0 F S J=$O(BMXX(J)) Q:'+J D Q:BMXM>BMXXMAX
. X BMXX(J)
;
D WRITE^BMXSQL6
;
END Q
;
;
F1(BMXC,BMXNAM,BMXNUM) ;EP
S BMXF(BMXNAM)=BMXNUM
S BMXFNX(BMXNUM)=BMXNAM
S BMXFO(BMXC)=BMXF(BMXNAM)
Q
;
OUT ;Set result in ^BMXTMP
S BMXOUT=BMXOUT+1
S ^BMXTMP($J,"O",D0)=""
S ^BMXTMP($J,BMXOUT)=D0
S BMXM=BMXM+1
Q
;
WPLAN ;Write execution plan
;Set up Column Names
N BMXLEN,BMXTYP,BMXT,J,BMXSCRT,BMXXT
S I=1
F BMXT="VARIABLE^","VALUE"_$C(30) D
. S ^BMXTEMP($J,I)=BMXT,BMXLEN(I)=15,BMXTYP(I)="T"
. S I=I+1
S J=0
I $D(BMXX) F S J=$O(BMXX(J)) Q:'+J D
. S ^BMXTEMP($J,I)="INDEX("_J_")^"
. S I=I+1
. S BMXXT(J)=BMXX(J)
. S BMXXT(J)=$P(BMXXT(J)," X BMXSCR")
. S ^BMXTEMP($J,I)=$TR(BMXXT(J),"^","~")_$C(30)
. S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I))
. S I=I+1
S ^BMXTEMP($J,I)="SCREEN^"
S I=I+1
S BMXSCRT=$G(BMXSCR)
S BMXSCRT=$P(BMXSCRT,"D:'$D(^BMXTMP")
S ^BMXTEMP($J,I)=$TR(BMXSCRT,"^","~")_$C(30)
S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I))
S I=I+1
S J=0
I $D(BMXSCR("C")) F S J=$O(BMXSCR("C",J)) Q:'+J D
. S ^BMXTEMP($J,I)="SCREEN("_J_")^"
. S I=I+1
. S ^BMXTEMP($J,I)=$TR(BMXSCR("C",J),"^","~")_$C(30)
. S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I))
. S I=I+1
D COLTYPE
S I=I+1
D ERRTACK(I)
Q
;
;
COLTYPE ;EP - Append column types and widths to output global
;REQUIRES - BMXLEN(),BMXTYP(),^BMXTEMP
;IHS/SET/HMW 4-22-2004 Modified to use new schema string
;
;"@@@meta@@@BMXIEN|FILE #|DA STRING"
;
N C
S C=0
F S C=$O(BMXLEN(C)) Q:'C D
. I BMXLEN(C)>99999 S BMXLEN(C)=99999
. I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length
. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
Q
;
;S ^BXTEMP($J,0)="@@@meta@@@BMXIEN|"_BMXF_"|" ;Last |-piece will be DA string
;N C
;S C=0
;F S C=$O(BMXLEN(C)) Q:'C D
;. I BMXLEN(C)>99999 S BMXLEN(C)=99999
;. I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length
;. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
;Q
;
ERRTACK(I) ;EP
;
S ^BMXTEMP($J,I)=$C(31)
S:$D(BMXERR) ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXERR
Q
;
NUMCHAR(BMXN) ;EP
;---> Returns Field Length left-padded with 0
;
N BMXC
S BMXC="00000"_BMXN
Q $E(BMXC,$L(BMXC)-4,$L(BMXC))
;
;
INDEX(BMXFF,BMXRET,BMXXCNT) ;
;Returns executable enumerator on first where field with an index
;or "" if no indexed where field
;IN: BMXFF()
;OUT: BMXRET()
; BMXXCNT - size of BMXRET array
;
N F,BMXNOD,BMXFNUM,BMXFLDNUM,BMXHIT,BMXREF,BMXRNAM,BMXOP,Q,BMXGL
N BMXTMP,BMXTMPV,BMXTMPI,BMXTMPL,BMXTMPN,BMXV,BMXRNOD,BMXTMPP
S BMXXCNT=0
S Q=$C(34)
I 'BMXFF Q
S F=0,BMXHIT=0
;
;--->Search BMXFF for special case WHERE clause 1 = "0"
; reset BMXX(1) to return no records
F F=1:1:BMXFF S BMXNOD=BMXFF(F) D Q:$D(BMXERR) Q:BMXHIT
. I ($P(BMXFF(F),"^",2,4)="1^=^0")!($P(BMXFF(F),"^",2,4)="0^=^1") S BMXRET(1)="Q ",BMXHIT=1,BMXXCNT=1
. Q
Q:BMXHIT
;
;Organize the first level into AND- and OR-parts
N BMXR1,BMXR2,BMXE,BMXR3,BMXRNAM
N BMXSTOP,BMXOR
D PLEVEL^BMXSQL3(.BMXFF,.BMXR1,.BMXR2)
;
N BMXPFF S BMXPFF=0
S BMXR3=0
;Look for an AND-part with only one element.
; If found, build an iterator on it and quit
F J=1:1:$L(BMXR2,"&") D Q:BMXHIT
. S BMXE=$P(BMXR2,"&",J)
. I +BMXE=BMXE,BMXR1(BMXE,"ELEMENTS")=1 D
. . ;Test index for element
. . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q ;I'm not sure why this quit was here
. . . Q:$D(BMXFF(K,"JOIN"))
. . . S BMXPFP=K,BMXPFF=0
. . . D XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP)
. . . I BMXR3 S BMXHIT=1,BMXFF(K,"INDEXED")=1
. Q:'BMXHIT
. ;Build iterator and quit
. D BLDIT^BMXSQL3(.BMXFF,K,.BMXRNAM,.BMXOR,.BMXPFP)
. S BMXXCNT=1
. S BMXRET(BMXXCNT)=BMXOR
. Q
Q:BMXHIT
;
;None of the single-element AND parts has a good index or
; there are no single-element AND parts
;If there are no OR-parts, then there are no good indexes so quit
I $L(BMXR2,"!")=1 Q
;
;Test each OR-part for a good index.
;If an OR-part is multi-element or
;if one OR-part doesn't have an index
;then set up to do a table scan and quit
S BMXSTOP=0
F J=1:1:$L(BMXR2,"!") D Q:BMXSTOP
. S BMXE=$P(BMXR2,"!",J)
. I +BMXE=BMXE D
. . I BMXR1(BMXE,"ELEMENTS")'=1 S BMXSTOP=1 Q ;Multiple elements
. . ;Test index elements
. . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q
. . . S BMXPFP=K,BMXPFF=0
. . . D XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP)
. . . I 'BMXR3 S BMXSTOP=1 Q
. . . S BMXFF(K,"INDEXED")=1
. . . S BMXR1(BMXE,"XREF")=BMXRNAM
;
;Build iterator and quit
I BMXSTOP D Q ;One of the elements had no index
. S J=0 F S J=$O(BMXFF(J)) Q:'+J K BMXFF(J,"INDEXED")
S BMXXCNT=0
F J=1:1:$L(BMXR2,"!") D
. S BMXE=$P(BMXR2,"!",J)
. I +BMXE=BMXE,BMXR1(BMXE,"ELEMENTS")=1 D
. . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q
. . . D BLDIT^BMXSQL3(.BMXFF,K,BMXR1(BMXE,"XREF"),.BMXOR,.BMXPFP)
. . . S BMXXCNT=BMXXCNT+1
. . . S BMXRET(BMXXCNT)=BMXOR
. Q
Q
;
;
;
ERROR ;EP - Error processing
;W !,BMXERR
;N A
;S A=0
;I $D(I) S A=I
;D ERROUT(BMXERR,A)
;B ;ERROR in BMXSQL
Q
;
ERROUT(BMXERR,I) ;EP
;---> Save next line for Error Code File if ever used.
;---> If necessary, use I>1 to avoid overwriting valid data.
D ERRTACK(I)
Q
;
ERRTRAP ;
;
K ^BMXTEMP($J)
S ^BMXTEMP($J,0)="T00030M_ERROR"_$C(30)
S BMXZE=$$EC^%ZOSV
S BMXZE=$TR(BMXZE,"^","~")
S ^BMXTEMP($J,1)=BMXZE_$C(30)
S ^BMXTEMP($J,2)=$C(31)
Q
Side by Side

After

Width:  |  Height:  |  Size: 11 KiB

336
m/BMXSQL1.m Normal file
View File

@ -0,0 +1,336 @@
BMXSQL1 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
KW(BMXTK) ;EP
;Identify and mark keywords in BMXTK
;MODIFIES BMXTK
;
N J,BMXSTOP,BMXTMP
;Combine ORDER BY and GROUP BY into a single token
;
S J=0
F S J=$O(BMXTK(J)) Q:'+J D
. S BMXTMP=$$UCASE(BMXTK(J))
. I BMXTMP="ORDER"!(BMXTMP="GROUP") D
. . I $D(BMXTK(J+1)),$$UCASE(BMXTK(J+1))="BY" D
. . . S BMXTK(J)=BMXTK(J)_" "_BMXTK(J+1)
. . . S BMXTK(J)=$$UCASE(BMXTK(J))
. . . S BMXTK(BMXTK(J))=J
. . . K BMXTK(J+1)
. . . Q
. . Q
. Q
;
;Find SELECT
S J=0,BMXSTOP=0
F S J=$O(BMXTK(J)) Q:'+J D Q:BMXSTOP
. I $$UCASE(BMXTK(J))="SELECT" D
. . S BMXTK(J)=$$UCASE(BMXTK(J))
. . S BMXTK("SELECT")=J
. . S BMXSTOP=1
. . Q
. Q
I '+J S BMXERR="SELECT KEYWORD NOT FOUND" Q
;
;DISTINCT
S BMXSTOP=0
F S J=$O(BMXTK(J)) Q:'+J Q:$$UCASE(BMXTK(J))="FROM" D Q:BMXSTOP
. I $$UCASE(BMXTK(J))="DISTINCT" D
. . S BMXTK("DISTINCT")="TRUE"
. . K BMXTK(J)
. . S J=J-1
. . S BMXSTOP=1
. Q
;
;FROM
S BMXSTOP=0
S J=J-1
F S J=$O(BMXTK(J)) Q:'+J Q:$$UCASE(BMXTK(J))="WHERE" D Q:BMXSTOP
. I $$UCASE(BMXTK(J))="FROM" D
. . S BMXTK(J)=$$UCASE(BMXTK(J))
. . S BMXTK("FROM")=J
. . S BMXSTOP=1
. . Q
. Q
;
I '$D(BMXTK("FROM")) S BMXERR="'FROM' KEYWORD NOT FOUND" Q
;
;WHERE
S BMXSTOP=0
F S J=$O(BMXTK(J)) Q:'+J Q:BMXTK(J)="ORDER BY" Q:BMXTK(J)="GROUP BY" D Q:BMXSTOP
. I $$UCASE(BMXTK(J))="WHERE" D
. . S BMXTK(J)=$$UCASE(BMXTK(J))
. . S BMXTK("WHERE")=J
. . S BMXSTOP=1
. Q
;
;SHOWPLAN
S J=BMXTK("FROM")
S BMXSTOP=0
F S J=$O(BMXTK(J)) Q:'+J D Q:BMXSTOP
. I $$UCASE(BMXTK(J))="SHOWPLAN" D
. . S BMXTK("SHOWPLAN")="TRUE"
. . K BMXTK(J)
. . S J=J-1
. . S BMXSTOP=1
. Q
;
;MAXRECORDS
S J=BMXTK("FROM")
S BMXSTOP=0
F S J=$O(BMXTK(J)) Q:'+J D Q:BMXSTOP
. I $$UCASE(BMXTK(J))["MAXRECORDS" D
. . S BMXXMAX=+$P(BMXTK(J),":",2)-1
. . S:+BMXXMAX<0 BMXXMAX=0
. . K BMXTK(J)
. . S J=J-1
. . S BMXSTOP=1
. Q
Q
;
SCREEN ;EP
;Set up BMXFG() array of executable screen code
N F,BMXNOD,BMXFNUM,BMXFLDNUM,BMXHIT,BMXREF
N BMXRNAM,BMXRET,BMXOP,Q,BMXPC,BMXV,BMXFLDLO,BMXFLDNO
N BMXGL
S BMXRET=""
S Q=$C(34)
S BMXFG=BMXFF
S BMXFG("C")=0
I 'BMXFF Q
S F=0,BMXHIT=0
F F=1:1:BMXFF S BMXNOD=BMXFF(F) D Q:$D(BMXERR) Q:BMXHIT
. I $G(BMXFF(F,"INDEXED"))=1 D Q
. . S BMXFG(F)="1"
. . Q
. I $D(BMXFF(F,"JOIN")) D Q
. . S BMXFG(F)="1"
. . Q
. I "(^)"[BMXFF(F) D Q
. . S BMXFG(F)=BMXFF(F)
. . Q
. I "AND^OR"[BMXFF(F) D Q
. . I BMXFF(F)="AND" S BMXFG(F)="&" Q
. . S BMXFG(F)="!"
. . Q
. S BMXFNUM=$S(+$P(BMXNOD,U):$P(BMXNOD,U),1:$O(^DIC("B",$P(BMXNOD,U),0)))
. I '+BMXFNUM D ;Not a fileman field
. . S BMXFLDNUM=0,BMXFLDNO=""
. . S BMXFLDLO=$P(BMXFF(F),U,2)
. . ;
. E D ;Get fileman field data
. . S BMXGL=^DIC(BMXFNUM,0,"GL")
. . I $D(BMXFF(F,"IEN")) D
. . . S BMXFLDNUM=".001"
. . . S BMXFLDNO="IEN"
. . E D
. . . S BMXFLDNUM=$O(^DD(BMXFNUM,"B",$P(BMXNOD,U,2),0))
. . . S BMXFLDNO=^DD(BMXFNUM,BMXFLDNUM,0)
. I BMXFLDNO="IEN" D ;BMXIEN field
. . N BMXEXT,C S BMXEXT=0
. . ;S BMXPC=$P(BMXFLDNO,U,4)
. . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer
. . S BMXFLDLO="D0"
. . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")"
. I $P(BMXFLDNO,U,2)["D" D ;Date field
. . N BMXEXT,C S BMXEXT=0
. . S BMXPC=$P(BMXFLDNO,U,4)
. . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer
. . S BMXFLDLO="$P($G("_BMXGL_"D0,"_Q_$P(BMXPC,";")_Q_")),U,"_$P(BMXPC,";",2)_")"
. . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")"
. I $P(BMXFLDNO,U,2)["S" D ;Set field
. . N BMXEXT,C S BMXEXT=0
. . S BMXPC=$P(BMXFLDNO,U,4)
. . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer
. . S BMXFLDLO="$P("_BMXGL_"D0,"_$P(BMXPC,";")_"),U,"_$P(BMXPC,";",2)_")"
. . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")"
. ;
. I $P(BMXFLDNO,U,2)["P" D ;Pointer field
. . N C,BMXEXT
. . S BMXEXT=0
. . I $P(BMXFF(F),U,5)'=BMXFO(1) D
. . . N R,G,BMXJN,BMXMSCR
. . . S BMXMXCR=1 ;Remove after testing. Find out if the field is from a subfile.
. . . I BMXMXCR D Q
. . . . ;Set up a screen in BMXSCR and in BMXMFL(
. . . . Q
. . . ;
. . . ;Find the node of BMXFF that has the join info
. . . S BMXEXT=1
. . . S BMXFG("C")=BMXFG("C")+1
. . . S C=BMXFG("C")
. . . S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q
. . . S BMXJN=BMXFF(G,"JOIN")
. . . S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2)
. . . S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN_"I +D0 S X="
. . . S BMXFG("C",C)=BMXJN
. . S BMXFLDLO=$$SCRNP(F,BMXGL,BMXFLDNUM,BMXFLDNO)
. . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")"
. I $P(BMXFLDNO,U,2)["C" D ;Computed field
. . N C
. . S BMXPC=$P(BMXFLDNO,U,5,99)
. . S BMXFG("C")=BMXFG("C")+1
. . S C=BMXFG("C")
. . ;If computed field not in primary file, connect navigation code
. . I $P(BMXFF(F),U,5)'=BMXFO(1) D
. . . ;Find the node of BMXFF that has the join info
. . . N R,G,BMXJN
. . . S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q
. . . S BMXJN=BMXFF(G,"JOIN")
. . . S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2)
. . . S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN_"I +D0 "
. . . S BMXJN=BMXJN_BMXPC
. . . S BMXFF(F,0)=$P(BMXFF(F,0),U,1,4)
. . . S $P(BMXFF(F,0),U,5)=BMXJN
. . . S BMXPC=BMXJN
. . S BMXFG("C",C)=BMXPC
. . S BMXFLDLO="BMXSCR(""X"","_C_")"
. I $P(BMXFLDNO,U,2)["N" D ;Numeric field
. . N BMXEXT,C S BMXEXT=0
. . S BMXPC=$P(BMXFLDNO,U,4)
. . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer
. . S BMXFLDLO="$P("_BMXGL_"D0,"_$P(BMXPC,";")_"),U,"_$P(BMXPC,";",2)_")"
. . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")"
. ;
. I $P(BMXFLDNO,U,2)["F" D ;Free Text field
. . N BMXEXT,C S BMXEXT=0,C=0
. . S BMXPC=$P(BMXFLDNO,U,4)
. . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D
. . . N R,G,BMXJN
. . . S BMXFG("C")=BMXFG("C")+1
. . . S C=BMXFG("C")
. . . S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q
. . . S BMXJN=BMXFF(G,"JOIN")
. . . S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2)
. . . S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN
. . . S BMXJN=BMXJN_"I +D0 S X="
. . . S BMXFG("C",C)=BMXJN
. . . S BMXFLDLO="BMXSCR(""X"","_C_")"
. . I $P(BMXFLDNO,U,4)["E" D
. . . N BMXPC2,BMXTMP
. . . S BMXPC2=$P(BMXPC,"E",2)
. . . S BMXTMP="$E("_BMXGL_"D0,"_$P(BMXPC,";")_"),"_$P(BMXPC2,",")_","_$P(BMXPC2,",",2)_")"
. . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXTMP
. . . E S BMXFLDLO=BMXTMP
. . E D
. . . N BMXTMP
. . . S BMXTMP="$P("_BMXGL_"D0,"_$P(BMXPC,";")_"),U,"_$P(BMXPC,";",2)_")"
. . . S BMXTMP="$S($D("_BMXGL_"D0,"_$P(BMXPC,";")_")):"_BMXTMP_",1:"""")"
. . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXTMP
. . . E S BMXFLDLO=BMXTMP
. ;
. S BMXOP=$P(BMXNOD,U,3)
. S BMXV=$P(BMXFF(F),U,4)
. I "<^>^=^["[BMXOP D
. . I BMXOP=">",BMXV?.A S BMXOP="]"
. . I BMXOP="<",BMXV?.A S BMXOP="']"
. . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")"
. . Q
. I "<>"=BMXOP D
. . S BMXOP="'="
. . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")"
. I ">="=BMXOP D
. . I BMXV="" S BMXRET="(I 1)" Q
. . I +BMXV=BMXV D Q
. . . S BMXOP="'<"
. . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")"
. . S BMXV=$$DECSTR^BMXSQL2(BMXV)
. . S BMXOP="]"
. . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")"
. I "<="=BMXOP D
. . I BMXV="" S BMXRET="(I 0)" Q
. . I +BMXV=BMXV D Q
. . . S BMXOP="'>"
. . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")"
. . S BMXV=$$INCSTR^BMXSQL2(BMXV)
. . S BMXOP="']"
. . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")"
. I BMXOP="BETWEEN" D
. . I +$P(BMXV,"~")'=$P(BMXV,"~") D ;BMXV a string
. . . N W,X,Y,Z
. . . S X=$P(BMXV,"~")
. . . S Y=$E(X,1,$L(X)-1)
. . . S Z=$E(X,$L(X))
. . . S Z=$A(Z)
. . . S Z=Z-1
. . . S Z=$C(Z)
. . . S W=Y_Z
. . . S $P(BMXV,"~")=W
. . . S BMXRET="(("_BMXFLDLO_"]"_Q_$P(BMXV,"~")_Q_")&("_BMXFLDLO_"']"_Q_$P(BMXV,"~",2)_Q_"))"
. . E D ;BMXV a number
. . . S BMXRET="(("_BMXFLDLO_"'<"_$P(BMXV,"~")_")&("_BMXFLDLO_"'>"_$P(BMXV,"~",2)_"))"
. . Q
. I BMXOP="LIKE" D
. . S BMXRET="("_BMXFLDLO_"?1"_Q_BMXV_Q_".E)"
. I BMXRET]"" D
. . S BMXFG(F)=BMXRET
. . Q
. ;TODO: Pointer fields
. ;TODO: Computed fields
. ;TODO: Sets of codes
. ;TODO: Dates
. Q
Q
;
SCRNP(F,BMXGL,BMXFLDNU,BMXFLDNO) ;
;Requires BMXFF()
;Sets up expression for pointer field
N BMX,BMXCOR,BMXRET,BMXPC
S BMXPC=$P(BMXFLDNO,U,4)
S BMXCOR="$P($G("_BMXGL_"D0,"_Q_$P(BMXPC,";")_Q_")),U,"_$P(BMXPC,";",2)_")"
S BMXRET=BMXCOR
Q:$D(BMXFF(F,"INTERNAL")) BMXRET
S BMXFNUM=$P(BMXFLDNO,U,2)
S BMXFNUM=+$P(BMXFNUM,"P",2)
S BMXGL=^DIC(BMXFNUM,0,"GL")
S BMXFLDNUM=".01"
S BMXFLDNO=^DD(BMXFNUM,BMXFLDNUM,0)
F D:$P(BMXFLDNO,U,2)["P" Q:$P(BMXFLDNO,U,2)'["P"
. S BMXPC=$P(BMXFLDNO,U,4)
. S BMXRET="$P($G("_BMXGL_BMXRET_","_Q_$P(BMXPC,";")_Q_")),U,"_$P(BMXPC,";",2)_")"
. S BMXFNUM=$P(BMXFLDNO,U,2)
. S BMXFNUM=+$P(BMXFNUM,"P",2)
. S BMXGL=^DIC(BMXFNUM,0,"GL")
. S BMXFLDNUM=".01"
. S BMXFLDNO=^DD(BMXFNUM,BMXFLDNUM,0)
;B ;SCRN2 After chain
;I 0 D ;$P(BMXFLDNO,U,2)["D" D ;Pointer to a date
;. Q:+$G(BMXFF(F,"INDEXED")) ;Dates converted when iterator built
;. N BMXD,J
;. S BMXD=$P(BMXFF(F),U,4)
;. S %DT="T"
;. F J=1:1:$L(BMXD,"~") D
;. . S X=$P(BMXD,"~",J)
;. . D ^%DT
;. . S $P(BMXD,"~",J)=Y
;. S $P(BMXFF(F),U,4)=BMXD
S BMXRET="$P($G("_BMXGL_BMXRET_",0)),U,1)"
S BMXRET="$S(+"_BMXCOR_":"_BMXRET_",1:"""")"
Q BMXRET
;
CASE(BMXTK) ;EP
;Convert keywords to uppercase
N J
S J=0
F S J=$O(BMXTK(J)) Q:'+J D
. F K="DISTINCT","SELECT","WHERE","FROM","SHOWPLAN" D
. . I $$UCASE(BMXTK(J))=K S BMXTK(J)=$$UCASE(BMXTK(J))
. Q
Q
;
UCASE(X) ;EP Convert X to uppercase
F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)
Q X
;
EXP ;Extended pointer
N R,G,BMXJN
S BMXEXT=1
S BMXFG("C")=BMXFG("C")+1
S C=BMXFG("C")
S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q
S BMXJN=BMXFF(G,"JOIN")
S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2)
S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN_"I +D0 S X="
S BMXFG("C",C)=BMXJN
Q
Side by Side

After

Width:  |  Height:  |  Size: 10 KiB

97
m/BMXSQL2.m Normal file
View File

@ -0,0 +1,97 @@
BMXSQL2 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
FLDFILE(BMXIN) ;EP - Returns name of file containing field BMXIN
;in the form FILE^FIELD^FILENUMBER^FIELDNUMBER
;Based on data contained in the BMXF() array
;BMXIN can be either an unambiguous field name or FILE.FIELDNAME
;
N C,BMXA,BMXB,BMXRET,BMXFILN,BMXFLDN,BMXFILNA
S BMXRET=""
I BMXTMPLT D Q BMXRET
. S BMXFILNA=BMXIN
. I '$D(BMXF(BMXFILNA)) S BMXERR="FILE NOT FOUND" S BMXRET="" D ERROR^BMXSQL Q
. I BMXF(BMXFILNA)'=BMXFO(1) S BMXERR="TEMPLATES ONLY SUPPORTED ON PRIMARY FILE" D ERROR^BMXSQL Q
. S BMXRET=BMXFILNA_U_"BMXIEN"_U_BMXF(BMXFILNA)_U_".001"
;
I BMXIN["." D Q BMXRET
. S BMXFILNA=$P(BMXIN,".") ;File Name
. I '$D(BMXF(BMXFILNA)) S BMXERR="FILE NOT FOUND" S BMXRET="" D ERROR^BMXSQL Q
. S BMXRET=BMXFILNA_U_$P(BMXIN,".",2)
. S $P(BMXRET,U,3)=BMXF(BMXFILNA)
. S BMXFLDN=0
. I $P(BMXIN,".",2)'="",$D(^DD(BMXF(BMXFILNA),"B",$P(BMXIN,".",2))) D
. . S BMXFLDN=$O(^DD(BMXF(BMXFILNA),"B",$P(BMXIN,".",2),0))
. I BMXIN["BMXIEN" S BMXFLDN=".001"
. I '+BMXFLDN S BMXERR="FIELD NOT FOUND",BMXRET="" D ERROR^BMXSQL Q
. S $P(BMXRET,U,4)=BMXFLDN
. Q
;Loop through files in BMXF to locate field name
S C=0,BMXA=""
I 'BMXIEN F S BMXA=$O(BMXF(BMXA)) Q:BMXA="" D Q:$D(BMXERR)
. I $D(^DD(BMXF(BMXA),"B",BMXIN)) S BMXRET=BMXA_U_BMXIN D Q:$D(BMXERR)
. . S C=C+1
. . I C>1 S BMXERR="AMBIGUOUS FIELD NAME" D ERROR^BMXSQL Q
. . Q
. Q
I BMXIEN D
. S BMXA=BMXFO(1)
. S BMXA=BMXFNX(BMXA)
. S BMXRET=BMXA_U_BMXIN
. S C=1
I C=0 D Q BMXRET
. S BMXRET="0^"_BMXIN ;String or numeric literal
S BMXFILNA=$P(BMXRET,U)
S BMXFILN=BMXF(BMXFILNA)
S $P(BMXRET,U,3)=BMXFILN
I $D(^DD(BMXFILN,"B",BMXIN)) D
. S BMXFLDN=$O(^DD(BMXFILN,"B",BMXIN,0))
I BMXIEN S BMXFLDN=".001"
I '+BMXFLDN S BMXERR="FIELD NOT FOUND",BMXRET="" D ERROR^BMXSQL Q
S $P(BMXRET,U,4)=BMXFLDN
Q BMXRET
;
DECSTR(BMXSTR) ;EP
;Decrements string collation value by 1
;
N A,E,S,L,BMXRET
I BMXSTR="" Q BMXSTR
S L=$L(BMXSTR)
S E=$E(BMXSTR,L)
S B=$E(BMXSTR,1,L-1)
S A=$A(E)
S A=A-1
S E=$C(A)
S BMXRET=B_E
Q BMXRET
;
INCSTR(BMXSTR) ;EP
;Increments string collation value by 1
Q BMXSTR_$C(1)
;
SETX(BMXX,BMXFG,BMXSCR) ;EP
;Set up executable screen code
;by assembling pieces in BMXFG
;and attach to executable iterator(s)
;
;IN: BMXFG()
; BMXX() -- modified
;OUT: BMXSCR
;
N J
Q:'$D(BMXFG)
S BMXSCR=""
S J=0 F S J=$O(BMXX(J)) Q:'+J D
. S BMXX(J)=BMXX(J)_"X BMXSCR"
F J=1:1:BMXFG S BMXSCR=BMXSCR_BMXFG(J)
S BMXSCR=$S(BMXSCR]"":"I "_BMXSCR_" ",1:"")
S BMXSCR=BMXSCR_"D:'$D(^BMXTMP($J,""O"",D0)) OUT^BMXSQL"
I BMXFG("C") D
. N C
. S C=BMXFG("C")
. S BMXSCR("C")="F BMXC=1:1:"_C_" X BMXSCR(""C"",BMXC) S BMXSCR(""X"",BMXC)=X"
. F C=1:1:BMXFG("C") S BMXSCR("C",C)=BMXFG("C",C)
. S BMXSCR="X BMXSCR(""C"") "_BMXSCR
;
Q
Side by Side

After

Width:  |  Height:  |  Size: 2.8 KiB

330
m/BMXSQL3.m Normal file
View File

@ -0,0 +1,330 @@
BMXSQL3 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
PLEVEL(BMXFF,BMXLVL,BMXRET) ;EP
;Analyze WHERE statement according to paren level
;Return a string to guide building of iterator(s)
;
;Basically, count the number of OR clauses on the
;same paren level
;IN: BMXFF()
;OUT: BMXLVL(), BMXRET
;
;BMXRET = 1&/!2&/!...&/!n clauses
;BMXLVL(E,"BEGIN")=Index where element E begins
;BMXLVL(E,"END") =Index where element E ends
;BMXLVL(E,"ELEMENTS")=Number of subelements in element E
;
N BMXNOR,BMXNAND,J,C,BMXTMP
N E,L,BMXCNT
;Test for no ORs or no ANDs
S BMXNOR=1,BMXNAND=1
S J=0 F S J=$O(BMXFF(J)) Q:'+J D ;Q:'BMXNOR Q:'BMXNAND
. I BMXFF(J)="OR" S BMXNOR=0
. I BMXFF(J)="AND" S BMXNAND=0
. Q
;If no ORs or no ANDs then take all parens out of BMXFF
I ((BMXNOR)!(BMXNAND)) D
. S:$D(BMXFF("INDEX")) BMXTMP("INDEX")=BMXFF("INDEX")
. S J=0,C=0 F S J=$O(BMXFF(J)) Q:'+J D:"(^)"'[BMXFF(J)
. . S C=C+1
. . S BMXTMP(C)=BMXFF(J)
. . S:$D(BMXFF(J,0)) BMXTMP(C,0)=BMXFF(J,0)
. . S:$D(BMXFF(J,"INTERNAL")) BMXTMP(J,"INTERNAL")=BMXFF(J,"INTERNAL")
. . S:$D(BMXFF(J,"TYPE")) BMXTMP(C,"TYPE")=BMXFF(J,"TYPE")
. . S:$D(BMXFF(J,"IEN")) BMXTMP(C,"IEN")=BMXFF(J,"IEN")
. . S:$D(BMXFF(J,"JOIN")) BMXTMP(C,"JOIN")=BMXFF(J,"JOIN")
. . S:$D(BMXFF(J,"JOIN","IEN")) BMXTMP(C,"JOIN","IEN")=BMXFF(J,"JOIN","IEN")
. . ;I $D(BMXFF(J,"JOIN")) D
. . ;. N K S K=0 F S K=$O(BMXFF(J,"JOIN",K)) Q:'+K D
. . ;. . N L S L=0 F S L=$O(BMXFF(J,"JOIN",K,L)) Q:'+L D
. . ;. . . S BMXTMP(C,"JOIN",K,L)=BMXFF(J,"JOIN",K,L)
. . I $D(BMXFF(J,"SET")) D
. . . N BMXSS
. . . S BMXSS="" F S BMXSS=$O(BMXFF(J,"SET",BMXSS)) Q:BMXSS="" D
. . . . S BMXTMP(C,"SET",BMXSS)=BMXFF(J,"SET",BMXSS)
. K BMXFF
. I $D(BMXTMP("INDEX")) S BMXFF("INDEX")=BMXTMP("INDEX")
. S J=0 F S J=$O(BMXTMP(J)) Q:'+J D
. . S BMXFF(J)=BMXTMP(J)
. . S:$D(BMXTMP(J,0)) BMXFF(J,0)=BMXTMP(J,0)
. . S:$D(BMXTMP(J,"TYPE")) BMXFF(J,"TYPE")=BMXTMP(J,"TYPE")
. . I $D(BMXTMP(J,"JOIN")) S BMXFF(J,"JOIN")=BMXTMP(J,"JOIN") S:$D(BMXTMP(J,"JOIN","IEN")) BMXFF(J,"JOIN","IEN")=BMXTMP(J,"JOIN","IEN") S BMXFJ("JOIN",+$P($P(BMXFF(J,0),U,2),"P",2))=J
. . ;I $D(BMXTMP(J,"JOIN")) D
. . ;. N K S K=0 F S K=$O(BMXTMP(J,"JOIN",K)) Q:'+K D
. . ;. . N L S L=0 F S L=$O(BMXTMP(J,"JOIN",K,L)) Q:'+L D
. . ;. . . S BMXFF(J,"JOIN",K,L)=BMXTMP(J,"JOIN",K,L)
. . I $D(BMXTMP(J,"SET")) D
. . . N BMXSS
. . . S BMXSS="" F S BMXSS=$O(BMXTMP(J,"SET",BMXSS)) Q:BMXSS="" D
. . . . S BMXFF(J,"SET",BMXSS)=BMXTMP(J,"SET",BMXSS)
. . I $D(BMXTMP(J,"INTERNAL")) S BMXFF(J,"INTERNAL")=BMXTMP(J,"INTERNAL")
. . I $D(BMXTMP(J,"IEN")) S BMXFF(J,"IEN")=BMXTMP(J,"IEN")
. S BMXFF=C
. Q
;
;Remove excess leading and trailing parens
;Find close paren corresponding to BMXFF(1)
;If its the last paren, then remove the first and last parens
;Else, quit
N BMXEND
S BMXEND=0
F Q:'((BMXFF(1)="(")&(BMXFF(BMXFF)=")")) Q:BMXEND D
. S L=1,J=1
. F S J=$O(BMXFF(J)) Q:'+J D:"(^)"[BMXFF(J) Q:BMXEND
. . I BMXFF(J)="(" S L=L+1 Q
. . I BMXFF(J)=")" S L=L-1
. . I L=0,J<BMXFF S BMXEND=1 Q
. . I L=0,J=BMXFF D Q
. . . K BMXFF(1),BMXFF(BMXFF)
. . . F J=2:1:BMXFF-1 D
. . . . S BMXFF(J-1)=BMXFF(J)
. . . . S:$D(BMXFF(J,0)) BMXFF(J-1,0)=BMXFF(J,0)
. . . . K BMXFF(J)
. . . S BMXFF=BMXFF-2
;
S BMXRET="",E=1,L=0,BMXCNT=0
K BMXLVL
S J=0 F S J=$O(BMXFF(J)) Q:'+J D
. I BMXFF(J)="(" D Q ;If BMXFF(J) is an open paren
. . S L=1
. . S BMXLVL(E,"BEGIN")=J ;Start position of this expression
. . S BMXCNT=0
. . ;Find corresponding close paren
. . F S J=$O(BMXFF(J)) Q:'+J D Q:L=0
. . . I BMXFF(J)=")" S L=L-1,BMXLVL(E,"END")=J,BMXLVL(E,"ELEMENTS")=BMXCNT Q
. . . I BMXFF(J)="(" S L=L+1 Q
. . . I "AND^OR"'[BMXFF(J) S BMXCNT=BMXCNT+1
. . S BMXRET=BMXRET_E
. . S E=E+1
. . Q
. I "AND^OR"[BMXFF(J) D Q ;If BMXFF(J) is an operator
. . S BMXRET=BMXRET_$S(BMXFF(J)="OR":"!",1:"&")
. D Q ; BMXFF(J) is an element unenclosed by parens
. . S BMXLVL(E,"BEGIN")=J
. . S BMXLVL(E,"END")=J
. . S BMXLVL(E,"ELEMENTS")=1
. . S BMXRET=BMXRET_E
. . S E=E+1
. Q
Q
;
XRTST(BMXFF,F,BMXHIT,BMXRNAM,BMXPFP) ;EP
;Returns TRUE (1) in BMXRET if 'normal' index exists
;for field in BMXFF(BMXNDX)
;ELSE returns 0
;
;IN: BMXFF
; F
;OUT:BMXRET - 1 or 0
; BMXRNAM - If BMXRET=1, Index name
;
N BMXNOD0,BMXFNUM,BMXGL,BMXFLDNUM,BMXREF,Q
S BMXRET=0,Q=$C(34)
;
Q:"AND^OR^(^)"[BMXFF(F)
S BMXNOD=BMXFF(F)
S BMXNOD0=BMXFF(F,0)
S BMXFNUM=$P(BMXNOD,U,5)
Q:'+BMXFNUM
S BMXGL=$P(BMXNOD,U,7,8)
S BMXFLDNUM=$P(BMXNOD,U,6)
S BMXHIT=0
Q:$D(BMXFF("JOIN"))
Q:$D(BMXFF(F,"INTERNAL"))
I BMXPFF=0,$P(BMXFF(F),U,4)="" Q ;Cannot create iterator on null
I $D(BMXFF(F,"IEN")) S BMXHIT=1 Q
I '$D(^DD(BMXFNUM,BMXFLDNUM,1)) Q
I $P(BMXNOD0,U,2)'["P",$D(BMXFF("INDEX")) D Q ;Explicit index
. S BMXRNAM=BMXFF("INDEX")
. S BMXHIT=1
S BMXREF=0
F S BMXREF=$O(^DD(BMXFNUM,BMXFLDNUM,1,BMXREF)) Q:'+BMXREF Q:BMXHIT D
. Q:'$D(^DD(BMXFNUM,BMXFLDNUM,1,BMXREF,0))
. S BMXRNOD=^DD(BMXFNUM,BMXFLDNUM,1,BMXREF,0)
. Q:$P(BMXRNOD,U,3)]""
. S BMXRNAM=$P(BMXRNOD,U,2)
. S BMXTMP=BMXGL_Q_BMXRNAM_Q_")"
. Q:'$D(@BMXTMP)
. S BMXTMPV=0,BMXTMPV=$O(@BMXTMP@(BMXTMPV))
. Q:BMXTMPV=""
. S BMXTMP=BMXGL_Q_BMXRNAM_Q_","_Q_BMXTMPV_Q_")"
. S BMXTMPI=0,BMXTMPI=$O(@BMXTMP@(BMXTMPI))
. S BMXTMP=$S(BMXGL[",":$P(BMXGL,",")_")",1:$P(BMXGL,"("))
. Q:'$D(@BMXTMP@(BMXTMPI))
. S BMXTMPL=$P(BMXFF(F,0),U,4)
. S BMXTMPP=$P(BMXTMPL,";",2)
. S BMXTMPL=$P(BMXTMPL,";")
. Q:BMXTMPL=""
. S BMXTMP=BMXGL_BMXTMPI_")"
. Q:'$D(@BMXTMP@(BMXTMPL))
. S BMXTMPN=@BMXTMP@(BMXTMPL)
. I BMXTMPP["E" D
. . S BMXTMPP=$P(BMXTMPP,"E",2)
. . S BMXTMPP=$E(BMXTMPN,$P(BMXTMPP,","),$P(BMXTMPP,",",2))
. E D
. . S BMXTMPP=$P(BMXTMPN,"^",BMXTMPP)
. I $P(BMXNOD0,U,2)["P" D Q
. . N BMXPFFN
. . S BMXPFF(BMXPFF)=BMXFF(F)
. . S BMXPFF(BMXPFF,0)=BMXFF(F,0)
. . S BMXPFF(BMXPFF,1)=BMXREF
. . S $P(BMXPFF(BMXPFF,1),U,2)=BMXRNAM
. . S BMXPFP(BMXPFP,BMXPFF)=BMXFF(F)
. . S BMXPFP(BMXPFP,BMXPFF,0)=BMXFF(F,0)
. . S BMXPFP(BMXPFP,BMXPFF,1)=BMXREF
. . S $P(BMXPFP(BMXPFP,BMXPFF,1),U,2)=BMXRNAM
. . S BMXPFF=BMXPFF+1
. . S BMXPFFN=$P(BMXNOD0,U,2)
. . S BMXPFFN=+$P(BMXPFFN,"P",2)
. . S $P(BMXPFF(BMXPFF),U,5)=BMXPFFN
. . S $P(BMXPFF(BMXPFF),U,6)=".01"
. . S $P(BMXPFF(BMXPFF),U,7)=^DIC(BMXPFFN,0,"GL")
. . S BMXPFF(BMXPFF,0)=^DD(BMXPFFN,".01",0)
. . S $P(BMXPFP(BMXPFP,BMXPFF),U,5)=BMXPFFN
. . S $P(BMXPFP(BMXPFP,BMXPFF),U,6)=".01"
. . S $P(BMXPFP(BMXPFP,BMXPFF),U,7)=^DIC(BMXPFFN,0,"GL")
. . S BMXPFP(BMXPFP,BMXPFF,0)=^DD(BMXPFFN,".01",0)
. . D XRTST(.BMXPFF,BMXPFF,.BMXHIT,BMXRNAM,.BMXPFP)
. . Q
. I BMXTMPP=BMXTMPV D Q
. . S BMXHIT=1,BMXRET=1
. . I BMXPFF>0 D Q
. . . S BMXPFF(BMXPFF,1)=BMXREF
. . . S $P(BMXPFF(BMXPFF,1),U,2)=BMXRNAM
. . . S BMXPFP(BMXPFP,BMXPFF,1)=BMXREF
. . . S $P(BMXPFP(BMXPFP,BMXPFF,1),U,2)=BMXRNAM
. . Q
. Q
Q
;
;
BLDIT(BMXFF,F,BMXRNAM,BMXRET,BMXPFP) ;EP - Build iterator
;
K BMXRET
N BMXNOD,BMXOP,BMXV,BMXGL,Q
S BMXNOD=BMXFF(F)
S BMXOP=$P(BMXNOD,U,3)
S BMXV=$P(BMXNOD,U,4)
S BMXGL=$P(BMXNOD,U,7,8)
S Q=$C(34)
I $D(BMXPFP(F)) D BLDIT2 Q ;Pointer
;TODO Set BMXV to the pointer or set or FM date that corresponds
; to the user-entered value
I $D(BMXFF(F,"IEN")),BMXFF(F,"IEN")="TEMPLATE" D Q
. N BMXTNUM
. S BMXTNUM=$O(^DIBT("B",$P(BMXFF(F),U,4),0))
. S BMXRET="S D0=0 F S D0=$O(^DIBT("_BMXTNUM_",1,D0)) Q:'+D0 Q:BMXM>BMXXMAX "
. Q
I BMXOP="=" D Q
. I $D(BMXFF(F,"IEN")) S BMXRET="S D0="_BMXV_" Q:'+D0 Q:BMXM>BMXXMAX " Q
. S BMXRET="S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_","_Q_BMXV_Q_",D0)) Q:D0="""" Q:BMXM>BMXXMAX "
. Q
;
I BMXOP=">=" D Q
. I $D(BMXFF(F,"IEN")) S BMXV=BMXV-1,BMXRET="S D0="_BMXV_" F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX " Q
. N BMXTMP
. S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)"
. S @BMXTMP
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
;
I BMXOP=">" D Q
. I $D(BMXFF(F,"IEN")) S BMXRET="S D0="_BMXV_" F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX " Q
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
;
I BMXOP="<>" D Q
. I $D(BMXFF(F,"IEN")) S BMXRET="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 I D0'="_BMXV_" Q:BMXM>BMXXMAX " Q
. S BMXRET="S BMXV=0 F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX I BMXV'="_Q_BMXV_Q_" S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
;
I BMXOP="<=" D Q
. I $D(BMXFF(F,"IEN")) S BMXRET="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:D0>"_BMXV_" Q:BMXM>BMXXMAX " Q
. N BMXTMP
. S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV))"
. S @BMXTMP
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
;
I BMXOP="<" D Q
. I $D(BMXFF(F,"IEN")) S BMXRET="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:D0'<"_BMXV_" Q:BMXM>BMXXMAX " Q
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
;
I BMXOP="BETWEEN" D Q ;changed '< to > (inclusive BETWEEN)
. I $D(BMXFF(F,"IEN")) D Q
. . S BMXRET="S D0="_(+$P(BMXV,"~")-1)_" F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:D0>"_$P(BMXV,"~",2)_" Q:BMXM>BMXXMAX "
. I +$P(BMXV,"~")=$P(BMXV,"~") D ;BMXV is a number
. . S BMXRET="S BMXV="_$P(BMXV,"~")_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q
. . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV>"_$P(BMXV,"~",2)_" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
. E D ;BMXV is a string
. . S BMXRET="S BMXV="_Q_$P(BMXV,"~")_Q_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q
. . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV]"_Q_$P(BMXV,"~",2)_Q_" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
;
I BMXOP="LIKE" D Q
. N BMXTMP,BMXV1
. S BMXV1=BMXV
. S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)"
. S @BMXTMP
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXV'?1"_Q_BMXV1_Q_".E Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX "
Q
;
BLDIT2 ;Pointer
N BMXPS,J
S BMXPS=$O(BMXPFP(F,999),-1)
S BMXNOD=BMXPFP(F,BMXPS)
S BMXGL=$P(BMXNOD,U,7,8)
I BMXOP="=" D
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXRET="S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_","_Q_BMXV_Q_",D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP=">" D
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP=">=" D
. N BMXTMP
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)"
. S @BMXTMP
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP="<=" D
. N BMXTMP
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV))"
. S @BMXTMP
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP="<>" D
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXRET="S BMXV=0 F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX I BMXV'="_Q_BMXV_Q_" S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP="<" D
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP="BETWEEN" D
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. I +$P(BMXV,"~")=$P(BMXV,"~") D ;BMXV is a number
. . S BMXRET="S BMXV="_$P(BMXV,"~")_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q
. . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV>"_$P(BMXV,"~",2)_" Q:BMXM>BMXXMAX S D"_BMXPS_"=0 F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
. E D ;BMXV is a string
. . S BMXRET="S BMXV="_Q_$P(BMXV,"~")_Q_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q
. . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV]"_Q_$P(BMXV,"~",2)_Q_" Q:BMXM>BMXXMAX S D"_BMXPS_"=0 F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
I BMXOP="LIKE" D
. N BMXTMP,BMXV1
. S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2)
. S BMXV1=BMXV
. S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)"
. S @BMXTMP
. S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXV'?1"_Q_BMXV1_Q_".E Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX "
;
F J=BMXPS-1:-1:0 D
. S BMXNOD=BMXPFP(F,J)
. S BMXGL=$P(BMXNOD,U,7,8)
. S BMXRNAM=$P(BMXPFP(F,J,1),U,2)
. S BMXRET=BMXRET_"S D"_J_"=0 F S D"_J_"=$O("_BMXGL_Q_BMXRNAM_Q_",D"_(J+1)_",D"_J_")) Q:'+D"_J_" Q:BMXM>BMXXMAX "
Q
;TODO: Computed fields
;TODO: Sets of codes
;TODO: User-specified index
Q
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

33
m/BMXSQL4.m Normal file
View File

@ -0,0 +1,33 @@
BMXSQL4 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
JOIN ;EP - Join processing
;Create a pointer chain back to the primary file
;or to a reverse pointer file, E.G.:
;Either executable code or an expression that returns the
;IEN of the terminal pointed-to file
;
; S IEN1=$P(^DIZ(1000,IEN2,0),U,4)
; I +IEN1 S IEN=$P(^AUTTLOC(IEN1,0),U,23)
;
Q:'$D(BMXFJ("JOIN"))
N C,D,E,BMXSTOP,BMXPTF,BMXPTG,BMXPTL,BMXPTN,BMXPTP,BMXPTC
S C=0 F S C=$O(BMXFF(C)) Q:'+C D
. Q:'$D(BMXFF(C,"JOIN"))
. S BMXPTL=1,BMXPTC="",D=C ;Pointer level
. F S BMXPTF=$P(BMXFF(D),U,5) D Q:BMXPTF=BMXFO(1)
. . S BMXPTG=$P(BMXFF(D),U,7,99) ;Pf Global
. . S BMXPTN=$P(BMXFF(D,0),U,4) ;Pf Node
. . S BMXPTP=$P(BMXPTN,";",2) ;Pf Piece
. . S BMXPTN=$P(BMXPTN,";")
. . S BMXPTC="I +IEN"_BMXPTL_" S IEN"_(BMXPTL-1)_"=$P($G("_BMXPTG_"IEN"_BMXPTL_","_BMXPTN_")),U,"_BMXPTP_") "_BMXPTC
. . S BMXPTL=BMXPTL+1
. . ;S D To the index of the pointed to file's entry in BMXFF
. . Q:BMXPTF=BMXFO(1)
. . S E=0,BMXSTOP=0 F S E=$O(BMXFF(E)) Q:'+E Q:BMXSTOP D
. . . I $D(BMXFF(E,0)),+$P($P(BMXFF(E,0),U,2),"P",2)=BMXPTF S D=E,BMXSTOP=1 Q
. . . I $D(BMXFF(E,0)),BMXPTF=9000001,+$P($P(BMXFF(E,0),U,2),"P",2)=2 S D=E,BMXSTOP=1 Q ;IHS auto join PATIENT to VA PATIENT
. S BMXFF(C,"JOIN")=BMXPTC
. S BMXFF(C,"JOIN","IEN")="IEN"_(BMXPTL-1)
Q
Side by Side

After

Width:  |  Height:  |  Size: 1.3 KiB

181
m/BMXSQL5.m Normal file
View File

@ -0,0 +1,181 @@
BMXSQL5 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
SELECT ;EP - Get field names into BMXFLD("NAME")="FILE#^FIELD#"
N BMXA,BMXB,BMXS,BMXSINGL
N BMXINTNL
S T=$G(BMXTK("SELECT"))
I '+T S BMXERR="'SELECT' CLAUSE NOT FOUND" D ERRTACK^BMXSQL(1) Q
S BMXFLD=0
N BMXOFF,BMXGS1,BMXLVL
F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("FROM")) I BMXTK(T)'="," S BMXOFF=1,BMXLVL=0 D S1 Q:$D(BMXERR)
Q
;
SALIAS ;
Q:'+$O(BMXTK(T))
N V
S V=T+1
Q:$G(BMXTK(V))=","
Q:V=$G(BMXTK("FROM"))
S:BMXTK(V)["'" BMXTK(V)=$P(BMXTK(V),"'",2)
S BMXFLDA(BMXFILE,BMXFLDN)=BMXTK(V)
S $P(BMXFLDO(BMXFLDO-1),U,6)=BMXTK(V)
S T=T+1
Q
;
S1 ;
S BMXTK(T)=$TR(BMXTK(T),"_"," ")
;Check for INTERNAL[ modifier
S BMXGS1=0
S BMXINTNL="E"
I BMXTK(T)["[" S BMXINTNL="I",BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1)
;If explicit file name
S BMXSINGL=0
I BMXTK(T)["." D G:BMXGS1 S1 G:BMXSINGL NOTEXP Q
. ;Before FILE.FIELD Parsing
. S BMXA=$P(BMXTK(T),".",1,BMXOFF) ;File Name
. I '$D(BMXF(BMXA)) D Q:$D(BMXERR) Q:BMXSINGL
. . I $D(^DD(BMXFO(1),"B",BMXTK(T))),BMXOFF=1 S BMXSINGL=1 Q
. . S BMXERR="FILE NOT FOUND" D ERRTACK^BMXSQL(1) Q
. S BMXB=$P(BMXTK(T),".",1+BMXOFF,99) ;Field Name TODO: Test here for multiple in extended pointer -- FILE.MULTIPLE.FIELD
. N BMXLAST S BMXLAST=0
. I $L(BMXB,".")>1 D Q:'BMXLAST ;Multiple
. . N BMXFNUM,BMXFNAM,BMXFNOD,BMXSUBFN,BMXUPFN,BMXGL,W,BMXFOUND
. . ;Multiple or Field-name with period?
. . S BMXFOUND=0
. . F W=1:1:$L(BMXTK(T),".") D Q:BMXFOUND
. . . S BMXOFF=BMXOFF+1
. . . I $D(^DD(BMXF(BMXA),"B",$P(BMXB,".",1,W))) D
. . . . S BMXFNAM=$P(BMXB,".",1,W)
. . . . S BMXFOUND=1
. . . . S:W=$L(BMXB,".") BMXLAST=1
. . . . S BMXLVL=BMXLVL+1
. . ;
. . Q:BMXLAST
. . S BMXF=BMXF+1
. . S BMXFNUM=$O(^DD(BMXF(BMXA),"B",BMXFNAM,0)) ;FieldNumber
. . S BMXFNOD=^DD(BMXF(BMXA),BMXFNUM,0)
. . S BMXGL=$P(BMXFNOD,U,4),BMXGL=$P(BMXGL,";")
. . S BMXSUBFN=+$P(BMXFNOD,U,2) ;Subfile Number
. . S BMXUPFN=^DD(BMXSUBFN,0,"UP") ;Parent File Number
. . D SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXLVL,0)
. . S BMXGS1=1
. S:BMXB["'" BMXB=$P(BMXB,"'",2)
. I BMXB="BMXIEN" D Q
. . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
. . D SELECT1
. I BMXB="*" D Q ;All fields in file BMXA
. . ;BMXIEN Has to be first because ADO doesn't handle it well if a DATE type column is returned first
. . S BMXB="BMXIEN"
. . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
. . D SELECT1
. . S BMXB=0 F S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB="" D
. . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
. . . D SELECT1
. S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. I '$D(^DD(BMXF(BMXA),"B",BMXB)) S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q
. S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
. D SELECT1
. Q
;
NOTEXP ;File not explicit so Loop through files in BMXF to locate field name
;
I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2)
S C=0,BMXA=""
I BMXTK(T)="BMXIEN" D Q
. S BMXB=BMXTK(T)
. S BMXA=BMXFO(1) ;File defaults to first named file in FROM
. S BMXA=BMXFNX(BMXA)
. S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
. D SELECT1
F S BMXA=$O(BMXF(BMXA)) Q:BMXA="" D Q:$D(BMXERR)
. S BMXB=BMXTK(T)
. I BMXB="*" D Q ;All fields in file BMXA
. . S BMXB="BMXIEN"
. . S BMXA=BMXFO(1) ;File defaults to first named file in FROM
. . S BMXA=BMXFNX(BMXA)
. . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
. . D SELECT1
. . S BMXB=0 F S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB="" D
. . . S BMXS=BMXA_"."_BMXB
. . . S BMXFLD(BMXS)=BMXF(BMXA)
. . . S $P(BMXFLD(BMXS),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
. . . D SELECT1
. . . S C=1
. I $D(^DD(BMXF(BMXA),"B",BMXTK(T))) D Q:$D(BMXERR)
. . S C=C+1
. . I C>1 S BMXERR="AMBIGUOUS FIELD NAME" D ERRTACK^BMXSQL(1) Q
. . S BMXB=BMXTK(T) ;Field Name
. . I BMXB["'" S BMXB=$P(BMXB,"'",2)
. . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
. . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
. . D SELECT1
. . Q
. Q
I C=0 S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q
Q
;
SELECT1 ;
N BMXGNOD,BMXFILE,BMXGNOD1
S BMXFLDN=$P(BMXFLD(BMXA_"."_BMXB),"^",2)
S BMXFILE=$P(BMXFLD(BMXA_"."_BMXB),U)
S BMXFLDN(BMXFILE,BMXFLDN)=BMXB
I BMXFLDN=".001" S BMXGNOD="IEN",BMXGNOD1="",$P(BMXGNOD1,U,2)="N"
E S BMXGNOD1=^DD(BMXFILE,BMXFLDN,0)
S BMXGNOD=$P(BMXGNOD1,"^",4)
S $P(BMXFLD(BMXA_"."_BMXB),"^",3)=$P(BMXGNOD,";")
S $P(BMXFLD(BMXA_"."_BMXB),"^",4)=$P(BMXGNOD,";",2)
S $P(BMXFLD(BMXA_"."_BMXB),"^",5)=BMXINTNL
S BMXFLDO(BMXFLD)=BMXFILE_"^"_BMXFLDN_"^"_BMXINTNL
I +$P(BMXGNOD1,U,2) D ;Check for WP
. S BMXGNOD1=+$P(BMXGNOD1,U,2)
. Q:'$D(^DD(BMXGNOD1,.01,0))
. I $P(^DD(BMXGNOD1,.01,0),U,2)["W" S $P(BMXFLDO(BMXFLD),U,4)="W"
;HMW20030630 Modified next line to make data type of Internal[] for pointer an Integer.
I $P(BMXGNOD1,U,2)["P" S BMXGNOD1=$$PTYPE(BMXGNOD1) Q:BMXGNOD1="" S:$G(BMXINTNL)="I" $P(BMXGNOD1,U,2)="N" ;I BMXGNOD1="" then Pointed-to file doesn't exist
I $P(BMXGNOD1,U,2)["D" S $P(BMXFLDO(BMXFLD),U,5)="D"
I $P(BMXGNOD1,U,2)["N" D
. N Z
. S Z=$P(BMXGNOD1,U,2)
. I +$P(Z,",",2)=0 S $P(BMXFLDO(BMXFLD),U,5)="I" ;Integer
S BMXFLDOX(BMXFILE,BMXFLDN,BMXINTNL)=BMXFLD
S BMXFLD=BMXFLD+1
S BMXFLDO=BMXFLD
D SALIAS
Q
;
SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXOFF,BMXOTM) ;EP
;
;BMXOTM = One-To-Many
N BMXUPG
S BMXMFL("PARENT",BMXSUBFN)=BMXUPFN
S BMXMFL(BMXUPFN,"SUBFILE",BMXSUBFN)=""
S BMXMFL("SUBFILE",BMXUPFN,BMXSUBFN)=""
S BMXUPG=BMXMFL(BMXUPFN,"GLOC") ;Parent File Global Set in FROM clause
S BMXFNAM=BMXA_"."_BMXFNAM ;TODO: Regression test this line with OTM
I 'BMXOTM S BMXMFL(BMXSUBFN,"GLOC")=BMXUPG_"IEN"_(BMXOFF-1)_","_$C(34)_BMXGL_$C(34)_","
E S BMXMFL(BMXSUBFN,"GLOC")=BMXGL,BMXMFL(BMXSUBFN,"OTM")=""
S BMXMFL(BMXSUBFN,"MULT")="S IEN"_BMXOFF_"=0 F S IEN"_BMXOFF_"=$O("_BMXMFL(BMXSUBFN,"GLOC")_"IEN"_BMXOFF_")) Q:'+IEN"_BMXOFF_" "
I $D(BMXMFL(BMXUPFN,"MULT")) S BMXMFL(BMXSUBFN,"MULT")=BMXMFL(BMXUPFN,"MULT")_" "_BMXMFL(BMXSUBFN,"MULT")
I 'BMXOTM S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" F J=0:1:"_BMXOFF_" S BMXIENS=@(""IEN""_J)_"",""_BMXIENS"
E S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" S J=1 S BMXIENS=@(""IEN""_J)_"",""_BMXIENS"
S BMXMFL(BMXSUBFN,"EXEC")=BMXMFL(BMXSUBFN,"MULT")_"X BMXMFL(BMXFN,""IENS"")"_" D GETS^DIQ(BMXFN,BMXIENS,BMXGF(BMXFN),""E"",BMXA) D SETIEN(IEN"_BMXOFF_",BMXFN)"
D F1^BMXSQL(BMXF,BMXFNAM,BMXSUBFN)
;
Q
;
PTYPE(BMXGNOD1) ;
;Traverse pointer chain to retrieve data type of pointed-to field
N BMXFILE
I $P(BMXGNOD1,U,2)'["P" Q BMXGNOD1
S BMXFILE=$P(BMXGNOD1,U,2)
S BMXFILE=+$P(BMXFILE,"P",2)
S BMXGNOD1=$G(^DD(BMXFILE,".01",0))
S BMXGNOD1=$$PTYPE(BMXGNOD1)
Q BMXGNOD1
Side by Side

After

Width:  |  Height:  |  Size: 6.7 KiB

343
m/BMXSQL6.m Normal file
View File

@ -0,0 +1,343 @@
BMXSQL6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 7/20/2009
;;2.1;BMX;;Jul 26, 2009
; Line EOR+3 used a 2 argument form of $Q which is not
; in the M 95 standard. Replaced this with a call to $$LAST,
; a new Extrinsic in this routine.
;
;
WRITE ;EP
N BMXFN,C,BMXN,BMXGF,BMXA,BMXFLDF,N,A,IEN0,I
N BMXCNT,BMXCNTB,BMXLEN,BMXLTMP,BMXNUM,BMXORD,BMXTYP
N BMXCFN,BMXCFNX,F,BMXROOT,BMXCID,BMXZ ;From MAKEC
N BMXREC,BMXCHAIN ;TODO: COMMENT AFTER TESTING
N BMXIENS
;Set up FIELD value for GETS^DIQ call
; BMXFLD("NAME")="FILE#^FIELD#"
; Need: BMXFLDN(FieldNumber)
; and : BMXFLDO(SelectOrder)
; Get file number -- for now just use first file in array
; TODO: Set up same main file and related files here and in enumerator
S C=0,BMXN=""
N F
S BMXGF=0
S F=0 F S F=$O(BMXF(F)) Q:F="" S BMXFN=BMXF(F) D
. S C=0,BMXN=-1 F S BMXN=$O(BMXFLDO(BMXN)) Q:BMXN="" D
. . Q:$P(BMXFLDO(BMXN),U)'=BMXFN
. . I $P(BMXFLDO(BMXN),U,2)=".001" S BMXGF=BMXGF+1 Q
. . S C=C+1
. . S $P(BMXGF(BMXFN),";",C)=$P(BMXFLDO(BMXN),U,2)
. . S:'$D(BMXGF(BMXFN,"INTERNAL")) BMXGF(BMXFN,"INTERNAL")="E"
. . I $P(BMXFLDO(BMXN),U,3)="I" S BMXGF(BMXFN,"INTERNAL")="IE"
. . S BMXGF=BMXGF+1
. . Q
. Q
;
I BMXGF>1 K BMXTK("DISTINCT") ;Distinct supported for only one field
S N=0,BMXFLDF=0,I=1,BMXNUM=0
D FIELDS
D MAKEC
;
;
I BMXCOL D COLTYPE^BMXSQL,ERRTACK^BMXSQL(I) Q ;Column info only
;
S BMXA="A"
N G,R
;---> Loop through results global
F S N=$O(^BMXTMP($J,N)) Q:'+N D
. K A
. S R=0 F S R=$O(BMXFO(R)) Q:'+R D ;For each file in ORDER array
. . S IEN0=0
. . S BMXFN=BMXFO(R)
. . Q:$D(BMXMFL(BMXFN,"MULT"))
. . I R=1 S IEN0=^BMXTMP($J,N) ;Primary file
. . I R>1,$D(BMXFJ("JOIN",BMXFN)) D ;Joined file
. . . S IEN0=0
. . . S G=BMXFJ("JOIN",BMXFN)
. . . S V=BMXFF(G,"JOIN","IEN")
. . . S @V=^BMXTMP($J,N)
. . . X BMXFF(G,"JOIN")
. . I +IEN0 D ;Removed $D(BMXGF(BMXFN)) for mult fld on extdnd ptr
. . . D SUBFILE(BMXFN)
. . I +IEN0,$D(BMXFLDN(BMXFN,.001)) D SETIEN(IEN0,BMXFN)
. . ;
. . I 0,R>1,$D(BMXMFL(BMXFN,"MULT")) D ;Multiple field
. . . Q:'+IEN0
. . . Q:'$D(BMXGF(BMXFN)) ;Intervening multiple
. . . ;Call GETS for each subentry in multiple
. . . X BMXMFL(BMXFN,"EXEC")
. S F=0,BMXCNT=0
. ;
. D RECORD
. D OUT
;
;
;---> Tack on Error Delimiter and any error.
S I=I+1
D ERRTACK^BMXSQL(I)
D COLTYPE^BMXSQL
Q
;
SETIEN(BMXIEN,BMXFN) ;
;B ;SETIEN
Q:'$D(BMXFLDN(BMXFN,.001))
Q:'+BMXIEN
S A(BMXFN,BMXIEN_",",.001,"E")=BMXIEN
Q
;
SUBFILE(BMXFN) ;
;Execute GETS for Any fields in BMXGF(SUBFILE)
;
;If the subfile itself has subfiles, call SUBFILE(BMXSUBFN)
; (Loop through BMXMFL(BMXFN,"SUBFILE",BMXSUBFN))
I $D(BMXMFL(BMXFN,"SUBFILE")) D
. N BMXSUBFN
. S BMXSUBFN=0
. F S BMXSUBFN=$O(BMXMFL(BMXFN,"SUBFILE",BMXSUBFN)) Q:'+BMXSUBFN D SUBFILE(BMXSUBFN)
. Q
;
I $D(BMXGF(BMXFN)) D
. I '$D(BMXMFL(BMXFN,"MULT")) S BMXMSCR=1 D GETS^DIQ(BMXFN,IEN0_",",BMXGF(BMXFN),BMXGF(BMXFN,"INTERNAL"),BMXA) Q
. E X BMXMFL(BMXFN,"EXEC") Q
;
;
Q
;
FIELDS ;---> Write Field Names
;Field name is TAAAAANAME
;Where T is the field type (T=Text; D=Date)
; AAAAA is the field size (see NUMCHAR routine)
; NAME is the field name
N BMXNUM,BMXFNUM,BMXFNAM,R
K BMXLEN,BMXTYP
S BMXFLDF=1
S BMXNUM=0
;B ;In FIELDS sub
D ;:$D(A)
. I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number
. S BMXFNUM=0
. S BMXFNAM=0
. F R=0:1:(BMXFLDO-1) S BMXFN=$P(BMXFLDO(R),U),BMXFNUM=$P(BMXFLDO(R),U,2) D
. . ;S BMXFNAM=$P(^DD(BMXFN,BMXFNUM,0),"^") ;Get type here
. . S BMXFNAM=BMXFLDN(BMXFN,BMXFNUM)
. . I $P(BMXFLDO(R),U,3)="I" S BMXFNAM="INTERNAL["_BMXFNAM_"]"
. . S BMXFNAM=$TR(BMXFNAM," ","_")
. . I BMXF>1 S BMXFNAM=$TR($P(BMXFNX(BMXFN),".")," ","_")_"."_BMXFNAM
. . S BMXTYP(I)="T"
. . S:$P(BMXFLDO(R),U,5)="D" BMXTYP(I)="D"
. . S:$P(BMXFLDO(R),U,5)="I" BMXTYP(I)="I"
. . S BMXLEN(I)=0 ;Start with length zero
. . ;I $D(BMXFLDA(BMXFN,BMXFNUM)) S BMXFNAM=BMXFLDA(BMXFN,BMXFNUM)
. . I $P(BMXFLDO(R),U,6)]"" S BMXFNAM=$P(BMXFLDO(R),U,6)
. . S ^BMXTEMP($J,I)=BMXFNAM_"^"
. . S I=I+1
. S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30)
Q
;
OUT ;
;Output to BMXTEMP($J
Q:'$D(BMXREC)
N J,K,L,BMXLENT
S J=0 F S J=$O(BMXREC(J)) Q:'+J D
. S K=0 F S K=$O(BMXREC(J,K)) Q:'+K D
. . I +$O(BMXREC(J,K,0)) D Q ;WP
. . . S L=0,BMXLENT=0 F S L=$O(BMXREC(J,K,L)) Q:'+L D
. . . . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)=""
. . . . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)=""
. . . . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K,L)
. . . . S BMXLENT=BMXLENT+$L(BMXREC(J,K,L))
. . . I BMXLEN(K)<BMXLENT S BMXLEN(K)=BMXLENT
. . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)=""
. . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)=""
. . I $G(BMXTK("DISTINCT"))="TRUE",BMXREC(J,K)]"" Q:$D(^BMXTEMP($J,"DISTINCT",BMXREC(J,K)))
. . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K)
. . S:$L(BMXREC(J,K))>BMXLEN(K) BMXLEN(K)=$L(BMXREC(J,K))
. . I $G(BMXTK("DISTINCT"))="TRUE" S ^BMXTEMP($J,"DISTINCT",BMXREC(J,K))=""
Q
;
RECORD ;
;For each chain
N C,BMXCQ,BMXLCQ,BMXCQN,BMXLCQN,BMXTRACK,BMXNODE,BMXCNAME,BMXWP
K BMXREC,BMXCHAIN ;TODO: REMOVE AFTER TESTING
D BLDCHN
S BMXREC=0
D RECINI
S C=0 F S C=$O(BMXCHAIN(C)) Q:'+C D
. ;New chain
. ;Go to the end of the chain, writing record pieces as you go
. ;At the end of the chain, write end-of-record marker,increment record counter, copy previous record
. K BMXTRACK
. S BMXCNAME="BMXCHAIN("_C_")"
. S BMXCQN=""
. S BMXCQ=BMXCNAME F S BMXCQ=$Q(@BMXCQ) Q:BMXCQ="" Q:$P(BMXCQ,",")'=("BMXCHAIN("_C) D
. . S BMXNODE=@BMXCQ
. . I $P(BMXNODE,U,2)="" Q
. . S BMXWP=$P(BMXNODE,U,3)
. . S BMXLCQ=$L(BMXCQ,",")
. . S BMXCQN=$Q(@BMXCQ)
. . S BMXLCQN=$L(BMXCQN,",")
. . I BMXWP="W" D
. . . S BMXREC(BMXREC,$P(BMXNODE,U,2),$P(BMXNODE,U,4))=$P(BMXNODE,U)
. . . S BMXTRACK(BMXLCQ-1,$P(BMXNODE,U,2))=BMXNODE
. . E D
. . . S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U
. . . S BMXTRACK(BMXLCQ,$P(BMXNODE,U,2))=BMXNODE
. . I BMXCQN="" D EOR Q
. . I $P(BMXCQN,",")'=("BMXCHAIN("_C) D EOR Q
. . I BMXLCQN>BMXLCQ Q
. . I (BMXLCQN>$S(BMXWP="W":7,1:6)) D Q
. . . I ($P(BMXCQ,",",1,BMXLCQ-2)=$P(BMXCQN,",",1,BMXLCQN-2)) Q
. . . D EOR ;End of chain
Q
;
RECINI ;
N J
S BMXREC=BMXREC+1
F J=1:1:BMXFLDO D
. I $P(BMXFLDO(J-1),U,4)="W" S BMXREC(BMXREC,J,999999)="^" Q
. S BMXREC(BMXREC,J)="^"
Q
;
EOR ;
;B ;EOR
N J,K,L,M,I,N
; S M=$Q(BMXREC(9999999),-1) //SMH - Another Cacheism
S M=$$LAST("BMXREC")
S @M=$TR(@M,"^",$C(30))
Q:BMXCQN=""
I BMXCQN'="" D RECINI
;K BMXTRACK(BMXLCQ) ;Also kill all track levels between current and next level
F K BMXTRACK($O(BMXTRACK(999999),-1)) Q:$O(BMXTRACK(9999999),-1)'>BMXLCQN
S J=0 F S J=$O(BMXTRACK(J)) Q:'+J D ;Level
. S K=0 F S K=$O(BMXTRACK(J,K)) Q:'+K D ;Order
. . I $D(BMXTRACK(J,K)) S BMXNODE=BMXTRACK(J,K) S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U
. . S L=0 F S L=$O(BMXTRACK(J,K,L)) Q:'+L D ;wp node
. . . I $D(BMXTRACK(J,K,L)) S BMXNODE=BMXTRACK(J,K,L) S BMXREC(BMXREC,$P(BMXNODE,U,2),L)=$P(BMXNODE,U)
Q
;
BLDCHN ;
N B
D MAKEB
;D MAKEC
D BUILD
Q
;
MAKEC ;
;MAKE Chain
;How many chains are there?
S BMXZ=0 S BMXCID=1 K BMXCFN
;
;
;Create BMXCHNP(BMXCID)
S F=0 F S F=$O(BMXMFL(F)) Q:'+F I '$D(BMXMFL("SUBFILE",F)),$D(BMXMFL("PARENT",F)) S BMXMFL("BOTTOM",F)=""
N BMXCB,BMXCHNP,BMXP
S BMXCID=0,BMXCB=0,BMXCHNP=0
I $D(BMXMFL("BOTTOM")) F S BMXCB=$O(BMXMFL("BOTTOM",BMXCB)) Q:'BMXCB D
. S BMXCID=BMXCID+1,BMXCHNP=BMXCID
. S BMXCHNP(BMXCID)=BMXCB
. S BMXP=BMXCB
. F Q:'$D(BMXMFL("PARENT",BMXP)) S BMXP=BMXMFL("PARENT",BMXP) S BMXCHNP(BMXCID)=BMXP_U_BMXCHNP(BMXCID)
;
N J,K,L,M
;Create BMXMFL("BASE")="FILE1^FILE2^...^FILEN"
S F=0,M=0,BMXMFL("BASE")="" F S F=$O(BMXMFL(F)) Q:'+F I (('$D(BMXMFL("PARENT",F)))&('$D(BMXMFL(F,"SUBFILE"))))!(BMXFO(1)=F) S M=M+1,$P(BMXMFL("BASE"),U,M)=F ;Changed to make BMXFO(1) always a member of the base
;
;Create BMXCFN(BMXCID,BMXZ,FILE)
I BMXCID=0 S BMXCID=1
S J=0,BMXZ=0 F J=1:1:BMXCID D
. I BMXMFL("BASE")]"" F L=1:1:$L(BMXMFL("BASE"),"^") S F=$P(BMXMFL("BASE"),"^",L) D
. . S BMXZ=BMXZ+100
. . S BMXCFN(J,BMXZ,F)=""
. I +BMXCHNP F K=1:1:$L(BMXCHNP(J),"^") S F=$P(BMXCHNP(J),"^",K) D
. . Q:F=BMXFO(1) ;BMXFO(1) Is always a member of the base
. . S BMXZ=BMXZ+100
. . S BMXCFN(J,BMXZ,F)=""
;
;
;B ;FIXCFN
D FIXCFN
Q
;
BUILD ;Building BMXCHAIN(
N BMXIEN,BMXCID,BMXFLD,BMXCS,BMXINT,BMXCFNC,BMXCFIEN
S BMXCID=0,BMXIEN=0
F S BMXCID=$O(BMXCFN(BMXCID)) Q:'+BMXCID D
. S BMXCFNC=0 F S BMXCFNC=$O(BMXCFN(BMXCID,BMXCFNC)) Q:'+BMXCFNC S BMXCFN=+BMXCFN(BMXCID,BMXCFNC) D
. . S BMXIEN=0 F S BMXIEN=$O(B(BMXCFN,BMXIEN)) Q:BMXIEN="" D
. . . S $P(BMXCFN(BMXCID,BMXCFNC),U,2)=BMXIEN
. . . S BMXFLD=0 F S BMXFLD=$O(B(BMXCFN,BMXIEN,BMXFLD)) Q:'+BMXFLD D
. . . . S BMXINT="D" F S BMXINT=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D
. . . . . Q:'$D(BMXFLDOX(BMXCFN,BMXFLD,BMXINT))
. . . . . I $P(BMXFLDO(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)),U,4)="W" D MCWP Q
. . . . . D FIXIEN
. . . . . S BMXCS="BMXCHAIN("_BMXCID_","_$S($L(BMXIEN,",")=2:1,1:2)_","_BMXCFIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")"
. . . . . S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXINT)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)
Q
;
FIXIEN ;
N BMXC,BMXCFN1,BMXOFF
S BMXC=BMXCFNC
S BMXCFIEN=BMXCFN_","_$P(BMXIEN,",",$L(BMXIEN,","))
S BMXOFF=1
F S BMXC=$O(BMXCFN(BMXCID,BMXC),-1) Q:'+BMXC D
. S BMXCFN1=+BMXCFN(BMXCID,BMXC)
. I '$D(BMXMFL(BMXCFN,"OTM")) D
. . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q
. . S BMXCFIEN=BMXCFN1_","_$P(BMXIEN,",",$L(BMXIEN,",")-BMXOFF)_","_BMXCFIEN
. I $D(BMXMFL(BMXCFN,"OTM")) D
. . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q
. . S BMXCFIEN=BMXCFN1_$P(BMXCFN(BMXCID,BMXC),U,2)_","_BMXCFIEN
. S BMXOFF=BMXOFF+1
;
;
Q
;
FIXCFN ;
N J,K,L
S J=0 F S J=$O(BMXCFN(J)) Q:'+J D
. S K=0 F S K=$O(BMXCFN(J,K)) Q:'+K D
. . S L=0 F S L=$O(BMXCFN(J,K,L)) Q:'+L D
. . . K BMXCFN(J,K,L)
. . . S BMXCFN(J,K)=L
;
Q
;
MCWP ;
;MAKEC Process WP Field
N BMXIENL,BMXWP
S BMXIENL=1
S:$L(BMXIEN,",")>2 BMXIENL=2
S BMXWP=0
;
F S BMXWP=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXWP)) Q:'+BMXWP D
. S BMXCS="BMXCHAIN("_BMXCID_","_BMXIENL_","_BMXCFN_BMXIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_","_BMXWP_")"
. S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXWP)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)_U_"W"_U_BMXWP
Q
;
;
MAKEB ;
N BMXFILE,BMXIEN,BMXFLD,BMXINT
N BMXSUB,BMXIENR
S BMXFILE=0 F S BMXFILE=$O(A(BMXFILE)) Q:'+BMXFILE D
. S BMXIEN=0 F S BMXIEN=$O(A(BMXFILE,BMXIEN)) Q:'+BMXIEN D
. . S BMXFLD=0 F S BMXFLD=$O(A(BMXFILE,BMXIEN,BMXFLD)) Q:'+BMXFLD D
. . . S BMXINT=0 F S BMXINT=$O(A(BMXFILE,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D
. . . . S BMXIENR=$$REVERSE(BMXIEN)
. . . . S BMXSUB="B("_BMXFILE_","_$C(34)_BMXIENR_$C(34)_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")"
. . . . I $D(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),$P(BMXFLDO(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),U,5)="D" D Q
. . . . . S @BMXSUB=$TR(A(BMXFILE,BMXIEN,BMXFLD,BMXINT),"@"," ")
. . . . S @BMXSUB=A(BMXFILE,BMXIEN,BMXFLD,BMXINT)
Q
;
REVERSE(BMXIEN) ;
N J,T,C
S C=1
F J=$L(BMXIEN,","):-1:1 D
. S $P(T,",",C)=$P(BMXIEN,",",J)
. S C=C+1
Q T
LAST(VAR) ; Get last entry in an array //SMH new code
N SUB1 S SUB1=$O(@VAR@(""),-1)
N SUB2 S SUB2=$O(@VAR@(SUB1,""),-1)
N SUB3 S SUB3=$O(@VAR@(SUB1,SUB2,""),-1)
I SUB3="" Q $NA(@VAR@(SUB1,SUB2))
E Q $NA(@VAR@(SUB1,SUB2,SUB3))
Side by Side

After

Width:  |  Height:  |  Size: 11 KiB

232
m/BMXSQL7.m Normal file
View File

@ -0,0 +1,232 @@
BMXSQL7 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
CHKCR(BMXFNUM,BMXFLDNU,BMXRET) ;Returns cross reference to iterate on for related file
N BMXREF,BMXHIT,BMXRNOD,BMXTMP,BMXTMPV,BMXTMPI,BMXTMPP,BMXPFFN,BMXPFF,Q
N BMXHIT,BMXREF,BMXGL,BMXNOD,BMXRNAM,BMXTMPL,BMXTMPN,BMXTST
;
S BMXNOD=^DD(BMXFNUM,BMXFLDNU,0)
S BMXGL=^DIC(BMXFNUM,0,"GL") ;Subfile global
S BMXREF=0,BMXHIT=0,Q=$C(34),BMXRET=""
F S BMXREF=$O(^DD(BMXFNUM,BMXFLDNU,1,BMXREF)) Q:'+BMXREF D Q:BMXHIT
. Q:'$D(^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0))
. S BMXRNOD=^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0)
. Q:$P(BMXRNOD,U,3)]""
. S BMXRNAM=$P(BMXRNOD,U,2)
. S BMXTMP=BMXGL_Q_BMXRNAM_Q_")"
. S BMXTST=$P(BMXTMP,")")_",IEN0,"
. Q:'$D(@BMXTMP)
. S BMXTMPV=0,BMXTMPV=$O(@BMXTMP@(BMXTMPV))
. Q:BMXTMPV=""
. S BMXTMP=BMXGL_Q_BMXRNAM_Q_","_Q_BMXTMPV_Q_")"
. S BMXTMPI=0,BMXTMPI=$O(@BMXTMP@(BMXTMPI))
. S BMXTMP=$S(BMXGL[",":$P(BMXGL,",")_")",1:$P(BMXGL,"("))
. Q:'$D(@BMXTMP@(BMXTMPI))
. S BMXTMPL=$P(BMXNOD,U,4)
. S BMXTMPP=$P(BMXTMPL,";",2)
. S BMXTMPL=$P(BMXTMPL,";")
. Q:BMXTMPL=""
. S BMXTMP=BMXGL_BMXTMPI_")"
. Q:'$D(@BMXTMP@(BMXTMPL))
. S BMXTMPN=@BMXTMP@(BMXTMPL)
. S BMXTMPP=$P(BMXTMPN,"^",BMXTMPP)
. I BMXTMPP=BMXTMPV S BMXRET=BMXTST,BMXHIT=1
Q BMXHIT
;
;
WHERE ;EP - WHERE-clause processing
;
;Set up the defualt iterator in BMXX(1) to scan the entire file.
;For now, just use first file in the FROM group
;Later, pick the smallest file if more than one file
;
;Set up BMXFF array for each expression element
; BMXFF(n)=FILENAME^FIELDNAME^OPERATOR^VALUE^FILENUMBER^FIELDNUMBER
; ^FILE GLOBAL^FIELD DATA LOCATION
; BMXFF(n,0)=Field descriptor ^DD(FILE,FIELD,0)
;
N BMXGL,BMXOP,BMXTYP,BMXV,BMXV1,BMXV2,BMXFILE,BMXTMP
N BMXINTNL,BMXTMPLT
N BMXIEN
S BMXGL=^DIC(BMXFO(1),0,"GL")
S BMXX=1
S BMXX(1)="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX "
S BMXTMP=BMXGL
I BMXTMP["," S BMXTMP=$TR(BMXTMP,",",")")
E S BMXTMP=$P(BMXTMP,"(",1)
I $D(@BMXTMP@("B")) D
. S BMXX(1)="S BMXTMP=0 F S BMXTMP=$O("_BMXGL_$C(34)_"B"_$C(34)_",BMXTMP)) Q:BMXTMP="""" S D0=0 F S D0=$O("_BMXGL_$C(34)_"B"_$C(34)_",BMXTMP,D0)) Q:'+D0 Q:BMXM>BMXXMAX "
;
;--->BMXFF array:
;
S T=$G(BMXTK("WHERE"))
S BMXFF=0,C=0
Q:'+T
F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("ORDER BY")) Q:T=$G(BMXTK("GROUP BY")) D Q:$D(BMXERR)
. ;Get the file of the field
. I "AND^OR^(^)"[BMXTK(T) D Q
. . S C=C+1
. . S BMXFF(C)=BMXTK(T)
. . S BMXFF=C
. S BMXTK(T)=$TR(BMXTK(T),"_"," ")
. S BMXTK(T)=$TR(BMXTK(T),"'","")
. S BMXINTNL=0
. S BMXTMPLT=0
. S BMXIEN=0
. I BMXTK(T)["INTERNAL[" S BMXINTNL=1,BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1)
. I BMXTK(T)["TEMPLATE[" S BMXTMPLT=1,BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1),BMXIEN=1
. I BMXTK(T)["BMXIEN" S BMXIEN=1
. S BMXFILE=$$FLDFILE^BMXSQL2(BMXTK(T))
. Q:$D(BMXERR)
. S C=C+1
. S BMXFF=C ;This is a count of the where fields
. I BMXFILE]"" D
. . S $P(BMXFF(C),U,1)=$P(BMXFILE,U,1) ;FILENAME
. . S $P(BMXFF(C),U,2)=$P(BMXFILE,U,2) ;FIELDNAME
. . S $P(BMXFF(C),U,5)=$P(BMXFILE,U,3) ;FILENUMBER
. . S $P(BMXFF(C),U,6)=$P(BMXFILE,U,4) ;FIELDNUMBER
. . I $P(BMXFILE,U,3),$D(^DIC($P(BMXFILE,U,3),0,"GL")) S $P(BMXFF(C),U,7)=^DIC($P(BMXFILE,U,3),0,"GL")
. . I BMXIEN S BMXFF(C,0)="IEN",BMXFF(C,"IEN")=1,BMXFF(C,"TYPE")="IEN"
. . E S BMXFF(C,0)=$S(+$P(BMXFILE,U,3):^DD($P(BMXFILE,U,3),$P(BMXFILE,U,4),0),1:"")
. . I BMXINTNL S BMXFF(C,"INTERNAL")=1
. ;
. ;If BMXFF(C) is a pointer, traverse pointer chain to retrieve type
. I $P(BMXFF(C,0),U,2)["P" D
. . ;B ;WHERE Pointer Type
. . N BMXFILN,BMXFLDN,BMXDD
. . S BMXDD=BMXFF(C,0)
. . F Q:$P(BMXDD,U,2)'["P" D:$P(BMXDD,U,2)["P"
. . . S BMXFILN=$P(BMXDD,U,2)
. . . S BMXFILN=+$P(BMXFILN,"P",2)
. . . S BMXDD=^DD(BMXFILN,".01",0)
. . S BMXFF(C,"TYPE")=$S($P(BMXDD,U,2)["D":"DATE",$P(BMXDD,U,2)["S":"SET",1:"OTHER")
. . I BMXFF(C,"TYPE")="SET" S $P(BMXFF(C,"TYPE"),U,2)=$P(BMXDD,U,3)
. ;B ;WHERE Set Type
. I ($P(BMXFF(C,0),U,2)["S")!($P($G(BMXFF(C,"TYPE")),U)="SET") D ;Set
. . N BMXSET,BMXSETP
. . I $P(BMXFF(C,0),U,2)["S" D
. . . S BMXFF(C,"TYPE")="SET"
. . . S $P(BMXFF(C,"TYPE"),U,2)=$P(BMXFF(C,0),U,3)
. . S BMXSET=$P(BMXFF(C,"TYPE"),U,2)
. . F J=1:1:$L(BMXSET,";") D
. . . S BMXSETP=$P(BMXSET,";",J)
. . . Q:BMXSETP=""
. . . S BMXFF(C,"SET",$P(BMXSETP,":",2))=$P(BMXSETP,":")
. ;
. ;Set up comparisons based on operators
. S T=T+1
. S BMXOP=BMXTK(T)
. I BMXTMPLT S BMXOP="="
. I "^<^>^=^[^<>^>=^<=^LIKE"[BMXOP D Q
. . S $P(BMXFF(C),U,3)=BMXTK(T)
. . ;Get the comparison value
. . S T=T+1
. . S BMXTMP=BMXTK(T)
. . S BMXTMP=$TR(BMXTMP,"'","")
. . I BMXOP="LIKE" S BMXTMP=$P(BMXTMP,"%"),$P(BMXFF(C),U,4)=BMXTMP Q
. . I BMXTMPLT D TMPLATE Q
. . I BMXTMP="*" S T=T+1,BMXTMP=BMXTK(T) D OTM Q
. . I BMXTMP[".",BMXTK(T)'["'" D ;This is a join ;TODO: Extended pointers
. . . ;Setting BMXFJ("JOIN"
. . . S BMXTMP=BMXTK(T)
. . . I $D(BMXF($P(BMXTMP,"."))),BMXF($P(BMXTMP,"."))=BMXFO(1) D Q
. . . . S BMXTMP=BMXTK(T-2)
. . . . D OTM
. . . N BMXJN
. . . S BMXFF(C,"JOIN")="Pointer chain"
. . . S BMXJN=+$P($P(BMXFF(C,0),U,2),"P",2)
. . . S BMXFJ("JOIN",+$P($P(BMXFF(C,0),U,2),"P",2))=C
. . . S:+$P($P(BMXFF(C,0),U,2),"P",2)=2 BMXFJ("JOIN",9000001)=C ;IHS Only -- auto join PATIENT to VA PATIENT
. . I ($P(BMXFF(C,0),U,2)["D")!($G(BMXFF(C,"TYPE"))="DATE") D ;Date
. . . Q:$D(BMXFF(C,"INTERNAL"))
. . . I BMXTMP]"" S X=BMXTMP,%DT="T" D ^%DT S BMXTMP=Y
. . I $P($G(BMXFF(C,"TYPE")),U)="SET" D
. . . Q:$D(BMXFF(C,"INTERNAL"))
. . . Q:BMXTMP=""
. . . I $G(BMXFF(C,"SET",BMXTMP))="" S BMXTMP="ZZZZZZ" Q
. . . S BMXTMP=$G(BMXFF(C,"SET",BMXTMP))
. . S $P(BMXFF(C),U,4)=BMXTMP
. . Q
. I BMXOP="BETWEEN" D
. . S $P(BMXFF(C),U,3)="BETWEEN"
. . ;Get the comparison value
. . S T=T+1
. . S BMXV1=BMXTK(T)
. . S:BMXV1["'" BMXV1=$P(BMXV1,"'",2)
. . S T=T+1
. . I BMXTK(T)'="AND" S BMXERR="'BETWEEN' VALUES NOT SPECIFIED" D ERROR Q
. . S T=T+1
. . S BMXV2=BMXTK(T)
. . S:BMXV2["'" BMXV2=$P(BMXV2,"'",2)
. . I ($P(BMXFF(C,0),U,2)["D")!($G(BMXFF(C,"TYPE"))="DATE") D ;Date
. . . Q:$D(BMXFF(C,"INTERNAL"))
. . . S X=BMXV1,%DT="T" D ^%DT S BMXV1=Y
. . . S X=BMXV2,%DT="T" D ^%DT S BMXV2=Y
. . I BMXV1>BMXV2 S BMXTMP=BMXV1,BMXV1=BMXV2,BMXV2=BMXTMP
. . S $P(BMXFF(C),U,4)=BMXV1_"~"_BMXV2
. . Q
. I $P(BMXFF(C),U,3)="" S BMXERR="INVALID OPERATOR" D ERROR Q
. I $D(BMXTK(T+1)),BMXTK(T+1)["[INDEX:" D
. . S T=T+1
. . N BMXIND
. . S BMXIND=$P(BMXTK(T),"INDEX:",2)
. . S:BMXIND["]" BMXIND=$P(BMXIND,"]")
. . S:BMXIND["'" BMXIND=$P(BMXIND,"'",2)
. . S BMXFF("INDEX")=BMXIND
. Q
;
Q:$D(BMXERR)
D JOIN^BMXSQL4
Q
;
TMPLATE ;
N BMXTNUM,BMXTNOD
I BMXTMP["[" S BMXTMP=$P(BMXTMP,"[",2),BMXTMP=$P(BMXTMP,"]")
S BMXTMP=$TR(BMXTMP,"_"," ")
;Test template validity
I '$D(^DIBT("B",BMXTMP)) S BMXERR="TEMPLATE NOT FOUND" D ERROR Q
S BMXTNUM=$O(^DIBT("B",BMXTMP,0))
I '$D(^DIBT(BMXTNUM,0)) S BMXERR="TEMPLATE NOT FOUND" D ERROR Q
S BMXTNOD=^DIBT(BMXTNUM,0)
I $P(BMXTNOD,U,4)'=$P(BMXFF(C),U,5) S BMXERR="TEMPLATE DOES NOT MATCH FILE" D ERROR Q
I '$D(^DIBT(BMXTNUM,1)) S BMXERR="TEMPLATE HAS NO ENTRIES" D ERROR Q
S BMXFF(C,0)="IEN",BMXFF(C,"IEN")="TEMPLATE",BMXFF(C,"TYPE")="IEN"
S $P(BMXFF(C),U,4)=BMXTMP
;
Q
;
OTM ;One-To-Many
N BMXUPFN,BMXSUBFN,BMXA,BMXB,BMXSUBFLD,BMXFNAM
I BMXTMP["INTERNAL[" S BMXTMP=$P(BMXTMP,"INTERNAL[",2),BMXTMP=$P(BMXTMP,"]")
S BMXUPFN=BMXFO(1)
S BMXA=$TR($P(BMXTMP,"."),"_"," ")
S BMXB=$TR($P(BMXTMP,".",2),"_"," ")
S BMXFNAM=BMXB ;Required by SETMFL. Won't work if filename BMXB [ "."
;Get the subfile
I '$D(BMXF(BMXA)) S BMXERR="Related File Not Found" Q
S BMXSUBFN=BMXF(BMXA)
I '$D(^DD(BMXSUBFN,0)) S BMXERR="Related file not found" Q
;Get the field that points to the main file
I '$D(^DD(BMXSUBFN,"B",BMXB)) S BMXERR="Related field not found" Q
S BMXSUBFLD=$O(^DD(BMXSUBFN,"B",BMXB,0))
I '+BMXSUBFLD S BMXERR="Related field not found" Q
;
;Find a normal index on that field
;Set up for call to CHKCR^BMXSQL7
N BMXEXEC
I '$$CHKCR^BMXSQL7(BMXSUBFN,BMXSUBFLD,.BMXEXEC) S BMXERR="Related File not indexed" Q
;
;
S BMXFF(C,"JOIN")="One-to-many Join"
;
;Call SETMFL^BMXSQL5 to set up the iteration code
D SETMFL^BMXSQL5(BMXUPFN,BMXSUBFN,BMXEXEC,1,1)
;
;
;Upfile is the mainfile, Subfile is the related file
;BMXOFF is 1 but What is BMXGL?
;
Q
;
ERROR Q
Side by Side

After

Width:  |  Height:  |  Size: 8.1 KiB

141
m/BMXSQL91.m Normal file
View File

@ -0,0 +1,141 @@
BMXSQL91 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;Below is dead code, but keep for later
SETX2 ;Don't need this unless porting to machine with
;local variable size limitations
N F,LVL,ROOT,START
S LVL=1,START=1
S ROOT="BMXY"
F F=1:1:BMXFF D Q:$D(BMXERR)
. S BMX=BMXFF(F)
. I BMX="(" D Q ;Increment level
. . S LVL=LVL+1
. . ;S ROOT=$S(ROOT["(":$P(ROOT,")")_","_0_")",1:ROOT_"("_0_")")
. . ;Get operator following close paren corresponding to this open
. . ;If op = OR then set up FOR loop in zeroeth node
. . ;if op = AND then set up
. I BMX=")" D Q ;Decrement level
. . S LVL=LVL-1
. . I LVL=1,$D(BMXFF(F+1)),BMXFF(F+1)="&" D Q
. . . S BMXX=BMXX+1
. . . S BMXX(BMXX)=""
. . . F J=START:1:F S BMXX(BMXX)=BMXX(BMXX)_BMXFF(J)
. . . S START=F+2
. . . ;S BMXX(BMXX)="I "_BMXX(BMXX)_" X BMXX("_BMXX+1_")"
. I BMX="AND" D Q ;Chain to previous expression at current level
. I BMX="OR" D Q ;Create FOR-loop to execute screens
;
Q
;
;
;S F=0 F S F=$O(BMXMFL(F)) Q:'+F S:'$D(BMXMFL(F,"SUBFILE")) BMXMFL("NOSUBFILE",F)=""
;I $D(BMXMFL("NOSUBFILE")) S F=0 F S F=$O(BMXMFL("NOSUBFILE",F)) Q:'+F D MAKEC1
;I $D(BMXMFL("SUBFILE")) S F=0 F S F=$O(BMXMFL("SUBFILE",F)) Q:'+F D MAKEC1 ;S BMXROOTZ=BMXZ+100
;
Q
MAKEC1 ;
I '$D(BMXMFL(F,"SUBFILE")),'$D(BMXMFL(F,"MULT")) S BMXZ=BMXZ+100,BMXCFN(BMXCID,BMXZ,F)="" Q
Q:'$D(BMXMFL(F,"SUBFILE"))
Q:$D(BMXMFL(F,"MULT"))
S BMXROOT=F
S BMXROOTZ=BMXZ+100
S BMXROOTC=BMXCID
D MCNT(F)
Q
;
MCNT(F) ;
N S
;B ;MCNT
I '$D(BMXMFL(F,"SUBFILE")) D MCNT2 Q
S S=0 F S S=$O(BMXMFL(F,"SUBFILE",S)) Q:'+S S:'$D(BMXCFN(BMXCID,BMXZ,F)) BMXZ=BMXZ+100,BMXCFN(BMXCID,BMXZ,F)="" S BMXZ=BMXZ+100,BMXCFN(BMXCID,BMXZ,S)="",BMXCFNX(S,F)="" D MCNT(S)
Q
;
MCNT2 ;
;B ;Back-chain
;TODO: RESTART HERE -- $O(BMXCFN(BMXCID,0)) NEEDS TO BE CHANGED TO SOMETHING BESIDES 0
N BMXFTOP,BMXFBACK
F S BMXFTOP=$O(BMXCFN(BMXROOTC,BMXROOTZ,0)) Q:BMXFTOP=BMXROOT S BMXFBACK=$O(BMXCFNX(BMXFTOP,0)) S BMXROOTZ=BMXROOTZ-1,BMXCFN(BMXCID,BMXROOTZ,BMXFBACK)=""
S BMXCID=BMXCID+1,BMXROOTC=BMXCID
;Get the root files
I $D(BMXMFL("NOSUBFILE")) D
. N F
. S F=0 F S F=$O(BMXMFL("NOSUBFILE",F)) Q:'+F D
. . Q:$D(BMXMFL(F,"MULT"))
. . Q:F=BMXROOT
. . S BMXZ=BMXZ+100
. . S BMXCFN(BMXCID,BMXZ,F)=""
S BMXROOTZ=BMXZ+100
Q
;
;
ITER ;Iterate through result array A
S BMXCNT=BMXFLDO ;Field count
S F=0
S:BMXNUM ^BMXTEMP($J,I)=IEN0_"^"
S BMXCNTB=0
S BMXORD=BMXNUM
N BMXONOD
N BMXINT
;B ;WRITE Before REORG
N M,N S N=0
D REORG
;B ;WRITE After REORG
F S N=$O(M(N)) Q:'+N D
. S O=0
. F O=1:1:$L(M(N),U) S BMXFLDO(O-1,"IEN0")=$P(M(N),U,O)
. S BMXORD=BMXNUM
. D OA
Q
;
REORG N R,IEN,J,CONT,TEST
F R=0:1:BMXFLDO-1 S IEN(R)=0
F J=1:1 D Q:'CONT
. S CONT=0
. F R=1:1:BMXFLDO D
. . S TEST=$O(A(+BMXFLDO(R-1),IEN(R-1)))
. . I +TEST S IEN(R-1)=TEST,CONT=1
. . S $P(M(J),U,R)=IEN(R-1)
. Q
I M(J)=M(J-1) K M(J)
Q
;
;
OA ;
I $D(A) F R=0:1:(BMXFLDO-1) S F=$P(BMXFLDO(R),U,2),BMXFN=$P(BMXFLDO(R),U),BMXINT=$P(BMXFLDO(R),U,3) D S:(R+1)<BMXFLDO ^BMXTEMP($J,I)=^BMXTEMP($J,I)_U
. ;S IEN0=BMXFLDO(R,"IEN0") F S IEN0=$O(A(BMXFN,IEN0)) Q:'+IEN0 Q:$D(A(BMXFN,IEN0,F,BMXINT))
. S IEN0=BMXFLDO(R,"IEN0")
. Q:'+IEN0
. S BMXORD=BMXORD+1
. I $D(^DD(BMXFN,F,0)),$P(^DD(BMXFN,F,0),U,2) D I 1 ;Multiple or WP
. . ;Get the subfile number into FL1
. . S FL1=+$P(^DD(BMXFN,F,0),U,2)
. . S FLD1=$O(^DD(FL1,0))
. . I $P(^DD(FL1,FLD1,0),U,2)["W" D ;WP
. . . S WPL=0,BMXLTMP=0
. . . F S WPL=$O(A(BMXFN,IEN0,F,WPL)) Q:'WPL S I=I+1 D
. . . . S ^BMXTEMP($J,I)=A(BMXFN,IEN0,F,WPL)_" "
. . . . S BMXLTMP=BMXLTMP+$L(A(BMXFN,IEN0,F,WPL))+1
. . . . Q
. . . S:BMXLTMP>BMXLEN(BMXORD) BMXLEN(BMXORD)=BMXLTMP
. . . Q
. . D ;It's a multiple. Implement in next phase
. . . ;S BMXMCT=BMXMCT+1
. . . ;S BMXMCT(BMXMCT)=BMXFN_U_F
. . . Q ;Process A( for multiple field
. . Q
. E D ;Not a multiple
. . S I=I+1
. . I $G(BMXTK("DISTINCT"))="TRUE" D Q
. . . Q:A(BMXFN,IEN0,F,BMXINT)=""
. . . I $D(^BMXTMPD($J,A(BMXFN,IEN0,F,BMXINT))) Q
. . . S ^BMXTMPD($J,A(BMXFN,IEN0,F,BMXINT))=""
. . . S ^BMXTEMP($J,I)=A(BMXFN,IEN0,F,BMXINT)
. . . S:$L(A(BMXFN,IEN0,F,BMXINT))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFN,IEN0,F,BMXINT))
. . . Q
. . S ^BMXTEMP($J,I)=A(BMXFN,IEN0,F,BMXINT)
. . S:$L(A(BMXFN,IEN0,F,BMXINT))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFN,IEN0,F,BMXINT))
. Q
;---> Set data in result global.
I $D(^BMXTEMP($J,I)) S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_$C(30)
ZZZ Q
Side by Side

After

Width:  |  Height:  |  Size: 4.4 KiB

7
m/BMXTABLE.m Normal file
View File

@ -0,0 +1,7 @@
BMXTABLE ; IHS/OIT/HMW - BMX RETURN ENTIRE TABLE ;
;;2.1;BMX;;Jul 26, 2009
;
TABLE(BMXGBL,BMXFL,BMXMX) ;EP
;
D FIND^BMXFIND(.BMXGBL,BMXFL,"*",,,BMXMX,,,,1)
Q
Side by Side

After

Width:  |  Height:  |  Size: 166 B

42
m/BMXTRS.m Normal file
View File

@ -0,0 +1,42 @@
BMXTRS ; IHS/OIT/HMW - UPPERCASE-LOWERCASE ;
;;2.1;BMX;;Jul 26, 2009
;
T(X) ;EP
;---> Translate word to mixed case.
;
N BMXWORD,I
I '$D(X) Q ""
I X="^" Q X
I X=" " Q X
;-----> REMOVE LEADING INAPPROPRIATE CHARACTERS IF PRESENT.
F Q:$E(X)'?1P S X=$E(X,2,99)
;-----> CHANGE FIRST LETTER TO UPPERCASE:
S BMXWORD=$E(X)
I $E(BMXWORD)?1L S BMXWORD=$C($A($E(BMXWORD))-32)
;-----> DO NEXT CHARACTER
F I=2:1:$L(X) D CHAR
;-----> REMOVE TRAILING SPACE OR QUOTE.
F Q:""" "'[$E(BMXWORD,$L(BMXWORD)) D
.S BMXWORD=$E(BMXWORD,1,($L(BMXWORD)-1))
;-----> RESET X EQUAL TO RESULT
EOJ ;
Q BMXWORD
;
CHAR ;
;-----> IF THE CHARACTER IS UPPERCASE AND PREVIOUS CHARACTER IS NOT
;-----> PUNCTUATION (EXCEPT FOR AN APOSTROPHY) OR A SPACE,
;-----> THEN CHANGE CHARACTER TO LOWERCASE:
I ($E(X,I)?1U)&(($E(X,I-1)'?1P)!($E(X,I-1)="'")) D Q
.S BMXWORD=BMXWORD_$C($A($E(X,I))+32)
;
;-----> IF THE CHARACTER IS LOWERCASE AND PREVIOUS CHARACTER IS
;-----> PUNCTUATION (BUT NOT AN APOSTROPHY) OR A SPACE, THEN CHANGE
;-----> CHARACTER TO UPPERCASE:
I $E(X,I)?1L,$E(X,I-1)?1P,$E(X,I-1)'="'" D Q
.S BMXWORD=BMXWORD_$C($A($E(X,I))-32)
;
;-----> ADD CHARACTER TO BMXWORD STRING WITHOUT MODIFICATION.
;-----> "\" PLACED BEFORE A LETTER FORCES IT TO BE UPPERCASE;
;-----> HERE REMOVE ANY "\"'s.
I $E(X,I)'="\" S BMXWORD=BMXWORD_$E(X,I)
Q
Side by Side

After

Width:  |  Height:  |  Size: 1.3 KiB

330
m/BMXUTL1.m Normal file
View File

@ -0,0 +1,330 @@
BMXUTL1 ; IHS/OIT/HMW - UTIL: PATIENT DEMOGRAPHICS ;
;;2.1;BMX;;Jul 26, 2009
;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: PATIENT DEMOGRAPHICS.
;
;
;----------
NAME(DFN,ORDER) ;EP
;---> Return text of Patient Name.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - ORDER (opt) ""/0=Last,First 2=First Only
; 1=First Last 3=Last Only
;
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "Unknown"
N X S X=$P(^DPT(DFN,0),U)
Q:'$G(ORDER) X
S X=$$FL(X)
Q:ORDER=1 X
Q:ORDER=2 $P(X," ")
Q:ORDER=3 $P(X," ",2)
Q "UNKNOWN ORDER"
;
;
;----------
FL(X) ;EP
;---> Switch First and Last Names.
Q $P($P(X,",",2)," ")_" "_$P(X,",")
;
;
;----------
DOB(DFN) ;EP
;---> Return Patient's Date of Birth in Fileman format.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "NO PATIENT"
Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
Q $P(^DPT(DFN,0),U,3)
;
;
;----------
DOBF(DFN,BMXDT,BMXNOA) ;EP
;---> Date of Birth formatted "09-Sep-1994 (35 Months)"
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BMXDT (opt) Date on which Age should be calculated.
; 3 - BMXNOA (opt) 1=No age (don't append age).
;
N X,Y
S X=$$DOB($G(DFN))
Q:'X X
S X=$$TXDT1^BMXUTL5(X)
Q:$G(BMXNOA) X
S Y=$$AGEF(DFN,$G(BMXDT))
S:Y["DECEASED" Y="DECEASED"
S X=X_" ("_Y_")"
Q X
;
;
;----------
AGE(DFN,BMXZ,BMXDT) ;EP
;---> Return Patient's Age.
;---> Parameters:
; 1 - DFN (req) IEN in PATIENT File.
; 2 - BMXZ (opt) BMXZ=1,2,3 1=years, 2=months, 3=days.
; 2 will be assumed if not passed.
; 3 - BMXDT (opt) Date on which Age should be calculated.
;
N BMXDOB,X,X1,X2 S:$G(BMXZ)="" BMXZ=2
Q:'$G(DFN) "NO PATIENT"
S BMXDOB=$$DOB(DFN)
Q:'BMXDOB "Unknown"
I '$G(BMXDT)&($$DECEASED(DFN)) D Q X
.S X="DECEASED: "_$$TXDT1^BMXUTL5(+^DPT(DFN,.35))
S:'$G(DT) DT=$$DT^XLFDT
S:'$G(BMXDT) BMXDT=DT
Q:BMXDT<BMXDOB "NOT BORN"
;
;---> Age in Years.
N BMXAGEY,BMXAGEM,BMXD1,BMXD2,BMXM1,BMXM2,BMXY1,BMXY2
S BMXM1=$E(BMXDOB,4,7),BMXM2=$E(BMXDT,4,7)
S BMXY1=$E(BMXDOB,1,3),BMXY2=$E(BMXDT,1,3)
S BMXAGEY=BMXY2-BMXY1 S:BMXM2<BMXM1 BMXAGEY=BMXAGEY-1
S:BMXAGEY<1 BMXAGEY="<1"
Q:BMXZ=1 BMXAGEY
;
;---> Age in Months.
S BMXD1=$E(BMXM1,3,4),BMXM1=$E(BMXM1,1,2)
S BMXD2=$E(BMXM2,3,4),BMXM2=$E(BMXM2,1,2)
S BMXAGEM=12*BMXAGEY
I BMXM2=BMXM1&(BMXD2<BMXD1) S BMXAGEM=BMXAGEM+12
I BMXM2>BMXM1 S BMXAGEM=BMXAGEM+BMXM2-BMXM1
I BMXM2<BMXM1 S BMXAGEM=BMXAGEM+BMXM2+(12-BMXM1)
S:BMXD2<BMXD1 BMXAGEM=BMXAGEM-1
Q:BMXZ=2 BMXAGEM
;
;---> Age in Days.
S X1=BMXDT,X2=BMXDOB
D ^%DTC
Q X
;
;
;----------
AGEF(DFN,BMXDT) ;EP
;---> Age formatted "35 Months" or "23 Years"
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BMXDT (opt) Date on which Age should be calculated.
;
N Y
S Y=$$AGE(DFN,2,$G(BMXDT))
Q:Y["DECEASED" Y
Q:Y["NOT BORN" Y
;
;---> If over 60 months, return years.
Q:Y>60 $$AGE(DFN,1,$G(BMXDT))_" years"
;
;---> If under 1 month return days.
I Y<1 S Y=$$AGE(DFN,3,$G(BMXDT)) Q Y_$S(Y=1:" day",1:" days")
;
;---> Return months
Q Y_$S(Y=1:" month",1:" months")
;
;
;----------
DECEASED(DFN,BMXDT) ;EP
;---> Return 1 if patient is deceased, 0 if not deceased.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BMXDT (opt) If BMXDT=1 return Date of Death (Fileman format).
;
Q:'$G(DFN) 0
N X S X=+$G(^DPT(DFN,.35))
Q:'X 0
Q:'$G(BMXDT) 1
Q X
;
;
;----------
SEX(DFN,PRON) ;EP
;---> Return "F" is patient is female, "M" if male.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - PRON (opt) Pronoun: 1=he/she, 2=him/her,3=his,her
;
Q:'$G(DFN) ""
Q:'$D(^DPT(DFN,0)) ""
N X S X=$P(^DPT(DFN,0),U,2)
Q:'$G(PRON) X
I PRON=1 Q $S(X="F":"she",1:"he")
I PRON=2 Q $S(X="F":"her",1:"him")
I PRON=3 Q $S(X="F":"her",1:"his")
Q X
;
;
;----------
SEXW(DFN) ;EP
;---> Return Patient sex: "Female"/"Male".
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:$$SEX(DFN)="M" "Male"
Q:$$SEX(DFN)="F" "Female"
Q "Unknown"
;
;
;----------
NAMAGE(DFN) ;EP
;---> Return Patient Name concatenated with age.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "NO PATIENT"
Q $$NAME(DFN)_" ("_$$AGE(DFN)_"y/o)"
;
;
;----------
SSN(DFN) ;EP
;---> Return Social Security Number (SSN).
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
N X
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "Unknown"
S X=$P(^DPT(DFN,0),U,9)
Q:X']"" "Unknown"
Q X
;
;
;----------
HRCN(DFN,DUZ2,AGD) ;EP
;---> Return IHS Health Record Number.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - DUZ2 (opt) User's Site/Location IEN. If no DUZ2
; provided, function will look for DUZ(2).
; 3 - AGD (opt) If AGD=1 return HRCN with no dashes.
;
;
S:'$G(DUZ2) DUZ2=$G(DUZ(2))
Q:'$G(DFN)!('$G(DUZ2)) "Unknown1"
Q:'$D(^AUPNPAT(DFN,41,DUZ2,0)) "Unknown2"
Q:'+$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) "Unknown3"
N Y S Y=$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
Q:$G(AGD) Y
Q:'+Y Y
I $L(Y)=7 D Q Y
.S Y=$TR("123-45-67",1234567,Y)
S Y=$E("00000",0,6-$L(Y))_Y
S Y=$TR("12-34-56",123456,Y)
Q Y
;
;
;----------
PHONE(AGDFN,AGOFF) ;EP
;---> Return patient's home phone number.
;---> Parameters:
; 1 - AGDFN (req) Patient's IEN (DFN).
; 2 - AGOFF (opt) =1 will return Patient's Office Phone.
;
Q:'$G(AGDFN) "Error: No DFN"
Q $P($G(^DPT(AGDFN,.13)),U,$S($G(AGOFF):2,1:1))
;
;
;----------
STREET(DFN) ;EP
;---> Return patient's street address.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) ""
Q:$P(^DPT(DFN,.11),U)="" ""
Q $P(^DPT(DFN,.11),U)
;
;
;----------
CITY(DFN) ;EP
;---> Return patient's city.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) ""
Q:$P(^DPT(DFN,.11),U,4)="" ""
Q $P(^DPT(DFN,.11),U,4)
;
;
;----------
STATE(DFN,NOTEXT) ;EP
;---> Return patient's state.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - NOTEXT (opt) If NOTEXT=1 return only the State IEN.
; If NOTEXT=2 return IEN|Text.
;
Q:'$G(DFN) ""
N Y S Y=$P($G(^DPT(DFN,.11)),U,5)
Q:$G(NOTEXT)=1 Y
Q:$G(NOTEXT)=2 Y_"|"_$$GET^BMXG(1,Y)
Q $$GET^BMXG(1,Y)
;
;
;----------
ZIP(DFN) ;EP
;---> Return patient's zipcode.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) ""
Q:$P(^DPT(DFN,.11),U,6)="" ""
Q $P(^DPT(DFN,.11),U,6)
;
;
;----------
CTYSTZ(DFN) ;EP
;---> Return patient's city, state zip.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN)
;
;
CURCOM(DFN,NOTEXT) ;EP
;---> Return patient's Current Community IEN or Text.
;---> (Item 6 on page 1 of Registration).
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - NOTEXT (opt) If NOTEXT=1 return only the Current Comm IEN.
; If NOTEXT=2 return IEN|Text.
;
Q:'$G(DFN) "No Patient"
Q:'$D(^AUPNPAT(DFN,11)) "" ;"Unknown1"
;
N X,Y,Z
S X=^AUPNPAT(DFN,11)
;---> Set Y=Pointer (IEN in ^AUTTCOM, piece 17), Z=Text (piece 18).
S Y=$P(X,U,17),Z=$P(X,U,18)
;---> If both Pointer and Text are null, return "Unknown2".
Q:('Y&(Z="")) "" ;"Unknown2"
;
;---> If Y is null or a bad pointer, set Y="".
I Y<1!('$D(^AUTTCOM(+Y,0))) S Y=""
;
;---> If no valid pointer and if Text (pc 18) exists in the
;---> Community file, then set Y=IEN in ^AUTTCOM(.
I Y<1,$D(^AUTTCOM("B",Z)) S Y=$O(^AUTTCOM("B",Z,0))
;
Q:'$D(^AUTTCOM(+Y,0)) "" ;"Unknown3"
Q:$G(NOTEXT)=1 Y
Q:$G(NOTEXT)=2 Y_"|"_$$GET^BMXG(2,Y)
Q $$GET^BMXG(2,Y)
;
;
;----------
PERSON(X,ORDER) ;EP
;---> Return person's name from File #200.
;---> Parameters:
; 1 - X (req) Person's IEN in New Person File #200.
; 2 - ORDER (opt) ""/0=Last,First 1=First Last
;
Q:'X "Unknown"
Q:'$D(^VA(200,X,0)) "Unknown"
N Y S Y=$P(^VA(200,X,0),U)
Q:'$G(ORDER) Y
Q $$FL(Y)
Side by Side

After

Width:  |  Height:  |  Size: 8.0 KiB

32
m/BMXUTL2.m Normal file
View File

@ -0,0 +1,32 @@
BMXUTL2 ; IHS/OIT/HMW - UTIL: PATIENT INFO ;
;;2.1;BMX;;Jul 26, 2009
;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: PATIENT FUNCTIONS: CONTRAS, INPATIENT, HIDOSE.
;
NEXTAPPT(BMXDFN) ;EP
;---> Return patient's next appointment from Scheduling Package.
;---> Parameters:
; 1 - BMXDFN (req) Patient's IEN (BMXDFN).
;
Q:'$G(BMXDFN) ""
Q:'$D(^DPT(BMXDFN)) ""
;
N BMXAPPT,BMXDT,BMXYES
S BMXDT=DT+.2400,BMXYES=0
F S BMXDT=$O(^DPT(BMXDFN,"S",BMXDT)) Q:'BMXDT!(BMXYES) D
.N BMXDATA,BMXOI,X
.S BMXDATA=$G(^DPT(BMXDFN,"S",BMXDT,0))
.Q:BMXDATA=""
.;
.;---> Quit if appointment is cancelled.
.Q:$P(BMXDATA,U,2)["C"
.;
.S X=0 F S X=$O(^SC(+BMXDATA,"S",BMXDT,1,X)) Q:'X D
..Q:+$G(^SC(+BMXDATA,"S",BMXDT,1,X,0))'=BMXDFN
..S BMXYES=BMXDT_U_+BMXDATA
;
Q:'BMXYES ""
;
S BMXAPPT=$$FMTE^XLFDT(+BMXYES,"1P")_" with "
S BMXAPPT=BMXAPPT_$P($G(^SC($P(BMXYES,U,2),0)),U)
Q BMXAPPT
Side by Side

After

Width:  |  Height:  |  Size: 932 B

217
m/BMXUTL5.m Normal file
View File

@ -0,0 +1,217 @@
BMXUTL5 ; IHS/OIT/HMW - DATE FORMAT ;
;;2.1;BMX;;Jul 26, 2009
;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: SETVARS, CENTERT, COPYLET,
;; UPPERCASE XREFS, DATE FORMATS, PADS/SPACES.
;
;
;----------
SETVARS ;EP
;---> Set standard variables.
D ^XBKVAR
S:'$D(IOF) IOF="#"
Q
;
;
;----------
PHONFIX(X) ;EP
;---> Remove parentheses from Phone#.
;---> Parameters:
; 1 - X (req) Input Phone Number; returned without parentheses.
;
Q:$G(X)=""
S X=$TR(X,"(","")
S X=$TR(X,")","-")
S X=$TR(X,"/","-")
S:X["- " X=$P(X,"- ")_"-"_$P(X,"- ",2)
S:$E(X,4)=" " $E(X,4)="-"
S:X["--" X=$P(X,"--")_"-"_$P(X,"--",2)
S:X?7N X=$E(X,1,3)_"-"_$E(X,4,7)
Q
;
;
;----------
CENTERT(TEXT,X) ;EP
;---> Pad TEXT with leading spaces to center in 80 columns.
;---> Parameters:
; 1 - TEXT (req) Text to be centered.
; 2 - X (opt) Columns to adjust to the right.
;
S:$G(TEXT)="" TEXT="* NO TEXT SUPPLIED *"
S:'$G(X) X=39
N I
F I=1:1:(X-($L(TEXT)/2)) S TEXT=" "_TEXT
Q
;
;
;----------
UPPER(X) ;EP
;---> Translate X to all uppercase.
;---> Parameters:
; 1 - X (req) Value to be translated into all uppercase.
;
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
;
;
;----------
UPXREF(X,AGGBL) ;EP
;---> Set uppercase xref for X. Called from M xrefs on mixed case
;---> fields where an all uppercase lookup is needed.
;---> Parameters:
; 1 - X (req) The value that should be xrefed in uppercase.
; 2 - AGGBL (req) The global root of the file.
;
;---> Variables:
; 1 - DA (req) IEN of the entry being xrefed.
;
Q:'$D(AGGBL) Q:$G(X)="" Q:'$G(DA)
S @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")=""
Q
;
;
;----------
KUPXREF(X,AGGBL) ;EP
;---> Kill uppercase xref for X. Called from M xrefs on mixed case
;---> fields where an all uppercase lookup is needed.
;---> Parameters:
; 1 - X (req) The value that should be xrefed in uppercase.
; 2 - AGGBL (req) The global root of the file.
;
;---> Variables:
; 1 - DA (req) IEN of the entry being xrefed.
;
Q:'$D(AGGBL) Q:$G(X)="" Q:'$G(DA)
K @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")
Q
;
;
;----------
SLDT2(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YYYY.
;---> DATE=DATE IN FILEMAN FORMAT.
Q:'$G(DATE) "NO DATE"
S DATE=$P(DATE,".")
Q:$L(DATE)'=7 DATE
Q:'$E(DATE,4,5) $E(DATE,1,3)+1700
Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)
;
;
;----------
SLDT1(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT:
;---> MM/DD/YYYY @TIME
N Y
Q:'$D(DATE) "NO DATE"
S Y=DATE,DATE=$P(DATE,".")
Q:'DATE "NO DATE"
Q:$L(DATE)'=7 DATE
Q:'$E(DATE,4,5) $E(DATE,1,3)+1700
Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
D DD^%DT S:Y["@" Y=" @ "_$P($P(Y,"@",2),":",1,2)
Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_Y
;
;
;----------
NOSLDT(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "NO SLASH" FORMAT: MMDDYYYY.
;---> DATE=DATE IN FILEMAN FORMAT.
Q:'$G(DATE) "NO DATE"
S DATE=$P(DATE,".")
Q:$L(DATE)'=7 DATE
Q $E(DATE,4,5)_$E(DATE,6,7)_($E(DATE,1,3)+1700)
;
;
;----------
IMMSDT(DATE) ;EP
;---> Convert Immserve Date (format MMDDYYYY) TO FILEMAN
;---> Internal format.
;---> NOTE: This code is copied into routine ^AGPATUP1 for speed.
;---> Any changes here should also be made to the call in ^AGPATUP1.
Q:'$G(DATE) "NO DATE"
Q ($E(DATE,5,9)-1700)_$E(DATE,1,2)_$E(DATE,3,4)
;
;
;----------
TXDT1(DATE,TIME) ;EP
;---> Return external date in format: DD-Mmm-YYYY@HH:MM, from Fileman
;---> internal YYYMMDD.HHMM
;---> Parameters:
; 1 - DATE (req) Internal Fileman date.
; 2 - TIME (opt)
;
Q:'$G(DATE) "NO DATE"
N X,Y,Z
S X="Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec"
S Y=$E(DATE,6,7)_"-"_$P(X,U,$E(DATE,4,5))_"-"_($E(DATE,1,3)+1700)
S:'$E(DATE,6,7) Y=$E(Y,4,99)
S:'$E(DATE,4,5) Y=$E(DATE,1,3)+1700
Q:'$G(TIME) Y
S Z=$P(DATE,".",2)
Q:'Z Y
Q Y_" @"_$E(Z,1,2)_":"_$$PAD($E(Z,3,4),2,"0")
;
;
;----------
TXDT(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY.
N Y
Q:'$D(DATE) "NO DATE"
S Y=DATE D DD^%DT
I Y[", " S Y=$P(Y,", ")_","_$P(Y,", ",2)
I Y["@" S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
Q Y
;
;
;----------
NOW() ;EP
;---> Return Current Date and Time in external format.
N %H,X,Y,Z
S %H=$H
D YX^%DTC
I Y["@" S Y=$P($P(Y,"@",2),":",1,2)
S Z=$$TXDT1(X)
S:Y]"" Z=Z_" @"_Y
Q Z
;
;
;----------
PAD(D,L,C) ;EP
;---> Pad the length of data to a total of L characters
;---> by adding spaces to the end of the data.
; Example: S X=$$PAD("MIKE",7) X="MIKE " (Added 3 spaces.)
;---> Parameters:
; 1 - D (req) Data to be padded.
; 2 - L (req) Total length of resulting data.
; 3 - C (opt) Character to pad with (default=space).
;
Q:'$D(D) ""
S:'$G(L) L=$L(D)
S:$G(C)="" C=" "
Q $E(D_$$REPEAT^XLFSTR(C,L),1,L)
;
;
;----------
SP(N,C) ;EP
;---> Return N spaces or other character.
; Example: S X=$$SP(5)_X Pads the front of X with 5 spaces.
;---> Parameters:
; 1 - N (req) Number of spaces to be returned as extrinsic var.
; 2 - C (opt) Character to pad with (default=space).
;
Q:$G(N)<1 ""
S:$G(C)="" C=" "
Q $$PAD(C,N,C)
;
;
;----------
STRIP(X) ;EP
;---> Strip any punctuation characters from the beginning of X,
;---> including spaces.
;---> Parameters:
; 1 - X (req) String of characters.
;
Q:$G(X)="" ""
F Q:$E(X)'?1P S X=$E(X,2,99)
Q X
Side by Side

After

Width:  |  Height:  |  Size: 5.4 KiB

36
m/BMXUTL6.m Normal file
View File

@ -0,0 +1,36 @@
BMXUTL6 ; IHS/OIT/HMW - BMXNET INSTALLATION CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
POST ;EP - Called from BMX Installation postinit
;
;Add BMX AV CODE to XUS SIGNON broker option
N BMXFDA,BMXIEN,BMXMSG,BMXIENS,BMXMENN,BMXAVI
S BMXAVI=$O(^XWB(8994,"B","BMX AV CODE",0))
Q:'+BMXAVI
S BMXIENS=$O(^DIC(19,"B","XUS SIGNON",0))
Q:'+BMXIENS
;
S BMXIENS="?+2,"_BMXIENS_","
S BMXFDA(19.05,BMXIENS,.01)=BMXAVI
K BMXIEN,BMXMSG
S DIC(0)=""
D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG")
Q
;
;
;
;Create BMXNET,APPLICATION user and set attributes
;
;N BMXFDA,BMXIEN,BMXMSG,BMXIENS,BMXMENN
;S BMXIENS = "?+1,"
;S BMXFDA(200,BMXIENS,.01)="BMXNET,APPLICATION"
;S BMXFDA(200,BMXIENS,2)="1_(a>yr}:3x3ja9\8vbH"
;S BMXFDA(200,BMXIENS,11)="$;HOSs|:3w25lLD}Be="
;S BMXFDA(200,BMXIENS,11.2)="88888,88888"
;S BMXMENN=$O(^DIC(19,"B","BMXRPC",0))
;I +BMXMENN S BMXFDA(200.03,"?+2,?+1,",.01)=BMXMENN
;K BMXIEN,BMXMSG
;S DIC(0)=""
;D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG")
Q
Side by Side

After

Width:  |  Height:  |  Size: 978 B

8
m/BMXUTL7.m Normal file
View File

@ -0,0 +1,8 @@
BMXUTL7 ; IHS/OIT/HMW - BMXNET INSTALLATION CALLS ;
;;2.1;BMX;;Jul 26, 2009
;
;
ENV ;EP Environment Check
I $G(XPDENV)=1 D
. S XPDDIQ("XPZ1")=0
. S XPDDIQ("XPZ2")=0
Side by Side

After

Width:  |  Height:  |  Size: 171 B

236
m/XWBTCPM.m Normal file
View File

@ -0,0 +1,236 @@
XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;8/29/07 22:11
;;1.1;RPC BROKER;**35,43,49**;Mar 28, 1997;Build 6
;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
;Changed to be started by UCX or %ZISTCPS
;
DSM ;DSM called from ucx, % passed in with device.
D ESET
;Open the device
S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
;Go find the connection type
U XWBTDEV
G CONNTYPE
;
CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
D ESET
S XWBTDEV="SYS$NET"
; **Cache'/VMS specific code**
O XWBTDEV::5
X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
G CONNTYPE
;
NT ;entry from ZISTCPS
;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
D ESET
S XWBTDEV=IO
G CONNTYPE
;
GTMUCX(%) ;From ucx ZFOO
;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
D ESET
;GTM specific code
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
S XWBTDEV=% X "O %:(RECORDSIZE=512)"
G CONNTYPE
;
GTMLNX ;From Linux xinetd script
D ESET
;GTM specific code
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
I %["::ffff:" S IO("GTM-IP")=$P(%,"::ffff:",2) ; ipv6 support
G CONNTYPE
;
ESET ;Set inital error trap
S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
S X="",@^%ZOSF("TRAP") ;Clear old trap
Q
;Find the type of connection and jump to the processing routine.
CONNTYPE ;
N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
N SOCK,TYPE
D INIT
S XWB=$$BREAD^XWBRW(5,XWBTIME)
D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="{BMX}":"BMX",1:"Unk"))
I XWB["[XWB]" G NEW
I XWB["{XWB}" G OLD^XWBTCPM1
I XWB["<?xml" G M2M
I XWB["{BMX}" G GTMLNX^BMXMON
I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
D LOG("Prefix not known: "_XWB)
Q
;
NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
N X,Y,J,XWBVOL
D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),J=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
Q 1
;
M2M ;M2M Broker
S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
Q
;
NEW ;New broker
S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
D SETTIME(1) ;Setup for sign-on timeout
U XWBTDEV D
. N XWB,ERR,NATIP,I
. S ERR=$$PRSP^XWBPRS
. S ERR=$$PRSM^XWBPRS
. S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
. S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
. ;Get the peer and save that IP.
. S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
. I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
. Q
S X=$$NEWJOB() D:'X LOG("No New Connects")
I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
D QSND^XWBRW("accept"),LOG("accept") ;Ack
S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
S XWBTIP=$G(IO("IP"))
;start RUM for Broker Handler XWB*1.1*5
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
;GTM
I $G(XWBT("PCNT")) D
. S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
. D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
;We don't use a callback
K XWB,CON,LEN,MSG ;Clean up
;Attempt to share license, Must have TCP port open first.
U XWBTDEV ;D SHARELIC^%ZOSV(1)
;setup null device "NULL"
S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q
D SAVDEV^%ZISUTL("XWBNULL")
;change process name
D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
;
RESTART ;The error trap returns to here
N $ESTACK S $ETRAP="D ETRAP^XWBTCPM"
S DT=$$DT^XLFDT,DTIME=30
U XWBTDEV D MAIN
D LOG("Exit: "_XWBTBUF)
;Turn off the error trap for the exit
S $ETRAP=""
D EXIT ;Logout
K XWBR,XWBARY
;stop RUM for handler XWB*1.1*5
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
;Close in the calling script
K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
Q
;
MAIN ; -- main message processing loop. debug at MAIN+1
F D Q:XWBTBUF="#BYE#"
. ;Setup
. S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
. K XWBR,XWBARY,XWBPRT
. ; -- read client request
. S XR=$$BREAD^XWBRW(1,XWBTIME,1)
. I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
. S XR=XR_$$BREAD^XWBRW(4)
. I XR="#BYE#" D Q ;Check for exit
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
. . Q
. S TYPE=(XR="[XWB]") ;check HDR
. I 'TYPE D LOG("Bad Header: "_XR) Q
. D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
. IF XWBTCMD="#BYE#" D Q
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
. . Q
. U XWBTDEV
. S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
. ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
. I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
Q ;End Of Main
;
;
ETRAP ; -- on trapped error, send error info to client
N XWBERC,XWBERR
;Change trapping during trap.
S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT"
S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
D ^%ZTER ;%ZTER clears $ZE and $ZCODE
D LOG("In ETRAP: "_XWBERC) ;Log
I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT HALT
U XWBTDEV
I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
E L ;Clear Locks
;I XWBOS'="DSM" D
S XWBPTYPE=1 ;So SNDERR won't check XWBR
;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4))
D ESND^XWBRW($C(24)_XWBERR_$C(4))
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
Q
;
CLEANP ;Clean up the partion
N XWBTDEV,XWBNULL D KILL^XUSCLEAN
Q
;
STYPE(X,WRAP) ;For backward compatability only
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
Q $$RTRNFMT^XWBLIB(X)
;
BREAD(L,T) ;read tcp buffer, L is length
Q $$BREAD^XWBRW(L,$G(T))
;
CHPRN(N) ;change process name
;Change process name to N
D SETNM^%ZOSV($E(N,1,15))
Q
;
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2
I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
Q
TIMEOUT ;Do this on MAIN loop timeout
I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
;Sign-on timeout
S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
D SND^XWBRW
Q
;
OS() ;Return the OS
; Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM") //SMH
Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["GT.M":"GT.M",^("OS")["OpenM":"OpenM",1:"MSM")
;
INIT ;Setup
S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
D LOGSTART^XWBDLOG("XWBTCPM")
Q
;
DEBUG ;Entry point for debug, Build a server to get the connect
;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1"
W !,"Before running this entry point set your debugger to stop at"
W !,"the place you want to debug. Some spots to use:"
W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
W !,"or location of your choice.",!
W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^")
;Use %ZISTCP to do a single server
D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
U $P W !,"Done"
Q
SERV ;Callback from the server
S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
D NEW
S IO("C")=1 ;Cause the Listenr to stop
Q
;
EXIT ;Close out
I $G(DUZ) D LOGOUT^XUSRB
I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
Q
;
LOG(MSG) ;Record Debug Info
D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
Q
;