source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRSLAB.m@ 619

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