- 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