Index: /ccr/trunk/p/CCR_1_0_5_T2_CACHE.KID =================================================================== --- /ccr/trunk/p/CCR_1_0_5_T2_CACHE.KID (revision 202) +++ /ccr/trunk/p/CCR_1_0_5_T2_CACHE.KID (revision 202) @@ -0,0 +1,9070 @@ +KIDS Distribution saved on Oct 07, 2008@15:52:44 +output file names have version number +**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) +9 +"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^B82192762 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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^B82192762 +"RTN","GPLCCR",1,0) +GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 +"RTN","GPLCCR",2,0) + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 9 +"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_0_5.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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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 9 +"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**