LRGEN2 ;SLC/RWF-CUMULATIVE REPORT FOR SELECTED TESTS ;8/25/87 08:35 [ 04/14/2003 8:40 AM ]
;;5.2T9;LR;**1003,1004,1013,1015,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**121,153,221**;Sep 27, 1994
TESTS ;from LRGEN
N LRCUTE
S LRTSTS=0,DIC="^LAB(60,",DIC(0)="AEMOQ",DIC("S")="I ""BO""[$P(^(0),U,3)!$D(^XUSEC(""LRLAB"",DUZ))" D ^DIC Q:Y<1 S LRONETST=+Y
I $L($P(^LAB(60,+Y,.1),U,5)) S LRCUTE=$P(^(.1),U,4,5) K DIC("S") D Q
. I $G(LRDONT) D LRTP S (LRIX,LRTSTS,LRPRETTY)=1,LRTEST(+LRONETST)=LRCUTE Q
. D @LRCUTE S LRTSTS=0 Q ;pretty print routine
D LRTP F I=0:0 D ^DIC Q:Y<0 S LRONETST="" D LRTP
D:'LRONETST SPEC Q:LREND I LRONETST S Y=+$O(LRTEST(0)) D LRTP D:'LRTP TYPE Q:LREND
S LRXPD="S LRSUB=$P(^TMP(""LR"",$J,""T"",X),U,5) S:$L(LRSUB) ^TMP(""LR"",$J,""TMP"",LRSUB)=^LAB(60,+$O(^LAB(60,""C"",LRSUB,0)),.1),^TMP(""LR"",$J,""TMP"",LRSUB,1)=$S($D(^LAB(60,+$O(^LAB(60,""C"",LRSUB,0)),1,LRTP,0)):^(0),1:"""")"
S LRTEST=0 F I=0:0 S LRTEST=+$O(LRTEST(LRTEST)) Q:LRTEST<1 S LREXPD=LRXPD D ^LREXPD
COAG ;K LRXPD Q:LRTSTS>18 S LRSSP=0,LRIX=1,(LRPS,LRHDR,LRUT,LRNG)="",LRORD=+$O(LRORD(0)) I LRORD<1 W !!,$C(7),"TEST NOT IMPLEMENTED" Q
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
K LRXPD Q:LRTSTS>18 S LRSSP=0,LRIX=1,(LRPS,LRHDR,LRUT,LRNG)="",LRHDR=" ",LRORD=+$O(LRORD(0)) I LRORD<1 W !!,$C(7),"TEST NOT IMPLEMENTED" Q ;IHS/ITSC/TPF 10/1/01 TESTING ADDED SPACES TO LRHDR TO MOVE TEST HEADER OVER PATCH **1013*
;----- END IHS MODIFICATIONS
S LRTN=LRORD(LRORD),LRTN=$P(^TMP("LR",$J,"T",LRTN),U,5),LRPS=$P(LRTN,";"),LRIX(1)=0,LRSUB(1)=LRPS ;used by coag
I LRTN<0 W !!,$C(7),"TEST NOT IMPLEMENTED" Q
S:'$L($G(SEX)) SEX="M" S:'$L($G(AGE)) AGE=99
F I=0:0 D MUSH S LRORD=+$O(LRORD(LRORD)) Q:LRORD'>0 S LRTN=$P(^TMP("LR",$J,"T",LRORD(LRORD)),U,5) Q:LRTN<0
S:$L(LRHDR) LRHDR(LRIX)=$E(LRHDR,4,255),LRHDR(LRIX,1)=$E(LRUT,4,255),LRHDR(LRIX,2)=$E(LRNG,1,255) S LRSUB(LRIX+1)=LRSUB,LRIX(LRIX+1)=LRSSP S:'$L(LRHDR) LRIX=LRIX-1
K ^TMP("LR",$J,"TMP"),DIC,LRUT S LRHDR=""
Q
MUSH I '$D(^XUSEC("LRLAB",DUZ)),"BO"'[$P(^LAB(60,LRORD(LRORD),0),U,3) Q
S X=^TMP("LR",$J,"TMP",LRTN),LRSUB=$P(LRTN,";",1)
I LRPS'=LRSUB D:LRIX(LRIX)'=LRSSP PUSH S LRSUB(LRIX)=LRSUB,LRPS=LRSUB
S LRSSP=LRSSP+1,LRND(LRSSP)=$P(LRTN,";",2),LRPP(LRSSP)=$P(LRTN,";",3) S:$L($P(X,U,3)) LRPR(LRSSP)=$P(X,U,3)
S LRHDR=LRHDR_$$RJ^XLFSTR($P(X,U),LRCW) S:LRTP LRUT=LRUT_$$RJ^XLFSTR($E($P(^TMP("LR",$J,"TMP",LRTN,1),U,7),1,7),LRCW)
I LRTP S X=$S($L($P(^TMP("LR",$J,"TMP",LRTN,1),U,11,12))>1:$P(^(1),U,11,12),$L($P(^(1),U,2,3))>1:$P(^(1)_"^",U,2,3)_"^1",1:"^^1"),LRHI=$P(X,U,2),LRLO=$P(X,U) S:'$P(X,U,3) LRTHER=1
I LRTP S @("LRHI="_$S($L(LRHI):LRHI,1:"""""")),@("LRLO="_$S($L(LRLO):LRLO,1:"""""")),LRNG=LRNG_$S($L(LRHI_LRLO):$$RJ^XLFSTR(LRLO_"-"_LRHI,LRCW),1:" ")
I LRSSP-LRIX(LRIX)#6=0 D PUSH S LRSUB(LRIX)=LRSUB,LRPS=LRSUB
Q
PUSH S LRIX=LRIX+1,LRHDR(LRIX-1)=$E(LRHDR,4,255),LRHDR="",LRHDR(LRIX-1,1)=$E(LRUT,4,255),LRUT="",LRHDR(LRIX-1,2)=$E(LRNG,1,255),LRNG="",LRIX(LRIX)=LRSSP
Q
LRTP S LRTP=""
I $P(^LAB(60,+Y,0),U,8) S LRTP=$S($D(^LAB(60,+Y,3,1,0)):+^(0),1:0),LRTP=$S($D(^LAB(62,LRTP,0)):$P(^(0),U,2),1:0) S:LRTP LRTP(+Y)=LRTP
I $L($P(^LAB(60,+Y,.1),U,5)) W !!?2,$P(^LAB(60,+Y,0),U)," has a specialized print routine",!?2," and must be selected by itself.",$C(7),! Q
S LRTEST(+Y)="" S:'LRTP LRONETST=""
Q
SPEC Q:'$D(LRTP) W ! S LRTP="" F I=0:0 S LRTP=$O(LRTP(LRTP)) Q:LRTP="" W !,?20,$P(^LAB(60,LRTP,0),U),?40,$P(^LAB(61,LRTP(LRTP),0),U),?65,$P(^(0),U,2)
I $D(LRTP)=11 W !!,"Listed above are the site/specimens for 'UNIQUE COLLECTION SAMPLES'",!,"defined for the tests selected. To see reference ranges, a specific",!,"site/specimen must be selected."
K LRTP S LRTP=0
TYPE W !!?3,"Specify specimen actually tested. Use BLOOD when Whole blood is tested;",!,"use SERUM when Serum is tested; etc. In doubt press the Return key."
K DIC("S") S LRONESPC="",DIC="^LAB(61,",DIC("A")="Select SITE/SPECIMEN: ANY//",DIC(0)="AEMOQ",LRTP=0 D ^DIC S:$D(DUOUT)!$D(DTOUT) LREND=1 Q:LREND S:Y>0 LRTP=+Y,LRONESPC=LRTP K DIC("A")
Q
SPC ;from LRSOR1
D COAG
Q
LRGEN2 ;SLC/RWF-CUMULATIVE REPORT FOR SELECTED TESTS ;8/25/87 08:35 [ 04/14/2003 8:40 AM ]
+1 ;;5.2T9;LR;**1003,1004,1013,1015,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**121,153,221**;Sep 27, 1994
TESTS ;from LRGEN
+1 NEW LRCUTE
+2 SET LRTSTS=0
SET DIC="^LAB(60,"
SET DIC(0)="AEMOQ"
SET DIC("S")="I ""BO""[$P(^(0),U,3)!$D(^XUSEC(""LRLAB"",DUZ))"
DO ^DIC
IF Y<1
QUIT
SET LRONETST=+Y
+3 IF $LENGTH($PIECE(^LAB(60,+Y,.1),U,5))
SET LRCUTE=$PIECE(^(.1),U,4,5)
KILL DIC("S")
Begin DoDot:1
+4 IF $GET(LRDONT)
DO LRTP
SET (LRIX,LRTSTS,LRPRETTY)=1
SET LRTEST(+LRONETST)=LRCUTE
QUIT
+5 ;pretty print routine
DO @LRCUTE
SET LRTSTS=0
QUIT
End DoDot:1
QUIT
+6 DO LRTP
FOR I=0:0
DO ^DIC
IF Y<0
QUIT
SET LRONETST=""
DO LRTP
+7 IF 'LRONETST
DO SPEC
IF LREND
QUIT
IF LRONETST
SET Y=+$ORDER(LRTEST(0))
DO LRTP
IF 'LRTP
DO TYPE
IF LREND
QUIT
+8 SET LRXPD="S LRSUB=$P(^TMP(""LR"",$J,""T"",X),U,5) S:$L(LRSUB) ^TMP(""LR"",$J,""TMP"",LRSUB)=^LAB(60,+$O(^LAB(60,""C"",LRSUB,0)),.1),^TMP(""LR"",$J,""TMP"",LRSUB,1)=$S($D(^LAB(60,+$O(^LAB(60,""C"",LRSUB,0)),1,LRTP,0)):^(0),1:"""")"
+9 SET LRTEST=0
FOR I=0:0
SET LRTEST=+$ORDER(LRTEST(LRTEST))
IF LRTEST<1
QUIT
SET LREXPD=LRXPD
DO ^LREXPD
COAG ;K LRXPD Q:LRTSTS>18 S LRSSP=0,LRIX=1,(LRPS,LRHDR,LRUT,LRNG)="",LRORD=+$O(LRORD(0)) I LRORD<1 W !!,$C(7),"TEST NOT IMPLEMENTED" Q
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ITSC/TPF 10/1/01 TESTING ADDED SPACES TO LRHDR TO MOVE TEST HEADER OVER PATCH **1013*
KILL LRXPD
IF LRTSTS>18
QUIT
SET LRSSP=0
SET LRIX=1
SET (LRPS,LRHDR,LRUT,LRNG)=""
SET LRHDR=" "
SET LRORD=+$ORDER(LRORD(0))
IF LRORD<1
WRITE !!,$CHAR(7),"TEST NOT IMPLEMENTED"
QUIT
+3 ;----- END IHS MODIFICATIONS
+4 ;used by coag
SET LRTN=LRORD(LRORD)
SET LRTN=$PIECE(^TMP("LR",$JOB,"T",LRTN),U,5)
SET LRPS=$PIECE(LRTN,";")
SET LRIX(1)=0
SET LRSUB(1)=LRPS
+5 IF LRTN<0
WRITE !!,$CHAR(7),"TEST NOT IMPLEMENTED"
QUIT
+6 IF '$LENGTH($GET(SEX))
SET SEX="M"
IF '$LENGTH($GET(AGE))
SET AGE=99
+7 FOR I=0:0
DO MUSH
SET LRORD=+$ORDER(LRORD(LRORD))
IF LRORD'>0
QUIT
SET LRTN=$PIECE(^TMP("LR",$JOB,"T",LRORD(LRORD)),U,5)
IF LRTN<0
QUIT
+8 IF $LENGTH(LRHDR)
SET LRHDR(LRIX)=$EXTRACT(LRHDR,4,255)
SET LRHDR(LRIX,1)=$EXTRACT(LRUT,4,255)
SET LRHDR(LRIX,2)=$EXTRACT(LRNG,1,255)
SET LRSUB(LRIX+1)=LRSUB
SET LRIX(LRIX+1)=LRSSP
IF '$LENGTH(LRHDR)
SET LRIX=LRIX-1
+9 KILL ^TMP("LR",$JOB,"TMP"),DIC,LRUT
SET LRHDR=""
+10 QUIT
MUSH IF '$DATA(^XUSEC("LRLAB",DUZ))
IF "BO"'[$PIECE(^LAB(60,LRORD(LRORD),0),U,3)
QUIT
+1 SET X=^TMP("LR",$JOB,"TMP",LRTN)
SET LRSUB=$PIECE(LRTN,";",1)
+2 IF LRPS'=LRSUB
IF LRIX(LRIX)'=LRSSP
DO PUSH
SET LRSUB(LRIX)=LRSUB
SET LRPS=LRSUB
+3 SET LRSSP=LRSSP+1
SET LRND(LRSSP)=$PIECE(LRTN,";",2)
SET LRPP(LRSSP)=$PIECE(LRTN,";",3)
IF $LENGTH($PIECE(X,U,3))
SET LRPR(LRSSP)=$PIECE(X,U,3)
+4 SET LRHDR=LRHDR_$$RJ^XLFSTR($PIECE(X,U),LRCW)
IF LRTP
SET LRUT=LRUT_$$RJ^XLFSTR($EXTRACT($PIECE(^TMP("LR",$JOB,"TMP",LRTN,1),U,7),1,7),LRCW)
+5 IF LRTP
SET X=$SELECT($LENGTH($PIECE(^TMP("LR",$JOB,"TMP",LRTN,1),U,11,12))>1:$PIECE(^(1),U,11,12),$LENGTH($PIECE(^(1),U,2,3))>1:$PIECE(^(1)_"^",U,2,3)_"^1",1:"^^1")
SET LRHI=$PIECE(X,U,2)
SET LRLO=$PIECE(X,U)
IF '$PIECE(X,U,3)
SET LRTHER=1
+6 IF LRTP
SET @("LRHI="_$SELECT($LENGTH(LRHI):LRHI,1:""""""))
SET @("LRLO="_$SELECT($LENGTH(LRLO):LRLO,1:""""""))
SET LRNG=LRNG_$SELECT($LENGTH(LRHI_LRLO):$$RJ^XLFSTR(LRLO_"-"_LRHI,LRCW),1:" ")
+7 IF LRSSP-LRIX(LRIX)#6=0
DO PUSH
SET LRSUB(LRIX)=LRSUB
SET LRPS=LRSUB
+8 QUIT
PUSH SET LRIX=LRIX+1
SET LRHDR(LRIX-1)=$EXTRACT(LRHDR,4,255)
SET LRHDR=""
SET LRHDR(LRIX-1,1)=$EXTRACT(LRUT,4,255)
SET LRUT=""
SET LRHDR(LRIX-1,2)=$EXTRACT(LRNG,1,255)
SET LRNG=""
SET LRIX(LRIX)=LRSSP
+1 QUIT
LRTP SET LRTP=""
+1 IF $PIECE(^LAB(60,+Y,0),U,8)
SET LRTP=$SELECT($DATA(^LAB(60,+Y,3,1,0)):+^(0),1:0)
SET LRTP=$SELECT($DATA(^LAB(62,LRTP,0)):$PIECE(^(0),U,2),1:0)
IF LRTP
SET LRTP(+Y)=LRTP
+2 IF $LENGTH($PIECE(^LAB(60,+Y,.1),U,5))
WRITE !!?2,$PIECE(^LAB(60,+Y,0),U)," has a specialized print routine",!?2," and must be selected by itself.",$CHAR(7),!
QUIT
+3 SET LRTEST(+Y)=""
IF 'LRTP
SET LRONETST=""
+4 QUIT
SPEC IF '$DATA(LRTP)
QUIT
WRITE !
SET LRTP=""
FOR I=0:0
SET LRTP=$ORDER(LRTP(LRTP))
IF LRTP=""
QUIT
WRITE !,?20,$PIECE(^LAB(60,LRTP,0),U),?40,$PIECE(^LAB(61,LRTP(LRTP),0),U),?65,$PIECE(^(0),U,2)
+1 IF $DATA(LRTP)=11
WRITE !!,"Listed above are the site/specimens for 'UNIQUE COLLECTION SAMPLES'",!,"defined for the tests selected. To see reference ranges, a specific",!,"site/specimen must be selected."
+2 KILL LRTP
SET LRTP=0
TYPE WRITE !!?3,"Specify specimen actually tested. Use BLOOD when Whole blood is tested;",!,"use SERUM when Serum is tested; etc. In doubt press the Return key."
+1 KILL DIC("S")
SET LRONESPC=""
SET DIC="^LAB(61,"
SET DIC("A")="Select SITE/SPECIMEN: ANY//"
SET DIC(0)="AEMOQ"
SET LRTP=0
DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
SET LREND=1
IF LREND
QUIT
IF Y>0
SET LRTP=+Y
SET LRONESPC=LRTP
KILL DIC("A")
+2 QUIT
SPC ;from LRSOR1
+1 DO COAG
+2 QUIT
