Routine: LRTT5P1

LRTT5P1 ;DALOI/FHS - LAB URGENCY TURNAROUND TIMES PROCESSOR ;02/28/12  19:45

 ;;5.2;LAB SERVICE;**153,221,263,274,358,350**;Sep 27, 1994;Build 230

ONE ; from LRTT5

 ; return for reg & irreg: # tests, total time, bad turnaround time

 ; input:

 ; ^TMP("LRTT5",$J,"TESTS",tests)=test names

 ; LRPQ("URGENCY",urgencies)=urgency names

 ; LRSDT, LREDT, LRPDET

 ; output:

 ; ^TMP("LR",$J,"REG")=#tests^total time

 ; ^TMP("LR",$J,"REG",TAT,#)=acc^test^in^out

 ; ^TMP("LR",$J,"REGT",test)=#tests^total time

 ; ^TMP("LR",$J,"IRREG")=#tests^total time

 ; ^TMP("LR",$J,"IRREG",TAT,#)=acc^test^in^out

 ; ^TMP("LR",$J,"IRREGT",test)=#tests^total time

 ; ^TMP("LR",$J,"BAD",TAT,#)=acc^test^in^out

START ; go thru tests

 S LRSDT=$P(LRSDT,"."),LREDT=$P(LREDT,".")

 I LRSDT>LREDT S X=LRSDT,LRSDT=LREDT,LREDT=X

 S LRPSDT=LRSDT,LRPEDT=LREDT

 S LRTEST=0 F  S LRTEST=$O(^TMP("LRTT5",$J,"TESTS",LRTEST)) Q:LRTEST<1  D

 .; get acc areas for tests

 . S LRPN=0 F  S LRPN=$O(^LAB(60,LRTEST,8,LRPN)) Q:LRPN<1  I $D(^(LRPN,0)) S LRAA=+$P(^(0),U,2) I $D(^LRO(68,LRAA,0)) S LRAA(LRAA)=""

 ; go thru valid accession areas, get accession type - daily, yearly, etc

 S (LRPN,LRAA)=0 F  S LRAA=$O(LRAA(LRAA)) Q:LRAA<1  I $D(^LRO(68,LRAA,0)) S LRAAT=$P(^(0),U,3) D

 . ; go thru accession dates, start using appropriate acc type

 . S LRSDT=LRPSDT,LREDT=$P(LRPEDT,".")_".24"

 . S LRAD=$S(LRAAT="D":LRSDT,LRAAT="M":LRSDT\100*100,1:LRSDT\10000*10000)-.000001

 . F  S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>(LREDT))  D

 . . ; go thru accession #s

 . . S LRAN=0 F  S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:LRAN<1  S LRDPF=$P($G(^(LRAN,0)),U,2) D

 . . . Q:$S('LRDPF:1,LRDPF=2:0,LRDPF=67:0,1:1)

 . . . ; check lab arrival time, must be >= begin time and <= end time

 . . . Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3))  S LRPLRRX1=$P(^(3),U,3) Q:LRPLRRX1<LRSDT  Q:LRPLRRX1>(LREDT)

 . . . I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,.4)),$O(LRLLOC(0)),'$D(LRLLOC(+$G(^(.4)))) Q

 . . . ; go thru tests on accession, if valid urgency get date reported

 . . . S LRTEST=0 F  S LRTEST=$O(^TMP("LRTT5",$J,"TESTS",LRTEST)) Q:LRTEST<1  I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),$D(LRPQ("URGENCY",+$P(^(0),U,2))) S LRPLRRX2=+$P(^(0),U,5) D

 . . . . Q:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,4)  ;Must be verified and have suffix code.

 . . . . ; increment sequence number

 . . . . S LRPN=LRPN+1

 . . . . ; no report date, set to zero TAT save as bad and quit

 . . . . I 'LRPLRRX2 S LRPLRRX2=LRPLRRX1 D SAVE("BAD") Q

 . . . . ; if negative times save as bad and quit

 . . . . I LRPLRRX1>LRPLRRX2 D SAVE("BAD") Q

 . . . . ; if time is not regular (7am-5pm) then save as irregular and quit

 . . . . S LRPRX1T="."_$P(LRPLRRX1,".",2) I LRPRX1T<.07!(LRPRX1T>.17) D SAVE("IRREG") Q

 . . . . ; if Sunday or Saturday save as irregular and quit

 . . . . S (LRPRX1D,X)=LRPLRRX1\1 D H^%DTC I %Y=0!(%Y=6) D SAVE("IRREG") Q

 . . . . ; if holiday save as irregular and quit

 . . . . I $D(^HOLIDAY("B",LRPRX1D)) D SAVE("IRREG") Q

 . . . . ; otherwise save as regular and quit

 . . . . D SAVE("REG")

 ; go thru reg & irreg

 F LRPTYPE="REG","IRREG" D

 . ; go thru TATs

 . S (LRPNN,LRPNT)=0,LRPDIFF="" F  S LRPDIFF=$O(^TMP("LR",$J,LRPTYPE,LRPDIFF)) Q:LRPDIFF=""  D

 . . ; go thru each reg & irreg TAT, count # and total

 . . S LRPN="" F  S LRPN=$O(^TMP("LR",$J,LRPTYPE,LRPDIFF,LRPN)) Q:LRPN=""  S LRPNN=LRPNN+1,LRPNT=LRPNT+LRPDIFF

 . ; store reg data

 . S ^TMP("LR",$J,LRPTYPE)=LRPNN_U_LRPNT

