LRXREF ;DALOI/STAFF - BUILD CROSS-REFERENCES FOR RE-INDEX ;02/17/17 10:43
;;5.2;LAB SERVICE;**70,153,263,350,479**;Sep 27, 1994;Build 8
;
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
AVS1 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
I $D(DIU(0)),$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 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
I $D(DIU(0)),$P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)'="" K ^LRO(68,"AVS",DA(2),DA(1),DA)
Q
;
;
AVS3 ; Rebuild "AVS" cross-reference in fie #68 for re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
I '$D(DIU(0)),$P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)'="" K ^LRO(68,"AVS",DA(2),DA(1),DA)
Q
;
;
AVS4 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
I '$D(DIU(0)),$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
;
;
AN1 ; Build logic "AN"" cross-reference in File 69, when results available
S ^LRO(69,"AN",$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,20),$P(^(0),U),9999999-$P(^LRO(69,DA(1),1,DA,1),U))=""
Q
;
;
AN2 ; Kill logic for "AN"" cross-reference in File 69, when results available
K ^LRO(69,"AN",$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,20),$P(^(0),U),9999999-$P(^LRO(69,DA(1),1,DA,1),U))
Q
;
;
AR1 ; Setup variables for set/kill "AR" cross-reference in File 69, when results available
S LRDT=$E(X,1,7),LRLLOC=$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,20)
S LRDFN=$P(^(0),U),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
S LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
S LRGN=$S($D(@LRGN):@LRGN,1:"") S LRPNM=$P(LRGN,U)
Q
;
;
AR2 ; Build "AR" cross-reference in File 69, when results available
N LRDT,LRGN,LRDFN,LRLLOC,LRPNM
D AR1
S ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)=""
Q
;
;
AR3 ; Kill "AR" cross-reference in File 69, when results available
N LRDT,LRGN,LRDFN,LRLLOC,LRPNM
D AR1
K ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)
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 ; Setup variables for set/kill "AP" cross-reference in File 69, when results available
S LRDATE=$P($P(^LRO(69,DA(1),1,DA,3),U),".")
;;*
S LRPHY=+$P(^LRO(69,DA(1),1,DA,0),U,6)
S 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=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
S LRGN=$S($D(@LRGN):@LRGN,1:""),LRPNM=$P(LRGN,U)
Q
;
;
AP1 ; Build "AP" cross-reference in File 69, when results available
N LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
D AP
S ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)=""
Q
;
;
AP2 ; Kill "AP" cross-reference in File 69, when results available
N LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
D AP
K ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)
Q
;
;
AL ; Setup variables for set/kill "AL" cross-reference in File 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=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_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,20)
Q
;
;
AL1 ; Build "AL" cross-reference in File 69, when results available
N LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
D AL
S ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)=""
Q
;
;
AL2 ; Kill "AL" cross-reference in File 69, when results available
N LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
D AL
K ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)
Q
;
;
UP ; Convert lower to upper case.
S X=$$UP^XLFSTR(X)
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="ICD9(":"ICD",1:"NOS")
Q
;
;
SCTCHK(LRSCT,LR612,LRSCT1) ;
; File #61.2 SNOMEDCT field check - Coded to work within FM DD calls
; Inputs
; LRSCT : SNOMED CT code
; LR612 : File #61.2 IEN
; LRSCT1 : <opt>"old" value of SNOMED CT ID field
; Output
; 1 = OK to add code
; -1 = SCT code not valid
;
N LRSTAT,LRX,LRCNT,LRT
S LRT=$T ;save $T
S LRSCT=$G(LRSCT),LRSCT1=$G(LRSCT1),LR612=+$G(LR612),LRSTAT=1
Q:LRSCT="" 1
Q:$G(LR612F20)=1 1
S LRX=$$CODE^LRSCT(LRSCT,"SCT")
; invalid SCT
S:+LRX=-1 LRSTAT=-1
;
I LRT ;reset $T
Q LRSTAT
;
;
DELSCT(LR612) ;
; Delete File #61.2 field 20 (SNOMED CT ID) - For use within FM DD calls and SCTCHK API
N DA,DI,DIC,DIERR,X,Y,LRFDA,LRMSG,LRT
S LRT=$T
S LR612=+$G(LR612)
S LRFDA(1,61.2,LR612_",",20)="@"
D FILE^DIE("I","LRFDA(1)","LRMSG")
I LRT ;reset $T
Q
;
;
IT61F20 ; Input transform for file #61, field 20
; $C(32) tricks EN^DDIOL to not insert a linefeed
;
;ZEXCEPT: DIUTIL,LRFMERTS,X
;
N LROUT,LRSTATUS
;
Q:$G(X)=""
;
; Check if SCT ID is valid
S LRSTATUS=$$CODE^LEXTRAN(X,"SCT",DT,"LROUT")
I LRSTATUS<1 K X
;
; Display term if not "quiet" or via FileMan Verify Fields option
I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D
. I $G(LROUT("F"))'="" D EN^DDIOL(LROUT("F"),"","$C(32)")
. I LRSTATUS<1 D EN^DDIOL(" "_$P(LRSTATUS,"^",2),"","$C(32)")
;
; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
I $D(X),$G(DIUTIL)'="VERIFY FIELDS",'$G(LRFMERTS) K X
;
Q
;
;
IT612F20 ; Input Transform for File #61.2 field 20
; $C(32) tricks EN^DDIOL to not insert a linefeed
;
;ZEXCEPT: DA,DIUTIL,LRFMERTS,X,Y
;
N LRX,LRT
;
S LRT=$T ;save $T
;
Q:$G(X)=""
;
; Y=Old Value
; Is this SCT code used in #62.47?
I $G(Y)'="",$D(^LAB(62.47,"AF","SCT",Y)) D Q
. K X
. I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D EN^DDIOL("**Mapped in File #62.47**",,"$C(32)")
. I LRT ; reset $T
;
Q:+$G(DA)<1
S LRX=$$SCTCHK(X,DA,$G(Y))
;
I +LRX=-1 D
. K X
. I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D EN^DDIOL("**Invalid SCT code**",,"$C(32)")
;
; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
I $D(X),$G(DIUTIL)'="VERIFY FIELDS",'$G(LRFMERTS) K X
;
I LRT ; reset $T
Q
;
;
IT62F20 ; Input transform for file #62, field 20
; $C(32) tricks EN^DDIOL to not insert a linefeed
;
;ZEXCEPT: DIUTIL,LRFMERTS,X
;
N LROUT,LRSTATUS
;
Q:$G(X)=""
;
; Check if SCT ID is valid
S LRSTATUS=$$CODE^LEXTRAN(X,"SCT",DT,"LROUT")
I LRSTATUS<1 K X
;
; Display term if not "quiet" or via FileMan Verify Fields option
I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D
. I $G(LROUT("F"))'="" D EN^DDIOL(LROUT("F"),"","$C(32)")
. I LRSTATUS<1 D EN^DDIOL(" "_$P(LRSTATUS,"^",2),"","$C(32)")
;
; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
I $D(X),$G(DIUTIL)'="VERIFY FIELDS",'$G(LRFMERTS) K X
;
Q
;
;
ISQUIET() ;
; Is "Quiet" or not (Should we Write output?)
N QUIET
S QUIET=0
S:$G(LRQUIET) QUIET=1
S:$G(DIQUIET) QUIET=1
Q QUIET
;
;
SETISOID(LRSUB) ;
; Called from #63.05 fields Cross reference
; Create and stuff ISOLATE ID when .01 field entered
; Inputs
; LRSUB : The global subscript for this isolate
;
N LRFDA,LRMSG,LRIENS,LRX,LRSUBFL
S LRSUB=$G(LRSUB)
Q:'$G(DA)
S LRSUBFL=0
I LRSUB=3 S LRSUBFL=63.3
I LRSUB=6 S LRSUBFL=63.34
I LRSUB=9 S LRSUBFL=63.37
I LRSUB=12 S LRSUBFL=63.39
I LRSUB=17 S LRSUBFL=63.43
Q:'LRSUBFL
;
; build IENS
S LRIENS=$$IENS^DILF(.DA)
S LRX=$$MAKEISO^LRVRMI1(+$$KSP^XUPARAM("INST"),LRSUB_"-"_DA)
S LRFDA(1,LRSUBFL,LRIENS,.1)=LRX
D ;
. N DA,X,Y,X1,X2,DIE,DIC,DIERR
. D FILE^DIE("","LRFDA(1)","LRMSG")
Q
;
;
IT600201 ;
; Input Transform for Sub-File #60.02 field #.01
; Expects X (#60 IEN of test being added to panel) and DA array -- DA(1)=^LAB(60,IEN) DA=^LAB(60,DA(1),2,DA)
I $P(^LAB(60,DA(1),0),U,5)'="" D Q ;
. K X
. D EN^DDIOL("NO CAN DO",,"!")
;
Q:$G(DIUTIL)="VERIFY FIELDS"
I X=DA(1) D Q ;
. K X
. D EN^DDIOL("CAN'T ADD TEST TO ITSELF",,"!,$C(7)")
;
Q:'$D(X)
; Check for recursive panel entries
N LRRECUR,LR60C,LR60P
S LR60C=X ;child
S LR60P=DA(1) ;parent
; If they're both panels then check for recursion
I $O(^LAB(60,LR60C,2,0)) I $O(^LAB(60,LR60P,2,0)) D ;
. K ^TMP($J,"LRXREF-PANELCHK")
. S ^TMP($J,"LRXREF-PANELCHK",LR60C)=""
. S ^TMP($J,"LRXREF-PANELCHK",LR60P)=""
. S LRRECUR=0
. D PANELCHK(LR60P,.LRRECUR) ;check parent
. I 'LRRECUR D PANELCHK(LR60C,.LRRECUR) ;check the one we're adding
. K ^TMP($J,"LRXREF-PANELCHK")
. I LRRECUR D Q ;
. . K X
. . D EN^DDIOL("RECURSION DETECTED -- TEST NOT ADDED",,"!,$C(7)")
. ;
Q
;
;
PANELCHK(LR60,LRRECUR) ;
; Private method for IT600201 above
; This is a recursive method.
; Called from DD (Input Transform). Must be FileMan safe.
; Caller must kill ^TMP($J,"LRXREF-PANELCHK") before
; first call and after last call. Parent and Child panel tests
; should be added to ^TMP($J,"LRXREF-PANELCHK",IEN) before calling:
; I $O(^LAB(60,IEN,2,0)) S ^TMP($J,"LRXREF-PANELCHK",IEN)=""
;
; Inputs
; LR60: #60 IEN of panel
; LRRECUR: <byref> See Outputs
;
; Outputs
; LRRECUR: 1=recursion found 0=no recursion
; LRRECUR(1): The parent #60 IEN and child #60 IEN that
; caused the recursion.
;
N LR60B,LR6002,LRDATA,DA,X
S LR60=$G(LR60)
S LRRECUR=$G(LRRECUR,0)
Q:LRRECUR
S LR6002=0
F S LR6002=$O(^LAB(60,LR60,2,LR6002)) Q:'LR6002 D Q:LRRECUR ;
. S LR60B=LR60
. S LRDATA=^LAB(60,LR60,2,LR6002,0)
. N LR60
. S LR60=$P(LRDATA,U,1)
. Q:'LR60
. Q:'$O(^LAB(60,LR60,2,0)) ;not a panel test
. I $D(^TMP($J,"LRXREF-PANELCHK",LR60)) D Q ;
. . S LRRECUR=1
. . S LRRECUR(1)=LR60B_"^"_LR60
. ;
. S ^TMP($J,"LRXREF-PANELCHK",LR60)=""
. D PANELCHK(LR60,.LRRECUR) ;recursive call
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRXREF 11590 printed Dec 13, 2024@02:23:29 Page 2
LRXREF ;DALOI/STAFF - BUILD CROSS-REFERENCES FOR RE-INDEX ;02/17/17 10:43
+1 ;;5.2;LAB SERVICE;**70,153,263,350,479**;Sep 27, 1994;Build 8
+2 ;
+3 ;
+4 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+5 ; used in conjunction with Eclipse M-editor.
+6 ;
AVS1 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
+1 IF $DATA(DIU(0))
IF $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
+3 ;
+4 ;
AVS2 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
+1 IF $DATA(DIU(0))
IF $PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)'=""
KILL ^LRO(68,"AVS",DA(2),DA(1),DA)
+2 QUIT
+3 ;
+4 ;
AVS3 ; Rebuild "AVS" cross-reference in fie #68 for re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
+1 IF '$DATA(DIU(0))
IF $PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,4)'=""
KILL ^LRO(68,"AVS",DA(2),DA(1),DA)
+2 QUIT
+3 ;
+4 ;
AVS4 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
+1 IF '$DATA(DIU(0))
IF $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
+3 ;
+4 ;
AC1 ; Build "AC" cross-reference when comment is deleted from a verified test in File 63. Audit trail only.
+1 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
+2 QUIT
+3 ;
+4 ;
AN1 ; Build logic "AN"" cross-reference in File 69, when results available
+1 SET ^LRO(69,"AN",$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,20),$PIECE(^(0),U),9999999-$PIECE(^LRO(69,DA(1),1,DA,1),U))=""
+2 QUIT
+3 ;
+4 ;
AN2 ; Kill logic for "AN"" cross-reference in File 69, when results available
+1 KILL ^LRO(69,"AN",$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,20),$PIECE(^(0),U),9999999-$PIECE(^LRO(69,DA(1),1,DA,1),U))
+2 QUIT
+3 ;
+4 ;
AR1 ; Setup variables for set/kill "AR" cross-reference in File 69, when results available
+1 SET LRDT=$EXTRACT(X,1,7)
SET LRLLOC=$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,20)
+2 SET LRDFN=$PIECE(^(0),U)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+3 SET LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
+4 SET LRGN=$SELECT($DATA(@LRGN):@LRGN,1:"")
SET LRPNM=$PIECE(LRGN,U)
+5 QUIT
+6 ;
+7 ;
AR2 ; Build "AR" cross-reference in File 69, when results available
+1 NEW LRDT,LRGN,LRDFN,LRLLOC,LRPNM
+2 DO AR1
+3 SET ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)=""
+4 QUIT
+5 ;
+6 ;
AR3 ; Kill "AR" cross-reference in File 69, when results available
+1 NEW LRDT,LRGN,LRDFN,LRLLOC,LRPNM
+2 DO AR1
+3 KILL ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)
+4 QUIT
+5 ;
+6 ;
LRKILL ; This cross-reference will be reset when the cumulative runs. Due to the complexity of the cumulative reporting it was felt that
+1 ; it was better to have reprinted data rather than possibly having some data not printed at all.
+2 KILL ^LAC("LRKILL")
+3 QUIT
+4 ;
+5 ;
AP ; Setup variables for set/kill "AP" cross-reference in File 69, when results available
+1 SET LRDATE=$PIECE($PIECE(^LRO(69,DA(1),1,DA,3),U),".")
+2 ;;*
+3 SET LRPHY=+$PIECE(^LRO(69,DA(1),1,DA,0),U,6)
+4 SET LRPHY=$SELECT($DATA(^VA(200,LRPHY,0)):$EXTRACT($PIECE(^(0),U),1,20),1:"UNK")
+5 ;;;*
+6 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)
+7 SET LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
+8 SET LRGN=$SELECT($DATA(@LRGN):@LRGN,1:"")
SET LRPNM=$PIECE(LRGN,U)
+9 QUIT
+10 ;
+11 ;
AP1 ; Build "AP" cross-reference in File 69, when results available
+1 NEW LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
+2 DO AP
+3 SET ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)=""
+4 QUIT
+5 ;
+6 ;
AP2 ; Kill "AP" cross-reference in File 69, when results available
+1 NEW LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
+2 DO AP
+3 KILL ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)
+4 QUIT
+5 ;
+6 ;
AL ; Setup variables for set/kill "AL" cross-reference in File 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)
+2 SET LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
+3 SET LRGN=$SELECT($DATA(@LRGN):@LRGN,1:"")
SET LRPNM=$PIECE(LRGN,U)
+4 SET LRLLOC=$EXTRACT($PIECE(^LRO(69,DA(1),1,DA,0),U,7),1,20)
+5 QUIT
+6 ;
+7 ;
AL1 ; Build "AL" cross-reference in File 69, when results available
+1 NEW LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
+2 DO AL
+3 SET ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)=""
+4 QUIT
+5 ;
+6 ;
AL2 ; Kill "AL" cross-reference in File 69, when results available
+1 NEW LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
+2 DO AL
+3 KILL ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)
+4 QUIT
+5 ;
+6 ;
UP ; Convert lower to upper case.
+1 SET X=$$UP^XLFSTR(X)
+2 QUIT
+3 ;
+4 ;
TRIG ; Trigger LAB Workload
+1 ; Stuff the Cap Code Name into field .03 of field 4 of field 1 of field 1 of ^LRO(67.9 LAB MONTHLY WORKLOAD
+2 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)
+3 QUIT
+4 ;
+5 ;
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
+3 ;
+4 ;
TRIG9 ; Trigger for LAB Workload
+1 ; 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
+2 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)
+3 QUIT
+4 ;
+5 ;
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
+3 ;
+4 ;
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="ICD9(":"ICD",1:"NOS")
+3 QUIT
+4 ;
+5 ;
SCTCHK(LRSCT,LR612,LRSCT1) ;
+1 ; File #61.2 SNOMEDCT field check - Coded to work within FM DD calls
+2 ; Inputs
+3 ; LRSCT : SNOMED CT code
+4 ; LR612 : File #61.2 IEN
+5 ; LRSCT1 : <opt>"old" value of SNOMED CT ID field
+6 ; Output
+7 ; 1 = OK to add code
+8 ; -1 = SCT code not valid
+9 ;
+10 NEW LRSTAT,LRX,LRCNT,LRT
+11 ;save $T
SET LRT=$TEST
+12 SET LRSCT=$GET(LRSCT)
SET LRSCT1=$GET(LRSCT1)
SET LR612=+$GET(LR612)
SET LRSTAT=1
+13 if LRSCT=""
QUIT 1
+14 if $GET(LR612F20)=1
QUIT 1
+15 SET LRX=$$CODE^LRSCT(LRSCT,"SCT")
+16 ; invalid SCT
+17 if +LRX=-1
SET LRSTAT=-1
+18 ;
+19 ;reset $T
IF LRT
+20 QUIT LRSTAT
+21 ;
+22 ;
DELSCT(LR612) ;
+1 ; Delete File #61.2 field 20 (SNOMED CT ID) - For use within FM DD calls and SCTCHK API
+2 NEW DA,DI,DIC,DIERR,X,Y,LRFDA,LRMSG,LRT
+3 SET LRT=$TEST
+4 SET LR612=+$GET(LR612)
+5 SET LRFDA(1,61.2,LR612_",",20)="@"
+6 DO FILE^DIE("I","LRFDA(1)","LRMSG")
+7 ;reset $T
IF LRT
+8 QUIT
+9 ;
+10 ;
IT61F20 ; Input transform for file #61, field 20
+1 ; $C(32) tricks EN^DDIOL to not insert a linefeed
+2 ;
+3 ;ZEXCEPT: DIUTIL,LRFMERTS,X
+4 ;
+5 NEW LROUT,LRSTATUS
+6 ;
+7 if $GET(X)=""
QUIT
+8 ;
+9 ; Check if SCT ID is valid
+10 SET LRSTATUS=$$CODE^LEXTRAN(X,"SCT",DT,"LROUT")
+11 IF LRSTATUS<1
KILL X
+12 ;
+13 ; Display term if not "quiet" or via FileMan Verify Fields option
+14 IF '$$ISQUIET()
IF $GET(DIUTIL)'="VERIFY FIELDS"
Begin DoDot:1
+15 IF $GET(LROUT("F"))'=""
DO EN^DDIOL(LROUT("F"),"","$C(32)")
+16 IF LRSTATUS<1
DO EN^DDIOL(" "_$PIECE(LRSTATUS,"^",2),"","$C(32)")
End DoDot:1
+17 ;
+18 ; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
+19 IF $DATA(X)
IF $GET(DIUTIL)'="VERIFY FIELDS"
IF '$GET(LRFMERTS)
KILL X
+20 ;
+21 QUIT
+22 ;
+23 ;
IT612F20 ; Input Transform for File #61.2 field 20
+1 ; $C(32) tricks EN^DDIOL to not insert a linefeed
+2 ;
+3 ;ZEXCEPT: DA,DIUTIL,LRFMERTS,X,Y
+4 ;
+5 NEW LRX,LRT
+6 ;
+7 ;save $T
SET LRT=$TEST
+8 ;
+9 if $GET(X)=""
QUIT
+10 ;
+11 ; Y=Old Value
+12 ; Is this SCT code used in #62.47?
+13 IF $GET(Y)'=""
IF $DATA(^LAB(62.47,"AF","SCT",Y))
Begin DoDot:1
+14 KILL X
+15 IF '$$ISQUIET()
IF $GET(DIUTIL)'="VERIFY FIELDS"
DO EN^DDIOL("**Mapped in File #62.47**",,"$C(32)")
+16 ; reset $T
IF LRT
End DoDot:1
QUIT
+17 ;
+18 if +$GET(DA)<1
QUIT
+19 SET LRX=$$SCTCHK(X,DA,$GET(Y))
+20 ;
+21 IF +LRX=-1
Begin DoDot:1
+22 KILL X
+23 IF '$$ISQUIET()
IF $GET(DIUTIL)'="VERIFY FIELDS"
DO EN^DDIOL("**Invalid SCT code**",,"$C(32)")
End DoDot:1
+24 ;
+25 ; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
+26 IF $DATA(X)
IF $GET(DIUTIL)'="VERIFY FIELDS"
IF '$GET(LRFMERTS)
KILL X
+27 ;
+28 ; reset $T
IF LRT
+29 QUIT
+30 ;
+31 ;
IT62F20 ; Input transform for file #62, field 20
+1 ; $C(32) tricks EN^DDIOL to not insert a linefeed
+2 ;
+3 ;ZEXCEPT: DIUTIL,LRFMERTS,X
+4 ;
+5 NEW LROUT,LRSTATUS
+6 ;
+7 if $GET(X)=""
QUIT
+8 ;
+9 ; Check if SCT ID is valid
+10 SET LRSTATUS=$$CODE^LEXTRAN(X,"SCT",DT,"LROUT")
+11 IF LRSTATUS<1
KILL X
+12 ;
+13 ; Display term if not "quiet" or via FileMan Verify Fields option
+14 IF '$$ISQUIET()
IF $GET(DIUTIL)'="VERIFY FIELDS"
Begin DoDot:1
+15 IF $GET(LROUT("F"))'=""
DO EN^DDIOL(LROUT("F"),"","$C(32)")
+16 IF LRSTATUS<1
DO EN^DDIOL(" "_$PIECE(LRSTATUS,"^",2),"","$C(32)")
End DoDot:1
+17 ;
+18 ; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
+19 IF $DATA(X)
IF $GET(DIUTIL)'="VERIFY FIELDS"
IF '$GET(LRFMERTS)
KILL X
+20 ;
+21 QUIT
+22 ;
+23 ;
ISQUIET() ;
+1 ; Is "Quiet" or not (Should we Write output?)
+2 NEW QUIET
+3 SET QUIET=0
+4 if $GET(LRQUIET)
SET QUIET=1
+5 if $GET(DIQUIET)
SET QUIET=1
+6 QUIT QUIET
+7 ;
+8 ;
SETISOID(LRSUB) ;
+1 ; Called from #63.05 fields Cross reference
+2 ; Create and stuff ISOLATE ID when .01 field entered
+3 ; Inputs
+4 ; LRSUB : The global subscript for this isolate
+5 ;
+6 NEW LRFDA,LRMSG,LRIENS,LRX,LRSUBFL
+7 SET LRSUB=$GET(LRSUB)
+8 if '$GET(DA)
QUIT
+9 SET LRSUBFL=0
+10 IF LRSUB=3
SET LRSUBFL=63.3
+11 IF LRSUB=6
SET LRSUBFL=63.34
+12 IF LRSUB=9
SET LRSUBFL=63.37
+13 IF LRSUB=12
SET LRSUBFL=63.39
+14 IF LRSUB=17
SET LRSUBFL=63.43
+15 if 'LRSUBFL
QUIT
+16 ;
+17 ; build IENS
+18 SET LRIENS=$$IENS^DILF(.DA)
+19 SET LRX=$$MAKEISO^LRVRMI1(+$$KSP^XUPARAM("INST"),LRSUB_"-"_DA)
+20 SET LRFDA(1,LRSUBFL,LRIENS,.1)=LRX
+21 ;
Begin DoDot:1
+22 NEW DA,X,Y,X1,X2,DIE,DIC,DIERR
+23 DO FILE^DIE("","LRFDA(1)","LRMSG")
End DoDot:1
+24 QUIT
+25 ;
+26 ;
IT600201 ;
+1 ; Input Transform for Sub-File #60.02 field #.01
+2 ; Expects X (#60 IEN of test being added to panel) and DA array -- DA(1)=^LAB(60,IEN) DA=^LAB(60,DA(1),2,DA)
+3 ;
IF $PIECE(^LAB(60,DA(1),0),U,5)'=""
Begin DoDot:1
+4 KILL X
+5 DO EN^DDIOL("NO CAN DO",,"!")
End DoDot:1
QUIT
+6 ;
+7 if $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+8 ;
IF X=DA(1)
Begin DoDot:1
+9 KILL X
+10 DO EN^DDIOL("CAN'T ADD TEST TO ITSELF",,"!,$C(7)")
End DoDot:1
QUIT
+11 ;
+12 if '$DATA(X)
QUIT
+13 ; Check for recursive panel entries
+14 NEW LRRECUR,LR60C,LR60P
+15 ;child
SET LR60C=X
+16 ;parent
SET LR60P=DA(1)
+17 ; If they're both panels then check for recursion
+18 ;
IF $ORDER(^LAB(60,LR60C,2,0))
IF $ORDER(^LAB(60,LR60P,2,0))
Begin DoDot:1
+19 KILL ^TMP($JOB,"LRXREF-PANELCHK")
+20 SET ^TMP($JOB,"LRXREF-PANELCHK",LR60C)=""
+21 SET ^TMP($JOB,"LRXREF-PANELCHK",LR60P)=""
+22 SET LRRECUR=0
+23 ;check parent
DO PANELCHK(LR60P,.LRRECUR)
+24 ;check the one we're adding
IF 'LRRECUR
DO PANELCHK(LR60C,.LRRECUR)
+25 KILL ^TMP($JOB,"LRXREF-PANELCHK")
+26 ;
IF LRRECUR
Begin DoDot:2
+27 KILL X
+28 DO EN^DDIOL("RECURSION DETECTED -- TEST NOT ADDED",,"!,$C(7)")
End DoDot:2
QUIT
+29 ;
End DoDot:1
+30 QUIT
+31 ;
+32 ;
PANELCHK(LR60,LRRECUR) ;
+1 ; Private method for IT600201 above
+2 ; This is a recursive method.
+3 ; Called from DD (Input Transform). Must be FileMan safe.
+4 ; Caller must kill ^TMP($J,"LRXREF-PANELCHK") before
+5 ; first call and after last call. Parent and Child panel tests
+6 ; should be added to ^TMP($J,"LRXREF-PANELCHK",IEN) before calling:
+7 ; I $O(^LAB(60,IEN,2,0)) S ^TMP($J,"LRXREF-PANELCHK",IEN)=""
+8 ;
+9 ; Inputs
+10 ; LR60: #60 IEN of panel
+11 ; LRRECUR: <byref> See Outputs
+12 ;
+13 ; Outputs
+14 ; LRRECUR: 1=recursion found 0=no recursion
+15 ; LRRECUR(1): The parent #60 IEN and child #60 IEN that
+16 ; caused the recursion.
+17 ;
+18 NEW LR60B,LR6002,LRDATA,DA,X
+19 SET LR60=$GET(LR60)
+20 SET LRRECUR=$GET(LRRECUR,0)
+21 if LRRECUR
QUIT
+22 SET LR6002=0
+23 ;
FOR
SET LR6002=$ORDER(^LAB(60,LR60,2,LR6002))
if 'LR6002
QUIT
Begin DoDot:1
+24 SET LR60B=LR60
+25 SET LRDATA=^LAB(60,LR60,2,LR6002,0)
+26 NEW LR60
+27 SET LR60=$PIECE(LRDATA,U,1)
+28 if 'LR60
QUIT
+29 ;not a panel test
if '$ORDER(^LAB(60,LR60,2,0))
QUIT
+30 ;
IF $DATA(^TMP($JOB,"LRXREF-PANELCHK",LR60))
Begin DoDot:2
+31 SET LRRECUR=1
+32 SET LRRECUR(1)=LR60B_"^"_LR60
End DoDot:2
QUIT
+33 ;
+34 SET ^TMP($JOB,"LRXREF-PANELCHK",LR60)=""
+35 ;recursive call
DO PANELCHK(LR60,.LRRECUR)
End DoDot:1
if LRRECUR
QUIT
+36 ;
+37 QUIT
