- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULAB 2004 printed Jan 18, 2025@03:43:12 Page 2
- 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