CLEAN K %Y,LRAA,LRAAT,LRAN,LRPDIFF,LRAD,LRPLRRX1,LRPLRRX2,LRPN,LRPNN,LRPNT,LRPRX1D,LRPRX1T,LRTEST,LRTESTN,LRPTYPE,X

SAVE(LRPUTYPE) ; collect reg, irreg, and bad

 N LRUID

 S LRUID=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))

 S LRPDIFF=$$DIFF(LRPLRRX2,LRPLRRX1),LRTESTN=$P(^LAB(60,LRTEST,0),U)

 I LRPUTYPE="BAD"!('$L(LRUID)) S ^TMP("LR",$J,"BAD",-LRPDIFF,LRPN)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))_U_LRTESTN_U_LRPLRRX1_U_$S(LRPLRRX2=LRPLRRX1:"",1:LRPLRRX2) Q

 Q:$D(^TMP("LR",$J,LRPUTYPE,+LRPDIFF,LRTESTN_LRUID))#2

 S ^TMP("LR",$J,LRPUTYPE,+LRPDIFF,LRTESTN_LRUID)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))_U_LRTESTN_U_LRPLRRX1_U_LRPLRRX2

 S $P(^(LRTESTN),U)=$P($G(^TMP("LR",$J,LRPUTYPE_"T",LRTESTN)),U)+1,$P(^(LRTESTN),U,2)=$P($G(^(LRTESTN)),U,2)+LRPDIFF

DIFF(LRPUT1,LRPUT2) ; $$(time1,time2) -> difference in min

 N LRPUDIFF,X1,X2,LRPUX1M,LRPUX2M,LRPUX1H,LRPUX2H,LRPUX1TH,LRPUX2TH,LRPUX1TM,LRPUX2TM,LRPUXMI

 S X1=$P(LRPUT1,"."),X2=$P(LRPUT2,"."),LRPUX1TH=$E(LRPUT1,9),LRPUX2TH=$E(LRPUT2,9),LRPUX1H=$E(LRPUT1,10),LRPUX2H=$E(LRPUT2,10),LRPUX1TM=$E(LRPUT1,11),LRPUX2TM=$E(LRPUT2,11),LRPUX1M=$E(LRPUT1,12),LRPUX2M=$E(LRPUT2,12)

 D ^%DTC S LRPUXMI=X*1440+(LRPUX1M+(LRPUX1TM*10)+(LRPUX1TH*600)+(LRPUX1H*60))-(LRPUX2M+(LRPUX2TM*10)+(LRPUX2TH*600)+(LRPUX2H*60)),LRPUDIFF=LRPUXMI S:LRPUXMI<0 LRPUDIFF=-LRPUXMI

 Q LRPUDIFF

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTT5P1   4794     printed  Feb 18, 2025@23:47:03                                                                                                                                                                                                     Page 2

LRTT5P1   ;DALOI/FHS - LAB URGENCY TURNAROUND TIMES PROCESSOR ;02/28/12  19:45

 +1       ;;5.2;LAB SERVICE;**153,221,263,274,358,350**;Sep 27, 1994;Build 230

 +2       ;

