50 lines
2.0 KiB
Mathematica
50 lines
2.0 KiB
Mathematica
IMRSUDLB ;HCIOFO/FT/FAI-LOCAL LISTING OF LAB UTILIZATION ;07/17/00 17:09
|
|
;;2.1;IMMUNOLOGY CASE REGISTRY;**5**;Feb 09, 1998
|
|
D LRARC^IMRUTL ;check Lab archive date
|
|
S IMRUT=0
|
|
DQ ;
|
|
U IO D GETNOW^IMRACESS
|
|
K ^TMP($J) S IMRC="CANC",IMRC1="canc"
|
|
F I=0:0 S I=$O(^IMR(158,I)) Q:I'>0 S X=+^(I,0),IMR1C=+$P(^(0),U,42) D XOR^IMRXOR S IMRDFN=X I $D(^DPT(IMRDFN,0)) D DQ1
|
|
F IMR0C=1:1:4,"T" S IMR1C="C"_IMR0C D A1
|
|
D ^IMRLLAB1
|
|
KILL Q
|
|
Q
|
|
DQ1 ;
|
|
F IMR0C=IMR1C,"T" S IMR1C="C"_IMR0C,^TMP($J,IMR1C,"PAT",IMRDFN)="" I $D(^DPT(IMRDFN,"LR")) S IMRLRFN=+^("LR") I IMRLRFN>0 D C1
|
|
Q
|
|
;
|
|
C1 ;
|
|
S IMRI=IMRED+1
|
|
F IMRI=9999999-IMRI:0 S IMRI=$O(^LR(IMRLRFN,"CH",IMRI)) Q:IMRI'>0!(IMRI>(9999999-IMRSD)) I $O(^(IMRI,0))>0 D C2
|
|
Q
|
|
;
|
|
C2 ;
|
|
S K=0
|
|
F J=0:0 S J=$O(^LR(IMRLRFN,"CH",IMRI,J)) Q:J'>0 I $D(^(J))#2 S X=$P(^(J),U) I $D(^DD(63.04,J,0)),X'[IMRC,X'[IMRC1 D C21
|
|
Q
|
|
C21 ;
|
|
S:K=0 ^(IMRDFN)=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN)):^(IMRDFN),1:0)+1,K=1 S ^(J)=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN,J)):^(J),1:0)+1
|
|
Q
|
|
;
|
|
A1 ;
|
|
S ^TMP($J,IMR1C,"LR")=0,^("LR","TST")=0 F IMRDFN=0:0 S IMRDFN=$O(^TMP($J,IMR1C,"PAT",IMRDFN)) Q:IMRDFN'>0 D:^(IMRDFN)>0 AA1 S:^TMP($J,IMR1C,"PAT",IMRDFN)>0 X=^(IMRDFN),^TMP($J,IMR1C,"MAX",(999999-X),IMRDFN)=X D A2
|
|
F I=0:0 S I=$O(^TMP($J,IMR1C,"LR",I)) Q:I'>0 S X=^(I),X1=^(I,"N"),N=$P(^DD(63.04,I,0),U),^TMP($J,IMR1C,"A",(999999-X1),N)=X_U_X1 D A3 K ^TMP($J,IMR1C,"LR",I)
|
|
Q
|
|
;
|
|
AA1 S I=0,J=0 F K=0:0 S K=$O(^TMP($J,IMR1C,"PAT",IMRDFN,K)) Q:K'>0 S I=I+1,J=J+^(K)
|
|
S ^(IMRDFN)=^TMP($J,IMR1C,"PAT",IMRDFN)_U_J_U_I
|
|
Q
|
|
;
|
|
A2 ;
|
|
S:$O(^TMP($J,IMR1C,"PAT",IMRDFN,0))>0 ^("LR")=^TMP($J,IMR1C,"LR")+1
|
|
S K=0 F J=0:0 S J=$O(^TMP($J,IMR1C,"PAT",IMRDFN,J)) Q:J'>0 S K=K+1,X=^(J),^("TST")=^TMP($J,IMR1C,"LR","TST")+X,^(J)=$S($D(^TMP($J,IMR1C,"LR",J)):^(J),1:0)+1,^("N")=$S($D(^(J,"N")):^("N"),1:0)+X,^(X)=$S($D(^(X)):^(X),1:0)+1
|
|
S K=+^TMP($J,IMR1C,"PAT",IMRDFN),J=999999-K,^(J)=($S($D(^TMP($J,IMR1C,"LR","N",J)):+^(J),1:0)+1)_U_K
|
|
Q
|
|
;
|
|
A3 S M=0 F K=0:0 S K=$O(^TMP($J,IMR1C,"LR",I,K)) Q:K'>0 S M=K_U_^(K)
|
|
S ^TMP($J,IMR1C,"A",(999999-X1),N,"MAX")=M
|
|
Q
|
|
;
|
|
Q
|