LRUTIL3 ;DALOI/JDB - Lab Utilities ;11/04/11 11:07
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
;CREATE^XUSAP/4677
Q
;
FMERR(ERR,RTN,FDA,TXT,CONFIG,QUIET,MORE,HOOK) ;
; Process a FileMan filing error.
; Stores info into ^TMP(TMPNM,$J,timestamp:seq)
; Purges existing ^TMP entries as needed.
; Displays FM error text and additional text.
; Inputs
; ERR: Name of FileMan error array.
; RTN:<opt> Routine info (ie TAG^RTN).
; FDA:<opt> Name of FileMan FDA array.
; TXT:<byref><opt> Additional error message text.
; : TXT(0) used to indicate if text should be placed above
; : or below the FileMan error text. (0=above<dflt> 1=below)
; CONFIG:<byref><opt> Array for additional config info.
; : CONFIG("CJ"):<opt> Center Justify? 1=yes 0=no <dflt=0>
; : CONFIG("LM"):<opt> Left Margin <dflt=1>
; QUIET:<opt> 1=no screen display 0=Display <dflt=0>
; MORE:<opt> Display "MORE" prompt 0=no 1=yes <dflt=0>
; HOOK:<opt> Executable code to add custom functionality.
;
N NOW,ERRNUM,ZZZFMERR,ZZZMSG,TXTPOS,X,I,FMT,DIERR,TMPNM
S ERR=$G(ERR)
S RTN=$G(RTN)
S FDA=$G(FDA)
S QUIET=$G(QUIET)
S MORE=$G(MORE)
S HOOK=$G(HOOK)
Q:ERR=""
Q:'$D(@ERR) 0
S TMPNM="LRUTIL3-FMERR"
S NOW=$$NOW^XLFDT()
; remove entries older than 1 day
S I=""
F S I=$O(^TMP(TMPNM,$J,I)) Q:'I D ;
. S X=$P(I,":",1)
. I $$FMDIFF^XLFDT(X,NOW,1)'>1 Q
. K ^TMP(TMPNM,$J,I)
;
; add sequence # to end of timestamp
S ERRNUM=$$NOW^XLFDT()_":0"
; increment sequence # if needed
I $D(^TMP(TMPNM,$J,ERRNUM)) D ;
. S X=$P(ERRNUM,":",2)
. S X=X+1
. S ERRNUM=$P(ERRNUM,":",1)_":"_X
;
D MSG^DIALOG("AEHMS",.ZZZFMERR,"","",ERR)
Q:'$D(ZZZFMERR) 0
S ^TMP(TMPNM,$J,ERRNUM,0)=NOW_"^"_DUZ
I RTN'="" S ^TMP(TMPNM,$J,ERRNUM,1)=RTN
M ^TMP(TMPNM,$J,ERRNUM,"FDA")=@FDA
M ^TMP(TMPNM,$J,ERRNUM,"ERR")=@ERR
S X=RTN
D ADDNODE(.ZZZMSG,"A FileMan error occurred"_$S(X'="":" in "_X,1:"")_":")
S TXTPOS=$G(TXT(0))
S TXTPOS=$S(TXTPOS=1:1,1:0)
I 'TXTPOS D ADDNODE(.ZZZMSG,.TXT) S ZZZMSG(1,"F")="$C(7),!!"
K FMT S FMT(1)="!,$C(32,32,32,32)"
D ADDNODE(.ZZZMSG,.ZZZFMERR,.FMT)
K FMT S FMT(0)="!!"
D ADDNODE(.ZZZMSG,"More info available in ^TMP("""_TMPNM_""","_$J_")",.FMT)
I TXTPOS D ADDNODE(.ZZZMSG,.TXT) S ZZZMSG(1,"F")="$C(7),!!"
I '$D(XPDNM) I 'QUIET D EN^DDIOL(.ZZZMSG)
I $D(XPDNM) I 'QUIET D
. D BMES^XPDUTL(" ")
. D MES^LRUTIL2(.ZZZMSG,$G(CONFIG("CJ")),$G(CONFIG("LM")))
;
K ZZZMSG,TXT
I HOOK'="" X HOOK
; Display any text added by external call
I $D(ZZZMSG) D ;
. Q:QUIET
. I '$D(XPDNM) D EN^DDIOL(.ZZZMSG)
. I $D(XPDNM) D MES^LRUTIL2(.ZZZMSG,$G(CONFIG("CJ")),$G(CONFIG("LM")))
;
I 'QUIET I MORE D MORE^LRUTIL($$TRIM^XLFSTR($$CJ^XLFSTR("Press 'ENTER' to continue",$G(IOM,80)," "),"R"," "),1)
Q ERRNUM
;
ADDNODE(ARR,TXT,FMT) ;
; Private helper method for FMERR above.
; Kills the FMT array when done.
; Inputs
; ARR:<byref> Target array (See Outputs)
; TXT:<byval><byref> Text to add to target array.
; FMT:<byref><opt> Format array
; : FMT(1)="!!"
; Outputs
; ARR: The modified array.
N I,J
I $G(TXT)'="" D ;
. S J=$O(ARR("A"),-1)+1
. S ARR(J)=TXT
. I $D(FMT(0)) S ARR(J,"F")=FMT(0)
;
S I=0
F S I=$O(TXT(I)) Q:'I D ;
. S J=$O(ARR("A"),-1)+1
. S ARR(J)=TXT(I)
. I $D(FMT(I)) S ARR(J,"F")=FMT(I)
K FMT
Q
;
PRXYUSR(SUFFIX,CREATE) ;
;CREATE^XUSAP/4677
; Returns IEN of Lab Application Proxy (HL7, POC, TASKMAN) user.
; If Proxy user doesnt exist, will create.
; Inputs
; SUFFIX:"LRLAB," suffix ie HL7, POC, TASKMAN
; CREATE:<opt> Create user when needed? 0=no 1=yes <dflt>=no
; Outputs
; Returns the IEN of the proxy user or 0 with error code+message
;
N IEN,DIC,DA,DIE,SUB,X,I,NAME,ISPRXY,R200
N LRFDA,LRIEN,LRIENS,LRMSG,LRTARG,DIERR
S SUFFIX=$G(SUFFIX)
S CREATE=$G(CREATE)
I "^HL^POC^TASKMAN^"'[("^"_SUFFIX_"^") Q "0^1^Invalid suffix."
S NAME="LRLAB,"_SUFFIX
; Use FIND instead of FIND1 in case there's more than one entry
; so we avoid creating duplicate entries.
K LRTARG,LRMSG,DIERR
D FIND^DIC(200,"","@","X",NAME,"B",,,,"LRTARG","LRMSG")
S X=$G(LRTARG("DILIST",0))
S X=$P(X,"^",1) ;# of matches
I 'X D Q IEN
. I 'CREATE S IEN="0^3^Create not enabled." Q
. I "^LRLAB,HL^LRLAB,POC^LRLAB,TASKMAN^"'[("^"_NAME_"^") S IEN="0^4^Invalid proxy user" Q
. S X=$$CREATE^XUSAP(NAME,"@",)
. I X>0 S IEN=X Q
. S IEN="0^5^$$CREATE error"
;
; Are any of the #200 matches set to "APP PROXY"
S (I,IEN,ISPRXY)=0
F S I=$O(LRTARG("DILIST",2,I)) Q:'I D Q:ISPRXY ;
. N LRTARG2
. S R200=LRTARG("DILIST",2,I)
. K LRMSG,DIERR,LRTARG2
. S X=","_R200_","
. D FIND^DIC(200.07,X,"@","X","APPLICATION PROXY","B",,,,"LRTARG2","LRMSG")
. S X=$G(LRTARG2("DILIST",0))
. S X=$P(X,"^",1) ;# of matches
. Q:'X
. S (IEN,ISPRXY)=R200
;
; Sets #200 entry's field USER CLASS to "APPLICATION PROXY"
; File #200 update approved by Wally Fort (email 03/27/2006)
I 'ISPRXY D ;
. K DIERR
. S SUB="?+1,"_R200_","
. S LRFDA(200.07,SUB,.01)="APPLICATION PROXY"
. S LRFDA(200.07,SUB,2)=1
. D UPDATE^DIE("E","LRFDA","LRIENS","LRMSG")
. I $D(LRMSG) S IEN="0^2^Error while updating entry"
Q IEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUTIL3 5265 printed Dec 13, 2024@02:22:17 Page 2
LRUTIL3 ;DALOI/JDB - Lab Utilities ;11/04/11 11:07
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 ;CREATE^XUSAP/4677
+4 QUIT
+5 ;
FMERR(ERR,RTN,FDA,TXT,CONFIG,QUIET,MORE,HOOK) ;
+1 ; Process a FileMan filing error.
+2 ; Stores info into ^TMP(TMPNM,$J,timestamp:seq)
+3 ; Purges existing ^TMP entries as needed.
+4 ; Displays FM error text and additional text.
+5 ; Inputs
+6 ; ERR: Name of FileMan error array.
+7 ; RTN:<opt> Routine info (ie TAG^RTN).
+8 ; FDA:<opt> Name of FileMan FDA array.
+9 ; TXT:<byref><opt> Additional error message text.
+10 ; : TXT(0) used to indicate if text should be placed above
+11 ; : or below the FileMan error text. (0=above<dflt> 1=below)
+12 ; CONFIG:<byref><opt> Array for additional config info.
+13 ; : CONFIG("CJ"):<opt> Center Justify? 1=yes 0=no <dflt=0>
+14 ; : CONFIG("LM"):<opt> Left Margin <dflt=1>
+15 ; QUIET:<opt> 1=no screen display 0=Display <dflt=0>
+16 ; MORE:<opt> Display "MORE" prompt 0=no 1=yes <dflt=0>
+17 ; HOOK:<opt> Executable code to add custom functionality.
+18 ;
+19 NEW NOW,ERRNUM,ZZZFMERR,ZZZMSG,TXTPOS,X,I,FMT,DIERR,TMPNM
+20 SET ERR=$GET(ERR)
+21 SET RTN=$GET(RTN)
+22 SET FDA=$GET(FDA)
+23 SET QUIET=$GET(QUIET)
+24 SET MORE=$GET(MORE)
+25 SET HOOK=$GET(HOOK)
+26 if ERR=""
QUIT
+27 if '$DATA(@ERR)
QUIT 0
+28 SET TMPNM="LRUTIL3-FMERR"
+29 SET NOW=$$NOW^XLFDT()
+30 ; remove entries older than 1 day
+31 SET I=""
+32 ;
FOR
SET I=$ORDER(^TMP(TMPNM,$JOB,I))
if 'I
QUIT
Begin DoDot:1
+33 SET X=$PIECE(I,":",1)
+34 IF $$FMDIFF^XLFDT(X,NOW,1)'>1
QUIT
+35 KILL ^TMP(TMPNM,$JOB,I)
End DoDot:1
+36 ;
+37 ; add sequence # to end of timestamp
+38 SET ERRNUM=$$NOW^XLFDT()_":0"
+39 ; increment sequence # if needed
+40 ;
IF $DATA(^TMP(TMPNM,$JOB,ERRNUM))
Begin DoDot:1
+41 SET X=$PIECE(ERRNUM,":",2)
+42 SET X=X+1
+43 SET ERRNUM=$PIECE(ERRNUM,":",1)_":"_X
End DoDot:1
+44 ;
+45 DO MSG^DIALOG("AEHMS",.ZZZFMERR,"","",ERR)
+46 if '$DATA(ZZZFMERR)
QUIT 0
+47 SET ^TMP(TMPNM,$JOB,ERRNUM,0)=NOW_"^"_DUZ
+48 IF RTN'=""
SET ^TMP(TMPNM,$JOB,ERRNUM,1)=RTN
+49 MERGE ^TMP(TMPNM,$JOB,ERRNUM,"FDA")=@FDA
+50 MERGE ^TMP(TMPNM,$JOB,ERRNUM,"ERR")=@ERR
+51 SET X=RTN
+52 DO ADDNODE(.ZZZMSG,"A FileMan error occurred"_$SELECT(X'="":" in "_X,1:"")_":")
+53 SET TXTPOS=$GET(TXT(0))
+54 SET TXTPOS=$SELECT(TXTPOS=1:1,1:0)
+55 IF 'TXTPOS
DO ADDNODE(.ZZZMSG,.TXT)
SET ZZZMSG(1,"F")="$C(7),!!"
+56 KILL FMT
SET FMT(1)="!,$C(32,32,32,32)"
+57 DO ADDNODE(.ZZZMSG,.ZZZFMERR,.FMT)
+58 KILL FMT
SET FMT(0)="!!"
+59 DO ADDNODE(.ZZZMSG,"More info available in ^TMP("""_TMPNM_""","_$JOB_")",.FMT)
+60 IF TXTPOS
DO ADDNODE(.ZZZMSG,.TXT)
SET ZZZMSG(1,"F")="$C(7),!!"
+61 IF '$DATA(XPDNM)
IF 'QUIET
DO EN^DDIOL(.ZZZMSG)
+62 IF $DATA(XPDNM)
IF 'QUIET
Begin DoDot:1
+63 DO BMES^XPDUTL(" ")
+64 DO MES^LRUTIL2(.ZZZMSG,$GET(CONFIG("CJ")),$GET(CONFIG("LM")))
End DoDot:1
+65 ;
+66 KILL ZZZMSG,TXT
+67 IF HOOK'=""
XECUTE HOOK
+68 ; Display any text added by external call
+69 ;
IF $DATA(ZZZMSG)
Begin DoDot:1
+70 if QUIET
QUIT
+71 IF '$DATA(XPDNM)
DO EN^DDIOL(.ZZZMSG)
+72 IF $DATA(XPDNM)
DO MES^LRUTIL2(.ZZZMSG,$GET(CONFIG("CJ")),$GET(CONFIG("LM")))
End DoDot:1
+73 ;
+74 IF 'QUIET
IF MORE
DO MORE^LRUTIL($$TRIM^XLFSTR($$CJ^XLFSTR("Press 'ENTER' to continue",$GET(IOM,80)," "),"R"," "),1)
+75 QUIT ERRNUM
+76 ;
ADDNODE(ARR,TXT,FMT) ;
+1 ; Private helper method for FMERR above.
+2 ; Kills the FMT array when done.
+3 ; Inputs
+4 ; ARR:<byref> Target array (See Outputs)
+5 ; TXT:<byval><byref> Text to add to target array.
+6 ; FMT:<byref><opt> Format array
+7 ; : FMT(1)="!!"
+8 ; Outputs
+9 ; ARR: The modified array.
+10 NEW I,J
+11 ;
IF $GET(TXT)'=""
Begin DoDot:1
+12 SET J=$ORDER(ARR("A"),-1)+1
+13 SET ARR(J)=TXT
+14 IF $DATA(FMT(0))
SET ARR(J,"F")=FMT(0)
End DoDot:1
+15 ;
+16 SET I=0
+17 ;
FOR
SET I=$ORDER(TXT(I))
if 'I
QUIT
Begin DoDot:1
+18 SET J=$ORDER(ARR("A"),-1)+1
+19 SET ARR(J)=TXT(I)
+20 IF $DATA(FMT(I))
SET ARR(J,"F")=FMT(I)
End DoDot:1
+21 KILL FMT
+22 QUIT
+23 ;
PRXYUSR(SUFFIX,CREATE) ;
+1 ;CREATE^XUSAP/4677
+2 ; Returns IEN of Lab Application Proxy (HL7, POC, TASKMAN) user.
+3 ; If Proxy user doesnt exist, will create.
+4 ; Inputs
+5 ; SUFFIX:"LRLAB," suffix ie HL7, POC, TASKMAN
+6 ; CREATE:<opt> Create user when needed? 0=no 1=yes <dflt>=no
+7 ; Outputs
+8 ; Returns the IEN of the proxy user or 0 with error code+message
+9 ;
+10 NEW IEN,DIC,DA,DIE,SUB,X,I,NAME,ISPRXY,R200
+11 NEW LRFDA,LRIEN,LRIENS,LRMSG,LRTARG,DIERR
+12 SET SUFFIX=$GET(SUFFIX)
+13 SET CREATE=$GET(CREATE)
+14 IF "^HL^POC^TASKMAN^"'[("^"_SUFFIX_"^")
QUIT "0^1^Invalid suffix."
+15 SET NAME="LRLAB,"_SUFFIX
+16 ; Use FIND instead of FIND1 in case there's more than one entry
+17 ; so we avoid creating duplicate entries.
+18 KILL LRTARG,LRMSG,DIERR
+19 DO FIND^DIC(200,"","@","X",NAME,"B",,,,"LRTARG","LRMSG")
+20 SET X=$GET(LRTARG("DILIST",0))
+21 ;# of matches
SET X=$PIECE(X,"^",1)
+22 IF 'X
Begin DoDot:1
+23 IF 'CREATE
SET IEN="0^3^Create not enabled."
QUIT
+24 IF "^LRLAB,HL^LRLAB,POC^LRLAB,TASKMAN^"'[("^"_NAME_"^")
SET IEN="0^4^Invalid proxy user"
QUIT
+25 SET X=$$CREATE^XUSAP(NAME,"@",)
+26 IF X>0
SET IEN=X
QUIT
+27 SET IEN="0^5^$$CREATE error"
End DoDot:1
QUIT IEN
+28 ;
+29 ; Are any of the #200 matches set to "APP PROXY"
+30 SET (I,IEN,ISPRXY)=0
+31 ;
FOR
SET I=$ORDER(LRTARG("DILIST",2,I))
if 'I
QUIT
Begin DoDot:1
+32 NEW LRTARG2
+33 SET R200=LRTARG("DILIST",2,I)
+34 KILL LRMSG,DIERR,LRTARG2
+35 SET X=","_R200_","
+36 DO FIND^DIC(200.07,X,"@","X","APPLICATION PROXY","B",,,,"LRTARG2","LRMSG")
+37 SET X=$GET(LRTARG2("DILIST",0))
+38 ;# of matches
SET X=$PIECE(X,"^",1)
+39 if 'X
QUIT
+40 SET (IEN,ISPRXY)=R200
End DoDot:1
if ISPRXY
QUIT
+41 ;
+42 ; Sets #200 entry's field USER CLASS to "APPLICATION PROXY"
+43 ; File #200 update approved by Wally Fort (email 03/27/2006)
+44 ;
IF 'ISPRXY
Begin DoDot:1
+45 KILL DIERR
+46 SET SUB="?+1,"_R200_","
+47 SET LRFDA(200.07,SUB,.01)="APPLICATION PROXY"
+48 SET LRFDA(200.07,SUB,2)=1
+49 DO UPDATE^DIE("E","LRFDA","LRIENS","LRMSG")
+50 IF $DATA(LRMSG)
SET IEN="0^2^Error while updating entry"
End DoDot:1
+51 QUIT IEN
