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

BLRUTIL6.m

Go to the documentation of this file. 
  1. BLRUTIL6 ;IHS/MSC/MKK - MISC IHS LAB UTILITIES (Cont) ; 04-Apr-2016 14:28 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033,1034,1035,1039**;NOV 01, 1997;Build 38
  1.  ;
  1. GETSTACK ; EP -- from BLRUTIL.
  1.  NEW CONTXT,LOOP
  1.  ;
  1.  S CONTXT=$STACK(-1)
  1.  F LOOP=0:1:CONTXT  D
  1.  . S ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"$STACK",LOOP,1,"CONTEXT LEVEL")=LOOP
  1.  . S ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"$STACK",LOOP,2,"CONTEXT TYPE")=$STACK(LOOP)
  1.  . S ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"$STACK",LOOP,3,"CURRENT PLACE")=$STACK(LOOP,"PLACE")
  1.  . S ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"$STACK",LOOP,4,"CURRENT SOURCE")=$STACK(LOOP,"MCODE")
  1.  Q
  1.  ;
  1. DEBUGMI ; EP - from BLRUTIL.
  1.  Q:+$G(LRAA)<1!(+$G(LRAD)<1)!(+$G(LRAN)<1)
  1.  Q:$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT")'["MICRO"
  1.  ;
  1.  S DMLRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),DMLRIDT=$P($G(^(3)),"^",5)
  1.  Q
  1.  ;
  1. MAKEITSO ; EP - Reset PROCESSING DATE variable
  1.  NEW WOTRTN
  1.  F  Q:$L($G(BLRQDH))=5  D
  1.  . S BLRQDH=+$H           ; Try setting it again
  1.  . I $L(BLRQDH)'=5 D      ; Still invalid
  1.  .. D MAKETMPC(.WOTRTN)
  1.  .. H 5                   ; Pause 5 seconds
  1.  K ^TMP(WOTRTN,$J,"MAKEITSO")
  1.  Q
  1.  ;
  1. MAKETMPC(WOTRTN) ; EP - Keep track of # of times tried to reset
  1.  NEW BLRVERN,CONTEXT,FRMWHERE,MSGARRAY,STACKNUM
  1.  ;
  1.  D SETBLRVS("MAKETMPC")
  1.  S FRMWHERE=BLRVERN
  1.  ;
  1.  ; Try to determine the calling routine's name
  1.  S CONTEXT=$STACK(-1)
  1.  F  Q:CONTEXT<1!(FRMWHERE'=BLRVERN)  D
  1.  . S FRMWHERE=$STACK(CONTEXT,"PLACE")
  1.  . S:FRMWHERE["^" FRMWHERE=$P(FRMWHERE,"^",2)
  1.  . S FRMWHERE=$P(FRMWHERE," ")
  1.  . S CONTEXT=CONTEXT-1
  1.  ;
  1.  S WOTRTN=FRMWHERE
  1.  ;
  1.  S ^TMP(FRMWHERE,$J,"MAKEITSO")=1+$G(^TMP(FRMWHERE,$J,"MAKEITSO"))
  1.  S ^TMP(FRMWHERE,$J,"MAKEITSO",$H)=""
  1.  ;
  1.  Q:+$G(^TMP(FRMWHERE,$J,"MAKEITSO"))<5
  1.  Q:+$O(^XTMP(FRMWHERE,"MAILSENT",+$H))   ; Skip if Mail already sent
  1.  ;
  1.  ; Tried to reset 5 Times, so send e-mail & Alert to LMI Mail Group
  1.  S MSGARRAY(1)="LAB TO PCC LINKER ISSUE"
  1.  S MSGARRAY(2)="     Cannot reset BLRQDH variable.  BLRQDH:"_BLRQDH_"."
  1.  D MAILALMI^BLRUTIL3("LAB TO PCC LINKER ISSUE",.MSGARRAY,FRMWHERE,1)
  1.  ;
  1.  ; Store information about sending email
  1.  S ^XTMP(FRMWHERE,0)=$$HTFM^XLFDT(+$H+90)_"^"_$$DT^XLFDT_"^RPMS Lab To PCC Linker Issue"
  1.  S ^XTMP(FRMWHERE,"MAILSENT",$H)=BLRQDH
  1.  ;
  1.  Q
  1.  ;
  1. PASSMESG(WOT) ; EP -- Splash message
  1.  NEW CRTLINE,MAXIT,AROUND
  1.  ;
  1.  S MAXIT="@"
  1.  F J=1:1:$L(WOT) S MAXIT=MAXIT_$E(WOT,J,J)_"@"
  1.  S AROUND=$TR($J("",8+$L(MAXIT))," ","@")
  1.  S MAXIT="@@!!"_$TR(MAXIT," ","@")_"!!@@"
  1.  ;
  1.  D ^XBCLS
  1.  W $TR($J("",IOM)," ","*"),!,$TR($J("",IOM)," ","*"),!
  1.  W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(MAXIT,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
  1.  W $TR($J("",IOM)," ","*"),!,$TR($J("",IOM)," ","*"),!
  1.  Q
  1.  ;
  1.  ; Data in ARRAY(1)="First String"; ARRAY(2)="Second String"; etc.
  1. UPDTCOML(LRDFN,LRSS,LRIDT,ARRAY,ERRORMSG) ; EP - Update the Comment line(s)
  1.  NEW ANSWER,ASKORDQ,DIE,ERRCNT,ERRS,FDA,IENS,LRAS,MAILARRY,ORD,P60,P60DESC,P60BORDR,QUESCNT
  1.  ;
  1.  Q:$D(ARRAY)<1     ; Skip if nothing stored
  1.  ;
  1.  S (ERRCNT,LINE)=0
  1.  F  S LINE=$O(ARRAY(LINE))  Q:LINE<1  D
  1.  . Q:$L($G(ARRAY(LINE)))<1
  1.  . D ADDCOMNT(LRDFN,LRSS,LRIDT,ARRAY(LINE),.ERRCNT)
  1.  ;
  1.  Q:ERRCNT<1
  1.  ;
  1.  ; There exist errors.  Send E-Mail via MailMan to user
  1.  S LRAS=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),"^",6)
  1.  S MAILARRY(1)="Error Updating Accession "_LRAS,MAILARRY(2)=" "
  1.  S MAILARRY(3)="     LRDFN:"_LRDFN
  1.  S MAILARRY(4)="      LRSS:"_LRSS
  1.  S MAILARRY(5)="     LRIDT:"_LRIDT
  1.  S MAILARRY(6)="        $J:"_$J
  1.  S MAILARRY(7)=" ",MAILARRY(8)="     SEE ^TMP(""BLRUTIL6"","_$J_",""ERRORS"")"
  1.  ;
  1.  D SENDMAIL^BLRUTIL3(ERRORMSG,MAILARRY,"UPDTCOML",1)
  1.  ;
  1.  Q
  1.  ;
  1. ADDCOMNT(LRDFN,LRSS,LRIDT,WOT,ERRCNT) ; EP - Add the comment
  1.  NEW FDA,IENS,RJAMT
  1.  ;
  1.  S WOT=$$UP^XLFSTR($$HTE^XLFDT($H,"MPZ"))_": "_WOT
  1.  ;
  1.  S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1  ; Get next COMMENT line
  1.  ;
  1.  S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=$TR(WOT,"^"," ")
  1.  ;
  1.  D UPDATE^DIE(,"FDA","IENS","ERRS")
  1.  ;
  1.  I $D(ERRS("DIERR"))>0  D
  1.  . S ^TMP("BLRUTIL6",$J,"ERRORS",LRDFN,LRSS,LRIDT)=""
  1.  . M ^TMP("BLRUTIL6",$J,"ERRORS",LRDFN,LRSS,LRIDT,"LINE")=WOT
  1.  . M ^TMP("BLRUTIL6",$J,"ERRORS",LRDFN,LRSS,LRIDT,"ERRORS")=ERRS("DIERR")
  1.  . S ERRCNT=ERRCNT+1
  1.  Q
  1.  ;
  1. DUPDNAME ; EP - Find Instances of Duplicate DataNames
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$DUPNAMEI()="Q"
  1.  ;
  1.  F  S DATADESC=$O(^DD(63.04,"B",DATADESC))  Q:DATADESC=""!(QFLG="Q")  D DUPNAMEL
  1.  ;
  1.  ; W !!,?4,"Number of Duplicate Datanames = ",CNT
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  W !!,?4,DATANCNT," DataNames Analyzed."
  1.  W !!,?9,$S(CNT:CNT,1:"No")," Duplicate DataName",$S(CNT=1:"",1:"s"),"."
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  D ^%ZISC
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. DUPNAMEI() ; EP - Initialization
  1.  D SETBLRVS("DUPDNAME")
  1.  ;
  1.  S HEADER(1)="Duplicate DataNames"
  1.  S HEADER(2)="File 63.04"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),10)="#"
  1.  S $E(HEADER(4),20)="Description"
  1.  S $E(HEADER(4),50)="Last Edit"
  1.  S $E(HEADER(4),65)="F 60"
  1.  ;
  1.  D ^%ZIS
  1.  I POP D  Q "Q"
  1.  . W !,?4,"Invalid DEVICE call.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  U IO
  1.  ;
  1.  S (CNT,PG)=0
  1.  S MAXLINES=(IOSL-4),LINES=MAXLINES+10
  1.  S QFLG="NO"
  1.  S DATADESC=""
  1.  S DATANCNT=0 ; IHS/MSC/MKK - LR*5.2*1034
  1.  Q "OK"
  1.  ;
  1. DUPNAMEL ; EP - Line of Data
  1.  Q:$$DUPNAMEC(.DUPNAMEA)=0
  1.  ;
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  ;
  1.  S (CNTDN,DATANAME)=0
  1.  F  S DATANAME=$O(DUPNAMEA(DATANAME))  Q:DATANAME<1!(QFLG="Q")  D
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  . ;
  1.  . S CNTDN=CNTDN+1
  1.  . W $J(CNTDN,3)
  1.  . W ?9,DATANAME
  1.  . W ?19,$E(DATADESC,1,28)
  1.  . S CREATEDT=$G(DUPNAMEA(DATANAME,"DT"))
  1.  . W:$L(CREATEDT) ?49,$$FMTE^XLFDT(CREATEDT,"5DZ")
  1.  . W ?65,$O(^LAB(60,"C","CH;"_DATANAME_";1",0))
  1.  . W !
  1.  . S LINES=LINES+1
  1.  ;
  1.  W !
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1. DUPNAMEC(ARRAY) ; EP - Check on the DataName
  1.  S DATANCNT=DATANCNT+1  ; IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  NEW DN,NUMDUPS
  1.  ;
  1.  K ARRAY
  1.  ;
  1.  S (DN,NUMDUPS)=0
  1.  F  S DN=$O(^DD(63.04,"B",DATADESC,DN))  Q:DN<1  D
  1.  . S NUMDUPS=NUMDUPS+1
  1.  . S ARRAY(DN)=""
  1.  . S ARRAY(DN,"DT")=$G(^DD(63.04,DN,"DT"))
  1.  ;
  1.  Q $S(NUMDUPS<2:1,1:0)
  1.  ;
  1. FINDSEXR ; EP - Find usage of SEX in Reference Ranges in File 60
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$FINDSEXI()="Q"
  1.  ;
  1.  F  S F60IEN=$O(^LAB(60,F60IEN))  Q:F60IEN<1!(QFLG="Q")  D
  1.  . S F60DESC=$$GET1^DIQ(60,F60IEN,"NAME")
  1.  . S SITESPEC=0
  1.  . F  S SITESPEC=$O(^LAB(60,F60IEN,1,SITESPEC))  Q:SITESPEC<1!(QFLG="Q")  D FINDSEXL
  1.  ;
  1.  W:CNT !!,?4,"Number of Tests with SEX in Reference Range = ",CNT,!
  1.  ;
  1.  D ^%ZISC
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. FINDSEXI() ; EP - Initialization
  1.  D SETBLRVS("FINDSEXR")
  1.  ;
  1.  S HEADER(1)="LABORATORY TEST (#60) FILE"
  1.  S HEADER(2)="RANGES WITH 'SEX' USED IN MUMPS CODE"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  S HEADER(3)=" "
  1.  S HEADER(4)=$TR($$CJ^XLFSTR("@File@60@",26)," @","= ")
  1.  S $E(HEADER(4),29)=$TR($$CJ^XLFSTR("@File@62@",26)," @","= ")
  1.  S $E(HEADER(4),58)="Ref",$E(HEADER(4),62)="Ref"
  1.  S $E(HEADER(4),66)="Cri",$E(HEADER(4),70)="Cri"
  1.  S $E(HEADER(4),74)="Thr",$E(HEADER(4),78)="Thr"
  1.  S HEADER(5)="IEN",$E(HEADER(5),10)="Description"
  1.  S $E(HEADER(5),29)="IEN",$E(HEADER(5),39)="Description"
  1.  S $E(HEADER(5),58)="Low",$E(HEADER(5),62)="Hi"
  1.  S $E(HEADER(5),66)="Low",$E(HEADER(5),70)="Hi"
  1.  S $E(HEADER(5),74)="Low",$E(HEADER(5),78)="Hi"
  1.  ;
  1.  D ^%ZIS
  1.  I POP D  Q "Q"
  1.  . W !,?4,"Device Issue.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  U IO
  1.  ;
  1.  S MAXLINES=(IOSL-4),LINES=MAXLINES+10
  1.  S (CNT,F60IEN,PG)=0
  1.  S QFLG="NO"
  1.  Q "OK"
  1.  ;
  1. FINDSEXL ; EP - Line of Data
  1.  S STR=$$UP^XLFSTR($G(^LAB(60,F60IEN,1,SITESPEC,0)))
  1.  Q:STR'["SEX"
  1.  ;
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  D FINDSEXB
  1.  ;
  1.  W F60IEN
  1.  W ?9,$E(F60DESC,1,17)
  1.  W ?28,SITESPTR
  1.  W ?38,$E(SITESPN,1,17)
  1.  W:REFLOW["SEX" ?58,"X"
  1.  W:REFHIGH["SEX" ?62,"X"
  1.  W:CRITLOW["SEX" ?66,"X"
  1.  W:CRITHIGH["SEX" ?70,"X"
  1.  W:THERLOW["SEX" ?74,"X"
  1.  W:THERHIGH["SEX" ?78,"X"
  1.  W !
  1.  S CNT=CNT+1
  1.  S LINES=LINES+1
  1.  Q
  1.  ;
  1. FINDSEXB ; EP - Breakout Data
  1.  S SITESPTR=+STR
  1.  S SITESPN=$$GET1^DIQ(61,SITESPTR,"NAME")
  1.  ;
  1.  S REFLOW=$P(STR,"^",2)
  1.  S REFHIGH=$P(STR,"^",3)
  1.  S CRITLOW=$P(STR,"^",4)
  1.  S CRITHIGH=$P(STR,"^",5)
  1.  S THERLOW=$P(STR,"^",11)
  1.  S THERHIGH=$P(STR,"^",12)
  1.  Q
  1.  ;
  1.  ; See LRORDST routine regarding ^TMP("LRORDST") setup.
  1. IHSCOLS ; EP - From LRWLST1.
  1.  NEW DN,F60IEN,COLLSAMP,COLLSIEN,CSAMP1,CSAMP2,CSAMP3,STR,TMPCNT,TMPSPEC,TMPSAMP,TMPTEST
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  NEW F69CSAMP
  1.  ;
  1.  S F69CSAMP=$$GET1^DIQ(69.01,LRSN_","_LRODT,"COLLECTION SAMPLE","I")
  1.  I F69CSAMP D  Q
  1.  . S FDA(LRI,68.05,"+1,"_LR6802,1)=F69CSAMP
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  S TMPSAMP=0  F  S TMPSAMP=$O(^TMP("LRORDST",$J,"LROT",TMPSAMP))  Q:TMPSAMP<1  D
  1.  . S TMPSPEC=0  F  S TMPSPEC=$O(^TMP("LRORDST",$J,"LROT",TMPSAMP,TMPSPEC))  Q:TMPSPEC<1  D
  1.  .. S TMPCNT=0  F  S TMPCNT=$O(^TMP("LRORDST",$J,"LROT",TMPSAMP,TMPSPEC,TMPCNT))  Q:TMPCNT<1  D
  1.  ... S TMPTEST(+$G(^TMP("LRORDST",$J,"LROT",TMPSAMP,TMPSPEC,TMPCNT)))=TMPSAMP_"^"_TMPSPEC
  1.  ;
  1.  S F60IEN=+LRTSTS
  1.  Q:F60IEN<1
  1.  ;
  1.  I $D(TMPTEST) D  Q:$L(LRSAMP)
  1.  . S STR=$G(TMPTEST(F60IEN))
  1.  . S LRSAMP=$P(STR,"^"),LRSPEC=$P(STR,"^",2)
  1.  . S FDA(LRI,68.05,"+1,"_LR6802,1)=LRSAMP
  1.  ;
  1.  ; Reset LRSPEC variable
  1.  S LRSPEC=+LRX
  1.  S:LRSPEC<1 LRSPEC=-1
  1.  ;
  1.  S COLLSIEN=+$O(^LAB(60,F60IEN,3,0))
  1.  S CSAMP1=+$$GET1^DIQ(60.03,COLLSIEN_","_F60IEN,.01,"I")   ; Collection Sample from File 60
  1.  S CSAMP2=+$$GET1^DIQ(61,LRSPEC,4.1,"I")                   ; Collection Sample from File 61
  1.  ;
  1.  ; ---- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  I $L($P($G(LRZX),"^",3)),CSAMP2<1 S CSAMP2=$P(LRZX,"^",3)
  1.  ;
  1.  S COLLSAMP=$S(CSAMP2:CSAMP2,1:CSAMP1)
  1.  ; ---- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  ; If null, set COLLSAMP variable from Collection Sample from File 60
  1.  I $L($G(COLLSAMP))<1,CSAMP1 S COLLSAMP=CSAMP1
  1.  ;
  1.  Q:+$G(COLLSAMP)<1
  1.  ;
  1.  S FDA(LRI,68.05,"+1,"_LR6802,1)=COLLSAMP
  1.  ;
  1.  ; Force the Order file to have the value, if null
  1.  S:$P(^LRO(69,LRODT,1,LRSN,0),"^",3)="" $P(^LRO(69,LRODT,1,LRSN,0),"^",3)=COLLSAMP
  1.  ;
  1.  ; Reset LRSAMP variable
  1.  S LRSAMP=COLLSAMP
  1.  Q
  1.  ;
  1.  ;
  1. BADSTUFF(MSG) ; EP - 'Routine Ends' prompt
  1.  W !!,?4,MSG," Routine Ends."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. BADSTUFQ(MSG) ; EP - Quits with "Q"
  1.  D BADSTUFF(MSG)
  1.  Q "Q"
  1.  ;
  1. BADSTUFN(MSG) ; EP - Quits with ""
  1.  D BADSTUFF(MSG)
  1.  Q ""
  1.  ;
  1. SETBLRVS(TWO) ; EP - Use the STACK to find the Routine and set the BLRVRN variable(S)
  1.  K BLRVERN,BLRVERN2
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=$G(TWO)
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1. STORDIAG(LRODT,LRSP,LROT,ICDSTR) ; EP - Store the Diagnosis code(s)
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,ICDSTR,LRODT,LRSP,LROT,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:ICDSTR<1     ; Quit if no ICD code
  1.  ;
  1.  S F60PTR=+$$GET1^DIQ(69.03,LROT_","_LRSP_","_LRODT,.01,"I")
  1.  Q:$$REFLABCK(F60PTR,LRODT,LRSP)<1      ; Do nothing if not a Ref Lab test
  1.  ;
  1.  S ORDERN=$$GET1^DIQ(69.01,LRSP_","_LRODT,9.5,"I")
  1.  Q:ORDERN<1      ; Quit if no Order #
  1.  ;
  1.  S LRDFN=$$GET1^DIQ(69.01,LRSP_","_LRODT,.01,"I")
  1.  S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
  1.  ;
  1.  S TORDIEN=LROT_","_LRSP_","_LRODT
  1.  ;
  1.  S X=$$ORD^BLRRLEDI(ORDERN,DFN)   ; Create entry in 9009026.3, if necessary
  1.  ;
  1.  S ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
  1.  Q:ORDIEN<1   ; Quit if Order # NOT in 9009026.3
  1.  ;
  1.  ; Store ICD code(s) into DIAGNOSIS field
  1.  D ADBLRRLO(LRODT,LRSP,LROT)
  1.  Q
  1.  ;
  1. ADBLRRLO(LRODT,LRSP,LROT) ; EP - Add ICD(s) to 9009026.3
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRSP,LROT,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S IEN=LRSP_","_LRODT
  1.  ;
  1.  S F60PTR=+$$GET1^DIQ(69.03,LROT_","_IEN,.01,"I")
  1.  Q:$$REFLABCK(F60PTR,LRODT,LRSP)<1      ; Do nothing if not a Ref Lab test
  1.  ;
  1.  S LRDFN=$$GET1^DIQ(69.01,IEN,.01,"I")
  1.  S ORDERN=$$GET1^DIQ(69.01,IEN,9.5,"I")
  1.  S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
  1.  S X=$$ORD^BLRRLEDI(ORDERN,DFN)    ; Create entry in 9009026.3, if necessary
  1.  ;
  1.  S ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
  1.  Q:ORDIEN<1      ; Quit if Order # NOT in 9009026.3
  1.  ;
  1.  S F60PTR=$$GET1^DIQ(69.03,LROT_","_IEN,.01,"I")
  1.  S IEN=LROT_","_LRSP_","_LRODT
  1.  ;
  1.  S ICD=0
  1.  F  S ICD=$O(^LRO(69,LRODT,1,LRSP,2,LROT,2,ICD))  Q:ICD<1  D
  1.  . S ICDIEN=$$GET1^DIQ(69.05,ICD_","_IEN,.01,"I")
  1.  . ; Skip if UNCODED DIAGNOSIS
  1.  . Q:$$GET1^DIQ(80,ICDIEN,.01)=".9999"!($$GET1^DIQ(80,ICDIEN,.01)="ZZZ.999")
  1.  . ;
  1.  . K FDA,ERRS
  1.  . S FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDIEN
  1.  . S:$L(F60PTR) FDA(9009026.31,"?+1,"_ORDIEN_",",1)=F60PTR      ; IHS/MSC/MKK - LR*5.2*1034
  1.  . D UPDATE^DIE(,"FDA",,"ERRS")
  1.  Q
  1.  ;
  1. REFLABCK(F60PTR,LRODT,LRSP) ; EP - Return 1 if Test is a Reference Lab test, otherwise return 0 (zero)
  1.  NEW ORDLINST,ORDLOC
  1.  ;
  1.  S ORDLOC=+$$GET1^DIQ(69.01,LRSP_","_LRODT,23,"I")    ; Ordering Location
  1.  S ORDLINST=+$$GET1^DIQ(44,ORDLOC,3,"I")              ; Ord Loc's Institution
  1.  ;
  1.  Q $$REFLAB(ORDLINST,F60PTR)      ; IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1. REFLAB(INSTIEN,F60IEN) ; EP - If Test has been MAPPED, return 1 else return 0
  1.  NEW REFLLABS
  1.  ;
  1.  S REFLLABS=+$$GET1^DIQ(9009029,INSTIEN,3001,"I")    ; Reference Lab
  1.  Q:REFLLABS<1 0
  1.  ;
  1.  ; I +$$GET1^DIQ(9009029,INSTIEN,3022) Q $$F629MAP(F60IEN)   ; IHS/MSC/MKK - LR*5.2*1035 - If a LEDI setup, check its Mapped Tests in File 62.9
  1.  I +$$GET1^DIQ(9009029,INSTIEN,3022,"I") Q $$F629MAP(F60IEN)   ; IHS/MSC/MKK - LR*5.2*1039 - If a LEDI setup, check its Mapped Tests in File 62.9 - Need Internal value of field 3022.
  1.  ;
  1.  Q $S(+$O(^BLRRL("ALP",F60IEN,REFLLABS,0)):1,1:0)     ; The "ALP" index must be valid for this to work.
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1. F629MAP(F60IEN) ; EP - Is test mapped in the LAB CONFIGURATION (#62.9) File? (1=YES,0=No)
  1.  NEW IEN,MAPPED
  1.  ;
  1.  S (IEN,MAPPED)=0
  1.  F  S IEN=$O(^LAHM(62.9,IEN))  Q:IEN<1!(MAPPED)  D
  1.  . Q:$$GET1^DIQ(62.9,IEN,.04,"I")<1   ; Don't check if INACTIVE
  1.  . S:+$O(^LAHM(62.9,IEN,60,"B",F60IEN,0)) MAPPED=IEN
  1.  ;
  1.  Q $S(MAPPED:1,1:0)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1035