73 lines
4.0 KiB
Mathematica
73 lines
4.0 KiB
Mathematica
IMRSLAB ;ISC-SF.SEA/JLI/NCA-Local Listing of Utilization of Specific Lab Tests ;7/31/97 15:09
|
|
;;2.1;IMMUNOLOGY CASE REGISTRY;;Feb 09, 1998
|
|
;[IMR SPECFC LAB LIST]
|
|
I '$D(^XUSEC("IMRMGR",DUZ)) S IMRLOC="IMRSLAB" D ACESSERR^IMRERR,H^XUS K IMRLOC
|
|
ASK S %DT="AQEXP",%DT("A")=" Start Date for Period: " D ^%DT K %DT G:Y'>0 KILL S IMRSD=Y,%DT="AQEXP",%DT("A")=" End Date for Period: " D ^%DT K %DT G:Y'>0 KILL S IMRED=Y
|
|
I IMRED<IMRSD W !,$C(7),"END CAN NOT BE BEFORE START",! G ASK
|
|
K DIC,^TMP($J,"IMRLAB") S DIC("?")="Select a specific Laboratory Test Name, IT CAN NOT BE A PANEL of tests",IMRN=0
|
|
TEST S DIC=60,DIC(0)="AEQM",DIC("S")="I $O(^LAB(60,Y,2,0))=""""" D ^DIC
|
|
G:$D(DTOUT)!($D(DUOUT)) KILL
|
|
I Y>0 S IMRN=IMRN+1,^TMP($J,"IMRLAB",+Y)=IMRN,DIC("A")="Select ANOTHER Laboratory Test NAME: " G TEST
|
|
K DIC G:'$D(^TMP($J,"IMRLAB")) KILL
|
|
D LRARC^IMRUTL ;get lab archive date
|
|
I IMRLRC,IMRLRC'<IMRSD,IMRLRC'>IMRED D ASKN I $D(DIRUT) D KILL Q
|
|
I IMRLRC,IMRLRC'<IMRSD,IMRLRC>IMRED D ASKN I $D(DIRUT) D KILL Q
|
|
D IMRDEV^IMREDIT G:POP KILL
|
|
I $D(IO("Q")) D SAVE,^%ZISC G KILL
|
|
U IO D DQ D ^%ZISC K %ZIS,IOP G KILL
|
|
SAVE ; ZTSAVE the Variables Used
|
|
S ZTRTN="DQ^IMRSLAB",ZTIO=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("^TMP($J,""IMRLAB"",")="",ZTDESC="Selected LAB Activty"
|
|
D ^%ZTLOAD
|
|
K IO("Q"),ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK G KILL
|
|
Q
|
|
DQ ; Start report
|
|
U IO K ^TMP($J,"I"),^("T") S IMRC="CANC",IMRC1="canc"
|
|
S:$D(ZTQUEUED) ZTREQ="@"
|
|
S (IMRPG,IMRUT)=0 D NOW^%DTC S IMRDTE=%,Y=IMRDTE D DD^%DT S IMRDTE=Y
|
|
F I=0:0 S I=$O(^TMP($J,"IMRLAB",I)) Q:I'>0 S J=^(I) I $D(^LAB(60,I,0))#2 S X=$P(^LAB(60,I,0),U,5),X=$P(X,";",2) I X'="" S ^TMP($J,"I",X)=J_U_I,^TMP($J,"T",J,X)=0
|
|
K ^TMP($J,"IMRLAB")
|
|
F IMRJ=0:0 S IMRJ=$O(^IMR(158,IMRJ)) Q:IMRJ'>0 S X=+^(IMRJ,0) D ^IMRXOR S IMRDFN=X I $D(^DPT(IMRDFN,0)),$D(^("LR")) S IMRLRFN=+^("LR") I IMRLRFN>0 S DFN=IMRDFN D NS^IMRCALL K DFN S IMRN=IMRNAM K IMRNAM,IMRSSN D C1
|
|
D A1,LABPRNT
|
|
D:'IMRUT EOP
|
|
Q
|
|
KILL K %,%DT,%I,DIC,DTOUT,DUOUT,IMRLRC,IMRC,IMRC1,IMRFLG,IMRJ,IMRN,IMRSTN,IMRSD,IMRED,IMRX,IMRD,IMRAD,IMRDD,IMRDFN,IMRI,IMRLRFN,IMRUT,I,J,K,M,N,POP,X,X1,Y,DFN,K1,T,IMRV,VAERR,IMRY,IMRZ,DISYS,IMRDTE,IMRPG,IMRYES,IMRDL
|
|
K ^TMP($J)
|
|
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 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(^TMP($J,"I",J)),X'[IMRC,X'[IMRC1 S N=+^TMP($J,"I",J),^(J)=^TMP($J,"T",N,J)+1,^(IMRDFN)=$S($D(^(J,IMRN,IMRDFN)):^(IMRDFN),1:0)+1
|
|
Q
|
|
A1 F I=0:0 S I=$O(^TMP($J,"T",I)) Q:I'>0 S T=$O(^(I,0)),N=0 S IMRN="" F S IMRN=$O(^TMP($J,"T",I,T,IMRN)) S:IMRN="" ^(T)=^TMP($J,"T",I,T)_U_N Q:IMRN="" F J=0:0 S J=$O(^TMP($J,"T",I,T,IMRN,J)) Q:J'>0 S N=N+1
|
|
Q
|
|
LABPRNT ;
|
|
S IMRD="FOR THE PERIOD "_$E(IMRSD,4,5)_"/"_$E(IMRSD,6,7)_"/"_$E(IMRSD,2,3)_" TO "_$E(IMRED,4,5)_"/"_$E(IMRED,6,7)_"/"_$E(IMRED,2,3)
|
|
Q:'$D(^TMP($J,"T")) S IMRX="UTILIZATION OF SPECIFIC LAB TESTS"
|
|
D HEDR
|
|
F I=0:0 S I=$O(^TMP($J,"T",I)) Q:I'>0!(IMRUT) S T=$O(^(I,0)),X=$P(^TMP($J,"I",T),U,2),IMRV=$P(^LAB(60,X,0),U) D PRNTA
|
|
Q
|
|
PRNTA ;
|
|
S IMRY=+^TMP($J,"T",I,T),IMRZ=+$P(^(T),U,2)
|
|
I (($Y+IMRY)>(IOSL-4)) D EOP Q:IMRUT D HEDR
|
|
W !!!,"Lab Test: ",$E(IMRV,1,30),?42,$J(IMRY,6)," test",$S(IMRY'=1:"s",1:" ")," for",$J(IMRZ,6)," patient",$S(IMRZ'=1:"s",1:"")
|
|
W ! S J=""
|
|
F S J=$O(^TMP($J,"T",I,T,J)) Q:J=""!(IMRUT) F K=0:0 S K=$O(^TMP($J,"T",I,T,J,K)) Q:K'>0!(IMRUT) S N=^(K) D
|
|
.I ($Y>(IOSL-4)) D EOP Q:IMRUT D HEDR,HEDR1
|
|
.S DFN=K D NS^IMRCALL W !?5,$E(IMRNAM,1,25),?30,IMRSSN,?40,$J(N,6)," test",$S(N'=1:"s",1:"")
|
|
.Q
|
|
K IMRNAM,IMRSSN
|
|
Q
|
|
ASKN ; Ask User Whether they Want to Query the National
|
|
S IMRYES=0 D ASKQ1^IMRNTL Q:'IMRYES S IMRDL="" D ASKQ2^IMRNTL Q:IMRDL="" D MSG^IMRNTL,LABS^IMRNTL1
|
|
Q
|
|
EOP ; Check End of Page
|
|
Q:$D(IO("S")) ;quit if a slave device
|
|
I IOST["C-" K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1
|
|
Q
|
|
HEDR ; Heading of the Specific Lab Report
|
|
W:$Y>0 @IOF S IMRPG=IMRPG+1
|
|
W !,IMRDTE,?(IOM-$L(IMRX)\2),IMRX,?(IOM-8),"Page ",IMRPG,!?(IOM-$L(IMRD)\2),IMRD,!
|
|
Q
|
|
HEDR1 W !!!,"Lab Test: ",$E(IMRV,1,30)," (continued)",!
|
|
Q
|