IBCEP8C ;DSS/SCR - Functions for IB SILENT INTERFACE FROM FB ;03-27-12
;;2.0;INTEGRATED BILLING;**476**;21-MAR-94;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine contains functions needed by the FB PAID TO IB OPTION to maintain
; the 355.93 - IB VA NON/OTHER BILLING PROVIDER file
;
EPTRANS() ;EP called from INPUT TRANSFORM IN THE .01 FIELD
; of 355.93 VA NON/OTHER BILLING PROVIDER file
;
;Used only by the IB AUTOMATIC INTERFACE FROM FB to ADD a new entry or UPDATE an existing one
;
S:IBPRVTYP=1 IBTYPE="F"
S:IBPRVTYP=2 IBTYPE="I"
S IBFBFLAG=1 ;USED BY THE NPI input transform to transfer code to interface and avoid user interaction
;
Q
EPFBAPI(IBSRCREC,IBRETARY) ;EP from FBTOIB^FBPAID3A
; INPUTS : IBSRCREC - an array of information about this source record supplied by FB side
;
; OUTPUT : IBRETARY (passed by reference) populated with information about results of interface processing
;
;TO IB NON/OTHER VA BILLING PROVIDER FILE 355.93
N IBRET
;
S IBRET=$$IBNONVA(.IBSRCREC) ;UPDATES THE IB NON/OTHER VA BILLING PROVIDER FILE
S IBRETARY(1)=$P(IBRET,U,1) ;The IEN of the IB record matched or created or NULL if neither
S IBRETARY(2)=$P(IBRET,U,2) ;A code from below indicating how NPI validation and record updates went
; '0' FOR NO NPI UPDATES ATTEMPTED;'1' FOR NPI DATA INVALID;'2' FOR NPI MATCHED ACTIVE, NO UPDATES;
; '3' FOR NPI MATCHED INACTIVE, NO UPDATES;'4' FOR NPI MATCHED ACTIVE, IB UPDATED; '5' FOR NPI NEW, IB RECORD CREATED;
S IBRETARY(3)=$P(IBRET,U,3) ;A code from below indicating how TXY updates went
; '0' FOR NO TXY UPDATES ATTEMPTED;'1' FOR TXY CODE NOT FOUND IN 8932.1; '2' FOR MATCHED PRIMARY,NO UPDATES;
;'3' FOR MATCHED NON-PRIMARY, IB TXY UPDATES;'4' FOR NEW, IB TXY ENTRY CREATED;
Q
;
IBNONVA(IBFBINF) ;UPDATES TO #355.93
; INPUTS IBFBINF : AN ARRAY OF INFORMATION FROM FB TO BE COMPARED/UPDATED IN IB NON/OTHER
;
; LOOK UP BY NPI - should only be one match per provider type
;
N IBQUIT,IBRTRN,IBDONE,IBFLGS,IBFLDS,IBIEN,IBSCRN,IBINDX,IBERR2,IBLKUP,IBOKTXY,IBOKNPI
N IBERR,IBFBMLT,IBNPICHK,IBFDA,IBALLOW,IBOKFB,IBOK,IBPRVNPI,IBPRVTYP
;
S IBQUIT=0
S IBDONE=0
S IBOKTXY=""
S IBOKNPI=""
S IBPRVTYP=IBFBINF("IB TYPE")
S IBPRVNPI=IBFBINF("FBNPI")
S IBPRVNAM=IBFBINF("NAME")
S IBPRVTXY=IBFBINF("FBTXY")
S IBFBDUZ=IBFBINF("FB SUP DUZ")
;
I IBPRVNPI'="" D
.N DO,X,%,%H,%I,X,IBNOW,DD,Y
.D NOW^%DTC
.S IBNOW=%
.S IBPRVNAM=$$STRIP(IBPRVNAM)
.S IBPRVNAM=$$UP^XLFSTR(IBPRVNAM)
.S IBIEN=$$ACTVNPI(IBPRVNPI) ;returns IEN of record with this NPI as 'active'
.I IBIEN>0 D
..S IBFBMLT=0 ;FB MULTIPLE NOT YET UPDATED
..S IBOKNPI=2 ;MATCHED ACTIVE NO UPDATES...will get changed if updates are made
..S IBOKTXY=0 ;NO TXY UPDATES ATTEMPTED
..;(#.01) NAME [1F] ; (#.02) PROVIDER TYPE [2S](#.05) STREETADDRESS [5F] ; (#.06) CITY [6F];
..;(#.07) STATE [7P:5] ^(#.08) ZIP CODE [8F] ; (#.09) FACILITY DEFAULT ID NUMBER[9F] ^(#.1) STREET ADDRESS LINE 2 [10F] ;
..;(#.13)PRIMARY ID QUALIFIER [13P:355.97];(#41.01) NPI [14F]
..S IBFLDS=".01;.02;.05;.06;.07;.08;.09;.1;.13;41.01"
..D GETS^DIQ(355.93,IBIEN_",",IBFLDS,"I","IBRTRN","IBERR") ; 355.93 IB NON/OTHER VA BILLING PROVIDER FILE
..I $G(IBERR("DIERR")) S IBQUIT=1
..Q:IBQUIT
..S IBALLOW=$$FBALLOW(IBIEN) ;FIND OUT IF THIS PROVIDER SHOULD BE EDITED OR NOT
..Q:IBALLOW=0
..I IBRTRN(355.93,IBIEN_",",".02","I")=IBPRVTYP D SETIBFDA(.IBRTRN,.IBFBINF,.IBFDA,IBIEN)
..S IBOK=$$LOCK(IBIEN) ;locks the #355.93 record
..Q:'IBOK
..I $D(IBFDA(355.93)) D
...S XQY0="FB AUTO INTERFACE TO IB" ; MUST be set to pass the .01 input transform defined in PRVFMT^IBCEP8
...S IBFLPFLP=IBPRVTYP ;needed for input transform
...D FILE^DIE("","IBFDA","IBERR")
...I $G(IBERR("DIERR")) S IBQUIT=1 ;FILE ATTEMPT RETURNED DB ERROR
...Q:IBQUIT
...S IBFBMLT=$$ADDFB(IBIEN,IBFBDUZ,IBNOW,0)
...S IBOKNPI=4 ; FOR NPI MATCHED ACTIVE, IB UPDATED;
..;CHECK TAXONOMY CODE
..I $G(IBPRVTXY)'="" D
...S IBOKTXY=$$CHKTXY(IBIEN,IBPRVTXY) ;RETURNS A CODE FROM SET OF CODES - 0 IF NO CHANGES WERE MADE
...S:('+IBFBMLT)&((IBOKTXY=3)!(IBOKTXY=4)) IBFBMLT=$$ADDFB(IBIEN,IBFBDUZ,IBNOW,0)
...;add FB mult if not already added for other changes, and the txy was changed
..D UNLOCK(IBIEN) ;Unlocks the #355.93 record
..S IBDONE=1 ;We have found a match on NPI
.Q:IBQUIT
.Q:IBDONE
.I IBIEN="" D
..S IBNPICHK=$$INACTV(IBPRVNPI) ;look for match on currently inactive
..I IBNPICHK'="" D
...S IBIEN=IBNPICHK ;THE IEN OF THE record with this NPI as INACTIVE
...S IBOKNPI=3 ;FOR NPI MATCHED INACTIVE, NO UPDATES;
...S IBOKTXY=0 ;NO ATTEMPTED UPDATES
...S IBDONE=1
..Q:IBDONE
..S IBNPICHK=$$RULES(IBPRVNPI) ;RETURN OF 0 means no problem
..I IBNPICHK>0 D
...;there is a match on an active NPI in the NEW PERSON or the INSTITUTION file
...S IBOKNPI=2 ;NPI MATCHED ACTIVE NO UPDATES
...S IBOKTXY=0
...S IBDONE=1
..Q:IBDONE
..;all checks have occurred, now we are going to add this PROVIDER/NPI
..S IBOK=$$LOCK() ;locks the #355.93 file
..I 'IBOK Q
..N DIC,X,Y
..S DIC="^IBA(355.93,"
..S X=IBPRVNAM
..S DIC(0)=""
..S DIC("DR")=".02///"_IBPRVTYP
..I IBPRVTYP=1 D ;ADD FACILITY INFORMATION
...I $G(IBFBINF("FBADD1"))'="" S DIC("DR")=DIC("DR")_";.05///"_IBFBINF("FBADD1")
...I $G(IBFBINF("FBADD2"))'="" S DIC("DR")=DIC("DR")_";.1///"_IBFBINF("FBADD2")
...I $G(IBFBINF("FBCITY"))'="" S DIC("DR")=DIC("DR")_";.06///"_IBFBINF("FBCITY")
...S:$G(IBFBINF("FBSTATE INT")) DIC("DR")=DIC("DR")_";.07///`"_IBFBINF("FBSTATE INT") ;POINTER SO PUT INTO INTERNAL FORMAT
...S:$G(IBFBINF("FBZIP")) DIC("DR")=DIC("DR")_";.08///"_IBFBINF("FBZIP")
...I $G(IBFBINF("FBFACID"))'="" S DIC("DR")=DIC("DR")_";.09///"_IBFBINF("FBFACID")
..S DIC("DR")=DIC("DR")_";41.01///"_IBPRVNPI
..S XQY0="FB AUTO INTERFACE TO IB" ; MUST be set to pass the .01 input transform defined in PRVFMT^IBCEP8
..S IBFLPFLP=IBPRVTYP ;needed for successful 'three stuff' validation
..D FILE^DICN
..S IBIEN=+Y
..I IBIEN=-1 D
...S IBQUIT=1
...D UNLOCK()
..Q:IBQUIT
..S IBOKFB=$$ADDFB(IBIEN,IBFBDUZ,IBNOW,1)
..S IBOKNPI=$$ADDNPI(IBIEN,IBPRVNPI,IBFBDUZ,IBNOW) ;returns 1 or 0
..S:IBOKNPI=1 IBOKNPI=5 ;NPI NEW, IB RECORD CREATED
..I $G(IBPRVTXY)'="" D
...S IBOK=$$ADDTXY(IBIEN,IBPRVTXY,1)
...S:IBOK IBOKTXY=4 ;FOR NEW TXY ENTRY CREATED
...S:'IBOK IBOKTXY=0 ;NO TXY UPDATES ATTEMPTED
..D UNLOCK() ;unlocks the #355.93 file or a record
S:$G(IBPRVTXY)="" IBOKTXY=0 ;NO TXY UPDATES ATTEMPTED
S:$G(IBPRVNPI)="" IBOKNPI=0 ;NO NPI UPDATES ATTEMPTED
I IBQUIT S IBIEN=""
Q IBIEN_"^"_IBOKNPI_"^"_IBOKTXY
;
ADDFB(IBIEN,IBFBDUZ,IBNOW,IBFBADD) ;ADD a multiple entry
; INPUTS : IBIEN: IEN OF THE IB NON/OTHER VA PROVIDER FILE being updated with NPI information
; IBFBDUZ : IEN of the FB SUPERVISOR who certified the batch
; IBNOW : FM Date/time
; IBFBADD : 1 if FB is just created the record 0 if not
;
N IBFDA,IBIENRET,IBERR
;
S IBQUIT=0
S IBFDA(355.935,"+1,"_IBIEN_",",.01)=IBNOW ;(#.01) DATE/TIME LAST FB UPDATE [1D]
S IBFDA(355.935,"+1,"_IBIEN_",",.02)=IBFBDUZ ;(#.02) DUZ OFFB SUP [2P:200]
S:IBFBADD IBFDA(355.935,"+1,"_IBIEN_",",.03)=IBFBADD ;(#.03) CREATED BY FB PAID TO IB[3S]
D UPDATE^DIE("","IBFDA","IBIENRET","IBERR")
I $G(IBERR("DIERR"))'="" S IBQUIT=1
Q 'IBQUIT
;
ADDNPI(IBIEN,IBNPI,IBFBDUZ,IBNOW) ;ADD NPI multiple
; INPUTS : IBIEN: IEN OF THE IB NON/OTHER VA PROVIDER FILE being updated with NPI information
; IBNPI : NPI STRING TO BE ADDED if it passes validation rules (we already know this
; npi does not exist as an 'active' npi for a current entry in this file
;
N IBFDA,IBERR,IBQUIT
;
S IBQUIT=0
S IBFDA(355.9301,"+1,"_IBIEN_",",.01)=IBNOW ;355.9301 ;(#40) DATE/TIME OF LAST NPI CHANGE (#.01) DATE/TIME OF LAST NPI CHANGE [1D]
S IBFDA(355.9301,"+1,"_IBIEN_",",.02)=1 ;(#.02) STATUS [2S]
S IBFDA(355.9301,"+1,"_IBIEN_",",.03)=IBNPI ;(#.03) NPI [3F]
S IBFDA(355.9301,"+1,"_IBIEN_",",.04)=IBFBDUZ ;(#.04)PERSON AFFECTING LAST CHANGE [4P:200]
D UPDATE^DIE("","IBFDA","","IBERR")
I $G(IBERR("DIERR"))'="" S IBQUIT=1
Q 'IBQUIT
;
CHKTXY(IBIEN,IBPRVTXY) ;LOOKS FOR TAXONOMY CODE AND MAKES ACTIVE OR ADDS
;
;INPUT : IBIEN - THE IEN OF THE IB NON/OTHER VA BILLING PROVIDER BEING UDPATED
; IBPRVTXY - THE TAXONOMY CODE PROVIDED BY FEE BASIS THAT IS BEING LOOKED FOR
;
; RETURNS:
; '0' FOR NO TXY UPDATES ATTEMPTED;
; '1' FOR TXY CODE NOT FOUND IN 8932.1;
; '2' FOR MATCHED PRIMARY,NO UPDATES;
; '3' FOR MATCHED NON-PRIMARY, IB TXY UPDATES;
; '4' FOR NEW, IB TXY ENTRY CREATED;
;
N IBDONE,IBERR,IBTXYIEN,IBRETRN,IBACTIV,IBTXYCOD,IBOK
;
;GET THE INTERNAL VALUE OF THIS TAXONOMY CODE
S IBTXYIEN=$$FIND1^DIC(8932.1,"","X",IBPRVTXY,"G","","IBERR") ;8932.1 PERSON CLASS FILE
I (IBTXYIEN>0) D
.S IBDONE=0
.S IBPRIM=0
.S IBTXY=0
.F S IBTXY=$O(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY)) Q:(('+IBTXY)!IBDONE) D
..S IBTXYCOD=$P(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY,0),U,1)
..S IBPRIM=$P(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY,0),U,2)
..S IBACTIV=$P(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY,0),U,3)
..I IBTXYCOD=IBTXYIEN D
...S IBDONE=1
...S IBRETRN=2 ;'2' FOR MATCHED PRIMARY,NO UPDATES;
...I IBPRIM'=1 D
....S IBFDA(355.9342,IBTXY_","_IBIEN_",",".02")=1 ;355.9342 IB NON/OTHER VA BILLING PROVIDER FILE :TAXONOMY
....S IBFDA(355.9342,IBTXY_","_IBIEN_",",".03")="A"
....S IBRETRN=3 ;'3' FOR MATCHED NON-PRIMARY, IB TXY UPDATES;
....D FILE^DIE("","IBFDA","IBERR")
.I 'IBDONE D
..S IBOK=$$ADDTXY(IBIEN,IBPRVTXY,1)
..S:IBOK IBRETRN=4 ; '4' FOR NEW IB TXY ENTRY CREATED
..S:'IBOK IBRETRN=0 ;'0' FOR NO UPDATES ATTEMPTED
I (IBTXYIEN<=0) S IBRETRN=1 ;THIS CODE IS NOT A POINTER TO THE PERSON CLASS FILE - CAN'T ADD
Q IBRETRN
;
ADDTXY(IBIEN,IBTXY,IBPRIM) ;ADD TAXONOMY multiple entry
; INPUTS : IBIEN: IEN OF THE IB NON/OTHER VA PROVIDER FILE being updated with NPI information
; IBTXY : TAXONOMY STRING TO BE ADDED if it passes validation rules
; IBPRIM : 1 IF THIS IS TO BE ADDED AS PRIMARY CODE, 0 OTHERWISE
;
; RETURNS: 0 IF NO UDPATES WERE MADE TO TAXONOMY FILE
; 1 IF NEW TAXONOMY CODE WAS ADDED
;
N IBFDA,IBFDAVAL,IBIENRET,IBERR,IBQUIT,IBOK
;
S IBQUIT=0
S IBFDA(355.9342,"?+1,"_IBIEN_",",.01)=IBTXY ;355.9342 ;IB NON/OTHER VA BILLING PROVIDER FILE :TAXONOMY
S IBFDA(355.9342,"?+1,"_IBIEN_",",.02)=IBPRIM
S IBFDA(355.9342,"?+1,"_IBIEN_",",.03)="A"
D VALS^DIE("","IBFDA","IBFDAVAL","IBERR")
I $G(IBERR("DIERR"))'="" S IBQUIT=1
I 'IBQUIT D
.D UPDATE^DIE("","IBFDAVAL","IBIENRET","IBERR")
.I $G(IBERR("DIERR"))="" D
..S:$G(IBIENRET(1))'="" IBOK=IBIENRET(1) ;THE IEN WHICH WAS JUST ADDED
..S:'+IBOK IBQUIT=1
.I $G(IBERR("DIERR"))'="" S IBQUIT=1
Q 'IBQUIT
;
ACTVNPI(IBNPI) ;RETURNS ien of ACTIVE NPI IN IB NON/OTHER VA BILLING PROVIDER FILE
;INPUT IBNPI : The NPI from FB provider under consideration
N IBIEN,IBSUB
S IBIEN=$O(^IBA(355.93,"NPIHISTORY",IBNPI,""),-1) ;Most recent IEN for this NPI
I $G(IBIEN)'="" D
.S IBSUB=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBNPI,""),-1) ;MOST recent status for this IEN for this NPI
.S:IBSUB="" IBIEN=""
.Q:IBIEN=""
.S:'$D(^IBA(355.93,IBIEN,"NPISTATUS","NPISTATUS",1,IBSUB)) IBIEN=""
Q IBIEN
;
INACTV(IBNPI) ;RETURNS ien of INACTIVE NPI IN IB NON/OTHER VA BILLING PROVIDER FILE
;INPUT IBNPI : The NPI from FB provider under consideration
N IBIEN,IBSUB
S IBIEN=$O(^IBA(355.93,"NPIHISTORY",IBNPI,""),-1)
I $G(IBIEN)'="" D
.S IBSUB=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBNPI,""),-1) ;MOST recent status for this NPI
.S:IBSUB="" IBIEN=""
.Q:IBIEN=""
.S:'$D(^IBA(355.93,IBIEN,"NPISTATUS","NPISTATUS",0,IBSUB)) IBIEN=""
Q IBIEN
;
RULES(IBNPI) ;Verify that the NPI meets all rules for being added
; see NPIUSED^IBCEP81 where the input transform on the NPI field that is being bypassed is defined
; INPUT IBNPI - the NPI about to be added
;
; OUTPUT 0 if no ACTIVE records found 1 if ACTIVE in NEW PERSON FILE, 2 IF ACVTIVE IN INSTUTUTION FILE
N IBIEN1,IBIEN2,IBRETURN
;
S IBRETURN=0 ;NOT FOUND IN ANY FILES
I IBNPI="" S IBRETURN=""
S:+IBNPI&$D(^VA(200,"ANPI",IBNPI)) IBRETURN=1 ;ACTIVE in the NEW PERSON file
S:+IBNPI&$D(^DIC(4,"ANPI",IBNPI)) IBRETURN=2 ;ACTIVE in the INSTITUTION file
Q IBRETURN
;
FBALLOW(IBIEN) ;Returns 1 if FB updates are allowed
; INPUT : IBIEN - The internal entry number to the IB NON/OTHER VA BILLING PROVIDER FILE
;
N IBRETURN,IBSUB,IBERR
;
S IBSUB=9999999
S IBRETURN=1 ;ALLOW updates if no entry has been made
I $O(^IBA(355.93,IBIEN,2))=3 D
.S IBSUB=$O(^IBA(355.93,IBIEN,3,IBSUB),-1) ;get the most recent sub-entry
.S IBRETURN=$$GET1^DIQ(355.9351,IBSUB_","_IBIEN_",",".02","I","","")
.I IBRETURN'=0 S IBRETURN=1
Q IBRETURN
;
STRIP(FBPRVNAM) ; Strip off leading and trailing spaces
;
N IBPRVNAM
;
S IBPRVNAM=FBPRVNAM
F Q:$E(IBPRVNAM)'=" " S IBPRVNAM=$E(IBPRVNAM,2,$L(IBPRVNAM))
F Q:$E(IBPRVNAM,$L(IBPRVNAM))'=" " S IBPRVNAM=$E(FBPRVNAM,1,$L(IBPRVNAM)-1)
Q IBPRVNAM
;
SETIBFDA(IBRTRN,IBFBINF,IBFDA,IBIEN) ;Populates IBFDA ARRAY with update information
; INPUT : IBRTRN - an array with current IB information in it
; IBFBINF - an array with information from FB in it
; IBFDA - the array which will be used to update the record
; IBIEN - the IEN of the IB record being updated
;
; OUTPUT : POPULATED IBFDA ARRAY IF UPDATES ARE NEEDED
I IBFBINF("IB TYPE")=1 D
.I IBRTRN(355.93,IBIEN_",",".01","I")=IBPRVNAM D
..I IBRTRN(355.93,IBIEN_",",".05","I")'=$G(IBFBINF("FBADD1")) S IBFDA(355.93,IBIEN_",",.05)=IBFBINF("FBADD1")
..I IBRTRN(355.93,IBIEN_",",".1","I")'=$G(IBFBINF("FBADD2")) S IBFDA(355.93,IBIEN_",",.1)=IBFBINF("FBADD2")
..I IBRTRN(355.93,IBIEN_",",".06","I")'=$G(IBFBINF("FBCITY")) S IBFDA(355.93,IBIEN_",",.06)=IBFBINF("FBCITY")
..I IBRTRN(355.93,IBIEN_",",".07","I")'=$G(IBFBINF("FBSTATE INT")) S IBFDA(355.93,IBIEN_",",.07)=IBFBINF("FBSTATE INT")
..I IBRTRN(355.93,IBIEN_",",".08","I")'=$G(IBFBINF("FBZIP")) S IBFDA(355.93,IBIEN_",",.08)=IBFBINF("FBZIP")
..I IBRTRN(355.93,IBIEN_",",".09","I")'=$G(IBFBINF("FBFACID")) S IBFDA(355.93,IBIEN_",",.09)=IBFBINF("FBFACID")
.I (IBRTRN(355.93,IBIEN_",",".01","I")'=IBPRVNAM) D
..; When the name changes, everything is wiped out, so needs to be saved again
..S IBFDA(355.93,IBIEN_",",.01)=IBPRVNAM
..I $G(IBFBINF("FBADD1"))'="" S IBFDA(355.93,IBIEN_",",.05)=IBFBINF("FBADD1")
..I $G(IBFBINF("FBADD2"))'="" S IBFDA(355.93,IBIEN_",",.1)=IBFBINF("FBADD2")
..I $G(IBFBINF("FBCITY"))'="" S IBFDA(355.93,IBIEN_",",.06)=IBFBINF("FBCITY")
..I $G(IBFBINF("FBSTATE"))'="" S IBFDA(355.93,IBIEN_",",.07)=IBFBINF("FBSTATE INT")
..I $G(IBFBINF("FBZIP"))'="" S IBFDA(355.93,IBIEN_",",.08)=IBFBINF("FBZIP")
..I $G(IBFBINF("FBFACID"))'="" S IBFDA(355.93,IBIEN_",",.09)=IBFBINF("FBFACID")
I IBFBINF("IB TYPE")=2 D
.I (IBRTRN(355.93,IBIEN_",",".01","I")'=IBPRVNAM) S IBFDA(355.93,IBIEN_",",.01)=IBPRVNAM
Q
;
LOCK(IBIEN) ;Locks the #355.93 file or a record in it
; INPUT : IBIEN - the ien of the record to be locked NULL if a new record is being added
N IBLOCK
;
S IBLOCK=1
I $G(IBIEN)="" D
.L +^IBA(355.93):3
.I '$T S IBLOCK=0
I $G(IBIEN)'="" D
.L +^IBA(355.93,IBIEN):3
.I '$T S IBLOCK=0
Q IBLOCK
;
UNLOCK(IBIEN) ; Unlocks the #355.93 file or a record in it
; INPUT : IBIEN - the ien of the record to be unlocked or NULL if a new record was added
I $G(IBIEN)="" L -^IBA(355.93)
I $G(IBIEN)'="" L -^IBA(355.93,IBIEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP8C 15970 printed Dec 13, 2024@02:11:52 Page 2
IBCEP8C ;DSS/SCR - Functions for IB SILENT INTERFACE FROM FB ;03-27-12
+1 ;;2.0;INTEGRATED BILLING;**476**;21-MAR-94;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine contains functions needed by the FB PAID TO IB OPTION to maintain
+5 ; the 355.93 - IB VA NON/OTHER BILLING PROVIDER file
+6 ;
EPTRANS() ;EP called from INPUT TRANSFORM IN THE .01 FIELD
+1 ; of 355.93 VA NON/OTHER BILLING PROVIDER file
+2 ;
+3 ;Used only by the IB AUTOMATIC INTERFACE FROM FB to ADD a new entry or UPDATE an existing one
+4 ;
+5 if IBPRVTYP=1
SET IBTYPE="F"
+6 if IBPRVTYP=2
SET IBTYPE="I"
+7 ;USED BY THE NPI input transform to transfer code to interface and avoid user interaction
SET IBFBFLAG=1
+8 ;
+9 QUIT
EPFBAPI(IBSRCREC,IBRETARY) ;EP from FBTOIB^FBPAID3A
+1 ; INPUTS : IBSRCREC - an array of information about this source record supplied by FB side
+2 ;
+3 ; OUTPUT : IBRETARY (passed by reference) populated with information about results of interface processing
+4 ;
+5 ;TO IB NON/OTHER VA BILLING PROVIDER FILE 355.93
+6 NEW IBRET
+7 ;
+8 ;UPDATES THE IB NON/OTHER VA BILLING PROVIDER FILE
SET IBRET=$$IBNONVA(.IBSRCREC)
+9 ;The IEN of the IB record matched or created or NULL if neither
SET IBRETARY(1)=$PIECE(IBRET,U,1)
+10 ;A code from below indicating how NPI validation and record updates went
SET IBRETARY(2)=$PIECE(IBRET,U,2)
+11 ; '0' FOR NO NPI UPDATES ATTEMPTED;'1' FOR NPI DATA INVALID;'2' FOR NPI MATCHED ACTIVE, NO UPDATES;
+12 ; '3' FOR NPI MATCHED INACTIVE, NO UPDATES;'4' FOR NPI MATCHED ACTIVE, IB UPDATED; '5' FOR NPI NEW, IB RECORD CREATED;
+13 ;A code from below indicating how TXY updates went
SET IBRETARY(3)=$PIECE(IBRET,U,3)
+14 ; '0' FOR NO TXY UPDATES ATTEMPTED;'1' FOR TXY CODE NOT FOUND IN 8932.1; '2' FOR MATCHED PRIMARY,NO UPDATES;
+15 ;'3' FOR MATCHED NON-PRIMARY, IB TXY UPDATES;'4' FOR NEW, IB TXY ENTRY CREATED;
+16 QUIT
+17 ;
IBNONVA(IBFBINF) ;UPDATES TO #355.93
+1 ; INPUTS IBFBINF : AN ARRAY OF INFORMATION FROM FB TO BE COMPARED/UPDATED IN IB NON/OTHER
+2 ;
+3 ; LOOK UP BY NPI - should only be one match per provider type
+4 ;
+5 NEW IBQUIT,IBRTRN,IBDONE,IBFLGS,IBFLDS,IBIEN,IBSCRN,IBINDX,IBERR2,IBLKUP,IBOKTXY,IBOKNPI
+6 NEW IBERR,IBFBMLT,IBNPICHK,IBFDA,IBALLOW,IBOKFB,IBOK,IBPRVNPI,IBPRVTYP
+7 ;
+8 SET IBQUIT=0
+9 SET IBDONE=0
+10 SET IBOKTXY=""
+11 SET IBOKNPI=""
+12 SET IBPRVTYP=IBFBINF("IB TYPE")
+13 SET IBPRVNPI=IBFBINF("FBNPI")
+14 SET IBPRVNAM=IBFBINF("NAME")
+15 SET IBPRVTXY=IBFBINF("FBTXY")
+16 SET IBFBDUZ=IBFBINF("FB SUP DUZ")
+17 ;
+18 IF IBPRVNPI'=""
Begin DoDot:1
+19 NEW DO,X,%,%H,%I,X,IBNOW,DD,Y
+20 DO NOW^%DTC
+21 SET IBNOW=%
+22 SET IBPRVNAM=$$STRIP(IBPRVNAM)
+23 SET IBPRVNAM=$$UP^XLFSTR(IBPRVNAM)
+24 ;returns IEN of record with this NPI as 'active'
SET IBIEN=$$ACTVNPI(IBPRVNPI)
+25 IF IBIEN>0
Begin DoDot:2
+26 ;FB MULTIPLE NOT YET UPDATED
SET IBFBMLT=0
+27 ;MATCHED ACTIVE NO UPDATES...will get changed if updates are made
SET IBOKNPI=2
+28 ;NO TXY UPDATES ATTEMPTED
SET IBOKTXY=0
+29 ;(#.01) NAME [1F] ; (#.02) PROVIDER TYPE [2S](#.05) STREETADDRESS [5F] ; (#.06) CITY [6F];
+30 ;(#.07) STATE [7P:5] ^(#.08) ZIP CODE [8F] ; (#.09) FACILITY DEFAULT ID NUMBER[9F] ^(#.1) STREET ADDRESS LINE 2 [10F] ;
+31 ;(#.13)PRIMARY ID QUALIFIER [13P:355.97];(#41.01) NPI [14F]
+32 SET IBFLDS=".01;.02;.05;.06;.07;.08;.09;.1;.13;41.01"
+33 ; 355.93 IB NON/OTHER VA BILLING PROVIDER FILE
DO GETS^DIQ(355.93,IBIEN_",",IBFLDS,"I","IBRTRN","IBERR")
+34 IF $GET(IBERR("DIERR"))
SET IBQUIT=1
+35 if IBQUIT
QUIT
+36 ;FIND OUT IF THIS PROVIDER SHOULD BE EDITED OR NOT
SET IBALLOW=$$FBALLOW(IBIEN)
+37 if IBALLOW=0
QUIT
+38 IF IBRTRN(355.93,IBIEN_",",".02","I")=IBPRVTYP
DO SETIBFDA(.IBRTRN,.IBFBINF,.IBFDA,IBIEN)
+39 ;locks the #355.93 record
SET IBOK=$$LOCK(IBIEN)
+40 if 'IBOK
QUIT
+41 IF $DATA(IBFDA(355.93))
Begin DoDot:3
+42 ; MUST be set to pass the .01 input transform defined in PRVFMT^IBCEP8
SET XQY0="FB AUTO INTERFACE TO IB"
+43 ;needed for input transform
SET IBFLPFLP=IBPRVTYP
+44 DO FILE^DIE("","IBFDA","IBERR")
+45 ;FILE ATTEMPT RETURNED DB ERROR
IF $GET(IBERR("DIERR"))
SET IBQUIT=1
+46 if IBQUIT
QUIT
+47 SET IBFBMLT=$$ADDFB(IBIEN,IBFBDUZ,IBNOW,0)
+48 ; FOR NPI MATCHED ACTIVE, IB UPDATED;
SET IBOKNPI=4
End DoDot:3
+49 ;CHECK TAXONOMY CODE
+50 IF $GET(IBPRVTXY)'=""
Begin DoDot:3
+51 ;RETURNS A CODE FROM SET OF CODES - 0 IF NO CHANGES WERE MADE
SET IBOKTXY=$$CHKTXY(IBIEN,IBPRVTXY)
+52 if ('+IBFBMLT)&((IBOKTXY=3)!(IBOKTXY=4))
SET IBFBMLT=$$ADDFB(IBIEN,IBFBDUZ,IBNOW,0)
+53 ;add FB mult if not already added for other changes, and the txy was changed
End DoDot:3
+54 ;Unlocks the #355.93 record
DO UNLOCK(IBIEN)
+55 ;We have found a match on NPI
SET IBDONE=1
End DoDot:2
+56 if IBQUIT
QUIT
+57 if IBDONE
QUIT
+58 IF IBIEN=""
Begin DoDot:2
+59 ;look for match on currently inactive
SET IBNPICHK=$$INACTV(IBPRVNPI)
+60 IF IBNPICHK'=""
Begin DoDot:3
+61 ;THE IEN OF THE record with this NPI as INACTIVE
SET IBIEN=IBNPICHK
+62 ;FOR NPI MATCHED INACTIVE, NO UPDATES;
SET IBOKNPI=3
+63 ;NO ATTEMPTED UPDATES
SET IBOKTXY=0
+64 SET IBDONE=1
End DoDot:3
+65 if IBDONE
QUIT
+66 ;RETURN OF 0 means no problem
SET IBNPICHK=$$RULES(IBPRVNPI)
+67 IF IBNPICHK>0
Begin DoDot:3
+68 ;there is a match on an active NPI in the NEW PERSON or the INSTITUTION file
+69 ;NPI MATCHED ACTIVE NO UPDATES
SET IBOKNPI=2
+70 SET IBOKTXY=0
+71 SET IBDONE=1
End DoDot:3
+72 if IBDONE
QUIT
+73 ;all checks have occurred, now we are going to add this PROVIDER/NPI
+74 ;locks the #355.93 file
SET IBOK=$$LOCK()
+75 IF 'IBOK
QUIT
+76 NEW DIC,X,Y
+77 SET DIC="^IBA(355.93,"
+78 SET X=IBPRVNAM
+79 SET DIC(0)=""
+80 SET DIC("DR")=".02///"_IBPRVTYP
+81 ;ADD FACILITY INFORMATION
IF IBPRVTYP=1
Begin DoDot:3
+82 IF $GET(IBFBINF("FBADD1"))'=""
SET DIC("DR")=DIC("DR")_";.05///"_IBFBINF("FBADD1")
+83 IF $GET(IBFBINF("FBADD2"))'=""
SET DIC("DR")=DIC("DR")_";.1///"_IBFBINF("FBADD2")
+84 IF $GET(IBFBINF("FBCITY"))'=""
SET DIC("DR")=DIC("DR")_";.06///"_IBFBINF("FBCITY")
+85 ;POINTER SO PUT INTO INTERNAL FORMAT
if $GET(IBFBINF("FBSTATE INT"))
SET DIC("DR")=DIC("DR")_";.07///`"_IBFBINF("FBSTATE INT")
+86 if $GET(IBFBINF("FBZIP"))
SET DIC("DR")=DIC("DR")_";.08///"_IBFBINF("FBZIP")
+87 IF $GET(IBFBINF("FBFACID"))'=""
SET DIC("DR")=DIC("DR")_";.09///"_IBFBINF("FBFACID")
End DoDot:3
+88 SET DIC("DR")=DIC("DR")_";41.01///"_IBPRVNPI
+89 ; MUST be set to pass the .01 input transform defined in PRVFMT^IBCEP8
SET XQY0="FB AUTO INTERFACE TO IB"
+90 ;needed for successful 'three stuff' validation
SET IBFLPFLP=IBPRVTYP
+91 DO FILE^DICN
+92 SET IBIEN=+Y
+93 IF IBIEN=-1
Begin DoDot:3
+94 SET IBQUIT=1
+95 DO UNLOCK()
End DoDot:3
+96 if IBQUIT
QUIT
+97 SET IBOKFB=$$ADDFB(IBIEN,IBFBDUZ,IBNOW,1)
+98 ;returns 1 or 0
SET IBOKNPI=$$ADDNPI(IBIEN,IBPRVNPI,IBFBDUZ,IBNOW)
+99 ;NPI NEW, IB RECORD CREATED
if IBOKNPI=1
SET IBOKNPI=5
+100 IF $GET(IBPRVTXY)'=""
Begin DoDot:3
+101 SET IBOK=$$ADDTXY(IBIEN,IBPRVTXY,1)
+102 ;FOR NEW TXY ENTRY CREATED
if IBOK
SET IBOKTXY=4
+103 ;NO TXY UPDATES ATTEMPTED
if 'IBOK
SET IBOKTXY=0
End DoDot:3
+104 ;unlocks the #355.93 file or a record
DO UNLOCK()
End DoDot:2
End DoDot:1
+105 ;NO TXY UPDATES ATTEMPTED
if $GET(IBPRVTXY)=""
SET IBOKTXY=0
+106 ;NO NPI UPDATES ATTEMPTED
if $GET(IBPRVNPI)=""
SET IBOKNPI=0
+107 IF IBQUIT
SET IBIEN=""
+108 QUIT IBIEN_"^"_IBOKNPI_"^"_IBOKTXY
+109 ;
ADDFB(IBIEN,IBFBDUZ,IBNOW,IBFBADD) ;ADD a multiple entry
+1 ; INPUTS : IBIEN: IEN OF THE IB NON/OTHER VA PROVIDER FILE being updated with NPI information
+2 ; IBFBDUZ : IEN of the FB SUPERVISOR who certified the batch
+3 ; IBNOW : FM Date/time
+4 ; IBFBADD : 1 if FB is just created the record 0 if not
+5 ;
+6 NEW IBFDA,IBIENRET,IBERR
+7 ;
+8 SET IBQUIT=0
+9 ;(#.01) DATE/TIME LAST FB UPDATE [1D]
SET IBFDA(355.935,"+1,"_IBIEN_",",.01)=IBNOW
+10 ;(#.02) DUZ OFFB SUP [2P:200]
SET IBFDA(355.935,"+1,"_IBIEN_",",.02)=IBFBDUZ
+11 ;(#.03) CREATED BY FB PAID TO IB[3S]
if IBFBADD
SET IBFDA(355.935,"+1,"_IBIEN_",",.03)=IBFBADD
+12 DO UPDATE^DIE("","IBFDA","IBIENRET","IBERR")
+13 IF $GET(IBERR("DIERR"))'=""
SET IBQUIT=1
+14 QUIT 'IBQUIT
+15 ;
ADDNPI(IBIEN,IBNPI,IBFBDUZ,IBNOW) ;ADD NPI multiple
+1 ; INPUTS : IBIEN: IEN OF THE IB NON/OTHER VA PROVIDER FILE being updated with NPI information
+2 ; IBNPI : NPI STRING TO BE ADDED if it passes validation rules (we already know this
+3 ; npi does not exist as an 'active' npi for a current entry in this file
+4 ;
+5 NEW IBFDA,IBERR,IBQUIT
+6 ;
+7 SET IBQUIT=0
+8 ;355.9301 ;(#40) DATE/TIME OF LAST NPI CHANGE (#.01) DATE/TIME OF LAST NPI CHANGE [1D]
SET IBFDA(355.9301,"+1,"_IBIEN_",",.01)=IBNOW
+9 ;(#.02) STATUS [2S]
SET IBFDA(355.9301,"+1,"_IBIEN_",",.02)=1
+10 ;(#.03) NPI [3F]
SET IBFDA(355.9301,"+1,"_IBIEN_",",.03)=IBNPI
+11 ;(#.04)PERSON AFFECTING LAST CHANGE [4P:200]
SET IBFDA(355.9301,"+1,"_IBIEN_",",.04)=IBFBDUZ
+12 DO UPDATE^DIE("","IBFDA","","IBERR")
+13 IF $GET(IBERR("DIERR"))'=""
SET IBQUIT=1
+14 QUIT 'IBQUIT
+15 ;
CHKTXY(IBIEN,IBPRVTXY) ;LOOKS FOR TAXONOMY CODE AND MAKES ACTIVE OR ADDS
+1 ;
+2 ;INPUT : IBIEN - THE IEN OF THE IB NON/OTHER VA BILLING PROVIDER BEING UDPATED
+3 ; IBPRVTXY - THE TAXONOMY CODE PROVIDED BY FEE BASIS THAT IS BEING LOOKED FOR
+4 ;
+5 ; RETURNS:
+6 ; '0' FOR NO TXY UPDATES ATTEMPTED;
+7 ; '1' FOR TXY CODE NOT FOUND IN 8932.1;
+8 ; '2' FOR MATCHED PRIMARY,NO UPDATES;
+9 ; '3' FOR MATCHED NON-PRIMARY, IB TXY UPDATES;
+10 ; '4' FOR NEW, IB TXY ENTRY CREATED;
+11 ;
+12 NEW IBDONE,IBERR,IBTXYIEN,IBRETRN,IBACTIV,IBTXYCOD,IBOK
+13 ;
+14 ;GET THE INTERNAL VALUE OF THIS TAXONOMY CODE
+15 ;8932.1 PERSON CLASS FILE
SET IBTXYIEN=$$FIND1^DIC(8932.1,"","X",IBPRVTXY,"G","","IBERR")
+16 IF (IBTXYIEN>0)
Begin DoDot:1
+17 SET IBDONE=0
+18 SET IBPRIM=0
+19 SET IBTXY=0
+20 FOR
SET IBTXY=$ORDER(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY))
if (('+IBTXY)!IBDONE)
QUIT
Begin DoDot:2
+21 SET IBTXYCOD=$PIECE(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY,0),U,1)
+22 SET IBPRIM=$PIECE(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY,0),U,2)
+23 SET IBACTIV=$PIECE(^IBA(355.93,IBIEN,"TAXONOMY",IBTXY,0),U,3)
+24 IF IBTXYCOD=IBTXYIEN
Begin DoDot:3
+25 SET IBDONE=1
+26 ;'2' FOR MATCHED PRIMARY,NO UPDATES;
SET IBRETRN=2
+27 IF IBPRIM'=1
Begin DoDot:4
+28 ;355.9342 IB NON/OTHER VA BILLING PROVIDER FILE :TAXONOMY
SET IBFDA(355.9342,IBTXY_","_IBIEN_",",".02")=1
+29 SET IBFDA(355.9342,IBTXY_","_IBIEN_",",".03")="A"
+30 ;'3' FOR MATCHED NON-PRIMARY, IB TXY UPDATES;
SET IBRETRN=3
+31 DO FILE^DIE("","IBFDA","IBERR")
End DoDot:4
End DoDot:3
End DoDot:2
+32 IF 'IBDONE
Begin DoDot:2
+33 SET IBOK=$$ADDTXY(IBIEN,IBPRVTXY,1)
+34 ; '4' FOR NEW IB TXY ENTRY CREATED
if IBOK
SET IBRETRN=4
+35 ;'0' FOR NO UPDATES ATTEMPTED
if 'IBOK
SET IBRETRN=0
End DoDot:2
End DoDot:1
+36 ;THIS CODE IS NOT A POINTER TO THE PERSON CLASS FILE - CAN'T ADD
IF (IBTXYIEN<=0)
SET IBRETRN=1
+37 QUIT IBRETRN
+38 ;
ADDTXY(IBIEN,IBTXY,IBPRIM) ;ADD TAXONOMY multiple entry
+1 ; INPUTS : IBIEN: IEN OF THE IB NON/OTHER VA PROVIDER FILE being updated with NPI information
+2 ; IBTXY : TAXONOMY STRING TO BE ADDED if it passes validation rules
+3 ; IBPRIM : 1 IF THIS IS TO BE ADDED AS PRIMARY CODE, 0 OTHERWISE
+4 ;
+5 ; RETURNS: 0 IF NO UDPATES WERE MADE TO TAXONOMY FILE
+6 ; 1 IF NEW TAXONOMY CODE WAS ADDED
+7 ;
+8 NEW IBFDA,IBFDAVAL,IBIENRET,IBERR,IBQUIT,IBOK
+9 ;
+10 SET IBQUIT=0
+11 ;355.9342 ;IB NON/OTHER VA BILLING PROVIDER FILE :TAXONOMY
SET IBFDA(355.9342,"?+1,"_IBIEN_",",.01)=IBTXY
+12 SET IBFDA(355.9342,"?+1,"_IBIEN_",",.02)=IBPRIM
+13 SET IBFDA(355.9342,"?+1,"_IBIEN_",",.03)="A"
+14 DO VALS^DIE("","IBFDA","IBFDAVAL","IBERR")
+15 IF $GET(IBERR("DIERR"))'=""
SET IBQUIT=1
+16 IF 'IBQUIT
Begin DoDot:1
+17 DO UPDATE^DIE("","IBFDAVAL","IBIENRET","IBERR")
+18 IF $GET(IBERR("DIERR"))=""
Begin DoDot:2
+19 ;THE IEN WHICH WAS JUST ADDED
if $GET(IBIENRET(1))'=""
SET IBOK=IBIENRET(1)
+20 if '+IBOK
SET IBQUIT=1
End DoDot:2
+21 IF $GET(IBERR("DIERR"))'=""
SET IBQUIT=1
End DoDot:1
+22 QUIT 'IBQUIT
+23 ;
ACTVNPI(IBNPI) ;RETURNS ien of ACTIVE NPI IN IB NON/OTHER VA BILLING PROVIDER FILE
+1 ;INPUT IBNPI : The NPI from FB provider under consideration
+2 NEW IBIEN,IBSUB
+3 ;Most recent IEN for this NPI
SET IBIEN=$ORDER(^IBA(355.93,"NPIHISTORY",IBNPI,""),-1)
+4 IF $GET(IBIEN)'=""
Begin DoDot:1
+5 ;MOST recent status for this IEN for this NPI
SET IBSUB=$ORDER(^IBA(355.93,IBIEN,"NPISTATUS","C",IBNPI,""),-1)
+6 if IBSUB=""
SET IBIEN=""
+7 if IBIEN=""
QUIT
+8 if '$DATA(^IBA(355.93,IBIEN,"NPISTATUS","NPISTATUS",1,IBSUB))
SET IBIEN=""
End DoDot:1
+9 QUIT IBIEN
+10 ;
INACTV(IBNPI) ;RETURNS ien of INACTIVE NPI IN IB NON/OTHER VA BILLING PROVIDER FILE
+1 ;INPUT IBNPI : The NPI from FB provider under consideration
+2 NEW IBIEN,IBSUB
+3 SET IBIEN=$ORDER(^IBA(355.93,"NPIHISTORY",IBNPI,""),-1)
+4 IF $GET(IBIEN)'=""
Begin DoDot:1
+5 ;MOST recent status for this NPI
SET IBSUB=$ORDER(^IBA(355.93,IBIEN,"NPISTATUS","C",IBNPI,""),-1)
+6 if IBSUB=""
SET IBIEN=""
+7 if IBIEN=""
QUIT
+8 if '$DATA(^IBA(355.93,IBIEN,"NPISTATUS","NPISTATUS",0,IBSUB))
SET IBIEN=""
End DoDot:1
+9 QUIT IBIEN
+10 ;
RULES(IBNPI) ;Verify that the NPI meets all rules for being added
+1 ; see NPIUSED^IBCEP81 where the input transform on the NPI field that is being bypassed is defined
+2 ; INPUT IBNPI - the NPI about to be added
+3 ;
+4 ; OUTPUT 0 if no ACTIVE records found 1 if ACTIVE in NEW PERSON FILE, 2 IF ACVTIVE IN INSTUTUTION FILE
+5 NEW IBIEN1,IBIEN2,IBRETURN
+6 ;
+7 ;NOT FOUND IN ANY FILES
SET IBRETURN=0
+8 IF IBNPI=""
SET IBRETURN=""
+9 ;ACTIVE in the NEW PERSON file
if +IBNPI&$DATA(^VA(200,"ANPI",IBNPI))
SET IBRETURN=1
+10 ;ACTIVE in the INSTITUTION file
if +IBNPI&$DATA(^DIC(4,"ANPI",IBNPI))
SET IBRETURN=2
+11 QUIT IBRETURN
+12 ;
FBALLOW(IBIEN) ;Returns 1 if FB updates are allowed
+1 ; INPUT : IBIEN - The internal entry number to the IB NON/OTHER VA BILLING PROVIDER FILE
+2 ;
+3 NEW IBRETURN,IBSUB,IBERR
+4 ;
+5 SET IBSUB=9999999
+6 ;ALLOW updates if no entry has been made
SET IBRETURN=1
+7 IF $ORDER(^IBA(355.93,IBIEN,2))=3
Begin DoDot:1
+8 ;get the most recent sub-entry
SET IBSUB=$ORDER(^IBA(355.93,IBIEN,3,IBSUB),-1)
+9 SET IBRETURN=$$GET1^DIQ(355.9351,IBSUB_","_IBIEN_",",".02","I","","")
+10 IF IBRETURN'=0
SET IBRETURN=1
End DoDot:1
+11 QUIT IBRETURN
+12 ;
STRIP(FBPRVNAM) ; Strip off leading and trailing spaces
+1 ;
+2 NEW IBPRVNAM
+3 ;
+4 SET IBPRVNAM=FBPRVNAM
+5 FOR
if $EXTRACT(IBPRVNAM)'=" "
QUIT
SET IBPRVNAM=$EXTRACT(IBPRVNAM,2,$LENGTH(IBPRVNAM))
+6 FOR
if $EXTRACT(IBPRVNAM,$LENGTH(IBPRVNAM))'=" "
QUIT
SET IBPRVNAM=$EXTRACT(FBPRVNAM,1,$LENGTH(IBPRVNAM)-1)
+7 QUIT IBPRVNAM
+8 ;
SETIBFDA(IBRTRN,IBFBINF,IBFDA,IBIEN) ;Populates IBFDA ARRAY with update information
+1 ; INPUT : IBRTRN - an array with current IB information in it
+2 ; IBFBINF - an array with information from FB in it
+3 ; IBFDA - the array which will be used to update the record
+4 ; IBIEN - the IEN of the IB record being updated
+5 ;
+6 ; OUTPUT : POPULATED IBFDA ARRAY IF UPDATES ARE NEEDED
+7 IF IBFBINF("IB TYPE")=1
Begin DoDot:1
+8 IF IBRTRN(355.93,IBIEN_",",".01","I")=IBPRVNAM
Begin DoDot:2
+9 IF IBRTRN(355.93,IBIEN_",",".05","I")'=$GET(IBFBINF("FBADD1"))
SET IBFDA(355.93,IBIEN_",",.05)=IBFBINF("FBADD1")
+10 IF IBRTRN(355.93,IBIEN_",",".1","I")'=$GET(IBFBINF("FBADD2"))
SET IBFDA(355.93,IBIEN_",",.1)=IBFBINF("FBADD2")
+11 IF IBRTRN(355.93,IBIEN_",",".06","I")'=$GET(IBFBINF("FBCITY"))
SET IBFDA(355.93,IBIEN_",",.06)=IBFBINF("FBCITY")
+12 IF IBRTRN(355.93,IBIEN_",",".07","I")'=$GET(IBFBINF("FBSTATE INT"))
SET IBFDA(355.93,IBIEN_",",.07)=IBFBINF("FBSTATE INT")
+13 IF IBRTRN(355.93,IBIEN_",",".08","I")'=$GET(IBFBINF("FBZIP"))
SET IBFDA(355.93,IBIEN_",",.08)=IBFBINF("FBZIP")
+14 IF IBRTRN(355.93,IBIEN_",",".09","I")'=$GET(IBFBINF("FBFACID"))
SET IBFDA(355.93,IBIEN_",",.09)=IBFBINF("FBFACID")
End DoDot:2
+15 IF (IBRTRN(355.93,IBIEN_",",".01","I")'=IBPRVNAM)
Begin DoDot:2
+16 ; When the name changes, everything is wiped out, so needs to be saved again
+17 SET IBFDA(355.93,IBIEN_",",.01)=IBPRVNAM
+18 IF $GET(IBFBINF("FBADD1"))'=""
SET IBFDA(355.93,IBIEN_",",.05)=IBFBINF("FBADD1")
+19 IF $GET(IBFBINF("FBADD2"))'=""
SET IBFDA(355.93,IBIEN_",",.1)=IBFBINF("FBADD2")
+20 IF $GET(IBFBINF("FBCITY"))'=""
SET IBFDA(355.93,IBIEN_",",.06)=IBFBINF("FBCITY")
+21 IF $GET(IBFBINF("FBSTATE"))'=""
SET IBFDA(355.93,IBIEN_",",.07)=IBFBINF("FBSTATE INT")
+22 IF $GET(IBFBINF("FBZIP"))'=""
SET IBFDA(355.93,IBIEN_",",.08)=IBFBINF("FBZIP")
+23 IF $GET(IBFBINF("FBFACID"))'=""
SET IBFDA(355.93,IBIEN_",",.09)=IBFBINF("FBFACID")
End DoDot:2
End DoDot:1
+24 IF IBFBINF("IB TYPE")=2
Begin DoDot:1
+25 IF (IBRTRN(355.93,IBIEN_",",".01","I")'=IBPRVNAM)
SET IBFDA(355.93,IBIEN_",",.01)=IBPRVNAM
End DoDot:1
+26 QUIT
+27 ;
LOCK(IBIEN) ;Locks the #355.93 file or a record in it
+1 ; INPUT : IBIEN - the ien of the record to be locked NULL if a new record is being added
+2 NEW IBLOCK
+3 ;
+4 SET IBLOCK=1
+5 IF $GET(IBIEN)=""
Begin DoDot:1
+6 LOCK +^IBA(355.93):3
+7 IF '$TEST
SET IBLOCK=0
End DoDot:1
+8 IF $GET(IBIEN)'=""
Begin DoDot:1
+9 LOCK +^IBA(355.93,IBIEN):3
+10 IF '$TEST
SET IBLOCK=0
End DoDot:1
+11 QUIT IBLOCK
+12 ;
UNLOCK(IBIEN) ; Unlocks the #355.93 file or a record in it
+1 ; INPUT : IBIEN - the ien of the record to be unlocked or NULL if a new record was added
+2 IF $GET(IBIEN)=""
LOCK -^IBA(355.93)
+3 IF $GET(IBIEN)'=""
LOCK -^IBA(355.93,IBIEN)
+4 QUIT
