Changeset 1325 for ccr


Ignore:
Timestamp:
Dec 31, 2011, 12:08:05 AM (12 years ago)
Author:
George Lilly
Message:

latest ohum update

Location:
ccr/branches/ohum/p
Files:
1 added
47 edited

Legend:

Unmodified
Added
Removed

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

    r1206 r1325  
    11C0CACTOR  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CALERT  ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    5656 . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy
    5757 . N ALTCDE ; SNOMED CODE THE THE ALERT
    58  . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
     58 . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
    5959 . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ;
    6060 . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE
    … …  
    8181 . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT
    8282 . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM
    83  . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
    84  . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
     83 . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID
    8584 . I ACVUID'="" D  ; IF VUID IS NOT NULL
    86  . . S ZC=$$CODE^C0CUTIL(ACVUID)
    87  . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
    88  . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
    89  . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
     85 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID"
    9086 . E  D  ; IF REACTANT CODE VALUE IS NULL
    9187 . . I $G(DUZ("AG"))="I" D  ; IF WE ARE RUNNING ON RPMS
    … …  
    9490 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=""
    9591 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=""
    96  . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD
    97  . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS
    98  . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD
    99  . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD
    10092 . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW
    10193 . N ARTMP,ARIEN,ARDES,ARVUID

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

    r1206 r1325  
    11C0CBAT   ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CCCD   ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CCCR   ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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 3111222 To take inputs from user for date limits and notes
     29        D ^C0CVALID
     30        ;OHUM/RUT
    2831 D XPAT(DFN) ; EXPORT TO A FILE
    2932 Q
    … …  
    103106 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
    104107 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
    105  D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")
    106108 I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
    107109 ;
    … …  
    135137 D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
    136138 K ACTT,ACTT2
    137  ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
    138  ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
    139  ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
    140  ; gpl - turned off Comments for Certification
     139 D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
     140 D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
     141 D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
    141142 K CMTT,CMTT2
    142143 N TRIMI,J,DONE S DONE=0
    … …  
    166167 D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")")
    167168 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")")
     169 ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
    168170 ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    169  ; gpl - turned off Encounters for Certification
     171 I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
     172 ;OHUM/RUT
    170173 Q
    171174 ;

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

    r1206 r1325  
    11C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    792792 ;;</Name>
    793793 ;;</Person>
     794 ;;<IDs>
     795 ;;<Type>
     796 ;;<Text>@@IDTYPE@@</Text>
     797 ;;</Type>
     798 ;;<ID>@@ID@@</ID>
     799 ;;<IssuedBy>
     800 ;;<Description>
     801 ;;<Text>@@IDDESC@@</Text>
     802 ;;</Description>
     803 ;;</IssuedBy>
     804 ;;</IDs>
    794805 ;;<Specialty>
    795806 ;;<Text>@@ACTORSPECIALITY@@</Text>

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

    r1206 r1325  
    11C0CCMT  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
    2  ;;1.0;C0C;;May 21, 2010;Build 38
     2 ;;1.0;C0C;;May 21, 2010;Build 39
    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

    r1206 r1325  
    11C0CCPT ;;BSL;RETURN CPT DATA;
    2  ;Sequence Managers Software GPL;;;;;Build 38
     2 ;Sequence Managers Software GPL;;;;;Build 39
    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
    2124        S Z=""
    2225        F  S Z=$O(NOTE(Z)) Q:Z=""  D

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

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

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

    r1267 r1325  
    11C0CENC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
    2  ;;1.0;C0C;;May 21, 2010;Build 38
     2 ;;1.0;C0C;;May 21, 2010;Build 39
    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

    r1267 r1325  
    11C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
    2  ;;1.0;C0C;;May 19, 2009;
     2 ;;1.0;C0C;;May 19, 2009;Build 40
    33 ;
    44 ;
    … …  
    2222 ;
    2323CHECK ; Perform environment check
    24         ;
     24 ;
    2525 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
    2626 . D BMES("Terminal Device is not defined")
    … …  
    3434 . D BMES("You are not a valid user on this system")
    3535 . S XPDQUIT=2
    36         Q
    37         ;
    38         ;
     36 Q
     37 ;
     38 ;
    3939EXIT ;
    40         ;
    41         ;
     40 ;
     41 ;
    4242 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
    4343 D BMES("--- Environment Check is Ok ---")
    44         ;
     44 ;
    4545 Q
    46         ;
    47         ;
     46 ;
     47 ;
    4848PRE ;Pre-install entry point
    49         ;
    50         ; No action needed in pre-install
    51         D BMES("No action need for pre-install")
    52         ;
    53         Q
    54         ;
    55         ;
     49 ;
     50 ; No action needed in pre-install
     51 D BMES("No action need for pre-install")
     52 ;
     53 Q
     54 ;
     55 ;
    5656POST ;Post install
    57         ;
    58         ; Check for RPMS system with V LAB file.
    59         ;
    60         I $$VFILE^DILFD(9000010.09)'=1 Q
    61         ;
    62         S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
    63         S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
    64         S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
    65         S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
    66         S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
    67         S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
    68         S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
    69         ;
    70         Q
    71         ;
    72         ;
    73 POST1   ; Checkpoint call back entry point.
    74         ; Add new style ALR1 cross-reference to V LAB file.
    75         ;
    76         N MSG
    77         S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    78         D BMES(MSG)
    79         D ALR1^C0CLA7DD
    80         S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    81         D BMES(MSG)
    82         Q
    83         ;
    84         ;
    85 POST2   ; Checkpoint call back entry point.
    86         ; Add new style ALR2 cross-reference to V LAB file.
    87         ;
    88         N MSG
    89         S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    90         D BMES(MSG)
    91         D ALR2^C0CLA7DD
    92         S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    93         D BMES(MSG)
    94         Q
    95         ;
    96         ;
    97 POST3   ; Checkpoint call back entry point.
    98         ; Add new style ALR3 cross-reference to V LAB file.
    99         ;
    100         N MSG
    101         S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    102         D BMES(MSG)
    103         D ALR3^C0CLA7DD
    104         S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    105         D BMES(MSG)
    106         Q
    107         ;
    108         ;
    109 POST4   ; Checkpoint call back entry point.
    110         ; Add new style ALR4 cross-reference to V LAB file.
    111         ;
    112         N MSG
    113         S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    114         D BMES(MSG)
    115         D ALR4^C0CLA7DD
    116         S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    117         D BMES(MSG)
    118         Q
    119         ;
    120         ;
    121 POST5   ; Checkpoint call back entry point.
    122         ; Add new style ALR5 cross-reference to V LAB file.
    123         ;
    124         N MSG
    125         S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    126         D BMES(MSG)
    127         D ALR5^C0CLA7DD
    128         S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    129         D BMES(MSG)
    130         Q
    131         ;
    132         ;
     57 ;
     58 ; Check for RPMS system with V LAB file.
     59 ;
     60 I $$VFILE^DILFD(9000010.09)'=1 Q
     61 ;
     62 S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
     63 S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
     64 S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
     65 S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
     66 S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
     67 S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
     68 S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
     69 ;
     70 Q
     71 ;
     72 ;
     73POST1 ; Checkpoint call back entry point.
     74 ; Add new style ALR1 cross-reference to V LAB file.
     75 ;
     76 N MSG
     77 S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     78 D BMES(MSG)
     79 D ALR1^C0CLA7DD
     80 S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     81 D BMES(MSG)
     82 Q
     83 ;
     84 ;
     85POST2 ; Checkpoint call back entry point.
     86 ; Add new style ALR2 cross-reference to V LAB file.
     87 ;
     88 N MSG
     89 S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     90 D BMES(MSG)
     91 D ALR2^C0CLA7DD
     92 S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     93 D BMES(MSG)
     94 Q
     95 ;
     96 ;
     97POST3 ; Checkpoint call back entry point.
     98 ; Add new style ALR3 cross-reference to V LAB file.
     99 ;
     100 N MSG
     101 S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     102 D BMES(MSG)
     103 D ALR3^C0CLA7DD
     104 S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     105 D BMES(MSG)
     106 Q
     107 ;
     108 ;
     109POST4 ; Checkpoint call back entry point.
     110 ; Add new style ALR4 cross-reference to V LAB file.
     111 ;
     112 N MSG
     113 S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     114 D BMES(MSG)
     115 D ALR4^C0CLA7DD
     116 S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     117 D BMES(MSG)
     118 Q
     119 ;
     120 ;
     121POST5 ; Checkpoint call back entry point.
     122 ; Add new style ALR5 cross-reference to V LAB file.
     123 ;
     124 N MSG
     125 S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     126 D BMES(MSG)
     127 D ALR5^C0CLA7DD
     128 S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     129 D BMES(MSG)
     130 Q
     131 ;
     132 ;
    133133POST6 ; Checkpoint call back entry point.
    134         ; Check for RPMS system and determine LAB patch level
    135         ;  and need to load in C0C version of LA7 routines.
    136         ;
    137         N MSG
    138         ;
    139         ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
    140         I '$$PATCH^XPDUTL("LA*5.2*69") D
    141         . S MSG="This system missing LAB patch LA*5.2*69"
    142         . D BMES(MSG)
    143         . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
    144         . D BMES(MSG)
    145         . D LOAD("C0CQRY2")
    146         . D SAVE("C0CQRY2","LA7QRY2")
    147         ;
    148         ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
    149         I '$$PATCH^XPDUTL("LA*5.2*64") D
    150         . S MSG="This system missing LAB patch LA*5.2*64"
    151         . D BMES(MSG)
    152         . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
    153         . D BMES(MSG)
    154         . D LOAD("C0CVOBX1")
    155         . D SAVE("C0CVOBX1","LA7VOBX1")
    156         ;
    157         ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
    158         I '$$PATCH^XPDUTL("LA*5.2*68") D
    159         . S MSG="This system missing LAB patch LA*5.2*68"
    160         . D BMES(MSG)
    161         . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
    162         . D BMES(MSG)
    163         . D LOAD("C0CQRY1")
    164         . D SAVE("C0CQRY1","LA7QRY1")
    165         ;
    166         Q
    167         ;
    168         ;
    169 POST7   ; Checkpoint call back entry point.
    170         ;
    171         D REINDEX^C0CLA7DD
    172         ;
    173         Q
    174         ;
    175         ;
     134 ; Check for RPMS system and determine LAB patch level
     135 ;  and need to load in C0C version of LA7 routines.
     136 ;
     137 N MSG
     138 ;
     139 ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
     140 I '$$PATCH^XPDUTL("LA*5.2*69") D
     141 . S MSG="This system missing LAB patch LA*5.2*69"
     142 . D BMES(MSG)
     143 . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
     144 . D BMES(MSG)
     145 . D LOAD("C0CQRY2")
     146 . D SAVE("C0CQRY2","LA7QRY2")
     147 ;
     148 ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
     149 I '$$PATCH^XPDUTL("LA*5.2*64") D
     150 . S MSG="This system missing LAB patch LA*5.2*64"
     151 . D BMES(MSG)
     152 . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
     153 . D BMES(MSG)
     154 . D LOAD("C0CVOBX1")
     155 . D SAVE("C0CVOBX1","LA7VOBX1")
     156 ;
     157 ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
     158 I '$$PATCH^XPDUTL("LA*5.2*68") D
     159 . S MSG="This system missing LAB patch LA*5.2*68"
     160 . D BMES(MSG)
     161 . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
     162 . D BMES(MSG)
     163 . D LOAD("C0CQRY1")
     164 . D SAVE("C0CQRY1","LA7QRY1")
     165 ;
     166 Q
     167 ;
     168 ;
     169POST7 ; Checkpoint call back entry point.
     170 ;
     171 D REINDEX^C0CLA7DD
     172 ;
     173 Q
     174 ;
     175 ;
    176176BMES(STR) ; Write BMES^XPDUTL statements
    177         ;
    178         D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
    179         ;
    180         Q
    181         ;
    182         ;
    183 LOAD(X) ; load routine X
    184         N %N,DIF,XCNP
    185         K ^TMP($J,X)
    186         S DIF="^TMP($J,X,",XCNP=0
    187         X ^%ZOSF("LOAD")
    188         Q
    189         ;
    190         ;
    191 SAVE(OLD,NEW)   ; restore routine X
    192         N %,DIE,X,XCM,XCN,XCS
    193         S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
    194         X ^%ZOSF("SAVE")
    195         Q
     177 ;
     178 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
     179 ;
     180 Q
     181 ;
     182 ;
     183LOAD(X) ; load routine X
     184 N %N,DIF,XCNP
     185 K ^TMP($J,X)
     186 S DIF="^TMP($J,X,",XCNP=0
     187 X ^%ZOSF("LOAD")
     188 Q
     189 ;
     190 ;
     191SAVE(OLD,NEW) ; restore routine X
     192 N %,DIE,X,XCM,XCN,XCS
     193 S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
     194 X ^%ZOSF("SAVE")
     195 Q

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

    r1267 r1325  
    7474 N ZT,ZDFN
    7575 S ZT=$$URLTOKEN^C0CEWD(sessid)
    76  ;S ^TMP("GPL")=ZT
    77  d trace^%zewdAPI("*********************ZT="_ZT)
     76 S ^TMP("GPL")=ZT
    7877 S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
    7978 S ^TMP("GPL","DFN")=ZDFN

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

    r1267 r1325  
    11C0CEWD   ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
    2  ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
    33 ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    44 ;General Public License See attached copy of the License.
    … …  
    4848 Q token
    4949 ;
    50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 
     50cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options)
    5151 ;
    5252 n maxNo,noFound

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

    r1206 r1325  
    11C0CFM1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CFM2   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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/C0CIM2.m

    r1206 r1325  
    11C0CIM2  ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
    2  ;;1.0;C0C;;Feb 16, 2010;Build 38
     2 ;;1.0;C0C;;Feb 16, 2010;Build 39
    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

    r1206 r1325  
    11C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CIN   ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
    2  ;;1.0;C0C;;Sep 20, 2009;Build 38
     2 ;;1.0;C0C;;Sep 20, 2009;Build 39
    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/C0CLA7Q.m

    r1204 r1325  
    1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 38
    3         ;
    4         ;
    5         Q
    6         ;
    7         ;
    8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7)  ; Entry point for Lab Result Query
    9         ;
    10         ;
    11         K ^TMP("C0C-VLAB",$J)
    12         ;
    13         ; Check and retrieve lab results from LAB DATA file (#63)
    14         S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
    15         ;
    16         ; If V LAB file present then check for lab results that are only in this file
    17         ; If results found in V Lab file then build results and add to above results.
    18         I $D(^AUPNVLAB) D
    19         . D VCHECK
    20         . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
    21         ;
    22         ;K ^TMP("C0C-VLAB",$J)
    23         ;
    24         Q C0CDEST
    25         ;
    26         ;
    27 VCHECK  ; If V LAB file present then check for lab results that are only in this file.
    28         ;
    29         N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
    30         ;
    31         S LA7PTID=C0CPTID
    32         D PATID^LA7QRY2
    33         I $D(LA7ERR) Q
    34         ;
    35         ; Resolve search codes to lab datanames
    36         S LA7SC=$G(C0CSC)
    37         I $T(SCLIST^LA7QRY2)'="" D
    38         . N TMP
    39         . S LA7SCRC=$G(C0CSC)
    40         . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
    41         . S LA7SC=TMP
    42         ;
    43         I LA7SC'="*" D CHKSC^LA7QRY1
    44         ;
    45         ; Convert specimen codes to file #61 Topography entries
    46         S LA7SPEC=$G(C0CSPEC)
    47         I LA7SPEC'="*"  D SPEC^LA7QRY1
    48         ;
    49         S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
    50         ;
    51         F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
    52         . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
    53         . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
    54         . S C0CDA=$QS(C0CROOT,4)
    55         . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
    56         . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q  ; Source is LAB DATA file - skip
    57         . D VCHK1
    58         ;
    59         ;
    60         Q
    61         ;
    62         ;
    63 VBUILD  ; Build results found only in V LAB file into HL7 structure.
    64         ;
    65         ;
    66         Q
    67         ;
    68         ;
    69 LNCHK   ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
    70         ; Call from LA7QRY2
    71         ;
    72         N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
    73         ;
    74         S DFN=$P(^LR(LRDFN,0),"^",3)
    75         S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
    76         S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
    77         S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
    78         ;
    79         ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
    80         ;
    81         S C0C60=""
    82         F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
    83         . D FINDDT
    84         . I C0CDA<1 Q
    85         . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q  ; Source is not LAB DATA file - skip
    86         . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
    87         . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
    88         . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
    89         . I C0CPDA="" S C0CPDA=C0CDA
    90         . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
    91         . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
    92         . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
    93         . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
    94         . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
    95         . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
    96         . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
    97         ;
    98         S X=$P(LA7X,"^",3)
    99         ; If order NLT then update if no order NLT
    100         I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
    101         ;
    102         ; If result NLT then update if no result NLT
    103         I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
    104         ;
    105         ; If LOINC found then update variable with LN code
    106         I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
    107         ;
    108         S $P(LA7X,"^",3)=X
    109         ;
    110         Q
    111         ;
    112         ;
    113 TMPCHK  ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
    114         ; Called from LA7VOBX1
    115         ;
    116         N I,X
    117         ;
    118         S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
    119         I X="" Q
    120         F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
    121         S $P(LA7VAL,"^",3)=LA7X
    122         ;
    123         Q
    124         ;
    125         ;
    126 VCHK1   ; Check the entry in V Lab to determine if it meets criteria
    127         ;
    128         N C0CVLAB,I
    129         ;
    130         F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
    131         ;
    132         ; JMC 04/13/09 - Store anything for now that meets date criteria.
    133         D VSTORE
    134         ;
    135         Q
    136         ;
    137         ;
    138 VSTORE  ; Store entry for building in HL7 message when parent is from V LAB file.
    139         ;
    140         N C0CPDA,C0CPTEST
    141         ;
    142         ; Determine parent test to use for OBR segment
    143         S C0CPDA=$P(C0CVLAB(12),"^",8)
    144         I C0CPDA="" S C0CPDA=C0CDA
    145         ;
    146         ; Determine parent test
    147         S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
    148         ;
    149         S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
    150         ;
    151         Q
    152         ;
    153         ;
    154 FINDDT  ; Find entry in V LAB for the date/time or one close to it.
    155         ; RPMS stores related specimen entries under the same date/time.
    156         ; Lab file #63 creates unique entries with slightly different times.
    157         ;
    158         S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
    159         I C0CDA>0 Q
    160         ;
    161         ; If entry found then confirm that specimen type matches.
    162         N C0CDTY
    163         S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
    164         I C0CDTY D
    165         . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
    166         . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
    167         . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
    168         ;
    169         Q
     1C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
     2 ;;1.0;C0C;;May 19, 2009;Build 39
     3 ;
     4 ;
     5 Q
     6 ;
     7 ;
     8LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query
     9 ;
     10 ;
     11 K ^TMP("C0C-VLAB",$J)
     12 ;
     13 ; Check and retrieve lab results from LAB DATA file (#63)
     14 S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
     15 ;
     16 ; If V LAB file present then check for lab results that are only in this file
     17 ; If results found in V Lab file then build results and add to above results.
     18 I $D(^AUPNVLAB) D
     19 . D VCHECK
     20 . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
     21 ;
     22 ;K ^TMP("C0C-VLAB",$J)
     23 ;
     24 Q C0CDEST
     25 ;
     26 ;
     27VCHECK ; If V LAB file present then check for lab results that are only in this file.
     28 ;
     29 N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
     30 ;
     31 S LA7PTID=C0CPTID
     32 D PATID^LA7QRY2
     33 I $D(LA7ERR) Q
     34 ;
     35 ; Resolve search codes to lab datanames
     36 S LA7SC=$G(C0CSC)
     37 I $T(SCLIST^LA7QRY2)'="" D
     38 . N TMP
     39 . S LA7SCRC=$G(C0CSC)
     40 . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
     41 . S LA7SC=TMP
     42 ;
     43 I LA7SC'="*" D CHKSC^LA7QRY1
     44 ;
     45 ; Convert specimen codes to file #61 Topography entries
     46 S LA7SPEC=$G(C0CSPEC)
     47 I LA7SPEC'="*"  D SPEC^LA7QRY1
     48 ;
     49 S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
     50 ;
     51 F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
     52 . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
     53 . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
     54 . S C0CDA=$QS(C0CROOT,4)
     55 . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
     56 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q  ; Source is LAB DATA file - skip
     57 . D VCHK1
     58 ;
     59 ;
     60 Q
     61 ;
     62 ;
     63VBUILD ; Build results found only in V LAB file into HL7 structure.
     64 ;
     65 ;
     66 Q
     67 ;
     68 ;
     69LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
     70 ; Call from LA7QRY2
     71 ;
     72 N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
     73 ;
     74 S DFN=$P(^LR(LRDFN,0),"^",3)
     75 S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
     76 S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
     77 S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
     78 ;
     79 ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
     80 ;
     81 S C0C60=""
     82 F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
     83 . D FINDDT
     84 . I C0CDA<1 Q
     85 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q  ; Source is not LAB DATA file - skip
     86 . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
     87 . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
     88 . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
     89 . I C0CPDA="" S C0CPDA=C0CDA
     90 . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
     91 . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
     92 . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
     93 . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
     94 . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
     95 . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
     96 . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
     97 ;
     98 S X=$P(LA7X,"^",3)
     99 ; If order NLT then update if no order NLT
     100 I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
     101 ;
     102 ; If result NLT then update if no result NLT
     103 I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
     104 ;
     105 ; If LOINC found then update variable with LN code
     106 I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
     107 ;
     108 S $P(LA7X,"^",3)=X
     109 ;
     110 Q
     111 ;
     112 ;
     113TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
     114 ; Called from LA7VOBX1
     115 ;
     116 N I,X
     117 ;
     118 S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
     119 I X="" Q
     120 F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
     121 S $P(LA7VAL,"^",3)=LA7X
     122 ;
     123 Q
     124 ;
     125 ;
     126VCHK1 ; Check the entry in V Lab to determine if it meets criteria
     127 ;
     128 N C0CVLAB,I
     129 ;
     130 F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
     131 ;
     132 ; JMC 04/13/09 - Store anything for now that meets date criteria.
     133 D VSTORE
     134 ;
     135 Q
     136 ;
     137 ;
     138VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
     139 ;
     140 N C0CPDA,C0CPTEST
     141 ;
     142 ; Determine parent test to use for OBR segment
     143 S C0CPDA=$P(C0CVLAB(12),"^",8)
     144 I C0CPDA="" S C0CPDA=C0CDA
     145 ;
     146 ; Determine parent test
     147 S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
     148 ;
     149 S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
     150 ;
     151 Q
     152 ;
     153 ;
     154FINDDT ; Find entry in V LAB for the date/time or one close to it.
     155 ; RPMS stores related specimen entries under the same date/time.
     156 ; Lab file #63 creates unique entries with slightly different times.
     157 ;
     158 S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
     159 I C0CDA>0 Q
     160 ;
     161 ; If entry found then confirm that specimen type matches.
     162 N C0CDTY
     163 S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
     164 I C0CDTY D
     165 . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
     166 . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
     167 . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
     168 ;
     169 Q

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

    r1206 r1325  
    11C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    130130 S C0CQT=1 ; SURPRESS LISTING
    131131 D LIST ; EXTRACT THE VARIABLES
    132  ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD
    133  D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS
    134132 S C0CQT=QTSAV ; RESET SILENT FLAG
    135133 K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT
    … …  
    154152 W "LAB LIMIT: ",C0CLLMT,!
    155153 D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM
    156  S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW
    157154 S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP
    158155 Q
    … …  
    175172 . S C0CTYP=$P(@C0CHB@(C0CI),"|",1)
    176173 . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT)
    177  . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D  ; gpl - for certification
    178  . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT
    179  . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION
    180  . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE
    181  . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD
    182174 . M XV=C0CVAR ;
    183175 . I C0CTYP="OBR" D  ; BEGINNING OF NEW SECTION
    … …  
    199191 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE
    200192 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
    201  . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT
    202  . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1")
     193 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT
    203194 . . E  I C0CVAR("C6")="LN" D  ; SECONDARY CODE IS LOINC
    204195 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE

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

    r1185 r1325  
    149149 S ZI=""
    150150 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
     151 . S ZJ=$P(ZI,"/",2) ;
     152 . I ZJ="" S ZJ=$P(ZI,"/",3) ;
     153 . S @OUTARY@(ZJ,ZI)=@INARY@(ZI)
    157154 Q
    158155 ;

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

    r1206 r1325  
    11C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
    44 ; Licensed under the terms of the GNU General Public License.
    … …  
    7979 S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
    8080 ; N IPIV ; Inpatient IV Meds
    81  N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds
    82  K @IPUD
    83  S @IPUD@(0)=0
    84  ;
     81 ; N IPUD ; Inpatient UD Meds
    8582 D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
    8683 D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds
    8784 ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds
    8885 D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL
    89  D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl
    9086 I @HIST@(0)>0 D 
    9187 . D CP^C0CXPATH(HIST,MEDOUTXML)
    … …  
    9995 . E  D CP^C0CXPATH(NVA,MEDOUTXML)
    10096 . W:$G(DEBUG) "HAS NON-VA MEDS",!
    101  I @IPUD@(0)>0 D
    102  . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD)
    103  . E  D CP^C0CXPATH(IPUD,MEDOUTXML)
    104  . W:$G(DEBUG) "HAS INPATIENT MEDS",!
    10597 N ZI
    10698 S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
    … …  
    110102 K @HIST
    111103 K @NVA
    112  K @IPUD
    113104 Q
    114105 

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

    r1206 r1325  
    11C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;;Last modified Sat Jan 10 21:42:27 PST 2009
    44 ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
    … …  
    7272 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U))
    7373 . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
    74  . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U))
     74 . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MED(101),U))
    7575 . S @MAP@("MEDRXNOTXT")="Prescription Number"
    7676 . S @MAP@("MEDRXNO")=MED(.01)

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

    r1206 r1325  
    11C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
    44 ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
    … …  
    7171 . S @MAP@("MEDTYPETEXT")="Medication"
    7272 . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    73  . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds
     73 . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds
    7474 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I")
    7575 . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E")
    … …  
    114114 . . ; To protect against failure, I will put an if/else block
    115115 . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
    116  . . ;
    117  . . ; begin changes for systems that have eRx installed
    118  . . ; RxNorm is found in the ^C0P("RXN") global - gpl
    119  . . ;
    120  . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
    121  . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
    122  . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE
    123  . . I NDFIEN,$D(^C0P("RXN")) D  ;
    124  . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
    125  . . . S ZC=$$CODE^C0CUTIL(VUID)
    126  . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
    127  . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
    128  . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
    129  . . . S RXNORM=ZCD ; THE CODE
    130  . . . S RXNNAME=ZCDS ; THE CODING SYSTEM
    131  . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION
    132  . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
    133  . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD
    134  . . E  I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
     116 . . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
    135117 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
    136118 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
    … …  
    140122 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
    141123 . . ;
    142  . . ;E  S (RXNORM,RXNNAME,RXNVER)=""
     124 . . E  S (RXNORM,RXNNAME,RXNVER)=""
    143125 . . ; End if/else block
    144126 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    … …  
    179161 . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    180162 . . E  S @MAP@("MEDQUANTITYUNIT")=""
    181  . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
    182163 . E  D
    183164 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
    … …  
    200181 . ; MEDDIRECTIONDESCRIPTIONTEXT
    201182 . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS
    202  . ;
    203  . ; change for eRx meds - gpl 6/25/2011
    204  . ;
    205  . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    206  . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME
    207  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX
    208  . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity
    209  . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME
    210  . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D  ; FIX THE DRUG NAME
    211  . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME
    212  . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM
    213  . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY
    214  . . I RXNORM'="" D  ;
    215  . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM
    216  . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM
    217  . . . S RXNVER="" ; THE CODING SYSTEM VERSION
    218  . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
    219  . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM
    220  . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    221  . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    222  . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    223  . . . I RXNORM["979334" D  ; PATCH FOR CERTIFICATION
    224  . . . . S @MAP@("MEDSTRENGTHVALUE")=650
    225  . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg"
    226  . . . . S @MAP@("MEDFORMTEXT")="INHALER"
    227  . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS
    228  . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY
    229  . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ;
    230  . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     183 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    231184 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
    232185 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
    … …  
    260213 . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
    261214 . E  S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
    262  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl
    263215 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    264216 . K @RESULT

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

    r691 r1325  
    11C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
    2  ;;1.0;C0C;;May 19, 2009;
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    44 ; General Public License See attached copy of the License.
    … …  
    165165 . ; we want the components.
    166166 . ; 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"
     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"
    176176 . ;
    177177 . ; Will use GETS^DIQ to get fields.
    … …  
    306306 Q
    307307 ;
    308 GETRXN(NDC)     ; Extrinsic Function; PUBLIC; NDC to RxNorm
     308GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm
    309309 ;; Get RxNorm Concept Number for a Given NDC
    310310 ;

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

    r1206 r1325  
    11C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
    2  ;;0.1;C0C;nopatch;noreleasedate;Build 38
     2 ;;0.1;C0C;nopatch;noreleasedate;Build 39
    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

    r1204 r1325  
    66 ;DOCTYPE - Want to include a DOCTYPE node
    77 ;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.
     8START(DOC,DOCTYPE,FLAG) ;Call this once at the begining.
    99 K ^TMP("MXMLBLD",$J)
    1010 S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
    1111 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_">")
     12 D OUTPUT($$XMLHDR) D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
    1413 Q
    1514 ;
    … …  
    4241 Q S
    4342 ;
    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)=""
     43Q(X) ;Add Quotes
     44 I X'[$C(34) Q $C(34)_X_$C(34)
     45 N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
    4946 F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
    5047 S Y=Y_$P(X,Q,$L(X,Q))
    51  ;Q $C(34)_Y_$C(34)
    52  Q $C(39)_Y_$C(39)
     48 Q $C(34)_Y_$C(34)
    5349 ;
    5450XMLHDR() ; -- provides current XML standard header

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

    r1206 r1325  
    11C0CMXP   ; GPL - MXML based XPath utilities;12/04/09  17:05
    2  ;;0.1;C0C;nopatch;noreleasedate;Build 38
     2 ;;0.1;C0C;nopatch;noreleasedate;Build 39
    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/C0CPARMS.m

    r1206 r1325  
    11C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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  I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
    41  I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
    42  I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
    43  I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
    44  I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
    45  I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
    46  I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
    47  I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
    48  I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
     40 ;OHUM/RUT
     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@("RALIMIT")=^TMP("C0CCCR","RALIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT")
     51        ;OHUM/RUT
     52 ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-36500" ;ONE YR WORTH
     53        I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
     54        ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-36500" ;ONE YR VITALS
     55        I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
     56        I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
     57        ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-1" ; ONE YR MEDS
     58        I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
     59        I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
     60        I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE
     61        ;ELN
     62        ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
     63        ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
     64        ;I '$D(@C0CPARMS@("TIULIMIT")) S @C0CPARMS@("TIULIMIT")="T-2000" ;ONE YR WORTH
     65        I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
     66        ;ELN
     67        ;OHUM/RUT commented the hardcoded limits
    4968 Q
    5069 ;

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

    r1206 r1325  
    11C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    6060 . S @VMAP@("PROBLEMCODINGVERSION")=""
    6161 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3)
    62  . ; FOR CERTIFICATION - GPL
    63  . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493
    6462 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT")
    6563 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT")
    … …  
    112110 . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"")
    113111 . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG
    114  . ; turn off acute/chronic for certification gpl
    115  . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
     112 . S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
    116113 . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
    117114 . S @VMAP@("PROBLEMCODINGVERSION")=""
    118115 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
    119  . ; FOR CERTIFICATION - GPL
    120  . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493
    121116 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT")
    122117 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT")

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

    r1206 r1325  
    11C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
    2  ;;1.0;C0C;;Jan 21, 2010;Build 38
     2 ;;1.0;C0C;;Jan 21, 2010;Build 39
    33 ;Copyright 2010 George Lilly, University of Minnesota and others.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    2626 S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
    2727 S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
    28  ; ADDITION FOR CERTIFICATION
    29  S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))
    3028 Q
    3129 ;
    … …  
    8078 . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET
    8179 . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET
    82  . . . ; additions for Certification - need to have EKG in Results
    83  . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT
    8480 . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ
    8581 . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS
    … …  
    8783 . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE
    8884 . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
    89  . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
    90  . . . W !,"CPT=",ZCPT
    91  . . . I ZCPT["93000" D  ; THIS IS AN EKG
    92  . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
    93  . . . . M ^GPL("RNF2")=@C0CPRSLT
    9485 . . . S PREVCPT=ZCPT
    9586 . . . S PREVDT=ZDATE

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

    r1206 r1325  
    11C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    415415    I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
    416416    N ZLST
    417     S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE
     417    S LSTRTN(0)=0 ; DEFAULT RETURN NONE
    418418    S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
    419419    S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
    … …  
    430430    . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
    431431    S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
    432     S ZPAT=0 ; START AT FIRST PATIENT IN LIST
     432    S ZPAT="" ; START AT FIRST PATIENT IN LIST
    433433    F  S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT=""  D  ;
    434434    . S ZCNT=ZCNT+1
    … …  
    438438DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
    439439    ;
    440     ;N ZR
    441     D PCLST("ZR",CATTR)
     440    N ZR
     441    D PCLST(.ZR,CATTR)
    442442    I ZR(0)=0 D  Q  ;
    443443    . W "NO PATIENTS RETURNED",!
    444444    E  D  ;
    445     . N ZI S ZI=0
    446     . F  S ZI=$O(ZR(ZI)) Q:ZI=""  D  ;
    447     . . W !,ZI
    448     . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY
    449     . W !,"COUNT=",ZR(0)
     445    . D PARY^C0CXPATH("ZR") ; PRINT ARRAY
     446    . W "COUNT=",ZR(0),!
    450447    Q
    451448    ;

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

    r1206 r1325  
    11C0CRNF   ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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/C0CRXN.m

    r1206 r1325  
    11C0CRXN   ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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/C0CSOAP.m

    r1206 r1325  
    11C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2  ;;0.1;C0C;;Jun 15, 2008;Build 38
     2 ;;0.1;C0C;;Jun 15, 2008;Build 39
    33 ;Copyright 2008-2009 Sam Habiel & George Lilly. 
    44 ;Licensed under the terms of the GNU
    … …  
    135135 Q
    136136 ;
    137 RXNFN() 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  ;
    167137RPMS() ; Are we running on an RPMS system rather than Vista?
    168138 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service

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

    r1206 r1325  
    11C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2  ;;1.0;C0C;;Feb 16, 2010;Build 38
     2 ;;1.0;C0C;;Feb 16, 2010;Build 39
    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

    r1206 r1325  
    11C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    33 ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    44 ;Licensed under the terms of the GNU General Public License.
    … …  
    5858 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
    5959 D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
    60  I DEBUG ZWR VDATES ;DEBUG
     60 ; I DEBUG ZWR VDATES ;DEBUG
    6161 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
    6262 ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
    … …  
    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"
    7874 . . I $P(VITPTMP,U,2)="HT" D
    7975 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    … …  
    8783 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    8884 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    89  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     85 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    9086 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    9187 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
    … …  
    10197 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    10298 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    103  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     99 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    104100 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    105101 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
    106102 . . E  I $P(VITPTMP,U,2)="BP" D
    107103 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    108  . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     104 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    109105 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    110106 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    … …  
    115111 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    116112 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    117  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     113 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    118114 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    119115 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    … …  
    129125 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    130126 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    131  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     127 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    132128 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    133129 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F"
    … …  
    143139 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    144140 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    145  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     141 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    146142 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    147143 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    … …  
    157153 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    158154 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    159  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     155 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    160156 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    161157 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    … …  
    171167 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    172168 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    173  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    174  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    175  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    176  . . E  I $P(VITPTMP,U,2)="BMI" D
    177  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    178  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    179  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
    180  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    181  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    182  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    183  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
    184  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009"
    185  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    186  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    187  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     169 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    188170 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    189171 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    … …  
    200182 . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
    201183 . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    202  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
     184 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    203185 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    204186 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
    205         . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
    206         . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
    207187 . . S VITARYTMP=$NA(@VITTARYTMP@(J))
    208188 . . K @VITARYTMP

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

    r1206 r1325  
    11C0CXPAT0   ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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

    r1206 r1325  
    11C0CXPATH   ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
     2 ;;1.0;C0C;;May 19, 2009;Build 39
    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/VWTIME.m

    r1213 r1325  
    1 VWTIME  ; Report Age in Time / Date;5:33 AM  11 Feb 2010
    2         ;;1.0;WorldVistA;;WorldVistA 30-June-08;Build 2
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         QUIT  ;  No Fall Through
    23         ;  =============
    24         ; FDT = First Date/Time (SD)
    25         ;  W $$DIF^VWTIME(3090512.1145)
    26 DIF(SD,ED)      ; Now a Call will look like the above
    27         N BUF,DED,DSD,EH,EI,FTD
    28         S SD=$G(SD),ED=$G(ED)
    29         I ED="" D NOW^%DTC S ED=%
    30         I SD<.00001 D NOW^%DTC S SD=%  ; Invalid start date is set to now
    31         S X=SD
    32         D
    33         . I SD="" S ER=99 Q
    34         . ;
    35         . ; Convert both Values to Fileman Time to Decimal.
    36         . ;  We are interested in just the differences
    37         . ;
    38         . I SD>1400000 D
    39         . . S X=$$F2D(SD)
    40         . . D H^%DTC
    41         . . S SD=%H_","_$TR($J(%T,5)," ","0")
    42         . .QUIT
    43         . S DST=$$F2D(SD)
    44         . S DET=$$F2D(ED)
    45         .QUIT
    46         ;  Decimal Date/Times calculated in DST (start) and DET (end),
    47         ;   differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
    48         S (DTD,FTD)=DET-DST
    49         ; Time Frames
    50         ; 1 Minute = .000694444444444444444
    51         ; 1 Hour   = .0416666666666666666
    52         ; 1 Day    = 1
    53         ; 1 WeeK   = 7
    54         ; 1 Month  = 30.5
    55         ; 1 Year   = 365.249
    56         N BUF,DAY,HR,MIN,MON,WK,YR
    57         S BUF=""
    58         S DAY=1
    59         S SEP=""
    60         D
    61         . N HR,MON,YR,WEEK
    62         . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
    63         . I FTD>(2*YR)    D
    64         . . S T=DTD\YR
    65         . . S BUF=BUF_SEP_T_" Year"
    66         . . S:T>1 BUF=BUF_"s"
    67         . . S DTD=(DTD#YR),SEP=", "
    68         . . .QUIT
    69         . QUIT:FTD>(20*YR)
    70         . ;
    71         . ;  Time Calculations
    72         . I FTD>(4*MON) I FTD<(18*YR)   D
    73         . . S T=DTD\MON
    74         . . S BUF=BUF_SEP_T_" Month"
    75         . . S:T>1 BUF=BUF_"s"
    76         . . S DTD=(DTD#MON),SEP=", "
    77         . .QUIT
    78         . QUIT:FTD>(18*YR)
    79         . I FTD>29 I FTD<4*WEEK          D
    80         . . S T=DTD\WEEK
    81         . . S BUF=BUF_SEP_T_" Week"
    82         . . S:T>1 BUF=BUF_"s"
    83         . . S DTD=(DTD#WEEK),SEP=", "
    84         . .QUIT
    85         . ;  Time Calculations
    86         . I FTD<29 I DTD'<2        D
    87         . . S T=DTD\1
    88         . . S BUF=BUF_SEP_T_" Day"
    89         . . S:T>1 BUF=BUF_"s"
    90         . . S DTD=(DTD#DAY),SEP=", "
    91         . .QUIT
    92         . I DTD>.999999&(FTD<4)    D
    93         . . S T=DTD\HR
    94         . . S BUF=BUF_SEP_T_" Hour"
    95         . . S:T>1 BUF=BUF_"s"
    96         . . S DTD=(DTD#HR),SEP=", "
    97         . .QUIT
    98         . D:(FTD<4.00000001)
    99         . . N MIN,HR
    100         . . S HR=1/24,SEP=$G(SEP)
    101         . . S MIN=HR/60
    102         . . ;
    103         . . I DTD>MIN    D
    104         . . . S T=DTD\MIN
    105         . . . S BUF=BUF_SEP_T_" Minute"
    106         . . . S:T>1 BUF=BUF_"s"
    107         . . . S DTD=(DTD#MIN),SEP=", "
    108         . .QUIT
    109         . . ;
    110         . . S SEC=MIN/60
    111         . . I DTD>SEC    D
    112         . . . S T=DTD\SEC
    113         . . . S BUF=BUF_SEP_T_" Second"
    114         . . . S:T>1 BUF=BUF_"s"
    115         . . . S DTD=(DTD#SEC),SEP=", "
    116         . . .QUIT
    117         . .QUIT
    118         . ; I DTD    S BUF=BUF_" Less than a Minute"
    119         .QUIT
    120         QUIT BUF
    121         ;  ==========
    122         ;  W $$BRIEF^VWTIME(DOB)    >>> Years^Months^Weeks^Days^Hours^Minutes^Seconds
    123 BRIEF(SD,ED)    ; Now a Call will look like the above
    124         N BUF,DED,DSD,EH,EI,FTD,BUF
    125         S SD=$G(SD),ED=$G(ED)
    126         I ED="" D NOW^%DTC S ED=%
    127         S:SD<2 SD=""
    128         S BUF="INVALID INPUT"
    129         D:SD   ; SD has been checked and passed if it passes here
    130         . S X=SD
    131         . ;
    132         . ; Convert both Values to Fileman Time to Decimal.
    133         . ;  We are interested in just the differences
    134         . ;
    135         . ; I SD>1400000 D
    136         . ; . S X=$$F2D(SD)
    137         . ; .  D H^%DTC
    138         . ; .  S SD=%H_","_$TR($J(%T,5)," ","0")
    139         . ; .QUIT
    140         . ;  If we get here, we have the ST and ET defined and ready
    141         . S DST=$$F2D(SD)
    142         . S DET=$$F2D(ED)
    143         . D TDIFF(.BUF)
    144         .QUIT
    145         QUIT BUF
    146         ;  ===========
    147 TDIFF(BF)       ; Time Difference formulation
    148         ;  Decimal Date/Times calculated in DST (start) and DET (end),
    149         ;   differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
    150         S (DTD,FTD)=DET-DST
    151         ; Time Frames
    152         ; 1 Minute = .000694444444444444444
    153         ; 1 Hour   = .0416666666666666666
    154         ; 1 Day    = 1
    155         ; 1 WeeK   = 7
    156         ; 1 Month  = 30.5
    157         ; 1 Year   = 365.249
    158         N DAY,HR,MIN,MON,WK,YR
    159         S $P(BF,"^",7)=""
    160         S DAY=1
    161         S SEP=""
    162         D
    163         . N HR,MON,YR,WEEK
    164         . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
    165         . I FTD>(2*YR)    D
    166         . . S $P(BF,"^")=DTD\YR
    167         . . S DTD=(DTD#YR)
    168         . .QUIT
    169         . ;
    170         . ;  Time Calculations
    171         . I FTD>(4*MON) I FTD<(18*YR)   D
    172         . . S $P(BF,"^",2)=DTD\MON
    173         . . S DTD=(DTD#MON)
    174         . .QUIT
    175         . D   ; I FTD>29 I FTD<4*WEEK          D
    176         . . S $P(BF,"^",3)=DTD\WEEK
    177         . . S DTD=(DTD#WEEK)
    178         . .QUIT
    179         . ;  Time Calculations
    180         . D   ; I FTD<29 I DTD'<2        D
    181         . . S $P(BF,"^",4)=DTD\1
    182         . . S DTD=(DTD#DAY)
    183         . .QUIT
    184         . D    ; I DTD>.999999&(FTD<4)    D
    185         . . S $P(BF,"^",5)=DTD\HR
    186         . . S DTD=(DTD#HR)
    187         . .QUIT
    188         . S MIN=1/(24*60)
    189         . D   ; :(FTD<4.00000001)
    190         . . N HR
    191         . . S HR=1/24
    192         . . S MIN=HR/60
    193         . . ;
    194         . . ; I DTD>MIN    D
    195         . . S $P(BF,"^",6)=DTD\MIN
    196         . . S DTD=(DTD#MIN)
    197         . .QUIT
    198         . . ;
    199         . S SEC=MIN/60
    200         . ; I DTD>SEC    D
    201         . S $P(BF,"^",7)=DTD\SEC
    202         . S DTD=(DTD#SEC)
    203         . .QUIT
    204         . ; I DTD    S BF=BF_" Less than a Minute"
    205         .QUIT
    206         QUIT
    207         ;  ==========
    208 F2D(X)  ;  Conver FM Date/Time to Decimal
    209         N %H,%T,%Y
    210         D H^%DTC
    211         QUIT $$H2D(%H_","_%T)
    212         ;  ========
    213 H2D(X)  ; Convert Horolog to Decimal Days
    214         N D,T
    215         S D=$P(X,","),T=$P(X,",",2)/86400
    216         QUIT D+T
    217         ;  =============
    218 LONGAGE(VWAGE,VWDFN)    ; RPC FOR LONG AGE
    219         N VWDOB
    220         S VWDOB=$P(^DPT(VWDFN,0),"^",3)
    221         S VWAGE=$$DIF(VWDOB)
    222         QUIT
    223         ;  =============
    224 BRFAGE(VWAGE,VWDFN)     ; RPC FOR BRIEF AGE
    225         N VWDOB
    226         S VWDOB=$P(^DPT(VWDFN,0),"^",3)
    227         S VWAGE=$$BRIEF(VWDOB)
    228         QUIT
    229         ;  =============
    230 RPCREG  ; Register NEW RPCs
    231         N MENU,RPC,FDA,FDAIEN,ERR,DIERR
    232         S MENU="OR CPRS GUI CHART"
    233         F RPC="VWTIME LONG AGE","VWTIME BRIEF AGE" D
    234         . S FDA(19,"?1,",.01)=MENU
    235         . S FDA(19.05,"?+2,?1,",.01)=RPC
    236         . D UPDATE^DIE("E","FDA","FDAIEN","ERR")
    237         .QUIT
    238         QUIT
    239         ;  ============
     1VWTIME ; Report Age in Time / Date;5:33 AM  11 Feb 2010
     2 ;;1.0;WorldVistA;;WorldVistA 30-June-08;Build 2
     3 ;
     4 ;Modified from FOIA VISTA,
     5 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     6 ;General Public License See attached copy of the License.
     7 ;
     8 ;This program is free software; you can redistribute it and/or modify
     9 ;it under the terms of the GNU General Public License as published by
     10 ;the Free Software Foundation; either version 2 of the License, or
     11 ;(at your option) any later version.
     12 ;
     13 ;This program is distributed in the hope that it will be useful,
     14 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     15 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     16 ;GNU General Public License for more details.
     17 ;
     18 ;You should have received a copy of the GNU General Public License along
     19 ;with this program; if not, write to the Free Software Foundation, Inc.,
     20 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     21 ;
     22 QUIT  ;  No Fall Through
     23 ;  =============
     24 ; FDT = First Date/Time (SD)
     25 ;  W $$DIF^VWTIME(3090512.1145)
     26DIF(SD,ED) ; Now a Call will look like the above
     27 N BUF,DED,DSD,EH,EI,FTD
     28 S SD=$G(SD),ED=$G(ED)
     29 I ED="" D NOW^%DTC S ED=%
     30 I SD<.00001 D NOW^%DTC S SD=%  ; Invalid start date is set to now
     31 S X=SD
     32 D
     33 . I SD="" S ER=99 Q
     34 . ;
     35 . ; Convert both Values to Fileman Time to Decimal.
     36 . ;  We are interested in just the differences
     37 . ;
     38 . I SD>1400000 D
     39 . . S X=$$F2D(SD)
     40 . . D H^%DTC
     41 . . S SD=%H_","_$TR($J(%T,5)," ","0")
     42 . .QUIT
     43 . S DST=$$F2D(SD)
     44 . S DET=$$F2D(ED)
     45 .QUIT
     46 ;  Decimal Date/Times calculated in DST (start) and DET (end),
     47 ;   differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
     48 S (DTD,FTD)=DET-DST
     49 ; Time Frames
     50 ; 1 Minute = .000694444444444444444
     51 ; 1 Hour   = .0416666666666666666
     52 ; 1 Day    = 1
     53 ; 1 WeeK   = 7
     54 ; 1 Month  = 30.5
     55 ; 1 Year   = 365.249
     56 N BUF,DAY,HR,MIN,MON,WK,YR
     57 S BUF=""
     58 S DAY=1
     59 S SEP=""
     60 D
     61 . N HR,MON,YR,WEEK
     62 . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
     63 . I FTD>(2*YR)    D
     64 . . S T=DTD\YR
     65 . . S BUF=BUF_SEP_T_" Year"
     66 . . S:T>1 BUF=BUF_"s"
     67 . . S DTD=(DTD#YR),SEP=", "
     68 . . .QUIT
     69 . QUIT:FTD>(20*YR)
     70 . ;
     71 . ;  Time Calculations
     72 . I FTD>(4*MON) I FTD<(18*YR)   D
     73 . . S T=DTD\MON
     74 . . S BUF=BUF_SEP_T_" Month"
     75 . . S:T>1 BUF=BUF_"s"
     76 . . S DTD=(DTD#MON),SEP=", "
     77 . .QUIT
     78 . QUIT:FTD>(18*YR)
     79 . I FTD>29 I FTD<4*WEEK          D
     80 . . S T=DTD\WEEK
     81 . . S BUF=BUF_SEP_T_" Week"
     82 . . S:T>1 BUF=BUF_"s"
     83 . . S DTD=(DTD#WEEK),SEP=", "
     84 . .QUIT
     85 . ;  Time Calculations
     86 . I FTD<29 I DTD'<2        D
     87 . . S T=DTD\1
     88 . . S BUF=BUF_SEP_T_" Day"
     89 . . S:T>1 BUF=BUF_"s"
     90 . . S DTD=(DTD#DAY),SEP=", "
     91 . .QUIT
     92 . I DTD>.999999&(FTD<4)    D
     93 . . S T=DTD\HR
     94 . . S BUF=BUF_SEP_T_" Hour"
     95 . . S:T>1 BUF=BUF_"s"
     96 . . S DTD=(DTD#HR),SEP=", "
     97 . .QUIT
     98 . D:(FTD<4.00000001)
     99 . . N MIN,HR
     100 . . S HR=1/24,SEP=$G(SEP)
     101 . . S MIN=HR/60
     102 . . ;
     103 . . I DTD>MIN    D
     104 . . . S T=DTD\MIN
     105 . . . S BUF=BUF_SEP_T_" Minute"
     106 . . . S:T>1 BUF=BUF_"s"
     107 . . . S DTD=(DTD#MIN),SEP=", "
     108 . .QUIT
     109 . . ;
     110 . . S SEC=MIN/60
     111 . . I DTD>SEC    D
     112 . . . S T=DTD\SEC
     113 . . . S BUF=BUF_SEP_T_" Second"
     114 . . . S:T>1 BUF=BUF_"s"
     115 . . . S DTD=(DTD#SEC),SEP=", "
     116 . . .QUIT
     117 . .QUIT
     118 . ; I DTD    S BUF=BUF_" Less than a Minute"
     119 .QUIT
     120 QUIT BUF
     121 ;  ==========
     122 ;  W $$BRIEF^VWTIME(DOB)    >>> Years^Months^Weeks^Days^Hours^Minutes^Seconds
     123BRIEF(SD,ED) ; Now a Call will look like the above
     124 N BUF,DED,DSD,EH,EI,FTD,BUF
     125 S SD=$G(SD),ED=$G(ED)
     126 I ED="" D NOW^%DTC S ED=%
     127 S:SD<2 SD=""
     128 S BUF="INVALID INPUT"
     129 D:SD   ; SD has been checked and passed if it passes here
     130 . S X=SD
     131 . ;
     132 . ; Convert both Values to Fileman Time to Decimal.
     133 . ;  We are interested in just the differences
     134 . ;
     135 . ; I SD>1400000 D
     136 . ; . S X=$$F2D(SD)
     137 . ; .  D H^%DTC
     138 . ; .  S SD=%H_","_$TR($J(%T,5)," ","0")
     139 . ; .QUIT
     140 . ;  If we get here, we have the ST and ET defined and ready
     141 . S DST=$$F2D(SD)
     142 . S DET=$$F2D(ED)
     143 . D TDIFF(.BUF)
     144 .QUIT
     145 QUIT BUF
     146 ;  ===========
     147TDIFF(BF) ; Time Difference formulation
     148 ;  Decimal Date/Times calculated in DST (start) and DET (end),
     149 ;   differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
     150 S (DTD,FTD)=DET-DST
     151 ; Time Frames
     152 ; 1 Minute = .000694444444444444444
     153 ; 1 Hour   = .0416666666666666666
     154 ; 1 Day    = 1
     155 ; 1 WeeK   = 7
     156 ; 1 Month  = 30.5
     157 ; 1 Year   = 365.249
     158 N DAY,HR,MIN,MON,WK,YR
     159 S $P(BF,"^",7)=""
     160 S DAY=1
     161 S SEP=""
     162 D
     163 . N HR,MON,YR,WEEK
     164 . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
     165 . I FTD>(2*YR)    D
     166 . . S $P(BF,"^")=DTD\YR
     167 . . S DTD=(DTD#YR)
     168 . .QUIT
     169 . ;
     170 . ;  Time Calculations
     171 . I FTD>(4*MON) I FTD<(18*YR)   D
     172 . . S $P(BF,"^",2)=DTD\MON
     173 . . S DTD=(DTD#MON)
     174 . .QUIT
     175 . D   ; I FTD>29 I FTD<4*WEEK          D
     176 . . S $P(BF,"^",3)=DTD\WEEK
     177 . . S DTD=(DTD#WEEK)
     178 . .QUIT
     179 . ;  Time Calculations
     180 . D   ; I FTD<29 I DTD'<2        D
     181 . . S $P(BF,"^",4)=DTD\1
     182 . . S DTD=(DTD#DAY)
     183 . .QUIT
     184 . D    ; I DTD>.999999&(FTD<4)    D
     185 . . S $P(BF,"^",5)=DTD\HR
     186 . . S DTD=(DTD#HR)
     187 . .QUIT
     188 . S MIN=1/(24*60)
     189 . D   ; :(FTD<4.00000001)
     190 . . N HR
     191 . . S HR=1/24
     192 . . S MIN=HR/60
     193 . . ;
     194 . . ; I DTD>MIN    D
     195 . . S $P(BF,"^",6)=DTD\MIN
     196 . . S DTD=(DTD#MIN)
     197 . .QUIT
     198 . . ;
     199 . S SEC=MIN/60
     200 . ; I DTD>SEC    D
     201 . S $P(BF,"^",7)=DTD\SEC
     202 . S DTD=(DTD#SEC)
     203 . .QUIT
     204 . ; I DTD    S BF=BF_" Less than a Minute"
     205 .QUIT
     206 QUIT
     207 ;  ==========
     208F2D(X) ;  Conver FM Date/Time to Decimal
     209 N %H,%T,%Y
     210 D H^%DTC
     211 QUIT $$H2D(%H_","_%T)
     212 ;  ========
     213H2D(X) ; Convert Horolog to Decimal Days
     214 N D,T
     215 S D=$P(X,","),T=$P(X,",",2)/86400
     216 QUIT D+T
     217 ;  =============
     218LONGAGE(VWAGE,VWDFN) ; RPC FOR LONG AGE
     219 N VWDOB
     220 S VWDOB=$P(^DPT(VWDFN,0),"^",3)
     221 S VWAGE=$$DIF(VWDOB)
     222 QUIT
     223 ;  =============
     224BRFAGE(VWAGE,VWDFN) ; RPC FOR BRIEF AGE
     225 N VWDOB
     226 S VWDOB=$P(^DPT(VWDFN,0),"^",3)
     227 S VWAGE=$$BRIEF(VWDOB)
     228 QUIT
     229 ;  =============
     230RPCREG ; Register NEW RPCs
     231 N MENU,RPC,FDA,FDAIEN,ERR,DIERR
     232 S MENU="OR CPRS GUI CHART"
     233 F RPC="VWTIME LONG AGE","VWTIME BRIEF AGE" D
     234 . S FDA(19,"?1,",.01)=MENU
     235 . S FDA(19.05,"?+2,?1,",.01)=RPC
     236 . D UPDATE^DIE("E","FDA","FDAIEN","ERR")
     237 .QUIT
     238 QUIT
     239 ;  ============
Note: See TracChangeset for help on using the changeset viewer.