BARUFEX1 ; IHS/SD/TPF - MAIN EXTRACT RTN FOR UFMS (CONTINUED FROM BARUFEX) ; 10/31/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**7,9,16,19,20,23,28**;OCT 26,2005;Build 92
;NEW ROUTINE -- to meet SAC size requirements ;MRS:BAR*1.8*7
;Heavily modified to prevent duplicate records ;MRS:BAR*1.8*7 IM30562
;New functionality; only enters from single PULLSESS EP ;MRS:BAR*1.8*7 IM30562
;MAR 2013 P.OTTIS ADDED NEW VA billing
;IHS/SD/SDR 1.8*28 CR8349 HEAT293633 - Added code so ignore transactions won't transmit to UFMS.
Q
;
GETDATA(TRDATE,RECORD,TOTAMT,UDUZ,SESSID) ;EP - PULL DATA FROM ONE TRANSACTION DATE/TIME
;Q:$D(^BARSESS(DUZ(2),"ST",TRDATE)) ;TRANSACTION HAS BEEN TRANSMITTED INDIVIDUALLY BAR*1.8*4
Q:'$$OK(TRDATE,SESSID) ;DON'T SEND IF ALREADY SENT;MRS:BAR*1.8*7 IM30562
Q:'$$LCKTR(TRDATE,SESSID) ;CAN'T LOCK THE TRANSACTION NODE
D DATA
LOCK -^BARTR(DUZ(2),TRDATE,6)
Q
;
DATA ;LOCAL ENTRY POINT
W "."
K IENS,UFMSTRDT,ARCREDIT,ARDEBIT,ARBILL,UFMSBILL,TPBIEN,TPBLOC,BARACCT,TPBSTAT
K ARCOL,ARCOLIN,ARASUFAC,ARCOLDT,TRANTYPE,UFMSTYPE,UFMSAMT,APPLYTO,BARAREA,PARNTLOC
K PRELIV,PRELIVLM,REVERSAL,ARCRDEB,UFMSSUFC,BARREAS
S PRELIVLM=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5) ;MRS:BAR*1.8*7 IM30562
;I DT>3070930 S PRELIVLM=3071001 I 1 ;ORIGINAL UFMS RELEASE DATE ;MRS:BAR*1.7 IM30562
;E S PRELIVLM=$P($$LAST^XPDUTL("IHS ACCOUNTS RECEIVABLE",1.8),U,2) ;FOR PRE 10-1-2007 RELEASE;MRS:BAR*1.7 IM30562
S IENS=TRDATE_","
S Y=TRDATE X ^DD("DD") S UFMSTRDT=Y
S ARBILL=$$GET1^DIQ(90050.03,IENS,4,"E") ;A/R TRANSACTIONS, BILL (A/R)
Q:ARBILL="" ;SCREEN OUT TRANSACTIONS WITH NO A/R BILL
S ARCREDIT=$$GET1^DIQ(90050.03,IENS,2,"E") ;A/R TRANSACTIONS, CREDIT
S ARDEBIT=$$GET1^DIQ(90050.03,IENS,3,"E") ;A/R TRANSACTIONS, DEBIT
S ARCRDEB=$$GET1^DIQ(90050.03,IENS,3.5,"E") ;A/R TRANSACTIONS, CREDIT - DEBIT ;MRS:BAR*1.8*4
I ARCRDEB=0 Q ;DON'T SEND ZERO DOLLAR TX'S
S ARBILLIN=$$GET1^DIQ(90050.03,IENS,4,"I") ;A/R TRANSACTIONS, BILL (A/R) PTR
S CURBLAMT=$$GET1^DIQ(90050.01,ARBILLIN_",",15,"I") ;A/R BILL, CURRENT BILL AMOUNT BAR*1.8*4 PER MEETING
;
;BAR*1.8*4 SCR56,58
I CURBLAMT<0 D Q ;DON'T SEND NEGATIVE BALANCE TX
ERR1 .D ERR^BARUFEXU(1)
;
;BAR*1.8*4 IM26555,IM26610 ET AL SCR80 4.1.1
S TPBDUZ2=$$GETDUZ2^BARUFEXU(ARBILLIN,UDUZ,$G(SESSID),TRDATE,ARBILL)
Q:'TPBDUZ2
S TPBIEN=$$GETTPB^BARUFEXU(ARBILLIN) ;A/R BILL, 3P DUZ(2) BAR*1.8*4 IM26555,IM26610 ET AL
Q:'TPBIEN ;MRS:BAR*1.8*4 SCR80 4.1.1
I '$$IHS^BARUFUT(TPBDUZ2) D Q ;CHECK FOR SATELITE MRS:BAR*1.8*4 SCR80 4.1.1
. ;;;I '$$IHSERA^BARUFUT(TPBDUZ2) D Q ;P.OTT CHECK FOR SATELITE MRS:BAR*1.8*4 SCR80 4.1.1
. W !,"NON-IHS FACILITY BILL -- TRANSACTION NOT SENT FOR ",ARBILL
;
S BILASUFA=$P($$GET1^DIQ(90050.01,ARBILLIN_",",9,"I"),"-") ;A/R BILL, A/R BILLING SITE/ASUFAC BAR*1.8*4 ITEM 3 SCR58
;
;CHECK EXCLUSION TABLE (BAR v1.8 patch 3 SCR2 UFMS)
;IF 0 ITS IN THE EXCLUSION TABLE
;IF -1 THE API CAN'T FIND THE 3P BILL AND THE A/R BILL IS PROBABLY A DUPLICATE
I $$BILL^ABMUEAPI(TPBDUZ2,TPBIEN)<1 D Q
.W !,"3P EXCLUDED BILL -- TRANSACTION NOT SENT FOR ",ARBILL
;
S BARACCT=$$GETBACC^BARUFEXU(ARBILLIN) ;A/R BILL, A/R ACCOUNT
Q:'BARACCT ;MRS:BAR*1.8*4
S PARNTLOC=$$GETPLOC^BARUFEXU(ARBILLIN) ;A/R BILL, PARENT LOCATION
Q:'PARNTLOC ;MRS:BAR*1.8*4
S ARCOLITM=$$GET1^DIQ(90050.03,IENS,15,"E") ;A/R TRANSACTIONS, COLLECTION ITEM
S ARCOLB=$$GET1^DIQ(90050.03,IENS,14,"E") ;A/R TRANSACTIONS, A/R COLLECTION BATCH
S ARCOLIN=$$GET1^DIQ(90050.03,IENS,14,"I") ;A/R TRANSACTIONS, A/R COLLECTION BATCH PTR
;
S BARAREA=$$GET1^DIQ(9999999.06,PARNTLOC_",",.04,"I") ;LOCATION, AREA PTR
;
S D0=BARACCT
S BARITYP=$$VALI^BARVPM(8) ;GET 'VIP INSURER TYPE' CODE
Q:BARITYP="I"!(BARITYP="T") ;EXCLUDE 'INDIAN' OR 'THIRD PARTY BILLING' PER MEETING OF 5/4/2007
;
; Check 3P transmitted date
S UFMSSUFC=$$GETTRDT^BARUFEXU(TPBDUZ2,TPBIEN)
I UFMSSUFC="" Q ;Not transmitted from 3P
;
;REGULAR OLD LOGIC FOR 'APPLY TO' OR ASUFACASUFAC3PIEN STRING
;S UFMSSUFC=$$ASUFAC^BARUFUT1(DUZ(2),TRDATE)
;
S ARCOLB=$$GET1^DIQ(90051.01,ARCOLIN_",",.01,"I") ;A/R COLLECTION BATCH, NAME
S ARCOLDT=$$GET1^DIQ(90051.01,ARCOLIN_",",4,"I") ;A/R COLLECTION BATCH, OPENED DATE/TIME
S TDNDATE=$$GET1^DIQ(90051.01,ARCOLIN_",",30,"I") ;A/R COLLECTION BATCH, TDN/DATE ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
S TDNDATE=$$FMTE^XLFDT($P(TDNDATE,"@"),"5DZ")
S ARCOLDT=$$FMTE^XLFDT($P(ARCOLDT,"@"),"5DZ")
S UFMSTRDT=$$FMTE^XLFDT($P(TRDATE,"."),"5DZ")
S TRANTYPE=$$GET1^DIQ(90050.03,IENS,101,"E") ;A/R TRANSACTIONS, TRANSACTION TYPE
S ADJCAT=$$GET1^DIQ(90050.03,IENS,102,"E") ;A/R TRANSACTIONS, ADJUSTMENT CATEGORY
;
;MAIN SCREEN FOR TRANSACTIONS TO PULL
S UFMSAMT=ARCREDIT-ARDEBIT
I TRANTYPE="PAYMENT" D I 1
.S UFMSTYPE="R"
.S UFMSSIGN=$S(UFMSAMT>0!(UFMSAMT=0):"+",1:"-") ;keep sign
; IHS/SD/PKD 1.8*19 9/23/10 Include Status Change (send to Collection=993) transactions
; E I TRANTYPE[("ADJUST")!(TRANTYPE[("REFUND") D I 1
E I TRANTYPE[("ADJUST")!(TRANTYPE[("REFUND")!(TRANTYPE[("STATUS CHANGE"))!(TRANTYPE["993")) D I 1
.S UFMSTYPE="A"
.S UFMSSIGN=$S(UFMSAMT>0!(UFMSAMT=0):"-",1:"+") ;reverse the sign on "A" records
E Q
;Modifications to fix Transmission/Approvals dates ;and UFMSSUFC MRS:BAR*1.8*4
;NEW CODE FOR REVERSALS ;MRS:BAR*1.8*4
;CHECK REVERSAL DATES AND FIX IF POSSIBLE
S BARRIPAC=$$REVERSAL^BARUFEX3()
Q:'ARBILL
;
;MOVED IPAC SET TO HERE BECAUSE REVERSAL PROCESS CAN CHANGE IPAC ;MRS:BAR*1.8*4
;S IPAC=$$GET1^DIQ(90051.1101,ARCOLITM_","_ARCOLIN_",",20,"I") ;A/R COLLECTION BATCH, TREASURY DEPOSIT SCHEDULE NUMBER/IPAC ;MRS:BAR*1.8*9
S IPAC=$$GET1^DIQ(90051.1101,ARCOLITM_","_ARCOLIN_",",20) ;A/R COLLECTION BATCH, TREASURY DEPOSIT SCHEDULE NUMBER/IPAC ;MRS:BAR*1.8*9
;
;I IPAC["NONPAY"!(BARRIPAC["NONPAY") D Q ;DON'T SEND NONPAYMENTS ;bar*1.8*4 SDR
I UFMSTYPE="R",(IPAC["NONPAY")!(BARRIPAC["NONPAY") D Q ;DON'T SEND NONPAYMENTS ;bar*1.8*4 SDR
ERR2 .D ERR^BARUFEXU(2)
;
S:IPAC="" IPAC="PRE-UFMS_COLLECTIONS" ;FUNCTION ABOVE TAKES CARE OF NULL
S:UFMSTYPE="A" IPAC="" ;per UFMS THE FIELD WILL BE BLANK FOR ADJUSTMENTS
I BARRIPAC]"" S IPAC=BARRIPAC ;Re-set schedule number with original ipac
;
CONT ; ALL QUIT CONDITIONS HAVE BEEN MET
; LET'S UPDATE THE 'APPLY TO' FIELD IN THE SESSION LOG FILE
;
;KILL THE 'NOT SENT FLAG'
I $$GET1^DIQ(90057.110102,TRDATE_","_SESSID_","_UDUZ_",",.06,"I") D
.K DIR,DIE,DIC,DA,DR
.S DA(2)=UDUZ
.S DA(1)=SESSID
.S DA=TRDATE
.S DIE="^BARSESS(DUZ(2),"_DA(2)_",11,"_DA(1)_",2,"
.S DR=".06///@;.07////^S X=1;.08///^S X=$G(BARFILE)"
.D ^DIE
.K DIR,DIE,DIC,DA,DR
.W !!,"TRANSACTION "_TRDATE_" "_ARBILL ;MRS:BAR*1.8*4
.W !,"HAS BEEN SENT THAT PREVIOUSLY WAS NOT SENT" ;MRS:BAR*1.8*4
;
S REVERSAL=$P($$GET1^DIQ(90050.03,TRDATE_",",110,"I"),".")
;I REVERSAL='0,(REVERSAL]"") D ;MRS:BAR*1.8*9
I REVERSAL'=0,(REVERSAL]"") D ;MRS:BAR*1.8*9
.S UFMSTRDT=$$FMTE^XLFDT(REVERSAL,"5DZ")
;LETS PAD THE FIELDS
S UFMSCOLB=$$FILLSTR^BARUFUT1(ARCOLB,149,"R"," ") ;A/R COLLECTION BATCH NAME
S UFMSTRDT=$$FILLSTR^BARUFUT1(UFMSTRDT,10,"R"," ") ;A/R TRANSACTION DATE MM/DD/YYYY
S UFMSAMT=$$FILLDOL^BARUFUT1(UFMSAMT,20,"R",0) ;TRANSACTION AMT W/O SIGN
S UFMSSUFC=$$DBCK(UFMSSUFC) ;DOUBLE CHECK/RESET IF NECESSARY
;S UFMSSUFC=$$FILLSTR^BARUFUT1(UFMSSUFC,20,"L"," ") ;ASUFACAUSFAC3PIEN ;MRS:BAR*1.8*9 HEAT529
S UFMSSUFC=$$FILLSTR^BARUFUT1(UFMSSUFC,40,"L"," ") ;ASUFACAUSFAC3PIEN ;MRS:BAR*1.8*9 HEAT529
S UFMSIPAC=$$FILLSTR^BARUFUT1(IPAC,20,"R"," ") ;SCHEDULE NUMBER
S RPMSADJ=$$FILLSTR^BARUFUT1("",50,"R"," ") ;NOT POPULATED YET
S RPMSAMT=$$FILLSTR^BARUFUT1("",30,"R"," ") ;NOT POPULATED YET
S UFMSCODT=$$FILLSTR^BARUFUT1(ARCOLDT,10,"R"," ") ;COLLECTION BATCH DATE ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
S TDNDATE=$$FILLSTR^BARUFUT1(TDNDATE,10,"R"," ") ;TDN/DATE ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
;BEGIN BAR*1.8*4 ITEM 3 SCR58
S UNIQUEID=$$FILLSTR^BARUFUT1(TRDATE,14,"L",0)
I $E($TR(UFMSSUFC," "))?.A D I 1 ;IF PRE-LIVE 'APPLY TO' THEN GET UNIQUE ID DIFFERENTLY
.S PSUFAC=$$GETSUFAC^BARUFUT1()
.S:PSUFAC="" PSUFAC="000000"
.S:BILASUFA="" BILASUFA="000000"
.S PRESUFAC=PSUFAC_BILASUFA_TPBIEN ;ADRIAN APPROVED THE USE OF BILASUFA
.;S PRESUFAC=$$FILLSTR^BARUFUT1(PRESUFAC,20,"L"," ") ;MRS:BAR*1.8*9 HEAT529
.S PRESUFAC=$$FILLSTR^BARUFUT1(PRESUFAC,40,"L"," ") ;MRS:BAR*1.8*9 HEAT529
.S UNIQUEID=UNIQUEID_"|"_$TR(PRESUFAC," ")
E S UNIQUEID=UNIQUEID_"|"_$TR(UFMSSUFC," ")
S UNIQUEID=$$FILLSTR^BARUFUT1(UNIQUEID,150,"L"," ")
;END
;
;BEGIN BAR*1.8*4 ITEM 3 SCR58
;AND MRS:BAR*1.8*7 IM30562
SET ;EP -
;S ^BARUFEX($J,RECORD)=$G(UFMSTYPE)_$G(UFMSCOLB)_$G(UFMSTRDT)_$G(UFMSSIGN)_$G(UFMSAMT)_$G(UFMSSUFC)_$G(UFMSIPAC)_$G(RPMSADJ)_$G(RPMSAMT)_$G(UNIQUEID)
I UFMSTYPE="R" S ^BARUFEX($J,RECORD)=$G(UFMSTYPE)_$G(UFMSCOLB)_$G(UFMSTRDT)_$G(UFMSSIGN)_$G(UFMSAMT)_$G(UFMSSUFC)_$G(UFMSIPAC)_$G(RPMSADJ)_$G(RPMSAMT)_$G(UNIQUEID)_$G(TDNDATE)_$G(UFMSCODT) ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
E S ^BARUFEX($J,RECORD)=$G(UFMSTYPE)_$G(UFMSCOLB)_$G(UFMSTRDT)_$G(UFMSSIGN)_$G(UFMSAMT)_$G(UFMSSUFC)_$G(UFMSIPAC)_$G(RPMSADJ)_$G(RPMSAMT)_$G(UNIQUEID) ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
D UPSTR(TRDATE,BARNOW,DUZ,($P(UNIQUEID,"|",2))) ;UDATE SESSION FILE
;D UPTR(TRDATE,BARNOW,BARFILE,($P(UNIQUEID,"|",2)),DUZ) ;UPDATE TRANSACTION FILE ;MRS:BAR*1.8*9 IM30945
D UPTR(TRDATE,SESSID,BARFILE,($P(UNIQUEID,"|",2)),DUZ) ;UPDATE TRANSACTION FILE ;MRS:BAR*1.8*9 IM30945
;END
;IHS/SD/PKD 3/2/11 1.8*20
; Check to set ^BARSESS(DUZ(2),USER,11,SESSID,21,n,0)
; Call same code as Session being exported for the 1st time
; Update with UFMS FILENAME if not already there. Was missing for "NS" TRX's
; UDUZ - Original Cashier
D SET^BARUFUT0(UDUZ,SESSID)
; END 1.8*20
S RECORD=RECORD+1
S UFMSAMT=UFMSSIGN_UFMSAMT
S TOTAMT=TOTAMT+UFMSAMT
Q
;
UPSTR(A,D,Z,ID) ;UPDATE 'APPLY TO' AND THE TRANSMITTED? FIELD IN THE SESSION LOG FILE ;MRS:BAR*1.8*7 IM30562
;PUT INTO EFFECT FOR ALL TRANSMISSION WITH PATCH 7
;ENTERS WITH A = TRDATE
; D = TRANSMISSION DATE
; Z = DUZ OF CASHIER
; ID = APPLY TO/UNIQUEID
K DIR,DIC,DIE,DR,DA
S DA(2)=UDUZ
S DA(1)=SESSID
S DA=A
S DR=".02///^S X=1"
S DR=DR_";.03////"_Z
S DR=DR_";.04////"_D
S DR=DR_";.05////"_$TR(ID," ")
S DIE="^BARSESS(DUZ(2),"_DA(2)_",11,"_DA(1)_",2,"
D ^DIE
Q
;
UPTR(A,D,F,ID,Z) ;UPDATE THE NEW FIELDS IN A/R TRANSACTION FILE ;MRS:BAR*1.8*7 IM30562
;PUT INTO EFFECT WITH PATCH 7
;ENTERS WITH A = TRDATE
; D = DATE TRANSMITTED (CAN BE EARLIER THAN TODAY)--CHANGED TO: ;MRS:BAR*1.8*9 IM30945
; SESSION ID DATE/TIME ;MRS:BAR*1.8*9 IM30945
; F = UFMS FILE NAME (CAN BE NULL)
; ID = APPLY TO OR UNIQUEID
; Z = DUZ OF CASHIER
K DIR,DIC,DIE,DR,DA
S DA=A
S DR="601////"_F ;UFMS FILE NAME
S DR=DR_";602////"_D
S DR=DR_";603////"_Z
S DR=DR_";604////"_$TR(ID," ") ;APPLY TO
S DIE="^BARTR(DUZ(2),"
D ^DIE
Q
;
OK(A,B) ;CHECK A/R TRANSACTION AND SESSION FILES FOR TRANSMISSION DATES;MRS:BAR*1.8*7 IM30562
;PUT INTO EFFECT WITH PATCH 7
;ENTERS WITH A = TRDATE
; B = SESSID
N OK,TR0,S0,TRFILE,TRDT,TRDUZ,TRID,SDUZ,SDT,SID,SFILE
S OK=0
S TR0=$G(^BARTR(DUZ(2),A,6)) ;GET TRANSACTION TRANSMITTED INFO IF THERE
S S0=$G(^BARSESS(DUZ(2),UDUZ,11,B,2,A,0))
I $G(TR0)="",$G(S0)="" Q 1 ;NOT TRANSMITTED, OK TO GO
S TRDT=$P(TR0,U,2) ;SESSION DATE/TIME FROM TRANSACTION FILE
S SDT=$P(S0,U,4) ;DATE TRANSMITTED FROM SESSION FILE
I $P($G(^BARTR(DUZ(2),A,1)),U,12)="I" Q 0 ;ignored trans - don't send ;bar*1.8*28 IHS/SD/SDR CR8349 HEAT293633
I TRDT="",SDT="" Q 1 ;NOT TRANSMITTED, OK TO GO
S TRFILE=$P(TR0,U)
S TRDUZ=$P(TR0,U,3)
S TRID=$P(TR0,U,4)
S SDUZ=$P(S0,U,3) ;TRANSMITTED BY
S SID=$P(S0,U,5) ;APPLY TO/UNIQUEID
I TRDT]""&(SDT]"") D MSG(27,TRDT,TRDATE) Q 0 ;ALREADY SENT AND DATA IN BOTH FILES
S SFILE=""
S:SDUZ]"" SFILE=$P($G(^BARSESS(DUZ(2),UDUZ,11,B,21,A,0)),U,2) ;UFMS FILE NAME
I SDT]""&(TRDT="") D UPTR(A,B,SFILE,SDUZ,SID),MSG(27,SDT,A) Q 0 ;SET A/R TRANSACTION FILE W/INFO FROM SESSION FIELDS
I SDT=""&(TRDT]"") D UPSTR(A,TRDT,TRDUZ,TRID),MSG(27,TRDT,A) Q 0 ;SET SESSION TRANSMITTED? FIELDS
Q 1 ;OK TO TRANSMIT
;
MSG(X,Y,Z) ;WRITE ERROR MESSAGE MRS:BAR*1.8*9 IM30945
W !,$P($G(^BARUFERR(X,0)),U,5)
W " Date:"_Y_" for Transaction/Session: ",Z
Q
;
LCKTR(TRDATE,SESSID) ;EP; LOCK A/R SESSION FILE
;
N X
F I=1:1:5 LOCK +^BARSESS(DUZ(2),UDUZ,11,SESSID):2 S X=$T Q:X
ERR26 I 'X W !,"NOT PROCESSING SESSION " D
.D MSG(26,$G(TRDATE),SESSID)
Q X
;
DBCK(X) ;DOUBLE CHECK UFMSSUFC
;ENTERS WITH TRDATE AND X = UFMSSUFC
N Z
S Z=$$GETTRDT^BARUFEXU(TPBDUZ2,TPBIEN)
I X=Z Q X ;OK
I X'=Z D
.W !,"WRONG SETTING FOR UFMS APPLY TO "_X
.W !,"FOR ",TRDATE," RESET TO CORRECT "_Z
Q Z
;EOR - IHS/DIT/CPC 1.8*28
BARUFEX1 ; IHS/SD/TPF - MAIN EXTRACT RTN FOR UFMS (CONTINUED FROM BARUFEX) ; 10/31/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**7,9,16,19,20,23,28**;OCT 26,2005;Build 92
+2 ;NEW ROUTINE -- to meet SAC size requirements ;MRS:BAR*1.8*7
+3 ;Heavily modified to prevent duplicate records ;MRS:BAR*1.8*7 IM30562
+4 ;New functionality; only enters from single PULLSESS EP ;MRS:BAR*1.8*7 IM30562
+5 ;MAR 2013 P.OTTIS ADDED NEW VA billing
+6 ;IHS/SD/SDR 1.8*28 CR8349 HEAT293633 - Added code so ignore transactions won't transmit to UFMS.
+7 QUIT
+8 ;
GETDATA(TRDATE,RECORD,TOTAMT,UDUZ,SESSID) ;EP - PULL DATA FROM ONE TRANSACTION DATE/TIME
+1 ;Q:$D(^BARSESS(DUZ(2),"ST",TRDATE)) ;TRANSACTION HAS BEEN TRANSMITTED INDIVIDUALLY BAR*1.8*4
+2 ;DON'T SEND IF ALREADY SENT;MRS:BAR*1.8*7 IM30562
IF '$$OK(TRDATE,SESSID)
QUIT
+3 ;CAN'T LOCK THE TRANSACTION NODE
IF '$$LCKTR(TRDATE,SESSID)
QUIT
+4 DO DATA
+5 LOCK -^BARTR(DUZ(2),TRDATE,6)
+6 QUIT
+7 ;
DATA ;LOCAL ENTRY POINT
+1 WRITE "."
+2 KILL IENS,UFMSTRDT,ARCREDIT,ARDEBIT,ARBILL,UFMSBILL,TPBIEN,TPBLOC,BARACCT,TPBSTAT
+3 KILL ARCOL,ARCOLIN,ARASUFAC,ARCOLDT,TRANTYPE,UFMSTYPE,UFMSAMT,APPLYTO,BARAREA,PARNTLOC
+4 KILL PRELIV,PRELIVLM,REVERSAL,ARCRDEB,UFMSSUFC,BARREAS
+5 ;MRS:BAR*1.8*7 IM30562
SET PRELIVLM=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5)
+6 ;I DT>3070930 S PRELIVLM=3071001 I 1 ;ORIGINAL UFMS RELEASE DATE ;MRS:BAR*1.7 IM30562
+7 ;E S PRELIVLM=$P($$LAST^XPDUTL("IHS ACCOUNTS RECEIVABLE",1.8),U,2) ;FOR PRE 10-1-2007 RELEASE;MRS:BAR*1.7 IM30562
+8 SET IENS=TRDATE_","
+9 SET Y=TRDATE
XECUTE ^DD("DD")
SET UFMSTRDT=Y
+10 ;A/R TRANSACTIONS, BILL (A/R)
SET ARBILL=$$GET1^DIQ(90050.03,IENS,4,"E")
+11 ;SCREEN OUT TRANSACTIONS WITH NO A/R BILL
IF ARBILL=""
QUIT
+12 ;A/R TRANSACTIONS, CREDIT
SET ARCREDIT=$$GET1^DIQ(90050.03,IENS,2,"E")
+13 ;A/R TRANSACTIONS, DEBIT
SET ARDEBIT=$$GET1^DIQ(90050.03,IENS,3,"E")
+14 ;A/R TRANSACTIONS, CREDIT - DEBIT ;MRS:BAR*1.8*4
SET ARCRDEB=$$GET1^DIQ(90050.03,IENS,3.5,"E")
+15 ;DON'T SEND ZERO DOLLAR TX'S
IF ARCRDEB=0
QUIT
+16 ;A/R TRANSACTIONS, BILL (A/R) PTR
SET ARBILLIN=$$GET1^DIQ(90050.03,IENS,4,"I")
+17 ;A/R BILL, CURRENT BILL AMOUNT BAR*1.8*4 PER MEETING
SET CURBLAMT=$$GET1^DIQ(90050.01,ARBILLIN_",",15,"I")
+18 ;
+19 ;BAR*1.8*4 SCR56,58
+20 ;DON'T SEND NEGATIVE BALANCE TX
IF CURBLAMT<0
Begin DoDot:1
ERR1 DO ERR^BARUFEXU(1)
End DoDot:1
QUIT
+1 ;
+2 ;BAR*1.8*4 IM26555,IM26610 ET AL SCR80 4.1.1
+3 SET TPBDUZ2=$$GETDUZ2^BARUFEXU(ARBILLIN,UDUZ,$GET(SESSID),TRDATE,ARBILL)
+4 IF 'TPBDUZ2
QUIT
+5 ;A/R BILL, 3P DUZ(2) BAR*1.8*4 IM26555,IM26610 ET AL
SET TPBIEN=$$GETTPB^BARUFEXU(ARBILLIN)
+6 ;MRS:BAR*1.8*4 SCR80 4.1.1
IF 'TPBIEN
QUIT
+7 ;CHECK FOR SATELITE MRS:BAR*1.8*4 SCR80 4.1.1
IF '$$IHS^BARUFUT(TPBDUZ2)
Begin DoDot:1
+8 ;;;I '$$IHSERA^BARUFUT(TPBDUZ2) D Q ;P.OTT CHECK FOR SATELITE MRS:BAR*1.8*4 SCR80 4.1.1
+9 WRITE !,"NON-IHS FACILITY BILL -- TRANSACTION NOT SENT FOR ",ARBILL
End DoDot:1
QUIT
+10 ;
+11 ;A/R BILL, A/R BILLING SITE/ASUFAC BAR*1.8*4 ITEM 3 SCR58
SET BILASUFA=$PIECE($$GET1^DIQ(90050.01,ARBILLIN_",",9,"I"),"-")
+12 ;
+13 ;CHECK EXCLUSION TABLE (BAR v1.8 patch 3 SCR2 UFMS)
+14 ;IF 0 ITS IN THE EXCLUSION TABLE
+15 ;IF -1 THE API CAN'T FIND THE 3P BILL AND THE A/R BILL IS PROBABLY A DUPLICATE
+16 IF $$BILL^ABMUEAPI(TPBDUZ2,TPBIEN)<1
Begin DoDot:1
+17 WRITE !,"3P EXCLUDED BILL -- TRANSACTION NOT SENT FOR ",ARBILL
End DoDot:1
QUIT
+18 ;
+19 ;A/R BILL, A/R ACCOUNT
SET BARACCT=$$GETBACC^BARUFEXU(ARBILLIN)
+20 ;MRS:BAR*1.8*4
IF 'BARACCT
QUIT
+21 ;A/R BILL, PARENT LOCATION
SET PARNTLOC=$$GETPLOC^BARUFEXU(ARBILLIN)
+22 ;MRS:BAR*1.8*4
IF 'PARNTLOC
QUIT
+23 ;A/R TRANSACTIONS, COLLECTION ITEM
SET ARCOLITM=$$GET1^DIQ(90050.03,IENS,15,"E")
+24 ;A/R TRANSACTIONS, A/R COLLECTION BATCH
SET ARCOLB=$$GET1^DIQ(90050.03,IENS,14,"E")
+25 ;A/R TRANSACTIONS, A/R COLLECTION BATCH PTR
SET ARCOLIN=$$GET1^DIQ(90050.03,IENS,14,"I")
+26 ;
+27 ;LOCATION, AREA PTR
SET BARAREA=$$GET1^DIQ(9999999.06,PARNTLOC_",",.04,"I")
+28 ;
+29 SET D0=BARACCT
+30 ;GET 'VIP INSURER TYPE' CODE
SET BARITYP=$$VALI^BARVPM(8)
+31 ;EXCLUDE 'INDIAN' OR 'THIRD PARTY BILLING' PER MEETING OF 5/4/2007
IF BARITYP="I"!(BARITYP="T")
QUIT
+32 ;
+33 ; Check 3P transmitted date
+34 SET UFMSSUFC=$$GETTRDT^BARUFEXU(TPBDUZ2,TPBIEN)
+35 ;Not transmitted from 3P
IF UFMSSUFC=""
QUIT
+36 ;
+37 ;REGULAR OLD LOGIC FOR 'APPLY TO' OR ASUFACASUFAC3PIEN STRING
+38 ;S UFMSSUFC=$$ASUFAC^BARUFUT1(DUZ(2),TRDATE)
+39 ;
+40 ;A/R COLLECTION BATCH, NAME
SET ARCOLB=$$GET1^DIQ(90051.01,ARCOLIN_",",.01,"I")
+41 ;A/R COLLECTION BATCH, OPENED DATE/TIME
SET ARCOLDT=$$GET1^DIQ(90051.01,ARCOLIN_",",4,"I")
+42 ;A/R COLLECTION BATCH, TDN/DATE ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
SET TDNDATE=$$GET1^DIQ(90051.01,ARCOLIN_",",30,"I")
+43 SET TDNDATE=$$FMTE^XLFDT($PIECE(TDNDATE,"@"),"5DZ")
+44 SET ARCOLDT=$$FMTE^XLFDT($PIECE(ARCOLDT,"@"),"5DZ")
+45 SET UFMSTRDT=$$FMTE^XLFDT($PIECE(TRDATE,"."),"5DZ")
+46 ;A/R TRANSACTIONS, TRANSACTION TYPE
SET TRANTYPE=$$GET1^DIQ(90050.03,IENS,101,"E")
+47 ;A/R TRANSACTIONS, ADJUSTMENT CATEGORY
SET ADJCAT=$$GET1^DIQ(90050.03,IENS,102,"E")
+48 ;
+49 ;MAIN SCREEN FOR TRANSACTIONS TO PULL
+50 SET UFMSAMT=ARCREDIT-ARDEBIT
+51 IF TRANTYPE="PAYMENT"
Begin DoDot:1
+52 SET UFMSTYPE="R"
+53 ;keep sign
SET UFMSSIGN=$SELECT(UFMSAMT>0!(UFMSAMT=0):"+",1:"-")
End DoDot:1
IF 1
+54 ; IHS/SD/PKD 1.8*19 9/23/10 Include Status Change (send to Collection=993) transactions
+55 ; E I TRANTYPE[("ADJUST")!(TRANTYPE[("REFUND") D I 1
+56 IF '$TEST
IF TRANTYPE[("ADJUST")!(TRANTYPE[("REFUND")!(TRANTYPE[("STATUS CHANGE"))!(TRANTYPE["993"))
Begin DoDot:1
+57 SET UFMSTYPE="A"
+58 ;reverse the sign on "A" records
SET UFMSSIGN=$SELECT(UFMSAMT>0!(UFMSAMT=0):"-",1:"+")
End DoDot:1
IF 1
+59 IF '$TEST
QUIT
+60 ;Modifications to fix Transmission/Approvals dates ;and UFMSSUFC MRS:BAR*1.8*4
+61 ;NEW CODE FOR REVERSALS ;MRS:BAR*1.8*4
+62 ;CHECK REVERSAL DATES AND FIX IF POSSIBLE
+63 SET BARRIPAC=$$REVERSAL^BARUFEX3()
+64 IF 'ARBILL
QUIT
+65 ;
+66 ;MOVED IPAC SET TO HERE BECAUSE REVERSAL PROCESS CAN CHANGE IPAC ;MRS:BAR*1.8*4
+67 ;S IPAC=$$GET1^DIQ(90051.1101,ARCOLITM_","_ARCOLIN_",",20,"I") ;A/R COLLECTION BATCH, TREASURY DEPOSIT SCHEDULE NUMBER/IPAC ;MRS:BAR*1.8*9
+68 ;A/R COLLECTION BATCH, TREASURY DEPOSIT SCHEDULE NUMBER/IPAC ;MRS:BAR*1.8*9
SET IPAC=$$GET1^DIQ(90051.1101,ARCOLITM_","_ARCOLIN_",",20)
+69 ;
+70 ;I IPAC["NONPAY"!(BARRIPAC["NONPAY") D Q ;DON'T SEND NONPAYMENTS ;bar*1.8*4 SDR
+71 ;DON'T SEND NONPAYMENTS ;bar*1.8*4 SDR
IF UFMSTYPE="R"
IF (IPAC["NONPAY")!(BARRIPAC["NONPAY")
Begin DoDot:1
ERR2 DO ERR^BARUFEXU(2)
End DoDot:1
QUIT
+1 ;
+2 ;FUNCTION ABOVE TAKES CARE OF NULL
IF IPAC=""
SET IPAC="PRE-UFMS_COLLECTIONS"
+3 ;per UFMS THE FIELD WILL BE BLANK FOR ADJUSTMENTS
IF UFMSTYPE="A"
SET IPAC=""
+4 ;Re-set schedule number with original ipac
IF BARRIPAC]""
SET IPAC=BARRIPAC
+5 ;
CONT ; ALL QUIT CONDITIONS HAVE BEEN MET
+1 ; LET'S UPDATE THE 'APPLY TO' FIELD IN THE SESSION LOG FILE
+2 ;
+3 ;KILL THE 'NOT SENT FLAG'
+4 IF $$GET1^DIQ(90057.110102,TRDATE_","_SESSID_","_UDUZ_",",.06,"I")
Begin DoDot:1
+5 KILL DIR,DIE,DIC,DA,DR
+6 SET DA(2)=UDUZ
+7 SET DA(1)=SESSID
+8 SET DA=TRDATE
+9 SET DIE="^BARSESS(DUZ(2),"_DA(2)_",11,"_DA(1)_",2,"
+10 SET DR=".06///@;.07////^S X=1;.08///^S X=$G(BARFILE)"
+11 DO ^DIE
+12 KILL DIR,DIE,DIC,DA,DR
+13 ;MRS:BAR*1.8*4
WRITE !!,"TRANSACTION "_TRDATE_" "_ARBILL
+14 ;MRS:BAR*1.8*4
WRITE !,"HAS BEEN SENT THAT PREVIOUSLY WAS NOT SENT"
End DoDot:1
+15 ;
+16 SET REVERSAL=$PIECE($$GET1^DIQ(90050.03,TRDATE_",",110,"I"),".")
+17 ;I REVERSAL='0,(REVERSAL]"") D ;MRS:BAR*1.8*9
+18 ;MRS:BAR*1.8*9
IF REVERSAL'=0
IF (REVERSAL]"")
Begin DoDot:1
+19 SET UFMSTRDT=$$FMTE^XLFDT(REVERSAL,"5DZ")
End DoDot:1
+20 ;LETS PAD THE FIELDS
+21 ;A/R COLLECTION BATCH NAME
SET UFMSCOLB=$$FILLSTR^BARUFUT1(ARCOLB,149,"R"," ")
+22 ;A/R TRANSACTION DATE MM/DD/YYYY
SET UFMSTRDT=$$FILLSTR^BARUFUT1(UFMSTRDT,10,"R"," ")
+23 ;TRANSACTION AMT W/O SIGN
SET UFMSAMT=$$FILLDOL^BARUFUT1(UFMSAMT,20,"R",0)
+24 ;DOUBLE CHECK/RESET IF NECESSARY
SET UFMSSUFC=$$DBCK(UFMSSUFC)
+25 ;S UFMSSUFC=$$FILLSTR^BARUFUT1(UFMSSUFC,20,"L"," ") ;ASUFACAUSFAC3PIEN ;MRS:BAR*1.8*9 HEAT529
+26 ;ASUFACAUSFAC3PIEN ;MRS:BAR*1.8*9 HEAT529
SET UFMSSUFC=$$FILLSTR^BARUFUT1(UFMSSUFC,40,"L"," ")
+27 ;SCHEDULE NUMBER
SET UFMSIPAC=$$FILLSTR^BARUFUT1(IPAC,20,"R"," ")
+28 ;NOT POPULATED YET
SET RPMSADJ=$$FILLSTR^BARUFUT1("",50,"R"," ")
+29 ;NOT POPULATED YET
SET RPMSAMT=$$FILLSTR^BARUFUT1("",30,"R"," ")
+30 ;COLLECTION BATCH DATE ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
SET UFMSCODT=$$FILLSTR^BARUFUT1(ARCOLDT,10,"R"," ")
+31 ;TDN/DATE ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
SET TDNDATE=$$FILLSTR^BARUFUT1(TDNDATE,10,"R"," ")
+32 ;BEGIN BAR*1.8*4 ITEM 3 SCR58
+33 SET UNIQUEID=$$FILLSTR^BARUFUT1(TRDATE,14,"L",0)
+34 ;IF PRE-LIVE 'APPLY TO' THEN GET UNIQUE ID DIFFERENTLY
IF $EXTRACT($TRANSLATE(UFMSSUFC," "))?.A
Begin DoDot:1
+35 SET PSUFAC=$$GETSUFAC^BARUFUT1()
+36 IF PSUFAC=""
SET PSUFAC="000000"
+37 IF BILASUFA=""
SET BILASUFA="000000"
+38 ;ADRIAN APPROVED THE USE OF BILASUFA
SET PRESUFAC=PSUFAC_BILASUFA_TPBIEN
+39 ;S PRESUFAC=$$FILLSTR^BARUFUT1(PRESUFAC,20,"L"," ") ;MRS:BAR*1.8*9 HEAT529
+40 ;MRS:BAR*1.8*9 HEAT529
SET PRESUFAC=$$FILLSTR^BARUFUT1(PRESUFAC,40,"L"," ")
+41 SET UNIQUEID=UNIQUEID_"|"_$TRANSLATE(PRESUFAC," ")
End DoDot:1
IF 1
+42 IF '$TEST
SET UNIQUEID=UNIQUEID_"|"_$TRANSLATE(UFMSSUFC," ")
+43 SET UNIQUEID=$$FILLSTR^BARUFUT1(UNIQUEID,150,"L"," ")
+44 ;END
+45 ;
+46 ;BEGIN BAR*1.8*4 ITEM 3 SCR58
+47 ;AND MRS:BAR*1.8*7 IM30562
SET ;EP -
+1 ;S ^BARUFEX($J,RECORD)=$G(UFMSTYPE)_$G(UFMSCOLB)_$G(UFMSTRDT)_$G(UFMSSIGN)_$G(UFMSAMT)_$G(UFMSSUFC)_$G(UFMSIPAC)_$G(RPMSADJ)_$G(RPMSAMT)_$G(UNIQUEID)
+2 ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
IF UFMSTYPE="R"
SET ^BARUFEX($JOB,RECORD)=$GET(UFMSTYPE)_$GET(UFMSCOLB)_$GET(UFMSTRDT)_$GET(UFMSSIGN)_$GET(UFMSAMT)_$GET(UFMSSUFC)_$GET(UFMSIPAC)_$GET(RPMSADJ)_$GET(RPMSAMT)_$GET(UNIQUEID)_$GET(TDNDATE)_$GET(UFMSCODT)
+3 ;BAR*1.8*16 IHS/SD/TPF 1/27/2010
IF '$TEST
SET ^BARUFEX($JOB,RECORD)=$GET(UFMSTYPE)_$GET(UFMSCOLB)_$GET(UFMSTRDT)_$GET(UFMSSIGN)_$GET(UFMSAMT)_$GET(UFMSSUFC)_$GET(UFMSIPAC)_$GET(RPMSADJ)_$GET(RPMSAMT)_$GET(UNIQUEID)
+4 ;UDATE SESSION FILE
DO UPSTR(TRDATE,BARNOW,DUZ,($PIECE(UNIQUEID,"|",2)))
+5 ;D UPTR(TRDATE,BARNOW,BARFILE,($P(UNIQUEID,"|",2)),DUZ) ;UPDATE TRANSACTION FILE ;MRS:BAR*1.8*9 IM30945
+6 ;UPDATE TRANSACTION FILE ;MRS:BAR*1.8*9 IM30945
DO UPTR(TRDATE,SESSID,BARFILE,($PIECE(UNIQUEID,"|",2)),DUZ)
+7 ;END
+8 ;IHS/SD/PKD 3/2/11 1.8*20
+9 ; Check to set ^BARSESS(DUZ(2),USER,11,SESSID,21,n,0)
+10 ; Call same code as Session being exported for the 1st time
+11 ; Update with UFMS FILENAME if not already there. Was missing for "NS" TRX's
+12 ; UDUZ - Original Cashier
+13 DO SET^BARUFUT0(UDUZ,SESSID)
+14 ; END 1.8*20
+15 SET RECORD=RECORD+1
+16 SET UFMSAMT=UFMSSIGN_UFMSAMT
+17 SET TOTAMT=TOTAMT+UFMSAMT
+18 QUIT
+19 ;
UPSTR(A,D,Z,ID) ;UPDATE 'APPLY TO' AND THE TRANSMITTED? FIELD IN THE SESSION LOG FILE ;MRS:BAR*1.8*7 IM30562
+1 ;PUT INTO EFFECT FOR ALL TRANSMISSION WITH PATCH 7
+2 ;ENTERS WITH A = TRDATE
+3 ; D = TRANSMISSION DATE
+4 ; Z = DUZ OF CASHIER
+5 ; ID = APPLY TO/UNIQUEID
+6 KILL DIR,DIC,DIE,DR,DA
+7 SET DA(2)=UDUZ
+8 SET DA(1)=SESSID
+9 SET DA=A
+10 SET DR=".02///^S X=1"
+11 SET DR=DR_";.03////"_Z
+12 SET DR=DR_";.04////"_D
+13 SET DR=DR_";.05////"_$TRANSLATE(ID," ")
+14 SET DIE="^BARSESS(DUZ(2),"_DA(2)_",11,"_DA(1)_",2,"
+15 DO ^DIE
+16 QUIT
+17 ;
UPTR(A,D,F,ID,Z) ;UPDATE THE NEW FIELDS IN A/R TRANSACTION FILE ;MRS:BAR*1.8*7 IM30562
+1 ;PUT INTO EFFECT WITH PATCH 7
+2 ;ENTERS WITH A = TRDATE
+3 ; D = DATE TRANSMITTED (CAN BE EARLIER THAN TODAY)--CHANGED TO: ;MRS:BAR*1.8*9 IM30945
+4 ; SESSION ID DATE/TIME ;MRS:BAR*1.8*9 IM30945
+5 ; F = UFMS FILE NAME (CAN BE NULL)
+6 ; ID = APPLY TO OR UNIQUEID
+7 ; Z = DUZ OF CASHIER
+8 KILL DIR,DIC,DIE,DR,DA
+9 SET DA=A
+10 ;UFMS FILE NAME
SET DR="601////"_F
+11 SET DR=DR_";602////"_D
+12 SET DR=DR_";603////"_Z
+13 ;APPLY TO
SET DR=DR_";604////"_$TRANSLATE(ID," ")
+14 SET DIE="^BARTR(DUZ(2),"
+15 DO ^DIE
+16 QUIT
+17 ;
OK(A,B) ;CHECK A/R TRANSACTION AND SESSION FILES FOR TRANSMISSION DATES;MRS:BAR*1.8*7 IM30562
+1 ;PUT INTO EFFECT WITH PATCH 7
+2 ;ENTERS WITH A = TRDATE
+3 ; B = SESSID
+4 NEW OK,TR0,S0,TRFILE,TRDT,TRDUZ,TRID,SDUZ,SDT,SID,SFILE
+5 SET OK=0
+6 ;GET TRANSACTION TRANSMITTED INFO IF THERE
SET TR0=$GET(^BARTR(DUZ(2),A,6))
+7 SET S0=$GET(^BARSESS(DUZ(2),UDUZ,11,B,2,A,0))
+8 ;NOT TRANSMITTED, OK TO GO
IF $GET(TR0)=""
IF $GET(S0)=""
QUIT 1
+9 ;SESSION DATE/TIME FROM TRANSACTION FILE
SET TRDT=$PIECE(TR0,U,2)
+10 ;DATE TRANSMITTED FROM SESSION FILE
SET SDT=$PIECE(S0,U,4)
+11 ;ignored trans - don't send ;bar*1.8*28 IHS/SD/SDR CR8349 HEAT293633
IF $PIECE($GET(^BARTR(DUZ(2),A,1)),U,12)="I"
QUIT 0
+12 ;NOT TRANSMITTED, OK TO GO
IF TRDT=""
IF SDT=""
QUIT 1
+13 SET TRFILE=$PIECE(TR0,U)
+14 SET TRDUZ=$PIECE(TR0,U,3)
+15 SET TRID=$PIECE(TR0,U,4)
+16 ;TRANSMITTED BY
SET SDUZ=$PIECE(S0,U,3)
+17 ;APPLY TO/UNIQUEID
SET SID=$PIECE(S0,U,5)
+18 ;ALREADY SENT AND DATA IN BOTH FILES
IF TRDT]""&(SDT]"")
DO MSG(27,TRDT,TRDATE)
QUIT 0
+19 SET SFILE=""
+20 ;UFMS FILE NAME
IF SDUZ]""
SET SFILE=$PIECE($GET(^BARSESS(DUZ(2),UDUZ,11,B,21,A,0)),U,2)
+21 ;SET A/R TRANSACTION FILE W/INFO FROM SESSION FIELDS
IF SDT]""&(TRDT="")
DO UPTR(A,B,SFILE,SDUZ,SID)
DO MSG(27,SDT,A)
QUIT 0
+22 ;SET SESSION TRANSMITTED? FIELDS
IF SDT=""&(TRDT]"")
DO UPSTR(A,TRDT,TRDUZ,TRID)
DO MSG(27,TRDT,A)
QUIT 0
+23 ;OK TO TRANSMIT
QUIT 1
+24 ;
MSG(X,Y,Z) ;WRITE ERROR MESSAGE MRS:BAR*1.8*9 IM30945
+1 WRITE !,$PIECE($GET(^BARUFERR(X,0)),U,5)
+2 WRITE " Date:"_Y_" for Transaction/Session: ",Z
+3 QUIT
+4 ;
LCKTR(TRDATE,SESSID) ;EP; LOCK A/R SESSION FILE
+1 ;
+2 NEW X
+3 FOR I=1:1:5
LOCK +^BARSESS(DUZ(2),UDUZ,11,SESSID):2
SET X=$TEST
IF X
QUIT
ERR26 IF 'X
WRITE !,"NOT PROCESSING SESSION "
Begin DoDot:1
+1 DO MSG(26,$GET(TRDATE),SESSID)
End DoDot:1
+2 QUIT X
+3 ;
DBCK(X) ;DOUBLE CHECK UFMSSUFC
+1 ;ENTERS WITH TRDATE AND X = UFMSSUFC
+2 NEW Z
+3 SET Z=$$GETTRDT^BARUFEXU(TPBDUZ2,TPBIEN)
+4 ;OK
IF X=Z
QUIT X
+5 IF X'=Z
Begin DoDot:1
+6 WRITE !,"WRONG SETTING FOR UFMS APPLY TO "_X
+7 WRITE !,"FOR ",TRDATE," RESET TO CORRECT "_Z
End DoDot:1
+8 QUIT Z
+9 ;EOR - IHS/DIT/CPC 1.8*28
