BARPMUP2 ; IHS/SD/LSL - MANUAL UPLOAD PROCESS ;
;;1.8;IHS ACCOUNTS RECEIVABLE;*24*;OCT 26, 2005;Build 69
;
; IHS/SD/LSL - 12/12/02 - V1.7 - NHA-0601-180049
; Modified to find the correct bill in 3P. Modified routine
; clarity and documentation.
;
; IHS/SD/LSL - 05/08/03 - V1.7 Patch 1 - IM10668
; Modified to not previous run if DUZ(2) not there.
;
; IHS/SD/LSL - 06/09/03 - V1.7 Patch 1
; Modified to set BAR("OPT") to menu option to disquinish
; Upload by date range during AR Bill creation
;
; *********************************************************************
;
;** Manual upload process by approval dates
;
;IHS/SD/SDR JULY 2013 belcourt HEAT118656 - BAR*1.8*.24
;IHS/SD/POT LOCK (MAKE UPL PROCESS EXCLUSIVE) - BAR*1.8*.24
Q
; *********************************************************************
;
EN ;EP - entry
;START NEW CODE START BAR*1.8*.24
L +@($T(+0)):0
E W !!!,"THE UPLOAD OPTION IS BEING ACCESSED BY ANOTHER USER. TRY AGAIN LATER.",! D EOP^BARUTL(1) Q ;ALLOW ONLY ONE INSTANCE RUNNING
;END OF NEW CODE BAR*1.8*.24
D ^BARVKL0
S BARESIG=""
D SIG^XUSESIG ; Get electronic sig
Q:X1=""
I '$D(BARUSR) D INIT^BARUTL ; Initialize A/R environment
S BAROPT="Upload by date" ; LSL - V1.7 Patch 1
S (BAR("CONT"),BARERR)=0
W !
I ($D(^BARTMP("BARUP"))&($D(^BARTMP("BARUP","DUZ(2)")))) D Q ;Previous run detected
. W $$EN^BARVDF("IOF"),!,"A PREVIOUS RUN HAS BEEN DETECTED",!
. D STAT^BARPMUP4 ; Display status of last run
. I $E(BARUSTAT)="C" D ASKNEW Q ; Previous run completed
. D CONT ; Continue last run?
. Q
D NEW ; Begin new run
D EXIT
Q
; *********************************************************************
;
ASKNEW ;
; Previous run complete, ask if new one
W !,"The previous run has completed",!
K DIR
S DIR("A")="Do you want to do a new run"
S DIR("B")="NO"
S DIR(0)="Y"
D ^DIR
K DIR
I Y'=1 Q
W !!,*7,"You MUST write down the BAD bills found for follow up!"
W !,"They did not upload into A/R",!
K DIR
S DIR("A")="Sure you are ready to restart"
S DIR("B")="NO"
S DIR(0)="Y"
D ^DIR
K DIR
I Y'=1 Q
W !
K ^BARTMP("BARUP")
D NEW
D EXIT
Q
; *********************************************************************
;
CONT ;
; Continue previous run
K DIR
S DIR(0)="Y"
S DIR("A")="CONTINUE WITH RESTART"
S DIR("B")="NO"
D ^DIR
K DIR
I 'Y D Q
. W !,"NO RESTART OF UPLOAD",!
. D DX
; Variables obtained from result of STAT^BARPMUP4
S BAR("CONT")=1
S BARQ("RC")="RESUME^BARPMUP2"
S BARQ("RP")="DX^BARPMUP2"
S BARQ("NS")="BAR"
S BARQ("RX")="EXIT^BARPMUP2"
D ^BARDBQUE
Q
; *********************************************************************
;
DX ;
S ^BARTMP("BARUP","STATUS")="COMPLETE"
W $$EN^BARVDF("IOF"),!,"This run is complete. Here's the status",!
D STAT^BARPMUP4
;W !!,+BARCNT_" 3P Bills updated to A/R" ;IHS/SD/SDR belcourt HEAT118656
W !!,(+BARCNT-($O(^BARTMP("BARUP","ERRORS",""),-1)))_" 3P Bills updated to A/R" ;IHS/SD/SDR belcourt HEAT118656
D EOP^BARUTL(1)
Q
; *********************************************************************
;
NEW ;
; Start new run
D GETDOS ; Ask date range
Q:BARSTART<1 ; Date range not entered
D SCANMSG ; Ready? message
I Y'=1 Q ; Not ready
D SCAN ; Scan for 3p Bills
Q
; *********************************************************************
;
GETDOS ;EP
S BARSTART=$$DATE^BARDUTL(1)
I BARSTART<1 Q
;
G1 ;
S BAREND=$$DATE^BARDUTL(2)
I BAREND<1 W ! G GETDOS
I BAREND<BARSTART D G GETDOS
.W *7
.W !!,"The END date must not be before the START date.",!
Q
; *********************************************************************
;
SCANMSG ;
W !!,"This process will scan the 3P BILL file and extract all bills with approval"
W !,"dates between ",$$SDT^BARDUTL(BARSTART)," and ",$$SDT^BARDUTL(BAREND)
W ". The process will check to make"
W !,"sure that a bill that has already been uploaded will not be duplicated.",!
K DIR
S DIR("A")="Are you ready to start"
S DIR("B")="NO"
S DIR(0)="Y"
D ^DIR
K DIR
Q
; *********************************************************************
;
SCAN ;
W !!,"Starting scan process... "
N BARDA,DIC,BARBAL,BARBLNM
S BARCNT=0,BARDA=0,BARBLNM=""
S BARSTART=BARSTART-.1 ;IHS/SD/SDR belcourt HEAT118656
S BAREND=BAREND+.999999 ;IHS/SD/SDR belcourt HEAT118656
S ^BARTMP("BARUP","PREVIOUS START DATE")=BARSTART
S ^BARTMP("BARUP","PREVIOUS END DATE")=BAREND
S BARQ("RC")="RESUME^BARPMUP2"
S BARQ("RP")="DX^BARPMUP2"
S BARQ("NS")="BAR"
S BARQ("RX")="EXIT^BARPMUP2"
D ^BARDBQUE
Q
; *********************************************************************
;
RESUME ;
; Loop DUZ(2)
I $G(^BARTMP("STOP")) Q
S X="ERROR^BARPMUP2",@^%ZOSF("TRAP")
S ^BARTMP("BARUP","STATUS")="IN PROCESS"
S BARHOLD=DUZ(2)
S ^BARTMP("BARUP","STARTDUZ(2)")=DUZ(2) ;IHS/SD/SDR belcourt HEAT118656
S BARERR=0 ;IHS/SD/SDR belcourt HEAT118656
; loop 3P Bill file DUZ(2)
S DUZ(2)=0
S:+BAR("CONT") DUZ(2)=$O(^ABMDBILL(^BARTMP("BARUP","DUZ(2)")),-1)
F S DUZ(2)=$O(^ABMDBILL(DUZ(2))) Q:'+DUZ(2) D LOOPDT
S DUZ(2)=BARHOLD
Q
; *********************************************************************
;
LOOPDT ;
; Loop Date Approved x-ref on 3P bill for selected date range
S ^BARTMP("BARUP","DUZ(2)")=DUZ(2)
S BARAPDT=$O(^ABMDBILL(DUZ(2),"AP",BARSTART),-1)
S:+BAR("CONT") BARAPDT=$O(^ABMDBILL(DUZ(2),"AP",^BARTMP("BARUP","LAST AP DATE",DUZ(2))),-1)
F S BARAPDT=$O(^ABMDBILL(DUZ(2),"AP",BARAPDT)) Q:'+BARAPDT!(BARAPDT>BAREND) D LOOPBILL
Q
; *********************************************************************
;
LOOPBILL ;
;
S ^BARTMP("BARUP","LAST AP DATE",DUZ(2))=BARAPDT
S BARDA=0
;S:+BAR("CONT") BARDA=^BARTMP("BARUP","LAST BILL IEN",DUZ(2)) ;IHS/SD/SDR belcourt HEAT118656
S BARDA=+$G(^BARTMP("BARUP","LAST BILL IEN",DUZ(2))) ;IHS/SD/SDR belcourt HEAT118656
F S BARDA=$O(^ABMDBILL(DUZ(2),"AP",BARAPDT,BARDA)) Q:'+BARDA D DATA
Q
; *********************************************************************
;
DATA ;
; Gather data and upload to A/R
D NOW^%DTC
S Y=%
D DD^%DT
S (^BARTMP("BARUP","LAST DATE"),BARDTS)=Y
S ^BARTMP("BARUP","LAST BILL IEN",DUZ(2))=BARDA
Q:'$D(^ABMDBILL(DUZ(2),BARDA,0)) ; No data on 3P bill, Q
S (BARBAL,BARBLNM)=""
S BARSTAT=$$GET1^DIQ(9002274.4,BARDA,.04,"I")
; Only want approved, billed, partial payment, or transfered bills
;Q:$S(BARSTAT="A":0,BARSTAT="B":0,BARSTAT="P":0,BARSTAT="T":0,1:1) ;IHS/SD/SDR belcourt HEAT118656- BAR*1.8*.24
;all bill statuses EXCEPT REVIEWED
Q:$S(BARSTAT="A":0,BARSTAT="B":0,BARSTAT="P":0,BARSTAT="T":0,BARSTAT="C":0,BARSTAT="X":0,1:1) ;IHS/SD/SDR belcourt HEAT118656- BAR*1.8*.24
S BARBLNM=$$GET1^DIQ(9002274.4,BARDA,.01)
;--------------------------------------
I BARBLNM]"" I $D(^BARTMP("BARUP","BAR_ERRORS",BARBLNM)) D Q
. W !,"BILL # ",BARBLNM," NOT UPLOADED DUE TO: ",$G(^BARTMP("BARUP","ERROR",BARBLNM))
. Q
S ^BARTMP("BARUP","LAST BILL NAME",DUZ(2))=BARBLNM
S BAREXIST=$$FINDAR(BARBLNM) ; Bill already in A/R?
I +BAREXIST D ERROR2 Q ; It is, add error list, q
S DA=BARDA ; IEN to 3P bill
D EXT^ABMAPASS ; Upload to A/R
S BARCNT=BARCNT+1
S ^BARTMP("BARUP","COUNT")=BARCNT
I BARCNT#25=0,$E(IOST)="C",'$D(ZTQUEUED) W "."
Q
; *********************************************************************
;
FINDAR(BARBLNM) ;
; Find the 3P bill in A/R
; If it exists in any A/R environment, put on ERROR list
; Pass in Bill number
; Pass out 1 if found, 0 if not found
N BARDTMP,BARSNM,BARBTMP
S BARBTMP=-1
S BARSNM=$P(BARBLNM,"-")
I $L(BARBLNM)=$L(BARSNM) S BARSNM=BARSNM_" " ;IHS/SD/SDR belcourt HEAT118656
S BARDTMP=0
F S BARDTMP=$O(^BARBL(BARDTMP)) Q:('+BARDTMP!(BARBTMP>0)) D FINDAR2
I BARBTMP>0 Q 1
Q 0
; *********************************************************************
;
FINDAR2 ;
N BARNNM
S BARNNM=$O(^BARBL(BARDTMP,"B",BARSNM),-1)
F S BARNNM=$O(^BARBL(BARDTMP,"B",BARNNM)) Q:(($P(BARNNM,"-")'=BARSNM)!(BARBTMP>0)) D FINDAR3
Q
; *********************************************************************
;
FINDAR3 ;
S BARDATMP=0
F S BARDATMP=$O(^BARBL(BARDTMP,"B",BARNNM,BARDATMP)) Q:('+BARDATMP!(BARBTMP>0)) S BARBTMP=BARDATMP
Q
; *********************************************************************
;
ERROR ;PROCESS AN ERROR
S BARERR=BARERR+1
;N BARTMP ;IHS/SD/SDR 10/28/13 belcourt HEAT118656
S BARTMP="" ;IHS/SD/SDR 10/28/13 belcourt HEAT118656
S ^BARTMP("BARUP","ERRORS",BARERR)=BARBLNM_U_BARDA_U_$$GET1^DIQ(4,DUZ(2),.01)
;S BARTMP=BARBLNM_U_BARDA_U_DUZ(2)_U_$ZE ;NEW CODE ADDED $ZE
S BARTMP=BARBLNM_U_BARDA_U_DUZ(2) ;_U_$ZE ;- BAR*1.8*.24
S ^BARTMP("BARUP","ERRORS",BARERR)=BARTMP
S X="ERROR^BARPMUP2",@^%ZOSF("TRAP")
G RESUME
; *********************************************************************
;
ERROR2 ;
; Process bill already exists error.
S BARERR=BARERR+1
S ^BARTMP("BARUP","ERRORS",BARERR)=BARBLNM_U_BARDA_U_"ALREADY IN A/R"
S X="ERROR^BARPMUP2",@^%ZOSF("TRAP")
Q
; *********************************************************************
;
EXIT ;
S X=^%ZOSF("ERRTN"),@^%ZOSF("TRAP")
D ^BARVKL0
L -@($T(+0)) ;LINE ADDED BAR*1.8*.24
Q ;EOR
BARPMUP2 ; IHS/SD/LSL - MANUAL UPLOAD PROCESS ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;*24*;OCT 26, 2005;Build 69
+2 ;
+3 ; IHS/SD/LSL - 12/12/02 - V1.7 - NHA-0601-180049
+4 ; Modified to find the correct bill in 3P. Modified routine
+5 ; clarity and documentation.
+6 ;
+7 ; IHS/SD/LSL - 05/08/03 - V1.7 Patch 1 - IM10668
+8 ; Modified to not previous run if DUZ(2) not there.
+9 ;
+10 ; IHS/SD/LSL - 06/09/03 - V1.7 Patch 1
+11 ; Modified to set BAR("OPT") to menu option to disquinish
+12 ; Upload by date range during AR Bill creation
+13 ;
+14 ; *********************************************************************
+15 ;
+16 ;** Manual upload process by approval dates
+17 ;
+18 ;IHS/SD/SDR JULY 2013 belcourt HEAT118656 - BAR*1.8*.24
+19 ;IHS/SD/POT LOCK (MAKE UPL PROCESS EXCLUSIVE) - BAR*1.8*.24
+20 QUIT
+21 ; *********************************************************************
+22 ;
EN ;EP - entry
+1 ;START NEW CODE START BAR*1.8*.24
+2 LOCK +@($TEXT(+0)):0
+3 ;ALLOW ONLY ONE INSTANCE RUNNING
IF '$TEST
WRITE !!!,"THE UPLOAD OPTION IS BEING ACCESSED BY ANOTHER USER. TRY AGAIN LATER.",!
DO EOP^BARUTL(1)
QUIT
+4 ;END OF NEW CODE BAR*1.8*.24
+5 DO ^BARVKL0
+6 SET BARESIG=""
+7 ; Get electronic sig
DO SIG^XUSESIG
+8 IF X1=""
QUIT
+9 ; Initialize A/R environment
IF '$DATA(BARUSR)
DO INIT^BARUTL
+10 ; LSL - V1.7 Patch 1
SET BAROPT="Upload by date"
+11 SET (BAR("CONT"),BARERR)=0
+12 WRITE !
+13 ;Previous run detected
IF ($DATA">DATA(^BARTMP("BARUP"))&($DATA">DATA(^BARTMP("BARUP","DUZ(2)"))))
Begin DoDot:1
+14 WRITE $$EN^BARVDF("IOF"),!,"A PREVIOUS RUN HAS BEEN DETECTED",!
+15 ; Display status of last run
DO STAT^BARPMUP4
+16 ; Previous run completed
IF $EXTRACT(BARUSTAT)="C"
DO ASKNEW
QUIT
+17 ; Continue last run?
DO CONT
+18 QUIT
End DoDot:1
QUIT
+19 ; Begin new run
DO NEW
+20 DO EXIT
+21 QUIT
+22 ; *********************************************************************
+23 ;
ASKNEW ;
+1 ; Previous run complete, ask if new one
+2 WRITE !,"The previous run has completed",!
+3 KILL DIR
+4 SET DIR("A")="Do you want to do a new run"
+5 SET DIR("B")="NO"
+6 SET DIR(0)="Y"
+7 DO ^DIR
+8 KILL DIR
+9 IF Y'=1
QUIT
+10 WRITE !!,*7,"You MUST write down the BAD bills found for follow up!"
+11 WRITE !,"They did not upload into A/R",!
+12 KILL DIR
+13 SET DIR("A")="Sure you are ready to restart"
+14 SET DIR("B")="NO"
+15 SET DIR(0)="Y"
+16 DO ^DIR
+17 KILL DIR
+18 IF Y'=1
QUIT
+19 WRITE !
+20 KILL ^BARTMP("BARUP")
+21 DO NEW
+22 DO EXIT
+23 QUIT
+24 ; *********************************************************************
+25 ;
CONT ;
+1 ; Continue previous run
+2 KILL DIR
+3 SET DIR(0)="Y"
+4 SET DIR("A")="CONTINUE WITH RESTART"
+5 SET DIR("B")="NO"
+6 DO ^DIR
+7 KILL DIR
+8 IF 'Y
Begin DoDot:1
+9 WRITE !,"NO RESTART OF UPLOAD",!
+10 DO DX
End DoDot:1
QUIT
+11 ; Variables obtained from result of STAT^BARPMUP4
+12 SET BAR("CONT")=1
+13 SET BARQ("RC")="RESUME^BARPMUP2"
+14 SET BARQ("RP")="DX^BARPMUP2"
+15 SET BARQ("NS")="BAR"
+16 SET BARQ("RX")="EXIT^BARPMUP2"
+17 DO ^BARDBQUE
+18 QUIT
+19 ; *********************************************************************
+20 ;
DX ;
+1 SET ^BARTMP("BARUP","STATUS")="COMPLETE"
+2 WRITE $$EN^BARVDF("IOF"),!,"This run is complete. Here's the status",!
+3 DO STAT^BARPMUP4
+4 ;W !!,+BARCNT_" 3P Bills updated to A/R" ;IHS/SD/SDR belcourt HEAT118656
+5 ;IHS/SD/SDR belcourt HEAT118656
WRITE !!,(+BARCNT-($ORDER(^BARTMP("BARUP","ERRORS",""),-1)))_" 3P Bills updated to A/R"
+6 DO EOP^BARUTL(1)
+7 QUIT
+8 ; *********************************************************************
+9 ;
NEW ;
+1 ; Start new run
+2 ; Ask date range
DO GETDOS
+3 ; Date range not entered
IF BARSTART<1
QUIT
+4 ; Ready? message
DO SCANMSG
+5 ; Not ready
IF Y'=1
QUIT
+6 ; Scan for 3p Bills
DO SCAN
+7 QUIT
+8 ; *********************************************************************
+9 ;
GETDOS ;EP
+1 SET BARSTART=$$DATE^BARDUTL(1)
+2 IF BARSTART<1
QUIT
+3 ;
G1 ;
+1 SET BAREND=$$DATE^BARDUTL(2)
+2 IF BAREND<1
WRITE !
GOTO GETDOS
+3 IF BAREND<BARSTART
Begin DoDot:1
+4 WRITE *7
+5 WRITE !!,"The END date must not be before the START date.",!
End DoDot:1
GOTO GETDOS
+6 QUIT
+7 ; *********************************************************************
+8 ;
SCANMSG ;
+1 WRITE !!,"This process will scan the 3P BILL file and extract all bills with approval"
+2 WRITE !,"dates between ",$$SDT^BARDUTL(BARSTART)," and ",$$SDT^BARDUTL(BAREND)
+3 WRITE ". The process will check to make"
+4 WRITE !,"sure that a bill that has already been uploaded will not be duplicated.",!
+5 KILL DIR
+6 SET DIR("A")="Are you ready to start"
+7 SET DIR("B")="NO"
+8 SET DIR(0)="Y"
+9 DO ^DIR
+10 KILL DIR
+11 QUIT
+12 ; *********************************************************************
+13 ;
SCAN ;
+1 WRITE !!,"Starting scan process... "
+2 NEW BARDA,DIC,BARBAL,BARBLNM
+3 SET BARCNT=0
SET BARDA=0
SET BARBLNM=""
+4 ;IHS/SD/SDR belcourt HEAT118656
SET BARSTART=BARSTART-.1
+5 ;IHS/SD/SDR belcourt HEAT118656
SET BAREND=BAREND+.999999
+6 SET ^BARTMP("BARUP","PREVIOUS START DATE")=BARSTART
+7 SET ^BARTMP("BARUP","PREVIOUS END DATE")=BAREND
+8 SET BARQ("RC")="RESUME^BARPMUP2"
+9 SET BARQ("RP")="DX^BARPMUP2"
+10 SET BARQ("NS")="BAR"
+11 SET BARQ("RX")="EXIT^BARPMUP2"
+12 DO ^BARDBQUE
+13 QUIT
+14 ; *********************************************************************
+15 ;
RESUME ;
+1 ; Loop DUZ(2)
+2 IF $GET(^BARTMP("STOP"))
QUIT
+3 SET X="ERROR^BARPMUP2"
SET @^%ZOSF("TRAP")
+4 SET ^BARTMP("BARUP","STATUS")="IN PROCESS"
+5 SET BARHOLD=DUZ(2)
+6 ;IHS/SD/SDR belcourt HEAT118656
SET ^BARTMP("BARUP","STARTDUZ(2)")=DUZ(2)
+7 ;IHS/SD/SDR belcourt HEAT118656
SET BARERR=0
+8 ; loop 3P Bill file DUZ(2)
+9 SET DUZ(2)=0
+10 IF +BAR("CONT")
SET DUZ(2)=$ORDER(^ABMDBILL(^BARTMP("BARUP","DUZ(2)")),-1)
+11 FOR
SET DUZ(2)=$ORDER(^ABMDBILL(DUZ(2)))
IF '+DUZ(2)
QUIT
DO LOOPDT
+12 SET DUZ(2)=BARHOLD
+13 QUIT
+14 ; *********************************************************************
+15 ;
LOOPDT ;
+1 ; Loop Date Approved x-ref on 3P bill for selected date range
+2 SET ^BARTMP("BARUP","DUZ(2)")=DUZ(2)
+3 SET BARAPDT=$ORDER(^ABMDBILL(DUZ(2),"AP",BARSTART),-1)
+4 IF +BAR("CONT")
SET BARAPDT=$ORDER(^ABMDBILL(DUZ(2),"AP",^BARTMP("BARUP","LAST AP DATE",DUZ(2))),-1)
+5 FOR
SET BARAPDT=$ORDER(^ABMDBILL(DUZ(2),"AP",BARAPDT))
IF '+BARAPDT!(BARAPDT>BAREND)
QUIT
DO LOOPBILL
+6 QUIT
+7 ; *********************************************************************
+8 ;
LOOPBILL ;
+1 ;
+2 SET ^BARTMP("BARUP","LAST AP DATE",DUZ(2))=BARAPDT
+3 SET BARDA=0
+4 ;S:+BAR("CONT") BARDA=^BARTMP("BARUP","LAST BILL IEN",DUZ(2)) ;IHS/SD/SDR belcourt HEAT118656
+5 ;IHS/SD/SDR belcourt HEAT118656
SET BARDA=+$GET(^BARTMP("BARUP","LAST BILL IEN",DUZ(2)))
+6 FOR
SET BARDA=$ORDER(^ABMDBILL(DUZ(2),"AP",BARAPDT,BARDA))
IF '+BARDA
QUIT
DO DATA
+7 QUIT
+8 ; *********************************************************************
+9 ;
DATA ;
+1 ; Gather data and upload to A/R
+2 DO NOW^%DTC
+3 SET Y=%
+4 DO DD^%DT
+5 SET (^BARTMP("BARUP","LAST DATE"),BARDTS)=Y
+6 SET ^BARTMP("BARUP","LAST BILL IEN",DUZ(2))=BARDA
+7 ; No data on 3P bill, Q
IF '$DATA(^ABMDBILL(DUZ(2),BARDA,0))
QUIT
+8 SET (BARBAL,BARBLNM)=""
+9 SET BARSTAT=$$GET1^DIQ(9002274.4,BARDA,.04,"I")
+10 ; Only want approved, billed, partial payment, or transfered bills
+11 ;Q:$S(BARSTAT="A":0,BARSTAT="B":0,BARSTAT="P":0,BARSTAT="T":0,1:1) ;IHS/SD/SDR belcourt HEAT118656- BAR*1.8*.24
+12 ;all bill statuses EXCEPT REVIEWED
+13 ;IHS/SD/SDR belcourt HEAT118656- BAR*1.8*.24
IF $SELECT(BARSTAT="A"
QUIT
+14 SET BARBLNM=$$GET1^DIQ(9002274.4,BARDA,.01)
+15 ;--------------------------------------
+16 IF BARBLNM]""
IF $DATA(^BARTMP("BARUP","BAR_ERRORS",BARBLNM))
Begin DoDot:1
+17 WRITE !,"BILL # ",BARBLNM," NOT UPLOADED DUE TO: ",$GET(^BARTMP("BARUP","ERROR",BARBLNM))
+18 QUIT
End DoDot:1
QUIT
+19 SET ^BARTMP("BARUP","LAST BILL NAME",DUZ(2))=BARBLNM
+20 ; Bill already in A/R?
SET BAREXIST=$$FINDAR(BARBLNM)
+21 ; It is, add error list, q
IF +BAREXIST
DO ERROR2
QUIT
+22 ; IEN to 3P bill
SET DA=BARDA
+23 ; Upload to A/R
DO EXT^ABMAPASS
+24 SET BARCNT=BARCNT+1
+25 SET ^BARTMP("BARUP","COUNT")=BARCNT
+26 IF BARCNT#25=0
IF $EXTRACT(IOST)="C"
IF '$DATA(ZTQUEUED)
WRITE "."
+27 QUIT
+28 ; *********************************************************************
+29 ;
FINDAR(BARBLNM) ;
+1 ; Find the 3P bill in A/R
+2 ; If it exists in any A/R environment, put on ERROR list
+3 ; Pass in Bill number
+4 ; Pass out 1 if found, 0 if not found
+5 NEW BARDTMP,BARSNM,BARBTMP
+6 SET BARBTMP=-1
+7 SET BARSNM=$PIECE(BARBLNM,"-")
+8 ;IHS/SD/SDR belcourt HEAT118656
IF $LENGTH(BARBLNM)=$LENGTH(BARSNM)
SET BARSNM=BARSNM_" "
+9 SET BARDTMP=0
+10 FOR
SET BARDTMP=$ORDER(^BARBL(BARDTMP))
IF ('+BARDTMP!(BARBTMP>0))
QUIT
DO FINDAR2
+11 IF BARBTMP>0
QUIT 1
+12 QUIT 0
+13 ; *********************************************************************
+14 ;
FINDAR2 ;
+1 NEW BARNNM
+2 SET BARNNM=$ORDER(^BARBL(BARDTMP,"B",BARSNM),-1)
+3 FOR
SET BARNNM=$ORDER(^BARBL(BARDTMP,"B",BARNNM))
IF (($PIECE(BARNNM,"-")'=BARSNM)!(BARBTMP>0))
QUIT
DO FINDAR3
+4 QUIT
+5 ; *********************************************************************
+6 ;
FINDAR3 ;
+1 SET BARDATMP=0
+2 FOR
SET BARDATMP=$ORDER(^BARBL(BARDTMP,"B",BARNNM,BARDATMP))
IF ('+BARDATMP!(BARBTMP>0))
QUIT
SET BARBTMP=BARDATMP
+3 QUIT
+4 ; *********************************************************************
+5 ;
ERROR ;PROCESS AN ERROR
+1 SET BARERR=BARERR+1
+2 ;N BARTMP ;IHS/SD/SDR 10/28/13 belcourt HEAT118656
+3 ;IHS/SD/SDR 10/28/13 belcourt HEAT118656
SET BARTMP=""
+4 SET ^BARTMP("BARUP","ERRORS",BARERR)=BARBLNM_U_BARDA_U_$$GET1^DIQ(4,DUZ(2),.01)
+5 ;S BARTMP=BARBLNM_U_BARDA_U_DUZ(2)_U_$ZE ;NEW CODE ADDED $ZE
+6 ;_U_$ZE ;- BAR*1.8*.24
SET BARTMP=BARBLNM_U_BARDA_U_DUZ(2)
+7 SET ^BARTMP("BARUP","ERRORS",BARERR)=BARTMP
+8 SET X="ERROR^BARPMUP2"
SET @^%ZOSF("TRAP")
+9 GOTO RESUME
+10 ; *********************************************************************
+11 ;
ERROR2 ;
+1 ; Process bill already exists error.
+2 SET BARERR=BARERR+1
+3 SET ^BARTMP("BARUP","ERRORS",BARERR)=BARBLNM_U_BARDA_U_"ALREADY IN A/R"
+4 SET X="ERROR^BARPMUP2"
SET @^%ZOSF("TRAP")
+5 QUIT
+6 ; *********************************************************************
+7 ;
EXIT ;
+1 SET X=^%ZOSF("ERRTN")
SET @^%ZOSF("TRAP")
+2 DO ^BARVKL0
+3 ;LINE ADDED BAR*1.8*.24
LOCK -@($TEXT(+0))
+4 ;EOR
QUIT
