Index: /ccr/tags/CCR_1_0_7/p/C0CDIC.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/C0CDIC.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/C0CDIC.m (revision 291) @@ -0,0 +1,84 @@ +C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR Dictionary Utility Library ",! + W ! + Q + ; +GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template + ; and return them in C0CVARS, which is passed by name + ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE + ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE + ; C0CT IS RETURNED AS THE CCR TEMPLATE + N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS + D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE + D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS + N C0CI,C0CX + S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT + F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY + . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL + . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER + ;D PARY^GPLXPATH("C0CVARS") + Q + ; +GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES + ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS + ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE + ; BOTH ARE PASSED BY NAME + ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM + ; C0CPVARS(0) IS NUMBER OF VARIABLES + ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE + D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS + ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER + D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS + ; NOW GO GET THE XPATH INDEXES + D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY + S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS + F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE + . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX + . I C0CI=0 Q ; SKIP THE ZERO NODE + . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y + . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER + . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER + . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) + . . ; W "FOUND ",C0CI,! + . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE + . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR + D SORTV ; SORT THE ARRAY BY LINE NUMBER + Q + ; +HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH + ;N C0CI,C0CTVARS,C0CX,C0CY + F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY + . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER + . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME + . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER + Q + ; +SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER + ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY + S C0CI="" ; + F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER + . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME + . S C0CY=C0CX_"^"_C0CI ; VAR NAME ^ LINE NUM ^ XPATH + . D PUSH^GPLXPATH("C0C2",C0CY) ; PUT ONTO ARRAY + K @C0CPVARS + M @C0CPVARS=C0C2 + Q + ; Index: /ccr/tags/CCR_1_0_7/p/C0CRXNRD.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/C0CRXNRD.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/C0CRXNRD.m (revision 291) @@ -0,0 +1,69 @@ +C0CRXNRD ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + W "No entry from top" Q + ; +READCON ; Open and read concepts file: RXNCONSO.RRF + N PATH S PATH="/home/sakura/Desktop/RxNorm/rrf/" + N FILENAME S FILENAME="RXNCONSO.RRF" + D OPEN^%ZISH("FILE",PATH,FILENAME,"R") + IF POP W "Error reading file..., Please check...",! BREAK + F I=1:1 Q:$$STATUS^%ZISH D + . U IO + . N LINE R LINE + . IF $$STATUS^%ZISH QUIT + . U $P W I,! U IO ; Write I to the screen, then go back to reading the file + . N RXCUI,RXAUI,SAB,TTY,CODE,STR ; Fileman fields numbers below + . S RXCUI=$P(LINE,"|",1) ; .01 + . S RXAUI=$P(LINE,"|",8) ; 1 + . S SAB=$P(LINE,"|",12) ; 2 + . S TTY=$P(LINE,"|",13) ; 3 + . S CODE=$P(LINE,"|",14) ; 4 + . S STR=$P(LINE,"|",15) ; 5 + . ; Remove embedded "^" + . S STR=$TR(STR,"^") + . ; Convert STR into an array of 80 characters on each line + . N STRLINE S STRLINE=$L(STR)\80+1 + . ; In each line, chop 80 characters off, reset STR to be the rest + . F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR)) + . ; Now, construct the FDA array + . N RXNFDA + . S RXNFDA(11310000.01,"+"_I_",",.01)=RXCUI + . S RXNFDA(11310000.01,"+"_I_",",1)=RXAUI + . S RXNFDA(11310000.01,"+"_I_",",2)=SAB + . S RXNFDA(11310000.01,"+"_I_",",3)=TTY + . S RXNFDA(11310000.01,"+"_I_",",4)=CODE + . D UPDATE^DIE("","RXNFDA") + . I $D(^TMP("DIERR",$J)) U $P BREAK + . ; Now, file WP field STR + . D WP^DIE(11310000.01,I_",",5,,$NA(STR)) + D CLOSE^%ZISH("FILE") + Q + ; +READNDC ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF + N PATH S PATH="/home/sakura/Desktop/RxNorm/rrf/" + N FILENAME S FILENAME="RXNSAB.RRF" + D OPEN^%ZISH("FILE",PATH,FILENAME,"R") + IF POP W "Error reading file..., Please check...",! BREAK + F I=1:1 Q:$$STATUS^%ZISH D + . N LINE R LINE + . IF $$STATUS^%ZISH QUIT + . U $P W I U IO + . IF LINE'["NDC|VANDF" U $P W ?20,"No NDC Here :-)",! U IO QUIT + . ; Otherwise, we are good to go + . U $P W ?20,"Found VUID/NDC Set",! U IO + . N RXCUI,VUID,NDC ; Fileman fields below + . S RXCUI=$P(LINE,"|",1) ; .01 + . S VUID=$P(LINE,"|",6) ; 1 + . S NDC=$P(LINE,"|",11) ; 2 + . ; Using classic call to update. + . N DIC,X,DA,DR + . K DO + . S DIC="^C0CRXN(""RXN"",""NDC"",",DIC(0)="F",X=RXCUI + . D FILE^DICN + . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! BREAK + . S DIE=DIC,DA=$P(Y,"^") + . S DR="1////^S X=VUID;2////^S X=NDC" + . D ^DIE + D CLOSE^%ZISH("FILE") + + Index: /ccr/tags/CCR_1_0_7/p/CCRDPT.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRDPT.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRDPT.m (revision 291) @@ -0,0 +1,270 @@ +CCRDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 + ;;0.2;CCRCCD;;Jun 15, 2008; + ; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; CCRDPT CCRCCD/SMH - Routines to Extract Patient Data for + ; FAMILY Family Name + ; GIVEN Given Name + ; MIDDLE Middle Name + ; SUFFIX Suffix Name + ; DISPNAME Display Name + ; DOB Date of Birth + ; GENDER Get Gender + ; SSN Get SSN for ID + ; ADDRTYPE Get Home Address + ; ADDR1 Get Home Address line 1 + ; ADDR2 Get Home Address line 2 + ; CITY Get City for Home Address + ; STATE Get State for Home Address + ; ZIP Get Zip code for Home Address + ; COUNTY Get County for our Address + ; COUNTRY Get Country for our Address + ; RESTEL Residential Telephone + ; WORKTEL Work Telephone + ; EMAIL Email Adddress + ; CELLTEL Cell Phone + ; NOK1FAM Next of Kin 1 (NOK1) Family Name + ; NOK1GIV NOK1 Given Name + ; NOK1MID NOK1 Middle Name + ; NOK1SUF NOK1 Suffi Name + ; NOK1DISP NOK1 Display Name + ; NOK1REL NOK1 Relationship to the patient + ; NOK1ADD1 NOK1 Address 1 + ; NOK1ADD2 NOK1 Address 2 + ; NOK1CITY NOK1 City + ; NOK1STAT NOK1 State + ; NOK1ZIP NOK1 Zip Code + ; NOK1HTEL NOK1 Home Telephone + ; NOK1WTEL NOK1 Work Telephone + ; NOK1SAME Is NOK1's Address the same the patient? + ; NOK2FAM NOK2 Family Name + ; NOK2GIV NOK2 Given Name + ; NOK2MID NOK2 Middle Name + ; NOK2SUF NOK2 Suffi Name + ; NOK2DISP NOK2 Display Name + ; NOK2REL NOK2 Relationship to the patient + ; NOK2ADD1 NOK2 Address 1 + ; NOK2ADD2 NOK2 Address 2 + ; NOK2CITY NOK2 City + ; NOK2STAT NOK2 State + ; NOK2ZIP NOK2 Zip Code + ; NOK2HTEL NOK2 Home Telephone + ; NOK2WTEL NOK2 Work Telephone + ; NOK2SAME Is NOK2's Address the same the patient? + ; EMERFAM Emergency Contact (EMER) Family Name + ; EMERGIV EMER Given Name + ; EMERMID EMER Middle Name + ; EMERSUF EMER Suffi Name + ; EMERDISP EMER Display Name + ; EMERREL EMER Relationship to the patient + ; EMERADD1 EMER Address 1 + ; EMERADD2 EMER Address 2 + ; EMERCITY EMER City + ; EMERSTAT EMER State + ; EMERZIP EMER Zip Code + ; EMERHTEL EMER Home Telephone + ; EMERWTEL EMER Work Telephone + ; EMERSAME Is EMER's Address the same the NOK? + ; + W "No Entry at top!" Q + ; + ;**Revision History** + ; - June 15, 08: v0.1 using merged global + ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. + ; + ; All methods are Public and Extrinsic + ; All calls use Fileman file 2 (Patient). + ; You can obtain field numbers using the data dictionary + ; +FAMILY(DFN) ; Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +GIVEN(DFN) ; Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +MIDDLE(DFN) ; Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +SUFFIX(DFN) ; Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +DISPNAME(DFN) ; Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +DOB(DFN) ; Date of Birth + N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") + ; Date in FM Date Format. Convert to UTC/ISO 8601. + Q $$FMDTOUTC^CCRUTIL(DOB,"D") +GENDER(DFN) ; Gender/Sex + Q $$GET1^DIQ(2,DFN,.02) ; +SSN(DFN) ; SSN + Q $$GET1^DIQ(2,DFN,.09) +ADDRTYPE(DFN) ; Address Type + ; Vista only stores a home address for the patient. + Q "Home" +ADDR1(DFN) ; Get Home Address line 1 + Q $$GET1^DIQ(2,DFN,.111) +ADDR2(DFN) ; Get Home Address line 2 + ; Vista has Lines 2,3; CCR has only line 1,2; so compromise + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +CITY(DFN) ; Get City for Home Address + Q $$GET1^DIQ(2,DFN,.114) +STATE(DFN) ; Get State for Home Address + Q $$GET1^DIQ(2,DFN,.115) +ZIP(DFN) ; Get Zip code for Home Address + Q $$GET1^DIQ(2,DFN,.116) +COUNTY(DFN) ; Get County for our Address + Q $$GET1^DIQ(2,DFN,.117) +COUNTRY(DFN) ; Get Country for our Address + ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... + Q "USA" +RESTEL(DFN) ; Residential Telephone + Q $$GET1^DIQ(2,DFN,.131) +WORKTEL(DFN) ; Work Telephone + Q $$GET1^DIQ(2,DFN,.132) +EMAIL(DFN) ; Email Adddress + Q $$GET1^DIQ(2,DFN,.133) +CELLTEL(DFN) ; Cell Phone + Q $$GET1^DIQ(2,DFN,.134) +NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +NOK1GIV(DFN) ; NOK1 Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +NOK1MID(DFN) ; NOK1 Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +NOK1SUF(DFN) ; NOK1 Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +NOK1DISP(DFN) ; NOK1 Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +NOK1REL(DFN) ; NOK1 Relationship to the patient + Q $$GET1^DIQ(2,DFN,.212) +NOK1ADD1(DFN) ; NOK1 Address 1 + Q $$GET1^DIQ(2,DFN,.213) +NOK1ADD2(DFN) ; NOK1 Address 2 + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +NOK1CITY(DFN) ; NOK1 City + Q $$GET1^DIQ(2,DFN,.216) +NOK1STAT(DFN) ; NOK1 State + Q $$GET1^DIQ(2,DFN,.217) +NOK1ZIP(DFN) ; NOK1 Zip Code + Q $$GET1^DIQ(2,DFN,.218) +NOK1HTEL(DFN) ; NOK1 Home Telephone + Q $$GET1^DIQ(2,DFN,.219) +NOK1WTEL(DFN) ; NOK1 Work Telephone + Q $$GET1^DIQ(2,DFN,.21011) +NOK1SAME(DFN) ; Is NOK1's Address the same the patient? + Q $$GET1^DIQ(2,DFN,.2125) +NOK2FAM(DFN) ; NOK2 Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +NOK2GIV(DFN) ; NOK2 Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +NOK2MID(DFN) ; NOK2 Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +NOK2SUF(DFN) ; NOK2 Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +NOK2DISP(DFN) ; NOK2 Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +NOK2REL(DFN) ; NOK2 Relationship to the patient + Q $$GET1^DIQ(2,DFN,.2192) +NOK2ADD1(DFN) ; NOK2 Address 1 + Q $$GET1^DIQ(2,DFN,.2193) +NOK2ADD2(DFN) ; NOK2 Address 2 + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +NOK2CITY(DFN) ; NOK2 City + Q $$GET1^DIQ(2,DFN,.2196) +NOK2STAT(DFN) ; NOK2 State + Q $$GET1^DIQ(2,DFN,.2197) +NOK2ZIP(DFN) ; NOK2 Zip Code + Q $$GET1^DIQ(2,DFN,.2198) +NOK2HTEL(DFN) ; NOK2 Home Telephone + Q $$GET1^DIQ(2,DFN,.2199) +NOK2WTEL(DFN) ; NOK2 Work Telephone + Q $$GET1^DIQ(2,DFN,.211011) +NOK2SAME(DFN) ; Is NOK2's Address the same the patient? + Q $$GET1^DIQ(2,DFN,.21925) +EMERFAM(DFN) ; Emergency Contact (EMER) Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +EMERGIV(DFN) ; EMER Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +EMERMID(DFN) ; EMER Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +EMERSUF(DFN) ; EMER Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +EMERDISP(DFN) ; EMER Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +EMERREL(DFN) ; EMER Relationship to the patient + Q $$GET1^DIQ(2,DFN,.331) +EMERADD1(DFN) ; EMER Address 1 + Q $$GET1^DIQ(2,DFN,.333) +EMERADD2(DFN) ; EMER Address 2 + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +EMERCITY(DFN) ; EMER City + Q $$GET1^DIQ(2,DFN,.336) +EMERSTAT(DFN) ; EMER State + Q $$GET1^DIQ(2,DFN,.337) +EMERZIP(DFN) ; EMER Zip Code + Q $$GET1^DIQ(2,DFN,.338) +EMERHTEL(DFN) ; EMER Home Telephone + Q $$GET1^DIQ(2,DFN,.339) +EMERWTEL(DFN) ; EMER Work Telephone + Q $$GET1^DIQ(2,DFN,.33011) +EMERSAME(DFN) ; Is EMER's Address the same the NOK? + Q $$GET1^DIQ(2,DFN,.3305) Index: /ccr/tags/CCR_1_0_7/p/CCRDPTT.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRDPTT.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRDPTT.m (revision 291) @@ -0,0 +1,43 @@ +CCRDPTT ; Unit Tester... + ;;0.1;CCRCCD;;Jun 15, 2008; + ; + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; Get the functions in the routine using Rick's routine + ; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860" + ; STATS(1,0)="CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08" + ; STATS(2,0)=" ;;0.1;CCRCCD;;Jun 15, 2008;" + ; STATS(84,0)="INIT(DFN) ; Copy DFN global to a local variable; PUBLIC" + ; STATS(93,0)="DESTROY ; Kill local variable; PUBLIC" + ; STATS(99,0)="FAMILY() ; Family Name; PUBLIC; Extrinsic" + ; STATS(105,0)="GIVEN() ; Given Name; PUBLIC; Extrinsic" + ; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic " + ; etc. + ; + ; Load Routine Entry points; We get a sweeeeeet array + D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory + N X,Y + ; Select Patient + S DIC=2,DIC(0)="AEMQ" D ^DIC + ; + W "You have selected patient "_Y,!! + N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D + . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " + . W "valued at " + . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"CCRDPT"_"("_$P(Y,"^")_")") + . W ! + Q Index: /ccr/tags/CCR_1_0_7/p/CCRMEDS.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRMEDS.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRMEDS.m (revision 291) @@ -0,0 +1,204 @@ +CCRMEDS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR MEDICATIONS ;07/23/08 14:33 + ;;0.1;CCDCCR;;JUL 16,2008; + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MEDXML,DFN,MEDOUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MEDXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; IMEDXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE + ; + N HASOP S HASOP=0 ; FLAG FOR HAS OUTPATIENT MEDS + N MEDCNT S MEDCNT=0 ; COUNT FOR MEDS ALREADY PROCESSED + ; OUTPATIENT ACTIVE MEDS ARE PROCESSED IN EXTRACT^CCRMEDS1 + ; OUTPATIENT PENDING MEDS IN EXTRACT^CCRMEDS2 + ; NON-VA MEDS IN EXTRACT^CCRMEDS3 + ; INPATIENT MEDS IN EXTRACT^CCRMEDS4 + ; ALL OTHERS HERE + S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) + K @MEDTVMAP ; CLEAR VARIABLE ARRAY + S @MEDTVMAP@(0)=0 ; INITIALIZE NUMBER OF MEDS PROCESSED + S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) + K @MEDTARYTMP ; KILL XML ARRAY + D EXTRACT^CCRMEDS1(MEDXML,DFN,MEDOUTXML) ; FIRST EXTRACT OUTPATIENT MEDS + I @MEDOUTXML@(0)>0 D ; CCRMEDS FOUND ACTIVE OP MEDS + . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML + . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP + . W MEDCNT,! + . W "HAS ACTIVE OP MEDS",! + N PENDINGXML,MEDPENDING + S PENDINGXML="MEDPENDING" ;NAME FOR ARRAY + D EXTRACT^CCRMEDS2(MEDXML,DFN,PENDINGXML) ; FIRST EXTRACT OUTPATIENT MEDS + I @PENDINGXML@(0)>0 D ; CCRMEDS FOUND PENDING OP MEDS + . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML + . I @MEDOUTXML@(0)>0 D ; IF WE NEED TO COMBINE MEDS + . . D INSINNER^GPLXPATH(MEDOUTXML,PENDINGXML) ;ADD PENDING TO ACTIVE + . E D CP^GPLXPATH(PENDINGXML,MEDOUTXML) ; NO ACTIVE MEDS, JUST COPY + . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP + . ; W MEDCNT,! + . W "HAS OP PENDING MEDS",! + N PENDINGXML,MEDPENDING + S PENDINGXML="MEDPENDING" ;NAME FOR ARRAY + D EXTRACT^CCRMEDS3(MEDXML,DFN,PENDINGXML) ; FIRST EXTRACT OUTPATIENT MEDS + I @PENDINGXML@(0)>0 D ; CCRMEDS FOUND PENDING OP MEDS + . ; S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML + . I @MEDOUTXML@(0)>0 D ; IF WE NEED TO COMBINE MEDS + . . D INSINNER^GPLXPATH(MEDOUTXML,PENDINGXML) ;ADD NON-VA TO MEDS + . E D CP^GPLXPATH(PENDINGXML,MEDOUTXML) ; NO PREVIOUS MEDS, JUST COPY + . S MEDCNT=MEDCNT+@MEDTVMAP@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP + . ; W MEDCNT,! + . W "HAS NON-VA MEDS",! +THEND ; + Q ; SKIPPING ALL THE REST OF THIS LOGIC.. IT IS NOT GOING TO BE NEEDED + ; ONCE NON-VA AND IP MEDS WORK (CCRMEDS3 AND CCRMEDS4) + N MEDRSLT,I,J,K,MEDPTMP,X,MEDVMAP,TBUF + D ACTIVE^ORWPS(.MEDRSLT,DFN) + I '$D(MEDRSLT(1)) D ; NO MEDS FOR THIS PATIENT, EXIT + . I DEBUG W "MEDICATIONS RPC RETURNED NULL",! + . S @MEDOUTXML@(0)=0 + . Q + ; I DEBUG ZWR MEDRSLT + M GPLMEDS=MEDRSLT + S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) + S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) + ; I 'HASOP K @MEDTVMAP,@MEDTARYTMP KILL MOVED TO TOP OF ROUTINE + ; FIRST GO THROUGH MEDRSLT ARRAY AND COUNT MEDS AND LINES IN MEDS + ; ZA(0) IS TOTAL NUMBER OF MEDS ZA(ZI) IS LINES IN MED ZI + N ZA,ZI,ZJ,ZK,ZN S (ZI,ZJ,ZK,ZN)=0 ; ZI IS MED NUMBER, ZJ IS LINE IN MED + ; ZK IS THE NUMBER OF LINES IN A MED AND ZN IS COUNTER THROUGH LINES + S ZA(0)=0 ; ZA IS ARRAY OF MED LINE COUNTS + F ZJ=1:1 Q:'$D(MEDRSLT(ZJ)) D ; COUNT THE MEDS AND LINES + . I MEDRSLT(ZJ)?1"~".E D ; FOUND NEW MED + . . S ZI=ZI+1 ; INCREMENT MED COUNT + . . S ZA(0)=ZI ; NEW TOTAL FOR MEDS + . . S ZA(ZI)=ZJ_U_1 ; EACH ZA(X) IS Y^Z WHERE Y IS START LINE AND Z IS COUNT + . E D ; FOR EVERY LINE NOT A FIRST LINE IN MED + . . S ZK=$P(ZA(ZI),U,2)+1 ; INCREMENT LINE COUNT FOR CURRENT MED + . . S $P(ZA(ZI),U,2)=ZK ; AND STORE IT IN ARRAY + ;ZWR ZA + ; S @MEDTVMAP@(0)=ZA(0) ; SAVE NUMBER OF MEDS + F ZI=1:1:ZA(0) D ; FOR EACH MED + . I DEBUG W "ZI IS ",ZI,! + . ; W ZI," ",MEDCNT,! + . S ZJ=$P(ZA(ZI),U,1) ; INDEX OF FIRST LINE OF MED IN MEDRSLT + . S MEDPTMP=MEDRSLT(ZJ) ; PULL OUT FIRST LINE OF MED + . I $P(MEDPTMP,U,1)?1"~OP" Q ; SKIP OP ACTIVE AND PENDING + . S MEDCNT=MEDCNT+1 ; WE ARE GOING TO ADD A MED + . S MEDVMAP=$NA(@MEDTVMAP@(MEDCNT)) ; START PAST OP ACTIVE MEDS + . S @MEDTVMAP@(0)=@MEDTVMAP@(0)+1 ; ADDING A MED HERE + . S @MEDVMAP@("MEDOBJECTID")="MED"_(MEDCNT) ; UNIQUE OBJID FOR MEDS + . I $P(MEDPTMP,"^",11)="" S @MEDVMAP@("MEDISSUEDATETXT")="" + . E S @MEDVMAP@("MEDISSUEDATETXT")=$$FMDTOUTC^CCRUTIL($P(MEDPTMP,"^",11),"DT") ; GETS LAST FILL DATE + . S @MEDVMAP@("MEDISSUEDATE")="" + . S @MEDVMAP@("MEDLASTFILLDATETXT")="" + . S @MEDVMAP@("MEDLASTFILLDATE")="" + . S @MEDVMAP@("MEDRXNOTXT")="" + . S @MEDVMAP@("MEDRXNO")="" + . S @MEDVMAP@("MEDDETAILUNADORNED")="" + . S @MEDVMAP@("MEDCONCVALUE")="" + . S @MEDVMAP@("MEDCONCUNIT")="" + . S @MEDVMAP@("MEDSIZETEXT")="" + . S @MEDVMAP@("MEDDOSEINDICATOR")="" + . S @MEDVMAP@("MEDDELIVERYMETHOD")="" + . S @MEDVMAP@("MEDRATEVALUE")="" + . S @MEDVMAP@("MEDRATEUNIT")="" + . S @MEDVMAP@("MEDVEHICLETEXT")="" + . S @MEDVMAP@("MEDFREQUENCYUNIT")="" + . S @MEDVMAP@("MEDINTERVALVALUE")="" + . S @MEDVMAP@("MEDINTERVALUNIT")="" + . S @MEDVMAP@("MEDPRNFLAG")="" + . S @MEDVMAP@("MEDPROBLEMOBJECTID")="" + . S @MEDVMAP@("MEDPROBLEMTYPETXT")="" + . S @MEDVMAP@("MEDPROBLEMDESCRIPTION")="" + . S @MEDVMAP@("MEDPROBLEMCODEVALUE")="" + . S @MEDVMAP@("MEDPROBLEMCODINGSYSTEM")="" + . S @MEDVMAP@("MEDPROBLEMCODINGVERSION")="" + . S @MEDVMAP@("MEDPROBLEMSOURCEACTORID")="" + . S @MEDVMAP@("MEDSTOPINDICATOR")="" + . S @MEDVMAP@("MEDDIRSEQ")="" + . S @MEDVMAP@("MEDMULDIRMOD")="" + . S @MEDVMAP@("MEDPTINSTRUCTIONS")="" + . S @MEDVMAP@("MEDFULLFILLMENTINSTRUCTIONS")="" + . S @MEDVMAP@("MEDDATETIMEAGE")="" + . S @MEDVMAP@("MEDDATETIMEAGEUNITS")="" + . S @MEDVMAP@("MEDTYPETEXT")="Medication" + . S @MEDVMAP@("MEDSTATUSTEXT")=$P(MEDPTMP,"^",10) ; STATUS FROM RPC + . S @MEDVMAP@("MEDSOURCEACTORID")="ACTORSYSTEM_1" + . S @MEDVMAP@("MEDPRODUCTNAMETEXT")=$P(MEDPTMP,"^",3) + . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")="" ; DEFAULT VALUE + . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" + . S @MEDVMAP@("MEDPRODUCTNAMECODEVERSION")="" + . I $P(MEDPTMP,U,1)?1"~OP" D ; IS OUTPATIENT, MIGHT HAVE CODE + . . I $P(MEDPTMP,"^",10)="ACTIVE" D ; ONLY ACTIVE MEDS HAVE CODES + . . . N RXIEN ; IEN TO RX, EXAMPLE "~OP^13R;O^IBUPROFEN 400MG^" 13 IS IT + . . . S RXIEN=$$DIGITS($P($P(MEDPTMP,U,2),";",1)) ; GET JUST LEADING DIGITS + . . . I DEBUG W "RXIEN=",RXIEN,! ; + . . . D RX^PSO52API(DFN,"MEDCODE",RXIEN) ; EXTRACT THE RX RECORD TO ^TMP + . . . I $D(^TMP($J,"MEDCODE",DFN,RXIEN,27)) D ; IF SUCCESS + . . . . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")=^TMP($J,"MEDCODE",DFN,RXIEN,27) + . . . . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" + . S @MEDVMAP@("MEDBRANDNAMETEXT")="" + . S @MEDVMAP@("MEDBRANDNAMECODEVALUE")="" + . S @MEDVMAP@("MEDBRANDNAMECODINGSYSTEM")="" + . S @MEDVMAP@("MEDBRANDNAMECODEVERSION")="" + . S @MEDVMAP@("MEDSTRENGTHVALUE")="" + . S @MEDVMAP@("MEDSTRENGTHUNIT")="" + . S @MEDVMAP@("MEDFORMTEXT")="" + . S @MEDVMAP@("MEDQUANTITYVALUE")="" + . S @MEDVMAP@("MEDQUANTITYUNIT")="" + . S @MEDVMAP@("MEDRFNO")="" + . S ZK=$P(ZA(ZI),U,2) ; NUMBER OF LINES IN MED + . I ZK>1 D ; MORE THAN ONE LINE IN MED + . . S @MEDVMAP@("MEDDESCRIPTIONTEXT")=$P(MEDRSLT(ZJ+1)," *",2) + . I ZK>2 D ; THIRD THROUGH 2+N LINES OF MED ARE INSTRUCTIONS + . . N TMPTXT S TMPTXT="" ; BUILD UP INSTRUCTION LINE + . . F ZN=2:1:ZK-1 D ; REMAINING LINES IN EACH MED + . . . I MEDRSLT(ZJ+ZN)]"\ Sig: " D ; REMOVE THIS MARKUP + . . . . S TMPTXT=TMPTXT_$P(MEDRSLT(ZJ+ZN),"\ Sig: ",2)_" " ; APPEND 2 TMPTXT + . . . E S TMPTXT=TMPTXT_MEDRSLT(ZJ+ZN)_" " ; SEPARATE LINES WITH SPACE + . . S @MEDVMAP@("MEDDIRECTIONDESCRIPTIONTEXT")=TMPTXT ; CP TO MAP VAR + . S @MEDVMAP@("MEDDOSEVALUE")="" + . S @MEDVMAP@("MEDDOSEUNIT")="" + . S @MEDVMAP@("MEDFREQUENCYVALUE")="" + . S @MEDVMAP@("MEDDURATIONVALUE")="" + . S @MEDVMAP@("MEDDURATIONUNIT")="" + . S @MEDVMAP@("MEDDIRECTIONROUTETEXT")="" + . S @MEDVMAP@("MEDDIRECTIONFREQUENCYVALUE")="" + . S MEDARYTMP=$NA(@MEDTARYTMP@(ZI)) + . K @MEDARYTMP + . D MAP^GPLXPATH(MEDXML,MEDVMAP,MEDARYTMP) + . I ZI=1&('HASOP) D ; FIRST ONE IS JUST A COPY MAKE SURE OP IS NOT THERE + . . ; W "FIRST ONE",! + . . D CP^GPLXPATH(MEDARYTMP,MEDOUTXML) + . E D ; AFTER THE FIRST OR IF THERE ARE OP, INSERT INNER XML + . . D INSINNER^GPLXPATH(MEDOUTXML,MEDARYTMP) + N MEDTMP,MEDI + D MISSING^GPLXPATH(MEDOUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; +DIGITS(INSTR) ; RETURN JUST THE LEADING DIGITS OF THE STRING + ; EXAMPLE: $$DIGITS("13R") RETURNS 13 + N ALPHA ; CONTANT TO HOLD ALL ALPHA CHARACTERS + S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ; ALPHAS + Q $TR(INSTR,ALPHA) ; LEAVE ONLY THE DIGITS + ; Index: /ccr/tags/CCR_1_0_7/p/CCRMEDS1.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRMEDS1.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRMEDS1.m (revision 291) @@ -0,0 +1,196 @@ +CCRMEDS ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;08/24/08 + ;;0.1;CCDCCR;;JUL 16,2008; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS(J), one medicine + ; J is a counter. + ; + ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all + ; med data available. + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf + ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). + ; D PARY^GPLXPATH(MINXML) + N MEDS,MAP + K ^TMP($J) + D RX^PSO52API(DFN,"CCDCCR") + M MEDS=^TMP($J,"CCDCCR",DFN) + ; @(0) contains the number of meds or -1^NO DATA FOUND + ; If it is -1, we quit. + I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT + I DEBUG ZWR MEDS + N RXIEN S RXIEN=0 + N MEDCOUNT S MEDCOUNT=0 + S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP + S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY + F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST + . S MEDCOUNT=MEDCOUNT+1 + . I DEBUG W "RXIEN IS ",RXIEN,! + . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) + . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN CCRMEDS + . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY + . I DEBUG W "MAP= ",MAP,! + . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM + . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID + . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number + . S @MAP@("MEDISSUEDATETXT")="Issue Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($P(MED(1),U)) + . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" + . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^CCRUTIL($P(MED(101),U)) + . S @MAP@("MEDRXNOTXT")="Prescription Number" + . S @MAP@("MEDRXNO")=MED(.01) + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) + . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=MED(27) + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" + . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" + . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) + . N MEDIEN S MEDIEN=$P(MED(6),U) + . D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) + . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . D NDF^PSS50(MEDIEN,,,,,"CONC") + . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) + . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . N CONCDATA + . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . ; and this will crash the call. So... + . I NDFIEN="" S CONCDATA="" + . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) + . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) + . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) + . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) + . S @MAP@("MEDQUANTITYVALUE")=MED(7) + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . D DATA^PSS50(MEDIEN,,,,,"QTY") + . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . ; + . ; --- START OF DIRECTIONS --- + . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... + . ; we want the compoenents. + . ; It's in node 6 of ^PSRX(IEN) + . ; So, here we go again + . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE + . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) + . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE + . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ + . ; + . N DIRNUM S DIRNUM=0 ; Sigline number + . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS + . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D + . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. + . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) + . . ; Invervals... again another call. + . . ; In the wisdom of the original programmers, the schedule is a free text field + . . ; However, it gets translated by a call to the administration schedule file + . . ; to see if that schedule exists. + . . ; That's the same thing I am going to do. + . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). + . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- + . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. + . . ; So... + . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") + . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") + . . N INTERVAL + . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" + . . E D + . . . N SUB S SUB=$O(SCHEDATA(0)) + . . . S INTERVAL=SCHEDATA(SUB,2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM + . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" + . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) + . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) + . S @MAP@("MEDRFNO")=MED(9) + . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^GPLXPATH(MINXML,MAP,RESULT) + . ; D PARY^GPLXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/CCRMEDS2.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRMEDS2.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRMEDS2.m (revision 291) @@ -0,0 +1,222 @@ +CCRMEDS2 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Pending Meds;08/24/08 + ;;0.1;CCDCCR;;JUL 16,2008; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS, one medicine + ; + ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending + ; meds data available. + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf + ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). + ; File for pending meds is 52.41 + ; Unfortuantely, API does not supply us with any useful info beyond + ; the IEN in 52.41, and the Med Name, and route. + ; So, most of the info is going to get pulled from 52.41. + N MEDS,MAP + K ^TMP($J) + D PEN^PSO5241(DFN,"CCDCCR") + M MEDS=^TMP($J,"CCDCCR",DFN) + ; @(0) contains the number of meds or -1^NO DATA FOUND + ; If it is -1, we quit. + I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT + I DEBUG ZWR MEDS + N RXIEN S RXIEN=0 + N MEDCOUNT S MEDCOUNT=0 + N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING + S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) ; THIS IS THE VARIABLE MAP + S MEDCOUNT=@MEDMAP@(0) ; ACCOUNT FOR MEDS ALREADY IN ARRAY + F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST + . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order + . S MEDCOUNT=MEDCOUNT+1 + . I DEBUG W "RXIEN IS ",RXIEN,! + . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) + . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN CCRMEDS + . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY + . I DEBUG W "MAP= ",MAP,! + . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM + . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID + . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN + . S @MAP@("MEDISSUEDATETXT")="Issue Date" + . ; Field 6 is "Effective date", and we pull it in timson format w/ I + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") + . ; Med never filled; next 4 fields are not applicable. + . S @MAP@("MEDLASTFILLDATETXT")="" + . S @MAP@("MEDLASTFILLDATE")="" + . S @MAP@("MEDRXNOTXT")="" + . S @MAP@("MEDRXNO")="" + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") + . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) + . ; NDC not supplied in API, but is rather trivial to obtain + . ; MED(11) piece 1 has the IEN of the drug (file 50) + . ; IEN is field 31 in the drug file. + . N MEDIEN S MEDIEN=$P(MED(11),U) + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$$GET1^DIQ(50,MEDIEN,31,"E") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" + . S @MAP@("MEDPRODUCTNAMECODEVERSION")="none" + . S @MAP@("MEDBRANDNAMETEXT")="" + . D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . I $D(^TMP($J,"DOSE",MEDIEN)) D ; GPL ; CALL SUCCESSFUL + . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) + . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) + . E D ; GPL CALL UNSUCCESSUFL + . . S @MAP@("MEDSTRENGTHVALUE")="" ; NO DOSE INFORMATION AVAILABLE + . . S @MAP@("MEDSTRENGTHUNIT")="" ; + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . D NDF^PSS50(MEDIEN,,,,,"CONC") + . N NDFDATA M NDFDATA=^TMP($J,"CONC",MEDIEN) + . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . N CONCDATA + . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . ; and this will crash the call. So... + . I NDFIEN="" S CONCDATA="" + . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) + . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) + . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) + . S @MAP@("MEDSIZETEXT")=$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2) + . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . D DATA^PSS50(MEDIEN,,,,,"QTY") + . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . ; + . ; --- START OF DIRECTIONS --- + . ; Sig data is not in any API. We obtain it using the IEN from + . ; the PEN API to file 52.41. It's in field 3, which is a multiple. + . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) + . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call + . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") + . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. + . ; FMSIGNUM gets outputted as "IEN,RXIEN,". + . ; DIRNUM will be first piece for IEN. + . ; DIRNUM is the proper Sigline numer. + . ; SIGDATA is the simplfied array. Subscripts are really field numbers + . ; in subfile 52.413. + . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS + . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D + . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") + . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT + . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) + . . ; If this is an order for a refill; it's not really a new order; move on to next + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) + . . ; Invervals... again another call. + . . ; The schedule is a free text field + . . ; However, it gets translated by a call to the administration + . . ; schedule file to see if that schedule exists. + . . ; That's the same thing I am going to do. + . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). + . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- + . . ; I looked), PSSFT is the name, + . . ; and list is the ^TMP name to store the data in. + . . ; Also, freqency may have "PRN" in it, so strip that out + . . N FREQ S FREQ=SIGDATA(1) + . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp + . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") + . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") + . . N INTERVAL + . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" + . . E D + . . . N SUB S SUB=$O(SCHEDATA(0)) + . . . S INTERVAL=SCHEDATA(SUB,2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" + . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months + . . N DUR S DUR=SIGDATA(2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) + . . N DURUNIT S DURUNIT=$E(DUR) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL + . ; W @MAP@("MEDPTINSTRUCTIONS"),! + . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL + . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! + . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) + . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^GPLXPATH(MINXML,MAP,RESULT) + . ; D PARY^GPLXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") + . I MEDFIRST D ; + . . S MEDFIRST=0 ; RESET FIRST FLAG + . . D CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy + . D:'MEDFIRST INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/CCRMEDS3.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRMEDS3.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRMEDS3.m (revision 291) @@ -0,0 +1,187 @@ +CCRMEDS3 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Outside_non-VA Meds;10/13/08 + ;;0.1;CCDCCR;;; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS, one medicine + ; + ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 + ; Discontinued meds are indicated by the presence of a value in fields + ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) + ; Will use Fileman API GETS^DIQ + ; + N MEDS,MAP + K ^TMP($J),NVA + D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. + ; If NVA does not exist, then patient has no non-VA meds + I $D(NVA)=0 S @OUTXML@(0)=0 QUIT + ; Otherwise, we go on... + M MEDS=NVA(55.05) + ; We are done with NVA + K NVA + ; + I DEBUG ZWR MEDS + N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. + S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) + N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array + N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE + F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST + . N MED M MED=MEDS(FDAIEN) + . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. + . S MEDCOUNT=MEDCOUNT+1 + . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) + . S @MEDMAP@(0)=@MEDMAP@(0)+1 ; INCREMENT TOTAL MEDS IN VAR ARRAY + . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID + . S @MAP@("MEDISSUEDATETXT")="Documented Date" + . ; Field 6 is "Effective date", and we pull it in timson format w/ I + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL(MED(11,"I"),"DT") + . ; Med never filled; next 4 fields are not applicable. + . S @MAP@("MEDLASTFILLDATETXT")="" + . S @MAP@("MEDLASTFILLDATE")="" + . S @MAP@("MEDRXNOTXT")="" + . S @MAP@("MEDRXNO")="" + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") + . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file is not necessarily supplied. + . ; It' node 1, internal form. + . N MEDIEN S MEDIEN=MED(1,"I") + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") + . S @MAP@("MEDBRANDNAMETEXT")="" + . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") + . S @MAP@("MEDSTRENGTHUNIT")=$S($L(DOSEDATA(902))>0:$P(DOSEDATA(902),U,2),1:"") ; SAM PLEASE CHECK + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . N NDFDATA,CONCDATA + . I $L(MEDIEN) D + . . D NDF^PSS50(MEDIEN,,,,,"CONC") + . . M NDFDATA=^TMP($J,"CONC",MEDIEN) + . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . . ; and this will crash the call. So... + . . I NDFIEN="" S CONCDATA="" + . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. + . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") + . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") + . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") + . S @MAP@("MEDSIZETEXT")=$S($L(MEDIEN):$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2),1:"") + . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . I $L(MEDIEN) D + . . D DATA^PSS50(MEDIEN,,,,,"QTY") + . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . E S @MAP@("MEDQUANTITYUNIT")="" + . ; + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . I $D(MED(10,1)) D ; + . . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field + . E S @MAP@("MEDPTINSTRUCTIONS")="" + . I $D(MED(14,1)) D ; + . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" + . S @MAP@("MEDRFNO")="" + . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^GPLXPATH(MINXML,MAP,RESULT) + . ; D PARY^GPLXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") + . I MEDFIRST D ; + . . S MEDFIRST=0 ; RESET FIRST FLAG + . . D CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy + . D:'MEDFIRST INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/CCRMEDS4.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRMEDS4.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRMEDS4.m (revision 291) @@ -0,0 +1,179 @@ +CCRMEDS4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 + ;;0.1;CCDCCR;;; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from API. + ; MED is holds each array element from MEDS, one medicine + ; MAP is a mapping variable map (store result) for each med + ; + ; Inpatient Meds will be extracted using this routine and and the one following. + ; Inpatient Meds Unit Dose is going to be CCRMEDS4 + ; Inpatient Meds IVs is going to be CCRMEDS5 + ; + ; We will use two Pharmacy ReEnginnering API's: + ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info + ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info + ; For more information, see the PRE documentation at: + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf + ; + ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient + ; + N MEDS,MAP + K ^TMP($J) + D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) + I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit + ; Otherwise, we go on... + M MEDS=^TMP($J,"UD") + I DEBUG ZWR MEDS + S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) + N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array + N I S I=0 + F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index + . N MED M MED=MEDS(I) + . S MEDCOUNT=MEDCOUNT+1 + . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter + . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) + . N RXIEN S RXIEN=MED(.01) ; Order Number + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN + . S @MAP@("MEDISSUEDATETXT")="Order Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^CCRUTIL($P(MED(27),U),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient + . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient + . S @MAP@("MEDRXNOTXT")="" ; For Outpatient + . S @MAP@("MEDRXNO")="" ; For Outpatient + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="ACTIVE" + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) + . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file is not necessarily supplied. + . ; It' node 1, internal form. + . N MEDIEN S MEDIEN=MED(1,"I") + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") + . S @MAP@("MEDBRANDNAMETEXT")="" + . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") + . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . N NDFDATA,CONCDATA + . I $L(MEDIEN) D + . . D NDF^PSS50(MEDIEN,,,,,"CONC") + . . M NDFDATA=^TMP($J,"CONC",MEDIEN) + . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . . ; and this will crash the call. So... + . . I NDFIEN="" S CONCDATA="" + . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. + . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") + . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") + . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") + . S @MAP@("MEDSIZETEXT")=$S($L(MEDIEN):$P(NDFDATA(23),U,2)_" "_$P(NDFDATA(24),U,2),1:"") + . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . I $L(MEDIEN) D + . . D DATA^PSS50(MEDIEN,,,,,"QTY") + . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + E S @MAP@("MEDQUANTITYUNIT")="" + . ; + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . S @MAP@("MEDRFNO")="" + . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^GPLXPATH(MINXML,MAP,RESULT) + . ; D PARY^GPLXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/CCRSYS.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRSYS.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRSYS.m (revision 291) @@ -0,0 +1,58 @@ +CCRSYS ;CCDCCR/SMH - Routine to Get EHR System Information;6JUL2008 + ;;0.1;CCDCCR;;; + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "Enter at appropriate points." Q + ; + ; Originally, I was going to use VEPERVER, but VEPERVER + ; actually kills ^TMP($J), outputs it to the screen in a user-friendly + ; manner (press any key to continue), + ; and is really a very half finished routine + ; + ; So for now, I am hard-coding the values. + ; +SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic + Q "WorldVistA EHR/VOE" + ; +SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic + Q "1.0" + ; +PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT + ; DFN = IEN of the Patient to be tested + ; 1 = Merged or Test Patient + ; 0 = Non-test Patient + ; + I DFN="" Q 0 ; BAD DFN PASSED + I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged + I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add + ; + I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING + I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS + N DIERR,DATA + I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT + S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator + ; 1 = Test Patient + ; 0 = Non-test Patient + I DATA Q DATA + S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test + D CLEAN^DILF + I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN + I $E(DATA,1,3)="000" Q 1 + I $E(DATA,1,3)="666" Q 1 + Q 0 + ; Index: /ccr/tags/CCR_1_0_7/p/CCRUNIT.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRUNIT.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRUNIT.m (revision 291) @@ -0,0 +1,20 @@ +CCRUNIT ; A routine that tests some crap + ;;0.1;CCDCCR;;JUL 13, 2007;Build 0 + Q + ; +MEDS + N DEBUG S DEBUG=0 + N DFN S DFN=1 + K ^TMP($J) + W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! + N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) + N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" + W "XPATH is: "_XPATH,! + W "Getting Med Template into MINXML using",! + W "QUERY^GPLXPATH(T,XPATH,""MINXML"")",!! + D QUERY^GPLXPATH(T,XPATH,"MINXML") + W "Executing EXTRACT^CCRMEDS(MINXML,DFN,OUTXML)",! + W "OUTXML will be ^TMP($J,""OUT"")",! + N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) + D EXTRACT^CCRMEDS($NA(MINXML),DFN,OUTXML) + Q Index: /ccr/tags/CCR_1_0_7/p/CCRUTIL.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRUTIL.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRUTIL.m (revision 291) @@ -0,0 +1,123 @@ +CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08 + ;;0.1;CCRCCD;;Jun 15, 2008; + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "No Entry at Top!" + Q + ; +FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic + ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) + ; If not passed, or passed incorrectly, it's assumed that it is D. + ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. + ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC + ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) + N UTC,Y,M,D,H,MM,S,OFF + S Y=1700+$E(DATE,1,3) + S M=$E(DATE,4,5) + S D=$E(DATE,6,7) + S H=$E(DATE,9,10) + I $L(H)=1 S H="0"_H + S MM=$E(DATE,11,12) + I $L(MM)=1 S MM="0"_MM + S S=$E(DATE,13,14) + I $L(S)=1 S S="0"_S + S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. + S OFFS=$E(OFF,1,1) + S OFF0=$TR(OFF,"+-") + S OFF1=$E(OFF0+10000,2,3) + S OFF2=$E(OFF0+10000,4,5) + S OFF=OFFS_OFF1_":"_OFF2 + ;S OFF2=$E(OFF,1,2) ; + ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT + ;S OFF3=$E(OFF,3,4) ;MINUTES + ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3) + ; If H, MM and S are empty, it means that the FM date didn't supply the time. + ; In this case, set H, MM and S to "00" + ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? + S:'$L(H) H="00" + S:'$L(MM) MM="00" + S:'$L(S) S="00" + S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds + I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. + E Q $P(UTC,"T") + ; +SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT + ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE + ; DATE AND TIME ORDER. DEFAULT IS FORWARD + ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT + ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER + ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER + ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC + ; BOTH V1 AND V2 ARE PASSED BY REFERENCE + N VSRT ; TEMP FOR HASHING DATES + N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 + S ZCNT=V2(0) ; COUNTING NUMBER OF DATES + F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY + . I $D(V2(ZI)) D ; IF THE DATE EXISTS + . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE + . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE + . . ; W "DATE: ",ZP1," TIME: ",ZP2,! + . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT + N ZG + S ZG=$Q(VSRT("")) + F D Q:ZG="" ; + . ; W ZG,! + . D PUSH^GPLXPATH("V1",@ZG) + . S ZG=$Q(@ZG) + I ORDR=-1 D ; HAVE TO REVERSE ORDER + . N ZG2 + . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT + . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER + . S ZG2(0)=V1(0) + . D CP^GPLXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY + Q ZCNT + ; +DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX + ; RETURNS AN ARRAY RTN PASSED BY REFERENCE + ; THIS ROUTINE CAN BE USED AS AN RPC + ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY + ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY + ; + N LEXIEN + I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG + . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON + . W LEXIEN,! + . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 + . S RTN(0)=1 ; ONE THING RETURNED + E S RTN(0)=0 ; NOT FOUND + Q + ; +DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME + ; + N DARTN + D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE + I DARTN(0)>0 D ; GOT RESULTS + . W !,DARTN(1) ;PRINT THE SNOMED CODE + E W !,"NOT FOUND",! + Q + ; +DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL + ; ASSOCIATED SNOMED CODES + N DASTMP,DASIEN,DASNO + S DASTMP="" + F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED + . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED + . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY + . W DASTMP,"=",DASNO,! ; PRINT IT OUT + Q + ; Index: /ccr/tags/CCR_1_0_7/p/CCRVA200.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCRVA200.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCRVA200.m (revision 291) @@ -0,0 +1,167 @@ +CCRVA200 ;WV/CCDCCR/SMH - Routine to get Provider Data;07/13/2008 + ;;0.1;CCDCCR;;JUL 13, 2007;Build 0 + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + Q + ; This routine uses Kernel APIs and Direct Global Access to get + ; Proivder Data from File 200. + ; + ; The Global is VA(200,*) + ; +FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC + ; INPUT: DUZ (i.e. File 200 IEN) ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") + ; +GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") + ; +MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") + ; +SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") + ; +TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + ; Gets External Value of Title field in New Person File. + ; It's actually a pointer to file 3.1 + ; 200=New Person File; 8 is Title Field + Q $$GET1^DIQ(200,DUZ_",",8) + ; +NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: Delimited String in format: + ; IDType^ID^IDDescription + ; If the NPI doesn't exist, "" is returned. + ; This routine uses a call documented in the Kernel dev guide + ; This call returns as "NPI^TimeEntered^ActiveInactive" + ; It returns -1 for NPI if NPI doesn't exist. + N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) + Q:NPI=-1 "" + Q "NPI^"_NPI_"^HHS" + ; +SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" + ; Uses a Kernel API. Returns -1 if a specialty is not specified + ; in file 200. + ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code + N STR S STR=$$GET^XUA4A72(DUZ) + Q:+STR<0 "" + ; Sometimes we have 3 pieces, or 2. Deal with that. + Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) + Q $P(STR,U,2)_"-"_$P(STR,U,3) + ; +ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC + ; INPUT: DUZ, but not needed really... here for future expansion + ; OUTPUT: At this point "Work" + Q "Work" + ; +ADDLINE1(DUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; Output: String. + ; + ; First, get site number from the institution file. + ; 1st piece returned by $$SITE^VASITE, which gets the system institution + N INST S INST=$P($$SITE^VASITE(),U) + ; + ; Second, get mailing address + ; There are two APIs to get the address, one for physical and one for + ; mailing. We will check if mailing exists first, since that's the + ; one we want to use; then check for physical. If neither exists, + ; then we return nothing. We check for the existence of an address + ; by the length of the returned string. + ; NOTE: API doesn't support Address 2, so I won't even include it + ; in the template. + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U) + Q "" + ; +CITY(DUZ) ; Get City for Institution. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; Output: String. + ; See ADD1 for comments + N INST S INST=$P($$SITE^VASITE(),U) + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U,2) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U,2) + Q "" + ; +STATE(DUZ) ; Get State for Institution. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; Output: String. + ; See ADD1 for comments + N INST S INST=$P($$SITE^VASITE(),U) + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U,3) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U,3) + Q "" + ; +POSTCODE(DUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String. + ; See ADD1 for comments + N INST S INST=$P($$SITE^VASITE(),U) + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U,4) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U,4) + Q "" + ; +TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String. + ; Direct global access + N TEL S TEL=$G(^VA(200,DUZ,.13)) + Q $P(TEL,U,2) + ; +TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String. + Q "Office" + ; +EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + ; Direct global access + N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) + Q $P(EMAIL,U) + ; Index: /ccr/tags/CCR_1_0_7/p/CCR_1_0_1.txt =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCR_1_0_1.txt (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCR_1_0_1.txt (revision 291) @@ -0,0 +1,100 @@ +CCR Package version 1.0.1 + +The purpose of the CCR package is to provide support for exporting and eventually importing patient information from/to VistA in XML documents conforming to the Continuity of Care Record (CCR - ASTM) and Continuity of Care Document (CCD - HL7) standards. + +This version of the CCR package provides: + +EXPORT^GPLCCR +A command line interface to export a single patient's CCR to a host directory by specifying the patient by name. + +EXPORT^GPLCCD +A command line interface to export a single patient's CCD to a host directory by specifying the patient by name. + +XPAT^GPLCCR(DFN,OUTDIR,OUTFILE) +A command line and program interface to export a single patient's CCR using the IEN of the patient in the ^DPT file (DFN). +OUTDIR specifies an existing directory on the Host system into which the CCR XML document will be written. If OUTDIR is null (""), the output directory name will be taken from ^TMP("GPLCCR","ODIR"). +OUFILE specifies the host file name of the CCR XML document that will be written for this patient. If OUTFILE is null ("") the document name will default to PAT_x_CCR_V1.xml where x is the DFN of the patient. + +CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) +An RPC and program interface to return in return array CCRGRTN (passed by reference) a single patient's CCR. +DFN is the patient's IEN +CCRPART is what portion of the CCR should be returned. If "CCR" is specified, the entire CCR will be returned. If "PROBLEMS", "VITALS", or "MEDICATIONS" is specified, only that section of the CCR will be returned. +TIME1,TIME2 specify a beginning and end timeframe for the data to be included in the CCR. These parameters are not implemented in this release. +HDRARY will specify the values of certain header variables for the CCR. This parameter is not implemented in this release. + +ANALYZE^GPLRIMA(BGNDFN,DFNCNT) +A command line and program interface to analyze the data from multiple patients into categories that can be batch extracted. +BGNDFN is the beginning DFN to be analyzed. If BGNDFN is null ("") its value will be taken from ^TMP("GPLRIM","RESUME"). If this variable does not exist, the routine will start with the first IEN in the patient file ^DPT. ^TMP("GPLRIM","RESUME") is updated to the "next" patient to be analyzed on successful completion. +DFNCNT is the count of how many patient records will be analyzed in this execution. +For example ANALYZE^GPLRIMA(1000,1000) would start at patient DFN 1000 and analyzes 1000 patient records. ANALYZE^GPLRIMA("",1000) would then analyze the next 1000 patients. When the end of the patient file is reached, the routine terminates with a message that RESET^GPLRIMA would need to be called to restart the analysis. + +The categories into which the records are analyzed consist of attribute strings. The attributes represent characteristics of the variables that can be extracted for a given patient into the CCR or the CCD. This version supports the following attributes: +VITALS : the patient has variables for the VITALS section of the CCR/CCD +PROBLEMS : the patient has variables for the PROBLEMS section of the CCR/CCD +MEDS : the patient has variables for the MEDICATIONS section of the CCR/CCD +HEADER : the patient has variables for the HEADER section of the CCR/CCD. All patients are marked with the HEADER attribute in this version. +NOTEXTRACTED : the CCR or CCD has not yet been produced/extracted for this patient. All patient records are marked with the NOTEXTRACTED attribute in this version for batch control processing (not implemented in this version). + +ANAZYZE^GPLRIMA calls the variable extraction routines that would be used to produce a CCR or a CCD and saves the results to ^TMP("GPLRIM",DFN) for each patient. In addition, the attribute string for each patient is saved in ^TMP("GPLRIM","ATTR") + +Categories are created as they first occur based on each unique combination of attributes that is encountered. They are named after the attribute table that is used for the analysis. This version supports only the attribute table .RIMTBL. and the categories are named "RIMTBL_x". An example set of categories from a demo systems is: + +GTM>D CLIST^GPLRIMA +(RIMTBL_1:105) ^NOTEXTRACTED^HEADER^^^PROBLEMS^^^^^VITALS^^^^^MEDS +(RIMTBL_2:596) ^NOTEXTRACTED^HEADER^^^^^^^^VITALS +(RIMTBL_3:44) ^NOTEXTRACTED^HEADER^^^PROBLEMS^^^^^VITALS +(RIMTBL_4:821) ^NOTEXTRACTED^HEADER +(RIMTBL_5:18) ^NOTEXTRACTED^HEADER^^^^^^^^VITALS^^^^^MEDS +(RIMTBL_6:14) ^NOTEXTRACTED^HEADER^^^PROBLEMS +(RIMTBL_7:15) ^NOTEXTRACTED^HEADER^^^^^^^^^^^^^MEDS +(RIMTBL_8:5) ^NOTEXTRACTED^HEADER^^^PROBLEMS^^^^^^^^^^MEDS + +for RIMTBL_1 in this example, 105 is the record count of patients who have this combination of attributes. The list of patients for each category is also maintained for batch extraction. + +CLIST^GPLRIMA +A command line interface to show a summary of the categories, record counts, and attributes that have been analyzed so far. It produces the listing in the example above from information stored in ^TMP("GPLRIM","CATS","RIMTBL"). It is intended for future versions that attribute tables be supported in addition to the default "RIMTBL". + +CPAT^GPLRIMA(CPATCAT) +A command line interface which shows the DFN numbers of the patients represented by the category CPATCAT. DFNs are listed 10 per line. For example: + +GTM>D CPAT^GPLRIMA("RIMTBL_1") +1 3 8 25 42 69 123 140 146 149 +151 168 204 205 217 218 224 228 229 231 +236 237 240 253 260 267 271 301 347 350 +366 379 384 391 407 418 419 420 428 433 +442 520 569 600 620 692 706 715 722 723 +724 728 730 744 745 746 747 748 749 750 +751 752 753 754 755 756 757 758 759 760 +761 762 763 764 765 766 767 768 769 770 +771 772 773 774 775 776 777 778 779 780 +100000 100001 100002 100003 100004 100005 100006 100007 100008 100009 +100010 100011 100012 100013 100014 + +These are the 105 patient records included in category "RIMTBL_1" from the above example. + + +XCPAT^GPLRIMA(CPATCAT) +A command line interface to extract a batch of patient CCR documents that are associated with the category CPATCAT. For example, + +XCPAT^GPLRIMA("RIMTBL_1") to extract the CCR documents for the 105 patients in the above example. + +RESET^GPLRIMA +A command line interface to kill all ANALYZE^GPLRIMA results stored so far so that the analysis can be done again. It kills ^TMP("GPLRIM","RESUME") and all extraction variables that have been saved in ^TMP("GPLRIM") + +NOTES: +This version of the package is a prototype, and does not yet make use of the standard VistA features that are appropriate for it to use. + +^TMP("GPLCCR","ODIR") must be set manually to the output directory on the Host System. It is intended that this be maintainable in a parameter file. + +CCRRPC^GPLCCR and CCDRPC^GPLCCD are intended to be RPC interfaces to the package but there is no entry for them in the RPC table and the RPC method of access has not been tested. + +Most of the command line interface functions in the package are intended to also be made available as RPC calls. This will provide the ability to invoke and control batch extraction and analysis via RPCs + +The "RIM" variables and attributes that are now being stored in ^TMP("GPLRIM") are intended to be maintained in a standard FILEMAN global, and to take advantage of FILEMAN indexing for efficient batch analysis and processing. + +It is intended that menu interfaces be provided in addition to command line interfaces for all package functions. + + + + + Index: /ccr/tags/CCR_1_0_7/p/CCR_1_0_7_T1_CACHE.KID =================================================================== --- /ccr/tags/CCR_1_0_7/p/CCR_1_0_7_T1_CACHE.KID (revision 291) +++ /ccr/tags/CCR_1_0_7/p/CCR_1_0_7_T1_CACHE.KID (revision 291) @@ -0,0 +1,11222 @@ +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** Index: /ccr/tags/CCR_1_0_7/p/GPLACTOR.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLACTOR.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLACTOR.m (revision 291) @@ -0,0 +1,204 @@ +GPLACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 + ;;0.4;CCDCCR;nopatch;noreleasedate + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; PROCESS THE ACTORS SECTION OF THE CCR + ; + ; ===Revision History=== + ; 0.1 Initial Writing of Skeleton--GPL + ; 0.2 Patient Data Extraction--SMH + ; 0.3 Information System Info Extraction--SMH + ; 0.4 Patient data rouine refactored; adjustments here--SMH + ; +EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE + ; IPXML is the Input Actor Template into which we substitute values + ; This is straight XML. Values to be substituted are in @@VAL@@ format. + ; ALST is the actor list global generated by ACTLST^GPLCCR and has format: + ; ^TMP(7542,1,"ACTORS",0)=Count + ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" + ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" + ; AXML is the output arrary, to contain XML. + ; + N I,J,AMAP,AOID,ATYP,AIEN + D CP^GPLXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML + D REPLACE^GPLXPATH(AXML,"","//Actors") ; DELETE THE INSIDES + I DEBUG W "PROCESSING ACTORS ",! + F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST + . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR + . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID + . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE + . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER + . I AIEN="" D Q ; IEN CAN'T BE NULL + . . W "WARING NUL ACTOR: ",ATYP,! + . I ATYP="" Q ; NOT A VALID ACTOR + . ; + . I DEBUG W AOID_" "_ATYP_" "_AIEN,! + . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE + . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") + . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE + . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") + . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="NOK" D ; NOK ACTOR TYPE + . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") + . . D NOK("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE + . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") + . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE + . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") + . . D ORG("ATMP",AIEN,AOID,"ATMP2") + . ; + . W "PROCESSING:",ATYP," ",AIEN,! + . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE + . D INSINNER^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT + . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE + ; + N ACTTMP + D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS + I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - + . ; STRINGS MARKED AS @@X@@ + . W "ACTORS Missing list: ",! + . F I=1:1:ACTTMP(0) W ACTTMP(I),! + Q + ; +PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR + I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! + N AMAP,ZX + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) + S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) + S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) + S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) + S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) + S @AMAP@("ACTORSSN")="" + S @AMAP@("ACTORSSNTEXT")="" + S @AMAP@("ACTORSSNSOURCEID")="" + S ZX=$$SSN^CCRDPT(AIEN) + I ZX'="" D ; IF THERE IS A SSN IN THE RECORD + . S @AMAP@("ACTORSSN")=ZX + . S @AMAP@("ACTORSSNTEXT")="SSN" + . S @AMAP@("ACTORSSNSOURCEID")=AOID + S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) + S @AMAP@("ACTORRESTEL")="" + S @AMAP@("ACTORRESTELTEXT")="" + S ZX=$$RESTEL^CCRDPT(AIEN) + I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD + . S @AMAP@("ACTORRESTEL")=ZX + . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" + S @AMAP@("ACTORWORKTEL")="" + S @AMAP@("ACTORWORKTELTEXT")="" + S ZX=$$WORKTEL^CCRDPT(AIEN) + I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD + . S @AMAP@("ACTORWORKTEL")=ZX + . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" + S @AMAP@("ACTORCELLTEL")="" + S @AMAP@("ACTORCELLTELTEXT")="" + S ZX=$$CELLTEL^CCRDPT(AIEN) + I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD + . S @AMAP@("ACTORCELLTEL")=ZX + . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" + S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSSOURCEID")=AOID + S @AMAP@("ACTORIEN")=AIEN + S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^CCRSYS + S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^CCRSYS + S @AMAP@("ACTORINFOSYSSOURCEID")=AOID + D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORDISPLAYNAME")="" + S @AMAP@("ACTORRELATION")="" + S @AMAP@("ACTORRELATIONSOURCEID")="" + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ORGANIZATIONNAME")=$P($$SITE^VASITE,U,2) + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" + D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN) + . W "WARNING - MISSING PROVIDER: ",AIEN,! + . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRVA200(AIEN) + S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRVA200(AIEN) + S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRVA200(AIEN) + S @AMAP@("ACTORTITLE")=$$TITLE^CCRVA200(AIEN) + S @AMAP@("IDTYPE")=$P($$NPI^CCRVA200(AIEN),U,1) + S @AMAP@("ID")=$P($$NPI^CCRVA200(AIEN),U,2) + S @AMAP@("IDDESC")=$P($$NPI^CCRVA200(AIEN),U,3) + S @AMAP@("ACTORSPECIALITY")=$$SPEC^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRVA200(AIEN) + S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^CCRVA200(AIEN) + S @AMAP@("ACTORTELEPHONE")="" + S @AMAP@("ACTORTELEPHONETYPE")="" + S ZX=$$TEL^CCRVA200(AIEN) + I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE + . S @AMAP@("ACTORTELEPHONE")=ZX + . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^CCRVA200(AIEN) + S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLALERT.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLALERT.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLALERT.m (revision 291) @@ -0,0 +1,111 @@ +GPLALERT ; CCDCCR/CKU - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 + ;;0.1;CCDCCR;;SEP 11,2008; + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(ALTXML,DFN,ALTOUTXML) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE + ; + ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + ; GET ADVERSE REACTIONS AND ALLERGIES + ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES + S GMRA="0^0^111" + D EN1^GMRADPT + I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* + . S @ALTOUTXML@(0)=0 + ; DEFINE MAPPING + N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP + S ALTTVMAP=$NA(^TMP("GPLCCR",$J,"ALERTS")) + S ALTTARYTMP=$NA(^TMP("GPLCCR",$J,"ALERTSARYTMP")) + K @ALTTVMAP,@ALTTARYTMP + N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 + S ALTTMP="" ; + F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL + . W "ALTTMP="_ALTTMP,! + . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q + . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) + . K @ALTVMAP + . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT + . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES + . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM + . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG + . N ADT S ADT="Patient has an " ; X $ZINT H 5 + . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") + . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." + . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT + . N ALTCDE ; SNOMED CODE THE THE ALERT + . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC + . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; + . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE + . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE + . I ALTCDE'="" D ; IF THERE IS A CODE + . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" + . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" + . E D ; SET TO NULL + . . S @ALTVMAP@("ALERTCODESYSTEM")="" + . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" + . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? + . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN + . I ALTPROV'="" D ; PROVIDER PROVIDEED + . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV + . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN + . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! + . N ACGL1,ACGFI,ACIEN,ACVUID + . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, + . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER + . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT + . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? + . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=$P(@ALTG@(ALTTMP),U,2) ; REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID + . I ACVUID'="" D ; IF VUID IS NOT NULL + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID" + . E D ; IF REACTANT CODE VALUE IS NULL + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" + . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW + . N ARTMP,ARIEN,ARDES,ARVUID + . S (ARTMP,ARDES,ARVUID)="" + . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS + . . S ARTMP=@ALTG@(ALTTMP,"S",1) + . . W "REACTION:",ARTMP,! + . . S ARIEN=$P(ARTMP,";",2) + . . S ARDES=$P(ARTMP,";",1) + . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") + . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES + . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL + . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID + . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" + . E D ; IF IT IS NULL DON'T SET CODE SYSTEM + . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" + . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" + . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) + . K @ALTARYTMP + . D MAP^GPLXPATH(ALTXML,ALTVMAP,ALTARYTMP) + . I ALTCNT=1 D CP^GPLXPATH(ALTARYTMP,ALTOUTXML) + . I ALTCNT>1 D INSINNER^GPLXPATH(ALTOUTXML,ALTARYTMP) + . S ALTCNT=ALTCNT+1 + S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS + Q +PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER + ; INGLB IS OF THE FORM: PSNDF(50.6, + ; RETURN 50.6 + Q $P($P(INGLB,"(",2),",",1) ; Index: /ccr/tags/CCR_1_0_7/p/GPLCCD.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLCCD.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLCCD.m (revision 291) @@ -0,0 +1,271 @@ +GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; EXPORT A CCR + ; +EXPORT ; EXPORT ENTRY POINT FOR CCR + ; Select a patient. + S DIC=2,DIC(0)="AEMQ" D ^DIC + I Y<1 Q ; EXIT + S DFN=$P(Y,U,1) ; SET THE PATIENT + D XPAT(DFN,"","") ; EXPORT TO A FILE + Q + ; +XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE + ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("GPLCCR","ODIR") + ; FN IS FILE NAME, DEFAULTS IF NULL + ; N CCDGLO + D CCDRPC(.CCDGLO,DFN,"CCD","","","") + S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCD",1)) + S ONAM=FN + I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" + S ODIRGLB=$NA(^TMP("GPLCCR","ODIR")) + I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET + . S @ODIRGLB="/home/glilly/CCROUT" + . ;S @ODIRGLB="/home/cedwards/" + . ;S @ODIRGLB="/opt/wv/p/" + S ODIR=DIR + I DIR="" S ODIR=@ODIRGLB + N ZY + S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) + W $P(ZY,U,2) + Q + ; +CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT + ; CCRGRTN IS RETURN ARRAY PASSED BY NAME + ; DFN IS PATIENT IEN + ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART + ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC + ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL + ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME + ; - NULL MEANS NOW + ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND + ; "TO" VARIABLES + ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN + I '$D(DEBUG) S DEBUG=0 + N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD + I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD + S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE + I CCD S CCDGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD + E S CCDGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR + S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS + ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC + S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL + I CCD D LOAD^GPLCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE + E D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE + D CP^GPLXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL + N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES + S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT + S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD + S @CCDGLO@(3)="" ; CAP WITH CCR ROOT + S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO + S @CCDGLO@(@CCDGLO@(0))="" ; FINISH CAP + S @TGLOBAL@(@TGLOBAL@(0))="" ; FINISH CAP TEMP + ; + ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL + ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES + D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body") + D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors") + I 'CCD D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures") + I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),! + ; + I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES + ; MAPPING THE PATIENT PORTION OF THE CDA HEADER + S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient" + D QUERY^GPLXPATH(CCDGLO,ZZX,"ACTT1") + D PATIENT^GPLACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT + I DEBUG D PARY^GPLXPATH("ACTT2") + D REPLACE^GPLXPATH(CCDGLO,"ACTT2",ZZX) + I DEBUG D PARY^GPLXPATH(CCDGLO) + K ACTT1 K ACCT2 + ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER + ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION + D ORG^GPLACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG + D CP^GPLXPATH("ACTT2",CCDGLO) + ; + K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT + S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS + D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS + N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD + F I=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS + . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE + . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL + . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL + . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE + . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS + . S IXML="INXML" + . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION + . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES + . ; W OXML,! + . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL + . W "RUNNING ",CALL,! + . X CALL + . I @OXML@(0)'=0 D ; THERE IS A RESULT + . . I CCD D QUERY^GPLXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH + . . I CCD D UNSHAVE("ITMP",OXML) + . . I CCD D UNMARK^GPLXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION + . ; NOW INSERT THE RESULTS IN THE CCR BUFFER + . D INSERT^GPLXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body") + . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! + ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE + ; D ACTLST^GPLCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST + ; D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") + ; D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") + ; D INSINNER^GPLXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors") + N I,J,DONE S DONE=0 + F I=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE + . S J=$$TRIM^GPLXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS + . W "TRIMMED",J,! + . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE + I CCD D ; TURN THE BODY INTO A CCD COMPONENT + . N I + . F I=1:1:@CCDGLO@(0) D ; SEARCH THROUGH THE ENTIRE ARRAY + . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP + . . . S @CCDGLO@(I)="" ; WITH CCD EQ + . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP + . . . S @CCDGLO@(I)="" + S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD + S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE + Q + ; +INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS + ; TAB IS PASSED BY NAME + W "TAB= ",TAB,! + ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS + D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") + ;D PUSH^GPLXPATH(TAB,"EXTRACT;GPLMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") + I 'CCD D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") + Q + ; +SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT + ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION + N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST + W SHXML,! + W @SHXML@(1),! + D QUEUE^GPLXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED + D QUEUE^GPLXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART + D QUEUE^GPLXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE + D PARY^GPLXPATH("SHBLD") ; PRINT BUILD LIST + D BUILD^GPLXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION + D CP^GPLXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY + Q + ; +UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE + ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML + N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST + W SHXML,! + W @SHXML@(1),! + D QUEUE^GPLXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE + D QUEUE^GPLXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST + D QUEUE^GPLXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP + D PARY^GPLXPATH("SHBLD") ; PRINT BUILD LIST + D BUILD^GPLXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION + D CP^GPLXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY + Q + ; +HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT + N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) + ; K @VMAP + S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") + I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS + . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN + . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? + . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM + . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES + . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES + . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES + . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT + I IHDR'="" D ; HEADER VALUES ARE PROVIDED + . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY + N CTMP + D MAP^GPLXPATH(CXML,VMAP,"CTMP") + D CP^GPLXPATH("CTMP",CXML) + Q + ; +ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML + ; AXML AND ACTRTN ARE PASSED BY NAME + ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 + ; P1= OBJECTID - ACTORPATIENT_2 + ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE + ;OR INSTITUTION + ; OR PERSON(IN PATIENT FILE IE NOK) + ; P3= IEN RECORD NUMBER FOR ACTOR - 2 + N I,J,K,L + K @ACTRTN ; CLEAR RETURN ARRAY + F I=1:1:@AXML@(0) D ; SCAN ALL LINES + . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE + . . S J=$P($P(@AXML@(I),"",2),"",1) + . . W "=>",J,! + . . I J'="" S K(J)="" ; HASHING ACTOR + . . ; TO GET RID OF DUPLICATES + S I="" ; GOING TO $O THROUGH THE HASH + F J=0:0 D Q:$O(K(I))="" ; + . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS + . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID + . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE + . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR + . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY + Q + ; +TEST ; RUN ALL THE TEST CASES + D TESTALL^GPLUNIT("GPLCCR") + Q + ; +ZTEST(WHICH) ; RUN ONE SET OF TESTS + N ZTMP + D ZLOAD^GPLUNIT("ZTMP","GPLCCR") + D ZTEST^GPLUNIT(.ZTMP,WHICH) + Q + ; +TLIST ; LIST THE TESTS + N ZTMP + D ZLOAD^GPLUNIT("ZTMP","GPLCCR") + D TLIST^GPLUNIT(.ZTMP) + Q + ; + ;;> + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") + ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") + ;;> + ;;>>>D ZTEST^GPLCCR("ACTLST") + ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") + ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") + ;;>>?G3(G3(0))["" + ;;> + ;;>>>D ZTEST^GPLCCR("CCR") + ;;>>>W $$TRIM^GPLXPATH(CCDGLO) + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCD","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> Index: /ccr/tags/CCR_1_0_7/p/GPLCCD1.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLCCD1.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLCCD1.m (revision 291) @@ -0,0 +1,267 @@ +GPLCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is a CCD TEMPLATE with processing routines",! + W ! + Q + ; +ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array + ; ZARY IS PASSED BY NAME + ; BAT is a string identifying the section + ; LINE is a test which will evaluate to true or false + ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' + ; . S @ZARY@(0)=0 ; initially there are no elements + ; . W "GOT HERE LOADING "_LINE,! + N CNT ; count of array elements + S CNT=@ZARY@(0) ; contains array count + S CNT=CNT+1 ; increment count + S @ZARY@(CNT)=LINE ; put the line in the array + ; S @ZARY@(BAT,CNT)="" ; index the test by battery + S @ZARY@(0)=CNT ; update the array counter + Q + ; +ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference + ; ZARY IS PASSED BY NAME + ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") + ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE + K @ZARY S @ZARY="" + S @ZARY@(0)=0 ; initialize array count + N LINE,LABEL,BODY + N INTEST S INTEST=0 ; switch for in the TEMPLATE section + N SECTION S SECTION="[anonymous]" ; NO section LABEL + ; + N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D + . I LINE?." "1";".E S INTEST=0 ; leaving section + . I INTEST D ; within the section + . . I LINE?." "1";><".E D ; sub-section name found + . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name + . . I LINE?." "1";;".E D ; line found + . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array + Q + ; +LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME + D ZLOAD(ARY,"GPLCCD1") + ; ZWR @ARY + Q + ; +TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD + Q +MARKUP ; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ; + ;; + ;; + Q + ; + ; Index: /ccr/tags/CCR_1_0_7/p/GPLCCR.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLCCR.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLCCR.m (revision 291) @@ -0,0 +1,230 @@ +GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; EXPORT A CCR + ; +EXPORT ; EXPORT ENTRY POINT FOR CCR + ; Select a patient. + S DIC=2,DIC(0)="AEMQ" D ^DIC + I Y<1 Q ; EXIT + S DFN=$P(Y,U,1) ; SET THE PATIENT + D XPAT(DFN,"","") ; EXPORT TO A FILE + Q + ; +XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE + ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("GPLCCR","ODIR") + ; FN IS FILE NAME, DEFAULTS IF NULL + N CCRGLO,UDIR,UFN + I '$D(DIR) S UDIR="" + E S UDIR=DIR + I '$D(FN) S UFN="" + E S UFN=FN + D CCRRPC(.CCRGLO,DFN,"CCR","","","") + S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCR",1)) + S ONAM=UFN + I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_7.xml" + S ODIRGLB=$NA(^TMP("GPLCCR","ODIR")) + I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET + . ;S @ODIRGLB="/home/glilly/CCROUT" + . ;S @ODIRGLB="/home/cedwards/" + . S @ODIRGLB="/opt/wv/p/" + S ODIR=UDIR + I UDIR="" S ODIR=@ODIRGLB + N ZY + S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) + W !,$P(ZY,U,2),! + Q + ; +DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED + ; + N G1 + S G1=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) + I $D(@G1@(0)) D ; CCR EXISTS + . D PARY^GPLXPATH(G1) + E W "CCR NOT CREATED, RUN D XPAT^GPLCCR(DFN,"""","""") FIRST",! + Q + ; +CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT + ; CCRGRTN IS RETURN ARRAY PASSED BY NAME + ; DFN IS PATIENT IEN + ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART + ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC + ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL + ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME + ; - NULL MEANS NOW + ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND + ; "TO" VARIABLES + ; IF NULL WILL DEFAULT TO "FROM" DUZ AND "TO" DFN + I '$D(DEBUG) S DEBUG=0 + S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD + I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION + I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION + I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING CCRMEDS SECTION + S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE + S CCRGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR + S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS + ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC + S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL + D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE + D CP^GPLXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL + ; + ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL + ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES + D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") + D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") + D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") + I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! + ; + D HDRMAP(CCRGLO,DFN,HDRARY) ; MAP HEADER VARIABLES + ; + K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT + S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS + D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS + N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD + F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS + . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE + . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL + . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL + . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE + . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS + . S IXML="INXML" + . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES + . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY + . ; W OXML,! + . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL + . W "RUNNING ",CALL,! + . X CALL + . ; NOW INSERT THE RESULTS IN THE CCR BUFFER + . I @OXML@(0)'=0 D ; THERE IS A RESULT + . . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") + . . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! + N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING + D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST + D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") + D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") + D INSINNER^GPLXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") + N TRIMI,J,DONE S DONE=0 + F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE + . S J=$$TRIM^GPLXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS + . I DEBUG W "TRIMMED",J,! + . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE + Q + ; +INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS + ; TAB IS PASSED BY NAME + I DEBUG W "TAB= ",TAB,! + ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS + D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") + D PUSH^GPLXPATH(TAB,"EXTRACT;CCRMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") + D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") + D PUSH^GPLXPATH(TAB,"MAP;GPLLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""GPLCCR"",$J,DFN,""RESULTS"")") + I TESTALERT D PUSH^GPLXPATH(TAB,"EXTRACT;GPLALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""GPLCCR"",$J,DFN,""ALERTS"")") + Q + ; +HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT + N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) + ; K @VMAP + S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") + I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS + . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN + . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? + . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM + . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES + . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES + . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES + . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT + I IHDR'="" D ; HEADER VALUES ARE PROVIDED + . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY + N CTMP + D MAP^GPLXPATH(CXML,VMAP,"CTMP") + D CP^GPLXPATH("CTMP",CXML) + Q + ; +ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML + ; AXML AND ACTRTN ARE PASSED BY NAME + ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 + ; P1= OBJECTID - ACTORPATIENT_2 + ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE + ;OR INSTITUTION + ; OR PERSON(IN PATIENT FILE IE NOK) + ; P3= IEN RECORD NUMBER FOR ACTOR - 2 + N I,J,K,L + K @ACTRTN ; CLEAR RETURN ARRAY + F I=1:1:@AXML@(0) D ; SCAN ALL LINES + . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE + . . S J=$P($P(@AXML@(I),"",2),"",1) + . . I DEBUG W "=>",J,! + . . I J'="" S K(J)="" ; HASHING ACTOR + . . ; TO GET RID OF DUPLICATES + S I="" ; GOING TO $O THROUGH THE HASH + F J=0:0 D Q:$O(K(I))="" + . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS + . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID + . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE + . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR + . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY + Q + ; +TEST ; RUN ALL THE TEST CASES + D TESTALL^GPLUNIT("GPLCCR") + Q + ; +ZTEST(WHICH) ; RUN ONE SET OF TESTS + N ZTMP + D ZLOAD^GPLUNIT("ZTMP","GPLCCR") + D ZTEST^GPLUNIT(.ZTMP,WHICH) + Q + ; +TLIST ; LIST THE TESTS + N ZTMP + D ZLOAD^GPLUNIT("ZTMP","GPLCCR") + D TLIST^GPLUNIT(.ZTMP) + Q + ; + ;;> + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") + ;;>>?@GPL@(@GPL@(0))["" + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") + ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") + ;;> + ;;>>>D ZTEST^GPLCCR("ACTLST") + ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") + ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") + ;;>>?G3(G3(0))["" + ;;> + ;;>>>D ZTEST^GPLCCR("CCR") + ;;>>>W $$TRIM^GPLXPATH(CCRGLO) + ;;> + ;;>>>S TESTALERT=1 + ;;>>>K GPL S GPL="" + ;;>>>D CCRRPC^GPLCCR(.GPL,"2","ALERTS","","","") + ;;>>?@GPL@(@GPL@(0))["" + Index: /ccr/tags/CCR_1_0_7/p/GPLCCR0.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLCCR0.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLCCR0.m (revision 291) @@ -0,0 +1,755 @@ +GPLCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is a CCR TEMPLATE with processing routines",! + W ! + Q + ; +ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array + ; ZARY IS PASSED BY NAME + ; BAT is a string identifying the section + ; LINE is a test which will evaluate to true or false + ; I '$G(@ZARY) D ; + ; . S @ZARY@(0)=0 ; initially there are no elements + ; . W "GOT HERE LOADING "_LINE,! + N CNT ; count of array elements + S CNT=@ZARY@(0) ; contains array count + S CNT=CNT+1 ; increment count + S @ZARY@(CNT)=LINE ; put the line in the array + ; S @ZARY@(BAT,CNT)="" ; index the test by battery + S @ZARY@(0)=CNT ; update the array counter + Q + ; +ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference + ; ZARY IS PASSED BY NAME + ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") + ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE + K @ZARY S @ZARY="" + S @ZARY@(0)=0 ; initialize array count + N LINE,LABEL,BODY + N INTEST S INTEST=0 ; switch for in the TEMPLATE section + N SECTION S SECTION="[anonymous]" ; NO section LABEL + ; + N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D + . I LINE?." "1";".E S INTEST=0 ; leaving section + . I INTEST D ; within the section + . . I LINE?." "1";><".E D ; sub-section name found + . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name + . . I LINE?." "1";;".E D ; line found + . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array + Q + ; +LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME + D ZLOAD(ARY,"GPLCCR0") + ; ZWR @ARY + Q + ; + ; Index: /ccr/tags/CCR_1_0_7/p/GPLLABS.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLLABS.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLLABS.m (revision 291) @@ -0,0 +1,349 @@ +GPLALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 + ;;0.3;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; +;MAP(DFN,MOXML,MIVAR,MIXML) ; MAP RESULTS VARIABLES TO XML - GPL -TBD +MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT + ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR + ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME + ; MIXML IS THE TEMPLATE TO USE + ; MOXML IS THE OUTPUT XML ARRAY + ; DFN IS THE PATIENT RECORD NUMBER + N C0COXML,C0CO,C0CV,C0CIXML + I '$D(MIVAR) S C0CV="" ;DEFAULT + E S C0CV=MIVAR ;PASSED VARIABLE ARRAY + I '$D(MIXML) S C0CIXML="" ;DEFAULT + E S C0CIXML=MIXML ;PASSED INPUT XML + D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK + I '$D(MOXML) S C0CO=$NA(^TMP("GPLCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT + E S C0CO=MOXML + ; ZWR C0COXML + M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT + Q + ; +RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS + ; RTN IS PASSED BY REFERENCE + ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES + ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE + I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING + I RMIXML="" D ; INPUT XML NOT PASSED + . D LOAD^GPLCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE + . D QUERY^GPLXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R") + . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE + E S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE + I RMIVAR="" D ; LOCATION OF VARIABLES NOT PASSED + . S C0CV=$NA(^TMP("GPLCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION + E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS + D CP^GPLXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE + D REPLACE^GPLXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ + D QUERY^GPLXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE + I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT + I 'C0CQT D ; WE ARE DEBUGGING + . W "I MAPPED",! + . W "VARS:",C0CV,! + . W "DFN:",DFN,! + . ;D PARY^GPLXPATH("C0CT") ; SECTION TEMPLATE + . ;D PARY^GPLXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) + . ;D PARY^GPLXPATH("C0CTT") ;TEST TEMPLATE (OCX) + D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT + I '$D(@C0CV@(0)) D Q ; NO VARS THERE + . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR + I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS + S RIMVARS=$NA(^TMP("GPLRIM","VARS",DFN,"RESULTS")) + K @RIMVARS + M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH + N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP + S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR) + N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT + F C0CI=1:1:C0CIN D ; LOOP THROUGH VARIABLES + . K C0CMAP,C0CTMP,C0CRTMP ;EMPTY OUT LAST BATCH OF VARIABLES + . S C0CMAP=$NA(@C0CV@(C0CI)) ; + . I 'C0CQT W "MAPOBR:",C0CMAP,! + . ;MAPPING FOR TEST REQUEST GOES HERE + . D MAP^GPLXPATH("C0CRT",C0CMAP,"C0CRTMP") ; MAP OBR DATA + . I $D(@C0CMAP@("M","TESTS",0)) D ; TESTS EXIST + . . S C0CJN=@C0CMAP@("M","TESTS",0) ; NUMBER OF TESTS + . . K C0CTO ; CLEAR OUTPUT VARIABLE + . . F C0CJ=1:1:C0CJN D ;FOR EACH TEST RESULT + . . . K C0CTMAP,C0CTMP ; EMPTY MAPS FOR TEST RESULTS + . . . S C0CTMAP=$NA(@C0CMAP@("M","TESTS",C0CJ)) ; + . . . I 'C0CQT W "MAPOBX:",C0CTMAP,! + . . . D MAP^GPLXPATH("C0CTT",C0CTMAP,"C0CTMP") ; MAP TO TMP + . . . ;I C0CJ=1 D ; FIRST TIME, JUST COPY + . . . ;. D CP^GPLXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML + . . . ;E D INSINNER^GPLXPATH("C0CTO","C0CTMP") + . . . ; + . . . D PUSHA^GPLXPATH("C0CTO","C0CTMP") ;ADD THE TEST TO BUFFER + . . ; I 'C0CQT D PARY^GPLXPATH("C0CTO") + . . D INSINNER^GPLXPATH("C0CRTMP","C0CTO","//Results/Result/Test") ;INSERT TST + . I C0CI=1 D ; FIRST TIME, COPY INSTEAD OF INSERT + . . D CP^GPLXPATH("C0CRTMP","RTN") ; + . E D INSINNER^GPLXPATH("RTN","C0CRTMP") ; INSERT THIS TEST REQUEST + Q + ; +EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL + ; + ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + ; + ; + N C0CNSSN ; IS THERE AN SSN FLAG + S C0CNSSN=0 + S C0CLB=$NA(^TMP("GPLCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS + D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT + I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT + . S @C0CLB@(0)=0 + K @C0CLB ; CLEAR OUT OLD VARS IF ANY + N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG + S C0CQT=1 ; SURPRESS LISTING + D LIST ; EXTRACT THE VARIABLES + S C0CQT=QTSAV ; RESET SILENT FLAG + K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT + I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^GPLLABS + Q + ; +GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT + ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR + ; SET UP FOR LAB API CALL + S C0CPTID=$$SSN^CCRDPT(DFN) ; GET THE SSN FOR THIS PATIENT + I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT + . W "LAB LOOKUP FAILED, NO SSN",! + . S C0CNSSN=1 ; SET NO SSN FLAG + S C0CSPC="*" ; LOOKING FOR ALL LABS + D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING + D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY TO GET EVERYTHING + S C0CR=$$GCPR^LA7QRY(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP + Q + ; +LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB + ; + ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR + I '$D(C0CLB) S C0CLB=$NA(^TMP("GPLCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS + I '$D(C0CQT) S C0CQT=0 + I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT + I '$D(^KVAI(0)) D SETTBL ; INITIALIZE LAB TABLE + I ^KBAI(0)'="V2" D SETTBL ; NEED NEWEST VERSION + I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE + S C0CTAB=$NA(^KBAI) ; BASE OF OBX TABLE + S C0CHB=$NA(^TMP("HLS",$J)) + S C0CI="" + S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT + F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG + . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES + . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) + . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) + . M XV=C0CVAR ; + . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION + . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT + . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT + . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS + . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI + . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR + . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) + . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT + . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL + . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CX2,"DT") ;UTC TIME + . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS + . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION + . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 + . . ; RESULTTESTCODEVALUE + . . ; RESULTTESTDESCRIPTIONTEXT + . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT + . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT + . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT + . . E D ; NO SECONDARY, USE PRIMARY + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT + . I C0CTYP="OBX" D ; PROCESS TEST RESULTS + . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION + . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TESTS")) ; INDENT FOR TEST RESULTS + . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT + . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT + . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX + . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE + . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER + . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 + . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") + . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT + . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL + . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CX2,"DT") ;UTC TIME + . . ; I 'C0CQT ZWR XV + . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES + . I 'C0CQT D ; + . . W C0CI," ",C0CTYP,! + . ; S C0CI=$O(@C0CHB@(C0CI)) + ;K ^TMP("GPLRIM","VARS",DFN,"RESULTS") + ;M ^TMP("GPLRIM","VARS",DFN,"RESULTS")=@C0CLB + Q +LTYP(OSEG,OTYP,OVARA,OC0CQT) ; + S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE + I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT + E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG + I 1 D ; FOR HL7 SEGMENT TYPE + . S OI="" ; INDEX INTO FIELDS IN SEG + . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT + . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX + . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED + . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE + . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE + . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX + . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE + . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE + . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE + . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! + Q +LOBX ; + Q + ; +SETTBL ; + K X ; CLEAR X + S X("PID","PID1")="1^00104^Set ID - Patient ID" + S X("PID","PID2")="2^00105^Patient ID (External ID)" + S X("PID","PID3")="3^00106^Patient ID (Internal ID)" + S X("PID","PID4")="4^00107^Alternate Patient ID" + S X("PID","PID5")="5^00108^Patient's Name" + S X("PID","PID6")="6^00109^Mother's Maiden Name" + S X("PID","PID7")="7^00110^Date of Birth" + S X("PID","PID8")="8^00111^Sex" + S X("PID","PID9")="9^00112^Patient Alias" + S X("PID","PID10")="10^00113^Race" + S X("PID","PID11")="11^00114^Patient Address" + S X("PID","PID12")="12^00115^County Code" + S X("PID","PID13")="13^00116^Phone Number - Home" + S X("PID","PID14")="14^00117^Phone Number - Business" + S X("PID","PID15")="15^00118^Language - Patient" + S X("PID","PID16")="16^00119^Marital Status" + S X("PID","PID17")="17^00120^Religion" + S X("PID","PID18")="18^00121^Patient Account Number" + S X("PID","PID19")="19^00122^SSN Number - Patient" + S X("PID","PID20")="20^00123^Drivers License - Patient" + S X("PID","PID21")="21^00124^Mother's Identifier" + S X("PID","PID22")="22^00125^Ethnic Group" + S X("PID","PID23")="23^00126^Birth Place" + S X("PID","PID24")="24^00127^Multiple Birth Indicator" + S X("PID","PID25")="25^00128^Birth Order" + S X("PID","PID26")="26^00129^Citizenship" + S X("PID","PID27")="27^00130^Veteran.s Military Status" + S X("PID","PID28")="28^00739^Nationality" + S X("PID","PID29")="29^00740^Patient Death Date/Time" + S X("PID","PID30")="30^00741^Patient Death Indicator" + S X("NTE","NTE1")="1^00573^Set ID - NTE" + S X("NTE","NTE2")="2^00574^Source of Comment" + S X("NTE","NTE3")="3^00575^Comment" + S X("ORC","ORC1")="1^00215^Order Control" + S X("ORC","ORC2")="2^00216^Placer Order Number" + S X("ORC","ORC3")="3^00217^Filler Order Number" + S X("ORC","ORC4")="4^00218^Placer Order Number" + S X("ORC","ORC5")="5^00219^Order Status" + S X("ORC","ORC6")="6^00220^Response Flag" + S X("ORC","ORC7")="7^00221^Quantity/Timing" + S X("ORC","ORC8")="8^00222^Parent" + S X("ORC","ORC9")="9^00223^Date/Time of Transaction" + S X("ORC","ORC10")="10^00224^Entered By" + S X("ORC","ORC11")="11^00225^Verified By" + S X("ORC","ORC12")="12^00226^Ordering Provider" + S X("ORC","ORC13")="13^00227^Enterer's Location" + S X("ORC","ORC14")="14^00228^Call Back Phone Number" + S X("ORC","ORC15")="15^00229^Order Effective Date/Time" + S X("ORC","ORC16")="16^00230^Order Control Code Reason" + S X("ORC","ORC17")="17^00231^Entering Organization" + S X("ORC","ORC18")="18^00232^Entering Device" + S X("ORC","ORC19")="19^00233^Action By" + S X("OBR","OBR1")="1^00237^Set ID - Observation Request" + S X("OBR","OBR2")="2^00216^Placer Order Number" + S X("OBR","OBR3")="3^00217^Filler Order Number" + S X("OBR","OBR4")="4^00238^Universal Service ID" + S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" + S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" + S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" + S X("OBR","OBR5")="5^00239^Priority" + S X("OBR","OBR6")="6^00240^Requested Date/Time" + S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" + S X("OBR","OBR8")="8^00242^Observation End Date/Time" + S X("OBR","OBR9")="9^00243^Collection Volume" + S X("OBR","OBR10")="10^00244^Collector Identifier" + S X("OBR","OBR11")="11^00245^Specimen Action Code" + S X("OBR","OBR12")="12^00246^Danger Code" + S X("OBR","OBR13")="13^00247^Relevant Clinical Info." + S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" + S X("OBR","OBR15")="15^00249^Specimen Source" + S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" + S X("OBR","OBR17")="17^00250^Order Callback Phone Number" + S X("OBR","OBR18")="18^00251^Placers Field 1" + S X("OBR","OBR19")="19^00252^Placers Field 2" + S X("OBR","OBR20")="20^00253^Filler Field 1" + S X("OBR","OBR21")="21^00254^Filler Field 2" + S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" + S X("OBR","OBR23")="23^00256^Charge to Practice" + S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" + S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" + S X("OBR","OBR26")="26^00259^Parent Result" + S X("OBR","OBR27")="27^00221^Quantity/Timing" + S X("OBR","OBR28")="28^00260^Result Copies to" + S X("OBR","OBR29")="29^00261^Parent Number" + S X("OBR","OBR30")="30^00262^Transportation Mode" + S X("OBR","OBR31")="31^00263^Reason for Study" + S X("OBR","OBR32")="32^00264^Principal Result Interpreter" + S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" + S X("OBR","OBR34")="34^00266^Technician" + S X("OBR","OBR35")="35^00267^Transcriptionist" + S X("OBR","OBR36")="36^00268^Scheduled Date/Time" + S X("OBR","OBR37")="37^01028^Number of Sample Containers" + S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" + S X("OBR","OBR39")="39^01030^Collector.s Comment" + S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" + S X("OBR","OBR41")="41^01032^Transport Arranged" + S X("OBR","OBR42")="42^01033^Escort Required" + S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" + S X("OBX","OBX1")="1^00559^Set ID - OBX" + S X("OBX","OBX2")="2^00676^Value Type" + S X("OBX","OBX3")="3^00560^Observation Identifier" + S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" + S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" + S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" + S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" + S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" + S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" + S X("OBX","OBX4")="4^00769^Observation Sub-Id" + S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" + S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" + S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCRIPTIONTEXT" + S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" + S X("OBX","OBX9")="9^00639^Probability" + S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" + S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" + S X("OBX","OBX12")="12^00567^Date Last Normal Value" + S X("OBX","OBX13")="13^00581^User Defined Access Checks" + S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" + S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" + S X("OBX","OBX16")="16^00584^Responsible Observer" + S X("OBX","OBX17")="17^00936^Observation Method" + M ^KBAI=X ; SET VALUES IN ^KBAI + S ^KBAI(0)="V2" + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLPROBS.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLPROBS.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLPROBS.m (revision 291) @@ -0,0 +1,112 @@ +GPLPROBS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; + ; PROCESS THE PROBLEMS SECTION OF THE CCR + ; +EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE + ; + ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE + ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE + ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS + ; INSERT^GPLXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT + ; + N RPCRSLT,J,K,PTMP,X,VMAP,TBU + S TVMAP=$NA(^TMP("GPLCCR",$J,"PROBVALS")) + S TARYTMP=$NA(^TMP("GPLCCR",$J,"PROBARYTMP")) + K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES + D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC + I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL + . W "NULL RESULT FROM LIST^ORQQPL3 ",! + . S @OUTXML@(0)=0 + . ; Q + ; I DEBUG ZWR RPCRSLT + S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS + F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST + . S VMAP=$NA(@TVMAP@(J)) + . K @VMAP + . I DEBUG W "VMAP= ",VMAP,! + . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY + . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM + . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) + . S @VMAP@("PROBLEMSTATUS")=$P(PTMP,U,2) + . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) + . S @VMAP@("PROBLEMCODINGVERSION")="" + . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) + . S @VMAP@("PROBLEMDATEOFONSET")=$P(PTMP,U,5) + . S @VMAP@("PROBLEMDATEMOD")=$P(PTMP,U,6) + . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) + . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) + . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) + . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) + . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) + . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) + . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER + . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) + . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) + . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) + . S @VMAP@("PROBLEMDTREC")=$P(PTMP,U,15) + . S @VMAP@("PROBLEMINACT")=$P(PTMP,U,16) + . S ARYTMP=$NA(@TARYTMP@(J)) + . ; W "ARYTMP= ",ARYTMP,! + . K @ARYTMP + . D MAP^GPLXPATH(IPXML,VMAP,ARYTMP) ; + . I J=1 D ; FIRST ONE IS JUST A COPY + . . ; W "FIRST ONE",! + . . D CP^GPLXPATH(ARYTMP,OUTXML) + . . ; W "OUTXML ",OUTXML,! + . I J>1 D ; AFTER THE FIRST, INSERT INNER XML + . . D INSINNER^GPLXPATH(OUTXML,ARYTMP) + ; ZWR ^TMP("GPLCCR",$J,"PROBVALS",*) + ; ZWR ^TMP("GPLCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS + ; ZWR @OUTXML + ; $$HTML^DILF( + ; GENERATE THE NARITIVE HTML FOR THE CCD + I CCD D ; IF THIS IS FOR A CCD + . N HTMP,HOUT,HTMLO,GPLPROBI,ZX + . F GPLPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM + . . S VMAP=$NA(@TVMAP@(GPLPROBI)) + . . I DEBUG W "VMAP =",VMAP,! + . . D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE + . . D UNMARK^GPLXPATH("HTMP") ; REMOVE MARKUP + . . ; D PARY^GPLXPATH("HTMP") ; PRINT IT + . . D MAP^GPLXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES + . . ; D PARY^GPLXPATH("HOUT") ; PRINT IT AGAIN + . . I GPLPROBI=1 D ; FIRST ONE IS JUST A COPY + . . . D CP^GPLXPATH("HOUT","HTMLO") + . . I GPLPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML + . . . I DEBUG W "DOING INNER",! + . . . N HTMLBLD,HTMLTMP + . . . D QUEUE^GPLXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) + . . . D QUEUE^GPLXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) + . . . D QUEUE^GPLXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) + . . . D BUILD^GPLXPATH("HTMLBLD","HTMLTMP") + . . . D CP^GPLXPATH("HTMLTMP","HTMLO") + . . . ; D INSINNER^GPLXPATH("HOUT","HTMLO","//") + . I DEBUG D PARY^GPLXPATH("HTMLO") + . D INSB4^GPLXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION + N PROBSTMP,I + D MISSING^GPLXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS + I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - + . ; STRINGS MARKED AS @@X@@ + . W !,"PROBLEMS Missing list: ",! + . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLRIMA.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLRIMA.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLRIMA.m (revision 291) @@ -0,0 +1,445 @@ +GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE + ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR + ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL + ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE + ; CONVEYED VIA THE CCR OR CCD. + ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE: + ; 1. THE PRESENSE OF CLINICAL DATA IN A SECTION + ; 2. ARE THE DATA ELEMENTS TIME-BOUND + ; 3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC + ; 4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS + ; 5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE + ; .. AND OTHER FACTORS YET TO BE DETERMINED + ; + ; SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY + ; REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR + ; CONVEYANCE TO THE RIM APPLICATION. + ; + ; +ANALYZE(BEGDFN,DFNCNT) ; RIM COHERANCE ANALYSIS ROUTINE + ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS + ; TO RESUME AT NEXT PATIENT, USE BEGDFN="" + ; USE RESET^GPLRIMA TO RESET TO TOP OF PATIENT LIST + ; + N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR + N CCRGLO + D ASETUP ; SET UP VARIABLES AND GLOBALS + D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE + I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME + S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN + S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT + I RIMDFN="" S RIMDFN=RESUME + I +RIMDFN=0 D Q ; AT THE END OF THE PATIENTS + . W "END OF PATIENT LIST, CALL RESET^GPLRIMA",! + F RIMI=1:1:DFNCNT D Q:+RIMDFN=0 ; FOR DFNCNT NUMBER OF PATIENTS OR END + . D CCRRPC^GPLCCR(.CCRGLO,RIMDFN,"CCR","","","") ;PROCESS THE CCR + . W RIMDFN,! + . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS + . ; + . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT + . ; + . I $D(^TMP("GPLCCR",$J,"PROBVALS",1)) D ; PROBLEM VARS EXISTS + . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("GPLCCR",$J,"PROBVALS") + . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=^TMP("GPLCCR",$J,"PROBVALS",0) + . I $D(^TMP("GPLCCR",$J,"VITALS",1)) D ; VITALS VARS EXISTS + . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("GPLCCR",$J,"VITALS") + . I $D(^TMP("GPLCCR",$J,"MEDMAP",1)) D ; MEDS VARS EXISTS + . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("GPLCCR",$J,"MEDMAP") + . I $D(^TMP("GPLCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST + . . W "FOUND ALERT VARS",! + . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("GPLCCR",$J,"ALERTS") + . I $D(^TMP("GPLCCR",$J,"RESULTS",0)) D ; RESULTS EXIST + . . W "FOUND RESULTS VARS",! + . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("GPLCCR",$J,"RESULTS") + . K ^TMP("GPLCCR",$J) ; KILL WORK AREA FOR CCR BUILDING + . ; + . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP + . ; + . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS + . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT + . ; + . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL + . ; + . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS + . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED + . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT + . ; + . N CATNAME,CATTBL + . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) + . S CATNAME="" + . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY + . W "CATEGORY NAME: ",CATNAME,! + . ; + . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^CCRSYS(RIMDFN) ; NEXT PATIENT + . ; PTST TESTS TO SEE IF PATIENT WAS MERGED + . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT + . ; AND WE SKIP IT + . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN + ; D PARY^GPLXPATH(@RIMBASE@("ATTRTBL")) + Q + ; +SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS + N SBASE,SATTR + S SBASE=$NA(@RIMBASE@("VARS",SDFN)) + D APOST("SATTR","RIMTBL","HEADER") + I $D(@SBASE@("PROBLEMS",1)) D ; + . D APOST("SATTR","RIMTBL","PROBLEMS") + . ; W "POSTING PROBLEMS",! + I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") + I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES + . D APOST("SATTR","RIMTBL","MEDS") + . N ZR,ZI + . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES + . ; D PATD^GPLRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES + I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS + . D APOST("SATTR","RIMTBL","ALERTS") + . N ZR,ZI + . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES + I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES + . D APOST("SATTR","RIMTBL","RESULTS") + . N ZR,ZI + . S ZR(0)=0 ; INITIALIZE TO NONE + . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES + . ; D PARY^GPLXPATH("ZR") ; + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK + . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; + ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED + W "ATTRIBUTES: ",SATTR,! + Q SATTR + ; +RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES + K ^TMP("GPLRIM","RESUME") + K ^TMP("GPLRIM") + Q + ; +CLIST ; LIST THE CATEGORIES + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N CLBASE,CLNUM,ZI,CLIDX + S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) + S CLNUM=@CLBASE@(0) + F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES + . S CLIDX=@CLBASE@(ZI) + . W "(",$P(@CLBASE@(CLIDX),"^",1) + . W ":",$P(@CLBASE@(CLIDX),"^",2),") " + . W CLIDX,! + ; D PARY^GPLXPATH(CLBASE) + Q + ; +CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES + ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT + ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE + ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME + ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, + ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" + ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES + ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY + ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING + ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY + ; NUMBER IE CTBL_X(CDFN)="" + ; + ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST + S CCTBL=$NA(@CBASE@(CTBL,"CATS")) + W "CBASE: ",CCTBL,! + ; + I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY + . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY + . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY + . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT + . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY + . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME + . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 + ; + S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY + S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT + S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK + ; + S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED + ; + S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT + W "PATS BASE: ",CPATLIST,! + S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST + ; + Q + ; +CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT + S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES + S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS + S ZTOT=0 ; INITIALIZE OVERALL TOTAL + F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS + . S ZCNT=0 + . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY + . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME + . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST + . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS + . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT + . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! + . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) + . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) + . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD + . S ZTOT=ZTOT+ZCNT + W "TOTAL: ",ZTOT,! + Q + ; +CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST + ; INLST IS PASSED BY NAME + N ZI,ZDX,ZCOUNT + W INLST,! + S ZCOUNT=0 + S ZDX="" + F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END + . S ZCOUNT=ZCOUNT+1 + . S ZDX=$O(@INLST@(ZDX)) + . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! + Q ZCOUNT + ; +XCPAT(CPATCAT) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . D XPAT^GPLCCR(ZI,"","") ; EXPORT THE PATIENT TO A FILE + Q + ; +CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZC=0 ; COUNT FOR SPACING THE PRINTOUT + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT + . W ZI," " + . I ZC=10 D ; NEW LINE + . . S ZC=0 + . . W ! + Q + ; +PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT + ; + N ATTR S ATTR="" + I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT + . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT + S ATTR=^TMP("GPLRIM","ATTR",DFN) + I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND + I $D(^TMP("GPLRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT + . N CAT + . S CAT=$P(^TMP("GPLRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT + . W CAT,": ",ATTR,! + Q + ; +APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) + ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT + ; AND AMAP(N)=AVAL IS THE NTH AVAL + ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE + ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE + ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED + ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED + ; + I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST + . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS + S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT + S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY + S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF + Q + ; +ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL + I '$D(RIMBASE) S RIMBASE=$NA(^TMP("GPLRIM")) + I '$D(@RIMBASE) S @RIMBASE="" + I '$D(RIMTBL) S RIMTBL=$NA(^TMP("GPLRIM","RIMTBL","TABLE")) ; ATTR TABLE + S ^TMP("GPLRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES + Q + ; +AINIT ; INITIALIZE ATTRIBUTE TABLE + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + K @RIMTBL + D APUSH(RIMTBL,"EXTRACTED") + D APUSH(RIMTBL,"NOTEXTRACTED") + D APUSH(RIMTBL,"HEADER") + D APUSH(RIMTBL,"NOPCP") + D APUSH(RIMTBL,"PCP") + D APUSH(RIMTBL,"PROBLEMS") + D APUSH(RIMTBL,"PROBCODE") + D APUSH(RIMTBL,"PROBNOCODE") + D APUSH(RIMTBL,"PROBDATE") + D APUSH(RIMTBL,"PROBNODATE") + D APUSH(RIMTBL,"VITALS") + D APUSH(RIMTBL,"VITALSCODE") + D APUSH(RIMTBL,"VITALSNOCODE") + D APUSH(RIMTBL,"VITALSDATE") + D APUSH(RIMTBL,"VITALSNODATE") + D APUSH(RIMTBL,"MEDS") + D APUSH(RIMTBL,"MEDSCODE") + D APUSH(RIMTBL,"MEDSNOCODE") + D APUSH(RIMTBL,"MEDSDATE") + D APUSH(RIMTBL,"MEDSNODATE") + D APUSH(RIMTBL,"ALERTS") + D APUSH(RIMTBL,"ALERTSCODE") + D APUSH(RIMTBL,"RESULTS") + D APUSH(RIMTBL,"RESULTSLN") + Q + ; +APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL + ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING + ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES + ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) + I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING + N USETBL + I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE + . W "ERROR NO SUCH TABLE",! + S USETBL=@RIMBASE@("TABLES",PTBL) + S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL + Q +GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN + ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") + ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 + ; IN SECTION "MEDS" + ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS + ; PENDING FOR MED 2 FOR PATIENT 2 + ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE + ; RETURNED. RTN IS PASSED BY REFERENCE + ; + S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE + I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES + S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES + I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION + . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! + N ZZI,ZZS + S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT + ; ZWR @ZZS@(1) + S RTN(0)=@ZZS@(0) + F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) + . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE + . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE + Q + ; +PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR + ; + N ZR + D GETPA(.ZR,DFN,ISEC,IVAR) + I $D(ZR(0)) D PARY^GPLXPATH("ZR") + E W "NOTHING RETURNED",! + Q + ; +CAGET(RTN,IATTR) ; + ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR + ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE + ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC + Q + ; +PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR + ; + I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES + N ZLST + S LSTRTN(0)=0 ; DEFAULT RETURN NONE + S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES + S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS + N ZNC ; ZNC IS NUMBER OF CATEGORIES + S ZNC=@ZCBASE@(0) + I ZNC=0 Q ; NO CATEGORIES TO SEARCH + N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE + S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) + N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT + F ZI=1:1:ZNC D ; FOR ALL CATEGORIES + . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT + . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR + . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL + . . M LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT + S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS + S ZPAT=0 ; START AT FIRST PATIENT IN LIST + F S ZPAT=$O(LSTRTN(ZPAT)) Q:ZPAT="" D ; + . S ZCNT=ZCNT+1 + S LSTRTN(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY + Q + ; +DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR + ; + N ZR + D PCLST(.ZR,CATTR) + I ZR(0)=0 D Q ; + . W "NO PATIENTS RETURNED",! + E D ; + . D PARY^GPLXPATH("ZR") ; PRINT ARRAY + . W "COUNT=",ZR(0),! + Q + ; +RPCGV(RTN,DFN,WHICH) ; RPC GET VARS + ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES + ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT + ; DFN IS THE PATIENT NUMBER. + ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS" + ; OR OTHER SECTIONS AS THEY ARE ADDED + ; THIS IS MEANT TO BE AVAILABLE AS AN RPC + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES + S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED + N ZZGI + I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS + . F ZZGI="PROBLEMS","VITALS","MEDS","ALERTS","RESULTS" D ; EACH SECTION + . . D ZGVWRK(ZZGI) ; DO EACH SECTION + E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR + Q + ; +ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV + ; + N ZZGN ; NAME FOR SECTION VARIABLES + S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION + I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION + E D ; VARS EXIST + . N ZGVI + . F ZGVI=1:1:@ZZGN@(0) D ; FOR EACH MULTIPLE IN SECTION + . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS + . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE + . . S ZZGN2=$NA(@ZZGN@(ZGVI)) + . . ; W ZZGN2,!,$O(@ZZGN2@("")),! + . . D H2ARY^GPLXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY + . . ; D PARY^GPLXPATH("ZZGA") + . . D PUSHA^GPLXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN + Q + ; +DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN GPLRIM + ; ALONG WITH SAMPLE VALUES. + ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS" + N GTMP + I '$D(^TMP("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT + . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES + I '$D(IWHICH) S IWHICH="ALL" + D RPCGV(.GTMP,DFN,IWHICH) + D PARY^GPLXPATH("GTMP") + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLSNOA.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLSNOA.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLSNOA.m (revision 291) @@ -0,0 +1,197 @@ +GPLSNOA ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES + ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD + ; USING THE VISTA LEXICON ^LEX + ; +ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE + ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD + ; TO RESUME AT NEXT DRUG, USE BEGIEN="" + ; USE RESET^GPLSNOA TO RESET TO TOP OF DRUG LIST + ; + N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR + N CCRGLO + D ASETUP ; SET UP VARIABLES AND GLOBALS + D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE + I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME + S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN + S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD + I SNOIEN="" S SNOIEN=RESUME + I +SNOIEN=0 D Q ; AT THE END OF THE ALLERGY LIST + . W "END OF DRUG LIST, CALL RESET^GPLSNOA",! + F SNOI=1:1:IENCNT D Q:+SNOIEN=0 ; FOR IENCNT NUMBER OF PATIENTS OR END + . ;D CCRRPC^GPLCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR + . W SNOIEN,@GMRBASE@(SNOIEN,0),! + . N SNORTN,TTERM ; RETURN ARRAY + . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY" + . D TEXTRPC(.SNORTN,TTERM) + . I $D(SNORTN) ZWR SNORTN + . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS + . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0) + . ; + . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP + . ; + . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS + . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG + . ; + . N CATNAME,CATTBL + . S CATNAME="" + . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY + . ; W "CATEGORY NAME: ",CATNAME,! + . ; + . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD + . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN + ; D PARY^GPLXPATH(@SNOBASE@("ATTRTBL")) + Q + ; +TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN + ; + ;N TTMP + W ITEXT,! + S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN") + Q + ; +ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL + I '$D(SNOBASE) S SNOBASE=$NA(^TMP("GPLSNO")) + I '$D(@SNOBASE) S @SNOBASE="" + I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82)) + I '$D(SNOTBL) S SNOTBL=$NA(^TMP("GPLSNO","SNOTBL","TABLE")) ; ATTR TABLE + S ^TMP("GPLSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES + Q + ; +AINIT ; INITIALIZE ATTRIBUTE TABLE + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + K @SNOTBL + D APUSH^GPLRIMA(SNOTBL,"CODE") + D APUSH^GPLRIMA(SNOTBL,"NOCODE") + D APUSH^GPLRIMA(SNOTBL,"MULTICODE") + D APUSH^GPLRIMA(SNOTBL,"SUBMULTI") + D APUSH^GPLRIMA(SNOTBL,"DONE") + Q +APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL + ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING + ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES + ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) + I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING + N USETBL + I '$D(@SNOBASE@("TABLES",PTBL)) D Q ; NO TABLE + . W "ERROR NO SUCH TABLE",! + S USETBL=@SNOBASE@("TABLES",PTBL) + S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL + Q +SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS + N SBASE,SATTR + S SBASE=$NA(@SNOBASE@("VARS",SDFN)) + D APOST("SATTR","SNOTBL","DONE") + I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE") + I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE") + Q SATTR ; GPL + I $D(@SBASE@("PROBLEMS",1)) D ; + . D APOST("SATTR","SNOTBL","PROBLEMS") + . ; W "POSTING PROBLEMS",! + I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS") + I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES + . D APOST("SATTR","SNOTBL","MEDS") + . N ZR,ZI + . D GETPA^GPLRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES + . ; D PATD^GPLSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES + D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED + ; W "ATTRIBUTES: ",SATTR,! + Q SATTR + ; +RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES + K ^TMP("GPLSNO","RESUME") + K ^TMP("GPLSNO") + Q + ; +CLIST ; LIST THE CATEGORIES + ; + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + N CLBASE,CLNUM,ZI,CLIDX + S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) + S CLNUM=@CLBASE@(0) + F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES + . S CLIDX=@CLBASE@(ZI) + . W "(",$P(@CLBASE@(CLIDX),"^",1) + . W ":",$P(@CLBASE@(CLIDX),"^",2),") " + . W CLIDX,! + ; D PARY^GPLXPATH(CLBASE) + Q + ; +CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES + ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT + ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE + ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME + ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, + ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" + ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES + ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY + ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING + ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY + ; NUMBER IE CTBL_X(CDFN)="" + ; + ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST + S CCTBL=$NA(@CBASE@(CTBL,"CATS")) + ; W "CBASE: ",CCTBL,! + ; + I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY + . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY + . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY + . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT + . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY + . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME + . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 + ; + S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY + S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT + S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK + ; + S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED + ; + S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT + ; W "IENS BASE: ",CPATLIST,! + S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST + ; + Q + ; +REUSE ; GET SAVED VALUES FROM ^TMP("GPLSAV") AND PUT THEM IN A DATABASE + ; + D ASETUP + D AINIT + N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH + S SAVBASE=$NA(^TMP("GPLSAV","VARS")) + S SNOI="" + F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST + . S SNOI=$O(@SAVBASE@(SNOI)) + . S SNOJ=@SAVBASE@(SNOI) + . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) + . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE + . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON + . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE + . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE + . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE + . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! + . W SNOK,! + . W SNOJ,! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLUNIT.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLUNIT.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLUNIT.m (revision 291) @@ -0,0 +1,156 @@ +GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is a unit testing library",! + W ! + Q + ; +ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array + ; ZARY IS PASSED BY REFERENCE + ; BAT is a string identifying the test battery + ; TST is a test which will evaluate to true or false + ; I '$G(ZARY) D + ; . S ZARY(0)=0 ; initially there are no elements + ; W "GOT HERE LOADING "_TST,! + N CNT ; count of array elements + S CNT=ZARY(0) ; contains array count + S CNT=CNT+1 ; increment count + S ZARY(CNT)=TST ; put the test in the array + I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY + . N II,TN ; TEMP FOR ENDING TEST IN BATTERY + . S II=$P(ZARY(BAT),"^",2) + . S $P(ZARY(BAT),"^",2)=II+1 + I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY + . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY + . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX + . ; S TN=$NA(ZARY("TESTS")) + . ; D PUSH^GPLXPATH(TN,BAT) + S ZARY(0)=CNT ; update the array counter + Q + ; +ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference + ; ZARY IS PASSED BY NAME + ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") + ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE + K @ZARY + S @ZARY@(0)=0 ; initialize array count + N LINE,LABEL,BODY + N INTEST S INTEST=0 ; switch for in the test case section + N SECTION S SECTION="[anonymous]" ; test case section + ; + N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D + . I LINE?." "1";;>".E S INTEST=1 ; entering test section + . I LINE?." "1";;>".E S INTEST=0 ; leaving TEMPLATE section + . I INTEST D ; within the testing section + . . I LINE?." "1";;><".E D ; section name found + . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name + . . I LINE?." "1";;>>".E D ; test case found + . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array + S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL + Q + ; +ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST + N ZI,ZX,ZR,ZP + S DEBUG=0 + ; I WHICH="ALL" D Q ; RUN ALL THE TESTS + ; . W "DOING ALL",! + ; . N J,NT + ; . S NT=$NA(ZARY("TESTS")) + ; . W NT,@NT@(0),! + ; . F J=1:1:@NT@(0) D ; + ; . . W @NT@(J),! + ; . . D ZTEST^GPLUNIT(@ZARY,@NT@(J)) + I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST + . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! + N FIRST,LAST + S FIRST=$P(ZARY(WHICH),"^",1) + S LAST=$P(ZARY(WHICH),"^",2) + F ZI=FIRST:1:LAST D + . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT + . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) + . . ; W ZP,! + . . S ZX=ZP + . . W "RUNNING: "_ZP + . . X ZX + . . W "..SUCCESS: ",WHICH,! + . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST + . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) + . . S ZX="S ZR="_ZP + . . W "TRYING: "_ZP + . . X ZX + . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! + . . I '$D(TPASSED) D ; NOT INITIALIZED YET + . . . S TPASSED=0 S TFAILED=0 + . . I ZR S TPASSED=TPASSED+1 + . . I 'ZR S TFAILED=TFAILED+1 + Q + ; +TEST ; RUN ALL THE TEST CASES + N ZTMP + D ZLOAD(.ZTMP) + D ZTEST(.ZTMP,"ALL") + W "PASSED: ",TPASSED,! + W "FAILED: ",TFAILED,! + W ! + W "THE TESTS!",! + ; I DEBUG ZWR ZTMP + Q + ; +GTSTS(GTZARY,RTN) ; return an array of test names + N I,J S I="" S I=$O(GTZARY("TESTS",I)) + F J=0:0 Q:I="" D + . D PUSH^GPLXPATH(RTN,I) + . S I=$O(GTZARY("TESTS",I)) + Q + ; +TESTALL(RNM) ; RUN ALL THE TESTS + N ZI,J,TZTMP,TSTS,TOTP,TOTF + S TOTP=0 S TOTF=0 + D ZLOAD^GPLUNIT("TZTMP",RNM) + D GTSTS(.TZTMP,"TSTS") + F ZI=1:1:TSTS(0) D ; + . S TPASSED=0 S TFAILED=0 + . D ZTEST^GPLUNIT(.TZTMP,TSTS(ZI)) + . S TOTP=TOTP+TPASSED + . S TOTF=TOTF+TFAILED + . S $P(TSTS(ZI),"^",2)=TPASSED + . S $P(TSTS(ZI),"^",3)=TFAILED + F ZI=1:1:TSTS(0) D ; + . W "TEST=> ",$P(TSTS(ZI),"^",1) + . W " PASSED=>",$P(TSTS(ZI),"^",2) + . W " FAILED=>",$P(TSTS(ZI),"^",3),! + W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! + Q + ; +TLIST(ZARY) ; LIST ALL THE TESTS + ; THEY ARE MARKED AS ;;> IN THE TEST CASES + ; ZARY IS PASSED BY REFERENCE + N I,J,K S I="" S I=$O(ZARY("TESTS",I)) + S K=1 + F J=0:0 Q:I="" D + . ; W "I IS NOW=",I,! + . W I," " + . S I=$O(ZARY("TESTS",I)) + . S K=K+1 I K=6 D + . . W ! + . . S K=1 + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLVITAL.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLVITAL.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLVITAL.m (revision 291) @@ -0,0 +1,198 @@ +GPLVITAL ; CCDCCR/CJE - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 + ;;0.1;CCDCCR;;JUL 16,2008; + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE + ; + ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE + ; + N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR + D VITALS^ORQQVI(.VITRSLT,DFN,"","") + I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT + I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC + . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! + . S @VITOUTXML@(0)=0 + I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT + ; ZWR RPCRSLT + S VITTVMAP=$NA(^TMP("GPLCCR",$J,"VITALS")) + S VITTARYTMP=$NA(^TMP("GPLCCR",$J,"VITALARYTMP")) + K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES + N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX + D VITDATES(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY + ; I DEBUG ZWR VDATES ;DEBUG + S VCNT=$$SORTDT^CCRUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE + ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY + S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS + F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST + . I $D(VITRSLT(VSORT(J))) D + . . S VITVMAP=$NA(@VITTVMAP@(J)) + . . K @VITVMAP + . . I DEBUG W "VMAP= ",VITVMAP,! + . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY + . . I DEBUG W "VITAL ",VSORT(J),! + . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT"),! + . . I DEBUG W $P(VITPTMP,U,4),! + . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID + . . I $P(VITPTMP,U,2)="HT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="248327008" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" + . . E I $P(VITPTMP,U,2)="WT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="107647005" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" + . . E I $P(VITPTMP,U,2)="BP" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="392570002" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="T" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="309646008" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" + . . E I $P(VITPTMP,U,2)="R" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="366147009" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="P" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="366199006" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="PN" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="22253000" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E D + . . . ;W "IN VITAL: OTHER",! + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" + . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")="" + . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")="" + . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" + . . S VITARYTMP=$NA(@VITTARYTMP@(J)) + . . K @VITARYTMP + . . D MAP^GPLXPATH(VITXML,VITVMAP,VITARYTMP) + . . I J=1 D ; FIRST ONE IS JUST A COPY + . . . ; W "FIRST ONE",! + . . . D CP^GPLXPATH(VITARYTMP,VITOUTXML) + . . . I DEBUG W "VITOUTXML ",VITOUTXML,! + . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML + . . . D INSINNER^GPLXPATH(VITOUTXML,VITARYTMP) + ; ZWR ^TMP($J,"VITALS",*) + ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS + I DEBUG D PARY^GPLXPATH(VITOUTXML) + N VITTMP,I + D MISSING^GPLXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS + I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "VITALS MISSING ",! + . F I=1:1:VITTMP(0) W VITTMP(I),! + Q + ; +VITDATES(VDT) ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY + ; OF DATES IN THE VITALS RESULTS + N VDTI,VDTJ,VTDCNT + S VTDCNT=0 ; COUNT TO BUILD ARRAY + S VDTJ="" ; USED TO VISIT THE RESULTS + F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS + . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT + . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER + . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE + S VDT(0)=VTDCNT + Q + ; Index: /ccr/tags/CCR_1_0_7/p/GPLXPAT0.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLXPAT0.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLXPAT0.m (revision 291) @@ -0,0 +1,212 @@ +GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 + ;;0.2;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY",! + Q + ; + ;;> + ;;> + ;;>>>K GPL S GPL="" + ;;>>>D PUSH^GPLXPATH("GPL","FIRST") + ;;>>>D PUSH^GPLXPATH("GPL","SECOND") + ;;>>>D PUSH^GPLXPATH("GPL","THIRD") + ;;>>>D PUSH^GPLXPATH("GPL","FOURTH") + ;;>>?GPL(0)=4 + ;;> + ;;>>>K GXML S GXML="" + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","@@DATA1@@") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","@@DATA2@@") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;> + ;;>>>K GXML S GXML="" + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","DATA1") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","DATA2") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","<_SECOND>") + ;;>>>D PUSH^GPLXPATH("GXML","DATA3") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;>>>D PUSH^GPLXPATH("GXML","") + ;;> + ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") + ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INIT") + ;;>>?GPL(GPL(0))="FOURTH" + ;;>>>D POP^GPLXPATH("GPL",.GX) + ;;>>?GX="FOURTH" + ;;>>?GPL(GPL(0))="THIRD" + ;;>>>D POP^GPLXPATH("GPL",.GX) + ;;>>?GX="THIRD" + ;;>>?GPL(GPL(0))="SECOND" + ;;> + ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") + ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INIT") + ;;>>>S GX="" + ;;>>>D MKMDX^GPLXPATH("GPL",.GX) + ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" + ;;> + ;;>>?$$XNAME^GPLXPATH("DATA1")="FOURTH" + ;;>>?$$XNAME^GPLXPATH("")="SIXTH" + ;;>>?$$XNAME^GPLXPATH("")="THIRD" + ;;> + ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") + ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INITXML") + ;;>>>D INDEX^GPLXPATH("GXML") + ;;>>?GXML("//FIRST/SECOND")="2^12" + ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9" + ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7" + ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4" + ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8" + ;;>>?GXML("//FIRST/SECOND")="2^12" + ;;>>?GXML("//FIRST")="1^13" + ;;> + ;;>>>D ZTEST^GPLXPATH("INITXML2") + ;;>>>D INDEX^GPLXPATH("GXML") + ;;>>?GXML("//FIRST/SECOND")="2^12" + ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11" + ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10" + ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8" + ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^7" + ;;>>?GXML("//FIRST")="1^13" + ;;> + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" + ;;>>>D MISSING^GPLXPATH("GXML",OUTARY) + ;;>>?@OUTARY@(1)="DATA1" + ;;>>?@OUTARY@(2)="DATA2" + ;;> + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" + ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" + ;;>>>S @MAPARY@("DATA2")="VALUE2" + ;;>>>D MAP^GPLXPATH("GXML",MAPARY,OUTARY) + ;;>>?@OUTARY@(6)="VALUE2" + ;;> + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" + ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" + ;;>>>S @MAPARY@("DATA1")="VALUE1" + ;;>>>S @MAPARY@("DATA2")="VALUE2" + ;;>>>S @MAPARY@("DATA3")="VALUE3" + ;;>>>S GXML(4)="@@DATA1@@ AND @@DATA3@@" + ;;>>>D MAP^GPLXPATH("GXML",MAPARY,OUTARY) + ;;>>>D PARY^GPLXPATH(OUTARY) + ;;>>?@OUTARY@(4)="VALUE1 AND VALUE3" + ;;> + ;;>>>D QUEUE^GPLXPATH("BTLIST","GXML",2,3) + ;;>>>D QUEUE^GPLXPATH("BTLIST","GXML",4,5) + ;;>>?$P(BTLIST(2),";",2)=4 + ;;> + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") + ;;>>>D ZTEST^GPLXPATH("QUEUE") + ;;>>>D BUILD^GPLXPATH("BTLIST","G3") + ;;> + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D CP^GPLXPATH("GXML","G2") + ;;>>?G2(0)=13 + ;;> + ;;>>>K G2,GBL + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QOPEN^GPLXPATH("GBL","GXML") + ;;>>?$P(GBL(1),";",3)=12 + ;;>>>D BUILD^GPLXPATH("GBL","G2") + ;;>>?G2(G2(0))="" + ;;> + ;;>>>K G2,GBL + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND") + ;;>>?$P(GBL(1),";",3)=11 + ;;>>>D BUILD^GPLXPATH("GBL","G2") + ;;>>?G2(G2(0))="" + ;;> + ;;>>>K G2,GBL + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QCLOSE^GPLXPATH("GBL","GXML") + ;;>>?$P(GBL(1),";",3)=13 + ;;>>>D BUILD^GPLXPATH("GBL","G2") + ;;>>?G2(G2(0))="" + ;;> + ;;>>>K G2,GBL + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD") + ;;>>?$P(GBL(1),";",3)=13 + ;;>>>D BUILD^GPLXPATH("GBL","G2") + ;;>>?G2(G2(0))="" + ;;>>?G2(1)="" + ;;> + ;;>>>K G2,GBL,G3,G4 + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") + ;;>>>D INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") + ;;>>>D INSERT^GPLXPATH("G3","G2","//") + ;;>>?G2(1)=GXML(9) + ;;> + ;;>>>K G2,GBL,G3 + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") + ;;>>>D REPLACE^GPLXPATH("GXML","G2","//FIRST/SECOND") + ;;>>?GXML(2)="" + ;;> + ;;>>>K GXML,G2,GBL,G3 + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2") + ;;>>>D INSINNER^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") + ;;>>?GXML(10)="" + ;;> + ;;>>>K GXML,G2,GBL,G3 + ;;>>>D ZTEST^GPLXPATH("INITXML") + ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2") + ;;>>>D INSINNER^GPLXPATH("G2","G2") + ;;>>?G2(8)="" + ;;> + ;;>>>K GTMP,GTMP2 + ;;>>>N GTMP,GTMP2 + ;;>>>D PUSH^GPLXPATH("GTMP","A") + ;;>>>D PUSH^GPLXPATH("GTMP2","B") + ;;>>>D PUSH^GPLXPATH("GTMP2","C") + ;;>>>D PUSHA^GPLXPATH("GTMP","GTMP2") + ;;>>?GTMP(3)="C" + ;;>>?GTMP(0)=3 + ;;> + ;;>>>K GTMP,GTMP2 + ;;>>>S GTMP("TEST1")=1 + ;;>>>D H2ARY^GPLXPATH("GTMP2","GTMP") + ;;>>?GTMP2(0)=1 + ;;>>?GTMP2(1)="^TEST1^1" + ;;> + ;;>>>K GTMP,GTMP2 + ;;>>>D PUSH^GPLXPATH("GTMP","@@VAR1@@") + ;;>>>D XVARS^GPLXPATH("GTMP2","GTMP") + ;;>>?GTMP2(1)="^VAR1^" + ;;> Index: /ccr/tags/CCR_1_0_7/p/GPLXPATH.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/GPLXPATH.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/GPLXPATH.m (revision 291) @@ -0,0 +1,504 @@ +GPLXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 + ;;0.2;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is an XML XPATH utility library",! + W ! + Q + ; +OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE + ; + N Y + S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) + I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR + I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR + Q + ; +PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) + ; VAL IS A STRING AND STK IS PASSED BY NAME + ; + I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE + S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH + S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY + Q + ; +POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL + ; VAL AND STK ARE PASSED BY REFERENCE + ; + I @STK@(0)<1 D ; IF ARRAY IS EMPTY + . S VAL="" + . S @STK@(0)=0 + I @STK@(0)>0 D ; + . S VAL=@STK@(@STK@(0)) + . K @STK@(@STK@(0)) + . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY + Q + ; +PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME + ; + N ZGI + F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY + . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT + Q + ; +MKMDX(STK,RTN) ; MAKES A MUMPS INDEX FROM THE ARRAY STK + ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS + S RTN="" + N I + ; W "STK= ",STK,! + I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY + . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON + . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON + . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) + Q + ; +XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG + ; AND WILL RETURN NAME + ; ISTR IS PASSED BY VALUE + N CUR,TMP + I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET + . S TMP=$P(ISTR,"<",2) + I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE + . S TMP=$P(TMP,"/",2) + S CUR=$P(TMP,">",1) ; EXTRACT THE NAME + ; W "CUR= ",CUR,! + I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> + . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER + ; W "CUR2= ",CUR,! + Q CUR + ; +INDEX(ZXML) ; parse the XML in ZXML and produce an XPATH index + ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE + ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE + ; XML SECTION + ; ZXML IS PASSED BY NAME + N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND + N GPLSTK ; LEAVE OUT FOR DEBUGGING + I '$D(@ZXML@(0)) D ; NO XML PASSED + . W "ERROR IN XML FILE",! + S GPLSTK(0)=0 ; INITIALIZE STACK + F I=1:1:@ZXML@(0) D ; PROCESS THE ENTIRE ARRAY + . S LINE=@ZXML@(I) + . ;W LINE,! + . S FOUND=0 ; INTIALIZED FOUND FLAG + . I LINE?.E1"".E) D + . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS + . . . ; ON THE SAME LINE + . . . ; W "FOUND ",LINE,! + . . . S FOUND=1 ; SET FOUND FLAG + . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME + . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK + . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX + . . . ; W "MDX=",MDX,! + . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE + . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER + . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE + . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST + . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK + . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END + . . I LINE?.E1"") D ; BEGINNING OF A SECTION + . . . ; W "FOUND ",LINE,! + . . . S FOUND=1 ; SET FOUND FLAG + . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME + . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK + . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX + . . . ; W "MDX=",MDX,! + . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE + . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER + . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE + . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX + S @ZXML@("INDEXED")="" + S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH + Q + ; +QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION + ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" + ; IARY AND OARY ARE PASSED BY NAME + I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY + . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML + N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN + N TMP,I,J,QXPATH + S FIRST=1 + S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT + I XPATH'="//" D ; NOT A ROOT QUERY + . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES + . S FIRST=$P(TMP,"^",1) + . S LAST=$P(TMP,"^",2) + K @OARY + S @OARY@(0)=+LAST-FIRST+1 + S J=1 + FOR I=FIRST:1:LAST D + . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY + . S J=J+1 + ; ZWR OARY + Q + ; +XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH + ; INDEX WITH TWO PIECES START^FINISH + ; IDX IS PASSED BY NAME + Q $P(@IDX@(XPATH),"^",1) + ; +XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH + ; INDEX WITH TWO PIECES START^FINISH + ; IDX IS PASSED BY NAME + Q $P(@IDX@(XPATH),"^",2) + ; +START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX + ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH + ; COMPANION TO FINISH ; IDX IS PASSED BY NAME + Q $P(ISTR,";",2) + ; +FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX + ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH + Q $P(ISTR,";",3) + ; +ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX + ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH + Q $P(ISTR,";",1) + ; +BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST + ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST + ; DEST IS CLEARED TO START + ; USES PUSH TO DO THE COPY + N I + K @BDEST + F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST + . N J,ATMP + . S ATMP=$$ARRAY(@BLIST@(I)) + . I DEBUG W "ATMP=",ATMP,! + . I DEBUG W @BLIST@(I),! + . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; + . . ; FOR EACH LINE IN THIS INSTR + . . I DEBUG W "BDEST= ",BDEST,! + . . I DEBUG W "ATMP= ",@ATMP@(J),! + . . D PUSH(BDEST,@ATMP@(J)) + Q + ; +QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST + ; + I DEBUG W "QUEUEING ",BLST,! + D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) + Q + ; +CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME + ; KILLS CPDEST FIRST + N CPINSTR + I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,! + I @CPSRC@(0)<1 D ; BAD LENGTH + . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! + . Q + ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT + D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY + D BUILD("CPINSTR",CPDEST) + Q + ; +QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST + ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD + ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT + ; USED TO INSERT CHILDREN NODES + I @QOXML@(0)<1 D ; MALFORMED XML + . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! + . Q + I DEBUG W "DOING QOPEN",! + N S1,E1,QOT,QOTMP + S S1=1 ; OPEN FROM THE BEGINNING OF THE XML + I $D(QOXPATH) D ; XPATH PROVIDED + . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX + . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 + I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT + . S E1=@QOXML@(0)-1 + D QUEUE(QOBLIST,QOXML,S1,E1) + ; S QOTMP=QOXML_"^"_S1_"^"_E1 + ; D PUSH(QOBLIST,QOTMP) + Q + ; +QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN + ; ADDS THE LIST LINE OF QCXML TO QCBLIST + ; USED TO FINISH INSERTING CHILDERN NODES + ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END + ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO + I @QCXML@(0)<1 D ; MALFORMED XML + . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! + I DEBUG W "GOING TO CLOSE",! + N S1,E1,QCT,QCTMP + S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML + I $D(QCXPATH) D ; XPATH PROVIDED + . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX + . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML + I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT + . S S1=@QCXML@(0) + D QUEUE(QCBLIST,QCXML,S1,E1) + ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) + Q + ; +INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE + ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS + ; OMITTED, INSERTION WILL BE AT THE ROOT + ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW + ; XML AT THE END OF THE XPATH POINT + ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE + N INSBLD,INSTMP + I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! + I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),! + I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY + . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT + I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY + . I $D(INSXPATH) D ; XPATH PROVIDED + . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE + . . I DEBUG D PARY^GPLXPATH("INSBLD") + . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT + . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH + . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML + . I $D(INSXPATH) D ; XPATH PROVIDED + . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH + . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT + . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH + . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST + . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE + Q + ; +INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW + ; INTO INNXML AT THE INNXPATH XPATH POINT + ; + N INNBLD,UXPATH + N INNTBUF + S INNTBUF=$NA(^TMP($J,"INNTBUF")) + I '$D(INNXPATH) D ; XPATH NOT PASSED + . S UXPATH="//" ; USE ROOT XPATH + I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED + I '$D(@INNXML@(0)) D ; INNXML IS EMPTY + . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER + . D BUILD("INNBLD",INNXML) + I @INNXML@(0)>0 D ; NOT EMPTY + . D QOPEN("INNBLD",INNXML,UXPATH) ; + . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML + . D QCLOSE("INNBLD",INNXML,UXPATH) + . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER + . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST + Q + ; +INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST + ; BUT XDEST AN XNEW ARE PASSED BY NAME + N XBLD,XTMP + D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT + D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST + D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION + D BUILD("XBLD","XTMP") ; BUILD THE RESULT + D CP("XTMP",XDEST) ; COPY TO THE DESTINATION + I DEBUG D PARY("XDEST") + Q + ; +REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT + ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE + ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE + ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") + N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP + S OLD=$NA(^TMP($J,"REPLACE_OLD")) + D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD + S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS + S XFIRST=$P(XNODE,"^",1) + S XLAST=$P(XNODE,"^",2) + I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG + . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE + . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST + I RENEW'="" D ; NEW XML IS NOT NULL + . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE + . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW + . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST + I DEBUG W "REPLACE PREBUILD",! + I DEBUG D PARY("REBLD") + D BUILD("REBLD","RTMP") + K @REXML ; KILL WHAT WAS THERE + D CP("RTMP",REXML) ; COPY IN THE RESULT + Q + ; +MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY + ; W "Reporting on the missing",! + ; W OARY + I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q + N I + S @OARY@(0)=0 ; INITIALIZED MISSING COUNT + F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY + . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE + . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY + . . Q + Q + ; +MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY + ; AND PUT THE RESULTS IN OXML + I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q + I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q + N I,J,TNAM,TVAL,TSTR + S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT + F I=1:1:@OXML@(0) D ; LOOP THROUGH WHOLE ARRAY + . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT + . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? + . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS + . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS + . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! + . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME + . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED + . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? + . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD + . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE + . . . . E D DOFLD ; PROCESS A FIELD + . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER + . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES + . . I DEBUG W TSTR + I DEBUG W "MAPPED",! + Q + ; +DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE + ; + Q + ; +TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS + ; THEXML IS PASSED BY NAME + N I,J,TMPXML,DEL,FOUND,INTXT + S FOUND=0 + S INTXT=0 + I DEBUG W "DELETING EMPTY ELEMENTS",! + F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY + . S J=@THEXML@(I) + . I J["" D + . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM + . . I DEBUG W "IN HTML SECTION",! + . N JM,JP,JPX ; JMINUS AND JPLUS + . S JM=@THEXML@(I-1) ; LINE BEFORE + . I JM["" S INTXT=0 ; LEFT HTML SECTION,START TRIM + . S JP=@THEXML@(I+1) ; LINE AFTER + . I INTXT=0 D ; IF NOT IN AN HTML SECTION + . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH + . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES + . . . I DEBUG W I,J,JP,! + . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED + . . . S DEL(I)="" ; SET LINE TO DELETE + . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE + . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE + . . . I DEBUG W I,J,! + . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED + . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED + . . . I JM=JPX D ; + . . . . I DEBUG W I,JM_J_JPX,! + . . . . S DEL(I-1)="" + . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL + ; . I J'["><" D PUSH("TMPXML",J) + I FOUND D ; NEED TO DELETE THINGS + . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES + . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED + . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY + . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY + Q FOUND + ; +UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML + ; XSEC IS A SECTION PASSED BY NAME + N XBLD,XTMP + D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML + D BUILD("XBLD","XTMP") ; BUILD THE RESULT + D CP("XTMP",XSEC) ; REPLACE PASSED XML + Q + ; +PARY(GLO) ;PRINT AN ARRAY + N I + F I=1:1:@GLO@(0) W I_" "_@GLO@(I),! + Q + ; +H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY + ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE + I '$D(IPRE) S IPRE="" + N H2I S H2I="" + ; W $O(@IHASH@(H2I)),! + F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH + . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES + . . ;W H2I_"^"_@IHASH@(H2I),! + . . N IH,IHI + . . S IH=$NA(@IHASH@(H2I)) ; + . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR + . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE + . . S IHI="" ; INDEX INTO "M" MULTIPLES + . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE + . . . ; W @IH@(IHI) + . . . S IH3=$NA(@IH2@(IHI)) + . . . ; W "HEY",IH3,! + . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS + . . ; W IH,! + . . ; W "GPLZZ",! + . . ; W $NA(@IHASH@(H2I)),! + . . Q ; + . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) + . ; W @IARYRTN@(0),! + Q + ; +XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES + ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ + ; XVRTN AND XVIXML ARE PASSED BY NAME + ; + N XVI,XVTMP,XVT + F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML + . S XVT=@XVIXML@(XVI) + . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI + D H2ARY(XVRTN,"XVTMP") + Q + ; +DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE + ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE + ; + N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED + I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE + . D LOAD^GPLCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP + . S DXUSE="DTMP" ; DXUSE IS NAME + E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE + . D LOAD^GPLCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP + . S DXUSE="DTMP" ; DXUSE IS NAME + E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE + N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE + D XVARS("DVARS",DXUSE) ; PULL OUT VARS + D PARY^GPLXPATH("DVARS") ;AND DISPLAY THEM + Q + ; +TEST ; Run all the test cases + D TESTALL^GPLUNIT("GPLXPAT0") + Q + ; +ZTEST(WHICH) ; RUN ONE SET OF TESTS + N ZTMP + S DEBUG=1 + D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") + D ZTEST^GPLUNIT(.ZTMP,WHICH) + Q + ; +TLIST ; LIST THE TESTS + N ZTMP + D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") + D TLIST^GPLUNIT(.ZTMP) + Q + ; Index: /ccr/tags/CCR_1_0_7/p/KBAICSNA.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/KBAICSNA.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/KBAICSNA.m (revision 291) @@ -0,0 +1,213 @@ +KBAICSNA ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES + ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD + ; USING THE VISTA LEXICON ^LEX + ; +ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE + ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD + ; TO RESUME AT NEXT DRUG, USE BEGIEN="" + ; USE RESET^KBAICSNA TO RESET TO TOP OF DRUG LIST + ; + N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR + N CCRGLO + D ASETUP ; SET UP VARIABLES AND GLOBALS + D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE + I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME + S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN + S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD + I SNOIEN="" S SNOIEN=RESUME + I +SNOIEN=0 D Q ; AT THE END OF THE ALLERGY LIST + . W "END OF DRUG LIST, CALL RESET^KBAICSNA",! + F SNOI=1:1:IENCNT D Q:+SNOIEN=0 ; FOR IENCNT NUMBER OF PATIENTS OR END + . ;D CCRRPC^GPLCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR + . W SNOIEN,@GMRBASE@(SNOIEN,0),! + . N SNORTN,TTERM ; RETURN ARRAY + . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY" + . D TEXTRPC(.SNORTN,TTERM) + . I $D(SNORTN) D ; + . . S TVUID=$$GET1^DIQ(120.82,SNOIEN,"VUID") + . . W "VUID:",TVUID,! + . . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS + . . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)_"^"_TVUID_"^"_SNORTN("F") + . . ; + . . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP + . . ; + . . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS + . . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG + . . ; + . . N CATNAME,CATTBL + . . S CATNAME="" + . . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY + . . ; W "CATEGORY NAME: ",CATNAME,! + . . ; + . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD + . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN + ; D PARY^GPLXPATH(@SNOBASE@("ATTRTBL")) + Q + ; +TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN + ; + ;N TTMP + W ITEXT,! + S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN") + Q + ; +ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL + I '$D(SNOBASE) S SNOBASE=$NA(^TMP("GPLSNO")) + I '$D(@SNOBASE) S @SNOBASE="" + I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82)) + I '$D(SNOTBL) S SNOTBL=$NA(^TMP("GPLSNO","SNOTBL","TABLE")) ; ATTR TABLE + S ^TMP("GPLSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES + Q + ; +AINIT ; INITIALIZE ATTRIBUTE TABLE + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + K @SNOTBL + D APUSH^GPLRIMA(SNOTBL,"CODE") + D APUSH^GPLRIMA(SNOTBL,"NOCODE") + D APUSH^GPLRIMA(SNOTBL,"MULTICODE") + D APUSH^GPLRIMA(SNOTBL,"SUBMULTI") + D APUSH^GPLRIMA(SNOTBL,"DONE") + Q +APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL + ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING + ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES + ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) + I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING + N USETBL + I '$D(@SNOBASE@("TABLES",PTBL)) D Q ; NO TABLE + . W "ERROR NO SUCH TABLE",! + S USETBL=@SNOBASE@("TABLES",PTBL) + S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL + Q +SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS + N SBASE,SATTR + S SBASE=$NA(@SNOBASE@("VARS",SDFN)) + D APOST("SATTR","SNOTBL","DONE") + I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE") + I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE") + Q SATTR ; GPL + I $D(@SBASE@("PROBLEMS",1)) D ; + . D APOST("SATTR","SNOTBL","PROBLEMS") + . ; W "POSTING PROBLEMS",! + I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS") + I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES + . D APOST("SATTR","SNOTBL","MEDS") + . N ZR,ZI + . D GETPA^GPLRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES + . ; D PATD^KBAICSNA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES + D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED + ; W "ATTRIBUTES: ",SATTR,! + Q SATTR + ; +RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES + K ^TMP("GPLSNO","RESUME") + K ^TMP("GPLSNO") + Q + ; +CLIST ; LIST THE CATEGORIES + ; + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + N CLBASE,CLNUM,ZI,CLIDX + S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) + S CLNUM=@CLBASE@(0) + F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES + . S CLIDX=@CLBASE@(ZI) + . W "(",$P(@CLBASE@(CLIDX),"^",1) + . W ":",$P(@CLBASE@(CLIDX),"^",2),") " + . W CLIDX,! + ; D PARY^GPLXPATH(CLBASE) + Q + ; +CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES + ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT + ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE + ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME + ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, + ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" + ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES + ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY + ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING + ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY + ; NUMBER IE CTBL_X(CDFN)="" + ; + ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST + S CCTBL=$NA(@CBASE@(CTBL,"CATS")) + ; W "CBASE: ",CCTBL,! + ; + I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY + . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY + . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY + . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT + . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY + . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME + . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 + ; + S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY + S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT + S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK + ; + S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED + ; + S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT + ; W "IENS BASE: ",CPATLIST,! + S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST + ; + Q + ; +REUSE ; GET SAVED VALUES FROM ^TMP("GPLSAV") AND PUT THEM IN A DATABASE + ; + D ASETUP + D AINIT + N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH + D DO^KBAICX1 ; INITIALIZE GPLSAV VARIABLES + ;S SAVBASE=$NA(^TMP("GPLSAV","VARS")) + S SAVBASE=$NA(@SNOBASE@("VARS")) + S CSVARY=$NA(^TMP("GPLSNO","CSV")) + K @CSVARY + D PUSH^GPLXPATH(CSVARY,"VUID|VUIDText|MediationCode|MediationText") ; header for CSV file + S SNOI="" + F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST + . S SNOI=$O(@SAVBASE@(SNOI)) + . S SNOJ=@SAVBASE@(SNOI) + . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) + . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE + . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON + . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE + . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE + . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE + . S SNOVUID=$P(SNOJ,"^",9) ; VUID FOR THIS RECORD + . S SNOTXT=$P(SNOJ,"^",10) ; NOMED TEXT FOR CODE + . D PUSH^GPLXPATH(CSVARY,SNOVUID_"|"_$P(SNOSRCH," ALLERGY",1)_"|"_SNOSNO_"|"_SNOTXT) + . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! + . W SNOK,! + . W SNOJ,! + S OARY=$NA(@CSVARY@(1)) ; SETUP FOR OUTPUT ROUTINE + D PARY^GPLXPATH(CSVARY) + S OFILE="GMR_ALLERGY_MAPPING_TABLE.csv" + S ODIR="/home/vademo2/" + S ZY=$$OUTPUT^GPLXPATH(OARY,OFILE,ODIR) + I ZY W "WROTE ",OFILE," to ",ODIR,! + Q + ; Index: /ccr/tags/CCR_1_0_7/p/KBAICX1.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/KBAICX1.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/KBAICX1.m (revision 291) @@ -0,0 +1,90 @@ +KBAICX1 ; CCDCCR/GPL - LOADS SNOMED CODES INTO ^TMP; 10/15/08 + ;;0.2;CCDCCR;nopatch;noreleasedate +DO ; + S ^TMP("GPLSAV","VARS",3)="CHOCOLATE ALLERGY^1^7476359^300912001^disorder^20050701^F-C3111^1" + S ^TMP("GPLSAV","VARS",6)="STRAWBERRIES ALLERGY^1^7164395^91938006^disorder^20050701^D5-00331^1" + S ^TMP("GPLSAV","VARS",7)="EGGS ALLERGY^1^7164379^91930004^disorder^20050701^D5-00340^1" + S ^TMP("GPLSAV","VARS",9)="POLLEN ALLERGY^1^7476355^300910009^disorder^20050701^F-C310E^1" + S ^TMP("GPLSAV","VARS",10)="MOLD ALLERGY^1^7942600^419474003^disorder^20050701^F-C3128^1" + S ^TMP("GPLSAV","VARS",13)="ANIMAL HAIR ALLERGY^1^7476357^300911008^disorder^20050701^F-C310F^1" + S ^TMP("GPLSAV","VARS",14)="DUST ALLERGY^1^7561285^390952000^disorder^20050701^F-C300E^1" + S ^TMP("GPLSAV","VARS",15)="IODINE ALLERGY^1^7464505^294914009^disorder^20050701^DF-1006F^1" + S ^TMP("GPLSAV","VARS",20)="CHEESE ALLERGY^1^7476363^300914000^disorder^20050701^D5-00305^1" + S ^TMP("GPLSAV","VARS",22)="CITRUS ALLERGY^1^7939822^418085001^disorder^20050701^D5-00335^1" + S ^TMP("GPLSAV","VARS",24)="CORN ALLERGY^1^7942798^419573007^disorder^20050701^F-C3144^1" + S ^TMP("GPLSAV","VARS",26)="FISH ALLERGY^1^7608411^417532002^disorder^20050701^D5-00322^1" + S ^TMP("GPLSAV","VARS",29)="MILK ALLERGY^1^7414545^266931007^finding^20050701^C-F2979^1" + S ^TMP("GPLSAV","VARS",31)="NUTS ALLERGY^1^7164387^91934008^disorder^20050701^D5-00310^1" + S ^TMP("GPLSAV","VARS",33)="PEPPERMINT ALLERGY^1^7462059^293690005^disorder^20050701^DF-10F75^1" + S ^TMP("GPLSAV","VARS",36)="PORK ALLERGY^1^7939488^417918006^disorder^20050701^F-C312B^1" + S ^TMP("GPLSAV","VARS",37)="POTATO ALLERGY^1^7942890^419619007^disorder^20050701^F-C3136^1" + S ^TMP("GPLSAV","VARS",40)="SHRIMP ALLERGY^1^7943596^419972009^disorder^20050701^D5-00325^1" + S ^TMP("GPLSAV","VARS",44)="TOMATO ALLERGY^1^7941210^418779002^disorder^20050701^F-C3131^1" + S ^TMP("GPLSAV","VARS",46)="WHEAT ALLERGY^1^7944000^420174000^disorder^20050701^F-C3132^1" + S ^TMP("GPLSAV","VARS",52)="ALCOHOL ALLERGY^1^7463339^294330005^disorder^20050701^DF-1120D^1" + S ^TMP("GPLSAV","VARS",55)="ASCORBIC ACID ALLERGY^1^7464557^294940003^disorder^20050701^DF-10089^1" + S ^TMP("GPLSAV","VARS",56)="ASPARTAME ALLERGY^1^7942012^419180003^disorder^20050701^F-C312A^1" + S ^TMP("GPLSAV","VARS",57)="ASPIRIN ALLERGY^1^7461853^293586001^disorder^20050701^DF-10F0E^1" + S ^TMP("GPLSAV","VARS",62)="BOTULISM ANTITOXIN ALLERGY^1^7464013^294668002^disorder^20050701^DF-11358^1" + S ^TMP("GPLSAV","VARS",65)="CAFFEINE ALLERGY^1^7940340^418344001^disorder^20050701^DF-1144C^1" + S ^TMP("GPLSAV","VARS",66)="CALCITONIN, SALMON ALLERGY^1^7464357^294840004^disorder^20050701^DF-113FF^1" + S ^TMP("GPLSAV","VARS",69)="CETYLPYRIDINIUM ALLERGY^1^7463559^294441006^disorder^20050701^DF-1127A^1" + S ^TMP("GPLSAV","VARS",92)="FLUPHENAZINE DECANOATE ALLERGY^1^7462541^293931005^disorder^20050701^DF-11062^1" + S ^TMP("GPLSAV","VARS",94)="GELATIN ALLERGY^1^7464371^294847001^disorder^20050701^F-C3116^1" + S ^TMP("GPLSAV","VARS",98)="INSULIN ALLERGY^1^7464105^294714000^disorder^20050701^DF-11384^1" + S ^TMP("GPLSAV","VARS",109)="POVIDONE IODINE ALLERGY^1^7464509^294916006^disorder^20050701^DF-10073^1" + S ^TMP("GPLSAV","VARS",116)="SALICYLIC ACID ALLERGY^1^7463081^294201000^disorder^20050701^DF-1118F^1" + S ^TMP("GPLSAV","VARS",122)="TESTOSTERONE ALLERGY^1^7464229^294776007^disorder^20050701^DF-113C0^1" + S ^TMP("GPLSAV","VARS",125)="PENICILLIN ALLERGY^1^7164391^91936005^disorder^20050701^DF-10074^1" + S ^TMP("GPLSAV","VARS",131)="PEANUTS ALLERGY^1^7164389^91935009^disorder^20050701^D5-00311^1" + S ^TMP("GPLSAV","VARS",138)="APPLE JUICE ALLERGY^1^7940280^418314004^disorder^20050701^D5-00333^1" + S ^TMP("GPLSAV","VARS",144)="SULFA DRUGS ALLERGY^1^7164397^91939003^disorder^20050701^DF-10072^1" + S ^TMP("GPLSAV","VARS",161)="FERROUS SULFATE ALLERGY^1^7464481^294902001^disorder^20050701^DF-1006B^1" + S ^TMP("GPLSAV","VARS",199)="CONTRAST MEDIA ALLERGY^1^7461955^293637006^disorder^20050701^DF-10F41^1" + S ^TMP("GPLSAV","VARS",203)="WASP VENOM ALLERGY^1^7508115^320868003^product^20050701^C-B0508^1" + S ^TMP("GPLSAV","VARS",210)="COCONUT OIL ALLERGY^1^7943280^419814004^disorder^20050701^DF-1144E^1" + S ^TMP("GPLSAV","VARS",257)="NICKEL ALLERGY^1^7943228^419788000^disorder^20050701^F-C313B^1" + S ^TMP("GPLSAV","VARS",268)="MILDEW ALLERGY^1^7942600^419474003^disorder^20050701^F-C3128^1" + S ^TMP("GPLSAV","VARS",272)="METAL ALLERGY^1^7476365^300915004^disorder^20050701^F-C3112^1" + S ^TMP("GPLSAV","VARS",273)="METOCLOPRAMIDE ALLERGY^1^7462029^293675006^disorder^20050701^DF-10F66^1" + S ^TMP("GPLSAV","VARS",276)="MEAT ALLERGY^1^7941282^418815008^disorder^20050701^F-C312C^1" + S ^TMP("GPLSAV","VARS",289)="LEGUMES ALLERGY^1^7592039^409136006^disorder^20050701^F-C3123^1" + S ^TMP("GPLSAV","VARS",318)="VEGETABLES ALLERGY^1^7592039^409136006^disorder^20050701^F-C3123^1" + S ^TMP("GPLSAV","VARS",325)="TREE POLLEN ALLERGY^1^7942178^419263009^disorder^20050701^F-C3139^1" + S ^TMP("GPLSAV","VARS",337)="TAPE ALLERGY^1^7585411^405649006^disorder^20050701^F-C3122^1" + S ^TMP("GPLSAV","VARS",348)="SUNLIGHT ALLERGY^1^7399083^258155009^disorder^20050701^D0-75245^1" + S ^TMP("GPLSAV","VARS",355)="STRAW ALLERGY^1^7164395^91938006^disorder^20050701^D5-00331^1" + S ^TMP("GPLSAV","VARS",374)="SMALLPOX VACCINE ALLERGY^1^7463991^294657002^disorder^20050701^DF-1134D^1" + S ^TMP("GPLSAV","VARS",390)="WOOD ALLERGY^1^7579397^402595004^disorder^20050701^F-C311A^1" + S ^TMP("GPLSAV","VARS",394)="WEED POLLEN ALLERGY^1^7942072^419210001^disorder^20050701^F-C313A^1" + S ^TMP("GPLSAV","VARS",399)="SALT ALLERGY^1^7464471^294897002^disorder^20050701^DF-10066^1" + S ^TMP("GPLSAV","VARS",407)="RUBBER ALLERGY^1^7942476^419412007^disorder^20050701^F-C312E^1" + S ^TMP("GPLSAV","VARS",455)="PESTICIDES ALLERGY^1^7463933^294628001^disorder^20050701^DF-11332^1" + S ^TMP("GPLSAV","VARS",457)="PERFUME ALLERGY^1^7476351^300908007^disorder^20050701^F-C310D^1" + S ^TMP("GPLSAV","VARS",461)="PEPPERONI ALLERGY^1^7462059^293690005^disorder^20050701^DF-10F75^1" + S ^TMP("GPLSAV","VARS",462)="WATERMELONS ALLERGY^1^7942248^419298007^disorder^20050701^D5-00332^1" + S ^TMP("GPLSAV","VARS",464)="WALNUTS ALLERGY^1^7164399^91940001^disorder^20050701^D5-00312^1" + S ^TMP("GPLSAV","VARS",471)="SHELLFISH ALLERGY^1^7476361^300913006^disorder^20050701^D5-00321^1" + S ^TMP("GPLSAV","VARS",473)="SEAFOOD ALLERGY^1^7164393^91937001^disorder^20050701^D5-00320^1" + S ^TMP("GPLSAV","VARS",478)="RAGWEED ALLERGY^1^7940774^418561004^disorder^20050701^F-C312D^1" + S ^TMP("GPLSAV","VARS",486)="OATS ALLERGY^1^7942336^419342009^disorder^20050701^F-C3135^1" + S ^TMP("GPLSAV","VARS",488)="MUSTARD ALLERGY^1^7462171^293746007^disorder^20050701^DF-10FAB^1" + S ^TMP("GPLSAV","VARS",498)="ETHYL ALCOHOL ALLERGY^1^7943932^420140004^disorder^20050701^DF-1144D^1" + S ^TMP("GPLSAV","VARS",518)="GRASS ALLERGY^1^7941030^418689008^disorder^20050701^F-C3138^1" + S ^TMP("GPLSAV","VARS",522)="LOBSTER ALLERGY^1^7940904^418626004^disorder^20050701^D5-00323^1" + S ^TMP("GPLSAV","VARS",543)="SALMON ALLERGY^1^7464357^294840004^disorder^20050701^DF-113FF^1" + S ^TMP("GPLSAV","VARS",544)="RYE ALLERGY^1^7940020^418184004^disorder^20050701^F-C3134^1" + S ^TMP("GPLSAV","VARS",599)="BEE VENOM ALLERGY^1^7508115^320868003^product^20050701^C-B0508^1" + S ^TMP("GPLSAV","VARS",608)="ANTHRAX VACCINE ALLERGY^1^7463959^294641002^disorder^20050701^DF-1133E^1" + S ^TMP("GPLSAV","VARS",611)="ANIMAL DANDER ALLERGY^1^7351255^232347008^disorder^20050701^F-C3006^1" + S ^TMP("GPLSAV","VARS",613)="ALUMINUM ALLERGY^1^7578823^402306009^disorder^20050701^F-C3121^1" + S ^TMP("GPLSAV","VARS",621)="WOOL ALLERGY^1^7463339^294330005^disorder^20050701^DF-1120D^1" + S ^TMP("GPLSAV","VARS",634)="GRASS POLLEN ALLERGY^1^7941030^418689008^disorder^20050701^F-C3138^1" + S ^TMP("GPLSAV","VARS",645)="FRUIT ALLERGY^1^7164383^91932007^disorder^20050701^D5-00330^1" + S ^TMP("GPLSAV","VARS",686)="CITRUS FRUIT ALLERGY^1^7939822^418085001^disorder^20050701^D5-00335^1" + S ^TMP("GPLSAV","VARS",694)="DOG DANDER ALLERGY^1^7942194^419271008^disorder^20050701^F-C3014^1" + S ^TMP("GPLSAV","VARS",696)="JUICE ALLERGY^1^7940280^418314004^disorder^20050701^D5-00333^1" + S ^TMP("GPLSAV","VARS",703)="RED MEAT ALLERGY^1^7941282^418815008^disorder^20050701^F-C312C^1" + S ^TMP("GPLSAV","VARS",715)="PEPPER ALLERGY^1^7462059^293690005^disorder^20050701^DF-10F75^1" + Q + ; Index: /ccr/tags/CCR_1_0_7/p/LA7QRY1.m =================================================================== --- /ccr/tags/CCR_1_0_7/p/LA7QRY1.m (revision 291) +++ /ccr/tags/CCR_1_0_7/p/LA7QRY1.m (revision 291) @@ -0,0 +1,123 @@ +LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994 + ; + Q + ; +CHKSC ; Check search NLT/LOINC codes + ; + N J + ; + S J=0 + F S J=$O(LA7SC(J)) Q:'J D + . N X + . S X=LA7SC(J) + . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q + . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" + . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q + . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" + . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" + . K LA7SC(J) + Q + ; + ; +SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes + ; Find all topographies that use this HL7 specimen code + N J,K,L + ; + S J=0 + F S J=$O(LA7SPEC(J)) Q:'J D + . S K=LA7SPEC(J),L=0 + . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" + Q + ; + ; +BUILDMSG ; Build HL7 message with result of query + ; + N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X + ; + I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" + S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) + S (HLQ,HL("Q"))="""""" + ; Set flag to not send HL7 message + S LA7NOMSG=1 + ; Create dummy MSH to pass HL7 delimiters + S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS + D FILESEG^LA7VHLU(GBL,.LA7MSH) + ; + F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" + ; + ; Take search results and put in HL7 message structure + S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 + ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M + F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT + . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q + . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 + . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR + . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR + . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR + . D OBX + ; + Q + ; + ; +PID ; Build PID segment + ; + N LA7PID + ; + S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) + S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) + D DEM^LRX + D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) + D FILESEG^LA7VHLU(GBL,.LA7PID) + S (LA("LRIDT"),LA("SUB"))="" + Q + ; + ; +ORC ; Build ORC segment + ; + N X + ; + S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) + S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) + I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) + S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 + D ORC^LA7VORU + S LA("NLT")="" + ; + Q + ; + ; +OBR ; Build OBR segment + ; + N LA764,LA7NLT + ; + S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" + I $L(LA7NLT) D + . S LA764=+$O(^LAM("E",LA7NLT,0)) + . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) + I LA("SUB")="CH" D + . D OBR^LA7VORU + . D NTE^LA7VORU + . S LA7OBXSN=0 + ; + Q + ; + ; +OBX ; Build OBX segment + ; + N LA7DATA,LA7VT + ; + S LA7NTESN=0 + I LA("SUB")="MI" D MI^LA7VORU1 Q + I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q + ; + S LA7VT=$QS(LA7ROOT,7) + D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) + I '$D(LA7DATA) Q + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; Send any test interpretation from file #60 + D INTRP^LA7VORUA + ; + Q Index: /ccr/tags/CCR_1_0_7/p/ccr.xsl =================================================================== --- /ccr/tags/CCR_1_0_7/p/ccr.xsl (revision 291) +++ /ccr/tags/CCR_1_0_7/p/ccr.xsl (revision 291) @@ -0,0 +1,2765 @@ + + + + + + + + + + + + + + + + + + + + + Continuity of Care Record + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+

Continuity of Care Record +
+

+ + + + + + + + + + + + + + + + + + + +
+ Date Created: + + + + + + EEE MMM dd, yyyy 'at' hh:mm aa zzz + +
+ From: + + + + + + + ( + + ) + +
+ +
+ To: + + + + + + + ( + + ) + +
+ +
+ Purpose: + + +
+
+
+ Patient Demographics +
+ + + + + + + + + + + + + + + + + + + + + + + + + +
NameDate of BirthGenderIdentification NumbersAddress / Phone
+ + + + + +
+ 		+ + + + + + +
+ 		+ + + + + + + + + + + +
+ + + +
+ 		+ + + + : +
+ + + +
+ + + +
+ + + , + + + +
+ + +
+ + : + + + +
+
+ Alerts +
+ + + + + + + + + + + + + + + + + + + + + +
TypeDateCodeDescriptionReactionSource
+ + + + + + + + +
+ 		+ + + + + + + + + - + + + + + + # + + + + + + +
+
+ Advance Directives +
+ + + + + + + + + + + + + + + + + + + +
TypeDateDescriptionStatusSource
+ + + + + + + + +
+ 		+ + + + + + + + + # + + + + + + +
+
+ Support Providers +
+ + + + + + + + + + + + + +
RoleName
+ + + + + # + + + + + + +
+
+ Functional Status +
+ + + + + + + + + + + + + + + + + + + + + +
TypeDateCodeDescriptionStatusSource
+ + + + + + + + +
+ 		+ + + + + + + + + + + # + + + + + + +
+
+ Problems +
+ + + + + + + + + + + + + + + + + + + + + +
TypeDateCodeDescriptionStatusSource
+ + + + + + + + +
+ 		+ + + + + + + + + + + # + + + + + + +
+
+ Procedures +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
TypeDateCodeDescriptionLocationSubstanceMethodPositionSiteStatusSource
+ + + + + + + + +
+ 		+ + + + + + + + + + ( + + + + + - + + ) + + + +
+ + + 		+ + + + + + + + + + + + + + + # + + + + + + +
+
+ Medications +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
MedicationDateStatusFormStrengthQuantitySIGIndicationsInstructionRefillsSource
+ + + + ( + + ) + + + + + + + + + +
+ 		+ + + + + + + / + + + + + + + + + + + + + + + +
+ 		+ + + + +
+ + 		+ + +
+ + 		+ + + + + + + + # + + + + + + +
+
+ Immunizations +
+ + + + + + + + + + + + + + + + + + + + + +
CodeVaccineDateRouteSiteSource
+ + + + + + ( + + ) + + + + + + + + + +
+ 		+ + + + + + + # + + + + + + +
+
+ Vital Signs +
+ + + + + + + + + + + + + + + + + +
Vital SignDateResultSource
+ + + + + + + MMM dd, yyyy ':' hh:mm aa zzz + + +
+ 		+ + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + +
+ + + + + + + + + +
+ 		+ + + # + + + + + + +
+
+ Encounters +
+ + + + + + + + + + + + + + + + + + + + + + + + + +
TypeDateLocationStatusPractitionerDescriptionIndicationsSource
+ + + + + + + + +
+ 		+ + + + + +
+ + 		+ + + + + + +
+ + 		+ + + + + + + + +
+ + 		+ + + # + + + + + + +
+
+ Social History +
+ + + + + + + + + + + + + + + + + + + + + +
TypeDateCodeDescriptionStatusSource
+ + + + + + + + +
+ 		+ + + + + + + + + + + + + # + + + + + + +
+
+ Family History +
+ + + + + + + + + + + + + + + + + + + + + + + +
TypeDateCodeDescriptionRelationship(s)StatusSource
+ + + + + + + + +
+ 		+ + + + + + + + +
+ + + +
+ 		+ + + + + + + # + + + + + + +
+
+ Results (Discrete) +
+ + + + + + + + + + + + + + + + + +
TestDateResultSource
+ + + + + + + MMM dd, yyyy ':' hh:mm aa zzz + + +
+ 		+ + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + +
+ + + + + + + + + +
+ 		+ + + # + + + + + + +
+
+ Results (Report) +
+ + + + + + + + + + + + + + + + + +
TestDateResultSource
+ + + + + + + MMM dd, yyyy ':' hh:mm aa zzz + + +
+ 		+ + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + +
+ + + + + + + +
+ 		+ + + # + + + + + + +
+
+ Insurance +
+ + + + + + + + + + + + + + + + + + + + + +
TypeDateIdentification NumbersPayment ProviderSubscriberSource
+ + + + + + + + MMM dd, yyyy ':' hh:mm aa zzz + + + +
+ 		+ + + + + + + + + + + + + + + + + + + +
+ : + +
+ : + +
+ 		+ + + # + + + + + + + + + + # + + + + + + + + + + # + + + + + + +
+
+ Plan Of Care Recommendations +
+ + + + + + + + + + + + + + + + + + + +
DescriptionRecommendationGoalStatusSource
+ + + + + + + + + + + # + + + + + + +
+
+ Plan Of Care Orders +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
DescripionPlan StatusTypeDateProcedureScheduleLocationSubstanceMethodPositionSiteStatusSource
+ + + + + + + + + + + + +
+ 		+ + + Every + + + + for + + + + + + + +
+ + + 		+ + + + + + + + + + + + # + + + + + + +
+
+ Health Care Providers +
+ + + + + + + + + + + + + +
RoleName
+ + + + + # + + + + + + +
+
+ References +
+ + + + + + + + + + + + + + + + + + + +
TypeDateDescriptionLocationSource
+ + + + + + + + +
+ 		+ + + + + + + + + + + + + + # + + + + + + +
+
+ +
+
+
+
+ + Additional Information About People & Organizations + + +

People

+ + + + + + + + + + + + + + + + + + + + + + + + +
NameSpecialtyRelationIdentification NumbersPhoneAddress/ E-mail
+ + + + + + + + + + + + + + + + + + + + + + +
+ + + +
+ 		+ + + + + + + + + +
+ + + +
+ 		+ + + + : +
+ + + +
+ + + +
+ + + , + + + +
+ + +
+ + +
+ + + + +

Organizations

+ + + + + + + + + + + + + + + + + + + + + + + + +
NameSpecialtyRelationIdentification NumbersPhoneAddress/ E-mail
+ + + + + + + + + + + + + + + + + + + + +
+ + + +
+ 		+ + + + + + + + + +
+ + + +
+ 		+ + + + : +
+ + + +
+ + + +
+ + + , + + + +
+ + +
+ + +
+ + + + +

Information Systems

+ + + + + + + + + + + + + + + + + + + + + + + + +
NameTypeVersionIdentification NumbersPhoneAddress/ E-mail
+ + + + + + + + + + + + + + + + + + + + +
+ + + +
+ 		+ + + + + + + + + +
+ + + +
+ 		+ + + + : +
+ + + +
+ + + +
+ + + , + + + +
+ + +
+ + +
+ + + + + + + + + + + January + February + March + April + May + June + July + August + September + October + November + December + + + Sunday + Monday + Tuesday + Wednesday + Thursday + Friday + Saturday + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Z + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ' + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Invalid token in format string: + + + + + + + + + + + + + + + + + + + + + + + + + + + + + AD + BC + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + PM + AM + + + + + UTC + UTC + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 7 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + () + + + + + + + + + + + + + () + + + + + + + MMM dd, yyyy + + + + : + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (for + + ) + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + (for + + ) + + + + + + +
+ + + + + + + + + + + + + + +
+
+ + + + + + + + + + + +
+ + The stylesheet used to generate this view of the CCR was provided by the American Academy of Family Physicians and the CCR Acceleration Task Force + +
+
+ + Powered by the ASTM E2369-05 Specification for the Continuity of Care Record (CCR) + + +
+ + + + + + + + + + + + + + + + + + + +