MCARPS2 ;SLC/dcm,WAA Summary of patient procedures for CPRS ;12/15/97 14:49
;;2.3;Medicine;**15,33,39**;09/13/1996
;Modified from MCARPS1 for CPRS
; Please Reference DBIA # 3397
EN(DFN) ;Get procedures for a patient
I '$$PATCH^XPDUTL("MD*1.0*2") G MED
N MCGLB,MCBLK,MCRT K ^TMP("OR",$J,"MCAR") S MCGLB=$NA(^TMP("OR",$J,"MCAR","OT"))
S MCBLK="",MCRT="D EN1^MDPS1(.MCGLB,DFN,MCBLK,MCBLK,99999,MCBLK,MCBLK)"
X MCRT
Q
MED S WH=""
K ^TMP("OR",$J,"MCAR") S S4="" F M=1:1 S S4=$O(^MCAR(690,"AC",DFN,S4)) Q:S4="" D LOCFIL
D PR0
Q
LOCFIL G LOCFIL1:$D(S5) S S5="" F K=1:1 S S5=$O(^MCAR(690,"AC",DFN,S4,S5)) Q:S5="" D LOCFIL1
K S5 Q
LOCFIL1 S S6="" F L=1:1 S S6=$O(^MCAR(690,"AC",DFN,S4,S5,S6)) Q:S6="" D CONT
Q
CONT ;CONT+1 modified on 2-7-94,S MCFILE..2) added to conform w/alpha site
I $D(^MCAR(+$P(S5,"(",2),S6,2005)) S MCFILE=+$P(S5,"(",2) D SUM^MCMAG
I S5="MCAR(702.7" Q
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
;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
I S5="MCAR(699.5",'$D(PE) D Q ;MC*2.3*8
.S LL6=$P($G(^MCAR(699.5,S6,0)),U,6),LL8=$P($G(^MCAR(699.5,S6,0)),U,8)
.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
I S5="MCAR(699.5",$D(PE) D Q ;MC*2.3*8
.S LL6=$P($G(^MCAR(699.5,S6,0)),U,6),LL8=$P($G(^MCAR(699.5,S6,0)),U,8)
.S (LL,LL1)=$P($G(^MCAR(699.5,S6,0)),U,6) Q:'LL S LL=$P($G(^MCAR(697.2,LL,0)),U)
.N LLX,LLY
.S LLX=$O(^MCAR(697.2,"B",PE,0)) Q:'LLX S LLY=$P($G(^MCAR(697.2,LLX,1)),U)
.I LLY="S",LLX=LL6 D CONT1
.I LLY="P",LLX=LL8 D CONT1
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
;MFD 2/5/93 I S5[700,$P($G(^MCAR(700,S6,2)),U)'="Y" Q ; exclude unreleased PFT
S (LL,LL1)=$O(^MCAR(697.2,"C",S5,0)),LL=$P(^MCAR(697.2,LL,0),U,1)
CONT1 ;
S REC=$O(^MCAR(697.2,"B",LL,0)) S:REC="" REC=0
S MCARCODE=""
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)
S (MCARSUM,MCARPSUM)="",MCARFILE=U_S5_","_S6_",.2)" S:$D(@MCARFILE) MCARSUM=$P(@MCARFILE,U,1),MCARPSUM=$P(@MCARFILE,U,2)
K MCARFILE S S1=$S(WH="P":LL,1:S4),S2=$S(WH="P":S4,1:LL)
S MCFILE=+$P(S5,"(",2)
I MCESON,($G(MCESKEY)'=""),('$$SCRSUMPT^MCESSCR(MCESKEY,S6,MCSUP)) K MCARSUM,MCARPSUM,MCFILE,REC,MCSUP Q
I '$$VALID^MCARUTL5(S5,S6,DFN) Q ; MC*2.3*33
I $P($G(@(U_S5_","_S6_",""ES"")")),U,7)="S" G EXIT ;MC*2.3*8
S S2=S2_U_S6 ;MC*2.3*8
S ^TMP("OR",$J,"MCAR",S1,S2)=MCARSUM_U_S6_U_$P(^MCAR(697.2,LL1,0),U,5,7)
;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
;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
;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
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
S $P(^TMP("OR",$J,"MCAR",S1,S2),U,10)=MCARPSUM
S $P(^TMP("OR",$J,"MCAR",S1,S2),U,11)=LL
I S5="MCAR(699.5" D ;MC*2.3*8
.I LL8="" S LL8=" "
.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
EXIT K MCARSUM,MCARPSUM,REC,MCSUP,MCESON Q
PR0 S I="",L=0
F S I=$O(^TMP("OR",$J,"MCAR",I)) Q:I="" I I'="OT" D
. S J="" F S J=$O(^TMP("OR",$J,"MCAR",I,J)) Q:J="" S PR=^(J) D
.. Q:$P(PR,U,3,5)="^^" ; MC*2.3*33
.. S MCARDT=$S(WH="P":$P(J,U),1:I),MCARPROC=$S(WH="P":I,1:$P(J,U))
.. S MCARPROC=$O(^MCAR(697.2,"B",MCARPROC,0)),MCARPROC=$P(^MCAR(697.2,MCARPROC,0),U,8)
.. I $P(PR,U,12)'="" S MCARPROC=$P(PR,U,12)
.. S DA=$P(PR,U,2),K=$P(PR,U),M=$P(PR,U,10)
.. 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:"")
.. S Y=9999999.9999-MCARDT X ^DD("DD")
.. 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)
Q
MCARPS2 ;SLC/dcm,WAA Summary of patient procedures for CPRS ;12/15/97 14:49
+1 ;;2.3;Medicine;**15,33,39**;09/13/1996
+2 ;Modified from MCARPS1 for CPRS
+3 ; Please Reference DBIA # 3397
EN(DFN) ;Get procedures for a patient
+1 IF '$$PATCH^XPDUTL("MD*1.0*2")
GOTO MED
+2 NEW MCGLB,MCBLK,MCRT
KILL ^TMP("OR",$JOB,"MCAR")
SET MCGLB=$NAME(^TMP("OR",$JOB,"MCAR","OT"))
+3 SET MCBLK=""
SET MCRT="D EN1^MDPS1(.MCGLB,DFN,MCBLK,MCBLK,99999,MCBLK,MCBLK)"
+4 XECUTE MCRT
+5 QUIT
MED SET WH=""
+1 KILL ^TMP("OR",$JOB,"MCAR")
SET S4=""
FOR M=1:1
SET S4=$ORDER(^MCAR(690,"AC",DFN,S4))
IF S4=""
QUIT
DO LOCFIL
+2 DO PR0
+3 QUIT
LOCFIL IF $DATA(S5)
GOTO LOCFIL1
SET S5=""
FOR K=1:1
SET S5=$ORDER(^MCAR(690,"AC",DFN,S4,S5))
IF S5=""
QUIT
DO LOCFIL1
+1 KILL S5
QUIT
LOCFIL1 SET S6=""
FOR L=1:1
SET S6=$ORDER(^MCAR(690,"AC",DFN,S4,S5,S6))
IF S6=""
QUIT
DO CONT
+1 QUIT
CONT ;CONT+1 modified on 2-7-94,S MCFILE..2) added to conform w/alpha site
+1 IF $DATA(^MCAR(+$PIECE(S5,"(",2),S6,2005))
SET MCFILE=+$PIECE(S5,"(",2)
DO SUM^MCMAG
+2 IF S5="MCAR(702.7"
QUIT
+3 IF S5="MCAR(699"
SET (LL,LL1)=$PIECE($GET(^MCAR(699,S6,0)),U,12)
IF LL'>0
QUIT
SET LL=$PIECE($GET(^MCAR(697.2,LL,0)),U)
IF '$DATA(PE)
GOTO CONT1
IF PE'=LL
QUIT
GOTO CONT1
+4 ;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
+5 ;MC*2.3*8
IF S5="MCAR(699.5"
IF '$DATA(PE)
Begin DoDot:1
+6 SET LL6=$PIECE($GET(^MCAR(699.5,S6,0)),U,6)
SET LL8=$PIECE($GET(^MCAR(699.5,S6,0)),U,8)
+7 SET (LL,LL1)=$PIECE($GET(^MCAR(699.5,S6,0)),U,6)
IF 'LL
QUIT
SET LL=$PIECE($GET(^MCAR(697.2,LL,0)),U)
DO CONT1
End DoDot:1
QUIT
+8 ;MC*2.3*8
IF S5="MCAR(699.5"
IF $DATA(PE)
Begin DoDot:1
+9 SET LL6=$PIECE($GET(^MCAR(699.5,S6,0)),U,6)
SET LL8=$PIECE($GET(^MCAR(699.5,S6,0)),U,8)
+10 SET (LL,LL1)=$PIECE($GET(^MCAR(699.5,S6,0)),U,6)
IF 'LL
QUIT
SET LL=$PIECE($GET(^MCAR(697.2,LL,0)),U)
+11 NEW LLX,LLY
+12 SET LLX=$ORDER(^MCAR(697.2,"B",PE,0))
IF 'LLX
QUIT
SET LLY=$PIECE($GET(^MCAR(697.2,LLX,1)),U)
+13 IF LLY="S"
IF LLX=LL6
DO CONT1
+14 IF LLY="P"
IF LLX=LL8
DO CONT1
End DoDot:1
QUIT
+15 IF S5[694
SET (LL,LL1)=$PIECE($GET(^MCAR(694,S6,0)),U,3)
IF 'LL
QUIT
SET LL=$PIECE(^MCAR(697.2,LL,0),U)
IF '$DATA(PE)
GOTO CONT1
IF PE'=LL
QUIT
GOTO CONT1
+16 ;MFD 2/5/93 I S5[700,$P($G(^MCAR(700,S6,2)),U)'="Y" Q ; exclude unreleased PFT
+17 SET (LL,LL1)=$ORDER(^MCAR(697.2,"C",S5,0))
SET LL=$PIECE(^MCAR(697.2,LL,0),U,1)
CONT1 ;
+1 SET REC=$ORDER(^MCAR(697.2,"B",LL,0))
IF REC=""
SET REC=0
+2 SET MCARCODE=""
+3 SET MCESON=$PIECE($GET(^MCAR(697.2,REC,0)),U,14)
SET MCESKEY=$PIECE($GET(^MCAR(697.2,REC,0)),U,15)
SET MCSUP=+$PIECE($GET(^MCAR(697.2,REC,0)),U,16)
+4 SET (MCARSUM,MCARPSUM)=""
SET MCARFILE=U_S5_","_S6_",.2)"
IF $DATA(@MCARFILE)
SET MCARSUM=$PIECE(@MCARFILE,U,1)
SET MCARPSUM=$PIECE(@MCARFILE,U,2)
+5 KILL MCARFILE
SET S1=$SELECT(WH="P":LL,1:S4)
SET S2=$SELECT(WH="P":S4,1:LL)
+6 SET MCFILE=+$PIECE(S5,"(",2)
+7 IF MCESON
IF ($GET(MCESKEY)'="")
IF ('$$SCRSUMPT^MCESSCR(MCESKEY,S6,MCSUP))
KILL MCARSUM,MCARPSUM,MCFILE,REC,MCSUP
QUIT
+8 ; MC*2.3*33
IF '$$VALID^MCARUTL5(S5,S6,DFN)
QUIT
+9 ;MC*2.3*8
IF $PIECE($GET(@(U_S5_","_S6_",""ES"")")),U,7)="S"
GOTO EXIT
+10 ;MC*2.3*8
SET S2=S2_U_S6
+11 SET ^TMP("OR",$JOB,"MCAR",S1,S2)=MCARSUM_U_S6_U_$PIECE(^MCAR(697.2,LL1,0),U,5,7)
+12 ;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
+13 ;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
+14 ;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
+15 ; MC*2.3*33
IF $PIECE(^MCAR(697.2,LL1,0),U,2)'=S5
SET $PIECE(^TMP("OR",$JOB,"MCAR",S1,S2),U,3,5)="EN1^MCARGP^PARAC"
+16 SET $PIECE(^TMP("OR",$JOB,"MCAR",S1,S2),U,10)=MCARPSUM
+17 SET $PIECE(^TMP("OR",$JOB,"MCAR",S1,S2),U,11)=LL
+18 ;MC*2.3*8
IF S5="MCAR(699.5"
Begin DoDot:1
+19 IF LL8=""
SET LL8=" "
+20 SET $PIECE(^TMP("OR",$JOB,"MCAR",S1,S2),U,12)=$EXTRACT(($EXTRACT($PIECE($GET(^MCAR(697.2,LL6,0)),U,8),1,13)_"/"_$PIECE($GET(^MCAR(697.2,LL8,0)),U)),1,31)
KILL LL6,LL8
End DoDot:1
EXIT KILL MCARSUM,MCARPSUM,REC,MCSUP,MCESON
QUIT
PR0 SET I=""
SET L=0
+1 FOR
SET I=$ORDER(^TMP("OR",$JOB,"MCAR",I))
IF I=""
QUIT
IF I'="OT"
Begin DoDot:1
+2 SET J=""
FOR
SET J=$ORDER(^TMP("OR",$JOB,"MCAR",I,J))
IF J=""
QUIT
SET PR=^(J)
Begin DoDot:2
+3 ; MC*2.3*33
IF $PIECE(PR,U,3,5)="^^"
QUIT
+4 SET MCARDT=$SELECT(WH="P":$PIECE(J,U),1:I)
SET MCARPROC=$SELECT(WH="P":I,1:$PIECE(J,U))
+5 SET MCARPROC=$ORDER(^MCAR(697.2,"B",MCARPROC,0))
SET MCARPROC=$PIECE(^MCAR(697.2,MCARPROC,0),U,8)
+6 IF $PIECE(PR,U,12)'=""
SET MCARPROC=$PIECE(PR,U,12)
+7 SET DA=$PIECE(PR,U,2)
SET K=$PIECE(PR,U)
SET M=$PIECE(PR,U,10)
+8 SET K=$SELECT(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:"")
+9 SET Y=9999999.9999-MCARDT
XECUTE ^DD("DD")
+10 SET L=L+1
SET ^TMP("OR",$JOB,"MCAR","OT",L)=MCARPROC_U_DA_U_$PIECE(PR,U,3,5)_U_J
SET $PIECE(^(L),U,6)=Y
SET $PIECE(^(L),U,7)=K
SET $PIECE(^(L),U,10)=M
SET $PIECE(^(L),U,11)=$SELECT(WH="P":I_U_$PIECE(J,U,2),1:J)
End DoDot:2
End DoDot:1
+11 QUIT
