Index: /ccr/branches/ohum/p/C0CACTOR.m
===================================================================
--- /ccr/branches/ohum/p/C0CACTOR.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CACTOR.m (revision 1325)
@@ -1,4 +1,4 @@
C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CALERT.m
===================================================================
--- /ccr/branches/ohum/p/C0CALERT.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CALERT.m (revision 1325)
@@ -1,4 +1,4 @@
C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
@@ -56,5 +56,5 @@
. S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy
. N ALTCDE ; SNOMED CODE THE THE ALERT
- . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
+ . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
. S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ;
. ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE
@@ -81,11 +81,7 @@
. S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT
. S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM
- . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
- . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
+ . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID
. I ACVUID'="" D ; IF VUID IS NOT NULL
- . . S ZC=$$CODE^C0CUTIL(ACVUID)
- . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
- . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
- . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
+ . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID"
. E D ; IF REACTANT CODE VALUE IS NULL
. . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS
@@ -94,8 +90,4 @@
. . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=""
. . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=""
- . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD
- . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS
- . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD
- . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD
. ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW
. N ARTMP,ARIEN,ARDES,ARVUID
Index: /ccr/branches/ohum/p/C0CBAT.m
===================================================================
--- /ccr/branches/ohum/p/C0CBAT.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CBAT.m (revision 1325)
@@ -1,4 +1,4 @@
C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CCCD.m
===================================================================
--- /ccr/branches/ohum/p/C0CCCD.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CCCD.m (revision 1325)
@@ -1,4 +1,4 @@
C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CCCD1.m
===================================================================
--- /ccr/branches/ohum/p/C0CCCD1.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CCCD1.m (revision 1325)
@@ -1,4 +1,4 @@
C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CCCR.m
===================================================================
--- /ccr/branches/ohum/p/C0CCCR.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CCCR.m (revision 1325)
@@ -1,4 +1,4 @@
C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
@@ -26,4 +26,7 @@
I Y<1 Q ; EXIT
S DFN=$P(Y,U,1) ; SET THE PATIENT
+ ;OHUM/RUT 3111222 To take inputs from user for date limits and notes
+ D ^C0CVALID
+ ;OHUM/RUT
D XPAT(DFN) ; EXPORT TO A FILE
Q
@@ -103,5 +106,4 @@
D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
- D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")
I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
;
@@ -135,8 +137,7 @@
D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
K ACTT,ACTT2
- ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
- ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
- ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
- ; gpl - turned off Comments for Certification
+ D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
+ D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
+ D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
K CMTT,CMTT2
N TRIMI,J,DONE S DONE=0
@@ -166,6 +167,8 @@
D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")")
D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")")
+ ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
- ; gpl - turned off Encounters for Certification
+ I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
+ ;OHUM/RUT
Q
;
Index: /ccr/branches/ohum/p/C0CCCR0.m
===================================================================
--- /ccr/branches/ohum/p/C0CCCR0.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CCCR0.m (revision 1325)
@@ -1,4 +1,4 @@
C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
@@ -792,4 +792,15 @@
;;
;;
+ ;;
+ ;;
+ ;;@@IDTYPE@@
+ ;;
+ ;;@@ID@@
+ ;;
+ ;;
+ ;;@@IDDESC@@
+ ;;
+ ;;
+ ;;
;;
;;@@ACTORSPECIALITY@@
Index: /ccr/branches/ohum/p/C0CCMT.m
===================================================================
--- /ccr/branches/ohum/p/C0CCMT.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CCMT.m (revision 1325)
@@ -1,4 +1,4 @@
C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
- ;;1.0;C0C;;May 21, 2010;Build 38
+ ;;1.0;C0C;;May 21, 2010;Build 39
;Copyright 2010 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CCPT.m
===================================================================
--- /ccr/branches/ohum/p/C0CCPT.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CCPT.m (revision 1325)
@@ -1,4 +1,4 @@
C0CCPT ;;BSL;RETURN CPT DATA;
- ;Sequence Managers Software GPL;;;;;Build 38
+ ;Sequence Managers Software GPL;;;;;Build 39
;Copied into C0C namespace from SQMCPT with permission from
;Brian Lord - and with our thanks. gpl 01/20/2010
@@ -19,4 +19,7 @@
;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
;GET DATE OF NOTE
+ ;OHUM/RUT 3111228 Date Range for Notes
+ S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
+ ;OHUM/RUT
S Z=""
F S Z=$O(NOTE(Z)) Q:Z="" D
Index: /ccr/branches/ohum/p/C0CDPT.m
===================================================================
--- /ccr/branches/ohum/p/C0CDPT.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CDPT.m (revision 1325)
@@ -1,4 +1,4 @@
C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;
; Copyright 2008 WorldVistA. Licensed under the terms of the GNU
Index: /ccr/branches/ohum/p/C0CENC.m
===================================================================
--- /ccr/branches/ohum/p/C0CENC.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CENC.m (revision 1325)
@@ -1,4 +1,4 @@
C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
- ;;1.0;C0C;;May 21, 2010;Build 38
+ ;;1.0;C0C;;May 21, 2010;Build 39
;Copyright 2010 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CENV.m
===================================================================
--- /ccr/branches/ohum/p/C0CENV.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CENV.m (revision 1325)
@@ -1,4 +1,4 @@
C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
- ;;1.0;C0C;;May 19, 2009;
+ ;;1.0;C0C;;May 19, 2009;Build 40
;
;
@@ -22,5 +22,5 @@
;
CHECK ; Perform environment check
- ;
+ ;
I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
. D BMES("Terminal Device is not defined")
@@ -34,162 +34,162 @@
. D BMES("You are not a valid user on this system")
. S XPDQUIT=2
- Q
- ;
- ;
+ Q
+ ;
+ ;
EXIT ;
- ;
- ;
+ ;
+ ;
I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
D BMES("--- Environment Check is Ok ---")
- ;
+ ;
Q
- ;
- ;
+ ;
+ ;
PRE ;Pre-install entry point
- ;
- ; No action needed in pre-install
- D BMES("No action need for pre-install")
- ;
- Q
- ;
- ;
+ ;
+ ; No action needed in pre-install
+ D BMES("No action need for pre-install")
+ ;
+ Q
+ ;
+ ;
POST ;Post install
- ;
- ; Check for RPMS system with V LAB file.
- ;
- I $$VFILE^DILFD(9000010.09)'=1 Q
- ;
- S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
- S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
- S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
- S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
- S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
- S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
- S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
- ;
- Q
- ;
- ;
-POST1 ; Checkpoint call back entry point.
- ; Add new style ALR1 cross-reference to V LAB file.
- ;
- N MSG
- S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- D ALR1^C0CLA7DD
- S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- Q
- ;
- ;
-POST2 ; Checkpoint call back entry point.
- ; Add new style ALR2 cross-reference to V LAB file.
- ;
- N MSG
- S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- D ALR2^C0CLA7DD
- S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- Q
- ;
- ;
-POST3 ; Checkpoint call back entry point.
- ; Add new style ALR3 cross-reference to V LAB file.
- ;
- N MSG
- S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- D ALR3^C0CLA7DD
- S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- Q
- ;
- ;
-POST4 ; Checkpoint call back entry point.
- ; Add new style ALR4 cross-reference to V LAB file.
- ;
- N MSG
- S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- D ALR4^C0CLA7DD
- S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- Q
- ;
- ;
-POST5 ; Checkpoint call back entry point.
- ; Add new style ALR5 cross-reference to V LAB file.
- ;
- N MSG
- S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- D ALR5^C0CLA7DD
- S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
- D BMES(MSG)
- Q
- ;
- ;
+ ;
+ ; Check for RPMS system with V LAB file.
+ ;
+ I $$VFILE^DILFD(9000010.09)'=1 Q
+ ;
+ S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
+ ;
+ Q
+ ;
+ ;
+POST1 ; Checkpoint call back entry point.
+ ; Add new style ALR1 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR1^C0CLA7DD
+ S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST2 ; Checkpoint call back entry point.
+ ; Add new style ALR2 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR2^C0CLA7DD
+ S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST3 ; Checkpoint call back entry point.
+ ; Add new style ALR3 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR3^C0CLA7DD
+ S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST4 ; Checkpoint call back entry point.
+ ; Add new style ALR4 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR4^C0CLA7DD
+ S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST5 ; Checkpoint call back entry point.
+ ; Add new style ALR5 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR5^C0CLA7DD
+ S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
POST6 ; Checkpoint call back entry point.
- ; Check for RPMS system and determine LAB patch level
- ; and need to load in C0C version of LA7 routines.
- ;
- N MSG
- ;
- ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
- I '$$PATCH^XPDUTL("LA*5.2*69") D
- . S MSG="This system missing LAB patch LA*5.2*69"
- . D BMES(MSG)
- . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
- . D BMES(MSG)
- . D LOAD("C0CQRY2")
- . D SAVE("C0CQRY2","LA7QRY2")
- ;
- ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
- I '$$PATCH^XPDUTL("LA*5.2*64") D
- . S MSG="This system missing LAB patch LA*5.2*64"
- . D BMES(MSG)
- . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
- . D BMES(MSG)
- . D LOAD("C0CVOBX1")
- . D SAVE("C0CVOBX1","LA7VOBX1")
- ;
- ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
- I '$$PATCH^XPDUTL("LA*5.2*68") D
- . S MSG="This system missing LAB patch LA*5.2*68"
- . D BMES(MSG)
- . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
- . D BMES(MSG)
- . D LOAD("C0CQRY1")
- . D SAVE("C0CQRY1","LA7QRY1")
- ;
- Q
- ;
- ;
-POST7 ; Checkpoint call back entry point.
- ;
- D REINDEX^C0CLA7DD
- ;
- Q
- ;
- ;
+ ; Check for RPMS system and determine LAB patch level
+ ; and need to load in C0C version of LA7 routines.
+ ;
+ N MSG
+ ;
+ ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
+ I '$$PATCH^XPDUTL("LA*5.2*69") D
+ . S MSG="This system missing LAB patch LA*5.2*69"
+ . D BMES(MSG)
+ . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
+ . D BMES(MSG)
+ . D LOAD("C0CQRY2")
+ . D SAVE("C0CQRY2","LA7QRY2")
+ ;
+ ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
+ I '$$PATCH^XPDUTL("LA*5.2*64") D
+ . S MSG="This system missing LAB patch LA*5.2*64"
+ . D BMES(MSG)
+ . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
+ . D BMES(MSG)
+ . D LOAD("C0CVOBX1")
+ . D SAVE("C0CVOBX1","LA7VOBX1")
+ ;
+ ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
+ I '$$PATCH^XPDUTL("LA*5.2*68") D
+ . S MSG="This system missing LAB patch LA*5.2*68"
+ . D BMES(MSG)
+ . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
+ . D BMES(MSG)
+ . D LOAD("C0CQRY1")
+ . D SAVE("C0CQRY1","LA7QRY1")
+ ;
+ Q
+ ;
+ ;
+POST7 ; Checkpoint call back entry point.
+ ;
+ D REINDEX^C0CLA7DD
+ ;
+ Q
+ ;
+ ;
BMES(STR) ; Write BMES^XPDUTL statements
- ;
- D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
- ;
- Q
- ;
- ;
-LOAD(X) ; load routine X
- N %N,DIF,XCNP
- K ^TMP($J,X)
- S DIF="^TMP($J,X,",XCNP=0
- X ^%ZOSF("LOAD")
- Q
- ;
- ;
-SAVE(OLD,NEW) ; restore routine X
- N %,DIE,X,XCM,XCN,XCS
- S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
- X ^%ZOSF("SAVE")
- Q
+ ;
+ D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
+ ;
+ Q
+ ;
+ ;
+LOAD(X) ; load routine X
+ N %N,DIF,XCNP
+ K ^TMP($J,X)
+ S DIF="^TMP($J,X,",XCNP=0
+ X ^%ZOSF("LOAD")
+ Q
+ ;
+ ;
+SAVE(OLD,NEW) ; restore routine X
+ N %,DIE,X,XCM,XCN,XCS
+ S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
+ X ^%ZOSF("SAVE")
+ Q
Index: /ccr/branches/ohum/p/C0CEVC.m
===================================================================
--- /ccr/branches/ohum/p/C0CEVC.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CEVC.m (revision 1325)
@@ -74,6 +74,5 @@
N ZT,ZDFN
S ZT=$$URLTOKEN^C0CEWD(sessid)
- ;S ^TMP("GPL")=ZT
- d trace^%zewdAPI("*********************ZT="_ZT)
+ S ^TMP("GPL")=ZT
S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
S ^TMP("GPL","DFN")=ZDFN
Index: /ccr/branches/ohum/p/C0CEWD.m
===================================================================
--- /ccr/branches/ohum/p/C0CEWD.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CEWD.m (revision 1325)
@@ -1,4 +1,4 @@
C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
- ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
+ ;;0.1;CCDCCR;nopatch;noreleasedate
;Copyright 2011 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
@@ -48,5 +48,5 @@
Q token
;
-cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options)
+cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options)
;
n maxNo,noFound
Index: /ccr/branches/ohum/p/C0CFM1.m
===================================================================
--- /ccr/branches/ohum/p/C0CFM1.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CFM1.m (revision 1325)
@@ -1,4 +1,4 @@
C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CFM2.m
===================================================================
--- /ccr/branches/ohum/p/C0CFM2.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CFM2.m (revision 1325)
@@ -1,4 +1,4 @@
C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CIM2.m
===================================================================
--- /ccr/branches/ohum/p/C0CIM2.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CIM2.m (revision 1325)
@@ -1,4 +1,4 @@
C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
- ;;1.0;C0C;;Feb 16, 2010;Build 38
+ ;;1.0;C0C;;Feb 16, 2010;Build 39
;Copyright 2010 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CIMMU.m
===================================================================
--- /ccr/branches/ohum/p/C0CIMMU.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CIMMU.m (revision 1325)
@@ -1,4 +1,4 @@
C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CIN.m
===================================================================
--- /ccr/branches/ohum/p/C0CIN.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CIN.m (revision 1325)
@@ -1,4 +1,4 @@
C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
- ;;1.0;C0C;;Sep 20, 2009;Build 38
+ ;;1.0;C0C;;Sep 20, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CLA7Q.m
===================================================================
--- /ccr/branches/ohum/p/C0CLA7Q.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CLA7Q.m (revision 1325)
@@ -1,169 +1,169 @@
-C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
- ;;1.0;C0C;;May 19, 2009;Build 38
- ;
- ;
- Q
- ;
- ;
-LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query
- ;
- ;
- K ^TMP("C0C-VLAB",$J)
- ;
- ; Check and retrieve lab results from LAB DATA file (#63)
- S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
- ;
- ; If V LAB file present then check for lab results that are only in this file
- ; If results found in V Lab file then build results and add to above results.
- I $D(^AUPNVLAB) D
- . D VCHECK
- . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
- ;
- ;K ^TMP("C0C-VLAB",$J)
- ;
- Q C0CDEST
- ;
- ;
-VCHECK ; If V LAB file present then check for lab results that are only in this file.
- ;
- N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
- ;
- S LA7PTID=C0CPTID
- D PATID^LA7QRY2
- I $D(LA7ERR) Q
- ;
- ; Resolve search codes to lab datanames
- S LA7SC=$G(C0CSC)
- I $T(SCLIST^LA7QRY2)'="" D
- . N TMP
- . S LA7SCRC=$G(C0CSC)
- . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
- . S LA7SC=TMP
- ;
- I LA7SC'="*" D CHKSC^LA7QRY1
- ;
- ; Convert specimen codes to file #61 Topography entries
- S LA7SPEC=$G(C0CSPEC)
- I LA7SPEC'="*" D SPEC^LA7QRY1
- ;
- S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
- ;
- F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND
- . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient
- . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time
- . S C0CDA=$QS(C0CROOT,4)
- . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63
- . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip
- . D VCHK1
- ;
- ;
- Q
- ;
- ;
-VBUILD ; Build results found only in V LAB file into HL7 structure.
- ;
- ;
- Q
- ;
- ;
-LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
- ; Call from LA7QRY2
- ;
- N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
- ;
- S DFN=$P(^LR(LRDFN,0),"^",3)
- S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
- S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
- S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
- ;
- ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
- ;
- S C0C60=""
- F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'=""
- . D FINDDT
- . I C0CDA<1 Q
- . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip
- . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
- . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
- . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
- . I C0CPDA="" S C0CPDA=C0CDA
- . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
- . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
- . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
- . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
- . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
- . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
- . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
- ;
- S X=$P(LA7X,"^",3)
- ; If order NLT then update if no order NLT
- I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
- ;
- ; If result NLT then update if no result NLT
- I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
- ;
- ; If LOINC found then update variable with LN code
- I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
- ;
- S $P(LA7X,"^",3)=X
- ;
- Q
- ;
- ;
-TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
- ; Called from LA7VOBX1
- ;
- N I,X
- ;
- S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
- I X="" Q
- F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
- S $P(LA7VAL,"^",3)=LA7X
- ;
- Q
- ;
- ;
-VCHK1 ; Check the entry in V Lab to determine if it meets criteria
- ;
- N C0CVLAB,I
- ;
- F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
- ;
- ; JMC 04/13/09 - Store anything for now that meets date criteria.
- D VSTORE
- ;
- Q
- ;
- ;
-VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
- ;
- N C0CPDA,C0CPTEST
- ;
- ; Determine parent test to use for OBR segment
- S C0CPDA=$P(C0CVLAB(12),"^",8)
- I C0CPDA="" S C0CPDA=C0CDA
- ;
- ; Determine parent test
- S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
- ;
- S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
- ;
- Q
- ;
- ;
-FINDDT ; Find entry in V LAB for the date/time or one close to it.
- ; RPMS stores related specimen entries under the same date/time.
- ; Lab file #63 creates unique entries with slightly different times.
- ;
- S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
- I C0CDA>0 Q
- ;
- ; If entry found then confirm that specimen type matches.
- N C0CDTY
- S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
- I C0CDTY D
- . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
- . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
- . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
- ;
- Q
+C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
+ ;;1.0;C0C;;May 19, 2009;Build 39
+ ;
+ ;
+ Q
+ ;
+ ;
+LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query
+ ;
+ ;
+ K ^TMP("C0C-VLAB",$J)
+ ;
+ ; Check and retrieve lab results from LAB DATA file (#63)
+ S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
+ ;
+ ; If V LAB file present then check for lab results that are only in this file
+ ; If results found in V Lab file then build results and add to above results.
+ I $D(^AUPNVLAB) D
+ . D VCHECK
+ . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
+ ;
+ ;K ^TMP("C0C-VLAB",$J)
+ ;
+ Q C0CDEST
+ ;
+ ;
+VCHECK ; If V LAB file present then check for lab results that are only in this file.
+ ;
+ N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
+ ;
+ S LA7PTID=C0CPTID
+ D PATID^LA7QRY2
+ I $D(LA7ERR) Q
+ ;
+ ; Resolve search codes to lab datanames
+ S LA7SC=$G(C0CSC)
+ I $T(SCLIST^LA7QRY2)'="" D
+ . N TMP
+ . S LA7SCRC=$G(C0CSC)
+ . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
+ . S LA7SC=TMP
+ ;
+ I LA7SC'="*" D CHKSC^LA7QRY1
+ ;
+ ; Convert specimen codes to file #61 Topography entries
+ S LA7SPEC=$G(C0CSPEC)
+ I LA7SPEC'="*" D SPEC^LA7QRY1
+ ;
+ S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
+ ;
+ F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND
+ . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient
+ . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time
+ . S C0CDA=$QS(C0CROOT,4)
+ . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63
+ . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip
+ . D VCHK1
+ ;
+ ;
+ Q
+ ;
+ ;
+VBUILD ; Build results found only in V LAB file into HL7 structure.
+ ;
+ ;
+ Q
+ ;
+ ;
+LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
+ ; Call from LA7QRY2
+ ;
+ N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
+ ;
+ S DFN=$P(^LR(LRDFN,0),"^",3)
+ S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
+ S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
+ S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
+ ;
+ ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
+ ;
+ S C0C60=""
+ F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'=""
+ . D FINDDT
+ . I C0CDA<1 Q
+ . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip
+ . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
+ . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
+ . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
+ . I C0CPDA="" S C0CPDA=C0CDA
+ . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
+ . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
+ . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
+ . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
+ . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
+ . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
+ . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
+ ;
+ S X=$P(LA7X,"^",3)
+ ; If order NLT then update if no order NLT
+ I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
+ ;
+ ; If result NLT then update if no result NLT
+ I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
+ ;
+ ; If LOINC found then update variable with LN code
+ I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
+ ;
+ S $P(LA7X,"^",3)=X
+ ;
+ Q
+ ;
+ ;
+TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
+ ; Called from LA7VOBX1
+ ;
+ N I,X
+ ;
+ S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
+ I X="" Q
+ F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
+ S $P(LA7VAL,"^",3)=LA7X
+ ;
+ Q
+ ;
+ ;
+VCHK1 ; Check the entry in V Lab to determine if it meets criteria
+ ;
+ N C0CVLAB,I
+ ;
+ F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
+ ;
+ ; JMC 04/13/09 - Store anything for now that meets date criteria.
+ D VSTORE
+ ;
+ Q
+ ;
+ ;
+VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
+ ;
+ N C0CPDA,C0CPTEST
+ ;
+ ; Determine parent test to use for OBR segment
+ S C0CPDA=$P(C0CVLAB(12),"^",8)
+ I C0CPDA="" S C0CPDA=C0CDA
+ ;
+ ; Determine parent test
+ S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
+ ;
+ S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
+ ;
+ Q
+ ;
+ ;
+FINDDT ; Find entry in V LAB for the date/time or one close to it.
+ ; RPMS stores related specimen entries under the same date/time.
+ ; Lab file #63 creates unique entries with slightly different times.
+ ;
+ S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
+ I C0CDA>0 Q
+ ;
+ ; If entry found then confirm that specimen type matches.
+ N C0CDTY
+ S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
+ I C0CDTY D
+ . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
+ . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
+ . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
+ ;
+ Q
Index: /ccr/branches/ohum/p/C0CLABS.m
===================================================================
--- /ccr/branches/ohum/p/C0CLABS.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CLABS.m (revision 1325)
@@ -1,4 +1,4 @@
C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
@@ -130,6 +130,4 @@
S C0CQT=1 ; SURPRESS LISTING
D LIST ; EXTRACT THE VARIABLES
- ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD
- D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS
S C0CQT=QTSAV ; RESET SILENT FLAG
K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT
@@ -154,5 +152,4 @@
W "LAB LIMIT: ",C0CLLMT,!
D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM
- S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW
S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP
Q
@@ -175,9 +172,4 @@
. S C0CTYP=$P(@C0CHB@(C0CI),"|",1)
. D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT)
- . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification
- . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT
- . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION
- . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE
- . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD
. M XV=C0CVAR ;
. I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION
@@ -199,6 +191,5 @@
. . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE
. . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
- . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT
- . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1")
+ . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT
. . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC
. . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE
Index: /ccr/branches/ohum/p/C0CMCCD.m
===================================================================
--- /ccr/branches/ohum/p/C0CMCCD.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMCCD.m (revision 1325)
@@ -149,10 +149,7 @@
S ZI=""
F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY
- . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES
- . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor
- . E D ; FOR BODY PARTS
- . . S ZJ=$P(ZI,"/",2) ;
- . . I ZJ="" S ZJ=$P(ZI,"/",3) ;
- . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS
+ . S ZJ=$P(ZI,"/",2) ;
+ . I ZJ="" S ZJ=$P(ZI,"/",3) ;
+ . S @OUTARY@(ZJ,ZI)=@INARY@(ZI)
Q
;
Index: /ccr/branches/ohum/p/C0CMED.m
===================================================================
--- /ccr/branches/ohum/p/C0CMED.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMED.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
; Licensed under the terms of the GNU General Public License.
@@ -79,13 +79,9 @@
S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
; N IPIV ; Inpatient IV Meds
- N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds
- K @IPUD
- S @IPUD@(0)=0
- ;
+ ; N IPUD ; Inpatient UD Meds
D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds
;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds
D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL
- D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl
I @HIST@(0)>0 D
. D CP^C0CXPATH(HIST,MEDOUTXML)
@@ -99,8 +95,4 @@
. E D CP^C0CXPATH(NVA,MEDOUTXML)
. W:$G(DEBUG) "HAS NON-VA MEDS",!
- I @IPUD@(0)>0 D
- . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD)
- . E D CP^C0CXPATH(IPUD,MEDOUTXML)
- . W:$G(DEBUG) "HAS INPATIENT MEDS",!
N ZI
S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
@@ -110,5 +102,4 @@
K @HIST
K @NVA
- K @IPUD
Q
Index: /ccr/branches/ohum/p/C0CMED1.m
===================================================================
--- /ccr/branches/ohum/p/C0CMED1.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMED1.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;;Last modified Sat Jan 10 21:42:27 PST 2009
; Copyright 2009 WorldVistA. Licensed under the terms of the GNU
@@ -72,5 +72,5 @@
. S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U))
. S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
- . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U))
+ . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MED(101),U))
. S @MAP@("MEDRXNOTXT")="Prescription Number"
. S @MAP@("MEDRXNO")=MED(.01)
Index: /ccr/branches/ohum/p/C0CMED2.m
===================================================================
--- /ccr/branches/ohum/p/C0CMED2.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMED2.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;;Last Modified Sat Jan 10 21:41:14 PST 2009
; Copyright 2008 WorldVistA. Licensed under the terms of the GNU
Index: /ccr/branches/ohum/p/C0CMED3.m
===================================================================
--- /ccr/branches/ohum/p/C0CMED3.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMED3.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
; Copyright 2009 WorldVistA. Licensed under the terms of the GNU
@@ -71,5 +71,5 @@
. S @MAP@("MEDTYPETEXT")="Medication"
. S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses
- . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds
+ . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds
. S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I")
. S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E")
@@ -114,23 +114,5 @@
. . ; To protect against failure, I will put an if/else block
. . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
- . . ;
- . . ; begin changes for systems that have eRx installed
- . . ; RxNorm is found in the ^C0P("RXN") global - gpl
- . . ;
- . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
- . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
- . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE
- . . I NDFIEN,$D(^C0P("RXN")) D ;
- . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
- . . . S ZC=$$CODE^C0CUTIL(VUID)
- . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
- . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
- . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
- . . . S RXNORM=ZCD ; THE CODE
- . . . S RXNNAME=ZCDS ; THE CODING SYSTEM
- . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION
- . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
- . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD
- . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet.
+ . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet.
. . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
. . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
@@ -140,5 +122,5 @@
. . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
. . ;
- . . ;E S (RXNORM,RXNNAME,RXNVER)=""
+ . . E S (RXNORM,RXNNAME,RXNVER)=""
. . ; End if/else block
. . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
@@ -179,5 +161,4 @@
. . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
. . E S @MAP@("MEDQUANTITYUNIT")=""
- . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
. E D
. . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
@@ -200,33 +181,5 @@
. ; MEDDIRECTIONDESCRIPTIONTEXT
. S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS
- . ;
- . ; change for eRx meds - gpl 6/25/2011
- . ;
- . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
- . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME
- . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX
- . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity
- . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME
- . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME
- . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME
- . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM
- . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY
- . . I RXNORM'="" D ;
- . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM
- . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM
- . . . S RXNVER="" ; THE CODING SYSTEM VERSION
- . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
- . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM
- . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
- . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
- . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
- . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION
- . . . . S @MAP@("MEDSTRENGTHVALUE")=650
- . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg"
- . . . . S @MAP@("MEDFORMTEXT")="INHALER"
- . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS
- . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY
- . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ;
- . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
+ . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
. S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05.
. S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
@@ -260,5 +213,4 @@
. . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
. E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
- . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl
. N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
. K @RESULT
Index: /ccr/branches/ohum/p/C0CMED6.m
===================================================================
--- /ccr/branches/ohum/p/C0CMED6.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMED6.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
- ;;1.0;C0C;;May 19, 2009;
+ ;;1.0;C0C;;May 19, 2009;Build 39
; Copyright 2008 WorldVistA. Licensed under the terms of the GNU
; General Public License See attached copy of the License.
@@ -165,13 +165,13 @@
. ; we want the components.
. ; It's in multiple 113 in the Prescription File (52)
- . ; #.01 DOSAGE ORDERED [1F] "20"
- . ; #1 DISPENSE UNITS PER DOSE [2N] "1"
- . ; #2 UNITS [3P:50.607] "MG"
- . ; #3 NOUN [4F] "TABLET"
- . ; #4 DURATION [5F] "10D"
- . ; #5 CONJUNCTION [6S] "AND"
- . ; #6 ROUTE [7P:51.2] "ORAL"
- . ; #7 SCHEDULE [8F] "BID"
- . ; #8 VERB [9F] "TAKE"
+ . ; #.01 DOSAGE ORDERED [1F] "20"
+ . ; #1 DISPENSE UNITS PER DOSE [2N] "1"
+ . ; #2 UNITS [3P:50.607] "MG"
+ . ; #3 NOUN [4F] "TABLET"
+ . ; #4 DURATION [5F] "10D"
+ . ; #5 CONJUNCTION [6S] "AND"
+ . ; #6 ROUTE [7P:51.2] "ORAL"
+ . ; #7 SCHEDULE [8F] "BID"
+ . ; #8 VERB [9F] "TAKE"
. ;
. ; Will use GETS^DIQ to get fields.
@@ -306,5 +306,5 @@
Q
;
-GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm
+GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm
;; Get RxNorm Concept Number for a Given NDC
;
Index: /ccr/branches/ohum/p/C0CMXML.m
===================================================================
--- /ccr/branches/ohum/p/C0CMXML.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMXML.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05
- ;;0.1;C0C;nopatch;noreleasedate;Build 38
+ ;;0.1;C0C;nopatch;noreleasedate;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CMXMLB.m
===================================================================
--- /ccr/branches/ohum/p/C0CMXMLB.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMXMLB.m (revision 1325)
@@ -6,10 +6,9 @@
;DOCTYPE - Want to include a DOCTYPE node
;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
-START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining.
+START(DOC,DOCTYPE,FLAG) ;Call this once at the begining.
K ^TMP("MXMLBLD",$J)
S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
- I $G(NO1ST)'=1 D OUTPUT($$XMLHDR)
- D:$L($G(DOCTYPE)) OUTPUT("") D OUTPUT("<"_DOC_">")
+ D OUTPUT($$XMLHDR) D:$L($G(DOCTYPE)) OUTPUT("") D OUTPUT("<"_DOC_">")
Q
;
@@ -42,13 +41,10 @@
Q S
;
-Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
- ;I X'[$C(34) Q $C(34)_X_$C(34)
- I X'[$C(39) Q $C(39)_X_$C(39)
- ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
- N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
+Q(X) ;Add Quotes
+ I X'[$C(34) Q $C(34)_X_$C(34)
+ N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
S Y=Y_$P(X,Q,$L(X,Q))
- ;Q $C(34)_Y_$C(34)
- Q $C(39)_Y_$C(39)
+ Q $C(34)_Y_$C(34)
;
XMLHDR() ; -- provides current XML standard header
Index: /ccr/branches/ohum/p/C0CMXP.m
===================================================================
--- /ccr/branches/ohum/p/C0CMXP.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CMXP.m (revision 1325)
@@ -1,4 +1,4 @@
C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05
- ;;0.1;C0C;nopatch;noreleasedate;Build 38
+ ;;0.1;C0C;nopatch;noreleasedate;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CPARMS.m
===================================================================
--- /ccr/branches/ohum/p/C0CPARMS.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CPARMS.m (revision 1325)
@@ -1,4 +1,4 @@
C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
@@ -38,13 +38,32 @@
; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS
; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS
- I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
- I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
- I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
- I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
- I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
- I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
- I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
- I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
- I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
+ ;OHUM/RUT
+ ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
+ ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
+ ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
+ ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
+ ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
+ ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
+ ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
+ ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
+ ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
+ 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")
+ ;OHUM/RUT
+ ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-36500" ;ONE YR WORTH
+ I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
+ ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-36500" ;ONE YR VITALS
+ I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
+ I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
+ ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-1" ; ONE YR MEDS
+ I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
+ I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
+ I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE
+ ;ELN
+ ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
+ ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
+ ;I '$D(@C0CPARMS@("TIULIMIT")) S @C0CPARMS@("TIULIMIT")="T-2000" ;ONE YR WORTH
+ I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
+ ;ELN
+ ;OHUM/RUT commented the hardcoded limits
Q
;
Index: /ccr/branches/ohum/p/C0CPROBS.m
===================================================================
--- /ccr/branches/ohum/p/C0CPROBS.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CPROBS.m (revision 1325)
@@ -1,4 +1,4 @@
C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
@@ -60,6 +60,4 @@
. S @VMAP@("PROBLEMCODINGVERSION")=""
. S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3)
- . ; FOR CERTIFICATION - GPL
- . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493
. S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT")
. S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT")
@@ -112,11 +110,8 @@
. S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"")
. N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG
- . ; turn off acute/chronic for certification gpl
- . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
+ . S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
. S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
. S @VMAP@("PROBLEMCODINGVERSION")=""
. S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
- . ; FOR CERTIFICATION - GPL
- . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493
. S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT")
. S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT")
Index: /ccr/branches/ohum/p/C0CPROC.m
===================================================================
--- /ccr/branches/ohum/p/C0CPROC.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CPROC.m (revision 1325)
@@ -1,4 +1,4 @@
C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
- ;;1.0;C0C;;Jan 21, 2010;Build 38
+ ;;1.0;C0C;;Jan 21, 2010;Build 39
;Copyright 2010 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
@@ -26,6 +26,4 @@
S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
- ; ADDITION FOR CERTIFICATION
- S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))
Q
;
@@ -80,6 +78,4 @@
. . . S ZRNF("PROCLINKID")="" ; NO LINKS YET
. . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET
- . . . ; additions for Certification - need to have EKG in Results
- . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT
. . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ
. . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS
@@ -87,9 +83,4 @@
. . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE
. . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
- . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
- . . . W !,"CPT=",ZCPT
- . . . I ZCPT["93000" D ; THIS IS AN EKG
- . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
- . . . . M ^GPL("RNF2")=@C0CPRSLT
. . . S PREVCPT=ZCPT
. . . S PREVDT=ZDATE
Index: /ccr/branches/ohum/p/C0CRIMA.m
===================================================================
--- /ccr/branches/ohum/p/C0CRIMA.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CRIMA.m (revision 1325)
@@ -1,4 +1,4 @@
C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota.
;Licensed under the terms of the GNU General Public License.
@@ -415,5 +415,5 @@
I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
N ZLST
- S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE
+ S LSTRTN(0)=0 ; DEFAULT RETURN NONE
S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
@@ -430,5 +430,5 @@
. . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
- S ZPAT=0 ; START AT FIRST PATIENT IN LIST
+ S ZPAT="" ; START AT FIRST PATIENT IN LIST
F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ;
. S ZCNT=ZCNT+1
@@ -438,14 +438,11 @@
DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
;
- ;N ZR
- D PCLST("ZR",CATTR)
+ N ZR
+ D PCLST(.ZR,CATTR)
I ZR(0)=0 D Q ;
. W "NO PATIENTS RETURNED",!
E D ;
- . N ZI S ZI=0
- . F S ZI=$O(ZR(ZI)) Q:ZI="" D ;
- . . W !,ZI
- . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY
- . W !,"COUNT=",ZR(0)
+ . D PARY^C0CXPATH("ZR") ; PRINT ARRAY
+ . W "COUNT=",ZR(0),!
Q
;
Index: /ccr/branches/ohum/p/C0CRNF.m
===================================================================
--- /ccr/branches/ohum/p/C0CRNF.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CRNF.m (revision 1325)
@@ -1,4 +1,4 @@
C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CRXN.m
===================================================================
--- /ccr/branches/ohum/p/C0CRXN.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CRXN.m (revision 1325)
@@ -1,4 +1,4 @@
C0CRXN ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CSOAP.m
===================================================================
--- /ccr/branches/ohum/p/C0CSOAP.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CSOAP.m (revision 1325)
@@ -1,4 +1,4 @@
C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CSUB1.m
===================================================================
--- /ccr/branches/ohum/p/C0CSUB1.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CSUB1.m (revision 1325)
@@ -1,4 +1,4 @@
C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CSYS.m
===================================================================
--- /ccr/branches/ohum/p/C0CSYS.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CSYS.m (revision 1325)
@@ -1,4 +1,4 @@
C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
; Copyright 2008 WorldVistA. Licensed under the terms of the GNU
; General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CUNIT.m
===================================================================
--- /ccr/branches/ohum/p/C0CUNIT.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CUNIT.m (revision 1325)
@@ -1,4 +1,4 @@
C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CUTIL.m
===================================================================
--- /ccr/branches/ohum/p/C0CUTIL.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CUTIL.m (revision 1325)
@@ -1,4 +1,4 @@
C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
- ;;0.1;C0C;;Jun 15, 2008;Build 38
+ ;;0.1;C0C;;Jun 15, 2008;Build 39
;Copyright 2008-2009 Sam Habiel & George Lilly.
;Licensed under the terms of the GNU
@@ -135,34 +135,4 @@
Q
;
-RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
- ;
-CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
- ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
- N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
- I $G(ZVUID)="" Q ""
- I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
- N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
- S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
- N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
- S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
- I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
- Q ZRSLT
- ;
-NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
- ; CONFORM TO NIST REQUIREMENTS
- ;INPATIENT CERTIFICATION
- I ZRXN=309362 S ZRXN=213169
- I ZRXN=855318 S ZRXN=855320
- I ZRXN=197361 S ZRXN=212549
- ;OUTPATIENT CERTIFICATION
- I ZRXN=310534 S ZRXN=205875
- I ZRXN=617312 S ZRXN=617314
- I ZRXN=310429 S ZRXN=200801
- I ZRXN=628953 S ZRXN=628958
- I ZRXN=745679 S ZRXN=630208
- I ZRXN=311564 S ZRXN=979334
- I ZRXN=836343 S ZRXN=836370
- Q ZRXN
- ;
RPMS() ; Are we running on an RPMS system rather than Vista?
Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
Index: /ccr/branches/ohum/p/C0CVA200.m
===================================================================
--- /ccr/branches/ohum/p/C0CVA200.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CVA200.m (revision 1325)
@@ -1,4 +1,4 @@
C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CVALID.m
===================================================================
--- /ccr/branches/ohum/p/C0CVALID.m (revision 1325)
+++ /ccr/branches/ohum/p/C0CVALID.m (revision 1325)
@@ -0,0 +1,10 @@
+C0CVALID ; C0C/OHUM/RUT - PROCESSING FOR DATE LIMITS, NOTES ; 22/12/2011
+ ;;1.0;C0C;;Dec 22, 2011;Build 39
+ S ^TMP("C0CCCR","LABLIMIT")="",^TMP("C0CCCR","VITLIMIT")="",^TMP("C0CCCR","MEDLIMIT")="",^TMP("C0CCCR","RALIMIT")="",^TMP("C0CCCR","TIULIMIT")=""
+ S %DT="AEX",%DT("A")="LAB Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","LABLIMIT")=Y
+ S %DT="AEX",%DT("A")="VITAL Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","VITLIMIT")=Y
+ S %DT="AEX",%DT("A")="MEDICATION Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","MEDLIMIT")=Y
+ ;S ^TMP("C0CCCR","MEDLIMIT")="T-1"
+ S %DT="AEX",%DT("A")="RADIOLOGY Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","RALIMIT")=Y
+ W !,"Do you want to include Notes: YES/NO? //NO" D YN^DICN I %=1 S %DT="AEX",%DT("A")="NOTE Report From: ",%DT("B")="T-36500" D ^%DT S ^TMP("C0CCCR","TIULIMIT")=Y
+ Q
Index: /ccr/branches/ohum/p/C0CVIT2.m
===================================================================
--- /ccr/branches/ohum/p/C0CVIT2.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CVIT2.m (revision 1325)
@@ -1,4 +1,4 @@
C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
- ;;1.0;C0C;;Feb 16, 2010;Build 38
+ ;;1.0;C0C;;Feb 16, 2010;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
Index: /ccr/branches/ohum/p/C0CVITAL.m
===================================================================
--- /ccr/branches/ohum/p/C0CVITAL.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CVITAL.m (revision 1325)
@@ -1,4 +1,4 @@
C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008,2009 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
@@ -58,5 +58,5 @@
N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
- I DEBUG ZWR VDATES ;DEBUG
+ ; I DEBUG ZWR VDATES ;DEBUG
S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
@@ -72,8 +72,4 @@
. . I DEBUG W $P(VITPTMP,U,4),!
. . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
- . . ;B ;gpl
- . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
- . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ;
- . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1"
. . I $P(VITPTMP,U,2)="HT" D
. . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
@@ -87,5 +83,5 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
@@ -101,10 +97,10 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
. . E I $P(VITPTMP,U,2)="BP" D
. . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
- . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
. . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
. . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
@@ -115,5 +111,5 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
@@ -129,5 +125,5 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F"
@@ -143,5 +139,5 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
@@ -157,5 +153,5 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
@@ -171,19 +167,5 @@
. . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
. . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
- . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
- . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
- . . E I $P(VITPTMP,U,2)="BMI" D
- . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
- . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
- . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
- . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
- . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
- . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
- . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
- . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009"
- . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
- . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
@@ -200,9 +182,7 @@
. . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
. . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")=""
- . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
. . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
- . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ;
- . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
. . S VITARYTMP=$NA(@VITTARYTMP@(J))
. . K @VITARYTMP
Index: /ccr/branches/ohum/p/C0CXPAT0.m
===================================================================
--- /ccr/branches/ohum/p/C0CXPAT0.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CXPAT0.m (revision 1325)
@@ -1,4 +1,4 @@
C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/C0CXPATH.m
===================================================================
--- /ccr/branches/ohum/p/C0CXPATH.m (revision 1324)
+++ /ccr/branches/ohum/p/C0CXPATH.m (revision 1325)
@@ -1,4 +1,4 @@
C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
- ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;1.0;C0C;;May 19, 2009;Build 39
;Copyright 2008 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
Index: /ccr/branches/ohum/p/VWTIME.m
===================================================================
--- /ccr/branches/ohum/p/VWTIME.m (revision 1324)
+++ /ccr/branches/ohum/p/VWTIME.m (revision 1325)
@@ -1,239 +1,239 @@
-VWTIME ; Report Age in Time / Date;5:33 AM 11 Feb 2010
- ;;1.0;WorldVistA;;WorldVistA 30-June-08;Build 2
- ;
- ;Modified from FOIA VISTA,
- ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
- ;General Public License See attached copy of the License.
- ;
- ;This program is free software; you can redistribute it and/or modify
- ;it under the terms of the GNU General Public License as published by
- ;the Free Software Foundation; either version 2 of the License, or
- ;(at your option) any later version.
- ;
- ;This program is distributed in the hope that it will be useful,
- ;but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;GNU General Public License for more details.
- ;
- ;You should have received a copy of the GNU General Public License along
- ;with this program; if not, write to the Free Software Foundation, Inc.,
- ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- ;
- QUIT ; No Fall Through
- ; =============
- ; FDT = First Date/Time (SD)
- ; W $$DIF^VWTIME(3090512.1145)
-DIF(SD,ED) ; Now a Call will look like the above
- N BUF,DED,DSD,EH,EI,FTD
- S SD=$G(SD),ED=$G(ED)
- I ED="" D NOW^%DTC S ED=%
- I SD<.00001 D NOW^%DTC S SD=% ; Invalid start date is set to now
- S X=SD
- D
- . I SD="" S ER=99 Q
- . ;
- . ; Convert both Values to Fileman Time to Decimal.
- . ; We are interested in just the differences
- . ;
- . I SD>1400000 D
- . . S X=$$F2D(SD)
- . . D H^%DTC
- . . S SD=%H_","_$TR($J(%T,5)," ","0")
- . .QUIT
- . S DST=$$F2D(SD)
- . S DET=$$F2D(ED)
- .QUIT
- ; Decimal Date/Times calculated in DST (start) and DET (end),
- ; differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
- S (DTD,FTD)=DET-DST
- ; Time Frames
- ; 1 Minute = .000694444444444444444
- ; 1 Hour = .0416666666666666666
- ; 1 Day = 1
- ; 1 WeeK = 7
- ; 1 Month = 30.5
- ; 1 Year = 365.249
- N BUF,DAY,HR,MIN,MON,WK,YR
- S BUF=""
- S DAY=1
- S SEP=""
- D
- . N HR,MON,YR,WEEK
- . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
- . I FTD>(2*YR) D
- . . S T=DTD\YR
- . . S BUF=BUF_SEP_T_" Year"
- . . S:T>1 BUF=BUF_"s"
- . . S DTD=(DTD#YR),SEP=", "
- . . .QUIT
- . QUIT:FTD>(20*YR)
- . ;
- . ; Time Calculations
- . I FTD>(4*MON) I FTD<(18*YR) D
- . . S T=DTD\MON
- . . S BUF=BUF_SEP_T_" Month"
- . . S:T>1 BUF=BUF_"s"
- . . S DTD=(DTD#MON),SEP=", "
- . .QUIT
- . QUIT:FTD>(18*YR)
- . I FTD>29 I FTD<4*WEEK D
- . . S T=DTD\WEEK
- . . S BUF=BUF_SEP_T_" Week"
- . . S:T>1 BUF=BUF_"s"
- . . S DTD=(DTD#WEEK),SEP=", "
- . .QUIT
- . ; Time Calculations
- . I FTD<29 I DTD'<2 D
- . . S T=DTD\1
- . . S BUF=BUF_SEP_T_" Day"
- . . S:T>1 BUF=BUF_"s"
- . . S DTD=(DTD#DAY),SEP=", "
- . .QUIT
- . I DTD>.999999&(FTD<4) D
- . . S T=DTD\HR
- . . S BUF=BUF_SEP_T_" Hour"
- . . S:T>1 BUF=BUF_"s"
- . . S DTD=(DTD#HR),SEP=", "
- . .QUIT
- . D:(FTD<4.00000001)
- . . N MIN,HR
- . . S HR=1/24,SEP=$G(SEP)
- . . S MIN=HR/60
- . . ;
- . . I DTD>MIN D
- . . . S T=DTD\MIN
- . . . S BUF=BUF_SEP_T_" Minute"
- . . . S:T>1 BUF=BUF_"s"
- . . . S DTD=(DTD#MIN),SEP=", "
- . .QUIT
- . . ;
- . . S SEC=MIN/60
- . . I DTD>SEC D
- . . . S T=DTD\SEC
- . . . S BUF=BUF_SEP_T_" Second"
- . . . S:T>1 BUF=BUF_"s"
- . . . S DTD=(DTD#SEC),SEP=", "
- . . .QUIT
- . .QUIT
- . ; I DTD S BUF=BUF_" Less than a Minute"
- .QUIT
- QUIT BUF
- ; ==========
- ; W $$BRIEF^VWTIME(DOB) >>> Years^Months^Weeks^Days^Hours^Minutes^Seconds
-BRIEF(SD,ED) ; Now a Call will look like the above
- N BUF,DED,DSD,EH,EI,FTD,BUF
- S SD=$G(SD),ED=$G(ED)
- I ED="" D NOW^%DTC S ED=%
- S:SD<2 SD=""
- S BUF="INVALID INPUT"
- D:SD ; SD has been checked and passed if it passes here
- . S X=SD
- . ;
- . ; Convert both Values to Fileman Time to Decimal.
- . ; We are interested in just the differences
- . ;
- . ; I SD>1400000 D
- . ; . S X=$$F2D(SD)
- . ; . D H^%DTC
- . ; . S SD=%H_","_$TR($J(%T,5)," ","0")
- . ; .QUIT
- . ; If we get here, we have the ST and ET defined and ready
- . S DST=$$F2D(SD)
- . S DET=$$F2D(ED)
- . D TDIFF(.BUF)
- .QUIT
- QUIT BUF
- ; ===========
-TDIFF(BF) ; Time Difference formulation
- ; Decimal Date/Times calculated in DST (start) and DET (end),
- ; differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
- S (DTD,FTD)=DET-DST
- ; Time Frames
- ; 1 Minute = .000694444444444444444
- ; 1 Hour = .0416666666666666666
- ; 1 Day = 1
- ; 1 WeeK = 7
- ; 1 Month = 30.5
- ; 1 Year = 365.249
- N DAY,HR,MIN,MON,WK,YR
- S $P(BF,"^",7)=""
- S DAY=1
- S SEP=""
- D
- . N HR,MON,YR,WEEK
- . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
- . I FTD>(2*YR) D
- . . S $P(BF,"^")=DTD\YR
- . . S DTD=(DTD#YR)
- . .QUIT
- . ;
- . ; Time Calculations
- . I FTD>(4*MON) I FTD<(18*YR) D
- . . S $P(BF,"^",2)=DTD\MON
- . . S DTD=(DTD#MON)
- . .QUIT
- . D ; I FTD>29 I FTD<4*WEEK D
- . . S $P(BF,"^",3)=DTD\WEEK
- . . S DTD=(DTD#WEEK)
- . .QUIT
- . ; Time Calculations
- . D ; I FTD<29 I DTD'<2 D
- . . S $P(BF,"^",4)=DTD\1
- . . S DTD=(DTD#DAY)
- . .QUIT
- . D ; I DTD>.999999&(FTD<4) D
- . . S $P(BF,"^",5)=DTD\HR
- . . S DTD=(DTD#HR)
- . .QUIT
- . S MIN=1/(24*60)
- . D ; :(FTD<4.00000001)
- . . N HR
- . . S HR=1/24
- . . S MIN=HR/60
- . . ;
- . . ; I DTD>MIN D
- . . S $P(BF,"^",6)=DTD\MIN
- . . S DTD=(DTD#MIN)
- . .QUIT
- . . ;
- . S SEC=MIN/60
- . ; I DTD>SEC D
- . S $P(BF,"^",7)=DTD\SEC
- . S DTD=(DTD#SEC)
- . .QUIT
- . ; I DTD S BF=BF_" Less than a Minute"
- .QUIT
- QUIT
- ; ==========
-F2D(X) ; Conver FM Date/Time to Decimal
- N %H,%T,%Y
- D H^%DTC
- QUIT $$H2D(%H_","_%T)
- ; ========
-H2D(X) ; Convert Horolog to Decimal Days
- N D,T
- S D=$P(X,","),T=$P(X,",",2)/86400
- QUIT D+T
- ; =============
-LONGAGE(VWAGE,VWDFN) ; RPC FOR LONG AGE
- N VWDOB
- S VWDOB=$P(^DPT(VWDFN,0),"^",3)
- S VWAGE=$$DIF(VWDOB)
- QUIT
- ; =============
-BRFAGE(VWAGE,VWDFN) ; RPC FOR BRIEF AGE
- N VWDOB
- S VWDOB=$P(^DPT(VWDFN,0),"^",3)
- S VWAGE=$$BRIEF(VWDOB)
- QUIT
- ; =============
-RPCREG ; Register NEW RPCs
- N MENU,RPC,FDA,FDAIEN,ERR,DIERR
- S MENU="OR CPRS GUI CHART"
- F RPC="VWTIME LONG AGE","VWTIME BRIEF AGE" D
- . S FDA(19,"?1,",.01)=MENU
- . S FDA(19.05,"?+2,?1,",.01)=RPC
- . D UPDATE^DIE("E","FDA","FDAIEN","ERR")
- .QUIT
- QUIT
- ; ============
+VWTIME ; Report Age in Time / Date;5:33 AM 11 Feb 2010
+ ;;1.0;WorldVistA;;WorldVistA 30-June-08;Build 2
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ QUIT ; No Fall Through
+ ; =============
+ ; FDT = First Date/Time (SD)
+ ; W $$DIF^VWTIME(3090512.1145)
+DIF(SD,ED) ; Now a Call will look like the above
+ N BUF,DED,DSD,EH,EI,FTD
+ S SD=$G(SD),ED=$G(ED)
+ I ED="" D NOW^%DTC S ED=%
+ I SD<.00001 D NOW^%DTC S SD=% ; Invalid start date is set to now
+ S X=SD
+ D
+ . I SD="" S ER=99 Q
+ . ;
+ . ; Convert both Values to Fileman Time to Decimal.
+ . ; We are interested in just the differences
+ . ;
+ . I SD>1400000 D
+ . . S X=$$F2D(SD)
+ . . D H^%DTC
+ . . S SD=%H_","_$TR($J(%T,5)," ","0")
+ . .QUIT
+ . S DST=$$F2D(SD)
+ . S DET=$$F2D(ED)
+ .QUIT
+ ; Decimal Date/Times calculated in DST (start) and DET (end),
+ ; differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
+ S (DTD,FTD)=DET-DST
+ ; Time Frames
+ ; 1 Minute = .000694444444444444444
+ ; 1 Hour = .0416666666666666666
+ ; 1 Day = 1
+ ; 1 WeeK = 7
+ ; 1 Month = 30.5
+ ; 1 Year = 365.249
+ N BUF,DAY,HR,MIN,MON,WK,YR
+ S BUF=""
+ S DAY=1
+ S SEP=""
+ D
+ . N HR,MON,YR,WEEK
+ . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
+ . I FTD>(2*YR) D
+ . . S T=DTD\YR
+ . . S BUF=BUF_SEP_T_" Year"
+ . . S:T>1 BUF=BUF_"s"
+ . . S DTD=(DTD#YR),SEP=", "
+ . . .QUIT
+ . QUIT:FTD>(20*YR)
+ . ;
+ . ; Time Calculations
+ . I FTD>(4*MON) I FTD<(18*YR) D
+ . . S T=DTD\MON
+ . . S BUF=BUF_SEP_T_" Month"
+ . . S:T>1 BUF=BUF_"s"
+ . . S DTD=(DTD#MON),SEP=", "
+ . .QUIT
+ . QUIT:FTD>(18*YR)
+ . I FTD>29 I FTD<4*WEEK D
+ . . S T=DTD\WEEK
+ . . S BUF=BUF_SEP_T_" Week"
+ . . S:T>1 BUF=BUF_"s"
+ . . S DTD=(DTD#WEEK),SEP=", "
+ . .QUIT
+ . ; Time Calculations
+ . I FTD<29 I DTD'<2 D
+ . . S T=DTD\1
+ . . S BUF=BUF_SEP_T_" Day"
+ . . S:T>1 BUF=BUF_"s"
+ . . S DTD=(DTD#DAY),SEP=", "
+ . .QUIT
+ . I DTD>.999999&(FTD<4) D
+ . . S T=DTD\HR
+ . . S BUF=BUF_SEP_T_" Hour"
+ . . S:T>1 BUF=BUF_"s"
+ . . S DTD=(DTD#HR),SEP=", "
+ . .QUIT
+ . D:(FTD<4.00000001)
+ . . N MIN,HR
+ . . S HR=1/24,SEP=$G(SEP)
+ . . S MIN=HR/60
+ . . ;
+ . . I DTD>MIN D
+ . . . S T=DTD\MIN
+ . . . S BUF=BUF_SEP_T_" Minute"
+ . . . S:T>1 BUF=BUF_"s"
+ . . . S DTD=(DTD#MIN),SEP=", "
+ . .QUIT
+ . . ;
+ . . S SEC=MIN/60
+ . . I DTD>SEC D
+ . . . S T=DTD\SEC
+ . . . S BUF=BUF_SEP_T_" Second"
+ . . . S:T>1 BUF=BUF_"s"
+ . . . S DTD=(DTD#SEC),SEP=", "
+ . . .QUIT
+ . .QUIT
+ . ; I DTD S BUF=BUF_" Less than a Minute"
+ .QUIT
+ QUIT BUF
+ ; ==========
+ ; W $$BRIEF^VWTIME(DOB) >>> Years^Months^Weeks^Days^Hours^Minutes^Seconds
+BRIEF(SD,ED) ; Now a Call will look like the above
+ N BUF,DED,DSD,EH,EI,FTD,BUF
+ S SD=$G(SD),ED=$G(ED)
+ I ED="" D NOW^%DTC S ED=%
+ S:SD<2 SD=""
+ S BUF="INVALID INPUT"
+ D:SD ; SD has been checked and passed if it passes here
+ . S X=SD
+ . ;
+ . ; Convert both Values to Fileman Time to Decimal.
+ . ; We are interested in just the differences
+ . ;
+ . ; I SD>1400000 D
+ . ; . S X=$$F2D(SD)
+ . ; . D H^%DTC
+ . ; . S SD=%H_","_$TR($J(%T,5)," ","0")
+ . ; .QUIT
+ . ; If we get here, we have the ST and ET defined and ready
+ . S DST=$$F2D(SD)
+ . S DET=$$F2D(ED)
+ . D TDIFF(.BUF)
+ .QUIT
+ QUIT BUF
+ ; ===========
+TDIFF(BF) ; Time Difference formulation
+ ; Decimal Date/Times calculated in DST (start) and DET (end),
+ ; differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date
+ S (DTD,FTD)=DET-DST
+ ; Time Frames
+ ; 1 Minute = .000694444444444444444
+ ; 1 Hour = .0416666666666666666
+ ; 1 Day = 1
+ ; 1 WeeK = 7
+ ; 1 Month = 30.5
+ ; 1 Year = 365.249
+ N DAY,HR,MIN,MON,WK,YR
+ S $P(BF,"^",7)=""
+ S DAY=1
+ S SEP=""
+ D
+ . N HR,MON,YR,WEEK
+ . S MON=30.49,YR=365.249,HR=1/24,WEEK=7
+ . I FTD>(2*YR) D
+ . . S $P(BF,"^")=DTD\YR
+ . . S DTD=(DTD#YR)
+ . .QUIT
+ . ;
+ . ; Time Calculations
+ . I FTD>(4*MON) I FTD<(18*YR) D
+ . . S $P(BF,"^",2)=DTD\MON
+ . . S DTD=(DTD#MON)
+ . .QUIT
+ . D ; I FTD>29 I FTD<4*WEEK D
+ . . S $P(BF,"^",3)=DTD\WEEK
+ . . S DTD=(DTD#WEEK)
+ . .QUIT
+ . ; Time Calculations
+ . D ; I FTD<29 I DTD'<2 D
+ . . S $P(BF,"^",4)=DTD\1
+ . . S DTD=(DTD#DAY)
+ . .QUIT
+ . D ; I DTD>.999999&(FTD<4) D
+ . . S $P(BF,"^",5)=DTD\HR
+ . . S DTD=(DTD#HR)
+ . .QUIT
+ . S MIN=1/(24*60)
+ . D ; :(FTD<4.00000001)
+ . . N HR
+ . . S HR=1/24
+ . . S MIN=HR/60
+ . . ;
+ . . ; I DTD>MIN D
+ . . S $P(BF,"^",6)=DTD\MIN
+ . . S DTD=(DTD#MIN)
+ . .QUIT
+ . . ;
+ . S SEC=MIN/60
+ . ; I DTD>SEC D
+ . S $P(BF,"^",7)=DTD\SEC
+ . S DTD=(DTD#SEC)
+ . .QUIT
+ . ; I DTD S BF=BF_" Less than a Minute"
+ .QUIT
+ QUIT
+ ; ==========
+F2D(X) ; Conver FM Date/Time to Decimal
+ N %H,%T,%Y
+ D H^%DTC
+ QUIT $$H2D(%H_","_%T)
+ ; ========
+H2D(X) ; Convert Horolog to Decimal Days
+ N D,T
+ S D=$P(X,","),T=$P(X,",",2)/86400
+ QUIT D+T
+ ; =============
+LONGAGE(VWAGE,VWDFN) ; RPC FOR LONG AGE
+ N VWDOB
+ S VWDOB=$P(^DPT(VWDFN,0),"^",3)
+ S VWAGE=$$DIF(VWDOB)
+ QUIT
+ ; =============
+BRFAGE(VWAGE,VWDFN) ; RPC FOR BRIEF AGE
+ N VWDOB
+ S VWDOB=$P(^DPT(VWDFN,0),"^",3)
+ S VWAGE=$$BRIEF(VWDOB)
+ QUIT
+ ; =============
+RPCREG ; Register NEW RPCs
+ N MENU,RPC,FDA,FDAIEN,ERR,DIERR
+ S MENU="OR CPRS GUI CHART"
+ F RPC="VWTIME LONG AGE","VWTIME BRIEF AGE" D
+ . S FDA(19,"?1,",.01)=MENU
+ . S FDA(19.05,"?+2,?1,",.01)=RPC
+ . D UPDATE^DIE("E","FDA","FDAIEN","ERR")
+ .QUIT
+ QUIT
+ ; ============