Routine: LRXREF

LRXREF ;SLC/RWA/DALOI/FHS - BUILD CROSS-REFERENCES FOR RE-INDEX ; 17-Oct-2014 09:22 ; MKK

 ;;5.2;LAB SERVICE;**70,153,263,1018,1034**;NOV 1, 1997;Build 88

AVS1 ;Rebuild "AVS" cross-reference in file 68 for Re-index utility

 I $D(DIU(0)),'$L($P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)) S ^LRO(68,"AVS",DA(2),DA(1),DA)=$P(^LRO(68,DA(2),1,DA(1),1,DA,0),U)_"^"_$P(^(3),U,5)

AVS2 I $D(DIU(0)),$L($P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)) K ^LRO(68,"AVS",DA(2),DA(1),DA)

AVS3 I '$D(DIU(0)),$L($P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)) K ^LRO(68,"AVS",DA(2),DA(1),DA)

AVS4 I '$D(DIU(0)),'$L($P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)) S ^LRO(68,"AVS",DA(2),DA(1),DA)=$P(^LRO(68,DA(2),1,DA(1),1,DA,0),U)_"^"_$P(^(3),U,5)

AC1 ;Build "AC" cross-reference when comment is deleted from a verified

 ;test in File 63. Audit trail only.

 I '$D(DIU(0)),$D(DUZ),$P(^LR(DA(2),"CH",DA(1),0),U,3) S ^LR(DA(2),"CH",DA(1),1,"AC",DUZ,$H)=$P(^LR(DA(2),"CH",DA(1),0),U,3,4)_"^"_X

 ;Build and Kill "AN"" cross-reference in File 69, when results available

AN1 S ^LRO(69,"AN",$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,15),$P(^(0),U),9999999-$P(^LRO(69,DA(1),1,DA,1),U))=""

AN2 K ^LRO(69,"AN",$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,15),$P(^(0),U),9999999-$P(^LRO(69,DA(1),1,DA,1),U))

 ; Build and Kill "AR" cross-reference in File 69, when results available

AR1 S LRDT=$E(X,1,7),LRLLOC=$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,15)

 S LRDFN=$P(^(0),U),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) S LRGN=^DIC(+LRDPF,0,"GL")_DFN_",0)" S LRGN=$S($D(@LRGN):@LRGN,1:"") S LRPNM=$P(LRGN,U)

AR2 S ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)="" K LRDT,LRGN,LRDFN,LRLLOC,LRPNM

AR3 K ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN) K LRDT,LRGN,LRDFN,LRLLOC,LRPNM

LRKILL ; This cross-reference will be reset when the cumulative runs.  Due

 ;to the complexity of the cumulative reporting it was felt that

 ;it was better to have reprinted data rather than possibly having

 ;some data not printed at all.

 K ^LAC("LRKILL") Q

AP ;Build and kill "AP" cross-refernce in File 69, when results available

 S LRDATE=$P($P(^LRO(69,DA(1),1,DA,3),U),"."),LRPHY=$P(^LRO(69,DA(1),1,DA,0),U,6),LRPHY=$S($D(^VA(200,LRPHY,0)):$E($P(^(0),U),1,20),1:"UNK")

 S LRDFN=$P(^LRO(69,DA(1),1,DA,0),U),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) S LRGN=^DIC(+LRDPF,0,"GL")_DFN_",0)" S LRGN=$S($D(@LRGN):@LRGN,1:"") S LRPNM=$P(LRGN,U)

AP1 S ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)="" K LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN

AP2 K ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN) K LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN

AL ;Build and kill "AL" cross-reference inFile 69, when results available

 S LRDATE=$P($P(^LRO(69,DA(1),1,DA,3),U),"."),LRDFN=$P(^LRO(69,DA(1),1,DA,0),U),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) S LRGN=^DIC(+LRDPF,0,"GL")_DFN_",0)" S LRGN=$S($D(@LRGN):@LRGN,1:"") S LRPNM=$P(LRGN,U)

 S LRLLOC=$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,15)

AL1 S ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)="" K LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC

AL2 K ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN) K LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC

UP ;Convert lower to upper case.

 F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,1,%-1)_$C($A(X,%)-32)_$E(X,%+1,99)

