TIULAB ; SLC/JER - Lab objects ;7/7/95 15:22
;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
MAIN(DFN,EARLY,LATE,DISPLAY,NORM,TARGET,LINE) ; Control branching
N GMTS1,GMTS2,GMTSAGE,GMTSDOB,GMTSPNM,GMTSRB,GMTSSN,GMTSWARD,SEX
N LRDFN,MAX,I,J,SMPL,TIUY,VADPT,VAIN
K ^TMP("LRC",$J)
I $G(NORM)']"" S NORM="ALL"
I '$D(^DPT(DFN,"LR")) D NOLABS G LABX
S LRDFN=+^DPT(DFN,"LR") I '$D(^LR(LRDFN)) D NOLABS G LABX
S MAX=999,GMTS1=9999999-LATE,GMTS2=9999999-EARLY
I +$G(DISPLAY) W !,"Gathering Laboratory Data."
D ^GMTSLRCE
I '$D(^TMP("LRC",$J)) D NOLABS G LABX
D SORT($G(NORM))
S (TIUY,SMPL)="" F S SMPL=$O(^TMP("LRC",$J,NORM,SMPL)) Q:SMPL="" D
. S I=GMTS1 F S I=$O(^TMP("LRC",$J,NORM,SMPL,I)) Q:+I'>0!(I>GMTS2) D
. . S J=0 F S J=$O(^TMP("LRC",$J,NORM,SMPL,I,J)) Q:+J'>0 D LINE
K ^TMP("LRC",$J)
LABX Q "~@"_$NA(@TARGET)
NOLABS ; Handles Case Where no Labs are found to satisfy criteria
S LINE=$S(+$G(LINE):+$G(LINE),1:1),@TARGET@(LINE,0)="No data available"
S LINE=+$G(LINE)+1,@TARGET@(LINE,0)=" "
S @TARGET@(0)="^^"_LINE_"^"_LINE_"^"_DT_"^^"
Q
SORT(NFLAG) ; Sort ^TMP("LRC",$J, by reference flag
N I,J,K,L I $G(NFLAG)']"" S NFLAG="ALL"
S I=GMTS1 F S I=$O(^TMP("LRC",$J,I)) Q:+I'>0!(I>GMTS2) D
. S J=0 F S J=$O(^TMP("LRC",$J,I,J)) Q:+J'>0 D
. . I NFLAG="ALL" S K="ALL"
. . E I $P(^TMP("LRC",$J,I,J),U,5)']"" S K="NORM"
. . E S K="ABNORM"
. . S L=$P(^TMP("LRC",$J,I,J),U,2)
. . I NFLAG="ALL"!(K=NFLAG) S ^TMP("LRC",$J,K,L,I,J)=^TMP("LRC",$J,I,J)
. . K ^TMP("LRC",$J,I,J)
Q
LINE ; Line-wrap with comma-dimited data
N X,Y,TIUX
S TIUX=$P($G(^TMP("LRC",$J,NORM,SMPL,I,J)),U,3,4)
I $S($$HASNUM^TIULS($P(TIUX,U)):0,$L($P(TIUX,U))>5:1,$L($P(TIUX,U)," ")>1:1,1:0) D
. S $P(TIUX,U)=$$MIXED^TIULS($P(TIUX,U))
S $P(TIUX,U,2)=$TR($P(TIUX,U,2)," ",""),TIUX=$TR(TIUX,U," ")
S TIUY=$$FILL^TIULS(TIUX,TIUY,79)
I TIUY=TIUX S LINE=+$G(LINE)+1
S @TARGET@(LINE,0)=TIUY
S @TARGET@(0)="^^"_LINE_"^"_LINE_"^"_DT_"^^"
I +$G(DISPLAY) W "."
Q
TIULAB ; SLC/JER - Lab objects ;7/7/95 15:22
+1 ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
MAIN(DFN,EARLY,LATE,DISPLAY,NORM,TARGET,LINE) ; Control branching
+1 NEW GMTS1,GMTS2,GMTSAGE,GMTSDOB,GMTSPNM,GMTSRB,GMTSSN,GMTSWARD,SEX
+2 NEW LRDFN,MAX,I,J,SMPL,TIUY,VADPT,VAIN
+3 KILL ^TMP("LRC",$JOB)
+4 IF $GET(NORM)']""
SET NORM="ALL"
+5 IF '$DATA(^DPT(DFN,"LR"))
DO NOLABS
GOTO LABX
+6 SET LRDFN=+^DPT(DFN,"LR")
IF '$DATA(^LR(LRDFN))
DO NOLABS
GOTO LABX
+7 SET MAX=999
SET GMTS1=9999999-LATE
SET GMTS2=9999999-EARLY
+8 IF +$GET(DISPLAY)
WRITE !,"Gathering Laboratory Data."
+9 DO ^GMTSLRCE
+10 IF '$DATA(^TMP("LRC",$JOB))
DO NOLABS
GOTO LABX
+11 DO SORT($GET(NORM))
+12 SET (TIUY,SMPL)=""
FOR
SET SMPL=$ORDER(^TMP("LRC",$JOB,NORM,SMPL))
IF SMPL=""
QUIT
Begin DoDot:1
+13 SET I=GMTS1
FOR
SET I=$ORDER(^TMP("LRC",$JOB,NORM,SMPL,I))
IF +I'>0!(I>GMTS2)
QUIT
Begin DoDot:2
+14 SET J=0
FOR
SET J=$ORDER(^TMP("LRC",$JOB,NORM,SMPL,I,J))
IF +J'>0
QUIT
DO LINE
End DoDot:2
End DoDot:1
+15 KILL ^TMP("LRC",$JOB)
LABX QUIT "~@"_$NAME(@TARGET)
NOLABS ; Handles Case Where no Labs are found to satisfy criteria
+1 SET LINE=$SELECT(+$GET(LINE):+$GET(LINE),1:1)
SET @TARGET@(LINE,0)="No data available"
+2 SET LINE=+$GET(LINE)+1
SET @TARGET@(LINE,0)=" "
+3 SET @TARGET@(0)="^^"_LINE_"^"_LINE_"^"_DT_"^^"
+4 QUIT
SORT(NFLAG) ; Sort ^TMP("LRC",$J, by reference flag
+1 NEW I,J,K,L
IF $GET(NFLAG)']""
SET NFLAG="ALL"
+2 SET I=GMTS1
FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
IF +I'>0!(I>GMTS2)
QUIT
Begin DoDot:1
+3 SET J=0
FOR
SET J=$ORDER(^TMP("LRC",$JOB,I,J))
IF +J'>0
QUIT
Begin DoDot:2
+4 IF NFLAG="ALL"
SET K="ALL"
+5 IF '$TEST
IF $PIECE(^TMP("LRC",$JOB,I,J),U,5)']""
SET K="NORM"
+6 IF '$TEST
SET K="ABNORM"
+7 SET L=$PIECE(^TMP("LRC",$JOB,I,J),U,2)
+8 IF NFLAG="ALL"!(K=NFLAG)
SET ^TMP("LRC",$JOB,K,L,I,J)=^TMP("LRC",$JOB,I,J)
+9 KILL ^TMP("LRC",$JOB,I,J)
End DoDot:2
End DoDot:1
+10 QUIT
LINE ; Line-wrap with comma-dimited data
+1 NEW X,Y,TIUX
+2 SET TIUX=$PIECE($GET(^TMP("LRC",$JOB,NORM,SMPL,I,J)),U,3,4)
+3 IF $SELECT($$HASNUM^TIULS($PIECE(TIUX,U)):0,$LENGTH($PIECE(TIUX,U))>5:1,$LENGTH($PIECE(TIUX,U)," ")>1:1,1:0)
Begin DoDot:1
+4 SET $PIECE(TIUX,U)=$$MIXED^TIULS($PIECE(TIUX,U))
End DoDot:1
+5 SET $PIECE(TIUX,U,2)=$TRANSLATE($PIECE(TIUX,U,2)," ","")
SET TIUX=$TRANSLATE(TIUX,U," ")
+6 SET TIUY=$$FILL^TIULS(TIUX,TIUY,79)
+7 IF TIUY=TIUX
SET LINE=+$GET(LINE)+1
+8 SET @TARGET@(LINE,0)=TIUY
+9 SET @TARGET@(0)="^^"_LINE_"^"_LINE_"^"_DT_"^^"
+10 IF +$GET(DISPLAY)
WRITE "."
+11 QUIT
