Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRXREF

LRXREF.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ; ZEXCEPT is used to identify variables which are external to a specific TAG
  1. ; used in conjunction with Eclipse M-editor.
  1. ;
  1. AVS1 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
  1. 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)
  1. Q
  1. ;
  1. ;
  1. AVS2 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
  1. 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)
  1. Q
  1. ;
  1. ;
  1. AVS3 ; Rebuild "AVS" cross-reference in fie #68 for re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
  1. 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)
  1. Q
  1. ;
  1. ;
  1. AVS4 ; Rebuild "AVS" cross-reference in file 68 for Re-index utility - DATE/TIME RESULTS AVAILABLE (68.02,13)
  1. 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)
  1. Q
  1. ;
  1. ;
  1. AC1 ; Build "AC" cross-reference when comment is deleted from a verified test in File 63. Audit trail only.
  1. 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
  1. Q
  1. ;
  1. ;
  1. AN1 ; Build logic "AN"" cross-reference in File 69, when results available
  1. 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))=""
  1. Q
  1. ;
  1. ;
  1. AN2 ; Kill logic for "AN"" cross-reference in File 69, when results available
  1. 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))
  1. Q
  1. ;
  1. ;
  1. AR1 ; Setup variables for set/kill "AR" cross-reference in File 69, when results available
  1. S LRDT=$E(X,1,7),LRLLOC=$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,20)
  1. S LRDFN=$P(^(0),U),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1. S LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
  1. S LRGN=$S($D(@LRGN):@LRGN,1:"") S LRPNM=$P(LRGN,U)
  1. Q
  1. ;
  1. ;
  1. AR2 ; Build "AR" cross-reference in File 69, when results available
  1. N LRDT,LRGN,LRDFN,LRLLOC,LRPNM
  1. D AR1
  1. S ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)=""
  1. Q
  1. ;
  1. ;
  1. AR3 ; Kill "AR" cross-reference in File 69, when results available
  1. N LRDT,LRGN,LRDFN,LRLLOC,LRPNM
  1. D AR1
  1. K ^LRO(69,LRDT,1,"AR",LRLLOC,LRPNM,LRDFN)
  1. Q
  1. ;
  1. ;
  1. 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.
  1. K ^LAC("LRKILL")
  1. Q
  1. ;
  1. ;
  1. AP ; Setup variables for set/kill "AP" cross-reference in File 69, when results available
  1. S LRDATE=$P($P(^LRO(69,DA(1),1,DA,3),U),".")
  1. ;;*
  1. S LRPHY=+$P(^LRO(69,DA(1),1,DA,0),U,6)
  1. S LRPHY=$S($D(^VA(200,LRPHY,0)):$E($P(^(0),U),1,20),1:"UNK")
  1. ;;;*
  1. S LRDFN=$P(^LRO(69,DA(1),1,DA,0),U),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1. S LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
  1. S LRGN=$S($D(@LRGN):@LRGN,1:""),LRPNM=$P(LRGN,U)
  1. Q
  1. ;
  1. ;
  1. AP1 ; Build "AP" cross-reference in File 69, when results available
  1. N LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
  1. D AP
  1. S ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)=""
  1. Q
  1. ;
  1. ;
  1. AP2 ; Kill "AP" cross-reference in File 69, when results available
  1. N LRDATE,LRPHY,LRPNM,LRDFN,LRGN,LRDPF,DFN
  1. D AP
  1. K ^LRO(69,LRDATE,1,"AP",LRPHY,LRPNM,LRDFN)
  1. Q
  1. ;
  1. ;
  1. AL ; Setup variables for set/kill "AL" cross-reference in File 69, when results available
  1. 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)
  1. S LRGN=$$GET1^DID(+LRDPF,"","","GLOBAL NAME")_DFN_",0)"
  1. S LRGN=$S($D(@LRGN):@LRGN,1:"") S LRPNM=$P(LRGN,U)
  1. S LRLLOC=$E($P(^LRO(69,DA(1),1,DA,0),U,7),1,20)
  1. Q
  1. ;
  1. ;
  1. AL1 ; Build "AL" cross-reference in File 69, when results available
  1. N LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
  1. D AL
  1. S ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)=""
  1. Q
  1. ;
  1. ;
  1. AL2 ; Kill "AL" cross-reference in File 69, when results available
  1. N LRDATE,LRPNM,LRDFN,LRGN,LRDPF,DFN,LRLLOC
  1. D AL
  1. K ^LRO(69,LRDATE,1,"AL",LRLLOC,LRPNM,LRDFN)
  1. Q
  1. ;
  1. ;
  1. UP ; Convert lower to upper case.
  1. S X=$$UP^XLFSTR(X)
  1. Q
  1. ;
  1. ;
  1. 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
  1. 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)
  1. Q
  1. ;
  1. ;
  1. TRIGTS ; Trigger to stuff treating specialty name into .03 field of ^DD(67.91148
  1. 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"
  1. Q
  1. ;
  1. ;
  1. 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
  1. 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)
  1. Q
  1. ;
  1. ;
  1. TRIGTS9 ; Trigger to stuff treating specialty name into .03 field of ^DD(67.999991148
  1. 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"
  1. Q
  1. ;
  1. ;
  1. LAM185 ; Trigger logic to set TYPE(#5) of CODE (#18) of WKLD CODE (#64)
  1. N %1
  1. S %1=$P(X,";",2),X=$S(%1="ICPT(":"CPT",%1="LAB(61.1,":"SNO",%1="ICD9(":"ICD",1:"NOS")
  1. Q
  1. ;
  1. ;
  1. SCTCHK(LRSCT,LR612,LRSCT1) ;
  1. ; File #61.2 SNOMEDCT field check - Coded to work within FM DD calls
  1. ; Inputs
  1. ; LRSCT : SNOMED CT code
  1. ; LR612 : File #61.2 IEN
  1. ; LRSCT1 : <opt>"old" value of SNOMED CT ID field
  1. ; Output
  1. ; 1 = OK to add code
  1. ; -1 = SCT code not valid
  1. ;
  1. N LRSTAT,LRX,LRCNT,LRT
  1. S LRT=$T ;save $T
  1. S LRSCT=$G(LRSCT),LRSCT1=$G(LRSCT1),LR612=+$G(LR612),LRSTAT=1
  1. Q:LRSCT="" 1
  1. Q:$G(LR612F20)=1 1
  1. S LRX=$$CODE^LRSCT(LRSCT,"SCT")
  1. ; invalid SCT
  1. S:+LRX=-1 LRSTAT=-1
  1. ;
  1. I LRT ;reset $T
  1. Q LRSTAT
  1. ;
  1. ;
  1. DELSCT(LR612) ;
  1. ; Delete File #61.2 field 20 (SNOMED CT ID) - For use within FM DD calls and SCTCHK API
  1. N DA,DI,DIC,DIERR,X,Y,LRFDA,LRMSG,LRT
  1. S LRT=$T
  1. S LR612=+$G(LR612)
  1. S LRFDA(1,61.2,LR612_",",20)="@"
  1. D FILE^DIE("I","LRFDA(1)","LRMSG")
  1. I LRT ;reset $T
  1. Q
  1. ;
  1. ;
  1. IT61F20 ; Input transform for file #61, field 20
  1. ; $C(32) tricks EN^DDIOL to not insert a linefeed
  1. ;
  1. ;ZEXCEPT: DIUTIL,LRFMERTS,X
  1. ;
  1. N LROUT,LRSTATUS
  1. ;
  1. Q:$G(X)=""
  1. ;
  1. ; Check if SCT ID is valid
  1. S LRSTATUS=$$CODE^LEXTRAN(X,"SCT",DT,"LROUT")
  1. I LRSTATUS<1 K X
  1. ;
  1. ; Display term if not "quiet" or via FileMan Verify Fields option
  1. I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D
  1. . I $G(LROUT("F"))'="" D EN^DDIOL(LROUT("F"),"","$C(32)")
  1. . I LRSTATUS<1 D EN^DDIOL(" "_$P(LRSTATUS,"^",2),"","$C(32)")
  1. ;
  1. ; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
  1. I $D(X),$G(DIUTIL)'="VERIFY FIELDS",'$G(LRFMERTS) K X
  1. ;
  1. Q
  1. ;
  1. ;
  1. IT612F20 ; Input Transform for File #61.2 field 20
  1. ; $C(32) tricks EN^DDIOL to not insert a linefeed
  1. ;
  1. ;ZEXCEPT: DA,DIUTIL,LRFMERTS,X,Y
  1. ;
  1. N LRX,LRT
  1. ;
  1. S LRT=$T ;save $T
  1. ;
  1. Q:$G(X)=""
  1. ;
  1. ; Y=Old Value
  1. ; Is this SCT code used in #62.47?
  1. I $G(Y)'="",$D(^LAB(62.47,"AF","SCT",Y)) D Q
  1. . K X
  1. . I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D EN^DDIOL("**Mapped in File #62.47**",,"$C(32)")
  1. . I LRT ; reset $T
  1. ;
  1. Q:+$G(DA)<1
  1. S LRX=$$SCTCHK(X,DA,$G(Y))
  1. ;
  1. I +LRX=-1 D
  1. . K X
  1. . I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D EN^DDIOL("**Invalid SCT code**",,"$C(32)")
  1. ;
  1. ; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
  1. I $D(X),$G(DIUTIL)'="VERIFY FIELDS",'$G(LRFMERTS) K X
  1. ;
  1. I LRT ; reset $T
  1. Q
  1. ;
  1. ;
  1. IT62F20 ; Input transform for file #62, field 20
  1. ; $C(32) tricks EN^DDIOL to not insert a linefeed
  1. ;
  1. ;ZEXCEPT: DIUTIL,LRFMERTS,X
  1. ;
  1. N LROUT,LRSTATUS
  1. ;
  1. Q:$G(X)=""
  1. ;
  1. ; Check if SCT ID is valid
  1. S LRSTATUS=$$CODE^LEXTRAN(X,"SCT",DT,"LROUT")
  1. I LRSTATUS<1 K X
  1. ;
  1. ; Display term if not "quiet" or via FileMan Verify Fields option
  1. I '$$ISQUIET(),$G(DIUTIL)'="VERIFY FIELDS" D
  1. . I $G(LROUT("F"))'="" D EN^DDIOL(LROUT("F"),"","$C(32)")
  1. . I LRSTATUS<1 D EN^DDIOL(" "_$P(LRSTATUS,"^",2),"","$C(32)")
  1. ;
  1. ; If not FileMan Verify Fields and not editing via lab software then kill X to lock down local edits.
  1. I $D(X),$G(DIUTIL)'="VERIFY FIELDS",'$G(LRFMERTS) K X
  1. ;
  1. Q
  1. ;
  1. ;
  1. ISQUIET() ;
  1. ; Is "Quiet" or not (Should we Write output?)
  1. N QUIET
  1. S QUIET=0
  1. S:$G(LRQUIET) QUIET=1
  1. S:$G(DIQUIET) QUIET=1
  1. Q QUIET
  1. ;
  1. ;
  1. SETISOID(LRSUB) ;
  1. ; Called from #63.05 fields Cross reference
  1. ; Create and stuff ISOLATE ID when .01 field entered
  1. ; Inputs
  1. ; LRSUB : The global subscript for this isolate
  1. ;
  1. N LRFDA,LRMSG,LRIENS,LRX,LRSUBFL
  1. S LRSUB=$G(LRSUB)
  1. Q:'$G(DA)
  1. S LRSUBFL=0
  1. I LRSUB=3 S LRSUBFL=63.3
  1. I LRSUB=6 S LRSUBFL=63.34
  1. I LRSUB=9 S LRSUBFL=63.37
  1. I LRSUB=12 S LRSUBFL=63.39
  1. I LRSUB=17 S LRSUBFL=63.43
  1. Q:'LRSUBFL
  1. ;
  1. ; build IENS
  1. S LRIENS=$$IENS^DILF(.DA)
  1. S LRX=$$MAKEISO^LRVRMI1(+$$KSP^XUPARAM("INST"),LRSUB_"-"_DA)
  1. S LRFDA(1,LRSUBFL,LRIENS,.1)=LRX
  1. D ;
  1. . N DA,X,Y,X1,X2,DIE,DIC,DIERR
  1. . D FILE^DIE("","LRFDA(1)","LRMSG")
  1. Q
  1. ;
  1. ;
  1. IT600201 ;
  1. ; Input Transform for Sub-File #60.02 field #.01
  1. ; 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)
  1. I $P(^LAB(60,DA(1),0),U,5)'="" D Q ;
  1. . K X
  1. . D EN^DDIOL("NO CAN DO",,"!")
  1. ;
  1. Q:$G(DIUTIL)="VERIFY FIELDS"
  1. I X=DA(1) D Q ;
  1. . K X
  1. . D EN^DDIOL("CAN'T ADD TEST TO ITSELF",,"!,$C(7)")
  1. ;
  1. Q:'$D(X)
  1. ; Check for recursive panel entries
  1. N LRRECUR,LR60C,LR60P
  1. S LR60C=X ;child
  1. S LR60P=DA(1) ;parent
  1. ; If they're both panels then check for recursion
  1. I $O(^LAB(60,LR60C,2,0)) I $O(^LAB(60,LR60P,2,0)) D ;
  1. . K ^TMP($J,"LRXREF-PANELCHK")
  1. . S ^TMP($J,"LRXREF-PANELCHK",LR60C)=""
  1. . S ^TMP($J,"LRXREF-PANELCHK",LR60P)=""
  1. . S LRRECUR=0
  1. . D PANELCHK(LR60P,.LRRECUR) ;check parent
  1. . I 'LRRECUR D PANELCHK(LR60C,.LRRECUR) ;check the one we're adding
  1. . K ^TMP($J,"LRXREF-PANELCHK")
  1. . I LRRECUR D Q ;
  1. . . K X
  1. . . D EN^DDIOL("RECURSION DETECTED -- TEST NOT ADDED",,"!,$C(7)")
  1. . ;
  1. Q
  1. ;
  1. ;
  1. PANELCHK(LR60,LRRECUR) ;
  1. ; Private method for IT600201 above
  1. ; This is a recursive method.
  1. ; Called from DD (Input Transform). Must be FileMan safe.
  1. ; Caller must kill ^TMP($J,"LRXREF-PANELCHK") before
  1. ; first call and after last call. Parent and Child panel tests
  1. ; should be added to ^TMP($J,"LRXREF-PANELCHK",IEN) before calling:
  1. ; I $O(^LAB(60,IEN,2,0)) S ^TMP($J,"LRXREF-PANELCHK",IEN)=""
  1. ;
  1. ; Inputs
  1. ; LR60: #60 IEN of panel
  1. ; LRRECUR: <byref> See Outputs
  1. ;
  1. ; Outputs
  1. ; LRRECUR: 1=recursion found 0=no recursion
  1. ; LRRECUR(1): The parent #60 IEN and child #60 IEN that
  1. ; caused the recursion.
  1. ;
  1. N LR60B,LR6002,LRDATA,DA,X
  1. S LR60=$G(LR60)
  1. S LRRECUR=$G(LRRECUR,0)
  1. Q:LRRECUR
  1. S LR6002=0
  1. F S LR6002=$O(^LAB(60,LR60,2,LR6002)) Q:'LR6002 D Q:LRRECUR ;
  1. . S LR60B=LR60
  1. . S LRDATA=^LAB(60,LR60,2,LR6002,0)
  1. . N LR60
  1. . S LR60=$P(LRDATA,U,1)
  1. . Q:'LR60
  1. . Q:'$O(^LAB(60,LR60,2,0)) ;not a panel test
  1. . I $D(^TMP($J,"LRXREF-PANELCHK",LR60)) D Q ;
  1. . . S LRRECUR=1
  1. . . S LRRECUR(1)=LR60B_"^"_LR60
  1. . ;
  1. . S ^TMP($J,"LRXREF-PANELCHK",LR60)=""
  1. . D PANELCHK(LR60,.LRRECUR) ;recursive call
  1. ;
  1. Q