- 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 Feb 18, 2025@23:41:58 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 ;