- 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
- Q
- 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
- Q
- 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