Routine: LRCAPDSS

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

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

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

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

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  Mar 13, 2025@21:17:13                                                                                                                                                                                                    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

LRCAPDSS.m