ONE       ; from LRTT5

 +1       ; return for reg & irreg: # tests, total time, bad turnaround time

 +2       ; input:

 +3       ; ^TMP("LRTT5",$J,"TESTS",tests)=test names

 +4       ; LRPQ("URGENCY",urgencies)=urgency names

 +5       ; LRSDT, LREDT, LRPDET

 +6       ; output:

 +7       ; ^TMP("LR",$J,"REG")=#tests^total time

 +8       ; ^TMP("LR",$J,"REG",TAT,#)=acc^test^in^out

 +9       ; ^TMP("LR",$J,"REGT",test)=#tests^total time

 +10      ; ^TMP("LR",$J,"IRREG")=#tests^total time

 +11      ; ^TMP("LR",$J,"IRREG",TAT,#)=acc^test^in^out

 +12      ; ^TMP("LR",$J,"IRREGT",test)=#tests^total time

 +13      ; ^TMP("LR",$J,"BAD",TAT,#)=acc^test^in^out

 +14      ;

START     ; go thru tests

 +1        SET LRSDT=$PIECE(LRSDT,".")

           SET LREDT=$PIECE(LREDT,".")

 +2        IF LRSDT>LREDT

               SET X=LRSDT

               SET LRSDT=LREDT

               SET LREDT=X

 +3        SET LRPSDT=LRSDT

           SET LRPEDT=LREDT

 +4        SET LRTEST=0

FOR

               SET LRTEST=$ORDER(^TMP("LRTT5",$JOB,"TESTS",LRTEST))

               if LRTEST<1

                   QUIT

               Begin DoDot:1

 +5       ; get acc areas for tests

 +6                SET LRPN=0

FOR

                       SET LRPN=$ORDER(^LAB(60,LRTEST,8,LRPN))

                       if LRPN<1

                           QUIT

                       IF $DATA(^(LRPN,0))

                           SET LRAA=+$PIECE(^(0),U,2)

                           IF $DATA(^LRO(68,LRAA,0))

                               SET LRAA(LRAA)=""

               End DoDot:1

 +7       ; go thru valid accession areas, get accession type - daily, yearly, etc

 +8        SET (LRPN,LRAA)=0

FOR

               SET LRAA=$ORDER(LRAA(LRAA))

               if LRAA<1

                   QUIT

               IF $DATA(^LRO(68,LRAA,0))

                   SET LRAAT=$PIECE(^(0),U,3)

                   Begin DoDot:1

 +9       ; go thru accession dates, start using appropriate acc type

 +10                   SET LRSDT=LRPSDT

                       SET LREDT=$PIECE(LRPEDT,".")_".24"

 +11                   SET LRAD=$SELECT(LRAAT="D":LRSDT,LRAAT="M":LRSDT\100*100,1:LRSDT\10000*10000)-.000001

 +12                   FOR

                           SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))

                           if LRAD<1!(LRAD>(LREDT))

                               QUIT

                           Begin DoDot:2

 +13      ; go thru accession #s

 +14                           SET LRAN=0

FOR

                                   SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))

                                   if LRAN<1

                                       QUIT

                                   SET LRDPF=$PIECE($GET(^(LRAN,0)),U,2)

                                   Begin DoDot:3

 +15                                   if $SELECT('LRDPF

                                           QUIT

 +16      ; check lab arrival time, must be >= begin time and <= end time

 +17                                   if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))

                                           QUIT

                                       SET LRPLRRX1=$PIECE(^(3),U,3)

                                       if LRPLRRX1<LRSDT

                                           QUIT

                                       if LRPLRRX1>(LREDT)

                                           QUIT

 +18                                   IF $GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.4))

                                           IF $ORDER(LRLLOC(0))

                                               IF '$DATA(LRLLOC(+$GET(^(.4))))

                                                   QUIT

 +19      ; go thru tests on accession, if valid urgency get date reported

 +20                                   SET LRTEST=0

FOR

                                           SET LRTEST=$ORDER(^TMP("LRTT5",$JOB,"TESTS",LRTEST))

                                           if LRTEST<1

                                               QUIT

                                           IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0))

                                               IF $DATA(LRPQ("URGENCY",+$PIECE(^(0),U,2)))

                                                   SET LRPLRRX2=+$PIECE(^(0),U,5)

                                                   Begin DoDot:4

 +21      ;Must be verified and have suffix code.

                                                       if '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,4)

                                                           QUIT

 +22      ; increment sequence number

 +23                                                   SET LRPN=LRPN+1

 +24      ; no report date, set to zero TAT save as bad and quit

 +25                                                   IF 'LRPLRRX2

                                                           SET LRPLRRX2=LRPLRRX1

                                                           DO SAVE("BAD")

                                                           QUIT

 +26      ; if negative times save as bad and quit

 +27                                                   IF LRPLRRX1>LRPLRRX2

                                                           DO SAVE("BAD")

                                                           QUIT

 +28      ; if time is not regular (7am-5pm) then save as irregular and quit

 +29                                                   SET LRPRX1T="."_$PIECE(LRPLRRX1,".",2)

                                                       IF LRPRX1T<.07!(LRPRX1T>.17)

                                                           DO SAVE("IRREG")

                                                           QUIT

 +30      ; if Sunday or Saturday save as irregular and quit

 +31                                                   SET (LRPRX1D,X)=LRPLRRX1\1

                                                       DO H^%DTC

                                                       IF %Y=0!(%Y=6)

                                                           DO SAVE("IRREG")

                                                           QUIT

 +32      ; if holiday save as irregular and quit

 +33                                                   IF $DATA(^HOLIDAY("B",LRPRX1D))

                                                           DO SAVE("IRREG")

                                                           QUIT

 +34      ; otherwise save as regular and quit

 +35                                                   DO SAVE("REG")

                                                   End DoDot:4

                                   End DoDot:3

                           End DoDot:2

                   End DoDot:1

 +36      ; go thru reg & irreg

 +37       FOR LRPTYPE="REG","IRREG"

               Begin DoDot:1

 +38      ; go thru TATs

 +39               SET (LRPNN,LRPNT)=0

                   SET LRPDIFF=""

