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