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 Nov 22, 2024@17:31:15 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