TRIG ;Trigger LAB Workload

 ;Stuff the Cap Code Name into field .03 of field 4 of field 1 of field 1

 ;of ^LRO(67.9 LAB MONTHLY WORKLOAD

 S X=$P($G(^LAM($O(^LAM("E",$P(^LRO(67.9,DA(3),1,DA(2),1,DA(1),1,DA,0),U),0)),0)),U)

TRIGTS ;Trigger to stuff treating specialty name into .03 field of ^DD(67.91148

 S X=$P($G(^DIC(42.4,+$P($G(^LRO(67.9,DA(4),1,DA(3),1,DA(2),1,DA(1),1,DA,0)),U),0)),U) S:'$L(X) X="AMBULATORY CARE"

TRIG9 ;Trigger for LAB Workload

 ;Stuff the Cap Code Name into field .03 of field 4 of field 1 of field 1

 ;of ^LRO(67.99999 ARCHIVED LAB MONTHLY WORKLOAD

 S X=$P($G(^LAM($O(^LAM("E",$P(^LRO(67.99999,DA(3),1,DA(2),1,DA(1),1,DA,0),U),0)),0)),U)

TRIGTS9 ;Trigger to stuff treating specialty name into .03 field of ^DD(67.999991148

 S X=$P($G(^DIC(42.4,+$P($G(^LRO(67.99999,DA(4),1,DA(3),1,DA(2),1,DA(1),1,DA,0)),U),0)),U) S:'$L(X) X="AMBULATORY CARE"

LAM185 ;Trigger logic to set TYPE(#5) of CODE (#18) of WKLD CODE (#64)

 N %1

 S %1=$P(X,";",2),X=$S(%1="ICPT(":"CPT",%1="LAB(61.1,":"SNO",%1="LAB(95.3,":"LOINC",%1="ICD9(":"ICD",1:"NOS")

LRXREF    ;SLC/RWA/DALOI/FHS - BUILD CROSS-REFERENCES FOR RE-INDEX ; 17-Oct-2014 09:22 ; MKK

 +1       ;;5.2;LAB SERVICE;**70,153,263,1018,1034**;NOV 1, 1997;Build 88

 +2       ;

AVS1      ;Rebuild "AVS" cross-reference in file 68 for Re-index utility

 +1        IF $DATA(DIU(0))

               IF '$LENGTH($PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4))

                   SET ^LRO(68,"AVS",DA(2),DA(1),DA)=$PIECE(^LRO(68,DA(2),1,DA(1),1,DA,0),U)_"^"_$PIECE(^(3),U,5)

 +2        QUIT

AVS2       IF $DATA(DIU(0))

               IF $LENGTH($PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4))

                   KILL ^LRO(68,"AVS",DA(2),DA(1),DA)

 +1        QUIT

AVS3       IF '$DATA(DIU(0))

               IF $LENGTH($PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4))

                   KILL ^LRO(68,"AVS",DA(2),DA(1),DA)

 +1        QUIT

AVS4       IF '$DATA(DIU(0))

               IF '$LENGTH($PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4))

                   SET ^LRO(68,"AVS",DA(2),DA(1),DA)=$PIECE(^LRO(68,DA(2),1,DA(1),1,DA,0),U)_"^"_$PIECE(^(3),U,5)

 +1        QUIT

 +2       ;

AC1       ;Build "AC" cross-reference when comment is deleted from a verified

 +1       ;test in File 63. Audit trail only.

 +2        IF '$DATA(DIU(0))

               IF $DATA(DUZ)

                   IF $PIECE(^LR(DA(2),"CH",DA(1),0),U,3)

                       SET ^LR(DA(2),"CH",DA(1),1,"AC",DUZ,$HOROLOG)=$PIECE(^LR(DA(2),"CH",DA(1),0),U,3,4)_"^"_X

 +3        QUIT

 +4       ;Build and Kill "AN"" cross-reference in File 69, when results available

AN1        SET ^LRO(69,"AN",$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,15),$PIECE(^(0),U),9999999-$PIECE(^LRO(69,DA(1),1,DA,1),U))=""

 +1        QUIT

AN2        KILL ^LRO(69,"AN",$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,15),$PIECE(^(0),U),9999999-$PIECE(^LRO(69,DA(1),1,DA,1),U))

 +1        QUIT

 +2       ; Build and Kill "AR" cross-reference in File 69, when results available

AR1        SET LRDT=$EXTRACT(X,1,7)

           SET LRLLOC=$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,15)

 +1        SET LRDFN=$PIECE(^(0),U)

           SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

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

           SET LRGN=^DIC(+LRDPF,0,"GL")_DFN_",0)"

           SET LRGN=$SELECT($DATA(@LRGN):@LRGN,1:"")

           SET LRPNM=$PIECE(LRGN,U)

 +2        QUIT

AR2        SET ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)=""

           KILL LRDT,LRGN,LRDFN,LRLLOC,LRPNM

 +1        QUIT

