KIDS Distribution saved on Oct 07, 2008@13:29:01 improved meds, repaired Vitals, new cmds DPATV **KIDS**:CCR*1.0*5^ **INSTALL NAME** CCR*1.0*5 "BLD",6955,0) CCR*1.0*5^^0^3081007^n "BLD",6955,1,0) ^^23^23^3080923^ "BLD",6955,1,1,0) "BLD",6955,1,2,0) CCR AND CCD EXPORT TOOLS "BLD",6955,1,3,0) "BLD",6955,1,4,0) SINGLE XML EXPORT TO A HOST DIRECTORY AT "BLD",6955,1,5,0) "BLD",6955,1,6,0) BE SURE TO SET ^TMP("GPLCCR","ODIR")="DIRECTORYNAME" TO AN EXISTING "BLD",6955,1,7,0) DIRECTORY "BLD",6955,1,8,0) "BLD",6955,1,9,0) EXPORT^GPLCRR FOR THE CCR "BLD",6955,1,10,0) EXPORT^GPLCCD FOR THE CCD "BLD",6955,1,11,0) XPAT^GPLCCR(DFN,"","") "BLD",6955,1,12,0) "BLD",6955,1,13,0) BATCH ANALYSIS AND BATCH EXPORT BY RIM CATEGORIES "BLD",6955,1,14,0) "BLD",6955,1,15,0) ANALYZE^GPLRIMA("",5000) TO ANALYZE 5000 PATIENTS. REPEAT TO RESUME "BLD",6955,1,16,0) RESET^GPLRIMA TO RESET ANALYZE - DELETES ^TMP("GPLRIM","RESUME") "BLD",6955,1,17,0) ANALYZE^GPLRIMA(5098,1) TO ANALYZE PATIENT 5098 FOR ONE PATIENT "BLD",6955,1,18,0) "BLD",6955,1,19,0) CLIST^GPLRIMA TO LIST CATEGORY TOTALS "BLD",6955,1,20,0) CPAT^GPLRIMA("RIMTBL_X") TO LIST PATIENTS IN A CATEGORY "BLD",6955,1,21,0) XCPAT^GPLRIMA("RIMTBL_X") TO EXPORT CCR FOR ALL PATIENTS IN CATEGORY "BLD",6955,1,22,0) "BLD",6955,1,23,0) TEST^GPLCCR AND TEST^GPLXPATH RUN UNIT TESTS ON THE CODE "BLD",6955,4,0) ^9.64PA^^ "BLD",6955,6.3) 8 "BLD",6955,"KRN",0) ^9.67PA^8989.52^19 "BLD",6955,"KRN",.4,0) .4 "BLD",6955,"KRN",.401,0) .401 "BLD",6955,"KRN",.402,0) .402 "BLD",6955,"KRN",.403,0) .403 "BLD",6955,"KRN",.5,0) .5 "BLD",6955,"KRN",.84,0) .84 "BLD",6955,"KRN",3.6,0) 3.6 "BLD",6955,"KRN",3.8,0) 3.8 "BLD",6955,"KRN",9.2,0) 9.2 "BLD",6955,"KRN",9.8,0) 9.8 "BLD",6955,"KRN",9.8,"NM",0) ^9.68A^19^19 "BLD",6955,"KRN",9.8,"NM",1,0) CCRDPT^^0^B45805995 "BLD",6955,"KRN",9.8,"NM",2,0) CCRDPTT^^0^B4791589 "BLD",6955,"KRN",9.8,"NM",3,0) CCRMEDS^^0^B59807333 "BLD",6955,"KRN",9.8,"NM",4,0) CCRSYS^^0^B5866233 "BLD",6955,"KRN",9.8,"NM",5,0) CCRUNIT^^0^B8574 "BLD",6955,"KRN",9.8,"NM",6,0) CCRUTIL^^0^B5927217 "BLD",6955,"KRN",9.8,"NM",7,0) CCRVA200^^0^B35847405 "BLD",6955,"KRN",9.8,"NM",8,0) GPLACTOR^^0^B52628160 "BLD",6955,"KRN",9.8,"NM",9,0) GPLXPATH^^0^B241520746 "BLD",6955,"KRN",9.8,"NM",10,0) GPLUNIT^^0^B31438520 "BLD",6955,"KRN",9.8,"NM",11,0) GPLPROBS^^0^B25875394 "BLD",6955,"KRN",9.8,"NM",12,0) GPLVITAL^^0^B82628966 "BLD",6955,"KRN",9.8,"NM",13,0) GPLRIMA^^0^B214212612 "BLD",6955,"KRN",9.8,"NM",14,0) GPLCCR^^0^B82167126 "BLD",6955,"KRN",9.8,"NM",15,0) GPLCCR0^^0^B654252455 "BLD",6955,"KRN",9.8,"NM",16,0) GPLCCD^^0^B114413975 "BLD",6955,"KRN",9.8,"NM",17,0) GPLCCD1^^0^B100039732 "BLD",6955,"KRN",9.8,"NM",18,0) GPLMEDS^^0^B55630630 "BLD",6955,"KRN",9.8,"NM",19,0) GPLXPAT0^^0^B50983429 "BLD",6955,"KRN",9.8,"NM","B","CCRDPT",1) "BLD",6955,"KRN",9.8,"NM","B","CCRDPTT",2) "BLD",6955,"KRN",9.8,"NM","B","CCRMEDS",3) "BLD",6955,"KRN",9.8,"NM","B","CCRSYS",4) "BLD",6955,"KRN",9.8,"NM","B","CCRUNIT",5) "BLD",6955,"KRN",9.8,"NM","B","CCRUTIL",6) "BLD",6955,"KRN",9.8,"NM","B","CCRVA200",7) "BLD",6955,"KRN",9.8,"NM","B","GPLACTOR",8) "BLD",6955,"KRN",9.8,"NM","B","GPLCCD",16) "BLD",6955,"KRN",9.8,"NM","B","GPLCCD1",17) "BLD",6955,"KRN",9.8,"NM","B","GPLCCR",14) "BLD",6955,"KRN",9.8,"NM","B","GPLCCR0",15) "BLD",6955,"KRN",9.8,"NM","B","GPLMEDS",18) "BLD",6955,"KRN",9.8,"NM","B","GPLPROBS",11) "BLD",6955,"KRN",9.8,"NM","B","GPLRIMA",13) "BLD",6955,"KRN",9.8,"NM","B","GPLUNIT",10) "BLD",6955,"KRN",9.8,"NM","B","GPLVITAL",12) "BLD",6955,"KRN",9.8,"NM","B","GPLXPAT0",19) "BLD",6955,"KRN",9.8,"NM","B","GPLXPATH",9) "BLD",6955,"KRN",19,0) 19 "BLD",6955,"KRN",19.1,0) 19.1 "BLD",6955,"KRN",101,0) 101 "BLD",6955,"KRN",409.61,0) 409.61 "BLD",6955,"KRN",771,0) 771 "BLD",6955,"KRN",870,0) 870 "BLD",6955,"KRN",8989.51,0) 8989.51 "BLD",6955,"KRN",8989.52,0) 8989.52 "BLD",6955,"KRN",8994,0) 8994 "BLD",6955,"KRN","B",.4,.4) "BLD",6955,"KRN","B",.401,.401) "BLD",6955,"KRN","B",.402,.402) "BLD",6955,"KRN","B",.403,.403) "BLD",6955,"KRN","B",.5,.5) "BLD",6955,"KRN","B",.84,.84) "BLD",6955,"KRN","B",3.6,3.6) "BLD",6955,"KRN","B",3.8,3.8) "BLD",6955,"KRN","B",9.2,9.2) "BLD",6955,"KRN","B",9.8,9.8) "BLD",6955,"KRN","B",19,19) "BLD",6955,"KRN","B",19.1,19.1) "BLD",6955,"KRN","B",101,101) "BLD",6955,"KRN","B",409.61,409.61) "BLD",6955,"KRN","B",771,771) "BLD",6955,"KRN","B",870,870) "BLD",6955,"KRN","B",8989.51,8989.51) "BLD",6955,"KRN","B",8989.52,8989.52) "BLD",6955,"KRN","B",8994,8994) "BLD",6955,"QUES",0) ^9.62^^ "BLD",6955,"REQB",0) ^9.611^^ "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") 19 "RTN","CCRDPT") 0^1^B45805995 "RTN","CCRDPT",1,0) CCRDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 "RTN","CCRDPT",2,0) ;;0.2;CCRCCD;;Jun 15, 2008;Build 8 "RTN","CCRDPT",3,0) ; "RTN","CCRDPT",4,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","CCRDPT",5,0) ; General Public License. "RTN","CCRDPT",6,0) ; "RTN","CCRDPT",7,0) ; This program is distributed in the hope that it will be useful, "RTN","CCRDPT",8,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","CCRDPT",9,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","CCRDPT",10,0) ; GNU General Public License for more details. "RTN","CCRDPT",11,0) ; "RTN","CCRDPT",12,0) ; You should have received a copy of the GNU General Public License along "RTN","CCRDPT",13,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","CCRDPT",14,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","CCRDPT",15,0) ; "RTN","CCRDPT",16,0) ; CCRDPT CCRCCD/SMH - Routines to Extract Patient Data for "RTN","CCRDPT",17,0) ; FAMILY Family Name "RTN","CCRDPT",18,0) ; GIVEN Given Name "RTN","CCRDPT",19,0) ; MIDDLE Middle Name "RTN","CCRDPT",20,0) ; SUFFIX Suffix Name "RTN","CCRDPT",21,0) ; DISPNAME Display Name "RTN","CCRDPT",22,0) ; DOB Date of Birth "RTN","CCRDPT",23,0) ; GENDER Get Gender "RTN","CCRDPT",24,0) ; SSN Get SSN for ID "RTN","CCRDPT",25,0) ; ADDRTYPE Get Home Address "RTN","CCRDPT",26,0) ; ADDR1 Get Home Address line 1 "RTN","CCRDPT",27,0) ; ADDR2 Get Home Address line 2 "RTN","CCRDPT",28,0) ; CITY Get City for Home Address "RTN","CCRDPT",29,0) ; STATE Get State for Home Address "RTN","CCRDPT",30,0) ; ZIP Get Zip code for Home Address "RTN","CCRDPT",31,0) ; COUNTY Get County for our Address "RTN","CCRDPT",32,0) ; COUNTRY Get Country for our Address "RTN","CCRDPT",33,0) ; RESTEL Residential Telephone "RTN","CCRDPT",34,0) ; WORKTEL Work Telephone "RTN","CCRDPT",35,0) ; EMAIL Email Adddress "RTN","CCRDPT",36,0) ; CELLTEL Cell Phone "RTN","CCRDPT",37,0) ; NOK1FAM Next of Kin 1 (NOK1) Family Name "RTN","CCRDPT",38,0) ; NOK1GIV NOK1 Given Name "RTN","CCRDPT",39,0) ; NOK1MID NOK1 Middle Name "RTN","CCRDPT",40,0) ; NOK1SUF NOK1 Suffi Name "RTN","CCRDPT",41,0) ; NOK1DISP NOK1 Display Name "RTN","CCRDPT",42,0) ; NOK1REL NOK1 Relationship to the patient "RTN","CCRDPT",43,0) ; NOK1ADD1 NOK1 Address 1 "RTN","CCRDPT",44,0) ; NOK1ADD2 NOK1 Address 2 "RTN","CCRDPT",45,0) ; NOK1CITY NOK1 City "RTN","CCRDPT",46,0) ; NOK1STAT NOK1 State "RTN","CCRDPT",47,0) ; NOK1ZIP NOK1 Zip Code "RTN","CCRDPT",48,0) ; NOK1HTEL NOK1 Home Telephone "RTN","CCRDPT",49,0) ; NOK1WTEL NOK1 Work Telephone "RTN","CCRDPT",50,0) ; NOK1SAME Is NOK1's Address the same the patient? "RTN","CCRDPT",51,0) ; NOK2FAM NOK2 Family Name "RTN","CCRDPT",52,0) ; NOK2GIV NOK2 Given Name "RTN","CCRDPT",53,0) ; NOK2MID NOK2 Middle Name "RTN","CCRDPT",54,0) ; NOK2SUF NOK2 Suffi Name "RTN","CCRDPT",55,0) ; NOK2DISP NOK2 Display Name "RTN","CCRDPT",56,0) ; NOK2REL NOK2 Relationship to the patient "RTN","CCRDPT",57,0) ; NOK2ADD1 NOK2 Address 1 "RTN","CCRDPT",58,0) ; NOK2ADD2 NOK2 Address 2 "RTN","CCRDPT",59,0) ; NOK2CITY NOK2 City "RTN","CCRDPT",60,0) ; NOK2STAT NOK2 State "RTN","CCRDPT",61,0) ; NOK2ZIP NOK2 Zip Code "RTN","CCRDPT",62,0) ; NOK2HTEL NOK2 Home Telephone "RTN","CCRDPT",63,0) ; NOK2WTEL NOK2 Work Telephone "RTN","CCRDPT",64,0) ; NOK2SAME Is NOK2's Address the same the patient? "RTN","CCRDPT",65,0) ; EMERFAM Emergency Contact (EMER) Family Name "RTN","CCRDPT",66,0) ; EMERGIV EMER Given Name "RTN","CCRDPT",67,0) ; EMERMID EMER Middle Name "RTN","CCRDPT",68,0) ; EMERSUF EMER Suffi Name "RTN","CCRDPT",69,0) ; EMERDISP EMER Display Name "RTN","CCRDPT",70,0) ; EMERREL EMER Relationship to the patient "RTN","CCRDPT",71,0) ; EMERADD1 EMER Address 1 "RTN","CCRDPT",72,0) ; EMERADD2 EMER Address 2 "RTN","CCRDPT",73,0) ; EMERCITY EMER City "RTN","CCRDPT",74,0) ; EMERSTAT EMER State "RTN","CCRDPT",75,0) ; EMERZIP EMER Zip Code "RTN","CCRDPT",76,0) ; EMERHTEL EMER Home Telephone "RTN","CCRDPT",77,0) ; EMERWTEL EMER Work Telephone "RTN","CCRDPT",78,0) ; EMERSAME Is EMER's Address the same the NOK? "RTN","CCRDPT",79,0) ; "RTN","CCRDPT",80,0) W "No Entry at top!" Q "RTN","CCRDPT",81,0) ; "RTN","CCRDPT",82,0) ;**Revision History** "RTN","CCRDPT",83,0) ; - June 15, 08: v0.1 using merged global "RTN","CCRDPT",84,0) ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. "RTN","CCRDPT",85,0) ; "RTN","CCRDPT",86,0) ; All methods are Public and Extrinsic "RTN","CCRDPT",87,0) ; All calls use Fileman file 2 (Patient). "RTN","CCRDPT",88,0) ; You can obtain field numbers using the data dictionary "RTN","CCRDPT",89,0) ; "RTN","CCRDPT",90,0) FAMILY(DFN) ; Family Name "RTN","CCRDPT",91,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","CCRDPT",92,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",93,0) Q NAME("FAMILY") "RTN","CCRDPT",94,0) GIVEN(DFN) ; Given Name "RTN","CCRDPT",95,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","CCRDPT",96,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",97,0) Q NAME("GIVEN") "RTN","CCRDPT",98,0) MIDDLE(DFN) ; Middle Name "RTN","CCRDPT",99,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","CCRDPT",100,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",101,0) Q NAME("MIDDLE") "RTN","CCRDPT",102,0) SUFFIX(DFN) ; Suffi Name "RTN","CCRDPT",103,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","CCRDPT",104,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",105,0) Q NAME("SUFFIX") "RTN","CCRDPT",106,0) DISPNAME(DFN) ; Display Name "RTN","CCRDPT",107,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.01) "RTN","CCRDPT",108,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","CCRDPT",109,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","CCRDPT",110,0) DOB(DFN) ; Date of Birth "RTN","CCRDPT",111,0) N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","CCRDPT",112,0) ; Date in FM Date Format. Convert to UTC/ISO 8601. "RTN","CCRDPT",113,0) Q $$FMDTOUTC^CCRUTIL(DOB,"D") "RTN","CCRDPT",114,0) GENDER(DFN) ; Gender/Sex "RTN","CCRDPT",115,0) Q $$GET1^DIQ(2,DFN,.02) ; "RTN","CCRDPT",116,0) SSN(DFN) ; SSN "RTN","CCRDPT",117,0) Q $$GET1^DIQ(2,DFN,.09) "RTN","CCRDPT",118,0) ADDRTYPE(DFN) ; Address Type "RTN","CCRDPT",119,0) ; Vista only stores a home address for the patient. "RTN","CCRDPT",120,0) Q "Home" "RTN","CCRDPT",121,0) ADDR1(DFN) ; Get Home Address line 1 "RTN","CCRDPT",122,0) Q $$GET1^DIQ(2,DFN,.111) "RTN","CCRDPT",123,0) ADDR2(DFN) ; Get Home Address line 2 "RTN","CCRDPT",124,0) ; Vista has Lines 2,3; CCR has only line 1,2; so compromise "RTN","CCRDPT",125,0) N ADDLN2,ADDLN3 "RTN","CCRDPT",126,0) S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) "RTN","CCRDPT",127,0) Q:ADDLN3="" ADDLN2 "RTN","CCRDPT",128,0) Q ADDLN2_", "_ADDLN3 "RTN","CCRDPT",129,0) CITY(DFN) ; Get City for Home Address "RTN","CCRDPT",130,0) Q $$GET1^DIQ(2,DFN,.114) "RTN","CCRDPT",131,0) STATE(DFN) ; Get State for Home Address "RTN","CCRDPT",132,0) Q $$GET1^DIQ(2,DFN,.115) "RTN","CCRDPT",133,0) ZIP(DFN) ; Get Zip code for Home Address "RTN","CCRDPT",134,0) Q $$GET1^DIQ(2,DFN,.116) "RTN","CCRDPT",135,0) COUNTY(DFN) ; Get County for our Address "RTN","CCRDPT",136,0) Q $$GET1^DIQ(2,DFN,.117) "RTN","CCRDPT",137,0) COUNTRY(DFN) ; Get Country for our Address "RTN","CCRDPT",138,0) ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... "RTN","CCRDPT",139,0) Q "USA" "RTN","CCRDPT",140,0) RESTEL(DFN) ; Residential Telephone "RTN","CCRDPT",141,0) Q $$GET1^DIQ(2,DFN,.131) "RTN","CCRDPT",142,0) WORKTEL(DFN) ; Work Telephone "RTN","CCRDPT",143,0) Q $$GET1^DIQ(2,DFN,.132) "RTN","CCRDPT",144,0) EMAIL(DFN) ; Email Adddress "RTN","CCRDPT",145,0) Q $$GET1^DIQ(2,DFN,.133) "RTN","CCRDPT",146,0) CELLTEL(DFN) ; Cell Phone "RTN","CCRDPT",147,0) Q $$GET1^DIQ(2,DFN,.134) "RTN","CCRDPT",148,0) NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name "RTN","CCRDPT",149,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","CCRDPT",150,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",151,0) Q NAME("FAMILY") "RTN","CCRDPT",152,0) NOK1GIV(DFN) ; NOK1 Given Name "RTN","CCRDPT",153,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","CCRDPT",154,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",155,0) Q NAME("GIVEN") "RTN","CCRDPT",156,0) NOK1MID(DFN) ; NOK1 Middle Name "RTN","CCRDPT",157,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","CCRDPT",158,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",159,0) Q NAME("MIDDLE") "RTN","CCRDPT",160,0) NOK1SUF(DFN) ; NOK1 Suffi Name "RTN","CCRDPT",161,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","CCRDPT",162,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",163,0) Q NAME("SUFFIX") "RTN","CCRDPT",164,0) NOK1DISP(DFN) ; NOK1 Display Name "RTN","CCRDPT",165,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.211) "RTN","CCRDPT",166,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","CCRDPT",167,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","CCRDPT",168,0) NOK1REL(DFN) ; NOK1 Relationship to the patient "RTN","CCRDPT",169,0) Q $$GET1^DIQ(2,DFN,.212) "RTN","CCRDPT",170,0) NOK1ADD1(DFN) ; NOK1 Address 1 "RTN","CCRDPT",171,0) Q $$GET1^DIQ(2,DFN,.213) "RTN","CCRDPT",172,0) NOK1ADD2(DFN) ; NOK1 Address 2 "RTN","CCRDPT",173,0) N ADDLN2,ADDLN3 "RTN","CCRDPT",174,0) S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) "RTN","CCRDPT",175,0) Q:ADDLN3="" ADDLN2 "RTN","CCRDPT",176,0) Q ADDLN2_", "_ADDLN3 "RTN","CCRDPT",177,0) NOK1CITY(DFN) ; NOK1 City "RTN","CCRDPT",178,0) Q $$GET1^DIQ(2,DFN,.216) "RTN","CCRDPT",179,0) NOK1STAT(DFN) ; NOK1 State "RTN","CCRDPT",180,0) Q $$GET1^DIQ(2,DFN,.217) "RTN","CCRDPT",181,0) NOK1ZIP(DFN) ; NOK1 Zip Code "RTN","CCRDPT",182,0) Q $$GET1^DIQ(2,DFN,.218) "RTN","CCRDPT",183,0) NOK1HTEL(DFN) ; NOK1 Home Telephone "RTN","CCRDPT",184,0) Q $$GET1^DIQ(2,DFN,.219) "RTN","CCRDPT",185,0) NOK1WTEL(DFN) ; NOK1 Work Telephone "RTN","CCRDPT",186,0) Q $$GET1^DIQ(2,DFN,.21011) "RTN","CCRDPT",187,0) NOK1SAME(DFN) ; Is NOK1's Address the same the patient? "RTN","CCRDPT",188,0) Q $$GET1^DIQ(2,DFN,.2125) "RTN","CCRDPT",189,0) NOK2FAM(DFN) ; NOK2 Family Name "RTN","CCRDPT",190,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","CCRDPT",191,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",192,0) Q NAME("FAMILY") "RTN","CCRDPT",193,0) NOK2GIV(DFN) ; NOK2 Given Name "RTN","CCRDPT",194,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","CCRDPT",195,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",196,0) Q NAME("GIVEN") "RTN","CCRDPT",197,0) NOK2MID(DFN) ; NOK2 Middle Name "RTN","CCRDPT",198,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","CCRDPT",199,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",200,0) Q NAME("MIDDLE") "RTN","CCRDPT",201,0) NOK2SUF(DFN) ; NOK2 Suffi Name "RTN","CCRDPT",202,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","CCRDPT",203,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",204,0) Q NAME("SUFFIX") "RTN","CCRDPT",205,0) NOK2DISP(DFN) ; NOK2 Display Name "RTN","CCRDPT",206,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) "RTN","CCRDPT",207,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","CCRDPT",208,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","CCRDPT",209,0) NOK2REL(DFN) ; NOK2 Relationship to the patient "RTN","CCRDPT",210,0) Q $$GET1^DIQ(2,DFN,.2192) "RTN","CCRDPT",211,0) NOK2ADD1(DFN) ; NOK2 Address 1 "RTN","CCRDPT",212,0) Q $$GET1^DIQ(2,DFN,.2193) "RTN","CCRDPT",213,0) NOK2ADD2(DFN) ; NOK2 Address 2 "RTN","CCRDPT",214,0) N ADDLN2,ADDLN3 "RTN","CCRDPT",215,0) S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) "RTN","CCRDPT",216,0) Q:ADDLN3="" ADDLN2 "RTN","CCRDPT",217,0) Q ADDLN2_", "_ADDLN3 "RTN","CCRDPT",218,0) NOK2CITY(DFN) ; NOK2 City "RTN","CCRDPT",219,0) Q $$GET1^DIQ(2,DFN,.2196) "RTN","CCRDPT",220,0) NOK2STAT(DFN) ; NOK2 State "RTN","CCRDPT",221,0) Q $$GET1^DIQ(2,DFN,.2197) "RTN","CCRDPT",222,0) NOK2ZIP(DFN) ; NOK2 Zip Code "RTN","CCRDPT",223,0) Q $$GET1^DIQ(2,DFN,.2198) "RTN","CCRDPT",224,0) NOK2HTEL(DFN) ; NOK2 Home Telephone "RTN","CCRDPT",225,0) Q $$GET1^DIQ(2,DFN,.2199) "RTN","CCRDPT",226,0) NOK2WTEL(DFN) ; NOK2 Work Telephone "RTN","CCRDPT",227,0) Q $$GET1^DIQ(2,DFN,.211011) "RTN","CCRDPT",228,0) NOK2SAME(DFN) ; Is NOK2's Address the same the patient? "RTN","CCRDPT",229,0) Q $$GET1^DIQ(2,DFN,.21925) "RTN","CCRDPT",230,0) EMERFAM(DFN) ; Emergency Contact (EMER) Family Name "RTN","CCRDPT",231,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","CCRDPT",232,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",233,0) Q NAME("FAMILY") "RTN","CCRDPT",234,0) EMERGIV(DFN) ; EMER Given Name "RTN","CCRDPT",235,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","CCRDPT",236,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",237,0) Q NAME("GIVEN") "RTN","CCRDPT",238,0) EMERMID(DFN) ; EMER Middle Name "RTN","CCRDPT",239,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","CCRDPT",240,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",241,0) Q NAME("MIDDLE") "RTN","CCRDPT",242,0) EMERSUF(DFN) ; EMER Suffi Name "RTN","CCRDPT",243,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","CCRDPT",244,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRDPT",245,0) Q NAME("SUFFIX") "RTN","CCRDPT",246,0) EMERDISP(DFN) ; EMER Display Name "RTN","CCRDPT",247,0) N NAME S NAME=$$GET1^DIQ(2,DFN,.331) "RTN","CCRDPT",248,0) ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma "RTN","CCRDPT",249,0) Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") "RTN","CCRDPT",250,0) EMERREL(DFN) ; EMER Relationship to the patient "RTN","CCRDPT",251,0) Q $$GET1^DIQ(2,DFN,.331) "RTN","CCRDPT",252,0) EMERADD1(DFN) ; EMER Address 1 "RTN","CCRDPT",253,0) Q $$GET1^DIQ(2,DFN,.333) "RTN","CCRDPT",254,0) EMERADD2(DFN) ; EMER Address 2 "RTN","CCRDPT",255,0) N ADDLN2,ADDLN3 "RTN","CCRDPT",256,0) S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) "RTN","CCRDPT",257,0) Q:ADDLN3="" ADDLN2 "RTN","CCRDPT",258,0) Q ADDLN2_", "_ADDLN3 "RTN","CCRDPT",259,0) EMERCITY(DFN) ; EMER City "RTN","CCRDPT",260,0) Q $$GET1^DIQ(2,DFN,.336) "RTN","CCRDPT",261,0) EMERSTAT(DFN) ; EMER State "RTN","CCRDPT",262,0) Q $$GET1^DIQ(2,DFN,.337) "RTN","CCRDPT",263,0) EMERZIP(DFN) ; EMER Zip Code "RTN","CCRDPT",264,0) Q $$GET1^DIQ(2,DFN,.338) "RTN","CCRDPT",265,0) EMERHTEL(DFN) ; EMER Home Telephone "RTN","CCRDPT",266,0) Q $$GET1^DIQ(2,DFN,.339) "RTN","CCRDPT",267,0) EMERWTEL(DFN) ; EMER Work Telephone "RTN","CCRDPT",268,0) Q $$GET1^DIQ(2,DFN,.33011) "RTN","CCRDPT",269,0) EMERSAME(DFN) ; Is EMER's Address the same the NOK? "RTN","CCRDPT",270,0) Q $$GET1^DIQ(2,DFN,.3305) "RTN","CCRDPTT") 0^2^B4791589 "RTN","CCRDPTT",1,0) CCRDPTT ; Unit Tester... "RTN","CCRDPTT",2,0) ;;0.1;CCRCCD;;Jun 15, 2008;Build 8 "RTN","CCRDPTT",3,0) ; "RTN","CCRDPTT",4,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","CCRDPTT",5,0) ;General Public License See attached copy of the License. "RTN","CCRDPTT",6,0) ; "RTN","CCRDPTT",7,0) ;This program is free software; you can redistribute it and/or modify "RTN","CCRDPTT",8,0) ;it under the terms of the GNU General Public License as published by "RTN","CCRDPTT",9,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","CCRDPTT",10,0) ;(at your option) any later version. "RTN","CCRDPTT",11,0) ; "RTN","CCRDPTT",12,0) ;This program is distributed in the hope that it will be useful, "RTN","CCRDPTT",13,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","CCRDPTT",14,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","CCRDPTT",15,0) ;GNU General Public License for more details. "RTN","CCRDPTT",16,0) ; "RTN","CCRDPTT",17,0) ;You should have received a copy of the GNU General Public License along "RTN","CCRDPTT",18,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","CCRDPTT",19,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","CCRDPTT",20,0) ; Get the functions in the routine using Rick's routine "RTN","CCRDPTT",21,0) ; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860" "RTN","CCRDPTT",22,0) ; STATS(1,0)="CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08" "RTN","CCRDPTT",23,0) ; STATS(2,0)=" ;;0.1;CCRCCD;;Jun 15, 2008;" "RTN","CCRDPTT",24,0) ; STATS(84,0)="INIT(DFN) ; Copy DFN global to a local variable; PUBLIC" "RTN","CCRDPTT",25,0) ; STATS(93,0)="DESTROY ; Kill local variable; PUBLIC" "RTN","CCRDPTT",26,0) ; STATS(99,0)="FAMILY() ; Family Name; PUBLIC; Extrinsic" "RTN","CCRDPTT",27,0) ; STATS(105,0)="GIVEN() ; Given Name; PUBLIC; Extrinsic" "RTN","CCRDPTT",28,0) ; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic " "RTN","CCRDPTT",29,0) ; etc. "RTN","CCRDPTT",30,0) ; "RTN","CCRDPTT",31,0) ; Load Routine Entry points; We get a sweeeeeet array "RTN","CCRDPTT",32,0) D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory "RTN","CCRDPTT",33,0) N X,Y "RTN","CCRDPTT",34,0) ; Select Patient "RTN","CCRDPTT",35,0) S DIC=2,DIC(0)="AEMQ" D ^DIC "RTN","CCRDPTT",36,0) ; "RTN","CCRDPTT",37,0) W "You have selected patient "_Y,!! "RTN","CCRDPTT",38,0) N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D "RTN","CCRDPTT",39,0) . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " "RTN","CCRDPTT",40,0) . W "valued at " "RTN","CCRDPTT",41,0) . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"CCRDPT"_"("_$P(Y,"^")_")") "RTN","CCRDPTT",42,0) . W ! "RTN","CCRDPTT",43,0) Q "RTN","CCRMEDS") 0^3^B59807333 "RTN","CCRMEDS",1,0) CCRMEDS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR MEDICATIONS ;07/23/08 14:33 "RTN","CCRMEDS",2,0) ;;0.1;CCDCCR;;JUL 16,2008;Build 8 "RTN","CCRMEDS",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","CCRMEDS",4,0) ;General Public License See attached copy of the License. "RTN","CCRMEDS",5,0) ; "RTN","CCRMEDS",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","CCRMEDS",7,0) ;it under the terms of the GNU General Public License as published by "RTN","CCRMEDS",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","CCRMEDS",9,0) ;(at your option) any later version. "RTN","CCRMEDS",10,0) ; "RTN","CCRMEDS",11,0) ;This program is distributed in the hope that it will be useful, "RTN","CCRMEDS",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","CCRMEDS",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","CCRMEDS",14,0) ;GNU General Public License for more details. "RTN","CCRMEDS",15,0) ; "RTN","CCRMEDS",16,0) ;You should have received a copy of the GNU General Public License along "RTN","CCRMEDS",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","CCRMEDS",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","CCRMEDS",19,0) ; "RTN","CCRMEDS",20,0) W "NO ENTRY FROM TOP",! "RTN","CCRMEDS",21,0) Q "RTN","CCRMEDS",22,0) ; "RTN","CCRMEDS",23,0) EXTRACT(MEDXML,DFN,MEDOUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","CCRMEDS",24,0) ; "RTN","CCRMEDS",25,0) ; MEDXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","CCRMEDS",26,0) ; IMEDXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE "RTN","CCRMEDS",27,0) ; "RTN","CCRMEDS",28,0) N HASOP S HASOP=0 ; FLAG FOR HAS OUTPATIENT MEDS "RTN","CCRMEDS",29,0) N MEDCNT S MEDCNT=0 ; COUNT FOR MEDS ALREADY PROCESSED "RTN","CCRMEDS",30,0) ; OUTPATIENT ACTIVE MEDS ARE PROCESSED IN EXTRACT^CCRMEDS1 "RTN","CCRMEDS",31,0) ; OUTPATIENT PENDING MEDS IN EXTRACT^CCRMEDS2 "RTN","CCRMEDS",32,0) ; NON-VA MEDS IN EXTRACT^CCRMEDS3 "RTN","CCRMEDS",33,0) ; INPATIENT MEDS IN EXTRACT^CCRMEDS4 "RTN","CCRMEDS",34,0) ; ALL OTHERS HERE "RTN","CCRMEDS",35,0) S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) "RTN","CCRMEDS",36,0) K @MEDTVMAP ; CLEAR VARIABLE ARRAY "RTN","CCRMEDS",37,0) S @MEDTVMAP@(0)=0 ; INITIALIZE NUMBER OF MEDS PROCESSED "RTN","CCRMEDS",38,0) S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) "RTN","CCRMEDS",39,0) K @MEDTARYTMP ; KILL XML ARRAY "RTN","CCRMEDS",40,0) D EXTRACT^CCRMEDS1(MEDXML,DFN,MEDOUTXML) ; FIRST EXTRACT OUTPATIENT MEDS "RTN","CCRMEDS",41,0) I @MEDOUTXML@(0)>0 D ; CCRMEDS FOUND ACTIVE OP MEDS "RTN","CCRMEDS",42,0) . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML "RTN","CCRMEDS",43,0) . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP "RTN","CCRMEDS",44,0) . W MEDCNT,! "RTN","CCRMEDS",45,0) . W "HAS ACTIVE OP MEDS",! "RTN","CCRMEDS",46,0) N PENDINGXML,MEDPENDING "RTN","CCRMEDS",47,0) S PENDINGXML="MEDPENDING" ;NAME FOR ARRAY "RTN","CCRMEDS",48,0) D EXTRACT^CCRMEDS2(MEDXML,DFN,PENDINGXML) ; FIRST EXTRACT OUTPATIENT MEDS "RTN","CCRMEDS",49,0) I @PENDINGXML@(0)>0 D ; CCRMEDS FOUND PENDING OP MEDS "RTN","CCRMEDS",50,0) . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML "RTN","CCRMEDS",51,0) . I @MEDOUTXML@(0)>0 D ; IF WE NEED TO COMBINE MEDS "RTN","CCRMEDS",52,0) . . D INSINNER^GPLXPATH(MEDOUTXML,PENDINGXML) ;ADD PENDING TO ACTIVE "RTN","CCRMEDS",53,0) . E D CP^GPLXPATH(PENDINGXML,MEDOUTXML) ; NO ACTIVE MEDS, JUST COPY "RTN","CCRMEDS",54,0) . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP "RTN","CCRMEDS",55,0) . ; W MEDCNT,! "RTN","CCRMEDS",56,0) . W "HAS OP PENDING MEDS",! "RTN","CCRMEDS",57,0) N MEDRSLT,I,J,K,MEDPTMP,X,MEDVMAP,TBUF "RTN","CCRMEDS",58,0) D ACTIVE^ORWPS(.MEDRSLT,DFN) "RTN","CCRMEDS",59,0) I '$D(MEDRSLT(1)) D ; NO MEDS FOR THIS PATIENT, EXIT "RTN","CCRMEDS",60,0) . I DEBUG W "MEDICATIONS RPC RETURNED NULL",! "RTN","CCRMEDS",61,0) . S @MEDOUTXML@(0)=0 "RTN","CCRMEDS",62,0) . Q "RTN","CCRMEDS",63,0) ; I DEBUG ZWR MEDRSLT "RTN","CCRMEDS",64,0) M GPLMEDS=MEDRSLT "RTN","CCRMEDS",65,0) S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) "RTN","CCRMEDS",66,0) S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) "RTN","CCRMEDS",67,0) ; I 'HASOP K @MEDTVMAP,@MEDTARYTMP KILL MOVED TO TOP OF ROUTINE "RTN","CCRMEDS",68,0) ; FIRST GO THROUGH MEDRSLT ARRAY AND COUNT MEDS AND LINES IN MEDS "RTN","CCRMEDS",69,0) ; ZA(0) IS TOTAL NUMBER OF MEDS ZA(ZI) IS LINES IN MED ZI "RTN","CCRMEDS",70,0) N ZA,ZI,ZJ,ZK,ZN S (ZI,ZJ,ZK,ZN)=0 ; ZI IS MED NUMBER, ZJ IS LINE IN MED "RTN","CCRMEDS",71,0) ; ZK IS THE NUMBER OF LINES IN A MED AND ZN IS COUNTER THROUGH LINES "RTN","CCRMEDS",72,0) S ZA(0)=0 ; ZA IS ARRAY OF MED LINE COUNTS "RTN","CCRMEDS",73,0) F ZJ=1:1 Q:'$D(MEDRSLT(ZJ)) D ; COUNT THE MEDS AND LINES "RTN","CCRMEDS",74,0) . I MEDRSLT(ZJ)?1"~".E D ; FOUND NEW MED "RTN","CCRMEDS",75,0) . . S ZI=ZI+1 ; INCREMENT MED COUNT "RTN","CCRMEDS",76,0) . . S ZA(0)=ZI ; NEW TOTAL FOR MEDS "RTN","CCRMEDS",77,0) . . S ZA(ZI)=ZJ_U_1 ; EACH ZA(X) IS Y^Z WHERE Y IS START LINE AND Z IS COUNT "RTN","CCRMEDS",78,0) . E D ; FOR EVERY LINE NOT A FIRST LINE IN MED "RTN","CCRMEDS",79,0) . . S ZK=$P(ZA(ZI),U,2)+1 ; INCREMENT LINE COUNT FOR CURRENT MED "RTN","CCRMEDS",80,0) . . S $P(ZA(ZI),U,2)=ZK ; AND STORE IT IN ARRAY "RTN","CCRMEDS",81,0) ;ZWR ZA "RTN","CCRMEDS",82,0) ; S @MEDTVMAP@(0)=ZA(0) ; SAVE NUMBER OF MEDS "RTN","CCRMEDS",83,0) F ZI=1:1:ZA(0) D ; FOR EACH MED "RTN","CCRMEDS",84,0) . I DEBUG W "ZI IS ",ZI,! "RTN","CCRMEDS",85,0) . ; W ZI," ",MEDCNT,! "RTN","CCRMEDS",86,0) . S ZJ=$P(ZA(ZI),U,1) ; INDEX OF FIRST LINE OF MED IN MEDRSLT "RTN","CCRMEDS",87,0) . S MEDPTMP=MEDRSLT(ZJ) ; PULL OUT FIRST LINE OF MED "RTN","CCRMEDS",88,0) . I $P(MEDPTMP,U,1)?1"~OP" Q ; SKIP OP ACTIVE AND PENDING "RTN","CCRMEDS",89,0) . S MEDCNT=MEDCNT+1 ; WE ARE GOING TO ADD A MED "RTN","CCRMEDS",90,0) . S MEDVMAP=$NA(@MEDTVMAP@(MEDCNT)) ; START PAST OP ACTIVE MEDS "RTN","CCRMEDS",91,0) . S @MEDTVMAP@(0)=@MEDTVMAP@(0)+1 ; ADDING A MED HERE "RTN","CCRMEDS",92,0) . S @MEDVMAP@("MEDOBJECTID")="MED"_(MEDCNT) ; UNIQUE OBJID FOR MEDS "RTN","CCRMEDS",93,0) . I $P(MEDPTMP,"^",11)="" S @MEDVMAP@("MEDISSUEDATETXT")="" "RTN","CCRMEDS",94,0) . E S @MEDVMAP@("MEDISSUEDATETXT")=$$FMDTOUTC^CCRUTIL($P(MEDPTMP,"^",11),"DT") ; GETS LAST FILL DATE "RTN","CCRMEDS",95,0) . S @MEDVMAP@("MEDISSUEDATE")="" "RTN","CCRMEDS",96,0) . S @MEDVMAP@("MEDLASTFILLDATETXT")="" "RTN","CCRMEDS",97,0) . S @MEDVMAP@("MEDLASTFILLDATE")="" "RTN","CCRMEDS",98,0) . S @MEDVMAP@("MEDRXNOTXT")="" "RTN","CCRMEDS",99,0) . S @MEDVMAP@("MEDRXNO")="" "RTN","CCRMEDS",100,0) . S @MEDVMAP@("MEDDETAILUNADORNED")="" "RTN","CCRMEDS",101,0) . S @MEDVMAP@("MEDCONCVALUE")="" "RTN","CCRMEDS",102,0) . S @MEDVMAP@("MEDCONCUNIT")="" "RTN","CCRMEDS",103,0) . S @MEDVMAP@("MEDSIZETEXT")="" "RTN","CCRMEDS",104,0) . S @MEDVMAP@("MEDDOSEINDICATOR")="" "RTN","CCRMEDS",105,0) . S @MEDVMAP@("MEDDELIVERYMETHOD")="" "RTN","CCRMEDS",106,0) . S @MEDVMAP@("MEDRATEVALUE")="" "RTN","CCRMEDS",107,0) . S @MEDVMAP@("MEDRATEUNIT")="" "RTN","CCRMEDS",108,0) . S @MEDVMAP@("MEDVEHICLETEXT")="" "RTN","CCRMEDS",109,0) . S @MEDVMAP@("MEDFREQUENCYUNIT")="" "RTN","CCRMEDS",110,0) . S @MEDVMAP@("MEDINTERVALVALUE")="" "RTN","CCRMEDS",111,0) . S @MEDVMAP@("MEDINTERVALUNIT")="" "RTN","CCRMEDS",112,0) . S @MEDVMAP@("MEDPRNFLAG")="" "RTN","CCRMEDS",113,0) . S @MEDVMAP@("MEDPROBLEMOBJECTID")="" "RTN","CCRMEDS",114,0) . S @MEDVMAP@("MEDPROBLEMTYPETXT")="" "RTN","CCRMEDS",115,0) . S @MEDVMAP@("MEDPROBLEMDESCRIPTION")="" "RTN","CCRMEDS",116,0) . S @MEDVMAP@("MEDPROBLEMCODEVALUE")="" "RTN","CCRMEDS",117,0) . S @MEDVMAP@("MEDPROBLEMCODINGSYSTEM")="" "RTN","CCRMEDS",118,0) . S @MEDVMAP@("MEDPROBLEMCODINGVERSION")="" "RTN","CCRMEDS",119,0) . S @MEDVMAP@("MEDPROBLEMSOURCEACTORID")="" "RTN","CCRMEDS",120,0) . S @MEDVMAP@("MEDSTOPINDICATOR")="" "RTN","CCRMEDS",121,0) . S @MEDVMAP@("MEDDIRSEQ")="" "RTN","CCRMEDS",122,0) . S @MEDVMAP@("MEDMULDIRMOD")="" "RTN","CCRMEDS",123,0) . S @MEDVMAP@("MEDPTINSTRUCTIONS")="" "RTN","CCRMEDS",124,0) . S @MEDVMAP@("MEDFULLFILLMENTINSTRUCTIONS")="" "RTN","CCRMEDS",125,0) . S @MEDVMAP@("MEDDATETIMEAGE")="" "RTN","CCRMEDS",126,0) . S @MEDVMAP@("MEDDATETIMEAGEUNITS")="" "RTN","CCRMEDS",127,0) . S @MEDVMAP@("MEDTYPETEXT")="Medication" "RTN","CCRMEDS",128,0) . S @MEDVMAP@("MEDSTATUSTEXT")=$P(MEDPTMP,"^",10) ; STATUS FROM RPC "RTN","CCRMEDS",129,0) . S @MEDVMAP@("MEDSOURCEACTORID")="ACTORSYSTEM_1" "RTN","CCRMEDS",130,0) . S @MEDVMAP@("MEDPRODUCTNAMETEXT")=$P(MEDPTMP,"^",3) "RTN","CCRMEDS",131,0) . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")="" ; DEFAULT VALUE "RTN","CCRMEDS",132,0) . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" "RTN","CCRMEDS",133,0) . S @MEDVMAP@("MEDPRODUCTNAMECODEVERSION")="" "RTN","CCRMEDS",134,0) . I $P(MEDPTMP,U,1)?1"~OP" D ; IS OUTPATIENT, MIGHT HAVE CODE "RTN","CCRMEDS",135,0) . . I $P(MEDPTMP,"^",10)="ACTIVE" D ; ONLY ACTIVE MEDS HAVE CODES "RTN","CCRMEDS",136,0) . . . N RXIEN ; IEN TO RX, EXAMPLE "~OP^13R;O^IBUPROFEN 400MG^" 13 IS IT "RTN","CCRMEDS",137,0) . . . S RXIEN=$$DIGITS($P($P(MEDPTMP,U,2),";",1)) ; GET JUST LEADING DIGITS "RTN","CCRMEDS",138,0) . . . I DEBUG W "RXIEN=",RXIEN,! ; "RTN","CCRMEDS",139,0) . . . D RX^PSO52API(DFN,"MEDCODE",RXIEN) ; EXTRACT THE RX RECORD TO ^TMP "RTN","CCRMEDS",140,0) . . . I $D(^TMP($J,"MEDCODE",DFN,RXIEN,27)) D ; IF SUCCESS "RTN","CCRMEDS",141,0) . . . . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")=^TMP($J,"MEDCODE",DFN,RXIEN,27) "RTN","CCRMEDS",142,0) . . . . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" "RTN","CCRMEDS",143,0) . S @MEDVMAP@("MEDBRANDNAMETEXT")="" "RTN","CCRMEDS",144,0) . S @MEDVMAP@("MEDBRANDNAMECODEVALUE")="" "RTN","CCRMEDS",145,0) . S @MEDVMAP@("MEDBRANDNAMECODINGSYSTEM")="" "RTN","CCRMEDS",146,0) . S @MEDVMAP@("MEDBRANDNAMECODEVERSION")="" "RTN","CCRMEDS",147,0) . S @MEDVMAP@("MEDSTRENGTHVALUE")="" "RTN","CCRMEDS",148,0) . S @MEDVMAP@("MEDSTRENGTHUNIT")="" "RTN","CCRMEDS",149,0) . S @MEDVMAP@("MEDFORMTEXT")="" "RTN","CCRMEDS",150,0) . S @MEDVMAP@("MEDQUANTITYVALUE")="" "RTN","CCRMEDS",151,0) . S @MEDVMAP@("MEDQUANTITYUNIT")="" "RTN","CCRMEDS",152,0) . S @MEDVMAP@("MEDRFNO")="" "RTN","CCRMEDS",153,0) . S ZK=$P(ZA(ZI),U,2) ; NUMBER OF LINES IN MED "RTN","CCRMEDS",154,0) . I ZK>1 D ; MORE THAN ONE LINE IN MED "RTN","CCRMEDS",155,0) . . S @MEDVMAP@("MEDDESCRIPTIONTEXT")=$P(MEDRSLT(ZJ+1)," *",2) "RTN","CCRMEDS",156,0) . I ZK>2 D ; THIRD THROUGH 2+N LINES OF MED ARE INSTRUCTIONS "RTN","CCRMEDS",157,0) . . N TMPTXT S TMPTXT="" ; BUILD UP INSTRUCTION LINE "RTN","CCRMEDS",158,0) . . F ZN=2:1:ZK-1 D ; REMAINING LINES IN EACH MED "RTN","CCRMEDS",159,0) . . . I MEDRSLT(ZJ+ZN)]"\ Sig: " D ; REMOVE THIS MARKUP "RTN","CCRMEDS",160,0) . . . . S TMPTXT=TMPTXT_$P(MEDRSLT(ZJ+ZN),"\ Sig: ",2)_" " ; APPEND 2 TMPTXT "RTN","CCRMEDS",161,0) . . . E S TMPTXT=TMPTXT_MEDRSLT(ZJ+ZN)_" " ; SEPARATE LINES WITH SPACE "RTN","CCRMEDS",162,0) . . S @MEDVMAP@("MEDDIRECTIONDESCRIPTIONTEXT")=TMPTXT ; CP TO MAP VAR "RTN","CCRMEDS",163,0) . S @MEDVMAP@("MEDDOSEVALUE")="" "RTN","CCRMEDS",164,0) . S @MEDVMAP@("MEDDOSEUNIT")="" "RTN","CCRMEDS",165,0) . S @MEDVMAP@("MEDFREQUENCYVALUE")="" "RTN","CCRMEDS",166,0) . S @MEDVMAP@("MEDDURATIONVALUE")="" "RTN","CCRMEDS",167,0) . S @MEDVMAP@("MEDDURATIONUNIT")="" "RTN","CCRMEDS",168,0) . S @MEDVMAP@("MEDDIRECTIONROUTETEXT")="" "RTN","CCRMEDS",169,0) . S @MEDVMAP@("MEDDIRECTIONFREQUENCYVALUE")="" "RTN","CCRMEDS",170,0) . S MEDARYTMP=$NA(@MEDTARYTMP@(ZI)) "RTN","CCRMEDS",171,0) . K @MEDARYTMP "RTN","CCRMEDS",172,0) . D MAP^GPLXPATH(MEDXML,MEDVMAP,MEDARYTMP) "RTN","CCRMEDS",173,0) . I ZI=1&('HASOP) D ; FIRST ONE IS JUST A COPY MAKE SURE OP IS NOT THERE "RTN","CCRMEDS",174,0) . . ; W "FIRST ONE",! "RTN","CCRMEDS",175,0) . . D CP^GPLXPATH(MEDARYTMP,MEDOUTXML) "RTN","CCRMEDS",176,0) . E D ; AFTER THE FIRST OR IF THERE ARE OP, INSERT INNER XML "RTN","CCRMEDS",177,0) . . D INSINNER^GPLXPATH(MEDOUTXML,MEDARYTMP) "RTN","CCRMEDS",178,0) N MEDTMP,MEDI "RTN","CCRMEDS",179,0) D MISSING^GPLXPATH(MEDOUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","CCRMEDS",180,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","CCRMEDS",181,0) . W "MEDICATION MISSING ",! "RTN","CCRMEDS",182,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","CCRMEDS",183,0) Q "RTN","CCRMEDS",184,0) ; "RTN","CCRMEDS",185,0) DIGITS(INSTR) ; RETURN JUST THE LEADING DIGITS OF THE STRING "RTN","CCRMEDS",186,0) ; EXAMPLE: $$DIGITS("13R") RETURNS 13 "RTN","CCRMEDS",187,0) N ALPHA ; CONTANT TO HOLD ALL ALPHA CHARACTERS "RTN","CCRMEDS",188,0) S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ; ALPHAS "RTN","CCRMEDS",189,0) Q $TR(INSTR,ALPHA) ; LEAVE ONLY THE DIGITS "RTN","CCRMEDS",190,0) ; "RTN","CCRSYS") 0^4^B5866233 "RTN","CCRSYS",1,0) CCRSYS ;CCDCCR/SMH - Routine to Get EHR System Information;6JUL2008 "RTN","CCRSYS",2,0) ;;0.1;CCDCCR;;;Build 8 "RTN","CCRSYS",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","CCRSYS",4,0) ;General Public License See attached copy of the License. "RTN","CCRSYS",5,0) ; "RTN","CCRSYS",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","CCRSYS",7,0) ;it under the terms of the GNU General Public License as published by "RTN","CCRSYS",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","CCRSYS",9,0) ;(at your option) any later version. "RTN","CCRSYS",10,0) ; "RTN","CCRSYS",11,0) ;This program is distributed in the hope that it will be useful, "RTN","CCRSYS",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","CCRSYS",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","CCRSYS",14,0) ;GNU General Public License for more details. "RTN","CCRSYS",15,0) ; "RTN","CCRSYS",16,0) ;You should have received a copy of the GNU General Public License along "RTN","CCRSYS",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","CCRSYS",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","CCRSYS",19,0) ; "RTN","CCRSYS",20,0) W "Enter at appropriate points." Q "RTN","CCRSYS",21,0) ; "RTN","CCRSYS",22,0) ; Originally, I was going to use VEPERVER, but VEPERVER "RTN","CCRSYS",23,0) ; actually kills ^TMP($J), outputs it to the screen in a user-friendly "RTN","CCRSYS",24,0) ; manner (press any key to continue), "RTN","CCRSYS",25,0) ; and is really a very half finished routine "RTN","CCRSYS",26,0) ; "RTN","CCRSYS",27,0) ; So for now, I am hard-coding the values. "RTN","CCRSYS",28,0) ; "RTN","CCRSYS",29,0) SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic "RTN","CCRSYS",30,0) Q "WorldVistA EHR/VOE" "RTN","CCRSYS",31,0) ; "RTN","CCRSYS",32,0) SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic "RTN","CCRSYS",33,0) Q "1.0" "RTN","CCRSYS",34,0) ; "RTN","CCRSYS",35,0) PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT "RTN","CCRSYS",36,0) ; DFN = IEN of the Patient to be tested "RTN","CCRSYS",37,0) ; 1 = Merged or Test Patient "RTN","CCRSYS",38,0) ; 0 = Non-test Patient "RTN","CCRSYS",39,0) ; "RTN","CCRSYS",40,0) I DFN="" Q 0 ; BAD DFN PASSED "RTN","CCRSYS",41,0) I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged "RTN","CCRSYS",42,0) I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add "RTN","CCRSYS",43,0) ; "RTN","CCRSYS",44,0) I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING "RTN","CCRSYS",45,0) I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS "RTN","CCRSYS",46,0) N DIERR,DATA "RTN","CCRSYS",47,0) I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT "RTN","CCRSYS",48,0) S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator "RTN","CCRSYS",49,0) ; 1 = Test Patient "RTN","CCRSYS",50,0) ; 0 = Non-test Patient "RTN","CCRSYS",51,0) I DATA Q DATA "RTN","CCRSYS",52,0) S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test "RTN","CCRSYS",53,0) D CLEAN^DILF "RTN","CCRSYS",54,0) I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN "RTN","CCRSYS",55,0) I $E(DATA,1,3)="000" Q 1 "RTN","CCRSYS",56,0) I $E(DATA,1,3)="666" Q 1 "RTN","CCRSYS",57,0) Q 0 "RTN","CCRSYS",58,0) ; "RTN","CCRUNIT") 0^5^B8574 "RTN","CCRUNIT",1,0) CCRUNIT ; A routine that tests some crap "RTN","CCRUNIT",2,0) ;;0.1;CCDCCR;;JUL 13, 2007;Build 8 "RTN","CCRUNIT",3,0) Q "RTN","CCRUNIT",4,0) ; "RTN","CCRUNIT",5,0) MEDS "RTN","CCRUNIT",6,0) N DEBUG S DEBUG=0 "RTN","CCRUNIT",7,0) N DFN S DFN=1 "RTN","CCRUNIT",8,0) K ^TMP($J) "RTN","CCRUNIT",9,0) W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! "RTN","CCRUNIT",10,0) N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) "RTN","CCRUNIT",11,0) N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" "RTN","CCRUNIT",12,0) W "XPATH is: "_XPATH,! "RTN","CCRUNIT",13,0) W "Getting Med Template into MINXML using",! "RTN","CCRUNIT",14,0) W "QUERY^GPLXPATH(T,XPATH,""MINXML"")",!! "RTN","CCRUNIT",15,0) D QUERY^GPLXPATH(T,XPATH,"MINXML") "RTN","CCRUNIT",16,0) W "Executing EXTRACT^CCRMEDS(MINXML,DFN,OUTXML)",! "RTN","CCRUNIT",17,0) W "OUTXML will be ^TMP($J,""OUT"")",! "RTN","CCRUNIT",18,0) N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) "RTN","CCRUNIT",19,0) D EXTRACT^CCRMEDS($NA(MINXML),DFN,OUTXML) "RTN","CCRUNIT",20,0) Q "RTN","CCRUTIL") 0^6^B5927217 "RTN","CCRUTIL",1,0) CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08 "RTN","CCRUTIL",2,0) ;;0.1;CCRCCD;;Jun 15, 2008;Build 8 "RTN","CCRUTIL",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","CCRUTIL",4,0) ;General Public License See attached copy of the License. "RTN","CCRUTIL",5,0) ; "RTN","CCRUTIL",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","CCRUTIL",7,0) ;it under the terms of the GNU General Public License as published by "RTN","CCRUTIL",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","CCRUTIL",9,0) ;(at your option) any later version. "RTN","CCRUTIL",10,0) ; "RTN","CCRUTIL",11,0) ;This program is distributed in the hope that it will be useful, "RTN","CCRUTIL",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","CCRUTIL",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","CCRUTIL",14,0) ;GNU General Public License for more details. "RTN","CCRUTIL",15,0) ; "RTN","CCRUTIL",16,0) ;You should have received a copy of the GNU General Public License along "RTN","CCRUTIL",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","CCRUTIL",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","CCRUTIL",19,0) ; "RTN","CCRUTIL",20,0) W "No Entry at Top!" "RTN","CCRUTIL",21,0) Q "RTN","CCRUTIL",22,0) ; "RTN","CCRUTIL",23,0) FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic "RTN","CCRUTIL",24,0) ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) "RTN","CCRUTIL",25,0) ; If not passed, or passed incorrectly, it's assumed that it is D. "RTN","CCRUTIL",26,0) ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. "RTN","CCRUTIL",27,0) ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC "RTN","CCRUTIL",28,0) ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) "RTN","CCRUTIL",29,0) N UTC,Y,M,D,H,MM,S,OFF "RTN","CCRUTIL",30,0) S Y=1700+$E(DATE,1,3) "RTN","CCRUTIL",31,0) S M=$E(DATE,4,5) "RTN","CCRUTIL",32,0) S D=$E(DATE,6,7) "RTN","CCRUTIL",33,0) S H=$E(DATE,9,10) "RTN","CCRUTIL",34,0) I $L(H)=1 S H="0"_H "RTN","CCRUTIL",35,0) S MM=$E(DATE,11,12) "RTN","CCRUTIL",36,0) I $L(MM)=1 S MM="0"_MM "RTN","CCRUTIL",37,0) S S=$E(DATE,13,14) "RTN","CCRUTIL",38,0) I $L(S)=1 S S="0"_S "RTN","CCRUTIL",39,0) S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. "RTN","CCRUTIL",40,0) ; If H, MM and S are empty, it means that the FM date didn't supply the time. "RTN","CCRUTIL",41,0) ; In this case, set H, MM and S to "00" "RTN","CCRUTIL",42,0) ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? "RTN","CCRUTIL",43,0) S:'$L(H) H="00" "RTN","CCRUTIL",44,0) S:'$L(MM) MM="00" "RTN","CCRUTIL",45,0) S:'$L(S) S="00" "RTN","CCRUTIL",46,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","CCRUTIL",47,0) I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. "RTN","CCRUTIL",48,0) E Q $P(UTC,"T") "RTN","CCRUTIL",49,0) ; "RTN","CCRUTIL",50,0) SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT "RTN","CCRUTIL",51,0) ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE "RTN","CCRUTIL",52,0) ; DATE AND TIME ORDER. DEFAULT IS FORWARD "RTN","CCRUTIL",53,0) ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT "RTN","CCRUTIL",54,0) ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER "RTN","CCRUTIL",55,0) ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER "RTN","CCRUTIL",56,0) ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC "RTN","CCRUTIL",57,0) ; BOTH V1 AND V2 ARE PASSED BY REFERENCE "RTN","CCRUTIL",58,0) N VSRT ; TEMP FOR HASHING DATES "RTN","CCRUTIL",59,0) N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 "RTN","CCRUTIL",60,0) S ZCNT=V2(0) ; COUNTING NUMBER OF DATES "RTN","CCRUTIL",61,0) F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY "RTN","CCRUTIL",62,0) . I $D(V2(ZI)) D ; IF THE DATE EXISTS "RTN","CCRUTIL",63,0) . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE "RTN","CCRUTIL",64,0) . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE "RTN","CCRUTIL",65,0) . . ; W "DATE: ",ZP1," TIME: ",ZP2,! "RTN","CCRUTIL",66,0) . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT "RTN","CCRUTIL",67,0) N ZG "RTN","CCRUTIL",68,0) S ZG=$Q(VSRT("")) "RTN","CCRUTIL",69,0) F D Q:ZG="" ; "RTN","CCRUTIL",70,0) . ; W ZG,! "RTN","CCRUTIL",71,0) . D PUSH^GPLXPATH("V1",@ZG) "RTN","CCRUTIL",72,0) . S ZG=$Q(@ZG) "RTN","CCRUTIL",73,0) I ORDR=-1 D ; HAVE TO REVERSE ORDER "RTN","CCRUTIL",74,0) . N ZG2 "RTN","CCRUTIL",75,0) . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT "RTN","CCRUTIL",76,0) . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER "RTN","CCRUTIL",77,0) . S ZG2(0)=V1(0) "RTN","CCRUTIL",78,0) . D CP^GPLXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY "RTN","CCRUTIL",79,0) Q ZCNT "RTN","CCRUTIL",80,0) ; "RTN","CCRVA200") 0^7^B35847405 "RTN","CCRVA200",1,0) CCRVA200 ;WV/CCDCCR/SMH - Routine to get Provider Data;07/13/2008 "RTN","CCRVA200",2,0) ;;0.1;CCDCCR;;JUL 13, 2007;Build 8 "RTN","CCRVA200",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","CCRVA200",4,0) ;General Public License See attached copy of the License. "RTN","CCRVA200",5,0) ; "RTN","CCRVA200",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","CCRVA200",7,0) ;it under the terms of the GNU General Public License as published by "RTN","CCRVA200",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","CCRVA200",9,0) ;(at your option) any later version. "RTN","CCRVA200",10,0) ; "RTN","CCRVA200",11,0) ;This program is distributed in the hope that it will be useful, "RTN","CCRVA200",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","CCRVA200",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","CCRVA200",14,0) ;GNU General Public License for more details. "RTN","CCRVA200",15,0) ; "RTN","CCRVA200",16,0) ;You should have received a copy of the GNU General Public License along "RTN","CCRVA200",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","CCRVA200",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","CCRVA200",19,0) Q "RTN","CCRVA200",20,0) ; This routine uses Kernel APIs and Direct Global Access to get "RTN","CCRVA200",21,0) ; Proivder Data from File 200. "RTN","CCRVA200",22,0) ; "RTN","CCRVA200",23,0) ; The Global is VA(200,*) "RTN","CCRVA200",24,0) ; "RTN","CCRVA200",25,0) FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC "RTN","CCRVA200",26,0) ; INPUT: DUZ (i.e. File 200 IEN) ByVal "RTN","CCRVA200",27,0) ; OUTPUT: String "RTN","CCRVA200",28,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","CCRVA200",29,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRVA200",30,0) Q NAME("FAMILY") "RTN","CCRVA200",31,0) ; "RTN","CCRVA200",32,0) GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC "RTN","CCRVA200",33,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",34,0) ; OUTPUT: String "RTN","CCRVA200",35,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","CCRVA200",36,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRVA200",37,0) Q NAME("GIVEN") "RTN","CCRVA200",38,0) ; "RTN","CCRVA200",39,0) MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC "RTN","CCRVA200",40,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",41,0) ; OUTPUT: String "RTN","CCRVA200",42,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","CCRVA200",43,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRVA200",44,0) Q NAME("MIDDLE") "RTN","CCRVA200",45,0) ; "RTN","CCRVA200",46,0) SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC "RTN","CCRVA200",47,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",48,0) ; OUTPUT: String "RTN","CCRVA200",49,0) N NAME S NAME=$P(^VA(200,DUZ,0),U) "RTN","CCRVA200",50,0) D NAMECOMP^XLFNAME(.NAME) "RTN","CCRVA200",51,0) Q NAME("SUFFIX") "RTN","CCRVA200",52,0) ; "RTN","CCRVA200",53,0) TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC "RTN","CCRVA200",54,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",55,0) ; OUTPUT: String "RTN","CCRVA200",56,0) ; Gets External Value of Title field in New Person File. "RTN","CCRVA200",57,0) ; It's actually a pointer to file 3.1 "RTN","CCRVA200",58,0) ; 200=New Person File; 8 is Title Field "RTN","CCRVA200",59,0) Q $$GET1^DIQ(200,DUZ_",",8) "RTN","CCRVA200",60,0) ; "RTN","CCRVA200",61,0) NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC "RTN","CCRVA200",62,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",63,0) ; OUTPUT: Delimited String in format: "RTN","CCRVA200",64,0) ; IDType^ID^IDDescription "RTN","CCRVA200",65,0) ; If the NPI doesn't exist, "" is returned. "RTN","CCRVA200",66,0) ; This routine uses a call documented in the Kernel dev guide "RTN","CCRVA200",67,0) ; This call returns as "NPI^TimeEntered^ActiveInactive" "RTN","CCRVA200",68,0) ; It returns -1 for NPI if NPI doesn't exist. "RTN","CCRVA200",69,0) N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) "RTN","CCRVA200",70,0) Q:NPI=-1 "" "RTN","CCRVA200",71,0) Q "NPI^"_NPI_"^HHS" "RTN","CCRVA200",72,0) ; "RTN","CCRVA200",73,0) SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC "RTN","CCRVA200",74,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",75,0) ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" "RTN","CCRVA200",76,0) ; Uses a Kernel API. Returns -1 if a specialty is not specified "RTN","CCRVA200",77,0) ; in file 200. "RTN","CCRVA200",78,0) ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code "RTN","CCRVA200",79,0) N STR S STR=$$GET^XUA4A72(DUZ) "RTN","CCRVA200",80,0) Q:+STR<0 "" "RTN","CCRVA200",81,0) ; Sometimes we have 3 pieces, or 2. Deal with that. "RTN","CCRVA200",82,0) Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) "RTN","CCRVA200",83,0) Q $P(STR,U,2)_"-"_$P(STR,U,3) "RTN","CCRVA200",84,0) ; "RTN","CCRVA200",85,0) ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC "RTN","CCRVA200",86,0) ; INPUT: DUZ, but not needed really... here for future expansion "RTN","CCRVA200",87,0) ; OUTPUT: At this point "Work" "RTN","CCRVA200",88,0) Q "Work" "RTN","CCRVA200",89,0) ; "RTN","CCRVA200",90,0) ADDLINE1(DUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC "RTN","CCRVA200",91,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",92,0) ; Output: String. "RTN","CCRVA200",93,0) ; "RTN","CCRVA200",94,0) ; First, get site number from the institution file. "RTN","CCRVA200",95,0) ; 1st piece returned by $$SITE^VASITE, which gets the system institution "RTN","CCRVA200",96,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","CCRVA200",97,0) ; "RTN","CCRVA200",98,0) ; Second, get mailing address "RTN","CCRVA200",99,0) ; There are two APIs to get the address, one for physical and one for "RTN","CCRVA200",100,0) ; mailing. We will check if mailing exists first, since that's the "RTN","CCRVA200",101,0) ; one we want to use; then check for physical. If neither exists, "RTN","CCRVA200",102,0) ; then we return nothing. We check for the existence of an address "RTN","CCRVA200",103,0) ; by the length of the returned string. "RTN","CCRVA200",104,0) ; NOTE: API doesn't support Address 2, so I won't even include it "RTN","CCRVA200",105,0) ; in the template. "RTN","CCRVA200",106,0) N ADD "RTN","CCRVA200",107,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","CCRVA200",108,0) Q:$L(ADD) $P(ADD,U) "RTN","CCRVA200",109,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","CCRVA200",110,0) Q:$L(ADD) $P(ADD,U) "RTN","CCRVA200",111,0) Q "" "RTN","CCRVA200",112,0) ; "RTN","CCRVA200",113,0) CITY(DUZ) ; Get City for Institution. PUBLIC; EXTRINSIC "RTN","CCRVA200",114,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",115,0) ; Output: String. "RTN","CCRVA200",116,0) ; See ADD1 for comments "RTN","CCRVA200",117,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","CCRVA200",118,0) N ADD "RTN","CCRVA200",119,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","CCRVA200",120,0) Q:$L(ADD) $P(ADD,U,2) "RTN","CCRVA200",121,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","CCRVA200",122,0) Q:$L(ADD) $P(ADD,U,2) "RTN","CCRVA200",123,0) Q "" "RTN","CCRVA200",124,0) ; "RTN","CCRVA200",125,0) STATE(DUZ) ; Get State for Institution. PUBLIC; EXTRINSIC "RTN","CCRVA200",126,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",127,0) ; Output: String. "RTN","CCRVA200",128,0) ; See ADD1 for comments "RTN","CCRVA200",129,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","CCRVA200",130,0) N ADD "RTN","CCRVA200",131,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","CCRVA200",132,0) Q:$L(ADD) $P(ADD,U,3) "RTN","CCRVA200",133,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","CCRVA200",134,0) Q:$L(ADD) $P(ADD,U,3) "RTN","CCRVA200",135,0) Q "" "RTN","CCRVA200",136,0) ; "RTN","CCRVA200",137,0) POSTCODE(DUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC "RTN","CCRVA200",138,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",139,0) ; OUTPUT: String. "RTN","CCRVA200",140,0) ; See ADD1 for comments "RTN","CCRVA200",141,0) N INST S INST=$P($$SITE^VASITE(),U) "RTN","CCRVA200",142,0) N ADD "RTN","CCRVA200",143,0) S ADD=$$MADD^XUAF4(INST) ; mailing address "RTN","CCRVA200",144,0) Q:$L(ADD) $P(ADD,U,4) "RTN","CCRVA200",145,0) S ADD=$$PADD^XUAF4(INST) ; physical address "RTN","CCRVA200",146,0) Q:$L(ADD) $P(ADD,U,4) "RTN","CCRVA200",147,0) Q "" "RTN","CCRVA200",148,0) ; "RTN","CCRVA200",149,0) TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC "RTN","CCRVA200",150,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",151,0) ; OUTPUT: String. "RTN","CCRVA200",152,0) ; Direct global access "RTN","CCRVA200",153,0) N TEL S TEL=$G(^VA(200,DUZ,.13)) "RTN","CCRVA200",154,0) Q $P(TEL,U,2) "RTN","CCRVA200",155,0) ; "RTN","CCRVA200",156,0) TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC "RTN","CCRVA200",157,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",158,0) ; OUTPUT: String. "RTN","CCRVA200",159,0) Q "Office" "RTN","CCRVA200",160,0) ; "RTN","CCRVA200",161,0) EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC "RTN","CCRVA200",162,0) ; INPUT: DUZ ByVal "RTN","CCRVA200",163,0) ; OUTPUT: String "RTN","CCRVA200",164,0) ; Direct global access "RTN","CCRVA200",165,0) N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) "RTN","CCRVA200",166,0) Q $P(EMAIL,U) "RTN","CCRVA200",167,0) ; "RTN","GPLACTOR") 0^8^B52628160 "RTN","GPLACTOR",1,0) GPLACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 "RTN","GPLACTOR",2,0) ;;0.4;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLACTOR",3,0) ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLACTOR",4,0) ; General Public License See attached copy of the License. "RTN","GPLACTOR",5,0) ; "RTN","GPLACTOR",6,0) ; This program is free software; you can redistribute it and/or modify "RTN","GPLACTOR",7,0) ; it under the terms of the GNU General Public License as published by "RTN","GPLACTOR",8,0) ; the Free Software Foundation; either version 2 of the License, or "RTN","GPLACTOR",9,0) ; (at your option) any later version. "RTN","GPLACTOR",10,0) ; "RTN","GPLACTOR",11,0) ; This program is distributed in the hope that it will be useful, "RTN","GPLACTOR",12,0) ; but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLACTOR",13,0) ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLACTOR",14,0) ; GNU General Public License for more details. "RTN","GPLACTOR",15,0) ; "RTN","GPLACTOR",16,0) ; You should have received a copy of the GNU General Public License along "RTN","GPLACTOR",17,0) ; with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLACTOR",18,0) ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLACTOR",19,0) ; "RTN","GPLACTOR",20,0) ; PROCESS THE ACTORS SECTION OF THE CCR "RTN","GPLACTOR",21,0) ; "RTN","GPLACTOR",22,0) ; ===Revision History=== "RTN","GPLACTOR",23,0) ; 0.1 Initial Writing of Skeleton--GPL "RTN","GPLACTOR",24,0) ; 0.2 Patient Data Extraction--SMH "RTN","GPLACTOR",25,0) ; 0.3 Information System Info Extraction--SMH "RTN","GPLACTOR",26,0) ; 0.4 Patient data rouine refactored; adjustments here--SMH "RTN","GPLACTOR",27,0) ; "RTN","GPLACTOR",28,0) EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE "RTN","GPLACTOR",29,0) ; IPXML is the Input Actor Template into which we substitute values "RTN","GPLACTOR",30,0) ; This is straight XML. Values to be substituted are in @@VAL@@ format. "RTN","GPLACTOR",31,0) ; ALST is the actor list global generated by ACTLST^GPLCCR and has format: "RTN","GPLACTOR",32,0) ; ^TMP(7542,1,"ACTORS",0)=Count "RTN","GPLACTOR",33,0) ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" "RTN","GPLACTOR",34,0) ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" "RTN","GPLACTOR",35,0) ; AXML is the output arrary, to contain XML. "RTN","GPLACTOR",36,0) ; "RTN","GPLACTOR",37,0) N I,J,AMAP,AOID,ATYP,AIEN "RTN","GPLACTOR",38,0) D CP^GPLXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML "RTN","GPLACTOR",39,0) D REPLACE^GPLXPATH(AXML,"","//Actors") ; DELETE THE INSIDES "RTN","GPLACTOR",40,0) I DEBUG W "PROCESSING ACTORS ",! "RTN","GPLACTOR",41,0) F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST "RTN","GPLACTOR",42,0) . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR "RTN","GPLACTOR",43,0) . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID "RTN","GPLACTOR",44,0) . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE "RTN","GPLACTOR",45,0) . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER "RTN","GPLACTOR",46,0) . I ATYP="" Q ; NOT A VALID ACTOR "RTN","GPLACTOR",47,0) . ; "RTN","GPLACTOR",48,0) . I DEBUG W AOID_" "_ATYP_" "_AIEN,! "RTN","GPLACTOR",49,0) . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE "RTN","GPLACTOR",50,0) . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") "RTN","GPLACTOR",51,0) . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") "RTN","GPLACTOR",52,0) . ; "RTN","GPLACTOR",53,0) . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE "RTN","GPLACTOR",54,0) . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") "RTN","GPLACTOR",55,0) . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") "RTN","GPLACTOR",56,0) . ; "RTN","GPLACTOR",57,0) . I ATYP="NOK" D ; NOK ACTOR TYPE "RTN","GPLACTOR",58,0) . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") "RTN","GPLACTOR",59,0) . . D NOK("ATMP",AIEN,AOID,"ATMP2") "RTN","GPLACTOR",60,0) . ; "RTN","GPLACTOR",61,0) . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE "RTN","GPLACTOR",62,0) . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") "RTN","GPLACTOR",63,0) . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") "RTN","GPLACTOR",64,0) . ; "RTN","GPLACTOR",65,0) . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE "RTN","GPLACTOR",66,0) . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") "RTN","GPLACTOR",67,0) . . D ORG("ATMP",AIEN,AOID,"ATMP2") "RTN","GPLACTOR",68,0) . ; "RTN","GPLACTOR",69,0) . D INSINNER^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT "RTN","GPLACTOR",70,0) ; "RTN","GPLACTOR",71,0) N ACTTMP "RTN","GPLACTOR",72,0) D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS "RTN","GPLACTOR",73,0) I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - "RTN","GPLACTOR",74,0) . ; STRINGS MARKED AS @@X@@ "RTN","GPLACTOR",75,0) . W "ACTORS Missing list: ",! "RTN","GPLACTOR",76,0) . F I=1:1:ACTTMP(0) W ACTTMP(I),! "RTN","GPLACTOR",77,0) Q "RTN","GPLACTOR",78,0) ; "RTN","GPLACTOR",79,0) PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR "RTN","GPLACTOR",80,0) I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! "RTN","GPLACTOR",81,0) N AMAP,ZX "RTN","GPLACTOR",82,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","GPLACTOR",83,0) K @AMAP "RTN","GPLACTOR",84,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","GPLACTOR",85,0) S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) "RTN","GPLACTOR",86,0) S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) "RTN","GPLACTOR",87,0) S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) "RTN","GPLACTOR",88,0) S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) "RTN","GPLACTOR",89,0) S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) "RTN","GPLACTOR",90,0) S @AMAP@("ACTORSSN")="" "RTN","GPLACTOR",91,0) S @AMAP@("ACTORSSNTEXT")="" "RTN","GPLACTOR",92,0) S @AMAP@("ACTORSSNSOURCEID")="" "RTN","GPLACTOR",93,0) S ZX=$$SSN^CCRDPT(AIEN) "RTN","GPLACTOR",94,0) I ZX'="" D ; IF THERE IS A SSN IN THE RECORD "RTN","GPLACTOR",95,0) . S @AMAP@("ACTORSSN")=ZX "RTN","GPLACTOR",96,0) . S @AMAP@("ACTORSSNTEXT")="SSN" "RTN","GPLACTOR",97,0) . S @AMAP@("ACTORSSNSOURCEID")=AOID "RTN","GPLACTOR",98,0) S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT(AIEN) "RTN","GPLACTOR",99,0) S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) "RTN","GPLACTOR",100,0) S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) "RTN","GPLACTOR",101,0) S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) "RTN","GPLACTOR",102,0) S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) "RTN","GPLACTOR",103,0) S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) "RTN","GPLACTOR",104,0) S @AMAP@("ACTORRESTEL")="" "RTN","GPLACTOR",105,0) S @AMAP@("ACTORRESTELTEXT")="" "RTN","GPLACTOR",106,0) S ZX=$$RESTEL^CCRDPT(AIEN) "RTN","GPLACTOR",107,0) I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD "RTN","GPLACTOR",108,0) . S @AMAP@("ACTORRESTEL")=ZX "RTN","GPLACTOR",109,0) . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" "RTN","GPLACTOR",110,0) S @AMAP@("ACTORWORKTEL")="" "RTN","GPLACTOR",111,0) S @AMAP@("ACTORWORKTELTEXT")="" "RTN","GPLACTOR",112,0) S ZX=$$WORKTEL^CCRDPT(AIEN) "RTN","GPLACTOR",113,0) I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD "RTN","GPLACTOR",114,0) . S @AMAP@("ACTORWORKTEL")=ZX "RTN","GPLACTOR",115,0) . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" "RTN","GPLACTOR",116,0) S @AMAP@("ACTORCELLTEL")="" "RTN","GPLACTOR",117,0) S @AMAP@("ACTORCELLTELTEXT")="" "RTN","GPLACTOR",118,0) S ZX=$$CELLTEL^CCRDPT(AIEN) "RTN","GPLACTOR",119,0) I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD "RTN","GPLACTOR",120,0) . S @AMAP@("ACTORCELLTEL")=ZX "RTN","GPLACTOR",121,0) . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" "RTN","GPLACTOR",122,0) S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT(AIEN) "RTN","GPLACTOR",123,0) S @AMAP@("ACTORADDRESSSOURCEID")=AOID "RTN","GPLACTOR",124,0) S @AMAP@("ACTORIEN")=AIEN "RTN","GPLACTOR",125,0) S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX "RTN","GPLACTOR",126,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE "RTN","GPLACTOR",127,0) D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","GPLACTOR",128,0) Q "RTN","GPLACTOR",129,0) ; "RTN","GPLACTOR",130,0) SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR "RTN","GPLACTOR",131,0) ; "RTN","GPLACTOR",132,0) ; N AMAP "RTN","GPLACTOR",133,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","GPLACTOR",134,0) K @AMAP "RTN","GPLACTOR",135,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","GPLACTOR",136,0) S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^CCRSYS "RTN","GPLACTOR",137,0) S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^CCRSYS "RTN","GPLACTOR",138,0) S @AMAP@("ACTORINFOSYSSOURCEID")=AOID "RTN","GPLACTOR",139,0) D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","GPLACTOR",140,0) Q "RTN","GPLACTOR",141,0) ; "RTN","GPLACTOR",142,0) NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR "RTN","GPLACTOR",143,0) ; "RTN","GPLACTOR",144,0) ; N AMAP "RTN","GPLACTOR",145,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","GPLACTOR",146,0) K @AMAP "RTN","GPLACTOR",147,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","GPLACTOR",148,0) S @AMAP@("ACTORDISPLAYNAME")="" "RTN","GPLACTOR",149,0) S @AMAP@("ACTORRELATION")="" "RTN","GPLACTOR",150,0) S @AMAP@("ACTORRELATIONSOURCEID")="" "RTN","GPLACTOR",151,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE "RTN","GPLACTOR",152,0) D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","GPLACTOR",153,0) Q "RTN","GPLACTOR",154,0) ; "RTN","GPLACTOR",155,0) ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR "RTN","GPLACTOR",156,0) ; "RTN","GPLACTOR",157,0) ; N AMAP "RTN","GPLACTOR",158,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","GPLACTOR",159,0) K @AMAP "RTN","GPLACTOR",160,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","GPLACTOR",161,0) S @AMAP@("ORGANIZATIONNAME")=$P($$SITE^VASITE,U,2) "RTN","GPLACTOR",162,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" "RTN","GPLACTOR",163,0) D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","GPLACTOR",164,0) Q "RTN","GPLACTOR",165,0) ; "RTN","GPLACTOR",166,0) PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR "RTN","GPLACTOR",167,0) ; "RTN","GPLACTOR",168,0) ; N AMAP "RTN","GPLACTOR",169,0) S AMAP=$NA(^TMP($J,"AMAP")) "RTN","GPLACTOR",170,0) K @AMAP "RTN","GPLACTOR",171,0) S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID "RTN","GPLACTOR",172,0) S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRVA200(AIEN) "RTN","GPLACTOR",173,0) S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRVA200(AIEN) "RTN","GPLACTOR",174,0) S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRVA200(AIEN) "RTN","GPLACTOR",175,0) S @AMAP@("ACTORTITLE")=$$TITLE^CCRVA200(AIEN) "RTN","GPLACTOR",176,0) S @AMAP@("IDTYPE")=$P($$NPI^CCRVA200(AIEN),U,1) "RTN","GPLACTOR",177,0) S @AMAP@("ID")=$P($$NPI^CCRVA200(AIEN),U,2) "RTN","GPLACTOR",178,0) S @AMAP@("IDDESC")=$P($$NPI^CCRVA200(AIEN),U,3) "RTN","GPLACTOR",179,0) S @AMAP@("ACTORSPECIALITY")=$$SPEC^CCRVA200(AIEN) "RTN","GPLACTOR",180,0) S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^CCRVA200(AIEN) "RTN","GPLACTOR",181,0) S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^CCRVA200(AIEN) "RTN","GPLACTOR",182,0) S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRVA200(AIEN) "RTN","GPLACTOR",183,0) S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRVA200(AIEN) "RTN","GPLACTOR",184,0) S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^CCRVA200(AIEN) "RTN","GPLACTOR",185,0) S @AMAP@("ACTORTELEPHONE")="" "RTN","GPLACTOR",186,0) S @AMAP@("ACTORTELEPHONETYPE")="" "RTN","GPLACTOR",187,0) S ZX=$$TEL^CCRVA200(AIEN) "RTN","GPLACTOR",188,0) I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE "RTN","GPLACTOR",189,0) . S @AMAP@("ACTORTELEPHONE")=ZX "RTN","GPLACTOR",190,0) . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^CCRVA200(AIEN) "RTN","GPLACTOR",191,0) S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRVA200(AIEN) "RTN","GPLACTOR",192,0) S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" "RTN","GPLACTOR",193,0) S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE "RTN","GPLACTOR",194,0) D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE "RTN","GPLACTOR",195,0) Q "RTN","GPLACTOR",196,0) ; "RTN","GPLCCD") 0^16^B114413975 "RTN","GPLCCD",1,0) GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 "RTN","GPLCCD",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLCCD",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLCCD",4,0) ;General Public License See attached copy of the License. "RTN","GPLCCD",5,0) ; "RTN","GPLCCD",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLCCD",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLCCD",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLCCD",9,0) ;(at your option) any later version. "RTN","GPLCCD",10,0) ; "RTN","GPLCCD",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLCCD",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLCCD",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLCCD",14,0) ;GNU General Public License for more details. "RTN","GPLCCD",15,0) ; "RTN","GPLCCD",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLCCD",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLCCD",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLCCD",19,0) ; "RTN","GPLCCD",20,0) ; EXPORT A CCR "RTN","GPLCCD",21,0) ; "RTN","GPLCCD",22,0) EXPORT ; EXPORT ENTRY POINT FOR CCR "RTN","GPLCCD",23,0) ; Select a patient. "RTN","GPLCCD",24,0) S DIC=2,DIC(0)="AEMQ" D ^DIC "RTN","GPLCCD",25,0) I Y<1 Q ; EXIT "RTN","GPLCCD",26,0) S DFN=$P(Y,U,1) ; SET THE PATIENT "RTN","GPLCCD",27,0) D XPAT(DFN,"","") ; EXPORT TO A FILE "RTN","GPLCCD",28,0) Q "RTN","GPLCCD",29,0) ; "RTN","GPLCCD",30,0) XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE "RTN","GPLCCD",31,0) ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("GPLCCR","ODIR") "RTN","GPLCCD",32,0) ; FN IS FILE NAME, DEFAULTS IF NULL "RTN","GPLCCD",33,0) ; N CCDGLO "RTN","GPLCCD",34,0) D CCDRPC(.CCDGLO,DFN,"CCD","","","") "RTN","GPLCCD",35,0) S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCD",1)) "RTN","GPLCCD",36,0) S ONAM=FN "RTN","GPLCCD",37,0) I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" "RTN","GPLCCD",38,0) S ODIRGLB=$NA(^TMP("GPLCCR","ODIR")) "RTN","GPLCCD",39,0) I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET "RTN","GPLCCD",40,0) . S @ODIRGLB="/home/glilly/CCROUT" "RTN","GPLCCD",41,0) . ;S @ODIRGLB="/home/cedwards/" "RTN","GPLCCD",42,0) . ;S @ODIRGLB="/opt/wv/p/" "RTN","GPLCCD",43,0) S ODIR=DIR "RTN","GPLCCD",44,0) I DIR="" S ODIR=@ODIRGLB "RTN","GPLCCD",45,0) N ZY "RTN","GPLCCD",46,0) S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) "RTN","GPLCCD",47,0) W $P(ZY,U,2) "RTN","GPLCCD",48,0) Q "RTN","GPLCCD",49,0) ; "RTN","GPLCCD",50,0) CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT "RTN","GPLCCD",51,0) ; CCRGRTN IS RETURN ARRAY PASSED BY NAME "RTN","GPLCCD",52,0) ; DFN IS PATIENT IEN "RTN","GPLCCD",53,0) ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART "RTN","GPLCCD",54,0) ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC "RTN","GPLCCD",55,0) ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL "RTN","GPLCCD",56,0) ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME "RTN","GPLCCD",57,0) ; - NULL MEANS NOW "RTN","GPLCCD",58,0) ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND "RTN","GPLCCD",59,0) ; "TO" VARIABLES "RTN","GPLCCD",60,0) ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN "RTN","GPLCCD",61,0) I '$D(DEBUG) S DEBUG=0 "RTN","GPLCCD",62,0) N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD "RTN","GPLCCD",63,0) I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD "RTN","GPLCCD",64,0) S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE "RTN","GPLCCD",65,0) I CCD S CCDGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD "RTN","GPLCCD",66,0) E S CCDGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR "RTN","GPLCCD",67,0) S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS "RTN","GPLCCD",68,0) ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC "RTN","GPLCCD",69,0) S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL "RTN","GPLCCD",70,0) I CCD D LOAD^GPLCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE "RTN","GPLCCD",71,0) E D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE "RTN","GPLCCD",72,0) D CP^GPLXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL "RTN","GPLCCD",73,0) N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES "RTN","GPLCCD",74,0) S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT "RTN","GPLCCD",75,0) S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD "RTN","GPLCCD",76,0) S @CCDGLO@(3)="" ; CAP WITH CCR ROOT "RTN","GPLCCD",77,0) S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO "RTN","GPLCCD",78,0) S @CCDGLO@(@CCDGLO@(0))="" ; FINISH CAP "RTN","GPLCCD",79,0) S @TGLOBAL@(@TGLOBAL@(0))="" ; FINISH CAP TEMP "RTN","GPLCCD",80,0) ; "RTN","GPLCCD",81,0) ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL "RTN","GPLCCD",82,0) ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES "RTN","GPLCCD",83,0) D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body") "RTN","GPLCCD",84,0) D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors") "RTN","GPLCCD",85,0) I 'CCD D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures") "RTN","GPLCCD",86,0) I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),! "RTN","GPLCCD",87,0) ; "RTN","GPLCCD",88,0) I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES "RTN","GPLCCD",89,0) ; MAPPING THE PATIENT PORTION OF THE CDA HEADER "RTN","GPLCCD",90,0) S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient" "RTN","GPLCCD",91,0) D QUERY^GPLXPATH(CCDGLO,ZZX,"ACTT1") "RTN","GPLCCD",92,0) D PATIENT^GPLACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT "RTN","GPLCCD",93,0) I DEBUG D PARY^GPLXPATH("ACTT2") "RTN","GPLCCD",94,0) D REPLACE^GPLXPATH(CCDGLO,"ACTT2",ZZX) "RTN","GPLCCD",95,0) I DEBUG D PARY^GPLXPATH(CCDGLO) "RTN","GPLCCD",96,0) K ACTT1 K ACCT2 "RTN","GPLCCD",97,0) ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER "RTN","GPLCCD",98,0) ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION "RTN","GPLCCD",99,0) D ORG^GPLACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG "RTN","GPLCCD",100,0) D CP^GPLXPATH("ACTT2",CCDGLO) "RTN","GPLCCD",101,0) ; "RTN","GPLCCD",102,0) K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT "RTN","GPLCCD",103,0) S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS "RTN","GPLCCD",104,0) D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS "RTN","GPLCCD",105,0) N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD "RTN","GPLCCD",106,0) F I=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS "RTN","GPLCCD",107,0) . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE "RTN","GPLCCD",108,0) . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL "RTN","GPLCCD",109,0) . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL "RTN","GPLCCD",110,0) . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE "RTN","GPLCCD",111,0) . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS "RTN","GPLCCD",112,0) . S IXML="INXML" "RTN","GPLCCD",113,0) . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION "RTN","GPLCCD",114,0) . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES "RTN","GPLCCD",115,0) . ; W OXML,! "RTN","GPLCCD",116,0) . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL "RTN","GPLCCD",117,0) . W "RUNNING ",CALL,! "RTN","GPLCCD",118,0) . X CALL "RTN","GPLCCD",119,0) . I @OXML@(0)'=0 D ; THERE IS A RESULT "RTN","GPLCCD",120,0) . . I CCD D QUERY^GPLXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH "RTN","GPLCCD",121,0) . . I CCD D UNSHAVE("ITMP",OXML) "RTN","GPLCCD",122,0) . . I CCD D UNMARK^GPLXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION "RTN","GPLCCD",123,0) . ; NOW INSERT THE RESULTS IN THE CCR BUFFER "RTN","GPLCCD",124,0) . D INSERT^GPLXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body") "RTN","GPLCCD",125,0) . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! "RTN","GPLCCD",126,0) ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE "RTN","GPLCCD",127,0) ; D ACTLST^GPLCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST "RTN","GPLCCD",128,0) ; D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") "RTN","GPLCCD",129,0) ; D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") "RTN","GPLCCD",130,0) ; D INSINNER^GPLXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors") "RTN","GPLCCD",131,0) N I,J,DONE S DONE=0 "RTN","GPLCCD",132,0) F I=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE "RTN","GPLCCD",133,0) . S J=$$TRIM^GPLXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS "RTN","GPLCCD",134,0) . W "TRIMMED",J,! "RTN","GPLCCD",135,0) . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE "RTN","GPLCCD",136,0) I CCD D ; TURN THE BODY INTO A CCD COMPONENT "RTN","GPLCCD",137,0) . N I "RTN","GPLCCD",138,0) . F I=1:1:@CCDGLO@(0) D ; SEARCH THROUGH THE ENTIRE ARRAY "RTN","GPLCCD",139,0) . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP "RTN","GPLCCD",140,0) . . . S @CCDGLO@(I)="" ; WITH CCD EQ "RTN","GPLCCD",141,0) . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP "RTN","GPLCCD",142,0) . . . S @CCDGLO@(I)="" "RTN","GPLCCD",143,0) S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD "RTN","GPLCCD",144,0) S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE "RTN","GPLCCD",145,0) Q "RTN","GPLCCD",146,0) ; "RTN","GPLCCD",147,0) INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS "RTN","GPLCCD",148,0) ; TAB IS PASSED BY NAME "RTN","GPLCCD",149,0) W "TAB= ",TAB,! "RTN","GPLCCD",150,0) ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS "RTN","GPLCCD",151,0) D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") "RTN","GPLCCD",152,0) ;D PUSH^GPLXPATH(TAB,"EXTRACT;GPLMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") "RTN","GPLCCD",153,0) I 'CCD D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") "RTN","GPLCCD",154,0) Q "RTN","GPLCCD",155,0) ; "RTN","GPLCCD",156,0) SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT "RTN","GPLCCD",157,0) ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION "RTN","GPLCCD",158,0) N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST "RTN","GPLCCD",159,0) W SHXML,! "RTN","GPLCCD",160,0) W @SHXML@(1),! "RTN","GPLCCD",161,0) D QUEUE^GPLXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED "RTN","GPLCCD",162,0) D QUEUE^GPLXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART "RTN","GPLCCD",163,0) D QUEUE^GPLXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE "RTN","GPLCCD",164,0) D PARY^GPLXPATH("SHBLD") ; PRINT BUILD LIST "RTN","GPLCCD",165,0) D BUILD^GPLXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION "RTN","GPLCCD",166,0) D CP^GPLXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY "RTN","GPLCCD",167,0) Q "RTN","GPLCCD",168,0) ; "RTN","GPLCCD",169,0) UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE "RTN","GPLCCD",170,0) ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML "RTN","GPLCCD",171,0) N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST "RTN","GPLCCD",172,0) W SHXML,! "RTN","GPLCCD",173,0) W @SHXML@(1),! "RTN","GPLCCD",174,0) D QUEUE^GPLXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE "RTN","GPLCCD",175,0) D QUEUE^GPLXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST "RTN","GPLCCD",176,0) D QUEUE^GPLXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP "RTN","GPLCCD",177,0) D PARY^GPLXPATH("SHBLD") ; PRINT BUILD LIST "RTN","GPLCCD",178,0) D BUILD^GPLXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION "RTN","GPLCCD",179,0) D CP^GPLXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY "RTN","GPLCCD",180,0) Q "RTN","GPLCCD",181,0) ; "RTN","GPLCCD",182,0) HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT "RTN","GPLCCD",183,0) N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) "RTN","GPLCCD",184,0) ; K @VMAP "RTN","GPLCCD",185,0) S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") "RTN","GPLCCD",186,0) I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS "RTN","GPLCCD",187,0) . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN "RTN","GPLCCD",188,0) . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? "RTN","GPLCCD",189,0) . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM "RTN","GPLCCD",190,0) . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES "RTN","GPLCCD",191,0) . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES "RTN","GPLCCD",192,0) . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES "RTN","GPLCCD",193,0) . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT "RTN","GPLCCD",194,0) I IHDR'="" D ; HEADER VALUES ARE PROVIDED "RTN","GPLCCD",195,0) . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY "RTN","GPLCCD",196,0) N CTMP "RTN","GPLCCD",197,0) D MAP^GPLXPATH(CXML,VMAP,"CTMP") "RTN","GPLCCD",198,0) D CP^GPLXPATH("CTMP",CXML) "RTN","GPLCCD",199,0) Q "RTN","GPLCCD",200,0) ; "RTN","GPLCCD",201,0) ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML "RTN","GPLCCD",202,0) ; AXML AND ACTRTN ARE PASSED BY NAME "RTN","GPLCCD",203,0) ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 "RTN","GPLCCD",204,0) ; P1= OBJECTID - ACTORPATIENT_2 "RTN","GPLCCD",205,0) ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE "RTN","GPLCCD",206,0) ;OR INSTITUTION "RTN","GPLCCD",207,0) ; OR PERSON(IN PATIENT FILE IE NOK) "RTN","GPLCCD",208,0) ; P3= IEN RECORD NUMBER FOR ACTOR - 2 "RTN","GPLCCD",209,0) N I,J,K,L "RTN","GPLCCD",210,0) K @ACTRTN ; CLEAR RETURN ARRAY "RTN","GPLCCD",211,0) F I=1:1:@AXML@(0) D ; SCAN ALL LINES "RTN","GPLCCD",212,0) . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE "RTN","GPLCCD",213,0) . . S J=$P($P(@AXML@(I),"",2),"",1) "RTN","GPLCCD",214,0) . . W "=>",J,! "RTN","GPLCCD",215,0) . . I J'="" S K(J)="" ; HASHING ACTOR "RTN","GPLCCD",216,0) . . ; TO GET RID OF DUPLICATES "RTN","GPLCCD",217,0) S I="" ; GOING TO $O THROUGH THE HASH "RTN","GPLCCD",218,0) F J=0:0 D Q:$O(K(I))="" ; "RTN","GPLCCD",219,0) . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS "RTN","GPLCCD",220,0) . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID "RTN","GPLCCD",221,0) . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE "RTN","GPLCCD",222,0) . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR "RTN","GPLCCD",223,0) . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY "RTN","GPLCCD",224,0) Q "RTN","GPLCCD",225,0) ; "RTN","GPLCCD",226,0) TEST ; RUN ALL THE TEST CASES "RTN","GPLCCD",227,0) D TESTALL^GPLUNIT("GPLCCR") "RTN","GPLCCD",228,0) Q "RTN","GPLCCD",229,0) ; "RTN","GPLCCD",230,0) ZTEST(WHICH) ; RUN ONE SET OF TESTS "RTN","GPLCCD",231,0) N ZTMP "RTN","GPLCCD",232,0) D ZLOAD^GPLUNIT("ZTMP","GPLCCR") "RTN","GPLCCD",233,0) D ZTEST^GPLUNIT(.ZTMP,WHICH) "RTN","GPLCCD",234,0) Q "RTN","GPLCCD",235,0) ; "RTN","GPLCCD",236,0) TLIST ; LIST THE TESTS "RTN","GPLCCD",237,0) N ZTMP "RTN","GPLCCD",238,0) D ZLOAD^GPLUNIT("ZTMP","GPLCCR") "RTN","GPLCCD",239,0) D TLIST^GPLUNIT(.ZTMP) "RTN","GPLCCD",240,0) Q "RTN","GPLCCD",241,0) ; "RTN","GPLCCD",242,0) ;;> "RTN","GPLCCD",243,0) ;;> "RTN","GPLCCD",244,0) ;;>>>K GPL S GPL="" "RTN","GPLCCD",245,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") "RTN","GPLCCD",246,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCD",247,0) ;;> "RTN","GPLCCD",248,0) ;;>>>K GPL S GPL="" "RTN","GPLCCD",249,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") "RTN","GPLCCD",250,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCD",251,0) ;;> "RTN","GPLCCD",252,0) ;;>>>K GPL S GPL="" "RTN","GPLCCD",253,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") "RTN","GPLCCD",254,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCD",255,0) ;;> "RTN","GPLCCD",256,0) ;;>>>K GPL S GPL="" "RTN","GPLCCD",257,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") "RTN","GPLCCD",258,0) ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") "RTN","GPLCCD",259,0) ;;> "RTN","GPLCCD",260,0) ;;>>>D ZTEST^GPLCCR("ACTLST") "RTN","GPLCCD",261,0) ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") "RTN","GPLCCD",262,0) ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") "RTN","GPLCCD",263,0) ;;>>?G3(G3(0))["" "RTN","GPLCCD",264,0) ;;> "RTN","GPLCCD",265,0) ;;>>>D ZTEST^GPLCCR("CCR") "RTN","GPLCCD",266,0) ;;>>>W $$TRIM^GPLXPATH(CCDGLO) "RTN","GPLCCD",267,0) ;;> "RTN","GPLCCD",268,0) ;;>>>K GPL S GPL="" "RTN","GPLCCD",269,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCD","","","") "RTN","GPLCCD",270,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCD",271,0) ;;> "RTN","GPLCCD1") 0^17^B100039732 "RTN","GPLCCD1",1,0) GPLCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 "RTN","GPLCCD1",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLCCD1",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLCCD1",4,0) ;General Public License See attached copy of the License. "RTN","GPLCCD1",5,0) ; "RTN","GPLCCD1",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLCCD1",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLCCD1",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLCCD1",9,0) ;(at your option) any later version. "RTN","GPLCCD1",10,0) ; "RTN","GPLCCD1",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLCCD1",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLCCD1",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLCCD1",14,0) ;GNU General Public License for more details. "RTN","GPLCCD1",15,0) ; "RTN","GPLCCD1",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLCCD1",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLCCD1",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLCCD1",19,0) ; "RTN","GPLCCD1",20,0) W "This is a CCD TEMPLATE with processing routines",! "RTN","GPLCCD1",21,0) W ! "RTN","GPLCCD1",22,0) Q "RTN","GPLCCD1",23,0) ; "RTN","GPLCCD1",24,0) ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array "RTN","GPLCCD1",25,0) ; ZARY IS PASSED BY NAME "RTN","GPLCCD1",26,0) ; BAT is a string identifying the section "RTN","GPLCCD1",27,0) ; LINE is a test which will evaluate to true or false "RTN","GPLCCD1",28,0) ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' "RTN","GPLCCD1",29,0) ; . S @ZARY@(0)=0 ; initially there are no elements "RTN","GPLCCD1",30,0) ; . W "GOT HERE LOADING "_LINE,! "RTN","GPLCCD1",31,0) N CNT ; count of array elements "RTN","GPLCCD1",32,0) S CNT=@ZARY@(0) ; contains array count "RTN","GPLCCD1",33,0) S CNT=CNT+1 ; increment count "RTN","GPLCCD1",34,0) S @ZARY@(CNT)=LINE ; put the line in the array "RTN","GPLCCD1",35,0) ; S @ZARY@(BAT,CNT)="" ; index the test by battery "RTN","GPLCCD1",36,0) S @ZARY@(0)=CNT ; update the array counter "RTN","GPLCCD1",37,0) Q "RTN","GPLCCD1",38,0) ; "RTN","GPLCCD1",39,0) ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference "RTN","GPLCCD1",40,0) ; ZARY IS PASSED BY NAME "RTN","GPLCCD1",41,0) ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") "RTN","GPLCCD1",42,0) ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE "RTN","GPLCCD1",43,0) K @ZARY S @ZARY="" "RTN","GPLCCD1",44,0) S @ZARY@(0)=0 ; initialize array count "RTN","GPLCCD1",45,0) N LINE,LABEL,BODY "RTN","GPLCCD1",46,0) N INTEST S INTEST=0 ; switch for in the TEMPLATE section "RTN","GPLCCD1",47,0) N SECTION S SECTION="[anonymous]" ; NO section LABEL "RTN","GPLCCD1",48,0) ; "RTN","GPLCCD1",49,0) N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D "RTN","GPLCCD1",50,0) . I LINE?." "1";".E S INTEST=0 ; leaving section "RTN","GPLCCD1",52,0) . I INTEST D ; within the section "RTN","GPLCCD1",53,0) . . I LINE?." "1";><".E D ; sub-section name found "RTN","GPLCCD1",54,0) . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name "RTN","GPLCCD1",55,0) . . I LINE?." "1";;".E D ; line found "RTN","GPLCCD1",56,0) . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array "RTN","GPLCCD1",57,0) Q "RTN","GPLCCD1",58,0) ; "RTN","GPLCCD1",59,0) LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME "RTN","GPLCCD1",60,0) D ZLOAD(ARY,"GPLCCD1") "RTN","GPLCCD1",61,0) ; ZWR @ARY "RTN","GPLCCD1",62,0) Q "RTN","GPLCCD1",63,0) ; "RTN","GPLCCD1",64,0) TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD "RTN","GPLCCD1",65,0) Q "RTN","GPLCCD1",66,0) MARKUP ; "RTN","GPLCCD1",67,0) ;; "RTN","GPLCCD1",68,0) ;; "RTN","GPLCCD1",69,0) ;; "RTN","GPLCCD1",70,0) ;; "RTN","GPLCCD1",71,0) ;; "RTN","GPLCCD1",72,0) ;; "RTN","GPLCCD1",73,0) ;; "RTN","GPLCCD1",74,0) ;; "RTN","GPLCCD1",75,0) ;; "RTN","GPLCCD1",76,0) ;; "RTN","GPLCCD1",77,0) ;; "RTN","GPLCCD1",78,0) ;; "RTN","GPLCCD1",79,0) ;; "RTN","GPLCCD1",80,0) ;; "RTN","GPLCCD1",81,0) ;; "RTN","GPLCCD1",82,0) ;; "RTN","GPLCCD1",83,0) ;; "RTN","GPLCCD1",84,0) ; "RTN","GPLCCD1",85,0) ;; "RTN","GPLCCD1",86,0) ;; "RTN","GPLCCD1",87,0) Q "RTN","GPLCCD1",88,0) ; "RTN","GPLCCD1",89,0) ; "RTN","GPLCCR") 0^14^B82167126 "RTN","GPLCCR",1,0) GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 "RTN","GPLCCR",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLCCR",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLCCR",4,0) ;General Public License See attached copy of the License. "RTN","GPLCCR",5,0) ; "RTN","GPLCCR",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLCCR",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLCCR",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLCCR",9,0) ;(at your option) any later version. "RTN","GPLCCR",10,0) ; "RTN","GPLCCR",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLCCR",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLCCR",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLCCR",14,0) ;GNU General Public License for more details. "RTN","GPLCCR",15,0) ; "RTN","GPLCCR",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLCCR",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLCCR",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLCCR",19,0) ; "RTN","GPLCCR",20,0) ; EXPORT A CCR "RTN","GPLCCR",21,0) ; "RTN","GPLCCR",22,0) EXPORT ; EXPORT ENTRY POINT FOR CCR "RTN","GPLCCR",23,0) ; Select a patient. "RTN","GPLCCR",24,0) S DIC=2,DIC(0)="AEMQ" D ^DIC "RTN","GPLCCR",25,0) I Y<1 Q ; EXIT "RTN","GPLCCR",26,0) S DFN=$P(Y,U,1) ; SET THE PATIENT "RTN","GPLCCR",27,0) D XPAT(DFN,"","") ; EXPORT TO A FILE "RTN","GPLCCR",28,0) Q "RTN","GPLCCR",29,0) ; "RTN","GPLCCR",30,0) XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE "RTN","GPLCCR",31,0) ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("GPLCCR","ODIR") "RTN","GPLCCR",32,0) ; FN IS FILE NAME, DEFAULTS IF NULL "RTN","GPLCCR",33,0) N CCRGLO "RTN","GPLCCR",34,0) I '$D(DIR) S DIR="" "RTN","GPLCCR",35,0) I '$D(FN) S FN="" "RTN","GPLCCR",36,0) D CCRRPC(.CCRGLO,DFN,"CCR","","","") "RTN","GPLCCR",37,0) S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCR",1)) "RTN","GPLCCR",38,0) S ONAM=FN "RTN","GPLCCR",39,0) I FN="" S ONAM="PAT_"_DFN_"_CCR_V1.xml" "RTN","GPLCCR",40,0) S ODIRGLB=$NA(^TMP("GPLCCR","ODIR")) "RTN","GPLCCR",41,0) I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET "RTN","GPLCCR",42,0) . ;S @ODIRGLB="/home/glilly/CCROUT" "RTN","GPLCCR",43,0) . ;S @ODIRGLB="/home/cedwards/" "RTN","GPLCCR",44,0) . S @ODIRGLB="/opt/wv/p/" "RTN","GPLCCR",45,0) S ODIR=DIR "RTN","GPLCCR",46,0) I DIR="" S ODIR=@ODIRGLB "RTN","GPLCCR",47,0) N ZY "RTN","GPLCCR",48,0) S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) "RTN","GPLCCR",49,0) W !,$P(ZY,U,2),! "RTN","GPLCCR",50,0) Q "RTN","GPLCCR",51,0) ; "RTN","GPLCCR",52,0) DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED "RTN","GPLCCR",53,0) ; "RTN","GPLCCR",54,0) N G1 "RTN","GPLCCR",55,0) S G1=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) "RTN","GPLCCR",56,0) I $D(@G1@(0)) D ; CCR EXISTS "RTN","GPLCCR",57,0) . D PARY^GPLXPATH(G1) "RTN","GPLCCR",58,0) E W "CCR NOT CREATED, RUN D XPAT^GPLCCR(DFN,"""","""") FIRST",! "RTN","GPLCCR",59,0) Q "RTN","GPLCCR",60,0) ; "RTN","GPLCCR",61,0) CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT "RTN","GPLCCR",62,0) ; CCRGRTN IS RETURN ARRAY PASSED BY NAME "RTN","GPLCCR",63,0) ; DFN IS PATIENT IEN "RTN","GPLCCR",64,0) ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART "RTN","GPLCCR",65,0) ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC "RTN","GPLCCR",66,0) ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL "RTN","GPLCCR",67,0) ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME "RTN","GPLCCR",68,0) ; - NULL MEANS NOW "RTN","GPLCCR",69,0) ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND "RTN","GPLCCR",70,0) ; "TO" VARIABLES "RTN","GPLCCR",71,0) ; IF NULL WILL DEFAULT TO "FROM" DUZ AND "TO" DFN "RTN","GPLCCR",72,0) I '$D(DEBUG) S DEBUG=0 "RTN","GPLCCR",73,0) S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD "RTN","GPLCCR",74,0) I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION "RTN","GPLCCR",75,0) I '$D(TESTALERT) S TESTALERT=0 ; FLAG FOR TESTING ALERTS SECTION "RTN","GPLCCR",76,0) I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING CCRMEDS SECTION "RTN","GPLCCR",77,0) S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE "RTN","GPLCCR",78,0) S CCRGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR "RTN","GPLCCR",79,0) S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS "RTN","GPLCCR",80,0) ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC "RTN","GPLCCR",81,0) S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL "RTN","GPLCCR",82,0) D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE "RTN","GPLCCR",83,0) D CP^GPLXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL "RTN","GPLCCR",84,0) ; "RTN","GPLCCR",85,0) ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL "RTN","GPLCCR",86,0) ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES "RTN","GPLCCR",87,0) D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") "RTN","GPLCCR",88,0) D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") "RTN","GPLCCR",89,0) D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") "RTN","GPLCCR",90,0) I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! "RTN","GPLCCR",91,0) ; "RTN","GPLCCR",92,0) D HDRMAP(CCRGLO,DFN,HDRARY) ; MAP HEADER VARIABLES "RTN","GPLCCR",93,0) ; "RTN","GPLCCR",94,0) K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT "RTN","GPLCCR",95,0) S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS "RTN","GPLCCR",96,0) D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS "RTN","GPLCCR",97,0) N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD "RTN","GPLCCR",98,0) F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS "RTN","GPLCCR",99,0) . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE "RTN","GPLCCR",100,0) . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL "RTN","GPLCCR",101,0) . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL "RTN","GPLCCR",102,0) . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE "RTN","GPLCCR",103,0) . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS "RTN","GPLCCR",104,0) . S IXML="INXML" "RTN","GPLCCR",105,0) . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES "RTN","GPLCCR",106,0) . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY "RTN","GPLCCR",107,0) . ; W OXML,! "RTN","GPLCCR",108,0) . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL "RTN","GPLCCR",109,0) . I DEBUG W "RUNNING ",CALL,! "RTN","GPLCCR",110,0) . X CALL "RTN","GPLCCR",111,0) . ; NOW INSERT THE RESULTS IN THE CCR BUFFER "RTN","GPLCCR",112,0) . I @OXML@(0)'=0 D ; THERE IS A RESULT "RTN","GPLCCR",113,0) . . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") "RTN","GPLCCR",114,0) . . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! "RTN","GPLCCR",115,0) D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST "RTN","GPLCCR",116,0) D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") "RTN","GPLCCR",117,0) D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") "RTN","GPLCCR",118,0) D INSINNER^GPLXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") "RTN","GPLCCR",119,0) N TRIMI,J,DONE S DONE=0 "RTN","GPLCCR",120,0) F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE "RTN","GPLCCR",121,0) . S J=$$TRIM^GPLXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS "RTN","GPLCCR",122,0) . I DEBUG W "TRIMMED",J,! "RTN","GPLCCR",123,0) . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE "RTN","GPLCCR",124,0) Q "RTN","GPLCCR",125,0) ; "RTN","GPLCCR",126,0) INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS "RTN","GPLCCR",127,0) ; TAB IS PASSED BY NAME "RTN","GPLCCR",128,0) I DEBUG W "TAB= ",TAB,! "RTN","GPLCCR",129,0) ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS "RTN","GPLCCR",130,0) D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") "RTN","GPLCCR",131,0) I TESTMEDS D PUSH^GPLXPATH(TAB,"EXTRACT;CCRMEDS1;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") "RTN","GPLCCR",132,0) I 'TESTMEDS D PUSH^GPLXPATH(TAB,"EXTRACT;CCRMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") "RTN","GPLCCR",133,0) D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") "RTN","GPLCCR",134,0) I TESTLAB D PUSH^GPLXPATH(TAB,"EXTRACT;GPLLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""GPLCCR"",$J,DFN,""RESULTS"")") "RTN","GPLCCR",135,0) I TESTALERT D PUSH^GPLXPATH(TAB,"EXTRACT;GPLALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""GPLCCR"",$J,DFN,""ALERTS"")") "RTN","GPLCCR",136,0) Q "RTN","GPLCCR",137,0) ; "RTN","GPLCCR",138,0) HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT "RTN","GPLCCR",139,0) N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) "RTN","GPLCCR",140,0) ; K @VMAP "RTN","GPLCCR",141,0) S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") "RTN","GPLCCR",142,0) I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS "RTN","GPLCCR",143,0) . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN "RTN","GPLCCR",144,0) . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? "RTN","GPLCCR",145,0) . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM "RTN","GPLCCR",146,0) . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES "RTN","GPLCCR",147,0) . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES "RTN","GPLCCR",148,0) . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES "RTN","GPLCCR",149,0) . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT "RTN","GPLCCR",150,0) I IHDR'="" D ; HEADER VALUES ARE PROVIDED "RTN","GPLCCR",151,0) . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY "RTN","GPLCCR",152,0) N CTMP "RTN","GPLCCR",153,0) D MAP^GPLXPATH(CXML,VMAP,"CTMP") "RTN","GPLCCR",154,0) D CP^GPLXPATH("CTMP",CXML) "RTN","GPLCCR",155,0) Q "RTN","GPLCCR",156,0) ; "RTN","GPLCCR",157,0) ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML "RTN","GPLCCR",158,0) ; AXML AND ACTRTN ARE PASSED BY NAME "RTN","GPLCCR",159,0) ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 "RTN","GPLCCR",160,0) ; P1= OBJECTID - ACTORPATIENT_2 "RTN","GPLCCR",161,0) ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE "RTN","GPLCCR",162,0) ;OR INSTITUTION "RTN","GPLCCR",163,0) ; OR PERSON(IN PATIENT FILE IE NOK) "RTN","GPLCCR",164,0) ; P3= IEN RECORD NUMBER FOR ACTOR - 2 "RTN","GPLCCR",165,0) N I,J,K,L "RTN","GPLCCR",166,0) K @ACTRTN ; CLEAR RETURN ARRAY "RTN","GPLCCR",167,0) F I=1:1:@AXML@(0) D ; SCAN ALL LINES "RTN","GPLCCR",168,0) . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE "RTN","GPLCCR",169,0) . . S J=$P($P(@AXML@(I),"",2),"",1) "RTN","GPLCCR",170,0) . . I DEBUG W "=>",J,! "RTN","GPLCCR",171,0) . . I J'="" S K(J)="" ; HASHING ACTOR "RTN","GPLCCR",172,0) . . ; TO GET RID OF DUPLICATES "RTN","GPLCCR",173,0) S I="" ; GOING TO $O THROUGH THE HASH "RTN","GPLCCR",174,0) F J=0:0 D Q:$O(K(I))="" "RTN","GPLCCR",175,0) . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS "RTN","GPLCCR",176,0) . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID "RTN","GPLCCR",177,0) . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE "RTN","GPLCCR",178,0) . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR "RTN","GPLCCR",179,0) . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY "RTN","GPLCCR",180,0) Q "RTN","GPLCCR",181,0) ; "RTN","GPLCCR",182,0) TEST ; RUN ALL THE TEST CASES "RTN","GPLCCR",183,0) D TESTALL^GPLUNIT("GPLCCR") "RTN","GPLCCR",184,0) Q "RTN","GPLCCR",185,0) ; "RTN","GPLCCR",186,0) ZTEST(WHICH) ; RUN ONE SET OF TESTS "RTN","GPLCCR",187,0) N ZTMP "RTN","GPLCCR",188,0) D ZLOAD^GPLUNIT("ZTMP","GPLCCR") "RTN","GPLCCR",189,0) D ZTEST^GPLUNIT(.ZTMP,WHICH) "RTN","GPLCCR",190,0) Q "RTN","GPLCCR",191,0) ; "RTN","GPLCCR",192,0) TLIST ; LIST THE TESTS "RTN","GPLCCR",193,0) N ZTMP "RTN","GPLCCR",194,0) D ZLOAD^GPLUNIT("ZTMP","GPLCCR") "RTN","GPLCCR",195,0) D TLIST^GPLUNIT(.ZTMP) "RTN","GPLCCR",196,0) Q "RTN","GPLCCR",197,0) ; "RTN","GPLCCR",198,0) ;;> "RTN","GPLCCR",199,0) ;;> "RTN","GPLCCR",200,0) ;;>>>K GPL S GPL="" "RTN","GPLCCR",201,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") "RTN","GPLCCR",202,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCR",203,0) ;;> "RTN","GPLCCR",204,0) ;;>>>K GPL S GPL="" "RTN","GPLCCR",205,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") "RTN","GPLCCR",206,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCR",207,0) ;;> "RTN","GPLCCR",208,0) ;;>>>K GPL S GPL="" "RTN","GPLCCR",209,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") "RTN","GPLCCR",210,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCR",211,0) ;;> "RTN","GPLCCR",212,0) ;;>>>K GPL S GPL="" "RTN","GPLCCR",213,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") "RTN","GPLCCR",214,0) ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") "RTN","GPLCCR",215,0) ;;> "RTN","GPLCCR",216,0) ;;>>>D ZTEST^GPLCCR("ACTLST") "RTN","GPLCCR",217,0) ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") "RTN","GPLCCR",218,0) ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") "RTN","GPLCCR",219,0) ;;>>?G3(G3(0))["" "RTN","GPLCCR",220,0) ;;> "RTN","GPLCCR",221,0) ;;>>>D ZTEST^GPLCCR("CCR") "RTN","GPLCCR",222,0) ;;>>>W $$TRIM^GPLXPATH(CCRGLO) "RTN","GPLCCR",223,0) ;;> "RTN","GPLCCR",224,0) ;;>>>S TESTALERT=1 "RTN","GPLCCR",225,0) ;;>>>K GPL S GPL="" "RTN","GPLCCR",226,0) ;;>>>D CCRRPC^GPLCCR(.GPL,"2","ALERTS","","","") "RTN","GPLCCR",227,0) ;;>>?@GPL@(@GPL@(0))["" "RTN","GPLCCR",228,0) "RTN","GPLCCR0") 0^15^B654252455 "RTN","GPLCCR0",1,0) GPLCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 "RTN","GPLCCR0",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLCCR0",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLCCR0",4,0) ;General Public License See attached copy of the License. "RTN","GPLCCR0",5,0) ; "RTN","GPLCCR0",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLCCR0",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLCCR0",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLCCR0",9,0) ;(at your option) any later version. "RTN","GPLCCR0",10,0) ; "RTN","GPLCCR0",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLCCR0",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLCCR0",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLCCR0",14,0) ;GNU General Public License for more details. "RTN","GPLCCR0",15,0) ; "RTN","GPLCCR0",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLCCR0",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLCCR0",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLCCR0",19,0) ; "RTN","GPLCCR0",20,0) W "This is a CCR TEMPLATE with processing routines",! "RTN","GPLCCR0",21,0) W ! "RTN","GPLCCR0",22,0) Q "RTN","GPLCCR0",23,0) ; "RTN","GPLCCR0",24,0) ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array "RTN","GPLCCR0",25,0) ; ZARY IS PASSED BY NAME "RTN","GPLCCR0",26,0) ; BAT is a string identifying the section "RTN","GPLCCR0",27,0) ; LINE is a test which will evaluate to true or false "RTN","GPLCCR0",28,0) ; I '$G(@ZARY) D ; "RTN","GPLCCR0",29,0) ; . S @ZARY@(0)=0 ; initially there are no elements "RTN","GPLCCR0",30,0) ; . W "GOT HERE LOADING "_LINE,! "RTN","GPLCCR0",31,0) N CNT ; count of array elements "RTN","GPLCCR0",32,0) S CNT=@ZARY@(0) ; contains array count "RTN","GPLCCR0",33,0) S CNT=CNT+1 ; increment count "RTN","GPLCCR0",34,0) S @ZARY@(CNT)=LINE ; put the line in the array "RTN","GPLCCR0",35,0) ; S @ZARY@(BAT,CNT)="" ; index the test by battery "RTN","GPLCCR0",36,0) S @ZARY@(0)=CNT ; update the array counter "RTN","GPLCCR0",37,0) Q "RTN","GPLCCR0",38,0) ; "RTN","GPLCCR0",39,0) ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference "RTN","GPLCCR0",40,0) ; ZARY IS PASSED BY NAME "RTN","GPLCCR0",41,0) ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") "RTN","GPLCCR0",42,0) ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE "RTN","GPLCCR0",43,0) K @ZARY S @ZARY="" "RTN","GPLCCR0",44,0) S @ZARY@(0)=0 ; initialize array count "RTN","GPLCCR0",45,0) N LINE,LABEL,BODY "RTN","GPLCCR0",46,0) N INTEST S INTEST=0 ; switch for in the TEMPLATE section "RTN","GPLCCR0",47,0) N SECTION S SECTION="[anonymous]" ; NO section LABEL "RTN","GPLCCR0",48,0) ; "RTN","GPLCCR0",49,0) N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D "RTN","GPLCCR0",50,0) . I LINE?." "1";".E S INTEST=0 ; leaving section "RTN","GPLCCR0",52,0) . I INTEST D ; within the section "RTN","GPLCCR0",53,0) . . I LINE?." "1";><".E D ; sub-section name found "RTN","GPLCCR0",54,0) . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name "RTN","GPLCCR0",55,0) . . I LINE?." "1";;".E D ; line found "RTN","GPLCCR0",56,0) . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array "RTN","GPLCCR0",57,0) Q "RTN","GPLCCR0",58,0) ; "RTN","GPLCCR0",59,0) LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME "RTN","GPLCCR0",60,0) D ZLOAD(ARY,"GPLCCR0") "RTN","GPLCCR0",61,0) ; ZWR @ARY "RTN","GPLCCR0",62,0) Q "RTN","GPLCCR0",63,0) ; "RTN","GPLCCR0",64,0) ; "RTN","GPLMEDS") 0^18^B55630630 "RTN","GPLMEDS",1,0) GPLMEDS ; CCDCCR/CJE - CCR/CCD PROCESSING FOR MEDICATIONS ;07/23/08 14:33 "RTN","GPLMEDS",2,0) ;;0.1;CCDCCR;;JUL 16,2008;Build 8 "RTN","GPLMEDS",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLMEDS",4,0) ;General Public License See attached copy of the License. "RTN","GPLMEDS",5,0) ; "RTN","GPLMEDS",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLMEDS",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLMEDS",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLMEDS",9,0) ;(at your option) any later version. "RTN","GPLMEDS",10,0) ; "RTN","GPLMEDS",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLMEDS",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLMEDS",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLMEDS",14,0) ;GNU General Public License for more details. "RTN","GPLMEDS",15,0) ; "RTN","GPLMEDS",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLMEDS",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLMEDS",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLMEDS",19,0) ; "RTN","GPLMEDS",20,0) W "NO ENTRY FROM TOP",! "RTN","GPLMEDS",21,0) Q "RTN","GPLMEDS",22,0) ; "RTN","GPLMEDS",23,0) EXTRACT(MEDXML,DFN,MEDOUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE "RTN","GPLMEDS",24,0) ; "RTN","GPLMEDS",25,0) ; MEDXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","GPLMEDS",26,0) ; IMEDXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE "RTN","GPLMEDS",27,0) ; "RTN","GPLMEDS",28,0) N HASOP S HASOP=0 ; FLAG FOR HAS OUTPATIENT MEDS "RTN","GPLMEDS",29,0) N MEDCNT S MEDCNT=0 ; COUNT FOR MEDS ALREADY PROCESSED "RTN","GPLMEDS",30,0) ; OUTPATIENT MEDS ARE PROCESSED IN EXTRACT^CCRMEDS, ALL OTHERS HERE "RTN","GPLMEDS",31,0) D EXTRACT^CCRMEDS(MEDXML,DFN,MEDOUTXML) ; FIRST EXTRACT OUTPATIENT MEDS "RTN","GPLMEDS",32,0) I @MEDOUTXML@(0)>0 D ; CCRMEDS FOUND ACTIVE OP MEDS "RTN","GPLMEDS",33,0) . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML "RTN","GPLMEDS",34,0) . S MEDCNT=@MEDOUTXML@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP "RTN","GPLMEDS",35,0) . W "HAS ACTIVE OP MEDS",! "RTN","GPLMEDS",36,0) N MEDRSLT,I,J,K,MEDPTMP,X,MEDVMAP,TBUF "RTN","GPLMEDS",37,0) D ACTIVE^ORWPS(.MEDRSLT,DFN) "RTN","GPLMEDS",38,0) I '$D(MEDRSLT(1)) D ; NO MEDS FOR THIS PATIENT, EXIT "RTN","GPLMEDS",39,0) . I DEBUG W "MEDICATIONS RPC RETURNED NULL",! "RTN","GPLMEDS",40,0) . S @MEDOUTXML@(0)=0 "RTN","GPLMEDS",41,0) . Q "RTN","GPLMEDS",42,0) ; I DEBUG ZWR MEDRSLT "RTN","GPLMEDS",43,0) M GPLMEDS=MEDRSLT "RTN","GPLMEDS",44,0) S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) "RTN","GPLMEDS",45,0) S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) "RTN","GPLMEDS",46,0) I 'HASOP K @MEDTVMAP,@MEDTARYTMP "RTN","GPLMEDS",47,0) ; FIRST GO THROUGH MEDRSLT ARRAY AND COUNT MEDS AND LINES IN MEDS "RTN","GPLMEDS",48,0) ; ZA(0) IS TOTAL NUMBER OF MEDS ZA(ZI) IS LINES IN MED ZI "RTN","GPLMEDS",49,0) N ZA,ZI,ZJ,ZK,ZN S (ZI,ZJ,ZK,ZN)=0 ; ZI IS MED NUMBER, ZJ IS LINE IN MED "RTN","GPLMEDS",50,0) ; ZK IS THE NUMBER OF LINES IN A MED AND ZN IS COUNTER THROUGH LINES "RTN","GPLMEDS",51,0) S ZA(0)=0 ; ZA IS ARRAY OF MED LINE COUNTS "RTN","GPLMEDS",52,0) F ZJ=1:1 Q:'$D(MEDRSLT(ZJ)) D ; COUNT THE MEDS AND LINES "RTN","GPLMEDS",53,0) . I MEDRSLT(ZJ)?1"~".E D ; FOUND NEW MED "RTN","GPLMEDS",54,0) . . S ZI=ZI+1 ; INCREMENT MED COUNT "RTN","GPLMEDS",55,0) . . S ZA(0)=ZI ; NEW TOTAL FOR MEDS "RTN","GPLMEDS",56,0) . . S ZA(ZI)=ZJ_U_1 ; EACH ZA(X) IS Y^Z WHERE Y IS START LINE AND Z IS COUNT "RTN","GPLMEDS",57,0) . E D ; FOR EVERY LINE NOT A FIRST LINE IN MED "RTN","GPLMEDS",58,0) . . S ZK=$P(ZA(ZI),U,2)+1 ; INCREMENT LINE COUNT FOR CURRENT MED "RTN","GPLMEDS",59,0) . . S $P(ZA(ZI),U,2)=ZK ; AND STORE IT IN ARRAY "RTN","GPLMEDS",60,0) ;ZWR ZA "RTN","GPLMEDS",61,0) S @MEDTVMAP@(0)=ZA(0) ; SAVE NUMBER OF MEDS "RTN","GPLMEDS",62,0) F ZI=1:1:ZA(0) D ; FOR EACH MED "RTN","GPLMEDS",63,0) . I DEBUG W "ZI IS ",ZI,! "RTN","GPLMEDS",64,0) . S MEDVMAP=$NA(@MEDTVMAP@(ZI+MEDCNT)) ; START PAST OP ACTIVE MEDS "RTN","GPLMEDS",65,0) . K @MEDVMAP "RTN","GPLMEDS",66,0) . I DEBUG W "VMAP= ",MEDVMAP,! "RTN","GPLMEDS",67,0) . S ZJ=$P(ZA(ZI),U,1) ; INDEX OF FIRST LINE OF MED IN MEDRSLT "RTN","GPLMEDS",68,0) . S MEDPTMP=MEDRSLT(ZJ) ; PULL OUT FIRST LINE OF MED "RTN","GPLMEDS",69,0) . I $P(MEDPTMP,U,1)?1"~OP"&$P(MEDPTMP,"^",10)="ACTIVE" Q ; SKIP OP ACTIVE "RTN","GPLMEDS",70,0) . S @MEDVMAP@("MEDOBJECTID")="MED"_(ZI+MEDCNT) ; UNIQUE OBJID FOR MEDS "RTN","GPLMEDS",71,0) . I $P(MEDPTMP,"^",11)="" S @MEDVMAP@("MEDISSUEDATETXT")="" "RTN","GPLMEDS",72,0) . E S @MEDVMAP@("MEDISSUEDATETXT")=$$FMDTOUTC^CCRUTIL($P(MEDPTMP,"^",11),"DT") ; GETS LAST FILL DATE "RTN","GPLMEDS",73,0) . S @MEDVMAP@("MEDISSUEDATE")="" "RTN","GPLMEDS",74,0) . S @MEDVMAP@("MEDLASTFILLDATETXT")="" "RTN","GPLMEDS",75,0) . S @MEDVMAP@("MEDLASTFILLDATE")="" "RTN","GPLMEDS",76,0) . S @MEDVMAP@("MEDRXNOTXT")="" "RTN","GPLMEDS",77,0) . S @MEDVMAP@("MEDRXNO")="" "RTN","GPLMEDS",78,0) . S @MEDVMAP@("MEDDETAILUNADORNED")="" "RTN","GPLMEDS",79,0) . S @MEDVMAP@("MEDCONCVALUE")="" "RTN","GPLMEDS",80,0) . S @MEDVMAP@("MEDCONCUNIT")="" "RTN","GPLMEDS",81,0) . S @MEDVMAP@("MEDSIZETEXT")="" "RTN","GPLMEDS",82,0) . S @MEDVMAP@("MEDDOSEINDICATOR")="" "RTN","GPLMEDS",83,0) . S @MEDVMAP@("MEDDELIVERYMETHOD")="" "RTN","GPLMEDS",84,0) . S @MEDVMAP@("MEDRATEVALUE")="" "RTN","GPLMEDS",85,0) . S @MEDVMAP@("MEDRATEUNIT")="" "RTN","GPLMEDS",86,0) . S @MEDVMAP@("MEDVEHICLETEXT")="" "RTN","GPLMEDS",87,0) . S @MEDVMAP@("MEDFREQUENCYUNIT")="" "RTN","GPLMEDS",88,0) . S @MEDVMAP@("MEDINTERVALVALUE")="" "RTN","GPLMEDS",89,0) . S @MEDVMAP@("MEDINTERVALUNIT")="" "RTN","GPLMEDS",90,0) . S @MEDVMAP@("MEDPRNFLAG")="" "RTN","GPLMEDS",91,0) . S @MEDVMAP@("MEDPROBLEMOBJECTID")="" "RTN","GPLMEDS",92,0) . S @MEDVMAP@("MEDPROBLEMTYPETXT")="" "RTN","GPLMEDS",93,0) . S @MEDVMAP@("MEDPROBLEMDESCRIPTION")="" "RTN","GPLMEDS",94,0) . S @MEDVMAP@("MEDPROBLEMCODEVALUE")="" "RTN","GPLMEDS",95,0) . S @MEDVMAP@("MEDPROBLEMCODINGSYSTEM")="" "RTN","GPLMEDS",96,0) . S @MEDVMAP@("MEDPROBLEMCODINGVERSION")="" "RTN","GPLMEDS",97,0) . S @MEDVMAP@("MEDPROBLEMSOURCEACTORID")="" "RTN","GPLMEDS",98,0) . S @MEDVMAP@("MEDSTOPINDICATOR")="" "RTN","GPLMEDS",99,0) . S @MEDVMAP@("MEDDIRSEQ")="" "RTN","GPLMEDS",100,0) . S @MEDVMAP@("MEDMULDIRMOD")="" "RTN","GPLMEDS",101,0) . S @MEDVMAP@("MEDPTINSTRUCTIONS")="" "RTN","GPLMEDS",102,0) . S @MEDVMAP@("MEDFULLFILLMENTINSTRUCTIONS")="" "RTN","GPLMEDS",103,0) . S @MEDVMAP@("MEDDATETIMEAGE")="" "RTN","GPLMEDS",104,0) . S @MEDVMAP@("MEDDATETIMEAGEUNITS")="" "RTN","GPLMEDS",105,0) . S @MEDVMAP@("MEDTYPETEXT")="Medication" "RTN","GPLMEDS",106,0) . S @MEDVMAP@("MEDSTATUSTEXT")=$P(MEDPTMP,"^",10) ; STATUS FROM RPC "RTN","GPLMEDS",107,0) . S @MEDVMAP@("MEDSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLMEDS",108,0) . S @MEDVMAP@("MEDPRODUCTNAMETEXT")=$P(MEDPTMP,"^",3) "RTN","GPLMEDS",109,0) . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")="" ; DEFAULT VALUE "RTN","GPLMEDS",110,0) . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" "RTN","GPLMEDS",111,0) . S @MEDVMAP@("MEDPRODUCTNAMECODEVERSION")="" "RTN","GPLMEDS",112,0) . I $P(MEDPTMP,U,1)?1"~OP" D ; IS OUTPATIENT, MIGHT HAVE CODE "RTN","GPLMEDS",113,0) . . I $P(MEDPTMP,"^",10)="ACTIVE" D ; ONLY ACTIVE MEDS HAVE CODES "RTN","GPLMEDS",114,0) . . . N RXIEN ; IEN TO RX, EXAMPLE "~OP^13R;O^IBUPROFEN 400MG^" 13 IS IT "RTN","GPLMEDS",115,0) . . . S RXIEN=$$DIGITS($P($P(MEDPTMP,U,2),";",1)) ; GET JUST LEADING DIGITS "RTN","GPLMEDS",116,0) . . . I DEBUG W "RXIEN=",RXIEN,! ; "RTN","GPLMEDS",117,0) . . . D RX^PSO52API(DFN,"MEDCODE",RXIEN) ; EXTRACT THE RX RECORD TO ^TMP "RTN","GPLMEDS",118,0) . . . I $D(^TMP($J,"MEDCODE",DFN,RXIEN,27)) D ; IF SUCCESS "RTN","GPLMEDS",119,0) . . . . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")=^TMP($J,"MEDCODE",DFN,RXIEN,27) "RTN","GPLMEDS",120,0) . . . . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" "RTN","GPLMEDS",121,0) . S @MEDVMAP@("MEDBRANDNAMETEXT")="" "RTN","GPLMEDS",122,0) . S @MEDVMAP@("MEDBRANDNAMECODEVALUE")="" "RTN","GPLMEDS",123,0) . S @MEDVMAP@("MEDBRANDNAMECODINGSYSTEM")="" "RTN","GPLMEDS",124,0) . S @MEDVMAP@("MEDBRANDNAMECODEVERSION")="" "RTN","GPLMEDS",125,0) . S @MEDVMAP@("MEDSTRENGTHVALUE")="" "RTN","GPLMEDS",126,0) . S @MEDVMAP@("MEDSTRENGTHUNIT")="" "RTN","GPLMEDS",127,0) . S @MEDVMAP@("MEDFORMTEXT")="" "RTN","GPLMEDS",128,0) . S @MEDVMAP@("MEDQUANTITYVALUE")="" "RTN","GPLMEDS",129,0) . S @MEDVMAP@("MEDQUANTITYUNIT")="" "RTN","GPLMEDS",130,0) . S @MEDVMAP@("MEDRFNO")="" "RTN","GPLMEDS",131,0) . S ZK=$P(ZA(ZI),U,2) ; NUMBER OF LINES IN MED "RTN","GPLMEDS",132,0) . I ZK>1 D ; MORE THAN ONE LINE IN MED "RTN","GPLMEDS",133,0) . . S @MEDVMAP@("MEDDESCRIPTIONTEXT")=$P(MEDRSLT(ZJ+1)," *",2) "RTN","GPLMEDS",134,0) . I ZK>2 D ; THIRD THROUGH 2+N LINES OF MED ARE INSTRUCTIONS "RTN","GPLMEDS",135,0) . . N TMPTXT S TMPTXT="" ; BUILD UP INSTRUCTION LINE "RTN","GPLMEDS",136,0) . . F ZN=2:1:ZK-1 D ; REMAINING LINES IN EACH MED "RTN","GPLMEDS",137,0) . . . I MEDRSLT(ZJ+ZN)]"\ Sig: " D ; REMOVE THIS MARKUP "RTN","GPLMEDS",138,0) . . . . S TMPTXT=TMPTXT_$P(MEDRSLT(ZJ+ZN),"\ Sig: ",2)_" " ; APPEND 2 TMPTXT "RTN","GPLMEDS",139,0) . . . E S TMPTXT=TMPTXT_MEDRSLT(ZJ+ZN)_" " ; SEPARATE LINES WITH SPACE "RTN","GPLMEDS",140,0) . . S @MEDVMAP@("MEDDIRECTIONDESCRIPTIONTEXT")=TMPTXT ; CP TO MAP VAR "RTN","GPLMEDS",141,0) . S @MEDVMAP@("MEDDOSEVALUE")="" "RTN","GPLMEDS",142,0) . S @MEDVMAP@("MEDDOSEUNIT")="" "RTN","GPLMEDS",143,0) . S @MEDVMAP@("MEDFREQUENCYVALUE")="" "RTN","GPLMEDS",144,0) . S @MEDVMAP@("MEDDURATIONVALUE")="" "RTN","GPLMEDS",145,0) . S @MEDVMAP@("MEDDURATIONUNIT")="" "RTN","GPLMEDS",146,0) . S @MEDVMAP@("MEDDIRECTIONROUTETEXT")="" "RTN","GPLMEDS",147,0) . S @MEDVMAP@("MEDDIRECTIONFREQUENCYVALUE")="" "RTN","GPLMEDS",148,0) . S MEDARYTMP=$NA(@MEDTARYTMP@(ZI)) "RTN","GPLMEDS",149,0) . K @MEDARYTMP "RTN","GPLMEDS",150,0) . D MAP^GPLXPATH(MEDXML,MEDVMAP,MEDARYTMP) "RTN","GPLMEDS",151,0) . I ZI=1&('HASOP) D ; FIRST ONE IS JUST A COPY MAKE SURE OP IS NOT THERE "RTN","GPLMEDS",152,0) . . ; W "FIRST ONE",! "RTN","GPLMEDS",153,0) . . D CP^GPLXPATH(MEDARYTMP,MEDOUTXML) "RTN","GPLMEDS",154,0) . E D ; AFTER THE FIRST OR IF THERE ARE OP, INSERT INNER XML "RTN","GPLMEDS",155,0) . . D INSINNER^GPLXPATH(MEDOUTXML,MEDARYTMP) "RTN","GPLMEDS",156,0) N MEDTMP,MEDI "RTN","GPLMEDS",157,0) D MISSING^GPLXPATH(MEDOUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS "RTN","GPLMEDS",158,0) I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","GPLMEDS",159,0) . W "MEDICATION MISSING ",! "RTN","GPLMEDS",160,0) . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! "RTN","GPLMEDS",161,0) Q "RTN","GPLMEDS",162,0) ; "RTN","GPLMEDS",163,0) DIGITS(INSTR) ; RETURN JUST THE LEADING DIGITS OF THE STRING "RTN","GPLMEDS",164,0) ; EXAMPLE: $$DIGITS("13R") RETURNS 13 "RTN","GPLMEDS",165,0) N ALPHA ; CONTANT TO HOLD ALL ALPHA CHARACTERS "RTN","GPLMEDS",166,0) S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ; ALPHAS "RTN","GPLMEDS",167,0) Q $TR(INSTR,ALPHA) ; LEAVE ONLY THE DIGITS "RTN","GPLMEDS",168,0) ; "RTN","GPLPROBS") 0^11^B25875394 "RTN","GPLPROBS",1,0) GPLPROBS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 "RTN","GPLPROBS",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLPROBS",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLPROBS",4,0) ;General Public License See attached copy of the License. "RTN","GPLPROBS",5,0) ; "RTN","GPLPROBS",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLPROBS",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLPROBS",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLPROBS",9,0) ;(at your option) any later version. "RTN","GPLPROBS",10,0) ; "RTN","GPLPROBS",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLPROBS",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLPROBS",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLPROBS",14,0) ;GNU General Public License for more details. "RTN","GPLPROBS",15,0) ; "RTN","GPLPROBS",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLPROBS",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLPROBS",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLPROBS",19,0) ; "RTN","GPLPROBS",20,0) ; "RTN","GPLPROBS",21,0) ; PROCESS THE PROBLEMS SECTION OF THE CCR "RTN","GPLPROBS",22,0) ; "RTN","GPLPROBS",23,0) EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE "RTN","GPLPROBS",24,0) ; "RTN","GPLPROBS",25,0) ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","GPLPROBS",26,0) ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE "RTN","GPLPROBS",27,0) ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE "RTN","GPLPROBS",28,0) ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS "RTN","GPLPROBS",29,0) ; INSERT^GPLXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT "RTN","GPLPROBS",30,0) ; "RTN","GPLPROBS",31,0) N RPCRSLT,J,K,PTMP,X,VMAP,TBU "RTN","GPLPROBS",32,0) S TVMAP=$NA(^TMP("GPLCCR",$J,"PROBVALS")) "RTN","GPLPROBS",33,0) S TARYTMP=$NA(^TMP("GPLCCR",$J,"PROBARYTMP")) "RTN","GPLPROBS",34,0) K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES "RTN","GPLPROBS",35,0) D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC "RTN","GPLPROBS",36,0) I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL "RTN","GPLPROBS",37,0) . W "NULL RESULT FROM LIST^ORQQPL3 ",! "RTN","GPLPROBS",38,0) . S @OUTXML@(0)=0 "RTN","GPLPROBS",39,0) . ; Q "RTN","GPLPROBS",40,0) ; I DEBUG ZWR RPCRSLT "RTN","GPLPROBS",41,0) S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS "RTN","GPLPROBS",42,0) F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST "RTN","GPLPROBS",43,0) . S VMAP=$NA(@TVMAP@(J)) "RTN","GPLPROBS",44,0) . K @VMAP "RTN","GPLPROBS",45,0) . I DEBUG W "VMAP= ",VMAP,! "RTN","GPLPROBS",46,0) . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY "RTN","GPLPROBS",47,0) . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM "RTN","GPLPROBS",48,0) . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) "RTN","GPLPROBS",49,0) . S @VMAP@("PROBLEMSTATUS")=$P(PTMP,U,2) "RTN","GPLPROBS",50,0) . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) "RTN","GPLPROBS",51,0) . S @VMAP@("PROBLEMCODINGVERSION")="" "RTN","GPLPROBS",52,0) . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) "RTN","GPLPROBS",53,0) . S @VMAP@("PROBLEMDATEOFONSET")=$P(PTMP,U,5) "RTN","GPLPROBS",54,0) . S @VMAP@("PROBLEMDATEMOD")=$P(PTMP,U,6) "RTN","GPLPROBS",55,0) . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) "RTN","GPLPROBS",56,0) . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) "RTN","GPLPROBS",57,0) . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) "RTN","GPLPROBS",58,0) . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) "RTN","GPLPROBS",59,0) . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) "RTN","GPLPROBS",60,0) . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) "RTN","GPLPROBS",61,0) . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER "RTN","GPLPROBS",62,0) . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) "RTN","GPLPROBS",63,0) . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) "RTN","GPLPROBS",64,0) . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) "RTN","GPLPROBS",65,0) . S @VMAP@("PROBLEMDTREC")=$P(PTMP,U,15) "RTN","GPLPROBS",66,0) . S @VMAP@("PROBLEMINACT")=$P(PTMP,U,16) "RTN","GPLPROBS",67,0) . S ARYTMP=$NA(@TARYTMP@(J)) "RTN","GPLPROBS",68,0) . ; W "ARYTMP= ",ARYTMP,! "RTN","GPLPROBS",69,0) . K @ARYTMP "RTN","GPLPROBS",70,0) . D MAP^GPLXPATH(IPXML,VMAP,ARYTMP) ; "RTN","GPLPROBS",71,0) . I J=1 D ; FIRST ONE IS JUST A COPY "RTN","GPLPROBS",72,0) . . ; W "FIRST ONE",! "RTN","GPLPROBS",73,0) . . D CP^GPLXPATH(ARYTMP,OUTXML) "RTN","GPLPROBS",74,0) . . ; W "OUTXML ",OUTXML,! "RTN","GPLPROBS",75,0) . I J>1 D ; AFTER THE FIRST, INSERT INNER XML "RTN","GPLPROBS",76,0) . . D INSINNER^GPLXPATH(OUTXML,ARYTMP) "RTN","GPLPROBS",77,0) ; ZWR ^TMP("GPLCCR",$J,"PROBVALS",*) "RTN","GPLPROBS",78,0) ; ZWR ^TMP("GPLCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS "RTN","GPLPROBS",79,0) ; ZWR @OUTXML "RTN","GPLPROBS",80,0) ; $$HTML^DILF( "RTN","GPLPROBS",81,0) ; GENERATE THE NARITIVE HTML FOR THE CCD "RTN","GPLPROBS",82,0) I CCD D ; IF THIS IS FOR A CCD "RTN","GPLPROBS",83,0) . N HTMP,HOUT,HTMLO,GPLPROBI,ZX "RTN","GPLPROBS",84,0) . F GPLPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM "RTN","GPLPROBS",85,0) . . S VMAP=$NA(@TVMAP@(GPLPROBI)) "RTN","GPLPROBS",86,0) . . I DEBUG W "VMAP =",VMAP,! "RTN","GPLPROBS",87,0) . . D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE "RTN","GPLPROBS",88,0) . . D UNMARK^GPLXPATH("HTMP") ; REMOVE MARKUP "RTN","GPLPROBS",89,0) . . ; D PARY^GPLXPATH("HTMP") ; PRINT IT "RTN","GPLPROBS",90,0) . . D MAP^GPLXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES "RTN","GPLPROBS",91,0) . . ; D PARY^GPLXPATH("HOUT") ; PRINT IT AGAIN "RTN","GPLPROBS",92,0) . . I GPLPROBI=1 D ; FIRST ONE IS JUST A COPY "RTN","GPLPROBS",93,0) . . . D CP^GPLXPATH("HOUT","HTMLO") "RTN","GPLPROBS",94,0) . . I GPLPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML "RTN","GPLPROBS",95,0) . . . I DEBUG W "DOING INNER",! "RTN","GPLPROBS",96,0) . . . N HTMLBLD,HTMLTMP "RTN","GPLPROBS",97,0) . . . D QUEUE^GPLXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) "RTN","GPLPROBS",98,0) . . . D QUEUE^GPLXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) "RTN","GPLPROBS",99,0) . . . D QUEUE^GPLXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) "RTN","GPLPROBS",100,0) . . . D BUILD^GPLXPATH("HTMLBLD","HTMLTMP") "RTN","GPLPROBS",101,0) . . . D CP^GPLXPATH("HTMLTMP","HTMLO") "RTN","GPLPROBS",102,0) . . . ; D INSINNER^GPLXPATH("HOUT","HTMLO","//") "RTN","GPLPROBS",103,0) . I DEBUG D PARY^GPLXPATH("HTMLO") "RTN","GPLPROBS",104,0) . D INSB4^GPLXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION "RTN","GPLPROBS",105,0) N PROBSTMP,I "RTN","GPLPROBS",106,0) D MISSING^GPLXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS "RTN","GPLPROBS",107,0) I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - "RTN","GPLPROBS",108,0) . ; STRINGS MARKED AS @@X@@ "RTN","GPLPROBS",109,0) . W !,"PROBLEMS Missing list: ",! "RTN","GPLPROBS",110,0) . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! "RTN","GPLPROBS",111,0) Q "RTN","GPLPROBS",112,0) ; "RTN","GPLRIMA") 0^13^B214212612 "RTN","GPLRIMA",1,0) GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 "RTN","GPLRIMA",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLRIMA",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLRIMA",4,0) ;General Public License See attached copy of the License. "RTN","GPLRIMA",5,0) ; "RTN","GPLRIMA",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLRIMA",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLRIMA",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLRIMA",9,0) ;(at your option) any later version. "RTN","GPLRIMA",10,0) ; "RTN","GPLRIMA",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLRIMA",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLRIMA",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLRIMA",14,0) ;GNU General Public License for more details. "RTN","GPLRIMA",15,0) ; "RTN","GPLRIMA",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLRIMA",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLRIMA",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLRIMA",19,0) ; "RTN","GPLRIMA",20,0) ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE "RTN","GPLRIMA",21,0) ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR "RTN","GPLRIMA",22,0) ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL "RTN","GPLRIMA",23,0) ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE "RTN","GPLRIMA",24,0) ; CONVEYED VIA THE CCR OR CCD. "RTN","GPLRIMA",25,0) ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE: "RTN","GPLRIMA",26,0) ; 1. THE PRESENSE OF CLINICAL DATA IN A SECTION "RTN","GPLRIMA",27,0) ; 2. ARE THE DATA ELEMENTS TIME-BOUND "RTN","GPLRIMA",28,0) ; 3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC "RTN","GPLRIMA",29,0) ; 4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS "RTN","GPLRIMA",30,0) ; 5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE "RTN","GPLRIMA",31,0) ; .. AND OTHER FACTORS YET TO BE DETERMINED "RTN","GPLRIMA",32,0) ; "RTN","GPLRIMA",33,0) ; SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY "RTN","GPLRIMA",34,0) ; REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR "RTN","GPLRIMA",35,0) ; CONVEYANCE TO THE RIM APPLICATION. "RTN","GPLRIMA",36,0) ; "RTN","GPLRIMA",37,0) ; "RTN","GPLRIMA",38,0) ANALYZE(BEGDFN,DFNCNT) ; RIM COHERANCE ANALYSIS ROUTINE "RTN","GPLRIMA",39,0) ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS "RTN","GPLRIMA",40,0) ; TO RESUME AT NEXT PATIENT, USE BEGDFN="" "RTN","GPLRIMA",41,0) ; USE RESET^GPLRIMA TO RESET TO TOP OF PATIENT LIST "RTN","GPLRIMA",42,0) ; "RTN","GPLRIMA",43,0) N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR "RTN","GPLRIMA",44,0) N CCRGLO "RTN","GPLRIMA",45,0) D ASETUP ; SET UP VARIABLES AND GLOBALS "RTN","GPLRIMA",46,0) D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE "RTN","GPLRIMA",47,0) I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME "RTN","GPLRIMA",48,0) S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN "RTN","GPLRIMA",49,0) S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT "RTN","GPLRIMA",50,0) I RIMDFN="" S RIMDFN=RESUME "RTN","GPLRIMA",51,0) I +RIMDFN=0 D Q ; AT THE END OF THE PATIENTS "RTN","GPLRIMA",52,0) . W "END OF PATIENT LIST, CALL RESET^GPLRIMA",! "RTN","GPLRIMA",53,0) F RIMI=1:1:DFNCNT D Q:+RIMDFN=0 ; FOR DFNCNT NUMBER OF PATIENTS OR END "RTN","GPLRIMA",54,0) . D CCRRPC^GPLCCR(.CCRGLO,RIMDFN,"CCR","","","") ;PROCESS THE CCR "RTN","GPLRIMA",55,0) . W RIMDFN,! "RTN","GPLRIMA",56,0) . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS "RTN","GPLRIMA",57,0) . ; "RTN","GPLRIMA",58,0) . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT "RTN","GPLRIMA",59,0) . ; "RTN","GPLRIMA",60,0) . I $D(^TMP("GPLCCR",$J,"PROBVALS",1)) D ; PROBLEM VARS EXISTS "RTN","GPLRIMA",61,0) . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("GPLCCR",$J,"PROBVALS") "RTN","GPLRIMA",62,0) . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=^TMP("GPLCCR",$J,"PROBVALS",0) "RTN","GPLRIMA",63,0) . I $D(^TMP("GPLCCR",$J,"VITALS",1)) D ; VITALS VARS EXISTS "RTN","GPLRIMA",64,0) . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("GPLCCR",$J,"VITALS") "RTN","GPLRIMA",65,0) . I $D(^TMP("GPLCCR",$J,"MEDMAP",1)) D ; MEDS VARS EXISTS "RTN","GPLRIMA",66,0) . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("GPLCCR",$J,"MEDMAP") "RTN","GPLRIMA",67,0) . K ^TMP("GPLCCR",$J) ; KILL WORK AREA FOR CCR BUILDING "RTN","GPLRIMA",68,0) . ; "RTN","GPLRIMA",69,0) . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP "RTN","GPLRIMA",70,0) . ; "RTN","GPLRIMA",71,0) . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS "RTN","GPLRIMA",72,0) . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT "RTN","GPLRIMA",73,0) . ; "RTN","GPLRIMA",74,0) . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL "RTN","GPLRIMA",75,0) . ; "RTN","GPLRIMA",76,0) . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS "RTN","GPLRIMA",77,0) . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED "RTN","GPLRIMA",78,0) . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT "RTN","GPLRIMA",79,0) . ; "RTN","GPLRIMA",80,0) . N CATNAME,CATTBL "RTN","GPLRIMA",81,0) . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) "RTN","GPLRIMA",82,0) . S CATNAME="" "RTN","GPLRIMA",83,0) . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY "RTN","GPLRIMA",84,0) . W "CATEGORY NAME: ",CATNAME,! "RTN","GPLRIMA",85,0) . ; "RTN","GPLRIMA",86,0) . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^CCRSYS(RIMDFN) ; NEXT PATIENT "RTN","GPLRIMA",87,0) . ; PTST TESTS TO SEE IF PATIENT WAS MERGED "RTN","GPLRIMA",88,0) . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT "RTN","GPLRIMA",89,0) . ; AND WE SKIP IT "RTN","GPLRIMA",90,0) . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN "RTN","GPLRIMA",91,0) ; D PARY^GPLXPATH(@RIMBASE@("ATTRTBL")) "RTN","GPLRIMA",92,0) Q "RTN","GPLRIMA",93,0) ; "RTN","GPLRIMA",94,0) SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS "RTN","GPLRIMA",95,0) N SBASE,SATTR "RTN","GPLRIMA",96,0) S SBASE=$NA(@RIMBASE@("VARS",SDFN)) "RTN","GPLRIMA",97,0) D APOST("SATTR","RIMTBL","HEADER") "RTN","GPLRIMA",98,0) I $D(@SBASE@("PROBLEMS",1)) D ; "RTN","GPLRIMA",99,0) . D APOST("SATTR","RIMTBL","PROBLEMS") "RTN","GPLRIMA",100,0) . ; W "POSTING PROBLEMS",! "RTN","GPLRIMA",101,0) I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") "RTN","GPLRIMA",102,0) I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES "RTN","GPLRIMA",103,0) . D APOST("SATTR","RIMTBL","MEDS") "RTN","GPLRIMA",104,0) . N ZR,ZI "RTN","GPLRIMA",105,0) . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES "RTN","GPLRIMA",106,0) . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN "RTN","GPLRIMA",107,0) . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS "RTN","GPLRIMA",108,0) . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES "RTN","GPLRIMA",109,0) . ; D PATD^GPLRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES "RTN","GPLRIMA",110,0) D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED "RTN","GPLRIMA",111,0) W "ATTRIBUTES: ",SATTR,! "RTN","GPLRIMA",112,0) Q SATTR "RTN","GPLRIMA",113,0) ; "RTN","GPLRIMA",114,0) RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES "RTN","GPLRIMA",115,0) K ^TMP("GPLRIM","RESUME") "RTN","GPLRIMA",116,0) K ^TMP("GPLRIM") "RTN","GPLRIMA",117,0) Q "RTN","GPLRIMA",118,0) ; "RTN","GPLRIMA",119,0) CLIST ; LIST THE CATEGORIES "RTN","GPLRIMA",120,0) ; "RTN","GPLRIMA",121,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","GPLRIMA",122,0) N CLBASE,CLNUM,ZI,CLIDX "RTN","GPLRIMA",123,0) S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) "RTN","GPLRIMA",124,0) S CLNUM=@CLBASE@(0) "RTN","GPLRIMA",125,0) F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES "RTN","GPLRIMA",126,0) . S CLIDX=@CLBASE@(ZI) "RTN","GPLRIMA",127,0) . W "(",$P(@CLBASE@(CLIDX),"^",1) "RTN","GPLRIMA",128,0) . W ":",$P(@CLBASE@(CLIDX),"^",2),") " "RTN","GPLRIMA",129,0) . W CLIDX,! "RTN","GPLRIMA",130,0) ; D PARY^GPLXPATH(CLBASE) "RTN","GPLRIMA",131,0) Q "RTN","GPLRIMA",132,0) ; "RTN","GPLRIMA",133,0) CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES "RTN","GPLRIMA",134,0) ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT "RTN","GPLRIMA",135,0) ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE "RTN","GPLRIMA",136,0) ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME "RTN","GPLRIMA",137,0) ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, "RTN","GPLRIMA",138,0) ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" "RTN","GPLRIMA",139,0) ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES "RTN","GPLRIMA",140,0) ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY "RTN","GPLRIMA",141,0) ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING "RTN","GPLRIMA",142,0) ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY "RTN","GPLRIMA",143,0) ; NUMBER IE CTBL_X(CDFN)="" "RTN","GPLRIMA",144,0) ; "RTN","GPLRIMA",145,0) ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST "RTN","GPLRIMA",146,0) S CCTBL=$NA(@CBASE@(CTBL,"CATS")) "RTN","GPLRIMA",147,0) W "CBASE: ",CCTBL,! "RTN","GPLRIMA",148,0) ; "RTN","GPLRIMA",149,0) I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY "RTN","GPLRIMA",150,0) . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY "RTN","GPLRIMA",151,0) . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY "RTN","GPLRIMA",152,0) . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT "RTN","GPLRIMA",153,0) . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY "RTN","GPLRIMA",154,0) . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME "RTN","GPLRIMA",155,0) . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 "RTN","GPLRIMA",156,0) ; "RTN","GPLRIMA",157,0) S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY "RTN","GPLRIMA",158,0) S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT "RTN","GPLRIMA",159,0) S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK "RTN","GPLRIMA",160,0) ; "RTN","GPLRIMA",161,0) S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED "RTN","GPLRIMA",162,0) ; "RTN","GPLRIMA",163,0) S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT "RTN","GPLRIMA",164,0) W "PATS BASE: ",CPATLIST,! "RTN","GPLRIMA",165,0) S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST "RTN","GPLRIMA",166,0) ; "RTN","GPLRIMA",167,0) Q "RTN","GPLRIMA",168,0) ; "RTN","GPLRIMA",169,0) CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE "RTN","GPLRIMA",170,0) ; "RTN","GPLRIMA",171,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","GPLRIMA",172,0) N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT "RTN","GPLRIMA",173,0) S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES "RTN","GPLRIMA",174,0) S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS "RTN","GPLRIMA",175,0) S ZTOT=0 ; INITIALIZE OVERALL TOTAL "RTN","GPLRIMA",176,0) F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS "RTN","GPLRIMA",177,0) . S ZCNT=0 "RTN","GPLRIMA",178,0) . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY "RTN","GPLRIMA",179,0) . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME "RTN","GPLRIMA",180,0) . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST "RTN","GPLRIMA",181,0) . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS "RTN","GPLRIMA",182,0) . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT "RTN","GPLRIMA",183,0) . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! "RTN","GPLRIMA",184,0) . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) "RTN","GPLRIMA",185,0) . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) "RTN","GPLRIMA",186,0) . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD "RTN","GPLRIMA",187,0) . S ZTOT=ZTOT+ZCNT "RTN","GPLRIMA",188,0) W "TOTAL: ",ZTOT,! "RTN","GPLRIMA",189,0) Q "RTN","GPLRIMA",190,0) ; "RTN","GPLRIMA",191,0) CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST "RTN","GPLRIMA",192,0) ; INLST IS PASSED BY NAME "RTN","GPLRIMA",193,0) N ZI,ZDX,ZCOUNT "RTN","GPLRIMA",194,0) W INLST,! "RTN","GPLRIMA",195,0) S ZCOUNT=0 "RTN","GPLRIMA",196,0) S ZDX="" "RTN","GPLRIMA",197,0) F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END "RTN","GPLRIMA",198,0) . S ZCOUNT=ZCOUNT+1 "RTN","GPLRIMA",199,0) . S ZDX=$O(@INLST@(ZDX)) "RTN","GPLRIMA",200,0) . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! "RTN","GPLRIMA",201,0) Q ZCOUNT "RTN","GPLRIMA",202,0) ; "RTN","GPLRIMA",203,0) XCPAT(CPATCAT) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT "RTN","GPLRIMA",204,0) ; "RTN","GPLRIMA",205,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","GPLRIMA",206,0) N ZI,ZJ,ZC,ZPATBASE "RTN","GPLRIMA",207,0) S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) "RTN","GPLRIMA",208,0) S ZI="" "RTN","GPLRIMA",209,0) F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END "RTN","GPLRIMA",210,0) . S ZI=$O(@ZPATBASE@(ZI)) "RTN","GPLRIMA",211,0) . D XPAT^GPLCCR(ZI,"","") ; EXPORT THE PATIENT TO A FILE "RTN","GPLRIMA",212,0) Q "RTN","GPLRIMA",213,0) ; "RTN","GPLRIMA",214,0) CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT "RTN","GPLRIMA",215,0) ; "RTN","GPLRIMA",216,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","GPLRIMA",217,0) N ZI,ZJ,ZC,ZPATBASE "RTN","GPLRIMA",218,0) S ZC=0 ; COUNT FOR SPACING THE PRINTOUT "RTN","GPLRIMA",219,0) S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) "RTN","GPLRIMA",220,0) S ZI="" "RTN","GPLRIMA",221,0) F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END "RTN","GPLRIMA",222,0) . S ZI=$O(@ZPATBASE@(ZI)) "RTN","GPLRIMA",223,0) . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT "RTN","GPLRIMA",224,0) . W ZI," " "RTN","GPLRIMA",225,0) . I ZC=10 D ; NEW LINE "RTN","GPLRIMA",226,0) . . S ZC=0 "RTN","GPLRIMA",227,0) . . W ! "RTN","GPLRIMA",228,0) Q "RTN","GPLRIMA",229,0) ; "RTN","GPLRIMA",230,0) PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT "RTN","GPLRIMA",231,0) ; "RTN","GPLRIMA",232,0) N ATTR S ATTR="" "RTN","GPLRIMA",233,0) I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT "RTN","GPLRIMA",234,0) . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT "RTN","GPLRIMA",235,0) S ATTR=^TMP("GPLRIM","ATTR",DFN) "RTN","GPLRIMA",236,0) I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND "RTN","GPLRIMA",237,0) I $D(^TMP("GPLRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT "RTN","GPLRIMA",238,0) . N CAT "RTN","GPLRIMA",239,0) . S CAT=$P(^TMP("GPLRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT "RTN","GPLRIMA",240,0) . W CAT,": ",ATTR,! "RTN","GPLRIMA",241,0) Q "RTN","GPLRIMA",242,0) ; "RTN","GPLRIMA",243,0) APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) "RTN","GPLRIMA",244,0) ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT "RTN","GPLRIMA",245,0) ; AND AMAP(N)=AVAL IS THE NTH AVAL "RTN","GPLRIMA",246,0) ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE "RTN","GPLRIMA",247,0) ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE "RTN","GPLRIMA",248,0) ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED "RTN","GPLRIMA",249,0) ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED "RTN","GPLRIMA",250,0) ; "RTN","GPLRIMA",251,0) I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST "RTN","GPLRIMA",252,0) . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS "RTN","GPLRIMA",253,0) S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT "RTN","GPLRIMA",254,0) S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY "RTN","GPLRIMA",255,0) S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF "RTN","GPLRIMA",256,0) Q "RTN","GPLRIMA",257,0) ; "RTN","GPLRIMA",258,0) ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL "RTN","GPLRIMA",259,0) I '$D(RIMBASE) S RIMBASE=$NA(^TMP("GPLRIM")) "RTN","GPLRIMA",260,0) I '$D(@RIMBASE) S @RIMBASE="" "RTN","GPLRIMA",261,0) I '$D(RIMTBL) S RIMTBL=$NA(^TMP("GPLRIM","RIMTBL","TABLE")) ; ATTR TABLE "RTN","GPLRIMA",262,0) S ^TMP("GPLRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES "RTN","GPLRIMA",263,0) Q "RTN","GPLRIMA",264,0) ; "RTN","GPLRIMA",265,0) AINIT ; INITIALIZE ATTRIBUTE TABLE "RTN","GPLRIMA",266,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","GPLRIMA",267,0) K @RIMTBL "RTN","GPLRIMA",268,0) D APUSH(RIMTBL,"EXTRACTED") "RTN","GPLRIMA",269,0) D APUSH(RIMTBL,"NOTEXTRACTED") "RTN","GPLRIMA",270,0) D APUSH(RIMTBL,"HEADER") "RTN","GPLRIMA",271,0) D APUSH(RIMTBL,"NOPCP") "RTN","GPLRIMA",272,0) D APUSH(RIMTBL,"PCP") "RTN","GPLRIMA",273,0) D APUSH(RIMTBL,"PROBLEMS") "RTN","GPLRIMA",274,0) D APUSH(RIMTBL,"PROBCODE") "RTN","GPLRIMA",275,0) D APUSH(RIMTBL,"PROBNOCODE") "RTN","GPLRIMA",276,0) D APUSH(RIMTBL,"PROBDATE") "RTN","GPLRIMA",277,0) D APUSH(RIMTBL,"PROBNODATE") "RTN","GPLRIMA",278,0) D APUSH(RIMTBL,"VITALS") "RTN","GPLRIMA",279,0) D APUSH(RIMTBL,"VITALSCODE") "RTN","GPLRIMA",280,0) D APUSH(RIMTBL,"VITALSNOCODE") "RTN","GPLRIMA",281,0) D APUSH(RIMTBL,"VITALSDATE") "RTN","GPLRIMA",282,0) D APUSH(RIMTBL,"VITALSNODATE") "RTN","GPLRIMA",283,0) D APUSH(RIMTBL,"MEDS") "RTN","GPLRIMA",284,0) D APUSH(RIMTBL,"MEDSCODE") "RTN","GPLRIMA",285,0) D APUSH(RIMTBL,"MEDSNOCODE") "RTN","GPLRIMA",286,0) D APUSH(RIMTBL,"MEDSDATE") "RTN","GPLRIMA",287,0) D APUSH(RIMTBL,"MEDSNODATE") "RTN","GPLRIMA",288,0) Q "RTN","GPLRIMA",289,0) ; "RTN","GPLRIMA",290,0) APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL "RTN","GPLRIMA",291,0) ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING "RTN","GPLRIMA",292,0) ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES "RTN","GPLRIMA",293,0) ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) "RTN","GPLRIMA",294,0) I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING "RTN","GPLRIMA",295,0) N USETBL "RTN","GPLRIMA",296,0) I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE "RTN","GPLRIMA",297,0) . W "ERROR NO SUCH TABLE",! "RTN","GPLRIMA",298,0) S USETBL=@RIMBASE@("TABLES",PTBL) "RTN","GPLRIMA",299,0) S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL "RTN","GPLRIMA",300,0) Q "RTN","GPLRIMA",301,0) GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN "RTN","GPLRIMA",302,0) ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") "RTN","GPLRIMA",303,0) ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 "RTN","GPLRIMA",304,0) ; IN SECTION "MEDS" "RTN","GPLRIMA",305,0) ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS "RTN","GPLRIMA",306,0) ; PENDING FOR MED 2 FOR PATIENT 2 "RTN","GPLRIMA",307,0) ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE "RTN","GPLRIMA",308,0) ; RETURNED. RTN IS PASSED BY REFERENCE "RTN","GPLRIMA",309,0) ; "RTN","GPLRIMA",310,0) S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE "RTN","GPLRIMA",311,0) I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES "RTN","GPLRIMA",312,0) S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES "RTN","GPLRIMA",313,0) I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION "RTN","GPLRIMA",314,0) . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! "RTN","GPLRIMA",315,0) N ZZI,ZZS "RTN","GPLRIMA",316,0) S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT "RTN","GPLRIMA",317,0) ; ZWR @ZZS@(1) "RTN","GPLRIMA",318,0) S RTN(0)=@ZZS@(0) "RTN","GPLRIMA",319,0) F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) "RTN","GPLRIMA",320,0) . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE "RTN","GPLRIMA",321,0) . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE "RTN","GPLRIMA",322,0) Q "RTN","GPLRIMA",323,0) ; "RTN","GPLRIMA",324,0) PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR "RTN","GPLRIMA",325,0) ; "RTN","GPLRIMA",326,0) N ZR "RTN","GPLRIMA",327,0) D GETPA(.ZR,DFN,ISEC,IVAR) "RTN","GPLRIMA",328,0) I $D(ZR(0)) D PARY^GPLXPATH("ZR") "RTN","GPLRIMA",329,0) E W "NOTHING RETURNED",! "RTN","GPLRIMA",330,0) Q "RTN","GPLRIMA",331,0) ; "RTN","GPLRIMA",332,0) CAGET(RTN,IATTR) ; "RTN","GPLRIMA",333,0) ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR "RTN","GPLRIMA",334,0) ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE "RTN","GPLRIMA",335,0) ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC "RTN","GPLRIMA",336,0) Q "RTN","GPLRIMA",337,0) ; "RTN","GPLRIMA",338,0) PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR "RTN","GPLRIMA",339,0) ; "RTN","GPLRIMA",340,0) I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES "RTN","GPLRIMA",341,0) N ZLST "RTN","GPLRIMA",342,0) S LSTRTN(0)=0 ; DEFAULT RETURN NONE "RTN","GPLRIMA",343,0) S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES "RTN","GPLRIMA",344,0) S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS "RTN","GPLRIMA",345,0) N ZNC ; ZNC IS NUMBER OF CATEGORIES "RTN","GPLRIMA",346,0) S ZNC=@ZCBASE@(0) "RTN","GPLRIMA",347,0) I ZNC=0 Q ; NO CATEGORIES TO SEARCH "RTN","GPLRIMA",348,0) N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE "RTN","GPLRIMA",349,0) S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) "RTN","GPLRIMA",350,0) N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT "RTN","GPLRIMA",351,0) F ZI=1:1:ZNC D ; FOR ALL CATEGORIES "RTN","GPLRIMA",352,0) . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT "RTN","GPLRIMA",353,0) . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR "RTN","GPLRIMA",354,0) . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL "RTN","GPLRIMA",355,0) . . M LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT "RTN","GPLRIMA",356,0) S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS "RTN","GPLRIMA",357,0) S ZPAT=0 ; START AT FIRST PATIENT IN LIST "RTN","GPLRIMA",358,0) F S ZPAT=$O(LSTRTN(ZPAT)) Q:ZPAT="" D ; "RTN","GPLRIMA",359,0) . S ZCNT=ZCNT+1 "RTN","GPLRIMA",360,0) S LSTRTN(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY "RTN","GPLRIMA",361,0) Q "RTN","GPLRIMA",362,0) ; "RTN","GPLRIMA",363,0) DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR "RTN","GPLRIMA",364,0) ; "RTN","GPLRIMA",365,0) N ZR "RTN","GPLRIMA",366,0) D PCLST(.ZR,CATTR) "RTN","GPLRIMA",367,0) I ZR(0)=0 D Q ; "RTN","GPLRIMA",368,0) . W "NO PATIENTS RETURNED",! "RTN","GPLRIMA",369,0) E D ; "RTN","GPLRIMA",370,0) . D PARY^GPLXPATH("ZR") ; PRINT ARRAY "RTN","GPLRIMA",371,0) . W "COUNT=",ZR(0),! "RTN","GPLRIMA",372,0) Q "RTN","GPLRIMA",373,0) ; "RTN","GPLRIMA",374,0) RPCGV(RTN,DFN,WHICH) ; RPC GET VARS "RTN","GPLRIMA",375,0) ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES "RTN","GPLRIMA",376,0) ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT "RTN","GPLRIMA",377,0) ; DFN IS THE PATIENT NUMBER. "RTN","GPLRIMA",378,0) ; WHICH IS "ALL" OR "MEDS" OR "VITALS" OR "PROBLEMS" OR "ALERTS" OR "LABS" "RTN","GPLRIMA",379,0) ; OR OTHER SECTIONS AS THEY ARE ADDED "RTN","GPLRIMA",380,0) ; THIS IS MEANT TO BE AVAILABLE AS AN RPC "RTN","GPLRIMA",381,0) I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS "RTN","GPLRIMA",382,0) S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES "RTN","GPLRIMA",383,0) S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED "RTN","GPLRIMA",384,0) N ZZGI "RTN","GPLRIMA",385,0) I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS "RTN","GPLRIMA",386,0) . F ZZGI="PROBLEMS","VITALS","MEDS" D ; FOR EACH SECTION "RTN","GPLRIMA",387,0) . . D ZGVWRK(ZZGI) ; DO EACH SECTION "RTN","GPLRIMA",388,0) E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR "RTN","GPLRIMA",389,0) Q "RTN","GPLRIMA",390,0) ; "RTN","GPLRIMA",391,0) ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV "RTN","GPLRIMA",392,0) ; "RTN","GPLRIMA",393,0) N ZZGN ; NAME FOR SECTION VARIABLES "RTN","GPLRIMA",394,0) S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION "RTN","GPLRIMA",395,0) I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION "RTN","GPLRIMA",396,0) E D ; VARS EXIST "RTN","GPLRIMA",397,0) . N ZGVI "RTN","GPLRIMA",398,0) . F ZGVI=1:1:@ZZGN@(0) D ; FOR EACH MULTIPLE IN SECTION "RTN","GPLRIMA",399,0) . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS "RTN","GPLRIMA",400,0) . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE "RTN","GPLRIMA",401,0) . . S ZZGN2=$NA(@ZZGN@(ZGVI)) "RTN","GPLRIMA",402,0) . . ; W ZZGN2,!,$O(@ZZGN2@("")),! "RTN","GPLRIMA",403,0) . . D H2ARY^GPLXPATH("ZZGA",ZZGN2) ; CONVERT HASH TO ARRAY "RTN","GPLRIMA",404,0) . . ; D PARY^GPLXPATH("ZZGA") "RTN","GPLRIMA",405,0) . . D PUSHA^GPLXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN "RTN","GPLRIMA",406,0) Q "RTN","GPLRIMA",407,0) ; "RTN","GPLRIMA",408,0) DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN GPLRIM "RTN","GPLRIMA",409,0) ; ALONG WITH SAMPLE VALUES. "RTN","GPLRIMA",410,0) ; IWHICH IS "ALL" OR "MEDS" OR "VITALS" OR "PROBLEMS" OR "ALERTS" OR "LABS" "RTN","GPLRIMA",411,0) N GTMP "RTN","GPLRIMA",412,0) I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT "RTN","GPLRIMA",413,0) . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES "RTN","GPLRIMA",414,0) I '$D(IWHICH) S IWHICH="ALL" "RTN","GPLRIMA",415,0) D RPCGV(.GTMP,DFN,IWHICH) "RTN","GPLRIMA",416,0) D PARY^GPLXPATH("GTMP") "RTN","GPLRIMA",417,0) Q "RTN","GPLRIMA",418,0) ; "RTN","GPLUNIT") 0^10^B31438520 "RTN","GPLUNIT",1,0) GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 "RTN","GPLUNIT",2,0) ;;0.1;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLUNIT",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLUNIT",4,0) ;General Public License See attached copy of the License. "RTN","GPLUNIT",5,0) ; "RTN","GPLUNIT",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLUNIT",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLUNIT",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLUNIT",9,0) ;(at your option) any later version. "RTN","GPLUNIT",10,0) ; "RTN","GPLUNIT",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLUNIT",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLUNIT",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLUNIT",14,0) ;GNU General Public License for more details. "RTN","GPLUNIT",15,0) ; "RTN","GPLUNIT",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLUNIT",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLUNIT",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLUNIT",19,0) ; "RTN","GPLUNIT",20,0) W "This is a unit testing library",! "RTN","GPLUNIT",21,0) W ! "RTN","GPLUNIT",22,0) Q "RTN","GPLUNIT",23,0) ; "RTN","GPLUNIT",24,0) ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array "RTN","GPLUNIT",25,0) ; ZARY IS PASSED BY REFERENCE "RTN","GPLUNIT",26,0) ; BAT is a string identifying the test battery "RTN","GPLUNIT",27,0) ; TST is a test which will evaluate to true or false "RTN","GPLUNIT",28,0) ; I '$G(ZARY) D "RTN","GPLUNIT",29,0) ; . S ZARY(0)=0 ; initially there are no elements "RTN","GPLUNIT",30,0) ; W "GOT HERE LOADING "_TST,! "RTN","GPLUNIT",31,0) N CNT ; count of array elements "RTN","GPLUNIT",32,0) S CNT=ZARY(0) ; contains array count "RTN","GPLUNIT",33,0) S CNT=CNT+1 ; increment count "RTN","GPLUNIT",34,0) S ZARY(CNT)=TST ; put the test in the array "RTN","GPLUNIT",35,0) I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY "RTN","GPLUNIT",36,0) . N II,TN ; TEMP FOR ENDING TEST IN BATTERY "RTN","GPLUNIT",37,0) . S II=$P(ZARY(BAT),"^",2) "RTN","GPLUNIT",38,0) . S $P(ZARY(BAT),"^",2)=II+1 "RTN","GPLUNIT",39,0) I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY "RTN","GPLUNIT",40,0) . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY "RTN","GPLUNIT",41,0) . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX "RTN","GPLUNIT",42,0) . ; S TN=$NA(ZARY("TESTS")) "RTN","GPLUNIT",43,0) . ; D PUSH^GPLXPATH(TN,BAT) "RTN","GPLUNIT",44,0) S ZARY(0)=CNT ; update the array counter "RTN","GPLUNIT",45,0) Q "RTN","GPLUNIT",46,0) ; "RTN","GPLUNIT",47,0) ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference "RTN","GPLUNIT",48,0) ; ZARY IS PASSED BY NAME "RTN","GPLUNIT",49,0) ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") "RTN","GPLUNIT",50,0) ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE "RTN","GPLUNIT",51,0) K @ZARY "RTN","GPLUNIT",52,0) S @ZARY@(0)=0 ; initialize array count "RTN","GPLUNIT",53,0) N LINE,LABEL,BODY "RTN","GPLUNIT",54,0) N INTEST S INTEST=0 ; switch for in the test case section "RTN","GPLUNIT",55,0) N SECTION S SECTION="[anonymous]" ; test case section "RTN","GPLUNIT",56,0) ; "RTN","GPLUNIT",57,0) N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D "RTN","GPLUNIT",58,0) . I LINE?." "1";;>".E S INTEST=1 ; entering test section "RTN","GPLUNIT",59,0) . I LINE?." "1";;>".E S INTEST=0 ; leaving TEMPLATE section "RTN","GPLUNIT",62,0) . I INTEST D ; within the testing section "RTN","GPLUNIT",63,0) . . I LINE?." "1";;><".E D ; section name found "RTN","GPLUNIT",64,0) . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name "RTN","GPLUNIT",65,0) . . I LINE?." "1";;>>".E D ; test case found "RTN","GPLUNIT",66,0) . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array "RTN","GPLUNIT",67,0) S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL "RTN","GPLUNIT",68,0) Q "RTN","GPLUNIT",69,0) ; "RTN","GPLUNIT",70,0) ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST "RTN","GPLUNIT",71,0) N ZI,ZX,ZR,ZP "RTN","GPLUNIT",72,0) S DEBUG=0 "RTN","GPLUNIT",73,0) ; I WHICH="ALL" D Q ; RUN ALL THE TESTS "RTN","GPLUNIT",74,0) ; . W "DOING ALL",! "RTN","GPLUNIT",75,0) ; . N J,NT "RTN","GPLUNIT",76,0) ; . S NT=$NA(ZARY("TESTS")) "RTN","GPLUNIT",77,0) ; . W NT,@NT@(0),! "RTN","GPLUNIT",78,0) ; . F J=1:1:@NT@(0) D ; "RTN","GPLUNIT",79,0) ; . . W @NT@(J),! "RTN","GPLUNIT",80,0) ; . . D ZTEST^GPLUNIT(@ZARY,@NT@(J)) "RTN","GPLUNIT",81,0) I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST "RTN","GPLUNIT",82,0) . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! "RTN","GPLUNIT",83,0) N FIRST,LAST "RTN","GPLUNIT",84,0) S FIRST=$P(ZARY(WHICH),"^",1) "RTN","GPLUNIT",85,0) S LAST=$P(ZARY(WHICH),"^",2) "RTN","GPLUNIT",86,0) F ZI=FIRST:1:LAST D "RTN","GPLUNIT",87,0) . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT "RTN","GPLUNIT",88,0) . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) "RTN","GPLUNIT",89,0) . . ; W ZP,! "RTN","GPLUNIT",90,0) . . S ZX=ZP "RTN","GPLUNIT",91,0) . . W "RUNNING: "_ZP "RTN","GPLUNIT",92,0) . . X ZX "RTN","GPLUNIT",93,0) . . W "..SUCCESS: ",WHICH,! "RTN","GPLUNIT",94,0) . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST "RTN","GPLUNIT",95,0) . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) "RTN","GPLUNIT",96,0) . . S ZX="S ZR="_ZP "RTN","GPLUNIT",97,0) . . W "TRYING: "_ZP "RTN","GPLUNIT",98,0) . . X ZX "RTN","GPLUNIT",99,0) . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! "RTN","GPLUNIT",100,0) . . I '$D(TPASSED) D ; NOT INITIALIZED YET "RTN","GPLUNIT",101,0) . . . S TPASSED=0 S TFAILED=0 "RTN","GPLUNIT",102,0) . . I ZR S TPASSED=TPASSED+1 "RTN","GPLUNIT",103,0) . . I 'ZR S TFAILED=TFAILED+1 "RTN","GPLUNIT",104,0) Q "RTN","GPLUNIT",105,0) ; "RTN","GPLUNIT",106,0) TEST ; RUN ALL THE TEST CASES "RTN","GPLUNIT",107,0) N ZTMP "RTN","GPLUNIT",108,0) D ZLOAD(.ZTMP) "RTN","GPLUNIT",109,0) D ZTEST(.ZTMP,"ALL") "RTN","GPLUNIT",110,0) W "PASSED: ",TPASSED,! "RTN","GPLUNIT",111,0) W "FAILED: ",TFAILED,! "RTN","GPLUNIT",112,0) W ! "RTN","GPLUNIT",113,0) W "THE TESTS!",! "RTN","GPLUNIT",114,0) ; I DEBUG ZWR ZTMP "RTN","GPLUNIT",115,0) Q "RTN","GPLUNIT",116,0) ; "RTN","GPLUNIT",117,0) GTSTS(GTZARY,RTN) ; return an array of test names "RTN","GPLUNIT",118,0) N I,J S I="" S I=$O(GTZARY("TESTS",I)) "RTN","GPLUNIT",119,0) F J=0:0 Q:I="" D "RTN","GPLUNIT",120,0) . D PUSH^GPLXPATH(RTN,I) "RTN","GPLUNIT",121,0) . S I=$O(GTZARY("TESTS",I)) "RTN","GPLUNIT",122,0) Q "RTN","GPLUNIT",123,0) ; "RTN","GPLUNIT",124,0) TESTALL(RNM) ; RUN ALL THE TESTS "RTN","GPLUNIT",125,0) N ZI,J,TZTMP,TSTS,TOTP,TOTF "RTN","GPLUNIT",126,0) S TOTP=0 S TOTF=0 "RTN","GPLUNIT",127,0) D ZLOAD^GPLUNIT("TZTMP",RNM) "RTN","GPLUNIT",128,0) D GTSTS(.TZTMP,"TSTS") "RTN","GPLUNIT",129,0) F ZI=1:1:TSTS(0) D ; "RTN","GPLUNIT",130,0) . S TPASSED=0 S TFAILED=0 "RTN","GPLUNIT",131,0) . D ZTEST^GPLUNIT(.TZTMP,TSTS(ZI)) "RTN","GPLUNIT",132,0) . S TOTP=TOTP+TPASSED "RTN","GPLUNIT",133,0) . S TOTF=TOTF+TFAILED "RTN","GPLUNIT",134,0) . S $P(TSTS(ZI),"^",2)=TPASSED "RTN","GPLUNIT",135,0) . S $P(TSTS(ZI),"^",3)=TFAILED "RTN","GPLUNIT",136,0) F I=1:1:TSTS(0) D ; "RTN","GPLUNIT",137,0) . W "TEST=> ",$P(TSTS(ZI),"^",1) "RTN","GPLUNIT",138,0) . W " PASSED=>",$P(TSTS(ZI),"^",2) "RTN","GPLUNIT",139,0) . W " FAILED=>",$P(TSTS(ZI),"^",3),! "RTN","GPLUNIT",140,0) W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! "RTN","GPLUNIT",141,0) Q "RTN","GPLUNIT",142,0) ; "RTN","GPLUNIT",143,0) TLIST(ZARY) ; LIST ALL THE TESTS "RTN","GPLUNIT",144,0) ; THEY ARE MARKED AS ;;> IN THE TEST CASES "RTN","GPLUNIT",145,0) ; ZARY IS PASSED BY REFERENCE "RTN","GPLUNIT",146,0) N I,J,K S I="" S I=$O(ZARY("TESTS",I)) "RTN","GPLUNIT",147,0) S K=1 "RTN","GPLUNIT",148,0) F J=0:0 Q:I="" D "RTN","GPLUNIT",149,0) . ; W "I IS NOW=",I,! "RTN","GPLUNIT",150,0) . W I," " "RTN","GPLUNIT",151,0) . S I=$O(ZARY("TESTS",I)) "RTN","GPLUNIT",152,0) . S K=K+1 I K=6 D "RTN","GPLUNIT",153,0) . . W ! "RTN","GPLUNIT",154,0) . . S K=1 "RTN","GPLUNIT",155,0) Q "RTN","GPLUNIT",156,0) ; "RTN","GPLVITAL") 0^12^B82628966 "RTN","GPLVITAL",1,0) GPLVITAL ; CCDCCR/CJE - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 "RTN","GPLVITAL",2,0) ;;0.1;CCDCCR;;JUL 16,2008;Build 8 "RTN","GPLVITAL",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLVITAL",4,0) ;General Public License See attached copy of the License. "RTN","GPLVITAL",5,0) ; "RTN","GPLVITAL",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLVITAL",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLVITAL",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLVITAL",9,0) ;(at your option) any later version. "RTN","GPLVITAL",10,0) ; "RTN","GPLVITAL",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLVITAL",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLVITAL",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLVITAL",14,0) ;GNU General Public License for more details. "RTN","GPLVITAL",15,0) ; "RTN","GPLVITAL",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLVITAL",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLVITAL",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLVITAL",19,0) ; "RTN","GPLVITAL",20,0) W "NO ENTRY FROM TOP",! "RTN","GPLVITAL",21,0) Q "RTN","GPLVITAL",22,0) ; "RTN","GPLVITAL",23,0) EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE "RTN","GPLVITAL",24,0) ; "RTN","GPLVITAL",25,0) ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED "RTN","GPLVITAL",26,0) ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE "RTN","GPLVITAL",27,0) ; "RTN","GPLVITAL",28,0) N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR "RTN","GPLVITAL",29,0) D VITALS^ORQQVI(.VITRSLT,DFN,"","") "RTN","GPLVITAL",30,0) I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT "RTN","GPLVITAL",31,0) I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC "RTN","GPLVITAL",32,0) . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! "RTN","GPLVITAL",33,0) . S @VITOUTXML@(0)=0 "RTN","GPLVITAL",34,0) I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT "RTN","GPLVITAL",35,0) ; ZWR RPCRSLT "RTN","GPLVITAL",36,0) S VITTVMAP=$NA(^TMP("GPLCCR",$J,"VITALS")) "RTN","GPLVITAL",37,0) S VITTARYTMP=$NA(^TMP("GPLCCR",$J,"VITALARYTMP")) "RTN","GPLVITAL",38,0) K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES "RTN","GPLVITAL",39,0) N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX "RTN","GPLVITAL",40,0) D VITDATES(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY "RTN","GPLVITAL",41,0) ; I DEBUG ZWR VDATES ;DEBUG "RTN","GPLVITAL",42,0) S VCNT=$$SORTDT^CCRUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE "RTN","GPLVITAL",43,0) ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY "RTN","GPLVITAL",44,0) S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS "RTN","GPLVITAL",45,0) F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST "RTN","GPLVITAL",46,0) . I $D(VITRSLT(VSORT(J))) D "RTN","GPLVITAL",47,0) . . S VITVMAP=$NA(@VITTVMAP@(J)) "RTN","GPLVITAL",48,0) . . K @VITVMAP "RTN","GPLVITAL",49,0) . . I DEBUG W "VMAP= ",VITVMAP,! "RTN","GPLVITAL",50,0) . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY "RTN","GPLVITAL",51,0) . . I DEBUG W "VITAL ",VSORT(J),! "RTN","GPLVITAL",52,0) . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT"),! "RTN","GPLVITAL",53,0) . . I DEBUG W $P(VITPTMP,U,4),! "RTN","GPLVITAL",54,0) . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID "RTN","GPLVITAL",55,0) . . I $P(VITPTMP,U,2)="HT" D "RTN","GPLVITAL",56,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",57,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",58,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","GPLVITAL",59,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",60,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",61,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",62,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" "RTN","GPLVITAL",63,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="248327008" "RTN","GPLVITAL",64,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",65,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",66,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",67,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",68,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" "RTN","GPLVITAL",69,0) . . E I $P(VITPTMP,U,2)="WT" D "RTN","GPLVITAL",70,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",71,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",72,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","GPLVITAL",73,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",74,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",75,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",76,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" "RTN","GPLVITAL",77,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="107647005" "RTN","GPLVITAL",78,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",79,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",80,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",81,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",82,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" "RTN","GPLVITAL",83,0) . . E I $P(VITPTMP,U,2)="BP" D "RTN","GPLVITAL",84,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",85,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",86,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","GPLVITAL",87,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",88,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",89,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",90,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" "RTN","GPLVITAL",91,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="392570002" "RTN","GPLVITAL",92,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",93,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",94,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",95,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",96,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","GPLVITAL",97,0) . . E I $P(VITPTMP,U,2)="T" D "RTN","GPLVITAL",98,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",99,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",100,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","GPLVITAL",101,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",102,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",103,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",104,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" "RTN","GPLVITAL",105,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="309646008" "RTN","GPLVITAL",106,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",107,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",108,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",109,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",110,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" "RTN","GPLVITAL",111,0) . . E I $P(VITPTMP,U,2)="R" D "RTN","GPLVITAL",112,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",113,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",114,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","GPLVITAL",115,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",116,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",117,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",118,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" "RTN","GPLVITAL",119,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="366147009" "RTN","GPLVITAL",120,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",121,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",122,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",123,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",124,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","GPLVITAL",125,0) . . E I $P(VITPTMP,U,2)="P" D "RTN","GPLVITAL",126,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",127,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",128,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","GPLVITAL",129,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",130,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",131,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",132,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" "RTN","GPLVITAL",133,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="366199006" "RTN","GPLVITAL",134,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",135,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",136,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",137,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",138,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","GPLVITAL",139,0) . . E I $P(VITPTMP,U,2)="PN" D "RTN","GPLVITAL",140,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",141,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",142,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","GPLVITAL",143,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",144,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",145,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" "RTN","GPLVITAL",146,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" "RTN","GPLVITAL",147,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="22253000" "RTN","GPLVITAL",148,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" "RTN","GPLVITAL",149,0) . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",150,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",151,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",152,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" "RTN","GPLVITAL",153,0) . . E D "RTN","GPLVITAL",154,0) . . . ;W "IN VITAL: OTHER",! "RTN","GPLVITAL",155,0) . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" "RTN","GPLVITAL",156,0) . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") "RTN","GPLVITAL",157,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" "RTN","GPLVITAL",158,0) . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" "RTN","GPLVITAL",159,0) . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J "RTN","GPLVITAL",160,0) . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" "RTN","GPLVITAL",161,0) . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" "RTN","GPLVITAL",162,0) . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="" "RTN","GPLVITAL",163,0) . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="" "RTN","GPLVITAL",164,0) . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" "RTN","GPLVITAL",165,0) . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) "RTN","GPLVITAL",166,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) "RTN","GPLVITAL",167,0) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" "RTN","GPLVITAL",168,0) . . S VITARYTMP=$NA(@VITTARYTMP@(J)) "RTN","GPLVITAL",169,0) . . K @VITARYTMP "RTN","GPLVITAL",170,0) . . D MAP^GPLXPATH(VITXML,VITVMAP,VITARYTMP) "RTN","GPLVITAL",171,0) . . I J=1 D ; FIRST ONE IS JUST A COPY "RTN","GPLVITAL",172,0) . . . ; W "FIRST ONE",! "RTN","GPLVITAL",173,0) . . . D CP^GPLXPATH(VITARYTMP,VITOUTXML) "RTN","GPLVITAL",174,0) . . . I DEBUG W "VITOUTXML ",VITOUTXML,! "RTN","GPLVITAL",175,0) . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML "RTN","GPLVITAL",176,0) . . . D INSINNER^GPLXPATH(VITOUTXML,VITARYTMP) "RTN","GPLVITAL",177,0) ; ZWR ^TMP($J,"VITALS",*) "RTN","GPLVITAL",178,0) ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS "RTN","GPLVITAL",179,0) I DEBUG D PARY^GPLXPATH(VITOUTXML) "RTN","GPLVITAL",180,0) N VITTMP,I "RTN","GPLVITAL",181,0) D MISSING^GPLXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS "RTN","GPLVITAL",182,0) I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ "RTN","GPLVITAL",183,0) . W "VITALS MISSING ",! "RTN","GPLVITAL",184,0) . F I=1:1:VITTMP(0) W VITTMP(I),! "RTN","GPLVITAL",185,0) Q "RTN","GPLVITAL",186,0) ; "RTN","GPLVITAL",187,0) VITDATES(VDT) ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY "RTN","GPLVITAL",188,0) ; OF DATES IN THE VITALS RESULTS "RTN","GPLVITAL",189,0) N VDTI,VDTJ,VTDCNT "RTN","GPLVITAL",190,0) S VTDCNT=0 ; COUNT TO BUILD ARRAY "RTN","GPLVITAL",191,0) S VDTJ="" ; USED TO VISIT THE RESULTS "RTN","GPLVITAL",192,0) F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS "RTN","GPLVITAL",193,0) . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT "RTN","GPLVITAL",194,0) . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER "RTN","GPLVITAL",195,0) . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE "RTN","GPLVITAL",196,0) S VDT(0)=VTDCNT "RTN","GPLVITAL",197,0) Q "RTN","GPLVITAL",198,0) ; "RTN","GPLXPAT0") 0^19^B50983429 "RTN","GPLXPAT0",1,0) GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 "RTN","GPLXPAT0",2,0) ;;0.2;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLXPAT0",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLXPAT0",4,0) ;General Public License See attached copy of the License. "RTN","GPLXPAT0",5,0) ; "RTN","GPLXPAT0",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLXPAT0",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLXPAT0",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLXPAT0",9,0) ;(at your option) any later version. "RTN","GPLXPAT0",10,0) ; "RTN","GPLXPAT0",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLXPAT0",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLXPAT0",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLXPAT0",14,0) ;GNU General Public License for more details. "RTN","GPLXPAT0",15,0) ; "RTN","GPLXPAT0",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLXPAT0",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLXPAT0",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLXPAT0",19,0) ; "RTN","GPLXPAT0",20,0) W "NO ENTRY",! "RTN","GPLXPAT0",21,0) Q "RTN","GPLXPAT0",22,0) ; "RTN","GPLXPAT0",23,0) ;;> "RTN","GPLXPAT0",24,0) ;;> "RTN","GPLXPAT0",25,0) ;;>>>K GPL S GPL="" "RTN","GPLXPAT0",26,0) ;;>>>D PUSH^GPLXPATH("GPL","FIRST") "RTN","GPLXPAT0",27,0) ;;>>>D PUSH^GPLXPATH("GPL","SECOND") "RTN","GPLXPAT0",28,0) ;;>>>D PUSH^GPLXPATH("GPL","THIRD") "RTN","GPLXPAT0",29,0) ;;>>>D PUSH^GPLXPATH("GPL","FOURTH") "RTN","GPLXPAT0",30,0) ;;>>?GPL(0)=4 "RTN","GPLXPAT0",31,0) ;;> "RTN","GPLXPAT0",32,0) ;;>>>K GXML S GXML="" "RTN","GPLXPAT0",33,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",34,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",35,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",36,0) ;;>>>D PUSH^GPLXPATH("GXML","@@DATA1@@") "RTN","GPLXPAT0",37,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",38,0) ;;>>>D PUSH^GPLXPATH("GXML","@@DATA2@@") "RTN","GPLXPAT0",39,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",40,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",41,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",42,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",43,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",44,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",45,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",46,0) ;;> "RTN","GPLXPAT0",47,0) ;;>>>K GXML S GXML="" "RTN","GPLXPAT0",48,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",49,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",50,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",51,0) ;;>>>D PUSH^GPLXPATH("GXML","DATA1") "RTN","GPLXPAT0",52,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",53,0) ;;>>>D PUSH^GPLXPATH("GXML","DATA2") "RTN","GPLXPAT0",54,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",55,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",56,0) ;;>>>D PUSH^GPLXPATH("GXML","<_SECOND>") "RTN","GPLXPAT0",57,0) ;;>>>D PUSH^GPLXPATH("GXML","DATA3") "RTN","GPLXPAT0",58,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",59,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",60,0) ;;>>>D PUSH^GPLXPATH("GXML","") "RTN","GPLXPAT0",61,0) ;;> "RTN","GPLXPAT0",62,0) ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") "RTN","GPLXPAT0",63,0) ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INIT") "RTN","GPLXPAT0",64,0) ;;>>?GPL(GPL(0))="FOURTH" "RTN","GPLXPAT0",65,0) ;;>>>D POP^GPLXPATH("GPL",.GX) "RTN","GPLXPAT0",66,0) ;;>>?GX="FOURTH" "RTN","GPLXPAT0",67,0) ;;>>?GPL(GPL(0))="THIRD" "RTN","GPLXPAT0",68,0) ;;>>>D POP^GPLXPATH("GPL",.GX) "RTN","GPLXPAT0",69,0) ;;>>?GX="THIRD" "RTN","GPLXPAT0",70,0) ;;>>?GPL(GPL(0))="SECOND" "RTN","GPLXPAT0",71,0) ;;> "RTN","GPLXPAT0",72,0) ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") "RTN","GPLXPAT0",73,0) ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INIT") "RTN","GPLXPAT0",74,0) ;;>>>S GX="" "RTN","GPLXPAT0",75,0) ;;>>>D MKMDX^GPLXPATH("GPL",.GX) "RTN","GPLXPAT0",76,0) ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" "RTN","GPLXPAT0",77,0) ;;> "RTN","GPLXPAT0",78,0) ;;>>?$$XNAME^GPLXPATH("DATA1")="FOURTH" "RTN","GPLXPAT0",79,0) ;;>>?$$XNAME^GPLXPATH("")="SIXTH" "RTN","GPLXPAT0",80,0) ;;>>?$$XNAME^GPLXPATH("")="THIRD" "RTN","GPLXPAT0",81,0) ;;> "RTN","GPLXPAT0",82,0) ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") "RTN","GPLXPAT0",83,0) ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INITXML") "RTN","GPLXPAT0",84,0) ;;>>>D INDEX^GPLXPATH("GXML") "RTN","GPLXPAT0",85,0) ;;>>?GXML("//FIRST/SECOND")="2^12" "RTN","GPLXPAT0",86,0) ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9" "RTN","GPLXPAT0",87,0) ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7" "RTN","GPLXPAT0",88,0) ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4" "RTN","GPLXPAT0",89,0) ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8" "RTN","GPLXPAT0",90,0) ;;>>?GXML("//FIRST/SECOND")="2^12" "RTN","GPLXPAT0",91,0) ;;>>?GXML("//FIRST")="1^13" "RTN","GPLXPAT0",92,0) ;;> "RTN","GPLXPAT0",93,0) ;;>>>D ZTEST^GPLXPATH("INITXML2") "RTN","GPLXPAT0",94,0) ;;>>>D INDEX^GPLXPATH("GXML") "RTN","GPLXPAT0",95,0) ;;>>?GXML("//FIRST/SECOND")="2^12" "RTN","GPLXPAT0",96,0) ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11" "RTN","GPLXPAT0",97,0) ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10" "RTN","GPLXPAT0",98,0) ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8" "RTN","GPLXPAT0",99,0) ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^7" "RTN","GPLXPAT0",100,0) ;;>>?GXML("//FIRST")="1^13" "RTN","GPLXPAT0",101,0) ;;> "RTN","GPLXPAT0",102,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",103,0) ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" "RTN","GPLXPAT0",104,0) ;;>>>D MISSING^GPLXPATH("GXML",OUTARY) "RTN","GPLXPAT0",105,0) ;;>>?@OUTARY@(1)="DATA1" "RTN","GPLXPAT0",106,0) ;;>>?@OUTARY@(2)="DATA2" "RTN","GPLXPAT0",107,0) ;;> "RTN","GPLXPAT0",108,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",109,0) ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" "RTN","GPLXPAT0",110,0) ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" "RTN","GPLXPAT0",111,0) ;;>>>S @MAPARY@("DATA2")="VALUE2" "RTN","GPLXPAT0",112,0) ;;>>>D MAP^GPLXPATH("GXML",MAPARY,OUTARY) "RTN","GPLXPAT0",113,0) ;;>>?@OUTARY@(6)="VALUE2" "RTN","GPLXPAT0",114,0) ;;> "RTN","GPLXPAT0",115,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",116,0) ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" "RTN","GPLXPAT0",117,0) ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" "RTN","GPLXPAT0",118,0) ;;>>>S @MAPARY@("DATA1")="VALUE1" "RTN","GPLXPAT0",119,0) ;;>>>S @MAPARY@("DATA2")="VALUE2" "RTN","GPLXPAT0",120,0) ;;>>>S @MAPARY@("DATA3")="VALUE3" "RTN","GPLXPAT0",121,0) ;;>>>S GXML(4)="@@DATA1@@ AND @@DATA3@@" "RTN","GPLXPAT0",122,0) ;;>>>D MAP^GPLXPATH("GXML",MAPARY,OUTARY) "RTN","GPLXPAT0",123,0) ;;>>>D PARY^GPLXPATH(OUTARY) "RTN","GPLXPAT0",124,0) ;;>>?@OUTARY@(4)="VALUE1 AND VALUE3" "RTN","GPLXPAT0",125,0) ;;> "RTN","GPLXPAT0",126,0) ;;>>>D QUEUE^GPLXPATH("BTLIST","GXML",2,3) "RTN","GPLXPAT0",127,0) ;;>>>D QUEUE^GPLXPATH("BTLIST","GXML",4,5) "RTN","GPLXPAT0",128,0) ;;>>?$P(BTLIST(2),";",2)=4 "RTN","GPLXPAT0",129,0) ;;> "RTN","GPLXPAT0",130,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",131,0) ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") "RTN","GPLXPAT0",132,0) ;;>>>D ZTEST^GPLXPATH("QUEUE") "RTN","GPLXPAT0",133,0) ;;>>>D BUILD^GPLXPATH("BTLIST","G3") "RTN","GPLXPAT0",134,0) ;;> "RTN","GPLXPAT0",135,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",136,0) ;;>>>D CP^GPLXPATH("GXML","G2") "RTN","GPLXPAT0",137,0) ;;>>?G2(0)=13 "RTN","GPLXPAT0",138,0) ;;> "RTN","GPLXPAT0",139,0) ;;>>>K G2,GBL "RTN","GPLXPAT0",140,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",141,0) ;;>>>D QOPEN^GPLXPATH("GBL","GXML") "RTN","GPLXPAT0",142,0) ;;>>?$P(GBL(1),";",3)=12 "RTN","GPLXPAT0",143,0) ;;>>>D BUILD^GPLXPATH("GBL","G2") "RTN","GPLXPAT0",144,0) ;;>>?G2(G2(0))="" "RTN","GPLXPAT0",145,0) ;;> "RTN","GPLXPAT0",146,0) ;;>>>K G2,GBL "RTN","GPLXPAT0",147,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",148,0) ;;>>>D QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND") "RTN","GPLXPAT0",149,0) ;;>>?$P(GBL(1),";",3)=11 "RTN","GPLXPAT0",150,0) ;;>>>D BUILD^GPLXPATH("GBL","G2") "RTN","GPLXPAT0",151,0) ;;>>?G2(G2(0))="" "RTN","GPLXPAT0",152,0) ;;> "RTN","GPLXPAT0",153,0) ;;>>>K G2,GBL "RTN","GPLXPAT0",154,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",155,0) ;;>>>D QCLOSE^GPLXPATH("GBL","GXML") "RTN","GPLXPAT0",156,0) ;;>>?$P(GBL(1),";",3)=13 "RTN","GPLXPAT0",157,0) ;;>>>D BUILD^GPLXPATH("GBL","G2") "RTN","GPLXPAT0",158,0) ;;>>?G2(G2(0))="" "RTN","GPLXPAT0",159,0) ;;> "RTN","GPLXPAT0",160,0) ;;>>>K G2,GBL "RTN","GPLXPAT0",161,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",162,0) ;;>>>D QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD") "RTN","GPLXPAT0",163,0) ;;>>?$P(GBL(1),";",3)=13 "RTN","GPLXPAT0",164,0) ;;>>>D BUILD^GPLXPATH("GBL","G2") "RTN","GPLXPAT0",165,0) ;;>>?G2(G2(0))="" "RTN","GPLXPAT0",166,0) ;;>>?G2(1)="" "RTN","GPLXPAT0",167,0) ;;> "RTN","GPLXPAT0",168,0) ;;>>>K G2,GBL,G3,G4 "RTN","GPLXPAT0",169,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",170,0) ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") "RTN","GPLXPAT0",171,0) ;;>>>D INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") "RTN","GPLXPAT0",172,0) ;;>>>D INSERT^GPLXPATH("G3","G2","//") "RTN","GPLXPAT0",173,0) ;;>>?G2(1)=GXML(9) "RTN","GPLXPAT0",174,0) ;;> "RTN","GPLXPAT0",175,0) ;;>>>K G2,GBL,G3 "RTN","GPLXPAT0",176,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",177,0) ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") "RTN","GPLXPAT0",178,0) ;;>>>D REPLACE^GPLXPATH("GXML","G2","//FIRST/SECOND") "RTN","GPLXPAT0",179,0) ;;>>?GXML(2)="" "RTN","GPLXPAT0",180,0) ;;> "RTN","GPLXPAT0",181,0) ;;>>>K GXML,G2,GBL,G3 "RTN","GPLXPAT0",182,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",183,0) ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2") "RTN","GPLXPAT0",184,0) ;;>>>D INSINNER^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") "RTN","GPLXPAT0",185,0) ;;>>?GXML(10)="" "RTN","GPLXPAT0",186,0) ;;> "RTN","GPLXPAT0",187,0) ;;>>>K GXML,G2,GBL,G3 "RTN","GPLXPAT0",188,0) ;;>>>D ZTEST^GPLXPATH("INITXML") "RTN","GPLXPAT0",189,0) ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2") "RTN","GPLXPAT0",190,0) ;;>>>D INSINNER^GPLXPATH("G2","G2") "RTN","GPLXPAT0",191,0) ;;>>?G2(8)="" "RTN","GPLXPAT0",192,0) ;;> "RTN","GPLXPAT0",193,0) ;;>>>K GTMP,GTMP2 "RTN","GPLXPAT0",194,0) ;;>>>N GTMP,GTMP2 "RTN","GPLXPAT0",195,0) ;;>>>D PUSH^GPLXPATH("GTMP","A") "RTN","GPLXPAT0",196,0) ;;>>>D PUSH^GPLXPATH("GTMP2","B") "RTN","GPLXPAT0",197,0) ;;>>>D PUSH^GPLXPATH("GTMP2","C") "RTN","GPLXPAT0",198,0) ;;>>>D PUSHA^GPLXPATH("GTMP","GTMP2") "RTN","GPLXPAT0",199,0) ;;>>?GTMP(3)="C" "RTN","GPLXPAT0",200,0) ;;>>?GTMP(0)=3 "RTN","GPLXPAT0",201,0) ;;> "RTN","GPLXPAT0",202,0) ;;>>>K GTMP,GTMP2 "RTN","GPLXPAT0",203,0) ;;>>>S GTMP("TEST1")=1 "RTN","GPLXPAT0",204,0) ;;>>>D H2ARY^GPLXPATH("GTMP2","GTMP") "RTN","GPLXPAT0",205,0) ;;>>?GTMP2(0)=1 "RTN","GPLXPAT0",206,0) ;;>>?GTMP2(1)="TEST1^1" "RTN","GPLXPAT0",207,0) ;;> "RTN","GPLXPAT0",208,0) ;;>>>K GTMP,GTMP2 "RTN","GPLXPAT0",209,0) ;;>>>D PUSH^GPLXPATH("GTMP","@@VAR1@@") "RTN","GPLXPAT0",210,0) ;;>>>D XVARS^GPLXPATH("GTMP2","GTMP") "RTN","GPLXPAT0",211,0) ;;>>?GTMP2(1)="VAR1^" "RTN","GPLXPAT0",212,0) ;;> "RTN","GPLXPATH") 0^9^B241520746 "RTN","GPLXPATH",1,0) GPLXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 "RTN","GPLXPATH",2,0) ;;0.2;CCDCCR;nopatch;noreleasedate;Build 8 "RTN","GPLXPATH",3,0) ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU "RTN","GPLXPATH",4,0) ;General Public License See attached copy of the License. "RTN","GPLXPATH",5,0) ; "RTN","GPLXPATH",6,0) ;This program is free software; you can redistribute it and/or modify "RTN","GPLXPATH",7,0) ;it under the terms of the GNU General Public License as published by "RTN","GPLXPATH",8,0) ;the Free Software Foundation; either version 2 of the License, or "RTN","GPLXPATH",9,0) ;(at your option) any later version. "RTN","GPLXPATH",10,0) ; "RTN","GPLXPATH",11,0) ;This program is distributed in the hope that it will be useful, "RTN","GPLXPATH",12,0) ;but WITHOUT ANY WARRANTY; without even the implied warranty of "RTN","GPLXPATH",13,0) ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "RTN","GPLXPATH",14,0) ;GNU General Public License for more details. "RTN","GPLXPATH",15,0) ; "RTN","GPLXPATH",16,0) ;You should have received a copy of the GNU General Public License along "RTN","GPLXPATH",17,0) ;with this program; if not, write to the Free Software Foundation, Inc., "RTN","GPLXPATH",18,0) ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. "RTN","GPLXPATH",19,0) ; "RTN","GPLXPATH",20,0) W "This is an XML XPATH utility library",! "RTN","GPLXPATH",21,0) W ! "RTN","GPLXPATH",22,0) Q "RTN","GPLXPATH",23,0) ; "RTN","GPLXPATH",24,0) OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE "RTN","GPLXPATH",25,0) ; "RTN","GPLXPATH",26,0) N Y "RTN","GPLXPATH",27,0) S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) "RTN","GPLXPATH",28,0) I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR "RTN","GPLXPATH",29,0) I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR "RTN","GPLXPATH",30,0) Q "RTN","GPLXPATH",31,0) ; "RTN","GPLXPATH",32,0) PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) "RTN","GPLXPATH",33,0) ; VAL IS A STRING AND STK IS PASSED BY NAME "RTN","GPLXPATH",34,0) ; "RTN","GPLXPATH",35,0) I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE "RTN","GPLXPATH",36,0) S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH "RTN","GPLXPATH",37,0) S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY "RTN","GPLXPATH",38,0) Q "RTN","GPLXPATH",39,0) ; "RTN","GPLXPATH",40,0) POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL "RTN","GPLXPATH",41,0) ; VAL AND STK ARE PASSED BY REFERENCE "RTN","GPLXPATH",42,0) ; "RTN","GPLXPATH",43,0) I @STK@(0)<1 D ; IF ARRAY IS EMPTY "RTN","GPLXPATH",44,0) . S VAL="" "RTN","GPLXPATH",45,0) . S @STK@(0)=0 "RTN","GPLXPATH",46,0) I @STK@(0)>0 D ; "RTN","GPLXPATH",47,0) . S VAL=@STK@(@STK@(0)) "RTN","GPLXPATH",48,0) . K @STK@(@STK@(0)) "RTN","GPLXPATH",49,0) . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY "RTN","GPLXPATH",50,0) Q "RTN","GPLXPATH",51,0) ; "RTN","GPLXPATH",52,0) PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME "RTN","GPLXPATH",53,0) ; "RTN","GPLXPATH",54,0) N ZGI "RTN","GPLXPATH",55,0) F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY "RTN","GPLXPATH",56,0) . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT "RTN","GPLXPATH",57,0) Q "RTN","GPLXPATH",58,0) ; "RTN","GPLXPATH",59,0) MKMDX(STK,RTN) ; MAKES A MUMPS INDEX FROM THE ARRAY STK "RTN","GPLXPATH",60,0) ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS "RTN","GPLXPATH",61,0) S RTN="" "RTN","GPLXPATH",62,0) N I "RTN","GPLXPATH",63,0) ; W "STK= ",STK,! "RTN","GPLXPATH",64,0) I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY "RTN","GPLXPATH",65,0) . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON "RTN","GPLXPATH",66,0) . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON "RTN","GPLXPATH",67,0) . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) "RTN","GPLXPATH",68,0) Q "RTN","GPLXPATH",69,0) ; "RTN","GPLXPATH",70,0) XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG "RTN","GPLXPATH",71,0) ; AND WILL RETURN NAME "RTN","GPLXPATH",72,0) ; ISTR IS PASSED BY VALUE "RTN","GPLXPATH",73,0) N CUR,TMP "RTN","GPLXPATH",74,0) I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET "RTN","GPLXPATH",75,0) . S TMP=$P(ISTR,"<",2) "RTN","GPLXPATH",76,0) I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE "RTN","GPLXPATH",77,0) . S TMP=$P(TMP,"/",2) "RTN","GPLXPATH",78,0) S CUR=$P(TMP,">",1) ; EXTRACT THE NAME "RTN","GPLXPATH",79,0) ; W "CUR= ",CUR,! "RTN","GPLXPATH",80,0) I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> "RTN","GPLXPATH",81,0) . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER "RTN","GPLXPATH",82,0) ; W "CUR2= ",CUR,! "RTN","GPLXPATH",83,0) Q CUR "RTN","GPLXPATH",84,0) ; "RTN","GPLXPATH",85,0) INDEX(ZXML) ; parse the XML in ZXML and produce an XPATH index "RTN","GPLXPATH",86,0) ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE "RTN","GPLXPATH",87,0) ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE "RTN","GPLXPATH",88,0) ; XML SECTION "RTN","GPLXPATH",89,0) ; ZXML IS PASSED BY NAME "RTN","GPLXPATH",90,0) N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND "RTN","GPLXPATH",91,0) N GPLSTK ; LEAVE OUT FOR DEBUGGING "RTN","GPLXPATH",92,0) I '$D(@ZXML@(0)) D ; NO XML PASSED "RTN","GPLXPATH",93,0) . W "ERROR IN XML FILE",! "RTN","GPLXPATH",94,0) S GPLSTK(0)=0 ; INITIALIZE STACK "RTN","GPLXPATH",95,0) F I=1:1:@ZXML@(0) D ; PROCESS THE ENTIRE ARRAY "RTN","GPLXPATH",96,0) . S LINE=@ZXML@(I) "RTN","GPLXPATH",97,0) . ;W LINE,! "RTN","GPLXPATH",98,0) . S FOUND=0 ; INTIALIZED FOUND FLAG "RTN","GPLXPATH",99,0) . I LINE?.E1"".E) D "RTN","GPLXPATH",102,0) . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS "RTN","GPLXPATH",103,0) . . . ; ON THE SAME LINE "RTN","GPLXPATH",104,0) . . . ; W "FOUND ",LINE,! "RTN","GPLXPATH",105,0) . . . S FOUND=1 ; SET FOUND FLAG "RTN","GPLXPATH",106,0) . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME "RTN","GPLXPATH",107,0) . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK "RTN","GPLXPATH",108,0) . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX "RTN","GPLXPATH",109,0) . . . ; W "MDX=",MDX,! "RTN","GPLXPATH",110,0) . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE "RTN","GPLXPATH",111,0) . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER "RTN","GPLXPATH",112,0) . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE "RTN","GPLXPATH",113,0) . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST "RTN","GPLXPATH",114,0) . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK "RTN","GPLXPATH",115,0) . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END "RTN","GPLXPATH",116,0) . . I LINE?.E1"") D ; BEGINNING OF A SECTION "RTN","GPLXPATH",129,0) . . . ; W "FOUND ",LINE,! "RTN","GPLXPATH",130,0) . . . S FOUND=1 ; SET FOUND FLAG "RTN","GPLXPATH",131,0) . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME "RTN","GPLXPATH",132,0) . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK "RTN","GPLXPATH",133,0) . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX "RTN","GPLXPATH",134,0) . . . ; W "MDX=",MDX,! "RTN","GPLXPATH",135,0) . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE "RTN","GPLXPATH",136,0) . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER "RTN","GPLXPATH",137,0) . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE "RTN","GPLXPATH",138,0) . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX "RTN","GPLXPATH",139,0) S @ZXML@("INDEXED")="" "RTN","GPLXPATH",140,0) S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH "RTN","GPLXPATH",141,0) Q "RTN","GPLXPATH",142,0) ; "RTN","GPLXPATH",143,0) QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION "RTN","GPLXPATH",144,0) ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" "RTN","GPLXPATH",145,0) ; IARY AND OARY ARE PASSED BY NAME "RTN","GPLXPATH",146,0) I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY "RTN","GPLXPATH",147,0) . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML "RTN","GPLXPATH",148,0) N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN "RTN","GPLXPATH",149,0) N TMP,I,J,QXPATH "RTN","GPLXPATH",150,0) S FIRST=1 "RTN","GPLXPATH",151,0) S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT "RTN","GPLXPATH",152,0) I XPATH'="//" D ; NOT A ROOT QUERY "RTN","GPLXPATH",153,0) . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES "RTN","GPLXPATH",154,0) . S FIRST=$P(TMP,"^",1) "RTN","GPLXPATH",155,0) . S LAST=$P(TMP,"^",2) "RTN","GPLXPATH",156,0) K @OARY "RTN","GPLXPATH",157,0) S @OARY@(0)=+LAST-FIRST+1 "RTN","GPLXPATH",158,0) S J=1 "RTN","GPLXPATH",159,0) FOR I=FIRST:1:LAST D "RTN","GPLXPATH",160,0) . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY "RTN","GPLXPATH",161,0) . S J=J+1 "RTN","GPLXPATH",162,0) ; ZWR OARY "RTN","GPLXPATH",163,0) Q "RTN","GPLXPATH",164,0) ; "RTN","GPLXPATH",165,0) XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH "RTN","GPLXPATH",166,0) ; INDEX WITH TWO PIECES START^FINISH "RTN","GPLXPATH",167,0) ; IDX IS PASSED BY NAME "RTN","GPLXPATH",168,0) Q $P(@IDX@(XPATH),"^",1) "RTN","GPLXPATH",169,0) ; "RTN","GPLXPATH",170,0) XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH "RTN","GPLXPATH",171,0) ; INDEX WITH TWO PIECES START^FINISH "RTN","GPLXPATH",172,0) ; IDX IS PASSED BY NAME "RTN","GPLXPATH",173,0) Q $P(@IDX@(XPATH),"^",2) "RTN","GPLXPATH",174,0) ; "RTN","GPLXPATH",175,0) START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX "RTN","GPLXPATH",176,0) ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH "RTN","GPLXPATH",177,0) ; COMPANION TO FINISH ; IDX IS PASSED BY NAME "RTN","GPLXPATH",178,0) Q $P(ISTR,";",2) "RTN","GPLXPATH",179,0) ; "RTN","GPLXPATH",180,0) FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX "RTN","GPLXPATH",181,0) ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH "RTN","GPLXPATH",182,0) Q $P(ISTR,";",3) "RTN","GPLXPATH",183,0) ; "RTN","GPLXPATH",184,0) ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX "RTN","GPLXPATH",185,0) ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH "RTN","GPLXPATH",186,0) Q $P(ISTR,";",1) "RTN","GPLXPATH",187,0) ; "RTN","GPLXPATH",188,0) BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST "RTN","GPLXPATH",189,0) ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST "RTN","GPLXPATH",190,0) ; DEST IS CLEARED TO START "RTN","GPLXPATH",191,0) ; USES PUSH TO DO THE COPY "RTN","GPLXPATH",192,0) N I "RTN","GPLXPATH",193,0) K @BDEST "RTN","GPLXPATH",194,0) F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST "RTN","GPLXPATH",195,0) . N J,ATMP "RTN","GPLXPATH",196,0) . S ATMP=$$ARRAY(@BLIST@(I)) "RTN","GPLXPATH",197,0) . I DEBUG W "ATMP=",ATMP,! "RTN","GPLXPATH",198,0) . I DEBUG W @BLIST@(I),! "RTN","GPLXPATH",199,0) . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; "RTN","GPLXPATH",200,0) . . ; FOR EACH LINE IN THIS INSTR "RTN","GPLXPATH",201,0) . . I DEBUG W "BDEST= ",BDEST,! "RTN","GPLXPATH",202,0) . . I DEBUG W "ATMP= ",@ATMP@(J),! "RTN","GPLXPATH",203,0) . . D PUSH(BDEST,@ATMP@(J)) "RTN","GPLXPATH",204,0) Q "RTN","GPLXPATH",205,0) ; "RTN","GPLXPATH",206,0) QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST "RTN","GPLXPATH",207,0) ; "RTN","GPLXPATH",208,0) I DEBUG W "QUEUEING ",BLST,! "RTN","GPLXPATH",209,0) D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) "RTN","GPLXPATH",210,0) Q "RTN","GPLXPATH",211,0) ; "RTN","GPLXPATH",212,0) CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME "RTN","GPLXPATH",213,0) ; KILLS CPDEST FIRST "RTN","GPLXPATH",214,0) N CPINSTR "RTN","GPLXPATH",215,0) I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,! "RTN","GPLXPATH",216,0) I @CPSRC@(0)<1 D ; BAD LENGTH "RTN","GPLXPATH",217,0) . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! "RTN","GPLXPATH",218,0) . Q "RTN","GPLXPATH",219,0) ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT "RTN","GPLXPATH",220,0) D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY "RTN","GPLXPATH",221,0) D BUILD("CPINSTR",CPDEST) "RTN","GPLXPATH",222,0) Q "RTN","GPLXPATH",223,0) ; "RTN","GPLXPATH",224,0) QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST "RTN","GPLXPATH",225,0) ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD "RTN","GPLXPATH",226,0) ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT "RTN","GPLXPATH",227,0) ; USED TO INSERT CHILDREN NODES "RTN","GPLXPATH",228,0) I @QOXML@(0)<1 D ; MALFORMED XML "RTN","GPLXPATH",229,0) . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! "RTN","GPLXPATH",230,0) . Q "RTN","GPLXPATH",231,0) I DEBUG W "DOING QOPEN",! "RTN","GPLXPATH",232,0) N S1,E1,QOT,QOTMP "RTN","GPLXPATH",233,0) S S1=1 ; OPEN FROM THE BEGINNING OF THE XML "RTN","GPLXPATH",234,0) I $D(QOXPATH) D ; XPATH PROVIDED "RTN","GPLXPATH",235,0) . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX "RTN","GPLXPATH",236,0) . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 "RTN","GPLXPATH",237,0) I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT "RTN","GPLXPATH",238,0) . S E1=@QOXML@(0)-1 "RTN","GPLXPATH",239,0) D QUEUE(QOBLIST,QOXML,S1,E1) "RTN","GPLXPATH",240,0) ; S QOTMP=QOXML_"^"_S1_"^"_E1 "RTN","GPLXPATH",241,0) ; D PUSH(QOBLIST,QOTMP) "RTN","GPLXPATH",242,0) Q "RTN","GPLXPATH",243,0) ; "RTN","GPLXPATH",244,0) QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN "RTN","GPLXPATH",245,0) ; ADDS THE LIST LINE OF QCXML TO QCBLIST "RTN","GPLXPATH",246,0) ; USED TO FINISH INSERTING CHILDERN NODES "RTN","GPLXPATH",247,0) ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END "RTN","GPLXPATH",248,0) ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO "RTN","GPLXPATH",249,0) I @QCXML@(0)<1 D ; MALFORMED XML "RTN","GPLXPATH",250,0) . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! "RTN","GPLXPATH",251,0) I DEBUG W "GOING TO CLOSE",! "RTN","GPLXPATH",252,0) N S1,E1,QCT,QCTMP "RTN","GPLXPATH",253,0) S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML "RTN","GPLXPATH",254,0) I $D(QCXPATH) D ; XPATH PROVIDED "RTN","GPLXPATH",255,0) . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX "RTN","GPLXPATH",256,0) . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML "RTN","GPLXPATH",257,0) I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT "RTN","GPLXPATH",258,0) . S S1=@QCXML@(0) "RTN","GPLXPATH",259,0) D QUEUE(QCBLIST,QCXML,S1,E1) "RTN","GPLXPATH",260,0) ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) "RTN","GPLXPATH",261,0) Q "RTN","GPLXPATH",262,0) ; "RTN","GPLXPATH",263,0) INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE "RTN","GPLXPATH",264,0) ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS "RTN","GPLXPATH",265,0) ; OMITTED, INSERTION WILL BE AT THE ROOT "RTN","GPLXPATH",266,0) ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW "RTN","GPLXPATH",267,0) ; XML AT THE END OF THE XPATH POINT "RTN","GPLXPATH",268,0) ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE "RTN","GPLXPATH",269,0) N INSBLD,INSTMP "RTN","GPLXPATH",270,0) I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! "RTN","GPLXPATH",271,0) I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),! "RTN","GPLXPATH",272,0) I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY "RTN","GPLXPATH",273,0) . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT "RTN","GPLXPATH",274,0) I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY "RTN","GPLXPATH",275,0) . I $D(INSXPATH) D ; XPATH PROVIDED "RTN","GPLXPATH",276,0) . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE "RTN","GPLXPATH",277,0) . . I DEBUG D PARY^GPLXPATH("INSBLD") "RTN","GPLXPATH",278,0) . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT "RTN","GPLXPATH",279,0) . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH "RTN","GPLXPATH",280,0) . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML "RTN","GPLXPATH",281,0) . I $D(INSXPATH) D ; XPATH PROVIDED "RTN","GPLXPATH",282,0) . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH "RTN","GPLXPATH",283,0) . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT "RTN","GPLXPATH",284,0) . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH "RTN","GPLXPATH",285,0) . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST "RTN","GPLXPATH",286,0) . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE "RTN","GPLXPATH",287,0) Q "RTN","GPLXPATH",288,0) ; "RTN","GPLXPATH",289,0) INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW "RTN","GPLXPATH",290,0) ; INTO INNXML AT THE INNXPATH XPATH POINT "RTN","GPLXPATH",291,0) ; "RTN","GPLXPATH",292,0) N INNBLD,UXPATH "RTN","GPLXPATH",293,0) N INNTBUF "RTN","GPLXPATH",294,0) S INNTBUF=$NA(^TMP($J,"INNTBUF")) "RTN","GPLXPATH",295,0) I '$D(INNXPATH) D ; XPATH NOT PASSED "RTN","GPLXPATH",296,0) . S UXPATH="//" ; USE ROOT XPATH "RTN","GPLXPATH",297,0) I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED "RTN","GPLXPATH",298,0) I '$D(@INNXML@(0)) D ; INNXML IS EMPTY "RTN","GPLXPATH",299,0) . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER "RTN","GPLXPATH",300,0) . D BUILD("INNBLD",INNXML) "RTN","GPLXPATH",301,0) I @INNXML@(0)>0 D ; NOT EMPTY "RTN","GPLXPATH",302,0) . D QOPEN("INNBLD",INNXML,UXPATH) ; "RTN","GPLXPATH",303,0) . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML "RTN","GPLXPATH",304,0) . D QCLOSE("INNBLD",INNXML,UXPATH) "RTN","GPLXPATH",305,0) . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER "RTN","GPLXPATH",306,0) . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST "RTN","GPLXPATH",307,0) Q "RTN","GPLXPATH",308,0) ; "RTN","GPLXPATH",309,0) INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST "RTN","GPLXPATH",310,0) ; BUT XDEST AN XNEW ARE PASSED BY NAME "RTN","GPLXPATH",311,0) N XBLD,XTMP "RTN","GPLXPATH",312,0) D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT "RTN","GPLXPATH",313,0) D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST "RTN","GPLXPATH",314,0) D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION "RTN","GPLXPATH",315,0) D BUILD("XBLD","XTMP") ; BUILD THE RESULT "RTN","GPLXPATH",316,0) D CP("XTMP",XDEST) ; COPY TO THE DESTINATION "RTN","GPLXPATH",317,0) I DEBUG D PARY("XDEST") "RTN","GPLXPATH",318,0) Q "RTN","GPLXPATH",319,0) ; "RTN","GPLXPATH",320,0) REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT "RTN","GPLXPATH",321,0) ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE "RTN","GPLXPATH",322,0) ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE "RTN","GPLXPATH",323,0) ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") "RTN","GPLXPATH",324,0) N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP "RTN","GPLXPATH",325,0) S OLD=$NA(^TMP($J,"REPLACE_OLD")) "RTN","GPLXPATH",326,0) D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD "RTN","GPLXPATH",327,0) S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS "RTN","GPLXPATH",328,0) S XFIRST=$P(XNODE,"^",1) "RTN","GPLXPATH",329,0) S XLAST=$P(XNODE,"^",2) "RTN","GPLXPATH",330,0) I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG "RTN","GPLXPATH",331,0) . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE "RTN","GPLXPATH",332,0) . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST "RTN","GPLXPATH",333,0) I RENEW'="" D ; NEW XML IS NOT NULL "RTN","GPLXPATH",334,0) . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE "RTN","GPLXPATH",335,0) . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW "RTN","GPLXPATH",336,0) . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST "RTN","GPLXPATH",337,0) I DEBUG W "REPLACE PREBUILD",! "RTN","GPLXPATH",338,0) I DEBUG D PARY("REBLD") "RTN","GPLXPATH",339,0) D BUILD("REBLD","RTMP") "RTN","GPLXPATH",340,0) K @REXML ; KILL WHAT WAS THERE "RTN","GPLXPATH",341,0) D CP("RTMP",REXML) ; COPY IN THE RESULT "RTN","GPLXPATH",342,0) Q "RTN","GPLXPATH",343,0) ; "RTN","GPLXPATH",344,0) MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY "RTN","GPLXPATH",345,0) ; W "Reporting on the missing",! "RTN","GPLXPATH",346,0) ; W OARY "RTN","GPLXPATH",347,0) I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q "RTN","GPLXPATH",348,0) N I "RTN","GPLXPATH",349,0) S @OARY@(0)=0 ; INITIALIZED MISSING COUNT "RTN","GPLXPATH",350,0) F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY "RTN","GPLXPATH",351,0) . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE "RTN","GPLXPATH",352,0) . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY "RTN","GPLXPATH",353,0) . . Q "RTN","GPLXPATH",354,0) Q "RTN","GPLXPATH",355,0) ; "RTN","GPLXPATH",356,0) MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY "RTN","GPLXPATH",357,0) ; AND PUT THE RESULTS IN OXML "RTN","GPLXPATH",358,0) I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q "RTN","GPLXPATH",359,0) I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q "RTN","GPLXPATH",360,0) N I,J,TNAM,TVAL,TSTR "RTN","GPLXPATH",361,0) S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT "RTN","GPLXPATH",362,0) F I=1:1:@OXML@(0) D ; LOOP THROUGH WHOLE ARRAY "RTN","GPLXPATH",363,0) . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT "RTN","GPLXPATH",364,0) . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? "RTN","GPLXPATH",365,0) . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS "RTN","GPLXPATH",366,0) . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS "RTN","GPLXPATH",367,0) . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! "RTN","GPLXPATH",368,0) . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME "RTN","GPLXPATH",369,0) . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED "RTN","GPLXPATH",370,0) . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? "RTN","GPLXPATH",371,0) . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD "RTN","GPLXPATH",372,0) . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE "RTN","GPLXPATH",373,0) . . . . E D DOFLD ; PROCESS A FIELD "RTN","GPLXPATH",374,0) . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER "RTN","GPLXPATH",375,0) . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES "RTN","GPLXPATH",376,0) . . I DEBUG W TSTR "RTN","GPLXPATH",377,0) I DEBUG W "MAPPED",! "RTN","GPLXPATH",378,0) Q "RTN","GPLXPATH",379,0) ; "RTN","GPLXPATH",380,0) DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE "RTN","GPLXPATH",381,0) ; "RTN","GPLXPATH",382,0) Q "RTN","GPLXPATH",383,0) ; "RTN","GPLXPATH",384,0) TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS "RTN","GPLXPATH",385,0) ; THEXML IS PASSED BY NAME "RTN","GPLXPATH",386,0) N I,J,TMPXML,DEL,FOUND,INTXT "RTN","GPLXPATH",387,0) S FOUND=0 "RTN","GPLXPATH",388,0) S INTXT=0 "RTN","GPLXPATH",389,0) I DEBUG W "DELETING EMPTY ELEMENTS",! "RTN","GPLXPATH",390,0) F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY "RTN","GPLXPATH",391,0) . S J=@THEXML@(I) "RTN","GPLXPATH",392,0) . I J["" D "RTN","GPLXPATH",393,0) . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM "RTN","GPLXPATH",394,0) . . I DEBUG W "IN HTML SECTION",! "RTN","GPLXPATH",395,0) . N JM,JP,JPX ; JMINUS AND JPLUS "RTN","GPLXPATH",396,0) . S JM=@THEXML@(I-1) ; LINE BEFORE "RTN","GPLXPATH",397,0) . I JM["" S INTXT=0 ; LEFT HTML SECTION,START TRIM "RTN","GPLXPATH",398,0) . S JP=@THEXML@(I+1) ; LINE AFTER "RTN","GPLXPATH",399,0) . I INTXT=0 D ; IF NOT IN AN HTML SECTION "RTN","GPLXPATH",400,0) . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH "RTN","GPLXPATH",401,0) . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES "RTN","GPLXPATH",402,0) . . . I DEBUG W I,J,JP,! "RTN","GPLXPATH",403,0) . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED "RTN","GPLXPATH",404,0) . . . S DEL(I)="" ; SET LINE TO DELETE "RTN","GPLXPATH",405,0) . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE "RTN","GPLXPATH",406,0) . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE "RTN","GPLXPATH",407,0) . . . I DEBUG W I,J,! "RTN","GPLXPATH",408,0) . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED "RTN","GPLXPATH",409,0) . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED "RTN","GPLXPATH",410,0) . . . I JM=JPX D ; "RTN","GPLXPATH",411,0) . . . . I DEBUG W I,JM_J_JPX,! "RTN","GPLXPATH",412,0) . . . . S DEL(I-1)="" "RTN","GPLXPATH",413,0) . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL "RTN","GPLXPATH",414,0) ; . I J'["><" D PUSH("TMPXML",J) "RTN","GPLXPATH",415,0) I FOUND D ; NEED TO DELETE THINGS "RTN","GPLXPATH",416,0) . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES "RTN","GPLXPATH",417,0) . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED "RTN","GPLXPATH",418,0) . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY "RTN","GPLXPATH",419,0) . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY "RTN","GPLXPATH",420,0) Q FOUND "RTN","GPLXPATH",421,0) ; "RTN","GPLXPATH",422,0) UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML "RTN","GPLXPATH",423,0) ; XSEC IS A SECTION PASSED BY NAME "RTN","GPLXPATH",424,0) N XBLD,XTMP "RTN","GPLXPATH",425,0) D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML "RTN","GPLXPATH",426,0) D BUILD("XBLD","XTMP") ; BUILD THE RESULT "RTN","GPLXPATH",427,0) D CP("XTMP",XSEC) ; REPLACE PASSED XML "RTN","GPLXPATH",428,0) Q "RTN","GPLXPATH",429,0) ; "RTN","GPLXPATH",430,0) PARY(GLO) ;PRINT AN ARRAY "RTN","GPLXPATH",431,0) N I "RTN","GPLXPATH",432,0) F I=1:1:@GLO@(0) W I_" "_@GLO@(I),! "RTN","GPLXPATH",433,0) Q "RTN","GPLXPATH",434,0) ; "RTN","GPLXPATH",435,0) H2ARY(IARYRTN,IHASH) ; CONVERT IHASH TO RETURN ARRAY "RTN","GPLXPATH",436,0) ; "RTN","GPLXPATH",437,0) N H2I S H2I="" "RTN","GPLXPATH",438,0) ; W $O(@IHASH@(H2I)),! "RTN","GPLXPATH",439,0) F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH "RTN","GPLXPATH",440,0) . ; W H2I_"^"_@IHASH@(H2I),! "RTN","GPLXPATH",441,0) . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES "RTN","GPLXPATH",442,0) . . W "GPLZZ",! "RTN","GPLXPATH",443,0) . . W $NA(@IHASH@(H2I)),! "RTN","GPLXPATH",444,0) . . Q ; "RTN","GPLXPATH",445,0) . D PUSH(IARYRTN,H2I_"^"_@IHASH@(H2I)) "RTN","GPLXPATH",446,0) . ; W @IARYRTN@(0),! "RTN","GPLXPATH",447,0) Q "RTN","GPLXPATH",448,0) ; "RTN","GPLXPATH",449,0) XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES "RTN","GPLXPATH",450,0) ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ "RTN","GPLXPATH",451,0) ; XVRTN AND XVIXML ARE PASSED BY NAME "RTN","GPLXPATH",452,0) ; "RTN","GPLXPATH",453,0) N XVI,XVTMP,XVT "RTN","GPLXPATH",454,0) F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML "RTN","GPLXPATH",455,0) . S XVT=@XVIXML@(XVI) "RTN","GPLXPATH",456,0) . I XVT["@@" S XVTMP($P(XVT,"@@",2))="" "RTN","GPLXPATH",457,0) D H2ARY(XVRTN,"XVTMP") "RTN","GPLXPATH",458,0) Q "RTN","GPLXPATH",459,0) ; "RTN","GPLXPATH",460,0) DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE "RTN","GPLXPATH",461,0) ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE "RTN","GPLXPATH",462,0) ; "RTN","GPLXPATH",463,0) N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED "RTN","GPLXPATH",464,0) I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE "RTN","GPLXPATH",465,0) . D LOAD^GPLCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP "RTN","GPLXPATH",466,0) . S DXUSE="DTMP" ; DXUSE IS NAME "RTN","GPLXPATH",467,0) E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE "RTN","GPLXPATH",468,0) . D LOAD^GPLCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP "RTN","GPLXPATH",469,0) . S DXUSE="DTMP" ; DXUSE IS NAME "RTN","GPLXPATH",470,0) E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE "RTN","GPLXPATH",471,0) N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE "RTN","GPLXPATH",472,0) D XVARS("DVARS",DXUSE) ; PULL OUT VARS "RTN","GPLXPATH",473,0) D PARY^GPLXPATH("DVARS") ;AND DISPLAY THEM "RTN","GPLXPATH",474,0) Q "RTN","GPLXPATH",475,0) ; "RTN","GPLXPATH",476,0) TEST ; Run all the test cases "RTN","GPLXPATH",477,0) D TESTALL^GPLUNIT("GPLXPAT0") "RTN","GPLXPATH",478,0) Q "RTN","GPLXPATH",479,0) ; "RTN","GPLXPATH",480,0) ZTEST(WHICH) ; RUN ONE SET OF TESTS "RTN","GPLXPATH",481,0) N ZTMP "RTN","GPLXPATH",482,0) S DEBUG=1 "RTN","GPLXPATH",483,0) D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") "RTN","GPLXPATH",484,0) D ZTEST^GPLUNIT(.ZTMP,WHICH) "RTN","GPLXPATH",485,0) Q "RTN","GPLXPATH",486,0) ; "RTN","GPLXPATH",487,0) TLIST ; LIST THE TESTS "RTN","GPLXPATH",488,0) N ZTMP "RTN","GPLXPATH",489,0) D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") "RTN","GPLXPATH",490,0) D TLIST^GPLUNIT(.ZTMP) "RTN","GPLXPATH",491,0) Q "RTN","GPLXPATH",492,0) ; "VER") 8.0^22.0 **END** **END**