FOR

                       SET LRPDIFF=$ORDER(^TMP("LR",$JOB,LRPTYPE,LRPDIFF))

                       if LRPDIFF=""

                           QUIT

                       Begin DoDot:2

 +40      ; go thru each reg & irreg TAT, count # and total

 +41                       SET LRPN=""

FOR

                               SET LRPN=$ORDER(^TMP("LR",$JOB,LRPTYPE,LRPDIFF,LRPN))

                               if LRPN=""

                                   QUIT

                               SET LRPNN=LRPNN+1

                               SET LRPNT=LRPNT+LRPDIFF

                       End DoDot:2

 +42      ; store reg data

 +43               SET ^TMP("LR",$JOB,LRPTYPE)=LRPNN_U_LRPNT

               End DoDot:1

CLEAN      KILL %Y,LRAA,LRAAT,LRAN,LRPDIFF,LRAD,LRPLRRX1,LRPLRRX2,LRPN,LRPNN,LRPNT,LRPRX1D,LRPRX1T,LRTEST,LRTESTN,LRPTYPE,X

 +1        QUIT

SAVE(LRPUTYPE) ; collect reg, irreg, and bad

 +1        NEW LRUID

 +2        SET LRUID=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))

 +3        SET LRPDIFF=$$DIFF(LRPLRRX2,LRPLRRX1)

           SET LRTESTN=$PIECE(^LAB(60,LRTEST,0),U)

 +4        IF LRPUTYPE="BAD"!('$LENGTH(LRUID))

               SET ^TMP("LR",$JOB,"BAD",-LRPDIFF,LRPN)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))_U_LRTESTN_U_LRPLRRX1_U_$SELECT(LRPLRRX2=LRPLRRX1:"",1:LRPLRRX2)

               QUIT

 +5        if $DATA(^TMP("LR",$JOB,LRPUTYPE,+LRPDIFF,LRTESTN_LRUID))#2

               QUIT

 +6        SET ^TMP("LR",$JOB,LRPUTYPE,+LRPDIFF,LRTESTN_LRUID)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))_U_LRTESTN_U_LRPLRRX1_U_LRPLRRX2

 +7        SET $PIECE(^(LRTESTN),U)=$PIECE($GET(^TMP("LR",$JOB,LRPUTYPE_"T",LRTESTN)),U)+1

           SET $PIECE(^(LRTESTN),U,2)=$PIECE($GET(^(LRTESTN)),U,2)+LRPDIFF

 +8        QUIT

DIFF(LRPUT1,LRPUT2) ; $$(time1,time2) -> difference in min

 +1        NEW LRPUDIFF,X1,X2,LRPUX1M,LRPUX2M,LRPUX1H,LRPUX2H,LRPUX1TH,LRPUX2TH,LRPUX1TM,LRPUX2TM,LRPUXMI

 +2        SET X1=$PIECE(LRPUT1,".")

           SET X2=$PIECE(LRPUT2,".")

           SET LRPUX1TH=$EXTRACT(LRPUT1,9)

           SET LRPUX2TH=$EXTRACT(LRPUT2,9)

           SET LRPUX1H=$EXTRACT(LRPUT1,10)

           SET LRPUX2H=$EXTRACT(LRPUT2,10)

           SET LRPUX1TM=$EXTRACT(LRPUT1,11)

           SET LRPUX2TM=$EXTRACT(LRPUT2,11)

           SET LRPUX1M=$EXTRACT(LRPUT1,12)

           SET LRPUX2M=$EXTRACT(LRPUT2,12)

 +3        DO ^%DTC

           SET LRPUXMI=X*1440+(LRPUX1M+(LRPUX1TM*10)+(LRPUX1TH*600)+(LRPUX1H*60))-(LRPUX2M+(LRPUX2TM*10)+(LRPUX2TH*600)+(LRPUX2H*60))

           SET LRPUDIFF=LRPUXMI

           if LRPUXMI<0

               SET LRPUDIFF=-LRPUXMI

 +4        QUIT LRPUDIFF

LRTT5P1.m