AR3        KILL ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)

           KILL LRDT,LRGN,LRDFN,LRLLOC,LRPNM

 +1        QUIT

LRKILL    ; This cross-reference will be reset when the cumulative runs.  Due

 +1       ;to the complexity of the cumulative reporting it was felt that

 +2       ;it was better to have reprinted data rather than possibly having

 +3       ;some data not printed at all.

 +4        KILL ^LAC("LRKILL")

           QUIT

AP        ;Build and kill "AP" cross-refernce in File 69, when results available

 +1        SET LRDATE=$PIECE($PIECE(^LRO(69,DA(1),1,DA,3),U),".")

           SET LRPHY=$PIECE(^LRO(69,DA(1),1,DA,0),U,6)

           SET LRPHY=$SELECT($DATA(^VA(200,LRPHY,0)):$EXTRACT($PIECE(^(0),U),1,20),1:"UNK")

 +2        SET LRDFN=$PIECE(^LRO(69,DA(1),1,DA,0),U)

           SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

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

           SET LRGN=^DIC(+LRDPF,0,"GL")_DFN_",0)"

           SET LRGN=$SELECT($DATA(@LRGN):@LRGN,1:"")

           SET LRPNM=$PIECE(LRGN,U)

 +3        QUIT

AP1        SET ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)=""

           KILL LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN

 +1        QUIT

AP2        KILL ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)

           KILL LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN

 +1        QUIT

AL        ;Build and kill "AL" cross-reference inFile 69, when results available

 +1        SET LRDATE=$PIECE($PIECE(^LRO(69,DA(1),1,DA,3),U),".")

           SET LRDFN=$PIECE(^LRO(69,DA(1),1,DA,0),U)

           SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

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

           SET LRGN=^DIC(+LRDPF,0,"GL")_DFN_",0)"

           SET LRGN=$SELECT($DATA(@LRGN):@LRGN,1:"")

           SET LRPNM=$PIECE(LRGN,U)

 +2        SET LRLLOC=$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,15)

 +3        QUIT

AL1        SET ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)=""

           KILL LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC

 +1        QUIT

AL2        KILL ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)

           KILL LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC

 +1        QUIT

UP        ;Convert lower to upper case.

 +1        FOR %=1:1:$LENGTH(X)

               IF $EXTRACT(X,%)?1L

                   SET X=$EXTRACT(X,1,%-1)_$CHAR($ASCII(X,%)-32)_$EXTRACT(X,%+1,99)

 +2        QUIT

TRIG      ;Trigger LAB Workload

 +1       ;Stuff the Cap Code Name into field .03 of field 4 of field 1 of field 1

 +2       ;of ^LRO(67.9 LAB MONTHLY WORKLOAD

 +3        SET X=$PIECE($GET(^LAM($ORDER(^LAM("E",$PIECE(^LRO(67.9,DA(3),1,DA(2),1,DA(1),1,DA,0),U),0)),0)),U)

 +4        QUIT

TRIGTS    ;Trigger to stuff treating specialty name into .03 field of ^DD(67.91148

 +1        SET X=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^LRO(67.9,DA(4),1,DA(3),1,DA(2),1,DA(1),1,DA,0)),U),0)),U)

           IF '$LENGTH(X)

               SET X="AMBULATORY CARE"

 +2        QUIT

TRIG9     ;Trigger for LAB Workload

 +1       ;Stuff the Cap Code Name into field .03 of field 4 of field 1 of field 1

 +2       ;of ^LRO(67.99999 ARCHIVED LAB MONTHLY WORKLOAD

 +3        SET X=$PIECE($GET(^LAM($ORDER(^LAM("E",$PIECE(^LRO(67.99999,DA(3),1,DA(2),1,DA(1),1,DA,0),U),0)),0)),U)

 +4        QUIT

TRIGTS9   ;Trigger to stuff treating specialty name into .03 field of ^DD(67.999991148

 +1        SET X=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^LRO(67.99999,DA(4),1,DA(3),1,DA(2),1,DA(1),1,DA,0)),U),0)),U)

           IF '$LENGTH(X)

               SET X="AMBULATORY CARE"

 +2        QUIT

LAM185    ;Trigger logic to set TYPE(#5) of CODE (#18) of WKLD CODE (#64)

 +1        NEW %1

 +2        SET %1=$PIECE(X,";",2)

           SET X=$SELECT(%1="ICPT(":"CPT",%1="LAB(61.1,":"SNO",%1="LAB(95.3,":"LOINC",%1="ICD9(":"ICD",1:"NOS")

 +3        QUIT

LRXREF.m