Index: ccr/trunk/p/C0CCCR0.m =================================================================== --- ccr/trunk/p/C0CCCR0.m (revision 666) +++ ccr/trunk/p/C0CCCR0.m (revision 673) @@ -579,4 +579,72 @@ ;; ;; + ;; + ;; + ;;@@PROCOBJECTID@@ + ;; + ;; + ;;@@PROCDATETEXT@@ + ;; + ;;@@PROCDATETIME@@ + ;; + ;; + ;;@@PROCDESCTEXT@@ + ;; + ;;@@PROCDESCOBJATTR@@ + ;; + ;;@@PROCDESCOBJATTRVAL@@ + ;; + ;;@@PROCDESCOBJATTRCODE@@ + ;;@@PROCDESCOBJATTRCODESYS@@ + ;; + ;; + ;; + ;; + ;;@@PROCCODE@@ + ;;@@PROCCODESYS@@ + ;; + ;; + ;; + ;;@@PROCSTATUS@@ + ;; + ;; + ;; + ;;@@PROCACTOROBJID@@ + ;; + ;; + ;; + ;;@@PROCLINKID@@ + ;;@@PROCLINKREL@@ + ;; + ;; + ;; + ;; + ;; + ;;@@ENCOBJECTID@@ + ;; + ;;@@ENCDATETIME@@ + ;; + ;; + ;;@@ENCTYPE@@ + ;; + ;;@@ENCCODE@@ + ;;@@ENCCODESYS@@ + ;; + ;; + ;; + ;; + ;;@@ENCACTORID@@ + ;; + ;; + ;; + ;; + ;; + ;;@@ENCLOCACTORID@@ + ;; + ;; + ;; + ;;@@ENCCOMMENTID@@ + ;; + ;; ;; ;; Index: ccr/trunk/p/C0CCPT.m =================================================================== --- ccr/trunk/p/C0CCPT.m (revision 673) +++ ccr/trunk/p/C0CCPT.m (revision 673) @@ -0,0 +1,96 @@ +C0CCPT ;;BSL;RETURN CPT DATA; + ;Sequence Managers Software GPL + ;Copied into C0C namespace from SQMCPT with permission from + ;Brian Lord - and with our thanks. gpl 01/20/2010 +ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES + ;DFN=PATIENT IEN + ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) + ;ENDDT=END DATE IN 3100101 FORMAT + ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE + ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME + ;ALL INCLUSIVE IN THAT DIRECTION + ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) + ;BUILD INTO NOTE(Y)="" + S U="^",X="" + F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D + . S Y="" + . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D + .. S NOTE(Y)="" + ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE + ;GET DATE OF NOTE + S Z="" + F S Z=$O(NOTE(Z)) Q:Z="" D + . S DT=$P(^TIU(8925,Z,0),U,7) + . I $G(STDT)]"" D + .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED + . I $G(ENDDT)]"" D + .. I ENDDT
0) + . D ENCEVENT^PXKENC(VISIT,1) + . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q + . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D + .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) + .. ;Q:$P(X0,U,4)'="P" + .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) + .. S PRIM=($P(X0,U,4)="P") + .. S ILST=ILST+1 + .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM + .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM + . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D + .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) + .. S CODE=$P(X0,U) + .. S:CODE CODE=$P(^ICD9(CODE,0),U) + .. S CAT=$P(X802,U) + .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) + .. S NARR=$P(X0,U,4) + .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) + .. S PRIM=($P(X0,U,12)="P") + .. S PRV=$P(X12,U,4) + .. S ILST=ILST+1 + .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV + .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV + .. I X811]"" D + ... S ICOM=ICOM+1 + ... S $P(LST(ILST),U,10)=ICOM + ... S ILST=ILST+1 + ... S LST(ILST)="COM"_U_ICOM_U_X811 + . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D + .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) + .. ;S CODE=$P(X0,U) + .. S CODE=$O(^ICPT("B",$P(X0,U),0)) + .. S:CODE CODE=$P(^ICPT(CODE,0),U) + .. S CAT=$P(X802,U) + .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) + .. S NARR=$P(X0,U,4) + .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) + .. S QTY=$P(X0,U,16) + .. S PRV=$P(X12,U,4) + .. S MCNT=0,MIDX=0,MODS="" + .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D + ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) + ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN + .. I +MCNT S MODS=MCNT_MODS + .. S ILST=ILST+1 + .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS + .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS + . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") + . I $G(TXT)=1 D GETNOTE(IEN) + Q +GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT + ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" + ;Q:'$D(VISIT(IEN,"CPT")) + S TXTCNT=0 + F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D + . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) + Q + Index: ccr/trunk/p/C0CPROC.m =================================================================== --- ccr/trunk/p/C0CPROC.m (revision 673) +++ ccr/trunk/p/C0CPROC.m (revision 673) @@ -0,0 +1,100 @@ +C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 + ;;1.0;C0C;;Jan 21, 2010; + ;Copyright 2010 George Lilly, University of Minnesota and others. + ;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. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE + ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + S C0CENC=$NA(^TMP("C0CENC",$J,DFN)) + S C0CPRC=$NA(^TMP("C0CPRC",$J,DFN)) + S C0CNTE=$NA(^TMP("C0CNTE",$J,DFN)) + I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE + D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES + Q + ; +TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, + ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME + ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES + ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT + ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY + ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM + ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS + ; + K VISIT,LST,NOTE + D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE + ; NEED TO ADD START AND END DATES FROM PARAMETERS + N ZI S ZI="" + F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST + . N ZDATE + . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) + . S ZPRVARY=$NA(VISIT(ZI,"PRV")) + . N ZPRV + . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM + . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON + . N ZJ S ZJ="" + . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG + . . N ZRNF + . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT + . . I ZCPT'="" D ;IF CPT CODE IS PRESENT + . . . W !,ZCPT," ",ZDATE," ",ZPRV + . . . S ZRNF("PROCACTOROBJID")=ZPRV + . . . S ZRNF("PROCCODE")=$P(ZCPT,U,1) + . . . S ZRNF("PROCCODESYS")="CPT-4" + . . . S ZRNF("PROCDATETEXT")="Procedure Date" + . . . S ZRNF("PROCDATETIME")=ZDATE + . . . S ZRNF("PROCDESCOBJATTR")="" + . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES + . . . S ZRNF("PROCDESCOBJATTRVAL")="" + . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) + . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET + . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET + . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI + . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? + . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE + Q + ; +PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME + N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG + . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER + . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) + I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR + Q ZRTN + ; +DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT + Q $$FMDTOUTC^C0CUTIL(ISTR,"D") + ; +CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS + ; CPT^CATEGORY^TEXT + N Z1,Z2,Z3,ZRTN + I ISTR["(CPT-4 " D ; IF THERE IS A CPT CODE IN THERE + . S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) + . S Z2=$P(ISTR,U,2) + . S Z3=$P(ISTR,U,3) + . S ZRTN=Z1_U_Z2_U_Z3 + E S ZRTN="" + Q ZRTN + ; +MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML + ; + Q + ;