KIDS Distribution saved on Jan 03, 2012@11:18:10 C0C **KIDS**:C0C*1.0*0^ **INSTALL NAME** C0C*1.0*0 "BLD",7418,0) C0C*1.0*0^^0^3120103^y "BLD",7418,1,0) ^^1^1^3120103^ "BLD",7418,1,1,0) All C0C routines "BLD",7418,4,0) ^9.64PA^^ "BLD",7418,6.3) 1 "BLD",7418,"KRN",0) ^9.67PA^8989.52^19 "BLD",7418,"KRN",.4,0) .4 "BLD",7418,"KRN",.401,0) .401 "BLD",7418,"KRN",.402,0) .402 "BLD",7418,"KRN",.403,0) .403 "BLD",7418,"KRN",.5,0) .5 "BLD",7418,"KRN",.84,0) .84 "BLD",7418,"KRN",3.6,0) 3.6 "BLD",7418,"KRN",3.8,0) 3.8 "BLD",7418,"KRN",9.2,0) 9.2 "BLD",7418,"KRN",9.8,0) 9.8 "BLD",7418,"KRN",9.8,"NM",0) ^9.68A^71^71 "BLD",7418,"KRN",9.8,"NM",1,0) C0CACTOR^^0^B99733742 "BLD",7418,"KRN",9.8,"NM",2,0) C0CALERT^^0^B31627309 "BLD",7418,"KRN",9.8,"NM",3,0) C0CBAT^^0^B56971574 "BLD",7418,"KRN",9.8,"NM",4,0) C0CCCD^^0^B114134049 "BLD",7418,"KRN",9.8,"NM",5,0) C0CCCD1^^0^B100634737 "BLD",7418,"KRN",9.8,"NM",6,0) C0CCCR^^0^B105501729 "BLD",7418,"KRN",9.8,"NM",7,0) C0CCCR0^^0^B790419172 "BLD",7418,"KRN",9.8,"NM",8,0) C0CCMT^^0^B6740701 "BLD",7418,"KRN",9.8,"NM",9,0) C0CCPT^^0^B14724357 "BLD",7418,"KRN",9.8,"NM",10,0) C0CDIC^^0^B43527636 "BLD",7418,"KRN",9.8,"NM",11,0) C0CDOM^^0^B86773980 "BLD",7418,"KRN",9.8,"NM",12,0) C0CDPT^^0^B45873061 "BLD",7418,"KRN",9.8,"NM",13,0) C0CENC^^0^B46321144 "BLD",7418,"KRN",9.8,"NM",14,0) C0CENV^^0^B25371113 "BLD",7418,"KRN",9.8,"NM",15,0) C0CEVC^^0^B14016673 "BLD",7418,"KRN",9.8,"NM",16,0) C0CEWD^^0^B5607678 "BLD",7418,"KRN",9.8,"NM",17,0) C0CEWD1^^0^B6563070 "BLD",7418,"KRN",9.8,"NM",18,0) C0CFM1^^0^B27048099 "BLD",7418,"KRN",9.8,"NM",19,0) C0CFM2^^0^B102195978 "BLD",7418,"KRN",9.8,"NM",20,0) C0CFM3^^0^B68203631 "BLD",7418,"KRN",9.8,"NM",21,0) C0CIM2^^0^B20157375 "BLD",7418,"KRN",9.8,"NM",22,0) C0CIMMU^^0^B20441765 "BLD",7418,"KRN",9.8,"NM",23,0) C0CIN^^0^B30946883 "BLD",7418,"KRN",9.8,"NM",24,0) C0CLA7DD^^0^B66668579 "BLD",7418,"KRN",9.8,"NM",25,0) C0CLA7Q^^0^B21818572 "BLD",7418,"KRN",9.8,"NM",26,0) C0CLABS^^0^B282605501 "BLD",7418,"KRN",9.8,"NM",27,0) C0CMAIL^^0^B92791623 "BLD",7418,"KRN",9.8,"NM",28,0) C0CMAIL2^^0^B166788068 "BLD",7418,"KRN",9.8,"NM",29,0) C0CMAIL3^^0^B224733356 "BLD",7418,"KRN",9.8,"NM",30,0) C0CMCCD^^0^B73168233 "BLD",7418,"KRN",9.8,"NM",31,0) C0CMED^^0^B18939705 "BLD",7418,"KRN",9.8,"NM",32,0) C0CMED1^^0^B110909428 "BLD",7418,"KRN",9.8,"NM",33,0) C0CMED2^^0^B144699326 "BLD",7418,"KRN",9.8,"NM",34,0) C0CMED3^^0^B172422279 "BLD",7418,"KRN",9.8,"NM",35,0) C0CMED4^^0^B60848214 "BLD",7418,"KRN",9.8,"NM",36,0) C0CMED6^^0^B194177231 "BLD",7418,"KRN",9.8,"NM",37,0) C0CMIME^^0^B99031395 "BLD",7418,"KRN",9.8,"NM",38,0) C0CMXML^^0^B56456416 "BLD",7418,"KRN",9.8,"NM",39,0) C0CMXMLB^^0^B12056407 "BLD",7418,"KRN",9.8,"NM",40,0) C0CMXP^^0^B77680190 "BLD",7418,"KRN",9.8,"NM",41,0) C0CNHIN^^0^B87973392 "BLD",7418,"KRN",9.8,"NM",42,0) C0CNMED2^^0^B33216732 "BLD",7418,"KRN",9.8,"NM",43,0) C0CNMED4^^0^B92677865 "BLD",7418,"KRN",9.8,"NM",44,0) C0CORSLT^^0^B9647157 "BLD",7418,"KRN",9.8,"NM",45,0) C0CPARMS^^0^B7504183 "BLD",7418,"KRN",9.8,"NM",46,0) C0CPROBS^^0^B53281308 "BLD",7418,"KRN",9.8,"NM",47,0) C0CPROC^^0^B27869918 "BLD",7418,"KRN",9.8,"NM",48,0) C0CPXRM^^0^B14904056 "BLD",7418,"KRN",9.8,"NM",49,0) C0CQRY1^^0^B18992765 "BLD",7418,"KRN",9.8,"NM",50,0) C0CQRY2^^0^B20465060 "BLD",7418,"KRN",9.8,"NM",51,0) C0CRIMA^^0^B331901748 "BLD",7418,"KRN",9.8,"NM",52,0) C0CRNF^^0^B195772222 "BLD",7418,"KRN",9.8,"NM",53,0) C0CRNFRP^^0^B91867769 "BLD",7418,"KRN",9.8,"NM",54,0) C0CRPMS^^0^B16300714 "BLD",7418,"KRN",9.8,"NM",55,0) C0CRXN^^0^B103277157 "BLD",7418,"KRN",9.8,"NM",56,0) C0CRXNRD^^0^B34505 "BLD",7418,"KRN",9.8,"NM",57,0) C0CSNOA^^0^B56032588 "BLD",7418,"KRN",9.8,"NM",58,0) C0CSOAP^^0^B79899662 "BLD",7418,"KRN",9.8,"NM",59,0) C0CSUB1^^0^B16280924 "BLD",7418,"KRN",9.8,"NM",60,0) C0CSYS^^0^B3933593 "BLD",7418,"KRN",9.8,"NM",61,0) C0CUNIT^^0^B43465566 "BLD",7418,"KRN",9.8,"NM",62,0) C0CUTIL^^0^B27079469 "BLD",7418,"KRN",9.8,"NM",63,0) C0CVA200^^0^B32092477 "BLD",7418,"KRN",9.8,"NM",64,0) C0CVALID^^0^B2417040 "BLD",7418,"KRN",9.8,"NM",65,0) C0CVIT2^^0^B320700684 "BLD",7418,"KRN",9.8,"NM",66,0) C0CVITAL^^0^B319933080 "BLD",7418,"KRN",9.8,"NM",67,0) C0CVOBX1^^0^B12947698 "BLD",7418,"KRN",9.8,"NM",68,0) C0CVORU^^0^B58596883 "BLD",7418,"KRN",9.8,"NM",69,0) C0CXEWD^^0^B15380480 "BLD",7418,"KRN",9.8,"NM",70,0) C0CXPAT0^^0^B50736852 "BLD",7418,"KRN",9.8,"NM",71,0) C0CXPATH^^0^B521207435 "BLD",7418,"KRN",9.8,"NM","B","C0CACTOR",1) "BLD",7418,"KRN",9.8,"NM","B","C0CALERT",2) "BLD",7418,"KRN",9.8,"NM","B","C0CBAT",3) "BLD",7418,"KRN",9.8,"NM","B","C0CCCD",4) "BLD",7418,"KRN",9.8,"NM","B","C0CCCD1",5) "BLD",7418,"KRN",9.8,"NM","B","C0CCCR",6) "BLD",7418,"KRN",9.8,"NM","B","C0CCCR0",7) "BLD",7418,"KRN",9.8,"NM","B","C0CCMT",8) "BLD",7418,"KRN",9.8,"NM","B","C0CCPT",9) "BLD",7418,"KRN",9.8,"NM","B","C0CDIC",10) "BLD",7418,"KRN",9.8,"NM","B","C0CDOM",11) "BLD",7418,"KRN",9.8,"NM","B","C0CDPT",12) "BLD",7418,"KRN",9.8,"NM","B","C0CENC",13) "BLD",7418,"KRN",9.8,"NM","B","C0CENV",14) "BLD",7418,"KRN",9.8,"NM","B","C0CEVC",15) "BLD",7418,"KRN",9.8,"NM","B","C0CEWD",16) "BLD",7418,"KRN",9.8,"NM","B","C0CEWD1",17) "BLD",7418,"KRN",9.8,"NM","B","C0CFM1",18) "BLD",7418,"KRN",9.8,"NM","B","C0CFM2",19) "BLD",7418,"KRN",9.8,"NM","B","C0CFM3",20) "BLD",7418,"KRN",9.8,"NM","B","C0CIM2",21) "BLD",7418,"KRN",9.8,"NM","B","C0CIMMU",22) "BLD",7418,"KRN",9.8,"NM","B","C0CIN",23) "BLD",7418,"KRN",9.8,"NM","B","C0CLA7DD",24) "BLD",7418,"KRN",9.8,"NM","B","C0CLA7Q",25) "BLD",7418,"KRN",9.8,"NM","B","C0CLABS",26) "BLD",7418,"KRN",9.8,"NM","B","C0CMAIL",27) "BLD",7418,"KRN",9.8,"NM","B","C0CMAIL2",28) "BLD",7418,"KRN",9.8,"NM","B","C0CMAIL3",29) "BLD",7418,"KRN",9.8,"NM","B","C0CMCCD",30) "BLD",7418,"KRN",9.8,"NM","B","C0CMED",31) "BLD",7418,"KRN",9.8,"NM","B","C0CMED1",32) "BLD",7418,"KRN",9.8,"NM","B","C0CMED2",33) "BLD",7418,"KRN",9.8,"NM","B","C0CMED3",34) "BLD",7418,"KRN",9.8,"NM","B","C0CMED4",35) "BLD",7418,"KRN",9.8,"NM","B","C0CMED6",36) "BLD",7418,"KRN",9.8,"NM","B","C0CMIME",37) "BLD",7418,"KRN",9.8,"NM","B","C0CMXML",38) "BLD",7418,"KRN",9.8,"NM","B","C0CMXMLB",39) "BLD",7418,"KRN",9.8,"NM","B","C0CMXP",40) "BLD",7418,"KRN",9.8,"NM","B","C0CNHIN",41) "BLD",7418,"KRN",9.8,"NM","B","C0CNMED2",42) "BLD",7418,"KRN",9.8,"NM","B","C0CNMED4",43) "BLD",7418,"KRN",9.8,"NM","B","C0CORSLT",44) "BLD",7418,"KRN",9.8,"NM","B","C0CPARMS",45) "BLD",7418,"KRN",9.8,"NM","B","C0CPROBS",46) "BLD",7418,"KRN",9.8,"NM","B","C0CPROC",47) "BLD",7418,"KRN",9.8,"NM","B","C0CPXRM",48) "BLD",7418,"KRN",9.8,"NM","B","C0CQRY1",49) "BLD",7418,"KRN",9.8,"NM","B","C0CQRY2",50) "BLD",7418,"KRN",9.8,"NM","B","C0CRIMA",51) "BLD",7418,"KRN",9.8,"NM","B","C0CRNF",52) "BLD",7418,"KRN",9.8,"NM","B","C0CRNFRP",53) "BLD",7418,"KRN",9.8,"NM","B","C0CRPMS",54) "BLD",7418,"KRN",9.8,"NM","B","C0CRXN",55) "BLD",7418,"KRN",9.8,"NM","B","C0CRXNRD",56) "BLD",7418,"KRN",9.8,"NM","B","C0CSNOA",57) "BLD",7418,"KRN",9.8,"NM","B","C0CSOAP",58) "BLD",7418,"KRN",9.8,"NM","B","C0CSUB1",59) "BLD",7418,"KRN",9.8,"NM","B","C0CSYS",60) "BLD",7418,"KRN",9.8,"NM","B","C0CUNIT",61) "BLD",7418,"KRN",9.8,"NM","B","C0CUTIL",62) "BLD",7418,"KRN",9.8,"NM","B","C0CVA200",63) "BLD",7418,"KRN",9.8,"NM","B","C0CVALID",64) "BLD",7418,"KRN",9.8,"NM","B","C0CVIT2",65) "BLD",7418,"KRN",9.8,"NM","B","C0CVITAL",66) "BLD",7418,"KRN",9.8,"NM","B","C0CVOBX1",67) "BLD",7418,"KRN",9.8,"NM","B","C0CVORU",68) "BLD",7418,"KRN",9.8,"NM","B","C0CXEWD",69) "BLD",7418,"KRN",9.8,"NM","B","C0CXPAT0",70) "BLD",7418,"KRN",9.8,"NM","B","C0CXPATH",71) "BLD",7418,"KRN",19,0) 19 "BLD",7418,"KRN",19.1,0) 19.1 "BLD",7418,"KRN",101,0) 101 "BLD",7418,"KRN",409.61,0) 409.61 "BLD",7418,"KRN",771,0) 771 "BLD",7418,"KRN",870,0) 870 "BLD",7418,"KRN",8989.51,0) 8989.51 "BLD",7418,"KRN",8989.52,0) 8989.52 "BLD",7418,"KRN",8994,0) 8994 "BLD",7418,"KRN","B",.4,.4) "BLD",7418,"KRN","B",.401,.401) "BLD",7418,"KRN","B",.402,.402) "BLD",7418,"KRN","B",.403,.403) "BLD",7418,"KRN","B",.5,.5) "BLD",7418,"KRN","B",.84,.84) "BLD",7418,"KRN","B",3.6,3.6) "BLD",7418,"KRN","B",3.8,3.8) "BLD",7418,"KRN","B",9.2,9.2) "BLD",7418,"KRN","B",9.8,9.8) "BLD",7418,"KRN","B",19,19) "BLD",7418,"KRN","B",19.1,19.1) "BLD",7418,"KRN","B",101,101) "BLD",7418,"KRN","B",409.61,409.61) "BLD",7418,"KRN","B",771,771) "BLD",7418,"KRN","B",870,870) "BLD",7418,"KRN","B",8989.51,8989.51) "BLD",7418,"KRN","B",8989.52,8989.52) "BLD",7418,"KRN","B",8994,8994) "MBREQ") 0 "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") 71 "RTN","C0CACTOR") 0^1^B99733742 "RTN","C0CACTOR",1,0) C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 "RTN","C0CACTOR",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CACTOR",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CACTOR",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CACTOR",5,0) ;See attached copy of the License. "RTN","C0CACTOR",6,0) ; "RTN","C0CACTOR",7,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CACTOR",8,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CACTOR",9,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CACTOR",10,0) ; (at your option) any later version. "RTN","C0CACTOR",11,0) ; "RTN","C0CACTOR",12,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CACTOR",13,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CACTOR",14,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CACTOR",15,0) ; GNU General Public License for more details. "RTN","C0CACTOR",16,0) ; "RTN","C0CACTOR",17,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CACTOR",18,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CACTOR",19,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CACTOR",20,0) ; "RTN","C0CACTOR",21,0) ; PROCESS THE ACTORS SECTION OF THE CCR "RTN","C0CACTOR",22,0) ; "RTN","C0CACTOR",23,0) ; ===Revision History=== "RTN","C0CACTOR",24,0) ; 0.1 Initial Writing of Skeleton--GPL "RTN","C0CACTOR",25,0) ; 0.2 Patient Data Extraction--SMH "RTN","C0CACTOR",26,0) ; 0.3 Information System Info Extraction--SMH "RTN","C0CACTOR",27,0) ; 0.4 Patient data rouine refactored; adjustments here--SMH "RTN","C0CACTOR",28,0) ; "RTN","C0CACTOR",29,0) EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE "RTN","C0CACTOR",30,0) ; IPXML is the Input Actor Template into which we substitute values "RTN","C0CACTOR",31,0) ; This is straight XML. Values to be substituted are in @@VAL@@ format. "RTN","C0CACTOR",32,0) ; ALST is the actor list global generated by ACTLST^C0CCCR and has format: "RTN","C0CACTOR",33,0) ; ^TMP(7542,1,"ACTORS",0)=Count "RTN","C0CACTOR",34,0) ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" "RTN","C0CACTOR",35,0) ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" "RTN","C0CACTOR",36,0) ; AXML is the output arrary, to contain XML. "RTN","C0CACTOR",37,0) ; "RTN","C0CACTOR",38,0) N I,J,AMAP,AOID,ATYP,AIEN "RTN","C0CACTOR",39,0) D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML "RTN","C0CACTOR",40,0) D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES "RTN","C0CACTOR",41,0) I DEBUG W "PROCESSING ACTORS ",! "RTN","C0CACTOR",42,0) F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST "RTN","C0CACTOR",43,0) . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR "RTN","C0CACTOR",44,0) . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID "RTN","C0CACTOR",45,0) . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE "RTN","C0CACTOR",46,0) . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER "RTN","C0CACTOR",47,0) . I AIEN="" D Q ; IEN CAN'T BE NULL "RTN","C0CACTOR",48,0) . . W "WARING NUL ACTOR: ",ATYP,! "RTN","C0CACTOR",49,0) . I ATYP="" Q ; NOT A VALID ACTOR "RTN","C0CACTOR",50,0) . ; "RTN","C0CACTOR",51,0) . I DEBUG W AOID_" "_ATYP_" "_AIEN,! "RTN","C0CACTOR",52,0) . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE "RTN","C0CACTOR",53,0) . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") "RTN","C0CACTOR",54,0) . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") "RTN","C0CACTOR",55,0) . ; "RTN","C0CACTOR",56,0) . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE "RTN","C0CACTOR",57,0) . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") "RTN","C0CACTOR",58,0) . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") "RTN","C0CACTOR",59,0) . ; "RTN","C0CACTOR",60,0) . I ATYP="NOK" D ; NOK ACTOR TYPE "RTN","C0CACTOR",61,0) . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") "RTN","C0CACTOR",62,0) . . D NOK("ATMP",AIEN,AOID,"ATMP2") "RTN","C0CACTOR",63,0) . ; "RTN","C0CACTOR",64,0) . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE "RTN","C0CACTOR",65,0) . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") "RTN","C0CACTOR",66,0) . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") "RTN","C0CACTOR",67,0) . ; "RTN","C0CACTOR",68,0) . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE "RTN","C0CACTOR",69,0) . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") "RTN","C0CACTOR",70,0) . . D ORG("ATMP",AIEN,AOID,"ATMP2") "RTN","C0CACTOR",71,0) . ; "RTN","C0CACTOR",72,0) . W "PROCESSING:",ATYP," ",AIEN,! "RTN","C0CACTOR",73,0) . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE "RTN","C0CACTOR",74,0) . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT "RTN","C0CACTOR",75,0) . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE "RTN","C0CACTOR",76,0) ; "RTN","C0CACTOR",77,0) N ACTTMP "RTN","C0CACTOR",78,0) D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CACTOR",79,0) I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - "RTN","C0CACTOR",80,0) . ; STRINGS MARKED AS @@X@@ "RTN","C0CACTOR",81,0) . W "ACTORS Missing list: ",! "RTN","C0CACTOR",82,0) . F I=1:1:ACTTMP(0) W ACTTMP(I),! "RTN","C0CACTOR",83,0) Q "RTN","C0CACTOR",84,0) ; "RTN","C0CACTOR",85,0) PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR "RTN","C0CACTOR",86,0) I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! "RTN","C0CACTOR",87,0) ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE "RTN","C0CACTOR",88,0) ; CODE REUSABLE FROM ERX "RTN","C0CACTOR",89,0) N AMAP "RTN","C0CACTOR",90,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","C0CACTOR",91,0) K @AMAP "RTN","C0CACTOR",92,0) D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR "RTN","C0CACTOR",93,0) I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1 "RTN","C0CACTOR",94,0) I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR "RTN","C0CACTOR",95,0) D MAP(INXML,AMAP,OUTXML) ;MAP TO XML "RTN","C0CACTOR",96,0) K @AMAP ; CLEAN UP BEHIND US "RTN","C0CACTOR",97,0) Q "RTN","C0CACTOR",98,0) ; "RTN","C0CACTOR",99,0) DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR "RTN","C0CACTOR",100,0) S @GPL@("ACTORADDRESSCITY")="ALTON" "RTN","C0CACTOR",101,0) S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane" "RTN","C0CACTOR",102,0) S @GPL@("ACTORADDRESSLINE2")="" "RTN","C0CACTOR",103,0) S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN "RTN","C0CACTOR",104,0) S @GPL@("ACTORADDRESSSTATE")="KANSAS" "RTN","C0CACTOR",105,0) S @GPL@("ACTORADDRESSTYPE")="Home" "RTN","C0CACTOR",106,0) S @GPL@("ACTORADDRESSZIPCODE")=67623 "RTN","C0CACTOR",107,0) S @GPL@("ACTORCELLTEL")="" "RTN","C0CACTOR",108,0) S @GPL@("ACTORCELLTELTEXT")="" "RTN","C0CACTOR",109,0) S @GPL@("ACTORDATEOFBIRTH")="1957-12-25" "RTN","C0CACTOR",110,0) S @GPL@("ACTOREMAIL")="" "RTN","C0CACTOR",111,0) S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN "RTN","C0CACTOR",112,0) ;S @GPL@("ACTORGENDER")="MALE" "RTN","C0CACTOR",113,0) S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN "RTN","C0CACTOR",114,0) S @GPL@("ACTORIEN")=2 "RTN","C0CACTOR",115,0) S @GPL@("ACTORMIDDLENAME")="TWO" "RTN","C0CACTOR",116,0) S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN "RTN","C0CACTOR",117,0) S @GPL@("ACTORRESTEL")="888-555-1212" "RTN","C0CACTOR",118,0) S @GPL@("ACTORRESTELTEXT")="Residential Telephone" "RTN","C0CACTOR",119,0) S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1" "RTN","C0CACTOR",120,0) S @GPL@("ACTORSSN")="769122557P" "RTN","C0CACTOR",121,0) S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN "RTN","C0CACTOR",122,0) S @GPL@("ACTORSSNTEXT")="SSN" "RTN","C0CACTOR",123,0) S @GPL@("ACTORSUFFIXNAME")="" "RTN","C0CACTOR",124,0) S @GPL@("ACTORWORKTEL")="888-121-1212" "RTN","C0CACTOR",125,0) S @GPL@("ACTORWORKTELTEXT")="Work Telephone" "RTN","C0CACTOR",126,0) Q "RTN","C0CACTOR",127,0) ; "RTN","C0CACTOR",128,0) PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME "RTN","C0CACTOR",129,0) N ZX "RTN","C0CACTOR",130,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","C0CACTOR",131,0) S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN) "RTN","C0CACTOR",132,0) S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN) "RTN","C0CACTOR",133,0) S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN) "RTN","C0CACTOR",134,0) S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN) "RTN","C0CACTOR",135,0) S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2) "RTN","C0CACTOR",136,0) S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1) "RTN","C0CACTOR",137,0) S @AMAP@("ACTORSSN")="" "RTN","C0CACTOR",138,0) S @AMAP@("ACTORSSNTEXT")="" "RTN","C0CACTOR",139,0) S @AMAP@("ACTORSSNSOURCEID")="" "RTN","C0CACTOR",140,0) S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA "RTN","C0CACTOR",141,0) X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS "RTN","C0CACTOR",142,0) I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL "RTN","C0CACTOR",143,0) I $G(MRN)'="" D ; IF MRN IS PRESENT "RTN","C0CACTOR",144,0) . S @AMAP@("ACTORSSN")=MRN "RTN","C0CACTOR",145,0) . S @AMAP@("ACTORSSNTEXT")="MRN" "RTN","C0CACTOR",146,0) . S @AMAP@("ACTORSSNSOURCEID")=AOID "RTN","C0CACTOR",147,0) E D ; NO MRN, USE SSN "RTN","C0CACTOR",148,0) . S ZX=$$SSN^C0CDPT(AIEN) "RTN","C0CACTOR",149,0) . I ZX'="" D ; IF THERE IS A SSN IN THE RECORD "RTN","C0CACTOR",150,0) . . S @AMAP@("ACTORSSN")=ZX "RTN","C0CACTOR",151,0) . . S @AMAP@("ACTORSSNTEXT")="SSN" "RTN","C0CACTOR",152,0) . . S @AMAP@("ACTORSSNSOURCEID")=AOID "RTN","C0CACTOR",153,0) S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN) "RTN","C0CACTOR",154,0) S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN) "RTN","C0CACTOR",155,0) S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN) "RTN","C0CACTOR",156,0) S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN) "RTN","C0CACTOR",157,0) S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN) "RTN","C0CACTOR",158,0) S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN) "RTN","C0CACTOR",159,0) S @AMAP@("ACTORRESTEL")="" "RTN","C0CACTOR",160,0) S @AMAP@("ACTORRESTELTEXT")="" "RTN","C0CACTOR",161,0) S ZX=$$RESTEL^C0CDPT(AIEN) "RTN","C0CACTOR",162,0) I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD "RTN","C0CACTOR",163,0) . S @AMAP@("ACTORRESTEL")=ZX "RTN","C0CACTOR",164,0) . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" "RTN","C0CACTOR",165,0) S @AMAP@("ACTORWORKTEL")="" "RTN","C0CACTOR",166,0) S @AMAP@("ACTORWORKTELTEXT")="" "RTN","C0CACTOR",167,0) S ZX=$$WORKTEL^C0CDPT(AIEN) "RTN","C0CACTOR",168,0) I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD "RTN","C0CACTOR",169,0) . S @AMAP@("ACTORWORKTEL")=ZX "RTN","C0CACTOR",170,0) . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" "RTN","C0CACTOR",171,0) S @AMAP@("ACTORCELLTEL")="" "RTN","C0CACTOR",172,0) S @AMAP@("ACTORCELLTELTEXT")="" "RTN","C0CACTOR",173,0) S ZX=$$CELLTEL^C0CDPT(AIEN) "RTN","C0CACTOR",174,0) I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD "RTN","C0CACTOR",175,0) . S @AMAP@("ACTORCELLTEL")=ZX "RTN","C0CACTOR",176,0) . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" "RTN","C0CACTOR",177,0) S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN) "RTN","C0CACTOR",178,0) S @AMAP@("ACTORADDRESSSOURCEID")=AOID "RTN","C0CACTOR",179,0) S @AMAP@("ACTORIEN")=AIEN "RTN","C0CACTOR",180,0) S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX "RTN","C0CACTOR",181,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE "RTN","C0CACTOR",182,0) Q "RTN","C0CACTOR",183,0) ; "RTN","C0CACTOR",184,0) MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML "RTN","C0CACTOR",185,0) D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","C0CACTOR",186,0) Q "RTN","C0CACTOR",187,0) ; "RTN","C0CACTOR",188,0) SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR "RTN","C0CACTOR",189,0) ; "RTN","C0CACTOR",190,0) ; N AMAP "RTN","C0CACTOR",191,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","C0CACTOR",192,0) K @AMAP "RTN","C0CACTOR",193,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","C0CACTOR",194,0) S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS "RTN","C0CACTOR",195,0) S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS "RTN","C0CACTOR",196,0) S @AMAP@("ACTORINFOSYSSOURCEID")=AOID "RTN","C0CACTOR",197,0) D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","C0CACTOR",198,0) Q "RTN","C0CACTOR",199,0) ; "RTN","C0CACTOR",200,0) NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR "RTN","C0CACTOR",201,0) ; "RTN","C0CACTOR",202,0) ; N AMAP "RTN","C0CACTOR",203,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","C0CACTOR",204,0) K @AMAP "RTN","C0CACTOR",205,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","C0CACTOR",206,0) S @AMAP@("ACTORDISPLAYNAME")="" "RTN","C0CACTOR",207,0) S @AMAP@("ACTORRELATION")="" "RTN","C0CACTOR",208,0) S @AMAP@("ACTORRELATIONSOURCEID")="" "RTN","C0CACTOR",209,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE "RTN","C0CACTOR",210,0) D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","C0CACTOR",211,0) Q "RTN","C0CACTOR",212,0) ; "RTN","C0CACTOR",213,0) ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR "RTN","C0CACTOR",214,0) ; "RTN","C0CACTOR",215,0) N AMAP,ZIEN,ZSITE "RTN","C0CACTOR",216,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","C0CACTOR",217,0) K @AMAP "RTN","C0CACTOR",218,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","C0CACTOR",219,0) S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE "RTN","C0CACTOR",220,0) S ZIEN=$P(ZSITE,"^",1) "RTN","C0CACTOR",221,0) S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2) "RTN","C0CACTOR",222,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" "RTN","C0CACTOR",223,0) S @AMAP@("ACTORADDRESSTYPE")="Office" "RTN","C0CACTOR",224,0) S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01) "RTN","C0CACTOR",225,0) S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02) "RTN","C0CACTOR",226,0) S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03) "RTN","C0CACTOR",227,0) S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02) "RTN","C0CACTOR",228,0) S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04) "RTN","C0CACTOR",229,0) S @AMAP@("ACTORTELEPHONE")="" "RTN","C0CACTOR",230,0) S @AMAP@("ACTORTELEPHONETYPE")="" "RTN","C0CACTOR",231,0) S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03) "RTN","C0CACTOR",232,0) I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE "RTN","C0CACTOR",233,0) . S @AMAP@("ACTORTELEPHONE")=ZX "RTN","C0CACTOR",234,0) . S @AMAP@("ACTORTELEPHONETYPE")="Office" "RTN","C0CACTOR",235,0) D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","C0CACTOR",236,0) K @AMAP "RTN","C0CACTOR",237,0) Q "RTN","C0CACTOR",238,0) ; "RTN","C0CACTOR",239,0) PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR "RTN","C0CACTOR",240,0) ; "RTN","C0CACTOR",241,0) ; N AMAP "RTN","C0CACTOR",242,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","C0CACTOR",243,0) K @AMAP "RTN","C0CACTOR",244,0) I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN) "RTN","C0CACTOR",245,0) . W "WARNING - MISSING PROVIDER: ",AIEN,! "RTN","C0CACTOR",246,0) . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT "RTN","C0CACTOR",247,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","C0CACTOR",248,0) S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN) "RTN","C0CACTOR",249,0) S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN) "RTN","C0CACTOR",250,0) S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN) "RTN","C0CACTOR",251,0) S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN) "RTN","C0CACTOR",252,0) S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1) "RTN","C0CACTOR",253,0) S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2) "RTN","C0CACTOR",254,0) S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3) "RTN","C0CACTOR",255,0) S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN) "RTN","C0CACTOR",256,0) S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN) "RTN","C0CACTOR",257,0) S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN) "RTN","C0CACTOR",258,0) S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN) "RTN","C0CACTOR",259,0) S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN) "RTN","C0CACTOR",260,0) S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN) "RTN","C0CACTOR",261,0) S @AMAP@("ACTORTELEPHONE")="" "RTN","C0CACTOR",262,0) S @AMAP@("ACTORTELEPHONETYPE")="" "RTN","C0CACTOR",263,0) S ZX=$$TEL^C0CVA200(AIEN) "RTN","C0CACTOR",264,0) I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE "RTN","C0CACTOR",265,0) . S @AMAP@("ACTORTELEPHONE")=ZX "RTN","C0CACTOR",266,0) . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN) "RTN","C0CACTOR",267,0) S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN) "RTN","C0CACTOR",268,0) S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" "RTN","C0CACTOR",269,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE "RTN","C0CACTOR",270,0) S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1" "RTN","C0CACTOR",271,0) D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","C0CACTOR",272,0) Q "RTN","C0CACTOR",273,0) ; "RTN","C0CALERT") 0^2^B31627309 "RTN","C0CALERT",1,0) C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 "RTN","C0CALERT",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CALERT",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota and others. "RTN","C0CALERT",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CALERT",5,0) ;See attached copy of the License. "RTN","C0CALERT",6,0) ; "RTN","C0CALERT",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CALERT",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CALERT",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CALERT",10,0) ;(at your option) any later version. "RTN","C0CALERT",11,0) ; "RTN","C0CALERT",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CALERT",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CALERT",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CALERT",15,0) ;GNU General Public License for more details. "RTN","C0CALERT",16,0) ; "RTN","C0CALERT",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CALERT",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CALERT",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CALERT",20,0) ; "RTN","C0CALERT",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CALERT",22,0) Q "RTN","C0CALERT",23,0) ; "RTN","C0CALERT",24,0) EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO XML TEMPLATE "RTN","C0CALERT",25,0) ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING "RTN","C0CALERT",26,0) ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CALERT",27,0) ; "RTN","C0CALERT",28,0) ; GET ADVERSE REACTIONS AND ALLERGIES "RTN","C0CALERT",29,0) ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES "RTN","C0CALERT",30,0) S GMRA="0^0^111" "RTN","C0CALERT",31,0) D EN1^GMRADPT "RTN","C0CALERT",32,0) I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* "RTN","C0CALERT",33,0) . S @ALTOUTXML@(0)=0 "RTN","C0CALERT",34,0) ; DEFINE MAPPING "RTN","C0CALERT",35,0) N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP "RTN","C0CALERT",36,0) S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS")) "RTN","C0CALERT",37,0) S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP")) "RTN","C0CALERT",38,0) K @ALTTVMAP,@ALTTARYTMP "RTN","C0CALERT",39,0) N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 "RTN","C0CALERT",40,0) S ALTTMP="" ; "RTN","C0CALERT",41,0) F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL "RTN","C0CALERT",42,0) . W "ALTTMP="_ALTTMP,! "RTN","C0CALERT",43,0) . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q "RTN","C0CALERT",44,0) . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) "RTN","C0CALERT",45,0) . K @ALTVMAP "RTN","C0CALERT",46,0) . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT "RTN","C0CALERT",47,0) . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES "RTN","C0CALERT",48,0) . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING "RTN","C0CALERT",49,0) . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM "RTN","C0CALERT",50,0) . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG "RTN","C0CALERT",51,0) . N ADT S ADT="Patient has an " ; X $ZINT H 5 "RTN","C0CALERT",52,0) . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") "RTN","C0CALERT",53,0) . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." "RTN","C0CALERT",54,0) . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT "RTN","C0CALERT",55,0) . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ; "RTN","C0CALERT",56,0) . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy "RTN","C0CALERT",57,0) . N ALTCDE ; SNOMED CODE THE THE ALERT "RTN","C0CALERT",58,0) . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC "RTN","C0CALERT",59,0) . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; "RTN","C0CALERT",60,0) . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE "RTN","C0CALERT",61,0) . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE "RTN","C0CALERT",62,0) . I ALTCDE'="" D ; IF THERE IS A CODE "RTN","C0CALERT",63,0) . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" "RTN","C0CALERT",64,0) . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" "RTN","C0CALERT",65,0) . E D ; SET TO NULL "RTN","C0CALERT",66,0) . . S @ALTVMAP@("ALERTCODESYSTEM")="" "RTN","C0CALERT",67,0) . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" "RTN","C0CALERT",68,0) . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? "RTN","C0CALERT",69,0) . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN "RTN","C0CALERT",70,0) . I ALTPROV'="" D ; PROVIDER PROVIDEED "RTN","C0CALERT",71,0) . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV "RTN","C0CALERT",72,0) . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN "RTN","C0CALERT",73,0) . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! "RTN","C0CALERT",74,0) . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP "RTN","C0CALERT",75,0) . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, "RTN","C0CALERT",76,0) . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER "RTN","C0CALERT",77,0) . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT "RTN","C0CALERT",78,0) . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT "RTN","C0CALERT",79,0) . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT "RTN","C0CALERT",80,0) . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? "RTN","C0CALERT",81,0) . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT "RTN","C0CALERT",82,0) . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM "RTN","C0CALERT",83,0) . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION "RTN","C0CALERT",84,0) . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE "RTN","C0CALERT",85,0) . I ACVUID'="" D ; IF VUID IS NOT NULL "RTN","C0CALERT",86,0) . . S ZC=$$CODE^C0CUTIL(ACVUID) "RTN","C0CALERT",87,0) . . S ZCD=$P(ZC,"^",1) ; CODE TO USE "RTN","C0CALERT",88,0) . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID "RTN","C0CALERT",89,0) . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION "RTN","C0CALERT",90,0) . E D ; IF REACTANT CODE VALUE IS NULL "RTN","C0CALERT",91,0) . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS "RTN","C0CALERT",92,0) . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; "RTN","C0CALERT",93,0) . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! "RTN","C0CALERT",94,0) . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" "RTN","C0CALERT",95,0) . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" "RTN","C0CALERT",96,0) . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD "RTN","C0CALERT",97,0) . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS "RTN","C0CALERT",98,0) . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD "RTN","C0CALERT",99,0) . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD "RTN","C0CALERT",100,0) . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW "RTN","C0CALERT",101,0) . N ARTMP,ARIEN,ARDES,ARVUID "RTN","C0CALERT",102,0) . S (ARTMP,ARDES,ARVUID)="" "RTN","C0CALERT",103,0) . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS "RTN","C0CALERT",104,0) . . S ARTMP=@ALTG@(ALTTMP,"S",1) "RTN","C0CALERT",105,0) . . W "REACTION:",ARTMP,! "RTN","C0CALERT",106,0) . . S ARIEN=$P(ARTMP,";",2) "RTN","C0CALERT",107,0) . . S ARDES=$P(ARTMP,";",1) "RTN","C0CALERT",108,0) . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") "RTN","C0CALERT",109,0) . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES "RTN","C0CALERT",110,0) . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL "RTN","C0CALERT",111,0) . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID "RTN","C0CALERT",112,0) . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" "RTN","C0CALERT",113,0) . E D ; IF IT IS NULL DON'T SET CODE SYSTEM "RTN","C0CALERT",114,0) . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" "RTN","C0CALERT",115,0) . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" "RTN","C0CALERT",116,0) . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) "RTN","C0CALERT",117,0) . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION "RTN","C0CALERT",118,0) . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL "RTN","C0CALERT",119,0) . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME "RTN","C0CALERT",120,0) . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") "RTN","C0CALERT",121,0) . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") "RTN","C0CALERT",122,0) . K @ALTARYTMP "RTN","C0CALERT",123,0) . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) "RTN","C0CALERT",124,0) . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) "RTN","C0CALERT",125,0) . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) "RTN","C0CALERT",126,0) . S ALTCNT=ALTCNT+1 "RTN","C0CALERT",127,0) S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS "RTN","C0CALERT",128,0) Q "RTN","C0CALERT",129,0) PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER "RTN","C0CALERT",130,0) ; INGLB IS OF THE FORM: PSNDF(50.6, "RTN","C0CALERT",131,0) ; RETURN 50.6 "RTN","C0CALERT",132,0) Q $P($P(INGLB,"(",2),",",1) ; "RTN","C0CBAT") 0^3^B56971574 "RTN","C0CBAT",1,0) C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 "RTN","C0CBAT",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CBAT",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CBAT",4,0) ;General Public License See attached copy of the License. "RTN","C0CBAT",5,0) ; "RTN","C0CBAT",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CBAT",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CBAT",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CBAT",9,0) ;(at your option) any later version. "RTN","C0CBAT",10,0) ; "RTN","C0CBAT",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CBAT",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CBAT",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CBAT",14,0) ;GNU General Public License for more details. "RTN","C0CBAT",15,0) ; "RTN","C0CBAT",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CBAT",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CBAT",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CBAT",19,0) ; "RTN","C0CBAT",20,0) W "This is the CCR Batch Utility Library ",! "RTN","C0CBAT",21,0) Q "RTN","C0CBAT",22,0) ; "RTN","C0CBAT",23,0) STOP ; STOP A CURRENTLY RUNNING BATCH JOB "RTN","C0CBAT",24,0) I '$D(^TMP("C0CBAT","RUNNING")) Q ; "RTN","C0CBAT",25,0) W !,!,"HALTING CCR BATCH",! "RTN","C0CBAT",26,0) S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE "RTN","C0CBAT",27,0) H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED "RTN","C0CBAT",28,0) I '$D(^TMP("C0CBAT","STOP")) D ; SIGNAL RECEIVED "RTN","C0CBAT",29,0) . W "CCR BATCH JOB TERMINATING",! "RTN","C0CBAT",30,0) E D ; "RTN","C0CBAT",31,0) . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING "RTN","C0CBAT",32,0) . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",! "RTN","C0CBAT",33,0) Q "RTN","C0CBAT",34,0) ; "RTN","C0CBAT",35,0) START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION "RTN","C0CBAT",36,0) ; "RTN","C0CBAT",37,0) I $D(^TMP("C0CBAT","RUNNING")) D Q ; ONLY ONE ALLOWED AT A TIME "RTN","C0CBAT",38,0) . W !,"CCR BATCH ALREADY RUNNING",! "RTN","C0CBAT",39,0) . W !,"STOP FIRST WITH STOP^C0CBAT",! "RTN","C0CBAT",40,0) N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO "RTN","C0CBAT",41,0) S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch" "RTN","C0CBAT",42,0) S ZTDTH=$H ; "RTN","C0CBAT",43,0) ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) "RTN","C0CBAT",44,0) S ZTSAVE("C0C")="",ZTSAVE("C0C*")="" "RTN","C0CBAT",45,0) S ZTIO="NULL" ; "RTN","C0CBAT",46,0) W !,!,"CCR BATCH JOB STARTED",! "RTN","C0CBAT",47,0) D ^%ZTLOAD "RTN","C0CBAT",48,0) Q "RTN","C0CBAT",49,0) ; "RTN","C0CBAT",50,0) EN ; BATCH ENTRY POINT "RTN","C0CBAT",51,0) ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH "RTN","C0CBAT",52,0) ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE, "RTN","C0CBAT",53,0) ; GENERATES A NEW CCR FOR THE PATIENT "RTN","C0CBAT",54,0) ; UPDATES THE E2 CCR ELEMENTS FILE "RTN","C0CBAT",55,0) ; "RTN","C0CBAT",56,0) S C0CQT=1 ; QUIET MODE "RTN","C0CBAT",57,0) I $D(^TMP("C0CBAT","RUNNING")) Q ; ONLY ONE AT A TIME "RTN","C0CBAT",58,0) S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL "RTN","C0CBAT",59,0) S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN "RTN","C0CBAT",60,0) S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE "RTN","C0CBAT",61,0) S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE "RTN","C0CBAT",62,0) S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA "RTN","C0CBAT",63,0) I $D(@C0CBB@(0)) D ; ERROR SHOULDN'T EXIST "RTN","C0CBAT",64,0) . W "WORK AREA ERROR",! "RTN","C0CBAT",65,0) . B "RTN","C0CBAT",66,0) S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA "RTN","C0CBAT",67,0) S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST "RTN","C0CBAT",68,0) S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE "RTN","C0CBAT",69,0) ;I $D(^C0CB("B",C0CDT)) D ; BATCH RECORD EXISTS "RTN","C0CBAT",70,0) ;. H 10 ; HANG 10 SECONDS "RTN","C0CBAT",71,0) ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN "RTN","C0CBAT",72,0) ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK "RTN","C0CBAT",73,0) D BLDHOT(C0CBH) ; BUILD THE HOT LIST "RTN","C0CBAT",74,0) S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST "RTN","C0CBAT",75,0) S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS "RTN","C0CBAT",76,0) S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL "RTN","C0CBAT",77,0) S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM "RTN","C0CBAT",78,0) S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS "RTN","C0CBAT",79,0) S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST "RTN","C0CBAT",80,0) D UPDIE ; CREATE THE BATCH RECORD "RTN","C0CBAT",81,0) S C0CIEN=$O(^C0CB("B",C0CBDT,"")) "RTN","C0CBAT",82,0) S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST "RTN","C0CBAT",83,0) S C0CBCUR="" ; CURRENT PATIENT "RTN","C0CBAT",84,0) S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")="" "RTN","C0CBAT",85,0) ;F S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR="" D ; HOT LIST LATEST FIRST "RTN","C0CBAT",86,0) F S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; HOT LIST FIRST "RTN","C0CBAT",87,0) . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900") "RTN","C0CBAT",88,0) . I $G(C0CCHK) D ; "RTN","C0CBAT",89,0) . . D PUTRIM^C0CFM2(C0CBCUR) "RTN","C0CBAT",90,0) . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR "RTN","C0CBAT",91,0) . . K C0CFDA "RTN","C0CBAT",92,0) . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR "RTN","C0CBAT",93,0) . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" "RTN","C0CBAT",94,0) . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) "RTN","C0CBAT",95,0) . . D UPDIE ; CREATE UPDATE SUBFILE "RTN","C0CBAT",96,0) . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL "RTN","C0CBAT",97,0) . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL "RTN","C0CBAT",98,0) . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS "RTN","C0CBAT",99,0) . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS "RTN","C0CBAT",100,0) . S C0CNOW=$$NOW^XLFDT "RTN","C0CBAT",101,0) . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD "RTN","C0CBAT",102,0) . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS "RTN","C0CBAT",103,0) . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME "RTN","C0CBAT",104,0) . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME "RTN","C0CBAT",105,0) . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME "RTN","C0CBAT",106,0) . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START "RTN","C0CBAT",107,0) . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME "RTN","C0CBAT",108,0) . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED "RTN","C0CBAT",109,0) . D UPDIE ; "RTN","C0CBAT",110,0) . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED "RTN","C0CBAT",111,0) . . S C0CSTOP=1 "RTN","C0CBAT",112,0) . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED "RTN","C0CBAT",113,0) . H 1 ; GIVE OTHERS A CHANCE "RTN","C0CBAT",114,0) F S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; SUBS LIST "RTN","C0CBAT",115,0) . I $D(@C0CBH@(C0CBCUR)) Q ; SKIP IF IN HOT LIST - ALREADY DONE "RTN","C0CBAT",116,0) . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760") "RTN","C0CBAT",117,0) . I $G(C0CCHK) D ; IF CHECKSUMS HAVE CHANGED "RTN","C0CBAT",118,0) . . D PUTRIM^C0CFM2(C0CBCUR) "RTN","C0CBAT",119,0) . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR "RTN","C0CBAT",120,0) . . K C0CFDA "RTN","C0CBAT",121,0) . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR "RTN","C0CBAT",122,0) . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" "RTN","C0CBAT",123,0) . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) "RTN","C0CBAT",124,0) . . D UPDIE ; CREATE UPDATE SUBFILE "RTN","C0CBAT",125,0) . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL "RTN","C0CBAT",126,0) . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS "RTN","C0CBAT",127,0) . S C0CNOW=$$NOW^XLFDT "RTN","C0CBAT",128,0) . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD "RTN","C0CBAT",129,0) . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS "RTN","C0CBAT",130,0) . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME "RTN","C0CBAT",131,0) . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME "RTN","C0CBAT",132,0) . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME "RTN","C0CBAT",133,0) . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START "RTN","C0CBAT",134,0) . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME "RTN","C0CBAT",135,0) . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; "RTN","C0CBAT",136,0) . D UPDIE ; "RTN","C0CBAT",137,0) . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED "RTN","C0CBAT",138,0) . . S C0CSTOP=1 "RTN","C0CBAT",139,0) . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED "RTN","C0CBAT",140,0) . H 1 ; GIVE IT A BREAK "RTN","C0CBAT",141,0) I (C0CSTOP) S C0CDISP="KILLED" "RTN","C0CBAT",142,0) E S C0CDISP="FINISHED" "RTN","C0CBAT",143,0) S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP "RTN","C0CBAT",144,0) D UPDIE ; SET DISPOSITION FIELD "RTN","C0CBAT",145,0) K ^TMP("C0CBAT","RUNNING") "RTN","C0CBAT",146,0) Q "RTN","C0CBAT",147,0) ; "RTN","C0CBAT",148,0) BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME "RTN","C0CBAT",149,0) ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE "RTN","C0CBAT",150,0) N ZDFN "RTN","C0CBAT",151,0) S ZDFN="" "RTN","C0CBAT",152,0) F S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN="" D ; ALL PATIENTS IN THE AC INDX "RTN","C0CBAT",153,0) . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT(" "RTN","C0CBAT",154,0) . I '$D(@C0CBS@(ZZDFN)) Q ; SKIP IF NOT IN SUBSCRIPTION LIST "RTN","C0CBAT",155,0) . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST "RTN","C0CBAT",156,0) Q "RTN","C0CBAT",157,0) ; "RTN","C0CBAT",158,0) COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS "RTN","C0CBAT",159,0) N ZI,ZN "RTN","C0CBAT",160,0) S ZN=0 "RTN","C0CBAT",161,0) S ZI="" "RTN","C0CBAT",162,0) F S ZI=$O(@ZB@(ZI)) Q:ZI="" D ; "RTN","C0CBAT",163,0) . S ZN=ZN+1 "RTN","C0CBAT",164,0) Q ZN "RTN","C0CBAT",165,0) ; "RTN","C0CBAT",166,0) UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE "RTN","C0CBAT",167,0) ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO "RTN","C0CBAT",168,0) ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO "RTN","C0CBAT",169,0) ; "RTN","C0CBAT",170,0) N ZCCRD,ZVARN,C0CFDA2 "RTN","C0CBAT",171,0) S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY "RTN","C0CBAT",172,0) S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CBAT",173,0) I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT "RTN","C0CBAT",174,0) . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE "RTN","C0CBAT",175,0) . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! "RTN","C0CBAT",176,0) . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE "RTN","C0CBAT",177,0) . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE "RTN","C0CBAT",178,0) . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN "RTN","C0CBAT",179,0) . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY "RTN","C0CBAT",180,0) . I $D(ZERR) D ; LAYGO ERROR "RTN","C0CBAT",181,0) . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! "RTN","C0CBAT",182,0) . E D ; "RTN","C0CBAT",183,0) . . D CLEAN^DILF ; CLEAN UP "RTN","C0CBAT",184,0) . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CBAT",185,0) . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! "RTN","C0CBAT",186,0) Q ZVARN "RTN","C0CBAT",187,0) ; "RTN","C0CBAT",188,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CBAT",189,0) K ZERR "RTN","C0CBAT",190,0) D CLEAN^DILF "RTN","C0CBAT",191,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CBAT",192,0) I $D(ZERR) D ; "RTN","C0CBAT",193,0) . W "ERROR",! "RTN","C0CBAT",194,0) . ZWR ZERR "RTN","C0CBAT",195,0) . B "RTN","C0CBAT",196,0) K C0CFDA "RTN","C0CBAT",197,0) Q "RTN","C0CBAT",198,0) ; "RTN","C0CBAT",199,0) SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN "RTN","C0CBAT",200,0) ; TO SET TO VALUE C0CSV. "RTN","C0CBAT",201,0) ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE "RTN","C0CBAT",202,0) ; C0CSN,C0CSV ARE PASSED BY VALUE "RTN","C0CBAT",203,0) ; "RTN","C0CBAT",204,0) N C0CSI,C0CSJ "RTN","C0CBAT",205,0) S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER "RTN","C0CBAT",206,0) S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER "RTN","C0CBAT",207,0) S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV "RTN","C0CBAT",208,0) Q "RTN","C0CBAT",209,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CBAT",210,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) "RTN","C0CBAT",211,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CBAT",212,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CBAT",213,0) N ZR "RTN","C0CBAT",214,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) "RTN","C0CBAT",215,0) E S ZR="" "RTN","C0CBAT",216,0) Q ZR "RTN","C0CBAT",217,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CBAT",218,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) "RTN","C0CBAT",219,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CBAT",220,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CBAT",221,0) N ZR "RTN","C0CBAT",222,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) "RTN","C0CBAT",223,0) E S ZR="" "RTN","C0CBAT",224,0) Q ZR "RTN","C0CBAT",225,0) ; "RTN","C0CBAT",226,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CBAT",227,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) "RTN","C0CBAT",228,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CBAT",229,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CBAT",230,0) N ZR "RTN","C0CBAT",231,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) "RTN","C0CBAT",232,0) E S ZR="" "RTN","C0CBAT",233,0) Q ZR "RTN","C0CBAT",234,0) ; "RTN","C0CCCD") 0^4^B114134049 "RTN","C0CCCD",1,0) C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 "RTN","C0CCCD",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CCCD",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CCCD",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CCCD",5,0) ;See attached copy of the License. "RTN","C0CCCD",6,0) ; "RTN","C0CCCD",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CCCD",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CCCD",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CCCD",10,0) ;(at your option) any later version. "RTN","C0CCCD",11,0) ; "RTN","C0CCCD",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CCCD",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CCCD",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CCCD",15,0) ;GNU General Public License for more details. "RTN","C0CCCD",16,0) ; "RTN","C0CCCD",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CCCD",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CCCD",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CCCD",20,0) ; "RTN","C0CCCD",21,0) ; EXPORT A CCR "RTN","C0CCCD",22,0) ; "RTN","C0CCCD",23,0) EXPORT ; EXPORT ENTRY POINT FOR CCR "RTN","C0CCCD",24,0) ; Select a patient. "RTN","C0CCCD",25,0) S DIC=2,DIC(0)="AEMQ" D ^DIC "RTN","C0CCCD",26,0) I Y<1 Q ; EXIT "RTN","C0CCCD",27,0) S DFN=$P(Y,U,1) ; SET THE PATIENT "RTN","C0CCCD",28,0) D XPAT(DFN,"","") ; EXPORT TO A FILE "RTN","C0CCCD",29,0) Q "RTN","C0CCCD",30,0) ; "RTN","C0CCCD",31,0) XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE "RTN","C0CCCD",32,0) ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") "RTN","C0CCCD",33,0) ; FN IS FILE NAME, DEFAULTS IF NULL "RTN","C0CCCD",34,0) ; N CCDGLO "RTN","C0CCCD",35,0) D CCDRPC(.CCDGLO,DFN,"CCD","","","") "RTN","C0CCCD",36,0) S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1)) "RTN","C0CCCD",37,0) S ONAM=FN "RTN","C0CCCD",38,0) I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" "RTN","C0CCCD",39,0) S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) "RTN","C0CCCD",40,0) I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET "RTN","C0CCCD",41,0) . S @ODIRGLB="/home/glilly/CCROUT" "RTN","C0CCCD",42,0) . ;S @ODIRGLB="/home/cedwards/" "RTN","C0CCCD",43,0) . ;S @ODIRGLB="/opt/wv/p/" "RTN","C0CCCD",44,0) S ODIR=DIR "RTN","C0CCCD",45,0) I DIR="" S ODIR=@ODIRGLB "RTN","C0CCCD",46,0) N ZY "RTN","C0CCCD",47,0) S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) "RTN","C0CCCD",48,0) W $P(ZY,U,2) "RTN","C0CCCD",49,0) Q "RTN","C0CCCD",50,0) ; "RTN","C0CCCD",51,0) CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT "RTN","C0CCCD",52,0) ; CCRGRTN IS RETURN ARRAY PASSED BY NAME "RTN","C0CCCD",53,0) ; DFN IS PATIENT IEN "RTN","C0CCCD",54,0) ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART "RTN","C0CCCD",55,0) ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC "RTN","C0CCCD",56,0) ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL "RTN","C0CCCD",57,0) ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME "RTN","C0CCCD",58,0) ; - NULL MEANS NOW "RTN","C0CCCD",59,0) ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND "RTN","C0CCCD",60,0) ; "TO" VARIABLES "RTN","C0CCCD",61,0) ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN "RTN","C0CCCD",62,0) I '$D(DEBUG) S DEBUG=0 "RTN","C0CCCD",63,0) N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD "RTN","C0CCCD",64,0) I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD "RTN","C0CCCD",65,0) S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE "RTN","C0CCCD",66,0) I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD "RTN","C0CCCD",67,0) E S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR "RTN","C0CCCD",68,0) S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS "RTN","C0CCCD",69,0) ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC "RTN","C0CCCD",70,0) S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL "RTN","C0CCCD",71,0) I CCD D LOAD^C0CCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE "RTN","C0CCCD",72,0) E D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE "RTN","C0CCCD",73,0) D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL "RTN","C0CCCD",74,0) N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES "RTN","C0CCCD",75,0) S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT "RTN","C0CCCD",76,0) S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD "RTN","C0CCCD",77,0) S @CCDGLO@(3)="" ; CAP WITH CCR ROOT "RTN","C0CCCD",78,0) S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO "RTN","C0CCCD",79,0) S @CCDGLO@(@CCDGLO@(0))="" ; FINISH CAP "RTN","C0CCCD",80,0) S @TGLOBAL@(@TGLOBAL@(0))="" ; FINISH CAP TEMP "RTN","C0CCCD",81,0) ; "RTN","C0CCCD",82,0) ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL "RTN","C0CCCD",83,0) ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES "RTN","C0CCCD",84,0) D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body") "RTN","C0CCCD",85,0) D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors") "RTN","C0CCCD",86,0) I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures") "RTN","C0CCCD",87,0) I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),! "RTN","C0CCCD",88,0) ; "RTN","C0CCCD",89,0) I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES "RTN","C0CCCD",90,0) ; MAPPING THE PATIENT PORTION OF THE CDA HEADER "RTN","C0CCCD",91,0) S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient" "RTN","C0CCCD",92,0) D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1") "RTN","C0CCCD",93,0) D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT "RTN","C0CCCD",94,0) I DEBUG D PARY^C0CXPATH("ACTT2") "RTN","C0CCCD",95,0) D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX) "RTN","C0CCCD",96,0) I DEBUG D PARY^C0CXPATH(CCDGLO) "RTN","C0CCCD",97,0) K ACTT1 K ACCT2 "RTN","C0CCCD",98,0) ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER "RTN","C0CCCD",99,0) ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION "RTN","C0CCCD",100,0) D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG "RTN","C0CCCD",101,0) D CP^C0CXPATH("ACTT2",CCDGLO) "RTN","C0CCCD",102,0) ; "RTN","C0CCCD",103,0) K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT "RTN","C0CCCD",104,0) S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS "RTN","C0CCCD",105,0) D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS "RTN","C0CCCD",106,0) N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD "RTN","C0CCCD",107,0) F I=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS "RTN","C0CCCD",108,0) . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE "RTN","C0CCCD",109,0) . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL "RTN","C0CCCD",110,0) . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL "RTN","C0CCCD",111,0) . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE "RTN","C0CCCD",112,0) . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS "RTN","C0CCCD",113,0) . S IXML="INXML" "RTN","C0CCCD",114,0) . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION "RTN","C0CCCD",115,0) . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES "RTN","C0CCCD",116,0) . ; W OXML,! "RTN","C0CCCD",117,0) . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL "RTN","C0CCCD",118,0) . W "RUNNING ",CALL,! "RTN","C0CCCD",119,0) . X CALL "RTN","C0CCCD",120,0) . I @OXML@(0)'=0 D ; THERE IS A RESULT "RTN","C0CCCD",121,0) . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH "RTN","C0CCCD",122,0) . . I CCD D UNSHAVE("ITMP",OXML) "RTN","C0CCCD",123,0) . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION "RTN","C0CCCD",124,0) . ; NOW INSERT THE RESULTS IN THE CCR BUFFER "RTN","C0CCCD",125,0) . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body") "RTN","C0CCCD",126,0) . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! "RTN","C0CCCD",127,0) ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE "RTN","C0CCCD",128,0) ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST "RTN","C0CCCD",129,0) ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") "RTN","C0CCCD",130,0) ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") "RTN","C0CCCD",131,0) ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors") "RTN","C0CCCD",132,0) N I,J,DONE S DONE=0 "RTN","C0CCCD",133,0) F I=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE "RTN","C0CCCD",134,0) . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS "RTN","C0CCCD",135,0) . W "TRIMMED",J,! "RTN","C0CCCD",136,0) . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE "RTN","C0CCCD",137,0) I CCD D ; TURN THE BODY INTO A CCD COMPONENT "RTN","C0CCCD",138,0) . N I "RTN","C0CCCD",139,0) . F I=1:1:@CCDGLO@(0) D ; SEARCH THROUGH THE ENTIRE ARRAY "RTN","C0CCCD",140,0) . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP "RTN","C0CCCD",141,0) . . . S @CCDGLO@(I)="" ; WITH CCD EQ "RTN","C0CCCD",142,0) . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP "RTN","C0CCCD",143,0) . . . S @CCDGLO@(I)="" "RTN","C0CCCD",144,0) S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD "RTN","C0CCCD",145,0) S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE "RTN","C0CCCD",146,0) Q "RTN","C0CCCD",147,0) ; "RTN","C0CCCD",148,0) INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS "RTN","C0CCCD",149,0) ; TAB IS PASSED BY NAME "RTN","C0CCCD",150,0) W "TAB= ",TAB,! "RTN","C0CCCD",151,0) ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS "RTN","C0CCCD",152,0) D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") "RTN","C0CCCD",153,0) ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") "RTN","C0CCCD",154,0) I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") "RTN","C0CCCD",155,0) Q "RTN","C0CCCD",156,0) ; "RTN","C0CCCD",157,0) SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT "RTN","C0CCCD",158,0) ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION "RTN","C0CCCD",159,0) N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST "RTN","C0CCCD",160,0) W SHXML,! "RTN","C0CCCD",161,0) W @SHXML@(1),! "RTN","C0CCCD",162,0) D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED "RTN","C0CCCD",163,0) D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART "RTN","C0CCCD",164,0) D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE "RTN","C0CCCD",165,0) D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST "RTN","C0CCCD",166,0) D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION "RTN","C0CCCD",167,0) D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY "RTN","C0CCCD",168,0) Q "RTN","C0CCCD",169,0) ; "RTN","C0CCCD",170,0) UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE "RTN","C0CCCD",171,0) ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML "RTN","C0CCCD",172,0) N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST "RTN","C0CCCD",173,0) W SHXML,! "RTN","C0CCCD",174,0) W @SHXML@(1),! "RTN","C0CCCD",175,0) D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE "RTN","C0CCCD",176,0) D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST "RTN","C0CCCD",177,0) D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP "RTN","C0CCCD",178,0) D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST "RTN","C0CCCD",179,0) D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION "RTN","C0CCCD",180,0) D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY "RTN","C0CCCD",181,0) Q "RTN","C0CCCD",182,0) ; "RTN","C0CCCD",183,0) HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT "RTN","C0CCCD",184,0) N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) "RTN","C0CCCD",185,0) ; K @VMAP "RTN","C0CCCD",186,0) S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") "RTN","C0CCCD",187,0) I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS "RTN","C0CCCD",188,0) . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN "RTN","C0CCCD",189,0) . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? "RTN","C0CCCD",190,0) . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM "RTN","C0CCCD",191,0) . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES "RTN","C0CCCD",192,0) . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES "RTN","C0CCCD",193,0) . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES "RTN","C0CCCD",194,0) . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT "RTN","C0CCCD",195,0) I IHDR'="" D ; HEADER VALUES ARE PROVIDED "RTN","C0CCCD",196,0) . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY "RTN","C0CCCD",197,0) N CTMP "RTN","C0CCCD",198,0) D MAP^C0CXPATH(CXML,VMAP,"CTMP") "RTN","C0CCCD",199,0) D CP^C0CXPATH("CTMP",CXML) "RTN","C0CCCD",200,0) Q "RTN","C0CCCD",201,0) ; "RTN","C0CCCD",202,0) ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML "RTN","C0CCCD",203,0) ; AXML AND ACTRTN ARE PASSED BY NAME "RTN","C0CCCD",204,0) ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 "RTN","C0CCCD",205,0) ; P1= OBJECTID - ACTORPATIENT_2 "RTN","C0CCCD",206,0) ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE "RTN","C0CCCD",207,0) ;OR INSTITUTION "RTN","C0CCCD",208,0) ; OR PERSON(IN PATIENT FILE IE NOK) "RTN","C0CCCD",209,0) ; P3= IEN RECORD NUMBER FOR ACTOR - 2 "RTN","C0CCCD",210,0) N I,J,K,L "RTN","C0CCCD",211,0) K @ACTRTN ; CLEAR RETURN ARRAY "RTN","C0CCCD",212,0) F I=1:1:@AXML@(0) D ; SCAN ALL LINES "RTN","C0CCCD",213,0) . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE "RTN","C0CCCD",214,0) . . S J=$P($P(@AXML@(I),"",2),"",1) "RTN","C0CCCD",215,0) . . W "=>",J,! "RTN","C0CCCD",216,0) . . I J'="" S K(J)="" ; HASHING ACTOR "RTN","C0CCCD",217,0) . . ; TO GET RID OF DUPLICATES "RTN","C0CCCD",218,0) S I="" ; GOING TO $O THROUGH THE HASH "RTN","C0CCCD",219,0) F J=0:0 D Q:$O(K(I))="" ; "RTN","C0CCCD",220,0) . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS "RTN","C0CCCD",221,0) . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID "RTN","C0CCCD",222,0) . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE "RTN","C0CCCD",223,0) . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR "RTN","C0CCCD",224,0) . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY "RTN","C0CCCD",225,0) Q "RTN","C0CCCD",226,0) ; "RTN","C0CCCD",227,0) TEST ; RUN ALL THE TEST CASES "RTN","C0CCCD",228,0) D TESTALL^C0CUNIT("C0CCCR") "RTN","C0CCCD",229,0) Q "RTN","C0CCCD",230,0) ; "RTN","C0CCCD",231,0) ZTEST(WHICH) ; RUN ONE SET OF TESTS "RTN","C0CCCD",232,0) N ZTMP "RTN","C0CCCD",233,0) D ZLOAD^C0CUNIT("ZTMP","C0CCCR") "RTN","C0CCCD",234,0) D ZTEST^C0CUNIT(.ZTMP,WHICH) "RTN","C0CCCD",235,0) Q "RTN","C0CCCD",236,0) ; "RTN","C0CCCD",237,0) TLIST ; LIST THE TESTS "RTN","C0CCCD",238,0) N ZTMP "RTN","C0CCCD",239,0) D ZLOAD^C0CUNIT("ZTMP","C0CCCR") "RTN","C0CCCD",240,0) D TLIST^C0CUNIT(.ZTMP) "RTN","C0CCCD",241,0) Q "RTN","C0CCCD",242,0) ; "RTN","C0CCCD",243,0) ;;> "RTN","C0CCCD",244,0) ;;> "RTN","C0CCCD",245,0) ;;>>>K C0C S C0C="" "RTN","C0CCCD",246,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","") "RTN","C0CCCD",247,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCD",248,0) ;;> "RTN","C0CCCD",249,0) ;;>>>K C0C S C0C="" "RTN","C0CCCD",250,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","") "RTN","C0CCCD",251,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCD",252,0) ;;> "RTN","C0CCCD",253,0) ;;>>>K C0C S C0C="" "RTN","C0CCCD",254,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") "RTN","C0CCCD",255,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCD",256,0) ;;> "RTN","C0CCCD",257,0) ;;>>>K C0C S C0C="" "RTN","C0CCCD",258,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") "RTN","C0CCCD",259,0) ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") "RTN","C0CCCD",260,0) ;;> "RTN","C0CCCD",261,0) ;;>>>D ZTEST^C0CCCR("ACTLST") "RTN","C0CCCD",262,0) ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") "RTN","C0CCCD",263,0) ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") "RTN","C0CCCD",264,0) ;;>>?G3(G3(0))["" "RTN","C0CCCD",265,0) ;;> "RTN","C0CCCD",266,0) ;;>>>D ZTEST^C0CCCR("CCR") "RTN","C0CCCD",267,0) ;;>>>W $$TRIM^C0CXPATH(CCDGLO) "RTN","C0CCCD",268,0) ;;> "RTN","C0CCCD",269,0) ;;>>>K C0C S C0C="" "RTN","C0CCCD",270,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","") "RTN","C0CCCD",271,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCD",272,0) ;;> "RTN","C0CCCD1") 0^5^B100634737 "RTN","C0CCCD1",1,0) C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 "RTN","C0CCCD1",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CCCD1",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CCCD1",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CCCD1",5,0) ;See attached copy of the License. "RTN","C0CCCD1",6,0) ; "RTN","C0CCCD1",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CCCD1",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CCCD1",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CCCD1",10,0) ;(at your option) any later version. "RTN","C0CCCD1",11,0) ; "RTN","C0CCCD1",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CCCD1",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CCCD1",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CCCD1",15,0) ;GNU General Public License for more details. "RTN","C0CCCD1",16,0) ; "RTN","C0CCCD1",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CCCD1",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CCCD1",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CCCD1",20,0) ; "RTN","C0CCCD1",21,0) W "This is a CCD TEMPLATE with processing routines",! "RTN","C0CCCD1",22,0) W ! "RTN","C0CCCD1",23,0) Q "RTN","C0CCCD1",24,0) ; "RTN","C0CCCD1",25,0) ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array "RTN","C0CCCD1",26,0) ; ZARY IS PASSED BY NAME "RTN","C0CCCD1",27,0) ; BAT is a string identifying the section "RTN","C0CCCD1",28,0) ; LINE is a test which will evaluate to true or false "RTN","C0CCCD1",29,0) ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' "RTN","C0CCCD1",30,0) ; . S @ZARY@(0)=0 ; initially there are no elements "RTN","C0CCCD1",31,0) ; . W "GOT HERE LOADING "_LINE,! "RTN","C0CCCD1",32,0) N CNT ; count of array elements "RTN","C0CCCD1",33,0) S CNT=@ZARY@(0) ; contains array count "RTN","C0CCCD1",34,0) S CNT=CNT+1 ; increment count "RTN","C0CCCD1",35,0) S @ZARY@(CNT)=LINE ; put the line in the array "RTN","C0CCCD1",36,0) ; S @ZARY@(BAT,CNT)="" ; index the test by battery "RTN","C0CCCD1",37,0) S @ZARY@(0)=CNT ; update the array counter "RTN","C0CCCD1",38,0) Q "RTN","C0CCCD1",39,0) ; "RTN","C0CCCD1",40,0) ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference "RTN","C0CCCD1",41,0) ; ZARY IS PASSED BY NAME "RTN","C0CCCD1",42,0) ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") "RTN","C0CCCD1",43,0) ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE "RTN","C0CCCD1",44,0) K @ZARY S @ZARY="" "RTN","C0CCCD1",45,0) S @ZARY@(0)=0 ; initialize array count "RTN","C0CCCD1",46,0) N LINE,LABEL,BODY "RTN","C0CCCD1",47,0) N INTEST S INTEST=0 ; switch for in the TEMPLATE section "RTN","C0CCCD1",48,0) N SECTION S SECTION="[anonymous]" ; NO section LABEL "RTN","C0CCCD1",49,0) ; "RTN","C0CCCD1",50,0) N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D "RTN","C0CCCD1",51,0) . I LINE?." "1";".E S INTEST=0 ; leaving section "RTN","C0CCCD1",53,0) . I INTEST D ; within the section "RTN","C0CCCD1",54,0) . . I LINE?." "1";><".E D ; sub-section name found "RTN","C0CCCD1",55,0) . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name "RTN","C0CCCD1",56,0) . . I LINE?." "1";;".E D ; line found "RTN","C0CCCD1",57,0) . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array "RTN","C0CCCD1",58,0) Q "RTN","C0CCCD1",59,0) ; "RTN","C0CCCD1",60,0) LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME "RTN","C0CCCD1",61,0) D ZLOAD(ARY,"C0CCCD1") "RTN","C0CCCD1",62,0) ; ZWR @ARY "RTN","C0CCCD1",63,0) Q "RTN","C0CCCD1",64,0) ; "RTN","C0CCCD1",65,0) TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD "RTN","C0CCCD1",66,0) Q "RTN","C0CCCD1",67,0) MARKUP ; "RTN","C0CCCD1",68,0) ;; "RTN","C0CCCD1",69,0) ;; "RTN","C0CCCD1",70,0) ;; "RTN","C0CCCD1",71,0) ;; "RTN","C0CCCD1",72,0) ;; "RTN","C0CCCD1",73,0) ;; "RTN","C0CCCD1",74,0) ;; "RTN","C0CCCD1",75,0) ;; "RTN","C0CCCD1",76,0) ;; "RTN","C0CCCD1",77,0) ;; "RTN","C0CCCD1",78,0) ;; "RTN","C0CCCD1",79,0) ;; "RTN","C0CCCD1",80,0) ;; "RTN","C0CCCD1",81,0) ;; "RTN","C0CCCD1",82,0) ;; "RTN","C0CCCD1",83,0) ;; "RTN","C0CCCD1",84,0) ;; "RTN","C0CCCD1",85,0) ; "RTN","C0CCCD1",86,0) ;; "RTN","C0CCCD1",87,0) ;; "RTN","C0CCCD1",88,0) Q "RTN","C0CCCD1",89,0) ; "RTN","C0CCCD1",90,0) ; "RTN","C0CCCR") 0^6^B105501729 "RTN","C0CCCR",1,0) C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 "RTN","C0CCCR",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CCCR",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CCCR",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CCCR",5,0) ;See attached copy of the License. "RTN","C0CCCR",6,0) ; "RTN","C0CCCR",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CCCR",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CCCR",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CCCR",10,0) ;(at your option) any later version. "RTN","C0CCCR",11,0) ; "RTN","C0CCCR",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CCCR",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CCCR",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CCCR",15,0) ;GNU General Public License for more details. "RTN","C0CCCR",16,0) ; "RTN","C0CCCR",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CCCR",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CCCR",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CCCR",20,0) ; "RTN","C0CCCR",21,0) ; EXPORT A CCR "RTN","C0CCCR",22,0) ; "RTN","C0CCCR",23,0) EXPORT ; EXPORT ENTRY POINT FOR CCR "RTN","C0CCCR",24,0) ; Select a patient. "RTN","C0CCCR",25,0) S DIC=2,DIC(0)="AEMQ" D ^DIC "RTN","C0CCCR",26,0) I Y<1 Q ; EXIT "RTN","C0CCCR",27,0) S DFN=$P(Y,U,1) ; SET THE PATIENT "RTN","C0CCCR",28,0) ;OHUM/RUT 3120102 To take inputs from user for date limits and notes "RTN","C0CCCR",29,0) D ^C0CVALID "RTN","C0CCCR",30,0) ;OHUM/RUT "RTN","C0CCCR",31,0) D XPAT(DFN) ; EXPORT TO A FILE "RTN","C0CCCR",32,0) Q "RTN","C0CCCR",33,0) ; "RTN","C0CCCR",34,0) XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE "RTN","C0CCCR",35,0) ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") "RTN","C0CCCR",36,0) ; FN IS FILE NAME, DEFAULTS IF NULL "RTN","C0CCCR",37,0) N CCRGLO,UDIR,UFN "RTN","C0CCCR",38,0) S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC "RTN","C0CCCR",39,0) I '$D(DIR) S UDIR="" "RTN","C0CCCR",40,0) E S UDIR=DIR "RTN","C0CCCR",41,0) I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED "RTN","C0CCCR",42,0) E S UFN=FN "RTN","C0CCCR",43,0) I '$D(XPARMS) S XPARMS="" "RTN","C0CCCR",44,0) N C0CRTN ; RETURN ARRAY "RTN","C0CCCR",45,0) D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR") "RTN","C0CCCR",46,0) S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1)) "RTN","C0CCCR",47,0) S ONAM=UFN "RTN","C0CCCR",48,0) I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml" "RTN","C0CCCR",49,0) S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) "RTN","C0CCCR",50,0) S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE "RTN","C0CCCR",51,0) I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR") "RTN","C0CCCR",52,0) I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET "RTN","C0CCCR",53,0) . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q "RTN","C0CCCR",54,0) . ;S @ODIRGLB="/home/glilly/CCROUT" "RTN","C0CCCR",55,0) . ;S @ODIRGLB="/home/cedwards/" "RTN","C0CCCR",56,0) . S @ODIRGLB="/opt/wv/p/" "RTN","C0CCCR",57,0) S ODIR=UDIR "RTN","C0CCCR",58,0) I UDIR="" S ODIR=@ODIRGLB "RTN","C0CCCR",59,0) N ZY "RTN","C0CCCR",60,0) S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) "RTN","C0CCCR",61,0) W !,$P(ZY,U,2),! "RTN","C0CCCR",62,0) Q "RTN","C0CCCR",63,0) ; "RTN","C0CCCR",64,0) DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED "RTN","C0CCCR",65,0) ; "RTN","C0CCCR",66,0) N G1 "RTN","C0CCCR",67,0) S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) "RTN","C0CCCR",68,0) I $D(@G1@(0)) D ; CCR EXISTS "RTN","C0CCCR",69,0) . D PARY^C0CXPATH(G1) "RTN","C0CCCR",70,0) E W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",! "RTN","C0CCCR",71,0) Q "RTN","C0CCCR",72,0) ; "RTN","C0CCCR",73,0) CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT "RTN","C0CCCR",74,0) ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE "RTN","C0CCCR",75,0) ; DFN IS PATIENT IEN "RTN","C0CCCR",76,0) ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART "RTN","C0CCCR",77,0) ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC "RTN","C0CCCR",78,0) ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION "RTN","C0CCCR",79,0) ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2" "RTN","C0CCCR",80,0) ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS "RTN","C0CCCR",81,0) ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS "RTN","C0CCCR",82,0) K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT "RTN","C0CCCR",83,0) M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS "RTN","C0CCCR",84,0) K ^TMP($J) ; START CLEAN "RTN","C0CCCR",85,0) I '$D(DEBUG) S DEBUG=0 "RTN","C0CCCR",86,0) S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD "RTN","C0CCCR",87,0) I '$D(CCRPARMS) S CCRPARMS="" "RTN","C0CCCR",88,0) I '$D(CCRPART) S CCRPART="CCR" "RTN","C0CCCR",89,0) I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)="" "RTN","C0CCCR",90,0) D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES "RTN","C0CCCR",91,0) I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS "RTN","C0CCCR",92,0) I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION "RTN","C0CCCR",93,0) I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION "RTN","C0CCCR",94,0) I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION "RTN","C0CCCR",95,0) S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE "RTN","C0CCCR",96,0) S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR "RTN","C0CCCR",97,0) S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS "RTN","C0CCCR",98,0) ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC "RTN","C0CCCR",99,0) ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL "RTN","C0CCCR",100,0) D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE "RTN","C0CCCR",101,0) D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL "RTN","C0CCCR",102,0) ; "RTN","C0CCCR",103,0) ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL "RTN","C0CCCR",104,0) ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES "RTN","C0CCCR",105,0) D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") "RTN","C0CCCR",106,0) D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") "RTN","C0CCCR",107,0) D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") "RTN","C0CCCR",108,0) D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments") "RTN","C0CCCR",109,0) I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! "RTN","C0CCCR",110,0) ; "RTN","C0CCCR",111,0) D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES "RTN","C0CCCR",112,0) ; "RTN","C0CCCR",113,0) K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT "RTN","C0CCCR",114,0) S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS "RTN","C0CCCR",115,0) D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS "RTN","C0CCCR",116,0) N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD "RTN","C0CCCR",117,0) F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS "RTN","C0CCCR",118,0) . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE "RTN","C0CCCR",119,0) . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL "RTN","C0CCCR",120,0) . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL "RTN","C0CCCR",121,0) . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE "RTN","C0CCCR",122,0) . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS "RTN","C0CCCR",123,0) . S IXML="INXML" "RTN","C0CCCR",124,0) . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES "RTN","C0CCCR",125,0) . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY "RTN","C0CCCR",126,0) . ; W OXML,! "RTN","C0CCCR",127,0) . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL "RTN","C0CCCR",128,0) . W "RUNNING ",CALL,! "RTN","C0CCCR",129,0) . X CALL "RTN","C0CCCR",130,0) . ; NOW INSERT THE RESULTS IN THE CCR BUFFER "RTN","C0CCCR",131,0) . I $G(@OXML@(0))>0 D ; THERE IS A RESULT "RTN","C0CCCR",132,0) . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") "RTN","C0CCCR",133,0) . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! "RTN","C0CCCR",134,0) N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING "RTN","C0CCCR",135,0) D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST "RTN","C0CCCR",136,0) D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") "RTN","C0CCCR",137,0) D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") "RTN","C0CCCR",138,0) D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") "RTN","C0CCCR",139,0) K ACTT,ACTT2 "RTN","C0CCCR",140,0) ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") "RTN","C0CCCR",141,0) ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") "RTN","C0CCCR",142,0) ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") "RTN","C0CCCR",143,0) ; gpl - turned off Comments for Certification "RTN","C0CCCR",144,0) K CMTT,CMTT2 "RTN","C0CCCR",145,0) N TRIMI,J,DONE S DONE=0 "RTN","C0CCCR",146,0) F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE "RTN","C0CCCR",147,0) . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS "RTN","C0CCCR",148,0) . I DEBUG W "TRIMMED",J,! "RTN","C0CCCR",149,0) . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE "RTN","C0CCCR",150,0) ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL "RTN","C0CCCR",151,0) I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR "RTN","C0CCCR",152,0) E M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART "RTN","C0CCCR",153,0) I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))="" "RTN","C0CCCR",154,0) K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP "RTN","C0CCCR",155,0) K ^TMP($J) ; REALLY CLEAN UP "RTN","C0CCCR",156,0) M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J "RTN","C0CCCR",157,0) Q "RTN","C0CCCR",158,0) ; "RTN","C0CCCR",159,0) INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS "RTN","C0CCCR",160,0) ; TAB IS PASSED BY NAME "RTN","C0CCCR",161,0) I DEBUG W "TAB= ",TAB,! "RTN","C0CCCR",162,0) ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS "RTN","C0CCCR",163,0) D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") "RTN","C0CCCR",164,0) I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") "RTN","C0CCCR",165,0) D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") "RTN","C0CCCR",166,0) D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") "RTN","C0CCCR",167,0) I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") "RTN","C0CCCR",168,0) E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") "RTN","C0CCCR",169,0) D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") "RTN","C0CCCR",170,0) D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") "RTN","C0CCCR",171,0) ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") "RTN","C0CCCR",172,0) ; gpl - turned off Encounters for Certification "RTN","C0CCCR",173,0) ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not "RTN","C0CCCR",174,0) I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") "RTN","C0CCCR",175,0) ;OHUM/RUT "RTN","C0CCCR",176,0) Q "RTN","C0CCCR",177,0) ; "RTN","C0CCCR",178,0) HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT "RTN","C0CCCR",179,0) N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) "RTN","C0CCCR",180,0) ; K @VMAP "RTN","C0CCCR",181,0) S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") "RTN","C0CCCR",182,0) ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS "RTN","C0CCCR",183,0) D ; ALWAYS MAP THESE VARIABLES "RTN","C0CCCR",184,0) . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR "RTN","C0CCCR",185,0) . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN "RTN","C0CCCR",186,0) . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER "RTN","C0CCCR",187,0) . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? "RTN","C0CCCR",188,0) . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM "RTN","C0CCCR",189,0) . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES "RTN","C0CCCR",190,0) . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES "RTN","C0CCCR",191,0) . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES "RTN","C0CCCR",192,0) . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT "RTN","C0CCCR",193,0) ;I IHDR'="" D ; HEADER VALUES ARE PROVIDED "RTN","C0CCCR",194,0) ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY "RTN","C0CCCR",195,0) N CTMP "RTN","C0CCCR",196,0) D MAP^C0CXPATH(CXML,VMAP,"CTMP") "RTN","C0CCCR",197,0) D CP^C0CXPATH("CTMP",CXML) "RTN","C0CCCR",198,0) N HRIMVARS ; "RTN","C0CCCR",199,0) S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS "RTN","C0CCCR",200,0) M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE "RTN","C0CCCR",201,0) S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT "RTN","C0CCCR",202,0) Q "RTN","C0CCCR",203,0) ; "RTN","C0CCCR",204,0) ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML "RTN","C0CCCR",205,0) ; AXML AND ACTRTN ARE PASSED BY NAME "RTN","C0CCCR",206,0) ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 "RTN","C0CCCR",207,0) ; P1= OBJECTID - ACTORPATIENT_2 "RTN","C0CCCR",208,0) ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE "RTN","C0CCCR",209,0) ;OR INSTITUTION "RTN","C0CCCR",210,0) ; OR PERSON(IN PATIENT FILE IE NOK) "RTN","C0CCCR",211,0) ; P3= IEN RECORD NUMBER FOR ACTOR - 2 "RTN","C0CCCR",212,0) N I,J,K,L "RTN","C0CCCR",213,0) K @ACTRTN ; CLEAR RETURN ARRAY "RTN","C0CCCR",214,0) F I=1:1:@AXML@(0) D ; FIRST FIX MISSING LINKS "RTN","C0CCCR",215,0) . I @AXML@(I)?.E1"_<".E D ; "RTN","C0CCCR",216,0) . . N ZA,ZB "RTN","C0CCCR",217,0) . . S ZA=$P(@AXML@(I),">",1)_">" "RTN","C0CCCR",218,0) . . S ZB="<"_$P(@AXML@(I),"<",3) "RTN","C0CCCR",219,0) . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB "RTN","C0CCCR",220,0) F I=1:1:@AXML@(0) D ; SCAN ALL LINES "RTN","C0CCCR",221,0) . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE "RTN","C0CCCR",222,0) . . S J=$P($P(@AXML@(I),"",2),"",1) "RTN","C0CCCR",223,0) . . I $G(LINKDEBUG) W "=>",J,! "RTN","C0CCCR",224,0) . . I J'="" S K(J)="" ; HASHING ACTOR "RTN","C0CCCR",225,0) . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE "RTN","C0CCCR",226,0) . . S J=$P($P(@AXML@(I),"",2),"",1) "RTN","C0CCCR",227,0) . . I $G(LINKDEBUG) W "=>",J,! "RTN","C0CCCR",228,0) . . I J'="" S K(J)="" ; HASHING ACTOR "RTN","C0CCCR",229,0) . . ; TO GET RID OF DUPLICATES "RTN","C0CCCR",230,0) S I="" ; GOING TO $O THROUGH THE HASH "RTN","C0CCCR",231,0) F J=0:0 D Q:$O(K(I))="" "RTN","C0CCCR",232,0) . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS "RTN","C0CCCR",233,0) . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID "RTN","C0CCCR",234,0) . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE "RTN","C0CCCR",235,0) . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR "RTN","C0CCCR",236,0) . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY "RTN","C0CCCR",237,0) Q "RTN","C0CCCR",238,0) ; "RTN","C0CCCR",239,0) TEST ; RUN ALL THE TEST CASES "RTN","C0CCCR",240,0) D TESTALL^C0CUNIT("C0CCCR") "RTN","C0CCCR",241,0) Q "RTN","C0CCCR",242,0) ; "RTN","C0CCCR",243,0) ZTEST(WHICH) ; RUN ONE SET OF TESTS "RTN","C0CCCR",244,0) N ZTMP "RTN","C0CCCR",245,0) D ZLOAD^C0CUNIT("ZTMP","C0CCCR") "RTN","C0CCCR",246,0) D ZTEST^C0CUNIT(.ZTMP,WHICH) "RTN","C0CCCR",247,0) Q "RTN","C0CCCR",248,0) ; "RTN","C0CCCR",249,0) TLIST ; LIST THE TESTS "RTN","C0CCCR",250,0) N ZTMP "RTN","C0CCCR",251,0) D ZLOAD^C0CUNIT("ZTMP","C0CCCR") "RTN","C0CCCR",252,0) D TLIST^C0CUNIT(.ZTMP) "RTN","C0CCCR",253,0) Q "RTN","C0CCCR",254,0) ; "RTN","C0CCCR",255,0) ;;> "RTN","C0CCCR",256,0) ;;> "RTN","C0CCCR",257,0) ;;>>>K C0C S C0C="" "RTN","C0CCCR",258,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","") "RTN","C0CCCR",259,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCR",260,0) ;;> "RTN","C0CCCR",261,0) ;;>>>K C0C S C0C="" "RTN","C0CCCR",262,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","") "RTN","C0CCCR",263,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCR",264,0) ;;> "RTN","C0CCCR",265,0) ;;>>>K C0C S C0C="" "RTN","C0CCCR",266,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") "RTN","C0CCCR",267,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCR",268,0) ;;> "RTN","C0CCCR",269,0) ;;>>>K C0C S C0C="" "RTN","C0CCCR",270,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") "RTN","C0CCCR",271,0) ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") "RTN","C0CCCR",272,0) ;;> "RTN","C0CCCR",273,0) ;;>>>D ZTEST^C0CCCR("ACTLST") "RTN","C0CCCR",274,0) ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") "RTN","C0CCCR",275,0) ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") "RTN","C0CCCR",276,0) ;;>>?G3(G3(0))["" "RTN","C0CCCR",277,0) ;;> "RTN","C0CCCR",278,0) ;;>>>D ZTEST^C0CCCR("CCR") "RTN","C0CCCR",279,0) ;;>>>W $$TRIM^C0CXPATH(CCRGLO) "RTN","C0CCCR",280,0) ;;> "RTN","C0CCCR",281,0) ;;>>>S TESTALERT=1 "RTN","C0CCCR",282,0) ;;>>>K C0C S C0C="" "RTN","C0CCCR",283,0) ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","") "RTN","C0CCCR",284,0) ;;>>?@C0C@(@C0C@(0))["" "RTN","C0CCCR",285,0) "RTN","C0CCCR",286,0) "RTN","C0CCCR0") 0^7^B790419172 "RTN","C0CCCR0",1,0) C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 "RTN","C0CCCR0",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CCCR0",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CCCR0",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CCCR0",5,0) ;See attached copy of the License. "RTN","C0CCCR0",6,0) ; "RTN","C0CCCR0",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CCCR0",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CCCR0",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CCCR0",10,0) ;(at your option) any later version. "RTN","C0CCCR0",11,0) ; "RTN","C0CCCR0",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CCCR0",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CCCR0",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CCCR0",15,0) ;GNU General Public License for more details. "RTN","C0CCCR0",16,0) ; "RTN","C0CCCR0",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CCCR0",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CCCR0",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CCCR0",20,0) ; "RTN","C0CCCR0",21,0) W "This is a CCR TEMPLATE with processing routines",! "RTN","C0CCCR0",22,0) W ! "RTN","C0CCCR0",23,0) Q "RTN","C0CCCR0",24,0) ; "RTN","C0CCCR0",25,0) ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array "RTN","C0CCCR0",26,0) ; ZARY IS PASSED BY NAME "RTN","C0CCCR0",27,0) ; BAT is a string identifying the section "RTN","C0CCCR0",28,0) ; LINE is a test which will evaluate to true or false "RTN","C0CCCR0",29,0) ; I '$G(@ZARY) D ; "RTN","C0CCCR0",30,0) ; . S @ZARY@(0)=0 ; initially there are no elements "RTN","C0CCCR0",31,0) ; . W "GOT HERE LOADING "_LINE,! "RTN","C0CCCR0",32,0) N CNT ; count of array elements "RTN","C0CCCR0",33,0) S CNT=@ZARY@(0) ; contains array count "RTN","C0CCCR0",34,0) S CNT=CNT+1 ; increment count "RTN","C0CCCR0",35,0) S @ZARY@(CNT)=LINE ; put the line in the array "RTN","C0CCCR0",36,0) ; S @ZARY@(BAT,CNT)="" ; index the test by battery "RTN","C0CCCR0",37,0) S @ZARY@(0)=CNT ; update the array counter "RTN","C0CCCR0",38,0) Q "RTN","C0CCCR0",39,0) ; "RTN","C0CCCR0",40,0) ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference "RTN","C0CCCR0",41,0) ; ZARY IS PASSED BY NAME "RTN","C0CCCR0",42,0) ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") "RTN","C0CCCR0",43,0) ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE "RTN","C0CCCR0",44,0) K @ZARY S @ZARY="" "RTN","C0CCCR0",45,0) S @ZARY@(0)=0 ; initialize array count "RTN","C0CCCR0",46,0) N LINE,LABEL,BODY "RTN","C0CCCR0",47,0) N INTEST S INTEST=0 ; switch for in the TEMPLATE section "RTN","C0CCCR0",48,0) N SECTION S SECTION="[anonymous]" ; NO section LABEL "RTN","C0CCCR0",49,0) ; "RTN","C0CCCR0",50,0) N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D "RTN","C0CCCR0",51,0) . I LINE?." "1";".E S INTEST=0 ; leaving section "RTN","C0CCCR0",53,0) . I INTEST D ; within the section "RTN","C0CCCR0",54,0) . . I LINE?." "1";><".E D ; sub-section name found "RTN","C0CCCR0",55,0) . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name "RTN","C0CCCR0",56,0) . . I LINE?." "1";;".E D ; line found "RTN","C0CCCR0",57,0) . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array "RTN","C0CCCR0",58,0) Q "RTN","C0CCCR0",59,0) ; "RTN","C0CCCR0",60,0) LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME "RTN","C0CCCR0",61,0) D ZLOAD(ARY,"C0CCCR0") "RTN","C0CCCR0",62,0) ; ZWR @ARY "RTN","C0CCCR0",63,0) Q "RTN","C0CCCR0",64,0) ; "RTN","C0CCCR0",65,0) ; "RTN","C0CCMT") 0^8^B6740701 "RTN","C0CCMT",1,0) C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 "RTN","C0CCMT",2,0) ;;1.0;C0C;;May 21, 2010;Build 1 "RTN","C0CCMT",3,0) ;Copyright 2010 George Lilly, University of Minnesota and others. "RTN","C0CCMT",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CCMT",5,0) ;See attached copy of the License. "RTN","C0CCMT",6,0) ; "RTN","C0CCMT",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CCMT",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CCMT",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CCMT",10,0) ;(at your option) any later version. "RTN","C0CCMT",11,0) ; "RTN","C0CCMT",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CCMT",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CCMT",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CCMT",15,0) ;GNU General Public License for more details. "RTN","C0CCMT",16,0) ; "RTN","C0CCMT",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CCMT",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CCMT",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CCMT",20,0) ; "RTN","C0CCMT",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CCMT",22,0) Q "RTN","C0CCMT",23,0) ; "RTN","C0CCMT",24,0) EXTRACT(NOTEXML,DFN,NOTEOUT) ; EXTRACT NOTES INTO XML TEMPLATE "RTN","C0CCMT",25,0) ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CCMT",26,0) ; "RTN","C0CCMT",27,0) D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES "RTN","C0CCMT",28,0) ;I '$D(@C0CNTE) Q ; NO NOTES AVAILABLE "RTN","C0CCMT",29,0) D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES "RTN","C0CCMT",30,0) Q "RTN","C0CCMT",31,0) ; "RTN","C0CCMT",32,0) MAP(NOTEXML,C0CNTE,NOTEOUT) ; MAP PROCEDURES XML "RTN","C0CCMT",33,0) ; "RTN","C0CCMT",34,0) N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE "RTN","C0CCMT",35,0) K @ZTEMP "RTN","C0CCMT",36,0) N ZBLD "RTN","C0CCMT",37,0) S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA "RTN","C0CCMT",38,0) D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE "RTN","C0CCMT",39,0) N ZINNER "RTN","C0CCMT",40,0) D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE "RTN","C0CCMT",41,0) N ZTMP,ZVAR,ZI "RTN","C0CCMT",42,0) S ZI="" "RTN","C0CCMT",43,0) F S ZI=$O(@C0CNTE@(ZI)) Q:ZI="" D ;FOR EACH NOTE "RTN","C0CCMT",44,0) . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML "RTN","C0CCMT",45,0) . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES "RTN","C0CCMT",46,0) . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE "RTN","C0CCMT",47,0) . N ZNOTE,ZN "RTN","C0CCMT",48,0) . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED "RTN","C0CCMT",49,0) . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD "RTN","C0CCMT",50,0) . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE "RTN","C0CCMT",51,0) . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text") "RTN","C0CCMT",52,0) . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD "RTN","C0CCMT",53,0) D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0)) "RTN","C0CCMT",54,0) N ZZTMP "RTN","C0CCMT",55,0) D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML "RTN","C0CCMT",56,0) K @ZTEMP,@ZBLD,@C0CNTE "RTN","C0CCMT",57,0) Q "RTN","C0CCMT",58,0) ; "RTN","C0CCMT",59,0) CLEAN(INARY) ; INARY IS PASSED BY NAME "RTN","C0CCMT",60,0) ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY "RTN","C0CCMT",61,0) N ZI,ZJ S ZI="" "RTN","C0CCMT",62,0) F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; "RTN","C0CCMT",63,0) . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS "RTN","C0CCMT",64,0) . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS "RTN","C0CCMT",65,0) Q "RTN","C0CCMT",66,0) ; "RTN","C0CCPT") 0^9^B14724357 "RTN","C0CCPT",1,0) C0CCPT ;;BSL;RETURN CPT DATA; "RTN","C0CCPT",2,0) ;Sequence Managers Software GPL;;;;;Build 1 "RTN","C0CCPT",3,0) ;Copied into C0C namespace from SQMCPT with permission from "RTN","C0CCPT",4,0) ;Brian Lord - and with our thanks. gpl 01/20/2010 "RTN","C0CCPT",5,0) ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES "RTN","C0CCPT",6,0) ;DFN=PATIENT IEN "RTN","C0CCPT",7,0) ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) "RTN","C0CCPT",8,0) ;ENDDT=END DATE IN 3100101 FORMAT "RTN","C0CCPT",9,0) ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE "RTN","C0CCPT",10,0) ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME "RTN","C0CCPT",11,0) ;ALL INCLUSIVE IN THAT DIRECTION "RTN","C0CCPT",12,0) ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) "RTN","C0CCPT",13,0) ;BUILD INTO NOTE(Y)="" "RTN","C0CCPT",14,0) S U="^",X="" "RTN","C0CCPT",15,0) F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D "RTN","C0CCPT",16,0) . S Y="" "RTN","C0CCPT",17,0) . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D "RTN","C0CCPT",18,0) .. S NOTE(Y)="" "RTN","C0CCPT",19,0) ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE "RTN","C0CCPT",20,0) ;GET DATE OF NOTE "RTN","C0CCPT",21,0) ;OHUM/RUT 3111228 Date Range for Notes "RTN","C0CCPT",22,0) S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X "RTN","C0CCPT",23,0) ;OHUM/RUT "RTN","C0CCPT",24,0) S Z="" "RTN","C0CCPT",25,0) F S Z=$O(NOTE(Z)) Q:Z="" D "RTN","C0CCPT",26,0) . S DT=$P(^TIU(8925,Z,0),U,7) "RTN","C0CCPT",27,0) . I $G(STDT)]"" D "RTN","C0CCPT",28,0) .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED "RTN","C0CCPT",29,0) . I $G(ENDDT)]"" D "RTN","C0CCPT",30,0) .. I ENDDT
0) "RTN","C0CCPT",42,0) . D ENCEVENT^PXKENC(VISIT,1) "RTN","C0CCPT",43,0) . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q "RTN","C0CCPT",44,0) . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D "RTN","C0CCPT",45,0) .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) "RTN","C0CCPT",46,0) .. ;Q:$P(X0,U,4)'="P" "RTN","C0CCPT",47,0) .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) "RTN","C0CCPT",48,0) .. S PRIM=($P(X0,U,4)="P") "RTN","C0CCPT",49,0) .. S ILST=ILST+1 "RTN","C0CCPT",50,0) .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM "RTN","C0CCPT",51,0) .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM "RTN","C0CCPT",52,0) . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D "RTN","C0CCPT",53,0) .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) "RTN","C0CCPT",54,0) .. S CODE=$P(X0,U) "RTN","C0CCPT",55,0) .. S:CODE CODE=$P(^ICD9(CODE,0),U) "RTN","C0CCPT",56,0) .. S CAT=$P(X802,U) "RTN","C0CCPT",57,0) .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) "RTN","C0CCPT",58,0) .. S NARR=$P(X0,U,4) "RTN","C0CCPT",59,0) .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) "RTN","C0CCPT",60,0) .. S PRIM=($P(X0,U,12)="P") "RTN","C0CCPT",61,0) .. S PRV=$P(X12,U,4) "RTN","C0CCPT",62,0) .. S ILST=ILST+1 "RTN","C0CCPT",63,0) .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV "RTN","C0CCPT",64,0) .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV "RTN","C0CCPT",65,0) . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D "RTN","C0CCPT",66,0) .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) "RTN","C0CCPT",67,0) .. ;S CODE=$P(X0,U) "RTN","C0CCPT",68,0) .. S CODE=$O(^ICPT("B",$P(X0,U),0)) "RTN","C0CCPT",69,0) .. S:CODE CODE=$P(^ICPT(CODE,0),U) "RTN","C0CCPT",70,0) .. S CAT=$P(X802,U) "RTN","C0CCPT",71,0) .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) "RTN","C0CCPT",72,0) .. S NARR=$P(X0,U,4) "RTN","C0CCPT",73,0) .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) "RTN","C0CCPT",74,0) .. S QTY=$P(X0,U,16) "RTN","C0CCPT",75,0) .. S PRV=$P(X12,U,4) "RTN","C0CCPT",76,0) .. S MCNT=0,MIDX=0,MODS="" "RTN","C0CCPT",77,0) .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D "RTN","C0CCPT",78,0) ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) "RTN","C0CCPT",79,0) ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN "RTN","C0CCPT",80,0) .. I +MCNT S MODS=MCNT_MODS "RTN","C0CCPT",81,0) .. S ILST=ILST+1 "RTN","C0CCPT",82,0) .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS "RTN","C0CCPT",83,0) .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS "RTN","C0CCPT",84,0) . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") "RTN","C0CCPT",85,0) . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10 "RTN","C0CCPT",86,0) . I $G(TXT)=1 D GETNOTE(IEN) "RTN","C0CCPT",87,0) Q "RTN","C0CCPT",88,0) GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT "RTN","C0CCPT",89,0) ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" "RTN","C0CCPT",90,0) Q:'$D(VISIT(IEN,"CPT")) "RTN","C0CCPT",91,0) S TXTCNT=0 "RTN","C0CCPT",92,0) F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D "RTN","C0CCPT",93,0) . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) "RTN","C0CCPT",94,0) Q "RTN","C0CDIC") 0^10^B43527636 "RTN","C0CDIC",1,0) C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 "RTN","C0CDIC",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 "RTN","C0CDIC",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CDIC",4,0) ;General Public License See attached copy of the License. "RTN","C0CDIC",5,0) ; "RTN","C0CDIC",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CDIC",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CDIC",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CDIC",9,0) ;(at your option) any later version. "RTN","C0CDIC",10,0) ; "RTN","C0CDIC",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CDIC",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CDIC",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CDIC",14,0) ;GNU General Public License for more details. "RTN","C0CDIC",15,0) ; "RTN","C0CDIC",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CDIC",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CDIC",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CDIC",19,0) ; "RTN","C0CDIC",20,0) W "This is the CCR Dictionary Utility Library ",! "RTN","C0CDIC",21,0) W ! "RTN","C0CDIC",22,0) Q "RTN","C0CDIC",23,0) ; "RTN","C0CDIC",24,0) DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE "RTN","C0CDIC",25,0) ; "RTN","C0CDIC",26,0) N ZI "RTN","C0CDIC",27,0) S ZI="" "RTN","C0CDIC",28,0) S G1=$NA(^TMP($J,"C0CCSV",1)) "RTN","C0CDIC",29,0) S G1A=$NA(@G1@("V")) "RTN","C0CDIC",30,0) S G2=$NA(^TMP($J,"C0CCSV",2)) "RTN","C0CDIC",31,0) D GETN2^C0CRNF(G1,170) ; GET THE MATRIX "RTN","C0CDIC",32,0) F S ZI=$O(@G1A@(ZI)) Q:ZI="" D ;FOR EACH ROW IN THE MATRIX "RTN","C0CDIC",33,0) . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D ; "RTN","C0CDIC",34,0) . . W @G1A@(ZI,"MAPPING METHOD",1),! "RTN","C0CDIC",35,0) . . ;K @G1A@(ZI,"MAPPING METHOD") "RTN","C0CDIC",36,0) . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1)) "RTN","C0CDIC",37,0) D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE "RTN","C0CDIC",38,0) K @G1 "RTN","C0CDIC",39,0) D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv") "RTN","C0CDIC",40,0) K @G2 "RTN","C0CDIC",41,0) Q "RTN","C0CDIC",42,0) ; "RTN","C0CDIC",43,0) GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template "RTN","C0CDIC",44,0) ; and return them in C0CVARS, which is passed by name "RTN","C0CDIC",45,0) ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE "RTN","C0CDIC",46,0) ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE "RTN","C0CDIC",47,0) ; C0CT IS RETURNED AS THE CCR TEMPLATE "RTN","C0CDIC",48,0) N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS "RTN","C0CDIC",49,0) D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE "RTN","C0CDIC",50,0) D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS "RTN","C0CDIC",51,0) N C0CI,C0CX "RTN","C0CDIC",52,0) S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT "RTN","C0CDIC",53,0) F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY "RTN","C0CDIC",54,0) . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL "RTN","C0CDIC",55,0) . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER "RTN","C0CDIC",56,0) ;D PARY^GPLXPATH("C0CVARS") "RTN","C0CDIC",57,0) Q "RTN","C0CDIC",58,0) ; "RTN","C0CDIC",59,0) GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES "RTN","C0CDIC",60,0) ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS "RTN","C0CDIC",61,0) ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE "RTN","C0CDIC",62,0) ; BOTH ARE PASSED BY NAME "RTN","C0CDIC",63,0) ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM "RTN","C0CDIC",64,0) ; C0CPVARS(0) IS NUMBER OF VARIABLES "RTN","C0CDIC",65,0) ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE "RTN","C0CDIC",66,0) D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS "RTN","C0CDIC",67,0) ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER "RTN","C0CDIC",68,0) D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS "RTN","C0CDIC",69,0) ; NOW GO GET THE XPATH INDEXES "RTN","C0CDIC",70,0) D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY "RTN","C0CDIC",71,0) S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS "RTN","C0CDIC",72,0) F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE "RTN","C0CDIC",73,0) . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX "RTN","C0CDIC",74,0) . I C0CI=0 Q ; SKIP THE ZERO NODE "RTN","C0CDIC",75,0) . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y "RTN","C0CDIC",76,0) . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER "RTN","C0CDIC",77,0) . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER "RTN","C0CDIC",78,0) . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) "RTN","C0CDIC",79,0) . . ; W "FOUND ",C0CI,! "RTN","C0CDIC",80,0) . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE "RTN","C0CDIC",81,0) . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR "RTN","C0CDIC",82,0) D SORTV ; SORT THE ARRAY BY LINE NUMBER "RTN","C0CDIC",83,0) Q "RTN","C0CDIC",84,0) ; "RTN","C0CDIC",85,0) HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH "RTN","C0CDIC",86,0) ;N C0CI,C0CTVARS,C0CX,C0CY "RTN","C0CDIC",87,0) F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY "RTN","C0CDIC",88,0) . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER "RTN","C0CDIC",89,0) . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME "RTN","C0CDIC",90,0) . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER "RTN","C0CDIC",91,0) Q "RTN","C0CDIC",92,0) ; "RTN","C0CDIC",93,0) SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER "RTN","C0CDIC",94,0) ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY "RTN","C0CDIC",95,0) S C0CI="" ; "RTN","C0CDIC",96,0) F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER "RTN","C0CDIC",97,0) . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME "RTN","C0CDIC",98,0) . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE "RTN","C0CDIC",99,0) . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY "RTN","C0CDIC",100,0) K @C0CPVARS "RTN","C0CDIC",101,0) M @C0CPVARS=C0C2 "RTN","C0CDIC",102,0) Q "RTN","C0CDIC",103,0) ; "RTN","C0CDIC",104,0) LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170 "RTN","C0CDIC",105,0) ; INITIAL LOAD OF THE CCR DICTIONARY "RTN","C0CDIC",106,0) ; "RTN","C0CDIC",107,0) N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI "RTN","C0CDIC",108,0) S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY "RTN","C0CDIC",109,0) D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY "RTN","C0CDIC",110,0) ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD "RTN","C0CDIC",111,0) D PARY^GPLXPATH("C0CARY") ;TEST "RTN","C0CDIC",112,0) F C0CI=1:1:C0CARY(0) D ; LOAD EACH VARIABLE "RTN","C0CDIC",113,0) . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME "RTN","C0CDIC",114,0) . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH "RTN","C0CDIC",115,0) . D UPDATE^DIE("","C0CFDA") "RTN","C0CDIC",116,0) . I $D(^TMP("DIERR",$J)) U $P BREAK "RTN","C0CDIC",117,0) . W "LOADING:",C0CI," ",C0CARY(C0CI),! "RTN","C0CDIC",118,0) Q "RTN","C0CDIC",119,0) ; "RTN","C0CDIC",120,0) INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES "RTN","C0CDIC",121,0) ; "RTN","C0CDIC",122,0) ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx, "RTN","C0CDIC",123,0) ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY "RTN","C0CDIC",124,0) ;G1("CODING")="170^8" "RTN","C0CDIC",125,0) ;G1("DATA ELEMENT")="170^7" "RTN","C0CDIC",126,0) ;G1("DESCRIPTION")="170^3" "RTN","C0CDIC",127,0) ;G1("ID")="170^1" "RTN","C0CDIC",128,0) ;G1("M","170^8","CODING")="170.08^.01" "RTN","C0CDIC",129,0) ;G1("MAPPING METHOD")="170.08^1" "RTN","C0CDIC",130,0) ;G1("SECTION")="170^10" "RTN","C0CDIC",131,0) ;G1("SOURCE")="170^4" "RTN","C0CDIC",132,0) ;G1("STATUS")="170^9" "RTN","C0CDIC",133,0) ;G1("TYPE")="170^6" "RTN","C0CDIC",134,0) ;G1("VARIABLE")="170^.01" "RTN","C0CDIC",135,0) ;G1("XPATH")="170^2" "RTN","C0CDIC",136,0) ; "RTN","C0CDIC",137,0) N C0CZA,C0CZX,C0CN,C0CSTAT "RTN","C0CDIC",138,0) S C0CZX=0 "RTN","C0CDIC",139,0) S C0CSTAT=0 ; INIT STATUS SET FLAG "RTN","C0CDIC",140,0) F S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0 D ; FOR EACH DICT ENTRY "RTN","C0CDIC",141,0) . ;W C0CZX,! "RTN","C0CDIC",142,0) . K C0CA,C0CN ; CLEAR OUT THE LAST ONE "RTN","C0CDIC",143,0) . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH "RTN","C0CDIC",144,0) . ;ZWR C0CA B ; "RTN","C0CDIC",145,0) . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE "RTN","C0CDIC",146,0) . W "VARIABLE: ",C0CN,! "RTN","C0CDIC",147,0) . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ; "RTN","C0CDIC",148,0) . I $E(C0CN,1,6)="SOCIAL" D ; "RTN","C0CDIC",149,0) . . D SETFDA("SECTION","SOC") ; "RTN","C0CDIC",150,0) . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED "RTN","C0CDIC",151,0) . . S C0CSTAT=1 "RTN","C0CDIC",152,0) . I $E(C0CN,1,6)="FAMILY" D ; "RTN","C0CDIC",153,0) . . D SETFDA("SECTION","FAM") ; "RTN","C0CDIC",154,0) . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED "RTN","C0CDIC",155,0) . . S C0CSTAT=1 "RTN","C0CDIC",156,0) . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS "RTN","C0CDIC",157,0) . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS") "RTN","C0CDIC",158,0) . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS") "RTN","C0CDIC",159,0) . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS") "RTN","C0CDIC",160,0) . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST") "RTN","C0CDIC",161,0) . E I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS") "RTN","C0CDIC",162,0) . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES "RTN","C0CDIC",163,0) . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION "RTN","C0CDIC",164,0) . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM "RTN","C0CDIC",165,0) . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N "RTN","C0CDIC",166,0) . I $$ZVALUE("XPATH")["/Medication/Directions/" D ; MEDS DIRECTIONS VAR "RTN","C0CDIC",167,0) . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS "RTN","C0CDIC",168,0) . E I $$ZVALUE("XPATH")["/Medications/Medication/" D ; ALL OTHER MEDS "RTN","C0CDIC",169,0) . . D SETFDA("SECTION","MEDS") ; A MEDS VAR "RTN","C0CDIC",170,0) . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS "RTN","C0CDIC",171,0) . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE "RTN","C0CDIC",172,0) . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),! "RTN","C0CDIC",173,0) . ;ZWR C0CFDA "RTN","C0CDIC",174,0) . I $D(C0CFDA) D ; WE HAVE CHANGES ON THIS VARIABLE "RTN","C0CDIC",175,0) . . ;ZWR C0CFDA "RTN","C0CDIC",176,0) . . D UPDATE^DIE("","C0CFDA(C0CZX)") "RTN","C0CDIC",177,0) . . I $D(^TMP("DIERR",$J)) U $P BREAK "RTN","C0CDIC",178,0) . . D CLEAN^DILF ; CLEAN UP "RTN","C0CDIC",179,0) . ;ZWR C0CFDA "RTN","C0CDIC",180,0) Q "RTN","C0CDIC",181,0) ; "RTN","C0CDIC",182,0) SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN "RTN","C0CDIC",183,0) ; TO SET TO VALUE C0CSV. "RTN","C0CDIC",184,0) ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE "RTN","C0CDIC",185,0) ; C0CSN,C0CSV ARE PASSED BY VALUE "RTN","C0CDIC",186,0) ; "RTN","C0CDIC",187,0) N C0CSI,C0CSJ "RTN","C0CDIC",188,0) S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER "RTN","C0CDIC",189,0) S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER "RTN","C0CDIC",190,0) S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV "RTN","C0CDIC",191,0) Q "RTN","C0CDIC",192,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CDIC",193,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) "RTN","C0CDIC",194,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CDIC",195,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CDIC",196,0) Q $P(@ZTAB@(ZFN),"^",1) "RTN","C0CDIC",197,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CDIC",198,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) "RTN","C0CDIC",199,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CDIC",200,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CDIC",201,0) Q $P(@ZTAB@(ZFN),"^",2) "RTN","C0CDIC",202,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CDIC",203,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) "RTN","C0CDIC",204,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CDIC",205,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CDIC",206,0) Q $P(@ZTAB@(ZFN),"^",3) "RTN","C0CDIC",207,0) ; "RTN","C0CDOM") 0^11^B86773980 "RTN","C0CDOM",1,0) C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 "RTN","C0CDOM",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CDOM",3,0) ;Copyright 2011 George Lilly. Licensed under the terms of the GNU "RTN","C0CDOM",4,0) ;General Public License See attached copy of the License. "RTN","C0CDOM",5,0) ; "RTN","C0CDOM",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CDOM",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CDOM",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CDOM",9,0) ;(at your option) any later version. "RTN","C0CDOM",10,0) ; "RTN","C0CDOM",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CDOM",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CDOM",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CDOM",14,0) ;GNU General Public License for more details. "RTN","C0CDOM",15,0) ; "RTN","C0CDOM",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CDOM",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CDOM",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CDOM",19,0) ; "RTN","C0CDOM",20,0) Q "RTN","C0CDOM",21,0) ; "RTN","C0CDOM",22,0) DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE "RTN","C0CDOM",23,0) ; THE XPATH INDEX ZXIDX, PASSED BY NAME "RTN","C0CDOM",24,0) ; THE XPATH ARRAY XPARY, PASSED BY NAME "RTN","C0CDOM",25,0) ; ZOID IS THE STARTING OID "RTN","C0CDOM",26,0) ; ZPATH IS THE STARTING XPATH, USUALLY "/" "RTN","C0CDOM",27,0) ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE "RTN","C0CDOM",28,0) ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT "RTN","C0CDOM",29,0) I $G(ZREDUX)="" S ZREDUX="" "RTN","C0CDOM",30,0) N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY "RTN","C0CDOM",31,0) N NEWNUM S NEWNUM="" "RTN","C0CDOM",32,0) I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" "RTN","C0CDOM",33,0) S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE "RTN","C0CDOM",34,0) I $G(ZREDUX)'="" D ; REDUX PROVIDED? "RTN","C0CDOM",35,0) . N GT S GT=$P(NEWPATH,ZREDUX,2) "RTN","C0CDOM",36,0) . I GT'="" S NEWPATH=GT "RTN","C0CDOM",37,0) S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX "RTN","C0CDOM",38,0) N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE "RTN","C0CDOM",39,0) I $D(GA) D ; PROCESS THE ATTRIBUTES "RTN","C0CDOM",40,0) . N ZI S ZI="" "RTN","C0CDOM",41,0) . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE "RTN","C0CDOM",42,0) . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE "RTN","C0CDOM",43,0) . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY "RTN","C0CDOM",44,0) . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE "RTN","C0CDOM",45,0) N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE "RTN","C0CDOM",46,0) I $D(GD(2)) D ; "RTN","C0CDOM",47,0) . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY "RTN","C0CDOM",48,0) E I $D(GD(1)) D ; "RTN","C0CDOM",49,0) . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY "RTN","C0CDOM",50,0) . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY "RTN","C0CDOM",51,0) N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD "RTN","C0CDOM",52,0) I ZFRST'=0 D ; THERE IS A CHILD "RTN","C0CDOM",53,0) . N ZNUM "RTN","C0CDOM",54,0) . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE "RTN","C0CDOM",55,0) . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD "RTN","C0CDOM",56,0) N GNXT S GNXT=$$NXTSIB(ZOID) "RTN","C0CDOM",57,0) I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES "RTN","C0CDOM",58,0) I GNXT'=0 D ; "RTN","C0CDOM",59,0) . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? "RTN","C0CDOM",60,0) . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES "RTN","C0CDOM",61,0) . . N ZNUM S ZNUM=1 ; "RTN","C0CDOM",62,0) . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB "RTN","C0CDOM",63,0) . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB "RTN","C0CDOM",64,0) Q "RTN","C0CDOM",65,0) ; "RTN","C0CDOM",66,0) ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY "RTN","C0CDOM",67,0) ; "RTN","C0CDOM",68,0) ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES "RTN","C0CDOM",69,0) ; "RTN","C0CDOM",70,0) N ZZI,ZZJ,ZZN "RTN","C0CDOM",71,0) S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY "RTN","C0CDOM",72,0) I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE "RTN","C0CDOM",73,0) S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY "RTN","C0CDOM",74,0) S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . "RTN","C0CDOM",75,0) I ZZI'["]" D ; A SINGLETON "RTN","C0CDOM",76,0) . S ZZN=1 "RTN","C0CDOM",77,0) E D ; THERE IS AN [x] OCCURANCE "RTN","C0CDOM",78,0) . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE "RTN","C0CDOM",79,0) . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] "RTN","C0CDOM",80,0) I ZZJ'="" D ; TIME TO ADD THE VALUE "RTN","C0CDOM",81,0) . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE "RTN","C0CDOM",82,0) Q "RTN","C0CDOM",83,0) ; "RTN","C0CDOM",84,0) PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME "RTN","C0CDOM",85,0) ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW "RTN","C0CDOM",86,0) ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML "RTN","C0CDOM",87,0) ;Q $$EN^MXMLDOM(INXML) "RTN","C0CDOM",88,0) Q $$EN^MXMLDOM(INXML,"W") "RTN","C0CDOM",89,0) ; "RTN","C0CDOM",90,0) ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE "RTN","C0CDOM",91,0) N ZN "RTN","C0CDOM",92,0) ;I $$TAG(ZOID)["entry" B "RTN","C0CDOM",93,0) S ZN=$$NXTSIB(ZOID) "RTN","C0CDOM",94,0) I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG "RTN","C0CDOM",95,0) Q 0 "RTN","C0CDOM",96,0) ; "RTN","C0CDOM",97,0) FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID "RTN","C0CDOM",98,0) Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CDOM",99,0) ; "RTN","C0CDOM",100,0) PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID "RTN","C0CDOM",101,0) Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CDOM",102,0) ; "RTN","C0CDOM",103,0) ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID "RTN","C0CDOM",104,0) S HANDLE=C0CDOCID "RTN","C0CDOM",105,0) K @RTN "RTN","C0CDOM",106,0) D GETTXT^MXMLDOM("A") "RTN","C0CDOM",107,0) Q "RTN","C0CDOM",108,0) ; "RTN","C0CDOM",109,0) TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE "RTN","C0CDOM",110,0) ;I ZOID=149 B ;GPLTEST "RTN","C0CDOM",111,0) N X,Y "RTN","C0CDOM",112,0) S Y="" "RTN","C0CDOM",113,0) S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE "RTN","C0CDOM",114,0) I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y "RTN","C0CDOM",115,0) I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CDOM",116,0) Q Y "RTN","C0CDOM",117,0) ; "RTN","C0CDOM",118,0) NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING "RTN","C0CDOM",119,0) Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CDOM",120,0) ; "RTN","C0CDOM",121,0) DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE "RTN","C0CDOM",122,0) ;N ZT,ZN S ZT="" "RTN","C0CDOM",123,0) ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) "RTN","C0CDOM",124,0) ;Q $G(@C0CDOM@(ZOID,"T",1)) "RTN","C0CDOM",125,0) S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) "RTN","C0CDOM",126,0) Q "RTN","C0CDOM",127,0) ; "RTN","C0CDOM",128,0) OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM "RTN","C0CDOM",129,0) ; "RTN","C0CDOM",130,0) S C0CDOCID=INID "RTN","C0CDOM",131,0) I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE 0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID "RTN","C0CDOM",230,0) E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL "RTN","C0CDOM",231,0) . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE "RTN","C0CDOM",232,0) . S ZPARNODE=1 ; "RTN","C0CDOM",233,0) ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET "RTN","C0CDOM",234,0) N ZEXARY "RTN","C0CDOM",235,0) D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY "RTN","C0CDOM",236,0) D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED "RTN","C0CDOM",237,0) I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE "RTN","C0CDOM",238,0) Q HANDLE ; SUCCESS "RTN","C0CDOM",239,0) ; "RTN","C0CDOM",240,0) MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES "RTN","C0CDOM",241,0) N ZI S ZI="" "RTN","C0CDOM",242,0) N ZTAG "RTN","C0CDOM",243,0) F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH SECTION "RTN","C0CDOM",244,0) . N ZELEADD S ZELEADD=0 "RTN","C0CDOM",245,0) . I ZI["@" D ; END NODE HAS NO VALUE, ONLY ATTRIBUTES "RTN","C0CDOM",246,0) . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG "RTN","C0CDOM",247,0) . . K ZATT ; CLEAR OUT LAST ONE "RTN","C0CDOM",248,0) . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY "RTN","C0CDOM",249,0) . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE "RTN","C0CDOM",250,0) . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE "RTN","C0CDOM",251,0) . I $O(@ZARY@(ZI,""))="" D ;END NODE "RTN","C0CDOM",252,0) . . S ZTAG=ZI ; USE ZI FOR THE TAG "RTN","C0CDOM",253,0) . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE "RTN","C0CDOM",254,0) . . S ZELEADD=1 ; ADDED AN ELEMENT "RTN","C0CDOM",255,0) . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE "RTN","C0CDOM",256,0) . I ZELEADD D Q ; NO MORE TO DO ON THIS LEVEL "RTN","C0CDOM",257,0) . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING "RTN","C0CDOM",258,0) . N NEWARY ; INDENTED ARRAY "RTN","C0CDOM",259,0) . N ZN S ZN=0 "RTN","C0CDOM",260,0) . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE "RTN","C0CDOM",261,0) . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG "RTN","C0CDOM",262,0) . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY "RTN","C0CDOM",263,0) . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY "RTN","C0CDOM",264,0) . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG "RTN","C0CDOM",265,0) Q "RTN","C0CDOM",266,0) ; "RTN","C0CDOM",267,0) EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED "RTN","C0CDOM",268,0) ; CONSISTENT FORMAT "RTN","C0CDOM",269,0) ; GNARY("patient",1,"facilities[2].facility@code")="050" "RTN","C0CDOM",270,0) ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050" "RTN","C0CDOM",271,0) ; for easier processing (this is fileman format genius) "RTN","C0CDOM",272,0) ; basically removes the dot notation from the strings "RTN","C0CDOM",273,0) ; "RTN","C0CDOM",274,0) N ZZI "RTN","C0CDOM",275,0) S ZZI="" "RTN","C0CDOM",276,0) F S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI="" D ; "RTN","C0CDOM",277,0) . N ZZN S ZZN=0 "RTN","C0CDOM",278,0) . F S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN="" D ; "RTN","C0CDOM",279,0) . . N ZZS S ZZS="" "RTN","C0CDOM",280,0) . . N GA ;PUSH STACK "RTN","C0CDOM",281,0) . . F S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS="" D ; "RTN","C0CDOM",282,0) . . . K GA ; NEW STACK "RTN","C0CDOM",283,0) . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT "RTN","C0CDOM",284,0) . . . N ZZV ; PLACE TO STASH THE VALUE "RTN","C0CDOM",285,0) . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE "RTN","C0CDOM",286,0) . . . W !,"VALUE:",ZZV "RTN","C0CDOM",287,0) . . . N GK ; COUNTER "RTN","C0CDOM",288,0) . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE "RTN","C0CDOM",289,0) . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X] "RTN","C0CDOM",290,0) . . . . N GM S GM=$P(ZZS,".",GK) ; TAG "RTN","C0CDOM",291,0) . . . . I GM["[" D ; IT'S A MULTIPLE "RTN","C0CDOM",292,0) . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER "RTN","C0CDOM",293,0) . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG "RTN","C0CDOM",294,0) . . . . I GM["@" D ; IT'S GOT ATTRIBUTES "RTN","C0CDOM",295,0) . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME "RTN","C0CDOM",296,0) . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG "RTN","C0CDOM",297,0) . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2) "RTN","C0CDOM",298,0) . . . . E D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ; "RTN","C0CDOM",299,0) . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" "RTN","C0CDOM",300,0) . . . N GZI S GZI="" ; STRING FOR THE INDEX "RTN","C0CDOM",301,0) . . . F GK=1:1:GA(0) D ; TIME TO REVERSE POP THE TAGS "RTN","C0CDOM",302,0) . . . . S GM=$P(GA(GK),"^",1) ; THE TAG "RTN","C0CDOM",303,0) . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY "RTN","C0CDOM",304,0) . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE "RTN","C0CDOM",305,0) . . . . E S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST "RTN","C0CDOM",306,0) . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME "RTN","C0CDOM",307,0) . . . W !,GZI "RTN","C0CDOM",308,0) . . . S @GZI2=ZZV ; REMEMBER THE VALUE? "RTN","C0CDOM",309,0) Q "RTN","C0CDOM",310,0) ; "RTN","C0CDOM",311,0) NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE "RTN","C0CDOM",312,0) N CBK,SUCCESS,LEVEL,NODE,HANDLE "RTN","C0CDOM",313,0) K ^TMP("MXMLERR",$J) "RTN","C0CDOM",314,0) L +^TMP("MXMLDOM",$J):5 "RTN","C0CDOM",315,0) E Q 0 "RTN","C0CDOM",316,0) S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" "RTN","C0CDOM",317,0) L -^TMP("MXMLDOM",$J) "RTN","C0CDOM",318,0) Q HANDLE "RTN","C0CDOM",319,0) ; "RTN","C0CDPT") 0^12^B45873061 "RTN","C0CDPT",1,0) C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 "RTN","C0CDPT",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CDPT",3,0) ; "RTN","C0CDPT",4,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CDPT",5,0) ; General Public License. "RTN","C0CDPT",6,0) ; "RTN","C0CDPT",7,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CDPT",8,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CDPT",9,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CDPT",10,0) ; GNU General Public License for more details. "RTN","C0CDPT",11,0) ; "RTN","C0CDPT",12,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CDPT",13,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CDPT",14,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CDPT",15,0) ; "RTN","C0CDPT",16,0) ; FAMILY Family Name "RTN","C0CDPT",17,0) ; GIVEN Given Name "RTN","C0CDPT",18,0) ; MIDDLE Middle Name "RTN","C0CDPT",19,0) ; SUFFIX Suffix Name "RTN","C0CDPT",20,0) ; DISPNAME Display Name "RTN","C0CDPT",21,0) ; DOB Date of Birth "RTN","C0CDPT",22,0) ; GENDER Get Gender "RTN","C0CDPT",23,0) ; SSN Get SSN for ID "RTN","C0CDPT",24,0) ; ADDRTYPE Get Home Address "RTN","C0CDPT",25,0) ; ADDR1 Get Home Address line 1 "RTN","C0CDPT",26,0) ; ADDR2 Get Home Address line 2 "RTN","C0CDPT",27,0) ; CITY Get City for Home Address "RTN","C0CDPT",28,0) ; STATE Get State for Home Address "RTN","C0CDPT",29,0) ; ZIP Get Zip code for Home Address "RTN","C0CDPT",30,0) ; COUNTY Get County for our Address "RTN","C0CDPT",31,0) ; COUNTRY Get Country for our Address "RTN","C0CDPT",32,0) ; RESTEL Residential Telephone "RTN","C0CDPT",33,0) ; WORKTEL Work Telephone "RTN","C0CDPT",34,0) ; EMAIL Email Adddress "RTN","C0CDPT",35,0) ; CELLTEL Cell Phone "RTN","C0CDPT",36,0) ; NOK1FAM Next of Kin 1 (NOK1) Family Name "RTN","C0CDPT",37,0) ; NOK1GIV NOK1 Given Name "RTN","C0CDPT",38,0) ; NOK1MID NOK1 Middle Name "RTN","C0CDPT",39,0) ; NOK1SUF NOK1 Suffi Name "RTN","C0CDPT",40,0) ; NOK1DISP NOK1 Display Name "RTN","C0CDPT",41,0) ; NOK1REL NOK1 Relationship to the patient "RTN","C0CDPT",42,0) ; NOK1ADD1 NOK1 Address 1 "RTN","C0CDPT",43,0) ; NOK1ADD2 NOK1 Address 2 "RTN","C0CDPT",44,0) ; NOK1CITY NOK1 City "RTN","C0CDPT",45,0) ; NOK1STAT NOK1 State "RTN","C0CDPT",46,0) ; NOK1ZIP NOK1 Zip Code "RTN","C0CDPT",47,0) ; NOK1HTEL NOK1 Home Telephone "RTN","C0CDPT",48,0) ; NOK1WTEL NOK1 Work Telephone "RTN","C0CDPT",49,0) ; NOK1SAME Is NOK1's Address the same the patient? "RTN","C0CDPT",50,0) ; NOK2FAM NOK2 Family Name "RTN","C0CDPT",51,0) ; NOK2GIV NOK2 Given Name "RTN","C0CDPT",52,0) ; NOK2MID NOK2 Middle Name "RTN","C0CDPT",53,0) ; NOK2SUF NOK2 Suffi Name "RTN","C0CDPT",54,0) ; NOK2DISP NOK2 Display Name "RTN","C0CDPT",55,0) ; NOK2REL NOK2 Relationship to the patient "RTN","C0CDPT",56,0) ; NOK2ADD1 NOK2 Address 1 "RTN","C0CDPT",57,0) ; NOK2ADD2 NOK2 Address 2 "RTN","C0CDPT",58,0) ; NOK2CITY NOK2 City "RTN","C0CDPT",59,0) ; NOK2STAT NOK2 State "RTN","C0CDPT",60,0) ; NOK2ZIP NOK2 Zip Code "RTN","C0CDPT",61,0) ; NOK2HTEL NOK2 Home Telephone "RTN","C0CDPT",62,0) ; NOK2WTEL NOK2 Work Telephone "RTN","C0CDPT",63,0) ; NOK2SAME Is NOK2's Address the same the patient? "RTN","C0CDPT",64,0) ; EMERFAM Emergency Contact (EMER) Family Name "RTN","C0CDPT",65,0) ; EMERGIV EMER Given Name "RTN","C0CDPT",66,0) ; EMERMID EMER Middle Name "RTN","C0CDPT",67,0) ; EMERSUF EMER Suffi Name "RTN","C0CDPT",68,0) ; EMERDISP EMER Display Name "RTN","C0CDPT",69,0) ; EMERREL EMER Relationship to the patient "RTN","C0CDPT",70,0) ; EMERADD1 EMER Address 1 "RTN","C0CDPT",71,0) ; EMERADD2 EMER Address 2 "RTN","C0CDPT",72,0) ; EMERCITY EMER City "RTN","C0CDPT",73,0) ; EMERSTAT EMER State "RTN","C0CDPT",74,0) ; EMERZIP EMER Zip Code "RTN","C0CDPT",75,0) ; EMERHTEL EMER Home Telephone "RTN","C0CDPT",76,0) ; EMERWTEL EMER Work Telephone "RTN","C0CDPT",77,0) ; EMERSAME Is EMER's Address the same the NOK? "RTN","C0CDPT",78,0) ; "RTN","C0CDPT",79,0) W "No Entry at top!" Q "RTN","C0CDPT",80,0) ; "RTN","C0CDPT",81,0) ;**Revision History** "RTN","C0CDPT",82,0) ; - June 15, 08: v0.1 using merged global "RTN","C0CDPT",83,0) ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. "RTN","C0CDPT",84,0) ; "RTN","C0CDPT",85,0) ; All methods are Public and Extrinsic "RTN","C0CDPT",86,0) ; All calls use Fileman file 2 (Patient). "RTN","C0CDPT",87,0) ; You can obtain field numbers using the data dictionary "RTN","C0CDPT",88,0) ; "RTN","C0CDPT",89,0) FAMILY(DFN) ; Family Name "RTN","C0CDPT",90,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","C0CDPT",91,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",92,0) Q NAME("FAMILY") "RTN","C0CDPT",93,0) GIVEN(DFN) ; Given Name "RTN","C0CDPT",94,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","C0CDPT",95,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",96,0) Q NAME("GIVEN") "RTN","C0CDPT",97,0) MIDDLE(DFN) ; Middle Name "RTN","C0CDPT",98,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","C0CDPT",99,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",100,0) Q NAME("MIDDLE") "RTN","C0CDPT",101,0) SUFFIX(DFN) ; Suffi Name "RTN","C0CDPT",102,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","C0CDPT",103,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",104,0) Q NAME("SUFFIX") "RTN","C0CDPT",105,0) DISPNAME(DFN) ; Display Name "RTN","C0CDPT",106,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","C0CDPT",107,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","C0CDPT",108,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","C0CDPT",109,0) DOB(DFN) ; Date of Birth "RTN","C0CDPT",110,0) N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","C0CDPT",111,0) ; Date in FM Date Format. Convert to UTC/ISO 8601. "RTN","C0CDPT",112,0) Q $$FMDTOUTC^C0CUTIL(DOB,"D") "RTN","C0CDPT",113,0) GENDER(DFN) ; Gender/Sex "RTN","C0CDPT",114,0) Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ; "RTN","C0CDPT",115,0) SSN(DFN) ; SSN "RTN","C0CDPT",116,0) Q $$GET1^DIQ(2,DFN,.09) "RTN","C0CDPT",117,0) ADDRTYPE(DFN) ; Address Type "RTN","C0CDPT",118,0) ; Vista only stores a home address for the patient. "RTN","C0CDPT",119,0) Q "Home" "RTN","C0CDPT",120,0) ADDR1(DFN) ; Get Home Address line 1 "RTN","C0CDPT",121,0) Q $$GET1^DIQ(2,DFN,.111) "RTN","C0CDPT",122,0) ADDR2(DFN) ; Get Home Address line 2 "RTN","C0CDPT",123,0) ; Vista has Lines 2,3; CCR has only line 1,2; so compromise "RTN","C0CDPT",124,0) N ADDLN2,ADDLN3 "RTN","C0CDPT",125,0) S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) "RTN","C0CDPT",126,0) Q:ADDLN3="" ADDLN2 "RTN","C0CDPT",127,0) Q ADDLN2_", "_ADDLN3 "RTN","C0CDPT",128,0) CITY(DFN) ; Get City for Home Address "RTN","C0CDPT",129,0) Q $$GET1^DIQ(2,DFN,.114) "RTN","C0CDPT",130,0) STATE(DFN) ; Get State for Home Address "RTN","C0CDPT",131,0) Q $$GET1^DIQ(2,DFN,.115) "RTN","C0CDPT",132,0) ZIP(DFN) ; Get Zip code for Home Address "RTN","C0CDPT",133,0) Q $$GET1^DIQ(2,DFN,.116) "RTN","C0CDPT",134,0) COUNTY(DFN) ; Get County for our Address "RTN","C0CDPT",135,0) Q $$GET1^DIQ(2,DFN,.117) "RTN","C0CDPT",136,0) COUNTRY(DFN) ; Get Country for our Address "RTN","C0CDPT",137,0) ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... "RTN","C0CDPT",138,0) Q "USA" "RTN","C0CDPT",139,0) RESTEL(DFN) ; Residential Telephone "RTN","C0CDPT",140,0) Q $$GET1^DIQ(2,DFN,.131) "RTN","C0CDPT",141,0) WORKTEL(DFN) ; Work Telephone "RTN","C0CDPT",142,0) Q $$GET1^DIQ(2,DFN,.132) "RTN","C0CDPT",143,0) EMAIL(DFN) ; Email Adddress "RTN","C0CDPT",144,0) Q $$GET1^DIQ(2,DFN,.133) "RTN","C0CDPT",145,0) CELLTEL(DFN) ; Cell Phone "RTN","C0CDPT",146,0) Q $$GET1^DIQ(2,DFN,.134) "RTN","C0CDPT",147,0) NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name "RTN","C0CDPT",148,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","C0CDPT",149,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",150,0) Q NAME("FAMILY") "RTN","C0CDPT",151,0) NOK1GIV(DFN) ; NOK1 Given Name "RTN","C0CDPT",152,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","C0CDPT",153,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",154,0) Q NAME("GIVEN") "RTN","C0CDPT",155,0) NOK1MID(DFN) ; NOK1 Middle Name "RTN","C0CDPT",156,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","C0CDPT",157,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",158,0) Q NAME("MIDDLE") "RTN","C0CDPT",159,0) NOK1SUF(DFN) ; NOK1 Suffi Name "RTN","C0CDPT",160,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","C0CDPT",161,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",162,0) Q NAME("SUFFIX") "RTN","C0CDPT",163,0) NOK1DISP(DFN) ; NOK1 Display Name "RTN","C0CDPT",164,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","C0CDPT",165,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","C0CDPT",166,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","C0CDPT",167,0) NOK1REL(DFN) ; NOK1 Relationship to the patient "RTN","C0CDPT",168,0) Q $$GET1^DIQ(2,DFN,.212) "RTN","C0CDPT",169,0) NOK1ADD1(DFN) ; NOK1 Address 1 "RTN","C0CDPT",170,0) Q $$GET1^DIQ(2,DFN,.213) "RTN","C0CDPT",171,0) NOK1ADD2(DFN) ; NOK1 Address 2 "RTN","C0CDPT",172,0) N ADDLN2,ADDLN3 "RTN","C0CDPT",173,0) S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) "RTN","C0CDPT",174,0) Q:ADDLN3="" ADDLN2 "RTN","C0CDPT",175,0) Q ADDLN2_", "_ADDLN3 "RTN","C0CDPT",176,0) NOK1CITY(DFN) ; NOK1 City "RTN","C0CDPT",177,0) Q $$GET1^DIQ(2,DFN,.216) "RTN","C0CDPT",178,0) NOK1STAT(DFN) ; NOK1 State "RTN","C0CDPT",179,0) Q $$GET1^DIQ(2,DFN,.217) "RTN","C0CDPT",180,0) NOK1ZIP(DFN) ; NOK1 Zip Code "RTN","C0CDPT",181,0) Q $$GET1^DIQ(2,DFN,.218) "RTN","C0CDPT",182,0) NOK1HTEL(DFN) ; NOK1 Home Telephone "RTN","C0CDPT",183,0) Q $$GET1^DIQ(2,DFN,.219) "RTN","C0CDPT",184,0) NOK1WTEL(DFN) ; NOK1 Work Telephone "RTN","C0CDPT",185,0) Q $$GET1^DIQ(2,DFN,.21011) "RTN","C0CDPT",186,0) NOK1SAME(DFN) ; Is NOK1's Address the same the patient? "RTN","C0CDPT",187,0) Q $$GET1^DIQ(2,DFN,.2125) "RTN","C0CDPT",188,0) NOK2FAM(DFN) ; NOK2 Family Name "RTN","C0CDPT",189,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","C0CDPT",190,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",191,0) Q NAME("FAMILY") "RTN","C0CDPT",192,0) NOK2GIV(DFN) ; NOK2 Given Name "RTN","C0CDPT",193,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","C0CDPT",194,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",195,0) Q NAME("GIVEN") "RTN","C0CDPT",196,0) NOK2MID(DFN) ; NOK2 Middle Name "RTN","C0CDPT",197,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","C0CDPT",198,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",199,0) Q NAME("MIDDLE") "RTN","C0CDPT",200,0) NOK2SUF(DFN) ; NOK2 Suffi Name "RTN","C0CDPT",201,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","C0CDPT",202,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",203,0) Q NAME("SUFFIX") "RTN","C0CDPT",204,0) NOK2DISP(DFN) ; NOK2 Display Name "RTN","C0CDPT",205,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","C0CDPT",206,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","C0CDPT",207,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","C0CDPT",208,0) NOK2REL(DFN) ; NOK2 Relationship to the patient "RTN","C0CDPT",209,0) Q $$GET1^DIQ(2,DFN,.2192) "RTN","C0CDPT",210,0) NOK2ADD1(DFN) ; NOK2 Address 1 "RTN","C0CDPT",211,0) Q $$GET1^DIQ(2,DFN,.2193) "RTN","C0CDPT",212,0) NOK2ADD2(DFN) ; NOK2 Address 2 "RTN","C0CDPT",213,0) N ADDLN2,ADDLN3 "RTN","C0CDPT",214,0) S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) "RTN","C0CDPT",215,0) Q:ADDLN3="" ADDLN2 "RTN","C0CDPT",216,0) Q ADDLN2_", "_ADDLN3 "RTN","C0CDPT",217,0) NOK2CITY(DFN) ; NOK2 City "RTN","C0CDPT",218,0) Q $$GET1^DIQ(2,DFN,.2196) "RTN","C0CDPT",219,0) NOK2STAT(DFN) ; NOK2 State "RTN","C0CDPT",220,0) Q $$GET1^DIQ(2,DFN,.2197) "RTN","C0CDPT",221,0) NOK2ZIP(DFN) ; NOK2 Zip Code "RTN","C0CDPT",222,0) Q $$GET1^DIQ(2,DFN,.2198) "RTN","C0CDPT",223,0) NOK2HTEL(DFN) ; NOK2 Home Telephone "RTN","C0CDPT",224,0) Q $$GET1^DIQ(2,DFN,.2199) "RTN","C0CDPT",225,0) NOK2WTEL(DFN) ; NOK2 Work Telephone "RTN","C0CDPT",226,0) Q $$GET1^DIQ(2,DFN,.211011) "RTN","C0CDPT",227,0) NOK2SAME(DFN) ; Is NOK2's Address the same the patient? "RTN","C0CDPT",228,0) Q $$GET1^DIQ(2,DFN,.21925) "RTN","C0CDPT",229,0) EMERFAM(DFN) ; Emergency Contact (EMER) Family Name "RTN","C0CDPT",230,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","C0CDPT",231,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",232,0) Q NAME("FAMILY") "RTN","C0CDPT",233,0) EMERGIV(DFN) ; EMER Given Name "RTN","C0CDPT",234,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","C0CDPT",235,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",236,0) Q NAME("GIVEN") "RTN","C0CDPT",237,0) EMERMID(DFN) ; EMER Middle Name "RTN","C0CDPT",238,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","C0CDPT",239,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",240,0) Q NAME("MIDDLE") "RTN","C0CDPT",241,0) EMERSUF(DFN) ; EMER Suffi Name "RTN","C0CDPT",242,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","C0CDPT",243,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CDPT",244,0) Q NAME("SUFFIX") "RTN","C0CDPT",245,0) EMERDISP(DFN) ; EMER Display Name "RTN","C0CDPT",246,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","C0CDPT",247,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","C0CDPT",248,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","C0CDPT",249,0) EMERREL(DFN) ; EMER Relationship to the patient "RTN","C0CDPT",250,0) Q $$GET1^DIQ(2,DFN,.331) "RTN","C0CDPT",251,0) EMERADD1(DFN) ; EMER Address 1 "RTN","C0CDPT",252,0) Q $$GET1^DIQ(2,DFN,.333) "RTN","C0CDPT",253,0) EMERADD2(DFN) ; EMER Address 2 "RTN","C0CDPT",254,0) N ADDLN2,ADDLN3 "RTN","C0CDPT",255,0) S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) "RTN","C0CDPT",256,0) Q:ADDLN3="" ADDLN2 "RTN","C0CDPT",257,0) Q ADDLN2_", "_ADDLN3 "RTN","C0CDPT",258,0) EMERCITY(DFN) ; EMER City "RTN","C0CDPT",259,0) Q $$GET1^DIQ(2,DFN,.336) "RTN","C0CDPT",260,0) EMERSTAT(DFN) ; EMER State "RTN","C0CDPT",261,0) Q $$GET1^DIQ(2,DFN,.337) "RTN","C0CDPT",262,0) EMERZIP(DFN) ; EMER Zip Code "RTN","C0CDPT",263,0) Q $$GET1^DIQ(2,DFN,.338) "RTN","C0CDPT",264,0) EMERHTEL(DFN) ; EMER Home Telephone "RTN","C0CDPT",265,0) Q $$GET1^DIQ(2,DFN,.339) "RTN","C0CDPT",266,0) EMERWTEL(DFN) ; EMER Work Telephone "RTN","C0CDPT",267,0) Q $$GET1^DIQ(2,DFN,.33011) "RTN","C0CDPT",268,0) EMERSAME(DFN) ; Is EMER's Address the same the NOK? "RTN","C0CDPT",269,0) Q $$GET1^DIQ(2,DFN,.3305) "RTN","C0CENC") 0^13^B46321144 "RTN","C0CENC",1,0) C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 "RTN","C0CENC",2,0) ;;1.0;C0C;;May 21, 2010;Build 1 "RTN","C0CENC",3,0) ;Copyright 2010 George Lilly, University of Minnesota and others. "RTN","C0CENC",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CENC",5,0) ;See attached copy of the License. "RTN","C0CENC",6,0) ; "RTN","C0CENC",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CENC",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CENC",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CENC",10,0) ;(at your option) any later version. "RTN","C0CENC",11,0) ; "RTN","C0CENC",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CENC",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CENC",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CENC",15,0) ;GNU General Public License for more details. "RTN","C0CENC",16,0) ; "RTN","C0CENC",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CENC",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CENC",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CENC",20,0) ; "RTN","C0CENC",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CENC",22,0) Q "RTN","C0CENC",23,0) ; "RTN","C0CENC",24,0) EXTRACT(ENCXML,DFN,ENCOUT) ; EXTRACT ENCOUNTERS INTO XML TEMPLATE "RTN","C0CENC",25,0) ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CENC",26,0) ; "RTN","C0CENC",27,0) D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES "RTN","C0CENC",28,0) ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE "RTN","C0CENC",29,0) K @C0CENC "RTN","C0CENC",30,0) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS "RTN","C0CENC",31,0) D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS "RTN","C0CENC",32,0) Q "RTN","C0CENC",33,0) ; "RTN","C0CENC",34,0) TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, "RTN","C0CENC",35,0) ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME "RTN","C0CENC",36,0) ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES "RTN","C0CENC",37,0) ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT "RTN","C0CENC",38,0) ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY "RTN","C0CENC",39,0) ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM "RTN","C0CENC",40,0) ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS "RTN","C0CENC",41,0) ; "RTN","C0CENC",42,0) ;K VISIT,LST,NOTE "RTN","C0CENC",43,0) I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE "RTN","C0CENC",44,0) I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE "RTN","C0CENC",45,0) ; NEED TO ADD START AND END DATES FROM PARAMETERS "RTN","C0CENC",46,0) N ZI S ZI="" "RTN","C0CENC",47,0) N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" "RTN","C0CENC",48,0) F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST "RTN","C0CENC",49,0) . N ZDATE "RTN","C0CENC",50,0) . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) "RTN","C0CENC",51,0) . S ZPRVARY=$NA(VISIT(ZI,"PRV")) "RTN","C0CENC",52,0) . N ZPRV "RTN","C0CENC",53,0) . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM "RTN","C0CENC",54,0) . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON "RTN","C0CENC",55,0) . ; ENCOBJECTID - ENCOUNTER OBJECT ID "RTN","C0CENC",56,0) . ; ENCDATETIME - ENCOUNTER DATE TIME "RTN","C0CENC",57,0) . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL) "RTN","C0CENC",58,0) . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE "RTN","C0CENC",59,0) . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4 "RTN","C0CENC",60,0) . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT "RTN","C0CENC",61,0) . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE "RTN","C0CENC",62,0) . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM "RTN","C0CENC",63,0) . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID "RTN","C0CENC",64,0) . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID "RTN","C0CENC",65,0) . ; ENCINDTXT - ENCOUNTER INDICATION TEXT "RTN","C0CENC",66,0) . ; ENCINDCODE - ENCOUNTER INDICATION CODE "RTN","C0CENC",67,0) . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM "RTN","C0CENC",68,0) . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID "RTN","C0CENC",69,0) . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION "RTN","C0CENC",70,0) . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI "RTN","C0CENC",71,0) . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME "RTN","C0CENC",72,0) . S ZRNF("ENCTYPETXT")="" "RTN","C0CENC",73,0) . S ZRNF("ENCTYPECODE")="" "RTN","C0CENC",74,0) . S ZRNF("ENCTYPECODESYS")="" "RTN","C0CENC",75,0) . S ZRNF("ENCDESCTXT")="" "RTN","C0CENC",76,0) . S ZRNF("ENCDESCCODE")="" "RTN","C0CENC",77,0) . S ZRNF("ENCDESCCODESYS")="" "RTN","C0CENC",78,0) . N TYPTXT,TYPCDE,TYPSYS ; WILL BE UPDATED BY GETTYPE CALL "RTN","C0CENC",79,0) . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D ; RETURNS FALSE IF NO TYPE "RTN","C0CENC",80,0) . . S ZRNF("ENCTYPETXT")=TYPTXT "RTN","C0CENC",81,0) . . S ZRNF("ENCTYPECODE")=TYPCDE "RTN","C0CENC",82,0) . . S ZRNF("ENCTYPECODESYS")=TYPSYS "RTN","C0CENC",83,0) . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE "RTN","C0CENC",84,0) . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT) "RTN","C0CENC",85,0) . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA "RTN","C0CENC",86,0) . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1" "RTN","C0CENC",87,0) . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER "RTN","C0CENC",88,0) . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE "RTN","C0CENC",89,0) . S ZRNF("ENCINDCODE")="" "RTN","C0CENC",90,0) . S ZRNF("ENCINDCODESYS")="" "RTN","C0CENC",91,0) . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER "RTN","C0CENC",92,0) . S ZRNF("ENCCOMMENTID")="" "RTN","C0CENC",93,0) . I $G(VISIT(ZI,"TEXT",1))'="" D ; THERE IS A NOTE "RTN","C0CENC",94,0) . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE "RTN","C0CENC",95,0) . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI "RTN","C0CENC",96,0) . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE "RTN","C0CENC",97,0) . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE "RTN","C0CENC",98,0) . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER "RTN","C0CENC",99,0) . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY "RTN","C0CENC",100,0) . ;S PREVCPT=ZCPT "RTN","C0CENC",101,0) . ;S PREVDT=ZDATE "RTN","C0CENC",102,0) N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS")) "RTN","C0CENC",103,0) M @ZRIM=@C0CENC@("V") "RTN","C0CENC",104,0) K VISIT,LST,NOTE "RTN","C0CENC",105,0) Q "RTN","C0CENC",106,0) ; "RTN","C0CENC",107,0) GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE "RTN","C0CENC",108,0) ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE "RTN","C0CENC",109,0) ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM "RTN","C0CENC",110,0) ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE "RTN","C0CENC",111,0) ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10 "RTN","C0CENC",112,0) N ZS,ZC "RTN","C0CENC",113,0) S ZC="" S ZS="" "RTN","C0CENC",114,0) S (ZTXT,ZCDE,ZSYS)="" "RTN","C0CENC",115,0) F S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC="" D ; TRY AND FIND A "99" CPT CODE "RTN","C0CENC",116,0) . N ZT "RTN","C0CENC",117,0) . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE "RTN","C0CENC",118,0) . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE? "RTN","C0CENC",119,0) I ZS'="" D ; CODED ENCOUNTER TYPE FOUND "RTN","C0CENC",120,0) . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE "RTN","C0CENC",121,0) . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER "RTN","C0CENC",122,0) . S ZSYS="" "RTN","C0CENC",123,0) . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE "RTN","C0CENC",124,0) I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES "RTN","C0CENC",125,0) I ZTXT="" Q 0 ; FAILED "RTN","C0CENC",126,0) W !,ZTXT "RTN","C0CENC",127,0) Q 1 ; SUCCESS "RTN","C0CENC",128,0) ; "RTN","C0CENC",129,0) ANYTXT(ZVST) ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE "RTN","C0CENC",130,0) ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED) "RTN","C0CENC",131,0) ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME "RTN","C0CENC",132,0) ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY "RTN","C0CENC",133,0) N ZK,ZL "RTN","C0CENC",134,0) S ZK="" S ZL="" "RTN","C0CENC",135,0) F S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK="" D ; LOOK FOR SOME TEXT TO USE "RTN","C0CENC",136,0) . N ZT "RTN","C0CENC",137,0) . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE "RTN","C0CENC",138,0) . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3) "RTN","C0CENC",139,0) . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE "RTN","C0CENC",140,0) I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE "RTN","C0CENC",141,0) Q ZL "RTN","C0CENC",142,0) ; "RTN","C0CENC",143,0) PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME "RTN","C0CENC",144,0) N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" "RTN","C0CENC",145,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG "RTN","C0CENC",146,0) . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER "RTN","C0CENC",147,0) . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) "RTN","C0CENC",148,0) I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR "RTN","C0CENC",149,0) Q ZRTN "RTN","C0CENC",150,0) ; "RTN","C0CENC",151,0) DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT "RTN","C0CENC",152,0) Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") "RTN","C0CENC",153,0) ; "RTN","C0CENC",154,0) CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS "RTN","C0CENC",155,0) ; CPT^CATEGORY^TEXT "RTN","C0CENC",156,0) N Z1,Z2,Z3,ZRTN "RTN","C0CENC",157,0) S Z1=$P(ISTR,U,1) "RTN","C0CENC",158,0) I Z1="" D ; "RTN","C0CENC",159,0) . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) "RTN","C0CENC",160,0) I Z1'="" D ; IF THERE IS A CPT CODE IN THERE "RTN","C0CENC",161,0) . ;S Z1=$P(ISTR,U,1) "RTN","C0CENC",162,0) . S Z2=$P(ISTR,U,2) "RTN","C0CENC",163,0) . S Z3=$P(ISTR,U,3) "RTN","C0CENC",164,0) . S ZRTN=Z1_U_Z2_U_Z3 "RTN","C0CENC",165,0) E S ZRTN="" "RTN","C0CENC",166,0) Q ZRTN "RTN","C0CENC",167,0) ; "RTN","C0CENC",168,0) MAP(ENCXML,C0CENC,ENCOUT) ; MAP PROCEDURES XML "RTN","C0CENC",169,0) ; "RTN","C0CENC",170,0) N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE "RTN","C0CENC",171,0) K @ZTEMP "RTN","C0CENC",172,0) N ZBLD "RTN","C0CENC",173,0) S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA "RTN","C0CENC",174,0) D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE "RTN","C0CENC",175,0) N ZINNER "RTN","C0CENC",176,0) D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER "RTN","C0CENC",177,0) N ZTMP,ZVAR,ZI "RTN","C0CENC",178,0) S ZI="" "RTN","C0CENC",179,0) F S ZI=$O(@C0CENC@("V",ZI)) Q:ZI="" D ;FOR EACH ENCOUNTER "RTN","C0CENC",180,0) . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML "RTN","C0CENC",181,0) . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES "RTN","C0CENC",182,0) . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE "RTN","C0CENC",183,0) . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD "RTN","C0CENC",184,0) D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0)) "RTN","C0CENC",185,0) N ZZTMP "RTN","C0CENC",186,0) D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML "RTN","C0CENC",187,0) K @ZTEMP,@ZBLD,@C0CENC "RTN","C0CENC",188,0) Q "RTN","C0CENC",189,0) ; "RTN","C0CENV") 0^14^B25371113 "RTN","C0CENV",1,0) C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 "RTN","C0CENV",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CENV",3,0) ; "RTN","C0CENV",4,0) ; "RTN","C0CENV",5,0) ENV ; Does not prevent loading of the transport global. "RTN","C0CENV",6,0) ; Environment check is done only during the install. "RTN","C0CENV",7,0) ; "RTN","C0CENV",8,0) N XQA,XQAMSG "RTN","C0CENV",9,0) ; "RTN","C0CENV",10,0) ; "RTN","C0CENV",11,0) ; Make sure the patch name exist "RTN","C0CENV",12,0) ; "RTN","C0CENV",13,0) I '$D(XPDNM) D Q "RTN","C0CENV",14,0) . D BMES("No valid patch name exist") "RTN","C0CENV",15,0) . S XPDQUIT=2 "RTN","C0CENV",16,0) . D EXIT "RTN","C0CENV",17,0) ; "RTN","C0CENV",18,0) D CHECK "RTN","C0CENV",19,0) D EXIT "RTN","C0CENV",20,0) Q "RTN","C0CENV",21,0) ; "RTN","C0CENV",22,0) ; "RTN","C0CENV",23,0) CHECK ; Perform environment check "RTN","C0CENV",24,0) ; "RTN","C0CENV",25,0) I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D "RTN","C0CENV",26,0) . D BMES("Terminal Device is not defined") "RTN","C0CENV",27,0) . S XPDQUIT=2 "RTN","C0CENV",28,0) ; "RTN","C0CENV",29,0) I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D "RTN","C0CENV",30,0) . D BMES("Please log in to set local DUZ... variables") "RTN","C0CENV",31,0) . S XPDQUIT=2 "RTN","C0CENV",32,0) ; "RTN","C0CENV",33,0) I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D "RTN","C0CENV",34,0) . D BMES("You are not a valid user on this system") "RTN","C0CENV",35,0) . S XPDQUIT=2 "RTN","C0CENV",36,0) Q "RTN","C0CENV",37,0) ; "RTN","C0CENV",38,0) ; "RTN","C0CENV",39,0) EXIT ; "RTN","C0CENV",40,0) ; "RTN","C0CENV",41,0) ; "RTN","C0CENV",42,0) I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q "RTN","C0CENV",43,0) D BMES("--- Environment Check is Ok ---") "RTN","C0CENV",44,0) ; "RTN","C0CENV",45,0) Q "RTN","C0CENV",46,0) ; "RTN","C0CENV",47,0) ; "RTN","C0CENV",48,0) PRE ;Pre-install entry point "RTN","C0CENV",49,0) ; "RTN","C0CENV",50,0) ; No action needed in pre-install "RTN","C0CENV",51,0) D BMES("No action need for pre-install") "RTN","C0CENV",52,0) ; "RTN","C0CENV",53,0) Q "RTN","C0CENV",54,0) ; "RTN","C0CENV",55,0) ; "RTN","C0CENV",56,0) POST ;Post install "RTN","C0CENV",57,0) ; "RTN","C0CENV",58,0) ; Check for RPMS system with V LAB file. "RTN","C0CENV",59,0) ; "RTN","C0CENV",60,0) I $$VFILE^DILFD(9000010.09)'=1 Q "RTN","C0CENV",61,0) ; "RTN","C0CENV",62,0) S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV") "RTN","C0CENV",63,0) S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV") "RTN","C0CENV",64,0) S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV") "RTN","C0CENV",65,0) S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV") "RTN","C0CENV",66,0) S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV") "RTN","C0CENV",67,0) S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV") "RTN","C0CENV",68,0) S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV") "RTN","C0CENV",69,0) ; "RTN","C0CENV",70,0) Q "RTN","C0CENV",71,0) ; "RTN","C0CENV",72,0) ; "RTN","C0CENV",73,0) POST1 ; Checkpoint call back entry point. "RTN","C0CENV",74,0) ; Add new style ALR1 cross-reference to V LAB file. "RTN","C0CENV",75,0) ; "RTN","C0CENV",76,0) N MSG "RTN","C0CENV",77,0) S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",78,0) D BMES(MSG) "RTN","C0CENV",79,0) D ALR1^C0CLA7DD "RTN","C0CENV",80,0) S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",81,0) D BMES(MSG) "RTN","C0CENV",82,0) Q "RTN","C0CENV",83,0) ; "RTN","C0CENV",84,0) ; "RTN","C0CENV",85,0) POST2 ; Checkpoint call back entry point. "RTN","C0CENV",86,0) ; Add new style ALR2 cross-reference to V LAB file. "RTN","C0CENV",87,0) ; "RTN","C0CENV",88,0) N MSG "RTN","C0CENV",89,0) S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",90,0) D BMES(MSG) "RTN","C0CENV",91,0) D ALR2^C0CLA7DD "RTN","C0CENV",92,0) S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",93,0) D BMES(MSG) "RTN","C0CENV",94,0) Q "RTN","C0CENV",95,0) ; "RTN","C0CENV",96,0) ; "RTN","C0CENV",97,0) POST3 ; Checkpoint call back entry point. "RTN","C0CENV",98,0) ; Add new style ALR3 cross-reference to V LAB file. "RTN","C0CENV",99,0) ; "RTN","C0CENV",100,0) N MSG "RTN","C0CENV",101,0) S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",102,0) D BMES(MSG) "RTN","C0CENV",103,0) D ALR3^C0CLA7DD "RTN","C0CENV",104,0) S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",105,0) D BMES(MSG) "RTN","C0CENV",106,0) Q "RTN","C0CENV",107,0) ; "RTN","C0CENV",108,0) ; "RTN","C0CENV",109,0) POST4 ; Checkpoint call back entry point. "RTN","C0CENV",110,0) ; Add new style ALR4 cross-reference to V LAB file. "RTN","C0CENV",111,0) ; "RTN","C0CENV",112,0) N MSG "RTN","C0CENV",113,0) S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",114,0) D BMES(MSG) "RTN","C0CENV",115,0) D ALR4^C0CLA7DD "RTN","C0CENV",116,0) S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",117,0) D BMES(MSG) "RTN","C0CENV",118,0) Q "RTN","C0CENV",119,0) ; "RTN","C0CENV",120,0) ; "RTN","C0CENV",121,0) POST5 ; Checkpoint call back entry point. "RTN","C0CENV",122,0) ; Add new style ALR5 cross-reference to V LAB file. "RTN","C0CENV",123,0) ; "RTN","C0CENV",124,0) N MSG "RTN","C0CENV",125,0) S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",126,0) D BMES(MSG) "RTN","C0CENV",127,0) D ALR5^C0CLA7DD "RTN","C0CENV",128,0) S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CENV",129,0) D BMES(MSG) "RTN","C0CENV",130,0) Q "RTN","C0CENV",131,0) ; "RTN","C0CENV",132,0) ; "RTN","C0CENV",133,0) POST6 ; Checkpoint call back entry point. "RTN","C0CENV",134,0) ; Check for RPMS system and determine LAB patch level "RTN","C0CENV",135,0) ; and need to load in C0C version of LA7 routines. "RTN","C0CENV",136,0) ; "RTN","C0CENV",137,0) N MSG "RTN","C0CENV",138,0) ; "RTN","C0CENV",139,0) ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed "RTN","C0CENV",140,0) I '$$PATCH^XPDUTL("LA*5.2*69") D "RTN","C0CENV",141,0) . S MSG="This system missing LAB patch LA*5.2*69" "RTN","C0CENV",142,0) . D BMES(MSG) "RTN","C0CENV",143,0) . S MSG="Renaming routine C0CQRY2 to LA7QRY2" "RTN","C0CENV",144,0) . D BMES(MSG) "RTN","C0CENV",145,0) . D LOAD("C0CQRY2") "RTN","C0CENV",146,0) . D SAVE("C0CQRY2","LA7QRY2") "RTN","C0CENV",147,0) ; "RTN","C0CENV",148,0) ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed. "RTN","C0CENV",149,0) I '$$PATCH^XPDUTL("LA*5.2*64") D "RTN","C0CENV",150,0) . S MSG="This system missing LAB patch LA*5.2*64" "RTN","C0CENV",151,0) . D BMES(MSG) "RTN","C0CENV",152,0) . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1" "RTN","C0CENV",153,0) . D BMES(MSG) "RTN","C0CENV",154,0) . D LOAD("C0CVOBX1") "RTN","C0CENV",155,0) . D SAVE("C0CVOBX1","LA7VOBX1") "RTN","C0CENV",156,0) ; "RTN","C0CENV",157,0) ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed. "RTN","C0CENV",158,0) I '$$PATCH^XPDUTL("LA*5.2*68") D "RTN","C0CENV",159,0) . S MSG="This system missing LAB patch LA*5.2*68" "RTN","C0CENV",160,0) . D BMES(MSG) "RTN","C0CENV",161,0) . S MSG="Renaming routine C0CQRY1 to LA7QRY1" "RTN","C0CENV",162,0) . D BMES(MSG) "RTN","C0CENV",163,0) . D LOAD("C0CQRY1") "RTN","C0CENV",164,0) . D SAVE("C0CQRY1","LA7QRY1") "RTN","C0CENV",165,0) ; "RTN","C0CENV",166,0) Q "RTN","C0CENV",167,0) ; "RTN","C0CENV",168,0) ; "RTN","C0CENV",169,0) POST7 ; Checkpoint call back entry point. "RTN","C0CENV",170,0) ; "RTN","C0CENV",171,0) D REINDEX^C0CLA7DD "RTN","C0CENV",172,0) ; "RTN","C0CENV",173,0) Q "RTN","C0CENV",174,0) ; "RTN","C0CENV",175,0) ; "RTN","C0CENV",176,0) BMES(STR) ; Write BMES^XPDUTL statements "RTN","C0CENV",177,0) ; "RTN","C0CENV",178,0) D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) "RTN","C0CENV",179,0) ; "RTN","C0CENV",180,0) Q "RTN","C0CENV",181,0) ; "RTN","C0CENV",182,0) ; "RTN","C0CENV",183,0) LOAD(X) ; load routine X "RTN","C0CENV",184,0) N %N,DIF,XCNP "RTN","C0CENV",185,0) K ^TMP($J,X) "RTN","C0CENV",186,0) S DIF="^TMP($J,X,",XCNP=0 "RTN","C0CENV",187,0) X ^%ZOSF("LOAD") "RTN","C0CENV",188,0) Q "RTN","C0CENV",189,0) ; "RTN","C0CENV",190,0) ; "RTN","C0CENV",191,0) SAVE(OLD,NEW) ; restore routine X "RTN","C0CENV",192,0) N %,DIE,X,XCM,XCN,XCS "RTN","C0CENV",193,0) S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW "RTN","C0CENV",194,0) X ^%ZOSF("SAVE") "RTN","C0CENV",195,0) Q "RTN","C0CEVC") 0^15^B14016673 "RTN","C0CEVC",1,0) C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 "RTN","C0CEVC",2,0) ;;1.0;C0C;;Mar 1, 2010;Build 1 "RTN","C0CEVC",3,0) gpltest2 ; experiment with sending a CCR to an ewd page "RTN","C0CEVC",4,0) N ZI "RTN","C0CEVC",5,0) S ZI="" "RTN","C0CEVC",6,0) D PSEUDO "RTN","C0CEVC",7,0) N ZIO "RTN","C0CEVC",8,0) S ZIO=IO "RTN","C0CEVC",9,0) S IO="/dev/null" "RTN","C0CEVC",10,0) OPEN IO "RTN","C0CEVC",11,0) U IO "RTN","C0CEVC",12,0) N G "RTN","C0CEVC",13,0) S G=$$URLTOKEN^C0CEWD "RTN","C0CEVC",14,0) D CCRRPC^C0CCCR(.GPL,2) "RTN","C0CEVC",15,0) S IO=ZIO "RTN","C0CEVC",16,0) OPEN IO "RTN","C0CEVC",17,0) U IO "RTN","C0CEVC",18,0) K GPL(0) "RTN","C0CEVC",19,0) F S ZI=$O(GPL(ZI)) Q:ZI="" W GPL(ZI),! "RTN","C0CEVC",20,0) Q "RTN","C0CEVC",21,0) ; "RTN","C0CEVC",22,0) gpltest ; experiment with sending a CCR to an ewd page "RTN","C0CEVC",23,0) N ZI "RTN","C0CEVC",24,0) S ZI="" "RTN","C0CEVC",25,0) K ^GPL(0) "RTN","C0CEVC",26,0) S ^GPL(2)="" "RTN","C0CEVC",27,0) F S ZI=$O(^GPL(ZI)) Q:ZI="" W ^GPL(ZI),! "RTN","C0CEVC",28,0) Q "RTN","C0CEVC",29,0) ; "RTN","C0CEVC",30,0) TEST(sessid); "RTN","C0CEVC",31,0) d setSessionValue^%zewdAPI("person.Name","Rob",sessid) "RTN","C0CEVC",32,0) d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid) "RTN","C0CEVC",33,0) d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid) "RTN","C0CEVC",34,0) d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid) "RTN","C0CEVC",35,0) d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid) "RTN","C0CEVC",36,0) d setJSONValue^%zewdAPI("json","person",sessid) "RTN","C0CEVC",37,0) Q "" "RTN","C0CEVC",38,0) "RTN","C0CEVC",39,0) PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME "RTN","C0CEVC",40,0) ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD "RTN","C0CEVC",41,0) ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD "RTN","C0CEVC",42,0) N ZR "RTN","C0CEVC",43,0) M ^CacheTempEWD($j)=@INXML ; "RTN","C0CEVC",44,0) S ZR=$$parseDocument^%zewdHTMLParser(INDOC) "RTN","C0CEVC",45,0) Q ZR "RTN","C0CEVC",46,0) ; "RTN","C0CEVC",47,0) TEST2(sessid) ; try to put a ccr in the session "RTN","C0CEVC",48,0) S U="^" "RTN","C0CEVC",49,0) D PSEUDO ; FAKE LOGIN "RTN","C0CEVC",50,0) S ZIO=$IO "RTN","C0CEVC",51,0) S DEV="/dev/null" "RTN","C0CEVC",52,0) O DEV U DEV "RTN","C0CEVC",53,0) N G "RTN","C0CEVC",54,0) N ZDFN "RTN","C0CEVC",55,0) S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid) "RTN","C0CEVC",56,0) I ZDFN="" S ZDFN=2 "RTN","C0CEVC",57,0) ;K ^TMP("GPL") "RTN","C0CEVC",58,0) ;M ^TMP("GPL")=^%zewdSession("session",sessid) "RTN","C0CEVC",59,0) D CCRRPC^C0CCCR(.GPL,ZDFN) "RTN","C0CEVC",60,0) K GPL(0) "RTN","C0CEVC",61,0) S GPL(2)="" "RTN","C0CEVC",62,0) C DEV U ZIO "RTN","C0CEVC",63,0) ;M ^CacheTempEWD($j)=GPL "RTN","C0CEVC",64,0) S DOCNAME="CCR" "RTN","C0CEVC",65,0) ;ZWR GPL "RTN","C0CEVC",66,0) ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME) "RTN","C0CEVC",67,0) ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid) "RTN","C0CEVC",68,0) d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid) "RTN","C0CEVC",69,0) Q "" "RTN","C0CEVC",70,0) ; "RTN","C0CEVC",71,0) INITSES(sessid) ;initialize an EWD/CPRS session "RTN","C0CEVC",72,0) K ^TMP("GPL") "RTN","C0CEVC",73,0) ;M ^TMP("GPL")=^%zewdSession("session",sessid) "RTN","C0CEVC",74,0) N ZT,ZDFN "RTN","C0CEVC",75,0) S ZT=$$URLTOKEN^C0CEWD(sessid) "RTN","C0CEVC",76,0) ;S ^TMP("GPL")=ZT "RTN","C0CEVC",77,0) d trace^%zewdAPI("*********************ZT="_ZT) "RTN","C0CEVC",78,0) S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN "RTN","C0CEVC",79,0) S ^TMP("GPL","DFN")=ZDFN "RTN","C0CEVC",80,0) I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT "RTN","C0CEVC",81,0) D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid) "RTN","C0CEVC",82,0) ;M ^TMP("GPL","request")=requestArray "RTN","C0CEVC",83,0) ;D PSEUDO "RTN","C0CEVC",84,0) ;D ^%ZTER "RTN","C0CEVC",85,0) q "" "RTN","C0CEVC",86,0) ; "RTN","C0CEVC",87,0) PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN "RTN","C0CEVC",88,0) ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: "RTN","C0CEVC",89,0) ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6) "RTN","C0CEVC",90,0) N ZX,ZN1,ZIP,ZN2,ZDFN,ZG "RTN","C0CEVC",91,0) S ZDFN=0 ; DEFAULT RETURN "RTN","C0CEVC",92,0) S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER "RTN","C0CEVC",93,0) S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER "RTN","C0CEVC",94,0) S ZIP=$P(ZIP,"'",2) ; GET RID OF ' "RTN","C0CEVC",95,0) S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER "RTN","C0CEVC",96,0) S ZN2=$P(ZN2,")",1) ; GET RID OF ) "RTN","C0CEVC",97,0) S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME "RTN","C0CEVC",98,0) I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL "RTN","C0CEVC",99,0) S ^TMP("GPL","FIRSTDFN")=ZDFN "RTN","C0CEVC",100,0) S ^TMP("GPL","FIRSTGLB")=ZG "RTN","C0CEVC",101,0) Q ZDFN "RTN","C0CEVC",102,0) ; "RTN","C0CEVC",103,0) GETPATIENTLIST(sessid) ; "RTN","C0CEVC",104,0) D PSEUDO "RTN","C0CEVC",105,0) D LISTALL^ORWPT(.RTN,"NAME","1") "RTN","C0CEVC",106,0) N ZI "RTN","C0CEVC",107,0) S ZI="" "RTN","C0CEVC",108,0) F S ZI=$O(RTN(ZI)) Q:ZI="" D ; "RTN","C0CEVC",109,0) . S data(ZI,"DFN")=$P(RTN(ZI),"^",1) "RTN","C0CEVC",110,0) . S data(ZI,"Name")=$P(RTN(ZI),"^",2) "RTN","C0CEVC",111,0) ; ZWR data "RTN","C0CEVC",112,0) ;S data(1,"DFN")=$P(RTN(1),"^",1) "RTN","C0CEVC",113,0) ;S data(1,"Name")=$P(RTN(1),"^",2) "RTN","C0CEVC",114,0) d deleteFromSession^%zewdAPI("patients",sessid) "RTN","C0CEVC",115,0) d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid) "RTN","C0CEVC",116,0) ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid) "RTN","C0CEVC",117,0) Q "" "RTN","C0CEVC",118,0) ; "RTN","C0CEVC",119,0) PSEUDO "RTN","C0CEVC",120,0) S U="^" "RTN","C0CEVC",121,0) S DILOCKTM=3 "RTN","C0CEVC",122,0) S DISYS=19 "RTN","C0CEVC",123,0) S DT=3100219 "RTN","C0CEVC",124,0) S DTIME=999 "RTN","C0CEVC",125,0) S DUZ=10 "RTN","C0CEVC",126,0) S DUZ(0)="@" "RTN","C0CEVC",127,0) S DUZ(1)="" "RTN","C0CEVC",128,0) S DUZ(2)=1 "RTN","C0CEVC",129,0) S DUZ("AG")="V" "RTN","C0CEVC",130,0) S DUZ("BUF")=1 "RTN","C0CEVC",131,0) S DUZ("LANG")="" "RTN","C0CEVC",132,0) ;S IO="/dev/pts/2" "RTN","C0CEVC",133,0) ;S IO(0)="/dev/pts/2" "RTN","C0CEVC",134,0) ;S IO(1,"/dev/pts/2")="" "RTN","C0CEVC",135,0) ;S IO("ERROR")="" "RTN","C0CEVC",136,0) ;S IO("HOME")="41^/dev/pts/2" "RTN","C0CEVC",137,0) ;S IO("ZIO")="/dev/pts/2" "RTN","C0CEVC",138,0) ;S IOBS="$C(8)" "RTN","C0CEVC",139,0) ;S IOF="#,$C(27,91,50,74,27,91,72)" "RTN","C0CEVC",140,0) ;S SIOM=80 "RTN","C0CEVC",141,0) Q "RTN","C0CEVC",142,0) ; "RTN","C0CEVC",143,0) PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN "RTN","C0CEVC",144,0) S DILOCKTM=3 "RTN","C0CEVC",145,0) S DISYS=19 "RTN","C0CEVC",146,0) S DT=3100112 "RTN","C0CEVC",147,0) S DTIME=9999 "RTN","C0CEVC",148,0) S DUZ=10000000020 "RTN","C0CEVC",149,0) S DUZ(0)="@" "RTN","C0CEVC",150,0) S DUZ(1)="" "RTN","C0CEVC",151,0) S DUZ(2)=67 "RTN","C0CEVC",152,0) S DUZ("AG")="E" "RTN","C0CEVC",153,0) S DUZ("BUF")=1 "RTN","C0CEVC",154,0) S DUZ("LANG")=1 "RTN","C0CEVC",155,0) S IO="/dev/pts/0" "RTN","C0CEVC",156,0) ;S IO(0)="/dev/pts/0" "RTN","C0CEVC",157,0) ;S IO(1,"/dev/pts/0")="" "RTN","C0CEVC",158,0) ;S IO("ERROR")="" "RTN","C0CEVC",159,0) ;S IO("HOME")="50^/dev/pts/0" "RTN","C0CEVC",160,0) ;S IO("ZIO")="/dev/pts/0" "RTN","C0CEVC",161,0) ;S IOBS="$C(8)" "RTN","C0CEVC",162,0) ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)" "RTN","C0CEVC",163,0) ;S IOM=80 "RTN","C0CEVC",164,0) ;S ION="GTM/UNIX TELNET" "RTN","C0CEVC",165,0) ;S IOS=50 "RTN","C0CEVC",166,0) ;S IOSL=24 "RTN","C0CEVC",167,0) ;S IOST="C-VT100" "RTN","C0CEVC",168,0) ;S IOST(0)=9 "RTN","C0CEVC",169,0) ;S IOT="VTRM" "RTN","C0CEVC",170,0) ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" "RTN","C0CEVC",171,0) S U="^" "RTN","C0CEVC",172,0) S X="1;DIC(4.2," "RTN","C0CEVC",173,0) S XPARSYS="1;DIC(4.2," "RTN","C0CEVC",174,0) S XQXFLG="^^XUP" "RTN","C0CEVC",175,0) S Y="DEV^VISTA^hollywood^VISTA:hollywood" "RTN","C0CEVC",176,0) Q "RTN","C0CEVC",177,0) ; "RTN","C0CEWD") 0^16^B5607678 "RTN","C0CEWD",1,0) C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 "RTN","C0CEWD",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 "RTN","C0CEWD",3,0) ;Copyright 2011 George Lilly. Licensed under the terms of the GNU "RTN","C0CEWD",4,0) ;General Public License See attached copy of the License. "RTN","C0CEWD",5,0) ; "RTN","C0CEWD",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CEWD",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CEWD",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CEWD",9,0) ;(at your option) any later version. "RTN","C0CEWD",10,0) ; "RTN","C0CEWD",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CEWD",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CEWD",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CEWD",14,0) ;GNU General Public License for more details. "RTN","C0CEWD",15,0) ; "RTN","C0CEWD",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CEWD",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CEWD",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CEWD",19,0) ; "RTN","C0CEWD",20,0) Q "RTN","C0CEWD",21,0) ; "RTN","C0CEWD",22,0) TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN "RTN","C0CEWD",23,0) Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE "RTN","C0CEWD",24,0) ; "RTN","C0CEWD",25,0) STORE(ZARY) ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN "RTN","C0CEWD",26,0) ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION "RTN","C0CEWD",27,0) ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME "RTN","C0CEWD",28,0) N ZT "RTN","C0CEWD",29,0) S ZT=$$TOKEN ; GET A NEW TOKEN "RTN","C0CEWD",30,0) M ^TMP("C0E","TOKEN",ZT)=@ZARY ; "RTN","C0CEWD",31,0) Q ZT "RTN","C0CEWD",32,0) ; "RTN","C0CEWD",33,0) GET(C0ERTN,C0ETOKEN,NOKILL) ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN "RTN","C0CEWD",34,0) ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1 "RTN","C0CEWD",35,0) ; C0ERTN IS PASSED BY NAME "RTN","C0CEWD",36,0) I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D Q ; DOESN'T EXIST "RTN","C0CEWD",37,0) . S @C0ERTN="" ; PASS BACK NULL "RTN","C0CEWD",38,0) M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE "RTN","C0CEWD",39,0) I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE "RTN","C0CEWD",40,0) Q "RTN","C0CEWD",41,0) ; "RTN","C0CEWD",42,0) URLTOKEN(sessid) ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL "RTN","C0CEWD",43,0) ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345" "RTN","C0CEWD",44,0) N token "RTN","C0CEWD",45,0) S token="" "RTN","C0CEWD",46,0) s token=$$getRequestValue^%zewdAPI("token",sessid) "RTN","C0CEWD",47,0) s token=$tr(token,"""") ; strip out quotes "RTN","C0CEWD",48,0) Q token "RTN","C0CEWD",49,0) ; "RTN","C0CEWD",50,0) cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) "RTN","C0CEWD",51,0) ; "RTN","C0CEWD",52,0) n maxNo,noFound "RTN","C0CEWD",53,0) ; "RTN","C0CEWD",54,0) s maxNo=50 "RTN","C0CEWD",55,0) s noFound=0 "RTN","C0CEWD",56,0) f s seedValue=$o(^DPT("B",seedValue)) q:seedValue="" q:noFound=maxNo d "RTN","C0CEWD",57,0) . s lastSeedValue=seedValue "RTN","C0CEWD",58,0) . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q "RTN","C0CEWD",59,0) . s optionNo=optionNo+1 "RTN","C0CEWD",60,0) . s noFound=noFound+1 "RTN","C0CEWD",61,0) . s options(optionNo)=seedValue "RTN","C0CEWD",62,0) QUIT "RTN","C0CEWD",63,0) ; "RTN","C0CEWD",64,0) set1 ; "RTN","C0CEWD",65,0) s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW" "RTN","C0CEWD",66,0) q "RTN","C0CEWD",67,0) ; "RTN","C0CEWD",68,0) test1(sessid) ; "RTN","C0CEWD",69,0) d setSessionValue^%zewdAPI("testing","ZZ",sessid) "RTN","C0CEWD",70,0) q 0 "RTN","C0CEWD",71,0) ; "RTN","C0CEWD1") 0^17^B6563070 "RTN","C0CEWD1",1,0) C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 "RTN","C0CEWD1",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 "RTN","C0CEWD1",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CEWD1",4,0) ;General Public License See attached copy of the License. "RTN","C0CEWD1",5,0) ; "RTN","C0CEWD1",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CEWD1",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CEWD1",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CEWD1",9,0) ;(at your option) any later version. "RTN","C0CEWD1",10,0) ; "RTN","C0CEWD1",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CEWD1",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CEWD1",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CEWD1",14,0) ;GNU General Public License for more details. "RTN","C0CEWD1",15,0) ; "RTN","C0CEWD1",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CEWD1",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CEWD1",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CEWD1",19,0) ; "RTN","C0CEWD1",20,0) Q "RTN","C0CEWD1",21,0) ; "RTN","C0CEWD1",22,0) TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN "RTN","C0CEWD1",23,0) i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists "RTN","C0CEWD1",24,0) . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" "RTN","C0CEWD1",25,0) . s zfile=$re($p($re(filepath),"/",1)) ;file name "RTN","C0CEWD1",26,0) . s zpath=$p(filepath,zfile,1) ; file path "RTN","C0CEWD1",27,0) . s ztmp=$na(^CacheTempEWD($j,0)) "RTN","C0CEWD1",28,0) . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 "RTN","C0CEWD1",29,0) q "RTN","C0CEWD1",30,0) ; "RTN","C0CEWD1",31,0) TEST2 ; "RTN","C0CEWD1",32,0) s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" "RTN","C0CEWD1",33,0) ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) "RTN","C0CEWD1",34,0) s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global "RTN","C0CEWD1",35,0) s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) "RTN","C0CEWD1",36,0) ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") "RTN","C0CEWD1",37,0) w ok,! "RTN","C0CEWD1",38,0) q "RTN","C0CEWD1",39,0) ; "RTN","C0CEWD1",40,0) LOAD(filepath) ; load an xml file into the EWD global for DOM processing "RTN","C0CEWD1",41,0) ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) "RTN","C0CEWD1",42,0) ; after to process it to the DOM - isHTML=0 for XML files "RTN","C0CEWD1",43,0) n i "RTN","C0CEWD1",44,0) i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 "RTN","C0CEWD1",45,0) . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" "RTN","C0CEWD1",46,0) . s zfile=$re($p($re(filepath),"/",1)) ;file name "RTN","C0CEWD1",47,0) . s zpath=$p(filepath,zfile,1) ; file path "RTN","C0CEWD1",48,0) . s ztmp=$na(^CacheTempEWD($j,0)) "RTN","C0CEWD1",49,0) . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 "RTN","C0CEWD1",50,0) . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number "RTN","C0CEWD1",51,0) q i "RTN","C0CEWD1",52,0) ; "RTN","C0CEWD1",53,0) Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED "RTN","C0CEWD1",54,0) I '$D(ZD) S ZD="DerekDOM" "RTN","C0CEWD1",55,0) s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; "RTN","C0CEWD1",56,0) d displayNodes^%zewdXPath(.nodes) "RTN","C0CEWD1",57,0) q "RTN","C0CEWD1",58,0) ; "RTN","C0CEWD1",59,0) GET1URL0(URL) ; "RTN","C0CEWD1",60,0) s ok=$$httpGET^%zewdGTM(URL,.gpl) "RTN","C0CEWD1",61,0) D INDEX^C0CXPATH("gpl","gpl2") "RTN","C0CEWD1",62,0) W !,"S URL=""",URL,"""",! "RTN","C0CEWD1",63,0) S G="" "RTN","C0CEWD1",64,0) F S G=$O(gpl2(G)) Q:G="" D ; "RTN","C0CEWD1",65,0) . W " S VDX(""",G,""")=""",gpl2(G),"""",! "RTN","C0CEWD1",66,0) W ! "RTN","C0CEWD1",67,0) Q "RTN","C0CFM1") 0^18^B27048099 "RTN","C0CFM1",1,0) C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 "RTN","C0CFM1",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CFM1",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CFM1",4,0) ;General Public License See attached copy of the License. "RTN","C0CFM1",5,0) ; "RTN","C0CFM1",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CFM1",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CFM1",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CFM1",9,0) ;(at your option) any later version. "RTN","C0CFM1",10,0) ; "RTN","C0CFM1",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CFM1",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CFM1",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CFM1",14,0) ;GNU General Public License for more details. "RTN","C0CFM1",15,0) ; "RTN","C0CFM1",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CFM1",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CFM1",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CFM1",19,0) ; "RTN","C0CFM1",20,0) W "This is the CCR FILEMAN Utility Library ",! "RTN","C0CFM1",21,0) W ! "RTN","C0CFM1",22,0) Q "RTN","C0CFM1",23,0) ; "RTN","C0CFM1",24,0) PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE "RTN","C0CFM1",25,0) ; "RTN","C0CFM1",26,0) S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN)) "RTN","C0CFM1",27,0) I '$D(ZWHICH) S ZWHICH="ALL" "RTN","C0CFM1",28,0) I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED "RTN","C0CFM1",29,0) . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) "RTN","C0CFM1",30,0) . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION "RTN","C0CFM1",31,0) E D ; MULTIPLE SECTIONS "RTN","C0CFM1",32,0) . S C0CVARS=$NA(@C0CGLB) "RTN","C0CFM1",33,0) . S C0CI="" "RTN","C0CFM1",34,0) . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION "RTN","C0CFM1",35,0) . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION "RTN","C0CFM1",36,0) . . D PUTRIM1(DFN,C0CI,C0CVARSN) "RTN","C0CFM1",37,0) Q "RTN","C0CFM1",38,0) ; "RTN","C0CFM1",39,0) PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS "RTN","C0CFM1",40,0) ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" "RTN","C0CFM1",41,0) S C0CX=0 "RTN","C0CFM1",42,0) F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE "RTN","C0CFM1",43,0) . W "ZOCC=",C0CX,! "RTN","C0CFM1",44,0) . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE "RTN","C0CFM1",45,0) . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE "RTN","C0CFM1",46,0) Q "RTN","C0CFM1",47,0) ; "RTN","C0CFM1",48,0) PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE "RTN","C0CFM1",49,0) ; ^C0C(171.201, DFN IS THE PATIENT IEN PASSED BY VALUE "RTN","C0CFM1",50,0) ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE "RTN","C0CFM1",51,0) ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC "RTN","C0CFM1",52,0) ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM "RTN","C0CFM1",53,0) ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT "RTN","C0CFM1",54,0) ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES "RTN","C0CFM1",55,0) ; "RTN","C0CFM1",56,0) S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 "RTN","C0CFM1",57,0) ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE "RTN","C0CFM1",58,0) N ZF,ZFV S ZF=171.201 S ZFV=171.2012 "RTN","C0CFM1",59,0) S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS "RTN","C0CFM1",60,0) N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER "RTN","C0CFM1",61,0) N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) "RTN","C0CFM1",62,0) W "ZTYPE: ",ZTYPE," ",ZTYPN,! "RTN","C0CFM1",63,0) N ZVARN ; IEN OF VARIABLE BEING PROCESSED "RTN","C0CFM1",64,0) ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE "RTN","C0CFM1",65,0) S C0CFDA(ZF,"?+1,",.01)=DFN "RTN","C0CFM1",66,0) S C0CFDA(ZF,"?+1,",.02)=ZSRC "RTN","C0CFM1",67,0) S C0CFDA(ZF,"?+1,",.03)=ZTYPN "RTN","C0CFM1",68,0) S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE "RTN","C0CFM1",69,0) K ZERR "RTN","C0CFM1",70,0) D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER "RTN","C0CFM1",71,0) I $D(ZERR) B ;OOPS "RTN","C0CFM1",72,0) K C0CFDA "RTN","C0CFM1",73,0) S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,"")) "RTN","C0CFM1",74,0) W "RECORD NUMBER: ",ZD0,! "RTN","C0CFM1",75,0) ;B "RTN","C0CFM1",76,0) S ZCNT=0 "RTN","C0CFM1",77,0) S ZC0CI="" ; "RTN","C0CFM1",78,0) F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; "RTN","C0CFM1",79,0) . I ZC0CI'="M" D ; NOT A SUBVARIABLE "RTN","C0CFM1",80,0) . . S ZCNT=ZCNT+1 ;INCREMENT COUNT "RTN","C0CFM1",81,0) . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT "RTN","C0CFM1",82,0) . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND "RTN","C0CFM1",83,0) . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN "RTN","C0CFM1",84,0) . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM1",85,0) . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN "RTN","C0CFM1",86,0) . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM1",87,0) ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" "RTN","C0CFM1",88,0) ;S GT1(170,"?+1,",12)="DIR" "RTN","C0CFM1",89,0) ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" "RTN","C0CFM1",90,0) ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" "RTN","C0CFM1",91,0) D CLEAN^DILF "RTN","C0CFM1",92,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CFM1",93,0) Q "RTN","C0CFM1",94,0) ; "RTN","C0CFM1",95,0) VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE "RTN","C0CFM1",96,0) ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO "RTN","C0CFM1",97,0) ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO "RTN","C0CFM1",98,0) ; "RTN","C0CFM1",99,0) N ZCCRD,ZVARN,C0CFDA2 "RTN","C0CFM1",100,0) S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY "RTN","C0CFM1",101,0) S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CFM1",102,0) I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT "RTN","C0CFM1",103,0) . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE "RTN","C0CFM1",104,0) . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! "RTN","C0CFM1",105,0) . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE "RTN","C0CFM1",106,0) . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE "RTN","C0CFM1",107,0) . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN "RTN","C0CFM1",108,0) . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY "RTN","C0CFM1",109,0) . I $D(ZERR) D ; LAYGO ERROR "RTN","C0CFM1",110,0) . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! "RTN","C0CFM1",111,0) . E D ; "RTN","C0CFM1",112,0) . . D CLEAN^DILF ; CLEAN UP "RTN","C0CFM1",113,0) . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CFM1",114,0) . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! "RTN","C0CFM1",115,0) Q ZVARN "RTN","C0CFM1",116,0) ; "RTN","C0CFM1",117,0) BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) "RTN","C0CFM1",118,0) ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED "RTN","C0CFM1",119,0) ; "RTN","C0CFM1",120,0) N C0CDIC,C0CNODE ; "RTN","C0CFM1",121,0) S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY "RTN","C0CFM1",122,0) S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE "RTN","C0CFM1",123,0) Q "RTN","C0CFM1",124,0) ; "RTN","C0CFM1",125,0) FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED "RTN","C0CFM1",126,0) ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET "RTN","C0CFM1",127,0) ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS "RTN","C0CFM1",128,0) ; CONVERSION "RTN","C0CFM1",129,0) ;N C0CC,C0CI,C0CJ,C0CN,C0CZX "RTN","C0CFM1",130,0) D FIELDS^C0CRNF("C0CC",170) "RTN","C0CFM1",131,0) S C0CI="" "RTN","C0CFM1",132,0) F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION "RTN","C0CFM1",133,0) . S C0CZX="" "RTN","C0CFM1",134,0) . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE "RTN","C0CFM1",135,0) . . W "SECTION ",C0CI," VAR ",C0CZX "RTN","C0CFM1",136,0) . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) "RTN","C0CFM1",137,0) . . W " TYPE: ",C0CV,! "RTN","C0CFM1",138,0) . . D SETFDA("SECTION",C0CV) "RTN","C0CFM1",139,0) . . ;ZWR C0CFDA "RTN","C0CFM1",140,0) Q "RTN","C0CFM1",141,0) ; "RTN","C0CFM1",142,0) SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN "RTN","C0CFM1",143,0) ; TO SET TO VALUE C0CSV. "RTN","C0CFM1",144,0) ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE "RTN","C0CFM1",145,0) ; C0CSN,C0CSV ARE PASSED BY VALUE "RTN","C0CFM1",146,0) ; "RTN","C0CFM1",147,0) N C0CSI,C0CSJ "RTN","C0CFM1",148,0) S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER "RTN","C0CFM1",149,0) S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER "RTN","C0CFM1",150,0) S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV "RTN","C0CFM1",151,0) Q "RTN","C0CFM1",152,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CFM1",153,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) "RTN","C0CFM1",154,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM1",155,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM1",156,0) N ZR "RTN","C0CFM1",157,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) "RTN","C0CFM1",158,0) E S ZR="" "RTN","C0CFM1",159,0) Q ZR "RTN","C0CFM1",160,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CFM1",161,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) "RTN","C0CFM1",162,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM1",163,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM1",164,0) N ZR "RTN","C0CFM1",165,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) "RTN","C0CFM1",166,0) E S ZR="" "RTN","C0CFM1",167,0) Q ZR "RTN","C0CFM1",168,0) ; "RTN","C0CFM1",169,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CFM1",170,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) "RTN","C0CFM1",171,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM1",172,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM1",173,0) N ZR "RTN","C0CFM1",174,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) "RTN","C0CFM1",175,0) E S ZR="" "RTN","C0CFM1",176,0) Q ZR "RTN","C0CFM1",177,0) ; "RTN","C0CFM2") 0^19^B102195978 "RTN","C0CFM2",1,0) C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 "RTN","C0CFM2",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CFM2",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CFM2",4,0) ;General Public License See attached copy of the License. "RTN","C0CFM2",5,0) ; "RTN","C0CFM2",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CFM2",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CFM2",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CFM2",9,0) ;(at your option) any later version. "RTN","C0CFM2",10,0) ; "RTN","C0CFM2",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CFM2",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CFM2",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CFM2",14,0) ;GNU General Public License for more details. "RTN","C0CFM2",15,0) ; "RTN","C0CFM2",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CFM2",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CFM2",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CFM2",19,0) ; "RTN","C0CFM2",20,0) W "This is the CCR FILEMAN Utility Library ",! "RTN","C0CFM2",21,0) ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF "RTN","C0CFM2",22,0) ; CCR ELEMENTS (^C0C(179.201, "RTN","C0CFM2",23,0) ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE "RTN","C0CFM2",24,0) ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT "RTN","C0CFM2",25,0) ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS "RTN","C0CFM2",26,0) ; ALL SUB-VARIABLES HAVE BEEN REMOVED "RTN","C0CFM2",27,0) W ! "RTN","C0CFM2",28,0) Q "RTN","C0CFM2",29,0) ; "RTN","C0CFM2",30,0) RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE "RTN","C0CFM2",31,0) ; "RTN","C0CFM2",32,0) I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS "RTN","C0CFM2",33,0) N ZI,ZJ,ZC,ZPATBASE "RTN","C0CFM2",34,0) S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) "RTN","C0CFM2",35,0) S ZI="" "RTN","C0CFM2",36,0) F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END "RTN","C0CFM2",37,0) . S ZI=$O(@ZPATBASE@(ZI)) "RTN","C0CFM2",38,0) . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE "RTN","C0CFM2",39,0) Q "RTN","C0CFM2",40,0) ; "RTN","C0CFM2",41,0) PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE "RTN","C0CFM2",42,0) ; "RTN","C0CFM2",43,0) S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) "RTN","C0CFM2",44,0) I '$D(ZWHICH) S ZWHICH="ALL" "RTN","C0CFM2",45,0) I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED "RTN","C0CFM2",46,0) . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) "RTN","C0CFM2",47,0) . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION "RTN","C0CFM2",48,0) E D ; MULTIPLE SECTIONS "RTN","C0CFM2",49,0) . S C0CVARS=$NA(@C0CGLB) "RTN","C0CFM2",50,0) . S C0CI="" "RTN","C0CFM2",51,0) . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION "RTN","C0CFM2",52,0) . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION "RTN","C0CFM2",53,0) . . D PUTRIM1(DFN,C0CI,C0CVARSN) "RTN","C0CFM2",54,0) Q "RTN","C0CFM2",55,0) ; "RTN","C0CFM2",56,0) PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS "RTN","C0CFM2",57,0) ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" "RTN","C0CFM2",58,0) S C0CX=0 "RTN","C0CFM2",59,0) F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE "RTN","C0CFM2",60,0) . W "ZOCC=",C0CX,! "RTN","C0CFM2",61,0) . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME "RTN","C0CFM2",62,0) . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE "RTN","C0CFM2",63,0) . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE "RTN","C0CFM2",64,0) . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() "RTN","C0CFM2",65,0) . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV "RTN","C0CFM2",66,0) . . S ZZCNT=0 "RTN","C0CFM2",67,0) . . S ZZC0CI=0 "RTN","C0CFM2",68,0) . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE "RTN","C0CFM2",69,0) . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE "RTN","C0CFM2",70,0) . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR "RTN","C0CFM2",71,0) . . W "MULTIPLE:",ZZVALS,! "RTN","C0CFM2",72,0) . . ;B "RTN","C0CFM2",73,0) . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE "RTN","C0CFM2",74,0) . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT "RTN","C0CFM2",75,0) . . . W "COUNT:",ZZCNT,! "RTN","C0CFM2",76,0) . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) "RTN","C0CFM2",77,0) . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) "RTN","C0CFM2",78,0) Q "RTN","C0CFM2",79,0) ; "RTN","C0CFM2",80,0) PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE "RTN","C0CFM2",81,0) ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE "RTN","C0CFM2",82,0) ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE "RTN","C0CFM2",83,0) ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC "RTN","C0CFM2",84,0) ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM "RTN","C0CFM2",85,0) ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT "RTN","C0CFM2",86,0) ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES "RTN","C0CFM2",87,0) ; "RTN","C0CFM2",88,0) N PATN,ZTYPN,XD0,ZTYP "RTN","C0CFM2",89,0) I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET "RTN","C0CFM2",90,0) ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE "RTN","C0CFM2",91,0) N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL "RTN","C0CFM2",92,0) N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL "RTN","C0CFM2",93,0) N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL "RTN","C0CFM2",94,0) N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL "RTN","C0CFM2",95,0) N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL "RTN","C0CFM2",96,0) ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ... "RTN","C0CFM2",97,0) ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK "RTN","C0CFM2",98,0) N C0CFDA "RTN","C0CFM2",99,0) S C0CFDA(C0CFPAT,"?+1,",.01)=DFN "RTN","C0CFM2",100,0) D UPDIE ; ADD THE PATIENT "RTN","C0CFM2",101,0) S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT "RTN","C0CFM2",102,0) S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC "RTN","C0CFM2",103,0) D UPDIE ; ADD THE CCR SOURCE "RTN","C0CFM2",104,0) N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE "RTN","C0CFM2",105,0) S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN "RTN","C0CFM2",106,0) D UPDIE ; ADD THE ELEMENT TYPE "RTN","C0CFM2",107,0) S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE "RTN","C0CFM2",108,0) S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC "RTN","C0CFM2",109,0) ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE "RTN","C0CFM2",110,0) ; STRING COLLATION ON THE INDEX "RTN","C0CFM2",111,0) D UPDIE ; ADD THE OCCURANCE "RTN","C0CFM2",112,0) S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,"")) "RTN","C0CFM2",113,0) W "RECORD NUMBER: ",ZD0,! "RTN","C0CFM2",114,0) ;I ZD0=32 B "RTN","C0CFM2",115,0) ;I ZD0=31 B "RTN","C0CFM2",116,0) N ZCNT,ZC0CI,ZVARN,C0CZ1 "RTN","C0CFM2",117,0) S ZCNT=0 "RTN","C0CFM2",118,0) S ZC0CI="" ; "RTN","C0CFM2",119,0) F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; "RTN","C0CFM2",120,0) . I ZC0CI'="M" D ; NOT A SUBVARIABLE "RTN","C0CFM2",121,0) . . S ZCNT=ZCNT+1 ;INCREMENT COUNT "RTN","C0CFM2",122,0) . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT "RTN","C0CFM2",123,0) . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND "RTN","C0CFM2",124,0) . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_"," "RTN","C0CFM2",125,0) . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN "RTN","C0CFM2",126,0) . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|") "RTN","C0CFM2",127,0) . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL "RTN","C0CFM2",128,0) . E D ; THIS IS A SUBELEMENT "RTN","C0CFM2",129,0) . . ;PUT THE FOLLOWING BACK TO USE RECURSION "RTN","C0CFM2",130,0) . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV "RTN","C0CFM2",131,0) . . ;S ZZCNT=0 "RTN","C0CFM2",132,0) . . ;S ZZC0CI=0 "RTN","C0CFM2",133,0) . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE "RTN","C0CFM2",134,0) . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE "RTN","C0CFM2",135,0) . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR "RTN","C0CFM2",136,0) . . ;W "MULTIPLE:",ZZVALS,! "RTN","C0CFM2",137,0) . . ;B "RTN","C0CFM2",138,0) . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE "RTN","C0CFM2",139,0) . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT "RTN","C0CFM2",140,0) . . ;. W "COUNT:",ZZCNT,! "RTN","C0CFM2",141,0) . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) "RTN","C0CFM2",142,0) . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION "RTN","C0CFM2",143,0) . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) "RTN","C0CFM2",144,0) D UPDIE ; UPDATE "RTN","C0CFM2",145,0) Q "RTN","C0CFM2",146,0) ; "RTN","C0CFM2",147,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CFM2",148,0) K ZERR "RTN","C0CFM2",149,0) D CLEAN^DILF "RTN","C0CFM2",150,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CFM2",151,0) I $D(ZERR) D ; "RTN","C0CFM2",152,0) . W "ERROR",! "RTN","C0CFM2",153,0) . ZWR ZERR "RTN","C0CFM2",154,0) . B "RTN","C0CFM2",155,0) K C0CFDA "RTN","C0CFM2",156,0) Q "RTN","C0CFM2",157,0) ; "RTN","C0CFM2",158,0) CHECK ; CHECKSUM EXPERIMENTS "RTN","C0CFM2",159,0) ; "RTN","C0CFM2",160,0) ;B "RTN","C0CFM2",161,0) S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA)) "RTN","C0CFM2",162,0) ;S G2=$NA(^C0CE(8,1,1,1,2,1,6)) "RTN","C0CFM2",163,0) S X=$$CHKSUM^XUSESIG1(ZG) "RTN","C0CFM2",164,0) W G1,! "RTN","C0CFM2",165,0) Q "RTN","C0CFM2",166,0) ; "RTN","C0CFM2",167,0) CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR A PATIENT "RTN","C0CFM2",168,0) ; "RTN","C0CFM2",169,0) S ZGLB=$NA(^TMP("C0CCHK")) "RTN","C0CFM2",170,0) S ZPAT=$O(^C0CE("B",DFN,"")) "RTN","C0CFM2",171,0) K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS "RTN","C0CFM2",172,0) S ZSRC="" "RTN","C0CFM2",173,0) F S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC="" D ; "RTN","C0CFM2",174,0) . W "PAT:",ZPAT," SRC:",ZSRC,! "RTN","C0CFM2",175,0) . S ZEL="" "RTN","C0CFM2",176,0) . F S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL="" D ;ELEMENTS "RTN","C0CFM2",177,0) . . W "ELEMENT:",ZEL," " "RTN","C0CFM2",178,0) . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME "RTN","C0CFM2",179,0) . . W ZELE," " "RTN","C0CFM2",180,0) . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,"")) "RTN","C0CFM2",181,0) . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI)) "RTN","C0CFM2",182,0) . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT "RTN","C0CFM2",183,0) . . W ZCHK,! "RTN","C0CFM2",184,0) . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK "RTN","C0CFM2",185,0) ZWR ^TMP("C0CCHK",ZPAT,*) "RTN","C0CFM2",186,0) Q "RTN","C0CFM2",187,0) ; "RTN","C0CFM2",188,0) DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN) "RTN","C0CFM2",189,0) D SETXUP "RTN","C0CFM2",190,0) D CHKELS(DFN) "RTN","C0CFM2",191,0) Q "RTN","C0CFM2",192,0) ; "RTN","C0CFM2",193,0) SETXUP ; SET UP ENVIRONMENT "RTN","C0CFM2",194,0) S DISYS=19 "RTN","C0CFM2",195,0) S DT=3090325 "RTN","C0CFM2",196,0) S DTIME=300 "RTN","C0CFM2",197,0) S DUZ=1 "RTN","C0CFM2",198,0) S DUZ(0)="@" "RTN","C0CFM2",199,0) S DUZ(1)="" "RTN","C0CFM2",200,0) S DUZ(2)=7247 "RTN","C0CFM2",201,0) S DUZ("AG")="I" "RTN","C0CFM2",202,0) S DUZ("BUF")=1 "RTN","C0CFM2",203,0) S DUZ("LANG")="" "RTN","C0CFM2",204,0) S IO="/dev/pts/20" "RTN","C0CFM2",205,0) S IO(0)="/dev/pts/20" "RTN","C0CFM2",206,0) S IO(1,"/dev/pts/20")="" "RTN","C0CFM2",207,0) S IO("ERROR")="" "RTN","C0CFM2",208,0) S IO("HOME")="344^/dev/pts/20" "RTN","C0CFM2",209,0) S IO("ZIO")="/dev/pts/20" "RTN","C0CFM2",210,0) S IOBS="$C(8)" "RTN","C0CFM2",211,0) S IOF="#,$C(27,91,50,74,27,91,72)" "RTN","C0CFM2",212,0) S IOM=80 "RTN","C0CFM2",213,0) S ION="TELNET" "RTN","C0CFM2",214,0) S IOS=344 "RTN","C0CFM2",215,0) S IOSL=24 "RTN","C0CFM2",216,0) S IOST="C-VT100" "RTN","C0CFM2",217,0) S IOST(0)=9 "RTN","C0CFM2",218,0) S IOT="VTRM" "RTN","C0CFM2",219,0) S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" "RTN","C0CFM2",220,0) S U="^" "RTN","C0CFM2",221,0) S X="216;DIC(4.2," "RTN","C0CFM2",222,0) S XPARSYS="216;DIC(4.2," "RTN","C0CFM2",223,0) S XQXFLG="^^XUP" "RTN","C0CFM2",224,0) Q "RTN","C0CFM2",225,0) ; "RTN","C0CFM2",226,0) PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE "RTN","C0CFM2",227,0) ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE "RTN","C0CFM2",228,0) ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE "RTN","C0CFM2",229,0) ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC "RTN","C0CFM2",230,0) ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM "RTN","C0CFM2",231,0) ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT "RTN","C0CFM2",232,0) ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES "RTN","C0CFM2",233,0) ; "RTN","C0CFM2",234,0) S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 "RTN","C0CFM2",235,0) ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE "RTN","C0CFM2",236,0) N ZF,ZFV S ZF=171.101 S ZFV=171.1011 "RTN","C0CFM2",237,0) ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS "RTN","C0CFM2",238,0) ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER "RTN","C0CFM2",239,0) N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) "RTN","C0CFM2",240,0) W "ZTYPE: ",ZTYPE," ",ZTYPN,! "RTN","C0CFM2",241,0) N ZVARN ; IEN OF VARIABLE BEING PROCESSED "RTN","C0CFM2",242,0) ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE "RTN","C0CFM2",243,0) K C0CFDA "RTN","C0CFM2",244,0) S C0CFDA(ZF,"?+1,",.01)=DFN "RTN","C0CFM2",245,0) S C0CFDA(ZF,"?+1,",.02)=ZSRC "RTN","C0CFM2",246,0) S C0CFDA(ZF,"?+1,",.03)=ZTYPN "RTN","C0CFM2",247,0) S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE "RTN","C0CFM2",248,0) K ZERR "RTN","C0CFM2",249,0) ;B "RTN","C0CFM2",250,0) D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER "RTN","C0CFM2",251,0) I $D(ZERR) B ;OOPS "RTN","C0CFM2",252,0) K C0CFDA "RTN","C0CFM2",253,0) S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) "RTN","C0CFM2",254,0) W "RECORD NUMBER: ",ZD0,! "RTN","C0CFM2",255,0) ;B "RTN","C0CFM2",256,0) S ZCNT=0 "RTN","C0CFM2",257,0) S ZC0CI="" ; "RTN","C0CFM2",258,0) F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; "RTN","C0CFM2",259,0) . I ZC0CI'="M" D ; NOT A SUBVARIABLE "RTN","C0CFM2",260,0) . . S ZCNT=ZCNT+1 ;INCREMENT COUNT "RTN","C0CFM2",261,0) . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT "RTN","C0CFM2",262,0) . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND "RTN","C0CFM2",263,0) . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN "RTN","C0CFM2",264,0) . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM2",265,0) . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN "RTN","C0CFM2",266,0) . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM2",267,0) ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" "RTN","C0CFM2",268,0) ;S GT1(170,"?+1,",12)="DIR" "RTN","C0CFM2",269,0) ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" "RTN","C0CFM2",270,0) ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" "RTN","C0CFM2",271,0) D CLEAN^DILF "RTN","C0CFM2",272,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CFM2",273,0) I $D(ZERR) D ; "RTN","C0CFM2",274,0) . W "ERROR",! "RTN","C0CFM2",275,0) . ZWR ZERR "RTN","C0CFM2",276,0) . B "RTN","C0CFM2",277,0) K C0CFDA "RTN","C0CFM2",278,0) Q "RTN","C0CFM2",279,0) ; "RTN","C0CFM2",280,0) VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE "RTN","C0CFM2",281,0) ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO "RTN","C0CFM2",282,0) ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO "RTN","C0CFM2",283,0) ; "RTN","C0CFM2",284,0) N ZCCRD,ZVARN,C0CFDA2 "RTN","C0CFM2",285,0) S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY "RTN","C0CFM2",286,0) S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CFM2",287,0) I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT "RTN","C0CFM2",288,0) . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE "RTN","C0CFM2",289,0) . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! "RTN","C0CFM2",290,0) . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE "RTN","C0CFM2",291,0) . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE "RTN","C0CFM2",292,0) . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN "RTN","C0CFM2",293,0) . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY "RTN","C0CFM2",294,0) . I $D(ZERR) D ; LAYGO ERROR "RTN","C0CFM2",295,0) . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! "RTN","C0CFM2",296,0) . E D ; "RTN","C0CFM2",297,0) . . D CLEAN^DILF ; CLEAN UP "RTN","C0CFM2",298,0) . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CFM2",299,0) . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! "RTN","C0CFM2",300,0) Q ZVARN "RTN","C0CFM2",301,0) ; "RTN","C0CFM2",302,0) BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) "RTN","C0CFM2",303,0) ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED "RTN","C0CFM2",304,0) ; "RTN","C0CFM2",305,0) N C0CDIC,C0CNODE ; "RTN","C0CFM2",306,0) S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY "RTN","C0CFM2",307,0) S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE "RTN","C0CFM2",308,0) Q "RTN","C0CFM2",309,0) ; "RTN","C0CFM2",310,0) FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED "RTN","C0CFM2",311,0) ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET "RTN","C0CFM2",312,0) ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS "RTN","C0CFM2",313,0) ; CONVERSION "RTN","C0CFM2",314,0) ;N C0CC,C0CI,C0CJ,C0CN,C0CZX "RTN","C0CFM2",315,0) D FIELDS^C0CRNF("C0CC",170) "RTN","C0CFM2",316,0) S C0CI="" "RTN","C0CFM2",317,0) F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION "RTN","C0CFM2",318,0) . S C0CZX="" "RTN","C0CFM2",319,0) . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE "RTN","C0CFM2",320,0) . . W "SECTION ",C0CI," VAR ",C0CZX "RTN","C0CFM2",321,0) . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) "RTN","C0CFM2",322,0) . . W " TYPE: ",C0CV,! "RTN","C0CFM2",323,0) . . D SETFDA("SECTION",C0CV) "RTN","C0CFM2",324,0) . . ;ZWR C0CFDA "RTN","C0CFM2",325,0) Q "RTN","C0CFM2",326,0) ; "RTN","C0CFM2",327,0) SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN "RTN","C0CFM2",328,0) ; TO SET TO VALUE C0CSV. "RTN","C0CFM2",329,0) ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE "RTN","C0CFM2",330,0) ; C0CSN,C0CSV ARE PASSED BY VALUE "RTN","C0CFM2",331,0) ; "RTN","C0CFM2",332,0) N C0CSI,C0CSJ "RTN","C0CFM2",333,0) S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER "RTN","C0CFM2",334,0) S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER "RTN","C0CFM2",335,0) S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV "RTN","C0CFM2",336,0) Q "RTN","C0CFM2",337,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CFM2",338,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) "RTN","C0CFM2",339,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM2",340,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM2",341,0) N ZR "RTN","C0CFM2",342,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) "RTN","C0CFM2",343,0) E S ZR="" "RTN","C0CFM2",344,0) Q ZR "RTN","C0CFM2",345,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CFM2",346,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) "RTN","C0CFM2",347,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM2",348,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM2",349,0) N ZR "RTN","C0CFM2",350,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) "RTN","C0CFM2",351,0) E S ZR="" "RTN","C0CFM2",352,0) Q ZR "RTN","C0CFM2",353,0) ; "RTN","C0CFM2",354,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CFM2",355,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) "RTN","C0CFM2",356,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM2",357,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM2",358,0) N ZR "RTN","C0CFM2",359,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) "RTN","C0CFM2",360,0) E S ZR="" "RTN","C0CFM2",361,0) Q ZR "RTN","C0CFM2",362,0) ; "RTN","C0CFM3") 0^20^B68203631 "RTN","C0CFM3",1,0) C0CFM3 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 "RTN","C0CFM3",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 "RTN","C0CFM3",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CFM3",4,0) ;General Public License See attached copy of the License. "RTN","C0CFM3",5,0) ; "RTN","C0CFM3",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CFM3",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CFM3",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CFM3",9,0) ;(at your option) any later version. "RTN","C0CFM3",10,0) ; "RTN","C0CFM3",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CFM3",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CFM3",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CFM3",14,0) ;GNU General Public License for more details. "RTN","C0CFM3",15,0) ; "RTN","C0CFM3",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CFM3",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CFM3",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CFM3",19,0) ; "RTN","C0CFM3",20,0) W "This is the CCR FILEMAN Utility Library ",! "RTN","C0CFM3",21,0) ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF "RTN","C0CFM3",22,0) ; CCR ELEMENTS (^C0C(179.201, "RTN","C0CFM3",23,0) ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE "RTN","C0CFM3",24,0) ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT "RTN","C0CFM3",25,0) ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS "RTN","C0CFM3",26,0) ; ALL SUB-VARIABLES HAVE BEEN REMOVED "RTN","C0CFM3",27,0) W ! "RTN","C0CFM3",28,0) Q "RTN","C0CFM3",29,0) ; "RTN","C0CFM3",30,0) RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE "RTN","C0CFM3",31,0) ; ' "RTN","C0CFM3",32,0) I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS "RTN","C0CFM3",33,0) N ZI,ZJ,ZC,ZPATBASE "RTN","C0CFM3",34,0) S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) "RTN","C0CFM3",35,0) S ZI="" "RTN","C0CFM3",36,0) F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END "RTN","C0CFM3",37,0) . S ZI=$O(@ZPATBASE@(ZI)) "RTN","C0CFM3",38,0) . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE "RTN","C0CFM3",39,0) Q "RTN","C0CFM3",40,0) ; "RTN","C0CFM3",41,0) PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE "RTN","C0CFM3",42,0) ; "RTN","C0CFM3",43,0) S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) "RTN","C0CFM3",44,0) I '$D(ZWHICH) S ZWHICH="ALL" "RTN","C0CFM3",45,0) I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED "RTN","C0CFM3",46,0) . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) "RTN","C0CFM3",47,0) . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION "RTN","C0CFM3",48,0) E D ; MULTIPLE SECTIONS "RTN","C0CFM3",49,0) . S C0CVARS=$NA(@C0CGLB) "RTN","C0CFM3",50,0) . S C0CI="" "RTN","C0CFM3",51,0) . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION "RTN","C0CFM3",52,0) . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION "RTN","C0CFM3",53,0) . . D PUTRIM1(DFN,C0CI,C0CVARSN) "RTN","C0CFM3",54,0) Q "RTN","C0CFM3",55,0) ; "RTN","C0CFM3",56,0) PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS "RTN","C0CFM3",57,0) ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" "RTN","C0CFM3",58,0) S C0CX=0 "RTN","C0CFM3",59,0) F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE "RTN","C0CFM3",60,0) . W "ZOCC=",C0CX,! "RTN","C0CFM3",61,0) . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME "RTN","C0CFM3",62,0) . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE "RTN","C0CFM3",63,0) . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE "RTN","C0CFM3",64,0) . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() "RTN","C0CFM3",65,0) . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV "RTN","C0CFM3",66,0) . . S ZZCNT=0 "RTN","C0CFM3",67,0) . . S ZZC0CI=0 "RTN","C0CFM3",68,0) . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE "RTN","C0CFM3",69,0) . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE "RTN","C0CFM3",70,0) . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR "RTN","C0CFM3",71,0) . . W "MULTIPLE:",ZZVALS,! "RTN","C0CFM3",72,0) . . ;B "RTN","C0CFM3",73,0) . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE "RTN","C0CFM3",74,0) . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT "RTN","C0CFM3",75,0) . . . W "COUNT:",ZZCNT,! "RTN","C0CFM3",76,0) . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) "RTN","C0CFM3",77,0) . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) "RTN","C0CFM3",78,0) Q "RTN","C0CFM3",79,0) ; "RTN","C0CFM3",80,0) PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE "RTN","C0CFM3",81,0) ; 171.601, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE "RTN","C0CFM3",82,0) ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE "RTN","C0CFM3",83,0) ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC "RTN","C0CFM3",84,0) ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM "RTN","C0CFM3",85,0) ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT "RTN","C0CFM3",86,0) ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES "RTN","C0CFM3",87,0) ; "RTN","C0CFM3",88,0) N ZSRC,PATN,ZTYPN,XD0,ZTYP "RTN","C0CFM3",89,0) S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 "RTN","C0CFM3",90,0) ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE "RTN","C0CFM3",91,0) N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL "RTN","C0CFM3",92,0) N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL "RTN","C0CFM3",93,0) N C0CFDA "RTN","C0CFM3",94,0) N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) "RTN","C0CFM3",95,0) W "ZTYPE: ",ZTYPE," ",ZTYPN,! "RTN","C0CFM3",96,0) N ZVARN ; IEN OF VARIABLE BEING PROCESSED "RTN","C0CFM3",97,0) ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE "RTN","C0CFM3",98,0) S C0CFDA(C0CF,"+1,",.01)=ZTYPN "RTN","C0CFM3",99,0) S C0CFDA(C0CF,"+1,",.02)=DFN "RTN","C0CFM3",100,0) S C0CFDA(C0CF,"+1,",.03)=ZSRC "RTN","C0CFM3",101,0) S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space "RTN","C0CFM3",102,0) D UPDIE ; CREATE THE RECORD "RTN","C0CFM3",103,0) S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,"")) "RTN","C0CFM3",104,0) N ZCNT,ZC0CI,ZVARN,C0CZ1 "RTN","C0CFM3",105,0) S ZCNT=0 "RTN","C0CFM3",106,0) S ZC0CI="" ; "RTN","C0CFM3",107,0) F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; "RTN","C0CFM3",108,0) . I ZC0CI'="M" D ; NOT A SUBVARIABLE "RTN","C0CFM3",109,0) . . S ZCNT=ZCNT+1 ;INCREMENT COUNT "RTN","C0CFM3",110,0) . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT "RTN","C0CFM3",111,0) . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND "RTN","C0CFM3",112,0) . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN "RTN","C0CFM3",113,0) . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM3",114,0) . E D ; THIS IS A SUBELEMENT "RTN","C0CFM3",115,0) . . ;PUT THE FOLLOWING BACK TO USE RECURSION "RTN","C0CFM3",116,0) . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV "RTN","C0CFM3",117,0) . . ;S ZZCNT=0 "RTN","C0CFM3",118,0) . . ;S ZZC0CI=0 "RTN","C0CFM3",119,0) . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE "RTN","C0CFM3",120,0) . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE "RTN","C0CFM3",121,0) . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR "RTN","C0CFM3",122,0) . . ;W "MULTIPLE:",ZZVALS,! "RTN","C0CFM3",123,0) . . ;B "RTN","C0CFM3",124,0) . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE "RTN","C0CFM3",125,0) . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT "RTN","C0CFM3",126,0) . . ;. W "COUNT:",ZZCNT,! "RTN","C0CFM3",127,0) . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) "RTN","C0CFM3",128,0) . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION "RTN","C0CFM3",129,0) . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) "RTN","C0CFM3",130,0) D UPDIE ; UPDATE "RTN","C0CFM3",131,0) Q "RTN","C0CFM3",132,0) ; "RTN","C0CFM3",133,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CFM3",134,0) K ZERR "RTN","C0CFM3",135,0) D CLEAN^DILF "RTN","C0CFM3",136,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CFM3",137,0) I $D(ZERR) D ; "RTN","C0CFM3",138,0) . W "ERROR",! "RTN","C0CFM3",139,0) . ZWR ZERR "RTN","C0CFM3",140,0) . B "RTN","C0CFM3",141,0) K C0CFDA "RTN","C0CFM3",142,0) Q "RTN","C0CFM3",143,0) ; "RTN","C0CFM3",144,0) PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE "RTN","C0CFM3",145,0) ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE "RTN","C0CFM3",146,0) ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE "RTN","C0CFM3",147,0) ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC "RTN","C0CFM3",148,0) ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM "RTN","C0CFM3",149,0) ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT "RTN","C0CFM3",150,0) ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES "RTN","C0CFM3",151,0) ; "RTN","C0CFM3",152,0) S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 "RTN","C0CFM3",153,0) ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE "RTN","C0CFM3",154,0) N ZF,ZFV S ZF=171.101 S ZFV=171.1011 "RTN","C0CFM3",155,0) ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS "RTN","C0CFM3",156,0) ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER "RTN","C0CFM3",157,0) N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) "RTN","C0CFM3",158,0) W "ZTYPE: ",ZTYPE," ",ZTYPN,! "RTN","C0CFM3",159,0) N ZVARN ; IEN OF VARIABLE BEING PROCESSED "RTN","C0CFM3",160,0) ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE "RTN","C0CFM3",161,0) K C0CFDA "RTN","C0CFM3",162,0) S C0CFDA(ZF,"?+1,",.01)=DFN "RTN","C0CFM3",163,0) S C0CFDA(ZF,"?+1,",.02)=ZSRC "RTN","C0CFM3",164,0) S C0CFDA(ZF,"?+1,",.03)=ZTYPN "RTN","C0CFM3",165,0) S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE "RTN","C0CFM3",166,0) K ZERR "RTN","C0CFM3",167,0) ;B "RTN","C0CFM3",168,0) D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER "RTN","C0CFM3",169,0) I $D(ZERR) B ;OOPS "RTN","C0CFM3",170,0) K C0CFDA "RTN","C0CFM3",171,0) S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) "RTN","C0CFM3",172,0) W "RECORD NUMBER: ",ZD0,! "RTN","C0CFM3",173,0) ;B "RTN","C0CFM3",174,0) S ZCNT=0 "RTN","C0CFM3",175,0) S ZC0CI="" ; "RTN","C0CFM3",176,0) F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; "RTN","C0CFM3",177,0) . I ZC0CI'="M" D ; NOT A SUBVARIABLE "RTN","C0CFM3",178,0) . . S ZCNT=ZCNT+1 ;INCREMENT COUNT "RTN","C0CFM3",179,0) . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT "RTN","C0CFM3",180,0) . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND "RTN","C0CFM3",181,0) . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN "RTN","C0CFM3",182,0) . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM3",183,0) . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN "RTN","C0CFM3",184,0) . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) "RTN","C0CFM3",185,0) ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" "RTN","C0CFM3",186,0) ;S GT1(170,"?+1,",12)="DIR" "RTN","C0CFM3",187,0) ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" "RTN","C0CFM3",188,0) ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" "RTN","C0CFM3",189,0) D CLEAN^DILF "RTN","C0CFM3",190,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CFM3",191,0) I $D(ZERR) D ; "RTN","C0CFM3",192,0) . W "ERROR",! "RTN","C0CFM3",193,0) . ZWR ZERR "RTN","C0CFM3",194,0) . B "RTN","C0CFM3",195,0) K C0CFDA "RTN","C0CFM3",196,0) Q "RTN","C0CFM3",197,0) ; "RTN","C0CFM3",198,0) VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE "RTN","C0CFM3",199,0) ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO "RTN","C0CFM3",200,0) ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO "RTN","C0CFM3",201,0) ; "RTN","C0CFM3",202,0) N ZCCRD,ZVARN,C0CFDA2 "RTN","C0CFM3",203,0) S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY "RTN","C0CFM3",204,0) S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CFM3",205,0) I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT "RTN","C0CFM3",206,0) . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE "RTN","C0CFM3",207,0) . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! "RTN","C0CFM3",208,0) . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE "RTN","C0CFM3",209,0) . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE "RTN","C0CFM3",210,0) . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN "RTN","C0CFM3",211,0) . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY "RTN","C0CFM3",212,0) . I $D(ZERR) D ; LAYGO ERROR "RTN","C0CFM3",213,0) . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! "RTN","C0CFM3",214,0) . E D ; "RTN","C0CFM3",215,0) . . D CLEAN^DILF ; CLEAN UP "RTN","C0CFM3",216,0) . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CFM3",217,0) . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! "RTN","C0CFM3",218,0) Q ZVARN "RTN","C0CFM3",219,0) ; "RTN","C0CFM3",220,0) BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) "RTN","C0CFM3",221,0) ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED "RTN","C0CFM3",222,0) ; "RTN","C0CFM3",223,0) N C0CDIC,C0CNODE ; "RTN","C0CFM3",224,0) S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY "RTN","C0CFM3",225,0) S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE "RTN","C0CFM3",226,0) Q "RTN","C0CFM3",227,0) ; "RTN","C0CFM3",228,0) FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED "RTN","C0CFM3",229,0) ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET "RTN","C0CFM3",230,0) ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS "RTN","C0CFM3",231,0) ; CONVERSION "RTN","C0CFM3",232,0) ;N C0CC,C0CI,C0CJ,C0CN,C0CZX "RTN","C0CFM3",233,0) D FIELDS^C0CRNF("C0CC",170) "RTN","C0CFM3",234,0) S C0CI="" "RTN","C0CFM3",235,0) F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION "RTN","C0CFM3",236,0) . S C0CZX="" "RTN","C0CFM3",237,0) . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE "RTN","C0CFM3",238,0) . . W "SECTION ",C0CI," VAR ",C0CZX "RTN","C0CFM3",239,0) . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) "RTN","C0CFM3",240,0) . . W " TYPE: ",C0CV,! "RTN","C0CFM3",241,0) . . D SETFDA("SECTION",C0CV) "RTN","C0CFM3",242,0) . . ;ZWR C0CFDA "RTN","C0CFM3",243,0) Q "RTN","C0CFM3",244,0) ; "RTN","C0CFM3",245,0) SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN "RTN","C0CFM3",246,0) ; TO SET TO VALUE C0CSV. "RTN","C0CFM3",247,0) ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE "RTN","C0CFM3",248,0) ; C0CSN,C0CSV ARE PASSED BY VALUE "RTN","C0CFM3",249,0) ; "RTN","C0CFM3",250,0) N C0CSI,C0CSJ "RTN","C0CFM3",251,0) S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER "RTN","C0CFM3",252,0) S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER "RTN","C0CFM3",253,0) S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV "RTN","C0CFM3",254,0) Q "RTN","C0CFM3",255,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CFM3",256,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) "RTN","C0CFM3",257,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM3",258,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM3",259,0) N ZR "RTN","C0CFM3",260,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) "RTN","C0CFM3",261,0) E S ZR="" "RTN","C0CFM3",262,0) Q ZR "RTN","C0CFM3",263,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CFM3",264,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) "RTN","C0CFM3",265,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM3",266,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM3",267,0) N ZR "RTN","C0CFM3",268,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) "RTN","C0CFM3",269,0) E S ZR="" "RTN","C0CFM3",270,0) Q ZR "RTN","C0CFM3",271,0) ; "RTN","C0CFM3",272,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CFM3",273,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) "RTN","C0CFM3",274,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CFM3",275,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CFM3",276,0) N ZR "RTN","C0CFM3",277,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) "RTN","C0CFM3",278,0) E S ZR="" "RTN","C0CFM3",279,0) Q ZR "RTN","C0CFM3",280,0) ; "RTN","C0CFM3",281,0) SHOWE4(DFN) ; "RTN","C0CFM3",282,0) ; "RTN","C0CFM3",283,0) N ZG "RTN","C0CFM3",284,0) S ZG="" "RTN","C0CFM3",285,0) F S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG="" D ZWR ^C0CE4(ZG,*) "RTN","C0CFM3",286,0) Q "RTN","C0CFM3",287,0) ; "RTN","C0CIM2") 0^21^B20157375 "RTN","C0CIM2",1,0) C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 "RTN","C0CIM2",2,0) ;;1.0;C0C;;Feb 16, 2010;Build 1 "RTN","C0CIM2",3,0) ;Copyright 2010 George Lilly, University of Minnesota and others. "RTN","C0CIM2",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CIM2",5,0) ;See attached copy of the License. "RTN","C0CIM2",6,0) ; "RTN","C0CIM2",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CIM2",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CIM2",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CIM2",10,0) ;(at your option) any later version. "RTN","C0CIM2",11,0) ; "RTN","C0CIM2",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CIM2",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CIM2",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CIM2",15,0) ;GNU General Public License for more details. "RTN","C0CIM2",16,0) ; "RTN","C0CIM2",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CIM2",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CIM2",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CIM2",20,0) ; "RTN","C0CIM2",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CIM2",22,0) Q "RTN","C0CIM2",23,0) ; "RTN","C0CIM2",24,0) EXTRACT(IMMXML,DFN,IMMOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE "RTN","C0CIM2",25,0) ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CIM2",26,0) ; "RTN","C0CIM2",27,0) ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS "RTN","C0CIM2",28,0) ; THAT GET PASSED TO *GET ROUTINES "RTN","C0CIM2",29,0) ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) "RTN","C0CIM2",30,0) N C0CIMM "RTN","C0CIM2",31,0) S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM")) "RTN","C0CIM2",32,0) ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS "RTN","C0CIM2",33,0) ; THAT GET INSERTED INTO THE XML TEMPLATE "RTN","C0CIM2",34,0) ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE "RTN","C0CIM2",35,0) D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE "RTN","C0CIM2",36,0) ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE "RTN","C0CIM2",37,0) ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES "RTN","C0CIM2",38,0) D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES "RTN","C0CIM2",39,0) Q "RTN","C0CIM2",40,0) ; "RTN","C0CIM2",41,0) GETRPMS(DFN,C0CIMM) ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS. "RTN","C0CIM2",42,0) ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME "RTN","C0CIM2",43,0) ; C0CIMM: IMMUNIZATIONS "RTN","C0CIM2",44,0) ; READY TO BE MAPPED TO XML BY MAP^C0CIMM "RTN","C0CIM2",45,0) ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY "RTN","C0CIM2",46,0) ; EXIST. "RTN","C0CIM2",47,0) ; "RTN","C0CIM2",48,0) ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) "RTN","C0CIM2",49,0) ; "RTN","C0CIM2",50,0) ; SETUP RPC/API CALL HERE "RTN","C0CIM2",51,0) ; USE START AND END DATES FROM PARAMETERS IF REQUIRED "RTN","C0CIM2",52,0) N IMMA "RTN","C0CIM2",53,0) D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE "RTN","C0CIM2",54,0) ; PREFORM SORT HERE IF NEEDED "RTN","C0CIM2",55,0) ; "RTN","C0CIM2",56,0) ; NO SORT REQUIRED FOR IMMUNIZATIONS "RTN","C0CIM2",57,0) ; "RTN","C0CIM2",58,0) ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY "RTN","C0CIM2",59,0) ; RNF1 ARRAY FORMAT: "RTN","C0CIM2",60,0) ; VAR("NAME_OF_RIM_VARIABLE")=VALUE "RTN","C0CIM2",61,0) ; "RTN","C0CIM2",62,0) ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS "RTN","C0CIM2",63,0) ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD "RTN","C0CIM2",64,0) ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS "RTN","C0CIM2",65,0) N C0CIM,C0CC,ZRNF "RTN","C0CIM2",66,0) S C0CIM="" ; INITIALIZE FOR $O "RTN","C0CIM2",67,0) F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST "RTN","C0CIM2",68,0) . I DEBUG W @IMMA@(C0CIM),! "RTN","C0CIM2",69,0) . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS) "RTN","C0CIM2",70,0) . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN "RTN","C0CIM2",71,0) . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST "RTN","C0CIM2",72,0) . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA "RTN","C0CIM2",73,0) . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE "RTN","C0CIM2",74,0) . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY "RTN","C0CIM2",75,0) . K ZRNF "RTN","C0CIM2",76,0) ; SAVE RIM VARIABLES SEE C0CRIMA "RTN","C0CIM2",77,0) N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) "RTN","C0CIM2",78,0) M @ZRIM=@C0CIMM@("V") "RTN","C0CIM2",79,0) Q "RTN","C0CIM2",80,0) ; "RTN","C0CIM2",81,0) IMMUN ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS "RTN","C0CIM2",82,0) ; RPC FORMAT "RTN","C0CIM2",83,0) ; I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^ "RTN","C0CIM2",84,0) ; Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^ "RTN","C0CIM2",85,0) ; Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20] "RTN","C0CIM2",86,0) ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION "RTN","C0CIM2",87,0) D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD "RTN","C0CIM2",88,0) ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION "RTN","C0CIM2",89,0) D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD "RTN","C0CIM2",90,0) S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID "RTN","C0CIM2",91,0) S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME "RTN","C0CIM2",92,0) S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT") "RTN","C0CIM2",93,0) S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1) "RTN","C0CIM2",94,0) S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD "RTN","C0CIM2",95,0) S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE "RTN","C0CIM2",96,0) I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" "RTN","C0CIM2",97,0) E S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL "RTN","C0CIM2",98,0) ;CLEANUP FROM C0CRNF CALLS "RTN","C0CIM2",99,0) K C0CZIM,C0CZVI "RTN","C0CIM2",100,0) Q "RTN","C0CIM2",101,0) FORECAST ; PARSES FORECAST TYPE ROWS FOR RPMS "RTN","C0CIM2",102,0) ; CURRENTLY DISABLED "RTN","C0CIM2",103,0) Q "RTN","C0CIM2",104,0) CONTRA ; PARSES FORECAST TYPE ROWS FOR RPMS "RTN","C0CIM2",105,0) ; CURRENTLY DISABLED "RTN","C0CIM2",106,0) Q "RTN","C0CIM2",107,0) REFUSE ; PARSES FORECAST TYPE ROWS FOR RPMS "RTN","C0CIM2",108,0) ; CURRENTLY DISABLED "RTN","C0CIM2",109,0) Q "RTN","C0CIM2",110,0) ; "RTN","C0CIM2",111,0) MAP(IMMXML,C0CIMM,IMMOUT) ; MAP IMMUNIZATION XML "RTN","C0CIM2",112,0) ; "RTN","C0CIM2",113,0) N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE "RTN","C0CIM2",114,0) K @ZTEMP "RTN","C0CIM2",115,0) N ZBLD "RTN","C0CIM2",116,0) S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA "RTN","C0CIM2",117,0) D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE "RTN","C0CIM2",118,0) N ZINNER "RTN","C0CIM2",119,0) ; XPATH NEEDS TO MATCH YOUR SECTION "RTN","C0CIM2",120,0) D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC "RTN","C0CIM2",121,0) N ZTMP,ZVAR,ZI "RTN","C0CIM2",122,0) S ZI="" "RTN","C0CIM2",123,0) F S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI="" D ;FOR EACH IMMUNIZATION "RTN","C0CIM2",124,0) . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML "RTN","C0CIM2",125,0) . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES "RTN","C0CIM2",126,0) . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION "RTN","C0CIM2",127,0) . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD "RTN","C0CIM2",128,0) D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0)) "RTN","C0CIM2",129,0) N ZZTMP ; IS THIS NEEDED? "RTN","C0CIM2",130,0) D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML "RTN","C0CIM2",131,0) K @ZTEMP,@ZBLD "RTN","C0CIM2",132,0) Q "RTN","C0CIM2",133,0) ; "RTN","C0CIMMU") 0^22^B20441765 "RTN","C0CIMMU",1,0) C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 "RTN","C0CIMMU",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CIMMU",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CIMMU",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CIMMU",5,0) ;See attached copy of the License. "RTN","C0CIMMU",6,0) ; "RTN","C0CIMMU",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CIMMU",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CIMMU",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CIMMU",10,0) ;(at your option) any later version. "RTN","C0CIMMU",11,0) ; "RTN","C0CIMMU",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CIMMU",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CIMMU",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CIMMU",15,0) ;GNU General Public License for more details. "RTN","C0CIMMU",16,0) ; "RTN","C0CIMMU",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CIMMU",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CIMMU",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CIMMU",20,0) ; "RTN","C0CIMMU",21,0) ; "RTN","C0CIMMU",22,0) ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR "RTN","C0CIMMU",23,0) ; "RTN","C0CIMMU",24,0) MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS "RTN","C0CIMMU",25,0) ; "RTN","C0CIMMU",26,0) N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES "RTN","C0CIMMU",27,0) N C0CZT ; TMP ARRAY OF MAPPED XML "RTN","C0CIMMU",28,0) S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES "RTN","C0CIMMU",29,0) D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES "RTN","C0CIMMU",30,0) N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS "RTN","C0CIMMU",31,0) S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY "RTN","C0CIMMU",32,0) I C0CZIC>0 D ;IMMUNIZATIONS FOUND "RTN","C0CIMMU",33,0) . F C0CZI=1:1:C0CZIC D ;FOR EACH IMMUNIZATION "RTN","C0CIMMU",34,0) . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION "RTN","C0CIMMU",35,0) . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML "RTN","C0CIMMU",36,0) . . I C0CZI=1 D ; FIRST ONE "RTN","C0CIMMU",37,0) . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS "RTN","C0CIMMU",38,0) . . E D ;NOT THE FIRST "RTN","C0CIMMU",39,0) . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT") "RTN","C0CIMMU",40,0) E S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS "RTN","C0CIMMU",41,0) N IMMUTMP,I "RTN","C0CIMMU",42,0) D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CIMMU",43,0) I IMMUTMP(0)>0 D ; IF THERE ARE MISSING VARS - "RTN","C0CIMMU",44,0) . ; STRINGS MARKED AS @@X@@ "RTN","C0CIMMU",45,0) . W !,"IMMUNE Missing list: ",! "RTN","C0CIMMU",46,0) . F I=1:1:IMMUTMP(0) W IMMUTMP(I),! "RTN","C0CIMMU",47,0) Q "RTN","C0CIMMU",48,0) ; "RTN","C0CIMMU",49,0) EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES "RTN","C0CIMMU",50,0) ; "RTN","C0CIMMU",51,0) ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CIMMU",52,0) ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE "RTN","C0CIMMU",53,0) ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE "RTN","C0CIMMU",54,0) ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS "RTN","C0CIMMU",55,0) ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT "RTN","C0CIMMU",56,0) ; "RTN","C0CIMMU",57,0) N RPCRSLT,J,K,PTMP,X,VMAP,TBU "RTN","C0CIMMU",58,0) S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE")) "RTN","C0CIMMU",59,0) S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP")) "RTN","C0CIMMU",60,0) S IMMA=$NA(^TMP("PXI",$J)) ; "RTN","C0CIMMU",61,0) K @IMMA ; CLEAR OUT PREVIOUS RESULTS "RTN","C0CIMMU",62,0) K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES "RTN","C0CIMMU",63,0) D IMMUN^PXRHS03(DFN) ; "RTN","C0CIMMU",64,0) I $O(@IMMA@(""))="" D Q ; RPC RETURNS NULL "RTN","C0CIMMU",65,0) . W "NULL RESULT FROM IMMUN^PXRHS03 ",! "RTN","C0CIMMU",66,0) . S @TVMAP@(0)=0 "RTN","C0CIMMU",67,0) N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ; "RTN","C0CIMMU",68,0) S C0CIM="" "RTN","C0CIMMU",69,0) S C0CC=0 ; COUNT "RTN","C0CIMMU",70,0) F S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST "RTN","C0CIMMU",71,0) . S C0CC=C0CC+1 ;INCREMENT COUNT "RTN","C0CIMMU",72,0) . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY "RTN","C0CIMMU",73,0) . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT "RTN","C0CIMMU",74,0) . K @VMAP ; MAKE SURE IT IS CLEARED OUT "RTN","C0CIMMU",75,0) . W C0CIM,! "RTN","C0CIMMU",76,0) . S C0CIMD="" ; IMMUNE DATE "RTN","C0CIMMU",77,0) . F S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD="" D ; FOR EACH DATE "RTN","C0CIMMU",78,0) . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD "RTN","C0CIMMU",79,0) . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS "RTN","C0CIMMU",80,0) . . W C0CIEN,"_",C0CIMD "RTN","C0CIMMU",81,0) . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME "RTN","C0CIMMU",82,0) . . W C0CT,! "RTN","C0CIMMU",83,0) . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID "RTN","C0CIMMU",84,0) . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME "RTN","C0CIMMU",85,0) . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME "RTN","C0CIMMU",86,0) . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER "RTN","C0CIMMU",87,0) . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP "RTN","C0CIMMU",88,0) . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION "RTN","C0CIMMU",89,0) . . I $G(DUZ("AG"))="I" D ; RUNNING IN RPMS "RTN","C0CIMMU",90,0) . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD "RTN","C0CIMMU",91,0) . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD "RTN","C0CIMMU",92,0) . . . ; FOR LOOKING UP THE CODE "RTN","C0CIMMU",93,0) . . . ; GET IT FROM THE CODE FILE "RTN","C0CIMMU",94,0) . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE "RTN","C0CIMMU",95,0) . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME "RTN","C0CIMMU",96,0) . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE "RTN","C0CIMMU",97,0) . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ; "RTN","C0CIMMU",98,0) . . . E S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL "RTN","C0CIMMU",99,0) . . E D ; NOT IN RPMS "RTN","C0CIMMU",100,0) . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION "RTN","C0CIMMU",101,0) . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME "RTN","C0CIMMU",102,0) . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE "RTN","C0CIMMU",103,0) . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE "RTN","C0CIMMU",104,0) N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) "RTN","C0CIMMU",105,0) M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES "RTN","C0CIMMU",106,0) Q "RTN","C0CIMMU",107,0) ; "RTN","C0CIN") 0^23^B30946883 "RTN","C0CIN",1,0) C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 "RTN","C0CIN",2,0) ;;1.0;C0C;;Sep 20, 2009;Build 1 "RTN","C0CIN",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CIN",4,0) ;General Public License See attached copy of the License. "RTN","C0CIN",5,0) ; "RTN","C0CIN",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CIN",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CIN",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CIN",9,0) ;(at your option) any later version. "RTN","C0CIN",10,0) ; "RTN","C0CIN",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CIN",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CIN",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CIN",14,0) ;GNU General Public License for more details. "RTN","C0CIN",15,0) ; "RTN","C0CIN",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CIN",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CIN",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CIN",19,0) ; "RTN","C0CIN",20,0) W "This is the CCR Import Utility Library ",! "RTN","C0CIN",21,0) Q "RTN","C0CIN",22,0) ; "RTN","C0CIN",23,0) TEST ; TESTS BOTH ROUTINES AT ONCE "RTN","C0CIN",24,0) N ZI,ZJ "RTN","C0CIN",25,0) S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing / "RTN","C0CIN",26,0) S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient "RTN","C0CIN",27,0) D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI) "RTN","C0CIN",28,0) Q "RTN","C0CIN",29,0) ; "RTN","C0CIN",30,0) RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT "RTN","C0CIN",31,0) ; AND STORE IT IN THE INCOMING XML FILE "RTN","C0CIN",32,0) ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR "RTN","C0CIN",33,0) I $G(DFN)="" S RTN="DFN NOT DEFINED" Q ; "RTN","C0CIN",34,0) N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE "RTN","C0CIN",35,0) N C0CFDA,ZX "RTN","C0CIN",36,0) S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT "RTN","C0CIN",37,0) S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD "RTN","C0CIN",38,0) S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE "RTN","C0CIN",39,0) S C0CFDA(C0CXF,"+1,",2)=TYPE ;TYPE "RTN","C0CIN",40,0) S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE "RTN","C0CIN",41,0) S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED "RTN","C0CIN",42,0) D UPDIE ; CREATE THE RECORD "RTN","C0CIN",43,0) S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER "RTN","C0CIN",44,0) D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR") "RTN","C0CIN",45,0) ;W "RECORD:",ZX,! "RTN","C0CIN",46,0) S RTN=ZX ; RETURN IEN OF THE XML FILE "RTN","C0CIN",47,0) Q "RTN","C0CIN",48,0) ; "RTN","C0CIN",49,0) ADDSRC(ZSRC) ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE "RTN","C0CIN",50,0) ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER "RTN","C0CIN",51,0) ; "RTN","C0CIN",52,0) N ZX,ZF,C0CFDA "RTN","C0CIN",53,0) S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE "RTN","C0CIN",54,0) S C0CFDA(ZF,"?+1,",.01)=ZSRC "RTN","C0CIN",55,0) D UPDIE "RTN","C0CIN",56,0) Q $O(^C0C(171.401,"B",ZSRC,"")) "RTN","C0CIN",57,0) ; "RTN","C0CIN",58,0) RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) ; FILE IN RPC - READ AN XML DOCUMENT "RTN","C0CIN",59,0) ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE "RTN","C0CIN",60,0) N ZX,ZTMP "RTN","C0CIN",61,0) I $E($RE(FP))'="/" S ZX=FP_"/" "RTN","C0CIN",62,0) E S ZX=FP "RTN","C0CIN",63,0) S ZX=ZX_FN "RTN","C0CIN",64,0) D LOAD("ZTMP",ZX) "RTN","C0CIN",65,0) I '$D(ZTMP) D Q ; NO LUCK "RTN","C0CIN",66,0) . W "FILE NOT LOADED",! "RTN","C0CIN",67,0) D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP") "RTN","C0CIN",68,0) N C0CFDA "RTN","C0CIN",69,0) S C0CFDA(175,RTN_",",5)=FN ; FILE NAME "RTN","C0CIN",70,0) S C0CFDA(175,RTN_",",6)=FP ; FILE PATH "RTN","C0CIN",71,0) D UPDIE ; UPDATE WITH FILE NAME AND PATH "RTN","C0CIN",72,0) Q "RTN","C0CIN",73,0) ; "RTN","C0CIN",74,0) RPCLIST(RTN,DFN) ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN "RTN","C0CIN",75,0) ; THAT ARE STORED IN THE INCOMING XML FILE "RTN","C0CIN",76,0) ; RETURNS AN ARRAY OF THE FORM "RTN","C0CIN",77,0) ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE "RTN","C0CIN",78,0) ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT "RTN","C0CIN",79,0) ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE "RTN","C0CIN",80,0) ; TYPE IS "CCD" OR "CCR" OR "OTHER" "RTN","C0CIN",81,0) ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE "RTN","C0CIN",82,0) ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED) "RTN","C0CIN",83,0) ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML "RTN","C0CIN",84,0) N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE "RTN","C0CIN",85,0) N ZI S ZI="" "RTN","C0CIN",86,0) N ZN S ZN=0 "RTN","C0CIN",87,0) F S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI="" D ; FOR EACH RECORD FOR THIS PATIENT "RTN","C0CIN",88,0) . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY "RTN","C0CIN",89,0) . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD "RTN","C0CIN",90,0) . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE "RTN","C0CIN",91,0) . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE "RTN","C0CIN",92,0) . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE "RTN","C0CIN",93,0) . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS "RTN","C0CIN",94,0) . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY "RTN","C0CIN",95,0) Q "RTN","C0CIN",96,0) ; "RTN","C0CIN",97,0) RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE "RTN","C0CIN",98,0) ; RETURNED IN ARRAY RTN "RTN","C0CIN",99,0) N ZI "RTN","C0CIN",100,0) S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN") "RTN","C0CIN",101,0) Q "RTN","C0CIN",102,0) ; "RTN","C0CIN",103,0) EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML "RTN","C0CIN",104,0) ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE "RTN","C0CIN",105,0) ; FOR PATIENT C0CDFN "RTN","C0CIN",106,0) ;N C0CXP "RTN","C0CIN",107,0) S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN)) "RTN","C0CIN",108,0) S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID "RTN","C0CIN",109,0) ;S REDUX="//ContinuityOfCareRecord/Body" "RTN","C0CIN",110,0) S REDUX="" "RTN","C0CIN",111,0) D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX) "RTN","C0CIN",112,0) ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR "RTN","C0CIN",113,0) ;N ZI,ZJ,ZK "RTN","C0CIN",114,0) S ZI="" "RTN","C0CIN",115,0) F S ZI=$O(C0CXP(ZI)) Q:ZI="" D ; FOR EACH XPATH "RTN","C0CIN",116,0) . D DEMUX^C0CMXP("ZJ",ZI) ; "RTN","C0CIN",117,0) . W ZJ,! "RTN","C0CIN",118,0) . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH "RTN","C0CIN",119,0) . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE "RTN","C0CIN",120,0) . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE "RTN","C0CIN",121,0) . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,"")) "RTN","C0CIN",122,0) . I C0CDICN="" D Q ; "RTN","C0CIN",123,0) . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC "RTN","C0CIN",124,0) . . S MISSING(ZK)="" "RTN","C0CIN",125,0) . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA") "RTN","C0CIN",126,0) . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME "RTN","C0CIN",127,0) . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE "RTN","C0CIN",128,0) . W C0CSEC,":",C0CVAR,! "RTN","C0CIN",129,0) Q "RTN","C0CIN",130,0) ; "RTN","C0CIN",131,0) GETACCR(AOUT,C0CDFN) ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT "RTN","C0CIN",132,0) ;PASSED BY NAME "RTN","C0CIN",133,0) N ZT "RTN","C0CIN",134,0) D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000") "RTN","C0CIN",135,0) M @AOUT=ZT "RTN","C0CIN",136,0) Q "RTN","C0CIN",137,0) ; "RTN","C0CIN",138,0) TEST64 ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN "RTN","C0CIN",139,0) W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1) "RTN","C0CIN",140,0) S G=G64(1) "RTN","C0CIN",141,0) S ZI="" "RTN","C0CIN",142,0) F S ZI=$O(G64(1,"OVF",ZI)) Q:ZI="" D ; FOR EVERY OVERFLOW RECORD "RTN","C0CIN",143,0) . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG "RTN","C0CIN",144,0) S G2=$$DECODE^RGUTUU(G) "RTN","C0CIN",145,0) Q "RTN","C0CIN",146,0) ; "RTN","C0CIN",147,0) NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML "RTN","C0CIN",148,0) ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME "RTN","C0CIN",149,0) ; "RTN","C0CIN",150,0) N ZI,ZN,ZTMP "RTN","C0CIN",151,0) S ZN=1 "RTN","C0CIN",152,0) S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" "RTN","C0CIN",153,0) S ZN=ZN+1 "RTN","C0CIN",154,0) F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; "RTN","C0CIN",155,0) . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" "RTN","C0CIN",156,0) . S ZN=ZN+1 "RTN","C0CIN",157,0) Q "RTN","C0CIN",158,0) ; "RTN","C0CIN",159,0) CLEANCR(OUTXML,INXML) ; USE $C(10) TO SEPARATE THE STRING INXML INTO "RTN","C0CIN",160,0) ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME "RTN","C0CIN",161,0) N ZX,ZY,ZN "RTN","C0CIN",162,0) S ZX=1,ZN=1 "RTN","C0CIN",163,0) F S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0 D ; "RTN","C0CIN",164,0) . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2) "RTN","C0CIN",165,0) . I @OUTXML@(ZN)'="" S ZN=ZN+1 "RTN","C0CIN",166,0) . S ZX=ZY "RTN","C0CIN",167,0) Q "RTN","C0CIN",168,0) ; "RTN","C0CIN",169,0) LOAD(ZRTN,filepath) ; load an xml file into the ZRTN array, passed by name "RTN","C0CIN",170,0) n i "RTN","C0CIN",171,0) D ; "RTN","C0CIN",172,0) . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" "RTN","C0CIN",173,0) . s ztmp=$na(^TMP("C0CLOAD",$J)) "RTN","C0CIN",174,0) . k @ztmp "RTN","C0CIN",175,0) . s zfile=$re($p($re(filepath),"/",1)) ;file name "RTN","C0CIN",176,0) . s zpath=$p(filepath,zfile,1) ; file path "RTN","C0CIN",177,0) . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3 "RTN","C0CIN",178,0) . m @ZRTN=@ztmp "RTN","C0CIN",179,0) . k @ztmp "RTN","C0CIN",180,0) . s i=$o(@ZRTN@(""),-1) ; highest line number "RTN","C0CIN",181,0) q "RTN","C0CIN",182,0) ; "RTN","C0CIN",183,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CIN",184,0) K ZERR,C0CIEN "RTN","C0CIN",185,0) D CLEAN^DILF "RTN","C0CIN",186,0) D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR") "RTN","C0CIN",187,0) I $D(ZERR) D ; "RTN","C0CIN",188,0) . W "ERROR",! "RTN","C0CIN",189,0) . ZWR ZERR "RTN","C0CIN",190,0) . B "RTN","C0CIN",191,0) K C0CFDA "RTN","C0CIN",192,0) Q "RTN","C0CIN",193,0) ; "RTN","C0CLA7DD") 0^24^B66668579 "RTN","C0CLA7DD",1,0) C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 "RTN","C0CLA7DD",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CLA7DD",3,0) ; "RTN","C0CLA7DD",4,0) ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file. "RTN","C0CLA7DD",5,0) ; "RTN","C0CLA7DD",6,0) Q "RTN","C0CLA7DD",7,0) ; "RTN","C0CLA7DD",8,0) ; "RTN","C0CLA7DD",9,0) EN ; Add new style cross-references to V LAB file if it exists. "RTN","C0CLA7DD",10,0) ; OLD entry point - see new KIDS check points in C0CENV. "RTN","C0CLA7DD",11,0) ; "RTN","C0CLA7DD",12,0) ; "RTN","C0CLA7DD",13,0) ; Quit if AUPNVLAB global does not exist. "RTN","C0CLA7DD",14,0) I $$VFILE^DILFD(9000010.09)'=1 Q "RTN","C0CLA7DD",15,0) ; "RTN","C0CLA7DD",16,0) N MSG "RTN","C0CLA7DD",17,0) ; "RTN","C0CLA7DD",18,0) S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",19,0) D BMES(MSG) "RTN","C0CLA7DD",20,0) D ALR1 "RTN","C0CLA7DD",21,0) S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",22,0) D BMES(MSG) "RTN","C0CLA7DD",23,0) ; "RTN","C0CLA7DD",24,0) S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",25,0) D BMES(MSG) "RTN","C0CLA7DD",26,0) D ALR2 "RTN","C0CLA7DD",27,0) S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",28,0) D BMES(MSG) "RTN","C0CLA7DD",29,0) ; "RTN","C0CLA7DD",30,0) S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",31,0) D BMES(MSG) "RTN","C0CLA7DD",32,0) D ALR3 "RTN","C0CLA7DD",33,0) S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",34,0) D BMES(MSG) "RTN","C0CLA7DD",35,0) ; "RTN","C0CLA7DD",36,0) S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",37,0) D BMES(MSG) "RTN","C0CLA7DD",38,0) D ALR4 "RTN","C0CLA7DD",39,0) S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",40,0) D BMES(MSG) "RTN","C0CLA7DD",41,0) ; "RTN","C0CLA7DD",42,0) S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",43,0) D BMES(MSG) "RTN","C0CLA7DD",44,0) D ALR5 "RTN","C0CLA7DD",45,0) S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") "RTN","C0CLA7DD",46,0) D BMES(MSG) "RTN","C0CLA7DD",47,0) ; "RTN","C0CLA7DD",48,0) Q "RTN","C0CLA7DD",49,0) ; "RTN","C0CLA7DD",50,0) ; "RTN","C0CLA7DD",51,0) ALR1 ; Installation of ALR1 cross-reference "RTN","C0CLA7DD",52,0) ; "RTN","C0CLA7DD",53,0) N C0CFLAG,C0CXR,C0CRES,C0COUT "RTN","C0CLA7DD",54,0) ; "RTN","C0CLA7DD",55,0) S C0CFLAG="" "RTN","C0CLA7DD",56,0) ; "RTN","C0CLA7DD",57,0) S C0CXR("FILE")=9000010.09 "RTN","C0CLA7DD",58,0) S C0CXR("NAME")="ALR1" "RTN","C0CLA7DD",59,0) S C0CXR("TYPE")="R" "RTN","C0CLA7DD",60,0) S C0CXR("USE")="S" "RTN","C0CLA7DD",61,0) S C0CXR("EXECUTION")="R" "RTN","C0CLA7DD",62,0) S C0CXR("ACTIVITY")="IR" "RTN","C0CLA7DD",63,0) S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)" "RTN","C0CLA7DD",64,0) S C0CXR("VAL",1)=.02 "RTN","C0CLA7DD",65,0) S C0CXR("VAL",1,"SUBSCRIPT")=1 "RTN","C0CLA7DD",66,0) S C0CXR("VAL",1,"COLLATION")="F" "RTN","C0CLA7DD",67,0) S C0CXR("VAL",2)=.06 "RTN","C0CLA7DD",68,0) S C0CXR("VAL",2,"SUBSCRIPT")=2 "RTN","C0CLA7DD",69,0) S C0CXR("VAL",2,"LENGTH")=30 "RTN","C0CLA7DD",70,0) S C0CXR("VAL",2,"COLLATION")="F" "RTN","C0CLA7DD",71,0) S C0CXR("VAL",3)=.01 "RTN","C0CLA7DD",72,0) S C0CXR("VAL",3,"SUBSCRIPT")=3 "RTN","C0CLA7DD",73,0) S C0CXR("VAL",3,"COLLATION")="F" "RTN","C0CLA7DD",74,0) S C0CXR("VAL",4)=1201 "RTN","C0CLA7DD",75,0) S C0CXR("VAL",4,"SUBSCRIPT")=4 "RTN","C0CLA7DD",76,0) S C0CXR("VAL",4,"COLLATION")="F" "RTN","C0CLA7DD",77,0) D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") "RTN","C0CLA7DD",78,0) ; "RTN","C0CLA7DD",79,0) Q "RTN","C0CLA7DD",80,0) ; "RTN","C0CLA7DD",81,0) ; "RTN","C0CLA7DD",82,0) ALR2 ; Installation of ALR2 cross-reference "RTN","C0CLA7DD",83,0) ; "RTN","C0CLA7DD",84,0) N C0CFLAG,C0CXR,C0CRES,C0COUT "RTN","C0CLA7DD",85,0) ; "RTN","C0CLA7DD",86,0) S C0CFLAG="" "RTN","C0CLA7DD",87,0) ; "RTN","C0CLA7DD",88,0) S C0CXR("FILE")=9000010.09 "RTN","C0CLA7DD",89,0) S C0CXR("NAME")="ALR2" "RTN","C0CLA7DD",90,0) S C0CXR("TYPE")="MU" "RTN","C0CLA7DD",91,0) S C0CXR("USE")="S" "RTN","C0CLA7DD",92,0) S C0CXR("EXECUTION")="R" "RTN","C0CLA7DD",93,0) S C0CXR("ACTIVITY")="IR" "RTN","C0CLA7DD",94,0) S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result." "RTN","C0CLA7DD",95,0) S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes" "RTN","C0CLA7DD",96,0) S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to" "RTN","C0CLA7DD",97,0) S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test" "RTN","C0CLA7DD",98,0) S C0CXR("DESCR",4)="result." "RTN","C0CLA7DD",99,0) S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)=""""" "RTN","C0CLA7DD",100,0) S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)" "RTN","C0CLA7DD",101,0) S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")" "RTN","C0CLA7DD",102,0) S C0CXR("VAL",1)=.02 "RTN","C0CLA7DD",103,0) S C0CXR("VAL",1,"SUBSCRIPT")=1 "RTN","C0CLA7DD",104,0) S C0CXR("VAL",1,"COLLATION")="F" "RTN","C0CLA7DD",105,0) S C0CXR("VAL",2)=1201 "RTN","C0CLA7DD",106,0) S C0CXR("VAL",2,"SUBSCRIPT")=2 "RTN","C0CLA7DD",107,0) S C0CXR("VAL",2,"COLLATION")="F" "RTN","C0CLA7DD",108,0) S C0CXR("VAL",3)=.06 "RTN","C0CLA7DD",109,0) S C0CXR("VAL",3,"SUBSCRIPT")=3 "RTN","C0CLA7DD",110,0) S C0CXR("VAL",3,"COLLATION")="F" "RTN","C0CLA7DD",111,0) S C0CXR("VAL",4)=.01 "RTN","C0CLA7DD",112,0) S C0CXR("VAL",4,"SUBSCRIPT")=4 "RTN","C0CLA7DD",113,0) S C0CXR("VAL",4,"COLLATION")="F" "RTN","C0CLA7DD",114,0) S C0CXR("VAL",5)=1113 "RTN","C0CLA7DD",115,0) S C0CXR("VAL",5,"SUBSCRIPT")=5 "RTN","C0CLA7DD",116,0) S C0CXR("VAL",5,"COLLATION")="F" "RTN","C0CLA7DD",117,0) D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") "RTN","C0CLA7DD",118,0) ; "RTN","C0CLA7DD",119,0) Q "RTN","C0CLA7DD",120,0) ; "RTN","C0CLA7DD",121,0) ; "RTN","C0CLA7DD",122,0) ALR3 ; Installation of ALR3 cross-reference "RTN","C0CLA7DD",123,0) ; "RTN","C0CLA7DD",124,0) N C0CFLAG,C0CXR,C0CRES,C0COUT "RTN","C0CLA7DD",125,0) ; "RTN","C0CLA7DD",126,0) S C0CFLAG="" "RTN","C0CLA7DD",127,0) ; "RTN","C0CLA7DD",128,0) S C0CXR("FILE")=9000010.09 "RTN","C0CLA7DD",129,0) S C0CXR("NAME")="ALR3" "RTN","C0CLA7DD",130,0) S C0CXR("TYPE")="R" "RTN","C0CLA7DD",131,0) S C0CXR("USE")="S" "RTN","C0CLA7DD",132,0) S C0CXR("EXECUTION")="F" "RTN","C0CLA7DD",133,0) S C0CXR("ACTIVITY")="IR" "RTN","C0CLA7DD",134,0) S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient" "RTN","C0CLA7DD",135,0) S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries" "RTN","C0CLA7DD",136,0) S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient" "RTN","C0CLA7DD",137,0) S C0CXR("DESCR",3)="lab results to be identified by LOINC" "RTN","C0CLA7DD",138,0) S C0CXR("VAL",1)=1113 "RTN","C0CLA7DD",139,0) S C0CXR("VAL",1,"SUBSCRIPT")=1 "RTN","C0CLA7DD",140,0) S C0CXR("VAL",1,"COLLATION")="F" "RTN","C0CLA7DD",141,0) ; "RTN","C0CLA7DD",142,0) D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") "RTN","C0CLA7DD",143,0) ; "RTN","C0CLA7DD",144,0) Q "RTN","C0CLA7DD",145,0) ; "RTN","C0CLA7DD",146,0) ; "RTN","C0CLA7DD",147,0) ALR4 ; Installation of ALR4 cross-reference "RTN","C0CLA7DD",148,0) ; "RTN","C0CLA7DD",149,0) N C0CFLAG,C0CXR,C0CRES,C0COUT "RTN","C0CLA7DD",150,0) ; "RTN","C0CLA7DD",151,0) S C0CFLAG="" "RTN","C0CLA7DD",152,0) ; "RTN","C0CLA7DD",153,0) S C0CXR("FILE")=9000010.09 "RTN","C0CLA7DD",154,0) S C0CXR("NAME")="ALR4" "RTN","C0CLA7DD",155,0) S C0CXR("TYPE")="R" "RTN","C0CLA7DD",156,0) S C0CXR("USE")="S" "RTN","C0CLA7DD",157,0) S C0CXR("EXECUTION")="R" "RTN","C0CLA7DD",158,0) S C0CXR("ACTIVITY")="IR" "RTN","C0CLA7DD",159,0) S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time" "RTN","C0CLA7DD",160,0) S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" "RTN","C0CLA7DD",161,0) S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in" "RTN","C0CLA7DD",162,0) S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" "RTN","C0CLA7DD",163,0) S C0CXR("DESCR",4)="file (#63)." "RTN","C0CLA7DD",164,0) S C0CXR("VAL",1)=.02 "RTN","C0CLA7DD",165,0) S C0CXR("VAL",1,"SUBSCRIPT")=1 "RTN","C0CLA7DD",166,0) S C0CXR("VAL",1,"COLLATION")="F" "RTN","C0CLA7DD",167,0) S C0CXR("VAL",2)=1201 "RTN","C0CLA7DD",168,0) S C0CXR("VAL",2,"SUBSCRIPT")=2 "RTN","C0CLA7DD",169,0) S C0CXR("VAL",2,"COLLATION")="F" "RTN","C0CLA7DD",170,0) ; "RTN","C0CLA7DD",171,0) D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") "RTN","C0CLA7DD",172,0) ; "RTN","C0CLA7DD",173,0) Q "RTN","C0CLA7DD",174,0) ; "RTN","C0CLA7DD",175,0) ; "RTN","C0CLA7DD",176,0) ALR5 ; Installation of ALR5 cross-reference "RTN","C0CLA7DD",177,0) ; "RTN","C0CLA7DD",178,0) N C0CFLAG,C0CXR,C0CRES,C0COUT "RTN","C0CLA7DD",179,0) ; "RTN","C0CLA7DD",180,0) S C0CFLAG="" "RTN","C0CLA7DD",181,0) ; "RTN","C0CLA7DD",182,0) S C0CXR("FILE")=9000010.09 "RTN","C0CLA7DD",183,0) S C0CXR("NAME")="ALR5" "RTN","C0CLA7DD",184,0) S C0CXR("TYPE")="R" "RTN","C0CLA7DD",185,0) S C0CXR("USE")="S" "RTN","C0CLA7DD",186,0) S C0CXR("EXECUTION")="R" "RTN","C0CLA7DD",187,0) S C0CXR("ACTIVITY")="IR" "RTN","C0CLA7DD",188,0) S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time" "RTN","C0CLA7DD",189,0) S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" "RTN","C0CLA7DD",190,0) S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in" "RTN","C0CLA7DD",191,0) S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" "RTN","C0CLA7DD",192,0) S C0CXR("DESCR",4)="file (#63)." "RTN","C0CLA7DD",193,0) S C0CXR("VAL",1)=.02 "RTN","C0CLA7DD",194,0) S C0CXR("VAL",1,"SUBSCRIPT")=1 "RTN","C0CLA7DD",195,0) S C0CXR("VAL",1,"COLLATION")="F" "RTN","C0CLA7DD",196,0) S C0CXR("VAL",2)=1212 "RTN","C0CLA7DD",197,0) S C0CXR("VAL",2,"SUBSCRIPT")=2 "RTN","C0CLA7DD",198,0) S C0CXR("VAL",2,"COLLATION")="F" "RTN","C0CLA7DD",199,0) ; "RTN","C0CLA7DD",200,0) D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") "RTN","C0CLA7DD",201,0) ; "RTN","C0CLA7DD",202,0) Q "RTN","C0CLA7DD",203,0) ; "RTN","C0CLA7DD",204,0) ; "RTN","C0CLA7DD",205,0) REINDEX ; Set data into indexes for current entries. "RTN","C0CLA7DD",206,0) ; "RTN","C0CLA7DD",207,0) ; "RTN","C0CLA7DD",208,0) N C0CHLOG,DA,DIK,MSG "RTN","C0CLA7DD",209,0) ; "RTN","C0CLA7DD",210,0) S C0CHLOG("START")=$H "RTN","C0CLA7DD",211,0) S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") "RTN","C0CLA7DD",212,0) D BMES(MSG),SENDXQA(MSG) "RTN","C0CLA7DD",213,0) ; "RTN","C0CLA7DD",214,0) S DIK="^AUPNVLAB(" "RTN","C0CLA7DD",215,0) S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" "RTN","C0CLA7DD",216,0) D ENALL^DIK "RTN","C0CLA7DD",217,0) ; "RTN","C0CLA7DD",218,0) S C0CHLOG("END")=$H "RTN","C0CLA7DD",219,0) S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") "RTN","C0CLA7DD",220,0) D BMES(MSG),SENDXQA(MSG) "RTN","C0CLA7DD",221,0) ; "RTN","C0CLA7DD",222,0) S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) "RTN","C0CLA7DD",223,0) D BMES(MSG) "RTN","C0CLA7DD",224,0) ; "RTN","C0CLA7DD",225,0) S C0CHLOG("START")=$H "RTN","C0CLA7DD",226,0) S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") "RTN","C0CLA7DD",227,0) D BMES(MSG),SENDXQA(MSG) "RTN","C0CLA7DD",228,0) ; "RTN","C0CLA7DD",229,0) K DA,DIK "RTN","C0CLA7DD",230,0) S DIK="^AUPNVLAB(" "RTN","C0CLA7DD",231,0) S DIK(1)="1113^ALR3" "RTN","C0CLA7DD",232,0) D ENALL^DIK "RTN","C0CLA7DD",233,0) ; "RTN","C0CLA7DD",234,0) S C0CHLOG("END")=$H "RTN","C0CLA7DD",235,0) S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") "RTN","C0CLA7DD",236,0) D BMES(MSG),SENDXQA(MSG) "RTN","C0CLA7DD",237,0) ; "RTN","C0CLA7DD",238,0) S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) "RTN","C0CLA7DD",239,0) D BMES(MSG) "RTN","C0CLA7DD",240,0) ; "RTN","C0CLA7DD",241,0) Q "RTN","C0CLA7DD",242,0) ; "RTN","C0CLA7DD",243,0) ; "RTN","C0CLA7DD",244,0) BMES(STR) ; Write BMES^XPDUTL statements "RTN","C0CLA7DD",245,0) ; "RTN","C0CLA7DD",246,0) D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) "RTN","C0CLA7DD",247,0) ; "RTN","C0CLA7DD",248,0) Q "RTN","C0CLA7DD",249,0) ; "RTN","C0CLA7DD",250,0) ; "RTN","C0CLA7DD",251,0) SENDXQA(MSG) ; Send alert for reindex status "RTN","C0CLA7DD",252,0) ; "RTN","C0CLA7DD",253,0) N XQA,XQAMSG "RTN","C0CLA7DD",254,0) ; "RTN","C0CLA7DD",255,0) S XQA(DUZ)="" "RTN","C0CLA7DD",256,0) S XQAMSG=MSG "RTN","C0CLA7DD",257,0) D SETUP^XQALERT "RTN","C0CLA7DD",258,0) ; "RTN","C0CLA7DD",259,0) Q "RTN","C0CLA7Q") 0^25^B21818572 "RTN","C0CLA7Q",1,0) C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 "RTN","C0CLA7Q",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CLA7Q",3,0) ; "RTN","C0CLA7Q",4,0) ; "RTN","C0CLA7Q",5,0) Q "RTN","C0CLA7Q",6,0) ; "RTN","C0CLA7Q",7,0) ; "RTN","C0CLA7Q",8,0) LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query "RTN","C0CLA7Q",9,0) ; "RTN","C0CLA7Q",10,0) ; "RTN","C0CLA7Q",11,0) K ^TMP("C0C-VLAB",$J) "RTN","C0CLA7Q",12,0) ; "RTN","C0CLA7Q",13,0) ; Check and retrieve lab results from LAB DATA file (#63) "RTN","C0CLA7Q",14,0) S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7)) "RTN","C0CLA7Q",15,0) ; "RTN","C0CLA7Q",16,0) ; If V LAB file present then check for lab results that are only in this file "RTN","C0CLA7Q",17,0) ; If results found in V Lab file then build results and add to above results. "RTN","C0CLA7Q",18,0) I $D(^AUPNVLAB) D "RTN","C0CLA7Q",19,0) . D VCHECK "RTN","C0CLA7Q",20,0) . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD "RTN","C0CLA7Q",21,0) ; "RTN","C0CLA7Q",22,0) ;K ^TMP("C0C-VLAB",$J) "RTN","C0CLA7Q",23,0) ; "RTN","C0CLA7Q",24,0) Q C0CDEST "RTN","C0CLA7Q",25,0) ; "RTN","C0CLA7Q",26,0) ; "RTN","C0CLA7Q",27,0) VCHECK ; If V LAB file present then check for lab results that are only in this file. "RTN","C0CLA7Q",28,0) ; "RTN","C0CLA7Q",29,0) N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC "RTN","C0CLA7Q",30,0) ; "RTN","C0CLA7Q",31,0) S LA7PTID=C0CPTID "RTN","C0CLA7Q",32,0) D PATID^LA7QRY2 "RTN","C0CLA7Q",33,0) I $D(LA7ERR) Q "RTN","C0CLA7Q",34,0) ; "RTN","C0CLA7Q",35,0) ; Resolve search codes to lab datanames "RTN","C0CLA7Q",36,0) S LA7SC=$G(C0CSC) "RTN","C0CLA7Q",37,0) I $T(SCLIST^LA7QRY2)'="" D "RTN","C0CLA7Q",38,0) . N TMP "RTN","C0CLA7Q",39,0) . S LA7SCRC=$G(C0CSC) "RTN","C0CLA7Q",40,0) . S TMP=$$SCLIST^LA7QRY2(LA7SCRC) "RTN","C0CLA7Q",41,0) . S LA7SC=TMP "RTN","C0CLA7Q",42,0) ; "RTN","C0CLA7Q",43,0) I LA7SC'="*" D CHKSC^LA7QRY1 "RTN","C0CLA7Q",44,0) ; "RTN","C0CLA7Q",45,0) ; Convert specimen codes to file #61 Topography entries "RTN","C0CLA7Q",46,0) S LA7SPEC=$G(C0CSPEC) "RTN","C0CLA7Q",47,0) I LA7SPEC'="*" D SPEC^LA7QRY1 "RTN","C0CLA7Q",48,0) ; "RTN","C0CLA7Q",49,0) S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0 "RTN","C0CLA7Q",50,0) ; "RTN","C0CLA7Q",51,0) F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND "RTN","C0CLA7Q",52,0) . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient "RTN","C0CLA7Q",53,0) . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time "RTN","C0CLA7Q",54,0) . S C0CDA=$QS(C0CROOT,4) "RTN","C0CLA7Q",55,0) . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63 "RTN","C0CLA7Q",56,0) . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip "RTN","C0CLA7Q",57,0) . D VCHK1 "RTN","C0CLA7Q",58,0) ; "RTN","C0CLA7Q",59,0) ; "RTN","C0CLA7Q",60,0) Q "RTN","C0CLA7Q",61,0) ; "RTN","C0CLA7Q",62,0) ; "RTN","C0CLA7Q",63,0) VBUILD ; Build results found only in V LAB file into HL7 structure. "RTN","C0CLA7Q",64,0) ; "RTN","C0CLA7Q",65,0) ; "RTN","C0CLA7Q",66,0) Q "RTN","C0CLA7Q",67,0) ; "RTN","C0CLA7Q",68,0) ; "RTN","C0CLA7Q",69,0) LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. "RTN","C0CLA7Q",70,0) ; Call from LA7QRY2 "RTN","C0CLA7Q",71,0) ; "RTN","C0CLA7Q",72,0) N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X "RTN","C0CLA7Q",73,0) ; "RTN","C0CLA7Q",74,0) S DFN=$P(^LR(LRDFN,0),"^",3) "RTN","C0CLA7Q",75,0) S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) "RTN","C0CLA7Q",76,0) S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) "RTN","C0CLA7Q",77,0) S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" "RTN","C0CLA7Q",78,0) ; "RTN","C0CLA7Q",79,0) ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" "RTN","C0CLA7Q",80,0) ; "RTN","C0CLA7Q",81,0) S C0C60="" "RTN","C0CLA7Q",82,0) F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" "RTN","C0CLA7Q",83,0) . D FINDDT "RTN","C0CLA7Q",84,0) . I C0CDA<1 Q "RTN","C0CLA7Q",85,0) . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip "RTN","C0CLA7Q",86,0) . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) "RTN","C0CLA7Q",87,0) . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) "RTN","C0CLA7Q",88,0) . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer "RTN","C0CLA7Q",89,0) . I C0CPDA="" S C0CPDA=C0CDA "RTN","C0CLA7Q",90,0) . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) "RTN","C0CLA7Q",91,0) . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) "RTN","C0CLA7Q",92,0) . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") "RTN","C0CLA7Q",93,0) . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) "RTN","C0CLA7Q",94,0) . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" "RTN","C0CLA7Q",95,0) . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" "RTN","C0CLA7Q",96,0) . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST "RTN","C0CLA7Q",97,0) ; "RTN","C0CLA7Q",98,0) S X=$P(LA7X,"^",3) "RTN","C0CLA7Q",99,0) ; If order NLT then update if no order NLT "RTN","C0CLA7Q",100,0) I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) "RTN","C0CLA7Q",101,0) ; "RTN","C0CLA7Q",102,0) ; If result NLT then update if no result NLT "RTN","C0CLA7Q",103,0) I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) "RTN","C0CLA7Q",104,0) ; "RTN","C0CLA7Q",105,0) ; If LOINC found then update variable with LN code "RTN","C0CLA7Q",106,0) I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN "RTN","C0CLA7Q",107,0) ; "RTN","C0CLA7Q",108,0) S $P(LA7X,"^",3)=X "RTN","C0CLA7Q",109,0) ; "RTN","C0CLA7Q",110,0) Q "RTN","C0CLA7Q",111,0) ; "RTN","C0CLA7Q",112,0) ; "RTN","C0CLA7Q",113,0) TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments "RTN","C0CLA7Q",114,0) ; Called from LA7VOBX1 "RTN","C0CLA7Q",115,0) ; "RTN","C0CLA7Q",116,0) N I,X "RTN","C0CLA7Q",117,0) ; "RTN","C0CLA7Q",118,0) S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) "RTN","C0CLA7Q",119,0) I X="" Q "RTN","C0CLA7Q",120,0) F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I) "RTN","C0CLA7Q",121,0) S $P(LA7VAL,"^",3)=LA7X "RTN","C0CLA7Q",122,0) ; "RTN","C0CLA7Q",123,0) Q "RTN","C0CLA7Q",124,0) ; "RTN","C0CLA7Q",125,0) ; "RTN","C0CLA7Q",126,0) VCHK1 ; Check the entry in V Lab to determine if it meets criteria "RTN","C0CLA7Q",127,0) ; "RTN","C0CLA7Q",128,0) N C0CVLAB,I "RTN","C0CLA7Q",129,0) ; "RTN","C0CLA7Q",130,0) F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I)) "RTN","C0CLA7Q",131,0) ; "RTN","C0CLA7Q",132,0) ; JMC 04/13/09 - Store anything for now that meets date criteria. "RTN","C0CLA7Q",133,0) D VSTORE "RTN","C0CLA7Q",134,0) ; "RTN","C0CLA7Q",135,0) Q "RTN","C0CLA7Q",136,0) ; "RTN","C0CLA7Q",137,0) ; "RTN","C0CLA7Q",138,0) VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. "RTN","C0CLA7Q",139,0) ; "RTN","C0CLA7Q",140,0) N C0CPDA,C0CPTEST "RTN","C0CLA7Q",141,0) ; "RTN","C0CLA7Q",142,0) ; Determine parent test to use for OBR segment "RTN","C0CLA7Q",143,0) S C0CPDA=$P(C0CVLAB(12),"^",8) "RTN","C0CLA7Q",144,0) I C0CPDA="" S C0CPDA=C0CDA "RTN","C0CLA7Q",145,0) ; "RTN","C0CLA7Q",146,0) ; Determine parent test "RTN","C0CLA7Q",147,0) S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^") "RTN","C0CLA7Q",148,0) ; "RTN","C0CLA7Q",149,0) S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA "RTN","C0CLA7Q",150,0) ; "RTN","C0CLA7Q",151,0) Q "RTN","C0CLA7Q",152,0) ; "RTN","C0CLA7Q",153,0) ; "RTN","C0CLA7Q",154,0) FINDDT ; Find entry in V LAB for the date/time or one close to it. "RTN","C0CLA7Q",155,0) ; RPMS stores related specimen entries under the same date/time. "RTN","C0CLA7Q",156,0) ; Lab file #63 creates unique entries with slightly different times. "RTN","C0CLA7Q",157,0) ; "RTN","C0CLA7Q",158,0) S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0)) "RTN","C0CLA7Q",159,0) I C0CDA>0 Q "RTN","C0CLA7Q",160,0) ; "RTN","C0CLA7Q",161,0) ; If entry found then confirm that specimen type matches. "RTN","C0CLA7Q",162,0) N C0CDTY "RTN","C0CLA7Q",163,0) S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0)) "RTN","C0CLA7Q",164,0) I C0CDTY D "RTN","C0CLA7Q",165,0) . I $P(C0CDT,".")'=$P(C0CDTY,".") Q "RTN","C0CLA7Q",166,0) . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0)) "RTN","C0CLA7Q",167,0) . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA="" "RTN","C0CLA7Q",168,0) ; "RTN","C0CLA7Q",169,0) Q "RTN","C0CLABS") 0^26^B282605501 "RTN","C0CLABS",1,0) C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 "RTN","C0CLABS",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CLABS",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CLABS",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CLABS",5,0) ;See attached copy of the License. "RTN","C0CLABS",6,0) ; "RTN","C0CLABS",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CLABS",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CLABS",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CLABS",10,0) ;(at your option) any later version. "RTN","C0CLABS",11,0) ; "RTN","C0CLABS",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CLABS",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CLABS",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CLABS",15,0) ;GNU General Public License for more details. "RTN","C0CLABS",16,0) ; "RTN","C0CLABS",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CLABS",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CLABS",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CLABS",20,0) ; "RTN","C0CLABS",21,0) MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT "RTN","C0CLABS",22,0) ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR "RTN","C0CLABS",23,0) ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME "RTN","C0CLABS",24,0) ; MIXML IS THE TEMPLATE TO USE "RTN","C0CLABS",25,0) ; MOXML IS THE OUTPUT XML ARRAY "RTN","C0CLABS",26,0) ; DFN IS THE PATIENT RECORD NUMBER "RTN","C0CLABS",27,0) N C0COXML,C0CO,C0CV,C0CIXML "RTN","C0CLABS",28,0) I '$D(MIVAR) S C0CV="" ;DEFAULT "RTN","C0CLABS",29,0) E S C0CV=MIVAR ;PASSED VARIABLE ARRAY "RTN","C0CLABS",30,0) I '$D(MIXML) S C0CIXML="" ;DEFAULT "RTN","C0CLABS",31,0) E S C0CIXML=MIXML ;PASSED INPUT XML "RTN","C0CLABS",32,0) D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK "RTN","C0CLABS",33,0) I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT "RTN","C0CLABS",34,0) E S C0CO=MOXML "RTN","C0CLABS",35,0) ; ZWR C0COXML "RTN","C0CLABS",36,0) M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT "RTN","C0CLABS",37,0) Q "RTN","C0CLABS",38,0) ; "RTN","C0CLABS",39,0) RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS "RTN","C0CLABS",40,0) ; RTN IS PASSED BY REFERENCE "RTN","C0CLABS",41,0) ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES "RTN","C0CLABS",42,0) ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE "RTN","C0CLABS",43,0) I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING "RTN","C0CLABS",44,0) I RMIXML="" D ; INPUT XML NOT PASSED "RTN","C0CLABS",45,0) . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE "RTN","C0CLABS",46,0) . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R") "RTN","C0CLABS",47,0) . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE "RTN","C0CLABS",48,0) E S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE "RTN","C0CLABS",49,0) I RMIVAR="" D ; LOCATION OF VARIABLES NOT PASSED "RTN","C0CLABS",50,0) . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION "RTN","C0CLABS",51,0) E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS "RTN","C0CLABS",52,0) D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE "RTN","C0CLABS",53,0) D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ "RTN","C0CLABS",54,0) D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE "RTN","C0CLABS",55,0) I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT "RTN","C0CLABS",56,0) I 'C0CQT D ; WE ARE DEBUGGING "RTN","C0CLABS",57,0) . W "I MAPPED",! "RTN","C0CLABS",58,0) . W "VARS:",C0CV,! "RTN","C0CLABS",59,0) . W "DFN:",DFN,! "RTN","C0CLABS",60,0) . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE "RTN","C0CLABS",61,0) . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) "RTN","C0CLABS",62,0) . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX) "RTN","C0CLABS",63,0) D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT "RTN","C0CLABS",64,0) I '$D(@C0CV@(0)) D Q ; NO VARS THERE "RTN","C0CLABS",65,0) . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR "RTN","C0CLABS",66,0) I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS "RTN","C0CLABS",67,0) S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS")) "RTN","C0CLABS",68,0) K @RIMVARS "RTN","C0CLABS",69,0) M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH "RTN","C0CLABS",70,0) N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP "RTN","C0CLABS",71,0) S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR) "RTN","C0CLABS",72,0) N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT "RTN","C0CLABS",73,0) N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA "RTN","C0CLABS",74,0) N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END "RTN","C0CLABS",75,0) ; TO IMPROVE PERFORMANCE "RTN","C0CLABS",76,0) D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ; "RTN","C0CLABS",77,0) F C0CI=1:1:C0CIN D ; LOOP THROUGH VARIABLES "RTN","C0CLABS",78,0) . K C0CMAP,C0CTMP ;EMPTY OUT LAST BATCH OF VARIABLES "RTN","C0CLABS",79,0) . S C0CRTMP=$NA(@C0CRBASE@(C0CI)) ;PARTITION OF WORK AREA FOR EACH TEST "RTN","C0CLABS",80,0) . S C0CMAP=$NA(@C0CV@(C0CI)) ; "RTN","C0CLABS",81,0) . I 'C0CQT W "MAPOBR:",C0CMAP,! "RTN","C0CLABS",82,0) . ;MAPPING FOR TEST REQUEST GOES HERE "RTN","C0CLABS",83,0) . D MAP^C0CXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA "RTN","C0CLABS",84,0) . ;D QOPEN^C0CXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML "RTN","C0CLABS",85,0) . D QUEUE^C0CXPATH("C0CRBLD",C0CRTMP,2,@C0CRTMP@(0)-4) ;UP TO "RTN","C0CLABS",86,0) . I $D(@C0CMAP@("M","TEST",0)) D ; TESTS EXIST "RTN","C0CLABS",87,0) . . S C0CJN=@C0CMAP@("M","TEST",0) ; NUMBER OF TESTS "RTN","C0CLABS",88,0) . . K C0CTO ; CLEAR OUTPUT VARIABLE "RTN","C0CLABS",89,0) . . F C0CJ=1:1:C0CJN D ;FOR EACH TEST RESULT "RTN","C0CLABS",90,0) . . . K C0CTMAP ; EMPTY MAPS FOR TEST RESULTS "RTN","C0CLABS",91,0) . . . S C0CTMP=$NA(@C0CRBASE@(C0CI,C0CJ)) ;WORK AREA FOR TEST RESULTS "RTN","C0CLABS",92,0) . . . S C0CTMAP=$NA(@C0CMAP@("M","TEST",C0CJ)) ; "RTN","C0CLABS",93,0) . . . I 'C0CQT W "MAPOBX:",C0CTMAP,! "RTN","C0CLABS",94,0) . . . D MAP^C0CXPATH("C0CTT",C0CTMAP,C0CTMP) ; MAP TO TMP "RTN","C0CLABS",95,0) . . . I C0CJ=1 S C0CJS=2 E S C0CJS=1 ;FIRST TIME,SKIP THE "RTN","C0CLABS",96,0) . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E S C0CJE=@C0CTMP@(0) ; "RTN","C0CLABS",97,0) . . . S C0CJS=1 S C0CJE=@C0CTMP@(0) ; INSERT ALL OF THE TEXT XML "RTN","C0CLABS",98,0) . . . D QUEUE^C0CXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST "RTN","C0CLABS",99,0) . . . ;I C0CJ=1 D ; FIRST TIME, JUST COPY "RTN","C0CLABS",100,0) . . . ;. D CP^C0CXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML "RTN","C0CLABS",101,0) . . . ;E D INSINNER^C0CXPATH("C0CTO","C0CTMP") "RTN","C0CLABS",102,0) . . . ; "RTN","C0CLABS",103,0) . . . ;D PUSHA^C0CXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER "RTN","C0CLABS",104,0) . . ; I 'C0CQT D PARY^C0CXPATH("C0CTO") "RTN","C0CLABS",105,0) . . ;D INSINNER^C0CXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST "RTN","C0CLABS",106,0) . ;D QCLOSE^C0CXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML "RTN","C0CLABS",107,0) . D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ; "RTN","C0CLABS",108,0) . ;I C0CI=1 D ; FIRST TIME, COPY INSTEAD OF INSERT "RTN","C0CLABS",109,0) . . ;D CP^C0CXPATH(C0CRTMP,"RTN") ; "RTN","C0CLABS",110,0) . ;E D INSINNER^C0CXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST "RTN","C0CLABS",111,0) D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ; "RTN","C0CLABS",112,0) D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML "RTN","C0CLABS",113,0) K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE "RTN","C0CLABS",114,0) Q "RTN","C0CLABS",115,0) ; "RTN","C0CLABS",116,0) EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL "RTN","C0CLABS",117,0) ; "RTN","C0CLABS",118,0) ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CLABS",119,0) ; "RTN","C0CLABS",120,0) ; "RTN","C0CLABS",121,0) ; "RTN","C0CLABS",122,0) N C0CNSSN ; IS THERE AN SSN FLAG "RTN","C0CLABS",123,0) S C0CNSSN=0 "RTN","C0CLABS",124,0) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS "RTN","C0CLABS",125,0) D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT "RTN","C0CLABS",126,0) I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT "RTN","C0CLABS",127,0) . S @C0CLB@(0)=0 "RTN","C0CLABS",128,0) K @C0CLB ; CLEAR OUT OLD VARS IF ANY "RTN","C0CLABS",129,0) N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG "RTN","C0CLABS",130,0) S C0CQT=1 ; SURPRESS LISTING "RTN","C0CLABS",131,0) D LIST ; EXTRACT THE VARIABLES "RTN","C0CLABS",132,0) ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD "RTN","C0CLABS",133,0) D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS "RTN","C0CLABS",134,0) S C0CQT=QTSAV ; RESET SILENT FLAG "RTN","C0CLABS",135,0) K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT "RTN","C0CLABS",136,0) I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS "RTN","C0CLABS",137,0) Q "RTN","C0CLABS",138,0) ; "RTN","C0CLABS",139,0) GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT "RTN","C0CLABS",140,0) ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR "RTN","C0CLABS",141,0) ; SET UP FOR LAB API CALL "RTN","C0CLABS",142,0) S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT "RTN","C0CLABS",143,0) I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT "RTN","C0CLABS",144,0) . W "LAB LOOKUP FAILED, NO SSN",! "RTN","C0CLABS",145,0) . S C0CNSSN=1 ; SET NO SSN FLAG "RTN","C0CLABS",146,0) S C0CSPC="*" ; LOOKING FOR ALL LABS "RTN","C0CLABS",147,0) ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS "RTN","C0CLABS",148,0) ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME "RTN","C0CLABS",149,0) ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING "RTN","C0CLABS",150,0) ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY "RTN","C0CLABS",151,0) S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM "RTN","C0CLABS",152,0) S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM "RTN","C0CLABS",153,0) D DT^DILF(,C0CLLMT,.C0CSDT) ; "RTN","C0CLABS",154,0) W "LAB LIMIT: ",C0CLLMT,! "RTN","C0CLABS",155,0) D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM "RTN","C0CLABS",156,0) S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW "RTN","C0CLABS",157,0) S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP "RTN","C0CLABS",158,0) Q "RTN","C0CLABS",159,0) ; "RTN","C0CLABS",160,0) LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB "RTN","C0CLABS",161,0) ; "RTN","C0CLABS",162,0) ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR "RTN","C0CLABS",163,0) I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS "RTN","C0CLABS",164,0) I '$D(C0CQT) S C0CQT=0 "RTN","C0CLABS",165,0) I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT "RTN","C0CLABS",166,0) I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE "RTN","C0CLABS",167,0) I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION "RTN","C0CLABS",168,0) I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE "RTN","C0CLABS",169,0) S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE "RTN","C0CLABS",170,0) S C0CHB=$NA(^TMP("HLS",$J)) "RTN","C0CLABS",171,0) S C0CI="" "RTN","C0CLABS",172,0) S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT "RTN","C0CLABS",173,0) F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG "RTN","C0CLABS",174,0) . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES "RTN","C0CLABS",175,0) . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) "RTN","C0CLABS",176,0) . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) "RTN","C0CLABS",177,0) . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification "RTN","C0CLABS",178,0) . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT "RTN","C0CLABS",179,0) . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION "RTN","C0CLABS",180,0) . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE "RTN","C0CLABS",181,0) . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD "RTN","C0CLABS",182,0) . M XV=C0CVAR ; "RTN","C0CLABS",183,0) . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION "RTN","C0CLABS",184,0) . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT "RTN","C0CLABS",185,0) . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT "RTN","C0CLABS",186,0) . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS "RTN","C0CLABS",187,0) . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI "RTN","C0CLABS",188,0) . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR "RTN","C0CLABS",189,0) . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) "RTN","C0CLABS",190,0) . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT "RTN","C0CLABS",191,0) . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL "RTN","C0CLABS",192,0) . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME "RTN","C0CLABS",193,0) . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS "RTN","C0CLABS",194,0) . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION "RTN","C0CLABS",195,0) . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 "RTN","C0CLABS",196,0) . . ; RESULTTESTCODEVALUE "RTN","C0CLABS",197,0) . . ; RESULTTESTDESCRIPTIONTEXT "RTN","C0CLABS",198,0) . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC "RTN","C0CLABS",199,0) . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE "RTN","C0CLABS",200,0) . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC "RTN","C0CLABS",201,0) . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT "RTN","C0CLABS",202,0) . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1") "RTN","C0CLABS",203,0) . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC "RTN","C0CLABS",204,0) . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE "RTN","C0CLABS",205,0) . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC "RTN","C0CLABS",206,0) . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT "RTN","C0CLABS",207,0) . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT "RTN","C0CLABS",208,0) . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE "RTN","C0CLABS",209,0) . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME "RTN","C0CLABS",210,0) . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT "RTN","C0CLABS",211,0) . . E D ; NO SECONDARY, USE PRIMARY "RTN","C0CLABS",212,0) . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE "RTN","C0CLABS",213,0) . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME "RTN","C0CLABS",214,0) . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT "RTN","C0CLABS",215,0) . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; "RTN","C0CLABS",216,0) . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH "RTN","C0CLABS",217,0) . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE "RTN","C0CLABS",218,0) . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG "RTN","C0CLABS",219,0) . . S C0CZG=XV("RESULTTESTVALUE") "RTN","C0CLABS",220,0) . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH "RTN","C0CLABS",221,0) . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE "RTN","C0CLABS",222,0) . . S XV("RESULTTESTVALUE")=C0CZG "RTN","C0CLABS",223,0) . I C0CTYP="OBX" D ; PROCESS TEST RESULTS "RTN","C0CLABS",224,0) . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION "RTN","C0CLABS",225,0) . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS "RTN","C0CLABS",226,0) . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT "RTN","C0CLABS",227,0) . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT "RTN","C0CLABS",228,0) . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX "RTN","C0CLABS",229,0) . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE "RTN","C0CLABS",230,0) . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER "RTN","C0CLABS",231,0) . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 "RTN","C0CLABS",232,0) . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") "RTN","C0CLABS",233,0) . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT "RTN","C0CLABS",234,0) . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL "RTN","C0CLABS",235,0) . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME "RTN","C0CLABS",236,0) . . ; I 'C0CQT ZWR XV "RTN","C0CLABS",237,0) . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES "RTN","C0CLABS",238,0) . I 'C0CQT D ; "RTN","C0CLABS",239,0) . . W C0CI," ",C0CTYP,! "RTN","C0CLABS",240,0) . ; S C0CI=$O(@C0CHB@(C0CI)) "RTN","C0CLABS",241,0) ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") "RTN","C0CLABS",242,0) ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB "RTN","C0CLABS",243,0) Q "RTN","C0CLABS",244,0) LTYP(OSEG,OTYP,OVARA,OC0CQT) ; "RTN","C0CLABS",245,0) S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE "RTN","C0CLABS",246,0) I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT "RTN","C0CLABS",247,0) E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG "RTN","C0CLABS",248,0) I 1 D ; FOR HL7 SEGMENT TYPE "RTN","C0CLABS",249,0) . S OI="" ; INDEX INTO FIELDS IN SEG "RTN","C0CLABS",250,0) . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT "RTN","C0CLABS",251,0) . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX "RTN","C0CLABS",252,0) . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED "RTN","C0CLABS",253,0) . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE "RTN","C0CLABS",254,0) . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE "RTN","C0CLABS",255,0) . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX "RTN","C0CLABS",256,0) . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE "RTN","C0CLABS",257,0) . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE "RTN","C0CLABS",258,0) . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE "RTN","C0CLABS",259,0) . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! "RTN","C0CLABS",260,0) Q "RTN","C0CLABS",261,0) LOBX ; "RTN","C0CLABS",262,0) Q "RTN","C0CLABS",263,0) ; "RTN","C0CLABS",264,0) OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) "RTN","C0CLABS",265,0) N GA,GF,GD "RTN","C0CLABS",266,0) S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) "RTN","C0CLABS",267,0) S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" "RTN","C0CLABS",268,0) S GD=^TMP("C0CCCR","ODIR") "RTN","C0CLABS",269,0) W $$OUTPUT^C0CXPATH(GA,GF,GD) "RTN","C0CLABS",270,0) Q "RTN","C0CLABS",271,0) ; "RTN","C0CLABS",272,0) SETTBL ; "RTN","C0CLABS",273,0) K X ; CLEAR X "RTN","C0CLABS",274,0) S X("PID","PID1")="1^00104^Set ID - Patient ID" "RTN","C0CLABS",275,0) S X("PID","PID2")="2^00105^Patient ID (External ID)" "RTN","C0CLABS",276,0) S X("PID","PID3")="3^00106^Patient ID (Internal ID)" "RTN","C0CLABS",277,0) S X("PID","PID4")="4^00107^Alternate Patient ID" "RTN","C0CLABS",278,0) S X("PID","PID5")="5^00108^Patient's Name" "RTN","C0CLABS",279,0) S X("PID","PID6")="6^00109^Mother's Maiden Name" "RTN","C0CLABS",280,0) S X("PID","PID7")="7^00110^Date of Birth" "RTN","C0CLABS",281,0) S X("PID","PID8")="8^00111^Sex" "RTN","C0CLABS",282,0) S X("PID","PID9")="9^00112^Patient Alias" "RTN","C0CLABS",283,0) S X("PID","PID10")="10^00113^Race" "RTN","C0CLABS",284,0) S X("PID","PID11")="11^00114^Patient Address" "RTN","C0CLABS",285,0) S X("PID","PID12")="12^00115^County Code" "RTN","C0CLABS",286,0) S X("PID","PID13")="13^00116^Phone Number - Home" "RTN","C0CLABS",287,0) S X("PID","PID14")="14^00117^Phone Number - Business" "RTN","C0CLABS",288,0) S X("PID","PID15")="15^00118^Language - Patient" "RTN","C0CLABS",289,0) S X("PID","PID16")="16^00119^Marital Status" "RTN","C0CLABS",290,0) S X("PID","PID17")="17^00120^Religion" "RTN","C0CLABS",291,0) S X("PID","PID18")="18^00121^Patient Account Number" "RTN","C0CLABS",292,0) S X("PID","PID19")="19^00122^SSN Number - Patient" "RTN","C0CLABS",293,0) S X("PID","PID20")="20^00123^Drivers License - Patient" "RTN","C0CLABS",294,0) S X("PID","PID21")="21^00124^Mother's Identifier" "RTN","C0CLABS",295,0) S X("PID","PID22")="22^00125^Ethnic Group" "RTN","C0CLABS",296,0) S X("PID","PID23")="23^00126^Birth Place" "RTN","C0CLABS",297,0) S X("PID","PID24")="24^00127^Multiple Birth Indicator" "RTN","C0CLABS",298,0) S X("PID","PID25")="25^00128^Birth Order" "RTN","C0CLABS",299,0) S X("PID","PID26")="26^00129^Citizenship" "RTN","C0CLABS",300,0) S X("PID","PID27")="27^00130^Veteran.s Military Status" "RTN","C0CLABS",301,0) S X("PID","PID28")="28^00739^Nationality" "RTN","C0CLABS",302,0) S X("PID","PID29")="29^00740^Patient Death Date/Time" "RTN","C0CLABS",303,0) S X("PID","PID30")="30^00741^Patient Death Indicator" "RTN","C0CLABS",304,0) S X("NTE","NTE1")="1^00573^Set ID - NTE" "RTN","C0CLABS",305,0) S X("NTE","NTE2")="2^00574^Source of Comment" "RTN","C0CLABS",306,0) S X("NTE","NTE3")="3^00575^Comment" "RTN","C0CLABS",307,0) S X("ORC","ORC1")="1^00215^Order Control" "RTN","C0CLABS",308,0) S X("ORC","ORC2")="2^00216^Placer Order Number" "RTN","C0CLABS",309,0) S X("ORC","ORC3")="3^00217^Filler Order Number" "RTN","C0CLABS",310,0) S X("ORC","ORC4")="4^00218^Placer Order Number" "RTN","C0CLABS",311,0) S X("ORC","ORC5")="5^00219^Order Status" "RTN","C0CLABS",312,0) S X("ORC","ORC6")="6^00220^Response Flag" "RTN","C0CLABS",313,0) S X("ORC","ORC7")="7^00221^Quantity/Timing" "RTN","C0CLABS",314,0) S X("ORC","ORC8")="8^00222^Parent" "RTN","C0CLABS",315,0) S X("ORC","ORC9")="9^00223^Date/Time of Transaction" "RTN","C0CLABS",316,0) S X("ORC","ORC10")="10^00224^Entered By" "RTN","C0CLABS",317,0) S X("ORC","ORC11")="11^00225^Verified By" "RTN","C0CLABS",318,0) S X("ORC","ORC12")="12^00226^Ordering Provider" "RTN","C0CLABS",319,0) S X("ORC","ORC13")="13^00227^Enterer's Location" "RTN","C0CLABS",320,0) S X("ORC","ORC14")="14^00228^Call Back Phone Number" "RTN","C0CLABS",321,0) S X("ORC","ORC15")="15^00229^Order Effective Date/Time" "RTN","C0CLABS",322,0) S X("ORC","ORC16")="16^00230^Order Control Code Reason" "RTN","C0CLABS",323,0) S X("ORC","ORC17")="17^00231^Entering Organization" "RTN","C0CLABS",324,0) S X("ORC","ORC18")="18^00232^Entering Device" "RTN","C0CLABS",325,0) S X("ORC","ORC19")="19^00233^Action By" "RTN","C0CLABS",326,0) S X("OBR","OBR1")="1^00237^Set ID - Observation Request" "RTN","C0CLABS",327,0) S X("OBR","OBR2")="2^00216^Placer Order Number" "RTN","C0CLABS",328,0) S X("OBR","OBR3")="3^00217^Filler Order Number" "RTN","C0CLABS",329,0) S X("OBR","OBR4")="4^00238^Universal Service ID" "RTN","C0CLABS",330,0) S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" "RTN","C0CLABS",331,0) S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" "RTN","C0CLABS",332,0) S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" "RTN","C0CLABS",333,0) S X("OBR","OBR5")="5^00239^Priority" "RTN","C0CLABS",334,0) S X("OBR","OBR6")="6^00240^Requested Date/Time" "RTN","C0CLABS",335,0) S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" "RTN","C0CLABS",336,0) S X("OBR","OBR8")="8^00242^Observation End Date/Time" "RTN","C0CLABS",337,0) S X("OBR","OBR9")="9^00243^Collection Volume" "RTN","C0CLABS",338,0) S X("OBR","OBR10")="10^00244^Collector Identifier" "RTN","C0CLABS",339,0) S X("OBR","OBR11")="11^00245^Specimen Action Code" "RTN","C0CLABS",340,0) S X("OBR","OBR12")="12^00246^Danger Code" "RTN","C0CLABS",341,0) S X("OBR","OBR13")="13^00247^Relevant Clinical Info." "RTN","C0CLABS",342,0) S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" "RTN","C0CLABS",343,0) S X("OBR","OBR15")="15^00249^Specimen Source" "RTN","C0CLABS",344,0) S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" "RTN","C0CLABS",345,0) S X("OBR","OBR17")="17^00250^Order Callback Phone Number" "RTN","C0CLABS",346,0) S X("OBR","OBR18")="18^00251^Placers Field 1" "RTN","C0CLABS",347,0) S X("OBR","OBR19")="19^00252^Placers Field 2" "RTN","C0CLABS",348,0) S X("OBR","OBR20")="20^00253^Filler Field 1" "RTN","C0CLABS",349,0) S X("OBR","OBR21")="21^00254^Filler Field 2" "RTN","C0CLABS",350,0) S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" "RTN","C0CLABS",351,0) S X("OBR","OBR23")="23^00256^Charge to Practice" "RTN","C0CLABS",352,0) S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" "RTN","C0CLABS",353,0) S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" "RTN","C0CLABS",354,0) S X("OBR","OBR26")="26^00259^Parent Result" "RTN","C0CLABS",355,0) S X("OBR","OBR27")="27^00221^Quantity/Timing" "RTN","C0CLABS",356,0) S X("OBR","OBR28")="28^00260^Result Copies to" "RTN","C0CLABS",357,0) S X("OBR","OBR29")="29^00261^Parent Number" "RTN","C0CLABS",358,0) S X("OBR","OBR30")="30^00262^Transportation Mode" "RTN","C0CLABS",359,0) S X("OBR","OBR31")="31^00263^Reason for Study" "RTN","C0CLABS",360,0) S X("OBR","OBR32")="32^00264^Principal Result Interpreter" "RTN","C0CLABS",361,0) S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" "RTN","C0CLABS",362,0) S X("OBR","OBR34")="34^00266^Technician" "RTN","C0CLABS",363,0) S X("OBR","OBR35")="35^00267^Transcriptionist" "RTN","C0CLABS",364,0) S X("OBR","OBR36")="36^00268^Scheduled Date/Time" "RTN","C0CLABS",365,0) S X("OBR","OBR37")="37^01028^Number of Sample Containers" "RTN","C0CLABS",366,0) S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" "RTN","C0CLABS",367,0) S X("OBR","OBR39")="39^01030^Collector.s Comment" "RTN","C0CLABS",368,0) S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" "RTN","C0CLABS",369,0) S X("OBR","OBR41")="41^01032^Transport Arranged" "RTN","C0CLABS",370,0) S X("OBR","OBR42")="42^01033^Escort Required" "RTN","C0CLABS",371,0) S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" "RTN","C0CLABS",372,0) S X("OBX","OBX1")="1^00559^Set ID - OBX" "RTN","C0CLABS",373,0) S X("OBX","OBX2")="2^00676^Value Type" "RTN","C0CLABS",374,0) S X("OBX","OBX3")="3^00560^Observation Identifier" "RTN","C0CLABS",375,0) S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" "RTN","C0CLABS",376,0) S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" "RTN","C0CLABS",377,0) S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" "RTN","C0CLABS",378,0) S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" "RTN","C0CLABS",379,0) S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" "RTN","C0CLABS",380,0) S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" "RTN","C0CLABS",381,0) S X("OBX","OBX4")="4^00769^Observation Sub-Id" "RTN","C0CLABS",382,0) S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" "RTN","C0CLABS",383,0) S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" "RTN","C0CLABS",384,0) S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" "RTN","C0CLABS",385,0) S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" "RTN","C0CLABS",386,0) S X("OBX","OBX9")="9^00639^Probability" "RTN","C0CLABS",387,0) S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" "RTN","C0CLABS",388,0) S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" "RTN","C0CLABS",389,0) S X("OBX","OBX12")="12^00567^Date Last Normal Value" "RTN","C0CLABS",390,0) S X("OBX","OBX13")="13^00581^User Defined Access Checks" "RTN","C0CLABS",391,0) S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" "RTN","C0CLABS",392,0) S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" "RTN","C0CLABS",393,0) S X("OBX","OBX16")="16^00584^Responsible Observer" "RTN","C0CLABS",394,0) S X("OBX","OBX17")="17^00936^Observation Method" "RTN","C0CLABS",395,0) K ^TMP("C0CCCR","LABTBL") "RTN","C0CLABS",396,0) M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL "RTN","C0CLABS",397,0) S ^TMP("C0CCCR","LABTBL",0)="V3" "RTN","C0CLABS",398,0) Q "RTN","C0CLABS",399,0) ; "RTN","C0CMAIL") 0^27^B92791623 "RTN","C0CMAIL",1,0) C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr "RTN","C0CMAIL",2,0) V ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CMAIL",3,0) ;Copyright 2011 Chris Richardson, Richardson Computer Research "RTN","C0CMAIL",4,0) ; Modified 3110516@1818 "RTN","C0CMAIL",5,0) ; rcr@rcresearch.us "RTN","C0CMAIL",6,0) ; Licensed under the terms of the GNU "RTN","C0CMAIL",7,0) ;General Public License See attached copy of the License. "RTN","C0CMAIL",8,0) ; "RTN","C0CMAIL",9,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CMAIL",10,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CMAIL",11,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CMAIL",12,0) ;(at your option) any later version. "RTN","C0CMAIL",13,0) ; "RTN","C0CMAIL",14,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CMAIL",15,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMAIL",16,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMAIL",17,0) ;GNU General Public License for more details. "RTN","C0CMAIL",18,0) ; "RTN","C0CMAIL",19,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CMAIL",20,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMAIL",21,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMAIL",22,0) ; "RTN","C0CMAIL",23,0) ; ------------------ "RTN","C0CMAIL",24,0) ;Entry Points "RTN","C0CMAIL",25,0) ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) "RTN","C0CMAIL",26,0) ; Input: "RTN","C0CMAIL",27,0) ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL "RTN","C0CMAIL",28,0) ; or "*" for all boxes, default is "IN" if missing]" "RTN","C0CMAIL",29,0) ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", "RTN","C0CMAIL",30,0) ; "*" for All or 9,999 maximum "RTN","C0CMAIL",31,0) ; MALL?1.n = that number of the n most recent "RTN","C0CMAIL",32,0) ; Internally: "RTN","C0CMAIL",33,0) ; BNAM = Box Name "RTN","C0CMAIL",34,0) ; Output: "RTN","C0CMAIL",35,0) ; C0CDATA "RTN","C0CMAIL",36,0) ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket "RTN","C0CMAIL",37,0) ; (BNAM,"MSG",C0CIEN,"FROM")=Name "RTN","C0CMAIL",38,0) ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address "RTN","C0CMAIL",39,0) ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address "RTN","C0CMAIL",40,0) ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title "RTN","C0CMAIL",41,0) ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments "RTN","C0CMAIL",42,0) ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text "RTN","C0CMAIL",43,0) ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text "RTN","C0CMAIL",44,0) ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes "RTN","C0CMAIL",45,0) ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) "RTN","C0CMAIL",46,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line "RTN","C0CMAIL",47,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details "RTN","C0CMAIL",48,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data "RTN","C0CMAIL",49,0) ; "RTN","C0CMAIL",50,0) ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments "RTN","C0CMAIL",51,0) ; Input; "RTN","C0CMAIL",52,0) ; D0 - The IEN for the message in file 3.9, MESSAGE global "RTN","C0CMAIL",53,0) ; Output "RTN","C0CMAIL",54,0) ; OUTBF - The array of your choice to save the expanded and decoded message. "RTN","C0CMAIL",55,0) ; "RTN","C0CMAIL",56,0) GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data "RTN","C0CMAIL",57,0) K:'$G(C0CDATA("KEEP")) C0CDATA "RTN","C0CMAIL",58,0) N U "RTN","C0CMAIL",59,0) S U="^" "RTN","C0CMAIL",60,0) D:$G(C0CINPUT) "RTN","C0CMAIL",61,0) . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL "RTN","C0CMAIL",62,0) . S INPUT=C0CINPUT "RTN","C0CMAIL",63,0) . S DUZ=+INPUT "RTN","C0CMAIL",64,0) . D:$D(^XMB(3.7,DUZ,0))#2 "RTN","C0CMAIL",65,0) . . S MBLST=$P(INPUT,";",2) "RTN","C0CMAIL",66,0) . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag "RTN","C0CMAIL",67,0) . . S:MALL["*" MALL=99999 "RTN","C0CMAIL",68,0) . . ; Only one of these can be correct "RTN","C0CMAIL",69,0) . . D "RTN","C0CMAIL",70,0) . . . ; If nul, make it "IN" only "RTN","C0CMAIL",71,0) . . . I MBLST="" D QUIT "RTN","C0CMAIL",72,0) . . . . S MBLST("IN")=0,I=0 "RTN","C0CMAIL",73,0) . . . . D GATHER(DUZ,"IN",.LST) "RTN","C0CMAIL",74,0) . . . .QUIT "RTN","C0CMAIL",75,0) . . . ; "RTN","C0CMAIL",76,0) . . . ; If "*", Get all Mailboxes and look for New Messages "RTN","C0CMAIL",77,0) . . . I MBLST["*" D QUIT "RTN","C0CMAIL",78,0) . . . . N NAM,NUM "RTN","C0CMAIL",79,0) . . . . S NUM=0 "RTN","C0CMAIL",80,0) . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D "RTN","C0CMAIL",81,0) . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) "RTN","C0CMAIL",82,0) . . . . . D GATHER(DUZ,NAM,.LST) "RTN","C0CMAIL",83,0) . . . . .QUIT "RTN","C0CMAIL",84,0) . . . .QUIT "RTN","C0CMAIL",85,0) . . . ; "RTN","C0CMAIL",86,0) . . . ; If comma separated, look for mailboxes with new messages "RTN","C0CMAIL",87,0) . . . I $L(MBLST,",")>1 D QUIT "RTN","C0CMAIL",88,0) . . . . S NAM="" "RTN","C0CMAIL",89,0) . . . . N T,V "RTN","C0CMAIL",90,0) . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D "RTN","C0CMAIL",91,0) . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) "RTN","C0CMAIL",92,0) . . . . . S:NAM="" NAM=V "RTN","C0CMAIL",93,0) . . . . . D GATHER(DUZ,NAM,.LST) "RTN","C0CMAIL",94,0) . . . . .QUIT "RTN","C0CMAIL",95,0) . . . .QUIT "RTN","C0CMAIL",96,0) . . . ; "RTN","C0CMAIL",97,0) . . . ; If only 1 mailbox named, go get it "RTN","C0CMAIL",98,0) . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT "RTN","C0CMAIL",99,0) . . .QUIT "RTN","C0CMAIL",100,0) . . MERGE C0CDATA=LST "RTN","C0CMAIL",101,0) . .QUIT "RTN","C0CMAIL",102,0) .QUIT "RTN","C0CMAIL",103,0) QUIT "RTN","C0CMAIL",104,0) ; =================== "RTN","C0CMAIL",105,0) GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail "RTN","C0CMAIL",106,0) N I,J,K,L "RTN","C0CMAIL",107,0) S (I,K)=0 "RTN","C0CMAIL",108,0) S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) "RTN","C0CMAIL",109,0) F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D "RTN","C0CMAIL",110,0) . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) "RTN","C0CMAIL",111,0) . D ; :L "RTN","C0CMAIL",112,0) . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails "RTN","C0CMAIL",113,0) . . S LST(NAM,"MSG",I)=L "RTN","C0CMAIL",114,0) . . D GETTYP(I) "RTN","C0CMAIL",115,0) . .QUIT "RTN","C0CMAIL",116,0) .QUIT "RTN","C0CMAIL",117,0) S LST(NAM,"NUMBER")=K "RTN","C0CMAIL",118,0) QUIT "RTN","C0CMAIL",119,0) ; =================== "RTN","C0CMAIL",120,0) ; D0 is the IEN into the Message Global ^XMB(3.9,D0) "RTN","C0CMAIL",121,0) ; The products of these emails are scanned to identify "RTN","C0CMAIL",122,0) ; the number of documents stored in the MIME package. "RTN","C0CMAIL",123,0) ; The protocol runs like this; "RTN","C0CMAIL",124,0) ; Line 1 is the --separator "RTN","C0CMAIL",125,0) ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD "RTN","C0CMAIL",126,0) ; Line n+2 thru t-1 where t does NOT have "Content-" "RTN","C0CMAIL",127,0) ; Line t is Next Section Terminator, or Message Terminator, --separator "RTN","C0CMAIL",128,0) ; Line t+1 should not exist in the data set if Message Terminator "RTN","C0CMAIL",129,0) ; CON = "Content-" "RTN","C0CMAIL",130,0) ; FLG = "--" "RTN","C0CMAIL",131,0) ; SEP = FLG+7 or more characters ; Separator "RTN","C0CMAIL",132,0) ; END = SEP+FLG "RTN","C0CMAIL",133,0) ; SGC = Segment Count "RTN","C0CMAIL",134,0) ; Note: separator is a string of specific characters of "RTN","C0CMAIL",135,0) ; indeterminate length "RTN","C0CMAIL",136,0) ; LST() the transfer array "RTN","C0CMAIL",137,0) ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line "RTN","C0CMAIL",138,0) ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data "RTN","C0CMAIL",139,0) ; "RTN","C0CMAIL",140,0) GETTYP(D0) ; Look for the goodies in the Mail "RTN","C0CMAIL",141,0) N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM "RTN","C0CMAIL",142,0) S CON="Content-" "RTN","C0CMAIL",143,0) S FLG="--" "RTN","C0CMAIL",144,0) S SEP="" ; Start SEP as null, so we can use this to help identify the type "RTN","C0CMAIL",145,0) S (BCN,CNT,D1,END,SGC)=0 "RTN","C0CMAIL",146,0) S XX=$G(^XMB(3.9,D0,0)) "RTN","C0CMAIL",147,0) S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) "RTN","C0CMAIL",148,0) S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) "RTN","C0CMAIL",149,0) F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) "RTN","C0CMAIL",150,0) S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) "RTN","C0CMAIL",151,0) S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) "RTN","C0CMAIL",152,0) ; Get the folks the email is sent to. "RTN","C0CMAIL",153,0) S D1=0 "RTN","C0CMAIL",154,0) F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D "RTN","C0CMAIL",155,0) . N T "RTN","C0CMAIL",156,0) . S T=+$G(^XMB(3.9,D0,1,D1,0)) "RTN","C0CMAIL",157,0) . S:T T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL",158,0) . S LST("TO",D1)=T "RTN","C0CMAIL",159,0) . S T=$G(^XMB(3.9,D0,6,D1,0)) "RTN","C0CMAIL",160,0) . S:T T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL",161,0) . S:T="" T="" "RTN","C0CMAIL",162,0) . S LST("TO NAME",D1)=T "RTN","C0CMAIL",163,0) .QUIT "RTN","C0CMAIL",164,0) ; Preload first Segment (0) with beginning on Line 1 "RTN","C0CMAIL",165,0) ; if not a 64bit "RTN","C0CMAIL",166,0) S LST(NAM,"MSG",D0,"SEG",0)=1 "RTN","C0CMAIL",167,0) S D1=.9999,SEP="--" "RTN","C0CMAIL",168,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL",169,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL",170,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL",171,0) . ; Enter once to set the SEP to capture the separator "RTN","C0CMAIL",172,0) . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q "RTN","C0CMAIL",173,0) . . S SEP=X,END=X_FLG "RTN","C0CMAIL",174,0) . . S (CNT,SGC)=1,BCN=0 "RTN","C0CMAIL",175,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 "RTN","C0CMAIL",176,0) . .QUIT "RTN","C0CMAIL",177,0) . ; "RTN","C0CMAIL",178,0) . ; A new separator is set, process original "RTN","C0CMAIL",179,0) . I X=SEP D QUIT "RTN","C0CMAIL",180,0) . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN "RTN","C0CMAIL",181,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) "RTN","C0CMAIL",182,0) . . S SGC=SGC+1,BCN=0 "RTN","C0CMAIL",183,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 "RTN","C0CMAIL",184,0) . .QUIT "RTN","C0CMAIL",185,0) . ; "RTN","C0CMAIL",186,0) . S BCN=BCN+$L(X) "RTN","C0CMAIL",187,0) . I X[CON D Q "RTN","C0CMAIL",188,0) . . S J=$P($P(X,";"),CON,2) "RTN","C0CMAIL",189,0) . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) "RTN","C0CMAIL",190,0) . .QUIT "RTN","C0CMAIL",191,0) . ; "RTN","C0CMAIL",192,0) . ; S LST(NAM,"MSG",D0,"SEG",D1)=X "RTN","C0CMAIL",193,0) .QUIT "RTN","C0CMAIL",194,0) QUIT "RTN","C0CMAIL",195,0) ; =================== "RTN","C0CMAIL",196,0) NAME(NM) ; Return the name of the Sender "RTN","C0CMAIL",197,0) N NAME "RTN","C0CMAIL",198,0) S NAME="" "RTN","C0CMAIL",199,0) D "RTN","C0CMAIL",200,0) . ; Look first for a value to use with the NEW PERSON file "RTN","C0CMAIL",201,0) . ; "RTN","C0CMAIL",202,0) . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q "RTN","C0CMAIL",203,0) . ; "RTN","C0CMAIL",204,0) . I $L(NM) S NAME=NM Q "RTN","C0CMAIL",205,0) . ; "RTN","C0CMAIL",206,0) . ; Else, pull the data from the message and display the foreign source "RTN","C0CMAIL",207,0) . ; of the message. "RTN","C0CMAIL",208,0) . N T "RTN","C0CMAIL",209,0) . S VAL=$G(^XMB(3.9,D0,.7)) "RTN","C0CMAIL",210,0) . S:VAL T=$P(^VA(200,VAL,0),U) "RTN","C0CMAIL",211,0) . I $L($G(T)) S NAME=T Q "RTN","C0CMAIL",212,0) . ; "RTN","C0CMAIL",213,0) .QUIT "RTN","C0CMAIL",214,0) QUIT NAME "RTN","C0CMAIL",215,0) ; =================== "RTN","C0CMAIL",216,0) TIME(Y) ; The time and date of the sending "RTN","C0CMAIL",217,0) X ^DD("DD") "RTN","C0CMAIL",218,0) QUIT Y "RTN","C0CMAIL",219,0) ; =================== "RTN","C0CMAIL",220,0) ; Segments in Message need to be identified and decoded properly "RTN","C0CMAIL",221,0) ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message "RTN","C0CMAIL",222,0) ; ARRAY will have the details of this one call "RTN","C0CMAIL",223,0) ; "RTN","C0CMAIL",224,0) ; Inputs; "RTN","C0CMAIL",225,0) ; C0CINPUT - The IEN of the message to expand "RTN","C0CMAIL",226,0) ; Outputs; "RTN","C0CMAIL",227,0) ; C0CDATA - Carrier for the returned structure of the Message "RTN","C0CMAIL",228,0) ; C0CDATA(D0,"SEG")=number of SEGMENTS "RTN","C0CMAIL",229,0) ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details "RTN","C0CMAIL",230,0) ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details "RTN","C0CMAIL",231,0) ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details "RTN","C0CMAIL",232,0) ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details "RTN","C0CMAIL",233,0) ; "RTN","C0CMAIL",234,0) DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery "RTN","C0CMAIL",235,0) N LST,D0,D1,U "RTN","C0CMAIL",236,0) S U="^" "RTN","C0CMAIL",237,0) S D0=+$G(C0CINPUT) "RTN","C0CMAIL",238,0) I D0 D QUIT "RTN","C0CMAIL",239,0) . D GETTYP2(D0) "RTN","C0CMAIL",240,0) . I $D(LST) M C0CDATA(D0)=LST "RTN","C0CMAIL",241,0) .QUIT "RTN","C0CMAIL",242,0) QUIT "RTN","C0CMAIL",243,0) ; =================== "RTN","C0CMAIL",244,0) ; End note if needed "RTN","C0CMAIL",245,0) ; MSK - Set of characters that do not exist in 64 bit encoding "RTN","C0CMAIL",246,0) GETTYP2(D0) ; Try to get the types and MSK for the "RTN","C0CMAIL",247,0) N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM "RTN","C0CMAIL",248,0) S CON="Content-",U="^" "RTN","C0CMAIL",249,0) S FLG="--" "RTN","C0CMAIL",250,0) S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" "RTN","C0CMAIL",251,0) S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type "RTN","C0CMAIL",252,0) S (BCN,CNT,D1,END,SGC)=0 "RTN","C0CMAIL",253,0) S XX=$G(^XMB(3.9,D0,0)) "RTN","C0CMAIL",254,0) ; S K=$P(^XMB(3.9,D0,2,0),U,3) "RTN","C0CMAIL",255,0) S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) "RTN","C0CMAIL",256,0) S LST("CREATED")=$$TIME($P(XX,U,3)) "RTN","C0CMAIL",257,0) F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) "RTN","C0CMAIL",258,0) S LST("FROM")=$$NAME(XXNM) "RTN","C0CMAIL",259,0) ; Get the folks the email is sent to. "RTN","C0CMAIL",260,0) S D1=0 "RTN","C0CMAIL",261,0) F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" "RTN","C0CMAIL",262,0) . N I,T "RTN","C0CMAIL",263,0) . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) "RTN","C0CMAIL",264,0) . S:T T=$P($G(^VA(200,T,0)),"^") "RTN","C0CMAIL",265,0) . S LST("TO",+D1)=T "RTN","C0CMAIL",266,0) . S T=$G(^XMB(3.9,D0,6,+D1,0)) "RTN","C0CMAIL",267,0) . S:T="" T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL",268,0) . S:T="" T="" "RTN","C0CMAIL",269,0) . S LST("TO NAME",D1)=T "RTN","C0CMAIL",270,0) .QUIT "RTN","C0CMAIL",271,0) ; Get the Header for the message "RTN","C0CMAIL",272,0) S D1=0 "RTN","C0CMAIL",273,0) F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D "RTN","C0CMAIL",274,0) . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) "RTN","C0CMAIL",275,0) .QUIT "RTN","C0CMAIL",276,0) ; Start walking the different sections "RTN","C0CMAIL",277,0) S D1=.99999,SEP="--" "RTN","C0CMAIL",278,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL",279,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL",280,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL",281,0) . ; Enter once to set the SEP to capture the separator "RTN","C0CMAIL",282,0) . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q "RTN","C0CMAIL",283,0) . . S SEP=X,END=X_FLG "RTN","C0CMAIL",284,0) . . S (CNT,SGC)=1,BCN=0 "RTN","C0CMAIL",285,0) . . S LST("SEG",SGC)=D1 "RTN","C0CMAIL",286,0) . .QUIT "RTN","C0CMAIL",287,0) . ; "RTN","C0CMAIL",288,0) . ; A new SEGMENT separator is set, process original "RTN","C0CMAIL",289,0) . I X=SEP D QUIT "RTN","C0CMAIL",290,0) . . ; Save Current Values "RTN","C0CMAIL",291,0) . . S LST("SEG",SGC,"SIZE")=BCN "RTN","C0CMAIL",292,0) . . ; Close this Segment and prepare to start a New Segment "RTN","C0CMAIL",293,0) . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) "RTN","C0CMAIL",294,0) . . ; Put the result in LST("SEG",SGC,"XML") "RTN","C0CMAIL",295,0) . . I $L(BF) D "RTN","C0CMAIL",296,0) . . . S ZN=1 "RTN","C0CMAIL",297,0) . . . N I,T,TBF "RTN","C0CMAIL",298,0) . . . S TBF=BF "RTN","C0CMAIL",299,0) . . . F I=1:1:($L(TBF,"=")) D "RTN","C0CMAIL",300,0) . . . . S BF=$P(TBF,"=",I)_"=" "RTN","C0CMAIL",301,0) . . . . I BF'="=" D DECODER "RTN","C0CMAIL",302,0) . . . .QUIT "RTN","C0CMAIL",303,0) . . . S BF="" "RTN","C0CMAIL",304,0) . . .QUIT "RTN","C0CMAIL",305,0) . . S SGC=SGC+1,BCN=0 "RTN","C0CMAIL",306,0) . . ; Incriment SGC to start a new Segment "RTN","C0CMAIL",307,0) . . S LST("SEG",SGC)=D1 "RTN","C0CMAIL",308,0) . .QUIT "RTN","C0CMAIL",309,0) . ; "RTN","C0CMAIL",310,0) . ; Accumulate the 64 bit encoding "RTN","C0CMAIL",311,0) . I X=$TR(X,MSK)&$L(X) D Q "RTN","C0CMAIL",312,0) . . S BF=BF_X "RTN","C0CMAIL",313,0) . . S BCN=BCN+$L(X) "RTN","C0CMAIL",314,0) . .QUIT "RTN","C0CMAIL",315,0) . ; "RTN","C0CMAIL",316,0) . ; Ending Condition, close out the Segment "RTN","C0CMAIL",317,0) . I X=END D QUIT "RTN","C0CMAIL",318,0) . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) "RTN","C0CMAIL",319,0) . . I $L(BF) S ZN=1 D DECODER S BF="" Q "RTN","C0CMAIL",320,0) . .QUIT "RTN","C0CMAIL",321,0) . ; "RTN","C0CMAIL",322,0) . S BCN=BCN+$L(X) "RTN","C0CMAIL",323,0) . ; Split out the Content Info "RTN","C0CMAIL",324,0) . I X[CON D Q "RTN","C0CMAIL",325,0) . . S J=$P(X,CON,2) "RTN","C0CMAIL",326,0) . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) "RTN","C0CMAIL",327,0) . .QUIT "RTN","C0CMAIL",328,0) . ; "RTN","C0CMAIL",329,0) . ; Everything else is Text "RTN","C0CMAIL",330,0) . S LST("SEG",SGC,"TXT",D1)=X "RTN","C0CMAIL",331,0) .QUIT "RTN","C0CMAIL",332,0) QUIT "RTN","C0CMAIL",333,0) ; =================== "RTN","C0CMAIL",334,0) ; Break down the Buffer Array so it can be saved. "RTN","C0CMAIL",335,0) ; BF is passed in. "RTN","C0CMAIL",336,0) DECODER ; "RTN","C0CMAIL",337,0) N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE "RTN","C0CMAIL",338,0) S ZBF=BF "RTN","C0CMAIL",339,0) ; Full Buffer, BF, now check for Encryption and Unpack "RTN","C0CMAIL",340,0) F RCNT=1:1:$L(ZBF,"=") D "RTN","C0CMAIL",341,0) . N BF "RTN","C0CMAIL",342,0) . S BF=$P(ZBF,"=",RCNT) "RTN","C0CMAIL",343,0) . ; Unpacking the 64 bit encoding "RTN","C0CMAIL",344,0) . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) "RTN","C0CMAIL",345,0) . D:$L(TBF) "RTN","C0CMAIL",346,0) . . N XBF "RTN","C0CMAIL",347,0) . . S BF=BF_"=" "RTN","C0CMAIL",348,0) . . D NORMAL(.XBF,.TBF) "RTN","C0CMAIL",349,0) . . M LST("SEG",SGC,"XML",RCNT)=XBF "RTN","C0CMAIL",350,0) . .QUIT "RTN","C0CMAIL",351,0) .QUIT "RTN","C0CMAIL",352,0) QUIT "RTN","C0CMAIL",353,0) ; =================== "RTN","C0CMAIL",354,0) ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT "RTN","C0CMAIL",355,0) ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT "RTN","C0CMAIL",356,0) ; >D NORMAL^C0CMAIL(.OUT,BF) "RTN","C0CMAIL",357,0) NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML "RTN","C0CMAIL",358,0) ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME "RTN","C0CMAIL",359,0) ; "RTN","C0CMAIL",360,0) N ZN,OUTBF "RTN","C0CMAIL",361,0) S ZN=1 "RTN","C0CMAIL",362,0) S OUTBF(ZN)=$P(INXML,"><",ZN)_">" "RTN","C0CMAIL",363,0) F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; "RTN","C0CMAIL",364,0) . S OUTBF(ZN)=OUTBF(ZN)_">" "RTN","C0CMAIL",365,0) .QUIT "RTN","C0CMAIL",366,0) M OUTXML=OUTBF "RTN","C0CMAIL",367,0) QUIT "RTN","C0CMAIL",368,0) ; =================== "RTN","C0CMAIL",369,0) ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv "RTN","C0CMAIL",370,0) ; End note if needed "RTN","C0CMAIL",371,0) QUIT "RTN","C0CMAIL",372,0) ; =================== "RTN","C0CMAIL2") 0^28^B166788068 "RTN","C0CMAIL2",1,0) C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr "RTN","C0CMAIL2",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CMAIL2",3,0) ;Copyright 2011 Chris Richardson, Richardson Computer Research "RTN","C0CMAIL2",4,0) ; Modified 3110615@1040 "RTN","C0CMAIL2",5,0) ; rcr@rcresearch.us "RTN","C0CMAIL2",6,0) ; Licensed under the terms of the GNU "RTN","C0CMAIL2",7,0) ;General Public License See attached copy of the License. "RTN","C0CMAIL2",8,0) ; "RTN","C0CMAIL2",9,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CMAIL2",10,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CMAIL2",11,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CMAIL2",12,0) ;(at your option) any later version. "RTN","C0CMAIL2",13,0) ; "RTN","C0CMAIL2",14,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CMAIL2",15,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMAIL2",16,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMAIL2",17,0) ;GNU General Public License for more details. "RTN","C0CMAIL2",18,0) ; "RTN","C0CMAIL2",19,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CMAIL2",20,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMAIL2",21,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMAIL2",22,0) ; "RTN","C0CMAIL2",23,0) ; ------------------ "RTN","C0CMAIL2",24,0) ;Entry Points "RTN","C0CMAIL2",25,0) ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments "RTN","C0CMAIL2",26,0) ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) "RTN","C0CMAIL2",27,0) ; Input: "RTN","C0CMAIL2",28,0) ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL "RTN","C0CMAIL2",29,0) ; or "*" for all boxes, default is "IN" if missing]" "RTN","C0CMAIL2",30,0) ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", "RTN","C0CMAIL2",31,0) ; "*" for All or 9,999 maximum "RTN","C0CMAIL2",32,0) ; MALL?1.n = that number of the n most recent "RTN","C0CMAIL2",33,0) ; Internally: "RTN","C0CMAIL2",34,0) ; BNAM = Box Name "RTN","C0CMAIL2",35,0) ; Output: "RTN","C0CMAIL2",36,0) ; C0CDATA "RTN","C0CMAIL2",37,0) ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket "RTN","C0CMAIL2",38,0) ; (BNAM,"MSG",C0CIEN,"FROM")=Name "RTN","C0CMAIL2",39,0) ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address "RTN","C0CMAIL2",40,0) ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address "RTN","C0CMAIL2",41,0) ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title "RTN","C0CMAIL2",42,0) ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments "RTN","C0CMAIL2",43,0) ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text "RTN","C0CMAIL2",44,0) ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text "RTN","C0CMAIL2",45,0) ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes "RTN","C0CMAIL2",46,0) ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) "RTN","C0CMAIL2",47,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line "RTN","C0CMAIL2",48,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details "RTN","C0CMAIL2",49,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data "RTN","C0CMAIL2",50,0) ; "RTN","C0CMAIL2",51,0) ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments "RTN","C0CMAIL2",52,0) ; Input; "RTN","C0CMAIL2",53,0) ; D0 - The IEN for the message in file 3.9, MESSAGE global "RTN","C0CMAIL2",54,0) ; Output "RTN","C0CMAIL2",55,0) ; OUTBF - The array of your choice to save the expanded and decoded message. "RTN","C0CMAIL2",56,0) ; "RTN","C0CMAIL2",57,0) GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data "RTN","C0CMAIL2",58,0) K:'$G(C0CDATA("KEEP")) C0CDATA "RTN","C0CMAIL2",59,0) N U "RTN","C0CMAIL2",60,0) S U="^" "RTN","C0CMAIL2",61,0) D:$G(C0CINPUT) "RTN","C0CMAIL2",62,0) . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL "RTN","C0CMAIL2",63,0) . S INPUT=C0CINPUT "RTN","C0CMAIL2",64,0) . S DUZ=+INPUT "RTN","C0CMAIL2",65,0) . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q "RTN","C0CMAIL2",66,0) . ; "RTN","C0CMAIL2",67,0) . D:$D(^XMB(3.7,DUZ,0))#2 "RTN","C0CMAIL2",68,0) . . S MBLST=$P(INPUT,";",2) "RTN","C0CMAIL2",69,0) . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag "RTN","C0CMAIL2",70,0) . . S:MALL["*" MALL=99999 "RTN","C0CMAIL2",71,0) . . ; Only one of these can be correct "RTN","C0CMAIL2",72,0) . . D "RTN","C0CMAIL2",73,0) . . . ; If nul, make it "IN" only "RTN","C0CMAIL2",74,0) . . . I MBLST="" D QUIT "RTN","C0CMAIL2",75,0) . . . . S MBLST("IN")=0,I=0 "RTN","C0CMAIL2",76,0) . . . . D GATHER(DUZ,"IN",.LST) "RTN","C0CMAIL2",77,0) . . . .QUIT "RTN","C0CMAIL2",78,0) . . . ; "RTN","C0CMAIL2",79,0) . . . ; If "*", Get all Mailboxes and look for New Messages "RTN","C0CMAIL2",80,0) . . . I MBLST["*" D QUIT "RTN","C0CMAIL2",81,0) . . . . N NAM,NUM "RTN","C0CMAIL2",82,0) . . . . S NUM=0 "RTN","C0CMAIL2",83,0) . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D "RTN","C0CMAIL2",84,0) . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) "RTN","C0CMAIL2",85,0) . . . . . D GATHER(DUZ,NAM,.LST) "RTN","C0CMAIL2",86,0) . . . . .QUIT "RTN","C0CMAIL2",87,0) . . . .QUIT "RTN","C0CMAIL2",88,0) . . . ; "RTN","C0CMAIL2",89,0) . . . ; If comma separated, look for mailboxes with new messages "RTN","C0CMAIL2",90,0) . . . I $L(MBLST,",")>1 D QUIT "RTN","C0CMAIL2",91,0) . . . . S NAM="" "RTN","C0CMAIL2",92,0) . . . . N TN,V "RTN","C0CMAIL2",93,0) . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D "RTN","C0CMAIL2",94,0) . . . . . I $L(V) D QUIT "RTN","C0CMAIL2",95,0) . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) "RTN","C0CMAIL2",96,0) . . . . . . S:NAM="" NAM=V "RTN","C0CMAIL2",97,0) . . . . . . D GATHER(DUZ,NAM,.LST) "RTN","C0CMAIL2",98,0) . . . . . .QUIT "RTN","C0CMAIL2",99,0) . . . . . ; "RTN","C0CMAIL2",100,0) . . . . . D ERROR("ER08") "RTN","C0CMAIL2",101,0) . . . . .QUIT "RTN","C0CMAIL2",102,0) . . . .QUIT "RTN","C0CMAIL2",103,0) . . . ; "RTN","C0CMAIL2",104,0) . . . ; If only 1 mailbox named, go get it "RTN","C0CMAIL2",105,0) . . . I $L(MBLST) D QUIT "RTN","C0CMAIL2",106,0) . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT "RTN","C0CMAIL2",107,0) . . . . ; "RTN","C0CMAIL2",108,0) . . . . D ERROR("ER07") "RTN","C0CMAIL2",109,0) . . .QUIT "RTN","C0CMAIL2",110,0) . . MERGE C0CDATA=LST "RTN","C0CMAIL2",111,0) . .QUIT "RTN","C0CMAIL2",112,0) .QUIT "RTN","C0CMAIL2",113,0) QUIT "RTN","C0CMAIL2",114,0) ; =================== "RTN","C0CMAIL2",115,0) GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail "RTN","C0CMAIL2",116,0) N I,J,K,L "RTN","C0CMAIL2",117,0) S (I,K)=0 "RTN","C0CMAIL2",118,0) S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) "RTN","C0CMAIL2",119,0) F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D "RTN","C0CMAIL2",120,0) . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) "RTN","C0CMAIL2",121,0) . D ; :L "RTN","C0CMAIL2",122,0) . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails "RTN","C0CMAIL2",123,0) . . S LST(NAM,"MSG",I)=L "RTN","C0CMAIL2",124,0) . . D GETTYP(I) "RTN","C0CMAIL2",125,0) . .QUIT "RTN","C0CMAIL2",126,0) .QUIT "RTN","C0CMAIL2",127,0) S LST(NAM,"NUMBER")=K "RTN","C0CMAIL2",128,0) QUIT "RTN","C0CMAIL2",129,0) ; =================== "RTN","C0CMAIL2",130,0) ; D0 is the IEN into the Message Global ^XMB(3.9,D0) "RTN","C0CMAIL2",131,0) ; The products of these emails are scanned to identify "RTN","C0CMAIL2",132,0) ; the number of documents stored in the MIME package. "RTN","C0CMAIL2",133,0) ; The protocol runs like this; "RTN","C0CMAIL2",134,0) ; Line 1 is the --separator "RTN","C0CMAIL2",135,0) ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD "RTN","C0CMAIL2",136,0) ; Line n+2 thru t-1 where t does NOT have "Content-" "RTN","C0CMAIL2",137,0) ; Line t is Next Section Terminator, or Message Terminator, --separator "RTN","C0CMAIL2",138,0) ; Line t+1 should not exist in the data set if Message Terminator "RTN","C0CMAIL2",139,0) ; CON = "Content-" "RTN","C0CMAIL2",140,0) ; FLG = "--" "RTN","C0CMAIL2",141,0) ; SEP = FLG+7 or more characters ; Separator "RTN","C0CMAIL2",142,0) ; END = SEP+FLG "RTN","C0CMAIL2",143,0) ; SGC = Segment Count "RTN","C0CMAIL2",144,0) ; Note: separator is a string of specific characters of "RTN","C0CMAIL2",145,0) ; indeterminate length "RTN","C0CMAIL2",146,0) ; LST() the transfer array "RTN","C0CMAIL2",147,0) ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line "RTN","C0CMAIL2",148,0) ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data "RTN","C0CMAIL2",149,0) ; "RTN","C0CMAIL2",150,0) GETTYP(D0) ; Look for the goodies in the Mail "RTN","C0CMAIL2",151,0) N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM "RTN","C0CMAIL2",152,0) S CON="Content-" "RTN","C0CMAIL2",153,0) S FLG="--" "RTN","C0CMAIL2",154,0) S SEP="" ; Start SEP as null, so we can use this to help identify the type "RTN","C0CMAIL2",155,0) S (BCN,CNT,D1,END,SGC)=0 "RTN","C0CMAIL2",156,0) S XX=$G(^XMB(3.9,D0,0)) "RTN","C0CMAIL2",157,0) S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) "RTN","C0CMAIL2",158,0) S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) "RTN","C0CMAIL2",159,0) F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) "RTN","C0CMAIL2",160,0) S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) "RTN","C0CMAIL2",161,0) S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) "RTN","C0CMAIL2",162,0) ; Get the folks the email is sent to. "RTN","C0CMAIL2",163,0) S D1=0 "RTN","C0CMAIL2",164,0) F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D "RTN","C0CMAIL2",165,0) . N T "RTN","C0CMAIL2",166,0) . S T=+$G(^XMB(3.9,D0,1,D1,0)) "RTN","C0CMAIL2",167,0) . S:T T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL2",168,0) . S LST("TO",D1)=T "RTN","C0CMAIL2",169,0) . S T=$G(^XMB(3.9,D0,6,D1,0)) "RTN","C0CMAIL2",170,0) . S:T T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL2",171,0) . S:T="" T="" "RTN","C0CMAIL2",172,0) . S LST("TO NAME",D1)=T "RTN","C0CMAIL2",173,0) .QUIT "RTN","C0CMAIL2",174,0) ; Preload first Segment (0) with beginning on Line 1 "RTN","C0CMAIL2",175,0) ; if not a 64bit "RTN","C0CMAIL2",176,0) S LST(NAM,"MSG",D0,"SEG",0)=1 "RTN","C0CMAIL2",177,0) S D1=.9999,SEP="@@" "RTN","C0CMAIL2",178,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL2",179,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL2",180,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL2",181,0) . ; Enter once to set the SEP to capture the separator "RTN","C0CMAIL2",182,0) . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q "RTN","C0CMAIL2",183,0) . . S SEP=X,END=X_FLG "RTN","C0CMAIL2",184,0) . . S (CNT,SGC)=1,BCN=0 "RTN","C0CMAIL2",185,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 "RTN","C0CMAIL2",186,0) . .QUIT "RTN","C0CMAIL2",187,0) . ; "RTN","C0CMAIL2",188,0) . ; A new separator is set, process original "RTN","C0CMAIL2",189,0) . I X=SEP D QUIT "RTN","C0CMAIL2",190,0) . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) "RTN","C0CMAIL2",191,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) "RTN","C0CMAIL2",192,0) . . S SGC=SGC+1,BCN=0 "RTN","C0CMAIL2",193,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 "RTN","C0CMAIL2",194,0) . .QUIT "RTN","C0CMAIL2",195,0) . ; "RTN","C0CMAIL2",196,0) . S BCN=BCN+$L(X) "RTN","C0CMAIL2",197,0) . I X[CON D Q "RTN","C0CMAIL2",198,0) . . S J=$P($P(X,";"),CON,2) "RTN","C0CMAIL2",199,0) . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) "RTN","C0CMAIL2",200,0) . .QUIT "RTN","C0CMAIL2",201,0) . ; "RTN","C0CMAIL2",202,0) . ; S LST(NAM,"MSG",D0,"SEG",D1)=X "RTN","C0CMAIL2",203,0) .QUIT "RTN","C0CMAIL2",204,0) QUIT "RTN","C0CMAIL2",205,0) ; =================== "RTN","C0CMAIL2",206,0) NAME(NM) ; Return the name of the Sender "RTN","C0CMAIL2",207,0) N NAME "RTN","C0CMAIL2",208,0) S NAME="" "RTN","C0CMAIL2",209,0) D "RTN","C0CMAIL2",210,0) . ; Look first for a value to use with the NEW PERSON file "RTN","C0CMAIL2",211,0) . ; "RTN","C0CMAIL2",212,0) . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q "RTN","C0CMAIL2",213,0) . ; "RTN","C0CMAIL2",214,0) . I $L(NM) S NAME=NM Q "RTN","C0CMAIL2",215,0) . ; "RTN","C0CMAIL2",216,0) . ; Else, pull the data from the message and display the foreign source "RTN","C0CMAIL2",217,0) . ; of the message. "RTN","C0CMAIL2",218,0) . N T "RTN","C0CMAIL2",219,0) . S VAL=$G(^XMB(3.9,D0,.7)) "RTN","C0CMAIL2",220,0) . S:VAL T=$P(^VA(200,VAL,0),U) "RTN","C0CMAIL2",221,0) . I $L($G(T)) S NAME=T Q "RTN","C0CMAIL2",222,0) . ; "RTN","C0CMAIL2",223,0) .QUIT "RTN","C0CMAIL2",224,0) QUIT NAME "RTN","C0CMAIL2",225,0) ; =================== "RTN","C0CMAIL2",226,0) TIME(Y) ; The time and date of the sending "RTN","C0CMAIL2",227,0) X ^DD("DD") "RTN","C0CMAIL2",228,0) QUIT Y "RTN","C0CMAIL2",229,0) ; =================== "RTN","C0CMAIL2",230,0) ; Segments in Message need to be identified and decoded properly "RTN","C0CMAIL2",231,0) ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message "RTN","C0CMAIL2",232,0) ; ARRAY will have the details of this one call "RTN","C0CMAIL2",233,0) ; "RTN","C0CMAIL2",234,0) ; Inputs; "RTN","C0CMAIL2",235,0) ; C0CINPUT - The IEN of the message to expand "RTN","C0CMAIL2",236,0) ; Outputs; "RTN","C0CMAIL2",237,0) ; C0CDATA - Carrier for the returned structure of the Message "RTN","C0CMAIL2",238,0) ; C0CDATA(D0,"SEG")=number of SEGMENTS "RTN","C0CMAIL2",239,0) ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type "RTN","C0CMAIL2",240,0) ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details "RTN","C0CMAIL2",241,0) ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details "RTN","C0CMAIL2",242,0) ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details "RTN","C0CMAIL2",243,0) ; "RTN","C0CMAIL2",244,0) DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery "RTN","C0CMAIL2",245,0) N LST,D0,D1,U "RTN","C0CMAIL2",246,0) S U="^" "RTN","C0CMAIL2",247,0) S D0=+$G(C0CINPUT) "RTN","C0CMAIL2",248,0) I D0 D QUIT "RTN","C0CMAIL2",249,0) . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT "RTN","C0CMAIL2",250,0) . ; "RTN","C0CMAIL2",251,0) . D GETTYP2(D0) "RTN","C0CMAIL2",252,0) . I $D(LST) M C0CDATA(D0)=LST Q "RTN","C0CMAIL2",253,0) . ; "RTN","C0CMAIL2",254,0) . D ERROR("ER02") "RTN","C0CMAIL2",255,0) .QUIT "RTN","C0CMAIL2",256,0) QUIT "RTN","C0CMAIL2",257,0) ; =================== "RTN","C0CMAIL2",258,0) ; End note if needed "RTN","C0CMAIL2",259,0) ; MSK - Set of characters that do not exist in 64 bit encoding "RTN","C0CMAIL2",260,0) GETTYP2(D0) ; Try to get the types and MSK for the "RTN","C0CMAIL2",261,0) N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM "RTN","C0CMAIL2",262,0) S CON="Content-",U="^" "RTN","C0CMAIL2",263,0) S FLG="--" "RTN","C0CMAIL2",264,0) S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" "RTN","C0CMAIL2",265,0) S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type "RTN","C0CMAIL2",266,0) S (BCN,CNT,D1,END,SGC)=0 "RTN","C0CMAIL2",267,0) S XX=$G(^XMB(3.9,D0,0)) "RTN","C0CMAIL2",268,0) ; S K=$P(^XMB(3.9,D0,2,0),U,3) "RTN","C0CMAIL2",269,0) S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) "RTN","C0CMAIL2",270,0) S LST("CREATED")=$$TIME($P(XX,U,3)) "RTN","C0CMAIL2",271,0) F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) "RTN","C0CMAIL2",272,0) S LST("FROM")=$$NAME(XXNM) "RTN","C0CMAIL2",273,0) ; Get the folks the email is sent to. "RTN","C0CMAIL2",274,0) S D1=0 "RTN","C0CMAIL2",275,0) F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" "RTN","C0CMAIL2",276,0) . N I,T "RTN","C0CMAIL2",277,0) . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) "RTN","C0CMAIL2",278,0) . S:T T=$P($G(^VA(200,T,0)),"^") "RTN","C0CMAIL2",279,0) . S LST("TO",+D1)=T "RTN","C0CMAIL2",280,0) . S T=$G(^XMB(3.9,D0,6,+D1,0)) "RTN","C0CMAIL2",281,0) . S:T="" T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL2",282,0) . S:T="" T="" "RTN","C0CMAIL2",283,0) . S LST("TO NAME",D1)=T "RTN","C0CMAIL2",284,0) .QUIT "RTN","C0CMAIL2",285,0) ; Get the Header for the message "RTN","C0CMAIL2",286,0) S D1=0 "RTN","C0CMAIL2",287,0) F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D "RTN","C0CMAIL2",288,0) . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) "RTN","C0CMAIL2",289,0) .QUIT "RTN","C0CMAIL2",290,0) ; Start walking the different sections "RTN","C0CMAIL2",291,0) S D1=.99999,SEP="@@",SGC=0 "RTN","C0CMAIL2",292,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL2",293,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL2",294,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL2",295,0) . ; Enter once to set the SEP to capture the separator "RTN","C0CMAIL2",296,0) . I (SEP="@@")&(X?2."--"5.AN.E) D Q "RTN","C0CMAIL2",297,0) . . I $L(X,FLG)>2 D ERROR("ER10") "RTN","C0CMAIL2",298,0) . . S SEP=X,END=X_FLG "RTN","C0CMAIL2",299,0) . . S (CNT,SGC)=1,BCN=0 "RTN","C0CMAIL2",300,0) . . S LST("SEG",SGC)=D1 "RTN","C0CMAIL2",301,0) . .QUIT "RTN","C0CMAIL2",302,0) . ; "RTN","C0CMAIL2",303,0) . ; A new SEGMENT separator is set, process original "RTN","C0CMAIL2",304,0) . I X=SEP D QUIT "RTN","C0CMAIL2",305,0) . . ; Save Current Values "RTN","C0CMAIL2",306,0) . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) "RTN","C0CMAIL2",307,0) . . ; Close this Segment and prepare to start a New Segment "RTN","C0CMAIL2",308,0) . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) "RTN","C0CMAIL2",309,0) . . ; Put the result in LST("SEG",SGC,"XML") "RTN","C0CMAIL2",310,0) . . I $L(BF) D "RTN","C0CMAIL2",311,0) . . . S ZN=1 "RTN","C0CMAIL2",312,0) . . . N I,T,TBF "RTN","C0CMAIL2",313,0) . . . S TBF=BF "RTN","C0CMAIL2",314,0) . . . F I=1:1:($L(TBF,"=")) D "RTN","C0CMAIL2",315,0) . . . . S BF=$P(TBF,"=",I)_"=" "RTN","C0CMAIL2",316,0) . . . . I BF'="=" D DECODER "RTN","C0CMAIL2",317,0) . . . .QUIT "RTN","C0CMAIL2",318,0) . . . S BF="" "RTN","C0CMAIL2",319,0) . . .QUIT "RTN","C0CMAIL2",320,0) . . S SGC=SGC+1,BCN=0 "RTN","C0CMAIL2",321,0) . . ; Incriment SGC to start a new Segment "RTN","C0CMAIL2",322,0) . . S LST("SEG",SGC)=D1 "RTN","C0CMAIL2",323,0) . .QUIT "RTN","C0CMAIL2",324,0) . ; "RTN","C0CMAIL2",325,0) . ; Accumulate the 64 bit encoding "RTN","C0CMAIL2",326,0) . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT "RTN","C0CMAIL2",327,0) . ; "RTN","C0CMAIL2",328,0) . ; Ending Condition, close out the Segment "RTN","C0CMAIL2",329,0) . I X=END D QUIT "RTN","C0CMAIL2",330,0) . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) "RTN","C0CMAIL2",331,0) . . I $L(BF) S ZN=1 D DECODER S BF="" Q "RTN","C0CMAIL2",332,0) . .QUIT "RTN","C0CMAIL2",333,0) . ; "RTN","C0CMAIL2",334,0) . ; Accumulate the lengths of other lines of the message "RTN","C0CMAIL2",335,0) . S BCN=BCN+$L(X) "RTN","C0CMAIL2",336,0) . ; Split out the Content Info "RTN","C0CMAIL2",337,0) . I X[CON D Q "RTN","C0CMAIL2",338,0) . . S J=$P(X,CON,2) "RTN","C0CMAIL2",339,0) . . I J[" boundary=" D "RTN","C0CMAIL2",340,0) . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG "RTN","C0CMAIL2",341,0) . . . Q:SEP?2"-"5.ANP "RTN","C0CMAIL2",342,0) . . . ; "RTN","C0CMAIL2",343,0) . . . D ERROR("ER11") "RTN","C0CMAIL2",344,0) . . . Q:SEP'[" " "RTN","C0CMAIL2",345,0) . . . ; "RTN","C0CMAIL2",346,0) . . . D ERROR("ER12") "RTN","C0CMAIL2",347,0) . . .QUIT "RTN","C0CMAIL2",348,0) . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) "RTN","C0CMAIL2",349,0) . .QUIT "RTN","C0CMAIL2",350,0) . ; "RTN","C0CMAIL2",351,0) . ; Everything else is Text, Check for CCR/CCD. "RTN","C0CMAIL2",352,0) . N KK,UBF "RTN","C0CMAIL2",353,0) . D "RTN","C0CMAIL2",354,0) . . S UBF=$$UPPER(X) "RTN","C0CMAIL2",355,0) . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q "RTN","C0CMAIL2",391,0) . . ; "RTN","C0CMAIL2",392,0) . . D "RTN","C0CMAIL2",393,0) . . . I 'OK S (BF,UBF,TBF,XBF)="" Q "RTN","C0CMAIL2",394,0) . . . ; "RTN","C0CMAIL2",395,0) . . . S BF=BF_"=" "RTN","C0CMAIL2",396,0) . . . D NORMAL(.XBF,.TBF) "RTN","C0CMAIL2",397,0) . . .QUIT "RTN","C0CMAIL2",398,0) . . M LST("SEG",SGC,"XML",RCNT)=XBF "RTN","C0CMAIL2",399,0) . .QUIT "RTN","C0CMAIL2",400,0) .QUIT "RTN","C0CMAIL2",401,0) QUIT "RTN","C0CMAIL2",402,0) ; =================== "RTN","C0CMAIL2",403,0) ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT "RTN","C0CMAIL2",404,0) ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT "RTN","C0CMAIL2",405,0) ; >D NORMAL^C0CMAIL(.OUT,BF) "RTN","C0CMAIL2",406,0) NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML "RTN","C0CMAIL2",407,0) ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME "RTN","C0CMAIL2",408,0) ; "RTN","C0CMAIL2",409,0) N ZN,OUTBF,XX,ZSEP "RTN","C0CMAIL2",410,0) S INXML=$TR(INXML,$C(10,12,13)) "RTN","C0CMAIL2",411,0) S ZN=1,ZSEP=">" "RTN","C0CMAIL2",412,0) S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 "RTN","C0CMAIL2",413,0) F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" "RTN","C0CMAIL2",414,0) . S XX=$P(INXML,"><",ZN) "RTN","C0CMAIL2",415,0) . S:$E($RE(XX))=">" ZSEP="" "RTN","C0CMAIL2",416,0) . Q:XX="" "RTN","C0CMAIL2",417,0) . ; "RTN","C0CMAIL2",418,0) . S XX="<"_XX_ZSEP "RTN","C0CMAIL2",419,0) . D "RTN","C0CMAIL2",420,0) . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q "RTN","C0CMAIL2",421,0) . . ; "RTN","C0CMAIL2",422,0) . . D ERROR("ER05") "RTN","C0CMAIL2",423,0) . . F ZL=ZL+1:1 D Q:XX="" "RTN","C0CMAIL2",424,0) . . . N XL "RTN","C0CMAIL2",425,0) . . . S XL=$E(XX,1,4000) "RTN","C0CMAIL2",426,0) . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters "RTN","C0CMAIL2",427,0) . . . S OUTBF(ZL)=XL "RTN","C0CMAIL2",428,0) . . .QUIT "RTN","C0CMAIL2",429,0) . .QUIT "RTN","C0CMAIL2",430,0) .QUIT "RTN","C0CMAIL2",431,0) M OUTXML=OUTBF "RTN","C0CMAIL2",432,0) QUIT "RTN","C0CMAIL2",433,0) ; =================== "RTN","C0CMAIL2",434,0) UPPER(X) ; Convert any lowercase letters to Uppercase letters "RTN","C0CMAIL2",435,0) QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","C0CMAIL2",436,0) ; =================== "RTN","C0CMAIL2",437,0) ; EN is a counter that remains between error events "RTN","C0CMAIL2",438,0) ERROR(ER) ; Error Handler "RTN","C0CMAIL2",439,0) N TXXQ,XXXQ "RTN","C0CMAIL2",440,0) S XXXQ="Unknown Error Encountered = "_ER "RTN","C0CMAIL2",441,0) S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) "RTN","C0CMAIL2",442,0) I TXXQ'="" D "RTN","C0CMAIL2",443,0) . I TXXQ["_" X "S TXXQ="_TXXQ "RTN","C0CMAIL2",444,0) . S XXXQ=TXXQ "RTN","C0CMAIL2",445,0) .QUIT "RTN","C0CMAIL2",446,0) S EN(ER)=$G(EN(ER))+1 "RTN","C0CMAIL2",447,0) S LST("ERR",ER,EN(ER))=XXXQ "RTN","C0CMAIL2",448,0) QUIT "RTN","C0CMAIL2",449,0) ; =================== "RTN","C0CMAIL2",450,0) ER01 ;;Message Missing "RTN","C0CMAIL2",451,0) ER02 ;;Message Text Missing "RTN","C0CMAIL2",452,0) ER03 ;;Message Not Identifiable "RTN","C0CMAIL2",453,0) ER04 ;;Segment is too large "RTN","C0CMAIL2",454,0) ER05 ;;Mailbox Missing "RTN","C0CMAIL2",455,0) ER06 ;;"User Missing = "_$G(DUZ) "RTN","C0CMAIL2",456,0) ER07 ;;"Bad DUZ = "_DUZ "RTN","C0CMAIL2",457,0) ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) "RTN","C0CMAIL2",458,0) ER10 ;;"Bad Separator found = "_X "RTN","C0CMAIL2",459,0) ER11 ;;"Non-Standard Separator Found:>"_$G(J) "RTN","C0CMAIL2",460,0) ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) "RTN","C0CMAIL2",461,0) ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv "RTN","C0CMAIL2",462,0) ; End note if needed "RTN","C0CMAIL2",463,0) QUIT "RTN","C0CMAIL2",464,0) ; =================== "RTN","C0CMAIL3") 0^29^B224733356 "RTN","C0CMAIL3",1,0) C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr "RTN","C0CMAIL3",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CMAIL3",3,0) ;Copyright 2011 Chris Richardson, Richardson Computer Research "RTN","C0CMAIL3",4,0) ; Modified 3110619@2038 "RTN","C0CMAIL3",5,0) ; rcr@rcresearch.us "RTN","C0CMAIL3",6,0) ; Licensed under the terms of the GNU "RTN","C0CMAIL3",7,0) ;General Public License See attached copy of the License. "RTN","C0CMAIL3",8,0) ; "RTN","C0CMAIL3",9,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CMAIL3",10,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CMAIL3",11,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CMAIL3",12,0) ;(at your option) any later version. "RTN","C0CMAIL3",13,0) ; "RTN","C0CMAIL3",14,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CMAIL3",15,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMAIL3",16,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMAIL3",17,0) ;GNU General Public License for more details. "RTN","C0CMAIL3",18,0) ; "RTN","C0CMAIL3",19,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CMAIL3",20,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMAIL3",21,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMAIL3",22,0) ; "RTN","C0CMAIL3",23,0) ; ------------------ "RTN","C0CMAIL3",24,0) ;Entry Points "RTN","C0CMAIL3",25,0) ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments "RTN","C0CMAIL3",26,0) ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) "RTN","C0CMAIL3",27,0) ; Input: "RTN","C0CMAIL3",28,0) ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL "RTN","C0CMAIL3",29,0) ; or "*" for all boxes, default is "IN" if missing]" "RTN","C0CMAIL3",30,0) ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", "RTN","C0CMAIL3",31,0) ; "*" for All or 9,999 maximum "RTN","C0CMAIL3",32,0) ; MALL?1.n = that number of the n most recent "RTN","C0CMAIL3",33,0) ; Internally: "RTN","C0CMAIL3",34,0) ; BNAM = Box Name "RTN","C0CMAIL3",35,0) ; Output: "RTN","C0CMAIL3",36,0) ; C0CDATA "RTN","C0CMAIL3",37,0) ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket "RTN","C0CMAIL3",38,0) ; (BNAM,"MSG",C0CIEN,"FROM")=Name "RTN","C0CMAIL3",39,0) ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address "RTN","C0CMAIL3",40,0) ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address "RTN","C0CMAIL3",41,0) ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title "RTN","C0CMAIL3",42,0) ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments "RTN","C0CMAIL3",43,0) ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text "RTN","C0CMAIL3",44,0) ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text "RTN","C0CMAIL3",45,0) ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes "RTN","C0CMAIL3",46,0) ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) "RTN","C0CMAIL3",47,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line "RTN","C0CMAIL3",48,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details "RTN","C0CMAIL3",49,0) ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data "RTN","C0CMAIL3",50,0) ; "RTN","C0CMAIL3",51,0) ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments "RTN","C0CMAIL3",52,0) ; Input; "RTN","C0CMAIL3",53,0) ; D0 - The IEN for the message in file 3.9, MESSAGE global "RTN","C0CMAIL3",54,0) ; Output "RTN","C0CMAIL3",55,0) ; OUTBF - The array of your choice to save the expanded and decoded message. "RTN","C0CMAIL3",56,0) ; "RTN","C0CMAIL3",57,0) GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data "RTN","C0CMAIL3",58,0) K:'$G(C0CDATA("KEEP")) C0CDATA "RTN","C0CMAIL3",59,0) N U "RTN","C0CMAIL3",60,0) S U="^" "RTN","C0CMAIL3",61,0) D:$G(C0CINPUT) "RTN","C0CMAIL3",62,0) . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL "RTN","C0CMAIL3",63,0) . S INPUT=C0CINPUT "RTN","C0CMAIL3",64,0) . S DUZ=+INPUT "RTN","C0CMAIL3",65,0) . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q "RTN","C0CMAIL3",66,0) . ; "RTN","C0CMAIL3",67,0) . D:$D(^XMB(3.7,DUZ,0))#2 "RTN","C0CMAIL3",68,0) . . S MBLST=$P(INPUT,";",2) "RTN","C0CMAIL3",69,0) . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag "RTN","C0CMAIL3",70,0) . . S:MALL["*" MALL=99999 "RTN","C0CMAIL3",71,0) . . ; Only one of these can be correct "RTN","C0CMAIL3",72,0) . . D "RTN","C0CMAIL3",73,0) . . . ; If nul, make it "IN" only "RTN","C0CMAIL3",74,0) . . . I MBLST="" D QUIT "RTN","C0CMAIL3",75,0) . . . . S MBLST("IN")=0,I=0 "RTN","C0CMAIL3",76,0) . . . . D GATHER(DUZ,"IN",.LST) "RTN","C0CMAIL3",77,0) . . . .QUIT "RTN","C0CMAIL3",78,0) . . . ; "RTN","C0CMAIL3",79,0) . . . ; If "*", Get all Mailboxes and look for New Messages "RTN","C0CMAIL3",80,0) . . . I MBLST["*" D QUIT "RTN","C0CMAIL3",81,0) . . . . N NAM,NUM "RTN","C0CMAIL3",82,0) . . . . S NUM=0 "RTN","C0CMAIL3",83,0) . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D "RTN","C0CMAIL3",84,0) . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) "RTN","C0CMAIL3",85,0) . . . . . D GATHER(DUZ,NAM,.LST) "RTN","C0CMAIL3",86,0) . . . . .QUIT "RTN","C0CMAIL3",87,0) . . . .QUIT "RTN","C0CMAIL3",88,0) . . . ; "RTN","C0CMAIL3",89,0) . . . ; If comma separated, look for mailboxes with new messages "RTN","C0CMAIL3",90,0) . . . I $L(MBLST,",")>1 D QUIT "RTN","C0CMAIL3",91,0) . . . . S NAM="" "RTN","C0CMAIL3",92,0) . . . . N TN,V "RTN","C0CMAIL3",93,0) . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D "RTN","C0CMAIL3",94,0) . . . . . I $L(V) D QUIT "RTN","C0CMAIL3",95,0) . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) "RTN","C0CMAIL3",96,0) . . . . . . S:NAM="" NAM=V "RTN","C0CMAIL3",97,0) . . . . . . D GATHER(DUZ,NAM,.LST) "RTN","C0CMAIL3",98,0) . . . . . .QUIT "RTN","C0CMAIL3",99,0) . . . . . ; "RTN","C0CMAIL3",100,0) . . . . . D ERROR("ER08") "RTN","C0CMAIL3",101,0) . . . . .QUIT "RTN","C0CMAIL3",102,0) . . . .QUIT "RTN","C0CMAIL3",103,0) . . . ; "RTN","C0CMAIL3",104,0) . . . ; If only 1 mailbox named, go get it "RTN","C0CMAIL3",105,0) . . . I $L(MBLST) D QUIT "RTN","C0CMAIL3",106,0) . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT "RTN","C0CMAIL3",107,0) . . . . ; "RTN","C0CMAIL3",108,0) . . . . D ERROR("ER07") "RTN","C0CMAIL3",109,0) . . .QUIT "RTN","C0CMAIL3",110,0) . . MERGE C0CDATA=LST "RTN","C0CMAIL3",111,0) . .QUIT "RTN","C0CMAIL3",112,0) .QUIT "RTN","C0CMAIL3",113,0) QUIT "RTN","C0CMAIL3",114,0) ; =================== "RTN","C0CMAIL3",115,0) GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail "RTN","C0CMAIL3",116,0) N I,J,K,L "RTN","C0CMAIL3",117,0) S (I,K)=0 "RTN","C0CMAIL3",118,0) S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) "RTN","C0CMAIL3",119,0) F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D "RTN","C0CMAIL3",120,0) . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) "RTN","C0CMAIL3",121,0) . D ; :L "RTN","C0CMAIL3",122,0) . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails "RTN","C0CMAIL3",123,0) . . S LST(NAM,"MSG",I)=L "RTN","C0CMAIL3",124,0) . . D GETTYP(I) "RTN","C0CMAIL3",125,0) . .QUIT "RTN","C0CMAIL3",126,0) .QUIT "RTN","C0CMAIL3",127,0) S LST(NAM,"NUMBER")=K "RTN","C0CMAIL3",128,0) QUIT "RTN","C0CMAIL3",129,0) ; =================== "RTN","C0CMAIL3",130,0) ; D0 is the IEN into the Message Global ^XMB(3.9,D0) "RTN","C0CMAIL3",131,0) ; The products of these emails are scanned to identify "RTN","C0CMAIL3",132,0) ; the number of documents stored in the MIME package. "RTN","C0CMAIL3",133,0) ; The protocol runs like this; "RTN","C0CMAIL3",134,0) ; Line 1 is the --separator "RTN","C0CMAIL3",135,0) ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD "RTN","C0CMAIL3",136,0) ; Line n+2 thru t-1 where t does NOT have "Content-" "RTN","C0CMAIL3",137,0) ; Line t is Next Section Terminator, or Message Terminator, --separator "RTN","C0CMAIL3",138,0) ; Line t+1 should not exist in the data set if Message Terminator "RTN","C0CMAIL3",139,0) ; CON = "Content-" "RTN","C0CMAIL3",140,0) ; FLG = "--" "RTN","C0CMAIL3",141,0) ; SEP = FLG+7 or more characters ; Separator "RTN","C0CMAIL3",142,0) ; END = SEP+FLG "RTN","C0CMAIL3",143,0) ; SGC = Segment Count "RTN","C0CMAIL3",144,0) ; Note: separator is a string of specific characters of "RTN","C0CMAIL3",145,0) ; indeterminate length "RTN","C0CMAIL3",146,0) ; LST() the transfer array "RTN","C0CMAIL3",147,0) ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line "RTN","C0CMAIL3",148,0) ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data "RTN","C0CMAIL3",149,0) ; "RTN","C0CMAIL3",150,0) GETTYP(D0) ; Look for the goodies in the Mail "RTN","C0CMAIL3",151,0) N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM "RTN","C0CMAIL3",152,0) S CON="Content-" "RTN","C0CMAIL3",153,0) S FLG="--" "RTN","C0CMAIL3",154,0) S SEP="" ; Start SEP as null, so we can use this to help identify the type "RTN","C0CMAIL3",155,0) S (BCN,CNT,D1,END,SGC)=0 "RTN","C0CMAIL3",156,0) S XX=$G(^XMB(3.9,D0,0)) "RTN","C0CMAIL3",157,0) S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) "RTN","C0CMAIL3",158,0) S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) "RTN","C0CMAIL3",159,0) F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) "RTN","C0CMAIL3",160,0) S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) "RTN","C0CMAIL3",161,0) S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) "RTN","C0CMAIL3",162,0) ; Get the folks the email is sent to. "RTN","C0CMAIL3",163,0) S D1=0 "RTN","C0CMAIL3",164,0) F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D "RTN","C0CMAIL3",165,0) . N T "RTN","C0CMAIL3",166,0) . S T=+$G(^XMB(3.9,D0,1,D1,0)) "RTN","C0CMAIL3",167,0) . S:T T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL3",168,0) . S LST("TO",D1)=T "RTN","C0CMAIL3",169,0) . S T=$G(^XMB(3.9,D0,6,D1,0)) "RTN","C0CMAIL3",170,0) . S:T T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL3",171,0) . S:T="" T="" "RTN","C0CMAIL3",172,0) . S LST("TO NAME",D1)=T "RTN","C0CMAIL3",173,0) .QUIT "RTN","C0CMAIL3",174,0) ; Preload first Segment (0) with beginning on Line 1 "RTN","C0CMAIL3",175,0) ; if not a 64bit "RTN","C0CMAIL3",176,0) S LST(NAM,"MSG",D0,"SEG",0)=1 "RTN","C0CMAIL3",177,0) S D1=.9999,SEP="@@" "RTN","C0CMAIL3",178,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL3",179,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL3",180,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL3",181,0) . ; Enter once to set the SEP to capture the separator "RTN","C0CMAIL3",182,0) . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q "RTN","C0CMAIL3",183,0) . . S SEP=X,END=X_FLG "RTN","C0CMAIL3",184,0) . . S (CNT,SGC)=1,BCN=0 "RTN","C0CMAIL3",185,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 "RTN","C0CMAIL3",186,0) . .QUIT "RTN","C0CMAIL3",187,0) . ; "RTN","C0CMAIL3",188,0) . ; A new separator is set, process original "RTN","C0CMAIL3",189,0) . I X=SEP D QUIT "RTN","C0CMAIL3",190,0) . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) "RTN","C0CMAIL3",191,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) "RTN","C0CMAIL3",192,0) . . S SGC=SGC+1,BCN=0 "RTN","C0CMAIL3",193,0) . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 "RTN","C0CMAIL3",194,0) . .QUIT "RTN","C0CMAIL3",195,0) . ; "RTN","C0CMAIL3",196,0) . S BCN=BCN+$L(X) "RTN","C0CMAIL3",197,0) . I X[CON D Q "RTN","C0CMAIL3",198,0) . . S J=$P($P(X,";"),CON,2) "RTN","C0CMAIL3",199,0) . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) "RTN","C0CMAIL3",200,0) . .QUIT "RTN","C0CMAIL3",201,0) . ; "RTN","C0CMAIL3",202,0) . ; S LST(NAM,"MSG",D0,"SEG",D1)=X "RTN","C0CMAIL3",203,0) .QUIT "RTN","C0CMAIL3",204,0) QUIT "RTN","C0CMAIL3",205,0) ; =================== "RTN","C0CMAIL3",206,0) NAME(NM) ; Return the name of the Sender "RTN","C0CMAIL3",207,0) N NAME "RTN","C0CMAIL3",208,0) S NAME="" "RTN","C0CMAIL3",209,0) D "RTN","C0CMAIL3",210,0) . ; Look first for a value to use with the NEW PERSON file "RTN","C0CMAIL3",211,0) . ; "RTN","C0CMAIL3",212,0) . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q "RTN","C0CMAIL3",213,0) . ; "RTN","C0CMAIL3",214,0) . I $L(NM) S NAME=NM Q "RTN","C0CMAIL3",215,0) . ; "RTN","C0CMAIL3",216,0) . ; Else, pull the data from the message and display the foreign source "RTN","C0CMAIL3",217,0) . ; of the message. "RTN","C0CMAIL3",218,0) . N T "RTN","C0CMAIL3",219,0) . S VAL=$G(^XMB(3.9,D0,.7)) "RTN","C0CMAIL3",220,0) . S:VAL T=$P(^VA(200,VAL,0),U) "RTN","C0CMAIL3",221,0) . I $L($G(T)) S NAME=T Q "RTN","C0CMAIL3",222,0) . ; "RTN","C0CMAIL3",223,0) .QUIT "RTN","C0CMAIL3",224,0) QUIT NAME "RTN","C0CMAIL3",225,0) ; =================== "RTN","C0CMAIL3",226,0) TIME(Y) ; The time and date of the sending "RTN","C0CMAIL3",227,0) X ^DD("DD") "RTN","C0CMAIL3",228,0) QUIT Y "RTN","C0CMAIL3",229,0) ; =================== "RTN","C0CMAIL3",230,0) ; Segments in Message need to be identified and decoded properly "RTN","C0CMAIL3",231,0) ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message "RTN","C0CMAIL3",232,0) ; ARRAY will have the details of this one call "RTN","C0CMAIL3",233,0) ; "RTN","C0CMAIL3",234,0) ; Inputs; "RTN","C0CMAIL3",235,0) ; C0CINPUT - The IEN of the message to expand "RTN","C0CMAIL3",236,0) ; Outputs; "RTN","C0CMAIL3",237,0) ; C0CDATA - Carrier for the returned structure of the Message "RTN","C0CMAIL3",238,0) ; C0CDATA(D0,"SEG")=number of SEGMENTS "RTN","C0CMAIL3",239,0) ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type "RTN","C0CMAIL3",240,0) ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details "RTN","C0CMAIL3",241,0) ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details "RTN","C0CMAIL3",242,0) ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details "RTN","C0CMAIL3",243,0) ; "RTN","C0CMAIL3",244,0) DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery "RTN","C0CMAIL3",245,0) N LST,D0,D1,U "RTN","C0CMAIL3",246,0) S U="^" "RTN","C0CMAIL3",247,0) S D0=+$G(C0CINPUT) "RTN","C0CMAIL3",248,0) I D0 D QUIT "RTN","C0CMAIL3",249,0) . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT "RTN","C0CMAIL3",250,0) . ; "RTN","C0CMAIL3",251,0) . D GETTYP2(D0) "RTN","C0CMAIL3",252,0) . I $D(LST) M C0CDATA(D0)=LST Q "RTN","C0CMAIL3",253,0) . ; "RTN","C0CMAIL3",254,0) . D ERROR("ER02") "RTN","C0CMAIL3",255,0) .QUIT "RTN","C0CMAIL3",256,0) QUIT "RTN","C0CMAIL3",257,0) ; =================== "RTN","C0CMAIL3",258,0) ; End note if needed "RTN","C0CMAIL3",259,0) ; MSK - Set of characters that do not exist in 64 bit encoding "RTN","C0CMAIL3",260,0) GETTYP2(D0) ; Try to get the types and MSK for the "RTN","C0CMAIL3",261,0) N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM "RTN","C0CMAIL3",262,0) S CON="Content-",U="^" "RTN","C0CMAIL3",263,0) S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" "RTN","C0CMAIL3",264,0) S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type "RTN","C0CMAIL3",265,0) S (BCN,CNT,D1,END,SGC)=0 "RTN","C0CMAIL3",266,0) S XX=$G(^XMB(3.9,D0,0)) "RTN","C0CMAIL3",267,0) ; S K=$P(^XMB(3.9,D0,2,0),U,3) "RTN","C0CMAIL3",268,0) S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) "RTN","C0CMAIL3",269,0) S LST("CREATED")=$$TIME($P(XX,U,3)) "RTN","C0CMAIL3",270,0) F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) "RTN","C0CMAIL3",271,0) S LST("FROM")=$$NAME(XXNM) "RTN","C0CMAIL3",272,0) ; Get the folks the email is sent to. "RTN","C0CMAIL3",273,0) S D1=0 "RTN","C0CMAIL3",274,0) F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" "RTN","C0CMAIL3",275,0) . N I,T "RTN","C0CMAIL3",276,0) . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) "RTN","C0CMAIL3",277,0) . S:T T=$P($G(^VA(200,T,0)),"^") "RTN","C0CMAIL3",278,0) . S LST("TO",+D1)=T "RTN","C0CMAIL3",279,0) . S T=$G(^XMB(3.9,D0,6,+D1,0)) "RTN","C0CMAIL3",280,0) . S:T="" T=$P($G(^VA(200,+T,0)),"^") "RTN","C0CMAIL3",281,0) . S:T="" T="" "RTN","C0CMAIL3",282,0) . S LST("TO NAME",D1)=T "RTN","C0CMAIL3",283,0) .QUIT "RTN","C0CMAIL3",284,0) ; Get the Header for the message and store as "HDR" "RTN","C0CMAIL3",285,0) S D1=0,SGC=0 "RTN","C0CMAIL3",286,0) F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D "RTN","C0CMAIL3",287,0) . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) "RTN","C0CMAIL3",288,0) .QUIT "RTN","C0CMAIL3",289,0) N BNDRY,STKL,SEG "RTN","C0CMAIL3",290,0) S STKL=0,SEG=0 "RTN","C0CMAIL3",291,0) ; Find boundaries and map them "RTN","C0CMAIL3",292,0) S D1=0 "RTN","C0CMAIL3",293,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL3",294,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL3",295,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL3",296,0) . ; Look for " boundary=" in the various parts. Map the establishment and the "RTN","C0CMAIL3",297,0) . ; terminator markers and the actual boundary markers. "RTN","C0CMAIL3",298,0) . I X[" boundary=" D Q "RTN","C0CMAIL3",299,0) . . S SEP=$P(X," boundary=",2) "RTN","C0CMAIL3",300,0) . . S:$E(SEP)="""" SEP=$TR(SEP,"""") "RTN","C0CMAIL3",301,0) . . S STKL=STKL+1 "RTN","C0CMAIL3",302,0) . . S END=SEP_FLG "RTN","C0CMAIL3",303,0) . . S BNDRY(STKL,SEP)=0 "RTN","C0CMAIL3",304,0) . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 "RTN","C0CMAIL3",305,0) . .QUIT "RTN","C0CMAIL3",306,0) . ; "RTN","C0CMAIL3",307,0) . ; Look for information as to how amy boudaries are present and where "RTN","C0CMAIL3",308,0) . ; they terminate "RTN","C0CMAIL3",309,0) . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") "RTN","C0CMAIL3",310,0) . . ; Boundary Found "RTN","C0CMAIL3",311,0) . . I $D(BNDRX(X)) D Q "RTN","C0CMAIL3",312,0) . . . S SEG=SEG+1 "RTN","C0CMAIL3",313,0) . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" "RTN","C0CMAIL3",314,0) . . . S BND1(D1)=STKL_";B;"_SEG_";"_X "RTN","C0CMAIL3",315,0) . . . S BNDR(X,D1,"B")=STKL "RTN","C0CMAIL3",316,0) . . . I BNDRX(X)=X D ERROR("ER13") "RTN","C0CMAIL3",317,0) . . .QUIT "RTN","C0CMAIL3",318,0) . . ; "RTN","C0CMAIL3",319,0) . . ; Boundary Terminator "RTN","C0CMAIL3",320,0) . . I $D(BNDRZ(X)) D Q "RTN","C0CMAIL3",321,0) . . . S BNDR(X,D1,"E")=STKL "RTN","C0CMAIL3",322,0) . . . S BNDRZ(X)=BNDRZ(X)+1 "RTN","C0CMAIL3",323,0) . . . S BND1(D1)=STKL_";E;"_SEG_";"_X "RTN","C0CMAIL3",324,0) . . . S SEG=SEG+1 "RTN","C0CMAIL3",325,0) . . . I BNDRX(X)=X D ERROR("ER14") "RTN","C0CMAIL3",326,0) . . . S STKL=STKL-1 "RTN","C0CMAIL3",327,0) . . .QUIT "RTN","C0CMAIL3",328,0) . .QUIT "RTN","C0CMAIL3",329,0) .QUIT "RTN","C0CMAIL3",330,0) ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message "RTN","C0CMAIL3",331,0) N A,B,C,STACK,STYP,SEG,AX "RTN","C0CMAIL3",332,0) S D1=.99999,SGC=0 "RTN","C0CMAIL3",333,0) F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D "RTN","C0CMAIL3",334,0) . ; Clear any control characters (cr/lf/ff) off "RTN","C0CMAIL3",335,0) . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) "RTN","C0CMAIL3",336,0) . ; "RTN","C0CMAIL3",337,0) . D "RTN","C0CMAIL3",338,0) . . I $D(BND1(D1)) D BOUNDARY(X) QUIT "RTN","C0CMAIL3",339,0) . . ; "RTN","C0CMAIL3",340,0) . . S DX=$O(BND1(D1)) "RTN","C0CMAIL3",341,0) . . I DX="" D ERROR("ER15") Q "RTN","C0CMAIL3",342,0) . . ; "RTN","C0CMAIL3",343,0) . . ; Good situation, extract the parts for the section "RTN","C0CMAIL3",344,0) . . S A=$G(BND1(DX)) "RTN","C0CMAIL3",345,0) . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) "RTN","C0CMAIL3",346,0) . .QUIT "RTN","C0CMAIL3",347,0) . ; Enter once to set the SEP to capture the separator "RTN","C0CMAIL3",348,0) . ; "RTN","C0CMAIL3",349,0) . ; A new SEGMENT separator is set, process original "RTN","C0CMAIL3",350,0) . I $D(BND1(X)) D QUIT "RTN","C0CMAIL3",351,0) . . ; Save Current Values "RTN","C0CMAIL3",352,0) . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) "RTN","C0CMAIL3",353,0) . . ; Close this Segment and prepare to start a New Segment "RTN","C0CMAIL3",354,0) . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) "RTN","C0CMAIL3",355,0) . . ; Put the result in LST("SEG",SGC,"XML") "RTN","C0CMAIL3",356,0) . . I $L(BF) D "RTN","C0CMAIL3",357,0) . . . S ZN=1 "RTN","C0CMAIL3",358,0) . . . N I,T,TBF "RTN","C0CMAIL3",359,0) . . . S TBF=BF "RTN","C0CMAIL3",360,0) . . . F I=1:1:($L(TBF,"=")) D "RTN","C0CMAIL3",361,0) . . . . S BF=$P(TBF,"=",I)_"=" "RTN","C0CMAIL3",362,0) . . . . I "="'[BF D DECODER(.BF,.TYP) "RTN","C0CMAIL3",363,0) . . . .QUIT "RTN","C0CMAIL3",364,0) . . . S BF="" "RTN","C0CMAIL3",365,0) . . .QUIT "RTN","C0CMAIL3",366,0) . . S SGC=SGC+1,BCN=0 "RTN","C0CMAIL3",367,0) . . ; Incriment SGC to start a new Segment "RTN","C0CMAIL3",368,0) . . S LST("SEG",SGC)=D1 "RTN","C0CMAIL3",369,0) . .QUIT "RTN","C0CMAIL3",370,0) . ; "RTN","C0CMAIL3",371,0) . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters "RTN","C0CMAIL3",372,0) . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT "RTN","C0CMAIL3",373,0) . ; "RTN","C0CMAIL3",374,0) . ; Ending Condition, close out the Segment "RTN","C0CMAIL3",375,0) . I $D(BNDRZ(X)) D QUIT "RTN","C0CMAIL3",376,0) . . S $P(LST("SEG",SGC),"^",2)=D1-1 "RTN","C0CMAIL3",377,0) . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q "RTN","C0CMAIL3",378,0) . .QUIT "RTN","C0CMAIL3",379,0) . ; "RTN","C0CMAIL3",380,0) . ; Accumulate the content lines of the message "RTN","C0CMAIL3",381,0) . S BCN=BCN+$L(X) "RTN","C0CMAIL3",382,0) . ; Split out the Content Info "RTN","C0CMAIL3",383,0) . I X[CON D Q "RTN","C0CMAIL3",384,0) . . S J=$P(X,CON,2) "RTN","C0CMAIL3",385,0) . . S TYP="CONTENT" "RTN","C0CMAIL3",386,0) . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) "RTN","C0CMAIL3",387,0) . . D CONTENT(D1) "RTN","C0CMAIL3",388,0) . .QUIT "RTN","C0CMAIL3",389,0) . ; "RTN","C0CMAIL3",390,0) . ; Everything else is Text, Check for CCR/CCD. "RTN","C0CMAIL3",391,0) . N KK,UBF "RTN","C0CMAIL3",392,0) . D "RTN","C0CMAIL3",393,0) . . S UBF=$$UPPER(X) "RTN","C0CMAIL3",394,0) . . I UBF["1) S TYP=$P(UP,".",2) Q "RTN","C0CMAIL3",416,0) . I UP["XML" S TYP="XML" Q "RTN","C0CMAIL3",417,0) . I UP["P7S" S TYP="P7S" Q "RTN","C0CMAIL3",418,0) . I J[" boundary=" D BOUNDARY(J) "RTN","C0CMAIL3",419,0) .QUIT "RTN","C0CMAIL3",420,0) S LIS("CON",SGC,D1)=X "RTN","C0CMAIL3",421,0) S LIS("CON",SGC,D1,"TYP")=TYP "RTN","C0CMAIL3",422,0) ; If there is a follow-on, look for another line after this. "RTN","C0CMAIL3",423,0) I $E($RE(X),1)=";" D CONTENT(D1+1) "RTN","C0CMAIL3",424,0) QUIT "RTN","C0CMAIL3",425,0) ; =================== "RTN","C0CMAIL3",426,0) BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level "RTN","C0CMAIL3",427,0) S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG "RTN","C0CMAIL3",428,0) Q:SEP?2"-".ANP "RTN","C0CMAIL3",429,0) ; "RTN","C0CMAIL3",430,0) D ERROR("ER11") "RTN","C0CMAIL3",431,0) Q:SEP'[" " "RTN","C0CMAIL3",432,0) ; "RTN","C0CMAIL3",433,0) D ERROR("ER12") "RTN","C0CMAIL3",434,0) QUIT "RTN","C0CMAIL3",435,0) ; =================== "RTN","C0CMAIL3",436,0) ; Break down the Buffer Array so it can be saved. "RTN","C0CMAIL3",437,0) ; BF is passed in. "RTN","C0CMAIL3",438,0) ; TYP is the type of "RTN","C0CMAIL3",439,0) DECODER(BF,TYP) ; "RTN","C0CMAIL3",440,0) N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE "RTN","C0CMAIL3",441,0) S:$G(TYP)="" TYP="XML" "RTN","C0CMAIL3",442,0) S ZBF=BF "RTN","C0CMAIL3",443,0) ; Full Buffer, BF, now check for Encryption and Unpack "RTN","C0CMAIL3",444,0) F RCNT=1:1:$L(ZBF,"=") D "RTN","C0CMAIL3",445,0) . N BF "RTN","C0CMAIL3",446,0) . S BF=$P(ZBF,"=",RCNT) "RTN","C0CMAIL3",447,0) . ; Unpacking the 64 bit encoding "RTN","C0CMAIL3",448,0) . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) "RTN","C0CMAIL3",449,0) . D:$L(TBF) "RTN","C0CMAIL3",450,0) . . N C,OK,OKCNT,KK,XBF,UBF "RTN","C0CMAIL3",451,0) . . D "RTN","C0CMAIL3",452,0) . . . S UBF=$$UPPER(TBF) "RTN","C0CMAIL3",453,0) . . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q "RTN","C0CMAIL3",460,0) . . ; "RTN","C0CMAIL3",461,0) . . D "RTN","C0CMAIL3",462,0) . . . I 'OK S (BF,UBF,TBF,XBF)="" Q "RTN","C0CMAIL3",463,0) . . . ; "RTN","C0CMAIL3",464,0) . . . S BF=BF_"=" "RTN","C0CMAIL3",465,0) . . . D NORMAL(.XBF,.TBF) "RTN","C0CMAIL3",466,0) . . .QUIT "RTN","C0CMAIL3",467,0) . . M LST("SEG",SGC,TYP,RCNT)=XBF "RTN","C0CMAIL3",468,0) . .QUIT "RTN","C0CMAIL3",469,0) .QUIT "RTN","C0CMAIL3",470,0) QUIT "RTN","C0CMAIL3",471,0) ; =================== "RTN","C0CMAIL3",472,0) ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT "RTN","C0CMAIL3",473,0) ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT "RTN","C0CMAIL3",474,0) ; >D NORMAL^C0CMAIL(.OUT,BF) "RTN","C0CMAIL3",475,0) NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML "RTN","C0CMAIL3",476,0) ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME "RTN","C0CMAIL3",477,0) ; "RTN","C0CMAIL3",478,0) N ZN,OUTBF,XX,ZSEP "RTN","C0CMAIL3",479,0) S INXML=$TR(INXML,$C(10,12,13)) "RTN","C0CMAIL3",480,0) S ZN=1,ZSEP=">" "RTN","C0CMAIL3",481,0) S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 "RTN","C0CMAIL3",482,0) F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" "RTN","C0CMAIL3",483,0) . S XX=$P(INXML,"><",ZN) "RTN","C0CMAIL3",484,0) . S:$E($RE(XX))=">" ZSEP="" "RTN","C0CMAIL3",485,0) . Q:XX="" "RTN","C0CMAIL3",486,0) . ; "RTN","C0CMAIL3",487,0) . S XX="<"_XX_ZSEP "RTN","C0CMAIL3",488,0) . D "RTN","C0CMAIL3",489,0) . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q "RTN","C0CMAIL3",490,0) . . ; "RTN","C0CMAIL3",491,0) . . D ERROR("ER05") "RTN","C0CMAIL3",492,0) . . F ZL=ZL+1:1 D Q:XX="" "RTN","C0CMAIL3",493,0) . . . N XL "RTN","C0CMAIL3",494,0) . . . S XL=$E(XX,1,4000) "RTN","C0CMAIL3",495,0) . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters "RTN","C0CMAIL3",496,0) . . . S OUTBF(ZL)=XL "RTN","C0CMAIL3",497,0) . . .QUIT "RTN","C0CMAIL3",498,0) . .QUIT "RTN","C0CMAIL3",499,0) .QUIT "RTN","C0CMAIL3",500,0) M OUTXML=OUTBF "RTN","C0CMAIL3",501,0) QUIT "RTN","C0CMAIL3",502,0) ; =================== "RTN","C0CMAIL3",503,0) UPPER(X) ; Convert any lowercase letters to Uppercase letters "RTN","C0CMAIL3",504,0) QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","C0CMAIL3",505,0) ; =================== "RTN","C0CMAIL3",506,0) ; EN is a counter that remains between error events "RTN","C0CMAIL3",507,0) ERROR(ER) ; Error Handler "RTN","C0CMAIL3",508,0) N TXXQ,XXXQ "RTN","C0CMAIL3",509,0) S XXXQ="Unknown Error Encountered = "_ER "RTN","C0CMAIL3",510,0) S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) "RTN","C0CMAIL3",511,0) I TXXQ'="" D "RTN","C0CMAIL3",512,0) . I TXXQ["_" X "S TXXQ="_TXXQ "RTN","C0CMAIL3",513,0) . S XXXQ=TXXQ "RTN","C0CMAIL3",514,0) .QUIT "RTN","C0CMAIL3",515,0) S EN(ER)=$G(EN(ER))+1 "RTN","C0CMAIL3",516,0) S LST("ERR",ER,EN(ER))=XXXQ "RTN","C0CMAIL3",517,0) QUIT "RTN","C0CMAIL3",518,0) ; =================== "RTN","C0CMAIL3",519,0) ER01 ;;Message Missing "RTN","C0CMAIL3",520,0) ER02 ;;Message Text Missing "RTN","C0CMAIL3",521,0) ER03 ;;Message Not Identifiable "RTN","C0CMAIL3",522,0) ER04 ;;Segment is too large "RTN","C0CMAIL3",523,0) ER05 ;;Mailbox Missing "RTN","C0CMAIL3",524,0) ER06 ;;"User Missing = "_$G(DUZ) "RTN","C0CMAIL3",525,0) ER07 ;;"Bad DUZ = "_DUZ "RTN","C0CMAIL3",526,0) ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) "RTN","C0CMAIL3",527,0) ER10 ;;"Bad Separator found = "_X "RTN","C0CMAIL3",528,0) ER11 ;;"Non-Standard Separator Found:>"_$G(J) "RTN","C0CMAIL3",529,0) ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) "RTN","C0CMAIL3",530,0) ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X "RTN","C0CMAIL3",531,0) ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv "RTN","C0CMAIL3",532,0) ; End note if needed "RTN","C0CMAIL3",533,0) QUIT "RTN","C0CMAIL3",534,0) ; =================== "RTN","C0CMCCD") 0^30^B73168233 "RTN","C0CMCCD",1,0) C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 "RTN","C0CMCCD",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CMCCD",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CMCCD",4,0) ;General Public License See attached copy of the License. "RTN","C0CMCCD",5,0) ; "RTN","C0CMCCD",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CMCCD",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CMCCD",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CMCCD",9,0) ;(at your option) any later version. "RTN","C0CMCCD",10,0) ; "RTN","C0CMCCD",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CMCCD",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMCCD",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMCCD",14,0) ;GNU General Public License for more details. "RTN","C0CMCCD",15,0) ; "RTN","C0CMCCD",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CMCCD",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMCCD",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMCCD",19,0) ; "RTN","C0CMCCD",20,0) Q "RTN","C0CMCCD",21,0) ; "RTN","C0CMCCD",22,0) PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR "RTN","C0CMCCD",23,0) ; PROCESSING CCDS "RTN","C0CMCCD",24,0) N CBK,SUCCESS,LEVEL,NODE,HANDLE "RTN","C0CMCCD",25,0) K ^TMP("MXMLERR",$J) "RTN","C0CMCCD",26,0) L +^TMP("MXMLDOM",$J):5 "RTN","C0CMCCD",27,0) E Q 0 "RTN","C0CMCCD",28,0) S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" "RTN","C0CMCCD",29,0) L -^TMP("MXMLDOM",$J) "RTN","C0CMCCD",30,0) S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL "RTN","C0CMCCD",31,0) S CBK("ENDELEMENT")="ENDELE^MXMLDOM" "RTN","C0CMCCD",32,0) S CBK("COMMENT")="COMMENT^MXMLDOM" "RTN","C0CMCCD",33,0) S CBK("CHARACTERS")="CHAR^MXMLDOM" "RTN","C0CMCCD",34,0) S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM" "RTN","C0CMCCD",35,0) S CBK("ERROR")="ERROR^MXMLDOM" "RTN","C0CMCCD",36,0) S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1") "RTN","C0CMCCD",37,0) D EN^MXMLPRSE(DOC,.CBK,OPTION) "RTN","C0CMCCD",38,0) D:'SUCCESS DELETE^MXMLDOM(HANDLE) "RTN","C0CMCCD",39,0) Q $S(SUCCESS:HANDLE,1:0) "RTN","C0CMCCD",40,0) ; Start element "RTN","C0CMCCD",41,0) ; Create new child node and push info on stack "RTN","C0CMCCD",42,0) STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT "RTN","C0CMCCD",43,0) ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER "RTN","C0CMCCD",44,0) N PARENT "RTN","C0CMCCD",45,0) S PARENT=LEVEL(LEVEL),NODE=NODE+1 "RTN","C0CMCCD",46,0) S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE "RTN","C0CMCCD",47,0) S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE "RTN","C0CMCCD",48,0) S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT "RTN","C0CMCCD",49,0) ;M ^("A")=ATTR "RTN","C0CMCCD",50,0) N ZI S ZI="" ; INDEX FOR ATTR "RTN","C0CMCCD",51,0) F S ZI=$O(ATTR(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE "RTN","C0CMCCD",52,0) . N ELE,TXT ; ABOUT TO RECURSE "RTN","C0CMCCD",53,0) . S ELE=ZI ; TAG "RTN","C0CMCCD",54,0) . S TXT=ATTR(ZI) ; DATA "RTN","C0CMCCD",55,0) . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE "RTN","C0CMCCD",56,0) . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG "RTN","C0CMCCD",57,0) . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL "RTN","C0CMCCD",58,0) Q "RTN","C0CMCCD",59,0) ; "RTN","C0CMCCD",60,0) ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE "RTN","C0CMCCD",61,0) N ZN "RTN","C0CMCCD",62,0) ;I $$TAG(ZOID)["entry" B "RTN","C0CMCCD",63,0) S ZN=$$NXTSIB(ZOID) "RTN","C0CMCCD",64,0) I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG "RTN","C0CMCCD",65,0) Q 0 "RTN","C0CMCCD",66,0) ; "RTN","C0CMCCD",67,0) FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID "RTN","C0CMCCD",68,0) Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMCCD",69,0) ; "RTN","C0CMCCD",70,0) PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID "RTN","C0CMCCD",71,0) Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMCCD",72,0) ; "RTN","C0CMCCD",73,0) ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID "RTN","C0CMCCD",74,0) S HANDLE=C0CDOCID "RTN","C0CMCCD",75,0) K @RTN "RTN","C0CMCCD",76,0) D GETTXT^MXMLDOM("A") "RTN","C0CMCCD",77,0) Q "RTN","C0CMCCD",78,0) ; "RTN","C0CMCCD",79,0) TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE "RTN","C0CMCCD",80,0) ;I ZOID=149 B ;GPLTEST "RTN","C0CMCCD",81,0) N X,Y "RTN","C0CMCCD",82,0) S Y="" "RTN","C0CMCCD",83,0) S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE "RTN","C0CMCCD",84,0) I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y "RTN","C0CMCCD",85,0) I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMCCD",86,0) Q Y "RTN","C0CMCCD",87,0) ; "RTN","C0CMCCD",88,0) NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING "RTN","C0CMCCD",89,0) Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMCCD",90,0) ; "RTN","C0CMCCD",91,0) DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE "RTN","C0CMCCD",92,0) ;N ZT,ZN S ZT="" "RTN","C0CMCCD",93,0) ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) "RTN","C0CMCCD",94,0) ;Q $G(@C0CDOM@(ZOID,"T",1)) "RTN","C0CMCCD",95,0) S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) "RTN","C0CMCCD",96,0) Q "RTN","C0CMCCD",97,0) ; "RTN","C0CMCCD",98,0) CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE "RTN","C0CMCCD",99,0) ; INARY AND OUTARY PASSED BY NAME "RTN","C0CMCCD",100,0) N ZI S ZI="" "RTN","C0CMCCD",101,0) F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH NODE "RTN","C0CMCCD",102,0) . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE "RTN","C0CMCCD",103,0) Q "RTN","C0CMCCD",104,0) ; "RTN","C0CMCCD",105,0) CLEAN(STR) ; extrinsic function; returns string "RTN","C0CMCCD",106,0) ;; Removes all non printable characters from a string. "RTN","C0CMCCD",107,0) ;; STR by Value "RTN","C0CMCCD",108,0) N TR,I "RTN","C0CMCCD",109,0) F I=0:1:31 S TR=$G(TR)_$C(I) "RTN","C0CMCCD",110,0) S TR=TR_$C(127) "RTN","C0CMCCD",111,0) QUIT $TR(STR,TR) "RTN","C0CMCCD",112,0) ; "RTN","C0CMCCD",113,0) STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE "RTN","C0CMCCD",114,0) ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE "RTN","C0CMCCD",115,0) ; THEY DO NOT WORK RIGHT WITH THE PARSER "RTN","C0CMCCD",116,0) ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER "RTN","C0CMCCD",117,0) S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER "RTN","C0CMCCD",118,0) D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY "RTN","C0CMCCD",119,0) F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE OF THE ARRAY "RTN","C0CMCCD",120,0) . I $O(@ZARY@(ZI))="" D Q ; AT THE END "RTN","C0CMCCD",121,0) . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY "RTN","C0CMCCD",122,0) . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE "RTN","C0CMCCD",123,0) . I @ZARY@(ZI)["" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN "RTN","C0CMCCD",125,0) S ZI="" "RTN","C0CMCCD",126,0) F S ZI=$O(ZWRK(ZI)) Q:ZI="" D ; MAKE A BUILD LIST FROM THE WORK ARRAY "RTN","C0CMCCD",127,0) . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2)) "RTN","C0CMCCD",128,0) D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS "RTN","C0CMCCD",129,0) K @OUTARY@(0) ; GET RID OF THE LINE COUNT "RTN","C0CMCCD",130,0) Q "RTN","C0CMCCD",131,0) ; "RTN","C0CMCCD",132,0) C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME "RTN","C0CMCCD",133,0) N ZI "RTN","C0CMCCD",134,0) S ZI=$O(@ZA@(""),-1) "RTN","C0CMCCD",135,0) I ZI="" S ZI=1 "RTN","C0CMCCD",136,0) E S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY "RTN","C0CMCCD",137,0) S $P(@ZA@(ZI),"^",1)=LN "RTN","C0CMCCD",138,0) Q "RTN","C0CMCCD",139,0) ; "RTN","C0CMCCD",140,0) C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME "RTN","C0CMCCD",141,0) N ZI "RTN","C0CMCCD",142,0) S ZI=$O(@ZB@(""),-1) "RTN","C0CMCCD",143,0) I ZI="" S ZI=1 "RTN","C0CMCCD",144,0) S $P(@ZB@(ZI),"^",2)=LN "RTN","C0CMCCD",145,0) Q "RTN","C0CMCCD",146,0) ; "RTN","C0CMCCD",147,0) SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR "RTN","C0CMCCD",148,0) ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc") "RTN","C0CMCCD",149,0) S ZI="" "RTN","C0CMCCD",150,0) F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY "RTN","C0CMCCD",151,0) . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES "RTN","C0CMCCD",152,0) . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor "RTN","C0CMCCD",153,0) . E D ; FOR BODY PARTS "RTN","C0CMCCD",154,0) . . S ZJ=$P(ZI,"/",2) ; "RTN","C0CMCCD",155,0) . . I ZJ="" S ZJ=$P(ZI,"/",3) ; "RTN","C0CMCCD",156,0) . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS "RTN","C0CMCCD",157,0) Q "RTN","C0CMCCD",158,0) ; "RTN","C0CMCCD",159,0) FINDTID ; FIND TEMPLATE IDS IN DOM 1 "RTN","C0CMCCD",160,0) S C0CDOCID=1 "RTN","C0CMCCD",161,0) S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) "RTN","C0CMCCD",162,0) S ZN="" "RTN","C0CMCCD",163,0) S CURSEC="" "RTN","C0CMCCD",164,0) S TID="" "RTN","C0CMCCD",165,0) F S ZN=$O(@ZD@(ZN)) Q:ZN="" D ; "RTN","C0CMCCD",166,0) . I $$TAG(ZN)="root" D ; "RTN","C0CMCCD",167,0) . . I $$TAG($$PARENT(ZN))="templateId" D ; ONLY LOOKING FOR TEMPLATES "RTN","C0CMCCD",168,0) . . . S ZG=$$PARENT($$PARENT(ZN)) "RTN","C0CMCCD",169,0) . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION "RTN","C0CMCCD",170,0) . . . S CMT=$G(@ZD@(ZG,"X",1)) "RTN","C0CMCCD",171,0) . . . I CMT="" S CMT="?" "RTN","C0CMCCD",172,0) . . . I $$TAG(ZG)="section" D ;START OF A SECTION "RTN","C0CMCCD",173,0) . . . . S CURSEC=$$PARENT(ZG) "RTN","C0CMCCD",174,0) . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1)) "RTN","C0CMCCD",175,0) . . . . I SECCMT="" S SECCMT="?" "RTN","C0CMCCD",176,0) . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID "RTN","C0CMCCD",177,0) . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID "RTN","C0CMCCD",178,0) . . . I CURSEC'="" D ; IF WE ARE IN A SECTION "RTN","C0CMCCD",179,0) . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID "RTN","C0CMCCD",180,0) . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID "RTN","C0CMCCD",181,0) . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1)) "RTN","C0CMCCD",182,0) . . . W " root ",ZN," ",@ZD@(ZN,"T",1) "RTN","C0CMCCD",183,0) Q "RTN","C0CMCCD",184,0) ; "RTN","C0CMCCD",185,0) FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS "RTN","C0CMCCD",186,0) ; "RTN","C0CMCCD",187,0) S ZI="" "RTN","C0CMCCD",188,0) F S ZI=$O(DOMMAP(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE MAP "RTN","C0CMCCD",189,0) . S ZJ=DOMMAP(ZI) ; "RTN","C0CMCCD",190,0) . S PARNODE=$P(ZJ,U,1) ;PARENT NODE "RTN","C0CMCCD",191,0) . S TAG=$P(ZJ,U,2) ;THIS TAG "RTN","C0CMCCD",192,0) . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID "RTN","C0CMCCD",193,0) . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID "RTN","C0CMCCD",194,0) . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN "RTN","C0CMCCD",195,0) . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN "RTN","C0CMCCD",196,0) . I ZI=PARNODE D ; IF THIS IS A SECTION NODE "RTN","C0CMCCD",197,0) . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT "RTN","C0CMCCD",198,0) . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE "RTN","C0CMCCD",199,0) . . W ZI," ",TAG," ",ALTTAG," ",NAME,! "RTN","C0CMCCD",200,0) . . S C0CTAGS(ZI)=ALTTAG "RTN","C0CMCCD",201,0) . E D ; NOT A SECTION NODE "RTN","C0CMCCD",202,0) . . N ZJ S ZJ="" "RTN","C0CMCCD",203,0) . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER? "RTN","C0CMCCD",204,0) . . I ZJ'="" D ; THERE IS A NEW LABEL FOR THIS NODE "RTN","C0CMCCD",205,0) . . . N ZK "RTN","C0CMCCD",206,0) . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2) "RTN","C0CMCCD",207,0) . . . I ZK'="" D ; "RTN","C0CMCCD",208,0) . . . . W "FOUND ",ZK,! "RTN","C0CMCCD",209,0) . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION "RTN","C0CMCCD",210,0) Q "RTN","C0CMCCD",211,0) ; "RTN","C0CMCCD",212,0) ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND "RTN","C0CMCCD",213,0) ; "RTN","C0CMCCD",214,0) S Y=$G(C0CTAGS(NODE)) "RTN","C0CMCCD",215,0) Q "RTN","C0CMCCD",216,0) ; "RTN","C0CMCCD",217,0) SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD "RTN","C0CMCCD",218,0) S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)" "RTN","C0CMCCD",219,0) Q "RTN","C0CMCCD",220,0) ; "RTN","C0CMCCD",221,0) OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE "RTN","C0CMCCD",222,0) ;D TEST3^C0CMXML "RTN","C0CMCCD",223,0) N ZT S ZT=$NA(^TMP("CCDOUT",$J)) "RTN","C0CMCCD",224,0) N ZI,ZJ "RTN","C0CMCCD",225,0) S ZI=1 S ZJ="" "RTN","C0CMCCD",226,0) K @ZT "RTN","C0CMCCD",227,0) F S ZJ=$O(GARYIN(ZJ)) Q:ZJ="" D ; "RTN","C0CMCCD",228,0) . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ) "RTN","C0CMCCD",229,0) . S ZI=ZI+1 "RTN","C0CMCCD",230,0) S ONAME=$NA(@ZT@(1)) "RTN","C0CMCCD",231,0) W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR") "RTN","C0CMCCD",232,0) K @ZT "RTN","C0CMCCD",233,0) Q "RTN","C0CMCCD",234,0) ; "RTN","C0CMCCD",235,0) GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY "RTN","C0CMCCD",236,0) ; ARRAY ELEMENTS LOOK LIKE: "RTN","C0CMCCD",237,0) ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31" "RTN","C0CMCCD",238,0) ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId "RTN","C0CMCCD",239,0) S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE "RTN","C0CMCCD",240,0) S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT "RTN","C0CMCCD",241,0) S DONE=0 "RTN","C0CMCCD",242,0) F Q:DONE D ; "RTN","C0CMCCD",243,0) . W @ZI,! "RTN","C0CMCCD",244,0) . S ZJ=$QS(ZI,5) "RTN","C0CMCCD",245,0) . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE "RTN","C0CMCCD",246,0) . S C0CFDA(ZF,"?+1,",.01)=ZJ "RTN","C0CMCCD",247,0) . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE "RTN","C0CMCCD",248,0) . S C0CFDA(ZF,"?+1,",1)=@ZI "RTN","C0CMCCD",249,0) . D UPDIE "RTN","C0CMCCD",250,0) . S ZI=$Q(@ZI) "RTN","C0CMCCD",251,0) . I ZI="" S DONE=1 "RTN","C0CMCCD",252,0) Q "RTN","C0CMCCD",253,0) ; "RTN","C0CMCCD",254,0) WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM "RTN","C0CMCCD",255,0) ; CCDDIR PASS BY NAME "RTN","C0CMCCD",256,0) ; ARRAY ELEMENTS LOOK LIKE: "RTN","C0CMCCD",257,0) ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31" "RTN","C0CMCCD",258,0) ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId "RTN","C0CMCCD",259,0) S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE "RTN","C0CMCCD",260,0) S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE "RTN","C0CMCCD",261,0) S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT "RTN","C0CMCCD",262,0) S DONE=0 "RTN","C0CMCCD",263,0) F Q:DONE D ; "RTN","C0CMCCD",264,0) . W @ZI "RTN","C0CMCCD",265,0) . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE "RTN","C0CMCCD",266,0) . W " IEN:",ZIEN "RTN","C0CMCCD",267,0) . S ZJ=$QS(ZI,2) "RTN","C0CMCCD",268,0) . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE "RTN","C0CMCCD",269,0) . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN "RTN","C0CMCCD",270,0) . W " PARENT IEN:",ZPIEN "RTN","C0CMCCD",271,0) . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE "RTN","C0CMCCD",272,0) . W " TAG:",ZTAG,! "RTN","C0CMCCD",273,0) . I ZIEN'=ZPIEN D ; ONLY FOR CHILD TEMPLATES "RTN","C0CMCCD",274,0) . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR "RTN","C0CMCCD",275,0) . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY "RTN","C0CMCCD",276,0) . . D UPDIE "RTN","C0CMCCD",277,0) . ;S C0CFDA(ZF,"?+1,",1)=@ZI "RTN","C0CMCCD",278,0) . ;D UPDIE "RTN","C0CMCCD",279,0) . S ZI=$Q(@ZI) "RTN","C0CMCCD",280,0) . I ZI="" S DONE=1 "RTN","C0CMCCD",281,0) Q "RTN","C0CMCCD",282,0) ; "RTN","C0CMCCD",283,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CMCCD",284,0) K ZERR "RTN","C0CMCCD",285,0) D CLEAN^DILF "RTN","C0CMCCD",286,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CMCCD",287,0) I $D(ZERR) D ; "RTN","C0CMCCD",288,0) . W "ERROR",! "RTN","C0CMCCD",289,0) . ZWR ZERR "RTN","C0CMCCD",290,0) . B "RTN","C0CMCCD",291,0) K C0CFDA "RTN","C0CMCCD",292,0) Q "RTN","C0CMCCD",293,0) ; "RTN","C0CMED") 0^31^B18939705 "RTN","C0CMED",1,0) C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 "RTN","C0CMED",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CMED",3,0) ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. "RTN","C0CMED",4,0) ; Licensed under the terms of the GNU General Public License. "RTN","C0CMED",5,0) ; See attached copy of the License. "RTN","C0CMED",6,0) ; "RTN","C0CMED",7,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CMED",8,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CMED",9,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CMED",10,0) ; (at your option) any later version. "RTN","C0CMED",11,0) ; "RTN","C0CMED",12,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CMED",13,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMED",14,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMED",15,0) ; GNU General Public License for more details. "RTN","C0CMED",16,0) ; "RTN","C0CMED",17,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CMED",18,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMED",19,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMED",20,0) ; "RTN","C0CMED",21,0) ; --Revision History "RTN","C0CMED",22,0) ; July 2008 - Initial Version/GPL "RTN","C0CMED",23,0) ; July 2008 - March 2009 various revisions "RTN","C0CMED",24,0) ; March 2009 - Reconstruction of routine as driver for other med routines/SMH "RTN","C0CMED",25,0) ; "RTN","C0CMED",26,0) Q "RTN","C0CMED",27,0) EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template "RTN","C0CMED",28,0) ; DFN passed by reference "RTN","C0CMED",29,0) ; MEDXML and MEDOUTXML are passed by Name "RTN","C0CMED",30,0) ; MEDXML is the input template "RTN","C0CMED",31,0) ; MEDOUTXML is the output template "RTN","C0CMED",32,0) ; Both of them refer to ^TMP globals where the XML documents are stored "RTN","C0CMED",33,0) ; "RTN","C0CMED",34,0) ; -- This ep is the driver for extracting medications into the provided XML template "RTN","C0CMED",35,0) ; 1. VA Outpatient Meds are in C0CMED1 "RTN","C0CMED",36,0) ; 2. VA Pending Meds are in C0CMED2 "RTN","C0CMED",37,0) ; 3. VA non-VA Meds are in C0CMED3 "RTN","C0CMED",38,0) ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional) "RTN","C0CMED",39,0) ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009 "RTN","C0CMED",40,0) ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time. "RTN","C0CMED",41,0) ; "RTN","C0CMED",42,0) ; --Get parameters for meds "RTN","C0CMED",43,0) S @MEDOUTXML@(0)=0 ; By default, empty. "RTN","C0CMED",44,0) N C0CMFLAG "RTN","C0CMED",45,0) S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING") "RTN","C0CMED",46,0) W:$G(DEBUG) "Med Parameters: ",! "RTN","C0CMED",47,0) W:$G(DEBUG) "ALL: ",+C0CMFLAG,! "RTN","C0CMED",48,0) W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),! "RTN","C0CMED",49,0) W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),! "RTN","C0CMED",50,0) W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),! "RTN","C0CMED",51,0) ; --Find out what system we are on and branch out... "RTN","C0CMED",52,0) W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG")) "RTN","C0CMED",53,0) I $$RPMS^C0CUTIL() D RPMS QUIT "RTN","C0CMED",54,0) I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT "RTN","C0CMED",55,0) RPMS "RTN","C0CMED",56,0) ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT "RTN","C0CMED",57,0) N MEDCOUNT S MEDCOUNT=0 "RTN","C0CMED",58,0) K ^TMP($J,"MED") "RTN","C0CMED",59,0) N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed "RTN","C0CMED",60,0) N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds "RTN","C0CMED",61,0) S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) "RTN","C0CMED",62,0) D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds "RTN","C0CMED",63,0) D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds "RTN","C0CMED",64,0) I @HIST@(0)>0 D "RTN","C0CMED",65,0) . D CP^C0CXPATH(HIST,MEDOUTXML) "RTN","C0CMED",66,0) . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! "RTN","C0CMED",67,0) I @NVA@(0)>0 D "RTN","C0CMED",68,0) . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) "RTN","C0CMED",69,0) . ;E D CP^C0CXPATH(NVA,MEDOUTXML) "RTN","C0CMED",70,0) . W:$G(DEBUG) "HAS NON-VA MEDS",! "RTN","C0CMED",71,0) Q "RTN","C0CMED",72,0) VISTA "RTN","C0CMED",73,0) N MEDCOUNT S MEDCOUNT=0 "RTN","C0CMED",74,0) K ^TMP($J,"MED") "RTN","C0CMED",75,0) N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed "RTN","C0CMED",76,0) N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds "RTN","C0CMED",77,0) N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds "RTN","C0CMED",78,0) K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY "RTN","C0CMED",79,0) S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) "RTN","C0CMED",80,0) ; N IPIV ; Inpatient IV Meds "RTN","C0CMED",81,0) N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds "RTN","C0CMED",82,0) K @IPUD "RTN","C0CMED",83,0) S @IPUD@(0)=0 "RTN","C0CMED",84,0) ; "RTN","C0CMED",85,0) D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds "RTN","C0CMED",86,0) D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds "RTN","C0CMED",87,0) ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds "RTN","C0CMED",88,0) D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL "RTN","C0CMED",89,0) D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl "RTN","C0CMED",90,0) I @HIST@(0)>0 D "RTN","C0CMED",91,0) . D CP^C0CXPATH(HIST,MEDOUTXML) "RTN","C0CMED",92,0) . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! "RTN","C0CMED",93,0) I @PEND@(0)>0 D "RTN","C0CMED",94,0) . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical "RTN","C0CMED",95,0) . E D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy "RTN","C0CMED",96,0) . W:$G(DEBUG) "HAS OP PENDING MEDS",! "RTN","C0CMED",97,0) I @NVA@(0)>0 D "RTN","C0CMED",98,0) . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) "RTN","C0CMED",99,0) . E D CP^C0CXPATH(NVA,MEDOUTXML) "RTN","C0CMED",100,0) . W:$G(DEBUG) "HAS NON-VA MEDS",! "RTN","C0CMED",101,0) I @IPUD@(0)>0 D "RTN","C0CMED",102,0) . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) "RTN","C0CMED",103,0) . E D CP^C0CXPATH(IPUD,MEDOUTXML) "RTN","C0CMED",104,0) . W:$G(DEBUG) "HAS INPATIENT MEDS",! "RTN","C0CMED",105,0) N ZI "RTN","C0CMED",106,0) S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) "RTN","C0CMED",107,0) M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES "RTN","C0CMED",108,0) K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10 "RTN","C0CMED",109,0) K @PEND "RTN","C0CMED",110,0) K @HIST "RTN","C0CMED",111,0) K @NVA "RTN","C0CMED",112,0) K @IPUD "RTN","C0CMED",113,0) Q "RTN","C0CMED",114,0) "RTN","C0CMED1") 0^32^B110909428 "RTN","C0CMED1",1,0) C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 "RTN","C0CMED1",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CMED1",3,0) ;;Last modified Sat Jan 10 21:42:27 PST 2009 "RTN","C0CMED1",4,0) ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU "RTN","C0CMED1",5,0) ; General Public License See attached copy of the License. "RTN","C0CMED1",6,0) ; "RTN","C0CMED1",7,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CMED1",8,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CMED1",9,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CMED1",10,0) ; (at your option) any later version. "RTN","C0CMED1",11,0) ; "RTN","C0CMED1",12,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CMED1",13,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMED1",14,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMED1",15,0) ; GNU General Public License for more details. "RTN","C0CMED1",16,0) ; "RTN","C0CMED1",17,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CMED1",18,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMED1",19,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMED1",20,0) ; "RTN","C0CMED1",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CMED1",22,0) Q "RTN","C0CMED1",23,0) ; "RTN","C0CMED1",24,0) EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","C0CMED1",25,0) ; "RTN","C0CMED1",26,0) ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CMED1",27,0) ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE "RTN","C0CMED1",28,0) ; "RTN","C0CMED1",29,0) ; MEDS is return array from RPC. "RTN","C0CMED1",30,0) ; MAP is a mapping variable map (store result) for each med "RTN","C0CMED1",31,0) ; MED is holds each array element from MEDS(J), one medicine "RTN","C0CMED1",32,0) ; MEDCOUNT is a counter passed by Reference. "RTN","C0CMED1",33,0) ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) "RTN","C0CMED1",34,0) ; FLAGS are set-up in C0CMED. "RTN","C0CMED1",35,0) ; "RTN","C0CMED1",36,0) ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all "RTN","C0CMED1",37,0) ; med data available. "RTN","C0CMED1",38,0) ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf "RTN","C0CMED1",39,0) ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). "RTN","C0CMED1",40,0) ; D PARY^C0CXPATH(MINXML) "RTN","C0CMED1",41,0) N MEDS,MAP "RTN","C0CMED1",42,0) K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! "RTN","C0CMED1",43,0) N ALL S ALL=+FLAGS "RTN","C0CMED1",44,0) N ACTIVE S ACTIVE=$P(FLAGS,U,3) "RTN","C0CMED1",45,0) ; Below, X1 is today; X2 is the number of days we want to go back "RTN","C0CMED1",46,0) ; X is the result of this calculation using C^%DTC. "RTN","C0CMED1",47,0) N X,X1,X2 "RTN","C0CMED1",48,0) S X1=DT "RTN","C0CMED1",49,0) S X2=-$P($P(FLAGS,U,2),"-",2) "RTN","C0CMED1",50,0) D C^%DTC "RTN","C0CMED1",51,0) ; I discovered that I shouldn't put an ending date (last parameter) "RTN","C0CMED1",52,0) ; because it seems that it will get meds whose beginning is after X but "RTN","C0CMED1",53,0) ; whose exipriation is before the ending date. "RTN","C0CMED1",54,0) D RX^PSO52API(DFN,"CCDCCR","","","",X,"") "RTN","C0CMED1",55,0) M MEDS=^TMP($J,"CCDCCR",DFN) "RTN","C0CMED1",56,0) ; @(0) contains the number of meds or -1^NO DATA FOUND "RTN","C0CMED1",57,0) ; If it is -1, we quit. "RTN","C0CMED1",58,0) I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q "RTN","C0CMED1",59,0) ZWRITE:$G(DEBUG) MEDS "RTN","C0CMED1",60,0) N RXIEN S RXIEN=0 "RTN","C0CMED1",61,0) F S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)="" D ; FOR EACH MEDICATION IN THE LIST "RTN","C0CMED1",62,0) . N MED M MED=MEDS(RXIEN) "RTN","C0CMED1",63,0) . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT "RTN","C0CMED1",64,0) . S MEDCOUNT=MEDCOUNT+1 "RTN","C0CMED1",65,0) . W:$G(DEBUG) "RXIEN IS ",RXIEN,! "RTN","C0CMED1",66,0) . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) "RTN","C0CMED1",67,0) . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED "RTN","C0CMED1",68,0) . W:$G(DEBUG) "MAP= ",MAP,! "RTN","C0CMED1",69,0) . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID "RTN","C0CMED1",70,0) . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number "RTN","C0CMED1",71,0) . S @MAP@("MEDISSUEDATETXT")="Issue Date" "RTN","C0CMED1",72,0) . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U)) "RTN","C0CMED1",73,0) . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" "RTN","C0CMED1",74,0) . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U)) "RTN","C0CMED1",75,0) . S @MAP@("MEDRXNOTXT")="Prescription Number" "RTN","C0CMED1",76,0) . S @MAP@("MEDRXNO")=MED(.01) "RTN","C0CMED1",77,0) . S @MAP@("MEDTYPETEXT")="Medication" "RTN","C0CMED1",78,0) . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses "RTN","C0CMED1",79,0) . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) "RTN","C0CMED1",80,0) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) "RTN","C0CMED1",81,0) . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) "RTN","C0CMED1",82,0) . ; 12/30/08: I will be using RxNorm for coding... "RTN","C0CMED1",83,0) . ; 176.001 is the file for Concepts; 176.003 is the file for "RTN","C0CMED1",84,0) . ; sources (i.e. for RxNorm Version) "RTN","C0CMED1",85,0) . ; "RTN","C0CMED1",86,0) . ; We need the VUID first for the National Drug File entry first "RTN","C0CMED1",87,0) . ; We get the VUID of the drug, by looking up the VA Product entry "RTN","C0CMED1",88,0) . ; (file 50.68) using the call NDF^PSS50, returned in node 22. "RTN","C0CMED1",89,0) . ; Field 99.99 is the VUID. "RTN","C0CMED1",90,0) . ; "RTN","C0CMED1",91,0) . ; We use the VUID to look up the RxNorm in file 176.001; same idea. "RTN","C0CMED1",92,0) . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by "RTN","C0CMED1",93,0) . ; $$GET1^DIQ. "RTN","C0CMED1",94,0) . ; "RTN","C0CMED1",95,0) . ; I get the RxNorm name and version from the RxNorm Sources (file "RTN","C0CMED1",96,0) . ; 176.003), by searching for "RXNORM", then get the data. "RTN","C0CMED1",97,0) . N MEDIEN S MEDIEN=$P(MED(6),U) "RTN","C0CMED1",98,0) . D NDF^PSS50(MEDIEN,,,,,"NDF") "RTN","C0CMED1",99,0) . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) "RTN","C0CMED1",100,0) . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) "RTN","C0CMED1",101,0) . N VAPROD S VAPROD=$P(NDFDATA(22),U) "RTN","C0CMED1",102,0) . ; "RTN","C0CMED1",103,0) . ; NDFIEN is not necessarily defined; it won't be if the drug "RTN","C0CMED1",104,0) . ; is not matched to the national drug file (e.g. if the drug is "RTN","C0CMED1",105,0) . ; new on the market, compounded, or is a fake drug [blue pill]. "RTN","C0CMED1",106,0) . ; To protect against failure, I will put an if/else block "RTN","C0CMED1",107,0) . ; "RTN","C0CMED1",108,0) . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER "RTN","C0CMED1",109,0) . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. "RTN","C0CMED1",110,0) . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) "RTN","C0CMED1",111,0) . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") "RTN","C0CMED1",112,0) . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) "RTN","C0CMED1",113,0) . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") "RTN","C0CMED1",114,0) . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) "RTN","C0CMED1",115,0) . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) "RTN","C0CMED1",116,0) . ; "RTN","C0CMED1",117,0) . E S (RXNORM,RXNNAME,RXNVER)="" "RTN","C0CMED1",118,0) . ; End if/else block "RTN","C0CMED1",119,0) . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM "RTN","C0CMED1",120,0) . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME "RTN","C0CMED1",121,0) . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER "RTN","C0CMED1",122,0) . ; "RTN","C0CMED1",123,0) . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) "RTN","C0CMED1",124,0) . D DOSE^PSS50(MEDIEN,,,,,"DOSE") "RTN","C0CMED1",125,0) . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) "RTN","C0CMED1",126,0) . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) "RTN","C0CMED1",127,0) . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) "RTN","C0CMED1",128,0) . ; Units, concentration, etc, come from another call "RTN","C0CMED1",129,0) . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit "RTN","C0CMED1",130,0) . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters "RTN","C0CMED1",131,0) . ; NDF Entry IEN, and VA Product IEN "RTN","C0CMED1",132,0) . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") "RTN","C0CMED1",133,0) . ; These have been collected above. "RTN","C0CMED1",134,0) . N CONCDATA "RTN","C0CMED1",135,0) . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" "RTN","C0CMED1",136,0) . ; and this will crash the call. So... "RTN","C0CMED1",137,0) . I NDFIEN="" S CONCDATA="" "RTN","C0CMED1",138,0) . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) "RTN","C0CMED1",139,0) . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) "RTN","C0CMED1",140,0) . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) "RTN","C0CMED1",141,0) . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) "RTN","C0CMED1",142,0) . S @MAP@("MEDQUANTITYVALUE")=MED(7) "RTN","C0CMED1",143,0) . ; Oddly, there is no easy place to find the dispense unit. "RTN","C0CMED1",144,0) . ; It's not included in the original call, so we have to go to the drug file. "RTN","C0CMED1",145,0) . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") "RTN","C0CMED1",146,0) . ; Node 14.5 is the Dispense Unit "RTN","C0CMED1",147,0) . D DATA^PSS50(MEDIEN,,,,,"QTY") "RTN","C0CMED1",148,0) . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) "RTN","C0CMED1",149,0) . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) "RTN","C0CMED1",150,0) . ; "RTN","C0CMED1",151,0) . ; --- START OF DIRECTIONS --- "RTN","C0CMED1",152,0) . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... "RTN","C0CMED1",153,0) . ; we want the compoenents. "RTN","C0CMED1",154,0) . ; It's in node 6 of ^PSRX(IEN) "RTN","C0CMED1",155,0) . ; So, here we go again "RTN","C0CMED1",156,0) . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE "RTN","C0CMED1",157,0) . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) "RTN","C0CMED1",158,0) . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE "RTN","C0CMED1",159,0) . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ "RTN","C0CMED1",160,0) . ; "RTN","C0CMED1",161,0) . N DIRNUM S DIRNUM=0 ; Sigline number "RTN","C0CMED1",162,0) . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS "RTN","C0CMED1",163,0) . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D "RTN","C0CMED1",164,0) . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT "RTN","C0CMED1",165,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. "RTN","C0CMED1",166,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. "RTN","C0CMED1",167,0) . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) "RTN","C0CMED1",168,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) "RTN","C0CMED1",169,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) "RTN","C0CMED1",170,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") "RTN","C0CMED1",171,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient "RTN","C0CMED1",172,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient "RTN","C0CMED1",173,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient "RTN","C0CMED1",174,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) "RTN","C0CMED1",175,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) "RTN","C0CMED1",176,0) . . ; Invervals... again another call. "RTN","C0CMED1",177,0) . . ; In the wisdom of the original programmers, the schedule is a free text field "RTN","C0CMED1",178,0) . . ; However, it gets translated by a call to the administration schedule file "RTN","C0CMED1",179,0) . . ; to see if that schedule exists. "RTN","C0CMED1",180,0) . . ; That's the same thing I am going to do. "RTN","C0CMED1",181,0) . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). "RTN","C0CMED1",182,0) . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- "RTN","C0CMED1",183,0) . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. "RTN","C0CMED1",184,0) . . ; So... "RTN","C0CMED1",185,0) . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") "RTN","C0CMED1",186,0) . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") "RTN","C0CMED1",187,0) . . N INTERVAL "RTN","C0CMED1",188,0) . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" "RTN","C0CMED1",189,0) . . E D "RTN","C0CMED1",190,0) . . . N SUB S SUB=$O(SCHEDATA(0)) "RTN","C0CMED1",191,0) . . . S INTERVAL=SCHEDATA(SUB,2) "RTN","C0CMED1",192,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL "RTN","C0CMED1",193,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" "RTN","C0CMED1",194,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) "RTN","C0CMED1",195,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" "RTN","C0CMED1",196,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" "RTN","C0CMED1",197,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" "RTN","C0CMED1",198,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" "RTN","C0CMED1",199,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" "RTN","C0CMED1",200,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" "RTN","C0CMED1",201,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" "RTN","C0CMED1",202,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" "RTN","C0CMED1",203,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" "RTN","C0CMED1",204,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" "RTN","C0CMED1",205,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM "RTN","C0CMED1",206,0) . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) "RTN","C0CMED1",207,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") "RTN","C0CMED1",208,0) . ; "RTN","C0CMED1",209,0) . ; --- END OF DIRECTIONS --- "RTN","C0CMED1",210,0) . ; "RTN","C0CMED1",211,0) . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" "RTN","C0CMED1",212,0) . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) "RTN","C0CMED1",213,0) . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" "RTN","C0CMED1",214,0) . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) "RTN","C0CMED1",215,0) . S @MAP@("MEDRFNO")=MED(9) "RTN","C0CMED1",216,0) . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) "RTN","C0CMED1",217,0) . K @RESULT "RTN","C0CMED1",218,0) . D MAP^C0CXPATH(MINXML,MAP,RESULT) "RTN","C0CMED1",219,0) . ; MAPPING DIRECTIONS "RTN","C0CMED1",220,0) . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CMED1",221,0) . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CMED1",222,0) . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) "RTN","C0CMED1",223,0) . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") "RTN","C0CMED1",224,0) . ; N MDZ1,MDZNA "RTN","C0CMED1",225,0) . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS "RTN","C0CMED1",226,0) . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION "RTN","C0CMED1",227,0) . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) "RTN","C0CMED1",228,0) . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) "RTN","C0CMED1",229,0) . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") "RTN","C0CMED1",230,0) . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CMED1",231,0) . E D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML "RTN","C0CMED1",232,0) N MEDTMP,MEDI "RTN","C0CMED1",233,0) D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CMED1",234,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CMED1",235,0) . W "MEDICATION MISSING ",! "RTN","C0CMED1",236,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","C0CMED1",237,0) Q "RTN","C0CMED1",238,0) ; "RTN","C0CMED2") 0^33^B144699326 "RTN","C0CMED2",1,0) C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista "RTN","C0CMED2",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CMED2",3,0) ;;Last Modified Sat Jan 10 21:41:14 PST 2009 "RTN","C0CMED2",4,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CMED2",5,0) ; General Public License See attached copy of the License. "RTN","C0CMED2",6,0) ; "RTN","C0CMED2",7,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CMED2",8,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CMED2",9,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CMED2",10,0) ; (at your option) any later version. "RTN","C0CMED2",11,0) ; "RTN","C0CMED2",12,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CMED2",13,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMED2",14,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMED2",15,0) ; GNU General Public License for more details. "RTN","C0CMED2",16,0) ; "RTN","C0CMED2",17,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CMED2",18,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMED2",19,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMED2",20,0) ; "RTN","C0CMED2",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CMED2",22,0) Q "RTN","C0CMED2",23,0) ; "RTN","C0CMED2",24,0) EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","C0CMED2",25,0) ; "RTN","C0CMED2",26,0) ; MINXML is the Input XML Template, passed by name "RTN","C0CMED2",27,0) ; DFN is Patient IEN (by Value) "RTN","C0CMED2",28,0) ; OUTXML is the resultant XML (by Name) "RTN","C0CMED2",29,0) ; MEDCOUNT is the current count of extracted meds, passed by Reference "RTN","C0CMED2",30,0) ; "RTN","C0CMED2",31,0) ; MEDS is return array from RPC. "RTN","C0CMED2",32,0) ; MAP is a mapping variable map (store result) for each med "RTN","C0CMED2",33,0) ; MED is holds each array element from MEDS, one medicine "RTN","C0CMED2",34,0) ; "RTN","C0CMED2",35,0) ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending "RTN","C0CMED2",36,0) ; meds data available. "RTN","C0CMED2",37,0) ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf "RTN","C0CMED2",38,0) ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). "RTN","C0CMED2",39,0) ; File for pending meds is 52.41 "RTN","C0CMED2",40,0) ; Unfortuantely, API does not supply us with any useful info beyond "RTN","C0CMED2",41,0) ; the IEN in 52.41, and the Med Name, and route. "RTN","C0CMED2",42,0) ; So, most of the info is going to get pulled from 52.41. "RTN","C0CMED2",43,0) N MEDS,MAP "RTN","C0CMED2",44,0) K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! "RTN","C0CMED2",45,0) D PEN^PSO5241(DFN,"CCDCCR") "RTN","C0CMED2",46,0) M MEDS=^TMP($J,"CCDCCR",DFN) "RTN","C0CMED2",47,0) ; @(0) contains the number of meds or -1^NO DATA FOUND "RTN","C0CMED2",48,0) ; If it is -1, we quit. "RTN","C0CMED2",49,0) I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT "RTN","C0CMED2",50,0) ZWRITE:$G(DEBUG) MEDS "RTN","C0CMED2",51,0) N RXIEN S RXIEN=0 "RTN","C0CMED2",52,0) N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING "RTN","C0CMED2",53,0) F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST "RTN","C0CMED2",54,0) . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order "RTN","C0CMED2",55,0) . S MEDCOUNT=MEDCOUNT+1 "RTN","C0CMED2",56,0) . I DEBUG W "RXIEN IS ",RXIEN,! "RTN","C0CMED2",57,0) . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) "RTN","C0CMED2",58,0) . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED "RTN","C0CMED2",59,0) . I DEBUG W "MAP= ",MAP,! "RTN","C0CMED2",60,0) . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM "RTN","C0CMED2",61,0) . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID "RTN","C0CMED2",62,0) . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN "RTN","C0CMED2",63,0) . S @MAP@("MEDISSUEDATETXT")="Issue Date" "RTN","C0CMED2",64,0) . ; Field 6 is "Effective date", and we pull it in timson format w/ I "RTN","C0CMED2",65,0) . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") "RTN","C0CMED2",66,0) . ; Med never filled; next 4 fields are not applicable. "RTN","C0CMED2",67,0) . S @MAP@("MEDLASTFILLDATETXT")="" "RTN","C0CMED2",68,0) . S @MAP@("MEDLASTFILLDATE")="" "RTN","C0CMED2",69,0) . S @MAP@("MEDRXNOTXT")="" "RTN","C0CMED2",70,0) . S @MAP@("MEDRXNO")="" "RTN","C0CMED2",71,0) . S @MAP@("MEDTYPETEXT")="Medication" "RTN","C0CMED2",72,0) . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses "RTN","C0CMED2",73,0) . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds "RTN","C0CMED2",74,0) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") "RTN","C0CMED2",75,0) . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) "RTN","C0CMED2",76,0) . ; NDC not supplied in API, but is rather trivial to obtain "RTN","C0CMED2",77,0) . ; MED(11) piece 1 has the IEN of the drug (file 50) "RTN","C0CMED2",78,0) . ; IEN is field 31 in the drug file. "RTN","C0CMED2",79,0) . ; "RTN","C0CMED2",80,0) . ; MEDIEN (node 11 in the returned output) might not necessarily be defined "RTN","C0CMED2",81,0) . ; It is not defined when a dose in not chosen in CPRS. There is a long "RTN","C0CMED2",82,0) . ; series of fields that depend on it. We will use If and Else to deal "RTN","C0CMED2",83,0) . ; with that "RTN","C0CMED2",84,0) . N MEDIEN S MEDIEN=$P(MED(11),U) "RTN","C0CMED2",85,0) . I +MEDIEN>0 D ; start of if/else block "RTN","C0CMED2",86,0) . . ; 12/30/08: I will be using RxNorm for coding... "RTN","C0CMED2",87,0) . . ; 176.001 is the file for Concepts; 176.003 is the file for "RTN","C0CMED2",88,0) . . ; sources (i.e. for RxNorm Version) "RTN","C0CMED2",89,0) . . ; "RTN","C0CMED2",90,0) . . ; We need the VUID first for the National Drug File entry first "RTN","C0CMED2",91,0) . . ; We get the VUID of the drug, by looking up the VA Product entry "RTN","C0CMED2",92,0) . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. "RTN","C0CMED2",93,0) . . ; Field 99.99 is the VUID. "RTN","C0CMED2",94,0) . . ; "RTN","C0CMED2",95,0) . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. "RTN","C0CMED2",96,0) . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by "RTN","C0CMED2",97,0) . . ; $$GET1^DIQ. "RTN","C0CMED2",98,0) . . ; "RTN","C0CMED2",99,0) . . ; I get the RxNorm name and version from the RxNorm Sources (file "RTN","C0CMED2",100,0) . . ; 176.003), by searching for "RXNORM", then get the data. "RTN","C0CMED2",101,0) . . D NDF^PSS50(MEDIEN,,,,,"NDF") "RTN","C0CMED2",102,0) . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) "RTN","C0CMED2",103,0) . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) "RTN","C0CMED2",104,0) . . N VAPROD S VAPROD=$P(NDFDATA(22),U) "RTN","C0CMED2",105,0) . . ; "RTN","C0CMED2",106,0) . . ; NDFIEN is not necessarily defined; it won't be if the drug "RTN","C0CMED2",107,0) . . ; is not matched to the national drug file (e.g. if the drug is "RTN","C0CMED2",108,0) . . ; new on the market, compounded, or is a fake drug [blue pill]. "RTN","C0CMED2",109,0) . . ; To protect against failure, I will put an if/else block "RTN","C0CMED2",110,0) . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER "RTN","C0CMED2",111,0) . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. "RTN","C0CMED2",112,0) . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) "RTN","C0CMED2",113,0) . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") "RTN","C0CMED2",114,0) . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) "RTN","C0CMED2",115,0) . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") "RTN","C0CMED2",116,0) . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) "RTN","C0CMED2",117,0) . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) "RTN","C0CMED2",118,0) . . ; "RTN","C0CMED2",119,0) . . E S (RXNORM,RXNNAME,RXNVER)="" "RTN","C0CMED2",120,0) . . ; End if/else block "RTN","C0CMED2",121,0) . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM "RTN","C0CMED2",122,0) . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME "RTN","C0CMED2",123,0) . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER "RTN","C0CMED2",124,0) . . ; "RTN","C0CMED2",125,0) . . S @MAP@("MEDBRANDNAMETEXT")="" "RTN","C0CMED2",126,0) . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") "RTN","C0CMED2",127,0) . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) "RTN","C0CMED2",128,0) . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) "RTN","C0CMED2",129,0) . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) "RTN","C0CMED2",130,0) . . ; Units, concentration, etc, come from another call "RTN","C0CMED2",131,0) . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit "RTN","C0CMED2",132,0) . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters "RTN","C0CMED2",133,0) . . ; NDF Entry IEN, and VA Product Name "RTN","C0CMED2",134,0) . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") "RTN","C0CMED2",135,0) . . ; Documented in the same manual; executed above. "RTN","C0CMED2",136,0) . . N CONCDATA "RTN","C0CMED2",137,0) . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" "RTN","C0CMED2",138,0) . . ; and this will crash the call. So... "RTN","C0CMED2",139,0) . . I NDFIEN="" S CONCDATA="" "RTN","C0CMED2",140,0) . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) "RTN","C0CMED2",141,0) . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) "RTN","C0CMED2",142,0) . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) "RTN","C0CMED2",143,0) . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) "RTN","C0CMED2",144,0) . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) "RTN","C0CMED2",145,0) . . ; Oddly, there is no easy place to find the dispense unit. "RTN","C0CMED2",146,0) . . ; It's not included in the original call, so we have to go to the drug file. "RTN","C0CMED2",147,0) . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") "RTN","C0CMED2",148,0) . . ; Node 14.5 is the Dispense Unit "RTN","C0CMED2",149,0) . . D DATA^PSS50(MEDIEN,,,,,"QTY") "RTN","C0CMED2",150,0) . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) "RTN","C0CMED2",151,0) . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) "RTN","C0CMED2",152,0) . E D "RTN","C0CMED2",153,0) . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" "RTN","C0CMED2",154,0) . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" "RTN","C0CMED2",155,0) . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" "RTN","C0CMED2",156,0) . . S @MAP@("MEDBRANDNAMETEXT")="" "RTN","C0CMED2",157,0) . . S @MAP@("MEDSTRENGTHVALUE")="" "RTN","C0CMED2",158,0) . . S @MAP@("MEDSTRENGTHUNIT")="" "RTN","C0CMED2",159,0) . . S @MAP@("MEDFORMTEXT")="" "RTN","C0CMED2",160,0) . . S @MAP@("MEDCONCVALUE")="" "RTN","C0CMED2",161,0) . . S @MAP@("MEDCONCUNIT")="" "RTN","C0CMED2",162,0) . . S @MAP@("MEDSIZETEXT")="" "RTN","C0CMED2",163,0) . . S @MAP@("MEDQUANTITYVALUE")="" "RTN","C0CMED2",164,0) . . S @MAP@("MEDQUANTITYUNIT")="" "RTN","C0CMED2",165,0) . ; end of if/else block "RTN","C0CMED2",166,0) . ; "RTN","C0CMED2",167,0) . ; --- START OF DIRECTIONS --- "RTN","C0CMED2",168,0) . ; Sig data is not in any API. We obtain it using the IEN from "RTN","C0CMED2",169,0) . ; the PEN API to file 52.41. It's in field 3, which is a multiple. "RTN","C0CMED2",170,0) . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) "RTN","C0CMED2",171,0) . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call "RTN","C0CMED2",172,0) . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") "RTN","C0CMED2",173,0) . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. "RTN","C0CMED2",174,0) . ; FMSIGNUM gets outputted as "IEN,RXIEN,". "RTN","C0CMED2",175,0) . ; DIRNUM will be first piece for IEN. "RTN","C0CMED2",176,0) . ; DIRNUM is the proper Sigline numer. "RTN","C0CMED2",177,0) . ; SIGDATA is the simplfied array. Subscripts are really field numbers "RTN","C0CMED2",178,0) . ; in subfile 52.413. "RTN","C0CMED2",179,0) . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS "RTN","C0CMED2",180,0) . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D "RTN","C0CMED2",181,0) . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") "RTN","C0CMED2",182,0) . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT "RTN","C0CMED2",183,0) . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) "RTN","C0CMED2",184,0) . . ; If this is an order for a refill; it's not really a new order; move on to next "RTN","C0CMED2",185,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. "RTN","C0CMED2",186,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. "RTN","C0CMED2",187,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) "RTN","C0CMED2",188,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) "RTN","C0CMED2",189,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") "RTN","C0CMED2",190,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient "RTN","C0CMED2",191,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient "RTN","C0CMED2",192,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient "RTN","C0CMED2",193,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) "RTN","C0CMED2",194,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) "RTN","C0CMED2",195,0) . . ; Invervals... again another call. "RTN","C0CMED2",196,0) . . ; The schedule is a free text field "RTN","C0CMED2",197,0) . . ; However, it gets translated by a call to the administration "RTN","C0CMED2",198,0) . . ; schedule file to see if that schedule exists. "RTN","C0CMED2",199,0) . . ; That's the same thing I am going to do. "RTN","C0CMED2",200,0) . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). "RTN","C0CMED2",201,0) . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- "RTN","C0CMED2",202,0) . . ; I looked), PSSFT is the name, "RTN","C0CMED2",203,0) . . ; and list is the ^TMP name to store the data in. "RTN","C0CMED2",204,0) . . ; Also, freqency may have "PRN" in it, so strip that out "RTN","C0CMED2",205,0) . . N FREQ S FREQ=SIGDATA(1) "RTN","C0CMED2",206,0) . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp "RTN","C0CMED2",207,0) . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") "RTN","C0CMED2",208,0) . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") "RTN","C0CMED2",209,0) . . N INTERVAL "RTN","C0CMED2",210,0) . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" "RTN","C0CMED2",211,0) . . E D "RTN","C0CMED2",212,0) . . . N SUB S SUB=$O(SCHEDATA(0)) "RTN","C0CMED2",213,0) . . . S INTERVAL=SCHEDATA(SUB,2) "RTN","C0CMED2",214,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL "RTN","C0CMED2",215,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" "RTN","C0CMED2",216,0) . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months "RTN","C0CMED2",217,0) . . N DUR S DUR=SIGDATA(2) "RTN","C0CMED2",218,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) "RTN","C0CMED2",219,0) . . N DURUNIT S DURUNIT=$E(DUR) "RTN","C0CMED2",220,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") "RTN","C0CMED2",221,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" "RTN","C0CMED2",222,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" "RTN","C0CMED2",223,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" "RTN","C0CMED2",224,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" "RTN","C0CMED2",225,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" "RTN","C0CMED2",226,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" "RTN","C0CMED2",227,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" "RTN","C0CMED2",228,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" "RTN","C0CMED2",229,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field "RTN","C0CMED2",230,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM "RTN","C0CMED2",231,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) "RTN","C0CMED2",232,0) . ; "RTN","C0CMED2",233,0) . ; --- END OF DIRECTIONS --- "RTN","C0CMED2",234,0) . ; "RTN","C0CMED2",235,0) . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" "RTN","C0CMED2",236,0) . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL "RTN","C0CMED2",237,0) . ; W @MAP@("MEDPTINSTRUCTIONS"),! "RTN","C0CMED2",238,0) . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" "RTN","C0CMED2",239,0) . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL "RTN","C0CMED2",240,0) . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! "RTN","C0CMED2",241,0) . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) "RTN","C0CMED2",242,0) . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) "RTN","C0CMED2",243,0) . K @RESULT "RTN","C0CMED2",244,0) . D MAP^C0CXPATH(MINXML,MAP,RESULT) "RTN","C0CMED2",245,0) . ; D PARY^C0CXPATH(RESULT) "RTN","C0CMED2",246,0) . ; MAPPING DIRECTIONS "RTN","C0CMED2",247,0) . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CMED2",248,0) . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CMED2",249,0) . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) "RTN","C0CMED2",250,0) . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") "RTN","C0CMED2",251,0) . ; N MDZ1,MDZNA "RTN","C0CMED2",252,0) . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS "RTN","C0CMED2",253,0) . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION "RTN","C0CMED2",254,0) . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) "RTN","C0CMED2",255,0) . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) "RTN","C0CMED2",256,0) . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") "RTN","C0CMED2",257,0) . I MEDFIRST D ; "RTN","C0CMED2",258,0) . . S MEDFIRST=0 ; RESET FIRST FLAG "RTN","C0CMED2",259,0) . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CMED2",260,0) . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER "RTN","C0CMED2",261,0) N MEDTMP,MEDI "RTN","C0CMED2",262,0) D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CMED2",263,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CMED2",264,0) . W "Pending Medication MISSING ",! "RTN","C0CMED2",265,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","C0CMED2",266,0) Q "RTN","C0CMED2",267,0) ; "RTN","C0CMED3") 0^34^B172422279 "RTN","C0CMED3",1,0) C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista "RTN","C0CMED3",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CMED3",3,0) ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 "RTN","C0CMED3",4,0) ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU "RTN","C0CMED3",5,0) ; General Public License See attached copy of the License. "RTN","C0CMED3",6,0) ; "RTN","C0CMED3",7,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CMED3",8,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CMED3",9,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CMED3",10,0) ; (at your option) any later version. "RTN","C0CMED3",11,0) ; "RTN","C0CMED3",12,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CMED3",13,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMED3",14,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMED3",15,0) ; GNU General Public License for more details. "RTN","C0CMED3",16,0) ; "RTN","C0CMED3",17,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CMED3",18,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMED3",19,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMED3",20,0) ; "RTN","C0CMED3",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CMED3",22,0) Q "RTN","C0CMED3",23,0) ; "RTN","C0CMED3",24,0) EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template "RTN","C0CMED3",25,0) ; "RTN","C0CMED3",26,0) ; MINXML is the Input XML Template, (passed by name) "RTN","C0CMED3",27,0) ; DFN is Patient IEN (passed by value) "RTN","C0CMED3",28,0) ; OUTXML is the resultant XML (passed by name) "RTN","C0CMED3",29,0) ; MEDCOUNT is the number of Meds extracted so far (passed by reference) "RTN","C0CMED3",30,0) ; "RTN","C0CMED3",31,0) ; MEDS is return array from RPC. "RTN","C0CMED3",32,0) ; MAP is a mapping variable map (store result) for each med "RTN","C0CMED3",33,0) ; MED is holds each array element from MEDS, one medicine "RTN","C0CMED3",34,0) ; "RTN","C0CMED3",35,0) ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 "RTN","C0CMED3",36,0) ; Discontinued meds are indicated by the presence of a value in fields "RTN","C0CMED3",37,0) ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) "RTN","C0CMED3",38,0) ; Will use Fileman API GETS^DIQ "RTN","C0CMED3",39,0) ; "RTN","C0CMED3",40,0) N MEDS,MAP "RTN","C0CMED3",41,0) K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! "RTN","C0CMED3",42,0) N NVA "RTN","C0CMED3",43,0) D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. "RTN","C0CMED3",44,0) ; If NVA does not exist, then patient has no non-VA meds "RTN","C0CMED3",45,0) I $D(NVA)=0 S @OUTXML@(0)=0 QUIT "RTN","C0CMED3",46,0) ; Otherwise, we go on... "RTN","C0CMED3",47,0) M MEDS=NVA(55.05) "RTN","C0CMED3",48,0) ; We are done with NVA "RTN","C0CMED3",49,0) K NVA "RTN","C0CMED3",50,0) ; "RTN","C0CMED3",51,0) I DEBUG ZWRITE MEDS "RTN","C0CMED3",52,0) N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. "RTN","C0CMED3",53,0) N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE "RTN","C0CMED3",54,0) F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST "RTN","C0CMED3",55,0) . N MED M MED=MEDS(FDAIEN) "RTN","C0CMED3",56,0) . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. "RTN","C0CMED3",57,0) . S MEDCOUNT=MEDCOUNT+1 "RTN","C0CMED3",58,0) . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) "RTN","C0CMED3",59,0) . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient "RTN","C0CMED3",60,0) . I DEBUG W "RXIEN IS ",RXIEN,! "RTN","C0CMED3",61,0) . I DEBUG W "MAP= ",MAP,! "RTN","C0CMED3",62,0) . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID "RTN","C0CMED3",63,0) . S @MAP@("MEDISSUEDATETXT")="Documented Date" "RTN","C0CMED3",64,0) . ; Field 6 is "Effective date", and we pull it in timson format w/ I "RTN","C0CMED3",65,0) . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT") "RTN","C0CMED3",66,0) . ; Med never filled; next 4 fields are not applicable. "RTN","C0CMED3",67,0) . S @MAP@("MEDLASTFILLDATETXT")="" "RTN","C0CMED3",68,0) . S @MAP@("MEDLASTFILLDATE")="" "RTN","C0CMED3",69,0) . S @MAP@("MEDRXNOTXT")="" "RTN","C0CMED3",70,0) . S @MAP@("MEDRXNO")="" "RTN","C0CMED3",71,0) . S @MAP@("MEDTYPETEXT")="Medication" "RTN","C0CMED3",72,0) . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses "RTN","C0CMED3",73,0) . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds "RTN","C0CMED3",74,0) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") "RTN","C0CMED3",75,0) . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") "RTN","C0CMED3",76,0) . ; NDC is field 31 in the drug file. "RTN","C0CMED3",77,0) . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied. "RTN","C0CMED3",78,0) . ; It' node 1, internal form. "RTN","C0CMED3",79,0) . N MEDIEN S MEDIEN=MED(1,"I") "RTN","C0CMED3",80,0) . I +MEDIEN D ; start of if/else block "RTN","C0CMED3",81,0) . . ; 12/30/08: I will be using RxNorm for coding... "RTN","C0CMED3",82,0) . . ; 176.001 is the file for Concepts; 176.003 is the file for "RTN","C0CMED3",83,0) . . ; sources (i.e. for RxNorm Version) "RTN","C0CMED3",84,0) . . ; "RTN","C0CMED3",85,0) . . ; We need the VUID first for the National Drug File entry first "RTN","C0CMED3",86,0) . . ; We get the VUID of the drug, by looking up the VA Product entry "RTN","C0CMED3",87,0) . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. "RTN","C0CMED3",88,0) . . ; Field 99.99 is the VUID. "RTN","C0CMED3",89,0) . . ; "RTN","C0CMED3",90,0) . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. "RTN","C0CMED3",91,0) . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by "RTN","C0CMED3",92,0) . . ; $$GET1^DIQ. "RTN","C0CMED3",93,0) . . ; "RTN","C0CMED3",94,0) . . ; I get the RxNorm name and version from the RxNorm Sources (file "RTN","C0CMED3",95,0) . . ; 176.003), by searching for "RXNORM", then get the data. "RTN","C0CMED3",96,0) . . ; NDF^PSS50 ONLY EXISTS ON VISTA "RTN","C0CMED3",97,0) . . N NDFDATA,NDFIEN,VAPROD "RTN","C0CMED3",98,0) . . S NDFIEN="" "RTN","C0CMED3",99,0) . . I '$$RPMS^C0CUTIL() D "RTN","C0CMED3",100,0) . . . D NDF^PSS50(MEDIEN,,,,,"NDF") "RTN","C0CMED3",101,0) . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) "RTN","C0CMED3",102,0) . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U) "RTN","C0CMED3",103,0) . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U) "RTN","C0CMED3",104,0) . . . M NDFDATA=^TMP($J,"NDF",MEDIEN) "RTN","C0CMED3",105,0) . . . S NDFIEN=$P(NDFDATA(20),U) "RTN","C0CMED3",106,0) . . . S VAPROD=$P(NDFDATA(22),U) "RTN","C0CMED3",107,0) . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ; "RTN","C0CMED3",108,0) . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE "RTN","C0CMED3",109,0) . . ; HAVE IT. "RTN","C0CMED3",110,0) . . ; "RTN","C0CMED3",111,0) . . ; NDFIEN is not necessarily defined; it won't be if the drug "RTN","C0CMED3",112,0) . . ; is not matched to the national drug file (e.g. if the drug is "RTN","C0CMED3",113,0) . . ; new on the market, compounded, or is a fake drug [blue pill]. "RTN","C0CMED3",114,0) . . ; To protect against failure, I will put an if/else block "RTN","C0CMED3",115,0) . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER "RTN","C0CMED3",116,0) . . ; "RTN","C0CMED3",117,0) . . ; begin changes for systems that have eRx installed "RTN","C0CMED3",118,0) . . ; RxNorm is found in the ^C0P("RXN") global - gpl "RTN","C0CMED3",119,0) . . ; "RTN","C0CMED3",120,0) . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION "RTN","C0CMED3",121,0) . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE "RTN","C0CMED3",122,0) . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE "RTN","C0CMED3",123,0) . . I NDFIEN,$D(^C0P("RXN")) D ; "RTN","C0CMED3",124,0) . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) "RTN","C0CMED3",125,0) . . . S ZC=$$CODE^C0CUTIL(VUID) "RTN","C0CMED3",126,0) . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE "RTN","C0CMED3",127,0) . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID "RTN","C0CMED3",128,0) . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION "RTN","C0CMED3",129,0) . . . S RXNORM=ZCD ; THE CODE "RTN","C0CMED3",130,0) . . . S RXNNAME=ZCDS ; THE CODING SYSTEM "RTN","C0CMED3",131,0) . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION "RTN","C0CMED3",132,0) . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") "RTN","C0CMED3",133,0) . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD "RTN","C0CMED3",134,0) . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. "RTN","C0CMED3",135,0) . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) "RTN","C0CMED3",136,0) . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") "RTN","C0CMED3",137,0) . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) "RTN","C0CMED3",138,0) . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") "RTN","C0CMED3",139,0) . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) "RTN","C0CMED3",140,0) . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) "RTN","C0CMED3",141,0) . . ; "RTN","C0CMED3",142,0) . . ;E S (RXNORM,RXNNAME,RXNVER)="" "RTN","C0CMED3",143,0) . . ; End if/else block "RTN","C0CMED3",144,0) . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM "RTN","C0CMED3",145,0) . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME "RTN","C0CMED3",146,0) . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER "RTN","C0CMED3",147,0) . . ; "RTN","C0CMED3",148,0) . . S @MAP@("MEDBRANDNAMETEXT")="" "RTN","C0CMED3",149,0) . . ; DOSE^PSS50 ONLY ESISTS ON VISTA "RTN","C0CMED3",150,0) . . I '$$RPMS^C0CUTIL() D "RTN","C0CMED3",151,0) . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") "RTN","C0CMED3",152,0) . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) "RTN","C0CMED3",153,0) . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) "RTN","C0CMED3",154,0) . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) "RTN","C0CMED3",155,0) . . E S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")="" "RTN","C0CMED3",156,0) . . ; Units, concentration, etc, come from another call "RTN","C0CMED3",157,0) . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit "RTN","C0CMED3",158,0) . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters "RTN","C0CMED3",159,0) . . ; NDF Entry IEN, and VA Product Name "RTN","C0CMED3",160,0) . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") "RTN","C0CMED3",161,0) . . ; Documented in the same manual; executed above. "RTN","C0CMED3",162,0) . . ; "RTN","C0CMED3",163,0) . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" "RTN","C0CMED3",164,0) . . ; and this will crash the call. So... "RTN","C0CMED3",165,0) . . I NDFIEN="" S CONCDATA="" "RTN","C0CMED3",166,0) . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) "RTN","C0CMED3",167,0) . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) "RTN","C0CMED3",168,0) . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) "RTN","C0CMED3",169,0) . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) "RTN","C0CMED3",170,0) . . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. "RTN","C0CMED3",171,0) . . ; Oddly, there is no easy place to find the dispense unit. "RTN","C0CMED3",172,0) . . ; It's not included in the original call, so we have to go to the drug file. "RTN","C0CMED3",173,0) . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") "RTN","C0CMED3",174,0) . . ; Node 14.5 is the Dispense Unit "RTN","C0CMED3",175,0) . . ; PSS50 ONLY EXISTS ON VISTA "RTN","C0CMED3",176,0) . . I '$$RPMS^C0CUTIL() D "RTN","C0CMED3",177,0) . . . D DATA^PSS50(MEDIEN,,,,,"QTY") "RTN","C0CMED3",178,0) . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) "RTN","C0CMED3",179,0) . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) "RTN","C0CMED3",180,0) . . E S @MAP@("MEDQUANTITYUNIT")="" "RTN","C0CMED3",181,0) . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these "RTN","C0CMED3",182,0) . E D "RTN","C0CMED3",183,0) . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" "RTN","C0CMED3",184,0) . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" "RTN","C0CMED3",185,0) . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" "RTN","C0CMED3",186,0) . . S @MAP@("MEDBRANDNAMETEXT")="" "RTN","C0CMED3",187,0) . . S @MAP@("MEDSTRENGTHVALUE")="" "RTN","C0CMED3",188,0) . . S @MAP@("MEDSTRENGTHUNIT")="" "RTN","C0CMED3",189,0) . . S @MAP@("MEDFORMTEXT")="" "RTN","C0CMED3",190,0) . . S @MAP@("MEDCONCVALUE")="" "RTN","C0CMED3",191,0) . . S @MAP@("MEDCONCUNIT")="" "RTN","C0CMED3",192,0) . . S @MAP@("MEDSIZETEXT")="" "RTN","C0CMED3",193,0) . . S @MAP@("MEDQUANTITYVALUE")="" "RTN","C0CMED3",194,0) . . S @MAP@("MEDQUANTITYUNIT")="" "RTN","C0CMED3",195,0) . ; End If/Else "RTN","C0CMED3",196,0) . ; --- START OF DIRECTIONS --- "RTN","C0CMED3",197,0) . ; Dosage is field 2, route is 3, schedule is 4 "RTN","C0CMED3",198,0) . ; These are all free text fields, and don't point to any files "RTN","C0CMED3",199,0) . ; For that reason, I will use the field I never used before: "RTN","C0CMED3",200,0) . ; MEDDIRECTIONDESCRIPTIONTEXT "RTN","C0CMED3",201,0) . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS "RTN","C0CMED3",202,0) . ; "RTN","C0CMED3",203,0) . ; change for eRx meds - gpl 6/25/2011 "RTN","C0CMED3",204,0) . ; "RTN","C0CMED3",205,0) . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") "RTN","C0CMED3",206,0) . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME "RTN","C0CMED3",207,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX "RTN","C0CMED3",208,0) . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity "RTN","C0CMED3",209,0) . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME "RTN","C0CMED3",210,0) . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME "RTN","C0CMED3",211,0) . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME "RTN","C0CMED3",212,0) . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM "RTN","C0CMED3",213,0) . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY "RTN","C0CMED3",214,0) . . I RXNORM'="" D ; "RTN","C0CMED3",215,0) . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM "RTN","C0CMED3",216,0) . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM "RTN","C0CMED3",217,0) . . . S RXNVER="" ; THE CODING SYSTEM VERSION "RTN","C0CMED3",218,0) . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") "RTN","C0CMED3",219,0) . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM "RTN","C0CMED3",220,0) . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM "RTN","C0CMED3",221,0) . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME "RTN","C0CMED3",222,0) . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER "RTN","C0CMED3",223,0) . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION "RTN","C0CMED3",224,0) . . . . S @MAP@("MEDSTRENGTHVALUE")=650 "RTN","C0CMED3",225,0) . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg" "RTN","C0CMED3",226,0) . . . . S @MAP@("MEDFORMTEXT")="INHALER" "RTN","C0CMED3",227,0) . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS "RTN","C0CMED3",228,0) . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY "RTN","C0CMED3",229,0) . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ; "RTN","C0CMED3",230,0) . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") "RTN","C0CMED3",231,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. "RTN","C0CMED3",232,0) . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" "RTN","C0CMED3",233,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" "RTN","C0CMED3",234,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" "RTN","C0CMED3",235,0) . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" "RTN","C0CMED3",236,0) . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" "RTN","C0CMED3",237,0) . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" "RTN","C0CMED3",238,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" "RTN","C0CMED3",239,0) . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" "RTN","C0CMED3",240,0) . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" "RTN","C0CMED3",241,0) . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" "RTN","C0CMED3",242,0) . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" "RTN","C0CMED3",243,0) . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" "RTN","C0CMED3",244,0) . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" "RTN","C0CMED3",245,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" "RTN","C0CMED3",246,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" "RTN","C0CMED3",247,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" "RTN","C0CMED3",248,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" "RTN","C0CMED3",249,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" "RTN","C0CMED3",250,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" "RTN","C0CMED3",251,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" "RTN","C0CMED3",252,0) . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" "RTN","C0CMED3",253,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" "RTN","C0CMED3",254,0) . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" "RTN","C0CMED3",255,0) . ; "RTN","C0CMED3",256,0) . ; --- END OF DIRECTIONS --- "RTN","C0CMED3",257,0) . ; "RTN","C0CMED3",258,0) . S @MAP@("MEDRFNO")="" "RTN","C0CMED3",259,0) . I $D(MED(14,1)) D ; "RTN","C0CMED3",260,0) . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field "RTN","C0CMED3",261,0) . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" "RTN","C0CMED3",262,0) . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl "RTN","C0CMED3",263,0) . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) "RTN","C0CMED3",264,0) . K @RESULT "RTN","C0CMED3",265,0) . D MAP^C0CXPATH(MINXML,MAP,RESULT) "RTN","C0CMED3",266,0) . ; D PARY^C0CXPATH(RESULT) "RTN","C0CMED3",267,0) . ; MAPPING DIRECTIONS "RTN","C0CMED3",268,0) . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CMED3",269,0) . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CMED3",270,0) . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) "RTN","C0CMED3",271,0) . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") "RTN","C0CMED3",272,0) . N MDZ1,MDZNA "RTN","C0CMED3",273,0) . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS "RTN","C0CMED3",274,0) . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION "RTN","C0CMED3",275,0) . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) "RTN","C0CMED3",276,0) . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) "RTN","C0CMED3",277,0) . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") "RTN","C0CMED3",278,0) . ; "RTN","C0CMED3",279,0) . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION "RTN","C0CMED3",280,0) . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CMED3",281,0) . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CMED3",282,0) . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1) "RTN","C0CMED3",283,0) . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions") "RTN","C0CMED3",284,0) . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010 "RTN","C0CMED3",285,0) . ;S MDI1=$NA(@MAP@("I")) "RTN","C0CMED3",286,0) . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" "RTN","C0CMED3",287,0) . I $D(MED(10,1)) D ; "RTN","C0CMED3",288,0) . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field "RTN","C0CMED3",289,0) . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field "RTN","C0CMED3",290,0) . E S @MAP@("MEDPTINSTRUCTIONS")="" "RTN","C0CMED3",291,0) . ;E S @MAP@("I","MEDPTINSTRUCTIONS")="" "RTN","C0CMED3",292,0) . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2) "RTN","C0CMED3",293,0) . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL "RTN","C0CMED3",294,0) . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication") "RTN","C0CMED3",295,0) . ; "RTN","C0CMED3",296,0) . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT. "RTN","C0CMED3",297,0) . ;I MEDFIRST D ; "RTN","C0CMED3",298,0) . ;. S MEDFIRST=0 ; RESET FIRST FLAG "RTN","C0CMED3",299,0) . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CMED3",300,0) . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML "RTN","C0CMED3",301,0) . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CMED3",302,0) . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CMED3",303,0) . I MEDFIRST S MEDFIRST=0 "RTN","C0CMED3",304,0) N MEDTMP,MEDI "RTN","C0CMED3",305,0) D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CMED3",306,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CMED3",307,0) . W "MEDICATION MISSING ",! "RTN","C0CMED3",308,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","C0CMED3",309,0) Q "RTN","C0CMED3",310,0) ; "RTN","C0CMED4") 0^35^B60848214 "RTN","C0CMED4",1,0) C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 "RTN","C0CMED4",2,0) ;;0.1;CCDCCR;;;Build 1 "RTN","C0CMED4",3,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CMED4",4,0) ; General Public License See attached copy of the License. "RTN","C0CMED4",5,0) ; "RTN","C0CMED4",6,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CMED4",7,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CMED4",8,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CMED4",9,0) ; (at your option) any later version. "RTN","C0CMED4",10,0) ; "RTN","C0CMED4",11,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CMED4",12,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMED4",13,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMED4",14,0) ; GNU General Public License for more details. "RTN","C0CMED4",15,0) ; "RTN","C0CMED4",16,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CMED4",17,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMED4",18,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMED4",19,0) ; "RTN","C0CMED4",20,0) W "NO ENTRY FROM TOP",! "RTN","C0CMED4",21,0) Q "RTN","C0CMED4",22,0) ; "RTN","C0CMED4",23,0) EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","C0CMED4",24,0) ; "RTN","C0CMED4",25,0) ; MINXML is the Input XML Template, passed by name "RTN","C0CMED4",26,0) ; DFN is Patient IEN "RTN","C0CMED4",27,0) ; OUTXML is the resultant XML. "RTN","C0CMED4",28,0) ; "RTN","C0CMED4",29,0) ; MEDS is return array from API. "RTN","C0CMED4",30,0) ; MED is holds each array element from MEDS, one medicine "RTN","C0CMED4",31,0) ; MAP is a mapping variable map (store result) for each med "RTN","C0CMED4",32,0) ; "RTN","C0CMED4",33,0) ; Inpatient Meds will be extracted using this routine and and the one following. "RTN","C0CMED4",34,0) ; Inpatient Meds Unit Dose is going to be C0CMED4 "RTN","C0CMED4",35,0) ; Inpatient Meds IVs is going to be C0CMED5 "RTN","C0CMED4",36,0) ; "RTN","C0CMED4",37,0) ; We will use two Pharmacy ReEnginnering API's: "RTN","C0CMED4",38,0) ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info "RTN","C0CMED4",39,0) ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info "RTN","C0CMED4",40,0) ; For more information, see the PRE documentation at: "RTN","C0CMED4",41,0) ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf "RTN","C0CMED4",42,0) ; "RTN","C0CMED4",43,0) ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient "RTN","C0CMED4",44,0) ; "RTN","C0CMED4",45,0) N MEDS,MAP "RTN","C0CMED4",46,0) K ^TMP($J) "RTN","C0CMED4",47,0) D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) "RTN","C0CMED4",48,0) I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit "RTN","C0CMED4",49,0) ; Otherwise, we go on... "RTN","C0CMED4",50,0) M MEDS=^TMP($J,"UD") "RTN","C0CMED4",51,0) I DEBUG ZWR MEDS "RTN","C0CMED4",52,0) S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) "RTN","C0CMED4",53,0) N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array "RTN","C0CMED4",54,0) N I S I=0 "RTN","C0CMED4",55,0) F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index "RTN","C0CMED4",56,0) . N MED M MED=MEDS(I) "RTN","C0CMED4",57,0) . S MEDCOUNT=MEDCOUNT+1 "RTN","C0CMED4",58,0) . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter "RTN","C0CMED4",59,0) . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) "RTN","C0CMED4",60,0) . N RXIEN S RXIEN=MED(.01) ; Order Number "RTN","C0CMED4",61,0) . I DEBUG W "RXIEN IS ",RXIEN,! "RTN","C0CMED4",62,0) . I DEBUG W "MAP= ",MAP,! "RTN","C0CMED4",63,0) . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN "RTN","C0CMED4",64,0) . S @MAP@("MEDISSUEDATETXT")="Order Date" "RTN","C0CMED4",65,0) . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") "RTN","C0CMED4",66,0) . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient "RTN","C0CMED4",67,0) . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient "RTN","C0CMED4",68,0) . S @MAP@("MEDRXNOTXT")="" ; For Outpatient "RTN","C0CMED4",69,0) . S @MAP@("MEDRXNO")="" ; For Outpatient "RTN","C0CMED4",70,0) . S @MAP@("MEDTYPETEXT")="Medication" "RTN","C0CMED4",71,0) . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses "RTN","C0CMED4",72,0) . S @MAP@("MEDSTATUSTEXT")="ACTIVE" "RTN","C0CMED4",73,0) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) "RTN","C0CMED4",74,0) . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) "RTN","C0CMED4",75,0) . ; NDC is field 31 in the drug file. "RTN","C0CMED4",76,0) . ; The actual drug entry in the drug file is not necessarily supplied. "RTN","C0CMED4",77,0) . ; It' node 1, internal form. "RTN","C0CMED4",78,0) . N MEDIEN S MEDIEN=MED(1,"I") "RTN","C0CMED4",79,0) . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") "RTN","C0CMED4",80,0) . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") "RTN","C0CMED4",81,0) . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") "RTN","C0CMED4",82,0) . S @MAP@("MEDBRANDNAMETEXT")="" "RTN","C0CMED4",83,0) . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") "RTN","C0CMED4",84,0) . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) "RTN","C0CMED4",85,0) . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") "RTN","C0CMED4",86,0) . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") "RTN","C0CMED4",87,0) . ; Units, concentration, etc, come from another call "RTN","C0CMED4",88,0) . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit "RTN","C0CMED4",89,0) . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters "RTN","C0CMED4",90,0) . ; NDF Entry IEN, and VA Product Name "RTN","C0CMED4",91,0) . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") "RTN","C0CMED4",92,0) . ; Documented in the same manual. "RTN","C0CMED4",93,0) . N NDFDATA,CONCDATA "RTN","C0CMED4",94,0) . I $L(MEDIEN) D "RTN","C0CMED4",95,0) . . D NDF^PSS50(MEDIEN,,,,,"CONC") "RTN","C0CMED4",96,0) . . M NDFDATA=^TMP($J,"CONC",MEDIEN) "RTN","C0CMED4",97,0) . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) "RTN","C0CMED4",98,0) . . N VAPROD S VAPROD=$P(NDFDATA(22),U) "RTN","C0CMED4",99,0) . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" "RTN","C0CMED4",100,0) . . ; and this will crash the call. So... "RTN","C0CMED4",101,0) . . I NDFIEN="" S CONCDATA="" "RTN","C0CMED4",102,0) . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) "RTN","C0CMED4",103,0) . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. "RTN","C0CMED4",104,0) . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") "RTN","C0CMED4",105,0) . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") "RTN","C0CMED4",106,0) . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") "RTN","C0CMED4",107,0) . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. "RTN","C0CMED4",108,0) . ; Oddly, there is no easy place to find the dispense unit. "RTN","C0CMED4",109,0) . ; It's not included in the original call, so we have to go to the drug file. "RTN","C0CMED4",110,0) . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") "RTN","C0CMED4",111,0) . ; Node 14.5 is the Dispense Unit "RTN","C0CMED4",112,0) . I $L(MEDIEN) D "RTN","C0CMED4",113,0) . . D DATA^PSS50(MEDIEN,,,,,"QTY") "RTN","C0CMED4",114,0) . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) "RTN","C0CMED4",115,0) . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) "RTN","C0CMED4",116,0) E S @MAP@("MEDQUANTITYUNIT")="" "RTN","C0CMED4",117,0) . ; "RTN","C0CMED4",118,0) . ; --- START OF DIRECTIONS --- "RTN","C0CMED4",119,0) . ; Dosage is field 2, route is 3, schedule is 4 "RTN","C0CMED4",120,0) . ; These are all free text fields, and don't point to any files "RTN","C0CMED4",121,0) . ; For that reason, I will use the field I never used before: "RTN","C0CMED4",122,0) . ; MEDDIRECTIONDESCRIPTIONTEXT "RTN","C0CMED4",123,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") "RTN","C0CMED4",124,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. "RTN","C0CMED4",125,0) . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" "RTN","C0CMED4",126,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" "RTN","C0CMED4",127,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" "RTN","C0CMED4",128,0) . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" "RTN","C0CMED4",129,0) . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" "RTN","C0CMED4",130,0) . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" "RTN","C0CMED4",131,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" "RTN","C0CMED4",132,0) . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" "RTN","C0CMED4",133,0) . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" "RTN","C0CMED4",134,0) . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" "RTN","C0CMED4",135,0) . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" "RTN","C0CMED4",136,0) . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" "RTN","C0CMED4",137,0) . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" "RTN","C0CMED4",138,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" "RTN","C0CMED4",139,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" "RTN","C0CMED4",140,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" "RTN","C0CMED4",141,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" "RTN","C0CMED4",142,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" "RTN","C0CMED4",143,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" "RTN","C0CMED4",144,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" "RTN","C0CMED4",145,0) . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" "RTN","C0CMED4",146,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" "RTN","C0CMED4",147,0) . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" "RTN","C0CMED4",148,0) . ; "RTN","C0CMED4",149,0) . ; --- END OF DIRECTIONS --- "RTN","C0CMED4",150,0) . ; "RTN","C0CMED4",151,0) . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" "RTN","C0CMED4",152,0) . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field "RTN","C0CMED4",153,0) . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field "RTN","C0CMED4",154,0) . S @MAP@("MEDRFNO")="" "RTN","C0CMED4",155,0) . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) "RTN","C0CMED4",156,0) . K @RESULT "RTN","C0CMED4",157,0) . D MAP^GPLXPATH(MINXML,MAP,RESULT) "RTN","C0CMED4",158,0) . ; D PARY^GPLXPATH(RESULT) "RTN","C0CMED4",159,0) . ; MAPPING DIRECTIONS "RTN","C0CMED4",160,0) . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CMED4",161,0) . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CMED4",162,0) . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) "RTN","C0CMED4",163,0) . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") "RTN","C0CMED4",164,0) . ; N MDZ1,MDZNA "RTN","C0CMED4",165,0) . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS "RTN","C0CMED4",166,0) . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION "RTN","C0CMED4",167,0) . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) "RTN","C0CMED4",168,0) . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) "RTN","C0CMED4",169,0) . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") "RTN","C0CMED4",170,0) . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CMED4",171,0) . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CMED4",172,0) N MEDTMP,MEDI "RTN","C0CMED4",173,0) D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CMED4",174,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CMED4",175,0) . W "MEDICATION MISSING ",! "RTN","C0CMED4",176,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","C0CMED4",177,0) Q "RTN","C0CMED4",178,0) ; "RTN","C0CMED6") 0^36^B194177231 "RTN","C0CMED6",1,0) C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 "RTN","C0CMED6",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CMED6",3,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CMED6",4,0) ; General Public License See attached copy of the License. "RTN","C0CMED6",5,0) ; "RTN","C0CMED6",6,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CMED6",7,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CMED6",8,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CMED6",9,0) ; (at your option) any later version. "RTN","C0CMED6",10,0) ; "RTN","C0CMED6",11,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CMED6",12,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMED6",13,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMED6",14,0) ; GNU General Public License for more details. "RTN","C0CMED6",15,0) ; "RTN","C0CMED6",16,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CMED6",17,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMED6",18,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMED6",19,0) ; "RTN","C0CMED6",20,0) W "NO ENTRY FROM TOP",! "RTN","C0CMED6",21,0) Q "RTN","C0CMED6",22,0) ; "RTN","C0CMED6",23,0) EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","C0CMED6",24,0) ; "RTN","C0CMED6",25,0) ; MINXML and OUTXML are passed by name so globals can be used "RTN","C0CMED6",26,0) ; MINXML will contain only the medications skeleton of the overall template "RTN","C0CMED6",27,0) ; MEDCOUNT is a counter passed by Reference. "RTN","C0CMED6",28,0) ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) "RTN","C0CMED6",29,0) ; FLAGS are set-up in C0CMED. "RTN","C0CMED6",30,0) ; "RTN","C0CMED6",31,0) ; MEDS is return array from RPC. "RTN","C0CMED6",32,0) ; MAP is a mapping variable map (store result) for each med "RTN","C0CMED6",33,0) ; MED is holds each array element from MEDS(J), one medicine "RTN","C0CMED6",34,0) ; J is a counter. "RTN","C0CMED6",35,0) ; "RTN","C0CMED6",36,0) ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used. "RTN","C0CMED6",37,0) ; This API has been developed by Medsphere for IHS for getting "RTN","C0CMED6",38,0) ; Medications from RPMS. It has most of what we need. "RTN","C0CMED6",39,0) ; API written by Doug Martin when he worked for Medsphere (thanks Doug!) "RTN","C0CMED6",40,0) ; -- ARRAYNAME is passed by name (required) "RTN","C0CMED6",41,0) ; -- DFN is passed by value (required) "RTN","C0CMED6",42,0) ; -- DAYS is passed by value (optional; if not passed defaults to 365) "RTN","C0CMED6",43,0) ; "RTN","C0CMED6",44,0) ; Return: "RTN","C0CMED6",45,0) ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID "RTN","C0CMED6",46,0) ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ "RTN","C0CMED6",47,0) ; Status Reason^DEA Handling "RTN","C0CMED6",48,0) ; "RTN","C0CMED6",49,0) N MEDS,MEDS1,MAP "RTN","C0CMED6",50,0) D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360" "RTN","C0CMED6",51,0) N ALL S ALL=+FLAGS "RTN","C0CMED6",52,0) N ACTIVE S ACTIVE=$P(FLAGS,U,3) "RTN","C0CMED6",53,0) N PENDING S PENDING=$P(FLAGS,U,4) "RTN","C0CMED6",54,0) S @OUTXML@(0)=0 ;By default, no meds "RTN","C0CMED6",55,0) ; If MEDS1 is not defined, then no meds "RTN","C0CMED6",56,0) I '$D(MEDS1) QUIT "RTN","C0CMED6",57,0) I DEBUG ZWR MEDS1,MINXML "RTN","C0CMED6",58,0) N MEDCNT S MEDCNT=0 ; Med Count "RTN","C0CMED6",59,0) ; The next line is a super line. It goes through the array return "RTN","C0CMED6",60,0) ; and if the first characters are ~OP, it grabs the line. "RTN","C0CMED6",61,0) ; This means that line is for a dispensed Outpatient Med. "RTN","C0CMED6",62,0) ; That line has the metadata about the med that I need. "RTN","C0CMED6",63,0) ; The next lines, however many, are the med and the sig. "RTN","C0CMED6",64,0) ; I won't be using those because I have to get the sig parsed exactly. "RTN","C0CMED6",65,0) N J S J="" F S J=$O(MEDS1(J)) Q:J="" I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J) "RTN","C0CMED6",66,0) K MEDS1 "RTN","C0CMED6",67,0) S MEDCNT="" ; Initialize for $Order "RTN","C0CMED6",68,0) F S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT="" D ; for each medication in the list "RTN","C0CMED6",69,0) . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT "RTN","C0CMED6",70,0) . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT "RTN","C0CMED6",71,0) . I DEBUG W "MEDCNT IS ",MEDCNT,! "RTN","C0CMED6",72,0) . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT)) "RTN","C0CMED6",73,0) . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED "RTN","C0CMED6",74,0) . I DEBUG W "MAP= ",MAP,! "RTN","C0CMED6",75,0) . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID "RTN","C0CMED6",76,0) . S @MAP@("MEDISSUEDATETXT")="Issue Date" "RTN","C0CMED6",77,0) . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT") "RTN","C0CMED6",78,0) . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" "RTN","C0CMED6",79,0) . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT") "RTN","C0CMED6",80,0) . S @MAP@("MEDRXNOTXT")="Prescription Number" "RTN","C0CMED6",81,0) . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14) "RTN","C0CMED6",82,0) . S @MAP@("MEDTYPETEXT")="Medication" "RTN","C0CMED6",83,0) . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses "RTN","C0CMED6",84,0) . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10) "RTN","C0CMED6",85,0) . ; Provider only provided in API as text, not DUZ. "RTN","C0CMED6",86,0) . ; We need to get DUZ from filman file 52 (Prescription) "RTN","C0CMED6",87,0) . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters. "RTN","C0CMED6",88,0) . ; Note that I will use RXIEN several times later "RTN","C0CMED6",89,0) . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2) "RTN","C0CMED6",90,0) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I") "RTN","C0CMED6",91,0) . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3) "RTN","C0CMED6",92,0) . ; --- RxNorm Stuff "RTN","C0CMED6",93,0) . ; 176.001 is the file for Concepts; 176.003 is the file for "RTN","C0CMED6",94,0) . ; sources (i.e. for RxNorm Version) "RTN","C0CMED6",95,0) . ; "RTN","C0CMED6",96,0) . ; I use 176.001 for the Vista version of this routine (files 1-3) "RTN","C0CMED6",97,0) . ; Since IHS does not have VUID's, I will be getting RxNorm codes "RTN","C0CMED6",98,0) . ; using NDCs. My specially crafted index (sounds evil) named "NDC" "RTN","C0CMED6",99,0) . ; is in file 176.002. The file is called RxNorm NDC to VUID. "RTN","C0CMED6",100,0) . ; Except that I don't need the VUID, but it's there if I need it. "RTN","C0CMED6",101,0) . ; "RTN","C0CMED6",102,0) . ; We obviously need the NDC. That is easily obtained from the prescription. "RTN","C0CMED6",103,0) . ; Field 27 in file 52 "RTN","C0CMED6",104,0) . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I") "RTN","C0CMED6",105,0) . ; I discovered that file 176.002 might give you two codes for the NDC "RTN","C0CMED6",106,0) . ; One for the Clinical Drug, and one for the ingredient. "RTN","C0CMED6",107,0) . ; So the plan is to get the two RxNorm codes, and then find from "RTN","C0CMED6",108,0) . ; file 176.001 which one is the Clinical Drug. "RTN","C0CMED6",109,0) . ; ... I refactored this into GETRXN "RTN","C0CMED6",110,0) . N RXNORM,SRCIEN,RXNNAME,RXNVER "RTN","C0CMED6",111,0) . I +NDC,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. "RTN","C0CMED6",112,0) . . S RXNORM=$$GETRXN(NDC) "RTN","C0CMED6",113,0) . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B") "RTN","C0CMED6",114,0) . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) "RTN","C0CMED6",115,0) . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) "RTN","C0CMED6",116,0) . ; "RTN","C0CMED6",117,0) . E S (RXNORM,RXNNAME,RXNVER)="" "RTN","C0CMED6",118,0) . ; End if/else block "RTN","C0CMED6",119,0) . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM "RTN","C0CMED6",120,0) . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME "RTN","C0CMED6",121,0) . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER "RTN","C0CMED6",122,0) . ; --- End RxNorm section "RTN","C0CMED6",123,0) . ; "RTN","C0CMED6",124,0) . ; Brand name is 52 field 6.5 "RTN","C0CMED6",125,0) . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5) "RTN","C0CMED6",126,0) . ; "RTN","C0CMED6",127,0) . ; Next I need Med Form (tab, cap etc), strength (250mg) "RTN","C0CMED6",128,0) . ; concentration for liquids (250mg/mL) "RTN","C0CMED6",129,0) . ; Since IHS does not have any of the new calls that "RTN","C0CMED6",130,0) . ; Vista has, I will be doing a crosswalk: "RTN","C0CMED6",131,0) . ; File 52, field 6 is Drug IEN in file 50 "RTN","C0CMED6",132,0) . ; File 50, field 22 is VA Product IEN in file 50.68 "RTN","C0CMED6",133,0) . ; In file 50.68, I will get the following: "RTN","C0CMED6",134,0) . ; -- 1: Dosage Form "RTN","C0CMED6",135,0) . ; -- 2: Strength "RTN","C0CMED6",136,0) . ; -- 3: Units "RTN","C0CMED6",137,0) . ; -- 8: Dispense Units "RTN","C0CMED6",138,0) . ; -- Conc is 2 concatenated with 3 "RTN","C0CMED6",139,0) . ; "RTN","C0CMED6",140,0) . ; *** If Drug is not matched to NDF, then VA Product will be "" *** "RTN","C0CMED6",141,0) . ; "RTN","C0CMED6",142,0) . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50 "RTN","C0CMED6",143,0) . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68 "RTN","C0CMED6",144,0) . I +VAPROD D "RTN","C0CMED6",145,0) . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2) "RTN","C0CMED6",146,0) . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3) "RTN","C0CMED6",147,0) . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1) "RTN","C0CMED6",148,0) . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE") "RTN","C0CMED6",149,0) . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT") "RTN","C0CMED6",150,0) . E D "RTN","C0CMED6",151,0) . . S @MAP@("MEDSTRENGTHVALUE")="" "RTN","C0CMED6",152,0) . . S @MAP@("MEDSTRENGTHUNIT")="" "RTN","C0CMED6",153,0) . . S @MAP@("MEDFORMTEXT")="" "RTN","C0CMED6",154,0) . . S @MAP@("MEDCONCVALUE")="" "RTN","C0CMED6",155,0) . . S @MAP@("MEDCONCUNIT")="" "RTN","C0CMED6",156,0) . ; End Strengh/Conc stuff "RTN","C0CMED6",157,0) . ; "RTN","C0CMED6",158,0) . ; Quantity is in the prescription, field 7 "RTN","C0CMED6",159,0) . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7) "RTN","C0CMED6",160,0) . ; Dispense unit is in the drug file, field 14.5 "RTN","C0CMED6",161,0) . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5) "RTN","C0CMED6",162,0) . ; "RTN","C0CMED6",163,0) . ; --- START OF DIRECTIONS --- "RTN","C0CMED6",164,0) . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... "RTN","C0CMED6",165,0) . ; we want the components. "RTN","C0CMED6",166,0) . ; It's in multiple 113 in the Prescription File (52) "RTN","C0CMED6",167,0) . ; #.01 DOSAGE ORDERED [1F] "20" "RTN","C0CMED6",168,0) . ; #1 DISPENSE UNITS PER DOSE [2N] "1" "RTN","C0CMED6",169,0) . ; #2 UNITS [3P:50.607] "MG" "RTN","C0CMED6",170,0) . ; #3 NOUN [4F] "TABLET" "RTN","C0CMED6",171,0) . ; #4 DURATION [5F] "10D" "RTN","C0CMED6",172,0) . ; #5 CONJUNCTION [6S] "AND" "RTN","C0CMED6",173,0) . ; #6 ROUTE [7P:51.2] "ORAL" "RTN","C0CMED6",174,0) . ; #7 SCHEDULE [8F] "BID" "RTN","C0CMED6",175,0) . ; #8 VERB [9F] "TAKE" "RTN","C0CMED6",176,0) . ; "RTN","C0CMED6",177,0) . ; Will use GETS^DIQ to get fields. "RTN","C0CMED6",178,0) . ; Data comes out like this: "RTN","C0CMED6",179,0) . ; SAMINS(52.0113,"1,23,",.01)=20 "RTN","C0CMED6",180,0) . ; SAMINS(52.0113,"1,23,",1)=1 "RTN","C0CMED6",181,0) . ; SAMINS(52.0113,"1,23,",2)="MG" "RTN","C0CMED6",182,0) . ; SAMINS(52.0113,"1,23,",3)="TABLET" "RTN","C0CMED6",183,0) . ; SAMINS(52.0113,"1,23,",4)="5D" "RTN","C0CMED6",184,0) . ; SAMINS(52.0113,"1,23,",5)="THEN" "RTN","C0CMED6",185,0) . ; "RTN","C0CMED6",186,0) . N RAWDATA "RTN","C0CMED6",187,0) . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR") "RTN","C0CMED6",188,0) . D:$D(DIERR) ^%ZTER ; Log if there's an error in retrieving sig field "RTN","C0CMED6",189,0) . ; none the less, continue; some parts are retrievable. "RTN","C0CMED6",190,0) . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile... "RTN","C0CMED6",191,0) . K RAWDATA "RTN","C0CMED6",192,0) . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman. "RTN","C0CMED6",193,0) . ; FMSIGNUM gets outputted as "IEN,RXIEN,". "RTN","C0CMED6",194,0) . ; DIRCNT is the proper Sigline numer. "RTN","C0CMED6",195,0) . ; SIGDATA is the simplfied array. "RTN","C0CMED6",196,0) . F S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM="" D "RTN","C0CMED6",197,0) . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",") "RTN","C0CMED6",198,0) . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM) "RTN","C0CMED6",199,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. "RTN","C0CMED6",200,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. "RTN","C0CMED6",201,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8)) "RTN","C0CMED6",202,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01)) "RTN","C0CMED6",203,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2)) "RTN","C0CMED6",204,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient "RTN","C0CMED6",205,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient "RTN","C0CMED6",206,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient "RTN","C0CMED6",207,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6)) "RTN","C0CMED6",208,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7)) "RTN","C0CMED6",209,0) . . ; Invervals... again another call. "RTN","C0CMED6",210,0) . . ; In the wisdom of the original programmers, the schedule is a free text field "RTN","C0CMED6",211,0) . . ; However, it gets translated by a call to the administration schedule file "RTN","C0CMED6",212,0) . . ; to see if that schedule exists. "RTN","C0CMED6",213,0) . . ; That's the same thing I am going to do. "RTN","C0CMED6",214,0) . . ; Search B index of 51.1 (Admin Schedule) with schedule "RTN","C0CMED6",215,0) . . ; First, remove "PRN" if it exists (don't ask, that's how the file "RTN","C0CMED6",216,0) . . ; works; I wouldn't do it that way). "RTN","C0CMED6",217,0) . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7)) "RTN","C0CMED6",218,0) . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5) "RTN","C0CMED6",219,0) . . ; Super call below: "RTN","C0CMED6",220,0) . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes) "RTN","C0CMED6",221,0) . . ; 4=Packed format, Exact Match 5=Lookup Value "RTN","C0CMED6",222,0) . . ; 6=# of entries to return 7=Index 10=Return Array "RTN","C0CMED6",223,0) . . ; "RTN","C0CMED6",224,0) . . ; I do not account for the fact that two schedules can be "RTN","C0CMED6",225,0) . . ; spelled identically (ie duplicate entry). In that case, "RTN","C0CMED6",226,0) . . ; I get the first. That's just a bad pharmacy pkg maintainer. "RTN","C0CMED6",227,0) . . N C0C515 "RTN","C0CMED6",228,0) . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515") "RTN","C0CMED6",229,0) . . N INTERVAL S INTERVAL="" ; Default "RTN","C0CMED6",230,0) . . ; If there are entries found, get it "RTN","C0CMED6",231,0) . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) "RTN","C0CMED6",232,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL "RTN","C0CMED6",233,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" "RTN","C0CMED6",234,0) . . ; Duration is 10M minutes, 10H hours, 10D for Days "RTN","C0CMED6",235,0) . . ; 10W for weeks, 10L for months. I smell $Select "RTN","C0CMED6",236,0) . . ; But we don't need to do that if there isn't a duration "RTN","C0CMED6",237,0) . . I +$G(SIGDATA(4)) D "RTN","C0CMED6",238,0) . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char "RTN","C0CMED6",239,0) . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days") "RTN","C0CMED6",240,0) . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4) "RTN","C0CMED6",241,0) . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT "RTN","C0CMED6",242,0) . . E D "RTN","C0CMED6",243,0) . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")="" "RTN","C0CMED6",244,0) . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" "RTN","C0CMED6",245,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN" "RTN","C0CMED6",246,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail "RTN","C0CMED6",247,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" "RTN","C0CMED6",248,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" "RTN","C0CMED6",249,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" "RTN","C0CMED6",250,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" "RTN","C0CMED6",251,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" "RTN","C0CMED6",252,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" "RTN","C0CMED6",253,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored "RTN","C0CMED6",254,0) . . ; Another confusing line; I am pretty bad: "RTN","C0CMED6",255,0) . . ; If there is another entry in the FMSIG array (i.e. another line "RTN","C0CMED6",256,0) . . ; in the sig), set the direction count indicator. "RTN","C0CMED6",257,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")="" ; Default "RTN","C0CMED6",258,0) . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT "RTN","C0CMED6",259,0) . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5)) "RTN","C0CMED6",260,0) . ; "RTN","C0CMED6",261,0) . ; --- END OF DIRECTIONS --- "RTN","C0CMED6",262,0) . ; "RTN","C0CMED6",263,0) . ; Med instructions is a WP field, thus the acrobatics "RTN","C0CMED6",264,0) . ; Notice buffer overflow protection set at 10,000 chars "RTN","C0CMED6",265,0) . ; -- 1. Med Patient Instructions "RTN","C0CMED6",266,0) . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1") "RTN","C0CMED6",267,0) . N MEDPTIN2,J S (MEDPTIN2,J)="" "RTN","C0CMED6",268,0) . I $L(MEDPTIN1) F S J=$O(@MEDPTIN1@(J)) Q:J="" Q:$L(MEDPTIN2)>10000 S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" " "RTN","C0CMED6",269,0) . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2 "RTN","C0CMED6",270,0) . K J "RTN","C0CMED6",271,0) . ; -- 2. Med Provider Instructions "RTN","C0CMED6",272,0) . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1") "RTN","C0CMED6",273,0) . N MEDPVIN2,J S (MEDPVIN2,J)="" "RTN","C0CMED6",274,0) . I $L(MEDPVIN1) F S J=$O(@MEDPVIN1@(J)) Q:J="" Q:$L(MEDPVIN2)>10000 S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" " "RTN","C0CMED6",275,0) . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2 "RTN","C0CMED6",276,0) . ; "RTN","C0CMED6",277,0) . ; Remaining refills "RTN","C0CMED6",278,0) . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6) "RTN","C0CMED6",279,0) . ; ------ END OF MAPPING "RTN","C0CMED6",280,0) . ; "RTN","C0CMED6",281,0) . ; ------ BEGIN XML INSERTION "RTN","C0CMED6",282,0) . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) "RTN","C0CMED6",283,0) . K @RESULT "RTN","C0CMED6",284,0) . D MAP^C0CXPATH(MINXML,MAP,RESULT) "RTN","C0CMED6",285,0) . ; D PARY^C0CXPATH(RESULT) "RTN","C0CMED6",286,0) . ; MAPPING DIRECTIONS "RTN","C0CMED6",287,0) . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CMED6",288,0) . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CMED6",289,0) . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) "RTN","C0CMED6",290,0) . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") "RTN","C0CMED6",291,0) . ; N MDZ1,MDZNA "RTN","C0CMED6",292,0) . N DIRCNT S DIRCNT="" "RTN","C0CMED6",293,0) . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; IF THERE ARE DIRCTIONS "RTN","C0CMED6",294,0) . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; FOR EACH DIRECTION "RTN","C0CMED6",295,0) . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT)) "RTN","C0CMED6",296,0) . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) "RTN","C0CMED6",297,0) . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") "RTN","C0CMED6",298,0) . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CMED6",299,0) . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CMED6",300,0) . S MEDCOUNT=MEDCNT "RTN","C0CMED6",301,0) N MEDTMP,MEDI "RTN","C0CMED6",302,0) D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CMED6",303,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CMED6",304,0) . W "MEDICATION MISSING ",! "RTN","C0CMED6",305,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","C0CMED6",306,0) Q "RTN","C0CMED6",307,0) ; "RTN","C0CMED6",308,0) GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm "RTN","C0CMED6",309,0) ;; Get RxNorm Concept Number for a Given NDC "RTN","C0CMED6",310,0) ; "RTN","C0CMED6",311,0) S NDC=$TR(NDC,"-") ; Remove dashes "RTN","C0CMED6",312,0) N RXNORM,C0CZRXN,DIERR "RTN","C0CMED6",313,0) D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR") "RTN","C0CMED6",314,0) I $D(DIERR) D ^%ZTER BREAK "RTN","C0CMED6",315,0) S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries "RTN","C0CMED6",316,0) N I S I=0 "RTN","C0CMED6",317,0) F S I=$O(C0CZRXN("DILIST",I)) Q:I="" S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2) "RTN","C0CMED6",318,0) ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries "RTN","C0CMED6",319,0) ; If RxNorm(0) is 1, then we only have one entry, and that's it. "RTN","C0CMED6",320,0) I RXNORM(0)=1 QUIT RXNORM(1) ; RETURN RXNORM(1) "RTN","C0CMED6",321,0) ; Otherwise, we need to find out which one is the semantic "RTN","C0CMED6",322,0) ; clinical drug. I built an index on 176.001 (RxNorm Concepts) "RTN","C0CMED6",323,0) ; for that purpose. "RTN","C0CMED6",324,0) I RXNORM(0)>1 D "RTN","C0CMED6",325,0) . S I=0 "RTN","C0CMED6",326,0) . F S I=$O(RXNORM(I)) Q:I="" D Q:$G(RXNORM) "RTN","C0CMED6",327,0) . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD") "RTN","C0CMED6",328,0) . . I +$G(RXNIEN)=0 QUIT ; try the next entry... "RTN","C0CMED6",329,0) . . E S RXNORM=RXNORM(I) QUIT ; We found the right code "RTN","C0CMED6",330,0) QUIT +$G(RXNORM) ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0 "RTN","C0CMED6",331,0) "RTN","C0CMIME") 0^37^B99031395 "RTN","C0CMIME",1,0) C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm "RTN","C0CMIME",2,0) ;;1.0;C0C;;Mar 8, 2011;Build 1 "RTN","C0CMIME",3,0) ;Copyright 2008 George Lilly. Licensed under the terms of the GNU "RTN","C0CMIME",4,0) ;General Public License See attached copy of the License. "RTN","C0CMIME",5,0) ; "RTN","C0CMIME",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CMIME",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CMIME",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CMIME",9,0) ;(at your option) any later version. "RTN","C0CMIME",10,0) ; "RTN","C0CMIME",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CMIME",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMIME",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMIME",14,0) ;GNU General Public License for more details. "RTN","C0CMIME",15,0) ; "RTN","C0CMIME",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CMIME",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMIME",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMIME",19,0) ; "RTN","C0CMIME",20,0) Q "RTN","C0CMIME",21,0) ; "RTN","C0CMIME",22,0) TEST(ZDFN) ; "RTN","C0CMIME",23,0) D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH "RTN","C0CMIME",24,0) ;M ZCOPY=ZCCR "RTN","C0CMIME",25,0) S ZCOPY(1)="" "RTN","C0CMIME",26,0) N ZI S ZI=0 "RTN","C0CMIME",27,0) F S ZI=$O(ZCCR(ZI)) Q:ZI="" D ; FOR EACH LINE "RTN","C0CMIME",28,0) . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI) "RTN","C0CMIME",29,0) ;D ENCODE("ZCOPY",1,ZCOPY(1)) "RTN","C0CMIME",30,0) S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) "RTN","C0CMIME",31,0) D CHUNK("G2","G",45) "RTN","C0CMIME",32,0) Q "RTN","C0CMIME",33,0) ENCODE(ZRTN,ZARY) ; "RTN","C0CMIME",34,0) ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING "RTN","C0CMIME",35,0) ; ZARY IS PASSED BY NAME "RTN","C0CMIME",36,0) ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN "RTN","C0CMIME",37,0) ; "RTN","C0CMIME",38,0) S ZCOPY(1)="" "RTN","C0CMIME",39,0) N ZI S ZI=0 "RTN","C0CMIME",40,0) F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE "RTN","C0CMIME",41,0) . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI) "RTN","C0CMIME",42,0) N G "RTN","C0CMIME",43,0) S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) "RTN","C0CMIME",44,0) D CHUNK(ZRTN,"G",45) "RTN","C0CMIME",45,0) Q "RTN","C0CMIME",46,0) ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN "RTN","C0CMIME",47,0) ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line "RTN","C0CMIME",48,0) ; Call with LRSTR by reference, Remainder returned in LRSTR "RTN","C0CMIME",49,0) ; IARY IS PASSED BY NAME "RTN","C0CMIME",50,0) S LRQUIT=0,LRLEN=$L(LRSTR) "RTN","C0CMIME",51,0) F D Q:LRQUIT "RTN","C0CMIME",52,0) . I $L(LRSTR)<45 S LRQUIT=1 Q "RTN","C0CMIME",53,0) . S LRX=$E(LRSTR,1,45) "RTN","C0CMIME",54,0) . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX) "RTN","C0CMIME",55,0) . S LRSTR=$E(LRSTR,46,LRLEN) "RTN","C0CMIME",56,0) Q "RTN","C0CMIME",57,0) ; "RTN","C0CMIME",58,0) TESTMAIL ; "RTN","C0CMIME",59,0) ; TEST OF MAILSEND "RTN","C0CMIME",60,0) ;S ZTO("glilly@glilly.net")="" "RTN","C0CMIME",61,0) S ZTO("mish@nhin.openforum.opensourcevista.net")="" "RTN","C0CMIME",62,0) ;S ZTO("martijn@djigzo.com")="" "RTN","C0CMIME",63,0) ;S ZTO("profmish@gmail.com")="" "RTN","C0CMIME",64,0) ;S ZTO("nanthracite@earthlink.net")="" "RTN","C0CMIME",65,0) S ZFROM="ANTHRACITE.NANCY" "RTN","C0CMIME",66,0) S ZATTACH=$NA(^GPL("CCR")) "RTN","C0CMIME",67,0) I $G(@ZATTACH@(1))="" D ; NO CCR THERE "RTN","C0CMIME",68,0) . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 "RTN","C0CMIME",69,0) . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME "RTN","C0CMIME",70,0) S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" "RTN","C0CMIME",71,0) D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH) "RTN","C0CMIME",72,0) ZWR GR "RTN","C0CMIME",73,0) Q "RTN","C0CMIME",74,0) ; "RTN","C0CMIME",75,0) TESTMAIL2 ; "RTN","C0CMIME",76,0) ; TEST OF MAILSEND TO gpl.mdc-crew.net "RTN","C0CMIME",77,0) N C0CGM "RTN","C0CMIME",78,0) S C0CGM(1)="This is a test message." "RTN","C0CMIME",79,0) S C0CGM(2)="A Continuity of Care record is attached" "RTN","C0CMIME",80,0) S C0CGM(3)="It contains no Protected Health Information (PHI)" "RTN","C0CMIME",81,0) S C0CGM(4)="It is purely test data used for software development" "RTN","C0CMIME",82,0) S C0CGM(5)="It does not represent information about any person living or dead" "RTN","C0CMIME",83,0) ;S ZTO("glilly@glilly.net")="" "RTN","C0CMIME",84,0) ;S ZTO("george.lilly@pobox.com")="" "RTN","C0CMIME",85,0) ;S ZTO("george@nhin.openforum.opensourcevista.net")="" "RTN","C0CMIME",86,0) ;S ZTO("mish@nhin.openforum.opensourcevista.net")="" "RTN","C0CMIME",87,0) S ZTO("brooks.richard@securemail.opensourcevista.net")="" "RTN","C0CMIME",88,0) ;S ZTO("LILLY.GEORGE@mdc-crew.net")="" "RTN","C0CMIME",89,0) ;S ZTO("ncoal@live.com")="" "RTN","C0CMIME",90,0) ;S ZTO("martijn@djigzo.com")="" "RTN","C0CMIME",91,0) ;S ZTO("profmish@gmail.com")="" "RTN","C0CMIME",92,0) ;S ZTO("nanthracite@earthlink.net")="" "RTN","C0CMIME",93,0) S ZTO("gpl.doctortest@gmail.com")="" "RTN","C0CMIME",94,0) S ZFROM="LILLY.GEORGE" "RTN","C0CMIME",95,0) S ZATTACH=$NA(^GPL("CCR")) "RTN","C0CMIME",96,0) I $G(@ZATTACH@(1))="" D ; NO CCR THERE "RTN","C0CMIME",97,0) . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 "RTN","C0CMIME",98,0) . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME "RTN","C0CMIME",99,0) S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" "RTN","C0CMIME",100,0) D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml") "RTN","C0CMIME",101,0) ZWR GR "RTN","C0CMIME",102,0) Q "RTN","C0CMIME",103,0) ; "RTN","C0CMIME",104,0) LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to "RTN","C0CMIME",105,0) ; the email address in C0CTO "RTN","C0CMIME",106,0) ; the directory and the "from" are all hard coded "RTN","C0CMIME",107,0) ; "RTN","C0CMIME",108,0) N ZZFROM S ZZFROM="LILLY.GEORGE" "RTN","C0CMIME",109,0) N GN S GN=$NA(^TMP("C0CMIME2",$J)) "RTN","C0CMIME",110,0) N GN1 S GN1=$NA(@GN@(1)) "RTN","C0CMIME",111,0) K @GN "RTN","C0CMIME",112,0) I '$D(C0CFILE) Q ; NO FILENAME PASSED "RTN","C0CMIME",113,0) I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net" "RTN","C0CMIME",114,0) S ZZTO(C0CTO)="" "RTN","C0CMIME",115,0) N ZMESS S ZMESS(1)="file transmission from wvehr3-09" "RTN","C0CMIME",116,0) N GD S GD="/home/wvehr3-09/EHR/" ; directory "RTN","C0CMIME",117,0) I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q D ; "RTN","C0CMIME",118,0) . W !,"error reading file",C0CFILE "RTN","C0CMIME",119,0) D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE) "RTN","C0CMIME",120,0) K @GN ; CLEAN UP "RTN","C0CMIME",121,0) ;ZWR ZRTN "RTN","C0CMIME",122,0) W !,$G(ZRTN(1)) "RTN","C0CMIME",123,0) Q "RTN","C0CMIME",124,0) ; "RTN","C0CMIME",125,0) MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE "RTN","C0CMIME",126,0) ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE "RTN","C0CMIME",127,0) ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER "RTN","C0CMIME",128,0) ; IF NULL, WILL SEND FROM THE CURRENT DUZ "RTN","C0CMIME",129,0) ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME "RTN","C0CMIME",130,0) ; @TO@("addr1@domain1.net") "RTN","C0CMIME",131,0) ; @CC@("addr2@domain2.com") both can be multiples "RTN","C0CMIME",132,0) ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE "RTN","C0CMIME",133,0) ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT "RTN","C0CMIME",134,0) ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED "RTN","C0CMIME",135,0) ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml "RTN","C0CMIME",136,0) ; "RTN","C0CMIME",137,0) I '$D(FNAME) S FNAME="ccr.xml" ; default filename "RTN","C0CMIME",138,0) N GN "RTN","C0CMIME",139,0) S GN=$NA(^TMP($J,"C0CMIME")) "RTN","C0CMIME",140,0) K @GN "RTN","C0CMIME",141,0) S GM(1)="MIME-Version: 1.0" "RTN","C0CMIME",142,0) S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" "RTN","C0CMIME",143,0) S GM(3)="" "RTN","C0CMIME",144,0) S GM(4)="" "RTN","C0CMIME",145,0) ;S GM(5)="--123456788888" "RTN","C0CMIME",146,0) ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) "RTN","C0CMIME",147,0) S GM(5)="--123456899999" "RTN","C0CMIME",148,0) S GM(6)="Content-Type: text/xml; name="_FNAME "RTN","C0CMIME",149,0) S GM(7)="Content-Transfer-Encoding: base64" "RTN","C0CMIME",150,0) S GM(8)="Content-Disposition: attachment; filename="_FNAME "RTN","C0CMIME",151,0) S GM(9)="" "RTN","C0CMIME",152,0) S GM(10)="" ; FOR THE END "RTN","C0CMIME",153,0) ;S GM(11)="--123456788888--" "RTN","C0CMIME",154,0) S GM(11)="--123456899999--" "RTN","C0CMIME",155,0) S GM(12)="" "RTN","C0CMIME",156,0) S GM(13)="" "RTN","C0CMIME",157,0) S GG(1)="--123456899999" "RTN","C0CMIME",158,0) S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed" "RTN","C0CMIME",159,0) S GG(3)="Content-Transfer-Encoding: 7bit" "RTN","C0CMIME",160,0) S GG(4)="" "RTN","C0CMIME",161,0) S GG(5)="This is a test message." "RTN","C0CMIME",162,0) S GG(6)="A Continuity of Care record is attached" "RTN","C0CMIME",163,0) S GG(7)="It contains no Protected Health Information (PHI)" "RTN","C0CMIME",164,0) S GG(8)="It is purely test data used for software development" "RTN","C0CMIME",165,0) S GG(9)="It does not represent information about any person living or dead" "RTN","C0CMIME",166,0) S GG(10)="" "RTN","C0CMIME",167,0) S GG(11)="--123456899999--" "RTN","C0CMIME",168,0) ;S GG(11)="Content-Type: text/plain; charset=""us-ascii""" "RTN","C0CMIME",169,0) S GG(12)="" "RTN","C0CMIME",170,0) ;S GG(13)="This is a test message." "RTN","C0CMIME",171,0) S GG(14)="A Continuity of Care record is attached" "RTN","C0CMIME",172,0) S GG(15)="It contains no Protected Health Information (PHI)" "RTN","C0CMIME",173,0) S GG(16)="It is purely test data used for software development" "RTN","C0CMIME",174,0) S GG(17)="It does not represent information about any person living or dead" "RTN","C0CMIME",175,0) S GG(18)="" "RTN","C0CMIME",176,0) S GG(19)="--123456899999" "RTN","C0CMIME",177,0) S GG(20)="--987654321--" "RTN","C0CMIME",178,0) K GBLD "RTN","C0CMIME",179,0) ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE "RTN","C0CMIME",180,0) ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE "RTN","C0CMIME",181,0) I $D(MESSAGE)'="" D ; THERE IS A MESSAGE "RTN","C0CMIME",182,0) . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY "RTN","C0CMIME",183,0) . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE "RTN","C0CMIME",184,0) . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE "RTN","C0CMIME",185,0) D QUEUE^C0CXPATH("GBLD","GM",5,9) "RTN","C0CMIME",186,0) I $D(ATTACH)'="" D ; IF WE HAVE AN ATTACHMENT "RTN","C0CMIME",187,0) . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING "RTN","C0CMIME",188,0) . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) "RTN","C0CMIME",189,0) D QUEUE^C0CXPATH("GBLD","GM",11,12) "RTN","C0CMIME",190,0) D BUILD^C0CXPATH("GBLD",GN) "RTN","C0CMIME",191,0) ;S GGG=$NA(^GPL("MIME2")) "RTN","C0CMIME",192,0) K @GN@(0) ; KILL THE LINE COUNT "RTN","C0CMIME",193,0) K LRINSTR,LRTASK,LRTO,XMERR,XMZ "RTN","C0CMIME",194,0) M LRTO=@TO "RTN","C0CMIME",195,0) I $D(CC) M LRTO=@CC "RTN","C0CMIME",196,0) S LRINSTR("ADDR FLAGS")="R" "RTN","C0CMIME",197,0) S LRINSTR("FROM")=$G(FROM) "RTN","C0CMIME",198,0) S LRMSUBJ=$G(SUBJECT) "RTN","C0CMIME",199,0) S LRMSUBJ=$E(LRMSUBJ,1,65) "RTN","C0CMIME",200,0) D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) "RTN","C0CMIME",201,0) I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q ; "RTN","C0CMIME",202,0) S RTN(1)="OK" "RTN","C0CMIME",203,0) Q "RTN","C0CMIME",204,0) ; "RTN","C0CMIME",205,0) MAILSEND0(LRMSUBJ) ; Send extract back to requestor. "RTN","C0CMIME",206,0) ; "RTN","C0CMIME",207,0) ;D TEST "RTN","C0CMIME",208,0) S GN=$NA(^TMP($J,"C0CMIME")) "RTN","C0CMIME",209,0) K @GN "RTN","C0CMIME",210,0) ;M @GN=G2 "RTN","C0CMIME",211,0) S GM(1)="MIME-Version: 1.0" "RTN","C0CMIME",212,0) S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" "RTN","C0CMIME",213,0) S GM(3)="" "RTN","C0CMIME",214,0) S GM(4)="" "RTN","C0CMIME",215,0) S GM(5)="--1234567" "RTN","C0CMIME",216,0) ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) "RTN","C0CMIME",217,0) S GM(6)="Content-Type: text/xml; name=""ccr.xml""" "RTN","C0CMIME",218,0) S GM(7)="Content-Transfer-Encoding: base64" "RTN","C0CMIME",219,0) S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" "RTN","C0CMIME",220,0) ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") "RTN","C0CMIME",221,0) S GM(9)="" "RTN","C0CMIME",222,0) S GM(10)="" ; FOR THE END "RTN","C0CMIME",223,0) S GM(11)="--frontier--" "RTN","C0CMIME",224,0) S GM(12)="." "RTN","C0CMIME",225,0) S GM(13)="" "RTN","C0CMIME",226,0) K GBLD "RTN","C0CMIME",227,0) ;D QUEUE^C0CXPATH("GBLD","GM",1,9) "RTN","C0CMIME",228,0) ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) "RTN","C0CMIME",229,0) ;D QUEUE^C0CXPATH("GBLD","GM",10,13) "RTN","C0CMIME",230,0) ;D BUILD^C0CXPATH("GBLD",GN) "RTN","C0CMIME",231,0) S GGG=$NA(^GPL("MIME2")) "RTN","C0CMIME",232,0) ;D QUEUE^C0CXPATH("GBLD","GM",1,1) "RTN","C0CMIME",233,0) D QUEUE^C0CXPATH("GBLD",GGG,21,159) "RTN","C0CMIME",234,0) D BUILD^C0CXPATH("GBLD",GN) "RTN","C0CMIME",235,0) K @GN@(0) ; KILL THE LINE COUNT "RTN","C0CMIME",236,0) K LRINSTR,LRTASK,LRTO,XMERR,XMZ "RTN","C0CMIME",237,0) S XQSND="glilly@glilly.net" "RTN","C0CMIME",238,0) ;S XQSND="nanthracite@earthlink.net" "RTN","C0CMIME",239,0) ;S XQSND="dlefevre@orohosp.com" "RTN","C0CMIME",240,0) ;S XQSND="gregwoodhouse@me.com" "RTN","C0CMIME",241,0) ;S XQSND="rick.marshall@vistaexpertise.net" "RTN","C0CMIME",242,0) S LRTO(XQSND)="" "RTN","C0CMIME",243,0) S LRINSTR("ADDR FLAGS")="R" "RTN","C0CMIME",244,0) S LRINSTR("FROM")="CCR_PACKAGE" "RTN","C0CMIME",245,0) S LRMSUBJ="A SAMPLE CCR" "RTN","C0CMIME",246,0) S LRMSUBJ=$E(LRMSUBJ,1,65) "RTN","C0CMIME",247,0) D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) "RTN","C0CMIME",248,0) I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; "RTN","C0CMIME",249,0) ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" "RTN","C0CMIME",250,0) ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" "RTN","C0CMIME",251,0) Q "RTN","C0CMIME",252,0) ; "RTN","C0CMIME",253,0) MAILSEND2(UDFN,ADDR) ; Send extract back to requestor. "RTN","C0CMIME",254,0) ; "RTN","C0CMIME",255,0) I +$G(UDFN)=0 S UDFN=2 ; "RTN","C0CMIME",256,0) D TEST(UDFN) "RTN","C0CMIME",257,0) S GN=$NA(^TMP($J,"C0CMIME")) "RTN","C0CMIME",258,0) K @GN "RTN","C0CMIME",259,0) ;M @GN=G2 "RTN","C0CMIME",260,0) S GM(1)="MIME-Version: 1.0" "RTN","C0CMIME",261,0) S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" "RTN","C0CMIME",262,0) S GM(3)="" "RTN","C0CMIME",263,0) S GM(4)="" "RTN","C0CMIME",264,0) S GM(5)="--1234567" "RTN","C0CMIME",265,0) ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) "RTN","C0CMIME",266,0) S GM(6)="Content-Type: text/xml; name=""ccr.xml""" "RTN","C0CMIME",267,0) S GM(7)="Content-Transfer-Encoding: base64" "RTN","C0CMIME",268,0) S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" "RTN","C0CMIME",269,0) ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") "RTN","C0CMIME",270,0) S GM(9)="" "RTN","C0CMIME",271,0) S GM(10)="" ; FOR THE END "RTN","C0CMIME",272,0) S GM(11)="--1234567--" "RTN","C0CMIME",273,0) S GM(12)="" "RTN","C0CMIME",274,0) S GM(13)="" "RTN","C0CMIME",275,0) K GBLD "RTN","C0CMIME",276,0) D QUEUE^C0CXPATH("GBLD","GM",5,9) "RTN","C0CMIME",277,0) D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) "RTN","C0CMIME",278,0) D QUEUE^C0CXPATH("GBLD","GM",10,12) "RTN","C0CMIME",279,0) D BUILD^C0CXPATH("GBLD",GN) "RTN","C0CMIME",280,0) S GGG=$NA(^GPL("MIME2")) "RTN","C0CMIME",281,0) ;D QUEUE^C0CXPATH("GBLD","GM",1,1) "RTN","C0CMIME",282,0) ;D QUEUE^C0CXPATH("GBLD",GGG,21,159) "RTN","C0CMIME",283,0) ;D BUILD^C0CXPATH("GBLD",GN) "RTN","C0CMIME",284,0) K @GN@(0) ; KILL THE LINE COUNT "RTN","C0CMIME",285,0) K LRINSTR,LRTASK,LRTO,XMERR,XMZ "RTN","C0CMIME",286,0) I $G(ADDR)'="" S XQSND=ADDR "RTN","C0CMIME",287,0) E S XQSND="glilly@glilly.net" "RTN","C0CMIME",288,0) ;S XQSND="nanthracite@earthlink.net" "RTN","C0CMIME",289,0) ;S XQSND="dlefevre@orohosp.com" "RTN","C0CMIME",290,0) ;S XQSND="gregwoodhouse@me.com" "RTN","C0CMIME",291,0) ;S XQSND="rick.marshall@vistaexpertise.net" "RTN","C0CMIME",292,0) S LRTO(XQSND)="" "RTN","C0CMIME",293,0) ;S LRTO("glilly@glilly.net")="" "RTN","C0CMIME",294,0) S LRINSTR("ADDR FLAGS")="R" "RTN","C0CMIME",295,0) S LRINSTR("FROM")="ANTHRACITE.NANCY" "RTN","C0CMIME",296,0) S LRMSUBJ="Sending a CCR with Mailman" "RTN","C0CMIME",297,0) S LRMSUBJ=$E(LRMSUBJ,1,65) "RTN","C0CMIME",298,0) D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) "RTN","C0CMIME",299,0) I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; "RTN","C0CMIME",300,0) ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" "RTN","C0CMIME",301,0) ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" "RTN","C0CMIME",302,0) Q "RTN","C0CMIME",303,0) ; "RTN","C0CMIME",304,0) SIMPLE ; "RTN","C0CMIME",305,0) S GN(1)="SIMPLE TEST MESSAGE" "RTN","C0CMIME",306,0) K LRINSTR,LRTASK,LRTO,XMERR,XMZ "RTN","C0CMIME",307,0) S XQSND="glilly@glilly.net" "RTN","C0CMIME",308,0) S LRTO(XQSND)="" "RTN","C0CMIME",309,0) S LRINSTR("ADDR FLAGS")="R" "RTN","C0CMIME",310,0) S LRINSTR("FROM")="CCR_PACKAGE" "RTN","C0CMIME",311,0) S LRMSUBJ="A SAMPLE CCR" "RTN","C0CMIME",312,0) S LRMSUBJ=$E(LRMSUBJ,1,65) "RTN","C0CMIME",313,0) D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK) "RTN","C0CMIME",314,0) Q "RTN","C0CMIME",315,0) CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS "RTN","C0CMIME",316,0) ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS "RTN","C0CMIME",317,0) ; OUTXML IS ALSO PASSED BY NAME "RTN","C0CMIME",318,0) ; IF ZSIZE IS NOT PASSED, 1000 IS USED "RTN","C0CMIME",319,0) I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE "RTN","C0CMIME",320,0) N ZB,ZI,ZJ,ZK,ZL,ZN "RTN","C0CMIME",321,0) S ZB=ZSIZE-1 "RTN","C0CMIME",322,0) S ZN=1 "RTN","C0CMIME",323,0) S ZI=0 ; BEGINNING OF INDEX TO INXML "RTN","C0CMIME",324,0) F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML "RTN","C0CMIME",325,0) . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING "RTN","C0CMIME",326,0) . F ZJ=1:ZSIZE:ZL D ; "RTN","C0CMIME",327,0) . . S ZK=$S(ZJ+ZB0 S NEWNUM="["_ZNUM_"]" "RTN","C0CMXML",153,0) S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE "RTN","C0CMXML",154,0) I $G(ZREDUX)'="" D ; REDUX PROVIDED? "RTN","C0CMXML",155,0) . N GT S GT=$P(NEWPATH,ZREDUX,2) "RTN","C0CMXML",156,0) . I GT'="" S NEWPATH=GT "RTN","C0CMXML",157,0) S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX "RTN","C0CMXML",158,0) N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE "RTN","C0CMXML",159,0) I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY "RTN","C0CMXML",160,0) E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY "RTN","C0CMXML",161,0) N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD "RTN","C0CMXML",162,0) I ZFRST'=0 D ; THERE IS A CHILD "RTN","C0CMXML",163,0) . N ZNUM "RTN","C0CMXML",164,0) . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE "RTN","C0CMXML",165,0) . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD "RTN","C0CMXML",166,0) N GNXT S GNXT=$$NXTSIB(ZOID) "RTN","C0CMXML",167,0) I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES "RTN","C0CMXML",168,0) I GNXT'=0 D ; "RTN","C0CMXML",169,0) . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? "RTN","C0CMXML",170,0) . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES "RTN","C0CMXML",171,0) . . N ZNUM S ZNUM=1 ; "RTN","C0CMXML",172,0) . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB "RTN","C0CMXML",173,0) . E D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB "RTN","C0CMXML",174,0) Q "RTN","C0CMXML",175,0) ; "RTN","C0CMXML",176,0) PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME "RTN","C0CMXML",177,0) ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW "RTN","C0CMXML",178,0) ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML "RTN","C0CMXML",179,0) ;Q $$EN^MXMLDOM(INXML) "RTN","C0CMXML",180,0) Q $$EN^MXMLDOM(INXML,"W") "RTN","C0CMXML",181,0) ; "RTN","C0CMXML",182,0) ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE "RTN","C0CMXML",183,0) N ZN "RTN","C0CMXML",184,0) ;I $$TAG(ZOID)["entry" B "RTN","C0CMXML",185,0) S ZN=$$NXTSIB(ZOID) "RTN","C0CMXML",186,0) I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG "RTN","C0CMXML",187,0) Q 0 "RTN","C0CMXML",188,0) ; "RTN","C0CMXML",189,0) FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID "RTN","C0CMXML",190,0) Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMXML",191,0) ; "RTN","C0CMXML",192,0) PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID "RTN","C0CMXML",193,0) Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMXML",194,0) ; "RTN","C0CMXML",195,0) ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID "RTN","C0CMXML",196,0) S HANDLE=C0CDOCID "RTN","C0CMXML",197,0) K @RTN "RTN","C0CMXML",198,0) D GETTXT^MXMLDOM("A") "RTN","C0CMXML",199,0) Q "RTN","C0CMXML",200,0) ; "RTN","C0CMXML",201,0) TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE "RTN","C0CMXML",202,0) ;I ZOID=149 B ;GPLTEST "RTN","C0CMXML",203,0) N X,Y "RTN","C0CMXML",204,0) S Y="" "RTN","C0CMXML",205,0) S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE "RTN","C0CMXML",206,0) I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y "RTN","C0CMXML",207,0) I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMXML",208,0) Q Y "RTN","C0CMXML",209,0) ; "RTN","C0CMXML",210,0) NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING "RTN","C0CMXML",211,0) Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CMXML",212,0) ; "RTN","C0CMXML",213,0) DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE "RTN","C0CMXML",214,0) ;N ZT,ZN S ZT="" "RTN","C0CMXML",215,0) ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) "RTN","C0CMXML",216,0) ;Q $G(@C0CDOM@(ZOID,"T",1)) "RTN","C0CMXML",217,0) S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) "RTN","C0CMXML",218,0) Q "RTN","C0CMXML",219,0) ; "RTN","C0CMXML",220,0) OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM "RTN","C0CMXML",221,0) ; "RTN","C0CMXML",222,0) S C0CDOCID=INID "RTN","C0CMXML",223,0) D START^C0CMXMLB($$TAG(1),,"G") "RTN","C0CMXML",224,0) D NDOUT($$FIRST(1)) "RTN","C0CMXML",225,0) D END^C0CMXMLB ;END THE DOCUMENT "RTN","C0CMXML",226,0) M @ZRTN=^TMP("MXMLBLD",$J) "RTN","C0CMXML",227,0) K ^TMP("MXMLBLD",$J) "RTN","C0CMXML",228,0) Q "RTN","C0CMXML",229,0) ; "RTN","C0CMXML",230,0) NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE "RTN","C0CMXML",231,0) N ZI S ZI=$$FIRST(ZOID) "RTN","C0CMXML",232,0) I ZI'=0 D ; THERE IS A CHILD "RTN","C0CMXML",233,0) . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT "RTN","C0CMXML",234,0) . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN "RTN","C0CMXML",235,0) E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT "RTN","C0CMXML",236,0) . ;W "DOING",ZOID,! "RTN","C0CMXML",237,0) . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA "RTN","C0CMXML",238,0) . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES "RTN","C0CMXML",239,0) . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN "RTN","C0CMXML",240,0) I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING "RTN","C0CMXML",241,0) . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS "RTN","C0CMXML",242,0) Q "RTN","C0CMXML",243,0) ; "RTN","C0CMXML",244,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CMXML",245,0) K ZERR "RTN","C0CMXML",246,0) D CLEAN^DILF "RTN","C0CMXML",247,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CMXML",248,0) I $D(ZERR) D ; "RTN","C0CMXML",249,0) . W "ERROR",! "RTN","C0CMXML",250,0) . ZWR ZERR "RTN","C0CMXML",251,0) . B "RTN","C0CMXML",252,0) K C0CFDA "RTN","C0CMXML",253,0) Q "RTN","C0CMXML",254,0) ; "RTN","C0CMXMLB") 0^39^B12056407 "RTN","C0CMXMLB",1,0) MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55 "RTN","C0CMXMLB",2,0) ;;8.0;KERNEL;;;Build 1 "RTN","C0CMXMLB",3,0) QUIT "RTN","C0CMXMLB",4,0) ; "RTN","C0CMXMLB",5,0) ;DOC - The top level tag "RTN","C0CMXMLB",6,0) ;DOCTYPE - Want to include a DOCTYPE node "RTN","C0CMXMLB",7,0) ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, "RTN","C0CMXMLB",8,0) START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining. "RTN","C0CMXMLB",9,0) K ^TMP("MXMLBLD",$J) "RTN","C0CMXMLB",10,0) S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 "RTN","C0CMXMLB",11,0) I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 "RTN","C0CMXMLB",12,0) I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) "RTN","C0CMXMLB",13,0) D:$L($G(DOCTYPE)) OUTPUT("") D OUTPUT("<"_DOC_">") "RTN","C0CMXMLB",14,0) Q "RTN","C0CMXMLB",15,0) ; "RTN","C0CMXMLB",16,0) END ;Call this once to close out the document "RTN","C0CMXMLB",17,0) D OUTPUT("") "RTN","C0CMXMLB",18,0) I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J) "RTN","C0CMXMLB",19,0) K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK") "RTN","C0CMXMLB",20,0) Q "RTN","C0CMXMLB",21,0) ; "RTN","C0CMXMLB",22,0) ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item "RTN","C0CMXMLB",23,0) N I,X "RTN","C0CMXMLB",24,0) S ATT=$G(ATT) "RTN","C0CMXMLB",25,0) I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q "RTN","C0CMXMLB",26,0) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"") "RTN","C0CMXMLB",27,0) Q "RTN","C0CMXMLB",28,0) ;DOITEM is a callback to output the lower level. "RTN","C0CMXMLB",29,0) MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule "RTN","C0CMXMLB",30,0) N I,X,S "RTN","C0CMXMLB",31,0) S ATT=$G(ATT) "RTN","C0CMXMLB",32,0) D PUSH($G(INDENT),TAG,.ATT) "RTN","C0CMXMLB",33,0) D @DOITEM "RTN","C0CMXMLB",34,0) D POP "RTN","C0CMXMLB",35,0) Q "RTN","C0CMXMLB",36,0) ; "RTN","C0CMXMLB",37,0) ATT(ATT) ;Output a string of attributes "RTN","C0CMXMLB",38,0) I $D(ATT)<9 Q "" "RTN","C0CMXMLB",39,0) N I,S,V "RTN","C0CMXMLB",40,0) S S="",I="" "RTN","C0CMXMLB",41,0) F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I)) "RTN","C0CMXMLB",42,0) Q S "RTN","C0CMXMLB",43,0) ; "RTN","C0CMXMLB",44,0) Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11 "RTN","C0CMXMLB",45,0) ;I X'[$C(34) Q $C(34)_X_$C(34) "RTN","C0CMXMLB",46,0) I X'[$C(39) Q $C(39)_X_$C(39) "RTN","C0CMXMLB",47,0) ;N Q,Y,I,Z S Q=$C(34),(Y,Z)="" "RTN","C0CMXMLB",48,0) N Q,Y,I,Z S Q=$C(39),(Y,Z)="" "RTN","C0CMXMLB",49,0) F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q "RTN","C0CMXMLB",50,0) S Y=Y_$P(X,Q,$L(X,Q)) "RTN","C0CMXMLB",51,0) ;Q $C(34)_Y_$C(34) "RTN","C0CMXMLB",52,0) Q $C(39)_Y_$C(39) "RTN","C0CMXMLB",53,0) ; "RTN","C0CMXMLB",54,0) XMLHDR() ; -- provides current XML standard header "RTN","C0CMXMLB",55,0) Q "" "RTN","C0CMXMLB",56,0) ; "RTN","C0CMXMLB",57,0) OUTPUT(S) ;Output "RTN","C0CMXMLB",58,0) N C S C=$G(^TMP("MXMLBLD",$J,"CNT")) "RTN","C0CMXMLB",59,0) I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q "RTN","C0CMXMLB",60,0) W S,! "RTN","C0CMXMLB",61,0) Q "RTN","C0CMXMLB",62,0) ; "RTN","C0CMXMLB",63,0) CHARCHK(STR) ; -- replace xml character limits with entities "RTN","C0CMXMLB",64,0) N A,I,X,Y,Z,NEWSTR "RTN","C0CMXMLB",65,0) S (Y,Z)="" "RTN","C0CMXMLB",66,0) ;IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z "RTN","C0CMXMLB",67,0) ;. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&" "RTN","C0CMXMLB",68,0) I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&"_$P(STR,"&",I+1,999) "RTN","C0CMXMLB",69,0) I STR["<" F S STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<" "RTN","C0CMXMLB",70,0) I STR[">" F S STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">" "RTN","C0CMXMLB",71,0) I STR["'" F S STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'" "RTN","C0CMXMLB",72,0) I STR["""" F S STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) Q:STR'["""" "RTN","C0CMXMLB",73,0) ; "RTN","C0CMXMLB",74,0) S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31)) "RTN","C0CMXMLB",75,0) QUIT STR "RTN","C0CMXMLB",76,0) ; "RTN","C0CMXMLB",77,0) COMMENT(VAL) ;Add Comments "RTN","C0CMXMLB",78,0) N I,L "RTN","C0CMXMLB",79,0) ;I $D($G(VAL))=1 D OUTPUT("") Q "RTN","C0CMXMLB",80,0) I $D(VAL) D OUTPUT("") Q ;CHANGED BY GPL FOR GTM "RTN","C0CMXMLB",81,0) S I="",L="") "RTN","C0CMXMLB",84,0) Q "RTN","C0CMXMLB",85,0) ; "RTN","C0CMXMLB",86,0) PUSH(INDENT,TAG,ATT) ;Write a TAG and save. "RTN","C0CMXMLB",87,0) N CNT "RTN","C0CMXMLB",88,0) S ATT=$G(ATT) "RTN","C0CMXMLB",89,0) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">") "RTN","C0CMXMLB",90,0) S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG "RTN","C0CMXMLB",91,0) Q "RTN","C0CMXMLB",92,0) ; "RTN","C0CMXMLB",93,0) POP ;Write last pushed tag and pop "RTN","C0CMXMLB",94,0) N CNT,TAG,INDENT,X "RTN","C0CMXMLB",95,0) S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1 "RTN","C0CMXMLB",96,0) S INDENT=+X,TAG=$P(X,"^",2) "RTN","C0CMXMLB",97,0) D OUTPUT($$BLS(INDENT)_"") "RTN","C0CMXMLB",98,0) Q "RTN","C0CMXMLB",99,0) ; "RTN","C0CMXMLB",100,0) BLS(I) ;Return INDENT string "RTN","C0CMXMLB",101,0) N S "RTN","C0CMXMLB",102,0) S S="",I=$G(I) S:I>0 $P(S," ",I)=" " "RTN","C0CMXMLB",103,0) Q S "RTN","C0CMXMLB",104,0) ; "RTN","C0CMXMLB",105,0) INDENT() ;Renturn indent level "RTN","C0CMXMLB",106,0) Q +$G(^TMP("MXMLBLD",$J,"STK")) "RTN","C0CMXP") 0^40^B77680190 "RTN","C0CMXP",1,0) C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 "RTN","C0CMXP",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CMXP",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CMXP",4,0) ;General Public License See attached copy of the License. "RTN","C0CMXP",5,0) ; "RTN","C0CMXP",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CMXP",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CMXP",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CMXP",9,0) ;(at your option) any later version. "RTN","C0CMXP",10,0) ; "RTN","C0CMXP",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CMXP",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CMXP",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CMXP",14,0) ;GNU General Public License for more details. "RTN","C0CMXP",15,0) ; "RTN","C0CMXP",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CMXP",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CMXP",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CMXP",19,0) ; "RTN","C0CMXP",20,0) Q "RTN","C0CMXP",21,0) ; "RTN","C0CMXP",22,0) INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY "RTN","C0CMXP",23,0) ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD "RTN","C0CMXP",24,0) D INITFARY^C0CSOAP(ARY) ; "RTN","C0CMXP",25,0) Q "RTN","C0CMXP",26,0) S @ARY@("XML FILE NUMBER")=178.101 "RTN","C0CMXP",27,0) S @ARY@("XML SOURCE FIELD")=2.1 "RTN","C0CMXP",28,0) S @ARY@("XML TEMPLATE FIELD")=3 "RTN","C0CMXP",29,0) S @ARY@("XPATH BINDING SUBFILE")=178.1014 "RTN","C0CMXP",30,0) S @ARY@("REDUX FIELD")=2.5 "RTN","C0CMXP",31,0) Q "RTN","C0CMXP",32,0) ; "RTN","C0CMXP",33,0) SETXPF(ARY) ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY "RTN","C0CMXP",34,0) ; "RTN","C0CMXP",35,0) S C0CXPF=@ARY@("XML FILE NUMBER") "RTN","C0CMXP",36,0) S C0CXFLD=@ARY@("XML") "RTN","C0CMXP",37,0) S C0CXTFLD=@ARY@("TEMPLATE XML") "RTN","C0CMXP",38,0) S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER") "RTN","C0CMXP",39,0) S C0CRDUXF=@ARY@("XPATH REDUCTION STRING") "RTN","C0CMXP",40,0) Q "RTN","C0CMXP",41,0) ; "RTN","C0CMXP",42,0) ADDXP(INARY,TID,FARY) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID "RTN","C0CMXP",43,0) I '$D(FARY) D ; "RTN","C0CMXP",44,0) . S FARY="FARY" ; FILE ARRAY "RTN","C0CMXP",45,0) . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE "RTN","C0CMXP",46,0) D SETXPF(FARY) ;SET FILE VARIABLES "RTN","C0CMXP",47,0) N C0CA,C0CB "RTN","C0CMXP",48,0) S C0CA="" S C0CB=0 "RTN","C0CMXP",49,0) F S C0CA=$O(@INARY@(C0CA)) Q:C0CA="" D ; FOR EACH XPATH "RTN","C0CMXP",50,0) . S C0CB=C0CB+1 ; COUNT OF XPATHS "RTN","C0CMXP",51,0) . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA "RTN","C0CMXP",52,0) . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH "RTN","C0CMXP",53,0) Q "RTN","C0CMXP",54,0) ; "RTN","C0CMXP",55,0) FIXICD9 ; FIX THE ICD9RESULT XML "RTN","C0CMXP",56,0) D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE "RTN","C0CMXP",57,0) S ZI="" "RTN","C0CMXP",58,0) S G="" "RTN","C0CMXP",59,0) F S ZI=$O(GPL(ZI)) Q:ZI="" D ; FOR EACH LINE "RTN","C0CMXP",60,0) . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML "RTN","C0CMXP",61,0) D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY "RTN","C0CMXP",62,0) D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK "RTN","C0CMXP",63,0) Q "RTN","C0CMXP",64,0) ADDXML(INXML,TEMPID,INFARY) ;ADD XML TO A TEMPLATE ID TEMPID "RTN","C0CMXP",65,0) ; INXML IS PASSED BY NAME "RTN","C0CMXP",66,0) I '$D(INFARY) D ; "RTN","C0CMXP",67,0) . S INFARY="FARY" ; FILE ARRAY "RTN","C0CMXP",68,0) . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE "RTN","C0CMXP",69,0) I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME "RTN","C0CMXP",70,0) D SETXPF(INFARY) ;SET FILE VARIABLES "RTN","C0CMXP",71,0) D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML) "RTN","C0CMXP",72,0) Q "RTN","C0CMXP",73,0) ; "RTN","C0CMXP",74,0) ADDTEMP(INXML,TEMPID,INFARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID "RTN","C0CMXP",75,0) ; "RTN","C0CMXP",76,0) I '$D(INFARY) D ; "RTN","C0CMXP",77,0) . S INFARY="FARY" ; FILE ARRAY "RTN","C0CMXP",78,0) . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE "RTN","C0CMXP",79,0) I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME "RTN","C0CMXP",80,0) D SETXPF(INFARY) ;SET FILE VARIABLES "RTN","C0CMXP",81,0) D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML) "RTN","C0CMXP",82,0) Q "RTN","C0CMXP",83,0) ; "RTN","C0CMXP",84,0) GETXML(OUTXML,TEMPID,INFARY) ;GET THE XML FROM TEMPLATE TEMPID "RTN","C0CMXP",85,0) ; "RTN","C0CMXP",86,0) I '$D(INFARY) D ; "RTN","C0CMXP",87,0) . S INFARY="FARY" ; FILE ARRAY "RTN","C0CMXP",88,0) . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE "RTN","C0CMXP",89,0) D SETXPF(INFARY) ;SET FILE VARIABLES "RTN","C0CMXP",90,0) I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME "RTN","C0CMXP",91,0) I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D Q ; "RTN","C0CMXP",92,0) . W "ERROR RETRIEVING TEMPLATE",! "RTN","C0CMXP",93,0) Q "RTN","C0CMXP",94,0) ; "RTN","C0CMXP",95,0) GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID "RTN","C0CMXP",96,0) ; "RTN","C0CMXP",97,0) I '$D(FARY) D ; "RTN","C0CMXP",98,0) . S FARY="FARY" ; FILE ARRAY "RTN","C0CMXP",99,0) . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE "RTN","C0CMXP",100,0) D SETXPF(FARY) ;SET FILE VARIABLES "RTN","C0CMXP",101,0) I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME "RTN","C0CMXP",102,0) I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D Q ; "RTN","C0CMXP",103,0) . W "ERROR RETRIEVING TEMPLATE",! "RTN","C0CMXP",104,0) Q "RTN","C0CMXP",105,0) ; "RTN","C0CMXP",106,0) COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) ; COPIES A WORD PROCESSING FIELD "RTN","C0CMXP",107,0) ; FROM ONE RECORD TO ANOTHER RECORD "RTN","C0CMXP",108,0) ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF "RTN","C0CMXP",109,0) ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT "RTN","C0CMXP",110,0) ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED "RTN","C0CMXP",111,0) ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME "RTN","C0CMXP",112,0) ; A ZSRCF "RTN","C0CMXP",113,0) I '$D(ZSRCF) D ; "RTN","C0CMXP",114,0) . S ZSRCF="ZSRCF" "RTN","C0CMXP",115,0) . D INITFARY^C0CSOAP(ZSRCF) "RTN","C0CMXP",116,0) I '$D(ZDESTF) D ; "RTN","C0CMXP",117,0) . S ZDESTF="ZDESTF" "RTN","C0CMXP",118,0) . M @ZDESTF=@ZSRCF "RTN","C0CMXP",119,0) N ZSF,ZDF,ZSFREF,ZDFREF "RTN","C0CMXP",120,0) S ZSF=@ZSRCF@("XML FILE NUMBER") "RTN","C0CMXP",121,0) S ZSFREF=$$FILEREF^C0CRNF(ZSF) "RTN","C0CMXP",122,0) S ZDF=@ZDESTF@("XML FILE NUMBER") "RTN","C0CMXP",123,0) S ZDFREF=$$FILEREF^C0CRNF(ZDF) "RTN","C0CMXP",124,0) N ZSIEN,ZDIEN "RTN","C0CMXP",125,0) S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,"")) "RTN","C0CMXP",126,0) I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q ; "RTN","C0CMXP",127,0) S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,"")) "RTN","C0CMXP",128,0) I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q ; "RTN","C0CMXP",129,0) N ZFLDNUM "RTN","C0CMXP",130,0) I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME "RTN","C0CMXP",131,0) E S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER "RTN","C0CMXP",132,0) N ZWP,ZWPN "RTN","C0CMXP",133,0) S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE "RTN","C0CMXP",134,0) I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q ; "RTN","C0CMXP",135,0) D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST "RTN","C0CMXP",136,0) Q "RTN","C0CMXP",137,0) ; "RTN","C0CMXP",138,0) COMPILE(TID,UFARY) ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS "RTN","C0CMXP",139,0) ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE "RTN","C0CMXP",140,0) ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE "RTN","C0CMXP",141,0) ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT "RTN","C0CMXP",142,0) ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE "RTN","C0CMXP",143,0) ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01 "RTN","C0CMXP",144,0) I '$D(UFARY) D ; "RTN","C0CMXP",145,0) . S UFARY="DEFFARY" ; FILE ARRAY "RTN","C0CMXP",146,0) . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE "RTN","C0CMXP",147,0) . D INITFARY^C0CSOAP(UFARY) "RTN","C0CMXP",148,0) D SETXPF(UFARY) ;SET FILE VARIABLES "RTN","C0CMXP",149,0) I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY) "RTN","C0CMXP",150,0) E S INTID=TID "RTN","C0CMXP",151,0) ;B "RTN","C0CMXP",152,0) ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX "RTN","C0CMXP",153,0) D GETXML("C0CXML",INTID,UFARY) "RTN","C0CMXP",154,0) S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING "RTN","C0CMXP",155,0) D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX "RTN","C0CMXP",156,0) D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE "RTN","C0CMXP",157,0) D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH "RTN","C0CMXP",158,0) Q "RTN","C0CMXP",159,0) ; "RTN","C0CMXP",160,0) MKTPLATE(OUTT,OUTIDX,INXML,REDUX) ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT "RTN","C0CMXP",161,0) ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED "RTN","C0CMXP",162,0) ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE "RTN","C0CMXP",163,0) ; "RTN","C0CMXP",164,0) S C0CXLOC=$NA(^TMP("C0CXML",$J)) "RTN","C0CMXP",165,0) K @C0CXLOC "RTN","C0CMXP",166,0) M @C0CXLOC=@INXML "RTN","C0CMXP",167,0) S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT") "RTN","C0CMXP",168,0) K @C0CXLOC "RTN","C0CMXP",169,0) S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) "RTN","C0CMXP",170,0) ;N GIDX,GIDX2,GARY,GARY2 "RTN","C0CMXP",171,0) I '$D(REDUX) S REDUX="" "RTN","C0CMXP",172,0) D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX) "RTN","C0CMXP",173,0) D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE "RTN","C0CMXP",174,0) N ZI,ZD S ZI="" "RTN","C0CMXP",175,0) F S ZI=$O(@C0CDOM@(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE DOM "RTN","C0CMXP",176,0) . K ZD ;FOR DATA "RTN","C0CMXP",177,0) . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE "RTN","C0CMXP",178,0) . ;I $D(ZD(1)) D ; IF YES "RTN","C0CMXP",179,0) . I $$FIRST^C0CMXML(ZI)=0 D ; IF THERE ARE NO CHILDREN TO THIS NODE "RTN","C0CMXP",180,0) . . ;I ZI<3 B ;W !,ZD(1) "RTN","C0CMXP",181,0) . . K @C0CDOM@(ZI,"T") ; KILL THE DATA "RTN","C0CMXP",182,0) . . N ZXPATH "RTN","C0CMXP",183,0) . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE "RTN","C0CMXP",184,0) . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@" "RTN","C0CMXP",185,0) . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX "RTN","C0CMXP",186,0) D OUTXML^C0CMXML(OUTT,C0CDOCID) "RTN","C0CMXP",187,0) Q "RTN","C0CMXP",188,0) ; "RTN","C0CMXP",189,0) INVERT(OUTX,INX) ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from "RTN","C0CMXP",190,0) ; @INX@(XPath)=x "RTN","C0CMXP",191,0) N ZI S ZI="" "RTN","C0CMXP",192,0) F S ZI=$O(@INX@(ZI)) Q:ZI="" D ;FOR EACH XPATH IN THE INPUT "RTN","C0CMXP",193,0) . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY "RTN","C0CMXP",194,0) Q "RTN","C0CMXP",195,0) ; "RTN","C0CMXP",196,0) DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES "RTN","C0CMXP",197,0) ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH "RTN","C0CMXP",198,0) N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB "RTN","C0CMXP",199,0) S (ZMULT,ZSUB)="" "RTN","C0CMXP",200,0) S ZX=$P(INX,"[",2) "RTN","C0CMXP",201,0) I ZX'="" D ; THERE IS A [x] MULTIPLE "RTN","C0CMXP",202,0) . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH "RTN","C0CMXP",203,0) . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE "RTN","C0CMXP",204,0) . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH "RTN","C0CMXP",205,0) . I $P(ZX,"[",2)'="" D ; A SUB MULTIPLE EXISTS "RTN","C0CMXP",206,0) . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH "RTN","C0CMXP",207,0) . . S ZX=$P(ZX,"[",2) ; DELETE THE [ "RTN","C0CMXP",208,0) . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE "RTN","C0CMXP",209,0) . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH "RTN","C0CMXP",210,0) E S ZX=INX ;NO MULTIPLE HERE "RTN","C0CMXP",211,0) S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH "RTN","C0CMXP",212,0) Q "RTN","C0CMXP",213,0) ; "RTN","C0CMXP",214,0) DEMUXARY(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO "RTN","C0CMXP",215,0) ; FORMAT @OARY@(x,variablename) where x is the first multiple "RTN","C0CMXP",216,0) ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED "RTN","C0CMXP",217,0) N ZI,ZJ,ZK,ZL,ZM S ZI="" "RTN","C0CMXP",218,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; "RTN","C0CMXP",219,0) . D DEMUX^C0CMXP("ZJ",ZI) "RTN","C0CMXP",220,0) . S ZK=$P(ZJ,"^",3) "RTN","C0CMXP",221,0) . S ZM=$RE($P($RE(ZK),"/",1)) "RTN","C0CMXP",222,0) . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME "RTN","C0CMXP",223,0) . . S ZM=$RE($P($RE(ZK),"/",2))_ZM "RTN","C0CMXP",224,0) . S ZL=$P(ZJ,"^",1) "RTN","C0CMXP",225,0) . I ZL="" S ZL=1 "RTN","C0CMXP",226,0) . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP "RTN","C0CMXP",227,0) . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) "RTN","C0CMXP",228,0) . E S @OARY@(ZL,ZM)=@IARY@(ZI) "RTN","C0CMXP",229,0) Q "RTN","C0CMXP",230,0) ; "RTN","C0CMXP",231,0) DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO "RTN","C0CMXP",232,0) ; FORMAT @OARY@(x,variablename) where x is the first multiple "RTN","C0CMXP",233,0) ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED "RTN","C0CMXP",234,0) N ZI,ZJ,ZK,ZL,ZM S ZI="" "RTN","C0CMXP",235,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; "RTN","C0CMXP",236,0) . D DEMUX^C0CMXP("ZJ",ZI) "RTN","C0CMXP",237,0) . S ZK=$P(ZJ,"^",3) "RTN","C0CMXP",238,0) . S ZM=$RE($P($RE(ZK),"/",1)) "RTN","C0CMXP",239,0) . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME "RTN","C0CMXP",240,0) . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM "RTN","C0CMXP",241,0) . S ZL=$P(ZJ,"^",1) "RTN","C0CMXP",242,0) . I ZL="" S ZL=1 "RTN","C0CMXP",243,0) . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP "RTN","C0CMXP",244,0) . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) "RTN","C0CMXP",245,0) . E S @OARY@(ZL,ZM)=@IARY@(ZI) "RTN","C0CMXP",246,0) Q "RTN","C0CMXP",247,0) ; "RTN","C0CMXP",248,0) DEMUXXP1(OARY,IARY) ;IARY IS INCOMING XPATH ARRAY "RTN","C0CMXP",249,0) ; BOTH IARY AND OARY ARE PASSED BY NAME "RTN","C0CMXP",250,0) ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED "RTN","C0CMXP",251,0) N ZI,ZJ,ZK "RTN","C0CMXP",252,0) S ZI="" "RTN","C0CMXP",253,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH XPATH IN IARY "RTN","C0CMXP",254,0) . D DEMUX^C0CMXP("ZJ",ZI) "RTN","C0CMXP",255,0) . S ZK=$P(ZJ,"^",3) ;THE XPATH "RTN","C0CMXP",256,0) . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW "RTN","C0CMXP",257,0) . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST "RTN","C0CMXP",258,0) . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE "RTN","C0CMXP",259,0) . ; COMMON XPATH "RTN","C0CMXP",260,0) Q "RTN","C0CMXP",261,0) ; "RTN","C0CMXP",262,0) DEMUXXP2(OARY,IARY) ; IARY AND OARY ARE PASSED BY NAME "RTN","C0CMXP",263,0) ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES "RTN","C0CMXP",264,0) ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM "RTN","C0CMXP",265,0) ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE "RTN","C0CMXP",266,0) ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y] "RTN","C0CMXP",267,0) ; "RTN","C0CMXP",268,0) N ZI,ZJ,ZK,ZX,ZY,ZP "RTN","C0CMXP",269,0) S ZI="" "RTN","C0CMXP",270,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH INPUT XPATH "RTN","C0CMXP",271,0) . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES "RTN","C0CMXP",272,0) . S ZX=$P(ZJ,"^",1) ;x "RTN","C0CMXP",273,0) . S ZY=$P(ZJ,"^",2) ;y "RTN","C0CMXP",274,0) . S ZP=$P(ZJ,"^",3) ;Xpath "RTN","C0CMXP",275,0) . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1 "RTN","C0CMXP",276,0) . I ZY'="" D ;IS THERE A y? "RTN","C0CMXP",277,0) . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI) "RTN","C0CMXP",278,0) . E D ;NO y "RTN","C0CMXP",279,0) . . S @OARY@(ZX,ZP)=@IARY@(ZI) "RTN","C0CMXP",280,0) Q "RTN","C0CMXP",281,0) ; "RTN","C0CMXP",282,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CMXP",283,0) K ZERR "RTN","C0CMXP",284,0) D CLEAN^DILF "RTN","C0CMXP",285,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CMXP",286,0) I $D(ZERR) D ; "RTN","C0CMXP",287,0) . W "ERROR",! "RTN","C0CMXP",288,0) . ZWR ZERR "RTN","C0CMXP",289,0) . B "RTN","C0CMXP",290,0) K C0CFDA "RTN","C0CMXP",291,0) Q "RTN","C0CMXP",292,0) ; "RTN","C0CNHIN") 0^41^B87973392 "RTN","C0CNHIN",1,0) C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05 "RTN","C0CNHIN",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CNHIN",3,0) ;Copyright 2011 George Lilly. Licensed under the terms of the GNU "RTN","C0CNHIN",4,0) ;General Public License See attached copy of the License. "RTN","C0CNHIN",5,0) ; "RTN","C0CNHIN",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CNHIN",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CNHIN",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CNHIN",9,0) ;(at your option) any later version. "RTN","C0CNHIN",10,0) ; "RTN","C0CNHIN",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CNHIN",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CNHIN",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CNHIN",14,0) ;GNU General Public License for more details. "RTN","C0CNHIN",15,0) ; "RTN","C0CNHIN",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CNHIN",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CNHIN",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CNHIN",19,0) ; "RTN","C0CNHIN",20,0) Q "RTN","C0CNHIN",21,0) EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT "RTN","C0CNHIN",22,0) ; "RTN","C0CNHIN",23,0) K GARY,GNARY,GIDX,C0CDOCID "RTN","C0CNHIN",24,0) N GN "RTN","C0CNHIN",25,0) K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL "RTN","C0CNHIN",26,0) K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM "RTN","C0CNHIN",27,0) K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS "RTN","C0CNHIN",28,0) D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML "RTN","C0CNHIN",29,0) S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL "RTN","C0CNHIN",30,0) S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML "RTN","C0CNHIN",31,0) D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS "RTN","C0CNHIN",32,0) I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 "RTN","C0CNHIN",33,0) ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP)) "RTN","C0CNHIN",34,0) Q "RTN","C0CNHIN",35,0) ; "RTN","C0CNHIN",36,0) PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE "RTN","C0CNHIN",37,0) ; "RTN","C0CNHIN",38,0) N ZG "RTN","C0CNHIN",39,0) S ZG=$NA(^TMP("PQRIXML",$J)) "RTN","C0CNHIN",40,0) K @ZG "RTN","C0CNHIN",41,0) D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML "RTN","C0CNHIN",42,0) N C0CDOCID "RTN","C0CNHIN",43,0) S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML "RTN","C0CNHIN",44,0) D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS "RTN","C0CNHIN",45,0) I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 "RTN","C0CNHIN",46,0) Q "RTN","C0CNHIN",47,0) ; "RTN","C0CNHIN",48,0) PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE "RTN","C0CNHIN",49,0) ; "RTN","C0CNHIN",50,0) ;N GG "RTN","C0CNHIN",51,0) D GETXML^C0CMXP("GG","PQRI ONE MEASURE") "RTN","C0CNHIN",52,0) D PROCESS(ZRTN,"GG","root",1) "RTN","C0CNHIN",53,0) Q "RTN","C0CNHIN",54,0) ; "RTN","C0CNHIN",55,0) PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML "RTN","C0CNHIN",56,0) ; ZRTN IS PASSED BY REFERENCE "RTN","C0CNHIN",57,0) ; ZXML IS PASSED BY NAME "RTN","C0CNHIN",58,0) ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED "RTN","C0CNHIN",59,0) ; "RTN","C0CNHIN",60,0) N GN "RTN","C0CNHIN",61,0) S GN=$NA(^TMP("C0CPROCESS",$J)) "RTN","C0CNHIN",62,0) K @GN "RTN","C0CNHIN",63,0) M @GN=@ZXML "RTN","C0CNHIN",64,0) S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML "RTN","C0CNHIN",65,0) K @GN "RTN","C0CNHIN",66,0) D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS "RTN","C0CNHIN",67,0) I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 "RTN","C0CNHIN",68,0) Q "RTN","C0CNHIN",69,0) ; "RTN","C0CNHIN",70,0) LOADSMRT ; "RTN","C0CNHIN",71,0) ; "RTN","C0CNHIN",72,0) K ^GPL("SMART") "RTN","C0CNHIN",73,0) S GN=$NA(^GPL("SMART",1)) "RTN","C0CNHIN",74,0) I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED" "RTN","C0CNHIN",75,0) Q "RTN","C0CNHIN",76,0) ; "RTN","C0CNHIN",77,0) SMART ; TRY IT WITH SMART "RTN","C0CNHIN",78,0) ; "RTN","C0CNHIN",79,0) S GN=$NA(^GPL("SMART")) "RTN","C0CNHIN",80,0) ;K ^TMP("MXMLDOM",$J) "RTN","C0CNHIN",81,0) K ^TMP("MXMLERR",$J) "RTN","C0CNHIN",82,0) S C0CDOCID=$$PARSE(GN,"SMART") "RTN","C0CNHIN",83,0) D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/") "RTN","C0CNHIN",84,0) ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG "RTN","C0CNHIN",85,0) Q "RTN","C0CNHIN",86,0) ; "RTN","C0CNHIN",87,0) CCR ; TRY IT WITH A CCR "RTN","C0CNHIN",88,0) ; "RTN","C0CNHIN",89,0) S GN=$NA(^GPL("CCR")) "RTN","C0CNHIN",90,0) ;K ^TMP("MXMLDOM",$J) "RTN","C0CNHIN",91,0) K ^TMP("MXMLERR",$J) "RTN","C0CNHIN",92,0) S C0CDOCID=$$PARSE(GN,"CCR") "RTN","C0CNHIN",93,0) D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/") "RTN","C0CNHIN",94,0) ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG "RTN","C0CNHIN",95,0) Q "RTN","C0CNHIN",96,0) ; "RTN","C0CNHIN",97,0) MED ; TRY IT WITH A CCR MED SECTION "RTN","C0CNHIN",98,0) ; "RTN","C0CNHIN",99,0) S GN=$NA(^GPL("MED")) "RTN","C0CNHIN",100,0) K ^TMP("MXMLDOM",$J) "RTN","C0CNHIN",101,0) K ^TMP("MXMLERR",$J) "RTN","C0CNHIN",102,0) S C0CDOCID=$$PARSE(GN,"MED") "RTN","C0CNHIN",103,0) D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/") "RTN","C0CNHIN",104,0) ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG "RTN","C0CNHIN",105,0) Q "RTN","C0CNHIN",106,0) ; "RTN","C0CNHIN",107,0) CCD ; TRY IT WITH A CCD "RTN","C0CNHIN",108,0) ; "RTN","C0CNHIN",109,0) S GN=$NA(^GPL("CCD")) "RTN","C0CNHIN",110,0) ;K ^TMP("MXMLDOM",$J) "RTN","C0CNHIN",111,0) K ^TMP("MXMLERR",$J) "RTN","C0CNHIN",112,0) S C0CDOCID=$$PARSE(GN,"CCD") "RTN","C0CNHIN",113,0) D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/") "RTN","C0CNHIN",114,0) ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG "RTN","C0CNHIN",115,0) Q "RTN","C0CNHIN",116,0) ; "RTN","C0CNHIN",117,0) TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") "RTN","C0CNHIN",118,0) ; PARSED WITH MXML "RTN","C0CNHIN",119,0) ; RUN THROUGH XPATH "RTN","C0CNHIN",120,0) K GARY,GIDX,C0CDOCID "RTN","C0CNHIN",121,0) S GN=$NA(^GPL("NHIN")) "RTN","C0CNHIN",122,0) ;S GN=$NA(^GPL("DOMI")) "RTN","C0CNHIN",123,0) S C0CDOCID=$$PARSE(GN,"GPLTEST") "RTN","C0CNHIN",124,0) D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") "RTN","C0CNHIN",125,0) K ^GPL("GNARY") "RTN","C0CNHIN",126,0) M ^GPL("GNARY")=GNARY "RTN","C0CNHIN",127,0) Q "RTN","C0CNHIN",128,0) ; "RTN","C0CNHIN",129,0) TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI") "RTN","C0CNHIN",130,0) ; "RTN","C0CNHIN",131,0) S GN=$NA(^GPL("GNARY")) "RTN","C0CNHIN",132,0) S C0CDOCID=$$DOMI^C0CDOM(GN,,"results") "RTN","C0CNHIN",133,0) D OUTXML^C0CDOM("G",C0CDOCID) "RTN","C0CNHIN",134,0) K ^GPL("DOMI") "RTN","C0CNHIN",135,0) M ^GPL("DOMI")=G "RTN","C0CNHIN",136,0) Q "RTN","C0CNHIN",137,0) ; "RTN","C0CNHIN",138,0) TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") "RTN","C0CNHIN",139,0) ; PARSED WITH MXML "RTN","C0CNHIN",140,0) ; RUN THROUGH XPATH "RTN","C0CNHIN",141,0) K GARY,GIDX,C0CDOCID "RTN","C0CNHIN",142,0) ;S GN=$NA(^GPL("NHIN")) "RTN","C0CNHIN",143,0) S GN=$NA(^GPL("DOMI")) "RTN","C0CNHIN",144,0) S C0CDOCID=$$PARSE(GN,"GPLTEST") "RTN","C0CNHIN",145,0) D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") "RTN","C0CNHIN",146,0) Q "RTN","C0CNHIN",147,0) ; "RTN","C0CNHIN",148,0) DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE "RTN","C0CNHIN",149,0) ; THE XPATH INDEX ZXIDX, PASSED BY NAME "RTN","C0CNHIN",150,0) ; THE XPATH ARRAY XPARY, PASSED BY NAME "RTN","C0CNHIN",151,0) ; ZOID IS THE STARTING OID "RTN","C0CNHIN",152,0) ; ZPATH IS THE STARTING XPATH, USUALLY "/" "RTN","C0CNHIN",153,0) ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE "RTN","C0CNHIN",154,0) ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT "RTN","C0CNHIN",155,0) I $G(ZREDUX)="" S ZREDUX="" "RTN","C0CNHIN",156,0) N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY "RTN","C0CNHIN",157,0) N NEWNUM S NEWNUM="" "RTN","C0CNHIN",158,0) I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" "RTN","C0CNHIN",159,0) S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE "RTN","C0CNHIN",160,0) I $G(ZREDUX)'="" D ; REDUX PROVIDED? "RTN","C0CNHIN",161,0) . N GT S GT=$P(NEWPATH,ZREDUX,2) "RTN","C0CNHIN",162,0) . I GT'="" S NEWPATH=GT "RTN","C0CNHIN",163,0) S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX "RTN","C0CNHIN",164,0) N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE "RTN","C0CNHIN",165,0) I $D(GA) D ; PROCESS THE ATTRIBUTES "RTN","C0CNHIN",166,0) . N ZI S ZI="" "RTN","C0CNHIN",167,0) . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE "RTN","C0CNHIN",168,0) . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE "RTN","C0CNHIN",169,0) . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY "RTN","C0CNHIN",170,0) . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE "RTN","C0CNHIN",171,0) N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE "RTN","C0CNHIN",172,0) I $D(GD(2)) D ; "RTN","C0CNHIN",173,0) . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY "RTN","C0CNHIN",174,0) E I $D(GD(1)) D ; "RTN","C0CNHIN",175,0) . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY "RTN","C0CNHIN",176,0) . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY "RTN","C0CNHIN",177,0) N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD "RTN","C0CNHIN",178,0) I ZFRST'=0 D ; THERE IS A CHILD "RTN","C0CNHIN",179,0) . N ZNUM "RTN","C0CNHIN",180,0) . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE "RTN","C0CNHIN",181,0) . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD "RTN","C0CNHIN",182,0) N GNXT S GNXT=$$NXTSIB(ZOID) "RTN","C0CNHIN",183,0) I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES "RTN","C0CNHIN",184,0) I GNXT'=0 D ; "RTN","C0CNHIN",185,0) . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? "RTN","C0CNHIN",186,0) . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES "RTN","C0CNHIN",187,0) . . N ZNUM S ZNUM=1 ; "RTN","C0CNHIN",188,0) . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB "RTN","C0CNHIN",189,0) . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB "RTN","C0CNHIN",190,0) Q "RTN","C0CNHIN",191,0) ; "RTN","C0CNHIN",192,0) ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY "RTN","C0CNHIN",193,0) ; "RTN","C0CNHIN",194,0) N ZZI,ZZJ,ZZN "RTN","C0CNHIN",195,0) S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY "RTN","C0CNHIN",196,0) I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE "RTN","C0CNHIN",197,0) S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY "RTN","C0CNHIN",198,0) S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . "RTN","C0CNHIN",199,0) I ZZI'["]" D ; A SINGLETON "RTN","C0CNHIN",200,0) . S ZZN=1 "RTN","C0CNHIN",201,0) E D ; THERE IS AN [x] OCCURANCE "RTN","C0CNHIN",202,0) . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE "RTN","C0CNHIN",203,0) . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] "RTN","C0CNHIN",204,0) I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE "RTN","C0CNHIN",205,0) Q "RTN","C0CNHIN",206,0) ; "RTN","C0CNHIN",207,0) PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME "RTN","C0CNHIN",208,0) ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW "RTN","C0CNHIN",209,0) ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML "RTN","C0CNHIN",210,0) ;Q $$EN^MXMLDOM(INXML) "RTN","C0CNHIN",211,0) Q $$EN^MXMLDOM(INXML,"W") "RTN","C0CNHIN",212,0) ; "RTN","C0CNHIN",213,0) ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE "RTN","C0CNHIN",214,0) N ZN "RTN","C0CNHIN",215,0) ;I $$TAG(ZOID)["entry" B "RTN","C0CNHIN",216,0) S ZN=$$NXTSIB(ZOID) "RTN","C0CNHIN",217,0) I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG "RTN","C0CNHIN",218,0) Q 0 "RTN","C0CNHIN",219,0) ; "RTN","C0CNHIN",220,0) FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID "RTN","C0CNHIN",221,0) Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CNHIN",222,0) ; "RTN","C0CNHIN",223,0) PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID "RTN","C0CNHIN",224,0) Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CNHIN",225,0) ; "RTN","C0CNHIN",226,0) ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID "RTN","C0CNHIN",227,0) S HANDLE=C0CDOCID "RTN","C0CNHIN",228,0) K @RTN "RTN","C0CNHIN",229,0) D GETTXT^MXMLDOM("A") "RTN","C0CNHIN",230,0) Q "RTN","C0CNHIN",231,0) ; "RTN","C0CNHIN",232,0) TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE "RTN","C0CNHIN",233,0) ;I ZOID=149 B ;GPLTEST "RTN","C0CNHIN",234,0) N X,Y "RTN","C0CNHIN",235,0) S Y="" "RTN","C0CNHIN",236,0) S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE "RTN","C0CNHIN",237,0) I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y "RTN","C0CNHIN",238,0) I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CNHIN",239,0) Q Y "RTN","C0CNHIN",240,0) ; "RTN","C0CNHIN",241,0) NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING "RTN","C0CNHIN",242,0) Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) "RTN","C0CNHIN",243,0) ; "RTN","C0CNHIN",244,0) DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE "RTN","C0CNHIN",245,0) ;N ZT,ZN S ZT="" "RTN","C0CNHIN",246,0) ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) "RTN","C0CNHIN",247,0) ;Q $G(@C0CDOM@(ZOID,"T",1)) "RTN","C0CNHIN",248,0) S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) "RTN","C0CNHIN",249,0) Q "RTN","C0CNHIN",250,0) ; "RTN","C0CNHIN",251,0) OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM "RTN","C0CNHIN",252,0) ; "RTN","C0CNHIN",253,0) S C0CDOCID=INID "RTN","C0CNHIN",254,0) D START^C0CMXMLB($$TAG(1),,"G") "RTN","C0CNHIN",255,0) D NDOUT($$FIRST(1)) "RTN","C0CNHIN",256,0) D END^C0CMXMLB ;END THE DOCUMENT "RTN","C0CNHIN",257,0) M @ZRTN=^TMP("MXMLBLD",$J) "RTN","C0CNHIN",258,0) K ^TMP("MXMLBLD",$J) "RTN","C0CNHIN",259,0) Q "RTN","C0CNHIN",260,0) ; "RTN","C0CNHIN",261,0) NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE "RTN","C0CNHIN",262,0) N ZI S ZI=$$FIRST(ZOID) "RTN","C0CNHIN",263,0) I ZI'=0 D ; THERE IS A CHILD "RTN","C0CNHIN",264,0) . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT "RTN","C0CNHIN",265,0) . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN "RTN","C0CNHIN",266,0) E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT "RTN","C0CNHIN",267,0) . ;W "DOING",ZOID,! "RTN","C0CNHIN",268,0) . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA "RTN","C0CNHIN",269,0) . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES "RTN","C0CNHIN",270,0) . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN "RTN","C0CNHIN",271,0) I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING "RTN","C0CNHIN",272,0) . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS "RTN","C0CNHIN",273,0) Q "RTN","C0CNHIN",274,0) ; "RTN","C0CNHIN",275,0) WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE "RTN","C0CNHIN",276,0) ; "RTN","C0CNHIN",277,0) N GN,GN2 "RTN","C0CNHIN",278,0) D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML "RTN","C0CNHIN",279,0) S GN2=$NA(@GN@(1)) "RTN","C0CNHIN",280,0) W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") "RTN","C0CNHIN",281,0) Q "RTN","C0CNHIN",282,0) ; "RTN","C0CNHIN",283,0) TESTNARY ; TEST MAKING A NHIN ARRAY "RTN","C0CNHIN",284,0) N ZI S ZI="" "RTN","C0CNHIN",285,0) N ZH ; DOM HANDLE "RTN","C0CNHIN",286,0) D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM "RTN","C0CNHIN",287,0) S ZH=C0CDOCID ; SET THE HANDLE "RTN","C0CNHIN",288,0) N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH)) "RTN","C0CNHIN",289,0) F S ZI=$O(@ZD@(ZI)) Q:ZI="" D ; FOR EACH NODE "RTN","C0CNHIN",290,0) . N ZATT "RTN","C0CNHIN",291,0) . D MNARY(.ZATT,ZH,ZI) "RTN","C0CNHIN",292,0) . N ZPRE,ZN "RTN","C0CNHIN",293,0) . S ZPRE=$$PRE(ZI) "RTN","C0CNHIN",294,0) . S ZN=$P(ZPRE,",",2) "RTN","C0CNHIN",295,0) . S ZPRE=$P(ZPRE,",",1) "RTN","C0CNHIN",296,0) . ;I $D(ZATT) ZWR ZATT "RTN","C0CNHIN",297,0) . N ZJ S ZJ="" "RTN","C0CNHIN",298,0) . F S ZJ=$O(ZATT(ZJ)) Q:ZJ="" D ; FOR EACH ATTRIBUTE "RTN","C0CNHIN",299,0) . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),! "RTN","C0CNHIN",300,0) . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ) "RTN","C0CNHIN",301,0) Q "RTN","C0CNHIN",302,0) ; "RTN","C0CNHIN",303,0) PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE "RTN","C0CNHIN",304,0) ; "RTN","C0CNHIN",305,0) N GI,GI2,GPT,GJ,GN "RTN","C0CNHIN",306,0) S GI=$$PARENT(ZNODE) ; PARENT NODE "RTN","C0CNHIN",307,0) I GI=0 Q "" ; NO PARENT "RTN","C0CNHIN",308,0) S GPT=$$TAG(GI) ; TAG OF PARENT "RTN","C0CNHIN",309,0) S GI2=$$PARENT(GI) ; PARENT OF PARENT "RTN","C0CNHIN",310,0) I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT "RTN","C0CNHIN",311,0) S GJ=$$FIRST(GI) ; NODE OF FIRST SIB "RTN","C0CNHIN",312,0) I GJ=ZNODE Q:$$TAG(GI)_",1" "RTN","C0CNHIN",313,0) F GN=2:1 Q:GJ=ZNODE D ; "RTN","C0CNHIN",314,0) . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING "RTN","C0CNHIN",315,0) Q GPT_","_GN "RTN","C0CNHIN",316,0) ; "RTN","C0CNHIN",317,0) MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE "RTN","C0CNHIN",318,0) ; RETURNED IN ZRTN, PASSED BY REFERENCE "RTN","C0CNHIN",319,0) ; ZHANDLE IS THE DOM DOCUMENT ID "RTN","C0CNHIN",320,0) ; ZOID IS THE DOM NODE "RTN","C0CNHIN",321,0) D ATT("ZRTN",ZOID) "RTN","C0CNHIN",322,0) Q "RTN","C0CNHIN",323,0) ; "RTN","C0CNMED2") 0^42^B33216732 "RTN","C0CNMED2",1,0) C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 "RTN","C0CNMED2",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CNMED2",3,0) ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. "RTN","C0CNMED2",4,0) ; Licensed under the terms of the GNU General Public License. "RTN","C0CNMED2",5,0) ; See attached copy of the License. "RTN","C0CNMED2",6,0) ; "RTN","C0CNMED2",7,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CNMED2",8,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CNMED2",9,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CNMED2",10,0) ; (at your option) any later version. "RTN","C0CNMED2",11,0) ; "RTN","C0CNMED2",12,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CNMED2",13,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CNMED2",14,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CNMED2",15,0) ; GNU General Public License for more details. "RTN","C0CNMED2",16,0) ; "RTN","C0CNMED2",17,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CNMED2",18,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CNMED2",19,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CNMED2",20,0) ; "RTN","C0CNMED2",21,0) ; --Revision History "RTN","C0CNMED2",22,0) ; July 2008 - Initial Version/GPL "RTN","C0CNMED2",23,0) ; July 2008 - March 2009 various revisions "RTN","C0CNMED2",24,0) ; March 2009 - Reconstruction of routine as driver for other med routines/SMH "RTN","C0CNMED2",25,0) ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl "RTN","C0CNMED2",26,0) ; "RTN","C0CNMED2",27,0) Q "RTN","C0CNMED2",28,0) ; "RTN","C0CNMED2",29,0) ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN "RTN","C0CNMED2",30,0) ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( "RTN","C0CNMED2",31,0) ; GPL "RTN","C0CNMED2",32,0) ; "RTN","C0CNMED2",33,0) EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template "RTN","C0CNMED2",34,0) ; DFN passed by reference "RTN","C0CNMED2",35,0) ; MEDXML and MEDOUTXML are passed by Name "RTN","C0CNMED2",36,0) ; MEDXML is the input template "RTN","C0CNMED2",37,0) ; MEDOUTXML is the output template "RTN","C0CNMED2",38,0) ; Both of them refer to ^TMP globals where the XML documents are stored "RTN","C0CNMED2",39,0) ; "RTN","C0CNMED2",40,0) N GN "RTN","C0CNMED2",41,0) D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS "RTN","C0CNMED2",42,0) ; this call uses GET^NHINV to retrieve xml of the meds and then "RTN","C0CNMED2",43,0) ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array "RTN","C0CNMED2",44,0) ; "RTN","C0CNMED2",45,0) ; we now create an NHIN Array of the Meds section of the CCR "RTN","C0CNMED2",46,0) ; "RTN","C0CNMED2",47,0) N ZI S ZI="" "RTN","C0CNMED2",48,0) F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med "RTN","C0CNMED2",49,0) . N GA S GA=$NA(GN("med",ZI)) "RTN","C0CNMED2",50,0) . N GM S GM="Medication" ; to keep the lines shorter "RTN","C0CNMED2",51,0) . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI "RTN","C0CNMED2",52,0) . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE "RTN","C0CNMED2",53,0) . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds "RTN","C0CNMED2",54,0) . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") "RTN","C0CNMED2",55,0) . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 "RTN","C0CNMED2",56,0) . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" "RTN","C0CNMED2",57,0) . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" "RTN","C0CNMED2",58,0) . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" "RTN","C0CNMED2",59,0) . N GSIG S GSIG=$G(@GA@("sig")) "RTN","C0CNMED2",60,0) . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | "RTN","C0CNMED2",61,0) . S GC(GM,ZI,"Description.Text")=GSIG "RTN","C0CNMED2",62,0) . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER "RTN","C0CNMED2",63,0) . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" "RTN","C0CNMED2",64,0) . ;S GC(GM,ZI,GD_".Description.Text")="" "RTN","C0CNMED2",65,0) . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" "RTN","C0CNMED2",66,0) . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" "RTN","C0CNMED2",67,0) . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" "RTN","C0CNMED2",68,0) . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" "RTN","C0CNMED2",69,0) . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" "RTN","C0CNMED2",70,0) . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" "RTN","C0CNMED2",71,0) . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" "RTN","C0CNMED2",72,0) . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" "RTN","C0CNMED2",73,0) . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" "RTN","C0CNMED2",74,0) . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" "RTN","C0CNMED2",75,0) . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" "RTN","C0CNMED2",76,0) . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" "RTN","C0CNMED2",77,0) . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" "RTN","C0CNMED2",78,0) . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" "RTN","C0CNMED2",79,0) . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" "RTN","C0CNMED2",80,0) . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" "RTN","C0CNMED2",81,0) . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" "RTN","C0CNMED2",82,0) . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" "RTN","C0CNMED2",83,0) . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" "RTN","C0CNMED2",84,0) . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" "RTN","C0CNMED2",85,0) . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) "RTN","C0CNMED2",86,0) . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" "RTN","C0CNMED2",87,0) . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" "RTN","C0CNMED2",88,0) . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" "RTN","C0CNMED2",89,0) . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" "RTN","C0CNMED2",90,0) . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" "RTN","C0CNMED2",91,0) . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" "RTN","C0CNMED2",92,0) . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" "RTN","C0CNMED2",93,0) . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) "RTN","C0CNMED2",94,0) . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) "RTN","C0CNMED2",95,0) . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) "RTN","C0CNMED2",96,0) . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) "RTN","C0CNMED2",97,0) . N GR S GR=$$RXNCUI3^C0PLKUP(GV) "RTN","C0CNMED2",98,0) . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") "RTN","C0CNMED2",99,0) . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) "RTN","C0CNMED2",100,0) . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" "RTN","C0CNMED2",101,0) . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) "RTN","C0CNMED2",102,0) . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) "RTN","C0CNMED2",103,0) . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) "RTN","C0CNMED2",104,0) . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" "RTN","C0CNMED2",105,0) . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" "RTN","C0CNMED2",106,0) . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" "RTN","C0CNMED2",107,0) . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ "RTN","C0CNMED2",108,0) . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ "RTN","C0CNMED2",109,0) . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) "RTN","C0CNMED2",110,0) . S GC(GM,ZI,"Type.Text")="Medication" "RTN","C0CNMED2",111,0) N C0CDOCID "RTN","C0CNMED2",112,0) S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom "RTN","C0CNMED2",113,0) D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml "RTN","C0CNMED2",114,0) N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) "RTN","C0CNMED2",115,0) S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML "RTN","C0CNMED2",116,0) W !,MEDOUTXML "RTN","C0CNMED2",117,0) ;ZWR GN "RTN","C0CNMED2",118,0) ;ZWR GC "RTN","C0CNMED2",119,0) ;B "RTN","C0CNMED2",120,0) Q "RTN","C0CNMED2",121,0) ; "RTN","C0CNMED4") 0^43^B92677865 "RTN","C0CNMED4",1,0) C0CMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 "RTN","C0CNMED4",2,0) ;;0.1;CCDCCR;;;Build 1 "RTN","C0CNMED4",3,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CNMED4",4,0) ; General Public License See attached copy of the License. "RTN","C0CNMED4",5,0) ; "RTN","C0CNMED4",6,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CNMED4",7,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CNMED4",8,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CNMED4",9,0) ; (at your option) any later version. "RTN","C0CNMED4",10,0) ; "RTN","C0CNMED4",11,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CNMED4",12,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CNMED4",13,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CNMED4",14,0) ; GNU General Public License for more details. "RTN","C0CNMED4",15,0) ; "RTN","C0CNMED4",16,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CNMED4",17,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CNMED4",18,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CNMED4",19,0) ; "RTN","C0CNMED4",20,0) W "NO ENTRY FROM TOP",! "RTN","C0CNMED4",21,0) Q "RTN","C0CNMED4",22,0) ; "RTN","C0CNMED4",23,0) EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","C0CNMED4",24,0) ; "RTN","C0CNMED4",25,0) ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011 "RTN","C0CNMED4",26,0) ; "RTN","C0CNMED4",27,0) ; MINXML is the Input XML Template, passed by name "RTN","C0CNMED4",28,0) ; DFN is Patient IEN "RTN","C0CNMED4",29,0) ; OUTXML is the resultant XML. "RTN","C0CNMED4",30,0) ; "RTN","C0CNMED4",31,0) ; MEDS is return array from API. "RTN","C0CNMED4",32,0) ; MED is holds each array element from MEDS, one medicine "RTN","C0CNMED4",33,0) ; MAP is a mapping variable map (store result) for each med "RTN","C0CNMED4",34,0) ; "RTN","C0CNMED4",35,0) ; Inpatient Meds will be extracted using this routine and and the one following. "RTN","C0CNMED4",36,0) ; Inpatient Meds Unit Dose is going to be C0CMED4 "RTN","C0CNMED4",37,0) ; Inpatient Meds IVs is going to be C0CMED5 "RTN","C0CNMED4",38,0) ; "RTN","C0CNMED4",39,0) ; We will use two Pharmacy ReEnginnering API's: "RTN","C0CNMED4",40,0) ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info "RTN","C0CNMED4",41,0) ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info "RTN","C0CNMED4",42,0) ; For more information, see the PRE documentation at: "RTN","C0CNMED4",43,0) ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf "RTN","C0CNMED4",44,0) ; "RTN","C0CNMED4",45,0) ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient "RTN","C0CNMED4",46,0) ; "RTN","C0CNMED4",47,0) N MEDS,MAP "RTN","C0CNMED4",48,0) ;K ^TMP($J) "RTN","C0CNMED4",49,0) ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) "RTN","C0CNMED4",50,0) ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit "RTN","C0CNMED4",51,0) ;; Otherwise, we go on... "RTN","C0CNMED4",52,0) D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds "RTN","C0CNMED4",53,0) I '$D(MEDS) Q ; no meds "RTN","C0CNMED4",54,0) N ZI S ZI="" "RTN","C0CNMED4",55,0) N ZCOUNT S ZCOUNT=0 "RTN","C0CNMED4",56,0) F S ZI=$O(MEDS("med",ZI)) Q:ZI="" D ; for each returned med "RTN","C0CNMED4",57,0) . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1 "RTN","C0CNMED4",58,0) IF ZCOUNT=0 Q ; no inpatient meds "RTN","C0CNMED4",59,0) ;M MEDS=^TMP($J,"UD") "RTN","C0CNMED4",60,0) I DEBUG ZWR MEDS "RTN","C0CNMED4",61,0) S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) "RTN","C0CNMED4",62,0) ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array "RTN","C0CNMED4",63,0) N I S I=0 "RTN","C0CNMED4",64,0) F S I=$O(MEDS("med",I)) Q:'I D ; For each medication "RTN","C0CNMED4",65,0) . N MED M MED=MEDS("med",I) "RTN","C0CNMED4",66,0) . I $G(MED("vaType@value"))'="I" Q ; not inpatient "RTN","C0CNMED4",67,0) . S MEDCOUNT=MEDCOUNT+1 "RTN","C0CNMED4",68,0) . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter "RTN","C0CNMED4",69,0) . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) "RTN","C0CNMED4",70,0) . ;N RXIEN S RXIEN=MED(.01) ; Order Number "RTN","C0CNMED4",71,0) . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med "RTN","C0CNMED4",72,0) . I DEBUG W "RXIEN IS ",RXIEN,! "RTN","C0CNMED4",73,0) . I DEBUG W "MAP= ",MAP,! "RTN","C0CNMED4",74,0) . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN "RTN","C0CNMED4",75,0) . S @MAP@("MEDISSUEDATETXT")="Order Date" "RTN","C0CNMED4",76,0) . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") "RTN","C0CNMED4",77,0) . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT") "RTN","C0CNMED4",78,0) . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient "RTN","C0CNMED4",79,0) . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient "RTN","C0CNMED4",80,0) . S @MAP@("MEDRXNOTXT")="" ; For Outpatient "RTN","C0CNMED4",81,0) . S @MAP@("MEDRXNO")="" ; For Outpatient "RTN","C0CNMED4",82,0) . S @MAP@("MEDTYPETEXT")="Medication" "RTN","C0CNMED4",83,0) . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses "RTN","C0CNMED4",84,0) . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" "RTN","C0CNMED4",85,0) . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status "RTN","C0CNMED4",86,0) . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" "RTN","C0CNMED4",87,0) . I C0CMST="ACTIVE" S C0CMST="Active" ; "RTN","C0CNMED4",88,0) . S @MAP@("MEDSTATUSTEXT")=C0CMST "RTN","C0CNMED4",89,0) . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) "RTN","C0CNMED4",90,0) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) "RTN","C0CNMED4",91,0) . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) "RTN","C0CNMED4",92,0) . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value")) "RTN","C0CNMED4",93,0) . ; NDC is field 31 in the drug file. "RTN","C0CNMED4",94,0) . ; The actual drug entry in the drug file is not necessarily supplied. "RTN","C0CNMED4",95,0) . ; It' node 1, internal form. "RTN","C0CNMED4",96,0) . ;N MEDIEN S MEDIEN=MED(1,"I") "RTN","C0CNMED4",97,0) . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") "RTN","C0CNMED4",98,0) . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID "RTN","C0CNMED4",99,0) . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION "RTN","C0CNMED4",100,0) . D ; "RTN","C0CNMED4",101,0) . . S ZC=$$CODE^C0CUTIL(ZVUID) "RTN","C0CNMED4",102,0) . . S ZCD=$P(ZC,"^",1) ; CODE TO USE "RTN","C0CNMED4",103,0) . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID "RTN","C0CNMED4",104,0) . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION "RTN","C0CNMED4",105,0) . ;N ZRXNORM S ZRXNORM="" "RTN","C0CNMED4",106,0) . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID) "RTN","C0CNMED4",107,0) . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD "RTN","C0CNMED4",108,0) . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") "RTN","C0CNMED4",109,0) . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS "RTN","C0CNMED4",110,0) . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") "RTN","C0CNMED4",111,0) . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV "RTN","C0CNMED4",112,0) . S @MAP@("MEDBRANDNAMETEXT")="" "RTN","C0CNMED4",113,0) . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD "RTN","C0CNMED4",114,0) . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") "RTN","C0CNMED4",115,0) . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) "RTN","C0CNMED4",116,0) . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") "RTN","C0CNMED4",117,0) . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) "RTN","C0CNMED4",118,0) . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") "RTN","C0CNMED4",119,0) . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) "RTN","C0CNMED4",120,0) . ; Units, concentration, etc, come from another call "RTN","C0CNMED4",121,0) . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit "RTN","C0CNMED4",122,0) . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters "RTN","C0CNMED4",123,0) . ; NDF Entry IEN, and VA Product Name "RTN","C0CNMED4",124,0) . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") "RTN","C0CNMED4",125,0) . ; Documented in the same manual. "RTN","C0CNMED4",126,0) . ;N NDFDATA,CONCDATA "RTN","C0CNMED4",127,0) . ;I $L(MEDIEN) D "RTN","C0CNMED4",128,0) . ;. D NDF^PSS50(MEDIEN,,,,,"CONC") "RTN","C0CNMED4",129,0) . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN) "RTN","C0CNMED4",130,0) . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U) "RTN","C0CNMED4",131,0) . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U) "RTN","C0CNMED4",132,0) . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" "RTN","C0CNMED4",133,0) . ;. ; and this will crash the call. So... "RTN","C0CNMED4",134,0) . ;. I NDFIEN="" S CONCDATA="" "RTN","C0CNMED4",135,0) . ;. E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) "RTN","C0CNMED4",136,0) . ;E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. "RTN","C0CNMED4",137,0) . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") "RTN","C0CNMED4",138,0) . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) "RTN","C0CNMED4",139,0) . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") "RTN","C0CNMED4",140,0) . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) "RTN","C0CNMED4",141,0) . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") "RTN","C0CNMED4",142,0) . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) "RTN","C0CNMED4",143,0) . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. "RTN","C0CNMED4",144,0) . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; "RTN","C0CNMED4",145,0) . ; Oddly, there is no easy place to find the dispense unit. "RTN","C0CNMED4",146,0) . ; It's not included in the original call, so we have to go to the drug file. "RTN","C0CNMED4",147,0) . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") "RTN","C0CNMED4",148,0) . ; Node 14.5 is the Dispense Unit "RTN","C0CNMED4",149,0) . ;I $L(MEDIEN) D "RTN","C0CNMED4",150,0) . ;. D DATA^PSS50(MEDIEN,,,,,"QTY") "RTN","C0CNMED4",151,0) . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) "RTN","C0CNMED4",152,0) . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) "RTN","C0CNMED4",153,0) . ;E S @MAP@("MEDQUANTITYUNIT")="" "RTN","C0CNMED4",154,0) . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose")) "RTN","C0CNMED4",155,0) . ; "RTN","C0CNMED4",156,0) . ; --- START OF DIRECTIONS --- "RTN","C0CNMED4",157,0) . ; Dosage is field 2, route is 3, schedule is 4 "RTN","C0CNMED4",158,0) . ; These are all free text fields, and don't point to any files "RTN","C0CNMED4",159,0) . ; For that reason, I will use the field I never used before: "RTN","C0CNMED4",160,0) . ; MEDDIRECTIONDESCRIPTIONTEXT "RTN","C0CNMED4",161,0) . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") "RTN","C0CNMED4",162,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig")) "RTN","C0CNMED4",163,0) . ; $G(MED("products.product.vaProduct@name")) "RTN","C0CNMED4",164,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. "RTN","C0CNMED4",165,0) . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" "RTN","C0CNMED4",166,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" "RTN","C0CNMED4",167,0) . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" "RTN","C0CNMED4",168,0) . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" "RTN","C0CNMED4",169,0) . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" "RTN","C0CNMED4",170,0) . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" "RTN","C0CNMED4",171,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" "RTN","C0CNMED4",172,0) . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" "RTN","C0CNMED4",173,0) . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" "RTN","C0CNMED4",174,0) . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" "RTN","C0CNMED4",175,0) . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" "RTN","C0CNMED4",176,0) . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" "RTN","C0CNMED4",177,0) . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" "RTN","C0CNMED4",178,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" "RTN","C0CNMED4",179,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" "RTN","C0CNMED4",180,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" "RTN","C0CNMED4",181,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" "RTN","C0CNMED4",182,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" "RTN","C0CNMED4",183,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" "RTN","C0CNMED4",184,0) . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" "RTN","C0CNMED4",185,0) . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" "RTN","C0CNMED4",186,0) . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" "RTN","C0CNMED4",187,0) . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" "RTN","C0CNMED4",188,0) . ; "RTN","C0CNMED4",189,0) . ; --- END OF DIRECTIONS --- "RTN","C0CNMED4",190,0) . ; "RTN","C0CNMED4",191,0) . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" "RTN","C0CNMED4",192,0) . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field "RTN","C0CNMED4",193,0) . S @MAP@("MEDPTINSTRUCTIONS")="" "RTN","C0CNMED4",194,0) . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field "RTN","C0CNMED4",195,0) . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" "RTN","C0CNMED4",196,0) . S @MAP@("MEDRFNO")="" "RTN","C0CNMED4",197,0) . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) "RTN","C0CNMED4",198,0) . K @RESULT "RTN","C0CNMED4",199,0) . D MAP^C0CXPATH(MINXML,MAP,RESULT) "RTN","C0CNMED4",200,0) . ; D PARY^C0CXPATH(RESULT) "RTN","C0CNMED4",201,0) . ; MAPPING DIRECTIONS "RTN","C0CNMED4",202,0) . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE "RTN","C0CNMED4",203,0) . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT "RTN","C0CNMED4",204,0) . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) "RTN","C0CNMED4",205,0) . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") "RTN","C0CNMED4",206,0) . ; N MDZ1,MDZNA "RTN","C0CNMED4",207,0) . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS "RTN","C0CNMED4",208,0) . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS "RTN","C0CNMED4",209,0) . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION "RTN","C0CNMED4",210,0) . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) "RTN","C0CNMED4",211,0) . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) "RTN","C0CNMED4",212,0) . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") "RTN","C0CNMED4",213,0) . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy "RTN","C0CNMED4",214,0) . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CNMED4",215,0) N MEDTMP,MEDI "RTN","C0CNMED4",216,0) D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CNMED4",217,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CNMED4",218,0) . W "MEDICATION MISSING ",! "RTN","C0CNMED4",219,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","C0CNMED4",220,0) Q "RTN","C0CNMED4",221,0) ; "RTN","C0CORSLT") 0^44^B9647157 "RTN","C0CORSLT",1,0) C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 "RTN","C0CORSLT",2,0) ;;1.0;C0C;;Jan 21, 2010;Build 1 "RTN","C0CORSLT",3,0) ;Copyright 2011 George Lilly. "RTN","C0CORSLT",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CORSLT",5,0) ;See attached copy of the License. "RTN","C0CORSLT",6,0) ; "RTN","C0CORSLT",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CORSLT",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CORSLT",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CORSLT",10,0) ;(at your option) any later version. "RTN","C0CORSLT",11,0) ; "RTN","C0CORSLT",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CORSLT",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CORSLT",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CORSLT",15,0) ;GNU General Public License for more details. "RTN","C0CORSLT",16,0) ; "RTN","C0CORSLT",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CORSLT",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CORSLT",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CORSLT",20,0) ; "RTN","C0CORSLT",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CORSLT",22,0) Q "RTN","C0CORSLT",23,0) ; "RTN","C0CORSLT",24,0) EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS "RTN","C0CORSLT",25,0) ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE "RTN","C0CORSLT",26,0) ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS "RTN","C0CORSLT",27,0) ; THIS IS CREATED FOR MU CERTIFICATION BY GPL "RTN","C0CORSLT",28,0) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE "RTN","C0CORSLT",29,0) N ZN ; RESULT NUMBER "RTN","C0CORSLT",30,0) S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT "RTN","C0CORSLT",31,0) N ZI S ZI="" "RTN","C0CORSLT",32,0) F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT "RTN","C0CORSLT",33,0) . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG "RTN","C0CORSLT",34,0) . . S ZN=ZN+1 ; INCREMENT RESULT COUNT "RTN","C0CORSLT",35,0) . . N ZDATE,ZPRV,ZTXT "RTN","C0CORSLT",36,0) . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE "RTN","C0CORSLT",37,0) . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER "RTN","C0CORSLT",38,0) . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) "RTN","C0CORSLT",39,0) . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") "RTN","C0CORSLT",40,0) . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" "RTN","C0CORSLT",41,0) . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" "RTN","C0CORSLT",42,0) . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" "RTN","C0CORSLT",43,0) . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN "RTN","C0CORSLT",44,0) . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV "RTN","C0CORSLT",45,0) . . S @ZVARS@(ZN,"RESULTSTATUS")="" "RTN","C0CORSLT",46,0) . . S @ZVARS@(ZN,"M","TEST",0)=1 "RTN","C0CORSLT",47,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" "RTN","C0CORSLT",48,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" "RTN","C0CORSLT",49,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") "RTN","C0CORSLT",50,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" "RTN","C0CORSLT",51,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" "RTN","C0CORSLT",52,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" "RTN","C0CORSLT",53,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" "RTN","C0CORSLT",54,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN "RTN","C0CORSLT",55,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV "RTN","C0CORSLT",56,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" "RTN","C0CORSLT",57,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" "RTN","C0CORSLT",58,0) . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT "RTN","C0CORSLT",59,0) . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT "RTN","C0CORSLT",60,0) Q "RTN","C0CORSLT",61,0) ; "RTN","C0CORSLT",62,0) OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG "RTN","C0CORSLT",63,0) ; FOR CERTIFICATION - SAVE EKG RESULTS gpl "RTN","C0CORSLT",64,0) W !,"CPT=",ZCPT "RTN","C0CORSLT",65,0) I ZCPT["93000" D ; THIS IS AN EKG "RTN","C0CORSLT",66,0) . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS "RTN","C0CORSLT",67,0) . M ^GPL("RNF2")=@C0CPRSLT "RTN","C0CORSLT",68,0) Q "RTN","C0CORSLT",69,0) ; "RTN","C0CPARMS") 0^45^B7504183 "RTN","C0CPARMS",1,0) C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 "RTN","C0CPARMS",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CPARMS",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CPARMS",4,0) ;General Public License See attached copy of the License. "RTN","C0CPARMS",5,0) ; "RTN","C0CPARMS",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CPARMS",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CPARMS",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CPARMS",9,0) ;(at your option) any later version. "RTN","C0CPARMS",10,0) ; "RTN","C0CPARMS",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CPARMS",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CPARMS",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CPARMS",14,0) ;GNU General Public License for more details. "RTN","C0CPARMS",15,0) ; "RTN","C0CPARMS",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CPARMS",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CPARMS",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CPARMS",19,0) ; "RTN","C0CPARMS",20,0) SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS "RTN","C0CPARMS",21,0) ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC" "RTN","C0CPARMS",22,0) ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS "RTN","C0CPARMS",23,0) ; "RTN","C0CPARMS",24,0) N PTMP ; "RTN","C0CPARMS",25,0) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN "RTN","C0CPARMS",26,0) K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL "RTN","C0CPARMS",27,0) I $G(INPARMS)'="" D ; OVERRIDES PROVIDED "RTN","C0CPARMS",28,0) . N C0CI S C0CI="" "RTN","C0CPARMS",29,0) . N C0CN S C0CN=1 "RTN","C0CPARMS",30,0) . F S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI="" D ; "RTN","C0CPARMS",31,0) . . S C0CN=C0CN+1 ;NEXT PARM "RTN","C0CPARMS",32,0) . . N C1,C2 "RTN","C0CPARMS",33,0) . . S C1=$P(C0CI,":",1) ; PARAMETER "RTN","C0CPARMS",34,0) . . S C2=$P(C0CI,":",2) ; VALUE "RTN","C0CPARMS",35,0) . . I C2="" S C2=1 "RTN","C0CPARMS",36,0) . . S @C0CPARMS@(C1)=C2 "RTN","C0CPARMS",37,0) . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE "RTN","C0CPARMS",38,0) ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS "RTN","C0CPARMS",39,0) ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS "RTN","C0CPARMS",40,0) ;OHUM/RUT commented the hardcoded limits "RTN","C0CPARMS",41,0) ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH "RTN","C0CPARMS",42,0) ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY "RTN","C0CPARMS",43,0) ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS "RTN","C0CPARMS",44,0) ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY "RTN","C0CPARMS",45,0) ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY "RTN","C0CPARMS",46,0) ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS "RTN","C0CPARMS",47,0) ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES "RTN","C0CPARMS",48,0) ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO "RTN","C0CPARMS",49,0) ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE "RTN","C0CPARMS",50,0) S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT") "RTN","C0CPARMS",51,0) I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY "RTN","C0CPARMS",52,0) I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY "RTN","C0CPARMS",53,0) I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY "RTN","C0CPARMS",54,0) I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES "RTN","C0CPARMS",55,0) I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO "RTN","C0CPARMS",56,0) I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE "RTN","C0CPARMS",57,0) ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH "RTN","C0CPARMS",58,0) ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY "RTN","C0CPARMS",59,0) I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY "RTN","C0CPARMS",60,0) ;OHUM/RUT "RTN","C0CPARMS",61,0) Q "RTN","C0CPARMS",62,0) ; "RTN","C0CPARMS",63,0) CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET "RTN","C0CPARMS",64,0) ; "RTN","C0CPARMS",65,0) I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN "RTN","C0CPARMS",66,0) I '$D(@C0CPARMS) D SET("SETWITHCHECK:1") "RTN","C0CPARMS",67,0) Q "RTN","C0CPARMS",68,0) ; "RTN","C0CPARMS",69,0) GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP "RTN","C0CPARMS",70,0) ; "RTN","C0CPARMS",71,0) D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE "RTN","C0CPARMS",72,0) N GTMP "RTN","C0CPARMS",73,0) Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE "RTN","C0CPARMS",74,0) ; "RTN","C0CPROBS") 0^46^B53281308 "RTN","C0CPROBS",1,0) C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 "RTN","C0CPROBS",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CPROBS",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota. "RTN","C0CPROBS",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CPROBS",5,0) ;See attached copy of the License. "RTN","C0CPROBS",6,0) ; "RTN","C0CPROBS",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CPROBS",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CPROBS",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CPROBS",10,0) ;(at your option) any later version. "RTN","C0CPROBS",11,0) ; "RTN","C0CPROBS",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CPROBS",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CPROBS",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CPROBS",15,0) ;GNU General Public License for more details. "RTN","C0CPROBS",16,0) ; "RTN","C0CPROBS",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CPROBS",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CPROBS",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CPROBS",20,0) ; "RTN","C0CPROBS",21,0) ; "RTN","C0CPROBS",22,0) ; PROCESS THE PROBLEMS SECTION OF THE CCR "RTN","C0CPROBS",23,0) ; "RTN","C0CPROBS",24,0) EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE "RTN","C0CPROBS",25,0) ; "RTN","C0CPROBS",26,0) ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CPROBS",27,0) ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE "RTN","C0CPROBS",28,0) ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE "RTN","C0CPROBS",29,0) ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS "RTN","C0CPROBS",30,0) ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT "RTN","C0CPROBS",31,0) ; "RTN","C0CPROBS",32,0) N RPCRSLT,J,K,PTMP,X,VMAP,TBU "RTN","C0CPROBS",33,0) S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS")) "RTN","C0CPROBS",34,0) S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP")) "RTN","C0CPROBS",35,0) K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES "RTN","C0CPROBS",36,0) I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS) "RTN","C0CPROBS",37,0) I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT "RTN","C0CPROBS",38,0) Q "RTN","C0CPROBS",39,0) ; "RTN","C0CPROBS",40,0) RPMS ; GETS THE PROBLEM LIST FOR RPMS "RTN","C0CPROBS",41,0) S RPCGLO=$NA(^TMP("BGO",$J)) "RTN","C0CPROBS",42,0) D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC "RTN","C0CPROBS",43,0) ; FORMAT OF RPC: "RTN","C0CPROBS",44,0) ; Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^ "RTN","C0CPROBS",45,0) ; Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^ "RTN","C0CPROBS",46,0) ; ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16] "RTN","C0CPROBS",47,0) I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q "RTN","C0CPROBS",48,0) S J="" "RTN","C0CPROBS",49,0) F S J=$O(@RPCGLO@(J)) Q:J="" D ; FOR EACH PROBLEM IN THE LIST "RTN","C0CPROBS",50,0) . S VMAP=$NA(@TVMAP@(J)) "RTN","C0CPROBS",51,0) . K @VMAP "RTN","C0CPROBS",52,0) . I DEBUG W "VMAP= ",VMAP,! "RTN","C0CPROBS",53,0) . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY "RTN","C0CPROBS",54,0) . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL "RTN","C0CPROBS",55,0) . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME "RTN","C0CPROBS",56,0) . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM "RTN","C0CPROBS",57,0) . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10) "RTN","C0CPROBS",58,0) . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"") "RTN","C0CPROBS",59,0) . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6) "RTN","C0CPROBS",60,0) . S @VMAP@("PROBLEMCODINGVERSION")="" "RTN","C0CPROBS",61,0) . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3) "RTN","C0CPROBS",62,0) . ; FOR CERTIFICATION - GPL "RTN","C0CPROBS",63,0) . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493 "RTN","C0CPROBS",64,0) . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") "RTN","C0CPROBS",65,0) . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") "RTN","C0CPROBS",66,0) . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",67,0) . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",68,0) . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",69,0) . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",70,0) . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",71,0) . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",72,0) . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER "RTN","C0CPROBS",73,0) . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1") "RTN","C0CPROBS",74,0) . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",75,0) . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",76,0) . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",77,0) . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0 "RTN","C0CPROBS",78,0) . S ARYTMP=$NA(@TARYTMP@(J)) "RTN","C0CPROBS",79,0) . ; W "ARYTMP= ",ARYTMP,! "RTN","C0CPROBS",80,0) . K @ARYTMP "RTN","C0CPROBS",81,0) . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; "RTN","C0CPROBS",82,0) . I J=1 D ; FIRST ONE IS JUST A COPY "RTN","C0CPROBS",83,0) . . ; W "FIRST ONE",! "RTN","C0CPROBS",84,0) . . D CP^C0CXPATH(ARYTMP,OUTXML) "RTN","C0CPROBS",85,0) . . ; W "OUTXML ",OUTXML,! "RTN","C0CPROBS",86,0) . I J>1 D ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CPROBS",87,0) . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) "RTN","C0CPROBS",88,0) ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) "RTN","C0CPROBS",89,0) ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS "RTN","C0CPROBS",90,0) ; ZWR @OUTXML "RTN","C0CPROBS",91,0) ; $$HTML^DILF( "RTN","C0CPROBS",92,0) ; GENERATE THE NARITIVE HTML FOR THE CCD "RTN","C0CPROBS",93,0) I CCD D CCD ; IF THIS IS FOR A CCD "RTN","C0CPROBS",94,0) D MISSINGVARS "RTN","C0CPROBS",95,0) Q "RTN","C0CPROBS",96,0) ; "RTN","C0CPROBS",97,0) VISTA ; GETS THE PROBLEM LIST FOR VISTA "RTN","C0CPROBS",98,0) D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC "RTN","C0CPROBS",99,0) I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL "RTN","C0CPROBS",100,0) . W "NULL RESULT FROM LIST^ORQQPL3 ",! "RTN","C0CPROBS",101,0) . S @OUTXML@(0)=0 "RTN","C0CPROBS",102,0) . ; Q "RTN","C0CPROBS",103,0) ; I DEBUG ZWR RPCRSLT "RTN","C0CPROBS",104,0) S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS "RTN","C0CPROBS",105,0) F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST "RTN","C0CPROBS",106,0) . S VMAP=$NA(@TVMAP@(J)) "RTN","C0CPROBS",107,0) . K @VMAP "RTN","C0CPROBS",108,0) . I DEBUG W "VMAP= ",VMAP,! "RTN","C0CPROBS",109,0) . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY "RTN","C0CPROBS",110,0) . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM "RTN","C0CPROBS",111,0) . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) "RTN","C0CPROBS",112,0) . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") "RTN","C0CPROBS",113,0) . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG "RTN","C0CPROBS",114,0) . ; turn off acute/chronic for certification gpl "RTN","C0CPROBS",115,0) . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status "RTN","C0CPROBS",116,0) . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) "RTN","C0CPROBS",117,0) . S @VMAP@("PROBLEMCODINGVERSION")="" "RTN","C0CPROBS",118,0) . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) "RTN","C0CPROBS",119,0) . ; FOR CERTIFICATION - GPL "RTN","C0CPROBS",120,0) . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493 "RTN","C0CPROBS",121,0) . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") "RTN","C0CPROBS",122,0) . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") "RTN","C0CPROBS",123,0) . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) "RTN","C0CPROBS",124,0) . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) "RTN","C0CPROBS",125,0) . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) "RTN","C0CPROBS",126,0) . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) "RTN","C0CPROBS",127,0) . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) "RTN","C0CPROBS",128,0) . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) "RTN","C0CPROBS",129,0) . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER "RTN","C0CPROBS",130,0) . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) "RTN","C0CPROBS",131,0) . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) "RTN","C0CPROBS",132,0) . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) "RTN","C0CPROBS",133,0) . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") "RTN","C0CPROBS",134,0) . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") "RTN","C0CPROBS",135,0) . S ARYTMP=$NA(@TARYTMP@(J)) "RTN","C0CPROBS",136,0) . ; W "ARYTMP= ",ARYTMP,! "RTN","C0CPROBS",137,0) . K @ARYTMP "RTN","C0CPROBS",138,0) . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; "RTN","C0CPROBS",139,0) . I J=1 D ; FIRST ONE IS JUST A COPY "RTN","C0CPROBS",140,0) . . ; W "FIRST ONE",! "RTN","C0CPROBS",141,0) . . D CP^C0CXPATH(ARYTMP,OUTXML) "RTN","C0CPROBS",142,0) . . ; W "OUTXML ",OUTXML,! "RTN","C0CPROBS",143,0) . I J>1 D ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CPROBS",144,0) . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) "RTN","C0CPROBS",145,0) ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) "RTN","C0CPROBS",146,0) ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS "RTN","C0CPROBS",147,0) ; ZWR @OUTXML "RTN","C0CPROBS",148,0) ; $$HTML^DILF( "RTN","C0CPROBS",149,0) ; GENERATE THE NARITIVE HTML FOR THE CCD "RTN","C0CPROBS",150,0) I CCD D CCD ; IF THIS IS FOR A CCD "RTN","C0CPROBS",151,0) D MISSINGVARS "RTN","C0CPROBS",152,0) Q "RTN","C0CPROBS",153,0) CCD "RTN","C0CPROBS",154,0) N HTMP,HOUT,HTMLO,C0CPROBI,ZX "RTN","C0CPROBS",155,0) F C0CPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM "RTN","C0CPROBS",156,0) . S VMAP=$NA(@TVMAP@(C0CPROBI)) "RTN","C0CPROBS",157,0) . I DEBUG W "VMAP =",VMAP,! "RTN","C0CPROBS",158,0) . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE "RTN","C0CPROBS",159,0) . D UNMARK^C0CXPATH("HTMP") ; REMOVE MARKUP "RTN","C0CPROBS",160,0) . ; D PARY^C0CXPATH("HTMP") ; PRINT IT "RTN","C0CPROBS",161,0) . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES "RTN","C0CPROBS",162,0) . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN "RTN","C0CPROBS",163,0) . I C0CPROBI=1 D ; FIRST ONE IS JUST A COPY "RTN","C0CPROBS",164,0) . . D CP^C0CXPATH("HOUT","HTMLO") "RTN","C0CPROBS",165,0) . I C0CPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML "RTN","C0CPROBS",166,0) . . I DEBUG W "DOING INNER",! "RTN","C0CPROBS",167,0) . . N HTMLBLD,HTMLTMP "RTN","C0CPROBS",168,0) . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) "RTN","C0CPROBS",169,0) . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) "RTN","C0CPROBS",170,0) . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) "RTN","C0CPROBS",171,0) . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP") "RTN","C0CPROBS",172,0) . . D CP^C0CXPATH("HTMLTMP","HTMLO") "RTN","C0CPROBS",173,0) . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//") "RTN","C0CPROBS",174,0) I DEBUG D PARY^C0CXPATH("HTMLO") "RTN","C0CPROBS",175,0) D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION "RTN","C0CPROBS",176,0) Q "RTN","C0CPROBS",177,0) MISSINGVARS "RTN","C0CPROBS",178,0) N PROBSTMP,I "RTN","C0CPROBS",179,0) D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CPROBS",180,0) I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - "RTN","C0CPROBS",181,0) . ; STRINGS MARKED AS @@X@@ "RTN","C0CPROBS",182,0) . W !,"PROBLEMS Missing list: ",! "RTN","C0CPROBS",183,0) . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! "RTN","C0CPROBS",184,0) Q "RTN","C0CPROBS",185,0) ; "RTN","C0CPROC") 0^47^B27869918 "RTN","C0CPROC",1,0) C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 "RTN","C0CPROC",2,0) ;;1.0;C0C;;Jan 21, 2010;Build 1 "RTN","C0CPROC",3,0) ;Copyright 2010 George Lilly, University of Minnesota and others. "RTN","C0CPROC",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CPROC",5,0) ;See attached copy of the License. "RTN","C0CPROC",6,0) ; "RTN","C0CPROC",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CPROC",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CPROC",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CPROC",10,0) ;(at your option) any later version. "RTN","C0CPROC",11,0) ; "RTN","C0CPROC",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CPROC",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CPROC",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CPROC",15,0) ;GNU General Public License for more details. "RTN","C0CPROC",16,0) ; "RTN","C0CPROC",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CPROC",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CPROC",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CPROC",20,0) ; "RTN","C0CPROC",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CPROC",22,0) Q "RTN","C0CPROC",23,0) ; "RTN","C0CPROC",24,0) SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES "RTN","C0CPROC",25,0) S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN)) "RTN","C0CPROC",26,0) S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) "RTN","C0CPROC",27,0) S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) "RTN","C0CPROC",28,0) ; ADDITION FOR CERTIFICATION "RTN","C0CPROC",29,0) S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) "RTN","C0CPROC",30,0) Q "RTN","C0CPROC",31,0) ; "RTN","C0CPROC",32,0) EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE "RTN","C0CPROC",33,0) ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CPROC",34,0) ; "RTN","C0CPROC",35,0) D SETVARS ; SET UP VARIABLES "RTN","C0CPROC",36,0) I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE "RTN","C0CPROC",37,0) D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES "RTN","C0CPROC",38,0) Q "RTN","C0CPROC",39,0) ; "RTN","C0CPROC",40,0) TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, "RTN","C0CPROC",41,0) ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME "RTN","C0CPROC",42,0) ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES "RTN","C0CPROC",43,0) ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT "RTN","C0CPROC",44,0) ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY "RTN","C0CPROC",45,0) ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM "RTN","C0CPROC",46,0) ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS "RTN","C0CPROC",47,0) ; "RTN","C0CPROC",48,0) K VISIT,LST,NOTE,C0CLPRC "RTN","C0CPROC",49,0) ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS "RTN","C0CPROC",50,0) ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES "RTN","C0CPROC",51,0) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE "RTN","C0CPROC",52,0) ; NEED TO ADD START AND END DATES FROM PARAMETERS "RTN","C0CPROC",53,0) N ZI S ZI="" "RTN","C0CPROC",54,0) N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" "RTN","C0CPROC",55,0) F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST "RTN","C0CPROC",56,0) . N ZDATE "RTN","C0CPROC",57,0) . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) "RTN","C0CPROC",58,0) . S ZPRVARY=$NA(VISIT(ZI,"PRV")) "RTN","C0CPROC",59,0) . N ZPRV "RTN","C0CPROC",60,0) . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM "RTN","C0CPROC",61,0) . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON "RTN","C0CPROC",62,0) . N ZJ S ZJ="" "RTN","C0CPROC",63,0) . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG "RTN","C0CPROC",64,0) . . N ZRNF "RTN","C0CPROC",65,0) . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT "RTN","C0CPROC",66,0) . . I ZCPT'="" D ;IF CPT CODE IS PRESENT "RTN","C0CPROC",67,0) . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED "RTN","C0CPROC",68,0) . . . W !,ZCPT," ",ZDATE," ",ZPRV "RTN","C0CPROC",69,0) . . . S ZRNF("PROCACTOROBJID")=ZPRV "RTN","C0CPROC",70,0) . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) "RTN","C0CPROC",71,0) . . . S ZRNF("PROCCODE")=PROCCODE "RTN","C0CPROC",72,0) . . . S ZRNF("PROCCODESYS")="CPT-4" "RTN","C0CPROC",73,0) . . . S ZRNF("PROCDATETEXT")="Procedure Date" "RTN","C0CPROC",74,0) . . . S ZRNF("PROCDATETIME")=ZDATE "RTN","C0CPROC",75,0) . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET "RTN","C0CPROC",76,0) . . . S ZRNF("PROCDESCOBJATTR")="" "RTN","C0CPROC",77,0) . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES "RTN","C0CPROC",78,0) . . . S ZRNF("PROCDESCOBJATTRVAL")="" "RTN","C0CPROC",79,0) . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) "RTN","C0CPROC",80,0) . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET "RTN","C0CPROC",81,0) . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET "RTN","C0CPROC",82,0) . . . ; additions for Certification - need to have EKG in Results "RTN","C0CPROC",83,0) . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT "RTN","C0CPROC",84,0) . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ "RTN","C0CPROC",85,0) . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS "RTN","C0CPROC",86,0) . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? "RTN","C0CPROC",87,0) . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE "RTN","C0CPROC",88,0) . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY "RTN","C0CPROC",89,0) . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl "RTN","C0CPROC",90,0) . . . W !,"CPT=",ZCPT "RTN","C0CPROC",91,0) . . . I ZCPT["93000" D ; THIS IS AN EKG "RTN","C0CPROC",92,0) . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS "RTN","C0CPROC",93,0) . . . . M ^GPL("RNF2")=@C0CPRSLT "RTN","C0CPROC",94,0) . . . S PREVCPT=ZCPT "RTN","C0CPROC",95,0) . . . S PREVDT=ZDATE "RTN","C0CPROC",96,0) N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) "RTN","C0CPROC",97,0) M @ZRIM=@C0CPRC@("V") "RTN","C0CPROC",98,0) Q "RTN","C0CPROC",99,0) ; "RTN","C0CPROC",100,0) PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME "RTN","C0CPROC",101,0) N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" "RTN","C0CPROC",102,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG "RTN","C0CPROC",103,0) . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER "RTN","C0CPROC",104,0) . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) "RTN","C0CPROC",105,0) I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR "RTN","C0CPROC",106,0) Q ZRTN "RTN","C0CPROC",107,0) ; "RTN","C0CPROC",108,0) DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT "RTN","C0CPROC",109,0) Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") "RTN","C0CPROC",110,0) ; "RTN","C0CPROC",111,0) CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS "RTN","C0CPROC",112,0) ; CPT^CATEGORY^TEXT "RTN","C0CPROC",113,0) N Z1,Z2,Z3,ZRTN "RTN","C0CPROC",114,0) S Z1=$P(ISTR,U,1) "RTN","C0CPROC",115,0) I Z1="" D ; "RTN","C0CPROC",116,0) . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) "RTN","C0CPROC",117,0) I Z1'="" D ; IF THERE IS A CPT CODE IN THERE "RTN","C0CPROC",118,0) . ;S Z1=$P(ISTR,U,1) "RTN","C0CPROC",119,0) . S Z2=$P(ISTR,U,2) "RTN","C0CPROC",120,0) . S Z3=$P(ISTR,U,3) "RTN","C0CPROC",121,0) . S ZRTN=Z1_U_Z2_U_Z3 "RTN","C0CPROC",122,0) E S ZRTN="" "RTN","C0CPROC",123,0) Q ZRTN "RTN","C0CPROC",124,0) ; "RTN","C0CPROC",125,0) MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML "RTN","C0CPROC",126,0) ; "RTN","C0CPROC",127,0) N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE "RTN","C0CPROC",128,0) K @ZTEMP "RTN","C0CPROC",129,0) N ZBLD "RTN","C0CPROC",130,0) S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA "RTN","C0CPROC",131,0) D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE "RTN","C0CPROC",132,0) N ZINNER "RTN","C0CPROC",133,0) D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC "RTN","C0CPROC",134,0) N ZTMP,ZVAR,ZI "RTN","C0CPROC",135,0) S ZI="" "RTN","C0CPROC",136,0) F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE "RTN","C0CPROC",137,0) . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML "RTN","C0CPROC",138,0) . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES "RTN","C0CPROC",139,0) . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE "RTN","C0CPROC",140,0) . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD "RTN","C0CPROC",141,0) D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) "RTN","C0CPROC",142,0) N ZZTMP "RTN","C0CPROC",143,0) D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML "RTN","C0CPROC",144,0) K @ZTEMP,@ZBLD,@C0CPRC "RTN","C0CPROC",145,0) Q "RTN","C0CPROC",146,0) ; "RTN","C0CPXRM") 0^48^B14904056 "RTN","C0CPXRM",1,0) C0CPXRM ; "RTN","C0CPXRM",2,0) ;;;;;;Build 1 "RTN","C0CPXRM",3,0) DOIT ; "RTN","C0CPXRM",4,0) S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) "RTN","C0CPXRM",5,0) S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) "RTN","C0CPXRM",6,0) S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) "RTN","C0CPXRM",7,0) S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) "RTN","C0CPXRM",8,0) S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) "RTN","C0CPXRM",9,0) S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) "RTN","C0CPXRM",10,0) S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) "RTN","C0CPXRM",11,0) S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) "RTN","C0CPXRM",12,0) S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) "RTN","C0CPXRM",13,0) S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) "RTN","C0CPXRM",14,0) S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) "RTN","C0CPXRM",15,0) S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) "RTN","C0CPXRM",16,0) S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) "RTN","C0CPXRM",17,0) S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) "RTN","C0CPXRM",18,0) S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) "RTN","C0CPXRM",19,0) S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) "RTN","C0CPXRM",20,0) S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) "RTN","C0CPXRM",21,0) S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) "RTN","C0CPXRM",22,0) S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) "RTN","C0CPXRM",23,0) S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) "RTN","C0CPXRM",24,0) S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) "RTN","C0CPXRM",25,0) S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) "RTN","C0CPXRM",26,0) S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) "RTN","C0CPXRM",27,0) S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) "RTN","C0CPXRM",28,0) S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) "RTN","C0CPXRM",29,0) S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) "RTN","C0CPXRM",30,0) S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) "RTN","C0CPXRM",31,0) S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) "RTN","C0CPXRM",32,0) S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) "RTN","C0CPXRM",33,0) S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) "RTN","C0CPXRM",34,0) S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) "RTN","C0CPXRM",35,0) S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) "RTN","C0CPXRM",36,0) S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) "RTN","C0CPXRM",37,0) S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) "RTN","C0CPXRM",38,0) S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) "RTN","C0CPXRM",39,0) S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) "RTN","C0CPXRM",40,0) S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) "RTN","C0CPXRM",41,0) S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) "RTN","C0CPXRM",42,0) S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) "RTN","C0CPXRM",43,0) S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) "RTN","C0CPXRM",44,0) S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) "RTN","C0CPXRM",45,0) S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) "RTN","C0CPXRM",46,0) S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) "RTN","C0CPXRM",47,0) S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) "RTN","C0CPXRM",48,0) S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) "RTN","C0CPXRM",49,0) S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) "RTN","C0CPXRM",50,0) S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) "RTN","C0CPXRM",51,0) S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) "RTN","C0CPXRM",52,0) S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) "RTN","C0CPXRM",53,0) S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) "RTN","C0CPXRM",54,0) S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) "RTN","C0CPXRM",55,0) S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) "RTN","C0CPXRM",56,0) S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) "RTN","C0CPXRM",57,0) S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) "RTN","C0CPXRM",58,0) S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) "RTN","C0CPXRM",59,0) S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) "RTN","C0CPXRM",60,0) S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) "RTN","C0CPXRM",61,0) S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) "RTN","C0CPXRM",62,0) S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) "RTN","C0CPXRM",63,0) S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) "RTN","C0CPXRM",64,0) S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) "RTN","C0CPXRM",65,0) S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) "RTN","C0CPXRM",66,0) S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) "RTN","C0CPXRM",67,0) S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) "RTN","C0CPXRM",68,0) S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) "RTN","C0CPXRM",69,0) S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) "RTN","C0CPXRM",70,0) S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) "RTN","C0CPXRM",71,0) S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) "RTN","C0CPXRM",72,0) S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) "RTN","C0CPXRM",73,0) Q "RTN","C0CPXRM",74,0) ; "RTN","C0CQRY1") 0^49^B18992765 "RTN","C0CQRY1",1,0) LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 "RTN","C0CQRY1",2,0) ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 1 "RTN","C0CQRY1",3,0) ; "RTN","C0CQRY1",4,0) Q "RTN","C0CQRY1",5,0) ; "RTN","C0CQRY1",6,0) CHKSC ; Check search NLT/LOINC codes "RTN","C0CQRY1",7,0) ; "RTN","C0CQRY1",8,0) N J "RTN","C0CQRY1",9,0) ; "RTN","C0CQRY1",10,0) S J=0 "RTN","C0CQRY1",11,0) F S J=$O(LA7SC(J)) Q:'J D "RTN","C0CQRY1",12,0) . N X "RTN","C0CQRY1",13,0) . S X=LA7SC(J) "RTN","C0CQRY1",14,0) . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q "RTN","C0CQRY1",15,0) . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" "RTN","C0CQRY1",16,0) . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q "RTN","C0CQRY1",17,0) . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" "RTN","C0CQRY1",18,0) . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" "RTN","C0CQRY1",19,0) . K LA7SC(J) "RTN","C0CQRY1",20,0) Q "RTN","C0CQRY1",21,0) ; "RTN","C0CQRY1",22,0) ; "RTN","C0CQRY1",23,0) SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes "RTN","C0CQRY1",24,0) ; Find all topographies that use this HL7 specimen code "RTN","C0CQRY1",25,0) N J,K,L "RTN","C0CQRY1",26,0) ; "RTN","C0CQRY1",27,0) S J=0 "RTN","C0CQRY1",28,0) F S J=$O(LA7SPEC(J)) Q:'J D "RTN","C0CQRY1",29,0) . S K=LA7SPEC(J),L=0 "RTN","C0CQRY1",30,0) . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" "RTN","C0CQRY1",31,0) Q "RTN","C0CQRY1",32,0) ; "RTN","C0CQRY1",33,0) ; "RTN","C0CQRY1",34,0) BUILDMSG ; Build HL7 message with result of query "RTN","C0CQRY1",35,0) ; "RTN","C0CQRY1",36,0) N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X "RTN","C0CQRY1",37,0) ; "RTN","C0CQRY1",38,0) I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" "RTN","C0CQRY1",39,0) S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) "RTN","C0CQRY1",40,0) S (HLQ,HL("Q"))="""""" "RTN","C0CQRY1",41,0) ; Set flag to not send HL7 message "RTN","C0CQRY1",42,0) S LA7NOMSG=1 "RTN","C0CQRY1",43,0) ; Create dummy MSH to pass HL7 delimiters "RTN","C0CQRY1",44,0) S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS "RTN","C0CQRY1",45,0) D FILESEG^LA7VHLU(GBL,.LA7MSH) "RTN","C0CQRY1",46,0) ; "RTN","C0CQRY1",47,0) F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" "RTN","C0CQRY1",48,0) ; "RTN","C0CQRY1",49,0) ; Take search results and put in HL7 message structure "RTN","C0CQRY1",50,0) S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 "RTN","C0CQRY1",51,0) ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M "RTN","C0CQRY1",52,0) F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT "RTN","C0CQRY1",53,0) . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q "RTN","C0CQRY1",54,0) . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 "RTN","C0CQRY1",55,0) . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR "RTN","C0CQRY1",56,0) . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR "RTN","C0CQRY1",57,0) . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR "RTN","C0CQRY1",58,0) . D OBX "RTN","C0CQRY1",59,0) ; "RTN","C0CQRY1",60,0) Q "RTN","C0CQRY1",61,0) ; "RTN","C0CQRY1",62,0) ; "RTN","C0CQRY1",63,0) PID ; Build PID segment "RTN","C0CQRY1",64,0) ; "RTN","C0CQRY1",65,0) N LA7PID "RTN","C0CQRY1",66,0) ; "RTN","C0CQRY1",67,0) S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) "RTN","C0CQRY1",68,0) S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) "RTN","C0CQRY1",69,0) D DEM^LRX "RTN","C0CQRY1",70,0) D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) "RTN","C0CQRY1",71,0) D FILESEG^LA7VHLU(GBL,.LA7PID) "RTN","C0CQRY1",72,0) S (LA("LRIDT"),LA("SUB"))="" "RTN","C0CQRY1",73,0) Q "RTN","C0CQRY1",74,0) ; "RTN","C0CQRY1",75,0) ; "RTN","C0CQRY1",76,0) ORC ; Build ORC segment "RTN","C0CQRY1",77,0) ; "RTN","C0CQRY1",78,0) N X "RTN","C0CQRY1",79,0) ; "RTN","C0CQRY1",80,0) S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) "RTN","C0CQRY1",81,0) S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) "RTN","C0CQRY1",82,0) S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) "RTN","C0CQRY1",83,0) S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) "RTN","C0CQRY1",84,0) I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) "RTN","C0CQRY1",85,0) S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 "RTN","C0CQRY1",86,0) D ORC^LA7VORU "RTN","C0CQRY1",87,0) S LA("NLT")="" "RTN","C0CQRY1",88,0) ; "RTN","C0CQRY1",89,0) Q "RTN","C0CQRY1",90,0) ; "RTN","C0CQRY1",91,0) ; "RTN","C0CQRY1",92,0) OBR ; Build OBR segment "RTN","C0CQRY1",93,0) ; "RTN","C0CQRY1",94,0) N LA764,LA7NLT "RTN","C0CQRY1",95,0) ; "RTN","C0CQRY1",96,0) S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" "RTN","C0CQRY1",97,0) I $L(LA7NLT) D "RTN","C0CQRY1",98,0) . S LA764=+$O(^LAM("E",LA7NLT,0)) "RTN","C0CQRY1",99,0) . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) "RTN","C0CQRY1",100,0) I LA("SUB")="CH" D "RTN","C0CQRY1",101,0) . D OBR^LA7VORU "RTN","C0CQRY1",102,0) . D NTE^LA7VORU "RTN","C0CQRY1",103,0) . S LA7OBXSN=0 "RTN","C0CQRY1",104,0) ; "RTN","C0CQRY1",105,0) Q "RTN","C0CQRY1",106,0) ; "RTN","C0CQRY1",107,0) ; "RTN","C0CQRY1",108,0) OBX ; Build OBX segment "RTN","C0CQRY1",109,0) ; "RTN","C0CQRY1",110,0) N LA7DATA,LA7VT "RTN","C0CQRY1",111,0) ; "RTN","C0CQRY1",112,0) S LA7NTESN=0 "RTN","C0CQRY1",113,0) I LA("SUB")="MI" D MI^LA7VORU1 Q "RTN","C0CQRY1",114,0) I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q "RTN","C0CQRY1",115,0) ; "RTN","C0CQRY1",116,0) S LA7VT=$QS(LA7ROOT,7) "RTN","C0CQRY1",117,0) D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) "RTN","C0CQRY1",118,0) I '$D(LA7DATA) Q "RTN","C0CQRY1",119,0) D FILESEG^LA7VHLU(GBL,.LA7DATA) "RTN","C0CQRY1",120,0) ; Send any test interpretation from file #60 "RTN","C0CQRY1",121,0) D INTRP^LA7VORUA "RTN","C0CQRY1",122,0) ; "RTN","C0CQRY1",123,0) Q "RTN","C0CQRY2") 0^50^B20465060 "RTN","C0CQRY2",1,0) LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09 "RTN","C0CQRY2",2,0) ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 1 "RTN","C0CQRY2",3,0) ; JMC - mods to check for IHS V LAB file "RTN","C0CQRY2",4,0) ; "RTN","C0CQRY2",5,0) Q "RTN","C0CQRY2",6,0) ; "RTN","C0CQRY2",7,0) PATID ; Resolve patient id and establish patient environment "RTN","C0CQRY2",8,0) ; "RTN","C0CQRY2",9,0) N LA7X "RTN","C0CQRY2",10,0) ; "RTN","C0CQRY2",11,0) S (DFN,LRDFN)="",LA7PTYP=0 "RTN","C0CQRY2",12,0) ; "RTN","C0CQRY2",13,0) ; SSN passed as patient identifier "RTN","C0CQRY2",14,0) I LA7PTID?9N.1A D "RTN","C0CQRY2",15,0) . S LA7PTYP=1 "RTN","C0CQRY2",16,0) . S LA7X=$O(^DPT("SSN",LA7PTID,0)) "RTN","C0CQRY2",17,0) . I LA7X>0 D SETDFN(LA7X) "RTN","C0CQRY2",18,0) ; "RTN","C0CQRY2",19,0) ; MPI/ICN (integration control number) passed as patient identifier "RTN","C0CQRY2",20,0) I LA7PTID?10N1"V"6N D "RTN","C0CQRY2",21,0) . S LA7PTYP=2 "RTN","C0CQRY2",22,0) . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) "RTN","C0CQRY2",23,0) . I LA7X>0 D SETDFN(LA7X) "RTN","C0CQRY2",24,0) ; "RTN","C0CQRY2",25,0) ; If no patient identified/no laboratory record - return exception message "RTN","C0CQRY2",26,0) I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" "RTN","C0CQRY2",27,0) I 'DFN S LA7ERR(2)="No patient found with requested identifier" "RTN","C0CQRY2",28,0) I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" "RTN","C0CQRY2",29,0) I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" "RTN","C0CQRY2",30,0) Q "RTN","C0CQRY2",31,0) ; "RTN","C0CQRY2",32,0) ; "RTN","C0CQRY2",33,0) BCD ; Search by specimen collection date. "RTN","C0CQRY2",34,0) ; "RTN","C0CQRY2",35,0) N LA763,LA7QUIT "RTN","C0CQRY2",36,0) ; "RTN","C0CQRY2",37,0) S (LA7SDT(0),LA7EDT(0))=0 "RTN","C0CQRY2",38,0) I LA7SDT S LA7SDT(0)=9999999-LA7SDT "RTN","C0CQRY2",39,0) I LA7EDT S LA7EDT(0)=9999999-LA7EDT "RTN","C0CQRY2",40,0) ; "RTN","C0CQRY2",41,0) F LRSS="CH","MI","SP" D "RTN","C0CQRY2",42,0) . S (LA7QUIT,LRIDT)=0 "RTN","C0CQRY2",43,0) . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) "RTN","C0CQRY2",44,0) . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D "RTN","C0CQRY2",45,0) . . ; Quit if reached end of data or outside date criteria "RTN","C0CQRY2",46,0) . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q "RTN","C0CQRY2",47,0) . . D SEARCH "RTN","C0CQRY2",48,0) ; "RTN","C0CQRY2",49,0) Q "RTN","C0CQRY2",50,0) ; "RTN","C0CQRY2",51,0) ; "RTN","C0CQRY2",52,0) BRAD ; Search by results available date (completion date). "RTN","C0CQRY2",53,0) ; Assumes cross-references still exist for dates in LRO(69) global. "RTN","C0CQRY2",54,0) ; Collects specimen date/time values for a given LRDFN and completion date. "RTN","C0CQRY2",55,0) ; Cross-reference is by date only, time stripped from start date. "RTN","C0CQRY2",56,0) ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" "RTN","C0CQRY2",57,0) ; "RTN","C0CQRY2",58,0) N LA763,LA7DT,LA7ROOT,LA7SRC,X "RTN","C0CQRY2",59,0) ; "RTN","C0CQRY2",60,0) ; Check if orders still exist Iin file #69 for search range "RTN","C0CQRY2",61,0) S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 "RTN","C0CQRY2",62,0) S X=$O(^LRO(69,LA7SDT(1))) "RTN","C0CQRY2",63,0) I X,XLA7EDT(1)) D "RTN","C0CQRY2",69,0) . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" "RTN","C0CQRY2",70,0) . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D "RTN","C0CQRY2",71,0) . . . I $QS(LA7ROOT,6)'=LRDFN Q "RTN","C0CQRY2",72,0) . . . S LRIDT=$QS(LA7ROOT,7) "RTN","C0CQRY2",73,0) . . . F LRSS="CH","MI","SP" D SEARCH "RTN","C0CQRY2",74,0) ; "RTN","C0CQRY2",75,0) ; If no orders in #69 then do long search through file #63. "RTN","C0CQRY2",76,0) I 'LA7SRC D "RTN","C0CQRY2",77,0) . F LRSS="CH","MI","SP" D "RTN","C0CQRY2",78,0) . . S LRIDT=0 "RTN","C0CQRY2",79,0) . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D "RTN","C0CQRY2",80,0) . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) "RTN","C0CQRY2",81,0) . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES "RTN","C0CRIMA",123,0) I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES "RTN","C0CRIMA",124,0) . D APOST("SATTR","RIMTBL","MEDS") "RTN","C0CRIMA",125,0) . N ZR,ZI "RTN","C0CRIMA",126,0) . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES "RTN","C0CRIMA",127,0) . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN "RTN","C0CRIMA",128,0) . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS "RTN","C0CRIMA",129,0) . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES "RTN","C0CRIMA",130,0) . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES "RTN","C0CRIMA",131,0) I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS "RTN","C0CRIMA",132,0) . D APOST("SATTR","RIMTBL","ALERTS") "RTN","C0CRIMA",133,0) . N ZR,ZI "RTN","C0CRIMA",134,0) . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES "RTN","C0CRIMA",135,0) . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN "RTN","C0CRIMA",136,0) . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS "RTN","C0CRIMA",137,0) . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES "RTN","C0CRIMA",138,0) I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES "RTN","C0CRIMA",139,0) . D APOST("SATTR","RIMTBL","RESULTS") "RTN","C0CRIMA",140,0) . N ZR,ZI "RTN","C0CRIMA",141,0) . S ZR(0)=0 ; INITIALIZE TO NONE "RTN","C0CRIMA",142,0) . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES "RTN","C0CRIMA",143,0) . ; D PARY^C0CXPATH("ZR") ; "RTN","C0CRIMA",144,0) . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN "RTN","C0CRIMA",145,0) . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS "RTN","C0CRIMA",146,0) . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK "RTN","C0CRIMA",147,0) . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; "RTN","C0CRIMA",148,0) ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED "RTN","C0CRIMA",149,0) I $D(@SBASE@("PROCEDURES",1)) D ; "RTN","C0CRIMA",150,0) . D APOST("SATTR","RIMTBL","PROCEDURES") "RTN","C0CRIMA",151,0) W "ATTRIBUTES: ",SATTR,! "RTN","C0CRIMA",152,0) Q SATTR "RTN","C0CRIMA",153,0) ; "RTN","C0CRIMA",154,0) RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES "RTN","C0CRIMA",155,0) K ^TMP("C0CRIM","RESUME") "RTN","C0CRIMA",156,0) K ^TMP("C0CRIM") "RTN","C0CRIMA",157,0) Q "RTN","C0CRIMA",158,0) ; "RTN","C0CRIMA",159,0) CLIST ; LIST THE CATEGORIES "RTN","C0CRIMA",160,0) ; "RTN","C0CRIMA",161,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CRIMA",162,0) N CLBASE,CLNUM,ZI,CLIDX "RTN","C0CRIMA",163,0) S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) "RTN","C0CRIMA",164,0) S CLNUM=@CLBASE@(0) "RTN","C0CRIMA",165,0) F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES "RTN","C0CRIMA",166,0) . S CLIDX=@CLBASE@(ZI) "RTN","C0CRIMA",167,0) . W "(",$P(@CLBASE@(CLIDX),"^",1) "RTN","C0CRIMA",168,0) . W ":",$P(@CLBASE@(CLIDX),"^",2),") " "RTN","C0CRIMA",169,0) . W CLIDX,! "RTN","C0CRIMA",170,0) ; D PARY^C0CXPATH(CLBASE) "RTN","C0CRIMA",171,0) Q "RTN","C0CRIMA",172,0) ; "RTN","C0CRIMA",173,0) CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES "RTN","C0CRIMA",174,0) ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT "RTN","C0CRIMA",175,0) ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE "RTN","C0CRIMA",176,0) ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME "RTN","C0CRIMA",177,0) ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, "RTN","C0CRIMA",178,0) ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" "RTN","C0CRIMA",179,0) ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES "RTN","C0CRIMA",180,0) ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY "RTN","C0CRIMA",181,0) ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING "RTN","C0CRIMA",182,0) ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY "RTN","C0CRIMA",183,0) ; NUMBER IE CTBL_X(CDFN)="" "RTN","C0CRIMA",184,0) ; "RTN","C0CRIMA",185,0) ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST "RTN","C0CRIMA",186,0) S CCTBL=$NA(@CBASE@(CTBL,"CATS")) "RTN","C0CRIMA",187,0) W "CBASE: ",CCTBL,! "RTN","C0CRIMA",188,0) ; "RTN","C0CRIMA",189,0) I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY "RTN","C0CRIMA",190,0) . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY "RTN","C0CRIMA",191,0) . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY "RTN","C0CRIMA",192,0) . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT "RTN","C0CRIMA",193,0) . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY "RTN","C0CRIMA",194,0) . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME "RTN","C0CRIMA",195,0) . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 "RTN","C0CRIMA",196,0) ; "RTN","C0CRIMA",197,0) S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY "RTN","C0CRIMA",198,0) S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT "RTN","C0CRIMA",199,0) S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK "RTN","C0CRIMA",200,0) ; "RTN","C0CRIMA",201,0) S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED "RTN","C0CRIMA",202,0) ; "RTN","C0CRIMA",203,0) S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT "RTN","C0CRIMA",204,0) W "PATS BASE: ",CPATLIST,! "RTN","C0CRIMA",205,0) S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST "RTN","C0CRIMA",206,0) ; "RTN","C0CRIMA",207,0) Q "RTN","C0CRIMA",208,0) ; "RTN","C0CRIMA",209,0) CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS "RTN","C0CRIMA",210,0) ; "RTN","C0CRIMA",211,0) S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE "RTN","C0CRIMA",212,0) S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE "RTN","C0CRIMA",213,0) S C0CI="" "RTN","C0CRIMA",214,0) F S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI="" D ;FOR EACH DOMAIN "RTN","C0CRIMA",215,0) . ;W "DFN:",CKDFN," DOMAIN:",C0CI,! "RTN","C0CRIMA",216,0) . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI)) "RTN","C0CRIMA",217,0) . I C0CI="HEADER" D ; HAVE TO TAKE OUT THE "DATE GENERATED" "RTN","C0CRIMA",218,0) . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME") "RTN","C0CRIMA",219,0) . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME") "RTN","C0CRIMA",220,0) . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ) "RTN","C0CRIMA",221,0) . I C0CI="HEADER" D ; PUT IT BACK "RTN","C0CRIMA",222,0) . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT "RTN","C0CRIMA",223,0) S C0CK="C0CCK" ; "RTN","C0CRIMA",224,0) S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS "RTN","C0CRIMA",225,0) S CHKR=0 ; RESULT DEFAULT "RTN","C0CRIMA",226,0) I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D ; OLD CHECKSUM EXISTS "RTN","C0CRIMA",227,0) . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1 "RTN","C0CRIMA",228,0) E S CHKR=1 ;CHECKSUM IS NEW "RTN","C0CRIMA",229,0) S @C0CCKB@(CKDFN,"ALL")=C0CALL "RTN","C0CRIMA",230,0) M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK "RTN","C0CRIMA",231,0) ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*) "RTN","C0CRIMA",232,0) Q CHKR "RTN","C0CRIMA",233,0) ; "RTN","C0CRIMA",234,0) CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE "RTN","C0CRIMA",235,0) ; "RTN","C0CRIMA",236,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CRIMA",237,0) N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT "RTN","C0CRIMA",238,0) S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES "RTN","C0CRIMA",239,0) S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS "RTN","C0CRIMA",240,0) S ZTOT=0 ; INITIALIZE OVERALL TOTAL "RTN","C0CRIMA",241,0) F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS "RTN","C0CRIMA",242,0) . S ZCNT=0 "RTN","C0CRIMA",243,0) . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY "RTN","C0CRIMA",244,0) . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME "RTN","C0CRIMA",245,0) . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST "RTN","C0CRIMA",246,0) . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS "RTN","C0CRIMA",247,0) . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT "RTN","C0CRIMA",248,0) . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! "RTN","C0CRIMA",249,0) . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) "RTN","C0CRIMA",250,0) . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) "RTN","C0CRIMA",251,0) . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD "RTN","C0CRIMA",252,0) . S ZTOT=ZTOT+ZCNT "RTN","C0CRIMA",253,0) W "TOTAL: ",ZTOT,! "RTN","C0CRIMA",254,0) Q "RTN","C0CRIMA",255,0) ; "RTN","C0CRIMA",256,0) CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST "RTN","C0CRIMA",257,0) ; INLST IS PASSED BY NAME "RTN","C0CRIMA",258,0) N ZI,ZDX,ZCOUNT "RTN","C0CRIMA",259,0) W INLST,! "RTN","C0CRIMA",260,0) S ZCOUNT=0 "RTN","C0CRIMA",261,0) S ZDX="" "RTN","C0CRIMA",262,0) F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END "RTN","C0CRIMA",263,0) . S ZCOUNT=ZCOUNT+1 "RTN","C0CRIMA",264,0) . S ZDX=$O(@INLST@(ZDX)) "RTN","C0CRIMA",265,0) . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! "RTN","C0CRIMA",266,0) Q ZCOUNT "RTN","C0CRIMA",267,0) ; "RTN","C0CRIMA",268,0) XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT "RTN","C0CRIMA",269,0) ; "RTN","C0CRIMA",270,0) I '$D(CPATPARM) S CPATPARM="" "RTN","C0CRIMA",271,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CRIMA",272,0) N ZI,ZJ,ZC,ZPATBASE "RTN","C0CRIMA",273,0) S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) "RTN","C0CRIMA",274,0) S ZI="" "RTN","C0CRIMA",275,0) F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END "RTN","C0CRIMA",276,0) . S ZI=$O(@ZPATBASE@(ZI)) "RTN","C0CRIMA",277,0) . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE "RTN","C0CRIMA",278,0) Q "RTN","C0CRIMA",279,0) ; "RTN","C0CRIMA",280,0) CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT "RTN","C0CRIMA",281,0) ; "RTN","C0CRIMA",282,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CRIMA",283,0) N ZI,ZJ,ZC,ZPATBASE "RTN","C0CRIMA",284,0) S ZC=0 ; COUNT FOR SPACING THE PRINTOUT "RTN","C0CRIMA",285,0) S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) "RTN","C0CRIMA",286,0) S ZI="" "RTN","C0CRIMA",287,0) F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END "RTN","C0CRIMA",288,0) . S ZI=$O(@ZPATBASE@(ZI)) "RTN","C0CRIMA",289,0) . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT "RTN","C0CRIMA",290,0) . W ZI," " "RTN","C0CRIMA",291,0) . I ZC=10 D ; NEW LINE "RTN","C0CRIMA",292,0) . . S ZC=0 "RTN","C0CRIMA",293,0) . . W ! "RTN","C0CRIMA",294,0) Q "RTN","C0CRIMA",295,0) ; "RTN","C0CRIMA",296,0) PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT "RTN","C0CRIMA",297,0) ; "RTN","C0CRIMA",298,0) N ATTR S ATTR="" "RTN","C0CRIMA",299,0) I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT "RTN","C0CRIMA",300,0) . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT "RTN","C0CRIMA",301,0) S ATTR=^TMP("C0CRIM","ATTR",DFN) "RTN","C0CRIMA",302,0) I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND "RTN","C0CRIMA",303,0) I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT "RTN","C0CRIMA",304,0) . N CAT "RTN","C0CRIMA",305,0) . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT "RTN","C0CRIMA",306,0) . W CAT,": ",ATTR,! "RTN","C0CRIMA",307,0) Q "RTN","C0CRIMA",308,0) ; "RTN","C0CRIMA",309,0) APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) "RTN","C0CRIMA",310,0) ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT "RTN","C0CRIMA",311,0) ; AND AMAP(N)=AVAL IS THE NTH AVAL "RTN","C0CRIMA",312,0) ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE "RTN","C0CRIMA",313,0) ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE "RTN","C0CRIMA",314,0) ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED "RTN","C0CRIMA",315,0) ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED "RTN","C0CRIMA",316,0) ; "RTN","C0CRIMA",317,0) I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST "RTN","C0CRIMA",318,0) . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS "RTN","C0CRIMA",319,0) S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT "RTN","C0CRIMA",320,0) S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY "RTN","C0CRIMA",321,0) S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF "RTN","C0CRIMA",322,0) Q "RTN","C0CRIMA",323,0) ; "RTN","C0CRIMA",324,0) ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL "RTN","C0CRIMA",325,0) I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM")) "RTN","C0CRIMA",326,0) I '$D(@RIMBASE) S @RIMBASE="" "RTN","C0CRIMA",327,0) I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE "RTN","C0CRIMA",328,0) S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES "RTN","C0CRIMA",329,0) Q "RTN","C0CRIMA",330,0) ; "RTN","C0CRIMA",331,0) AINIT ; INITIALIZE ATTRIBUTE TABLE "RTN","C0CRIMA",332,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CRIMA",333,0) K @RIMTBL "RTN","C0CRIMA",334,0) D APUSH(RIMTBL,"EXTRACTED") "RTN","C0CRIMA",335,0) D APUSH(RIMTBL,"NOTEXTRACTED") "RTN","C0CRIMA",336,0) D APUSH(RIMTBL,"HEADER") "RTN","C0CRIMA",337,0) D APUSH(RIMTBL,"NOPCP") "RTN","C0CRIMA",338,0) D APUSH(RIMTBL,"PCP") "RTN","C0CRIMA",339,0) D APUSH(RIMTBL,"PROBLEMS") "RTN","C0CRIMA",340,0) D APUSH(RIMTBL,"PROBCODE") "RTN","C0CRIMA",341,0) D APUSH(RIMTBL,"PROBNOCODE") "RTN","C0CRIMA",342,0) D APUSH(RIMTBL,"PROBDATE") "RTN","C0CRIMA",343,0) D APUSH(RIMTBL,"PROBNODATE") "RTN","C0CRIMA",344,0) D APUSH(RIMTBL,"VITALS") "RTN","C0CRIMA",345,0) D APUSH(RIMTBL,"VITALSCODE") "RTN","C0CRIMA",346,0) D APUSH(RIMTBL,"VITALSNOCODE") "RTN","C0CRIMA",347,0) D APUSH(RIMTBL,"VITALSDATE") "RTN","C0CRIMA",348,0) D APUSH(RIMTBL,"VITALSNODATE") "RTN","C0CRIMA",349,0) D APUSH(RIMTBL,"IMMUNE") "RTN","C0CRIMA",350,0) D APUSH(RIMTBL,"IMMUNECODE") "RTN","C0CRIMA",351,0) D APUSH(RIMTBL,"MEDS") "RTN","C0CRIMA",352,0) D APUSH(RIMTBL,"MEDSCODE") "RTN","C0CRIMA",353,0) D APUSH(RIMTBL,"MEDSNOCODE") "RTN","C0CRIMA",354,0) D APUSH(RIMTBL,"MEDSDATE") "RTN","C0CRIMA",355,0) D APUSH(RIMTBL,"MEDSNODATE") "RTN","C0CRIMA",356,0) D APUSH(RIMTBL,"ALERTS") "RTN","C0CRIMA",357,0) D APUSH(RIMTBL,"ALERTSCODE") "RTN","C0CRIMA",358,0) D APUSH(RIMTBL,"RESULTS") "RTN","C0CRIMA",359,0) D APUSH(RIMTBL,"RESULTSLN") "RTN","C0CRIMA",360,0) D APUSH(RIMTBL,"PROCEDURES") "RTN","C0CRIMA",361,0) D APUSH(RIMTBL,"ENCOUNTERS") "RTN","C0CRIMA",362,0) D APUSH(RIMTBL,"NOTES") "RTN","C0CRIMA",363,0) Q "RTN","C0CRIMA",364,0) ; "RTN","C0CRIMA",365,0) APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL "RTN","C0CRIMA",366,0) ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING "RTN","C0CRIMA",367,0) ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES "RTN","C0CRIMA",368,0) ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) "RTN","C0CRIMA",369,0) I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING "RTN","C0CRIMA",370,0) N USETBL "RTN","C0CRIMA",371,0) I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE "RTN","C0CRIMA",372,0) . W "ERROR NO SUCH TABLE",! "RTN","C0CRIMA",373,0) S USETBL=@RIMBASE@("TABLES",PTBL) "RTN","C0CRIMA",374,0) S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL "RTN","C0CRIMA",375,0) Q "RTN","C0CRIMA",376,0) GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN "RTN","C0CRIMA",377,0) ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") "RTN","C0CRIMA",378,0) ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 "RTN","C0CRIMA",379,0) ; IN SECTION "MEDS" "RTN","C0CRIMA",380,0) ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS "RTN","C0CRIMA",381,0) ; PENDING FOR MED 2 FOR PATIENT 2 "RTN","C0CRIMA",382,0) ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE "RTN","C0CRIMA",383,0) ; RETURNED. RTN IS PASSED BY REFERENCE "RTN","C0CRIMA",384,0) ; "RTN","C0CRIMA",385,0) S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE "RTN","C0CRIMA",386,0) I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES "RTN","C0CRIMA",387,0) S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES "RTN","C0CRIMA",388,0) I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION "RTN","C0CRIMA",389,0) . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! "RTN","C0CRIMA",390,0) N ZZI,ZZS "RTN","C0CRIMA",391,0) S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT "RTN","C0CRIMA",392,0) ; ZWR @ZZS@(1) "RTN","C0CRIMA",393,0) S RTN(0)=@ZZS@(0) "RTN","C0CRIMA",394,0) F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) "RTN","C0CRIMA",395,0) . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE "RTN","C0CRIMA",396,0) . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE "RTN","C0CRIMA",397,0) Q "RTN","C0CRIMA",398,0) ; "RTN","C0CRIMA",399,0) PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR "RTN","C0CRIMA",400,0) ; "RTN","C0CRIMA",401,0) N ZR "RTN","C0CRIMA",402,0) D GETPA(.ZR,DFN,ISEC,IVAR) "RTN","C0CRIMA",403,0) I $D(ZR(0)) D PARY^C0CXPATH("ZR") "RTN","C0CRIMA",404,0) E W "NOTHING RETURNED",! "RTN","C0CRIMA",405,0) Q "RTN","C0CRIMA",406,0) ; "RTN","C0CRIMA",407,0) CAGET(RTN,IATTR) ; "RTN","C0CRIMA",408,0) ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR "RTN","C0CRIMA",409,0) ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE "RTN","C0CRIMA",410,0) ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC "RTN","C0CRIMA",411,0) Q "RTN","C0CRIMA",412,0) ; "RTN","C0CRIMA",413,0) PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR "RTN","C0CRIMA",414,0) ; "RTN","C0CRIMA",415,0) I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES "RTN","C0CRIMA",416,0) N ZLST "RTN","C0CRIMA",417,0) S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE "RTN","C0CRIMA",418,0) S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES "RTN","C0CRIMA",419,0) S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS "RTN","C0CRIMA",420,0) N ZNC ; ZNC IS NUMBER OF CATEGORIES "RTN","C0CRIMA",421,0) S ZNC=@ZCBASE@(0) "RTN","C0CRIMA",422,0) I ZNC=0 Q ; NO CATEGORIES TO SEARCH "RTN","C0CRIMA",423,0) N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE "RTN","C0CRIMA",424,0) S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) "RTN","C0CRIMA",425,0) N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT "RTN","C0CRIMA",426,0) F ZI=1:1:ZNC D ; FOR ALL CATEGORIES "RTN","C0CRIMA",427,0) . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT "RTN","C0CRIMA",428,0) . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR "RTN","C0CRIMA",429,0) . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL "RTN","C0CRIMA",430,0) . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT "RTN","C0CRIMA",431,0) S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS "RTN","C0CRIMA",432,0) S ZPAT=0 ; START AT FIRST PATIENT IN LIST "RTN","C0CRIMA",433,0) F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ; "RTN","C0CRIMA",434,0) . S ZCNT=ZCNT+1 "RTN","C0CRIMA",435,0) S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY "RTN","C0CRIMA",436,0) Q "RTN","C0CRIMA",437,0) ; "RTN","C0CRIMA",438,0) DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR "RTN","C0CRIMA",439,0) ; "RTN","C0CRIMA",440,0) ;N ZR "RTN","C0CRIMA",441,0) D PCLST("ZR",CATTR) "RTN","C0CRIMA",442,0) I ZR(0)=0 D Q ; "RTN","C0CRIMA",443,0) . W "NO PATIENTS RETURNED",! "RTN","C0CRIMA",444,0) E D ; "RTN","C0CRIMA",445,0) . N ZI S ZI=0 "RTN","C0CRIMA",446,0) . F S ZI=$O(ZR(ZI)) Q:ZI="" D ; "RTN","C0CRIMA",447,0) . . W !,ZI "RTN","C0CRIMA",448,0) . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY "RTN","C0CRIMA",449,0) . W !,"COUNT=",ZR(0) "RTN","C0CRIMA",450,0) Q "RTN","C0CRIMA",451,0) ; "RTN","C0CRIMA",452,0) RPCGV(RTN,DFN,WHICH) ; RPC GET VARS "RTN","C0CRIMA",453,0) ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES "RTN","C0CRIMA",454,0) ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT "RTN","C0CRIMA",455,0) ; DFN IS THE PATIENT NUMBER. "RTN","C0CRIMA",456,0) ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE" "RTN","C0CRIMA",457,0) ; OR OTHER SECTIONS AS THEY ARE ADDED "RTN","C0CRIMA",458,0) ; THIS IS MEANT TO BE AVAILABLE AS AN RPC "RTN","C0CRIMA",459,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CRIMA",460,0) S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES "RTN","C0CRIMA",461,0) S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED "RTN","C0CRIMA",462,0) N ZZGI "RTN","C0CRIMA",463,0) I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS "RTN","C0CRIMA",464,0) . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D ; "RTN","C0CRIMA",465,0) . . D ZGVWRK(ZZGI) ; DO EACH SECTION "RTN","C0CRIMA",466,0) . . I $G(DEBUG)'="" W "DID ",ZZGI,! "RTN","C0CRIMA",467,0) E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR "RTN","C0CRIMA",468,0) Q "RTN","C0CRIMA",469,0) ; "RTN","C0CRIMA",470,0) ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV "RTN","C0CRIMA",471,0) ; "RTN","C0CRIMA",472,0) N ZZGN ; NAME FOR SECTION VARIABLES "RTN","C0CRIMA",473,0) S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION "RTN","C0CRIMA",474,0) ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION "RTN","C0CRIMA",475,0) I $O(@ZZGN@(""),-1)="" D ; "RTN","C0CRIMA",476,0) E D ; VARS EXIST "RTN","C0CRIMA",477,0) . N ZGVI,ZGVN "RTN","C0CRIMA",478,0) . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS "RTN","C0CRIMA",479,0) . F ZGVI=1:1:ZGVN D ; FOR EACH MULTIPLE IN SECTION "RTN","C0CRIMA",480,0) . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS "RTN","C0CRIMA",481,0) . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE "RTN","C0CRIMA",482,0) . . S ZZGN2=$NA(@ZZGN@(ZGVI)) "RTN","C0CRIMA",483,0) . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),! "RTN","C0CRIMA",484,0) . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY "RTN","C0CRIMA",485,0) . . ; D PARY^C0CXPATH("ZZGA") "RTN","C0CRIMA",486,0) . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN "RTN","C0CRIMA",487,0) Q "RTN","C0CRIMA",488,0) ; "RTN","C0CRIMA",489,0) DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM "RTN","C0CRIMA",490,0) ; ALONG WITH SAMPLE VALUES. "RTN","C0CRIMA",491,0) ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER" "RTN","C0CRIMA",492,0) N GTMP "RTN","C0CRIMA",493,0) I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT "RTN","C0CRIMA",494,0) . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES "RTN","C0CRIMA",495,0) I '$D(IWHICH) S IWHICH="ALL" "RTN","C0CRIMA",496,0) D RPCGV(.GTMP,DFN,IWHICH) "RTN","C0CRIMA",497,0) D PARY^C0CXPATH("GTMP") "RTN","C0CRIMA",498,0) Q "RTN","C0CRIMA",499,0) ; "RTN","C0CRIMA",500,0) RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT "RTN","C0CRIMA",501,0) ; RETURN IN R2RTN, WHICH IS PASSED BY NAME "RTN","C0CRIMA",502,0) ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL" "RTN","C0CRIMA",503,0) ; "RTN","C0CRIMA",504,0) I '$D(RWHICH) S RWHICH="ALL" "RTN","C0CRIMA",505,0) ;N R2TMP "RTN","C0CRIMA",506,0) I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT "RTN","C0CRIMA",507,0) . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES "RTN","C0CRIMA",508,0) D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY "RTN","C0CRIMA",509,0) N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z "RTN","C0CRIMA",510,0) F R2I=1:1:R2TMP(0) D ; FOR EVERY LINE OF THE ARRAY "RTN","C0CRIMA",511,0) . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE "RTN","C0CRIMA",512,0) . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME "RTN","C0CRIMA",513,0) . I $L(R2Y)<4 Q ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING) "RTN","C0CRIMA",514,0) . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE "RTN","C0CRIMA",515,0) . I R2X[";" D ; THERES MULTIPLES "RTN","C0CRIMA",516,0) . . S R2X1=$P(R2X,";",1) ; FIRST INDEX "RTN","C0CRIMA",517,0) . . S R2X2=$P(R2X,";",2) ; SECOND INDEX "RTN","C0CRIMA",518,0) . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME "RTN","C0CRIMA",519,0) . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP "RTN","C0CRIMA",520,0) . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY "RTN","C0CRIMA",521,0) . E D ; NO SUB-MULTIPLES "RTN","C0CRIMA",522,0) . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP "RTN","C0CRIMA",523,0) . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY "RTN","C0CRIMA",524,0) Q "RTN","C0CRIMA",525,0) ; "RTN","C0CRIMA",526,0) RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE "RTN","C0CRIMA",527,0) ; "RTN","C0CRIMA",528,0) N R2CTMP,R2CARY "RTN","C0CRIMA",529,0) D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT "RTN","C0CRIMA",530,0) D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT "RTN","C0CRIMA",531,0) D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv") "RTN","C0CRIMA",532,0) Q "RTN","C0CRIMA",533,0) ; "RTN","C0CRNF") 0^52^B195772222 "RTN","C0CRNF",1,0) C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 "RTN","C0CRNF",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CRNF",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CRNF",4,0) ;General Public License See attached copy of the License. "RTN","C0CRNF",5,0) ; "RTN","C0CRNF",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CRNF",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CRNF",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CRNF",9,0) ;(at your option) any later version. "RTN","C0CRNF",10,0) ; "RTN","C0CRNF",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CRNF",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CRNF",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CRNF",14,0) ;GNU General Public License for more details. "RTN","C0CRNF",15,0) ; "RTN","C0CRNF",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CRNF",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CRNF",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CRNF",19,0) ; "RTN","C0CRNF",20,0) W "This is the Reference Name Format (RNF) Utility Library ",! "RTN","C0CRNF",21,0) W ! "RTN","C0CRNF",22,0) Q "RTN","C0CRNF",23,0) ; "RTN","C0CRNF",24,0) FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, "RTN","C0CRNF",25,0) ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE "RTN","C0CRNF",26,0) ; "RTN","C0CRNF",27,0) N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP "RTN","C0CRNF",28,0) N C0CFN ; FIELD NAME "RTN","C0CRNF",29,0) S C0CFI=0 S C0CFJ=C0CF "RTN","C0CRNF",30,0) K @C0CFRTN ; CLEAR THE RETURN ARRAY "RTN","C0CRNF",31,0) F Q:C0CFJ'[C0CF D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE "RTN","C0CRNF",32,0) . ;W "1: "_C0CFJ," ",C0CFI,! "RTN","C0CRNF",33,0) . F S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0 D ; EVERY FIELD "RTN","C0CRNF",34,0) . . ;W "2: "_C0CFJ," ",C0CFI,! "RTN","C0CRNF",35,0) . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD "RTN","C0CRNF",36,0) . . ;W "N: ",C0CFN,! "RTN","C0CRNF",37,0) . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,! "RTN","C0CRNF",38,0) . . I $D(@C0CFRTN@(C0CFN)) D ; IS THIS A DUPLICATE? "RTN","C0CRNF",39,0) . . . I $G(DEBUG) D ; "RTN","C0CRNF",40,0) . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),! "RTN","C0CRNF",41,0) . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI "RTN","C0CRNF",42,0) . . E S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI "RTN","C0CRNF",43,0) . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE "RTN","C0CRNF",44,0) Q "RTN","C0CRNF",45,0) ; "RTN","C0CRNF",46,0) TESTRNF ; TEST THE RNF1TO2 ROUTINE "RTN","C0CRNF",47,0) S G1("ONE")=1 "RTN","C0CRNF",48,0) S G1("TWO")=2 "RTN","C0CRNF",49,0) S G1("THREE")=3 "RTN","C0CRNF",50,0) D RNF1TO2("GPL","G1") "RTN","C0CRNF",51,0) S G1("ONE")="NOT1" "RTN","C0CRNF",52,0) S G1("TWO")="STILL2" "RTN","C0CRNF",53,0) S G1("THREE")=3 "RTN","C0CRNF",54,0) D RNF1TO2("GPL","G1") "RTN","C0CRNF",55,0) ZWR GPL "RTN","C0CRNF",56,0) Q "RTN","C0CRNF",57,0) ; "RTN","C0CRNF",58,0) RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY "RTN","C0CRNF",59,0) ; (ZOUT) BOTH ARE PASSED BY NAME "RTN","C0CRNF",60,0) ; RNF1 IS OF THE FORM: "RTN","C0CRNF",61,0) ; @ZIN@("VAR1")=VAL1 "RTN","C0CRNF",62,0) ; @ZIN@("VAR2")=VAL2 "RTN","C0CRNF",63,0) ; RNF2 IS OF THE FORM: "RTN","C0CRNF",64,0) ; @ZOUT@("F","VAR1")="" "RTN","C0CRNF",65,0) ; @ZOUT@("F","VAR2")="" "RTN","C0CRNF",66,0) ; @ZOUT@("V",n,"VAR1")=VAL1 "RTN","C0CRNF",67,0) ; @ZOUT@("V",n,"VAR2")=VAL2 "RTN","C0CRNF",68,0) ; WHERE n IS THE "ROW" OF THE ARRAY "RTN","C0CRNF",69,0) N ZI S ZI="" "RTN","C0CRNF",70,0) N ZN "RTN","C0CRNF",71,0) I '$D(@ZOUT@("V",1)) S ZN=1 "RTN","C0CRNF",72,0) E S ZN=$O(@ZOUT@("V",""),-1)+1 "RTN","C0CRNF",73,0) F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; "RTN","C0CRNF",74,0) . S @ZOUT@("F",ZI)="" "RTN","C0CRNF",75,0) . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI) "RTN","C0CRNF",76,0) Q "RTN","C0CRNF",77,0) ; "RTN","C0CRNF",78,0) RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY "RTN","C0CRNF",79,0) ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY "RTN","C0CRNF",80,0) ; EVERY "V" VARIABLE IS FOLLOWED BY A "1" "RTN","C0CRNF",81,0) ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1" "RTN","C0CRNF",82,0) ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV "RTN","C0CRNF",83,0) ; WITH RNF2CSV "RTN","C0CRNF",84,0) ; (ZOUT) BOTH ARE PASSED BY NAME "RTN","C0CRNF",85,0) ; RNF1 IS OF THE FORM: "RTN","C0CRNF",86,0) ; @ZIN@("VAR1")=VAL1 "RTN","C0CRNF",87,0) ; @ZIN@("VAR2")=VAL2 "RTN","C0CRNF",88,0) ; RNF2 IS OF THE FORM: "RTN","C0CRNF",89,0) ; @ZOUT@("F","VAR1")="" "RTN","C0CRNF",90,0) ; @ZOUT@("F","VAR2")="" "RTN","C0CRNF",91,0) ; @ZOUT@("V",n,"VAR1",1)=VAL1 "RTN","C0CRNF",92,0) ; @ZOUT@("V",n,"VAR2",1)=VAL2 "RTN","C0CRNF",93,0) ; WHERE n IS THE "ROW" OF THE ARRAY "RTN","C0CRNF",94,0) N ZI S ZI="" "RTN","C0CRNF",95,0) N ZN "RTN","C0CRNF",96,0) I '$D(@ZOUT@("V",1)) S ZN=1 "RTN","C0CRNF",97,0) E S ZN=$O(@ZOUT@("V",""),-1)+1 "RTN","C0CRNF",98,0) F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; "RTN","C0CRNF",99,0) . S @ZOUT@("F",ZI)="" "RTN","C0CRNF",100,0) . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI) "RTN","C0CRNF",101,0) Q "RTN","C0CRNF",102,0) ; "RTN","C0CRNF",103,0) GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME "RTN","C0CRNF",104,0) ; GRTN IS PASSED BY NAME "RTN","C0CRNF",105,0) ; "RTN","C0CRNF",106,0) N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME "RTN","C0CRNF",107,0) I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) "RTN","C0CRNF",108,0) E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) "RTN","C0CRNF",109,0) S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE "RTN","C0CRNF",110,0) D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP "RTN","C0CRNF",111,0) D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP") "RTN","C0CRNF",112,0) D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE "RTN","C0CRNF",113,0) S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE "RTN","C0CRNF",114,0) S (C0CI,C0CJ)="" "RTN","C0CRNF",115,0) F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES "RTN","C0CRNF",116,0) . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE "RTN","C0CRNF",117,0) . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS "RTN","C0CRNF",118,0) . . ;W C0CJ," ",C0CI,! "RTN","C0CRNF",119,0) . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME "RTN","C0CRNF",120,0) . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ; "RTN","C0CRNF",121,0) . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP "RTN","C0CRNF",122,0) . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 "RTN","C0CRNF",123,0) I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED "RTN","C0CRNF",124,0) . S C0CI="" "RTN","C0CRNF",125,0) . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY "RTN","C0CRNF",126,0) . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES "RTN","C0CRNF",127,0) Q "RTN","C0CRNF",128,0) ; "RTN","C0CRNF",129,0) GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP "RTN","C0CRNF",130,0) ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 "RTN","C0CRNF",131,0) ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL "RTN","C0CRNF",132,0) ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN "RTN","C0CRNF",133,0) ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP "RTN","C0CRNF",134,0) ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" "RTN","C0CRNF",135,0) ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP "RTN","C0CRNF",136,0) ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE "RTN","C0CRNF",137,0) ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE "RTN","C0CRNF",138,0) ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP "RTN","C0CRNF",139,0) ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP "RTN","C0CRNF",140,0) ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE "RTN","C0CRNF",141,0) ; IF GREF IS "" THE FIRST RECORD IS OBTAINED "RTN","C0CRNF",142,0) ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE "RTN","C0CRNF",143,0) ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN "RTN","C0CRNF",144,0) ; GREF IS THE VALUE FOR THE INDEX "RTN","C0CRNF",145,0) ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED "RTN","C0CRNF",146,0) ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN "RTN","C0CRNF",147,0) ; "RTN","C0CRNF",148,0) ; "RTN","C0CRNF",149,0) N GIEN,GF "RTN","C0CRNF",150,0) S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE "RTN","C0CRNF",151,0) I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN "RTN","C0CRNF",152,0) E D ; WE ARE USING AN INDEX "RTN","C0CRNF",153,0) . ;N ZG "RTN","C0CRNF",154,0) . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX "RTN","C0CRNF",155,0) . I ZG'="" D ; "RTN","C0CRNF",156,0) . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? "RTN","C0CRNF",157,0) . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN "RTN","C0CRNF",158,0) . . E S GIEN="" ; NOT FOUND IN INDEX "RTN","C0CRNF",159,0) . E S GIEN="" ; "RTN","C0CRNF",160,0) ;W "IEN: ",GIEN,! "RTN","C0CRNF",161,0) ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME "RTN","C0CRNF",162,0) I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) "RTN","C0CRNF",163,0) E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) "RTN","C0CRNF",164,0) S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE "RTN","C0CRNF",165,0) D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP "RTN","C0CRNF",166,0) K C0CTMP "RTN","C0CRNF",167,0) D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") "RTN","C0CRNF",168,0) D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE "RTN","C0CRNF",169,0) S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE "RTN","C0CRNF",170,0) S (C0CI,C0CJ)="" "RTN","C0CRNF",171,0) F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES "RTN","C0CRNF",172,0) . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE "RTN","C0CRNF",173,0) . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS "RTN","C0CRNF",174,0) . . ;W C0CJ," ",C0CI,! "RTN","C0CRNF",175,0) . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME "RTN","C0CRNF",176,0) . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; "RTN","C0CRNF",177,0) . . I C0CVALUE["C0CTMP" D ; WP FIELD "RTN","C0CRNF",178,0) . . . N ZT,ZWP S ZWP=0 ;ITERATOR "RTN","C0CRNF",179,0) . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE "RTN","C0CRNF",180,0) . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE "RTN","C0CRNF",181,0) . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; "RTN","C0CRNF",182,0) . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP "RTN","C0CRNF",183,0) . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " "RTN","C0CRNF",184,0) . . . . S C0CVALUE=C0CVALUE_ZT ; "RTN","C0CRNF",185,0) . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 "RTN","C0CRNF",186,0) . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) "RTN","C0CRNF",187,0) I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED "RTN","C0CRNF",188,0) . S C0CI="" "RTN","C0CRNF",189,0) . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY "RTN","C0CRNF",190,0) . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES "RTN","C0CRNF",191,0) Q "RTN","C0CRNF",192,0) ; "RTN","C0CRNF",193,0) GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP "RTN","C0CRNF",194,0) ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 "RTN","C0CRNF",195,0) ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL "RTN","C0CRNF",196,0) ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN "RTN","C0CRNF",197,0) ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP "RTN","C0CRNF",198,0) ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" "RTN","C0CRNF",199,0) ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP "RTN","C0CRNF",200,0) ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE "RTN","C0CRNF",201,0) ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE "RTN","C0CRNF",202,0) ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP "RTN","C0CRNF",203,0) ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP "RTN","C0CRNF",204,0) ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE "RTN","C0CRNF",205,0) ; IF GREF IS "" THE FIRST RECORD IS OBTAINED "RTN","C0CRNF",206,0) ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE "RTN","C0CRNF",207,0) ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN "RTN","C0CRNF",208,0) ; GREF IS THE VALUE FOR THE INDEX "RTN","C0CRNF",209,0) ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED "RTN","C0CRNF",210,0) ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN "RTN","C0CRNF",211,0) ; "RTN","C0CRNF",212,0) ; "RTN","C0CRNF",213,0) N GIEN,GF "RTN","C0CRNF",214,0) S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE "RTN","C0CRNF",215,0) I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN "RTN","C0CRNF",216,0) E D ; WE ARE USING AN INDEX "RTN","C0CRNF",217,0) . ;N ZG "RTN","C0CRNF",218,0) . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX "RTN","C0CRNF",219,0) . I ZG'="" D ; "RTN","C0CRNF",220,0) . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? "RTN","C0CRNF",221,0) . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN "RTN","C0CRNF",222,0) . . E S GIEN="" ; NOT FOUND IN INDEX "RTN","C0CRNF",223,0) . E S GIEN="" ; "RTN","C0CRNF",224,0) ;W "IEN: ",GIEN,! "RTN","C0CRNF",225,0) ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME "RTN","C0CRNF",226,0) I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) "RTN","C0CRNF",227,0) E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) "RTN","C0CRNF",228,0) S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE "RTN","C0CRNF",229,0) D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP "RTN","C0CRNF",230,0) K C0CTMP "RTN","C0CRNF",231,0) D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") "RTN","C0CRNF",232,0) D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE "RTN","C0CRNF",233,0) S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE "RTN","C0CRNF",234,0) S (C0CI,C0CJ)="" "RTN","C0CRNF",235,0) F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES "RTN","C0CRNF",236,0) . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE "RTN","C0CRNF",237,0) . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS "RTN","C0CRNF",238,0) . . ;W C0CJ," ",C0CI,! "RTN","C0CRNF",239,0) . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME "RTN","C0CRNF",240,0) . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; "RTN","C0CRNF",241,0) . . I C0CVALUE["C0CTMP" D ; WP FIELD "RTN","C0CRNF",242,0) . . . N ZT,ZWP S ZWP=0 ;ITERATOR "RTN","C0CRNF",243,0) . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE "RTN","C0CRNF",244,0) . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE "RTN","C0CRNF",245,0) . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; "RTN","C0CRNF",246,0) . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP "RTN","C0CRNF",247,0) . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " "RTN","C0CRNF",248,0) . . . . S C0CVALUE=C0CVALUE_ZT ; "RTN","C0CRNF",249,0) . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 "RTN","C0CRNF",250,0) . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) "RTN","C0CRNF",251,0) I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED "RTN","C0CRNF",252,0) . S C0CI="" "RTN","C0CRNF",253,0) . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY "RTN","C0CRNF",254,0) . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES "RTN","C0CRNF",255,0) Q "RTN","C0CRNF",256,0) ; "RTN","C0CRNF",257,0) GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES "RTN","C0CRNF",258,0) ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP "RTN","C0CRNF",259,0) ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" "RTN","C0CRNF",260,0) ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP "RTN","C0CRNF",261,0) ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE "RTN","C0CRNF",262,0) ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES "RTN","C0CRNF",263,0) ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE "RTN","C0CRNF",264,0) ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP "RTN","C0CRNF",265,0) ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP "RTN","C0CRNF",266,0) ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE "RTN","C0CRNF",267,0) ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE "RTN","C0CRNF",268,0) ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN "RTN","C0CRNF",269,0) ; .. OF THE FILE WILL BE USED "RTN","C0CRNF",270,0) ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE "RTN","C0CRNF",271,0) ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED "RTN","C0CRNF",272,0) ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE "RTN","C0CRNF",273,0) ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD "RTN","C0CRNF",274,0) ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED "RTN","C0CRNF",275,0) ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL "RTN","C0CRNF",276,0) ;N GATMP,GAI,GAF "RTN","C0CRNF",277,0) S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE "RTN","C0CRNF",278,0) I '$D(GAIDX) S GAIDX="" ;DEFAULT "RTN","C0CRNF",279,0) I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED "RTN","C0CRNF",280,0) I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX "RTN","C0CRNF",281,0) W GAF,! "RTN","C0CRNF",282,0) W $O(@GAF@(0)) ; "RTN","C0CRNF",283,0) S GAI=0 ;ITERATOR "RTN","C0CRNF",284,0) F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; "RTN","C0CRNF",285,0) . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD "RTN","C0CRNF",286,0) . N GAX S GAX=0 "RTN","C0CRNF",287,0) . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS "RTN","C0CRNF",288,0) . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN "RTN","C0CRNF",289,0) Q "RTN","C0CRNF",290,0) ; "RTN","C0CRNF",291,0) ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX "RTN","C0CRNF",292,0) ; "RTN","C0CRNF",293,0) S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# "RTN","C0CRNF",294,0) S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE "RTN","C0CRNF",295,0) Q "RTN","C0CRNF",296,0) ; "RTN","C0CRNF",297,0) RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT "RTN","C0CRNF",298,0) ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES "RTN","C0CRNF",299,0) ; RNSTY IS STYLE OF THE OUTPUT - "RTN","C0CRNF",300,0) ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES "RTN","C0CRNF",301,0) ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES "RTN","C0CRNF",302,0) ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES "RTN","C0CRNF",303,0) N RNR,RNC ;ROW ROOT,COL ROOT "RTN","C0CRNF",304,0) N RNI,RNJ,RNX "RTN","C0CRNF",305,0) I '$D(RNSTY) S RNSTY="NV" ;DEFAULT "RTN","C0CRNF",306,0) I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION "RTN","C0CRNF",307,0) E D VN(RNRTN,RNIN) ; "RTN","C0CRNF",308,0) Q "RTN","C0CRNF",309,0) ; "RTN","C0CRNF",310,0) NV(RNRTN,RNIN) ; "RTN","C0CRNF",311,0) S RNR=$NA(@RNIN@("F")) "RTN","C0CRNF",312,0) S RNC=$NA(@RNIN@("V")) "RTN","C0CRNF",313,0) ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER "RTN","C0CRNF",314,0) S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" "RTN","C0CRNF",315,0) S RNI="" "RTN","C0CRNF",316,0) F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN "RTN","C0CRNF",317,0) . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA "RTN","C0CRNF",318,0) S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNF",319,0) D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS "RTN","C0CRNF",320,0) S RNI="" "RTN","C0CRNF",321,0) F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW "RTN","C0CRNF",322,0) . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD "RTN","C0CRNF",323,0) . S RNJ="" "RTN","C0CRNF",324,0) . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL "RTN","C0CRNF",325,0) . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN "RTN","C0CRNF",326,0) . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA "RTN","C0CRNF",327,0) . . E S RNX=RNX_"," ; NUL COLUMN "RTN","C0CRNF",328,0) . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNF",329,0) . D PUSH^C0CXPATH(RNRTN,RNX) "RTN","C0CRNF",330,0) Q "RTN","C0CRNF",331,0) ; "RTN","C0CRNF",332,0) VN(RNRTN,RNIN) ; "RTN","C0CRNF",333,0) S RNR=$NA(@RNIN@("V")) "RTN","C0CRNF",334,0) S RNC=$NA(@RNIN@("F")) "RTN","C0CRNF",335,0) ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER "RTN","C0CRNF",336,0) S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW" "RTN","C0CRNF",337,0) S RNI="" "RTN","C0CRNF",338,0) F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN "RTN","C0CRNF",339,0) . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA "RTN","C0CRNF",340,0) S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNF",341,0) D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS "RTN","C0CRNF",342,0) S RNI="" "RTN","C0CRNF",343,0) F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW "RTN","C0CRNF",344,0) . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD "RTN","C0CRNF",345,0) . S RNJ="" "RTN","C0CRNF",346,0) . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL "RTN","C0CRNF",347,0) . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN "RTN","C0CRNF",348,0) . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","") "RTN","C0CRNF",349,0) . . . S RNV=$TR(RNV,",","") "RTN","C0CRNF",350,0) . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA "RTN","C0CRNF",351,0) . . E S RNX=RNX_"," ; NUL COLUMN "RTN","C0CRNF",352,0) . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNF",353,0) . D PUSH^C0CXPATH(RNRTN,RNX) "RTN","C0CRNF",354,0) Q "RTN","C0CRNF",355,0) ; "RTN","C0CRNF",356,0) READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME "RTN","C0CRNF",357,0) ; "RTN","C0CRNF",358,0) Q $$FTG^%ZISH(PATH,NAME,GLB,1) "RTN","C0CRNF",359,0) ; "RTN","C0CRNF",360,0) FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV "RTN","C0CRNF",361,0) ; "RTN","C0CRNF",362,0) ;N G1,G2 "RTN","C0CRNF",363,0) I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE "RTN","C0CRNF",364,0) S G1=$NA(^TMP($J,"C0CCSV",1)) "RTN","C0CRNF",365,0) S G2=$NA(^TMP($J,"C0CCSV",2)) "RTN","C0CRNF",366,0) D GETN2(G1,FNUM) ; GET THE MATRIX "RTN","C0CRNF",367,0) D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE "RTN","C0CRNF",368,0) K @G1 "RTN","C0CRNF",369,0) D FILEOUT(G2,"FILE_"_FNUM_".csv") "RTN","C0CRNF",370,0) K @G2 "RTN","C0CRNF",371,0) Q "RTN","C0CRNF",372,0) ; "RTN","C0CRNF",373,0) FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE "RTN","C0CRNF",374,0) ; "RTN","C0CRNF",375,0) W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR")) "RTN","C0CRNF",376,0) Q "RTN","C0CRNF",377,0) ; "RTN","C0CRNF",378,0) FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM "RTN","C0CRNF",379,0) ; "RTN","C0CRNF",380,0) N C0CF "RTN","C0CRNF",381,0) S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE "RTN","C0CRNF",382,0) S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT "RTN","C0CRNF",383,0) I C0CF["()" S C0CF=$P(C0CF,"()",1) "RTN","C0CRNF",384,0) Q C0CF "RTN","C0CRNF",385,0) ; "RTN","C0CRNF",386,0) SKIP ; "RTN","C0CRNF",387,0) N TXT,DIERR "RTN","C0CRNF",388,0) S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") "RTN","C0CRNF",389,0) I $D(DIERR) D CLEAN^DILF Q "RTN","C0CRNF",390,0) W " report_text:",! ;Progress Note Text "RTN","C0CRNF",391,0) N LN S LN=0 "RTN","C0CRNF",392,0) F S LN=$O(TXT(LN)) Q:'LN D "RTN","C0CRNF",393,0) . W " text"_LN_": "_TXT(LN),! "RTN","C0CRNF",394,0) . Q "RTN","C0CRNF",395,0) Q "RTN","C0CRNF",396,0) ; "RTN","C0CRNF",397,0) RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME "RTN","C0CRNF",398,0) ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT "RTN","C0CRNF",399,0) ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END "RTN","C0CRNF",400,0) ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES "RTN","C0CRNF",401,0) D PUSH^C0CXPATH(ZOUT,"") "RTN","C0CRNF",402,0) N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0 "RTN","C0CRNF",403,0) D PUSH^C0CXPATH(ZOUT,"") ;begin row and leave a blank col "RTN","C0CRNF",404,0) F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE "RTN","C0CRNF",405,0) . S ZV="" ; OCCURANCE AS COLUMNS HEADER "RTN","C0CRNF",406,0) . D PUSH^C0CXPATH(ZOUT,ZV) "RTN","C0CRNF",407,0) D PUSH^C0CXPATH(ZOUT,"") ;end of first row "RTN","C0CRNF",408,0) S ZI="" "RTN","C0CRNF",409,0) F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE "RTN","C0CRNF",410,0) . S ZN="" ; VARIABLE NAME IN FIRST COLUMN "RTN","C0CRNF",411,0) . D PUSH^C0CXPATH(ZOUT,ZN) "RTN","C0CRNF",412,0) . S ZJ=0 ;RESET TO DO IT AGAIN "RTN","C0CRNF",413,0) . F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE "RTN","C0CRNF",414,0) . . S ZV="" "RTN","C0CRNF",415,0) . . D PUSH^C0CXPATH(ZOUT,ZV) "RTN","C0CRNF",416,0) . D PUSH^C0CXPATH(ZOUT,"") ;END OF ROW "RTN","C0CRNF",417,0) D PUSH^C0CXPATH(ZOUT,"
"_ZJ_"
"_ZI_""_$G(@ZIN@("V",ZJ,ZI,1))_"
") ; end of table "RTN","C0CRNF",418,0) Q "RTN","C0CRNF",419,0) ; "RTN","C0CRNF",420,0) RNF2HVN(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME "RTN","C0CRNF",421,0) ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT "RTN","C0CRNF",422,0) ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END "RTN","C0CRNF",423,0) ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES "RTN","C0CRNF",424,0) D PUSH^C0CXPATH(ZOUT,"") "RTN","C0CRNF",425,0) N ZI,ZJ S ZI="" S ZJ=0 "RTN","C0CRNF",426,0) D PUSH^C0CXPATH(ZOUT,"") ;new row for column headers "RTN","C0CRNF",427,0) F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE "RTN","C0CRNF",428,0) . S ZV="" "RTN","C0CRNF",429,0) . D PUSH^C0CXPATH(ZOUT,ZV) ; name "RTN","C0CRNF",430,0) D PUSH^C0CXPATH(ZOUT,"") ; end header row "RTN","C0CRNF",431,0) S ZI="" ;RESET TO DO AGAIN "RTN","C0CRNF",432,0) F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH ROW OF VARIABLES "RTN","C0CRNF",433,0) . D PUSH^C0CXPATH(ZOUT,"") ;begin row "RTN","C0CRNF",434,0) . F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE "RTN","C0CRNF",435,0) . . S ZV="" ; value "RTN","C0CRNF",436,0) . . D PUSH^C0CXPATH(ZOUT,ZV) ; value "RTN","C0CRNF",437,0) . D PUSH^C0CXPATH(ZOUT,"") ; end header "RTN","C0CRNF",438,0) D PUSH^C0CXPATH(ZOUT,"
"_ZI_"
"_$G(@ZIN@("V",ZJ,ZI,1))_"
") ;end of table "RTN","C0CRNF",439,0) Q "RTN","C0CRNF",440,0) ; "RTN","C0CRNF",441,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CRNF",442,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) "RTN","C0CRNF",443,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNF",444,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNF",445,0) Q $P(@ZTAB@(ZFN),"^",1) "RTN","C0CRNF",446,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CRNF",447,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) "RTN","C0CRNF",448,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNF",449,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNF",450,0) Q $P(@ZTAB@(ZFN),"^",2) "RTN","C0CRNF",451,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CRNF",452,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) "RTN","C0CRNF",453,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNF",454,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNF",455,0) Q $P($G(@ZTAB@(ZFN)),"^",3) "RTN","C0CRNF",456,0) ; "RTN","C0CRNF",457,0) ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED "RTN","C0CRNF",458,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) "RTN","C0CRNF",459,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNF",460,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNF",461,0) Q $P($G(@ZTAB@(ZFN,"I")),"^",3) "RTN","C0CRNF",462,0) ; "RTN","C0CRNFRP") 0^53^B91867769 "RTN","C0CRNFRP",1,0) C0CRNFRPC ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 "RTN","C0CRNFRP",2,0) ;;1.0;C0C;;Dec 9, 2009;Build 1 "RTN","C0CRNFRP",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CRNFRP",4,0) ;General Public License See attached copy of the License. "RTN","C0CRNFRP",5,0) ; "RTN","C0CRNFRP",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CRNFRP",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CRNFRP",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CRNFRP",9,0) ;(at your option) any later version. "RTN","C0CRNFRP",10,0) ; "RTN","C0CRNFRP",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CRNFRP",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CRNFRP",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CRNFRP",14,0) ;GNU General Public License for more details. "RTN","C0CRNFRP",15,0) ; "RTN","C0CRNFRP",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CRNFRP",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CRNFRP",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CRNFRP",19,0) ; "RTN","C0CRNFRP",20,0) W "This is the Reference Name Format (RNF) RPC Library ",! "RTN","C0CRNFRP",21,0) W ! "RTN","C0CRNFRP",22,0) Q "RTN","C0CRNFRP",23,0) ; "RTN","C0CRNFRP",24,0) ;This routine will be mirroring C0CRNF and transform the output "RTN","C0CRNFRP",25,0) ;of the tags into an RPC friendly format "RTN","C0CRNFRP",26,0) ;The tags will be exactly as they are in C0CRNF "RTN","C0CRNFRP",27,0) FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, "RTN","C0CRNFRP",28,0) ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE "RTN","C0CRNFRP",29,0) ;RETURN FORMAT: "RTN","C0CRNFRP",30,0) ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS "RTN","C0CRNFRP",31,0) ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER" "RTN","C0CRNFRP",32,0) ; "RTN","C0CRNFRP",33,0) ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: "RTN","C0CRNFRP",34,0) ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625" "RTN","C0CRNFRP",35,0) ; "RTN","C0CRNFRP",36,0) ;FORMAT APPEARS TO BE: "RTN","C0CRNFRP",37,0) ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER" "RTN","C0CRNFRP",38,0) ; "RTN","C0CRNFRP",39,0) ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON "RTN","C0CRNFRP",40,0) S DEBUG=0 "RTN","C0CRNFRP",41,0) ;SET RETURN VALUE "RTN","C0CRNFRP",42,0) S C0CFRTN=$NA(^TMP("C0CRNF",$J)) "RTN","C0CRNFRP",43,0) K @C0CFRTN "RTN","C0CRNFRP",44,0) ;RUN WRAPPED CALL "RTN","C0CRNFRP",45,0) D FIELDS^C0CRNF("C0CRTN",C0CFILE) "RTN","C0CRNFRP",46,0) S J="" "RTN","C0CRNFRP",47,0) S I=1 "RTN","C0CRNFRP",48,0) ;FORMAT RETURN "RTN","C0CRNFRP",49,0) F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY "RTN","C0CRNFRP",50,0) . S @C0CFRTN@(I)=J_"^"_C0CRTN(J) "RTN","C0CRNFRP",51,0) . S I=I+1 "RTN","C0CRNFRP",52,0) S @C0CFRTN@(0)=I-1 "RTN","C0CRNFRP",53,0) ;CLEAN UP "RTN","C0CRNFRP",54,0) K J,I "RTN","C0CRNFRP",55,0) Q "RTN","C0CRNFRP",56,0) ; "RTN","C0CRNFRP",57,0) GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME "RTN","C0CRNFRP",58,0) ; GRTN IS PASSED BY NAME "RTN","C0CRNFRP",59,0) ; "RTN","C0CRNFRP",60,0) ; OLD TAG DO NOT USE! "RTN","C0CRNFRP",61,0) Q "RTN","C0CRNFRP",62,0) ; "RTN","C0CRNFRP",63,0) GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP "RTN","C0CRNFRP",64,0) ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL "RTN","C0CRNFRP",65,0) ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP "RTN","C0CRNFRP",66,0) ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" "RTN","C0CRNFRP",67,0) ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP "RTN","C0CRNFRP",68,0) ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE "RTN","C0CRNFRP",69,0) ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP "RTN","C0CRNFRP",70,0) ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP "RTN","C0CRNFRP",71,0) ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE "RTN","C0CRNFRP",72,0) ; IF GREF IS "" THE FIRST RECORD IS OBTAINED "RTN","C0CRNFRP",73,0) ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE "RTN","C0CRNFRP",74,0) ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN "RTN","C0CRNFRP",75,0) ; GREF IS THE VALUE FOR THE INDEX "RTN","C0CRNFRP",76,0) ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED "RTN","C0CRNFRP",77,0) ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN "RTN","C0CRNFRP",78,0) ; "RTN","C0CRNFRP",79,0) ; "RTN","C0CRNFRP",80,0) ;RETURN FORMAT: "RTN","C0CRNFRP",81,0) ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)" "RTN","C0CRNFRP",82,0) ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)" "RTN","C0CRNFRP",83,0) ; "RTN","C0CRNFRP",84,0) ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: "RTN","C0CRNFRP",85,0) ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268" "RTN","C0CRNFRP",86,0) ;C0CRNFGETN("1U4N")="2^.0905^H5369" "RTN","C0CRNFRP",87,0) ;C0CRNFGETN("1U4N","I")="^^H5369" "RTN","C0CRNFRP",88,0) ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26" "RTN","C0CRNFRP",89,0) ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326" "RTN","C0CRNFRP",90,0) ; "RTN","C0CRNFRP",91,0) ;FORMAT APPEARS TO BE: "RTN","C0CRNFRP",92,0) ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ" "RTN","C0CRNFRP",93,0) ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE" "RTN","C0CRNFRP",94,0) ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE" "RTN","C0CRNFRP",95,0) ; "RTN","C0CRNFRP",96,0) ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON "RTN","C0CRNFRP",97,0) S DEBUG=0 "RTN","C0CRNFRP",98,0) ;SET RETURN VALUE "RTN","C0CRNFRP",99,0) S C0CGRTN=$NA(^TMP("C0CRNF",$J)) "RTN","C0CRNFRP",100,0) K @C0CGRTN "RTN","C0CRNFRP",101,0) ;RUN WRAPPED CALL "RTN","C0CRNFRP",102,0) D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN)) "RTN","C0CRNFRP",103,0) S J="" "RTN","C0CRNFRP",104,0) S I=1 "RTN","C0CRNFRP",105,0) ;FORMAT RETURN "RTN","C0CRNFRP",106,0) F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY "RTN","C0CRNFRP",107,0) . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE "RTN","C0CRNFRP",108,0) . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE "RTN","C0CRNFRP",109,0) . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA "RTN","C0CRNFRP",110,0) . ;TEST TO SEE IF INTERNAL DATA EXISTS "RTN","C0CRNFRP",111,0) . I $D(C0CRTN(J,"I"))=1 D "RTN","C0CRNFRP",112,0) . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3 "RTN","C0CRNFRP",113,0) . S I=I+1 "RTN","C0CRNFRP",114,0) S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0) "RTN","C0CRNFRP",115,0) ;CLEAN UP "RTN","C0CRNFRP",116,0) K J,I "RTN","C0CRNFRP",117,0) Q "RTN","C0CRNFRP",118,0) ; "RTN","C0CRNFRP",119,0) GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP "RTN","C0CRNFRP",120,0) ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 "RTN","C0CRNFRP",121,0) ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL "RTN","C0CRNFRP",122,0) ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN "RTN","C0CRNFRP",123,0) ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP "RTN","C0CRNFRP",124,0) ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" "RTN","C0CRNFRP",125,0) ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP "RTN","C0CRNFRP",126,0) ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE "RTN","C0CRNFRP",127,0) ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE "RTN","C0CRNFRP",128,0) ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP "RTN","C0CRNFRP",129,0) ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP "RTN","C0CRNFRP",130,0) ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE "RTN","C0CRNFRP",131,0) ; IF GREF IS "" THE FIRST RECORD IS OBTAINED "RTN","C0CRNFRP",132,0) ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE "RTN","C0CRNFRP",133,0) ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN "RTN","C0CRNFRP",134,0) ; GREF IS THE VALUE FOR THE INDEX "RTN","C0CRNFRP",135,0) ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED "RTN","C0CRNFRP",136,0) ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN "RTN","C0CRNFRP",137,0) ; "RTN","C0CRNFRP",138,0) ; "RTN","C0CRNFRP",139,0) N GIEN,GF "RTN","C0CRNFRP",140,0) S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE "RTN","C0CRNFRP",141,0) I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN "RTN","C0CRNFRP",142,0) E D ; WE ARE USING AN INDEX "RTN","C0CRNFRP",143,0) . ;N ZG "RTN","C0CRNFRP",144,0) . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX "RTN","C0CRNFRP",145,0) . I ZG'="" D ; "RTN","C0CRNFRP",146,0) . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? "RTN","C0CRNFRP",147,0) . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN "RTN","C0CRNFRP",148,0) . . E S GIEN="" ; NOT FOUND IN INDEX "RTN","C0CRNFRP",149,0) . E S GIEN="" ; "RTN","C0CRNFRP",150,0) ;W "IEN: ",GIEN,! "RTN","C0CRNFRP",151,0) ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME "RTN","C0CRNFRP",152,0) I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) "RTN","C0CRNFRP",153,0) E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) "RTN","C0CRNFRP",154,0) S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE "RTN","C0CRNFRP",155,0) D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP "RTN","C0CRNFRP",156,0) K C0CTMP "RTN","C0CRNFRP",157,0) D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") "RTN","C0CRNFRP",158,0) D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE "RTN","C0CRNFRP",159,0) S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE "RTN","C0CRNFRP",160,0) S (C0CI,C0CJ)="" "RTN","C0CRNFRP",161,0) F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES "RTN","C0CRNFRP",162,0) . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE "RTN","C0CRNFRP",163,0) . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS "RTN","C0CRNFRP",164,0) . . ;W C0CJ," ",C0CI,! "RTN","C0CRNFRP",165,0) . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME "RTN","C0CRNFRP",166,0) . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; "RTN","C0CRNFRP",167,0) . . I C0CVALUE["C0CTMP" D ; WP FIELD "RTN","C0CRNFRP",168,0) . . . N ZT,ZWP S ZWP=0 ;ITERATOR "RTN","C0CRNFRP",169,0) . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE "RTN","C0CRNFRP",170,0) . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE "RTN","C0CRNFRP",171,0) . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; "RTN","C0CRNFRP",172,0) . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP "RTN","C0CRNFRP",173,0) . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " "RTN","C0CRNFRP",174,0) . . . . S C0CVALUE=C0CVALUE_ZT ; "RTN","C0CRNFRP",175,0) . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 "RTN","C0CRNFRP",176,0) . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) "RTN","C0CRNFRP",177,0) I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED "RTN","C0CRNFRP",178,0) . S C0CI="" "RTN","C0CRNFRP",179,0) . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY "RTN","C0CRNFRP",180,0) . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES "RTN","C0CRNFRP",181,0) Q "RTN","C0CRNFRP",182,0) ; "RTN","C0CRNFRP",183,0) GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES "RTN","C0CRNFRP",184,0) ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP "RTN","C0CRNFRP",185,0) ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" "RTN","C0CRNFRP",186,0) ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP "RTN","C0CRNFRP",187,0) ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE "RTN","C0CRNFRP",188,0) ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES "RTN","C0CRNFRP",189,0) ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE "RTN","C0CRNFRP",190,0) ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP "RTN","C0CRNFRP",191,0) ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP "RTN","C0CRNFRP",192,0) ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE "RTN","C0CRNFRP",193,0) ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE "RTN","C0CRNFRP",194,0) ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN "RTN","C0CRNFRP",195,0) ; .. OF THE FILE WILL BE USED "RTN","C0CRNFRP",196,0) ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE "RTN","C0CRNFRP",197,0) ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED "RTN","C0CRNFRP",198,0) ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE "RTN","C0CRNFRP",199,0) ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD "RTN","C0CRNFRP",200,0) ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED "RTN","C0CRNFRP",201,0) ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL "RTN","C0CRNFRP",202,0) ;N GATMP,GAI,GAF "RTN","C0CRNFRP",203,0) S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE "RTN","C0CRNFRP",204,0) I '$D(GAIDX) S GAIDX="" ;DEFAULT "RTN","C0CRNFRP",205,0) I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED "RTN","C0CRNFRP",206,0) I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX "RTN","C0CRNFRP",207,0) W GAF,! "RTN","C0CRNFRP",208,0) W $O(@GAF@(0)) ; "RTN","C0CRNFRP",209,0) S GAI=0 ;ITERATOR "RTN","C0CRNFRP",210,0) F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; "RTN","C0CRNFRP",211,0) . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD "RTN","C0CRNFRP",212,0) . N GAX S GAX=0 "RTN","C0CRNFRP",213,0) . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS "RTN","C0CRNFRP",214,0) . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN "RTN","C0CRNFRP",215,0) Q "RTN","C0CRNFRP",216,0) ; "RTN","C0CRNFRP",217,0) ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX "RTN","C0CRNFRP",218,0) ; "RTN","C0CRNFRP",219,0) S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# "RTN","C0CRNFRP",220,0) S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE "RTN","C0CRNFRP",221,0) Q "RTN","C0CRNFRP",222,0) ; "RTN","C0CRNFRP",223,0) RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT "RTN","C0CRNFRP",224,0) ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES "RTN","C0CRNFRP",225,0) ; RNSTY IS STYLE OF THE OUTPUT - "RTN","C0CRNFRP",226,0) ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES "RTN","C0CRNFRP",227,0) ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES "RTN","C0CRNFRP",228,0) ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES "RTN","C0CRNFRP",229,0) N RNR,RNC ;ROW ROOT,COL ROOT "RTN","C0CRNFRP",230,0) N RNI,RNJ,RNX "RTN","C0CRNFRP",231,0) I '$D(RNSTY) S RNSTY="NV" ;DEFAULT "RTN","C0CRNFRP",232,0) I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION "RTN","C0CRNFRP",233,0) E D VN(RNRTN,RNIN) ; "RTN","C0CRNFRP",234,0) Q "RTN","C0CRNFRP",235,0) ; "RTN","C0CRNFRP",236,0) NV(RNRTN,RNIN) ; "RTN","C0CRNFRP",237,0) S RNR=$NA(@RNIN@("F")) "RTN","C0CRNFRP",238,0) S RNC=$NA(@RNIN@("V")) "RTN","C0CRNFRP",239,0) ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER "RTN","C0CRNFRP",240,0) S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" "RTN","C0CRNFRP",241,0) S RNI="" "RTN","C0CRNFRP",242,0) F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN "RTN","C0CRNFRP",243,0) . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA "RTN","C0CRNFRP",244,0) S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNFRP",245,0) D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS "RTN","C0CRNFRP",246,0) S RNI="" "RTN","C0CRNFRP",247,0) F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW "RTN","C0CRNFRP",248,0) . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD "RTN","C0CRNFRP",249,0) . S RNJ="" "RTN","C0CRNFRP",250,0) . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL "RTN","C0CRNFRP",251,0) . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN "RTN","C0CRNFRP",252,0) . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA "RTN","C0CRNFRP",253,0) . . E S RNX=RNX_"," ; NUL COLUMN "RTN","C0CRNFRP",254,0) . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNFRP",255,0) . D PUSH^GPLXPATH(RNRTN,RNX) "RTN","C0CRNFRP",256,0) Q "RTN","C0CRNFRP",257,0) ; "RTN","C0CRNFRP",258,0) VN(RNRTN,RNIN) ; "RTN","C0CRNFRP",259,0) S RNR=$NA(@RNIN@("V")) "RTN","C0CRNFRP",260,0) S RNC=$NA(@RNIN@("F")) "RTN","C0CRNFRP",261,0) ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER "RTN","C0CRNFRP",262,0) S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" "RTN","C0CRNFRP",263,0) S RNI="" "RTN","C0CRNFRP",264,0) F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN "RTN","C0CRNFRP",265,0) . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA "RTN","C0CRNFRP",266,0) S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNFRP",267,0) D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS "RTN","C0CRNFRP",268,0) S RNI="" "RTN","C0CRNFRP",269,0) F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW "RTN","C0CRNFRP",270,0) . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD "RTN","C0CRNFRP",271,0) . S RNJ="" "RTN","C0CRNFRP",272,0) . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL "RTN","C0CRNFRP",273,0) . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN "RTN","C0CRNFRP",274,0) . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA "RTN","C0CRNFRP",275,0) . . E S RNX=RNX_"," ; NUL COLUMN "RTN","C0CRNFRP",276,0) . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA "RTN","C0CRNFRP",277,0) . D PUSH^GPLXPATH(RNRTN,RNX) "RTN","C0CRNFRP",278,0) Q "RTN","C0CRNFRP",279,0) ; "RTN","C0CRNFRP",280,0) READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME "RTN","C0CRNFRP",281,0) ; "RTN","C0CRNFRP",282,0) Q $$FTG^%ZISH(PATH,NAME,GLB,1) "RTN","C0CRNFRP",283,0) ; "RTN","C0CRNFRP",284,0) FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV "RTN","C0CRNFRP",285,0) ; "RTN","C0CRNFRP",286,0) ;N G1,G2 "RTN","C0CRNFRP",287,0) I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE "RTN","C0CRNFRP",288,0) S G1=$NA(^TMP($J,"C0CCSV",1)) "RTN","C0CRNFRP",289,0) S G2=$NA(^TMP($J,"C0CCSV",2)) "RTN","C0CRNFRP",290,0) D GETN2(G1,FNUM) ; GET THE MATRIX "RTN","C0CRNFRP",291,0) D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE "RTN","C0CRNFRP",292,0) K @G1 "RTN","C0CRNFRP",293,0) D FILEOUT(G2,"FILE_"_FNUM_".csv") "RTN","C0CRNFRP",294,0) K @G2 "RTN","C0CRNFRP",295,0) Q "RTN","C0CRNFRP",296,0) ; "RTN","C0CRNFRP",297,0) FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE "RTN","C0CRNFRP",298,0) ; "RTN","C0CRNFRP",299,0) W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR")) "RTN","C0CRNFRP",300,0) Q "RTN","C0CRNFRP",301,0) ; "RTN","C0CRNFRP",302,0) FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM "RTN","C0CRNFRP",303,0) ; "RTN","C0CRNFRP",304,0) N C0CF "RTN","C0CRNFRP",305,0) S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE "RTN","C0CRNFRP",306,0) S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT "RTN","C0CRNFRP",307,0) I C0CF["()" S C0CF=$P(C0CF,"()",1) "RTN","C0CRNFRP",308,0) Q C0CF "RTN","C0CRNFRP",309,0) ; "RTN","C0CRNFRP",310,0) SKIP ; "RTN","C0CRNFRP",311,0) N TXT,DIERR "RTN","C0CRNFRP",312,0) S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") "RTN","C0CRNFRP",313,0) I $D(DIERR) D CLEAN^DILF Q "RTN","C0CRNFRP",314,0) W " report_text:",! ;Progress Note Text "RTN","C0CRNFRP",315,0) N LN S LN=0 "RTN","C0CRNFRP",316,0) F S LN=$O(TXT(LN)) Q:'LN D "RTN","C0CRNFRP",317,0) . W " text"_LN_": "_TXT(LN),! "RTN","C0CRNFRP",318,0) . Q "RTN","C0CRNFRP",319,0) Q "RTN","C0CRNFRP",320,0) ; "RTN","C0CRNFRP",321,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CRNFRP",322,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) "RTN","C0CRNFRP",323,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNFRP",324,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNFRP",325,0) Q $P(@ZTAB@(ZFN),"^",1) "RTN","C0CRNFRP",326,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CRNFRP",327,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) "RTN","C0CRNFRP",328,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNFRP",329,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNFRP",330,0) Q $P(@ZTAB@(ZFN),"^",2) "RTN","C0CRNFRP",331,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CRNFRP",332,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) "RTN","C0CRNFRP",333,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNFRP",334,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNFRP",335,0) Q $P($G(@ZTAB@(ZFN)),"^",3) "RTN","C0CRNFRP",336,0) ; "RTN","C0CRNFRP",337,0) ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED "RTN","C0CRNFRP",338,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) "RTN","C0CRNFRP",339,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CRNFRP",340,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CRNFRP",341,0) Q $P($G(@ZTAB@(ZFN,"I")),"^",3) "RTN","C0CRNFRP",342,0) ; "RTN","C0CRPMS") 0^54^B16300714 "RTN","C0CRPMS",1,0) C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09 14:33 "RTN","C0CRPMS",2,0) ;;0.1;CCDCCR;;JUL 16,2008;Build 1 "RTN","C0CRPMS",3,0) ;Copyright 2008 George Lilly. Licensed under the terms of the GNU "RTN","C0CRPMS",4,0) ;General Public License See attached copy of the License. "RTN","C0CRPMS",5,0) ; "RTN","C0CRPMS",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CRPMS",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CRPMS",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CRPMS",9,0) ;(at your option) any later version. "RTN","C0CRPMS",10,0) ; "RTN","C0CRPMS",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CRPMS",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CRPMS",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CRPMS",14,0) ;GNU General Public License for more details. "RTN","C0CRPMS",15,0) ; "RTN","C0CRPMS",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CRPMS",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CRPMS",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CRPMS",19,0) ; "RTN","C0CRPMS",20,0) W "NO ENTRY FROM TOP",! "RTN","C0CRPMS",21,0) Q "RTN","C0CRPMS",22,0) ; "RTN","C0CRPMS",23,0) DISPLAY ; RUN THE PCC DISPLAY ROUTINE "RTN","C0CRPMS",24,0) D ^APCDDISP "RTN","C0CRPMS",25,0) Q "RTN","C0CRPMS",26,0) ; "RTN","C0CRPMS",27,0) VTYPES ; "RTN","C0CRPMS",28,0) D GETN2^C0CRNF("G1",9999999.07) "RTN","C0CRPMS",29,0) ZWR G1 "RTN","C0CRPMS",30,0) Q "RTN","C0CRPMS",31,0) ; "RTN","C0CRPMS",32,0) VISITS(C0CDFN,C0CCNT) ;LIST VISIT DATES FOR PATIENT DFN "RTN","C0CRPMS",33,0) ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL "RTN","C0CRPMS",34,0) I '$D(C0CCNT) S C0CCNT=999999999 "RTN","C0CRPMS",35,0) N G,GN "RTN","C0CRPMS",36,0) S G="" S GN=0 "RTN","C0CRPMS",37,0) F S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT) D ; "RTN","C0CRPMS",38,0) . S GN=GN+1 "RTN","C0CRPMS",39,0) . W $$FMDTOUTC^C0CUTIL(9999999-G),! "RTN","C0CRPMS",40,0) Q "RTN","C0CRPMS",41,0) ; "RTN","C0CRPMS",42,0) VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV "RTN","C0CRPMS",43,0) ; "RTN","C0CRPMS",44,0) N C0CG,GN "RTN","C0CRPMS",45,0) S C0CG="" "RTN","C0CRPMS",46,0) S GN=0 "RTN","C0CRPMS",47,0) I '$D(C0CCNT) S C0CCNT=99999999 "RTN","C0CRPMS",48,0) F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN "RTN","C0CSNOA",116,0) . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS "RTN","C0CSNOA",117,0) . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES "RTN","C0CSNOA",118,0) . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES "RTN","C0CSNOA",119,0) D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED "RTN","C0CSNOA",120,0) ; W "ATTRIBUTES: ",SATTR,! "RTN","C0CSNOA",121,0) Q SATTR "RTN","C0CSNOA",122,0) ; "RTN","C0CSNOA",123,0) RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES "RTN","C0CSNOA",124,0) K ^TMP("C0CSNO","RESUME") "RTN","C0CSNOA",125,0) K ^TMP("C0CSNO") "RTN","C0CSNOA",126,0) Q "RTN","C0CSNOA",127,0) ; "RTN","C0CSNOA",128,0) CLIST ; LIST THE CATEGORIES "RTN","C0CSNOA",129,0) ; "RTN","C0CSNOA",130,0) I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","C0CSNOA",131,0) N CLBASE,CLNUM,ZI,CLIDX "RTN","C0CSNOA",132,0) S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) "RTN","C0CSNOA",133,0) S CLNUM=@CLBASE@(0) "RTN","C0CSNOA",134,0) F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES "RTN","C0CSNOA",135,0) . S CLIDX=@CLBASE@(ZI) "RTN","C0CSNOA",136,0) . W "(",$P(@CLBASE@(CLIDX),"^",1) "RTN","C0CSNOA",137,0) . W ":",$P(@CLBASE@(CLIDX),"^",2),") " "RTN","C0CSNOA",138,0) . W CLIDX,! "RTN","C0CSNOA",139,0) ; D PARY^C0CXPATH(CLBASE) "RTN","C0CSNOA",140,0) Q "RTN","C0CSNOA",141,0) ; "RTN","C0CSNOA",142,0) CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES "RTN","C0CSNOA",143,0) ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT "RTN","C0CSNOA",144,0) ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE "RTN","C0CSNOA",145,0) ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME "RTN","C0CSNOA",146,0) ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, "RTN","C0CSNOA",147,0) ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" "RTN","C0CSNOA",148,0) ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES "RTN","C0CSNOA",149,0) ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY "RTN","C0CSNOA",150,0) ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING "RTN","C0CSNOA",151,0) ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY "RTN","C0CSNOA",152,0) ; NUMBER IE CTBL_X(CDFN)="" "RTN","C0CSNOA",153,0) ; "RTN","C0CSNOA",154,0) ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST "RTN","C0CSNOA",155,0) S CCTBL=$NA(@CBASE@(CTBL,"CATS")) "RTN","C0CSNOA",156,0) ; W "CBASE: ",CCTBL,! "RTN","C0CSNOA",157,0) ; "RTN","C0CSNOA",158,0) I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY "RTN","C0CSNOA",159,0) . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY "RTN","C0CSNOA",160,0) . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY "RTN","C0CSNOA",161,0) . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT "RTN","C0CSNOA",162,0) . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY "RTN","C0CSNOA",163,0) . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME "RTN","C0CSNOA",164,0) . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 "RTN","C0CSNOA",165,0) ; "RTN","C0CSNOA",166,0) S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY "RTN","C0CSNOA",167,0) S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT "RTN","C0CSNOA",168,0) S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK "RTN","C0CSNOA",169,0) ; "RTN","C0CSNOA",170,0) S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED "RTN","C0CSNOA",171,0) ; "RTN","C0CSNOA",172,0) S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT "RTN","C0CSNOA",173,0) ; W "IENS BASE: ",CPATLIST,! "RTN","C0CSNOA",174,0) S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST "RTN","C0CSNOA",175,0) ; "RTN","C0CSNOA",176,0) Q "RTN","C0CSNOA",177,0) ; "RTN","C0CSNOA",178,0) REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE "RTN","C0CSNOA",179,0) ; "RTN","C0CSNOA",180,0) D ASETUP "RTN","C0CSNOA",181,0) D AINIT "RTN","C0CSNOA",182,0) N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH "RTN","C0CSNOA",183,0) S SAVBASE=$NA(^TMP("C0CSAV","VARS")) "RTN","C0CSNOA",184,0) S SNOI="" "RTN","C0CSNOA",185,0) F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST "RTN","C0CSNOA",186,0) . S SNOI=$O(@SAVBASE@(SNOI)) "RTN","C0CSNOA",187,0) . S SNOJ=@SAVBASE@(SNOI) "RTN","C0CSNOA",188,0) . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) "RTN","C0CSNOA",189,0) . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE "RTN","C0CSNOA",190,0) . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON "RTN","C0CSNOA",191,0) . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE "RTN","C0CSNOA",192,0) . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE "RTN","C0CSNOA",193,0) . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE "RTN","C0CSNOA",194,0) . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! "RTN","C0CSNOA",195,0) . W SNOK,! "RTN","C0CSNOA",196,0) . W SNOJ,! "RTN","C0CSNOA",197,0) Q "RTN","C0CSNOA",198,0) ; "RTN","C0CSOAP") 0^58^B79899662 "RTN","C0CSOAP",1,0) C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 "RTN","C0CSOAP",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CSOAP",3,0) ;Copyright 2008 George Lilly. Licensed under the terms of the GNU "RTN","C0CSOAP",4,0) ;General Public License See attached copy of the License. "RTN","C0CSOAP",5,0) ; "RTN","C0CSOAP",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CSOAP",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CSOAP",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CSOAP",9,0) ;(at your option) any later version. "RTN","C0CSOAP",10,0) ; "RTN","C0CSOAP",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CSOAP",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CSOAP",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CSOAP",14,0) ;GNU General Public License for more details. "RTN","C0CSOAP",15,0) ; "RTN","C0CSOAP",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CSOAP",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CSOAP",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CSOAP",19,0) ; "RTN","C0CSOAP",20,0) W "This is an SOAP utility library",! "RTN","C0CSOAP",21,0) W ! "RTN","C0CSOAP",22,0) Q "RTN","C0CSOAP",23,0) ; "RTN","C0CSOAP",24,0) TEST1 "RTN","C0CSOAP",25,0) S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl" "RTN","C0CSOAP",26,0) D GET1URL^C0CEWD2(url) "RTN","C0CSOAP",27,0) Q "RTN","C0CSOAP",28,0) ; "RTN","C0CSOAP",29,0) INITFARY(ARY) ;initialize the Fileman Field array for SOAP processing "RTN","C0CSOAP",30,0) ; ARY is passed by name "RTN","C0CSOAP",31,0) S @ARY@("XML FILE NUMBER")="178.301" "RTN","C0CSOAP",32,0) S @ARY@("BINDING SUBFILE NUMBER")="178.3014" "RTN","C0CSOAP",33,0) S @ARY@("MIME TYPE")="2.3" "RTN","C0CSOAP",34,0) S @ARY@("PROXY SERVER")="2.4" "RTN","C0CSOAP",35,0) S @ARY@("REPLY TEMPLATE")=".03" "RTN","C0CSOAP",36,0) S @ARY@("TEMPLATE NAME")=".01" "RTN","C0CSOAP",37,0) S @ARY@("TEMPLATE XML")="3" "RTN","C0CSOAP",38,0) S @ARY@("URL")="1" "RTN","C0CSOAP",39,0) S @ARY@("WSDL URL")="2" "RTN","C0CSOAP",40,0) S @ARY@("XML")="2.1" "RTN","C0CSOAP",41,0) S @ARY@("XML HEADER")="2.2" "RTN","C0CSOAP",42,0) S @ARY@("XPATH REDUCTION STRING")="2.5" "RTN","C0CSOAP",43,0) S @ARY@("CCR VARIABLE")="4" "RTN","C0CSOAP",44,0) S @ARY@("FILEMAN FIELD NAME")="1" "RTN","C0CSOAP",45,0) S @ARY@("FILEMAN FIELD NUMBER")="1.2" "RTN","C0CSOAP",46,0) S @ARY@("FILEMAN FILE POINTER")="1.1" "RTN","C0CSOAP",47,0) S @ARY@("INDEXED BY")=".05" "RTN","C0CSOAP",48,0) S @ARY@("SQLI FIELD NAME")="3" "RTN","C0CSOAP",49,0) S @ARY@("VARIABLE NAME")="2" "RTN","C0CSOAP",50,0) Q "RTN","C0CSOAP",51,0) ; "RTN","C0CSOAP",52,0) RESTID(INNAM,INFARY) ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME "RTN","C0CSOAP",53,0) ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME "RTN","C0CSOAP",54,0) I '$D(INFARY) D ; NO FILE ARRAY PASSED "RTN","C0CSOAP",55,0) . S INFARY="FARY" "RTN","C0CSOAP",56,0) . D INITFARY(INFARY) "RTN","C0CSOAP",57,0) N ZN,ZREF,ZR "RTN","C0CSOAP",58,0) S ZN=@INFARY@("XML FILE NUMBER") "RTN","C0CSOAP",59,0) S ZREF=$$FILEREF^C0CRNF(ZN) "RTN","C0CSOAP",60,0) S ZR=$O(@ZREF@("B",INNAM,"")) "RTN","C0CSOAP",61,0) Q ZR "RTN","C0CSOAP",62,0) ; "RTN","C0CSOAP",63,0) TESTSOAP ; "RTN","C0CSOAP",64,0) ; USING ICD9 WEB SERVICE TO TEST SOAP "RTN","C0CSOAP",65,0) S G("CODE")="E*" "RTN","C0CSOAP",66,0) S G("CODELN")=3 "RTN","C0CSOAP",67,0) D SOAP("GPL","ICD9","G") "RTN","C0CSOAP",68,0) Q "RTN","C0CSOAP",69,0) ; "RTN","C0CSOAP",70,0) SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) ; MAKES A SOAP CALL FOR "RTN","C0CSOAP",71,0) ; TEMPLATE ID C0CTID "RTN","C0CSOAP",72,0) ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME "RTN","C0CSOAP",73,0) ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND "RTN","C0CSOAP",74,0) ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED "RTN","C0CSOAP",75,0) ; BEFORE MAPPING "RTN","C0CSOAP",76,0) ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND "RTN","C0CSOAP",77,0) ; ALTXML WILL BE USED INSTEAD "RTN","C0CSOAP",78,0) ; "RTN","C0CSOAP",79,0) ; ARTIFACTS SECTION "RTN","C0CSOAP",80,0) ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE "RTN","C0CSOAP",81,0) ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS "RTN","C0CSOAP",82,0) ; WILL NOT BE NEWED. "RTN","C0CSOAP",83,0) I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS "RTN","C0CSOAP",84,0) S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")="" "RTN","C0CSOAP",85,0) S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")="" "RTN","C0CSOAP",86,0) S C0CV(300,"HEADER","SOAP HEADER")="" "RTN","C0CSOAP",87,0) S C0CV(400,"C0CMIME","MIME TYPE")="" "RTN","C0CSOAP",88,0) S C0CV(500,"C0CURL","WS URL")="" "RTN","C0CSOAP",89,0) S C0CV(550,"C0CPURL","PROXY URL")="" "RTN","C0CSOAP",90,0) S C0CV(600,"C0CXML","XML VARIABLE NAME")="" "RTN","C0CSOAP",91,0) S C0CV(700,"XML","OUTBOUND XML")="" "RTN","C0CSOAP",92,0) S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")="" "RTN","C0CSOAP",93,0) S C0CV(900,"C0CRHDR","RETURNED HEADER")="" "RTN","C0CSOAP",94,0) S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")="" "RTN","C0CSOAP",95,0) S C0CV(1100,"C0CR","REPLY TEMPLATE")="" "RTN","C0CSOAP",96,0) S C0CV(1200,"C0CREDUX","REDUX STRING")="" "RTN","C0CSOAP",97,0) S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")="" "RTN","C0CSOAP",98,0) S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")="" "RTN","C0CSOAP",99,0) S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")="" "RTN","C0CSOAP",100,0) S C0CV(1600,"C0CID","RESULT DOM ID")="" "RTN","C0CSOAP",101,0) I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG "RTN","C0CSOAP",102,0) N ZI,ZJ S ZI="" "RTN","C0CSOAP",103,0) NEW "RTN","C0CSOAP",104,0) S ZI=$O(C0CV(ZI)) "RTN","C0CSOAP",105,0) S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND "RTN","C0CSOAP",106,0) ;W ZJ,! "RTN","C0CSOAP",107,0) N @ZJ ; NEW THE VARIABLE "RTN","C0CSOAP",108,0) I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT "RTN","C0CSOAP",109,0) NOTNEW "RTN","C0CSOAP",110,0) ; END ARTIFACTS "RTN","C0CSOAP",111,0) ; "RTN","C0CSOAP",112,0) I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS "RTN","C0CSOAP",113,0) E D ; "RTN","C0CSOAP",114,0) . K C0CF "RTN","C0CSOAP",115,0) . M C0CF=@IFARY "RTN","C0CSOAP",116,0) S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE "RTN","C0CSOAP",117,0) I +C0CTID=0 D ; A STRING WAS PASSED FOR THE TEMPLATE NAME "RTN","C0CSOAP",118,0) . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME "RTN","C0CSOAP",119,0) E S C0CUTID=C0CTID ; AN IEN WAS PASSED "RTN","C0CSOAP",120,0) N XML,TEMPLATE,HEADER "RTN","C0CSOAP",121,0) N C0CFH S C0CFH=C0CF("XML HEADER") "RTN","C0CSOAP",122,0) S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER") "RTN","C0CSOAP",123,0) N C0CFM S C0CFM=C0CF("MIME TYPE") "RTN","C0CSOAP",124,0) S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM) "RTN","C0CSOAP",125,0) N C0CFP S C0CFP=C0CF("PROXY SERVER") "RTN","C0CSOAP",126,0) S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP) "RTN","C0CSOAP",127,0) N C0CFU S C0CFU=C0CF("URL") "RTN","C0CSOAP",128,0) S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU) "RTN","C0CSOAP",129,0) N C0CFX S C0CFX=C0CF("XML") "RTN","C0CSOAP",130,0) S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML") "RTN","C0CSOAP",131,0) N C0CFT S C0CFT=C0CF("TEMPLATE XML") "RTN","C0CSOAP",132,0) S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE") "RTN","C0CSOAP",133,0) I C0CTMPL="TEMPLATE" D ; there is a template to process "RTN","C0CSOAP",134,0) . K XML ; going to replace the xml array "RTN","C0CSOAP",135,0) . N VARS "RTN","C0CSOAP",136,0) . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides "RTN","C0CSOAP",137,0) . I '$D(ALTXML) D ; if ALTXML is passed in, don't bind "RTN","C0CSOAP",138,0) . . D BIND("VARS",C0CVA,C0CUTID,"C0CF") "RTN","C0CSOAP",139,0) . . D MAP("XML","VARS",TPTR,"C0CF") "RTN","C0CSOAP",140,0) . . K XML(0) "RTN","C0CSOAP",141,0) . E M XML=@ALTXML ; use ALTXML instead "RTN","C0CSOAP",142,0) I $G(C0CPROXY) S C0CURL=C0CPURL "RTN","C0CSOAP",143,0) K C0CRSLT,C0CRHDR "RTN","C0CSOAP",144,0) B "RTN","C0CSOAP",145,0) S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR) "RTN","C0CSOAP",146,0) K C0CRXML "RTN","C0CSOAP",147,0) D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY "RTN","C0CSOAP",148,0) N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE")) "RTN","C0CSOAP",149,0) S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE "RTN","C0CSOAP",150,0) ; reply templates are optional and are specified by populating a "RTN","C0CSOAP",151,0) ; template pointer in field 2.5 of the request template "RTN","C0CSOAP",152,0) ; if specified, the reply template is the source of the REDUX string "RTN","C0CSOAP",153,0) ; used for XPath on the reply, and for UNBIND processing "RTN","C0CSOAP",154,0) ; if no reply template is specified, REDUX is obtained from the request "RTN","C0CSOAP",155,0) ; template and no UNBIND processing is performed. The XPath array is "RTN","C0CSOAP",156,0) ; returned without variable bindings "RTN","C0CSOAP",157,0) I C0CR'="" D ; REPLY TEMPLATE EXISTS "RTN","C0CSOAP",158,0) . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,! "RTN","C0CSOAP",159,0) . S C0CTID=C0CR ; "RTN","C0CSOAP",160,0) N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING") "RTN","C0CSOAP",161,0) S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING "RTN","C0CSOAP",162,0) K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS "RTN","C0CSOAP",163,0) S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM "RTN","C0CSOAP",164,0) S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER "RTN","C0CSOAP",165,0) S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE "RTN","C0CSOAP",166,0) D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR "RTN","C0CSOAP",167,0) ; Next, call UNBIND to map the reply XPath array to variables "RTN","C0CSOAP",168,0) ; This is only done if a Reply Template is provided "RTN","C0CSOAP",169,0) D DEMUXARY(C0CRTN,"C0CARY") "RTN","C0CSOAP",170,0) ; M @C0CRTN=C0CARY "RTN","C0CSOAP",171,0) Q "RTN","C0CSOAP",172,0) ; "RTN","C0CSOAP",173,0) DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO "RTN","C0CSOAP",174,0) ; FORMAT @OARY@(x,xpath) where x is the first multiple "RTN","C0CSOAP",175,0) N ZI,ZJ,ZK,ZL S ZI="" "RTN","C0CSOAP",176,0) F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; "RTN","C0CSOAP",177,0) . D DEMUX^C0CMXP("ZJ",ZI) "RTN","C0CSOAP",178,0) . S ZK=$P(ZJ,"^",3) "RTN","C0CSOAP",179,0) . S ZK=$RE($P($RE(ZK),"/",1)) "RTN","C0CSOAP",180,0) . S ZL=$P(ZJ,"^",1) "RTN","C0CSOAP",181,0) . I ZL="" S ZL=1 "RTN","C0CSOAP",182,0) . S @OARY@(ZL,ZK)=@IARY@(ZI) "RTN","C0CSOAP",183,0) Q "RTN","C0CSOAP",184,0) ; "RTN","C0CSOAP",185,0) NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML "RTN","C0CSOAP",186,0) ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME "RTN","C0CSOAP",187,0) ; "RTN","C0CSOAP",188,0) N ZI,ZN,ZTMP "RTN","C0CSOAP",189,0) S ZN=1 "RTN","C0CSOAP",190,0) S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" "RTN","C0CSOAP",191,0) S ZN=ZN+1 "RTN","C0CSOAP",192,0) F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; "RTN","C0CSOAP",193,0) . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" "RTN","C0CSOAP",194,0) . S ZN=ZN+1 "RTN","C0CSOAP",195,0) Q "RTN","C0CSOAP",196,0) ; "RTN","C0CSOAP",197,0) MAP(RARY,IVARS,TPTR,INFARY) ;RETURNS MAPPED XML IN RARY PASSED BY NAME "RTN","C0CSOAP",198,0) ; IVARS IS AN XPATH ARRAY PASSED BY NAME "RTN","C0CSOAP",199,0) ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE "RTN","C0CSOAP",200,0) ; "RTN","C0CSOAP",201,0) N ZT ;THE TEMPLATE "RTN","C0CSOAP",202,0) K ZT,@RARY "RTN","C0CSOAP",203,0) I '$D(INFARY) D ; "RTN","C0CSOAP",204,0) . S INFARY="FARY" "RTN","C0CSOAP",205,0) . D INITFARY(INFARY) "RTN","C0CSOAP",206,0) N ZF,ZFT "RTN","C0CSOAP",207,0) S ZF=@INFARY@("XML FILE NUMBER") "RTN","C0CSOAP",208,0) S ZFT=@INFARY@("TEMPLATE XML") "RTN","C0CSOAP",209,0) I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D Q ; ERROR GETTING TEMPLATE "RTN","C0CSOAP",210,0) . W "ERROR RETRIEVING TEMPLATE",! "RTN","C0CSOAP",211,0) D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING "RTN","C0CSOAP",212,0) Q "RTN","C0CSOAP",213,0) ; "RTN","C0CSOAP",214,0) TESTBIND ; "RTN","C0CSOAP",215,0) S G1("TESTONE")=1 "RTN","C0CSOAP",216,0) S G1("TESTTWO")=2 "RTN","C0CSOAP",217,0) D BIND("G","G1","TEST") "RTN","C0CSOAP",218,0) W ! "RTN","C0CSOAP",219,0) ZWR G "RTN","C0CSOAP",220,0) Q "RTN","C0CSOAP",221,0) ; "RTN","C0CSOAP",222,0) BIND(RARY,IVARS,INTPTR,INFARY) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP "RTN","C0CSOAP",223,0) ; TO BUILD AN INSTANTIATED TEMPLATE "RTN","C0CSOAP",224,0) ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE "RTN","C0CSOAP",225,0) ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND "RTN","C0CSOAP",226,0) ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES "RTN","C0CSOAP",227,0) ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME "RTN","C0CSOAP",228,0) I '$D(INFARY) D ; "RTN","C0CSOAP",229,0) . S INFARY="FARY" "RTN","C0CSOAP",230,0) . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED "RTN","C0CSOAP",231,0) I +INTPTR>0 S TPTR=INTPTR "RTN","C0CSOAP",232,0) E S TPTR=$$RESTID(INTPTR,INFARY) "RTN","C0CSOAP",233,0) N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF "RTN","C0CSOAP",234,0) S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file "RTN","C0CSOAP",235,0) S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file "RTN","C0CSOAP",236,0) S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER "RTN","C0CSOAP",237,0) S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings "RTN","C0CSOAP",238,0) I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index "RTN","C0CSOAP",239,0) ; this needs to be a whole file index on the XPath subfile with "RTN","C0CSOAP",240,0) ; the Template IEN perceding the XPath in the index "RTN","C0CSOAP",241,0) N ZI "RTN","C0CSOAP",242,0) S ZI="" "RTN","C0CSOAP",243,0) S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is "RTN","C0CSOAP",244,0) ;F S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI="" D ; FOR EACH XPATH "RTN","C0CSOAP",245,0) F S ZI=$O(@C0CXREF@(ZI)) Q:ZI="" D ; for each XPath in this template "RTN","C0CSOAP",246,0) . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,"")) "RTN","C0CSOAP",247,0) . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ; "RTN","C0CSOAP",248,0) . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD "RTN","C0CSOAP",249,0) . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER") "RTN","C0CSOAP",250,0) . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I") "RTN","C0CSOAP",251,0) . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER") "RTN","C0CSOAP",252,0) . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I") "RTN","C0CSOAP",253,0) . N ZFV S ZFV=@INFARY@("VARIABLE NAME") "RTN","C0CSOAP",254,0) . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E") "RTN","C0CSOAP",255,0) . N ZFX S ZFX=("INDEXED BY") "RTN","C0CSOAP",256,0) . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I") "RTN","C0CSOAP",257,0) . S ZINDEX="" "RTN","C0CSOAP",258,0) . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ "RTN","C0CSOAP",259,0) . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN "RTN","C0CSOAP",260,0) . E I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable "RTN","C0CSOAP",261,0) . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT "RTN","C0CSOAP",262,0) . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION "RTN","C0CSOAP",263,0) . I ZVAR'="" D ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS "RTN","C0CSOAP",264,0) . . S @RARY@(ZI)=@IVARS@(ZVAR) ; "RTN","C0CSOAP",265,0) . E D ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN "RTN","C0CSOAP",266,0) . . I (ZFILE="")!(ZFIELD="") Q ;QUIT IF FILE OR FIELD NOT THERE "RTN","C0CSOAP",267,0) . . D CLEAN^DILF "RTN","C0CSOAP",268,0) . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE "RTN","C0CSOAP",269,0) . . I $D(^TMP("DIERR",$J,1)) D B ; "RTN","C0CSOAP",270,0) . . . W "ERROR!",! "RTN","C0CSOAP",271,0) . . . ZWR ^TMP("DIERR",$J,*) "RTN","C0CSOAP",272,0) Q "RTN","C0CSOAP",273,0) ; "RTN","C0CSUB1") 0^59^B16280924 "RTN","C0CSUB1",1,0) C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 "RTN","C0CSUB1",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CSUB1",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CSUB1",4,0) ;General Public License See attached copy of the License. "RTN","C0CSUB1",5,0) ; "RTN","C0CSUB1",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CSUB1",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CSUB1",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CSUB1",9,0) ;(at your option) any later version. "RTN","C0CSUB1",10,0) ; "RTN","C0CSUB1",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CSUB1",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CSUB1",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CSUB1",14,0) ;GNU General Public License for more details. "RTN","C0CSUB1",15,0) ; "RTN","C0CSUB1",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CSUB1",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CSUB1",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CSUB1",19,0) ; "RTN","C0CSUB1",20,0) W "This is the CCR SUBSCRIPTIONN Utility Library ",! "RTN","C0CSUB1",21,0) Q "RTN","C0CSUB1",22,0) ; "RTN","C0CSUB1",23,0) CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT "RTN","C0CSUB1",24,0) ; "RTN","C0CSUB1",25,0) S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM")) "RTN","C0CSUB1",26,0) S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE "RTN","C0CSUB1",27,0) S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE "RTN","C0CSUB1",28,0) S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE "RTN","C0CSUB1",29,0) S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS "RTN","C0CSUB1",30,0) S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT "RTN","C0CSUB1",31,0) K C0CFDA "RTN","C0CSUB1",32,0) S C0CALL=$G(@C0CCHK@(DFN,"ALL")) "RTN","C0CSUB1",33,0) I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL "RTN","C0CSUB1",34,0) E Q ; NO CHECKSUMS FOR THISPATIENT "RTN","C0CSUB1",35,0) D UPDIE "RTN","C0CSUB1",36,0) N C0CJ S C0CJ="" "RTN","C0CSUB1",37,0) F S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ="" D ; FOR EACH DOMAIN "RTN","C0CSUB1",38,0) . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) "RTN","C0CSUB1",39,0) . W C0CJ," ",C0CD,! "RTN","C0CSUB1",40,0) . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD "RTN","C0CSUB1",41,0) . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ) "RTN","C0CSUB1",42,0) . D UPDIE "RTN","C0CSUB1",43,0) Q "RTN","C0CSUB1",44,0) ; "RTN","C0CSUB1",45,0) SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1 "RTN","C0CSUB1",46,0) ; "RTN","C0CSUB1",47,0) S C0CGLB=$NA(^TMP("C0CRIM","VARS")) "RTN","C0CSUB1",48,0) S C0CI="" "RTN","C0CSUB1",49,0) F S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI="" D ; FOR EACH PATIENT "RTN","C0CSUB1",50,0) . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN "RTN","C0CSUB1",51,0) Q "RTN","C0CSUB1",52,0) ; "RTN","C0CSUB1",53,0) SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS "RTN","C0CSUB1",54,0) ; "RTN","C0CSUB1",55,0) S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE "RTN","C0CSUB1",56,0) S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE "RTN","C0CSUB1",57,0) S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS "RTN","C0CSUB1",58,0) S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE "RTN","C0CSUB1",59,0) K C0CFDA "RTN","C0CSUB1",60,0) S C0CFDA(C0CSF,"+1,",.01)=DFN "RTN","C0CSUB1",61,0) D UPDIE ; ADD THE PATIENT "RTN","C0CSUB1",62,0) S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT "RTN","C0CSUB1",63,0) S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER "RTN","C0CSUB1",64,0) D UPDIE ; ADD THE SUBSCRIPTION "RTN","C0CSUB1",65,0) D CHK1(DFN) ; ADD THE CHECKSUMS "RTN","C0CSUB1",66,0) Q "RTN","C0CSUB1",67,0) ; "RTN","C0CSUB1",68,0) UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS "RTN","C0CSUB1",69,0) K ZERR "RTN","C0CSUB1",70,0) D CLEAN^DILF "RTN","C0CSUB1",71,0) D UPDATE^DIE("","C0CFDA","","ZERR") "RTN","C0CSUB1",72,0) I $D(ZERR) D ; "RTN","C0CSUB1",73,0) . W "ERROR",! "RTN","C0CSUB1",74,0) . ZWR ZERR "RTN","C0CSUB1",75,0) . B "RTN","C0CSUB1",76,0) K C0CFDA "RTN","C0CSUB1",77,0) Q "RTN","C0CSUB1",78,0) ; "RTN","C0CSUB1",79,0) VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE "RTN","C0CSUB1",80,0) ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO "RTN","C0CSUB1",81,0) ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO "RTN","C0CSUB1",82,0) ; "RTN","C0CSUB1",83,0) N ZCCRD,ZVARN,C0CFDA2 "RTN","C0CSUB1",84,0) S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY "RTN","C0CSUB1",85,0) S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CSUB1",86,0) I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT "RTN","C0CSUB1",87,0) . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE "RTN","C0CSUB1",88,0) . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! "RTN","C0CSUB1",89,0) . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE "RTN","C0CSUB1",90,0) . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE "RTN","C0CSUB1",91,0) . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN "RTN","C0CSUB1",92,0) . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY "RTN","C0CSUB1",93,0) . I $D(ZERR) D ; LAYGO ERROR "RTN","C0CSUB1",94,0) . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! "RTN","C0CSUB1",95,0) . E D ; "RTN","C0CSUB1",96,0) . . D CLEAN^DILF ; CLEAN UP "RTN","C0CSUB1",97,0) . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE "RTN","C0CSUB1",98,0) . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! "RTN","C0CSUB1",99,0) Q ZVARN "RTN","C0CSUB1",100,0) ; "RTN","C0CSUB1",101,0) SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN "RTN","C0CSUB1",102,0) ; TO SET TO VALUE C0CSV. "RTN","C0CSUB1",103,0) ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE "RTN","C0CSUB1",104,0) ; C0CSN,C0CSV ARE PASSED BY VALUE "RTN","C0CSUB1",105,0) ; "RTN","C0CSUB1",106,0) N C0CSI,C0CSJ "RTN","C0CSUB1",107,0) S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER "RTN","C0CSUB1",108,0) S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER "RTN","C0CSUB1",109,0) S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV "RTN","C0CSUB1",110,0) Q "RTN","C0CSUB1",111,0) ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED "RTN","C0CSUB1",112,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) "RTN","C0CSUB1",113,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CSUB1",114,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CSUB1",115,0) N ZR "RTN","C0CSUB1",116,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) "RTN","C0CSUB1",117,0) E S ZR="" "RTN","C0CSUB1",118,0) Q ZR "RTN","C0CSUB1",119,0) ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED "RTN","C0CSUB1",120,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) "RTN","C0CSUB1",121,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CSUB1",122,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CSUB1",123,0) N ZR "RTN","C0CSUB1",124,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) "RTN","C0CSUB1",125,0) E S ZR="" "RTN","C0CSUB1",126,0) Q ZR "RTN","C0CSUB1",127,0) ; "RTN","C0CSUB1",128,0) ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED "RTN","C0CSUB1",129,0) ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) "RTN","C0CSUB1",130,0) ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA "RTN","C0CSUB1",131,0) I '$D(ZTAB) S ZTAB="C0CA" "RTN","C0CSUB1",132,0) N ZR "RTN","C0CSUB1",133,0) I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) "RTN","C0CSUB1",134,0) E S ZR="" "RTN","C0CSUB1",135,0) Q ZR "RTN","C0CSUB1",136,0) ; "RTN","C0CSYS") 0^60^B3933593 "RTN","C0CSYS",1,0) C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 "RTN","C0CSYS",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CSYS",3,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","C0CSYS",4,0) ; General Public License See attached copy of the License. "RTN","C0CSYS",5,0) ; "RTN","C0CSYS",6,0) ; This program is free software; you can redistribute it and/or modify "RTN","C0CSYS",7,0) ; it under the terms of the GNU General Public License as published by "RTN","C0CSYS",8,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","C0CSYS",9,0) ; (at your option) any later version. "RTN","C0CSYS",10,0) ; "RTN","C0CSYS",11,0) ; This program is distributed in the hope that it will be useful, "RTN","C0CSYS",12,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CSYS",13,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CSYS",14,0) ; GNU General Public License for more details. "RTN","C0CSYS",15,0) ; "RTN","C0CSYS",16,0) ; You should have received a copy of the GNU General Public License along "RTN","C0CSYS",17,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CSYS",18,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CSYS",19,0) ; "RTN","C0CSYS",20,0) W "Enter at appropriate points." Q "RTN","C0CSYS",21,0) ; "RTN","C0CSYS",22,0) ; Originally, I was going to use VEPERVER, but VEPERVER "RTN","C0CSYS",23,0) ; actually kills ^TMP($J), outputs it to the screen in a user-friendly "RTN","C0CSYS",24,0) ; manner (press any key to continue), "RTN","C0CSYS",25,0) ; and is really a very half finished routine "RTN","C0CSYS",26,0) ; "RTN","C0CSYS",27,0) ; So for now, I am hard-coding the values. "RTN","C0CSYS",28,0) ; "RTN","C0CSYS",29,0) SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic "RTN","C0CSYS",30,0) Q:$G(DUZ("AG"))="I" "RPMS" "RTN","C0CSYS",31,0) Q "WorldVistA EHR/VOE" "RTN","C0CSYS",32,0) ; "RTN","C0CSYS",33,0) SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic "RTN","C0CSYS",34,0) Q "1.0" "RTN","C0CSYS",35,0) ; "RTN","C0CSYS",36,0) PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT "RTN","C0CSYS",37,0) ; DFN = IEN of the Patient to be tested "RTN","C0CSYS",38,0) ; 1 = Merged or Test Patient "RTN","C0CSYS",39,0) ; 0 = Non-test Patient "RTN","C0CSYS",40,0) ; "RTN","C0CSYS",41,0) I DFN="" Q 0 ; BAD DFN PASSED "RTN","C0CSYS",42,0) I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged "RTN","C0CSYS",43,0) I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add "RTN","C0CSYS",44,0) ; "RTN","C0CSYS",45,0) I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING "RTN","C0CSYS",46,0) I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS "RTN","C0CSYS",47,0) N DIERR,DATA "RTN","C0CSYS",48,0) I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT "RTN","C0CSYS",49,0) S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator "RTN","C0CSYS",50,0) ; 1 = Test Patient "RTN","C0CSYS",51,0) ; 0 = Non-test Patient "RTN","C0CSYS",52,0) I DATA Q DATA "RTN","C0CSYS",53,0) S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test "RTN","C0CSYS",54,0) D CLEAN^DILF "RTN","C0CSYS",55,0) I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN "RTN","C0CSYS",56,0) I $E(DATA,1,3)="000" Q 1 "RTN","C0CSYS",57,0) I $E(DATA,1,3)="666" Q 1 "RTN","C0CSYS",58,0) Q 0 "RTN","C0CSYS",59,0) ; "RTN","C0CUNIT") 0^61^B43465566 "RTN","C0CUNIT",1,0) C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 "RTN","C0CUNIT",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CUNIT",3,0) ;Copyright 2008 George Lilly. Licensed under the terms of the GNU "RTN","C0CUNIT",4,0) ;General Public License See attached copy of the License. "RTN","C0CUNIT",5,0) ; "RTN","C0CUNIT",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CUNIT",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CUNIT",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CUNIT",9,0) ;(at your option) any later version. "RTN","C0CUNIT",10,0) ; "RTN","C0CUNIT",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CUNIT",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CUNIT",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CUNIT",14,0) ;GNU General Public License for more details. "RTN","C0CUNIT",15,0) ; "RTN","C0CUNIT",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CUNIT",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CUNIT",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CUNIT",19,0) ; "RTN","C0CUNIT",20,0) W "This is a unit testing library",! "RTN","C0CUNIT",21,0) W ! "RTN","C0CUNIT",22,0) Q "RTN","C0CUNIT",23,0) ; "RTN","C0CUNIT",24,0) ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array "RTN","C0CUNIT",25,0) ; ZARY IS PASSED BY REFERENCE "RTN","C0CUNIT",26,0) ; BAT is a string identifying the test battery "RTN","C0CUNIT",27,0) ; TST is a test which will evaluate to true or false "RTN","C0CUNIT",28,0) ; I '$G(ZARY) D "RTN","C0CUNIT",29,0) ; . S ZARY(0)=0 ; initially there are no elements "RTN","C0CUNIT",30,0) ; W "GOT HERE LOADING "_TST,! "RTN","C0CUNIT",31,0) N CNT ; count of array elements "RTN","C0CUNIT",32,0) S CNT=ZARY(0) ; contains array count "RTN","C0CUNIT",33,0) S CNT=CNT+1 ; increment count "RTN","C0CUNIT",34,0) S ZARY(CNT)=TST ; put the test in the array "RTN","C0CUNIT",35,0) I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY "RTN","C0CUNIT",36,0) . N II,TN ; TEMP FOR ENDING TEST IN BATTERY "RTN","C0CUNIT",37,0) . S II=$P(ZARY(BAT),"^",2) "RTN","C0CUNIT",38,0) . S $P(ZARY(BAT),"^",2)=II+1 "RTN","C0CUNIT",39,0) I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY "RTN","C0CUNIT",40,0) . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY "RTN","C0CUNIT",41,0) . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX "RTN","C0CUNIT",42,0) . ; S TN=$NA(ZARY("TESTS")) "RTN","C0CUNIT",43,0) . ; D PUSH^C0CXPATH(TN,BAT) "RTN","C0CUNIT",44,0) S ZARY(0)=CNT ; update the array counter "RTN","C0CUNIT",45,0) Q "RTN","C0CUNIT",46,0) ; "RTN","C0CUNIT",47,0) ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference "RTN","C0CUNIT",48,0) ; ZARY IS PASSED BY NAME "RTN","C0CUNIT",49,0) ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") "RTN","C0CUNIT",50,0) ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE "RTN","C0CUNIT",51,0) K @ZARY "RTN","C0CUNIT",52,0) S @ZARY@(0)=0 ; initialize array count "RTN","C0CUNIT",53,0) N LINE,LABEL,BODY "RTN","C0CUNIT",54,0) N INTEST S INTEST=0 ; switch for in the test case section "RTN","C0CUNIT",55,0) N SECTION S SECTION="[anonymous]" ; test case section "RTN","C0CUNIT",56,0) ; "RTN","C0CUNIT",57,0) N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D "RTN","C0CUNIT",58,0) . I LINE?." "1";;>".E S INTEST=1 ; entering test section "RTN","C0CUNIT",59,0) . I LINE?." "1";;>".E S INTEST=0 ; leaving TEMPLATE section "RTN","C0CUNIT",62,0) . I INTEST D ; within the testing section "RTN","C0CUNIT",63,0) . . I LINE?." "1";;><".E D ; section name found "RTN","C0CUNIT",64,0) . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name "RTN","C0CUNIT",65,0) . . I LINE?." "1";;>>".E D ; test case found "RTN","C0CUNIT",66,0) . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array "RTN","C0CUNIT",67,0) S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL "RTN","C0CUNIT",68,0) Q "RTN","C0CUNIT",69,0) ; "RTN","C0CUNIT",70,0) ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST "RTN","C0CUNIT",71,0) N ZI,ZX,ZR,ZP "RTN","C0CUNIT",72,0) S DEBUG=0 "RTN","C0CUNIT",73,0) ; I WHICH="ALL" D Q ; RUN ALL THE TESTS "RTN","C0CUNIT",74,0) ; . W "DOING ALL",! "RTN","C0CUNIT",75,0) ; . N J,NT "RTN","C0CUNIT",76,0) ; . S NT=$NA(ZARY("TESTS")) "RTN","C0CUNIT",77,0) ; . W NT,@NT@(0),! "RTN","C0CUNIT",78,0) ; . F J=1:1:@NT@(0) D ; "RTN","C0CUNIT",79,0) ; . . W @NT@(J),! "RTN","C0CUNIT",80,0) ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J)) "RTN","C0CUNIT",81,0) I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST "RTN","C0CUNIT",82,0) . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! "RTN","C0CUNIT",83,0) N FIRST,LAST "RTN","C0CUNIT",84,0) S FIRST=$P(ZARY(WHICH),"^",1) "RTN","C0CUNIT",85,0) S LAST=$P(ZARY(WHICH),"^",2) "RTN","C0CUNIT",86,0) F ZI=FIRST:1:LAST D "RTN","C0CUNIT",87,0) . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT "RTN","C0CUNIT",88,0) . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) "RTN","C0CUNIT",89,0) . . ; W ZP,! "RTN","C0CUNIT",90,0) . . S ZX=ZP "RTN","C0CUNIT",91,0) . . W "RUNNING: "_ZP "RTN","C0CUNIT",92,0) . . X ZX "RTN","C0CUNIT",93,0) . . W "..SUCCESS: ",WHICH,! "RTN","C0CUNIT",94,0) . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST "RTN","C0CUNIT",95,0) . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) "RTN","C0CUNIT",96,0) . . S ZX="S ZR="_ZP "RTN","C0CUNIT",97,0) . . W "TRYING: "_ZP "RTN","C0CUNIT",98,0) . . X ZX "RTN","C0CUNIT",99,0) . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! "RTN","C0CUNIT",100,0) . . I '$D(TPASSED) D ; NOT INITIALIZED YET "RTN","C0CUNIT",101,0) . . . S TPASSED=0 S TFAILED=0 "RTN","C0CUNIT",102,0) . . I ZR S TPASSED=TPASSED+1 "RTN","C0CUNIT",103,0) . . I 'ZR S TFAILED=TFAILED+1 "RTN","C0CUNIT",104,0) Q "RTN","C0CUNIT",105,0) ; "RTN","C0CUNIT",106,0) TEST ; RUN ALL THE TEST CASES "RTN","C0CUNIT",107,0) N ZTMP "RTN","C0CUNIT",108,0) D ZLOAD(.ZTMP) "RTN","C0CUNIT",109,0) D ZTEST(.ZTMP,"ALL") "RTN","C0CUNIT",110,0) W "PASSED: ",TPASSED,! "RTN","C0CUNIT",111,0) W "FAILED: ",TFAILED,! "RTN","C0CUNIT",112,0) W ! "RTN","C0CUNIT",113,0) W "THE TESTS!",! "RTN","C0CUNIT",114,0) ; I DEBUG ZWR ZTMP "RTN","C0CUNIT",115,0) Q "RTN","C0CUNIT",116,0) ; "RTN","C0CUNIT",117,0) GTSTS(GTZARY,RTN) ; return an array of test names "RTN","C0CUNIT",118,0) N I,J S I="" S I=$O(GTZARY("TESTS",I)) "RTN","C0CUNIT",119,0) F J=0:0 Q:I="" D "RTN","C0CUNIT",120,0) . D PUSH^C0CXPATH(RTN,I) "RTN","C0CUNIT",121,0) . S I=$O(GTZARY("TESTS",I)) "RTN","C0CUNIT",122,0) Q "RTN","C0CUNIT",123,0) ; "RTN","C0CUNIT",124,0) TESTALL(RNM) ; RUN ALL THE TESTS "RTN","C0CUNIT",125,0) N ZI,J,TZTMP,TSTS,TOTP,TOTF "RTN","C0CUNIT",126,0) S TOTP=0 S TOTF=0 "RTN","C0CUNIT",127,0) D ZLOAD^C0CUNIT("TZTMP",RNM) "RTN","C0CUNIT",128,0) D GTSTS(.TZTMP,"TSTS") "RTN","C0CUNIT",129,0) F ZI=1:1:TSTS(0) D ; "RTN","C0CUNIT",130,0) . S TPASSED=0 S TFAILED=0 "RTN","C0CUNIT",131,0) . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI)) "RTN","C0CUNIT",132,0) . S TOTP=TOTP+TPASSED "RTN","C0CUNIT",133,0) . S TOTF=TOTF+TFAILED "RTN","C0CUNIT",134,0) . S $P(TSTS(ZI),"^",2)=TPASSED "RTN","C0CUNIT",135,0) . S $P(TSTS(ZI),"^",3)=TFAILED "RTN","C0CUNIT",136,0) F ZI=1:1:TSTS(0) D ; "RTN","C0CUNIT",137,0) . W "TEST=> ",$P(TSTS(ZI),"^",1) "RTN","C0CUNIT",138,0) . W " PASSED=>",$P(TSTS(ZI),"^",2) "RTN","C0CUNIT",139,0) . W " FAILED=>",$P(TSTS(ZI),"^",3),! "RTN","C0CUNIT",140,0) W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! "RTN","C0CUNIT",141,0) Q "RTN","C0CUNIT",142,0) ; "RTN","C0CUNIT",143,0) TLIST(ZARY) ; LIST ALL THE TESTS "RTN","C0CUNIT",144,0) ; THEY ARE MARKED AS ;;> IN THE TEST CASES "RTN","C0CUNIT",145,0) ; ZARY IS PASSED BY REFERENCE "RTN","C0CUNIT",146,0) N I,J,K S I="" S I=$O(ZARY("TESTS",I)) "RTN","C0CUNIT",147,0) S K=1 "RTN","C0CUNIT",148,0) F J=0:0 Q:I="" D "RTN","C0CUNIT",149,0) . ; W "I IS NOW=",I,! "RTN","C0CUNIT",150,0) . W I," " "RTN","C0CUNIT",151,0) . S I=$O(ZARY("TESTS",I)) "RTN","C0CUNIT",152,0) . S K=K+1 I K=6 D "RTN","C0CUNIT",153,0) . . W ! "RTN","C0CUNIT",154,0) . . S K=1 "RTN","C0CUNIT",155,0) Q "RTN","C0CUNIT",156,0) ; "RTN","C0CUNIT",157,0) MEDS "RTN","C0CUNIT",158,0) N DEBUG S DEBUG=0 "RTN","C0CUNIT",159,0) N DFN S DFN=5685 "RTN","C0CUNIT",160,0) K ^TMP($J) "RTN","C0CUNIT",161,0) W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! "RTN","C0CUNIT",162,0) N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) "RTN","C0CUNIT",163,0) N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" "RTN","C0CUNIT",164,0) W "XPATH is: "_XPATH,! "RTN","C0CUNIT",165,0) W "Getting Med Template into INXML using",! "RTN","C0CUNIT",166,0) W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!! "RTN","C0CUNIT",167,0) D QUERY^GPLXPATH(T,XPATH,"INXML") "RTN","C0CUNIT",168,0) W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",! "RTN","C0CUNIT",169,0) W "OUTXML will be ^TMP($J,""OUT"")",! "RTN","C0CUNIT",170,0) N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) "RTN","C0CUNIT",171,0) D EXTRACT^C0CMED6("INXML",DFN,OUTXML) "RTN","C0CUNIT",172,0) D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml") "RTN","C0CUNIT",173,0) Q "RTN","C0CUNIT",174,0) PAT "RTN","C0CUNIT",175,0) D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory "RTN","C0CUNIT",176,0) N X,Y "RTN","C0CUNIT",177,0) ; Select Patient "RTN","C0CUNIT",178,0) S DIC=2,DIC(0)="AEMQ" D ^DIC "RTN","C0CUNIT",179,0) ; "RTN","C0CUNIT",180,0) W "You have selected patient "_Y,!! "RTN","C0CUNIT",181,0) N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D "RTN","C0CUNIT",182,0) . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " "RTN","C0CUNIT",183,0) . W "valued at " "RTN","C0CUNIT",184,0) . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")") "RTN","C0CUNIT",185,0) . W ! "RTN","C0CUNIT",186,0) Q "RTN","C0CUTIL") 0^62^B27079469 "RTN","C0CUTIL",1,0) C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 "RTN","C0CUTIL",2,0) ;;0.1;C0C;;Jun 15, 2008;Build 1 "RTN","C0CUTIL",3,0) ;Copyright 2008-2009 Sam Habiel & George Lilly. "RTN","C0CUTIL",4,0) ;Licensed under the terms of the GNU "RTN","C0CUTIL",5,0) ;General Public License See attached copy of the License. "RTN","C0CUTIL",6,0) ; "RTN","C0CUTIL",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CUTIL",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CUTIL",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CUTIL",10,0) ;(at your option) any later version. "RTN","C0CUTIL",11,0) ; "RTN","C0CUTIL",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CUTIL",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CUTIL",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CUTIL",15,0) ;GNU General Public License for more details. "RTN","C0CUTIL",16,0) ; "RTN","C0CUTIL",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CUTIL",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CUTIL",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CUTIL",20,0) ; "RTN","C0CUTIL",21,0) W "No Entry at Top!" "RTN","C0CUTIL",22,0) Q "RTN","C0CUTIL",23,0) ; "RTN","C0CUTIL",24,0) UUID() ; thanks to Wally for this. "RTN","C0CUTIL",25,0) N R,I,J,N "RTN","C0CUTIL",26,0) S N="",R="" F S N=N_$R(100000) Q:$L(N)>64 "RTN","C0CUTIL",27,0) F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1)) "RTN","C0CUTIL",28,0) Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32) "RTN","C0CUTIL",29,0) ; "RTN","C0CUTIL",30,0) OLDUUID() ; GENERATE A RANDOM UUID (Version 4) "RTN","C0CUTIL",31,0) N I,J,ZS "RTN","C0CUTIL",32,0) S ZS="0123456789abcdef" S J="" "RTN","C0CUTIL",33,0) F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1)) "RTN","C0CUTIL",34,0) Q J "RTN","C0CUTIL",35,0) ; "RTN","C0CUTIL",36,0) FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic "RTN","C0CUTIL",37,0) ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) "RTN","C0CUTIL",38,0) ; If not passed, or passed incorrectly, it's assumed that it is D. "RTN","C0CUTIL",39,0) ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. "RTN","C0CUTIL",40,0) ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC "RTN","C0CUTIL",41,0) ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) "RTN","C0CUTIL",42,0) N UTC,Y,M,D,H,MM,S,OFF "RTN","C0CUTIL",43,0) S Y=1700+$E(DATE,1,3) "RTN","C0CUTIL",44,0) S M=$E(DATE,4,5) "RTN","C0CUTIL",45,0) S D=$E(DATE,6,7) "RTN","C0CUTIL",46,0) S H=$E(DATE,9,10) "RTN","C0CUTIL",47,0) I $L(H)=1 S H="0"_H "RTN","C0CUTIL",48,0) S MM=$E(DATE,11,12) "RTN","C0CUTIL",49,0) I $L(MM)=1 S MM="0"_MM "RTN","C0CUTIL",50,0) S S=$E(DATE,13,14) "RTN","C0CUTIL",51,0) I $L(S)=1 S S="0"_S "RTN","C0CUTIL",52,0) S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. "RTN","C0CUTIL",53,0) S OFFS=$E(OFF,1,1) "RTN","C0CUTIL",54,0) S OFF0=$TR(OFF,"+-") "RTN","C0CUTIL",55,0) S OFF1=$E(OFF0+10000,2,3) "RTN","C0CUTIL",56,0) S OFF2=$E(OFF0+10000,4,5) "RTN","C0CUTIL",57,0) S OFF=OFFS_OFF1_":"_OFF2 "RTN","C0CUTIL",58,0) ;S OFF2=$E(OFF,1,2) ; "RTN","C0CUTIL",59,0) ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT "RTN","C0CUTIL",60,0) ;S OFF3=$E(OFF,3,4) ;MINUTES "RTN","C0CUTIL",61,0) ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3) "RTN","C0CUTIL",62,0) ; If H, MM and S are empty, it means that the FM date didn't supply the time. "RTN","C0CUTIL",63,0) ; In this case, set H, MM and S to "00" "RTN","C0CUTIL",64,0) ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? "RTN","C0CUTIL",65,0) S:'$L(H) H="00" "RTN","C0CUTIL",66,0) S:'$L(MM) MM="00" "RTN","C0CUTIL",67,0) S:'$L(S) S="00" "RTN","C0CUTIL",68,0) S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds "RTN","C0CUTIL",69,0) I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. "RTN","C0CUTIL",70,0) E Q $P(UTC,"T") "RTN","C0CUTIL",71,0) ; "RTN","C0CUTIL",72,0) SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT "RTN","C0CUTIL",73,0) ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE "RTN","C0CUTIL",74,0) ; DATE AND TIME ORDER. DEFAULT IS FORWARD "RTN","C0CUTIL",75,0) ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT "RTN","C0CUTIL",76,0) ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER "RTN","C0CUTIL",77,0) ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER "RTN","C0CUTIL",78,0) ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC "RTN","C0CUTIL",79,0) ; BOTH V1 AND V2 ARE PASSED BY REFERENCE "RTN","C0CUTIL",80,0) N VSRT ; TEMP FOR HASHING DATES "RTN","C0CUTIL",81,0) N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 "RTN","C0CUTIL",82,0) S ZCNT=V2(0) ; COUNTING NUMBER OF DATES "RTN","C0CUTIL",83,0) F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY "RTN","C0CUTIL",84,0) . I $D(V2(ZI)) D ; IF THE DATE EXISTS "RTN","C0CUTIL",85,0) . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE "RTN","C0CUTIL",86,0) . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE "RTN","C0CUTIL",87,0) . . ; W "DATE: ",ZP1," TIME: ",ZP2,! "RTN","C0CUTIL",88,0) . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT "RTN","C0CUTIL",89,0) N ZG "RTN","C0CUTIL",90,0) S ZG=$Q(VSRT("")) "RTN","C0CUTIL",91,0) F D Q:ZG="" ; "RTN","C0CUTIL",92,0) . ; W ZG,! "RTN","C0CUTIL",93,0) . D PUSH^C0CXPATH("V1",@ZG) "RTN","C0CUTIL",94,0) . S ZG=$Q(@ZG) "RTN","C0CUTIL",95,0) I ORDR=-1 D ; HAVE TO REVERSE ORDER "RTN","C0CUTIL",96,0) . N ZG2 "RTN","C0CUTIL",97,0) . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT "RTN","C0CUTIL",98,0) . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER "RTN","C0CUTIL",99,0) . S ZG2(0)=V1(0) "RTN","C0CUTIL",100,0) . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY "RTN","C0CUTIL",101,0) Q ZCNT "RTN","C0CUTIL",102,0) ; "RTN","C0CUTIL",103,0) DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX "RTN","C0CUTIL",104,0) ; RETURNS AN ARRAY RTN PASSED BY REFERENCE "RTN","C0CUTIL",105,0) ; THIS ROUTINE CAN BE USED AS AN RPC "RTN","C0CUTIL",106,0) ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY "RTN","C0CUTIL",107,0) ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY "RTN","C0CUTIL",108,0) ; "RTN","C0CUTIL",109,0) N LEXIEN "RTN","C0CUTIL",110,0) I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG "RTN","C0CUTIL",111,0) . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON "RTN","C0CUTIL",112,0) . W LEXIEN,! "RTN","C0CUTIL",113,0) . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 "RTN","C0CUTIL",114,0) . S RTN(0)=1 ; ONE THING RETURNED "RTN","C0CUTIL",115,0) E S RTN(0)=0 ; NOT FOUND "RTN","C0CUTIL",116,0) Q "RTN","C0CUTIL",117,0) ; "RTN","C0CUTIL",118,0) DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME "RTN","C0CUTIL",119,0) ; "RTN","C0CUTIL",120,0) N DARTN "RTN","C0CUTIL",121,0) D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE "RTN","C0CUTIL",122,0) I DARTN(0)>0 D ; GOT RESULTS "RTN","C0CUTIL",123,0) . W !,DARTN(1) ;PRINT THE SNOMED CODE "RTN","C0CUTIL",124,0) E W !,"NOT FOUND",! "RTN","C0CUTIL",125,0) Q "RTN","C0CUTIL",126,0) ; "RTN","C0CUTIL",127,0) DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL "RTN","C0CUTIL",128,0) ; ASSOCIATED SNOMED CODES "RTN","C0CUTIL",129,0) N DASTMP,DASIEN,DASNO "RTN","C0CUTIL",130,0) S DASTMP="" "RTN","C0CUTIL",131,0) F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED "RTN","C0CUTIL",132,0) . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED "RTN","C0CUTIL",133,0) . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY "RTN","C0CUTIL",134,0) . W DASTMP,"=",DASNO,! ; PRINT IT OUT "RTN","C0CUTIL",135,0) Q "RTN","C0CUTIL",136,0) ; "RTN","C0CUTIL",137,0) RXNFN() Q 1130590011.001 ; RxNorm Concepts file number "RTN","C0CUTIL",138,0) ; "RTN","C0CUTIL",139,0) CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF "RTN","C0CUTIL",140,0) ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR "RTN","C0CUTIL",141,0) N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT "RTN","C0CUTIL",142,0) I $G(ZVUID)="" Q "" "RTN","C0CUTIL",143,0) I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED "RTN","C0CUTIL",144,0) N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") "RTN","C0CUTIL",145,0) S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES "RTN","C0CUTIL",146,0) N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) "RTN","C0CUTIL",147,0) S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED "RTN","C0CUTIL",148,0) I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" "RTN","C0CUTIL",149,0) Q ZRSLT "RTN","C0CUTIL",150,0) ; "RTN","C0CUTIL",151,0) NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO "RTN","C0CUTIL",152,0) ; CONFORM TO NIST REQUIREMENTS "RTN","C0CUTIL",153,0) ;INPATIENT CERTIFICATION "RTN","C0CUTIL",154,0) I ZRXN=309362 S ZRXN=213169 "RTN","C0CUTIL",155,0) I ZRXN=855318 S ZRXN=855320 "RTN","C0CUTIL",156,0) I ZRXN=197361 S ZRXN=212549 "RTN","C0CUTIL",157,0) ;OUTPATIENT CERTIFICATION "RTN","C0CUTIL",158,0) I ZRXN=310534 S ZRXN=205875 "RTN","C0CUTIL",159,0) I ZRXN=617312 S ZRXN=617314 "RTN","C0CUTIL",160,0) I ZRXN=310429 S ZRXN=200801 "RTN","C0CUTIL",161,0) I ZRXN=628953 S ZRXN=628958 "RTN","C0CUTIL",162,0) I ZRXN=745679 S ZRXN=630208 "RTN","C0CUTIL",163,0) I ZRXN=311564 S ZRXN=979334 "RTN","C0CUTIL",164,0) I ZRXN=836343 S ZRXN=836370 "RTN","C0CUTIL",165,0) Q ZRXN "RTN","C0CUTIL",166,0) ; "RTN","C0CUTIL",167,0) RPMS() ; Are we running on an RPMS system rather than Vista? "RTN","C0CUTIL",168,0) Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service "RTN","C0CUTIL",169,0) VISTA() ; Are we running on Vanilla Vista? "RTN","C0CUTIL",170,0) Q $G(DUZ("AG"))="V" ; If User Agency is VA "RTN","C0CUTIL",171,0) WV() ; Are we running on WorldVista? "RTN","C0CUTIL",172,0) Q $G(DUZ("AG"))="E" ; Code for WV. "RTN","C0CUTIL",173,0) OV() ; Are we running on OpenVista? "RTN","C0CUTIL",174,0) Q $G(DUZ("AG"))="O" ; Code for OpenVista "RTN","C0CUTIL",175,0) "RTN","C0CVA200") 0^63^B32092477 "RTN","C0CVA200",1,0) C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 "RTN","C0CVA200",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CVA200",3,0) ;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU "RTN","C0CVA200",4,0) ;General Public License See attached copy of the License. "RTN","C0CVA200",5,0) ; "RTN","C0CVA200",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CVA200",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CVA200",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CVA200",9,0) ;(at your option) any later version. "RTN","C0CVA200",10,0) ; "RTN","C0CVA200",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CVA200",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CVA200",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CVA200",14,0) ;GNU General Public License for more details. "RTN","C0CVA200",15,0) ; "RTN","C0CVA200",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CVA200",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CVA200",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CVA200",19,0) Q "RTN","C0CVA200",20,0) ; This routine uses Kernel APIs and Direct Global Access to get "RTN","C0CVA200",21,0) ; Proivder Data from File 200. "RTN","C0CVA200",22,0) ; "RTN","C0CVA200",23,0) ; The Global is VA(200,*) "RTN","C0CVA200",24,0) ; "RTN","C0CVA200",25,0) FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC "RTN","C0CVA200",26,0) ; INPUT: DUZ (i.e. File 200 IEN) ByVal "RTN","C0CVA200",27,0) ; OUTPUT: String "RTN","C0CVA200",28,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","C0CVA200",29,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CVA200",30,0) Q NAME("FAMILY") "RTN","C0CVA200",31,0) ; "RTN","C0CVA200",32,0) GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC "RTN","C0CVA200",33,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",34,0) ; OUTPUT: String "RTN","C0CVA200",35,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","C0CVA200",36,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CVA200",37,0) Q NAME("GIVEN") "RTN","C0CVA200",38,0) ; "RTN","C0CVA200",39,0) MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC "RTN","C0CVA200",40,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",41,0) ; OUTPUT: String "RTN","C0CVA200",42,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","C0CVA200",43,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CVA200",44,0) Q NAME("MIDDLE") "RTN","C0CVA200",45,0) ; "RTN","C0CVA200",46,0) SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC "RTN","C0CVA200",47,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",48,0) ; OUTPUT: String "RTN","C0CVA200",49,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","C0CVA200",50,0) D NAMECOMP^XLFNAME(.NAME) "RTN","C0CVA200",51,0) Q NAME("SUFFIX") "RTN","C0CVA200",52,0) ; "RTN","C0CVA200",53,0) TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC "RTN","C0CVA200",54,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",55,0) ; OUTPUT: String "RTN","C0CVA200",56,0) ; Gets External Value of Title field in New Person File. "RTN","C0CVA200",57,0) ; It's actually a pointer to file 3.1 "RTN","C0CVA200",58,0) ; 200=New Person File; 8 is Title Field "RTN","C0CVA200",59,0) Q $$GET1^DIQ(200,DUZ_",",8) "RTN","C0CVA200",60,0) ; "RTN","C0CVA200",61,0) NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC "RTN","C0CVA200",62,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",63,0) ; OUTPUT: Delimited String in format: "RTN","C0CVA200",64,0) ; IDType^ID^IDDescription "RTN","C0CVA200",65,0) ; If the NPI doesn't exist, "" is returned. "RTN","C0CVA200",66,0) ; This routine uses a call documented in the Kernel dev guide "RTN","C0CVA200",67,0) ; This call returns as "NPI^TimeEntered^ActiveInactive" "RTN","C0CVA200",68,0) ; It returns -1 for NPI if NPI doesn't exist. "RTN","C0CVA200",69,0) N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) "RTN","C0CVA200",70,0) Q:NPI=-1 "" "RTN","C0CVA200",71,0) Q "NPI^"_NPI_"^HHS" "RTN","C0CVA200",72,0) ; "RTN","C0CVA200",73,0) SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC "RTN","C0CVA200",74,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",75,0) ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" "RTN","C0CVA200",76,0) ; Uses a Kernel API. Returns -1 if a specialty is not specified "RTN","C0CVA200",77,0) ; in file 200. "RTN","C0CVA200",78,0) ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code "RTN","C0CVA200",79,0) N STR S STR=$$GET^XUA4A72(DUZ) "RTN","C0CVA200",80,0) Q:+STR<0 "" "RTN","C0CVA200",81,0) ; Sometimes we have 3 pieces, or 2. Deal with that. "RTN","C0CVA200",82,0) Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) "RTN","C0CVA200",83,0) Q $P(STR,U,2)_"-"_$P(STR,U,3) "RTN","C0CVA200",84,0) ; "RTN","C0CVA200",85,0) ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC "RTN","C0CVA200",86,0) ; INPUT: DUZ, but not needed really... here for future expansion "RTN","C0CVA200",87,0) ; OUTPUT: At this point "Work" "RTN","C0CVA200",88,0) Q "Work" "RTN","C0CVA200",89,0) ; "RTN","C0CVA200",90,0) ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09 "RTN","C0CVA200",91,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",92,0) ; Output: String. "RTN","C0CVA200",93,0) ; "RTN","C0CVA200",94,0) ; First, get site number from the institution file. "RTN","C0CVA200",95,0) ; 1st piece returned by $$SITE^VASITE, which gets the system institution "RTN","C0CVA200",96,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","C0CVA200",97,0) ; "RTN","C0CVA200",98,0) ; Second, get mailing address "RTN","C0CVA200",99,0) ; There are two APIs to get the address, one for physical and one for "RTN","C0CVA200",100,0) ; mailing. We will check if mailing exists first, since that's the "RTN","C0CVA200",101,0) ; one we want to use; then check for physical. If neither exists, "RTN","C0CVA200",102,0) ; then we return nothing. We check for the existence of an address "RTN","C0CVA200",103,0) ; by the length of the returned string. "RTN","C0CVA200",104,0) ; NOTE: API doesn't support Address 2, so I won't even include it "RTN","C0CVA200",105,0) ; in the template. "RTN","C0CVA200",106,0) N ADD "RTN","C0CVA200",107,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","C0CVA200",108,0) Q:$L(ADD) $P(ADD,U) "RTN","C0CVA200",109,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","C0CVA200",110,0) Q:$L(ADD) $P(ADD,U) "RTN","C0CVA200",111,0) Q "" "RTN","C0CVA200",112,0) ; "RTN","C0CVA200",113,0) CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC "RTN","C0CVA200",114,0) ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING "RTN","C0CVA200",115,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",116,0) ; Output: String. "RTN","C0CVA200",117,0) ; See ADD1 for comments "RTN","C0CVA200",118,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","C0CVA200",119,0) N ADD "RTN","C0CVA200",120,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","C0CVA200",121,0) Q:$L(ADD) $P(ADD,U,2) "RTN","C0CVA200",122,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","C0CVA200",123,0) Q:$L(ADD) $P(ADD,U,2) "RTN","C0CVA200",124,0) Q "" "RTN","C0CVA200",125,0) ; "RTN","C0CVA200",126,0) STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC "RTN","C0CVA200",127,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",128,0) ; Output: String. "RTN","C0CVA200",129,0) ; See ADD1 for comments "RTN","C0CVA200",130,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","C0CVA200",131,0) N ADD "RTN","C0CVA200",132,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","C0CVA200",133,0) Q:$L(ADD) $P(ADD,U,3) "RTN","C0CVA200",134,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","C0CVA200",135,0) Q:$L(ADD) $P(ADD,U,3) "RTN","C0CVA200",136,0) Q "" "RTN","C0CVA200",137,0) ; "RTN","C0CVA200",138,0) POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC "RTN","C0CVA200",139,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",140,0) ; OUTPUT: String. "RTN","C0CVA200",141,0) ; See ADD1 for comments "RTN","C0CVA200",142,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","C0CVA200",143,0) N ADD "RTN","C0CVA200",144,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","C0CVA200",145,0) Q:$L(ADD) $P(ADD,U,4) "RTN","C0CVA200",146,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","C0CVA200",147,0) Q:$L(ADD) $P(ADD,U,4) "RTN","C0CVA200",148,0) Q "" "RTN","C0CVA200",149,0) ; "RTN","C0CVA200",150,0) TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC "RTN","C0CVA200",151,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",152,0) ; OUTPUT: String. "RTN","C0CVA200",153,0) ; Direct global access "RTN","C0CVA200",154,0) N TEL S TEL=$G(^VA(200,DUZ,.13)) "RTN","C0CVA200",155,0) Q $P(TEL,U,2) "RTN","C0CVA200",156,0) ; "RTN","C0CVA200",157,0) TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC "RTN","C0CVA200",158,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",159,0) ; OUTPUT: String. "RTN","C0CVA200",160,0) Q "Office" "RTN","C0CVA200",161,0) ; "RTN","C0CVA200",162,0) EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC "RTN","C0CVA200",163,0) ; INPUT: DUZ ByVal "RTN","C0CVA200",164,0) ; OUTPUT: String "RTN","C0CVA200",165,0) ; Direct global access "RTN","C0CVA200",166,0) N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) "RTN","C0CVA200",167,0) Q $P(EMAIL,U) "RTN","C0CVA200",168,0) ; "RTN","C0CVALID") 0^64^B2417040 "RTN","C0CVALID",1,0) C0CVALID ; C0C/OHUM/RUT - PROCESSING FOR DATE LIMITS, NOTES ; 22/12/2011 "RTN","C0CVALID",2,0) ;;1.0;C0C;;Dec 22, 2011;Build 1 "RTN","C0CVALID",3,0) S ^TMP("C0CCCR","LABLIMIT")="",^TMP("C0CCCR","VITLIMIT")="",^TMP("C0CCCR","MEDLIMIT")="",^TMP("C0CCCR","TIULIMIT")="" "RTN","C0CVALID",4,0) S %DT="AEX",%DT("A")="LAB Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","LABLIMIT")=Y "RTN","C0CVALID",5,0) S %DT="AEX",%DT("A")="VITAL Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","VITLIMIT")=Y "RTN","C0CVALID",6,0) S %DT="AEX",%DT("A")="MEDICATION Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","MEDLIMIT")=Y "RTN","C0CVALID",7,0) ;S ^TMP("C0CCCR","RALIMIT")="",%DT="AEX",%DT("A")="RADIOLOGY Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","RALIMIT")=Y "RTN","C0CVALID",8,0) W !,"Do you want to include Notes: YES/NO? //NO" D YN^DICN I %=1 S %DT="AEX",%DT("A")="NOTE Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","TIULIMIT")=Y "RTN","C0CVALID",9,0) Q "RTN","C0CVIT2") 0^65^B320700684 "RTN","C0CVIT2",1,0) C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 "RTN","C0CVIT2",2,0) ;;1.0;C0C;;Feb 16, 2010;Build 1 "RTN","C0CVIT2",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota and others. "RTN","C0CVIT2",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CVIT2",5,0) ;See attached copy of the License. "RTN","C0CVIT2",6,0) ; "RTN","C0CVIT2",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CVIT2",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CVIT2",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CVIT2",10,0) ;(at your option) any later version. "RTN","C0CVIT2",11,0) ; "RTN","C0CVIT2",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CVIT2",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CVIT2",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CVIT2",15,0) ;GNU General Public License for more details. "RTN","C0CVIT2",16,0) ; "RTN","C0CVIT2",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CVIT2",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CVIT2",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CVIT2",20,0) ; "RTN","C0CVIT2",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CVIT2",22,0) Q "RTN","C0CVIT2",23,0) ; "RTN","C0CVIT2",24,0) EXTRACT(VITXML,DFN,VITOUT) ; EXTRACT VITAL SIGNS INTO XML TEMPLATE "RTN","C0CVIT2",25,0) ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CVIT2",26,0) ; "RTN","C0CVIT2",27,0) ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS "RTN","C0CVIT2",28,0) ; THAT GET PASSED TO *GET ROUTINES "RTN","C0CVIT2",29,0) ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) "RTN","C0CVIT2",30,0) N C0CVIT "RTN","C0CVIT2",31,0) S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT")) "RTN","C0CVIT2",32,0) ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS "RTN","C0CVIT2",33,0) ; THAT GET INSERTED INTO THE XML TEMPLATE "RTN","C0CVIT2",34,0) ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS "RTN","C0CVIT2",35,0) I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS "RTN","C0CVIT2",36,0) I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT) "RTN","C0CVIT2",37,0) ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE "RTN","C0CVIT2",38,0) ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES "RTN","C0CVIT2",39,0) D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES "RTN","C0CVIT2",40,0) Q "RTN","C0CVIT2",41,0) ; "RTN","C0CVIT2",42,0) GETVISTA(DFN,C0CVIT) ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS. "RTN","C0CVIT2",43,0) ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME "RTN","C0CVIT2",44,0) ; C0CVIT: VITAL SIGNS "RTN","C0CVIT2",45,0) ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 "RTN","C0CVIT2",46,0) ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY "RTN","C0CVIT2",47,0) ; EXIST. "RTN","C0CVIT2",48,0) ; "RTN","C0CVIT2",49,0) ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) "RTN","C0CVIT2",50,0) ; "RTN","C0CVIT2",51,0) ; SETUP RPC/API CALL HERE "RTN","C0CVIT2",52,0) ; USE START AND END DATES FROM PARAMETERS IF REQUIRED "RTN","C0CVIT2",53,0) ; "RTN","C0CVIT2",54,0) N VIT,DATA,START,END "RTN","C0CVIT2",55,0) ; RPC REQUIRES FM DATES NOT T-* DATES "RTN","C0CVIT2",56,0) D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM "RTN","C0CVIT2",57,0) D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM "RTN","C0CVIT2",58,0) ; RPC CALL (ORY,DFN,ORSDT,OREDT): "RTN","C0CVIT2",59,0) ;ORY: return variable "RTN","C0CVIT2",60,0) ;DFN: patient identifier from Patient File [#2] "RTN","C0CVIT2",61,0) ;ORSDT: start date/time in Fileman format "RTN","C0CVIT2",62,0) ;OREDT: end date/time in Fileman format "RTN","C0CVIT2",63,0) ; OUTPUT FORMAT: "RTN","C0CVIT2",64,0) ;vital measurement ien^vital type^rate^date/time taken "RTN","C0CVIT2",65,0) D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL "RTN","C0CVIT2",66,0) I '$D(VIT) S @VITOUT@(0)=0 K VIT Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT "RTN","C0CVIT2",67,0) I $P(VIT(1),U,2)="No vitals found." D Q ; signal no vitals and quit "RTN","C0CVIT2",68,0) . I $D(VITOUT) S @VITOUT@(0)=0 "RTN","C0CVIT2",69,0) . K VIT "RTN","C0CVIT2",70,0) ; "RTN","C0CVIT2",71,0) ; PREFORM SORT HERE IF NEEDED "RTN","C0CVIT2",72,0) ; "RTN","C0CVIT2",73,0) ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST "RTN","C0CVIT2",74,0) ; COPIED SORT LOGIC: "RTN","C0CVIT2",75,0) N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX "RTN","C0CVIT2",76,0) D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY "RTN","C0CVIT2",77,0) S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE "RTN","C0CVIT2",78,0) ; VSORT IS VITALS IN REVERSE ORDER "RTN","C0CVIT2",79,0) ; "RTN","C0CVIT2",80,0) ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY "RTN","C0CVIT2",81,0) ; RNF1 ARRAY FORMAT: "RTN","C0CVIT2",82,0) ; VAR("NAME_OF_RIM_VARIABLE")=VALUE "RTN","C0CVIT2",83,0) ; "RTN","C0CVIT2",84,0) ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS "RTN","C0CVIT2",85,0) ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD "RTN","C0CVIT2",86,0) ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS "RTN","C0CVIT2",87,0) N C0CVI,C0CC,ZRNF "RTN","C0CVIT2",88,0) ;S C0CVI="" ; INITIALIZE FOR $O "RTN","C0CVIT2",89,0) F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST "RTN","C0CVIT2",90,0) . I DEBUG W VIT(C0CVI),! "RTN","C0CVIT2",91,0) . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) "RTN","C0CVIT2",92,0) . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"in") "RTN","C0CVIT2",93,0) . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"lbs") "RTN","C0CVIT2",94,0) . D:$P(VIT(C0CVI),U,3)="BP" BP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") "RTN","C0CVIT2",95,0) . D:$P(VIT(C0CVI),U,3)="T" TMP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"F") "RTN","C0CVIT2",96,0) . D:$P(VIT(C0CVI),U,3)="R" RESP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") "RTN","C0CVIT2",97,0) . D:$P(VIT(C0CVI),U,3)="P" PULSE1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") "RTN","C0CVIT2",98,0) . D:$P(VIT(C0CVI),U,3)="PN" PAIN1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") "RTN","C0CVIT2",99,0) . D:'$D(ZRNF) OTHER1($$FMDTOUTC^C0CUTIL($P(C0CVI,U,4),"DT"),"OTHER VITAL",$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"UNKNOWN") ;IF THE VITAL ISN'T DEFINED IT IS OTHER "RTN","C0CVIT2",100,0) . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY "RTN","C0CVIT2",101,0) . K ZRNF "RTN","C0CVIT2",102,0) ; SAVE RIM VARIABLES SEE C0CRIMA "RTN","C0CVIT2",103,0) N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) "RTN","C0CVIT2",104,0) M @ZRIM=@C0CVIT@("V") "RTN","C0CVIT2",105,0) Q "RTN","C0CVIT2",106,0) ; "RTN","C0CVIT2",107,0) GETRPMS(DFN,C0CVIT) ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS. "RTN","C0CVIT2",108,0) ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME "RTN","C0CVIT2",109,0) ; C0CVIT: VITAL SIGNS "RTN","C0CVIT2",110,0) ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 "RTN","C0CVIT2",111,0) ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY "RTN","C0CVIT2",112,0) ; EXIST. "RTN","C0CVIT2",113,0) ; "RTN","C0CVIT2",114,0) ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) "RTN","C0CVIT2",115,0) ; "RTN","C0CVIT2",116,0) ; SETUP RPC/API CALL HERE "RTN","C0CVIT2",117,0) ; USE START AND END DATES FROM PARAMETERS IF REQUIRED "RTN","C0CVIT2",118,0) ; "RTN","C0CVIT2",119,0) ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE "RTN","C0CVIT2",120,0) ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE "RTN","C0CVIT2",121,0) N C0CEDT,C0CSDT,VIT,DATA,START,END "RTN","C0CVIT2",122,0) ; RPC REQUIRES FM DATES NOT T-* DATES "RTN","C0CVIT2",123,0) D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM "RTN","C0CVIT2",124,0) D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM "RTN","C0CVIT2",125,0) ; RPC OUTPUT FORMAT: "RTN","C0CVIT2",126,0) ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) "RTN","C0CVIT2",127,0) D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL "RTN","C0CVIT2",128,0) I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT "RTN","C0CVIT2",129,0) ; MOVE THE ARRAY TO LOCAL VARIABLE "RTN","C0CVIT2",130,0) M VIT=^TMP("CIAVMRPC",$J,0) "RTN","C0CVIT2",131,0) ; RPC CLEANUP "RTN","C0CVIT2",132,0) K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT "RTN","C0CVIT2",133,0) ; "RTN","C0CVIT2",134,0) ; PREFORM SORT HERE IF NEEDED "RTN","C0CVIT2",135,0) ; "RTN","C0CVIT2",136,0) ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST "RTN","C0CVIT2",137,0) ; COPIED SORT LOGIC: "RTN","C0CVIT2",138,0) N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX "RTN","C0CVIT2",139,0) D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY "RTN","C0CVIT2",140,0) S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE "RTN","C0CVIT2",141,0) ; VSORT IS VITALS IN REVERSE ORDER "RTN","C0CVIT2",142,0) ; "RTN","C0CVIT2",143,0) ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY "RTN","C0CVIT2",144,0) ; RNF1 ARRAY FORMAT: "RTN","C0CVIT2",145,0) ; VAR("NAME_OF_RIM_VARIABLE")=VALUE "RTN","C0CVIT2",146,0) ; "RTN","C0CVIT2",147,0) ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS "RTN","C0CVIT2",148,0) ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD "RTN","C0CVIT2",149,0) ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS "RTN","C0CVIT2",150,0) N C0CVI,C0CC,ZRNF "RTN","C0CVIT2",151,0) ;S C0CVI="" ; INITIALIZE FOR $O "RTN","C0CVIT2",152,0) F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST "RTN","C0CVIT2",153,0) . I DEBUG W VIT(C0CVI),! "RTN","C0CVIT2",154,0) . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) "RTN","C0CVIT2",155,0) . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT "RTN","C0CVIT2",156,0) . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT "RTN","C0CVIT2",157,0) . D:$P(VIT(C0CVI),U,3)="BP" BP "RTN","C0CVIT2",158,0) . D:$P(VIT(C0CVI),U,3)="TMP" TMP "RTN","C0CVIT2",159,0) . D:$P(VIT(C0CVI),U,3)="RS" RESP "RTN","C0CVIT2",160,0) . D:$P(VIT(C0CVI),U,3)="PU" PULSE "RTN","C0CVIT2",161,0) . D:$P(VIT(C0CVI),U,3)="PA" PAIN "RTN","C0CVIT2",162,0) . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER "RTN","C0CVIT2",163,0) . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY "RTN","C0CVIT2",164,0) . K ZRNF "RTN","C0CVIT2",165,0) ; SAVE RIM VARIABLES SEE C0CRIMA "RTN","C0CVIT2",166,0) N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) "RTN","C0CVIT2",167,0) M @ZRIM=@C0CVIT@("V") "RTN","C0CVIT2",168,0) Q "RTN","C0CVIT2",169,0) ; "RTN","C0CVIT2",170,0) HEIGHT "RTN","C0CVIT2",171,0) I DEBUG W "IN VITAL: HEIGHT",! "RTN","C0CVIT2",172,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID "RTN","C0CVIT2",173,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",174,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",175,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","C0CVIT2",176,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",177,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",178,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",179,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" "RTN","C0CVIT2",180,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",181,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",182,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",183,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",184,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",185,0) Q "RTN","C0CVIT2",186,0) ; "RTN","C0CVIT2",187,0) WEIGHT "RTN","C0CVIT2",188,0) I DEBUG W "IN VITAL: WEIGHT",! "RTN","C0CVIT2",189,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",190,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",191,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",192,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","C0CVIT2",193,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",194,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",195,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",196,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" "RTN","C0CVIT2",197,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",198,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",199,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",200,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",201,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",202,0) Q "RTN","C0CVIT2",203,0) ; "RTN","C0CVIT2",204,0) BP "RTN","C0CVIT2",205,0) I DEBUG W "IN VITAL: BLOOD PRESSURE",! "RTN","C0CVIT2",206,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",207,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",208,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",209,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","C0CVIT2",210,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",211,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",212,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",213,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" "RTN","C0CVIT2",214,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",215,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",216,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",217,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",218,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",219,0) Q "RTN","C0CVIT2",220,0) ; "RTN","C0CVIT2",221,0) TMP "RTN","C0CVIT2",222,0) I DEBUG W "IN VITAL: TEMPERATURE",! "RTN","C0CVIT2",223,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",224,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",225,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",226,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","C0CVIT2",227,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",228,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",229,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",230,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" "RTN","C0CVIT2",231,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",232,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",233,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",234,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",235,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",236,0) Q "RTN","C0CVIT2",237,0) ; "RTN","C0CVIT2",238,0) RESP "RTN","C0CVIT2",239,0) I DEBUG W "IN VITAL: RESPIRATION",! "RTN","C0CVIT2",240,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",241,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",242,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",243,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","C0CVIT2",244,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",245,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",246,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",247,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" "RTN","C0CVIT2",248,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",249,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",250,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",251,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",252,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",253,0) Q "RTN","C0CVIT2",254,0) ; "RTN","C0CVIT2",255,0) PULSE "RTN","C0CVIT2",256,0) I DEBUG W "IN VITAL: PULSE",! "RTN","C0CVIT2",257,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",258,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",259,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",260,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","C0CVIT2",261,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",262,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",263,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",264,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" "RTN","C0CVIT2",265,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",266,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",267,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",268,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",269,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",270,0) Q "RTN","C0CVIT2",271,0) ; "RTN","C0CVIT2",272,0) PAIN "RTN","C0CVIT2",273,0) I DEBUG W "IN VITAL: PAIN",! "RTN","C0CVIT2",274,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",275,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",276,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",277,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","C0CVIT2",278,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",279,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",280,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",281,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" "RTN","C0CVIT2",282,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",283,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",284,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",285,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",286,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",287,0) Q "RTN","C0CVIT2",288,0) ; "RTN","C0CVIT2",289,0) OTHER "RTN","C0CVIT2",290,0) I DEBUG W "IN VITAL: OTHER",! "RTN","C0CVIT2",291,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",292,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",293,0) S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") "RTN","C0CVIT2",294,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2) "RTN","C0CVIT2",295,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",296,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",297,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",298,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="" "RTN","C0CVIT2",299,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" "RTN","C0CVIT2",300,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",301,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) "RTN","C0CVIT2",302,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) "RTN","C0CVIT2",303,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) "RTN","C0CVIT2",304,0) Q "RTN","C0CVIT2",305,0) ; "RTN","C0CVIT2",306,0) ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE) "RTN","C0CVIT2",307,0) HEIGHT1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",308,0) I DEBUG W "IN VITAL: HEIGHT",! "RTN","C0CVIT2",309,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID "RTN","C0CVIT2",310,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",311,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",312,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","C0CVIT2",313,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",314,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",315,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",316,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" "RTN","C0CVIT2",317,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",318,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",319,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",320,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",321,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",322,0) Q "RTN","C0CVIT2",323,0) ; "RTN","C0CVIT2",324,0) WEIGHT1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",325,0) I DEBUG W "IN VITAL: WEIGHT",! "RTN","C0CVIT2",326,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",327,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",328,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",329,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","C0CVIT2",330,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",331,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",332,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",333,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" "RTN","C0CVIT2",334,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",335,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",336,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",337,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",338,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",339,0) Q "RTN","C0CVIT2",340,0) ; "RTN","C0CVIT2",341,0) BP1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",342,0) I DEBUG W "IN VITAL: BLOOD PRESSURE",! "RTN","C0CVIT2",343,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",344,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",345,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",346,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","C0CVIT2",347,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",348,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",349,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",350,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" "RTN","C0CVIT2",351,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",352,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",353,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",354,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",355,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",356,0) Q "RTN","C0CVIT2",357,0) ; "RTN","C0CVIT2",358,0) TMP1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",359,0) I DEBUG W "IN VITAL: TEMPERATURE",! "RTN","C0CVIT2",360,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",361,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",362,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",363,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","C0CVIT2",364,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",365,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",366,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",367,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" "RTN","C0CVIT2",368,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",369,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",370,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",371,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",372,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",373,0) Q "RTN","C0CVIT2",374,0) ; "RTN","C0CVIT2",375,0) RESP1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",376,0) I DEBUG W "IN VITAL: RESPIRATION",! "RTN","C0CVIT2",377,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",378,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",379,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",380,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","C0CVIT2",381,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",382,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",383,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",384,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" "RTN","C0CVIT2",385,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",386,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",387,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",388,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",389,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",390,0) Q "RTN","C0CVIT2",391,0) ; "RTN","C0CVIT2",392,0) PULSE1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",393,0) I DEBUG W "IN VITAL: PULSE",! "RTN","C0CVIT2",394,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",395,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",396,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",397,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","C0CVIT2",398,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",399,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",400,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",401,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" "RTN","C0CVIT2",402,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",403,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",404,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",405,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",406,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",407,0) Q "RTN","C0CVIT2",408,0) ; "RTN","C0CVIT2",409,0) PAIN1(DT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",410,0) I DEBUG W "IN VITAL: PAIN",! "RTN","C0CVIT2",411,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",412,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",413,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",414,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","C0CVIT2",415,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",416,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",417,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",418,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" "RTN","C0CVIT2",419,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVIT2",420,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",421,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",422,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",423,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",424,0) Q "RTN","C0CVIT2",425,0) ; "RTN","C0CVIT2",426,0) OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) "RTN","C0CVIT2",427,0) I DEBUG W "IN VITAL: OTHER",! "RTN","C0CVIT2",428,0) S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC "RTN","C0CVIT2",429,0) S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVIT2",430,0) S ZRNF("VITALSIGNSEXACTDATETIME")=DT "RTN","C0CVIT2",431,0) S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT "RTN","C0CVIT2",432,0) S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVIT2",433,0) S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC "RTN","C0CVIT2",434,0) S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVIT2",435,0) S ZRNF("VITALSIGNSDESCCODEVALUE")="" "RTN","C0CVIT2",436,0) S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" "RTN","C0CVIT2",437,0) S ZRNF("VITALSIGNSCODEVERSION")="" "RTN","C0CVIT2",438,0) S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR "RTN","C0CVIT2",439,0) S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE "RTN","C0CVIT2",440,0) S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT "RTN","C0CVIT2",441,0) Q "RTN","C0CVIT2",442,0) ; "RTN","C0CVIT2",443,0) VITSORT(VDT) ; RUN DATE SORTING ALGORITHM "RTN","C0CVIT2",444,0) ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY "RTN","C0CVIT2",445,0) ; OF DATES IN THE VITALS RESULTS "RTN","C0CVIT2",446,0) N VDTI,VDTJ,VTDCNT "RTN","C0CVIT2",447,0) S VTDCNT=0 ; COUNT TO BUILD ARRAY "RTN","C0CVIT2",448,0) S VDTJ="" ; USED TO VISIT THE RESULTS "RTN","C0CVIT2",449,0) F VDTI=0:0 D Q:$O(VIT(VDTJ))="" ; VISIT ALL RESULTS "RTN","C0CVIT2",450,0) . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT "RTN","C0CVIT2",451,0) . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER "RTN","C0CVIT2",452,0) . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE "RTN","C0CVIT2",453,0) S VDT(0)=VTDCNT "RTN","C0CVIT2",454,0) Q "RTN","C0CVIT2",455,0) ; "RTN","C0CVIT2",456,0) MAP(VITXML,C0CVIT,VITOUT) ; MAP VITAL SIGNS XML "RTN","C0CVIT2",457,0) ; "RTN","C0CVIT2",458,0) N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE "RTN","C0CVIT2",459,0) K @ZTEMP "RTN","C0CVIT2",460,0) N ZBLD "RTN","C0CVIT2",461,0) S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA "RTN","C0CVIT2",462,0) D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE "RTN","C0CVIT2",463,0) N ZINNER "RTN","C0CVIT2",464,0) ; XPATH NEEDS TO MATCH YOUR SECTION "RTN","C0CVIT2",465,0) D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN "RTN","C0CVIT2",466,0) N ZTMP,ZVAR,ZI "RTN","C0CVIT2",467,0) S ZI="" "RTN","C0CVIT2",468,0) F S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI="" D ;FOR EACH VITAL SIGN "RTN","C0CVIT2",469,0) . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML "RTN","C0CVIT2",470,0) . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES "RTN","C0CVIT2",471,0) . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN "RTN","C0CVIT2",472,0) . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD "RTN","C0CVIT2",473,0) D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0)) "RTN","C0CVIT2",474,0) N ZZTMP ; IS THIS NEEDED? "RTN","C0CVIT2",475,0) D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML "RTN","C0CVIT2",476,0) K @ZTEMP,@ZBLD "RTN","C0CVIT2",477,0) Q "RTN","C0CVIT2",478,0) ; "RTN","C0CVITAL") 0^66^B319933080 "RTN","C0CVITAL",1,0) C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 "RTN","C0CVITAL",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CVITAL",3,0) ;Copyright 2008,2009 George Lilly, University of Minnesota and others. "RTN","C0CVITAL",4,0) ;Licensed under the terms of the GNU General Public License. "RTN","C0CVITAL",5,0) ;See attached copy of the License. "RTN","C0CVITAL",6,0) ; "RTN","C0CVITAL",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CVITAL",8,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CVITAL",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CVITAL",10,0) ;(at your option) any later version. "RTN","C0CVITAL",11,0) ; "RTN","C0CVITAL",12,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CVITAL",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CVITAL",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CVITAL",15,0) ;GNU General Public License for more details. "RTN","C0CVITAL",16,0) ; "RTN","C0CVITAL",17,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CVITAL",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CVITAL",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CVITAL",20,0) ; "RTN","C0CVITAL",21,0) W "NO ENTRY FROM TOP",! "RTN","C0CVITAL",22,0) Q "RTN","C0CVITAL",23,0) ; "RTN","C0CVITAL",24,0) EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE "RTN","C0CVITAL",25,0) ; "RTN","C0CVITAL",26,0) ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","C0CVITAL",27,0) ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE "RTN","C0CVITAL",28,0) ; "RTN","C0CVITAL",29,0) N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR "RTN","C0CVITAL",30,0) S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM "RTN","C0CVITAL",31,0) S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM "RTN","C0CVITAL",32,0) D DT^DILF(,C0CVLMT,.C0CEDT) ; "RTN","C0CVITAL",33,0) D DT^DILF(,C0CVSTRT,.C0CSDT) ; "RTN","C0CVITAL",34,0) ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING "RTN","C0CVITAL",35,0) ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; "RTN","C0CVITAL",36,0) W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! "RTN","C0CVITAL",37,0) I $$RPMS^C0CUTIL() D VITRPMS QUIT "RTN","C0CVITAL",38,0) I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT "RTN","C0CVITAL",39,0) ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS "RTN","C0CVITAL",40,0) ;E D VITVISTA "RTN","C0CVITAL",41,0) Q "RTN","C0CVITAL",42,0) ; "RTN","C0CVITAL",43,0) VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE "RTN","C0CVITAL",44,0) D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT "RTN","C0CVITAL",45,0) ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS "RTN","C0CVITAL",46,0) ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) "RTN","C0CVITAL",47,0) ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) "RTN","C0CVITAL",48,0) ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES "RTN","C0CVITAL",49,0) I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT "RTN","C0CVITAL",50,0) I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC "RTN","C0CVITAL",51,0) . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! "RTN","C0CVITAL",52,0) . S @VITOUTXML@(0)=0 "RTN","C0CVITAL",53,0) I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT "RTN","C0CVITAL",54,0) ; ZWR RPCRSLT "RTN","C0CVITAL",55,0) S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) "RTN","C0CVITAL",56,0) S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) "RTN","C0CVITAL",57,0) K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES "RTN","C0CVITAL",58,0) N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX "RTN","C0CVITAL",59,0) D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY "RTN","C0CVITAL",60,0) I DEBUG ZWR VDATES ;DEBUG "RTN","C0CVITAL",61,0) S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE "RTN","C0CVITAL",62,0) ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY "RTN","C0CVITAL",63,0) S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS "RTN","C0CVITAL",64,0) F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST "RTN","C0CVITAL",65,0) . I $D(VITRSLT(VSORT(J))) D "RTN","C0CVITAL",66,0) . . S VITVMAP=$NA(@VITTVMAP@(J)) "RTN","C0CVITAL",67,0) . . K @VITVMAP "RTN","C0CVITAL",68,0) . . I DEBUG W "VMAP= ",VITVMAP,! "RTN","C0CVITAL",69,0) . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY "RTN","C0CVITAL",70,0) . . I DEBUG W "VITAL ",VSORT(J),! "RTN","C0CVITAL",71,0) . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! "RTN","C0CVITAL",72,0) . . I DEBUG W $P(VITPTMP,U,4),! "RTN","C0CVITAL",73,0) . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID "RTN","C0CVITAL",74,0) . . ;B ;gpl "RTN","C0CVITAL",75,0) . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) "RTN","C0CVITAL",76,0) . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; "RTN","C0CVITAL",77,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",78,0) . . I $P(VITPTMP,U,2)="HT" D "RTN","C0CVITAL",79,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",80,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",81,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","C0CVITAL",82,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",83,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",84,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",85,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","C0CVITAL",86,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" "RTN","C0CVITAL",87,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",88,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",89,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",90,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",91,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" "RTN","C0CVITAL",92,0) . . E I $P(VITPTMP,U,2)="WT" D "RTN","C0CVITAL",93,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",94,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",95,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","C0CVITAL",96,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",97,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",98,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",99,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","C0CVITAL",100,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" "RTN","C0CVITAL",101,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",102,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",103,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",104,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",105,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" "RTN","C0CVITAL",106,0) . . E I $P(VITPTMP,U,2)="BP" D "RTN","C0CVITAL",107,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",108,0) . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",109,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","C0CVITAL",110,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",111,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",112,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",113,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","C0CVITAL",114,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" "RTN","C0CVITAL",115,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",116,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",117,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",118,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",119,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","C0CVITAL",120,0) . . E I $P(VITPTMP,U,2)="T" D "RTN","C0CVITAL",121,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",122,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",123,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","C0CVITAL",124,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",125,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",126,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",127,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","C0CVITAL",128,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" "RTN","C0CVITAL",129,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",130,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",131,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",132,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",133,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" "RTN","C0CVITAL",134,0) . . E I $P(VITPTMP,U,2)="R" D "RTN","C0CVITAL",135,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",136,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",137,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","C0CVITAL",138,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",139,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",140,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",141,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","C0CVITAL",142,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" "RTN","C0CVITAL",143,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",144,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",145,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",146,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",147,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","C0CVITAL",148,0) . . E I $P(VITPTMP,U,2)="P" D "RTN","C0CVITAL",149,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",150,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",151,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","C0CVITAL",152,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",153,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",154,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",155,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","C0CVITAL",156,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" "RTN","C0CVITAL",157,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",158,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",159,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",160,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",161,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","C0CVITAL",162,0) . . E I $P(VITPTMP,U,2)="PN" D "RTN","C0CVITAL",163,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",164,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",165,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","C0CVITAL",166,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",167,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",168,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",169,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","C0CVITAL",170,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" "RTN","C0CVITAL",171,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",172,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",173,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",174,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",175,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","C0CVITAL",176,0) . . E I $P(VITPTMP,U,2)="BMI" D "RTN","C0CVITAL",177,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",178,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",179,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" "RTN","C0CVITAL",180,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",181,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",182,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",183,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" "RTN","C0CVITAL",184,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009" "RTN","C0CVITAL",185,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",186,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",187,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","C0CVITAL",188,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",189,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","C0CVITAL",190,0) . . E D "RTN","C0CVITAL",191,0) . . . ;W "IN VITAL: OTHER",! "RTN","C0CVITAL",192,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",193,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",194,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" "RTN","C0CVITAL",195,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",196,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",197,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" "RTN","C0CVITAL",198,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" "RTN","C0CVITAL",199,0) . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" "RTN","C0CVITAL",200,0) . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" "RTN","C0CVITAL",201,0) . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",202,0) . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) "RTN","C0CVITAL",203,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","C0CVITAL",204,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" "RTN","C0CVITAL",205,0) . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; "RTN","C0CVITAL",206,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; "RTN","C0CVITAL",207,0) . . S VITARYTMP=$NA(@VITTARYTMP@(J)) "RTN","C0CVITAL",208,0) . . K @VITARYTMP "RTN","C0CVITAL",209,0) . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) "RTN","C0CVITAL",210,0) . . I J=1 D ; FIRST ONE IS JUST A COPY "RTN","C0CVITAL",211,0) . . . ; W "FIRST ONE",! "RTN","C0CVITAL",212,0) . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) "RTN","C0CVITAL",213,0) . . . I DEBUG W "VITOUTXML ",VITOUTXML,! "RTN","C0CVITAL",214,0) . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CVITAL",215,0) . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) "RTN","C0CVITAL",216,0) ; ZWR ^TMP($J,"VITALS",*) "RTN","C0CVITAL",217,0) ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS "RTN","C0CVITAL",218,0) I DEBUG D PARY^C0CXPATH(VITOUTXML) "RTN","C0CVITAL",219,0) N VITTMP,I "RTN","C0CVITAL",220,0) D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CVITAL",221,0) I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CVITAL",222,0) . W "VITALS MISSING ",! "RTN","C0CVITAL",223,0) . F I=1:1:VITTMP(0) W VITTMP(I),! "RTN","C0CVITAL",224,0) Q "RTN","C0CVITAL",225,0) ; "RTN","C0CVITAL",226,0) VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE "RTN","C0CVITAL",227,0) ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE "RTN","C0CVITAL",228,0) ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE "RTN","C0CVITAL",229,0) N END,START,DATA "RTN","C0CVITAL",230,0) D DT^DILF("",C0CVLMT,.END) "RTN","C0CVITAL",231,0) D DT^DILF("",C0CVSTRT,.START) "RTN","C0CVITAL",232,0) ; RPC OUTPUT FORMAT: "RTN","C0CVITAL",233,0) ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) "RTN","C0CVITAL",234,0) D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL "RTN","C0CVITAL",235,0) I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT "RTN","C0CVITAL",236,0) ;ZW ^TMP("CIAVMRPC",$J) "RTN","C0CVITAL",237,0) S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) "RTN","C0CVITAL",238,0) S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) "RTN","C0CVITAL",239,0) K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES "RTN","C0CVITAL",240,0) N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX "RTN","C0CVITAL",241,0) D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY "RTN","C0CVITAL",242,0) S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE "RTN","C0CVITAL",243,0) ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY "RTN","C0CVITAL",244,0) S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS "RTN","C0CVITAL",245,0) F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST "RTN","C0CVITAL",246,0) . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D "RTN","C0CVITAL",247,0) . . S VITVMAP=$NA(@VITTVMAP@(J)) "RTN","C0CVITAL",248,0) . . K @VITVMAP "RTN","C0CVITAL",249,0) . . I DEBUG W "VMAP= ",VITVMAP,! "RTN","C0CVITAL",250,0) . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY "RTN","C0CVITAL",251,0) . . I DEBUG W "VITAL ",VSORT(J),! "RTN","C0CVITAL",252,0) . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! "RTN","C0CVITAL",253,0) . . I DEBUG W $P(VITPTMP,U,4),! "RTN","C0CVITAL",254,0) . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID "RTN","C0CVITAL",255,0) . . I $P(VITPTMP,U,3)="HT" D "RTN","C0CVITAL",256,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",257,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",258,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","C0CVITAL",259,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",260,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",261,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",262,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","C0CVITAL",263,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" "RTN","C0CVITAL",264,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",265,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",266,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",267,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",268,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",269,0) . . E I $P(VITPTMP,U,3)="WT" D "RTN","C0CVITAL",270,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",271,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",272,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","C0CVITAL",273,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",274,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",275,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",276,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","C0CVITAL",277,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" "RTN","C0CVITAL",278,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",279,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",280,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",281,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",282,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",283,0) . . E I $P(VITPTMP,U,3)="BP" D "RTN","C0CVITAL",284,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",285,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",286,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","C0CVITAL",287,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",288,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",289,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",290,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","C0CVITAL",291,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" "RTN","C0CVITAL",292,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",293,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",294,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",295,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",296,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",297,0) . . E I $P(VITPTMP,U,3)="TMP" D "RTN","C0CVITAL",298,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",299,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",300,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","C0CVITAL",301,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",302,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",303,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",304,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","C0CVITAL",305,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" "RTN","C0CVITAL",306,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",307,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",308,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",309,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",310,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",311,0) . . E I $P(VITPTMP,U,3)="RS" D "RTN","C0CVITAL",312,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",313,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",314,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","C0CVITAL",315,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",316,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",317,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",318,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","C0CVITAL",319,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" "RTN","C0CVITAL",320,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",321,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",322,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",323,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",324,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",325,0) . . E I $P(VITPTMP,U,3)="PU" D "RTN","C0CVITAL",326,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",327,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",328,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","C0CVITAL",329,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",330,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",331,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",332,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","C0CVITAL",333,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" "RTN","C0CVITAL",334,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",335,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",336,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",337,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",338,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",339,0) . . E I $P(VITPTMP,U,3)="PA" D "RTN","C0CVITAL",340,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",341,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",342,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","C0CVITAL",343,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",344,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",345,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",346,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","C0CVITAL",347,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" "RTN","C0CVITAL",348,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" "RTN","C0CVITAL",349,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",350,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",351,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",352,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",353,0) . . E D "RTN","C0CVITAL",354,0) . . . ;W "IN VITAL: OTHER",! "RTN","C0CVITAL",355,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","C0CVITAL",356,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") "RTN","C0CVITAL",357,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) "RTN","C0CVITAL",358,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","C0CVITAL",359,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","C0CVITAL",360,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","C0CVITAL",361,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) "RTN","C0CVITAL",362,0) . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" "RTN","C0CVITAL",363,0) . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" "RTN","C0CVITAL",364,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","C0CVITAL",365,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) "RTN","C0CVITAL",366,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) "RTN","C0CVITAL",367,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) "RTN","C0CVITAL",368,0) . . S VITARYTMP=$NA(@VITTARYTMP@(J)) "RTN","C0CVITAL",369,0) . . K @VITARYTMP "RTN","C0CVITAL",370,0) . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) "RTN","C0CVITAL",371,0) . . I J=1 D ; FIRST ONE IS JUST A COPY "RTN","C0CVITAL",372,0) . . . ; W "FIRST ONE",! "RTN","C0CVITAL",373,0) . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) "RTN","C0CVITAL",374,0) . . . I DEBUG W "VITOUTXML ",VITOUTXML,! "RTN","C0CVITAL",375,0) . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML "RTN","C0CVITAL",376,0) . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) "RTN","C0CVITAL",377,0) ; ZWR ^TMP($J,"VITALS",*) "RTN","C0CVITAL",378,0) ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS "RTN","C0CVITAL",379,0) I DEBUG D PARY^C0CXPATH(VITOUTXML) "RTN","C0CVITAL",380,0) N VITTMP,I "RTN","C0CVITAL",381,0) D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS "RTN","C0CVITAL",382,0) I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","C0CVITAL",383,0) . W "VITALS MISSING ",! "RTN","C0CVITAL",384,0) . F I=1:1:VITTMP(0) W VITTMP(I),! "RTN","C0CVITAL",385,0) K ^TMP("CIAVMRPC",$J) "RTN","C0CVITAL",386,0) Q "RTN","C0CVITAL",387,0) ; "RTN","C0CVITAL",388,0) VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS "RTN","C0CVITAL",389,0) ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY "RTN","C0CVITAL",390,0) ; OF DATES IN THE VITALS RESULTS "RTN","C0CVITAL",391,0) N VDTI,VDTJ,VTDCNT "RTN","C0CVITAL",392,0) S VTDCNT=0 ; COUNT TO BUILD ARRAY "RTN","C0CVITAL",393,0) S VDTJ="" ; USED TO VISIT THE RESULTS "RTN","C0CVITAL",394,0) F VDTI=0:0 D Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))="" ; VISIT ALL RESULTS "RTN","C0CVITAL",395,0) . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT "RTN","C0CVITAL",396,0) . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER "RTN","C0CVITAL",397,0) . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE "RTN","C0CVITAL",398,0) S VDT(0)=VTDCNT "RTN","C0CVITAL",399,0) Q "RTN","C0CVITAL",400,0) ; "RTN","C0CVITAL",401,0) VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA "RTN","C0CVITAL",402,0) ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY "RTN","C0CVITAL",403,0) ; OF DATES IN THE VITALS RESULTS "RTN","C0CVITAL",404,0) N VDTI,VDTJ,VTDCNT "RTN","C0CVITAL",405,0) S VTDCNT=0 ; COUNT TO BUILD ARRAY "RTN","C0CVITAL",406,0) S VDTJ="" ; USED TO VISIT THE RESULTS "RTN","C0CVITAL",407,0) F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS "RTN","C0CVITAL",408,0) . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT "RTN","C0CVITAL",409,0) . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER "RTN","C0CVITAL",410,0) . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE "RTN","C0CVITAL",411,0) S VDT(0)=VTDCNT "RTN","C0CVITAL",412,0) Q "RTN","C0CVITAL",413,0) ; "RTN","C0CVOBX1") 0^67^B12947698 "RTN","C0CVOBX1",1,0) LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 "RTN","C0CVOBX1",2,0) ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 1 "RTN","C0CVOBX1",3,0) ; JMC - mods to check for IHS V LAB file "RTN","C0CVOBX1",4,0) ; "RTN","C0CVOBX1",5,0) CH ; Observation/Result segment for "CH" subscript results. "RTN","C0CVOBX1",6,0) ; Called by LA7VOBX "RTN","C0CVOBX1",7,0) ; "RTN","C0CVOBX1",8,0) N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X "RTN","C0CVOBX1",9,0) ; "RTN","C0CVOBX1",10,0) ; "CH" subscript requires a dataname "RTN","C0CVOBX1",11,0) I '$G(LRSB) Q "RTN","C0CVOBX1",12,0) ; "RTN","C0CVOBX1",13,0) ; get result node from LR global. "RTN","C0CVOBX1",14,0) S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) "RTN","C0CVOBX1",15,0) S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) "RTN","C0CVOBX1",16,0) ; "RTN","C0CVOBX1",17,0) ; Check if test is OK to send - (O)utput or (B)oth "RTN","C0CVOBX1",18,0) S LA7X=$P(LA7VAL,"^",12) "RTN","C0CVOBX1",19,0) I LA7X]"","BO"'[LA7X Q "RTN","C0CVOBX1",20,0) I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q "RTN","C0CVOBX1",21,0) ; "RTN","C0CVOBX1",22,0) ; If no result NLT or LOINC try to determine from file #60 "RTN","C0CVOBX1",23,0) S LA7X=$P(LA7VAL,"^",3) "RTN","C0CVOBX1",24,0) ; WV check for IHS - NLT/LN codes from V LAB file "RTN","C0CVOBX1",25,0) I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q "RTN","C0CVOBX1",26,0) ; "RTN","C0CVOBX1",27,0) I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) "RTN","C0CVOBX1",28,0) ; No result NLT code - log error "RTN","C0CVOBX1",29,0) I $P($P(LA7VAL,"^",3),"!",2)="" D "RTN","C0CVOBX1",30,0) . N LA7X "RTN","C0CVOBX1",31,0) . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") "RTN","C0CVOBX1",32,0) . D CREATE^LA7LOG(36) "RTN","C0CVOBX1",33,0) ; "RTN","C0CVOBX1",34,0) ; something missing - No NLT code, etc. "RTN","C0CVOBX1",35,0) I LA7VAL="" Q "RTN","C0CVOBX1",36,0) ; "RTN","C0CVOBX1",37,0) ; Check for missing units/reference ranges "RTN","C0CVOBX1",38,0) S LA7X=$P(LA7VAL,"^",5) "RTN","C0CVOBX1",39,0) ; "RTN","C0CVOBX1",40,0) ; Results missing units, lookup in file #60 "RTN","C0CVOBX1",41,0) I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) "RTN","C0CVOBX1",42,0) ; "RTN","C0CVOBX1",43,0) ; If results missing reference ranges, use values from file #60. "RTN","C0CVOBX1",44,0) I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D "RTN","C0CVOBX1",45,0) . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) "RTN","C0CVOBX1",46,0) . S $P(LA7X,"!",2)=$P(LA7Y,"^") "RTN","C0CVOBX1",47,0) . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) "RTN","C0CVOBX1",48,0) . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) "RTN","C0CVOBX1",49,0) . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) "RTN","C0CVOBX1",50,0) ; Use therapeutic low/high if low/high missing. "RTN","C0CVOBX1",51,0) I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D "RTN","C0CVOBX1",52,0) . S $P(LA7X,"!",2)=$P(LA7X,"!",11) "RTN","C0CVOBX1",53,0) . S $P(LA7X,"!",3)=$P(LA7X,"!",12) "RTN","C0CVOBX1",54,0) ; "RTN","C0CVOBX1",55,0) ; Evaluate low/high reference ranges in case M code in these fields. "RTN","C0CVOBX1",56,0) S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 "RTN","C0CVOBX1",57,0) F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D "RTN","C0CVOBX1",58,0) . S @("X="_$P(LA7X,"!",LA7I)) "RTN","C0CVOBX1",59,0) . S $P(LA7X,"!",LA7I)=X "RTN","C0CVOBX1",60,0) ; "RTN","C0CVOBX1",61,0) ; Put units/reference ranges back in variable LA7VAL "RTN","C0CVOBX1",62,0) S $P(LA7VAL,"^",5)=LA7X "RTN","C0CVOBX1",63,0) ; "RTN","C0CVOBX1",64,0) ; Initialize OBX segment "RTN","C0CVOBX1",65,0) S LA7OBX(0)="OBX" "RTN","C0CVOBX1",66,0) S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) "RTN","C0CVOBX1",67,0) ; "RTN","C0CVOBX1",68,0) ; Value type "RTN","C0CVOBX1",69,0) S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) "RTN","C0CVOBX1",70,0) ; "RTN","C0CVOBX1",71,0) ; Observation identifer "RTN","C0CVOBX1",72,0) ; build alternate code based on dataname from file #63 in case it's needed "RTN","C0CVOBX1",73,0) S LA7X=$P(LA7VAL,"^",3) "RTN","C0CVOBX1",74,0) S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" "RTN","C0CVOBX1",75,0) S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) "RTN","C0CVOBX1",76,0) ; "RTN","C0CVOBX1",77,0) ; Test value "RTN","C0CVOBX1",78,0) S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH) "RTN","C0CVOBX1",79,0) ; "RTN","C0CVOBX1",80,0) ; Units - remove leading and trailing spaces "RTN","C0CVOBX1",81,0) S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ") "RTN","C0CVOBX1",82,0) S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) "RTN","C0CVOBX1",83,0) ; "RTN","C0CVOBX1",84,0) ; Reference range "RTN","C0CVOBX1",85,0) S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) "RTN","C0CVOBX1",86,0) ; "RTN","C0CVOBX1",87,0) ; Abnormal flags "RTN","C0CVOBX1",88,0) S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2)) "RTN","C0CVOBX1",89,0) ; "RTN","C0CVOBX1",90,0) ; "P"artial or "F"inal results "RTN","C0CVOBX1",91,0) S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F")) "RTN","C0CVOBX1",92,0) ; "RTN","C0CVOBX1",93,0) ; Observation date/time - collection date/time per HL7 standard "RTN","C0CVOBX1",94,0) I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) "RTN","C0CVOBX1",95,0) ; "RTN","C0CVOBX1",96,0) S LA7DIV=$P(LA7VAL,"^",9) "RTN","C0CVOBX1",97,0) I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) "RTN","C0CVOBX1",98,0) ; "RTN","C0CVOBX1",99,0) ; Facility that performed the testing "RTN","C0CVOBX1",100,0) S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) "RTN","C0CVOBX1",101,0) ; "RTN","C0CVOBX1",102,0) ; Person that verified the test "RTN","C0CVOBX1",103,0) S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) "RTN","C0CVOBX1",104,0) ; "RTN","C0CVOBX1",105,0) ; Observation method "RTN","C0CVOBX1",106,0) S LA7X=$P($P(LA7VAL,"^",3),"!",4) "RTN","C0CVOBX1",107,0) I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) "RTN","C0CVOBX1",108,0) ; "RTN","C0CVOBX1",109,0) ; Equipment entity identifier "RTN","C0CVOBX1",110,0) I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) "RTN","C0CVOBX1",111,0) ; "RTN","C0CVOBX1",112,0) D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) "RTN","C0CVOBX1",113,0) ; "RTN","C0CVOBX1",114,0) Q "RTN","C0CVORU") 0^68^B58596883 "RTN","C0CVORU",1,0) C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 "RTN","C0CVORU",2,0) ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1 "RTN","C0CVORU",3,0) ; "RTN","C0CVORU",4,0) EN(LA) ; called from C0CVLAB "RTN","C0CVORU",5,0) ; variables "RTN","C0CVORU",6,0) ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) "RTN","C0CVORU",7,0) ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) "RTN","C0CVORU",8,0) ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) "RTN","C0CVORU",9,0) ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) "RTN","C0CVORU",10,0) ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) "RTN","C0CVORU",11,0) ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) "RTN","C0CVORU",12,0) ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) "RTN","C0CVORU",13,0) ; LA("LRDFN") - IEN in LAB DATA file (#63) "RTN","C0CVORU",14,0) ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. "RTN","C0CVORU",15,0) ; LA("AUTO-INST") - Auto-Instrument "RTN","C0CVORU",16,0) ; "RTN","C0CVORU",17,0) N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY "RTN","C0CVORU",18,0) ; "RTN","C0CVORU",19,0) S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" "RTN","C0CVORU",20,0) I $G(PRIMARY)'="" D "RTN","C0CVORU",21,0) . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) "RTN","C0CVORU",22,0) . S PRIMARY=$P(PRIMARY,U,3) "RTN","C0CVORU",23,0) . S LA("AUTO-INST")="LA7V HOST "_PRIMARY "RTN","C0CVORU",24,0) ; "RTN","C0CVORU",25,0) I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q "RTN","C0CVORU",26,0) . ; need to add error logging when no entry in 63. "RTN","C0CVORU",27,0) ; "RTN","C0CVORU",28,0) ; Get zeroth node of entry in #63. "RTN","C0CVORU",29,0) S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) "RTN","C0CVORU",30,0) S LA7NLT=$G(LA("NLT")) "RTN","C0CVORU",31,0) ; "RTN","C0CVORU",32,0) S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) "RTN","C0CVORU",33,0) S LA7NTESN=0 "RTN","C0CVORU",34,0) D ORC "RTN","C0CVORU",35,0) ; "RTN","C0CVORU",36,0) I $G(LA("SUB"))="CH" D CH "RTN","C0CVORU",37,0) ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 "RTN","C0CVORU",38,0) ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 "RTN","C0CVORU",39,0) Q "RTN","C0CVORU",40,0) ; "RTN","C0CVORU",41,0) ; "RTN","C0CVORU",42,0) CH ; Build segments for "CH" subscript "RTN","C0CVORU",43,0) ; "RTN","C0CVORU",44,0) D OBR "RTN","C0CVORU",45,0) D NTE "RTN","C0CVORU",46,0) S LA7OBXSN=0 "RTN","C0CVORU",47,0) D OBX "RTN","C0CVORU",48,0) ; "RTN","C0CVORU",49,0) Q "RTN","C0CVORU",50,0) ; "RTN","C0CVORU",51,0) ; "RTN","C0CVORU",52,0) ORC ; Build ORC segment "RTN","C0CVORU",53,0) ; "RTN","C0CVORU",54,0) N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC "RTN","C0CVORU",55,0) ; "RTN","C0CVORU",56,0) S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) "RTN","C0CVORU",57,0) ; "RTN","C0CVORU",58,0) S ORC(0)="ORC" "RTN","C0CVORU",59,0) ; "RTN","C0CVORU",60,0) ; Order control "RTN","C0CVORU",61,0) S ORC(1)=$$ORC1^LA7VORC("RE") "RTN","C0CVORU",62,0) ; "RTN","C0CVORU",63,0) ; Remote UID "RTN","C0CVORU",64,0) S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) "RTN","C0CVORU",65,0) ; "RTN","C0CVORU",66,0) ; Host UID "RTN","C0CVORU",67,0) S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) "RTN","C0CVORU",68,0) ; "RTN","C0CVORU",69,0) ; Return shipping manifest if found "RTN","C0CVORU",70,0) S LA7SM="",LA7696=0 "RTN","C0CVORU",71,0) I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) "RTN","C0CVORU",72,0) I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) "RTN","C0CVORU",73,0) I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) "RTN","C0CVORU",74,0) ; "RTN","C0CVORU",75,0) ; Order status "RTN","C0CVORU",76,0) ; DoD/CHCS requires ORC-5 valued otherwise will not process message "RTN","C0CVORU",77,0) I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) "RTN","C0CVORU",78,0) ; "RTN","C0CVORU",79,0) ; Ordering provider "RTN","C0CVORU",80,0) S (LA7X,LA7Y)="" "RTN","C0CVORU",81,0) ; "CH" subscript stores requesting provider and requesting div/location. "RTN","C0CVORU",82,0) I LA("SUB")="CH" D "RTN","C0CVORU",83,0) . N LA7J "RTN","C0CVORU",84,0) . S LA7J=$P(LA763(0),"^",13) "RTN","C0CVORU",85,0) . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") "RTN","C0CVORU",86,0) . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") "RTN","C0CVORU",87,0) . S LA7X=$P(LA763(0),"^",10) "RTN","C0CVORU",88,0) ; "RTN","C0CVORU",89,0) ; Other subscripts only store requesting provider "RTN","C0CVORU",90,0) I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) "RTN","C0CVORU",91,0) ; Get default institution from MailMan Site Parameters file "RTN","C0CVORU",92,0) I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") "RTN","C0CVORU",93,0) S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",94,0) ; "RTN","C0CVORU",95,0) ; Entering organization "RTN","C0CVORU",96,0) S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",97,0) ; "RTN","C0CVORU",98,0) D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) "RTN","C0CVORU",99,0) D FILESEG^LA7VHLU(GBL,.LA7DATA) "RTN","C0CVORU",100,0) ; "RTN","C0CVORU",101,0) ; Check for flag to only build message but do not file "RTN","C0CVORU",102,0) I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) "RTN","C0CVORU",103,0) ; "RTN","C0CVORU",104,0) Q "RTN","C0CVORU",105,0) ; "RTN","C0CVORU",106,0) ; "RTN","C0CVORU",107,0) OBR ;Observation Request segment for Lab Order "RTN","C0CVORU",108,0) ; "RTN","C0CVORU",109,0) N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR "RTN","C0CVORU",110,0) ; "RTN","C0CVORU",111,0) ; Retrieve placer's OBR information stored in #69.6 "RTN","C0CVORU",112,0) D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) "RTN","C0CVORU",113,0) ; "RTN","C0CVORU",114,0) ; Initialize OBR segment "RTN","C0CVORU",115,0) S OBR(0)="OBR" "RTN","C0CVORU",116,0) S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) "RTN","C0CVORU",117,0) ; "RTN","C0CVORU",118,0) ; Remote UID "RTN","C0CVORU",119,0) S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) "RTN","C0CVORU",120,0) ; "RTN","C0CVORU",121,0) ; Host UID "RTN","C0CVORU",122,0) S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) "RTN","C0CVORU",123,0) ; "RTN","C0CVORU",124,0) ; Universal service ID, build from info stored in #69.6 "RTN","C0CVORU",125,0) S LA7X="" "RTN","C0CVORU",126,0) I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) "RTN","C0CVORU",127,0) E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) "RTN","C0CVORU",128,0) ; "RTN","C0CVORU",129,0) ; Collection D/T "RTN","C0CVORU",130,0) S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) "RTN","C0CVORU",131,0) ; "RTN","C0CVORU",132,0) ; Specimen action code "RTN","C0CVORU",133,0) ; If no OBR from PENDING ORDER file (#69.6) then assume added test. "RTN","C0CVORU",134,0) I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") "RTN","C0CVORU",135,0) ; "RTN","C0CVORU",136,0) ; Infection Warning "RTN","C0CVORU",137,0) S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) "RTN","C0CVORU",138,0) ; "RTN","C0CVORU",139,0) ; Lab Arrival Time "RTN","C0CVORU",140,0) ; "CH" subscript does not store lab arrival time, use collection time. "RTN","C0CVORU",141,0) ; Other subscripts do store lab arrival time (date/time received). "RTN","C0CVORU",142,0) I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) "RTN","C0CVORU",143,0) I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) "RTN","C0CVORU",144,0) ; "RTN","C0CVORU",145,0) ; Specimen source "RTN","C0CVORU",146,0) S (LA761,LA762)="" "RTN","C0CVORU",147,0) I "CHMI"[LA("SUB") D "RTN","C0CVORU",148,0) . S LA761=$P(LA763(0),U,5) "RTN","C0CVORU",149,0) . I LA761="" D CREATE^LA7LOG(27) "RTN","C0CVORU",150,0) . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) "RTN","C0CVORU",151,0) S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) "RTN","C0CVORU",152,0) ; "RTN","C0CVORU",153,0) ; Ordering provider "RTN","C0CVORU",154,0) S (LA7X,LA7Y)="" "RTN","C0CVORU",155,0) ; "CH" subscript stores requesting provider and requesting div/location. "RTN","C0CVORU",156,0) I LA("SUB")="CH" D "RTN","C0CVORU",157,0) . N LA7J "RTN","C0CVORU",158,0) . S LA7J=$P(LA763(0),"^",13) "RTN","C0CVORU",159,0) . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") "RTN","C0CVORU",160,0) . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") "RTN","C0CVORU",161,0) . S LA7X=$P(LA763(0),"^",10) "RTN","C0CVORU",162,0) ; "RTN","C0CVORU",163,0) ; Other subscripts only store requesting provider "RTN","C0CVORU",164,0) I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) "RTN","C0CVORU",165,0) ; Get default institution from MailMan Site Parameters file "RTN","C0CVORU",166,0) I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") "RTN","C0CVORU",167,0) S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",168,0) ; "RTN","C0CVORU",169,0) ; Placer Field #1 (remote auto-inst) "RTN","C0CVORU",170,0) ; Build from info stored in #69.6 "RTN","C0CVORU",171,0) I $G(LA7PLOBR("OBR-18"))'="" D "RTN","C0CVORU",172,0) . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) "RTN","C0CVORU",173,0) ; Else build "auto instrument" if sending to VA facility "RTN","C0CVORU",174,0) I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D "RTN","C0CVORU",175,0) . N LA7X "RTN","C0CVORU",176,0) . S LA7X(1)=LA("AUTO-INST") "RTN","C0CVORU",177,0) . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) "RTN","C0CVORU",178,0) ; "RTN","C0CVORU",179,0) ; Placer Field #2 "RTN","C0CVORU",180,0) I $G(LA7PLOBR("OBR-19"))'="" D "RTN","C0CVORU",181,0) . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) "RTN","C0CVORU",182,0) ; Else build collecting UID if sending to VA facility "RTN","C0CVORU",183,0) I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D "RTN","C0CVORU",184,0) . K LA7X "RTN","C0CVORU",185,0) . S LA7X(7)=LA("RUID") "RTN","C0CVORU",186,0) . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) "RTN","C0CVORU",187,0) ; "RTN","C0CVORU",188,0) ; Filler Field #1 "RTN","C0CVORU",189,0) ; Send file #63 ien info - used by HDR to track patient/specimen "RTN","C0CVORU",190,0) K LA7X "RTN","C0CVORU",191,0) S LA7X(1)=LA("LRDFN") "RTN","C0CVORU",192,0) S LA7X(2)=LA("SUB") "RTN","C0CVORU",193,0) S LA7X(3)=LA("LRIDT") "RTN","C0CVORU",194,0) S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) "RTN","C0CVORU",195,0) ; "RTN","C0CVORU",196,0) ; Date Report Completed "RTN","C0CVORU",197,0) I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) "RTN","C0CVORU",198,0) ; "RTN","C0CVORU",199,0) ; Diagnostic service id "RTN","C0CVORU",200,0) S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) "RTN","C0CVORU",201,0) ; "RTN","C0CVORU",202,0) ; Parent Result and Parent "RTN","C0CVORU",203,0) I $D(LA7PARNT) D "RTN","C0CVORU",204,0) . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) "RTN","C0CVORU",205,0) . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) "RTN","C0CVORU",206,0) ; "RTN","C0CVORU",207,0) ; Principle result interpreter "RTN","C0CVORU",208,0) ; Get default institution from MailMan Site Parameters file "RTN","C0CVORU",209,0) I "CYEMMISP"[LA("SUB") D "RTN","C0CVORU",210,0) . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) "RTN","C0CVORU",211,0) . E S LA7X=$P(LA763(0),"^",2) "RTN","C0CVORU",212,0) . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") "RTN","C0CVORU",213,0) . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",214,0) ; "RTN","C0CVORU",215,0) ; Assistant result interpreter "RTN","C0CVORU",216,0) ; Get default institution from MailMan Site Parameters file "RTN","C0CVORU",217,0) I "EMSP"[LA("SUB") D "RTN","C0CVORU",218,0) . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") "RTN","C0CVORU",219,0) . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",220,0) ; "RTN","C0CVORU",221,0) ; Technician "RTN","C0CVORU",222,0) ; Get default institution from MailMan Site Parameters file "RTN","C0CVORU",223,0) I "CYEM"[LA("SUB") D "RTN","C0CVORU",224,0) . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") "RTN","C0CVORU",225,0) . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",226,0) ; "RTN","C0CVORU",227,0) ; Typist - VistA stores as free text "RTN","C0CVORU",228,0) ; Get default institution from MailMan Site Parameters file "RTN","C0CVORU",229,0) I "CYEMSP"[LA("SUB") D "RTN","C0CVORU",230,0) . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") "RTN","C0CVORU",231,0) . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) "RTN","C0CVORU",232,0) ; "RTN","C0CVORU",233,0) D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) "RTN","C0CVORU",234,0) D FILESEG^LA7VHLU(GBL,.LA7DATA) "RTN","C0CVORU",235,0) ; "RTN","C0CVORU",236,0) ; Check for flag to only build message but do not file "RTN","C0CVORU",237,0) I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) "RTN","C0CVORU",238,0) ; "RTN","C0CVORU",239,0) Q "RTN","C0CVORU",240,0) ; "RTN","C0CVORU",241,0) ; "RTN","C0CVORU",242,0) OBX ;Observation/Result segment for Lab Results "RTN","C0CVORU",243,0) ; "RTN","C0CVORU",244,0) N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X "RTN","C0CVORU",245,0) ; "RTN","C0CVORU",246,0) S LA7VTIEN=0 "RTN","C0CVORU",247,0) F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D "RTN","C0CVORU",248,0) . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) "RTN","C0CVORU",249,0) . ; Build OBX segment "RTN","C0CVORU",250,0) . K LA7DATA "RTN","C0CVORU",251,0) . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) "RTN","C0CVORU",252,0) . ; If OBX failed to build then don't store "RTN","C0CVORU",253,0) . I '$D(LA7DATA) Q "RTN","C0CVORU",254,0) . ; "RTN","C0CVORU",255,0) . D FILESEG^LA7VHLU(GBL,.LA7DATA) "RTN","C0CVORU",256,0) . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) "RTN","C0CVORU",257,0) . ; "RTN","C0CVORU",258,0) . ; Send performing lab comment and interpretation from file #60 "RTN","C0CVORU",259,0) . S LA7NTESN=0 "RTN","C0CVORU",260,0) . I LA7NVAF=1 D PLC^LA7VORUA "RTN","C0CVORU",261,0) . D INTRP^LA7VORUA "RTN","C0CVORU",262,0) . ; "RTN","C0CVORU",263,0) . ; Mark result as sent - set to 1, if corrected results set to 2 "RTN","C0CVORU",264,0) . I LA("SUB")="CH" D "RTN","C0CVORU",265,0) . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q "RTN","C0CVORU",266,0) . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) "RTN","C0CVORU",267,0) ; "RTN","C0CVORU",268,0) Q "RTN","C0CVORU",269,0) ; "RTN","C0CVORU",270,0) ; "RTN","C0CVORU",271,0) NTE ; Build NTE segment "RTN","C0CVORU",272,0) ; "RTN","C0CVORU",273,0) D NTE^LA7VORUA "RTN","C0CVORU",274,0) Q "RTN","C0CXEWD") 0^69^B15380480 "RTN","C0CXEWD",1,0) C0CXEWD ; C0C/GPL - EWD based XPath utilities; 10/11/09 "RTN","C0CXEWD",2,0) ;;0.1;C0C;nopatch;noreleasedate;Build 1 "RTN","C0CXEWD",3,0) ;Copyright 2009 George Lilly. Licensed under the terms of the GNU "RTN","C0CXEWD",4,0) ;General Public License See attached copy of the License. "RTN","C0CXEWD",5,0) ; "RTN","C0CXEWD",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CXEWD",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CXEWD",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CXEWD",9,0) ;(at your option) any later version. "RTN","C0CXEWD",10,0) ; "RTN","C0CXEWD",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CXEWD",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CXEWD",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CXEWD",14,0) ;GNU General Public License for more details. "RTN","C0CXEWD",15,0) ; "RTN","C0CXEWD",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CXEWD",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CXEWD",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CXEWD",19,0) ; "RTN","C0CXEWD",20,0) Q "RTN","C0CXEWD",21,0) ; "RTN","C0CXEWD",22,0) TEST ; "RTN","C0CXEWD",23,0) D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY") "RTN","C0CXEWD",24,0) Q "RTN","C0CXEWD",25,0) ; "RTN","C0CXEWD",26,0) TEST2 ; "RTN","C0CXEWD",27,0) S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" "RTN","C0CXEWD",28,0) D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX) "RTN","C0CXEWD",29,0) Q "RTN","C0CXEWD",30,0) ; "RTN","C0CXEWD",31,0) XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE "RTN","C0CXEWD",32,0) ; THE XPATH INDEX ZXIDX, PASSED BY NAME "RTN","C0CXEWD",33,0) ; THE XPATH ARRAY XPARY, PASSED BY NAME "RTN","C0CXEWD",34,0) ; ZOID IS THE STARTING OID "RTN","C0CXEWD",35,0) ; ZPATH IS THE STARTING XPATH, USUALLY "/" "RTN","C0CXEWD",36,0) ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE "RTN","C0CXEWD",37,0) ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT "RTN","C0CXEWD",38,0) I '$D(ZREDUX) S ZREDUX="" "RTN","C0CXEWD",39,0) N NEWPATH "RTN","C0CXEWD",40,0) N NEWNUM S NEWNUM="" "RTN","C0CXEWD",41,0) I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" "RTN","C0CXEWD",42,0) S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE "RTN","C0CXEWD",43,0) I $G(ZREDUX)'="" D ; REDUX PROVIDED? "RTN","C0CXEWD",44,0) . N GT S GT=$P(NEWPATH,ZREDUX,2) "RTN","C0CXEWD",45,0) . I GT'="" S NEWPATH=GT "RTN","C0CXEWD",46,0) S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX "RTN","C0CXEWD",47,0) N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE "RTN","C0CXEWD",48,0) I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY "RTN","C0CXEWD",49,0) E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY "RTN","C0CXEWD",50,0) I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY "RTN","C0CXEWD",51,0) N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD "RTN","C0CXEWD",52,0) I ZFRST'="" D ; THERE IS A CHILD "RTN","C0CXEWD",53,0) . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE "RTN","C0CXEWD",54,0) . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD "RTN","C0CXEWD",55,0) N GNXT S GNXT=$$NXTSIB(ZOID) "RTN","C0CXEWD",56,0) I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING "RTN","C0CXEWD",57,0) . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB "RTN","C0CXEWD",58,0) Q "RTN","C0CXEWD",59,0) ; "RTN","C0CXEWD",60,0) PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME "RTN","C0CXEWD",61,0) ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD "RTN","C0CXEWD",62,0) ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD "RTN","C0CXEWD",63,0) N ZR "RTN","C0CXEWD",64,0) M ^CacheTempEWD($j)=@INXML ; "RTN","C0CXEWD",65,0) S ZR=$$parseDocument^%zewdHTMLParser(INDOC) "RTN","C0CXEWD",66,0) Q ZR "RTN","C0CXEWD",67,0) ; "RTN","C0CXEWD",68,0) ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE "RTN","C0CXEWD",69,0) N ZN "RTN","C0CXEWD",70,0) S ZN=$$NXTSIB(ZOID) "RTN","C0CXEWD",71,0) I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG "RTN","C0CXEWD",72,0) Q 0 "RTN","C0CXEWD",73,0) ; "RTN","C0CXEWD",74,0) DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME "RTN","C0CXEWD",75,0) N DET "RTN","C0CXEWD",76,0) D getElementDetails^%zewdXPath(ZOID,.DET) "RTN","C0CXEWD",77,0) M @ZRTN=DET "RTN","C0CXEWD",78,0) Q "RTN","C0CXEWD",79,0) ; "RTN","C0CXEWD",80,0) ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME "RTN","C0CXEWD",81,0) Q $$getDocumentNode^%zewdDOM(ZNAME) "RTN","C0CXEWD",82,0) ; "RTN","C0CXEWD",83,0) NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID "RTN","C0CXEWD",84,0) Q $$getDocumentName^%zewdDOM(ZOID) "RTN","C0CXEWD",85,0) ; "RTN","C0CXEWD",86,0) FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID "RTN","C0CXEWD",87,0) N GOID "RTN","C0CXEWD",88,0) S GOID=ZOID "RTN","C0CXEWD",89,0) S GOID=$$getFirstChild^%zewdDOM(GOID) "RTN","C0CXEWD",90,0) I GOID="" Q "" "RTN","C0CXEWD",91,0) I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) "RTN","C0CXEWD",92,0) Q GOID "RTN","C0CXEWD",93,0) ; "RTN","C0CXEWD",94,0) HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES "RTN","C0CXEWD",95,0) Q $$hasChildNodes^%zewdDOM(ZOID) "RTN","C0CXEWD",96,0) ; "RTN","C0CXEWD",97,0) CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME "RTN","C0CXEWD",98,0) N childArray "RTN","C0CXEWD",99,0) d getChildrenInOrder^%zewdDOM(ZOID,.childArray) "RTN","C0CXEWD",100,0) m @ZRTN=childArray "RTN","C0CXEWD",101,0) q "RTN","C0CXEWD",102,0) ; "RTN","C0CXEWD",103,0) TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE "RTN","C0CXEWD",104,0) Q $$getName^%zewdDOM(ZOID) "RTN","C0CXEWD",105,0) ; "RTN","C0CXEWD",106,0) NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING "RTN","C0CXEWD",107,0) Q $$getNextSibling^%zewdDOM(ZOID) "RTN","C0CXEWD",108,0) ; "RTN","C0CXEWD",109,0) NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR "RTN","C0CXEWD",110,0) N GOID "RTN","C0CXEWD",111,0) S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID) "RTN","C0CXEWD",112,0) I GOID="" Q "" "RTN","C0CXEWD",113,0) I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) "RTN","C0CXEWD",114,0) Q GOID "RTN","C0CXEWD",115,0) ; "RTN","C0CXEWD",116,0) PARENT(ZOID) ; RETURNS PARENT OF ZOID "RTN","C0CXEWD",117,0) Q $$getParentNode^%zewdDOM(ZOID) "RTN","C0CXEWD",118,0) ; "RTN","C0CXEWD",119,0) DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE "RTN","C0CXEWD",120,0) N ZT2 "RTN","C0CXEWD",121,0) S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2) "RTN","C0CXEWD",122,0) M @ZT=ZT2 "RTN","C0CXEWD",123,0) Q "RTN","C0CXEWD",124,0) ;Q $$getTextValue^%zewdXPath(ZOID) "RTN","C0CXEWD",125,0) ;Q $$getData^%zewdDOM(ZOID,.ZT) "RTN","C0CXEWD",126,0) ; "RTN","C0CXPAT0") 0^70^B50736852 "RTN","C0CXPAT0",1,0) C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 "RTN","C0CXPAT0",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CXPAT0",3,0) ;Copyright 2008 George Lilly. Licensed under the terms of the GNU "RTN","C0CXPAT0",4,0) ;General Public License See attached copy of the License. "RTN","C0CXPAT0",5,0) ; "RTN","C0CXPAT0",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CXPAT0",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CXPAT0",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CXPAT0",9,0) ;(at your option) any later version. "RTN","C0CXPAT0",10,0) ; "RTN","C0CXPAT0",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CXPAT0",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CXPAT0",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CXPAT0",14,0) ;GNU General Public License for more details. "RTN","C0CXPAT0",15,0) ; "RTN","C0CXPAT0",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CXPAT0",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CXPAT0",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CXPAT0",19,0) ; "RTN","C0CXPAT0",20,0) W "NO ENTRY",! "RTN","C0CXPAT0",21,0) Q "RTN","C0CXPAT0",22,0) ; "RTN","C0CXPAT0",23,0) ;;> "RTN","C0CXPAT0",24,0) ;;> "RTN","C0CXPAT0",25,0) ;;>>>K C0C S C0C="" "RTN","C0CXPAT0",26,0) ;;>>>D PUSH^C0CXPATH("C0C","FIRST") "RTN","C0CXPAT0",27,0) ;;>>>D PUSH^C0CXPATH("C0C","SECOND") "RTN","C0CXPAT0",28,0) ;;>>>D PUSH^C0CXPATH("C0C","THIRD") "RTN","C0CXPAT0",29,0) ;;>>>D PUSH^C0CXPATH("C0C","FOURTH") "RTN","C0CXPAT0",30,0) ;;>>?C0C(0)=4 "RTN","C0CXPAT0",31,0) ;;> "RTN","C0CXPAT0",32,0) ;;>>>K GXML S GXML="" "RTN","C0CXPAT0",33,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",34,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",35,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",36,0) ;;>>>D PUSH^C0CXPATH("GXML","@@DATA1@@") "RTN","C0CXPAT0",37,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",38,0) ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@") "RTN","C0CXPAT0",39,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",40,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",41,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",42,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",43,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",44,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",45,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",46,0) ;;> "RTN","C0CXPAT0",47,0) ;;>>>K GXML S GXML="" "RTN","C0CXPAT0",48,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",49,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",50,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",51,0) ;;>>>D PUSH^C0CXPATH("GXML","DATA1") "RTN","C0CXPAT0",52,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",53,0) ;;>>>D PUSH^C0CXPATH("GXML","DATA2") "RTN","C0CXPAT0",54,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",55,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",56,0) ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>") "RTN","C0CXPAT0",57,0) ;;>>>D PUSH^C0CXPATH("GXML","DATA3") "RTN","C0CXPAT0",58,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",59,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",60,0) ;;>>>D PUSH^C0CXPATH("GXML","") "RTN","C0CXPAT0",61,0) ;;> "RTN","C0CXPAT0",62,0) ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") "RTN","C0CXPAT0",63,0) ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT") "RTN","C0CXPAT0",64,0) ;;>>?C0C(C0C(0))="FOURTH" "RTN","C0CXPAT0",65,0) ;;>>>D POP^C0CXPATH("C0C",.GX) "RTN","C0CXPAT0",66,0) ;;>>?GX="FOURTH" "RTN","C0CXPAT0",67,0) ;;>>?C0C(C0C(0))="THIRD" "RTN","C0CXPAT0",68,0) ;;>>>D POP^C0CXPATH("C0C",.GX) "RTN","C0CXPAT0",69,0) ;;>>?GX="THIRD" "RTN","C0CXPAT0",70,0) ;;>>?C0C(C0C(0))="SECOND" "RTN","C0CXPAT0",71,0) ;;> "RTN","C0CXPAT0",72,0) ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") "RTN","C0CXPAT0",73,0) ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT") "RTN","C0CXPAT0",74,0) ;;>>>S GX="" "RTN","C0CXPAT0",75,0) ;;>>>D MKMDX^C0CXPATH("C0C",.GX) "RTN","C0CXPAT0",76,0) ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" "RTN","C0CXPAT0",77,0) ;;> "RTN","C0CXPAT0",78,0) ;;>>?$$XNAME^C0CXPATH("DATA1")="FOURTH" "RTN","C0CXPAT0",79,0) ;;>>?$$XNAME^C0CXPATH("")="SIXTH" "RTN","C0CXPAT0",80,0) ;;>>?$$XNAME^C0CXPATH("")="THIRD" "RTN","C0CXPAT0",81,0) ;;> "RTN","C0CXPAT0",82,0) ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") "RTN","C0CXPAT0",83,0) ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INITXML") "RTN","C0CXPAT0",84,0) ;;>>>D INDEX^C0CXPATH("GXML") "RTN","C0CXPAT0",85,0) ;;>>?GXML("//FIRST/SECOND")="2^12" "RTN","C0CXPAT0",86,0) ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9" "RTN","C0CXPAT0",87,0) ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7" "RTN","C0CXPAT0",88,0) ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4^@@DATA1@@" "RTN","C0CXPAT0",89,0) ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8^" "RTN","C0CXPAT0",90,0) ;;>>?GXML("//FIRST/SECOND")="2^12" "RTN","C0CXPAT0",91,0) ;;>>?GXML("//FIRST")="1^13" "RTN","C0CXPAT0",92,0) ;;> "RTN","C0CXPAT0",93,0) ;;>>>D ZTEST^C0CXPATH("INITXML2") "RTN","C0CXPAT0",94,0) ;;>>>D INDEX^C0CXPATH("GXML") "RTN","C0CXPAT0",95,0) ;;>>?GXML("//FIRST/SECOND")="2^12" "RTN","C0CXPAT0",96,0) ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11" "RTN","C0CXPAT0",97,0) ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10^DATA3" "RTN","C0CXPAT0",98,0) ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8" "RTN","C0CXPAT0",99,0) ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH[1]")="4^4^DATA1" "RTN","C0CXPAT0",100,0) ;;>>?GXML("//FIRST")="1^13" "RTN","C0CXPAT0",101,0) ;;> "RTN","C0CXPAT0",102,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",103,0) ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" "RTN","C0CXPAT0",104,0) ;;>>>D MISSING^C0CXPATH("GXML",OUTARY) "RTN","C0CXPAT0",105,0) ;;>>?@OUTARY@(1)="DATA1" "RTN","C0CXPAT0",106,0) ;;>>?@OUTARY@(2)="DATA2" "RTN","C0CXPAT0",107,0) ;;> "RTN","C0CXPAT0",108,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",109,0) ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" "RTN","C0CXPAT0",110,0) ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" "RTN","C0CXPAT0",111,0) ;;>>>S @MAPARY@("DATA2")="VALUE2" "RTN","C0CXPAT0",112,0) ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY) "RTN","C0CXPAT0",113,0) ;;>>?@OUTARY@(6)="VALUE2" "RTN","C0CXPAT0",114,0) ;;> "RTN","C0CXPAT0",115,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",116,0) ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" "RTN","C0CXPAT0",117,0) ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" "RTN","C0CXPAT0",118,0) ;;>>>S @MAPARY@("DATA1")="VALUE1" "RTN","C0CXPAT0",119,0) ;;>>>S @MAPARY@("DATA2")="VALUE2" "RTN","C0CXPAT0",120,0) ;;>>>S @MAPARY@("DATA3")="VALUE3" "RTN","C0CXPAT0",121,0) ;;>>>S GXML(4)="@@DATA1@@ AND @@DATA3@@" "RTN","C0CXPAT0",122,0) ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY) "RTN","C0CXPAT0",123,0) ;;>>>D PARY^C0CXPATH(OUTARY) "RTN","C0CXPAT0",124,0) ;;>>?@OUTARY@(4)="VALUE1 AND VALUE3" "RTN","C0CXPAT0",125,0) ;;> "RTN","C0CXPAT0",126,0) ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3) "RTN","C0CXPAT0",127,0) ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5) "RTN","C0CXPAT0",128,0) ;;>>?$P(BTLIST(2),";",2)=4 "RTN","C0CXPAT0",129,0) ;;> "RTN","C0CXPAT0",130,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",131,0) ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") "RTN","C0CXPAT0",132,0) ;;>>>D ZTEST^C0CXPATH("QUEUE") "RTN","C0CXPAT0",133,0) ;;>>>D BUILD^C0CXPATH("BTLIST","G3") "RTN","C0CXPAT0",134,0) ;;> "RTN","C0CXPAT0",135,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",136,0) ;;>>>D CP^C0CXPATH("GXML","G2") "RTN","C0CXPAT0",137,0) ;;>>?G2(0)=13 "RTN","C0CXPAT0",138,0) ;;> "RTN","C0CXPAT0",139,0) ;;>>>K G2,GBL "RTN","C0CXPAT0",140,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",141,0) ;;>>>D QOPEN^C0CXPATH("GBL","GXML") "RTN","C0CXPAT0",142,0) ;;>>?$P(GBL(1),";",3)=12 "RTN","C0CXPAT0",143,0) ;;>>>D BUILD^C0CXPATH("GBL","G2") "RTN","C0CXPAT0",144,0) ;;>>?G2(G2(0))="" "RTN","C0CXPAT0",145,0) ;;> "RTN","C0CXPAT0",146,0) ;;>>>K G2,GBL "RTN","C0CXPAT0",147,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",148,0) ;;>>>D QOPEN^C0CXPATH("GBL","GXML","//FIRST/SECOND") "RTN","C0CXPAT0",149,0) ;;>>?$P(GBL(1),";",3)=11 "RTN","C0CXPAT0",150,0) ;;>>>D BUILD^C0CXPATH("GBL","G2") "RTN","C0CXPAT0",151,0) ;;>>?G2(G2(0))="" "RTN","C0CXPAT0",152,0) ;;> "RTN","C0CXPAT0",153,0) ;;>>>K G2,GBL "RTN","C0CXPAT0",154,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",155,0) ;;>>>D QCLOSE^C0CXPATH("GBL","GXML") "RTN","C0CXPAT0",156,0) ;;>>?$P(GBL(1),";",3)=13 "RTN","C0CXPAT0",157,0) ;;>>>D BUILD^C0CXPATH("GBL","G2") "RTN","C0CXPAT0",158,0) ;;>>?G2(G2(0))="" "RTN","C0CXPAT0",159,0) ;;> "RTN","C0CXPAT0",160,0) ;;>>>K G2,GBL "RTN","C0CXPAT0",161,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",162,0) ;;>>>D QCLOSE^C0CXPATH("GBL","GXML","//FIRST/SECOND/THIRD") "RTN","C0CXPAT0",163,0) ;;>>?$P(GBL(1),";",3)=13 "RTN","C0CXPAT0",164,0) ;;>>>D BUILD^C0CXPATH("GBL","G2") "RTN","C0CXPAT0",165,0) ;;>>?G2(G2(0))="" "RTN","C0CXPAT0",166,0) ;;>>?G2(1)="" "RTN","C0CXPAT0",167,0) ;;> "RTN","C0CXPAT0",168,0) ;;>>>K G2,GBL,G3,G4 "RTN","C0CXPAT0",169,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",170,0) ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") "RTN","C0CXPAT0",171,0) ;;>>>D INSERT^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD") "RTN","C0CXPAT0",172,0) ;;>>>D INSERT^C0CXPATH("G3","G2","//") "RTN","C0CXPAT0",173,0) ;;>>?G2(1)=GXML(9) "RTN","C0CXPAT0",174,0) ;;> "RTN","C0CXPAT0",175,0) ;;>>>K G2,GBL,G3 "RTN","C0CXPAT0",176,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",177,0) ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") "RTN","C0CXPAT0",178,0) ;;>>>D REPLACE^C0CXPATH("GXML","G2","//FIRST/SECOND") "RTN","C0CXPAT0",179,0) ;;>>?GXML(2)="" "RTN","C0CXPAT0",180,0) ;;> "RTN","C0CXPAT0",181,0) ;;>>>K GXML,G2,GBL,G3 "RTN","C0CXPAT0",182,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",183,0) ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2") "RTN","C0CXPAT0",184,0) ;;>>>D INSINNER^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD") "RTN","C0CXPAT0",185,0) ;;>>?GXML(10)="" "RTN","C0CXPAT0",186,0) ;;> "RTN","C0CXPAT0",187,0) ;;>>>K GXML,G2,GBL,G3 "RTN","C0CXPAT0",188,0) ;;>>>D ZTEST^C0CXPATH("INITXML") "RTN","C0CXPAT0",189,0) ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2") "RTN","C0CXPAT0",190,0) ;;>>>D INSINNER^C0CXPATH("G2","G2") "RTN","C0CXPAT0",191,0) ;;>>?G2(8)="" "RTN","C0CXPAT0",192,0) ;;> "RTN","C0CXPAT0",193,0) ;;>>>K GTMP,GTMP2 "RTN","C0CXPAT0",194,0) ;;>>>N GTMP,GTMP2 "RTN","C0CXPAT0",195,0) ;;>>>D PUSH^C0CXPATH("GTMP","A") "RTN","C0CXPAT0",196,0) ;;>>>D PUSH^C0CXPATH("GTMP2","B") "RTN","C0CXPAT0",197,0) ;;>>>D PUSH^C0CXPATH("GTMP2","C") "RTN","C0CXPAT0",198,0) ;;>>>D PUSHA^C0CXPATH("GTMP","GTMP2") "RTN","C0CXPAT0",199,0) ;;>>?GTMP(3)="C" "RTN","C0CXPAT0",200,0) ;;>>?GTMP(0)=3 "RTN","C0CXPAT0",201,0) ;;> "RTN","C0CXPAT0",202,0) ;;>>>K GTMP,GTMP2 "RTN","C0CXPAT0",203,0) ;;>>>S GTMP("TEST1")=1 "RTN","C0CXPAT0",204,0) ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP") "RTN","C0CXPAT0",205,0) ;;>>?GTMP2(0)=1 "RTN","C0CXPAT0",206,0) ;;>>?GTMP2(1)="^TEST1^1" "RTN","C0CXPAT0",207,0) ;;> "RTN","C0CXPAT0",208,0) ;;>>>K GTMP,GTMP2 "RTN","C0CXPAT0",209,0) ;;>>>D PUSH^C0CXPATH("GTMP","@@VAR1@@") "RTN","C0CXPAT0",210,0) ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP") "RTN","C0CXPAT0",211,0) ;;>>?GTMP2(1)="^VAR1^1" "RTN","C0CXPAT0",212,0) ;;> "RTN","C0CXPATH") 0^71^B521207435 "RTN","C0CXPATH",1,0) C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 "RTN","C0CXPATH",2,0) ;;1.0;C0C;;May 19, 2009;Build 1 "RTN","C0CXPATH",3,0) ;Copyright 2008 George Lilly. Licensed under the terms of the GNU "RTN","C0CXPATH",4,0) ;General Public License See attached copy of the License. "RTN","C0CXPATH",5,0) ; "RTN","C0CXPATH",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","C0CXPATH",7,0) ;it under the terms of the GNU General Public License as published by "RTN","C0CXPATH",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","C0CXPATH",9,0) ;(at your option) any later version. "RTN","C0CXPATH",10,0) ; "RTN","C0CXPATH",11,0) ;This program is distributed in the hope that it will be useful, "RTN","C0CXPATH",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","C0CXPATH",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","C0CXPATH",14,0) ;GNU General Public License for more details. "RTN","C0CXPATH",15,0) ; "RTN","C0CXPATH",16,0) ;You should have received a copy of the GNU General Public License along "RTN","C0CXPATH",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","C0CXPATH",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","C0CXPATH",19,0) ; "RTN","C0CXPATH",20,0) W "This is an XML XPATH utility library",! "RTN","C0CXPATH",21,0) W ! "RTN","C0CXPATH",22,0) Q "RTN","C0CXPATH",23,0) ; "RTN","C0CXPATH",24,0) OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE "RTN","C0CXPATH",25,0) ; "RTN","C0CXPATH",26,0) N Y "RTN","C0CXPATH",27,0) S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) "RTN","C0CXPATH",28,0) I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR "RTN","C0CXPATH",29,0) I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR "RTN","C0CXPATH",30,0) Q "RTN","C0CXPATH",31,0) ; "RTN","C0CXPATH",32,0) PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) "RTN","C0CXPATH",33,0) ; VAL IS A STRING AND STK IS PASSED BY NAME "RTN","C0CXPATH",34,0) ; "RTN","C0CXPATH",35,0) I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE "RTN","C0CXPATH",36,0) S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH "RTN","C0CXPATH",37,0) S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY "RTN","C0CXPATH",38,0) Q "RTN","C0CXPATH",39,0) ; "RTN","C0CXPATH",40,0) POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL "RTN","C0CXPATH",41,0) ; VAL AND STK ARE PASSED BY REFERENCE "RTN","C0CXPATH",42,0) ; "RTN","C0CXPATH",43,0) I @STK@(0)<1 D ; IF ARRAY IS EMPTY "RTN","C0CXPATH",44,0) . S VAL="" "RTN","C0CXPATH",45,0) . S @STK@(0)=0 "RTN","C0CXPATH",46,0) I @STK@(0)>0 D ; "RTN","C0CXPATH",47,0) . S VAL=@STK@(@STK@(0)) "RTN","C0CXPATH",48,0) . K @STK@(@STK@(0)) "RTN","C0CXPATH",49,0) . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY "RTN","C0CXPATH",50,0) Q "RTN","C0CXPATH",51,0) ; "RTN","C0CXPATH",52,0) PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME "RTN","C0CXPATH",53,0) ; "RTN","C0CXPATH",54,0) N ZGI "RTN","C0CXPATH",55,0) F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY "RTN","C0CXPATH",56,0) . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT "RTN","C0CXPATH",57,0) Q "RTN","C0CXPATH",58,0) ; "RTN","C0CXPATH",59,0) MKMDX(STK,RTN,INREDUX) ; MAKES A MUMPS INDEX FROM THE ARRAY STK "RTN","C0CXPATH",60,0) ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS "RTN","C0CXPATH",61,0) ; REDUX IS A STRING TO REMOVE FROM THE RESULT "RTN","C0CXPATH",62,0) S RTN="" "RTN","C0CXPATH",63,0) N I "RTN","C0CXPATH",64,0) ; W "STK= ",STK,! "RTN","C0CXPATH",65,0) I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY "RTN","C0CXPATH",66,0) . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON "RTN","C0CXPATH",67,0) . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON "RTN","C0CXPATH",68,0) . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) "RTN","C0CXPATH",69,0) I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2) "RTN","C0CXPATH",70,0) Q "RTN","C0CXPATH",71,0) ; "RTN","C0CXPATH",72,0) XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG "RTN","C0CXPATH",73,0) ; AND WILL RETURN NAME "RTN","C0CXPATH",74,0) ; ISTR IS PASSED BY VALUE "RTN","C0CXPATH",75,0) N CUR,TMP "RTN","C0CXPATH",76,0) I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET "RTN","C0CXPATH",77,0) . S TMP=$P(ISTR,"<",2) "RTN","C0CXPATH",78,0) I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE "RTN","C0CXPATH",79,0) . S TMP=$P(TMP,"/",2) "RTN","C0CXPATH",80,0) S CUR=$P(TMP,">",1) ; EXTRACT THE NAME "RTN","C0CXPATH",81,0) ; W "CUR= ",CUR,! "RTN","C0CXPATH",82,0) I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> "RTN","C0CXPATH",83,0) . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER "RTN","C0CXPATH",84,0) ; W "CUR2= ",CUR,! "RTN","C0CXPATH",85,0) Q CUR "RTN","C0CXPATH",86,0) ; "RTN","C0CXPATH",87,0) XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML "RTN","C0CXPATH",88,0) ; VALUE WILL RETURN VALUE "RTN","C0CXPATH",89,0) N G "RTN","C0CXPATH",90,0) S G=$P(ISTR,">",2) ;STRIP OFF "RTN","C0CXPATH",91,0) Q $P(G,"<",1) ; STRIP OFF LEAVING VALUE "RTN","C0CXPATH",92,0) ; "RTN","C0CXPATH",93,0) VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV "RTN","C0CXPATH",94,0) ; VDX: @INVDX@(XPATH)=VALUE "RTN","C0CXPATH",95,0) ; VDV: @OUTVDV@(X1X2X3X4)=VALUE "RTN","C0CXPATH",96,0) ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE "RTN","C0CXPATH",97,0) ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS "RTN","C0CXPATH",98,0) ; @VDV@("XPATH",X1X2X3X4)="XPATH" "RTN","C0CXPATH",99,0) N ZA,ZI,ZW "RTN","C0CXPATH",100,0) S ZI="" "RTN","C0CXPATH",101,0) F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; "RTN","C0CXPATH",102,0) . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME "RTN","C0CXPATH",103,0) . W ZW,! "RTN","C0CXPATH",104,0) . S @OUTVDV@(ZW)=@INVDX@(ZI) "RTN","C0CXPATH",105,0) . S @OUTVDV@("XPATH",ZW)=ZI "RTN","C0CXPATH",106,0) Q "RTN","C0CXPATH",107,0) ; "RTN","C0CXPATH",108,0) VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG "RTN","C0CXPATH",109,0) ; VDX: @VDX@(XPATH)=VALUE "RTN","C0CXPATH",110,0) ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE "RTN","C0CXPATH",111,0) ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX "RTN","C0CXPATH",112,0) N ZA,ZI,ZW "RTN","C0CXPATH",113,0) S ZI="" "RTN","C0CXPATH",114,0) F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; "RTN","C0CXPATH",115,0) . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL // "RTN","C0CXPATH",116,0) . S ZW2=$P(ZW,"/",1) "RTN","C0CXPATH",117,0) . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK)) "RTN","C0CXPATH",118,0) . ;ZWR ZA "RTN","C0CXPATH",119,0) . S ZW2=ZA(1) "RTN","C0CXPATH",120,0) . F ZK=2:1:ZA(0) D ; "RTN","C0CXPATH",121,0) . . S ZW2=ZW2_""","""_ZA(ZK) "RTN","C0CXPATH",122,0) . K ZA "RTN","C0CXPATH",123,0) . S ZW2=""""_ZW2_"""" "RTN","C0CXPATH",124,0) . W ZW2,! "RTN","C0CXPATH",125,0) . S ZN=OUTXPG_"("_ZW2_")" "RTN","C0CXPATH",126,0) . S @ZN=@INVDX@(ZI) "RTN","C0CXPATH",127,0) Q "RTN","C0CXPATH",128,0) ; "RTN","C0CXPATH",129,0) XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY "RTN","C0CXPATH",130,0) ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE "RTN","C0CXPATH",131,0) ; "RTN","C0CXPATH",132,0) ;N G1 "RTN","C0CXPATH",133,0) D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED "RTN","C0CXPATH",134,0) D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM "RTN","C0CXPATH",135,0) Q "RTN","C0CXPATH",136,0) ; "RTN","C0CXPATH",137,0) DO "RTN","C0CXPATH",138,0) D XPG2XML("^GPL2B","^GPL2A") "RTN","C0CXPATH",139,0) Q "RTN","C0CXPATH",140,0) ; "RTN","C0CXPATH",141,0) T1 ; TEST OUT THESE ROUTINES "RTN","C0CXPATH",142,0) D XML2XPG("G2","^GPL") "RTN","C0CXPATH",143,0) D XPG2XML("G3","G2") "RTN","C0CXPATH",144,0) K ^GPLOUT "RTN","C0CXPATH",145,0) M ^GPLOUT=G3 "RTN","C0CXPATH",146,0) W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p") "RTN","C0CXPATH",147,0) Q "RTN","C0CXPATH",148,0) ; "RTN","C0CXPATH",149,0) XPG2XML(OUTXML,INXPG) ; "RTN","C0CXPATH",150,0) N C0CN,FWD,ZA,G,GA,ZQ "RTN","C0CXPATH",151,0) S ZQ=0 ; QUIT FLAG "RTN","C0CXPATH",152,0) F Q:ZQ=1 D ; LOOP THROUGH EVERYTHING "RTN","C0CXPATH",153,0) . I '$D(C0CN) D ; FIRST TIME THROUGH "RTN","C0CXPATH",154,0) . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR "RTN","C0CXPATH",155,0) . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS "RTN","C0CXPATH",156,0) . . S G=$Q(@INXPG) ; THIS ONE "RTN","C0CXPATH",157,0) . . S GN=$Q(@G) ; NEXT ONE "RTN","C0CXPATH",158,0) . . S C0CN=1 ; SUBSCRIPT COUNT "RTN","C0CXPATH",159,0) . . S ZQ=0 ; QUIT FLAG "RTN","C0CXPATH",160,0) . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML "RTN","C0CXPATH",161,0) . . I $QS(G,1)="ContinuityOfCareRecord" D ; "RTN","C0CXPATH",162,0) . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK "RTN","C0CXPATH",163,0) . I FWD D ; GOING FORWARDS "RTN","C0CXPATH",164,0) . . I C0CN<$QL(G) D ; NOT A DATA NODE "RTN","C0CXPATH",165,0) . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT "RTN","C0CXPATH",166,0) . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT "RTN","C0CXPATH",167,0) . . . I @OUTXML@(@OUTXML@(0))="" D ; "RTN","C0CXPATH",168,0) . . . . S @OUTXML@(@OUTXML@(0))="" "RTN","C0CXPATH",169,0) . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE "RTN","C0CXPATH",170,0) . . E D ; AT THE DATA NODE "RTN","C0CXPATH",171,0) . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT "RTN","C0CXPATH",172,0) . . . D ZXVAL(ZA,@G) ; OUTPUT VAL FOR DATA NODE "RTN","C0CXPATH",173,0) . . . S FWD=0 ; GO BACKWARDS "RTN","C0CXPATH",174,0) . I 'FWD D ;GOING BACKWARDS "RTN","C0CXPATH",175,0) . . S GN=$Q(@G) ;NEXT XPATH "RTN","C0CXPATH",176,0) . . ;W "NEXT!",GN,! "RTN","C0CXPATH",177,0) . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT "RTN","C0CXPATH",178,0) . . I GN'="" D ; "RTN","C0CXPATH",179,0) . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D ; NEED TO CLOSE OFF ELEMENT "RTN","C0CXPATH",180,0) . . . . D ZXC($QS(G,C0CN)) ; "RTN","C0CXPATH",181,0) . . . E I GN'="" D ; MORE ELEMENTS AT THIS LEVEL "RTN","C0CXPATH",182,0) . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH "RTN","C0CXPATH",183,0) . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT "RTN","C0CXPATH",184,0) . . . . S FWD=1 ; GOING FORWARD NOW "RTN","C0CXPATH",185,0) . I (GN="")&(C0CN=1) D Q ; WHEN WE ARE ALL DONE "RTN","C0CXPATH",186,0) . . D ZXC($QS(G,C0CN)) ; LAST ONE "RTN","C0CXPATH",187,0) . . S ZQ=1 ; QUIT NOW "RTN","C0CXPATH",188,0) Q "RTN","C0CXPATH",189,0) ; "RTN","C0CXPATH",190,0) ZXO(WHAT) "RTN","C0CXPATH",191,0) D PUSH("GA",WHAT) "RTN","C0CXPATH",192,0) D PUSH(OUTXML,"<"_WHAT_">") "RTN","C0CXPATH",193,0) Q "RTN","C0CXPATH",194,0) ; "RTN","C0CXPATH",195,0) ZXC(WHAT) "RTN","C0CXPATH",196,0) D POP("GA",.TMP) "RTN","C0CXPATH",197,0) D PUSH(OUTXML,"") "RTN","C0CXPATH",198,0) Q "RTN","C0CXPATH",199,0) ; "RTN","C0CXPATH",200,0) ZXVAL(WHAT,VAL) "RTN","C0CXPATH",201,0) D PUSH(OUTXML,"<"_WHAT_">"_VAL_"") "RTN","C0CXPATH",202,0) Q "RTN","C0CXPATH",203,0) ; "RTN","C0CXPATH",204,0) INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce "RTN","C0CXPATH",205,0) ; an XPATH index; REDUX is a string to be removed from each xpath "RTN","C0CXPATH",206,0) ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME "RTN","C0CXPATH",207,0) ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE "RTN","C0CXPATH",208,0) ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG "RTN","C0CXPATH",209,0) ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME "RTN","C0CXPATH",210,0) ; @VDX@("XPATH")=VALUE "RTN","C0CXPATH",211,0) ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE "RTN","C0CXPATH",212,0) ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE "RTN","C0CXPATH",213,0) ; XML SECTION "RTN","C0CXPATH",214,0) ; IZXML IS PASSED BY NAME "RTN","C0CXPATH",215,0) ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE "RTN","C0CXPATH",216,0) N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT "RTN","C0CXPATH",217,0) N C0CSTK ; LEAVE OUT FOR DEBUGGING "RTN","C0CXPATH",218,0) I '$D(REDUX) S REDUX="" "RTN","C0CXPATH",219,0) I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX "RTN","C0CXPATH",220,0) N ZXML "RTN","C0CXPATH",221,0) I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD "RTN","C0CXPATH",222,0) E S ZXML=IZXML ; PLACE FOR INDEX TO KEEP "RTN","C0CXPATH",223,0) I '$D(@IZXML@(0)) D ; IF COUNT NOT IN NODE 0 COUNT THEM "RTN","C0CXPATH",224,0) . S I="",LCNT=0 "RTN","C0CXPATH",225,0) . F S I=$O(@IZXML@(I)) Q:I="" S LCNT=LCNT+1 "RTN","C0CXPATH",226,0) E S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY "RTN","C0CXPATH",227,0) I LCNT=0 D Q ; NO XML PASSED "RTN","C0CXPATH",228,0) . W "ERROR IN XML FILE",! "RTN","C0CXPATH",229,0) S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX "RTN","C0CXPATH",230,0) I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX "RTN","C0CXPATH",231,0) S C0CSTK(0)=0 ; INITIALIZE STACK "RTN","C0CXPATH",232,0) K LKASD ; KILL LOOKASIDE ARRAY "RTN","C0CXPATH",233,0) D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES "RTN","C0CXPATH",234,0) F I=1:1:LCNT D ; PROCESS THE ENTIRE ARRAY "RTN","C0CXPATH",235,0) . S LINE=@IZXML@(I) "RTN","C0CXPATH",236,0) . I $D(TEMPLATE) D ;IF TEMPLATE IS REQUESTED "RTN","C0CXPATH",237,0) . . S @TEMPLATE@(I)=$$CLEAN(LINE) "RTN","C0CXPATH",238,0) . ;W LINE,! "RTN","C0CXPATH",239,0) . S FOUND=0 ; INTIALIZED FOUND FLAG "RTN","C0CXPATH",240,0) . I LINE?.E1"".E) D "RTN","C0CXPATH",243,0) . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS "RTN","C0CXPATH",244,0) . . . ; ON THE SAME LINE "RTN","C0CXPATH",245,0) . . . ; W "FOUND ",LINE,! "RTN","C0CXPATH",246,0) . . . S FOUND=1 ; SET FOUND FLAG "RTN","C0CXPATH",247,0) . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME "RTN","C0CXPATH",248,0) . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES "RTN","C0CXPATH",249,0) . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK "RTN","C0CXPATH",250,0) . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX "RTN","C0CXPATH",251,0) . . . ; W "MDX=",MDX,! "RTN","C0CXPATH",252,0) . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE "RTN","C0CXPATH",253,0) . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2 "RTN","C0CXPATH",254,0) . . . . ;E S ZDUP(MDX)=ZDUP(MDX)+1 "RTN","C0CXPATH",255,0) . . . . ;W "DUP:",MDX,! "RTN","C0CXPATH",256,0) . . . . ;I '$D(CURVAL) S CURVAL="" "RTN","C0CXPATH",257,0) . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL "RTN","C0CXPATH",258,0) . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER "RTN","C0CXPATH",259,0) . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE "RTN","C0CXPATH",260,0) . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST "RTN","C0CXPATH",261,0) . . . . S CURVAL=$$XVAL(LINE) ; VALUE "RTN","C0CXPATH",262,0) . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE "RTN","C0CXPATH",263,0) . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED "RTN","C0CXPATH",264,0) . . . . I $D(TEMPLATE) D ; IF TEMPLATE IS REQUESTED "RTN","C0CXPATH",265,0) . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS "RTN","C0CXPATH",266,0) . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@") D ; BEGINNING OF A SECTION "RTN","C0CXPATH",283,0) . . . ; W "FOUND ",LINE,! "RTN","C0CXPATH",284,0) . . . S FOUND=1 ; SET FOUND FLAG "RTN","C0CXPATH",285,0) . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME "RTN","C0CXPATH",286,0) . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES "RTN","C0CXPATH",287,0) . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK "RTN","C0CXPATH",288,0) . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX "RTN","C0CXPATH",289,0) . . . ; W "MDX=",MDX,! "RTN","C0CXPATH",290,0) . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE "RTN","C0CXPATH",291,0) . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER "RTN","C0CXPATH",292,0) . . . . ;B "RTN","C0CXPATH",293,0) . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE "RTN","C0CXPATH",294,0) . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX "RTN","C0CXPATH",295,0) S @ZXML@("INDEXED")="" "RTN","C0CXPATH",296,0) S @ZXML@("//")="1^"_LCNT ; ROOT XPATH "RTN","C0CXPATH",297,0) I NOINX K @ZXML ; DELETE UNWANTED INDEX "RTN","C0CXPATH",298,0) Q "RTN","C0CXPATH",299,0) ; "RTN","C0CXPATH",300,0) MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES "RTN","C0CXPATH",301,0) ; "RTN","C0CXPATH",302,0) N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2 "RTN","C0CXPATH",303,0) F ZI=1:1:LCNT-1 D ; PROCESS THE ENTIRE ARRAY "RTN","C0CXPATH",304,0) . S ZLINE=@IZXML@(ZI) "RTN","C0CXPATH",305,0) . I ZI") D ; BEGINNING OF A SECTION "RTN","C0CXPATH",309,0) . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME "RTN","C0CXPATH",310,0) . . . I CUR=CUR2 D ; IF THIS IS A MULTIPLE "RTN","C0CXPATH",311,0) . . . . S OUTBUF(CUR,ZI+1)="" "RTN","C0CXPATH",312,0) ;ZWR OUTBUF "RTN","C0CXPATH",313,0) S ZI="" "RTN","C0CXPATH",314,0) F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; FOR EACH KIND OF MULTIPLE "RTN","C0CXPATH",315,0) . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE "RTN","C0CXPATH",316,0) . F S ZN=$O(@IZXML@(ZN),-1) Q:ZN="" I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q ; "RTN","C0CXPATH",317,0) . S OUTBUF(ZI,ZN)="" "RTN","C0CXPATH",318,0) S ZA=1,ZI="",ZN="" "RTN","C0CXPATH",319,0) F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; ADDING THE COUNT FOR THE MULIPLES [x] "RTN","C0CXPATH",320,0) . S ZN="",ZA=1 "RTN","C0CXPATH",321,0) . F S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN="" D ; "RTN","C0CXPATH",322,0) . . S OUTBUF(ZI,ZN)="["_ZA_"]" "RTN","C0CXPATH",323,0) . . S ZA=ZA+1 "RTN","C0CXPATH",324,0) Q "RTN","C0CXPATH",325,0) ; "RTN","C0CXPATH",326,0) CLEAN(STR,TR) ; extrinsic function; returns string "RTN","C0CXPATH",327,0) ;; Removes all non printable characters from a string. "RTN","C0CXPATH",328,0) ;; STR by Value "RTN","C0CXPATH",329,0) ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE "RTN","C0CXPATH",330,0) N TR,I "RTN","C0CXPATH",331,0) I '$D(TR) D ; "RTN","C0CXPATH",332,0) . F I=0:1:31 S TR=$G(TR)_$C(I) "RTN","C0CXPATH",333,0) . S TR=TR_$C(127) "RTN","C0CXPATH",334,0) QUIT $TR(STR,TR) "RTN","C0CXPATH",335,0) ; "RTN","C0CXPATH",336,0) QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION "RTN","C0CXPATH",337,0) ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" "RTN","C0CXPATH",338,0) ; IARY AND OARY ARE PASSED BY NAME "RTN","C0CXPATH",339,0) I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY "RTN","C0CXPATH",340,0) . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML "RTN","C0CXPATH",341,0) N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN "RTN","C0CXPATH",342,0) N TMP,I,J,QXPATH "RTN","C0CXPATH",343,0) S FIRST=1 "RTN","C0CXPATH",344,0) I '$D(@IARY@(0)) D ; LINE COUNT NOT IN ZERO NODE "RTN","C0CXPATH",345,0) . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK "RTN","C0CXPATH",346,0) S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT "RTN","C0CXPATH",347,0) I XPATH'="//" D ; NOT A ROOT QUERY "RTN","C0CXPATH",348,0) . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES "RTN","C0CXPATH",349,0) . S FIRST=$P(TMP,"^",1) "RTN","C0CXPATH",350,0) . S LAST=$P(TMP,"^",2) "RTN","C0CXPATH",351,0) K @OARY "RTN","C0CXPATH",352,0) S @OARY@(0)=+LAST-FIRST+1 "RTN","C0CXPATH",353,0) S J=1 "RTN","C0CXPATH",354,0) FOR I=FIRST:1:LAST D "RTN","C0CXPATH",355,0) . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY "RTN","C0CXPATH",356,0) . S J=J+1 "RTN","C0CXPATH",357,0) ; ZWR OARY "RTN","C0CXPATH",358,0) Q "RTN","C0CXPATH",359,0) ; "RTN","C0CXPATH",360,0) XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH "RTN","C0CXPATH",361,0) ; INDEX WITH TWO PIECES START^FINISH "RTN","C0CXPATH",362,0) ; IDX IS PASSED BY NAME "RTN","C0CXPATH",363,0) Q $P(@IDX@(XPATH),"^",1) "RTN","C0CXPATH",364,0) ; "RTN","C0CXPATH",365,0) XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH "RTN","C0CXPATH",366,0) ; INDEX WITH TWO PIECES START^FINISH "RTN","C0CXPATH",367,0) ; IDX IS PASSED BY NAME "RTN","C0CXPATH",368,0) Q $P(@IDX@(XPATH),"^",2) "RTN","C0CXPATH",369,0) ; "RTN","C0CXPATH",370,0) START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX "RTN","C0CXPATH",371,0) ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH "RTN","C0CXPATH",372,0) ; COMPANION TO FINISH ; IDX IS PASSED BY NAME "RTN","C0CXPATH",373,0) Q $P(ISTR,";",2) "RTN","C0CXPATH",374,0) ; "RTN","C0CXPATH",375,0) FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX "RTN","C0CXPATH",376,0) ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH "RTN","C0CXPATH",377,0) Q $P(ISTR,";",3) "RTN","C0CXPATH",378,0) ; "RTN","C0CXPATH",379,0) ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX "RTN","C0CXPATH",380,0) ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH "RTN","C0CXPATH",381,0) Q $P(ISTR,";",1) "RTN","C0CXPATH",382,0) ; "RTN","C0CXPATH",383,0) BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST "RTN","C0CXPATH",384,0) ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST "RTN","C0CXPATH",385,0) ; DEST IS CLEARED TO START "RTN","C0CXPATH",386,0) ; USES PUSH TO DO THE COPY "RTN","C0CXPATH",387,0) N I "RTN","C0CXPATH",388,0) K @BDEST "RTN","C0CXPATH",389,0) F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST "RTN","C0CXPATH",390,0) . N J,ATMP "RTN","C0CXPATH",391,0) . S ATMP=$$ARRAY(@BLIST@(I)) "RTN","C0CXPATH",392,0) . I $G(DEBUG) W "ATMP=",ATMP,! "RTN","C0CXPATH",393,0) . I $G(DEBUG) W @BLIST@(I),! "RTN","C0CXPATH",394,0) . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; "RTN","C0CXPATH",395,0) . . ; FOR EACH LINE IN THIS INSTR "RTN","C0CXPATH",396,0) . . I $G(DEBUG) W "BDEST= ",BDEST,! "RTN","C0CXPATH",397,0) . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),! "RTN","C0CXPATH",398,0) . . D PUSH(BDEST,@ATMP@(J)) "RTN","C0CXPATH",399,0) Q "RTN","C0CXPATH",400,0) ; "RTN","C0CXPATH",401,0) QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST "RTN","C0CXPATH",402,0) ; "RTN","C0CXPATH",403,0) I $G(DEBUG) W "QUEUEING ",BLST,! "RTN","C0CXPATH",404,0) D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) "RTN","C0CXPATH",405,0) Q "RTN","C0CXPATH",406,0) ; "RTN","C0CXPATH",407,0) CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME "RTN","C0CXPATH",408,0) ; KILLS CPDEST FIRST "RTN","C0CXPATH",409,0) N CPINSTR "RTN","C0CXPATH",410,0) I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,! "RTN","C0CXPATH",411,0) I @CPSRC@(0)<1 D ; BAD LENGTH "RTN","C0CXPATH",412,0) . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! "RTN","C0CXPATH",413,0) . Q "RTN","C0CXPATH",414,0) ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT "RTN","C0CXPATH",415,0) D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY "RTN","C0CXPATH",416,0) D BUILD("CPINSTR",CPDEST) "RTN","C0CXPATH",417,0) Q "RTN","C0CXPATH",418,0) ; "RTN","C0CXPATH",419,0) QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST "RTN","C0CXPATH",420,0) ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD "RTN","C0CXPATH",421,0) ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT "RTN","C0CXPATH",422,0) ; USED TO INSERT CHILDREN NODES "RTN","C0CXPATH",423,0) I @QOXML@(0)<1 D ; MALFORMED XML "RTN","C0CXPATH",424,0) . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! "RTN","C0CXPATH",425,0) . Q "RTN","C0CXPATH",426,0) I $G(DEBUG) W "DOING QOPEN",! "RTN","C0CXPATH",427,0) N S1,E1,QOT,QOTMP "RTN","C0CXPATH",428,0) S S1=1 ; OPEN FROM THE BEGINNING OF THE XML "RTN","C0CXPATH",429,0) I $D(QOXPATH) D ; XPATH PROVIDED "RTN","C0CXPATH",430,0) . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX "RTN","C0CXPATH",431,0) . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 "RTN","C0CXPATH",432,0) I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT "RTN","C0CXPATH",433,0) . S E1=@QOXML@(0)-1 "RTN","C0CXPATH",434,0) D QUEUE(QOBLIST,QOXML,S1,E1) "RTN","C0CXPATH",435,0) ; S QOTMP=QOXML_"^"_S1_"^"_E1 "RTN","C0CXPATH",436,0) ; D PUSH(QOBLIST,QOTMP) "RTN","C0CXPATH",437,0) Q "RTN","C0CXPATH",438,0) ; "RTN","C0CXPATH",439,0) QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN "RTN","C0CXPATH",440,0) ; ADDS THE LIST LINE OF QCXML TO QCBLIST "RTN","C0CXPATH",441,0) ; USED TO FINISH INSERTING CHILDERN NODES "RTN","C0CXPATH",442,0) ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END "RTN","C0CXPATH",443,0) ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO "RTN","C0CXPATH",444,0) I @QCXML@(0)<1 D ; MALFORMED XML "RTN","C0CXPATH",445,0) . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! "RTN","C0CXPATH",446,0) I $G(DEBUG) W "GOING TO CLOSE",! "RTN","C0CXPATH",447,0) N S1,E1,QCT,QCTMP "RTN","C0CXPATH",448,0) S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML "RTN","C0CXPATH",449,0) I $D(QCXPATH) D ; XPATH PROVIDED "RTN","C0CXPATH",450,0) . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX "RTN","C0CXPATH",451,0) . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML "RTN","C0CXPATH",452,0) I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT "RTN","C0CXPATH",453,0) . S S1=@QCXML@(0) "RTN","C0CXPATH",454,0) D QUEUE(QCBLIST,QCXML,S1,E1) "RTN","C0CXPATH",455,0) ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) "RTN","C0CXPATH",456,0) Q "RTN","C0CXPATH",457,0) ; "RTN","C0CXPATH",458,0) INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE "RTN","C0CXPATH",459,0) ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS "RTN","C0CXPATH",460,0) ; OMITTED, INSERTION WILL BE AT THE ROOT "RTN","C0CXPATH",461,0) ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW "RTN","C0CXPATH",462,0) ; XML AT THE END OF THE XPATH POINT "RTN","C0CXPATH",463,0) ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE "RTN","C0CXPATH",464,0) N INSBLD,INSTMP "RTN","C0CXPATH",465,0) I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! "RTN","C0CXPATH",466,0) I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),! "RTN","C0CXPATH",467,0) I '$D(@INSXML@(1)) D ; INSERT INTO AN EMPTY ARRAY "RTN","C0CXPATH",468,0) . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT "RTN","C0CXPATH",469,0) I $D(@INSXML@(1)) D ; IF ORIGINAL ARRAY IS NOT EMPTY "RTN","C0CXPATH",470,0) . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH "RTN","C0CXPATH",471,0) . I $D(INSXPATH) D ; XPATH PROVIDED "RTN","C0CXPATH",472,0) . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE "RTN","C0CXPATH",473,0) . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD") "RTN","C0CXPATH",474,0) . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT "RTN","C0CXPATH",475,0) . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH "RTN","C0CXPATH",476,0) . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML "RTN","C0CXPATH",477,0) . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML "RTN","C0CXPATH",478,0) . I $D(INSXPATH) D ; XPATH PROVIDED "RTN","C0CXPATH",479,0) . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH "RTN","C0CXPATH",480,0) . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT "RTN","C0CXPATH",481,0) . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH "RTN","C0CXPATH",482,0) . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST "RTN","C0CXPATH",483,0) . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE "RTN","C0CXPATH",484,0) Q "RTN","C0CXPATH",485,0) ; "RTN","C0CXPATH",486,0) INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW "RTN","C0CXPATH",487,0) ; INTO INNXML AT THE INNXPATH XPATH POINT "RTN","C0CXPATH",488,0) ; "RTN","C0CXPATH",489,0) N INNBLD,UXPATH "RTN","C0CXPATH",490,0) N INNTBUF "RTN","C0CXPATH",491,0) S INNTBUF=$NA(^TMP($J,"INNTBUF")) "RTN","C0CXPATH",492,0) I '$D(INNXPATH) D ; XPATH NOT PASSED "RTN","C0CXPATH",493,0) . S UXPATH="//" ; USE ROOT XPATH "RTN","C0CXPATH",494,0) I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED "RTN","C0CXPATH",495,0) I '$D(@INNXML@(0)) D ; INNXML IS EMPTY "RTN","C0CXPATH",496,0) . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER "RTN","C0CXPATH",497,0) . D BUILD("INNBLD",INNXML) "RTN","C0CXPATH",498,0) I @INNXML@(0)>0 D ; NOT EMPTY "RTN","C0CXPATH",499,0) . D QOPEN("INNBLD",INNXML,UXPATH) ; "RTN","C0CXPATH",500,0) . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML "RTN","C0CXPATH",501,0) . D QCLOSE("INNBLD",INNXML,UXPATH) "RTN","C0CXPATH",502,0) . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER "RTN","C0CXPATH",503,0) . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST "RTN","C0CXPATH",504,0) Q "RTN","C0CXPATH",505,0) ; "RTN","C0CXPATH",506,0) INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST "RTN","C0CXPATH",507,0) ; BUT XDEST AN XNEW ARE PASSED BY NAME "RTN","C0CXPATH",508,0) N XBLD,XTMP "RTN","C0CXPATH",509,0) D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT "RTN","C0CXPATH",510,0) D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST "RTN","C0CXPATH",511,0) D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION "RTN","C0CXPATH",512,0) D BUILD("XBLD","XTMP") ; BUILD THE RESULT "RTN","C0CXPATH",513,0) D CP("XTMP",XDEST) ; COPY TO THE DESTINATION "RTN","C0CXPATH",514,0) I $G(DEBUG) D PARY("XDEST") "RTN","C0CXPATH",515,0) Q "RTN","C0CXPATH",516,0) ; "RTN","C0CXPATH",517,0) REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT "RTN","C0CXPATH",518,0) ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE "RTN","C0CXPATH",519,0) ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE "RTN","C0CXPATH",520,0) ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") "RTN","C0CXPATH",521,0) N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP "RTN","C0CXPATH",522,0) S OLD=$NA(^TMP($J,"REPLACE_OLD")) "RTN","C0CXPATH",523,0) D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD "RTN","C0CXPATH",524,0) S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS "RTN","C0CXPATH",525,0) S XFIRST=$P(XNODE,"^",1) "RTN","C0CXPATH",526,0) S XLAST=$P(XNODE,"^",2) "RTN","C0CXPATH",527,0) I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG "RTN","C0CXPATH",528,0) . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE "RTN","C0CXPATH",529,0) . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST "RTN","C0CXPATH",530,0) I RENEW'="" D ; NEW XML IS NOT NULL "RTN","C0CXPATH",531,0) . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE "RTN","C0CXPATH",532,0) . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW "RTN","C0CXPATH",533,0) . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST "RTN","C0CXPATH",534,0) I $G(DEBUG) W "REPLACE PREBUILD",! "RTN","C0CXPATH",535,0) I $G(DEBUG) D PARY("REBLD") "RTN","C0CXPATH",536,0) D BUILD("REBLD","RTMP") "RTN","C0CXPATH",537,0) K @REXML ; KILL WHAT WAS THERE "RTN","C0CXPATH",538,0) D CP("RTMP",REXML) ; COPY IN THE RESULT "RTN","C0CXPATH",539,0) Q "RTN","C0CXPATH",540,0) ; "RTN","C0CXPATH",541,0) DELETE(REXML,REXPATH) ; DELETE THE XML AT THE XPATH POINT "RTN","C0CXPATH",542,0) ; REXML IS PASSED BY NAME XPATH IS A VALUE "RTN","C0CXPATH",543,0) N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP "RTN","C0CXPATH",544,0) S OLD=$NA(^TMP($J,"REPLACE_OLD")) "RTN","C0CXPATH",545,0) D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD "RTN","C0CXPATH",546,0) S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS "RTN","C0CXPATH",547,0) S XFIRST=$P(XNODE,"^",1) "RTN","C0CXPATH",548,0) S XLAST=$P(XNODE,"^",2) "RTN","C0CXPATH",549,0) D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE "RTN","C0CXPATH",550,0) D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST "RTN","C0CXPATH",551,0) I $G(DEBUG) D PARY("REBLD") "RTN","C0CXPATH",552,0) D BUILD("REBLD","RTMP") "RTN","C0CXPATH",553,0) K @REXML ; KILL WHAT WAS THERE "RTN","C0CXPATH",554,0) D CP("RTMP",REXML) ; COPY IN THE RESULT "RTN","C0CXPATH",555,0) Q "RTN","C0CXPATH",556,0) ; "RTN","C0CXPATH",557,0) MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY "RTN","C0CXPATH",558,0) ; W "Reporting on the missing",! "RTN","C0CXPATH",559,0) ; W OARY "RTN","C0CXPATH",560,0) I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q "RTN","C0CXPATH",561,0) N I "RTN","C0CXPATH",562,0) S @OARY@(0)=0 ; INITIALIZED MISSING COUNT "RTN","C0CXPATH",563,0) F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY "RTN","C0CXPATH",564,0) . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE "RTN","C0CXPATH",565,0) . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY "RTN","C0CXPATH",566,0) . . Q "RTN","C0CXPATH",567,0) Q "RTN","C0CXPATH",568,0) ; "RTN","C0CXPATH",569,0) MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY "RTN","C0CXPATH",570,0) ; AND PUT THE RESULTS IN OXML "RTN","C0CXPATH",571,0) N XCNT "RTN","C0CXPATH",572,0) I '$D(DEBUG) S DEBUG=0 "RTN","C0CXPATH",573,0) I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q "RTN","C0CXPATH",574,0) I '$D(@IXML@(0)) D ; INITIALIZE COUNT "RTN","C0CXPATH",575,0) . S XCNT=$O(@IXML@(""),-1) "RTN","C0CXPATH",576,0) E S XCNT=@IXML@(0) ;COUNT "RTN","C0CXPATH",577,0) I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q "RTN","C0CXPATH",578,0) N I,J,TNAM,TVAL,TSTR "RTN","C0CXPATH",579,0) S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT "RTN","C0CXPATH",580,0) F I=1:1:XCNT D ; LOOP THROUGH WHOLE ARRAY "RTN","C0CXPATH",581,0) . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT "RTN","C0CXPATH",582,0) . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? "RTN","C0CXPATH",583,0) . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS "RTN","C0CXPATH",584,0) . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS "RTN","C0CXPATH",585,0) . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! "RTN","C0CXPATH",586,0) . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME "RTN","C0CXPATH",587,0) . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED "RTN","C0CXPATH",588,0) . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? "RTN","C0CXPATH",589,0) . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD "RTN","C0CXPATH",590,0) . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE "RTN","C0CXPATH",591,0) . . . . E D DOFLD ; PROCESS A FIELD "RTN","C0CXPATH",592,0) . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE "RTN","C0CXPATH",593,0) . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER "RTN","C0CXPATH",594,0) . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES "RTN","C0CXPATH",595,0) . . I DEBUG W TSTR "RTN","C0CXPATH",596,0) I DEBUG W "MAPPED",! "RTN","C0CXPATH",597,0) Q "RTN","C0CXPATH",598,0) ; "RTN","C0CXPATH",599,0) DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE "RTN","C0CXPATH",600,0) ; "RTN","C0CXPATH",601,0) Q "RTN","C0CXPATH",602,0) ; "RTN","C0CXPATH",603,0) TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS "RTN","C0CXPATH",604,0) ; THEXML IS PASSED BY NAME "RTN","C0CXPATH",605,0) N I,J,TMPXML,DEL,FOUND,INTXT "RTN","C0CXPATH",606,0) S FOUND=0 "RTN","C0CXPATH",607,0) S INTXT=0 "RTN","C0CXPATH",608,0) I $G(DEBUG) W "DELETING EMPTY ELEMENTS",! "RTN","C0CXPATH",609,0) F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY "RTN","C0CXPATH",610,0) . S J=@THEXML@(I) "RTN","C0CXPATH",611,0) . I J["" D "RTN","C0CXPATH",612,0) . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM "RTN","C0CXPATH",613,0) . . I $G(DEBUG) W "IN HTML SECTION",! "RTN","C0CXPATH",614,0) . N JM,JP,JPX ; JMINUS AND JPLUS "RTN","C0CXPATH",615,0) . S JM=@THEXML@(I-1) ; LINE BEFORE "RTN","C0CXPATH",616,0) . I JM["" S INTXT=0 ; LEFT HTML SECTION,START TRIM "RTN","C0CXPATH",617,0) . S JP=@THEXML@(I+1) ; LINE AFTER "RTN","C0CXPATH",618,0) . I INTXT=0 D ; IF NOT IN AN HTML SECTION "RTN","C0CXPATH",619,0) . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH "RTN","C0CXPATH",620,0) . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES "RTN","C0CXPATH",621,0) . . . I $G(DEBUG) W I,J,JP,! "RTN","C0CXPATH",622,0) . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED "RTN","C0CXPATH",623,0) . . . S DEL(I)="" ; SET LINE TO DELETE "RTN","C0CXPATH",624,0) . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE "RTN","C0CXPATH",625,0) . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE "RTN","C0CXPATH",626,0) . . . I $G(DEBUG) W I,J,! "RTN","C0CXPATH",627,0) . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED "RTN","C0CXPATH",628,0) . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED "RTN","C0CXPATH",629,0) . . . I JM=JPX D ; "RTN","C0CXPATH",630,0) . . . . I $G(DEBUG) W I,JM_J_JPX,! "RTN","C0CXPATH",631,0) . . . . S DEL(I-1)="" "RTN","C0CXPATH",632,0) . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL "RTN","C0CXPATH",633,0) ; . I J'["><" D PUSH("TMPXML",J) "RTN","C0CXPATH",634,0) I FOUND D ; NEED TO DELETE THINGS "RTN","C0CXPATH",635,0) . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES "RTN","C0CXPATH",636,0) . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED "RTN","C0CXPATH",637,0) . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY "RTN","C0CXPATH",638,0) . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY "RTN","C0CXPATH",639,0) Q FOUND "RTN","C0CXPATH",640,0) ; "RTN","C0CXPATH",641,0) UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML "RTN","C0CXPATH",642,0) ; XSEC IS A SECTION PASSED BY NAME "RTN","C0CXPATH",643,0) N XBLD,XTMP "RTN","C0CXPATH",644,0) D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML "RTN","C0CXPATH",645,0) D BUILD("XBLD","XTMP") ; BUILD THE RESULT "RTN","C0CXPATH",646,0) D CP("XTMP",XSEC) ; REPLACE PASSED XML "RTN","C0CXPATH",647,0) Q "RTN","C0CXPATH",648,0) ; "RTN","C0CXPATH",649,0) PARY(GLO,ZN) ;PRINT AN ARRAY "RTN","C0CXPATH",650,0) ; IF ZN=-1 NO LINE NUMBERS "RTN","C0CXPATH",651,0) N I "RTN","C0CXPATH",652,0) F I=1:1:@GLO@(0) D ; "RTN","C0CXPATH",653,0) . I $G(ZN)=-1 W @GLO@(I),! "RTN","C0CXPATH",654,0) . E W I_" "_@GLO@(I),! "RTN","C0CXPATH",655,0) Q "RTN","C0CXPATH",656,0) ; "RTN","C0CXPATH",657,0) H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY "RTN","C0CXPATH",658,0) ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE "RTN","C0CXPATH",659,0) I '$D(IPRE) S IPRE="" "RTN","C0CXPATH",660,0) N H2I S H2I="" "RTN","C0CXPATH",661,0) ; W $O(@IHASH@(H2I)),! "RTN","C0CXPATH",662,0) F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH "RTN","C0CXPATH",663,0) . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES "RTN","C0CXPATH",664,0) . . ;W H2I_"^"_@IHASH@(H2I),! "RTN","C0CXPATH",665,0) . . N IH,IHI "RTN","C0CXPATH",666,0) . . S IH=$NA(@IHASH@(H2I)) ; "RTN","C0CXPATH",667,0) . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR "RTN","C0CXPATH",668,0) . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE "RTN","C0CXPATH",669,0) . . S IHI="" ; INDEX INTO "M" MULTIPLES "RTN","C0CXPATH",670,0) . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE "RTN","C0CXPATH",671,0) . . . ; W @IH@(IHI) "RTN","C0CXPATH",672,0) . . . S IH3=$NA(@IH2@(IHI)) "RTN","C0CXPATH",673,0) . . . ; W "HEY",IH3,! "RTN","C0CXPATH",674,0) . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS "RTN","C0CXPATH",675,0) . . ; W IH,! "RTN","C0CXPATH",676,0) . . ; W "C0CZZ",! "RTN","C0CXPATH",677,0) . . ; W $NA(@IHASH@(H2I)),! "RTN","C0CXPATH",678,0) . . Q ; "RTN","C0CXPATH",679,0) . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) "RTN","C0CXPATH",680,0) . ; W @IARYRTN@(0),! "RTN","C0CXPATH",681,0) Q "RTN","C0CXPATH",682,0) ; "RTN","C0CXPATH",683,0) XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES "RTN","C0CXPATH",684,0) ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ "RTN","C0CXPATH",685,0) ; XVRTN AND XVIXML ARE PASSED BY NAME "RTN","C0CXPATH",686,0) ; "RTN","C0CXPATH",687,0) N XVI,XVTMP,XVT "RTN","C0CXPATH",688,0) F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML "RTN","C0CXPATH",689,0) . S XVT=@XVIXML@(XVI) "RTN","C0CXPATH",690,0) . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI "RTN","C0CXPATH",691,0) D H2ARY(XVRTN,"XVTMP") "RTN","C0CXPATH",692,0) Q "RTN","C0CXPATH",693,0) ; "RTN","C0CXPATH",694,0) DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE "RTN","C0CXPATH",695,0) ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE "RTN","C0CXPATH",696,0) ; "RTN","C0CXPATH",697,0) N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED "RTN","C0CXPATH",698,0) I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE "RTN","C0CXPATH",699,0) . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP "RTN","C0CXPATH",700,0) . S DXUSE="DTMP" ; DXUSE IS NAME "RTN","C0CXPATH",701,0) E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE "RTN","C0CXPATH",702,0) . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP "RTN","C0CXPATH",703,0) . S DXUSE="DTMP" ; DXUSE IS NAME "RTN","C0CXPATH",704,0) E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE "RTN","C0CXPATH",705,0) N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE "RTN","C0CXPATH",706,0) D XVARS("DVARS",DXUSE) ; PULL OUT VARS "RTN","C0CXPATH",707,0) D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM "RTN","C0CXPATH",708,0) Q "RTN","C0CXPATH",709,0) ; "RTN","C0CXPATH",710,0) TEST ; Run all the test cases "RTN","C0CXPATH",711,0) D TESTALL^C0CUNIT("C0CXPAT0") "RTN","C0CXPATH",712,0) Q "RTN","C0CXPATH",713,0) ; "RTN","C0CXPATH",714,0) ZTEST(WHICH) ; RUN ONE SET OF TESTS "RTN","C0CXPATH",715,0) N ZTMP "RTN","C0CXPATH",716,0) S DEBUG=1 "RTN","C0CXPATH",717,0) D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") "RTN","C0CXPATH",718,0) D ZTEST^C0CUNIT(.ZTMP,WHICH) "RTN","C0CXPATH",719,0) Q "RTN","C0CXPATH",720,0) ; "RTN","C0CXPATH",721,0) TLIST ; LIST THE TESTS "RTN","C0CXPATH",722,0) N ZTMP "RTN","C0CXPATH",723,0) D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") "RTN","C0CXPATH",724,0) D TLIST^C0CUNIT(.ZTMP) "RTN","C0CXPATH",725,0) Q "RTN","C0CXPATH",726,0) ; "VER") 8.0^22.0 **END** **END**