Changeset 1332 for ccr/branches


Ignore:
Timestamp:
Jan 4, 2012, 12:05:03 AM (13 years ago)
Author:
George Lilly
Message:

reset to certification routines with tabs

Location:
ccr/branches/ohum/p
Files:
70 edited

Legend:

Unmodified
Added
Removed

  • ccr/branches/ohum/p/C0CACTOR.m

    r1330 r1332  
    11C0CACTOR         ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CALERT.m

    r1330 r1332  
    11C0CALERT         ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CBAT.m

    r1330 r1332  
    11C0CBAT    ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CCCD.m

    r1330 r1332  
    11C0CCCD    ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CCCD1.m

    r1330 r1332  
    11C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CCCR.m

    r1330 r1332  
    11C0CCCR    ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
    … …  
    2626        I Y<1 Q  ; EXIT
    2727        S DFN=$P(Y,U,1) ; SET THE PATIENT
    28         ;OHUM/RUT 3120102 To take inputs from user for date limits and notes
    29         D ^C0CVALID
    30         ;OHUM/RUT
    3128        D XPAT(DFN) ; EXPORT TO A FILE
    3229        Q
    … …  
    171168        ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    172169        ; gpl - turned off Encounters for Certification
    173         ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
    174         I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    175         ;OHUM/RUT
    176170        Q
    177171        ;

  • ccr/branches/ohum/p/C0CCCR0.m

    r1330 r1332  
    11C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CCMT.m

    r1330 r1332  
    11C0CCMT   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
    2         ;;1.0;C0C;;May 21, 2010;Build 1
     2        ;;1.0;C0C;;May 21, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CCPT.m

    r1330 r1332  
    11C0CCPT  ;;BSL;RETURN CPT DATA;
    2         ;Sequence Managers Software GPL;;;;;Build 1
     2        ;Sequence Managers Software GPL;;;;;Build 38
    33        ;Copied into C0C namespace from SQMCPT with permission from
    44        ;Brian Lord - and with our thanks. gpl 01/20/2010
    … …  
    1919               ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
    2020               ;GET DATE OF NOTE
    21         ;OHUM/RUT 3111228 Date Range for Notes
    22                S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
    23                ;OHUM/RUT
    2421               S Z=""
    2522               F  S Z=$O(NOTE(Z)) Q:Z=""  D

  • ccr/branches/ohum/p/C0CDIC.m

    r1330 r1332  
    1 C0CDIC    ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR Dictionary Utility Library ",!
    21         W !
    22         Q
    23         ;
    24 DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE
    25         ;
    26         N ZI
    27         S ZI=""
    28         S G1=$NA(^TMP($J,"C0CCSV",1))
    29         S G1A=$NA(@G1@("V"))
    30         S G2=$NA(^TMP($J,"C0CCSV",2))
    31         D GETN2^C0CRNF(G1,170) ; GET THE MATRIX
    32         F  S ZI=$O(@G1A@(ZI)) Q:ZI=""  D  ;FOR EACH ROW IN THE MATRIX
    33         . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D  ;
    34         . . W @G1A@(ZI,"MAPPING METHOD",1),!
    35         . . ;K @G1A@(ZI,"MAPPING METHOD")
    36         . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1))
    37         D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE
    38         K @G1
    39         D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv")
    40         K @G2
    41         Q
    42         ;
    43 GVARS(C0CVARS,C0CT)     ; Get the CCR variables from the CCR template
    44         ; and return them in C0CVARS, which is passed by name
    45         ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE
    46         ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE
    47         ; C0CT IS RETURNED AS THE CCR TEMPLATE
    48         N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS
    49         D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE
    50         D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS
    51         N C0CI,C0CX
    52         S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT
    53         F C0CI=1:1:C0CTVARS(0) D  ; FOR EVERY LINE IN THE ARRAY
    54         . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL
    55         . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER
    56         ;D PARY^GPLXPATH("C0CVARS")
    57         Q
    58         ;
    59 GXPATH(C0CPVARS,C0CPT)  ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES
    60         ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS
    61         ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE
    62         ; BOTH ARE PASSED BY NAME
    63         ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM
    64         ; C0CPVARS(0) IS NUMBER OF VARIABLES
    65         ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE
    66         D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS
    67         ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER
    68         D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS
    69         ; NOW GO GET THE XPATH INDEXES
    70         D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY
    71         S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS
    72         F  S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI=""  D  ; VISIT EVERY LINE
    73         . I +C0CI'=0 Q  ; SKIP EVERYTHING BUT THE XPATH INDEX
    74         . I C0CI=0 Q  ; SKIP THE ZERO NODE
    75         . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y
    76         . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER
    77         . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER
    78         . I C0CY=C0CZ D  ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE)
    79         . . ; W "FOUND ",C0CI,!
    80         . . I $D(C0CTVARS(C0CY)) D  ; IF THERE IS A VARIABLE THERE
    81         . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR
    82         D SORTV ; SORT THE ARRAY BY LINE NUMBER
    83         Q
    84         ;
    85 HASHV   ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH
    86         ;N C0CI,C0CTVARS,C0CX,C0CY
    87         F C0CI=1:1:@C0CPVARS@(0) D  ; FOR THE ENTIRE ARRAY
    88         . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER
    89         . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME
    90         . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER
    91         Q
    92         ;
    93 SORTV   ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER
    94         ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY
    95         S C0CI="" ;
    96         F  S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI=""  D  ; BY LINE NUMBER
    97         . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME
    98         . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE
    99         . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY
    100         K @C0CPVARS
    101         M @C0CPVARS=C0C2
    102         Q
    103         ;
    104 LOAD    ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170
    105         ; INITIAL LOAD OF THE CCR DICTIONARY
    106         ;
    107         N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI
    108         S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY
    109         D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY
    110         ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD
    111         D PARY^GPLXPATH("C0CARY") ;TEST
    112         F C0CI=1:1:C0CARY(0) D  ; LOAD EACH VARIABLE
    113         . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME
    114         . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH
    115         . D UPDATE^DIE("","C0CFDA")
    116         . I $D(^TMP("DIERR",$J)) U $P BREAK
    117         . W "LOADING:",C0CI," ",C0CARY(C0CI),!
    118         Q
    119         ;
    120 INIT    ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES
    121         ;
    122         ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx,
    123         ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY
    124         ;G1("CODING")="170^8"
    125         ;G1("DATA ELEMENT")="170^7"
    126         ;G1("DESCRIPTION")="170^3"
    127         ;G1("ID")="170^1"
    128         ;G1("M","170^8","CODING")="170.08^.01"
    129         ;G1("MAPPING METHOD")="170.08^1"
    130         ;G1("SECTION")="170^10"
    131         ;G1("SOURCE")="170^4"
    132         ;G1("STATUS")="170^9"
    133         ;G1("TYPE")="170^6"
    134         ;G1("VARIABLE")="170^.01"
    135         ;G1("XPATH")="170^2"
    136         ;
    137         N C0CZA,C0CZX,C0CN,C0CSTAT
    138         S C0CZX=0
    139         S C0CSTAT=0 ; INIT STATUS SET FLAG
    140         F  S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0  D  ; FOR EACH DICT ENTRY
    141         . ;W C0CZX,!
    142         . K C0CA,C0CN ; CLEAR OUT THE LAST ONE
    143         . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH
    144         . ;ZWR C0CA B ;
    145         . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE
    146         . W "VARIABLE: ",C0CN,!
    147         . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ;
    148         . I $E(C0CN,1,6)="SOCIAL" D  ;
    149         . . D SETFDA("SECTION","SOC") ;
    150         . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED
    151         . . S C0CSTAT=1
    152         . I $E(C0CN,1,6)="FAMILY" D  ;
    153         . . D SETFDA("SECTION","FAM") ;
    154         . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED
    155         . . S C0CSTAT=1
    156         . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS
    157         . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS")
    158         . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS")
    159         . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS")
    160         . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST")
    161         . E  I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS")
    162         . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES
    163         . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION
    164         . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM
    165         . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N
    166         . I $$ZVALUE("XPATH")["/Medication/Directions/" D  ; MEDS DIRECTIONS VAR
    167         . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS
    168         . E  I $$ZVALUE("XPATH")["/Medications/Medication/" D  ; ALL OTHER MEDS
    169         . . D SETFDA("SECTION","MEDS") ; A MEDS VAR
    170         . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS
    171         . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE
    172         . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),!
    173         . ;ZWR C0CFDA
    174         . I $D(C0CFDA) D  ; WE HAVE CHANGES ON THIS VARIABLE
    175         . . ;ZWR C0CFDA
    176         . . D UPDATE^DIE("","C0CFDA(C0CZX)")
    177         . . I $D(^TMP("DIERR",$J)) U $P BREAK
    178         . . D CLEAN^DILF ; CLEAN UP
    179         . ;ZWR C0CFDA
    180         Q
    181         ;
    182 SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    183         ; TO SET TO VALUE C0CSV.
    184         ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    185         ; C0CSN,C0CSV ARE PASSED BY VALUE
    186         ;
    187         N C0CSI,C0CSJ
    188         S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER
    189         S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER
    190         S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV
    191         Q
    192 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    193         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    194         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    195         I '$D(ZTAB) S ZTAB="C0CA"
    196         Q $P(@ZTAB@(ZFN),"^",1)
    197 ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    198         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    199         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    200         I '$D(ZTAB) S ZTAB="C0CA"
    201         Q $P(@ZTAB@(ZFN),"^",2)
    202 ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    203         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    204         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    205         I '$D(ZTAB) S ZTAB="C0CA"
    206         Q $P(@ZTAB@(ZFN),"^",3)
    207         ;
     1C0CDIC   ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "This is the CCR Dictionary Utility Library ",!
     21 W !
     22 Q
     23 ;
     24DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE
     25 ;
     26 N ZI
     27 S ZI=""
     28 S G1=$NA(^TMP($J,"C0CCSV",1))
     29 S G1A=$NA(@G1@("V"))
     30 S G2=$NA(^TMP($J,"C0CCSV",2))
     31 D GETN2^C0CRNF(G1,170) ; GET THE MATRIX
     32 F  S ZI=$O(@G1A@(ZI)) Q:ZI=""  D  ;FOR EACH ROW IN THE MATRIX
     33 . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D  ;
     34 . . W @G1A@(ZI,"MAPPING METHOD",1),!
     35 . . ;K @G1A@(ZI,"MAPPING METHOD")
     36 . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1))
     37 D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE
     38 K @G1
     39 D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv")
     40 K @G2
     41 Q
     42 ;
     43GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template
     44 ; and return them in C0CVARS, which is passed by name
     45 ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE
     46 ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE
     47 ; C0CT IS RETURNED AS THE CCR TEMPLATE
     48 N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS
     49 D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE
     50 D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS
     51 N C0CI,C0CX
     52 S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT
     53 F C0CI=1:1:C0CTVARS(0) D  ; FOR EVERY LINE IN THE ARRAY
     54 . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL
     55 . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER
     56 ;D PARY^GPLXPATH("C0CVARS")
     57 Q
     58 ;
     59GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES
     60 ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS
     61 ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE
     62 ; BOTH ARE PASSED BY NAME
     63 ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM
     64 ; C0CPVARS(0) IS NUMBER OF VARIABLES
     65 ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE
     66 D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS
     67 ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER
     68 D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS
     69 ; NOW GO GET THE XPATH INDEXES
     70 D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY
     71 S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS
     72 F  S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI=""  D  ; VISIT EVERY LINE
     73 . I +C0CI'=0 Q  ; SKIP EVERYTHING BUT THE XPATH INDEX
     74 . I C0CI=0 Q  ; SKIP THE ZERO NODE
     75 . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y
     76 . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER
     77 . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER
     78 . I C0CY=C0CZ D  ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE)
     79 . . ; W "FOUND ",C0CI,!
     80 . . I $D(C0CTVARS(C0CY)) D  ; IF THERE IS A VARIABLE THERE
     81 . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR
     82 D SORTV ; SORT THE ARRAY BY LINE NUMBER
     83 Q
     84 ;
     85HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH
     86 ;N C0CI,C0CTVARS,C0CX,C0CY
     87 F C0CI=1:1:@C0CPVARS@(0) D  ; FOR THE ENTIRE ARRAY
     88 . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER
     89 . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME
     90 . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER
     91 Q
     92 ;
     93SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER
     94 ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY
     95 S C0CI="" ;
     96 F  S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI=""  D  ; BY LINE NUMBER
     97 . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME
     98 . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE
     99 . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY
     100 K @C0CPVARS
     101 M @C0CPVARS=C0C2
     102 Q
     103 ;
     104LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170
     105 ; INITIAL LOAD OF THE CCR DICTIONARY
     106 ;
     107 N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI
     108 S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY
     109 D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY
     110 ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD
     111 D PARY^GPLXPATH("C0CARY") ;TEST
     112 F C0CI=1:1:C0CARY(0) D  ; LOAD EACH VARIABLE
     113 . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME
     114 . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH
     115 . D UPDATE^DIE("","C0CFDA")
     116 . I $D(^TMP("DIERR",$J)) U $P BREAK
     117 . W "LOADING:",C0CI," ",C0CARY(C0CI),!
     118 Q
     119 ;
     120INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES
     121 ;
     122 ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx,
     123 ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY
     124 ;G1("CODING")="170^8"
     125 ;G1("DATA ELEMENT")="170^7"
     126 ;G1("DESCRIPTION")="170^3"
     127 ;G1("ID")="170^1"
     128 ;G1("M","170^8","CODING")="170.08^.01"
     129 ;G1("MAPPING METHOD")="170.08^1"
     130 ;G1("SECTION")="170^10"
     131 ;G1("SOURCE")="170^4"
     132 ;G1("STATUS")="170^9"
     133 ;G1("TYPE")="170^6"
     134 ;G1("VARIABLE")="170^.01"
     135 ;G1("XPATH")="170^2"
     136 ;
     137 N C0CZA,C0CZX,C0CN,C0CSTAT
     138 S C0CZX=0
     139 S C0CSTAT=0 ; INIT STATUS SET FLAG
     140 F  S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0  D  ; FOR EACH DICT ENTRY
     141 . ;W C0CZX,!
     142 . K C0CA,C0CN ; CLEAR OUT THE LAST ONE
     143 . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH
     144 . ;ZWR C0CA B ;
     145 . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE
     146 . W "VARIABLE: ",C0CN,!
     147 . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ;
     148 . I $E(C0CN,1,6)="SOCIAL" D  ;
     149 . . D SETFDA("SECTION","SOC") ;
     150 . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED
     151 . . S C0CSTAT=1
     152 . I $E(C0CN,1,6)="FAMILY" D  ;
     153 . . D SETFDA("SECTION","FAM") ;
     154 . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED
     155 . . S C0CSTAT=1
     156 . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS
     157 . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS")
     158 . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS")
     159 . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS")
     160 . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST")
     161 . E  I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS")
     162 . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES
     163 . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION
     164 . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM
     165 . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N
     166 . I $$ZVALUE("XPATH")["/Medication/Directions/" D  ; MEDS DIRECTIONS VAR
     167 . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS
     168 . E  I $$ZVALUE("XPATH")["/Medications/Medication/" D  ; ALL OTHER MEDS
     169 . . D SETFDA("SECTION","MEDS") ; A MEDS VAR
     170 . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS
     171 . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE
     172 . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),!
     173 . ;ZWR C0CFDA
     174 . I $D(C0CFDA) D  ; WE HAVE CHANGES ON THIS VARIABLE
     175 . . ;ZWR C0CFDA
     176 . . D UPDATE^DIE("","C0CFDA(C0CZX)")
     177 . . I $D(^TMP("DIERR",$J)) U $P BREAK
     178 . . D CLEAN^DILF ; CLEAN UP
     179 . ;ZWR C0CFDA
     180 Q
     181 ;
     182SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     183 ; TO SET TO VALUE C0CSV.
     184 ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     185 ; C0CSN,C0CSV ARE PASSED BY VALUE
     186 ;
     187 N C0CSI,C0CSJ
     188 S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER
     189 S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER
     190 S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV
     191 Q
     192ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     193 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     194 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     195 I '$D(ZTAB) S ZTAB="C0CA"
     196 Q $P(@ZTAB@(ZFN),"^",1)
     197ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     198 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     199 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     200 I '$D(ZTAB) S ZTAB="C0CA"
     201 Q $P(@ZTAB@(ZFN),"^",2)
     202ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     203 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     204 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     205 I '$D(ZTAB) S ZTAB="C0CA"
     206 Q $P(@ZTAB@(ZFN),"^",3)
     207 ;

  • ccr/branches/ohum/p/C0CDOM.m

    r1330 r1332  
    11C0CDOM    ; GPL - DOM PROCESSING ROUTINES ;6/6/11  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
     2 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     3 ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
    2222DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
    23         ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    24         ; THE XPATH ARRAY XPARY, PASSED BY NAME
    25         ; ZOID IS THE STARTING OID
    26         ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    27         ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    28         ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    29         I $G(ZREDUX)="" S ZREDUX=""
    30         N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
    31         N NEWNUM S NEWNUM=""
    32         I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    33         S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    34         I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    35         . N GT S GT=$P(NEWPATH,ZREDUX,2)
    36         . I GT'="" S NEWPATH=GT
    37         S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    38         N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
    39         I $D(GA) D  ; PROCESS THE ATTRIBUTES
    40         . N ZI S ZI=""
    41         . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
    42         . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE
    43         . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
    44         . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
    45         N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    46         I $D(GD(2)) D  ;
    47         . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    48         E  I $D(GD(1)) D  ;
    49         . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    50         . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
    51         N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    52         I ZFRST'=0 D  ; THERE IS A CHILD
    53         . N ZNUM
    54         . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    55         . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
    56         N GNXT S GNXT=$$NXTSIB(ZOID)
    57         I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
    58         I GNXT'=0 D  ;
    59         . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
    60         . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
    61         . . N ZNUM S ZNUM=1 ;
    62         . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
    63         . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
    64         Q
    65         ;
    66 ADDNARY(ZXP,ZVALUE)     ; ADD AN NHIN ARRAY VALUE TO ZNARY
    67         ;
    68         ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES
    69         ;
    70         N ZZI,ZZJ,ZZN
    71         S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
    72         I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
    73         S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
    74         S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
    75         I ZZI'["]" D  ; A SINGLETON
    76         . S ZZN=1
    77         E  D  ; THERE IS AN [x] OCCURANCE
    78         . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
    79         . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
    80         I ZZJ'="" D  ; TIME TO ADD THE VALUE
    81         . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
    82         Q
    83         ;
     23 ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     24 ; THE XPATH ARRAY XPARY, PASSED BY NAME
     25 ; ZOID IS THE STARTING OID
     26 ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     27 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     28 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     29 I $G(ZREDUX)="" S ZREDUX=""
     30 N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
     31 N NEWNUM S NEWNUM=""
     32 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     33 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     34 I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     35 . N GT S GT=$P(NEWPATH,ZREDUX,2)
     36 . I GT'="" S NEWPATH=GT
     37 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     38 N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
     39 I $D(GA) D  ; PROCESS THE ATTRIBUTES
     40 . N ZI S ZI=""
     41 . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
     42 . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE
     43 . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
     44 . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
     45 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     46 I $D(GD(2)) D  ;
     47 . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     48 E  I $D(GD(1)) D  ;
     49 . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     50 . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
     51 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     52 I ZFRST'=0 D  ; THERE IS A CHILD
     53 . N ZNUM
     54 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     55 . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
     56 N GNXT S GNXT=$$NXTSIB(ZOID)
     57 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
     58 I GNXT'=0 D  ;
     59 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
     60 . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
     61 . . N ZNUM S ZNUM=1 ;
     62 . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
     63 . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
     64 Q
     65 ;
     66ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY
     67 ;
     68 ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES
     69 ;
     70 N ZZI,ZZJ,ZZN
     71 S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
     72 I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
     73 S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
     74 S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
     75 I ZZI'["]" D  ; A SINGLETON
     76 . S ZZN=1
     77 E  D  ; THERE IS AN [x] OCCURANCE
     78 . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
     79 . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
     80 I ZZJ'="" D  ; TIME TO ADD THE VALUE
     81 . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
     82 Q
     83 ;
    8484PARSE(INXML,INDOC)      ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
    85         ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
    86         ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
    87         ;Q $$EN^MXMLDOM(INXML)
    88         Q $$EN^MXMLDOM(INXML,"W")
    89         ;
     85 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
     86 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
     87 ;Q $$EN^MXMLDOM(INXML)
     88 Q $$EN^MXMLDOM(INXML,"W")
     89 ;
    9090ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    91         N ZN
    92         ;I $$TAG(ZOID)["entry" B
    93         S ZN=$$NXTSIB(ZOID)
    94         I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    95         Q 0
    96         ;
     91 N ZN
     92 ;I $$TAG(ZOID)["entry" B
     93 S ZN=$$NXTSIB(ZOID)
     94 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     95 Q 0
     96 ;
    9797FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    98         Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
    99         ;
     98 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
     99 ;
    100100PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
    101         Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
    102         ;
     101 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
     102 ;
    103103ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
    104         S HANDLE=C0CDOCID
    105         K @RTN
    106         D GETTXT^MXMLDOM("A")
    107         Q
    108         ;
     104 S HANDLE=C0CDOCID
     105 K @RTN
     106 D GETTXT^MXMLDOM("A")
     107 Q
     108 ;
    109109TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
    110         ;I ZOID=149 B ;GPLTEST
    111         N X,Y
    112         S Y=""
    113         S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    114         I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    115         I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
    116         Q Y
    117         ;
     110 ;I ZOID=149 B ;GPLTEST
     111 N X,Y
     112 S Y=""
     113 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     114 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     115 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
     116 Q Y
     117 ;
    118118NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
    119         Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
    120         ;
     119 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
     120 ;
    121121DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
    122         ;N ZT,ZN S ZT=""
    123         ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    124         ;Q $G(@C0CDOM@(ZOID,"T",1))
    125         S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
    126         Q
    127         ;
     122 ;N ZT,ZN S ZT=""
     123 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     124 ;Q $G(@C0CDOM@(ZOID,"T",1))
     125 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
     126 Q
     127 ;
    128128OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
    129         ;
    130         S C0CDOCID=INID
    131         I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation
    132         D START^C0CMXMLB($$TAG(1),,"G",NO1ST)
    133         D NDOUT($$FIRST(1))
    134         D END^C0CMXMLB ;END THE DOCUMENT
    135         M @ZRTN=^TMP("MXMLBLD",$J)
    136         K ^TMP("MXMLBLD",$J)
    137         Q
    138         ;
     129 ;
     130 S C0CDOCID=INID
     131 I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation
     132 D START^C0CMXMLB($$TAG(1),,"G",NO1ST)
     133 D NDOUT($$FIRST(1))
     134 D END^C0CMXMLB ;END THE DOCUMENT
     135 M @ZRTN=^TMP("MXMLBLD",$J)
     136 K ^TMP("MXMLBLD",$J)
     137 Q
     138 ;
    139139NDOUT(ZOID)     ;CALLBACK ROUTINE - IT IS RECURSIVE
    140         N ZI S ZI=$$FIRST(ZOID)
    141         I ZI'=0 D  ; THERE IS A CHILD
    142         . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
    143         . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
    144         E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
    145         . ;W "DOING",ZOID,!
    146         . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
    147         . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
    148         . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
    149         I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
    150         . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
    151         Q
    152         ;
    153 WNHIN(ZDFN)     ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
    154         ;
    155         N GN,GN2
    156         D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
    157         S GN2=$NA(@GN@(1))
    158         W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
    159         Q
    160         ;
    161 NARY2XML(ZGOUT,ZGIN)    ; CREATE XML FROM AN NHIN ARRAY
    162         ; ZGOUT AND ZGIN ARE PASSED BY NAME
    163         N C0CDOCID
    164         W !,ZGOUT," ",ZGIN
    165         S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM
    166         D OUTXML(ZGOUT,C0CDOCID)
    167         Q
    168         ;
    169         ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN
    170         ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA)
    171         ;
    172         ;GNARY("med",1,"doses.dose@dose")=10
    173         ;GNARY("med",1,"doses.dose@noun")="TABLET"
    174         ;GNARY("med",1,"doses.dose@route")="PO"
    175         ;GNARY("med",1,"doses.dose@schedule")="QD"
    176         ;GNARY("med",1,"doses.dose@units")="MG"
    177         ;GNARY("med",1,"doses.dose@unitsPerDose")=1
    178         ;GNARY("med",1,"facility@code")=100
    179         ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION"
    180         ;GNARY("med",1,"form@value")="TAB"
    181         ;GNARY("med",1,"id@value")="1N;O"
    182         ;GNARY("med",1,"location@code")=5
    183         ;GNARY("med",1,"location@name")="3 WEST"
    184         ;GNARY("med",1,"name@value")="LISINOPRIL TAB"
    185         ;GNARY("med",1,"orderID@value")=294
    186         ;GNARY("med",1,"ordered@value")=3110531.001233
    187         ;GNARY("med",1,"orderingProvider@code")=63
    188         ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL"
    189         ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS"
    190         ;GNARY("med",1,"products.product.vaGeneric@code")=1990
    191         ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL"
    192         ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380
    193         ;GNARY("med",1,"products.product.vaProduct@code")=8118
    194         ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB"
    195         ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593
    196         ;GNARY("med",1,"products.product@code")=6174
    197         ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D"
    198         ;GNARY("med",1,"products.product@role")="D"
    199         ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY"
    200         ;GNARY("med",1,"sig@xml:space")="preserve"
    201         ;GNARY("med",1,"status@value")="active"
    202         ;GNARY("med",1,"type@value")="OTC"
    203         ;GNARY("med",1,"vaType@value")="N"
    204         ;
    205         ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM
    206         ; it returns 0 or 1 based on success.
    207         ;
    208         ; INARY is passed by name and has the format shown above
    209         ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will
    210         ; be supported eventually - initial implementation is for MXML
    211         ;
    212         ; PARENT is the node id or tag of the parent under which the DOM will
    213         ; be populated. If it is numeric, it is a node. If it is a string, the DOM
    214         ; will be searched to find the tag. If not found and there is no root,
    215         ; it will be inserted as the root. If not found and there is a root, it
    216         ; will be inserted under the root.
    217         ;
    218         ; For the above example the call would be OK=$$DOMI("GNARY",0,"results")
    219         ; because "results" is the root tag. Use OUTXML to render the xml from
    220         ; the DOM.
    221         ;
    222 DOMI(INARY,HANDLE,PARENT)       ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
    223         ;
    224         N ZPARNODE
    225         S (SUCCESS,LEVEL,LEVEL(0),NODE)=0
    226         I '$D(INARY) Q 0 ; NO ARRAY PASSED
    227         I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM
    228         ;I PARENT="" S PARENT="root"
    229         I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID
    230         E  I $L($G(PARENT))>0 D  ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
    231         . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE
    232         . S ZPARNODE=1 ;
    233         ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET
    234         N ZEXARY
    235         D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY
    236         D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED
    237         I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
    238         Q HANDLE ; SUCCESS
    239         ;
    240 MAJOR(ZARY)     ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
    241         N ZI S ZI=""
    242         N ZTAG
    243         F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH SECTION
    244         . N ZELEADD S ZELEADD=0
    245         . I ZI["@" D  ; END NODE HAS NO VALUE, ONLY ATTRIBUTES
    246         . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG
    247         . . K ZATT ; CLEAR OUT LAST ONE
    248         . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY
    249         . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE
    250         . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE
    251         . I $O(@ZARY@(ZI,""))="" D  ;END NODE
    252         . . S ZTAG=ZI ; USE ZI FOR THE TAG
    253         . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE
    254         . . S ZELEADD=1 ; ADDED AN ELEMENT
    255         . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE
    256         . I ZELEADD D  Q  ; NO MORE TO DO ON THIS LEVEL
    257         . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING
    258         . N NEWARY ; INDENTED ARRAY
    259         . N ZN S ZN=0
    260         . F  S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN=""  D  ; FOR EACH MULTIPLE
    261         . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG
    262         . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY
    263         . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY
    264         . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG
    265         Q
    266         ;
    267 EXPAND(ZZOUT,ZZIN)      ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED
    268         ; CONSISTENT FORMAT
    269         ; GNARY("patient",1,"facilities[2].facility@code")="050"
    270         ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050"
    271         ; for easier processing (this is fileman format genius)
    272         ; basically removes the dot notation from the strings
    273         ;
    274         N ZZI
    275         S ZZI=""
    276         F  S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI=""  D  ;
    277         . N ZZN S ZZN=0
    278         . F  S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN=""  D  ;
    279         . . N ZZS S ZZS=""
    280         . . N GA ;PUSH STACK
    281         . . F  S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS=""  D  ;
    282         . . . K GA ; NEW STACK
    283         . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT
    284         . . . N ZZV ; PLACE TO STASH THE VALUE
    285         . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE
    286         . . . W !,"VALUE:",ZZV
    287         . . . N GK ; COUNTER
    288         . . . F GK=1:1:$L(ZZS,".") D  ; FOR EACH INTERMEDIATE NODE
    289         . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X]
    290         . . . . N GM S GM=$P(ZZS,".",GK) ; TAG
    291         . . . . I GM["[" D  ; IT'S A MULTIPLE
    292         . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER
    293         . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG
    294         . . . . I GM["@" D  ; IT'S GOT ATTRIBUTES
    295         . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME
    296         . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG
    297         . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2)
    298         . . . . E  D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ;
    299         . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1"
    300         . . . N GZI S GZI="" ; STRING FOR THE INDEX
    301         . . . F GK=1:1:GA(0) D  ; TIME TO REVERSE POP THE TAGS
    302         . . . . S GM=$P(GA(GK),"^",1) ; THE TAG
    303         . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY
    304         . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE
    305         . . . . E  S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST
    306         . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME
    307         . . . W !,GZI
    308         . . . S @GZI2=ZZV ; REMEMBER THE VALUE?
    309         Q
    310         ;
    311 NEWDOM()        ; extrinsic which creates a new DOM and returns the HANDLE
    312         N CBK,SUCCESS,LEVEL,NODE,HANDLE
    313         K ^TMP("MXMLERR",$J)
    314         L +^TMP("MXMLDOM",$J):5
    315         E  Q 0
    316         S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
    317         L -^TMP("MXMLDOM",$J)
    318         Q HANDLE
    319         ;
     140 N ZI S ZI=$$FIRST(ZOID)
     141 I ZI'=0 D  ; THERE IS A CHILD
     142 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
     143 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
     144 E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
     145 . ;W "DOING",ZOID,!
     146 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
     147 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
     148 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
     149 I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
     150 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
     151 Q
     152 ;
     153WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
     154 ;
     155 N GN,GN2
     156 D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
     157 S GN2=$NA(@GN@(1))
     158 W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
     159 Q
     160 ;
     161NARY2XML(ZGOUT,ZGIN) ; CREATE XML FROM AN NHIN ARRAY
     162 ; ZGOUT AND ZGIN ARE PASSED BY NAME
     163 N C0CDOCID
     164 W !,ZGOUT," ",ZGIN
     165 S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM
     166 D OUTXML(ZGOUT,C0CDOCID)
     167 Q
     168 ;
     169 ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN
     170 ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA)
     171 ;
     172 ;GNARY("med",1,"doses.dose@dose")=10
     173 ;GNARY("med",1,"doses.dose@noun")="TABLET"
     174 ;GNARY("med",1,"doses.dose@route")="PO"
     175 ;GNARY("med",1,"doses.dose@schedule")="QD"
     176 ;GNARY("med",1,"doses.dose@units")="MG"
     177 ;GNARY("med",1,"doses.dose@unitsPerDose")=1
     178 ;GNARY("med",1,"facility@code")=100
     179 ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION"
     180 ;GNARY("med",1,"form@value")="TAB"
     181 ;GNARY("med",1,"id@value")="1N;O"
     182 ;GNARY("med",1,"location@code")=5
     183 ;GNARY("med",1,"location@name")="3 WEST"
     184 ;GNARY("med",1,"name@value")="LISINOPRIL TAB"
     185 ;GNARY("med",1,"orderID@value")=294
     186 ;GNARY("med",1,"ordered@value")=3110531.001233
     187 ;GNARY("med",1,"orderingProvider@code")=63
     188 ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL"
     189 ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS"
     190 ;GNARY("med",1,"products.product.vaGeneric@code")=1990
     191 ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL"
     192 ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380
     193 ;GNARY("med",1,"products.product.vaProduct@code")=8118
     194 ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB"
     195 ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593
     196 ;GNARY("med",1,"products.product@code")=6174
     197 ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D"
     198 ;GNARY("med",1,"products.product@role")="D"
     199 ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY"
     200 ;GNARY("med",1,"sig@xml:space")="preserve"
     201 ;GNARY("med",1,"status@value")="active"
     202 ;GNARY("med",1,"type@value")="OTC"
     203 ;GNARY("med",1,"vaType@value")="N"
     204 ;
     205 ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM
     206 ; it returns 0 or 1 based on success.
     207 ;
     208 ; INARY is passed by name and has the format shown above
     209 ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will
     210 ; be supported eventually - initial implementation is for MXML
     211 ;
     212 ; PARENT is the node id or tag of the parent under which the DOM will
     213 ; be populated. If it is numeric, it is a node. If it is a string, the DOM
     214 ; will be searched to find the tag. If not found and there is no root,
     215 ; it will be inserted as the root. If not found and there is a root, it
     216 ; will be inserted under the root.
     217 ;
     218 ; For the above example the call would be OK=$$DOMI("GNARY",0,"results")
     219 ; because "results" is the root tag. Use OUTXML to render the xml from
     220 ; the DOM.
     221 ;
     222DOMI(INARY,HANDLE,PARENT) ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
     223 ;
     224 N ZPARNODE
     225 S (SUCCESS,LEVEL,LEVEL(0),NODE)=0
     226 I '$D(INARY) Q 0 ; NO ARRAY PASSED
     227 I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM
     228 ;I PARENT="" S PARENT="root"
     229 I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID
     230 E  I $L($G(PARENT))>0 D  ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
     231 . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE
     232 . S ZPARNODE=1 ;
     233 ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET
     234 N ZEXARY
     235 D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY
     236 D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED
     237 I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
     238 Q HANDLE ; SUCCESS
     239 ;
     240MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
     241 N ZI S ZI=""
     242 N ZTAG
     243 F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH SECTION
     244 . N ZELEADD S ZELEADD=0
     245 . I ZI["@" D  ; END NODE HAS NO VALUE, ONLY ATTRIBUTES
     246 . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG
     247 . . K ZATT ; CLEAR OUT LAST ONE
     248 . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY
     249 . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE
     250 . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE
     251 . I $O(@ZARY@(ZI,""))="" D  ;END NODE
     252 . . S ZTAG=ZI ; USE ZI FOR THE TAG
     253 . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE
     254 . . S ZELEADD=1 ; ADDED AN ELEMENT
     255 . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE
     256 . I ZELEADD D  Q  ; NO MORE TO DO ON THIS LEVEL
     257 . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING
     258 . N NEWARY ; INDENTED ARRAY
     259 . N ZN S ZN=0
     260 . F  S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN=""  D  ; FOR EACH MULTIPLE
     261 . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG
     262 . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY
     263 . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY
     264 . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG
     265 Q
     266 ;
     267EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED
     268 ; CONSISTENT FORMAT
     269 ; GNARY("patient",1,"facilities[2].facility@code")="050"
     270 ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050"
     271 ; for easier processing (this is fileman format genius)
     272 ; basically removes the dot notation from the strings
     273 ;
     274 N ZZI
     275 S ZZI=""
     276 F  S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI=""  D  ;
     277 . N ZZN S ZZN=0
     278 . F  S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN=""  D  ;
     279 . . N ZZS S ZZS=""
     280 . . N GA ;PUSH STACK
     281 . . F  S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS=""  D  ;
     282 . . . K GA ; NEW STACK
     283 . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT
     284 . . . N ZZV ; PLACE TO STASH THE VALUE
     285 . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE
     286 . . . W !,"VALUE:",ZZV
     287 . . . N GK ; COUNTER
     288 . . . F GK=1:1:$L(ZZS,".") D  ; FOR EACH INTERMEDIATE NODE
     289 . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X]
     290 . . . . N GM S GM=$P(ZZS,".",GK) ; TAG
     291 . . . . I GM["[" D  ; IT'S A MULTIPLE
     292 . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER
     293 . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG
     294 . . . . I GM["@" D  ; IT'S GOT ATTRIBUTES
     295 . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME
     296 . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG
     297 . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2)
     298 . . . . E  D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ;
     299 . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1"
     300 . . . N GZI S GZI="" ; STRING FOR THE INDEX
     301 . . . F GK=1:1:GA(0) D  ; TIME TO REVERSE POP THE TAGS
     302 . . . . S GM=$P(GA(GK),"^",1) ; THE TAG
     303 . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY
     304 . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE
     305 . . . . E  S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST
     306 . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME
     307 . . . W !,GZI
     308 . . . S @GZI2=ZZV ; REMEMBER THE VALUE?
     309 Q
     310 ;
     311NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE
     312 N CBK,SUCCESS,LEVEL,NODE,HANDLE
     313 K ^TMP("MXMLERR",$J)
     314 L +^TMP("MXMLDOM",$J):5
     315 E  Q 0
     316 S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
     317 L -^TMP("MXMLDOM",$J)
     318 Q HANDLE
     319 ;

  • ccr/branches/ohum/p/C0CDPT.m

    r1330 r1332  
    11C0CDPT  ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;
    44        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU

  • ccr/branches/ohum/p/C0CENC.m

    r1330 r1332  
    11C0CENC   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
    2         ;;1.0;C0C;;May 21, 2010;Build 1
     2        ;;1.0;C0C;;May 21, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CENV.m

    r1330 r1332  
    1 C0CENV  ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     1C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
     2 ;;1.0;C0C;;May 19, 2009;
     3 ;
     4 ;
     5ENV ; Does not prevent loading of the transport global.
     6 ; Environment check is done only during the install.
     7 ;
     8 N XQA,XQAMSG
     9 ;
     10 ;
     11 ; Make sure the patch name exist
     12 ;
     13 I '$D(XPDNM) D  Q
     14 . D BMES("No valid patch name exist")
     15 . S XPDQUIT=2
     16 . D EXIT
     17 ;
     18 D CHECK
     19 D EXIT
     20 Q
     21 ;
     22 ;
     23CHECK ; Perform environment check
    324        ;
    4         ;
    5 ENV     ; Does not prevent loading of the transport global.
    6         ; Environment check is done only during the install.
    7         ;
    8         N XQA,XQAMSG
    9         ;
    10         ;
    11         ; Make sure the patch name exist
    12         ;
    13         I '$D(XPDNM) D  Q
    14         . D BMES("No valid patch name exist")
    15         . S XPDQUIT=2
    16         . D EXIT
    17         ;
    18         D CHECK
    19         D EXIT
     25 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
     26 . D BMES("Terminal Device is not defined")
     27 . S XPDQUIT=2
     28 ;
     29 I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
     30 . D BMES("Please log in to set local DUZ... variables")
     31 . S XPDQUIT=2
     32 ;
     33 I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
     34 . D BMES("You are not a valid user on this system")
     35 . S XPDQUIT=2
    2036        Q
    2137        ;
    2238        ;
    23 CHECK   ; Perform environment check
    24         ;
    25         I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
    26         . D BMES("Terminal Device is not defined")
    27         . S XPDQUIT=2
    28         ;
    29         I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
    30         . D BMES("Please log in to set local DUZ... variables")
    31         . S XPDQUIT=2
    32         ;
    33         I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
    34         . D BMES("You are not a valid user on this system")
    35         . S XPDQUIT=2
    36         Q
     39EXIT ;
    3740        ;
    3841        ;
    39 EXIT    ;
     42 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
     43 D BMES("--- Environment Check is Ok ---")
     44        ;
     45 Q
    4046        ;
    4147        ;
    42         I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
    43         D BMES("--- Environment Check is Ok ---")
    44         ;
    45         Q
    46         ;
    47         ;
    48 PRE     ;Pre-install entry point
     48PRE ;Pre-install entry point
    4949        ;
    5050        ; No action needed in pre-install
    … …  
    5454        ;
    5555        ;
    56 POST    ;Post install
     56POST ;Post install
    5757        ;
    5858        ; Check for RPMS system with V LAB file.
    … …  
    131131        ;
    132132        ;
    133 POST6   ; Checkpoint call back entry point.
     133POST6 ; Checkpoint call back entry point.
    134134        ; Check for RPMS system and determine LAB patch level
    135135        ;  and need to load in C0C version of LA7 routines.
    … …  
    174174        ;
    175175        ;
    176 BMES(STR)       ; Write BMES^XPDUTL statements
     176BMES(STR) ; Write BMES^XPDUTL statements
    177177        ;
    178178        D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))

  • ccr/branches/ohum/p/C0CEVC.m

    r1330 r1332  
    11C0CEVC    ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010
    2         ;;1.0;C0C;;Mar 1, 2010;Build 1
    3 gpltest2        ; experiment with sending a CCR to an ewd page
    4         N ZI
    5         S ZI=""
    6         D PSEUDO
    7         N ZIO
    8         S ZIO=IO
    9         S IO="/dev/null"
    10         OPEN IO
    11         U IO
    12         N G
    13         S G=$$URLTOKEN^C0CEWD
    14         D CCRRPC^C0CCCR(.GPL,2)
    15         S IO=ZIO
    16         OPEN IO
    17         U IO
    18         K GPL(0)
    19         F  S ZI=$O(GPL(ZI)) Q:ZI=""  W GPL(ZI),!
    20         Q
    21         ;
    22 gpltest ; experiment with sending a CCR to an ewd page
    23         N ZI
    24         S ZI=""
    25         K ^GPL(0)
    26         S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
    27         F  S ZI=$O(^GPL(ZI)) Q:ZI=""  W ^GPL(ZI),!
    28         Q
    29         ;
    30 TEST(sessid);   
    31         d setSessionValue^%zewdAPI("person.Name","Rob",sessid)
    32         d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid)
    33         d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid)
    34         d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid)
    35         d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid)
    36         d setJSONValue^%zewdAPI("json","person",sessid)
    37         Q ""
    38        
    39 PARSE(INXML,INDOC)      ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
    40         ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
    41         ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
    42         N ZR
    43         M ^CacheTempEWD($j)=@INXML ;
    44         S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
    45         Q ZR
    46         ;
    47 TEST2(sessid)   ; try to put a ccr in the session
    48         S U="^"
    49         D PSEUDO ; FAKE LOGIN
    50         S ZIO=$IO
    51         S DEV="/dev/null"
    52         O DEV U DEV
    53         N G
    54         N ZDFN
    55         S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid)
    56         I ZDFN="" S ZDFN=2
    57         ;K ^TMP("GPL")
    58         ;M ^TMP("GPL")=^%zewdSession("session",sessid)
    59         D CCRRPC^C0CCCR(.GPL,ZDFN)
    60         K GPL(0)   
    61         S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
    62         C DEV U ZIO
    63         ;M ^CacheTempEWD($j)=GPL
    64         S DOCNAME="CCR"
    65         ;ZWR GPL
    66         ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME)
    67         ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid)
    68         d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid)
    69         Q ""
    70         ;
    71 INITSES(sessid) ;initialize an EWD/CPRS session
    72         K ^TMP("GPL")
    73         ;M ^TMP("GPL")=^%zewdSession("session",sessid)
    74         N ZT,ZDFN
    75         S ZT=$$URLTOKEN^C0CEWD(sessid)
    76         ;S ^TMP("GPL")=ZT
    77         d trace^%zewdAPI("*********************ZT="_ZT)
    78         S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
    79         S ^TMP("GPL","DFN")=ZDFN
    80         I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT
    81         D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid)
    82         ;M ^TMP("GPL","request")=requestArray
    83         ;D PSEUDO
    84         ;D ^%ZTER
    85         q ""
    86         ;
    87 PRSEORTK(ZTOKEN)        ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN
    88         ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE:
    89         ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6)
    90         N ZX,ZN1,ZIP,ZN2,ZDFN,ZG
    91         S ZDFN=0 ; DEFAULT RETURN
    92         S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER
    93         S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER
    94         S ZIP=$P(ZIP,"'",2) ; GET RID OF '
    95         S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER
    96         S ZN2=$P(ZN2,")",1) ; GET RID OF )
    97         S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME
    98         I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL
    99         S ^TMP("GPL","FIRSTDFN")=ZDFN
    100         S ^TMP("GPL","FIRSTGLB")=ZG
    101         Q ZDFN
    102         ;
    103 GETPATIENTLIST(sessid)  ;
    104         D PSEUDO
    105         D LISTALL^ORWPT(.RTN,"NAME","1")
    106         N ZI
    107         S ZI=""
    108         F  S ZI=$O(RTN(ZI)) Q:ZI=""  D  ;
    109         . S data(ZI,"DFN")=$P(RTN(ZI),"^",1)
    110         . S data(ZI,"Name")=$P(RTN(ZI),"^",2)
    111         ; ZWR data
    112         ;S data(1,"DFN")=$P(RTN(1),"^",1)
    113         ;S data(1,"Name")=$P(RTN(1),"^",2)
    114         d deleteFromSession^%zewdAPI("patients",sessid)
    115         d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid)
    116         ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid)
    117         Q ""
    118         ;
    119 PSEUDO 
    120         S U="^"
    121         S DILOCKTM=3
    122         S DISYS=19
    123         S DT=3100219
    124         S DTIME=999
    125         S DUZ=10
    126         S DUZ(0)="@"
    127         S DUZ(1)=""
    128         S DUZ(2)=1
    129         S DUZ("AG")="V"
    130         S DUZ("BUF")=1
    131         S DUZ("LANG")=""
    132         ;S IO="/dev/pts/2"
    133         ;S IO(0)="/dev/pts/2"
    134         ;S IO(1,"/dev/pts/2")=""
    135         ;S IO("ERROR")=""
    136         ;S IO("HOME")="41^/dev/pts/2"
    137         ;S IO("ZIO")="/dev/pts/2"
    138         ;S IOBS="$C(8)"
    139         ;S IOF="#,$C(27,91,50,74,27,91,72)"
    140         ;S SIOM=80
    141         Q
    142         ;
    143 PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
    144         S DILOCKTM=3
    145         S DISYS=19
    146         S DT=3100112
    147         S DTIME=9999
    148         S DUZ=10000000020
    149         S DUZ(0)="@"
    150         S DUZ(1)=""
    151         S DUZ(2)=67
    152         S DUZ("AG")="E"
    153         S DUZ("BUF")=1
    154         S DUZ("LANG")=1
    155         S IO="/dev/pts/0"
    156         ;S IO(0)="/dev/pts/0"
    157         ;S IO(1,"/dev/pts/0")=""
    158         ;S IO("ERROR")=""
    159         ;S IO("HOME")="50^/dev/pts/0"
    160         ;S IO("ZIO")="/dev/pts/0"
    161         ;S IOBS="$C(8)"
    162         ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
    163         ;S IOM=80
    164         ;S ION="GTM/UNIX TELNET"
    165         ;S IOS=50
    166         ;S IOSL=24
    167         ;S IOST="C-VT100"
    168         ;S IOST(0)=9
    169         ;S IOT="VTRM"
    170         ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
    171         S U="^"
    172         S X="1;DIC(4.2,"
    173         S XPARSYS="1;DIC(4.2,"
    174         S XQXFLG="^^XUP"
    175         S Y="DEV^VISTA^hollywood^VISTA:hollywood"
    176         Q
    177         ;
     2 ;;1.0;C0C;;Mar 1, 2010;
     3gpltest2 ; experiment with sending a CCR to an ewd page
     4 N ZI
     5 S ZI=""
     6 D PSEUDO
     7 N ZIO
     8 S ZIO=IO
     9 S IO="/dev/null"
     10 OPEN IO
     11 U IO
     12 N G
     13 S G=$$URLTOKEN^C0CEWD
     14 D CCRRPC^C0CCCR(.GPL,2)
     15 S IO=ZIO
     16 OPEN IO
     17 U IO
     18 K GPL(0)
     19 F  S ZI=$O(GPL(ZI)) Q:ZI=""  W GPL(ZI),!
     20 Q
     21 ;
     22gpltest ; experiment with sending a CCR to an ewd page
     23 N ZI
     24 S ZI=""
     25 K ^GPL(0)
     26 S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
     27 F  S ZI=$O(^GPL(ZI)) Q:ZI=""  W ^GPL(ZI),!
     28 Q
     29 ;
     30TEST(sessid); 
     31 d setSessionValue^%zewdAPI("person.Name","Rob",sessid)
     32 d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid)
     33 d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid)
     34 d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid)
     35 d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid)
     36 d setJSONValue^%zewdAPI("json","person",sessid)
     37 Q ""
     38
     39PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
     40 ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
     41 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
     42 N ZR
     43 M ^CacheTempEWD($j)=@INXML ;
     44 S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
     45 Q ZR
     46 ;
     47TEST2(sessid) ; try to put a ccr in the session
     48 S U="^"
     49 D PSEUDO ; FAKE LOGIN
     50 S ZIO=$IO
     51 S DEV="/dev/null"
     52 O DEV U DEV
     53 N G
     54 N ZDFN
     55 S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid)
     56 I ZDFN="" S ZDFN=2
     57 ;K ^TMP("GPL")
     58 ;M ^TMP("GPL")=^%zewdSession("session",sessid)
     59 D CCRRPC^C0CCCR(.GPL,ZDFN)
     60 K GPL(0)   
     61 S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
     62 C DEV U ZIO
     63 ;M ^CacheTempEWD($j)=GPL
     64 S DOCNAME="CCR"
     65 ;ZWR GPL
     66 ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME)
     67 ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid)
     68 d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid)
     69 Q ""
     70 ;
     71INITSES(sessid) ;initialize an EWD/CPRS session
     72 K ^TMP("GPL")
     73 ;M ^TMP("GPL")=^%zewdSession("session",sessid)
     74 N ZT,ZDFN
     75 S ZT=$$URLTOKEN^C0CEWD(sessid)
     76 ;S ^TMP("GPL")=ZT
     77 d trace^%zewdAPI("*********************ZT="_ZT)
     78 S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
     79 S ^TMP("GPL","DFN")=ZDFN
     80 I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT
     81 D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid)
     82 ;M ^TMP("GPL","request")=requestArray
     83 ;D PSEUDO
     84 ;D ^%ZTER
     85 q ""
     86 ;
     87PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN
     88 ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE:
     89 ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6)
     90 N ZX,ZN1,ZIP,ZN2,ZDFN,ZG
     91 S ZDFN=0 ; DEFAULT RETURN
     92 S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER
     93 S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER
     94 S ZIP=$P(ZIP,"'",2) ; GET RID OF '
     95 S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER
     96 S ZN2=$P(ZN2,")",1) ; GET RID OF )
     97 S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME
     98 I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL
     99 S ^TMP("GPL","FIRSTDFN")=ZDFN
     100 S ^TMP("GPL","FIRSTGLB")=ZG
     101 Q ZDFN
     102 ;
     103GETPATIENTLIST(sessid) ;
     104 D PSEUDO
     105 D LISTALL^ORWPT(.RTN,"NAME","1")
     106 N ZI
     107 S ZI=""
     108 F  S ZI=$O(RTN(ZI)) Q:ZI=""  D  ;
     109 . S data(ZI,"DFN")=$P(RTN(ZI),"^",1)
     110 . S data(ZI,"Name")=$P(RTN(ZI),"^",2)
     111 ; ZWR data
     112 ;S data(1,"DFN")=$P(RTN(1),"^",1)
     113 ;S data(1,"Name")=$P(RTN(1),"^",2)
     114 d deleteFromSession^%zewdAPI("patients",sessid)
     115 d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid)
     116 ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid)
     117 Q ""
     118 ;
     119PSEUDO
     120 S U="^"
     121 S DILOCKTM=3
     122 S DISYS=19
     123 S DT=3100219
     124 S DTIME=999
     125 S DUZ=10
     126 S DUZ(0)="@"
     127 S DUZ(1)=""
     128 S DUZ(2)=1
     129 S DUZ("AG")="V"
     130 S DUZ("BUF")=1
     131 S DUZ("LANG")=""
     132 ;S IO="/dev/pts/2"
     133 ;S IO(0)="/dev/pts/2"
     134 ;S IO(1,"/dev/pts/2")=""
     135 ;S IO("ERROR")=""
     136 ;S IO("HOME")="41^/dev/pts/2"
     137 ;S IO("ZIO")="/dev/pts/2"
     138 ;S IOBS="$C(8)"
     139 ;S IOF="#,$C(27,91,50,74,27,91,72)"
     140 ;S SIOM=80
     141 Q
     142 ;
     143PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
     144 S DILOCKTM=3
     145 S DISYS=19
     146 S DT=3100112
     147 S DTIME=9999
     148 S DUZ=10000000020
     149 S DUZ(0)="@"
     150 S DUZ(1)=""
     151 S DUZ(2)=67
     152 S DUZ("AG")="E"
     153 S DUZ("BUF")=1
     154 S DUZ("LANG")=1
     155 S IO="/dev/pts/0"
     156 ;S IO(0)="/dev/pts/0"
     157 ;S IO(1,"/dev/pts/0")=""
     158 ;S IO("ERROR")=""
     159 ;S IO("HOME")="50^/dev/pts/0"
     160 ;S IO("ZIO")="/dev/pts/0"
     161 ;S IOBS="$C(8)"
     162 ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
     163 ;S IOM=80
     164 ;S ION="GTM/UNIX TELNET"
     165 ;S IOS=50
     166 ;S IOSL=24
     167 ;S IOST="C-VT100"
     168 ;S IOST(0)=9
     169 ;S IOT="VTRM"
     170 ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
     171 S U="^"
     172 S X="1;DIC(4.2,"
     173 S XPARSYS="1;DIC(4.2,"
     174 S XQXFLG="^^XUP"
     175 S Y="DEV^VISTA^hollywood^VISTA:hollywood"
     176 Q
     177 ;

  • ccr/branches/ohum/p/C0CEWD.m

    r1330 r1332  
    11C0CEWD    ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
     2        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
    33        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CEWD1.m

    r1330 r1332  
    1 C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 TEST(filepath)  ; filepath IS THE PATH/FILE TO BE READ IN
    23         i $g(^%ZISH)["" d  ; if the VistA Kernal routine %ZISH exists
    24         . n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
    25         . s zfile=$re($p($re(filepath),"/",1)) ;file name
    26         . s zpath=$p(filepath,zfile,1) ; file path
    27         . s ztmp=$na(^CacheTempEWD($j,0))
    28         . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
    29         q
    30         ;
    31 TEST2   ;
    32         s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
    33         ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
    34         s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
    35         s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
    36         ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
    37         w ok,!
    38         q
    39         ;
    40 LOAD(filepath)  ; load an xml file into the EWD global for DOM processing
    41         ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
    42         ; after to process it to the DOM - isHTML=0 for XML files
    43         n i
    44         i $g(^%ZISH)["" d  QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
    45         . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
    46         . s zfile=$re($p($re(filepath),"/",1)) ;file name
    47         . s zpath=$p(filepath,zfile,1) ; file path
    48         . s ztmp=$na(^CacheTempEWD($j,0))
    49         . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
    50         . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
    51         q i
    52         ;
    53 Q(ZQ,ZD)        ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
    54         I '$D(ZD) S ZD="DerekDOM"
    55         s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
    56         d displayNodes^%zewdXPath(.nodes)
    57         q
    58         ;
    59 GET1URL0(URL)   ;
    60         s ok=$$httpGET^%zewdGTM(URL,.gpl)
    61         D INDEX^C0CXPATH("gpl","gpl2")
    62         W !,"S URL=""",URL,"""",!
    63         S G=""
    64         F  S G=$O(gpl2(G)) Q:G=""  D  ;
    65         . W " S VDX(""",G,""")=""",gpl2(G),"""",!
    66         W !
    67         Q
     1C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     22TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN
     23 i $g(^%ZISH)["" d  ; if the VistA Kernal routine %ZISH exists
     24 . n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
     25 . s zfile=$re($p($re(filepath),"/",1)) ;file name
     26 . s zpath=$p(filepath,zfile,1) ; file path
     27 . s ztmp=$na(^CacheTempEWD($j,0))
     28 . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
     29 q
     30 ;
     31TEST2 ;
     32 s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
     33 ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
     34 s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
     35 s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
     36 ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
     37 w ok,!
     38 q
     39 ;
     40LOAD(filepath) ; load an xml file into the EWD global for DOM processing
     41 ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
     42 ; after to process it to the DOM - isHTML=0 for XML files
     43 n i
     44 i $g(^%ZISH)["" d  QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
     45 . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
     46 . s zfile=$re($p($re(filepath),"/",1)) ;file name
     47 . s zpath=$p(filepath,zfile,1) ; file path
     48 . s ztmp=$na(^CacheTempEWD($j,0))
     49 . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
     50 . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
     51 q i
     52 ;
     53Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
     54 I '$D(ZD) S ZD="DerekDOM"
     55 s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
     56 d displayNodes^%zewdXPath(.nodes)
     57 q
     58 ;
     59GET1URL0(URL) ;
     60 s ok=$$httpGET^%zewdGTM(URL,.gpl)
     61 D INDEX^C0CXPATH("gpl","gpl2")
     62 W !,"S URL=""",URL,"""",!
     63 S G=""
     64 F  S G=$O(gpl2(G)) Q:G=""  D  ;
     65 . W " S VDX(""",G,""")=""",gpl2(G),"""",!
     66 W !
     67 Q

  • ccr/branches/ohum/p/C0CFM1.m

    r1330 r1332  
    11C0CFM1    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CFM2.m

    r1330 r1332  
    11C0CFM2    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CFM3.m

    r1330 r1332  
    1 C0CFM3    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR FILEMAN Utility Library ",!
    21         ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
    22         ; CCR ELEMENTS (^C0C(179.201,
    23         ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
    24         ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
    25         ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
    26         ; ALL SUB-VARIABLES HAVE BEEN REMOVED
    27         W !
    28         Q
    29         ;
    30 RIMTBL(ZWHICH)  ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
    31         ; '
    32         I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS
    33         N ZI,ZJ,ZC,ZPATBASE
    34         S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
    35         S ZI=""
    36         F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    37         . S ZI=$O(@ZPATBASE@(ZI))
    38         . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
    39         Q
    40         ;
    41 PUTRIM(DFN,ZWHICH)      ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
    42         ;
    43         S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
    44         I '$D(ZWHICH) S ZWHICH="ALL"
    45         I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
    46         . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
    47         . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
    48         E  D  ; MULTIPLE SECTIONS
    49         . S C0CVARS=$NA(@C0CGLB)
    50         . S C0CI=""
    51         . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
    52         . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
    53         . . D PUTRIM1(DFN,C0CI,C0CVARSN)
    54         Q
    55         ;
    56 PUTRIM1(DFN,ZZTYP,ZVARS)        ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
    57         ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
    58         S C0CX=0
    59         F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
    60         . W "ZOCC=",C0CX,!
    61         . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
    62         . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
    63         . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
    64         . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
    65         . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
    66         . . S ZZCNT=0
    67         . . S ZZC0CI=0
    68         . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
    69         . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
    70         . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
    71         . . W "MULTIPLE:",ZZVALS,!
    72         . . ;B
    73         . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
    74         . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
    75         . . . W "COUNT:",ZZCNT,!
    76         . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
    77         . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
    78         Q
    79         ;
    80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS)    ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    81         ; 171.601, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
    82         ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    83         ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    84         ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    85         ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    86         ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    87         ;
    88         N ZSRC,PATN,ZTYPN,XD0,ZTYP
    89         S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
    90         ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    91         N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL
    92         N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL
    93         N C0CFDA
    94         N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
    95         W "ZTYPE: ",ZTYPE," ",ZTYPN,!
    96         N ZVARN ; IEN OF VARIABLE BEING PROCESSED
    97         ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
    98         S C0CFDA(C0CF,"+1,",.01)=ZTYPN
    99         S C0CFDA(C0CF,"+1,",.02)=DFN
    100         S C0CFDA(C0CF,"+1,",.03)=ZSRC
    101         S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space
    102         D UPDIE ; CREATE THE RECORD
    103         S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,""))
    104         N ZCNT,ZC0CI,ZVARN,C0CZ1
    105         S ZCNT=0
    106         S ZC0CI="" ;
    107         F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    108         . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    109         . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    110         . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    111         . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    112         . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN
    113         . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI)
    114         . E  D  ; THIS IS A SUBELEMENT
    115         . . ;PUT THE FOLLOWING BACK TO USE RECURSION
    116         . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
    117         . . ;S ZZCNT=0
    118         . . ;S ZZC0CI=0
    119         . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
    120         . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
    121         . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
    122         . . ;W "MULTIPLE:",ZZVALS,!
    123         . . ;B
    124         . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
    125         . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
    126         . . ;. W "COUNT:",ZZCNT,!
    127         . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
    128         . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
    129         . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
    130         D UPDIE ; UPDATE
    131         Q
    132         ;
    133 UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    134         K ZERR
    135         D CLEAN^DILF
    136         D UPDATE^DIE("","C0CFDA","","ZERR")
    137         I $D(ZERR) D  ;
    138         . W "ERROR",!
    139         . ZWR ZERR
    140         . B
    141         K C0CFDA
    142         Q
    143         ;
    144 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    145         ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
    146         ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    147         ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    148         ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    149         ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    150         ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    151         ;
    152         S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
    153         ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    154         N ZF,ZFV S ZF=171.101 S ZFV=171.1011
    155         ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
    156         ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
    157         N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
    158         W "ZTYPE: ",ZTYPE," ",ZTYPN,!
    159         N ZVARN ; IEN OF VARIABLE BEING PROCESSED
    160         ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
    161         K C0CFDA
    162         S C0CFDA(ZF,"?+1,",.01)=DFN
    163         S C0CFDA(ZF,"?+1,",.02)=ZSRC
    164         S C0CFDA(ZF,"?+1,",.03)=ZTYPN
    165         S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
    166         K ZERR
    167         ;B
    168         D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
    169         I $D(ZERR) B  ;OOPS
    170         K C0CFDA
    171         S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
    172         W "RECORD NUMBER: ",ZD0,!
    173         ;B
    174         S ZCNT=0
    175         S ZC0CI="" ;
    176         F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    177         . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    178         . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    179         . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    180         . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    181         . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
    182         . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
    183         . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
    184         . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
    185         ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    186         ;S GT1(170,"?+1,",12)="DIR"
    187         ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    188         ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
    189         D CLEAN^DILF
    190         D UPDATE^DIE("","C0CFDA","","ZERR")
    191         I $D(ZERR) D  ;
    192         . W "ERROR",!
    193         . ZWR ZERR
    194         . B
    195         K C0CFDA
    196         Q
    197         ;
    198 VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    199         ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    200         ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    201         ;
    202         N ZCCRD,ZVARN,C0CFDA2
    203         S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    204         S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    205         I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    206         . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    207         . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    208         . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    209         . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    210         . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    211         . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    212         . I $D(ZERR) D  ; LAYGO ERROR
    213         . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    214         . E  D  ;
    215         . . D CLEAN^DILF ; CLEAN UP
    216         . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    217         . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    218         Q ZVARN
    219         ;
    220 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
    221         ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
    222         ;
    223         N C0CDIC,C0CNODE ;
    224         S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
    225         S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
    226         Q
    227         ;
    228 FIXSEC  ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
    229         ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
    230         ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
    231         ; CONVERSION
    232         ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
    233         D FIELDS^C0CRNF("C0CC",170)
    234         S C0CI=""
    235         F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
    236         . S C0CZX=""
    237         . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
    238         . . W "SECTION ",C0CI," VAR ",C0CZX
    239         . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
    240         . . W " TYPE: ",C0CV,!
    241         . . D SETFDA("SECTION",C0CV)
    242         . . ;ZWR C0CFDA
    243         Q
    244         ;
    245 SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    246         ; TO SET TO VALUE C0CSV.
    247         ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    248         ; C0CSN,C0CSV ARE PASSED BY VALUE
    249         ;
    250         N C0CSI,C0CSJ
    251         S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    252         S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    253         S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    254         Q
    255 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    256         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    257         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    258         I '$D(ZTAB) S ZTAB="C0CA"
    259         N ZR
    260         I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    261         E  S ZR=""
    262         Q ZR
    263 ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    264         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    265         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    266         I '$D(ZTAB) S ZTAB="C0CA"
    267         N ZR
    268         I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    269         E  S ZR=""
    270         Q ZR
    271         ;
    272 ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    273         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    274         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    275         I '$D(ZTAB) S ZTAB="C0CA"
    276         N ZR
    277         I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    278         E  S ZR=""
    279         Q ZR
    280         ;
    281 SHOWE4(DFN)     ;
    282         ;
    283         N ZG
    284         S ZG=""
    285         F  S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG=""  D  ZWR ^C0CE4(ZG,*)
    286         Q
    287         ;
     1C0CFM3   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "This is the CCR FILEMAN Utility Library ",!
     21 ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
     22 ; CCR ELEMENTS (^C0C(179.201,
     23 ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
     24 ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
     25 ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
     26 ; ALL SUB-VARIABLES HAVE BEEN REMOVED
     27 W !
     28 Q
     29 ;
     30RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
     31 ; '
     32 I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS
     33 N ZI,ZJ,ZC,ZPATBASE
     34 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
     35 S ZI=""
     36 F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
     37 . S ZI=$O(@ZPATBASE@(ZI))
     38 . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
     39 Q
     40 ;
     41PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
     42 ;
     43 S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
     44 I '$D(ZWHICH) S ZWHICH="ALL"
     45 I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
     46 . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
     47 . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
     48 E  D  ; MULTIPLE SECTIONS
     49 . S C0CVARS=$NA(@C0CGLB)
     50 . S C0CI=""
     51 . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
     52 . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
     53 . . D PUTRIM1(DFN,C0CI,C0CVARSN)
     54 Q
     55 ;
     56PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
     57 ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
     58 S C0CX=0
     59 F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
     60 . W "ZOCC=",C0CX,!
     61 . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
     62 . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
     63 . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
     64 . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
     65 . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
     66 . . S ZZCNT=0
     67 . . S ZZC0CI=0
     68 . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
     69 . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
     70 . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
     71 . . W "MULTIPLE:",ZZVALS,!
     72 . . ;B
     73 . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
     74 . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
     75 . . . W "COUNT:",ZZCNT,!
     76 . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
     77 . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
     78 Q
     79 ;
     80PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     81 ; 171.601, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
     82 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     83 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     84 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     85 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     86 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     87 ;
     88 N ZSRC,PATN,ZTYPN,XD0,ZTYP
     89 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
     90 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     91 N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL
     92 N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL
     93 N C0CFDA
     94 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
     95 W "ZTYPE: ",ZTYPE," ",ZTYPN,!
     96 N ZVARN ; IEN OF VARIABLE BEING PROCESSED
     97 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
     98 S C0CFDA(C0CF,"+1,",.01)=ZTYPN
     99 S C0CFDA(C0CF,"+1,",.02)=DFN
     100 S C0CFDA(C0CF,"+1,",.03)=ZSRC
     101 S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space
     102 D UPDIE ; CREATE THE RECORD
     103 S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,""))
     104 N ZCNT,ZC0CI,ZVARN,C0CZ1
     105 S ZCNT=0
     106 S ZC0CI="" ;
     107 F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     108 . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     109 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     110 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     111 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     112 . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN
     113 . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI)
     114 . E  D  ; THIS IS A SUBELEMENT
     115 . . ;PUT THE FOLLOWING BACK TO USE RECURSION
     116 . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
     117 . . ;S ZZCNT=0
     118 . . ;S ZZC0CI=0
     119 . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
     120 . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
     121 . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
     122 . . ;W "MULTIPLE:",ZZVALS,!
     123 . . ;B
     124 . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
     125 . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
     126 . . ;. W "COUNT:",ZZCNT,!
     127 . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
     128 . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
     129 . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
     130 D UPDIE ; UPDATE
     131 Q
     132 ;
     133UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     134 K ZERR
     135 D CLEAN^DILF
     136 D UPDATE^DIE("","C0CFDA","","ZERR")
     137 I $D(ZERR) D  ;
     138 . W "ERROR",!
     139 . ZWR ZERR
     140 . B
     141 K C0CFDA
     142 Q
     143 ;
     144PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     145 ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
     146 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     147 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     148 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     149 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     150 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     151 ;
     152 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
     153 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     154 N ZF,ZFV S ZF=171.101 S ZFV=171.1011
     155 ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
     156 ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
     157 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
     158 W "ZTYPE: ",ZTYPE," ",ZTYPN,!
     159 N ZVARN ; IEN OF VARIABLE BEING PROCESSED
     160 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
     161 K C0CFDA
     162 S C0CFDA(ZF,"?+1,",.01)=DFN
     163 S C0CFDA(ZF,"?+1,",.02)=ZSRC
     164 S C0CFDA(ZF,"?+1,",.03)=ZTYPN
     165 S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
     166 K ZERR
     167 ;B
     168 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
     169 I $D(ZERR) B  ;OOPS
     170 K C0CFDA
     171 S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
     172 W "RECORD NUMBER: ",ZD0,!
     173 ;B
     174 S ZCNT=0
     175 S ZC0CI="" ;
     176 F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     177 . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     178 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     179 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     180 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     181 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
     182 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
     183 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
     184 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
     185 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     186 ;S GT1(170,"?+1,",12)="DIR"
     187 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     188 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
     189 D CLEAN^DILF
     190 D UPDATE^DIE("","C0CFDA","","ZERR")
     191 I $D(ZERR) D  ;
     192 . W "ERROR",!
     193 . ZWR ZERR
     194 . B
     195 K C0CFDA
     196 Q
     197 ;
     198VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     199 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     200 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     201 ;
     202 N ZCCRD,ZVARN,C0CFDA2
     203 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     204 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     205 I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     206 . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     207 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     208 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     209 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     210 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     211 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     212 . I $D(ZERR) D  ; LAYGO ERROR
     213 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     214 . E  D  ;
     215 . . D CLEAN^DILF ; CLEAN UP
     216 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     217 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     218 Q ZVARN
     219 ;
     220BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
     221 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
     222 ;
     223 N C0CDIC,C0CNODE ;
     224 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
     225 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
     226 Q
     227 ;
     228FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
     229 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
     230 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
     231 ; CONVERSION
     232 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
     233 D FIELDS^C0CRNF("C0CC",170)
     234 S C0CI=""
     235 F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
     236 . S C0CZX=""
     237 . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
     238 . . W "SECTION ",C0CI," VAR ",C0CZX
     239 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
     240 . . W " TYPE: ",C0CV,!
     241 . . D SETFDA("SECTION",C0CV)
     242 . . ;ZWR C0CFDA
     243 Q
     244 ;
     245SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     246 ; TO SET TO VALUE C0CSV.
     247 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     248 ; C0CSN,C0CSV ARE PASSED BY VALUE
     249 ;
     250 N C0CSI,C0CSJ
     251 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     252 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     253 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     254 Q
     255ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     256 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     257 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     258 I '$D(ZTAB) S ZTAB="C0CA"
     259 N ZR
     260 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     261 E  S ZR=""
     262 Q ZR
     263ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     264 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     265 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     266 I '$D(ZTAB) S ZTAB="C0CA"
     267 N ZR
     268 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     269 E  S ZR=""
     270 Q ZR
     271 ;
     272ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     273 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     274 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     275 I '$D(ZTAB) S ZTAB="C0CA"
     276 N ZR
     277 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     278 E  S ZR=""
     279 Q ZR
     280 ;
     281SHOWE4(DFN) ;
     282 ;
     283 N ZG
     284 S ZG=""
     285 F  S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG=""  D  ZWR ^C0CE4(ZG,*)
     286 Q
     287 ;

  • ccr/branches/ohum/p/C0CIM2.m

    r1330 r1332  
    11C0CIM2   ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
    2         ;;1.0;C0C;;Feb 16, 2010;Build 1
     2        ;;1.0;C0C;;Feb 16, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CIMMU.m

    r1330 r1332  
    11C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CIN.m

    r1330 r1332  
    11C0CIN     ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
    2         ;;1.0;C0C;;Sep 20, 2009;Build 1
     2        ;;1.0;C0C;;Sep 20, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CLA7DD.m

    r1330 r1332  
    1 C0CLA7DD        ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;
    4         ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file.
    5         ;
    6         Q
    7         ;
    8         ;
    9 EN      ; Add new style cross-references to V LAB file if it exists.
    10         ; OLD entry point - see new KIDS check points in C0CENV.
    11         ;
    12         ;
    13         ; Quit if AUPNVLAB global does not exist.
    14         I $$VFILE^DILFD(9000010.09)'=1 Q
    15         ;
    16         N MSG
    17         ;
    18         S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    19         D BMES(MSG)
    20         D ALR1
    21         S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    22         D BMES(MSG)
    23         ;
    24         S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    25         D BMES(MSG)
    26         D ALR2
    27         S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    28         D BMES(MSG)
    29         ;
    30         S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    31         D BMES(MSG)
    32         D ALR3
    33         S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    34         D BMES(MSG)
    35         ;
    36         S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    37         D BMES(MSG)
    38         D ALR4
    39         S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    40         D BMES(MSG)
    41         ;
    42         S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    43         D BMES(MSG)
    44         D ALR5
    45         S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    46         D BMES(MSG)
    47         ;
    48         Q
    49         ;
    50         ;
    51 ALR1    ; Installation of ALR1 cross-reference
    52         ;
    53         N C0CFLAG,C0CXR,C0CRES,C0COUT
    54         ;
    55         S C0CFLAG=""
    56         ;
    57         S C0CXR("FILE")=9000010.09
    58         S C0CXR("NAME")="ALR1"
    59         S C0CXR("TYPE")="R"
    60         S C0CXR("USE")="S"
    61         S C0CXR("EXECUTION")="R"
    62         S C0CXR("ACTIVITY")="IR"
    63         S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)"
    64         S C0CXR("VAL",1)=.02
    65         S C0CXR("VAL",1,"SUBSCRIPT")=1
    66         S C0CXR("VAL",1,"COLLATION")="F"
    67         S C0CXR("VAL",2)=.06
    68         S C0CXR("VAL",2,"SUBSCRIPT")=2
    69         S C0CXR("VAL",2,"LENGTH")=30
    70         S C0CXR("VAL",2,"COLLATION")="F"
    71         S C0CXR("VAL",3)=.01
    72         S C0CXR("VAL",3,"SUBSCRIPT")=3
    73         S C0CXR("VAL",3,"COLLATION")="F"
    74         S C0CXR("VAL",4)=1201
    75         S C0CXR("VAL",4,"SUBSCRIPT")=4
    76         S C0CXR("VAL",4,"COLLATION")="F"
    77         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    78         ;
    79         Q
    80         ;
    81         ;
    82 ALR2    ; Installation of ALR2 cross-reference
    83         ;
    84         N C0CFLAG,C0CXR,C0CRES,C0COUT
    85         ;
    86         S C0CFLAG=""
    87         ;
    88         S C0CXR("FILE")=9000010.09
    89         S C0CXR("NAME")="ALR2"
    90         S C0CXR("TYPE")="MU"
    91         S C0CXR("USE")="S"
    92         S C0CXR("EXECUTION")="R"
    93         S C0CXR("ACTIVITY")="IR"
    94         S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result."
    95         S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes"
    96         S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to"
    97         S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test"
    98         S C0CXR("DESCR",4)="result."
    99         S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)="""""
    100         S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)"
    101         S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")"
    102         S C0CXR("VAL",1)=.02
    103         S C0CXR("VAL",1,"SUBSCRIPT")=1
    104         S C0CXR("VAL",1,"COLLATION")="F"
    105         S C0CXR("VAL",2)=1201
    106         S C0CXR("VAL",2,"SUBSCRIPT")=2
    107         S C0CXR("VAL",2,"COLLATION")="F"
    108         S C0CXR("VAL",3)=.06
    109         S C0CXR("VAL",3,"SUBSCRIPT")=3
    110         S C0CXR("VAL",3,"COLLATION")="F"
    111         S C0CXR("VAL",4)=.01
    112         S C0CXR("VAL",4,"SUBSCRIPT")=4
    113         S C0CXR("VAL",4,"COLLATION")="F"
    114         S C0CXR("VAL",5)=1113
    115         S C0CXR("VAL",5,"SUBSCRIPT")=5
    116         S C0CXR("VAL",5,"COLLATION")="F"
    117         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    118         ;
    119         Q
    120         ;
    121         ;
    122 ALR3    ; Installation of ALR3 cross-reference
    123         ;
    124         N C0CFLAG,C0CXR,C0CRES,C0COUT
    125         ;
    126         S C0CFLAG=""
    127         ;
    128         S C0CXR("FILE")=9000010.09
    129         S C0CXR("NAME")="ALR3"
    130         S C0CXR("TYPE")="R"
    131         S C0CXR("USE")="S"
    132         S C0CXR("EXECUTION")="F"
    133         S C0CXR("ACTIVITY")="IR"
    134         S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient"
    135         S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries"
    136         S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient"
    137         S C0CXR("DESCR",3)="lab results to be identified by LOINC"
    138         S C0CXR("VAL",1)=1113
    139         S C0CXR("VAL",1,"SUBSCRIPT")=1
    140         S C0CXR("VAL",1,"COLLATION")="F"
    141         ;
    142         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    143         ;
    144         Q
    145         ;
    146         ;
    147 ALR4    ; Installation of ALR4 cross-reference
    148         ;
    149         N C0CFLAG,C0CXR,C0CRES,C0COUT
    150         ;
    151         S C0CFLAG=""
    152         ;
    153         S C0CXR("FILE")=9000010.09
    154         S C0CXR("NAME")="ALR4"
    155         S C0CXR("TYPE")="R"
    156         S C0CXR("USE")="S"
    157         S C0CXR("EXECUTION")="R"
    158         S C0CXR("ACTIVITY")="IR"
    159         S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time"
    160         S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
    161         S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in"
    162         S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
    163         S C0CXR("DESCR",4)="file (#63)."
    164         S C0CXR("VAL",1)=.02
    165         S C0CXR("VAL",1,"SUBSCRIPT")=1
    166         S C0CXR("VAL",1,"COLLATION")="F"
    167         S C0CXR("VAL",2)=1201
    168         S C0CXR("VAL",2,"SUBSCRIPT")=2
    169         S C0CXR("VAL",2,"COLLATION")="F"
    170         ;
    171         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    172         ;
    173         Q
    174         ;
    175         ;
    176 ALR5    ; Installation of ALR5 cross-reference
    177         ;
    178         N C0CFLAG,C0CXR,C0CRES,C0COUT
    179         ;
    180         S C0CFLAG=""
    181         ;
    182         S C0CXR("FILE")=9000010.09
    183         S C0CXR("NAME")="ALR5"
    184         S C0CXR("TYPE")="R"
    185         S C0CXR("USE")="S"
    186         S C0CXR("EXECUTION")="R"
    187         S C0CXR("ACTIVITY")="IR"
    188         S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time"
    189         S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
    190         S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in"
    191         S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
    192         S C0CXR("DESCR",4)="file (#63)."
    193         S C0CXR("VAL",1)=.02
    194         S C0CXR("VAL",1,"SUBSCRIPT")=1
    195         S C0CXR("VAL",1,"COLLATION")="F"
    196         S C0CXR("VAL",2)=1212
    197         S C0CXR("VAL",2,"SUBSCRIPT")=2
    198         S C0CXR("VAL",2,"COLLATION")="F"
    199         ;
    200         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    201         ;
    202         Q
    203         ;
    204         ;
    205 REINDEX ; Set data into indexes for current entries.
    206         ;
    207         ;
    208         N C0CHLOG,DA,DIK,MSG
    209         ;
    210         S C0CHLOG("START")=$H
    211         S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
    212         D BMES(MSG),SENDXQA(MSG)
    213         ;
    214         S DIK="^AUPNVLAB("
    215         S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5"
    216         D ENALL^DIK
    217         ;
    218         S C0CHLOG("END")=$H
    219         S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
    220         D BMES(MSG),SENDXQA(MSG)
    221         ;
    222         S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
    223         D BMES(MSG)
    224         ;
    225         S C0CHLOG("START")=$H
    226         S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
    227         D BMES(MSG),SENDXQA(MSG)
    228         ;
    229         K DA,DIK
    230         S DIK="^AUPNVLAB("
    231         S DIK(1)="1113^ALR3"
    232         D ENALL^DIK
    233         ;
    234         S C0CHLOG("END")=$H
    235         S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
    236         D BMES(MSG),SENDXQA(MSG)
    237         ;
    238         S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
    239         D BMES(MSG)
    240         ;
    241         Q
    242         ;
    243         ;
    244 BMES(STR)       ; Write BMES^XPDUTL statements
    245         ;
    246         D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
    247         ;
    248         Q
    249         ;
    250         ;
     1C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
     2 ;;1.0;C0C;;May 19, 2009;
     3 ;
     4 ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file.
     5 ;
     6 Q
     7 ;
     8 ;
     9EN ; Add new style cross-references to V LAB file if it exists.
     10 ; OLD entry point - see new KIDS check points in C0CENV.
     11 ;
     12 ;
     13 ; Quit if AUPNVLAB global does not exist.
     14 I $$VFILE^DILFD(9000010.09)'=1 Q
     15 ;
     16 N MSG
     17 ;
     18 S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     19 D BMES(MSG)
     20 D ALR1
     21 S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     22 D BMES(MSG)
     23 ;
     24 S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     25 D BMES(MSG)
     26 D ALR2
     27 S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     28 D BMES(MSG)
     29 ;
     30 S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     31 D BMES(MSG)
     32 D ALR3
     33 S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     34 D BMES(MSG)
     35 ;
     36 S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     37 D BMES(MSG)
     38 D ALR4
     39 S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     40 D BMES(MSG)
     41 ;
     42 S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     43 D BMES(MSG)
     44 D ALR5
     45 S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     46 D BMES(MSG)
     47 ;
     48 Q
     49 ;
     50 ;
     51ALR1 ; Installation of ALR1 cross-reference
     52 ;
     53 N C0CFLAG,C0CXR,C0CRES,C0COUT
     54 ;
     55 S C0CFLAG=""
     56 ;
     57 S C0CXR("FILE")=9000010.09
     58 S C0CXR("NAME")="ALR1"
     59 S C0CXR("TYPE")="R"
     60 S C0CXR("USE")="S"
     61 S C0CXR("EXECUTION")="R"
     62 S C0CXR("ACTIVITY")="IR"
     63 S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)"
     64 S C0CXR("VAL",1)=.02
     65 S C0CXR("VAL",1,"SUBSCRIPT")=1
     66 S C0CXR("VAL",1,"COLLATION")="F"
     67 S C0CXR("VAL",2)=.06
     68 S C0CXR("VAL",2,"SUBSCRIPT")=2
     69 S C0CXR("VAL",2,"LENGTH")=30
     70 S C0CXR("VAL",2,"COLLATION")="F"
     71 S C0CXR("VAL",3)=.01
     72 S C0CXR("VAL",3,"SUBSCRIPT")=3
     73 S C0CXR("VAL",3,"COLLATION")="F"
     74 S C0CXR("VAL",4)=1201
     75 S C0CXR("VAL",4,"SUBSCRIPT")=4
     76 S C0CXR("VAL",4,"COLLATION")="F"
     77 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     78 ;
     79 Q
     80 ;
     81 ;
     82ALR2 ; Installation of ALR2 cross-reference
     83 ;
     84 N C0CFLAG,C0CXR,C0CRES,C0COUT
     85 ;
     86 S C0CFLAG=""
     87 ;
     88 S C0CXR("FILE")=9000010.09
     89 S C0CXR("NAME")="ALR2"
     90 S C0CXR("TYPE")="MU"
     91 S C0CXR("USE")="S"
     92 S C0CXR("EXECUTION")="R"
     93 S C0CXR("ACTIVITY")="IR"
     94 S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result."
     95 S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes"
     96 S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to"
     97 S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test"
     98 S C0CXR("DESCR",4)="result."
     99 S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)="""""
     100 S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)"
     101 S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")"
     102 S C0CXR("VAL",1)=.02
     103 S C0CXR("VAL",1,"SUBSCRIPT")=1
     104 S C0CXR("VAL",1,"COLLATION")="F"
     105 S C0CXR("VAL",2)=1201
     106 S C0CXR("VAL",2,"SUBSCRIPT")=2
     107 S C0CXR("VAL",2,"COLLATION")="F"
     108 S C0CXR("VAL",3)=.06
     109 S C0CXR("VAL",3,"SUBSCRIPT")=3
     110 S C0CXR("VAL",3,"COLLATION")="F"
     111 S C0CXR("VAL",4)=.01
     112 S C0CXR("VAL",4,"SUBSCRIPT")=4
     113 S C0CXR("VAL",4,"COLLATION")="F"
     114 S C0CXR("VAL",5)=1113
     115 S C0CXR("VAL",5,"SUBSCRIPT")=5
     116 S C0CXR("VAL",5,"COLLATION")="F"
     117 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     118 ;
     119 Q
     120 ;
     121 ;
     122ALR3 ; Installation of ALR3 cross-reference
     123 ;
     124 N C0CFLAG,C0CXR,C0CRES,C0COUT
     125 ;
     126 S C0CFLAG=""
     127 ;
     128 S C0CXR("FILE")=9000010.09
     129 S C0CXR("NAME")="ALR3"
     130 S C0CXR("TYPE")="R"
     131 S C0CXR("USE")="S"
     132 S C0CXR("EXECUTION")="F"
     133 S C0CXR("ACTIVITY")="IR"
     134 S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient"
     135 S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries"
     136 S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient"
     137 S C0CXR("DESCR",3)="lab results to be identified by LOINC"
     138 S C0CXR("VAL",1)=1113
     139 S C0CXR("VAL",1,"SUBSCRIPT")=1
     140 S C0CXR("VAL",1,"COLLATION")="F"
     141 ;
     142 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     143 ;
     144 Q
     145 ;
     146 ;
     147ALR4 ; Installation of ALR4 cross-reference
     148 ;
     149 N C0CFLAG,C0CXR,C0CRES,C0COUT
     150 ;
     151 S C0CFLAG=""
     152 ;
     153 S C0CXR("FILE")=9000010.09
     154 S C0CXR("NAME")="ALR4"
     155 S C0CXR("TYPE")="R"
     156 S C0CXR("USE")="S"
     157 S C0CXR("EXECUTION")="R"
     158 S C0CXR("ACTIVITY")="IR"
     159 S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time"
     160 S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
     161 S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in"
     162 S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
     163 S C0CXR("DESCR",4)="file (#63)."
     164 S C0CXR("VAL",1)=.02
     165 S C0CXR("VAL",1,"SUBSCRIPT")=1
     166 S C0CXR("VAL",1,"COLLATION")="F"
     167 S C0CXR("VAL",2)=1201
     168 S C0CXR("VAL",2,"SUBSCRIPT")=2
     169 S C0CXR("VAL",2,"COLLATION")="F"
     170 ;
     171 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     172 ;
     173 Q
     174 ;
     175 ;
     176ALR5 ; Installation of ALR5 cross-reference
     177 ;
     178 N C0CFLAG,C0CXR,C0CRES,C0COUT
     179 ;
     180 S C0CFLAG=""
     181 ;
     182 S C0CXR("FILE")=9000010.09
     183 S C0CXR("NAME")="ALR5"
     184 S C0CXR("TYPE")="R"
     185 S C0CXR("USE")="S"
     186 S C0CXR("EXECUTION")="R"
     187 S C0CXR("ACTIVITY")="IR"
     188 S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time"
     189 S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
     190 S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in"
     191 S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
     192 S C0CXR("DESCR",4)="file (#63)."
     193 S C0CXR("VAL",1)=.02
     194 S C0CXR("VAL",1,"SUBSCRIPT")=1
     195 S C0CXR("VAL",1,"COLLATION")="F"
     196 S C0CXR("VAL",2)=1212
     197 S C0CXR("VAL",2,"SUBSCRIPT")=2
     198 S C0CXR("VAL",2,"COLLATION")="F"
     199 ;
     200 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     201 ;
     202 Q
     203 ;
     204 ;
     205REINDEX ; Set data into indexes for current entries.
     206 ;
     207 ;
     208 N C0CHLOG,DA,DIK,MSG
     209 ;
     210 S C0CHLOG("START")=$H
     211 S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
     212 D BMES(MSG),SENDXQA(MSG)
     213        ;
     214 S DIK="^AUPNVLAB("
     215 S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5"
     216 D ENALL^DIK
     217 ;
     218 S C0CHLOG("END")=$H
     219 S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
     220 D BMES(MSG),SENDXQA(MSG)
     221 ;
     222 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
     223 D BMES(MSG)
     224        ;
     225 S C0CHLOG("START")=$H
     226 S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
     227 D BMES(MSG),SENDXQA(MSG)
     228 ;
     229 K DA,DIK
     230 S DIK="^AUPNVLAB("
     231 S DIK(1)="1113^ALR3"
     232 D ENALL^DIK
     233 ;
     234 S C0CHLOG("END")=$H
     235 S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
     236 D BMES(MSG),SENDXQA(MSG)
     237 ;
     238 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
     239 D BMES(MSG)
     240 ;
     241 Q
     242 ;
     243 ;
     244BMES(STR) ; Write BMES^XPDUTL statements
     245 ;
     246 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
     247 ;
     248 Q
     249 ;
     250 ;
    251251SENDXQA(MSG)    ; Send alert for reindex status
    252252        ;

  • ccr/branches/ohum/p/C0CLA7Q.m

    r1330 r1332  
    11C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;
    44        ;

  • ccr/branches/ohum/p/C0CLABS.m

    r1330 r1332  
    11C0CALABS        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CMAIL.m

    r1330 r1332  
    11C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2 V       ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 Chris Richardson, Richardson Computer Research
    4         ; Modified 3110516@1818
    5         ;   rcr@rcresearch.us
    6         ;  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23         ;  ------------------
    24         ;Entry Points
    25         ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
    26         ;  Input:
    27         ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
    28         ;                      or "*" for all boxes, default is "IN" if missing]"
    29         ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
    30         ;                                     "*" for All or 9,999 maximum
    31         ;                    MALL?1.n = that number of the n most recent
    32         ;  Internally:
    33         ;    BNAM = Box Name
    34         ;  Output:
    35         ;    C0CDATA
    36         ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
    37         ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
    38         ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
    39         ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
    40         ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
    41         ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
    42         ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
    43         ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
    44         ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
    45         ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
    46         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
    47         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
    48         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
    49         ;
    50         ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
    51         ;   Input;
    52         ;     D0     - The IEN for the message in file 3.9, MESSAGE global
    53         ;   Output
    54         ;     OUTBF  - The array of your choice to save the expanded and decoded message.
    55         ;
    56 GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
    57         K:'$G(C0CDATA("KEEP")) C0CDATA
    58         N U
    59         S U="^"
    60         D:$G(C0CINPUT)
    61         . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
    62         . S INPUT=C0CINPUT
    63         . S DUZ=+INPUT
    64         . D:$D(^XMB(3.7,DUZ,0))#2
    65         . . S MBLST=$P(INPUT,";",2)
    66         . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
    67         . . S:MALL["*" MALL=99999
    68         . . ; Only one of these can be correct
    69         . . D
    70         . . . ;  If nul, make it "IN" only
    71         . . . I MBLST="" D  QUIT
    72         . . . . S MBLST("IN")=0,I=0
    73         . . . . D GATHER(DUZ,"IN",.LST)
    74         . . . .QUIT
    75         . . . ;
    76         . . . ;  If "*", Get all Mailboxes and look for New Messages
    77         . . . I MBLST["*" D  QUIT
    78         . . . . N NAM,NUM
    79         . . . . S NUM=0
    80         . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
    81         . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
    82         . . . . . D GATHER(DUZ,NAM,.LST)
    83         . . . . .QUIT
    84         . . . .QUIT
    85         . . . ;
    86         . . . ;  If comma separated, look for mailboxes with new messages
    87         . . . I $L(MBLST,",")>1 D  QUIT
    88         . . . . S NAM=""
    89         . . . . N T,V
    90         . . . . F T=1:1:$L(MBLST,",")  S V=$P(MBLST,",",T)  I $L(V) D
    91         . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
    92         . . . . . S:NAM="" NAM=V
    93         . . . . . D GATHER(DUZ,NAM,.LST)
    94         . . . . .QUIT
    95         . . . .QUIT
    96         . . . ;
    97         . . . ;  If only 1 mailbox named, go get it
    98         . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT
    99         . . .QUIT
    100         . . MERGE C0CDATA=LST
    101         . .QUIT
    102         .QUIT
    103         QUIT
    104         ;  ===================
    105 GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
    106         N I,J,K,L
    107         S (I,K)=0
    108         S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
    109         F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
    110         . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
    111         . D   ; :L
    112         . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
    113         . . S LST(NAM,"MSG",I)=L
    114         . . D GETTYP(I)
    115         . .QUIT
    116         .QUIT
    117         S LST(NAM,"NUMBER")=K
    118         QUIT
    119         ;  ===================
    120         ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
    121         ; The products of these emails are scanned to identify
    122         ;  the number of documents stored in the MIME package.
    123         ;  The protocol runs like this;
    124         ; Line 1 is the --separator
    125         ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
    126         ; Line n+2 thru t-1 where t does NOT have "Content-"
    127         ; Line t   is Next Section Terminator, or Message Terminator, --separator
    128         ; Line t+1 should not exist in the data set if Message Terminator
    129         ; CON = "Content-"
    130         ; FLG = "--"
    131         ; SEP = FLG+7 or more characters  ; Separator
    132         ; END = SEP+FLG
    133         ; SGC = Segment Count
    134         ; Note: separator is a string of specific characters of
    135         ;        indeterminate length 
    136         ; LST() the transfer array
    137         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
    138         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
    139         ;
    140 GETTYP(D0)      ; Look for the goodies in the Mail
    141         N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
    142         S CON="Content-"
    143         S FLG="--"
    144         S SEP=""  ; Start SEP as null, so we can use this to help identify the type
    145         S (BCN,CNT,D1,END,SGC)=0
    146         S XX=$G(^XMB(3.9,D0,0))
    147         S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    148         S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
    149         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    150         S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
    151         S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
    152         ; Get the folks the email is sent to.
    153         S D1=0
    154         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
    155         . N T
    156         . S T=+$G(^XMB(3.9,D0,1,D1,0))
    157         . S:T T=$P($G(^VA(200,+T,0)),"^")
    158         . S LST("TO",D1)=T
    159         . S T=$G(^XMB(3.9,D0,6,D1,0))
    160         . S:T T=$P($G(^VA(200,+T,0)),"^")
    161         . S:T="" T="<Unknown>"
    162         . S LST("TO NAME",D1)=T
    163         .QUIT
    164         ; Preload first Segment (0) with beginning on Line 1
    165         ;  if not a 64bit
    166         S LST(NAM,"MSG",D0,"SEG",0)=1
    167         S D1=.9999,SEP="--"
    168         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    169         . ; Clear any control characters (cr/lf/ff) off
    170         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    171         . ; Enter once to set the SEP to capture the separator
    172         . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
    173         . . S SEP=X,END=X_FLG
    174         . . S (CNT,SGC)=1,BCN=0
    175         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    176         . .QUIT
    177         . ;
    178         . ; A new separator is set, process original
    179         . I X=SEP  D  QUIT
    180         . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN
    181         . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
    182         . . S SGC=SGC+1,BCN=0
    183         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    184         . .QUIT
    185         . ;
    186         . S BCN=BCN+$L(X)
    187         . I X[CON D  Q
    188         . . S J=$P($P(X,";"),CON,2)
    189         . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
    190         . .QUIT
    191         . ;
    192         . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
    193         .QUIT
    194         QUIT
    195         ;  ===================
    196 NAME(NM)        ; Return the name of the Sender
    197         N NAME
    198         S NAME="<Unknown Sender>"
    199         D
    200         . ; Look first for a value to use with the NEW PERSON file
    201         . ;
    202         . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
    203         . ;
    204         . I $L(NM) S NAME=NM                    Q
    205         . ;
    206         . ; Else, pull the data from the message and display the foreign source
    207         . ;   of the message.
    208         . N T
    209         . S VAL=$G(^XMB(3.9,D0,.7))
    210         . S:VAL T=$P(^VA(200,VAL,0),U)
    211         . I $L($G(T)) S NAME=T                  Q
    212         . ;
    213         .QUIT
    214         QUIT NAME
    215         ;  ===================
    216 TIME(Y) ; The time and date of the sending
    217         X ^DD("DD")
    218         QUIT Y
    219         ;  ===================
    220         ;  Segments in Message need to be identified and decoded properly
    221         ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
    222         ;   ARRAY will have the details of this one call
    223         ;   
    224         ; Inputs;
    225         ;   C0CINPUT    - The IEN of the message to expand
    226         ; Outputs;
    227         ;   C0CDATA     - Carrier for the returned structure of the Message
    228         ;  C0CDATA(D0,"SEG")=number of SEGMENTS
    229         ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details
    230         ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
    231         ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
    232         ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
    233         ;
    234 DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
    235         N LST,D0,D1,U
    236         S U="^"
    237         S D0=+$G(C0CINPUT)
    238         I D0   D    QUIT
    239         . D GETTYP2(D0)
    240         . I $D(LST)   M C0CDATA(D0)=LST
    241         .QUIT
    242         QUIT
    243         ;  ===================
    244         ;  End note if needed
    245         ; MSK   - Set of characters that do not exist in 64 bit encoding
    246 GETTYP2(D0)     ; Try to get the types and MSK for the
    247         N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
    248         S CON="Content-",U="^"
    249         S FLG="--"
    250         S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
    251         S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
    252         S (BCN,CNT,D1,END,SGC)=0
    253         S XX=$G(^XMB(3.9,D0,0))
    254         ; S K=$P(^XMB(3.9,D0,2,0),U,3)
    255         S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    256         S LST("CREATED")=$$TIME($P(XX,U,3))
    257         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    258         S LST("FROM")=$$NAME(XXNM)
    259         ; Get the folks the email is sent to.
    260         S D1=0
    261         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
    262         . N I,T
    263         . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
    264         . S:T T=$P($G(^VA(200,T,0)),"^")
    265         . S LST("TO",+D1)=T
    266         . S T=$G(^XMB(3.9,D0,6,+D1,0))
    267         . S:T="" T=$P($G(^VA(200,+T,0)),"^")
    268         . S:T="" T="<Unknown>"
    269         . S LST("TO NAME",D1)=T
    270         .QUIT
    271         ; Get the Header for the message
    272         S D1=0
    273         F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
    274         . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
    275         .QUIT
    276         ; Start walking the different sections
    277         S D1=.99999,SEP="--"
    278         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    279         . ; Clear any control characters (cr/lf/ff) off
    280         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    281         . ; Enter once to set the SEP to capture the separator
    282         . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2)  D   Q
    283         . . S SEP=X,END=X_FLG
    284         . . S (CNT,SGC)=1,BCN=0
    285         . . S LST("SEG",SGC)=D1
    286         . .QUIT
    287         . ;
    288         . ; A new SEGMENT separator is set, process original
    289         . I X=SEP  D  QUIT
    290         . . ; Save Current Values
    291         . . S LST("SEG",SGC,"SIZE")=BCN
    292         . . ;  Close this Segment and prepare to start a New Segment
    293         . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
    294         . . ;  Put the result in LST("SEG",SGC,"XML")
    295         . . I $L(BF) D
    296         . . . S ZN=1
    297         . . . N I,T,TBF
    298         . . . S TBF=BF
    299         . . . F I=1:1:($L(TBF,"="))  D
    300         . . . . S BF=$P(TBF,"=",I)_"="
    301         . . . . I BF'="="  D DECODER
    302         . . . .QUIT
    303         . . . S BF=""
    304         . . .QUIT
    305         . . S SGC=SGC+1,BCN=0
    306         . . ; Incriment SGC to start a new Segment
    307         . . S LST("SEG",SGC)=D1
    308         . .QUIT
    309         . ;
    310         . ; Accumulate the 64 bit encoding
    311         . I X=$TR(X,MSK)&$L(X) D   Q
    312         . . S BF=BF_X
    313         . . S BCN=BCN+$L(X)
    314         . .QUIT
    315         . ;
    316         . ; Ending Condition, close out the Segment
    317         . I X=END D  QUIT
    318         . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
    319         . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
    320         . .QUIT
    321         . ;
    322         . S BCN=BCN+$L(X)
    323         . ; Split out the Content Info
    324         . I X[CON D  Q
    325         . . S J=$P(X,CON,2)
    326         . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
    327         . .QUIT
    328         . ;
    329         . ; Everything else is Text
    330         . S LST("SEG",SGC,"TXT",D1)=X
    331         .QUIT
    332         QUIT
    333         ;  ===================
    334         ; Break down the Buffer Array so it can be saved.
    335         ;  BF is passed in.
    336 DECODER ;
    337         N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE
    338         S ZBF=BF
    339         ;  Full Buffer, BF, now check for Encryption and Unpack
    340         F RCNT=1:1:$L(ZBF,"=")   D
    341         . N BF
    342         . S BF=$P(ZBF,"=",RCNT)
    343         . ;  Unpacking the 64 bit encoding
    344         . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
    345         . D:$L(TBF)
    346         . . N XBF
    347         . . S BF=BF_"="
    348         . . D NORMAL(.XBF,.TBF)
    349         . . M LST("SEG",SGC,"XML",RCNT)=XBF
    350         . .QUIT
    351         .QUIT
    352         QUIT
    353         ;  ===================
    354         ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
    355         ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
    356         ;   >D NORMAL^C0CMAIL(.OUT,BF)
    357 NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    358         ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    359         ;
    360         N ZN,OUTBF
    361         S ZN=1
    362         S OUTBF(ZN)=$P(INXML,"><",ZN)_">"
    363         F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)=""  D  ;
    364         . S OUTBF(ZN)=OUTBF(ZN)_">"
    365         .QUIT
    366         M OUTXML=OUTBF
    367         QUIT
    368         ;  ===================
    369         ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
    370         ;  End note if needed
    371         QUIT
    372         ;  ===================
     2V ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2011 Chris Richardson, Richardson Computer Research
     4 ; Modified 3110516@1818
     5 ;   rcr@rcresearch.us
     6 ;  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23 ;  ------------------
     24 ;Entry Points
     25 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
     26 ;  Input:
     27 ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
     28 ;                      or "*" for all boxes, default is "IN" if missing]"
     29 ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
     30 ;                                     "*" for All or 9,999 maximum
     31 ;                    MALL?1.n = that number of the n most recent
     32 ;  Internally:
     33 ;    BNAM = Box Name
     34 ;  Output:
     35 ;    C0CDATA
     36 ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
     37 ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
     38 ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
     39 ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
     40 ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
     41 ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
     42 ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
     43 ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
     44 ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
     45 ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
     46 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
     47 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
     48 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
     49 ;
     50 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
     51 ;   Input;
     52 ;     D0     - The IEN for the message in file 3.9, MESSAGE global
     53 ;   Output
     54 ;     OUTBF  - The array of your choice to save the expanded and decoded message.
     55 ;
     56GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
     57 K:'$G(C0CDATA("KEEP")) C0CDATA
     58 N U
     59 S U="^"
     60 D:$G(C0CINPUT)
     61 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
     62 . S INPUT=C0CINPUT
     63 . S DUZ=+INPUT
     64 . D:$D(^XMB(3.7,DUZ,0))#2
     65 . . S MBLST=$P(INPUT,";",2)
     66 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
     67 . . S:MALL["*" MALL=99999
     68 . . ; Only one of these can be correct
     69 . . D
     70 . . . ;  If nul, make it "IN" only
     71 . . . I MBLST="" D  QUIT
     72 . . . . S MBLST("IN")=0,I=0
     73 . . . . D GATHER(DUZ,"IN",.LST)
     74 . . . .QUIT
     75 . . . ;
     76 . . . ;  If "*", Get all Mailboxes and look for New Messages
     77 . . . I MBLST["*" D  QUIT
     78 . . . . N NAM,NUM
     79 . . . . S NUM=0
     80 . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
     81 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
     82 . . . . . D GATHER(DUZ,NAM,.LST)
     83 . . . . .QUIT
     84 . . . .QUIT
     85 . . . ;
     86 . . . ;  If comma separated, look for mailboxes with new messages
     87 . . . I $L(MBLST,",")>1 D  QUIT
     88 . . . . S NAM=""
     89 . . . . N T,V
     90 . . . . F T=1:1:$L(MBLST,",")  S V=$P(MBLST,",",T)  I $L(V) D
     91 . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
     92 . . . . . S:NAM="" NAM=V
     93 . . . . . D GATHER(DUZ,NAM,.LST)
     94 . . . . .QUIT
     95 . . . .QUIT
     96 . . . ;
     97 . . . ;  If only 1 mailbox named, go get it
     98 . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT
     99 . . .QUIT
     100 . . MERGE C0CDATA=LST
     101 . .QUIT
     102 .QUIT
     103 QUIT
     104 ;  ===================
     105GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
     106 N I,J,K,L
     107 S (I,K)=0
     108 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
     109 F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
     110 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
     111 . D   ; :L
     112 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
     113 . . S LST(NAM,"MSG",I)=L
     114 . . D GETTYP(I)
     115 . .QUIT
     116 .QUIT
     117 S LST(NAM,"NUMBER")=K
     118 QUIT
     119 ;  ===================
     120 ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
     121 ; The products of these emails are scanned to identify
     122 ;  the number of documents stored in the MIME package.
     123 ;  The protocol runs like this;
     124 ; Line 1 is the --separator
     125 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
     126 ; Line n+2 thru t-1 where t does NOT have "Content-"
     127 ; Line t   is Next Section Terminator, or Message Terminator, --separator
     128 ; Line t+1 should not exist in the data set if Message Terminator
     129 ; CON = "Content-"
     130 ; FLG = "--"
     131 ; SEP = FLG+7 or more characters  ; Separator
     132 ; END = SEP+FLG
     133 ; SGC = Segment Count
     134 ; Note: separator is a string of specific characters of
     135 ;        indeterminate length 
     136 ; LST() the transfer array
     137 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
     138 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
     139 ;
     140GETTYP(D0) ; Look for the goodies in the Mail
     141 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
     142 S CON="Content-"
     143 S FLG="--"
     144 S SEP=""  ; Start SEP as null, so we can use this to help identify the type
     145 S (BCN,CNT,D1,END,SGC)=0
     146 S XX=$G(^XMB(3.9,D0,0))
     147 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     148 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
     149 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     150 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
     151 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
     152 ; Get the folks the email is sent to.
     153 S D1=0
     154 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
     155 . N T
     156 . S T=+$G(^XMB(3.9,D0,1,D1,0))
     157 . S:T T=$P($G(^VA(200,+T,0)),"^")
     158 . S LST("TO",D1)=T
     159 . S T=$G(^XMB(3.9,D0,6,D1,0))
     160 . S:T T=$P($G(^VA(200,+T,0)),"^")
     161 . S:T="" T="<Unknown>"
     162 . S LST("TO NAME",D1)=T
     163 .QUIT
     164 ; Preload first Segment (0) with beginning on Line 1
     165 ;  if not a 64bit
     166 S LST(NAM,"MSG",D0,"SEG",0)=1
     167 S D1=.9999,SEP="--"
     168 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     169 . ; Clear any control characters (cr/lf/ff) off
     170 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     171 . ; Enter once to set the SEP to capture the separator
     172 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
     173 . . S SEP=X,END=X_FLG
     174 . . S (CNT,SGC)=1,BCN=0
     175 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     176 . .QUIT
     177 . ;
     178 . ; A new separator is set, process original
     179 . I X=SEP  D  QUIT
     180 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN
     181 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
     182 . . S SGC=SGC+1,BCN=0
     183 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     184 . .QUIT
     185 . ;
     186 . S BCN=BCN+$L(X)
     187 . I X[CON D  Q
     188 . . S J=$P($P(X,";"),CON,2)
     189 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
     190 . .QUIT
     191 . ;
     192 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
     193 .QUIT
     194 QUIT
     195 ;  ===================
     196NAME(NM) ; Return the name of the Sender
     197 N NAME
     198 S NAME="<Unknown Sender>"
     199 D
     200 . ; Look first for a value to use with the NEW PERSON file
     201 . ;
     202 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
     203 . ;
     204 . I $L(NM) S NAME=NM                    Q
     205 . ;
     206 . ; Else, pull the data from the message and display the foreign source
     207 . ;   of the message.
     208 . N T
     209 . S VAL=$G(^XMB(3.9,D0,.7))
     210 . S:VAL T=$P(^VA(200,VAL,0),U)
     211 . I $L($G(T)) S NAME=T                  Q
     212 . ;
     213 .QUIT
     214 QUIT NAME
     215 ;  ===================
     216TIME(Y) ; The time and date of the sending
     217 X ^DD("DD")
     218 QUIT Y
     219 ;  ===================
     220 ;  Segments in Message need to be identified and decoded properly
     221 ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
     222 ;   ARRAY will have the details of this one call
     223 ;   
     224 ; Inputs;
     225 ;   C0CINPUT    - The IEN of the message to expand
     226 ; Outputs;
     227 ;   C0CDATA     - Carrier for the returned structure of the Message
     228 ;  C0CDATA(D0,"SEG")=number of SEGMENTS
     229 ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details
     230 ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
     231 ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
     232 ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
     233 ;
     234DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
     235 N LST,D0,D1,U
     236 S U="^"
     237 S D0=+$G(C0CINPUT)
     238 I D0   D    QUIT
     239 . D GETTYP2(D0)
     240 . I $D(LST)   M C0CDATA(D0)=LST
     241 .QUIT
     242 QUIT
     243 ;  ===================
     244 ;  End note if needed
     245 ; MSK   - Set of characters that do not exist in 64 bit encoding
     246GETTYP2(D0) ; Try to get the types and MSK for the
     247 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
     248 S CON="Content-",U="^"
     249 S FLG="--"
     250 S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
     251 S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
     252 S (BCN,CNT,D1,END,SGC)=0
     253 S XX=$G(^XMB(3.9,D0,0))
     254 ; S K=$P(^XMB(3.9,D0,2,0),U,3)
     255 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     256 S LST("CREATED")=$$TIME($P(XX,U,3))
     257 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     258 S LST("FROM")=$$NAME(XXNM)
     259 ; Get the folks the email is sent to.
     260 S D1=0
     261 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
     262 . N I,T
     263 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
     264 . S:T T=$P($G(^VA(200,T,0)),"^")
     265 . S LST("TO",+D1)=T
     266 . S T=$G(^XMB(3.9,D0,6,+D1,0))
     267 . S:T="" T=$P($G(^VA(200,+T,0)),"^")
     268 . S:T="" T="<Unknown>"
     269 . S LST("TO NAME",D1)=T
     270 .QUIT
     271 ; Get the Header for the message
     272 S D1=0
     273 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
     274 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
     275 .QUIT
     276 ; Start walking the different sections
     277 S D1=.99999,SEP="--"
     278 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     279 . ; Clear any control characters (cr/lf/ff) off
     280 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     281 . ; Enter once to set the SEP to capture the separator
     282 . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2)  D   Q
     283 . . S SEP=X,END=X_FLG
     284 . . S (CNT,SGC)=1,BCN=0
     285 . . S LST("SEG",SGC)=D1
     286 . .QUIT
     287 . ;
     288 . ; A new SEGMENT separator is set, process original
     289 . I X=SEP  D  QUIT
     290 . . ; Save Current Values
     291 . . S LST("SEG",SGC,"SIZE")=BCN
     292 . . ;  Close this Segment and prepare to start a New Segment
     293 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
     294 . . ;  Put the result in LST("SEG",SGC,"XML")
     295 . . I $L(BF) D
     296 . . . S ZN=1
     297 . . . N I,T,TBF
     298 . . . S TBF=BF
     299 . . . F I=1:1:($L(TBF,"="))  D
     300 . . . . S BF=$P(TBF,"=",I)_"="
     301 . . . . I BF'="="  D DECODER
     302 . . . .QUIT
     303 . . . S BF=""
     304 . . .QUIT
     305 . . S SGC=SGC+1,BCN=0
     306 . . ; Incriment SGC to start a new Segment
     307 . . S LST("SEG",SGC)=D1
     308 . .QUIT
     309 . ;
     310 . ; Accumulate the 64 bit encoding
     311 . I X=$TR(X,MSK)&$L(X) D   Q
     312 . . S BF=BF_X
     313 . . S BCN=BCN+$L(X)
     314 . .QUIT
     315 . ;
     316 . ; Ending Condition, close out the Segment
     317 . I X=END D  QUIT
     318 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
     319 . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
     320 . .QUIT
     321 . ;
     322 . S BCN=BCN+$L(X)
     323 . ; Split out the Content Info
     324 . I X[CON D  Q
     325 . . S J=$P(X,CON,2)
     326 . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
     327 . .QUIT
     328 . ;
     329 . ; Everything else is Text
     330 . S LST("SEG",SGC,"TXT",D1)=X
     331 .QUIT
     332 QUIT
     333 ;  ===================
     334 ; Break down the Buffer Array so it can be saved.
     335 ;  BF is passed in.
     336DECODER ;
     337 N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE
     338 S ZBF=BF
     339 ;  Full Buffer, BF, now check for Encryption and Unpack
     340 F RCNT=1:1:$L(ZBF,"=")   D
     341 . N BF
     342 . S BF=$P(ZBF,"=",RCNT)
     343 . ;  Unpacking the 64 bit encoding
     344 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
     345 . D:$L(TBF)
     346 . . N XBF
     347 . . S BF=BF_"="
     348 . . D NORMAL(.XBF,.TBF)
     349 . . M LST("SEG",SGC,"XML",RCNT)=XBF
     350 . .QUIT
     351 .QUIT
     352 QUIT
     353 ;  ===================
     354 ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
     355 ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
     356 ;   >D NORMAL^C0CMAIL(.OUT,BF)
     357NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     358 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     359 ;
     360 N ZN,OUTBF
     361 S ZN=1
     362 S OUTBF(ZN)=$P(INXML,"><",ZN)_">"
     363 F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)=""  D  ;
     364 . S OUTBF(ZN)=OUTBF(ZN)_">"
     365 .QUIT
     366 M OUTXML=OUTBF
     367 QUIT
     368 ;  ===================
     369 ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
     370 ;  End note if needed
     371 QUIT
     372 ;  ===================

  • ccr/branches/ohum/p/C0CMAIL2.m

    r1330 r1332  
    11C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 Chris Richardson, Richardson Computer Research
    4         ; Modified 3110615@1040
    5         ;   rcr@rcresearch.us
    6         ;  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23         ;  ------------------
    24         ;Entry Points
    25         ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
    26         ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
    27         ;  Input:
    28         ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
    29         ;                      or "*" for all boxes, default is "IN" if missing]"
    30         ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
    31         ;                                     "*" for All or 9,999 maximum
    32         ;                    MALL?1.n = that number of the n most recent
    33         ;  Internally:
    34         ;    BNAM = Box Name
    35         ;  Output:
    36         ;    C0CDATA
    37         ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
    38         ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
    39         ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
    40         ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
    41         ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
    42         ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
    43         ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
    44         ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
    45         ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
    46         ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
    47         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
    48         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
    49         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
    50         ;
    51         ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
    52         ;   Input;
    53         ;     D0     - The IEN for the message in file 3.9, MESSAGE global
    54         ;   Output
    55         ;     OUTBF  - The array of your choice to save the expanded and decoded message.
    56         ;
    57 GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
    58         K:'$G(C0CDATA("KEEP")) C0CDATA
    59         N U
    60         S U="^"
    61         D:$G(C0CINPUT)
    62         . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
    63         . S INPUT=C0CINPUT
    64         . S DUZ=+INPUT
    65         . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
    66         . ;
    67         . D:$D(^XMB(3.7,DUZ,0))#2
    68         . . S MBLST=$P(INPUT,";",2)
    69         . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
    70         . . S:MALL["*" MALL=99999
    71         . . ; Only one of these can be correct
    72         . . D
    73         . . . ;  If nul, make it "IN" only
    74         . . . I MBLST="" D  QUIT
    75         . . . . S MBLST("IN")=0,I=0
    76         . . . . D GATHER(DUZ,"IN",.LST)
    77         . . . .QUIT
    78         . . . ;
    79         . . . ;  If "*", Get all Mailboxes and look for New Messages
    80         . . . I MBLST["*" D  QUIT
    81         . . . . N NAM,NUM
    82         . . . . S NUM=0
    83         . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
    84         . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
    85         . . . . . D GATHER(DUZ,NAM,.LST)
    86         . . . . .QUIT
    87         . . . .QUIT
    88         . . . ;
    89         . . . ;  If comma separated, look for mailboxes with new messages
    90         . . . I $L(MBLST,",")>1 D  QUIT
    91         . . . . S NAM=""
    92         . . . . N TN,V
    93         . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
    94         . . . . . I $L(V) D   QUIT
    95         . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
    96         . . . . . . S:NAM="" NAM=V
    97         . . . . . . D GATHER(DUZ,NAM,.LST)
    98         . . . . . .QUIT
    99         . . . . . ;
    100         . . . . . D ERROR("ER08")
    101         . . . . .QUIT
    102         . . . .QUIT
    103         . . . ;
    104         . . . ;  If only 1 mailbox named, go get it
    105         . . . I $L(MBLST)  D   QUIT
    106         . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
    107         . . . . ;
    108         . . . . D ERROR("ER07")
    109         . . .QUIT
    110         . . MERGE C0CDATA=LST
    111         . .QUIT
    112         .QUIT
    113         QUIT
    114         ;  ===================
    115 GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
    116         N I,J,K,L
    117         S (I,K)=0
    118         S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
    119         F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
    120         . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
    121         . D   ; :L
    122         . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
    123         . . S LST(NAM,"MSG",I)=L
    124         . . D GETTYP(I)
    125         . .QUIT
    126         .QUIT
    127         S LST(NAM,"NUMBER")=K
    128         QUIT
    129         ;  ===================
    130         ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
    131         ; The products of these emails are scanned to identify
    132         ;  the number of documents stored in the MIME package.
    133         ;  The protocol runs like this;
    134         ; Line 1 is the --separator
    135         ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
    136         ; Line n+2 thru t-1 where t does NOT have "Content-"
    137         ; Line t   is Next Section Terminator, or Message Terminator, --separator
    138         ; Line t+1 should not exist in the data set if Message Terminator
    139         ; CON = "Content-"
    140         ; FLG = "--"
    141         ; SEP = FLG+7 or more characters  ; Separator
    142         ; END = SEP+FLG
    143         ; SGC = Segment Count
    144         ; Note: separator is a string of specific characters of
    145         ;        indeterminate length 
    146         ; LST() the transfer array
    147         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
    148         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
    149         ;
    150 GETTYP(D0)      ; Look for the goodies in the Mail
    151         N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
    152         S CON="Content-"
    153         S FLG="--"
    154         S SEP=""  ; Start SEP as null, so we can use this to help identify the type
    155         S (BCN,CNT,D1,END,SGC)=0
    156         S XX=$G(^XMB(3.9,D0,0))
    157         S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    158         S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
    159         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    160         S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
    161         S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
    162         ; Get the folks the email is sent to.
    163         S D1=0
    164         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
    165         . N T
    166         . S T=+$G(^XMB(3.9,D0,1,D1,0))
    167         . S:T T=$P($G(^VA(200,+T,0)),"^")
    168         . S LST("TO",D1)=T
    169         . S T=$G(^XMB(3.9,D0,6,D1,0))
    170         . S:T T=$P($G(^VA(200,+T,0)),"^")
    171         . S:T="" T="<Unknown>"
    172         . S LST("TO NAME",D1)=T
    173         .QUIT
    174         ; Preload first Segment (0) with beginning on Line 1
    175         ;  if not a 64bit
    176         S LST(NAM,"MSG",D0,"SEG",0)=1
    177         S D1=.9999,SEP="@@"
    178         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    179         . ; Clear any control characters (cr/lf/ff) off
    180         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    181         . ; Enter once to set the SEP to capture the separator
    182         . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
    183         . . S SEP=X,END=X_FLG
    184         . . S (CNT,SGC)=1,BCN=0
    185         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    186         . .QUIT
    187         . ;
    188         . ; A new separator is set, process original
    189         . I X=SEP  D  QUIT
    190         . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
    191         . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
    192         . . S SGC=SGC+1,BCN=0
    193         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    194         . .QUIT
    195         . ;
    196         . S BCN=BCN+$L(X)
    197         . I X[CON D  Q
    198         . . S J=$P($P(X,";"),CON,2)
    199         . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
    200         . .QUIT
    201         . ;
    202         . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
    203         .QUIT
    204         QUIT
    205         ;  ===================
    206 NAME(NM)        ; Return the name of the Sender
    207         N NAME
    208         S NAME="<Unknown Sender>"
    209         D
    210         . ; Look first for a value to use with the NEW PERSON file
    211         . ;
    212         . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
    213         . ;
    214         . I $L(NM) S NAME=NM                    Q
    215         . ;
    216         . ; Else, pull the data from the message and display the foreign source
    217         . ;   of the message.
    218         . N T
    219         . S VAL=$G(^XMB(3.9,D0,.7))
    220         . S:VAL T=$P(^VA(200,VAL,0),U)
    221         . I $L($G(T)) S NAME=T                  Q
    222         . ;
    223         .QUIT
    224         QUIT NAME
    225         ;  ===================
    226 TIME(Y) ; The time and date of the sending
    227         X ^DD("DD")
    228         QUIT Y
    229         ;  ===================
    230         ;  Segments in Message need to be identified and decoded properly
    231         ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
    232         ;   ARRAY will have the details of this one call
    233         ;   
    234         ; Inputs;
    235         ;   C0CINPUT    - The IEN of the message to expand
    236         ; Outputs;
    237         ;   C0CDATA     - Carrier for the returned structure of the Message
    238         ;  C0CDATA(D0,"SEG")=number of SEGMENTS
    239         ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
    240         ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
    241         ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
    242         ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
    243         ;
    244 DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
    245         N LST,D0,D1,U
    246         S U="^"
    247         S D0=+$G(C0CINPUT)
    248         I D0   D    QUIT
    249         . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
    250         . ;
    251         . D GETTYP2(D0)
    252         . I $D(LST)   M C0CDATA(D0)=LST  Q
    253         . ;
    254         . D ERROR("ER02")
    255         .QUIT
    256         QUIT
    257         ;  ===================
    258         ;  End note if needed
    259         ; MSK   - Set of characters that do not exist in 64 bit encoding
    260 GETTYP2(D0)     ; Try to get the types and MSK for the
    261         N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
    262         S CON="Content-",U="^"
    263         S FLG="--"
    264         S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
    265         S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
    266         S (BCN,CNT,D1,END,SGC)=0
    267         S XX=$G(^XMB(3.9,D0,0))
    268         ; S K=$P(^XMB(3.9,D0,2,0),U,3)
    269         S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    270         S LST("CREATED")=$$TIME($P(XX,U,3))
    271         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    272         S LST("FROM")=$$NAME(XXNM)
    273         ; Get the folks the email is sent to.
    274         S D1=0
    275         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
    276         . N I,T
    277         . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
    278         . S:T T=$P($G(^VA(200,T,0)),"^")
    279         . S LST("TO",+D1)=T
    280         . S T=$G(^XMB(3.9,D0,6,+D1,0))
    281         . S:T="" T=$P($G(^VA(200,+T,0)),"^")
    282         . S:T="" T="<Unknown>"
    283         . S LST("TO NAME",D1)=T
    284         .QUIT
    285         ; Get the Header for the message
    286         S D1=0
    287         F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
    288         . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
    289         .QUIT
    290         ; Start walking the different sections
    291         S D1=.99999,SEP="@@",SGC=0
    292         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    293         . ; Clear any control characters (cr/lf/ff) off
    294         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    295         . ; Enter once to set the SEP to capture the separator
    296         . I (SEP="@@")&(X?2."--"5.AN.E)  D   Q
    297         . . I $L(X,FLG)>2 D ERROR("ER10")
    298         . . S SEP=X,END=X_FLG
    299         . . S (CNT,SGC)=1,BCN=0
    300         . . S LST("SEG",SGC)=D1
    301         . .QUIT
    302         . ;
    303         . ; A new SEGMENT separator is set, process original
    304         . I X=SEP  D  QUIT
    305         . . ; Save Current Values
    306         . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
    307         . . ;  Close this Segment and prepare to start a New Segment
    308         . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
    309         . . ;  Put the result in LST("SEG",SGC,"XML")
    310         . . I $L(BF) D
    311         . . . S ZN=1
    312         . . . N I,T,TBF
    313         . . . S TBF=BF
    314         . . . F I=1:1:($L(TBF,"="))  D
    315         . . . . S BF=$P(TBF,"=",I)_"="
    316         . . . . I BF'="="  D DECODER
    317         . . . .QUIT
    318         . . . S BF=""
    319         . . .QUIT
    320         . . S SGC=SGC+1,BCN=0
    321         . . ; Incriment SGC to start a new Segment
    322         . . S LST("SEG",SGC)=D1
    323         . .QUIT
    324         . ;
    325         . ; Accumulate the 64 bit encoding
    326         . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
    327         . ;
    328         . ; Ending Condition, close out the Segment
    329         . I X=END D  QUIT
    330         . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
    331         . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
    332         . .QUIT
    333         . ;
    334         . ; Accumulate the lengths of other lines of the message
    335         . S BCN=BCN+$L(X)
    336         . ; Split out the Content Info
    337         . I X[CON D  Q
    338         . . S J=$P(X,CON,2)
    339         . . I J[" boundary=" D
    340         . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG
    341         . . . Q:SEP?2"-"5.ANP
    342         . . . ;
    343         . . . D ERROR("ER11")
    344         . . . Q:SEP'[" "
    345         . . . ;
    346         . . . D ERROR("ER12")
    347         . . .QUIT
    348         . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
    349         . .QUIT
    350         . ;
    351         . ; Everything else is Text, Check for CCR/CCD.
    352         . N KK,UBF
    353         . D
    354         . . S UBF=$$UPPER(X)
    355         . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
    356         . . ;
    357         . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
    358         . .QUIT
    359         . ; Look for directives in the text before it gets published
    360         . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
    361         . ;  but there may be situations where the line has been wrapped.
    362         . D:X["=3D"
    363         . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
    364         . .QUIT
    365         . S LST("SEG",SGC,"TXT",D1)=X
    366         .QUIT
    367         QUIT
    368         ;  ===================
    369         ; Break down the Buffer Array so it can be saved.
    370         ;  BF is passed in.
    371 DECODER ;
    372         N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
    373         S ZBF=BF
    374         ;  Full Buffer, BF, now check for Encryption and Unpack
    375         F RCNT=1:1:$L(ZBF,"=")   D
    376         . N BF
    377         . S BF=$P(ZBF,"=",RCNT)
    378         . ;  Unpacking the 64 bit encoding
    379         . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
    380         . D:$L(TBF)
    381         . . N C,OK,OKCNT,KK,XBF,UBF
    382         . . D
    383         . . . S UBF=$$UPPER(TBF)
    384         . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
    385         . . . ;
    386         . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
    387         . . .QUIT
    388         . . ; Check for Bad Signature Decoding, after 100 bad characters
    389         . . S OK=1,OKCNT=0
    390         . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
    391         . . ;
    392         . . D
    393         . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
    394         . . . ;
    395         . . . S BF=BF_"="
    396         . . . D NORMAL(.XBF,.TBF)
    397         . . .QUIT
    398         . . M LST("SEG",SGC,"XML",RCNT)=XBF
    399         . .QUIT
    400         .QUIT
    401         QUIT
    402         ;  ===================
    403         ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
    404         ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
    405         ;   >D NORMAL^C0CMAIL(.OUT,BF)
    406 NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    407         ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    408         ;
    409         N ZN,OUTBF,XX,ZSEP
    410         S INXML=$TR(INXML,$C(10,12,13))
    411         S ZN=1,ZSEP=">"
    412         S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
    413         F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
    414         . S XX=$P(INXML,"><",ZN)
    415         . S:$E($RE(XX))=">" ZSEP=""
    416         . Q:XX=""
    417         . ;
    418         . S XX="<"_XX_ZSEP
    419         . D
    420         . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
    421         . . ;
    422         . . D ERROR("ER05")
    423         . . F ZL=ZL+1:1 D   Q:XX=""
    424         . . .  N XL
    425         . . .  S XL=$E(XX,1,4000)
    426         . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
    427         . . .  S OUTBF(ZL)=XL
    428         . . .QUIT
    429         . .QUIT
    430         .QUIT
    431         M OUTXML=OUTBF
    432         QUIT
    433         ;  ===================
    434 UPPER(X)        ; Convert any lowercase letters to Uppercase letters
    435         QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    436         ;  ===================
    437         ; EN is a counter that remains between error events
    438 ERROR(ER)       ; Error Handler
    439         N TXXQ,XXXQ
    440         S XXXQ="Unknown Error Encountered = "_ER
    441         S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
    442         I TXXQ'=""  D
    443         . I TXXQ["_" X "S TXXQ="_TXXQ
    444         . S XXXQ=TXXQ
    445         .QUIT
    446         S EN(ER)=$G(EN(ER))+1
    447         S LST("ERR",ER,EN(ER))=XXXQ
    448         QUIT
    449         ;  ===================
    450 ER01    ;;Message Missing
    451 ER02    ;;Message Text Missing
    452 ER03    ;;Message Not Identifiable
    453 ER04    ;;Segment is too large
    454 ER05    ;;Mailbox Missing
    455 ER06    ;;"User Missing = "_$G(DUZ)
    456 ER07    ;;"Bad DUZ = "_DUZ
    457 ER08    ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
    458 ER10    ;;"Bad Separator found = "_X
    459 ER11    ;;"Non-Standard Separator Found:>"_$G(J)
    460 ER12    ;;"Spaces are not allowed in Separators:>"_$G(J)
    461         ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
    462         ;  End note if needed
    463         QUIT
    464         ;  ===================
     2V ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2011 Chris Richardson, Richardson Computer Research
     4 ; Modified 3110615@1040
     5 ;   rcr@rcresearch.us
     6 ;  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23 ;  ------------------
     24 ;Entry Points
     25 ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
     26 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
     27 ;  Input:
     28 ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
     29 ;                      or "*" for all boxes, default is "IN" if missing]"
     30 ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
     31 ;                                     "*" for All or 9,999 maximum
     32 ;                    MALL?1.n = that number of the n most recent
     33 ;  Internally:
     34 ;    BNAM = Box Name
     35 ;  Output:
     36 ;    C0CDATA
     37 ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
     38 ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
     39 ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
     40 ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
     41 ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
     42 ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
     43 ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
     44 ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
     45 ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
     46 ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
     47 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
     48 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
     49 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
     50 ;
     51 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
     52 ;   Input;
     53 ;     D0     - The IEN for the message in file 3.9, MESSAGE global
     54 ;   Output
     55 ;     OUTBF  - The array of your choice to save the expanded and decoded message.
     56 ;
     57GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
     58 K:'$G(C0CDATA("KEEP")) C0CDATA
     59 N U
     60 S U="^"
     61 D:$G(C0CINPUT)
     62 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
     63 . S INPUT=C0CINPUT
     64 . S DUZ=+INPUT
     65 . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
     66 . ;
     67 . D:$D(^XMB(3.7,DUZ,0))#2
     68 . . S MBLST=$P(INPUT,";",2)
     69 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
     70 . . S:MALL["*" MALL=99999
     71 . . ; Only one of these can be correct
     72 . . D
     73 . . . ;  If nul, make it "IN" only
     74 . . . I MBLST="" D  QUIT
     75 . . . . S MBLST("IN")=0,I=0
     76 . . . . D GATHER(DUZ,"IN",.LST)
     77 . . . .QUIT
     78 . . . ;
     79 . . . ;  If "*", Get all Mailboxes and look for New Messages
     80 . . . I MBLST["*" D  QUIT
     81 . . . . N NAM,NUM
     82 . . . . S NUM=0
     83 . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
     84 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
     85 . . . . . D GATHER(DUZ,NAM,.LST)
     86 . . . . .QUIT
     87 . . . .QUIT
     88 . . . ;
     89 . . . ;  If comma separated, look for mailboxes with new messages
     90 . . . I $L(MBLST,",")>1 D  QUIT
     91 . . . . S NAM=""
     92 . . . . N TN,V
     93 . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
     94 . . . . . I $L(V) D   QUIT
     95 . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
     96 . . . . . . S:NAM="" NAM=V
     97 . . . . . . D GATHER(DUZ,NAM,.LST)
     98 . . . . . .QUIT
     99 . . . . . ;
     100 . . . . . D ERROR("ER08")
     101 . . . . .QUIT
     102 . . . .QUIT
     103 . . . ;
     104 . . . ;  If only 1 mailbox named, go get it
     105 . . . I $L(MBLST)  D   QUIT
     106 . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
     107 . . . . ;
     108 . . . . D ERROR("ER07")
     109 . . .QUIT
     110 . . MERGE C0CDATA=LST
     111 . .QUIT
     112 .QUIT
     113 QUIT
     114 ;  ===================
     115GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
     116 N I,J,K,L
     117 S (I,K)=0
     118 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
     119 F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
     120 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
     121 . D   ; :L
     122 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
     123 . . S LST(NAM,"MSG",I)=L
     124 . . D GETTYP(I)
     125 . .QUIT
     126 .QUIT
     127 S LST(NAM,"NUMBER")=K
     128 QUIT
     129 ;  ===================
     130 ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
     131 ; The products of these emails are scanned to identify
     132 ;  the number of documents stored in the MIME package.
     133 ;  The protocol runs like this;
     134 ; Line 1 is the --separator
     135 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
     136 ; Line n+2 thru t-1 where t does NOT have "Content-"
     137 ; Line t   is Next Section Terminator, or Message Terminator, --separator
     138 ; Line t+1 should not exist in the data set if Message Terminator
     139 ; CON = "Content-"
     140 ; FLG = "--"
     141 ; SEP = FLG+7 or more characters  ; Separator
     142 ; END = SEP+FLG
     143 ; SGC = Segment Count
     144 ; Note: separator is a string of specific characters of
     145 ;        indeterminate length 
     146 ; LST() the transfer array
     147 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
     148 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
     149 ;
     150GETTYP(D0) ; Look for the goodies in the Mail
     151 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
     152 S CON="Content-"
     153 S FLG="--"
     154 S SEP=""  ; Start SEP as null, so we can use this to help identify the type
     155 S (BCN,CNT,D1,END,SGC)=0
     156 S XX=$G(^XMB(3.9,D0,0))
     157 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     158 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
     159 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     160 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
     161 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
     162 ; Get the folks the email is sent to.
     163 S D1=0
     164 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
     165 . N T
     166 . S T=+$G(^XMB(3.9,D0,1,D1,0))
     167 . S:T T=$P($G(^VA(200,+T,0)),"^")
     168 . S LST("TO",D1)=T
     169 . S T=$G(^XMB(3.9,D0,6,D1,0))
     170 . S:T T=$P($G(^VA(200,+T,0)),"^")
     171 . S:T="" T="<Unknown>"
     172 . S LST("TO NAME",D1)=T
     173 .QUIT
     174 ; Preload first Segment (0) with beginning on Line 1
     175 ;  if not a 64bit
     176 S LST(NAM,"MSG",D0,"SEG",0)=1
     177 S D1=.9999,SEP="@@"
     178 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     179 . ; Clear any control characters (cr/lf/ff) off
     180 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     181 . ; Enter once to set the SEP to capture the separator
     182 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
     183 . . S SEP=X,END=X_FLG
     184 . . S (CNT,SGC)=1,BCN=0
     185 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     186 . .QUIT
     187 . ;
     188 . ; A new separator is set, process original
     189 . I X=SEP  D  QUIT
     190 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
     191 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
     192 . . S SGC=SGC+1,BCN=0
     193 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     194 . .QUIT
     195 . ;
     196 . S BCN=BCN+$L(X)
     197 . I X[CON D  Q
     198 . . S J=$P($P(X,";"),CON,2)
     199 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
     200 . .QUIT
     201 . ;
     202 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
     203 .QUIT
     204 QUIT
     205 ;  ===================
     206NAME(NM) ; Return the name of the Sender
     207 N NAME
     208 S NAME="<Unknown Sender>"
     209 D
     210 . ; Look first for a value to use with the NEW PERSON file
     211 . ;
     212 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
     213 . ;
     214 . I $L(NM) S NAME=NM                    Q
     215 . ;
     216 . ; Else, pull the data from the message and display the foreign source
     217 . ;   of the message.
     218 . N T
     219 . S VAL=$G(^XMB(3.9,D0,.7))
     220 . S:VAL T=$P(^VA(200,VAL,0),U)
     221 . I $L($G(T)) S NAME=T                  Q
     222 . ;
     223 .QUIT
     224 QUIT NAME
     225 ;  ===================
     226TIME(Y) ; The time and date of the sending
     227 X ^DD("DD")
     228 QUIT Y
     229 ;  ===================
     230 ;  Segments in Message need to be identified and decoded properly
     231 ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
     232 ;   ARRAY will have the details of this one call
     233 ;   
     234 ; Inputs;
     235 ;   C0CINPUT    - The IEN of the message to expand
     236 ; Outputs;
     237 ;   C0CDATA     - Carrier for the returned structure of the Message
     238 ;  C0CDATA(D0,"SEG")=number of SEGMENTS
     239 ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
     240 ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
     241 ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
     242 ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
     243 ;
     244DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
     245 N LST,D0,D1,U
     246 S U="^"
     247 S D0=+$G(C0CINPUT)
     248 I D0   D    QUIT
     249 . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
     250 . ;
     251 . D GETTYP2(D0)
     252 . I $D(LST)   M C0CDATA(D0)=LST  Q
     253 . ;
     254 . D ERROR("ER02")
     255 .QUIT
     256 QUIT
     257 ;  ===================
     258 ;  End note if needed
     259 ; MSK   - Set of characters that do not exist in 64 bit encoding
     260GETTYP2(D0) ; Try to get the types and MSK for the
     261 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
     262 S CON="Content-",U="^"
     263 S FLG="--"
     264 S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
     265 S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
     266 S (BCN,CNT,D1,END,SGC)=0
     267 S XX=$G(^XMB(3.9,D0,0))
     268 ; S K=$P(^XMB(3.9,D0,2,0),U,3)
     269 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     270 S LST("CREATED")=$$TIME($P(XX,U,3))
     271 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     272 S LST("FROM")=$$NAME(XXNM)
     273 ; Get the folks the email is sent to.
     274 S D1=0
     275 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
     276 . N I,T
     277 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
     278 . S:T T=$P($G(^VA(200,T,0)),"^")
     279 . S LST("TO",+D1)=T
     280 . S T=$G(^XMB(3.9,D0,6,+D1,0))
     281 . S:T="" T=$P($G(^VA(200,+T,0)),"^")
     282 . S:T="" T="<Unknown>"
     283 . S LST("TO NAME",D1)=T
     284 .QUIT
     285 ; Get the Header for the message
     286 S D1=0
     287 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
     288 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
     289 .QUIT
     290 ; Start walking the different sections
     291 S D1=.99999,SEP="@@",SGC=0
     292 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     293 . ; Clear any control characters (cr/lf/ff) off
     294 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     295 . ; Enter once to set the SEP to capture the separator
     296 . I (SEP="@@")&(X?2."--"5.AN.E)  D   Q
     297 . . I $L(X,FLG)>2 D ERROR("ER10")
     298 . . S SEP=X,END=X_FLG
     299 . . S (CNT,SGC)=1,BCN=0
     300 . . S LST("SEG",SGC)=D1
     301 . .QUIT
     302 . ;
     303 . ; A new SEGMENT separator is set, process original
     304 . I X=SEP  D  QUIT
     305 . . ; Save Current Values
     306 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
     307 . . ;  Close this Segment and prepare to start a New Segment
     308 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
     309 . . ;  Put the result in LST("SEG",SGC,"XML")
     310 . . I $L(BF) D
     311 . . . S ZN=1
     312 . . . N I,T,TBF
     313 . . . S TBF=BF
     314 . . . F I=1:1:($L(TBF,"="))  D
     315 . . . . S BF=$P(TBF,"=",I)_"="
     316 . . . . I BF'="="  D DECODER
     317 . . . .QUIT
     318 . . . S BF=""
     319 . . .QUIT
     320 . . S SGC=SGC+1,BCN=0
     321 . . ; Incriment SGC to start a new Segment
     322 . . S LST("SEG",SGC)=D1
     323 . .QUIT
     324 . ;
     325 . ; Accumulate the 64 bit encoding
     326 . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
     327 . ;
     328 . ; Ending Condition, close out the Segment
     329 . I X=END D  QUIT
     330 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
     331 . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
     332 . .QUIT
     333 . ;
     334 . ; Accumulate the lengths of other lines of the message
     335 . S BCN=BCN+$L(X)
     336 . ; Split out the Content Info
     337 . I X[CON D  Q
     338 . . S J=$P(X,CON,2)
     339 . . I J[" boundary=" D
     340 . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG
     341 . . . Q:SEP?2"-"5.ANP
     342 . . . ;
     343 . . . D ERROR("ER11")
     344 . . . Q:SEP'[" "
     345 . . . ;
     346 . . . D ERROR("ER12")
     347 . . .QUIT
     348 . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
     349 . .QUIT
     350 . ;
     351 . ; Everything else is Text, Check for CCR/CCD.
     352 . N KK,UBF
     353 . D
     354 . . S UBF=$$UPPER(X)
     355 . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
     356 . . ;
     357 . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
     358 . .QUIT
     359 . ; Look for directives in the text before it gets published
     360 . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
     361 . ;  but there may be situations where the line has been wrapped.
     362 . D:X["=3D"
     363 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
     364 . .QUIT
     365 . S LST("SEG",SGC,"TXT",D1)=X
     366 .QUIT
     367 QUIT
     368 ;  ===================
     369 ; Break down the Buffer Array so it can be saved.
     370 ;  BF is passed in.
     371DECODER ;
     372 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
     373 S ZBF=BF
     374 ;  Full Buffer, BF, now check for Encryption and Unpack
     375 F RCNT=1:1:$L(ZBF,"=")   D
     376 . N BF
     377 . S BF=$P(ZBF,"=",RCNT)
     378 . ;  Unpacking the 64 bit encoding
     379 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
     380 . D:$L(TBF)
     381 . . N C,OK,OKCNT,KK,XBF,UBF
     382 . . D
     383 . . . S UBF=$$UPPER(TBF)
     384 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
     385 . . . ;
     386 . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
     387 . . .QUIT
     388 . . ; Check for Bad Signature Decoding, after 100 bad characters
     389 . . S OK=1,OKCNT=0
     390 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
     391 . . ;
     392 . . D
     393 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
     394 . . . ;
     395 . . . S BF=BF_"="
     396 . . . D NORMAL(.XBF,.TBF)
     397 . . .QUIT
     398 . . M LST("SEG",SGC,"XML",RCNT)=XBF
     399 . .QUIT
     400 .QUIT
     401 QUIT
     402 ;  ===================
     403 ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
     404 ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
     405 ;   >D NORMAL^C0CMAIL(.OUT,BF)
     406NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     407 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     408 ;
     409 N ZN,OUTBF,XX,ZSEP
     410 S INXML=$TR(INXML,$C(10,12,13))
     411 S ZN=1,ZSEP=">"
     412 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
     413 F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
     414 . S XX=$P(INXML,"><",ZN)
     415 . S:$E($RE(XX))=">" ZSEP=""
     416 . Q:XX=""
     417 . ;
     418 . S XX="<"_XX_ZSEP
     419 . D
     420 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
     421 . . ;
     422 . . D ERROR("ER05")
     423 . . F ZL=ZL+1:1 D   Q:XX=""
     424 . . .  N XL
     425 . . .  S XL=$E(XX,1,4000)
     426 . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
     427 . . .  S OUTBF(ZL)=XL
     428 . . .QUIT
     429 . .QUIT
     430 .QUIT
     431 M OUTXML=OUTBF
     432 QUIT
     433 ;  ===================
     434UPPER(X) ; Convert any lowercase letters to Uppercase letters
     435 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     436 ;  ===================
     437 ; EN is a counter that remains between error events
     438ERROR(ER) ; Error Handler
     439 N TXXQ,XXXQ
     440 S XXXQ="Unknown Error Encountered = "_ER
     441 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
     442 I TXXQ'=""  D
     443 . I TXXQ["_" X "S TXXQ="_TXXQ
     444 . S XXXQ=TXXQ
     445 .QUIT
     446 S EN(ER)=$G(EN(ER))+1
     447 S LST("ERR",ER,EN(ER))=XXXQ
     448 QUIT
     449 ;  ===================
     450ER01 ;;Message Missing
     451ER02 ;;Message Text Missing
     452ER03 ;;Message Not Identifiable
     453ER04 ;;Segment is too large
     454ER05 ;;Mailbox Missing
     455ER06 ;;"User Missing = "_$G(DUZ)
     456ER07 ;;"Bad DUZ = "_DUZ
     457ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
     458ER10 ;;"Bad Separator found = "_X
     459ER11 ;;"Non-Standard Separator Found:>"_$G(J)
     460ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
     461 ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
     462 ;  End note if needed
     463 QUIT
     464 ;  ===================

  • ccr/branches/ohum/p/C0CMAIL3.m

    r1330 r1332  
    11C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 Chris Richardson, Richardson Computer Research
    4         ; Modified 3110619@2038
    5         ;   rcr@rcresearch.us
    6         ;  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23         ;  ------------------
    24         ;Entry Points
    25         ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
    26         ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
    27         ;  Input:
    28         ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
    29         ;                      or "*" for all boxes, default is "IN" if missing]"
    30         ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
    31         ;                                     "*" for All or 9,999 maximum
    32         ;                    MALL?1.n = that number of the n most recent
    33         ;  Internally:
    34         ;    BNAM = Box Name
    35         ;  Output:
    36         ;    C0CDATA
    37         ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
    38         ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
    39         ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
    40         ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
    41         ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
    42         ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
    43         ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
    44         ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
    45         ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
    46         ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
    47         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
    48         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
    49         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
    50         ;
    51         ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
    52         ;   Input;
    53         ;     D0     - The IEN for the message in file 3.9, MESSAGE global
    54         ;   Output
    55         ;     OUTBF  - The array of your choice to save the expanded and decoded message.
    56         ;
    57 GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
    58         K:'$G(C0CDATA("KEEP")) C0CDATA
    59         N U
    60         S U="^"
    61         D:$G(C0CINPUT)
    62         . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
    63         . S INPUT=C0CINPUT
    64         . S DUZ=+INPUT
    65         . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
    66         . ;
    67         . D:$D(^XMB(3.7,DUZ,0))#2
    68         . . S MBLST=$P(INPUT,";",2)
    69         . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
    70         . . S:MALL["*" MALL=99999
    71         . . ; Only one of these can be correct
    72         . . D
    73         . . . ;  If nul, make it "IN" only
    74         . . . I MBLST="" D  QUIT
    75         . . . . S MBLST("IN")=0,I=0
    76         . . . . D GATHER(DUZ,"IN",.LST)
    77         . . . .QUIT
    78         . . . ;
    79         . . . ;  If "*", Get all Mailboxes and look for New Messages
    80         . . . I MBLST["*" D  QUIT
    81         . . . . N NAM,NUM
    82         . . . . S NUM=0
    83         . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
    84         . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
    85         . . . . . D GATHER(DUZ,NAM,.LST)
    86         . . . . .QUIT
    87         . . . .QUIT
    88         . . . ;
    89         . . . ;  If comma separated, look for mailboxes with new messages
    90         . . . I $L(MBLST,",")>1 D  QUIT
    91         . . . . S NAM=""
    92         . . . . N TN,V
    93         . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
    94         . . . . . I $L(V) D   QUIT
    95         . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
    96         . . . . . . S:NAM="" NAM=V
    97         . . . . . . D GATHER(DUZ,NAM,.LST)
    98         . . . . . .QUIT
    99         . . . . . ;
    100         . . . . . D ERROR("ER08")
    101         . . . . .QUIT
    102         . . . .QUIT
    103         . . . ;
    104         . . . ;  If only 1 mailbox named, go get it
    105         . . . I $L(MBLST)  D   QUIT
    106         . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
    107         . . . . ;
    108         . . . . D ERROR("ER07")
    109         . . .QUIT
    110         . . MERGE C0CDATA=LST
    111         . .QUIT
    112         .QUIT
    113         QUIT
    114         ;  ===================
    115 GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
    116         N I,J,K,L
    117         S (I,K)=0
    118         S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
    119         F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
    120         . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
    121         . D   ; :L
    122         . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
    123         . . S LST(NAM,"MSG",I)=L
    124         . . D GETTYP(I)
    125         . .QUIT
    126         .QUIT
    127         S LST(NAM,"NUMBER")=K
    128         QUIT
    129         ;  ===================
    130         ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
    131         ; The products of these emails are scanned to identify
    132         ;  the number of documents stored in the MIME package.
    133         ;  The protocol runs like this;
    134         ; Line 1 is the --separator
    135         ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
    136         ; Line n+2 thru t-1 where t does NOT have "Content-"
    137         ; Line t   is Next Section Terminator, or Message Terminator, --separator
    138         ; Line t+1 should not exist in the data set if Message Terminator
    139         ; CON = "Content-"
    140         ; FLG = "--"
    141         ; SEP = FLG+7 or more characters  ; Separator
    142         ; END = SEP+FLG
    143         ; SGC = Segment Count
    144         ; Note: separator is a string of specific characters of
    145         ;        indeterminate length 
    146         ; LST() the transfer array
    147         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
    148         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
    149         ;
    150 GETTYP(D0)      ; Look for the goodies in the Mail
    151         N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
    152         S CON="Content-"
    153         S FLG="--"
    154         S SEP=""  ; Start SEP as null, so we can use this to help identify the type
    155         S (BCN,CNT,D1,END,SGC)=0
    156         S XX=$G(^XMB(3.9,D0,0))
    157         S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    158         S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
    159         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    160         S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
    161         S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
    162         ; Get the folks the email is sent to.
    163         S D1=0
    164         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
    165         . N T
    166         . S T=+$G(^XMB(3.9,D0,1,D1,0))
    167         . S:T T=$P($G(^VA(200,+T,0)),"^")
    168         . S LST("TO",D1)=T
    169         . S T=$G(^XMB(3.9,D0,6,D1,0))
    170         . S:T T=$P($G(^VA(200,+T,0)),"^")
    171         . S:T="" T="<Unknown>"
    172         . S LST("TO NAME",D1)=T
    173         .QUIT
    174         ; Preload first Segment (0) with beginning on Line 1
    175         ;  if not a 64bit
    176         S LST(NAM,"MSG",D0,"SEG",0)=1
    177         S D1=.9999,SEP="@@"
    178         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    179         . ; Clear any control characters (cr/lf/ff) off
    180         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    181         . ; Enter once to set the SEP to capture the separator
    182         . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
    183         . . S SEP=X,END=X_FLG
    184         . . S (CNT,SGC)=1,BCN=0
    185         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    186         . .QUIT
    187         . ;
    188         . ; A new separator is set, process original
    189         . I X=SEP  D  QUIT
    190         . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
    191         . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
    192         . . S SGC=SGC+1,BCN=0
    193         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    194         . .QUIT
    195         . ;
    196         . S BCN=BCN+$L(X)
    197         . I X[CON D  Q
    198         . . S J=$P($P(X,";"),CON,2)
    199         . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
    200         . .QUIT
    201         . ;
    202         . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
    203         .QUIT
    204         QUIT
    205         ;  ===================
    206 NAME(NM)        ; Return the name of the Sender
    207         N NAME
    208         S NAME="<Unknown Sender>"
    209         D
    210         . ; Look first for a value to use with the NEW PERSON file
    211         . ;
    212         . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
    213         . ;
    214         . I $L(NM) S NAME=NM                    Q
    215         . ;
    216         . ; Else, pull the data from the message and display the foreign source
    217         . ;   of the message.
    218         . N T
    219         . S VAL=$G(^XMB(3.9,D0,.7))
    220         . S:VAL T=$P(^VA(200,VAL,0),U)
    221         . I $L($G(T)) S NAME=T                  Q
    222         . ;
    223         .QUIT
    224         QUIT NAME
    225         ;  ===================
    226 TIME(Y) ; The time and date of the sending
    227         X ^DD("DD")
    228         QUIT Y
    229         ;  ===================
    230         ;  Segments in Message need to be identified and decoded properly
    231         ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
    232         ;   ARRAY will have the details of this one call
    233         ;   
    234         ; Inputs;
    235         ;   C0CINPUT    - The IEN of the message to expand
    236         ; Outputs;
    237         ;   C0CDATA     - Carrier for the returned structure of the Message
    238         ;  C0CDATA(D0,"SEG")=number of SEGMENTS
    239         ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
    240         ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
    241         ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
    242         ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
    243         ;
    244 DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
    245         N LST,D0,D1,U
    246         S U="^"
    247         S D0=+$G(C0CINPUT)
    248         I D0   D    QUIT
    249         . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
    250         . ;
    251         . D GETTYP2(D0)
    252         . I $D(LST)   M C0CDATA(D0)=LST  Q
    253         . ;
    254         . D ERROR("ER02")
    255         .QUIT
    256         QUIT
    257         ;  ===================
    258         ;  End note if needed
    259         ; MSK   - Set of characters that do not exist in 64 bit encoding
    260 GETTYP2(D0)     ; Try to get the types and MSK for the
    261         N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
    262         S CON="Content-",U="^"
    263         S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
    264         S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
    265         S (BCN,CNT,D1,END,SGC)=0
    266         S XX=$G(^XMB(3.9,D0,0))
    267         ; S K=$P(^XMB(3.9,D0,2,0),U,3)
    268         S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    269         S LST("CREATED")=$$TIME($P(XX,U,3))
    270         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    271         S LST("FROM")=$$NAME(XXNM)
    272         ; Get the folks the email is sent to.
    273         S D1=0
    274         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
    275         . N I,T
    276         . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
    277         . S:T T=$P($G(^VA(200,T,0)),"^")
    278         . S LST("TO",+D1)=T
    279         . S T=$G(^XMB(3.9,D0,6,+D1,0))
    280         . S:T="" T=$P($G(^VA(200,+T,0)),"^")
    281         . S:T="" T="<Unknown>"
    282         . S LST("TO NAME",D1)=T
    283         .QUIT
    284         ; Get the Header for the message and store as "HDR"
    285         S D1=0,SGC=0
    286         F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
    287         . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
    288         .QUIT
    289         N BNDRY,STKL,SEG
    290         S STKL=0,SEG=0
    291         ; Find boundaries and map them
    292         S D1=0
    293         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    294         . ; Clear any control characters (cr/lf/ff) off
    295         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    296         . ; Look for " boundary=" in the various parts.  Map the establishment and the
    297         . ;  terminator markers and the actual boundary markers.
    298         . I X[" boundary=" D  Q
    299         . . S SEP=$P(X," boundary=",2)
    300         . . S:$E(SEP)="""" SEP=$TR(SEP,"""")
    301         . . S STKL=STKL+1
    302         . . S END=SEP_FLG
    303         . . S BNDRY(STKL,SEP)=0
    304         . . S BNDRX(SEP)=STKL,BNDRZ(END)=0
    305         . .QUIT
    306         . ;
    307         . ; Look for information as to how amy boudaries are present and where
    308         . ;   they terminate
    309         . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--")
    310         . . ; Boundary Found
    311         . . I $D(BNDRX(X)) D  Q
    312         . . . S SEG=SEG+1
    313         . . . S BNDRE(X)=$G(BNDRE(X))_D1_";"
    314         . . . S BND1(D1)=STKL_";B;"_SEG_";"_X
    315         . . . S BNDR(X,D1,"B")=STKL
    316         . . . I BNDRX(X)=X  D ERROR("ER13")
    317         . . .QUIT
    318         . . ;
    319         . . ; Boundary Terminator
    320         . . I $D(BNDRZ(X)) D  Q
    321         . . . S BNDR(X,D1,"E")=STKL
    322         . . . S BNDRZ(X)=BNDRZ(X)+1
    323         . . . S BND1(D1)=STKL_";E;"_SEG_";"_X
    324         . . . S SEG=SEG+1
    325         . . . I BNDRX(X)=X  D ERROR("ER14")
    326         . . . S STKL=STKL-1
    327         . . .QUIT
    328         . .QUIT
    329         .QUIT
    330         ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message
    331         N A,B,C,STACK,STYP,SEG,AX
    332         S D1=.99999,SGC=0
    333         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    334         . ; Clear any control characters (cr/lf/ff) off
    335         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    336         . ;
    337         . D
    338         . . I $D(BND1(D1)) D BOUNDARY(X)    QUIT
    339         . . ;
    340         . . S DX=$O(BND1(D1))
    341         . . I DX=""  D ERROR("ER15")   Q
    342         . . ;
    343         . . ; Good situation, extract the parts for the section
    344         . . S A=$G(BND1(DX))
    345         . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999)
    346         . .QUIT
    347         . ; Enter once to set the SEP to capture the separator
    348         . ;
    349         . ; A new SEGMENT separator is set, process original
    350         . I $D(BND1(X))  D  QUIT
    351         . . ; Save Current Values
    352         . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
    353         . . ;  Close this Segment and prepare to start a New Segment
    354         . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
    355         . . ;  Put the result in LST("SEG",SGC,"XML")
    356         . . I $L(BF) D
    357         . . . S ZN=1
    358         . . . N I,T,TBF
    359         . . . S TBF=BF
    360         . . . F I=1:1:($L(TBF,"="))  D
    361         . . . . S BF=$P(TBF,"=",I)_"="
    362         . . . . I "="'[BF  D DECODER(.BF,.TYP)
    363         . . . .QUIT
    364         . . . S BF=""
    365         . . .QUIT
    366         . . S SGC=SGC+1,BCN=0
    367         . . ; Incriment SGC to start a new Segment
    368         . . S LST("SEG",SGC)=D1
    369         . .QUIT
    370         . ;
    371         . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters
    372         . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
    373         . ;
    374         . ; Ending Condition, close out the Segment
    375         . I $D(BNDRZ(X)) D  QUIT
    376         . . S $P(LST("SEG",SGC),"^",2)=D1-1
    377         . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP)  S BF="" Q
    378         . .QUIT
    379         . ;
    380         . ; Accumulate the content lines of the message
    381         . S BCN=BCN+$L(X)
    382         . ; Split out the Content Info
    383         . I X[CON D  Q
    384         . . S J=$P(X,CON,2)
    385         . . S TYP="CONTENT"
    386         . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9)
    387         . . D CONTENT(D1)
    388         . .QUIT
    389         . ;
    390         . ; Everything else is Text, Check for CCR/CCD.
    391         . N KK,UBF
    392         . D
    393         . . S UBF=$$UPPER(X)
    394         . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
    395         . . ;
    396         . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
    397         . .QUIT
    398         . ; Look for directives in the text before it gets published
    399         . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
    400         . ;  but there may be situations where the line has been wrapped.
    401         . D:X["=3D"
    402         . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
    403         . .QUIT
    404         . S LST("SEG",SGC,TYP,D1)=X
    405         .QUIT
    406         QUIT
    407         ;  ===================
    408 CONTENT(D1)     ; Try pulling Content Statements
    409         N J,UP,X
    410         S X=$G(^XMB(3.9,D0,2,D1,0))
    411         S J=$P(X,CON,2)
    412         S UP=$TR($$UPPER(X),"""")
    413         S:$G(TYP)="" TYP="TXT"
    414         D
    415         . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q
    416         . I UP["XML" S TYP="XML"                         Q
    417         . I UP["P7S" S TYP="P7S"                         Q
    418         . I J[" boundary=" D BOUNDARY(J)
    419         .QUIT
    420         S LIS("CON",SGC,D1)=X
    421         S LIS("CON",SGC,D1,"TYP")=TYP
    422         ; If there is a follow-on, look for another line after this.
    423         I $E($RE(X),1)=";"   D CONTENT(D1+1)
    424         QUIT
    425         ;  ===================
    426 BOUNDARY(X)     ; Set an additional BOUNDARY, and activate another stack level
    427         S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG
    428         Q:SEP?2"-".ANP
    429         ;
    430         D ERROR("ER11")
    431         Q:SEP'[" "
    432         ;
    433         D ERROR("ER12")
    434         QUIT
    435         ;  ===================
    436         ; Break down the Buffer Array so it can be saved.
    437         ;  BF is passed in.
    438         ;  TYP is the type of
    439 DECODER(BF,TYP) ;
    440         N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
    441         S:$G(TYP)="" TYP="XML"
    442         S ZBF=BF
    443         ;  Full Buffer, BF, now check for Encryption and Unpack
    444         F RCNT=1:1:$L(ZBF,"=")   D
    445         . N BF
    446         . S BF=$P(ZBF,"=",RCNT)
    447         . ;  Unpacking the 64 bit encoding
    448         . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
    449         . D:$L(TBF)
    450         . . N C,OK,OKCNT,KK,XBF,UBF
    451         . . D
    452         . . . S UBF=$$UPPER(TBF)
    453         . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
    454         . . . ;
    455         . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
    456         . . .QUIT
    457         . . ; Check for Bad Signature Decoding, after 100 bad characters
    458         . . S OK=1,OKCNT=0
    459         . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
    460         . . ;
    461         . . D
    462         . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
    463         . . . ;
    464         . . . S BF=BF_"="
    465         . . . D NORMAL(.XBF,.TBF)
    466         . . .QUIT
    467         . . M LST("SEG",SGC,TYP,RCNT)=XBF
    468         . .QUIT
    469         .QUIT
    470         QUIT
    471         ;  ===================
    472         ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
    473         ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
    474         ;   >D NORMAL^C0CMAIL(.OUT,BF)
    475 NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    476         ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    477         ;
    478         N ZN,OUTBF,XX,ZSEP
    479         S INXML=$TR(INXML,$C(10,12,13))
    480         S ZN=1,ZSEP=">"
    481         S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
    482         F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
    483         . S XX=$P(INXML,"><",ZN)
    484         . S:$E($RE(XX))=">" ZSEP=""
    485         . Q:XX=""
    486         . ;
    487         . S XX="<"_XX_ZSEP
    488         . D
    489         . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
    490         . . ;
    491         . . D ERROR("ER05")
    492         . . F ZL=ZL+1:1 D   Q:XX=""
    493         . . .  N XL
    494         . . .  S XL=$E(XX,1,4000)
    495         . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
    496         . . .  S OUTBF(ZL)=XL
    497         . . .QUIT
    498         . .QUIT
    499         .QUIT
    500         M OUTXML=OUTBF
    501         QUIT
    502         ;  ===================
    503 UPPER(X)        ; Convert any lowercase letters to Uppercase letters
    504         QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    505         ;  ===================
    506         ; EN is a counter that remains between error events
    507 ERROR(ER)       ; Error Handler
    508         N TXXQ,XXXQ
    509         S XXXQ="Unknown Error Encountered = "_ER
    510         S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
    511         I TXXQ'=""  D
    512         . I TXXQ["_" X "S TXXQ="_TXXQ
    513         . S XXXQ=TXXQ
    514         .QUIT
    515         S EN(ER)=$G(EN(ER))+1
    516         S LST("ERR",ER,EN(ER))=XXXQ
    517         QUIT
    518         ;  ===================
    519 ER01    ;;Message Missing
    520 ER02    ;;Message Text Missing
    521 ER03    ;;Message Not Identifiable
    522 ER04    ;;Segment is too large
    523 ER05    ;;Mailbox Missing
    524 ER06    ;;"User Missing = "_$G(DUZ)
    525 ER07    ;;"Bad DUZ = "_DUZ
    526 ER08    ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
    527 ER10    ;;"Bad Separator found = "_X
    528 ER11    ;;"Non-Standard Separator Found:>"_$G(J)
    529 ER12    ;;"Spaces are not allowed in Separators:>"_$G(J)
    530 ER13    ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X
    531         ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
    532         ;  End note if needed
    533         QUIT
    534         ;  ===================
     2V ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2011 Chris Richardson, Richardson Computer Research
     4 ; Modified 3110619@2038
     5 ;   rcr@rcresearch.us
     6 ;  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23 ;  ------------------
     24 ;Entry Points
     25 ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
     26 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
     27 ;  Input:
     28 ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
     29 ;                      or "*" for all boxes, default is "IN" if missing]"
     30 ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
     31 ;                                     "*" for All or 9,999 maximum
     32 ;                    MALL?1.n = that number of the n most recent
     33 ;  Internally:
     34 ;    BNAM = Box Name
     35 ;  Output:
     36 ;    C0CDATA
     37 ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
     38 ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
     39 ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
     40 ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
     41 ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
     42 ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
     43 ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
     44 ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
     45 ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
     46 ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
     47 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
     48 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
     49 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
     50 ;
     51 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
     52 ;   Input;
     53 ;     D0     - The IEN for the message in file 3.9, MESSAGE global
     54 ;   Output
     55 ;     OUTBF  - The array of your choice to save the expanded and decoded message.
     56 ;
     57GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
     58 K:'$G(C0CDATA("KEEP")) C0CDATA
     59 N U
     60 S U="^"
     61 D:$G(C0CINPUT)
     62 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
     63 . S INPUT=C0CINPUT
     64 . S DUZ=+INPUT
     65 . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
     66 . ;
     67 . D:$D(^XMB(3.7,DUZ,0))#2
     68 . . S MBLST=$P(INPUT,";",2)
     69 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
     70 . . S:MALL["*" MALL=99999
     71 . . ; Only one of these can be correct
     72 . . D
     73 . . . ;  If nul, make it "IN" only
     74 . . . I MBLST="" D  QUIT
     75 . . . . S MBLST("IN")=0,I=0
     76 . . . . D GATHER(DUZ,"IN",.LST)
     77 . . . .QUIT
     78 . . . ;
     79 . . . ;  If "*", Get all Mailboxes and look for New Messages
     80 . . . I MBLST["*" D  QUIT
     81 . . . . N NAM,NUM
     82 . . . . S NUM=0
     83 . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
     84 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
     85 . . . . . D GATHER(DUZ,NAM,.LST)
     86 . . . . .QUIT
     87 . . . .QUIT
     88 . . . ;
     89 . . . ;  If comma separated, look for mailboxes with new messages
     90 . . . I $L(MBLST,",")>1 D  QUIT
     91 . . . . S NAM=""
     92 . . . . N TN,V
     93 . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
     94 . . . . . I $L(V) D   QUIT
     95 . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
     96 . . . . . . S:NAM="" NAM=V
     97 . . . . . . D GATHER(DUZ,NAM,.LST)
     98 . . . . . .QUIT
     99 . . . . . ;
     100 . . . . . D ERROR("ER08")
     101 . . . . .QUIT
     102 . . . .QUIT
     103 . . . ;
     104 . . . ;  If only 1 mailbox named, go get it
     105 . . . I $L(MBLST)  D   QUIT
     106 . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
     107 . . . . ;
     108 . . . . D ERROR("ER07")
     109 . . .QUIT
     110 . . MERGE C0CDATA=LST
     111 . .QUIT
     112 .QUIT
     113 QUIT
     114 ;  ===================
     115GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
     116 N I,J,K,L
     117 S (I,K)=0
     118 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
     119 F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
     120 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
     121 . D   ; :L
     122 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
     123 . . S LST(NAM,"MSG",I)=L
     124 . . D GETTYP(I)
     125 . .QUIT
     126 .QUIT
     127 S LST(NAM,"NUMBER")=K
     128 QUIT
     129 ;  ===================
     130 ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
     131 ; The products of these emails are scanned to identify
     132 ;  the number of documents stored in the MIME package.
     133 ;  The protocol runs like this;
     134 ; Line 1 is the --separator
     135 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
     136 ; Line n+2 thru t-1 where t does NOT have "Content-"
     137 ; Line t   is Next Section Terminator, or Message Terminator, --separator
     138 ; Line t+1 should not exist in the data set if Message Terminator
     139 ; CON = "Content-"
     140 ; FLG = "--"
     141 ; SEP = FLG+7 or more characters  ; Separator
     142 ; END = SEP+FLG
     143 ; SGC = Segment Count
     144 ; Note: separator is a string of specific characters of
     145 ;        indeterminate length 
     146 ; LST() the transfer array
     147 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
     148 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
     149 ;
     150GETTYP(D0) ; Look for the goodies in the Mail
     151 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
     152 S CON="Content-"
     153 S FLG="--"
     154 S SEP=""  ; Start SEP as null, so we can use this to help identify the type
     155 S (BCN,CNT,D1,END,SGC)=0
     156 S XX=$G(^XMB(3.9,D0,0))
     157 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     158 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
     159 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     160 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
     161 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
     162 ; Get the folks the email is sent to.
     163 S D1=0
     164 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
     165 . N T
     166 . S T=+$G(^XMB(3.9,D0,1,D1,0))
     167 . S:T T=$P($G(^VA(200,+T,0)),"^")
     168 . S LST("TO",D1)=T
     169 . S T=$G(^XMB(3.9,D0,6,D1,0))
     170 . S:T T=$P($G(^VA(200,+T,0)),"^")
     171 . S:T="" T="<Unknown>"
     172 . S LST("TO NAME",D1)=T
     173 .QUIT
     174 ; Preload first Segment (0) with beginning on Line 1
     175 ;  if not a 64bit
     176 S LST(NAM,"MSG",D0,"SEG",0)=1
     177 S D1=.9999,SEP="@@"
     178 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     179 . ; Clear any control characters (cr/lf/ff) off
     180 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     181 . ; Enter once to set the SEP to capture the separator
     182 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
     183 . . S SEP=X,END=X_FLG
     184 . . S (CNT,SGC)=1,BCN=0
     185 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     186 . .QUIT
     187 . ;
     188 . ; A new separator is set, process original
     189 . I X=SEP  D  QUIT
     190 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
     191 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
     192 . . S SGC=SGC+1,BCN=0
     193 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     194 . .QUIT
     195 . ;
     196 . S BCN=BCN+$L(X)
     197 . I X[CON D  Q
     198 . . S J=$P($P(X,";"),CON,2)
     199 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
     200 . .QUIT
     201 . ;
     202 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
     203 .QUIT
     204 QUIT
     205 ;  ===================
     206NAME(NM) ; Return the name of the Sender
     207 N NAME
     208 S NAME="<Unknown Sender>"
     209 D
     210 . ; Look first for a value to use with the NEW PERSON file
     211 . ;
     212 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
     213 . ;
     214 . I $L(NM) S NAME=NM                    Q
     215 . ;
     216 . ; Else, pull the data from the message and display the foreign source
     217 . ;   of the message.
     218 . N T
     219 . S VAL=$G(^XMB(3.9,D0,.7))
     220 . S:VAL T=$P(^VA(200,VAL,0),U)
     221 . I $L($G(T)) S NAME=T                  Q
     222 . ;
     223 .QUIT
     224 QUIT NAME
     225 ;  ===================
     226TIME(Y) ; The time and date of the sending
     227 X ^DD("DD")
     228 QUIT Y
     229 ;  ===================
     230 ;  Segments in Message need to be identified and decoded properly
     231 ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
     232 ;   ARRAY will have the details of this one call
     233 ;   
     234 ; Inputs;
     235 ;   C0CINPUT    - The IEN of the message to expand
     236 ; Outputs;
     237 ;   C0CDATA     - Carrier for the returned structure of the Message
     238 ;  C0CDATA(D0,"SEG")=number of SEGMENTS
     239 ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
     240 ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
     241 ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
     242 ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
     243 ;
     244DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
     245 N LST,D0,D1,U
     246 S U="^"
     247 S D0=+$G(C0CINPUT)
     248 I D0   D    QUIT
     249 . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
     250 . ;
     251 . D GETTYP2(D0)
     252 . I $D(LST)   M C0CDATA(D0)=LST  Q
     253 . ;
     254 . D ERROR("ER02")
     255 .QUIT
     256 QUIT
     257 ;  ===================
     258 ;  End note if needed
     259 ; MSK   - Set of characters that do not exist in 64 bit encoding
     260GETTYP2(D0) ; Try to get the types and MSK for the
     261 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
     262 S CON="Content-",U="^"
     263 S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
     264 S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
     265 S (BCN,CNT,D1,END,SGC)=0
     266 S XX=$G(^XMB(3.9,D0,0))
     267 ; S K=$P(^XMB(3.9,D0,2,0),U,3)
     268 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     269 S LST("CREATED")=$$TIME($P(XX,U,3))
     270 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     271 S LST("FROM")=$$NAME(XXNM)
     272 ; Get the folks the email is sent to.
     273 S D1=0
     274 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
     275 . N I,T
     276 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
     277 . S:T T=$P($G(^VA(200,T,0)),"^")
     278 . S LST("TO",+D1)=T
     279 . S T=$G(^XMB(3.9,D0,6,+D1,0))
     280 . S:T="" T=$P($G(^VA(200,+T,0)),"^")
     281 . S:T="" T="<Unknown>"
     282 . S LST("TO NAME",D1)=T
     283 .QUIT
     284 ; Get the Header for the message and store as "HDR"
     285 S D1=0,SGC=0
     286 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
     287 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
     288 .QUIT
     289 N BNDRY,STKL,SEG
     290 S STKL=0,SEG=0
     291 ; Find boundaries and map them
     292 S D1=0
     293 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     294 . ; Clear any control characters (cr/lf/ff) off
     295 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     296 . ; Look for " boundary=" in the various parts.  Map the establishment and the
     297 . ;  terminator markers and the actual boundary markers.
     298 . I X[" boundary=" D  Q
     299 . . S SEP=$P(X," boundary=",2)
     300 . . S:$E(SEP)="""" SEP=$TR(SEP,"""")
     301 . . S STKL=STKL+1
     302 . . S END=SEP_FLG
     303 . . S BNDRY(STKL,SEP)=0
     304 . . S BNDRX(SEP)=STKL,BNDRZ(END)=0
     305 . .QUIT
     306 . ;
     307 . ; Look for information as to how amy boudaries are present and where
     308 . ;   they terminate
     309 . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--")
     310 . . ; Boundary Found
     311 . . I $D(BNDRX(X)) D  Q
     312 . . . S SEG=SEG+1
     313 . . . S BNDRE(X)=$G(BNDRE(X))_D1_";"
     314 . . . S BND1(D1)=STKL_";B;"_SEG_";"_X
     315 . . . S BNDR(X,D1,"B")=STKL
     316 . . . I BNDRX(X)=X  D ERROR("ER13")
     317 . . .QUIT
     318 . . ;
     319 . . ; Boundary Terminator
     320 . . I $D(BNDRZ(X)) D  Q
     321 . . . S BNDR(X,D1,"E")=STKL
     322 . . . S BNDRZ(X)=BNDRZ(X)+1
     323 . . . S BND1(D1)=STKL_";E;"_SEG_";"_X
     324 . . . S SEG=SEG+1
     325 . . . I BNDRX(X)=X  D ERROR("ER14")
     326 . . . S STKL=STKL-1
     327 . . .QUIT
     328 . .QUIT
     329 .QUIT
     330 ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message
     331 N A,B,C,STACK,STYP,SEG,AX
     332 S D1=.99999,SGC=0
     333 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     334 . ; Clear any control characters (cr/lf/ff) off
     335 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     336 . ;
     337 . D
     338 . . I $D(BND1(D1)) D BOUNDARY(X)    QUIT
     339 . . ;
     340 . . S DX=$O(BND1(D1))
     341 . . I DX=""  D ERROR("ER15")   Q
     342 . . ;
     343 . . ; Good situation, extract the parts for the section
     344 . . S A=$G(BND1(DX))
     345 . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999)
     346 . .QUIT
     347 . ; Enter once to set the SEP to capture the separator
     348 . ;
     349 . ; A new SEGMENT separator is set, process original
     350 . I $D(BND1(X))  D  QUIT
     351 . . ; Save Current Values
     352 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
     353 . . ;  Close this Segment and prepare to start a New Segment
     354 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
     355 . . ;  Put the result in LST("SEG",SGC,"XML")
     356 . . I $L(BF) D
     357 . . . S ZN=1
     358 . . . N I,T,TBF
     359 . . . S TBF=BF
     360 . . . F I=1:1:($L(TBF,"="))  D
     361 . . . . S BF=$P(TBF,"=",I)_"="
     362 . . . . I "="'[BF  D DECODER(.BF,.TYP)
     363 . . . .QUIT
     364 . . . S BF=""
     365 . . .QUIT
     366 . . S SGC=SGC+1,BCN=0
     367 . . ; Incriment SGC to start a new Segment
     368 . . S LST("SEG",SGC)=D1
     369 . .QUIT
     370 . ;
     371 . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters
     372 . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
     373 . ;
     374 . ; Ending Condition, close out the Segment
     375 . I $D(BNDRZ(X)) D  QUIT
     376 . . S $P(LST("SEG",SGC),"^",2)=D1-1
     377 . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP)  S BF="" Q
     378 . .QUIT
     379 . ;
     380 . ; Accumulate the content lines of the message
     381 . S BCN=BCN+$L(X)
     382 . ; Split out the Content Info
     383 . I X[CON D  Q
     384 . . S J=$P(X,CON,2)
     385 . . S TYP="CONTENT"
     386 . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9)
     387 . . D CONTENT(D1)
     388 . .QUIT
     389 . ;
     390 . ; Everything else is Text, Check for CCR/CCD.
     391 . N KK,UBF
     392 . D
     393 . . S UBF=$$UPPER(X)
     394 . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
     395 . . ;
     396 . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
     397 . .QUIT
     398 . ; Look for directives in the text before it gets published
     399 . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
     400 . ;  but there may be situations where the line has been wrapped.
     401 . D:X["=3D"
     402 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
     403 . .QUIT
     404 . S LST("SEG",SGC,TYP,D1)=X
     405 .QUIT
     406 QUIT
     407 ;  ===================
     408CONTENT(D1) ; Try pulling Content Statements
     409 N J,UP,X
     410 S X=$G(^XMB(3.9,D0,2,D1,0))
     411 S J=$P(X,CON,2)
     412 S UP=$TR($$UPPER(X),"""")
     413 S:$G(TYP)="" TYP="TXT"
     414 D
     415 . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q
     416 . I UP["XML" S TYP="XML"                         Q
     417 . I UP["P7S" S TYP="P7S"                         Q
     418 . I J[" boundary=" D BOUNDARY(J)
     419 .QUIT
     420 S LIS("CON",SGC,D1)=X
     421 S LIS("CON",SGC,D1,"TYP")=TYP
     422 ; If there is a follow-on, look for another line after this.
     423 I $E($RE(X),1)=";"   D CONTENT(D1+1)
     424 QUIT
     425 ;  ===================
     426BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level
     427 S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG
     428 Q:SEP?2"-".ANP
     429 ;
     430 D ERROR("ER11")
     431 Q:SEP'[" "
     432 ;
     433 D ERROR("ER12")
     434 QUIT
     435 ;  ===================
     436 ; Break down the Buffer Array so it can be saved.
     437 ;  BF is passed in.
     438 ;  TYP is the type of
     439DECODER(BF,TYP) ;
     440 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
     441 S:$G(TYP)="" TYP="XML"
     442 S ZBF=BF
     443 ;  Full Buffer, BF, now check for Encryption and Unpack
     444 F RCNT=1:1:$L(ZBF,"=")   D
     445 . N BF
     446 . S BF=$P(ZBF,"=",RCNT)
     447 . ;  Unpacking the 64 bit encoding
     448 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
     449 . D:$L(TBF)
     450 . . N C,OK,OKCNT,KK,XBF,UBF
     451 . . D
     452 . . . S UBF=$$UPPER(TBF)
     453 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
     454 . . . ;
     455 . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
     456 . . .QUIT
     457 . . ; Check for Bad Signature Decoding, after 100 bad characters
     458 . . S OK=1,OKCNT=0
     459 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
     460 . . ;
     461 . . D
     462 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
     463 . . . ;
     464 . . . S BF=BF_"="
     465 . . . D NORMAL(.XBF,.TBF)
     466 . . .QUIT
     467 . . M LST("SEG",SGC,TYP,RCNT)=XBF
     468 . .QUIT
     469 .QUIT
     470 QUIT
     471 ;  ===================
     472 ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
     473 ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
     474 ;   >D NORMAL^C0CMAIL(.OUT,BF)
     475NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     476 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     477 ;
     478 N ZN,OUTBF,XX,ZSEP
     479 S INXML=$TR(INXML,$C(10,12,13))
     480 S ZN=1,ZSEP=">"
     481 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
     482 F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
     483 . S XX=$P(INXML,"><",ZN)
     484 . S:$E($RE(XX))=">" ZSEP=""
     485 . Q:XX=""
     486 . ;
     487 . S XX="<"_XX_ZSEP
     488 . D
     489 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
     490 . . ;
     491 . . D ERROR("ER05")
     492 . . F ZL=ZL+1:1 D   Q:XX=""
     493 . . .  N XL
     494 . . .  S XL=$E(XX,1,4000)
     495 . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
     496 . . .  S OUTBF(ZL)=XL
     497 . . .QUIT
     498 . .QUIT
     499 .QUIT
     500 M OUTXML=OUTBF
     501 QUIT
     502 ;  ===================
     503UPPER(X) ; Convert any lowercase letters to Uppercase letters
     504 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     505 ;  ===================
     506 ; EN is a counter that remains between error events
     507ERROR(ER) ; Error Handler
     508 N TXXQ,XXXQ
     509 S XXXQ="Unknown Error Encountered = "_ER
     510 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
     511 I TXXQ'=""  D
     512 . I TXXQ["_" X "S TXXQ="_TXXQ
     513 . S XXXQ=TXXQ
     514 .QUIT
     515 S EN(ER)=$G(EN(ER))+1
     516 S LST("ERR",ER,EN(ER))=XXXQ
     517 QUIT
     518 ;  ===================
     519ER01 ;;Message Missing
     520ER02 ;;Message Text Missing
     521ER03 ;;Message Not Identifiable
     522ER04 ;;Segment is too large
     523ER05 ;;Mailbox Missing
     524ER06 ;;"User Missing = "_$G(DUZ)
     525ER07 ;;"Bad DUZ = "_DUZ
     526ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
     527ER10 ;;"Bad Separator found = "_X
     528ER11 ;;"Non-Standard Separator Found:>"_$G(J)
     529ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
     530ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X
     531 ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
     532 ;  End note if needed
     533 QUIT
     534 ;  ===================

  • ccr/branches/ohum/p/C0CMCCD.m

    r1330 r1332  
    11C0CMCCD   ; GPL - MXML based CCD utilities;12/04/09  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 PARSCCD(DOC,OPTION)     ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR
    23         ; PROCESSING CCDS
    24         N CBK,SUCCESS,LEVEL,NODE,HANDLE
    25         K ^TMP("MXMLERR",$J)
    26         L +^TMP("MXMLDOM",$J):5
    27         E  Q 0
    28         S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
    29         L -^TMP("MXMLDOM",$J)
    30         S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL
    31         S CBK("ENDELEMENT")="ENDELE^MXMLDOM"
    32         S CBK("COMMENT")="COMMENT^MXMLDOM"
    33         S CBK("CHARACTERS")="CHAR^MXMLDOM"
    34         S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM"
    35         S CBK("ERROR")="ERROR^MXMLDOM"
    36         S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1")
    37         D EN^MXMLPRSE(DOC,.CBK,OPTION)
    38         D:'SUCCESS DELETE^MXMLDOM(HANDLE)
    39         Q $S(SUCCESS:HANDLE,1:0)
    40         ; Start element
    41         ; Create new child node and push info on stack
    42 STARTELE(ELE,ATTR)      ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT
    43         ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER
    44         N PARENT
    45         S PARENT=LEVEL(LEVEL),NODE=NODE+1
    46         S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE
    47         S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE
    48         S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT
    49         ;M ^("A")=ATTR
    50         N ZI S ZI="" ; INDEX FOR ATTR
    51         F  S ZI=$O(ATTR(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
    52         . N ELE,TXT ; ABOUT TO RECURSE
    53         . S ELE=ZI ; TAG
    54         . S TXT=ATTR(ZI) ; DATA
    55         . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE
    56         . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG
    57         . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL
    58         Q
    59         ;
    60 ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    61         N ZN
    62         ;I $$TAG(ZOID)["entry" B
    63         S ZN=$$NXTSIB(ZOID)
    64         I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    65         Q 0
    66         ;
    67 FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    68         Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
    69         ;
    70 PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
    71         Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
    72         ;
    73 ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
    74         S HANDLE=C0CDOCID
    75         K @RTN
    76         D GETTXT^MXMLDOM("A")
    77         Q
    78         ;
    79 TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
    80         ;I ZOID=149 B ;GPLTEST
    81         N X,Y
    82         S Y=""
    83         S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    84         I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    85         I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
    86         Q Y
    87         ;
    88 NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
    89         Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
    90         ;
    91 DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
    92         ;N ZT,ZN S ZT=""
    93         ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    94         ;Q $G(@C0CDOM@(ZOID,"T",1))
    95         S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
    96         Q
    97         ;
    98 CLEANARY(OUTARY,INARY)  ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE
    99         ; INARY AND OUTARY PASSED BY NAME
    100         N ZI S ZI=""
    101         F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
    102         . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE
    103         Q
    104         ;
    105 CLEAN(STR)      ; extrinsic function; returns string
    106         ;; Removes all non printable characters from a string.
    107         ;; STR by Value
    108         N TR,I
    109         F I=0:1:31 S TR=$G(TR)_$C(I)
    110         S TR=TR_$C(127)
    111         QUIT $TR(STR,TR)
    112         ;
    113 STRIPTXT(OUTARY,ZARY)   ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE
    114         ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE
    115         ; THEY DO NOT WORK RIGHT WITH THE PARSER
    116         ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER
    117         S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER
    118         D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY
    119         F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF THE ARRAY
    120         . I $O(@ZARY@(ZI))="" D  Q  ; AT THE END
    121         . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY
    122         . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE
    123         . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END
    124         . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN
    125         S ZI=""
    126         F  S ZI=$O(ZWRK(ZI)) Q:ZI=""  D  ; MAKE A BUILD LIST FROM THE WORK ARRAY
    127         . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2))
    128         D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS
    129         K @OUTARY@(0) ; GET RID OF THE LINE COUNT
    130         Q
    131         ;
    132 C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME
    133         N ZI
    134         S ZI=$O(@ZA@(""),-1)
    135         I ZI="" S ZI=1
    136         E  S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY
    137         S $P(@ZA@(ZI),"^",1)=LN
    138         Q
    139         ;
    140 C0CEND(ZB,LN)   ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME
    141         N ZI
    142         S ZI=$O(@ZB@(""),-1)
    143         I ZI="" S ZI=1
    144         S $P(@ZB@(ZI),"^",2)=LN
    145         Q
    146         ;
    147 SEPARATE(OUTARY,INARY)  ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR
    148         ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc")
    149         S ZI=""
    150         F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH ELEMENT OF THE ARRAY
    151         . I $P(ZI,"//",2)'="" D  ; FOR NON-BODY ENTRIES
    152         . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor
    153         . E  D  ; FOR BODY PARTS
    154         . . S ZJ=$P(ZI,"/",2) ;
    155         . . I ZJ="" S ZJ=$P(ZI,"/",3) ;
    156         . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS
    157         Q
    158         ;
    159 FINDTID ; FIND TEMPLATE IDS IN DOM 1
    160         S C0CDOCID=1
    161         S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    162         S ZN=""
    163         S CURSEC=""
    164         S TID=""
    165         F  S ZN=$O(@ZD@(ZN)) Q:ZN=""  D  ;
    166         . I $$TAG(ZN)="root" D  ;
    167         . . I $$TAG($$PARENT(ZN))="templateId" D  ; ONLY LOOKING FOR TEMPLATES
    168         . . . S ZG=$$PARENT($$PARENT(ZN))
    169         . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION
    170         . . . S CMT=$G(@ZD@(ZG,"X",1))
    171         . . . I CMT="" S CMT="?"
    172         . . . I $$TAG(ZG)="section" D  ;START OF A SECTION
    173         . . . . S CURSEC=$$PARENT(ZG)
    174         . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1))
    175         . . . . I SECCMT="" S SECCMT="?"
    176         . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID
    177         . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID
    178         . . . I CURSEC'="" D  ; IF WE ARE IN A SECTION
    179         . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID
    180         . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID
    181         . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1))
    182         . . . W " root ",ZN," ",@ZD@(ZN,"T",1)
    183         Q
    184         ;
    185 FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS
    186         ;
    187         S ZI=""
    188         F  S ZI=$O(DOMMAP(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE MAP
    189         . S ZJ=DOMMAP(ZI) ;
    190         . S PARNODE=$P(ZJ,U,1) ;PARENT NODE
    191         . S TAG=$P(ZJ,U,2) ;THIS TAG
    192         . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID
    193         . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID
    194         . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN
    195         . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN
    196         . I ZI=PARNODE D  ; IF THIS IS A SECTION NODE
    197         . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT
    198         . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE
    199         . . W ZI," ",TAG," ",ALTTAG," ",NAME,!
    200         . . S C0CTAGS(ZI)=ALTTAG
    201         . E  D  ; NOT A SECTION NODE
    202         . . N ZJ S ZJ=""
    203         . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER?
    204         . . I ZJ'="" D  ; THERE IS A NEW LABEL FOR THIS NODE
    205         . . . N ZK
    206         . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2)
    207         . . . I ZK'="" D  ;
    208         . . . . W "FOUND ",ZK,!
    209         . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION
    210         Q
    211         ;
    212 ALTTAG(NODE)    ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND
    213         ;
    214         S Y=$G(C0CTAGS(NODE))
    215         Q
    216         ;
    217 SETCBK  ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD
    218         S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)"
    219         Q
    220         ;
    221 OUTCCD(GARYIN)  ; OUTPUT THE PARSED CCD TO A TEXT FILE
    222         ;D TEST3^C0CMXML
    223         N ZT S ZT=$NA(^TMP("CCDOUT",$J))
    224         N ZI,ZJ
    225         S ZI=1 S ZJ=""
    226         K @ZT
    227         F  S ZJ=$O(GARYIN(ZJ)) Q:ZJ=""  D  ;
    228         . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ)
    229         . S ZI=ZI+1
    230         S ONAME=$NA(@ZT@(1))
    231         W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR")
    232         K @ZT
    233         Q
    234         ;
    235 GENXDS(ZD)      ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY
    236         ; ARRAY ELEMENTS LOOK LIKE:
    237         ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31"
    238         ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId
    239         S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
    240         S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
    241         S DONE=0
    242         F  Q:DONE  D  ;
    243         . W @ZI,!
    244         . S ZJ=$QS(ZI,5)
    245         . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
    246         . S C0CFDA(ZF,"?+1,",.01)=ZJ
    247         . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
    248         . S C0CFDA(ZF,"?+1,",1)=@ZI
    249         . D UPDIE
    250         . S ZI=$Q(@ZI)
    251         . I ZI="" S DONE=1
    252         Q
    253         ;
    254 WHRUSD(ZD)      ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM
    255         ; CCDDIR PASS BY NAME
    256         ; ARRAY ELEMENTS LOOK LIKE:
    257         ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31"
    258         ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId
    259         S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
    260         S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE
    261         S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
    262         S DONE=0
    263         F  Q:DONE  D  ;
    264         . W @ZI
    265         . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE
    266         . W " IEN:",ZIEN
    267         . S ZJ=$QS(ZI,2)
    268         . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
    269         . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN
    270         . W " PARENT IEN:",ZPIEN
    271         . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
    272         . W " TAG:",ZTAG,!
    273         . I ZIEN'=ZPIEN D  ; ONLY FOR CHILD TEMPLATES
    274         . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR
    275         . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY
    276         . . D UPDIE
    277         . ;S C0CFDA(ZF,"?+1,",1)=@ZI
    278         . ;D UPDIE
    279         . S ZI=$Q(@ZI)
    280         . I ZI="" S DONE=1
    281         Q
    282         ;
     2 ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     22PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR
     23 ; PROCESSING CCDS
     24 N CBK,SUCCESS,LEVEL,NODE,HANDLE
     25 K ^TMP("MXMLERR",$J)
     26 L +^TMP("MXMLDOM",$J):5
     27 E  Q 0
     28 S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
     29 L -^TMP("MXMLDOM",$J)
     30 S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL
     31 S CBK("ENDELEMENT")="ENDELE^MXMLDOM"
     32 S CBK("COMMENT")="COMMENT^MXMLDOM"
     33 S CBK("CHARACTERS")="CHAR^MXMLDOM"
     34 S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM"
     35 S CBK("ERROR")="ERROR^MXMLDOM"
     36 S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1")
     37 D EN^MXMLPRSE(DOC,.CBK,OPTION)
     38 D:'SUCCESS DELETE^MXMLDOM(HANDLE)
     39 Q $S(SUCCESS:HANDLE,1:0)
     40 ; Start element
     41 ; Create new child node and push info on stack
     42STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT
     43 ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER
     44 N PARENT
     45 S PARENT=LEVEL(LEVEL),NODE=NODE+1
     46 S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE
     47 S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE
     48 S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT
     49 ;M ^("A")=ATTR
     50 N ZI S ZI="" ; INDEX FOR ATTR
     51 F  S ZI=$O(ATTR(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
     52 . N ELE,TXT ; ABOUT TO RECURSE
     53 . S ELE=ZI ; TAG
     54 . S TXT=ATTR(ZI) ; DATA
     55 . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE
     56 . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG
     57 . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL
     58 Q
     59 ;
     60ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
     61 N ZN
     62 ;I $$TAG(ZOID)["entry" B
     63 S ZN=$$NXTSIB(ZOID)
     64 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     65 Q 0
     66 ;
     67FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
     68 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
     69 ;
     70PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
     71 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
     72 ;
     73ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
     74 S HANDLE=C0CDOCID
     75 K @RTN
     76 D GETTXT^MXMLDOM("A")
     77 Q
     78 ;
     79TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
     80 ;I ZOID=149 B ;GPLTEST
     81 N X,Y
     82 S Y=""
     83 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     84 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     85 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
     86 Q Y
     87 ;
     88NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
     89 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
     90 ;
     91DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
     92 ;N ZT,ZN S ZT=""
     93 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     94 ;Q $G(@C0CDOM@(ZOID,"T",1))
     95 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
     96 Q
     97 ;
     98CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE
     99 ; INARY AND OUTARY PASSED BY NAME
     100 N ZI S ZI=""
     101 F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
     102 . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE
     103 Q
     104 ;
     105CLEAN(STR) ; extrinsic function; returns string
     106 ;; Removes all non printable characters from a string.
     107 ;; STR by Value
     108 N TR,I
     109 F I=0:1:31 S TR=$G(TR)_$C(I)
     110 S TR=TR_$C(127)
     111 QUIT $TR(STR,TR)
     112 ;
     113STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE
     114 ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE
     115 ; THEY DO NOT WORK RIGHT WITH THE PARSER
     116 ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER
     117 S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER
     118 D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY
     119 F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF THE ARRAY
     120 . I $O(@ZARY@(ZI))="" D  Q  ; AT THE END
     121 . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY
     122 . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE
     123 . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END
     124 . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN
     125 S ZI=""
     126 F  S ZI=$O(ZWRK(ZI)) Q:ZI=""  D  ; MAKE A BUILD LIST FROM THE WORK ARRAY
     127 . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2))
     128 D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS
     129 K @OUTARY@(0) ; GET RID OF THE LINE COUNT
     130 Q
     131 ;
     132C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME
     133 N ZI
     134 S ZI=$O(@ZA@(""),-1)
     135 I ZI="" S ZI=1
     136 E  S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY
     137 S $P(@ZA@(ZI),"^",1)=LN
     138 Q
     139 ;
     140C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME
     141 N ZI
     142 S ZI=$O(@ZB@(""),-1)
     143 I ZI="" S ZI=1
     144 S $P(@ZB@(ZI),"^",2)=LN
     145 Q
     146 ;
     147SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR
     148 ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc")
     149 S ZI=""
     150 F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH ELEMENT OF THE ARRAY
     151 . I $P(ZI,"//",2)'="" D  ; FOR NON-BODY ENTRIES
     152 . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor
     153 . E  D  ; FOR BODY PARTS
     154 . . S ZJ=$P(ZI,"/",2) ;
     155 . . I ZJ="" S ZJ=$P(ZI,"/",3) ;
     156 . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS
     157 Q
     158 ;
     159FINDTID ; FIND TEMPLATE IDS IN DOM 1
     160 S C0CDOCID=1
     161 S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     162 S ZN=""
     163 S CURSEC=""
     164 S TID=""
     165 F  S ZN=$O(@ZD@(ZN)) Q:ZN=""  D  ;
     166 . I $$TAG(ZN)="root" D  ;
     167 . . I $$TAG($$PARENT(ZN))="templateId" D  ; ONLY LOOKING FOR TEMPLATES
     168 . . . S ZG=$$PARENT($$PARENT(ZN))
     169 . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION
     170 . . . S CMT=$G(@ZD@(ZG,"X",1))
     171 . . . I CMT="" S CMT="?"
     172 . . . I $$TAG(ZG)="section" D  ;START OF A SECTION
     173 . . . . S CURSEC=$$PARENT(ZG)
     174 . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1))
     175 . . . . I SECCMT="" S SECCMT="?"
     176 . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID
     177 . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID
     178 . . . I CURSEC'="" D  ; IF WE ARE IN A SECTION
     179 . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID
     180 . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID
     181 . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1))
     182 . . . W " root ",ZN," ",@ZD@(ZN,"T",1)
     183 Q
     184 ;
     185FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS
     186 ;
     187 S ZI=""
     188 F  S ZI=$O(DOMMAP(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE MAP
     189 . S ZJ=DOMMAP(ZI) ;
     190 . S PARNODE=$P(ZJ,U,1) ;PARENT NODE
     191 . S TAG=$P(ZJ,U,2) ;THIS TAG
     192 . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID
     193 . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID
     194 . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN
     195 . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN
     196 . I ZI=PARNODE D  ; IF THIS IS A SECTION NODE
     197 . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT
     198 . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE
     199 . . W ZI," ",TAG," ",ALTTAG," ",NAME,!
     200 . . S C0CTAGS(ZI)=ALTTAG
     201 . E  D  ; NOT A SECTION NODE
     202 . . N ZJ S ZJ=""
     203 . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER?
     204 . . I ZJ'="" D  ; THERE IS A NEW LABEL FOR THIS NODE
     205 . . . N ZK
     206 . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2)
     207 . . . I ZK'="" D  ;
     208 . . . . W "FOUND ",ZK,!
     209 . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION
     210 Q
     211 ;
     212ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND
     213 ;
     214 S Y=$G(C0CTAGS(NODE))
     215 Q
     216 ;
     217SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD
     218 S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)"
     219 Q
     220 ;
     221OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE
     222 ;D TEST3^C0CMXML
     223 N ZT S ZT=$NA(^TMP("CCDOUT",$J))
     224 N ZI,ZJ
     225 S ZI=1 S ZJ=""
     226 K @ZT
     227 F  S ZJ=$O(GARYIN(ZJ)) Q:ZJ=""  D  ;
     228 . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ)
     229 . S ZI=ZI+1
     230 S ONAME=$NA(@ZT@(1))
     231 W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR")
     232 K @ZT
     233 Q
     234 ;
     235GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY
     236 ; ARRAY ELEMENTS LOOK LIKE:
     237 ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31"
     238 ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId
     239 S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
     240 S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
     241 S DONE=0
     242 F  Q:DONE  D  ;
     243 . W @ZI,!
     244 . S ZJ=$QS(ZI,5)
     245 . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
     246 . S C0CFDA(ZF,"?+1,",.01)=ZJ
     247 . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
     248 . S C0CFDA(ZF,"?+1,",1)=@ZI
     249 . D UPDIE
     250 . S ZI=$Q(@ZI)
     251 . I ZI="" S DONE=1
     252 Q
     253 ;
     254WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM
     255 ; CCDDIR PASS BY NAME
     256 ; ARRAY ELEMENTS LOOK LIKE:
     257 ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31"
     258 ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId
     259 S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
     260 S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE
     261 S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
     262 S DONE=0
     263 F  Q:DONE  D  ;
     264 . W @ZI
     265 . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE
     266 . W " IEN:",ZIEN
     267 . S ZJ=$QS(ZI,2)
     268 . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
     269 . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN
     270 . W " PARENT IEN:",ZPIEN
     271 . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
     272 . W " TAG:",ZTAG,!
     273 . I ZIEN'=ZPIEN D  ; ONLY FOR CHILD TEMPLATES
     274 . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR
     275 . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY
     276 . . D UPDIE
     277 . ;S C0CFDA(ZF,"?+1,",1)=@ZI
     278 . ;D UPDIE
     279 . S ZI=$Q(@ZI)
     280 . I ZI="" S DONE=1
     281 Q
     282 ;
    283283UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    284         K ZERR
    285         D CLEAN^DILF
    286         D UPDATE^DIE("","C0CFDA","","ZERR")
    287         I $D(ZERR) D  ;
    288         . W "ERROR",!
    289         . ZWR ZERR
    290         . B
    291         K C0CFDA
    292         Q
    293         ;
     284 K ZERR
     285 D CLEAN^DILF
     286 D UPDATE^DIE("","C0CFDA","","ZERR")
     287 I $D(ZERR) D  ;
     288 . W "ERROR",!
     289 . ZWR ZERR
     290 . B
     291 K C0CFDA
     292 Q
     293 ;

  • ccr/branches/ohum/p/C0CMED.m

    r1330 r1332  
    11C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
    44        ; Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CMED1.m

    r1330 r1332  
    11C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;;Last modified Sat Jan 10 21:42:27 PST 2009
    44        ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
    … …  
    5656        ; @(0) contains the number of meds or -1^NO DATA FOUND
    5757        ; If it is -1, we quit.
    58         I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q
     58        I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
    5959        ZWRITE:$G(DEBUG) MEDS
    6060        N RXIEN S RXIEN=0
    61         F  S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)=""  D  ; FOR EACH MEDICATION IN THE LIST
     61        F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
    6262        . N MED M MED=MEDS(RXIEN)
    6363        . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT

  • ccr/branches/ohum/p/C0CMED2.m

    r1330 r1332  
    11C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;;Last Modified Sat Jan 10 21:41:14 PST 2009
    44        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU

  • ccr/branches/ohum/p/C0CMED3.m

    r1330 r1332  
    11C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
    44        ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU

  • ccr/branches/ohum/p/C0CMED4.m

    r1330 r1332  
    1 C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
    2         ;;0.1;CCDCCR;;;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "NO ENTRY FROM TOP",!
    21         Q
    22         ;
    23 EXTRACT(MINXML,DFN,OUTXML)                ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    24         ;
    25         ; MINXML is the Input XML Template, passed by name
    26         ; DFN is Patient IEN
    27         ; OUTXML is the resultant XML.
    28         ;
    29         ; MEDS is return array from API.
    30         ; MED is holds each array element from MEDS, one medicine
    31         ; MAP is a mapping variable map (store result) for each med
    32         ;
    33         ; Inpatient Meds will be extracted using this routine and and the one following.
    34         ; Inpatient Meds Unit Dose is going to be C0CMED4
    35         ; Inpatient Meds IVs is going to be C0CMED5
    36         ;
    37         ; We will use two Pharmacy ReEnginnering API's:
    38         ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
    39         ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
    40         ; For more information, see the PRE documentation at:
    41         ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
    42         ;
    43         ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
    44         ;
    45         N MEDS,MAP
    46         K ^TMP($J)
    47         D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
    48         I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
    49         ; Otherwise, we go on...
    50         M MEDS=^TMP($J,"UD")
    51         I DEBUG ZWR MEDS
    52         S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP"))
    53         N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
    54         N I S I=0
    55         F  S I=$O(MEDS("B",I)) Q:'I  D  ; For each medication in B index
    56         . N MED M MED=MEDS(I)
    57         . S MEDCOUNT=MEDCOUNT+1
    58         . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
    59         . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT))
    60         . N RXIEN S RXIEN=MED(.01) ; Order Number
    61         . I DEBUG W "RXIEN IS ",RXIEN,!
    62         . I DEBUG W "MAP= ",MAP,!
    63         . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
    64         . S @MAP@("MEDISSUEDATETXT")="Order Date"
    65         . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
    66         . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
    67         . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
    68         . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
    69         . S @MAP@("MEDRXNO")="" ; For Outpatient
    70         . S @MAP@("MEDTYPETEXT")="Medication"
    71         . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    72         . S @MAP@("MEDSTATUSTEXT")="ACTIVE"
    73         . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
    74         . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
    75         . ; NDC is field 31 in the drug file.
    76         . ; The actual drug entry in the drug file is not necessarily supplied.
    77         . ; It' node 1, internal form.
    78         . N MEDIEN S MEDIEN=MED(1,"I")
    79         . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
    80         . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
    81         . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
    82         . S @MAP@("MEDBRANDNAMETEXT")=""
    83         . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    84         . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    85         . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
    86         . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
    87         . ; Units, concentration, etc, come from another call
    88         . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    89         . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    90         . ; NDF Entry IEN, and VA Product Name
    91         . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    92         . ; Documented in the same manual.
    93         . N NDFDATA,CONCDATA
    94         . I $L(MEDIEN) D
    95         . . D NDF^PSS50(MEDIEN,,,,,"CONC")
    96         . . M NDFDATA=^TMP($J,"CONC",MEDIEN)
    97         . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    98         . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
    99         . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    100         . . ; and this will crash the call. So...
    101         . . I NDFIEN="" S CONCDATA=""
    102         . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    103         . E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
    104         . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
    105         . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
    106         . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
    107         . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
    108         . ; Oddly, there is no easy place to find the dispense unit.
    109         . ; It's not included in the original call, so we have to go to the drug file.
    110         . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    111         . ; Node 14.5 is the Dispense Unit
    112         . I $L(MEDIEN) D
    113         . . D DATA^PSS50(MEDIEN,,,,,"QTY")
    114         . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    115         . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    116           E  S @MAP@("MEDQUANTITYUNIT")=""
    117         . ;
    118         . ; --- START OF DIRECTIONS ---
    119         . ; Dosage is field 2, route is 3, schedule is 4
    120         . ; These are all free text fields, and don't point to any files
    121         . ; For that reason, I will use the field I never used before:
    122         . ; MEDDIRECTIONDESCRIPTIONTEXT
    123         . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    124         . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
    125         . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
    126         . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
    127         . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
    128         . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
    129         . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
    130         . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
    131         . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
    132         . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
    133         . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
    134         . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
    135         . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
    136         . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
    137         . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
    138         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
    139         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
    140         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
    141         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
    142         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
    143         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
    144         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
    145         . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
    146         . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
    147         . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
    148         . ;
    149         . ; --- END OF DIRECTIONS ---
    150         . ;
    151         . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
    152         . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
    153         . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
    154         . S @MAP@("MEDRFNO")=""
    155         . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED"))
    156         . K @RESULT
    157         . D MAP^GPLXPATH(MINXML,MAP,RESULT)
    158         . ; D PARY^GPLXPATH(RESULT)
    159         . ; MAPPING DIRECTIONS
    160         . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    161         . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    162         . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    163         . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions")
    164         . ; N MDZ1,MDZNA
    165         . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    166         . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    167         . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    168         . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2)
    169         . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication")
    170         . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy
    171         . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    172         N MEDTMP,MEDI
    173         D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    174         I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    175         . W "MEDICATION MISSING ",!
    176         . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    177         Q
    178         ;
     1C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
     2 ;;0.1;CCDCCR;;;
     3 ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4 ; General Public License See attached copy of the License.
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License along
     17 ; with this program; if not, write to the Free Software Foundation, Inc.,
     18 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "NO ENTRY FROM TOP",!
     21 Q
     22 ;
     23EXTRACT(MINXML,DFN,OUTXML)           ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     24 ;
     25 ; MINXML is the Input XML Template, passed by name
     26 ; DFN is Patient IEN
     27 ; OUTXML is the resultant XML.
     28 ;
     29 ; MEDS is return array from API.
     30 ; MED is holds each array element from MEDS, one medicine
     31 ; MAP is a mapping variable map (store result) for each med
     32 ;
     33 ; Inpatient Meds will be extracted using this routine and and the one following.
     34 ; Inpatient Meds Unit Dose is going to be C0CMED4
     35 ; Inpatient Meds IVs is going to be C0CMED5
     36 ;
     37 ; We will use two Pharmacy ReEnginnering API's:
     38 ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
     39 ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
     40 ; For more information, see the PRE documentation at:
     41 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
     42 ;
     43 ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
     44 ;
     45 N MEDS,MAP
     46 K ^TMP($J)
     47 D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
     48 I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
     49 ; Otherwise, we go on...
     50 M MEDS=^TMP($J,"UD")
     51 I DEBUG ZWR MEDS
     52 S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP"))
     53 N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
     54 N I S I=0
     55 F  S I=$O(MEDS("B",I)) Q:'I  D  ; For each medication in B index
     56 . N MED M MED=MEDS(I)
     57 . S MEDCOUNT=MEDCOUNT+1
     58 . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
     59 . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT))
     60 . N RXIEN S RXIEN=MED(.01) ; Order Number
     61 . I DEBUG W "RXIEN IS ",RXIEN,!
     62 . I DEBUG W "MAP= ",MAP,!
     63 . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
     64 . S @MAP@("MEDISSUEDATETXT")="Order Date"
     65 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
     66 . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
     67 . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
     68 . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
     69 . S @MAP@("MEDRXNO")="" ; For Outpatient
     70 . S @MAP@("MEDTYPETEXT")="Medication"
     71 . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     72 . S @MAP@("MEDSTATUSTEXT")="ACTIVE"
     73 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
     74 . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
     75 . ; NDC is field 31 in the drug file.
     76 . ; The actual drug entry in the drug file is not necessarily supplied.
     77 . ; It' node 1, internal form.
     78 . N MEDIEN S MEDIEN=MED(1,"I")
     79 . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
     80 . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
     81 . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
     82 . S @MAP@("MEDBRANDNAMETEXT")=""
     83 . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     84 . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     85 . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
     86 . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
     87 . ; Units, concentration, etc, come from another call
     88 . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     89 . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     90 . ; NDF Entry IEN, and VA Product Name
     91 . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     92 . ; Documented in the same manual.
     93 . N NDFDATA,CONCDATA
     94 . I $L(MEDIEN) D
     95 . . D NDF^PSS50(MEDIEN,,,,,"CONC")
     96 . . M NDFDATA=^TMP($J,"CONC",MEDIEN)
     97 . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     98 . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
     99 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     100 . . ; and this will crash the call. So...
     101 . . I NDFIEN="" S CONCDATA=""
     102 . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     103 . E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
     104 . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
     105 . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
     106 . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
     107 . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
     108 . ; Oddly, there is no easy place to find the dispense unit.
     109 . ; It's not included in the original call, so we have to go to the drug file.
     110 . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     111 . ; Node 14.5 is the Dispense Unit
     112 . I $L(MEDIEN) D
     113 . . D DATA^PSS50(MEDIEN,,,,,"QTY")
     114 . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     115 . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     116   E  S @MAP@("MEDQUANTITYUNIT")=""
     117 . ;
     118 . ; --- START OF DIRECTIONS ---
     119 . ; Dosage is field 2, route is 3, schedule is 4
     120 . ; These are all free text fields, and don't point to any files
     121 . ; For that reason, I will use the field I never used before:
     122 . ; MEDDIRECTIONDESCRIPTIONTEXT
     123 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     124 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
     125 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
     126 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
     127 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
     128 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
     129 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
     130 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
     131 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
     132 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
     133 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
     134 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
     135 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
     136 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
     137 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
     138 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
     139 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
     140 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
     141 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
     142 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
     143 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
     144 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
     145 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
     146 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
     147 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
     148 . ;
     149 . ; --- END OF DIRECTIONS ---
     150 . ;
     151 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
     152 . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
     153 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
     154 . S @MAP@("MEDRFNO")=""
     155 . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED"))
     156 . K @RESULT
     157 . D MAP^GPLXPATH(MINXML,MAP,RESULT)
     158 . ; D PARY^GPLXPATH(RESULT)
     159 . ; MAPPING DIRECTIONS
     160 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     161 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     162 . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     163 . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions")
     164 . ; N MDZ1,MDZNA
     165 . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     166 . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     167 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     168 . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2)
     169 . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication")
     170 . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy
     171 . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     172 N MEDTMP,MEDI
     173 D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     174 I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     175 . W "MEDICATION MISSING ",!
     176 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     177 Q
     178 ;

  • ccr/branches/ohum/p/C0CMED6.m

    r1330 r1332  
    1 C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "NO ENTRY FROM TOP",!
    21         Q
    22         ;
    23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS)        ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    24         ;
    25         ; MINXML and OUTXML are passed by name so globals can be used
    26         ; MINXML will contain only the medications skeleton of the overall template
    27         ; MEDCOUNT is a counter passed by Reference.
    28         ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
    29         ; FLAGS are set-up in C0CMED.
    30         ;
    31         ; MEDS is return array from RPC.
    32         ; MAP is a mapping variable map (store result) for each med
    33         ; MED is holds each array element from MEDS(J), one medicine
    34         ; J is a counter.
    35         ;
    36         ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used.
    37         ; This API has been developed by Medsphere for IHS for getting
    38         ; Medications from RPMS. It has most of what we need.
    39         ; API written by Doug Martin when he worked for Medsphere (thanks Doug!)
    40         ; -- ARRAYNAME is passed by name (required)
    41         ; -- DFN is passed by value (required)
    42         ; -- DAYS is passed by value (optional; if not passed defaults to 365)
    43         ;
    44         ; Return:
    45         ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID
    46         ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^
    47         ; Status Reason^DEA Handling
    48         ;
    49         N MEDS,MEDS1,MAP
    50         D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360"
    51         N ALL S ALL=+FLAGS
    52         N ACTIVE S ACTIVE=$P(FLAGS,U,3)
    53         N PENDING S PENDING=$P(FLAGS,U,4)
    54         S @OUTXML@(0)=0  ;By default, no meds
    55         ; If MEDS1 is not defined, then no meds
    56         I '$D(MEDS1) QUIT
    57         I DEBUG ZWR MEDS1,MINXML
    58         N MEDCNT S MEDCNT=0 ; Med Count
    59         ; The next line is a super line. It goes through the array return
    60         ; and if the first characters are ~OP, it grabs the line.
    61         ; This means that line is for a dispensed Outpatient Med.
    62         ; That line has the metadata about the med that I need.
    63         ; The next lines, however many, are the med and the sig.
    64         ; I won't be using those because I have to get the sig parsed exactly.
    65         N J S J="" F  S J=$O(MEDS1(J)) Q:J=""  I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J)
    66         K MEDS1
    67         S MEDCNT="" ; Initialize for $Order
    68         F  S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT=""  D  ; for each medication in the list
    69         . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT
    70         . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT
    71         . I DEBUG W "MEDCNT IS ",MEDCNT,!
    72         . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT))
    73         . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
    74         . I DEBUG W "MAP= ",MAP,!
    75         . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID
    76         . S @MAP@("MEDISSUEDATETXT")="Issue Date"
    77         . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT")
    78         . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
    79         . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT")
    80         . S @MAP@("MEDRXNOTXT")="Prescription Number"
    81         . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14)
    82         . S @MAP@("MEDTYPETEXT")="Medication"
    83         . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    84         . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10)
    85         . ; Provider only provided in API as text, not DUZ.
    86         . ; We need to get DUZ from filman file 52 (Prescription)
    87         . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters.
    88         . ; Note that I will use RXIEN several times later
    89         . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2)
    90         . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I")
    91         . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3)
    92         . ; --- RxNorm Stuff
    93         . ; 176.001 is the file for Concepts; 176.003 is the file for
    94         . ; sources (i.e. for RxNorm Version)
    95         . ;
    96         . ; I use 176.001 for the Vista version of this routine (files 1-3)
    97         . ; Since IHS does not have VUID's, I will be getting RxNorm codes
    98         . ; using NDCs. My specially crafted index (sounds evil) named "NDC"
    99         . ; is in file 176.002. The file is called RxNorm NDC to VUID.
    100         . ; Except that I don't need the VUID, but it's there if I need it.
    101         . ;
    102         . ; We obviously need the NDC. That is easily obtained from the prescription.
    103         . ; Field 27 in file 52
    104         . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I")
    105         . ; I discovered that file 176.002 might give you two codes for the NDC
    106         . ; One for the Clinical Drug, and one for the ingredient.
    107         . ; So the plan is to get the two RxNorm codes, and then find from
    108         . ; file 176.001 which one is the Clinical Drug.
    109         . ; ... I refactored this into GETRXN
    110         . N RXNORM,SRCIEN,RXNNAME,RXNVER
    111         . I +NDC,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
    112         . . S RXNORM=$$GETRXN(NDC)
    113         . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B")
    114         . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
    115         . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
    116         . ;
    117         . E  S (RXNORM,RXNNAME,RXNVER)=""
    118         . ; End if/else block
    119         . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    120         . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    121         . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    122         . ; --- End RxNorm section
    123         . ;
    124         . ; Brand name is 52 field 6.5
    125         . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5)
    126         . ;
    127         . ; Next I need Med Form (tab, cap etc), strength (250mg)
    128         . ; concentration for liquids (250mg/mL)
    129         . ; Since IHS does not have any of the new calls that
    130         . ; Vista has, I will be doing a crosswalk:
    131         . ; File 52, field 6 is Drug IEN in file 50
    132         . ; File 50, field 22 is VA Product IEN in file 50.68
    133         . ; In file 50.68, I will get the following:
    134         . ; -- 1: Dosage Form
    135         . ; -- 2: Strength
    136         . ; -- 3: Units
    137         . ; -- 8: Dispense Units
    138         . ; -- Conc is 2 concatenated with 3
    139         . ;
    140         . ; *** If Drug is not matched to NDF, then VA Product will be "" ***
    141         . ;
    142         . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50
    143         . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68
    144         . I +VAPROD D
    145         . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2)
    146         . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3)
    147         . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1)
    148         . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE")
    149         . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT")
    150         . E  D
    151         . . S @MAP@("MEDSTRENGTHVALUE")=""
    152         . . S @MAP@("MEDSTRENGTHUNIT")=""
    153         . . S @MAP@("MEDFORMTEXT")=""
    154         . . S @MAP@("MEDCONCVALUE")=""
    155         . . S @MAP@("MEDCONCUNIT")=""
    156         . ; End Strengh/Conc stuff
    157         . ;
    158         . ; Quantity is in the prescription, field 7
    159         . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7)
    160         . ; Dispense unit is in the drug file, field 14.5
    161         . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5)
    162         . ;
    163         . ; --- START OF DIRECTIONS ---
    164         . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
    165         . ; we want the components.
    166         . ; It's in multiple 113 in the Prescription File (52)
    167         . ; #.01 DOSAGE ORDERED [1F]                    "20"
    168         . ; #1 DISPENSE UNITS PER DOSE [2N]     "1"
    169         . ; #2 UNITS [3P:50.607]                                "MG"
    170         . ; #3 NOUN [4F]                                                "TABLET"
    171         . ; #4 DURATION [5F]                                    "10D"
    172         . ; #5 CONJUNCTION [6S]                                 "AND"
    173         . ; #6 ROUTE [7P:51.2]                          "ORAL"
    174         . ; #7 SCHEDULE [8F]                                    "BID"
    175         . ; #8 VERB [9F]                                                "TAKE"
    176         . ;
    177         . ; Will use GETS^DIQ to get fields.
    178         . ; Data comes out like this:
    179         . ; SAMINS(52.0113,"1,23,",.01)=20
    180         . ; SAMINS(52.0113,"1,23,",1)=1
    181         . ; SAMINS(52.0113,"1,23,",2)="MG"
    182         . ; SAMINS(52.0113,"1,23,",3)="TABLET"
    183         . ; SAMINS(52.0113,"1,23,",4)="5D"
    184         . ; SAMINS(52.0113,"1,23,",5)="THEN"
    185         . ;
    186         . N RAWDATA
    187         . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR")
    188         . D:$D(DIERR) ^%ZTER  ; Log if there's an error in retrieving sig field
    189         . ; none the less, continue; some parts are retrievable.
    190         . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile...
    191         . K RAWDATA
    192         . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman.
    193         . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
    194         . ; DIRCNT is the proper Sigline numer.
    195         . ; SIGDATA is the simplfied array.
    196         . F  S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM=""  D
    197         . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",")
    198         . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM)
    199         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
    200         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
    201         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8))
    202         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01))
    203         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2))
    204         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
    205         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
    206         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
    207         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6))
    208         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7))
    209         . . ; Invervals... again another call.
    210         . . ; In the wisdom of the original programmers, the schedule is a free text field
    211         . . ; However, it gets translated by a call to the administration schedule file
    212         . . ; to see if that schedule exists.
    213         . . ; That's the same thing I am going to do.
    214         . . ; Search B index of 51.1 (Admin Schedule) with schedule
    215         . . ; First, remove "PRN" if it exists (don't ask, that's how the file
    216         . . ; works; I wouldn't do it that way).
    217         . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7))
    218         . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5)
    219         . . ; Super call below:
    220         . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes)
    221         . . ; 4=Packed format, Exact Match 5=Lookup Value
    222         . . ; 6=# of entries to return 7=Index 10=Return Array
    223         . . ;
    224         . . ; I do not account for the fact that two schedules can be
    225         . . ; spelled identically (ie duplicate entry). In that case,
    226         . . ; I get the first. That's just a bad pharmacy pkg maintainer.
    227         . . N C0C515
    228         . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515")
    229         . . N INTERVAL S INTERVAL="" ; Default
    230         . . ; If there are entries found, get it
    231         . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2)
    232         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
    233         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
    234         . . ; Duration is 10M minutes, 10H hours, 10D for Days
    235         . . ; 10W for weeks, 10L for months. I smell $Select
    236         . . ; But we don't need to do that if there isn't a duration
    237         . . I +$G(SIGDATA(4)) D
    238         . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char
    239         . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days")
    240         . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4)
    241         . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT
    242         . . E  D
    243         . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=""
    244         . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
    245         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN"
    246         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail
    247         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
    248         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
    249         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
    250         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
    251         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
    252         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
    253         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored
    254         . . ; Another confusing line; I am pretty bad:
    255         . . ; If there is another entry in the FMSIG array (i.e. another line
    256         . . ; in the sig), set the direction count indicator.
    257         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=""  ; Default
    258         . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT
    259         . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5))
    260         . ;
    261         . ; --- END OF DIRECTIONS ---
    262         . ;
    263         . ; Med instructions is a WP field, thus the acrobatics
    264         . ; Notice buffer overflow protection set at 10,000 chars
    265         . ; -- 1. Med Patient Instructions
    266         . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1")
    267         . N MEDPTIN2,J  S (MEDPTIN2,J)=""
    268         . I $L(MEDPTIN1) F  S J=$O(@MEDPTIN1@(J)) Q:J=""  Q:$L(MEDPTIN2)>10000  S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" "
    269         . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2
    270         . K J
    271         . ; -- 2. Med Provider Instructions
    272         . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1")
    273         . N MEDPVIN2,J S (MEDPVIN2,J)=""
    274         . I $L(MEDPVIN1) F  S J=$O(@MEDPVIN1@(J)) Q:J=""  Q:$L(MEDPVIN2)>10000  S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" "
    275         . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2
    276         . ;
    277         . ; Remaining refills
    278         . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6)
    279         . ; ------ END OF MAPPING
    280         . ;
    281         . ; ------ BEGIN XML INSERTION
    282         . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    283         . K @RESULT
    284         . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    285         . ; D PARY^C0CXPATH(RESULT)
    286         . ; MAPPING DIRECTIONS
    287         . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    288         . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    289         . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    290         . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    291         . ; N MDZ1,MDZNA
    292         . N DIRCNT S DIRCNT=""
    293         . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; IF THERE ARE DIRCTIONS
    294         . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; FOR EACH DIRECTION
    295         . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT))
    296         . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    297         . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    298         . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    299         . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    300         . S MEDCOUNT=MEDCNT
    301         N MEDTMP,MEDI
    302         D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    303         I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    304         . W "MEDICATION MISSING ",!
    305         . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    306         Q
    307         ;
     1C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
     2 ;;1.0;C0C;;May 19, 2009;
     3 ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4 ; General Public License See attached copy of the License.
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License along
     17 ; with this program; if not, write to the Free Software Foundation, Inc.,
     18 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "NO ENTRY FROM TOP",!
     21 Q
     22 ;
     23EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS)  ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     24 ;
     25 ; MINXML and OUTXML are passed by name so globals can be used
     26 ; MINXML will contain only the medications skeleton of the overall template
     27 ; MEDCOUNT is a counter passed by Reference.
     28 ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
     29 ; FLAGS are set-up in C0CMED.
     30 ;
     31 ; MEDS is return array from RPC.
     32 ; MAP is a mapping variable map (store result) for each med
     33 ; MED is holds each array element from MEDS(J), one medicine
     34 ; J is a counter.
     35 ;
     36 ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used.
     37 ; This API has been developed by Medsphere for IHS for getting
     38 ; Medications from RPMS. It has most of what we need.
     39 ; API written by Doug Martin when he worked for Medsphere (thanks Doug!)
     40 ; -- ARRAYNAME is passed by name (required)
     41 ; -- DFN is passed by value (required)
     42 ; -- DAYS is passed by value (optional; if not passed defaults to 365)
     43 ;
     44 ; Return:
     45 ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID
     46 ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^
     47 ; Status Reason^DEA Handling
     48 ;
     49 N MEDS,MEDS1,MAP
     50 D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360"
     51 N ALL S ALL=+FLAGS
     52 N ACTIVE S ACTIVE=$P(FLAGS,U,3)
     53 N PENDING S PENDING=$P(FLAGS,U,4)
     54 S @OUTXML@(0)=0  ;By default, no meds
     55 ; If MEDS1 is not defined, then no meds
     56 I '$D(MEDS1) QUIT
     57 I DEBUG ZWR MEDS1,MINXML
     58 N MEDCNT S MEDCNT=0 ; Med Count
     59 ; The next line is a super line. It goes through the array return
     60 ; and if the first characters are ~OP, it grabs the line.
     61 ; This means that line is for a dispensed Outpatient Med.
     62 ; That line has the metadata about the med that I need.
     63 ; The next lines, however many, are the med and the sig.
     64 ; I won't be using those because I have to get the sig parsed exactly.
     65 N J S J="" F  S J=$O(MEDS1(J)) Q:J=""  I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J)
     66 K MEDS1
     67 S MEDCNT="" ; Initialize for $Order
     68 F  S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT=""  D  ; for each medication in the list
     69 . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT
     70 . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT
     71 . I DEBUG W "MEDCNT IS ",MEDCNT,!
     72 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT))
     73 . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
     74 . I DEBUG W "MAP= ",MAP,!
     75 . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID
     76 . S @MAP@("MEDISSUEDATETXT")="Issue Date"
     77 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT")
     78 . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
     79 . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT")
     80 . S @MAP@("MEDRXNOTXT")="Prescription Number"
     81 . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14)
     82 . S @MAP@("MEDTYPETEXT")="Medication"
     83 . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     84 . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10)
     85 . ; Provider only provided in API as text, not DUZ.
     86 . ; We need to get DUZ from filman file 52 (Prescription)
     87 . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters.
     88 . ; Note that I will use RXIEN several times later
     89 . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2)
     90 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I")
     91 . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3)
     92 . ; --- RxNorm Stuff
     93 . ; 176.001 is the file for Concepts; 176.003 is the file for
     94 . ; sources (i.e. for RxNorm Version)
     95 . ;
     96 . ; I use 176.001 for the Vista version of this routine (files 1-3)
     97 . ; Since IHS does not have VUID's, I will be getting RxNorm codes
     98 . ; using NDCs. My specially crafted index (sounds evil) named "NDC"
     99 . ; is in file 176.002. The file is called RxNorm NDC to VUID.
     100 . ; Except that I don't need the VUID, but it's there if I need it.
     101 . ;
     102 . ; We obviously need the NDC. That is easily obtained from the prescription.
     103 . ; Field 27 in file 52
     104 . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I")
     105 . ; I discovered that file 176.002 might give you two codes for the NDC
     106 . ; One for the Clinical Drug, and one for the ingredient.
     107 . ; So the plan is to get the two RxNorm codes, and then find from
     108 . ; file 176.001 which one is the Clinical Drug.
     109 . ; ... I refactored this into GETRXN
     110 . N RXNORM,SRCIEN,RXNNAME,RXNVER
     111 . I +NDC,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
     112 . . S RXNORM=$$GETRXN(NDC)
     113 . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B")
     114 . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
     115 . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
     116 . ;
     117 . E  S (RXNORM,RXNNAME,RXNVER)=""
     118 . ; End if/else block
     119 . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
     120 . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
     121 . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
     122 . ; --- End RxNorm section
     123 . ;
     124 . ; Brand name is 52 field 6.5
     125 . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5)
     126 . ;
     127 . ; Next I need Med Form (tab, cap etc), strength (250mg)
     128 . ; concentration for liquids (250mg/mL)
     129 . ; Since IHS does not have any of the new calls that
     130 . ; Vista has, I will be doing a crosswalk:
     131 . ; File 52, field 6 is Drug IEN in file 50
     132 . ; File 50, field 22 is VA Product IEN in file 50.68
     133 . ; In file 50.68, I will get the following:
     134 . ; -- 1: Dosage Form
     135 . ; -- 2: Strength
     136 . ; -- 3: Units
     137 . ; -- 8: Dispense Units
     138 . ; -- Conc is 2 concatenated with 3
     139 . ;
     140 . ; *** If Drug is not matched to NDF, then VA Product will be "" ***
     141 . ;
     142 . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50
     143 . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68
     144 . I +VAPROD D
     145 . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2)
     146 . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3)
     147 . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1)
     148 . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE")
     149 . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT")
     150 . E  D
     151 . . S @MAP@("MEDSTRENGTHVALUE")=""
     152 . . S @MAP@("MEDSTRENGTHUNIT")=""
     153 . . S @MAP@("MEDFORMTEXT")=""
     154 . . S @MAP@("MEDCONCVALUE")=""
     155 . . S @MAP@("MEDCONCUNIT")=""
     156 . ; End Strengh/Conc stuff
     157 . ;
     158 . ; Quantity is in the prescription, field 7
     159 . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7)
     160 . ; Dispense unit is in the drug file, field 14.5
     161 . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5)
     162 . ;
     163 . ; --- START OF DIRECTIONS ---
     164 . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
     165 . ; we want the components.
     166 . ; It's in multiple 113 in the Prescription File (52)
     167 . ; #.01 DOSAGE ORDERED [1F]                   "20"
     168 . ; #1 DISPENSE UNITS PER DOSE [2N]    "1"
     169 . ; #2 UNITS [3P:50.607]                               "MG"
     170 . ; #3 NOUN [4F]                                               "TABLET"
     171 . ; #4 DURATION [5F]                                   "10D"
     172 . ; #5 CONJUNCTION [6S]                                "AND"
     173 . ; #6 ROUTE [7P:51.2]                                 "ORAL"
     174 . ; #7 SCHEDULE [8F]                                   "BID"
     175 . ; #8 VERB [9F]                                               "TAKE"
     176 . ;
     177 . ; Will use GETS^DIQ to get fields.
     178 . ; Data comes out like this:
     179 . ; SAMINS(52.0113,"1,23,",.01)=20
     180 . ; SAMINS(52.0113,"1,23,",1)=1
     181 . ; SAMINS(52.0113,"1,23,",2)="MG"
     182 . ; SAMINS(52.0113,"1,23,",3)="TABLET"
     183 . ; SAMINS(52.0113,"1,23,",4)="5D"
     184 . ; SAMINS(52.0113,"1,23,",5)="THEN"
     185 . ;
     186 . N RAWDATA
     187 . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR")
     188 . D:$D(DIERR) ^%ZTER  ; Log if there's an error in retrieving sig field
     189 . ; none the less, continue; some parts are retrievable.
     190 . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile...
     191 . K RAWDATA
     192 . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman.
     193 . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
     194 . ; DIRCNT is the proper Sigline numer.
     195 . ; SIGDATA is the simplfied array.
     196 . F  S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM=""  D
     197 . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",")
     198 . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM)
     199 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
     200 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
     201 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8))
     202 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01))
     203 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2))
     204 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
     205 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
     206 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
     207 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6))
     208 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7))
     209 . . ; Invervals... again another call.
     210 . . ; In the wisdom of the original programmers, the schedule is a free text field
     211 . . ; However, it gets translated by a call to the administration schedule file
     212 . . ; to see if that schedule exists.
     213 . . ; That's the same thing I am going to do.
     214 . . ; Search B index of 51.1 (Admin Schedule) with schedule
     215 . . ; First, remove "PRN" if it exists (don't ask, that's how the file
     216 . . ; works; I wouldn't do it that way).
     217 . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7))
     218 . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5)
     219 . . ; Super call below:
     220 . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes)
     221 . . ; 4=Packed format, Exact Match 5=Lookup Value
     222 . . ; 6=# of entries to return 7=Index 10=Return Array
     223 . . ;
     224 . . ; I do not account for the fact that two schedules can be
     225 . . ; spelled identically (ie duplicate entry). In that case,
     226 . . ; I get the first. That's just a bad pharmacy pkg maintainer.
     227 . . N C0C515
     228 . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515")
     229 . . N INTERVAL S INTERVAL="" ; Default
     230 . . ; If there are entries found, get it
     231 . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2)
     232 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
     233 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
     234 . . ; Duration is 10M minutes, 10H hours, 10D for Days
     235 . . ; 10W for weeks, 10L for months. I smell $Select
     236 . . ; But we don't need to do that if there isn't a duration
     237 . . I +$G(SIGDATA(4)) D
     238 . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char
     239 . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days")
     240 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4)
     241 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT
     242 . . E  D
     243 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=""
     244 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
     245 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN"
     246 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail
     247 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
     248 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
     249 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
     250 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
     251 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
     252 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
     253 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored
     254 . . ; Another confusing line; I am pretty bad:
     255 . . ; If there is another entry in the FMSIG array (i.e. another line
     256 . . ; in the sig), set the direction count indicator.
     257 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=""  ; Default
     258 . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT
     259 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5))
     260 . ;
     261 . ; --- END OF DIRECTIONS ---
     262 . ;
     263 . ; Med instructions is a WP field, thus the acrobatics
     264 . ; Notice buffer overflow protection set at 10,000 chars
     265 . ; -- 1. Med Patient Instructions
     266 . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1")
     267 . N MEDPTIN2,J  S (MEDPTIN2,J)=""
     268 . I $L(MEDPTIN1) F  S J=$O(@MEDPTIN1@(J)) Q:J=""  Q:$L(MEDPTIN2)>10000  S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" "
     269 . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2
     270 . K J
     271 . ; -- 2. Med Provider Instructions
     272 . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1")
     273 . N MEDPVIN2,J S (MEDPVIN2,J)=""
     274 . I $L(MEDPVIN1) F  S J=$O(@MEDPVIN1@(J)) Q:J=""  Q:$L(MEDPVIN2)>10000  S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" "
     275 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2
     276 . ;
     277 . ; Remaining refills
     278 . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6)
     279 . ; ------ END OF MAPPING
     280 . ;
     281 . ; ------ BEGIN XML INSERTION
     282 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     283 . K @RESULT
     284 . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     285 . ; D PARY^C0CXPATH(RESULT)
     286 . ; MAPPING DIRECTIONS
     287 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     288 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     289 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     290 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     291 . ; N MDZ1,MDZNA
     292 . N DIRCNT S DIRCNT=""
     293 . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; IF THERE ARE DIRCTIONS
     294 . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; FOR EACH DIRECTION
     295 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT))
     296 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     297 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     298 . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     299 . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     300 . S MEDCOUNT=MEDCNT
     301 N MEDTMP,MEDI
     302 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     303 I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     304 . W "MEDICATION MISSING ",!
     305 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     306 Q
     307 ;
    308308GETRXN(NDC)     ; Extrinsic Function; PUBLIC; NDC to RxNorm
    309         ;; Get RxNorm Concept Number for a Given NDC
    310         ;
    311         S NDC=$TR(NDC,"-")  ; Remove dashes
    312         N RXNORM,C0CZRXN,DIERR
    313         D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR")
    314         I $D(DIERR) D ^%ZTER BREAK
    315         S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries
    316         N I S I=0
    317         F  S I=$O(C0CZRXN("DILIST",I)) Q:I=""  S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2)
    318         ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries
    319         ; If RxNorm(0) is 1, then we only have one entry, and that's it.
    320         I RXNORM(0)=1 QUIT RXNORM(1)  ; RETURN RXNORM(1)
    321         ; Otherwise, we need to find out which one is the semantic
    322         ; clinical drug. I built an index on 176.001 (RxNorm Concepts)
    323         ; for that purpose.
    324         I RXNORM(0)>1 D
    325         . S I=0
    326         . F  S I=$O(RXNORM(I)) Q:I=""  D  Q:$G(RXNORM)
    327         . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD")
    328         . . I +$G(RXNIEN)=0 QUIT  ; try the next entry...
    329         . . E  S RXNORM=RXNORM(I) QUIT  ; We found the right code
    330         QUIT +$G(RXNORM)  ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0
    331        
     309 ;; Get RxNorm Concept Number for a Given NDC
     310 ;
     311 S NDC=$TR(NDC,"-")  ; Remove dashes
     312 N RXNORM,C0CZRXN,DIERR
     313 D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR")
     314 I $D(DIERR) D ^%ZTER BREAK
     315 S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries
     316 N I S I=0
     317 F  S I=$O(C0CZRXN("DILIST",I)) Q:I=""  S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2)
     318 ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries
     319 ; If RxNorm(0) is 1, then we only have one entry, and that's it.
     320 I RXNORM(0)=1 QUIT RXNORM(1)  ; RETURN RXNORM(1)
     321 ; Otherwise, we need to find out which one is the semantic
     322 ; clinical drug. I built an index on 176.001 (RxNorm Concepts)
     323 ; for that purpose.
     324 I RXNORM(0)>1 D
     325 . S I=0
     326 . F  S I=$O(RXNORM(I)) Q:I=""  D  Q:$G(RXNORM)
     327 . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD")
     328 . . I +$G(RXNIEN)=0 QUIT  ; try the next entry...
     329 . . E  S RXNORM=RXNORM(I) QUIT  ; We found the right code
     330 QUIT +$G(RXNORM)  ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0
     331 

  • ccr/branches/ohum/p/C0CMIME.m

    r1330 r1332  
    1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
    2         ;;1.0;C0C;;Mar 8, 2011;Build 1
    3         ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 TEST(ZDFN)      ;
    23         D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
    24         ;M ZCOPY=ZCCR
    25         S ZCOPY(1)=""
    26         N ZI S ZI=0
    27         F  S ZI=$O(ZCCR(ZI)) Q:ZI=""  D  ; FOR EACH LINE
    28         . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
    29         ;D ENCODE("ZCOPY",1,ZCOPY(1))
    30         S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
    31         D CHUNK("G2","G",45)
    32         Q
    33 ENCODE(ZRTN,ZARY)       ;
    34         ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
    35         ; ZARY IS PASSED BY NAME
    36         ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
    37         ;
    38         S ZCOPY(1)=""
    39         N ZI S ZI=0
    40         F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE
    41         . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
    42         N G
    43         S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
    44         D CHUNK(ZRTN,"G",45)
    45         Q
    46         ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
    47 ENCODEOLD(IARY,LRNODE,LRSTR)    ; Encode a string, keep remainder for next line
    48         ; Call with LRSTR by reference, Remainder returned in LRSTR
    49         ; IARY IS PASSED BY NAME
    50         S LRQUIT=0,LRLEN=$L(LRSTR)
    51         F  D  Q:LRQUIT
    52         . I $L(LRSTR)<45 S LRQUIT=1 Q
    53         . S LRX=$E(LRSTR,1,45)
    54         . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
    55         . S LRSTR=$E(LRSTR,46,LRLEN)
    56         Q
    57         ;
    58 TESTMAIL        ;
    59         ; TEST OF MAILSEND
    60         ;S ZTO("glilly@glilly.net")=""
    61         S ZTO("mish@nhin.openforum.opensourcevista.net")=""
    62         ;S ZTO("martijn@djigzo.com")=""
    63         ;S ZTO("profmish@gmail.com")=""
    64         ;S ZTO("nanthracite@earthlink.net")=""
    65         S ZFROM="ANTHRACITE.NANCY"
    66         S ZATTACH=$NA(^GPL("CCR"))
    67         I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
    68         . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
    69         . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
    70         S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
    71         D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
    72         ZWR GR
    73         Q
    74         ;
    75 TESTMAIL2       ;
    76         ; TEST OF MAILSEND TO gpl.mdc-crew.net
    77         N C0CGM
    78         S C0CGM(1)="This is a test message."
    79         S C0CGM(2)="A Continuity of Care record is attached"
    80         S C0CGM(3)="It contains no Protected Health Information (PHI)"
    81         S C0CGM(4)="It is purely test data used for software development"
    82         S C0CGM(5)="It does not represent information about any person living or dead"
    83         ;S ZTO("glilly@glilly.net")=""
    84         ;S ZTO("george.lilly@pobox.com")=""
    85         ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
    86         ;S ZTO("mish@nhin.openforum.opensourcevista.net")=""
    87         S ZTO("brooks.richard@securemail.opensourcevista.net")=""
    88         ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
    89         ;S ZTO("ncoal@live.com")=""
    90         ;S ZTO("martijn@djigzo.com")=""
    91         ;S ZTO("profmish@gmail.com")=""
    92         ;S ZTO("nanthracite@earthlink.net")=""
    93         S ZTO("gpl.doctortest@gmail.com")=""
    94         S ZFROM="LILLY.GEORGE"
    95         S ZATTACH=$NA(^GPL("CCR"))
    96         I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
    97         . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
    98         . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
    99         S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
    100         D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
    101         ZWR GR
    102         Q
    103         ;
    104 LINE(C0CFILE,C0CTO)     ; read a file name passed in C0CFILE and send it to
    105         ; the email address in C0CTO
    106         ; the directory and the "from" are all hard coded
    107         ;
    108         N ZZFROM S ZZFROM="LILLY.GEORGE"
    109         N GN S GN=$NA(^TMP("C0CMIME2",$J))
    110         N GN1 S GN1=$NA(@GN@(1))
    111         K @GN
    112         I '$D(C0CFILE) Q  ; NO FILENAME PASSED
    113         I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
    114         S ZZTO(C0CTO)=""
    115         N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
    116         N GD S GD="/home/wvehr3-09/EHR/" ; directory
    117         I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q  D  ;
    118         . W !,"error reading file",C0CFILE
    119         D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
    120         K @GN ; CLEAN UP
    121         ;ZWR ZRTN
    122         W !,$G(ZRTN(1))
    123         Q
    124         ;
    125 MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS)     ; MAIL SENDING INTERFACE
    126         ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
    127         ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
    128         ;  IF NULL, WILL SEND FROM THE CURRENT DUZ
    129         ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
    130         ;  @TO@("addr1@domain1.net")
    131         ;  @CC@("addr2@domain2.com")  both can be multiples
    132         ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
    133         ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
    134         ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
    135         ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
    136         ;
    137         I '$D(FNAME) S FNAME="ccr.xml" ; default filename
    138         N GN
    139         S GN=$NA(^TMP($J,"C0CMIME"))
    140         K @GN
    141         S GM(1)="MIME-Version: 1.0"
    142         S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
    143         S GM(3)=""
    144         S GM(4)=""
    145         ;S GM(5)="--123456788888"
    146         ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
    147         S GM(5)="--123456899999"
    148         S GM(6)="Content-Type: text/xml; name="_FNAME
    149         S GM(7)="Content-Transfer-Encoding: base64"
    150         S GM(8)="Content-Disposition: attachment; filename="_FNAME
    151         S GM(9)=""
    152         S GM(10)="" ; FOR THE END
    153         ;S GM(11)="--123456788888--"
    154         S GM(11)="--123456899999--"
    155         S GM(12)=""
    156         S GM(13)=""
    157         S GG(1)="--123456899999"
    158         S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
    159         S GG(3)="Content-Transfer-Encoding: 7bit"
    160         S GG(4)=""
    161         S GG(5)="This is a test message."
    162         S GG(6)="A Continuity of Care record is attached"
    163         S GG(7)="It contains no Protected Health Information (PHI)"
    164         S GG(8)="It is purely test data used for software development"
    165         S GG(9)="It does not represent information about any person living or dead"
    166         S GG(10)=""
    167         S GG(11)="--123456899999--"
    168         ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
    169         S GG(12)=""
    170         ;S GG(13)="This is a test message."
    171         S GG(14)="A Continuity of Care record is attached"
    172         S GG(15)="It contains no Protected Health Information (PHI)"
    173         S GG(16)="It is purely test data used for software development"
    174         S GG(17)="It does not represent information about any person living or dead"
    175         S GG(18)=""
    176         S GG(19)="--123456899999"
    177         S GG(20)="--987654321--"
    178         K GBLD
    179         ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
    180         ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
    181         I $D(MESSAGE)'="" D  ; THERE IS A MESSAGE
    182         . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
    183         . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
    184         . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
    185         D QUEUE^C0CXPATH("GBLD","GM",5,9)
    186         I $D(ATTACH)'="" D  ; IF WE HAVE AN ATTACHMENT
    187         . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
    188         . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
    189         D QUEUE^C0CXPATH("GBLD","GM",11,12)
    190         D BUILD^C0CXPATH("GBLD",GN)
    191         ;S GGG=$NA(^GPL("MIME2"))
    192         K @GN@(0) ; KILL THE LINE COUNT
    193         K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    194         M LRTO=@TO
    195         I $D(CC) M LRTO=@CC
    196         S LRINSTR("ADDR FLAGS")="R"
    197         S LRINSTR("FROM")=$G(FROM)
    198         S LRMSUBJ=$G(SUBJECT)
    199         S LRMSUBJ=$E(LRMSUBJ,1,65)
    200         D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
    201         I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q  ;
    202         S RTN(1)="OK"
    203         Q
    204         ;
    205 MAILSEND0(LRMSUBJ)      ; Send extract back to requestor.
    206         ;
    207         ;D TEST
    208         S GN=$NA(^TMP($J,"C0CMIME"))
    209         K @GN
    210         ;M @GN=G2
    211         S GM(1)="MIME-Version: 1.0"
    212         S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
    213         S GM(3)=""
    214         S GM(4)=""
    215         S GM(5)="--1234567"
    216         ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
    217         S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
    218         S GM(7)="Content-Transfer-Encoding: base64"
    219         S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
    220         ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
    221         S GM(9)=""
    222         S GM(10)="" ; FOR THE END
    223         S GM(11)="--frontier--"
    224         S GM(12)="."
    225         S GM(13)=""
    226         K GBLD
    227         ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
    228         ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
    229         ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
    230         ;D BUILD^C0CXPATH("GBLD",GN)
    231         S GGG=$NA(^GPL("MIME2"))
    232         ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
    233         D QUEUE^C0CXPATH("GBLD",GGG,21,159)
    234         D BUILD^C0CXPATH("GBLD",GN)
    235         K @GN@(0) ; KILL THE LINE COUNT
    236         K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    237         S XQSND="glilly@glilly.net"
    238         ;S XQSND="nanthracite@earthlink.net"
    239         ;S XQSND="dlefevre@orohosp.com"
    240         ;S XQSND="gregwoodhouse@me.com"
    241         ;S XQSND="rick.marshall@vistaexpertise.net"
    242         S LRTO(XQSND)=""
    243         S LRINSTR("ADDR FLAGS")="R"
    244         S LRINSTR("FROM")="CCR_PACKAGE"
    245         S LRMSUBJ="A SAMPLE CCR"
    246         S LRMSUBJ=$E(LRMSUBJ,1,65)
    247         D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
    248         I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
    249         ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
    250         ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
    251         Q
    252         ;
    253 MAILSEND2(UDFN,ADDR)    ; Send extract back to requestor.
    254         ;
    255         I +$G(UDFN)=0 S UDFN=2 ;
    256         D TEST(UDFN)
    257         S GN=$NA(^TMP($J,"C0CMIME"))
    258         K @GN
    259         ;M @GN=G2
    260         S GM(1)="MIME-Version: 1.0"
    261         S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
    262         S GM(3)=""
    263         S GM(4)=""
    264         S GM(5)="--1234567"
    265         ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
    266         S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
    267         S GM(7)="Content-Transfer-Encoding: base64"
    268         S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
    269         ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
    270         S GM(9)=""
    271         S GM(10)="" ; FOR THE END
    272         S GM(11)="--1234567--"
    273         S GM(12)=""
    274         S GM(13)=""
    275         K GBLD
    276         D QUEUE^C0CXPATH("GBLD","GM",5,9)
    277         D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
    278         D QUEUE^C0CXPATH("GBLD","GM",10,12)
    279         D BUILD^C0CXPATH("GBLD",GN)
    280         S GGG=$NA(^GPL("MIME2"))
    281         ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
    282         ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
    283         ;D BUILD^C0CXPATH("GBLD",GN)
    284         K @GN@(0) ; KILL THE LINE COUNT
    285         K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    286         I $G(ADDR)'="" S XQSND=ADDR
    287         E  S XQSND="glilly@glilly.net"
    288         ;S XQSND="nanthracite@earthlink.net"
    289         ;S XQSND="dlefevre@orohosp.com"
    290         ;S XQSND="gregwoodhouse@me.com"
    291         ;S XQSND="rick.marshall@vistaexpertise.net"
    292         S LRTO(XQSND)=""
    293         ;S LRTO("glilly@glilly.net")=""
    294         S LRINSTR("ADDR FLAGS")="R"
    295         S LRINSTR("FROM")="ANTHRACITE.NANCY"
    296         S LRMSUBJ="Sending a CCR with Mailman"
    297         S LRMSUBJ=$E(LRMSUBJ,1,65)
    298         D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
    299         I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
    300         ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
    301         ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
    302         Q
    303         ;
    304 SIMPLE  ;
    305         S GN(1)="SIMPLE TEST MESSAGE"
    306         K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    307         S XQSND="glilly@glilly.net"
    308         S LRTO(XQSND)=""
    309         S LRINSTR("ADDR FLAGS")="R"
    310         S LRINSTR("FROM")="CCR_PACKAGE"
    311         S LRMSUBJ="A SAMPLE CCR"
    312         S LRMSUBJ=$E(LRMSUBJ,1,65)
    313         D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
    314         Q
    315 CHUNK(OUTXML,INXML,ZSIZE)       ; BREAKS INXML INTO ZSIZE BLOCKS
    316         ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
    317         ; OUTXML IS ALSO PASSED BY NAME
    318         ; IF ZSIZE IS NOT PASSED, 1000 IS USED
    319         I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
    320         N ZB,ZI,ZJ,ZK,ZL,ZN
    321         S ZB=ZSIZE-1
    322         S ZN=1
    323         S ZI=0 ; BEGINNING OF INDEX TO INXML
    324         F  S ZI=$O(@INXML@(ZI)) Q:+ZI=0  D  ; FOR EACH STRING IN INXML
    325         . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
    326         . F ZJ=1:ZSIZE:ZL D  ;
    327         . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
    328         . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
    329         . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
    330         Q
    331         ;
    332 CLEAN(IARY)     ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
    333         ;
    334         N ZI S ZI=0
    335         F  S ZI=$O(@IARY@(ZI)) Q:+ZI=0  D  ;
    336         . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
    337         . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
    338         Q
    339         ;
     1C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
     2 ;;1.0;C0C;;Mar 8, 2011;
     3 ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     22TEST(ZDFN) ;
     23 D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
     24 ;M ZCOPY=ZCCR
     25 S ZCOPY(1)=""
     26 N ZI S ZI=0
     27 F  S ZI=$O(ZCCR(ZI)) Q:ZI=""  D  ; FOR EACH LINE
     28 . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
     29 ;D ENCODE("ZCOPY",1,ZCOPY(1))
     30 S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
     31 D CHUNK("G2","G",45)
     32 Q
     33ENCODE(ZRTN,ZARY) ;
     34 ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
     35 ; ZARY IS PASSED BY NAME
     36 ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
     37 ;
     38 S ZCOPY(1)=""
     39 N ZI S ZI=0
     40 F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE
     41 . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
     42 N G
     43 S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
     44 D CHUNK(ZRTN,"G",45)
     45 Q
     46 ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
     47ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line
     48 ; Call with LRSTR by reference, Remainder returned in LRSTR
     49 ; IARY IS PASSED BY NAME
     50 S LRQUIT=0,LRLEN=$L(LRSTR)
     51 F  D  Q:LRQUIT
     52 . I $L(LRSTR)<45 S LRQUIT=1 Q
     53 . S LRX=$E(LRSTR,1,45)
     54 . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
     55 . S LRSTR=$E(LRSTR,46,LRLEN)
     56 Q
     57 ;
     58TESTMAIL ;
     59 ; TEST OF MAILSEND
     60 ;S ZTO("glilly@glilly.net")=""
     61 S ZTO("mish@nhin.openforum.opensourcevista.net")=""
     62 ;S ZTO("martijn@djigzo.com")=""
     63 ;S ZTO("profmish@gmail.com")=""
     64 ;S ZTO("nanthracite@earthlink.net")=""
     65 S ZFROM="ANTHRACITE.NANCY"
     66 S ZATTACH=$NA(^GPL("CCR"))
     67 I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
     68 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
     69 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
     70 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
     71 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
     72 ZWR GR
     73 Q
     74 ;
     75TESTMAIL2 ;
     76 ; TEST OF MAILSEND TO gpl.mdc-crew.net
     77 N C0CGM
     78 S C0CGM(1)="This is a test message."
     79 S C0CGM(2)="A Continuity of Care record is attached"
     80 S C0CGM(3)="It contains no Protected Health Information (PHI)"
     81 S C0CGM(4)="It is purely test data used for software development"
     82 S C0CGM(5)="It does not represent information about any person living or dead"
     83 ;S ZTO("glilly@glilly.net")=""
     84 ;S ZTO("george.lilly@pobox.com")=""
     85 ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
     86 ;S ZTO("mish@nhin.openforum.opensourcevista.net")=""
     87 S ZTO("brooks.richard@securemail.opensourcevista.net")=""
     88 ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
     89 ;S ZTO("ncoal@live.com")=""
     90 ;S ZTO("martijn@djigzo.com")=""
     91 ;S ZTO("profmish@gmail.com")=""
     92 ;S ZTO("nanthracite@earthlink.net")=""
     93 S ZTO("gpl.doctortest@gmail.com")=""
     94 S ZFROM="LILLY.GEORGE"
     95 S ZATTACH=$NA(^GPL("CCR"))
     96 I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
     97 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
     98 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
     99 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
     100 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
     101 ZWR GR
     102 Q
     103 ;
     104LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to
     105 ; the email address in C0CTO
     106 ; the directory and the "from" are all hard coded
     107 ;
     108 N ZZFROM S ZZFROM="LILLY.GEORGE"
     109 N GN S GN=$NA(^TMP("C0CMIME2",$J))
     110 N GN1 S GN1=$NA(@GN@(1))
     111 K @GN
     112 I '$D(C0CFILE) Q  ; NO FILENAME PASSED
     113 I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
     114 S ZZTO(C0CTO)=""
     115 N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
     116 N GD S GD="/home/wvehr3-09/EHR/" ; directory
     117 I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q  D  ;
     118 . W !,"error reading file",C0CFILE
     119 D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
     120 K @GN ; CLEAN UP
     121 ;ZWR ZRTN
     122 W !,$G(ZRTN(1))
     123 Q
     124 ;
     125MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE
     126 ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
     127 ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
     128 ;  IF NULL, WILL SEND FROM THE CURRENT DUZ
     129 ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
     130 ;  @TO@("addr1@domain1.net")
     131 ;  @CC@("addr2@domain2.com")  both can be multiples
     132 ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
     133 ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
     134 ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
     135 ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
     136 ;
     137 I '$D(FNAME) S FNAME="ccr.xml" ; default filename
     138 N GN
     139 S GN=$NA(^TMP($J,"C0CMIME"))
     140 K @GN
     141 S GM(1)="MIME-Version: 1.0"
     142 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
     143 S GM(3)=""
     144 S GM(4)=""
     145 ;S GM(5)="--123456788888"
     146 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
     147 S GM(5)="--123456899999"
     148 S GM(6)="Content-Type: text/xml; name="_FNAME
     149 S GM(7)="Content-Transfer-Encoding: base64"
     150 S GM(8)="Content-Disposition: attachment; filename="_FNAME
     151 S GM(9)=""
     152 S GM(10)="" ; FOR THE END
     153 ;S GM(11)="--123456788888--"
     154 S GM(11)="--123456899999--"
     155 S GM(12)=""
     156 S GM(13)=""
     157 S GG(1)="--123456899999"
     158 S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
     159 S GG(3)="Content-Transfer-Encoding: 7bit"
     160 S GG(4)=""
     161 S GG(5)="This is a test message."
     162 S GG(6)="A Continuity of Care record is attached"
     163 S GG(7)="It contains no Protected Health Information (PHI)"
     164 S GG(8)="It is purely test data used for software development"
     165 S GG(9)="It does not represent information about any person living or dead"
     166 S GG(10)=""
     167 S GG(11)="--123456899999--"
     168 ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
     169 S GG(12)=""
     170 ;S GG(13)="This is a test message."
     171 S GG(14)="A Continuity of Care record is attached"
     172 S GG(15)="It contains no Protected Health Information (PHI)"
     173 S GG(16)="It is purely test data used for software development"
     174 S GG(17)="It does not represent information about any person living or dead"
     175 S GG(18)=""
     176 S GG(19)="--123456899999"
     177 S GG(20)="--987654321--"
     178 K GBLD
     179 ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
     180 ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
     181 I $D(MESSAGE)'="" D  ; THERE IS A MESSAGE
     182 . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
     183 . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
     184 . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
     185 D QUEUE^C0CXPATH("GBLD","GM",5,9)
     186 I $D(ATTACH)'="" D  ; IF WE HAVE AN ATTACHMENT
     187 . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
     188 . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
     189 D QUEUE^C0CXPATH("GBLD","GM",11,12)
     190 D BUILD^C0CXPATH("GBLD",GN)
     191 ;S GGG=$NA(^GPL("MIME2"))
     192 K @GN@(0) ; KILL THE LINE COUNT
     193 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     194 M LRTO=@TO
     195 I $D(CC) M LRTO=@CC
     196 S LRINSTR("ADDR FLAGS")="R"
     197 S LRINSTR("FROM")=$G(FROM)
     198 S LRMSUBJ=$G(SUBJECT)
     199 S LRMSUBJ=$E(LRMSUBJ,1,65)
     200 D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
     201 I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q  ;
     202 S RTN(1)="OK"
     203 Q
     204 ;
     205MAILSEND0(LRMSUBJ) ; Send extract back to requestor.
     206 ;
     207 ;D TEST
     208 S GN=$NA(^TMP($J,"C0CMIME"))
     209 K @GN
     210 ;M @GN=G2
     211 S GM(1)="MIME-Version: 1.0"
     212 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
     213 S GM(3)=""
     214 S GM(4)=""
     215 S GM(5)="--1234567"
     216 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
     217 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
     218 S GM(7)="Content-Transfer-Encoding: base64"
     219 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
     220 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
     221 S GM(9)=""
     222 S GM(10)="" ; FOR THE END
     223 S GM(11)="--frontier--"
     224 S GM(12)="."
     225 S GM(13)=""
     226 K GBLD
     227 ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
     228 ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
     229 ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
     230 ;D BUILD^C0CXPATH("GBLD",GN)
     231 S GGG=$NA(^GPL("MIME2"))
     232 ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
     233 D QUEUE^C0CXPATH("GBLD",GGG,21,159)
     234 D BUILD^C0CXPATH("GBLD",GN)
     235 K @GN@(0) ; KILL THE LINE COUNT
     236 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     237 S XQSND="glilly@glilly.net"
     238 ;S XQSND="nanthracite@earthlink.net"
     239 ;S XQSND="dlefevre@orohosp.com"
     240 ;S XQSND="gregwoodhouse@me.com"
     241 ;S XQSND="rick.marshall@vistaexpertise.net"
     242 S LRTO(XQSND)=""
     243 S LRINSTR("ADDR FLAGS")="R"
     244 S LRINSTR("FROM")="CCR_PACKAGE"
     245 S LRMSUBJ="A SAMPLE CCR"
     246 S LRMSUBJ=$E(LRMSUBJ,1,65)
     247 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
     248 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
     249 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
     250 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
     251 Q
     252 ;
     253MAILSEND2(UDFN,ADDR) ; Send extract back to requestor.
     254 ;
     255 I +$G(UDFN)=0 S UDFN=2 ;
     256 D TEST(UDFN)
     257 S GN=$NA(^TMP($J,"C0CMIME"))
     258 K @GN
     259 ;M @GN=G2
     260 S GM(1)="MIME-Version: 1.0"
     261 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
     262 S GM(3)=""
     263 S GM(4)=""
     264 S GM(5)="--1234567"
     265 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
     266 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
     267 S GM(7)="Content-Transfer-Encoding: base64"
     268 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
     269 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
     270 S GM(9)=""
     271 S GM(10)="" ; FOR THE END
     272 S GM(11)="--1234567--"
     273 S GM(12)=""
     274 S GM(13)=""
     275 K GBLD
     276 D QUEUE^C0CXPATH("GBLD","GM",5,9)
     277 D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
     278 D QUEUE^C0CXPATH("GBLD","GM",10,12)
     279 D BUILD^C0CXPATH("GBLD",GN)
     280 S GGG=$NA(^GPL("MIME2"))
     281 ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
     282 ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
     283 ;D BUILD^C0CXPATH("GBLD",GN)
     284 K @GN@(0) ; KILL THE LINE COUNT
     285 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     286 I $G(ADDR)'="" S XQSND=ADDR
     287 E  S XQSND="glilly@glilly.net"
     288 ;S XQSND="nanthracite@earthlink.net"
     289 ;S XQSND="dlefevre@orohosp.com"
     290 ;S XQSND="gregwoodhouse@me.com"
     291 ;S XQSND="rick.marshall@vistaexpertise.net"
     292 S LRTO(XQSND)=""
     293 ;S LRTO("glilly@glilly.net")=""
     294 S LRINSTR("ADDR FLAGS")="R"
     295 S LRINSTR("FROM")="ANTHRACITE.NANCY"
     296 S LRMSUBJ="Sending a CCR with Mailman"
     297 S LRMSUBJ=$E(LRMSUBJ,1,65)
     298 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
     299 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
     300 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
     301 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
     302 Q
     303 ;
     304SIMPLE ;
     305 S GN(1)="SIMPLE TEST MESSAGE"
     306 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     307 S XQSND="glilly@glilly.net"
     308 S LRTO(XQSND)=""
     309 S LRINSTR("ADDR FLAGS")="R"
     310 S LRINSTR("FROM")="CCR_PACKAGE"
     311 S LRMSUBJ="A SAMPLE CCR"
     312 S LRMSUBJ=$E(LRMSUBJ,1,65)
     313 D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
     314 Q
     315CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
     316 ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
     317 ; OUTXML IS ALSO PASSED BY NAME
     318 ; IF ZSIZE IS NOT PASSED, 1000 IS USED
     319 I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
     320 N ZB,ZI,ZJ,ZK,ZL,ZN
     321 S ZB=ZSIZE-1
     322 S ZN=1
     323 S ZI=0 ; BEGINNING OF INDEX TO INXML
     324 F  S ZI=$O(@INXML@(ZI)) Q:+ZI=0  D  ; FOR EACH STRING IN INXML
     325 . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
     326 . F ZJ=1:ZSIZE:ZL D  ;
     327 . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
     328 . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
     329 . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
     330 Q
     331 ;
     332CLEAN(IARY) ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
     333 ;
     334 N ZI S ZI=0
     335 F  S ZI=$O(@IARY@(ZI)) Q:+ZI=0  D  ;
     336 . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
     337 . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
     338 Q
     339 ;

  • ccr/branches/ohum/p/C0CMXML.m

    r1330 r1332  
    11C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
     2        ;;0.1;C0C;nopatch;noreleasedate;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CMXMLB.m

    r1330 r1332  
    1 MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55
    2         ;;8.0;KERNEL;;;Build 1
    3         QUIT
    4         ;
    5         ;DOC - The top level tag
    6         ;DOCTYPE - Want to include a DOCTYPE node
    7         ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
    8 START(DOC,DOCTYPE,FLAG,NO1ST)   ;Call this once at the begining.
    9         K ^TMP("MXMLBLD",$J)
    10         S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
    11         I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
    12         I $G(NO1ST)'=1 D OUTPUT($$XMLHDR)
    13         D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
    14         Q
    15         ;
    16 END     ;Call this once to close out the document
    17         D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">")
    18         I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J)
    19         K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK")
    20         Q
    21         ;
    22 ITEM(INDENT,TAG,ATT,VALUE)      ;Output a Item
    23         N I,X
    24         S ATT=$G(ATT)
    25         I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q
    26         D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">")
    27         Q
    28         ;DOITEM is a callback to output the lower level.
    29 MULTI(INDENT,TAG,ATT,DOITEM)    ;Output a Multipule
    30         N I,X,S
    31         S ATT=$G(ATT)
    32         D PUSH($G(INDENT),TAG,.ATT)
    33         D @DOITEM
    34         D POP
    35         Q
    36         ;
    37 ATT(ATT)        ;Output a string of attributes
    38         I $D(ATT)<9 Q ""
    39         N I,S,V
    40         S S="",I=""
    41         F  S I=$O(ATT(I)) Q:I=""  S S=S_" "_I_"="_$$Q(ATT(I))
    42         Q S
    43         ;
    44 Q(X)    ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
    45         ;I X'[$C(34) Q $C(34)_X_$C(34)
    46         I X'[$C(39) Q $C(39)_X_$C(39)
    47         ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
    48         N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
    49         F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
    50         S Y=Y_$P(X,Q,$L(X,Q))
    51         ;Q $C(34)_Y_$C(34)
    52         Q $C(39)_Y_$C(39)
    53         ;
    54 XMLHDR()        ; -- provides current XML standard header
    55         Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"
    56         ;
    57 OUTPUT(S)       ;Output
    58         N C S C=$G(^TMP("MXMLBLD",$J,"CNT"))
    59         I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q
    60         W S,!
    61         Q
    62         ;
    63 CHARCHK(STR)    ; -- replace xml character limits with entities
    64         N A,I,X,Y,Z,NEWSTR
    65         S (Y,Z)=""
    66         ;IF STR["&" SET NEWSTR=STR DO  SET STR=Y_Z
    67         ;. FOR X=1:1  SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
    68         I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&amp;"_$P(STR,"&",I+1,999)
    69         I STR["<" F  S STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
    70         I STR[">" F  S STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
    71         I STR["'" F  S STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
    72         I STR["""" F  S STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) Q:STR'[""""
    73         ;
    74         S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
    75         QUIT STR
    76         ;
    77 COMMENT(VAL)    ;Add Comments
    78         N I,L
    79         ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q
    80         I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q  ;CHANGED BY GPL FOR GTM
    81         S I="",L="<!--"
    82         F  S I=$O(ATT(I)) Q:I=""  D OUTPUT(L_ATT(I)) S L=""
    83         D OUTPUT("-->")
    84         Q
    85         ;
    86 PUSH(INDENT,TAG,ATT)    ;Write a TAG and save.
    87         N CNT
    88         S ATT=$G(ATT)
    89         D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">")
    90         S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG
    91         Q
    92         ;
    93 POP     ;Write last pushed tag and pop
    94         N CNT,TAG,INDENT,X
    95         S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1
    96         S INDENT=+X,TAG=$P(X,"^",2)
    97         D OUTPUT($$BLS(INDENT)_"</"_TAG_">")
    98         Q
    99         ;
    100 BLS(I)  ;Return INDENT string
    101         N S
    102         S S="",I=$G(I) S:I>0 $P(S," ",I)=" "
    103         Q S
    104         ;
    105 INDENT()        ;Renturn indent level
    106         Q +$G(^TMP("MXMLBLD",$J,"STK"))
     1MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55
     2 ;;8.0;KERNEL;;
     3 QUIT
     4 ;
     5 ;DOC - The top level tag
     6 ;DOCTYPE - Want to include a DOCTYPE node
     7 ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
     8START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining.
     9 K ^TMP("MXMLBLD",$J)
     10 S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
     11 I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
     12 I $G(NO1ST)'=1 D OUTPUT($$XMLHDR)
     13 D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
     14 Q
     15 ;
     16END ;Call this once to close out the document
     17 D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">")
     18 I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J)
     19 K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK")
     20 Q
     21 ;
     22ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item
     23 N I,X
     24 S ATT=$G(ATT)
     25 I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q
     26 D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">")
     27 Q
     28 ;DOITEM is a callback to output the lower level.
     29MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule
     30 N I,X,S
     31 S ATT=$G(ATT)
     32 D PUSH($G(INDENT),TAG,.ATT)
     33 D @DOITEM
     34 D POP
     35 Q
     36 ;
     37ATT(ATT) ;Output a string of attributes
     38 I $D(ATT)<9 Q ""
     39 N I,S,V
     40 S S="",I=""
     41 F  S I=$O(ATT(I)) Q:I=""  S S=S_" "_I_"="_$$Q(ATT(I))
     42 Q S
     43 ;
     44Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
     45 ;I X'[$C(34) Q $C(34)_X_$C(34)
     46 I X'[$C(39) Q $C(39)_X_$C(39)
     47 ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
     48 N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
     49 F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
     50 S Y=Y_$P(X,Q,$L(X,Q))
     51 ;Q $C(34)_Y_$C(34)
     52 Q $C(39)_Y_$C(39)
     53 ;
     54XMLHDR() ; -- provides current XML standard header
     55 Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"
     56 ;
     57OUTPUT(S) ;Output
     58 N C S C=$G(^TMP("MXMLBLD",$J,"CNT"))
     59 I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q
     60 W S,!
     61 Q
     62 ;
     63CHARCHK(STR) ; -- replace xml character limits with entities
     64 N A,I,X,Y,Z,NEWSTR
     65 S (Y,Z)=""
     66 ;IF STR["&" SET NEWSTR=STR DO  SET STR=Y_Z
     67 ;. FOR X=1:1  SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
     68 I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&amp;"_$P(STR,"&",I+1,999)
     69 I STR["<" F  S STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
     70 I STR[">" F  S STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
     71 I STR["'" F  S STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
     72 I STR["""" F  S STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) Q:STR'[""""
     73 ;
     74 S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
     75 QUIT STR
     76 ;
     77COMMENT(VAL) ;Add Comments
     78 N I,L
     79 ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q
     80 I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q  ;CHANGED BY GPL FOR GTM
     81 S I="",L="<!--"
     82 F  S I=$O(ATT(I)) Q:I=""  D OUTPUT(L_ATT(I)) S L=""
     83 D OUTPUT("-->")
     84 Q
     85 ;
     86PUSH(INDENT,TAG,ATT) ;Write a TAG and save.
     87 N CNT
     88 S ATT=$G(ATT)
     89 D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">")
     90 S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG
     91 Q
     92 ;
     93POP ;Write last pushed tag and pop
     94 N CNT,TAG,INDENT,X
     95 S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1
     96 S INDENT=+X,TAG=$P(X,"^",2)
     97 D OUTPUT($$BLS(INDENT)_"</"_TAG_">")
     98 Q
     99 ;
     100BLS(I) ;Return INDENT string
     101 N S
     102 S S="",I=$G(I) S:I>0 $P(S," ",I)=" "
     103 Q S
     104 ;
     105INDENT() ;Renturn indent level
     106 Q +$G(^TMP("MXMLBLD",$J,"STK"))

  • ccr/branches/ohum/p/C0CMXP.m

    r1330 r1332  
    11C0CMXP    ; GPL - MXML based XPath utilities;12/04/09  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
     2        ;;0.1;C0C;nopatch;noreleasedate;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CNHIN.m

    r1330 r1332  
    11C0CNHIN   ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21 EN(ZRTN,ZDFN,ZPART,KEEP)        ; GENERATE AN NHIN ARRAY FOR A PATIENT
    22         ;
    23         K GARY,GNARY,GIDX,C0CDOCID
    24         N GN
    25         K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL
    26         K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM
    27         K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS
    28         D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML
    29         S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL
    30         S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
    31         D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS
    32         I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
    33         ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP))
    34         Q
    35         ;
    36 PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
    37         ;
    38         N ZG
    39         S ZG=$NA(^TMP("PQRIXML",$J))
    40         K @ZG
    41         D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML
    42         N C0CDOCID
    43         S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML
    44         D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
    45         I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
    46         Q
    47         ;
    48 PQRI2(ZRTN)     ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE
    49         ;
    50         ;N GG
    51         D GETXML^C0CMXP("GG","PQRI ONE MEASURE")
    52         D PROCESS(ZRTN,"GG","root",1)
    53         Q
    54         ;
    55 PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP)        ; PARSE AND RUN DOMO ON XML
    56         ; ZRTN IS PASSED BY REFERENCE
    57         ; ZXML IS PASSED BY NAME
    58         ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
    59         ;
    60         N GN
    61         S GN=$NA(^TMP("C0CPROCESS",$J))
    62         K @GN
    63         M @GN=@ZXML
    64         S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
    65         K @GN
    66         D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
    67         I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
    68         Q
    69         ;
    70 LOADSMRT        ;
    71         ;
    72         K ^GPL("SMART")
    73         S GN=$NA(^GPL("SMART",1))
    74         I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED"
    75         Q
    76         ;
    77 SMART   ; TRY IT WITH SMART
    78         ;
    79         S GN=$NA(^GPL("SMART"))
    80         ;K ^TMP("MXMLDOM",$J)
    81         K ^TMP("MXMLERR",$J)
    82         S C0CDOCID=$$PARSE(GN,"SMART")
    83         D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/")
    84         ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    85         Q
    86         ;
    87 CCR     ; TRY IT WITH A CCR
    88         ;
    89         S GN=$NA(^GPL("CCR"))
    90         ;K ^TMP("MXMLDOM",$J)
    91         K ^TMP("MXMLERR",$J)
    92         S C0CDOCID=$$PARSE(GN,"CCR")
    93         D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/")
    94         ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    95         Q
    96         ;
    97 MED     ; TRY IT WITH A CCR MED SECTION
    98         ;
    99         S GN=$NA(^GPL("MED"))
    100         K ^TMP("MXMLDOM",$J)
    101         K ^TMP("MXMLERR",$J)
    102         S C0CDOCID=$$PARSE(GN,"MED")
    103         D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/")
    104         ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    105         Q
    106         ;
    107 CCD     ; TRY IT WITH A CCD
    108         ;
    109         S GN=$NA(^GPL("CCD"))
    110         ;K ^TMP("MXMLDOM",$J)
    111         K ^TMP("MXMLERR",$J)
    112         S C0CDOCID=$$PARSE(GN,"CCD")
    113         D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/")
    114         ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    115         Q
    116         ;
    117 TEST1   ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
    118         ; PARSED WITH MXML
    119         ; RUN THROUGH XPATH
    120         K GARY,GIDX,C0CDOCID
    121         S GN=$NA(^GPL("NHIN"))
    122         ;S GN=$NA(^GPL("DOMI"))
    123         S C0CDOCID=$$PARSE(GN,"GPLTEST")
    124         D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
    125         K ^GPL("GNARY")
    126         M ^GPL("GNARY")=GNARY
    127         Q
    128         ;
    129 TEST2   ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI")
    130         ;
    131         S GN=$NA(^GPL("GNARY"))
    132         S C0CDOCID=$$DOMI^C0CDOM(GN,,"results")
    133         D OUTXML^C0CDOM("G",C0CDOCID)
    134         K ^GPL("DOMI")
    135         M ^GPL("DOMI")=G
    136         Q
    137         ;
    138 TEST3   ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
    139         ; PARSED WITH MXML
    140         ; RUN THROUGH XPATH
    141         K GARY,GIDX,C0CDOCID
    142         ;S GN=$NA(^GPL("NHIN"))
    143         S GN=$NA(^GPL("DOMI"))
    144         S C0CDOCID=$$PARSE(GN,"GPLTEST")
    145         D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
    146         Q
    147         ;
     2 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     3 ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT
     22 ;
     23 K GARY,GNARY,GIDX,C0CDOCID
     24 N GN
     25 K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL
     26 K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM
     27 K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS
     28 D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML
     29 S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL
     30 S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
     31 D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS
     32 I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
     33 ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP))
     34 Q
     35 ;
     36PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
     37 ;
     38 N ZG
     39 S ZG=$NA(^TMP("PQRIXML",$J))
     40 K @ZG
     41 D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML
     42 N C0CDOCID
     43 S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML
     44 D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
     45 I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
     46 Q
     47 ;
     48PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE
     49 ;
     50 ;N GG
     51 D GETXML^C0CMXP("GG","PQRI ONE MEASURE")
     52 D PROCESS(ZRTN,"GG","root",1)
     53 Q
     54 ;
     55PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML
     56 ; ZRTN IS PASSED BY REFERENCE
     57 ; ZXML IS PASSED BY NAME
     58 ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
     59 ;
     60 N GN
     61 S GN=$NA(^TMP("C0CPROCESS",$J))
     62 K @GN
     63 M @GN=@ZXML
     64 S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
     65 K @GN
     66 D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
     67 I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
     68 Q
     69 ;
     70LOADSMRT ;
     71 ;
     72 K ^GPL("SMART")
     73 S GN=$NA(^GPL("SMART",1))
     74 I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED"
     75 Q
     76 ;
     77SMART ; TRY IT WITH SMART
     78 ;
     79 S GN=$NA(^GPL("SMART"))
     80 ;K ^TMP("MXMLDOM",$J)
     81 K ^TMP("MXMLERR",$J)
     82 S C0CDOCID=$$PARSE(GN,"SMART")
     83 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/")
     84 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     85 Q
     86 ;
     87CCR ; TRY IT WITH A CCR
     88 ;
     89 S GN=$NA(^GPL("CCR"))
     90 ;K ^TMP("MXMLDOM",$J)
     91 K ^TMP("MXMLERR",$J)
     92 S C0CDOCID=$$PARSE(GN,"CCR")
     93 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/")
     94 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     95 Q
     96 ;
     97MED ; TRY IT WITH A CCR MED SECTION
     98 ;
     99 S GN=$NA(^GPL("MED"))
     100 K ^TMP("MXMLDOM",$J)
     101 K ^TMP("MXMLERR",$J)
     102 S C0CDOCID=$$PARSE(GN,"MED")
     103 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/")
     104 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     105 Q
     106 ;
     107CCD ; TRY IT WITH A CCD
     108 ;
     109 S GN=$NA(^GPL("CCD"))
     110 ;K ^TMP("MXMLDOM",$J)
     111 K ^TMP("MXMLERR",$J)
     112 S C0CDOCID=$$PARSE(GN,"CCD")
     113 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/")
     114 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     115 Q
     116 ;
     117TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
     118 ; PARSED WITH MXML
     119 ; RUN THROUGH XPATH
     120 K GARY,GIDX,C0CDOCID
     121 S GN=$NA(^GPL("NHIN"))
     122 ;S GN=$NA(^GPL("DOMI"))
     123 S C0CDOCID=$$PARSE(GN,"GPLTEST")
     124 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
     125 K ^GPL("GNARY")
     126 M ^GPL("GNARY")=GNARY
     127 Q
     128 ;
     129TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI")
     130 ;
     131 S GN=$NA(^GPL("GNARY"))
     132 S C0CDOCID=$$DOMI^C0CDOM(GN,,"results")
     133 D OUTXML^C0CDOM("G",C0CDOCID)
     134 K ^GPL("DOMI")
     135 M ^GPL("DOMI")=G
     136 Q
     137 ;
     138TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
     139 ; PARSED WITH MXML
     140 ; RUN THROUGH XPATH
     141 K GARY,GIDX,C0CDOCID
     142 ;S GN=$NA(^GPL("NHIN"))
     143 S GN=$NA(^GPL("DOMI"))
     144 S C0CDOCID=$$PARSE(GN,"GPLTEST")
     145 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
     146 Q
     147 ;
    148148DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
    149         ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    150         ; THE XPATH ARRAY XPARY, PASSED BY NAME
    151         ; ZOID IS THE STARTING OID
    152         ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    153         ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    154         ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    155         I $G(ZREDUX)="" S ZREDUX=""
    156         N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
    157         N NEWNUM S NEWNUM=""
    158         I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    159         S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    160         I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    161         . N GT S GT=$P(NEWPATH,ZREDUX,2)
    162         . I GT'="" S NEWPATH=GT
    163         S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    164         N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
    165         I $D(GA) D  ; PROCESS THE ATTRIBUTES
    166         . N ZI S ZI=""
    167         . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
    168         . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE
    169         . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
    170         . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
    171         N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    172         I $D(GD(2)) D  ;
    173         . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    174         E  I $D(GD(1)) D  ;
    175         . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    176         . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
    177         N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    178         I ZFRST'=0 D  ; THERE IS A CHILD
    179         . N ZNUM
    180         . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    181         . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
    182         N GNXT S GNXT=$$NXTSIB(ZOID)
    183         I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
    184         I GNXT'=0 D  ;
    185         . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
    186         . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
    187         . . N ZNUM S ZNUM=1 ;
    188         . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
    189         . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
    190         Q
    191         ;
    192 ADDNARY(ZXP,ZVALUE)     ; ADD AN NHIN ARRAY VALUE TO ZNARY
    193         ;
    194         N ZZI,ZZJ,ZZN
    195         S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
    196         I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
    197         S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
    198         S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
    199         I ZZI'["]" D  ; A SINGLETON
    200         . S ZZN=1
    201         E  D  ; THERE IS AN [x] OCCURANCE
    202         . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
    203         . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
    204         I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
    205         Q
    206         ;
     149 ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     150 ; THE XPATH ARRAY XPARY, PASSED BY NAME
     151 ; ZOID IS THE STARTING OID
     152 ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     153 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     154 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     155 I $G(ZREDUX)="" S ZREDUX=""
     156 N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
     157 N NEWNUM S NEWNUM=""
     158 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     159 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     160 I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     161 . N GT S GT=$P(NEWPATH,ZREDUX,2)
     162 . I GT'="" S NEWPATH=GT
     163 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     164 N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
     165 I $D(GA) D  ; PROCESS THE ATTRIBUTES
     166 . N ZI S ZI=""
     167 . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
     168 . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE
     169 . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
     170 . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
     171 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     172 I $D(GD(2)) D  ;
     173 . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     174 E  I $D(GD(1)) D  ;
     175 . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     176 . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
     177 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     178 I ZFRST'=0 D  ; THERE IS A CHILD
     179 . N ZNUM
     180 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     181 . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
     182 N GNXT S GNXT=$$NXTSIB(ZOID)
     183 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
     184 I GNXT'=0 D  ;
     185 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
     186 . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
     187 . . N ZNUM S ZNUM=1 ;
     188 . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
     189 . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
     190 Q
     191 ;
     192ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY
     193 ;
     194 N ZZI,ZZJ,ZZN
     195 S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
     196 I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
     197 S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
     198 S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
     199 I ZZI'["]" D  ; A SINGLETON
     200 . S ZZN=1
     201 E  D  ; THERE IS AN [x] OCCURANCE
     202 . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
     203 . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
     204 I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
     205 Q
     206 ;
    207207PARSE(INXML,INDOC)      ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
    208         ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
    209         ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
    210         ;Q $$EN^MXMLDOM(INXML)
    211         Q $$EN^MXMLDOM(INXML,"W")
    212         ;
     208 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
     209 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
     210 ;Q $$EN^MXMLDOM(INXML)
     211 Q $$EN^MXMLDOM(INXML,"W")
     212 ;
    213213ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    214         N ZN
    215         ;I $$TAG(ZOID)["entry" B
    216         S ZN=$$NXTSIB(ZOID)
    217         I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    218         Q 0
    219         ;
     214 N ZN
     215 ;I $$TAG(ZOID)["entry" B
     216 S ZN=$$NXTSIB(ZOID)
     217 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     218 Q 0
     219 ;
    220220FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    221         Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
    222         ;
     221 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
     222 ;
    223223PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
    224         Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
    225         ;
     224 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
     225 ;
    226226ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
    227         S HANDLE=C0CDOCID
    228         K @RTN
    229         D GETTXT^MXMLDOM("A")
    230         Q
    231         ;
     227 S HANDLE=C0CDOCID
     228 K @RTN
     229 D GETTXT^MXMLDOM("A")
     230 Q
     231 ;
    232232TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
    233         ;I ZOID=149 B ;GPLTEST
    234         N X,Y
    235         S Y=""
    236         S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    237         I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    238         I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
    239         Q Y
    240         ;
     233 ;I ZOID=149 B ;GPLTEST
     234 N X,Y
     235 S Y=""
     236 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     237 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     238 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
     239 Q Y
     240 ;
    241241NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
    242         Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
    243         ;
     242 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
     243 ;
    244244DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
    245         ;N ZT,ZN S ZT=""
    246         ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    247         ;Q $G(@C0CDOM@(ZOID,"T",1))
    248         S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
    249         Q
    250         ;
     245 ;N ZT,ZN S ZT=""
     246 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     247 ;Q $G(@C0CDOM@(ZOID,"T",1))
     248 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
     249 Q
     250 ;
    251251OUTXML(ZRTN,INID)       ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
    252         ;
    253         S C0CDOCID=INID
    254         D START^C0CMXMLB($$TAG(1),,"G")
    255         D NDOUT($$FIRST(1))
    256         D END^C0CMXMLB ;END THE DOCUMENT
    257         M @ZRTN=^TMP("MXMLBLD",$J)
    258         K ^TMP("MXMLBLD",$J)
    259         Q
    260         ;
     252 ;
     253 S C0CDOCID=INID
     254 D START^C0CMXMLB($$TAG(1),,"G")
     255 D NDOUT($$FIRST(1))
     256 D END^C0CMXMLB ;END THE DOCUMENT
     257 M @ZRTN=^TMP("MXMLBLD",$J)
     258 K ^TMP("MXMLBLD",$J)
     259 Q
     260 ;
    261261NDOUT(ZOID)     ;CALLBACK ROUTINE - IT IS RECURSIVE
    262         N ZI S ZI=$$FIRST(ZOID)
    263         I ZI'=0 D  ; THERE IS A CHILD
    264         . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
    265         . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
    266         E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
    267         . ;W "DOING",ZOID,!
    268         . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
    269         . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
    270         . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
    271         I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
    272         . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
    273         Q
    274         ;
    275 WNHIN(ZDFN)     ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
    276         ;
    277         N GN,GN2
    278         D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
    279         S GN2=$NA(@GN@(1))
    280         W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
    281         Q
    282         ;
    283 TESTNARY        ; TEST MAKING A NHIN ARRAY
    284         N ZI S ZI=""
    285         N ZH ; DOM HANDLE
    286         D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM
    287         S ZH=C0CDOCID ; SET THE HANDLE
    288         N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH))
    289         F  S ZI=$O(@ZD@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
    290         . N ZATT
    291         . D MNARY(.ZATT,ZH,ZI)
    292         . N ZPRE,ZN
    293         . S ZPRE=$$PRE(ZI)
    294         . S ZN=$P(ZPRE,",",2)
    295         . S ZPRE=$P(ZPRE,",",1)
    296         . ;I $D(ZATT) ZWR ZATT
    297         . N ZJ S ZJ=""
    298         . F  S ZJ=$O(ZATT(ZJ)) Q:ZJ=""  D  ; FOR EACH ATTRIBUTE
    299         . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),!
    300         . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ)
    301         Q
    302         ;
    303 PRE(ZNODE)      ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE
    304         ;
    305         N GI,GI2,GPT,GJ,GN
    306         S GI=$$PARENT(ZNODE) ; PARENT NODE
    307         I GI=0 Q ""  ; NO PARENT
    308         S GPT=$$TAG(GI) ; TAG OF PARENT
    309         S GI2=$$PARENT(GI) ; PARENT OF PARENT
    310         I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT
    311         S GJ=$$FIRST(GI) ; NODE OF FIRST SIB
    312         I GJ=ZNODE Q:$$TAG(GI)_",1"
    313         F GN=2:1 Q:GJ=ZNODE  D  ;
    314         . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING
    315         Q GPT_","_GN
    316         ;
    317 MNARY(ZRTN,ZHANDLE,ZOID)        ; MAKE A NHIN ARRAY FROM A DOM NODE
    318         ; RETURNED IN ZRTN, PASSED BY REFERENCE
    319         ; ZHANDLE IS THE DOM DOCUMENT ID
    320         ; ZOID IS THE DOM NODE
    321         D ATT("ZRTN",ZOID)
    322         Q
    323         ;
     262 N ZI S ZI=$$FIRST(ZOID)
     263 I ZI'=0 D  ; THERE IS A CHILD
     264 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
     265 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
     266 E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
     267 . ;W "DOING",ZOID,!
     268 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
     269 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
     270 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
     271 I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
     272 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
     273 Q
     274 ;
     275WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
     276 ;
     277 N GN,GN2
     278 D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
     279 S GN2=$NA(@GN@(1))
     280 W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
     281 Q
     282 ;
     283TESTNARY ; TEST MAKING A NHIN ARRAY
     284 N ZI S ZI=""
     285 N ZH ; DOM HANDLE
     286 D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM
     287 S ZH=C0CDOCID ; SET THE HANDLE
     288 N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH))
     289 F  S ZI=$O(@ZD@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
     290 . N ZATT
     291 . D MNARY(.ZATT,ZH,ZI)
     292 . N ZPRE,ZN
     293 . S ZPRE=$$PRE(ZI)
     294 . S ZN=$P(ZPRE,",",2)
     295 . S ZPRE=$P(ZPRE,",",1)
     296 . ;I $D(ZATT) ZWR ZATT
     297 . N ZJ S ZJ=""
     298 . F  S ZJ=$O(ZATT(ZJ)) Q:ZJ=""  D  ; FOR EACH ATTRIBUTE
     299 . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),!
     300 . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ)
     301 Q
     302 ;
     303PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE
     304 ;
     305 N GI,GI2,GPT,GJ,GN
     306 S GI=$$PARENT(ZNODE) ; PARENT NODE
     307 I GI=0 Q ""  ; NO PARENT
     308 S GPT=$$TAG(GI) ; TAG OF PARENT
     309 S GI2=$$PARENT(GI) ; PARENT OF PARENT
     310 I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT
     311 S GJ=$$FIRST(GI) ; NODE OF FIRST SIB
     312 I GJ=ZNODE Q:$$TAG(GI)_",1"
     313 F GN=2:1 Q:GJ=ZNODE  D  ;
     314 . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING
     315 Q GPT_","_GN
     316 ;
     317MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE
     318 ; RETURNED IN ZRTN, PASSED BY REFERENCE
     319 ; ZHANDLE IS THE DOM DOCUMENT ID
     320 ; ZOID IS THE DOM NODE
     321 D ATT("ZRTN",ZOID)
     322 Q
     323 ;

  • ccr/branches/ohum/p/C0CNMED2.m

    r1330 r1332  
    11C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
    4         ; Licensed under the terms of the GNU General Public License.
    5         ; See attached copy of the License.
    6         ;
    7         ; This program is free software; you can redistribute it and/or modify
    8         ; it under the terms of the GNU General Public License as published by
    9         ; the Free Software Foundation; either version 2 of the License, or
    10         ; (at your option) any later version.
    11         ;
    12         ; This program is distributed in the hope that it will be useful,
    13         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    14         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15         ; GNU General Public License for more details.
    16         ;
    17         ; You should have received a copy of the GNU General Public License along
    18         ; with this program; if not, write to the Free Software Foundation, Inc.,
    19         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    20         ;
    21         ; --Revision History
    22         ; July 2008 - Initial Version/GPL
    23         ; July 2008 - March 2009 various revisions
    24         ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
    25         ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl
    26         ;
    27         Q
    28         ;
    29         ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN
    30         ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :(
    31         ; GPL
    32         ;
    33 EXTRACT(MEDXML,DFN,MEDOUTXML)   ; Private; Extract medications into provided XML template
    34         ; DFN passed by reference
    35         ; MEDXML and MEDOUTXML are passed by Name
    36         ; MEDXML is the input template
    37         ; MEDOUTXML is the output template
    38         ; Both of them refer to ^TMP globals where the XML documents are stored
    39         ;
    40         N GN
    41         D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS
    42         ; this call uses GET^NHINV to retrieve xml of the meds and then
    43         ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array
    44         ;
    45         ; we now create an NHIN Array of the Meds section of the CCR
    46         ;
    47         N ZI S ZI=""
    48         F  S ZI=$O(GN("med",ZI)) Q:ZI=""  D  ; for each med
    49         . N GA S GA=$NA(GN("med",ZI))
    50         . N GM S GM="Medication" ; to keep the lines shorter
    51         . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI
    52         . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE
    53         . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds
    54         . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT")
    55         . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2
    56         . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date"
    57         . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")=""
    58         . ;S GC(GM,ZI,"DateTime[2].Type.Text")=""
    59         . N GSIG S GSIG=$G(@GA@("sig"))
    60         . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by |
    61         . S GC(GM,ZI,"Description.Text")=GSIG
    62         . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER
    63         . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@"
    64         . ;S GC(GM,ZI,GD_".Description.Text")=""
    65         . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@"
    66         . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@"
    67         . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@"
    68         . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@"
    69         . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@"
    70         . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@"
    71         . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@"
    72         . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@"
    73         . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@"
    74         . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@"
    75         . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")=""
    76         . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")=""
    77         . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")=""
    78         . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")=""
    79         . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")=""
    80         . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")=""
    81         . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")=""
    82         . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@"
    83         . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@"
    84         . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@"
    85         . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route"))
    86         . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@"
    87         . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@"
    88         . ;S GC(GM,ZI,"FullfillmentInstructions.Text")=""
    89         . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@"
    90         . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@"
    91         . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@"
    92         . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@"
    93         . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units"))
    94         . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose"))
    95         . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value"))
    96         . N GV S GV=$G(@GA@("products.product.vaProduct@vuid"))
    97         . N GR S GR=$$RXNCUI3^C0PLKUP(GV)
    98         . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID")
    99         . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV)
    100         . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F"
    101         . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value"))
    102         . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units"))
    103         . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose"))
    104         . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@"
    105         . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@"
    106         . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@"
    107         . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ
    108         . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ
    109         . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value"))
    110         . S GC(GM,ZI,"Type.Text")="Medication"
    111         N C0CDOCID
    112         S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom
    113         D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml
    114         N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1)
    115         S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML
    116         W !,MEDOUTXML
    117         ;ZWR GN
    118         ;ZWR GC
    119         ;B
    120         Q
    121         ;
     2 ;;1.0;C0C;;May 19, 2009;Build 38
     3 ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
     4 ; Licensed under the terms of the GNU General Public License.
     5 ; See attached copy of the License.
     6 ;
     7 ; This program is free software; you can redistribute it and/or modify
     8 ; it under the terms of the GNU General Public License as published by
     9 ; the Free Software Foundation; either version 2 of the License, or
     10 ; (at your option) any later version.
     11 ;
     12 ; This program is distributed in the hope that it will be useful,
     13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15 ; GNU General Public License for more details.
     16 ;
     17 ; You should have received a copy of the GNU General Public License along
     18 ; with this program; if not, write to the Free Software Foundation, Inc.,
     19 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     20 ;
     21 ; --Revision History
     22 ; July 2008 - Initial Version/GPL
     23 ; July 2008 - March 2009 various revisions
     24 ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
     25 ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl
     26 ;
     27 Q
     28 ;
     29 ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN
     30 ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :(
     31 ; GPL
     32 ;
     33EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template
     34 ; DFN passed by reference
     35 ; MEDXML and MEDOUTXML are passed by Name
     36 ; MEDXML is the input template
     37 ; MEDOUTXML is the output template
     38 ; Both of them refer to ^TMP globals where the XML documents are stored
     39 ;
     40 N GN
     41 D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS
     42 ; this call uses GET^NHINV to retrieve xml of the meds and then
     43 ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array
     44 ;
     45 ; we now create an NHIN Array of the Meds section of the CCR
     46 ;
     47 N ZI S ZI=""
     48 F  S ZI=$O(GN("med",ZI)) Q:ZI=""  D  ; for each med
     49 . N GA S GA=$NA(GN("med",ZI))
     50 . N GM S GM="Medication" ; to keep the lines shorter
     51 . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI
     52 . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE
     53 . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds
     54 . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT")
     55 . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2
     56 . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date"
     57 . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")=""
     58 . ;S GC(GM,ZI,"DateTime[2].Type.Text")=""
     59 . N GSIG S GSIG=$G(@GA@("sig"))
     60 . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by |
     61 . S GC(GM,ZI,"Description.Text")=GSIG
     62 . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER
     63 . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@"
     64 . ;S GC(GM,ZI,GD_".Description.Text")=""
     65 . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@"
     66 . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@"
     67 . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@"
     68 . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@"
     69 . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@"
     70 . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@"
     71 . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@"
     72 . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@"
     73 . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@"
     74 . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@"
     75 . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")=""
     76 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")=""
     77 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")=""
     78 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")=""
     79 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")=""
     80 . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")=""
     81 . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")=""
     82 . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@"
     83 . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@"
     84 . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@"
     85 . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route"))
     86 . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@"
     87 . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@"
     88 . ;S GC(GM,ZI,"FullfillmentInstructions.Text")=""
     89 . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@"
     90 . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@"
     91 . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@"
     92 . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@"
     93 . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units"))
     94 . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose"))
     95 . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value"))
     96 . N GV S GV=$G(@GA@("products.product.vaProduct@vuid"))
     97 . N GR S GR=$$RXNCUI3^C0PLKUP(GV)
     98 . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID")
     99 . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV)
     100 . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F"
     101 . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value"))
     102 . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units"))
     103 . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose"))
     104 . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@"
     105 . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@"
     106 . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@"
     107 . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ
     108 . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ
     109 . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value"))
     110 . S GC(GM,ZI,"Type.Text")="Medication"
     111 N C0CDOCID
     112 S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom
     113 D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml
     114 N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1)
     115 S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML
     116 W !,MEDOUTXML
     117 ;ZWR GN
     118 ;ZWR GC
     119 ;B
     120 Q
     121 ;

  • ccr/branches/ohum/p/C0CNMED4.m

    r1330 r1332  
    1 C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
    2         ;;0.1;CCDCCR;;;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "NO ENTRY FROM TOP",!
    21         Q
    22         ;
    23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)     ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    24         ;
    25         ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011
    26         ;
    27         ; MINXML is the Input XML Template, passed by name
    28         ; DFN is Patient IEN
    29         ; OUTXML is the resultant XML.
    30         ;
    31         ; MEDS is return array from API.
    32         ; MED is holds each array element from MEDS, one medicine
    33         ; MAP is a mapping variable map (store result) for each med
    34         ;
    35         ; Inpatient Meds will be extracted using this routine and and the one following.
    36         ; Inpatient Meds Unit Dose is going to be C0CMED4
    37         ; Inpatient Meds IVs is going to be C0CMED5
    38         ;
    39         ; We will use two Pharmacy ReEnginnering API's:
    40         ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
    41         ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
    42         ; For more information, see the PRE documentation at:
    43         ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
    44         ;
    45         ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
    46         ;
    47         N MEDS,MAP
    48         ;K ^TMP($J)
    49         ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
    50         ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
    51         ;; Otherwise, we go on...
    52         D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds
    53         I '$D(MEDS) Q  ; no meds
    54         N ZI S ZI=""
    55         N ZCOUNT S ZCOUNT=0
    56         F  S ZI=$O(MEDS("med",ZI)) Q:ZI=""  D  ; for each returned med
    57         . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1
    58         IF ZCOUNT=0 Q  ; no inpatient meds
    59         ;M MEDS=^TMP($J,"UD")
    60         I DEBUG ZWR MEDS
    61         S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
    62         ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
    63         N I S I=0
    64         F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
    65         . N MED M MED=MEDS("med",I)
    66         . I $G(MED("vaType@value"))'="I" Q  ; not inpatient
    67         . S MEDCOUNT=MEDCOUNT+1
    68         . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
    69         . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
    70         . ;N RXIEN S RXIEN=MED(.01) ; Order Number
    71         . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med
    72         . I DEBUG W "RXIEN IS ",RXIEN,!
    73         . I DEBUG W "MAP= ",MAP,!
    74         . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
    75         . S @MAP@("MEDISSUEDATETXT")="Order Date"
    76         . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
    77         . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT")
    78         . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
    79         . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
    80         . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
    81         . S @MAP@("MEDRXNO")="" ; For Outpatient
    82         . S @MAP@("MEDTYPETEXT")="Medication"
    83         . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    84         . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE"
    85         . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status
    86         . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active"
    87         . I C0CMST="ACTIVE" S C0CMST="Active" ;
    88         . S @MAP@("MEDSTATUSTEXT")=C0CMST
    89         . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
    90         . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code"))
    91         . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
    92         . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))
    93         . ; NDC is field 31 in the drug file.
    94         . ; The actual drug entry in the drug file is not necessarily supplied.
    95         . ; It' node 1, internal form.
    96         . ;N MEDIEN S MEDIEN=MED(1,"I")
    97         . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
    98         . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID
    99         . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
    100         . D  ;
    101         . . S ZC=$$CODE^C0CUTIL(ZVUID)
    102         . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
    103         . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
    104         . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
    105         . ;N ZRXNORM S ZRXNORM=""
    106         . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID)
    107         . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD
    108         . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
    109         . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS
    110         . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
    111         . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV
    112         . S @MAP@("MEDBRANDNAMETEXT")=""
    113         . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD
    114         . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    115         . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    116         . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
    117         . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose"))
    118         . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
    119         . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units"))
    120         . ; Units, concentration, etc, come from another call
    121         . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    122         . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    123         . ; NDF Entry IEN, and VA Product Name
    124         . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    125         . ; Documented in the same manual.
    126         . ;N NDFDATA,CONCDATA
    127         . ;I $L(MEDIEN) D
    128         . ;. D NDF^PSS50(MEDIEN,,,,,"CONC")
    129         . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN)
    130         . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    131         . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U)
    132         . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    133         . ;. ; and this will crash the call. So...
    134         . ;. I NDFIEN="" S CONCDATA=""
    135         . ;. E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    136         . ;E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
    137         . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
    138         . S @MAP@("MEDFORMTEXT")=$G(MED("form@value"))
    139         . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
    140         . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose"))
    141         . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
    142         . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units"))
    143         . ;S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
    144         . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ;
    145         . ; Oddly, there is no easy place to find the dispense unit.
    146         . ; It's not included in the original call, so we have to go to the drug file.
    147         . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    148         . ; Node 14.5 is the Dispense Unit
    149         . ;I $L(MEDIEN) D
    150         . ;. D DATA^PSS50(MEDIEN,,,,,"QTY")
    151         . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    152         . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    153         . ;E  S @MAP@("MEDQUANTITYUNIT")=""
    154         . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose"))
    155         . ;
    156         . ; --- START OF DIRECTIONS ---
    157         . ; Dosage is field 2, route is 3, schedule is 4
    158         . ; These are all free text fields, and don't point to any files
    159         . ; For that reason, I will use the field I never used before:
    160         . ; MEDDIRECTIONDESCRIPTIONTEXT
    161         . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    162         . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig"))
    163         . ; $G(MED("products.product.vaProduct@name"))
    164         . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
    165         . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
    166         . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
    167         . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
    168         . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
    169         . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
    170         . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
    171         . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
    172         . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
    173         . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
    174         . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
    175         . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
    176         . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
    177         . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
    178         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
    179         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
    180         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
    181         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
    182         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
    183         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
    184         . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
    185         . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
    186         . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
    187         . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
    188         . ;
    189         . ; --- END OF DIRECTIONS ---
    190         . ;
    191         . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
    192         . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
    193         . S @MAP@("MEDPTINSTRUCTIONS")=""
    194         . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
    195         . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
    196         . S @MAP@("MEDRFNO")=""
    197         . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    198         . K @RESULT
    199         . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    200         . ; D PARY^C0CXPATH(RESULT)
    201         . ; MAPPING DIRECTIONS
    202         . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    203         . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    204         . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    205         . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    206         . ; N MDZ1,MDZNA
    207         . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS
    208         . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    209         . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    210         . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    211         . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    212         . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    213         . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    214         . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    215         N MEDTMP,MEDI
    216         D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    217         I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    218         . W "MEDICATION MISSING ",!
    219         . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    220         Q
    221         ;
     1C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
     2 ;;0.1;CCDCCR;;;
     3 ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4 ; General Public License See attached copy of the License.
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License along
     17 ; with this program; if not, write to the Free Software Foundation, Inc.,
     18 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "NO ENTRY FROM TOP",!
     21 Q
     22 ;
     23EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     24 ;
     25 ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011
     26 ;
     27 ; MINXML is the Input XML Template, passed by name
     28 ; DFN is Patient IEN
     29 ; OUTXML is the resultant XML.
     30 ;
     31 ; MEDS is return array from API.
     32 ; MED is holds each array element from MEDS, one medicine
     33 ; MAP is a mapping variable map (store result) for each med
     34 ;
     35 ; Inpatient Meds will be extracted using this routine and and the one following.
     36 ; Inpatient Meds Unit Dose is going to be C0CMED4
     37 ; Inpatient Meds IVs is going to be C0CMED5
     38 ;
     39 ; We will use two Pharmacy ReEnginnering API's:
     40 ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
     41 ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
     42 ; For more information, see the PRE documentation at:
     43 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
     44 ;
     45 ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
     46 ;
     47 N MEDS,MAP
     48 ;K ^TMP($J)
     49 ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
     50 ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
     51 ;; Otherwise, we go on...
     52 D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds
     53 I '$D(MEDS) Q  ; no meds
     54 N ZI S ZI=""
     55 N ZCOUNT S ZCOUNT=0
     56 F  S ZI=$O(MEDS("med",ZI)) Q:ZI=""  D  ; for each returned med
     57 . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1
     58 IF ZCOUNT=0 Q  ; no inpatient meds
     59 ;M MEDS=^TMP($J,"UD")
     60 I DEBUG ZWR MEDS
     61 S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
     62 ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
     63 N I S I=0
     64 F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
     65 . N MED M MED=MEDS("med",I)
     66 . I $G(MED("vaType@value"))'="I" Q  ; not inpatient
     67 . S MEDCOUNT=MEDCOUNT+1
     68 . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
     69 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
     70 . ;N RXIEN S RXIEN=MED(.01) ; Order Number
     71 . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med
     72 . I DEBUG W "RXIEN IS ",RXIEN,!
     73 . I DEBUG W "MAP= ",MAP,!
     74 . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
     75 . S @MAP@("MEDISSUEDATETXT")="Order Date"
     76 . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
     77 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT")
     78 . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
     79 . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
     80 . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
     81 . S @MAP@("MEDRXNO")="" ; For Outpatient
     82 . S @MAP@("MEDTYPETEXT")="Medication"
     83 . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     84 . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE"
     85 . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status
     86 . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active"
     87 . I C0CMST="ACTIVE" S C0CMST="Active" ;
     88 . S @MAP@("MEDSTATUSTEXT")=C0CMST
     89 . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
     90 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code"))
     91 . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
     92 . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))
     93 . ; NDC is field 31 in the drug file.
     94 . ; The actual drug entry in the drug file is not necessarily supplied.
     95 . ; It' node 1, internal form.
     96 . ;N MEDIEN S MEDIEN=MED(1,"I")
     97 . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
     98 . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID
     99 . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
     100 . D  ;
     101 . . S ZC=$$CODE^C0CUTIL(ZVUID)
     102 . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
     103 . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
     104 . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
     105 . ;N ZRXNORM S ZRXNORM=""
     106 . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID)
     107 . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD
     108 . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
     109 . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS
     110 . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
     111 . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV
     112 . S @MAP@("MEDBRANDNAMETEXT")=""
     113 . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD
     114 . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     115 . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     116 . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
     117 . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose"))
     118 . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
     119 . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units"))
     120 . ; Units, concentration, etc, come from another call
     121 . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     122 . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     123 . ; NDF Entry IEN, and VA Product Name
     124 . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     125 . ; Documented in the same manual.
     126 . ;N NDFDATA,CONCDATA
     127 . ;I $L(MEDIEN) D
     128 . ;. D NDF^PSS50(MEDIEN,,,,,"CONC")
     129 . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN)
     130 . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     131 . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U)
     132 . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     133 . ;. ; and this will crash the call. So...
     134 . ;. I NDFIEN="" S CONCDATA=""
     135 . ;. E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     136 . ;E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
     137 . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
     138 . S @MAP@("MEDFORMTEXT")=$G(MED("form@value"))
     139 . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
     140 . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose"))
     141 . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
     142 . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units"))
     143 . ;S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
     144 . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ;
     145 . ; Oddly, there is no easy place to find the dispense unit.
     146 . ; It's not included in the original call, so we have to go to the drug file.
     147 . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     148 . ; Node 14.5 is the Dispense Unit
     149 . ;I $L(MEDIEN) D
     150 . ;. D DATA^PSS50(MEDIEN,,,,,"QTY")
     151 . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     152 . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     153 . ;E  S @MAP@("MEDQUANTITYUNIT")=""
     154 . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose"))
     155 . ;
     156 . ; --- START OF DIRECTIONS ---
     157 . ; Dosage is field 2, route is 3, schedule is 4
     158 . ; These are all free text fields, and don't point to any files
     159 . ; For that reason, I will use the field I never used before:
     160 . ; MEDDIRECTIONDESCRIPTIONTEXT
     161 . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     162 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig"))
     163 . ; $G(MED("products.product.vaProduct@name"))
     164 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
     165 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
     166 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
     167 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
     168 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
     169 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
     170 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
     171 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
     172 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
     173 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
     174 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
     175 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
     176 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
     177 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
     178 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
     179 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
     180 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
     181 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
     182 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
     183 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
     184 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
     185 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
     186 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
     187 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
     188 . ;
     189 . ; --- END OF DIRECTIONS ---
     190 . ;
     191 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
     192 . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
     193 . S @MAP@("MEDPTINSTRUCTIONS")=""
     194 . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
     195 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
     196 . S @MAP@("MEDRFNO")=""
     197 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     198 . K @RESULT
     199 . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     200 . ; D PARY^C0CXPATH(RESULT)
     201 . ; MAPPING DIRECTIONS
     202 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     203 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     204 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     205 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     206 . ; N MDZ1,MDZNA
     207 . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS
     208 . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     209 . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     210 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     211 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     212 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     213 . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     214 . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     215 N MEDTMP,MEDI
     216 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     217 I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     218 . W "MEDICATION MISSING ",!
     219 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     220 Q
     221 ;

  • ccr/branches/ohum/p/C0CORSLT.m

    r1330 r1332  
    1 C0CORSLT        ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
    2         ;;1.0;C0C;;Jan 21, 2010;Build 1
     1C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
     2        ;;1.0;C0C;;Jan 21, 2010;Build 38
    33        ;Copyright 2011 George Lilly.
    44        ;Licensed under the terms of the GNU General Public License.
    … …  
    2222        Q
    2323        ;
    24 EN(ZVARS,DFN)   ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS
    25         ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE
    26         ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS
    27         ; THIS IS CREATED FOR MU CERTIFICATION BY GPL
    28         D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
    29         N ZN ; RESULT NUMBER
    30         S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT
    31         N ZI S ZI=""
    32         F  S ZI=$O(VISIT(ZI)) Q:ZI=""  D  ; FOR EACH VISIT
    33         . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D  ; GOT AN ECG
    34         . . S ZN=ZN+1 ; INCREMENT RESULT COUNT
    35         . . N ZDATE,ZPRV,ZTXT
    36         . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE
    37         . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER
    38         . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2)
    39         . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
    40         . . S @ZVARS@(ZN,"RESULTCODE")="34534-8"
    41         . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC"
    42         . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
    43         . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN
    44         . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV
    45         . . S @ZVARS@(ZN,"RESULTSTATUS")=""
    46         . . S @ZVARS@(ZN,"M","TEST",0)=1
    47         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8"
    48         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC"
    49         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
    50         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
    51         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")=""
    52         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")=""
    53         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM"
    54         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN
    55         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV
    56         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F"
    57         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")=""
    58         . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT
    59         . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT
    60         Q
    61         ;
    62 OLD     ; OLD CODE FOR OTHER WAYS OF DOING THE ECG
    63         ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
    64         W !,"CPT=",ZCPT
    65         I ZCPT["93000" D  ; THIS IS AN EKG
    66         . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
    67         . M ^GPL("RNF2")=@C0CPRSLT
    68         Q
    69         ;
     24EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS
     25 ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE
     26 ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS
     27 ; THIS IS CREATED FOR MU CERTIFICATION BY GPL
     28 D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
     29 N ZN ; RESULT NUMBER
     30 S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT
     31 N ZI S ZI=""
     32 F  S ZI=$O(VISIT(ZI)) Q:ZI=""  D  ; FOR EACH VISIT
     33 . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D  ; GOT AN ECG
     34 . . S ZN=ZN+1 ; INCREMENT RESULT COUNT
     35 . . N ZDATE,ZPRV,ZTXT
     36 . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE
     37 . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER
     38 . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2)
     39 . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
     40 . . S @ZVARS@(ZN,"RESULTCODE")="34534-8"
     41 . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC"
     42 . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
     43 . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN
     44 . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV
     45 . . S @ZVARS@(ZN,"RESULTSTATUS")=""
     46 . . S @ZVARS@(ZN,"M","TEST",0)=1
     47 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8"
     48 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC"
     49 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
     50 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
     51 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")=""
     52 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")=""
     53 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM"
     54 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN
     55 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV
     56 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F"
     57 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")=""
     58 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT
     59 . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT
     60 Q
     61 ;
     62OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG
     63 ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
     64 W !,"CPT=",ZCPT
     65 I ZCPT["93000" D  ; THIS IS AN EKG
     66 . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
     67 . M ^GPL("RNF2")=@C0CPRSLT
     68 Q
     69 ;

  • ccr/branches/ohum/p/C0CPARMS.m

    r1330 r1332  
    11C0CPARMS        ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
    … …  
    3838        ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS
    3939        ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS
    40         ;OHUM/RUT commented the hardcoded limits
    41         ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
    42         ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
    43         ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
    44         ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
    45         ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
    46         ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
    47         ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
    48         ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
    49         ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
    50         S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT")
     40        I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
    5141        I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
     42        I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
    5243        I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
    5344        I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
     45        I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
    5446        I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
    5547        I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
    56         I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE
    57         ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
    58         ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
    59         I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
    60         ;OHUM/RUT
     48        I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
    6149        Q
    6250        ;

  • ccr/branches/ohum/p/C0CPROBS.m

    r1330 r1332  
    11C0CPROBS        ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CPROC.m

    r1330 r1332  
    11C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
    2         ;;1.0;C0C;;Jan 21, 2010;Build 1
     2        ;;1.0;C0C;;Jan 21, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CPXRM.m

    r1330 r1332  
    1 C0CPXRM ;
    2 DOIT    ;
    3         S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*)
    4         S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*)
    5         S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*)
    6         S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*)
    7         S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*)
    8         S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*)
    9         S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*)
    10         S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*)
    11         S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*)
    12         S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*)
    13         S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*)
    14         S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*)
    15         S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*)
    16         S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*)
    17         S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*)
    18         S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*)
    19         S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*)
    20         S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*)
    21         S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*)
    22         S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*)
    23         S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*)
    24         S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*)
    25         S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*)
    26         S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*)
    27         S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*)
    28         S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*)
    29         S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*)
    30         S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*)
    31         S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*)
    32         S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*)
    33         S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*)
    34         S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*)
    35         S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*)
    36         S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*)
    37         S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*)
    38         S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*)
    39         S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*)
    40         S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*)
    41         S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*)
    42         S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*)
    43         S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*)
    44         S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*)
    45         S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*)
    46         S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*)
    47         S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*)
    48         S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*)
    49         S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*)
    50         S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*)
    51         S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*)
    52         S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*)
    53         S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*)
    54         S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*)
    55         S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*)
    56         S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*)
    57         S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*)
    58         S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*)
    59         S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*)
    60         S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*)
    61         S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*)
    62         S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*)
    63         S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*)
    64         S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*)
    65         S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*)
    66         S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*)
    67         S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*)
    68         S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*)
    69         S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*)
    70         S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*)
    71         S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*)
    72         Q
    73         ;
     1C0CPXRM ;
     2;;;
     3DOIT ;
     4 S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*)
     5 S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*)
     6 S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*)
     7 S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*)
     8 S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*)
     9 S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*)
     10 S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*)
     11 S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*)
     12 S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*)
     13 S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*)
     14 S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*)
     15 S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*)
     16 S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*)
     17 S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*)
     18 S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*)
     19 S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*)
     20 S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*)
     21 S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*)
     22 S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*)
     23 S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*)
     24 S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*)
     25 S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*)
     26 S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*)
     27 S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*)
     28 S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*)
     29 S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*)
     30 S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*)
     31 S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*)
     32 S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*)
     33 S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*)
     34 S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*)
     35 S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*)
     36 S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*)
     37 S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*)
     38 S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*)
     39 S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*)
     40 S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*)
     41 S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*)
     42 S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*)
     43 S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*)
     44 S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*)
     45 S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*)
     46 S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*)
     47 S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*)
     48 S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*)
     49 S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*)
     50 S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*)
     51 S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*)
     52 S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*)
     53 S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*)
     54 S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*)
     55 S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*)
     56 S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*)
     57 S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*)
     58 S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*)
     59 S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*)
     60 S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*)
     61 S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*)
     62 S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*)
     63 S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*)
     64 S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*)
     65 S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*)
     66 S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*)
     67 S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*)
     68 S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*)
     69 S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*)
     70 S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*)
     71 S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*)
     72 S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*)
     73 Q
     74 ;

  • ccr/branches/ohum/p/C0CQRY1.m

    r1330 r1332  
    1 LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
    2                ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 1
    3                ;
    4                Q
    5                ;
    6 CHKSC     ; Check search NLT/LOINC codes
    7                ;
    8                N J
    9                ;
    10                S J=0
    11                F  S J=$O(LA7SC(J)) Q:'J  D
    12                . N X
    13                . S X=LA7SC(J)
    14                . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
    15                . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
    16                . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
    17                . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
    18                . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
    19                . K LA7SC(J)
    20                Q
    21                ;
    22                ;
    23 SPEC       ; Convert HL7 Specimen Codes to File #61, Topography codes
    24                ; Find all topographies that use this HL7 specimen code
    25                N J,K,L
    26                ;
    27                S J=0
    28                F  S J=$O(LA7SPEC(J)) Q:'J  D
    29                . S K=LA7SPEC(J),L=0
    30                . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
    31                Q
    32                ;
    33                ;
    34 BUILDMSG               ; Build HL7 message with result of query
    35                ;
    36                N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
    37                ;
    38                I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
    39                S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
    40                S (HLQ,HL("Q"))=""""""
    41                ; Set flag to not send HL7 message
    42                S LA7NOMSG=1
    43                ; Create dummy MSH to pass HL7 delimiters
    44                S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
    45                D FILESEG^LA7VHLU(GBL,.LA7MSH)
    46                ;
    47                F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
    48                ;
    49                ; Take search results and put in HL7 message structure
    50                S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
    51                ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
    52                F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
    53                . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
    54                . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
    55                . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
    56                . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
    57                . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
    58                . D OBX
    59                ;
    60                Q
    61                ;
    62                ;
    63 PID         ; Build PID segment
    64                ;
    65                N LA7PID
    66                ;
    67                S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
    68                S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
    69                D DEM^LRX
    70                D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
    71                D FILESEG^LA7VHLU(GBL,.LA7PID)
    72                S (LA("LRIDT"),LA("SUB"))=""
    73                Q
    74                ;
    75                ;
    76 ORC         ; Build ORC segment
    77                ;
    78                N X
    79                ;
    80                S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
    81                S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    82                S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
    83                S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
    84                I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
    85                S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
    86                D ORC^LA7VORU
    87                S LA("NLT")=""
    88                ;
    89                Q
    90                ;
    91                ;
    92 OBR         ; Build OBR segment
    93                ;
    94                N LA764,LA7NLT
    95                ;
    96                S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
    97                I $L(LA7NLT) D
    98                . S LA764=+$O(^LAM("E",LA7NLT,0))
    99                . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
    100                I LA("SUB")="CH" D
    101                . D OBR^LA7VORU
    102                . D NTE^LA7VORU
    103                . S LA7OBXSN=0
    104                ;
    105                Q
    106                ;
    107                ;
    108 OBX         ; Build OBX segment
    109                ;
    110                N LA7DATA,LA7VT
    111                ;
    112                S LA7NTESN=0
    113                I LA("SUB")="MI" D MI^LA7VORU1 Q
    114                I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
    115                ;
    116                S LA7VT=$QS(LA7ROOT,7)
    117                D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
    118                I '$D(LA7DATA) Q
    119                D FILESEG^LA7VHLU(GBL,.LA7DATA)
    120                ; Send any test interpretation from file #60
    121                D INTRP^LA7VORUA
    122                ;
    123                Q
     1LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
     2        ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31
     3        ;
     4        Q
     5        ;
     6CHKSC   ; Check search NLT/LOINC codes
     7        ;
     8        N J
     9        ;
     10        S J=0
     11        F  S J=$O(LA7SC(J)) Q:'J  D
     12        . N X
     13        . S X=LA7SC(J)
     14        . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
     15        . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
     16        . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
     17        . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
     18        . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
     19        . K LA7SC(J)
     20        Q
     21        ;
     22        ;
     23SPEC    ; Convert HL7 Specimen Codes to File #61, Topography codes
     24        ; Find all topographies that use this HL7 specimen code
     25        N J,K,L
     26        ;
     27        S J=0
     28        F  S J=$O(LA7SPEC(J)) Q:'J  D
     29        . S K=LA7SPEC(J),L=0
     30        . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
     31        Q
     32        ;
     33        ;
     34BUILDMSG        ; Build HL7 message with result of query
     35        ;
     36        N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
     37        ;
     38        I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
     39        S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
     40        S (HLQ,HL("Q"))=""""""
     41        ; Set flag to not send HL7 message
     42        S LA7NOMSG=1
     43        ; Create dummy MSH to pass HL7 delimiters
     44        S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
     45        D FILESEG^LA7VHLU(GBL,.LA7MSH)
     46        ;
     47        F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
     48        ;
     49        ; Take search results and put in HL7 message structure
     50        S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
     51        ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
     52        F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
     53        . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
     54        . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
     55        . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
     56        . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
     57        . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
     58        . D OBX
     59        ;
     60        Q
     61        ;
     62        ;
     63PID     ; Build PID segment
     64        ;
     65        N LA7PID
     66        ;
     67        S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
     68        S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
     69        D DEM^LRX
     70        D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
     71        D FILESEG^LA7VHLU(GBL,.LA7PID)
     72        S (LA("LRIDT"),LA("SUB"))=""
     73        Q
     74        ;
     75        ;
     76ORC     ; Build ORC segment
     77        ;
     78        N X
     79        ;
     80        S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
     81        S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     82        S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
     83        S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
     84        I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
     85        S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
     86        D ORC^LA7VORU
     87        S LA("NLT")=""
     88        ;
     89        Q
     90        ;
     91        ;
     92OBR     ; Build OBR segment
     93        ;
     94        N LA764,LA7NLT
     95        ;
     96        S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
     97        I $L(LA7NLT) D
     98        . S LA764=+$O(^LAM("E",LA7NLT,0))
     99        . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
     100        I LA("SUB")="CH" D
     101        . D OBR^LA7VORU
     102        . D NTE^LA7VORU
     103        . S LA7OBXSN=0
     104        ;
     105        Q
     106        ;
     107        ;
     108OBX     ; Build OBX segment
     109        ;
     110        N LA7DATA,LA7VT
     111        ;
     112        S LA7NTESN=0
     113        I LA("SUB")="MI" D MI^LA7VORU1 Q
     114        I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
     115        ;
     116        S LA7VT=$QS(LA7ROOT,7)
     117        D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
     118        I '$D(LA7DATA) Q
     119        D FILESEG^LA7VHLU(GBL,.LA7DATA)
     120        ; Send any test interpretation from file #60
     121        D INTRP^LA7VORUA
     122        ;
     123        Q

  • ccr/branches/ohum/p/C0CQRY2.m

    r1330 r1332  
    1 LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 1
    3         ; JMC - mods to check for IHS V LAB file
    4         ;
    5         Q
    6         ;
    7 PATID   ; Resolve patient id and establish patient environment
    8         ;
    9         N LA7X
    10         ;
    11         S (DFN,LRDFN)="",LA7PTYP=0
    12         ;
    13         ; SSN passed as patient identifier
    14         I LA7PTID?9N.1A D
    15         . S LA7PTYP=1
    16         . S LA7X=$O(^DPT("SSN",LA7PTID,0))
    17         . I LA7X>0 D SETDFN(LA7X)
    18         ;
    19         ; MPI/ICN (integration control number) passed as patient identifier
    20         I LA7PTID?10N1"V"6N D
    21         . S LA7PTYP=2
    22         . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
    23         . I LA7X>0 D SETDFN(LA7X)
    24         ;
    25         ; If no patient identified/no laboratory record - return exception message
    26         I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
    27         I 'DFN S LA7ERR(2)="No patient found with requested identifier"
    28         I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
    29         I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
    30         Q
    31         ;
    32         ;
    33 BCD     ; Search by specimen collection date.
    34         ;
    35         N LA763,LA7QUIT
    36         ;
    37         S (LA7SDT(0),LA7EDT(0))=0
    38         I LA7SDT S LA7SDT(0)=9999999-LA7SDT
    39         I LA7EDT S LA7EDT(0)=9999999-LA7EDT
    40         ;
    41         F LRSS="CH","MI","SP" D
    42         . S (LA7QUIT,LRIDT)=0
    43         . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
    44         . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
    45         . . ; Quit if reached end of data or outside date criteria
    46         . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
    47         . . D SEARCH
    48         ;
    49         Q
    50         ;
    51         ;
    52 BRAD    ; Search by results available date (completion date).
    53         ; Assumes cross-references still exist for dates in LRO(69) global.
    54         ; Collects specimen date/time values for a given LRDFN and completion date.
    55         ; Cross-reference is by date only, time stripped from start date.
    56         ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
    57         ;
    58         N LA763,LA7DT,LA7ROOT,LA7SRC,X
    59         ;
    60         ; Check if orders still exist Iin file #69 for search range
    61         S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
    62         S X=$O(^LRO(69,LA7SDT(1)))
    63         I X,X<LA7EDT(1) S LA7SRC=1
    64         ;
    65         ; Search "AN" cross-reference in file #69.
    66         I LA7SRC D
    67         . S LA7DT=LA7SDT(1)
    68         . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
    69         . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
    70         . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
    71         . . . I $QS(LA7ROOT,6)'=LRDFN Q
    72         . . . S LRIDT=$QS(LA7ROOT,7)
    73         . . . F LRSS="CH","MI","SP" D SEARCH
    74         ;
    75         ; If no orders in #69 then do long search through file #63.
    76         I 'LA7SRC D
    77         . F LRSS="CH","MI","SP" D
    78         . . S LRIDT=0
    79         . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
    80         . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
    81         . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
    82         ;
    83         Q
    84         ;
    85         ;
    86 SEARCH  ; Search subscript for a specific collection date/time
    87         ;
    88         K LA763
    89         S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
    90         ;
    91         ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
    92         ; Quit if specific specimen codes and they do not match
    93         I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
    94         E  S LA761=0
    95         I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
    96         ;
    97         ; --- Chemistry
    98         I LRSS="CH" D CHSS Q
    99         ; --- Microbiology
    100         I LRSS="MI" D MISS Q
    101         ; --- Surgical pathology
    102         I LRSS="SP" D APSS Q
    103         ; --- Cytology
    104         I LRSS="CY" D APSS Q
    105         ; --- Electron Micrscopsy
    106         I LRSS="EM" D APSS Q
    107         ; --- Autopsy
    108         I LRSS="AU" D APSS Q
    109         ; --- Blood Bank
    110         I LRSS="BB" D BBSS Q
    111         Q
    112         ;
    113         ;
    114 CHSS    ; Search "CH" datanames for matching codes
    115         ;
    116         N LA7X,LRSB
    117         ;
    118         S LRSB=1
    119         F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
    120         . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
    121         . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
    122         . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
    123         . D CHECK
    124         ;
    125         Q
    126         ;
    127         ;
    128 MISS    ; Search "MI" subscripts for matching codes
    129         ;
    130         N LA7ND,LRSB
    131         ;
    132         S LA7ND=0
    133         F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
    134         . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
    135         . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
    136         . D CHECK
    137         Q
    138         ;
    139         ;
    140 APSS    ; Search AP subscripts for matching codes
    141         ; AP results are currently not coded - use defaults
    142         ;
    143         N LA7CODE,LRSB
    144         ;
    145         S LRSB=.012
    146         S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
    147         D CHECK
    148         ;
    149         Q
    150         ;
    151         ;
    152 BBSS    ; Search BB subscript for matching codes
    153         ; *** This subscript currently not supported ***
    154         Q
    155         ;
    156         ;
    157 CHECK   ; Check NLT order/result and LOINC codes.
    158         ;
    159         N LA7QUIT
    160         ;
    161         ; If wildcard then store
    162         ; Otherwise check for specific NLT order/result and LOINC codes
    163         I LA7SC="*" D STORE Q
    164         S LA7QUIT=0
    165         F I=1:1:3 D  Q:LA7QUIT
    166         . ; If no test code then skip
    167         . I '$L($P(LA7CODE,"!",I)) Q
    168         . ; If test code does not match a search code then quit
    169         . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
    170         . D STORE S LA7QUIT=1
    171         ;
    172         Q
    173         ;
    174         ;
    175 STORE   ; Store entry for building in HL7 message
    176         ;
    177         S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
    178         Q
    179         ;
    180         ;
    181 SETDFN(LA7X)    ; Setup DFN and other lab variables.
    182         ;
    183         S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
    184         Q
     1LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
     3 ; JMC - mods to check for IHS V LAB file
     4 ;
     5 Q
     6 ;
     7PATID ; Resolve patient id and establish patient environment
     8 ;
     9 N LA7X
     10 ;
     11 S (DFN,LRDFN)="",LA7PTYP=0
     12 ;
     13 ; SSN passed as patient identifier
     14 I LA7PTID?9N.1A D
     15 . S LA7PTYP=1
     16 . S LA7X=$O(^DPT("SSN",LA7PTID,0))
     17 . I LA7X>0 D SETDFN(LA7X)
     18 ;
     19 ; MPI/ICN (integration control number) passed as patient identifier
     20 I LA7PTID?10N1"V"6N D
     21 . S LA7PTYP=2
     22 . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
     23 . I LA7X>0 D SETDFN(LA7X)
     24 ;
     25 ; If no patient identified/no laboratory record - return exception message
     26 I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
     27 I 'DFN S LA7ERR(2)="No patient found with requested identifier"
     28 I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
     29 I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
     30 Q
     31 ;
     32 ;
     33BCD ; Search by specimen collection date.
     34 ;
     35 N LA763,LA7QUIT
     36 ;
     37 S (LA7SDT(0),LA7EDT(0))=0
     38 I LA7SDT S LA7SDT(0)=9999999-LA7SDT
     39 I LA7EDT S LA7EDT(0)=9999999-LA7EDT
     40 ;
     41 F LRSS="CH","MI","SP" D
     42 . S (LA7QUIT,LRIDT)=0
     43 . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
     44 . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
     45 . . ; Quit if reached end of data or outside date criteria
     46 . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
     47 . . D SEARCH
     48 ;
     49 Q
     50 ;
     51 ;
     52BRAD ; Search by results available date (completion date).
     53 ; Assumes cross-references still exist for dates in LRO(69) global.
     54 ; Collects specimen date/time values for a given LRDFN and completion date.
     55 ; Cross-reference is by date only, time stripped from start date.
     56 ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
     57 ;
     58 N LA763,LA7DT,LA7ROOT,LA7SRC,X
     59 ;
     60 ; Check if orders still exist Iin file #69 for search range
     61 S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
     62 S X=$O(^LRO(69,LA7SDT(1)))
     63 I X,X<LA7EDT(1) S LA7SRC=1
     64 ;
     65 ; Search "AN" cross-reference in file #69.
     66 I LA7SRC D
     67 . S LA7DT=LA7SDT(1)
     68 . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
     69 . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
     70 . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
     71 . . . I $QS(LA7ROOT,6)'=LRDFN Q
     72 . . . S LRIDT=$QS(LA7ROOT,7)
     73 . . . F LRSS="CH","MI","SP" D SEARCH
     74 ;
     75 ; If no orders in #69 then do long search through file #63.
     76 I 'LA7SRC D
     77 . F LRSS="CH","MI","SP" D
     78 . . S LRIDT=0
     79 . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
     80 . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
     81 . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
     82 ;
     83 Q
     84 ;
     85 ;
     86SEARCH ; Search subscript for a specific collection date/time
     87 ;
     88 K LA763
     89 S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
     90 ;
     91 ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
     92 ; Quit if specific specimen codes and they do not match
     93 I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
     94 E  S LA761=0
     95 I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
     96 ;
     97 ; --- Chemistry
     98 I LRSS="CH" D CHSS Q
     99 ; --- Microbiology
     100 I LRSS="MI" D MISS Q
     101 ; --- Surgical pathology
     102 I LRSS="SP" D APSS Q
     103 ; --- Cytology
     104 I LRSS="CY" D APSS Q
     105 ; --- Electron Micrscopsy
     106 I LRSS="EM" D APSS Q
     107 ; --- Autopsy
     108 I LRSS="AU" D APSS Q
     109 ; --- Blood Bank
     110 I LRSS="BB" D BBSS Q
     111 Q
     112 ;
     113 ;
     114CHSS ; Search "CH" datanames for matching codes
     115 ;
     116 N LA7X,LRSB
     117 ;
     118 S LRSB=1
     119 F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
     120 . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
     121 . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
     122 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
     123 . D CHECK
     124 ;
     125 Q
     126 ;
     127 ;
     128MISS ; Search "MI" subscripts for matching codes
     129 ;
     130 N LA7ND,LRSB
     131 ;
     132 S LA7ND=0
     133 F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
     134 . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
     135 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
     136 . D CHECK
     137 Q
     138 ;
     139 ;
     140APSS ; Search AP subscripts for matching codes
     141 ; AP results are currently not coded - use defaults
     142 ;
     143 N LA7CODE,LRSB
     144 ;
     145 S LRSB=.012
     146 S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
     147 D CHECK
     148 ;
     149 Q
     150 ;
     151 ;
     152BBSS ; Search BB subscript for matching codes
     153 ; *** This subscript currently not supported ***
     154 Q
     155 ;
     156 ;
     157CHECK ; Check NLT order/result and LOINC codes.
     158 ;
     159 N LA7QUIT
     160 ;
     161 ; If wildcard then store
     162 ; Otherwise check for specific NLT order/result and LOINC codes
     163 I LA7SC="*" D STORE Q
     164 S LA7QUIT=0
     165 F I=1:1:3 D  Q:LA7QUIT
     166 . ; If no test code then skip
     167 . I '$L($P(LA7CODE,"!",I)) Q
     168 . ; If test code does not match a search code then quit
     169 . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
     170 . D STORE S LA7QUIT=1
     171 ;
     172 Q
     173 ;
     174 ;
     175STORE ; Store entry for building in HL7 message
     176 ;
     177 S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
     178 Q
     179 ;
     180 ;
     181SETDFN(LA7X) ; Setup DFN and other lab variables.
     182 ;
     183 S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
     184 Q

  • ccr/branches/ohum/p/C0CRIMA.m

    r1330 r1332  
    11C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CRNF.m

    r1330 r1332  
    11C0CRNF    ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CRNFRP.m

    r1330 r1332  
    1 C0CRNFRPC         ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
    2         ;;1.0;C0C;;Dec 9, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the Reference Name Format (RNF) RPC Library ",!
    21         W !
    22         Q
    23         ;
    24         ;This routine will be mirroring C0CRNF and transform the output
    25         ;of the tags into an RPC friendly format
    26         ;The tags will be exactly as they are in C0CRNF
    27 FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
    28         ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE
    29         ;RETURN FORMAT:
    30         ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS
    31         ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER"
    32         ;
    33         ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
    34         ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625"
    35         ;
    36         ;FORMAT APPEARS TO BE:
    37         ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER"
    38         ;
    39         ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
    40         S DEBUG=0
    41         ;SET RETURN VALUE
    42         S C0CFRTN=$NA(^TMP("C0CRNF",$J))
    43         K @C0CFRTN
    44         ;RUN WRAPPED CALL
    45         D FIELDS^C0CRNF("C0CRTN",C0CFILE)
    46         S J=""
    47         S I=1
    48         ;FORMAT RETURN
    49         F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
    50         . S @C0CFRTN@(I)=J_"^"_C0CRTN(J)
    51         . S I=I+1
    52         S @C0CFRTN@(0)=I-1
    53         ;CLEAN UP
    54         K J,I
    55         Q
    56         ;
    57 GETNOLD(GRTN,GFILE,GIEN,GNN)    ; GET FIELDS FOR ACCESS BY NAME
    58         ; GRTN IS PASSED BY NAME
    59         ;
    60         ; OLD TAG DO NOT USE!
    61         Q
    62         ;
    63 GETN(C0CGRTN,GFILE,GREF,GNDX,GNN)       ; GET BY NAME ; RETURN A FIELD VALUE MAP
    64         ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
    65         ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    66         ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
    67         ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    68         ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
    69         ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    70         ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    71         ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    72         ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
    73         ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
    74         ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
    75         ; GREF IS THE VALUE FOR THE INDEX
    76         ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    77         ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
    78         ;
    79         ;
    80         ;RETURN FORMAT:
    81         ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)"
    82         ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)"
    83         ;
    84         ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
    85         ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268"
    86         ;C0CRNFGETN("1U4N")="2^.0905^H5369"
    87         ;C0CRNFGETN("1U4N","I")="^^H5369"
    88         ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26"
    89         ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326"
    90         ;
    91         ;FORMAT APPEARS TO BE:
    92         ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ"
    93         ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE"
    94         ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE"
    95         ;
    96         ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
    97         S DEBUG=0
    98         ;SET RETURN VALUE
    99         S C0CGRTN=$NA(^TMP("C0CRNF",$J))
    100         K @C0CGRTN
    101         ;RUN WRAPPED CALL
    102         D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN))
    103         S J=""
    104         S I=1
    105         ;FORMAT RETURN
    106         F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
    107         . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE
    108         . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE
    109         . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA
    110         . ;TEST TO SEE IF INTERNAL DATA EXISTS
    111         . I $D(C0CRTN(J,"I"))=1 D
    112         . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3
    113         . S I=I+1
    114         S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0)
    115         ;CLEAN UP
    116         K J,I
    117         Q
    118         ;
    119 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
    120         ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
    121         ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
    122         ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
    123         ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    124         ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
    125         ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    126         ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
    127         ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    128         ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    129         ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    130         ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    131         ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
    132         ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
    133         ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
    134         ; GREF IS THE VALUE FOR THE INDEX
    135         ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    136         ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
    137         ;
    138         ;
    139         N GIEN,GF
    140         S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
    141         I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
    142         E  D  ; WE ARE USING AN INDEX
    143         . ;N ZG
    144         . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
    145         . I ZG'="" D  ;
    146         . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
    147         . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
    148         . . E  S GIEN="" ; NOT FOUND IN INDEX
    149         . E  S GIEN="" ;
    150         ;W "IEN: ",GIEN,!
    151         ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
    152         I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
    153         E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
    154         S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
    155         D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    156         K C0CTMP
    157         D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
    158         D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
    159         S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
    160         S (C0CI,C0CJ)=""
    161         F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
    162         . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
    163         . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
    164         . . ;W C0CJ," ",C0CI,!
    165         . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
    166         . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
    167         . . I C0CVALUE["C0CTMP" D  ; WP FIELD
    168         . . . N ZT,ZWP S ZWP=0 ;ITERATOR
    169         . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
    170         . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
    171         . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
    172         . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
    173         . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
    174         . . . . S C0CVALUE=C0CVALUE_ZT ;
    175         . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
    176         . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
    177         I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
    178         . S C0CI=""
    179         . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
    180         . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
    181         Q
    182         ;
    183 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN)     ; RETURN FIELD MAP AND VALUES
    184         ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    185         ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
    186         ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    187         ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
    188         ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
    189         ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    190         ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    191         ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    192         ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    193         ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
    194         ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
    195         ; .. OF THE FILE WILL BE USED
    196         ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
    197         ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
    198         ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
    199         ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
    200         ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    201         ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
    202         ;N GATMP,GAI,GAF
    203         S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
    204         I '$D(GAIDX) S GAIDX="" ;DEFAULT
    205         I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
    206         I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
    207         W GAF,!
    208         W $O(@GAF@(0)) ;
    209         S GAI=0 ;ITERATOR
    210         F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
    211         . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
    212         . N GAX S GAX=0
    213         . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
    214         . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
    215         Q
    216         ;
    217 ADDNV(GNV,GNVN,GNVF,GNVV)       ; CREATE AN ELEMENT OF THE MATRIX
    218         ;
    219         S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
    220         S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
    221         Q
    222         ;
    223 RNF2CSV(RNRTN,RNIN,RNSTY)       ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
    224         ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
    225         ; RNSTY IS STYLE OF THE OUTPUT -
    226         ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
    227         ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
    228         ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
    229         N RNR,RNC ;ROW ROOT,COL ROOT
    230         N RNI,RNJ,RNX
    231         I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
    232         I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
    233         E  D VN(RNRTN,RNIN) ;
    234         Q
    235         ;
    236 NV(RNRTN,RNIN)  ;
    237         S RNR=$NA(@RNIN@("F"))
    238         S RNC=$NA(@RNIN@("V"))
    239         ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
    240         S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
    241         S RNI=""
    242         F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
    243         . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
    244         S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    245         D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
    246         S RNI=""
    247         F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
    248         . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
    249         . S RNJ=""
    250         . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
    251         . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
    252         . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
    253         . . E  S RNX=RNX_"," ; NUL COLUMN
    254         . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    255         . D PUSH^GPLXPATH(RNRTN,RNX)
    256         Q
    257         ;
    258 VN(RNRTN,RNIN)  ;
    259         S RNR=$NA(@RNIN@("V"))
    260         S RNC=$NA(@RNIN@("F"))
    261         ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
    262         S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
    263         S RNI=""
    264         F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
    265         . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
    266         S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    267         D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
    268         S RNI=""
    269         F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
    270         . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
    271         . S RNJ=""
    272         . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
    273         . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
    274         . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
    275         . . E  S RNX=RNX_"," ; NUL COLUMN
    276         . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    277         . D PUSH^GPLXPATH(RNRTN,RNX)
    278         Q
    279         ;
    280 READCSV(PATH,NAME,GLB)  ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
    281         ;
    282         Q $$FTG^%ZISH(PATH,NAME,GLB,1)
    283         ;
    284 FILE2CSV(FNUM,FVN)      ; WRITES OUT A FILEMAN FILE TO CSV
    285         ;
    286         ;N G1,G2
    287         I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
    288         S G1=$NA(^TMP($J,"C0CCSV",1))
    289         S G2=$NA(^TMP($J,"C0CCSV",2))
    290         D GETN2(G1,FNUM) ; GET THE MATRIX
    291         D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
    292         K @G1
    293         D FILEOUT(G2,"FILE_"_FNUM_".csv")
    294         K @G2
    295         Q
    296         ;
    297 FILEOUT(FOARY,FONAM)    ; WRITE OUT A FILE
    298         ;
    299         W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR"))
    300         Q
    301         ;
    302 FILEREF(FNUM)   ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
    303         ;
    304         N C0CF
    305         S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
    306         S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
    307         I C0CF["()" S C0CF=$P(C0CF,"()",1)
    308         Q C0CF
    309         ;
    310 SKIP    ;
    311         N TXT,DIERR
    312         S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
    313         I $D(DIERR) D CLEAN^DILF Q
    314         W "  report_text:",!  ;Progress Note Text
    315         N LN S LN=0
    316         F  S LN=$O(TXT(LN)) Q:'LN  D
    317         . W "    text"_LN_": "_TXT(LN),!
    318         . Q
    319         Q
    320         ;
    321 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    322         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
    323         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    324         I '$D(ZTAB) S ZTAB="C0CA"
    325         Q $P(@ZTAB@(ZFN),"^",1)
    326 ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    327         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
    328         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    329         I '$D(ZTAB) S ZTAB="C0CA"
    330         Q $P(@ZTAB@(ZFN),"^",2)
    331 ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    332         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
    333         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    334         I '$D(ZTAB) S ZTAB="C0CA"
    335         Q $P($G(@ZTAB@(ZFN)),"^",3)
    336         ;
    337 ZVALUEI(ZFN,ZTAB)       ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
    338         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
    339         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    340         I '$D(ZTAB) S ZTAB="C0CA"
    341         Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
    342         ;
     1C0CRNFRPC   ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
     2 ;;1.0;C0C;;Dec 9, 2009;
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "This is the Reference Name Format (RNF) RPC Library ",!
     21 W !
     22 Q
     23 ;
     24 ;This routine will be mirroring C0CRNF and transform the output
     25 ;of the tags into an RPC friendly format
     26 ;The tags will be exactly as they are in C0CRNF
     27FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
     28 ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE
     29 ;RETURN FORMAT:
     30 ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS
     31 ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER"
     32 ;
     33 ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
     34 ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625"
     35 ;
     36 ;FORMAT APPEARS TO BE:
     37 ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER"
     38 ;
     39 ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
     40 S DEBUG=0
     41 ;SET RETURN VALUE
     42 S C0CFRTN=$NA(^TMP("C0CRNF",$J))
     43 K @C0CFRTN
     44 ;RUN WRAPPED CALL
     45 D FIELDS^C0CRNF("C0CRTN",C0CFILE)
     46 S J=""
     47 S I=1
     48 ;FORMAT RETURN
     49 F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
     50 . S @C0CFRTN@(I)=J_"^"_C0CRTN(J)
     51 . S I=I+1
     52 S @C0CFRTN@(0)=I-1
     53 ;CLEAN UP
     54 K J,I
     55 Q
     56 ;
     57GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME
     58 ; GRTN IS PASSED BY NAME
     59 ;
     60 ; OLD TAG DO NOT USE!
     61 Q
     62 ;
     63GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP
     64 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
     65 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     66 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
     67 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     68 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
     69 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     70 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     71 ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     72 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
     73 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
     74 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
     75 ; GREF IS THE VALUE FOR THE INDEX
     76 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     77 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
     78 ;
     79 ;
     80 ;RETURN FORMAT:
     81 ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)"
     82 ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)"
     83 ;
     84 ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
     85 ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268"
     86 ;C0CRNFGETN("1U4N")="2^.0905^H5369"
     87 ;C0CRNFGETN("1U4N","I")="^^H5369"
     88 ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26"
     89 ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326"
     90 ;
     91 ;FORMAT APPEARS TO BE:
     92 ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ"
     93 ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE"
     94 ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE"
     95 ;
     96 ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
     97 S DEBUG=0
     98 ;SET RETURN VALUE
     99 S C0CGRTN=$NA(^TMP("C0CRNF",$J))
     100 K @C0CGRTN
     101 ;RUN WRAPPED CALL
     102 D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN))
     103 S J=""
     104 S I=1
     105 ;FORMAT RETURN
     106 F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
     107 . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE
     108 . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE
     109 . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA
     110 . ;TEST TO SEE IF INTERNAL DATA EXISTS
     111 . I $D(C0CRTN(J,"I"))=1 D
     112 . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3
     113 . S I=I+1
     114 S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0)
     115 ;CLEAN UP
     116 K J,I
     117 Q
     118 ;
     119GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
     120 ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
     121 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
     122 ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
     123 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     124 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
     125 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     126 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
     127 ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     128 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     129 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     130 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     131 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
     132 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
     133 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
     134 ; GREF IS THE VALUE FOR THE INDEX
     135 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     136 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
     137 ;
     138 ;
     139 N GIEN,GF
     140 S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
     141 I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
     142 E  D  ; WE ARE USING AN INDEX
     143 . ;N ZG
     144 . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
     145 . I ZG'="" D  ;
     146 . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
     147 . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
     148 . . E  S GIEN="" ; NOT FOUND IN INDEX
     149 . E  S GIEN="" ;
     150 ;W "IEN: ",GIEN,!
     151 ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
     152 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
     153 E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
     154 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
     155 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     156 K C0CTMP
     157 D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
     158 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
     159 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
     160 S (C0CI,C0CJ)=""
     161 F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
     162 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
     163 . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
     164 . . ;W C0CJ," ",C0CI,!
     165 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
     166 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
     167 . . I C0CVALUE["C0CTMP" D  ; WP FIELD
     168 . . . N ZT,ZWP S ZWP=0 ;ITERATOR
     169 . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
     170 . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
     171 . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
     172 . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
     173 . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
     174 . . . . S C0CVALUE=C0CVALUE_ZT ;
     175 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
     176 . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
     177 I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
     178 . S C0CI=""
     179 . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
     180 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
     181 Q
     182 ;
     183GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES
     184 ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     185 ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
     186 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     187 ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
     188 ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
     189 ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     190 ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     191 ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     192 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     193 ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
     194 ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
     195 ; .. OF THE FILE WILL BE USED
     196 ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
     197 ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
     198 ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
     199 ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
     200 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     201 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
     202 ;N GATMP,GAI,GAF
     203 S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
     204 I '$D(GAIDX) S GAIDX="" ;DEFAULT
     205 I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
     206 I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
     207 W GAF,!
     208 W $O(@GAF@(0)) ;
     209 S GAI=0 ;ITERATOR
     210 F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
     211 . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
     212 . N GAX S GAX=0
     213 . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
     214 . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
     215 Q
     216 ;
     217ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX
     218 ;
     219 S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
     220 S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
     221 Q
     222 ;
     223RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
     224 ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
     225 ; RNSTY IS STYLE OF THE OUTPUT -
     226 ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
     227 ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
     228 ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
     229 N RNR,RNC ;ROW ROOT,COL ROOT
     230 N RNI,RNJ,RNX
     231 I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
     232 I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
     233 E  D VN(RNRTN,RNIN) ;
     234 Q
     235 ;
     236NV(RNRTN,RNIN) ;
     237 S RNR=$NA(@RNIN@("F"))
     238 S RNC=$NA(@RNIN@("V"))
     239 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
     240 S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
     241 S RNI=""
     242 F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
     243 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
     244 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     245 D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
     246 S RNI=""
     247 F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
     248 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
     249 . S RNJ=""
     250 . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
     251 . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
     252 . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
     253 . . E  S RNX=RNX_"," ; NUL COLUMN
     254 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     255 . D PUSH^GPLXPATH(RNRTN,RNX)
     256 Q
     257 ;
     258VN(RNRTN,RNIN) ;
     259 S RNR=$NA(@RNIN@("V"))
     260 S RNC=$NA(@RNIN@("F"))
     261 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
     262 S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
     263 S RNI=""
     264 F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
     265 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
     266 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     267 D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
     268 S RNI=""
     269 F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
     270 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
     271 . S RNJ=""
     272 . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
     273 . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
     274 . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
     275 . . E  S RNX=RNX_"," ; NUL COLUMN
     276 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     277 . D PUSH^GPLXPATH(RNRTN,RNX)
     278 Q
     279 ;
     280READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
     281 ;
     282 Q $$FTG^%ZISH(PATH,NAME,GLB,1)
     283 ;
     284FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV
     285 ;
     286 ;N G1,G2
     287 I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
     288 S G1=$NA(^TMP($J,"C0CCSV",1))
     289 S G2=$NA(^TMP($J,"C0CCSV",2))
     290 D GETN2(G1,FNUM) ; GET THE MATRIX
     291 D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
     292 K @G1
     293 D FILEOUT(G2,"FILE_"_FNUM_".csv")
     294 K @G2
     295 Q
     296 ;
     297FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE
     298 ;
     299 W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR"))
     300 Q
     301 ;
     302FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
     303 ;
     304 N C0CF
     305 S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
     306 S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
     307 I C0CF["()" S C0CF=$P(C0CF,"()",1)
     308 Q C0CF
     309 ;
     310SKIP ;
     311 N TXT,DIERR
     312 S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
     313 I $D(DIERR) D CLEAN^DILF Q
     314 W "  report_text:",!  ;Progress Note Text
     315 N LN S LN=0
     316 F  S LN=$O(TXT(LN)) Q:'LN  D
     317 . W "    text"_LN_": "_TXT(LN),!
     318 . Q
     319 Q
     320 ;
     321ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     322 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
     323 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     324 I '$D(ZTAB) S ZTAB="C0CA"
     325 Q $P(@ZTAB@(ZFN),"^",1)
     326ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     327 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
     328 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     329 I '$D(ZTAB) S ZTAB="C0CA"
     330 Q $P(@ZTAB@(ZFN),"^",2)
     331ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     332 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
     333 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     334 I '$D(ZTAB) S ZTAB="C0CA"
     335 Q $P($G(@ZTAB@(ZFN)),"^",3)
     336 ;
     337ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
     338 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
     339 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     340 I '$D(ZTAB) S ZTAB="C0CA"
     341 Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
     342 ;

  • ccr/branches/ohum/p/C0CRPMS.m

    r1330 r1332  
    1 C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
    2         ;;0.1;CCDCCR;;JUL 16,2008;Build 1
    3         ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "NO ENTRY FROM TOP",!
    21         Q
    22         ;
    23 DISPLAY ; RUN THE PCC DISPLAY ROUTINE
    24         D ^APCDDISP
    25         Q
    26         ;
    27 VTYPES  ;
    28         D GETN2^C0CRNF("G1",9999999.07)
    29         ZWR G1
    30         Q
    31         ;
    32 VISITS(C0CDFN,C0CCNT)   ;LIST VISIT DATES FOR PATIENT DFN
    33         ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL
    34         I '$D(C0CCNT) S C0CCNT=999999999
    35         N G,GN
    36         S G="" S GN=0
    37         F  S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT)  D  ;
    38         . S GN=GN+1
    39         . W $$FMDTOUTC^C0CUTIL(9999999-G),!
    40         Q
    41         ;
    42 VISITS2(C0CDFN,C0CCNT)  ;SECOND VERSION USING NEXTV
    43         ;
    44         N C0CG,GN
    45         S C0CG=""
    46         S GN=0
    47         I '$D(C0CCNT) S C0CCNT=99999999
    48         F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT)  D  ;
    49         . S GN=GN+1
    50         . W $$FMDTOUTC^C0CUTIL(C0CG),!
    51         Q
    52         ;
    53 NEXTV(C0CDFN,C0CVDT)    ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE
    54         ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST
    55         ; RECENT VISIT
    56         N G
    57         S G=C0CVDT
    58         I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX
    59         S G=$O(^AUPNVSIT("AA",C0CDFN,G))
    60         I G="" Q ""
    61         E  Q 9999999-G
    62         ;
    63 GETV(C0CDFN,C0CVDT)     ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL,
    64         ; GET MOST RECENT VISIT
    65         N C0CG
    66         I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"")
    67         S APCDVLDT=C0CVDT
    68         S APCDPAT=C0CDFN
    69         D ^APCDVLK
    70         D ^APCDVD
    71         ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
    72         Q
    73         ;
    74 GETNV(C0CDFN)   ;GET MANY VISITS
    75         ;
    76         S APCDPAT=C0CDFN ;
    77         N C0CG S C0CG=""
    78         F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG=""  D  ; LOOP BACKWARD THROUGH VISITS
    79         . W C0CG,"    ",$$FMDTOUTC^C0CUTIL(C0CG),!
    80         . S APCDVLDT=C0CG
    81         . D ^APCDVLK
    82         . D ^APCDVD
    83         . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
    84         Q
    85         ;
    86 GETTBL(C0CTBL)  ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE
    87         ;
    88         N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL))
    89         N C0CG S C0CG=""
    90         N C0CQ S C0CQ=0
    91         F  S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="")  D  ;
    92         . W "PAT: ",C0CG,!
    93         . D GETNV^C0CRPMS(C0CG)
    94         . K X R X
    95         . I X="Q" S C0CQ=1 ; QUIT IF Q
    96         Q
    97         ;
    98 CMPDRG  ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
    99         ;
    100         S C0CZI=0 ;
    101         F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
    102         . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
    103         . ;W "C0CZI:",C0CZI
    104         . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
    105         . . ;W " C0CZJ:",C0CZJ
    106         . . N C0CZN,C0CZV ;
    107         . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
    108         . . ;W " C0CZN:",C0CZN,!
    109         . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
    110         . . I $D(C0CZV) D  ;FOUND A MATCH
    111         . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN
    112         . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV")
    113         . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO)
    114         . . . W C0CVO,!
    115         Q
    116         ;
    117 CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
    118         ;
    119         S C0CZI=0 ;
    120         F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
    121         . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
    122         . W "C0CZI:",C0CZI
    123         . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
    124         . . W " C0CZJ:",C0CZJ
    125         . . N C0CZN,C0CZV ;
    126         . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
    127         . . W " C0CZN:",C0CZN,!
    128         . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
    129         . . I $D(C0CZV) D  ;FOUND A MATCH
    130         . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN
    131         . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),!
    132         Q
    133         ;
     1C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
     2 ;;0.1;CCDCCR;;JUL 16,2008;Build 7
     3 ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "NO ENTRY FROM TOP",!
     21 Q
     22 ;
     23DISPLAY ; RUN THE PCC DISPLAY ROUTINE
     24 D ^APCDDISP
     25 Q
     26 ;
     27VTYPES ;
     28 D GETN2^C0CRNF("G1",9999999.07)
     29 ZWR G1
     30 Q
     31 ;
     32VISITS(C0CDFN,C0CCNT) ;LIST VISIT DATES FOR PATIENT DFN
     33 ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL
     34 I '$D(C0CCNT) S C0CCNT=999999999
     35 N G,GN
     36 S G="" S GN=0
     37 F  S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT)  D  ;
     38 . S GN=GN+1
     39 . W $$FMDTOUTC^C0CUTIL(9999999-G),!
     40 Q
     41 ;
     42VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV
     43 ;
     44 N C0CG,GN
     45 S C0CG=""
     46 S GN=0
     47 I '$D(C0CCNT) S C0CCNT=99999999
     48 F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT)  D  ;
     49 . S GN=GN+1
     50 . W $$FMDTOUTC^C0CUTIL(C0CG),!
     51 Q
     52 ;
     53NEXTV(C0CDFN,C0CVDT) ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE
     54 ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST
     55 ; RECENT VISIT
     56 N G
     57 S G=C0CVDT
     58 I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX
     59 S G=$O(^AUPNVSIT("AA",C0CDFN,G))
     60 I G="" Q ""
     61 E  Q 9999999-G
     62 ;
     63GETV(C0CDFN,C0CVDT) ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL,
     64 ; GET MOST RECENT VISIT
     65 N C0CG
     66 I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"")
     67 S APCDVLDT=C0CVDT
     68 S APCDPAT=C0CDFN
     69 D ^APCDVLK
     70 D ^APCDVD
     71 ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
     72 Q
     73 ;
     74GETNV(C0CDFN) ;GET MANY VISITS
     75 ;
     76 S APCDPAT=C0CDFN ;
     77 N C0CG S C0CG=""
     78 F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG=""  D  ; LOOP BACKWARD THROUGH VISITS
     79 . W C0CG,"    ",$$FMDTOUTC^C0CUTIL(C0CG),!
     80 . S APCDVLDT=C0CG
     81 . D ^APCDVLK
     82 . D ^APCDVD
     83 . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
     84 Q
     85 ;
     86GETTBL(C0CTBL) ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE
     87 ;
     88 N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL))
     89 N C0CG S C0CG=""
     90 N C0CQ S C0CQ=0
     91 F  S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="")  D  ;
     92 . W "PAT: ",C0CG,!
     93 . D GETNV^C0CRPMS(C0CG)
     94 . K X R X
     95 . I X="Q" S C0CQ=1 ; QUIT IF Q
     96 Q
     97 ;
     98CMPDRG ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
     99 ;
     100 S C0CZI=0 ;
     101 F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
     102 . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
     103 . ;W "C0CZI:",C0CZI
     104 . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
     105 . . ;W " C0CZJ:",C0CZJ
     106 . . N C0CZN,C0CZV ;
     107 . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
     108 . . ;W " C0CZN:",C0CZN,!
     109 . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
     110 . . I $D(C0CZV) D  ;FOUND A MATCH
     111 . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN
     112 . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV")
     113 . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO)
     114 . . . W C0CVO,!
     115 Q
     116 ;
     117CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
     118 ;
     119 S C0CZI=0 ;
     120 F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
     121 . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
     122 . W "C0CZI:",C0CZI
     123 . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
     124 . . W " C0CZJ:",C0CZJ
     125 . . N C0CZN,C0CZV ;
     126 . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
     127 . . W " C0CZN:",C0CZN,!
     128 . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
     129 . . I $D(C0CZV) D  ;FOUND A MATCH
     130 . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN
     131 . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),!
     132 Q
     133 ;

  • ccr/branches/ohum/p/C0CRXN.m

    r1330 r1332  
    11C0CRXN    ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CRXNRD.m

    r1330 r1332  
    1 C0CRXNRD        ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         W "No entry from top" Q
    4 IMPORT(PATH)   
    5         I PATH="" QUIT
    6         D READSRC(PATH),READCON(PATH),READNDC(PATH)
    7         QUIT
    8         ;
    9 DELFILED(FN)    ; Delete file data; PEP procedure; only for RxNorm files
    10         ; FN is Filenumber passed by Value
    11         QUIT:$E(FN,1,3)'=176  ; Quit if not RxNorm files
    12         D CLEAN^DILF ; Clean FM variables
    13         N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
    14         N ZERO S ZERO=@ROOT@(0) ; Save zero node
    15         S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
    16         K @ROOT ; Kill the file -- so sad!
    17         S @ROOT@(0)=ZERO ; It riseth again!
    18         QUIT
    19 GETLINES(PATH,FILENAME) ; Get number of lines in a file
    20         D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    21         U IO
    22         N I
    23         F I=1:1 R LINE Q:$$STATUS^%ZISH
    24         D CLOSE^%ZISH("FILE")
    25         Q I-1
    26 READCON(PATH,INCRES)    ; Open and read concepts file: RXNCONSO.RRF; EP
    27         ; PATH ByVal, path of RxNorm files
    28         ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
    29         I PATH="" QUIT
    30         S INCRES=+$G(INCRES) ; if not passed, becomes zero.
    31         N FILENAME S FILENAME="RXNCONSO.RRF"
    32         D DELFILED(176.001) ; delete data
    33         N LINES S LINES=$$GETLINES(PATH,FILENAME)
    34         D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    35         IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
    36         N C0CCOUNT
    37         F C0CCOUNT=1:1 D  Q:$$STATUS^%ZISH
    38         . U IO
    39         . N LINE R LINE
    40         . IF $$STATUS^%ZISH QUIT
    41         . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
    42         . N RXCUI,RXAUI,SAB,TTY,CODE,STR  ; Fileman fields numbers below
    43         . S RXCUI=$P(LINE,"|",1)        ; .01
    44         . S RXAUI=$P(LINE,"|",8)        ; 1
    45         . S SAB=$P(LINE,"|",12) ; 2
    46         . ; If the source is a restricted source, decide what to do based on what's asked.
    47         . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
    48         . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
    49         . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
    50         . ; If user didn't ask to include restricted sources, and the source is restricted, then quit
    51         . I 'INCRES,RESTRIC QUIT
    52         . S TTY=$P(LINE,"|",13) ; 3
    53         . S CODE=$P(LINE,"|",14)        ; 4
    54         . S STR=$P(LINE,"|",15) ; 5
    55         . ; Remove embedded "^"
    56         . S STR=$TR(STR,"^")
    57         . ; Convert STR into an array of 80 characters on each line
    58         . N STRLINE S STRLINE=$L(STR)\80+1
    59         . ; In each line, chop 80 characters off, reset STR to be the rest
    60         . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
    61         . ; Now, construct the FDA array
    62         . N RXNFDA
    63         . S RXNFDA(176.001,"+1,",.01)=RXCUI
    64         . S RXNFDA(176.001,"+1,",1)=RXAUI
    65         . S RXNFDA(176.001,"+1,",2)=SAB
    66         . S RXNFDA(176.001,"+1,",3)=TTY
    67         . S RXNFDA(176.001,"+1,",4)=CODE
    68         . N RXNIEN S RXNIEN(1)=C0CCOUNT
    69         . D UPDATE^DIE("","RXNFDA","RXNIEN")
    70         . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
    71         . ; Now, file WP field STR
    72         . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR))
    73 EX      D CLOSE^%ZISH("FILE")
    74         QUIT
    75 READNDC(PATH)   ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF
    76         I PATH="" QUIT
    77         N FILENAME S FILENAME="RXNSAT.RRF"
    78         D DELFILED(176.002) ; delete data
    79         N LINES S LINES=$$GETLINES(PATH,FILENAME)
    80         D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    81         IF POP W "Error reading file..., Please check...",! G EX2
    82         F C0CCOUNT=1:1 Q:$$STATUS^%ZISH  D
    83         . U IO
    84         . N LINE R LINE
    85         . IF $$STATUS^%ZISH QUIT
    86         . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
    87         . IF LINE'["NDC|RXNORM"  QUIT
    88         . ; Otherwise, we are good to go
    89         . N RXCUI,NDC ; Fileman fields below
    90         . S RXCUI=$P(LINE,"|",1)        ; .01
    91         . S NDC=$P(LINE,"|",11) ; 2
    92         . ; Using classic call to update.
    93         . N DIC,X,DA,DR
    94         . K DO
    95         . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC
    96         . D FILE^DICN
    97         . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2
    98 EX2     D CLOSE^%ZISH("FILE")
    99         QUIT
    100 READSRC(PATH)   ; Open the read RxNorm Sources file: RXNSAB.RRF
    101         I PATH="" QUIT
    102         N FILENAME S FILENAME="RXNSAB.RRF"
    103         D DELFILED(176.003) ; delete data
    104         D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    105         IF POP W "Error reading file..., Please check...",! G EX3
    106         F I=1:1 Q:$$STATUS^%ZISH  D
    107         . U IO
    108         . N LINE R LINE
    109         . IF $$STATUS^%ZISH QUIT
    110         . U $P W I,! U IO  ; Write I to the screen, then go back to reading the file
    111         . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
    112         . S VCUI=$P(LINE,"|",1)        ; .01
    113         . S RCUI=$P(LINE,"|",2)        ; 2
    114         . S VSAB=$P(LINE,"|",3)        ; 3
    115         . S RSAB=$P(LINE,"|",4)        ; 4
    116         . S SON=$P(LINE,"|",5)         ; 5
    117         . S SF=$P(LINE,"|",6)          ; 6
    118         . S SVER=$P(LINE,"|",7)        ; 7
    119         . S SRL=$P(LINE,"|",14)         ; 14
    120         . S SCIT=$P(LINE,"|",25)       ; 25
    121         . ; Remove embedded "^"
    122         . S SCIT=$TR(SCIT,"^")
    123         . ; Convert SCIT into an array of 80 characters on each line
    124         . ; In each line, chop 80 characters off, reset SCIT to be the rest
    125         . N SCITLINE S SCITLINE=$L(SCIT)\80+1
    126         . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
    127         . ; Now, construct the FDA array
    128         . N RXNFDA
    129         . S RXNFDA(176.003,"+"_I_",",.01)=VCUI
    130         . S RXNFDA(176.003,"+"_I_",",2)=RCUI
    131         . S RXNFDA(176.003,"+"_I_",",3)=VSAB
    132         . S RXNFDA(176.003,"+"_I_",",4)=RSAB
    133         . S RXNFDA(176.003,"+"_I_",",5)=SON
    134         . S RXNFDA(176.003,"+"_I_",",6)=SF
    135         . S RXNFDA(176.003,"+"_I_",",7)=SVER
    136         . S RXNFDA(176.003,"+"_I_",",14)=SRL
    137         . D UPDATE^DIE("","RXNFDA")
    138         . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
    139         . ; Now, file WP field SCIT
    140         . D WP^DIE(176.003,I_",",25,,$NA(SCIT))
    141 EX3     D CLOSE^%ZISH("FILE")
    142         Q
    143        
     1C0CRXNRD ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
     2 ;;0.1;C0C;nopatch;noreleasedate
     3 W "No entry from top" Q
     4IMPORT(PATH)
     5 I PATH="" QUIT
     6 D READSRC(PATH),READCON(PATH),READNDC(PATH)
     7 QUIT
     8 ;
     9DELFILED(FN) ; Delete file data; PEP procedure; only for RxNorm files
     10 ; FN is Filenumber passed by Value
     11 QUIT:$E(FN,1,3)'=176  ; Quit if not RxNorm files
     12 D CLEAN^DILF ; Clean FM variables
     13 N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
     14 N ZERO S ZERO=@ROOT@(0) ; Save zero node
     15 S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
     16 K @ROOT ; Kill the file -- so sad!
     17 S @ROOT@(0)=ZERO ; It riseth again!
     18 QUIT
     19GETLINES(PATH,FILENAME) ; Get number of lines in a file
     20 D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     21 U IO
     22 N I
     23 F I=1:1 R LINE Q:$$STATUS^%ZISH
     24 D CLOSE^%ZISH("FILE")
     25 Q I-1
     26READCON(PATH,INCRES) ; Open and read concepts file: RXNCONSO.RRF; EP
     27 ; PATH ByVal, path of RxNorm files
     28 ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
     29 I PATH="" QUIT
     30 S INCRES=+$G(INCRES) ; if not passed, becomes zero.
     31 N FILENAME S FILENAME="RXNCONSO.RRF"
     32 D DELFILED(176.001) ; delete data
     33 N LINES S LINES=$$GETLINES(PATH,FILENAME)
     34 D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     35 IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
     36 N C0CCOUNT
     37 F C0CCOUNT=1:1 D  Q:$$STATUS^%ZISH
     38 . U IO
     39 . N LINE R LINE
     40 . IF $$STATUS^%ZISH QUIT
     41 . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
     42 . N RXCUI,RXAUI,SAB,TTY,CODE,STR  ; Fileman fields numbers below
     43 . S RXCUI=$P(LINE,"|",1)       ; .01
     44 . S RXAUI=$P(LINE,"|",8)       ; 1
     45 . S SAB=$P(LINE,"|",12)        ; 2
     46 . ; If the source is a restricted source, decide what to do based on what's asked.
     47 . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
     48 . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
     49 . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
     50 . ; If user didn't ask to include restricted sources, and the source is restricted, then quit
     51 . I 'INCRES,RESTRIC QUIT
     52 . S TTY=$P(LINE,"|",13)        ; 3
     53 . S CODE=$P(LINE,"|",14)       ; 4
     54 . S STR=$P(LINE,"|",15)        ; 5
     55 . ; Remove embedded "^"
     56 . S STR=$TR(STR,"^")
     57 . ; Convert STR into an array of 80 characters on each line
     58 . N STRLINE S STRLINE=$L(STR)\80+1
     59 . ; In each line, chop 80 characters off, reset STR to be the rest
     60 . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
     61 . ; Now, construct the FDA array
     62 . N RXNFDA
     63 . S RXNFDA(176.001,"+1,",.01)=RXCUI
     64 . S RXNFDA(176.001,"+1,",1)=RXAUI
     65 . S RXNFDA(176.001,"+1,",2)=SAB
     66 . S RXNFDA(176.001,"+1,",3)=TTY
     67 . S RXNFDA(176.001,"+1,",4)=CODE
     68 . N RXNIEN S RXNIEN(1)=C0CCOUNT
     69 . D UPDATE^DIE("","RXNFDA","RXNIEN")
     70 . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
     71 . ; Now, file WP field STR
     72 . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR))
     73EX D CLOSE^%ZISH("FILE")
     74 QUIT
     75READNDC(PATH) ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF
     76 I PATH="" QUIT
     77 N FILENAME S FILENAME="RXNSAT.RRF"
     78 D DELFILED(176.002) ; delete data
     79 N LINES S LINES=$$GETLINES(PATH,FILENAME)
     80 D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     81 IF POP W "Error reading file..., Please check...",! G EX2
     82 F C0CCOUNT=1:1 Q:$$STATUS^%ZISH  D
     83 . U IO
     84 . N LINE R LINE
     85 . IF $$STATUS^%ZISH QUIT
     86 . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
     87 . IF LINE'["NDC|RXNORM"  QUIT
     88 . ; Otherwise, we are good to go
     89 . N RXCUI,NDC ; Fileman fields below
     90 . S RXCUI=$P(LINE,"|",1)       ; .01
     91 . S NDC=$P(LINE,"|",11)        ; 2
     92 . ; Using classic call to update.
     93 . N DIC,X,DA,DR
     94 . K DO
     95 . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC
     96 . D FILE^DICN
     97 . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2
     98EX2 D CLOSE^%ZISH("FILE")
     99 QUIT
     100READSRC(PATH) ; Open the read RxNorm Sources file: RXNSAB.RRF
     101 I PATH="" QUIT
     102 N FILENAME S FILENAME="RXNSAB.RRF"
     103 D DELFILED(176.003) ; delete data
     104 D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     105 IF POP W "Error reading file..., Please check...",! G EX3
     106 F I=1:1 Q:$$STATUS^%ZISH  D
     107 . U IO
     108 . N LINE R LINE
     109 . IF $$STATUS^%ZISH QUIT
     110 . U $P W I,! U IO  ; Write I to the screen, then go back to reading the file
     111 . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
     112 . S VCUI=$P(LINE,"|",1)        ; .01
     113 . S RCUI=$P(LINE,"|",2)        ; 2
     114 . S VSAB=$P(LINE,"|",3)        ; 3
     115 . S RSAB=$P(LINE,"|",4)        ; 4
     116 . S SON=$P(LINE,"|",5)         ; 5
     117 . S SF=$P(LINE,"|",6)          ; 6
     118 . S SVER=$P(LINE,"|",7)        ; 7
     119 . S SRL=$P(LINE,"|",14)                ; 14
     120 . S SCIT=$P(LINE,"|",25)       ; 25
     121 . ; Remove embedded "^"
     122 . S SCIT=$TR(SCIT,"^")
     123 . ; Convert SCIT into an array of 80 characters on each line
     124 . ; In each line, chop 80 characters off, reset SCIT to be the rest
     125 . N SCITLINE S SCITLINE=$L(SCIT)\80+1
     126 . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
     127 . ; Now, construct the FDA array
     128 . N RXNFDA
     129 . S RXNFDA(176.003,"+"_I_",",.01)=VCUI
     130 . S RXNFDA(176.003,"+"_I_",",2)=RCUI
     131 . S RXNFDA(176.003,"+"_I_",",3)=VSAB
     132 . S RXNFDA(176.003,"+"_I_",",4)=RSAB
     133 . S RXNFDA(176.003,"+"_I_",",5)=SON
     134 . S RXNFDA(176.003,"+"_I_",",6)=SF
     135 . S RXNFDA(176.003,"+"_I_",",7)=SVER
     136 . S RXNFDA(176.003,"+"_I_",",14)=SRL
     137 . D UPDATE^DIE("","RXNFDA")
     138 . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
     139 . ; Now, file WP field SCIT
     140 . D WP^DIE(176.003,I_",",25,,$NA(SCIT))
     141EX3 D CLOSE^%ZISH("FILE")
     142 Q
     143

  • ccr/branches/ohum/p/C0CSNOA.m

    r1330 r1332  
    1 C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4         ;Licensed under the terms of the GNU General Public License.
    5         ;See attached copy of the License.
    6         ;
    7         ;This program is free software; you can redistribute it and/or modify
    8         ;it under the terms of the GNU General Public License as published by
    9         ;the Free Software Foundation; either version 2 of the License, or
    10         ;(at your option) any later version.
    11         ;
    12         ;This program is distributed in the hope that it will be useful,
    13         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    14         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15         ;GNU General Public License for more details.
    16         ;
    17         ;You should have received a copy of the GNU General Public License along
    18         ;with this program; if not, write to the Free Software Foundation, Inc.,
    19         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    20         ;
    21         ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES
    22         ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD
    23         ; USING THE VISTA LEXICON ^LEX
    24         ;
    25 ANALYZE(BEGIEN,IENCNT)  ; SNOMED RETRIEVAL ANALYSIS ROUTINE
    26            ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD
    27            ; TO RESUME AT NEXT DRUG, USE BEGIEN=""
    28            ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST
    29            ;
    30            N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR
    31            N CCRGLO
    32            D ASETUP ; SET UP VARIABLES AND GLOBALS
    33            D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
    34            I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME
    35            S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
    36            S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD
    37            I SNOIEN="" S SNOIEN=RESUME
    38            I +SNOIEN=0 D  Q  ; AT THE END OF THE ALLERGY LIST
    39            . W "END OF DRUG LIST, CALL RESET^C0CSNOA",!
    40            F SNOI=1:1:IENCNT  D  Q:+SNOIEN=0  ; FOR IENCNT NUMBER OF PATIENTS OR END
    41            . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR
    42            . W SNOIEN,@GMRBASE@(SNOIEN,0),!
    43            . N SNORTN,TTERM ; RETURN ARRAY
    44            . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY"
    45            . D TEXTRPC(.SNORTN,TTERM)
    46            . I $D(SNORTN) ZWR SNORTN
    47            . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS
    48            . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)
    49            . ;
    50            . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
    51            . ;
    52            . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
    53            . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG
    54            . ;
    55            . N CATNAME,CATTBL
    56            . S CATNAME=""
    57            . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY
    58            . ; W "CATEGORY NAME: ",CATNAME,!
    59            . ;
    60            . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD
    61            . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN
    62            ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL"))
    63            Q
    64            ;
    65 TEXTRPC(ORTN,ITEXT)     ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN
    66         ;
    67         ;N TTMP
    68         W ITEXT,!
    69         S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN")
    70         Q
    71         ;
    72 ASETUP  ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL
    73              I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO"))
    74              I '$D(@SNOBASE) S @SNOBASE=""
    75              I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82))
    76              I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE
    77              S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES
    78              Q
    79              ;
    80 AINIT   ; INITIALIZE ATTRIBUTE TABLE
    81              I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
    82              K @SNOTBL
    83              D APUSH^C0CRIMA(SNOTBL,"CODE")
    84              D APUSH^C0CRIMA(SNOTBL,"NOCODE")
    85              D APUSH^C0CRIMA(SNOTBL,"MULTICODE")
    86              D APUSH^C0CRIMA(SNOTBL,"SUBMULTI")
    87              D APUSH^C0CRIMA(SNOTBL,"DONE")
    88              Q
    89 APOST(PRSLT,PTBL,PVAL)  ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
    90            ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
    91            ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES
    92            ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
    93            I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
    94            N USETBL
    95            I '$D(@SNOBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
    96            . W "ERROR NO SUCH TABLE",!
    97            S USETBL=@SNOBASE@("TABLES",PTBL)
    98            S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
    99            Q
    100 SETATTR(SDFN)   ; SET ATTRIBUTES BASED ON VARS
    101            N SBASE,SATTR
    102            S SBASE=$NA(@SNOBASE@("VARS",SDFN))
    103            D APOST("SATTR","SNOTBL","DONE")
    104            I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE")
    105            I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE")
    106            Q SATTR  ; C0C
    107            I $D(@SBASE@("PROBLEMS",1)) D  ;
    108            . D APOST("SATTR","SNOTBL","PROBLEMS")
    109            . ; W "POSTING PROBLEMS",!
    110            I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS")
    111            I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
    112            . D APOST("SATTR","SNOTBL","MEDS")
    113            . N ZR,ZI
    114            . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
    115            . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
    116            . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
    117            . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES
    118            . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
    119            D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
    120            ; W "ATTRIBUTES: ",SATTR,!
    121            Q SATTR
    122            ;
    123 RESET   ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES
    124            K ^TMP("C0CSNO","RESUME")
    125            K ^TMP("C0CSNO")
    126            Q
    127            ;
    128 CLIST   ; LIST THE CATEGORIES
    129            ;
    130            I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
    131            N CLBASE,CLNUM,ZI,CLIDX
    132            S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS"))
    133            S CLNUM=@CLBASE@(0)
    134            F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
    135            . S CLIDX=@CLBASE@(ZI)
    136            . W "(",$P(@CLBASE@(CLIDX),"^",1)
    137            . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
    138            . W CLIDX,!
    139            ; D PARY^C0CXPATH(CLBASE)
    140            Q
    141            ;
    142 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR)     ; ADD PATIENTS TO CATEGORIES
    143            ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
    144            ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
    145            ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
    146            ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
    147            ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
    148            ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
    149            ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
    150            ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
    151            ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
    152            ; NUMBER IE CTBL_X(CDFN)=""
    153            ;
    154            ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
    155            S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
    156            ; W "CBASE: ",CCTBL,!
    157            ;
    158            I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
    159            . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
    160            . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
    161            . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
    162            . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
    163            . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
    164            . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
    165            ;
    166            S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
    167            S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
    168            S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
    169            ;
    170            S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
    171            ;
    172            S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
    173            ; W "IENS BASE: ",CPATLIST,!
    174            S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
    175            ;
    176            Q
    177            ;
    178 REUSE   ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE
    179         ;
    180         D ASETUP
    181         D AINIT
    182         N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH
    183         S SAVBASE=$NA(^TMP("C0CSAV","VARS"))
    184         S SNOI=""
    185         F  D  Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST
    186         . S SNOI=$O(@SAVBASE@(SNOI))
    187         . S SNOJ=@SAVBASE@(SNOI)
    188         . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1)
    189         . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE
    190         . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON
    191         . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE
    192         . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE
    193         . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE
    194         . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,!
    195         . W SNOK,!
    196         . W SNOJ,!
    197         Q
    198         ;
     1C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4 ;Licensed under the terms of the GNU General Public License.
     5 ;See attached copy of the License.
     6 ;
     7 ;This program is free software; you can redistribute it and/or modify
     8 ;it under the terms of the GNU General Public License as published by
     9 ;the Free Software Foundation; either version 2 of the License, or
     10 ;(at your option) any later version.
     11 ;
     12 ;This program is distributed in the hope that it will be useful,
     13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15 ;GNU General Public License for more details.
     16 ;
     17 ;You should have received a copy of the GNU General Public License along
     18 ;with this program; if not, write to the Free Software Foundation, Inc.,
     19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     20 ;
     21 ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES
     22 ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD
     23 ; USING THE VISTA LEXICON ^LEX
     24 ;
     25ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE
     26    ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD
     27    ; TO RESUME AT NEXT DRUG, USE BEGIEN=""
     28    ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST
     29    ;
     30    N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR
     31    N CCRGLO
     32    D ASETUP ; SET UP VARIABLES AND GLOBALS
     33    D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
     34    I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME
     35    S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
     36    S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD
     37    I SNOIEN="" S SNOIEN=RESUME
     38    I +SNOIEN=0 D  Q  ; AT THE END OF THE ALLERGY LIST
     39    . W "END OF DRUG LIST, CALL RESET^C0CSNOA",!
     40    F SNOI=1:1:IENCNT  D  Q:+SNOIEN=0  ; FOR IENCNT NUMBER OF PATIENTS OR END
     41    . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR
     42    . W SNOIEN,@GMRBASE@(SNOIEN,0),!
     43    . N SNORTN,TTERM ; RETURN ARRAY
     44    . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY"
     45    . D TEXTRPC(.SNORTN,TTERM)
     46    . I $D(SNORTN) ZWR SNORTN
     47    . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS
     48    . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)
     49    . ;
     50    . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
     51    . ;
     52    . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
     53    . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG
     54    . ;
     55    . N CATNAME,CATTBL
     56    . S CATNAME=""
     57    . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY
     58    . ; W "CATEGORY NAME: ",CATNAME,!
     59    . ;
     60    . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD
     61    . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN
     62    ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL"))
     63    Q
     64    ;
     65TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN
     66 ;
     67 ;N TTMP
     68 W ITEXT,!
     69 S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN")
     70 Q
     71 ;
     72ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL
     73      I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO"))
     74      I '$D(@SNOBASE) S @SNOBASE=""
     75      I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82))
     76      I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE
     77      S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES
     78      Q
     79      ;
     80AINIT ; INITIALIZE ATTRIBUTE TABLE
     81      I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
     82      K @SNOTBL
     83      D APUSH^C0CRIMA(SNOTBL,"CODE")
     84      D APUSH^C0CRIMA(SNOTBL,"NOCODE")
     85      D APUSH^C0CRIMA(SNOTBL,"MULTICODE")
     86      D APUSH^C0CRIMA(SNOTBL,"SUBMULTI")
     87      D APUSH^C0CRIMA(SNOTBL,"DONE")
     88      Q
     89APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
     90    ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
     91    ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES
     92    ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
     93    I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
     94    N USETBL
     95    I '$D(@SNOBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
     96    . W "ERROR NO SUCH TABLE",!
     97    S USETBL=@SNOBASE@("TABLES",PTBL)
     98    S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
     99    Q
     100SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS
     101    N SBASE,SATTR
     102    S SBASE=$NA(@SNOBASE@("VARS",SDFN))
     103    D APOST("SATTR","SNOTBL","DONE")
     104    I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE")
     105    I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE")
     106    Q SATTR  ; C0C
     107    I $D(@SBASE@("PROBLEMS",1)) D  ;
     108    . D APOST("SATTR","SNOTBL","PROBLEMS")
     109    . ; W "POSTING PROBLEMS",!
     110    I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS")
     111    I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
     112    . D APOST("SATTR","SNOTBL","MEDS")
     113    . N ZR,ZI
     114    . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
     115    . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
     116    . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
     117    . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES
     118    . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
     119    D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
     120    ; W "ATTRIBUTES: ",SATTR,!
     121    Q SATTR
     122    ;
     123RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES
     124    K ^TMP("C0CSNO","RESUME")
     125    K ^TMP("C0CSNO")
     126    Q
     127    ;
     128CLIST ; LIST THE CATEGORIES
     129    ;
     130    I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
     131    N CLBASE,CLNUM,ZI,CLIDX
     132    S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS"))
     133    S CLNUM=@CLBASE@(0)
     134    F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
     135    . S CLIDX=@CLBASE@(ZI)
     136    . W "(",$P(@CLBASE@(CLIDX),"^",1)
     137    . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
     138    . W CLIDX,!
     139    ; D PARY^C0CXPATH(CLBASE)
     140    Q
     141    ;
     142CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES
     143    ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
     144    ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
     145    ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
     146    ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
     147    ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
     148    ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
     149    ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
     150    ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
     151    ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
     152    ; NUMBER IE CTBL_X(CDFN)=""
     153    ;
     154    ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
     155    S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
     156    ; W "CBASE: ",CCTBL,!
     157    ;
     158    I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
     159    . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
     160    . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
     161    . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
     162    . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
     163    . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
     164    . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
     165    ;
     166    S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
     167    S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
     168    S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
     169    ;
     170    S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
     171    ;
     172    S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
     173    ; W "IENS BASE: ",CPATLIST,!
     174    S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
     175    ;
     176    Q
     177    ;
     178REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE
     179 ;
     180 D ASETUP
     181 D AINIT
     182 N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH
     183 S SAVBASE=$NA(^TMP("C0CSAV","VARS"))
     184 S SNOI=""
     185 F  D  Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST
     186 . S SNOI=$O(@SAVBASE@(SNOI))
     187 . S SNOJ=@SAVBASE@(SNOI)
     188 . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1)
     189 . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE
     190 . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON
     191 . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE
     192 . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE
     193 . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE
     194 . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,!
     195 . W SNOK,!
     196 . W SNOJ,!
     197 Q
     198 ;

  • ccr/branches/ohum/p/C0CSOAP.m

    r1330 r1332  
    11C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CSUB1.m

    r1330 r1332  
    11C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CSYS.m

    r1330 r1332  
    11C0CSYS  ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    44        ; General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CUNIT.m

    r1330 r1332  
    11C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008 George Lilly. Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CUTIL.m

    r1330 r1332  
    11C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2         ;;0.1;C0C;;Jun 15, 2008;Build 1
     2        ;;0.1;C0C;;Jun 15, 2008;Build 38
    33        ;Copyright 2008-2009 Sam Habiel & George Lilly. 
    44        ;Licensed under the terms of the GNU
    … …  
    136136        ;
    137137RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
    138         ;
    139 CODE(ZVUID)     ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
    140         ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
    141         N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
    142         I $G(ZVUID)="" Q ""
    143         I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
    144         N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
    145         S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
    146         N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
    147         S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
    148         I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
    149         Q ZRSLT
    150         ;
    151 NISTMAP(ZRXN)   ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
    152         ; CONFORM TO NIST REQUIREMENTS
    153         ;INPATIENT CERTIFICATION
    154         I ZRXN=309362 S ZRXN=213169
    155         I ZRXN=855318 S ZRXN=855320
    156         I ZRXN=197361 S ZRXN=212549
    157         ;OUTPATIENT CERTIFICATION
    158         I ZRXN=310534 S ZRXN=205875
    159         I ZRXN=617312 S ZRXN=617314
    160         I ZRXN=310429 S ZRXN=200801
    161         I ZRXN=628953 S ZRXN=628958
    162         I ZRXN=745679 S ZRXN=630208
    163         I ZRXN=311564 S ZRXN=979334
    164         I ZRXN=836343 S ZRXN=836370
    165         Q ZRXN
    166         ;
     138 ;
     139CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
     140 ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
     141 N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
     142 I $G(ZVUID)="" Q ""
     143 I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
     144 N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
     145 S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
     146 N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
     147 S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
     148 I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
     149 Q ZRSLT
     150 ;
     151NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
     152 ; CONFORM TO NIST REQUIREMENTS
     153 ;INPATIENT CERTIFICATION
     154 I ZRXN=309362 S ZRXN=213169
     155 I ZRXN=855318 S ZRXN=855320
     156 I ZRXN=197361 S ZRXN=212549
     157 ;OUTPATIENT CERTIFICATION
     158 I ZRXN=310534 S ZRXN=205875
     159 I ZRXN=617312 S ZRXN=617314
     160 I ZRXN=310429 S ZRXN=200801
     161 I ZRXN=628953 S ZRXN=628958
     162 I ZRXN=745679 S ZRXN=630208
     163 I ZRXN=311564 S ZRXN=979334
     164 I ZRXN=836343 S ZRXN=836370
     165 Q ZRXN
     166 ;
    167167RPMS()  ; Are we running on an RPMS system rather than Vista?
    168168        Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service

  • ccr/branches/ohum/p/C0CVA200.m

    r1330 r1332  
    11C0CVA200        ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008 Sam Habiel.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CVIT2.m

    r1330 r1332  
    11C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2         ;;1.0;C0C;;Feb 16, 2010;Build 1
     2        ;;1.0;C0C;;Feb 16, 2010;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.

  • ccr/branches/ohum/p/C0CVITAL.m

    r1330 r1332  
    11C0CVITAL        ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.
    … …  
    7272        . . I DEBUG W $P(VITPTMP,U,4),!
    7373        . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
    74                . . ;B  ;gpl
    75                . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
    76                . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
    77                . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1"
     74        . . ;B  ;gpl
     75        . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
     76        . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
     77        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1"
    7878        . . I $P(VITPTMP,U,2)="HT" D
    7979        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    … …  
    203203        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    204204        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
    205                . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
    206                . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
     205        . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
     206        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
    207207        . . S VITARYTMP=$NA(@VITTARYTMP@(J))
    208208        . . K @VITARYTMP

  • ccr/branches/ohum/p/C0CVOBX1.m

    r1330 r1332  
    1 LA7VOBX1        ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 1
    3         ; JMC - mods to check for IHS V LAB file
    4         ;
    5 CH      ; Observation/Result segment for "CH" subscript results.
    6         ; Called by LA7VOBX
    7         ;
    8         N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
    9         ;
    10         ; "CH" subscript requires a dataname
    11         I '$G(LRSB) Q
    12         ;
    13         ; get result node from LR global.
    14         S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
    15         S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
    16         ;
    17         ; Check if test is OK to send - (O)utput or (B)oth
    18         S LA7X=$P(LA7VAL,"^",12)
    19         I LA7X]"","BO"'[LA7X Q
    20         I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
     1LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
     3 ; JMC - mods to check for IHS V LAB file
     4 ;
     5CH ; Observation/Result segment for "CH" subscript results.
     6 ; Called by LA7VOBX
     7 ;
     8 N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
     9 ;
     10 ; "CH" subscript requires a dataname
     11 I '$G(LRSB) Q
     12 ;
     13 ; get result node from LR global.
     14 S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
     15 S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
     16 ;
     17 ; Check if test is OK to send - (O)utput or (B)oth
     18 S LA7X=$P(LA7VAL,"^",12)
     19 I LA7X]"","BO"'[LA7X Q
     20 I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
    2121        ;
    2222        ; If no result NLT or LOINC try to determine from file #60
    … …  
    2727        I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
    2828        ; No result NLT code - log error
    29         I $P($P(LA7VAL,"^",3),"!",2)="" D
    30         . N LA7X
    31         . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
    32         . D CREATE^LA7LOG(36)
    33         ;
    34         ; something missing - No NLT code, etc.
    35         I LA7VAL="" Q
    36         ;
    37         ; Check for missing units/reference ranges
    38         S LA7X=$P(LA7VAL,"^",5)
    39         ;
    40         ; Results missing units, lookup in file #60
    41         I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
    42         ;
    43         ; If results missing reference ranges, use values from file #60.
    44         I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
    45         . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
    46         . S $P(LA7X,"!",2)=$P(LA7Y,"^")
    47         . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
    48         . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
    49         . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
    50         ; Use therapeutic low/high if low/high missing.
    51         I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
    52         . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
    53         . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
    54         ;
    55         ; Evaluate low/high reference ranges in case M code in these fields.
    56         S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
    57         F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
    58         . S @("X="_$P(LA7X,"!",LA7I))
    59         . S $P(LA7X,"!",LA7I)=X
    60         ;
    61         ; Put units/reference ranges back in variable LA7VAL
    62         S $P(LA7VAL,"^",5)=LA7X
    63         ;
    64         ; Initialize OBX segment
    65         S LA7OBX(0)="OBX"
    66         S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
    67         ;
    68         ; Value type
    69         S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
    70         ;
    71         ; Observation identifer
    72         ; build alternate code based on dataname from file #63 in case it's needed
    73         S LA7X=$P(LA7VAL,"^",3)
    74         S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
    75         S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
    76         ;
    77         ; Test value
    78         S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
    79         ;
    80         ; Units - remove leading and trailing spaces
    81         S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
    82         S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
    83         ;
    84         ; Reference range
    85         S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
    86         ;
    87         ; Abnormal flags
    88         S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
    89         ;
    90         ; "P"artial or "F"inal results
    91         S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
    92         ;
    93         ; Observation date/time - collection date/time per HL7 standard
    94         I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
    95         ;
    96         S LA7DIV=$P(LA7VAL,"^",9)
    97         I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
    98         ;
    99         ; Facility that performed the testing
    100         S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
    101         ;
    102         ; Person that verified the test
    103         S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
    104         ;
    105         ; Observation method
    106         S LA7X=$P($P(LA7VAL,"^",3),"!",4)
    107         I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
    108         ;
    109         ; Equipment entity identifier
    110         I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
    111         ;
    112         D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
    113         ;
    114         Q
     29 I $P($P(LA7VAL,"^",3),"!",2)="" D
     30 . N LA7X
     31 . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
     32 . D CREATE^LA7LOG(36)
     33 ;
     34 ; something missing - No NLT code, etc.
     35 I LA7VAL="" Q
     36 ;
     37 ; Check for missing units/reference ranges
     38 S LA7X=$P(LA7VAL,"^",5)
     39 ;
     40 ; Results missing units, lookup in file #60
     41 I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
     42 ;
     43 ; If results missing reference ranges, use values from file #60.
     44 I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
     45 . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
     46 . S $P(LA7X,"!",2)=$P(LA7Y,"^")
     47 . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
     48 . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
     49 . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
     50 ; Use therapeutic low/high if low/high missing.
     51 I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
     52 . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
     53 . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
     54 ;
     55 ; Evaluate low/high reference ranges in case M code in these fields.
     56 S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
     57 F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
     58 . S @("X="_$P(LA7X,"!",LA7I))
     59 . S $P(LA7X,"!",LA7I)=X
     60 ;
     61 ; Put units/reference ranges back in variable LA7VAL
     62 S $P(LA7VAL,"^",5)=LA7X
     63 ;
     64 ; Initialize OBX segment
     65 S LA7OBX(0)="OBX"
     66 S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
     67 ;
     68 ; Value type
     69 S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
     70 ;
     71 ; Observation identifer
     72 ; build alternate code based on dataname from file #63 in case it's needed
     73 S LA7X=$P(LA7VAL,"^",3)
     74 S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
     75 S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
     76 ;
     77 ; Test value
     78 S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
     79 ;
     80 ; Units - remove leading and trailing spaces
     81 S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
     82 S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
     83 ;
     84 ; Reference range
     85 S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
     86 ;
     87 ; Abnormal flags
     88 S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
     89 ;
     90 ; "P"artial or "F"inal results
     91 S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
     92 ;
     93 ; Observation date/time - collection date/time per HL7 standard
     94 I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
     95 ;
     96 S LA7DIV=$P(LA7VAL,"^",9)
     97 I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
     98 ;
     99 ; Facility that performed the testing
     100 S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
     101 ;
     102 ; Person that verified the test
     103 S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
     104 ;
     105 ; Observation method
     106 S LA7X=$P($P(LA7VAL,"^",3),"!",4)
     107 I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
     108 ;
     109 ; Equipment entity identifier
     110 I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
     111 ;
     112 D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
     113 ;
     114 Q

  • ccr/branches/ohum/p/C0CVORU.m

    r1330 r1332  
    1 C0C7VORU        ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1
    3         ;
    4 EN(LA)  ; called from C0CVLAB
    5         ; variables
    6         ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
    7         ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
    8         ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
    9         ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
    10         ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
    11         ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
    12         ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
    13         ; LA("LRDFN") - IEN in LAB DATA file (#63)
    14         ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
    15         ; LA("AUTO-INST") - Auto-Instrument
    16         ;
    17         N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
    18         ;
    19         S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
    20         I $G(PRIMARY)'="" D
    21         . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
    22         . S PRIMARY=$P(PRIMARY,U,3)
    23         . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
    24         ;
    25         I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D  Q
    26         . ; need to add error logging when no entry in 63.
    27         ;
    28         ; Get zeroth node of entry in #63.
    29         S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    30         S LA7NLT=$G(LA("NLT"))
    31         ;
    32         S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
    33         S LA7NTESN=0
    34         D ORC
    35         ;
    36         I $G(LA("SUB"))="CH" D CH
    37         ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
    38         ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
    39         Q
    40         ;
    41         ;
    42 CH      ; Build segments for "CH" subscript
    43         ;
    44         D OBR
    45         D NTE
    46         S LA7OBXSN=0
    47         D OBX
    48         ;
    49         Q
    50         ;
    51         ;
    52 ORC     ; Build ORC segment
    53         ;
    54         N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
    55         ;
    56         S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    57         ;
    58         S ORC(0)="ORC"
    59         ;
    60         ; Order control
    61         S ORC(1)=$$ORC1^LA7VORC("RE")
    62         ;
    63         ; Remote UID
    64         S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
    65         ;
    66         ; Host UID
    67         S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
    68         ;
    69         ; Return shipping manifest if found
    70         S LA7SM="",LA7696=0
    71         I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
    72         I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
    73         I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
    74         ;
    75         ; Order status
    76         ; DoD/CHCS requires ORC-5 valued otherwise will not process message
    77         I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
    78         ;
    79         ; Ordering provider
    80         S (LA7X,LA7Y)=""
    81         ; "CH" subscript stores requesting provider and requesting div/location.
    82         I LA("SUB")="CH" D
    83         . N LA7J
    84         . S LA7J=$P(LA763(0),"^",13)
    85         . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
    86         . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
    87         . S LA7X=$P(LA763(0),"^",10)
    88         ;
    89         ; Other subscripts only store requesting provider
    90         I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
    91         ; Get default institution from MailMan Site Parameters file
    92         I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    93         S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
    94         ;
    95         ; Entering organization
    96         S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
    97         ;
    98         D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
    99         D FILESEG^LA7VHLU(GBL,.LA7DATA)
    100         ;
    101         ; Check for flag to only build message but do not file
    102         I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
    103         ;
    104         Q
    105         ;
    106         ;
    107 OBR     ;Observation Request segment for Lab Order
    108         ;
    109         N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
    110         ;
    111         ; Retrieve placer's OBR information stored in #69.6
    112         D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
    113         ;
    114         ; Initialize OBR segment
    115         S OBR(0)="OBR"
    116         S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
    117         ;
    118         ; Remote UID
    119         S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
    120         ;
    121         ; Host UID
    122         S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
    123         ;
    124         ; Universal service ID, build from info stored in #69.6
    125         S LA7X=""
    126         I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
    127         E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
    128         ;
    129         ; Collection D/T
    130         S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
    131         ;
    132         ; Specimen action code
    133         ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
    134         I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
    135         ;
    136         ; Infection Warning
    137         S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
    138         ;
    139         ; Lab Arrival Time
    140         ; "CH" subscript does not store lab arrival time, use collection time.
    141         ; Other subscripts do store lab arrival time (date/time received).
    142         I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
    143         I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
    144         ;
    145         ; Specimen source
    146         S (LA761,LA762)=""
    147         I "CHMI"[LA("SUB") D
    148         . S LA761=$P(LA763(0),U,5)
    149         . I LA761="" D CREATE^LA7LOG(27)
    150         . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
    151         S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
    152         ;
    153         ; Ordering provider
    154         S (LA7X,LA7Y)=""
    155         ; "CH" subscript stores requesting provider and requesting div/location.
    156         I LA("SUB")="CH" D
    157         . N LA7J
    158         . S LA7J=$P(LA763(0),"^",13)
    159         . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
    160         . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
    161         . S LA7X=$P(LA763(0),"^",10)
    162         ;
    163         ; Other subscripts only store requesting provider
    164         I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
    165         ; Get default institution from MailMan Site Parameters file
    166         I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    167         S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
    168         ;
    169         ; Placer Field #1 (remote auto-inst)
    170         ; Build from info stored in #69.6
    171         I $G(LA7PLOBR("OBR-18"))'="" D
    172         . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
    173         ; Else build "auto instrument" if sending to VA facility
    174         I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
    175         . N LA7X
    176         . S LA7X(1)=LA("AUTO-INST")
    177         . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
    178         ;
    179         ; Placer Field #2
    180         I $G(LA7PLOBR("OBR-19"))'="" D
    181         . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
    182         ; Else build collecting UID if sending to VA facility
    183         I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
    184         . K LA7X
    185         . S LA7X(7)=LA("RUID")
    186         . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
    187         ;
    188         ; Filler Field #1
    189         ; Send file #63 ien info - used by HDR to track patient/specimen
    190         K LA7X
    191         S LA7X(1)=LA("LRDFN")
    192         S LA7X(2)=LA("SUB")
    193         S LA7X(3)=LA("LRIDT")
    194         S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
    195         ;
    196         ; Date Report Completed
    197         I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
    198         ;
    199         ; Diagnostic service id
    200         S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
    201         ;
    202         ; Parent Result and Parent
    203         I $D(LA7PARNT) D
    204         . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
    205         . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
    206         ;
    207         ; Principle result interpreter
    208         ; Get default institution from MailMan Site Parameters file
    209         I "CYEMMISP"[LA("SUB") D
    210         . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
    211         . E  S LA7X=$P(LA763(0),"^",2)
    212         . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    213         . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    214         ;
    215         ; Assistant result interpreter
    216         ; Get default institution from MailMan Site Parameters file
    217         I "EMSP"[LA("SUB") D
    218         . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    219         . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    220         ;
    221         ; Technician
    222         ; Get default institution from MailMan Site Parameters file
    223         I "CYEM"[LA("SUB") D
    224         . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    225         . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    226         ;
    227         ; Typist - VistA stores as free text
    228         ; Get default institution from MailMan Site Parameters file
    229         I "CYEMSP"[LA("SUB") D
    230         . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    231         . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    232         ;
    233         D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
    234         D FILESEG^LA7VHLU(GBL,.LA7DATA)
    235         ;
    236         ; Check for flag to only build message but do not file
    237         I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
    238         ;
    239         Q
    240         ;
    241         ;
    242 OBX     ;Observation/Result segment for Lab Results
    243         ;
    244         N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
    245         ;
    246         S LA7VTIEN=0
    247         F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
    248         . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
    249         . ; Build OBX segment
    250         . K LA7DATA
    251         . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
    252         . ; If OBX failed to build then don't store
    253         . I '$D(LA7DATA) Q
    254         . ;
    255         . D FILESEG^LA7VHLU(GBL,.LA7DATA)
    256         . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
    257         . ;
    258         . ; Send performing lab comment and interpretation from file #60
    259         . S LA7NTESN=0
    260         . I LA7NVAF=1 D PLC^LA7VORUA
    261         . D INTRP^LA7VORUA
    262         . ;
    263         . ; Mark result as sent - set to 1, if corrected results set to 2
    264         . I LA("SUB")="CH" D
    265         . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
    266         . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
    267         ;
    268         Q
    269         ;
    270         ;
    271 NTE     ; Build NTE segment
    272         ;
    273         D NTE^LA7VORUA
    274         Q
     1C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
     3 ;
     4EN(LA) ; called from C0CVLAB
     5 ; variables
     6 ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
     7 ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
     8 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
     9 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
     10 ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
     11 ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
     12 ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
     13 ; LA("LRDFN") - IEN in LAB DATA file (#63)
     14 ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
     15 ; LA("AUTO-INST") - Auto-Instrument
     16 ;
     17 N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
     18 ;
     19 S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
     20 I $G(PRIMARY)'="" D
     21 . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
     22 . S PRIMARY=$P(PRIMARY,U,3)
     23 . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
     24 ;
     25 I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D  Q
     26 . ; need to add error logging when no entry in 63.
     27 ;
     28 ; Get zeroth node of entry in #63.
     29 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     30 S LA7NLT=$G(LA("NLT"))
     31 ;
     32 S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
     33 S LA7NTESN=0
     34 D ORC
     35 ;
     36 I $G(LA("SUB"))="CH" D CH
     37 ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
     38 ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
     39 Q
     40 ;
     41 ;
     42CH ; Build segments for "CH" subscript
     43 ;
     44 D OBR
     45 D NTE
     46 S LA7OBXSN=0
     47 D OBX
     48 ;
     49 Q
     50 ;
     51 ;
     52ORC ; Build ORC segment
     53 ;
     54 N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
     55 ;
     56 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     57 ;
     58 S ORC(0)="ORC"
     59 ;
     60 ; Order control
     61 S ORC(1)=$$ORC1^LA7VORC("RE")
     62 ;
     63 ; Remote UID
     64 S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
     65 ;
     66 ; Host UID
     67 S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
     68 ;
     69 ; Return shipping manifest if found
     70 S LA7SM="",LA7696=0
     71 I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
     72 I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
     73 I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
     74 ;
     75 ; Order status
     76 ; DoD/CHCS requires ORC-5 valued otherwise will not process message
     77 I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
     78 ;
     79 ; Ordering provider
     80 S (LA7X,LA7Y)=""
     81 ; "CH" subscript stores requesting provider and requesting div/location.
     82 I LA("SUB")="CH" D
     83 . N LA7J
     84 . S LA7J=$P(LA763(0),"^",13)
     85 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
     86 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
     87 . S LA7X=$P(LA763(0),"^",10)
     88 ;
     89 ; Other subscripts only store requesting provider
     90 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
     91 ; Get default institution from MailMan Site Parameters file
     92 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     93 S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
     94 ;
     95 ; Entering organization
     96 S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
     97 ;
     98 D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
     99 D FILESEG^LA7VHLU(GBL,.LA7DATA)
     100 ;
     101 ; Check for flag to only build message but do not file
     102 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
     103 ;
     104 Q
     105 ;
     106 ;
     107OBR ;Observation Request segment for Lab Order
     108 ;
     109 N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
     110 ;
     111 ; Retrieve placer's OBR information stored in #69.6
     112 D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
     113 ;
     114 ; Initialize OBR segment
     115 S OBR(0)="OBR"
     116 S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
     117 ;
     118 ; Remote UID
     119 S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
     120 ;
     121 ; Host UID
     122 S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
     123 ;
     124 ; Universal service ID, build from info stored in #69.6
     125 S LA7X=""
     126 I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
     127 E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
     128 ;
     129 ; Collection D/T
     130 S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
     131 ;
     132 ; Specimen action code
     133 ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
     134 I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
     135 ;
     136 ; Infection Warning
     137 S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
     138 ;
     139 ; Lab Arrival Time
     140 ; "CH" subscript does not store lab arrival time, use collection time.
     141 ; Other subscripts do store lab arrival time (date/time received).
     142 I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
     143 I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
     144 ;
     145 ; Specimen source
     146 S (LA761,LA762)=""
     147 I "CHMI"[LA("SUB") D
     148 . S LA761=$P(LA763(0),U,5)
     149 . I LA761="" D CREATE^LA7LOG(27)
     150 . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
     151 S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
     152 ;
     153 ; Ordering provider
     154 S (LA7X,LA7Y)=""
     155 ; "CH" subscript stores requesting provider and requesting div/location.
     156 I LA("SUB")="CH" D
     157 . N LA7J
     158 . S LA7J=$P(LA763(0),"^",13)
     159 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
     160 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
     161 . S LA7X=$P(LA763(0),"^",10)
     162 ;
     163 ; Other subscripts only store requesting provider
     164 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
     165 ; Get default institution from MailMan Site Parameters file
     166 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     167 S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
     168 ;
     169 ; Placer Field #1 (remote auto-inst)
     170 ; Build from info stored in #69.6
     171 I $G(LA7PLOBR("OBR-18"))'="" D
     172 . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
     173 ; Else build "auto instrument" if sending to VA facility
     174 I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
     175 . N LA7X
     176 . S LA7X(1)=LA("AUTO-INST")
     177 . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
     178 ;
     179 ; Placer Field #2
     180 I $G(LA7PLOBR("OBR-19"))'="" D
     181 . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
     182 ; Else build collecting UID if sending to VA facility
     183 I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
     184 . K LA7X
     185 . S LA7X(7)=LA("RUID")
     186 . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
     187 ;
     188 ; Filler Field #1
     189 ; Send file #63 ien info - used by HDR to track patient/specimen
     190 K LA7X
     191 S LA7X(1)=LA("LRDFN")
     192 S LA7X(2)=LA("SUB")
     193 S LA7X(3)=LA("LRIDT")
     194 S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
     195 ;
     196 ; Date Report Completed
     197 I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
     198 ;
     199 ; Diagnostic service id
     200 S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
     201 ;
     202 ; Parent Result and Parent
     203 I $D(LA7PARNT) D
     204 . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
     205 . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
     206 ;
     207 ; Principle result interpreter
     208 ; Get default institution from MailMan Site Parameters file
     209 I "CYEMMISP"[LA("SUB") D
     210 . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
     211 . E  S LA7X=$P(LA763(0),"^",2)
     212 . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     213 . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     214 ;
     215 ; Assistant result interpreter
     216 ; Get default institution from MailMan Site Parameters file
     217 I "EMSP"[LA("SUB") D
     218 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     219 . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     220 ;
     221 ; Technician
     222 ; Get default institution from MailMan Site Parameters file
     223 I "CYEM"[LA("SUB") D
     224 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     225 . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     226 ;
     227 ; Typist - VistA stores as free text
     228 ; Get default institution from MailMan Site Parameters file
     229 I "CYEMSP"[LA("SUB") D
     230 . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     231 . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     232 ;
     233 D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
     234 D FILESEG^LA7VHLU(GBL,.LA7DATA)
     235 ;
     236 ; Check for flag to only build message but do not file
     237 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
     238 ;
     239 Q
     240 ;
     241 ;
     242OBX ;Observation/Result segment for Lab Results
     243 ;
     244 N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
     245 ;
     246 S LA7VTIEN=0
     247 F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
     248 . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
     249 . ; Build OBX segment
     250 . K LA7DATA
     251 . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
     252 . ; If OBX failed to build then don't store
     253 . I '$D(LA7DATA) Q
     254 . ;
     255 . D FILESEG^LA7VHLU(GBL,.LA7DATA)
     256 . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
     257 . ;
     258 . ; Send performing lab comment and interpretation from file #60
     259 . S LA7NTESN=0
     260 . I LA7NVAF=1 D PLC^LA7VORUA
     261 . D INTRP^LA7VORUA
     262 . ;
     263 . ; Mark result as sent - set to 1, if corrected results set to 2
     264 . I LA("SUB")="CH" D
     265 . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
     266 . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
     267 ;
     268 Q
     269 ;
     270 ;
     271NTE ; Build NTE segment
     272 ;
     273 D NTE^LA7VORUA
     274 Q

  • ccr/branches/ohum/p/C0CXEWD.m

    r1330 r1332  
    1 C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 TEST    ;
    23         D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
    24         Q
    25         ;
    26 TEST2   ;
    27         S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
    28         D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
    29         Q
    30         ;
    31 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX)      ; RECURSIVE ROUTINE TO POPULATE
    32         ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    33         ; THE XPATH ARRAY XPARY, PASSED BY NAME
    34         ; ZOID IS THE STARTING OID
    35         ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    36         ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    37         ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    38         I '$D(ZREDUX) S ZREDUX=""
    39         N NEWPATH
    40         N NEWNUM S NEWNUM=""
    41         I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    42         S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    43         I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    44         . N GT S GT=$P(NEWPATH,ZREDUX,2)
    45         . I GT'="" S NEWPATH=GT
    46         S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    47         N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    48         I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    49         E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    50         I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
    51         N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    52         I ZFRST'="" D  ; THERE IS A CHILD
    53         . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    54         . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
    55         N GNXT S GNXT=$$NXTSIB(ZOID)
    56         I GNXT'="" D  ; MOVE ON TO THE NEXT SIBLING
    57         . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
    58         Q
    59         ;
    60 PARSE(INXML,INDOC)      ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
    61         ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
    62         ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
    63         N ZR
    64         M ^CacheTempEWD($j)=@INXML ;
    65         S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
    66         Q ZR
    67         ;
    68 ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    69         N ZN
    70         S ZN=$$NXTSIB(ZOID)
    71         I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    72         Q 0
    73         ;
    74 DETAIL(ZRTN,ZOID)       ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
    75         N DET
    76         D getElementDetails^%zewdXPath(ZOID,.DET)
    77         M @ZRTN=DET
    78         Q
    79         ;
    80 ID(ZNAME)       ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
    81         Q $$getDocumentNode^%zewdDOM(ZNAME)
    82         ;
    83 NAME(ZOID)      ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
    84         Q $$getDocumentName^%zewdDOM(ZOID)
    85         ;
    86 FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    87         N GOID
    88         S GOID=ZOID
    89         S GOID=$$getFirstChild^%zewdDOM(GOID)
    90         I GOID="" Q ""
    91         I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
    92         Q GOID
    93         ;
    94 HASCHILD(ZOID)  ; RETURNS TRUE IF ZOID HAS CHILD NODES
    95         Q $$hasChildNodes^%zewdDOM(ZOID)
    96         ;
    97 CHILDREN(ZRTN,ZOID)     ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
    98         N childArray
    99         d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
    100         m @ZRTN=childArray
    101         q
    102         ;
    103 TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
    104         Q $$getName^%zewdDOM(ZOID)
    105         ;
    106 NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
    107         Q $$getNextSibling^%zewdDOM(ZOID)
    108         ;
    109 NXTCHLD(ZOID)   ; RETURNS THE NEXT CHILD IN PARENT ZPAR
    110         N GOID
    111         S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
    112         I GOID="" Q ""
    113         I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
    114         Q GOID
    115         ;
    116 PARENT(ZOID)    ; RETURNS PARENT OF ZOID
    117         Q $$getParentNode^%zewdDOM(ZOID)
    118         ;
    119 DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
    120         N ZT2
    121         S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
    122         M @ZT=ZT2
    123         Q
    124         ;Q $$getTextValue^%zewdXPath(ZOID)
    125         ;Q $$getData^%zewdDOM(ZOID,.ZT)
    126         ;
     1C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
     2 ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     22TEST ;
     23 D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
     24 Q
     25 ;
     26TEST2 ;
     27 S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
     28 D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
     29 Q
     30 ;
     31XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
     32 ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     33 ; THE XPATH ARRAY XPARY, PASSED BY NAME
     34 ; ZOID IS THE STARTING OID
     35 ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     36 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     37 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     38 I '$D(ZREDUX) S ZREDUX=""
     39 N NEWPATH
     40 N NEWNUM S NEWNUM=""
     41 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     42 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     43 I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     44 . N GT S GT=$P(NEWPATH,ZREDUX,2)
     45 . I GT'="" S NEWPATH=GT
     46 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     47 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     48 I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     49 E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     50 I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
     51 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     52 I ZFRST'="" D  ; THERE IS A CHILD
     53 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     54 . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
     55 N GNXT S GNXT=$$NXTSIB(ZOID)
     56 I GNXT'="" D  ; MOVE ON TO THE NEXT SIBLING
     57 . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
     58 Q
     59 ;
     60PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
     61 ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
     62 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
     63 N ZR
     64 M ^CacheTempEWD($j)=@INXML ;
     65 S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
     66 Q ZR
     67 ;
     68ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
     69 N ZN
     70 S ZN=$$NXTSIB(ZOID)
     71 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     72 Q 0
     73 ;
     74DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
     75 N DET
     76 D getElementDetails^%zewdXPath(ZOID,.DET)
     77 M @ZRTN=DET
     78 Q
     79 ;
     80ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
     81 Q $$getDocumentNode^%zewdDOM(ZNAME)
     82 ;
     83NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
     84 Q $$getDocumentName^%zewdDOM(ZOID)
     85 ;
     86FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
     87 N GOID
     88 S GOID=ZOID
     89 S GOID=$$getFirstChild^%zewdDOM(GOID)
     90 I GOID="" Q ""
     91 I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
     92 Q GOID
     93 ;
     94HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES
     95 Q $$hasChildNodes^%zewdDOM(ZOID)
     96 ;
     97CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
     98 N childArray
     99 d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
     100 m @ZRTN=childArray
     101 q
     102 ;
     103TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
     104 Q $$getName^%zewdDOM(ZOID)
     105 ;
     106NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
     107 Q $$getNextSibling^%zewdDOM(ZOID)
     108 ;
     109NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR
     110 N GOID
     111 S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
     112 I GOID="" Q ""
     113 I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
     114 Q GOID
     115 ;
     116PARENT(ZOID) ; RETURNS PARENT OF ZOID
     117 Q $$getParentNode^%zewdDOM(ZOID)
     118 ;
     119DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
     120 N ZT2
     121 S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
     122 M @ZT=ZT2
     123 Q
     124 ;Q $$getTextValue^%zewdXPath(ZOID)
     125 ;Q $$getData^%zewdDOM(ZOID,.ZT)
     126 ;

  • ccr/branches/ohum/p/C0CXPAT0.m

    r1330 r1332  
    11C0CXPAT0          ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.

  • ccr/branches/ohum/p/C0CXPATH.m

    r1330 r1332  
    11C0CXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
Note: See TracChangeset for help on using the changeset viewer.