Changeset 1336 for ccr/trunk/p/C0CUTIL.m


Ignore:
Timestamp:
Jan 4, 2012, 9:39:08 PM (12 years ago)
Author:
George Lilly
Message:

removed tabs

File:
1 edited

Legend:

Unmodified
Added
Removed

  • ccr/trunk/p/C0CUTIL.m

    r1331 r1336  
    1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2         ;;0.1;C0C;;Jun 15, 2008;Build 38
    3         ;Copyright 2008-2009 Sam Habiel & George Lilly. 
    4         ;Licensed under the terms of the GNU
    5         ;General Public License 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         W "No Entry at Top!"
    22         Q
    23         ;
    24 UUID()  ; thanks to Wally for this.
    25                N R,I,J,N
    26                S N="",R="" F  S N=N_$R(100000) Q:$L(N)>64
    27                F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1))
    28                Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32)
    29         ;
    30 OLDUUID()       ; GENERATE A RANDOM UUID (Version 4)
    31         N I,J,ZS
    32         S ZS="0123456789abcdef" S J=""
    33         F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1))
    34         Q J
    35         ;
    36 FMDTOUTC(DATE,FORMAT)   ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
    37         ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
    38         ; If not passed, or passed incorrectly, it's assumed that it is D.
    39         ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
    40         ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
    41         ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
    42         N UTC,Y,M,D,H,MM,S,OFF
    43         S Y=1700+$E(DATE,1,3)
    44         S M=$E(DATE,4,5)
    45         S D=$E(DATE,6,7)
    46         S H=$E(DATE,9,10)
    47         I $L(H)=1 S H="0"_H
    48         S MM=$E(DATE,11,12)
    49         I $L(MM)=1 S MM="0"_MM
    50         S S=$E(DATE,13,14)
    51         I $L(S)=1 S S="0"_S
    52         S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
    53         S OFFS=$E(OFF,1,1)
    54         S OFF0=$TR(OFF,"+-")
    55         S OFF1=$E(OFF0+10000,2,3)
    56         S OFF2=$E(OFF0+10000,4,5)
    57         S OFF=OFFS_OFF1_":"_OFF2
    58         ;S OFF2=$E(OFF,1,2) ;
    59         ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT
    60         ;S OFF3=$E(OFF,3,4) ;MINUTES
    61         ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3)
    62         ; If H, MM and S are empty, it means that the FM date didn't supply the time.
    63         ; In this case, set H, MM and S to "00"
    64         ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
    65         S:'$L(H) H="00"
    66         S:'$L(MM) MM="00"
    67         S:'$L(S) S="00"
    68         S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
    69         I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
    70         E  Q $P(UTC,"T")
    71         ;
    72 SORTDT(V1,V2,ORDR)      ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
    73         ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
    74         ; DATE AND TIME ORDER. DEFAULT IS FORWARD
    75         ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
    76         ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
    77         ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
    78         ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
    79         ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
    80         N VSRT ; TEMP FOR HASHING DATES
    81         N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
    82         S ZCNT=V2(0) ; COUNTING NUMBER OF DATES
    83         F ZI=1:1:ZCNT D  ; FOR EACH DATE IN THE ARRAY
    84         . I $D(V2(ZI)) D  ; IF THE DATE EXISTS
    85         . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE
    86         . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE
    87         . . ; W "DATE: ",ZP1," TIME: ",ZP2,!
    88         . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT
    89         N ZG
    90         S ZG=$Q(VSRT(""))
    91         F  D  Q:ZG=""  ;
    92         . ; W ZG,!
    93         . D PUSH^C0CXPATH("V1",@ZG)
    94         . S ZG=$Q(@ZG)
    95         I ORDR=-1 D  ; HAVE TO REVERSE ORDER
    96         . N ZG2
    97         . F ZI=1:1:V1(0) D  ; FOR EACH ELELMENT
    98         . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER
    99         . S ZG2(0)=V1(0)
    100         . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY
    101         Q ZCNT
    102         ;
    103 DA2SNO(RTN,DNAME)       ; LOOK UP DRUG ALLERGY CODE IN ^LEX
    104         ; RETURNS AN ARRAY RTN PASSED BY REFERENCE
    105         ; THIS ROUTINE CAN BE USED AS AN RPC
    106         ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY
    107         ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY
    108         ;
    109         N LEXIEN
    110         I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D  ; IEN FOUND FOR THIS DRUG
    111         . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON
    112         . W LEXIEN,!
    113         . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2
    114         . S RTN(0)=1 ; ONE THING RETURNED
    115         E  S RTN(0)=0 ; NOT FOUND
    116         Q
    117         ;
    118 DASNO(DANAME)   ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME
    119         ;
    120         N DARTN
    121         D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE
    122         I DARTN(0)>0 D  ; GOT RESULTS
    123         . W !,DARTN(1) ;PRINT THE SNOMED CODE
    124         E  W !,"NOT FOUND",!
    125         Q
    126         ;
    127 DASNALL(WHICH)  ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL
    128         ; ASSOCIATED SNOMED CODES
    129         N DASTMP,DASIEN,DASNO
    130         S DASTMP=""
    131         F  S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP=""  D  ; NAME OF MED
    132         . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED
    133         . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY
    134         . W DASTMP,"=",DASNO,! ; PRINT IT OUT
    135         Q
    136         ;
    137 RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
     1C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
     2 ;;0.1;C0C;;Jun 15, 2008;Build 38
     3 ;Copyright 2008-2009 Sam Habiel & George Lilly. 
     4 ;Licensed under the terms of the GNU
     5 ;General Public License 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 W "No Entry at Top!"
     22 Q
     23 ;
     24UUID()  ; thanks to Wally for this.
     25        N R,I,J,N
     26        S N="",R="" F  S N=N_$R(100000) Q:$L(N)>64
     27        F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1))
     28        Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32)
     29 ;
     30OLDUUID() ; GENERATE A RANDOM UUID (Version 4)
     31 N I,J,ZS
     32 S ZS="0123456789abcdef" S J=""
     33 F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1))
     34 Q J
     35 ;
     36FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
     37 ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
     38 ; If not passed, or passed incorrectly, it's assumed that it is D.
     39 ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
     40 ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
     41 ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
     42 N UTC,Y,M,D,H,MM,S,OFF
     43 S Y=1700+$E(DATE,1,3)
     44 S M=$E(DATE,4,5)
     45 S D=$E(DATE,6,7)
     46 S H=$E(DATE,9,10)
     47 I $L(H)=1 S H="0"_H
     48 S MM=$E(DATE,11,12)
     49 I $L(MM)=1 S MM="0"_MM
     50 S S=$E(DATE,13,14)
     51 I $L(S)=1 S S="0"_S
     52 S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
     53 S OFFS=$E(OFF,1,1)
     54 S OFF0=$TR(OFF,"+-")
     55 S OFF1=$E(OFF0+10000,2,3)
     56 S OFF2=$E(OFF0+10000,4,5)
     57 S OFF=OFFS_OFF1_":"_OFF2
     58 ;S OFF2=$E(OFF,1,2) ;
     59 ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT
     60 ;S OFF3=$E(OFF,3,4) ;MINUTES
     61 ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3)
     62 ; If H, MM and S are empty, it means that the FM date didn't supply the time.
     63 ; In this case, set H, MM and S to "00"
     64 ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
     65 S:'$L(H) H="00"
     66 S:'$L(MM) MM="00"
     67 S:'$L(S) S="00"
     68 S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
     69 I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
     70 E  Q $P(UTC,"T")
     71 ;
     72SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
     73 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
     74 ; DATE AND TIME ORDER. DEFAULT IS FORWARD
     75 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
     76 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
     77 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
     78 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
     79 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
     80 N VSRT ; TEMP FOR HASHING DATES
     81 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
     82 S ZCNT=V2(0) ; COUNTING NUMBER OF DATES
     83 F ZI=1:1:ZCNT D  ; FOR EACH DATE IN THE ARRAY
     84 . I $D(V2(ZI)) D  ; IF THE DATE EXISTS
     85 . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE
     86 . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE
     87 . . ; W "DATE: ",ZP1," TIME: ",ZP2,!
     88 . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT
     89 N ZG
     90 S ZG=$Q(VSRT(""))
     91 F  D  Q:ZG=""  ;
     92 . ; W ZG,!
     93 . D PUSH^C0CXPATH("V1",@ZG)
     94 . S ZG=$Q(@ZG)
     95 I ORDR=-1 D  ; HAVE TO REVERSE ORDER
     96 . N ZG2
     97 . F ZI=1:1:V1(0) D  ; FOR EACH ELELMENT
     98 . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER
     99 . S ZG2(0)=V1(0)
     100 . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY
     101 Q ZCNT
     102 ;
     103DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX
     104 ; RETURNS AN ARRAY RTN PASSED BY REFERENCE
     105 ; THIS ROUTINE CAN BE USED AS AN RPC
     106 ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY
     107 ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY
     108 ;
     109 N LEXIEN
     110 I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D  ; IEN FOUND FOR THIS DRUG
     111 . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON
     112 . W LEXIEN,!
     113 . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2
     114 . S RTN(0)=1 ; ONE THING RETURNED
     115 E  S RTN(0)=0 ; NOT FOUND
     116 Q
     117 ;
     118DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME
     119 ;
     120 N DARTN
     121 D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE
     122 I DARTN(0)>0 D  ; GOT RESULTS
     123 . W !,DARTN(1) ;PRINT THE SNOMED CODE
     124 E  W !,"NOT FOUND",!
     125 Q
     126 ;
     127DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL
     128 ; ASSOCIATED SNOMED CODES
     129 N DASTMP,DASIEN,DASNO
     130 S DASTMP=""
     131 F  S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP=""  D  ; NAME OF MED
     132 . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED
     133 . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY
     134 . W DASTMP,"=",DASNO,! ; PRINT IT OUT
     135 Q
     136 ;
     137RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
    138138 ;
    139139CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
    … …  
    165165 Q ZRXN
    166166 ;
    167 RPMS()  ; Are we running on an RPMS system rather than Vista?
    168         Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
    169 VISTA() ; Are we running on Vanilla Vista?
    170         Q $G(DUZ("AG"))="V" ; If User Agency is VA
    171 WV()    ; Are we running on WorldVista?
    172         Q $G(DUZ("AG"))="E" ; Code for WV.
    173 OV()    ; Are we running on OpenVista?
    174         Q $G(DUZ("AG"))="O" ; Code for OpenVista
    175        
     167RPMS() ; Are we running on an RPMS system rather than Vista?
     168 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
     169VISTA() ; Are we running on Vanilla Vista?
     170 Q $G(DUZ("AG"))="V" ; If User Agency is VA
     171WV() ; Are we running on WorldVista?
     172 Q $G(DUZ("AG"))="E" ; Code for WV.
     173OV() ; Are we running on OpenVista?
     174 Q $G(DUZ("AG"))="O" ; Code for OpenVista
     175 
Note: See TracChangeset for help on using the changeset viewer.