- LRRP6A1 ;DALISC/J0 - LAB TEST SUMMARY REPORT-BUILD ;11/27/92
- ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- EN ;
- DQ ;
- D INIT S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
- S ACCTRNS=$P(^LRO(68,LRAA,0),U,3) Q:"MDQY"'[ACCTRNS
- I ACCTRNS="D" D DAILY
- I ACCTRNS="Y" D YEARLY
- I ACCTRNS="M"!(ACCTRNS="Q") D MONTHLY
- D PRINT
- D:$D(ZTQUEUED) WRAPUP^LRRP6
- Q
- INIT ;
- S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
- K ^TMP("LR",$J)
- S LRDAT=$$Y2K^LRX(DT),(LRPAG,LREND)=0
- Q
- DAILY ;
- S LRDT=LRSDT
- F S LRDT=$O(^LRO(68,LRAA,1,LRDT)) Q:('LRDT)!(LRDT>LREDT) D
- . S LRANN=+$G(LRANF)
- . F S LRANN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN)) Q:'LRANN!(LRANN>LRANL) S LRPDT=+$P($G(^(LRANN,3)),U,3) D ACC
- Q
- YEARLY ;
- S LRDT=$E(LRSDT,1,3)_"0000"-.001,LREDT=LREDT_".99999"
- F S LRDT=$O(^LRO(68,LRAA,1,LRDT)) Q:('LRDT)!(LRDT>LREDT) D
- . S LRANN=+$G(LRANF)
- . F S LRANN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN)) Q:'LRANN!(LRANN>LRANL) D
- . . Q:'$D(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2 S LRANN0=+$P($G(^(3)),U,3)
- . . I LRANN0,LRANN0'>LREDT&(LRANN0'<LRSDT) S LRPDT=LRANN0 D ACC
- Q
- MONTHLY ;
- S LRDT=$E(LRSDT,1,5)_"00"-.001,LREDT=LREDT_".99999"
- F S LRDT=$O(^LRO(68,LRAA,1,LRDT)) Q:('LRDT)!(LRDT>LREDT) D
- . S LRANN=+$G(LRANF)
- . F S LRANN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN)) Q:'LRANN!(LRANN>LRANL) D
- . . Q:'$D(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2 S LRANN0=+$P($G(^(3)),U,3)
- . . I LRANN0,LRANN0'>LREDT&(LRANN0'<LRSDT) D ACC
- Q
- ACC ;
- S LRAN=$G(^LRO(68,LRAA,1,LRDT,1,LRANN,.2)) Q:LRAN=""
- S LRTIC=$P(LRAN," ",3)
- S LRTIC=$S($L(LRTIC)'>1:"00"_LRTIC,$L(LRTIC)'>2:"0"_LRTIC,1:LRTIC)
- S LRAN=$E(LRAN,1,$L(LRAN)-$L($P(LRAN," ",3)))_LRTIC
- S LRTST=0
- F S LRTST=$O(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST)) Q:'LRTST D
- . S LRTNAM=$E($$TST^LRCAPR2(LRTST),1,60)
- . S LRCPN=0
- . F S LRCPN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN)) Q:'LRCPN D
- . . S LRNODE=$G(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN,0)) Q:'LRNODE
- . . Q:$P(LRNODE,U,3)'=1
- . . S LRMULT=+$P(LRNODE,U,4)
- . . I $D(LRDIVSEL),'$D(LRDIVSEL(+$P(LRNODE,U,8)))#2 Q
- . . S LRCAPNAM=$E($$WKLDNAME^LRCAPU(LRCPN),1,60)
- . . Q:('$L(LRCAPNAM))!('LRCAPNUM)
- . . S LRCC(LRCAPNAM)=LRCAPNUM
- . . D BMPTOTS
- Q
- BMPTOTS ;
- S LRANX=LRAN N LRAN
- S LRAN=LRANX_"~"_LRDT
- S:'$D(^TMP("LR",$J))#2 ^($J)=0
- S ^($J)=^TMP("LR",$J)+LRMULT
- S:'$D(^TMP("LR",$J,"ACCNUM",LRAN))#2 ^(LRAN)=0
- S ^(LRAN)=^TMP("LR",$J,"ACCNUM",LRAN)+LRMULT
- ;***S:'$D(^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM))#2 ^(LRTNAM)=0
- ;***S ^(LRTNAM)=^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM)+LRMULT
- S:'$D(^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM,LRCAPNAM))#2 ^(LRCAPNAM)=0
- S ^(LRCAPNAM)=^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM,LRCAPNAM)+LRMULT
- S:'$D(^TMP("LR",$J,"WKLD",LRCAPNAM))#2 ^(LRCAPNAM)=0
- S ^(LRCAPNAM)=^TMP("LR",$J,"WKLD",LRCAPNAM)+LRMULT
- S:'$D(^TMP("LR",$J,"TST"))#2 ^("TST")=0
- S ^("TST")=^TMP("LR",$J,"TST")+LRMULT
- S:'$D(^TMP("LR",$J,"TST",LRTNAM))#2 ^(LRTNAM)=0
- S ^(LRTNAM)=^TMP("LR",$J,"TST",LRTNAM)+LRMULT
- S:'$D(^TMP("LR",$J,"TST",LRTNAM,LRCAPNAM))#2 ^(LRCAPNAM)=0
- S ^(LRCAPNAM)=^TMP("LR",$J,"TST",LRTNAM,LRCAPNAM)+LRMULT
- Q
- PRINT ;
- W:$E(IOST,1,2)="C-" @IOF
- S $P(LRDASH,"=",IOM)="",$P(LRSTAR,"*",IOM)=""
- I '$D(^TMP("LR",$J)) D NOTHING Q
- D:LRREPTYP="D" DET^LRRP6A3 Q:LREND
- D COND^LRRP6A2
- Q
- NOTHING ;
- S LRPAG=LRPAG+1
- W LRDASH
- W !,"Lab Test Summary for ",LRDATRNG
- W ?62,LRDAT,?72,"PAGE ",$J(LRPAG,3)
- W !,"Accession Area: ",LRX
- W !,LRSTAR
- W !!?18,"*** NO DATA FOR REPORT OPTIONS SELECTED ***"
- I $D(LRDIVSEL) D
- . W !!,"DIVISIONS SELECTED",!,$E(LRDASH,1,18)
- . S LRDIV=""
- . F S LRDIV=$O(LRDIVSEL(LRDIV)) Q:LRDIV="" W !,LRDIVSEL(LRDIV)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP6A1 3596 printed Jan 18, 2025@03:20:40 Page 2
- LRRP6A1 ;DALISC/J0 - LAB TEST SUMMARY REPORT-BUILD ;11/27/92
- +1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- EN ;
- DQ ;
- +1 DO INIT
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL ZTSK
- +2 SET ACCTRNS=$PIECE(^LRO(68,LRAA,0),U,3)
- if "MDQY"'[ACCTRNS
- QUIT
- +3 IF ACCTRNS="D"
- DO DAILY
- +4 IF ACCTRNS="Y"
- DO YEARLY
- +5 IF ACCTRNS="M"!(ACCTRNS="Q")
- DO MONTHLY
- +6 DO PRINT
- +7 if $DATA(ZTQUEUED)
- DO WRAPUP^LRRP6
- +8 QUIT
- INIT ;
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL ZTSK
- USE IO
- +2 KILL ^TMP("LR",$JOB)
- +3 SET LRDAT=$$Y2K^LRX(DT)
- SET (LRPAG,LREND)=0
- +4 QUIT
- DAILY ;
- +1 SET LRDT=LRSDT
- +2 FOR
- SET LRDT=$ORDER(^LRO(68,LRAA,1,LRDT))
- if ('LRDT)!(LRDT>LREDT)
- QUIT
- Begin DoDot:1
- +3 SET LRANN=+$GET(LRANF)
- +4 FOR
- SET LRANN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN))
- if 'LRANN!(LRANN>LRANL)
- QUIT
- SET LRPDT=+$PIECE($GET(^(LRANN,3)),U,3)
- DO ACC
- End DoDot:1
- +5 QUIT
- YEARLY ;
- +1 SET LRDT=$EXTRACT(LRSDT,1,3)_"0000"-.001
- SET LREDT=LREDT_".99999"
- +2 FOR
- SET LRDT=$ORDER(^LRO(68,LRAA,1,LRDT))
- if ('LRDT)!(LRDT>LREDT)
- QUIT
- Begin DoDot:1
- +3 SET LRANN=+$GET(LRANF)
- +4 FOR
- SET LRANN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN))
- if 'LRANN!(LRANN>LRANL)
- QUIT
- Begin DoDot:2
- +5 if '$DATA(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2
- QUIT
- SET LRANN0=+$PIECE($GET(^(3)),U,3)
- +6 IF LRANN0
- IF LRANN0'>LREDT&(LRANN0'<LRSDT)
- SET LRPDT=LRANN0
- DO ACC
- End DoDot:2
- End DoDot:1
- +7 QUIT
- MONTHLY ;
- +1 SET LRDT=$EXTRACT(LRSDT,1,5)_"00"-.001
- SET LREDT=LREDT_".99999"
- +2 FOR
- SET LRDT=$ORDER(^LRO(68,LRAA,1,LRDT))
- if ('LRDT)!(LRDT>LREDT)
- QUIT
- Begin DoDot:1
- +3 SET LRANN=+$GET(LRANF)
- +4 FOR
- SET LRANN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN))
- if 'LRANN!(LRANN>LRANL)
- QUIT
- Begin DoDot:2
- +5 if '$DATA(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2
- QUIT
- SET LRANN0=+$PIECE($GET(^(3)),U,3)
- +6 IF LRANN0
- IF LRANN0'>LREDT&(LRANN0'<LRSDT)
- DO ACC
- End DoDot:2
- End DoDot:1
- +7 QUIT
- ACC ;
- +1 SET LRAN=$GET(^LRO(68,LRAA,1,LRDT,1,LRANN,.2))
- if LRAN=""
- QUIT
- +2 SET LRTIC=$PIECE(LRAN," ",3)
- +3 SET LRTIC=$SELECT($LENGTH(LRTIC)'>1:"00"_LRTIC,$LENGTH(LRTIC)'>2:"0"_LRTIC,1:LRTIC)
- +4 SET LRAN=$EXTRACT(LRAN,1,$LENGTH(LRAN)-$LENGTH($PIECE(LRAN," ",3)))_LRTIC
- +5 SET LRTST=0
- +6 FOR
- SET LRTST=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST))
- if 'LRTST
- QUIT
- Begin DoDot:1
- +7 SET LRTNAM=$EXTRACT($$TST^LRCAPR2(LRTST),1,60)
- +8 SET LRCPN=0
- +9 FOR
- SET LRCPN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN))
- if 'LRCPN
- QUIT
- Begin DoDot:2
- +10 SET LRNODE=$GET(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN,0))
- if 'LRNODE
- QUIT
- +11 if $PIECE(LRNODE,U,3)'=1
- QUIT
- +12 SET LRMULT=+$PIECE(LRNODE,U,4)
- +13 IF $DATA(LRDIVSEL)
- IF '$DATA(LRDIVSEL(+$PIECE(LRNODE,U,8)))#2
- QUIT
- +14 SET LRCAPNAM=$EXTRACT($$WKLDNAME^LRCAPU(LRCPN),1,60)
- +15 if ('$LENGTH(LRCAPNAM))!('LRCAPNUM)
- QUIT
- +16 SET LRCC(LRCAPNAM)=LRCAPNUM
- +17 DO BMPTOTS
- End DoDot:2
- End DoDot:1
- +18 QUIT
- BMPTOTS ;
- +1 SET LRANX=LRAN
- NEW LRAN
- +2 SET LRAN=LRANX_"~"_LRDT
- +3 if '$DATA(^TMP("LR",$JOB))#2
- SET ^($JOB)=0
- +4 SET ^($JOB)=^TMP("LR",$JOB)+LRMULT
- +5 if '$DATA(^TMP("LR",$JOB,"ACCNUM",LRAN))#2
- SET ^(LRAN)=0
- +6 SET ^(LRAN)=^TMP("LR",$JOB,"ACCNUM",LRAN)+LRMULT
- +7 ;***S:'$D(^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM))#2 ^(LRTNAM)=0
- +8 ;***S ^(LRTNAM)=^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM)+LRMULT
- +9 if '$DATA(^TMP("LR",$JOB,"ACCNUM",LRAN,LRTNAM,LRCAPNAM))#2
- SET ^(LRCAPNAM)=0
- +10 SET ^(LRCAPNAM)=^TMP("LR",$JOB,"ACCNUM",LRAN,LRTNAM,LRCAPNAM)+LRMULT
- +11 if '$DATA(^TMP("LR",$JOB,"WKLD",LRCAPNAM))#2
- SET ^(LRCAPNAM)=0
- +12 SET ^(LRCAPNAM)=^TMP("LR",$JOB,"WKLD",LRCAPNAM)+LRMULT
- +13 if '$DATA(^TMP("LR",$JOB,"TST"))#2
- SET ^("TST")=0
- +14 SET ^("TST")=^TMP("LR",$JOB,"TST")+LRMULT
- +15 if '$DATA(^TMP("LR",$JOB,"TST",LRTNAM))#2
- SET ^(LRTNAM)=0
- +16 SET ^(LRTNAM)=^TMP("LR",$JOB,"TST",LRTNAM)+LRMULT
- +17 if '$DATA(^TMP("LR",$JOB,"TST",LRTNAM,LRCAPNAM))#2
- SET ^(LRCAPNAM)=0
- +18 SET ^(LRCAPNAM)=^TMP("LR",$JOB,"TST",LRTNAM,LRCAPNAM)+LRMULT
- +19 QUIT
- PRINT ;
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +2 SET $PIECE(LRDASH,"=",IOM)=""
- SET $PIECE(LRSTAR,"*",IOM)=""
- +3 IF '$DATA(^TMP("LR",$JOB))
- DO NOTHING
- QUIT
- +4 if LRREPTYP="D"
- DO DET^LRRP6A3
- if LREND
- QUIT
- +5 DO COND^LRRP6A2
- +6 QUIT
- NOTHING ;
- +1 SET LRPAG=LRPAG+1
- +2 WRITE LRDASH
- +3 WRITE !,"Lab Test Summary for ",LRDATRNG
- +4 WRITE ?62,LRDAT,?72,"PAGE ",$JUSTIFY(LRPAG,3)
- +5 WRITE !,"Accession Area: ",LRX
- +6 WRITE !,LRSTAR
- +7 WRITE !!?18,"*** NO DATA FOR REPORT OPTIONS SELECTED ***"
- +8 IF $DATA(LRDIVSEL)
- Begin DoDot:1
- +9 WRITE !!,"DIVISIONS SELECTED",!,$EXTRACT(LRDASH,1,18)
- +10 SET LRDIV=""
- +11 FOR
- SET LRDIV=$ORDER(LRDIVSEL(LRDIV))
- if LRDIV=""
- QUIT
- WRITE !,LRDIVSEL(LRDIV)
- End DoDot:1
- +12 QUIT