BARUFEXU ; IHS/SD/TPF - UTILITY EXTRACT RTN FOR UFMS ;03/26/08
;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;NOV 19, 2007
; NEW ROUTINE-- IHS/IOT/MRS:BAR*1.8*4 UFMS
; This routine checks for certain missing or invalid data in the
; A/R BILL IHS file
; If an error is found, the routine attempts to correct the problem.
; If not it sets the "NOT SENT" flag in the A/R UFMS CASHIER SESSION LOG
; file, and sets the REASON NOT SENT field and quits, returning a null value.
Q
;
GETDUZ2(BARBLN,UDUZ,SESSID,TRDATE,ARBILL) ;EP; EXTRINSIC FUNCTION TO FIND TPB DUZ(2)
;
; This sub-routine returns the Third Party Billing DUZ(2) from the
; A/R BILL IHS file **or** if it is missing, searches the 3P BILL file and
; checks for errors. The routine loops through the TPB BILL file primary
; node (DUZ(2)) and looks for a match with the TPB IEN stored in A/R BILL file
;
; If there is no match, or the TPB IEN, Patient, or Payer info is
; missing, an error is created and the process quits.
;
; If it finds an entry, the routine checks for further matches.
;
; If the Bill Number, Patient, or Payer pointers do not match, an
; error is created and the process quits.
;
; If there are no errors, the routine modifies the A/R BILL IHS file
; and returns the TPB IEN to the calling routine.
;
; ENTERS WITH: BARBLN = AR BILL IEN
; UDUZ = AR USER PTR
; SESSID = SESSION ID
; TRDATE = TRANSMISSION DATE
; ARBILL = A/R BILL NUMBER
; RETURNS: THIRD PARTY DUZ(2) or null and ERROR message
;
;If an error is found, the routine sets the "NOT SENT" flag in the
;A/R UFMS CASHIER SESSION LOG file, and sets the REASON NOT SENT field and quits
;returning a null value.
;
S TPBDUZ2=$P($G(^BARBL(DUZ(2),BARBLN,0)),U,22) ;A/R BILL, 3P DUZ(2)
I TPBDUZ2]"" Q TPBDUZ2 ;Has value
;
N BARPAT,BARPAY,MSG
S IENS=TRDATE_","
S MSG=""
S BARPAT=$P($G(^BARBL(DUZ(2),BARBLN,1)),U)
ERR10 I BARPAT="" D ERR(10) Q "" ;No patient
S BARBACC=$$GETBACC(BARBLN)
I 'BARBACC Q "" ;A/R BILL, A/R ACCOUNT PTR
S BARPAY=+$$IEN^BARVPM ;INSURER PTR
ERR11 I 'BARPAY D ERR(11) Q "" ;No insurer
S ABMIEN=$$GETTPB(BARBLN) ;A/R BILL, 3P IEN (DA)
I ABMIEN="" Q "" ;ERROR AND QUIT
;
N ABMDUZ,ABMTMP
S ABMDUZ=0
F S ABMDUZ=$O(^ABMDBILL(ABMDUZ)) Q:'ABMDUZ D Q:TPBDUZ2]""
.Q:'$D(^ABMDBILL(ABMDUZ,ABMIEN)) ;NOT IN THIS DUZ(2)
.S ABMTMP=$G(^ABMDBILL(ABMDUZ,ABMIEN,0))
ERR13 .I $G(ABMTMP)="" D ERR(13) Q ;TPB missing
.S ABMBIL=$P(ABMTMP,U) ;TPB BILL NUMBER
.S ABMPAT=$P(ABMTMP,U,5) ;TPB PATIEN IEN
.S ABMPAY=$P(ABMTMP,U,8) ;TPB INSURER IEN
ERR14 .I ABMBIL'=$P(ARBILL,"-",1) D ERR(14) Q ;Bill numbers don't match
ERR15 .I ABMPAT'=BARPAT D ERR(15) Q ;Patient pointers don't match
ERR16 .I ABMPAY'=BARPAY D ERR(16) Q ;Insurers don't match
.;HAVE A MATCH -- NOW STUFF DUZ(2) INTO AR BILL FILE
.K DR
.S DIE="^BARBL(DUZ(2),"
.S DA=BARBLN
.S DR="22////"_ABMDUZ ;SET TPB DUZ(2)
.D ^DIE
.S TPBDUZ2=ABMDUZ
ERR17 I 'TPBDUZ2 D ERR(17) ;Can't find TPB DUZ(2)
Q TPBDUZ2
;
GETBACC(BARBLN) ;EP;
; ENTERS WITH: BARBLN = AR BILL IEN
;
; RETURNS: A/R ACCOUNT or null and ERROR message
;
S D0=$P($G(^BARBL(DUZ(2),BARBLN,0)),U,3) ;A/R BILL, A/R ACCOUNT PTR
ERR12 I 'D0 D ERR(12) Q "" ;Pointer is missing
Q D0
;
GETPLOC(BARBLN) ;EP;Check Parent Location
; ENTERS WITH: BARBLN = AR BILL IEN
;
; RETURNS: PARENT LOCATION or null and ERROR message
;
N BARPLOC,BARVLOC
S BARPLOC=$P($G(^BARBL(DUZ(2),BARBLN,0)),U,8) ;A/R BILL, PARENT LOCATION
I BARPLOC Q BARPLOC
I 'BARPLOC D ;Not found/or bad location
.S BARVLOC=$P($G(^BARBL(DUZ(2),BARBLN,1)),U,8) ;A/R BILL, VISIT LOCATION
.S BARPLOC=$$PARENT ;A/R PARENT/SATELITE
ERR18 I 'BARPLOC D ERR(18) Q "" ;Can't find parent
;Have a match -- now stuff DUZ(2) into AR BILL/IHS file
; also updates the ASUFAC-IEN and A/R BILLING SITE/ASUFAC fields
K DR
S DIE="^BARBL(DUZ(2),"
S DA=BARBLN
S DR="8////"_BARPLOC ;Set Parent Location
D ^DIE
Q BARPLOC
;
GETASUFA(BARBLN) ;EP;Check ASUFAC; if not in document, find and populate or error
;
; ENTERS WITH: BARBLN = AR BILL IEN
;
; RETURNS: ASUFAC or null and ERROR message
;
N BARASUF
S BARASUF=$P($P($G(^BARBL(DUZ(2),BARBLN,0)),U,9),"-")
I 'BARASUF D
.S BARASUF=$$GETSUFAC^BARUFUT1
.I BARASUF D
..K DR
..S DIE="^BARBL(DUZ(2),"
..S DA=BARBLN
..S DR=".02////"_BARASUF_"-"_BARBLN ;Set ASUFAC - IEN
..D ^DIE
ERR19 I 'BARASUF D ERR(19) ;Can't build asufac
Q BARASUF
;
ERR(BARREAS) ;EP; Message Center and Error Processor
;ALWAYS WRITE MESSAGE
W !!,"TRANSACTION "_TRDATE_" HAS NOT BEEN SENT BECAUSE"
I BARREAS="I" D Q
.W !,"IS ONE OF A PAIR OF IGNORED TRANSACTIONS IN "_ARBILL
W !,$P($G(^BARUFERR(BARREAS,0)),U,5)
W !," FOR A/R BILL "_ARBILL
N DIR,DIE,DIC,DA,DR
S DA(2)=UDUZ
S DA(1)=SESSID
S DA=TRDATE
S DIE="^BARSESS(DUZ(2),"_UDUZ_",11,"_SESSID_",2,"
S DR=".06////^S X=1;.09///"_$G(BARREAS)
D ^DIE
Q
;
PARENT() ;EP: get parent from parent/satellite file
;
N BARSAT,BARPAR,DA,ASUFAC
S BARSAT=DUZ(2)
S BARPAR=0 ; Parent
; check site active at DOS to ensure bill added to correct site
S DA=0
F S DA=$O(^BAR(90052.06,DA)) Q:DA'>0 D Q:BARPAR
. Q:'$D(^BAR(90052.06,DA,DA)) ; Pos Parent UNDEF Site Parameter
. Q:'$D(^BAR(90052.05,DA,BARSAT)) ; Satellite UNDEF Parent/Satellit
. Q:+$P($G(^BAR(90052.05,DA,BARSAT,0)),U,5) ; Par/Sat not usable
. ; Q if sat NOT active at DT
. I DT<$P($G(^BAR(90052.05,DA,BARSAT,0)),U,6) Q
. ; Q if sat became NOT active before DT
. I $P($G(^BAR(90052.05,DA,BARSAT,0)),U,7),(DT>$P($G(^BAR(90052.05,DA,BARSAT,0)),U,7)) Q
. S BARPAR=$S(BARSAT:$P($G(^BAR(90052.05,DA,BARSAT,0)),U,3),1:"")
Q BARPAR
;
GETTPB(BARBLN) ;EP;
;
; ENTERS WITH: BARBLN = AR BILL IEN
;
; RETURNS: THIRD PARTY IEN or null and ERROR message
;
N ABMIEN
S ABMIEN=$P($G(^BARBL(DUZ(2),BARBLN,0)),U,17) ;A/R BILL, 3P IEN (DA)
ERR20 I ABMIEN="" D ERR(20) Q "" ;No pointer, create error and quit
Q ABMIEN
;
GETTRDT(TPBDUZ2,TPBIEN) ;EP; GET 3P TRANSMISSION DATE
;
;Check if the 3P Bill (Invoice) has been sent to A/R from 3P
;If so, the Invoice # will be returned as ASUFACASUFACIEN
;
N TPBAPDT,TPBEXDT
S UFMSSUFC=""
S TPBAPDT=$$APPRDTTM^ABMUEAPI(TPBDUZ2,TPBIEN) ;API 3P APPROVAL DATE
I TPBAPDT="" D Q UFMSSUFC
ERR21 .D ERR(21) ;3PB not approved
;
;Prelive logic for 'APPLY TO' or ASUFACASUFAC3PIEN string
;If Date/Time Approved < 10/1/2007 then UFMSSUFC=$$PRELIVE instead
;
;If this is true there will be no delay send at all
;
S BAR08DT=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5) ;IHS/SD/SDR bar*1.8*4 SCR100
I TPBAPDT<PRELIVLM!(TPBAPDT<BAR08DT) D Q UFMSSUFC ;IHS/SD/SDR bar*1.8*4 SCR100
.S PRELIV=$$PRELIVE^BARUFUT1(BARAREA,BARITYP)
.S UFMSSUFC=PRELIV
;
I $L($T(TRANSMIT^ABMUEAPI)) D
.S UFMSSUFC=$$TRANSMIT^ABMUEAPI(TPBDUZ2,TPBIEN)
I 'UFMSSUFC D Q UFMSSUFC
ERR22 .D ERR(22) ;3PB bill not sent to UFMS
.S UFMSSUFC="" ;Sometimes UFMSSUFC can be -1
Q UFMSSUFC
BARUFEXU ; IHS/SD/TPF - UTILITY EXTRACT RTN FOR UFMS ;03/26/08
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;NOV 19, 2007
+2 ; NEW ROUTINE-- IHS/IOT/MRS:BAR*1.8*4 UFMS
+3 ; This routine checks for certain missing or invalid data in the
+4 ; A/R BILL IHS file
+5 ; If an error is found, the routine attempts to correct the problem.
+6 ; If not it sets the "NOT SENT" flag in the A/R UFMS CASHIER SESSION LOG
+7 ; file, and sets the REASON NOT SENT field and quits, returning a null value.
+8 QUIT
+9 ;
GETDUZ2(BARBLN,UDUZ,SESSID,TRDATE,ARBILL) ;EP; EXTRINSIC FUNCTION TO FIND TPB DUZ(2)
+1 ;
+2 ; This sub-routine returns the Third Party Billing DUZ(2) from the
+3 ; A/R BILL IHS file **or** if it is missing, searches the 3P BILL file and
+4 ; checks for errors. The routine loops through the TPB BILL file primary
+5 ; node (DUZ(2)) and looks for a match with the TPB IEN stored in A/R BILL file
+6 ;
+7 ; If there is no match, or the TPB IEN, Patient, or Payer info is
+8 ; missing, an error is created and the process quits.
+9 ;
+10 ; If it finds an entry, the routine checks for further matches.
+11 ;
+12 ; If the Bill Number, Patient, or Payer pointers do not match, an
+13 ; error is created and the process quits.
+14 ;
+15 ; If there are no errors, the routine modifies the A/R BILL IHS file
+16 ; and returns the TPB IEN to the calling routine.
+17 ;
+18 ; ENTERS WITH: BARBLN = AR BILL IEN
+19 ; UDUZ = AR USER PTR
+20 ; SESSID = SESSION ID
+21 ; TRDATE = TRANSMISSION DATE
+22 ; ARBILL = A/R BILL NUMBER
+23 ; RETURNS: THIRD PARTY DUZ(2) or null and ERROR message
+24 ;
+25 ;If an error is found, the routine sets the "NOT SENT" flag in the
+26 ;A/R UFMS CASHIER SESSION LOG file, and sets the REASON NOT SENT field and quits
+27 ;returning a null value.
+28 ;
+29 ;A/R BILL, 3P DUZ(2)
SET TPBDUZ2=$PIECE($GET(^BARBL(DUZ(2),BARBLN,0)),U,22)
+30 ;Has value
IF TPBDUZ2]""
QUIT TPBDUZ2
+31 ;
+32 NEW BARPAT,BARPAY,MSG
+33 SET IENS=TRDATE_","
+34 SET MSG=""
+35 SET BARPAT=$PIECE($GET(^BARBL(DUZ(2),BARBLN,1)),U)
ERR10 ;No patient
IF BARPAT=""
DO ERR(10)
QUIT ""
+1 SET BARBACC=$$GETBACC(BARBLN)
+2 ;A/R BILL, A/R ACCOUNT PTR
IF 'BARBACC
QUIT ""
+3 ;INSURER PTR
SET BARPAY=+$$IEN^BARVPM
ERR11 ;No insurer
IF 'BARPAY
DO ERR(11)
QUIT ""
+1 ;A/R BILL, 3P IEN (DA)
SET ABMIEN=$$GETTPB(BARBLN)
+2 ;ERROR AND QUIT
IF ABMIEN=""
QUIT ""
+3 ;
+4 NEW ABMDUZ,ABMTMP
+5 SET ABMDUZ=0
+6 FOR
SET ABMDUZ=$ORDER(^ABMDBILL(ABMDUZ))
IF 'ABMDUZ
QUIT
Begin DoDot:1
+7 ;NOT IN THIS DUZ(2)
IF '$DATA(^ABMDBILL(ABMDUZ,ABMIEN))
QUIT
+8 SET ABMTMP=$GET(^ABMDBILL(ABMDUZ,ABMIEN,0))
ERR13 ;TPB missing
IF $GET(ABMTMP)=""
DO ERR(13)
QUIT
+1 ;TPB BILL NUMBER
SET ABMBIL=$PIECE(ABMTMP,U)
+2 ;TPB PATIEN IEN
SET ABMPAT=$PIECE(ABMTMP,U,5)
+3 ;TPB INSURER IEN
SET ABMPAY=$PIECE(ABMTMP,U,8)
ERR14 ;Bill numbers don't match
IF ABMBIL'=$PIECE(ARBILL,"-",1)
DO ERR(14)
QUIT
ERR15 ;Patient pointers don't match
IF ABMPAT'=BARPAT
DO ERR(15)
QUIT
ERR16 ;Insurers don't match
IF ABMPAY'=BARPAY
DO ERR(16)
QUIT
+1 ;HAVE A MATCH -- NOW STUFF DUZ(2) INTO AR BILL FILE
+2 KILL DR
+3 SET DIE="^BARBL(DUZ(2),"
+4 SET DA=BARBLN
+5 ;SET TPB DUZ(2)
SET DR="22////"_ABMDUZ
+6 DO ^DIE
+7 SET TPBDUZ2=ABMDUZ
End DoDot:1
IF TPBDUZ2]""
QUIT
ERR17 ;Can't find TPB DUZ(2)
IF 'TPBDUZ2
DO ERR(17)
+1 QUIT TPBDUZ2
+2 ;
GETBACC(BARBLN) ;EP;
+1 ; ENTERS WITH: BARBLN = AR BILL IEN
+2 ;
+3 ; RETURNS: A/R ACCOUNT or null and ERROR message
+4 ;
+5 ;A/R BILL, A/R ACCOUNT PTR
SET D0=$PIECE($GET(^BARBL(DUZ(2),BARBLN,0)),U,3)
ERR12 ;Pointer is missing
IF 'D0
DO ERR(12)
QUIT ""
+1 QUIT D0
+2 ;
GETPLOC(BARBLN) ;EP;Check Parent Location
+1 ; ENTERS WITH: BARBLN = AR BILL IEN
+2 ;
+3 ; RETURNS: PARENT LOCATION or null and ERROR message
+4 ;
+5 NEW BARPLOC,BARVLOC
+6 ;A/R BILL, PARENT LOCATION
SET BARPLOC=$PIECE($GET(^BARBL(DUZ(2),BARBLN,0)),U,8)
+7 IF BARPLOC
QUIT BARPLOC
+8 ;Not found/or bad location
IF 'BARPLOC
Begin DoDot:1
+9 ;A/R BILL, VISIT LOCATION
SET BARVLOC=$PIECE($GET(^BARBL(DUZ(2),BARBLN,1)),U,8)
+10 ;A/R PARENT/SATELITE
SET BARPLOC=$$PARENT
End DoDot:1
ERR18 ;Can't find parent
IF 'BARPLOC
DO ERR(18)
QUIT ""
+1 ;Have a match -- now stuff DUZ(2) into AR BILL/IHS file
+2 ; also updates the ASUFAC-IEN and A/R BILLING SITE/ASUFAC fields
+3 KILL DR
+4 SET DIE="^BARBL(DUZ(2),"
+5 SET DA=BARBLN
+6 ;Set Parent Location
SET DR="8////"_BARPLOC
+7 DO ^DIE
+8 QUIT BARPLOC
+9 ;
GETASUFA(BARBLN) ;EP;Check ASUFAC; if not in document, find and populate or error
+1 ;
+2 ; ENTERS WITH: BARBLN = AR BILL IEN
+3 ;
+4 ; RETURNS: ASUFAC or null and ERROR message
+5 ;
+6 NEW BARASUF
+7 SET BARASUF=$PIECE($PIECE($GET(^BARBL(DUZ(2),BARBLN,0)),U,9),"-")
+8 IF 'BARASUF
Begin DoDot:1
+9 SET BARASUF=$$GETSUFAC^BARUFUT1
+10 IF BARASUF
Begin DoDot:2
+11 KILL DR
+12 SET DIE="^BARBL(DUZ(2),"
+13 SET DA=BARBLN
+14 ;Set ASUFAC - IEN
SET DR=".02////"_BARASUF_"-"_BARBLN
+15 DO ^DIE
End DoDot:2
End DoDot:1
ERR19 ;Can't build asufac
IF 'BARASUF
DO ERR(19)
+1 QUIT BARASUF
+2 ;
ERR(BARREAS) ;EP; Message Center and Error Processor
+1 ;ALWAYS WRITE MESSAGE
+2 WRITE !!,"TRANSACTION "_TRDATE_" HAS NOT BEEN SENT BECAUSE"
+3 IF BARREAS="I"
Begin DoDot:1
+4 WRITE !,"IS ONE OF A PAIR OF IGNORED TRANSACTIONS IN "_ARBILL
End DoDot:1
QUIT
+5 WRITE !,$PIECE($GET(^BARUFERR(BARREAS,0)),U,5)
+6 WRITE !," FOR A/R BILL "_ARBILL
+7 NEW DIR,DIE,DIC,DA,DR
+8 SET DA(2)=UDUZ
+9 SET DA(1)=SESSID
+10 SET DA=TRDATE
+11 SET DIE="^BARSESS(DUZ(2),"_UDUZ_",11,"_SESSID_",2,"
+12 SET DR=".06////^S X=1;.09///"_$GET(BARREAS)
+13 DO ^DIE
+14 QUIT
+15 ;
PARENT() ;EP: get parent from parent/satellite file
+1 ;
+2 NEW BARSAT,BARPAR,DA,ASUFAC
+3 SET BARSAT=DUZ(2)
+4 ; Parent
SET BARPAR=0
+5 ; check site active at DOS to ensure bill added to correct site
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^BAR(90052.06,DA))
IF DA'>0
QUIT
Begin DoDot:1
+8 ; Pos Parent UNDEF Site Parameter
IF '$DATA(^BAR(90052.06,DA,DA))
QUIT
+9 ; Satellite UNDEF Parent/Satellit
IF '$DATA(^BAR(90052.05,DA,BARSAT))
QUIT
+10 ; Par/Sat not usable
IF +$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,5)
QUIT
+11 ; Q if sat NOT active at DT
+12 IF DT<$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,6)
QUIT
+13 ; Q if sat became NOT active before DT
+14 IF $PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,7)
IF (DT>$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,7))
QUIT
+15 SET BARPAR=$SELECT(BARSAT:$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,3),1:"")
End DoDot:1
IF BARPAR
QUIT
+16 QUIT BARPAR
+17 ;
GETTPB(BARBLN) ;EP;
+1 ;
+2 ; ENTERS WITH: BARBLN = AR BILL IEN
+3 ;
+4 ; RETURNS: THIRD PARTY IEN or null and ERROR message
+5 ;
+6 NEW ABMIEN
+7 ;A/R BILL, 3P IEN (DA)
SET ABMIEN=$PIECE($GET(^BARBL(DUZ(2),BARBLN,0)),U,17)
ERR20 ;No pointer, create error and quit
IF ABMIEN=""
DO ERR(20)
QUIT ""
+1 QUIT ABMIEN
+2 ;
GETTRDT(TPBDUZ2,TPBIEN) ;EP; GET 3P TRANSMISSION DATE
+1 ;
+2 ;Check if the 3P Bill (Invoice) has been sent to A/R from 3P
+3 ;If so, the Invoice # will be returned as ASUFACASUFACIEN
+4 ;
+5 NEW TPBAPDT,TPBEXDT
+6 SET UFMSSUFC=""
+7 ;API 3P APPROVAL DATE
SET TPBAPDT=$$APPRDTTM^ABMUEAPI(TPBDUZ2,TPBIEN)
+8 IF TPBAPDT=""
Begin DoDot:1
ERR21 ;3PB not approved
DO ERR(21)
End DoDot:1
QUIT UFMSSUFC
+1 ;
+2 ;Prelive logic for 'APPLY TO' or ASUFACASUFAC3PIEN string
+3 ;If Date/Time Approved < 10/1/2007 then UFMSSUFC=$$PRELIVE instead
+4 ;
+5 ;If this is true there will be no delay send at all
+6 ;
+7 ;IHS/SD/SDR bar*1.8*4 SCR100
SET BAR08DT=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5)
+8 ;IHS/SD/SDR bar*1.8*4 SCR100
IF TPBAPDT<PRELIVLM!(TPBAPDT<BAR08DT)
Begin DoDot:1
+9 SET PRELIV=$$PRELIVE^BARUFUT1(BARAREA,BARITYP)
+10 SET UFMSSUFC=PRELIV
End DoDot:1
QUIT UFMSSUFC
+11 ;
+12 IF $LENGTH($TEXT(TRANSMIT^ABMUEAPI))
Begin DoDot:1
+13 SET UFMSSUFC=$$TRANSMIT^ABMUEAPI(TPBDUZ2,TPBIEN)
End DoDot:1
+14 IF 'UFMSSUFC
Begin DoDot:1
ERR22 ;3PB bill not sent to UFMS
DO ERR(22)
+1 ;Sometimes UFMSSUFC can be -1
SET UFMSSUFC=""
End DoDot:1
QUIT UFMSSUFC
+2 QUIT UFMSSUFC
