Index: ccr/trunk/p/CCR_1_0_5_T4_CACHE.KID =================================================================== --- ccr/trunk/p/CCR_1_0_5_T4_CACHE.KID (revision 549) +++ (revision ) @@ -1,9700 +1,0 @@ -KIDS Distribution saved on Oct 09, 2008@16:24:27 -included missing routines -**KIDS**:CCR*1.0*5^ - -**INSTALL NAME** -CCR*1.0*5 -"BLD",6955,0) -CCR*1.0*5^^0^3081009^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) -12 -"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^21^21 -"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) -GPLCCD^^0^B114413975 -"BLD",6955,"KRN",9.8,"NM",9,0) -GPLXPATH^^0^B241520746 -"BLD",6955,"KRN",9.8,"NM",10,0) -CCRMEDS1^^0^B80043311 -"BLD",6955,"KRN",9.8,"NM",11,0) -CCRMEDS2^^0^B99730224 -"BLD",6955,"KRN",9.8,"NM",12,0) -GPLUNIT^^0^B31438520 -"BLD",6955,"KRN",9.8,"NM",13,0) -GPLCCR^^0^B82192762 -"BLD",6955,"KRN",9.8,"NM",14,0) -GPLCCR0^^0^B654252455 -"BLD",6955,"KRN",9.8,"NM",15,0) -GPLCCD1^^0^B100039732 -"BLD",6955,"KRN",9.8,"NM",16,0) -GPLACTOR^^0^B52628160 -"BLD",6955,"KRN",9.8,"NM",17,0) -GPLVITAL^^0^B82628966 -"BLD",6955,"KRN",9.8,"NM",18,0) -GPLRIMA^^0^B214212612 -"BLD",6955,"KRN",9.8,"NM",19,0) -GPLALERT^^0^B13662473 -"BLD",6955,"KRN",9.8,"NM",20,0) -GPLPROBS^^0^B25875394 -"BLD",6955,"KRN",9.8,"NM",21,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","CCRMEDS1",10) - -"BLD",6955,"KRN",9.8,"NM","B","CCRMEDS2",11) - -"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",16) - -"BLD",6955,"KRN",9.8,"NM","B","GPLALERT",19) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD",8) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD1",15) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR",13) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR0",14) - -"BLD",6955,"KRN",9.8,"NM","B","GPLPROBS",20) - -"BLD",6955,"KRN",9.8,"NM","B","GPLRIMA",18) - -"BLD",6955,"KRN",9.8,"NM","B","GPLUNIT",12) - -"BLD",6955,"KRN",9.8,"NM","B","GPLVITAL",17) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPAT0",21) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPATH",9) - -"BLD",6955,"KRN",19,0) -19 -"BLD",6955,"KRN",19,"NM",0) -^9.68A^^ -"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") -21 -"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 12 -"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 12 -"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 12 -"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","CCRMEDS1") -0^10^B80043311 -"RTN","CCRMEDS1",1,0) -CCRMEDS ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;08/24/08 -"RTN","CCRMEDS1",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 12 -"RTN","CCRMEDS1",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS1",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS1",5,0) - ; -"RTN","CCRMEDS1",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS1",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS1",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS1",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS1",10,0) - ; -"RTN","CCRMEDS1",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS1",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS1",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS1",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS1",15,0) - ; -"RTN","CCRMEDS1",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS1",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS1",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS1",19,0) - ; -"RTN","CCRMEDS1",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS1",21,0) - Q -"RTN","CCRMEDS1",22,0) - ; -"RTN","CCRMEDS1",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS1",24,0) - ; -"RTN","CCRMEDS1",25,0) - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","CCRMEDS1",26,0) - ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE -"RTN","CCRMEDS1",27,0) - ; -"RTN","CCRMEDS1",28,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS1",29,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS1",30,0) - ; MED is holds each array element from MEDS(J), one medicine -"RTN","CCRMEDS1",31,0) - ; J is a counter. -"RTN","CCRMEDS1",32,0) - ; -"RTN","CCRMEDS1",33,0) - ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all -"RTN","CCRMEDS1",34,0) - ; med data available. -"RTN","CCRMEDS1",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS1",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS1",37,0) - ; D PARY^GPLXPATH(MINXML) -"RTN","CCRMEDS1",38,0) - N MEDS,MAP -"RTN","CCRMEDS1",39,0) - K ^TMP($J) -"RTN","CCRMEDS1",40,0) - D RX^PSO52API(DFN,"CCDCCR") -"RTN","CCRMEDS1",41,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS1",42,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS1",43,0) - ; If it is -1, we quit. -"RTN","CCRMEDS1",44,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS1",45,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS1",46,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS1",47,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS1",48,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS1",49,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS1",50,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS1",51,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS1",52,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS1",53,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS1",54,0) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN CCRMEDS -"RTN","CCRMEDS1",55,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS1",56,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS1",57,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS1",58,0) - . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS1",59,0) - . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number -"RTN","CCRMEDS1",60,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS1",61,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($P(MED(1),U)) -"RTN","CCRMEDS1",62,0) - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" -"RTN","CCRMEDS1",63,0) - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^CCRUTIL($P(MED(101),U)) -"RTN","CCRMEDS1",64,0) - . S @MAP@("MEDRXNOTXT")="Prescription Number" -"RTN","CCRMEDS1",65,0) - . S @MAP@("MEDRXNO")=MED(.01) -"RTN","CCRMEDS1",66,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS1",67,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS1",68,0) - . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) -"RTN","CCRMEDS1",69,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) -"RTN","CCRMEDS1",70,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) -"RTN","CCRMEDS1",71,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=MED(27) -"RTN","CCRMEDS1",72,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS1",73,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS1",74,0) - . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) -"RTN","CCRMEDS1",75,0) - . N MEDIEN S MEDIEN=$P(MED(6),U) -"RTN","CCRMEDS1",76,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS1",77,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS1",78,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS1",79,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS1",80,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS1",81,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS1",82,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS1",83,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS1",84,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",85,0) - . ; Documented in the same manual. -"RTN","CCRMEDS1",86,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS1",87,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS1",88,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS1",89,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS1",90,0) - . N CONCDATA -"RTN","CCRMEDS1",91,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS1",92,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS1",93,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS1",94,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS1",95,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS1",96,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS1",97,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS1",98,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS1",99,0) - . S @MAP@("MEDQUANTITYVALUE")=MED(7) -"RTN","CCRMEDS1",100,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS1",101,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS1",102,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",103,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS1",104,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS1",105,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS1",106,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS1",107,0) - . ; -"RTN","CCRMEDS1",108,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS1",109,0) - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... -"RTN","CCRMEDS1",110,0) - . ; we want the compoenents. -"RTN","CCRMEDS1",111,0) - . ; It's in node 6 of ^PSRX(IEN) -"RTN","CCRMEDS1",112,0) - . ; So, here we go again -"RTN","CCRMEDS1",113,0) - . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE -"RTN","CCRMEDS1",114,0) - . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) -"RTN","CCRMEDS1",115,0) - . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE -"RTN","CCRMEDS1",116,0) - . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ -"RTN","CCRMEDS1",117,0) - . ; -"RTN","CCRMEDS1",118,0) - . N DIRNUM S DIRNUM=0 ; Sigline number -"RTN","CCRMEDS1",119,0) - . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS -"RTN","CCRMEDS1",120,0) - . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D -"RTN","CCRMEDS1",121,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS1",122,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS1",123,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS1",124,0) - . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) -"RTN","CCRMEDS1",125,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) -"RTN","CCRMEDS1",126,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) -"RTN","CCRMEDS1",127,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS1",128,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS1",129,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS1",130,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS1",131,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) -"RTN","CCRMEDS1",132,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) -"RTN","CCRMEDS1",133,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS1",134,0) - . . ; In the wisdom of the original programmers, the schedule is a free text field -"RTN","CCRMEDS1",135,0) - . . ; However, it gets translated by a call to the administration schedule file -"RTN","CCRMEDS1",136,0) - . . ; to see if that schedule exists. -"RTN","CCRMEDS1",137,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS1",138,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS1",139,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS1",140,0) - . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. -"RTN","CCRMEDS1",141,0) - . . ; So... -"RTN","CCRMEDS1",142,0) - . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") -"RTN","CCRMEDS1",143,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS1",144,0) - . . N INTERVAL -"RTN","CCRMEDS1",145,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS1",146,0) - . . E D -"RTN","CCRMEDS1",147,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS1",148,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS1",149,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS1",150,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS1",151,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) -"RTN","CCRMEDS1",152,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" -"RTN","CCRMEDS1",153,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" -"RTN","CCRMEDS1",154,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS1",155,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS1",156,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS1",157,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS1",158,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS1",159,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS1",160,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS1",161,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" -"RTN","CCRMEDS1",162,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS1",163,0) - . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) -"RTN","CCRMEDS1",164,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") -"RTN","CCRMEDS1",165,0) - . ; -"RTN","CCRMEDS1",166,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS1",167,0) - . ; -"RTN","CCRMEDS1",168,0) - . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" -"RTN","CCRMEDS1",169,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) -"RTN","CCRMEDS1",170,0) - . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" -"RTN","CCRMEDS1",171,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) -"RTN","CCRMEDS1",172,0) - . S @MAP@("MEDRFNO")=MED(9) -"RTN","CCRMEDS1",173,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS1",174,0) - . K @RESULT -"RTN","CCRMEDS1",175,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS1",176,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS1",177,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS1",178,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS1",179,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS1",180,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS1",181,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS1",182,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS1",183,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS1",184,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS1",185,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS1",186,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS1",187,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS1",188,0) - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS1",189,0) - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML -"RTN","CCRMEDS1",190,0) - N MEDTMP,MEDI -"RTN","CCRMEDS1",191,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS1",192,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS1",193,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS1",194,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS1",195,0) - Q -"RTN","CCRMEDS1",196,0) - ; -"RTN","CCRMEDS2") -0^11^B99730224 -"RTN","CCRMEDS2",1,0) -CCRMEDS2 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Pending Meds;08/24/08 -"RTN","CCRMEDS2",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 12 -"RTN","CCRMEDS2",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS2",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS2",5,0) - ; -"RTN","CCRMEDS2",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS2",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS2",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS2",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS2",10,0) - ; -"RTN","CCRMEDS2",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS2",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS2",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS2",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS2",15,0) - ; -"RTN","CCRMEDS2",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS2",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS2",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS2",19,0) - ; -"RTN","CCRMEDS2",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS2",21,0) - Q -"RTN","CCRMEDS2",22,0) - ; -"RTN","CCRMEDS2",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS2",24,0) - ; -"RTN","CCRMEDS2",25,0) - ; MINXML is the Input XML Template, passed by name -"RTN","CCRMEDS2",26,0) - ; DFN is Patient IEN -"RTN","CCRMEDS2",27,0) - ; OUTXML is the resultant XML. -"RTN","CCRMEDS2",28,0) - ; -"RTN","CCRMEDS2",29,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS2",30,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS2",31,0) - ; MED is holds each array element from MEDS, one medicine -"RTN","CCRMEDS2",32,0) - ; -"RTN","CCRMEDS2",33,0) - ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending -"RTN","CCRMEDS2",34,0) - ; meds data available. -"RTN","CCRMEDS2",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS2",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS2",37,0) - ; File for pending meds is 52.41 -"RTN","CCRMEDS2",38,0) - ; Unfortuantely, API does not supply us with any useful info beyond -"RTN","CCRMEDS2",39,0) - ; the IEN in 52.41, and the Med Name, and route. -"RTN","CCRMEDS2",40,0) - ; So, most of the info is going to get pulled from 52.41. -"RTN","CCRMEDS2",41,0) - N MEDS,MAP -"RTN","CCRMEDS2",42,0) - K ^TMP($J) -"RTN","CCRMEDS2",43,0) - D PEN^PSO5241(DFN,"CCDCCR") -"RTN","CCRMEDS2",44,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS2",45,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS2",46,0) - ; If it is -1, we quit. -"RTN","CCRMEDS2",47,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS2",48,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS2",49,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS2",50,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS2",51,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS2",52,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS2",53,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS2",54,0) - . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order -"RTN","CCRMEDS2",55,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS2",56,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS2",57,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS2",58,0) - . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN CCRMEDS -"RTN","CCRMEDS2",59,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS2",60,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS2",61,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS2",62,0) - . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS2",63,0) - . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN -"RTN","CCRMEDS2",64,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS2",65,0) - . ; Field 6 is "Effective date", and we pull it in timson format w/ I -"RTN","CCRMEDS2",66,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($$GET1^DIQ(52.41,RXIEN,6,"I")) -"RTN","CCRMEDS2",67,0) - . ; Med never filled; next 4 fields are not applicable. -"RTN","CCRMEDS2",68,0) - . S @MAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS2",69,0) - . S @MAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS2",70,0) - . S @MAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS2",71,0) - . S @MAP@("MEDRXNO")="" -"RTN","CCRMEDS2",72,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS2",73,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS2",74,0) - . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds -"RTN","CCRMEDS2",75,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") -"RTN","CCRMEDS2",76,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) -"RTN","CCRMEDS2",77,0) - . ; NDC not supplied in API, but is rather trivial to obtain -"RTN","CCRMEDS2",78,0) - . ; MED(11) piece 1 has the IEN of the drug (file 50) -"RTN","CCRMEDS2",79,0) - . ; IEN is field 31 in the drug file. -"RTN","CCRMEDS2",80,0) - . N MEDIEN S MEDIEN=$P(MED(11),U) -"RTN","CCRMEDS2",81,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$$GET1^DIQ(50,MEDIEN,31,"E") -"RTN","CCRMEDS2",82,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS2",83,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS2",84,0) - . S @MAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS2",85,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS2",86,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS2",87,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS2",88,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS2",89,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS2",90,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS2",91,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS2",92,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS2",93,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",94,0) - . ; Documented in the same manual. -"RTN","CCRMEDS2",95,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS2",96,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS2",97,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS2",98,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS2",99,0) - . N CONCDATA -"RTN","CCRMEDS2",100,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS2",101,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS2",102,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS2",103,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS2",104,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS2",105,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS2",106,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS2",107,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS2",108,0) - . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) -"RTN","CCRMEDS2",109,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS2",110,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS2",111,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",112,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS2",113,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS2",114,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS2",115,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS2",116,0) - . ; -"RTN","CCRMEDS2",117,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS2",118,0) - . ; Sig data is not in any API. We obtain it using the IEN from -"RTN","CCRMEDS2",119,0) - . ; the PEN API to file 52.41. It's in field 3, which is a multiple. -"RTN","CCRMEDS2",120,0) - . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) -"RTN","CCRMEDS2",121,0) - . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call -"RTN","CCRMEDS2",122,0) - . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") -"RTN","CCRMEDS2",123,0) - . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. -"RTN","CCRMEDS2",124,0) - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". -"RTN","CCRMEDS2",125,0) - . ; DIRNUM will be first piece for IEN. -"RTN","CCRMEDS2",126,0) - . ; DIRNUM is the proper Sigline numer. -"RTN","CCRMEDS2",127,0) - . ; SIGDATA is the simplfied array. Subscripts are really field numbers -"RTN","CCRMEDS2",128,0) - . ; in subfile 52.413. -"RTN","CCRMEDS2",129,0) - . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS -"RTN","CCRMEDS2",130,0) - . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D -"RTN","CCRMEDS2",131,0) - . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") -"RTN","CCRMEDS2",132,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS2",133,0) - . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) -"RTN","CCRMEDS2",134,0) - . . ; If this is an order for a refill; it's not really a new order; move on to next -"RTN","CCRMEDS2",135,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS2",136,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS2",137,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) -"RTN","CCRMEDS2",138,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) -"RTN","CCRMEDS2",139,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS2",140,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS2",141,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS2",142,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS2",143,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) -"RTN","CCRMEDS2",144,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) -"RTN","CCRMEDS2",145,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS2",146,0) - . . ; The schedule is a free text field -"RTN","CCRMEDS2",147,0) - . . ; However, it gets translated by a call to the administration -"RTN","CCRMEDS2",148,0) - . . ; schedule file to see if that schedule exists. -"RTN","CCRMEDS2",149,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS2",150,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS2",151,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS2",152,0) - . . ; I looked), PSSFT is the name, -"RTN","CCRMEDS2",153,0) - . . ; and list is the ^TMP name to store the data in. -"RTN","CCRMEDS2",154,0) - . . ; Also, freqency may have "PRN" in it, so strip that out -"RTN","CCRMEDS2",155,0) - . . N FREQ S FREQ=SIGDATA(1) -"RTN","CCRMEDS2",156,0) - . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp -"RTN","CCRMEDS2",157,0) - . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") -"RTN","CCRMEDS2",158,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS2",159,0) - . . N INTERVAL -"RTN","CCRMEDS2",160,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS2",161,0) - . . E D -"RTN","CCRMEDS2",162,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS2",163,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS2",164,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS2",165,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS2",166,0) - . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months -"RTN","CCRMEDS2",167,0) - . . N DUR S DUR=SIGDATA(2) -"RTN","CCRMEDS2",168,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) -"RTN","CCRMEDS2",169,0) - . . N DURUNIT S DURUNIT=$E(DUR) -"RTN","CCRMEDS2",170,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") -"RTN","CCRMEDS2",171,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" -"RTN","CCRMEDS2",172,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS2",173,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS2",174,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS2",175,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS2",176,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS2",177,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS2",178,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS2",179,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field -"RTN","CCRMEDS2",180,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS2",181,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) -"RTN","CCRMEDS2",182,0) - . ; -"RTN","CCRMEDS2",183,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS2",184,0) - . ; -"RTN","CCRMEDS2",185,0) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" -"RTN","CCRMEDS2",186,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL -"RTN","CCRMEDS2",187,0) - . ; W @MAP@("MEDPTINSTRUCTIONS"),! -"RTN","CCRMEDS2",188,0) - . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" -"RTN","CCRMEDS2",189,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL -"RTN","CCRMEDS2",190,0) - . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! -"RTN","CCRMEDS2",191,0) - . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) -"RTN","CCRMEDS2",192,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS2",193,0) - . K @RESULT -"RTN","CCRMEDS2",194,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS2",195,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS2",196,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS2",197,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS2",198,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS2",199,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS2",200,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS2",201,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS2",202,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS2",203,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS2",204,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS2",205,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS2",206,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS2",207,0) - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS2",208,0) - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML -"RTN","CCRMEDS2",209,0) - N MEDTMP,MEDI -"RTN","CCRMEDS2",210,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS2",211,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS2",212,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS2",213,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS2",214,0) - Q -"RTN","CCRMEDS2",215,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 12 -"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 12 -"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 12 -"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 12 -"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^16^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 12 -"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","GPLALERT") -0^19^B13662473 -"RTN","GPLALERT",1,0) -GPLALERT ; CCDCCR/CKU - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 -"RTN","GPLALERT",2,0) - ;;0.1;CCDCCR;;SEP 11,2008;Build 12 -"RTN","GPLALERT",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","GPLALERT",4,0) - ;General Public License See attached copy of the License. -"RTN","GPLALERT",5,0) - ; -"RTN","GPLALERT",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","GPLALERT",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","GPLALERT",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","GPLALERT",9,0) - ;(at your option) any later version. -"RTN","GPLALERT",10,0) - ; -"RTN","GPLALERT",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","GPLALERT",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","GPLALERT",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","GPLALERT",14,0) - ;GNU General Public License for more details. -"RTN","GPLALERT",15,0) - ; -"RTN","GPLALERT",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","GPLALERT",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","GPLALERT",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","GPLALERT",19,0) - ; -"RTN","GPLALERT",20,0) - W "NO ENTRY FROM TOP",! -"RTN","GPLALERT",21,0) - Q -"RTN","GPLALERT",22,0) - ; -"RTN","GPLALERT",23,0) -EXTRACT(ALTXML,DFN,ALTOUTXML) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE -"RTN","GPLALERT",24,0) - ; -"RTN","GPLALERT",25,0) - ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","GPLALERT",26,0) - ; -"RTN","GPLALERT",27,0) - ; GET ADVERSE REACTIONS AND ALLERGIES -"RTN","GPLALERT",28,0) - N GMRA,GMRAL S GMRA="0^0^111" -"RTN","GPLALERT",29,0) - D EN1^GMRADPT -"RTN","GPLALERT",30,0) - I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* -"RTN","GPLALERT",31,0) - . S @ALTOUTXML@(0)=0 -"RTN","GPLALERT",32,0) - -"RTN","GPLALERT",33,0) - ; DEFINE MAPPING -"RTN","GPLALERT",34,0) - N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP -"RTN","GPLALERT",35,0) - S ALTTVMAP=$NA(^TMP("GPLALERT",$J,"ALERTS")) -"RTN","GPLALERT",36,0) - S ALTTARYTMP=$NA(^TMP("GPLALERT",$J,"ALERTSARYTMP")) -"RTN","GPLALERT",37,0) - K @ALTTVMAP,@ALTTARYTMP -"RTN","GPLALERT",38,0) - N ALTTMP,ALTCNT S ALTTMP=$NA(GMRAL),ALTCNT=1 -"RTN","GPLALERT",39,0) - F S ALTTMP=$Q(@ALTTMP) Q:ALTTMP="" D -"RTN","GPLALERT",40,0) - . I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q -"RTN","GPLALERT",41,0) - . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) -"RTN","GPLALERT",42,0) - . K @ALTVMAP -"RTN","GPLALERT",43,0) - . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT -"RTN","GPLALERT",44,0) - . N ALERTDESCRIPTIONTEXT S ALERTDESCRIPTIONTEXT="Patient has an " ; X $ZINT H 5 -"RTN","GPLALERT",45,0) - . S ALERTDESCRIPTIONTEXT=ALERTDESCRIPTIONTEXT_$S($P(@ALTTMP,U,4)=1:"ADVERSE",$P(@ALTTMP,U,5)=1:"ALLERGIC",1:"UNKNOWN") -"RTN","GPLALERT",46,0) - . S ALERTDESCRIPTIONTEXT=ALERTDESCRIPTIONTEXT_" reaction to "_$P(@ALTTMP,U,2)_"." -"RTN","GPLALERT",47,0) - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ALERTDESCRIPTIONTEXT -"RTN","GPLALERT",48,0) - . S @ALTVMAP@("ALERTCODEVALUE")="ALERT CODE VALUE" -"RTN","GPLALERT",49,0) - . S @ALTVMAP@("ALERTCODESYSTEM")="ALERT CODE SYSTEM" -"RTN","GPLALERT",50,0) - . S @ALTVMAP@("ALERTSTATUSTEXT")="ALERT STATUS TEXT" -"RTN","GPLALERT",51,0) - . S @ALTVMAP@("ALERTSOURCEID")="ALERT SOURCE ID" -"RTN","GPLALERT",52,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="ALERT AGENT PRODUCT OBJECT ID" -"RTN","GPLALERT",53,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="A" -"RTN","GPLALERT",54,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")="B" -"RTN","GPLALERT",55,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="C" -"RTN","GPLALERT",56,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="D" -"RTN","GPLALERT",57,0) - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) -"RTN","GPLALERT",58,0) - . K @ALTARYTMP -"RTN","GPLALERT",59,0) - . D MAP^GPLXPATH(ALTXML,ALTVMAP,ALTARYTMP) -"RTN","GPLALERT",60,0) - . I ALTCNT=1 D CP^GPLXPATH(ALTARYTMP,ALTOUTXML) -"RTN","GPLALERT",61,0) - . I ALTCNT>1 D INSINNER^GPLXPATH(ALTOUTXML,ALTARYTMP) -"RTN","GPLALERT",62,0) - . S ALTCNT=ALTCNT+1 -"RTN","GPLALERT",63,0) - -"RTN","GPLALERT",64,0) - Q -"RTN","GPLALERT",65,0) - -"RTN","GPLCCD") -0^8^B114413975 -"RTN","GPLCCD",1,0) -GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 -"RTN","GPLCCD",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 12 -"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^15^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 12 -"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^13^B82192762 -"RTN","GPLCCR",1,0) -GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 -"RTN","GPLCCR",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 12 -"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^14^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 12 -"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","GPLPROBS") -0^20^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 12 -"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^18^B214212612 -"RTN","GPLRIMA",1,0) -GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 -"RTN","GPLRIMA",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 12 -"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^12^B31438520 -"RTN","GPLUNIT",1,0) -GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 -"RTN","GPLUNIT",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 12 -"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^17^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 12 -"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^21^B50983429 -"RTN","GPLXPAT0",1,0) -GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 -"RTN","GPLXPAT0",2,0) - ;;0.2;CCDCCR;nopatch;noreleasedate;Build 12 -"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 12 -"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** Index: ccr/trunk/p/CCR_1_0_5_T6_CACHE.KID =================================================================== --- ccr/trunk/p/CCR_1_0_5_T6_CACHE.KID (revision 549) +++ (revision ) @@ -1,9700 +1,0 @@ -KIDS Distribution saved on Oct 10, 2008@15:06:02 -fix for false multiple patients in ACTORS -**KIDS**:CCR*1.0*5^ - -**INSTALL NAME** -CCR*1.0*5 -"BLD",6955,0) -CCR*1.0*5^^0^3081010^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) -13 -"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^21^21 -"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) -GPLCCD^^0^B114413975 -"BLD",6955,"KRN",9.8,"NM",9,0) -GPLXPATH^^0^B241520746 -"BLD",6955,"KRN",9.8,"NM",10,0) -CCRMEDS1^^0^B80043311 -"BLD",6955,"KRN",9.8,"NM",11,0) -CCRMEDS2^^0^B99730224 -"BLD",6955,"KRN",9.8,"NM",12,0) -GPLUNIT^^0^B31438520 -"BLD",6955,"KRN",9.8,"NM",13,0) -GPLCCR^^0^B82192762 -"BLD",6955,"KRN",9.8,"NM",14,0) -GPLCCR0^^0^B654252455 -"BLD",6955,"KRN",9.8,"NM",15,0) -GPLCCD1^^0^B100039732 -"BLD",6955,"KRN",9.8,"NM",16,0) -GPLACTOR^^0^B52628160 -"BLD",6955,"KRN",9.8,"NM",17,0) -GPLVITAL^^0^B82628966 -"BLD",6955,"KRN",9.8,"NM",18,0) -GPLRIMA^^0^B214212612 -"BLD",6955,"KRN",9.8,"NM",19,0) -GPLALERT^^0^B13662473 -"BLD",6955,"KRN",9.8,"NM",20,0) -GPLPROBS^^0^B25875394 -"BLD",6955,"KRN",9.8,"NM",21,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","CCRMEDS1",10) - -"BLD",6955,"KRN",9.8,"NM","B","CCRMEDS2",11) - -"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",16) - -"BLD",6955,"KRN",9.8,"NM","B","GPLALERT",19) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD",8) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD1",15) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR",13) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR0",14) - -"BLD",6955,"KRN",9.8,"NM","B","GPLPROBS",20) - -"BLD",6955,"KRN",9.8,"NM","B","GPLRIMA",18) - -"BLD",6955,"KRN",9.8,"NM","B","GPLUNIT",12) - -"BLD",6955,"KRN",9.8,"NM","B","GPLVITAL",17) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPAT0",21) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPATH",9) - -"BLD",6955,"KRN",19,0) -19 -"BLD",6955,"KRN",19,"NM",0) -^9.68A^^ -"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") -21 -"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 13 -"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 13 -"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 13 -"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","CCRMEDS1") -0^10^B80043311 -"RTN","CCRMEDS1",1,0) -CCRMEDS ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;08/24/08 -"RTN","CCRMEDS1",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 13 -"RTN","CCRMEDS1",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS1",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS1",5,0) - ; -"RTN","CCRMEDS1",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS1",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS1",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS1",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS1",10,0) - ; -"RTN","CCRMEDS1",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS1",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS1",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS1",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS1",15,0) - ; -"RTN","CCRMEDS1",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS1",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS1",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS1",19,0) - ; -"RTN","CCRMEDS1",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS1",21,0) - Q -"RTN","CCRMEDS1",22,0) - ; -"RTN","CCRMEDS1",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS1",24,0) - ; -"RTN","CCRMEDS1",25,0) - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","CCRMEDS1",26,0) - ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE -"RTN","CCRMEDS1",27,0) - ; -"RTN","CCRMEDS1",28,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS1",29,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS1",30,0) - ; MED is holds each array element from MEDS(J), one medicine -"RTN","CCRMEDS1",31,0) - ; J is a counter. -"RTN","CCRMEDS1",32,0) - ; -"RTN","CCRMEDS1",33,0) - ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all -"RTN","CCRMEDS1",34,0) - ; med data available. -"RTN","CCRMEDS1",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS1",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS1",37,0) - ; D PARY^GPLXPATH(MINXML) -"RTN","CCRMEDS1",38,0) - N MEDS,MAP -"RTN","CCRMEDS1",39,0) - K ^TMP($J) -"RTN","CCRMEDS1",40,0) - D RX^PSO52API(DFN,"CCDCCR") -"RTN","CCRMEDS1",41,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS1",42,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS1",43,0) - ; If it is -1, we quit. -"RTN","CCRMEDS1",44,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS1",45,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS1",46,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS1",47,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS1",48,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS1",49,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS1",50,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS1",51,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS1",52,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS1",53,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS1",54,0) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN CCRMEDS -"RTN","CCRMEDS1",55,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS1",56,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS1",57,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS1",58,0) - . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS1",59,0) - . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number -"RTN","CCRMEDS1",60,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS1",61,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($P(MED(1),U)) -"RTN","CCRMEDS1",62,0) - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" -"RTN","CCRMEDS1",63,0) - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^CCRUTIL($P(MED(101),U)) -"RTN","CCRMEDS1",64,0) - . S @MAP@("MEDRXNOTXT")="Prescription Number" -"RTN","CCRMEDS1",65,0) - . S @MAP@("MEDRXNO")=MED(.01) -"RTN","CCRMEDS1",66,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS1",67,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS1",68,0) - . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) -"RTN","CCRMEDS1",69,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) -"RTN","CCRMEDS1",70,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) -"RTN","CCRMEDS1",71,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=MED(27) -"RTN","CCRMEDS1",72,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS1",73,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS1",74,0) - . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) -"RTN","CCRMEDS1",75,0) - . N MEDIEN S MEDIEN=$P(MED(6),U) -"RTN","CCRMEDS1",76,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS1",77,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS1",78,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS1",79,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS1",80,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS1",81,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS1",82,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS1",83,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS1",84,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",85,0) - . ; Documented in the same manual. -"RTN","CCRMEDS1",86,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS1",87,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS1",88,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS1",89,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS1",90,0) - . N CONCDATA -"RTN","CCRMEDS1",91,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS1",92,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS1",93,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS1",94,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS1",95,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS1",96,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS1",97,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS1",98,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS1",99,0) - . S @MAP@("MEDQUANTITYVALUE")=MED(7) -"RTN","CCRMEDS1",100,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS1",101,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS1",102,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",103,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS1",104,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS1",105,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS1",106,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS1",107,0) - . ; -"RTN","CCRMEDS1",108,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS1",109,0) - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... -"RTN","CCRMEDS1",110,0) - . ; we want the compoenents. -"RTN","CCRMEDS1",111,0) - . ; It's in node 6 of ^PSRX(IEN) -"RTN","CCRMEDS1",112,0) - . ; So, here we go again -"RTN","CCRMEDS1",113,0) - . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE -"RTN","CCRMEDS1",114,0) - . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) -"RTN","CCRMEDS1",115,0) - . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE -"RTN","CCRMEDS1",116,0) - . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ -"RTN","CCRMEDS1",117,0) - . ; -"RTN","CCRMEDS1",118,0) - . N DIRNUM S DIRNUM=0 ; Sigline number -"RTN","CCRMEDS1",119,0) - . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS -"RTN","CCRMEDS1",120,0) - . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D -"RTN","CCRMEDS1",121,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS1",122,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS1",123,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS1",124,0) - . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) -"RTN","CCRMEDS1",125,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) -"RTN","CCRMEDS1",126,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) -"RTN","CCRMEDS1",127,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS1",128,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS1",129,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS1",130,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS1",131,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) -"RTN","CCRMEDS1",132,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) -"RTN","CCRMEDS1",133,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS1",134,0) - . . ; In the wisdom of the original programmers, the schedule is a free text field -"RTN","CCRMEDS1",135,0) - . . ; However, it gets translated by a call to the administration schedule file -"RTN","CCRMEDS1",136,0) - . . ; to see if that schedule exists. -"RTN","CCRMEDS1",137,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS1",138,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS1",139,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS1",140,0) - . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. -"RTN","CCRMEDS1",141,0) - . . ; So... -"RTN","CCRMEDS1",142,0) - . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") -"RTN","CCRMEDS1",143,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS1",144,0) - . . N INTERVAL -"RTN","CCRMEDS1",145,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS1",146,0) - . . E D -"RTN","CCRMEDS1",147,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS1",148,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS1",149,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS1",150,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS1",151,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) -"RTN","CCRMEDS1",152,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" -"RTN","CCRMEDS1",153,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" -"RTN","CCRMEDS1",154,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS1",155,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS1",156,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS1",157,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS1",158,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS1",159,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS1",160,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS1",161,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" -"RTN","CCRMEDS1",162,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS1",163,0) - . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) -"RTN","CCRMEDS1",164,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") -"RTN","CCRMEDS1",165,0) - . ; -"RTN","CCRMEDS1",166,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS1",167,0) - . ; -"RTN","CCRMEDS1",168,0) - . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" -"RTN","CCRMEDS1",169,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) -"RTN","CCRMEDS1",170,0) - . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" -"RTN","CCRMEDS1",171,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) -"RTN","CCRMEDS1",172,0) - . S @MAP@("MEDRFNO")=MED(9) -"RTN","CCRMEDS1",173,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS1",174,0) - . K @RESULT -"RTN","CCRMEDS1",175,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS1",176,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS1",177,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS1",178,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS1",179,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS1",180,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS1",181,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS1",182,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS1",183,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS1",184,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS1",185,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS1",186,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS1",187,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS1",188,0) - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS1",189,0) - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML -"RTN","CCRMEDS1",190,0) - N MEDTMP,MEDI -"RTN","CCRMEDS1",191,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS1",192,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS1",193,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS1",194,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS1",195,0) - Q -"RTN","CCRMEDS1",196,0) - ; -"RTN","CCRMEDS2") -0^11^B99730224 -"RTN","CCRMEDS2",1,0) -CCRMEDS2 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Pending Meds;08/24/08 -"RTN","CCRMEDS2",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 13 -"RTN","CCRMEDS2",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS2",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS2",5,0) - ; -"RTN","CCRMEDS2",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS2",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS2",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS2",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS2",10,0) - ; -"RTN","CCRMEDS2",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS2",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS2",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS2",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS2",15,0) - ; -"RTN","CCRMEDS2",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS2",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS2",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS2",19,0) - ; -"RTN","CCRMEDS2",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS2",21,0) - Q -"RTN","CCRMEDS2",22,0) - ; -"RTN","CCRMEDS2",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS2",24,0) - ; -"RTN","CCRMEDS2",25,0) - ; MINXML is the Input XML Template, passed by name -"RTN","CCRMEDS2",26,0) - ; DFN is Patient IEN -"RTN","CCRMEDS2",27,0) - ; OUTXML is the resultant XML. -"RTN","CCRMEDS2",28,0) - ; -"RTN","CCRMEDS2",29,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS2",30,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS2",31,0) - ; MED is holds each array element from MEDS, one medicine -"RTN","CCRMEDS2",32,0) - ; -"RTN","CCRMEDS2",33,0) - ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending -"RTN","CCRMEDS2",34,0) - ; meds data available. -"RTN","CCRMEDS2",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS2",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS2",37,0) - ; File for pending meds is 52.41 -"RTN","CCRMEDS2",38,0) - ; Unfortuantely, API does not supply us with any useful info beyond -"RTN","CCRMEDS2",39,0) - ; the IEN in 52.41, and the Med Name, and route. -"RTN","CCRMEDS2",40,0) - ; So, most of the info is going to get pulled from 52.41. -"RTN","CCRMEDS2",41,0) - N MEDS,MAP -"RTN","CCRMEDS2",42,0) - K ^TMP($J) -"RTN","CCRMEDS2",43,0) - D PEN^PSO5241(DFN,"CCDCCR") -"RTN","CCRMEDS2",44,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS2",45,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS2",46,0) - ; If it is -1, we quit. -"RTN","CCRMEDS2",47,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS2",48,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS2",49,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS2",50,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS2",51,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS2",52,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS2",53,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS2",54,0) - . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order -"RTN","CCRMEDS2",55,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS2",56,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS2",57,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS2",58,0) - . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN CCRMEDS -"RTN","CCRMEDS2",59,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS2",60,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS2",61,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS2",62,0) - . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS2",63,0) - . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN -"RTN","CCRMEDS2",64,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS2",65,0) - . ; Field 6 is "Effective date", and we pull it in timson format w/ I -"RTN","CCRMEDS2",66,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($$GET1^DIQ(52.41,RXIEN,6,"I")) -"RTN","CCRMEDS2",67,0) - . ; Med never filled; next 4 fields are not applicable. -"RTN","CCRMEDS2",68,0) - . S @MAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS2",69,0) - . S @MAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS2",70,0) - . S @MAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS2",71,0) - . S @MAP@("MEDRXNO")="" -"RTN","CCRMEDS2",72,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS2",73,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS2",74,0) - . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds -"RTN","CCRMEDS2",75,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") -"RTN","CCRMEDS2",76,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) -"RTN","CCRMEDS2",77,0) - . ; NDC not supplied in API, but is rather trivial to obtain -"RTN","CCRMEDS2",78,0) - . ; MED(11) piece 1 has the IEN of the drug (file 50) -"RTN","CCRMEDS2",79,0) - . ; IEN is field 31 in the drug file. -"RTN","CCRMEDS2",80,0) - . N MEDIEN S MEDIEN=$P(MED(11),U) -"RTN","CCRMEDS2",81,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$$GET1^DIQ(50,MEDIEN,31,"E") -"RTN","CCRMEDS2",82,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS2",83,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS2",84,0) - . S @MAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS2",85,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS2",86,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS2",87,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS2",88,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS2",89,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS2",90,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS2",91,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS2",92,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS2",93,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",94,0) - . ; Documented in the same manual. -"RTN","CCRMEDS2",95,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS2",96,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS2",97,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS2",98,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS2",99,0) - . N CONCDATA -"RTN","CCRMEDS2",100,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS2",101,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS2",102,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS2",103,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS2",104,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS2",105,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS2",106,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS2",107,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS2",108,0) - . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) -"RTN","CCRMEDS2",109,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS2",110,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS2",111,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",112,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS2",113,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS2",114,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS2",115,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS2",116,0) - . ; -"RTN","CCRMEDS2",117,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS2",118,0) - . ; Sig data is not in any API. We obtain it using the IEN from -"RTN","CCRMEDS2",119,0) - . ; the PEN API to file 52.41. It's in field 3, which is a multiple. -"RTN","CCRMEDS2",120,0) - . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) -"RTN","CCRMEDS2",121,0) - . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call -"RTN","CCRMEDS2",122,0) - . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") -"RTN","CCRMEDS2",123,0) - . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. -"RTN","CCRMEDS2",124,0) - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". -"RTN","CCRMEDS2",125,0) - . ; DIRNUM will be first piece for IEN. -"RTN","CCRMEDS2",126,0) - . ; DIRNUM is the proper Sigline numer. -"RTN","CCRMEDS2",127,0) - . ; SIGDATA is the simplfied array. Subscripts are really field numbers -"RTN","CCRMEDS2",128,0) - . ; in subfile 52.413. -"RTN","CCRMEDS2",129,0) - . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS -"RTN","CCRMEDS2",130,0) - . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D -"RTN","CCRMEDS2",131,0) - . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") -"RTN","CCRMEDS2",132,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS2",133,0) - . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) -"RTN","CCRMEDS2",134,0) - . . ; If this is an order for a refill; it's not really a new order; move on to next -"RTN","CCRMEDS2",135,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS2",136,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS2",137,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) -"RTN","CCRMEDS2",138,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) -"RTN","CCRMEDS2",139,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS2",140,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS2",141,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS2",142,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS2",143,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) -"RTN","CCRMEDS2",144,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) -"RTN","CCRMEDS2",145,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS2",146,0) - . . ; The schedule is a free text field -"RTN","CCRMEDS2",147,0) - . . ; However, it gets translated by a call to the administration -"RTN","CCRMEDS2",148,0) - . . ; schedule file to see if that schedule exists. -"RTN","CCRMEDS2",149,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS2",150,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS2",151,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS2",152,0) - . . ; I looked), PSSFT is the name, -"RTN","CCRMEDS2",153,0) - . . ; and list is the ^TMP name to store the data in. -"RTN","CCRMEDS2",154,0) - . . ; Also, freqency may have "PRN" in it, so strip that out -"RTN","CCRMEDS2",155,0) - . . N FREQ S FREQ=SIGDATA(1) -"RTN","CCRMEDS2",156,0) - . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp -"RTN","CCRMEDS2",157,0) - . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") -"RTN","CCRMEDS2",158,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS2",159,0) - . . N INTERVAL -"RTN","CCRMEDS2",160,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS2",161,0) - . . E D -"RTN","CCRMEDS2",162,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS2",163,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS2",164,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS2",165,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS2",166,0) - . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months -"RTN","CCRMEDS2",167,0) - . . N DUR S DUR=SIGDATA(2) -"RTN","CCRMEDS2",168,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) -"RTN","CCRMEDS2",169,0) - . . N DURUNIT S DURUNIT=$E(DUR) -"RTN","CCRMEDS2",170,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") -"RTN","CCRMEDS2",171,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" -"RTN","CCRMEDS2",172,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS2",173,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS2",174,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS2",175,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS2",176,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS2",177,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS2",178,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS2",179,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field -"RTN","CCRMEDS2",180,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS2",181,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) -"RTN","CCRMEDS2",182,0) - . ; -"RTN","CCRMEDS2",183,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS2",184,0) - . ; -"RTN","CCRMEDS2",185,0) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" -"RTN","CCRMEDS2",186,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL -"RTN","CCRMEDS2",187,0) - . ; W @MAP@("MEDPTINSTRUCTIONS"),! -"RTN","CCRMEDS2",188,0) - . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" -"RTN","CCRMEDS2",189,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL -"RTN","CCRMEDS2",190,0) - . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! -"RTN","CCRMEDS2",191,0) - . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) -"RTN","CCRMEDS2",192,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS2",193,0) - . K @RESULT -"RTN","CCRMEDS2",194,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS2",195,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS2",196,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS2",197,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS2",198,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS2",199,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS2",200,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS2",201,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS2",202,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS2",203,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS2",204,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS2",205,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS2",206,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS2",207,0) - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS2",208,0) - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML -"RTN","CCRMEDS2",209,0) - N MEDTMP,MEDI -"RTN","CCRMEDS2",210,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS2",211,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS2",212,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS2",213,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS2",214,0) - Q -"RTN","CCRMEDS2",215,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 13 -"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 13 -"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 13 -"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 13 -"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^16^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 13 -"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","GPLALERT") -0^19^B13662473 -"RTN","GPLALERT",1,0) -GPLALERT ; CCDCCR/CKU - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 -"RTN","GPLALERT",2,0) - ;;0.1;CCDCCR;;SEP 11,2008;Build 13 -"RTN","GPLALERT",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","GPLALERT",4,0) - ;General Public License See attached copy of the License. -"RTN","GPLALERT",5,0) - ; -"RTN","GPLALERT",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","GPLALERT",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","GPLALERT",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","GPLALERT",9,0) - ;(at your option) any later version. -"RTN","GPLALERT",10,0) - ; -"RTN","GPLALERT",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","GPLALERT",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","GPLALERT",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","GPLALERT",14,0) - ;GNU General Public License for more details. -"RTN","GPLALERT",15,0) - ; -"RTN","GPLALERT",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","GPLALERT",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","GPLALERT",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","GPLALERT",19,0) - ; -"RTN","GPLALERT",20,0) - W "NO ENTRY FROM TOP",! -"RTN","GPLALERT",21,0) - Q -"RTN","GPLALERT",22,0) - ; -"RTN","GPLALERT",23,0) -EXTRACT(ALTXML,DFN,ALTOUTXML) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE -"RTN","GPLALERT",24,0) - ; -"RTN","GPLALERT",25,0) - ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","GPLALERT",26,0) - ; -"RTN","GPLALERT",27,0) - ; GET ADVERSE REACTIONS AND ALLERGIES -"RTN","GPLALERT",28,0) - N GMRA,GMRAL S GMRA="0^0^111" -"RTN","GPLALERT",29,0) - D EN1^GMRADPT -"RTN","GPLALERT",30,0) - I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* -"RTN","GPLALERT",31,0) - . S @ALTOUTXML@(0)=0 -"RTN","GPLALERT",32,0) - -"RTN","GPLALERT",33,0) - ; DEFINE MAPPING -"RTN","GPLALERT",34,0) - N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP -"RTN","GPLALERT",35,0) - S ALTTVMAP=$NA(^TMP("GPLALERT",$J,"ALERTS")) -"RTN","GPLALERT",36,0) - S ALTTARYTMP=$NA(^TMP("GPLALERT",$J,"ALERTSARYTMP")) -"RTN","GPLALERT",37,0) - K @ALTTVMAP,@ALTTARYTMP -"RTN","GPLALERT",38,0) - N ALTTMP,ALTCNT S ALTTMP=$NA(GMRAL),ALTCNT=1 -"RTN","GPLALERT",39,0) - F S ALTTMP=$Q(@ALTTMP) Q:ALTTMP="" D -"RTN","GPLALERT",40,0) - . I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q -"RTN","GPLALERT",41,0) - . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) -"RTN","GPLALERT",42,0) - . K @ALTVMAP -"RTN","GPLALERT",43,0) - . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT -"RTN","GPLALERT",44,0) - . N ALERTDESCRIPTIONTEXT S ALERTDESCRIPTIONTEXT="Patient has an " ; X $ZINT H 5 -"RTN","GPLALERT",45,0) - . S ALERTDESCRIPTIONTEXT=ALERTDESCRIPTIONTEXT_$S($P(@ALTTMP,U,4)=1:"ADVERSE",$P(@ALTTMP,U,5)=1:"ALLERGIC",1:"UNKNOWN") -"RTN","GPLALERT",46,0) - . S ALERTDESCRIPTIONTEXT=ALERTDESCRIPTIONTEXT_" reaction to "_$P(@ALTTMP,U,2)_"." -"RTN","GPLALERT",47,0) - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ALERTDESCRIPTIONTEXT -"RTN","GPLALERT",48,0) - . S @ALTVMAP@("ALERTCODEVALUE")="ALERT CODE VALUE" -"RTN","GPLALERT",49,0) - . S @ALTVMAP@("ALERTCODESYSTEM")="ALERT CODE SYSTEM" -"RTN","GPLALERT",50,0) - . S @ALTVMAP@("ALERTSTATUSTEXT")="ALERT STATUS TEXT" -"RTN","GPLALERT",51,0) - . S @ALTVMAP@("ALERTSOURCEID")="ALERT SOURCE ID" -"RTN","GPLALERT",52,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="ALERT AGENT PRODUCT OBJECT ID" -"RTN","GPLALERT",53,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="A" -"RTN","GPLALERT",54,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")="B" -"RTN","GPLALERT",55,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="C" -"RTN","GPLALERT",56,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="D" -"RTN","GPLALERT",57,0) - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) -"RTN","GPLALERT",58,0) - . K @ALTARYTMP -"RTN","GPLALERT",59,0) - . D MAP^GPLXPATH(ALTXML,ALTVMAP,ALTARYTMP) -"RTN","GPLALERT",60,0) - . I ALTCNT=1 D CP^GPLXPATH(ALTARYTMP,ALTOUTXML) -"RTN","GPLALERT",61,0) - . I ALTCNT>1 D INSINNER^GPLXPATH(ALTOUTXML,ALTARYTMP) -"RTN","GPLALERT",62,0) - . S ALTCNT=ALTCNT+1 -"RTN","GPLALERT",63,0) - -"RTN","GPLALERT",64,0) - Q -"RTN","GPLALERT",65,0) - -"RTN","GPLCCD") -0^8^B114413975 -"RTN","GPLCCD",1,0) -GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 -"RTN","GPLCCD",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 13 -"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^15^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 13 -"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^13^B82192762 -"RTN","GPLCCR",1,0) -GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 -"RTN","GPLCCR",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 13 -"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^14^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 13 -"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","GPLPROBS") -0^20^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 13 -"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^18^B214212612 -"RTN","GPLRIMA",1,0) -GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 -"RTN","GPLRIMA",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 13 -"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^12^B31438520 -"RTN","GPLUNIT",1,0) -GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 -"RTN","GPLUNIT",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 13 -"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^17^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 13 -"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^21^B50983429 -"RTN","GPLXPAT0",1,0) -GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 -"RTN","GPLXPAT0",2,0) - ;;0.2;CCDCCR;nopatch;noreleasedate;Build 13 -"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 13 -"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** Index: ccr/trunk/p/CCR_1_0_6_T1_CACHE.KID =================================================================== --- ccr/trunk/p/CCR_1_0_6_T1_CACHE.KID (revision 549) +++ (revision ) @@ -1,10942 +1,0 @@ -KIDS Distribution saved on Nov 03, 2008@16:18:23 -Alerts and Non-VA Meds. Lab display -**KIDS**:CCR*1.0*6^ - -**INSTALL NAME** -CCR*1.0*6 -"BLD",6955,0) -CCR*1.0*6^^0^3081103^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) -14 -"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^24^24 -"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^B68553972 -"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^B11670240 -"BLD",6955,"KRN",9.8,"NM",7,0) -CCRVA200^^0^B35847405 -"BLD",6955,"KRN",9.8,"NM",8,0) -GPLCCD^^0^B114413975 -"BLD",6955,"KRN",9.8,"NM",9,0) -GPLXPATH^^0^B242640815 -"BLD",6955,"KRN",9.8,"NM",10,0) -CCRMEDS1^^0^B80043311 -"BLD",6955,"KRN",9.8,"NM",11,0) -CCRMEDS2^^0^B101302627 -"BLD",6955,"KRN",9.8,"NM",12,0) -GPLUNIT^^0^B31438520 -"BLD",6955,"KRN",9.8,"NM",13,0) -GPLCCR^^0^B81968343 -"BLD",6955,"KRN",9.8,"NM",14,0) -GPLCCR0^^0^B654420916 -"BLD",6955,"KRN",9.8,"NM",15,0) -GPLCCD1^^0^B100039732 -"BLD",6955,"KRN",9.8,"NM",16,0) -GPLACTOR^^0^B53216743 -"BLD",6955,"KRN",9.8,"NM",17,0) -GPLVITAL^^0^B82628966 -"BLD",6955,"KRN",9.8,"NM",18,0) -GPLRIMA^^0^B228265839 -"BLD",6955,"KRN",9.8,"NM",19,0) -GPLALERT^^0^B22007040 -"BLD",6955,"KRN",9.8,"NM",20,0) -GPLPROBS^^0^B25875394 -"BLD",6955,"KRN",9.8,"NM",21,0) -GPLXPAT0^^0^B51026779 -"BLD",6955,"KRN",9.8,"NM",22,0) -GPLLABS^^0^B74153607 -"BLD",6955,"KRN",9.8,"NM",23,0) -LA7QRY1^^0^B12511401 -"BLD",6955,"KRN",9.8,"NM",24,0) -CCRMEDS3^^0^B68176928 -"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","CCRMEDS1",10) - -"BLD",6955,"KRN",9.8,"NM","B","CCRMEDS2",11) - -"BLD",6955,"KRN",9.8,"NM","B","CCRMEDS3",24) - -"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",16) - -"BLD",6955,"KRN",9.8,"NM","B","GPLALERT",19) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD",8) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD1",15) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR",13) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR0",14) - -"BLD",6955,"KRN",9.8,"NM","B","GPLLABS",22) - -"BLD",6955,"KRN",9.8,"NM","B","GPLPROBS",20) - -"BLD",6955,"KRN",9.8,"NM","B","GPLRIMA",18) - -"BLD",6955,"KRN",9.8,"NM","B","GPLUNIT",12) - -"BLD",6955,"KRN",9.8,"NM","B","GPLVITAL",17) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPAT0",21) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPATH",9) - -"BLD",6955,"KRN",9.8,"NM","B","LA7QRY1",23) - -"BLD",6955,"KRN",19,0) -19 -"BLD",6955,"KRN",19,"NM",0) -^9.68A^^ -"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") -24 -"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 14 -"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 14 -"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^B68553972 -"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 14 -"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 PENDINGXML,MEDPENDING -"RTN","CCRMEDS",58,0) - S PENDINGXML="MEDPENDING" ;NAME FOR ARRAY -"RTN","CCRMEDS",59,0) - D EXTRACT^CCRMEDS3(MEDXML,DFN,PENDINGXML) ; FIRST EXTRACT OUTPATIENT MEDS -"RTN","CCRMEDS",60,0) - I @PENDINGXML@(0)>0 D ; CCRMEDS FOUND PENDING OP MEDS -"RTN","CCRMEDS",61,0) - . ; S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML -"RTN","CCRMEDS",62,0) - . I @MEDOUTXML@(0)>0 D ; IF WE NEED TO COMBINE MEDS -"RTN","CCRMEDS",63,0) - . . D INSINNER^GPLXPATH(MEDOUTXML,PENDINGXML) ;ADD NON-VA TO MEDS -"RTN","CCRMEDS",64,0) - . E D CP^GPLXPATH(PENDINGXML,MEDOUTXML) ; NO PREVIOUS MEDS, JUST COPY -"RTN","CCRMEDS",65,0) - . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP -"RTN","CCRMEDS",66,0) - . ; W MEDCNT,! -"RTN","CCRMEDS",67,0) - . W "HAS NON-VA MEDS",! -"RTN","CCRMEDS",68,0) -THEND ; -"RTN","CCRMEDS",69,0) - Q ; SKIPPING ALL THE REST OF THIS LOGIC.. IT IS NOT GOING TO BE NEEDED -"RTN","CCRMEDS",70,0) - ; ONCE NON-VA AND IP MEDS WORK (CCRMEDS3 AND CCRMEDS4) -"RTN","CCRMEDS",71,0) - N MEDRSLT,I,J,K,MEDPTMP,X,MEDVMAP,TBUF -"RTN","CCRMEDS",72,0) - D ACTIVE^ORWPS(.MEDRSLT,DFN) -"RTN","CCRMEDS",73,0) - I '$D(MEDRSLT(1)) D ; NO MEDS FOR THIS PATIENT, EXIT -"RTN","CCRMEDS",74,0) - . I DEBUG W "MEDICATIONS RPC RETURNED NULL",! -"RTN","CCRMEDS",75,0) - . S @MEDOUTXML@(0)=0 -"RTN","CCRMEDS",76,0) - . Q -"RTN","CCRMEDS",77,0) - ; I DEBUG ZWR MEDRSLT -"RTN","CCRMEDS",78,0) - M GPLMEDS=MEDRSLT -"RTN","CCRMEDS",79,0) - S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) -"RTN","CCRMEDS",80,0) - S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) -"RTN","CCRMEDS",81,0) - ; I 'HASOP K @MEDTVMAP,@MEDTARYTMP KILL MOVED TO TOP OF ROUTINE -"RTN","CCRMEDS",82,0) - ; FIRST GO THROUGH MEDRSLT ARRAY AND COUNT MEDS AND LINES IN MEDS -"RTN","CCRMEDS",83,0) - ; ZA(0) IS TOTAL NUMBER OF MEDS ZA(ZI) IS LINES IN MED ZI -"RTN","CCRMEDS",84,0) - N ZA,ZI,ZJ,ZK,ZN S (ZI,ZJ,ZK,ZN)=0 ; ZI IS MED NUMBER, ZJ IS LINE IN MED -"RTN","CCRMEDS",85,0) - ; ZK IS THE NUMBER OF LINES IN A MED AND ZN IS COUNTER THROUGH LINES -"RTN","CCRMEDS",86,0) - S ZA(0)=0 ; ZA IS ARRAY OF MED LINE COUNTS -"RTN","CCRMEDS",87,0) - F ZJ=1:1 Q:'$D(MEDRSLT(ZJ)) D ; COUNT THE MEDS AND LINES -"RTN","CCRMEDS",88,0) - . I MEDRSLT(ZJ)?1"~".E D ; FOUND NEW MED -"RTN","CCRMEDS",89,0) - . . S ZI=ZI+1 ; INCREMENT MED COUNT -"RTN","CCRMEDS",90,0) - . . S ZA(0)=ZI ; NEW TOTAL FOR MEDS -"RTN","CCRMEDS",91,0) - . . S ZA(ZI)=ZJ_U_1 ; EACH ZA(X) IS Y^Z WHERE Y IS START LINE AND Z IS COUNT -"RTN","CCRMEDS",92,0) - . E D ; FOR EVERY LINE NOT A FIRST LINE IN MED -"RTN","CCRMEDS",93,0) - . . S ZK=$P(ZA(ZI),U,2)+1 ; INCREMENT LINE COUNT FOR CURRENT MED -"RTN","CCRMEDS",94,0) - . . S $P(ZA(ZI),U,2)=ZK ; AND STORE IT IN ARRAY -"RTN","CCRMEDS",95,0) - ;ZWR ZA -"RTN","CCRMEDS",96,0) - ; S @MEDTVMAP@(0)=ZA(0) ; SAVE NUMBER OF MEDS -"RTN","CCRMEDS",97,0) - F ZI=1:1:ZA(0) D ; FOR EACH MED -"RTN","CCRMEDS",98,0) - . I DEBUG W "ZI IS ",ZI,! -"RTN","CCRMEDS",99,0) - . ; W ZI," ",MEDCNT,! -"RTN","CCRMEDS",100,0) - . S ZJ=$P(ZA(ZI),U,1) ; INDEX OF FIRST LINE OF MED IN MEDRSLT -"RTN","CCRMEDS",101,0) - . S MEDPTMP=MEDRSLT(ZJ) ; PULL OUT FIRST LINE OF MED -"RTN","CCRMEDS",102,0) - . I $P(MEDPTMP,U,1)?1"~OP" Q ; SKIP OP ACTIVE AND PENDING -"RTN","CCRMEDS",103,0) - . S MEDCNT=MEDCNT+1 ; WE ARE GOING TO ADD A MED -"RTN","CCRMEDS",104,0) - . S MEDVMAP=$NA(@MEDTVMAP@(MEDCNT)) ; START PAST OP ACTIVE MEDS -"RTN","CCRMEDS",105,0) - . S @MEDTVMAP@(0)=@MEDTVMAP@(0)+1 ; ADDING A MED HERE -"RTN","CCRMEDS",106,0) - . S @MEDVMAP@("MEDOBJECTID")="MED"_(MEDCNT) ; UNIQUE OBJID FOR MEDS -"RTN","CCRMEDS",107,0) - . I $P(MEDPTMP,"^",11)="" S @MEDVMAP@("MEDISSUEDATETXT")="" -"RTN","CCRMEDS",108,0) - . E S @MEDVMAP@("MEDISSUEDATETXT")=$$FMDTOUTC^CCRUTIL($P(MEDPTMP,"^",11),"DT") ; GETS LAST FILL DATE -"RTN","CCRMEDS",109,0) - . S @MEDVMAP@("MEDISSUEDATE")="" -"RTN","CCRMEDS",110,0) - . S @MEDVMAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS",111,0) - . S @MEDVMAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS",112,0) - . S @MEDVMAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS",113,0) - . S @MEDVMAP@("MEDRXNO")="" -"RTN","CCRMEDS",114,0) - . S @MEDVMAP@("MEDDETAILUNADORNED")="" -"RTN","CCRMEDS",115,0) - . S @MEDVMAP@("MEDCONCVALUE")="" -"RTN","CCRMEDS",116,0) - . S @MEDVMAP@("MEDCONCUNIT")="" -"RTN","CCRMEDS",117,0) - . S @MEDVMAP@("MEDSIZETEXT")="" -"RTN","CCRMEDS",118,0) - . S @MEDVMAP@("MEDDOSEINDICATOR")="" -"RTN","CCRMEDS",119,0) - . S @MEDVMAP@("MEDDELIVERYMETHOD")="" -"RTN","CCRMEDS",120,0) - . S @MEDVMAP@("MEDRATEVALUE")="" -"RTN","CCRMEDS",121,0) - . S @MEDVMAP@("MEDRATEUNIT")="" -"RTN","CCRMEDS",122,0) - . S @MEDVMAP@("MEDVEHICLETEXT")="" -"RTN","CCRMEDS",123,0) - . S @MEDVMAP@("MEDFREQUENCYUNIT")="" -"RTN","CCRMEDS",124,0) - . S @MEDVMAP@("MEDINTERVALVALUE")="" -"RTN","CCRMEDS",125,0) - . S @MEDVMAP@("MEDINTERVALUNIT")="" -"RTN","CCRMEDS",126,0) - . S @MEDVMAP@("MEDPRNFLAG")="" -"RTN","CCRMEDS",127,0) - . S @MEDVMAP@("MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS",128,0) - . S @MEDVMAP@("MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS",129,0) - . S @MEDVMAP@("MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS",130,0) - . S @MEDVMAP@("MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS",131,0) - . S @MEDVMAP@("MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS",132,0) - . S @MEDVMAP@("MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS",133,0) - . S @MEDVMAP@("MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS",134,0) - . S @MEDVMAP@("MEDSTOPINDICATOR")="" -"RTN","CCRMEDS",135,0) - . S @MEDVMAP@("MEDDIRSEQ")="" -"RTN","CCRMEDS",136,0) - . S @MEDVMAP@("MEDMULDIRMOD")="" -"RTN","CCRMEDS",137,0) - . S @MEDVMAP@("MEDPTINSTRUCTIONS")="" -"RTN","CCRMEDS",138,0) - . S @MEDVMAP@("MEDFULLFILLMENTINSTRUCTIONS")="" -"RTN","CCRMEDS",139,0) - . S @MEDVMAP@("MEDDATETIMEAGE")="" -"RTN","CCRMEDS",140,0) - . S @MEDVMAP@("MEDDATETIMEAGEUNITS")="" -"RTN","CCRMEDS",141,0) - . S @MEDVMAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS",142,0) - . S @MEDVMAP@("MEDSTATUSTEXT")=$P(MEDPTMP,"^",10) ; STATUS FROM RPC -"RTN","CCRMEDS",143,0) - . S @MEDVMAP@("MEDSOURCEACTORID")="ACTORSYSTEM_1" -"RTN","CCRMEDS",144,0) - . S @MEDVMAP@("MEDPRODUCTNAMETEXT")=$P(MEDPTMP,"^",3) -"RTN","CCRMEDS",145,0) - . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")="" ; DEFAULT VALUE -"RTN","CCRMEDS",146,0) - . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" -"RTN","CCRMEDS",147,0) - . S @MEDVMAP@("MEDPRODUCTNAMECODEVERSION")="" -"RTN","CCRMEDS",148,0) - . I $P(MEDPTMP,U,1)?1"~OP" D ; IS OUTPATIENT, MIGHT HAVE CODE -"RTN","CCRMEDS",149,0) - . . I $P(MEDPTMP,"^",10)="ACTIVE" D ; ONLY ACTIVE MEDS HAVE CODES -"RTN","CCRMEDS",150,0) - . . . N RXIEN ; IEN TO RX, EXAMPLE "~OP^13R;O^IBUPROFEN 400MG^" 13 IS IT -"RTN","CCRMEDS",151,0) - . . . S RXIEN=$$DIGITS($P($P(MEDPTMP,U,2),";",1)) ; GET JUST LEADING DIGITS -"RTN","CCRMEDS",152,0) - . . . I DEBUG W "RXIEN=",RXIEN,! ; -"RTN","CCRMEDS",153,0) - . . . D RX^PSO52API(DFN,"MEDCODE",RXIEN) ; EXTRACT THE RX RECORD TO ^TMP -"RTN","CCRMEDS",154,0) - . . . I $D(^TMP($J,"MEDCODE",DFN,RXIEN,27)) D ; IF SUCCESS -"RTN","CCRMEDS",155,0) - . . . . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")=^TMP($J,"MEDCODE",DFN,RXIEN,27) -"RTN","CCRMEDS",156,0) - . . . . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS",157,0) - . S @MEDVMAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS",158,0) - . S @MEDVMAP@("MEDBRANDNAMECODEVALUE")="" -"RTN","CCRMEDS",159,0) - . S @MEDVMAP@("MEDBRANDNAMECODINGSYSTEM")="" -"RTN","CCRMEDS",160,0) - . S @MEDVMAP@("MEDBRANDNAMECODEVERSION")="" -"RTN","CCRMEDS",161,0) - . S @MEDVMAP@("MEDSTRENGTHVALUE")="" -"RTN","CCRMEDS",162,0) - . S @MEDVMAP@("MEDSTRENGTHUNIT")="" -"RTN","CCRMEDS",163,0) - . S @MEDVMAP@("MEDFORMTEXT")="" -"RTN","CCRMEDS",164,0) - . S @MEDVMAP@("MEDQUANTITYVALUE")="" -"RTN","CCRMEDS",165,0) - . S @MEDVMAP@("MEDQUANTITYUNIT")="" -"RTN","CCRMEDS",166,0) - . S @MEDVMAP@("MEDRFNO")="" -"RTN","CCRMEDS",167,0) - . S ZK=$P(ZA(ZI),U,2) ; NUMBER OF LINES IN MED -"RTN","CCRMEDS",168,0) - . I ZK>1 D ; MORE THAN ONE LINE IN MED -"RTN","CCRMEDS",169,0) - . . S @MEDVMAP@("MEDDESCRIPTIONTEXT")=$P(MEDRSLT(ZJ+1)," *",2) -"RTN","CCRMEDS",170,0) - . I ZK>2 D ; THIRD THROUGH 2+N LINES OF MED ARE INSTRUCTIONS -"RTN","CCRMEDS",171,0) - . . N TMPTXT S TMPTXT="" ; BUILD UP INSTRUCTION LINE -"RTN","CCRMEDS",172,0) - . . F ZN=2:1:ZK-1 D ; REMAINING LINES IN EACH MED -"RTN","CCRMEDS",173,0) - . . . I MEDRSLT(ZJ+ZN)]"\ Sig: " D ; REMOVE THIS MARKUP -"RTN","CCRMEDS",174,0) - . . . . S TMPTXT=TMPTXT_$P(MEDRSLT(ZJ+ZN),"\ Sig: ",2)_" " ; APPEND 2 TMPTXT -"RTN","CCRMEDS",175,0) - . . . E S TMPTXT=TMPTXT_MEDRSLT(ZJ+ZN)_" " ; SEPARATE LINES WITH SPACE -"RTN","CCRMEDS",176,0) - . . S @MEDVMAP@("MEDDIRECTIONDESCRIPTIONTEXT")=TMPTXT ; CP TO MAP VAR -"RTN","CCRMEDS",177,0) - . S @MEDVMAP@("MEDDOSEVALUE")="" -"RTN","CCRMEDS",178,0) - . S @MEDVMAP@("MEDDOSEUNIT")="" -"RTN","CCRMEDS",179,0) - . S @MEDVMAP@("MEDFREQUENCYVALUE")="" -"RTN","CCRMEDS",180,0) - . S @MEDVMAP@("MEDDURATIONVALUE")="" -"RTN","CCRMEDS",181,0) - . S @MEDVMAP@("MEDDURATIONUNIT")="" -"RTN","CCRMEDS",182,0) - . S @MEDVMAP@("MEDDIRECTIONROUTETEXT")="" -"RTN","CCRMEDS",183,0) - . S @MEDVMAP@("MEDDIRECTIONFREQUENCYVALUE")="" -"RTN","CCRMEDS",184,0) - . S MEDARYTMP=$NA(@MEDTARYTMP@(ZI)) -"RTN","CCRMEDS",185,0) - . K @MEDARYTMP -"RTN","CCRMEDS",186,0) - . D MAP^GPLXPATH(MEDXML,MEDVMAP,MEDARYTMP) -"RTN","CCRMEDS",187,0) - . I ZI=1&('HASOP) D ; FIRST ONE IS JUST A COPY MAKE SURE OP IS NOT THERE -"RTN","CCRMEDS",188,0) - . . ; W "FIRST ONE",! -"RTN","CCRMEDS",189,0) - . . D CP^GPLXPATH(MEDARYTMP,MEDOUTXML) -"RTN","CCRMEDS",190,0) - . E D ; AFTER THE FIRST OR IF THERE ARE OP, INSERT INNER XML -"RTN","CCRMEDS",191,0) - . . D INSINNER^GPLXPATH(MEDOUTXML,MEDARYTMP) -"RTN","CCRMEDS",192,0) - N MEDTMP,MEDI -"RTN","CCRMEDS",193,0) - D MISSING^GPLXPATH(MEDOUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS",194,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS",195,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS",196,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS",197,0) - Q -"RTN","CCRMEDS",198,0) - ; -"RTN","CCRMEDS",199,0) -DIGITS(INSTR) ; RETURN JUST THE LEADING DIGITS OF THE STRING -"RTN","CCRMEDS",200,0) - ; EXAMPLE: $$DIGITS("13R") RETURNS 13 -"RTN","CCRMEDS",201,0) - N ALPHA ; CONTANT TO HOLD ALL ALPHA CHARACTERS -"RTN","CCRMEDS",202,0) - S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ; ALPHAS -"RTN","CCRMEDS",203,0) - Q $TR(INSTR,ALPHA) ; LEAVE ONLY THE DIGITS -"RTN","CCRMEDS",204,0) - ; -"RTN","CCRMEDS1") -0^10^B80043311 -"RTN","CCRMEDS1",1,0) -CCRMEDS ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;08/24/08 -"RTN","CCRMEDS1",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 14 -"RTN","CCRMEDS1",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS1",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS1",5,0) - ; -"RTN","CCRMEDS1",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS1",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS1",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS1",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS1",10,0) - ; -"RTN","CCRMEDS1",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS1",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS1",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS1",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS1",15,0) - ; -"RTN","CCRMEDS1",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS1",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS1",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS1",19,0) - ; -"RTN","CCRMEDS1",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS1",21,0) - Q -"RTN","CCRMEDS1",22,0) - ; -"RTN","CCRMEDS1",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS1",24,0) - ; -"RTN","CCRMEDS1",25,0) - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","CCRMEDS1",26,0) - ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE -"RTN","CCRMEDS1",27,0) - ; -"RTN","CCRMEDS1",28,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS1",29,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS1",30,0) - ; MED is holds each array element from MEDS(J), one medicine -"RTN","CCRMEDS1",31,0) - ; J is a counter. -"RTN","CCRMEDS1",32,0) - ; -"RTN","CCRMEDS1",33,0) - ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all -"RTN","CCRMEDS1",34,0) - ; med data available. -"RTN","CCRMEDS1",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS1",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS1",37,0) - ; D PARY^GPLXPATH(MINXML) -"RTN","CCRMEDS1",38,0) - N MEDS,MAP -"RTN","CCRMEDS1",39,0) - K ^TMP($J) -"RTN","CCRMEDS1",40,0) - D RX^PSO52API(DFN,"CCDCCR") -"RTN","CCRMEDS1",41,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS1",42,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS1",43,0) - ; If it is -1, we quit. -"RTN","CCRMEDS1",44,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS1",45,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS1",46,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS1",47,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS1",48,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS1",49,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS1",50,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS1",51,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS1",52,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS1",53,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS1",54,0) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN CCRMEDS -"RTN","CCRMEDS1",55,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS1",56,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS1",57,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS1",58,0) - . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS1",59,0) - . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number -"RTN","CCRMEDS1",60,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS1",61,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($P(MED(1),U)) -"RTN","CCRMEDS1",62,0) - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" -"RTN","CCRMEDS1",63,0) - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^CCRUTIL($P(MED(101),U)) -"RTN","CCRMEDS1",64,0) - . S @MAP@("MEDRXNOTXT")="Prescription Number" -"RTN","CCRMEDS1",65,0) - . S @MAP@("MEDRXNO")=MED(.01) -"RTN","CCRMEDS1",66,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS1",67,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS1",68,0) - . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) -"RTN","CCRMEDS1",69,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) -"RTN","CCRMEDS1",70,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) -"RTN","CCRMEDS1",71,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=MED(27) -"RTN","CCRMEDS1",72,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS1",73,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS1",74,0) - . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) -"RTN","CCRMEDS1",75,0) - . N MEDIEN S MEDIEN=$P(MED(6),U) -"RTN","CCRMEDS1",76,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS1",77,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS1",78,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS1",79,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS1",80,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS1",81,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS1",82,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS1",83,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS1",84,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",85,0) - . ; Documented in the same manual. -"RTN","CCRMEDS1",86,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS1",87,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS1",88,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS1",89,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS1",90,0) - . N CONCDATA -"RTN","CCRMEDS1",91,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS1",92,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS1",93,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS1",94,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS1",95,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS1",96,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS1",97,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS1",98,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS1",99,0) - . S @MAP@("MEDQUANTITYVALUE")=MED(7) -"RTN","CCRMEDS1",100,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS1",101,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS1",102,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",103,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS1",104,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS1",105,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS1",106,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS1",107,0) - . ; -"RTN","CCRMEDS1",108,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS1",109,0) - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... -"RTN","CCRMEDS1",110,0) - . ; we want the compoenents. -"RTN","CCRMEDS1",111,0) - . ; It's in node 6 of ^PSRX(IEN) -"RTN","CCRMEDS1",112,0) - . ; So, here we go again -"RTN","CCRMEDS1",113,0) - . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE -"RTN","CCRMEDS1",114,0) - . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) -"RTN","CCRMEDS1",115,0) - . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE -"RTN","CCRMEDS1",116,0) - . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ -"RTN","CCRMEDS1",117,0) - . ; -"RTN","CCRMEDS1",118,0) - . N DIRNUM S DIRNUM=0 ; Sigline number -"RTN","CCRMEDS1",119,0) - . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS -"RTN","CCRMEDS1",120,0) - . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D -"RTN","CCRMEDS1",121,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS1",122,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS1",123,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS1",124,0) - . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) -"RTN","CCRMEDS1",125,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) -"RTN","CCRMEDS1",126,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) -"RTN","CCRMEDS1",127,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS1",128,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS1",129,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS1",130,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS1",131,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) -"RTN","CCRMEDS1",132,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) -"RTN","CCRMEDS1",133,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS1",134,0) - . . ; In the wisdom of the original programmers, the schedule is a free text field -"RTN","CCRMEDS1",135,0) - . . ; However, it gets translated by a call to the administration schedule file -"RTN","CCRMEDS1",136,0) - . . ; to see if that schedule exists. -"RTN","CCRMEDS1",137,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS1",138,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS1",139,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS1",140,0) - . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. -"RTN","CCRMEDS1",141,0) - . . ; So... -"RTN","CCRMEDS1",142,0) - . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") -"RTN","CCRMEDS1",143,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS1",144,0) - . . N INTERVAL -"RTN","CCRMEDS1",145,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS1",146,0) - . . E D -"RTN","CCRMEDS1",147,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS1",148,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS1",149,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS1",150,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS1",151,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) -"RTN","CCRMEDS1",152,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" -"RTN","CCRMEDS1",153,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" -"RTN","CCRMEDS1",154,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS1",155,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS1",156,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS1",157,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS1",158,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS1",159,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS1",160,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS1",161,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" -"RTN","CCRMEDS1",162,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS1",163,0) - . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) -"RTN","CCRMEDS1",164,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") -"RTN","CCRMEDS1",165,0) - . ; -"RTN","CCRMEDS1",166,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS1",167,0) - . ; -"RTN","CCRMEDS1",168,0) - . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" -"RTN","CCRMEDS1",169,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) -"RTN","CCRMEDS1",170,0) - . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" -"RTN","CCRMEDS1",171,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) -"RTN","CCRMEDS1",172,0) - . S @MAP@("MEDRFNO")=MED(9) -"RTN","CCRMEDS1",173,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS1",174,0) - . K @RESULT -"RTN","CCRMEDS1",175,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS1",176,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS1",177,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS1",178,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS1",179,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS1",180,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS1",181,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS1",182,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS1",183,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS1",184,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS1",185,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS1",186,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS1",187,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS1",188,0) - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS1",189,0) - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML -"RTN","CCRMEDS1",190,0) - N MEDTMP,MEDI -"RTN","CCRMEDS1",191,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS1",192,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS1",193,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS1",194,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS1",195,0) - Q -"RTN","CCRMEDS1",196,0) - ; -"RTN","CCRMEDS2") -0^11^B101302627 -"RTN","CCRMEDS2",1,0) -CCRMEDS2 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Pending Meds;08/24/08 -"RTN","CCRMEDS2",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 14 -"RTN","CCRMEDS2",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS2",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS2",5,0) - ; -"RTN","CCRMEDS2",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS2",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS2",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS2",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS2",10,0) - ; -"RTN","CCRMEDS2",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS2",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS2",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS2",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS2",15,0) - ; -"RTN","CCRMEDS2",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS2",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS2",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS2",19,0) - ; -"RTN","CCRMEDS2",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS2",21,0) - Q -"RTN","CCRMEDS2",22,0) - ; -"RTN","CCRMEDS2",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS2",24,0) - ; -"RTN","CCRMEDS2",25,0) - ; MINXML is the Input XML Template, passed by name -"RTN","CCRMEDS2",26,0) - ; DFN is Patient IEN -"RTN","CCRMEDS2",27,0) - ; OUTXML is the resultant XML. -"RTN","CCRMEDS2",28,0) - ; -"RTN","CCRMEDS2",29,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS2",30,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS2",31,0) - ; MED is holds each array element from MEDS, one medicine -"RTN","CCRMEDS2",32,0) - ; -"RTN","CCRMEDS2",33,0) - ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending -"RTN","CCRMEDS2",34,0) - ; meds data available. -"RTN","CCRMEDS2",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS2",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS2",37,0) - ; File for pending meds is 52.41 -"RTN","CCRMEDS2",38,0) - ; Unfortuantely, API does not supply us with any useful info beyond -"RTN","CCRMEDS2",39,0) - ; the IEN in 52.41, and the Med Name, and route. -"RTN","CCRMEDS2",40,0) - ; So, most of the info is going to get pulled from 52.41. -"RTN","CCRMEDS2",41,0) - N MEDS,MAP -"RTN","CCRMEDS2",42,0) - K ^TMP($J) -"RTN","CCRMEDS2",43,0) - D PEN^PSO5241(DFN,"CCDCCR") -"RTN","CCRMEDS2",44,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS2",45,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS2",46,0) - ; If it is -1, we quit. -"RTN","CCRMEDS2",47,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS2",48,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS2",49,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS2",50,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS2",51,0) - N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING -"RTN","CCRMEDS2",52,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS2",53,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS2",54,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS2",55,0) - . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order -"RTN","CCRMEDS2",56,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS2",57,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS2",58,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS2",59,0) - . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN CCRMEDS -"RTN","CCRMEDS2",60,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS2",61,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS2",62,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS2",63,0) - . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS2",64,0) - . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN -"RTN","CCRMEDS2",65,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS2",66,0) - . ; Field 6 is "Effective date", and we pull it in timson format w/ I -"RTN","CCRMEDS2",67,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") -"RTN","CCRMEDS2",68,0) - . ; Med never filled; next 4 fields are not applicable. -"RTN","CCRMEDS2",69,0) - . S @MAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS2",70,0) - . S @MAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS2",71,0) - . S @MAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS2",72,0) - . S @MAP@("MEDRXNO")="" -"RTN","CCRMEDS2",73,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS2",74,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS2",75,0) - . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds -"RTN","CCRMEDS2",76,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") -"RTN","CCRMEDS2",77,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) -"RTN","CCRMEDS2",78,0) - . ; NDC not supplied in API, but is rather trivial to obtain -"RTN","CCRMEDS2",79,0) - . ; MED(11) piece 1 has the IEN of the drug (file 50) -"RTN","CCRMEDS2",80,0) - . ; IEN is field 31 in the drug file. -"RTN","CCRMEDS2",81,0) - . N MEDIEN S MEDIEN=$P(MED(11),U) -"RTN","CCRMEDS2",82,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$$GET1^DIQ(50,MEDIEN,31,"E") -"RTN","CCRMEDS2",83,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS2",84,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS2",85,0) - . S @MAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS2",86,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS2",87,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS2",88,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS2",89,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS2",90,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS2",91,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS2",92,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS2",93,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS2",94,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",95,0) - . ; Documented in the same manual. -"RTN","CCRMEDS2",96,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS2",97,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS2",98,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS2",99,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS2",100,0) - . N CONCDATA -"RTN","CCRMEDS2",101,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS2",102,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS2",103,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS2",104,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS2",105,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS2",106,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS2",107,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS2",108,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS2",109,0) - . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) -"RTN","CCRMEDS2",110,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS2",111,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS2",112,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",113,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS2",114,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS2",115,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS2",116,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS2",117,0) - . ; -"RTN","CCRMEDS2",118,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS2",119,0) - . ; Sig data is not in any API. We obtain it using the IEN from -"RTN","CCRMEDS2",120,0) - . ; the PEN API to file 52.41. It's in field 3, which is a multiple. -"RTN","CCRMEDS2",121,0) - . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) -"RTN","CCRMEDS2",122,0) - . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call -"RTN","CCRMEDS2",123,0) - . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") -"RTN","CCRMEDS2",124,0) - . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. -"RTN","CCRMEDS2",125,0) - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". -"RTN","CCRMEDS2",126,0) - . ; DIRNUM will be first piece for IEN. -"RTN","CCRMEDS2",127,0) - . ; DIRNUM is the proper Sigline numer. -"RTN","CCRMEDS2",128,0) - . ; SIGDATA is the simplfied array. Subscripts are really field numbers -"RTN","CCRMEDS2",129,0) - . ; in subfile 52.413. -"RTN","CCRMEDS2",130,0) - . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS -"RTN","CCRMEDS2",131,0) - . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D -"RTN","CCRMEDS2",132,0) - . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") -"RTN","CCRMEDS2",133,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS2",134,0) - . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) -"RTN","CCRMEDS2",135,0) - . . ; If this is an order for a refill; it's not really a new order; move on to next -"RTN","CCRMEDS2",136,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS2",137,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS2",138,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) -"RTN","CCRMEDS2",139,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) -"RTN","CCRMEDS2",140,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS2",141,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS2",142,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS2",143,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS2",144,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) -"RTN","CCRMEDS2",145,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) -"RTN","CCRMEDS2",146,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS2",147,0) - . . ; The schedule is a free text field -"RTN","CCRMEDS2",148,0) - . . ; However, it gets translated by a call to the administration -"RTN","CCRMEDS2",149,0) - . . ; schedule file to see if that schedule exists. -"RTN","CCRMEDS2",150,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS2",151,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS2",152,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS2",153,0) - . . ; I looked), PSSFT is the name, -"RTN","CCRMEDS2",154,0) - . . ; and list is the ^TMP name to store the data in. -"RTN","CCRMEDS2",155,0) - . . ; Also, freqency may have "PRN" in it, so strip that out -"RTN","CCRMEDS2",156,0) - . . N FREQ S FREQ=SIGDATA(1) -"RTN","CCRMEDS2",157,0) - . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp -"RTN","CCRMEDS2",158,0) - . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") -"RTN","CCRMEDS2",159,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS2",160,0) - . . N INTERVAL -"RTN","CCRMEDS2",161,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS2",162,0) - . . E D -"RTN","CCRMEDS2",163,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS2",164,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS2",165,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS2",166,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS2",167,0) - . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months -"RTN","CCRMEDS2",168,0) - . . N DUR S DUR=SIGDATA(2) -"RTN","CCRMEDS2",169,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) -"RTN","CCRMEDS2",170,0) - . . N DURUNIT S DURUNIT=$E(DUR) -"RTN","CCRMEDS2",171,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") -"RTN","CCRMEDS2",172,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" -"RTN","CCRMEDS2",173,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS2",174,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS2",175,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS2",176,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS2",177,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS2",178,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS2",179,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS2",180,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field -"RTN","CCRMEDS2",181,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS2",182,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) -"RTN","CCRMEDS2",183,0) - . ; -"RTN","CCRMEDS2",184,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS2",185,0) - . ; -"RTN","CCRMEDS2",186,0) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" -"RTN","CCRMEDS2",187,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL -"RTN","CCRMEDS2",188,0) - . ; W @MAP@("MEDPTINSTRUCTIONS"),! -"RTN","CCRMEDS2",189,0) - . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" -"RTN","CCRMEDS2",190,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL -"RTN","CCRMEDS2",191,0) - . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! -"RTN","CCRMEDS2",192,0) - . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) -"RTN","CCRMEDS2",193,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS2",194,0) - . K @RESULT -"RTN","CCRMEDS2",195,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS2",196,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS2",197,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS2",198,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS2",199,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS2",200,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS2",201,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS2",202,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS2",203,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS2",204,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS2",205,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS2",206,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS2",207,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS2",208,0) - . I MEDFIRST D ; -"RTN","CCRMEDS2",209,0) - . . S MEDFIRST=0 ; RESET FIRST FLAG -"RTN","CCRMEDS2",210,0) - . . D CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS2",211,0) - . D:'MEDFIRST INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML -"RTN","CCRMEDS2",212,0) - N MEDTMP,MEDI -"RTN","CCRMEDS2",213,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS2",214,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS2",215,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS2",216,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS2",217,0) - Q -"RTN","CCRMEDS2",218,0) - ; -"RTN","CCRMEDS3") -0^24^B68176928 -"RTN","CCRMEDS3",1,0) -CCRMEDS3 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Outside_non-VA Meds;10/13/08 -"RTN","CCRMEDS3",2,0) - ;;0.1;CCDCCR;;;Build 14 -"RTN","CCRMEDS3",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS3",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS3",5,0) - ; -"RTN","CCRMEDS3",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS3",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS3",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS3",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS3",10,0) - ; -"RTN","CCRMEDS3",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS3",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS3",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS3",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS3",15,0) - ; -"RTN","CCRMEDS3",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS3",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS3",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS3",19,0) - ; -"RTN","CCRMEDS3",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS3",21,0) - Q -"RTN","CCRMEDS3",22,0) - ; -"RTN","CCRMEDS3",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS3",24,0) - ; -"RTN","CCRMEDS3",25,0) - ; MINXML is the Input XML Template, passed by name -"RTN","CCRMEDS3",26,0) - ; DFN is Patient IEN -"RTN","CCRMEDS3",27,0) - ; OUTXML is the resultant XML. -"RTN","CCRMEDS3",28,0) - ; -"RTN","CCRMEDS3",29,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS3",30,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS3",31,0) - ; MED is holds each array element from MEDS, one medicine -"RTN","CCRMEDS3",32,0) - ; -"RTN","CCRMEDS3",33,0) - ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 -"RTN","CCRMEDS3",34,0) - ; Discontinued meds are indicated by the presence of a value in fields -"RTN","CCRMEDS3",35,0) - ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) -"RTN","CCRMEDS3",36,0) - ; Will use Fileman API GETS^DIQ -"RTN","CCRMEDS3",37,0) - ; -"RTN","CCRMEDS3",38,0) - N MEDS,MAP -"RTN","CCRMEDS3",39,0) - K ^TMP($J),NVA -"RTN","CCRMEDS3",40,0) - D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. -"RTN","CCRMEDS3",41,0) - ; If NVA does not exist, then patient has no non-VA meds -"RTN","CCRMEDS3",42,0) - I $D(NVA)=0 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS3",43,0) - ; Otherwise, we go on... -"RTN","CCRMEDS3",44,0) - M MEDS=NVA(55.05) -"RTN","CCRMEDS3",45,0) - ; We are done with NVA -"RTN","CCRMEDS3",46,0) - K NVA -"RTN","CCRMEDS3",47,0) - ; -"RTN","CCRMEDS3",48,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS3",49,0) - N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. -"RTN","CCRMEDS3",50,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) -"RTN","CCRMEDS3",51,0) - N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array -"RTN","CCRMEDS3",52,0) - N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE -"RTN","CCRMEDS3",53,0) - F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS3",54,0) - . N MED M MED=MEDS(FDAIEN) -"RTN","CCRMEDS3",55,0) - . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. -"RTN","CCRMEDS3",56,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS3",57,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS3",58,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS3",59,0) - . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient -"RTN","CCRMEDS3",60,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS3",61,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS3",62,0) - . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS3",63,0) - . S @MAP@("MEDISSUEDATETXT")="Documented Date" -"RTN","CCRMEDS3",64,0) - . ; Field 6 is "Effective date", and we pull it in timson format w/ I -"RTN","CCRMEDS3",65,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL(MED(11,"I"),"DT") -"RTN","CCRMEDS3",66,0) - . ; Med never filled; next 4 fields are not applicable. -"RTN","CCRMEDS3",67,0) - . S @MAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS3",68,0) - . S @MAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS3",69,0) - . S @MAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS3",70,0) - . S @MAP@("MEDRXNO")="" -"RTN","CCRMEDS3",71,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS3",72,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS3",73,0) - . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds -"RTN","CCRMEDS3",74,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") -"RTN","CCRMEDS3",75,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") -"RTN","CCRMEDS3",76,0) - . ; NDC is field 31 in the drug file. -"RTN","CCRMEDS3",77,0) - . ; The actual drug entry in the drug file is not necessarily supplied. -"RTN","CCRMEDS3",78,0) - . ; It' node 1, internal form. -"RTN","CCRMEDS3",79,0) - . N MEDIEN S MEDIEN=MED(1,"I") -"RTN","CCRMEDS3",80,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") -"RTN","CCRMEDS3",81,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") -"RTN","CCRMEDS3",82,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") -"RTN","CCRMEDS3",83,0) - . S @MAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS3",84,0) - . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS3",85,0) - . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS3",86,0) - . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") -"RTN","CCRMEDS3",87,0) - . S @MAP@("MEDSTRENGTHUNIT")=$S($L(DOSEDATA(902))>0:$P(DOSEDATA(902),U,2),1:"") ; SAM PLEASE CHECK -"RTN","CCRMEDS3",88,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS3",89,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS3",90,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS3",91,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS3",92,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS3",93,0) - . ; Documented in the same manual. -"RTN","CCRMEDS3",94,0) - . N NDFDATA,CONCDATA -"RTN","CCRMEDS3",95,0) - . I $L(MEDIEN) D -"RTN","CCRMEDS3",96,0) - . . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS3",97,0) - . . M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS3",98,0) - . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS3",99,0) - . . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS3",100,0) - . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS3",101,0) - . . ; and this will crash the call. So... -"RTN","CCRMEDS3",102,0) - . . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS3",103,0) - . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS3",104,0) - . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. -"RTN","CCRMEDS3",105,0) - . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") -"RTN","CCRMEDS3",106,0) - . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") -"RTN","CCRMEDS3",107,0) - . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") -"RTN","CCRMEDS3",108,0) - . S @MAP@("MEDSIZETEXT")=$S($L(MEDIEN):$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2),1:"") -"RTN","CCRMEDS3",109,0) - . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. -"RTN","CCRMEDS3",110,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS3",111,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS3",112,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS3",113,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS3",114,0) - . I $L(MEDIEN) D -"RTN","CCRMEDS3",115,0) - . . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS3",116,0) - . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS3",117,0) - . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS3",118,0) - . E S @MAP@("MEDQUANTITYUNIT")="" -"RTN","CCRMEDS3",119,0) - . ; -"RTN","CCRMEDS3",120,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS3",121,0) - . ; Dosage is field 2, route is 3, schedule is 4 -"RTN","CCRMEDS3",122,0) - . ; These are all free text fields, and don't point to any files -"RTN","CCRMEDS3",123,0) - . ; For that reason, I will use the field I never used before: -"RTN","CCRMEDS3",124,0) - . ; MEDDIRECTIONDESCRIPTIONTEXT -"RTN","CCRMEDS3",125,0) - . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS -"RTN","CCRMEDS3",126,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") -"RTN","CCRMEDS3",127,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. -"RTN","CCRMEDS3",128,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" -"RTN","CCRMEDS3",129,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" -"RTN","CCRMEDS3",130,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" -"RTN","CCRMEDS3",131,0) - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" -"RTN","CCRMEDS3",132,0) - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" -"RTN","CCRMEDS3",133,0) - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" -"RTN","CCRMEDS3",134,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" -"RTN","CCRMEDS3",135,0) - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" -"RTN","CCRMEDS3",136,0) - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" -"RTN","CCRMEDS3",137,0) - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" -"RTN","CCRMEDS3",138,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" -"RTN","CCRMEDS3",139,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" -"RTN","CCRMEDS3",140,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" -"RTN","CCRMEDS3",141,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS3",142,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS3",143,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS3",144,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS3",145,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS3",146,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS3",147,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS3",148,0) - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" -"RTN","CCRMEDS3",149,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" -"RTN","CCRMEDS3",150,0) - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" -"RTN","CCRMEDS3",151,0) - . ; -"RTN","CCRMEDS3",152,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS3",153,0) - . ; -"RTN","CCRMEDS3",154,0) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" -"RTN","CCRMEDS3",155,0) - . I $D(MED(10,1)) D ; -"RTN","CCRMEDS3",156,0) - . . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field -"RTN","CCRMEDS3",157,0) - . E S @MAP@("MEDPTINSTRUCTIONS")="" -"RTN","CCRMEDS3",158,0) - . I $D(MED(14,1)) D ; -"RTN","CCRMEDS3",159,0) - . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field -"RTN","CCRMEDS3",160,0) - . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" -"RTN","CCRMEDS3",161,0) - . S @MAP@("MEDRFNO")="" -"RTN","CCRMEDS3",162,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS3",163,0) - . K @RESULT -"RTN","CCRMEDS3",164,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS3",165,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS3",166,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS3",167,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS3",168,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS3",169,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS3",170,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS3",171,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS3",172,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS3",173,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS3",174,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS3",175,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS3",176,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS3",177,0) - . I MEDFIRST D ; -"RTN","CCRMEDS3",178,0) - . . S MEDFIRST=0 ; RESET FIRST FLAG -"RTN","CCRMEDS3",179,0) - . . D CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS3",180,0) - . D:'MEDFIRST INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML -"RTN","CCRMEDS3",181,0) - N MEDTMP,MEDI -"RTN","CCRMEDS3",182,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS3",183,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS3",184,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS3",185,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS3",186,0) - Q -"RTN","CCRMEDS3",187,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 14 -"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 14 -"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^B11670240 -"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 14 -"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","CCRUTIL",81,0) -DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX -"RTN","CCRUTIL",82,0) - ; RETURNS AN ARRAY RTN PASSED BY REFERENCE -"RTN","CCRUTIL",83,0) - ; THIS ROUTINE CAN BE USED AS AN RPC -"RTN","CCRUTIL",84,0) - ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY -"RTN","CCRUTIL",85,0) - ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY -"RTN","CCRUTIL",86,0) - ; -"RTN","CCRUTIL",87,0) - N LEXIEN -"RTN","CCRUTIL",88,0) - I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG -"RTN","CCRUTIL",89,0) - . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON -"RTN","CCRUTIL",90,0) - . W LEXIEN,! -"RTN","CCRUTIL",91,0) - . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 -"RTN","CCRUTIL",92,0) - . S RTN(0)=1 ; ONE THING RETURNED -"RTN","CCRUTIL",93,0) - E S RTN(0)=0 ; NOT FOUND -"RTN","CCRUTIL",94,0) - Q -"RTN","CCRUTIL",95,0) - ; -"RTN","CCRUTIL",96,0) -DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME -"RTN","CCRUTIL",97,0) - ; -"RTN","CCRUTIL",98,0) - N DARTN -"RTN","CCRUTIL",99,0) - D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE -"RTN","CCRUTIL",100,0) - I DARTN(0)>0 D ; GOT RESULTS -"RTN","CCRUTIL",101,0) - . W !,DARTN(1) ;PRINT THE SNOMED CODE -"RTN","CCRUTIL",102,0) - E W !,"NOT FOUND",! -"RTN","CCRUTIL",103,0) - Q -"RTN","CCRUTIL",104,0) - ; -"RTN","CCRUTIL",105,0) -DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL -"RTN","CCRUTIL",106,0) - ; ASSOCIATED SNOMED CODES -"RTN","CCRUTIL",107,0) - N DASTMP,DASIEN,DASNO -"RTN","CCRUTIL",108,0) - S DASTMP="" -"RTN","CCRUTIL",109,0) - F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED -"RTN","CCRUTIL",110,0) - . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED -"RTN","CCRUTIL",111,0) - . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY -"RTN","CCRUTIL",112,0) - . W DASTMP,"=",DASNO,! ; PRINT IT OUT -"RTN","CCRUTIL",113,0) - Q -"RTN","CCRUTIL",114,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 14 -"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^16^B53216743 -"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 14 -"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) - . K ATYP,AIEN,AOID ; BE SURE TO GET THE NEXT ONE -"RTN","GPLACTOR",71,0) - ; -"RTN","GPLACTOR",72,0) - N ACTTMP -"RTN","GPLACTOR",73,0) - D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS -"RTN","GPLACTOR",74,0) - I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - -"RTN","GPLACTOR",75,0) - . ; STRINGS MARKED AS @@X@@ -"RTN","GPLACTOR",76,0) - . W "ACTORS Missing list: ",! -"RTN","GPLACTOR",77,0) - . F I=1:1:ACTTMP(0) W ACTTMP(I),! -"RTN","GPLACTOR",78,0) - Q -"RTN","GPLACTOR",79,0) - ; -"RTN","GPLACTOR",80,0) -PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR -"RTN","GPLACTOR",81,0) - I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! -"RTN","GPLACTOR",82,0) - N AMAP,ZX -"RTN","GPLACTOR",83,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",84,0) - K @AMAP -"RTN","GPLACTOR",85,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",86,0) - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) -"RTN","GPLACTOR",87,0) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) -"RTN","GPLACTOR",88,0) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) -"RTN","GPLACTOR",89,0) - S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) -"RTN","GPLACTOR",90,0) - S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) -"RTN","GPLACTOR",91,0) - S @AMAP@("ACTORSSN")="" -"RTN","GPLACTOR",92,0) - S @AMAP@("ACTORSSNTEXT")="" -"RTN","GPLACTOR",93,0) - S @AMAP@("ACTORSSNSOURCEID")="" -"RTN","GPLACTOR",94,0) - S ZX=$$SSN^CCRDPT(AIEN) -"RTN","GPLACTOR",95,0) - I ZX'="" D ; IF THERE IS A SSN IN THE RECORD -"RTN","GPLACTOR",96,0) - . S @AMAP@("ACTORSSN")=ZX -"RTN","GPLACTOR",97,0) - . S @AMAP@("ACTORSSNTEXT")="SSN" -"RTN","GPLACTOR",98,0) - . S @AMAP@("ACTORSSNSOURCEID")=AOID -"RTN","GPLACTOR",99,0) - S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT(AIEN) -"RTN","GPLACTOR",100,0) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) -"RTN","GPLACTOR",101,0) - S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) -"RTN","GPLACTOR",102,0) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) -"RTN","GPLACTOR",103,0) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) -"RTN","GPLACTOR",104,0) - S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) -"RTN","GPLACTOR",105,0) - S @AMAP@("ACTORRESTEL")="" -"RTN","GPLACTOR",106,0) - S @AMAP@("ACTORRESTELTEXT")="" -"RTN","GPLACTOR",107,0) - S ZX=$$RESTEL^CCRDPT(AIEN) -"RTN","GPLACTOR",108,0) - I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD -"RTN","GPLACTOR",109,0) - . S @AMAP@("ACTORRESTEL")=ZX -"RTN","GPLACTOR",110,0) - . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" -"RTN","GPLACTOR",111,0) - S @AMAP@("ACTORWORKTEL")="" -"RTN","GPLACTOR",112,0) - S @AMAP@("ACTORWORKTELTEXT")="" -"RTN","GPLACTOR",113,0) - S ZX=$$WORKTEL^CCRDPT(AIEN) -"RTN","GPLACTOR",114,0) - I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD -"RTN","GPLACTOR",115,0) - . S @AMAP@("ACTORWORKTEL")=ZX -"RTN","GPLACTOR",116,0) - . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" -"RTN","GPLACTOR",117,0) - S @AMAP@("ACTORCELLTEL")="" -"RTN","GPLACTOR",118,0) - S @AMAP@("ACTORCELLTELTEXT")="" -"RTN","GPLACTOR",119,0) - S ZX=$$CELLTEL^CCRDPT(AIEN) -"RTN","GPLACTOR",120,0) - I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD -"RTN","GPLACTOR",121,0) - . S @AMAP@("ACTORCELLTEL")=ZX -"RTN","GPLACTOR",122,0) - . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" -"RTN","GPLACTOR",123,0) - S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT(AIEN) -"RTN","GPLACTOR",124,0) - S @AMAP@("ACTORADDRESSSOURCEID")=AOID -"RTN","GPLACTOR",125,0) - S @AMAP@("ACTORIEN")=AIEN -"RTN","GPLACTOR",126,0) - S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX -"RTN","GPLACTOR",127,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE -"RTN","GPLACTOR",128,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",129,0) - Q -"RTN","GPLACTOR",130,0) - ; -"RTN","GPLACTOR",131,0) -SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR -"RTN","GPLACTOR",132,0) - ; -"RTN","GPLACTOR",133,0) - ; N AMAP -"RTN","GPLACTOR",134,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",135,0) - K @AMAP -"RTN","GPLACTOR",136,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",137,0) - S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^CCRSYS -"RTN","GPLACTOR",138,0) - S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^CCRSYS -"RTN","GPLACTOR",139,0) - S @AMAP@("ACTORINFOSYSSOURCEID")=AOID -"RTN","GPLACTOR",140,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",141,0) - Q -"RTN","GPLACTOR",142,0) - ; -"RTN","GPLACTOR",143,0) -NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR -"RTN","GPLACTOR",144,0) - ; -"RTN","GPLACTOR",145,0) - ; N AMAP -"RTN","GPLACTOR",146,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",147,0) - K @AMAP -"RTN","GPLACTOR",148,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",149,0) - S @AMAP@("ACTORDISPLAYNAME")="" -"RTN","GPLACTOR",150,0) - S @AMAP@("ACTORRELATION")="" -"RTN","GPLACTOR",151,0) - S @AMAP@("ACTORRELATIONSOURCEID")="" -"RTN","GPLACTOR",152,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE -"RTN","GPLACTOR",153,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",154,0) - Q -"RTN","GPLACTOR",155,0) - ; -"RTN","GPLACTOR",156,0) -ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR -"RTN","GPLACTOR",157,0) - ; -"RTN","GPLACTOR",158,0) - ; N AMAP -"RTN","GPLACTOR",159,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",160,0) - K @AMAP -"RTN","GPLACTOR",161,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",162,0) - S @AMAP@("ORGANIZATIONNAME")=$P($$SITE^VASITE,U,2) -"RTN","GPLACTOR",163,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" -"RTN","GPLACTOR",164,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",165,0) - Q -"RTN","GPLACTOR",166,0) - ; -"RTN","GPLACTOR",167,0) -PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR -"RTN","GPLACTOR",168,0) - ; -"RTN","GPLACTOR",169,0) - ; N AMAP -"RTN","GPLACTOR",170,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",171,0) - K @AMAP -"RTN","GPLACTOR",172,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",173,0) - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRVA200(AIEN) -"RTN","GPLACTOR",174,0) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRVA200(AIEN) -"RTN","GPLACTOR",175,0) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRVA200(AIEN) -"RTN","GPLACTOR",176,0) - S @AMAP@("ACTORTITLE")=$$TITLE^CCRVA200(AIEN) -"RTN","GPLACTOR",177,0) - S @AMAP@("IDTYPE")=$P($$NPI^CCRVA200(AIEN),U,1) -"RTN","GPLACTOR",178,0) - S @AMAP@("ID")=$P($$NPI^CCRVA200(AIEN),U,2) -"RTN","GPLACTOR",179,0) - S @AMAP@("IDDESC")=$P($$NPI^CCRVA200(AIEN),U,3) -"RTN","GPLACTOR",180,0) - S @AMAP@("ACTORSPECIALITY")=$$SPEC^CCRVA200(AIEN) -"RTN","GPLACTOR",181,0) - S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^CCRVA200(AIEN) -"RTN","GPLACTOR",182,0) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^CCRVA200(AIEN) -"RTN","GPLACTOR",183,0) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRVA200(AIEN) -"RTN","GPLACTOR",184,0) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRVA200(AIEN) -"RTN","GPLACTOR",185,0) - S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^CCRVA200(AIEN) -"RTN","GPLACTOR",186,0) - S @AMAP@("ACTORTELEPHONE")="" -"RTN","GPLACTOR",187,0) - S @AMAP@("ACTORTELEPHONETYPE")="" -"RTN","GPLACTOR",188,0) - S ZX=$$TEL^CCRVA200(AIEN) -"RTN","GPLACTOR",189,0) - I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE -"RTN","GPLACTOR",190,0) - . S @AMAP@("ACTORTELEPHONE")=ZX -"RTN","GPLACTOR",191,0) - . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^CCRVA200(AIEN) -"RTN","GPLACTOR",192,0) - S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRVA200(AIEN) -"RTN","GPLACTOR",193,0) - S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" -"RTN","GPLACTOR",194,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE -"RTN","GPLACTOR",195,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",196,0) - Q -"RTN","GPLACTOR",197,0) - ; -"RTN","GPLALERT") -0^19^B22007040 -"RTN","GPLALERT",1,0) -GPLALERT ; CCDCCR/CKU - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 -"RTN","GPLALERT",2,0) - ;;0.1;CCDCCR;;SEP 11,2008;Build 14 -"RTN","GPLALERT",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","GPLALERT",4,0) - ;General Public License See attached copy of the License. -"RTN","GPLALERT",5,0) - ; -"RTN","GPLALERT",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","GPLALERT",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","GPLALERT",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","GPLALERT",9,0) - ;(at your option) any later version. -"RTN","GPLALERT",10,0) - ; -"RTN","GPLALERT",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","GPLALERT",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","GPLALERT",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","GPLALERT",14,0) - ;GNU General Public License for more details. -"RTN","GPLALERT",15,0) - ; -"RTN","GPLALERT",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","GPLALERT",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","GPLALERT",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","GPLALERT",19,0) - ; -"RTN","GPLALERT",20,0) - W "NO ENTRY FROM TOP",! -"RTN","GPLALERT",21,0) - Q -"RTN","GPLALERT",22,0) - ; -"RTN","GPLALERT",23,0) -EXTRACT(ALTXML,DFN,ALTOUTXML) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE -"RTN","GPLALERT",24,0) - ; -"RTN","GPLALERT",25,0) - ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","GPLALERT",26,0) - ; -"RTN","GPLALERT",27,0) - ; GET ADVERSE REACTIONS AND ALLERGIES -"RTN","GPLALERT",28,0) - ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES -"RTN","GPLALERT",29,0) - S GMRA="0^0^111" -"RTN","GPLALERT",30,0) - D EN1^GMRADPT -"RTN","GPLALERT",31,0) - I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* -"RTN","GPLALERT",32,0) - . S @ALTOUTXML@(0)=0 -"RTN","GPLALERT",33,0) - ; DEFINE MAPPING -"RTN","GPLALERT",34,0) - N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP -"RTN","GPLALERT",35,0) - S ALTTVMAP=$NA(^TMP("GPLALERT",$J,"ALERTS")) -"RTN","GPLALERT",36,0) - S ALTTARYTMP=$NA(^TMP("GPLALERT",$J,"ALERTSARYTMP")) -"RTN","GPLALERT",37,0) - K @ALTTVMAP,@ALTTARYTMP -"RTN","GPLALERT",38,0) - N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 -"RTN","GPLALERT",39,0) - S ALTTMP="" ; -"RTN","GPLALERT",40,0) - F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL -"RTN","GPLALERT",41,0) - . W "ALTTMP="_ALTTMP,! -"RTN","GPLALERT",42,0) - . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q -"RTN","GPLALERT",43,0) - . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) -"RTN","GPLALERT",44,0) - . K @ALTVMAP -"RTN","GPLALERT",45,0) - . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT -"RTN","GPLALERT",46,0) - . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES -"RTN","GPLALERT",47,0) - . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM -"RTN","GPLALERT",48,0) - . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG -"RTN","GPLALERT",49,0) - . N ADT S ADT="Patient has an " ; X $ZINT H 5 -"RTN","GPLALERT",50,0) - . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") -"RTN","GPLALERT",51,0) - . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." -"RTN","GPLALERT",52,0) - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT -"RTN","GPLALERT",53,0) - . N ALTCDE ; SNOMED CODE THE THE ALERT -"RTN","GPLALERT",54,0) - . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC -"RTN","GPLALERT",55,0) - . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; -"RTN","GPLALERT",56,0) - . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE -"RTN","GPLALERT",57,0) - . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE -"RTN","GPLALERT",58,0) - . I ALTCDE'="" D ; IF THERE IS A CODE -"RTN","GPLALERT",59,0) - . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" -"RTN","GPLALERT",60,0) - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" -"RTN","GPLALERT",61,0) - . E D ; SET TO NULL -"RTN","GPLALERT",62,0) - . . S @ALTVMAP@("ALERTCODESYSTEM")="" -"RTN","GPLALERT",63,0) - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" -"RTN","GPLALERT",64,0) - . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? -"RTN","GPLALERT",65,0) - . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN -"RTN","GPLALERT",66,0) - . I ALTPROV'="" D ; PROVIDER PROVIDEED -"RTN","GPLALERT",67,0) - . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV -"RTN","GPLALERT",68,0) - . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN -"RTN","GPLALERT",69,0) - . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! -"RTN","GPLALERT",70,0) - . N ACGL1,ACGFI,ACIEN,ACVUID -"RTN","GPLALERT",71,0) - . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, -"RTN","GPLALERT",72,0) - . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER -"RTN","GPLALERT",73,0) - . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT -"RTN","GPLALERT",74,0) - . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT -"RTN","GPLALERT",75,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT -"RTN","GPLALERT",76,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? -"RTN","GPLALERT",77,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=$P(@ALTG@(ALTTMP),U,2) ; REACTANT -"RTN","GPLALERT",78,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID -"RTN","GPLALERT",79,0) - . I ACVUID'="" D ; IF VUID IS NOT NULL -"RTN","GPLALERT",80,0) - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID" -"RTN","GPLALERT",81,0) - . E D ; IF REACTANT CODE VALUE IS NULL -"RTN","GPLALERT",82,0) - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" -"RTN","GPLALERT",83,0) - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" -"RTN","GPLALERT",84,0) - . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW -"RTN","GPLALERT",85,0) - . N ARTMP,ARIEN,ARDES,ARVUID -"RTN","GPLALERT",86,0) - . S (ARTMP,ARDES,ARVUID)="" -"RTN","GPLALERT",87,0) - . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS -"RTN","GPLALERT",88,0) - . . S ARTMP=@ALTG@(ALTTMP,"S",1) -"RTN","GPLALERT",89,0) - . . W "REACTION:",ARTMP,! -"RTN","GPLALERT",90,0) - . . S ARIEN=$P(ARTMP,";",2) -"RTN","GPLALERT",91,0) - . . S ARDES=$P(ARTMP,";",1) -"RTN","GPLALERT",92,0) - . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") -"RTN","GPLALERT",93,0) - . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES -"RTN","GPLALERT",94,0) - . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL -"RTN","GPLALERT",95,0) - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID -"RTN","GPLALERT",96,0) - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" -"RTN","GPLALERT",97,0) - . E D ; IF IT IS NULL DON'T SET CODE SYSTEM -"RTN","GPLALERT",98,0) - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" -"RTN","GPLALERT",99,0) - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" -"RTN","GPLALERT",100,0) - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) -"RTN","GPLALERT",101,0) - . K @ALTARYTMP -"RTN","GPLALERT",102,0) - . D MAP^GPLXPATH(ALTXML,ALTVMAP,ALTARYTMP) -"RTN","GPLALERT",103,0) - . I ALTCNT=1 D CP^GPLXPATH(ALTARYTMP,ALTOUTXML) -"RTN","GPLALERT",104,0) - . I ALTCNT>1 D INSINNER^GPLXPATH(ALTOUTXML,ALTARYTMP) -"RTN","GPLALERT",105,0) - . S ALTCNT=ALTCNT+1 -"RTN","GPLALERT",106,0) - S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS -"RTN","GPLALERT",107,0) - Q -"RTN","GPLALERT",108,0) -PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER -"RTN","GPLALERT",109,0) - ; INGLB IS OF THE FORM: PSNDF(50.6, -"RTN","GPLALERT",110,0) - ; RETURN 50.6 -"RTN","GPLALERT",111,0) - Q $P($P(INGLB,"(",2),",",1) ; -"RTN","GPLCCD") -0^8^B114413975 -"RTN","GPLCCD",1,0) -GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 -"RTN","GPLCCD",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 14 -"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^15^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 14 -"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^13^B81968343 -"RTN","GPLCCR",1,0) -GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 -"RTN","GPLCCR",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 14 -"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,UDIR,UFN -"RTN","GPLCCR",34,0) - I '$D(DIR) S UDIR="" -"RTN","GPLCCR",35,0) - E S UDIR=DIR -"RTN","GPLCCR",36,0) - I '$D(FN) S UFN="" -"RTN","GPLCCR",37,0) - E S UFN=FN -"RTN","GPLCCR",38,0) - D CCRRPC(.CCRGLO,DFN,"CCR","","","") -"RTN","GPLCCR",39,0) - S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCR",1)) -"RTN","GPLCCR",40,0) - S ONAM=UFN -"RTN","GPLCCR",41,0) - I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_5.xml" -"RTN","GPLCCR",42,0) - S ODIRGLB=$NA(^TMP("GPLCCR","ODIR")) -"RTN","GPLCCR",43,0) - I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET -"RTN","GPLCCR",44,0) - . ;S @ODIRGLB="/home/glilly/CCROUT" -"RTN","GPLCCR",45,0) - . ;S @ODIRGLB="/home/cedwards/" -"RTN","GPLCCR",46,0) - . S @ODIRGLB="/opt/wv/p/" -"RTN","GPLCCR",47,0) - S ODIR=UDIR -"RTN","GPLCCR",48,0) - I UDIR="" S ODIR=@ODIRGLB -"RTN","GPLCCR",49,0) - N ZY -"RTN","GPLCCR",50,0) - S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) -"RTN","GPLCCR",51,0) - W !,$P(ZY,U,2),! -"RTN","GPLCCR",52,0) - Q -"RTN","GPLCCR",53,0) - ; -"RTN","GPLCCR",54,0) -DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED -"RTN","GPLCCR",55,0) - ; -"RTN","GPLCCR",56,0) - N G1 -"RTN","GPLCCR",57,0) - S G1=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) -"RTN","GPLCCR",58,0) - I $D(@G1@(0)) D ; CCR EXISTS -"RTN","GPLCCR",59,0) - . D PARY^GPLXPATH(G1) -"RTN","GPLCCR",60,0) - E W "CCR NOT CREATED, RUN D XPAT^GPLCCR(DFN,"""","""") FIRST",! -"RTN","GPLCCR",61,0) - Q -"RTN","GPLCCR",62,0) - ; -"RTN","GPLCCR",63,0) -CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT -"RTN","GPLCCR",64,0) - ; CCRGRTN IS RETURN ARRAY PASSED BY NAME -"RTN","GPLCCR",65,0) - ; DFN IS PATIENT IEN -"RTN","GPLCCR",66,0) - ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART -"RTN","GPLCCR",67,0) - ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC -"RTN","GPLCCR",68,0) - ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL -"RTN","GPLCCR",69,0) - ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME -"RTN","GPLCCR",70,0) - ; - NULL MEANS NOW -"RTN","GPLCCR",71,0) - ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND -"RTN","GPLCCR",72,0) - ; "TO" VARIABLES -"RTN","GPLCCR",73,0) - ; IF NULL WILL DEFAULT TO "FROM" DUZ AND "TO" DFN -"RTN","GPLCCR",74,0) - I '$D(DEBUG) S DEBUG=0 -"RTN","GPLCCR",75,0) - S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD -"RTN","GPLCCR",76,0) - I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION -"RTN","GPLCCR",77,0) - I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION -"RTN","GPLCCR",78,0) - I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING CCRMEDS SECTION -"RTN","GPLCCR",79,0) - S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE -"RTN","GPLCCR",80,0) - S CCRGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR -"RTN","GPLCCR",81,0) - S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS -"RTN","GPLCCR",82,0) - ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC -"RTN","GPLCCR",83,0) - S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL -"RTN","GPLCCR",84,0) - D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE -"RTN","GPLCCR",85,0) - D CP^GPLXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL -"RTN","GPLCCR",86,0) - ; -"RTN","GPLCCR",87,0) - ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL -"RTN","GPLCCR",88,0) - ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES -"RTN","GPLCCR",89,0) - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") -"RTN","GPLCCR",90,0) - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") -"RTN","GPLCCR",91,0) - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") -"RTN","GPLCCR",92,0) - I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! -"RTN","GPLCCR",93,0) - ; -"RTN","GPLCCR",94,0) - D HDRMAP(CCRGLO,DFN,HDRARY) ; MAP HEADER VARIABLES -"RTN","GPLCCR",95,0) - ; -"RTN","GPLCCR",96,0) - K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT -"RTN","GPLCCR",97,0) - S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS -"RTN","GPLCCR",98,0) - D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS -"RTN","GPLCCR",99,0) - N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD -"RTN","GPLCCR",100,0) - F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS -"RTN","GPLCCR",101,0) - . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE -"RTN","GPLCCR",102,0) - . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL -"RTN","GPLCCR",103,0) - . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL -"RTN","GPLCCR",104,0) - . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE -"RTN","GPLCCR",105,0) - . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS -"RTN","GPLCCR",106,0) - . S IXML="INXML" -"RTN","GPLCCR",107,0) - . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES -"RTN","GPLCCR",108,0) - . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY -"RTN","GPLCCR",109,0) - . ; W OXML,! -"RTN","GPLCCR",110,0) - . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL -"RTN","GPLCCR",111,0) - . I DEBUG W "RUNNING ",CALL,! -"RTN","GPLCCR",112,0) - . X CALL -"RTN","GPLCCR",113,0) - . ; NOW INSERT THE RESULTS IN THE CCR BUFFER -"RTN","GPLCCR",114,0) - . I @OXML@(0)'=0 D ; THERE IS A RESULT -"RTN","GPLCCR",115,0) - . . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") -"RTN","GPLCCR",116,0) - . . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! -"RTN","GPLCCR",117,0) - N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING -"RTN","GPLCCR",118,0) - D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST -"RTN","GPLCCR",119,0) - D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") -"RTN","GPLCCR",120,0) - D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") -"RTN","GPLCCR",121,0) - D INSINNER^GPLXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") -"RTN","GPLCCR",122,0) - N TRIMI,J,DONE S DONE=0 -"RTN","GPLCCR",123,0) - F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE -"RTN","GPLCCR",124,0) - . S J=$$TRIM^GPLXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS -"RTN","GPLCCR",125,0) - . I DEBUG W "TRIMMED",J,! -"RTN","GPLCCR",126,0) - . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE -"RTN","GPLCCR",127,0) - Q -"RTN","GPLCCR",128,0) - ; -"RTN","GPLCCR",129,0) -INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS -"RTN","GPLCCR",130,0) - ; TAB IS PASSED BY NAME -"RTN","GPLCCR",131,0) - I DEBUG W "TAB= ",TAB,! -"RTN","GPLCCR",132,0) - ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS -"RTN","GPLCCR",133,0) - D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") -"RTN","GPLCCR",134,0) - D PUSH^GPLXPATH(TAB,"EXTRACT;CCRMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") -"RTN","GPLCCR",135,0) - D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") -"RTN","GPLCCR",136,0) - I TESTLAB D PUSH^GPLXPATH(TAB,"EXTRACT;GPLLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""GPLCCR"",$J,DFN,""RESULTS"")") -"RTN","GPLCCR",137,0) - I TESTALERT D PUSH^GPLXPATH(TAB,"EXTRACT;GPLALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""GPLCCR"",$J,DFN,""ALERTS"")") -"RTN","GPLCCR",138,0) - Q -"RTN","GPLCCR",139,0) - ; -"RTN","GPLCCR",140,0) -HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT -"RTN","GPLCCR",141,0) - N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) -"RTN","GPLCCR",142,0) - ; K @VMAP -"RTN","GPLCCR",143,0) - S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") -"RTN","GPLCCR",144,0) - I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS -"RTN","GPLCCR",145,0) - . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN -"RTN","GPLCCR",146,0) - . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? -"RTN","GPLCCR",147,0) - . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM -"RTN","GPLCCR",148,0) - . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES -"RTN","GPLCCR",149,0) - . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES -"RTN","GPLCCR",150,0) - . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES -"RTN","GPLCCR",151,0) - . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT -"RTN","GPLCCR",152,0) - I IHDR'="" D ; HEADER VALUES ARE PROVIDED -"RTN","GPLCCR",153,0) - . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY -"RTN","GPLCCR",154,0) - N CTMP -"RTN","GPLCCR",155,0) - D MAP^GPLXPATH(CXML,VMAP,"CTMP") -"RTN","GPLCCR",156,0) - D CP^GPLXPATH("CTMP",CXML) -"RTN","GPLCCR",157,0) - Q -"RTN","GPLCCR",158,0) - ; -"RTN","GPLCCR",159,0) -ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML -"RTN","GPLCCR",160,0) - ; AXML AND ACTRTN ARE PASSED BY NAME -"RTN","GPLCCR",161,0) - ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 -"RTN","GPLCCR",162,0) - ; P1= OBJECTID - ACTORPATIENT_2 -"RTN","GPLCCR",163,0) - ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE -"RTN","GPLCCR",164,0) - ;OR INSTITUTION -"RTN","GPLCCR",165,0) - ; OR PERSON(IN PATIENT FILE IE NOK) -"RTN","GPLCCR",166,0) - ; P3= IEN RECORD NUMBER FOR ACTOR - 2 -"RTN","GPLCCR",167,0) - N I,J,K,L -"RTN","GPLCCR",168,0) - K @ACTRTN ; CLEAR RETURN ARRAY -"RTN","GPLCCR",169,0) - F I=1:1:@AXML@(0) D ; SCAN ALL LINES -"RTN","GPLCCR",170,0) - . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE -"RTN","GPLCCR",171,0) - . . S J=$P($P(@AXML@(I),"",2),"",1) -"RTN","GPLCCR",172,0) - . . I DEBUG W "=>",J,! -"RTN","GPLCCR",173,0) - . . I J'="" S K(J)="" ; HASHING ACTOR -"RTN","GPLCCR",174,0) - . . ; TO GET RID OF DUPLICATES -"RTN","GPLCCR",175,0) - S I="" ; GOING TO $O THROUGH THE HASH -"RTN","GPLCCR",176,0) - F J=0:0 D Q:$O(K(I))="" -"RTN","GPLCCR",177,0) - . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS -"RTN","GPLCCR",178,0) - . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID -"RTN","GPLCCR",179,0) - . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE -"RTN","GPLCCR",180,0) - . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR -"RTN","GPLCCR",181,0) - . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY -"RTN","GPLCCR",182,0) - Q -"RTN","GPLCCR",183,0) - ; -"RTN","GPLCCR",184,0) -TEST ; RUN ALL THE TEST CASES -"RTN","GPLCCR",185,0) - D TESTALL^GPLUNIT("GPLCCR") -"RTN","GPLCCR",186,0) - Q -"RTN","GPLCCR",187,0) - ; -"RTN","GPLCCR",188,0) -ZTEST(WHICH) ; RUN ONE SET OF TESTS -"RTN","GPLCCR",189,0) - N ZTMP -"RTN","GPLCCR",190,0) - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") -"RTN","GPLCCR",191,0) - D ZTEST^GPLUNIT(.ZTMP,WHICH) -"RTN","GPLCCR",192,0) - Q -"RTN","GPLCCR",193,0) - ; -"RTN","GPLCCR",194,0) -TLIST ; LIST THE TESTS -"RTN","GPLCCR",195,0) - N ZTMP -"RTN","GPLCCR",196,0) - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") -"RTN","GPLCCR",197,0) - D TLIST^GPLUNIT(.ZTMP) -"RTN","GPLCCR",198,0) - Q -"RTN","GPLCCR",199,0) - ; -"RTN","GPLCCR",200,0) - ;;> -"RTN","GPLCCR",201,0) - ;;> -"RTN","GPLCCR",202,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",203,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") -"RTN","GPLCCR",204,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",205,0) - ;;> -"RTN","GPLCCR",206,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",207,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") -"RTN","GPLCCR",208,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",209,0) - ;;> -"RTN","GPLCCR",210,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",211,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") -"RTN","GPLCCR",212,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",213,0) - ;;> -"RTN","GPLCCR",214,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",215,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") -"RTN","GPLCCR",216,0) - ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") -"RTN","GPLCCR",217,0) - ;;> -"RTN","GPLCCR",218,0) - ;;>>>D ZTEST^GPLCCR("ACTLST") -"RTN","GPLCCR",219,0) - ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") -"RTN","GPLCCR",220,0) - ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") -"RTN","GPLCCR",221,0) - ;;>>?G3(G3(0))["" -"RTN","GPLCCR",222,0) - ;;> -"RTN","GPLCCR",223,0) - ;;>>>D ZTEST^GPLCCR("CCR") -"RTN","GPLCCR",224,0) - ;;>>>W $$TRIM^GPLXPATH(CCRGLO) -"RTN","GPLCCR",225,0) - ;;> -"RTN","GPLCCR",226,0) - ;;>>>S TESTALERT=1 -"RTN","GPLCCR",227,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",228,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","ALERTS","","","") -"RTN","GPLCCR",229,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",230,0) - -"RTN","GPLCCR0") -0^14^B654420916 -"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 14 -"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","GPLLABS") -0^22^B74153607 -"RTN","GPLLABS",1,0) -GPLALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 -"RTN","GPLLABS",2,0) - ;;0.3;CCDCCR;nopatch;noreleasedate;Build 14 -"RTN","GPLLABS",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","GPLLABS",4,0) - ;General Public License See attached copy of the License. -"RTN","GPLLABS",5,0) - ; -"RTN","GPLLABS",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","GPLLABS",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","GPLLABS",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","GPLLABS",9,0) - ;(at your option) any later version. -"RTN","GPLLABS",10,0) - ; -"RTN","GPLLABS",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","GPLLABS",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","GPLLABS",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","GPLLABS",14,0) - ;GNU General Public License for more details. -"RTN","GPLLABS",15,0) - ; -"RTN","GPLLABS",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","GPLLABS",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","GPLLABS",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","GPLLABS",19,0) - ; -"RTN","GPLLABS",20,0) -EXTRACT(LABXML,DFN,LABOUTXML) ; EXTRACT LABS INTO PROVIDED XML TEMPLATE -"RTN","GPLLABS",21,0) - ; -"RTN","GPLLABS",22,0) - ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","GPLLABS",23,0) - ; -"RTN","GPLLABS",24,0) - ; -"RTN","GPLLABS",25,0) - ; -"RTN","GPLLABS",26,0) - ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR -"RTN","GPLLABS",27,0) - ; SET UP FOR LAB API CALL -"RTN","GPLLABS",28,0) - S C0CPTID=$$SSN^CCRDPT(DFN) ; GET THE SSN FOR THIS PATIENT -"RTN","GPLLABS",29,0) - I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT -"RTN","GPLLABS",30,0) - . W "LAB LOOKUP FAILED, NO SSN",! -"RTN","GPLLABS",31,0) - S C0CSPC="*" ; LOOKING FOR ALL LABS -"RTN","GPLLABS",32,0) - D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING -"RTN","GPLLABS",33,0) - D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY TO GET EVERYTHING -"RTN","GPLLABS",34,0) - S C0CR=$$GCPR^LA7QRY(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP -"RTN","GPLLABS",35,0) - W "i'm back",! -"RTN","GPLLABS",36,0) - Q -"RTN","GPLLABS",37,0) - ; -"RTN","GPLLABS",38,0) -LIST ; LIST THE HL7 MESSAGE -"RTN","GPLLABS",39,0) - ; -"RTN","GPLLABS",40,0) - ; N C0CI,C0CJ,C0COBT,C0CHB -"RTN","GPLLABS",41,0) - ; D EXTRACT^GPLLABS(,1,) -"RTN","GPLLABS",42,0) - S C0CTAB=$NA(^KBAI) ; BASE OF OBX TABLE -"RTN","GPLLABS",43,0) - S C0CHB=$NA(^TMP("HLS",$J)) -"RTN","GPLLABS",44,0) - S C0CI="" -"RTN","GPLLABS",45,0) - F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG -"RTN","GPLLABS",46,0) - . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) -"RTN","GPLLABS",47,0) - . D LTYP(@C0CHB@(C0CI),C0CTYP) -"RTN","GPLLABS",48,0) - . W C0CI," ",C0CTYP,! -"RTN","GPLLABS",49,0) - . ; S C0CI=$O(@C0CHB@(C0CI)) -"RTN","GPLLABS",50,0) - Q -"RTN","GPLLABS",51,0) -LTYP(OSEG,OTYP) ; -"RTN","GPLLABS",52,0) - S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE -"RTN","GPLLABS",53,0) - I 1 D ; FOR HL7 SEGMENT TYPE -"RTN","GPLLABS",54,0) - . S OI="" ; INDEX INTO FIELDS IN SEG -"RTN","GPLLABS",55,0) - . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT -"RTN","GPLLABS",56,0) - . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX -"RTN","GPLLABS",57,0) - . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED -"RTN","GPLLABS",58,0) - . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE -"RTN","GPLLABS",59,0) - . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE -"RTN","GPLLABS",60,0) - . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX -"RTN","GPLLABS",61,0) - . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE -"RTN","GPLLABS",62,0) - . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! -"RTN","GPLLABS",63,0) - Q -"RTN","GPLLABS",64,0) -LOBX ; -"RTN","GPLLABS",65,0) - Q -"RTN","GPLLABS",66,0) - ; -"RTN","GPLLABS",67,0) -SETTBL ; -"RTN","GPLLABS",68,0) - K X ; CLEAR X -"RTN","GPLLABS",69,0) - S X("PID","PID1")="1^00104^Set ID - Patient ID" -"RTN","GPLLABS",70,0) - S X("PID","PID2")="2^00105^Patient ID (External ID)" -"RTN","GPLLABS",71,0) - S X("PID","PID3")="3^00106^Patient ID (Internal ID)" -"RTN","GPLLABS",72,0) - S X("PID","PID4")="4^00107^Alternate Patient ID" -"RTN","GPLLABS",73,0) - S X("PID","PID5")="5^00108^Patient's Name" -"RTN","GPLLABS",74,0) - S X("PID","PID6")="6^00109^Mother's Maiden Name" -"RTN","GPLLABS",75,0) - S X("PID","PID7")="7^00110^Date of Birth" -"RTN","GPLLABS",76,0) - S X("PID","PID8")="8^00111^Sex" -"RTN","GPLLABS",77,0) - S X("PID","PID9")="9^00112^Patient Alias" -"RTN","GPLLABS",78,0) - S X("PID","PID10")="10^00113^Race" -"RTN","GPLLABS",79,0) - S X("PID","PID11")="11^00114^Patient Address" -"RTN","GPLLABS",80,0) - S X("PID","PID12")="12^00115^County Code" -"RTN","GPLLABS",81,0) - S X("PID","PID13")="13^00116^Phone Number - Home" -"RTN","GPLLABS",82,0) - S X("PID","PID14")="14^00117^Phone Number - Business" -"RTN","GPLLABS",83,0) - S X("PID","PID15")="15^00118^Language - Patient" -"RTN","GPLLABS",84,0) - S X("PID","PID16")="16^00119^Marital Status" -"RTN","GPLLABS",85,0) - S X("PID","PID17")="17^00120^Religion" -"RTN","GPLLABS",86,0) - S X("PID","PID18")="18^00121^Patient Account Number" -"RTN","GPLLABS",87,0) - S X("PID","PID19")="19^00122^SSN Number - Patient" -"RTN","GPLLABS",88,0) - S X("PID","PID20")="20^00123^Drivers License - Patient" -"RTN","GPLLABS",89,0) - S X("PID","PID21")="21^00124^Mother's Identifier" -"RTN","GPLLABS",90,0) - S X("PID","PID22")="22^00125^Ethnic Group" -"RTN","GPLLABS",91,0) - S X("PID","PID23")="23^00126^Birth Place" -"RTN","GPLLABS",92,0) - S X("PID","PID24")="24^00127^Multiple Birth Indicator" -"RTN","GPLLABS",93,0) - S X("PID","PID25")="25^00128^Birth Order" -"RTN","GPLLABS",94,0) - S X("PID","PID26")="26^00129^Citizenship" -"RTN","GPLLABS",95,0) - S X("PID","PID27")="27^00130^Veteran.s Military Status" -"RTN","GPLLABS",96,0) - S X("PID","PID28")="28^00739^Nationality" -"RTN","GPLLABS",97,0) - S X("PID","PID29")="29^00740^Patient Death Date/Time" -"RTN","GPLLABS",98,0) - S X("PID","PID30")="30^00741^Patient Death Indicator" -"RTN","GPLLABS",99,0) - S X("NTE","NTE1")="1^00573^Set ID - NTE" -"RTN","GPLLABS",100,0) - S X("NTE","NTE2")="2^00574^Source of Comment" -"RTN","GPLLABS",101,0) - S X("NTE","NTE3")="3^00575^Comment" -"RTN","GPLLABS",102,0) - S X("ORC","ORC1")="1^00215^Order Control" -"RTN","GPLLABS",103,0) - S X("ORC","ORC2")="2^00216^Placer Order Number" -"RTN","GPLLABS",104,0) - S X("ORC","ORC3")="3^00217^Filler Order Number" -"RTN","GPLLABS",105,0) - S X("ORC","ORC4")="4^00218^Placer Order Number" -"RTN","GPLLABS",106,0) - S X("ORC","ORC5")="5^00219^Order Status" -"RTN","GPLLABS",107,0) - S X("ORC","ORC6")="6^00220^Response Flag" -"RTN","GPLLABS",108,0) - S X("ORC","ORC7")="7^00221^Quantity/Timing" -"RTN","GPLLABS",109,0) - S X("ORC","ORC8")="8^00222^Parent" -"RTN","GPLLABS",110,0) - S X("ORC","ORC9")="9^00223^Date/Time of Transaction" -"RTN","GPLLABS",111,0) - S X("ORC","ORC10")="10^00224^Entered By" -"RTN","GPLLABS",112,0) - S X("ORC","ORC11")="11^00225^Verified By" -"RTN","GPLLABS",113,0) - S X("ORC","ORC12")="12^00226^Ordering Provider" -"RTN","GPLLABS",114,0) - S X("ORC","ORC13")="13^00227^Enterer's Location" -"RTN","GPLLABS",115,0) - S X("ORC","ORC14")="14^00228^Call Back Phone Number" -"RTN","GPLLABS",116,0) - S X("ORC","ORC15")="15^00229^Order Effective Date/Time" -"RTN","GPLLABS",117,0) - S X("ORC","ORC16")="16^00230^Order Control Code Reason" -"RTN","GPLLABS",118,0) - S X("ORC","ORC17")="17^00231^Entering Organization" -"RTN","GPLLABS",119,0) - S X("ORC","ORC18")="18^00232^Entering Device" -"RTN","GPLLABS",120,0) - S X("ORC","ORC19")="19^00233^Action By" -"RTN","GPLLABS",121,0) - S X("OBR","OBR1")="1^00237^Set ID - Observation Request" -"RTN","GPLLABS",122,0) - S X("OBR","OBR2")="2^00216^Placer Order Number" -"RTN","GPLLABS",123,0) - S X("OBR","OBR3")="3^00217^Filler Order Number" -"RTN","GPLLABS",124,0) - S X("OBR","OBR4")="4^00238^Universal Service ID" -"RTN","GPLLABS",125,0) - S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" -"RTN","GPLLABS",126,0) - S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" -"RTN","GPLLABS",127,0) - S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE" -"RTN","GPLLABS",128,0) - S X("OBR","OBR5")="5^00239^Priority" -"RTN","GPLLABS",129,0) - S X("OBR","OBR6")="6^00240^Requested Date/Time" -"RTN","GPLLABS",130,0) - S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" -"RTN","GPLLABS",131,0) - S X("OBR","OBR8")="8^00242^Observation End Date/Time" -"RTN","GPLLABS",132,0) - S X("OBR","OBR9")="9^00243^Collection Volume" -"RTN","GPLLABS",133,0) - S X("OBR","OBR10")="10^00244^Collector Identifier" -"RTN","GPLLABS",134,0) - S X("OBR","OBR11")="11^00245^Specimen Action Code" -"RTN","GPLLABS",135,0) - S X("OBR","OBR12")="12^00246^Danger Code" -"RTN","GPLLABS",136,0) - S X("OBR","OBR13")="13^00247^Relevant Clinical Info." -"RTN","GPLLABS",137,0) - S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" -"RTN","GPLLABS",138,0) - S X("OBR","OBR15")="15^00249^Specimen Source" -"RTN","GPLLABS",139,0) - S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" -"RTN","GPLLABS",140,0) - S X("OBR","OBR17")="17^00250^Order Callback Phone Number" -"RTN","GPLLABS",141,0) - S X("OBR","OBR18")="18^00251^Placers Field 1" -"RTN","GPLLABS",142,0) - S X("OBR","OBR19")="19^00252^Placers Field 2" -"RTN","GPLLABS",143,0) - S X("OBR","OBR20")="20^00253^Filler Field 1" -"RTN","GPLLABS",144,0) - S X("OBR","OBR21")="21^00254^Filler Field 2" -"RTN","GPLLABS",145,0) - S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" -"RTN","GPLLABS",146,0) - S X("OBR","OBR23")="23^00256^Charge to Practice" -"RTN","GPLLABS",147,0) - S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" -"RTN","GPLLABS",148,0) - S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" -"RTN","GPLLABS",149,0) - S X("OBR","OBR26")="26^00259^Parent Result" -"RTN","GPLLABS",150,0) - S X("OBR","OBR27")="27^00221^Quantity/Timing" -"RTN","GPLLABS",151,0) - S X("OBR","OBR28")="28^00260^Result Copies to" -"RTN","GPLLABS",152,0) - S X("OBR","OBR29")="29^00261^Parent Number" -"RTN","GPLLABS",153,0) - S X("OBR","OBR30")="30^00262^Transportation Mode" -"RTN","GPLLABS",154,0) - S X("OBR","OBR31")="31^00263^Reason for Study" -"RTN","GPLLABS",155,0) - S X("OBR","OBR32")="32^00264^Principal Result Interpreter" -"RTN","GPLLABS",156,0) - S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" -"RTN","GPLLABS",157,0) - S X("OBR","OBR34")="34^00266^Technician" -"RTN","GPLLABS",158,0) - S X("OBR","OBR35")="35^00267^Transcriptionist" -"RTN","GPLLABS",159,0) - S X("OBR","OBR36")="36^00268^Scheduled Date/Time" -"RTN","GPLLABS",160,0) - S X("OBR","OBR37")="37^01028^Number of Sample Containers" -"RTN","GPLLABS",161,0) - S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" -"RTN","GPLLABS",162,0) - S X("OBR","OBR39")="39^01030^Collector.s Comment" -"RTN","GPLLABS",163,0) - S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" -"RTN","GPLLABS",164,0) - S X("OBR","OBR41")="41^01032^Transport Arranged" -"RTN","GPLLABS",165,0) - S X("OBR","OBR42")="42^01033^Escort Required" -"RTN","GPLLABS",166,0) - S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" -"RTN","GPLLABS",167,0) - S X("OBX","OBX1")="1^00559^Set ID - OBX" -"RTN","GPLLABS",168,0) - S X("OBX","OBX2")="2^00676^Value Type" -"RTN","GPLLABS",169,0) - S X("OBX","OBX3")="3^00560^Observation Identifier" -"RTN","GPLLABS",170,0) - S X("OBX","OBX3;LOINC")="3;4^00560^Observation Identifier^RESULTTESTCODEVALUE" -"RTN","GPLLABS",171,0) - S X("OBX","OBX3;DESC")="3;5^00560^Observation Identifier^RESULTTESTDESCRIPTIONTEXT" -"RTN","GPLLABS",172,0) - S X("OBX","OBX3;VACODE")="3;6^00560^Observation Identifier" -"RTN","GPLLABS",173,0) - S X("OBX","OBX4")="4^00769^Observation Sub-Id" -"RTN","GPLLABS",174,0) - S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" -"RTN","GPLLABS",175,0) - S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" -"RTN","GPLLABS",176,0) - S X("OBX","OBX7")="7^00563^Reference Range^" -"RTN","GPLLABS",177,0) - S X("OBX","OBX8")="8^00564^Abnormal Flags" -"RTN","GPLLABS",178,0) - S X("OBX","OBX9")="9^00639^Probability" -"RTN","GPLLABS",179,0) - S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" -"RTN","GPLLABS",180,0) - S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" -"RTN","GPLLABS",181,0) - S X("OBX","OBX12")="12^00567^Date Last Normal Value" -"RTN","GPLLABS",182,0) - S X("OBX","OBX13")="13^00581^User Defined Access Checks" -"RTN","GPLLABS",183,0) - S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" -"RTN","GPLLABS",184,0) - S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" -"RTN","GPLLABS",185,0) - S X("OBX","OBX16")="16^00584^Responsible Observer" -"RTN","GPLLABS",186,0) - S X("OBX","OBX17")="17^00936^Observation Method" -"RTN","GPLLABS",187,0) - M ^KBAI=X ; SET VALUES IN ^KBAI -"RTN","GPLLABS",188,0) - Q -"RTN","GPLLABS",189,0) - ; -"RTN","GPLPROBS") -0^20^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 14 -"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^18^B228265839 -"RTN","GPLRIMA",1,0) -GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 -"RTN","GPLRIMA",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 14 -"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) - . I $D(^TMP("GPLALERT",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST -"RTN","GPLRIMA",68,0) - . . W "FOUND ALERT VARS",! -"RTN","GPLRIMA",69,0) - . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("GPLALERT",$J,"ALERTS") -"RTN","GPLRIMA",70,0) - . K ^TMP("GPLCCR",$J) ; KILL WORK AREA FOR CCR BUILDING -"RTN","GPLRIMA",71,0) - . ; -"RTN","GPLRIMA",72,0) - . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP -"RTN","GPLRIMA",73,0) - . ; -"RTN","GPLRIMA",74,0) - . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS -"RTN","GPLRIMA",75,0) - . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT -"RTN","GPLRIMA",76,0) - . ; -"RTN","GPLRIMA",77,0) - . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL -"RTN","GPLRIMA",78,0) - . ; -"RTN","GPLRIMA",79,0) - . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS -"RTN","GPLRIMA",80,0) - . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED -"RTN","GPLRIMA",81,0) - . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT -"RTN","GPLRIMA",82,0) - . ; -"RTN","GPLRIMA",83,0) - . N CATNAME,CATTBL -"RTN","GPLRIMA",84,0) - . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) -"RTN","GPLRIMA",85,0) - . S CATNAME="" -"RTN","GPLRIMA",86,0) - . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY -"RTN","GPLRIMA",87,0) - . W "CATEGORY NAME: ",CATNAME,! -"RTN","GPLRIMA",88,0) - . ; -"RTN","GPLRIMA",89,0) - . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^CCRSYS(RIMDFN) ; NEXT PATIENT -"RTN","GPLRIMA",90,0) - . ; PTST TESTS TO SEE IF PATIENT WAS MERGED -"RTN","GPLRIMA",91,0) - . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT -"RTN","GPLRIMA",92,0) - . ; AND WE SKIP IT -"RTN","GPLRIMA",93,0) - . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN -"RTN","GPLRIMA",94,0) - ; D PARY^GPLXPATH(@RIMBASE@("ATTRTBL")) -"RTN","GPLRIMA",95,0) - Q -"RTN","GPLRIMA",96,0) - ; -"RTN","GPLRIMA",97,0) -SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS -"RTN","GPLRIMA",98,0) - N SBASE,SATTR -"RTN","GPLRIMA",99,0) - S SBASE=$NA(@RIMBASE@("VARS",SDFN)) -"RTN","GPLRIMA",100,0) - D APOST("SATTR","RIMTBL","HEADER") -"RTN","GPLRIMA",101,0) - I $D(@SBASE@("PROBLEMS",1)) D ; -"RTN","GPLRIMA",102,0) - . D APOST("SATTR","RIMTBL","PROBLEMS") -"RTN","GPLRIMA",103,0) - . ; W "POSTING PROBLEMS",! -"RTN","GPLRIMA",104,0) - I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") -"RTN","GPLRIMA",105,0) - I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES -"RTN","GPLRIMA",106,0) - . D APOST("SATTR","RIMTBL","MEDS") -"RTN","GPLRIMA",107,0) - . N ZR,ZI -"RTN","GPLRIMA",108,0) - . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES -"RTN","GPLRIMA",109,0) - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN -"RTN","GPLRIMA",110,0) - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS -"RTN","GPLRIMA",111,0) - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES -"RTN","GPLRIMA",112,0) - . ; D PATD^GPLRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES -"RTN","GPLRIMA",113,0) - I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS -"RTN","GPLRIMA",114,0) - . D APOST("SATTR","RIMTBL","ALERTS") -"RTN","GPLRIMA",115,0) - . N ZR,ZI -"RTN","GPLRIMA",116,0) - . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES -"RTN","GPLRIMA",117,0) - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN -"RTN","GPLRIMA",118,0) - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS -"RTN","GPLRIMA",119,0) - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES -"RTN","GPLRIMA",120,0) - ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED -"RTN","GPLRIMA",121,0) - W "ATTRIBUTES: ",SATTR,! -"RTN","GPLRIMA",122,0) - Q SATTR -"RTN","GPLRIMA",123,0) - ; -"RTN","GPLRIMA",124,0) -RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES -"RTN","GPLRIMA",125,0) - K ^TMP("GPLRIM","RESUME") -"RTN","GPLRIMA",126,0) - K ^TMP("GPLRIM") -"RTN","GPLRIMA",127,0) - Q -"RTN","GPLRIMA",128,0) - ; -"RTN","GPLRIMA",129,0) -CLIST ; LIST THE CATEGORIES -"RTN","GPLRIMA",130,0) - ; -"RTN","GPLRIMA",131,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",132,0) - N CLBASE,CLNUM,ZI,CLIDX -"RTN","GPLRIMA",133,0) - S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) -"RTN","GPLRIMA",134,0) - S CLNUM=@CLBASE@(0) -"RTN","GPLRIMA",135,0) - F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES -"RTN","GPLRIMA",136,0) - . S CLIDX=@CLBASE@(ZI) -"RTN","GPLRIMA",137,0) - . W "(",$P(@CLBASE@(CLIDX),"^",1) -"RTN","GPLRIMA",138,0) - . W ":",$P(@CLBASE@(CLIDX),"^",2),") " -"RTN","GPLRIMA",139,0) - . W CLIDX,! -"RTN","GPLRIMA",140,0) - ; D PARY^GPLXPATH(CLBASE) -"RTN","GPLRIMA",141,0) - Q -"RTN","GPLRIMA",142,0) - ; -"RTN","GPLRIMA",143,0) -CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES -"RTN","GPLRIMA",144,0) - ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT -"RTN","GPLRIMA",145,0) - ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE -"RTN","GPLRIMA",146,0) - ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME -"RTN","GPLRIMA",147,0) - ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, -"RTN","GPLRIMA",148,0) - ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" -"RTN","GPLRIMA",149,0) - ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES -"RTN","GPLRIMA",150,0) - ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY -"RTN","GPLRIMA",151,0) - ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING -"RTN","GPLRIMA",152,0) - ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY -"RTN","GPLRIMA",153,0) - ; NUMBER IE CTBL_X(CDFN)="" -"RTN","GPLRIMA",154,0) - ; -"RTN","GPLRIMA",155,0) - ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST -"RTN","GPLRIMA",156,0) - S CCTBL=$NA(@CBASE@(CTBL,"CATS")) -"RTN","GPLRIMA",157,0) - W "CBASE: ",CCTBL,! -"RTN","GPLRIMA",158,0) - ; -"RTN","GPLRIMA",159,0) - I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY -"RTN","GPLRIMA",160,0) - . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY -"RTN","GPLRIMA",161,0) - . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY -"RTN","GPLRIMA",162,0) - . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT -"RTN","GPLRIMA",163,0) - . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY -"RTN","GPLRIMA",164,0) - . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME -"RTN","GPLRIMA",165,0) - . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 -"RTN","GPLRIMA",166,0) - ; -"RTN","GPLRIMA",167,0) - S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY -"RTN","GPLRIMA",168,0) - S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT -"RTN","GPLRIMA",169,0) - S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK -"RTN","GPLRIMA",170,0) - ; -"RTN","GPLRIMA",171,0) - S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED -"RTN","GPLRIMA",172,0) - ; -"RTN","GPLRIMA",173,0) - S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT -"RTN","GPLRIMA",174,0) - W "PATS BASE: ",CPATLIST,! -"RTN","GPLRIMA",175,0) - S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST -"RTN","GPLRIMA",176,0) - ; -"RTN","GPLRIMA",177,0) - Q -"RTN","GPLRIMA",178,0) - ; -"RTN","GPLRIMA",179,0) -CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE -"RTN","GPLRIMA",180,0) - ; -"RTN","GPLRIMA",181,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",182,0) - N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT -"RTN","GPLRIMA",183,0) - S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES -"RTN","GPLRIMA",184,0) - S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS -"RTN","GPLRIMA",185,0) - S ZTOT=0 ; INITIALIZE OVERALL TOTAL -"RTN","GPLRIMA",186,0) - F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS -"RTN","GPLRIMA",187,0) - . S ZCNT=0 -"RTN","GPLRIMA",188,0) - . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY -"RTN","GPLRIMA",189,0) - . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME -"RTN","GPLRIMA",190,0) - . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST -"RTN","GPLRIMA",191,0) - . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS -"RTN","GPLRIMA",192,0) - . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT -"RTN","GPLRIMA",193,0) - . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! -"RTN","GPLRIMA",194,0) - . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) -"RTN","GPLRIMA",195,0) - . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) -"RTN","GPLRIMA",196,0) - . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD -"RTN","GPLRIMA",197,0) - . S ZTOT=ZTOT+ZCNT -"RTN","GPLRIMA",198,0) - W "TOTAL: ",ZTOT,! -"RTN","GPLRIMA",199,0) - Q -"RTN","GPLRIMA",200,0) - ; -"RTN","GPLRIMA",201,0) -CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST -"RTN","GPLRIMA",202,0) - ; INLST IS PASSED BY NAME -"RTN","GPLRIMA",203,0) - N ZI,ZDX,ZCOUNT -"RTN","GPLRIMA",204,0) - W INLST,! -"RTN","GPLRIMA",205,0) - S ZCOUNT=0 -"RTN","GPLRIMA",206,0) - S ZDX="" -"RTN","GPLRIMA",207,0) - F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END -"RTN","GPLRIMA",208,0) - . S ZCOUNT=ZCOUNT+1 -"RTN","GPLRIMA",209,0) - . S ZDX=$O(@INLST@(ZDX)) -"RTN","GPLRIMA",210,0) - . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! -"RTN","GPLRIMA",211,0) - Q ZCOUNT -"RTN","GPLRIMA",212,0) - ; -"RTN","GPLRIMA",213,0) -XCPAT(CPATCAT) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT -"RTN","GPLRIMA",214,0) - ; -"RTN","GPLRIMA",215,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",216,0) - N ZI,ZJ,ZC,ZPATBASE -"RTN","GPLRIMA",217,0) - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) -"RTN","GPLRIMA",218,0) - S ZI="" -"RTN","GPLRIMA",219,0) - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END -"RTN","GPLRIMA",220,0) - . S ZI=$O(@ZPATBASE@(ZI)) -"RTN","GPLRIMA",221,0) - . D XPAT^GPLCCR(ZI,"","") ; EXPORT THE PATIENT TO A FILE -"RTN","GPLRIMA",222,0) - Q -"RTN","GPLRIMA",223,0) - ; -"RTN","GPLRIMA",224,0) -CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT -"RTN","GPLRIMA",225,0) - ; -"RTN","GPLRIMA",226,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",227,0) - N ZI,ZJ,ZC,ZPATBASE -"RTN","GPLRIMA",228,0) - S ZC=0 ; COUNT FOR SPACING THE PRINTOUT -"RTN","GPLRIMA",229,0) - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) -"RTN","GPLRIMA",230,0) - S ZI="" -"RTN","GPLRIMA",231,0) - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END -"RTN","GPLRIMA",232,0) - . S ZI=$O(@ZPATBASE@(ZI)) -"RTN","GPLRIMA",233,0) - . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT -"RTN","GPLRIMA",234,0) - . W ZI," " -"RTN","GPLRIMA",235,0) - . I ZC=10 D ; NEW LINE -"RTN","GPLRIMA",236,0) - . . S ZC=0 -"RTN","GPLRIMA",237,0) - . . W ! -"RTN","GPLRIMA",238,0) - Q -"RTN","GPLRIMA",239,0) - ; -"RTN","GPLRIMA",240,0) -PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT -"RTN","GPLRIMA",241,0) - ; -"RTN","GPLRIMA",242,0) - N ATTR S ATTR="" -"RTN","GPLRIMA",243,0) - I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT -"RTN","GPLRIMA",244,0) - . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT -"RTN","GPLRIMA",245,0) - S ATTR=^TMP("GPLRIM","ATTR",DFN) -"RTN","GPLRIMA",246,0) - I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND -"RTN","GPLRIMA",247,0) - I $D(^TMP("GPLRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT -"RTN","GPLRIMA",248,0) - . N CAT -"RTN","GPLRIMA",249,0) - . S CAT=$P(^TMP("GPLRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT -"RTN","GPLRIMA",250,0) - . W CAT,": ",ATTR,! -"RTN","GPLRIMA",251,0) - Q -"RTN","GPLRIMA",252,0) - ; -"RTN","GPLRIMA",253,0) -APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) -"RTN","GPLRIMA",254,0) - ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT -"RTN","GPLRIMA",255,0) - ; AND AMAP(N)=AVAL IS THE NTH AVAL -"RTN","GPLRIMA",256,0) - ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE -"RTN","GPLRIMA",257,0) - ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE -"RTN","GPLRIMA",258,0) - ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED -"RTN","GPLRIMA",259,0) - ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED -"RTN","GPLRIMA",260,0) - ; -"RTN","GPLRIMA",261,0) - I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST -"RTN","GPLRIMA",262,0) - . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS -"RTN","GPLRIMA",263,0) - S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT -"RTN","GPLRIMA",264,0) - S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY -"RTN","GPLRIMA",265,0) - S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF -"RTN","GPLRIMA",266,0) - Q -"RTN","GPLRIMA",267,0) - ; -"RTN","GPLRIMA",268,0) -ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL -"RTN","GPLRIMA",269,0) - I '$D(RIMBASE) S RIMBASE=$NA(^TMP("GPLRIM")) -"RTN","GPLRIMA",270,0) - I '$D(@RIMBASE) S @RIMBASE="" -"RTN","GPLRIMA",271,0) - I '$D(RIMTBL) S RIMTBL=$NA(^TMP("GPLRIM","RIMTBL","TABLE")) ; ATTR TABLE -"RTN","GPLRIMA",272,0) - S ^TMP("GPLRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES -"RTN","GPLRIMA",273,0) - Q -"RTN","GPLRIMA",274,0) - ; -"RTN","GPLRIMA",275,0) -AINIT ; INITIALIZE ATTRIBUTE TABLE -"RTN","GPLRIMA",276,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",277,0) - K @RIMTBL -"RTN","GPLRIMA",278,0) - D APUSH(RIMTBL,"EXTRACTED") -"RTN","GPLRIMA",279,0) - D APUSH(RIMTBL,"NOTEXTRACTED") -"RTN","GPLRIMA",280,0) - D APUSH(RIMTBL,"HEADER") -"RTN","GPLRIMA",281,0) - D APUSH(RIMTBL,"NOPCP") -"RTN","GPLRIMA",282,0) - D APUSH(RIMTBL,"PCP") -"RTN","GPLRIMA",283,0) - D APUSH(RIMTBL,"PROBLEMS") -"RTN","GPLRIMA",284,0) - D APUSH(RIMTBL,"PROBCODE") -"RTN","GPLRIMA",285,0) - D APUSH(RIMTBL,"PROBNOCODE") -"RTN","GPLRIMA",286,0) - D APUSH(RIMTBL,"PROBDATE") -"RTN","GPLRIMA",287,0) - D APUSH(RIMTBL,"PROBNODATE") -"RTN","GPLRIMA",288,0) - D APUSH(RIMTBL,"VITALS") -"RTN","GPLRIMA",289,0) - D APUSH(RIMTBL,"VITALSCODE") -"RTN","GPLRIMA",290,0) - D APUSH(RIMTBL,"VITALSNOCODE") -"RTN","GPLRIMA",291,0) - D APUSH(RIMTBL,"VITALSDATE") -"RTN","GPLRIMA",292,0) - D APUSH(RIMTBL,"VITALSNODATE") -"RTN","GPLRIMA",293,0) - D APUSH(RIMTBL,"MEDS") -"RTN","GPLRIMA",294,0) - D APUSH(RIMTBL,"MEDSCODE") -"RTN","GPLRIMA",295,0) - D APUSH(RIMTBL,"MEDSNOCODE") -"RTN","GPLRIMA",296,0) - D APUSH(RIMTBL,"MEDSDATE") -"RTN","GPLRIMA",297,0) - D APUSH(RIMTBL,"MEDSNODATE") -"RTN","GPLRIMA",298,0) - D APUSH(RIMTBL,"ALERTS") -"RTN","GPLRIMA",299,0) - D APUSH(RIMTBL,"ALERTSCODE") -"RTN","GPLRIMA",300,0) - Q -"RTN","GPLRIMA",301,0) - ; -"RTN","GPLRIMA",302,0) -APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL -"RTN","GPLRIMA",303,0) - ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING -"RTN","GPLRIMA",304,0) - ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES -"RTN","GPLRIMA",305,0) - ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) -"RTN","GPLRIMA",306,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING -"RTN","GPLRIMA",307,0) - N USETBL -"RTN","GPLRIMA",308,0) - I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE -"RTN","GPLRIMA",309,0) - . W "ERROR NO SUCH TABLE",! -"RTN","GPLRIMA",310,0) - S USETBL=@RIMBASE@("TABLES",PTBL) -"RTN","GPLRIMA",311,0) - S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL -"RTN","GPLRIMA",312,0) - Q -"RTN","GPLRIMA",313,0) -GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN -"RTN","GPLRIMA",314,0) - ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") -"RTN","GPLRIMA",315,0) - ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 -"RTN","GPLRIMA",316,0) - ; IN SECTION "MEDS" -"RTN","GPLRIMA",317,0) - ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS -"RTN","GPLRIMA",318,0) - ; PENDING FOR MED 2 FOR PATIENT 2 -"RTN","GPLRIMA",319,0) - ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE -"RTN","GPLRIMA",320,0) - ; RETURNED. RTN IS PASSED BY REFERENCE -"RTN","GPLRIMA",321,0) - ; -"RTN","GPLRIMA",322,0) - S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE -"RTN","GPLRIMA",323,0) - I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES -"RTN","GPLRIMA",324,0) - S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES -"RTN","GPLRIMA",325,0) - I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION -"RTN","GPLRIMA",326,0) - . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! -"RTN","GPLRIMA",327,0) - N ZZI,ZZS -"RTN","GPLRIMA",328,0) - S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT -"RTN","GPLRIMA",329,0) - ; ZWR @ZZS@(1) -"RTN","GPLRIMA",330,0) - S RTN(0)=@ZZS@(0) -"RTN","GPLRIMA",331,0) - F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) -"RTN","GPLRIMA",332,0) - . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE -"RTN","GPLRIMA",333,0) - . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE -"RTN","GPLRIMA",334,0) - Q -"RTN","GPLRIMA",335,0) - ; -"RTN","GPLRIMA",336,0) -PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR -"RTN","GPLRIMA",337,0) - ; -"RTN","GPLRIMA",338,0) - N ZR -"RTN","GPLRIMA",339,0) - D GETPA(.ZR,DFN,ISEC,IVAR) -"RTN","GPLRIMA",340,0) - I $D(ZR(0)) D PARY^GPLXPATH("ZR") -"RTN","GPLRIMA",341,0) - E W "NOTHING RETURNED",! -"RTN","GPLRIMA",342,0) - Q -"RTN","GPLRIMA",343,0) - ; -"RTN","GPLRIMA",344,0) -CAGET(RTN,IATTR) ; -"RTN","GPLRIMA",345,0) - ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR -"RTN","GPLRIMA",346,0) - ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE -"RTN","GPLRIMA",347,0) - ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC -"RTN","GPLRIMA",348,0) - Q -"RTN","GPLRIMA",349,0) - ; -"RTN","GPLRIMA",350,0) -PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR -"RTN","GPLRIMA",351,0) - ; -"RTN","GPLRIMA",352,0) - I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES -"RTN","GPLRIMA",353,0) - N ZLST -"RTN","GPLRIMA",354,0) - S LSTRTN(0)=0 ; DEFAULT RETURN NONE -"RTN","GPLRIMA",355,0) - S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES -"RTN","GPLRIMA",356,0) - S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS -"RTN","GPLRIMA",357,0) - N ZNC ; ZNC IS NUMBER OF CATEGORIES -"RTN","GPLRIMA",358,0) - S ZNC=@ZCBASE@(0) -"RTN","GPLRIMA",359,0) - I ZNC=0 Q ; NO CATEGORIES TO SEARCH -"RTN","GPLRIMA",360,0) - N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE -"RTN","GPLRIMA",361,0) - S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) -"RTN","GPLRIMA",362,0) - N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT -"RTN","GPLRIMA",363,0) - F ZI=1:1:ZNC D ; FOR ALL CATEGORIES -"RTN","GPLRIMA",364,0) - . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT -"RTN","GPLRIMA",365,0) - . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR -"RTN","GPLRIMA",366,0) - . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL -"RTN","GPLRIMA",367,0) - . . M LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT -"RTN","GPLRIMA",368,0) - S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS -"RTN","GPLRIMA",369,0) - S ZPAT=0 ; START AT FIRST PATIENT IN LIST -"RTN","GPLRIMA",370,0) - F S ZPAT=$O(LSTRTN(ZPAT)) Q:ZPAT="" D ; -"RTN","GPLRIMA",371,0) - . S ZCNT=ZCNT+1 -"RTN","GPLRIMA",372,0) - S LSTRTN(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY -"RTN","GPLRIMA",373,0) - Q -"RTN","GPLRIMA",374,0) - ; -"RTN","GPLRIMA",375,0) -DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR -"RTN","GPLRIMA",376,0) - ; -"RTN","GPLRIMA",377,0) - N ZR -"RTN","GPLRIMA",378,0) - D PCLST(.ZR,CATTR) -"RTN","GPLRIMA",379,0) - I ZR(0)=0 D Q ; -"RTN","GPLRIMA",380,0) - . W "NO PATIENTS RETURNED",! -"RTN","GPLRIMA",381,0) - E D ; -"RTN","GPLRIMA",382,0) - . D PARY^GPLXPATH("ZR") ; PRINT ARRAY -"RTN","GPLRIMA",383,0) - . W "COUNT=",ZR(0),! -"RTN","GPLRIMA",384,0) - Q -"RTN","GPLRIMA",385,0) - ; -"RTN","GPLRIMA",386,0) -RPCGV(RTN,DFN,WHICH) ; RPC GET VARS -"RTN","GPLRIMA",387,0) - ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES -"RTN","GPLRIMA",388,0) - ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT -"RTN","GPLRIMA",389,0) - ; DFN IS THE PATIENT NUMBER. -"RTN","GPLRIMA",390,0) - ; WHICH IS "ALL" OR "MEDS" OR "VITALS" OR "PROBLEMS" OR "ALERTS" OR "LABS" -"RTN","GPLRIMA",391,0) - ; OR OTHER SECTIONS AS THEY ARE ADDED -"RTN","GPLRIMA",392,0) - ; THIS IS MEANT TO BE AVAILABLE AS AN RPC -"RTN","GPLRIMA",393,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",394,0) - S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES -"RTN","GPLRIMA",395,0) - S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED -"RTN","GPLRIMA",396,0) - N ZZGI -"RTN","GPLRIMA",397,0) - I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS -"RTN","GPLRIMA",398,0) - . F ZZGI="PROBLEMS","VITALS","MEDS","ALERTS" D ; FOR EACH SECTION -"RTN","GPLRIMA",399,0) - . . D ZGVWRK(ZZGI) ; DO EACH SECTION -"RTN","GPLRIMA",400,0) - E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR -"RTN","GPLRIMA",401,0) - Q -"RTN","GPLRIMA",402,0) - ; -"RTN","GPLRIMA",403,0) -ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV -"RTN","GPLRIMA",404,0) - ; -"RTN","GPLRIMA",405,0) - N ZZGN ; NAME FOR SECTION VARIABLES -"RTN","GPLRIMA",406,0) - S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION -"RTN","GPLRIMA",407,0) - I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION -"RTN","GPLRIMA",408,0) - E D ; VARS EXIST -"RTN","GPLRIMA",409,0) - . N ZGVI -"RTN","GPLRIMA",410,0) - . F ZGVI=1:1:@ZZGN@(0) D ; FOR EACH MULTIPLE IN SECTION -"RTN","GPLRIMA",411,0) - . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS -"RTN","GPLRIMA",412,0) - . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE -"RTN","GPLRIMA",413,0) - . . S ZZGN2=$NA(@ZZGN@(ZGVI)) -"RTN","GPLRIMA",414,0) - . . ; W ZZGN2,!,$O(@ZZGN2@("")),! -"RTN","GPLRIMA",415,0) - . . D H2ARY^GPLXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY -"RTN","GPLRIMA",416,0) - . . ; D PARY^GPLXPATH("ZZGA") -"RTN","GPLRIMA",417,0) - . . D PUSHA^GPLXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN -"RTN","GPLRIMA",418,0) - Q -"RTN","GPLRIMA",419,0) - ; -"RTN","GPLRIMA",420,0) -DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN GPLRIM -"RTN","GPLRIMA",421,0) - ; ALONG WITH SAMPLE VALUES. -"RTN","GPLRIMA",422,0) - ; IWHICH IS "ALL" OR "MEDS" OR "VITALS" OR "PROBLEMS" OR "ALERTS" OR "LABS" -"RTN","GPLRIMA",423,0) - N GTMP -"RTN","GPLRIMA",424,0) - I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT -"RTN","GPLRIMA",425,0) - . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES -"RTN","GPLRIMA",426,0) - I '$D(IWHICH) S IWHICH="ALL" -"RTN","GPLRIMA",427,0) - D RPCGV(.GTMP,DFN,IWHICH) -"RTN","GPLRIMA",428,0) - D PARY^GPLXPATH("GTMP") -"RTN","GPLRIMA",429,0) - Q -"RTN","GPLRIMA",430,0) - ; -"RTN","GPLUNIT") -0^12^B31438520 -"RTN","GPLUNIT",1,0) -GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 -"RTN","GPLUNIT",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 14 -"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^17^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 14 -"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^21^B51026779 -"RTN","GPLXPAT0",1,0) -GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 -"RTN","GPLXPAT0",2,0) - ;;0.2;CCDCCR;nopatch;noreleasedate;Build 14 -"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^B242640815 -"RTN","GPLXPATH",1,0) -GPLXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 -"RTN","GPLXPATH",2,0) - ;;0.2;CCDCCR;nopatch;noreleasedate;Build 14 -"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,IPRE) ; CONVERT IHASH TO RETURN ARRAY -"RTN","GPLXPATH",436,0) - ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE -"RTN","GPLXPATH",437,0) - I '$D(IPRE) S IPRE="" -"RTN","GPLXPATH",438,0) - N H2I S H2I="" -"RTN","GPLXPATH",439,0) - ; W $O(@IHASH@(H2I)),! -"RTN","GPLXPATH",440,0) - F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH -"RTN","GPLXPATH",441,0) - . ; W H2I_"^"_@IHASH@(H2I),! -"RTN","GPLXPATH",442,0) - . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES -"RTN","GPLXPATH",443,0) - . . W "GPLZZ",! -"RTN","GPLXPATH",444,0) - . . W $NA(@IHASH@(H2I)),! -"RTN","GPLXPATH",445,0) - . . Q ; -"RTN","GPLXPATH",446,0) - . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) -"RTN","GPLXPATH",447,0) - . ; W @IARYRTN@(0),! -"RTN","GPLXPATH",448,0) - Q -"RTN","GPLXPATH",449,0) - ; -"RTN","GPLXPATH",450,0) -XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES -"RTN","GPLXPATH",451,0) - ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ -"RTN","GPLXPATH",452,0) - ; XVRTN AND XVIXML ARE PASSED BY NAME -"RTN","GPLXPATH",453,0) - ; -"RTN","GPLXPATH",454,0) - N XVI,XVTMP,XVT -"RTN","GPLXPATH",455,0) - F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML -"RTN","GPLXPATH",456,0) - . S XVT=@XVIXML@(XVI) -"RTN","GPLXPATH",457,0) - . I XVT["@@" S XVTMP($P(XVT,"@@",2))="" -"RTN","GPLXPATH",458,0) - D H2ARY(XVRTN,"XVTMP") -"RTN","GPLXPATH",459,0) - Q -"RTN","GPLXPATH",460,0) - ; -"RTN","GPLXPATH",461,0) -DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE -"RTN","GPLXPATH",462,0) - ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE -"RTN","GPLXPATH",463,0) - ; -"RTN","GPLXPATH",464,0) - N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED -"RTN","GPLXPATH",465,0) - I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE -"RTN","GPLXPATH",466,0) - . D LOAD^GPLCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP -"RTN","GPLXPATH",467,0) - . S DXUSE="DTMP" ; DXUSE IS NAME -"RTN","GPLXPATH",468,0) - E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE -"RTN","GPLXPATH",469,0) - . D LOAD^GPLCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP -"RTN","GPLXPATH",470,0) - . S DXUSE="DTMP" ; DXUSE IS NAME -"RTN","GPLXPATH",471,0) - E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE -"RTN","GPLXPATH",472,0) - N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE -"RTN","GPLXPATH",473,0) - D XVARS("DVARS",DXUSE) ; PULL OUT VARS -"RTN","GPLXPATH",474,0) - D PARY^GPLXPATH("DVARS") ;AND DISPLAY THEM -"RTN","GPLXPATH",475,0) - Q -"RTN","GPLXPATH",476,0) - ; -"RTN","GPLXPATH",477,0) -TEST ; Run all the test cases -"RTN","GPLXPATH",478,0) - D TESTALL^GPLUNIT("GPLXPAT0") -"RTN","GPLXPATH",479,0) - Q -"RTN","GPLXPATH",480,0) - ; -"RTN","GPLXPATH",481,0) -ZTEST(WHICH) ; RUN ONE SET OF TESTS -"RTN","GPLXPATH",482,0) - N ZTMP -"RTN","GPLXPATH",483,0) - S DEBUG=1 -"RTN","GPLXPATH",484,0) - D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") -"RTN","GPLXPATH",485,0) - D ZTEST^GPLUNIT(.ZTMP,WHICH) -"RTN","GPLXPATH",486,0) - Q -"RTN","GPLXPATH",487,0) - ; -"RTN","GPLXPATH",488,0) -TLIST ; LIST THE TESTS -"RTN","GPLXPATH",489,0) - N ZTMP -"RTN","GPLXPATH",490,0) - D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") -"RTN","GPLXPATH",491,0) - D TLIST^GPLUNIT(.ZTMP) -"RTN","GPLXPATH",492,0) - Q -"RTN","GPLXPATH",493,0) - ; -"RTN","LA7QRY1") -0^23^B12511401 -"RTN","LA7QRY1",1,0) -LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 -"RTN","LA7QRY1",2,0) - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 14 -"RTN","LA7QRY1",3,0) - ; -"RTN","LA7QRY1",4,0) - Q -"RTN","LA7QRY1",5,0) - ; -"RTN","LA7QRY1",6,0) -CHKSC ; Check search NLT/LOINC codes -"RTN","LA7QRY1",7,0) - ; -"RTN","LA7QRY1",8,0) - N J -"RTN","LA7QRY1",9,0) - ; -"RTN","LA7QRY1",10,0) - S J=0 -"RTN","LA7QRY1",11,0) - F S J=$O(LA7SC(J)) Q:'J D -"RTN","LA7QRY1",12,0) - . N X -"RTN","LA7QRY1",13,0) - . S X=LA7SC(J) -"RTN","LA7QRY1",14,0) - . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q -"RTN","LA7QRY1",15,0) - . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" -"RTN","LA7QRY1",16,0) - . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q -"RTN","LA7QRY1",17,0) - . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" -"RTN","LA7QRY1",18,0) - . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" -"RTN","LA7QRY1",19,0) - . K LA7SC(J) -"RTN","LA7QRY1",20,0) - Q -"RTN","LA7QRY1",21,0) - ; -"RTN","LA7QRY1",22,0) - ; -"RTN","LA7QRY1",23,0) -SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes -"RTN","LA7QRY1",24,0) - ; Find all topographies that use this HL7 specimen code -"RTN","LA7QRY1",25,0) - N J,K,L -"RTN","LA7QRY1",26,0) - ; -"RTN","LA7QRY1",27,0) - S J=0 -"RTN","LA7QRY1",28,0) - F S J=$O(LA7SPEC(J)) Q:'J D -"RTN","LA7QRY1",29,0) - . S K=LA7SPEC(J),L=0 -"RTN","LA7QRY1",30,0) - . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" -"RTN","LA7QRY1",31,0) - Q -"RTN","LA7QRY1",32,0) - ; -"RTN","LA7QRY1",33,0) - ; -"RTN","LA7QRY1",34,0) -BUILDMSG ; Build HL7 message with result of query -"RTN","LA7QRY1",35,0) - ; -"RTN","LA7QRY1",36,0) - N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X -"RTN","LA7QRY1",37,0) - ; -"RTN","LA7QRY1",38,0) - I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" -"RTN","LA7QRY1",39,0) - S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) -"RTN","LA7QRY1",40,0) - S (HLQ,HL("Q"))="""""" -"RTN","LA7QRY1",41,0) - ; Set flag to not send HL7 message -"RTN","LA7QRY1",42,0) - S LA7NOMSG=1 -"RTN","LA7QRY1",43,0) - ; Create dummy MSH to pass HL7 delimiters -"RTN","LA7QRY1",44,0) - S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS -"RTN","LA7QRY1",45,0) - D FILESEG^LA7VHLU(GBL,.LA7MSH) -"RTN","LA7QRY1",46,0) - ; -"RTN","LA7QRY1",47,0) - F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" -"RTN","LA7QRY1",48,0) - ; -"RTN","LA7QRY1",49,0) - ; Take search results and put in HL7 message structure -"RTN","LA7QRY1",50,0) - S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 -"RTN","LA7QRY1",51,0) - ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M -"RTN","LA7QRY1",52,0) - F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT -"RTN","LA7QRY1",53,0) - . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q -"RTN","LA7QRY1",54,0) - . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 -"RTN","LA7QRY1",55,0) - . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR -"RTN","LA7QRY1",56,0) - . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR -"RTN","LA7QRY1",57,0) - . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR -"RTN","LA7QRY1",58,0) - . D OBX -"RTN","LA7QRY1",59,0) - ; -"RTN","LA7QRY1",60,0) - Q -"RTN","LA7QRY1",61,0) - ; -"RTN","LA7QRY1",62,0) - ; -"RTN","LA7QRY1",63,0) -PID ; Build PID segment -"RTN","LA7QRY1",64,0) - ; -"RTN","LA7QRY1",65,0) - N LA7PID -"RTN","LA7QRY1",66,0) - ; -"RTN","LA7QRY1",67,0) - S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) -"RTN","LA7QRY1",68,0) - S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) -"RTN","LA7QRY1",69,0) - D DEM^LRX -"RTN","LA7QRY1",70,0) - D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) -"RTN","LA7QRY1",71,0) - D FILESEG^LA7VHLU(GBL,.LA7PID) -"RTN","LA7QRY1",72,0) - S (LA("LRIDT"),LA("SUB"))="" -"RTN","LA7QRY1",73,0) - Q -"RTN","LA7QRY1",74,0) - ; -"RTN","LA7QRY1",75,0) - ; -"RTN","LA7QRY1",76,0) -ORC ; Build ORC segment -"RTN","LA7QRY1",77,0) - ; -"RTN","LA7QRY1",78,0) - N X -"RTN","LA7QRY1",79,0) - ; -"RTN","LA7QRY1",80,0) - S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) -"RTN","LA7QRY1",81,0) - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) -"RTN","LA7QRY1",82,0) - S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) -"RTN","LA7QRY1",83,0) - S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) -"RTN","LA7QRY1",84,0) - I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) -"RTN","LA7QRY1",85,0) - S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 -"RTN","LA7QRY1",86,0) - D ORC^LA7VORU -"RTN","LA7QRY1",87,0) - S LA("NLT")="" -"RTN","LA7QRY1",88,0) - ; -"RTN","LA7QRY1",89,0) - Q -"RTN","LA7QRY1",90,0) - ; -"RTN","LA7QRY1",91,0) - ; -"RTN","LA7QRY1",92,0) -OBR ; Build OBR segment -"RTN","LA7QRY1",93,0) - ; -"RTN","LA7QRY1",94,0) - N LA764,LA7NLT -"RTN","LA7QRY1",95,0) - ; -"RTN","LA7QRY1",96,0) - S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" -"RTN","LA7QRY1",97,0) - I $L(LA7NLT) D -"RTN","LA7QRY1",98,0) - . S LA764=+$O(^LAM("E",LA7NLT,0)) -"RTN","LA7QRY1",99,0) - . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) -"RTN","LA7QRY1",100,0) - I LA("SUB")="CH" D -"RTN","LA7QRY1",101,0) - . D OBR^LA7VORU -"RTN","LA7QRY1",102,0) - . D NTE^LA7VORU -"RTN","LA7QRY1",103,0) - . S LA7OBXSN=0 -"RTN","LA7QRY1",104,0) - ; -"RTN","LA7QRY1",105,0) - Q -"RTN","LA7QRY1",106,0) - ; -"RTN","LA7QRY1",107,0) - ; -"RTN","LA7QRY1",108,0) -OBX ; Build OBX segment -"RTN","LA7QRY1",109,0) - ; -"RTN","LA7QRY1",110,0) - N LA7DATA,LA7VT -"RTN","LA7QRY1",111,0) - ; -"RTN","LA7QRY1",112,0) - S LA7NTESN=0 -"RTN","LA7QRY1",113,0) - I LA("SUB")="MI" D MI^LA7VORU1 Q -"RTN","LA7QRY1",114,0) - I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q -"RTN","LA7QRY1",115,0) - ; -"RTN","LA7QRY1",116,0) - S LA7VT=$QS(LA7ROOT,7) -"RTN","LA7QRY1",117,0) - D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) -"RTN","LA7QRY1",118,0) - I '$D(LA7DATA) Q -"RTN","LA7QRY1",119,0) - D FILESEG^LA7VHLU(GBL,.LA7DATA) -"RTN","LA7QRY1",120,0) - ; Send any test interpretation from file #60 -"RTN","LA7QRY1",121,0) - D INTRP^LA7VORUA -"RTN","LA7QRY1",122,0) - ; -"RTN","LA7QRY1",123,0) - Q -"VER") -8.0^22.0 -**END** -**END** Index: ccr/trunk/p/CCR_1_0_7_T1_CACHE.KID =================================================================== --- ccr/trunk/p/CCR_1_0_7_T1_CACHE.KID (revision 549) +++ (revision ) @@ -1,11222 +1,0 @@ -KIDS Distribution saved on Nov 19, 2008@15:53:51 -Labs, alerts and non-VA meds -**KIDS**:CCR*1.0*7^ - -**INSTALL NAME** -CCR*1.0*7 -"BLD",6955,0) -CCR*1.0*7^^0^3081119^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) -15 -"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^24^24 -"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^B68553972 -"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^B12964247 -"BLD",6955,"KRN",9.8,"NM",7,0) -CCRVA200^^0^B35847405 -"BLD",6955,"KRN",9.8,"NM",8,0) -GPLCCD^^0^B114413975 -"BLD",6955,"KRN",9.8,"NM",9,0) -GPLXPATH^^0^B255658739 -"BLD",6955,"KRN",9.8,"NM",10,0) -CCRMEDS1^^0^B80043311 -"BLD",6955,"KRN",9.8,"NM",11,0) -CCRMEDS2^^0^B104632066 -"BLD",6955,"KRN",9.8,"NM",12,0) -GPLUNIT^^0^B31452964 -"BLD",6955,"KRN",9.8,"NM",13,0) -GPLCCR^^0^B81638593 -"BLD",6955,"KRN",9.8,"NM",14,0) -GPLCCR0^^0^B555785104 -"BLD",6955,"KRN",9.8,"NM",15,0) -GPLCCD1^^0^B100039732 -"BLD",6955,"KRN",9.8,"NM",16,0) -GPLACTOR^^0^B57497934 -"BLD",6955,"KRN",9.8,"NM",17,0) -GPLVITAL^^0^B82628966 -"BLD",6955,"KRN",9.8,"NM",18,0) -GPLRIMA^^0^B244980714 -"BLD",6955,"KRN",9.8,"NM",19,0) -GPLALERT^^0^B21981592 -"BLD",6955,"KRN",9.8,"NM",20,0) -GPLPROBS^^0^B25875394 -"BLD",6955,"KRN",9.8,"NM",21,0) -GPLXPAT0^^0^B51026779 -"BLD",6955,"KRN",9.8,"NM",22,0) -GPLLABS^^0^B221616742 -"BLD",6955,"KRN",9.8,"NM",23,0) -LA7QRY1^^0^B12511401 -"BLD",6955,"KRN",9.8,"NM",24,0) -CCRMEDS3^^0^B68176928 -"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","CCRMEDS1",10) - -"BLD",6955,"KRN",9.8,"NM","B","CCRMEDS2",11) - -"BLD",6955,"KRN",9.8,"NM","B","CCRMEDS3",24) - -"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",16) - -"BLD",6955,"KRN",9.8,"NM","B","GPLALERT",19) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD",8) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCD1",15) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR",13) - -"BLD",6955,"KRN",9.8,"NM","B","GPLCCR0",14) - -"BLD",6955,"KRN",9.8,"NM","B","GPLLABS",22) - -"BLD",6955,"KRN",9.8,"NM","B","GPLPROBS",20) - -"BLD",6955,"KRN",9.8,"NM","B","GPLRIMA",18) - -"BLD",6955,"KRN",9.8,"NM","B","GPLUNIT",12) - -"BLD",6955,"KRN",9.8,"NM","B","GPLVITAL",17) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPAT0",21) - -"BLD",6955,"KRN",9.8,"NM","B","GPLXPATH",9) - -"BLD",6955,"KRN",9.8,"NM","B","LA7QRY1",23) - -"BLD",6955,"KRN",19,0) -19 -"BLD",6955,"KRN",19,"NM",0) -^9.68A^^ -"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") -24 -"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 15 -"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 15 -"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^B68553972 -"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 15 -"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 PENDINGXML,MEDPENDING -"RTN","CCRMEDS",58,0) - S PENDINGXML="MEDPENDING" ;NAME FOR ARRAY -"RTN","CCRMEDS",59,0) - D EXTRACT^CCRMEDS3(MEDXML,DFN,PENDINGXML) ; FIRST EXTRACT OUTPATIENT MEDS -"RTN","CCRMEDS",60,0) - I @PENDINGXML@(0)>0 D ; CCRMEDS FOUND PENDING OP MEDS -"RTN","CCRMEDS",61,0) - . ; S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML -"RTN","CCRMEDS",62,0) - . I @MEDOUTXML@(0)>0 D ; IF WE NEED TO COMBINE MEDS -"RTN","CCRMEDS",63,0) - . . D INSINNER^GPLXPATH(MEDOUTXML,PENDINGXML) ;ADD NON-VA TO MEDS -"RTN","CCRMEDS",64,0) - . E D CP^GPLXPATH(PENDINGXML,MEDOUTXML) ; NO PREVIOUS MEDS, JUST COPY -"RTN","CCRMEDS",65,0) - . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP -"RTN","CCRMEDS",66,0) - . ; W MEDCNT,! -"RTN","CCRMEDS",67,0) - . W "HAS NON-VA MEDS",! -"RTN","CCRMEDS",68,0) -THEND ; -"RTN","CCRMEDS",69,0) - Q ; SKIPPING ALL THE REST OF THIS LOGIC.. IT IS NOT GOING TO BE NEEDED -"RTN","CCRMEDS",70,0) - ; ONCE NON-VA AND IP MEDS WORK (CCRMEDS3 AND CCRMEDS4) -"RTN","CCRMEDS",71,0) - N MEDRSLT,I,J,K,MEDPTMP,X,MEDVMAP,TBUF -"RTN","CCRMEDS",72,0) - D ACTIVE^ORWPS(.MEDRSLT,DFN) -"RTN","CCRMEDS",73,0) - I '$D(MEDRSLT(1)) D ; NO MEDS FOR THIS PATIENT, EXIT -"RTN","CCRMEDS",74,0) - . I DEBUG W "MEDICATIONS RPC RETURNED NULL",! -"RTN","CCRMEDS",75,0) - . S @MEDOUTXML@(0)=0 -"RTN","CCRMEDS",76,0) - . Q -"RTN","CCRMEDS",77,0) - ; I DEBUG ZWR MEDRSLT -"RTN","CCRMEDS",78,0) - M GPLMEDS=MEDRSLT -"RTN","CCRMEDS",79,0) - S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) -"RTN","CCRMEDS",80,0) - S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) -"RTN","CCRMEDS",81,0) - ; I 'HASOP K @MEDTVMAP,@MEDTARYTMP KILL MOVED TO TOP OF ROUTINE -"RTN","CCRMEDS",82,0) - ; FIRST GO THROUGH MEDRSLT ARRAY AND COUNT MEDS AND LINES IN MEDS -"RTN","CCRMEDS",83,0) - ; ZA(0) IS TOTAL NUMBER OF MEDS ZA(ZI) IS LINES IN MED ZI -"RTN","CCRMEDS",84,0) - N ZA,ZI,ZJ,ZK,ZN S (ZI,ZJ,ZK,ZN)=0 ; ZI IS MED NUMBER, ZJ IS LINE IN MED -"RTN","CCRMEDS",85,0) - ; ZK IS THE NUMBER OF LINES IN A MED AND ZN IS COUNTER THROUGH LINES -"RTN","CCRMEDS",86,0) - S ZA(0)=0 ; ZA IS ARRAY OF MED LINE COUNTS -"RTN","CCRMEDS",87,0) - F ZJ=1:1 Q:'$D(MEDRSLT(ZJ)) D ; COUNT THE MEDS AND LINES -"RTN","CCRMEDS",88,0) - . I MEDRSLT(ZJ)?1"~".E D ; FOUND NEW MED -"RTN","CCRMEDS",89,0) - . . S ZI=ZI+1 ; INCREMENT MED COUNT -"RTN","CCRMEDS",90,0) - . . S ZA(0)=ZI ; NEW TOTAL FOR MEDS -"RTN","CCRMEDS",91,0) - . . S ZA(ZI)=ZJ_U_1 ; EACH ZA(X) IS Y^Z WHERE Y IS START LINE AND Z IS COUNT -"RTN","CCRMEDS",92,0) - . E D ; FOR EVERY LINE NOT A FIRST LINE IN MED -"RTN","CCRMEDS",93,0) - . . S ZK=$P(ZA(ZI),U,2)+1 ; INCREMENT LINE COUNT FOR CURRENT MED -"RTN","CCRMEDS",94,0) - . . S $P(ZA(ZI),U,2)=ZK ; AND STORE IT IN ARRAY -"RTN","CCRMEDS",95,0) - ;ZWR ZA -"RTN","CCRMEDS",96,0) - ; S @MEDTVMAP@(0)=ZA(0) ; SAVE NUMBER OF MEDS -"RTN","CCRMEDS",97,0) - F ZI=1:1:ZA(0) D ; FOR EACH MED -"RTN","CCRMEDS",98,0) - . I DEBUG W "ZI IS ",ZI,! -"RTN","CCRMEDS",99,0) - . ; W ZI," ",MEDCNT,! -"RTN","CCRMEDS",100,0) - . S ZJ=$P(ZA(ZI),U,1) ; INDEX OF FIRST LINE OF MED IN MEDRSLT -"RTN","CCRMEDS",101,0) - . S MEDPTMP=MEDRSLT(ZJ) ; PULL OUT FIRST LINE OF MED -"RTN","CCRMEDS",102,0) - . I $P(MEDPTMP,U,1)?1"~OP" Q ; SKIP OP ACTIVE AND PENDING -"RTN","CCRMEDS",103,0) - . S MEDCNT=MEDCNT+1 ; WE ARE GOING TO ADD A MED -"RTN","CCRMEDS",104,0) - . S MEDVMAP=$NA(@MEDTVMAP@(MEDCNT)) ; START PAST OP ACTIVE MEDS -"RTN","CCRMEDS",105,0) - . S @MEDTVMAP@(0)=@MEDTVMAP@(0)+1 ; ADDING A MED HERE -"RTN","CCRMEDS",106,0) - . S @MEDVMAP@("MEDOBJECTID")="MED"_(MEDCNT) ; UNIQUE OBJID FOR MEDS -"RTN","CCRMEDS",107,0) - . I $P(MEDPTMP,"^",11)="" S @MEDVMAP@("MEDISSUEDATETXT")="" -"RTN","CCRMEDS",108,0) - . E S @MEDVMAP@("MEDISSUEDATETXT")=$$FMDTOUTC^CCRUTIL($P(MEDPTMP,"^",11),"DT") ; GETS LAST FILL DATE -"RTN","CCRMEDS",109,0) - . S @MEDVMAP@("MEDISSUEDATE")="" -"RTN","CCRMEDS",110,0) - . S @MEDVMAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS",111,0) - . S @MEDVMAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS",112,0) - . S @MEDVMAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS",113,0) - . S @MEDVMAP@("MEDRXNO")="" -"RTN","CCRMEDS",114,0) - . S @MEDVMAP@("MEDDETAILUNADORNED")="" -"RTN","CCRMEDS",115,0) - . S @MEDVMAP@("MEDCONCVALUE")="" -"RTN","CCRMEDS",116,0) - . S @MEDVMAP@("MEDCONCUNIT")="" -"RTN","CCRMEDS",117,0) - . S @MEDVMAP@("MEDSIZETEXT")="" -"RTN","CCRMEDS",118,0) - . S @MEDVMAP@("MEDDOSEINDICATOR")="" -"RTN","CCRMEDS",119,0) - . S @MEDVMAP@("MEDDELIVERYMETHOD")="" -"RTN","CCRMEDS",120,0) - . S @MEDVMAP@("MEDRATEVALUE")="" -"RTN","CCRMEDS",121,0) - . S @MEDVMAP@("MEDRATEUNIT")="" -"RTN","CCRMEDS",122,0) - . S @MEDVMAP@("MEDVEHICLETEXT")="" -"RTN","CCRMEDS",123,0) - . S @MEDVMAP@("MEDFREQUENCYUNIT")="" -"RTN","CCRMEDS",124,0) - . S @MEDVMAP@("MEDINTERVALVALUE")="" -"RTN","CCRMEDS",125,0) - . S @MEDVMAP@("MEDINTERVALUNIT")="" -"RTN","CCRMEDS",126,0) - . S @MEDVMAP@("MEDPRNFLAG")="" -"RTN","CCRMEDS",127,0) - . S @MEDVMAP@("MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS",128,0) - . S @MEDVMAP@("MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS",129,0) - . S @MEDVMAP@("MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS",130,0) - . S @MEDVMAP@("MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS",131,0) - . S @MEDVMAP@("MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS",132,0) - . S @MEDVMAP@("MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS",133,0) - . S @MEDVMAP@("MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS",134,0) - . S @MEDVMAP@("MEDSTOPINDICATOR")="" -"RTN","CCRMEDS",135,0) - . S @MEDVMAP@("MEDDIRSEQ")="" -"RTN","CCRMEDS",136,0) - . S @MEDVMAP@("MEDMULDIRMOD")="" -"RTN","CCRMEDS",137,0) - . S @MEDVMAP@("MEDPTINSTRUCTIONS")="" -"RTN","CCRMEDS",138,0) - . S @MEDVMAP@("MEDFULLFILLMENTINSTRUCTIONS")="" -"RTN","CCRMEDS",139,0) - . S @MEDVMAP@("MEDDATETIMEAGE")="" -"RTN","CCRMEDS",140,0) - . S @MEDVMAP@("MEDDATETIMEAGEUNITS")="" -"RTN","CCRMEDS",141,0) - . S @MEDVMAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS",142,0) - . S @MEDVMAP@("MEDSTATUSTEXT")=$P(MEDPTMP,"^",10) ; STATUS FROM RPC -"RTN","CCRMEDS",143,0) - . S @MEDVMAP@("MEDSOURCEACTORID")="ACTORSYSTEM_1" -"RTN","CCRMEDS",144,0) - . S @MEDVMAP@("MEDPRODUCTNAMETEXT")=$P(MEDPTMP,"^",3) -"RTN","CCRMEDS",145,0) - . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")="" ; DEFAULT VALUE -"RTN","CCRMEDS",146,0) - . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" -"RTN","CCRMEDS",147,0) - . S @MEDVMAP@("MEDPRODUCTNAMECODEVERSION")="" -"RTN","CCRMEDS",148,0) - . I $P(MEDPTMP,U,1)?1"~OP" D ; IS OUTPATIENT, MIGHT HAVE CODE -"RTN","CCRMEDS",149,0) - . . I $P(MEDPTMP,"^",10)="ACTIVE" D ; ONLY ACTIVE MEDS HAVE CODES -"RTN","CCRMEDS",150,0) - . . . N RXIEN ; IEN TO RX, EXAMPLE "~OP^13R;O^IBUPROFEN 400MG^" 13 IS IT -"RTN","CCRMEDS",151,0) - . . . S RXIEN=$$DIGITS($P($P(MEDPTMP,U,2),";",1)) ; GET JUST LEADING DIGITS -"RTN","CCRMEDS",152,0) - . . . I DEBUG W "RXIEN=",RXIEN,! ; -"RTN","CCRMEDS",153,0) - . . . D RX^PSO52API(DFN,"MEDCODE",RXIEN) ; EXTRACT THE RX RECORD TO ^TMP -"RTN","CCRMEDS",154,0) - . . . I $D(^TMP($J,"MEDCODE",DFN,RXIEN,27)) D ; IF SUCCESS -"RTN","CCRMEDS",155,0) - . . . . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")=^TMP($J,"MEDCODE",DFN,RXIEN,27) -"RTN","CCRMEDS",156,0) - . . . . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS",157,0) - . S @MEDVMAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS",158,0) - . S @MEDVMAP@("MEDBRANDNAMECODEVALUE")="" -"RTN","CCRMEDS",159,0) - . S @MEDVMAP@("MEDBRANDNAMECODINGSYSTEM")="" -"RTN","CCRMEDS",160,0) - . S @MEDVMAP@("MEDBRANDNAMECODEVERSION")="" -"RTN","CCRMEDS",161,0) - . S @MEDVMAP@("MEDSTRENGTHVALUE")="" -"RTN","CCRMEDS",162,0) - . S @MEDVMAP@("MEDSTRENGTHUNIT")="" -"RTN","CCRMEDS",163,0) - . S @MEDVMAP@("MEDFORMTEXT")="" -"RTN","CCRMEDS",164,0) - . S @MEDVMAP@("MEDQUANTITYVALUE")="" -"RTN","CCRMEDS",165,0) - . S @MEDVMAP@("MEDQUANTITYUNIT")="" -"RTN","CCRMEDS",166,0) - . S @MEDVMAP@("MEDRFNO")="" -"RTN","CCRMEDS",167,0) - . S ZK=$P(ZA(ZI),U,2) ; NUMBER OF LINES IN MED -"RTN","CCRMEDS",168,0) - . I ZK>1 D ; MORE THAN ONE LINE IN MED -"RTN","CCRMEDS",169,0) - . . S @MEDVMAP@("MEDDESCRIPTIONTEXT")=$P(MEDRSLT(ZJ+1)," *",2) -"RTN","CCRMEDS",170,0) - . I ZK>2 D ; THIRD THROUGH 2+N LINES OF MED ARE INSTRUCTIONS -"RTN","CCRMEDS",171,0) - . . N TMPTXT S TMPTXT="" ; BUILD UP INSTRUCTION LINE -"RTN","CCRMEDS",172,0) - . . F ZN=2:1:ZK-1 D ; REMAINING LINES IN EACH MED -"RTN","CCRMEDS",173,0) - . . . I MEDRSLT(ZJ+ZN)]"\ Sig: " D ; REMOVE THIS MARKUP -"RTN","CCRMEDS",174,0) - . . . . S TMPTXT=TMPTXT_$P(MEDRSLT(ZJ+ZN),"\ Sig: ",2)_" " ; APPEND 2 TMPTXT -"RTN","CCRMEDS",175,0) - . . . E S TMPTXT=TMPTXT_MEDRSLT(ZJ+ZN)_" " ; SEPARATE LINES WITH SPACE -"RTN","CCRMEDS",176,0) - . . S @MEDVMAP@("MEDDIRECTIONDESCRIPTIONTEXT")=TMPTXT ; CP TO MAP VAR -"RTN","CCRMEDS",177,0) - . S @MEDVMAP@("MEDDOSEVALUE")="" -"RTN","CCRMEDS",178,0) - . S @MEDVMAP@("MEDDOSEUNIT")="" -"RTN","CCRMEDS",179,0) - . S @MEDVMAP@("MEDFREQUENCYVALUE")="" -"RTN","CCRMEDS",180,0) - . S @MEDVMAP@("MEDDURATIONVALUE")="" -"RTN","CCRMEDS",181,0) - . S @MEDVMAP@("MEDDURATIONUNIT")="" -"RTN","CCRMEDS",182,0) - . S @MEDVMAP@("MEDDIRECTIONROUTETEXT")="" -"RTN","CCRMEDS",183,0) - . S @MEDVMAP@("MEDDIRECTIONFREQUENCYVALUE")="" -"RTN","CCRMEDS",184,0) - . S MEDARYTMP=$NA(@MEDTARYTMP@(ZI)) -"RTN","CCRMEDS",185,0) - . K @MEDARYTMP -"RTN","CCRMEDS",186,0) - . D MAP^GPLXPATH(MEDXML,MEDVMAP,MEDARYTMP) -"RTN","CCRMEDS",187,0) - . I ZI=1&('HASOP) D ; FIRST ONE IS JUST A COPY MAKE SURE OP IS NOT THERE -"RTN","CCRMEDS",188,0) - . . ; W "FIRST ONE",! -"RTN","CCRMEDS",189,0) - . . D CP^GPLXPATH(MEDARYTMP,MEDOUTXML) -"RTN","CCRMEDS",190,0) - . E D ; AFTER THE FIRST OR IF THERE ARE OP, INSERT INNER XML -"RTN","CCRMEDS",191,0) - . . D INSINNER^GPLXPATH(MEDOUTXML,MEDARYTMP) -"RTN","CCRMEDS",192,0) - N MEDTMP,MEDI -"RTN","CCRMEDS",193,0) - D MISSING^GPLXPATH(MEDOUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS",194,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS",195,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS",196,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS",197,0) - Q -"RTN","CCRMEDS",198,0) - ; -"RTN","CCRMEDS",199,0) -DIGITS(INSTR) ; RETURN JUST THE LEADING DIGITS OF THE STRING -"RTN","CCRMEDS",200,0) - ; EXAMPLE: $$DIGITS("13R") RETURNS 13 -"RTN","CCRMEDS",201,0) - N ALPHA ; CONTANT TO HOLD ALL ALPHA CHARACTERS -"RTN","CCRMEDS",202,0) - S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ; ALPHAS -"RTN","CCRMEDS",203,0) - Q $TR(INSTR,ALPHA) ; LEAVE ONLY THE DIGITS -"RTN","CCRMEDS",204,0) - ; -"RTN","CCRMEDS1") -0^10^B80043311 -"RTN","CCRMEDS1",1,0) -CCRMEDS ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;08/24/08 -"RTN","CCRMEDS1",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 15 -"RTN","CCRMEDS1",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS1",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS1",5,0) - ; -"RTN","CCRMEDS1",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS1",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS1",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS1",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS1",10,0) - ; -"RTN","CCRMEDS1",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS1",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS1",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS1",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS1",15,0) - ; -"RTN","CCRMEDS1",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS1",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS1",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS1",19,0) - ; -"RTN","CCRMEDS1",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS1",21,0) - Q -"RTN","CCRMEDS1",22,0) - ; -"RTN","CCRMEDS1",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS1",24,0) - ; -"RTN","CCRMEDS1",25,0) - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","CCRMEDS1",26,0) - ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE -"RTN","CCRMEDS1",27,0) - ; -"RTN","CCRMEDS1",28,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS1",29,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS1",30,0) - ; MED is holds each array element from MEDS(J), one medicine -"RTN","CCRMEDS1",31,0) - ; J is a counter. -"RTN","CCRMEDS1",32,0) - ; -"RTN","CCRMEDS1",33,0) - ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all -"RTN","CCRMEDS1",34,0) - ; med data available. -"RTN","CCRMEDS1",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS1",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS1",37,0) - ; D PARY^GPLXPATH(MINXML) -"RTN","CCRMEDS1",38,0) - N MEDS,MAP -"RTN","CCRMEDS1",39,0) - K ^TMP($J) -"RTN","CCRMEDS1",40,0) - D RX^PSO52API(DFN,"CCDCCR") -"RTN","CCRMEDS1",41,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS1",42,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS1",43,0) - ; If it is -1, we quit. -"RTN","CCRMEDS1",44,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS1",45,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS1",46,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS1",47,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS1",48,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS1",49,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS1",50,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS1",51,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS1",52,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS1",53,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS1",54,0) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN CCRMEDS -"RTN","CCRMEDS1",55,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS1",56,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS1",57,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS1",58,0) - . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS1",59,0) - . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number -"RTN","CCRMEDS1",60,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS1",61,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($P(MED(1),U)) -"RTN","CCRMEDS1",62,0) - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" -"RTN","CCRMEDS1",63,0) - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^CCRUTIL($P(MED(101),U)) -"RTN","CCRMEDS1",64,0) - . S @MAP@("MEDRXNOTXT")="Prescription Number" -"RTN","CCRMEDS1",65,0) - . S @MAP@("MEDRXNO")=MED(.01) -"RTN","CCRMEDS1",66,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS1",67,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS1",68,0) - . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) -"RTN","CCRMEDS1",69,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) -"RTN","CCRMEDS1",70,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) -"RTN","CCRMEDS1",71,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=MED(27) -"RTN","CCRMEDS1",72,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS1",73,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS1",74,0) - . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) -"RTN","CCRMEDS1",75,0) - . N MEDIEN S MEDIEN=$P(MED(6),U) -"RTN","CCRMEDS1",76,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS1",77,0) - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS1",78,0) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS1",79,0) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS1",80,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS1",81,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS1",82,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS1",83,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS1",84,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",85,0) - . ; Documented in the same manual. -"RTN","CCRMEDS1",86,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS1",87,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS1",88,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS1",89,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS1",90,0) - . N CONCDATA -"RTN","CCRMEDS1",91,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS1",92,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS1",93,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS1",94,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS1",95,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS1",96,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS1",97,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS1",98,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS1",99,0) - . S @MAP@("MEDQUANTITYVALUE")=MED(7) -"RTN","CCRMEDS1",100,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS1",101,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS1",102,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS1",103,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS1",104,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS1",105,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS1",106,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS1",107,0) - . ; -"RTN","CCRMEDS1",108,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS1",109,0) - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... -"RTN","CCRMEDS1",110,0) - . ; we want the compoenents. -"RTN","CCRMEDS1",111,0) - . ; It's in node 6 of ^PSRX(IEN) -"RTN","CCRMEDS1",112,0) - . ; So, here we go again -"RTN","CCRMEDS1",113,0) - . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE -"RTN","CCRMEDS1",114,0) - . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) -"RTN","CCRMEDS1",115,0) - . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE -"RTN","CCRMEDS1",116,0) - . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ -"RTN","CCRMEDS1",117,0) - . ; -"RTN","CCRMEDS1",118,0) - . N DIRNUM S DIRNUM=0 ; Sigline number -"RTN","CCRMEDS1",119,0) - . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS -"RTN","CCRMEDS1",120,0) - . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D -"RTN","CCRMEDS1",121,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS1",122,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS1",123,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS1",124,0) - . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) -"RTN","CCRMEDS1",125,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) -"RTN","CCRMEDS1",126,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) -"RTN","CCRMEDS1",127,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS1",128,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS1",129,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS1",130,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS1",131,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) -"RTN","CCRMEDS1",132,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) -"RTN","CCRMEDS1",133,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS1",134,0) - . . ; In the wisdom of the original programmers, the schedule is a free text field -"RTN","CCRMEDS1",135,0) - . . ; However, it gets translated by a call to the administration schedule file -"RTN","CCRMEDS1",136,0) - . . ; to see if that schedule exists. -"RTN","CCRMEDS1",137,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS1",138,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS1",139,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS1",140,0) - . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. -"RTN","CCRMEDS1",141,0) - . . ; So... -"RTN","CCRMEDS1",142,0) - . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") -"RTN","CCRMEDS1",143,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS1",144,0) - . . N INTERVAL -"RTN","CCRMEDS1",145,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS1",146,0) - . . E D -"RTN","CCRMEDS1",147,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS1",148,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS1",149,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS1",150,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS1",151,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) -"RTN","CCRMEDS1",152,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" -"RTN","CCRMEDS1",153,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" -"RTN","CCRMEDS1",154,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS1",155,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS1",156,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS1",157,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS1",158,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS1",159,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS1",160,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS1",161,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" -"RTN","CCRMEDS1",162,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS1",163,0) - . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) -"RTN","CCRMEDS1",164,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") -"RTN","CCRMEDS1",165,0) - . ; -"RTN","CCRMEDS1",166,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS1",167,0) - . ; -"RTN","CCRMEDS1",168,0) - . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" -"RTN","CCRMEDS1",169,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) -"RTN","CCRMEDS1",170,0) - . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" -"RTN","CCRMEDS1",171,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) -"RTN","CCRMEDS1",172,0) - . S @MAP@("MEDRFNO")=MED(9) -"RTN","CCRMEDS1",173,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS1",174,0) - . K @RESULT -"RTN","CCRMEDS1",175,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS1",176,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS1",177,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS1",178,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS1",179,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS1",180,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS1",181,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS1",182,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS1",183,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS1",184,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS1",185,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS1",186,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS1",187,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS1",188,0) - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS1",189,0) - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML -"RTN","CCRMEDS1",190,0) - N MEDTMP,MEDI -"RTN","CCRMEDS1",191,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS1",192,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS1",193,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS1",194,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS1",195,0) - Q -"RTN","CCRMEDS1",196,0) - ; -"RTN","CCRMEDS2") -0^11^B104632066 -"RTN","CCRMEDS2",1,0) -CCRMEDS2 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Pending Meds;08/24/08 -"RTN","CCRMEDS2",2,0) - ;;0.1;CCDCCR;;JUL 16,2008;Build 15 -"RTN","CCRMEDS2",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS2",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS2",5,0) - ; -"RTN","CCRMEDS2",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS2",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS2",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS2",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS2",10,0) - ; -"RTN","CCRMEDS2",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS2",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS2",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS2",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS2",15,0) - ; -"RTN","CCRMEDS2",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS2",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS2",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS2",19,0) - ; -"RTN","CCRMEDS2",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS2",21,0) - Q -"RTN","CCRMEDS2",22,0) - ; -"RTN","CCRMEDS2",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS2",24,0) - ; -"RTN","CCRMEDS2",25,0) - ; MINXML is the Input XML Template, passed by name -"RTN","CCRMEDS2",26,0) - ; DFN is Patient IEN -"RTN","CCRMEDS2",27,0) - ; OUTXML is the resultant XML. -"RTN","CCRMEDS2",28,0) - ; -"RTN","CCRMEDS2",29,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS2",30,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS2",31,0) - ; MED is holds each array element from MEDS, one medicine -"RTN","CCRMEDS2",32,0) - ; -"RTN","CCRMEDS2",33,0) - ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending -"RTN","CCRMEDS2",34,0) - ; meds data available. -"RTN","CCRMEDS2",35,0) - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf -"RTN","CCRMEDS2",36,0) - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). -"RTN","CCRMEDS2",37,0) - ; File for pending meds is 52.41 -"RTN","CCRMEDS2",38,0) - ; Unfortuantely, API does not supply us with any useful info beyond -"RTN","CCRMEDS2",39,0) - ; the IEN in 52.41, and the Med Name, and route. -"RTN","CCRMEDS2",40,0) - ; So, most of the info is going to get pulled from 52.41. -"RTN","CCRMEDS2",41,0) - N MEDS,MAP -"RTN","CCRMEDS2",42,0) - K ^TMP($J) -"RTN","CCRMEDS2",43,0) - D PEN^PSO5241(DFN,"CCDCCR") -"RTN","CCRMEDS2",44,0) - M MEDS=^TMP($J,"CCDCCR",DFN) -"RTN","CCRMEDS2",45,0) - ; @(0) contains the number of meds or -1^NO DATA FOUND -"RTN","CCRMEDS2",46,0) - ; If it is -1, we quit. -"RTN","CCRMEDS2",47,0) - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS2",48,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS2",49,0) - N RXIEN S RXIEN=0 -"RTN","CCRMEDS2",50,0) - N MEDCOUNT S MEDCOUNT=0 -"RTN","CCRMEDS2",51,0) - N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING -"RTN","CCRMEDS2",52,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP -"RTN","CCRMEDS2",53,0) - S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY -"RTN","CCRMEDS2",54,0) - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS2",55,0) - . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order -"RTN","CCRMEDS2",56,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS2",57,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS2",58,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS2",59,0) - . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN CCRMEDS -"RTN","CCRMEDS2",60,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS2",61,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS2",62,0) - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM -"RTN","CCRMEDS2",63,0) - . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS2",64,0) - . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN -"RTN","CCRMEDS2",65,0) - . S @MAP@("MEDISSUEDATETXT")="Issue Date" -"RTN","CCRMEDS2",66,0) - . ; Field 6 is "Effective date", and we pull it in timson format w/ I -"RTN","CCRMEDS2",67,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") -"RTN","CCRMEDS2",68,0) - . ; Med never filled; next 4 fields are not applicable. -"RTN","CCRMEDS2",69,0) - . S @MAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS2",70,0) - . S @MAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS2",71,0) - . S @MAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS2",72,0) - . S @MAP@("MEDRXNO")="" -"RTN","CCRMEDS2",73,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS2",74,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS2",75,0) - . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds -"RTN","CCRMEDS2",76,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") -"RTN","CCRMEDS2",77,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) -"RTN","CCRMEDS2",78,0) - . ; NDC not supplied in API, but is rather trivial to obtain -"RTN","CCRMEDS2",79,0) - . ; MED(11) piece 1 has the IEN of the drug (file 50) -"RTN","CCRMEDS2",80,0) - . ; IEN is field 31 in the drug file. -"RTN","CCRMEDS2",81,0) - . N MEDIEN S MEDIEN=$P(MED(11),U) -"RTN","CCRMEDS2",82,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$$GET1^DIQ(50,MEDIEN,31,"E") -"RTN","CCRMEDS2",83,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" -"RTN","CCRMEDS2",84,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" -"RTN","CCRMEDS2",85,0) - . S @MAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS2",86,0) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS2",87,0) - . I $D(^TMP($J,"DOSE",MEDIEN)) D ; GPL ; CALL SUCCESSFUL -"RTN","CCRMEDS2",88,0) - . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS2",89,0) - . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) -"RTN","CCRMEDS2",90,0) - . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) -"RTN","CCRMEDS2",91,0) - . E D ; GPL CALL UNSUCCESSUFL -"RTN","CCRMEDS2",92,0) - . . S @MAP@("MEDSTRENGTHVALUE")="" ; NO DOSE INFORMATION AVAILABLE -"RTN","CCRMEDS2",93,0) - . . S @MAP@("MEDSTRENGTHUNIT")="" ; -"RTN","CCRMEDS2",94,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS2",95,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS2",96,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS2",97,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS2",98,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",99,0) - . ; Documented in the same manual. -"RTN","CCRMEDS2",100,0) - . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS2",101,0) - . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS2",102,0) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS2",103,0) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS2",104,0) - . N CONCDATA -"RTN","CCRMEDS2",105,0) - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS2",106,0) - . ; and this will crash the call. So... -"RTN","CCRMEDS2",107,0) - . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS2",108,0) - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS2",109,0) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) -"RTN","CCRMEDS2",110,0) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) -"RTN","CCRMEDS2",111,0) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) -"RTN","CCRMEDS2",112,0) - . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) -"RTN","CCRMEDS2",113,0) - . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) -"RTN","CCRMEDS2",114,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS2",115,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS2",116,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS2",117,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS2",118,0) - . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS2",119,0) - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS2",120,0) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS2",121,0) - . ; -"RTN","CCRMEDS2",122,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS2",123,0) - . ; Sig data is not in any API. We obtain it using the IEN from -"RTN","CCRMEDS2",124,0) - . ; the PEN API to file 52.41. It's in field 3, which is a multiple. -"RTN","CCRMEDS2",125,0) - . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) -"RTN","CCRMEDS2",126,0) - . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call -"RTN","CCRMEDS2",127,0) - . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") -"RTN","CCRMEDS2",128,0) - . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. -"RTN","CCRMEDS2",129,0) - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". -"RTN","CCRMEDS2",130,0) - . ; DIRNUM will be first piece for IEN. -"RTN","CCRMEDS2",131,0) - . ; DIRNUM is the proper Sigline numer. -"RTN","CCRMEDS2",132,0) - . ; SIGDATA is the simplfied array. Subscripts are really field numbers -"RTN","CCRMEDS2",133,0) - . ; in subfile 52.413. -"RTN","CCRMEDS2",134,0) - . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS -"RTN","CCRMEDS2",135,0) - . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D -"RTN","CCRMEDS2",136,0) - . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") -"RTN","CCRMEDS2",137,0) - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT -"RTN","CCRMEDS2",138,0) - . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) -"RTN","CCRMEDS2",139,0) - . . ; If this is an order for a refill; it's not really a new order; move on to next -"RTN","CCRMEDS2",140,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. -"RTN","CCRMEDS2",141,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. -"RTN","CCRMEDS2",142,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) -"RTN","CCRMEDS2",143,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) -"RTN","CCRMEDS2",144,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") -"RTN","CCRMEDS2",145,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient -"RTN","CCRMEDS2",146,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient -"RTN","CCRMEDS2",147,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient -"RTN","CCRMEDS2",148,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) -"RTN","CCRMEDS2",149,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) -"RTN","CCRMEDS2",150,0) - . . ; Invervals... again another call. -"RTN","CCRMEDS2",151,0) - . . ; The schedule is a free text field -"RTN","CCRMEDS2",152,0) - . . ; However, it gets translated by a call to the administration -"RTN","CCRMEDS2",153,0) - . . ; schedule file to see if that schedule exists. -"RTN","CCRMEDS2",154,0) - . . ; That's the same thing I am going to do. -"RTN","CCRMEDS2",155,0) - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). -"RTN","CCRMEDS2",156,0) - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- -"RTN","CCRMEDS2",157,0) - . . ; I looked), PSSFT is the name, -"RTN","CCRMEDS2",158,0) - . . ; and list is the ^TMP name to store the data in. -"RTN","CCRMEDS2",159,0) - . . ; Also, freqency may have "PRN" in it, so strip that out -"RTN","CCRMEDS2",160,0) - . . N FREQ S FREQ=SIGDATA(1) -"RTN","CCRMEDS2",161,0) - . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp -"RTN","CCRMEDS2",162,0) - . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") -"RTN","CCRMEDS2",163,0) - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") -"RTN","CCRMEDS2",164,0) - . . N INTERVAL -"RTN","CCRMEDS2",165,0) - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" -"RTN","CCRMEDS2",166,0) - . . E D -"RTN","CCRMEDS2",167,0) - . . . N SUB S SUB=$O(SCHEDATA(0)) -"RTN","CCRMEDS2",168,0) - . . . S INTERVAL=SCHEDATA(SUB,2) -"RTN","CCRMEDS2",169,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL -"RTN","CCRMEDS2",170,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" -"RTN","CCRMEDS2",171,0) - . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months -"RTN","CCRMEDS2",172,0) - . . N DUR S DUR=SIGDATA(2) -"RTN","CCRMEDS2",173,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) -"RTN","CCRMEDS2",174,0) - . . N DURUNIT S DURUNIT=$E(DUR) -"RTN","CCRMEDS2",175,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") -"RTN","CCRMEDS2",176,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" -"RTN","CCRMEDS2",177,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS2",178,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS2",179,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS2",180,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS2",181,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS2",182,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS2",183,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS2",184,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field -"RTN","CCRMEDS2",185,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM -"RTN","CCRMEDS2",186,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) -"RTN","CCRMEDS2",187,0) - . ; -"RTN","CCRMEDS2",188,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS2",189,0) - . ; -"RTN","CCRMEDS2",190,0) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" -"RTN","CCRMEDS2",191,0) - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL -"RTN","CCRMEDS2",192,0) - . ; W @MAP@("MEDPTINSTRUCTIONS"),! -"RTN","CCRMEDS2",193,0) - . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" -"RTN","CCRMEDS2",194,0) - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL -"RTN","CCRMEDS2",195,0) - . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! -"RTN","CCRMEDS2",196,0) - . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) -"RTN","CCRMEDS2",197,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS2",198,0) - . K @RESULT -"RTN","CCRMEDS2",199,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS2",200,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS2",201,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS2",202,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS2",203,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS2",204,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS2",205,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS2",206,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS2",207,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS2",208,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS2",209,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS2",210,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS2",211,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS2",212,0) - . I MEDFIRST D ; -"RTN","CCRMEDS2",213,0) - . . S MEDFIRST=0 ; RESET FIRST FLAG -"RTN","CCRMEDS2",214,0) - . . D CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS2",215,0) - . D:'MEDFIRST INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML -"RTN","CCRMEDS2",216,0) - N MEDTMP,MEDI -"RTN","CCRMEDS2",217,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS2",218,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS2",219,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS2",220,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS2",221,0) - Q -"RTN","CCRMEDS2",222,0) - ; -"RTN","CCRMEDS3") -0^24^B68176928 -"RTN","CCRMEDS3",1,0) -CCRMEDS3 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Outside_non-VA Meds;10/13/08 -"RTN","CCRMEDS3",2,0) - ;;0.1;CCDCCR;;;Build 15 -"RTN","CCRMEDS3",3,0) - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","CCRMEDS3",4,0) - ; General Public License See attached copy of the License. -"RTN","CCRMEDS3",5,0) - ; -"RTN","CCRMEDS3",6,0) - ; This program is free software; you can redistribute it and/or modify -"RTN","CCRMEDS3",7,0) - ; it under the terms of the GNU General Public License as published by -"RTN","CCRMEDS3",8,0) - ; the Free Software Foundation; either version 2 of the License, or -"RTN","CCRMEDS3",9,0) - ; (at your option) any later version. -"RTN","CCRMEDS3",10,0) - ; -"RTN","CCRMEDS3",11,0) - ; This program is distributed in the hope that it will be useful, -"RTN","CCRMEDS3",12,0) - ; but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","CCRMEDS3",13,0) - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","CCRMEDS3",14,0) - ; GNU General Public License for more details. -"RTN","CCRMEDS3",15,0) - ; -"RTN","CCRMEDS3",16,0) - ; You should have received a copy of the GNU General Public License along -"RTN","CCRMEDS3",17,0) - ; with this program; if not, write to the Free Software Foundation, Inc., -"RTN","CCRMEDS3",18,0) - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","CCRMEDS3",19,0) - ; -"RTN","CCRMEDS3",20,0) - W "NO ENTRY FROM TOP",! -"RTN","CCRMEDS3",21,0) - Q -"RTN","CCRMEDS3",22,0) - ; -"RTN","CCRMEDS3",23,0) -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE -"RTN","CCRMEDS3",24,0) - ; -"RTN","CCRMEDS3",25,0) - ; MINXML is the Input XML Template, passed by name -"RTN","CCRMEDS3",26,0) - ; DFN is Patient IEN -"RTN","CCRMEDS3",27,0) - ; OUTXML is the resultant XML. -"RTN","CCRMEDS3",28,0) - ; -"RTN","CCRMEDS3",29,0) - ; MEDS is return array from RPC. -"RTN","CCRMEDS3",30,0) - ; MAP is a mapping variable map (store result) for each med -"RTN","CCRMEDS3",31,0) - ; MED is holds each array element from MEDS, one medicine -"RTN","CCRMEDS3",32,0) - ; -"RTN","CCRMEDS3",33,0) - ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 -"RTN","CCRMEDS3",34,0) - ; Discontinued meds are indicated by the presence of a value in fields -"RTN","CCRMEDS3",35,0) - ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) -"RTN","CCRMEDS3",36,0) - ; Will use Fileman API GETS^DIQ -"RTN","CCRMEDS3",37,0) - ; -"RTN","CCRMEDS3",38,0) - N MEDS,MAP -"RTN","CCRMEDS3",39,0) - K ^TMP($J),NVA -"RTN","CCRMEDS3",40,0) - D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. -"RTN","CCRMEDS3",41,0) - ; If NVA does not exist, then patient has no non-VA meds -"RTN","CCRMEDS3",42,0) - I $D(NVA)=0 S @OUTXML@(0)=0 QUIT -"RTN","CCRMEDS3",43,0) - ; Otherwise, we go on... -"RTN","CCRMEDS3",44,0) - M MEDS=NVA(55.05) -"RTN","CCRMEDS3",45,0) - ; We are done with NVA -"RTN","CCRMEDS3",46,0) - K NVA -"RTN","CCRMEDS3",47,0) - ; -"RTN","CCRMEDS3",48,0) - I DEBUG ZWR MEDS -"RTN","CCRMEDS3",49,0) - N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. -"RTN","CCRMEDS3",50,0) - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) -"RTN","CCRMEDS3",51,0) - N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array -"RTN","CCRMEDS3",52,0) - N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE -"RTN","CCRMEDS3",53,0) - F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST -"RTN","CCRMEDS3",54,0) - . N MED M MED=MEDS(FDAIEN) -"RTN","CCRMEDS3",55,0) - . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. -"RTN","CCRMEDS3",56,0) - . S MEDCOUNT=MEDCOUNT+1 -"RTN","CCRMEDS3",57,0) - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) -"RTN","CCRMEDS3",58,0) - . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY -"RTN","CCRMEDS3",59,0) - . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient -"RTN","CCRMEDS3",60,0) - . I DEBUG W "RXIEN IS ",RXIEN,! -"RTN","CCRMEDS3",61,0) - . I DEBUG W "MAP= ",MAP,! -"RTN","CCRMEDS3",62,0) - . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID -"RTN","CCRMEDS3",63,0) - . S @MAP@("MEDISSUEDATETXT")="Documented Date" -"RTN","CCRMEDS3",64,0) - . ; Field 6 is "Effective date", and we pull it in timson format w/ I -"RTN","CCRMEDS3",65,0) - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL(MED(11,"I"),"DT") -"RTN","CCRMEDS3",66,0) - . ; Med never filled; next 4 fields are not applicable. -"RTN","CCRMEDS3",67,0) - . S @MAP@("MEDLASTFILLDATETXT")="" -"RTN","CCRMEDS3",68,0) - . S @MAP@("MEDLASTFILLDATE")="" -"RTN","CCRMEDS3",69,0) - . S @MAP@("MEDRXNOTXT")="" -"RTN","CCRMEDS3",70,0) - . S @MAP@("MEDRXNO")="" -"RTN","CCRMEDS3",71,0) - . S @MAP@("MEDTYPETEXT")="Medication" -"RTN","CCRMEDS3",72,0) - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses -"RTN","CCRMEDS3",73,0) - . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds -"RTN","CCRMEDS3",74,0) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") -"RTN","CCRMEDS3",75,0) - . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") -"RTN","CCRMEDS3",76,0) - . ; NDC is field 31 in the drug file. -"RTN","CCRMEDS3",77,0) - . ; The actual drug entry in the drug file is not necessarily supplied. -"RTN","CCRMEDS3",78,0) - . ; It' node 1, internal form. -"RTN","CCRMEDS3",79,0) - . N MEDIEN S MEDIEN=MED(1,"I") -"RTN","CCRMEDS3",80,0) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") -"RTN","CCRMEDS3",81,0) - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") -"RTN","CCRMEDS3",82,0) - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") -"RTN","CCRMEDS3",83,0) - . S @MAP@("MEDBRANDNAMETEXT")="" -"RTN","CCRMEDS3",84,0) - . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") -"RTN","CCRMEDS3",85,0) - . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) -"RTN","CCRMEDS3",86,0) - . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") -"RTN","CCRMEDS3",87,0) - . S @MAP@("MEDSTRENGTHUNIT")=$S($L(DOSEDATA(902))>0:$P(DOSEDATA(902),U,2),1:"") ; SAM PLEASE CHECK -"RTN","CCRMEDS3",88,0) - . ; Units, concentration, etc, come from another call -"RTN","CCRMEDS3",89,0) - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit -"RTN","CCRMEDS3",90,0) - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters -"RTN","CCRMEDS3",91,0) - . ; NDF Entry IEN, and VA Product Name -"RTN","CCRMEDS3",92,0) - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS3",93,0) - . ; Documented in the same manual. -"RTN","CCRMEDS3",94,0) - . N NDFDATA,CONCDATA -"RTN","CCRMEDS3",95,0) - . I $L(MEDIEN) D -"RTN","CCRMEDS3",96,0) - . . D NDF^PSS50(MEDIEN,,,,,"CONC") -"RTN","CCRMEDS3",97,0) - . . M NDFDATA=^TMP($J,"CONC",MEDIEN) -"RTN","CCRMEDS3",98,0) - . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) -"RTN","CCRMEDS3",99,0) - . . N VAPROD S VAPROD=$P(NDFDATA(22),U) -"RTN","CCRMEDS3",100,0) - . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" -"RTN","CCRMEDS3",101,0) - . . ; and this will crash the call. So... -"RTN","CCRMEDS3",102,0) - . . I NDFIEN="" S CONCDATA="" -"RTN","CCRMEDS3",103,0) - . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) -"RTN","CCRMEDS3",104,0) - . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. -"RTN","CCRMEDS3",105,0) - . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") -"RTN","CCRMEDS3",106,0) - . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") -"RTN","CCRMEDS3",107,0) - . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") -"RTN","CCRMEDS3",108,0) - . S @MAP@("MEDSIZETEXT")=$S($L(MEDIEN):$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2),1:"") -"RTN","CCRMEDS3",109,0) - . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. -"RTN","CCRMEDS3",110,0) - . ; Oddly, there is no easy place to find the dispense unit. -"RTN","CCRMEDS3",111,0) - . ; It's not included in the original call, so we have to go to the drug file. -"RTN","CCRMEDS3",112,0) - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") -"RTN","CCRMEDS3",113,0) - . ; Node 14.5 is the Dispense Unit -"RTN","CCRMEDS3",114,0) - . I $L(MEDIEN) D -"RTN","CCRMEDS3",115,0) - . . D DATA^PSS50(MEDIEN,,,,,"QTY") -"RTN","CCRMEDS3",116,0) - . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) -"RTN","CCRMEDS3",117,0) - . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) -"RTN","CCRMEDS3",118,0) - . E S @MAP@("MEDQUANTITYUNIT")="" -"RTN","CCRMEDS3",119,0) - . ; -"RTN","CCRMEDS3",120,0) - . ; --- START OF DIRECTIONS --- -"RTN","CCRMEDS3",121,0) - . ; Dosage is field 2, route is 3, schedule is 4 -"RTN","CCRMEDS3",122,0) - . ; These are all free text fields, and don't point to any files -"RTN","CCRMEDS3",123,0) - . ; For that reason, I will use the field I never used before: -"RTN","CCRMEDS3",124,0) - . ; MEDDIRECTIONDESCRIPTIONTEXT -"RTN","CCRMEDS3",125,0) - . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS -"RTN","CCRMEDS3",126,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") -"RTN","CCRMEDS3",127,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. -"RTN","CCRMEDS3",128,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" -"RTN","CCRMEDS3",129,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" -"RTN","CCRMEDS3",130,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" -"RTN","CCRMEDS3",131,0) - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" -"RTN","CCRMEDS3",132,0) - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" -"RTN","CCRMEDS3",133,0) - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" -"RTN","CCRMEDS3",134,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" -"RTN","CCRMEDS3",135,0) - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" -"RTN","CCRMEDS3",136,0) - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" -"RTN","CCRMEDS3",137,0) - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" -"RTN","CCRMEDS3",138,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" -"RTN","CCRMEDS3",139,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" -"RTN","CCRMEDS3",140,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" -"RTN","CCRMEDS3",141,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" -"RTN","CCRMEDS3",142,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" -"RTN","CCRMEDS3",143,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" -"RTN","CCRMEDS3",144,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" -"RTN","CCRMEDS3",145,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" -"RTN","CCRMEDS3",146,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" -"RTN","CCRMEDS3",147,0) - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" -"RTN","CCRMEDS3",148,0) - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" -"RTN","CCRMEDS3",149,0) - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" -"RTN","CCRMEDS3",150,0) - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" -"RTN","CCRMEDS3",151,0) - . ; -"RTN","CCRMEDS3",152,0) - . ; --- END OF DIRECTIONS --- -"RTN","CCRMEDS3",153,0) - . ; -"RTN","CCRMEDS3",154,0) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" -"RTN","CCRMEDS3",155,0) - . I $D(MED(10,1)) D ; -"RTN","CCRMEDS3",156,0) - . . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field -"RTN","CCRMEDS3",157,0) - . E S @MAP@("MEDPTINSTRUCTIONS")="" -"RTN","CCRMEDS3",158,0) - . I $D(MED(14,1)) D ; -"RTN","CCRMEDS3",159,0) - . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field -"RTN","CCRMEDS3",160,0) - . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" -"RTN","CCRMEDS3",161,0) - . S @MAP@("MEDRFNO")="" -"RTN","CCRMEDS3",162,0) - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) -"RTN","CCRMEDS3",163,0) - . K @RESULT -"RTN","CCRMEDS3",164,0) - . D MAP^GPLXPATH(MINXML,MAP,RESULT) -"RTN","CCRMEDS3",165,0) - . ; D PARY^GPLXPATH(RESULT) -"RTN","CCRMEDS3",166,0) - . ; MAPPING DIRECTIONS -"RTN","CCRMEDS3",167,0) - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE -"RTN","CCRMEDS3",168,0) - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT -"RTN","CCRMEDS3",169,0) - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) -"RTN","CCRMEDS3",170,0) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") -"RTN","CCRMEDS3",171,0) - . ; N MDZ1,MDZNA -"RTN","CCRMEDS3",172,0) - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS -"RTN","CCRMEDS3",173,0) - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION -"RTN","CCRMEDS3",174,0) - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) -"RTN","CCRMEDS3",175,0) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) -"RTN","CCRMEDS3",176,0) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") -"RTN","CCRMEDS3",177,0) - . I MEDFIRST D ; -"RTN","CCRMEDS3",178,0) - . . S MEDFIRST=0 ; RESET FIRST FLAG -"RTN","CCRMEDS3",179,0) - . . D CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy -"RTN","CCRMEDS3",180,0) - . D:'MEDFIRST INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML -"RTN","CCRMEDS3",181,0) - N MEDTMP,MEDI -"RTN","CCRMEDS3",182,0) - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS -"RTN","CCRMEDS3",183,0) - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ -"RTN","CCRMEDS3",184,0) - . W "MEDICATION MISSING ",! -"RTN","CCRMEDS3",185,0) - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! -"RTN","CCRMEDS3",186,0) - Q -"RTN","CCRMEDS3",187,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 15 -"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 15 -"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^B12964247 -"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 15 -"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) - S OFFS=$E(OFF,1,1) -"RTN","CCRUTIL",41,0) - S OFF0=$TR(OFF,"+-") -"RTN","CCRUTIL",42,0) - S OFF1=$E(OFF0+10000,2,3) -"RTN","CCRUTIL",43,0) - S OFF2=$E(OFF0+10000,4,5) -"RTN","CCRUTIL",44,0) - S OFF=OFFS_OFF1_":"_OFF2 -"RTN","CCRUTIL",45,0) - ;S OFF2=$E(OFF,1,2) ; -"RTN","CCRUTIL",46,0) - ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT -"RTN","CCRUTIL",47,0) - ;S OFF3=$E(OFF,3,4) ;MINUTES -"RTN","CCRUTIL",48,0) - ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3) -"RTN","CCRUTIL",49,0) - ; If H, MM and S are empty, it means that the FM date didn't supply the time. -"RTN","CCRUTIL",50,0) - ; In this case, set H, MM and S to "00" -"RTN","CCRUTIL",51,0) - ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? -"RTN","CCRUTIL",52,0) - S:'$L(H) H="00" -"RTN","CCRUTIL",53,0) - S:'$L(MM) MM="00" -"RTN","CCRUTIL",54,0) - S:'$L(S) S="00" -"RTN","CCRUTIL",55,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",56,0) - I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. -"RTN","CCRUTIL",57,0) - E Q $P(UTC,"T") -"RTN","CCRUTIL",58,0) - ; -"RTN","CCRUTIL",59,0) -SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT -"RTN","CCRUTIL",60,0) - ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE -"RTN","CCRUTIL",61,0) - ; DATE AND TIME ORDER. DEFAULT IS FORWARD -"RTN","CCRUTIL",62,0) - ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT -"RTN","CCRUTIL",63,0) - ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER -"RTN","CCRUTIL",64,0) - ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER -"RTN","CCRUTIL",65,0) - ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC -"RTN","CCRUTIL",66,0) - ; BOTH V1 AND V2 ARE PASSED BY REFERENCE -"RTN","CCRUTIL",67,0) - N VSRT ; TEMP FOR HASHING DATES -"RTN","CCRUTIL",68,0) - N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 -"RTN","CCRUTIL",69,0) - S ZCNT=V2(0) ; COUNTING NUMBER OF DATES -"RTN","CCRUTIL",70,0) - F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY -"RTN","CCRUTIL",71,0) - . I $D(V2(ZI)) D ; IF THE DATE EXISTS -"RTN","CCRUTIL",72,0) - . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE -"RTN","CCRUTIL",73,0) - . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE -"RTN","CCRUTIL",74,0) - . . ; W "DATE: ",ZP1," TIME: ",ZP2,! -"RTN","CCRUTIL",75,0) - . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT -"RTN","CCRUTIL",76,0) - N ZG -"RTN","CCRUTIL",77,0) - S ZG=$Q(VSRT("")) -"RTN","CCRUTIL",78,0) - F D Q:ZG="" ; -"RTN","CCRUTIL",79,0) - . ; W ZG,! -"RTN","CCRUTIL",80,0) - . D PUSH^GPLXPATH("V1",@ZG) -"RTN","CCRUTIL",81,0) - . S ZG=$Q(@ZG) -"RTN","CCRUTIL",82,0) - I ORDR=-1 D ; HAVE TO REVERSE ORDER -"RTN","CCRUTIL",83,0) - . N ZG2 -"RTN","CCRUTIL",84,0) - . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT -"RTN","CCRUTIL",85,0) - . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER -"RTN","CCRUTIL",86,0) - . S ZG2(0)=V1(0) -"RTN","CCRUTIL",87,0) - . D CP^GPLXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY -"RTN","CCRUTIL",88,0) - Q ZCNT -"RTN","CCRUTIL",89,0) - ; -"RTN","CCRUTIL",90,0) -DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX -"RTN","CCRUTIL",91,0) - ; RETURNS AN ARRAY RTN PASSED BY REFERENCE -"RTN","CCRUTIL",92,0) - ; THIS ROUTINE CAN BE USED AS AN RPC -"RTN","CCRUTIL",93,0) - ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY -"RTN","CCRUTIL",94,0) - ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY -"RTN","CCRUTIL",95,0) - ; -"RTN","CCRUTIL",96,0) - N LEXIEN -"RTN","CCRUTIL",97,0) - I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG -"RTN","CCRUTIL",98,0) - . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON -"RTN","CCRUTIL",99,0) - . W LEXIEN,! -"RTN","CCRUTIL",100,0) - . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 -"RTN","CCRUTIL",101,0) - . S RTN(0)=1 ; ONE THING RETURNED -"RTN","CCRUTIL",102,0) - E S RTN(0)=0 ; NOT FOUND -"RTN","CCRUTIL",103,0) - Q -"RTN","CCRUTIL",104,0) - ; -"RTN","CCRUTIL",105,0) -DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME -"RTN","CCRUTIL",106,0) - ; -"RTN","CCRUTIL",107,0) - N DARTN -"RTN","CCRUTIL",108,0) - D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE -"RTN","CCRUTIL",109,0) - I DARTN(0)>0 D ; GOT RESULTS -"RTN","CCRUTIL",110,0) - . W !,DARTN(1) ;PRINT THE SNOMED CODE -"RTN","CCRUTIL",111,0) - E W !,"NOT FOUND",! -"RTN","CCRUTIL",112,0) - Q -"RTN","CCRUTIL",113,0) - ; -"RTN","CCRUTIL",114,0) -DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL -"RTN","CCRUTIL",115,0) - ; ASSOCIATED SNOMED CODES -"RTN","CCRUTIL",116,0) - N DASTMP,DASIEN,DASNO -"RTN","CCRUTIL",117,0) - S DASTMP="" -"RTN","CCRUTIL",118,0) - F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED -"RTN","CCRUTIL",119,0) - . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED -"RTN","CCRUTIL",120,0) - . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY -"RTN","CCRUTIL",121,0) - . W DASTMP,"=",DASNO,! ; PRINT IT OUT -"RTN","CCRUTIL",122,0) - Q -"RTN","CCRUTIL",123,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 15 -"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^16^B57497934 -"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 15 -"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 AIEN="" D Q ; IEN CAN'T BE NULL -"RTN","GPLACTOR",47,0) - . . W "WARING NUL ACTOR: ",ATYP,! -"RTN","GPLACTOR",48,0) - . I ATYP="" Q ; NOT A VALID ACTOR -"RTN","GPLACTOR",49,0) - . ; -"RTN","GPLACTOR",50,0) - . I DEBUG W AOID_" "_ATYP_" "_AIEN,! -"RTN","GPLACTOR",51,0) - . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE -"RTN","GPLACTOR",52,0) - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") -"RTN","GPLACTOR",53,0) - . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") -"RTN","GPLACTOR",54,0) - . ; -"RTN","GPLACTOR",55,0) - . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE -"RTN","GPLACTOR",56,0) - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") -"RTN","GPLACTOR",57,0) - . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") -"RTN","GPLACTOR",58,0) - . ; -"RTN","GPLACTOR",59,0) - . I ATYP="NOK" D ; NOK ACTOR TYPE -"RTN","GPLACTOR",60,0) - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") -"RTN","GPLACTOR",61,0) - . . D NOK("ATMP",AIEN,AOID,"ATMP2") -"RTN","GPLACTOR",62,0) - . ; -"RTN","GPLACTOR",63,0) - . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE -"RTN","GPLACTOR",64,0) - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") -"RTN","GPLACTOR",65,0) - . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") -"RTN","GPLACTOR",66,0) - . ; -"RTN","GPLACTOR",67,0) - . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE -"RTN","GPLACTOR",68,0) - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") -"RTN","GPLACTOR",69,0) - . . D ORG("ATMP",AIEN,AOID,"ATMP2") -"RTN","GPLACTOR",70,0) - . ; -"RTN","GPLACTOR",71,0) - . W "PROCESSING:",ATYP," ",AIEN,! -"RTN","GPLACTOR",72,0) - . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE -"RTN","GPLACTOR",73,0) - . D INSINNER^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT -"RTN","GPLACTOR",74,0) - . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE -"RTN","GPLACTOR",75,0) - ; -"RTN","GPLACTOR",76,0) - N ACTTMP -"RTN","GPLACTOR",77,0) - D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS -"RTN","GPLACTOR",78,0) - I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - -"RTN","GPLACTOR",79,0) - . ; STRINGS MARKED AS @@X@@ -"RTN","GPLACTOR",80,0) - . W "ACTORS Missing list: ",! -"RTN","GPLACTOR",81,0) - . F I=1:1:ACTTMP(0) W ACTTMP(I),! -"RTN","GPLACTOR",82,0) - Q -"RTN","GPLACTOR",83,0) - ; -"RTN","GPLACTOR",84,0) -PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR -"RTN","GPLACTOR",85,0) - I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! -"RTN","GPLACTOR",86,0) - N AMAP,ZX -"RTN","GPLACTOR",87,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",88,0) - K @AMAP -"RTN","GPLACTOR",89,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",90,0) - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) -"RTN","GPLACTOR",91,0) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) -"RTN","GPLACTOR",92,0) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) -"RTN","GPLACTOR",93,0) - S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) -"RTN","GPLACTOR",94,0) - S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) -"RTN","GPLACTOR",95,0) - S @AMAP@("ACTORSSN")="" -"RTN","GPLACTOR",96,0) - S @AMAP@("ACTORSSNTEXT")="" -"RTN","GPLACTOR",97,0) - S @AMAP@("ACTORSSNSOURCEID")="" -"RTN","GPLACTOR",98,0) - S ZX=$$SSN^CCRDPT(AIEN) -"RTN","GPLACTOR",99,0) - I ZX'="" D ; IF THERE IS A SSN IN THE RECORD -"RTN","GPLACTOR",100,0) - . S @AMAP@("ACTORSSN")=ZX -"RTN","GPLACTOR",101,0) - . S @AMAP@("ACTORSSNTEXT")="SSN" -"RTN","GPLACTOR",102,0) - . S @AMAP@("ACTORSSNSOURCEID")=AOID -"RTN","GPLACTOR",103,0) - S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT(AIEN) -"RTN","GPLACTOR",104,0) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) -"RTN","GPLACTOR",105,0) - S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) -"RTN","GPLACTOR",106,0) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) -"RTN","GPLACTOR",107,0) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) -"RTN","GPLACTOR",108,0) - S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) -"RTN","GPLACTOR",109,0) - S @AMAP@("ACTORRESTEL")="" -"RTN","GPLACTOR",110,0) - S @AMAP@("ACTORRESTELTEXT")="" -"RTN","GPLACTOR",111,0) - S ZX=$$RESTEL^CCRDPT(AIEN) -"RTN","GPLACTOR",112,0) - I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD -"RTN","GPLACTOR",113,0) - . S @AMAP@("ACTORRESTEL")=ZX -"RTN","GPLACTOR",114,0) - . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" -"RTN","GPLACTOR",115,0) - S @AMAP@("ACTORWORKTEL")="" -"RTN","GPLACTOR",116,0) - S @AMAP@("ACTORWORKTELTEXT")="" -"RTN","GPLACTOR",117,0) - S ZX=$$WORKTEL^CCRDPT(AIEN) -"RTN","GPLACTOR",118,0) - I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD -"RTN","GPLACTOR",119,0) - . S @AMAP@("ACTORWORKTEL")=ZX -"RTN","GPLACTOR",120,0) - . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" -"RTN","GPLACTOR",121,0) - S @AMAP@("ACTORCELLTEL")="" -"RTN","GPLACTOR",122,0) - S @AMAP@("ACTORCELLTELTEXT")="" -"RTN","GPLACTOR",123,0) - S ZX=$$CELLTEL^CCRDPT(AIEN) -"RTN","GPLACTOR",124,0) - I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD -"RTN","GPLACTOR",125,0) - . S @AMAP@("ACTORCELLTEL")=ZX -"RTN","GPLACTOR",126,0) - . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" -"RTN","GPLACTOR",127,0) - S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT(AIEN) -"RTN","GPLACTOR",128,0) - S @AMAP@("ACTORADDRESSSOURCEID")=AOID -"RTN","GPLACTOR",129,0) - S @AMAP@("ACTORIEN")=AIEN -"RTN","GPLACTOR",130,0) - S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX -"RTN","GPLACTOR",131,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE -"RTN","GPLACTOR",132,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",133,0) - Q -"RTN","GPLACTOR",134,0) - ; -"RTN","GPLACTOR",135,0) -SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR -"RTN","GPLACTOR",136,0) - ; -"RTN","GPLACTOR",137,0) - ; N AMAP -"RTN","GPLACTOR",138,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",139,0) - K @AMAP -"RTN","GPLACTOR",140,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",141,0) - S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^CCRSYS -"RTN","GPLACTOR",142,0) - S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^CCRSYS -"RTN","GPLACTOR",143,0) - S @AMAP@("ACTORINFOSYSSOURCEID")=AOID -"RTN","GPLACTOR",144,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",145,0) - Q -"RTN","GPLACTOR",146,0) - ; -"RTN","GPLACTOR",147,0) -NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR -"RTN","GPLACTOR",148,0) - ; -"RTN","GPLACTOR",149,0) - ; N AMAP -"RTN","GPLACTOR",150,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",151,0) - K @AMAP -"RTN","GPLACTOR",152,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",153,0) - S @AMAP@("ACTORDISPLAYNAME")="" -"RTN","GPLACTOR",154,0) - S @AMAP@("ACTORRELATION")="" -"RTN","GPLACTOR",155,0) - S @AMAP@("ACTORRELATIONSOURCEID")="" -"RTN","GPLACTOR",156,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE -"RTN","GPLACTOR",157,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",158,0) - Q -"RTN","GPLACTOR",159,0) - ; -"RTN","GPLACTOR",160,0) -ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR -"RTN","GPLACTOR",161,0) - ; -"RTN","GPLACTOR",162,0) - ; N AMAP -"RTN","GPLACTOR",163,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",164,0) - K @AMAP -"RTN","GPLACTOR",165,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",166,0) - S @AMAP@("ORGANIZATIONNAME")=$P($$SITE^VASITE,U,2) -"RTN","GPLACTOR",167,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" -"RTN","GPLACTOR",168,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",169,0) - Q -"RTN","GPLACTOR",170,0) - ; -"RTN","GPLACTOR",171,0) -PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR -"RTN","GPLACTOR",172,0) - ; -"RTN","GPLACTOR",173,0) - ; N AMAP -"RTN","GPLACTOR",174,0) - S AMAP=$NA(^TMP($J,"AMAP")) -"RTN","GPLACTOR",175,0) - K @AMAP -"RTN","GPLACTOR",176,0) - I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN) -"RTN","GPLACTOR",177,0) - . W "WARNING - MISSING PROVIDER: ",AIEN,! -"RTN","GPLACTOR",178,0) - . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT -"RTN","GPLACTOR",179,0) - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID -"RTN","GPLACTOR",180,0) - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRVA200(AIEN) -"RTN","GPLACTOR",181,0) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRVA200(AIEN) -"RTN","GPLACTOR",182,0) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRVA200(AIEN) -"RTN","GPLACTOR",183,0) - S @AMAP@("ACTORTITLE")=$$TITLE^CCRVA200(AIEN) -"RTN","GPLACTOR",184,0) - S @AMAP@("IDTYPE")=$P($$NPI^CCRVA200(AIEN),U,1) -"RTN","GPLACTOR",185,0) - S @AMAP@("ID")=$P($$NPI^CCRVA200(AIEN),U,2) -"RTN","GPLACTOR",186,0) - S @AMAP@("IDDESC")=$P($$NPI^CCRVA200(AIEN),U,3) -"RTN","GPLACTOR",187,0) - S @AMAP@("ACTORSPECIALITY")=$$SPEC^CCRVA200(AIEN) -"RTN","GPLACTOR",188,0) - S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^CCRVA200(AIEN) -"RTN","GPLACTOR",189,0) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^CCRVA200(AIEN) -"RTN","GPLACTOR",190,0) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRVA200(AIEN) -"RTN","GPLACTOR",191,0) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRVA200(AIEN) -"RTN","GPLACTOR",192,0) - S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^CCRVA200(AIEN) -"RTN","GPLACTOR",193,0) - S @AMAP@("ACTORTELEPHONE")="" -"RTN","GPLACTOR",194,0) - S @AMAP@("ACTORTELEPHONETYPE")="" -"RTN","GPLACTOR",195,0) - S ZX=$$TEL^CCRVA200(AIEN) -"RTN","GPLACTOR",196,0) - I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE -"RTN","GPLACTOR",197,0) - . S @AMAP@("ACTORTELEPHONE")=ZX -"RTN","GPLACTOR",198,0) - . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^CCRVA200(AIEN) -"RTN","GPLACTOR",199,0) - S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRVA200(AIEN) -"RTN","GPLACTOR",200,0) - S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" -"RTN","GPLACTOR",201,0) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE -"RTN","GPLACTOR",202,0) - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE -"RTN","GPLACTOR",203,0) - Q -"RTN","GPLACTOR",204,0) - ; -"RTN","GPLALERT") -0^19^B21981592 -"RTN","GPLALERT",1,0) -GPLALERT ; CCDCCR/CKU - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 -"RTN","GPLALERT",2,0) - ;;0.1;CCDCCR;;SEP 11,2008;Build 15 -"RTN","GPLALERT",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","GPLALERT",4,0) - ;General Public License See attached copy of the License. -"RTN","GPLALERT",5,0) - ; -"RTN","GPLALERT",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","GPLALERT",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","GPLALERT",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","GPLALERT",9,0) - ;(at your option) any later version. -"RTN","GPLALERT",10,0) - ; -"RTN","GPLALERT",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","GPLALERT",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","GPLALERT",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","GPLALERT",14,0) - ;GNU General Public License for more details. -"RTN","GPLALERT",15,0) - ; -"RTN","GPLALERT",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","GPLALERT",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","GPLALERT",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","GPLALERT",19,0) - ; -"RTN","GPLALERT",20,0) - W "NO ENTRY FROM TOP",! -"RTN","GPLALERT",21,0) - Q -"RTN","GPLALERT",22,0) - ; -"RTN","GPLALERT",23,0) -EXTRACT(ALTXML,DFN,ALTOUTXML) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE -"RTN","GPLALERT",24,0) - ; -"RTN","GPLALERT",25,0) - ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","GPLALERT",26,0) - ; -"RTN","GPLALERT",27,0) - ; GET ADVERSE REACTIONS AND ALLERGIES -"RTN","GPLALERT",28,0) - ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES -"RTN","GPLALERT",29,0) - S GMRA="0^0^111" -"RTN","GPLALERT",30,0) - D EN1^GMRADPT -"RTN","GPLALERT",31,0) - I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* -"RTN","GPLALERT",32,0) - . S @ALTOUTXML@(0)=0 -"RTN","GPLALERT",33,0) - ; DEFINE MAPPING -"RTN","GPLALERT",34,0) - N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP -"RTN","GPLALERT",35,0) - S ALTTVMAP=$NA(^TMP("GPLCCR",$J,"ALERTS")) -"RTN","GPLALERT",36,0) - S ALTTARYTMP=$NA(^TMP("GPLCCR",$J,"ALERTSARYTMP")) -"RTN","GPLALERT",37,0) - K @ALTTVMAP,@ALTTARYTMP -"RTN","GPLALERT",38,0) - N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 -"RTN","GPLALERT",39,0) - S ALTTMP="" ; -"RTN","GPLALERT",40,0) - F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL -"RTN","GPLALERT",41,0) - . W "ALTTMP="_ALTTMP,! -"RTN","GPLALERT",42,0) - . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q -"RTN","GPLALERT",43,0) - . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) -"RTN","GPLALERT",44,0) - . K @ALTVMAP -"RTN","GPLALERT",45,0) - . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT -"RTN","GPLALERT",46,0) - . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES -"RTN","GPLALERT",47,0) - . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM -"RTN","GPLALERT",48,0) - . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG -"RTN","GPLALERT",49,0) - . N ADT S ADT="Patient has an " ; X $ZINT H 5 -"RTN","GPLALERT",50,0) - . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") -"RTN","GPLALERT",51,0) - . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." -"RTN","GPLALERT",52,0) - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT -"RTN","GPLALERT",53,0) - . N ALTCDE ; SNOMED CODE THE THE ALERT -"RTN","GPLALERT",54,0) - . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC -"RTN","GPLALERT",55,0) - . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; -"RTN","GPLALERT",56,0) - . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE -"RTN","GPLALERT",57,0) - . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE -"RTN","GPLALERT",58,0) - . I ALTCDE'="" D ; IF THERE IS A CODE -"RTN","GPLALERT",59,0) - . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" -"RTN","GPLALERT",60,0) - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" -"RTN","GPLALERT",61,0) - . E D ; SET TO NULL -"RTN","GPLALERT",62,0) - . . S @ALTVMAP@("ALERTCODESYSTEM")="" -"RTN","GPLALERT",63,0) - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" -"RTN","GPLALERT",64,0) - . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? -"RTN","GPLALERT",65,0) - . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN -"RTN","GPLALERT",66,0) - . I ALTPROV'="" D ; PROVIDER PROVIDEED -"RTN","GPLALERT",67,0) - . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV -"RTN","GPLALERT",68,0) - . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN -"RTN","GPLALERT",69,0) - . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! -"RTN","GPLALERT",70,0) - . N ACGL1,ACGFI,ACIEN,ACVUID -"RTN","GPLALERT",71,0) - . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, -"RTN","GPLALERT",72,0) - . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER -"RTN","GPLALERT",73,0) - . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT -"RTN","GPLALERT",74,0) - . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT -"RTN","GPLALERT",75,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT -"RTN","GPLALERT",76,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? -"RTN","GPLALERT",77,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=$P(@ALTG@(ALTTMP),U,2) ; REACTANT -"RTN","GPLALERT",78,0) - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID -"RTN","GPLALERT",79,0) - . I ACVUID'="" D ; IF VUID IS NOT NULL -"RTN","GPLALERT",80,0) - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID" -"RTN","GPLALERT",81,0) - . E D ; IF REACTANT CODE VALUE IS NULL -"RTN","GPLALERT",82,0) - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" -"RTN","GPLALERT",83,0) - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" -"RTN","GPLALERT",84,0) - . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW -"RTN","GPLALERT",85,0) - . N ARTMP,ARIEN,ARDES,ARVUID -"RTN","GPLALERT",86,0) - . S (ARTMP,ARDES,ARVUID)="" -"RTN","GPLALERT",87,0) - . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS -"RTN","GPLALERT",88,0) - . . S ARTMP=@ALTG@(ALTTMP,"S",1) -"RTN","GPLALERT",89,0) - . . W "REACTION:",ARTMP,! -"RTN","GPLALERT",90,0) - . . S ARIEN=$P(ARTMP,";",2) -"RTN","GPLALERT",91,0) - . . S ARDES=$P(ARTMP,";",1) -"RTN","GPLALERT",92,0) - . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") -"RTN","GPLALERT",93,0) - . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES -"RTN","GPLALERT",94,0) - . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL -"RTN","GPLALERT",95,0) - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID -"RTN","GPLALERT",96,0) - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" -"RTN","GPLALERT",97,0) - . E D ; IF IT IS NULL DON'T SET CODE SYSTEM -"RTN","GPLALERT",98,0) - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" -"RTN","GPLALERT",99,0) - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" -"RTN","GPLALERT",100,0) - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) -"RTN","GPLALERT",101,0) - . K @ALTARYTMP -"RTN","GPLALERT",102,0) - . D MAP^GPLXPATH(ALTXML,ALTVMAP,ALTARYTMP) -"RTN","GPLALERT",103,0) - . I ALTCNT=1 D CP^GPLXPATH(ALTARYTMP,ALTOUTXML) -"RTN","GPLALERT",104,0) - . I ALTCNT>1 D INSINNER^GPLXPATH(ALTOUTXML,ALTARYTMP) -"RTN","GPLALERT",105,0) - . S ALTCNT=ALTCNT+1 -"RTN","GPLALERT",106,0) - S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS -"RTN","GPLALERT",107,0) - Q -"RTN","GPLALERT",108,0) -PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER -"RTN","GPLALERT",109,0) - ; INGLB IS OF THE FORM: PSNDF(50.6, -"RTN","GPLALERT",110,0) - ; RETURN 50.6 -"RTN","GPLALERT",111,0) - Q $P($P(INGLB,"(",2),",",1) ; -"RTN","GPLCCD") -0^8^B114413975 -"RTN","GPLCCD",1,0) -GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 -"RTN","GPLCCD",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 15 -"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^15^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 15 -"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^13^B81638593 -"RTN","GPLCCR",1,0) -GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 -"RTN","GPLCCR",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 15 -"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,UDIR,UFN -"RTN","GPLCCR",34,0) - I '$D(DIR) S UDIR="" -"RTN","GPLCCR",35,0) - E S UDIR=DIR -"RTN","GPLCCR",36,0) - I '$D(FN) S UFN="" -"RTN","GPLCCR",37,0) - E S UFN=FN -"RTN","GPLCCR",38,0) - D CCRRPC(.CCRGLO,DFN,"CCR","","","") -"RTN","GPLCCR",39,0) - S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCR",1)) -"RTN","GPLCCR",40,0) - S ONAM=UFN -"RTN","GPLCCR",41,0) - I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_7.xml" -"RTN","GPLCCR",42,0) - S ODIRGLB=$NA(^TMP("GPLCCR","ODIR")) -"RTN","GPLCCR",43,0) - I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET -"RTN","GPLCCR",44,0) - . ;S @ODIRGLB="/home/glilly/CCROUT" -"RTN","GPLCCR",45,0) - . ;S @ODIRGLB="/home/cedwards/" -"RTN","GPLCCR",46,0) - . S @ODIRGLB="/opt/wv/p/" -"RTN","GPLCCR",47,0) - S ODIR=UDIR -"RTN","GPLCCR",48,0) - I UDIR="" S ODIR=@ODIRGLB -"RTN","GPLCCR",49,0) - N ZY -"RTN","GPLCCR",50,0) - S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) -"RTN","GPLCCR",51,0) - W !,$P(ZY,U,2),! -"RTN","GPLCCR",52,0) - Q -"RTN","GPLCCR",53,0) - ; -"RTN","GPLCCR",54,0) -DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED -"RTN","GPLCCR",55,0) - ; -"RTN","GPLCCR",56,0) - N G1 -"RTN","GPLCCR",57,0) - S G1=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) -"RTN","GPLCCR",58,0) - I $D(@G1@(0)) D ; CCR EXISTS -"RTN","GPLCCR",59,0) - . D PARY^GPLXPATH(G1) -"RTN","GPLCCR",60,0) - E W "CCR NOT CREATED, RUN D XPAT^GPLCCR(DFN,"""","""") FIRST",! -"RTN","GPLCCR",61,0) - Q -"RTN","GPLCCR",62,0) - ; -"RTN","GPLCCR",63,0) -CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT -"RTN","GPLCCR",64,0) - ; CCRGRTN IS RETURN ARRAY PASSED BY NAME -"RTN","GPLCCR",65,0) - ; DFN IS PATIENT IEN -"RTN","GPLCCR",66,0) - ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART -"RTN","GPLCCR",67,0) - ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC -"RTN","GPLCCR",68,0) - ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL -"RTN","GPLCCR",69,0) - ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME -"RTN","GPLCCR",70,0) - ; - NULL MEANS NOW -"RTN","GPLCCR",71,0) - ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND -"RTN","GPLCCR",72,0) - ; "TO" VARIABLES -"RTN","GPLCCR",73,0) - ; IF NULL WILL DEFAULT TO "FROM" DUZ AND "TO" DFN -"RTN","GPLCCR",74,0) - I '$D(DEBUG) S DEBUG=0 -"RTN","GPLCCR",75,0) - S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD -"RTN","GPLCCR",76,0) - I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION -"RTN","GPLCCR",77,0) - I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION -"RTN","GPLCCR",78,0) - I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING CCRMEDS SECTION -"RTN","GPLCCR",79,0) - S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE -"RTN","GPLCCR",80,0) - S CCRGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR -"RTN","GPLCCR",81,0) - S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS -"RTN","GPLCCR",82,0) - ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC -"RTN","GPLCCR",83,0) - S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL -"RTN","GPLCCR",84,0) - D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE -"RTN","GPLCCR",85,0) - D CP^GPLXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL -"RTN","GPLCCR",86,0) - ; -"RTN","GPLCCR",87,0) - ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL -"RTN","GPLCCR",88,0) - ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES -"RTN","GPLCCR",89,0) - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") -"RTN","GPLCCR",90,0) - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") -"RTN","GPLCCR",91,0) - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") -"RTN","GPLCCR",92,0) - I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! -"RTN","GPLCCR",93,0) - ; -"RTN","GPLCCR",94,0) - D HDRMAP(CCRGLO,DFN,HDRARY) ; MAP HEADER VARIABLES -"RTN","GPLCCR",95,0) - ; -"RTN","GPLCCR",96,0) - K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT -"RTN","GPLCCR",97,0) - S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS -"RTN","GPLCCR",98,0) - D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS -"RTN","GPLCCR",99,0) - N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD -"RTN","GPLCCR",100,0) - F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS -"RTN","GPLCCR",101,0) - . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE -"RTN","GPLCCR",102,0) - . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL -"RTN","GPLCCR",103,0) - . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL -"RTN","GPLCCR",104,0) - . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE -"RTN","GPLCCR",105,0) - . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS -"RTN","GPLCCR",106,0) - . S IXML="INXML" -"RTN","GPLCCR",107,0) - . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES -"RTN","GPLCCR",108,0) - . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY -"RTN","GPLCCR",109,0) - . ; W OXML,! -"RTN","GPLCCR",110,0) - . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL -"RTN","GPLCCR",111,0) - . W "RUNNING ",CALL,! -"RTN","GPLCCR",112,0) - . X CALL -"RTN","GPLCCR",113,0) - . ; NOW INSERT THE RESULTS IN THE CCR BUFFER -"RTN","GPLCCR",114,0) - . I @OXML@(0)'=0 D ; THERE IS A RESULT -"RTN","GPLCCR",115,0) - . . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") -"RTN","GPLCCR",116,0) - . . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! -"RTN","GPLCCR",117,0) - N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING -"RTN","GPLCCR",118,0) - D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST -"RTN","GPLCCR",119,0) - D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") -"RTN","GPLCCR",120,0) - D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") -"RTN","GPLCCR",121,0) - D INSINNER^GPLXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") -"RTN","GPLCCR",122,0) - N TRIMI,J,DONE S DONE=0 -"RTN","GPLCCR",123,0) - F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE -"RTN","GPLCCR",124,0) - . S J=$$TRIM^GPLXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS -"RTN","GPLCCR",125,0) - . I DEBUG W "TRIMMED",J,! -"RTN","GPLCCR",126,0) - . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE -"RTN","GPLCCR",127,0) - Q -"RTN","GPLCCR",128,0) - ; -"RTN","GPLCCR",129,0) -INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS -"RTN","GPLCCR",130,0) - ; TAB IS PASSED BY NAME -"RTN","GPLCCR",131,0) - I DEBUG W "TAB= ",TAB,! -"RTN","GPLCCR",132,0) - ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS -"RTN","GPLCCR",133,0) - D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") -"RTN","GPLCCR",134,0) - D PUSH^GPLXPATH(TAB,"EXTRACT;CCRMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") -"RTN","GPLCCR",135,0) - D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") -"RTN","GPLCCR",136,0) - D PUSH^GPLXPATH(TAB,"MAP;GPLLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""GPLCCR"",$J,DFN,""RESULTS"")") -"RTN","GPLCCR",137,0) - I TESTALERT D PUSH^GPLXPATH(TAB,"EXTRACT;GPLALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""GPLCCR"",$J,DFN,""ALERTS"")") -"RTN","GPLCCR",138,0) - Q -"RTN","GPLCCR",139,0) - ; -"RTN","GPLCCR",140,0) -HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT -"RTN","GPLCCR",141,0) - N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) -"RTN","GPLCCR",142,0) - ; K @VMAP -"RTN","GPLCCR",143,0) - S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") -"RTN","GPLCCR",144,0) - I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS -"RTN","GPLCCR",145,0) - . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN -"RTN","GPLCCR",146,0) - . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? -"RTN","GPLCCR",147,0) - . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM -"RTN","GPLCCR",148,0) - . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES -"RTN","GPLCCR",149,0) - . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES -"RTN","GPLCCR",150,0) - . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES -"RTN","GPLCCR",151,0) - . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT -"RTN","GPLCCR",152,0) - I IHDR'="" D ; HEADER VALUES ARE PROVIDED -"RTN","GPLCCR",153,0) - . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY -"RTN","GPLCCR",154,0) - N CTMP -"RTN","GPLCCR",155,0) - D MAP^GPLXPATH(CXML,VMAP,"CTMP") -"RTN","GPLCCR",156,0) - D CP^GPLXPATH("CTMP",CXML) -"RTN","GPLCCR",157,0) - Q -"RTN","GPLCCR",158,0) - ; -"RTN","GPLCCR",159,0) -ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML -"RTN","GPLCCR",160,0) - ; AXML AND ACTRTN ARE PASSED BY NAME -"RTN","GPLCCR",161,0) - ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 -"RTN","GPLCCR",162,0) - ; P1= OBJECTID - ACTORPATIENT_2 -"RTN","GPLCCR",163,0) - ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE -"RTN","GPLCCR",164,0) - ;OR INSTITUTION -"RTN","GPLCCR",165,0) - ; OR PERSON(IN PATIENT FILE IE NOK) -"RTN","GPLCCR",166,0) - ; P3= IEN RECORD NUMBER FOR ACTOR - 2 -"RTN","GPLCCR",167,0) - N I,J,K,L -"RTN","GPLCCR",168,0) - K @ACTRTN ; CLEAR RETURN ARRAY -"RTN","GPLCCR",169,0) - F I=1:1:@AXML@(0) D ; SCAN ALL LINES -"RTN","GPLCCR",170,0) - . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE -"RTN","GPLCCR",171,0) - . . S J=$P($P(@AXML@(I),"",2),"",1) -"RTN","GPLCCR",172,0) - . . I DEBUG W "=>",J,! -"RTN","GPLCCR",173,0) - . . I J'="" S K(J)="" ; HASHING ACTOR -"RTN","GPLCCR",174,0) - . . ; TO GET RID OF DUPLICATES -"RTN","GPLCCR",175,0) - S I="" ; GOING TO $O THROUGH THE HASH -"RTN","GPLCCR",176,0) - F J=0:0 D Q:$O(K(I))="" -"RTN","GPLCCR",177,0) - . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS -"RTN","GPLCCR",178,0) - . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID -"RTN","GPLCCR",179,0) - . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE -"RTN","GPLCCR",180,0) - . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR -"RTN","GPLCCR",181,0) - . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY -"RTN","GPLCCR",182,0) - Q -"RTN","GPLCCR",183,0) - ; -"RTN","GPLCCR",184,0) -TEST ; RUN ALL THE TEST CASES -"RTN","GPLCCR",185,0) - D TESTALL^GPLUNIT("GPLCCR") -"RTN","GPLCCR",186,0) - Q -"RTN","GPLCCR",187,0) - ; -"RTN","GPLCCR",188,0) -ZTEST(WHICH) ; RUN ONE SET OF TESTS -"RTN","GPLCCR",189,0) - N ZTMP -"RTN","GPLCCR",190,0) - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") -"RTN","GPLCCR",191,0) - D ZTEST^GPLUNIT(.ZTMP,WHICH) -"RTN","GPLCCR",192,0) - Q -"RTN","GPLCCR",193,0) - ; -"RTN","GPLCCR",194,0) -TLIST ; LIST THE TESTS -"RTN","GPLCCR",195,0) - N ZTMP -"RTN","GPLCCR",196,0) - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") -"RTN","GPLCCR",197,0) - D TLIST^GPLUNIT(.ZTMP) -"RTN","GPLCCR",198,0) - Q -"RTN","GPLCCR",199,0) - ; -"RTN","GPLCCR",200,0) - ;;> -"RTN","GPLCCR",201,0) - ;;> -"RTN","GPLCCR",202,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",203,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") -"RTN","GPLCCR",204,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",205,0) - ;;> -"RTN","GPLCCR",206,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",207,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") -"RTN","GPLCCR",208,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",209,0) - ;;> -"RTN","GPLCCR",210,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",211,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") -"RTN","GPLCCR",212,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",213,0) - ;;> -"RTN","GPLCCR",214,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",215,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") -"RTN","GPLCCR",216,0) - ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") -"RTN","GPLCCR",217,0) - ;;> -"RTN","GPLCCR",218,0) - ;;>>>D ZTEST^GPLCCR("ACTLST") -"RTN","GPLCCR",219,0) - ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") -"RTN","GPLCCR",220,0) - ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") -"RTN","GPLCCR",221,0) - ;;>>?G3(G3(0))["" -"RTN","GPLCCR",222,0) - ;;> -"RTN","GPLCCR",223,0) - ;;>>>D ZTEST^GPLCCR("CCR") -"RTN","GPLCCR",224,0) - ;;>>>W $$TRIM^GPLXPATH(CCRGLO) -"RTN","GPLCCR",225,0) - ;;> -"RTN","GPLCCR",226,0) - ;;>>>S TESTALERT=1 -"RTN","GPLCCR",227,0) - ;;>>>K GPL S GPL="" -"RTN","GPLCCR",228,0) - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","ALERTS","","","") -"RTN","GPLCCR",229,0) - ;;>>?@GPL@(@GPL@(0))["" -"RTN","GPLCCR",230,0) - -"RTN","GPLCCR0") -0^14^B555785104 -"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 15 -"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","GPLLABS") -0^22^B221616742 -"RTN","GPLLABS",1,0) -GPLALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 -"RTN","GPLLABS",2,0) - ;;0.3;CCDCCR;nopatch;noreleasedate;Build 15 -"RTN","GPLLABS",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","GPLLABS",4,0) - ;General Public License See attached copy of the License. -"RTN","GPLLABS",5,0) - ; -"RTN","GPLLABS",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","GPLLABS",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","GPLLABS",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","GPLLABS",9,0) - ;(at your option) any later version. -"RTN","GPLLABS",10,0) - ; -"RTN","GPLLABS",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","GPLLABS",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","GPLLABS",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","GPLLABS",14,0) - ;GNU General Public License for more details. -"RTN","GPLLABS",15,0) - ; -"RTN","GPLLABS",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","GPLLABS",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","GPLLABS",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","GPLLABS",19,0) - ; -"RTN","GPLLABS",20,0) -;MAP(DFN,MOXML,MIVAR,MIXML) ; MAP RESULTS VARIABLES TO XML - GPL -TBD -"RTN","GPLLABS",21,0) -MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT -"RTN","GPLLABS",22,0) - ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR -"RTN","GPLLABS",23,0) - ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME -"RTN","GPLLABS",24,0) - ; MIXML IS THE TEMPLATE TO USE -"RTN","GPLLABS",25,0) - ; MOXML IS THE OUTPUT XML ARRAY -"RTN","GPLLABS",26,0) - ; DFN IS THE PATIENT RECORD NUMBER -"RTN","GPLLABS",27,0) - N C0COXML,C0CO,C0CV,C0CIXML -"RTN","GPLLABS",28,0) - I '$D(MIVAR) S C0CV="" ;DEFAULT -"RTN","GPLLABS",29,0) - E S C0CV=MIVAR ;PASSED VARIABLE ARRAY -"RTN","GPLLABS",30,0) - I '$D(MIXML) S C0CIXML="" ;DEFAULT -"RTN","GPLLABS",31,0) - E S C0CIXML=MIXML ;PASSED INPUT XML -"RTN","GPLLABS",32,0) - D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK -"RTN","GPLLABS",33,0) - I '$D(MOXML) S C0CO=$NA(^TMP("GPLCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT -"RTN","GPLLABS",34,0) - E S C0CO=MOXML -"RTN","GPLLABS",35,0) - ; ZWR C0COXML -"RTN","GPLLABS",36,0) - M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT -"RTN","GPLLABS",37,0) - Q -"RTN","GPLLABS",38,0) - ; -"RTN","GPLLABS",39,0) -RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS -"RTN","GPLLABS",40,0) - ; RTN IS PASSED BY REFERENCE -"RTN","GPLLABS",41,0) - ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES -"RTN","GPLLABS",42,0) - ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE -"RTN","GPLLABS",43,0) - I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING -"RTN","GPLLABS",44,0) - I RMIXML="" D ; INPUT XML NOT PASSED -"RTN","GPLLABS",45,0) - . D LOAD^GPLCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE -"RTN","GPLLABS",46,0) - . D QUERY^GPLXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R") -"RTN","GPLLABS",47,0) - . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE -"RTN","GPLLABS",48,0) - E S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE -"RTN","GPLLABS",49,0) - I RMIVAR="" D ; LOCATION OF VARIABLES NOT PASSED -"RTN","GPLLABS",50,0) - . S C0CV=$NA(^TMP("GPLCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION -"RTN","GPLLABS",51,0) - E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS -"RTN","GPLLABS",52,0) - D CP^GPLXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE -"RTN","GPLLABS",53,0) - D REPLACE^GPLXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ -"RTN","GPLLABS",54,0) - D QUERY^GPLXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE -"RTN","GPLLABS",55,0) - I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT -"RTN","GPLLABS",56,0) - I 'C0CQT D ; WE ARE DEBUGGING -"RTN","GPLLABS",57,0) - . W "I MAPPED",! -"RTN","GPLLABS",58,0) - . W "VARS:",C0CV,! -"RTN","GPLLABS",59,0) - . W "DFN:",DFN,! -"RTN","GPLLABS",60,0) - . ;D PARY^GPLXPATH("C0CT") ; SECTION TEMPLATE -"RTN","GPLLABS",61,0) - . ;D PARY^GPLXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) -"RTN","GPLLABS",62,0) - . ;D PARY^GPLXPATH("C0CTT") ;TEST TEMPLATE (OCX) -"RTN","GPLLABS",63,0) - D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT -"RTN","GPLLABS",64,0) - I '$D(@C0CV@(0)) D Q ; NO VARS THERE -"RTN","GPLLABS",65,0) - . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR -"RTN","GPLLABS",66,0) - I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS -"RTN","GPLLABS",67,0) - S RIMVARS=$NA(^TMP("GPLRIM","VARS",DFN,"RESULTS")) -"RTN","GPLLABS",68,0) - K @RIMVARS -"RTN","GPLLABS",69,0) - M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH -"RTN","GPLLABS",70,0) - N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP -"RTN","GPLLABS",71,0) - S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR) -"RTN","GPLLABS",72,0) - N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT -"RTN","GPLLABS",73,0) - F C0CI=1:1:C0CIN D ; LOOP THROUGH VARIABLES -"RTN","GPLLABS",74,0) - . K C0CMAP,C0CTMP,C0CRTMP ;EMPTY OUT LAST BATCH OF VARIABLES -"RTN","GPLLABS",75,0) - . S C0CMAP=$NA(@C0CV@(C0CI)) ; -"RTN","GPLLABS",76,0) - . I 'C0CQT W "MAPOBR:",C0CMAP,! -"RTN","GPLLABS",77,0) - . ;MAPPING FOR TEST REQUEST GOES HERE -"RTN","GPLLABS",78,0) - . D MAP^GPLXPATH("C0CRT",C0CMAP,"C0CRTMP") ; MAP OBR DATA -"RTN","GPLLABS",79,0) - . I $D(@C0CMAP@("M","TESTS",0)) D ; TESTS EXIST -"RTN","GPLLABS",80,0) - . . S C0CJN=@C0CMAP@("M","TESTS",0) ; NUMBER OF TESTS -"RTN","GPLLABS",81,0) - . . K C0CTO ; CLEAR OUTPUT VARIABLE -"RTN","GPLLABS",82,0) - . . F C0CJ=1:1:C0CJN D ;FOR EACH TEST RESULT -"RTN","GPLLABS",83,0) - . . . K C0CTMAP,C0CTMP ; EMPTY MAPS FOR TEST RESULTS -"RTN","GPLLABS",84,0) - . . . S C0CTMAP=$NA(@C0CMAP@("M","TESTS",C0CJ)) ; -"RTN","GPLLABS",85,0) - . . . I 'C0CQT W "MAPOBX:",C0CTMAP,! -"RTN","GPLLABS",86,0) - . . . D MAP^GPLXPATH("C0CTT",C0CTMAP,"C0CTMP") ; MAP TO TMP -"RTN","GPLLABS",87,0) - . . . ;I C0CJ=1 D ; FIRST TIME, JUST COPY -"RTN","GPLLABS",88,0) - . . . ;. D CP^GPLXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML -"RTN","GPLLABS",89,0) - . . . ;E D INSINNER^GPLXPATH("C0CTO","C0CTMP") -"RTN","GPLLABS",90,0) - . . . ; -"RTN","GPLLABS",91,0) - . . . D PUSHA^GPLXPATH("C0CTO","C0CTMP") ;ADD THE TEST TO BUFFER -"RTN","GPLLABS",92,0) - . . ; I 'C0CQT D PARY^GPLXPATH("C0CTO") -"RTN","GPLLABS",93,0) - . . D INSINNER^GPLXPATH("C0CRTMP","C0CTO","//Results/Result/Test") ;INSERT TST -"RTN","GPLLABS",94,0) - . I C0CI=1 D ; FIRST TIME, COPY INSTEAD OF INSERT -"RTN","GPLLABS",95,0) - . . D CP^GPLXPATH("C0CRTMP","RTN") ; -"RTN","GPLLABS",96,0) - . E D INSINNER^GPLXPATH("RTN","C0CRTMP") ; INSERT THIS TEST REQUEST -"RTN","GPLLABS",97,0) - Q -"RTN","GPLLABS",98,0) - ; -"RTN","GPLLABS",99,0) -EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL -"RTN","GPLLABS",100,0) - ; -"RTN","GPLLABS",101,0) - ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED -"RTN","GPLLABS",102,0) - ; -"RTN","GPLLABS",103,0) - ; -"RTN","GPLLABS",104,0) - ; -"RTN","GPLLABS",105,0) - N C0CNSSN ; IS THERE AN SSN FLAG -"RTN","GPLLABS",106,0) - S C0CNSSN=0 -"RTN","GPLLABS",107,0) - S C0CLB=$NA(^TMP("GPLCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS -"RTN","GPLLABS",108,0) - D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT -"RTN","GPLLABS",109,0) - I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT -"RTN","GPLLABS",110,0) - . S @C0CLB@(0)=0 -"RTN","GPLLABS",111,0) - K @C0CLB ; CLEAR OUT OLD VARS IF ANY -"RTN","GPLLABS",112,0) - N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG -"RTN","GPLLABS",113,0) - S C0CQT=1 ; SURPRESS LISTING -"RTN","GPLLABS",114,0) - D LIST ; EXTRACT THE VARIABLES -"RTN","GPLLABS",115,0) - S C0CQT=QTSAV ; RESET SILENT FLAG -"RTN","GPLLABS",116,0) - K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT -"RTN","GPLLABS",117,0) - I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^GPLLABS -"RTN","GPLLABS",118,0) - Q -"RTN","GPLLABS",119,0) - ; -"RTN","GPLLABS",120,0) -GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT -"RTN","GPLLABS",121,0) - ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR -"RTN","GPLLABS",122,0) - ; SET UP FOR LAB API CALL -"RTN","GPLLABS",123,0) - S C0CPTID=$$SSN^CCRDPT(DFN) ; GET THE SSN FOR THIS PATIENT -"RTN","GPLLABS",124,0) - I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT -"RTN","GPLLABS",125,0) - . W "LAB LOOKUP FAILED, NO SSN",! -"RTN","GPLLABS",126,0) - . S C0CNSSN=1 ; SET NO SSN FLAG -"RTN","GPLLABS",127,0) - S C0CSPC="*" ; LOOKING FOR ALL LABS -"RTN","GPLLABS",128,0) - D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING -"RTN","GPLLABS",129,0) - D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY TO GET EVERYTHING -"RTN","GPLLABS",130,0) - S C0CR=$$GCPR^LA7QRY(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP -"RTN","GPLLABS",131,0) - Q -"RTN","GPLLABS",132,0) - ; -"RTN","GPLLABS",133,0) -LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB -"RTN","GPLLABS",134,0) - ; -"RTN","GPLLABS",135,0) - ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR -"RTN","GPLLABS",136,0) - I '$D(C0CLB) S C0CLB=$NA(^TMP("GPLCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS -"RTN","GPLLABS",137,0) - I '$D(C0CQT) S C0CQT=0 -"RTN","GPLLABS",138,0) - I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT -"RTN","GPLLABS",139,0) - I '$D(^KVAI(0)) D SETTBL ; INITIALIZE LAB TABLE -"RTN","GPLLABS",140,0) - I ^KBAI(0)'="V2" D SETTBL ; NEED NEWEST VERSION -"RTN","GPLLABS",141,0) - I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE -"RTN","GPLLABS",142,0) - S C0CTAB=$NA(^KBAI) ; BASE OF OBX TABLE -"RTN","GPLLABS",143,0) - S C0CHB=$NA(^TMP("HLS",$J)) -"RTN","GPLLABS",144,0) - S C0CI="" -"RTN","GPLLABS",145,0) - S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT -"RTN","GPLLABS",146,0) - F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG -"RTN","GPLLABS",147,0) - . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES -"RTN","GPLLABS",148,0) - . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) -"RTN","GPLLABS",149,0) - . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) -"RTN","GPLLABS",150,0) - . M XV=C0CVAR ; -"RTN","GPLLABS",151,0) - . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION -"RTN","GPLLABS",152,0) - . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT -"RTN","GPLLABS",153,0) - . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT -"RTN","GPLLABS",154,0) - . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS -"RTN","GPLLABS",155,0) - . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI -"RTN","GPLLABS",156,0) - . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR -"RTN","GPLLABS",157,0) - . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) -"RTN","GPLLABS",158,0) - . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT -"RTN","GPLLABS",159,0) - . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL -"RTN","GPLLABS",160,0) - . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CX2,"DT") ;UTC TIME -"RTN","GPLLABS",161,0) - . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS -"RTN","GPLLABS",162,0) - . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION -"RTN","GPLLABS",163,0) - . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 -"RTN","GPLLABS",164,0) - . . ; RESULTTESTCODEVALUE -"RTN","GPLLABS",165,0) - . . ; RESULTTESTDESCRIPTIONTEXT -"RTN","GPLLABS",166,0) - . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC -"RTN","GPLLABS",167,0) - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE -"RTN","GPLLABS",168,0) - . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC -"RTN","GPLLABS",169,0) - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT -"RTN","GPLLABS",170,0) - . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC -"RTN","GPLLABS",171,0) - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE -"RTN","GPLLABS",172,0) - . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC -"RTN","GPLLABS",173,0) - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT -"RTN","GPLLABS",174,0) - . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT -"RTN","GPLLABS",175,0) - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE -"RTN","GPLLABS",176,0) - . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME -"RTN","GPLLABS",177,0) - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT -"RTN","GPLLABS",178,0) - . . E D ; NO SECONDARY, USE PRIMARY -"RTN","GPLLABS",179,0) - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE -"RTN","GPLLABS",180,0) - . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME -"RTN","GPLLABS",181,0) - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT -"RTN","GPLLABS",182,0) - . I C0CTYP="OBX" D ; PROCESS TEST RESULTS -"RTN","GPLLABS",183,0) - . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION -"RTN","GPLLABS",184,0) - . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TESTS")) ; INDENT FOR TEST RESULTS -"RTN","GPLLABS",185,0) - . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT -"RTN","GPLLABS",186,0) - . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT -"RTN","GPLLABS",187,0) - . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX -"RTN","GPLLABS",188,0) - . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE -"RTN","GPLLABS",189,0) - . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER -"RTN","GPLLABS",190,0) - . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 -"RTN","GPLLABS",191,0) - . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") -"RTN","GPLLABS",192,0) - . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT -"RTN","GPLLABS",193,0) - . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL -"RTN","GPLLABS",194,0) - . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CX2,"DT") ;UTC TIME -"RTN","GPLLABS",195,0) - . . ; I 'C0CQT ZWR XV -"RTN","GPLLABS",196,0) - . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES -"RTN","GPLLABS",197,0) - . I 'C0CQT D ; -"RTN","GPLLABS",198,0) - . . W C0CI," ",C0CTYP,! -"RTN","GPLLABS",199,0) - . ; S C0CI=$O(@C0CHB@(C0CI)) -"RTN","GPLLABS",200,0) - ;K ^TMP("GPLRIM","VARS",DFN,"RESULTS") -"RTN","GPLLABS",201,0) - ;M ^TMP("GPLRIM","VARS",DFN,"RESULTS")=@C0CLB -"RTN","GPLLABS",202,0) - Q -"RTN","GPLLABS",203,0) -LTYP(OSEG,OTYP,OVARA,OC0CQT) ; -"RTN","GPLLABS",204,0) - S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE -"RTN","GPLLABS",205,0) - I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT -"RTN","GPLLABS",206,0) - E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG -"RTN","GPLLABS",207,0) - I 1 D ; FOR HL7 SEGMENT TYPE -"RTN","GPLLABS",208,0) - . S OI="" ; INDEX INTO FIELDS IN SEG -"RTN","GPLLABS",209,0) - . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT -"RTN","GPLLABS",210,0) - . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX -"RTN","GPLLABS",211,0) - . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED -"RTN","GPLLABS",212,0) - . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE -"RTN","GPLLABS",213,0) - . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE -"RTN","GPLLABS",214,0) - . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX -"RTN","GPLLABS",215,0) - . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE -"RTN","GPLLABS",216,0) - . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE -"RTN","GPLLABS",217,0) - . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE -"RTN","GPLLABS",218,0) - . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! -"RTN","GPLLABS",219,0) - Q -"RTN","GPLLABS",220,0) -LOBX ; -"RTN","GPLLABS",221,0) - Q -"RTN","GPLLABS",222,0) - ; -"RTN","GPLLABS",223,0) -SETTBL ; -"RTN","GPLLABS",224,0) - K X ; CLEAR X -"RTN","GPLLABS",225,0) - S X("PID","PID1")="1^00104^Set ID - Patient ID" -"RTN","GPLLABS",226,0) - S X("PID","PID2")="2^00105^Patient ID (External ID)" -"RTN","GPLLABS",227,0) - S X("PID","PID3")="3^00106^Patient ID (Internal ID)" -"RTN","GPLLABS",228,0) - S X("PID","PID4")="4^00107^Alternate Patient ID" -"RTN","GPLLABS",229,0) - S X("PID","PID5")="5^00108^Patient's Name" -"RTN","GPLLABS",230,0) - S X("PID","PID6")="6^00109^Mother's Maiden Name" -"RTN","GPLLABS",231,0) - S X("PID","PID7")="7^00110^Date of Birth" -"RTN","GPLLABS",232,0) - S X("PID","PID8")="8^00111^Sex" -"RTN","GPLLABS",233,0) - S X("PID","PID9")="9^00112^Patient Alias" -"RTN","GPLLABS",234,0) - S X("PID","PID10")="10^00113^Race" -"RTN","GPLLABS",235,0) - S X("PID","PID11")="11^00114^Patient Address" -"RTN","GPLLABS",236,0) - S X("PID","PID12")="12^00115^County Code" -"RTN","GPLLABS",237,0) - S X("PID","PID13")="13^00116^Phone Number - Home" -"RTN","GPLLABS",238,0) - S X("PID","PID14")="14^00117^Phone Number - Business" -"RTN","GPLLABS",239,0) - S X("PID","PID15")="15^00118^Language - Patient" -"RTN","GPLLABS",240,0) - S X("PID","PID16")="16^00119^Marital Status" -"RTN","GPLLABS",241,0) - S X("PID","PID17")="17^00120^Religion" -"RTN","GPLLABS",242,0) - S X("PID","PID18")="18^00121^Patient Account Number" -"RTN","GPLLABS",243,0) - S X("PID","PID19")="19^00122^SSN Number - Patient" -"RTN","GPLLABS",244,0) - S X("PID","PID20")="20^00123^Drivers License - Patient" -"RTN","GPLLABS",245,0) - S X("PID","PID21")="21^00124^Mother's Identifier" -"RTN","GPLLABS",246,0) - S X("PID","PID22")="22^00125^Ethnic Group" -"RTN","GPLLABS",247,0) - S X("PID","PID23")="23^00126^Birth Place" -"RTN","GPLLABS",248,0) - S X("PID","PID24")="24^00127^Multiple Birth Indicator" -"RTN","GPLLABS",249,0) - S X("PID","PID25")="25^00128^Birth Order" -"RTN","GPLLABS",250,0) - S X("PID","PID26")="26^00129^Citizenship" -"RTN","GPLLABS",251,0) - S X("PID","PID27")="27^00130^Veteran.s Military Status" -"RTN","GPLLABS",252,0) - S X("PID","PID28")="28^00739^Nationality" -"RTN","GPLLABS",253,0) - S X("PID","PID29")="29^00740^Patient Death Date/Time" -"RTN","GPLLABS",254,0) - S X("PID","PID30")="30^00741^Patient Death Indicator" -"RTN","GPLLABS",255,0) - S X("NTE","NTE1")="1^00573^Set ID - NTE" -"RTN","GPLLABS",256,0) - S X("NTE","NTE2")="2^00574^Source of Comment" -"RTN","GPLLABS",257,0) - S X("NTE","NTE3")="3^00575^Comment" -"RTN","GPLLABS",258,0) - S X("ORC","ORC1")="1^00215^Order Control" -"RTN","GPLLABS",259,0) - S X("ORC","ORC2")="2^00216^Placer Order Number" -"RTN","GPLLABS",260,0) - S X("ORC","ORC3")="3^00217^Filler Order Number" -"RTN","GPLLABS",261,0) - S X("ORC","ORC4")="4^00218^Placer Order Number" -"RTN","GPLLABS",262,0) - S X("ORC","ORC5")="5^00219^Order Status" -"RTN","GPLLABS",263,0) - S X("ORC","ORC6")="6^00220^Response Flag" -"RTN","GPLLABS",264,0) - S X("ORC","ORC7")="7^00221^Quantity/Timing" -"RTN","GPLLABS",265,0) - S X("ORC","ORC8")="8^00222^Parent" -"RTN","GPLLABS",266,0) - S X("ORC","ORC9")="9^00223^Date/Time of Transaction" -"RTN","GPLLABS",267,0) - S X("ORC","ORC10")="10^00224^Entered By" -"RTN","GPLLABS",268,0) - S X("ORC","ORC11")="11^00225^Verified By" -"RTN","GPLLABS",269,0) - S X("ORC","ORC12")="12^00226^Ordering Provider" -"RTN","GPLLABS",270,0) - S X("ORC","ORC13")="13^00227^Enterer's Location" -"RTN","GPLLABS",271,0) - S X("ORC","ORC14")="14^00228^Call Back Phone Number" -"RTN","GPLLABS",272,0) - S X("ORC","ORC15")="15^00229^Order Effective Date/Time" -"RTN","GPLLABS",273,0) - S X("ORC","ORC16")="16^00230^Order Control Code Reason" -"RTN","GPLLABS",274,0) - S X("ORC","ORC17")="17^00231^Entering Organization" -"RTN","GPLLABS",275,0) - S X("ORC","ORC18")="18^00232^Entering Device" -"RTN","GPLLABS",276,0) - S X("ORC","ORC19")="19^00233^Action By" -"RTN","GPLLABS",277,0) - S X("OBR","OBR1")="1^00237^Set ID - Observation Request" -"RTN","GPLLABS",278,0) - S X("OBR","OBR2")="2^00216^Placer Order Number" -"RTN","GPLLABS",279,0) - S X("OBR","OBR3")="3^00217^Filler Order Number" -"RTN","GPLLABS",280,0) - S X("OBR","OBR4")="4^00238^Universal Service ID" -"RTN","GPLLABS",281,0) - S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" -"RTN","GPLLABS",282,0) - S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" -"RTN","GPLLABS",283,0) - S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" -"RTN","GPLLABS",284,0) - S X("OBR","OBR5")="5^00239^Priority" -"RTN","GPLLABS",285,0) - S X("OBR","OBR6")="6^00240^Requested Date/Time" -"RTN","GPLLABS",286,0) - S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" -"RTN","GPLLABS",287,0) - S X("OBR","OBR8")="8^00242^Observation End Date/Time" -"RTN","GPLLABS",288,0) - S X("OBR","OBR9")="9^00243^Collection Volume" -"RTN","GPLLABS",289,0) - S X("OBR","OBR10")="10^00244^Collector Identifier" -"RTN","GPLLABS",290,0) - S X("OBR","OBR11")="11^00245^Specimen Action Code" -"RTN","GPLLABS",291,0) - S X("OBR","OBR12")="12^00246^Danger Code" -"RTN","GPLLABS",292,0) - S X("OBR","OBR13")="13^00247^Relevant Clinical Info." -"RTN","GPLLABS",293,0) - S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" -"RTN","GPLLABS",294,0) - S X("OBR","OBR15")="15^00249^Specimen Source" -"RTN","GPLLABS",295,0) - S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" -"RTN","GPLLABS",296,0) - S X("OBR","OBR17")="17^00250^Order Callback Phone Number" -"RTN","GPLLABS",297,0) - S X("OBR","OBR18")="18^00251^Placers Field 1" -"RTN","GPLLABS",298,0) - S X("OBR","OBR19")="19^00252^Placers Field 2" -"RTN","GPLLABS",299,0) - S X("OBR","OBR20")="20^00253^Filler Field 1" -"RTN","GPLLABS",300,0) - S X("OBR","OBR21")="21^00254^Filler Field 2" -"RTN","GPLLABS",301,0) - S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" -"RTN","GPLLABS",302,0) - S X("OBR","OBR23")="23^00256^Charge to Practice" -"RTN","GPLLABS",303,0) - S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" -"RTN","GPLLABS",304,0) - S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" -"RTN","GPLLABS",305,0) - S X("OBR","OBR26")="26^00259^Parent Result" -"RTN","GPLLABS",306,0) - S X("OBR","OBR27")="27^00221^Quantity/Timing" -"RTN","GPLLABS",307,0) - S X("OBR","OBR28")="28^00260^Result Copies to" -"RTN","GPLLABS",308,0) - S X("OBR","OBR29")="29^00261^Parent Number" -"RTN","GPLLABS",309,0) - S X("OBR","OBR30")="30^00262^Transportation Mode" -"RTN","GPLLABS",310,0) - S X("OBR","OBR31")="31^00263^Reason for Study" -"RTN","GPLLABS",311,0) - S X("OBR","OBR32")="32^00264^Principal Result Interpreter" -"RTN","GPLLABS",312,0) - S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" -"RTN","GPLLABS",313,0) - S X("OBR","OBR34")="34^00266^Technician" -"RTN","GPLLABS",314,0) - S X("OBR","OBR35")="35^00267^Transcriptionist" -"RTN","GPLLABS",315,0) - S X("OBR","OBR36")="36^00268^Scheduled Date/Time" -"RTN","GPLLABS",316,0) - S X("OBR","OBR37")="37^01028^Number of Sample Containers" -"RTN","GPLLABS",317,0) - S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" -"RTN","GPLLABS",318,0) - S X("OBR","OBR39")="39^01030^Collector.s Comment" -"RTN","GPLLABS",319,0) - S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" -"RTN","GPLLABS",320,0) - S X("OBR","OBR41")="41^01032^Transport Arranged" -"RTN","GPLLABS",321,0) - S X("OBR","OBR42")="42^01033^Escort Required" -"RTN","GPLLABS",322,0) - S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" -"RTN","GPLLABS",323,0) - S X("OBX","OBX1")="1^00559^Set ID - OBX" -"RTN","GPLLABS",324,0) - S X("OBX","OBX2")="2^00676^Value Type" -"RTN","GPLLABS",325,0) - S X("OBX","OBX3")="3^00560^Observation Identifier" -"RTN","GPLLABS",326,0) - S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" -"RTN","GPLLABS",327,0) - S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" -"RTN","GPLLABS",328,0) - S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" -"RTN","GPLLABS",329,0) - S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" -"RTN","GPLLABS",330,0) - S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" -"RTN","GPLLABS",331,0) - S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" -"RTN","GPLLABS",332,0) - S X("OBX","OBX4")="4^00769^Observation Sub-Id" -"RTN","GPLLABS",333,0) - S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" -"RTN","GPLLABS",334,0) - S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" -"RTN","GPLLABS",335,0) - S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCRIPTIONTEXT" -"RTN","GPLLABS",336,0) - S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" -"RTN","GPLLABS",337,0) - S X("OBX","OBX9")="9^00639^Probability" -"RTN","GPLLABS",338,0) - S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" -"RTN","GPLLABS",339,0) - S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" -"RTN","GPLLABS",340,0) - S X("OBX","OBX12")="12^00567^Date Last Normal Value" -"RTN","GPLLABS",341,0) - S X("OBX","OBX13")="13^00581^User Defined Access Checks" -"RTN","GPLLABS",342,0) - S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" -"RTN","GPLLABS",343,0) - S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" -"RTN","GPLLABS",344,0) - S X("OBX","OBX16")="16^00584^Responsible Observer" -"RTN","GPLLABS",345,0) - S X("OBX","OBX17")="17^00936^Observation Method" -"RTN","GPLLABS",346,0) - M ^KBAI=X ; SET VALUES IN ^KBAI -"RTN","GPLLABS",347,0) - S ^KBAI(0)="V2" -"RTN","GPLLABS",348,0) - Q -"RTN","GPLLABS",349,0) - ; -"RTN","GPLPROBS") -0^20^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 15 -"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^18^B244980714 -"RTN","GPLRIMA",1,0) -GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 -"RTN","GPLRIMA",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 15 -"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) - . I $D(^TMP("GPLCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST -"RTN","GPLRIMA",68,0) - . . W "FOUND ALERT VARS",! -"RTN","GPLRIMA",69,0) - . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("GPLCCR",$J,"ALERTS") -"RTN","GPLRIMA",70,0) - . I $D(^TMP("GPLCCR",$J,"RESULTS",0)) D ; RESULTS EXIST -"RTN","GPLRIMA",71,0) - . . W "FOUND RESULTS VARS",! -"RTN","GPLRIMA",72,0) - . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("GPLCCR",$J,"RESULTS") -"RTN","GPLRIMA",73,0) - . K ^TMP("GPLCCR",$J) ; KILL WORK AREA FOR CCR BUILDING -"RTN","GPLRIMA",74,0) - . ; -"RTN","GPLRIMA",75,0) - . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP -"RTN","GPLRIMA",76,0) - . ; -"RTN","GPLRIMA",77,0) - . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS -"RTN","GPLRIMA",78,0) - . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT -"RTN","GPLRIMA",79,0) - . ; -"RTN","GPLRIMA",80,0) - . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL -"RTN","GPLRIMA",81,0) - . ; -"RTN","GPLRIMA",82,0) - . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS -"RTN","GPLRIMA",83,0) - . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED -"RTN","GPLRIMA",84,0) - . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT -"RTN","GPLRIMA",85,0) - . ; -"RTN","GPLRIMA",86,0) - . N CATNAME,CATTBL -"RTN","GPLRIMA",87,0) - . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) -"RTN","GPLRIMA",88,0) - . S CATNAME="" -"RTN","GPLRIMA",89,0) - . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY -"RTN","GPLRIMA",90,0) - . W "CATEGORY NAME: ",CATNAME,! -"RTN","GPLRIMA",91,0) - . ; -"RTN","GPLRIMA",92,0) - . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^CCRSYS(RIMDFN) ; NEXT PATIENT -"RTN","GPLRIMA",93,0) - . ; PTST TESTS TO SEE IF PATIENT WAS MERGED -"RTN","GPLRIMA",94,0) - . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT -"RTN","GPLRIMA",95,0) - . ; AND WE SKIP IT -"RTN","GPLRIMA",96,0) - . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN -"RTN","GPLRIMA",97,0) - ; D PARY^GPLXPATH(@RIMBASE@("ATTRTBL")) -"RTN","GPLRIMA",98,0) - Q -"RTN","GPLRIMA",99,0) - ; -"RTN","GPLRIMA",100,0) -SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS -"RTN","GPLRIMA",101,0) - N SBASE,SATTR -"RTN","GPLRIMA",102,0) - S SBASE=$NA(@RIMBASE@("VARS",SDFN)) -"RTN","GPLRIMA",103,0) - D APOST("SATTR","RIMTBL","HEADER") -"RTN","GPLRIMA",104,0) - I $D(@SBASE@("PROBLEMS",1)) D ; -"RTN","GPLRIMA",105,0) - . D APOST("SATTR","RIMTBL","PROBLEMS") -"RTN","GPLRIMA",106,0) - . ; W "POSTING PROBLEMS",! -"RTN","GPLRIMA",107,0) - I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") -"RTN","GPLRIMA",108,0) - I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES -"RTN","GPLRIMA",109,0) - . D APOST("SATTR","RIMTBL","MEDS") -"RTN","GPLRIMA",110,0) - . N ZR,ZI -"RTN","GPLRIMA",111,0) - . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES -"RTN","GPLRIMA",112,0) - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN -"RTN","GPLRIMA",113,0) - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS -"RTN","GPLRIMA",114,0) - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES -"RTN","GPLRIMA",115,0) - . ; D PATD^GPLRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES -"RTN","GPLRIMA",116,0) - I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS -"RTN","GPLRIMA",117,0) - . D APOST("SATTR","RIMTBL","ALERTS") -"RTN","GPLRIMA",118,0) - . N ZR,ZI -"RTN","GPLRIMA",119,0) - . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES -"RTN","GPLRIMA",120,0) - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN -"RTN","GPLRIMA",121,0) - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS -"RTN","GPLRIMA",122,0) - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES -"RTN","GPLRIMA",123,0) - I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES -"RTN","GPLRIMA",124,0) - . D APOST("SATTR","RIMTBL","RESULTS") -"RTN","GPLRIMA",125,0) - . N ZR,ZI -"RTN","GPLRIMA",126,0) - . S ZR(0)=0 ; INITIALIZE TO NONE -"RTN","GPLRIMA",127,0) - . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES -"RTN","GPLRIMA",128,0) - . ; D PARY^GPLXPATH("ZR") ; -"RTN","GPLRIMA",129,0) - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN -"RTN","GPLRIMA",130,0) - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS -"RTN","GPLRIMA",131,0) - . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK -"RTN","GPLRIMA",132,0) - . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; -"RTN","GPLRIMA",133,0) - ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED -"RTN","GPLRIMA",134,0) - W "ATTRIBUTES: ",SATTR,! -"RTN","GPLRIMA",135,0) - Q SATTR -"RTN","GPLRIMA",136,0) - ; -"RTN","GPLRIMA",137,0) -RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES -"RTN","GPLRIMA",138,0) - K ^TMP("GPLRIM","RESUME") -"RTN","GPLRIMA",139,0) - K ^TMP("GPLRIM") -"RTN","GPLRIMA",140,0) - Q -"RTN","GPLRIMA",141,0) - ; -"RTN","GPLRIMA",142,0) -CLIST ; LIST THE CATEGORIES -"RTN","GPLRIMA",143,0) - ; -"RTN","GPLRIMA",144,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",145,0) - N CLBASE,CLNUM,ZI,CLIDX -"RTN","GPLRIMA",146,0) - S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) -"RTN","GPLRIMA",147,0) - S CLNUM=@CLBASE@(0) -"RTN","GPLRIMA",148,0) - F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES -"RTN","GPLRIMA",149,0) - . S CLIDX=@CLBASE@(ZI) -"RTN","GPLRIMA",150,0) - . W "(",$P(@CLBASE@(CLIDX),"^",1) -"RTN","GPLRIMA",151,0) - . W ":",$P(@CLBASE@(CLIDX),"^",2),") " -"RTN","GPLRIMA",152,0) - . W CLIDX,! -"RTN","GPLRIMA",153,0) - ; D PARY^GPLXPATH(CLBASE) -"RTN","GPLRIMA",154,0) - Q -"RTN","GPLRIMA",155,0) - ; -"RTN","GPLRIMA",156,0) -CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES -"RTN","GPLRIMA",157,0) - ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT -"RTN","GPLRIMA",158,0) - ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE -"RTN","GPLRIMA",159,0) - ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME -"RTN","GPLRIMA",160,0) - ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, -"RTN","GPLRIMA",161,0) - ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" -"RTN","GPLRIMA",162,0) - ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES -"RTN","GPLRIMA",163,0) - ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY -"RTN","GPLRIMA",164,0) - ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING -"RTN","GPLRIMA",165,0) - ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY -"RTN","GPLRIMA",166,0) - ; NUMBER IE CTBL_X(CDFN)="" -"RTN","GPLRIMA",167,0) - ; -"RTN","GPLRIMA",168,0) - ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST -"RTN","GPLRIMA",169,0) - S CCTBL=$NA(@CBASE@(CTBL,"CATS")) -"RTN","GPLRIMA",170,0) - W "CBASE: ",CCTBL,! -"RTN","GPLRIMA",171,0) - ; -"RTN","GPLRIMA",172,0) - I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY -"RTN","GPLRIMA",173,0) - . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY -"RTN","GPLRIMA",174,0) - . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY -"RTN","GPLRIMA",175,0) - . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT -"RTN","GPLRIMA",176,0) - . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY -"RTN","GPLRIMA",177,0) - . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME -"RTN","GPLRIMA",178,0) - . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 -"RTN","GPLRIMA",179,0) - ; -"RTN","GPLRIMA",180,0) - S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY -"RTN","GPLRIMA",181,0) - S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT -"RTN","GPLRIMA",182,0) - S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK -"RTN","GPLRIMA",183,0) - ; -"RTN","GPLRIMA",184,0) - S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED -"RTN","GPLRIMA",185,0) - ; -"RTN","GPLRIMA",186,0) - S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT -"RTN","GPLRIMA",187,0) - W "PATS BASE: ",CPATLIST,! -"RTN","GPLRIMA",188,0) - S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST -"RTN","GPLRIMA",189,0) - ; -"RTN","GPLRIMA",190,0) - Q -"RTN","GPLRIMA",191,0) - ; -"RTN","GPLRIMA",192,0) -CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE -"RTN","GPLRIMA",193,0) - ; -"RTN","GPLRIMA",194,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",195,0) - N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT -"RTN","GPLRIMA",196,0) - S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES -"RTN","GPLRIMA",197,0) - S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS -"RTN","GPLRIMA",198,0) - S ZTOT=0 ; INITIALIZE OVERALL TOTAL -"RTN","GPLRIMA",199,0) - F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS -"RTN","GPLRIMA",200,0) - . S ZCNT=0 -"RTN","GPLRIMA",201,0) - . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY -"RTN","GPLRIMA",202,0) - . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME -"RTN","GPLRIMA",203,0) - . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST -"RTN","GPLRIMA",204,0) - . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS -"RTN","GPLRIMA",205,0) - . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT -"RTN","GPLRIMA",206,0) - . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! -"RTN","GPLRIMA",207,0) - . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) -"RTN","GPLRIMA",208,0) - . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) -"RTN","GPLRIMA",209,0) - . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD -"RTN","GPLRIMA",210,0) - . S ZTOT=ZTOT+ZCNT -"RTN","GPLRIMA",211,0) - W "TOTAL: ",ZTOT,! -"RTN","GPLRIMA",212,0) - Q -"RTN","GPLRIMA",213,0) - ; -"RTN","GPLRIMA",214,0) -CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST -"RTN","GPLRIMA",215,0) - ; INLST IS PASSED BY NAME -"RTN","GPLRIMA",216,0) - N ZI,ZDX,ZCOUNT -"RTN","GPLRIMA",217,0) - W INLST,! -"RTN","GPLRIMA",218,0) - S ZCOUNT=0 -"RTN","GPLRIMA",219,0) - S ZDX="" -"RTN","GPLRIMA",220,0) - F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END -"RTN","GPLRIMA",221,0) - . S ZCOUNT=ZCOUNT+1 -"RTN","GPLRIMA",222,0) - . S ZDX=$O(@INLST@(ZDX)) -"RTN","GPLRIMA",223,0) - . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! -"RTN","GPLRIMA",224,0) - Q ZCOUNT -"RTN","GPLRIMA",225,0) - ; -"RTN","GPLRIMA",226,0) -XCPAT(CPATCAT) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT -"RTN","GPLRIMA",227,0) - ; -"RTN","GPLRIMA",228,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",229,0) - N ZI,ZJ,ZC,ZPATBASE -"RTN","GPLRIMA",230,0) - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) -"RTN","GPLRIMA",231,0) - S ZI="" -"RTN","GPLRIMA",232,0) - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END -"RTN","GPLRIMA",233,0) - . S ZI=$O(@ZPATBASE@(ZI)) -"RTN","GPLRIMA",234,0) - . D XPAT^GPLCCR(ZI,"","") ; EXPORT THE PATIENT TO A FILE -"RTN","GPLRIMA",235,0) - Q -"RTN","GPLRIMA",236,0) - ; -"RTN","GPLRIMA",237,0) -CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT -"RTN","GPLRIMA",238,0) - ; -"RTN","GPLRIMA",239,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",240,0) - N ZI,ZJ,ZC,ZPATBASE -"RTN","GPLRIMA",241,0) - S ZC=0 ; COUNT FOR SPACING THE PRINTOUT -"RTN","GPLRIMA",242,0) - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) -"RTN","GPLRIMA",243,0) - S ZI="" -"RTN","GPLRIMA",244,0) - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END -"RTN","GPLRIMA",245,0) - . S ZI=$O(@ZPATBASE@(ZI)) -"RTN","GPLRIMA",246,0) - . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT -"RTN","GPLRIMA",247,0) - . W ZI," " -"RTN","GPLRIMA",248,0) - . I ZC=10 D ; NEW LINE -"RTN","GPLRIMA",249,0) - . . S ZC=0 -"RTN","GPLRIMA",250,0) - . . W ! -"RTN","GPLRIMA",251,0) - Q -"RTN","GPLRIMA",252,0) - ; -"RTN","GPLRIMA",253,0) -PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT -"RTN","GPLRIMA",254,0) - ; -"RTN","GPLRIMA",255,0) - N ATTR S ATTR="" -"RTN","GPLRIMA",256,0) - I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT -"RTN","GPLRIMA",257,0) - . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT -"RTN","GPLRIMA",258,0) - S ATTR=^TMP("GPLRIM","ATTR",DFN) -"RTN","GPLRIMA",259,0) - I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND -"RTN","GPLRIMA",260,0) - I $D(^TMP("GPLRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT -"RTN","GPLRIMA",261,0) - . N CAT -"RTN","GPLRIMA",262,0) - . S CAT=$P(^TMP("GPLRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT -"RTN","GPLRIMA",263,0) - . W CAT,": ",ATTR,! -"RTN","GPLRIMA",264,0) - Q -"RTN","GPLRIMA",265,0) - ; -"RTN","GPLRIMA",266,0) -APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) -"RTN","GPLRIMA",267,0) - ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT -"RTN","GPLRIMA",268,0) - ; AND AMAP(N)=AVAL IS THE NTH AVAL -"RTN","GPLRIMA",269,0) - ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE -"RTN","GPLRIMA",270,0) - ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE -"RTN","GPLRIMA",271,0) - ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED -"RTN","GPLRIMA",272,0) - ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED -"RTN","GPLRIMA",273,0) - ; -"RTN","GPLRIMA",274,0) - I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST -"RTN","GPLRIMA",275,0) - . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS -"RTN","GPLRIMA",276,0) - S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT -"RTN","GPLRIMA",277,0) - S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY -"RTN","GPLRIMA",278,0) - S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF -"RTN","GPLRIMA",279,0) - Q -"RTN","GPLRIMA",280,0) - ; -"RTN","GPLRIMA",281,0) -ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL -"RTN","GPLRIMA",282,0) - I '$D(RIMBASE) S RIMBASE=$NA(^TMP("GPLRIM")) -"RTN","GPLRIMA",283,0) - I '$D(@RIMBASE) S @RIMBASE="" -"RTN","GPLRIMA",284,0) - I '$D(RIMTBL) S RIMTBL=$NA(^TMP("GPLRIM","RIMTBL","TABLE")) ; ATTR TABLE -"RTN","GPLRIMA",285,0) - S ^TMP("GPLRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES -"RTN","GPLRIMA",286,0) - Q -"RTN","GPLRIMA",287,0) - ; -"RTN","GPLRIMA",288,0) -AINIT ; INITIALIZE ATTRIBUTE TABLE -"RTN","GPLRIMA",289,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",290,0) - K @RIMTBL -"RTN","GPLRIMA",291,0) - D APUSH(RIMTBL,"EXTRACTED") -"RTN","GPLRIMA",292,0) - D APUSH(RIMTBL,"NOTEXTRACTED") -"RTN","GPLRIMA",293,0) - D APUSH(RIMTBL,"HEADER") -"RTN","GPLRIMA",294,0) - D APUSH(RIMTBL,"NOPCP") -"RTN","GPLRIMA",295,0) - D APUSH(RIMTBL,"PCP") -"RTN","GPLRIMA",296,0) - D APUSH(RIMTBL,"PROBLEMS") -"RTN","GPLRIMA",297,0) - D APUSH(RIMTBL,"PROBCODE") -"RTN","GPLRIMA",298,0) - D APUSH(RIMTBL,"PROBNOCODE") -"RTN","GPLRIMA",299,0) - D APUSH(RIMTBL,"PROBDATE") -"RTN","GPLRIMA",300,0) - D APUSH(RIMTBL,"PROBNODATE") -"RTN","GPLRIMA",301,0) - D APUSH(RIMTBL,"VITALS") -"RTN","GPLRIMA",302,0) - D APUSH(RIMTBL,"VITALSCODE") -"RTN","GPLRIMA",303,0) - D APUSH(RIMTBL,"VITALSNOCODE") -"RTN","GPLRIMA",304,0) - D APUSH(RIMTBL,"VITALSDATE") -"RTN","GPLRIMA",305,0) - D APUSH(RIMTBL,"VITALSNODATE") -"RTN","GPLRIMA",306,0) - D APUSH(RIMTBL,"MEDS") -"RTN","GPLRIMA",307,0) - D APUSH(RIMTBL,"MEDSCODE") -"RTN","GPLRIMA",308,0) - D APUSH(RIMTBL,"MEDSNOCODE") -"RTN","GPLRIMA",309,0) - D APUSH(RIMTBL,"MEDSDATE") -"RTN","GPLRIMA",310,0) - D APUSH(RIMTBL,"MEDSNODATE") -"RTN","GPLRIMA",311,0) - D APUSH(RIMTBL,"ALERTS") -"RTN","GPLRIMA",312,0) - D APUSH(RIMTBL,"ALERTSCODE") -"RTN","GPLRIMA",313,0) - D APUSH(RIMTBL,"RESULTS") -"RTN","GPLRIMA",314,0) - D APUSH(RIMTBL,"RESULTSLN") -"RTN","GPLRIMA",315,0) - Q -"RTN","GPLRIMA",316,0) - ; -"RTN","GPLRIMA",317,0) -APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL -"RTN","GPLRIMA",318,0) - ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING -"RTN","GPLRIMA",319,0) - ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES -"RTN","GPLRIMA",320,0) - ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) -"RTN","GPLRIMA",321,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING -"RTN","GPLRIMA",322,0) - N USETBL -"RTN","GPLRIMA",323,0) - I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE -"RTN","GPLRIMA",324,0) - . W "ERROR NO SUCH TABLE",! -"RTN","GPLRIMA",325,0) - S USETBL=@RIMBASE@("TABLES",PTBL) -"RTN","GPLRIMA",326,0) - S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL -"RTN","GPLRIMA",327,0) - Q -"RTN","GPLRIMA",328,0) -GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN -"RTN","GPLRIMA",329,0) - ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") -"RTN","GPLRIMA",330,0) - ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 -"RTN","GPLRIMA",331,0) - ; IN SECTION "MEDS" -"RTN","GPLRIMA",332,0) - ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS -"RTN","GPLRIMA",333,0) - ; PENDING FOR MED 2 FOR PATIENT 2 -"RTN","GPLRIMA",334,0) - ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE -"RTN","GPLRIMA",335,0) - ; RETURNED. RTN IS PASSED BY REFERENCE -"RTN","GPLRIMA",336,0) - ; -"RTN","GPLRIMA",337,0) - S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE -"RTN","GPLRIMA",338,0) - I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES -"RTN","GPLRIMA",339,0) - S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES -"RTN","GPLRIMA",340,0) - I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION -"RTN","GPLRIMA",341,0) - . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! -"RTN","GPLRIMA",342,0) - N ZZI,ZZS -"RTN","GPLRIMA",343,0) - S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT -"RTN","GPLRIMA",344,0) - ; ZWR @ZZS@(1) -"RTN","GPLRIMA",345,0) - S RTN(0)=@ZZS@(0) -"RTN","GPLRIMA",346,0) - F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) -"RTN","GPLRIMA",347,0) - . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE -"RTN","GPLRIMA",348,0) - . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE -"RTN","GPLRIMA",349,0) - Q -"RTN","GPLRIMA",350,0) - ; -"RTN","GPLRIMA",351,0) -PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR -"RTN","GPLRIMA",352,0) - ; -"RTN","GPLRIMA",353,0) - N ZR -"RTN","GPLRIMA",354,0) - D GETPA(.ZR,DFN,ISEC,IVAR) -"RTN","GPLRIMA",355,0) - I $D(ZR(0)) D PARY^GPLXPATH("ZR") -"RTN","GPLRIMA",356,0) - E W "NOTHING RETURNED",! -"RTN","GPLRIMA",357,0) - Q -"RTN","GPLRIMA",358,0) - ; -"RTN","GPLRIMA",359,0) -CAGET(RTN,IATTR) ; -"RTN","GPLRIMA",360,0) - ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR -"RTN","GPLRIMA",361,0) - ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE -"RTN","GPLRIMA",362,0) - ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC -"RTN","GPLRIMA",363,0) - Q -"RTN","GPLRIMA",364,0) - ; -"RTN","GPLRIMA",365,0) -PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR -"RTN","GPLRIMA",366,0) - ; -"RTN","GPLRIMA",367,0) - I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES -"RTN","GPLRIMA",368,0) - N ZLST -"RTN","GPLRIMA",369,0) - S LSTRTN(0)=0 ; DEFAULT RETURN NONE -"RTN","GPLRIMA",370,0) - S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES -"RTN","GPLRIMA",371,0) - S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS -"RTN","GPLRIMA",372,0) - N ZNC ; ZNC IS NUMBER OF CATEGORIES -"RTN","GPLRIMA",373,0) - S ZNC=@ZCBASE@(0) -"RTN","GPLRIMA",374,0) - I ZNC=0 Q ; NO CATEGORIES TO SEARCH -"RTN","GPLRIMA",375,0) - N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE -"RTN","GPLRIMA",376,0) - S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) -"RTN","GPLRIMA",377,0) - N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT -"RTN","GPLRIMA",378,0) - F ZI=1:1:ZNC D ; FOR ALL CATEGORIES -"RTN","GPLRIMA",379,0) - . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT -"RTN","GPLRIMA",380,0) - . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR -"RTN","GPLRIMA",381,0) - . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL -"RTN","GPLRIMA",382,0) - . . M LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT -"RTN","GPLRIMA",383,0) - S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS -"RTN","GPLRIMA",384,0) - S ZPAT=0 ; START AT FIRST PATIENT IN LIST -"RTN","GPLRIMA",385,0) - F S ZPAT=$O(LSTRTN(ZPAT)) Q:ZPAT="" D ; -"RTN","GPLRIMA",386,0) - . S ZCNT=ZCNT+1 -"RTN","GPLRIMA",387,0) - S LSTRTN(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY -"RTN","GPLRIMA",388,0) - Q -"RTN","GPLRIMA",389,0) - ; -"RTN","GPLRIMA",390,0) -DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR -"RTN","GPLRIMA",391,0) - ; -"RTN","GPLRIMA",392,0) - N ZR -"RTN","GPLRIMA",393,0) - D PCLST(.ZR,CATTR) -"RTN","GPLRIMA",394,0) - I ZR(0)=0 D Q ; -"RTN","GPLRIMA",395,0) - . W "NO PATIENTS RETURNED",! -"RTN","GPLRIMA",396,0) - E D ; -"RTN","GPLRIMA",397,0) - . D PARY^GPLXPATH("ZR") ; PRINT ARRAY -"RTN","GPLRIMA",398,0) - . W "COUNT=",ZR(0),! -"RTN","GPLRIMA",399,0) - Q -"RTN","GPLRIMA",400,0) - ; -"RTN","GPLRIMA",401,0) -RPCGV(RTN,DFN,WHICH) ; RPC GET VARS -"RTN","GPLRIMA",402,0) - ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES -"RTN","GPLRIMA",403,0) - ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT -"RTN","GPLRIMA",404,0) - ; DFN IS THE PATIENT NUMBER. -"RTN","GPLRIMA",405,0) - ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS" -"RTN","GPLRIMA",406,0) - ; OR OTHER SECTIONS AS THEY ARE ADDED -"RTN","GPLRIMA",407,0) - ; THIS IS MEANT TO BE AVAILABLE AS AN RPC -"RTN","GPLRIMA",408,0) - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS -"RTN","GPLRIMA",409,0) - S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES -"RTN","GPLRIMA",410,0) - S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED -"RTN","GPLRIMA",411,0) - N ZZGI -"RTN","GPLRIMA",412,0) - I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS -"RTN","GPLRIMA",413,0) - . F ZZGI="PROBLEMS","VITALS","MEDS","ALERTS","RESULTS" D ; EACH SECTION -"RTN","GPLRIMA",414,0) - . . D ZGVWRK(ZZGI) ; DO EACH SECTION -"RTN","GPLRIMA",415,0) - E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR -"RTN","GPLRIMA",416,0) - Q -"RTN","GPLRIMA",417,0) - ; -"RTN","GPLRIMA",418,0) -ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV -"RTN","GPLRIMA",419,0) - ; -"RTN","GPLRIMA",420,0) - N ZZGN ; NAME FOR SECTION VARIABLES -"RTN","GPLRIMA",421,0) - S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION -"RTN","GPLRIMA",422,0) - I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION -"RTN","GPLRIMA",423,0) - E D ; VARS EXIST -"RTN","GPLRIMA",424,0) - . N ZGVI -"RTN","GPLRIMA",425,0) - . F ZGVI=1:1:@ZZGN@(0) D ; FOR EACH MULTIPLE IN SECTION -"RTN","GPLRIMA",426,0) - . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS -"RTN","GPLRIMA",427,0) - . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE -"RTN","GPLRIMA",428,0) - . . S ZZGN2=$NA(@ZZGN@(ZGVI)) -"RTN","GPLRIMA",429,0) - . . ; W ZZGN2,!,$O(@ZZGN2@("")),! -"RTN","GPLRIMA",430,0) - . . D H2ARY^GPLXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY -"RTN","GPLRIMA",431,0) - . . ; D PARY^GPLXPATH("ZZGA") -"RTN","GPLRIMA",432,0) - . . D PUSHA^GPLXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN -"RTN","GPLRIMA",433,0) - Q -"RTN","GPLRIMA",434,0) - ; -"RTN","GPLRIMA",435,0) -DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN GPLRIM -"RTN","GPLRIMA",436,0) - ; ALONG WITH SAMPLE VALUES. -"RTN","GPLRIMA",437,0) - ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS" -"RTN","GPLRIMA",438,0) - N GTMP -"RTN","GPLRIMA",439,0) - I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT -"RTN","GPLRIMA",440,0) - . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES -"RTN","GPLRIMA",441,0) - I '$D(IWHICH) S IWHICH="ALL" -"RTN","GPLRIMA",442,0) - D RPCGV(.GTMP,DFN,IWHICH) -"RTN","GPLRIMA",443,0) - D PARY^GPLXPATH("GTMP") -"RTN","GPLRIMA",444,0) - Q -"RTN","GPLRIMA",445,0) - ; -"RTN","GPLUNIT") -0^12^B31452964 -"RTN","GPLUNIT",1,0) -GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 -"RTN","GPLUNIT",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 15 -"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 ZI=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^17^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 15 -"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^21^B51026779 -"RTN","GPLXPAT0",1,0) -GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 -"RTN","GPLXPAT0",2,0) - ;;0.2;CCDCCR;nopatch;noreleasedate;Build 15 -"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^B255658739 -"RTN","GPLXPATH",1,0) -GPLXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 -"RTN","GPLXPATH",2,0) - ;;0.2;CCDCCR;nopatch;noreleasedate;Build 15 -"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,IPRE) ; CONVERT IHASH TO RETURN ARRAY -"RTN","GPLXPATH",436,0) - ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE -"RTN","GPLXPATH",437,0) - I '$D(IPRE) S IPRE="" -"RTN","GPLXPATH",438,0) - N H2I S H2I="" -"RTN","GPLXPATH",439,0) - ; W $O(@IHASH@(H2I)),! -"RTN","GPLXPATH",440,0) - F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH -"RTN","GPLXPATH",441,0) - . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES -"RTN","GPLXPATH",442,0) - . . ;W H2I_"^"_@IHASH@(H2I),! -"RTN","GPLXPATH",443,0) - . . N IH,IHI -"RTN","GPLXPATH",444,0) - . . S IH=$NA(@IHASH@(H2I)) ; -"RTN","GPLXPATH",445,0) - . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR -"RTN","GPLXPATH",446,0) - . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE -"RTN","GPLXPATH",447,0) - . . S IHI="" ; INDEX INTO "M" MULTIPLES -"RTN","GPLXPATH",448,0) - . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE -"RTN","GPLXPATH",449,0) - . . . ; W @IH@(IHI) -"RTN","GPLXPATH",450,0) - . . . S IH3=$NA(@IH2@(IHI)) -"RTN","GPLXPATH",451,0) - . . . ; W "HEY",IH3,! -"RTN","GPLXPATH",452,0) - . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS -"RTN","GPLXPATH",453,0) - . . ; W IH,! -"RTN","GPLXPATH",454,0) - . . ; W "GPLZZ",! -"RTN","GPLXPATH",455,0) - . . ; W $NA(@IHASH@(H2I)),! -"RTN","GPLXPATH",456,0) - . . Q ; -"RTN","GPLXPATH",457,0) - . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) -"RTN","GPLXPATH",458,0) - . ; W @IARYRTN@(0),! -"RTN","GPLXPATH",459,0) - Q -"RTN","GPLXPATH",460,0) - ; -"RTN","GPLXPATH",461,0) -XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES -"RTN","GPLXPATH",462,0) - ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ -"RTN","GPLXPATH",463,0) - ; XVRTN AND XVIXML ARE PASSED BY NAME -"RTN","GPLXPATH",464,0) - ; -"RTN","GPLXPATH",465,0) - N XVI,XVTMP,XVT -"RTN","GPLXPATH",466,0) - F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML -"RTN","GPLXPATH",467,0) - . S XVT=@XVIXML@(XVI) -"RTN","GPLXPATH",468,0) - . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI -"RTN","GPLXPATH",469,0) - D H2ARY(XVRTN,"XVTMP") -"RTN","GPLXPATH",470,0) - Q -"RTN","GPLXPATH",471,0) - ; -"RTN","GPLXPATH",472,0) -DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE -"RTN","GPLXPATH",473,0) - ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE -"RTN","GPLXPATH",474,0) - ; -"RTN","GPLXPATH",475,0) - N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED -"RTN","GPLXPATH",476,0) - I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE -"RTN","GPLXPATH",477,0) - . D LOAD^GPLCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP -"RTN","GPLXPATH",478,0) - . S DXUSE="DTMP" ; DXUSE IS NAME -"RTN","GPLXPATH",479,0) - E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE -"RTN","GPLXPATH",480,0) - . D LOAD^GPLCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP -"RTN","GPLXPATH",481,0) - . S DXUSE="DTMP" ; DXUSE IS NAME -"RTN","GPLXPATH",482,0) - E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE -"RTN","GPLXPATH",483,0) - N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE -"RTN","GPLXPATH",484,0) - D XVARS("DVARS",DXUSE) ; PULL OUT VARS -"RTN","GPLXPATH",485,0) - D PARY^GPLXPATH("DVARS") ;AND DISPLAY THEM -"RTN","GPLXPATH",486,0) - Q -"RTN","GPLXPATH",487,0) - ; -"RTN","GPLXPATH",488,0) -TEST ; Run all the test cases -"RTN","GPLXPATH",489,0) - D TESTALL^GPLUNIT("GPLXPAT0") -"RTN","GPLXPATH",490,0) - Q -"RTN","GPLXPATH",491,0) - ; -"RTN","GPLXPATH",492,0) -ZTEST(WHICH) ; RUN ONE SET OF TESTS -"RTN","GPLXPATH",493,0) - N ZTMP -"RTN","GPLXPATH",494,0) - S DEBUG=1 -"RTN","GPLXPATH",495,0) - D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") -"RTN","GPLXPATH",496,0) - D ZTEST^GPLUNIT(.ZTMP,WHICH) -"RTN","GPLXPATH",497,0) - Q -"RTN","GPLXPATH",498,0) - ; -"RTN","GPLXPATH",499,0) -TLIST ; LIST THE TESTS -"RTN","GPLXPATH",500,0) - N ZTMP -"RTN","GPLXPATH",501,0) - D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") -"RTN","GPLXPATH",502,0) - D TLIST^GPLUNIT(.ZTMP) -"RTN","GPLXPATH",503,0) - Q -"RTN","GPLXPATH",504,0) - ; -"RTN","LA7QRY1") -0^23^B12511401 -"RTN","LA7QRY1",1,0) -LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 -"RTN","LA7QRY1",2,0) - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 15 -"RTN","LA7QRY1",3,0) - ; -"RTN","LA7QRY1",4,0) - Q -"RTN","LA7QRY1",5,0) - ; -"RTN","LA7QRY1",6,0) -CHKSC ; Check search NLT/LOINC codes -"RTN","LA7QRY1",7,0) - ; -"RTN","LA7QRY1",8,0) - N J -"RTN","LA7QRY1",9,0) - ; -"RTN","LA7QRY1",10,0) - S J=0 -"RTN","LA7QRY1",11,0) - F S J=$O(LA7SC(J)) Q:'J D -"RTN","LA7QRY1",12,0) - . N X -"RTN","LA7QRY1",13,0) - . S X=LA7SC(J) -"RTN","LA7QRY1",14,0) - . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q -"RTN","LA7QRY1",15,0) - . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" -"RTN","LA7QRY1",16,0) - . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q -"RTN","LA7QRY1",17,0) - . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" -"RTN","LA7QRY1",18,0) - . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" -"RTN","LA7QRY1",19,0) - . K LA7SC(J) -"RTN","LA7QRY1",20,0) - Q -"RTN","LA7QRY1",21,0) - ; -"RTN","LA7QRY1",22,0) - ; -"RTN","LA7QRY1",23,0) -SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes -"RTN","LA7QRY1",24,0) - ; Find all topographies that use this HL7 specimen code -"RTN","LA7QRY1",25,0) - N J,K,L -"RTN","LA7QRY1",26,0) - ; -"RTN","LA7QRY1",27,0) - S J=0 -"RTN","LA7QRY1",28,0) - F S J=$O(LA7SPEC(J)) Q:'J D -"RTN","LA7QRY1",29,0) - . S K=LA7SPEC(J),L=0 -"RTN","LA7QRY1",30,0) - . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" -"RTN","LA7QRY1",31,0) - Q -"RTN","LA7QRY1",32,0) - ; -"RTN","LA7QRY1",33,0) - ; -"RTN","LA7QRY1",34,0) -BUILDMSG ; Build HL7 message with result of query -"RTN","LA7QRY1",35,0) - ; -"RTN","LA7QRY1",36,0) - N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X -"RTN","LA7QRY1",37,0) - ; -"RTN","LA7QRY1",38,0) - I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" -"RTN","LA7QRY1",39,0) - S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) -"RTN","LA7QRY1",40,0) - S (HLQ,HL("Q"))="""""" -"RTN","LA7QRY1",41,0) - ; Set flag to not send HL7 message -"RTN","LA7QRY1",42,0) - S LA7NOMSG=1 -"RTN","LA7QRY1",43,0) - ; Create dummy MSH to pass HL7 delimiters -"RTN","LA7QRY1",44,0) - S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS -"RTN","LA7QRY1",45,0) - D FILESEG^LA7VHLU(GBL,.LA7MSH) -"RTN","LA7QRY1",46,0) - ; -"RTN","LA7QRY1",47,0) - F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" -"RTN","LA7QRY1",48,0) - ; -"RTN","LA7QRY1",49,0) - ; Take search results and put in HL7 message structure -"RTN","LA7QRY1",50,0) - S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 -"RTN","LA7QRY1",51,0) - ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M -"RTN","LA7QRY1",52,0) - F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT -"RTN","LA7QRY1",53,0) - . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q -"RTN","LA7QRY1",54,0) - . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 -"RTN","LA7QRY1",55,0) - . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR -"RTN","LA7QRY1",56,0) - . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR -"RTN","LA7QRY1",57,0) - . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR -"RTN","LA7QRY1",58,0) - . D OBX -"RTN","LA7QRY1",59,0) - ; -"RTN","LA7QRY1",60,0) - Q -"RTN","LA7QRY1",61,0) - ; -"RTN","LA7QRY1",62,0) - ; -"RTN","LA7QRY1",63,0) -PID ; Build PID segment -"RTN","LA7QRY1",64,0) - ; -"RTN","LA7QRY1",65,0) - N LA7PID -"RTN","LA7QRY1",66,0) - ; -"RTN","LA7QRY1",67,0) - S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) -"RTN","LA7QRY1",68,0) - S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) -"RTN","LA7QRY1",69,0) - D DEM^LRX -"RTN","LA7QRY1",70,0) - D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) -"RTN","LA7QRY1",71,0) - D FILESEG^LA7VHLU(GBL,.LA7PID) -"RTN","LA7QRY1",72,0) - S (LA("LRIDT"),LA("SUB"))="" -"RTN","LA7QRY1",73,0) - Q -"RTN","LA7QRY1",74,0) - ; -"RTN","LA7QRY1",75,0) - ; -"RTN","LA7QRY1",76,0) -ORC ; Build ORC segment -"RTN","LA7QRY1",77,0) - ; -"RTN","LA7QRY1",78,0) - N X -"RTN","LA7QRY1",79,0) - ; -"RTN","LA7QRY1",80,0) - S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) -"RTN","LA7QRY1",81,0) - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) -"RTN","LA7QRY1",82,0) - S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) -"RTN","LA7QRY1",83,0) - S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) -"RTN","LA7QRY1",84,0) - I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) -"RTN","LA7QRY1",85,0) - S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 -"RTN","LA7QRY1",86,0) - D ORC^LA7VORU -"RTN","LA7QRY1",87,0) - S LA("NLT")="" -"RTN","LA7QRY1",88,0) - ; -"RTN","LA7QRY1",89,0) - Q -"RTN","LA7QRY1",90,0) - ; -"RTN","LA7QRY1",91,0) - ; -"RTN","LA7QRY1",92,0) -OBR ; Build OBR segment -"RTN","LA7QRY1",93,0) - ; -"RTN","LA7QRY1",94,0) - N LA764,LA7NLT -"RTN","LA7QRY1",95,0) - ; -"RTN","LA7QRY1",96,0) - S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" -"RTN","LA7QRY1",97,0) - I $L(LA7NLT) D -"RTN","LA7QRY1",98,0) - . S LA764=+$O(^LAM("E",LA7NLT,0)) -"RTN","LA7QRY1",99,0) - . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) -"RTN","LA7QRY1",100,0) - I LA("SUB")="CH" D -"RTN","LA7QRY1",101,0) - . D OBR^LA7VORU -"RTN","LA7QRY1",102,0) - . D NTE^LA7VORU -"RTN","LA7QRY1",103,0) - . S LA7OBXSN=0 -"RTN","LA7QRY1",104,0) - ; -"RTN","LA7QRY1",105,0) - Q -"RTN","LA7QRY1",106,0) - ; -"RTN","LA7QRY1",107,0) - ; -"RTN","LA7QRY1",108,0) -OBX ; Build OBX segment -"RTN","LA7QRY1",109,0) - ; -"RTN","LA7QRY1",110,0) - N LA7DATA,LA7VT -"RTN","LA7QRY1",111,0) - ; -"RTN","LA7QRY1",112,0) - S LA7NTESN=0 -"RTN","LA7QRY1",113,0) - I LA("SUB")="MI" D MI^LA7VORU1 Q -"RTN","LA7QRY1",114,0) - I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q -"RTN","LA7QRY1",115,0) - ; -"RTN","LA7QRY1",116,0) - S LA7VT=$QS(LA7ROOT,7) -"RTN","LA7QRY1",117,0) - D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) -"RTN","LA7QRY1",118,0) - I '$D(LA7DATA) Q -"RTN","LA7QRY1",119,0) - D FILESEG^LA7VHLU(GBL,.LA7DATA) -"RTN","LA7QRY1",120,0) - ; Send any test interpretation from file #60 -"RTN","LA7QRY1",121,0) - D INTRP^LA7VORUA -"RTN","LA7QRY1",122,0) - ; -"RTN","LA7QRY1",123,0) - Q -"VER") -8.0^22.0 -**END** -**END**