- 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 Feb 18, 2025@23:49:20 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