BLRSNOMU ; IHS/OIT/MKK - IHS Lab SNOMED Utilities ; 17-Oct-2014 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033,1034**;NOV 1, 1997;Build 88
;
; Requires user to enter free text input so as to retrieve matches from the
; BSTS terminology server.
;
PEP ; EP
EP ; EP
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
; Requried variables are:
; (1) DFN -- Patient Pointer to file 2
; (2) LRORD -- Order Number
; (3) LRODT -- Order Date
;
GETSDIAG(LRORD,LRODT,TESTIEN) ; EP - Get & Store Diagnosis
NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,PNM,HRCN,TESTIEN,U,XPARSYS,XQXFLG)
;
S LRDFN=+$G(^DPT(DFN,"LR"))
;
S PROBSTR=$$TEXTPOVI(DFN)
;
I $L(PROBSTR)<1 D FATALERR Q
;
D STORDIAG
Q
;
TEXTPOVI(DFN) ; EP - Use Text & BSTS Database
NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PNM,U,XPARSYS,XQXFLG)
;
; User MUST enter a diagnosis. No exceptions.
S Y=0
F Q:Y D
. W !!
. D ^XBFMK
. S DIR(0)="F"
. S DIR("A")="Enter Clinical Indication (Free Text)"
. D ^DIR
. I $G(X)="^^^" S Y=99999999 Q ; Trick to exit
. ;
. I $L(X)<1!(+$G(DIRUT)) D Q
.. W !!,?4,"Invalid. Must Enter a Clinical Indication.",!
.. D PRESSKEY^BLRGMENU(9)
.. S Y=0
. K VARS,IN
. S OUT="VARS",IN=$G(X)_"^F^^^^300"
. S Y=$$SEARCH^BSTSAPI(OUT,IN)
. I Y<1 W !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database. Try Again."
;
D:$G(X)="^^^" FATALERR
;
S (NUM,CNT)=0
K ^TMP("BLRSNO"),BLRSNOX
; Call List Manager routine
D EN^BLRSNO
;
;
F S NUM=$O(VARS(NUM)) Q:NUM<1 D
. Q:$L($G(VARS(NUM,"ICD",1,"COD")))<1&($L($G(VARS(NUM,"10D",1,"COD")))<1)
. ;
. S CNT=CNT+1
. ; Setup List Manager Array
. D SET^VALM10(CNT,$J(CNT,3)_" "_$$LJ^XLFSTR($G(VARS(NUM,"FSN","DSC")),14)_$G(VARS(NUM,"FSN","TRM")))
. S BLRSNOX(CNT,NUM)="" ; Build "Cross Reference" Array
;
S VALMCNT=CNT
S MAXSEARCH=$O(VARS("A"),-1)
;
S WHATSEL=0
F Q:+WHATSEL!(BOOM) D
. D MAKEDIR(WHATSEL)
. M TMPDIR=DIR
. ;
K ICDCODES
S (CNT,NUM)=0
F S NUM=$O(VARS(NUM)) Q:NUM<1!(CNT>17) D
. Q:$L($G(VARS(NUM,"ICD",1,"COD")))<1&($L($G(VARS(NUM,"10D",1,"COD")))<1)
. ;
. Q:$L($G(ICDCODES($G(VARS(NUM,"ICD",1,"COD")))))
. S ICDCODES($G(VARS(NUM,"ICD",1,"COD")))=$G(VARS(NUM,"FSN","TRM"))_"^^"_$G(VARS(NUM,"FSN","DSC"))
. S CNT=CNT+1
;
S DIRZERO="S^"
S (CNT,ICDCODE)=0
F S ICDCODE=$O(ICDCODES(ICDCODE)) Q:ICDCODE<1 D
. S ICDDESC=$P($G(ICDCODES(ICDCODE)),"^")
. S SNOMED=$P($G(ICDCODES(ICDCODE)),"^",3)
. S CNT=CNT+1
. S DIRZERO=DIRZERO_CNT_":"_ICDCODE_";"
. S STR=$J(CNT,4)_") "
. S $E(STR,7)=ICDCODE
. S:$G(DEBUG)'="YES" $E(STR,20)=$E(ICDDESC,1,53)
. S:$G(DEBUG)="YES" $E(STR,20)=$E(ICDDESC,1,38),$E(STR,60)=$S(SORTDATE:$$FMTE^XLFDT(SORTDATE,"5DZ"),1:" ")
. S DIRZERO(CNT)=$$LJ^XLFSTR(STR,75)
. S ICDINDEX(CNT)=ICDCODE_"^"_ICDDESC_"^^"_SNOMED
;
D MAKEDIR ; Create DIR array
;
M TMPDIR=DIR ; Allows DIR array to be reset in the following FOR loop
;
; User MUST select an entry. No exceptions.
S Y=0
F Q:Y D
. W !!
. D ^DIR
. I +$G(Y)<1!(+$G(DIRUT)) D
.. W !!,?4,"Invalid. Must Select an Entry.",!
.. D PRESSKEY^BLRGMENU(9)
.. D ^XBFMK
.. S Y=0
.. M DIR=TMPDIR
;
Q $G(ICDINDEX(Y))
;
STORDIAG ; EP - Store the Same ICD code on ALL tests in an order
NEW DESCIEN,ERRS,FDA,ICDIEN,ICDSTR,ICDCODE,ICDDESC,ICDSTR,IENS,LATEST,LRSN,LRTST
;
S ICDCODE=$P(PROBSTR,"^")
S ICDDESC=$P(PROBSTR,"^",2)
S PROVNARR=$P(PROBSTR,"^",3) ; Provider Narrative, if it exists
S:$L(PROVNARR)<1 PROVNARR=ICDDESC ; If it doesn't exist, set to ICD Description
S SNOMED=$P(PROBSTR,"^",4)
;
S LRSN=.9999999
F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 D
. S LRTST=.9999999
. F S LRTST=$O(^LRO(69,LRODT,1,LRSN,2,LRTST)) Q:LRTST<1 D
.. D ^XBFMK
.. K FDA,ERRS,IENS
.. S IENS=LRTST_","_LRSN_","_LRODT_","
.. S FDA(69.03,IENS,9999999.1)=$S($L(PROVNARR):PROVNARR,$L(ICDDESC):ICDDESC,1:" ")
.. S:$L(SNOMED) FDA(69.03,IENS,9999999.2)=SNOMED
.. D FILE^DIE("EKS","FDA","ERRS")
.. I $D(ERRS) D ERRMSG("STORDIAG^BLRSNOMU FILE^DIE")
.. Q:$L(ICDCODE)<1
.. ;
.. K FDA,ERRS
.. S FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
.. D UPDATE^DIE("ES","FDA",,"ERRS")
.. I $D(ERRS) D ERRMSG("STORDIAG^BLRSNOMU UPDATE^DIE")
Q
;
MAKEDIR ; EP - Create DIR array for ICD Codes
D ^XBFMK
S DIR(0)=DIRZERO
S DIR("L",1)="Select Clinical Indication for "_PNM_" ["_HRCN_"]:"
S DIR("L",2)=" "
S DIR("L",3)=" SNOMED SNOMED Description"
; 12345678901234567890123456789012345678901234567890123456789012345678901234567890
S DIR("L",4)=" ----------- ---------------------------------------------------------------"
S BELOW=5
S CNT=0
F S CNT=$O(DIRZERO(CNT)) Q:CNT<1 D
. ; S DIR("L",BELOW)=$J("",2)_$G(DIR("L",BELOW))_DIRZERO(CNT)
. S DIR("L",BELOW)=$G(DIR("L",BELOW))_DIRZERO(CNT)
. S BELOW=BELOW+1
;
S DIR("L")=""
S DIR("A")="Selection"
Q
;
FATALERR ; EP - Hard Crash the process
NEW ROWSTARS,SPACER,SPACERLN,STR,STRLEN
;
S STR="@NO@SIGN@NOR@SYMPTOM!@FORCE@CRASH!@"
S STRLEN=$L(STR)
S SPACER=$TR($J("",STRLEN)," ","@")
S ROWSTARS=$TR($J("",IOM)," ","*")
S SPACERLN=$TR($$CJ^XLFSTR(SPACER,IOM),"@ "," *")
;
D ^XBCLS
W ROWSTARS,!
W ROWSTARS,!
W SPACERLN,!
W $TR($$CJ^XLFSTR(STR,IOM),"@ "," *")
W SPACERLN,!
W ROWSTARS,!
W ROWSTARS,!
;
W !!,"Occurring in " F X=5:-1:1 W X,"..." H 1
;
D ^LRKILL
;
D BIGWORD("BOOM")
W 1/0
Q
;
BIGWORD(LRLTR) ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRLTR,U,XPARSYS,XQXFLG)
;
I '$D(^TMP("LRLTR",$J,"A")) D ^LRLTR2
;
B1 ; EP
S LRLTY=$E(LRLTR,1,6),LRLTX=""
F LRLT1=1:1:$L(LRLTY) I $A(LRLTY,LRLT1)>32,$D(^TMP("LRLTR",$J,$E(LRLTY,LRLT1))) S LRLTX=LRLTX_$E(LRLTY,LRLT1)
D B2
K LRLT1,LRLT2,LRLT3,LRLTX,LRLTY,LRLT,LRJ0,LRJ02 W !
Q
;
B2 ; EP
W !
F LRLT1=9:-1:1 W ! F LRLT3=1:1:$L(LRLTX) S X=^TMP("LRLTR",$J,$E(LRLTX,LRLT3)) W " " F LRLT2=1:1:5 W $S($E(X,(LRLT2-1*9+LRLT1)):"XXX",1:" ")
Q
;
ERRMSG(MSG) ; EP - Error occurred during a DIE call
NEW LRCNT,LRMTXT,MESSAGE,NOWDTIME,TAB,WOTARR1,WOTARR2,WOTVAR
;
S TAB=$J("",10)
;
S MESSAGE="FileMan DBS call failed."
;
S LRMTXT(1)=MSG_" Issue"
S LRMTXT(2)=" "
S LRMTXT(3)="The following debugging information is provided to assist"
S LRMTXT(4)="support staff in resolving the error."
;
S LRMTXT(5)=" "
S LRCNT=5
;
S LRCNT=LRCNT+1,LRMTXT(LRCNT)=" DUZ="_$G(DUZ)
S LRCNT=LRCNT+1,LRMTXT(LRCNT)=" DUZ(2)="_$G(DUZ(2))
S LRCNT=LRCNT+1,LRMTXT(LRCNT)=" "
;
; Store Arrays
F WOTARR1="ERRS","FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
. S X=$G(@WOTARR1)
. I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=WOTARR1_"="_X
. S WOTARR2=WOTARR1
. F S WOTARR2=$Q(@WOTARR2) Q:WOTARR2="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=WOTARR2_"="_@WOTARR2
;
; Store variables
F WOTVAR="DFN","LRORD","LRODT","LRSP","PROBSTR","SNOMED","DESCPROB","ICDCODE","ICDDESC" D
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_WOTVAR_"="_$G(@WOTVAR)
;
; D MAILALMI^BLRUTIL3(.MESSAGE,.LRMTXT,"BLRSNOMU",1)
;
; Store errors for 30 days
S NOWDTIME=$$HTFM^XLFDT($H)
I +$P($G(^XTMP("BLRSNOMU",0)),"^")'>(+NOWDTIME) D
. K ^XTMP("BLRSNOMU")
. S ^XTMP("BLRSNOMU",0)=$$HTFM^XLFDT(+$H+30)_"^"_$$DT^XLFDT_"^Temporary Error Message Storage for BLRSNOMU routine"
;
M ^XTMP("BLRSNOMU",NOWDTIME,MSG)=LRMTXT
Q
BLRSNOMU ; IHS/OIT/MKK - IHS Lab SNOMED Utilities ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033,1034**;NOV 1, 1997;Build 88
+2 ;
+3 ; Requires user to enter free text input so as to retrieve matches from the
+4 ; BSTS terminology server.
+5 ;
PEP ; EP
EP ; EP
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; Requried variables are:
+5 ; (1) DFN -- Patient Pointer to file 2
+6 ; (2) LRORD -- Order Number
+7 ; (3) LRODT -- Order Date
+8 ;
GETSDIAG(LRORD,LRODT,TESTIEN) ; EP - Get & Store Diagnosis
+1 NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,PNM,HRCN,TESTIEN,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRDFN=+$GET(^DPT(DFN,"LR"))
+4 ;
+5 SET PROBSTR=$$TEXTPOVI(DFN)
+6 ;
+7 IF $LENGTH(PROBSTR)<1
DO FATALERR
QUIT
+8 ;
+9 DO STORDIAG
+10 QUIT
+11 ;
TEXTPOVI(DFN) ; EP - Use Text & BSTS Database
+1 NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PNM,U,XPARSYS,XQXFLG)
+2 ;
+3 ; User MUST enter a diagnosis. No exceptions.
+4 SET Y=0
+5 FOR
IF Y
QUIT
Begin DoDot:1
+6 WRITE !!
+7 DO ^XBFMK
+8 SET DIR(0)="F"
+9 SET DIR("A")="Enter Clinical Indication (Free Text)"
+10 DO ^DIR
+11 ; Trick to exit
IF $GET(X)="^^^"
SET Y=99999999
QUIT
+12 ;
+13 IF $LENGTH(X)<1!(+$GET(DIRUT))
Begin DoDot:2
+14 WRITE !!,?4,"Invalid. Must Enter a Clinical Indication.",!
+15 DO PRESSKEY^BLRGMENU(9)
+16 SET Y=0
End DoDot:2
QUIT
+17 KILL VARS,IN
+18 SET OUT="VARS"
SET IN=$GET(X)_"^F^^^^300"
+19 SET Y=$$SEARCH^BSTSAPI(OUT,IN)
+20 IF Y<1
WRITE !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database. Try Again."
End DoDot:1
+21 ;
+22 IF $GET(X)="^^^"
DO FATALERR
+23 ;
+24 SET (NUM,CNT)=0
+25 KILL ^TMP("BLRSNO"),BLRSNOX
+26 ; Call List Manager routine
+27 DO EN^BLRSNO
+28 ;
+29 ;
+30 FOR
SET NUM=$ORDER(VARS(NUM))
IF NUM<1
QUIT
Begin DoDot:1
+31 IF $LENGTH($GET(VARS(NUM,"ICD",1,"COD")))<1&($LENGTH($GET(VARS(NUM,"10D",1,"COD")))<1)
QUIT
+32 ;
+33 SET CNT=CNT+1
+34 ; Setup List Manager Array
+35 DO SET^VALM10(CNT,$JUSTIFY(CNT,3)_" "_$$LJ^XLFSTR($GET(VARS(NUM,"FSN","DSC")),14)_$GET(VARS(NUM,"FSN","TRM")))
+36 ; Build "Cross Reference" Array
SET BLRSNOX(CNT,NUM)=""
End DoDot:1
+37 ;
+38 SET VALMCNT=CNT
+39 SET MAXSEARCH=$ORDER(VARS("A"),-1)
+40 ;
+41 SET WHATSEL=0
+42 FOR
IF +WHATSEL!(BOOM)
QUIT
Begin DoDot:1
+43 DO MAKEDIR(WHATSEL)
+44 MERGE TMPDIR=DIR
+45 ;
End DoDot:1
+46 KILL ICDCODES
+47 SET (CNT,NUM)=0
+48 FOR
SET NUM=$ORDER(VARS(NUM))
IF NUM<1!(CNT>17)
QUIT
Begin DoDot:1
+49 IF $LENGTH($GET(VARS(NUM,"ICD",1,"COD")))<1&($LENGTH($GET(VARS(NUM,"10D",1,"COD")))<1)
QUIT
+50 ;
+51 IF $LENGTH($GET(ICDCODES($GET(VARS(NUM,"ICD",1,"COD")))))
QUIT
+52 SET ICDCODES($GET(VARS(NUM,"ICD",1,"COD")))=$GET(VARS(NUM,"FSN","TRM"))_"^^"_$GET(VARS(NUM,"FSN","DSC"))
+53 SET CNT=CNT+1
End DoDot:1
+54 ;
+55 SET DIRZERO="S^"
+56 SET (CNT,ICDCODE)=0
+57 FOR
SET ICDCODE=$ORDER(ICDCODES(ICDCODE))
IF ICDCODE<1
QUIT
Begin DoDot:1
+58 SET ICDDESC=$PIECE($GET(ICDCODES(ICDCODE)),"^")
+59 SET SNOMED=$PIECE($GET(ICDCODES(ICDCODE)),"^",3)
+60 SET CNT=CNT+1
+61 SET DIRZERO=DIRZERO_CNT_":"_ICDCODE_";"
+62 SET STR=$JUSTIFY(CNT,4)_") "
+63 SET $EXTRACT(STR,7)=ICDCODE
+64 IF $GET(DEBUG)'="YES"
SET $EXTRACT(STR,20)=$EXTRACT(ICDDESC,1,53)
+65 IF $GET(DEBUG)="YES"
SET $EXTRACT(STR,20)=$EXTRACT(ICDDESC,1,38)
SET $EXTRACT(STR,60)=$SELECT(SORTDATE:$$FMTE^XLFDT(SORTDATE,"5DZ"),1:" ")
+66 SET DIRZERO(CNT)=$$LJ^XLFSTR(STR,75)
+67 SET ICDINDEX(CNT)=ICDCODE_"^"_ICDDESC_"^^"_SNOMED
End DoDot:1
+68 ;
+69 ; Create DIR array
DO MAKEDIR
+70 ;
+71 ; Allows DIR array to be reset in the following FOR loop
MERGE TMPDIR=DIR
+72 ;
+73 ; User MUST select an entry. No exceptions.
+74 SET Y=0
+75 FOR
IF Y
QUIT
Begin DoDot:1
+76 WRITE !!
+77 DO ^DIR
+78 IF +$GET(Y)<1!(+$GET(DIRUT))
Begin DoDot:2
+79 WRITE !!,?4,"Invalid. Must Select an Entry.",!
+80 DO PRESSKEY^BLRGMENU(9)
+81 DO ^XBFMK
+82 SET Y=0
+83 MERGE DIR=TMPDIR
End DoDot:2
End DoDot:1
+84 ;
+85 QUIT $GET(ICDINDEX(Y))
+86 ;
STORDIAG ; EP - Store the Same ICD code on ALL tests in an order
+1 NEW DESCIEN,ERRS,FDA,ICDIEN,ICDSTR,ICDCODE,ICDDESC,ICDSTR,IENS,LATEST,LRSN,LRTST
+2 ;
+3 SET ICDCODE=$PIECE(PROBSTR,"^")
+4 SET ICDDESC=$PIECE(PROBSTR,"^",2)
+5 ; Provider Narrative, if it exists
SET PROVNARR=$PIECE(PROBSTR,"^",3)
+6 ; If it doesn't exist, set to ICD Description
IF $LENGTH(PROVNARR)<1
SET PROVNARR=ICDDESC
+7 SET SNOMED=$PIECE(PROBSTR,"^",4)
+8 ;
+9 SET LRSN=.9999999
+10 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
IF LRSN<1
QUIT
Begin DoDot:1
+11 SET LRTST=.9999999
+12 FOR
SET LRTST=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTST))
IF LRTST<1
QUIT
Begin DoDot:2
+13 DO ^XBFMK
+14 KILL FDA,ERRS,IENS
+15 SET IENS=LRTST_","_LRSN_","_LRODT_","
+16 SET FDA(69.03,IENS,9999999.1)=$SELECT($LENGTH(PROVNARR):PROVNARR,$LENGTH(ICDDESC):ICDDESC,1:" ")
+17 IF $LENGTH(SNOMED)
SET FDA(69.03,IENS,9999999.2)=SNOMED
+18 DO FILE^DIE("EKS","FDA","ERRS")
+19 IF $DATA(ERRS)
DO ERRMSG("STORDIAG^BLRSNOMU FILE^DIE")
+20 IF $LENGTH(ICDCODE)<1
QUIT
+21 ;
+22 KILL FDA,ERRS
+23 SET FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
+24 DO UPDATE^DIE("ES","FDA",,"ERRS")
+25 IF $DATA(ERRS)
DO ERRMSG("STORDIAG^BLRSNOMU UPDATE^DIE")
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
MAKEDIR ; EP - Create DIR array for ICD Codes
+1 DO ^XBFMK
+2 SET DIR(0)=DIRZERO
+3 SET DIR("L",1)="Select Clinical Indication for "_PNM_" ["_HRCN_"]:"
+4 SET DIR("L",2)=" "
+5 SET DIR("L",3)=" SNOMED SNOMED Description"
+6 ; 12345678901234567890123456789012345678901234567890123456789012345678901234567890
+7 SET DIR("L",4)=" ----------- ---------------------------------------------------------------"
+8 SET BELOW=5
+9 SET CNT=0
+10 FOR
SET CNT=$ORDER(DIRZERO(CNT))
IF CNT<1
QUIT
Begin DoDot:1
+11 ; S DIR("L",BELOW)=$J("",2)_$G(DIR("L",BELOW))_DIRZERO(CNT)
+12 SET DIR("L",BELOW)=$GET(DIR("L",BELOW))_DIRZERO(CNT)
+13 SET BELOW=BELOW+1
End DoDot:1
+14 ;
+15 SET DIR("L")=""
+16 SET DIR("A")="Selection"
+17 QUIT
+18 ;
FATALERR ; EP - Hard Crash the process
+1 NEW ROWSTARS,SPACER,SPACERLN,STR,STRLEN
+2 ;
+3 SET STR="@NO@SIGN@NOR@SYMPTOM!@FORCE@CRASH!@"
+4 SET STRLEN=$LENGTH(STR)
+5 SET SPACER=$TRANSLATE($JUSTIFY("",STRLEN)," ","@")
+6 SET ROWSTARS=$TRANSLATE($JUSTIFY("",IOM)," ","*")
+7 SET SPACERLN=$TRANSLATE($$CJ^XLFSTR(SPACER,IOM),"@ "," *")
+8 ;
+9 DO ^XBCLS
+10 WRITE ROWSTARS,!
+11 WRITE ROWSTARS,!
+12 WRITE SPACERLN,!
+13 WRITE $TRANSLATE($$CJ^XLFSTR(STR,IOM),"@ "," *")
+14 WRITE SPACERLN,!
+15 WRITE ROWSTARS,!
+16 WRITE ROWSTARS,!
+17 ;
+18 WRITE !!,"Occurring in "
FOR X=5:-1:1
WRITE X,"..."
HANG 1
+19 ;
+20 DO ^LRKILL
+21 ;
+22 DO BIGWORD("BOOM")
+23 WRITE 1/0
+24 QUIT
+25 ;
BIGWORD(LRLTR) ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRLTR,U,XPARSYS,XQXFLG)
+2 ;
+3 IF '$DATA(^TMP("LRLTR",$JOB,"A"))
DO ^LRLTR2
+4 ;
B1 ; EP
+1 SET LRLTY=$EXTRACT(LRLTR,1,6)
SET LRLTX=""
+2 FOR LRLT1=1:1:$LENGTH(LRLTY)
IF $ASCII(LRLTY,LRLT1)>32
IF $DATA(^TMP("LRLTR",$JOB,$EXTRACT(LRLTY,LRLT1)))
SET LRLTX=LRLTX_$EXTRACT(LRLTY,LRLT1)
+3 DO B2
+4 KILL LRLT1,LRLT2,LRLT3,LRLTX,LRLTY,LRLT,LRJ0,LRJ02
WRITE !
+5 QUIT
+6 ;
B2 ; EP
+1 WRITE !
+2 FOR LRLT1=9:-1:1
WRITE !
FOR LRLT3=1:1:$LENGTH(LRLTX)
SET X=^TMP("LRLTR",$JOB,$EXTRACT(LRLTX,LRLT3))
WRITE " "
FOR LRLT2=1:1:5
WRITE $SELECT($EXTRACT(X,(LRLT2-1*9+LRLT1)):"XXX",1:" ")
+3 QUIT
+4 ;
ERRMSG(MSG) ; EP - Error occurred during a DIE call
+1 NEW LRCNT,LRMTXT,MESSAGE,NOWDTIME,TAB,WOTARR1,WOTARR2,WOTVAR
+2 ;
+3 SET TAB=$JUSTIFY("",10)
+4 ;
+5 SET MESSAGE="FileMan DBS call failed."
+6 ;
+7 SET LRMTXT(1)=MSG_" Issue"
+8 SET LRMTXT(2)=" "
+9 SET LRMTXT(3)="The following debugging information is provided to assist"
+10 SET LRMTXT(4)="support staff in resolving the error."
+11 ;
+12 SET LRMTXT(5)=" "
+13 SET LRCNT=5
+14 ;
+15 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=" DUZ="_$GET(DUZ)
+16 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=" DUZ(2)="_$GET(DUZ(2))
+17 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=" "
+18 ;
+19 ; Store Arrays
+20 FOR WOTARR1="ERRS","FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0"
Begin DoDot:1
+21 SET X=$GET(@WOTARR1)
+22 IF X'=""
SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=WOTARR1_"="_X
+23 SET WOTARR2=WOTARR1
+24 FOR
SET WOTARR2=$QUERY(@WOTARR2)
IF WOTARR2=""
QUIT
SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=WOTARR2_"="_@WOTARR2
End DoDot:1
+25 ;
+26 ; Store variables
+27 FOR WOTVAR="DFN","LRORD","LRODT","LRSP","PROBSTR","SNOMED","DESCPROB","ICDCODE","ICDDESC"
Begin DoDot:1
+28 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_WOTVAR_"="_$GET(@WOTVAR)
End DoDot:1
+29 ;
+30 ; D MAILALMI^BLRUTIL3(.MESSAGE,.LRMTXT,"BLRSNOMU",1)
+31 ;
+32 ; Store errors for 30 days
+33 SET NOWDTIME=$$HTFM^XLFDT($HOROLOG)
+34 IF +$PIECE($GET(^XTMP("BLRSNOMU",0)),"^")'>(+NOWDTIME)
Begin DoDot:1
+35 KILL ^XTMP("BLRSNOMU")
+36 SET ^XTMP("BLRSNOMU",0)=$$HTFM^XLFDT(+$HOROLOG+30)_"^"_$$DT^XLFDT_"^Temporary Error Message Storage for BLRSNOMU routine"
End DoDot:1
+37 ;
+38 MERGE ^XTMP("BLRSNOMU",NOWDTIME,MSG)=LRMTXT
+39 QUIT
