source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCARPS2.m@ 1704

Last change on this file since 1704 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1MCARPS2 ;SLC/dcm,WAA Summary of patient procedures for CPRS ;4/5/06 09:57
2 ;;1.0;CLINICAL PROCEDURES;**5,13**;Apr 01, 2004;Build 19
3 ;Modified from MCARPS1 for CPRS
4 ; Reference DBIA # 3397 Medicine Report Support from CPRS.
5 ; # 2263 XPAR parameter call.
6EN(DFN) ;Get procedures for a patient
7 I '$$PATCH^XPDUTL("MD*1.0*2") G MED
8 I $$FIND1^DIC(9.4,"","MX","MEDICINE") Q:$$GET^XPAR("SYS","MD MEDICINE CONVERTED",1)&$D(S5)
9 N MCGLB,MCBLK,MCRT K ^TMP("OR",$J,"MCAR") S MCGLB=$NA(^TMP("OR",$J,"MCAR","OT"))
10 S MCBLK="" I '$D(S5) D EN1^MDPS1(.MCGLB,DFN,MCBLK,MCBLK,99999,MCBLK,MCBLK) Q
11 I $D(S5) G MED
12 Q
13MED S WH=""
14 K ^TMP("OR",$J,"MCAR") S S4="" F M=1:1 S S4=$O(^MCAR(690,"AC",DFN,S4)) Q:S4="" D LOCFIL
15 D PR0
16 Q
17LOCFIL G LOCFIL1:$D(S5) S S5="" F K=1:1 S S5=$O(^MCAR(690,"AC",DFN,S4,S5)) Q:S5="" D LOCFIL1
18 K S5 Q
19LOCFIL1 S S6="" F L=1:1 S S6=$O(^MCAR(690,"AC",DFN,S4,S5,S6)) Q:S6="" D CONT
20 Q
21CONT ;CONT+1 modified on 2-7-94,S MCFILE..2) added to conform w/alpha site
22 Q:$O(^MDD(702,"ACONV",S6_";"_S5_",",0))
23 I $D(^MCAR(+$P(S5,"(",2),S6,2005)) S MCFILE=+$P(S5,"(",2) D SUM^MCMAG
24 I S5="MCAR(702.7" Q
25 I S5="MCAR(699" S (LL,LL1)=$P($G(^MCAR(699,S6,0)),U,12) Q:LL'>0 S LL=$P($G(^MCAR(697.2,LL,0)),U) G:'$D(PE) CONT1 Q:PE'=LL G CONT1
26 ;I S5="MCAR(699.5" S (LL,LL1)=$P($G(^MCAR(699.5,S6,0)),U,6) Q:'LL S LL=$P($G(^MCAR(697.2,LL,0)),U) G CONT1:'$D(PE) Q:PE'=LL G CONT1 ;MC*2.3*8
27 I S5="MCAR(699.5",'$D(PE) D Q ;MC*2.3*8
28 .S LL6=$P($G(^MCAR(699.5,S6,0)),U,6),LL8=$P($G(^MCAR(699.5,S6,0)),U,8)
29 .S (LL,LL1)=$P($G(^MCAR(699.5,S6,0)),U,6) Q:'LL S LL=$P($G(^MCAR(697.2,LL,0)),U) D CONT1
30 I S5="MCAR(699.5",$D(PE) D Q ;MC*2.3*8
31 .S LL6=$P($G(^MCAR(699.5,S6,0)),U,6),LL8=$P($G(^MCAR(699.5,S6,0)),U,8)
32 .S (LL,LL1)=$P($G(^MCAR(699.5,S6,0)),U,6) Q:'LL S LL=$P($G(^MCAR(697.2,LL,0)),U)
33 .N LLX,LLY
34 .S LLX=$O(^MCAR(697.2,"B",PE,0)) Q:'LLX S LLY=$P($G(^MCAR(697.2,LLX,1)),U)
35 .I LLY="S",LLX=LL6 D CONT1
36 .I LLY="P",LLX=LL8 D CONT1
37 I S5[694 S (LL,LL1)=$P($G(^MCAR(694,S6,0)),U,3) Q:'LL S LL=$P(^MCAR(697.2,LL,0),U) G CONT1:'$D(PE) Q:PE'=LL G CONT1
38 ;MFD 2/5/93 I S5[700,$P($G(^MCAR(700,S6,2)),U)'="Y" Q ; exclude unreleased PFT
39 S (LL,LL1)=$O(^MCAR(697.2,"C",S5,0)),LL=$P(^MCAR(697.2,LL,0),U,1)
40CONT1 ;
41 S REC=$O(^MCAR(697.2,"B",LL,0)) S:REC="" REC=0
42 S MCARCODE=""
43 S MCESON=$P($G(^MCAR(697.2,REC,0)),U,14),MCESKEY=$P($G(^MCAR(697.2,REC,0)),U,15),MCSUP=+$P($G(^MCAR(697.2,REC,0)),U,16)
44 S (MCARSUM,MCARPSUM)="",MCARFILE=U_S5_","_S6_",.2)" S:$D(@MCARFILE) MCARSUM=$P(@MCARFILE,U,1),MCARPSUM=$P(@MCARFILE,U,2)
45 K MCARFILE S S1=$S(WH="P":LL,1:S4),S2=$S(WH="P":S4,1:LL)
46 S MCFILE=+$P(S5,"(",2)
47 I MCESON,($G(MCESKEY)'=""),('$$SCRSUMPT^MCESSCR(MCESKEY,S6,MCSUP)) K MCARSUM,MCARPSUM,MCFILE,REC,MCSUP Q
48 I '$$VALID^MCARUTL5(S5,S6,DFN) Q ; MC*2.3*33
49 I $P($G(@(U_S5_","_S6_",""ES"")")),U,7)="S" G EXIT ;MC*2.3*8
50 S S2=S2_U_S6 ;MC*2.3*8
51 S ^TMP("OR",$J,"MCAR",S1,S2)=MCARSUM_U_S6_U_$P(^MCAR(697.2,LL1,0),U,5,7)
52 ;I $P(^MCAR(697.2,LL1,0),U,2)'=S5 S $P(^TMP("OR",$J,"MCAR",S1,S2),U,3,5)="EN1^MCARGP^CONSULTS" ; MC*2.3*33
53 ;I $P(^MCAR(697.2,LL1,0),U,2)'=S5 S $P(^TMP("OR",$J,"MCAR",S1,S2),U,3,5)="EN1^MCARGP^NONENDO" ; MC*2.3*33
54 ;I $P(^MCAR(697.2,LL1,0),U,2)'=S5 S $P(^TMP("OR",$J,"MCAR",S1,S2),U,3,5)="EN1^MCARGP^GI" ; MC*2.3*33
55 I $P(^MCAR(697.2,LL1,0),U,2)'=S5 S $P(^TMP("OR",$J,"MCAR",S1,S2),U,3,5)="EN1^MCARGP^PARAC" ; MC*2.3*33
56 S $P(^TMP("OR",$J,"MCAR",S1,S2),U,10)=MCARPSUM
57 S $P(^TMP("OR",$J,"MCAR",S1,S2),U,11)=LL
58 I S5="MCAR(699.5" D ;MC*2.3*8
59 .I LL8="" S LL8=" "
60 .S $P(^TMP("OR",$J,"MCAR",S1,S2),U,12)=$E(($E($P($G(^MCAR(697.2,LL6,0)),U,8),1,13)_"/"_$P($G(^MCAR(697.2,LL8,0)),U)),1,31) K LL6,LL8
61EXIT K MCARSUM,MCARPSUM,REC,MCSUP,MCESON Q
62PR0 S I="",L=0
63 F S I=$O(^TMP("OR",$J,"MCAR",I)) Q:I="" I I'="OT" D
64 . S J="" F S J=$O(^TMP("OR",$J,"MCAR",I,J)) Q:J="" S PR=^(J) D
65 .. Q:$P(PR,U,3,5)="^^" ; MC*2.3*33
66 .. S MCARDT=$S(WH="P":$P(J,U),1:I),MCARPROC=$S(WH="P":I,1:$P(J,U))
67 .. S MCARPROC=$O(^MCAR(697.2,"B",MCARPROC,0)),MCARPROC=$P(^MCAR(697.2,MCARPROC,0),U,8)
68 .. I $P(PR,U,12)'="" S MCARPROC=$P(PR,U,12)
69 .. S DA=$P(PR,U,2),K=$P(PR,U),M=$P(PR,U,10)
70 .. S K=$S(K="N"!(K="L"):"NORMAL",K="A":"ABNORMAL",K="B":"BORDERLINE",K="T":"TECHNICALLY UNSATISFACTORY",K="ND":"NON-DIAGNOSTIC",K="MI":"MILDLY ABNORMAL",K="MO":"MODERATELY ABNORMAL",K="S":"SEVERELY ABNORMAL",1:"")
71 .. S Y=9999999.9999-MCARDT X ^DD("DD")
72 .. S L=L+1 S ^TMP("OR",$J,"MCAR","OT",L)=MCARPROC_U_DA_U_$P(PR,U,3,5)_U_J S $P(^(L),U,6)=Y,$P(^(L),U,7)=K,$P(^(L),U,10)=M,$P(^(L),U,11)=$S(WH="P":I_U_$P(J,U,2),1:J)
73 Q
Note: See TracBrowser for help on using the repository browser.