KIDS Distribution saved on Aug 20, 2008@19:39:18 This patch supports the WorldVistA Config Utility GUI **KIDS**:TMG-GUI-CONFIG*1.0*1^ **INSTALL NAME** TMG-GUI-CONFIG*1.0*1 "BLD",5421,0) TMG-GUI-CONFIG*1.0*1^^0^3080820^n "BLD",5421,1,0) ^^12^12^3080820^^ "BLD",5421,1,1,0) This will contain one source file (TMGRPC3.m) and RPC's "BLD",5421,1,2,0) to support the WorldVistA Config Utility (a Windows "BLD",5421,1,3,0) GUI client for performing Fileman tasks. "BLD",5421,1,4,0) "BLD",5421,1,5,0) Note, user will need to have the menu option: "BLD",5421,1,6,0) TMG RPC CONTEXT GUI_CONFIG "BLD",5421,1,7,0) added to their secondary menu to be authorized for use. "BLD",5421,1,8,0) "BLD",5421,1,9,0) Note: This utility will allow an authorized user to perform "BLD",5421,1,10,0) arbitrary Fileman writes, and could potentially cause "BLD",5421,1,11,0) significant problems. So careful consideration should be "BLD",5421,1,12,0) given to determining who can use this GUI utility. "BLD",5421,4,0) ^9.64PA^^0 "BLD",5421,"KRN",0) ^9.67PA^8989.52^19 "BLD",5421,"KRN",.4,0) .4 "BLD",5421,"KRN",.401,0) .401 "BLD",5421,"KRN",.402,0) .402 "BLD",5421,"KRN",.403,0) .403 "BLD",5421,"KRN",.5,0) .5 "BLD",5421,"KRN",.84,0) .84 "BLD",5421,"KRN",3.6,0) 3.6 "BLD",5421,"KRN",3.8,0) 3.8 "BLD",5421,"KRN",9.2,0) 9.2 "BLD",5421,"KRN",9.8,0) 9.8 "BLD",5421,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",5421,"KRN",9.8,"NM",1,0) TMGRPC3^^0^B43913 "BLD",5421,"KRN",9.8,"NM","B","TMGRPC3",1) "BLD",5421,"KRN",19,0) 19 "BLD",5421,"KRN",19,"NM",0) ^9.68A^1^1 "BLD",5421,"KRN",19,"NM",1,0) TMG RPC CONTEXT GUI_CONFIG^^0 "BLD",5421,"KRN",19,"NM","B","TMG RPC CONTEXT GUI_CONFIG",1) "BLD",5421,"KRN",19.1,0) 19.1 "BLD",5421,"KRN",101,0) 101 "BLD",5421,"KRN",409.61,0) 409.61 "BLD",5421,"KRN",771,0) 771 "BLD",5421,"KRN",870,0) 870 "BLD",5421,"KRN",8989.51,0) 8989.51 "BLD",5421,"KRN",8989.52,0) 8989.52 "BLD",5421,"KRN",8994,0) 8994 "BLD",5421,"KRN",8994,"NM",0) ^9.68A^1^1 "BLD",5421,"KRN",8994,"NM",1,0) TMG CHANNEL^^0 "BLD",5421,"KRN",8994,"NM","B","TMG CHANNEL",1) "BLD",5421,"KRN","B",.4,.4) "BLD",5421,"KRN","B",.401,.401) "BLD",5421,"KRN","B",.402,.402) "BLD",5421,"KRN","B",.403,.403) "BLD",5421,"KRN","B",.5,.5) "BLD",5421,"KRN","B",.84,.84) "BLD",5421,"KRN","B",3.6,3.6) "BLD",5421,"KRN","B",3.8,3.8) "BLD",5421,"KRN","B",9.2,9.2) "BLD",5421,"KRN","B",9.8,9.8) "BLD",5421,"KRN","B",19,19) "BLD",5421,"KRN","B",19.1,19.1) "BLD",5421,"KRN","B",101,101) "BLD",5421,"KRN","B",409.61,409.61) "BLD",5421,"KRN","B",771,771) "BLD",5421,"KRN","B",870,870) "BLD",5421,"KRN","B",8989.51,8989.51) "BLD",5421,"KRN","B",8989.52,8989.52) "BLD",5421,"KRN","B",8994,8994) "BLD",5421,"QUES",0) ^9.62^^ "KRN",19,10090,-1) 0^1 "KRN",19,10090,0) TMG RPC CONTEXT GUI_CONFIG^GUIConfig 1.0.0.0^^B^^^^^^^^FP OF GREENEVILLE (TMG) "KRN",19,10090,1,0) ^^2^2^3080720^^ "KRN",19,10090,1,1,0) This will be the context file for GUI_Config "KRN",19,10090,1,2,0) It will hold the list of all allowed RPC calls. "KRN",19,10090,"RPC",0) ^19.05P^1^1 "KRN",19,10090,"RPC",1,0) TMG CHANNEL "KRN",19,10090,"U") GUICONFIG 1.0.0.0 "KRN",8994,1785,-1) 0^1 "KRN",8994,1785,0) TMG CHANNEL^CHANNEL^TMGRPC3^2^^^^1^1 "KRN",8994,1785,1,0) ^8994.01^2^2^3080805^^^ "KRN",8994,1785,1,1,0) This RPC will be used to pass multiple requests back "KRN",8994,1785,1,2,0) and forth from client to server "KRN",8994,1785,2,0) ^8994.02A^1^1 "KRN",8994,1785,2,1,0) INPUT^3^^1^1 "KRN",8994,1785,2,1,1,0) ^8994.021^2^2^3080805^^^ "KRN",8994,1785,2,1,1,1,0) This is the data array sent from client. "KRN",8994,1785,2,1,1,2,0) Format still to be decided. "KRN",8994,1785,2,"B","INPUT",1) "KRN",8994,1785,2,"PARAMSEQ",1,1) "KRN",8994,1785,3,0) ^8994.03^3^3^3080805^^^ "KRN",8994,1785,3,1,0) This is the result array passed from server back to client. "KRN",8994,1785,3,2,0) Format still to be decided. "KRN",8994,1785,3,3,0) See documentation in CHANNEL^TMGRPC3 "MBREQ") 0 "ORD",16,8994) 8994;16;1;;;;;;;RPCDEL^XPDIA1 "ORD",16,8994,0) REMOTE PROCEDURE "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 1 "RTN","TMGRPC3") 0^1^B43913 "RTN","TMGRPC3",1,0) TMGRPC3 ;TMG/kst/RPC Functions for GUI_Config ;07/20/08 "RTN","TMGRPC3",2,0) ;;1.0;TMG-LIB;**1**;07/20/08 "RTN","TMGRPC3",3,0) "RTN","TMGRPC3",4,0) ;"TMG RPC FUNCTIONS for a GUI config program "RTN","TMGRPC3",5,0) "RTN","TMGRPC3",6,0) ;"Kevin Toppenberg MD "RTN","TMGRPC3",7,0) ;"GNU Lesser General Public License (LGPL) applies "RTN","TMGRPC3",8,0) ;"7/20/08 "RTN","TMGRPC3",9,0) "RTN","TMGRPC3",10,0) ;"======================================================================= "RTN","TMGRPC3",11,0) ;" RPC -- Public Functions. "RTN","TMGRPC3",12,0) ;"======================================================================= "RTN","TMGRPC3",13,0) ;"CHANNEL(RESULT,INPUT) -- general purpose channel RPC from a GUI config program "RTN","TMGRPC3",14,0) "RTN","TMGRPC3",15,0) ;"======================================================================= "RTN","TMGRPC3",16,0) ;"PRIVATE API FUNCTIONS "RTN","TMGRPC3",17,0) ;"======================================================================= "RTN","TMGRPC3",18,0) ;"GetUserList(OutArray,param) -- fill list with users on the system. "RTN","TMGRPC3",19,0) ;"GetRecordsList(OutArray,param) -- fill list with records in file on the system "RTN","TMGRPC3",20,0) ;"GetOneUser(OutArray,IEN) -- Get one user's record "RTN","TMGRPC3",21,0) ;"GetOneRecord(OutArray,params) -- get one record in file "RTN","TMGRPC3",22,0) ;"ExtractFields(OutArray,TMGARRAY,Flag) -- convert output from GETS^DIQ into another format "RTN","TMGRPC3",23,0) ;"GetFileSubset(OutArray,params) -- return a subset of entries a file's .01 names "RTN","TMGRPC3",24,0) ;"GetSubRecsList(OutArray,params) -- Get all .01 sub record entries for a subfile "RTN","TMGRPC3",25,0) ;"PostData(OutArray,Data) -- Post Changes to database via Fileman "RTN","TMGRPC3",26,0) ;"QtTermUser(XUDA) -- quietly inactive a given user "RTN","TMGRPC3",27,0) ;"QtReactUser(TMGDA) -- launch quiet reactivation code "RTN","TMGRPC3",28,0) ;"GetEmptyEntry(OutArray,params) -- get stub entries for a file (typically a subfile) "RTN","TMGRPC3",29,0) ;"CloneUser(OutArray,params) -- replicate a record into a new record, including all subrecs. "RTN","TMGRPC3",30,0) ;"CloneRecord(OutArray,params) --- replicate a record into a new record, including all subrecs. "RTN","TMGRPC3",31,0) ;"GetHelpMsg(OutArray,param) -- retrieve the help message for a given field. "RTN","TMGRPC3",32,0) ;"StubNewRecord(File,NewValue,OutArray) -- create a stub entry in the file (200), to be filled in elsewhere "RTN","TMGRPC3",33,0) ;"GetIfWPField(OutArray,params) -- return if filenumber is a WP subfile "RTN","TMGRPC3",34,0) ;"GetWPField(OutArray,params) -- retrieve on word processing (WP) field entry "RTN","TMGRPC3",35,0) ;"PostWPField(OutArray,params,INPUT) -- store a word processing (WP) field entry "RTN","TMGRPC3",36,0) ;"RegPatient(OutArray,params) -- register a new patient into VistA, providing not already been registered. "RTN","TMGRPC3",37,0) ;"SrchPtExact(Array) -- search for a preexisting patient, using an exact search "RTN","TMGRPC3",38,0) ;"GetErrStr(ErrArray) -- convert a standard DIERR array into a string for output "RTN","TMGRPC3",39,0) "RTN","TMGRPC3",40,0) ;"======================================================================= "RTN","TMGRPC3",41,0) ;"======================================================================= "RTN","TMGRPC3",42,0) ;"Dependencies: "RTN","TMGRPC3",43,0) ;" No TMG* dependencies "RTN","TMGRPC3",44,0) "RTN","TMGRPC3",45,0) ;"======================================================================= "RTN","TMGRPC3",46,0) ;"======================================================================= "RTN","TMGRPC3",47,0) "RTN","TMGRPC3",48,0) CHANNEL(RESULT,INPUT) "RTN","TMGRPC3",49,0) ;"Purpose: This will be a general purpose channel RPC from a GUI config program "RTN","TMGRPC3",50,0) ;"Input: RESULT -- this is an OUT parameter, and it is always passed by reference "RTN","TMGRPC3",51,0) ;" INPUT -- this will be array of data sent from the GUI client. Defined below: "RTN","TMGRPC3",52,0) ;" "RTN","TMGRPC3",53,0) ;" INPUT("REQUEST")="cmd^params" Valid values for "cmd" are: "RTN","TMGRPC3",54,0) ;" "GET USER LIST" "RTN","TMGRPC3",55,0) ;" params: or NODISUSER "RTN","TMGRPC3",56,0) ;" "GET RECORDS LIST" -- get list of all .01 fields for file. "RTN","TMGRPC3",57,0) ;" params: FileNumber (e.g. 'GET RECORDS LIST^8989.3') "RTN","TMGRPC3",58,0) ;" "GET ONE USER" "RTN","TMGRPC3",59,0) ;" params: IEN (e.g. 'GET ONE USER^12345') "RTN","TMGRPC3",60,0) ;" "GET ONE RECORD" "RTN","TMGRPC3",61,0) ;" params: FileNum^IENS (e.g. 'GET ONE RECORD^200^73,') "RTN","TMGRPC3",62,0) ;" "GET ONE WP FIELD" "RTN","TMGRPC3",63,0) ;" params: FileNum^Field^IENS^ (e.g. 'GET ONE WP FIELD^200^2^73,') "RTN","TMGRPC3",64,0) ;" "FILE ENTRY SUBSET" "RTN","TMGRPC3",65,0) ;" params: FileNum^ListStartValue^direction^MaxCount(optional, def=44) "RTN","TMGRPC3",66,0) ;" "GET SUB RECS LIST" -- get all .01 sub record entries for a subfile "RTN","TMGRPC3",67,0) ;" params: SubFileNum^ParentIENS "RTN","TMGRPC3",68,0) ;" "POST DATA" "RTN","TMGRPC3",69,0) ;" params: (not used) "RTN","TMGRPC3",70,0) ;" INPUT(0)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue "RTN","TMGRPC3",71,0) ;" INPUT(1)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue "RTN","TMGRPC3",72,0) ;" ... (note: FieldName and oldValue are not used) "RTN","TMGRPC3",73,0) ;" "POST WP FIELD" "RTN","TMGRPC3",74,0) ;" params: FileNum^FieldNum^IENS (e.g. 'POST WP FIELD^200^2^73,') "RTN","TMGRPC3",75,0) ;" WP field itself is stored as follows: "RTN","TMGRPC3",76,0) ;" INPUT(0)=0TH line "RTN","TMGRPC3",77,0) ;" INPUT(1)=1st line "RTN","TMGRPC3",78,0) ;" INPUT(2)=2nd line "RTN","TMGRPC3",79,0) ;" ... "RTN","TMGRPC3",80,0) ;" Note: don't include INPUT("REQUEST") with text. "RTN","TMGRPC3",81,0) ;" "GET EMPTY ENTRY" -- getting stub entries for subfiles typically "RTN","TMGRPC3",82,0) ;" params: file entry (file or subfile number) "RTN","TMGRPC3",83,0) ;" "GET CURRENT USER NAME" -- return name of DUZ (current) user "RTN","TMGRPC3",84,0) ;" (params: not used) "RTN","TMGRPC3",85,0) ;" "CLONE USER" "RTN","TMGRPC3",86,0) ;" params: SourceIENS^New.01Value "RTN","TMGRPC3",87,0) ;" "CLONE RECORD" "RTN","TMGRPC3",88,0) ;" params: FileNum^SourceIENS^New.01Value "RTN","TMGRPC3",89,0) ;" "GET HELP MSG" "RTN","TMGRPC3",90,0) ;" params : FileNum^FieldNum^HelpType "RTN","TMGRPC3",91,0) ;" "IS WP FIELD" "RTN","TMGRPC3",92,0) ;" params: FileNum^FieldNum "RTN","TMGRPC3",93,0) ;" "GET ONE WP FIELD" -- retrieve on word processing (WP) field entry "RTN","TMGRPC3",94,0) ;" param -- FileNum^Field^IENS (e.g. 'GET ONE WP FIELD^200^2^73,') "RTN","TMGRPC3",95,0) ;" "REGISTER PATIENT" "RTN","TMGRPC3",96,0) ;" param -- FieldNum1^FieldValue1^FieldNum2^FieldValue2^FieldNum3^FieldValue3^... "RTN","TMGRPC3",97,0) ;"Output: results of this function should be put into RESULTS array. "RTN","TMGRPC3",98,0) ;" For cmd: "RTN","TMGRPC3",99,0) ;" "GET USER LIST" "RTN","TMGRPC3",100,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",101,0) ;" RESULT(1)=Name^IEN^200^DISUSER DISUSER will be 1 for "Y" or 0 for "N" "RTN","TMGRPC3",102,0) ;" RESULT(2)=Name^IEN^200^DISUSER "RTN","TMGRPC3",103,0) ;" etc ... "RTN","TMGRPC3",104,0) ;" "GET RECORDS LIST" "RTN","TMGRPC3",105,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",106,0) ;" RESULT(1)=.01Value^IEN^FileNum "RTN","TMGRPC3",107,0) ;" RESULT(2)=.01Value^IEN^FileNum "RTN","TMGRPC3",108,0) ;" etc ... "RTN","TMGRPC3",109,0) ;" "GET ONE USER" "RTN","TMGRPC3",110,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",111,0) ;" RESULT(1)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",112,0) ;" RESULT(2)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",113,0) ;" etc ... "RTN","TMGRPC3",114,0) ;" "GET ONE RECORD" "RTN","TMGRPC3",115,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",116,0) ;" RESULT(1)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",117,0) ;" RESULT(2)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",118,0) ;" ... "RTN","TMGRPC3",119,0) ;" "GET ONE WP FIELD" "RTN","TMGRPC3",120,0) ;" RESULT(0): "1^Success" or "-1^Message" "RTN","TMGRPC3",121,0) ;" RESULT(1) will contain Fileman error, if any "RTN","TMGRPC3",122,0) ;" - or to return WP array - "RTN","TMGRPC3",123,0) ;" RESULT(1)=1st line of text "RTN","TMGRPC3",124,0) ;" RESULT(2)=2nd line of text "RTN","TMGRPC3",125,0) ;" etc.. "RTN","TMGRPC3",126,0) ;" "FILE ENTRY SUBSET" "RTN","TMGRPC3",127,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",128,0) ;" RESULT(1)=Value "RTN","TMGRPC3",129,0) ;" RESULT(2)=Value "RTN","TMGRPC3",130,0) ;" etc ... "RTN","TMGRPC3",131,0) ;" "GET SUB RECS LIST" "RTN","TMGRPC3",132,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",133,0) ;" RESULT(1)=IEN^Value "RTN","TMGRPC3",134,0) ;" RESULT(2)=IEN^Value "RTN","TMGRPC3",135,0) ;" ... "RTN","TMGRPC3",136,0) ;" "POST DATA" "RTN","TMGRPC3",137,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",138,0) ;" RESULT(1)=Fileman message (long) (if generated) "RTN","TMGRPC3",139,0) ;" -or (if +1 etc values used)- "RTN","TMGRPC3",140,0) ;" RESULT(1)=+5^1234 <-- results of IEN array returned (+5 converted to record 1234) "RTN","TMGRPC3",141,0) ;" RESULT(2)=+3^2341 <-- results of IEN array returned (+3 converted to record 2341) "RTN","TMGRPC3",142,0) ;" ... "RTN","TMGRPC3",143,0) ;" "GET EMPTY ENTRY" "RTN","TMGRPC3",144,0) ;" RESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",145,0) ;" RESULT(1)=File^^FieldNum^^DDInfo... "RTN","TMGRPC3",146,0) ;" RESULT(2)=File^^FieldNum^^DDInfo... "RTN","TMGRPC3",147,0) ;" etc ... "RTN","TMGRPC3",148,0) ;" "GET CURRENT USER NAME" -- return name of DUZ (current) user "RTN","TMGRPC3",149,0) ;" RESULT(0)="1^Success^UserName" or "-1^Message" "RTN","TMGRPC3",150,0) ;" "CLONE USER" "RTN","TMGRPC3",151,0) ;" RESULT(0)="1^Success^NewIENS" or "-1^Message" "RTN","TMGRPC3",152,0) ;" RESULT(1)=Long Fileman message (if -1 error) "RTN","TMGRPC3",153,0) ;" "CLONE RECORD" "RTN","TMGRPC3",154,0) ;" RESULT(0)="1^Success^NewIENS" or "-1^Message" "RTN","TMGRPC3",155,0) ;" RESULT(1)=Fileman message (long) (if generated) "RTN","TMGRPC3",156,0) ;" "GET HELP MSG" "RTN","TMGRPC3",157,0) ;" RESULT(0)="1^Success^NewIENS" or "-1^Message" "RTN","TMGRPC3",158,0) ;" RESULT(1)=Fileman message (long) (if generated) "RTN","TMGRPC3",159,0) ;" "IS WP FIELD" "RTN","TMGRPC3",160,0) ;" RESULT(0)="1^Success^YES/NO" or "-1^Message" "RTN","TMGRPC3",161,0) ;" "YES" if is a WP subfile, otherwise "NO" "RTN","TMGRPC3",162,0) ;" RESULT(1)=Fileman message (long) (if generated) "RTN","TMGRPC3",163,0) ;" "REGISTER PATIENT" "RTN","TMGRPC3",164,0) ;" RESULT(0)="1^Success^NewIEN" or "-1^Message" "RTN","TMGRPC3",165,0) ;" RESULT(1)=Fileman message (long) (if generated) "RTN","TMGRPC3",166,0) "RTN","TMGRPC3",167,0) ;"Result: none "RTN","TMGRPC3",168,0) "RTN","TMGRPC3",169,0) new command,params "RTN","TMGRPC3",170,0) set command=$$TRIM^XLFSTR($$UP^XLFSTR($piece($get(INPUT("REQUEST")),"^",1))) "RTN","TMGRPC3",171,0) set params=$$UP^XLFSTR($piece($get(INPUT("REQUEST")),"^",2,199)) "RTN","TMGRPC3",172,0) set RESULT(0)="-1^No command requested." ;"default to error state. "RTN","TMGRPC3",173,0) if command="GET USER LIST" do "RTN","TMGRPC3",174,0) . do GetUserList(.RESULT,params) "RTN","TMGRPC3",175,0) if command="GET RECORDS LIST" do "RTN","TMGRPC3",176,0) . do GetRecordsList(.RESULT,params) "RTN","TMGRPC3",177,0) else if command="GET ONE USER" do "RTN","TMGRPC3",178,0) . do GetOneUser(.RESULT,params) "RTN","TMGRPC3",179,0) else if command="GET ONE RECORD" do "RTN","TMGRPC3",180,0) . do GetOneRecord(.RESULT,params) "RTN","TMGRPC3",181,0) else if command="FILE ENTRY SUBSET" do "RTN","TMGRPC3",182,0) . do GetFileSubset(.RESULT,params) "RTN","TMGRPC3",183,0) else if command="GET SUB RECS LIST" do "RTN","TMGRPC3",184,0) . do GetSubRecsList(.RESULT,params) "RTN","TMGRPC3",185,0) else if command="POST DATA" do "RTN","TMGRPC3",186,0) . kill INPUT("REQUEST") "RTN","TMGRPC3",187,0) . do PostData(.RESULT,.INPUT) "RTN","TMGRPC3",188,0) else if command="GET EMPTY ENTRY" do "RTN","TMGRPC3",189,0) . do GetEmptyEntry(.RESULT,params) "RTN","TMGRPC3",190,0) else if command="GET CURRENT USER NAME" do "RTN","TMGRPC3",191,0) . set RESULT(0)="1^Success^"_$piece($get(^VA(200,DUZ,0)),"^",1) "RTN","TMGRPC3",192,0) else if command="CLONE RECORD" do "RTN","TMGRPC3",193,0) . do CloneRecord(.RESULT,params) "RTN","TMGRPC3",194,0) else if command="CLONE USER" do "RTN","TMGRPC3",195,0) . do CloneUser(.RESULT,params) "RTN","TMGRPC3",196,0) else if command="GET HELP MSG" do "RTN","TMGRPC3",197,0) . do GetHelpMsg(.RESULT,params) "RTN","TMGRPC3",198,0) else if command="IS WP FIELD" do "RTN","TMGRPC3",199,0) . do GetIfWPField(.RESULT,params) "RTN","TMGRPC3",200,0) else if command="GET ONE WP FIELD" do "RTN","TMGRPC3",201,0) . do GetWPField(.RESULT,params) "RTN","TMGRPC3",202,0) else if command="POST WP FIELD" do "RTN","TMGRPC3",203,0) . kill INPUT("REQUEST") "RTN","TMGRPC3",204,0) . do PostWPField(.RESULT,params,.INPUT) "RTN","TMGRPC3",205,0) else if command="REGISTER PATIENT" do "RTN","TMGRPC3",206,0) . do RegPatient(.RESULT,params) "RTN","TMGRPC3",207,0) "RTN","TMGRPC3",208,0) "RTN","TMGRPC3",209,0) quit "RTN","TMGRPC3",210,0) "RTN","TMGRPC3",211,0) ;"======================================================================= "RTN","TMGRPC3",212,0) "RTN","TMGRPC3",213,0) GetUserList(OutArray,param) "RTN","TMGRPC3",214,0) ;"Purpose: to fill list with users on the system. "RTN","TMGRPC3",215,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",216,0) ;" param -- either "" or "NODISUSER" if not to return DISUSER=YES users "RTN","TMGRPC3",217,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",218,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",219,0) ;" OutArray(1)=Name^IEN^200^DISUSER DISUSER will be 1 for "Y" or 0 for "N" "RTN","TMGRPC3",220,0) ;" OutArray(2)=Name^IEN^200^DISUSER "RTN","TMGRPC3",221,0) ;"Results: none "RTN","TMGRPC3",222,0) "RTN","TMGRPC3",223,0) new onlyActive set onlyActive=($get(param)="NODISUSER") "RTN","TMGRPC3",224,0) new index set index=1 "RTN","TMGRPC3",225,0) new name set name="" "RTN","TMGRPC3",226,0) for set name=$order(^VA(200,"B",name)) quit:(name="") do "RTN","TMGRPC3",227,0) . new IEN set IEN="" "RTN","TMGRPC3",228,0) . for set IEN=$order(^VA(200,"B",name,IEN)) quit:(+IEN'>0) do "RTN","TMGRPC3",229,0) . . new disUser set disUser=$piece($get(^VA(200,IEN,0)),"^",7) "RTN","TMGRPC3",230,0) . . if onlyActive&disUser quit "RTN","TMGRPC3",231,0) . . new name set name=$piece($get(^VA(200,IEN,0)),"^",1) "RTN","TMGRPC3",232,0) . . set OutArray(index)=name_"^"_IEN_"^200^"_disUser "RTN","TMGRPC3",233,0) . . set index=index+1 "RTN","TMGRPC3",234,0) "RTN","TMGRPC3",235,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",236,0) "RTN","TMGRPC3",237,0) quit "RTN","TMGRPC3",238,0) "RTN","TMGRPC3",239,0) GetRecordsList(OutArray,param) "RTN","TMGRPC3",240,0) ;"Purpose: to fill list with records in file on the system. "RTN","TMGRPC3",241,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",242,0) ;" param -- Filenumber "RTN","TMGRPC3",243,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",244,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",245,0) ;" OutArray(1)=.01Value^IEN^FileNum "RTN","TMGRPC3",246,0) ;" OutArray(2)=.01Value^IEN^FileNum "RTN","TMGRPC3",247,0) ;"Results: none "RTN","TMGRPC3",248,0) "RTN","TMGRPC3",249,0) new index set index=1 "RTN","TMGRPC3",250,0) new name set name="" "RTN","TMGRPC3",251,0) new FileNum set FileNum=+$get(param) "RTN","TMGRPC3",252,0) if FileNum'>0 do goto GRLDone "RTN","TMGRPC3",253,0) . set OutArray(0)="-1^Valid file number not found" "RTN","TMGRPC3",254,0) new ref set ref=$get(^DIC(FileNum,0,"GL")) "RTN","TMGRPC3",255,0) set ref=$$CREF^DILF(ref) "RTN","TMGRPC3",256,0) if ref="" do goto GRLDone "RTN","TMGRPC3",257,0) . set OutArray(0)="-1^Unable to find global reference for file: "_FileNum "RTN","TMGRPC3",258,0) new loc,pce "RTN","TMGRPC3",259,0) set loc=$piece(^DD(FileNum,.01,0),"^",4) "RTN","TMGRPC3",260,0) set pce=$piece(loc,";",2) "RTN","TMGRPC3",261,0) set loc=$piece(loc,";",1) "RTN","TMGRPC3",262,0) for set name=$order(@ref@("B",name)) quit:(name="") do "RTN","TMGRPC3",263,0) . new IEN set IEN="" "RTN","TMGRPC3",264,0) . for set IEN=$order(@ref@("B",name,IEN)) quit:(+IEN'>0) do "RTN","TMGRPC3",265,0) . . new name set name=$piece($get(@ref@(IEN,loc)),"^",pce) "RTN","TMGRPC3",266,0) . . set OutArray(index)=name_"^"_IEN_"^"_FileNum "RTN","TMGRPC3",267,0) . . set index=index+1 "RTN","TMGRPC3",268,0) "RTN","TMGRPC3",269,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",270,0) GRLDone "RTN","TMGRPC3",271,0) quit "RTN","TMGRPC3",272,0) "RTN","TMGRPC3",273,0) GetOneUser(OutArray,IEN) "RTN","TMGRPC3",274,0) ;"Purpose: to get record of one user "RTN","TMGRPC3",275,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",276,0) ;" IEN -- the IEN in file 200 to get "RTN","TMGRPC3",277,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",278,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",279,0) ;" OutArray(1)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",280,0) ;" OutArray(2)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",281,0) ;"Note: the fields to return are decided HERE "RTN","TMGRPC3",282,0) ;"Results: none "RTN","TMGRPC3",283,0) "RTN","TMGRPC3",284,0) new IENS set IENS=+$get(IEN)_"," "RTN","TMGRPC3",285,0) do GetOneRecord(.OutArray,"200^"_IENS) "RTN","TMGRPC3",286,0) quit "RTN","TMGRPC3",287,0) "RTN","TMGRPC3",288,0) "RTN","TMGRPC3",289,0) GetOneRecord(OutArray,params) "RTN","TMGRPC3",290,0) ;"Purpose: to get one record in file "RTN","TMGRPC3",291,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",292,0) ;" params: File^IENS "RTN","TMGRPC3",293,0) ;" File -- the file or subfile to retrieve from "RTN","TMGRPC3",294,0) ;" IENS -- if File is a subfile, then IENS should be full IENS to get (e.g. '2,103,') "RTN","TMGRPC3",295,0) ;" if File is not a subfile, then IENS can be just IEN or IEN_"," "RTN","TMGRPC3",296,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",297,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",298,0) ;" OutArray(1)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",299,0) ;" OutArray(2)=File^IENS^FieldNum^ExternalValue^DDInfo... "RTN","TMGRPC3",300,0) ;"Note: the fields to return are decided HERE "RTN","TMGRPC3",301,0) ;"Results: none "RTN","TMGRPC3",302,0) "RTN","TMGRPC3",303,0) set OutArray(0)="1^Success" ;"default to success "RTN","TMGRPC3",304,0) new TMGARRAY,TMGMSG "RTN","TMGRPC3",305,0) new ref set ref="TMGARRAY" "RTN","TMGRPC3",306,0) set params=$get(params) "RTN","TMGRPC3",307,0) new file set file=$piece(params,"^",1) "RTN","TMGRPC3",308,0) if +file'>0 do goto GORDone "RTN","TMGRPC3",309,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",310,0) new IENS set IENS=$piece(params,"^",2) "RTN","TMGRPC3",311,0) if IENS="" do goto GORDone "RTN","TMGRPC3",312,0) . set OutArray(0)="-1^No IENS supplied" "RTN","TMGRPC3",313,0) "RTN","TMGRPC3",314,0) do GETS^DIQ(file,IENS,"**","IE",ref,"TMGMSG") "RTN","TMGRPC3",315,0) "RTN","TMGRPC3",316,0) if $data(TMGMSG("DIERR")) do goto GORDone "RTN","TMGRPC3",317,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",318,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",319,0) "RTN","TMGRPC3",320,0) do ExtractFields(.OutArray,.TMGARRAY,"E") "RTN","TMGRPC3",321,0) "RTN","TMGRPC3",322,0) GORDone "RTN","TMGRPC3",323,0) quit "RTN","TMGRPC3",324,0) "RTN","TMGRPC3",325,0) "RTN","TMGRPC3",326,0) ExtractFields(OutArray,TMGARRAY,Flag) "RTN","TMGRPC3",327,0) ;"Purpose: convert output from GETS^DIQ into another format "RTN","TMGRPC3",328,0) "RTN","TMGRPC3",329,0) new index set index=1 "RTN","TMGRPC3",330,0) new file,field,IENS "RTN","TMGRPC3",331,0) set file="" "RTN","TMGRPC3",332,0) for set file=$order(TMGARRAY(file)) quit:(file="") do "RTN","TMGRPC3",333,0) . set IENS="" "RTN","TMGRPC3",334,0) . for set IENS=$order(TMGARRAY(file,IENS)) quit:(IENS="") do "RTN","TMGRPC3",335,0) . . set field=0 "RTN","TMGRPC3",336,0) . . for set field=$order(^DD(file,field)) quit:(+field'>0) do "RTN","TMGRPC3",337,0) . . . if $get(TMGARRAY(file,IENS,field,Flag))="" do "RTN","TMGRPC3",338,0) . . . . set TMGARRAY(file,IENS,field,Flag)="" "RTN","TMGRPC3",339,0) . . set field="" "RTN","TMGRPC3",340,0) . . for set field=$order(TMGARRAY(file,IENS,field)) quit:(field="") do "RTN","TMGRPC3",341,0) . . . new Value set Value=$get(TMGARRAY(file,IENS,field,Flag)) "RTN","TMGRPC3",342,0) . . . new DDInfo set DDInfo=$piece($get(^DD(file,field,0)),"^",1,4) "RTN","TMGRPC3",343,0) . . . if $piece(DDInfo,"^",2)["D" do ;"convert data format to one Delphi can use "RTN","TMGRPC3",344,0) . . . . if Flag="I" quit "RTN","TMGRPC3",345,0) . . . . new X set X=$get(TMGARRAY(file,IENS,field,"I")) "RTN","TMGRPC3",346,0) . . . . set Value=$$FMTE^XLFDT(X,5) "RTN","TMGRPC3",347,0) . . . set OutArray(index)=file_"^"_IENS_"^"_field_"^"_Value "RTN","TMGRPC3",348,0) . . . set OutArray(index)=OutArray(index)_"^"_DDInfo "RTN","TMGRPC3",349,0) . . . set index=index+1 "RTN","TMGRPC3",350,0) "RTN","TMGRPC3",351,0) quit "RTN","TMGRPC3",352,0) "RTN","TMGRPC3",353,0) GetFileSubset(OutArray,params) "RTN","TMGRPC3",354,0) ;"Purpose: to return a subset of entries a file's .01 names "RTN","TMGRPC3",355,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",356,0) ;" params -- FileNum^StartFrom^Direction^maxCount "RTN","TMGRPC3",357,0) ;" FileNum - filename file to traverse "RTN","TMGRPC3",358,0) ;" StartFrom -- text to $order() from -- OPTIONAL "RTN","TMGRPC3",359,0) ;" Direction -- $order(xx,Direction) direction (should be 1 or -1) -- OPTIONAL "RTN","TMGRPC3",360,0) ;" maxCt -- OPTIONAL -- the max number of entries to return. "RTN","TMGRPC3",361,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",362,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",363,0) ;" OutArray(1)=IEN^Value "RTN","TMGRPC3",364,0) ;" OutArray(2)=IEN^Value "RTN","TMGRPC3",365,0) ;" ... "RTN","TMGRPC3",366,0) ;"Results: none "RTN","TMGRPC3",367,0) ;"NOTE: does NOT work with sub files. "RTN","TMGRPC3",368,0) "RTN","TMGRPC3",369,0) new File set File=+$piece(params,"^",1) "RTN","TMGRPC3",370,0) if File'>0 do goto GFSDone "RTN","TMGRPC3",371,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",372,0) new From set From=$piece(params,"^",2) "RTN","TMGRPC3",373,0) new dir set dir=$piece(params,"^",3) "RTN","TMGRPC3",374,0) if dir'=-1 set dir=1 "RTN","TMGRPC3",375,0) new maxCt set maxCt=+$piece(params,"^",4) "RTN","TMGRPC3",376,0) if maxCt=0 set maxCt=44 "RTN","TMGRPC3",377,0) "RTN","TMGRPC3",378,0) new i set i=0 "RTN","TMGRPC3",379,0) new last set last="" "RTN","TMGRPC3",380,0) new prev set prev="" "RTN","TMGRPC3",381,0) new ref set ref=$get(^DIC(File,0,"GL")) "RTN","TMGRPC3",382,0) set ref=$$CREF^DILF(ref) ;"convert open --> closed reference "RTN","TMGRPC3",383,0) if ref="" do goto GFSDone "RTN","TMGRPC3",384,0) . set OutArray(0)="-1^Unable to obtain global ref for file #"_File "RTN","TMGRPC3",385,0) "RTN","TMGRPC3",386,0) for set From=$order(@ref@("B",From),dir) quit:(From="")!(i=maxCt) do "RTN","TMGRPC3",387,0) . new IEN set IEN="" "RTN","TMGRPC3",388,0) . for set IEN=$order(@ref@("B",From,IEN),dir) quit:(+IEN'>0) do "RTN","TMGRPC3",389,0) . . set i=i+1 "RTN","TMGRPC3",390,0) . . set OutArray(i)=IEN_"^"_$$GET1^DIQ(File,IEN_",",.01) "RTN","TMGRPC3",391,0) . . ;"set OutArray(i)=$$GET1^DIQ(File,IEN_",",.01) "RTN","TMGRPC3",392,0) "RTN","TMGRPC3",393,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",394,0) GFSDone "RTN","TMGRPC3",395,0) quit "RTN","TMGRPC3",396,0) "RTN","TMGRPC3",397,0) "RTN","TMGRPC3",398,0) GetSubRecsList(OutArray,params) "RTN","TMGRPC3",399,0) ;"Purpose: Get all .01 sub record entries for a subfile "RTN","TMGRPC3",400,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",401,0) ;" params -- SubFileNum^ParentIENS "RTN","TMGRPC3",402,0) ;" SubFileNum - Subfile Number to get list from. "RTN","TMGRPC3",403,0) ;" ParentIENS -- IENS for parent to get list from (e.g. "73," "RTN","TMGRPC3",404,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",405,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",406,0) ;" OutArray(1)=IEN^Value "RTN","TMGRPC3",407,0) ;" OutArray(2)=IEN^Value "RTN","TMGRPC3",408,0) ;" ... "RTN","TMGRPC3",409,0) ;"Results: none "RTN","TMGRPC3",410,0) "RTN","TMGRPC3",411,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",412,0) new subFile set subFile=+$piece(params,"^",1) "RTN","TMGRPC3",413,0) if subFile'>0 do goto GSRLDone "RTN","TMGRPC3",414,0) . set OutArray(0)="-1^No Subfile number supplied" "RTN","TMGRPC3",415,0) new ParentIENS set ParentIENS=$piece(params,"^",2) "RTN","TMGRPC3",416,0) if ParentIENS="" do goto GSRLDone "RTN","TMGRPC3",417,0) . set OutArray(0)="-1^No Parent IENS supplied" "RTN","TMGRPC3",418,0) new IENS set IENS=","_ParentIENS "RTN","TMGRPC3",419,0) "RTN","TMGRPC3",420,0) do LIST^DIC(subFile,IENS,,"PU","*",,,,,,"TMGMSG","TMGERR") "RTN","TMGRPC3",421,0) "RTN","TMGRPC3",422,0) if $data(TMGMSG("DIERR")) do goto GSRLDone "RTN","TMGRPC3",423,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",424,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",425,0) "RTN","TMGRPC3",426,0) new count set count=1 "RTN","TMGRPC3",427,0) new i set i=0 "RTN","TMGRPC3",428,0) for set i=$order(TMGMSG("DILIST",i)) quit:(+i'>0) do "RTN","TMGRPC3",429,0) . new oneEntry set oneEntry=$get(TMGMSG("DILIST",i,0)) "RTN","TMGRPC3",430,0) . if oneEntry="" quit "RTN","TMGRPC3",431,0) . new IEN set IEN=$piece(oneEntry,"^",1) "RTN","TMGRPC3",432,0) . set $piece(oneEntry,"^",1)=IEN_","_ParentIENS "RTN","TMGRPC3",433,0) . set OutArray(count)=oneEntry "RTN","TMGRPC3",434,0) . set count=count+1 "RTN","TMGRPC3",435,0) "RTN","TMGRPC3",436,0) GSRLDone "RTN","TMGRPC3",437,0) quit "RTN","TMGRPC3",438,0) "RTN","TMGRPC3",439,0) "RTN","TMGRPC3",440,0) PostData(OutArray,Data,Flag) "RTN","TMGRPC3",441,0) ;"Post Changes to database via Fileman "RTN","TMGRPC3",442,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",443,0) ;" Data -- Entries to be filed. Format: "RTN","TMGRPC3",444,0) ;" Data(0)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue "RTN","TMGRPC3",445,0) ;" Data(1)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue "RTN","TMGRPC3",446,0) ;" Data(2)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue "RTN","TMGRPC3",447,0) ;" ... "RTN","TMGRPC3",448,0) ;" Note: FieldName, oldValue pieces are not used (optional) "RTN","TMGRPC3",449,0) ;" Flag -- OPTIONAL, "E" is default. Flag passed to FILE^DIE or UPDATE^DIE "RTN","TMGRPC3",450,0) ;" should be "E" or "I" "RTN","TMGRPC3",451,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",452,0) ;" OutArray(0)="1^Success" or "-1^Short Message" "RTN","TMGRPC3",453,0) ;" OutArray(1)=Fileman message (long) "RTN","TMGRPC3",454,0) ;" -or if new records added: "RTN","TMGRPC3",455,0) ;" OutArray(1)=5^1234 <-- results of IEN array returned (+5 converted to record 1234) "RTN","TMGRPC3",456,0) ;" OutArray(2)=3^2341 <-- results of IEN array returned (+3 converted to record 2341) "RTN","TMGRPC3",457,0) ;" ... "RTN","TMGRPC3",458,0) ;"Results: none "RTN","TMGRPC3",459,0) "RTN","TMGRPC3",460,0) new AVC set AVC=0 ;"AVC=AccessVerifyCode. Default to no change. "RTN","TMGRPC3",461,0) new InactUser,ReactUser "RTN","TMGRPC3",462,0) set Flag=$get(Flag,"E") "RTN","TMGRPC3",463,0) new i set i="" "RTN","TMGRPC3",464,0) new TMGFDA,TMGNEWFDA,TMGMSG,TMGIEN,DIC "RTN","TMGRPC3",465,0) new TMGintFDA "RTN","TMGRPC3",466,0) for set i=$order(Data(i)) quit:(i="") do "RTN","TMGRPC3",467,0) . new file,IENS,field,value,oneEntry "RTN","TMGRPC3",468,0) . new internalValue set internalValue=0 "RTN","TMGRPC3",469,0) . new continue set continue=0 "RTN","TMGRPC3",470,0) . set oneEntry=$get(Data(i)) "RTN","TMGRPC3",471,0) . set file=$piece(oneEntry,"^",1) "RTN","TMGRPC3",472,0) . set IENS=$piece(oneEntry,"^",2) "RTN","TMGRPC3",473,0) . set field=$piece(oneEntry,"^",3) "RTN","TMGRPC3",474,0) . set value=$piece(oneEntry,"^",5) "RTN","TMGRPC3",475,0) . if file=200 do "RTN","TMGRPC3",476,0) . . if field=2 do ;"2 = Access Code "RTN","TMGRPC3",477,0) . . . if IENS["+" do quit "RTN","TMGRPC3",478,0) . . . . set continue=1 "RTN","TMGRPC3",479,0) . . . . set OutArray(1)="Can't set Access code when first adding new user. Try again." "RTN","TMGRPC3",480,0) . . . ;"NOTICE: currently this code does NOT force code of certain length etc. "RTN","TMGRPC3",481,0) . . . ;"S Y=$$VCHK(XV2,XUH) Q:Y Y ;check for valid verify code, returns 0 (for OK), or 1^msg "RTN","TMGRPC3",482,0) . . . ;"set value=$$UP^XLFSTR(value) ;"access code must be upper case elh "RTN","TMGRPC3",483,0) . . . set value=$$EN^XUSHSH(value) ;"access code is supposed to be hashed first "RTN","TMGRPC3",484,0) . . . set AVC=1 ;"signal change "RTN","TMGRPC3",485,0) . . . set AVC("DA")=+IENS "RTN","TMGRPC3",486,0) . . . set internalValue=1 "RTN","TMGRPC3",487,0) . . else if field=11 do ;"11 = Verify Code "RTN","TMGRPC3",488,0) . . . if IENS["+" do quit "RTN","TMGRPC3",489,0) . . . . set continue=1 "RTN","TMGRPC3",490,0) . . . . set OutArray(1)="Can't set Verify code when first adding new user. Try again." "RTN","TMGRPC3",491,0) . . . ;"NOTICE: currently this code does NOT force code of certain length etc. "RTN","TMGRPC3",492,0) . . . ;"S Y=$$VCHK(XV2,XUH) Q:Y Y ;check for valid verify code, returns 0 (for OK), or 1^msg "RTN","TMGRPC3",493,0) . . . ;"set value=$$UP^XLFSTR(value) ;"verify code must be upper case elh "RTN","TMGRPC3",494,0) . . . set value=$$EN^XUSHSH(value) ;"verify code is supposed to be hashed first "RTN","TMGRPC3",495,0) . . . set AVC=1 ;"signal change "RTN","TMGRPC3",496,0) . . . set AVC("DA")=+IENS "RTN","TMGRPC3",497,0) . . . set internalValue=1 "RTN","TMGRPC3",498,0) . . else if field=7 do ;"7 = DISUSER Value should be 'YES' or 'NO' "RTN","TMGRPC3",499,0) . . . if IENS["+" do quit "RTN","TMGRPC3",500,0) . . . . set continue=1 "RTN","TMGRPC3",501,0) . . . . set OutArray(1)="Can't set DISUSER code when first adding new user. Try again." "RTN","TMGRPC3",502,0) . . . if value="YES" do "RTN","TMGRPC3",503,0) . . . . set TMGFDA(200,IENS,9.2)="NOW" ;"add 9.2 = termination date "RTN","TMGRPC3",504,0) . . . . set InactUser("DA")=+IENS "RTN","TMGRPC3",505,0) . . . if (value="NO")!(value="@") do "RTN","TMGRPC3",506,0) . . . . set TMGFDA(200,IENS,9.2)="@" ;"delete 9.2 = termination date "RTN","TMGRPC3",507,0) . . . . set TMGFDA(200,IENS,9.4)="@" ;"delete 9.4 = termination reason "RTN","TMGRPC3",508,0) . . . . set ReactUser("DA")=+IENS "RTN","TMGRPC3",509,0) . . else if field=3 do ;"3 = FILE MANAGER ACCESS CODE (i.e. @ etc) "RTN","TMGRPC3",510,0) . . . if value'["^" do "RTN","TMGRPC3",511,0) . . . . set $piece(^VA(200,+IENS,0),"^",4)=value ;"force value in with low-level write "RTN","TMGRPC3",512,0) . . . . set continue=1 "RTN","TMGRPC3",513,0) . if continue quit "RTN","TMGRPC3",514,0) . if IENS["+" do "RTN","TMGRPC3",515,0) . . set TMGNEWFDA(file,IENS,field)=value "RTN","TMGRPC3",516,0) . else do "RTN","TMGRPC3",517,0) . . if internalValue=1 set TMGintFDA(file,IENS,field)=value "RTN","TMGRPC3",518,0) . . else set TMGFDA(file,IENS,field)=value "RTN","TMGRPC3",519,0) "RTN","TMGRPC3",520,0) set OutArray(0)="1^Success" ;"default to success "RTN","TMGRPC3",521,0) if $data(TMGFDA) do "RTN","TMGRPC3",522,0) . do FILE^DIE(Flag_"K","TMGFDA","TMGMSG") "RTN","TMGRPC3",523,0) if $data(TMGMSG("DIERR")) do "RTN","TMGRPC3",524,0) . set OutArray(0)="-1^See Fileman message re posting" "RTN","TMGRPC3",525,0) . set OutArray(1)=$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1)) "RTN","TMGRPC3",526,0) "RTN","TMGRPC3",527,0) if $data(TMGintFDA) do ;"process FDA with INTERNAL values "RTN","TMGRPC3",528,0) . do FILE^DIE("K","TMGintFDA","TMGMSG") "RTN","TMGRPC3",529,0) if $data(TMGMSG("DIERR")) do "RTN","TMGRPC3",530,0) . set OutArray(0)="-1^See Fileman message re posting" "RTN","TMGRPC3",531,0) . set OutArray(1)=$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1)) "RTN","TMGRPC3",532,0) "RTN","TMGRPC3",533,0) if $data(TMGNEWFDA) do "RTN","TMGRPC3",534,0) . do UPDATE^DIE(Flag_"K","TMGNEWFDA","TMGIEN","TMGMSG") "RTN","TMGRPC3",535,0) if $data(TMGMSG("DIERR")) do "RTN","TMGRPC3",536,0) . set OutArray(0)="-1^See Fileman message re posting" "RTN","TMGRPC3",537,0) . set OutArray(1)=$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1)) "RTN","TMGRPC3",538,0) "RTN","TMGRPC3",539,0) if ($piece(OutArray(0),"^",1)=1)&($data(TMGIEN)) do "RTN","TMGRPC3",540,0) . new count set count=1 "RTN","TMGRPC3",541,0) . new i set i="" "RTN","TMGRPC3",542,0) . for set i=$order(TMGIEN(i)) quit:(i="") do "RTN","TMGRPC3",543,0) . . set OutArray(count)=i_"^"_$get(TMGIEN(i)) "RTN","TMGRPC3",544,0) . . set count=count+1 "RTN","TMGRPC3",545,0) "RTN","TMGRPC3",546,0) ;"If Access code / Verify code changed, then finish some follow up business "RTN","TMGRPC3",547,0) ;" as per BRCVC^XUS2<--CVC^XUSRB<--called by RPC 'XUS CVC' "RTN","TMGRPC3",548,0) if AVC do "RTN","TMGRPC3",549,0) . new DA set DA=AVC("DA") "RTN","TMGRPC3",550,0) . do CALL^XUSERP(DA,2) ;"Call for Kernel Create, **Update**, Disuser or Terminate events "RTN","TMGRPC3",551,0) . ;"The above sets Taskman job -->DEQUE^XUSERP--> --> D HL7^ALPBGEN "RTN","TMGRPC3",552,0) "RTN","TMGRPC3",553,0) if $data(InactUser) do ;"Finish up inactivating user with VistA code "RTN","TMGRPC3",554,0) . new result "RTN","TMGRPC3",555,0) . set result=$$QtTermUser(InactUser("DA")) ;"finish termination of user code "RTN","TMGRPC3",556,0) . if +result'=0 do "RTN","TMGRPC3",557,0) . . set OutArray(0)="-1^See Fileman message re terminating user" "RTN","TMGRPC3",558,0) . . set OutArray(1)=OutArray(1)_";"_result "RTN","TMGRPC3",559,0) "RTN","TMGRPC3",560,0) if $data(ReactUser) do ;"finish up reactivating user with VistA code "RTN","TMGRPC3",561,0) . new result "RTN","TMGRPC3",562,0) . set result=$$QtReactUser(ReactUser("DA")) ;"launch quiet reactivation code "RTN","TMGRPC3",563,0) . if +result'=0 do "RTN","TMGRPC3",564,0) . . set OutArray(0)="-1^See Fileman message re reactivating user" "RTN","TMGRPC3",565,0) . . set OutArray(1)=OutArray(1)_";"_result "RTN","TMGRPC3",566,0) "RTN","TMGRPC3",567,0) quit "RTN","TMGRPC3",568,0) "RTN","TMGRPC3",569,0) "RTN","TMGRPC3",570,0) QtTermUser(XUDA) "RTN","TMGRPC3",571,0) ;"Purpose: to quietly inactive a given user "RTN","TMGRPC3",572,0) ;" I traced through menu option XUSERDEACT --> XUSTERM to create below "RTN","TMGRPC3",573,0) ;"Input: XUDA -- the IEN in 200 of user to inactivate "RTN","TMGRPC3",574,0) ;"Note: based on code from XUSTERM "RTN","TMGRPC3",575,0) ;"Results: 0 = OK, or 1^message if error "RTN","TMGRPC3",576,0) "RTN","TMGRPC3",577,0) new result set result=0 "RTN","TMGRPC3",578,0) new TMGFDA,TMGMSG,XUDT,DIC "RTN","TMGRPC3",579,0) set TMGFDA(200,+XUDA_",",9.2)="NOW" "RTN","TMGRPC3",580,0) do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGRPC3",581,0) if $data(TMGMSG("DIERR")) do goto QTUDone "RTN","TMGRPC3",582,0) . set result="1^"_$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1)) "RTN","TMGRPC3",583,0) set XUDT=$P(^VA(200,+XUDA,0),"^",11) ;" field 9.2 termination date "RTN","TMGRPC3",584,0) do GET^XUSTERM ;"load up info about mail, mailboxes, keys ? needed ? "RTN","TMGRPC3",585,0) set ZTDTH=XUDT ;"Task Start time. VA FileMan or $HOROLOG format "RTN","TMGRPC3",586,0) set ZTRTN="DQ1^XUSTERM1" ;"routine to be fired "RTN","TMGRPC3",587,0) set ZTDESC="DEACTIVATE USER" ;"description "RTN","TMGRPC3",588,0) set ZTSAVE("XUDA")="" ;"save variable XUDA for use in task "RTN","TMGRPC3",589,0) set ZTIO="" ;"no IO device needed "RTN","TMGRPC3",590,0) do ^%ZTLOAD ;"que a taskman task "RTN","TMGRPC3",591,0) QTUDone "RTN","TMGRPC3",592,0) quit result "RTN","TMGRPC3",593,0) "RTN","TMGRPC3",594,0) "RTN","TMGRPC3",595,0) QtReactUser(TMGDA) "RTN","TMGRPC3",596,0) ;"Purpose: launch quiet reactivation code "RTN","TMGRPC3",597,0) ;" I traced through menu option XUSERREACT --> REACT^XUSERNEW to create below "RTN","TMGRPC3",598,0) ;"Input: TMGDA -- the IEN in 200 to be reactivated "RTN","TMGRPC3",599,0) ;"Results: 0 if OK, or 1^ErrMsg "RTN","TMGRPC3",600,0) ;"NOTE: when user is deleated through VistA code, the access and verify codes "RTN","TMGRPC3",601,0) ;" are deleted. This function does NOT replace these. "RTN","TMGRPC3",602,0) "RTN","TMGRPC3",603,0) new result set result=0 "RTN","TMGRPC3",604,0) new TMGFDA,TMGMSG,DIC "RTN","TMGRPC3",605,0) set TMGFDA(200,TMGDA_",",9.2)="@" ;"Clear the Termination date "RTN","TMGRPC3",606,0) do FILE^DIE("EK","TMGFDA","TMGMSG") ;"Post data "RTN","TMGRPC3",607,0) if $data(TMGMSG("DIERR")) do goto QRUDone "RTN","TMGRPC3",608,0) . set result="1^"_$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",609,0) "RTN","TMGRPC3",610,0) K XMZ ;" if null, then user can access old mail. "RTN","TMGRPC3",611,0) S Y=TMGDA ;"set user to work on. "RTN","TMGRPC3",612,0) D NEW^XM ;"mailman driver -- create a mailbox for user Y "RTN","TMGRPC3",613,0) "RTN","TMGRPC3",614,0) if +$piece($get(^VA(200,TMGDA,201)),"^",1)'>0 do ;"201;1 = PRIMARY MENU OPTION (#201) "RTN","TMGRPC3",615,0) . set TMGFDA(200,TMGDA_",",201)="EVE" ;"set default primary menu to EVE (high level!) "RTN","TMGRPC3",616,0) . do FILE^DIE("EK","TMGFDA","TMGMSG") "RTN","TMGRPC3",617,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGRPC3",618,0) . . set result="1^"_$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",619,0) if +result>0 goto QRUDone "RTN","TMGRPC3",620,0) "RTN","TMGRPC3",621,0) K XMDT,XMM,XMZ "RTN","TMGRPC3",622,0) D REACT^XQ84(TMGDA) ;"See if this user's menu trees need to be rebuilt "RTN","TMGRPC3",623,0) QRUDone "RTN","TMGRPC3",624,0) Q result "RTN","TMGRPC3",625,0) "RTN","TMGRPC3",626,0) "RTN","TMGRPC3",627,0) GetEmptyEntry(OutArray,params) "RTN","TMGRPC3",628,0) ;"Purpose: to get stub entries for a file (typically a subfile) "RTN","TMGRPC3",629,0) ;" "GET EMPTY ENTRY" -- getting stub entries for subfiles typically "RTN","TMGRPC3",630,0) ;" params: file entry (file or subfile number) "RTN","TMGRPC3",631,0) ;"Input: OutArray --an OUT ARRAY, filled as follows: "RTN","TMGRPC3",632,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",633,0) ;" OutArray(1)=File^^FieldNum^^DDInfo... "RTN","TMGRPC3",634,0) ;" OutArray(2)=File^^FieldNum^^DDInfo... "RTN","TMGRPC3",635,0) ;" Etc ... "RTN","TMGRPC3",636,0) ;" Params: filenumber (typically a subfilenumber) "RTN","TMGRPC3",637,0) ;"Result: None "RTN","TMGRPC3",638,0) "RTN","TMGRPC3",639,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",640,0) new count set count=1 "RTN","TMGRPC3",641,0) new fileNum set fileNum=+$get(params) "RTN","TMGRPC3",642,0) new fieldNum set fieldNum=0 "RTN","TMGRPC3",643,0) for set fieldNum=$order(^DD(fileNum,fieldNum)) quit:(+fieldNum'>0) do "RTN","TMGRPC3",644,0) . new DDInfo set DDInfo=$piece($get(^DD(fileNum,fieldNum,0)),"^",1,4) "RTN","TMGRPC3",645,0) . set OutArray(count)=fileNum_"^^"_fieldNum_"^^"_DDInfo "RTN","TMGRPC3",646,0) . set count=count+1 "RTN","TMGRPC3",647,0) "RTN","TMGRPC3",648,0) quit "RTN","TMGRPC3",649,0) "RTN","TMGRPC3",650,0) "RTN","TMGRPC3",651,0) CloneUser(OutArray,params) "RTN","TMGRPC3",652,0) ;"Purpose: to replicate a record into a new record, including all subrecs. "RTN","TMGRPC3",653,0) ;" Implementation of "CLONE RECORD" request "RTN","TMGRPC3",654,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",655,0) ;" params -- SourceIENS^New.01Value "RTN","TMGRPC3",656,0) ;" FileNum - filename file that is to be worked in "RTN","TMGRPC3",657,0) ;" SourceIENS -- source IENS for new record, (i.e. '123,' not '123') "RTN","TMGRPC3",658,0) ;" New.01Value -- new value to be put into the .01 field (to distinguish it from the old record) "RTN","TMGRPC3",659,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",660,0) ;" OutArray(0)="1^Success^NewIENS" or "-1^Message" "RTN","TMGRPC3",661,0) ;" OutArray(1)=Long Fileman message (if -1 error) "RTN","TMGRPC3",662,0) "RTN","TMGRPC3",663,0) set params="200^"_params "RTN","TMGRPC3",664,0) do CloneRecord(.OutArray,params) "RTN","TMGRPC3",665,0) new TMGFDA,TMGMSG "RTN","TMGRPC3",666,0) if +OutArray(0)'=1 goto CUDone "RTN","TMGRPC3",667,0) new newIEN,newIENS "RTN","TMGRPC3",668,0) set newIEN=+$piece(OutArray(0),"^",3) "RTN","TMGRPC3",669,0) if newIEN="" do goto CUDone "RTN","TMGRPC3",670,0) . set OutArray(0)="-1^Can't find IEN of added record" "RTN","TMGRPC3",671,0) "RTN","TMGRPC3",672,0) ;"Set new user to inactive (needs editing before it is active) "RTN","TMGRPC3",673,0) new data "RTN","TMGRPC3",674,0) set data(0)="200^"_newIEN_",^7^^YES" "RTN","TMGRPC3",675,0) do PostData(.OutArray,.data,"E") "RTN","TMGRPC3",676,0) if +OutArray(0)=1 set $piece(OutArray(0),"^",3)=newIEN "RTN","TMGRPC3",677,0) "RTN","TMGRPC3",678,0) CUDone "RTN","TMGRPC3",679,0) quit "RTN","TMGRPC3",680,0) "RTN","TMGRPC3",681,0) CloneRecord(OutArray,params) "RTN","TMGRPC3",682,0) ;"Purpose: to replicate a record into a new record, including all subrecs. "RTN","TMGRPC3",683,0) ;" Implementation of "CLONE RECORD" request "RTN","TMGRPC3",684,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",685,0) ;" params -- FileNum^SourceIENS^New.01Value "RTN","TMGRPC3",686,0) ;" FileNum - filename file that is to be worked in "RTN","TMGRPC3",687,0) ;" SourceIENS -- the source IENS for the new record, (i.e. 123, not 123) "RTN","TMGRPC3",688,0) ;" New.01Value -- the new value to be put into the .01 field (to distinguish it from the old record) "RTN","TMGRPC3",689,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",690,0) ;" OutArray(0)="1^Success^NewIENS" or "-1^Message" "RTN","TMGRPC3",691,0) ;" OutArray(1)=Long Fileman message (if -1 error) "RTN","TMGRPC3",692,0) ;"NOTE: This hasn't been tested on subfiles yet... "RTN","TMGRPC3",693,0) "RTN","TMGRPC3",694,0) new File,IENS,new01Value "RTN","TMGRPC3",695,0) set OutArray(0)="-1^Error" ;"default to error "RTN","TMGRPC3",696,0) "RTN","TMGRPC3",697,0) set File=+$piece(params,"^",1) "RTN","TMGRPC3",698,0) if File'>0 do goto CRDone "RTN","TMGRPC3",699,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",700,0) set IENS=$piece(params,"^",2) "RTN","TMGRPC3",701,0) if IENS="" do goto CRDone "RTN","TMGRPC3",702,0) . set OutArray(0)="-1^IENS supplied" "RTN","TMGRPC3",703,0) if +IENS=IENS do "RTN","TMGRPC3",704,0) . if IENS'["," set IENS=IENS_"," "RTN","TMGRPC3",705,0) set new01Value=$piece(params,"^",3) "RTN","TMGRPC3",706,0) if new01Value="" do goto CRDone "RTN","TMGRPC3",707,0) . set OutArray(0)="-1^No new value supplied for .01 value" "RTN","TMGRPC3",708,0) "RTN","TMGRPC3",709,0) new oldRec,TMGARRAY,TMGMSG,TMGTEMP "RTN","TMGRPC3",710,0) new ref set ref="TMGARRAY" "RTN","TMGRPC3",711,0) "RTN","TMGRPC3",712,0) do StubNewRecord(File,new01Value,.OutArray) "RTN","TMGRPC3",713,0) if +OutArray(0)'=1 do goto CRDone "RTN","TMGRPC3",714,0) . set $piece(OutArray(0),"^",2)="Unable to stub in new record. "_$piece(OutArray(0),"^",2) "RTN","TMGRPC3",715,0) new newIEN set newIEN=$piece(OutArray(0),"^",3) "RTN","TMGRPC3",716,0) ;"Write "The IENS of the new record is: ",newIEN,! ;"TEMP!!! "RTN","TMGRPC3",717,0) "RTN","TMGRPC3",718,0) ;"Note: Using a "X" flag is VERY slow, because it reindexes "RTN","TMGRPC3",719,0) ;" ALL XREFS for ALL entries in file (e.g. 60 seconds) "RTN","TMGRPC3",720,0) ;"do TRNMRG^TMGDIT("M",File,File,IENS,newIEN_",") ;"do actual record copy. "RTN","TMGRPC3",721,0) do TRNMRG^DIT("M",File,File,IENS,newIEN_",") ;"do actual record copy. "RTN","TMGRPC3",722,0) new DA,DIK "RTN","TMGRPC3",723,0) set DIK=$get(^DIC(File,0,"GL")) "RTN","TMGRPC3",724,0) set DA=newIEN "RTN","TMGRPC3",725,0) if (+DA>0)&(DIK'="") do IX1^DIK ;"index just the new record "RTN","TMGRPC3",726,0) "RTN","TMGRPC3",727,0) ;"OK if we got this far (can't check error from TRNMRG) "RTN","TMGRPC3",728,0) set OutArray(0)="1^Success^"_newIEN "RTN","TMGRPC3",729,0) "RTN","TMGRPC3",730,0) CRDone quit "RTN","TMGRPC3",731,0) "RTN","TMGRPC3",732,0) "RTN","TMGRPC3",733,0) GetHelpMsg(OutArray,param) "RTN","TMGRPC3",734,0) ;"Purpose: to retrieve the help message for a given field. "RTN","TMGRPC3",735,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",736,0) ;" param -- file^field^HelpType "RTN","TMGRPC3",737,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",738,0) ;" OutArray(0)="1^Success" or "-1^Message" "RTN","TMGRPC3",739,0) ;" OutArray(1...?)=Help Message "RTN","TMGRPC3",740,0) "RTN","TMGRPC3",741,0) new TMGMSG "RTN","TMGRPC3",742,0) new index set index=1 "RTN","TMGRPC3",743,0) new File set File=+$piece(params,"^",1) "RTN","TMGRPC3",744,0) new Field set Field=+$piece(params,"^",2) "RTN","TMGRPC3",745,0) new HelpType set HelpType=$piece(params,"^",3) "RTN","TMGRPC3",746,0) if File'>0 do goto GHMDone "RTN","TMGRPC3",747,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",748,0) if Field'>0 do goto GHMDone "RTN","TMGRPC3",749,0) . set OutArray(0)="-1^No Field Number supplied" "RTN","TMGRPC3",750,0) do HELP^DIE(File,,Field,HelpType,"TMGMSG") "RTN","TMGRPC3",751,0) set i="" "RTN","TMGRPC3",752,0) for set i=$order(TMGMSG("DIHELP",i)) quit:(i="") do "RTN","TMGRPC3",753,0) . set OutArray(index)=TMGMSG("DIHELP",i) "RTN","TMGRPC3",754,0) . set index=index+1 "RTN","TMGRPC3",755,0) "RTN","TMGRPC3",756,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",757,0) "RTN","TMGRPC3",758,0) GHMDone "RTN","TMGRPC3",759,0) quit "RTN","TMGRPC3",760,0) "RTN","TMGRPC3",761,0) "RTN","TMGRPC3",762,0) StubNewRecord(File,NewValue,OutArray) "RTN","TMGRPC3",763,0) ;"Purpose: to create a stub entry in the file (200), to be filled in elsewhere "RTN","TMGRPC3",764,0) ;"Input: NewValue -- a value for the .01 field "RTN","TMGRPC3",765,0) ;" OutArray -- PASS BY REFERENCE, an OUT PARAMETER. "RTN","TMGRPC3",766,0) ;"Output: A new record will be added to file, if no errors "RTN","TMGRPC3",767,0) ;" OutArray(0): 1^Success^NewIEN or -1^See Fileman message "RTN","TMGRPC3",768,0) ;" OutArray(1) will contain Fileman error, if any "RTN","TMGRPC3",769,0) ;"Results: none "RTN","TMGRPC3",770,0) ;"NOTICE: This function makes no promise that the creation of the "RTN","TMGRPC3",771,0) ;" new record will succeed. For example, if there are required "RTN","TMGRPC3",772,0) ;" fields, the creation will fail. So users should check for success "RTN","TMGRPC3",773,0) ;" result and error feedback. "RTN","TMGRPC3",774,0) ;"Results: none "RTN","TMGRPC3",775,0) "RTN","TMGRPC3",776,0) new TMGFDA,TMGIEN,TMGMSG,DIC "RTN","TMGRPC3",777,0) set DIC(0)="" ;"I get a crash without this, for some reason... "RTN","TMGRPC3",778,0) set TMGFDA(File,"+1,",.01)=NewValue "RTN","TMGRPC3",779,0) do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGRPC3",780,0) "RTN","TMGRPC3",781,0) if $data(TMGMSG("DIERR")) do goto SNPDone "RTN","TMGRPC3",782,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",783,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",784,0) "RTN","TMGRPC3",785,0) set OutArray(0)="1^Success^"_$get(TMGIEN(1)) "RTN","TMGRPC3",786,0) "RTN","TMGRPC3",787,0) SNPDone "RTN","TMGRPC3",788,0) quit "RTN","TMGRPC3",789,0) "RTN","TMGRPC3",790,0) "RTN","TMGRPC3",791,0) GetIfWPField(OutArray,params) "RTN","TMGRPC3",792,0) ;"Purpose: to return if filenumber is a WP subfile "RTN","TMGRPC3",793,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",794,0) ;" param -- file^field "RTN","TMGRPC3",795,0) ;"Output: "RTN","TMGRPC3",796,0) ;" OutArray(0): "1^Success^YES/NO" or "-1^Message" "RTN","TMGRPC3",797,0) ;" "YES" if is a WP subfile, otherwise "NO" "RTN","TMGRPC3",798,0) ;" OutArray(1) will contain Fileman error, if any "RTN","TMGRPC3",799,0) ;"Results: none "RTN","TMGRPC3",800,0) "RTN","TMGRPC3",801,0) new result "RTN","TMGRPC3",802,0) new File set File=+$piece(params,"^",1) "RTN","TMGRPC3",803,0) new Field set Field=+$piece(params,"^",2) "RTN","TMGRPC3",804,0) if File'>0 do goto GWPSDone "RTN","TMGRPC3",805,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",806,0) if Field'>0 do goto GWPSDone "RTN","TMGRPC3",807,0) . set OutArray(0)="-1^No Field Number supplied" "RTN","TMGRPC3",808,0) "RTN","TMGRPC3",809,0) do FIELD^DID(File,Field,"","TYPE","TMGARRAY","TMGMSG") "RTN","TMGRPC3",810,0) "RTN","TMGRPC3",811,0) if $data(TMGMSG("DIERR")) do goto GWPSDone "RTN","TMGRPC3",812,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",813,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",814,0) "RTN","TMGRPC3",815,0) if $get(TMGARRAY("TYPE"))="WORD-PROCESSING" do "RTN","TMGRPC3",816,0) . set result="YES" "RTN","TMGRPC3",817,0) else do "RTN","TMGRPC3",818,0) . set result="NO" "RTN","TMGRPC3",819,0) "RTN","TMGRPC3",820,0) set OutArray(0)="1^Success^"_result "RTN","TMGRPC3",821,0) "RTN","TMGRPC3",822,0) GWPSDone "RTN","TMGRPC3",823,0) quit "RTN","TMGRPC3",824,0) "RTN","TMGRPC3",825,0) "RTN","TMGRPC3",826,0) GetWPField(OutArray,params) "RTN","TMGRPC3",827,0) ;"Purpose: To retrieve on word processing (WP) field entry "RTN","TMGRPC3",828,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",829,0) ;" param -- FileNum^Field^IENS (e.g. 'GET ONE WP FIELD^200^73,') "RTN","TMGRPC3",830,0) ;"Output: "RTN","TMGRPC3",831,0) ;" OutArray(0): "1^Success" or "-1^Message" "RTN","TMGRPC3",832,0) ;" OutArray(1) will contain Fileman error, if any "RTN","TMGRPC3",833,0) ;" - or to return WP array - "RTN","TMGRPC3",834,0) ;" OutArray(1)=1st line of text "RTN","TMGRPC3",835,0) ;" OutArray(2)=2nd line of text "RTN","TMGRPC3",836,0) ;" etc.. "RTN","TMGRPC3",837,0) ;"Results: None "RTN","TMGRPC3",838,0) "RTN","TMGRPC3",839,0) new File set File=+$piece(params,"^",1) "RTN","TMGRPC3",840,0) new Field set Field=+$piece(params,"^",2) "RTN","TMGRPC3",841,0) new IENS set IENS=+$piece(params,"^",3) "RTN","TMGRPC3",842,0) if File'>0 do goto GWPDone "RTN","TMGRPC3",843,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",844,0) if Field'>0 do goto GWPDone "RTN","TMGRPC3",845,0) . set OutArray(0)="-1^No Field Number supplied" "RTN","TMGRPC3",846,0) if IENS="" do goto GWPDone "RTN","TMGRPC3",847,0) . set OutArray(0)="-1^No IENS supplied" "RTN","TMGRPC3",848,0) "RTN","TMGRPC3",849,0) new temp "RTN","TMGRPC3",850,0) set temp=$$GET1^DIQ(File,IENS,Field,"","TMGARRAY","TMGMSG") "RTN","TMGRPC3",851,0) if $data(TMGMSG("DIERR")) do goto GWPDone "RTN","TMGRPC3",852,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",853,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",854,0) "RTN","TMGRPC3",855,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",856,0) new index,i "RTN","TMGRPC3",857,0) set i=0 "RTN","TMGRPC3",858,0) set index=1 "RTN","TMGRPC3",859,0) for set i=$order(TMGARRAY(i)) quit:(i="") do "RTN","TMGRPC3",860,0) . set OutArray(index)=TMGARRAY(i) "RTN","TMGRPC3",861,0) . set index=index+1 "RTN","TMGRPC3",862,0) "RTN","TMGRPC3",863,0) GWPDone "RTN","TMGRPC3",864,0) quit "RTN","TMGRPC3",865,0) "RTN","TMGRPC3",866,0) "RTN","TMGRPC3",867,0) PostWPField(OutArray,params,INPUT) "RTN","TMGRPC3",868,0) ;"Purpose: To store a word processing (WP) field entry "RTN","TMGRPC3",869,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",870,0) ;" param -- FileNum^FieldNum^IENS (e.g. 'GET ONE WP FIELD^200^73,') "RTN","TMGRPC3",871,0) ;" INPUT -- holds the WP itself to be stored: "RTN","TMGRPC3",872,0) ;" INPUT(0)=0TH line "RTN","TMGRPC3",873,0) ;" INPUT(1)=1st line "RTN","TMGRPC3",874,0) ;" INPUT(2)=2nd line "RTN","TMGRPC3",875,0) ;" ... "RTN","TMGRPC3",876,0) ;"Output: "RTN","TMGRPC3",877,0) ;" OutArray(0): "1^Success" or "-1^Message" "RTN","TMGRPC3",878,0) ;" OutArray(1) will contain Fileman error, if any "RTN","TMGRPC3",879,0) ;"Results: None "RTN","TMGRPC3",880,0) "RTN","TMGRPC3",881,0) new File set File=+$piece(params,"^",1) "RTN","TMGRPC3",882,0) new Field set Field=+$piece(params,"^",2) "RTN","TMGRPC3",883,0) new IENS set IENS=+$piece(params,"^",3) "RTN","TMGRPC3",884,0) if File'>0 do goto PWPDone "RTN","TMGRPC3",885,0) . set OutArray(0)="-1^No file number supplied" "RTN","TMGRPC3",886,0) if Field'>0 do goto PWPDone "RTN","TMGRPC3",887,0) . set OutArray(0)="-1^No Field Number supplied" "RTN","TMGRPC3",888,0) if IENS="" do goto PWPDone "RTN","TMGRPC3",889,0) . set OutArray(0)="-1^No IENS supplied" "RTN","TMGRPC3",890,0) if $length(IENS,",")=1 set IENS=IENS_"," "RTN","TMGRPC3",891,0) "RTN","TMGRPC3",892,0) do WP^DIE(File,IENS,Field,"K","INPUT","TMGMSG") "RTN","TMGRPC3",893,0) "RTN","TMGRPC3",894,0) if $data(TMGMSG("DIERR")) do goto GWPDone "RTN","TMGRPC3",895,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",896,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",897,0) "RTN","TMGRPC3",898,0) set OutArray(0)="1^Success" "RTN","TMGRPC3",899,0) "RTN","TMGRPC3",900,0) PWPDone "RTN","TMGRPC3",901,0) quit "RTN","TMGRPC3",902,0) "RTN","TMGRPC3",903,0) "RTN","TMGRPC3",904,0) RegPatient(OutArray,params) "RTN","TMGRPC3",905,0) ;"Purpose: to register a new patient into VistA, providing that they have not "RTN","TMGRPC3",906,0) ;" already been registered. "RTN","TMGRPC3",907,0) ;"Note: The search for preexisting records is exact, meaning that DOE,JOHN "RTN","TMGRPC3",908,0) ;" would be considered different from DOE,JOHN H "RTN","TMGRPC3",909,0) ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE. "RTN","TMGRPC3",910,0) ;" param -- FieldNum1^FieldValue1^FieldNum2^FieldValue2^FieldNum3^FieldValue3^... "RTN","TMGRPC3",911,0) ;" NOTE: Because I want to be able to specify here the HealthRecordNumber (HRN), "RTN","TMGRPC3",912,0) ;" even though it is not truly a field in the PATIENT file, I am going "RTN","TMGRPC3",913,0) ;" to manually allow a field of '0' (HRN) to be specified as a FieldNumber "RTN","TMGRPC3",914,0) ;"Output: OutArray is filled as follows: "RTN","TMGRPC3",915,0) ;" OutArray(0)="1^Success^NewIEN" or "-1^Message" "RTN","TMGRPC3",916,0) ;" OutArray(1)=Long Fileman message (if -1 error) "RTN","TMGRPC3",917,0) "RTN","TMGRPC3",918,0) new array "RTN","TMGRPC3",919,0) for do quit:($length(params,"^"))<2 "RTN","TMGRPC3",920,0) . new pair,field,value "RTN","TMGRPC3",921,0) . set pair=$piece(params,"^",1,2) "RTN","TMGRPC3",922,0) . set field=$piece(pair,"^",1) "RTN","TMGRPC3",923,0) . set value=$piece(pair,"^",2) "RTN","TMGRPC3",924,0) . set params=$extract(params,$length(pair)+2,999) "RTN","TMGRPC3",925,0) . if (field="")!(value="") quit "RTN","TMGRPC3",926,0) . set array(field)=value "RTN","TMGRPC3",927,0) "RTN","TMGRPC3",928,0) new IEN set IEN=$$SrchPtExact(.array) "RTN","TMGRPC3",929,0) if +IEN>0 do goto RPtDone "RTN","TMGRPC3",930,0) . set OutArray(0)="-1^Patient already registered^"_IEN "RTN","TMGRPC3",931,0) "RTN","TMGRPC3",932,0) new TMGFDA,TMGMSG,TMGIEN "RTN","TMGRPC3",933,0) if $get(array(.01))="" do goto RPtDone "RTN","TMGRPC3",934,0) . set OutArray(0)="-1^Patient name (.01 field) missing" "RTN","TMGRPC3",935,0) set TMGFDA(2,"+1,",.01)=array(.01) "RTN","TMGRPC3",936,0) if $get(array(.02))="" do goto RPtDone "RTN","TMGRPC3",937,0) . set OutArray(0)="-1^Patient sex (.02 field) missing" "RTN","TMGRPC3",938,0) set TMGFDA(2,"+1,",.02)=array(.02) "RTN","TMGRPC3",939,0) if $get(array(.03))="" do goto RPtDone "RTN","TMGRPC3",940,0) . set OutArray(0)="-1^Patient DOB (.03 field) missing" "RTN","TMGRPC3",941,0) set TMGFDA(2,"+1,",.03)=array(.03) "RTN","TMGRPC3",942,0) if $get(array(.09))'="" do ;"let fileman decide if field is required "RTN","TMGRPC3",943,0) . set TMGFDA(2,"+1,",.09)=array(.09) "RTN","TMGRPC3",944,0) "RTN","TMGRPC3",945,0) ;"Create basic record first, then add other fields on subsequent post "RTN","TMGRPC3",946,0) ;"(I think I have had problems trying to load some fields when the "RTN","TMGRPC3",947,0) ;" record has not already been created.) "RTN","TMGRPC3",948,0) do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGRPC3",949,0) if $data(TMGMSG("DIERR")) do goto RPtDone "RTN","TMGRPC3",950,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",951,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",952,0) "RTN","TMGRPC3",953,0) set IEN=$get(TMGIEN(1)) "RTN","TMGRPC3",954,0) if IEN'>0 do goto RPtDone "RTN","TMGRPC3",955,0) . set OutArray(0)="-1^Unable to find IEN of added record" "RTN","TMGRPC3",956,0) "RTN","TMGRPC3",957,0) new field set field="" "RTN","TMGRPC3",958,0) kill TMGFDA,TMGIEN,TMGMSG "RTN","TMGRPC3",959,0) for set field=$order(array(field)) quit:(field="") do "RTN","TMGRPC3",960,0) . if (field=".01")!(field=".02")!(field=".03")!(field=".09")!(field="0") quit "RTN","TMGRPC3",961,0) . new value set value=$get(array(field)) "RTN","TMGRPC3",962,0) . if value="" quit "RTN","TMGRPC3",963,0) . set TMGFDA(2,IEN_",",field)=value "RTN","TMGRPC3",964,0) "RTN","TMGRPC3",965,0) if $data(TMGFDA) do "RTN","TMGRPC3",966,0) . do FILE^DIE("E","TMGFDA","TMGMSG") "RTN","TMGRPC3",967,0) if $data(TMGMSG("DIERR")) do goto RPtDone "RTN","TMGRPC3",968,0) . set OutArray(0)="-1^See Fileman message" "RTN","TMGRPC3",969,0) . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",970,0) "RTN","TMGRPC3",971,0) set OutArray(0)="1^Success^"_IEN "RTN","TMGRPC3",972,0) "RTN","TMGRPC3",973,0) new HRN set HRN=$get(array("0"))="" ;" pseudoField '0' from client will hold HRN "RTN","TMGRPC3",974,0) if HRN="" goto RPtDone "RTN","TMGRPC3",975,0) ;"Set HRN field in file 9000001 (^AUPNPAT), linked to Patient entry "RTN","TMGRPC3",976,0) "RTN","TMGRPC3",977,0) new LocIEN,InstIEN "RTN","TMGRPC3",978,0) ;"Get DEFAULT INSTITUTION from KERNEL SYSTEM PARAMETERS. "RTN","TMGRPC3",979,0) set InstIEN=$piece($get(^XTV(8989.3,1,"XUS")),17) ;" XUS;17 = DEFAULT INSTITUTION "RTN","TMGRPC3",980,0) if +InstIEN'>0 do goto RPtDone "RTN","TMGRPC3",981,0) . set OutArray(0)="1^Success (but see message)^"_IEN "RTN","TMGRPC3",982,0) . set OutArray(1)="Unable to add HRN because couldn't find value for DEFAULT INSTITUTION in KERNEL SYSTEM PARAMETERS file." "RTN","TMGRPC3",983,0) "RTN","TMGRPC3",984,0) ;"Get LOCATION file entry pointing to this INSTITUTION "RTN","TMGRPC3",985,0) set LocIEN=$order(^AUTTLOC("B",InstIEN,"")) "RTN","TMGRPC3",986,0) if +LocIEN'>0 do goto RPtDone "RTN","TMGRPC3",987,0) . set OutArray(0)="1^Success (but see message)^"_IEN "RTN","TMGRPC3",988,0) . set OutArray(1)="Unable to add HRN because couldn't find `"_InstIEN_" in LOCATION file" "RTN","TMGRPC3",989,0) "RTN","TMGRPC3",990,0) new HRNIEN set HRNIEN=+$order(^AUNPNPAT("B",IEN,"")) "RTN","TMGRPC3",991,0) if HRNIEN'>0 do goto RPtDone "RTN","TMGRPC3",992,0) . set OutArray(0)="1^Success (but see message)^"_IEN "RTN","TMGRPC3",993,0) . set OutArray(1)="Unable to add HRN because couldn't find record in PATIENT/IHS file" "RTN","TMGRPC3",994,0) "RTN","TMGRPC3",995,0) kill TMGFDA,TMGMSG,TMGIEN "RTN","TMGRPC3",996,0) ;"Now see if there already is an entry for LocIEN (DINUM in play, so subFile record#=LocIEN) "RTN","TMGRPC3",997,0) if $get(^AUPNPAT(HRNIEN,41,LocIEN,0))="" do "RTN","TMGRPC3",998,0) . ;"Put HRN into value for current subfile entry "RTN","TMGRPC3",999,0) . set TMGFDA(9000001.41,LocIEN_","_HRNIEN_",",.02)=HRN "RTN","TMGRPC3",1000,0) . do FILE^DIE("","TMGFDA","TMGMSG") "RTN","TMGRPC3",1001,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGRPC3",1002,0) . . set OutArray(0)="1^Success (but see message)^"_IEN "RTN","TMGRPC3",1003,0) . . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",1004,0) else do "RTN","TMGRPC3",1005,0) . ;"Add new subfile entry for HRN "RTN","TMGRPC3",1006,0) . set TMGFDA(9000001.41,LocIEN_","_HRNIEN_",",.01)=LocIEN "RTN","TMGRPC3",1007,0) . set TMGFDA(9000001.41,LocIEN_","_HRNIEN_",",.02)=HRN "RTN","TMGRPC3",1008,0) . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") "RTN","TMGRPC3",1009,0) . if $data(TMGMSG("DIERR")) do "RTN","TMGRPC3",1010,0) . . set OutArray(0)="1^Success (but see message)^"_IEN "RTN","TMGRPC3",1011,0) . . set OutArray(1)=$$GetErrStr(.TMGMSG) "RTN","TMGRPC3",1012,0) "RTN","TMGRPC3",1013,0) RPtDone "RTN","TMGRPC3",1014,0) quit "RTN","TMGRPC3",1015,0) "RTN","TMGRPC3",1016,0) SrchPtExact(Array) "RTN","TMGRPC3",1017,0) ;"Purpose: to search for a preexisting patient, using an exact search "RTN","TMGRPC3",1018,0) ;" By exact search, I mean that DOE,JOHN would be considered different "RTN","TMGRPC3",1019,0) ;" from DOE,JOHN H because it is a different ascii string. Etc. "RTN","TMGRPC3",1020,0) ;" However, see search description below. "RTN","TMGRPC3",1021,0) ;"Input: Array -- PASS BY REFERENCE. Search info. Format: "RTN","TMGRPC3",1022,0) ;" Array(.01)=PatientName, e.g. DOE,JOHN "RTN","TMGRPC3",1023,0) ;" Array(.02)=Sex e.g. M "RTN","TMGRPC3",1024,0) ;" Array(.03)=DOB e.g. 01-04-69 (an external date format) "RTN","TMGRPC3",1025,0) ;" Array(.09)=SSNum e.g. 123-45-6789 "RTN","TMGRPC3",1026,0) ;"Result: returns DFN (patient IEN), or 0^Message if not found. "RTN","TMGRPC3",1027,0) ;"Notes: "RTN","TMGRPC3",1028,0) ;" The following are sufficient for search: "RTN","TMGRPC3",1029,0) ;" -- SSNum only "RTN","TMGRPC3",1030,0) ;" -- or Name-Sex-DOB "RTN","TMGRPC3",1031,0) "RTN","TMGRPC3",1032,0) ;" Search technique: "RTN","TMGRPC3",1033,0) ;" 1. Search for SSN, if found then no further comparison made. "RTN","TMGRPC3",1034,0) ;" 2. Search for exact name match, no none found, then exit with 0 "RTN","TMGRPC3",1035,0) ;" 3. ... "RTN","TMGRPC3",1036,0) "RTN","TMGRPC3",1037,0) new result set result=0 "RTN","TMGRPC3",1038,0) "RTN","TMGRPC3",1039,0) ;"Search by SSN. Quit if match found "RTN","TMGRPC3",1040,0) new SSN set SSN=$translate($get(Array(.09)),"-","") "RTN","TMGRPC3",1041,0) if SSN'="" set result=+$order(^DPT("SSN",SSN,"")) "RTN","TMGRPC3",1042,0) if result>0 goto PSEDone "RTN","TMGRPC3",1043,0) "RTN","TMGRPC3",1044,0) new name,sex,DOB "RTN","TMGRPC3",1045,0) set name=$get(Array(.01)) "RTN","TMGRPC3",1046,0) if name="" do goto PSEDone "RTN","TMGRPC3",1047,0) . set result="0^No Name (.01 field) provided" "RTN","TMGRPC3",1048,0) "RTN","TMGRPC3",1049,0) set sex=$get(Array(.02)) "RTN","TMGRPC3",1050,0) if sex="" do goto PSEDone "RTN","TMGRPC3",1051,0) . set result="0^Sex (.02 field) not specified" "RTN","TMGRPC3",1052,0) if (sex'="M")&(sex'="F") do goto PSEDone "RTN","TMGRPC3",1053,0) . set result="0^Sex should be 'Y' or 'N'. Value provided="_sex "RTN","TMGRPC3",1054,0) "RTN","TMGRPC3",1055,0) set DOB=$get(Array(.03)) "RTN","TMGRPC3",1056,0) if DOB="" do goto PSEDone "RTN","TMGRPC3",1057,0) . set result="0^No DOB (.03 field) provided" "RTN","TMGRPC3",1058,0) new %DT,X,Y set %DT="P" ;"P-Post dates assumed "RTN","TMGRPC3",1059,0) set X=DOB do ^%DT set DOB=Y ;"convert external date into internal format "RTN","TMGRPC3",1060,0) if +DOB'>0 do goto PSEDone "RTN","TMGRPC3",1061,0) . set result="0^Invalid date: "_$get(Array(.03)) "RTN","TMGRPC3",1062,0) "RTN","TMGRPC3",1063,0) new matches merge matches=^DPT("B",name) "RTN","TMGRPC3",1064,0) if $data(matches)=0 do goto PSEDone "RTN","TMGRPC3",1065,0) . set result="0^No match for name" "RTN","TMGRPC3",1066,0) "RTN","TMGRPC3",1067,0) ;"Now compare each name match for also matching sex and DOB "RTN","TMGRPC3",1068,0) new IEN set IEN="" "RTN","TMGRPC3",1069,0) for set IEN=$order(matches(IEN)) quit:(+IEN'>0) do "RTN","TMGRPC3",1070,0) . new node0 set node0=$get(^DPT(IEN,0)) "RTN","TMGRPC3",1071,0) . if $piece(node0,"^",2)'=sex do quit "RTN","TMGRPC3",1072,0) . . kill matches(IEN) "RTN","TMGRPC3",1073,0) . if $piece(node0,"^",3)'=DOB do quit "RTN","TMGRPC3",1074,0) . . kill matches(IEN) "RTN","TMGRPC3",1075,0) "RTN","TMGRPC3",1076,0) ;"matches should contain all entries matching name+sex+DOB "RTN","TMGRPC3",1077,0) set result=+$order(matches("")) "RTN","TMGRPC3",1078,0) ;"Now check for more than one match "RTN","TMGRPC3",1079,0) if $order(matches(result))'="" do goto PSEDone "RTN","TMGRPC3",1080,0) . set result="0^More than one match found for Name+Sex+DOB" "RTN","TMGRPC3",1081,0) "RTN","TMGRPC3",1082,0) PSEDone "RTN","TMGRPC3",1083,0) quit result "RTN","TMGRPC3",1084,0) "RTN","TMGRPC3",1085,0) "RTN","TMGRPC3",1086,0) GetErrStr(ErrArray) "RTN","TMGRPC3",1087,0) ;"Purpose: convert a standard DIERR array into a string for output "RTN","TMGRPC3",1088,0) ;"Input: ErrArray -- PASS BY REFERENCE. example: "RTN","TMGRPC3",1089,0) ;" array("DIERR")="1^1" "RTN","TMGRPC3",1090,0) ;" array("DIERR",1)=311 "RTN","TMGRPC3",1091,0) ;" array("DIERR",1,"PARAM",0)=3 "RTN","TMGRPC3",1092,0) ;" array("DIERR",1,"PARAM","FIELD")=.02 "RTN","TMGRPC3",1093,0) ;" array("DIERR",1,"PARAM","FILE")=2 "RTN","TMGRPC3",1094,0) ;" array("DIERR",1,"PARAM","IENS")="+1," "RTN","TMGRPC3",1095,0) ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers." "RTN","TMGRPC3",1096,0) ;" array("DIERR","E",311,1)="" "RTN","TMGRPC3",1097,0) ;"Results: returns one long equivalent string from above array. "RTN","TMGRPC3",1098,0) ;"Note: This is a copy of the function GetErrStr^TMGDEBUG "RTN","TMGRPC3",1099,0) ;" I copied it here so that this file has no TMG* dependencies. "RTN","TMGRPC3",1100,0) "RTN","TMGRPC3",1101,0) new ErrStr "RTN","TMGRPC3",1102,0) new TMGIDX "RTN","TMGRPC3",1103,0) new ErrNum "RTN","TMGRPC3",1104,0) "RTN","TMGRPC3",1105,0) set ErrStr="" "RTN","TMGRPC3",1106,0) for ErrNum=1:1:+$get(ErrArray("DIERR")) do "RTN","TMGRPC3",1107,0) . set ErrStr=ErrStr_"Fileman says: '" "RTN","TMGRPC3",1108,0) . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") " "RTN","TMGRPC3",1109,0) . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT","")) "RTN","TMGRPC3",1110,0) . if TMGIDX'="" for do quit:(TMGIDX="") "RTN","TMGRPC3",1111,0) . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" " "RTN","TMGRPC3",1112,0) . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX)) "RTN","TMGRPC3",1113,0) . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do "RTN","TMGRPC3",1114,0) . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0)) "RTN","TMGRPC3",1115,0) . . set ErrStr=ErrStr_"Details: " "RTN","TMGRPC3",1116,0) . . for do quit:(TMGIDX="") "RTN","TMGRPC3",1117,0) . . . if TMGIDX="" quit "RTN","TMGRPC3",1118,0) . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" " "RTN","TMGRPC3",1119,0) . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX)) "RTN","TMGRPC3",1120,0) "RTN","TMGRPC3",1121,0) quit ErrStr "RTN","TMGRPC3",1122,0) "RTN","TMGRPC3",1123,0) "VER") 8.0^22.0 **END** **END**