BLRSGNS3 ; IHS/MSC/MKK - Delete Order even though in SiGN or SYmptom Process (Continued) ; 02-Nov-2015 13:45 ; MKK
;;5.2;LR;**1035,1037**;NOV 1, 1997;Build 4
;
; Code moved from BLRSGNSP becuase BLRSGNSP became too large
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
ERRMSG(MSG,ERRFRTN) ; EP - Errors occurred during FILE^DIE call
NEW LRCNT,LRMTXT,MESSAGE,NOWDTIME,ORDERNUM,TAB,WOTARR1,WOTARR2,WOTVAR
NEW IENS ; IHS/MSC/MKK - LR*5.2*1037
;
S TAB=$J("",10)
;
S MSG=$G(MSG,"FileMan Error") ; IHS/MSC/MKK - LR*5.2*1037 - Make sure MSG variable exists
S ERRFRTN=$G(ERRFRTN,"BLRSGNSP") ; Set "ERRor From RouTiNe" Variable
;
S MESSAGE="FileMan DBS call failed in routine "_ERRFRTN_"."
;
S LRMTXT(1)=MSG_" Issue in routine "_ERRFRTN_"."
S LRMTXT(2)=" "
S LRMTXT(3)="The following debugging information is provided to assist"
S LRMTXT(4)="support staff in resolving issue during accessioning."
;
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)
. Q:X="" ; IHS/MSC/MKK - LR*5.2*1037 - Don't do anything if the variable doesn't exist
. ;
. 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
;
; Create ORDERNUM variable, if possible.
S IENS=+$G(LRORT)_","_+$G(LRSP)_","_+$G(LRODT)_"," ; IHS/MSC/MKK - LR*5.2*1037
S ORDERNUM=$$GET1^DIQ(69.01,$P(IENS,",",2,3),"ORDER #")
;
; Store variables
F WOTVAR="DFN","IENS","LRORD","LRODT","LRSP","ORDERNUM","PROBSTR","SNOMED","DESCPROB","ICDCODE","ICDDESC" D
. Q:$G(@WOTARR1)="" ; IHS/MSC/MKK - LR*5.2*1037 - Don't do anything if the variable doesn't exist
. ;
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_WOTVAR_"="_$G(@WOTVAR)
;
F WOTVAR="LRASTEST","LRNEWTST","ORIGPN","ORIGSN","ORIGICDP","ORIGICDI" D
. Q:$G(@WOTARR1)="" ; IHS/MSC/MKK - LR*5.2*1037 - Don't do anything if the variable doesn't exist
. ;
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_WOTVAR_"="_$G(@WOTVAR)
;
I $L($G(INDIC)) S WOTVAR="INDIC",LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_WOTVAR_"="_$G(@WOTVAR)
;
; Store the $STACK as well
S CONTXT=$STACK(-1)
F LOOP=0:1:CONTXT D
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",1,CONTEXT LEVEL)="_LOOP
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",2,CONTEXT TYPE)="_$STACK(LOOP)
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",3,CURRENT PLACE)="_$STACK(LOOP,"PLACE")
. S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",4,CURRENT SOURCE)="_$STACK(LOOP,"MCODE")
;
; D SENDMAIL^BLRUTIL3(.MESSAGE,.LRMTXT,ERRFRTN,1) ; Deliberately commented out. Do Not send MailMan message.
;
; Store messages for 30 days
S NOWDTIME=$$HTFM^XLFDT($H)
I +$P($G(^XTMP(ERRFRTN,0)),"^")'>(+NOWDTIME) D
. K ^XTMP(ERRFRTN)
. K ^XTMP("BLRSGNSP")
. S ^XTMP(ERRFRTN,0)=$$HTFM^XLFDT(+$H+30)_"^"_$$DT^XLFDT_"^Temporary Informational Message Storage"
. S ^XTMP("BLRSGNSP")=$$HTFM^XLFDT(+$H+30)_"^"_$$DT^XLFDT_"^'D' Index for Temporary Informational Message Storage"
;
M ^XTMP(ERRFRTN,NOWDTIME,MSG)=LRMTXT
; S ^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN)=""
S:+$G(ORDERNUM) ^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN)="" ; IHS/MSC/MKK - LR*5.2*1037
Q
;
FIXIT ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)
;
K ^XTMP("BLRSGNSP")
S ERRFRTN="BLRSGN"
F S ERRFRTN=$O(^XTMP(ERRFRTN)) Q:ERRFRTN=""!($E(ERRFRTN,1,6)'="BLRSGN") D
. W "ERRFRTN=",ERRFRTN,!
. S ORDERNUM=0
. F S ORDERNUM=$O(^XTMP(ERRFRTN,"D",ORDERNUM)) Q:ORDERNUM<1 D
.. S NOWDTIME=0
.. F S NOWDTIME=$O(^XTMP(ERRFRTN,"D",ORDERNUM,NOWDTIME)) Q:NOWDTIME<1 D
... S ^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN)=""
;
Q
;
OERRSTSC(ODT,SN) ; EP - Change OERR Status from PENDING to DISCOUNTINUED for entire test
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ODT,SN,U,XPARSYS,XQXFLG)
S CONTROL="OC"
D NEW^LR7OB1(ODT,SN,CONTROL,,,1)
Q
;
OERRSTSO(LRODT,LRSN,LROT) ; EP - Change OERR Status from PENDING to DISCOUNTINUED for specific test(s)
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LROT,LRSN,U,XPARSYS,XQXFLG)
S LROTIEN=LROT_","_LRSN_","_LRODT
S ORIFN=$$GET1^DIQ(69.03,LROTIEN,6)
S F60IEN=$$GET1^DIQ(69.03,.01,LROTIEN,"I")
S II(F60IEN)="",LRSTATUS=1
D NEW^LR7OB1(LRODT,LRSN,"OC",,.II,LRSTATUS)
Q
BLRSGNS3 ; IHS/MSC/MKK - Delete Order even though in SiGN or SYmptom Process (Continued) ; 02-Nov-2015 13:45 ; MKK
+1 ;;5.2;LR;**1035,1037**;NOV 1, 1997;Build 4
+2 ;
+3 ; Code moved from BLRSGNSP becuase BLRSGNSP became too large
+4 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
ERRMSG(MSG,ERRFRTN) ; EP - Errors occurred during FILE^DIE call
+1 NEW LRCNT,LRMTXT,MESSAGE,NOWDTIME,ORDERNUM,TAB,WOTARR1,WOTARR2,WOTVAR
+2 ; IHS/MSC/MKK - LR*5.2*1037
NEW IENS
+3 ;
+4 SET TAB=$JUSTIFY("",10)
+5 ;
+6 ; IHS/MSC/MKK - LR*5.2*1037 - Make sure MSG variable exists
SET MSG=$GET(MSG,"FileMan Error")
+7 ; Set "ERRor From RouTiNe" Variable
SET ERRFRTN=$GET(ERRFRTN,"BLRSGNSP")
+8 ;
+9 SET MESSAGE="FileMan DBS call failed in routine "_ERRFRTN_"."
+10 ;
+11 SET LRMTXT(1)=MSG_" Issue in routine "_ERRFRTN_"."
+12 SET LRMTXT(2)=" "
+13 SET LRMTXT(3)="The following debugging information is provided to assist"
+14 SET LRMTXT(4)="support staff in resolving issue during accessioning."
+15 ;
+16 SET LRMTXT(5)=" "
+17 SET LRCNT=5
+18 ;
+19 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=" DUZ="_$GET(DUZ)
+20 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=" DUZ(2)="_$GET(DUZ(2))
+21 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=" "
+22 ;
+23 ; Store Arrays
+24 FOR WOTARR1="ERRS","FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0"
Begin DoDot:1
+25 SET X=$GET(@WOTARR1)
+26 ; IHS/MSC/MKK - LR*5.2*1037 - Don't do anything if the variable doesn't exist
IF X=""
QUIT
+27 ;
+28 IF X'=""
SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=WOTARR1_"="_X
+29 SET WOTARR2=WOTARR1
+30 FOR
SET WOTARR2=$QUERY(@WOTARR2)
IF WOTARR2=""
QUIT
SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=WOTARR2_"="_@WOTARR2
End DoDot:1
+31 ;
+32 ; Create ORDERNUM variable, if possible.
+33 ; IHS/MSC/MKK - LR*5.2*1037
SET IENS=+$GET(LRORT)_","_+$GET(LRSP)_","_+$GET(LRODT)_","
+34 SET ORDERNUM=$$GET1^DIQ(69.01,$PIECE(IENS,",",2,3),"ORDER #")
+35 ;
+36 ; Store variables
+37 FOR WOTVAR="DFN","IENS","LRORD","LRODT","LRSP","ORDERNUM","PROBSTR","SNOMED","DESCPROB","ICDCODE","ICDDESC"
Begin DoDot:1
+38 ; IHS/MSC/MKK - LR*5.2*1037 - Don't do anything if the variable doesn't exist
IF $GET(@WOTARR1)=""
QUIT
+39 ;
+40 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_WOTVAR_"="_$GET(@WOTVAR)
End DoDot:1
+41 ;
+42 FOR WOTVAR="LRASTEST","LRNEWTST","ORIGPN","ORIGSN","ORIGICDP","ORIGICDI"
Begin DoDot:1
+43 ; IHS/MSC/MKK - LR*5.2*1037 - Don't do anything if the variable doesn't exist
IF $GET(@WOTARR1)=""
QUIT
+44 ;
+45 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_WOTVAR_"="_$GET(@WOTVAR)
End DoDot:1
+46 ;
+47 IF $LENGTH($GET(INDIC))
SET WOTVAR="INDIC"
SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_WOTVAR_"="_$GET(@WOTVAR)
+48 ;
+49 ; Store the $STACK as well
+50 SET CONTXT=$STACK(-1)
+51 FOR LOOP=0:1:CONTXT
Begin DoDot:1
+52 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",1,CONTEXT LEVEL)="_LOOP
+53 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",2,CONTEXT TYPE)="_$STACK(LOOP)
+54 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",3,CURRENT PLACE)="_$STACK(LOOP,"PLACE")
+55 SET LRCNT=LRCNT+1
SET LRMTXT(LRCNT)=TAB_"$STACK("_LOOP_",4,CURRENT SOURCE)="_$STACK(LOOP,"MCODE")
End DoDot:1
+56 ;
+57 ; D SENDMAIL^BLRUTIL3(.MESSAGE,.LRMTXT,ERRFRTN,1) ; Deliberately commented out. Do Not send MailMan message.
+58 ;
+59 ; Store messages for 30 days
+60 SET NOWDTIME=$$HTFM^XLFDT($HOROLOG)
+61 IF +$PIECE($GET(^XTMP(ERRFRTN,0)),"^")'>(+NOWDTIME)
Begin DoDot:1
+62 KILL ^XTMP(ERRFRTN)
+63 KILL ^XTMP("BLRSGNSP")
+64 SET ^XTMP(ERRFRTN,0)=$$HTFM^XLFDT(+$HOROLOG+30)_"^"_$$DT^XLFDT_"^Temporary Informational Message Storage"
+65 SET ^XTMP("BLRSGNSP")=$$HTFM^XLFDT(+$HOROLOG+30)_"^"_$$DT^XLFDT_"^'D' Index for Temporary Informational Message Storage"
End DoDot:1
+66 ;
+67 MERGE ^XTMP(ERRFRTN,NOWDTIME,MSG)=LRMTXT
+68 ; S ^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN)=""
+69 ; IHS/MSC/MKK - LR*5.2*1037
IF +$GET(ORDERNUM)
SET ^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN)=""
+70 QUIT
+71 ;
FIXIT ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)
+2 ;
+3 KILL ^XTMP("BLRSGNSP")
+4 SET ERRFRTN="BLRSGN"
+5 FOR
SET ERRFRTN=$ORDER(^XTMP(ERRFRTN))
IF ERRFRTN=""!($EXTRACT(ERRFRTN,1,6)'="BLRSGN")
QUIT
Begin DoDot:1
+6 WRITE "ERRFRTN=",ERRFRTN,!
+7 SET ORDERNUM=0
+8 FOR
SET ORDERNUM=$ORDER(^XTMP(ERRFRTN,"D",ORDERNUM))
IF ORDERNUM<1
QUIT
Begin DoDot:2
+9 SET NOWDTIME=0
+10 FOR
SET NOWDTIME=$ORDER(^XTMP(ERRFRTN,"D",ORDERNUM,NOWDTIME))
IF NOWDTIME<1
QUIT
Begin DoDot:3
+11 SET ^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;
+13 QUIT
+14 ;
OERRSTSC(ODT,SN) ; EP - Change OERR Status from PENDING to DISCOUNTINUED for entire test
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ODT,SN,U,XPARSYS,XQXFLG)
+2 SET CONTROL="OC"
+3 DO NEW^LR7OB1(ODT,SN,CONTROL,,,1)
+4 QUIT
+5 ;
OERRSTSO(LRODT,LRSN,LROT) ; EP - Change OERR Status from PENDING to DISCOUNTINUED for specific test(s)
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LROT,LRSN,U,XPARSYS,XQXFLG)
+2 SET LROTIEN=LROT_","_LRSN_","_LRODT
+3 SET ORIFN=$$GET1^DIQ(69.03,LROTIEN,6)
+4 SET F60IEN=$$GET1^DIQ(69.03,.01,LROTIEN,"I")
+5 SET II(F60IEN)=""
SET LRSTATUS=1
+6 DO NEW^LR7OB1(LRODT,LRSN,"OC",,.II,LRSTATUS)
+7 QUIT
