LRCAPDSS ;DALISC/FHS-LAB WORKLOAD DSS EXTRACT (LMIP) ;4/18/14 13:35
;;5.2;LAB SERVICE;**127,143,201,221,403,410,441**;Sep 27, 1994;Build 1
;ECX*3 compatible
EN ;
; Call with Start Date (LRSDT) End Date (LREDT) FileMan format
; Calling routine should have already purged ^LRO(64.03)
S:$D(ZTQUEUED) ZTREQ="@"
I $S($G(LRSDT)'?7N:1,$G(LREDT)'?7N:1,1:0) Q
N X,I
L +^LRO(64.03):10 G:'$T END
I LRSDT>LREDT S X=LRSDT,LRSDT=LREDT,LREDT=X
S LRX1=(9999999-LRSDT),LRX2=(9999999-LREDT)-1
S LREDT0=LREDT,X1=LREDT,X2="+35" D C^%DTC S LREDT=X
S LRSDT0=LRSDT,LRSDT=LRSDT-".9999"
;Q
S LRDPROV=$P($G(^LAB(69.9,1,12)),U) G END:'LRDPROV S $P(^("NITE"),U,6)=""
S:'$D(^LRO(64.03,0))#2 ^LRO(64.03,0)="WKLD LOG FILE^64.03^"
S LRNOW=$$NOW^XLFDT
S LRDSS0=^LRO(64.03,0),LRSNODE=$S($P(LRDSS0,U,3):$P(LRDSS0,U,3),1:1) F LRSNODE=LRSNODE:1 Q:'$D(^LRO(64.03,LRSNODE,0))
S ^LRO(64.03,LRSNODE,0)=LRSNODE,^(1,0)="^64.317DA^1^1",^(1,0)=LRNOW_U_LRSDT0_U_LREDT0_U_U_$G(DUZ)
S ^LRO(64.03,"B",LRNOW,LRSNODE,1)=""
INST S LRSDTX=LRSDT,LRIN=0 F S LRIN=$O(^LRO(64.1,LRIN)) Q:LRIN<1 D
. S LRSDT=LRSDTX-.0001 F S LRSDT=$O(^LRO(64.1,LRIN,1,LRSDT)) Q:LRSDT<1!(LRSDT>LREDT) D
. . S LRCC=0 F S LRCC=$O(^LRO(64.1,LRIN,1,LRSDT,1,LRCC)) Q:LRCC<1 S LRCCX=$G(^LAM(LRCC,0)) D
. . . Q:$P($G(LRCCX),U,2)'?5N1"."4N.5N Q:$S($P(LRCCX,U,5):0,$P(LRCCX,U,16):0,+$P(LRCCX,".",2)=9999:0,$E($P(LRCCX,".",2))=8:0,1:1)
. . . S LRTM=0 F S LRTM=$O(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,1,LRTM)) Q:LRTM'>0 I $D(^(LRTM,0)) D SET
S $P(^LRO(64.03,LRSNODE,1,1,0),U,4)=$$NOW^XLFDT
END ;
L -^LRO(64.03) Q:$G(LRDBUG)
K DFN,LRAA,LRACCDT,LRACCN,LRCC,LRCCX,LRDSS,LRDSS0,LREDT,LRIDT,LRIN
K LRLOC,LRLOCN,LRLOCTY,LRODT,LRPROV,LRSDT,LRSDTX,LRSNODE,LRSPEC,LRSTR,LRTEST
K LRTIM,LRTM,LRTS,LRURG,LRX,LRN0,LRNX,X,LRMULT,LREDT0,LRSDT0,LRNOW,LRX1
K LRX2,X1,X2,LRPFILE,LR64PTR,LRBILL,LRDSSFK,LRTNM,LRDTNM,LRDPROV,LROCTY
Q
SET ;
N LRPATH ;441 Patch
S LRSTR=$G(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,1,LRTM,0))
S LR64PTR=+$G(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,0)),LRBILL="",LRDSSFK=""
I LR64PTR>0,$D(^LAM(LR64PTR,0)) S LRBILL=$P(^(0),U,5),LRDSSFK=$P(^(0),U,16)
S LRPFILE=$P($P(LRSTR,U,10),";",2) Q:$S(LRPFILE="LRT(67,":0,LRPFILE="DPT(":0,LRPFILE="LRT(67.1,":0,1:1)
S LRIDT=$P(LRSTR,U,22)
I '$G(LRDBUG),$S(LRIDT>LRX1:1,LRIDT<LRX2:1,1:0) Q
S X=LRSTR,LRTEST=$P(X,U,2),LRMULT=$S($P(X,U,3):$P(X,U,3),1:1),LRAA=$P(X,U,7)
S LRTNM="",LRDTNM="" I $D(^LAB(60,LRTEST,0)) D
. S LRTNM=$TR($$GET1^DIQ(60,LRTEST,400),"!~","##"),LRDTNM=$P(^LAB(60,LRTEST,0),U,5)
S LRACCN=$P(X,U,9),DFN=$P(X,U,10),LRACCDT=$P(X,U,11),LRODT=$P(X,U,12)
S LRSPEC=$P(X,U,14),LRLOCN=$P(X,U,15)
S LRTS=$P(X,U,17)
S LRLOCTY=$P(X,U,19),LRURG=$P(X,U,23)
S LRTIM=9999999-LRIDT D
. I $P($G(^LRO(68,LRAA,0)),U,21) S (LRLOC,LROCTY)="" Q
. S LRLOC=$P(X,U,21) S:LRLOC LRLOC=LRLOC_";SC("
S LRPROV=$P(X,U,16)
I 'LRLOC,LRPFILE="LRT(67,",$P(LRPROV,":",2) S LRLOC=$P(LRPROV,":",2)_";DIC(4,"
S:'LRPROV LRPROV=LRDPROV
S LRPATH=$$PATH ;441 patch Gets pathologist associated with test
S LRX=LRPROV_U_DFN_U_LRSDT_U_LRIN_U_LRLOCTY_U_LRAA_U_LRTEST_U_LRURG
S LRX=LRX_U_LRTS_U_LRCC_U_LRIDT_U_LRTIM_U_LRODT_U_LRLOC_U_LRACCN_U_LRSPEC
I LRMULT>0 F I=1:1:LRMULT D NEXT
Q
NEXT S LRN0=^LRO(64.03,0),LRNX=$S($P(LRN0,U,3):$P(LRN0,U,3),1:1) F LRNX=LRNX:1 Q:'$D(^LRO(64.03,LRNX,0))
S $P(LRN0,U,3)=LRNX,$P(LRN0,U,4)=$P(LRN0,U,4)+1,^LRO(64.03,0)=LRN0
S ^LRO(64.03,LRNX,0)=LRNX_U_LRX
S ^LRO(64.03,LRNX,2)=LRBILL_"^"_LRDSSFK_"^"_LRTNM_"^"_LRDTNM_"^"_LRPATH ;441 patch Add pathologist
Q
LOOP S LRDPROV=$P(^LAB(69.9,1,12),U),LRDBUG=1
S LRTM=0 F S LRTM=$O(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,1,LRTM)) Q:LRTM<1 D SET
K LRDBUG
Q
;
PATH() ;441 Patch added function to return pathologist
N LRSUB,PATH,LRDFN
S PATH=""
S LRSUB=$$GET1^DIQ(68,LRAA,.02,"I") I LRSUB="" Q PATH
S LRDFN=$S(LRPFILE="DPT(":$G(^DPT(+DFN,"LR")),LRPFILE="LRT(67,":$G(^LRT(67,+DFN,"LR")),LRPFILE="LRT(67.1,":$G(^LRT(67.1,+DFN,"LR")),1:"") I LRDFN="" Q PATH
I LRSUB="AU" S PATH=$P($G(^LR(LRDFN,"AU")),U,10) Q PATH ;Autopsy pathologist
I LRSUB="CY"!(LRSUB="EM")!(LRSUB="SP") S PATH=$P($G(^LR(LRDFN,LRSUB,LRIDT,0)),U,2) ;For CY, SP and EM pathologist
Q PATH
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPDSS 4177 printed Sep 23, 2025@19:48:32 Page 2
LRCAPDSS ;DALISC/FHS-LAB WORKLOAD DSS EXTRACT (LMIP) ;4/18/14 13:35
+1 ;;5.2;LAB SERVICE;**127,143,201,221,403,410,441**;Sep 27, 1994;Build 1
+2 ;ECX*3 compatible
EN ;
+1 ; Call with Start Date (LRSDT) End Date (LREDT) FileMan format
+2 ; Calling routine should have already purged ^LRO(64.03)
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF $SELECT($GET(LRSDT)'?7N:1,$GET(LREDT)'?7N:1,1:0)
QUIT
+5 NEW X,I
+6 LOCK +^LRO(64.03):10
if '$TEST
GOTO END
+7 IF LRSDT>LREDT
SET X=LRSDT
SET LRSDT=LREDT
SET LREDT=X
+8 SET LRX1=(9999999-LRSDT)
SET LRX2=(9999999-LREDT)-1
+9 SET LREDT0=LREDT
SET X1=LREDT
SET X2="+35"
DO C^%DTC
SET LREDT=X
+10 SET LRSDT0=LRSDT
SET LRSDT=LRSDT-".9999"
+11 ;Q
+12 SET LRDPROV=$PIECE($GET(^LAB(69.9,1,12)),U)
if 'LRDPROV
GOTO END
SET $PIECE(^("NITE"),U,6)=""
+13 if '$DATA(^LRO(64.03,0))#2
SET ^LRO(64.03,0)="WKLD LOG FILE^64.03^"
+14 SET LRNOW=$$NOW^XLFDT
+15 SET LRDSS0=^LRO(64.03,0)
SET LRSNODE=$SELECT($PIECE(LRDSS0,U,3):$PIECE(LRDSS0,U,3),1:1)
FOR LRSNODE=LRSNODE:1
if '$DATA(^LRO(64.03,LRSNODE,0))
QUIT
+16 SET ^LRO(64.03,LRSNODE,0)=LRSNODE
SET ^(1,0)="^64.317DA^1^1"
SET ^(1,0)=LRNOW_U_LRSDT0_U_LREDT0_U_U_$GET(DUZ)
+17 SET ^LRO(64.03,"B",LRNOW,LRSNODE,1)=""
INST SET LRSDTX=LRSDT
SET LRIN=0
FOR
SET LRIN=$ORDER(^LRO(64.1,LRIN))
if LRIN<1
QUIT
Begin DoDot:1
+1 SET LRSDT=LRSDTX-.0001
FOR
SET LRSDT=$ORDER(^LRO(64.1,LRIN,1,LRSDT))
if LRSDT<1!(LRSDT>LREDT)
QUIT
Begin DoDot:2
+2 SET LRCC=0
FOR
SET LRCC=$ORDER(^LRO(64.1,LRIN,1,LRSDT,1,LRCC))
if LRCC<1
QUIT
SET LRCCX=$GET(^LAM(LRCC,0))
Begin DoDot:3
+3 if $PIECE($GET(LRCCX),U,2)'?5N1"."4N.5N
QUIT
if $SELECT($PIECE(LRCCX,U,5)
QUIT
+4 SET LRTM=0
FOR
SET LRTM=$ORDER(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,1,LRTM))
if LRTM'>0
QUIT
IF $DATA(^(LRTM,0))
DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+5 SET $PIECE(^LRO(64.03,LRSNODE,1,1,0),U,4)=$$NOW^XLFDT
END ;
+1 LOCK -^LRO(64.03)
if $GET(LRDBUG)
QUIT
+2 KILL DFN,LRAA,LRACCDT,LRACCN,LRCC,LRCCX,LRDSS,LRDSS0,LREDT,LRIDT,LRIN
+3 KILL LRLOC,LRLOCN,LRLOCTY,LRODT,LRPROV,LRSDT,LRSDTX,LRSNODE,LRSPEC,LRSTR,LRTEST
+4 KILL LRTIM,LRTM,LRTS,LRURG,LRX,LRN0,LRNX,X,LRMULT,LREDT0,LRSDT0,LRNOW,LRX1
+5 KILL LRX2,X1,X2,LRPFILE,LR64PTR,LRBILL,LRDSSFK,LRTNM,LRDTNM,LRDPROV,LROCTY
+6 QUIT
SET ;
+1 ;441 Patch
NEW LRPATH
+2 SET LRSTR=$GET(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,1,LRTM,0))
+3 SET LR64PTR=+$GET(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,0))
SET LRBILL=""
SET LRDSSFK=""
+4 IF LR64PTR>0
IF $DATA(^LAM(LR64PTR,0))
SET LRBILL=$PIECE(^(0),U,5)
SET LRDSSFK=$PIECE(^(0),U,16)
+5 SET LRPFILE=$PIECE($PIECE(LRSTR,U,10),";",2)
if $SELECT(LRPFILE="LRT(67,"
QUIT
+6 SET LRIDT=$PIECE(LRSTR,U,22)
+7 IF '$GET(LRDBUG)
IF $SELECT(LRIDT>LRX1:1,LRIDT<LRX2:1,1:0)
QUIT
+8 SET X=LRSTR
SET LRTEST=$PIECE(X,U,2)
SET LRMULT=$SELECT($PIECE(X,U,3):$PIECE(X,U,3),1:1)
SET LRAA=$PIECE(X,U,7)
+9 SET LRTNM=""
SET LRDTNM=""
IF $DATA(^LAB(60,LRTEST,0))
Begin DoDot:1
+10 SET LRTNM=$TRANSLATE($$GET1^DIQ(60,LRTEST,400),"!~","##")
SET LRDTNM=$PIECE(^LAB(60,LRTEST,0),U,5)
End DoDot:1
+11 SET LRACCN=$PIECE(X,U,9)
SET DFN=$PIECE(X,U,10)
SET LRACCDT=$PIECE(X,U,11)
SET LRODT=$PIECE(X,U,12)
+12 SET LRSPEC=$PIECE(X,U,14)
SET LRLOCN=$PIECE(X,U,15)
+13 SET LRTS=$PIECE(X,U,17)
+14 SET LRLOCTY=$PIECE(X,U,19)
SET LRURG=$PIECE(X,U,23)
+15 SET LRTIM=9999999-LRIDT
Begin DoDot:1
+16 IF $PIECE($GET(^LRO(68,LRAA,0)),U,21)
SET (LRLOC,LROCTY)=""
QUIT
+17 SET LRLOC=$PIECE(X,U,21)
if LRLOC
SET LRLOC=LRLOC_";SC("
End DoDot:1
+18 SET LRPROV=$PIECE(X,U,16)
+19 IF 'LRLOC
IF LRPFILE="LRT(67,"
IF $PIECE(LRPROV,":",2)
SET LRLOC=$PIECE(LRPROV,":",2)_";DIC(4,"
+20 if 'LRPROV
SET LRPROV=LRDPROV
+21 ;441 patch Gets pathologist associated with test
SET LRPATH=$$PATH
+22 SET LRX=LRPROV_U_DFN_U_LRSDT_U_LRIN_U_LRLOCTY_U_LRAA_U_LRTEST_U_LRURG
+23 SET LRX=LRX_U_LRTS_U_LRCC_U_LRIDT_U_LRTIM_U_LRODT_U_LRLOC_U_LRACCN_U_LRSPEC
+24 IF LRMULT>0
FOR I=1:1:LRMULT
DO NEXT
+25 QUIT
NEXT SET LRN0=^LRO(64.03,0)
SET LRNX=$SELECT($PIECE(LRN0,U,3):$PIECE(LRN0,U,3),1:1)
FOR LRNX=LRNX:1
if '$DATA(^LRO(64.03,LRNX,0))
QUIT
+1 SET $PIECE(LRN0,U,3)=LRNX
SET $PIECE(LRN0,U,4)=$PIECE(LRN0,U,4)+1
SET ^LRO(64.03,0)=LRN0
+2 SET ^LRO(64.03,LRNX,0)=LRNX_U_LRX
+3 ;441 patch Add pathologist
SET ^LRO(64.03,LRNX,2)=LRBILL_"^"_LRDSSFK_"^"_LRTNM_"^"_LRDTNM_"^"_LRPATH
+4 QUIT
LOOP SET LRDPROV=$PIECE(^LAB(69.9,1,12),U)
SET LRDBUG=1
+1 SET LRTM=0
FOR
SET LRTM=$ORDER(^LRO(64.1,LRIN,1,LRSDT,1,LRCC,1,LRTM))
if LRTM<1
QUIT
DO SET
+2 KILL LRDBUG
+3 QUIT
+4 ;
PATH() ;441 Patch added function to return pathologist
+1 NEW LRSUB,PATH,LRDFN
+2 SET PATH=""
+3 SET LRSUB=$$GET1^DIQ(68,LRAA,.02,"I")
IF LRSUB=""
QUIT PATH
+4 SET LRDFN=$SELECT(LRPFILE="DPT(":$GET(^DPT(+DFN,"LR")),LRPFILE="LRT(67,":$GET(^LRT(67,+DFN,"LR")),LRPFILE="LRT(67.1,":$GET(^LRT(67.1,+DFN,"LR")),1:"")
IF LRDFN=""
QUIT PATH
+5 ;Autopsy pathologist
IF LRSUB="AU"
SET PATH=$PIECE($GET(^LR(LRDFN,"AU")),U,10)
QUIT PATH
+6 ;For CY, SP and EM pathologist
IF LRSUB="CY"!(LRSUB="EM")!(LRSUB="SP")
SET PATH=$PIECE($GET(^LR(LRDFN,LRSUB,LRIDT,0)),U,2)
+7 QUIT PATH
