IBCNEAMI ;DAOU/ESG - IIV AUTO MATCH INPUT TRANSFORM ;06-JUN-2002
;;2.0;INTEGRATED BILLING;**184**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ITAM ; Input Transform Code for the .01 field - auto match value
NEW MSG,MSGNUM,AMHIT,INSNAME
I $L(X)>30 D ERRMSG("Response is too long. 30 characters maximum.") K X G ITAMX
I $L(X)<3 D ERRMSG("Response is too short. 3 characters minimum.") K X G ITAMX
I X["*",$L($TR(X,"*"))<4 D ERRMSG("Wildcarded entries must have at least 4 non-wildcard characters.") K X G ITAMX
;
S X=$$UP^XLFSTR(X) ; make it all uppercase
S X=$$TRIM^XLFSTR(X) ; strip leading & trailing spaces
;
; Translate multiple asterisks into a single asterisk
I X["**" F S X=$P(X,"**",1)_"*"_$P(X,"**",2,999) Q:X'["**"
;
I $G(DIUTIL)="VERIFY FIELDS" G ITAMX
;
I X["*" D
. D ICH(X,1) ; procedure builds a scratch global of hits
. ;
. ; check to see if no hits at all, display message, then quit
. I '$D(^TMP($J,"IBCNEAME ICH")) D Q
.. S MSG(1)=" For your information, no insurance company names or synonyms passed"
.. S MSG(2)=" a pattern match on '"_X_"'."
.. S MSG(3)=""
.. S MSG(1,"F")="!!"
.. DO EN^DDIOL(.MSG)
.. Q
. ;
. ; At this point, we know we got some hits
. S MSG(1)=" For your information, the following insurance company names and"
. S MSG(2)=" synonyms passed a pattern match on '"_X_"':"
. S MSG(3)=""
. S MSG(1,"F")="!!"
. S AMHIT="",MSGNUM=3
. F S AMHIT=$O(^TMP($J,"IBCNEAME ICH",AMHIT)) Q:AMHIT="" D
.. ;
.. ; If the $D at this level is either 1 or 11, then we want to
.. ; display the data. If the $D at this level is a 10, then we
.. ; don't want to display this data at this time.
.. ;
.. I $D(^TMP($J,"IBCNEAME ICH",AMHIT))'=10 D
... S MSGNUM=MSGNUM+1
... S MSG(MSGNUM)=" "_AMHIT
... Q
.. S INSNAME=""
.. F S INSNAME=$O(^TMP($J,"IBCNEAME ICH",AMHIT,INSNAME)) Q:INSNAME="" D
... S MSGNUM=MSGNUM+1
... S MSG(MSGNUM)=" "_AMHIT_" (Synonym for "_INSNAME_")"
... Q
.. Q
. S MSGNUM=MSGNUM+1
. S MSG(MSGNUM)="" ; one more blank line on the screen
. DO EN^DDIOL(.MSG)
. KILL ^TMP($J,"IBCNEAME ICH") ; clean up scratch global
. Q
;
ITAMX ;
Q
;
ITIC ; Input Transform Code for the .02 field - ins company name
; This field must be a valid, active insurance company name
I $L(X)>30 D ERRMSG("Response is too long. 30 characters maximum.") K X G ITICX
S X=$$UP^XLFSTR(X)
S X=$$TRIM^XLFSTR(X)
;
I $G(DIUTIL)="VERIFY FIELDS" G ITICX
;
; Call the IB insurance company lister function
S X=$$DICINS^IBCNBU1(X,1,10)
;
; Make sure the user chose a valid insurance company name
I X=0!(X=-1) D ERRMSG("You must choose a valid insurance company name. Enter ?? for more info.") K X G ITICX
ITICX ;
Q
;
ERRMSG(Z) ; Display an error message
D EN^DDIOL(Z,"","!!")
ERRMSGX ;
Q
;
ICH(AMV,ACTIVE) ; Insurance Company Hits
; This procedure will return a global array of insurance company
; names and synonyms that passed a pattern match of a given
; wildcarded auto-match entry.
;
; Input
; AMV auto match value with *'s
; ACTIVE 0/1 flag indicating to screen for active insurance
; companies (default is 0 - don't screen)
; Output
; ^TMP($J,"IBCNEAME ICH",name) = ""
; ^TMP($J,"IBCNEAME ICH",synonym,name) = ""
;
NEW IBSUB,INSIEN,INSNAME,INSTXT,NOMATCH,SEED,STOP
KILL ^TMP($J,"IBCNEAME ICH")
I AMV'["*" G ICHX ; no wildcard characters
I $L($TR(AMV,"*"))<4 G ICHX ; not enough non-wildcard characters
S ACTIVE=$G(ACTIVE,0) ; active/inactive flag - default 0
;
; build the NOMATCH check
D AMC^IBCNEUT1("INSTXT",AMV,.NOMATCH,0)
;
F IBSUB="B","C" D
. S SEED=$P(AMV,"*",1),INSTXT=""
. I SEED'="" S INSTXT=$O(^DIC(36,IBSUB,SEED),-1)
. F S INSTXT=$O(^DIC(36,IBSUB,INSTXT)) Q:INSTXT="" Q:(SEED'=""&($E(INSTXT,1,$L(SEED))'=SEED)) D
.. I @NOMATCH Q
.. S (INSIEN,STOP)=0 ; loop thru ien's below
.. F S INSIEN=$O(^DIC(36,IBSUB,INSTXT,INSIEN)) Q:'INSIEN D Q:STOP
... I ACTIVE,$P($G(^DIC(36,INSIEN,0)),U,5) Q ; inactive
... I ACTIVE,$P($G(^DIC(36,INSIEN,5)),U,1) Q ; sched. for deletion
... S INSNAME=$P($G(^DIC(36,INSIEN,0)),U,1) Q:INSNAME=""
... ;
... ; If looping thru names, we can stop here
... I IBSUB="B" S ^TMP($J,"IBCNEAME ICH",INSTXT)="",STOP=1 Q
... ;
... ; Looping thru synonyms...keep going
... S ^TMP($J,"IBCNEAME ICH",INSTXT,INSNAME)=""
... Q
.. Q
. Q
ICHX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEAMI 4540 printed Sep 23, 2025@19:50:36 Page 2
IBCNEAMI ;DAOU/ESG - IIV AUTO MATCH INPUT TRANSFORM ;06-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ITAM ; Input Transform Code for the .01 field - auto match value
+1 NEW MSG,MSGNUM,AMHIT,INSNAME
+2 IF $LENGTH(X)>30
DO ERRMSG("Response is too long. 30 characters maximum.")
KILL X
GOTO ITAMX
+3 IF $LENGTH(X)<3
DO ERRMSG("Response is too short. 3 characters minimum.")
KILL X
GOTO ITAMX
+4 IF X["*"
IF $LENGTH($TRANSLATE(X,"*"))<4
DO ERRMSG("Wildcarded entries must have at least 4 non-wildcard characters.")
KILL X
GOTO ITAMX
+5 ;
+6 ; make it all uppercase
SET X=$$UP^XLFSTR(X)
+7 ; strip leading & trailing spaces
SET X=$$TRIM^XLFSTR(X)
+8 ;
+9 ; Translate multiple asterisks into a single asterisk
+10 IF X["**"
FOR
SET X=$PIECE(X,"**",1)_"*"_$PIECE(X,"**",2,999)
if X'["**"
QUIT
+11 ;
+12 IF $GET(DIUTIL)="VERIFY FIELDS"
GOTO ITAMX
+13 ;
+14 IF X["*"
Begin DoDot:1
+15 ; procedure builds a scratch global of hits
DO ICH(X,1)
+16 ;
+17 ; check to see if no hits at all, display message, then quit
+18 IF '$DATA(^TMP($JOB,"IBCNEAME ICH"))
Begin DoDot:2
+19 SET MSG(1)=" For your information, no insurance company names or synonyms passed"
+20 SET MSG(2)=" a pattern match on '"_X_"'."
+21 SET MSG(3)=""
+22 SET MSG(1,"F")="!!"
+23 DO EN^DDIOL(.MSG)
+24 QUIT
End DoDot:2
QUIT
+25 ;
+26 ; At this point, we know we got some hits
+27 SET MSG(1)=" For your information, the following insurance company names and"
+28 SET MSG(2)=" synonyms passed a pattern match on '"_X_"':"
+29 SET MSG(3)=""
+30 SET MSG(1,"F")="!!"
+31 SET AMHIT=""
SET MSGNUM=3
+32 FOR
SET AMHIT=$ORDER(^TMP($JOB,"IBCNEAME ICH",AMHIT))
if AMHIT=""
QUIT
Begin DoDot:2
+33 ;
+34 ; If the $D at this level is either 1 or 11, then we want to
+35 ; display the data. If the $D at this level is a 10, then we
+36 ; don't want to display this data at this time.
+37 ;
+38 IF $DATA(^TMP($JOB,"IBCNEAME ICH",AMHIT))'=10
Begin DoDot:3
+39 SET MSGNUM=MSGNUM+1
+40 SET MSG(MSGNUM)=" "_AMHIT
+41 QUIT
End DoDot:3
+42 SET INSNAME=""
+43 FOR
SET INSNAME=$ORDER(^TMP($JOB,"IBCNEAME ICH",AMHIT,INSNAME))
if INSNAME=""
QUIT
Begin DoDot:3
+44 SET MSGNUM=MSGNUM+1
+45 SET MSG(MSGNUM)=" "_AMHIT_" (Synonym for "_INSNAME_")"
+46 QUIT
End DoDot:3
+47 QUIT
End DoDot:2
+48 SET MSGNUM=MSGNUM+1
+49 ; one more blank line on the screen
SET MSG(MSGNUM)=""
+50 DO EN^DDIOL(.MSG)
+51 ; clean up scratch global
KILL ^TMP($JOB,"IBCNEAME ICH")
+52 QUIT
End DoDot:1
+53 ;
ITAMX ;
+1 QUIT
+2 ;
ITIC ; Input Transform Code for the .02 field - ins company name
+1 ; This field must be a valid, active insurance company name
+2 IF $LENGTH(X)>30
DO ERRMSG("Response is too long. 30 characters maximum.")
KILL X
GOTO ITICX
+3 SET X=$$UP^XLFSTR(X)
+4 SET X=$$TRIM^XLFSTR(X)
+5 ;
+6 IF $GET(DIUTIL)="VERIFY FIELDS"
GOTO ITICX
+7 ;
+8 ; Call the IB insurance company lister function
+9 SET X=$$DICINS^IBCNBU1(X,1,10)
+10 ;
+11 ; Make sure the user chose a valid insurance company name
+12 IF X=0!(X=-1)
DO ERRMSG("You must choose a valid insurance company name. Enter ?? for more info.")
KILL X
GOTO ITICX
ITICX ;
+1 QUIT
+2 ;
ERRMSG(Z) ; Display an error message
+1 DO EN^DDIOL(Z,"","!!")
ERRMSGX ;
+1 QUIT
+2 ;
ICH(AMV,ACTIVE) ; Insurance Company Hits
+1 ; This procedure will return a global array of insurance company
+2 ; names and synonyms that passed a pattern match of a given
+3 ; wildcarded auto-match entry.
+4 ;
+5 ; Input
+6 ; AMV auto match value with *'s
+7 ; ACTIVE 0/1 flag indicating to screen for active insurance
+8 ; companies (default is 0 - don't screen)
+9 ; Output
+10 ; ^TMP($J,"IBCNEAME ICH",name) = ""
+11 ; ^TMP($J,"IBCNEAME ICH",synonym,name) = ""
+12 ;
+13 NEW IBSUB,INSIEN,INSNAME,INSTXT,NOMATCH,SEED,STOP
+14 KILL ^TMP($JOB,"IBCNEAME ICH")
+15 ; no wildcard characters
IF AMV'["*"
GOTO ICHX
+16 ; not enough non-wildcard characters
IF $LENGTH($TRANSLATE(AMV,"*"))<4
GOTO ICHX
+17 ; active/inactive flag - default 0
SET ACTIVE=$GET(ACTIVE,0)
+18 ;
+19 ; build the NOMATCH check
+20 DO AMC^IBCNEUT1("INSTXT",AMV,.NOMATCH,0)
+21 ;
+22 FOR IBSUB="B","C"
Begin DoDot:1
+23 SET SEED=$PIECE(AMV,"*",1)
SET INSTXT=""
+24 IF SEED'=""
SET INSTXT=$ORDER(^DIC(36,IBSUB,SEED),-1)
+25 FOR
SET INSTXT=$ORDER(^DIC(36,IBSUB,INSTXT))
if INSTXT=""
QUIT
if (SEED'=""&($EXTRACT(INSTXT,1,$LENGTH(SEED))'=SEED))
QUIT
Begin DoDot:2
+26 IF @NOMATCH
QUIT
+27 ; loop thru ien's below
SET (INSIEN,STOP)=0
+28 FOR
SET INSIEN=$ORDER(^DIC(36,IBSUB,INSTXT,INSIEN))
if 'INSIEN
QUIT
Begin DoDot:3
+29 ; inactive
IF ACTIVE
IF $PIECE($GET(^DIC(36,INSIEN,0)),U,5)
QUIT
+30 ; sched. for deletion
IF ACTIVE
IF $PIECE($GET(^DIC(36,INSIEN,5)),U,1)
QUIT
+31 SET INSNAME=$PIECE($GET(^DIC(36,INSIEN,0)),U,1)
if INSNAME=""
QUIT
+32 ;
+33 ; If looping thru names, we can stop here
+34 IF IBSUB="B"
SET ^TMP($JOB,"IBCNEAME ICH",INSTXT)=""
SET STOP=1
QUIT
+35 ;
+36 ; Looping thru synonyms...keep going
+37 SET ^TMP($JOB,"IBCNEAME ICH",INSTXT,INSNAME)=""
+38 QUIT
End DoDot:3
if STOP
QUIT
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
ICHX ;
+1 QUIT
+2 ;
