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)
Q
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)
Q
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)
Q
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)
Q
;
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
Q
;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))=""
Q
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))
Q
; 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)
Q
AR2 S ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)="" K LRDT,LRGN,LRDFN,LRLLOC,LRPNM
Q
AR3 K ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN) K LRDT,LRGN,LRDFN,LRLLOC,LRPNM
Q
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)
Q
AP1 S ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)="" K LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
Q
AP2 K ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN) K LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
Q
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)
Q
AL1 S ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)="" K LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
Q
AL2 K ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN) K LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
Q
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)
Q
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)
Q
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"
Q
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)
Q
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"
Q
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")
Q
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
