Changeset 1325 for ccr/branches/ohum
- Timestamp:
- Dec 31, 2011, 12:08:05 AM (13 years ago)
- Location:
- ccr/branches/ohum/p
- Files:
-
- 1 added
- 47 edited
-
C0CACTOR.m (modified) (1 diff)
-
C0CALERT.m (modified) (4 diffs)
-
C0CBAT.m (modified) (1 diff)
-
C0CCCD.m (modified) (1 diff)
-
C0CCCD1.m (modified) (1 diff)
-
C0CCCR.m (modified) (5 diffs)
-
C0CCCR0.m (modified) (2 diffs)
-
C0CCMT.m (modified) (1 diff)
-
C0CCPT.m (modified) (2 diffs)
-
C0CDPT.m (modified) (1 diff)
-
C0CENC.m (modified) (1 diff)
-
C0CENV.m (modified) (3 diffs)
-
C0CEVC.m (modified) (1 diff)
-
C0CEWD.m (modified) (2 diffs)
-
C0CFM1.m (modified) (1 diff)
-
C0CFM2.m (modified) (1 diff)
-
C0CIM2.m (modified) (1 diff)
-
C0CIMMU.m (modified) (1 diff)
-
C0CIN.m (modified) (1 diff)
-
C0CLA7Q.m (modified) (1 diff)
-
C0CLABS.m (modified) (5 diffs)
-
C0CMCCD.m (modified) (1 diff)
-
C0CMED.m (modified) (4 diffs)
-
C0CMED1.m (modified) (2 diffs)
-
C0CMED2.m (modified) (1 diff)
-
C0CMED3.m (modified) (7 diffs)
-
C0CMED6.m (modified) (3 diffs)
-
C0CMXML.m (modified) (1 diff)
-
C0CMXMLB.m (modified) (2 diffs)
-
C0CMXP.m (modified) (1 diff)
-
C0CPARMS.m (modified) (2 diffs)
-
C0CPROBS.m (modified) (3 diffs)
-
C0CPROC.m (modified) (4 diffs)
-
C0CRIMA.m (modified) (4 diffs)
-
C0CRNF.m (modified) (1 diff)
-
C0CRXN.m (modified) (1 diff)
-
C0CSOAP.m (modified) (1 diff)
-
C0CSUB1.m (modified) (1 diff)
-
C0CSYS.m (modified) (1 diff)
-
C0CUNIT.m (modified) (1 diff)
-
C0CUTIL.m (modified) (2 diffs)
-
C0CVA200.m (modified) (1 diff)
-
C0CVALID.m (added)
-
C0CVIT2.m (modified) (1 diff)
-
C0CVITAL.m (modified) (11 diffs)
-
C0CXPAT0.m (modified) (1 diff)
-
C0CXPATH.m (modified) (1 diff)
-
VWTIME.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CACTOR.m
r1206 r1325 1 1 C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CALERT.m
r1206 r1325 1 1 C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. … … 56 56 . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy 57 57 . N ALTCDE ; SNOMED CODE THE THE ALERT 58 . S ALTCDE=$S(A2="P":"282100009",A2="A":"41 6098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC58 . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC 59 59 . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; 60 60 . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE … … 81 81 . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT 82 82 . 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 85 84 . 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" 90 86 . E D ; IF REACTANT CODE VALUE IS NULL 91 87 . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS … … 94 90 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" 95 91 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" 96 . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD97 . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS98 . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD99 . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD100 92 . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW 101 93 . N ARTMP,ARIEN,ARDES,ARVUID -
ccr/branches/ohum/p/C0CBAT.m
r1206 r1325 1 1 C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CCCD.m
r1206 r1325 1 1 C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCCD1.m
r1206 r1325 1 1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCCR.m
r1206 r1325 1 1 C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. … … 26 26 I Y<1 Q ; EXIT 27 27 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 28 31 D XPAT(DFN) ; EXPORT TO A FILE 29 32 Q … … 103 106 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") 104 107 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") 105 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")106 108 I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! 107 109 ; … … 135 137 D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") 136 138 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") 141 142 K CMTT,CMTT2 142 143 N TRIMI,J,DONE S DONE=0 … … 166 167 D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") 167 168 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 168 170 ;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 170 173 Q 171 174 ; -
ccr/branches/ohum/p/C0CCCR0.m
r1206 r1325 1 1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. … … 792 792 ;;</Name> 793 793 ;;</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> 794 805 ;;<Specialty> 795 806 ;;<Text>@@ACTORSPECIALITY@@</Text> -
ccr/branches/ohum/p/C0CCMT.m
r1206 r1325 1 1 C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 2 ;;1.0;C0C;;May 21, 2010;Build 3 82 ;;1.0;C0C;;May 21, 2010;Build 39 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCPT.m
r1206 r1325 1 1 C0CCPT ;;BSL;RETURN CPT DATA; 2 ;Sequence Managers Software GPL;;;;;Build 3 82 ;Sequence Managers Software GPL;;;;;Build 39 3 3 ;Copied into C0C namespace from SQMCPT with permission from 4 4 ;Brian Lord - and with our thanks. gpl 01/20/2010 … … 19 19 ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE 20 20 ;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 21 24 S Z="" 22 25 F S Z=$O(NOTE(Z)) Q:Z="" D -
ccr/branches/ohum/p/C0CDPT.m
r1206 r1325 1 1 C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ; 4 4 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -
ccr/branches/ohum/p/C0CENC.m
r1267 r1325 1 1 C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 2 ;;1.0;C0C;;May 21, 2010;Build 3 82 ;;1.0;C0C;;May 21, 2010;Build 39 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CENV.m
r1267 r1325 1 1 C0CENV ;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 3 3 ; 4 4 ; … … 22 22 ; 23 23 CHECK ; Perform environment check 24 24 ; 25 25 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D 26 26 . D BMES("Terminal Device is not defined") … … 34 34 . D BMES("You are not a valid user on this system") 35 35 . S XPDQUIT=2 36 37 38 36 Q 37 ; 38 ; 39 39 EXIT ; 40 41 40 ; 41 ; 42 42 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q 43 43 D BMES("--- Environment Check is Ok ---") 44 44 ; 45 45 Q 46 47 46 ; 47 ; 48 48 PRE ;Pre-install entry point 49 50 51 52 53 54 55 49 ; 50 ; No action needed in pre-install 51 D BMES("No action need for pre-install") 52 ; 53 Q 54 ; 55 ; 56 56 POST ;Post install 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 POST1 74 75 76 77 78 79 80 81 82 83 84 85 POST2 86 87 88 89 90 91 92 93 94 95 96 97 POST3 98 99 100 101 102 103 104 105 106 107 108 109 POST4 110 111 112 113 114 115 116 117 118 119 120 121 POST5 122 123 124 125 126 127 128 129 130 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 ; 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 ; 133 133 POST6 ; Checkpoint call back entry point. 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 POST7 170 171 172 173 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 ; 169 POST7 ; Checkpoint call back entry point. 170 ; 171 D REINDEX^C0CLA7DD 172 ; 173 Q 174 ; 175 ; 176 176 BMES(STR) ; Write BMES^XPDUTL statements 177 178 179 180 181 182 183 LOAD(X) 184 185 186 187 188 189 190 191 SAVE(OLD,NEW) 192 193 194 195 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 -
ccr/branches/ohum/p/C0CEVC.m
r1267 r1325 74 74 N ZT,ZDFN 75 75 S ZT=$$URLTOKEN^C0CEWD(sessid) 76 ;S ^TMP("GPL")=ZT 77 d trace^%zewdAPI("*********************ZT="_ZT) 76 S ^TMP("GPL")=ZT 78 77 S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN 79 78 S ^TMP("GPL","DFN")=ZDFN -
ccr/branches/ohum/p/C0CEWD.m
r1267 r1325 1 1 C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 2 ;;0.1;CCDCCR;nopatch;noreleasedate ;Build 772 ;;0.1;CCDCCR;nopatch;noreleasedate 3 3 ;Copyright 2011 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. … … 48 48 Q token 49 49 ; 50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 51 51 ; 52 52 n maxNo,noFound -
ccr/branches/ohum/p/C0CFM1.m
r1206 r1325 1 1 C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CFM2.m
r1206 r1325 1 1 C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CIM2.m
r1206 r1325 1 1 C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 2 ;;1.0;C0C;;Feb 16, 2010;Build 3 82 ;;1.0;C0C;;Feb 16, 2010;Build 39 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CIMMU.m
r1206 r1325 1 1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CIN.m
r1206 r1325 1 1 C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 2 ;;1.0;C0C;;Sep 20, 2009;Build 3 82 ;;1.0;C0C;;Sep 20, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CLA7Q.m
r1204 r1325 1 C0CLA7Q 2 ;;1.0;C0C;;May 19, 2009;Build 38 3 4 5 6 7 8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 VCHECK 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 VBUILD 64 65 66 67 68 69 LNCHK 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 TMPCHK 114 115 116 117 118 119 120 121 122 123 124 125 126 VCHK1 127 128 129 130 131 132 133 134 135 136 137 138 VSTORE 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 FINDDT 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 1 C0CLA7Q ;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 ; 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 -
ccr/branches/ohum/p/C0CLABS.m
r1206 r1325 1 1 C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. … … 130 130 S C0CQT=1 ; SURPRESS LISTING 131 131 D LIST ; EXTRACT THE VARIABLES 132 ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD133 D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS134 132 S C0CQT=QTSAV ; RESET SILENT FLAG 135 133 K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT … … 154 152 W "LAB LIMIT: ",C0CLLMT,! 155 153 D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM 156 S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW157 154 S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP 158 155 Q … … 175 172 . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) 176 173 . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) 177 . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification178 . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT179 . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION180 . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE181 . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD182 174 . M XV=C0CVAR ; 183 175 . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION … … 199 191 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE 200 192 . . . 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 203 194 . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC 204 195 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE -
ccr/branches/ohum/p/C0CMCCD.m
r1185 r1325 149 149 S ZI="" 150 150 F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY 151 . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES 152 . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor 153 . E D ; FOR BODY PARTS 154 . . S ZJ=$P(ZI,"/",2) ; 155 . . I ZJ="" S ZJ=$P(ZI,"/",3) ; 156 . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS 151 . S ZJ=$P(ZI,"/",2) ; 152 . I ZJ="" S ZJ=$P(ZI,"/",3) ; 153 . S @OUTARY@(ZJ,ZI)=@INARY@(ZI) 157 154 Q 158 155 ; -
ccr/branches/ohum/p/C0CMED.m
r1206 r1325 1 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. 4 4 ; Licensed under the terms of the GNU General Public License. … … 79 79 S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) 80 80 ; 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 85 82 D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds 86 83 D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds 87 84 ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 88 85 D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL 89 D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl90 86 I @HIST@(0)>0 D 91 87 . D CP^C0CXPATH(HIST,MEDOUTXML) … … 99 95 . E D CP^C0CXPATH(NVA,MEDOUTXML) 100 96 . W:$G(DEBUG) "HAS NON-VA MEDS",! 101 I @IPUD@(0)>0 D102 . 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",!105 97 N ZI 106 98 S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) … … 110 102 K @HIST 111 103 K @NVA 112 K @IPUD113 104 Q 114 105 -
ccr/branches/ohum/p/C0CMED1.m
r1206 r1325 1 1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;;Last modified Sat Jan 10 21:42:27 PST 2009 4 4 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU … … 72 72 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U)) 73 73 . 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)) 75 75 . S @MAP@("MEDRXNOTXT")="Prescription Number" 76 76 . S @MAP@("MEDRXNO")=MED(.01) -
ccr/branches/ohum/p/C0CMED2.m
r1206 r1325 1 1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;;Last Modified Sat Jan 10 21:41:14 PST 2009 4 4 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -
ccr/branches/ohum/p/C0CMED3.m
r1206 r1325 1 1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 4 4 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU … … 71 71 . S @MAP@("MEDTYPETEXT")="Medication" 72 72 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 73 . S @MAP@("MEDSTATUSTEXT")="A ctive" ; nearest status for pending meds73 . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds 74 74 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") 75 75 . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") … … 114 114 . . ; To protect against failure, I will put an if/else block 115 115 . . 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. 135 117 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 136 118 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") … … 140 122 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 141 123 . . ; 142 . . ;E S (RXNORM,RXNNAME,RXNVER)=""124 . . E S (RXNORM,RXNNAME,RXNVER)="" 143 125 . . ; End if/else block 144 126 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM … … 179 161 . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 180 162 . . E S @MAP@("MEDQUANTITYUNIT")="" 181 . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these182 163 . E D 183 164 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" … … 200 181 . ; MEDDIRECTIONDESCRIPTIONTEXT 201 182 . 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") 231 184 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. 232 185 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" … … 260 213 . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field 261 214 . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" 262 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl263 215 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 264 216 . K @RESULT -
ccr/branches/ohum/p/C0CMED6.m
r691 r1325 1 1 C0CMED6 ; 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 3 3 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 4 ; General Public License See attached copy of the License. … … 165 165 . ; we want the components. 166 166 . ; It's in multiple 113 in the Prescription File (52) 167 . ; #.01 DOSAGE ORDERED [1F] 168 . ; #1 DISPENSE UNITS PER DOSE [2N] 169 . ; #2 UNITS [3P:50.607] 170 . ; #3 NOUN [4F] 171 . ; #4 DURATION [5F] 172 . ; #5 CONJUNCTION [6S] 173 . ; #6 ROUTE [7P:51.2] 174 . ; #7 SCHEDULE [8F] 175 . ; #8 VERB [9F] 167 . ; #.01 DOSAGE ORDERED [1F] "20" 168 . ; #1 DISPENSE UNITS PER DOSE [2N] "1" 169 . ; #2 UNITS [3P:50.607] "MG" 170 . ; #3 NOUN [4F] "TABLET" 171 . ; #4 DURATION [5F] "10D" 172 . ; #5 CONJUNCTION [6S] "AND" 173 . ; #6 ROUTE [7P:51.2] "ORAL" 174 . ; #7 SCHEDULE [8F] "BID" 175 . ; #8 VERB [9F] "TAKE" 176 176 . ; 177 177 . ; Will use GETS^DIQ to get fields. … … 306 306 Q 307 307 ; 308 GETRXN(NDC) 308 GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm 309 309 ;; Get RxNorm Concept Number for a Given NDC 310 310 ; -
ccr/branches/ohum/p/C0CMXML.m
r1206 r1325 1 1 C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate;Build 3 82 ;;0.1;C0C;nopatch;noreleasedate;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CMXMLB.m
r1204 r1325 6 6 ;DOCTYPE - Want to include a DOCTYPE node 7 7 ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, 8 START(DOC,DOCTYPE,FLAG ,NO1ST) ;Call this once at the begining.8 START(DOC,DOCTYPE,FLAG) ;Call this once at the begining. 9 9 K ^TMP("MXMLBLD",$J) 10 10 S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 11 11 I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 12 I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) 13 D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">") 12 D OUTPUT($$XMLHDR) D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">") 14 13 Q 15 14 ; … … 42 41 Q S 43 42 ; 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)="" 43 Q(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)="" 49 46 F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q 50 47 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) 53 49 ; 54 50 XMLHDR() ; -- provides current XML standard header -
ccr/branches/ohum/p/C0CMXP.m
r1206 r1325 1 1 C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate;Build 3 82 ;;0.1;C0C;nopatch;noreleasedate;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CPARMS.m
r1206 r1325 1 1 C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. … … 38 38 ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS 39 39 ; 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 49 68 Q 50 69 ; -
ccr/branches/ohum/p/C0CPROBS.m
r1206 r1325 1 1 C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. … … 60 60 . S @VMAP@("PROBLEMCODINGVERSION")="" 61 61 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3) 62 . ; FOR CERTIFICATION - GPL63 . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=49364 62 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") 65 63 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") … … 112 110 . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") 113 111 . 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 116 113 . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) 117 114 . S @VMAP@("PROBLEMCODINGVERSION")="" 118 115 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) 119 . ; FOR CERTIFICATION - GPL120 . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493121 116 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") 122 117 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") -
ccr/branches/ohum/p/C0CPROC.m
r1206 r1325 1 1 C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 2 ;;1.0;C0C;;Jan 21, 2010;Build 3 82 ;;1.0;C0C;;Jan 21, 2010;Build 39 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. … … 26 26 S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) 27 27 S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) 28 ; ADDITION FOR CERTIFICATION29 S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))30 28 Q 31 29 ; … … 80 78 . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET 81 79 . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET 82 . . . ; additions for Certification - need to have EKG in Results83 . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT84 80 . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ 85 81 . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS … … 87 83 . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE 88 84 . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY 89 . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl90 . . . W !,"CPT=",ZCPT91 . . . I ZCPT["93000" D ; THIS IS AN EKG92 . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS93 . . . . M ^GPL("RNF2")=@C0CPRSLT94 85 . . . S PREVCPT=ZCPT 95 86 . . . S PREVDT=ZDATE -
ccr/branches/ohum/p/C0CRIMA.m
r1206 r1325 1 1 C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. … … 415 415 I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES 416 416 N ZLST 417 S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE417 S LSTRTN(0)=0 ; DEFAULT RETURN NONE 418 418 S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES 419 419 S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS … … 430 430 . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT 431 431 S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS 432 S ZPAT= 0; START AT FIRST PATIENT IN LIST432 S ZPAT="" ; START AT FIRST PATIENT IN LIST 433 433 F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ; 434 434 . S ZCNT=ZCNT+1 … … 438 438 DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR 439 439 ; 440 ;N ZR441 D PCLST( "ZR",CATTR)440 N ZR 441 D PCLST(.ZR,CATTR) 442 442 I ZR(0)=0 D Q ; 443 443 . W "NO PATIENTS RETURNED",! 444 444 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),! 450 447 Q 451 448 ; -
ccr/branches/ohum/p/C0CRNF.m
r1206 r1325 1 1 C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CRXN.m
r1206 r1325 1 1 C0CRXN ; CCDCCR/GPL - CCR RXN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CSOAP.m
r1206 r1325 1 1 C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CSUB1.m
r1206 r1325 1 1 C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CSYS.m
r1206 r1325 1 1 C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 4 ; General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CUNIT.m
r1206 r1325 1 1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CUTIL.m
r1206 r1325 1 1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 ;;0.1;C0C;;Jun 15, 2008;Build 3 82 ;;0.1;C0C;;Jun 15, 2008;Build 39 3 3 ;Copyright 2008-2009 Sam Habiel & George Lilly. 4 4 ;Licensed under the terms of the GNU … … 135 135 Q 136 136 ; 137 RXNFN() Q 1130590011.001 ; RxNorm Concepts file number138 ;139 CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF140 ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR141 N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT142 I $G(ZVUID)="" Q ""143 I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED144 N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")145 S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES146 N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)147 S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED148 I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"149 Q ZRSLT150 ;151 NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO152 ; CONFORM TO NIST REQUIREMENTS153 ;INPATIENT CERTIFICATION154 I ZRXN=309362 S ZRXN=213169155 I ZRXN=855318 S ZRXN=855320156 I ZRXN=197361 S ZRXN=212549157 ;OUTPATIENT CERTIFICATION158 I ZRXN=310534 S ZRXN=205875159 I ZRXN=617312 S ZRXN=617314160 I ZRXN=310429 S ZRXN=200801161 I ZRXN=628953 S ZRXN=628958162 I ZRXN=745679 S ZRXN=630208163 I ZRXN=311564 S ZRXN=979334164 I ZRXN=836343 S ZRXN=836370165 Q ZRXN166 ;167 137 RPMS() ; Are we running on an RPMS system rather than Vista? 168 138 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service -
ccr/branches/ohum/p/C0CVA200.m
r1206 r1325 1 1 C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CVIT2.m
r1206 r1325 1 1 C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 2 ;;1.0;C0C;;Feb 16, 2010;Build 3 82 ;;1.0;C0C;;Feb 16, 2010;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CVITAL.m
r1206 r1325 1 1 C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. … … 58 58 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 59 59 D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 60 I DEBUG ZWR VDATES ;DEBUG60 ; I DEBUG ZWR VDATES ;DEBUG 61 61 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 62 62 ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY … … 72 72 . . I DEBUG W $P(VITPTMP,U,4),! 73 73 . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID 74 . . ;B ;gpl75 . . 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"78 74 . . I $P(VITPTMP,U,2)="HT" D 79 75 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" … … 87 83 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 88 84 . . . 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) 90 86 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 91 87 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" … … 101 97 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 102 98 . . . 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) 104 100 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 105 101 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" 106 102 . . E I $P(VITPTMP,U,2)="BP" D 107 103 . . . 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") 109 105 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 110 106 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" … … 115 111 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 116 112 . . . 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) 118 114 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 119 115 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" … … 129 125 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 130 126 . . . 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) 132 128 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 133 129 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" … … 143 139 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 144 140 . . . 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) 146 142 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 147 143 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" … … 157 153 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 158 154 . . . 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) 160 156 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 161 157 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" … … 171 167 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 172 168 . . . 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) 188 170 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 189 171 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" … … 200 182 . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" 201 183 . . . ;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) 203 185 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 204 186 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" 205 . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ;206 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;207 187 . . S VITARYTMP=$NA(@VITTARYTMP@(J)) 208 188 . . K @VITARYTMP -
ccr/branches/ohum/p/C0CXPAT0.m
r1206 r1325 1 1 C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CXPATH.m
r1206 r1325 1 1 C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 2 ;;1.0;C0C;;May 19, 2009;Build 3 82 ;;1.0;C0C;;May 19, 2009;Build 39 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/VWTIME.m
r1213 r1325 1 VWTIME 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 DIF(SD,ED) 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 BRIEF(SD,ED) 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 TDIFF(BF) 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 F2D(X) 209 210 211 212 213 H2D(X) 214 215 216 217 218 LONGAGE(VWAGE,VWDFN) 219 220 221 222 223 224 BRFAGE(VWAGE,VWDFN) 225 226 227 228 229 230 RPCREG 231 232 233 234 235 236 237 238 239 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 ; ============
Note:
See TracChangeset
for help on using the changeset viewer.
