Changeset 1337 for ccr/branches/ohum/p/C0CPROC.m
- Timestamp:
- Jan 4, 2012, 9:40:24 PM (13 years ago)
- File:
-
- 1 edited
-
ccr/branches/ohum/p/C0CPROC.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CPROC.m
r1333 r1337 1 C0CPROC 2 ;;1.0;C0C;;Jan 21, 2010;Build 1 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 SETVARS 25 26 27 28 29 30 31 32 EXTRACT(PROCXML,DFN,PROCOUT) 33 34 35 36 37 38 39 40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) 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 PRV(IARY) 101 102 103 104 105 106 107 108 DATE(ISTR) 109 110 111 CPT(ISTR) 112 113 114 115 116 117 118 119 120 121 122 123 124 125 MAP(PROCXML,C0CPRC,PROCOUT) 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 1 C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 2 ;;1.0;C0C;;Jan 21, 2010;Build 38 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 ;Licensed under the terms of the GNU General Public License. 5 ;See attached copy of the License. 6 ; 7 ;This program is free software; you can redistribute it and/or modify 8 ;it under the terms of the GNU General Public License as published by 9 ;the Free Software Foundation; either version 2 of the License, or 10 ;(at your option) any later version. 11 ; 12 ;This program is distributed in the hope that it will be useful, 13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;GNU General Public License for more details. 16 ; 17 ;You should have received a copy of the GNU General Public License along 18 ;with this program; if not, write to the Free Software Foundation, Inc., 19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 20 ; 21 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES 25 S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN)) 26 S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) 27 S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) 28 ; ADDITION FOR CERTIFICATION 29 S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) 30 Q 31 ; 32 EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE 33 ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 34 ; 35 D SETVARS ; SET UP VARIABLES 36 I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE 37 D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES 38 Q 39 ; 40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 41 ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 42 ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES 43 ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT 44 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 45 ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM 46 ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS 47 ; 48 K VISIT,LST,NOTE,C0CLPRC 49 ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS 50 ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES 51 D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE 52 ; NEED TO ADD START AND END DATES FROM PARAMETERS 53 N ZI S ZI="" 54 N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" 55 F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST 56 . N ZDATE 57 . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) 58 . S ZPRVARY=$NA(VISIT(ZI,"PRV")) 59 . N ZPRV 60 . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM 61 . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 62 . N ZJ S ZJ="" 63 . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG 64 . . N ZRNF 65 . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT 66 . . I ZCPT'="" D ;IF CPT CODE IS PRESENT 67 . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED 68 . . . W !,ZCPT," ",ZDATE," ",ZPRV 69 . . . S ZRNF("PROCACTOROBJID")=ZPRV 70 . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) 71 . . . S ZRNF("PROCCODE")=PROCCODE 72 . . . S ZRNF("PROCCODESYS")="CPT-4" 73 . . . S ZRNF("PROCDATETEXT")="Procedure Date" 74 . . . S ZRNF("PROCDATETIME")=ZDATE 75 . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET 76 . . . S ZRNF("PROCDESCOBJATTR")="" 77 . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES 78 . . . S ZRNF("PROCDESCOBJATTRVAL")="" 79 . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) 80 . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET 81 . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET 82 . . . ; additions for Certification - need to have EKG in Results 83 . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT 84 . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ 85 . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS 86 . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? 87 . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE 88 . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY 89 . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl 90 . . . W !,"CPT=",ZCPT 91 . . . I ZCPT["93000" D ; THIS IS AN EKG 92 . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS 93 . . . . M ^GPL("RNF2")=@C0CPRSLT 94 . . . S PREVCPT=ZCPT 95 . . . S PREVDT=ZDATE 96 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) 97 M @ZRIM=@C0CPRC@("V") 98 Q 99 ; 100 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME 101 N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" 102 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG 103 . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER 104 . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) 105 I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR 106 Q ZRTN 107 ; 108 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT 109 Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") 110 ; 111 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS 112 ; CPT^CATEGORY^TEXT 113 N Z1,Z2,Z3,ZRTN 114 S Z1=$P(ISTR,U,1) 115 I Z1="" D ; 116 . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) 117 I Z1'="" D ; IF THERE IS A CPT CODE IN THERE 118 . ;S Z1=$P(ISTR,U,1) 119 . S Z2=$P(ISTR,U,2) 120 . S Z3=$P(ISTR,U,3) 121 . S ZRTN=Z1_U_Z2_U_Z3 122 E S ZRTN="" 123 Q ZRTN 124 ; 125 MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML 126 ; 127 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE 128 K @ZTEMP 129 N ZBLD 130 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA 131 D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE 132 N ZINNER 133 D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC 134 N ZTMP,ZVAR,ZI 135 S ZI="" 136 F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE 137 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML 138 . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES 139 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE 140 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD 141 D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) 142 N ZZTMP 143 D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML 144 K @ZTEMP,@ZBLD,@C0CPRC 145 Q 146 ;
Note:
See TracChangeset
for help on using the changeset viewer.
