IBCNEUT6 ;DAOU/ESG - IIV MISC. UTILITIES ;14-AUG-2002
;;2.0;INTEGRATED BILLING;**184,252,271,566,668,687**;21-MAR-94;Build 88
;;Per VA Directive 6402, this routine should not be modified.
;
; Can't be called from the top
;
; IA 10076 - To access ^XUSEC global for security key check
Q
;
AMCHECK ; This procedure will examine the insurance company names in the
; Auto Match file (#365.11) to make sure there is still at least
; one active insurance company with that name. If there isn't,
; then the Auto Match entries for that insurance company name
; will be deleted.
;
NEW NAME,INSIEN,FOUNDACT,DA,DIK,DIC,X,Y,%
S NAME=""
F S NAME=$O(^IBCN(365.11,"C",NAME)) Q:NAME="" D
. ;
. ; For this Auto Match ins co name, see if there is an active ins co
. S INSIEN=0,FOUNDACT=0
. F S INSIEN=$O(^DIC(36,"B",NAME,INSIEN)) Q:'INSIEN I $$ACTIVE^IBCNEUT4(INSIEN) S FOUNDACT=1 Q
. ;
. ; If an active ins co was found, then we're OK so quit
. I FOUNDACT Q
. ;
. ; Otherwise, we need to delete all Auto Match entries for this name
. S DA=0,DIK="^IBCN(365.11,"
. F S DA=$O(^IBCN(365.11,"C",NAME,DA)) Q:'DA D ^DIK
. Q
AMCHKX ;
Q
;
;
AMADD(INSNAME,IBCNEXT1) ; Conditionally add an Auto Match entry based on user input
; Input Parameters:
; INSNAME is a valid, active insurance company name
; IBCNEXT1 is the existing entry in the ins co name field in the
; buffer. This may be used as the Auto Match value for
; a new auto match entry.
;
NEW AMDATA,AMIEN,AMERROR
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
NEW D,D0,D1,DA,DB,DC,DDH,DE,DG,DH,DI,DIC,DIE,DIEL,DIFLD,DIG,DIH
NEW DIK,DILN,DIPA,DISYS,DIV,DK,DL,DM,DN,DOV,DP,DQ,DR,DU,DV,DZ
;
;/vd-IB*2.0*687 - Changed the following line to address the renaming of the Security Key.
;I '$$KCHK^XUSRB("IBCNE EIV MAINTENANCE") G AMADDX
I '$D(^XUSEC("IBCNE EIV IIU MAINTENANCE",DUZ)) G AMADDX ;IA 10076
;
S IBCNEXT1=$$UP^XLFSTR(IBCNEXT1) ; all uppercase
S IBCNEXT1=$$TRIM^XLFSTR(IBCNEXT1) ; lead/trail spaces
I IBCNEXT1="" G AMADDX ; must exist
I $L(IBCNEXT1)>30!($L(IBCNEXT1)<3) G AMADDX ; too long or too short
I IBCNEXT1=INSNAME G AMADDX ; cannot equal the name
I $D(^IBCN(365.11,"B",IBCNEXT1)) G AMADDX ; already in Auto Match
I $D(^DIC(36,"B",IBCNEXT1)) G AMADDX ; already an ins co name
I $D(^DIC(36,"C",IBCNEXT1)) G AMADDX ; already a synonym
I IBCNEXT1["*" G AMADDX ; no wildcards allowed
;
S DIR(0)="YO"
S DIR("A",1)=" "
S DIR("A",2)="Do you want to add an Auto Match entry that associates"
S DIR("A")=IBCNEXT1_" with "_INSNAME
S DIR("B")="No"
S DIR("?",1)=" The Auto Match Value is "_IBCNEXT1_"."
S DIR("?",2)="The Insurance Company Name is "_INSNAME_"."
S DIR("?",3)=" "
S DIR("?",4)="Please enter NO if you do not want to associate these two values together"
S DIR("?",5)="in the Auto Match file."
S DIR("?",6)=" "
S DIR("?",7)="Please enter YES if you do want to create an Auto Match entry for these"
S DIR("?",8)="two values. If you enter YES, then you will have the chance to modify"
S DIR("?")="the Auto Match Value."
D ^DIR K DIR
D EN^DDIOL(,,"!!")
;
; If user didn't say Yes, then we exit
I 'Y G AMADDX
; To allow for edits to the .01 field and not the .02 field,
; Add this new entry first and then edit only the .01 field.
S AMDATA(365.11,"+1,",.01)=IBCNEXT1
S AMDATA(365.11,"+1,",.02)=INSNAME
S AMDATA(365.11,"+1,",.03)=$$NOW^XLFDT
S AMDATA(365.11,"+1,",.04)=DUZ
S AMDATA(365.11,"+1,",.05)=$$NOW^XLFDT
S AMDATA(365.11,"+1,",.06)=DUZ
S AMDATA(365.11,"+1,",.07)=IBCNEXT1
S AMDATA(365.11,"+1,",.08)=INSNAME
D UPDATE^DIE("","AMDATA","AMIEN","AMERROR")
;
I $D(AMERROR) G AMADDX ; FileMan error so get out
S AMIEN=+$G(AMIEN(1)) ; internal entry number created
I 'AMIEN G AMADDX ; if IEN not there get out
;
; Here we have to edit the entry to allow for the opportunity to
; change something
S DIE=365.11,DA=AMIEN,DR=".01;.05////"_$$NOW^XLFDT_";.06////"_DUZ
D ^DIE
;
; Display the confirmation message to the user
S AMDATA=$G(^IBCN(365.11,AMIEN,0))
I AMDATA'="" D EN^DDIOL($P(AMDATA,U,1)_" is now associated with "_$P(AMDATA,U,2)_".",,"!!?3")
D EN^DDIOL(,,"!!")
AMADDX ;
Q
;
PYRFLTR() ;
; Function to assist with filtering items in custom payer
; lookups for most popular list. This logic is used in the
; DIC("S") definition for the lookup
;
;IB*2.0*668/TAZ - This functionality is no longer used and will be removed with a future User Story.
Q 0
;
NEW IBDATA,IBPIEN,IBPNM,IBAIEN,IBADATA,OK
;
S OK=1
;
S IBDATA=^(0) ; Naked reference from DIC call
S IBPIEN=$G(Y) I IBPIEN="" S OK=0 G XPFLTR
;
; Set Payer Name and IEN
S IBPNM=$P(IBDATA,U,1) I IBPNM="" S OK=0 G XPFLTR
;
; Set Payer Application IEN (365.13)
; Quit if IIV not defined for payer
S IBAIEN=$$PYRAPP^IBCNEUT5("IIV",IBPIEN) I IBAIEN="" S OK=0 G XPFLTR
;
; Get IIV application specific data
S IBADATA=$G(^IBE(365.12,IBPIEN,1,IBAIEN,0)) I IBADATA="" S OK=0 G XPFLTR
;
; Filter if Deactivated
I +$P(IBADATA,U,11) S OK=0 G XPFLTR
;
; Filter if ID Inq Req ID and SSN is not ID
I +$P(IBADATA,U,8),'$P(IBADATA,U,9) S OK=0 G XPFLTR
;
; Filter if already in the list
I $D(^TMP($J,"IBJPI3-IENS",IBPIEN)) S OK=0 G XPFLTR
;
XPFLTR Q OK
;
DSPLINE() ;
; Format display text for custom Most Pop. payer lookup
;
N ITEMDATA,DISPSTR,IBAIEN,IBADATA,PYRIEN,PADLEN
;
; Initialize the data for the item to be displayed
; Naked reference is referencing the DIC data
S ITEMDATA=^(0)
;
; Initialize Display string
S DISPSTR=""
;
; Payer IEN is passed from DIC as Y
S PYRIEN=+$G(Y) I 'PYRIEN G EXDSP
;
; Set Payer Application IEN (365.13)
S IBAIEN=$$PYRAPP^IBCNEUT5("IIV",PYRIEN) I IBAIEN="" G EXDSP
;
; Get IIV Application specific data
S IBADATA=$G(^IBE(365.12,PYRIEN,1,IBAIEN,0)) I IBADATA="" G EXDSP
;
; Pad start of display data, adjusting for payer name length
S PADLEN=$L($E($P($G(ITEMDATA),U),1,30))
S DISPSTR=DISPSTR_$$FO^IBCNEUT1("",31-PADLEN,"L")
;
; Add National and Local active flags
S DISPSTR=DISPSTR_" National: "_$$FO^IBCNEUT1($S('$P(IBADATA,U,2):"Inactive",1:"Active"),8)
S DISPSTR=DISPSTR_" Local: "_$$FO^IBCNEUT1($S('$P(IBADATA,U,3):"Inactive",1:"Active"),8)
EXDSP ;
Q DISPSTR
;
;/vd-IB*2.0*687 - Added the following module of code for use by input templates
CKAPS(IBPYR) ; Utility allow only for Payers that are active and have a valid IIV
; and/or IIU Payer application.
; OUTPUT:
; 0 = Not a valid Payer
; 1 = Valid Payer (Active and has either an IIV or IIU Payer Application)
Q:'IBPYR 0
I '$$PYRAPP^IBCNEUT5("EIV",+IBPYR),'$$PYRAPP^IBCNEUT5("IIU",+IBPYR) Q 0 ; Invalid Payer Application.
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEUT6 6954 printed Dec 13, 2024@02:15:35 Page 2
IBCNEUT6 ;DAOU/ESG - IIV MISC. UTILITIES ;14-AUG-2002
+1 ;;2.0;INTEGRATED BILLING;**184,252,271,566,668,687**;21-MAR-94;Build 88
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Can't be called from the top
+5 ;
+6 ; IA 10076 - To access ^XUSEC global for security key check
+7 QUIT
+8 ;
AMCHECK ; This procedure will examine the insurance company names in the
+1 ; Auto Match file (#365.11) to make sure there is still at least
+2 ; one active insurance company with that name. If there isn't,
+3 ; then the Auto Match entries for that insurance company name
+4 ; will be deleted.
+5 ;
+6 NEW NAME,INSIEN,FOUNDACT,DA,DIK,DIC,X,Y,%
+7 SET NAME=""
+8 FOR
SET NAME=$ORDER(^IBCN(365.11,"C",NAME))
if NAME=""
QUIT
Begin DoDot:1
+9 ;
+10 ; For this Auto Match ins co name, see if there is an active ins co
+11 SET INSIEN=0
SET FOUNDACT=0
+12 FOR
SET INSIEN=$ORDER(^DIC(36,"B",NAME,INSIEN))
if 'INSIEN
QUIT
IF $$ACTIVE^IBCNEUT4(INSIEN)
SET FOUNDACT=1
QUIT
+13 ;
+14 ; If an active ins co was found, then we're OK so quit
+15 IF FOUNDACT
QUIT
+16 ;
+17 ; Otherwise, we need to delete all Auto Match entries for this name
+18 SET DA=0
SET DIK="^IBCN(365.11,"
+19 FOR
SET DA=$ORDER(^IBCN(365.11,"C",NAME,DA))
if 'DA
QUIT
DO ^DIK
+20 QUIT
End DoDot:1
AMCHKX ;
+1 QUIT
+2 ;
+3 ;
AMADD(INSNAME,IBCNEXT1) ; Conditionally add an Auto Match entry based on user input
+1 ; Input Parameters:
+2 ; INSNAME is a valid, active insurance company name
+3 ; IBCNEXT1 is the existing entry in the ins co name field in the
+4 ; buffer. This may be used as the Auto Match value for
+5 ; a new auto match entry.
+6 ;
+7 NEW AMDATA,AMIEN,AMERROR
+8 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+9 NEW D,D0,D1,DA,DB,DC,DDH,DE,DG,DH,DI,DIC,DIE,DIEL,DIFLD,DIG,DIH
+10 NEW DIK,DILN,DIPA,DISYS,DIV,DK,DL,DM,DN,DOV,DP,DQ,DR,DU,DV,DZ
+11 ;
+12 ;/vd-IB*2.0*687 - Changed the following line to address the renaming of the Security Key.
+13 ;I '$$KCHK^XUSRB("IBCNE EIV MAINTENANCE") G AMADDX
+14 ;IA 10076
IF '$DATA(^XUSEC("IBCNE EIV IIU MAINTENANCE",DUZ))
GOTO AMADDX
+15 ;
+16 ; all uppercase
SET IBCNEXT1=$$UP^XLFSTR(IBCNEXT1)
+17 ; lead/trail spaces
SET IBCNEXT1=$$TRIM^XLFSTR(IBCNEXT1)
+18 ; must exist
IF IBCNEXT1=""
GOTO AMADDX
+19 ; too long or too short
IF $LENGTH(IBCNEXT1)>30!($LENGTH(IBCNEXT1)<3)
GOTO AMADDX
+20 ; cannot equal the name
IF IBCNEXT1=INSNAME
GOTO AMADDX
+21 ; already in Auto Match
IF $DATA(^IBCN(365.11,"B",IBCNEXT1))
GOTO AMADDX
+22 ; already an ins co name
IF $DATA(^DIC(36,"B",IBCNEXT1))
GOTO AMADDX
+23 ; already a synonym
IF $DATA(^DIC(36,"C",IBCNEXT1))
GOTO AMADDX
+24 ; no wildcards allowed
IF IBCNEXT1["*"
GOTO AMADDX
+25 ;
+26 SET DIR(0)="YO"
+27 SET DIR("A",1)=" "
+28 SET DIR("A",2)="Do you want to add an Auto Match entry that associates"
+29 SET DIR("A")=IBCNEXT1_" with "_INSNAME
+30 SET DIR("B")="No"
+31 SET DIR("?",1)=" The Auto Match Value is "_IBCNEXT1_"."
+32 SET DIR("?",2)="The Insurance Company Name is "_INSNAME_"."
+33 SET DIR("?",3)=" "
+34 SET DIR("?",4)="Please enter NO if you do not want to associate these two values together"
+35 SET DIR("?",5)="in the Auto Match file."
+36 SET DIR("?",6)=" "
+37 SET DIR("?",7)="Please enter YES if you do want to create an Auto Match entry for these"
+38 SET DIR("?",8)="two values. If you enter YES, then you will have the chance to modify"
+39 SET DIR("?")="the Auto Match Value."
+40 DO ^DIR
KILL DIR
+41 DO EN^DDIOL(,,"!!")
+42 ;
+43 ; If user didn't say Yes, then we exit
+44 IF 'Y
GOTO AMADDX
+45 ; To allow for edits to the .01 field and not the .02 field,
+46 ; Add this new entry first and then edit only the .01 field.
+47 SET AMDATA(365.11,"+1,",.01)=IBCNEXT1
+48 SET AMDATA(365.11,"+1,",.02)=INSNAME
+49 SET AMDATA(365.11,"+1,",.03)=$$NOW^XLFDT
+50 SET AMDATA(365.11,"+1,",.04)=DUZ
+51 SET AMDATA(365.11,"+1,",.05)=$$NOW^XLFDT
+52 SET AMDATA(365.11,"+1,",.06)=DUZ
+53 SET AMDATA(365.11,"+1,",.07)=IBCNEXT1
+54 SET AMDATA(365.11,"+1,",.08)=INSNAME
+55 DO UPDATE^DIE("","AMDATA","AMIEN","AMERROR")
+56 ;
+57 ; FileMan error so get out
IF $DATA(AMERROR)
GOTO AMADDX
+58 ; internal entry number created
SET AMIEN=+$GET(AMIEN(1))
+59 ; if IEN not there get out
IF 'AMIEN
GOTO AMADDX
+60 ;
+61 ; Here we have to edit the entry to allow for the opportunity to
+62 ; change something
+63 SET DIE=365.11
SET DA=AMIEN
SET DR=".01;.05////"_$$NOW^XLFDT_";.06////"_DUZ
+64 DO ^DIE
+65 ;
+66 ; Display the confirmation message to the user
+67 SET AMDATA=$GET(^IBCN(365.11,AMIEN,0))
+68 IF AMDATA'=""
DO EN^DDIOL($PIECE(AMDATA,U,1)_" is now associated with "_$PIECE(AMDATA,U,2)_".",,"!!?3")
+69 DO EN^DDIOL(,,"!!")
AMADDX ;
+1 QUIT
+2 ;
PYRFLTR() ;
+1 ; Function to assist with filtering items in custom payer
+2 ; lookups for most popular list. This logic is used in the
+3 ; DIC("S") definition for the lookup
+4 ;
+5 ;IB*2.0*668/TAZ - This functionality is no longer used and will be removed with a future User Story.
+6 QUIT 0
+7 ;
+8 NEW IBDATA,IBPIEN,IBPNM,IBAIEN,IBADATA,OK
+9 ;
+10 SET OK=1
+11 ;
+12 ; Naked reference from DIC call
SET IBDATA=^(0)
+13 SET IBPIEN=$GET(Y)
IF IBPIEN=""
SET OK=0
GOTO XPFLTR
+14 ;
+15 ; Set Payer Name and IEN
+16 SET IBPNM=$PIECE(IBDATA,U,1)
IF IBPNM=""
SET OK=0
GOTO XPFLTR
+17 ;
+18 ; Set Payer Application IEN (365.13)
+19 ; Quit if IIV not defined for payer
+20 SET IBAIEN=$$PYRAPP^IBCNEUT5("IIV",IBPIEN)
IF IBAIEN=""
SET OK=0
GOTO XPFLTR
+21 ;
+22 ; Get IIV application specific data
+23 SET IBADATA=$GET(^IBE(365.12,IBPIEN,1,IBAIEN,0))
IF IBADATA=""
SET OK=0
GOTO XPFLTR
+24 ;
+25 ; Filter if Deactivated
+26 IF +$PIECE(IBADATA,U,11)
SET OK=0
GOTO XPFLTR
+27 ;
+28 ; Filter if ID Inq Req ID and SSN is not ID
+29 IF +$PIECE(IBADATA,U,8)
IF '$PIECE(IBADATA,U,9)
SET OK=0
GOTO XPFLTR
+30 ;
+31 ; Filter if already in the list
+32 IF $DATA(^TMP($JOB,"IBJPI3-IENS",IBPIEN))
SET OK=0
GOTO XPFLTR
+33 ;
XPFLTR QUIT OK
+1 ;
DSPLINE() ;
+1 ; Format display text for custom Most Pop. payer lookup
+2 ;
+3 NEW ITEMDATA,DISPSTR,IBAIEN,IBADATA,PYRIEN,PADLEN
+4 ;
+5 ; Initialize the data for the item to be displayed
+6 ; Naked reference is referencing the DIC data
+7 SET ITEMDATA=^(0)
+8 ;
+9 ; Initialize Display string
+10 SET DISPSTR=""
+11 ;
+12 ; Payer IEN is passed from DIC as Y
+13 SET PYRIEN=+$GET(Y)
IF 'PYRIEN
GOTO EXDSP
+14 ;
+15 ; Set Payer Application IEN (365.13)
+16 SET IBAIEN=$$PYRAPP^IBCNEUT5("IIV",PYRIEN)
IF IBAIEN=""
GOTO EXDSP
+17 ;
+18 ; Get IIV Application specific data
+19 SET IBADATA=$GET(^IBE(365.12,PYRIEN,1,IBAIEN,0))
IF IBADATA=""
GOTO EXDSP
+20 ;
+21 ; Pad start of display data, adjusting for payer name length
+22 SET PADLEN=$LENGTH($EXTRACT($PIECE($GET(ITEMDATA),U),1,30))
+23 SET DISPSTR=DISPSTR_$$FO^IBCNEUT1("",31-PADLEN,"L")
+24 ;
+25 ; Add National and Local active flags
+26 SET DISPSTR=DISPSTR_" National: "_$$FO^IBCNEUT1($SELECT('$PIECE(IBADATA,U,2):"Inactive",1:"Active"),8)
+27 SET DISPSTR=DISPSTR_" Local: "_$$FO^IBCNEUT1($SELECT('$PIECE(IBADATA,U,3):"Inactive",1:"Active"),8)
EXDSP ;
+1 QUIT DISPSTR
+2 ;
+3 ;/vd-IB*2.0*687 - Added the following module of code for use by input templates
CKAPS(IBPYR) ; Utility allow only for Payers that are active and have a valid IIV
+1 ; and/or IIU Payer application.
+2 ; OUTPUT:
+3 ; 0 = Not a valid Payer
+4 ; 1 = Valid Payer (Active and has either an IIV or IIU Payer Application)
+5 if 'IBPYR
QUIT 0
+6 ; Invalid Payer Application.
IF '$$PYRAPP^IBCNEUT5("EIV",+IBPYR)
IF '$$PYRAPP^IBCNEUT5("IIU",+IBPYR)
QUIT 0
+7 QUIT 1
+8 ;
